'From Squeak3.0 of 4 February 2001 [latest update: #3414] on 4 February 2001 at 1:28:53 am'!
SoundCodec subclass: #ADPCMCodec
	instanceVariableNames: 'predicted index deltaSignMask deltaValueMask deltaValueHighBit frameSizeMask currentByte bitPosition byteIndex encodedBytes samples rightSamples sampleIndex bitsPerSample stepSizeTable indexTable '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!ADPCMCodec commentStamp: '<historical>' prior: 0!
This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the alorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives.

This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.)
!


!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 16:24'!
nextBits: n
	"Answer the next n bits of my bit stream as an unsigned integer."

	| result remaining shift |
	self inline: true.

	result _ 0.
	remaining _ n.
	[true] whileTrue: [
		shift _ remaining - bitPosition.
		result _ result + (currentByte bitShift: shift).
		shift > 0
			ifTrue: [  "consumed currentByte buffer; fetch next byte"
				remaining _ remaining - bitPosition.			
				currentByte _ (encodedBytes at: (byteIndex _ byteIndex + 1)).
				bitPosition _ 8]
			ifFalse: [  "still some bits left in currentByte buffer"
				bitPosition _ bitPosition - remaining.
				"mask out the consumed bits:"
				currentByte _ currentByte bitAnd: (255 bitShift: (bitPosition - 8)).
				^ result]].
! !

!ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 20:21'!
nextBits: n put: anInteger
	"Write the next n bits to my bit stream."

	| buf bufBits bitsAvailable shift |
	self inline: true.

	buf _ anInteger.
	bufBits _ n.
	[true] whileTrue: [
		bitsAvailable _ 8 - bitPosition.
		shift _ bitsAvailable - bufBits.  "either left or right shift"
		"append high bits of buf to end of currentByte:"
		currentByte _ currentByte + (buf bitShift: shift).
		shift < 0
			ifTrue: [  "currentByte buffer filled; output it"
				encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte.
				bitPosition _ 0.
				currentByte _ 0.
				"clear saved high bits of buf:"
				buf _ buf bitAnd: (1 bitShift: 0 - shift) - 1.
				bufBits _ bufBits - bitsAvailable]
			ifFalse: [  "still some bits available in currentByte buffer"
				bitPosition _ bitPosition + bufBits.
				^ self]].
! !


!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/27/1999 11:21'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data."
	"Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes."

	^ bitsPerSample
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 7/2/1999 13:29'!
compressAndDecompress: aSound
	"Compress and decompress the given sound. Overridden to use same bits per sample for both compressing and decompressing."

	| compressed decoder |
	compressed _ self compressSound: aSound.
	decoder _ self class new
		initializeForBitsPerSample: bitsPerSample
		samplesPerFrame: 0.
	^ decoder decompressSound: compressed

! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:37'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	encodedBytes _ srcByteArray.
	byteIndex _ srcIndex - 1.
	bitPosition _ 0.
	currentByte _ 0.
	samples _ dstSoundBuffer.
	sampleIndex _ dstIndex - 1.
	self privateDecodeMono: (frameCount * self samplesPerFrame).
	^ Array with: (byteIndex - (srcIndex - 1)) with: (sampleIndex - (dstIndex - 1))
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:28'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	samples _ srcSoundBuffer.
	sampleIndex _ srcIndex - 1.
	encodedBytes _ dstByteArray.
	byteIndex _ dstIndex - 1.
	bitPosition _ 0.
	currentByte _ 0.
	self privateEncodeMono: (frameCount * self samplesPerFrame).
	^ Array with: frameCount with: (byteIndex - (dstIndex - 1))
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'!
resetForMono
	"Reset my encoding and decoding state for mono."

	predicted _ 0.
	index _ 0.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'!
resetForStereo
	"Reset my encoding and decoding state for stereo."

	"keep state as SoundBuffers to allow fast access from primitive"
	predicted _ SoundBuffer new: 2.
	index _ SoundBuffer new: 2.
! !

!ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/27/1999 08:34'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	frameSizeMask > 0 ifTrue: [^ frameSizeMask + 1].
	^ 8  "frame size when there are no running headers"
! !


!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 06:26'!
decode: aByteArray bitsPerSample: bits

	^ self
		decode: aByteArray
		sampleCount: (aByteArray size * 8) // bits
		bitsPerSample: bits
		frameSize: 0
		stereo: false
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 15:57'!
decode: aByteArray sampleCount: count bitsPerSample: bits frameSize: frameSize stereo: stereoFlag

	self initializeForBitsPerSample: bits samplesPerFrame: frameSize.
	encodedBytes _ aByteArray.
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	stereoFlag
		ifTrue: [
			self resetForStereo.
			samples _ SoundBuffer newMonoSampleCount: count.
			rightSamples _ SoundBuffer newMonoSampleCount: count.
			sampleIndex _ 0.
			self privateDecodeStereo: count.
			^ Array with: samples with: rightSamples]
		ifFalse: [
			samples _ SoundBuffer newMonoSampleCount: count.
			sampleIndex _ 0.
			self privateDecodeMono: count.
			^ samples]
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/30/1999 08:56'!
decodeFlash: aByteArray sampleCount: sampleCount stereo: stereoFlag

	| bits |
	encodedBytes _ aByteArray.
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	bits _ 2 + (self nextBits: 2).  "bits per sample"
	self initializeForBitsPerSample: bits samplesPerFrame: 4096.
	stereoFlag
		ifTrue: [
			self resetForStereo.
			samples _ SoundBuffer newMonoSampleCount: sampleCount.
			rightSamples _ SoundBuffer newMonoSampleCount: sampleCount.
			sampleIndex _ 0.
			self privateDecodeStereo: sampleCount.
			^ Array with: samples with: rightSamples]
		ifFalse: [
			samples _ SoundBuffer newMonoSampleCount: sampleCount.
			sampleIndex _ 0.
			self privateDecodeMono: sampleCount.
			^ Array with: samples].
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 08:59'!
encode: aSoundBuffer bitsPerSample: bits

	^ self
		encodeLeft: aSoundBuffer
		right: nil
		bitsPerSample: bits
		frameSize: 0
		forFlash: false
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 08:58'!
encodeFlashLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits

	^ self
		encodeLeft: leftSoundBuffer
		right: rightSoundBuffer
		bitsPerSample: bits
		frameSize: 4096
		forFlash: true
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 09:17'!
encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag

	| stereoFlag sampleCount sampleBitCount bitCount |
	self initializeForBitsPerSample: bits samplesPerFrame: frameSize.
	stereoFlag _ rightSoundBuffer notNil.
	sampleCount _ leftSoundBuffer monoSampleCount.
	stereoFlag
		ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)]
		ifFalse: [sampleBitCount _ sampleCount * bitsPerSample].
	bitCount _ sampleBitCount +
		(self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag).

	encodedBytes _ ByteArray new: (bitCount / 8) ceiling.
	byteIndex _ 0.
	bitPosition _ 0.
	currentByte _ 0.
	flashFlag ifTrue: [self nextBits: 2 put: bits - 2].
	stereoFlag
		ifTrue: [
			samples _ Array with: leftSoundBuffer with: rightSoundBuffer.
			sampleIndex _ Array with: 0 with: 0.
			self privateEncodeStereo: sampleCount]
		ifFalse: [
			samples _ leftSoundBuffer.
			sampleIndex _ 0.
			self privateEncodeMono: sampleCount].

	^ encodedBytes
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/27/1999 12:14'!
headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag
	"Answer the number of extra header bits required for the given number of samples. This will be zero if I am not using frame headers."

	| frameCount bitsPerHeader |
	frameSizeMask = 0 ifTrue: [^ 0].
	frameCount _ (sampleCount / self samplesPerFrame) ceiling.
	bitsPerHeader _ 16 + 6.
	stereoFlag ifTrue: [bitsPerHeader _ 2 * bitsPerHeader].
	^ frameCount * bitsPerHeader
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 16:08'!
indexForDeltaFrom: thisSample to: nextSample
	"Answer the best index to use for the difference between the given samples."
	"Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63."
	"Note: Since there does not appear to be any documentation of how Flash acutally computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder."

	| diff bestIndex |
	self inline: true.

	diff _ nextSample - thisSample.
	diff < 0 ifTrue: [diff _ 0 - diff].
	bestIndex _ 63.
	1 to: 62 do: [:j |
		bestIndex = 63 ifTrue: [
			(stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]].
	^ bestIndex
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 20:48'!
initializeForBitsPerSample: sampleBits samplesPerFrame: frameSize

	self resetForMono.
	stepSizeTable _ #(7 8 9 10 11 12 13 14 16 17 19 21 23 25 28 31 34 37 41 45 50 55 60 66 73 80 88 97 107 118 130 143 157 173 190 209 230 253 279 307 337 371 408 449 494 544 598 658 724 796 876 963 1060 1166 1282 1411 1552 1707 1878 2066 2272 2499 2749 3024 3327 3660 4026 4428 4871 5358 5894 6484 7132 7845 8630 9493 10442 11487 12635 13899 15289 16818 18500 20350 22385 24623 27086 29794 32767).

	indexTable _ nil.
	sampleBits = 2 ifTrue: [
		indexTable _ #(-1 2)].
	sampleBits = 3 ifTrue: [
		indexTable _ #(-1 -1 2 4)].
	sampleBits = 4 ifTrue: [
		indexTable _ #(-1 -1 -1 -1 2 4 6 8)].
	sampleBits = 5 ifTrue: [
		indexTable _ #(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16)].
	indexTable ifNil: [self error: 'unimplemented bits/sample'].

	bitsPerSample _ sampleBits.
	deltaSignMask _ 1 bitShift: bitsPerSample - 1.
	deltaValueMask _ deltaSignMask - 1.
	deltaValueHighBit _ deltaSignMask / 2.

	frameSize <= 1
		ifTrue: [frameSizeMask _ 0]
		ifFalse: [
			(frameSize = (1 bitShift: frameSize highBit - 1))
				ifFalse: [self error: 'frameSize must be a power of two'].
			frameSizeMask _ frameSize - 1].

	"keep as SoundBuffer to allow fast access from primitive"
	indexTable _ SoundBuffer fromArray: indexTable.
	stepSizeTable _ SoundBuffer fromArray: stepSizeTable.
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'ar 2/3/2001 15:50'!
privateDecodeMono: count

	| delta step predictedDelta bit |
	<primitive: 'primitiveDecodeMono' module: 'ADPCMPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.

	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1
			ifTrue: [  "start of frame; read frame header"
				predicted _ self nextBits: 16.
				predicted > 32767 ifTrue: [predicted _ predicted - 65536].
				index _ self nextBits: 6.
				samples at: (sampleIndex _ sampleIndex + 1) put: predicted]
			ifFalse: [
				delta _ self nextBits: bitsPerSample.
				step _ stepSizeTable at: index + 1.
				predictedDelta _ 0.
				bit _ deltaValueHighBit.
				[bit > 0] whileTrue: [
					(delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step].
					step _ step bitShift: -1.
					bit _ bit bitShift: -1].
				predictedDelta _ predictedDelta + step.

				(delta bitAnd: deltaSignMask) > 0
					ifTrue: [predicted _ predicted - predictedDelta]
					ifFalse: [predicted _ predicted + predictedDelta].
				predicted > 32767
					ifTrue: [predicted _ 32767]
					ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]].

				index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1).
				index < 0
					ifTrue: [index _ 0]
					ifFalse: [index > 88 ifTrue: [index _ 88]].

				samples at: (sampleIndex _ sampleIndex + 1) put: predicted]].
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'ar 2/3/2001 15:50'!
privateDecodeStereo: count

	| predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight
	 stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit |

	<primitive: 'primitiveDecodeStereo' module: 'ADPCMPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.
	self var: #rightSamples declareC: 'short int *rightSamples'.
	self var: #predicted declareC: 'short int *predicted'.
	self var: #index declareC: 'short int *index'.

	"make local copies of decoder state variables"
	predictedLeft _ predicted at: 1.
	predictedRight _ predicted at: 2.
	indexLeft _ index at: 1.
	indexRight _ index at: 2.

	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1
			ifTrue: [  "start of frame; read frame header"
				predictedLeft _ self nextBits: 16.
				indexLeft _ self nextBits: 6.
				predictedRight _ self nextBits: 16.
				indexRight _ self nextBits: 6.
				predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536].
				predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536].
				samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft.
				rightSamples at: sampleIndex put: predictedRight]
			ifFalse: [
				deltaLeft _ self nextBits: bitsPerSample.
				deltaRight _ self nextBits: bitsPerSample.
				stepLeft _ stepSizeTable at: indexLeft + 1.
				stepRight _ stepSizeTable at: indexRight + 1.
				predictedDeltaLeft _ predictedDeltaRight _ 0.
				bit _ deltaValueHighBit.
				[bit > 0] whileTrue: [
					(deltaLeft bitAnd: bit) > 0 ifTrue: [
						predictedDeltaLeft _ predictedDeltaLeft + stepLeft].
					(deltaRight bitAnd: bit) > 0 ifTrue: [
						predictedDeltaRight _ predictedDeltaRight + stepRight].
					stepLeft _ stepLeft bitShift: -1.
					stepRight _ stepRight bitShift: -1.
					bit _ bit bitShift: -1].
				predictedDeltaLeft _ predictedDeltaLeft + stepLeft.
				predictedDeltaRight _ predictedDeltaRight + stepRight.

				(deltaLeft bitAnd: deltaSignMask) > 0
					ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft]
					ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft].
				(deltaRight bitAnd: deltaSignMask) > 0
					ifTrue: [predictedRight _ predictedRight - predictedDeltaRight]
					ifFalse: [predictedRight _ predictedRight + predictedDeltaRight].
				predictedLeft > 32767
					ifTrue: [predictedLeft _ 32767]
					ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]].
				predictedRight > 32767
					ifTrue: [predictedRight _ 32767]
					ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]].

				indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1).
				indexLeft < 0
					ifTrue: [indexLeft _ 0]
					ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]].
				indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1).
				indexRight < 0
					ifTrue: [indexRight _ 0]
					ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]].

				samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft.
				rightSamples at: sampleIndex put: predictedRight]].

	"save local copies of decoder state variables"
	predicted at: 1 put: predictedLeft.
	predicted at: 2 put: predictedRight.
	index at: 1 put: indexLeft.
	index at: 2 put: indexRight.
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'ar 2/3/2001 15:51'!
privateEncodeMono: count

	| step sign diff delta predictedDelta bit p |
	<primitive: 'primitiveEncodeMono' module: 'ADPCMPlugin'>
	self var: #stepSizeTable declareC: 'short int *stepSizeTable'.
	self var: #indexTable declareC: 'short int *indexTable'.
	self var: #samples declareC: 'short int *samples'.
	self var: #encodedBytes declareC: 'unsigned char *encodedBytes'.

	step _ stepSizeTable at: 1.
	1 to: count do: [:i |
		(i bitAnd: frameSizeMask) = 1 ifTrue: [
			predicted _ samples at: (sampleIndex _ sampleIndex + 1).
			(p _ predicted) < 0 ifTrue: [p _ p + 65536].
			self nextBits: 16 put: p.
			i < count ifTrue: [
				index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)].
			self nextBits: 6 put: index.
		] ifFalse: [
			"compute sign and magnitude of difference from the predicted sample"
			sign _ 0.
			diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted.
			diff < 0 ifTrue: [
				sign _ deltaSignMask.
				diff _ 0 - diff].

			"Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates:
				delta _ (4 * diff) / step.
				predictedDelta _ ((delta + 0.5) * step) / 4;
			but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines."
			delta _ 0.
			predictedDelta _ 0.
			bit _ deltaValueHighBit.
			[bit > 0] whileTrue: [
				diff >= step ifTrue: [
					delta _ delta + bit.
					predictedDelta _ predictedDelta + step.
					diff _ diff - step].
				step _ step bitShift: -1.
				bit _ bit bitShift: -1].
			predictedDelta _ predictedDelta + step.

			"compute and clamp new prediction"
			sign > 0
				ifTrue: [predicted _ predicted - predictedDelta]
				ifFalse: [predicted _ predicted + predictedDelta].
			predicted > 32767
				ifTrue: [predicted _ 32767]
				ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]].

			"compute new index and step values"
			index _ index + (indexTable at: delta + 1).
			index < 0
				ifTrue: [index _ 0]
				ifFalse: [index > 88 ifTrue: [index _ 88]].
			step _ stepSizeTable at: index + 1.

			"output encoded, signed delta"
			self nextBits: bitsPerSample put: (sign bitOr: delta)]].

	bitPosition > 0 ifTrue: [  "flush the last output byte, if necessary"
		encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte].
! !

!ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'ar 2/3/2001 15:51'!
privateEncodeStereo: count

	<primitive: 'primitiveEncodeStereo' module: 'ADPCMPlugin'>
	"not yet implemented"
	self inline: false.
	self success: false.! !

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

ADPCMCodec class
	instanceVariableNames: ''!

!ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 3/27/1999 11:15'!
new

	^ super new
		initializeForBitsPerSample: 4
		samplesPerFrame: 0.
! !


!ADPCMCodec class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:50'!
translatedPrimitives
	"Answer a string containing the translated C code for my primitives."
	"Note: This code currently must be hand-edited to remove several methods that are inlined (thus not needed) but not pruned out by the ST-to-C translator."

	^#(
		(ADPCMCodec privateDecodeMono:)
		(ADPCMCodec privateDecodeStereo:)
		(ADPCMCodec privateEncodeMono:)
		(ADPCMCodec privateEncodeStereo:)
		(ADPCMCodec indexForDeltaFrom:to:)
		(ADPCMCodec nextBits:)
		(ADPCMCodec nextBits:put:))
! !
InterpreterPlugin subclass: #ADPCMCodecPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

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

ADPCMCodecPlugin class
	instanceVariableNames: ''!

!ADPCMCodecPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 18:34'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"ADPCMCodecPlugin translateLocally"
	| code |
	cg addClass: InterpreterPlugin.
	InterpreterPlugin declareCVarsIn: cg.
	cg addMethodsForPrimitives: ADPCMCodec translatedPrimitives.
	"now remove a few which will be inlined but not pruned"
	cg pruneMethods: #(indexForDeltaFrom:to: nextBits: nextBits:put:).
	code _ cg generateCodeStringForPrimitives.
	self storeString: code onFileNamed: fullName.! !
MacExternalData variableWordSubclass: #AEDesc
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!AEDesc commentStamp: '<historical>' prior: 0!
I represent an Apple Event Descriptor.  I am a low-level representation of Apple Event (and hence Applescript) information.  For further Information, see Apple's Inside Macintosh: Interapplication Communications, at

	http://developer.apple.com/techpubs/mac/IAC/IAC-2.html.

Essentially, I represent a record comprising a one-word "string" (treating the word as fourbyte characters) representing a data type, followed by a pointer to a pointer (a handle) to the data I represent.  Care must be taken to assure that the Handle data is disposed after use, or memory leaks result.  At this time, I make no effort to do this automatically through finalization.!
]style[(218 54 384)f1,f1Rhttp://developer.apple.com/techpubs/mac/IAC/IAC-2.html;,f1!


!AEDesc methodsFor: 'accessing' stamp: 'acg 9/12/1999 21:33'!
dataSize

	^self handleSizeAt: 2! !

!AEDesc methodsFor: 'accessing' stamp: 'acg 9/20/1999 14:22'!
dispose

	(0 = (self at: 2)) ifTrue:
		[self error: 'cannot dispose of unallocated space'].
	self primAEDisposeDesc isZero ifFalse: 
		[self error: 'dispose operation failed'].
	self at: 1 put: 0.
	self at: 2 put: 0.
	^nil! !


!AEDesc methodsFor: 'converting' stamp: 'acg 9/24/1999 00:35'!
asCompiledApplescript

	| theSize |
	((self at: 1) ~= 16r73637074) ifTrue:
		[^self error: 'AEDesc is not of type ''scpt'''].
	(theSize _ self dataSize) < 0 ifTrue: [^self error: 'Invalid size for data'].
	^self primAEDescToString: (CompiledApplescript new: theSize).
! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/24/1999 00:31'!
asCompiledApplescriptThenDispose

	| CAD |
	CAD _ self asCompiledApplescript.
	self dispose.
	^CAD! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/26/1999 18:39'!
asOSAIDThenDisposeAEDescWith: aComponent

	^aComponent loadAndDisposeAEDesc: self mode: 0! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/23/1999 23:46'!
asShort

	^(self primAEDescToString: (ByteArray new: 2))
		shortAt: 1 bigEndian: true! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/23/1999 23:47'!
asShortThenDispose

	| short |
	short _ self asShort.
	self dispose.
	^short! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/20/1999 14:19'!
asString

	| theSize |
	((self at: 1) ~= 16r54455854) ifTrue:
		[^self error: 'AEDesc is not of type ''TEXT'''].
	(theSize _ self dataSize) < 0 ifTrue: [^self error: 'Invalid size for data'].
	^self primAEDescToString: (String new: theSize).
! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/21/1999 00:13'!
asStringThenDispose

	| string |
	string _ self asString.
	self dispose.
	^string! !

!AEDesc methodsFor: 'converting' stamp: 'acg 9/26/1999 01:15'!
to: aString

	| newAEDesc result |
	newAEDesc _ AEDesc new.
	result _ self primAECoerceDesc: (DescType of: aString) to: newAEDesc.
	result isZero ifFalse: [^result].
	self dispose.
	self at: 1 put: (newAEDesc at: 1).
	self at: 2 put: (newAEDesc at: 2).
	^0! !


!AEDesc methodsFor: 'private' stamp: 'acg 9/24/1999 00:38'!
createFromScpt: aCompiledApplescriptData

	(aCompiledApplescriptData class = CompiledApplescript) ifFalse:
		[^self error: 'textType Data Not From CompiledApplescriptData'].
	(self 
		primAECreateDesc: (DescType of: 'scpt')
		from: aCompiledApplescriptData) isZero ifTrue: [^self].
	self error: 'failed to create aeDesc'.
	^nil! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/20/1999 14:39'!
createFromText: aString

	(aString class = String) ifFalse:
		[^self error: 'TextType Data Not From String'].
	(self 
		primAECreateDesc: (DescType of: 'TEXT')
		from: aString) isZero ifTrue: [^self].
	self error: 'failed to create aeDesc'.
	^nil! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/25/1999 22:54'!
createNull

	(self 
		primAECreateDesc: (DescType of: 'null')
		from: '') isZero ifTrue: [^self].
	self error: 'failed to create aeDesc'.
	^nil! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/23/1999 22:51'!
primAECoerceDesc: typeCode to: result

	<primitive: 'primAECoerceDesc' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primAECoerceDesc:to:'
		withArguments: {typeCode. result}! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/20/1999 13:25'!
primAECreateDesc: typeCode from: aString

	<primitive: 'primAECreateDesc' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primAECreateDesc:from:'	
		withArguments: {typeCode. aString}! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/23/1999 21:13'!
primAEDescToString: aString

	<primitive: 'primAEDescToString' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primAEDescToString:'
		withArguments: {aString}! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/20/1999 13:28'!
primAEDisposeDesc

	<primitive: 'primAEDisposeDesc' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primAEDisposeDesc'
		withArguments: {}! !

!AEDesc methodsFor: 'private' stamp: 'acg 9/23/1999 22:20'!
primAEGetKeyPtr: keyDesc type: typeDesc actual: ignoreDesc to: aByteArray

	<primitive: 'primAEGetKeyPtr' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primAEGetKeyPtr:type:actual:to:'
		withArguments: {keyDesc. typeDesc. ignoreDesc. aByteArray}! !

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

AEDesc class
	instanceVariableNames: ''!

!AEDesc class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 22:17'!
new

	^super new: 2! !

!AEDesc class methodsFor: 'as yet unclassified' stamp: 'acg 9/25/1999 22:53'!
nullType

	^self new createNull! !

!AEDesc class methodsFor: 'as yet unclassified' stamp: 'acg 9/22/1999 08:05'!
scptTypeOn: aCompiledApplescriptData

	^(self new) createFromScpt: aCompiledApplescriptData

		! !

!AEDesc class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 13:30'!
textTypeOn: aString

	^(self new) createFromText: aString
		! !


!AEDesc class methodsFor: 'private' stamp: 'acg 9/12/1999 20:49'!
primSizeAEDesc

	<primitive: 'primSizeAEDesc' module: 'OSAPlugin'>
	^-1! !
Object subclass: #AIFFFileReader
	instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData markers pitch gain isLooped skipDataChunk mergeIfStereo '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!AIFFFileReader commentStamp: '<historical>' prior: 0!
I am a parser for AIFF (audio interchange file format) files. I can read uncompressed 8-bit and 16-bit mono, stereo, or multichannel AIFF files. I read the marker information used by the TransferStation utility to mark the loop points in sounds extracted from commercial sampled-sound CD-ROMs.
!


!AIFFFileReader methodsFor: 'reading'!
readFrom: binaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read the AIFF file of the given name. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data."
	"AIFFFileReader new readFromFile: 'test.aif' mergeIfStereo: false skipDataChunk: false"

	mergeIfStereo _ mergeFlag.
	skipDataChunk _ skipDataFlag.
	isLooped _ false.
	gain _ 1.0.
	self readFrom: binaryStream.
	binaryStream close.
! !

!AIFFFileReader methodsFor: 'reading' stamp: 'jm 8/2/1998 16:27'!
readFromFile: fileName
	"Read the AIFF file of the given name."
	"AIFFFileReader new readFromFile: 'test.aiff'"

	self readFromFile: fileName
		mergeIfStereo: false
		skipDataChunk: false.
! !

!AIFFFileReader methodsFor: 'reading'!
readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
	"Read the AIFF file of the given name. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data."
	"AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true"

	| binaryStream |
	binaryStream _ (FileStream readOnlyFileNamed: fileName) binary.
	self readFrom: binaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag
! !


!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
bitsPerSample

	^ bitsPerSample
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'!
channelCount

	^ channelCount
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
channelData

	^ channelData
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'!
frameCount

	^ frameCount
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
gain

	^ gain
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:40'!
isLooped

	^ isLooped
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 20:02'!
isStereo

	^ channelData size = 2
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:26'!
leftSamples

	^ channelData at: 1
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'!
loopEnd

	^ markers last last
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'!
loopLength

	^ markers last last - markers first last
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'!
markers

	^ markers
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:48'!
pitch

	^ pitch
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 19:34'!
rightSamples

	^ channelData at: 2
! !

!AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:25'!
samplingRate

	^ samplingRate
! !


!AIFFFileReader methodsFor: 'other' stamp: 'jm 8/17/1998 20:36'!
edit

	| ed |
	ed _ WaveEditor new.
	ed data: channelData first.
	ed loopEnd: markers last last.
	ed loopLength: (markers last last - markers first last) + 1.
	ed openInWorld.
! !

!AIFFFileReader methodsFor: 'other' stamp: 'jm 7/12/1998 01:44'!
pitchForKey: midiKey
	"Convert my MIDI key number to a pitch and return it."

	| indexInOctave octave p |
	indexInOctave _ (midiKey \\ 12) + 1.
	octave _ (midiKey // 12) + 1.
	"Table generator: (0 to: 11) collect: [:i | 16.3516 * (2.0 raisedTo: i asFloat / 12.0)]"
	p _ #(16.3516 17.32391 18.35405 19.44544 20.60173 21.82677
		  23.12466 24.49972 25.95655 27.50000 29.13524 30.86771) at: indexInOctave.
	^ p * (#(0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0) at: octave)
! !

!AIFFFileReader methodsFor: 'other' stamp: 'jm 1/14/1999 10:11'!
sound
	"Answer the sound represented by this AIFFFileReader. This method should be called only after readFrom: has been done."

	| snd rightSnd |
	snd _ SampledSound
		samples: (channelData at: 1)
		samplingRate: samplingRate.
	self isStereo ifTrue: [
		rightSnd _ SampledSound
			samples: (channelData at: 2)
			samplingRate: samplingRate.
		snd _ MixedSound new
			add: snd pan: 0;
			add: rightSnd pan: 1.0].
	^ snd
! !


!AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 07:33'!
readChunk: chunkType size: chunkSize
	"Read a AIFF chunk of the given type. Skip unrecognized chunks. Leave the input stream positioned chunkSize bytes past its position when this method is called."

	chunkType = 'COMM' ifTrue: [^ self readCommonChunk: chunkSize].
	chunkType = 'SSND' ifTrue: [^ self readSamplesChunk: chunkSize].
	chunkType = 'INST' ifTrue: [^ self readInstrumentChunk: chunkSize].
	chunkType = 'MARK' ifTrue: [^ self readMarkerChunk: chunkSize].
	in skip: chunkSize.  "skip unknown chunks"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 7/12/1998 18:24'!
readCommonChunk: chunkSize
	"Read a COMM chunk. All AIFF files have exactly one chunk of this type."

	| compressionType |
	channelCount _ in nextNumber: 2.
	frameCount _ in nextNumber: 4.
	bitsPerSample _ in nextNumber: 2.
	samplingRate _ self readExtendedFloat.
	chunkSize > 18 ifTrue: [
		fileType = 'AIFF'
			ifTrue: [self error: 'unexpectedly long COMM chunk size for AIFF file'].
		compressionType _ (in next: 4) asString.
		compressionType = 'NONE' ifFalse: [self error: 'cannot read compressed AIFF files'].
		in skip: (chunkSize - 22)].  "skip the reminder of AIFF-C style chunk"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 11:43'!
readExtendedFloat
	"Read and answer an Apple extended-precision 80-bit floating point number from the input stream."
	"Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."

	| signAndExp mantissa sign exp |
	signAndExp _ in nextNumber: 2.
	mantissa _ in nextNumber: 8.  "scaled by (2 raisedTo: -64) below"
	(signAndExp bitAnd: 16r8000) = 0
		ifTrue: [sign _ 1.0]
		ifFalse: [sign _ -1.0].
	exp _ (signAndExp bitAnd: 16r7FFF) - 16r4000 + 2.  "not sure why +2 is needed..."
	^ (sign * mantissa asFloat * (2.0 raisedTo: exp - 64)) roundTo: 0.00000001
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 19:58'!
readFrom: aBinaryStream
	"Read AIFF data from the given binary stream."
	"Details: An AIFF file consists of a header (FORM chunk) followed by a sequence of tagged data chunks. Each chunk starts with a header consisting of a four-byte tag (a string) and a four byte size. These eight bytes of chunk header are not included in the chunk size. For each chunk, the readChunk:size: method consumes chunkSize bytes of the input stream, parsing recognized chunks or skipping unrecognized ones. If chunkSize is odd, it will be followed by a padding byte. Chunks may occur in any order."

	| sz end chunkType chunkSize p |
	in _ aBinaryStream.

	"read FORM chunk"
	(in next: 4) asString = 'FORM' ifFalse: [^ self error: 'not an AIFF file'].
	sz _ in nextNumber: 4.
	end _ in position + sz.
	fileType _ (in next: 4) asString.

	[in atEnd not and: [in position < end]] whileTrue: [
		chunkType _ (in next: 4) asString.
		chunkSize _ in nextNumber: 4.
		p _ in position.
		self readChunk: chunkType size: chunkSize.
		(in position = (p + chunkSize))
			ifFalse: [self error: 'chunk size mismatch; bad AIFF file?'].
		chunkSize odd ifTrue: [in skip: 1]].  "skip padding byte"
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/5/1998 17:31'!
readInstrumentChunk: chunkSize

	| midiKey detune lowNote highNote lowVelocity highVelocity
	  sustainMode sustainStartID sustainEndID
	  releaseMode releaseStartID releaseEndID |

	midiKey _ in next.
	detune _ in next.
	lowNote _ in next.
	highNote _ in next.
	lowVelocity _ in next.
	highVelocity _ in next.
	gain _ in nextNumber: 2.
	sustainMode _ in nextNumber: 2.
	sustainStartID _ in nextNumber: 2.
	sustainEndID _ in nextNumber: 2.
	releaseMode _ in nextNumber: 2.
	releaseStartID _ in nextNumber: 2.
	releaseEndID _ in nextNumber: 2.
	isLooped _ sustainMode = 1.
	(isLooped and: [markers notNil]) ifTrue: [
		((markers first last > frameCount) or:
		 [markers last last > frameCount]) ifTrue: [
			"bad loop data; some sample CD files claim to be looped but aren't"
			isLooped _ false]].
	pitch _ self pitchForKey: midiKey.
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 21:22'!
readMarkerChunk: chunkSize

	| markerCount id position labelBytes label |
	markerCount _ in nextNumber: 2.
	markers _ Array new: markerCount.
	1 to: markerCount do: [:i |
		id _ in nextNumber: 2.
		position _ in nextNumber: 4.
		labelBytes _ in next.
		label _ (in next: labelBytes) asString.
		labelBytes even ifTrue: [in skip: 1].
		markers at: i put: (Array with: id with: label with: position)].

! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:58'!
readMergedStereoChannelDataFrom: s
	"Read stereophonic channel data from the given stream, mixing the two channels to create a single monophonic channel. Each frame contains two samples."

	| buf w1 w2 |
	buf _ channelData at: 1.
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w1 _ s next.
				w1 > 127 ifTrue: [w1 _ w1 - 256].
				w2 _ s next.
				w2 > 127 ifTrue: [w2 _ w2 - 256].
				buf at: i put: ((w1 + w2) bitShift: 7)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w1 _ (s next bitShift: 8) + s next.
				w1 > 32767 ifTrue: [w1 _ w1 - 65536].
				w2 _ (s next bitShift: 8) + s next.
				w2 > 32767 ifTrue: [w2 _ w2 - 65536].
				buf at: i put: ((w1 + w2) bitShift: -1)]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:53'!
readMonoChannelDataFrom: s
	"Read monophonic channel data from the given stream. Each frame contains a single sample."

	| buf w |
	buf _ channelData at: 1.  "the only buffer"
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				buf at: i put: (w bitShift: 8)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				buf at: i put: w]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:55'!
readMultiChannelDataFrom: s
	"Read multi-channel data from the given stream. Each frame contains channelCount samples."

	| w |
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				1 to: channelCount do: [:ch |
					w _ s next.
					w > 127 ifTrue: [w _ w - 256].
					(channelData at: ch) at: i put: (w bitShift: 8)]]]
		ifFalse: [
			1 to: frameCount do: [:i |
				1 to: channelCount do: [:ch |
					w _ (s next bitShift: 8) + s next.
					w > 32767 ifTrue: [w _ w - 65536].
					(channelData at: ch) at: i put: w]]].
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/3/1998 14:55'!
readSamplesChunk: chunkSize
	"Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type."

	| offset blockSize bytesOfSamples s |
	skipDataChunk ifTrue: [in skip: chunkSize. ^ self].

	offset _ in nextNumber: 4.
	blockSize _ in nextNumber: 4.
	((offset ~= 0) or: [blockSize ~= 0])
		ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks'].
	bytesOfSamples _ chunkSize - 8.
	bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8))
		ifFalse: [self error: 'actual sample count does not match COMM chunk'].
	(mergeIfStereo and: [channelCount = 2])
		ifTrue: [
			channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)]
		ifFalse: [
			channelData _
				(1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]].

	(bytesOfSamples < (Smalltalk garbageCollectMost - 300000))
		ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)]  "bulk-read, then process"
		ifFalse: [s _ in].  "not enough space to buffer; read directly from file"

	"mono and stereo are special-cased for better performance"
	channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s].
	channelCount = 2 ifTrue: [
		mergeIfStereo
			ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s]
			ifFalse: [^ self readStereoChannelDataFrom: s]].
	self readMultiChannelDataFrom: s.
! !

!AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:56'!
readStereoChannelDataFrom: s
	"Read stereophonic channel data from the given stream. Each frame contains two samples."

	| left right w |
	left _ channelData at: 1.
	right _ channelData at: 2.
	bitsPerSample = 8
		ifTrue: [
			1 to: frameCount do: [:i |
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				left at: i put: (w bitShift: 8).
				w _ s next.
				w > 127 ifTrue: [w _ w - 256].
				right at: i put: (w bitShift: 8)]]
		ifFalse: [
			1 to: frameCount do: [:i |
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				left at: i put: w.
				w _ (s next bitShift: 8) + s next.
				w > 32767 ifTrue: [w _ w - 65536].
				right at: i put: w]].
! !
Animation subclass: #AbsoluteAnimation
	instanceVariableNames: 'lastStartState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!AbsoluteAnimation commentStamp: '<historical>' prior: 0!
An AbsoluteAnimation is any animation where the final state of the animation is always the same. Every time this animation runs we store the initial state, so that when the animation is reversed and run we can determine what that end point should be.
!


!AbsoluteAnimation methodsFor: 'management' stamp: 'jsp 2/16/1999 16:36'!
prologue: currentTime
	"Extends the AbstractAnimation prologue by saving the start state of the animation."

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (UndoAnimation new: (self makeUndoVersion)).
					].

	(direction = Forward) ifTrue: [
									startState _ getStartStateFunction value.
									lastStartState _ startState.
									endState _ getEndStateFunction value.
								]
						ifFalse: [
									startState _ getStartStateFunction value.
									endState _ lastStartState.
								].


	super prologue: currentTime.
! !


!AbsoluteAnimation methodsFor: 'initialization' stamp: 'jsp 3/9/1999 15:49'!
object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs to run."

	lastStartState _ startFunc value.

	super object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland.
! !


!AbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 3/9/1999 15:49'!
copy
	"Creates a copy of the animation"

	| anim |

	anim _ AbsoluteAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		style: styleFunction
		duration: duration
		undoable: undoable
		inWonderland: myWonderland.

	(direction = Forward) ifFalse: [ anim reverseDirection ].

	^ anim.
! !

!AbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 3/9/1999 15:49'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim |

	anim _ AbsoluteAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		style: styleFunction
		duration: 0.5
		undoable: false
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !

!AbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 4/9/1999 14:22'!
reversed
	"Creates a reversed version of an animation"

	| anim |

	anim _ AbsoluteAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		style: styleFunction
		duration: duration
		undoable: true
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !
Object subclass: #AbstractAnimation
	instanceVariableNames: 'startTime endTime duration state direction loopCount undoable myScheduler myWonderland pausedInterval animatedObject '
	classVariableNames: 'Finished Forward Infinity Paused Reverse Running Stopped Waiting '
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!AbstractAnimation commentStamp: '<historical>' prior: 0!
This class implements the basic functionality of Animations for Wonderlands. All animations pass through 4 specific stages:

Waiting - this is the state animations are in when they are just started, before they run their prologue (perform any tasks they need to do before the animation actually starts)

Running - this is the state animations are in when they are actually running

Stopped - this is the state animations are in after they stop running but before they execute their prologue

Finished - this is the state animations are in after they finish their epilogue (perform any tasks they need to do after the animation completes).
!


!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 3/9/1999 15:45'!
getAnimatedObject
	"Return the object that this animation affects"

	^ animatedObject.
! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/26/1999 12:41'!
getLoopCount
	"Returns the animation's current loop count"

	^ loopCount.
! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/4/1999 10:22'!
getState
	"Returns the current state of the animation."

	^ state.
! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/3/1999 14:23'!
isDone
	"Returns true if the animation is running"

	^ (state = Stopped).
! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/26/1999 12:01'!
isLooping
	"Returns true if the animation is looping"

	^ ( loopCount > 1) or: [ loopCount = Infinity ].
! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/26/1999 12:42'!
setLoopCount: count
	"Sets the animation's current loop count"

	loopCount _ count.

! !

!AbstractAnimation methodsFor: 'accessing' stamp: 'jsp 2/26/1999 12:23'!
setUndoable: aBoolean
	"Sets the animation's undoable property"

	undoable _ aBoolean.
! !


!AbstractAnimation methodsFor: 'management' stamp: 'jsp 3/3/1999 12:38'!
copy

	self subclassResponsibility.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 3/3/1999 12:06'!
epilogue: currentTime
	"This method does any work that needs to be done after an interation of the animation finishes."

	(loopCount = Infinity) ifTrue:
				[state _ Waiting]
	ifFalse:
				[
					loopCount _ loopCount - 1.

					(loopCount > 0) ifTrue: [ state _ Waiting ]
									ifFalse: [state _ Stopped.
											 loopCount _ 1 ].
				].

! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:47'!
getDuration
	"This method returns the duration of the animation."

	^ duration.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 3/24/1999 15:48'!
loop
	"This method causes an animation to loop forever."

	loopCount _ Infinity.

	(state = Stopped) ifTrue: [ state _ Waiting.
							  myScheduler addAnimation: self. ].
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 15:10'!
loop: numberOfTimes
	"This method causes an animation to loop for the specified number of times."

	loopCount _ numberOfTimes.

	(state = Stopped) ifTrue: [ state _ Waiting.
							  myScheduler addAnimation: self. ].
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 3/3/1999 12:37'!
looped
	"This method creates a copy of an animation and loops it forever."

	| anim |

	anim _ self copy.
	anim setLoopCount: Infinity.

	^ anim.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 3/3/1999 12:36'!
looped: numberOfTimes
	"This method creates a copy of an animation and loops it for the specified number of times."

	| anim |

	anim _ self copy.
	anim setLoopCount: numberOfTimes.

	^ anim.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:43'!
pause
	"This method pauses an active Animation."

	(state = Running) ifTrue: [ state _ Paused. 
							    pausedInterval _ (myScheduler getTime) - startTime.].
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:56'!
prologue: currentTime
	"This method does any work that needs to be done before the animation starts, including possibly adding the current state to the undo stack."

	"Undo stack stuff here"
	undoable ifTrue: [].

	startTime _ currentTime.
	endTime _ startTime + duration.
	state _ Running.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/26/1999 15:21'!
resume
	"This method resumes a paused animation"

	(state = Paused) ifTrue:
		[
			state _ Running.
			startTime _ (myScheduler getTime) - pausedInterval.
			endTime _ startTime + duration.
		]
	ifFalse: [(state = Stopped) ifTrue:
				[
					state _ Waiting.
					myScheduler addAnimation: self.
				].
			]


! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 15:00'!
start
	"This method starts an existing animation"

	state _ Waiting.
	loopCount _ 1.
	myScheduler addAnimation: self.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:25'!
stop
	"This method changes the state of an animation to stopped.  If it is currently active, the Scheduler will remove it from the list of active animations."

	state _ Stopped.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:50'!
stopLooping
	"This method causes the animation to stop looping; the current interation of the animation completes before the animation stops."

	loopCount _ 1.
! !

!AbstractAnimation methodsFor: 'management' stamp: 'jsp 2/3/1999 14:53'!
update: currentTime
	"Updates the animation using the current Wonderland time"

	(state = Waiting) ifTrue: [self prologue: currentTime].

	(state = Running) ifTrue: [].

	(state = Finished) ifTrue: [self epilogue: currentTime].
! !


!AbstractAnimation methodsFor: 'reversing' stamp: 'jsp 2/15/1999 10:28'!
reverseDirection
	"Changes the direction an animation runs in (forward or in reverse)"

	(direction = Forward) ifTrue: [ direction _ Reverse ]
						 ifFalse: [ direction _ Forward ].
! !


!AbstractAnimation methodsFor: 'private' stamp: 'jsp 2/26/1999 14:21'!
scaleDuration: scaleAmount
	"Scales the animation's duration by the specified amount"

	duration _ duration * scaleAmount.
! !

!AbstractAnimation methodsFor: 'private' stamp: 'jsp 2/26/1999 14:17'!
setDirection: aDirection
	"Sets the animation's direction variable"

	direction _ aDirection.
! !

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

AbstractAnimation class
	instanceVariableNames: ''!

!AbstractAnimation class methodsFor: 'class initialization' stamp: 'jsp 3/24/1999 11:01'!
initialize
	"Initialize the class variables"

	Waiting _ 1.
	Running _ 2.
	Paused _ 3.
	Finished _ 4.
	Stopped _ 5.

	Forward _ 0.
	Reverse _ 1.

	Infinity _ -1.
! !
Object subclass: #AbstractFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!AbstractFont commentStamp: '<historical>' prior: 0!
AbstractFont defines the generic interface that all fonts need to implement.!


!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:56'!
characterToGlyphMap
	"Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character."
	^nil! !

!AbstractFont methodsFor: 'accessing' stamp: 'ar 5/19/2000 14:57'!
xTable
	"Return the xTable for the font. The xTable defines the left x-value for each individual glyph in the receiver. If such a table is not provided, the character scanner will ask the font directly for the appropriate width of each individual character."
	^nil! !


!AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 15:00'!
composeWord: aTextLineInterval in: sourceString beginningAt: xInteger 
	"Non-primitive composition of a word--add up widths of characters, add 
	sum to beginning x and answer the resulting x. Similar to performance 
	of scanning primitive, but without stop conditions."

	| character resultX |
	resultX _ xInteger.
	aTextLineInterval do: 
		[:i | 
		character _ sourceString at: i.
		resultX _ resultX + (self widthOf: character)].
	^resultX! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 14:58'!
widthOf: aCharacter
	"Return the width of the given character"
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'measuring' stamp: 'ar 5/19/2000 15:00'!
widthOfString: aString

	^ self composeWord: (1 to: aString size) in: aString beginningAt: 0
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"! !


!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'!
displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) display context."
	^self subclassResponsibility! !

!AbstractFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 14:59'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	"Install the receiver on the given DisplayContext (either BitBlt or Canvas) for further drawing operations."
	^self subclassResponsibility! !
Model subclass: #AbstractHierarchicalList
	instanceVariableNames: 'currentSelection myBrowser '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!AbstractHierarchicalList commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:22'!
genericMenu: aMenu

	aMenu add: 'no menu yet' target: self selector: #yourself.
	^aMenu! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:44'!
getCurrentSelection

	^currentSelection! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:46'!
noteNewSelection: x

	currentSelection _ x.
	self changed: #getCurrentSelection.
	currentSelection ifNil: [^self].
	currentSelection sendSettingMessageTo: self.
! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:53'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!AbstractHierarchicalList methodsFor: 'as yet unclassified' stamp: 'RAA 4/7/1999 16:47'!
update: aSymbol

	aSymbol == #hierarchicalList ifTrue: [
		^self changed: #getList
	].
	super update: aSymbol! !

Object subclass: #AbstractInstructionPrinter
	instanceVariableNames: 'bingo '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!AbstractInstructionPrinter commentStamp: '<historical>' prior: 0!
My job is to make it easier to scan bytecodes for specific actions, e.g. any instance variable reference.

BlockContext allInstances collect: [ :x |
	{x. x hasInstVarRef}
].!


!AbstractInstructionPrinter methodsFor: 'initialize-release' stamp: 'RAA 1/5/2001 08:43'!
interpretNextInstructionUsing: aScanner 
	
	bingo _ false.
	aScanner interpretNextInstructionFor: self.
	^bingo! !


!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
blockReturnTop
	"Print the Return Top Of Stack bytecode."

! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
doDup
	"Print the Duplicate Top Of Stack bytecode."

! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
doPop
	"Print the Remove Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:31'!
jump: offset
	"Print the Unconditional Jump bytecode."

! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:32'!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
methodReturnConstant: value 
	"Print the Return Constant bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
methodReturnReceiver
	"Print the Return Self bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
methodReturnTop
	"Print the Return Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
popIntoLiteralVariable: anAssociation 
	"Print the Remove Top Of Stack And Store Into Literal Variable bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
popIntoReceiverVariable: offset 
	"Print the Remove Top Of Stack And Store Into Instance Variable 
	bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:33'!
popIntoTemporaryVariable: offset 
	"Print the Remove Top Of Stack And Store Into Temporary Variable 
	bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushActiveContext
	"Print the Push Active Context On Top Of Its Own Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushConstant: value
	"Print the Push Constant, value, on Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushLiteralVariable: anAssociation
	"Print the Push Contents Of anAssociation On Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushReceiver
	"Print the Push Active Context's Receiver on Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushReceiverVariable: offset
	"Print the Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
pushTemporaryVariable: offset
	"Print the Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
send: selector super: supered numArgs: numberArguments
	"Print the Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
storeIntoLiteralVariable: anAssociation 
	"Print the Store Top Of Stack Into Literal Variable Of Method bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
storeIntoReceiverVariable: offset 
	"Print the Store Top Of Stack Into Instance Variable Of Method bytecode."
! !

!AbstractInstructionPrinter methodsFor: 'instruction decoding' stamp: 'RAA 1/5/2001 08:34'!
storeIntoTemporaryVariable: offset 
	"Print the Store Top Of Stack Into Temporary Variable Of Method 
	bytecode."
! !
Object subclass: #AbstractLauncher
	instanceVariableNames: 'parameters '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!AbstractLauncher commentStamp: '<historical>' prior: 0!
The class AutoStart in combination with the Launcher classes provides a mechanism for starting Squeak from the command line or a web page. Parameters on the command line or in the embed tag in the web page a parsed and stored in the lauchner's parameter dictionary.
Subclasses can access these parameters to determine what to do.

CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer.
To enable this execute
CommandLineLauncherExample activate
before you save the image.
To disable execute
CommandLineLauncherExample deactivate

The PluginLauchner is an example how to use this framework to start Squeak as a browser plugin. It looks for a parameter 'src' which should point to a file containing a squeak script.!


!AbstractLauncher methodsFor: 'private' stamp: 'jm 8/20/1999 15:33'!
commandLine: aString
	"Start up this launcher from within Squeak as if it Squeak been launched the given command line."

	| dict tokens cmd arg |
	dict _ Dictionary new.
	tokens _ ReadStream on: (aString findTokens: ' ').
	[cmd _ tokens next.
	 arg _ tokens next.
	 ((cmd ~~ nil) and: [arg ~~ nil])]
		whileTrue: [dict at: cmd put: arg].
	self parameters: dict.
	self startUp.
! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 13:18'!
determineParameterNameFrom: alternateParameterNames
	"Determine which of the given alternate parameter names is actually used."

	^alternateParameterNames detect: [:each | self includesParameter: each asUppercase] ifNone: [nil] ! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:35'!
includesParameter: parName
	"Return if the parameter named parName exists."
	^self parameters
		includesKey: parName asUppercase! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 12:11'!
numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock
	"Return the parameter named using one of the alternate names or an empty string"

	| parameterValue |
	parameterValue _ self parameterAtOneOf: alternateParameterNames.
	parameterValue isEmpty
		ifTrue: [^aBlock value].
	^[Number readFrom: parameterValue] ifError: [aBlock] 

! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 8/4/1999 14:19'!
parameterAt: parName
	"Return the parameter named parName or an empty string"
	^self
		parameterAt: parName
		ifAbsent: ['']! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:36'!
parameterAt: parName ifAbsent: aBlock
	"Return the parameter named parName.
	Evaluate the block if parameter does not exist."
	^self parameters
		at: parName asUppercase
		ifAbsent: [aBlock value]! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 9/23/1999 12:09'!
parameterAtOneOf: alternateParameterNames
	| parameterName |
	"Return the parameter named using one of the alternate names or an empty string"

	parameterName _ self determineParameterNameFrom: alternateParameterNames.
	^parameterName isNil
		ifTrue: ['']
		ifFalse: [self parameterAt: parameterName ifAbsent: ['']]! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 1/11/2000 16:53'!
parameters
	parameters == nil
		ifTrue: [parameters _ self class extractParameters].
	^parameters! !

!AbstractLauncher methodsFor: 'private' stamp: 'mir 7/29/1999 10:21'!
parameters: startupParameters
	parameters _ startupParameters! !


!AbstractLauncher methodsFor: 'running' stamp: 'mir 7/29/1999 10:22'!
startUp


! !


!AbstractLauncher methodsFor: 'initialization' stamp: 'mir 8/6/1999 18:32'!
initialize! !

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

AbstractLauncher class
	instanceVariableNames: ''!

!AbstractLauncher class methodsFor: 'private' stamp: 'mir 8/4/1999 13:57'!
autoStarter
	^AutoStart! !

!AbstractLauncher class methodsFor: 'private' stamp: 'mir 1/11/2000 16:54'!
extractParameters
	| pName value index globals |
	globals := Dictionary new.
	index := 3. "Muss bei 3 starten, da 2 documentName ist"
	[pName := Smalltalk getSystemAttribute: index.
	pName isEmptyOrNil] whileFalse:[
		index := index + 1.
		value := Smalltalk getSystemAttribute: index.
		value ifNil: [value _ ''].
 		globals at: pName asUppercase put: value.
		index := index + 1].
	^globals! !


!AbstractLauncher class methodsFor: 'activation' stamp: 'mir 8/6/1999 18:14'!
activate
	"Register this launcher with the auto start class"

	self autoStarter addLauncher: self! !

!AbstractLauncher class methodsFor: 'activation' stamp: 'mir 8/4/1999 13:57'!
deactivate
	"Unregister this launcher with the auto start class"
	self autoStarter removeLauncherClass: self! !


!AbstractLauncher class methodsFor: 'instance creation' stamp: 'mir 8/6/1999 18:33'!
new
	^super new initialize! !
RectangleMorph subclass: #AbstractMediaEventMorph
	instanceVariableNames: 'startTimeInScore endTimeInScore '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!AbstractMediaEventMorph commentStamp: '<historical>' prior: 0!
An abstract representation of media events to be placed in a PianoRollScoreMorph (or others as they are developed)!


!AbstractMediaEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 12:58'!
endTime

	^endTimeInScore ifNil: [startTimeInScore + 100]! !

!AbstractMediaEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 11:37'!
initialize

	super initialize.
	color _ Color paleYellow.
	self borderColor: Color black.
	self borderWidth: 1.
	self layoutPolicy: TableLayout new.
	self listDirection: #leftToRight.
	self wrapCentering: #topLeft.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self layoutInset: 2.
	self rubberBandCells: true. "default"! !

!AbstractMediaEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:45'!
justDroppedIntoPianoRoll: pianoRoll event: evt
	
	| ambientEvent |
	startTimeInScore _ pianoRoll timeForX: self left.

	ambientEvent _ AmbientEvent new 
		morph: self;
		time: startTimeInScore.

	pianoRoll score addAmbientEvent: ambientEvent.

	"self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
		[pianoRoll scorePlayer updateDuration]"
! !
Object subclass: #AbstractScoreEvent
	instanceVariableNames: 'time '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!AbstractScoreEvent commentStamp: '<historical>' prior: 0!
Abstract class for timed events in a MIDI score.
!


!AbstractScoreEvent methodsFor: 'accessing' stamp: 'di 6/17/1999 14:28'!
adjustTimeBy: delta

	time _ time + delta
! !

!AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'!
endTime
	"Subclasses should override to return the ending time if the event has some duration."

	^ time
! !

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

	^ time
! !

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

	time _ aNumber.
! !


!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isControlChange

	^ false
! !

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

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isPitchBend

	^ false
! !

!AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'!
isProgramChange

	^ false
! !

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

	^ false
! !


!AbstractScoreEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port. This default implementation does nothing."
! !
Object subclass: #AbstractSound
	instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit '
	classVariableNames: 'FloatScaleFactor MaxScaledValue PitchesForBottomOctave ScaleFactor Sounds TopOfBottomOctave UnloadedSnd '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!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 3/24/1999 12:03'!
loudness: aNumber
	"Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super."

	| vol |
	vol _ (aNumber asFloat max: 0.0) min: 1.0.
	envelopes do: [:e |
		(e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]].
	self initialVolume: vol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:04'!
nameOrNumberToPitch: aStringOrNumber
	"Answer the pitch in cycles/second for the given pitch specification. The specification can be either a numeric pitch or pitch name such as 'c4'."

	aStringOrNumber isNumber
		ifTrue: [^ aStringOrNumber asFloat]
		ifFalse: [^ AbstractSound pitchForName: aStringOrNumber]
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/19/1998 08:45'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super."

	| p |
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	envelopes do: [:e |
		e volume: l.
		e centerPitch: p].
	self initialVolume: l.
	self duration: d.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 17:11'!
soundForMidiKey: midiKey dur: d loudness: l
	"Answer an initialized sound object (a copy of the receiver) that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."

	^ self copy
		setPitch: (AbstractSound pitchForMIDIKey: midiKey)
		dur: d
		loudness: l
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 16:58'!
soundForPitch: pitchNameOrNumber dur: d loudness: l
	"Answer an initialized sound object (a copy of the receiver) that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."

	^ self copy setPitch: pitchNameOrNumber dur: d loudness: l
! !


!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 8/18/1998 09:57'!
removeAllEnvelopes
	"Remove all envelopes from my envelopes list."

	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: 'RAA 8/11/2000 11:51'!
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 |

	self flag: #bob.		"I removed the upper limit to allow making sounds louder. hmm..."

	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: 'jm 8/13/1998 16:37'!
loudness
	"Answer the current volume setting for this sound."

	^ scaledVol asFloat / ScaleFactor asFloat! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:28'!
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."

	self error: 'not yet implemented'.
! !


!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: 'ar 12/5/1998 22:20'!
isPlaying
	"Return true if the receiver is currently playing"
	^ SoundPlayer isPlaying: self! !

!AbstractSound methodsFor: 'playing' stamp: 'di 5/30/1999 12:46'!
millisecondsSinceStart

	^ mSecsSinceStart! !

!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 8/13/1998 15:09'!
playAndWaitUntilDone
	"Play this sound to the sound ouput port and wait until it has finished playing before returning."

	SoundPlayer playSound: self.
	[self samplesRemaining > 0] whileTrue.
	(Delay forMilliseconds: 2 * SoundPlayer bufferMSecs) wait.  "ensure last buffer has been output"
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/18/1998 10:52'!
playChromaticRunFrom: startPitch to: endPitch
	"Play a fast chromatic run between the given pitches. Useful for auditioning a sound."

	(AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 16:17'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
	"Mix the next n samples of this sound into the given buffer starting at the given index. Update the receiver's control parameters periodically."

	| fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
	fullVol _ AbstractSound scaleFactor.
	samplesBetweenControlUpdates _ self samplingRate // self controlRate.
	pastEnd _ startIndex + n.  "index just after the 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 7/5/1998 17:53'!
playSilently
	"Compute the samples of this sound without outputting them. Used for performance analysis."

	| bufSize buf |
	self reset.
	bufSize _ self samplingRate // 10.
	buf _ SoundBuffer newStereoSampleCount: bufSize.
	[self samplesRemaining > 0] whileTrue: [
		buf primFill: 0.
		self playSampleCount: bufSize 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: 'playing' stamp: 'jm 8/19/1998 08:30'!
viewSamples

	| stereoBuf |
	stereoBuf _ self computeSamplesForSeconds: self duration.
	WaveEditor openOn: stereoBuf extractLeftChannel.
! !


!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:34'!
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 |
	envelopes size > 0 ifTrue: [
		pitchModOrRatioChange _ false.
		1 to: envelopes size do: [:i |
			((envelopes at: i) updateTargetAt: mSecsSinceStart)
				ifTrue: [pitchModOrRatioChange _ true]].
		pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]].
	mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate).
! !

!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 7/6/1998 06:40'!
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 ScaleFactor is full volume."

	self subclassResponsibility.
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:45'!
reset
	"Reset my internal state for a replay. Methods that override this method should do super reset."

	mSecsSinceStart _ 0.
	samplesUntilNextControl _ 0.
	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 9/9/1998 21:56'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds. This default implementation does nothing."
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:54'!
stopGracefully
	"End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."

	| decayInMs env |
	envelopes isEmpty
		ifTrue: [
			self adjustVolumeTo: 0 overMSecs: 10.
			decayInMs _ 10]
		ifFalse: [
			env _ envelopes first.
			decayInMs _ env attackTime + env decayTime].
	self duration: (mSecsSinceStart + decayInMs) / 1000.0.
	self stopAfterMSecs: decayInMs.
! !

!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 2/2/1999 15:53'!
asSound

	^ self
! !

!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 methodsFor: 'copying' stamp: 'di 3/4/1999 21:29'!
sounds
	"Allows simple sounds to behave as, eg, sequential sounds"

	^ Array with: self! !


!AbstractSound methodsFor: 'file i/o' stamp: 'jm 3/13/1999 11:47'!
storeAIFFOnFileNamed: fileName

	| f |
	f _ (FileStream fileNamed: fileName) binary.
	self storeAIFFSamples: self samples samplingRate: self originalSamplingRate on: f.
	f close.
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 3/13/1999 11:48'!
storeAIFFSamples: aSoundBuffer samplingRate: rate on: aBinaryStream

	| sampleCount s |
	sampleCount _ aSoundBuffer monoSampleCount.
	aBinaryStream nextPutAll: 'FORM' asByteArray.
	aBinaryStream nextInt32Put: (2 * sampleCount) + ((7 * 4) + 18).
	aBinaryStream nextPutAll: 'AIFF' asByteArray.
	aBinaryStream nextPutAll: 'COMM' asByteArray.
	aBinaryStream nextInt32Put: 18.
	aBinaryStream nextNumber: 2 put: 1.  "channels"
	aBinaryStream nextInt32Put: sampleCount.
	aBinaryStream nextNumber: 2 put: 16.  "bits/sample"
	self storeExtendedFloat: rate on: aBinaryStream.
	aBinaryStream nextPutAll: 'SSND' asByteArray.
	aBinaryStream nextInt32Put: (2 * sampleCount) + 8.
	aBinaryStream nextInt32Put: 0.
	aBinaryStream nextInt32Put: 0.
	1 to: sampleCount do: [:i |
		s _ aSoundBuffer at: i.
		aBinaryStream nextPut: ((s bitShift: -8) bitAnd: 16rFF).
		aBinaryStream nextPut: (s bitAnd: 16rFF)].
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'jm 3/13/1999 11:34'!
storeExtendedFloat: aNumber on: aBinaryStream
	"Store an Apple extended-precision 80-bit floating point number on the given stream."
	"Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."

	| n isNeg exp mantissa |
	n _ aNumber asFloat.
	isNeg _ false.
	n < 0.0 ifTrue: [
		n _ 0.0 - n.
		isNeg _ true].
	exp _ (n log: 2.0) ceiling.
	mantissa _ (n * (2 raisedTo: 64 - exp)) truncated.
	exp _ exp + 16r4000 - 2.  "not sure why the -2 is needed..."
	isNeg ifTrue: [exp _ exp bitOr: 16r8000].  "set sign bit"
	aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF).
	aBinaryStream nextPut: (exp bitAnd: 16rFF).
	8 to: 1 by: -1 do: [:i | aBinaryStream nextPut: (mantissa digitAt: i)].
! !

!AbstractSound methodsFor: 'file i/o' stamp: 'JMV 1/19/2001 12:08'!
storeWAVOnFileNamed: fileName

	| f |
	f _ (FileStream fileNamed: fileName) binary.
	self storeWAVSamplesSamplingRate: self samplingRate on: f.
	f close.! !

!AbstractSound methodsFor: 'file i/o' stamp: 'JMV 1/26/2001 11:36'!
storeWAVSamplesSamplingRate: rate on: aBinaryStream
	"Write WAV sound file. Stereo, 16 bit. At the appropiate sampling rate."

	| bufferSize buffer fullBufferCount lastBufferSize finalSampleCount |

	self reset.
	finalSampleCount _ (self duration * self samplingRate) ceiling.
	bufferSize _ self samplingRate rounded min: finalSampleCount.	"One second. Could be any size."
	fullBufferCount _ finalSampleCount // bufferSize.
	lastBufferSize _ finalSampleCount \\ bufferSize.

	"File header"
	aBinaryStream
		nextPutAll: 'RIFF' asByteArray;
		nextLittleEndianNumber: 4 put: finalSampleCount * 4 + 36;	"Lenght of all chunks"
		nextPutAll: 'WAVE' asByteArray.

	"Format Chunk"
	aBinaryStream
		nextPutAll: 'fmt ' asByteArray;
		nextLittleEndianNumber: 4 put: 16;		"Lenght of this chunk"
		nextLittleEndianNumber: 2 put: 1;		"Format tag"
		nextLittleEndianNumber: 2 put: 2;		"Channel count"
		nextLittleEndianNumber: 4 put: self samplingRate rounded;		"Samples per sec"
		nextLittleEndianNumber: 4 put: self samplingRate rounded * 4;	"Bytes per sec"
		nextLittleEndianNumber: 2 put: 4;		"Alignment"
		nextLittleEndianNumber: 2 put: 16.		"Bits per sample"

	"Data chunk"
	aBinaryStream
		nextPutAll: 'data' asByteArray;
		nextLittleEndianNumber: 4 put: finalSampleCount * 4.		"Lenght of this chunk"

	fullBufferCount timesRepeat: [
		buffer _ SoundBuffer newStereoSampleCount: bufferSize.
		self playSampleCount: bufferSize into: buffer startingAt: 1.
		buffer do: [ :sample |
			aBinaryStream nextLittleEndianNumber: 2 put: sample \\ 65536 ].
	].
	buffer _ SoundBuffer newStereoSampleCount: lastBufferSize.
	self playSampleCount: lastBufferSize into: buffer startingAt: 1.
	buffer do: [ :sample |
		aBinaryStream nextLittleEndianNumber: 2 put: sample \\ 65536].! !


!AbstractSound methodsFor: 'conversion' stamp: 'mjg 12/3/1999 12:58'!
asSampledSound
	^SampledSound samples: (self computeSamplesForSeconds: self 
duration) samplingRate: (self samplingRate)*2.
! !

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

AbstractSound class
	instanceVariableNames: ''!

!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 8/3/1998 16:13'!
initialize
	"AbstractSound initialize"
 
	| bottomC |
	ScaleFactor _ 2 raisedTo: 15.
	FloatScaleFactor _ ScaleFactor asFloat.
	MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1.  "magnitude of largest scaled value in 32-bits"

	"generate pitches for c-1 through c0"
	bottomC _ (440.0 / 32) * (2.0 raisedTo: -9.0 / 12.0).
	PitchesForBottomOctave _ (0 to: 12) collect: [:i | bottomC * (2.0 raisedTo: i asFloat / 12.0)].
	TopOfBottomOctave _ PitchesForBottomOctave last.
! !

!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: 'jm 8/3/1998 17:00'!
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
						soundForPitch: 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: 'utilities' stamp: 'DSM 9/5/2000 13:50'!
busySignal: count
	"AbstractSound busySignal: 3"
	| m s |
	s _ SequentialSound new.
	m _ MixedSound new.
	m	add: (FMSound new setPitch: 480 dur: 0.5 loudness: 0.5);
		add: (FMSound new setPitch: 620 dur: 0.5 loudness: 0.5).
	s add: m.
	s add: (FMSound new setPitch: 1 dur: 0.5 loudness: 0).
	^ (RepeatingSound repeat: s count: count) play.

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:56'!
dial: aString
	| index lo hi m s |
	"AbstractSound dial: '867-5309'" "ask for Jenny"

	s _ SequentialSound new.
	aString do: [ :c |
		c = $,
			ifTrue: [ s add: (FMSound new setPitch: 1 dur: 1 loudness: 0) ]
			ifFalse: [
				(index _ ('123A456B789C*0#D' indexOf: c)) > 0
					ifTrue: [
						lo _ #(697 770 852 941) at: (index - 1 // 4 + 1).
						hi _ #(1209 1336 1477 1633) at: (index - 1 \\ 4 + 1).
						m _ MixedSound new.
						m add: (FMSound new setPitch: lo dur: 0.15 loudness: 0.5).
						m add: (FMSound new setPitch: hi dur: 0.15 loudness: 0.5).
						s add: m.
						s add: (FMSound new setPitch: 1 dur: 0.05 loudness: 0)]]].
	^ s play.

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:49'!
dialTone: duration
	"AbstractSound dialTone: 2"
	| m |
	m _ MixedSound new.
	m add: (FMSound new setPitch: 350 dur: duration loudness: 0.5).
	m add: (FMSound new setPitch: 440 dur: duration loudness: 0.5).
	m play.
	^ m! !

!AbstractSound class methodsFor: 'utilities' stamp: 'DSM 9/5/2000 13:50'!
hangUpWarning: count
	"AbstractSound hangUpWarning: 20"
	| m s |
	s _ SequentialSound new.
	m _ MixedSound new.
	m	add: (FMSound new setPitch: 1400 dur: 0.1 loudness: 0.5);
		add: (FMSound new setPitch: 2060 dur: 0.1 loudness: 0.5).
	s add: m; add: (FMSound new setPitch: 1 dur: 0.1 loudness: 0).
	^ (RepeatingSound repeat: s count: count) play

! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'!
indexOfBottomOctavePitch: p
	"Answer the index of the first pitch in the bottom octave equal to or higher than the given pitch. Assume that the given pitch is below the top pitch of the bottom octave."

	1 to: PitchesForBottomOctave size do: [:i |
		(PitchesForBottomOctave at: i) >= p ifTrue: [^ i]].
	self error: 'implementation error: argument pitch should be below or within the bottom octave'.
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'!
midiKeyForPitch: pitchNameOrNumber
	"Answer the midiKey closest to the given pitch. Pitch may be a numeric pitch or a pitch name string such as 'c4'."
	"AbstractSound midiKeyForPitch: 440.0"

	| p octave i midiKey |
	pitchNameOrNumber isNumber
		ifTrue: [p _ pitchNameOrNumber asFloat]
		ifFalse: [p _ AbstractSound pitchForName: pitchNameOrNumber].
	octave _ -1.
	[p >= TopOfBottomOctave] whileTrue: [
		octave _ octave + 1.
		p _ p / 2.0].

	i _ self indexOfBottomOctavePitch: p.
	(i > 1) ifTrue: [
		(p - (PitchesForBottomOctave at: i - 1)) < ((PitchesForBottomOctave at: i) - p)
			ifTrue: [i _ i - 1]].

	midiKey _ ((octave * 12) + 11 + i).
	midiKey > 127 ifTrue: [midiKey _ 127].
	^ midiKey
! !

!AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:43'!
pitchForMIDIKey: midiKey
	"Answer the pitch for the given MIDI key."
	"(1 to: 127) collect: [:i | AbstractSound pitchForMIDIKey: i]"

	| indexInOctave octave |
	indexInOctave _ (midiKey \\ 12) + 1.
	octave _ (midiKey // 12) + 1.
	^ (PitchesForBottomOctave at: indexInOctave) *
		(#(1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0) at: octave)
! !

!AbstractSound class methodsFor: 'utilities'!
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: 'utilities' stamp: 'jm 7/6/1998 15:47'!
pitchTable
	"AbstractSound pitchTable"

	| out note i |
	out _ WriteStream on: (String new: 1000).
	i _ 12.
	0 to: 8 do: [:octave |
		#(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName |
			note _ noteName, octave printString.
			out nextPutAll: note; tab.
			out nextPutAll: i printString; tab.
			out nextPutAll: (AbstractSound pitchForName: note) printString; cr.
			i _ i + 1]].
	^ out contents
! !


!AbstractSound class methodsFor: 'examples' stamp: 'jm 6/30/1998 18:40'!
chromaticPitchesFrom: aPitch

	| halfStep pitch |
	halfStep _ 2.0 raisedTo: (1.0 / 12.0).
	pitch _ aPitch isNumber
			ifTrue: [aPitch]
			ifFalse: [self pitchForName: aPitch].
	pitch _ pitch / halfStep.
	^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep]
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 8/18/1998 11:32'!
chromaticRunFrom: startPitch to: endPitch on: aSound
	"Answer a composite sound consisting of a rapid chromatic run between the given pitches on the given sound."
	"(AbstractSound chromaticRunFrom: 'c3' to: 'c#5' on: FMSound oboe1) play"

	| scale halfStep pEnd p |
	scale _ SequentialSound new.
	halfStep _ 2.0 raisedTo: (1.0 / 12.0).
	endPitch isNumber
		ifTrue: [pEnd _ endPitch asFloat]
		ifFalse: [pEnd _ AbstractSound pitchForName: endPitch].
	startPitch isNumber
		ifTrue: [p _ startPitch asFloat]
		ifFalse: [p _ AbstractSound pitchForName: startPitch].
	[p <= pEnd] whileTrue: [
		scale add: (aSound soundForPitch: p dur: 0.2 loudness: 0.5).
		p _ p * halfStep].
	^ scale
! !

!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: '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 8/3/1998 17:00'!
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
			soundForPitch: (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 7/13/1998 13:09'!
majorScaleOn: aSound from: aPitch
	"FMSound majorScale play"

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

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/4/1999 09:26'!
majorScaleOn: aSound from: aPitch octaves: octaveCount
	"(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play"

	| startingPitch pitches chromatic |
	startingPitch _ aPitch isNumber
		ifTrue: [aPitch]
		ifFalse: [self pitchForName: aPitch].
	pitches _ OrderedCollection new.
	0 to: octaveCount - 1 do: [:i |
		chromatic _ self chromaticPitchesFrom: startingPitch * (2 raisedTo: i).
		#(1 3 5 6 8 10 12) do: [:j | pitches addLast: (chromatic at: j)]].
	pitches addLast: startingPitch * (2 raisedTo: octaveCount).
	^ self noteSequenceOn: aSound
		from: (pitches collect: [:pitch | Array with: pitch with: 0.5 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: 'di 4/13/1999 13:53'!
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 ratio |
	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.
			ratio _ mousePt y asFloat / 20.0.
			s modulation: mod ratio: ratio.
			lastVal _ mousePt.
			status _
'mod: ', mod printString, '
ratio: ', ratio printString.
			status 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: 'sound library' stamp: 'jm 8/14/1998 13:27'!
initSounds
	"AbstractSound initSounds"

	Sounds _ Dictionary new.
	(FMSound class organization listAtCategoryNamed: #instruments)
		do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)].
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:25'!
soundNamed: soundName

	^ Sounds at: soundName
! !

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

	^ Sounds at: soundName ifAbsent: aBlock
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'di 11/7/2000 12:12'!
soundNamed: soundName put: aSound

	Sounds at: soundName put: aSound.
	AbstractSound updateScorePlayers.
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/19/1998 14:11'!
soundNames

	^ Sounds keys asSortedCollection asArray
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/4/1998 18:26'!
sounds

	^ Sounds
! !

!AbstractSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 13:00'!
updateFMSounds
	"AbstractSound updateFMSounds"

	Sounds keys do: [:k |
		((Sounds at: k) isKindOf: FMSound) ifTrue: [
			Sounds removeKey: k ifAbsent: []]].

	(FMSound class organization listAtCategoryNamed: #instruments) do:
		[:sel | Sounds at: sel asString put: (FMSound perform: sel)].
! !


!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'sge 2/13/2000 05:20'!
fileInSoundLibrary
	"Prompt the user for a file name and the file in the sound library with that name."
	"AbstractSound fileInSoundLibrary"

	| fileName |
	fileName _ FillInTheBlank request: 'Sound library file name?'.
	fileName isEmptyOrNil ifTrue: [^ self].
	(fileName endsWith: '.sounds') ifFalse: [fileName _ fileName, '.sounds'].
	self fileInSoundLibraryNamed: fileName.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'di 11/7/2000 12:50'!
fileInSoundLibraryNamed: fileName
	"File in the sound library with the given file name, and add its contents to the current sound library."

	| s newSounds |
	s _ FileStream oldFileNamed: fileName.
	newSounds _ s fileInObjectAndCode.
	s close.
	newSounds associationsDo:
		[:assoc | self storeFiledInSound: assoc value named: assoc key].
	AbstractSound updateScorePlayers.
	Smalltalk garbageCollect.  "Large objects may have been released"
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 8/19/1998 12:42'!
fileOutSoundLibrary
	"File out the current sound library."
	"AbstractSound fileOutSoundLibrary"

	self fileOutSoundLibrary: Sounds.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'sge 2/13/2000 05:22'!
fileOutSoundLibrary: aDictionary
	"File out the given dictionary, which is assumed to contain sound and instrument objects keyed by their names."
	"Note: This method is separated out so that one can file out edited sound libraries, as well as the system sound library. To make such a collection, you can inspect AbstractSound sounds and remove the items you don't want. Then do: 'AbstractSound fileOutSoundLibrary: self' from the Dictionary inspector."

	| fileName refStream |
	(aDictionary isKindOf: Dictionary)
		ifFalse: [self error: 'arg should be a dictionary of sounds'].
	fileName _ FillInTheBlank request: 'Sound library file name?'.
	fileName isEmptyOrNil ifTrue: [^ self].
	refStream _ SmartRefStream fileNamed: fileName, '.sounds'.
	refStream nextPut: aDictionary.
	refStream close.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:35'!
storeFiledInSound: snd named: sndName
	"Store the given sound in the sound library. Use the given name if it isn't in use, otherwise ask the user what to do."

	| menu choice i |
	(Sounds includesKey: sndName) ifFalse: [  "no name clash"
		Sounds at: sndName put: snd.
		^ self].

	(Sounds at: sndName) == UnloadedSnd ifTrue: [
		"re-loading a sound that was unloaded to save space"
		Sounds at: sndName put: snd.
		^ self].

	"the given sound name is already used"
	menu _ SelectionMenu selections:
		#('replace the existing sound' 'rename the new sound' 'skip it').
	choice _ menu startUpWithCaption:
		'"', sndName, '" has the same name as an existing sound'.
	(choice beginsWith: 'replace') ifTrue: [
		Sounds at: sndName put: snd.
		^ self].
	(choice beginsWith: 'rename') ifTrue: [
		i _ 2.
		[Sounds includesKey: (sndName, ' v', i printString)] whileTrue: [i _ i + 1].
		Sounds at: (sndName, ' v', i printString) put: snd].
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 22:18'!
unloadSampledTimbres
	"This can be done to unload those bulky sampled timbres to shrink the image. The unloaded sounds are replaced by a well-known 'unloaded sound' object to enable the unloaded sounds to be detected when the process is reversed."
	"AbstractSound unloadSampledTimbres"

	Sounds keys copy do: [:soundName |
		(((Sounds at: soundName) isKindOf: SampledInstrument) or:
		 [(Sounds at: soundName) isKindOf: LoopedSampledSound]) ifTrue: [
			Sounds at: soundName put: self unloadedSound]].
	self updateScorePlayers.
	Smalltalk garbageCollect.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/11/1998 16:47'!
unloadSoundNamed: soundName

	(Sounds includesKey: soundName) ifTrue: [
		Sounds at: soundName put: self unloadedSound].
	self updateScorePlayers.
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:48'!
unloadedSound
	"Answer a sound to be used as the place-holder for sounds that have been unloaded."

	UnloadedSnd ifNil: [UnloadedSnd _ UnloadedSound default copy].
	^ UnloadedSnd
! !

!AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'di 11/7/2000 13:00'!
updateScorePlayers
	| soundsBeingEdited |
	"Force all ScorePlayers to update their instrument list from the sound library. This may done after loading, unloading, or replacing a sound to make all ScorePlayers feel the change."

	ScorePlayer allSubInstancesDo:
		[:p | p pause].
	SoundPlayer shutDown.
	soundsBeingEdited _ EnvelopeEditorMorph allSubInstances collect: [:ed | ed soundBeingEdited].
	ScorePlayerMorph allSubInstancesDo:
		[:p | p updateInstrumentsFromLibraryExcept: soundsBeingEdited].
! !


!AbstractSound class methodsFor: 'primitive generation' stamp: 'ar 2/3/2001 15:30'!
translatedPrimitives
	^#(
		(FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(LoopedSampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
		(ReverbSound applyReverbTo:startingAt:count:)
	).
! !
PluggableTextMorph subclass: #AcceptableCleanTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!AcceptableCleanTextMorph methodsFor: 'as yet unclassified' stamp: 'di 6/22/1998 21:38'!
accept
	"Overridden to allow accept of clean text"
	| textToAccept ok |
	textToAccept _ textMorph asText.
	ok _ (setTextSelector == nil) or:
		[setTextSelector numArgs = 2
			ifTrue: [model perform: setTextSelector with: textToAccept with: self]
			ifFalse: [model perform: setTextSelector with: textToAccept]].
	ok ifTrue:
		[self setText: self getText.
		self hasUnacceptedEdits: false]! !
FileDirectory subclass: #AcornFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!

!AcornFileDirectory methodsFor: 'file name utilities' stamp: 'ar 12/18/1999 00:47'!
fullPathFor: path
	path isEmpty ifTrue:[^pathName].
	((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path].
	^pathName, self slash, path! !

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

AcornFileDirectory class
	instanceVariableNames: ''!

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'sma 6/25/2000 09:25'!
isActiveDirectoryClass
	"Does this class claim to be that properly active subclass of FileDirectory  
	for the current platform? On Acorn, the test is whether platformName 
	is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on
	older ones), which is what we would like to use for a dirsep if only it
	would work out. See pathNameDelimiter for more woeful details - then
	just get on and enjoy Squeak"

	^ Smalltalk platformName = 'RiscOS'
		or: [self primPathNameDelimiter = $.]! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 7/20/1999 17:52'!
maxFileNameLength

	^ 255
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/10/1998 21:45'!
pathNameDelimiter
"Acorn RiscOS uses a dot as the directory separator and has no real concept of filename extensions. We tried to make code handle this, but there are just too many uses of dot as a filename extension - so fake it out by pretending to use a slash. The file prims do conversions instead.
Sad, but pragmatic"
	^ $/
! !
Object subclass: #Action
	instanceVariableNames: 'actionTask paused affectedObject lifetime stopCondition myScheduler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!Action commentStamp: '<historical>' prior: 0!
This class implements Actions for Wonderlands. An Action is some task that should be executed every frame either forever, until a specified amount of time has elapsed, or until a specified condition holds true.
!


!Action methodsFor: 'accessing' stamp: 'jsp 3/9/1999 16:08'!
getAffectedObject
	"Returns the object affected by the action"

	^ affectedObject.
! !

!Action methodsFor: 'accessing' stamp: 'jsp 2/1/1999 15:13'!
isDone
	"Returns true if the Action is done executing either because it's lifetime has expired or because the specified condition is true"

	(lifetime > 0) ifTrue: [^ (lifetime < (myScheduler getTime))]
				ifFalse: [^ (stopCondition value)].
	! !

!Action methodsFor: 'accessing' stamp: 'jsp 3/9/1999 16:22'!
isPaused
	"Returns true if the action is paused"

	^ paused.
! !

!Action methodsFor: 'accessing' stamp: 'jsp 3/9/1999 16:21'!
pause
	"Pause the action"

	paused _ true.
! !

!Action methodsFor: 'accessing' stamp: 'jsp 3/9/1999 16:21'!
resume
	"resume the action"

	paused _ false.
! !


!Action methodsFor: 'management' stamp: 'jsp 3/9/1999 16:20'!
execute
	"Execute the Action's task"

	paused ifFalse: [ actionTask value ].

! !

!Action methodsFor: 'management' stamp: 'jsp 3/9/1999 16:08'!
setAffectedObject: anObject
	"Sets the object affected by the action"

	affectedObject _ anObject.
! !

!Action methodsFor: 'management' stamp: 'jsp 2/1/1999 11:44'!
setLifetime: howlong andCondition: condition
	"Sets how long the action should run, or the condition under which it should stop"

	lifetime _ howlong.
	stopCondition _ condition.
! !

!Action methodsFor: 'management' stamp: 'jsp 2/1/1999 16:20'!
setScheduler: scheduler
	"Sets the scheduler the Action is active in"

	myScheduler _ scheduler.
! !

!Action methodsFor: 'management' stamp: 'jsp 3/9/1999 16:20'!
setTask: task
	"Sets the task the Action should perform each frame"

	actionTask _ task.
	paused _ false.

! !

!Action methodsFor: 'management' stamp: 'jsp 3/30/1999 11:50'!
stop
	"This method removes the Action from myScheduler's list of active actions"

	stopCondition _ [ true ].
	myScheduler removeAction: self.
! !

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

Action class
	instanceVariableNames: ''!

!Action class methodsFor: 'initialize-release' stamp: 'jsp 3/9/1999 16:09'!
do: task eachframefor: time toObject: anObject inScheduler: scheduler
	"Creates a new Action that performs the specified task each frame for (time) seconds"

	| newAction |
	newAction _ Action new.

	newAction setTask: task.
	newAction setLifetime: (time + (scheduler getTime)) andCondition: [false].
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addAction: newAction.

	^ newAction.
! !

!Action class methodsFor: 'initialize-release' stamp: 'jsp 3/9/1999 16:09'!
do: task eachframeuntil: condition toObject: anObject inScheduler: scheduler
	"Creates a new Action that performs the specified task each frame until the specified condition holds true"

	| newAction |
	newAction _ Action new.

	newAction setTask: task.
	newAction setLifetime: -1 andCondition: condition.
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addAction: newAction.

	^ newAction.
! !

!Action class methodsFor: 'initialize-release' stamp: 'jsp 3/9/1999 16:10'!
do: task toObject: anObject inScheduler: scheduler
	"Creates a new Action that executes the specified task each frame"

	| newAction |
	newAction _ Action new.

	newAction setTask: task.
	newAction setLifetime: -1 andCondition: [false].
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addAction: newAction.

	^ newAction.
! !
SwikiAction subclass: #ActiveSwikiAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 9/1/1998
12:44'!
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: (formatter swikify: liveText
			linkhandler: [:link | urlmap
					linkFor: link
					from: request peerName
					storingTo: OrderedCollection new
					page: formattedPage]).
	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: 'mjg 9/10/1998
15:33'!
inputFrom: request
	"Take user's input and respond with a searchresult or store the edit"

	| coreRef page theText |
	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].
	(theText _ request fields at: 'text' ifAbsent: [nil]) ifNotNil: [
		"It's a response from an edit, so store the page"
		page _ urlmap atID: coreRef.
		page user: request peerName.  "Address is machine, user only if
logged in"
		 page pageStatus = #new ifTrue: [page pageStatus: #standard].
		page _ urlmap
			storeID: coreRef
			text: theText withSqueakLineEndings
			from: request peerName.
		^ self].	"return self means do serve the edited page
afterwards"
	request fields keys do: [:aTag |
		(aTag beginsWith: 'text-') ifTrue: [
			urlmap
				storeID: coreRef
				text: (request fields at: aTag)
withSqueakLineEndings
				insertAt: (aTag copyFrom: 6 to: aTag size).
	"string"
			^ self]].
	"oops, a new kind!! -- but don't complain!! Could be for ActivePage!!"
"	Transcript show: 'Unknown data from client. '; show: request fields
printString; cr."! !
Object subclass: #ActorState
	instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!
!ActorState commentStamp: '<historical>' 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: 'ar 10/5/2000 18:50'!
choosePenColor: evt
	owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer penColor hand: evt hand.! !

!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'].
! !

!ActorState methodsFor: 'other' stamp: 'MPW 1/1/1901 21:53'!
printOnStream: aStream
	aStream print: 'ActorState for '; print:owningPlayer externalName; print:' '.
	penDown ifNotNil: [aStream cr; print: 'penDown '; write:penDown].
	penColor ifNotNil: [aStream cr; print: 'penColor '; write:penColor].
	penSize ifNotNil: [aStream cr; print: 'penSize '; write:penSize].
	instantiatedUserScriptsDictionary ifNotNil:
		[aStream cr; print:
			'+ '; write: instantiatedUserScriptsDictionary size; print:' user scripts'].
! !
B3DSceneMorph subclass: #AdvancedB3DSceneMorph
	instanceVariableNames: 'rotationAngle stepTime isRotating oldPoint headLightStatus savedHeadLight '
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Demo Morphs'!

!AdvancedB3DSceneMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 16:36'!
rotationAngle
	^rotationAngle! !

!AdvancedB3DSceneMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 16:36'!
rotationAngle: aNumber
	rotationAngle := aNumber! !

!AdvancedB3DSceneMorph methodsFor: 'accessing'!
scene: aScene
	super scene: (self updateSceneWithDefaults: aScene).
	self updateUpVectorForCamera: self scene defaultCamera.
	self updateHeadlight.
	self changed! !

!AdvancedB3DSceneMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 16:35'!
stepTime
	^stepTime! !

!AdvancedB3DSceneMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 16:35'!
stepTime: aNumber
	stepTime := aNumber! !


!AdvancedB3DSceneMorph methodsFor: 'camera actions'!
addDolly: delta
	| camera new |
	camera := scene defaultCamera.
	new := camera position - (camera direction * delta).
	camera target = new ifFalse: [
		camera position: new].
	"new := camera direction * delta.
	camera position: camera position - new.
	camera target: camera target - new."
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 3/27/2000 16:55'!
addFovAngle: delta
	| camera new |
	camera := scene defaultCamera.
	new := camera fov + delta.
	0 < new ifTrue: [
		camera fov: new].
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 3/27/2000 16:54'!
panBy: aPoint
	| camera pt |
	pt := B3DVector3 x: aPoint x y: aPoint y negated z: 0.0.
 	camera := scene defaultCamera.
	pt := pt * (camera direction length) / 200.

	pt := camera asMatrix4x4 inverseTransformation localPointToGlobal: pt.
	pt := pt - camera position.

	camera position: camera position + pt.
	camera target: camera target + pt.
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 6/21/2000 10:38'!
rotateFrom: anOldPoint to: aCurrentPoint
	| camera matrix anOldPointOnSphere aCurrentPointOnSphere center radius |
	center := self bounds center.
	radius := self bounds extent r / 2. 
	anOldPointOnSphere := self pointOnSphereCentered: center radius: radius atPoint: anOldPoint.
	aCurrentPointOnSphere := self pointOnSphereCentered: center radius: radius atPoint: aCurrentPoint.
	camera := scene defaultCamera.
	matrix := B3DMatrix4x4
		rotatedBy: ((anOldPointOnSphere dot: aCurrentPointOnSphere) min: 1.0) arcCos radiansToDegrees
		around:
			(camera asMatrix4x4 inverseTransformation localPointToGlobal:
				(anOldPointOnSphere cross: aCurrentPointOnSphere)) - camera position
		centeredAt: camera target.
	camera position: (matrix localPointToGlobal: camera position).
	camera up: (matrix localPointToGlobal: camera up).
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 3/27/2000 16:55'!
rotateX:  angle
	| camera matrix |
	camera := scene defaultCamera.
	matrix := B3DMatrix4x4
		rotatedBy: angle
		around: ((camera position - camera target) cross: camera up)
		centeredAt: camera target.
	camera position: (matrix localPointToGlobal: camera position).
	camera up: (matrix localPointToGlobal: camera up).
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 3/27/2000 16:55'!
rotateY: angle
	| camera matrix |
	camera := scene defaultCamera.
	matrix := B3DMatrix4x4
		rotatedBy: angle
		around: camera up
		centeredAt: camera target.
	camera position: (matrix localPointToGlobal: camera position).
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 3/27/2000 16:54'!
rotateZ: angle
	| camera matrix |
	camera := scene defaultCamera.
	matrix := B3DMatrix4x4
		rotatedBy: angle
		around: (camera position - camera target)
		centeredAt: camera target.
	camera up: (matrix localPointToGlobal: camera up).
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions' stamp: 'ti 6/20/2000 15:47'!
transformWithMatrix: matrix
	| camera |
	camera := scene defaultCamera.
	camera position: (matrix localPointToGlobal: camera position).
	camera up: (matrix localPointToGlobal: camera up).
	self updateHeadlight.
	self changed.! !

!AdvancedB3DSceneMorph methodsFor: 'camera actions'!
updateHeadlight

	| headLight camera |
	camera := scene defaultCamera.
	(self scene lights isKindOf: Dictionary)
		ifTrue: [headLight := self scene lights at: '$HeadLight$' ifAbsent: []]
		ifFalse: [headLight := nil].
	headLight
		ifNil: [
			((headLightStatus = #on) and: [self scene lights isKindOf: Dictionary]) ifTrue: [
				self scene lights at: '$HeadLight$' put: savedHeadLight.
				headLight := savedHeadLight]]
		ifNotNil: [
			(headLightStatus = #off) ifTrue: [
				savedHeadLight := headLight.
				self scene lights removeKey: '$HeadLight$']].
	headLight ifNotNil: [
		headLight
			position: camera position;
			target: camera target].
! !


!AdvancedB3DSceneMorph methodsFor: 'drawing' stamp: 'ti 3/24/2000 17:12'!
renderOn: aRenderer
	aRenderer getVertexBuffer flags: (aRenderer getVertexBuffer flags bitOr: VBTwoSidedLighting).
	super renderOn: aRenderer! !


!AdvancedB3DSceneMorph methodsFor: 'event handling' stamp: 'ti 3/24/2000 17:01'!
handlesMouseDown: evt
	evt yellowButtonPressed ifTrue: [^false] ifFalse: [^true]
! !

!AdvancedB3DSceneMorph methodsFor: 'event handling' stamp: 'ti 6/20/2000 18:18'!
mouseDown: evt
	oldPoint := evt cursorPoint.
	super mouseDown: evt.! !

!AdvancedB3DSceneMorph methodsFor: 'event handling' stamp: 'ti 6/21/2000 09:00'!
mouseMove: evt
	oldPoint ifNil: [^super mouseMove: evt].
	(evt redButtonPressed) ifTrue: [
		(evt shiftPressed)
			ifTrue: [self panBy: oldPoint - evt cursorPoint]
			ifFalse: [
				(oldPoint = evt cursorPoint) ifFalse: [
					(self rotateFrom: oldPoint to: evt cursorPoint)]].
		oldPoint := evt cursorPoint].! !


!AdvancedB3DSceneMorph methodsFor: 'initialization' stamp: 'ti 3/27/2000 10:51'!
createDefaultScene
	| camera headLight |
	super createDefaultScene.
	camera _ B3DCamera new.
	camera position: 0@0@-6.
	camera target: 0@0@0.
	camera fov: 15.0.
	scene defaultCamera: camera.
	headLight := B3DSpotLight new.
	headLight position: 0@-1@0.
	headLight target: 0@0@0.
	headLight lightColor: (B3DMaterialColor color: (Color blue)).
	headLight attenuation: (B3DLightAttenuation constant: 1.0 linear: 0.0 squared: 0.0).
	headLight minAngle: 5.
	headLight maxAngle: 6.
	scene lights add: headLight.
	scene objects do: [ :object |
		object material: nil]! !

!AdvancedB3DSceneMorph methodsFor: 'initialization' stamp: 'ti 5/10/2000 11:21'!
initialize
	super initialize.
	self stepTime: 0.
	self rotationAngle: 1.
	self beRotating.
	self switchHeadLightOn.! !


!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 3/24/2000 16:37'!
beRotating
	isRotating := true.! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 3/24/2000 16:37'!
beStill
	isRotating := false.! !

!AdvancedB3DSceneMorph methodsFor: 'properties'!
headLightIsOn
	^(headLightStatus = #on)! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 3/24/2000 16:37'!
isRotating
	^isRotating! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 5/10/2000 11:20'!
switchHeadLightOff
	headLightStatus := #off.
	self updateHeadlight.
	self changed! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 5/10/2000 11:20'!
switchHeadLightOn
	headLightStatus := #on.
	self updateHeadlight.
	self changed! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 5/10/2000 11:21'!
switchHeadLightStatus
	(headLightStatus = #on)
		ifTrue: [self switchHeadLightOff]
		ifFalse: [self switchHeadLightOn]! !

!AdvancedB3DSceneMorph methodsFor: 'properties' stamp: 'ti 3/24/2000 16:37'!
switchRotationStatus
	self isRotating
		ifTrue: [self beStill]
		ifFalse: [self beRotating]! !


!AdvancedB3DSceneMorph methodsFor: 'stepping' stamp: 'ti 3/27/2000 16:55'!
step
	self isRotating ifTrue: [
		scene defaultCamera rotateBy: self rotationAngle.
		self updateHeadlight.
		self changed.].! !


!AdvancedB3DSceneMorph methodsFor: 'private' stamp: 'ti 6/21/2000 10:39'!
pointOnSphereCentered: center radius: radius atPoint: aPoint
	| x y z r s |
	x := (aPoint x - center x) / radius.
	y := (aPoint y - center y) / radius.
	r := (x * x) + (y * y).
	(r > 1.0)
		ifTrue: [
			s := 1.0 / (r sqrt).
			x := s * x negated.
			y := s * y.
			z := 0.0]
		ifFalse: [ z := (1.0 - r) sqrt].
	^B3DVector3 x: x y: y negated z: z! !

!AdvancedB3DSceneMorph methodsFor: 'private'!
updateSceneWithDefaults: myScene
	| headLight mat |
	myScene lights at: 'Ambient1' put: (B3DAmbientLight color: (Color gray: 0.2)).
	headLight := B3DSpotLight new.
	headLight position: myScene defaultCamera position.
	headLight target: myScene defaultCamera target.
	headLight lightColor: (B3DMaterialColor color: (Color gray: 0.7)).
	headLight attenuation: (B3DLightAttenuation constant: 1.0 linear: 0.0 squared: 0.0).
	headLight minAngle: 80.
	headLight maxAngle: 90.
	myScene lights at: '$HeadLight$' put: headLight copy.
	mat := B3DMaterial new.
	mat diffusePart: (Color gray: 0.25).
	mat ambientPart: (Color gray: 0.01).
	myScene objects do: [:o|
		o material: mat].
	^myScene! !

!AdvancedB3DSceneMorph methodsFor: 'private'!
updateUpVectorForCamera: aCamera
	| oldUp |
	oldUp := aCamera up.
	aCamera up:
		((aCamera direction cross: oldUp) cross: (aCamera direction))! !
ScrollPane subclass: #AlansTextPlusMorph
	instanceVariableNames: 'theTextMorph thePasteUp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!
!AlansTextPlusMorph commentStamp: '<historical>' prior: 0!
The code is here, but the class you really want to use is GeeMailMorph (nicer name).!


!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 13:58'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'make a book of me' action: #convertToBook.
! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/30/2000 15:06'!
adjustPasteUpSize

	| newBottom |

	thePasteUp ifNil: [^self].
	newBottom _ thePasteUp bottom max: thePasteUp boundingBoxOfSubmorphs bottom + 20.
	thePasteUp height: (newBottom - thePasteUp top max: self height).
	thePasteUp width: (thePasteUp width max: scroller innerBounds width - 5).! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:03'!
convertToBook

	GeeBookMorph new 
		geeMail: thePasteUp;
		rebuildPages;
		openInWorld! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:55'!
drawOn: aCanvas

	super drawOn: aCanvas.! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 15:33'!
handlesMouseDown: evt

	^false! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 12:02'!
initialize

	super initialize.
	color _ Color white.
	thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0; color: color.
	scroller addMorph: thePasteUp.
	theTextMorph _ TextPlusMorph new position: 4@4; scrollerOwner: self.
	thePasteUp theTextMorph: theTextMorph.
	self position: 100@100.
	self extent: Display extent // 3.
	self useRoundedCorners.
! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:32'!
layoutChanged

	self setScrollDeltas.
	super layoutChanged.
	self adjustPasteUpSize.
! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:58'!
leftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	^ self totalScrollRange - bounds height max: 0
! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/6/2000 16:36'!
mouseUp: evt inMorph: aMorph

	evt hand grabMorph: aMorph	"old instances may have a handler we no longer use"! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:25'!
printPSToFile

	thePasteUp printer doPages! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:11'!
scrollSelectionIntoView: event alignTop: alignTop
	"Scroll my text into view if necessary and return true, else return false"

	| selRects delta selRect rectToTest transform cpHere |

	selRects _ theTextMorph paragraph selectionRects.
	selRects isEmpty ifTrue: [^ false].
	rectToTest _ selRects first merge: selRects last.
	transform _ scroller transformFrom: self.
	(event notNil and: [event anyButtonPressed]) ifTrue:  "Check for autoscroll"
		[cpHere _ transform localPointToGlobal: event cursorPoint.
		cpHere y <= self top
			ifTrue: [rectToTest _ selRects first topLeft extent: 2@2]
			ifFalse: [cpHere y >= self bottom
					ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2]
					ifFalse: [^ false]]].
	selRect _ transform localBoundsToGlobal: rectToTest.
	selRect height > bounds height
		ifTrue: [^ false].  "Would not fit, even if we tried to scroll"
	alignTop ifTrue: [
		self scrollBy: 0@(bounds top - selRect top).
		^ true
	].
	selRect bottom > bounds bottom ifTrue: [
		self scrollBy: 0@(bounds bottom - selRect bottom - 30).
		^ true
	].
	(delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue: [
		"Scroll end of selection into view if necessary"
		self scrollBy: 0@delta y.
		^ true].
	^ false! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:42'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. The default implementation returns false.
NOTE: the event is assumed to be in global (world) coordinates."

	^false! !

!AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 16:25'!
wantsSlot

	^false! !

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

AlansTextPlusMorph class
	instanceVariableNames: ''!

!AlansTextPlusMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 9/10/2000 12:52'!
includeInNewMorphMenu

	^ false		"to encourage the use of GeeMail instead"! !
Object subclass: #Alarm
	instanceVariableNames: 'alarmTask alarmTime myScheduler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!Alarm commentStamp: '<historical>' prior: 0!
This class implements the alarms for Wonderlands. The user specifies the time the alarm should go off (either in a certain amount of time or at a specific moment) and the task the system should execute when the alarm goes off.
!


!Alarm methodsFor: 'accessing' stamp: 'jsp 2/1/1999 14:50'!
checkTime
	"Returns the time the alarm is set to go off at"

	^ alarmTime.
! !


!Alarm methodsFor: 'management' stamp: 'jsp 1/29/1999 14:49'!
execute
	"Execute the appointed task because it's the appointed hour"

	alarmTask value.
! !

!Alarm methodsFor: 'management' stamp: 'jsp 2/1/1999 12:12'!
setScheduler: scheduler
	"Set the Scheduler that manages this Alarm"

	myScheduler _ scheduler.
! !

!Alarm methodsFor: 'management' stamp: 'jsp 2/1/1999 10:58'!
setTask: task
	"Specifies the task the alarm executes when it goes off"

	alarmTask _ task.
! !

!Alarm methodsFor: 'management' stamp: 'jsp 2/1/1999 10:59'!
setTime: time
	"Specifies the time the alarm goes off"

	alarmTime _ time.
! !

!Alarm methodsFor: 'management' stamp: 'jsp 2/1/1999 16:33'!
stop
	"This method removes the Alarm from myScheduler's list of active Alarms"

	myScheduler removeAlarm: self.
! !

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

Alarm class
	instanceVariableNames: ''!

!Alarm class methodsFor: 'intialize-release' stamp: 'jsp 2/8/1999 16:07'!
do: task at: executeTime inScheduler: scheduler
	"Creates an alarm that does the specified task at the specified time"

	| newAlarm |
	newAlarm _ Alarm new.

	newAlarm setTime: executeTime.
	newAlarm setTask: task.
	newAlarm setScheduler: scheduler.

	scheduler addAlarm: newAlarm.

	^ newAlarm.! !

!Alarm class methodsFor: 'intialize-release' stamp: 'jsp 2/8/1999 16:06'!
do: task in: waitTime inScheduler: scheduler
	"This sets an alarm that will expire in waitTime seconds and execute the specified task"

	| newAlarm |
	newAlarm _ Alarm new.

	newAlarm setTask: task.
	newAlarm setTime: waitTime + (scheduler getTime).
	newAlarm setScheduler: scheduler.

	scheduler addAlarm: newAlarm.

	^ newAlarm.
! !
EllipseMorph subclass: #AlertMorph
	instanceVariableNames: 'onColor offColor myObjSock socketOwner '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Audio-Chat'!

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'TBP 3/5/2000 13:47'!
canHaveFillStyles
	^false! !

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'TBP 3/5/2000 13:47'!
color: aColor

	super color: aColor.
	onColor _ aColor.! !

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'TBP 3/5/2000 13:47'!
initialize

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

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/2000 10:39'!
socketOwner: aChatGUI

	socketOwner _ aChatGUI.! !

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/7/2000 08:22'!
step

	super step.
	offColor ifNil: [offColor _ onColor mixed: 0.5 with: Color black].
	socketOwner objectsInQueue = 0 ifTrue: [
		color = offColor ifFalse: [super color: offColor].
	] ifFalse: [
		super color: (color = onColor ifTrue: [offColor] ifFalse: [onColor]).
	].
! !

!AlertMorph methodsFor: 'as yet unclassified' stamp: 'TBP 3/5/2000 13:47'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 500! !
AliceAbstractAnimation subclass: #AliceAbsoluteAnimation
	instanceVariableNames: 'lastStartState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceAbsoluteAnimation methodsFor: 'initialization' stamp: 'jsp 7/20/1999 00:12'!
prologue: currentTime
	"Extends the AliceAbstractAnimation prologue by saving the start state of the animation."

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (AliceUndoAnimation new: (self makeUndoVersion)).
					].

	(direction = Forward) ifTrue: [
									startState _ getStartStateFunction value.
									lastStartState _ startState.
									endState _ getEndStateFunction value.
								]
						ifFalse: [
									startState _ getStartStateFunction value.
									endState _ lastStartState.
								].


	super prologue: currentTime.
! !


!AliceAbsoluteAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 00:12'!
object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the animation with all the information that it needs to run."

	lastStartState _ startFunc value.

	super object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland.
! !


!AliceAbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:02'!
copy
	"Creates a copy of the animation"

	| anim |

	anim _ AliceAbsoluteAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		style: styleFunction
		duration: duration
		undoable: undoable
		inWonderland: myWonderland.

	(direction = Forward) ifFalse: [ anim reverseDirection ].

	^ anim.
! !

!AliceAbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:03'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim |

	anim _ AliceAbsoluteAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		style: styleFunction
		duration: 0.5
		undoable: false
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !

!AliceAbsoluteAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:07'!
reversed
	"Creates a reversed version of an animation"

	| anim |

	anim _ self copy reverseDirection.

	^ anim.
! !
AliceUpdateable subclass: #AliceAbstractAnimation
	instanceVariableNames: 'startTime endTime duration state direction loopCount undoable myWonderland pausedInterval animatedObject startState endState proportionDone getStartStateFunction getEndStateFunction updateFunction styleFunction '
	classVariableNames: 'Finished Forward Infinity Paused Reverse Running Stopped Waiting '
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:02'!
getAnimatedObject
	"Return the object that this animation affects"

	^ animatedObject.
! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:02'!
getLoopCount
	"Returns the animation's current loop count"

	^ loopCount.
! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:02'!
getState
	"Returns the current state of the animation."

	^ state.
! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:03'!
isDone
	"Returns true if the animation is running"

	^ (state = Stopped).
! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:03'!
isLooping
	"Returns true if the animation is looping"

	^ ( loopCount > 1) or: [ loopCount = Infinity ].
! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:03'!
setLoopCount: count
	"Sets the animation's current loop count"

	loopCount _ count.

! !

!AliceAbstractAnimation methodsFor: 'accessing' stamp: 'jsp 7/19/1999 23:03'!
setUndoable: aBoolean
	"Sets the animation's undoable property"

	undoable _ aBoolean.
! !


!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:04'!
copy

	self subclassResponsibility.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:04'!
epilogue: currentTime
	"This method does any work that needs to be done after an interation of the animation finishes."

	(loopCount = Infinity) ifTrue:
				[state _ Waiting]
	ifFalse:
				[
					loopCount _ loopCount - 1.

					(loopCount > 0) ifTrue: [ state _ Waiting ]
									ifFalse: [state _ Stopped.
											 loopCount _ 1 ].
				].

! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:04'!
getDuration
	"This method returns the duration of the animation."

	^ duration.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:04'!
loop
	"This method causes an animation to loop forever."

	loopCount _ Infinity.

	(state = Stopped) ifTrue: [ state _ Waiting.
							  myScheduler addAnimation: self. ].
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:05'!
loop: numberOfTimes
	"This method causes an animation to loop for the specified number of times."

	loopCount _ numberOfTimes.

	(state = Stopped) ifTrue: [ state _ Waiting.
							  myScheduler addAnimation: self. ].
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:05'!
looped
	"This method creates a copy of an animation and loops it forever."

	| anim |

	anim _ self copy.
	anim setLoopCount: Infinity.

	^ anim.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:05'!
looped: numberOfTimes
	"This method creates a copy of an animation and loops it for the specified number of times."

	| anim |

	anim _ self copy.
	anim setLoopCount: numberOfTimes.

	^ anim.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:05'!
pause
	"This method pauses an active Animation."

	(state = Running) ifTrue: [ state _ Paused. 
							    pausedInterval _ (myScheduler getTime) - startTime.].
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/19/1999 23:07'!
prologue: currentTime
	"This method does any work that needs to be done before the animation starts, including possibly adding the current state to the undo stack."

	startTime _ currentTime.
	endTime _ startTime + duration.
	state _ Running.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 01:04'!
resume
	"This method resumes a paused animation"

	(state = Paused) ifTrue:
		[
			state _ Running.
			startTime _ (myScheduler getTime) - pausedInterval.
			endTime _ startTime + duration.
		]
	ifFalse: [(state = Stopped) ifTrue:
				[
					state _ Waiting.
					myScheduler addUpdateItem: self.
				].
			]


! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 01:10'!
start
	"This method starts an existing animation"

	state _ Waiting.
	loopCount _ 1.
	myScheduler addUpdateItem: self.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 01:10'!
stop
	"This method changes the state of an animation to stopped.  If it is currently active, the Scheduler will remove it from the list of active animations."

	state _ Stopped.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 01:10'!
stopLooping
	"This method causes the animation to stop looping; the current interation of the animation completes before the animation stops."

	loopCount _ 1.
! !

!AliceAbstractAnimation methodsFor: 'management' stamp: 'jsp 7/28/1999 21:51'!
update: currentTime
	"Updates the animation using the current Wonderland time"

	| newState |

	(state = Waiting) ifTrue: [self prologue: currentTime].

	(state = Running) ifTrue: [
				proportionDone _ styleFunction value: (currentTime - startTime) value: duration.
				newState _ startState interpolateTo: endState at: proportionDone.
				updateFunction value: newState.
				(currentTime >= endTime) ifTrue: [ state _ Finished. ].
							  ].

	(state = Finished) ifTrue: [self epilogue: currentTime].! !


!AliceAbstractAnimation methodsFor: 'reversing' stamp: 'jsp 7/19/1999 23:01'!
reverseDirection
	"Changes the direction an animation runs in (forward or in reverse)"

	(direction = Forward) ifTrue: [ direction _ Reverse ]
						 ifFalse: [ direction _ Forward ].
! !


!AliceAbstractAnimation methodsFor: 'private' stamp: 'jsp 7/19/1999 23:00'!
scaleDuration: scaleAmount
	"Scales the animation's duration by the specified amount"

	duration _ duration * scaleAmount.
! !

!AliceAbstractAnimation methodsFor: 'private' stamp: 'jsp 7/19/1999 23:01'!
setDirection: aDirection
	"Sets the animation's direction variable"

	direction _ aDirection.
! !


!AliceAbstractAnimation methodsFor: 'initialization' stamp: 'jsp 7/28/1999 21:51'!
object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs run."

	animatedObject _ anObject.
	updateFunction _ func.
	styleFunction _ styleFunc.
	getStartStateFunction _ startFunc.
	getEndStateFunction _ endFunc.
	duration _ time.
	undoable _ canUndo.
	myScheduler _ aWonderland getScheduler.
	myWonderland _ aWonderland.
	loopCount _ 1.
	direction _ Forward.

	state _ Waiting.
	myScheduler addAnimation: self.! !

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

AliceAbstractAnimation class
	instanceVariableNames: ''!

!AliceAbstractAnimation class methodsFor: 'class initialization' stamp: 'jsp 7/19/1999 22:57'!
initialize
	"Initialize the class variables"

	Waiting _ 1.
	Running _ 2.
	Paused _ 3.
	Finished _ 4.
	Stopped _ 5.

	Forward _ 0.
	Reverse _ 1.

	Infinity _ -1.
! !
AliceUpdateable subclass: #AliceAction
	instanceVariableNames: 'actionTask paused affectedObject lifetime stopCondition '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceAction methodsFor: 'accessing' stamp: 'jsp 7/19/1999 22:06'!
getAffectedObject
	"Returns the object affected by the action"

	^ affectedObject.
! !

!AliceAction methodsFor: 'accessing' stamp: 'jsp 7/19/1999 22:08'!
isDone
	"Returns true if the action is done executing either because it's lifetime has expired or because the specified condition is true"

	(lifetime > 0) ifTrue: [^ (lifetime < (myScheduler getTime))]
				ifFalse: [^ (stopCondition value)].
	! !

!AliceAction methodsFor: 'accessing' stamp: 'jsp 7/19/1999 22:27'!
isPaused
	"Returns true if the action is paused"

	^ paused.
! !

!AliceAction methodsFor: 'accessing' stamp: 'jsp 7/19/1999 22:28'!
pause
	"Pause the action"

	paused _ true.
! !

!AliceAction methodsFor: 'accessing' stamp: 'jsp 7/19/1999 22:28'!
resume
	"resume the action"

	paused _ false.
! !


!AliceAction methodsFor: 'management' stamp: 'jsp 7/19/1999 22:29'!
setAffectedObject: anObject
	"Sets the object affected by the action"

	affectedObject _ anObject.
! !

!AliceAction methodsFor: 'management' stamp: 'jsp 7/19/1999 22:29'!
setLifetime: howlong andCondition: condition
	"Sets how long the action should run, or the condition under which it should stop"

	lifetime _ howlong.
	stopCondition _ condition.
! !

!AliceAction methodsFor: 'management' stamp: 'jsp 7/19/1999 22:29'!
setTask: task
	"Sets the task the Action should perform each frame"

	actionTask _ task.
	paused _ false.

! !

!AliceAction methodsFor: 'management' stamp: 'jsp 7/19/1999 22:29'!
stop
	"This method removes the Action from myScheduler's list of active actions"

	stopCondition _ [ true ].
	myScheduler removeAction: self.
! !


!AliceAction methodsFor: 'update' stamp: 'jsp 7/19/1999 22:30'!
update: currentTime
	"Execute the Action's task"

	paused ifFalse: [ actionTask value ].

! !

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

AliceAction class
	instanceVariableNames: ''!

!AliceAction class methodsFor: 'initialize-release' stamp: 'jsp 7/19/1999 22:31'!
do: task eachframefor: time toObject: anObject inScheduler: scheduler
	"Creates a new AliceAction that performs the specified task each frame for (time) seconds"

	| newAction |
	newAction _ AliceAction new.

	newAction setTask: task.
	newAction setLifetime: (time + (scheduler getTime)) andCondition: [false].
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addUpdateItem: newAction.

	^ newAction.
! !

!AliceAction class methodsFor: 'initialize-release' stamp: 'jsp 7/19/1999 22:32'!
do: task eachframeuntil: condition toObject: anObject inScheduler: scheduler
	"Creates a new AliceAction that performs the specified task each frame until the specified condition holds true"

	| newAction |
	newAction _ AliceAction new.

	newAction setTask: task.
	newAction setLifetime: -1 andCondition: condition.
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addUpdateItem: newAction.

	^ newAction.
! !

!AliceAction class methodsFor: 'initialize-release' stamp: 'jsp 7/19/1999 22:33'!
do: task toObject: anObject inScheduler: scheduler
	"Creates a new AliceAction that executes the specified task each frame"

	| newAction |
	newAction _ AliceAction new.

	newAction setTask: task.
	newAction setLifetime: -1 andCondition: [false].
	newAction setAffectedObject: anObject.
	newAction setScheduler: scheduler.

	scheduler addUpdateItem: newAction.

	^ newAction.
! !
AliceHierarchical subclass: #AliceActor
	instanceVariableNames: 'myName myWorld myMesh myTexture myMaterial myColor compositeMatrix scaleMatrix isHidden isFirstClass '
	classVariableNames: ''
	poolDictionaries: 'AliceConstants '
	category: 'Balloon3D-Alice Cast'!

!AliceActor methodsFor: 'initialization' stamp: 'jsp 6/9/1999 00:11'!
initializeFor: anAliceWorld
	"Initialize the instance variables for the AliceActor"

	super initialize.

	myName _ 'Unnamed'.
	myWorld _ myWorld.
	myParent _ myWorld getScene.
	myParent addChild: self.

	"Initialize our material"
	myMaterial _ B3DMaterial new.
	myMaterial ambientPart: Color white.
	myMaterial diffusePart: Color white.
	myMaterial specularPart: Color white.

	"Set up our default properties"
	myColor _ B3DColor4 r: 1.0 g: 1.0 b: 1.0 a: 1.0.
	compositeMatrix _ B3DMatrix4x4 identity.
	scaleMatrix _ B3DMatrix4x4 identity.

	isHidden _ false.
	isFirstClass _ true.
! !


!AliceActor methodsFor: 'drawing' stamp: 'jsp 6/9/1999 00:16'!
drawMesh: aRenderer
	"Draw the mesh for this actor."

	myMaterial ifNotNil: [
			aRenderer pushMaterial.
			aRenderer material: myMaterial.
						].

	myTexture ifNotNil: [
			aRenderer pushTexture.
			aRenderer texture: myTexture.
						].

	"Note from Andreas: Using myMesh>>renderOn: here prevents meshes
		from being picked!!"
	myMesh ifNotNil: [ myMesh renderOn: aRenderer ].

	myTexture ifNotNil: [ aRenderer popTexture ].

	myMaterial ifNotNil: [ aRenderer popMaterial ].
! !

!AliceActor methodsFor: 'drawing' stamp: 'jsp 6/9/1999 00:14'!
renderOn: aRenderer
	"Draw the actor."

	"Save the old transformation matrix"
	aRenderer pushMatrix.

	"Modify the matrix using our composite matrix for position and orientation"
	aRenderer transformBy: compositeMatrix.

	"Save the new transformation matrix"
	aRenderer pushMatrix.

	"Modify the matrix using our scale matrix - we do this seperately to avoid scaling space"
	aRenderer transformBy: scaleMatrix.

	"Draw our mesh if the object is not hidden"
	(isHidden) ifFalse: [ self drawMesh: aRenderer ].

	"Remove the scaling matrix"
	aRenderer popMatrix.

	"Draw our children.
	Note: For correct picking it is important to use B3DRenderEngine>>render: here."
	myChildren do: [:child | aRenderer render: child].

	"Restore the old transformation matrix"
	aRenderer popMatrix.! !

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

AliceActor class
	instanceVariableNames: ''!

!AliceActor class methodsFor: 'instance creation' stamp: 'jsp 6/9/1999 00:10'!
newFor: anAliceWorld
	"Create a new instance for this World."

	^ super new initializeFor: anAliceWorld.
! !


!AliceActor class methodsFor: 'unique name creation' stamp: 'jsp 6/9/1999 00:09'!
uniqueNameFrom: aName
	"If aName is not an instance variable of this class, returns aName.  Otherwise it returns a unique name based on aName that is not an instance var."

	| index |

	(self instVarNames includes: aName) ifFalse: [ ^ aName ].

	index _ 2.
	[ self instVarNames includes: (aName , (index asString)) ]
		whileTrue: [ index _ index + 1 ].

	^ aName , (index asString).
	! !
AliceUpdateable subclass: #AliceAlarm
	instanceVariableNames: 'alarmTask alarmTime '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceAlarm methodsFor: 'accessing' stamp: 'jsp 7/19/1999 21:17'!
checkTime
	"Returns the time the alarm is set to go off at"

	^ alarmTime.
! !

!AliceAlarm methodsFor: 'accessing' stamp: 'jsp 7/20/1999 01:06'!
isDone
	"Returns true if the alarm has expired."

	^ (myScheduler getTime) > alarmTime.
! !


!AliceAlarm methodsFor: 'management' stamp: 'jsp 7/20/1999 01:06'!
setTask: task
	"Specifies the task the alarm executes when it goes off.  Also sets isDone to false because the task has not yet been executed."

	alarmTask _ task.

! !

!AliceAlarm methodsFor: 'management' stamp: 'jsp 7/19/1999 21:21'!
setTime: time
	"Specifies the time the alarm goes off"

	alarmTime _ time.
! !

!AliceAlarm methodsFor: 'management' stamp: 'jsp 7/20/1999 01:06'!
stop
	"This method stops the alarm."

	myScheduler removeUpdateItem: self.
! !


!AliceAlarm methodsFor: 'update' stamp: 'jsp 7/20/1999 01:06'!
update: currentTime
	"If the alarm's time has expired, then execute the task associated with the alarm."

	(alarmTime < currentTime)
			ifTrue:	[ self execute ].


! !

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

AliceAlarm class
	instanceVariableNames: ''!

!AliceAlarm class methodsFor: 'instance creation' stamp: 'jsp 7/19/1999 22:00'!
do: task at: executeTime inScheduler: scheduler
	"Creates an alarm that does the specified task at the specified time"

	| newAlarm |
	newAlarm _ AliceAlarm new.

	newAlarm setTime: executeTime.
	newAlarm setTask: task.
	newAlarm setScheduler: scheduler.

	scheduler addUpdateItem: newAlarm.

	^ newAlarm.! !

!AliceAlarm class methodsFor: 'instance creation' stamp: 'jsp 7/19/1999 22:01'!
do: task in: waitTime inScheduler: scheduler
	"This sets an alarm that will expire in waitTime seconds and execute the specified task"

	| newAlarm |
	newAlarm _ AliceAlarm new.

	newAlarm setTask: task.
	newAlarm setTime: waitTime + (scheduler getTime).
	newAlarm setScheduler: scheduler.

	scheduler addAlarm: newAlarm.

	^ newAlarm.
! !
AliceActor subclass: #AliceCamera
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Cast'!
Object subclass: #AliceHierarchical
	instanceVariableNames: 'myParent myChildren '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Cast'!

!AliceHierarchical methodsFor: 'initialization' stamp: 'jsp 6/8/1999 23:52'!
initialize
	"Initialize this instance"

	myChildren _ OrderedCollection new.
! !


!AliceHierarchical methodsFor: 'parent-child' stamp: 'jsp 6/8/1999 23:57'!
getAllChildren
	"Return all of this instance's children"

	| children |

	children _ OrderedCollection new.

	myChildren do: [:child | children addLast: child.
						children _ children , (child getAllChildren).
					].

	^ children.! !

!AliceHierarchical methodsFor: 'parent-child' stamp: 'jsp 6/8/1999 23:58'!
getChildren
	"Return the object's immediate children."

	^ (myChildren copy).
! !

!AliceHierarchical methodsFor: 'parent-child' stamp: 'jsp 6/8/1999 23:59'!
getParent
	"Return the object's parent."

	^ myParent.
! !

!AliceHierarchical methodsFor: 'parent-child' stamp: 'jsp 6/8/1999 23:59'!
setParent: anObject
	"Set this instance's parent"

	myParent _ anObject.
! !


!AliceHierarchical methodsFor: 'private' stamp: 'jsp 6/8/1999 23:54'!
addChild: aChild
	"Add an object to this instance's list of children. Checks to make sure that aChild is not already a child of this object"

	((myChildren identityIndexOf: aChild) = 0) ifTrue: [ myChildren addLast: aChild ].
! !

!AliceHierarchical methodsFor: 'private' stamp: 'jsp 6/8/1999 23:59'!
appendChildrenNamesTo: prefix
	"Return the object's children's names, each appended to the prefix."

	| nameList |

	nameList _ OrderedCollection new.
	myChildren do: [:child | nameList addLast: (prefix , (child getName)).
							nameList _ nameList , (child appendChildrenNamesTo: (prefix , '    '))].

	^ nameList.
! !

!AliceHierarchical methodsFor: 'private' stamp: 'jsp 6/8/1999 23:58'!
getChildrenNames
	"Return the object's children."

	^ myChildren collect: [: child | child asString ].
! !

!AliceHierarchical methodsFor: 'private' stamp: 'jsp 6/8/1999 23:57'!
removeChild: aChild
	"Remove an object from this instance's list of children"

	myChildren remove: aChild ifAbsent: [].

! !

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

AliceHierarchical class
	instanceVariableNames: ''!

!AliceHierarchical class methodsFor: 'instance creation' stamp: 'jsp 6/8/1999 23:52'!
new
	"Create and initialize a new instance."

	^ super new initialize.
! !
AliceActor subclass: #AliceLight
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Cast'!
Object subclass: #AliceNamespace
	instanceVariableNames: 'myDictionary myWorkspace '
	classVariableNames: ''
	poolDictionaries: 'AliceConstants '
	category: 'Balloon3D-Alice Misc'!

!AliceNamespace methodsFor: 'initialize' stamp: 'jsp 6/7/1999 21:49'!
initialize
	"Initialize the namespace"

	myDictionary _ AliceConstants copy.

	myWorkspace _ Workspace new.
	myWorkspace setBindings: myDictionary.
	myWorkspace embeddedInMorphicWindowLabeled: 'Namespace'.
! !


!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:43'!
at: key
	"Return the value in the namespace associated with the key"

	^ myDictionary at: key.
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:43'!
at: key put: value
	"Store the value in the namespace under the key"

	myDictionary at: key put: value.
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:42'!
getDictionary
	"Return the namespace dictionary"

	^ myDictionary.
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:44'!
getEvaluationContext
	"Return a context containing the namespace for evaluating a statement "

	^ (myWorkspace dependents last select model: myWorkspace).
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:55'!
includesKey: aKey
	"Return true if the namespace includes the key"

	^ myDictionary includesKey: aKey.
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/8/1999 22:57'!
removeKey: theKey
	"Remove the key from the namespace"

	myDictionary removeKey: theKey ifAbsent: [].
! !

!AliceNamespace methodsFor: 'accessing' stamp: 'jsp 6/8/1999 22:57'!
removeKey: theKey ifAbsent: failBlock
	"Remove the key from the namespace. If the key isn't there, run the code in the fail block."

	myDictionary removeKey: theKey ifAbsent: failBlock.
! !

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

AliceNamespace class
	instanceVariableNames: ''!

!AliceNamespace class methodsFor: 'instance creation' stamp: 'jsp 6/7/1999 21:46'!
new
	"Create a new namespace for an Alice world"

	^ super new initialize.
! !
Object subclass: #AlicePoolDefiner
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Misc'!

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

AlicePoolDefiner class
	instanceVariableNames: ''!

!AlicePoolDefiner class methodsFor: 'class initialization' stamp: 'jsp 6/7/1999 14:58'!
initialize
	"Initialize the Alice 2.0 pool dictionary"

	self initPool.
! !


!AlicePoolDefiner class methodsFor: 'pool definition' stamp: 'jsp 6/29/1999 00:06'!
initPool
	"Create the pool dictionary if necessary"

	| poolName |
	poolName _ #AliceConstants.
	(Smalltalk includesKey: poolName) ifFalse:[
		Smalltalk declare: poolName from: Undeclared.
	].

	(Smalltalk at: poolName) isNil ifTrue:[
		(Smalltalk associationAt: poolName)
				value: ((Smalltalk at: #WonderlandConstants) copy).
	].

	self initPool: (Smalltalk at: poolName).! !

!AlicePoolDefiner class methodsFor: 'pool definition' stamp: 'jsp 6/7/1999 15:03'!
initPool: aDictionary
	"Initialize the dictionary"

	aDictionary at: #inOrder put: #inOrder.
	aDictionary at: #together put: #together.
! !
AliceAbstractAnimation subclass: #AliceRelativeAnimation
	instanceVariableNames: 'getReverseStateFunction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceRelativeAnimation methodsFor: 'initialization' stamp: 'jsp 7/20/1999 00:15'!
object: anObject update: func getStartState: startFunc getEndState: endFunc getReverseState: reverseFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs to run."

	getReverseStateFunction _ reverseFunc.

	super object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland.
! !


!AliceRelativeAnimation methodsFor: 'management' stamp: 'jsp 7/20/1999 00:18'!
prologue: currentTime
	"Extends the AbstractAnimation prologue by saving the start state of the animation."

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (AliceUndoAnimation new: (self makeUndoVersion)).
					].

	(direction = Forward) ifTrue: [
									startState _ getStartStateFunction value.
									endState _ getEndStateFunction value.
								]
						ifFalse: [
									startState _ getStartStateFunction value.
									endState _ getReverseStateFunction value.
								].


	super prologue: currentTime.
! !


!AliceRelativeAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:16'!
copy
	"Creates a copy of the animation"

	| anim |

	anim _ AliceRelativeAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		getReverseState: getReverseStateFunction 
		style: styleFunction
		duration: duration
		undoable: undoable
		inWonderland: myWonderland.

	(direction = Forward) ifFalse: [ anim reverseDirection ].

	^ anim.
! !

!AliceRelativeAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:18'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim |

	anim _ AliceRelativeAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		getReverseState: getReverseStateFunction 
		style: styleFunction
		duration: 0.5
		undoable: false
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !

!AliceRelativeAnimation methodsFor: 'copying' stamp: 'jsp 7/20/1999 00:18'!
reversed
	"Creates a reversed version of an animation"

	| anim |

	anim _ self copy reverseDirection.

	^ anim.
! !
AliceHierarchical subclass: #AliceScene
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Cast'!
Object subclass: #AliceScheduler
	instanceVariableNames: 'currentTime elapsedTime lastSystemTime speed isRunning updateList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceScheduler methodsFor: 'initialize' stamp: 'jsp 6/7/1999 16:06'!
initialize
	"Initialize the scheduler"

	"The scheduler starts at time 0"
	currentTime _ 0.
	elapsedTime _ 0.

	"The scheduler starts executing at 1:1 time"
	speed _ 1.

	"The scheduler starts running"
	isRunning _ true.

	"Determine the system time we're starting at"
	lastSystemTime _ Time millisecondClockValue / 1000.0.

	"Create the list of items to update"
	updateList _ OrderedCollection new.
! !

!AliceScheduler methodsFor: 'initialize' stamp: 'jsp 6/7/1999 15:51'!
reset
	"Resets the Wonderland time to 0"

	self initialize.

! !


!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:53'!
getElapsedTime

	"Returns the time that elapsed in the last Scheduler tick"

	^ elapsedTime.
! !

!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:53'!
getFPS

	"Returns the instantaneous frames per second (1 / elapsedTime)"

	^ (1.0 / elapsedTime).
! !

!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:53'!
getTime

	"Returns the current scheduler time"

	^ currentTime.
! !

!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:55'!
pause
	"Pause the scheduler. Pauses all script executiong, but any active cameras continue to render."

	isRunning _ false.
! !

!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:55'!
resume
	"If the scheduler was paused, resume it."

	isRunning ifFalse: 	[ isRunning _ true.
						  lastSystemTime _ (Time millisecondClockValue) / 1000.0.
						].

! !

!AliceScheduler methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:55'!
setSpeed: newSpeed
	"This method sets the speed for the Scheduler. 1 is a 1:1 mapping with clock time, 2 is a 2:1 mapping, etc."

	(speed > 0) ifTrue: [speed _ newSpeed] ifFalse: [self error: 'Scheduler speed must be greater than 0.'].

! !


!AliceScheduler methodsFor: 'update list maintenance' stamp: 'jsp 6/7/1999 16:05'!
addUpdateItem: newItem
	"Add a new item to the scheduler's update list (a running animation, active script, etc"

	updateList addLast: newItem.
! !

!AliceScheduler methodsFor: 'update list maintenance' stamp: 'jsp 6/7/1999 16:06'!
removeUpdateItem: anItem
	"Add a new item to the scheduler's update list (a running animation, active script, etc)"

	updateList remove: anItem ifAbsent: [].
! !


!AliceScheduler methodsFor: 'ticking' stamp: 'jsp 6/7/1999 16:02'!
tick
	"Figure out how much time has elapsed since the last Scheduler tick and update all the scripts"

	isRunning ifTrue: [
			elapsedTime _ ((Time millisecondClockValue / 1000.0) - lastSystemTime) * speed.

			"if elapsedTime is negative the clock rolled over; deal with it"
			(elapsedTime < 0) ifTrue: [lastSystemTime _ 0. elapsedTime _
										(Time millisecondClockValue) / 1000.0].

			currentTime _ currentTime + elapsedTime.
			lastSystemTime _ lastSystemTime + elapsedTime.

			"Process scripts here"	
			updateList do: [:item | item update: currentTime.
								(item isDone) ifTrue: [self removeUpdateItem: item]
				].						].
! !

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

AliceScheduler class
	instanceVariableNames: ''!

!AliceScheduler class methodsFor: 'instance creation' stamp: 'jsp 6/7/1999 15:46'!
new
	"Create a new scheduler and initialize it"

	^ super new initialize.
! !
AliceUpdateable subclass: #AliceScript
	instanceVariableNames: 'scriptName myCommands activeAnimations pendingCommands scriptType isRunning myWorld '
	classVariableNames: ''
	poolDictionaries: 'AliceConstants '
	category: 'Balloon3D-Alice Scripts'!

!AliceScript methodsFor: 'initialize' stamp: 'jsp 7/20/1999 01:08'!
initialize: anAliceWorld
	"Initialize script by assigning the scheduler and putting default values in the instance variables"

	"Set the script name"
	scriptName _ 'Unnamed'.

	"Set the scheduler for this script"
	myWorld _ anAliceWorld.
	myScheduler _ myWorld getScheduler.

	"By default a script contains no commands"
	myCommands _ OrderedCollection new.

	"By default there are no active commands"
	pendingCommands _ OrderedCollection new.

	"By default there are no active animations"
	activeAnimations _ OrderedCollection new.

	"By default scripts run in order (one command after another)"
	scriptType _ inOrder.

	"By default the script isn't running"
	isRunning _ false.

! !


!AliceScript methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:59'!
getScriptName
	"Returns the name of the script"

	^ scriptName.
! !

!AliceScript methodsFor: 'accessing' stamp: 'jsp 6/7/1999 16:12'!
isDone
	"Returns true if the script is not currently running"

	^ isRunning not.
! !

!AliceScript methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:15'!
setCommands: commands
	"Set the commands in the script"

	myCommands _ commands.
! !

!AliceScript methodsFor: 'accessing' stamp: 'jsp 6/7/1999 21:59'!
setScriptName: aName
	"Sets the name of the script"

	scriptName _ aName.
! !

!AliceScript methodsFor: 'accessing' stamp: 'jsp 6/7/1999 15:14'!
setScriptType: type
	"Set the script type (inOrder or Together)"

	scriptType _ type.
! !


!AliceScript methodsFor: 'executing' stamp: 'jsp 7/20/1999 01:09'!
start
	"Start running this script"

	| result |

	(scriptType = inOrder)
		ifTrue: [
					pendingCommands _ OrderedCollection new.
					1 to: (myCommands size) do: [:i | pendingCommands addLast: i ].
				]
		ifFalse: [
					myCommands do: [:command | result _ command.
						result _ Compiler new evaluate: command in: nil to: nil
								notifying: (myWorld getNamespace
											getEvaluationContext) ifFail: [].

						myWorld addOutputText: (result printString).

						(result isKindOf: Animation)
							ifTrue: [ activeAnimations add: result ].
									].
				].


	isRunning _ true.

	"Need to add this script to the scheduler so it gets updated"
	myScheduler addUpdateItem: self.

	"Update the script once with the current time"
	self update: (myScheduler getTime).
! !

!AliceScript methodsFor: 'executing' stamp: 'jsp 6/7/1999 21:38'!
update: currentTime
	"Determine how to update this script based on the type of script it is"

	(scriptType = inOrder)
		ifTrue: [ self updateInOrder: currentTime ]
		ifFalse: [ self updateTogether: currentTime ].

! !

!AliceScript methodsFor: 'executing' stamp: 'jsp 6/8/1999 17:33'!
updateInOrder: currentTime
	"Update this script assuming that one command runs after the previous command finishes"

	| nextCommand result |

	"Update the previous command if it's still active"
	activeAnimations do: [:anim | anim update: currentTime.
								(anim isDone) ifTrue: [activeAnimations remove: anim ]].

	"Check if all active animations are complete, if not keep pulling and executing script commands until we hit one that doesn't complete immediately"
	(activeAnimations isEmpty)
		ifTrue: [ [ (pendingCommands isEmpty) or: [activeAnimations isEmpty not] ]
					whileFalse: [
						nextCommand _ myCommands at: (pendingCommands removeFirst).

						"evaluate the command in my namespace"
						result _ Compiler new evaluate: nextCommand in: nil to: nil
									notifying: (myWorld getNamespace
												getEvaluationContext) ifFail: [].

						myWorld addOutputText: (result printString).

						(result isKindOf: Animation)
							ifTrue: [ activeAnimations addLast: result ].
								].
				
				((activeAnimations isEmpty) and: [ pendingCommands isEmpty ])
					ifTrue: [ isRunning _ false ].
				].
! !

!AliceScript methodsFor: 'executing' stamp: 'jsp 6/7/1999 21:39'!
updateTogether: currentTime
	"Update this script assuming that all script commands begin simultaneously"

	activeAnimations do: [:anim | anim update: currentTime.
								(anim isDone) ifTrue: [activeAnimations remove: anim ]].

	(activeAnimations isEmpty) ifTrue: [ isRunning _ false ].


! !

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

AliceScript class
	instanceVariableNames: ''!

!AliceScript class methodsFor: 'instance creation' stamp: 'jsp 6/8/1999 13:36'!
new: type withCommands: commands in: anAliceWorld
	"Create a new nameless (lambda) script containing the specified commands"

	| newScript |

	newScript _ AliceScript new initialize: anAliceWorld.
	newScript setScriptType: type.
	newScript setCommands: commands.

	^ newScript.

! !
PluggableTextMorph subclass: #AliceTextOutputWindow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Interface'!

!AliceTextOutputWindow methodsFor: 'initialization' stamp: 'jsp 7/25/1999 23:11'!
initialize
	"Initialize the window for output."

	super initialize.

	self color: (Color r: 0.627 g: 0.909 b: 0.972).
	self openInWorld.
! !


!AliceTextOutputWindow methodsFor: 'output text' stamp: 'jsp 7/25/1999 23:09'!
addText: aString
	"Adds the specified string to the output window"

	| textLength |

	self setText: ((textMorph contents) , aString) asText.

	textLength _ textMorph contents size + 1.

	self selectFrom: textLength to: textLength.
	self scrollSelectionIntoView.
! !

!AliceTextOutputWindow methodsFor: 'output text' stamp: 'jsp 7/25/1999 23:05'!
addTextOnNewLine: aString
	"Adds the specified string to the output window as a new line"

	| textLength |

	self setText: ((textMorph contents) , (Character cr asString) , aString) asText.

	textLength _ textMorph contents size + 1.

	self selectFrom: textLength to: textLength.
	self scrollSelectionIntoView.


! !
Object subclass: #AliceUndoAnimation
	instanceVariableNames: 'wrappedAnimation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Undo'!

!AliceUndoAnimation methodsFor: 'accessing' stamp: 'jsp 7/20/1999 00:10'!
setAnimation: anAnimation
	"Set wrapped animation."

	wrappedAnimation _ anAnimation.
! !


!AliceUndoAnimation methodsFor: 'undoing' stamp: 'jsp 7/20/1999 00:10'!
undoIt
	"Undo by running the wrapped animation."

	wrappedAnimation start.
! !

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

AliceUndoAnimation class
	instanceVariableNames: ''!

!AliceUndoAnimation class methodsFor: 'instance creation' stamp: 'jsp 7/20/1999 00:11'!
new: anAnimation
	"Create a wrapper for undoing an animation"

	| newUndo |

	newUndo _ UndoAnimation new.
	newUndo setAnimation: anAnimation.
	^ newUndo.! !
Object subclass: #AliceUpdateable
	instanceVariableNames: 'myScheduler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Alice Time'!

!AliceUpdateable methodsFor: 'management' stamp: 'jsp 7/20/1999 00:59'!
setScheduler: scheduler
	"Set the Scheduler that manages this updateable item"

	myScheduler _ scheduler.
! !

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

AliceUpdateable class
	instanceVariableNames: ''!

!AliceUpdateable class methodsFor: 'instance creation' stamp: 'jsp 7/19/1999 21:54'!
new
	"Create and initialize a new instance"

	super new initialize.
! !
Object subclass: #AliceWorld
	instanceVariableNames: 'myScheduler myNamespace myUndoStack sharedMeshDict sharedTextureDict cameraList lightList myScene actorClassList myTextOutputWindow '
	classVariableNames: 'ActorPrototypeClasses '
	poolDictionaries: 'AliceConstants '
	category: 'Balloon3D-Alice Worlds'!

!AliceWorld methodsFor: 'temporary' stamp: 'jsp 6/8/1999 22:52'!
makeActorFrom: filename
	"Creates a new actor using the specification from the given file"

	| aFile words line startSubstr index parent name texture meshFile matrix baseActor newActor protoClass actorClass fileVersion |

	myUndoStack closeStack.
	words _ (filename findTokens: #.).

	((words last) = 'mdl') ifTrue: [
			aFile _ (CrLfFileStream readOnlyFileNamed: filename) ascii.

			"First see if we need to create a prototype class for this model"
			(ActorPrototypeClasses includesKey: (aFile localName))
					ifTrue: [ protoClass _ ActorPrototypeClasses at: (aFile localName) ]
					ifFalse: [
							"Make a new prototype class for this model"
							protoClass _ (WonderlandActor newUniqueClassInstVars: ''
															classInstVars: '').
							ActorPrototypeClasses at: (aFile localName) put: protoClass.
							].

			"Check what version this mdl file is"
			line _ aFile upTo: (Character cr).
			line _ aFile upTo: (Character cr).
			line _ aFile upTo: (Character cr).

			((line truncateTo: 7) = 'version')
					ifTrue: [ fileVersion _ 1 ]
					ifFalse: [ fileVersion _ 0 ].

			[ line _ aFile upTo: (Character cr).
			  (aFile atEnd) ifTrue: [ true ]
			  			ifFalse: [ words _ line findTokens: '='.
								  false ]
			] whileFalse: [

					"See if we're creating a new object"
					(((words size) > 1) and: [ ((words at: 2) beginsWith: ' _MakeObject')
											or: [ (words at: 2) beginsWith: ' Alice.MakeObject' ] ])

						ifTrue: [
						(fileVersion = 0)
							ifTrue: [
								words _ line findTokens: #,.
								parent _ (words at: 2) withBlanksTrimmed.
								name _ (((words at: 3) withBlanksTrimmed)
													findBetweenSubStrs: '"') at: 1.
									]
							ifFalse: [
								name _ (words at: 1) truncateTo: (((words at: 1) size) - 1).
								parent _ ((words at: 3) findTokens: #,) at: 1.
									].

						"Now pull in the texture to use"
						startSubstr _ name , '.SetTexture'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						texture _ (line findBetweenSubStrs: '"') at: 2.
						texture _ (aFile directory pathName), FileDirectory slash, texture.

						"Read the composite matrix to use"
						startSubstr _ name , '._SetLocalTransformation'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						matrix _ B3DMatrix4x4 new.
						words _ line findBetweenSubStrs: ',()'.
						words removeAllSuchThat: [:str | str = ' '].

						index _ words size.
						4 to: 1 by: -1 do: [:i | 
							4 to: 1 by: -1 do: [:j | matrix at: i at: j put: 
										((words at: index) withBlanksTrimmed) asNumber.
										   		index _ index - 1. ]. ].

						1 to: 4 do: [:i | index _ matrix at: i at: 4.
									   matrix at: i at: 4 put: (matrix at: 4 at: i).
									   matrix at: 4 at: i put: index. ].

						matrix a14: (matrix a14 negated).

						"Read the mesh file to use"
						startSubstr _ 'LoadGeometry'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						meshFile _ (line findBetweenSubStrs: '"') at: 2.
						meshFile _ (aFile directory pathName), FileDirectory slash, meshFile.

						"Now build the actor name"
						words _ name findTokens: '.'.
						name _ words last.
						name at: 1 put: ((name at: 1) asLowercase).

						"Now build the parent name"
						parent _ parent copyReplaceAll: '.' with: ' '.

						"Now create the object"
						(parent = 'None') ifTrue: [
								actorClass _ protoClass newUniqueClassInstVars: '' classInstVars: ''.
								baseActor _ actorClass createFor: self.
								actorClassList addLast: actorClass.
								baseActor setName: name.
								baseActor setTexture: texture.
								baseActor loadMeshFromFile: meshFile.
								baseActor setComposite: matrix.
												]  "end base actor creation"

										ifFalse: [
								actorClass _ WonderlandActor newUniqueClassInstVars: ''
																classInstVars: ''.
								newActor _ actorClass createFor: self.
								actorClassList addLast: actorClass.
								newActor setName: name.
								parent _ (baseActor getChildNamed: parent).
								newActor reparentTo: parent.
								newActor becomePart.
								newActor setTexture: texture.
								newActor loadMeshFromFile: meshFile.
								newActor setComposite: matrix.
												]. "end new actor with parent"

															]. "end MakeObject parsing"

											]. "end file parsing"

			aFile close.
			myUndoStack openStack.

			"Ensure that the new actor's name is unique"
			name _ self uniqueNameFrom: (baseActor getName).
			baseActor setName: name.
			myNamespace at: name put: baseActor.

			"Add an undo item to undo the creation of this object"
			myUndoStack push: (UndoAction new: [ baseActor removeFromScene.
													myNamespace removeKey: name ifAbsent: [].
												  ] ).

			^ baseActor.
								]. " end mdl file parsing"
! !

!AliceWorld methodsFor: 'temporary' stamp: 'jsp 6/8/1999 23:06'!
makeLight
	"Create a light of the specified type and add it to the Wonderland"

	| theLight lightType name |

	lightType _ positional.

	"Make sure the user gave us a type of light"
	[ WonderlandVerifier VerifyLight: lightType ]
		ifError: [ :msg :rcvr |
			self reportErrorToUser:
				'Squeak could not determine the type of light to create because ', msg.
			^ nil ].

	"The user gave us a valid type type, so proceed"
	(lightType = ambient)
		ifTrue: [ theLight _ WonderlandAmbientLight createFor: self. ]
		ifFalse: [ (lightType = positional)
			ifTrue: [ theLight _ WonderlandPositionalLight createFor: self. ]
			ifFalse: [ (lightType = directional)
				ifTrue: [ theLight _ WonderlandDirectionalLight createFor: self. ]
				ifFalse: [ theLight _ WonderlandSpotLight createFor: self. ]
					]
				].

	name _ self uniqueNameFrom: 'light'.
	theLight setName: name.
	myNamespace at: name put: theLight.

	lightList addLast: theLight.

	^ theLight.
! !

!AliceWorld methodsFor: 'temporary' stamp: 'jsp 6/8/1999 23:05'!
makeLight: lightType
	"Create a light of the specified type and add it to the Wonderland"

	| theLight name |

	"Make sure the user gave us a type of light"
	[ WonderlandVerifier VerifyLight: lightType ]
		ifError: [ :msg :rcvr |
			self reportErrorToUser:
				'Squeak could not determine the type of light to create because ', msg.
			^ nil ].

	"The user gave us a valid type type, so proceed"
	(lightType = ambient)
		ifTrue: [ theLight _ WonderlandAmbientLight createFor: self. ]
		ifFalse: [ (lightType = positional)
			ifTrue: [ theLight _ WonderlandPositionalLight createFor: self. ]
			ifFalse: [ (lightType = directional)
				ifTrue: [ theLight _ WonderlandDirectionalLight createFor: self. ]
				ifFalse: [ theLight _ WonderlandSpotLight createFor: self. ]
					]
				].

	name _ self uniqueNameFrom: 'light'.
	theLight setName: name.
	myNamespace at: name put: theLight.

	lightList addLast: theLight.

	^ theLight.
! !

!AliceWorld methodsFor: 'temporary' stamp: 'jsp 6/8/1999 22:51'!
renderWonderland: aRenderer
	"Temporary method"

	self renderWorld: aRenderer.

! !


!AliceWorld methodsFor: 'initialize-reset-release' stamp: 'jsp 7/25/1999 23:10'!
initialize
	"Initialize the Alice world"

	| defaultCamera |

	"Initialize this Wonderland's shared namespace"
	myNamespace _ AliceNamespace new.
	myNamespace at: 'world' put: self.

	"Create the Wonderland's scheduler"
	myScheduler _ AliceScheduler new.
	myNamespace at: 'scheduler' put: myScheduler.

	"Initialize the list of actor UniClasses"
	actorClassList _ OrderedCollection new.

	"Initialize the shared mesh and texture directories"
	sharedMeshDict _ Dictionary new.
	sharedTextureDict _ Dictionary new.

	"Create an output window for us to dump text to"
	myTextOutputWindow _ AliceTextOutputWindow new.
	myTextOutputWindow setText: 'Squeak Alice v2.0.'.

	cameraList _ OrderedCollection new.
	lightList _ OrderedCollection new.

	"-------------------------------"

	"Create the undo stack for this Wonderland."
	myUndoStack _ WonderlandUndoStack new.

	"The scene object is the root of the object tree - all objects in the Wonderland are children (directly or indirectly) of the scene. "
	myScene _ WonderlandScene newFor: self.
	myNamespace at: 'scene' put: myScene.

	"Create the default camera"
	defaultCamera _ WonderlandCamera createFor: self.
	cameraList addLast: defaultCamera.
	myNamespace at: 'camera' put: defaultCamera.
	myNamespace at: 'cameraWindow' put: (defaultCamera getMorph).
	defaultCamera setName: 'camera'.

	myUndoStack reset.
! !

!AliceWorld methodsFor: 'initialize-reset-release' stamp: 'jsp 6/8/1999 22:46'!
release
	"This method cleans up the world."

	"Clean up any uniclasses we created"
	actorClassList do: [:aClass | aClass removeFromSystem ].

	"Clean up the output window"
	myTextOutputWindow delete.

	"Get rid of our cameras"
	cameraList do: [:camera | camera release].
! !

!AliceWorld methodsFor: 'initialize-reset-release' stamp: 'jsp 6/8/1999 17:19'!
reset
	"Reset this Wonderland"

	"Initialize this Wonderland's shared namespace"
	myNamespace _ AliceNamespace new.

	"Reset the scheduler"
	myScheduler reset.

	"Reset the shared mesh and texture directories"
	sharedMeshDict _ Dictionary new.
	sharedTextureDict _ Dictionary new.

	"Reset the list of actor uniclasses"
	actorClassList do: [:aClass | aClass removeFromSystem ].
	actorClassList _ OrderedCollection new.

	"Rebuild the namespace"
	myNamespace at: 'scheduler' put: myScheduler.
	myNamespace at: 'world' put: self.

	"Create a new text output window"
	myTextOutputWindow setText: 'Reset'.

! !


!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 22:55'!
getActorClassList
	"Return the list of actor classes"

	^ actorClassList.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 22:39'!
getCameras
	"Return the list of cameras in the scene"

	^ cameraList.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:36'!
getDefaultCamera
	"Return the default camera, which is the camera at the front of the camera list"

	^ cameraList first.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 22:39'!
getLights
	"Return the list of lights in the scene"

	^ lightList.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 17:38'!
getNamespace
	"Return this world's namespace"

	^ myNamespace.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:37'!
getScene
	"Return the world's scene"

	^ myScene.

! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 17:56'!
getScheduler
	"Return this world's scheduler"

	^ myScheduler.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:47'!
getSharedMeshDict
	"Return the shared mesh dictionary"

	^ sharedMeshDict.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:47'!
getSharedTextureDict
	"Return the shared texture dictionary"

	^ sharedTextureDict.
! !

!AliceWorld methodsFor: 'accessing' stamp: 'jsp 6/8/1999 21:38'!
getUndoStack
	"Return the world's undo stack"

	^ myUndoStack.

! !


!AliceWorld methodsFor: 'creating scripts' stamp: 'jsp 6/8/1999 13:37'!
doInOrder: commands
	"Create a nameless inOrder script with the specified commands"

	^ AliceScript new: inOrder withCommands: commands in: self.
! !

!AliceWorld methodsFor: 'creating scripts' stamp: 'jsp 6/8/1999 13:37'!
doTogether: commands
	"Create a nameless together script with the specified commands"

	^ AliceScript new: together withCommands: commands in: self.
! !


!AliceWorld methodsFor: 'creating actors' stamp: 'jsp 6/8/1999 23:12'!
fixNameFrom: aString
	"Fix the name to be a valid Smalltalk name (e.g., so that we can compile it as an inst var and accessor message)"

	| aName |

	aName _ aString select: [:c | c isAlphaNumeric].

	"If the name is empty use 'unknown'"
	aName isEmpty ifTrue:[aName _ 'unknown'].

	"Make sure the first letter is lowercase"
	aName first isUppercase
		ifTrue: [aName _ (aName first asLowercase asString) ,
								(aName copyFrom: 2 to: aName size) ].

	"Make sure the first letter is a letter, otherwise use 'a' as the first letter"
	aName first isLetter ifFalse: [aName _ 'a' , aName].

	^ aName.
! !

!AliceWorld methodsFor: 'creating actors' stamp: 'jsp 6/8/1999 23:12'!
uniqueNameFrom: aString
	"If aName is unique to this world's namespace, returns that name. Otherwise creates a unique variant and returns that."

	| index aName |

	aName _ self fixNameFrom: aString.

	(myNamespace includesKey: aName)
			ifFalse: [ ^ aName ]
			ifTrue: [
						index _ 2.
						[ myNamespace includesKey: (aName , (index asString)) ]
							whileTrue: [ index _ index + 1 ].
						^ aName , (index asString).
					].
! !


!AliceWorld methodsFor: 'user feedback' stamp: 'jsp 6/8/1999 17:20'!
addOutputText: thisText
	"Appends the given text to the Alice output window"

	myTextOutputWindow addTextOnNewLine: thisText.
! !

!AliceWorld methodsFor: 'user feedback' stamp: 'jsp 6/8/1999 21:52'!
reportErrorToUser: errorString
	"When any object in an Alice World discovers an error it creates an error report and then calls this method to display the error to the user."

	| errWin tm |

	errWin _ SystemWindowWithButton labelled: 'Ooops'.
	errWin openInWorldExtent: 400@100.
	errWin color: (Color white).

	tm _ TextMorph new.
	tm initialize.
	errWin addMorph: tm.

	tm color: (Color red).
	tm contents: errorString wrappedTo: 380.
	tm position: ((errWin position) + (10@20)).
	tm lock.

	errWin height: (tm height) + 30.

	errorSound play.



! !


!AliceWorld methodsFor: 'undoing actions' stamp: 'jsp 6/8/1999 21:52'!
undo
	"Undo the last action the user performed in the Wonderland.  This pulls a block context off the animation stack and executes it."

	myUndoStack popAndUndo.
! !


!AliceWorld methodsFor: 'drawing' stamp: 'jsp 6/8/1999 21:48'!
renderWorld: aRenderer
	"Tell all the objects in the World to render themselves."

	myScene renderOn: aRenderer.

! !


!AliceWorld methodsFor: 'private' stamp: 'jsp 6/8/1999 22:42'!
getTextOutputWindow
	"Returns the current text output window"

	^ myTextOutputWindow.
! !

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

AliceWorld class
	instanceVariableNames: ''!

!AliceWorld class methodsFor: 'instance creation' stamp: 'jsp 6/7/1999 22:27'!
new   "AliceWorld new" 
	"Create and initialize a new AliceWorld."

	B3DPrimitiveEngine isAvailable ifFalse: [
	(self confirm: 'WARNING: This Squeak does not have real 3D support.
Opening a Wonderland will EXTREMELY time consuming.
Are you sure you want to do this?
(NO is probably the right answer :-)') ifFalse: [^ self]].

	Display depth < 8 ifTrue:
		[(self confirm: 'The display depth should be set to at least 8 bit.
Shall I do this now for you?') ifTrue: [Display newDepth: 8]].

	^ super new initialize.

! !


!AliceWorld class methodsFor: 'class initialization' stamp: 'jsp 6/7/1999 22:17'!
initialize
	"Initialize the AliceWorld class by creating the ActorPrototypeClasses collection"

	ActorPrototypeClasses _ Dictionary new.
! !


!AliceWorld class methodsFor: 'actor prototype mgmt' stamp: 'jsp 6/7/1999 22:18'!
removeActorPrototypesFromSystem
	"Clean out all the actor prototypes - this involves removing those classes from the Smalltalk dictionary"

	ActorPrototypeClasses do: [:aClass | aClass removeFromSystem ].

	ActorPrototypeClasses _ Dictionary new.! !
RectangleMorph subclass: #AlignmentMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 10/25/2000 17:53'!
addUpDownArrowsFor: aMorph
	"Add a column of up and down arrows that serve to send upArrowHit and downArrowHit to aMorph when they're pressed/held down"

	| holder downArrow upArrow |
	holder _ Morph new extent: 16 @ 16; beTransparent.
	downArrow _ ImageMorph new image: (ScriptingSystem formAtKey: 'DownArrow').
	upArrow _ ImageMorph new image: (ScriptingSystem formAtKey: 'UpArrow').
	upArrow position: holder bounds topLeft + (2@2).
	downArrow align: downArrow bottomLeft
				with: holder topLeft + (0 @ TileMorph defaultH) + (2@-2).
	holder addMorph: upArrow.
	holder addMorph: downArrow.
	self addMorphBack: holder.
	upArrow on: #mouseDown send: #upArrowHit to: aMorph.
	upArrow on: #mouseStillDown send: #upArrowHit to: aMorph.
	downArrow on: #mouseDown send: #downArrowHit to: aMorph.
	downArrow on: #mouseStillDown send: #downArrowHit to: aMorph.! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 22:26'!
initialize

	super initialize.
	borderWidth _ 0.
	self layoutPolicy: TableLayout new.
	self listDirection: #leftToRight.
	self wrapCentering: #topLeft.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	self layoutInset: 2.
	color _ Color r: 0.8 g: 1.0 b: 0.8.
	self rubberBandCells: true. "default"! !

!AlignmentMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:34'!
openInWindowLabeled: aString inWorld: aWorld

	self layoutInset: 0.
	^super openInWindowLabeled: aString inWorld: aWorld.! !


!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' stamp: 'panda 4/25/2000 15:44'!
configureForKids
	self disableDragNDrop.
	super configureForKids
! !






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


!AlignmentMorph methodsFor: 'object fileIn' stamp: 'RAA 12/21/2000 11:25'!
convertOldAlignmentsNov2000: varDict using: smartRefStrm

	"major change - much of AlignmentMorph is now implemented more generally in Morph"

	"These are going away 
	#('orientation' 'centering' 'hResizing' 'vResizing' 
	'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')"

	| orientation centering hResizing vResizing inset minCellSize inAlignment |
	orientation _ varDict at: 'orientation'.
	centering _ varDict at: 'centering'.
	hResizing _ varDict at: 'hResizing'.
	vResizing _ varDict at: 'vResizing'.
	inset _ varDict at: 'inset'.
	minCellSize _ varDict at: 'minCellSize'.

	(orientation == #horizontal or:[orientation == #vertical])
		ifTrue:[self layoutPolicy: TableLayout new].

	self cellPositioning: #topLeft.
	self rubberBandCells: true.

	orientation == #horizontal 
		ifTrue:[self listDirection: #leftToRight].
	orientation == #vertical 
		ifTrue:[self listDirection: #topToBottom].

	centering == #topLeft 
		ifTrue:[self wrapCentering: #topLeft].
	centering == #bottomRight 
		ifTrue:[self wrapCentering: #bottomRight].
	centering == #center 
		ifTrue:[self wrapCentering: #center.
				orientation == #horizontal
					ifTrue:[self cellPositioning: #leftCenter]
					ifFalse:[self cellPositioning: #topCenter]].

	(inset isNumber or:[inset isPoint]) 
		ifTrue:[self layoutInset: inset].
	(minCellSize isNumber or:[minCellSize isPoint]) 
		ifTrue:[self minCellSize: minCellSize].
	(self hasProperty: #clipToOwnerWidth)
		ifTrue:[self clipSubmorphs: true].

	"now figure out if our owner was an AlignmentMorph, even if it is reshaped..."
	inAlignment _ false.
	(owner isKindOf: Morph) ifTrue:[
		(owner isKindOf: AlignmentMorph) ifTrue:[inAlignment _ true].
	] ifFalse:[
		"e.g., owner may be reshaped"
		(owner class instanceVariablesString findString: 'orientation centering hResizing vResizing')
			> 0 ifTrue:["this was an alignment morph being reshaped"
						inAlignment _ true].
	].
	"And check for containment in system windows"
	(owner isKindOf: SystemWindow) ifTrue:[inAlignment _ true].
	(hResizing == #spaceFill and:[inAlignment not])
		ifTrue:[self hResizing: #shrinkWrap]
		ifFalse:[self hResizing: hResizing].
	(vResizing == #spaceFill and:[inAlignment not])
		ifTrue:[self vResizing: #shrinkWrap]
		ifFalse:[self vResizing: vResizing].

! !

!AlignmentMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 18:00'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	super convertToCurrentVersion: varDict refStream: smartRefStrm.

	"major change - much of AlignmentMorph is now implemented more generally in Morph"
	varDict at: 'hResizing' ifPresent: [ :x | 
		self convertOldAlignmentsNov2000: varDict using: smartRefStrm
	].

! !


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

AlignmentMorph class
	instanceVariableNames: ''!

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:51'!
newColumn

	^ self new
		listDirection: #topToBottom;
		hResizing: #spaceFill;
		extent: 1@1;
		vResizing: #spaceFill
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:50'!
newRow

	^ self new
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		extent: 1@1;
		borderWidth: 0
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'!
newSpacer: aColor
	"Answer a space-filling instance of me of the given color."

	^ self new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: 1@1;
		color: aColor.
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'ar 11/9/2000 20:37'!
newVariableTransparentSpacer
	"Answer a space-filling instance of me of the given color."

	^ self new
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: 1@1;
		color: Color transparent
! !
AlignmentMorph subclass: #AlignmentMorphBob1
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!AlignmentMorphBob1 commentStamp: '<historical>' prior: 0!
A quick and easy to space things vertically in absolute or proportional amounts.!


!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 16:42'!
addAColumn: aCollectionOfMorphs

	| col |
	col _ self inAColumn: aCollectionOfMorphs.
	self addMorphBack: col.
	^col! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 16:42'!
addARow: aCollectionOfMorphs

	| row |
	row _ self inARow: aCollectionOfMorphs.
	self addMorphBack: row.
	^row! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:09'!
addARowCentered: aCollectionOfMorphs

	^(self addARow: aCollectionOfMorphs)
		hResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #leftCenter! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 20:09'!
fancyText: aString ofSize: pointSize color: aColor

	| answer tm |
	answer _ self inAColumn: {
		tm _ TextMorph new 
			beAllFont: ((TextStyle default fontOfSize: pointSize) emphasized: 1);
			color: aColor;
			contents: aString
	}.
	tm addDropShadow.
	tm shadowPoint: (5@5) + tm bounds center.
	tm lock.
	^answer
! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:10'!
inAColumn: aCollectionOfMorphs

	| col |
	col _ AlignmentMorph newColumn
		color: Color transparent;
		vResizing: #shrinkWrap;
		layoutInset: 1;
		wrapCentering: #center;
		cellPositioning: #topCenter.
	aCollectionOfMorphs do: [ :each | col addMorphBack: each].
	^col! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:10'!
inARow: aCollectionOfMorphs

	| row |
	row _ AlignmentMorph newRow
		color: Color transparent;
		vResizing: #shrinkWrap;
		layoutInset: 1;
		wrapCentering: #center;
		cellPositioning: #leftCenter.
	aCollectionOfMorphs do: [ :each | row addMorphBack: each].
	^row! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:18'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self layoutInset: 0.
	borderWidth _ 0.
	self hResizing: #rigid. "... this is very unlikely..."
	self vResizing: #rigid.
! !

!AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:43'!
simpleToggleButtonFor: target attribute: attribute help: helpText

	^(EtoyUpdatingThreePhaseButtonMorph checkBox)
		target: target;
		actionSelector: #toggleChoice:;
		arguments: {attribute};
		getSelector: #getChoice:;
		setBalloonText: helpText;
		step

! !

AlignmentMorph subclass: #AllScriptsTool
	instanceVariableNames: 'presenter showingOnlyActiveScripts showingAllInstances '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!AllScriptsTool methodsFor: 'initialization' stamp: 'sw 1/30/2001 23:21'!
initializeFor: aPresenter
	"Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the world"

	| aButton aRow outerButton |
	presenter _ aPresenter.
	showingOnlyActiveScripts _ true.
	showingAllInstances _ true.
	self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap.
	self useRoundedCorners.
	self borderWidth: 4; borderColor: Color brown darker.
	self addMorph: ScriptingSystem scriptControlButtons.
	aButton _ SimpleButtonMorph new target: aPresenter; actionSelector: #updateContentsFor:; arguments: (Array with: self); label: 'Update'; color: Color lightYellow; actWhen: #buttonDown.
	aButton setBalloonText: 'Press here to get the lists of scripts updated'.
	aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent.
	aRow addMorphBack: aButton.

	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingOnlyActiveScripts;
		getSelector: #showingOnlyActiveScripts.
	outerButton addMorphBack: (StringMorph contents: 'tickers only') lock.
	outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown'.
	aRow addMorphBack: outerButton.

	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingAllInstances;
		getSelector: #showingAllInstances.
	outerButton addMorphBack: (StringMorph contents: 'all instances') lock.
	outerButton setBalloonText: 'If checked, then status of all instances will be shown, but if not checked, scripts for only one exemplar of each uniclass will be shown'.
	aRow addMorphBack: outerButton.

	self addMorphBack: aRow.
	aPresenter updateContentsFor: self.
	self layoutChanged.! !


!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/30/2001 23:18'!
showingAllInstances
	"Answer whether the receiver is currently showing controls for all instances of each uniclass."
 
	^ showingAllInstances ! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/30/2001 23:18'!
showingOnlyActiveScripts
	"Answer whether the receiver is currently showing only active scripts"
 
	^ showingOnlyActiveScripts ! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/31/2001 00:58'!
toggleWhetherShowingAllInstances
	"Toggle whether the receiver is showing all instances or only one exemplar per uniclass"

	showingAllInstances _ showingAllInstances not.
	presenter updateContentsFor: self! !

!AllScriptsTool methodsFor: 'toggles' stamp: 'sw 1/31/2001 00:58'!
toggleWhetherShowingOnlyActiveScripts
	"Toggle whether the receiver is showing only active scripts"

	showingOnlyActiveScripts _ showingOnlyActiveScripts not.
	presenter updateContentsFor: self! !


!AllScriptsTool methodsFor: 'stepping' stamp: 'sw 1/31/2001 00:31'!
step
	"Update the contents of the tool -- but this is currently not reached because of some drastic performance bug at present"

	presenter updateContentsFor: self.! !

!AllScriptsTool methodsFor: 'stepping' stamp: 'sw 1/31/2001 23:12'!
stepTime
	"Answer the interval between steps -- in this case a leisurely 4 seconds"

	^ 4000! !

!AllScriptsTool methodsFor: 'stepping' stamp: 'sw 1/31/2001 23:12'!
wantsSteps
	"Answer whether the receiver wishes to receive the #step message"

	 ^ true! !

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

AllScriptsTool class
	instanceVariableNames: ''!

!AllScriptsTool class methodsFor: 'as yet unclassified' stamp: 'sw 1/30/2001 23:06'!
launchAllScriptsToolFor: aPresenter
	"Launch an AllScriptsTool to view scripts of the given presenter"

	| aTool |
	aTool _ self newColumn.
	aTool initializeFor: aPresenter.
	self currentHand attachMorph: aTool.
	aPresenter associatedMorph world startSteppingSubmorphsOf: aTool
! !
AbstractScoreEvent subclass: #AmbientEvent
	instanceVariableNames: 'morph target selector arguments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 21:27'!
morph 
	^ morph! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 20:09'!
morph: m
	morph _ m! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 10/21/2000 13:18'!
occurAtTime: ticks inScorePlayer: player atIndex: index inEventTrack: track secsPerTick: secsPerTick
	(target == nil or: [selector == nil]) ifTrue:
		[morph ifNil: [^ self].
		^ morph encounteredAtTime: ticks inScorePlayer: player atIndex: index
				inEventTrack: track secsPerTick: secsPerTick].
	target perform: selector withArguments: arguments! !

!AmbientEvent methodsFor: 'as yet unclassified' stamp: 'di 8/3/1998 20:08'!
target: t selector: s arguments: a
	target _ t.
	selector _ s.
	arguments _ a.
! !
AbstractAnimation subclass: #Animation
	instanceVariableNames: 'startState endState proportionDone getStartStateFunction getEndStateFunction updateFunction styleFunction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!Animation commentStamp: '<historical>' prior: 0!
The Animation class extends the AbstractAnimation class with methods designed for simple (non-composite) animations.
!


!Animation methodsFor: 'initialization' stamp: 'jsp 3/9/1999 15:48'!
object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs run."

	animatedObject _ anObject.
	updateFunction _ func.
	styleFunction _ styleFunc.
	getStartStateFunction _ startFunc.
	getEndStateFunction _ endFunc.
	duration _ time.
	undoable _ canUndo.
	myScheduler _ aWonderland getScheduler.
	myWonderland _ aWonderland.
	loopCount _ 1.
	direction _ Forward.

	state _ Waiting.
	myScheduler addAnimation: self.! !


!Animation methodsFor: 'management' stamp: 'jsp 3/3/1999 12:02'!
update: currentTime
	"Updates the animation using the current Wonderland time"

	| newState |

	(state = Waiting) ifTrue: [self prologue: currentTime].

	(state = Running) ifTrue: [
				proportionDone _ styleFunction value: (currentTime - startTime) value: duration.
				newState _ startState interpolateTo: endState at: proportionDone.
				updateFunction value: newState.
				(currentTime >= endTime) ifTrue: [ state _ Finished. ].
							  ].

	(state = Finished) ifTrue: [self epilogue: currentTime].! !
Object subclass: #Applescript
	instanceVariableNames: 'compiledScript source '
	classVariableNames: 'ApplescriptGeneric '
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!Applescript commentStamp: '<historical>' prior: 0!
I represent a Squeak front-end to Applescript.  My instances represent either compiled scripts, contexts or both.  My instances maintain separately the original source code from which I was compiled, and then a CompiledApplescript corresponding to that source code in its "current state."  I provide facilities for executing my scripts, alone or in various contexts, as well as for recompiling my script to restore the script to its initial state (if the script bears context information).

Examples:

	To execute some text:

		Applescript doIt: 'beep 3'

	To compile code into a script object (for MUCH faster execution of repeated tasks, and to maintain state between execution), and then to execute the code:

		|aVariable|
		aVariable _ Applescript on: '
			property sam: 0
			set sam to sam + 1
			beep sam'.
		aVariable doIt

	Other. somewhat more general operations

		Applescript doIt: aString mode: anInteger
		Applescript doIt: aString in: aContext mode: anInteger

		s _ Applescript on: aString mode: anInteger

		s doItMode: anInteger
		s doItIn: aContext
		s doItIn: aContext mode: anInteger
		s recompile

	Also note the examples in the class side of me.
		!


!Applescript methodsFor: 'accessing' stamp: 'acg 9/26/1999 01:00'!
compiledScript

	^compiledScript! !

!Applescript methodsFor: 'accessing' stamp: 'acg 9/27/1999 00:32'!
modeDocumentation

"
	16r0000			kOSAModeNull (kOSANullMode)
	16r0001			kOSAModePreventGetSource
	16r0002			kOSAModeCompileIntoContext
	16r0004			kOSAModeAugmentContext
	16r0008			kOSAModeDisplayForHumans
					kOSAModeNeverInteract
					kOSAModeCanInteract
					kOSAModeAlwaysInteract
					kOSAModeDontReconnect
	16r0040			kOSAModeCantSwitchLayer
	16r1000			kOSAModeDoRecord
	16r4000			kOSAModeDontStoreParent"! !

!Applescript methodsFor: 'accessing' stamp: 'acg 9/26/1999 00:59'!
source

	^source! !


!Applescript methodsFor: 'testing' stamp: 'acg 9/26/1999 22:40'!
hasSource

	^self doAsOSAID: [:o | Applescript generic hasSource: o]
! !

!Applescript methodsFor: 'testing' stamp: 'acg 9/26/1999 22:39'!
isCompiledScript

	^self doAsOSAID: [:o | Applescript generic isCompiledScript: o]
! !

!Applescript methodsFor: 'testing' stamp: 'acg 9/26/1999 22:39'!
isScriptContext

	^self doAsOSAID: [:o | Applescript generic isScriptContext: o]
! !

!Applescript methodsFor: 'testing' stamp: 'acg 9/26/1999 22:39'!
isScriptValue

	^self doAsOSAID: [:o | Applescript generic isScriptValue: o]
! !

!Applescript methodsFor: 'testing' stamp: 'acg 9/26/1999 22:39'!
timesModified

	^self doAsOSAID: [:o | Applescript generic timesModified: o]
! !


!Applescript methodsFor: 'interpreting' stamp: 'acg 9/26/1999 21:13'!
asContextDoOSAID: scptOSAID mode: anInteger
	"Answer a string corresponding to the result of executing preloaded scptOSAID using my compiledScript as the context, and using mode anInteger.  As a side-effect, update my script information as necessary.  (This routine will not update any stored versions of scptOSAID"

	^self 
		doAsOSAID: 
			[:contextOSAID |
			 ApplescriptGeneric 
				executeAndDisplayOSAID: scptOSAID
				in: contextOSAID
				mode: anInteger]
		onErrorDo: 		
			[ApplescriptError 
				syntaxErrorFor: (String streamContents:
					[:aStream |
					 aStream 
						nextPutAll: (ApplescriptGeneric sourceOfOSAID: scptOSAID); cr; cr;
						nextPutAll: '<=== Source Code of Context ===>'; cr;
						nextPutAll: source])
				withComponent: ApplescriptGeneric]! !

!Applescript methodsFor: 'interpreting' stamp: 'acg 9/26/1999 20:43'!
doIt
	"Answer a string corresponding to the result of executing my script in the default context. mode 0.  As a side-effect, update my script information as necessary."

	^self doAsOSAID: [:scptOSAID |
		ApplescriptGeneric executeAndDisplayOSAID: scptOSAID in: (OSAID new) mode: 0]! !

!Applescript methodsFor: 'interpreting' stamp: 'acg 9/26/1999 21:22'!
doItIn: aContext
	"Answer a string corresponding to the result of executing my script in aContext. mode 0.  As a side-effect, update my script and the aContext information as necessary."

	^self doAsOSAID: [:scptContext |
		aContext asContextDoOSAID: scptContext mode: 0]! !

!Applescript methodsFor: 'interpreting' stamp: 'acg 9/26/1999 20:43'!
doItIn: aContext mode: anInteger
	"Answer a string corresponding to the result of executing my script in aContext. mode anInteger.  As a side-effect, update my script and the aContext information as necessary."

	^self doAsOSAID: [:scptContext |
		aContext asContextDoOSAID: scptContext mode: anInteger]! !

!Applescript methodsFor: 'interpreting' stamp: 'acg 9/26/1999 20:43'!
doItMode: anInteger
	"Answer a string corresponding to the result of executing my script in the default context. mode anInteger.  As a side-effect, update my script information as necessary."

	^self doAsOSAID: [:scptOSAID |
		ApplescriptGeneric 
			executeAndDisplayOSAID: scptOSAID 
			in: (OSAID new) 
			mode: anInteger]! !


!Applescript methodsFor: 'recompiling' stamp: 'acg 9/26/1999 20:55'!
recompile

	self on: source! !

!Applescript methodsFor: 'recompiling' stamp: 'acg 9/26/1999 20:55'!
recompileMode: anInteger

	self on: source mode: anInteger! !


!Applescript methodsFor: 'printing' stamp: 'acg 9/26/1999 22:52'!
printOn: aStream

	aStream nextPutAll: 'an Applescript('.
	self isCompiledScript ifTrue: [aStream nextPutAll: 'script '].
	self isScriptContext ifTrue: [aStream nextPutAll: 'context '].
	aStream 
		nextPutAll: compiledScript size asString;
		nextPutAll: ' bytes)'
! !


!Applescript methodsFor: 'private' stamp: 'acg 9/26/1999 20:59'!
doAsOSAID: aBlock
	"Answer the result of performing aBlock on my compiledScript, converted to OSAID form.  As a side-effect, update compiledScript to conform to any changes that may have occurred inside the Applescript scripting component."

	^self doAsOSAID: aBlock onErrorDo:
		[ApplescriptError 
			syntaxErrorFor: source 
			withComponent: ApplescriptGeneric]! !

!Applescript methodsFor: 'private' stamp: 'acg 9/27/1999 00:04'!
doAsOSAID: aCodeBlock onErrorDo: anErrorBlock
	"Answer the result of performing aBlock on my compiledScript, converted to OSAID form.  As a side-effect, update compiledScript to conform to any changes that may have occurred inside the Applescript scripting component."

	| anOSAID result |
	anOSAID _ compiledScript asAEDesc asOSAIDThenDisposeAEDescWith: ApplescriptGeneric.
	result _ aCodeBlock value: anOSAID.
	compiledScript _ (anOSAID asCompiledApplescriptWith: ApplescriptGeneric)
						ifNil: [compiledScript].
	anOSAID disposeWith: ApplescriptGeneric.
	^result ifNil: [anErrorBlock value]! !

!Applescript methodsFor: 'private' stamp: 'acg 9/26/1999 21:00'!
on: aString

	^self on: aString mode: 2 onErrorDo: 
		[ApplescriptError 
			syntaxErrorFor: aString 
			withComponent: ApplescriptGeneric]! !

!Applescript methodsFor: 'private' stamp: 'acg 9/26/1999 20:59'!
on: aString mode: anInteger

	^self on: aString mode: anInteger onErrorDo: 
		[ApplescriptError 
			syntaxErrorFor: aString 
			withComponent: ApplescriptGeneric]! !

!Applescript methodsFor: 'private' stamp: 'acg 9/26/1999 20:47'!
on: aString mode: anInteger onErrorDo: aBlock

	source _ aString.
	compiledScript _ ApplescriptGeneric compile: aString mode: anInteger.
	compiledScript ifNil: [^aBlock value].
	^self! !

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

Applescript class
	instanceVariableNames: ''!

!Applescript class methodsFor: 'instance creation' stamp: 'acg 9/25/1999 23:36'!
on: aString

	^super new on: aString! !

!Applescript class methodsFor: 'instance creation' stamp: 'acg 9/26/1999 20:49'!
on: aString mode: anInteger

	^super new on: aString mode: anInteger! !


!Applescript class methodsFor: 'generic scripting component' stamp: 'acg 9/26/1999 02:19'!
doIt: aString

	^(self on: aString) doIt! !

!Applescript class methodsFor: 'generic scripting component' stamp: 'acg 9/26/1999 20:50'!
doIt: aString in: aContext mode: anInteger

	^(self on: aString mode: anInteger) doItIn: aContext mode: anInteger! !

!Applescript class methodsFor: 'generic scripting component' stamp: 'acg 9/26/1999 20:50'!
doIt: aString mode: anInteger

	^(self on: aString mode: anInteger) doItMode: anInteger! !

!Applescript class methodsFor: 'generic scripting component' stamp: 'acg 9/25/1999 23:43'!
generic
	"Answer an ApplescriptInstance (Applescript Generic Scripting Component) that is guaranteed to be active from startUp, but is not (at present) guaranteed to be identical across startups.  Additional instances can be created for multi-threaded applications by using ApplescriptInstance."

	^ApplescriptGeneric ifNil:
		[ApplescriptGeneric _ ApplescriptInstance new]! !

!Applescript class methodsFor: 'generic scripting component' stamp: 'acg 9/25/1999 23:28'!
lastError

	^self generic lastError! !


!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
beep: anInteger
	"Beep n times"

	^self doIt: 'beep ', anInteger asString! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
browse: anUrl
	"Open Microsoft's Web Browser to a page"
	
	^self doIt: 'tell application "Internet Explorer"
		activate
		openURL "', anUrl, '"
	end tell'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
distill

	Applescript doIt: '
set prompt to "Select a file to convert to .pdf format"
set myFile to (choose file with prompt prompt of type "TEXT")
tell application "Acrobatª Distillerª 3.02"
	activate
	open myFile
end tell'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
mandatoryDemo
	"A mandatory first script"

	^self doIt: '3 + 4'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/27/1999 08:12'!
playQT4Movie
	"Demonstrate Access to Quicktime"

	^Applescript doIt: '-- Play QuickTime File
-- ©1999 Sal Soghoian, Apple Computer

property source_folder : ""
property container_kind : "folder"
property reset_string : "Pick New Source Folder"

-- Check the version of QuickTime
copy my gestaltVersion_info("qtim", 8) to {QT_version, QT_string}
if the QT_version is less than "0400" then
	display dialog "This script requires QuickTime 4.0 or higher." & Â
		return & return & "The currently installed version is: " & Â
		QT_string buttons {"Cancel"} default button 1
end if

-- Check the version of the OS
copy my gestaltVersion_info("sysv", 4) to {system_version, system_string}
if the system_version is less than "0850" then
	display dialog "This script requires Mac OS 8.5 or higher." & Â
		return & return & "The currently installed version is: " & Â
		system_string buttons {"Cancel"} default button 1
end if

-- check to see if source folder exists
try
	if the source_folder is "" then error
	set the source_folder to alias (source_folder as text)
on error
	set the source_folder to choose_source_folder()
	if the result is false then return "user canceled"
end try

-- set the target folder to the source folder
set the target_folder to the source_folder

repeat
	-- search the target folder for folders or QT files
	try
		tell application "Finder"
			set the item_list to (the name of every item of Â
				the target_folder whose Â
				(creator type is "TVOD") or Â
				(kind is the container_kind)) as list
			set the item_list to my ASCII_Sort(item_list)
			set the beginning of the item_list to "Pick New Source Folder"
		end tell
	on error
		beep
		display dialog "The chosen folder contains no folders or QuickTime files." buttons {"Show Me", "Cancel"} default button 2
		tell application "Finder"
			activate
			open the target_folder
		end tell
		return "no items"
	end try
	
	-- prompt the user to pick a folder or file
	set the chosen_item to choose from list the item_list with prompt Â
		"Pick an item:"
	if the chosen_item is false then return
	set the chosen_item to the chosen_item as string
	
	if the chosen_item is reset_string then
		set the source_folder to choose_source_folder()
		if the result is false then return "user canceled"
		set the target_folder to the source_folder
	else
		-- Check the user''s choice to determine whether it''s a file or folder
		tell application "Finder"
			if the kind of item chosen_item of the target_folder is the container_kind then
				-- The user picked a folder. Set the new target folder and repeat the process.
				set the target_folder to folder chosen_item of the the target_folder
			else
				-- The user picked a file. Get the path to the file and exit the repeat.
				set the chosen_item to (item chosen_item of the target_folder) as alias
				exit repeat
			end if
		end tell
	end if
end repeat

-- Find out if the user wants to play the item in the front or back.
set play_in_background to true
display dialog "Play the media in the foreground or background?" buttons {"Cancel", "Foreground", "Background"} default button 3
if the button returned of the result is "Foreground" then set play_in_background to false

-- Quit the QuickTime Player if it is open
tell application "Finder"
	if (the creator type of every process) contains Çclass TVODÈ then Â
		tell application "QuickTime Player" to quit
end tell

-- Convert the alias to a URL format string
set this_file to "file:///" & my filepath_to_URL(the chosen_item, true, false)

-- Tell the QuickTime Player to open the file.
-- NOTE: to autoplay, Check the Auto-Play preference in the General setting in the QuickTime Player.
tell application "QuickTime Player"
	if play_in_background is false then activate
	open location this_file
end tell

on gestaltVersion_info(gestalt_code, string_length)
	try
		tell application "Finder" to Â
			copy my NumToHex((computer gestalt_code), Â
				string_length) to {a, b, c, d}
		set the numeric_version to {a, b, c, d} as string
		if a is "0" then set a to ""
		set the version_string to (a & b & "." & c & "." & d) as string
		return {numeric_version, version_string}
	on error
		return {"", "unknown"}
	end try
end gestaltVersion_info

on NumToHex(hexData, stringLength)
	set hexString to {}
	repeat with i from stringLength to 1 by -1
		set hexString to ((hexData mod 16) as string) & hexString
		set hexData to hexData div 16
	end repeat
	return (hexString as string)
end NumToHex

on choose_source_folder()
	try
		set the source_folder to choose folder with prompt Â
			"Pick a folder containing Quicktime content:"
		return the source_folder
	on error
		return false
	end try
end choose_source_folder

-- this sub-routine converts a filepath to an encoded URL
-- My Disk:My Folder:My File
-- My%20Disk/My%20Folder/My%20File
on filepath_to_URL(this_file, encode_URL_A, encode_URL_B)
	set this_file to this_file as text
	set AppleScript''s text item delimiters to ":"
	set the path_segments to every text item of this_file
	repeat with i from 1 to the count of the path_segments
		set this_segment to item i of the path_segments
		set item i of the path_segments to Â
			my encode_text(this_segment, encode_URL_A, encode_URL_B)
	end repeat
	set AppleScript''s text item delimiters to "/"
	set this_file to the path_segments as string
	set AppleScript''s text item delimiters to ""
	return this_file
end filepath_to_URL

-- this sub-routine is used to encode text
on encode_text(this_text, encode_URL_A, encode_URL_B)
	set the standard_characters to Â
		"abcdefghijklmnopqrstuvwxyz0123456789"
	set the URL_A_chars to "$+!!''/?;&@=#%><{}[]\"~`^\\|*"
	set the URL_B_chars to ".-_:"
	set the acceptable_characters to the standard_characters
	if encode_URL_A is false then Â
		set the acceptable_characters to Â
			the acceptable_characters & the URL_A_chars
	if encode_URL_B is false then Â
		set the acceptable_characters to Â
			the acceptable_characters & the URL_B_chars
	set the encoded_text to ""
	repeat with this_char in this_text
		if this_char is in the acceptable_characters then
			set the encoded_text to Â
				(the encoded_text & this_char)
		else
			set the encoded_text to Â
				(the encoded_text & encode_char(this_char)) as string
		end if
	end repeat
	return the encoded_text
end encode_text

-- this sub-routine is used to encode a character
on encode_char(this_char)
	set the ASCII_num to (the ASCII number this_char)
	set the hex_list to Â
		{"0", "1", "2", "3", "4", "5", "6", "7", "8", Â
			"9", "A", "B", "C", "D", "E", "F"}
	set x to item ((ASCII_num div 16) + 1) of the hex_list
	set y to item ((ASCII_num mod 16) + 1) of the hex_list
	return ("%" & x & y) as string
end encode_char

-- This routine sorts a list of strings passed to it
on ASCII_Sort(my_list)
	set the index_list to {}
	set the sorted_list to {}
	repeat (the number of items in my_list) times
		set the low_item to ""
		repeat with i from 1 to (number of items in my_list)
			if i is not in the index_list then
				set this_item to item i of my_list as text
				if the low_item is "" then
					set the low_item to this_item
					set the low_item_index to i
				else if this_item comes before the low_item then
					set the low_item to this_item
					set the low_item_index to i
				end if
			end if
		end repeat
		set the end of sorted_list to the low_item
		set the end of the index_list to the low_item_index
	end repeat
	return the sorted_list
end ASCII_Sort'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
say: aString
	"Speak the string"

	^self doIt: 'say "', aString, '"'
! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
selectFile
	"Harness Apple's select file dialog for Squeak"

	^self doIt: '(choose file with prompt "Hi guys!!" of type "TEXT") as string'
! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:16'!
selectFolder
	"Harness Apple's select Folder dialog for Squeak"

	^self doIt: '(choose folder with prompt "Hi guys!!") as string'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/21/1999 21:33'!
silly

	Applescript say: 'please prez a button for me'.
	Applescript sillyButtons.
	Applescript say: 'thank you for pressing the button' ! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:17'!
sillyButtons
	"A silly Apple GUI demo"

	^self doIt: '
		display dialog "The Mouse that Roars!!" ',
			'buttons {"One", "Two", "Three"} default button "One"'
! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:17'!
sillyDialog
	"A silly Apple GUI demo"

	self doIt: '
display dialog "Enter a number between 1 and 10." default answer ""
set userValue to {text returned of result} as real
if (userValue < 1) or (userValue > 10) then
	display dialog "That Value is out of range." buttons {"OK"} default button 1
else 
	display dialog "Thanks for playing." buttons {"OK"} default button 1
end if'


! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:17'!
sillyList
	"A silly Apple GUI demo"

	^Applescript doIt:
		'choose from list {"dogs", "cats", "lions", "pick the mouse!!"}',
			'with prompt "hi there"',
			'default items {"dogs"}',
			'OK button name "DoIt!!"', 
			'cancel button name "Chicken!!"'! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:17'!
sleep

	^self doIt: '
tell application "Finder"
	sleep
end tell'

"Applescript sleep"
! !

!Applescript class methodsFor: 'sample scripts' stamp: 'acg 9/26/1999 02:17'!
with: voiceString say: contentString
	"Speak the string"

	^self doIt: 'say "', contentString, '" using "', voiceString, '"'
! !


!Applescript class methodsFor: 'initialize-release' stamp: 'acg 9/27/1999 08:35'!
initialize

	Smalltalk addToStartUpList: self after: nil.
	ApplescriptGeneric _ nil.
	Applescript generic! !

!Applescript class methodsFor: 'initialize-release' stamp: 'acg 9/25/1999 23:29'!
reopen

	^self generic reopen! !

!Applescript class methodsFor: 'initialize-release' stamp: 'ar 2/1/2000 15:42'!
startUp
	Smalltalk platformName = 'Mac OS' "Can be *really* annoying otherwise"
		ifTrue:[^self reopen]! !
StringHolder subclass: #ApplescriptError
	instanceVariableNames: 'errorMessage from to '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!ApplescriptError commentStamp: '<historical>' prior: 0!
I represent a syntax or execution error report for errors encountered when processing Applescripts. As a StringHolder, the string to be viewed is generally the method code or expression containing the error.!


!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 02:10'!
canDiscardEdits

	^true! !

!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 01:26'!
code: codeString errorMessage: errString from: fromInteger to: toInteger

	contents _ codeString.
	from _ fromInteger.
	to _ toInteger.
	errorMessage _ errString! !

!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 01:25'!
contentsSelection

	^from to: to! !

!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 01:27'!
list

	^Array with: errorMessage! !

!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 01:27'!
listIndex

	^1! !

!ApplescriptError methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 22:10'!
listMenu: aMenu

	^aMenu labels: '' lines: #() selections: #()
! !

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

ApplescriptError class
	instanceVariableNames: ''!

!ApplescriptError class methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 21:00'!
buildMVCViewOn: aSyntaxError
	"Answer an MVC view on the given SyntaxError."

	| topView aListView aCodeView |
	topView _ StandardSystemView new
		model: aSyntaxError;
		label: 'Applescript Error';
		minimumSize: 380@220.

	aListView _ PluggableListView on: aSyntaxError
		list: #list
		selected: #listIndex
		changeSelected: nil
		menu: #listMenu:.
	aListView window: (0@0 extent: 380@20).
	topView addSubView: aListView.

	aCodeView _ PluggableTextView on: aSyntaxError
		text: #contents
		accept: nil
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	aCodeView window: (0@0 extent: 380@200).
	topView addSubView: aCodeView below: aListView.

	^ topView
! !

!ApplescriptError class methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 21:01'!
buildMorphicViewOn: aSyntaxError
	"Answer an Morphic view on the given SyntaxError."
	| window |
	window _ (SystemWindow labelled: 'Applescript Error') model: aSyntaxError.

	window addMorph: (PluggableListMorph on: aSyntaxError list: #list
			selected: #listIndex changeSelected: nil menu: #listMenu:)
		frame: (0@0 corner: 1@0.15).

	window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents
			accept: nil readSelection: #contentsSelection
			menu: #codePaneMenu:shifted:)
		frame: (0@0.15 corner: 1@1).

	^ window openInWorldExtent: 380@220! !

!ApplescriptError class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:12'!
open: aSyntaxError
	"Answer a standard system view whose model is an instance of me."

	| topView |
	<primitive: 19> "Simulation guard"
	Smalltalk isMorphic
		ifTrue:
			[self buildMorphicViewOn: aSyntaxError.
			CurrentProjectRefactoring newProcessIfUI: Processor activeProcess.
			^ Processor activeProcess suspend].
	topView _ self buildMVCViewOn: aSyntaxError.
	topView controller openNoTerminateDisplayAt: Display extent // 2.
	Cursor normal show.
	Processor activeProcess suspend! !

!ApplescriptError class methodsFor: 'as yet unclassified' stamp: 'acg 9/26/1999 01:38'!
syntaxErrorFor: aString withComponent: anApplescriptInstance

	|range |
	range _ anApplescriptInstance lastErrorCodeRange.
	self open:
		(super new 
			code: aString 
			errorMessage: anApplescriptInstance lastErrorString
			from: range first
			to: range last)! !
ComponentInstance variableWordSubclass: #ApplescriptInstance
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!ApplescriptInstance commentStamp: '<historical>' prior: 0!
I represent an Applescript Scripting Component, derived from the Component Manager.  For more information about Scripting Components, see Inside Macintosh: Interapplication Communications, at:

	http://developer.apple.com/techpubs/mac/IAC/IAC-2.html.

Essentially, I represent a record comprising a one-word handle to the scripting component. That handle is passed as a matter of course to almost every important Applescript call.  Accordingly, I am also the repository for most of the primitives for the Applescript/Squeak interface.!
]style[(195 54 285)f1,f1Rhttp://developer.apple.com/techpubs/mac/IAC/IAC-2.html;,f1!


!ApplescriptInstance methodsFor: 'testing' stamp: 'acg 9/26/1999 22:43'!
hasSource: anOSAID

	| result |
	result _ IntegerArray new: 1.
	(self 
		primOSAGetScriptInfo: anOSAID 
		type: (DescType of: 'gsrc')
		to: result) isZero ifFalse: [^nil].
	^(result at: 1) > 0! !

!ApplescriptInstance methodsFor: 'testing' stamp: 'acg 9/26/1999 22:43'!
isCompiledScript: anOSAID

	| result |
	result _ IntegerArray new: 1.
	(self 
		primOSAGetScriptInfo: anOSAID 
		type: (DescType of: 'cscr')
		to: result) isZero ifFalse: [^nil].
	^(result at: 1) > 0! !

!ApplescriptInstance methodsFor: 'testing' stamp: 'acg 9/26/1999 22:43'!
isScriptContext: anOSAID

	| result |
	result _ IntegerArray new: 1.
	(self 
		primOSAGetScriptInfo: anOSAID 
		type: (DescType of: 'cntx')
		to: result) isZero ifFalse: [^nil].
	^(result at: 1) > 0! !

!ApplescriptInstance methodsFor: 'testing' stamp: 'acg 9/26/1999 22:43'!
isScriptValue: anOSAID

	| result |
	result _ IntegerArray new: 1.
	(self 
		primOSAGetScriptInfo: anOSAID 
		type: (DescType of: 'valu')
		to: result) isZero ifFalse: [^nil].
	^(result at: 1) > 0! !

!ApplescriptInstance methodsFor: 'testing' stamp: 'acg 9/26/1999 22:42'!
timesModified: anOSAID

	| result |
	result _ IntegerArray new: 1.
	(self 
		primOSAGetScriptInfo: anOSAID 
		type: (DescType of: 'modi')
		to: result) isZero ifFalse: [^nil].
	^result at: 1! !


!ApplescriptInstance methodsFor: 'interpreting' stamp: 'sma 3/15/2000 21:46'!
compile: aString
	^ self compile: aString mode: 0! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/27/1999 00:05'!
compile: aString mode: anInteger

	| sourceAEDesc objectOSAID objectAEDesc |
	sourceAEDesc _ AEDesc textTypeOn: aString.
	(objectOSAID _ self 
		compileAndDisposeAEDesc: sourceAEDesc 
		mode: anInteger) ifNil: [^nil].
	(objectAEDesc _ self 
		storeAndDisposeOSAID: objectOSAID 
		type: 'scpt' 
		mode: anInteger) ifNil: [^nil].
	^objectAEDesc asCompiledApplescriptThenDispose
! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/27/1999 00:05'!
do: aString
	"Answer text result of compiling script in null context"

	^self doScript: aString in: OSAID new mode: 0! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/25/1999 14:14'!
do: aString in: contextOSAID mode: anInteger
	"Answer text result of executing Applescript aString in context contexOSAID in mode: anInteger"

	| source object result |
	source _ AEDesc textTypeOn: aString.
	object _ AEDesc new.
	result _ self	
		primOSADoScript: source
		in: contextOSAID
		mode: anInteger
		resultType: (DescType of: 'TEXT')
		to: object.
	source dispose.
	result isZero ifFalse: [^nil].
	^object asStringThenDispose! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/25/1999 14:14'!
doCompiledScript: aCompiledApplescriptData in: contextOSAID mode: anInteger
	"Answer text result of executing Applescript aString in context contexOSAID in mode: anInteger"

	^self valueOf: aCompiledApplescriptData in: contextOSAID mode: anInteger! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/25/1999 14:14'!
doScript: aString
	"Answer text result of compiling script in null context"

	^self do: aString! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/25/1999 14:15'!
doScript: aString in: contextOSAID mode: anInteger
	"Answer text result of executing Applescript aString in context contexOSAID in mode: anInteger"

	^self do: aString in: contextOSAID mode: anInteger! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/27/1999 00:06'!
scriptingName
"Answer the name of my generic scripting component"

	|aeDesc result |
	aeDesc _ AEDesc new.
	result _ self primOSAScriptingComponentNameTo: aeDesc.
	result isZero ifFalse: [^nil].
	^aeDesc asStringThenDispose.
! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/26/1999 21:08'!
sourceOfOSAID: anOSAID

	| anAEDesc result |
	anAEDesc _ AEDesc new.
	result _ self primOSAGetSource: anOSAID type: 'TEXT' to: anAEDesc.
	anOSAID disposeWith: self.
	result isZero ifFalse: [^''].
	^anAEDesc asStringThenDispose
	
	! !

!ApplescriptInstance methodsFor: 'interpreting' stamp: 'acg 9/25/1999 21:53'!
valueOf: aCompiledApplescript in: contextOSAID mode: anInteger
	"Answer text result of executing Applescript aString in context contexOSAID in mode: anInteger"

	| sourceAEDesc sourceOSAID objectOSAID objectAEDesc |
	sourceAEDesc _ AEDesc scptTypeOn: aCompiledApplescript.
	sourceOSAID _ self 
		loadAndDispose: sourceAEDesc 
		mode: anInteger.
	sourceOSAID ifNil: [^nil].
	objectOSAID _ self 
		executeAndDispose: sourceOSAID
		in: contextOSAID
		mode: anInteger.
	objectOSAID ifNil: [^nil].
	objectAEDesc _ self
		displayAndDispose: objectOSAID
		as: 'TEXT'
		mode: anInteger.
	objectAEDesc ifNil: [^nil].
	^objectAEDesc asStringThenDispose! !


!ApplescriptInstance methodsFor: 'error handling' stamp: 'acg 9/25/1999 23:27'!
lastBriefErrorString
	"Answer the brief error message for the last error"

	| aeDesc |
	aeDesc _ AEDesc new.
	Applescript generic
		primOSAScriptError: (DescType of: 'errb')
		type: (DescType of: 'TEXT')
		to: aeDesc.
	^aeDesc asStringThenDispose! !

!ApplescriptInstance methodsFor: 'error handling' stamp: 'acg 9/24/1999 00:06'!
lastError

	|range|
	range _ self lastErrorCodeRange.
	^String streamContents: [:aStream |
		aStream
			nextPutAll: 'Error #';
			nextPutAll: self lastErrorNumber asString;
			nextPutAll: ': ';
			nextPutAll: self lastErrorString;
			nextPutAll: ' (code ';
			nextPutAll: range first asString;
			nextPutAll: ' to ';
			nextPutAll: range last asString;
			nextPutAll: ').']! !

!ApplescriptInstance methodsFor: 'error handling' stamp: 'acg 9/25/1999 23:27'!
lastErrorCodeRange
	"Answer the brief error message for the last error"

	| aeDesc recordDesc data from to |
	aeDesc _ AEDesc new.
	recordDesc _ AEDesc new.
	Applescript generic
		primOSAScriptError: (DescType of: 'erng')
		type: (DescType of: 'erng')
		to: aeDesc.
	aeDesc
		primAECoerceDesc: (DescType of: 'reco')
		to: recordDesc.
	aeDesc dispose.
	data _ ByteArray new: 2.
	recordDesc
		primAEGetKeyPtr: (DescType of: 'srcs') 
		type: (DescType of: 'shor')
		actual: (DescType of: 'shor')
		to: data.
	from _ data shortAt: 1 bigEndian: true.
	recordDesc
		primAEGetKeyPtr: (DescType of: 'srce') 
		type: (DescType of: 'shor')
		actual: (DescType of: 'shor')
		to: data.
	to _ data shortAt: 1 bigEndian: true.
	recordDesc dispose.
	^ (from + 1) to: (to + 1)

! !

!ApplescriptInstance methodsFor: 'error handling' stamp: 'acg 9/25/1999 23:27'!
lastErrorNumber
	"Answer the error code number of the last error"

	| aeDesc |
	aeDesc _ AEDesc new.
	Applescript generic 
		primOSAScriptError: (DescType of: 'errn')
		type: (DescType of: 'shor')
		to: aeDesc.
	^aeDesc asShortThenDispose
! !

!ApplescriptInstance methodsFor: 'error handling' stamp: 'acg 9/25/1999 23:27'!
lastErrorString
	"Answer the error message for the last error"

	| aeDesc |
	aeDesc _ AEDesc new.
	Applescript generic
		primOSAScriptError: (DescType of: 'errs')
		type: (DescType of: 'TEXT')
		to: aeDesc.
	^aeDesc asStringThenDispose! !


!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/25/1999 13:55'!
compileAndDisposeAEDesc: sourceAEDesc mode: anInteger

	| objectOSAID result |
	objectOSAID _ OSAID new.
	result _ self	
		primOSACompile: sourceAEDesc
		mode: anInteger
		to: objectOSAID.
	sourceAEDesc dispose.
	result isZero ifFalse: [^nil].
	^objectOSAID
! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 00:14'!
displayAndDisposeOSAID: anOSAID as: aString mode: anInteger

	| anAEDesc result |
	anOSAID isEmpty ifTrue: [^AEDesc textTypeOn: ''].
	anAEDesc _ AEDesc new.
	result _ self 
		primOSADisplay: anOSAID 
		as: (DescType of: aString)
		mode: anInteger 
		to: anAEDesc.
	anOSAID disposeWith: self.
	result isZero ifFalse: 
		[^nil].
	^anAEDesc! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 20:29'!
executeAndDisplayOSAID: anOSAID in: contextOSAID mode: anInteger

	| resultOSAID resultAEDesc |
	resultOSAID _ (self executeOSAID: anOSAID in: contextOSAID mode: anInteger)
		ifNil: [^nil].
	resultAEDesc _ (self displayAndDisposeOSAID: resultOSAID as: 'TEXT' mode: anInteger)
		ifNil: [^nil].
	^resultAEDesc asStringThenDispose
  ! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/25/1999 09:57'!
executeAndDisposeOSAID: sourceOSAID in: contextOSAID mode: anInteger

	| objectOSAID result |
	objectOSAID _ OSAID new.
	result _ self 
		primOSAExecute: sourceOSAID 
		in: contextOSAID
		mode: anInteger 
		to: objectOSAID.
	sourceOSAID disposeWith: self.
	result isZero ifFalse: 
		[^nil].
	^objectOSAID! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 00:03'!
executeOSAID: sourceOSAID in: contextOSAID mode: anInteger

	| objectOSAID result |
	objectOSAID _ OSAID new.
	result _ self 
		primOSAExecute: sourceOSAID 
		in: contextOSAID
		mode: anInteger 
		to: objectOSAID.
	result isZero ifFalse: [^nil].
	^objectOSAID! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/25/1999 09:57'!
loadAndDisposeAEDesc: anAEDesc mode: anInteger

	| anOSAID result |
	anOSAID _ OSAID new.
	result _ self primOSALoad: anAEDesc mode: anInteger to: anOSAID.
	anAEDesc dispose.
	result isZero ifFalse: [^nil].
	^anOSAID! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 02:59'!
makeContextAndDiposeOSAID: anOSAID
	
	| result contextOSAID contextAEDesc |
	contextOSAID _ OSAID new.
	result _ self 
		primOSAMakeContext: (AEDesc nullType)
		parent: anOSAID
		to: contextOSAID.
	anOSAID dispose.
	result isZero ifFalse: [^nil].
	contextAEDesc _ self storeAndDisposeOSAID: contextOSAID type: 'scpt' mode: 0.
	contextAEDesc ifNil: [^nil].
	^ contextAEDesc asCompiledApplescriptThenDispose! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 02:49'!
makeContextAndDisposeOSAID: anOSAID
	
	| result contextAEDesc |
	contextAEDesc _ AEDesc new.
	result _ self 
		primOSAMakeContext: (AEDesc nullType)
		parent: anOSAID
		to: contextAEDesc.
	result isZero ifFalse: [^nil].
	anOSAID disposeWith: self.
	^ contextAEDesc asCompiledApplescriptThenDispose! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/26/1999 02:58'!
makeContextOSAID: anOSAID
	
	| result contextOSAID contextAEDesc |
	contextOSAID _ OSAID new.
	result _ self 
		primOSAMakeContext: (AEDesc nullType)
		parent: anOSAID
		to: contextOSAID.
	result isZero ifFalse: [^nil].
	contextAEDesc _ self storeAndDisposeOSAID: contextOSAID type: 'scpt' mode: 0.
	contextAEDesc ifNil: [^nil].
	^ contextAEDesc asCompiledApplescriptThenDispose! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/25/1999 14:17'!
storeAndDisposeOSAID: anOSAID type: aString mode: anInteger

	| theAEDesc result |
	theAEDesc _ AEDesc new.
	result _ self	
		primOSAStore: anOSAID 
		resultType: (DescType of: aString) 
		mode: 0  to: (theAEDesc).
	anOSAID disposeWith: self.
	result isZero ifFalse: [^nil].
	^theAEDesc

! !

!ApplescriptInstance methodsFor: 'intermediate operations' stamp: 'acg 9/25/1999 16:41'!
storeOSAID: anOSAID type: aString mode: anInteger

	| theAEDesc result |
	theAEDesc _ AEDesc new.
	result _ self	
		primOSAStore: anOSAID 
		resultType: (DescType of: aString) 
		mode: 0  to: (theAEDesc).
	result isZero ifFalse: [^nil].
	^theAEDesc

! !


!ApplescriptInstance methodsFor: 'printing' stamp: 'acg 9/26/1999 00:52'!
printOn: aStream

	aStream 
		nextPutAll: 'an ';
		nextPutAll: self species asString;
		nextPutAll: '(';
		nextPutAll: self scriptingName;
		nextPutAll: ')'! !


!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 21:23'!
initialize

	super type: 'osa ' subtype: 'scpt'! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/22/1999 03:14'!
primOSACompile: anAEDesc mode: anInteger to: anOSAID

	<primitive: 'primOSACompile' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSACompile:mode:to:'
		withArguments: {anAEDesc. anInteger. anOSAID}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 20:57'!
primOSADisplay: source as: type mode: mode to: result

	<primitive: 'primOSADisplay' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSADisplay:as:mode:to:'
		withArguments: {source. type. mode. result}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 20:57'!
primOSADispose: anOSAID

	<primitive: 'primOSADispose' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSADispose:'
		withArguments: {anOSAID}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 20:57'!
primOSADoScript: source in: context mode: mode resultType: type to: result

	<primitive: 'primOSADoScript' module: 'TestOSAPlugin'>
	^TestOSAPlugin
		doPrimitive: 'primOSADoScript:in:mode:resultType:to:'
		withArguments: {source. context. mode. type. result}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 20:57'!
primOSAExecute: script in: context mode: mode to: result

	<primitive: 'primOSAExecute' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAExecute:in:mode:to:'
		withArguments: { script. context. mode. result }! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/26/1999 22:24'!
primOSAGetScriptInfo: aScriptID type: aDescType to: resultData

	<primitive: 'primOSAGetScriptInfo' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAGetScriptInfo:type:to:'
		withArguments: {aScriptID. aDescType. resultData}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/25/1999 17:27'!
primOSAGetSource: aScriptID type: aDescType to: resultData

	<primitive: 'primOSAGetSource' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAGetSource:type:to:'
		withArguments: {aScriptID. aDescType. resultData}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/22/1999 03:17'!
primOSALoad: anAEDesc mode: anInteger to: anOSAID

	<primitive: 'primOSALoad' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSALoad:mode:to:'
		withArguments: {anAEDesc. anInteger. anOSAID}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/25/1999 22:56'!
primOSAMakeContext: name parent: parent to: result

	<primitive: 'primOSAMakeContext' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAMakeContext:parent:to:'
		withArguments: {name. parent. result}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/23/1999 20:43'!
primOSAScriptError: anOSType type: aDescType to: anAEDesc

	<primitive: 'primOSAScriptError' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAScriptError:type:to:'
		withArguments: {anOSType. aDescType. anAEDesc}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 20:57'!
primOSAScriptingComponentNameTo: anAEDesc

	<primitive: 'primOSAScriptingComponentName' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAScriptingComponentNameTo:'
		withArguments: {anAEDesc}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/22/1999 04:22'!
primOSAStore: a resultType: b mode: c to: d

	<primitive: 'primOSAStore' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOSAStore:resultType:mode:to:'
		withArguments: {a. b. c. d}! !

!ApplescriptInstance methodsFor: 'private' stamp: 'acg 9/21/1999 21:25'!
reopen

	^super type: 'osa ' subtype: 'scpt'! !

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

ApplescriptInstance class
	instanceVariableNames: ''!

!ApplescriptInstance class methodsFor: 'as yet unclassified' stamp: 'acg 9/21/1999 21:22'!
new

	^super new initialize! !
ObjectSocket subclass: #ArbitraryObjectSocket
	instanceVariableNames: 'encodingOfLastEncodedObject lastEncodedObject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-ObjectSocket'!
!ArbitraryObjectSocket commentStamp: '<historical>' prior: 0!
A network connection that passes objects instead of bytes.  The objects are encoded with SmartRefStreams.

Of course, one can send Arrays of Strings if one is unsure of what exactly SmartRefStream's are going to do.
!


!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:18'!
encodeObject: object  into: buffer  startingAt: startIndex
	"encode the given object into the given buffer"
	| encoded |
	encoded := self smartRefStreamEncode: object.
	buffer putInteger32: encoded size at: startIndex.
	buffer replaceFrom: startIndex+4 to: startIndex+4+(encoded size)-1 with: encoded.
! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:19'!
nextObjectLength
	"read the next object length from inBuf.  Returns nil if less than 4 bytes are available in inBuf"
	self inBufSize < 4 ifTrue: [ ^nil ].

	^inBuf getInteger32: inBufIndex! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:34'!
processInput
	"recieve some data"
	| inObjectData |

	"read as much data as possible"
	[ self isConnected and: [ socket dataAvailable ] ] whileTrue: [
		self addToInBuf: socket getData. ].


	"decode as many objects as possible"
	[self nextObjectLength ~~ nil and: [ self nextObjectLength <= (self inBufSize + 4) ]] whileTrue: [
		"a new object has arrived"
		inObjectData _ inBuf copyFrom: (inBufIndex + 4) to: (inBufIndex + 3 + self nextObjectLength).
		inBufIndex := inBufIndex + 4 + self nextObjectLength.

		inObjects addLast: (RWBinaryOrTextStream with: inObjectData) reset fileInObjectAndCode ].

	self shrinkInBuf.! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:33'!
smartRefStreamEncode: anObject
	| encodingStream |
	"encode an object using SmartRefStream"

	anObject == lastEncodedObject ifTrue: [
		^encodingOfLastEncodedObject ].


	encodingStream := RWBinaryOrTextStream on: ''.
	encodingStream reset.
	(SmartRefStream on: encodingStream) nextPut: anObject.
	
	lastEncodedObject := anObject.
	encodingOfLastEncodedObject := encodingStream contents.

	^encodingOfLastEncodedObject! !

!ArbitraryObjectSocket methodsFor: 'private' stamp: 'ls 4/25/2000 19:36'!
spaceToEncode: anObject
	"return the number of characters needed to encode the given object"
	^ 4 + (self smartRefStreamEncode: anObject) size! !
Path subclass: #Arc
	instanceVariableNames: 'quadrant radius center '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Arc commentStamp: '<historical>' prior: 0!
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: '<historical>' prior: 0!
I present an ArrayedCollection whose elements are objects.!


!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' stamp: 'sma 5/12/2000 17:32'!
asArray
	"Answer with the receiver itself."

	^ self! !

!Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:22'!
elementsExchangeIdentityWith: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray.  At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array.  The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation."
	<primitive: 128>
	self primitiveFailed! !

!Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'!
elementsForwardIdentityTo: otherArray
	"This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray.  The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation."
	<primitive: 72>
	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' stamp: 'sma 5/12/2000 14:11'!
isLiteral
	^ self allSatisfy: [:each | each isLiteral]! !

!Array methodsFor: 'printing' stamp: 'sma 6/1/2000 09:39'!
printOn: aStream
	aStream nextPut: $#.
	self printElementsOn: aStream! !

!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: 'sma 6/3/2000 21:39'!
hasLiteral: literal
	"Answer true if literal is identical to any literal in this array, even 
	if imbedded in further array structure. This method is only intended 
	for private use by CompiledMethod hasLiteralSymbol:"

	| lit |
	1 to: self size do: 
		[:index | 
		(lit _ self at: index) == literal ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]].
	^ false! !

!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! !


!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:42'!
byteEncode:aStream
	aStream writeArray:self.
! !

!Array methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:55'!
storeOnStream:aStream
	self isLiteral ifTrue: [super storeOnStream:aStream] ifFalse:[aStream writeCollection:self].
! !


!Array methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:35'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am one of two shared global arrays, write a proxy instead."

self == (TextConstants at: #DefaultTabsArray) ifTrue: [
	dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultTabsArray).
	refStrm replace: self with: dp.
	^ dp].
self == (TextConstants at: #DefaultMarginTabsArray) ifTrue: [
	dp _ DiskProxy global: #TextConstants selector: #at: args: #(DefaultMarginTabsArray).
	refStrm replace: self with: dp.
	^ dp].
^ super objectForDataStream: refStrm! !

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

Array class
	instanceVariableNames: ''!

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:12'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/19/1999 13:10'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asIntPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isIndexable')! !

!Array class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:12'!
ccgDeclareCForVar: aSymbolOrString

	^'int *', aSymbolOrString! !


!Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'!
braceStream: nElements
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ WriteStream basicNew braceArray: (self new: nElements)
! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'!
braceWith: a
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 1.
	array at: 1 put: a.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'!
braceWith: a with: b 
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 2.
	array at: 1 put: a.
	array at: 2 put: b.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'!
braceWith: a with: b with: c 
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 3.
	array at: 1 put: a.
	array at: 2 put: b.
	array at: 3 put: c.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'!
braceWith: a with: b with: c with: d
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	| array |
	array _ self new: 4.
	array at: 1 put: a.
	array at: 2 put: b.
	array at: 3 put: c.
	array at: 4 put: d.
	^ array! !

!Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'!
braceWithNone
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ self new: 0! !
ArrayedCollection subclass: #Array2D
	instanceVariableNames: 'width contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!Array2D commentStamp: '<historical>' prior: 0!
A simple 2D-Array implementation. 

Neither storing nor sorting (otherwise inherited from ArrayedCollection) will work. Neither comparing nor most accessing mehods inherited from Sequenceable collection will work.  Actually, it's a bad idea to inherit this class from collection at all!!!


!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:16'!
at: x at: y
	"Answer the element at index x,y."

	^ contents at: (self indexX: x y: y)! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
at: x at: y add: value
	"Add value (using #+) to the existing element at index x,y."

	| index |
	index _ self indexX: x y: y.
	^ contents at: index put: (contents at: index) + value! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
at: x at: y put: value
	"Store value at index x,y and answer it."

	^ contents at: (self indexX: x y: y) put: value! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:20'!
atAllPut: anObject
	"Put anObject at every one of the receiver's indices."

	contents atAllPut: anObject! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
extent
	"Answer the receiver's dimensions as point."

	^ self width @ self height! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:21'!
height
    "Answer the receiver's second dimension."

	^ contents size // width! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
size
	^ contents size! !

!Array2D methodsFor: 'accessing' stamp: 'sma 4/22/2000 18:22'!
width
	"Answer the receiver's first dimension."

	^ width! !


!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:27'!
atCol: x
	"Answer a whole column."

	| column |
	column _ contents class new: self height.
	1 to: self height do: [:index | column at: index put: (self at: x at: index)].
	^ column! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:30'!
atCol: x put: aCollection
	"Put in a whole column."

	aCollection size = self height ifFalse: [self error: 'wrong column size'].
	aCollection doWithIndex: [:value :y | self at: x at: y put: value].
	^ aCollection! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:27'!
atRow: y
    "Answer a whole row."

	(y < 1 or: [y > self height]) ifTrue: [self errorSubscriptBounds: y].
	^ contents copyFrom: y - 1 * width + 1 to: y * width! !

!Array2D methodsFor: 'accessing rows/columns' stamp: 'sma 4/22/2000 18:30'!
atRow: y put: aCollection
	"Put in a whole row."

	aCollection size = self width ifFalse: [self error: 'wrong row size'].
	aCollection doWithIndex: [:value :x | self at: x at: y put: value].
	^ aCollection! !


!Array2D methodsFor: 'converting' stamp: 'sma 4/22/2000 18:38'!
asArray
	^ contents copy! !


!Array2D methodsFor: 'copying' stamp: 'sma 4/22/2000 18:37'!
copy
	^ super copy setContents: contents copy! !


!Array2D methodsFor: 'enumeration' stamp: 'sma 4/22/2000 18:14'!
do: aBlock
	"Iterate with X varying most quickly.  6/20/96 tk"

	contents do: aBlock! !

!Array2D methodsFor: 'enumeration' stamp: 'sma 4/22/2000 18:39'!
rowAndColumnValuesDo: aBlock
	1 to: self width do: [:col |
		1 to: self height do: [:row |
			aBlock value: row value: col value: (self at: row at: col)]]! !

!Array2D methodsFor: 'enumeration' stamp: 'sma 4/22/2000 18:39'!
rowsAndColumnsDo: aBlock
	1 to: self width do: [:col |
		1 to: self height do: [:row |
			aBlock value: row value: col]]! !


!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:24'!
extent: extent fromArray: anArray
	"Load receiver 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: 'private' stamp: 'sma 4/22/2000 18:16'!
indexX: x y: y
	(x < 1 or: [x > width]) ifTrue: [self errorSubscriptBounds: x].
	^ y - 1 * width + x! !

!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:37'!
setContents: aCollection
	contents _ aCollection! !

!Array2D methodsFor: 'private' stamp: 'sma 4/22/2000 18:13'!
width: x height: y type: collectionClass
	"Set the number of elements in the first and second dimension.
	collectionClass 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 _ collectionClass new: x * y! !

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

Array2D class
	instanceVariableNames: ''!

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:40'!
extent: aPoint
	^ self width: aPoint x height: aPoint y! !

!Array2D class methodsFor: 'instance creation'!
new
	"Override ArrayedCollection.  6/20/96 tk"
	^ self basicNew! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:11'!
new: size
	self error: 'Use >>self width: x height: y<< instead'! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:10'!
width: width height: height
	^ self basicNew width: width height: height type: Array! !

!Array2D class methodsFor: 'instance creation' stamp: 'sma 4/22/2000 18:10'!
width: width height: height type: collectionClass
	^ self basicNew width: width height: height type: collectionClass! !
SequenceableCollection subclass: #ArrayedCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!ArrayedCollection commentStamp: '<historical>' prior: 0!
I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.!


!ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'!
size
	"Answer how many elements the receiver contains."

	<primitive: 62>
	^ self basicSize! !


!ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'!
add: newObject
	self shouldNotImplement! !


!ArrayedCollection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 14:20'!
flattenOnStream: aStream 
	aStream writeArrayedCollection: self! !


!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: 'printing' stamp: 'RAA 6/23/2000 08:24'!
writeOnGZIPByteStream: aStream 
	
	aStream nextPutAllBytes: self! !


!ArrayedCollection methodsFor: 'private'!
defaultElement

	^nil! !

!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 methodsFor: 'sorting' stamp: 'sma 5/12/2000 18:18'!
asSortedArray
	self isSorted ifTrue: [^ self asArray].
	^ super asSortedArray! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:57'!
isSorted
	"Return true if the receiver is sorted by the given criterion.
	Optimization for isSortedBy: [:a :b | a <= b]."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm _ self first.
	2 to: self size do: 
		[:index | 
		elm _ self at: index.
		lastElm <= elm ifFalse: [^ false].
		lastElm _ elm].
	^ true! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:58'!
isSortedBy: aBlock
	"Return true if the receiver is sorted by the given criterion."

	| lastElm elm |
	self isEmpty ifTrue: [^ true].
	lastElm _ self first.
	2 to: self size do: 
		[:index | 
		elm _ self at: index.
		(aBlock value: lastElm value: elm) ifFalse: [^ false].
		lastElm _ elm].
	^ true! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:28'!
mergeFirst: first middle: middle last: last into: dst by: aBlock
	"Private. Merge the sorted ranges [first..middle] and [middle+1..last] 
	of the receiver into the range [first..last] of dst."

	| i1 i2 val1 val2 out |
	i1 _ first.
	i2 _ middle + 1.
	val1 _ self at: i1.
	val2 _ self at: i2.
	out _ first - 1.  "will be pre-incremented"

	"select 'lower' half of the elements based on comparator"
	[(i1 <= middle) and: [i2 <= last]] whileTrue:
		[(aBlock value: val1 value: val2)
			ifTrue: [dst at: (out _ out + 1) put: val1.
					val1 _ self at: (i1 _ i1 + 1)]
			ifFalse: [dst at: (out _ out + 1) put: val2.
					i2 _ i2 + 1.
					i2 <= last ifTrue: [val2 _ self at: i2]]].

	"copy the remaining elements"
	i1 <= middle
		ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1]
		ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:25'!
mergeSortFrom: startIndex to: stopIndex by: aBlock
	"Sort the given range of indices using the mergesort algorithm.
	Mergesort is a worst-case O(N log N) sorting algorithm that usually
	does only half as many comparisons as heapsort or quicksort."

	"Details: recursively split the range to be sorted into two halves,
	mergesort each half, then merge the two halves together. An extra 
	copy of the data is used as temporary storage and successive merge 
	phases copy data back and forth between the receiver and this copy.
	The recursion is set up so that the final merge is performed into the
	receiver, resulting in the receiver being completely sorted."

	self size <= 1 ifTrue: [^ self].  "nothing to do"
	startIndex = stopIndex ifTrue: [^ self].
	self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index"
	self assert: [stopIndex <= self size]. "bad stop index"
	self
		mergeSortFrom: startIndex
		to: stopIndex 
		src: self clone 
		dst: self 
		by: aBlock! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:26'!
mergeSortFrom: first to: last src: src dst: dst by: aBlock
	"Private. Split the range to be sorted in half, sort each half, and 
	merge the two half-ranges into dst."

	| middle |
	first = last ifTrue: [^ self].
	middle _ (first + last) // 2.
	self mergeSortFrom: first to: middle src: dst dst: src by: aBlock.
	self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock.
	src mergeFirst: first middle: middle last: last into: dst by: aBlock! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:22'!
sort
	"Sort this array into ascending order using the '<=' operator."

	self sort: [:a :b | a <= b]! !

!ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:21'!
sort: aSortBlock 
	"Sort this array using aSortBlock. The block should take two arguments
	and return true if the first element should preceed the second one."

	self
		mergeSortFrom: 1
		to: self size
		by: aSortBlock! !

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

ArrayedCollection class
	instanceVariableNames: ''!

!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! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
	"Answer a new instance of me, containing only the 6 arguments as elements."

	| newCollection |
	newCollection _ self new: 6.
	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 at: 6 put: sixthObject.
	^ newCollection! !

!ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! !


!ArrayedCollection class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 10:03'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	self instSize > 0 ifTrue: 
		[self error: 'cannot auto-coerce arrays with named instance variables'].
	cg generateCoerceToObjectFromPtr: aNode on: aStream! !

!ArrayedCollection class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:18'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg 
		generateCoerceToPtr: (self ccgDeclareCForVar: '')
		fromObject: aNode on: aStream! !
Halt subclass: #AssertionFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Extensions'!
ParseNode subclass: #AssignmentNode
	instanceVariableNames: 'variable value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!AssignmentNode commentStamp: '<historical>' 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' stamp: 'di 3/22/1999 12:00'!
variable: aVariable value: expression from: encoder

	(aVariable isMemberOf: MessageAsTempNode)
		ifTrue: ["Case of remote temp vars"
				^ 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' stamp: 'di 6/7/2000 10:32'!
printOn: aStream indent: level

	aStream dialect = #SQ00
		ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Set '].
				variable printOn: aStream indent: level.
				aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: ' to '].
				value printOn: aStream indent: level + 2]
		ifFalse: [variable printOn: aStream indent: level.
				aStream nextPutAll: ' _ '.
				value printOn: aStream indent: level + 2]! !

!AssignmentNode methodsFor: 'printing' stamp: 'di 4/25/2000 13:52'!
printOn: aStream indent: level precedence: p

	(aStream dialect = #SQ00
			ifTrue: [p < 3]
			ifFalse: [p < 4])
		ifTrue: [aStream nextPutAll: '('.
				self printOn: aStream indent: level.
				aStream nextPutAll: ')']
		ifFalse: [self printOn: aStream indent: level]! !


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


!AssignmentNode methodsFor: 'C translation' stamp: 'hg 8/14/2000 15:33'!
asTranslatorNode
	^TAssignmentNode new
		setVariable: variable asTranslatorNode
		expression: value asTranslatorNode;
		comment: comment! !


!AssignmentNode methodsFor: 'tiles' stamp: 'di 11/10/2000 17:55'!
asMorphicSyntaxIn: parent

	| row |

	row _ parent addRow: #assignment on: self.
	variable asMorphicSyntaxIn: row.
	row addToken: ' _ ' type: #assignment on: self.
	value asMorphicSyntaxIn: row.
	^row
! !

!AssignmentNode methodsFor: 'tiles' stamp: 'RAA 8/15/1999 16:31'!
explanation

	^'The value of ',value explanation,' is being stored in ',variable explanation
! !
TileMorph subclass: #AssignmentTileMorph
	instanceVariableNames: 'assignmentRoot assignmentSuffix dataType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 1/17/1999 21:10'!
computeOperatorOrExpression
	| aSuffix |
	operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol.
	aSuffix _ ScriptingSystem wordingForAssignmentSuffix: assignmentSuffix.
	operatorReadoutString _ assignmentRoot, ' ', aSuffix.
 	self line1: operatorReadoutString.
	self addArrowsIfAppropriate! !

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

!AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 1/17/1999 21:10'!
setAssignmentSuffix: aString
	assignmentSuffix _ aString.
	self computeOperatorOrExpression.
	type _ #operator.
 	self line1: (ScriptingSystem wordingForOperator: operatorOrExpression).
	self addArrowsIfAppropriate; updateLiteralLabel! !

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


!AssignmentTileMorph methodsFor: 'arrow' stamp: 'sw 10/13/2000 12:58'!
addArrowsIfAppropriate
	"If the receiver's slot is of an appropriate type, add arrows to the tile.  The list of types wanting arrows is at this point simply hard-coded."

	(#(number sound boolean menu buttonPhase) includes: dataType)  ifTrue: [self addArrows]! !

!AssignmentTileMorph methodsFor: 'arrow' 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: 'code generation' stamp: 'sw 1/25/2001 12:16'!
storeCodeOn: aStream indent: tabCount
	"Generate code for an assignment statement.  The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now"

	assignmentSuffix = ':'
		ifTrue:   "Simple assignment, don't need existing value"
			[aStream nextPutAll: (ScriptingSystem setterSelectorFor: assignmentRoot).
			aStream space]
		ifFalse:  "Assignments that require that old values be retrieved"
			[aStream nextPutAll: ' assign', (assignmentSuffix copyWithout: $:), 'Getter: #'.
			aStream nextPutAll: (ScriptingSystem getterSelectorFor: assignmentRoot).
			aStream nextPutAll: ' setter: #'.
			aStream nextPutAll: (ScriptingSystem setterSelectorFor: assignmentRoot).
			aStream nextPutAll: ' amt: ']! !


!AssignmentTileMorph methodsFor: 'display' stamp: 'sw 1/31/98 00:42'!
updateLiteralLabel
	self computeOperatorOrExpression.
	super updateLiteralLabel! !
LookupKey subclass: #Association
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!Association commentStamp: '<historical>' prior: 0!
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' stamp: 'MPW 1/4/1901 08:31'!
propertyListOn: aStream
	aStream write:key; print:'='; write:value.
! !

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


!Association methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 20:53'!
byteEncode: aStream
	aStream writeAssocation:self.! !


!Association methodsFor: 'objects from disk' stamp: 'tk 10/3/2000 13:03'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am a known global, write a proxy that will hook up with the same resource in the destination system."

	^ (Smalltalk associationAt: key ifAbsent: [nil]) == self 
		ifTrue: [dp _ DiskProxy global: #Smalltalk selector: #associationOrUndeclaredAt: 
							args: (Array with: key).
			refStrm replace: self with: dp.
			dp]
		ifFalse: [self]! !

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

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! !
Object subclass: #AsyncFile
	instanceVariableNames: 'name writeable semaphore fileHandle '
	classVariableNames: 'Busy Error '
	poolDictionaries: ''
	category: 'System-Files'!
!AsyncFile commentStamp: '<historical>' prior: 0!
An asynchronous file allows simple file read and write operations to be performed in parallel with other processing. This is useful in multimedia applications that need to stream large amounts of sound or image data from or to a file while doing other work.
!


!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClose: fHandle
	"Close this file. Do nothing if primitive fails."

	<primitive: 'primitiveAsyncFileClose' module: 'AsynchFilePlugin'>
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpen: fileName forWrite: openForWrite semaIndex: semaIndex
	"Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise."

	<primitive: 'primitiveAsyncFileOpen' module: 'AsynchFilePlugin'>
	^ nil
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadResult: fHandle intoBuffer: buffer at: startIndex count: count
	"Copy the result of the last read operation into the given buffer starting at the given index. The buffer may be any sort of bytes or words object, excluding CompiledMethods. Answer the number of bytes read. A negative result means:
		-1 the last operation is still in progress
		-2 the last operation encountered an error"

	<primitive: 'primitiveAsyncFileReadResult' module: 'AsynchFilePlugin'>
	self primitiveFailed
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadStart: fHandle fPosition: fPosition count: count
	"Start a read operation of count bytes starting at the given offset in the given file."

	<primitive: 'primitiveAsyncFileReadStart' module: 'AsynchFilePlugin'>
	self error: 'READ THE COMMENT FOR THIS METHOD.'

"NOTE: This method will fail if there is insufficient C heap to allocate an internal buffer of the required size (the value of count).  If you are trying to read a movie file, then the buffer size will be height*width*2 bytes.  Each Squeak image retains a value to be used for this allocation, and it it initially set to 0.  If you are wish to play a 640x480 movie, you need room for a buffer of 640*480*2 = 614400 bytes.  You should execute the following...

	Smalltalk extraVMMemory 2555000.

Then save-and-quit, restart, and try to open the movie file again.  If you are using Async files in another way, find out the value of count when this failure occurs (call it NNNN), and instead of the above, execute...

	Smalltalk extraVMMemory: Smalltalk extraVMMemory + NNNN

then save-and-quit, restart, and try again.
"

! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWriteResult: fHandle
	"Answer the number of bytes written. A negative result means:
		-1 the last operation is still in progress
		-2 the last operation encountered an error"

	<primitive: 'primitiveAsyncFileWriteResult' module: 'AsynchFilePlugin'>
	self primitiveFailed
! !

!AsyncFile methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: startIndex count: count
	"Start a write operation of count bytes starting at the given index in the given buffer. The buffer may be any sort of bytes or words object, excluding CompiledMethods. The contents of the buffer are copied into an internal buffer immediately, so the buffer can be reused after the write operation has been started. Fail if there is insufficient C heap to allocate an internal buffer of the requested size."

	<primitive: 'primitiveAsyncFileWriteStart' module: 'AsynchFilePlugin'>
	writeable ifFalse: [^ self error: 'attempt to write a file opened read-only'].
	self primitiveFailed
! !


!AsyncFile methodsFor: 'as yet unclassified'!
close

	fileHandle ifNil: [^ self].  "already closed"
	self primClose: fileHandle.
	Smalltalk unregisterExternalObject: semaphore.
	semaphore _ nil.
	fileHandle _ nil.
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'!
fileHandle
	^ fileHandle! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 07:54'!
open: fullFileName forWrite: aBoolean
	"Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise.
	If openForWrite is true, then:
		if there is no existing file with this name, then create one
		else open the existing file in read-write mode
	otherwise:
		if there is an existing file with this name, then open it read-only
		else answer nil."
	"Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file."
	"Note: On some platforms (e.g., Mac), a file can only have one writer at a time."

	| semaIndex |
	name _ fullFileName.
	writeable _ aBoolean.
	semaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	fileHandle _ self primOpen: name forWrite: writeable semaIndex: semaIndex.
	fileHandle ifNil: [
		Smalltalk unregisterExternalObject: semaphore.
		semaphore _ nil.
		^ nil].
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 08:28'!
readByteCount: byteCount fromFilePosition: fPosition onCompletionDo: aBlock
	"Start a read operation to read byteCount's from the given position in this file. and fork a process to await its completion. When the operation completes, evaluate the given block. Note that, since the completion block may run asynchronous, the client may need to use a SharedQueue or a semaphore for synchronization."

	| buffer n |
	buffer _ String new: byteCount.
	self primReadStart: fileHandle fPosition: fPosition count: byteCount.
	"here's the process that awaits the results:"
	[
		[	semaphore wait.
		  	n _ self primReadResult: fileHandle intoBuffer: buffer at: 1 count: byteCount.
		  	n = Busy.
		] whileTrue.  "loop while busy in case the semaphore had excess signals"
		n = Error ifTrue: [^ self error: 'asynchronous read operation failed'].
		aBlock value: buffer.
	] forkAt: Processor userInterruptPriority.
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 10:07'!
test: byteCount fileName: fileName
	"AsyncFile new test: 10000 fileName: 'testData'"

	| buf1 buf2 bytesWritten bytesRead |
	buf1 _ String new: byteCount withAll: $x.
	buf2 _ String new: byteCount.
	self open: fileName forWrite: true.
	self primWriteStart: fileHandle
		fPosition: 0
		fromBuffer: buf1
		at: 1
		count: byteCount.
	semaphore wait.
	bytesWritten _ self primWriteResult: fileHandle.
	self close.
	
	self open: fileName forWrite: false.
	self primReadStart: fileHandle fPosition: 0 count: byteCount.
	semaphore wait.
	bytesRead _
		self primReadResult: fileHandle
			intoBuffer: buf2
			at: 1
			count: byteCount.
	self close.

	buf1 = buf2 ifFalse: [self error: 'buffers do not match'].
	^ 'wrote ', bytesWritten printString, ' bytes; ',
	   'read ', bytesRead printString, ' bytes'
! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'!
waitForCompletion
	semaphore wait! !

!AsyncFile methodsFor: 'as yet unclassified' stamp: 'jm 6/25/1998 17:28'!
writeBuffer: buffer atFilePosition: fPosition onCompletionDo: aBlock
	"Start an operation to write the contents of the buffer at given position in this file, and fork a process to await its completion. When the write completes, evaluate the given block. Note that, since the completion block runs asynchronously, the client may need to use a SharedQueue or a semaphore for synchronization."

	| n |
	self primWriteStart: fileHandle
		fPosition: fPosition
		fromBuffer: buffer
		at: 1
		count: buffer size.
	"here's the process that awaits the results:"
	[
		[	semaphore wait.
		  	n _ self primWriteResult: fileHandle.
		  	n = Busy.
		] whileTrue.  "loop while busy in case the semaphore had excess signals"
		n = Error ifTrue: [^ self error: 'asynchronous write operation failed'].
		n = buffer size ifFalse: [^ self error: 'did not write the entire buffer'].
		aBlock value.
	] forkAt: Processor userInterruptPriority.
! !

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

AsyncFile class
	instanceVariableNames: ''!

!AsyncFile class methodsFor: 'class initialization' stamp: 'jm 6/25/1998 17:33'!
initialize
	"AsyncFile initialize"

	"Possible abnormal I/O completion results."
	Busy _ -1.
	Error _ -2.
! !
TestInterpreterPlugin subclass: #AsynchFilePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!AsynchFilePlugin commentStamp: '<historical>' prior: 0!
Implements the asynchronous file primtives!


!AsynchFilePlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:52'!
initialiseModule
	"Initialise the module"
	self export: true.
	^self cCode: 'asyncFileInit()' inSmalltalk:[true]! !

!AsynchFilePlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:54'!
shutdownModule
	"Initialise the module"
	self export: true.
	^self cCode: 'asyncFileShutdown()' inSmalltalk:[true]! !


!AsynchFilePlugin methodsFor: 'primitives' stamp: 'TPR 2/7/2000 13:01'!
asyncFileValueOf: oop
	"Return a pointer to the first byte of the async file record within the given Smalltalk bytes object, or nil if oop is not an async file record."

	self returnTypeC: 'AsyncFile *'.
	interpreterProxy success:
		((interpreterProxy isIntegerObject: oop) not and:
		 [(interpreterProxy isBytes: oop) and:
		 [(interpreterProxy slotSizeOf: oop) = (self cCode: 'sizeof(AsyncFile)')]]).
	interpreterProxy failed ifTrue: [^ nil].
	^ self cCode: '(AsyncFile *) (oop + 4)'
! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 17:08'!
primitiveAsyncFileClose: fh 
	| f |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileClose'
		parameters: #(Oop ).
	f _ self asyncFileValueOf: fh.
	self asyncFileClose: f! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 17:10'!
primitiveAsyncFileOpen: fileName forWrite: writeFlag semaIndex: semaIndex 
	| fileNameSize fOop f |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileOpen'
		parameters: #(String Boolean SmallInteger ).

	fileNameSize _ interpreterProxy slotSizeOf: (fileName asOop: String).
	fOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: (self cCode: 'sizeof(AsyncFile)').
	f _ self asyncFileValueOf: fOop.
	interpreterProxy failed ifFalse: [self cCode: 'asyncFileOpen(f, (int)fileName, fileNameSize, writeFlag, semaIndex)'].
	^ fOop! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'JMM 8/10/2000 13:04'!
primitiveAsyncFileReadResult: fhandle intoBuffer: buffer at: start count: num 
	| bufferSize bufferPtr r f count startIndex |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileReadResult'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	f _ self asyncFileValueOf: fhandle.

	count _ num.
	startIndex _ start.
	bufferSize _ interpreterProxy slotSizeOf: buffer. "in bytes or words"
	(interpreterProxy isWords: buffer)
		ifTrue: ["covert word counts to byte counts"
			count _ count * 4.
			startIndex _ startIndex - 1 * 4 + 1.
			bufferSize _ bufferSize * 4].
	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= bufferSize]).

	bufferPtr _ (self cCoerce: (interpreterProxy firstIndexableField: buffer)
				to: 'int')
				+ startIndex - 1. 	"adjust for zero-origin indexing"
	interpreterProxy failed ifFalse: [r _ self cCode: 'asyncFileReadResult(f, bufferPtr, count)'].
	^ r asOop: SmallInteger! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'ar 5/13/2000 16:00'!
primitiveAsyncFileReadStart: fHandle fPosition: fPosition count: count
	| f |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileReadStart'
		parameters: #(Oop SmallInteger SmallInteger).
	f _ self asyncFileValueOf: fHandle.
	self cCode: 'asyncFileReadStart(f, fPosition, count)'
! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'TPR 2/7/2000 16:09'!
primitiveAsyncFileWriteResult: fHandle

	| f r |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileWriteResult'
		parameters:#(Oop).

	f _ self asyncFileValueOf: fHandle.
	r _ self cCode:' asyncFileWriteResult(f)'.
	^r asOop: SmallInteger! !

!AsynchFilePlugin methodsFor: 'primitives' stamp: 'JMM 8/10/2000 13:05'!
primitiveAsyncFileWriteStart: fHandle fPosition: fPosition fromBuffer: buffer at: start count: num 
	| f bufferSize bufferPtr count startIndex |
	self var: #f declareC: 'AsyncFile *f'.
	self primitive: 'primitiveAsyncFileWriteStart'
		parameters: #(Oop SmallInteger Oop SmallInteger SmallInteger ).
	f _ self asyncFileValueOf: fHandle.
	interpreterProxy failed ifTrue: [^ nil].

	count _ num.
	startIndex _ start.
	bufferSize _ interpreterProxy slotSizeOf: buffer.	"in bytes or words"
	(interpreterProxy isWords: buffer)
		ifTrue: ["covert word counts to byte counts"
			count _ count * 4.
			startIndex _ startIndex - 1 * 4 + 1.
			bufferSize _ bufferSize * 4].
	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= bufferSize]).
	bufferPtr _ (self cCoerce: (interpreterProxy firstIndexableField: buffer)
				to: 'int')
				+ startIndex - 1.	"adjust for zero-origin indexing"
	interpreterProxy failed ifFalse: [self cCode: 'asyncFileWriteStart(f, fPosition, bufferPtr, count)']! !

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

AsynchFilePlugin class
	instanceVariableNames: ''!

!AsynchFilePlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:21'!
headerFile
^'/* Header file for AsynchFile plugin */
/* module initialization/shutdown */
int asyncFileInit(void);
int asyncFileShutdown(void);

/*** Experimental Asynchronous File I/O ***/
typedef struct {
	int			sessionID;
	void		*state;
} AsyncFile;

int asyncFileClose(AsyncFile *f);
int asyncFileOpen(AsyncFile *f, int fileNamePtr, int fileNameSize, int writeFlag, int semaIndex);
int asyncFileRecordSize();
int asyncFileReadResult(AsyncFile *f, int bufferPtr, int bufferSize);
int asyncFileReadStart(AsyncFile *f, int fPosition, int count);
int asyncFileWriteResult(AsyncFile *f);
int asyncFileWriteStart(AsyncFile *f, int fPosition, int bufferPtr, int bufferSize);
'! !
EllipseMorph subclass: #AtomMorph
	instanceVariableNames: 'velocity '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!AtomMorph methodsFor: 'as yet unclassified' stamp: 'jm 8/10/1998 17:40'!
bounceIn: aRect
	"Move this atom one step along its velocity vector and make it bounce if it goes outside the given rectangle. Return true if it is bounced."

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

!AtomMorph methodsFor: 'as yet unclassified'!
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: 'as yet unclassified'!
infected

	^ color = Color red! !

!AtomMorph methodsFor: 'as yet unclassified'!
infected: aBoolean

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

!AtomMorph methodsFor: 'as yet unclassified'!
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: 'as yet unclassified' stamp: 'RAA 12/15/2000 07:32'!
randomPositionIn: aRectangle maxVelocity: maxVelocity
	"Give this atom a random position and velocity."

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

!AtomMorph methodsFor: 'as yet unclassified'!
velocity

	^ velocity! !

!AtomMorph methodsFor: 'as yet unclassified'!
velocity: newVelocity

	velocity _ newVelocity.! !

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

AtomMorph class
	instanceVariableNames: ''!

!AtomMorph class methodsFor: 'as yet unclassified' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Stream subclass: #AttributedTextStream
	instanceVariableNames: 'characters attributeRuns currentAttributes attributesChanged '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!AttributedTextStream commentStamp: '<historical>' prior: 0!
a stream on Text's which keeps track of the last attribute put; new characters are added with those attributes.

instance vars:

	characters - a WriteStream of the characters in the stream
	attributeRuns - a RunArray with the attributes for the stream
	currentAttributes - the attributes to be used for new text
	attributesChanged - whether the attributes have changed since the last addition!


!AttributedTextStream methodsFor: 'retrieving the text' stamp: 'ls 6/27/1998 15:04'!
contents
	| ans |
	ans _ Text new: characters size.
	ans setString: characters contents  setRuns: attributeRuns.   "this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...."
	^ans! !


!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ls 6/27/1998 14:59'!
nextPut: aChar
	attributesChanged 
		ifTrue: [ 
			attributeRuns addLast: currentAttributes.
			attributesChanged _ false ]
		ifFalse: [
			attributeRuns  repeatLastIfEmpty: [ OrderedCollection new ] ].
	characters nextPut: aChar! !

!AttributedTextStream methodsFor: 'stream protocol' stamp: 'ls 6/27/1998 15:02'!
nextPutAll: aString
	"add an entire string with the same attributes"
	attributesChanged 
		ifTrue: [ attributeRuns addLast: currentAttributes times: aString size.
			attributesChanged _ false. ]
		ifFalse: [ attributeRuns repeatLast: aString size  ifEmpty: [ OrderedCollection new ] ].
	characters nextPutAll: aString.! !


!AttributedTextStream methodsFor: 'access' stamp: 'ls 6/27/1998 15:09'!
currentAttributes
	"return the current attributes"
	^currentAttributes! !

!AttributedTextStream methodsFor: 'access' stamp: 'ls 7/28/1998 02:08'!
currentAttributes: newAttributes
	"set the current attributes"
	attributesChanged _ currentAttributes ~= newAttributes.
	currentAttributes _ newAttributes.
! !

!AttributedTextStream methodsFor: 'access' stamp: 'ls 9/10/1998 03:36'!
size
	"number of characters in the stream so far"
	^characters size! !


!AttributedTextStream methodsFor: 'private-initialization' stamp: 'ls 6/27/1998 15:08'!
initialize
	characters _ WriteStream on: String new.
	currentAttributes _ OrderedCollection new.
	attributesChanged _ true.
	attributeRuns _ RunArray new.
	! !

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

AttributedTextStream class
	instanceVariableNames: ''!

!AttributedTextStream class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:07'!
new
	^super basicNew initialize! !
EToyCommunicatorMorph subclass: #AudioChatGUI
	instanceVariableNames: 'mycodec myrecorder mytargetip myalert playOnArrival theConnectButton soundBlockNumber soundMessageID queueForMultipleSends transmitWhileRecording theTalkButton handsFreeTalking handsFreeTalkingFlashTime '
	classVariableNames: 'DebugLog LiveMessages NewAudioMessages PlayOnArrival '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/7/2000 06:51'!
changeTalkButtonLabel

	| bText |
	self transmitWhileRecording.
	handsFreeTalking ifTrue: [
		theTalkButton
			labelUp: 'Talk';
			labelDown: 'Release';
			label: 'Talk'.
		bText _ 'Click once to begin a message. Click again to end the message.'
	] ifFalse: [
		theTalkButton
			labelUp: 'Talk';
			labelDown: (transmitWhileRecording ifTrue: ['TALKING'] ifFalse: ['RECORDING']);
			label: 'Talk'.
		bText _ 'Press and hold to record a message.'
	].
	transmitWhileRecording ifTrue: [
		bText _ bText , ' The message will be sent while you are speaking.'
	] ifFalse: [
		bText _ bText , ' The message will be sent when you are finished.'
	].
	theTalkButton setBalloonText: bText.
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 13:25'!
connect

	mytargetip _ FillInTheBlank 
		request: 'Connect to?' 
		initialAnswer: (mytargetip ifNil: ['']).
	mytargetip _ NetNameResolver stringFromAddress: (
		(NetNameResolver addressFromString: mytargetip) ifNil: [^mytargetip _ '']
	)
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 13:09'!
currentConnectionStateString

	^'?'
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'TBP 3/5/2000 16:22'!
defaultBackgroundColor
	"In a better design, this would be handled by preferences."
	^Color yellow."r: 1.0 g: 0.7 b: 0.8"! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/6/2000 18:27'!
getChoice: aSymbol

	aSymbol == #playOnArrival ifTrue: [^self class playOnArrival].
	aSymbol == #transmitWhileRecording ifTrue: [^self transmitWhileRecording].
	aSymbol == #handsFreeTalking ifTrue: [^self handsFreeTalking].

! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'TBP 3/5/2000 16:02'!
initialExtent
	"Nice and small--that was the idea.
	It shouldn't take up much screen real estate."
	^200@100! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 13:01'!
objectsInQueue

	^self class numberOfNewMessages! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 12:26'!
playNextMessage

	self class playNextAudioMessage.
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/4/2000 14:59'!
removeConnectButton

	theConnectButton ifNotNil: [
		theConnectButton delete.
		theConnectButton _ nil.
	].! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/12/2000 18:11'!
step

	| now |
	super step.
	self transmitWhileRecording ifTrue: [self sendAnyCompletedSounds].
	self handsFreeTalking & myrecorder isRecording ifTrue: [
		now _ Time millisecondClockValue.
		((handsFreeTalkingFlashTime ifNil: [0]) - now) abs > 200 ifTrue: [
			theTalkButton color: (
				theTalkButton color = self buttonColor 
						ifTrue: [Color white] 
						ifFalse: [self buttonColor]
			).
			handsFreeTalkingFlashTime _ now.
		].
	].
	self class playOnArrival ifTrue: [self playNextMessage].

	"myrecorder ifNotNil: [
		myrecorder recorder samplingRate printString ,'   ',
		SoundPlayer samplingRate printString,'    '

		displayAt: 0@0
	]."! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/12/2000 18:09'!
stepTime

	myrecorder ifNil: [^200].
	myrecorder isRecording ifFalse: [^200].
	^20! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/2/2000 07:47'!
stepTimeIn: aSystemWindow

	^self stepTime
! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'Tbp 4/11/2000 16:49'!
stop

	myrecorder stop.
	self send.! !

!AudioChatGUI methodsFor: 'stuff' stamp: 'RAA 8/7/2000 06:52'!
toggleChoice: aSymbol

	aSymbol == #playOnArrival ifTrue: [
		^PlayOnArrival _ self class playOnArrival not
	].
	aSymbol == #transmitWhileRecording ifTrue: [
		transmitWhileRecording _ self transmitWhileRecording not.
		self changeTalkButtonLabel.
		^transmitWhileRecording
	].
	aSymbol == #handsFreeTalking ifTrue: [
		handsFreeTalking _ self handsFreeTalking not.
		self changeTalkButtonLabel.
		^handsFreeTalking
	].


! !


!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:33'!
buttonColor 

	^Color lightBrown! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:36'!
connectButton
	
	^SimpleButtonMorph new
		label: 'Connect';
		color: self buttonColor;
		target: self;
		actWhen: #buttonUp;
		actionSelector: #connect;
		setBalloonText: 'Press to connect to another audio chat user.'

! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/7/2000 06:51'!
initialize

	super initialize.

	transmitWhileRecording _ false.
	handsFreeTalking _ false.	
	mycodec _ GSMCodec new.
	myrecorder _ ChatNotes new.
	mytargetip _ ''.
	color _ Color yellow.
	borderWidth _ 4.
	borderColor _ Color black.
	self start2.
	self changeTalkButtonLabel.
	! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/4/2000 14:26'!
ipAddress: aString

	mytargetip _ aString! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:22'!
messageWaitingAlertIndicator

	| messageCounter |
	myalert _ AlertMorph new socketOwner: self.
	messageCounter _ UpdatingStringMorph on: self selector: #objectsInQueue.
	myalert addMorph: messageCounter.
	messageCounter contents: '0'; color: Color white.
	messageCounter align: messageCounter center with: myalert center.
	myalert setBalloonText: 'New messages indicator. This will flash and show the number of messages when there are messages that you haven''t listened to. You can click here to play the next message.'.

	myalert on: #mouseUp send: #playNextMessage to: self.
	^myalert! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:34'!
playButton

	^SimpleButtonMorph new
		label: 'Play';
		color: self buttonColor;
		target: self;
		actWhen: #buttonUp;
		actionSelector: #playNextMessage;
		setBalloonText: 'Play the next new message.'

! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/2/2000 16:37'!
recordAndStopButton

	^ChatButtonMorph new
		labelUp: 'Record';
		labelDown: 'RECORDING';
		label: 'Record';
		color: self buttonColor;
		target: self;
		actionUpSelector: #stop;
		actionDownSelector: #record;
		setBalloonText: 'Press and hold to record a message. It will be sent when you release the mouse.'
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/4/2000 14:05'!
start

	| myUpdatingText playButton myOpenConnectionButton myStopButton window  |
"
--- old system window version ---
"
	Socket initializeNetwork.
	myrecorder initialize.

	window _ (SystemWindow labelled: 'iSCREAM') model: self.

	myalert _ AlertMorph new.
	myalert socketOwner: self.
	window addMorph: myalert frame: (0.35@0.4 corner: 0.5@0.7).

	(playButton _ self playButton) center: 200@300.
	window addMorph: playButton frame: (0.5@0.4 corner: 1.0@0.7).

	(myOpenConnectionButton _ self connectButton) center: 250@300.
	window addMorph: myOpenConnectionButton frame: (0.5@0 corner: 1.0@0.4).

	(myStopButton _ self recordAndStopButton) center: 300@300.
	window addMorph: myStopButton frame: (0.5@0.7 corner: 1.0@1.0).

	myUpdatingText _ UpdatingStringMorph on: self selector: #objectsInQueue.
	window addMorph: myUpdatingText frame: (0.41@0.75 corner: 0.45@0.95).

	"myUserList init."! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:25'!
start2

	Socket initializeNetwork.
	myrecorder initialize.

	self addARow: {
		self inAColumn: {
			(
				self inARow: {
					self inAColumn: {self toggleForSendWhileTalking}.
					self inAColumn: {self toggleForHandsFreeTalking}.
					self inAColumn: {self toggleForPlayOnArrival}.
				}
			) hResizing: #shrinkWrap.
			self inARow: {
				self talkBacklogIndicator.
				self messageWaitingAlertIndicator.
			}.
		}.
		self inAColumn: {
			theConnectButton _ self connectButton.
			self playButton.
			theTalkButton _ self talkButton.
		}.
	}.
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:24'!
talkBacklogIndicator

	^(UpdatingStringMorph on: self selector: #talkBacklog)
		setBalloonText: 'Approximate number of seconds of delay in your messages getting to the other end.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/7/2000 06:52'!
talkButton

	^ChatButtonMorph new
		labelUp: 'xxx';
		labelDown: 'xxx';
		label: 'xxx';
		color: self buttonColor;
		target: self;
		actionUpSelector: #talkButtonUp;
		actionDownSelector: #talkButtonDown;
		setBalloonText: 'xxx'
! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:14'!
toggleForHandsFreeTalking

	^self
		simpleToggleButtonFor: self 
		attribute: #handsFreeTalking 
		help: 'Whether you want to talk without holding the mouse down.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:15'!
toggleForPlayOnArrival

	^self
		simpleToggleButtonFor: self 
		attribute: #playOnArrival 
		help: 'Whether you want to play messages automatically on arrival.'! !

!AudioChatGUI methodsFor: 'initialization' stamp: 'RAA 8/12/2000 16:14'!
toggleForSendWhileTalking

	^self
		simpleToggleButtonFor: self 
		attribute: #transmitWhileRecording 
		help: 'Whether you want to send messages while recording.'! !


!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 18:25'!
handsFreeTalking

	^handsFreeTalking ifNil: [handsFreeTalking _ false].! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 09:47'!
record

	queueForMultipleSends _ nil.
	myrecorder record.! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 15:01'!
samplingRateForTransmission

	^11025		"try to cut down on amount of data sent for live chats"! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/13/2000 11:44'!
send

	| null rawSound aSampledSound |

	mytargetip isEmpty ifTrue: [
		^self inform: 'You must connect with someone first.'.
	].
	rawSound _ myrecorder recorder recordedSound ifNil: [^self].
	aSampledSound _ rawSound asSampledSound.
"Smalltalk at: #Q3 put: {rawSound. rawSound asSampledSound. aCompressedSound}."
	self transmitWhileRecording ifTrue: [
		self sendOneOfMany: rawSound asSampledSound.
		queueForMultipleSends ifNotNil: [queueForMultipleSends nextPut: nil].
		queueForMultipleSends _ nil.
		^self
	].

	null _ String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeAudioChat,null. 
			Preferences defaultAuthorName,null.
			aSampledSound originalSamplingRate asInteger printString,null.
			(mycodec compressSound: aSampledSound) channels first.
		}
		to: mytargetip
		for: self.

! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 14:34'!
sendAnyCompletedSounds

	| soundsSoFar firstCompleteSound |

	myrecorder isRecording ifFalse: [^self].
	mytargetip isEmpty ifTrue: [^self].
	soundsSoFar _ myrecorder recorder recordedSound ifNil: [^self].
	firstCompleteSound _ soundsSoFar removeFirstCompleteSoundOrNil ifNil: [^self].
	self sendOneOfMany: firstCompleteSound.! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 18:22'!
sendOneOfMany: aSampledSound

	| null message aCompressedSound ratio resultBuf oldSamples newCount t fromIndex val maxVal |

	self samplingRateForTransmission = aSampledSound originalSamplingRate ifTrue: [
		aCompressedSound _ mycodec compressSound: aSampledSound.
	] ifFalse: [
		t _ [
			ratio _ aSampledSound originalSamplingRate // self samplingRateForTransmission.
			oldSamples _ aSampledSound samples.
			newCount _ oldSamples monoSampleCount // ratio.
			resultBuf _ SoundBuffer newMonoSampleCount: newCount.
			fromIndex _ 1.
			maxVal _ 0.
			1 to: newCount do: [ :i |
				maxVal _ maxVal max: (val _ oldSamples at: fromIndex).
				resultBuf at: i put: val.
				fromIndex _ fromIndex + ratio.
			].
		] timeToRun.
		NebraskaDebug at: #soundReductionTime add: {t. maxVal}.
		maxVal < 400 ifTrue: [
			NebraskaDebug at: #soundReductionTime add: {'---dropped---'}.
			^self
		].		"awfully quiet"
		aCompressedSound _ mycodec compressSound: (
			SampledSound new 
				setSamples: resultBuf 
				samplingRate: aSampledSound originalSamplingRate // ratio
		).
	].

	null _ String with: 0 asCharacter.
	message _ {
		EToyIncomingMessage typeAudioChatContinuous,null. 
		Preferences defaultAuthorName,null.
		aCompressedSound samplingRate asInteger printString,null.
		aCompressedSound channels first.
	}.
	queueForMultipleSends ifNil: [
		queueForMultipleSends _ EToyPeerToPeer new 
			sendSomeData: message
			to: mytargetip
			for: self
			multiple: true.
	] ifNotNil: [
		queueForMultipleSends nextPut: message
	].

! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/12/2000 16:18'!
talkBacklog

	^(queueForMultipleSends ifNil: [^0]) size // 2! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/9/2000 18:05'!
talkButtonDown

	EToyListenerMorph confirmListening.
	self handsFreeTalking ifFalse: [^self record].
	theTalkButton label: 'Release'.
! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/9/2000 18:13'!
talkButtonUp

	theTalkButton recolor: self buttonColor.
	self handsFreeTalking ifFalse: [^self stop].
	myrecorder isRecording ifTrue: [
		theTalkButton label: 'Talk'.
		^self stop.
	].
	self record.
	theTalkButton label: 'TALKING'.


! !

!AudioChatGUI methodsFor: 'sending' stamp: 'RAA 8/6/2000 13:08'!
transmitWhileRecording

	^transmitWhileRecording ifNil: [transmitWhileRecording _ false]! !

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

AudioChatGUI class
	instanceVariableNames: ''!

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 16:12'!
debugLog: x
"
AudioChatGUI debugLog: nil
AudioChatGUI debugLog: OrderedCollection new
DebugLog LiveMessages NewAudioMessages PlayOnArrival 
"
	DebugLog _ x.
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/11/2000 11:54'!
handleNewAudioChat2From: dataStream sentBy: senderName ipAddress: ipAddressString

	| newSound seqSound compressed |

	compressed _ self newCompressedSoundFrom: dataStream.
	newSound _ compressed asSound.
"-------an experiment to try
newSound adjustVolumeTo: 7.0 overMSecs: 10
--------"
DebugLog ifNotNil: [
	DebugLog add: {compressed. newSound}.
].
	LiveMessages ifNil: [LiveMessages _ Dictionary new].
	seqSound _ LiveMessages at: ipAddressString ifAbsentPut: [SequentialSound new].
	seqSound isPlaying ifTrue: [
		seqSound
			add: newSound;
			pruneFinishedSounds.
	] ifFalse: [
		seqSound
			initialize;
			add: newSound.
	].
	seqSound isPlaying ifFalse: [seqSound play].! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 19:28'!
handleNewAudioChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| compressed |

	compressed _ self newCompressedSoundFrom: dataStream.
DebugLog ifNotNil: [
	DebugLog add: {compressed}.
].

	self newAudioMessages nextPut: compressed.
	self playOnArrival ifTrue: [self playNextAudioMessage].
	
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/5/2000 19:22'!
initialize

	EToyIncomingMessage
		forType: EToyIncomingMessage typeAudioChat 
		send: #handleNewAudioChatFrom:sentBy:ipAddress: 
		to: self.

	EToyIncomingMessage
		forType: EToyIncomingMessage typeAudioChatContinuous
		send: #handleNewAudioChat2From:sentBy:ipAddress: 
		to: self.


! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 12:16'!
newAudioMessages

	^NewAudioMessages ifNil: [NewAudioMessages _ SharedQueue new].! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 19:28'!
newCompressedSoundFrom: dataStream

	| samplingRate |

	samplingRate _ (dataStream upTo: 0 asCharacter) asNumber.
	^CompressedSoundData new 
		withEToySound: dataStream upToEnd
		samplingRate: samplingRate.
! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:01'!
numberOfNewMessages

	^self newAudioMessages size! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 14:06'!
openAsMorph

	AudioChatGUI new openInWorld.	"old syswindow version in #start"

! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/6/2000 14:23'!
playNextAudioMessage

	(self newAudioMessages nextOrNil ifNil: [^self]) asSound play.! !

!AudioChatGUI class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:14'!
playOnArrival

	^PlayOnArrival ifNil: [PlayOnArrival _ false]! !
EmbeddedServerAction subclass: #AuthorizedServerAction
	instanceVariableNames: 'authorizer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!AuthorizedServerAction commentStamp: '<historical>' 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: 'Network-Pluggable Web Server'!
!AuthorizedSwikiAction commentStamp: '<historical>' 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: 'tk 9/21/1998 08:23'!
authorizer
	"*** Do not use this method to add or delete users!!  The change will not be recorded on the disk!!  Instead call mapName:password:to: in this class.***"
	^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: 'tk 7/6/1998 07:31'!
checkAuthorization: request
	^ authorizer ifNotNil: [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: 'mjg 8/31/1998
15:32'!
process: request
	self checkAuthorization: request.
	^(super process: request).! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 9/13/1998 20:45'!
processSpecial: request
	"Let SwikiAction process this with no authorization check."

	^(super process: request).! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'mdr 8/31/2000 18:41'!
restore: nameOfSwiki
	"Read all files in the directory 'nameOfSwiki'.  Reconstruct the url map."

	| fName |
	super restore: nameOfSwiki.
	fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator), 
				'authorizer'.
	(FileDirectory new fileExists: fName) ifTrue: [
		authorizer _ (FileStream readOnlyFileNamed: fName) fileInObjectAndCode].
! !
AuthorizedSwikiAction subclass: #AuthorizedWriteSwiki
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!AuthorizedWriteSwiki commentStamp: '<historical>' prior: 0!
Allows anyone to read the pages of this Swiki, but only authorized users can edit or change pages.  Can have multiple users, each with a different password.  Each can modify the whole Swiki area.

To restart an existing Authorized Swiki:

	AuthorizedWriteSwiki 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'.
	AuthorizedWriteSwiki setUp: 'SWSecure'.
	s := AuthorizedWriteSwiki new restore: 'SWSecure'.
	s authorizer: a.
!


!AuthorizedWriteSwiki methodsFor: 'as yet unclassified' stamp: 'tk 9/13/1998 20:59'!
process: request
	"Only demand authorization of name and password when requesting the edit page, requesting the append page, receiving an edit, or receiving an append."

	| command coreRef |
	request fields ifNotNil: ["Are there input fields?"
		coreRef _ request message size < 2
			ifTrue: ['1']
			ifFalse: [request message at: 2].
		coreRef = 'searchresult' ifFalse: ["Must be text for an edit!!"
			self checkAuthorization: request]].
	request message size > 2 ifTrue:
			["SearchResult, All, Versions, or Edit"
			command _ request message at: 3.
			command = 'edit' ifTrue:
					[self checkAuthorization: request].
			command = 'insert' ifTrue:
					[self checkAuthorization: request]].

	^(super processSpecial: request).		"all the way up to SwikiAction"! !
Object subclass: #Authorizer
	instanceVariableNames: 'users realm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!Authorizer commentStamp: '<historical>' 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) ]! !
Object subclass: #AutoStart
	instanceVariableNames: 'parameters '
	classVariableNames: 'InstalledLaunchers '
	poolDictionaries: ''
	category: 'System-Support'!

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

AutoStart class
	instanceVariableNames: ''!

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 7/28/1999 17:44'!
deinstall
	"AutoStart deinstall"

	Smalltalk removeFromStartUpList: AutoStart.
	InstalledLaunchers _ nil! !

!AutoStart class methodsFor: 'class initialization' stamp: 'mir 7/28/1999 17:43'!
initialize
	"AutoStart initialize"

	Smalltalk addToStartUpList: AutoStart! !

!AutoStart class methodsFor: 'class initialization' stamp: 'RAA 12/17/2000 12:07'!
startUp
	| startupParameters launchers |
	startupParameters _ AbstractLauncher extractParameters.
	launchers _ self installedLaunchers collect: [:launcher |
		launcher new].
	launchers do: [:launcher |
		launcher parameters: startupParameters].
	launchers do: [:launcher |
		Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! !


!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
addLauncher: launcher
	self installedLaunchers add: launcher! !

!AutoStart class methodsFor: 'accessing' stamp: 'mir 7/28/1999 17:47'!
removeLauncher: launcher
	self installedLaunchers remove: launcher ifAbsent: []! !

!AutoStart class methodsFor: 'accessing' stamp: 'mir 8/6/1999 18:14'!
removeLauncherClass: launcherClass
"	| launchersToBeRemoved |
	launchersToBeRemoved _ self installedLaunchers select: [:launcher |
		launcher class == launcherClass].
	launchersToBeRemoved do: [:launcher | self removeLauncher: launcher]"
	self removeLauncher: launcherClass! !


!AutoStart class methodsFor: 'private' stamp: 'mir 7/28/1999 17:43'!
installedLaunchers
	InstalledLaunchers ifNil: [
		InstalledLaunchers _ OrderedCollection new].
	^InstalledLaunchers! !
InterpreterPlugin subclass: #B3DAcceleratorPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Acceleration'!
!B3DAcceleratorPlugin commentStamp: '<historical>' prior: 0!
B3DAcceleratorPlugin translate!


!B3DAcceleratorPlugin methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 17:23'!
initialiseModule
	self export: true.
	^self b3dxInitialize! !

!B3DAcceleratorPlugin methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 17:23'!
shutdownModule
	self export: true.
	^self b3dxShutdown! !


!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:54'!
primitiveBltFromDisplay
	| result extent srcOrigin dstOrigin extentX extentY sourceX sourceY destX destY formHandle displayHandle |
	self export: true.
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	extent _ interpreterProxy stackObjectValue: 0.
	srcOrigin _ interpreterProxy stackObjectValue: 1.
	dstOrigin _ interpreterProxy stackObjectValue: 2.
	formHandle _ interpreterProxy stackIntegerValue: 3.
	displayHandle _ interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isPointers: extent) and:[(interpreterProxy slotSizeOf: extent) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: srcOrigin) and:[(interpreterProxy slotSizeOf: srcOrigin) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: dstOrigin) and:[(interpreterProxy slotSizeOf: dstOrigin) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	extentX _ interpreterProxy fetchInteger: 0 ofObject: extent.
	extentY _ interpreterProxy fetchInteger: 1 ofObject: extent.
	sourceX _ interpreterProxy fetchInteger: 0 ofObject: srcOrigin.
	sourceY _ interpreterProxy fetchInteger: 1 ofObject: srcOrigin.
	destX _ interpreterProxy fetchInteger: 0 ofObject: dstOrigin.
	destY _ interpreterProxy fetchInteger: 1 ofObject: dstOrigin.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxBltFromDisplay(displayHandle, formHandle, destX, destY, sourceX, sourceY, extentX, extentY)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 5. "pop args; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:55'!
primitiveBltToDisplay
	| result extent srcOrigin dstOrigin extentX extentY sourceX sourceY destX destY formHandle displayHandle |
	self export: true.
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	extent _ interpreterProxy stackObjectValue: 0.
	srcOrigin _ interpreterProxy stackObjectValue: 1.
	dstOrigin _ interpreterProxy stackObjectValue: 2.
	formHandle _ interpreterProxy stackIntegerValue: 3.
	displayHandle _ interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isPointers: extent) and:[(interpreterProxy slotSizeOf: extent) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: srcOrigin) and:[(interpreterProxy slotSizeOf: srcOrigin) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: dstOrigin) and:[(interpreterProxy slotSizeOf: dstOrigin) = 2])
		ifFalse:[^interpreterProxy primitiveFail].
	extentX _ interpreterProxy fetchInteger: 0 ofObject: extent.
	extentY _ interpreterProxy fetchInteger: 1 ofObject: extent.
	sourceX _ interpreterProxy fetchInteger: 0 ofObject: srcOrigin.
	sourceY _ interpreterProxy fetchInteger: 1 ofObject: srcOrigin.
	destX _ interpreterProxy fetchInteger: 0 ofObject: dstOrigin.
	destY _ interpreterProxy fetchInteger: 1 ofObject: dstOrigin.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxBltToDisplay(displayHandle, formHandle, destX, destY, sourceX, sourceY, extentX, extentY)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 5. "pop args; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:15'!
primitiveCreateDisplaySurface
	| h w d result |
	self export: true.
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	h _ interpreterProxy stackIntegerValue: 0.
	w _ interpreterProxy stackIntegerValue: 1.
	d _ interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxCreateDisplaySurface(w, h, d)' inSmalltalk:[-1].
	result = -1 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "args+rcvr"
	interpreterProxy pushInteger: result.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:16'!
primitiveDestroyDisplaySurface
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxDestroyDisplaySurface(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1. "pop arg; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 21:36'!
primitiveDisplayGetColorMasks
	| handle result masks array |
	self export: true.
	self var: #masks declareC:'int masks[4]'.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	array _ interpreterProxy stackObjectValue: 0.
	handle _ interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: array) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	result _ self cCode:'b3dxDisplayColorMasks(handle, masks)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	0 to: 3 do:[:i|
		interpreterProxy storePointer: i ofObject: array withValue:
			(interpreterProxy positive32BitIntegerFor: (masks at: i))].
	interpreterProxy pop: 2. "pop args return receiver"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:16'!
primitiveFillDisplaySurface
	| h w result y x pv handle |
	self export: true.
	interpreterProxy methodArgumentCount = 6
		ifFalse:[^interpreterProxy primitiveFail].
	h _ interpreterProxy stackIntegerValue: 0.
	w _ interpreterProxy stackIntegerValue: 1.
	y _ interpreterProxy stackIntegerValue: 2.
	x _ interpreterProxy stackIntegerValue: 3.
	pv _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 4).
	handle _ interpreterProxy stackIntegerValue: 5.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxFillDisplaySurface(handle, pv, x, y, w, h)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 6. "pop args; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:17'!
primitiveFinishDisplaySurface
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxFinishDisplaySurface(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1. "pop arg; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:17'!
primitiveFlushDisplaySurface
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxFlushDisplaySurface(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1. "pop arg; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 21:37'!
primitiveSupportsDisplayDepth
	| result depth |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	depth _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self b3dxSupportsDisplayDepth: depth.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: result.! !


!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/28/2000 01:17'!
primitiveAllocateTexture
	| h w d result |
	self export: true.
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	h _ interpreterProxy stackIntegerValue: 0.
	w _ interpreterProxy stackIntegerValue: 1.
	d _ interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxAllocateTexture(w, h, d)' inSmalltalk:[-1].
	result = -1 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "args+rcvr"
	interpreterProxy pushInteger: result.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/28/2000 01:18'!
primitiveDestroyTexture
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxDestroyTexture(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1. "pop arg; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 21:37'!
primitiveTextureDepth
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxActualTextureDepth(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2.
	interpreterProxy pushInteger: result.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 21:37'!
primitiveTextureGetColorMasks
	| handle result masks array |
	self export: true.
	self var: #masks declareC:'int masks[4]'.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	array _ interpreterProxy stackObjectValue: 0.
	handle _ interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: array) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	result _ self cCode:'b3dxTextureColorMasks(handle, masks)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	0 to: 3 do:[:i|
		interpreterProxy storePointer: i ofObject: array withValue:
			(interpreterProxy positive32BitIntegerFor: (masks at: i))].
	interpreterProxy pop: 2. "pop args return receiver"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/28/2000 01:18'!
primitiveTextureHeight
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxActualTextureHeight(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2.
	interpreterProxy pushInteger: result.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-textures' stamp: 'ar 5/28/2000 01:19'!
primitiveTextureWidth
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxActualTextureWidth(handle)' inSmalltalk:[-1].
	result < 0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2.
	interpreterProxy pushInteger: result.! !


!B3DAcceleratorPlugin methodsFor: 'primitives-forms' stamp: 'ar 5/28/2000 01:19'!
primitiveAllocateForm
	| h w d result |
	self export: true.
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	h _ interpreterProxy stackIntegerValue: 0.
	w _ interpreterProxy stackIntegerValue: 1.
	d _ interpreterProxy stackIntegerValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxAllocateForm(w, h, d)' inSmalltalk:[-1].
	result = -1 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "args+rcvr"
	interpreterProxy pushInteger: result.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-forms' stamp: 'ar 5/28/2000 01:19'!
primitiveDestroyForm
	| handle result |
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	handle _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxDestroyForm(handle)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1. "pop arg; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 21:38'!
primitiveFormGetColorMasks
	| handle result masks array |
	self export: true.
	self var: #masks declareC:'int masks[4]'.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	array _ interpreterProxy stackObjectValue: 0.
	handle _ interpreterProxy stackIntegerValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: array) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	result _ self cCode:'b3dxFormColorMasks(handle, masks)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	0 to: 3 do:[:i|
		interpreterProxy storePointer: i ofObject: array withValue:
			(interpreterProxy positive32BitIntegerFor: (masks at: i))].
	interpreterProxy pop: 2. "pop args return receiver"! !


!B3DAcceleratorPlugin methodsFor: 'primitives-rasterizer' stamp: 'ar 5/28/2000 01:19'!
primitiveClearDepthBuffer
	| result |
	self export: true.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	result _ self cCode:'b3dxClearDepthBuffer()'.
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "pop args; return rcvr"! !

!B3DAcceleratorPlugin methodsFor: 'primitives-rasterizer' stamp: 'ar 6/29/2000 06:55'!
primitiveProcessVertexBuffer
	| idxCount vtxCount vtxArray idxArray texHandle primType result box array |
	self export: true.
	self var: #idxArray type: 'int *'.
	self var: #vtxArray type: 'float *'.
	self var: #box declareC:'int box[4] = { 0, 0, 0, 0 }'.
	interpreterProxy methodArgumentCount = 6
		ifFalse:[^interpreterProxy primitiveFail].
	idxCount _ interpreterProxy stackIntegerValue: 0.
	vtxCount _ interpreterProxy stackIntegerValue: 2.
	texHandle _ interpreterProxy stackIntegerValue: 4.
	primType _ interpreterProxy stackIntegerValue: 5.
	interpreterProxy failed ifTrue:[^nil].
	vtxArray _ self stackPrimitiveVertexArray: 3 ofSize: vtxCount.
	idxArray _ self stackPrimitiveIndexArray: 1 ofSize: idxCount validate: true forVertexSize: vtxCount.
	(vtxArray == nil or:[idxArray == nil 
		or:[primType < 1 or:[primType > PrimTypeMax 
			or:[interpreterProxy failed]]]])
				ifTrue:[^interpreterProxy primitiveFail].

	result _ self cCode:'b3dxRasterizeVertexBuffer(primType, texHandle, vtxArray, vtxCount, idxArray, idxCount, box)' inSmalltalk:[false].
	result ifFalse:[^interpreterProxy primitiveFail].
	array _ interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 4.
	interpreterProxy storeInteger: 0 ofObject: array withValue: (box at: 0).
	interpreterProxy storeInteger: 1 ofObject: array withValue: (box at: 1).
	interpreterProxy storeInteger: 2 ofObject: array withValue: (box at: 2).
	interpreterProxy storeInteger: 3 ofObject: array withValue: (box at: 3).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 7. "pop args + rcvr"
	interpreterProxy push: array.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-rasterizer' stamp: 'ar 5/26/2000 17:24'!
primitiveRasterizerVersion
	self export: true.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: 1.! !

!B3DAcceleratorPlugin methodsFor: 'primitives-rasterizer' stamp: 'ar 5/28/2000 01:20'!
primitiveSetViewport
	| h w y x result |
	self export: true.
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	h _ interpreterProxy stackIntegerValue: 0.
	w _ interpreterProxy stackIntegerValue: 1.
	y _ interpreterProxy stackIntegerValue: 2.
	x _ interpreterProxy stackIntegerValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	result _ self cCode:'b3dxSetViewport(x, y, w, h)'.
	result ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 4. "pop args; return rcvr"! !


!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar 5/26/2000 12:37'!
stackPrimitiveIndexArray: stackIndex ofSize: nItems validate: aBool forVertexSize: maxIndex
	"Load a primitive index array from the interpreter stack.
	If aBool is true then check that all the indexes are in the range (1,maxIndex).
	Return a pointer to the index data if successful, nil otherwise."
	| oop oopSize idxPtr index |
	self inline: false.
	self returnTypeC:'void*'.
	self var: #idxPtr declareC:'int *idxPtr'.

	oop _ interpreterProxy stackObjectValue: stackIndex.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifFalse:[^nil].
 	oopSize _ interpreterProxy slotSizeOf: oop.
	oopSize < nItems ifTrue:[^nil].
	idxPtr _ self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int *'.
	aBool ifTrue:[
		0 to: nItems-1 do:[:i|
			index _ idxPtr at: i.
			(index < 0 or:[index > maxIndex]) ifTrue:[^nil]]].
	^idxPtr! !

!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar 5/26/2000 12:38'!
stackPrimitiveVertex: index
	"Load a primitive vertex from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop |
	self inline: false.
	self returnTypeC:'void*'.
	oop _ interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = PrimVertexSize])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !

!B3DAcceleratorPlugin methodsFor: 'primitive support' stamp: 'ar 5/26/2000 12:38'!
stackPrimitiveVertexArray: index ofSize: nItems
	"Load a primitive vertex array from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop oopSize |
	self inline: false.
	self returnTypeC:'void*'.
	oop _ interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifTrue:[
 		oopSize _ interpreterProxy slotSizeOf: oop.
		(oopSize >= nItems * PrimVertexSize and:[oopSize \\ PrimVertexSize = 0])
			ifTrue:[^interpreterProxy firstIndexableField: oop]].
	^nil! !

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

B3DAcceleratorPlugin class
	instanceVariableNames: ''!

!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'ar 6/29/2000 06:53'!
headerFile
^'/* Header file for 3D accelerator plugin */

/* module initialization support */
int b3dxInitialize(void); /* return true on success, false on error */
int b3dxShutdown(void); /* return true on success, false on error */

/* Display support primitives */
int b3dxCreateDisplaySurface(int w, int h, int d); /* return handle or -1 on error */
int b3dxDestroyDisplaySurface(int handle); /* return true on success, false on error */
int b3dxDisplayColorMasks(int handle, int masks[4]); /* return true on success, false on error */
int b3dxSupportsDisplayDepth(int depth); /* return true or false */
int b3dxFlushDisplaySurface(int handle); /* return true on success, false on error */
int b3dxFinishDisplaySurface(int handle); /* return true on success, false on error */

/* optional accelerated blt primitives */
int b3dxFillDisplaySurface(int handle, int pv, int x, int y, int w, int h); /* return true on success, false on error */
int b3dxBltToDisplay(int displayHandle, int formHandle, int dstX, int dstY, int srcX, int srcY, int w, int h); /* return true on success, false on error */
int b3dxBltFromDisplay(int displayHandle, int formHandle, int dstX, int dstY, int srcX, int srcY, int w, int h); /* return true on success, false on error */

/* Texture support primitives */
int b3dxAllocateTexture(int w, int h, int d); /* return handle or -1 on error */
int b3dxDestroyTexture(int handle); /* return true on success, false on error */
int b3dxActualTextureDepth(int handle); /* return depth or <0 on error */
int b3dxActualTextureWidth(int handle); /* return width or <0 on error */
int b3dxActualTextureHeight(int handle); /* return height or <0 on error */
int b3dxTextureColorMasks(int handle, int masks[4]);  /* return true on success, false on error */

/* Form support primitives */
int b3dxAllocateForm(int w, int h, int d); /* return handle or -1 on error */
int b3dxDestroyForm(int handle); /* return true on success, false on error */
int b3dxFormColorMasks(int handle, int masks[4]);  /* return true on success, false on error */

/* Rasterizer support primitives */
int b3dxSetViewport(int x, int y, int w, int h); /* return true on success, false on error */
int b3dxClearDepthBuffer(void); /* return true on success, false on error */
int b3dxRasterizeVertexBuffer(int primType, int texHandle, float *vtxArray, int vtxSize, int *idxArray, int idxSize, int *bounds); /* return true on success, false on error */

'.! !

!B3DAcceleratorPlugin class methodsFor: 'translation' stamp: 'ar 5/26/2000 17:25'!
moduleName
	^'Squeak3DX'! !
Object subclass: #B3DActiveEdgeTable
	instanceVariableNames: 'start stop array '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DActiveEdgeTable methodsFor: 'initialize' stamp: 'ar 4/4/1999 20:55'!
initialize
	array _ Array new: 100.
	start _ 0.
	stop _ 0.! !


!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/6/1999 02:21'!
at: index
	^array at: index! !

!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:48'!
first
	^array at: 1! !

!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/6/1999 23:20'!
indexOf: anEdge
	1 to: stop do:[:i| (array at: i) = anEdge ifTrue:[^i]].
	^0! !

!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:48'!
last
	^array at: stop! !

!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/3/1999 05:28'!
size
	^stop! !

!B3DActiveEdgeTable methodsFor: 'accessing' stamp: 'ar 4/6/1999 03:51'!
xValues
	^(array copyFrom: 1 to: stop) collect:[:e| e xValue]! !


!B3DActiveEdgeTable methodsFor: 'streaming' stamp: 'ar 4/3/1999 05:28'!
atEnd
	^start >= stop! !

!B3DActiveEdgeTable methodsFor: 'streaming' stamp: 'ar 4/3/1999 05:28'!
next
	"Return the next entry from the AET and advance start"
	^array at: (start _ start + 1)! !

!B3DActiveEdgeTable methodsFor: 'streaming' stamp: 'ar 4/5/1999 23:24'!
peek
	"Peek the next entry from the AET"
	^array at: (start + 1)! !

!B3DActiveEdgeTable methodsFor: 'streaming' stamp: 'ar 4/3/1999 05:28'!
reset
	start _ 0.! !


!B3DActiveEdgeTable methodsFor: 'merging' stamp: 'ar 4/4/1999 21:52'!
mergeEdgesFrom: inputList
	"Merge all the edges from the given input list in the AET"
	| srcIndex dstIndex outIndex srcEdge dstEdge |
	srcIndex _ inputList size.
	srcIndex = 0 ifTrue:[^self].
	dstIndex _ stop.
	"Make room for adding the stuff"
	[stop + srcIndex > array size] whileTrue:[self grow].
	"Adjust size"
	stop _ stop + srcIndex.
	"If the receiver is empty, simply copy the stuff"
	dstIndex = 0 ifTrue:[
		1 to: srcIndex do:[:i| array at: i put: (inputList at: i)].
		^self].
	"Merge inputList by walking backwards through the AET and checking each edge."
	outIndex _ dstIndex+srcIndex.
	srcEdge _ inputList at: srcIndex.
	dstEdge _ array at: dstIndex.
	[true] whileTrue:[
		srcEdge xValue >= dstEdge xValue ifTrue:[
			"Insert srcEdge"
			array at: outIndex put: srcEdge.
			srcIndex _ srcIndex - 1.
			srcIndex = 0 ifTrue:[^self].
			srcEdge _ inputList at: srcIndex.
		] ifFalse:[
			"Insert dstEdge"
			array at: outIndex put: dstEdge.
			dstIndex _ dstIndex - 1.
			dstIndex = 0 ifTrue:[
				1 to: srcIndex do:[:i| array at: i put: (inputList at: i)].
				^self].
			dstEdge _ array at: dstIndex.
		].
		outIndex _ outIndex-1.
	].! !


!B3DActiveEdgeTable methodsFor: 'removing' stamp: 'ar 4/5/1999 03:15'!
removeFirst
	stop _ stop - 1.
	array replaceFrom: start to: stop with: array startingAt: start+1.
	start _ start - 1.
	array at: stop+1 put: nil.! !


!B3DActiveEdgeTable methodsFor: 'sorting' stamp: 'ar 4/3/1999 05:27'!
resortFirst
	"Resort the first entry in the active edge table"
	| edge xValue leftEdge newIndex |
	start = 1 ifTrue:[^self]. "Nothing to do"
	"Fetch the edge to test."
	edge _ array at: start.
	xValue _ edge xValue.
	"Fetch the next edge left to it."
	leftEdge _ array at: start-1.
	leftEdge xValue <= xValue ifTrue:[^self]. "Okay."
	"Move the edge left to its correct insertion point."
	newIndex _ start.
	[newIndex > 1 and:[(leftEdge _ array at: newIndex-1) xValue > xValue]]
		whileTrue:[	array at: newIndex put: leftEdge.
					newIndex _ newIndex - 1].
	array at: newIndex put: edge.! !


!B3DActiveEdgeTable methodsFor: 'testing' stamp: 'ar 4/4/1999 21:21'!
isEmpty
	^stop = 0! !


!B3DActiveEdgeTable methodsFor: 'enumerating' stamp: 'ar 4/5/1999 02:19'!
do: aBlock
	1 to: stop do:[:i| aBlock value: (array at: i)].! !


!B3DActiveEdgeTable methodsFor: 'private' stamp: 'ar 4/5/1999 02:19'!
asArray
	^array copyFrom: 1 to: stop! !

!B3DActiveEdgeTable methodsFor: 'private' stamp: 'ar 4/3/1999 05:25'!
grow
	| newArray |
	newArray _ array species new: array size + 100. "Grow linearly"
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray.! !

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

B3DActiveEdgeTable class
	instanceVariableNames: ''!

!B3DActiveEdgeTable class methodsFor: 'instance creation' stamp: 'ar 4/4/1999 04:27'!
new
	^super new initialize! !
B3DLightSource subclass: #B3DAmbientLight
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DAmbientLight methodsFor: 'shading' stamp: 'ar 2/7/1999 17:16'!
computeAttenuationFor: distance
	^1.0! !

!B3DAmbientLight methodsFor: 'shading' stamp: 'ar 2/7/1999 16:56'!
computeDirectionTo: aB3DPrimitiveVertex
	^B3DVector3 zero! !

!B3DAmbientLight methodsFor: 'shading' stamp: 'ar 2/8/1999 00:33'!
shadeVertexBuffer: vb with: aMaterial into: colorArray
	"Overridden for simplicity and speed"
	| color |
	false ifTrue:[^super shadeVertexBuffer: vb with: aMaterial into: colorArray].
	self flag: #b3dPrimitive.
	vb trackAmbientColor ifTrue:[
		1 to: vb vertexCount do:[:i|
			color _ (vb primitiveB3dColorAt: i) * lightColor ambientPart.
			colorArray add: color at: i.
		].
	] ifFalse:[
		color _ aMaterial ambientPart * lightColor ambientPart.
		colorArray += color.
	].! !


!B3DAmbientLight methodsFor: 'testing' stamp: 'ar 2/8/1999 00:33'!
hasDiffusePart
	^false! !

!B3DAmbientLight methodsFor: 'testing' stamp: 'ar 2/8/1999 00:33'!
hasSpecularPart
	^false! !


!B3DAmbientLight methodsFor: 'converting' stamp: 'ar 2/15/1999 21:52'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight |
	primLight _ B3DPrimitiveLight new.
	primLight ambientPart: lightColor ambientPart.
	primLight flags: FlagAmbientPart.
	^primLight! !

!B3DAmbientLight methodsFor: 'converting' stamp: 'ar 2/8/1999 01:29'!
transformedBy: aTransformer
	^self! !
B3DGeometry subclass: #B3DBox
	instanceVariableNames: 'vertices '
	classVariableNames: 'BoxColors BoxFaceIndexes BoxNormals '
	poolDictionaries: ''
	category: 'Balloon3D-Objects'!

!B3DBox methodsFor: 'displaying' stamp: 'ar 2/16/1999 17:25'!
renderOn: aRenderer
	"Note: The use of BoxColors is an example for pre-lighting."
	1 to: 6 do:[:i|
		"Enable simple additive computation of box colors.
		Note: This must be turned on on per-primitive basis."
		aRenderer
			trackEmissionColor: true;		"Turn on pre-lit colors"
			normal: (BoxNormals at: i);
			color: (BoxColors at: i);		"Set pre-lit color per polygon"
			drawPolygonAfter:[
				aRenderer
					texCoords: (vertices at: ((BoxFaceIndexes at: i) at: 1));
					vertex: (vertices at: ((BoxFaceIndexes at: i) at: 1));
					texCoords: (vertices at: ((BoxFaceIndexes at: i) at: 2));
					vertex: (vertices at: ((BoxFaceIndexes at: i) at: 2));
					texCoords: (vertices at: ((BoxFaceIndexes at: i) at: 3));
					vertex: (vertices at: ((BoxFaceIndexes at: i) at: 3));
					texCoords: (vertices at: ((BoxFaceIndexes at: i) at: 4));
					vertex: (vertices at: ((BoxFaceIndexes at: i) at: 4)).
			].
	].! !


!B3DBox methodsFor: 'private'!
buildBoxFrom: origin to: corner
	vertices := Array new: 8.
	1 to: 8 do:[:i| vertices at: i put: B3DVector3 new].

	(vertices at: 1) x: origin x.	(vertices at: 1) y: origin y.	(vertices at: 1) z: origin z.
	(vertices at: 2) x: origin x.	(vertices at: 2) y: origin y.	(vertices at: 2) z: corner z.
	(vertices at: 3) x: origin x.	(vertices at: 3) y: corner y.	(vertices at: 3) z: corner z.
	(vertices at: 4) x: origin x.	(vertices at: 4) y: corner y.	(vertices at: 4) z: origin z.
	(vertices at: 5) x: corner x.	(vertices at: 5) y: origin y.	(vertices at: 5) z: origin z.
	(vertices at: 6) x: corner x.	(vertices at: 6) y: origin y.	(vertices at: 6) z: corner z.
	(vertices at: 7) x: corner x.	(vertices at: 7) y: corner y.	(vertices at: 7) z: corner z.
	(vertices at: 8) x: corner x.	(vertices at: 8) y: corner y.	(vertices at: 8) z: origin z.
! !


!B3DBox methodsFor: 'accessing' stamp: 'ar 3/12/2000 21:11'!
boundingBox
	^Rectangle origin: vertices first corner: (vertices at: 7)! !

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

B3DBox class
	instanceVariableNames: ''!

!B3DBox class methodsFor: 'class initialization' stamp: 'ar 2/4/1999 20:20'!
initialize
	"B3DBox initialize"
	| nrmls |
	nrmls := #(	(-1.0 0.0 0.0) (0.0 1.0 0.0) (1.0 0.0 0.0)
				(0.0 -1.0 0.0) (0.0 0.0 1.0) (0.0 0.0 -1.0)) 
			collect:[:spec| B3DVector3 x: spec first y: spec second z: spec third].
	BoxNormals := nrmls.
	"BoxNormals := Array new: 6.
	1 to: 6 do:[:i|
		BoxNormals at: i put: (FloatVector3 new).
		1 to: 3 do:[:j| (BoxNormals at: i) at: j put: ((nrmls at: i) at: j)]]."
	BoxFaceIndexes := #(	(1 2 3 4) (4 3 7 8) (8 7 6 5)
						(5 6 2 1) (6 7 3 2) (8 5 1 4)).
	BoxColors _ #(red green blue yellow gray cyan) collect:[:s| (Color perform: s) alpha: 0.5].! !


!B3DBox class methodsFor: 'instance creation'!
from: origin to: corner
	^self new buildBoxFrom: origin to: corner! !

Object subclass: #B3DCamera
	instanceVariableNames: 'position target up perspective '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!
!B3DCamera commentStamp: '<historical>' prior: 0!
I represent a simple perspective camera.

Instance variables:
	position		<B3DVector3>		where the camera is located
	target 		<B3DVector3>		where the camera is aiming at
	up 			<B3DVector3>		what is considered to be 'up' on screen
	perspective	<B3DCameraPerspective>	the actual camera perspective!


!B3DCamera methodsFor: 'accessing'!
aspectRatio
	^perspective aspectRatio! !

!B3DCamera methodsFor: 'accessing'!
aspectRatio: aFloat
	^perspective aspectRatio: aFloat! !

!B3DCamera methodsFor: 'accessing' stamp: 'ar 2/8/1999 16:48'!
direction
	^target - position! !

!B3DCamera methodsFor: 'accessing' stamp: 'ar 2/8/1999 16:48'!
direction: aVector
	target _ position + aVector.! !

!B3DCamera methodsFor: 'accessing'!
farDistance
	^perspective farDistance! !

!B3DCamera methodsFor: 'accessing'!
farDistance: aFloat
	^perspective farDistance: aFloat! !

!B3DCamera methodsFor: 'accessing'!
fieldOfView
	^perspective fieldOfView! !

!B3DCamera methodsFor: 'accessing'!
fieldOfView: aFloat
	^perspective fieldOfView: aFloat! !

!B3DCamera methodsFor: 'accessing'!
fov
	^self fieldOfView! !

!B3DCamera methodsFor: 'accessing'!
fov: aNumber
	self fieldOfView: aNumber! !

!B3DCamera methodsFor: 'accessing'!
nearDistance
	^perspective nearDistance! !

!B3DCamera methodsFor: 'accessing'!
nearDistance: aFloat
	^perspective nearDistance: aFloat! !

!B3DCamera methodsFor: 'accessing'!
perspective
	^perspective! !

!B3DCamera methodsFor: 'accessing'!
perspective: aPerspective
	perspective _ aPerspective! !

!B3DCamera methodsFor: 'accessing'!
position
	^position! !

!B3DCamera methodsFor: 'accessing'!
position: aVector
	position _ aVector! !

!B3DCamera methodsFor: 'accessing'!
target
	^target! !

!B3DCamera methodsFor: 'accessing'!
target: aVector
	target _ aVector! !

!B3DCamera methodsFor: 'accessing'!
up
	^up! !

!B3DCamera methodsFor: 'accessing'!
up: aVector
	up _ aVector! !


!B3DCamera methodsFor: 'initialize' stamp: 'ar 3/19/2000 14:12'!
from3DS: aDictionary
	"Initialize the receiver from a 3DS camera.
	Note: #near and #far are NOT clipping planes in 3DS!!"
	self position: (aDictionary at: #position).
	self target: (aDictionary at: #target).
	self up: (0@1@0).
	self flag: #TODO. "Include #roll value for upDirection"
	self fieldOfView: 2400.0 / (aDictionary at: #focal).! !

!B3DCamera methodsFor: 'initialize'!
from: positionVector to: targetVector up: upVector

	position := positionVector.
	target := targetVector.
	up := upVector.! !

!B3DCamera methodsFor: 'initialize' stamp: 'ar 2/5/1999 21:22'!
initialize
	position := B3DVector3 x: 0.0 y: 0.0 z: 1.0.
	target := B3DVector3 x: 0.0 y: 0.0 z: 0.0.
	up := B3DVector3 x: 0.0 y: 1.0 z: 0.0.
	perspective := B3DCameraPerspective new.
	self fov: 45.0.
	self aspectRatio: 1.0.
	self nearDistance: 0.0001.
	self farDistance: 10000.0.! !

!B3DCamera methodsFor: 'initialize' stamp: 'ti 3/27/2000 17:03'!
setClippingPlanesFrom: anObject
	"Set the clipping planes from the given object"
	| box center radius avgDist |
	box _ anObject boundingBox.
	center _ (box origin + box corner) * 0.5.
	radius _ (center - box origin) length.
	avgDist _ (position - center) length.
	self farDistance: avgDist + radius.
	avgDist > radius 
		ifTrue:[self nearDistance:
			((((center - position) normalized
				dot: (self direction normalized))
					* avgDist - radius) max: 1.0e-31)]
		ifFalse:[self nearDistance: (self farDistance * 0.00001)].! !

!B3DCamera methodsFor: 'initialize' stamp: 'ar 2/15/1999 01:04'!
setTargetFrom: anObject
	"Make the camera point at the given object"
	| box |
	box _ anObject boundingBox.
	self target: (box origin + box corner) * 0.5.! !


!B3DCamera methodsFor: 'rendering'!
renderOn: aRenderer
	aRenderer
		lookFrom: self position
		to: self target
		up: self up.
	aRenderer
		perspective: self perspective.! !


!B3DCamera methodsFor: 'experimental' stamp: 'ar 2/17/1999 05:41'!
changeDistanceBy: delta
	position _ target + (position - target * delta)! !

!B3DCamera methodsFor: 'experimental' stamp: 'ar 2/17/1999 16:05'!
moveToFit: aScene
	"Move the camera to fit the given scene. Experimental."
	| distance center |
	self setTargetFrom: aScene.
	center _ (aScene boundingBox origin + aScene boundingBox corner) * 0.5.
	distance _ (aScene boundingBox origin - center) length * 1.3.
	distance _ distance / (target - position) length.
	"self inform:'Distance ', distance printString."
	self changeDistanceBy: distance.! !

!B3DCamera methodsFor: 'experimental' stamp: 'ar 2/15/1999 23:47'!
rotateBy: angle
	"Experimental -- rotate around the current up vector by angle degrees.
	Center at the target point."
	position _ (B3DMatrix4x4 rotatedBy: angle around: up centeredAt: target) localPointToGlobal: position.! !


!B3DCamera methodsFor: 'converting' stamp: 'ti 3/22/2000 10:46'!
asMatrix4x4
	| xDir yDir zDir m |
	"calculate z vector"
	zDir _ self target - self position.
	zDir safelyNormalize.
	"calculate x vector"
	xDir _ self up cross: zDir.
	xDir safelyNormalize.
	"recalc y vector"
	yDir _ zDir cross: xDir.
	yDir safelyNormalize.
	m := B3DMatrix4x4 new.
	m	a11: xDir x;		a12: xDir y;		a13: xDir z;		a14: 0.0;
		a21: yDir x;		a22: yDir y;		a23: yDir z;		a24: 0.0;
		a31: zDir x;		a32: zDir y;		a33: zDir z;		a34: 0.0;
		a41: 0.0;			a42: 0.0;		a43: 0.0;		a44: 1.0.
	m := m composeWith: (B3DMatrix4x4 identity setTranslation: self position negated).
	^m! !

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

B3DCamera class
	instanceVariableNames: ''!

!B3DCamera class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 23:37'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !

!B3DCamera class methodsFor: 'instance creation'!
new
	^super new initialize! !
Object subclass: #B3DCameraPerspective
	instanceVariableNames: 'nearDistance farDistance fieldOfView aspectRatio '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!
!B3DCameraPerspective commentStamp: '<historical>' prior: 0!
I represent a perspective projection.

Instance variables:
	nearDistance 	<Float>	Near clipping plane distance
	farDistance 		<Float>	Far clipping plane distance
	fieldOfView 	<Float>	The field of view covered by the perspective
	aspectRatio		<Float> 	The aspect ratio to be included !


!B3DCameraPerspective methodsFor: 'converting'!
asFrustum
	^B3DViewingFrustum near: nearDistance far: farDistance fov: fieldOfView aspect: aspectRatio! !

!B3DCameraPerspective methodsFor: 'converting'!
asMatrix4x4
	^self asFrustum asPerspectiveMatrix! !


!B3DCameraPerspective methodsFor: 'accessing'!
aspectRatio
	^aspectRatio! !

!B3DCameraPerspective methodsFor: 'accessing'!
aspectRatio: aNumber
	aspectRatio _ aNumber! !

!B3DCameraPerspective methodsFor: 'accessing'!
farDistance
	^farDistance! !

!B3DCameraPerspective methodsFor: 'accessing'!
farDistance: aNumber
	farDistance _ aNumber! !

!B3DCameraPerspective methodsFor: 'accessing'!
fieldOfView
	^fieldOfView! !

!B3DCameraPerspective methodsFor: 'accessing'!
fieldOfView: aNumber
	fieldOfView _ aNumber! !

!B3DCameraPerspective methodsFor: 'accessing'!
nearDistance
	^nearDistance! !

!B3DCameraPerspective methodsFor: 'accessing'!
nearDistance: aNumber
	nearDistance _ aNumber! !
B3DEnginePlugin subclass: #B3DClipperPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DClipperPlugin methodsFor: 'primitives' stamp: 'ar 11/20/2000 22:47'!
b3dClipPolygon
	"Primitive. Clip the polygon given in the vertexArray using the temporary vertex array which is assumed to have sufficient size."
	| outMask vtxCount vtxArray tempVtxArray count |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'int *vtxArray'.
	self var: #tempVtxArray declareC:'int *tempVtxArray'.
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	outMask _ interpreterProxy stackIntegerValue: 0.
	vtxCount _ interpreterProxy stackIntegerValue: 2.
	vtxArray _ self stackPrimitiveVertexArray: 3 ofSize: vtxCount + 4.
	tempVtxArray _ self stackPrimitiveVertexArray: 1 ofSize: vtxCount + 4.
	(vtxArray == nil or:[tempVtxArray == nil or:[interpreterProxy failed]])
		ifTrue:[^interpreterProxy primitiveFail].
	"Hack pointers for one-based indexes"
	vtxArray _ vtxArray - PrimVertexSize.
	tempVtxArray _ tempVtxArray - PrimVertexSize.
	count _ self clipPolygon: vtxArray count: vtxCount with: tempVtxArray mask: outMask.
	interpreterProxy pop: 5.
	interpreterProxy pushInteger: count.! !

!B3DClipperPlugin methodsFor: 'primitives' stamp: 'ar 4/16/1999 01:54'!
b3dDetermineClipFlags
	"Primitive. Determine the clipping flags for all vertices."
	| vtxCount vtxArray result |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'void *vtxArray'.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	vtxCount _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	vtxArray _ self stackPrimitiveVertexArray: 1 ofSize: vtxCount.
	(vtxArray == nil or:[interpreterProxy failed])
		ifTrue:[^interpreterProxy primitiveFail].
	result _ self determineClipFlags: vtxArray count: vtxCount.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3.
		interpreterProxy pushInteger: result.
	].! !

!B3DClipperPlugin methodsFor: 'primitives' stamp: 'ar 4/18/1999 02:59'!
b3dPrimitiveNextClippedTriangle
	"Primitive. Return the next clipped triangle from the vertex buffer and return its index."
	| idxCount vtxCount firstIndex vtxArray idxArray idx1 idx2 idx3 triMask |
	self export: true.
	self inline: false.
	self var: #idxArray declareC:'int *idxArray'.
	self var: #vtxArray declareC:'int *vtxArray'.
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	idxCount _ interpreterProxy stackIntegerValue: 0.
	vtxCount _ interpreterProxy stackIntegerValue: 2.
	firstIndex _ interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	vtxArray _ self stackPrimitiveVertexArray: 3 ofSize: vtxCount.
	idxArray _ self stackPrimitiveIndexArray: 1 ofSize: idxCount validate: true forVertexSize: vtxCount.
	(vtxArray == nil or:[idxArray == nil or:[interpreterProxy failed]])
		ifTrue:[^interpreterProxy primitiveFail].

	"Hack idxArray and vtxArray for 1-based indexes"
	idxArray _ idxArray - 1.
	vtxArray _ vtxArray - PrimVertexSize.
	firstIndex to: idxCount by: 3 do:[:i|
		idx1 _ idxArray at: i.
		idx2 _ idxArray at: i+1.
		idx3 _ idxArray at: i+2.
		(idx1 == 0 or:[idx2 == 0 or:[idx3 == 0]]) ifFalse:[
			triMask _ ((vtxArray at: idx1 * PrimVertexSize + PrimVtxClipFlags) bitAnd:
						((vtxArray at: idx2 * PrimVertexSize + PrimVtxClipFlags) bitAnd:
						(vtxArray at: idx3 * PrimVertexSize + PrimVtxClipFlags))).
			"Check if tri is completely inside"
			(InAllMask bitAnd: triMask) = InAllMask ifFalse:[
				"Tri is not completely inside -> needs clipping."
				(triMask anyMask: OutAllMask) ifTrue:[
					"tri is completely outside. Store all zeros"
					idxArray at: i put: 0.
					idxArray at: i+1 put: 0.
					idxArray at: i+2 put: 0.
				] ifFalse:[
					"tri must be partially clipped."
					interpreterProxy pop: 6. "args + rcvr"
					interpreterProxy pushInteger: i.
					^nil
				].
			].
		].
	].
	"No more entries"
	interpreterProxy pop: 6. "args + rcvr"
	interpreterProxy pushInteger: 0.
! !


!B3DClipperPlugin methodsFor: 'clipping' stamp: 'ar 4/16/1999 06:03'!
clipPolygon: vtxArray count: vtxCount with: tempVtxArray mask: outMask
	| count |
	self var: #vtxArray declareC:'int *vtxArray'.
	self var: #tempVtxArray declareC:'int *tempVtxArray'.
	"Check if the polygon is outside one boundary only.
	If so, just do this single clipping operation avoiding multiple enumeration."
	outMask = OutLeftBit 
		ifTrue:[^self clipPolygonLeftFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutRightBit 
		ifTrue:[^self clipPolygonRightFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutTopBit 
		ifTrue:[^self clipPolygonTopFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutBottomBit 
		ifTrue:[^self clipPolygonBottomFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutFrontBit 
		ifTrue:[^self clipPolygonFrontFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutBackBit 
		ifTrue:[^self clipPolygonBackFrom: tempVtxArray to: vtxArray count: vtxCount].
	"Just do each of the clipping operations"
	count _ vtxCount.
	count _ self clipPolygonLeftFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonRightFrom: tempVtxArray to: vtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonTopFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonBottomFrom: tempVtxArray to: vtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonFrontFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonBackFrom: tempVtxArray to: vtxArray count: count.
	^count! !

!B3DClipperPlugin methodsFor: 'clipping' stamp: 'ar 4/16/1999 01:57'!
determineClipFlags: vtxArray count: count
	| vtxPtr fullMask w w2 flags x y z |
	self var: #vtxPtr declareC:'float *vtxPtr'.
	self var: #vtxArray declareC:'void *vtxArray'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #w declareC:'double w'.
	self var: #w2 declareC:'double w2'.
	vtxPtr _ self cCoerce: vtxArray to: 'float *'.
	fullMask _ InAllMask + OutAllMask.
	1 to: count do:[:i|
		w _ vtxPtr at: PrimVtxRasterPosW.
		w2 _ 0.0 - w.
		flags _ 0.
		x _ vtxPtr at: PrimVtxRasterPosX.
		x >= w2 ifTrue:[flags _ flags bitOr: InLeftBit] ifFalse:[flags _ flags bitOr: OutLeftBit].
		x <= w ifTrue:[flags _ flags bitOr: InRightBit] ifFalse:[flags _ flags bitOr: OutRightBit].
		y _ vtxPtr at: PrimVtxRasterPosY.
		y >= w2 ifTrue:[flags _ flags bitOr: InBottomBit] ifFalse:[flags _ flags bitOr: OutBottomBit].
		y <= w ifTrue:[flags _ flags bitOr: InTopBit] ifFalse:[flags _ flags bitOr: OutTopBit].
		z _ vtxPtr at: PrimVtxRasterPosZ.
		z >= w2 ifTrue:[flags _ flags bitOr: InFrontBit] ifFalse:[flags _ flags bitOr: OutFrontBit].
		z <= w ifTrue:[flags _ flags bitOr: InBackBit] ifFalse:[flags _ flags bitOr: OutBackBit].
		fullMask _ fullMask bitAnd: flags.
		(self cCoerce: vtxPtr to:'int *') at: PrimVtxClipFlags put: flags.
		vtxPtr _ vtxPtr + PrimVertexSize.
	].
	^fullMask! !

!B3DClipperPlugin methodsFor: 'clipping' stamp: 'ar 4/21/1999 01:26'!
interpolateFrom: last to: next at: t into: out
	"Interpolate the primitive vertices last/next at the parameter t"
	| delta rgbaLast lastValue rgbaNext nextValue newValue x y z w w2 flags |
	self var: #last declareC:'float *last'.
	self var: #next declareC:'float *next'.
	self var: #out declareC:'float *out'.
	self var: #t declareC: 'double t'.
	self var: #delta declareC: 'double delta'.
	self var: #rgbaLast declareC:'unsigned int rgbaLast'.
	self var: #rgbaNext declareC:'unsigned int rgbaNext'.
	self var: #lastValue declareC:'unsigned int lastValue'.
	self var: #nextValue declareC:'unsigned int nextValue'.
	self var: #newValue declareC:'unsigned int newValue'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #w declareC:'double w'.
	self var: #w2 declareC:'double w2'.
	"Interpolate raster position"
	delta _ (next at: PrimVtxRasterPosX) - (last at: PrimVtxRasterPosX).
	x _ (last at: PrimVtxRasterPosX) + (delta * t).
	out at: PrimVtxRasterPosX put: (self cCoerce: x to: 'float').
	delta _ (next at: PrimVtxRasterPosY) - (last at: PrimVtxRasterPosY).
	y _ (last at: PrimVtxRasterPosY) + (delta * t).
	out at: PrimVtxRasterPosY put: (self cCoerce: y to: 'float').
	delta _ (next at: PrimVtxRasterPosZ) - (last at: PrimVtxRasterPosZ).
	z _ (last at: PrimVtxRasterPosZ) + (delta * t).
	out at: PrimVtxRasterPosZ put: (self cCoerce: z to: 'float').
	delta _ (next at: PrimVtxRasterPosW) - (last at: PrimVtxRasterPosW).
	w _ (last at: PrimVtxRasterPosW) + (delta * t).
	out at: PrimVtxRasterPosW put: (self cCoerce: w to: 'float').
	"Determine new clipFlags"
	w2 _ 0.0 - w.
	flags _ 0.
	x >= w2 ifTrue:[flags _ flags bitOr: InLeftBit] ifFalse:[flags _ flags bitOr: OutLeftBit].
	x <= w ifTrue:[flags _ flags bitOr: InRightBit] ifFalse:[flags _ flags bitOr: OutRightBit].
	y >= w2 ifTrue:[flags _ flags bitOr: InBottomBit] ifFalse:[flags _ flags bitOr: OutBottomBit].
	y <= w ifTrue:[flags _ flags bitOr: InTopBit] ifFalse:[flags _ flags bitOr: OutTopBit].
	z >= w2 ifTrue:[flags _ flags bitOr: InFrontBit] ifFalse:[flags _ flags bitOr: OutFrontBit].
	z <= w ifTrue:[flags _ flags bitOr: InBackBit] ifFalse:[flags _ flags bitOr: OutBackBit].
	(self cCoerce: out to: 'int *') at: PrimVtxClipFlags put: flags.

	"Interpolate color"
	rgbaLast _ (self cCoerce: last to:'unsigned int *') at: PrimVtxColor32.
	lastValue _ rgbaLast bitAnd: 255. rgbaLast _ rgbaLast >> 8.
	rgbaNext _ (self cCoerce: next to: 'unsigned int *') at: PrimVtxColor32.
	nextValue _ rgbaNext bitAnd: 255. rgbaNext _ rgbaNext >> 8.
	delta _ (self cCoerce: (nextValue - lastValue) to:'int') * t.
	newValue _ (lastValue + delta) asInteger.

	lastValue _ rgbaLast bitAnd: 255. rgbaLast _ rgbaLast >> 8.
	nextValue _ rgbaNext bitAnd: 255. rgbaNext _ rgbaNext >> 8.
	delta _ (self cCoerce: (nextValue - lastValue) to:'int') * t.
	newValue _ newValue + ((lastValue + delta) asInteger << 8).

	lastValue _ rgbaLast bitAnd: 255. rgbaLast _ rgbaLast >> 8.
	nextValue _ rgbaNext bitAnd: 255. rgbaNext _ rgbaNext >> 8.
	delta _ (self cCoerce: (nextValue - lastValue) to:'int') * t.
	newValue _ newValue + ((lastValue + delta) asInteger << 16).

	lastValue _ rgbaLast bitAnd: 255.
	nextValue _ rgbaNext bitAnd: 255.
	delta _ (self cCoerce: (nextValue - lastValue) to:'int') * t.
	newValue _ newValue + ((lastValue + delta) asInteger << 24).

	(self cCoerce: out to:'unsigned int*') at: PrimVtxColor32 put: newValue.

	"Interpolate texture coordinates"
	delta _ (next at: PrimVtxTexCoordU) - (last at: PrimVtxTexCoordU).
	out at: PrimVtxTexCoordU put: (self cCoerce: (last at: PrimVtxTexCoordU) + (delta * t) to:'float').
	delta _ (next at: PrimVtxTexCoordV) - (last at: PrimVtxTexCoordV).
	out at: PrimVtxTexCoordV put: (self cCoerce: (last at: PrimVtxTexCoordV) + (delta * t) to:'float').
! !


!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 01:56'!
backClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(((self cCoerce: last to: 'float *') at: PrimVtxRasterPosZ) - 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW)) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	-
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosZ) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosZ))
	).! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 06:43'!
bottomClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(0.0 - (((self cCoerce: last to: 'float *') at: PrimVtxRasterPosY) + 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW))) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	+
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosY) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosY))
	).! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:18'!
clipPolygonBackFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InBackBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InBackBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self backClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:18'!
clipPolygonBottomFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InBottomBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InBottomBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self bottomClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:18'!
clipPolygonFrontFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InFrontBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InFrontBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self frontClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:18'!
clipPolygonLeftFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InLeftBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InLeftBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self leftClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:18'!
clipPolygonRightFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InRightBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InRightBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self rightClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/17/1999 22:19'!
clipPolygonTopFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext |
	self var: #buf1 declareC:'int *buf1'.
	self var: #buf2 declareC:'int *buf2'.
	self var: #last declareC:'int *last'.
	self var: #next declareC:'int *next'.
	self var: #t declareC: 'double t'.
	outIndex _ 0.
	last _ buf1 + (n * PrimVertexSize).
	next _ buf1 + PrimVertexSize.
	inLast _ (last at: PrimVtxClipFlags) anyMask: InTopBit.
	1 to: n do:[:i|
		inNext _ (next at: PrimVtxClipFlags) anyMask: InTopBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self topClipValueFrom: last to: next.
			outIndex _ outIndex + 1.
			self interpolateFrom: (self cCoerce: last to:'float *')
				to: (self cCoerce: next to:'float *')
				at: t 
				into: (self cCoerce: (buf2 + (outIndex * PrimVertexSize)) to:'float*')].
		inNext ifTrue:[
			outIndex _ outIndex+1.
			0 to: PrimVertexSize-1 do:[:j|
				buf2 at: (outIndex*PrimVertexSize + j) put: (next at: j)].
		].
		last _ next.
		inLast _ inNext.
		next _ next + PrimVertexSize.
	].
	^outIndex! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 06:43'!
frontClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(0.0 - (((self cCoerce: last to: 'float *') at: PrimVtxRasterPosZ) + 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW))) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	+
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosZ) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosZ))
	).! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 06:43'!
leftClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(0.0 - (((self cCoerce: last to: 'float *') at: PrimVtxRasterPosX) + 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW))) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	+
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosX) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosX))
	).! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 01:56'!
rightClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(((self cCoerce: last to: 'float *') at: PrimVtxRasterPosX) - 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW)) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	-
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosX) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosX))
	).! !

!B3DClipperPlugin methodsFor: 'clipping utilities' stamp: 'ar 4/16/1999 01:56'!
topClipValueFrom: last to: next
	self returnTypeC:'double'.
	^(((self cCoerce: last to: 'float *') at: PrimVtxRasterPosY) - 
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosW)) /

	(
	(((self cCoerce: next to:'float *') at: PrimVtxRasterPosW) -
		((self cCoerce: last to: 'float *') at: PrimVtxRasterPosW))
	-
	 (((self cCoerce: next to:'float *') at: PrimVtxRasterPosY) -
		((self cCoerce: last to:'float *') at: PrimVtxRasterPosY))
	).! !
B3DFloatArray variableWordSubclass: #B3DColor4
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DColor4 commentStamp: '<historical>' prior: 0!
I represent an RGBA color value in floating point format. I am used during the lighting and shading computations.!


!B3DColor4 methodsFor: 'accessing'!
alpha
	^self floatAt: 4! !

!B3DColor4 methodsFor: 'accessing'!
alpha: aNumber
	self floatAt: 4 put: aNumber! !

!B3DColor4 methodsFor: 'accessing'!
blue
	^self floatAt: 3! !

!B3DColor4 methodsFor: 'accessing'!
blue: aNumber
	self floatAt: 3 put: aNumber! !

!B3DColor4 methodsFor: 'accessing'!
green
	^self floatAt: 2! !

!B3DColor4 methodsFor: 'accessing'!
green: aNumber
	self floatAt: 2 put: aNumber! !

!B3DColor4 methodsFor: 'accessing'!
red
	^self floatAt: 1! !

!B3DColor4 methodsFor: 'accessing'!
red: aNumber
	self floatAt: 1 put: aNumber! !


!B3DColor4 methodsFor: 'converting' stamp: 'ar 5/4/2000 17:59'!
asB3DColor
	^self! !

!B3DColor4 methodsFor: 'converting'!
asColor
	^Color r: self red g: self green b: self blue alpha: self alpha! !

!B3DColor4 methodsFor: 'converting' stamp: 'ar 2/4/1999 20:21'!
pixelValue32
	^self asColor pixelWordForDepth: 32! !


!B3DColor4 methodsFor: 'private'!
privateLoadFrom: srcObject
	| color |
	color _ srcObject asColor.
	self red: color red.
	self green: color green.
	self blue: color blue.
	self alpha: color alpha.! !


!B3DColor4 methodsFor: 'initialize' stamp: 'ar 2/7/1999 16:21'!
r: rValue g: gValue b: bValue a: aValue
	self red: rValue.
	self green: gValue.
	self blue: bValue.
	self alpha: aValue.! !


!B3DColor4 methodsFor: 'testing' stamp: 'ar 2/15/1999 22:12'!
isZero
	^self alpha isZero! !


!B3DColor4 methodsFor: 'interpolating' stamp: 'jsp 2/8/1999 19:57'!
interpolateTo: end at: amountDone
	"Return the color vector yielded by interpolating from the state of the object to the specified end state at the specified amount done"

	| newColor r g b a |
	r _ self red.
	g _ self green.
	b _ self blue.
	a _ self alpha.

	newColor _ B3DColor4 new.
	newColor red: r + (((end red) - r) * amountDone).
	newColor green: g + (((end green) - g) * amountDone).
	newColor blue: b + (((end blue) - b) * amountDone).
	newColor alpha: a + (((end alpha) - a) * amountDone).

	^ newColor.
! !

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

B3DColor4 class
	instanceVariableNames: ''!

!B3DColor4 class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:22'!
numElements
	^4! !

!B3DColor4 class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 16:21'!
r: rValue g: gValue b: bValue a: aValue
	^self new r: rValue g: gValue b: bValue a: aValue! !

!B3DColor4 class methodsFor: 'instance creation' stamp: 'jsp 2/8/1999 18:46'!
red: r green: g blue: b alpha: a
	"Create an initialize a color vector."

	| newColor |
	newColor _ B3DColor4 new.

	newColor red: r.
	newColor green: g.
	newColor blue: b.
	newColor alpha: a.

	^ newColor.
! !
B3DInplaceArray variableWordSubclass: #B3DColor4Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!
!B3DColor4Array commentStamp: '<historical>' prior: 0!
I am an inplace storage area for B3DColor4 items used during lighting and shading.!


!B3DColor4Array methodsFor: 'special ops' stamp: 'ar 2/4/1999 01:50'!
+= aColor
	"Add the given color to all the elements in the receiver"
	| r g b a |
	r _ aColor red.
	g _ aColor green.
	b _ aColor blue.
	a _ aColor alpha.
	1 to: self basicSize by: 4 do:[:i|
		self floatAt: i put: (self floatAt: i) + r.
		self floatAt: i+1 put: (self floatAt: i+1) + g.
		self floatAt: i+2 put: (self floatAt: i+2) + b.
		self floatAt: i+3 put: (self floatAt: i+3) + a.
	].! !

!B3DColor4Array methodsFor: 'special ops' stamp: 'ar 2/7/1999 16:44'!
add: aB3dColor4 at: index
	| baseIdx |
	baseIdx _ index-1*4.
	self floatAt: baseIdx+1 put: (self floatAt: baseIdx+1) + aB3dColor4 red.
	self floatAt: baseIdx+2 put: (self floatAt: baseIdx+2) + aB3dColor4 green.
	self floatAt: baseIdx+3 put: (self floatAt: baseIdx+3) + aB3dColor4 blue.
	self floatAt: baseIdx+4 put: (self floatAt: baseIdx+4) + aB3dColor4 alpha.
! !

!B3DColor4Array methodsFor: 'special ops'!
clampAllFrom: minValue to: maxValue
	"Clamp all elements in the receiver to be in the range (minValue, maxValue)"
	| value |
	1 to: self basicSize do:[:i|
		value _ self floatAt: i.
		value _ value min: maxValue.
		value _ value max: minValue.
		self floatAt: i put: value.
	].! !

!B3DColor4Array methodsFor: 'special ops'!
fillWith: anInteger
	<primitive: 145>
	self primitiveFailed! !

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

B3DColor4Array class
	instanceVariableNames: ''!

!B3DColor4Array class methodsFor: 'instance creation' stamp: 'ar 2/5/1999 22:50'!
contentsClass
	^B3DColor4! !
B3DLightSource subclass: #B3DDirectionalLight
	instanceVariableNames: 'direction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DDirectionalLight methodsFor: 'shading' stamp: 'ar 2/7/1999 16:54'!
computeAttenuationFor: distance
	"Since a directional light is positioned at virtual infinity, it cannot have any attenuation"
	^1.0! !

!B3DDirectionalLight methodsFor: 'shading' stamp: 'ar 2/7/1999 16:53'!
computeDirectionTo: aB3DPrimitiveVertex
	"A directional light has an explicit direction regardless of the vertex position"
	^direction! !


!B3DDirectionalLight methodsFor: 'converting' stamp: 'ar 2/15/1999 21:55'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight flags |
	primLight _ B3DPrimitiveLight new.
	primLight direction: direction.
	flags _ FlagDirectional.
	lightColor ambientPart isZero ifFalse:[
		primLight ambientPart: lightColor ambientPart.
		flags _ flags bitOr: FlagAmbientPart].
	lightColor diffusePart isZero ifFalse:[
		primLight diffusePart: lightColor diffusePart.
		flags _ flags bitOr: FlagDiffusePart].
	lightColor specularPart isZero ifFalse:[
		primLight specularPart: lightColor specularPart.
		flags _ flags bitOr: FlagSpecularPart].
	primLight flags: flags.
	^primLight! !

!B3DDirectionalLight methodsFor: 'converting' stamp: 'ar 2/8/1999 01:28'!
transformedBy: aTransformer
	^(super transformedBy: aTransformer) direction: (aTransformer transformDirection: direction)! !
ExternalScreen subclass: #B3DDisplayScreen
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Acceleration'!
!B3DDisplayScreen commentStamp: '<historical>' prior: 0!
I represent a hardware accelerated 3D display. Usually, this means some sort of offscreen buffer (so that we can do efficient compositing for the 2D case) but it might be different.

The first implementation uses Direct3D on Windows where compositing is trivially achieved by using DirectDrawSurfaces which can be accessed by either 2D or 3D operations.!


!B3DDisplayScreen methodsFor: 'testing' stamp: 'ar 5/27/2000 17:16'!
isB3DDisplayScreen
	^true! !


!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:47'!
primBltFast: displayHandle from: sourceHandle at: destOrigin from: sourceOrigin extent: extent
	<primitive:'primitiveBltToDisplay' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:47'!
primBltFast: displayHandle to: dstHandle at: destOrigin from: sourceOrigin extent: extent
	"Primitive. Perform a fast blt operation. Return the receiver if successful."
	<primitive:'primitiveBltFromDisplay' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:18'!
primCreateDisplaySurface: d width: w height: h
	"Primitive. Create a new external display surface. Return the handle used to identify the receiver. Fail if the surface cannot be created."
	<primitive:'primitiveCreateDisplaySurface' module: 'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:18'!
primDestroyDisplaySurface: aHandle
	"Primitive. Destroy the display surface associated with the given handle."
	<primitive: 'primitiveDestroyDisplaySurface' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:19'!
primDisplay: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	<primitive: 'primitiveDisplayGetColorMasks' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:19'!
primFill: handle color: pixelWord x: x y: y w: w h: h
	"Primitive. Perform an accelerated fill operation on the receiver."
	<primitive:'primitiveFillDisplaySurface' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:20'!
primFinish: aHandle
	"Primitive. Finish all rendering operations on the receiver.
	Do not return before all rendering operations have taken effect."
	<primitive: 'primitiveFinishDisplaySurface' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:21'!
primFlush: aHandle
	"Primitive. If any rendering operations are pending, force them to be executed.
	Do not wait until they have taken effect."
	<primitive: 'primitiveFlushDisplaySurface' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:21'!
supportsDisplayDepth: pixelDepth
	"Return true if this pixel depth is supported on the current host platform."
	<primitive: 'primitiveSupportsDisplayDepth' module:'Squeak3DX'>
	^false! !


!B3DDisplayScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:21'!
primAllocateForm: d width: w height: h
	"Primitive. Allocate a form with the given parameters"
	<primitive:'primitiveAllocateForm' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:22'!
primDestroyForm: aHandle
	"Primitive. Destroy the form associated with the given handle."
	<primitive:'primitiveDestroyForm' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:22'!
primForm: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	<primitive: 'primitiveFormGetColorMasks' module:'Squeak3DX'>
	^nil! !


!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 20:21'!
primAllocateTexture: d width: w height: h
	"Primitive. Allocate a texture with the given dimensions.
	Note: The texture allocated may *not* match the specified values here."
	<primitive:'primitiveAllocateTexture' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:23'!
primDestroyTexture: aHandle
	"Primitive. Destroy the texture associated with the given handle."
	<primitive:'primitiveDestroyTexture' module:'Squeak3DX'>
	^nil! !

!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:23'!
primGetTextureDepth: aHandle
	"Primitive. Return the actual depth of the texture with the given handle"
	<primitive:'primitiveTextureDepth' module:'Squeak3DX'>
	^self primitiveFailed! !

!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primGetTextureHeight: aHandle
	"Primitive. Return the actual height of the texture with the given handle"
	<primitive:'primitiveTextureHeight' module:'Squeak3DX'>
	^self primitiveFailed! !

!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primGetTextureWidth: aHandle
	"Primitive. Return the actual width of the texture with the given handle"
	<primitive:'primitiveTextureWidth' module:'Squeak3DX'>
	^self primitiveFailed! !

!B3DDisplayScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primTexture: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	<primitive: 'primitiveTextureGetColorMasks' module:'Squeak3DX'>
	^nil! !
Object subclass: #B3DEnginePart
	instanceVariableNames: 'engine '
	classVariableNames: 'PrimitiveActions '
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Engine'!
!B3DEnginePart commentStamp: '<historical>' prior: 0!
I am the superclass for all separate parts of the Balloon 3D engine. I define the basic interface each part of the engine must respond to.

Instance variables:
	engine	<B3DRenderEngine>	The 3D engine I am associated with!


!B3DEnginePart methodsFor: 'initialize' stamp: 'ar 2/16/1999 01:47'!
destroy
	"Destroy all resources temporarily assigned to the receiver"! !

!B3DEnginePart methodsFor: 'initialize' stamp: 'ar 2/5/1999 21:34'!
flush
	"Flush all pending operations"! !

!B3DEnginePart methodsFor: 'initialize'!
initialize
! !

!B3DEnginePart methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:52'!
reset
! !


!B3DEnginePart methodsFor: 'private'!
setEngine: aB3DRenderEngine
	engine _ aB3DRenderEngine! !


!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/7/1999 03:39'!
processIndexedLines: vb
	"Process an indexed line set"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/8/1999 15:36'!
processIndexedQuads: vb
	"Process an indexed quad set"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/7/1999 03:39'!
processIndexedTriangles: vb
	"Process an indexed triangle set"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/4/1999 04:21'!
processLineLoop: vertexBuffer
	"Process a closed line defined by the vertex buffer"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/4/1999 04:21'!
processLines: vertexBuffer
	"Process a series of lines defined by each two points the vertex buffer"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/4/1999 04:21'!
processPoints: vertexBuffer
	"Process a series of points defined by the vertex buffer"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/4/1999 04:22'!
processPolygon: vertexBuffer
	"Process a polygon defined by the vertex buffer"! !

!B3DEnginePart methodsFor: 'processing' stamp: 'ar 2/8/1999 15:35'!
processVertexBuffer: vb
	"Process the given vertex buffer in this part of the engine."
	^self perform: (PrimitiveActions at: vb primitive) with: vb! !

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

B3DEnginePart class
	instanceVariableNames: ''!

!B3DEnginePart class methodsFor: 'instance creation'!
engine: aB3DRenderEngine
	^self new setEngine: aB3DRenderEngine! !

!B3DEnginePart class methodsFor: 'instance creation'!
new
	^super new initialize! !


!B3DEnginePart class methodsFor: 'class initialization' stamp: 'ar 2/7/1999 19:52'!
initialize
	"B3DEnginePart initialize"
	PrimitiveActions _ 
		#(	processPoints:
			processLines:
			processPolygon:
			processIndexedLines:
			processIndexedTriangles:
			processIndexedQuads:
		).! !


!B3DEnginePart class methodsFor: 'testing' stamp: 'ar 2/14/1999 01:39'!
isAvailable
	"Return true if this part of the engine is available"
	^self subclassResponsibility! !

!B3DEnginePart class methodsFor: 'testing' stamp: 'ar 2/17/1999 04:39'!
isAvailableFor: anOutputMedium
	"Return true if this part of the engine is available for the given output medium"
	^self isAvailable! !
InterpreterPlugin subclass: #B3DEnginePlugin
	instanceVariableNames: 'loadBBFn copyBitsFn bbPluginName '
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'VMConstruction-Plugins'!
!B3DEnginePlugin commentStamp: '<historical>' prior: 0!
I am a generic superclass for all Balloon 3D plugins.!


!B3DEnginePlugin methodsFor: 'primitive support' stamp: 'ar 2/14/1999 00:01'!
stackMatrix: index
	"Load a 4x4 transformation matrix from the interpreter stack.
	Return a pointer to the matrix data if successful, nil otherwise."
	| oop |
	self inline: false.
	self returnTypeC:'void*'.
	oop _ interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = 16])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !

!B3DEnginePlugin methodsFor: 'primitive support' stamp: 'ar 4/12/1999 02:15'!
stackPrimitiveIndexArray: stackIndex ofSize: nItems validate: aBool forVertexSize: maxIndex
	"Load a primitive index array from the interpreter stack.
	If aBool is true then check that all the indexes are in the range (1,maxIndex).
	Return a pointer to the index data if successful, nil otherwise."
	| oop oopSize idxPtr index |
	self inline: false.
	self returnTypeC:'void*'.
	self var: #idxPtr declareC:'int *idxPtr'.

	oop _ interpreterProxy stackObjectValue: stackIndex.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifFalse:[^nil].
 	oopSize _ interpreterProxy slotSizeOf: oop.
	oopSize < nItems ifTrue:[^nil].
	idxPtr _ self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int *'.
	aBool ifTrue:[
		0 to: nItems-1 do:[:i|
			index _ idxPtr at: i.
			(index < 0 or:[index > maxIndex]) ifTrue:[^nil]]].
	^idxPtr! !

!B3DEnginePlugin methodsFor: 'primitive support' stamp: 'ar 2/14/1999 00:00'!
stackPrimitiveVertex: index
	"Load a primitive vertex from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop |
	self inline: false.
	self returnTypeC:'void*'.
	oop _ interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = PrimVertexSize])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !

!B3DEnginePlugin methodsFor: 'primitive support' stamp: 'ar 2/14/1999 00:00'!
stackPrimitiveVertexArray: index ofSize: nItems
	"Load a primitive vertex array from the interpreter stack.
	Return a pointer to the vertex data if successful, nil otherwise."
	| oop oopSize |
	self inline: false.
	self returnTypeC:'void*'.
	oop _ interpreterProxy stackObjectValue: index.
	oop = nil ifTrue:[^nil].
	(interpreterProxy isWords: oop) ifTrue:[
 		oopSize _ interpreterProxy slotSizeOf: oop.
		(oopSize >= nItems * PrimVertexSize and:[oopSize \\ PrimVertexSize = 0])
			ifTrue:[^interpreterProxy firstIndexableField: oop]].
	^nil! !


!B3DEnginePlugin methodsFor: 'initialize-release' stamp: 'ar 5/16/2000 20:05'!
initialiseModule
	self export: true.
	loadBBFn _ interpreterProxy ioLoadFunction: 'loadBitBltFrom' From: bbPluginName.
	copyBitsFn _ interpreterProxy ioLoadFunction: 'copyBitsFromtoat' From: bbPluginName.
	^(loadBBFn ~= 0 and:[copyBitsFn ~= 0])! !

!B3DEnginePlugin methodsFor: 'initialize-release' stamp: 'ar 5/16/2000 20:05'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	self export: true.
	self var: #aModuleName type: 'char *'.
	(aModuleName strcmp: bbPluginName) = 0 ifTrue:[
		"BitBlt just shut down. How nasty."
		loadBBFn _ 0.
		copyBitsFn _ 0.
	].! !

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

B3DEnginePlugin class
	instanceVariableNames: ''!

!B3DEnginePlugin class methodsFor: 'translation' stamp: 'ar 5/16/2000 20:05'!
declareCVarsIn: cg
	cg var: 'bbPluginName' declareC:'char bbPluginName[256] = "BitBltPlugin"'.! !

!B3DEnginePlugin class methodsFor: 'translation' stamp: 'ar 2/8/1999 20:48'!
moduleName
	^'Squeak3D'! !

!B3DEnginePlugin class methodsFor: 'translation' stamp: 'TPR 5/23/2000 17:26'!
translateB3D
	"B3DEnginePlugin translateB3D"
	"Translate all the basic plugins into one support module 
	and write the C sources for the rasterizer."
	| cg |
	cg _ PluggableCodeGenerator new initialize.
		cg declareModuleName: self moduleNameAndVersion local: false.

	{InterpreterPlugin. B3DEnginePlugin. B3DTransformerPlugin. B3DVertexBufferPlugin. B3DShaderPlugin. B3DClipperPlugin. B3DPickerPlugin. B3DRasterizerPlugin} do: 
		[:theClass | 
		theClass initialize.
		cg addClass: theClass.
		theClass declareCVarsIn: cg].
	cg storeCodeOnFile: self moduleName , '.c' doInlining: true.
	"	cg storeCodeOnFile: '/tmp/Ballon3D.c' doInlining: true."
	B3DRasterizerPlugin writeSupportCode: true! !

!B3DEnginePlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 15:44'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"do the actual translation"
	{InterpreterPlugin. B3DEnginePlugin. B3DTransformerPlugin. B3DVertexBufferPlugin. B3DShaderPlugin. B3DClipperPlugin. B3DPickerPlugin. B3DRasterizerPlugin} do: 
		[:theClass | 
		theClass initialize.
		cg addClass: theClass.
		theClass declareCVarsIn: cg].
	cg storeCodeOnFile: fullName doInlining: inlineFlag.
	B3DRasterizerPlugin writeSupportCode: true.
! !
B3DFloatArray variableWordSubclass: #B3DExponentTable
	instanceVariableNames: ''
	classVariableNames: 'DefaultExponents '
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!
!B3DExponentTable commentStamp: '<historical>' prior: 0!
I represent a lookup table for several exponents during lighting. Values are computed based on linear interpolation between the stored elements. New tables are created by providing a one argument initialization block from  which I am created.!


!B3DExponentTable methodsFor: 'initialize' stamp: 'ar 2/8/1999 00:08'!
initializeFrom: aBlock
	| last next |
	last _ nil.
	1 to: self size // 2 do:[:i|
		next _ aBlock value: (i-1) / (self size // 2 - 1) asFloat.
		(next isInfinite or:[next isNaN]) ifTrue:[next _ 0.0].
		self at: i*2-1 put: next.
		i > 1 ifTrue:[self at: i-1*2 put: next - last].
		last _ next.
	].! !


!B3DExponentTable methodsFor: 'accessing' stamp: 'ar 2/8/1999 00:10'!
valueAt: aFloat
	"Return the table approximation for the given float value"
	| index max |
	aFloat < 0.0 ifTrue:[^self error:'Cannot use negative numbers in table lookup'].
	max _ self size // 2.
	index _ (max * aFloat) asInteger + 1.
	index >= max ifTrue:[^self at: self size-1].
	"Linear interpolation inbetween"
	^(self at: index) + (aFloat - (index-1) * (self at: index+1))! !

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

B3DExponentTable class
	instanceVariableNames: ''!

!B3DExponentTable class methodsFor: 'class initialization' stamp: 'ar 2/8/1999 00:02'!
initialize
	"B3DExponentTable initialize"
	DefaultExponents _ Dictionary new.
	0 to: 2 do:[:i|
		DefaultExponents at: i put: (self using:[:value| value raisedTo: i]).
	].! !


!B3DExponentTable class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 23:56'!
new
	^self using:[:value| value]! !

!B3DExponentTable class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 23:55'!
numElements
	^128! !

!B3DExponentTable class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 23:59'!
using: aBlock
	"Create a new exponent table using aBlock as initialization"
	^super new initializeFrom: aBlock! !
Object subclass: #B3DFillList
	instanceVariableNames: 'firstFace lastFace '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DFillList methodsFor: 'initialize' stamp: 'ar 4/4/1999 04:28'!
initialize
	self reset.! !


!B3DFillList methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:39'!
first
	^firstFace! !

!B3DFillList methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:49'!
last
	^lastFace! !

!B3DFillList methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:31'!
reset
	firstFace _ lastFace _ nil.! !

!B3DFillList methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:00'!
searchForNewTopAtX: xValue y: yValue
	"A top face ended with no known right face.
	We have to search the fill list for the face with the smallest z value.
	Note: In theory, this should only happen on *right* boundaries of meshes
	and thus not affect performance too much. Having the fillList sorted by
	its minimal z value should help, too."
	| face topFace topZ faceZ floatX floatY |
	self isEmpty ifTrue:[^self]. "No top"
	floatX _ xValue / 4096.0.
	floatY _ yValue.
	face _ self first.
	topFace _ face.
	topZ _ face zValueAtX: floatX y: floatY.
	[face _ face nextFace.
	face == nil] whileFalse:[
		face minZ > topZ ifTrue:[
			"Done. Everything else is behind."
			self remove: topFace.
			self addFront: topFace.
			^self].
		faceZ _ face zValueAtX: floatX y: floatY.
		faceZ < topZ ifTrue:[
			topZ _ faceZ.
			topFace _ face]].
	self remove: topFace.
	self addFront: topFace.! !

!B3DFillList methodsFor: 'accessing' stamp: 'ar 4/4/1999 23:53'!
size
	| n face |
	n _ 0.
	face _ firstFace.
	[face == nil] whileFalse:[
		n _ n + 1.
		face _ face nextFace.
	].
	^n! !


!B3DFillList methodsFor: 'adding' stamp: 'ar 4/5/1999 20:38'!
addBack: aFace
	"Add the given face as a non-front face (e.g., insert it after the front face).
	Make sure that the receiver stays sorted by the minimal z values of faces."
	| minZ midZ face |
	firstFace == nil ifTrue:[^self error:'Inserting a back face with no front face'].
	minZ _ aFace minZ.
	"Quick optimization for insertion at end"
	(firstFace == lastFace or:[minZ >= lastFace minZ]) ifTrue:[^self addLast: aFace].
	"Try an estimation for how to search"
	midZ _ (firstFace nextFace minZ + lastFace minZ) * 0.5.
	minZ <= midZ ifTrue:[
		"Search front to back"
		face _ firstFace nextFace.
		[face minZ < minZ] whileTrue:[face _ face nextFace].
	] ifFalse:[
		"Search back to front"
		face _ lastFace prevFace. "Already checked for lastFace minZ < face minZ"
		[face minZ > minZ] whileTrue:[face _ face prevFace].
		face _ face nextFace.
	].
	self insert: aFace before: face.! !

!B3DFillList methodsFor: 'adding' stamp: 'ar 4/18/1999 08:04'!
addFirst: aFace
	firstFace isNil
		ifTrue:[lastFace _ aFace]
		ifFalse:[firstFace prevFace: aFace].
	aFace nextFace: firstFace.
	aFace prevFace: nil.
	firstFace _ aFace.
	B3DScanner doDebug ifTrue:[self validate].! !

!B3DFillList methodsFor: 'adding' stamp: 'ar 4/5/1999 20:41'!
addFront: aFace
	"Add the given face as the new front face.
	Make sure the sort order stays okay."
	| backFace minZ tempFace |
	firstFace == lastFace ifFalse:["firstFace == lastFace denotes 0 or 1 elements"
		backFace _ firstFace nextFace.
		minZ _ firstFace minZ.
		[backFace notNil and:[backFace minZ < minZ]] 
			whileTrue:[backFace _ backFace nextFace].
		"backFace contains the face before which firstFace has to be added"
		firstFace nextFace == backFace ifFalse:[
			tempFace _ firstFace.
			self remove: tempFace.
			backFace == nil 
				ifTrue:[self addLast: tempFace]
				ifFalse:[self insert: tempFace before: backFace].
		].
	].
	^self addFirst: aFace! !

!B3DFillList methodsFor: 'adding' stamp: 'ar 4/18/1999 08:04'!
addLast: aFace
	lastFace isNil
		ifTrue:[firstFace _ aFace]
		ifFalse:[lastFace nextFace: aFace].
	aFace prevFace: lastFace.
	aFace nextFace: nil.
	lastFace _ aFace.
	B3DScanner doDebug ifTrue:[self validate].! !

!B3DFillList methodsFor: 'adding' stamp: 'ar 4/18/1999 08:04'!
insert: aFace before: nextFace
	"Insert the given face before nextFace."
	B3DScanner doDebug ifTrue:[
		(self includes: nextFace) ifFalse:[^self error:'Face not in collection'].
		(self includes: aFace) ifTrue:[^self error:'Face already in collection'].
	].
	aFace nextFace: nextFace.
	aFace prevFace: nextFace prevFace.
	aFace prevFace nextFace: aFace.
	nextFace prevFace: aFace.
	B3DScanner doDebug ifTrue:[self validate].! !


!B3DFillList methodsFor: 'removing' stamp: 'ar 4/18/1999 08:04'!
remove: aFace
	(B3DScanner doDebug and:[(self includes: aFace) not]) 
		ifTrue:[^self error:'Face not in list'].
	B3DScanner doDebug ifTrue:[self validate].
	aFace prevFace isNil
		ifTrue:[firstFace _ aFace nextFace]
		ifFalse:[aFace prevFace nextFace: aFace nextFace].
	aFace nextFace isNil
		ifTrue:[lastFace _ aFace prevFace]
		ifFalse:[aFace nextFace prevFace: aFace prevFace].
	^aFace! !


!B3DFillList methodsFor: 'enumerating' stamp: 'ar 4/18/1999 08:03'!
do: aBlock
	| face |
	B3DScanner doDebug ifTrue:[self validate].
	face _ firstFace.
	[face == nil] whileFalse:[
		aBlock value: face.
		face _ face nextFace.
	].! !


!B3DFillList methodsFor: 'testing' stamp: 'ar 4/5/1999 01:58'!
includes: aFace
	| face |
	face _ firstFace.
	[face == nil] whileFalse:[
		face == aFace ifTrue:[^true].
		face _ face nextFace.
	].
	^false! !

!B3DFillList methodsFor: 'testing' stamp: 'ar 4/3/1999 00:49'!
isEmpty
	^firstFace == nil! !


!B3DFillList methodsFor: 'private' stamp: 'ar 4/5/1999 03:54'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$(;
		print: self size;
		nextPut: $).! !

!B3DFillList methodsFor: 'private' stamp: 'ar 4/5/1999 20:27'!
validate
	| face |
	(firstFace == nil and:[lastFace == nil]) ifTrue:[^self].
	firstFace prevFace == nil ifFalse:[^self error:'Bad list'].
	lastFace nextFace == nil ifFalse:[^self error:'Bad list'].
	face _ firstFace.
	[face == lastFace] whileFalse:[face _ face nextFace].
	self validateSortOrder.! !

!B3DFillList methodsFor: 'private' stamp: 'ar 4/5/1999 20:39'!
validateSortOrder
	| backFace |
	firstFace == lastFace ifTrue:[^self]. "0 or 1 element"
	backFace _ firstFace nextFace.
	[backFace nextFace == nil] whileFalse:[
		backFace minZ <= backFace nextFace minZ ifFalse:[^self error:'Sorting error'].
		backFace _ backFace nextFace.
	].! !

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

B3DFillList class
	instanceVariableNames: ''!

!B3DFillList class methodsFor: 'instance creation' stamp: 'ar 4/4/1999 04:27'!
new
	^super new initialize! !
FloatArray variableWordSubclass: #B3DFloatArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DFloatArray commentStamp: '<historical>' prior: 0!
I am the superclass for all Balloon 3D vector objects.!


!B3DFloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index
	"For subclasses that override #at:"
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!B3DFloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index put: value
	"For subclasses that override #at:put:"
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	self basicAt: index put: value asIEEE32BitWord.
	^value! !

!B3DFloatArray methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:23'!
numElements
	^self class numElements! !

!B3DFloatArray methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:10'!
wordAt: index
	<primitive: 60>
	^self primitiveFailed! !

!B3DFloatArray methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:10'!
wordAt: index put: value
	<primitive: 61>
	^self primitiveFailed! !


!B3DFloatArray methodsFor: 'initialize'!
loadFrom: srcObject
	self == srcObject ifTrue:[^self].
	self class == srcObject class
		ifTrue:[self replaceFrom: 1 to: self size with: srcObject startingAt: 1]
		ifFalse:[self privateLoadFrom: srcObject]! !


!B3DFloatArray methodsFor: 'private'!
privateLoadFrom: srcObject
	"Load the receiver from the given source object."
	self error:'Cannot load a ', srcObject class name,' into a ', self class name.! !

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

B3DFloatArray class
	instanceVariableNames: ''!

!B3DFloatArray class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:20'!
new
	^super new: self numElements! !

!B3DFloatArray class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:21'!
numElements
	^0! !
Object subclass: #B3DGeometry
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Objects'!
B3DPrimitiveEngine subclass: #B3DHardwareEngine
	instanceVariableNames: 'vpTransform '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Acceleration'!
!B3DHardwareEngine commentStamp: '<historical>' prior: 0!
B3DHardwareEngine is a render engine specifically designed to deal with HW accellerated implementations. The (currently only) difference to the generic render engine is that a HW accellerated engine automatically clips the virtual viewport specified by client. This is necessary since HW accellerated rasterizers can usually not render outside the actual display surface.

Note: If the viewport clipping proves to be efficient enough it might be promoted to the general render engine since there is no point in rendering outside the clipping rectangle.!


!B3DHardwareEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 04:05'!
viewport: aRectangle
	"check if we need a transform override for the viewport"
	| vp clipRect |
	vp _ aRectangle.
	clipRect _ rasterizer clipRect.
	(clipRect containsRect: vp) ifTrue:[
		"Good. The viewport is fully within the clip rect."
		vpTransform _ nil.
	] ifFalse:[
		"We need a transform override here"
		vp _ clipRect intersect: vp.
		"Actual viewport is vp. Now scale from aRectangle into vp.
		This is equivalent to picking vp center with vp extent."
		vp area > 0 ifTrue:[
			vpTransform _ self pickingMatrixFor: aRectangle at: (vp origin + vp corner) * 0.5 extent: vp extent].
	].
	"And set actual viewport"
	super viewport: vp.! !


!B3DHardwareEngine methodsFor: 'private-rendering' stamp: 'ar 2/27/2000 20:14'!
privateTransformVB: vb
	vpTransform 
		ifNil:[^transformer processVertexBuffer: vb]
		ifNotNil:["We must override the projection matrix here"
			^transformer
				processVertexBuffer: vb
					modelView: transformer modelViewMatrix
					projection: (transformer projectionMatrix composedWithGlobal: vpTransform)].! !

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

B3DHardwareEngine class
	instanceVariableNames: ''!

!B3DHardwareEngine class methodsFor: 'accessing' stamp: 'ar 2/24/2000 00:15'!
rasterizer
	^B3DHardwareRasterizer! !
B3DVertexRasterizer subclass: #B3DHardwareRasterizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Acceleration'!
!B3DHardwareRasterizer commentStamp: '<historical>' prior: 0!
WICHTIG:

	Viewport muss an den renderer gebunden sein.
	Viewport kann multiple sein.
!


!B3DHardwareRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:13'!
finish
	"Wait until drawing was completed so we won't get into any trouble with 2D operations afterwards. Note: Later we will synchronize this with the portions of display in use."
	target finish! !

!B3DHardwareRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:13'!
flush
	"Flush the pipeline. Flushing will force processing but not wait until it's finished."
	target flush.! !

!B3DHardwareRasterizer methodsFor: 'initialize' stamp: 'ar 7/11/2000 11:05'!
viewport: vp
	super viewport: vp.
	self primSetViewportX: viewport left asInteger
			y: viewport top asInteger
			w: viewport width asInteger
			h: viewport height asInteger.! !


!B3DHardwareRasterizer methodsFor: 'accessing' stamp: 'ar 5/27/2000 00:47'!
clearDepthBuffer
	self primClearDepthBuffer.! !


!B3DHardwareRasterizer methodsFor: 'testing' stamp: 'ar 2/24/2000 00:00'!
needsClip
	^true! !


!B3DHardwareRasterizer methodsFor: 'processing' stamp: 'ar 9/1/2000 10:22'!
processVertexBuffer: vb
	| box |
	box _ self primProcessVB: vb primitive 
			texture: (target textureHandleOf: texture) 
			vertices: vb vertexArray 
			vertexCount: vb vertexCount 
			faces: vb indexArray 
			faceCount: vb indexCount.
	^box ifNotNil:[(box at: 1) @ (box at: 2) corner: (box at: 3) @ (box at: 4)]! !


!B3DHardwareRasterizer methodsFor: 'primitives' stamp: 'ar 5/26/2000 15:06'!
primClearDepthBuffer
	<primitive:'primitiveClearDepthBuffer' module:'Squeak3DX'>
	^self primitiveFailed! !

!B3DHardwareRasterizer methodsFor: 'primitives' stamp: 'ar 9/1/2000 10:23'!
primProcessVB: primitiveType texture: textureHandle vertices: vtxArray vertexCount: vtxCount faces: idxArray faceCount: idxCount
	<primitive:'primitiveProcessVertexBuffer' module:'Squeak3DX'>
	"There's a bug somewhere in the primitive code leading to failures every now and then which can be safely ignored since the next frame will almost always be fine. I need to track this down but it takes time and these primitive failures are annoying..."
	^nil! !

!B3DHardwareRasterizer methodsFor: 'primitives' stamp: 'ar 2/24/2000 00:06'!
primSetViewportX: left y: top w: width h: height
	<primitive:'primitiveSetViewport' module:'Squeak3DX'>
	^self primitiveFailed! !

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

B3DHardwareRasterizer class
	instanceVariableNames: ''!

!B3DHardwareRasterizer class methodsFor: 'accessing' stamp: 'ar 5/25/2000 22:00'!
isAvailable
	^self version > 0! !

!B3DHardwareRasterizer class methodsFor: 'accessing' stamp: 'ar 5/25/2000 22:01'!
version
	"B3DPrimitiveRasterizer version"
	<primitive:'primitiveRasterizerVersion' module:'Squeak3DX'>
	^0! !


!B3DHardwareRasterizer class methodsFor: 'testing' stamp: 'ar 5/28/2000 15:04'!
isAvailableFor: aForm
	"Return true if this part of the engine is available for the given output medium"
	aForm ifNil:[^false].
	(aForm isDisplayScreen and:[aForm isB3DDisplayScreen]) ifFalse:[^false].
	^self isAvailable! !
B3DGeometry subclass: #B3DIndexedMesh
	instanceVariableNames: 'vertices vtxNormals vtxColors vtxTexCoords faces faceNormals bBox '
	classVariableNames: 'FlagFanStart FlagStripStart VRML97BoxCache VRML97ConeCache VRMLCylCache VRMLSphereCache '
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!
!B3DIndexedMesh commentStamp: '<historical>' prior: 0!
I represent a generic indexed face mesh. My subclasses define what kind of primitive objects I can represent. !


!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 20:03'!
animationParameter
	^0.0! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 20:03'!
animationParameter: param
! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
boundingBox
	^bBox ifNil:[bBox _ self computeBoundingBox]! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
faceNormals
	^faceNormals ifNil:[faceNormals _ self computeFaceNormals]! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
faces
	^faces! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'jsp 3/11/1999 11:44'!
faces: newFaces
	faces _ newFaces.
! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
texCoords
	^vtxTexCoords! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'jsp 3/11/1999 11:43'!
texCoords: newTexCoords
	vtxTexCoords _ newTexCoords.
! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 9/16/1999 14:49'!
vertexColors
	^vtxColors! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 9/16/1999 14:50'!
vertexColors: aB3DColor4Array
	vtxColors _ aB3DColor4Array! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
vertexNormals
	^vtxNormals ifNil:[vtxNormals _ self computeVertexNormals].! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'jsp 3/11/1999 11:44'!
vertexNormals: newNormals
	vtxNormals _ newNormals.! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'ar 2/16/1999 19:08'!
vertices
	^vertices! !

!B3DIndexedMesh methodsFor: 'accessing' stamp: 'jsp 3/11/1999 11:43'!
vertices: newVertices
	vertices _ newVertices.! !


!B3DIndexedMesh methodsFor: 'modifying' stamp: 'ar 2/16/1999 19:08'!
centerAtZero
	self translateBy: (self boundingBox origin + self boundingBox corner * -0.5).! !

!B3DIndexedMesh methodsFor: 'modifying' stamp: 'jsp 9/17/1999 14:13'!
transformBy: aMatrix
	"Modify the mesh by transforming it using a matrix; this allows us to change the insertion point of the mesh"

	vertices do: [:vtx | 	vtx privateLoadFrom: ((aMatrix composeWith:
										(B3DMatrix4x4 identity translation: vtx)) translation) ].

	bBox ifNotNil: [ self computeBoundingBox ].
	self computeVertexNormals.
! !

!B3DIndexedMesh methodsFor: 'modifying' stamp: 'ar 2/16/1999 19:08'!
translateBy: amount
	vertices do:[:vtx| vtx += amount].
	bBox ifNotNil:[bBox _ bBox translateBy: amount].! !


!B3DIndexedMesh methodsFor: 'displaying' stamp: 'ar 2/16/1999 19:08'!
renderOn: aRenderer
	^self subclassResponsibility! !


!B3DIndexedMesh methodsFor: 'private' stamp: 'ar 2/16/1999 19:08'!
computeBoundingBox
	| min max |
	min _ max _ nil.
	vertices do:[:vtx|
		min ifNil:[min _ vtx] ifNotNil:[min _ min min: vtx].
		max ifNil:[max _ vtx] ifNotNil:[max _ max max: vtx].
	].
	^Rectangle origin: min corner: max! !

!B3DIndexedMesh methodsFor: 'private' stamp: 'ar 2/16/1999 19:09'!
computeFaceNormals
	| out face v1 v2 v3 d1 d2 normal |
	out _ B3DVector3Array new: faces size.
	1 to: faces size do:[:i|
		face _ faces at: i.
		v1 _ vertices at: face p1Index.
		v2 _ vertices at: face p2Index.
		v3 _ vertices at: face p3Index.
		d1 _ v3 - v1.
		d2 _ v2 - v1.
		d1 safelyNormalize.
		d2 safelyNormalize.
		normal _ d1 cross: d2.
		out at: i put: normal safelyNormalize.
	].
	^out! !

!B3DIndexedMesh methodsFor: 'private' stamp: 'ar 2/16/1999 19:09'!
computeVertexNormals
	| temp normals face normal v1 v2 v3 out |
	temp _ Array new: vertices size.
	1 to: temp size do:[:i| temp at: i put: B3DVector4 new].
	normals _ self faceNormals. "Forces computation if necessary"
	1 to: faces size do:[:i|
		face _ faces at: i.
		normal _ (normals at: i) asB3DVector4.
		v1 _ face p1Index.
		v2 _ face p2Index.
		v3 _ face p3Index.
		(temp at: v1) += normal.
		(temp at: v2) += normal.
		(temp at: v3) += normal.
	].
	out _ B3DVector3Array new: vertices size.
	1 to: out size do:[:i|
		out at: i put: (temp at: i) asB3DVector3 safelyNormalize.
	].
	^out! !


!B3DIndexedMesh methodsFor: 'optimizations' stamp: 'ar 2/8/1999 06:52'!
optimizeMeshLayout
	"Optimize the layout of the indexed mesh for primitive operations.
	Optimzed layouts include triangle/quad strips and fans and 
	will result in MUCH better performance during rendering.
	However, optimizations are generally time-consuming so
	you better don't call this method too often."
	^self "Must be implemented in my subclasses"! !


!B3DIndexedMesh methodsFor: 'converting' stamp: 'ar 9/17/1999 12:37'!
asSimpleMesh
	"Convert the receiver into a very simple mesh representation"
	| simpleFaces oldFace newVtx newFace newVertices pos |
	simpleFaces _ WriteStream on: (Array new: faces size).
	newVertices _ WriteStream on: (Array new: 10).
	1 to: faces size do:[:i|
		oldFace _ faces at: i.
		newVertices reset.
		1 to: oldFace size do:[:j|
			pos _ oldFace at: j.
			newVtx _ B3DSimpleMeshVertex new.
			newVtx position: (vertices at: pos).
			vtxNormals == nil ifFalse:[newVtx normal: (vtxNormals at: pos)].
			vtxColors == nil ifFalse:[newVtx color: (vtxColors at: pos)].
			vtxTexCoords == nil ifFalse:[newVtx texCoord: (vtxTexCoords at: pos)].
			newVertices nextPut: newVtx].
		newFace _ B3DSimpleMeshFace withAll: newVertices contents.
		simpleFaces nextPut: newFace].
	^B3DSimpleMesh withAll: simpleFaces contents! !


!B3DIndexedMesh methodsFor: 'testing' stamp: 'ar 9/16/1999 23:32'!
hasVertexColors
	^vtxColors notNil! !

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

B3DIndexedMesh class
	instanceVariableNames: ''!

!B3DIndexedMesh class methodsFor: 'class initialization' stamp: 'ar 9/16/1999 23:02'!
flushVRMLCache
	"B3DIndexedMesh flushVRMLCache"
	VRML97BoxCache _
	VRML97ConeCache _
	VRMLCylCache _
	VRMLSphereCache _
	nil.! !

!B3DIndexedMesh class methodsFor: 'class initialization' stamp: 'ar 2/8/1999 06:55'!
initialize	"B3DIndexedMesh initialize"
	"Optimization flags: These flags are *hints* and may be ignored by the renderer."
	FlagStripStart _ 1.
	FlagFanStart _ 2.! !


!B3DIndexedMesh class methodsFor: 'examples' stamp: 'ar 2/8/1999 21:18'!
sampleRect
	^self sampleRect: 10! !

!B3DIndexedMesh class methodsFor: 'examples' stamp: 'ar 2/8/1999 16:58'!
sampleRect: n
	^self new sampleRect: n! !


!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:12'!
vrml97Box
	"Return a mesh representing a VRML97 Box"
	^VRML97BoxCache ifNil:[
		VRML97BoxCache _ (B3DSimpleMesh withAll: self vrmlCreateBoxFaces) asIndexedMesh]! !

!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:15'!
vrml97Cone
	"Return a mesh representing a VRML97 Cone"
	^self vrml97Cone: true bottom: true.! !

!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:14'!
vrml97Cone: doSide bottom: doBottom
	"Return a mesh representing a VRML97 Cone"
	| idx |
	idx _ 0.
	doBottom ifTrue:[idx _ idx + 2].
	doSide ifTrue:[idx _ idx + 1].
	VRML97ConeCache == nil ifTrue:[
		VRML97ConeCache _ Array new: 3.
		1 to: 3 do:[:i|
			VRML97ConeCache at: i put:
				(self 
					vrmlCreateCone: (i anyMask: 1) 
					bottom: (i anyMask: 2))]].
	^VRML97ConeCache at: idx! !

!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:15'!
vrml97Cylinder
	"Return a mesh representing a VRML97 Cylinder"
	^self vrml97Cylinder: true bottom: true top: true.! !

!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:14'!
vrml97Cylinder: doSide bottom: doBottom top: doTop
	"Return a mesh representing a VRML97 Cylinder"
	| idx |
	idx _ 0.
	doTop ifTrue:[idx _ idx + 4].
	doBottom ifTrue:[idx _ idx + 2].
	doSide ifTrue:[idx _ idx + 1].
	idx = 0 ifTrue:[^nil].
	VRMLCylCache == nil ifTrue:[
		VRMLCylCache _ Array new: 7.
		1 to: 7 do:[:i|
			VRMLCylCache at: i put:
				(self 
					vrmlCreateCylinder: (i anyMask: 1) 
					bottom: (i anyMask: 2) 
					top: (i anyMask: 4))]].
	^VRMLCylCache at: idx! !

!B3DIndexedMesh class methodsFor: 'vrml97 prototypes' stamp: 'ar 9/16/1999 22:21'!
vrml97Sphere
	"Return a mesh representing a VRML97 Sphere"
	^VRMLSphereCache ifNil:[
		VRMLSphereCache _ (B3DSimpleMesh withAll: self vrmlCreateSphereFaces) asIndexedMesh].! !


!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:07'!
vrmlCreateBottomFaces
	| face steps dir m lastVtx nextVtx faceList midVtx |
	steps _ self vrmlSteps.
	faceList _ WriteStream on: (Array new: steps).
	dir _ 0@0@1.
	m _ (B3DRotation angle: (360.0 / steps) axis: (0@-1@0)) asMatrix4x4.
	lastVtx _ B3DSimpleMeshVertex new.
	lastVtx position: 0@-1@1.
	lastVtx normal: 0@-1@0.
	lastVtx texCoord: 0.5@1.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 3.
		face at: 1 put: lastVtx.
		dir _ (m localPointToGlobal: dir) normalized.
		nextVtx _ B3DSimpleMeshVertex new.
		nextVtx position: dir x @ -1 @ dir z.
		nextVtx normal: 0@-1@0.
		nextVtx texCoord: (dir x @ dir z) * 0.5 + 0.5.
		midVtx _ nextVtx copy.
		midVtx position: 0@-1@0.
		midVtx texCoord:  0.5@0.5.
		face at: 2 put: nextVtx.
		face at: 3 put: midVtx.
		faceList nextPut: face.
		lastVtx _ nextVtx].
	^faceList contents! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:11'!
vrmlCreateBoxFaces
	| vtx face vtxSpec faceList |
	faceList _ WriteStream on: (Array new: 6).
	"front and back face"
	vtxSpec _ #(	((-1 -1) (0 1))	(( 1 -1) (1 1))		(( 1  1) (1 0))	((-1  1) (0 0))).
	"front"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: spec first first @ spec first second @ -1.
		vtx normal: 0@0@-1.
		vtx texCoord: spec second first @ spec second second.
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	"back"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: spec first first @ spec first second @ 1.
		vtx normal: 0@0@1.
		vtx texCoord: 1 - spec second first @ spec second second.
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	"top"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: spec first first @ 1 @ spec first second.
		vtx normal: 1@0@0.
		vtx texCoord: spec second first @ spec second second.
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	"bottom"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: spec first first @ -1 @ spec first second.
		vtx normal: -1@0@0.
		vtx texCoord: spec second first @ (1 - spec second second).
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	vtxSpec _ #(	((-1 -1) (0 1))	((-1  1) (1 1))		(( 1  1) (1 0))	(( 1 -1) (0 0))).
	"right"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: 1 @ spec first first @ spec first second.
		vtx normal: 1@0@0.
		vtx texCoord: spec second first @ spec second second.
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	"left"
	face _ B3DSimpleMeshFace new: 4.
	vtxSpec doWithIndex:[:spec :idx|
		vtx _ B3DSimpleMeshVertex new.
		vtx position: -1 @ spec first first @ spec first second.
		vtx normal: -1@0@0.
		vtx texCoord: 1 - spec second first @ spec second second.
		face at: idx put: vtx.
	].
	faceList nextPut: face.
	^faceList contents! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:16'!
vrmlCreateCone: doSide bottom: doBottom
	| faces |
	faces _ #().
	doSide ifTrue:[faces _ faces, self vrmlCreateConeFaces].
	doBottom ifTrue:[faces _ faces, self vrmlCreateBottomFaces].
	^(B3DSimpleMesh withAll: faces) asIndexedMesh! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:07'!
vrmlCreateConeFaces
	| face steps dir m lastVtx nextVtx topVtx faceList |
	steps _ self vrmlSteps.
	faceList _ WriteStream on: (Array new: steps).
	dir _ 0@0@1.
	m _ (B3DRotation angle: (360.0 / steps) axis: (0@-1@0)) asMatrix4x4.
	lastVtx _ B3DSimpleMeshVertex new.
	lastVtx position: 0@-1@1.
	lastVtx normal: dir.
	lastVtx texCoord: 0@1.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 3.
		face at: 1 put: lastVtx.
		dir _ (m localPointToGlobal: dir) normalized.
		nextVtx _ B3DSimpleMeshVertex new.
		nextVtx position: dir x @ -1 @ dir z.
		nextVtx normal: dir.
		nextVtx texCoord: (i / steps asFloat) @ 1.
		topVtx _ nextVtx copy.
		topVtx position: 0@1@0.
		topVtx texCoord:  lastVtx texCoord x @ 0.
		face at: 2 put: nextVtx.
		face at: 3 put: topVtx.
		faceList nextPut: face.
		lastVtx _ nextVtx].
	^faceList contents! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:05'!
vrmlCreateCylinder: doSide bottom: doBottom top: doTop
	| faces |
	faces _ #().
	doSide ifTrue:[faces _ faces, self vrmlCreateCylinderFaces].
	doBottom ifTrue:[faces _ faces, self vrmlCreateBottomFaces].
	doTop ifTrue:[faces _ faces, self vrmlCreateTopFaces].
	^(B3DSimpleMesh withAll: faces) asIndexedMesh! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:07'!
vrmlCreateCylinderFaces
	| face steps dir m lastVtx nextVtx topVtx lastTopVtx faceList |
	steps _ self vrmlSteps.
	faceList _ WriteStream on: (Array new: steps).
	dir _ 0@0@1.
	m _ (B3DRotation angle: (360.0 / steps) axis: (0@-1@0)) asMatrix4x4.
	lastVtx _ B3DSimpleMeshVertex new.
	lastVtx position: 0@-1@1.
	lastVtx normal: dir.
	lastVtx texCoord: 0@1.
	lastTopVtx _ lastVtx copy.
	lastTopVtx position: 0@1@1.
	lastTopVtx texCoord: 0@0.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 4.
		face at: 1 put: lastVtx.
		face at: 4 put: lastTopVtx.
		dir _ (m localPointToGlobal: dir) normalized.
		nextVtx _ B3DSimpleMeshVertex new.
		nextVtx position: dir x @ -1 @ dir z.
		nextVtx normal: dir.
		nextVtx texCoord: (i / steps asFloat) @ 1.
		topVtx _ nextVtx copy.
		topVtx position: dir x @ 1 @  dir z.
		topVtx texCoord:  (i / steps asFloat) @ 0.
		face at: 2 put: nextVtx.
		face at: 3 put: topVtx.
		faceList nextPut: face.
		lastVtx _ nextVtx.
		lastTopVtx _ topVtx].
	^faceList contents
! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:58'!
vrmlCreateSphereFaces
	"B3DIndexedMesh vrmlCreateSphereFaces"
	| faceList vtx steps m1 m2 baseDir vtxList vertices dir lastVtx nextVtx face |
	steps _ self vrmlSteps.
	faceList _ WriteStream on: (Array new: steps * steps).
	"<--- vertex construction --->"
	m1 _ (B3DRotation angle: 360.0 / steps axis: 0@-1@0) asMatrix4x4.
	m2 _ (B3DRotation angle: 180.0 / steps axis: 1@0@0) asMatrix4x4.
	baseDir _ 0@1@0.
	vtxList _ Array new: steps + 1.
	0 to: steps do:[:i|
		i = steps ifTrue:[baseDir _ 0@-1@0]. "Make closed for sure"
		vertices _ Array new: steps + 1.
		vtxList at: i+1 put: vertices.
		dir _ baseDir.
		0 to: steps do:[:j|
			j = steps ifTrue:[dir _ baseDir]. "Make closed for sure"
			vtx _ B3DSimpleMeshVertex new.
			vtx position: dir; normal: dir.
			vtx texCoord: (j / steps asFloat) @ (i / steps asFloat).
			vertices at: j+1 put: vtx.
			dir _ (m1 localPointToGlobal: dir) normalized.
		].
		baseDir _ (m2 localPointToGlobal: baseDir) normalized.
	].
	"<--- face construction --->"
	"Construct first round separately as triangles"
	lastVtx _ vtxList at: 1.
	nextVtx _ vtxList at: 2.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 3.
		face at: 1 put: (lastVtx at: i).
		face at: 2 put: (nextVtx at: i+1).
		face at: 3 put: (nextVtx at: i).
		faceList nextPut: face].
	"Construct the next rounds as quads"
	2 to: steps-1 do:[:i|
		lastVtx _ vtxList at: i.
		nextVtx _ vtxList at: i+1.
		1 to: steps do:[:j|
			face _ B3DSimpleMeshFace new: 4.
			face at: 1 put: (lastVtx at: j).
			face at: 2 put: (lastVtx at: j+1).
			face at: 3 put: (nextVtx at: j+1).
			face at: 4 put: (nextVtx at: j).
			faceList nextPut: face]].
	"Construct the last round separately as triangles"
	lastVtx _ vtxList at: steps.
	nextVtx _ vtxList at: steps+1.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 3.
		face at: 1 put: (lastVtx at: i).
		face at: 2 put: (lastVtx at: i+1).
		face at: 3 put: (nextVtx at: i).
		faceList nextPut: face].
	^faceList contents! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:08'!
vrmlCreateTopFaces
	| face steps dir m lastVtx nextVtx faceList midVtx |
	steps _ self vrmlSteps.
	faceList _ WriteStream on: (Array new: steps).
	dir _ 0@0@1.
	m _ (B3DRotation angle: (360.0 / steps) axis: (0@-1@0)) asMatrix4x4.
	lastVtx _ B3DSimpleMeshVertex new.
	lastVtx position: 0@1@1.
	lastVtx normal: 0@1@0.
	lastVtx texCoord: 0.5@0.
	1 to: steps do:[:i|
		face _ B3DSimpleMeshFace new: 3.
		face at: 1 put: lastVtx.
		dir _ (m localPointToGlobal: dir) normalized.
		nextVtx _ B3DSimpleMeshVertex new.
		nextVtx position: dir x @ 1 @ dir z.
		nextVtx normal: 0@1@0.
		nextVtx texCoord: (dir x @ dir z) * (0.5 @ -0.5) + 0.5.
		midVtx _ nextVtx copy.
		midVtx position: 0@1@0.
		midVtx texCoord:  0.5@0.5.
		face at: 2 put: nextVtx.
		face at: 3 put: midVtx.
		faceList nextPut: face.
		lastVtx _ nextVtx].
	^faceList contents! !

!B3DIndexedMesh class methodsFor: 'vrml support' stamp: 'ar 9/16/1999 22:15'!
vrmlSteps
	"Return the number of steps for rotational objects"
	^16! !
B3DGeometry variableWordSubclass: #B3DIndexedQuad
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DIndexedQuad methodsFor: 'initialize' stamp: 'ar 2/7/1999 20:00'!
with: i1 with: i2 with: i3 with: i4
	self at: 1 put: i1.
	self at: 2 put: i2.
	self at: 3 put: i3.
	self at: 4 put: i4.! !


!B3DIndexedQuad methodsFor: 'accessing' stamp: 'ar 2/8/1999 16:39'!
flags
	^0! !


!B3DIndexedQuad methodsFor: 'private' stamp: 'ar 2/7/1999 20:02'!
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>
	^self primitiveFailed! !


!B3DIndexedQuad methodsFor: 'printing' stamp: 'ar 2/8/1999 16:39'!
printOn: aStream
	aStream nextPutAll:'IQuad(';
		print: (self at: 1);
		nextPutAll:', ';
		print: (self at: 2);
		nextPutAll:', ';
		print: (self at: 3);
		nextPutAll:', ';
		print: (self at: 4);
		nextPutAll:', ';
		print: (self flags);
		nextPutAll:')'.! !

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

B3DIndexedQuad class
	instanceVariableNames: ''!

!B3DIndexedQuad class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 19:59'!
new
	^self new: 4! !

!B3DIndexedQuad class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 20:03'!
numElements
	^4! !

!B3DIndexedQuad class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 19:59'!
with: i1 with: i2 with: i3 with: i4
	^self new with: i1 with: i2 with: i3 with: i4! !
B3DInplaceArray variableWordSubclass: #B3DIndexedQuadArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

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

B3DIndexedQuadArray class
	instanceVariableNames: ''!

!B3DIndexedQuadArray class methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:58'!
contentsClass
	^B3DIndexedQuad! !
B3DIndexedMesh subclass: #B3DIndexedQuadMesh
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DIndexedQuadMesh methodsFor: 'displaying' stamp: 'ar 11/7/1999 18:35'!
renderOn: aRenderer
	^aRenderer
		drawIndexedQuads: faces
			vertices: vertices
			normals: vtxNormals
			colors: vtxColors
			texCoords: vtxTexCoords.! !


!B3DIndexedQuadMesh methodsFor: 'private' stamp: 'ar 9/10/1999 15:05'!
plainTextureRect
	"Create a new plain rectangle w/ texture coords"

	vertices _ B3DVector3Array new: 4.
	vertices at: 1 put: (-1@-1@0).
	vertices at: 2 put: (1@-1@0).
	vertices at: 3 put: (1@1@0).
	vertices at: 4 put: (-1@1@0).

	vtxTexCoords _ B3DTexture2Array new: 4.
	vtxTexCoords at: 1 put: (0@1).
	vtxTexCoords at: 2 put: (1@1).
	vtxTexCoords at: 3 put: (1@0).
	vtxTexCoords at: 4 put: (0@0).

	faces _ B3DIndexedQuadArray new: 1.
	faces at: 1 put: (B3DIndexedQuad with: 1 with: 2 with: 3 with: 4).! !

!B3DIndexedQuadMesh methodsFor: 'private' stamp: 'ar 2/8/1999 02:15'!
sampleRect: n
	"B3DIndexedQuadMesh new sampleRect"
	| vtx face |
	vtx _ WriteStream on: (B3DVector3Array new).
	n negated to: n do:[:x|
		n negated to: n do:[:y|
			vtx nextPut: (B3DVector3 x: x y: y z: 0) /= n asFloat.
		].
	].
	vertices _ vtx contents.
	vtxNormals _ B3DVector3Array new: (2*n+1) squared.
	1 to: vtxNormals size do:[:i| vtxNormals at: i put: (0@0@-1)].
	faces _ B3DIndexedQuadArray new: (2*n) squared.
	0 to: 2*n-1 do:[:i|
		1 to: 2*n do:[:j|
			face _ B3DIndexedQuad 
						with: (i*(2*n+1)+j)
						with: (i*(2*n+1)+j+1)
						with: (i+1*(2*n+1)+j+1)
						with: (i+1*(2*n+1)+j).
			faces at: i*2*n+j put: face.
		]].! !
B3DGeometry variableWordSubclass: #B3DIndexedTriangle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DIndexedTriangle methodsFor: 'initialize' stamp: 'ar 2/16/1999 19:09'!
with: index1 with: index2 with: index3
	self p1Index: index1.
	self p2Index: index2.
	self p3Index: index3.! !


!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/8/1999 05:15'!
flags
	^0 "May be used later"! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/8/1999 05:16'!
flags: aNumber
	^self "Maybe used later"! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:54'!
p1Index
	^self at: 1! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:55'!
p1Index: aNumber
	self at: 1 put: aNumber! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:55'!
p2Index
	^self at: 2! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:55'!
p2Index: aNumber
	self at: 2 put: aNumber! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:55'!
p3Index
	^self at: 3! !

!B3DIndexedTriangle methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:55'!
p3Index: aNumber
	self at: 3 put: aNumber! !


!B3DIndexedTriangle methodsFor: 'testing' stamp: 'ar 2/8/1999 06:15'!
includesIndex: idx
	^(self at: 1) = idx or:[(self at: 2) = idx or:[(self at: 3) = idx]]! !


!B3DIndexedTriangle methodsFor: 'private' stamp: 'ar 2/5/1999 23:19'!
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>
	^self primitiveFailed! !


!B3DIndexedTriangle methodsFor: 'printing' stamp: 'ar 2/8/1999 05:14'!
printOn: aStream
	aStream nextPutAll:'IFace(';
		print: self p1Index;
		nextPutAll:', ';
		print: self p2Index;
		nextPutAll:', ';
		print: self p3Index;
		nextPutAll:', ';
		print: self flags;
		nextPutAll:')'.! !

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

B3DIndexedTriangle class
	instanceVariableNames: ''!

!B3DIndexedTriangle class methodsFor: 'instance creation' stamp: 'ar 2/8/1999 05:14'!
new
	^self new: self numElements! !

!B3DIndexedTriangle class methodsFor: 'instance creation' stamp: 'ar 2/8/1999 05:15'!
numElements
	^3! !

!B3DIndexedTriangle class methodsFor: 'instance creation' stamp: 'ar 2/16/1999 19:09'!
with: index1 with: index2 with: index3
	^self new with: index1 with: index2 with: index3! !
B3DInplaceArray variableWordSubclass: #B3DIndexedTriangleArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

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

B3DIndexedTriangleArray class
	instanceVariableNames: ''!

!B3DIndexedTriangleArray class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 20:56'!
contentsClass
	^B3DIndexedTriangle! !
B3DIndexedMesh subclass: #B3DIndexedTriangleMesh
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DIndexedTriangleMesh methodsFor: 'displaying' stamp: 'ar 11/7/1999 18:35'!
renderOn: aRenderer
	self hasVertexColors ifTrue:[
		aRenderer trackAmbientColor: true.
		aRenderer trackDiffuseColor: true].
	^aRenderer
		drawIndexedTriangles: faces
			vertices: vertices
			normals: vtxNormals
			colors: vtxColors
			texCoords: vtxTexCoords.! !


!B3DIndexedTriangleMesh methodsFor: 'private' stamp: 'ar 2/8/1999 02:15'!
sampleRect: n
	"B3DIndexedQuadMesh new sampleRect"
	| vtx face |
	vtx _ WriteStream on: (B3DVector3Array new).
	n negated to: n do:[:x|
		n negated to: n do:[:y|
			vtx nextPut: (B3DVector3 x: x y: y z: 0) /= n asFloat.
		].
	].
	vertices _ vtx contents.
	vtxNormals _ B3DVector3Array new: (2*n+1) squared.
	1 to: vtxNormals size do:[:i| vtxNormals at: i put: (0@0@-1)].
	faces _ B3DIndexedTriangleArray new: (2*n) squared.
	0 to: 2*n-1 do:[:i|
		1 to: 2*n do:[:j|
			face _ B3DIndexedTriangle 
						with: (i*(2*n+1)+j)
						with: (i*(2*n+1)+j+1)
						with: (i+1*(2*n+1)+j+1)
						"with: (i+1*(2*n+1)+j)".
			faces at: i*2*n+j put: face.
			"face _ B3DIndexedTriangle 
						with: (i*(2*n+1)+j)
						with: (i*(2*n+1)+j+1)
						with: (i+1*(2*n+1)+j+1)
						with: (i+1*(2*n+1)+j).
			"
		]].! !


!B3DIndexedTriangleMesh methodsFor: 'fan creation' stamp: 'ar 2/8/1999 06:42'!
makeTriangleFans
	"Re-arrange the triangles so that they represent triangle fans."
	| vtxDict avgFacesPerVertex todo done maxShared maxSharedIndex newOrder sharedAssoc |
	"Compute the average size of faces per vertex (strange measure isn't it ;-)"
	avgFacesPerVertex _ faces size // vertices size + 3. "So we cover 99% of all cases"
	"vtxDict contains vertexIndex->(OrderedCollection of: IndexedFace)"
	vtxDict _ OrderedCollection new: vertices size.
	"Add all the vertex indexes. The set is larger than necessary to avoid collisions."
	1 to: vertices size do:[:i| vtxDict add: i -> (IdentitySet new: avgFacesPerVertex * 3)].
	"Go over all faces and add the face to all its vertices. Also store the faces in the toGo list."
	todo _ IdentitySet new: faces size * 3.
	done _ IdentitySet new: faces size * 3.
	faces do:[:iFace| 
		todo add: iFace.
		(vtxDict at: iFace p1Index) value add: iFace.
		(vtxDict at: iFace p2Index) value add: iFace.
		(vtxDict at: iFace p3Index) value add: iFace].
	"Now start creating the fans"
	[todo isEmpty] whileFalse:[
		"Let's assume that this method is not called in real-time 
		and spend some time to find the vertex with most shared faces"
		maxShared _ 0.
		maxSharedIndex _ nil.
		vtxDict doWithIndex:[:assoc :index| assoc value size > maxShared
			ifTrue:[maxShared _ assoc value size.
					maxSharedIndex _ index]].
		maxSharedIndex = nil ifTrue:[^self error:'No shared vertices found'].
		"Now re-arrange the faces around the shared vertex"
		sharedAssoc _ vtxDict at: maxSharedIndex.
		newOrder _ self reArrangeFanFaces: sharedAssoc value around: sharedAssoc key from: todo into: done.
		"Remove re-arranged faces"
		newOrder do:[:iFace|
			(done includes: iFace) ifTrue:[self halt].
			todo remove: iFace.
			done add: iFace.
			(vtxDict at: iFace p1Index) value remove: iFace ifAbsent:[].
			(vtxDict at: iFace p2Index) value remove: iFace ifAbsent:[].
			(vtxDict at: iFace p3Index) value remove: iFace ifAbsent:[]].
		false ifTrue:[
		"Remove the shared index if no more faces left."
		sharedAssoc value isEmpty ifTrue:[
			vtxDict swap: maxSharedIndex with: vtxDict size.	"Optimized removal ;-)"
			vtxDict removeLast].
		].
	].! !

!B3DIndexedTriangleMesh methodsFor: 'fan creation' stamp: 'ar 2/8/1999 06:38'!
reArrangeFanFaces: sharedFaces around: maxSharedIndex from: todo into: done
	"Re-arrange the faces in sharedFaces to form a triangle fan.
	Avoid inplace-reversal of the triangles in doneList -- they have been arranged already"
	| out next nextIndex prevIndex index |
	out _ OrderedCollection new: sharedFaces size * 2.
	next _ sharedFaces detect:[:any| true].
	sharedFaces remove: next.
	out addLast: next.
	nextIndex _ next p1Index.
	nextIndex = maxSharedIndex ifTrue:[nextIndex _ next p2Index].
	prevIndex _ next p3Index.
	(prevIndex = maxSharedIndex) ifTrue:[prevIndex _ next p2Index].
	"Search forward"
	[next _ sharedFaces detect:[:iFace| iFace includesIndex: nextIndex] ifNone:[nil].
	next notNil] whileTrue:[
		sharedFaces remove: next.
		out addLast: next.
		index _ next p1Index.
		(index = maxSharedIndex or:[index = nextIndex]) ifTrue:[
			index _ next p2Index.
			(index = maxSharedIndex or:[index = nextIndex]) 
				ifTrue:[index _ next p3Index]].
		nextIndex _ index].
	"Search backwards"
	nextIndex _ prevIndex.
	[next _ sharedFaces detect:[:iFace| iFace includesIndex: nextIndex] ifNone:[nil].
	next notNil] whileTrue:[
		sharedFaces remove: next.
		out addFirst: next.
		index _ next p1Index.
		(index = maxSharedIndex or:[index = nextIndex]) ifTrue:[
			index _ next p2Index.
			(index = maxSharedIndex or:[index = nextIndex]) 
				ifTrue:[index _ next p3Index]].
		nextIndex _ index].
	^out! !
B3DFloatArray variableWordSubclass: #B3DInplaceArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!

!B3DInplaceArray methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:49'!
at: index
	"Return the primitive vertex at the given index"
	| vtx |
	(index < 1 or:[index > self size]) ifTrue:[^self errorSubscriptBounds: index].
	vtx _ self contentsClass new.
	vtx replaceFrom: 1 to: vtx size with: self startingAt: index - 1 * self contentsSize + 1.
	^vtx! !

!B3DInplaceArray methodsFor: 'accessing' stamp: 'ar 2/6/1999 00:12'!
at: index put: anObject
	"Store the object at the given index in the receiver"
	| idx |
	(index < 1 or:[index > self size]) ifTrue:[^self errorSubscriptBounds: index].
	idx _ index - 1 * self contentsSize.
	self privateReplaceFrom: idx+1 to: idx + self contentsSize with: anObject startingAt: 1.
	^anObject! !

!B3DInplaceArray methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:48'!
contentsClass
	^self class contentsClass! !

!B3DInplaceArray methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:48'!
contentsSize
	^self contentsClass numElements! !

!B3DInplaceArray methodsFor: 'accessing' stamp: 'ar 2/5/1999 22:49'!
size
	"Return the number of primitive vertices that can be stored in the receiver"
	^self basicSize // self contentsSize! !


!B3DInplaceArray methodsFor: 'copying' stamp: 'ar 2/7/1999 19:48'!
copyFrom: start to: stop 
	"Answer a copy of a subset of the receiver, starting from element at 
	index start until element at index stop."

	| newSize |
	newSize _ stop - start + 1.
	^(self species new: newSize)
		replaceFrom: 1
		to: newSize
		with: self
		startingAt: start! !


!B3DInplaceArray methodsFor: 'private' stamp: 'ar 2/6/1999 00:39'!
privateReplaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	start to: stop do:[:i|
		self basicAt: i put: (replacement at: i - start + repStart).
	].! !

!B3DInplaceArray methodsFor: 'private' stamp: 'ar 2/7/1999 19:46'!
replaceFrom: start to: stop with: replacement startingAt: repStart
	| max |
	max _ (replacement size - repStart) min: stop-start.
	start to: start+max do:[:i|
		self at: i put: (replacement at: i - start + repStart).
	].! !


!B3DInplaceArray methodsFor: 'enumerating' stamp: 'ar 2/6/1999 00:37'!
do: aBlock
	"Overridden to store the (possibly) modified argument back"
	| obj |
	1 to: self size do:[:index|
		obj _ self at: index.
		aBlock value: obj.
		self at: index put: obj].! !

!B3DInplaceArray methodsFor: 'enumerating' stamp: 'ar 2/6/1999 00:37'!
readOnlyDo: aBlock
	^super do: aBlock! !

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

B3DInplaceArray class
	instanceVariableNames: ''!

!B3DInplaceArray class methodsFor: 'instance creation' stamp: 'ar 2/5/1999 22:48'!
contentsClass
	^self subclassResponsibility! !

!B3DInplaceArray class methodsFor: 'instance creation' stamp: 'ar 2/5/1999 22:49'!
contentsSize
	^self contentsClass numElements! !

!B3DInplaceArray class methodsFor: 'instance creation' stamp: 'ar 2/5/1999 22:49'!
new: n
	^super new: self contentsSize*n! !
B3DMultiMesh subclass: #B3DInterpolatedMesh
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DInterpolatedMesh methodsFor: 'initialize' stamp: 'ar 8/31/2000 19:36'!
initialize
	index _ 1.! !


!B3DInterpolatedMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 20:02'!
animationParameter
	^index-1 asFloat / meshes size asFloat! !

!B3DInterpolatedMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 20:11'!
animationParameter: param
	index _ ((param \\ 1.0) * (meshes size-1)) asInteger + 1.! !

!B3DInterpolatedMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 23:19'!
boundingBox
	| box origin corner |
	box _ meshes first boundingBox.
	origin _ box origin.	corner _ box corner.
	2 to: meshes size do:[:i|
		box _ (meshes at: i) boundingBox.
		origin _ origin min: box origin.
		corner _ corner max: box corner.
	].
	^Rectangle origin: origin corner: corner! !


!B3DInterpolatedMesh methodsFor: 'displaying' stamp: 'ar 8/31/2000 19:43'!
renderOn: aRenderer
	^(meshes at: index) renderOn: aRenderer! !
B3DFloatArray variableWordSubclass: #B3DLightAttenuation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!
!B3DLightAttenuation commentStamp: '<historical>' prior: 0!
I represent the attenuation for any given light source, e.g., how the intensity of the light is reduced with increasing distance from the object. I consist of three parts, a constant part, a linear part and a squared part. The resulting intensity for any given distance d is computed by:

	intensity _ 1.0 / (constantPart + (distance * linearPart) + (distance^2 * squaredPart)).
!


!B3DLightAttenuation methodsFor: 'initialize' stamp: 'ar 2/7/1999 19:02'!
constant: constantFactor linear: linearFactor squared: squaredFactor
	self constantPart: constantFactor.
	self linearPart: linearFactor.
	self squaredPart: squaredFactor.! !


!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:44'!
constantPart
	^self floatAt: 1! !

!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:45'!
constantPart: aNumber
	self floatAt: 1 put: aNumber! !

!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:45'!
linearPart
	^self floatAt: 2! !

!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:45'!
linearPart: aNumber
	self floatAt: 2 put: aNumber! !

!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:45'!
squaredPart
	^self floatAt: 3! !

!B3DLightAttenuation methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:45'!
squaredPart: aNumber
	self floatAt: 3 put: aNumber! !


!B3DLightAttenuation methodsFor: 'lighting' stamp: 'ar 2/6/1999 18:44'!
computeAttenuationFor: distance
	"Compute the light attenuation for the given distance"
	^1.0 / (self constantPart + 
			(distance * (self linearPart + 
				(distance * self squaredPart))))! !


!B3DLightAttenuation methodsFor: 'testing' stamp: 'ar 2/15/1999 21:58'!
isIdentity
	"Return true if the attenuation results in a constant lighting"
	^self constantPart = 1.0
		and:[self linearPart = 0.0
			and:[self squaredPart = 0.0]]! !

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

B3DLightAttenuation class
	instanceVariableNames: ''!

!B3DLightAttenuation class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 19:01'!
constant: constantFactor linear: linearFactor squared: squaredFactor
	^self new constant: constantFactor linear: linearFactor squared: squaredFactor! !

!B3DLightAttenuation class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 18:46'!
numElements
	^3! !
Object subclass: #B3DLightSource
	instanceVariableNames: 'lightColor '
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Lights'!

!B3DLightSource methodsFor: 'shading' stamp: 'ar 2/7/1999 16:51'!
computeAttenuationFor: distance
	^self subclassResponsibility! !

!B3DLightSource methodsFor: 'shading' stamp: 'ar 2/7/1999 16:51'!
computeDirectionTo: aB3DPrimitiveVertex
	^self subclassResponsibility! !

!B3DLightSource methodsFor: 'shading' stamp: 'ar 2/15/1999 02:26'!
computeSpotFactor: light2Vertex
	"Compute the spot factor for a spot light"
	| lightDirection cosAngle minCos deltaCos maxCos |
	lightDirection _ self direction.
	cosAngle _ (lightDirection dot: light2Vertex) negated.
	(cosAngle < (minCos _ self hotSpotMinCosine)) ifTrue:[^0.0].
	maxCos _ self hotSpotMaxCosine.
"	maxCos = 1.0 ifFalse:["
		deltaCos _ self hotSpotDeltaCosine.
		deltaCos <= 0.00001 ifTrue:[
			"No delta -- a sharp boundary between on and off.
			Since off has already been determined above, we are on"
			^1.0].
		"Scale the angle to 0/1 range"
		cosAngle _ (cosAngle - minCos) / deltaCos.
		self flag: #TODO. "Don't scale by (maxCos - minCos)"
"	]."
	self flag: #TODO. "Use table lookup for spot exponent"
	^cosAngle raisedTo: self spotExponent! !

!B3DLightSource methodsFor: 'shading' stamp: 'ar 2/15/1999 03:55'!
shadeVertexBuffer: vb with: aMaterial into: colorArray
	"This is the generic shading function similar to the primitive.
	Subclasses may implement optimized versions but should evaluate
	exactly to the same value as in here if they are to be converted into
	B3DPrimitiveLights."
	| color vtxArray ambientColor vtx direction distance scale cosAngle diffusePart specularPart specDir specularFactor |
	self flag: #b3dPrimitive.
	vtxArray _ vb vertexArray.
	(self hasAmbientPart and:[vb trackAmbientColor not])
		ifTrue:[ambientColor _ aMaterial ambientPart * lightColor ambientPart].
	(self hasDiffusePart and:[vb trackDiffuseColor not])
		ifTrue:[diffusePart _ aMaterial diffusePart].
	(self hasSpecularPart and:[vb trackSpecularColor not])
		ifTrue:[specularPart _ aMaterial specularPart].
	1 to: vb vertexCount do:[:i|
		vtx _ vtxArray at: i.
		color _ colorArray at: i.

		"Compute the direction and distance of light source from vertex"
		direction _ self computeDirectionTo: vtx.
		distance _ direction length.
		(distance = 0.0 or:[distance = 1.0]) ifFalse:[direction /= distance negated].

		"Compute the attenuation for the given distance"
		self isAttenuated
			ifTrue:[scale _ self computeAttenuationFor: distance]
			ifFalse:[scale _ 1.0].

		"Compute spot light factor"
		self hasSpot
			ifTrue:[scale _ scale * (self computeSpotFactor: direction)].

		"Compute ambient part"
		self hasAmbientPart ifTrue:[
			vb trackAmbientColor 
				ifTrue:[ambientColor _ vtx b3dColor * lightColor ambientPart].
			color += (ambientColor * scale).
		].

		"Compute the diffuse part of the light"
		self hasDiffusePart ifTrue:[
			"Compute angle from light->vertex to vertex normal"
			cosAngle _ vtx normal dot: direction.
			"For one-sided lighting negate cosAngle if necessary"
			(vb twoSidedLighting not and:[cosAngle < 0.0]) 
				ifTrue:[cosAngle _ 0.0 - cosAngle].
			"For two-sided lighting check if cosAngle > 0.0 meaning that it is a front face"
			cosAngle > 0.0 ifTrue:[
				vb trackDiffuseColor ifTrue:[diffusePart _ vtx b3dColor].
				color += (diffusePart * lightColor diffusePart * (cosAngle * scale)).
			].
		].

		"Compute specular part of the light"
		(self hasSpecularPart and:[aMaterial shininess > 0.0]) ifTrue:[
			vb useLocalViewer 
				ifTrue:[specDir _ direction - vtx position safelyNormalized]
				ifFalse:[specDir _ direction - (0@0@1.0)].
			cosAngle _ vtx normal dot: specDir.
			cosAngle > 0.0 ifTrue:[
				"Normalize the angle"
				cosAngle _ cosAngle / specDir length.
				"cosAngle should be somewhere between 0 and 1.
				If not, then the vertex normal was not normalized"
				cosAngle > 1.0 ifTrue:[
					specularFactor _ cosAngle raisedTo: aMaterial shininess.
				] ifFalse:[
					self flag: #TODO. "Use table lookup later"
					specularFactor _ cosAngle raisedTo: self shininess.
				].
				color += (specularPart * lightColor specularPart * specularFactor).
			].
		].
		self flag: #TODO. "Check specular part"
		colorArray at: i put: color.
	].! !


!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:17'!
direction
	"If the light is directional, return the NORMALIZED direction of the light"
	^B3DVector3 zero! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:28'!
hotSpotDeltaCosine
	"Return the cosine value of the delta radius of a spot light (the fall off region)"
	^self hotSpotMaxCosine - self hotSpotMinCosine! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:27'!
hotSpotMaxCosine
	"Return the cosine value of the outer radius of a spot light (the unlit region)"
	^0.0! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:26'!
hotSpotMinCosine
	"Return the cosine value of the inner radius of a spot light (the fully lit region)"
	^0.0! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/8/1999 16:53'!
lightColor
	^lightColor! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ar 2/8/1999 16:53'!
lightColor: aMaterialColor
	lightColor _ aMaterialColor! !

!B3DLightSource methodsFor: 'accessing' stamp: 'ti 3/27/2000 14:21'!
spotExponent
	"Return the exponent to be used for the spot fall off computation"
	^1.0! !


!B3DLightSource methodsFor: 'testing' stamp: 'ar 2/7/1999 17:22'!
hasAmbientPart
	"Return true if the receiver contains an ambient part in its color"
	^true! !

!B3DLightSource methodsFor: 'testing' stamp: 'ar 2/15/1999 23:07'!
hasDiffusePart
	"Return true if the receiver contains a diffuse part in its color"
	^true! !

!B3DLightSource methodsFor: 'testing' stamp: 'ar 2/15/1999 23:07'!
hasSpecularPart
	"Return true if the receiver contains a specular part in its color"
	^true! !

!B3DLightSource methodsFor: 'testing' stamp: 'ar 2/7/1999 18:52'!
hasSpot
	"Return true if the receiver has a hot spot."
	^false! !

!B3DLightSource methodsFor: 'testing' stamp: 'ar 2/7/1999 17:27'!
isAttenuated
	"Return true if the receiver contains an attenuation.
	If so, #computeAttenuationFor: must return the attenuation for the given distance."
	^true! !


!B3DLightSource methodsFor: 'converting' stamp: 'ar 2/7/1999 06:45'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight that can be handled by the shader primitive directly. Light sources that cannot be represented as primitive should return nil. This will result in the callback of #shadeVertexBuffer from the shader."
	^nil! !

!B3DLightSource methodsFor: 'converting' stamp: 'ar 2/8/1999 01:29'!
transformedBy: aTransformer
	^self clone! !


!B3DLightSource methodsFor: 'private' stamp: 'ar 2/7/1999 16:37'!
setColor: aColor
	lightColor _ B3DMaterialColor new.
	lightColor ambientPart: aColor.
	lightColor diffusePart: aColor.
	lightColor specularPart: aColor.! !

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

B3DLightSource class
	instanceVariableNames: ''!

!B3DLightSource class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 16:09'!
color: aColor
	^self new setColor: aColor.! !
B3DMaterialColor variableWordSubclass: #B3DMaterial
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DMaterial methodsFor: 'initialize' stamp: 'ar 2/16/1999 03:05'!
from3DS: aDictionary
	self ambientPart: (aDictionary at: #ambient ifAbsent:[B3DColor4 r: 0.0 g: 0.0 b: 0.0 a: 1.0]).
	self diffusePart: (aDictionary at: #diffuse ifAbsent:[B3DColor4 r: 0.0 g: 0.0 b: 0.0 a: 1.0]).
	self specularPart: (aDictionary at: #specular ifAbsent:[B3DColor4 r: 0.0 g: 0.0 b: 0.0 a: 1.0]).
	(aDictionary includesKey: #textureName) 
		ifTrue:[^(aDictionary at: #textureName) -> self].! !


!B3DMaterial methodsFor: 'accessing' stamp: 'ar 2/8/1999 00:54'!
emission
	^B3DColor4
		r: self emissionRed
		g: self emissionGreen
		b: self emissionBlue
		a: self emissionAlpha! !

!B3DMaterial methodsFor: 'accessing' stamp: 'ar 2/8/1999 00:53'!
emission: aColor
	self emissionRed: aColor red.
	self emissionGreen: aColor green.
	self emissionBlue: aColor blue.
	self emissionAlpha: aColor alpha.! !

!B3DMaterial methodsFor: 'accessing' stamp: 'ar 2/8/1999 00:58'!
shininess
	^self floatAt: 17! !

!B3DMaterial methodsFor: 'accessing' stamp: 'ar 2/8/1999 00:59'!
shininess: aFloat
	^self floatAt: 17 put: (aFloat max: 0.0).! !


!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:58'!
emissionAlpha
	^self floatAt: 16! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:59'!
emissionAlpha: aFloat
	self floatAt: 16 put: aFloat! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:58'!
emissionBlue
	^self floatAt: 15! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:59'!
emissionBlue: aFloat
	self floatAt: 15 put: aFloat! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:58'!
emissionGreen
	^self floatAt: 14! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:59'!
emissionGreen: aFloat
	self floatAt: 14 put: aFloat! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:58'!
emissionRed
	^self floatAt: 13! !

!B3DMaterial methodsFor: 'element access' stamp: 'ar 2/8/1999 00:59'!
emissionRed: aFloat
	self floatAt: 13 put: aFloat! !

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

B3DMaterial class
	instanceVariableNames: ''!

!B3DMaterial class methodsFor: 'instance creation' stamp: 'ar 2/8/1999 01:01'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !

!B3DMaterial class methodsFor: 'instance creation' stamp: 'ar 2/8/1999 01:00'!
numElements
	^17! !
B3DFloatArray variableWordSubclass: #B3DMaterialColor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:58'!
ambientPart
	^B3DColor4
		r: self ambientRed
		g: self ambientGreen
		b: self ambientBlue
		a: self ambientAlpha! !

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 19:00'!
ambientPart: aColor
	self ambientRed: aColor red.
	self ambientGreen: aColor green.
	self ambientBlue: aColor blue.
	self ambientAlpha: aColor alpha.! !

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:58'!
diffusePart
	^B3DColor4
		r: self diffuseRed
		g: self diffuseGreen
		b: self diffuseBlue
		a: self diffuseAlpha! !

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 19:00'!
diffusePart: aColor
	self diffuseRed: aColor red.
	self diffuseGreen: aColor green.
	self diffuseBlue: aColor blue.
	self diffuseAlpha: aColor alpha.! !

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 18:59'!
specularPart
	^B3DColor4
		r: self specularRed
		g: self specularGreen
		b: self specularBlue
		a: self specularAlpha! !

!B3DMaterialColor methodsFor: 'accessing' stamp: 'ar 2/6/1999 19:01'!
specularPart: aColor
	self specularRed: aColor red.
	self specularGreen: aColor green.
	self specularBlue: aColor blue.
	self specularAlpha: aColor alpha.! !


!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
ambientAlpha
	^self floatAt: 4! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
ambientAlpha: aFloat
	^self floatAt: 4 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
ambientBlue
	^self floatAt: 3! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
ambientBlue: aFloat
	^self floatAt: 3 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
ambientGreen
	^self floatAt: 2! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
ambientGreen: aFloat
	^self floatAt: 2 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
ambientRed
	^self floatAt: 1! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
ambientRed: aFloat
	^self floatAt: 1 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
diffuseAlpha
	^self floatAt: 8! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
diffuseAlpha: aFloat
	^self floatAt: 8 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
diffuseBlue
	^self floatAt: 7! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
diffuseBlue: aFloat
	^self floatAt: 7 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
diffuseGreen
	^self floatAt: 6! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
diffuseGreen: aFloat
	^self floatAt: 6 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:01'!
diffuseRed
	^self floatAt: 5! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
diffuseRed: aFloat
	^self floatAt: 5 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
specularAlpha
	^self floatAt: 12! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
specularAlpha: aFloat
	^self floatAt: 12 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
specularBlue
	^self floatAt: 11! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:03'!
specularBlue: aFloat
	^self floatAt: 11 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
specularGreen
	^self floatAt: 10! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:04'!
specularGreen: aFloat
	^self floatAt: 10 put: aFloat! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:02'!
specularRed
	^self floatAt: 9! !

!B3DMaterialColor methodsFor: 'element access' stamp: 'ar 2/6/1999 19:04'!
specularRed: aFloat
	^self floatAt: 9 put: aFloat! !


!B3DMaterialColor methodsFor: 'private' stamp: 'ar 2/7/1999 18:41'!
setColor: aColor
	self ambientPart: aColor.
	self diffusePart: aColor.
	self specularPart: aColor.! !

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

B3DMaterialColor class
	instanceVariableNames: ''!

!B3DMaterialColor class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 18:41'!
color: aColor
	^self new setColor: aColor! !

!B3DMaterialColor class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 19:04'!
numElements
	^12! !
B3DFloatArray variableWordSubclass: #B3DMatrix4x4
	instanceVariableNames: ''
	classVariableNames: 'B3DIdentityMatrix B3DZeroMatrix '
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DMatrix4x4 commentStamp: '<historical>' prior: 0!
I represent a general 4x4 transformation matrix commonly used in computer graphics.!


!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:26'!
setBSplineBase
	"Set the receiver to the BSpline base matrix"
	"for further information see:
		Foley, van Dam, Feiner, Hughes
		'Computer Graphics: Principles and Practice'
		Addison-Wesley Publishing Company
		Second Edition, pp. 505"
	self
		a11: -1.0 / 6.0;	a12: 3.0 / 6.0;	a13: -3.0 / 6.0;	a14: 1.0 / 6.0;
		a21: 3.0 / 6.0;	a22: -6.0 / 6.0;	a23: 3.0 / 6.0;	a24: 0.0 / 6.0;
		a31: -3.0 / 6.0;	a32: 0.0 / 6.0;	a33: 3.0 / 6.0;	a34: 0.0 / 6.0;
		a41: 1.0 / 6.0;	a42: 4.0 / 6.0;	a43: 1.0 / 6.0;	a44: 0.0 / 6.0
! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:26'!
setBetaSplineBaseBias: beta1 tension: beta2
	"Set the receiver to the betaSpline base matrix 
	if beta1=1 and beta2=0 then the bSpline base matrix will be returned"
	"for further information see:
		Foley, van Dam, Feiner, Hughes
		'Computer Graphics: Principles and Practice'
		Addison-Wesley Publishing Company
		Second Edition, pp. 505"
	| b12 b13 delta |
	b12 := beta1 * beta1.
	b13 := beta1 * b12.
	delta := 1.0 / (beta2 + (2.0 * b13) + 4.0 * (b12 + beta1) +2.0).
	
	self
		a11: delta * -2.0 * b13;
		a12: delta * 2.0 * (beta2 + b13 + b12 + beta1);
		a13: delta * -2.0 * (beta2 + b12 + beta1 + 1.0);
		a14: delta * 2.0;
		a21: delta * 6.0 * b13;
		a22: delta * -3.0 * (beta2 + (2.0 * (b13 + b12)));
		a23: delta * 3.0 * (beta2 + (2.0 * b12));
		a24: 0.0;
		a31: delta * -6.0 * b13;
		a32: delta * 6.0 * (b13 - beta1);
		a33: delta * 6.0 * beta1;
		a34: 0.0;
		a41: delta * 2.0 * b13;
		a42: delta * (beta2 + 4.0 * (b12 + beta1));
		a43: delta * 2.0;
		a44: 0.0
! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:27'!
setBezierBase
	"Set the receiver to the bezier base matrix"
	"for further information see:
		Foley, van Dam, Feiner, Hughes
		'Computer Graphics: Principles and Practice'
		Addison-Wesley Publishing Company
		Second Edition, pp. 505"
	self
		a11: -1.0;		a12: 3.0;		a13: -3.0;	a14: 1.0;
		a21: 3.0;		a22: -6.0;	a23: 3.0;	a24: 0.0;
		a31: -3.0;	a32: 3.0;	a33: 0.0;	a34: 0.0;
		a41: 1.0;		a42: 0.0;	a43: 0.0;	a44: 0.0! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:27'!
setCardinalBase
	"Set the receiver to the cardinal spline base matrix - just catmull * 2"
	"for further information see:
		Foley, van Dam, Feiner, Hughes
		'Computer Graphics: Principles and Practice'
		Addison-Wesley Publishing Company
		Second Edition, pp. 505"
	self
		a11: -1.0;		a12: 3.0;		a13: -3.0;	a14: 1.0;
		a21: 2.0;		a22: -5.0;	a23: 4.0;	a24: -1.0;
		a31: -1.0;	a32: 0.0;	a33: 1.0;		a34: 0.0;
		a41: 0.0;		a42: 2.0;	a43: 0.0;	a44: 0.0
! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:27'!
setCatmullBase
	"Set the receiver to the Catmull-Rom base matrix"
	"for further information see:
		Foley, van Dam, Feiner, Hughes
		'Computer Graphics: Principles and Practice'
		Addison-Wesley Publishing Company
		Second Edition, pp. 505"
	self
		a11: -0.5;	a12: 1.5;		a13: -1.5;	a14: 0.5;
		a21: 1.0;		a22: -2.5;	a23: 2.0;	a24: -0.5;
		a31: -0.5;	a32: 0.0;	a33: 0.5;	a34: 0.0;
		a41: 0.0;		a42: 1.0;		a43: 0.0;	a44: 0.0
! !

!B3DMatrix4x4 methodsFor: 'initialize'!
setIdentity
	"Set the receiver to the identity matrix"
	self loadFrom: B3DIdentityMatrix! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/1/1999 21:27'!
setPolylineBase
	"Set the receiver to the polyline base matrix :)"
	self
		a11: 0.0;		a12: 0.0;		a13: 0.0;		a14: 0.0;
		a21: 0.0;		a22: 0.0;	a23: 0.0;	a24: 0.0;
		a31: 0.0;		a32: -1.0;	a33: 1.0;		a34: 0.0;
		a41: 0.0;		a42: 1.0;		a43: 0.0;	a44: 0.0
! !

!B3DMatrix4x4 methodsFor: 'initialize' stamp: 'ar 2/15/1999 02:55'!
setScale: aVector
	self 
		a11: aVector x;
		a22: aVector y;
		a33: aVector z! !

!B3DMatrix4x4 methodsFor: 'initialize'!
setTranslation: aVector
	self 
		a14: aVector x;
		a24: aVector y;
		a34: aVector z! !

!B3DMatrix4x4 methodsFor: 'initialize'!
setZero
	"Set the receiver to the zero matrix"
	self loadFrom: B3DZeroMatrix! !


!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a11
	"Return the element a11"
	^self at: 1! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a11: aNumber
	"Store the element a11"
	self at: 1 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a12
	"Return the element a12"
	^self at: 2! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a12: aNumber
	"Store the element a12"
	self at: 2 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a13
	"Return the element a13"
	^self at: 3! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a13: aNumber
	"Store the element a13"
	self at: 3 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a14
	"Return the element a14"
	^self at: 4! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a14: aNumber
	"Store the element a14"
	self at: 4 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a21
	"Return the element a21"
	^self at: 5! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a21: aNumber
	"Store the element a21"
	self at: 5 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a22
	"Return the element a22"
	^self at: 6! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a22: aNumber
	"Store the element a22"
	self at: 6 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a23
	"Return the element a23"
	^self at: 7! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a23: aNumber
	"Store the element a23"
	self at: 7 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a24
	"Return the element a24"
	^self at: 8! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a24: aNumber
	"Store the element a24"
	self at: 8 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a31
	"Return the element a31"
	^self at: 9! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a31: aNumber
	"Store the element a31"
	self at: 9 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a32
	"Return the element a32"
	^self at: 10! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a32: aNumber
	"Store the element a32"
	self at: 10 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a33
	"Return the element a33"
	^self at: 11! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a33: aNumber
	"Store the element a33"
	self at: 11 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a34
	"Return the element a34"
	^self at: 12! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a34: aNumber
	"Store the element a34"
	self at: 12 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a41
	"Return the element a41"
	^self at: 13! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a41: aNumber
	"Store the element a41"
	self at: 13 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a42
	"Return the element a42"
	^self at: 14! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a42: aNumber
	"Store the element a42"
	self at: 14 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a43
	"Return the element a43"
	^self at: 15! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a43: aNumber
	"Store the element a43"
	self at: 15 put: aNumber! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:29'!
a44
	"Return the element a44"
	^self at: 16! !

!B3DMatrix4x4 methodsFor: 'element-access' stamp: 'ar 2/1/1999 21:28'!
a44: aNumber
	"Store the element a44"
	self at: 16 put: aNumber! !


!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/25/1999 13:58'!
alternateRotation
	"Return the angular rotation around each axis of the matrix"

	| cp sp cy sy cr sr vAngles |

	vAngles _ B3DVector3 new.

	((self a13) = 0) ifTrue: [ ((self a33) >= 0)  ifTrue: [ vAngles at: 2 put: 0.
													  cr _ (self a11).
													  sr _ (self a12).
													  cp _ (self a33). ]
											 ifFalse: [ vAngles at: 2 put: (Float pi).
														cr _ (self a11) negated.
														sr _ (self a12) negated.
														cp _ (self a33) negated. ]
							]
					ifFalse: [
								vAngles at: 2 put: (((self a13) negated) arcTan: (self a33)).
								cy _ (vAngles at: 3) cos.
								sy _ (vAngles at: 3) sin.
								cr _ (cy * (self a11)) + (sy * (self a31)).
								sr _ (cy* (self a12)) + (sy * (self a32)).
								cp _ (cy * (self a33)) - (sy * (self a13)).
							].

	sp _ (self a23).
 
	vAngles at: 1 put: (sp arcTan: cp).
	vAngles at: 3 put: (sr arcTan: cr).

	vAngles at: 1 put: ((vAngles at: 1) radiansToDegrees).
	vAngles at: 2 put: ((vAngles at: 2) radiansToDegrees).
	vAngles at: 3 put: ((vAngles at: 3) radiansToDegrees).

	^ vAngles.
! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/11/1999 14:09'!
at: i at: j
	^ self at: ((i - 1) * 4 + j).
! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/11/1999 14:09'!
at: i at: j put: aValue
	^ self at: ((i - 1) * 4 + j) put: aValue.
! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/25/1999 13:58'!
rotation
	"Return the angular rotation around each axis of the matrix"

	| vRow1 vRow2 vRow3 vScale vShear vAngles vRowCross determinate |

	vRow1 _ self row1.
	vRow2 _ self row2.
	vRow3 _ self row3.

	vScale _ B3DVector3 new.
	vShear _ B3DVector3 new.
	vAngles _ B3DVector3 new.

	vScale at: 1 put: (vRow1 length).
	vRow1 normalize.
	vShear at: 1 put: (vRow1 dot: vRow2).
	vRow2 _ vRow2 + (vRow1 * ((vShear at: 1) negated)).

	vScale at: 2 put: (vRow2 length).
	vRow2 normalize.
	vShear at: 1 put: ((vShear at: 1) / (vScale at: 2)).

	vShear at: 2 put: (vRow1 dot: vRow3).
	vRow3 _ vRow3 + (vRow1 * ((vShear at: 2) negated)).

	vShear at: 3 put: (vRow2 dot: vRow3).
	vRow3 _ vRow3 + (vRow2 * ((vShear at: 3) negated)).

	vScale at: 3 put: (vRow3 length).
	vRow3 normalize.

	vShear at: 2 put: ((vShear at: 2) / (vScale at: 3)).
	vShear at: 3 put: ((vShear at: 3) / (vScale at: 3)).

	vRowCross _ vRow2 cross: vRow3.
	determinate _ vRow1 dot: vRowCross.

	(determinate < 0.0) ifTrue: [ vRow1 _ vRow1 negated.
								vRow2 _ vRow2 negated.
								vRow3 _ vRow3 negated.
								vScale _ vScale negated. ].

	vAngles at: 2 put: ((vRow1 at: 3) negated) arcSin.

	(((vAngles at: 2) cos) ~= 0.0) 
								ifTrue: [ vAngles at: 1 put:
												((vRow2 at: 3) arcTan: (vRow3 at: 3)).
										  vAngles at: 3 put:
												((vRow1 at: 2) arcTan: (vRow1 at: 1)). ]
								ifFalse: [ vAngles at: 1 put:
												((vRow2 at: 1) arcTan: (vRow2 at: 2)).
										  vAngles at: 3 put: 0.0 ].


	vAngles at: 1 put: ((vAngles at: 1) radiansToDegrees).
	vAngles at: 2 put: ((vAngles at: 2) radiansToDegrees).
	vAngles at: 3 put: ((vAngles at: 3) radiansToDegrees).

	^ vAngles.
! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/24/1999 09:46'!
rotation: aVector
	| xRot yRot zRot cosPitch sinPitch cosYaw sinYaw cosRoll sinRoll |

	xRot _ (aVector x) degreesToRadians.
	yRot _ (aVector y) degreesToRadians.
	zRot _ (aVector z) degreesToRadians.

	cosPitch _ xRot cos.
	sinPitch _ xRot sin.
	cosYaw _ yRot cos.
	sinYaw _ yRot sin.
	cosRoll _ zRot cos.
	sinRoll _ zRot sin.

	self a11: (cosRoll*cosYaw).
	self a12: (sinRoll*cosYaw).
	self a13: (sinYaw negated).

	self a21: ((cosRoll*sinYaw*sinPitch) - (sinRoll*cosPitch)).
	self a22: ((cosRoll*cosPitch) + (sinRoll*sinYaw*sinPitch)).
	self a23: (cosYaw*sinPitch).
	self a31: ((cosRoll*sinYaw*cosPitch) + (sinRoll*sinPitch)).
	self a32: ((sinRoll*sinYaw*cosPitch) - (cosRoll*sinPitch)).
	self a33: (cosYaw*cosPitch).

	^ self.
! !

!B3DMatrix4x4 methodsFor: 'accessing'!
rotation: anAngle around: aVector3
	"set up a rotation matrix around the direction aVector3"

	self loadFrom: (B3DRotation angle: anAngle axis: aVector3) asMatrix4x4! !

!B3DMatrix4x4 methodsFor: 'accessing'!
rotation: anAngle aroundX: xValue y: yValue z: zValue
	"set up a rotation matrix around the direction x/y/z"
	^self rotation: anAngle around:(B3DVector3 with: xValue with: yValue with: zValue)! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:34'!
rotationAroundX: anAngle
	| rad s c |
	rad := anAngle degreesToRadians.
	s := rad sin.
	c := rad cos.
	self a22: c.
	self a23: s negated.
	self a33: c.
	self a32: s.
	^self! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:34'!
rotationAroundY: anAngle
	| rad s c |
	rad := anAngle degreesToRadians.
	s := rad sin.
	c := rad cos.
	self a11: c.
	self a13: s.
	self a33: c.
	self a31: s negated.
	^self! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:35'!
rotationAroundZ: anAngle
	| rad s c |
	rad := anAngle degreesToRadians.
	s := rad sin.
	c := rad cos.
	self a11: c.
	self a12: s negated.
	self a22: c.
	self a21: s.
	^self! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:35'!
scaling: aVector

	^self scalingX: aVector x y: aVector y z: aVector z! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:35'!
scalingX: xValue y: yValue z: zValue

	self a11: xValue.
	self a22: yValue.
	self a33: zValue.
	^self! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 4/16/1999 21:51'!
squaredDistanceFrom: aMatrix
	| sum |
	sum _ 0.0.
	1 to: 4 do:[:i|
		1 to: 4 do:[:j|
			sum _ sum + ((self at: i at: j) - (aMatrix at: i at: j)) squared]].
	^sum! !

!B3DMatrix4x4 methodsFor: 'accessing'!
translation

	^(B3DVector3 x: self a14 y: self a24 z: self a34)! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:36'!
translation: aVector

	^self translationX: aVector x y: aVector y z: aVector z! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:36'!
translationX: xValue y: yValue z: zValue

	self a14: xValue.
	self a24: yValue.
	self a34: zValue.
	^self! !

!B3DMatrix4x4 methodsFor: 'accessing' stamp: 'jsp 2/25/1999 13:58'!
trotation
	"Return the angular rotation around each axis of the matrix"

	| cp sp cy sy cr sr vAngles |

	vAngles _ B3DVector3 new.

	((self a13) = 0) ifTrue: [ ((self a33) >= 0)  ifTrue: [ vAngles at: 2 put: 0.
													  cr _ (self a11).
													  sr _ (self a12).
													  cp _ (self a33). ]
											 ifFalse: [ vAngles at: 2 put: (Float pi).
														cr _ (self a11) negated.
														sr _ (self a12) negated.
														cp _ (self a33) negated. ]
							]
					ifFalse: [
								vAngles at: 2 put: (((self a13) negated) arcTan: (self a33)).
								cy _ (vAngles at: 3) cos.
								sy _ (vAngles at: 3) sin.
								cr _ (cy * (self a11)) + (sy * (self a31)).
								sr _ (cy* (self a12)) + (sy * (self a32)).
								cp _ (cy * (self a33)) - (sy * (self a13)).
							].

	sp _ (self a23).
 
	vAngles at: 1 put: (sp arcTan: cp).
	vAngles at: 3 put: (sr arcTan: cr).

	vAngles at: 1 put: ((vAngles at: 1) radiansToDegrees).
	vAngles at: 2 put: ((vAngles at: 2) radiansToDegrees).
	vAngles at: 3 put: ((vAngles at: 3) radiansToDegrees).

	^ vAngles.
! !


!B3DMatrix4x4 methodsFor: 'arithmetic' stamp: 'ar 2/2/2001 15:47'!
+ aB3DMatrix
	"Optimized for Matrix/Matrix operations"
	<primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'>
	^super + aB3DMatrix! !

!B3DMatrix4x4 methodsFor: 'arithmetic' stamp: 'ar 2/2/2001 15:47'!
- aB3DMatrix
	"Optimized for Matrix/Matrix operations"
	<primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'>
	^super - aB3DMatrix! !


!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 11/7/2000 14:48'!
composeWith: m2
	"Perform a 4x4 matrix multiplication."
	^self composedWithLocal: m2.! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 2/15/1999 23:56'!
composedWithGlobal: aB3DMatrix4x4
	| result |
	result _ self class new.
	self privateTransformMatrix: aB3DMatrix4x4 with: self into: result.
	^result! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 2/15/1999 23:57'!
composedWithLocal: aB3DMatrix4x4
	| result |
	result _ self class new.
	self privateTransformMatrix: self with: aB3DMatrix4x4 into: result.
	^result! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 5/21/2000 16:34'!
inverseTransformation
	"Return the inverse matrix of the receiver."
	^self clone inplaceHouseHolderInvert.! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 11/7/2000 17:29'!
localDirToGlobal: aVector
	"Multiply direction vector with the receiver"
	| x y z rx ry rz |
	x := aVector x.
	y := aVector y.
	z := aVector z.

	rx := (x * self a11) + (y * self a12) + (z * self a13).
	ry := (x * self a21) + (y * self a22) + (z * self a23).
	rz := (x * self a31) + (y * self a32) + (z * self a33).

	^B3DVector3 x: rx y: ry z: rz! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 2/15/1999 23:50'!
localPointToGlobal: aVector
	"Multiply aVector (temporarily converted to 4D) with the receiver"
	| x y z rx ry rz rw |
	x := aVector x.
	y := aVector y.
	z := aVector z.

	rx := (x * self a11) + (y * self a12) + (z * self a13) + self a14.
	ry := (x * self a21) + (y * self a22) + (z * self a23) + self a24.
	rz := (x * self a31) + (y * self a32) + (z * self a33) + self a34.
	rw := (x * self a41) + (y * self a42) + (z * self a43) + self a44.

	^B3DVector3 x:(rx/rw) y: (ry/rw) z: (rz/rw)! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 2/7/1999 06:32'!
quickTransformV3ArrayFrom: srcArray to: dstArray
	"Transform the 3 element vertices from srcArray to dstArray.
	ASSUMPTION: a41 = a42 = a43 = 0.0 and a44 = 1.0"
	| a11 a12 a13 a14 a21 a22 a23 a24 a31 a32 a33 a34 x y z index |
	self flag: #b3dPrimitive.
	a11 _ self a11.	a12 _ self a12.	a13 _ self a13.	a14 _ self a14.
	a21 _ self a21.	a22 _ self a22.	a23 _ self a23.	a24 _ self a24.
	a31 _ self a31.	a32 _ self a32.	a33 _ self a33.	a34 _ self a34.
	1 to: srcArray size do:[:i|
		index _ i-1*3.
		x _ srcArray floatAt: index+1.
		y _ srcArray floatAt: index+2.
		z _ srcArray floatAt: index+3.
		dstArray floatAt: index+1 put: (a11*x) + (a12*y) + (a13*z) + a14.
		dstArray floatAt: index+2 put: (a21*x) + (a22*y) + (a23*z) + a24.
		dstArray floatAt: index+3 put: (a31*x) + (a32*y) + (a33*z) + a34.
	].
	^dstArray! !

!B3DMatrix4x4 methodsFor: 'transforming' stamp: 'ar 2/1/1999 21:42'!
transposed
	"Return a transposed copy of the receiver"
	| matrix |
	matrix := self class new.
	matrix 
		a11: self a11; a12: self a21; a13: self a31; a14: self a41;
		a21: self a12; a22: self a22; a23: self a32; a24: self a42;
		a31: self a13; a32: self a23; a33: self a33; a34: self a43;
		a41: self a14; a42: self a24; a43: self a34; a44: self a44.
	^matrix! !


!B3DMatrix4x4 methodsFor: 'double dispatching' stamp: 'ar 2/1/1999 21:49'!
printOn: aStream
	"Print the receiver on aStream"
	1 to: 4 do:[:r|
		1 to: 4 do:[:c| 
			(self at: r-1*4+c) printOn: aStream.
			aStream nextPut: Character space].
		(r < 4) ifTrue:[aStream nextPut: Character cr]].! !

!B3DMatrix4x4 methodsFor: 'double dispatching' stamp: 'ar 2/8/1999 20:11'!
productFromMatrix4x4: matrix
	"Multiply a 4x4 matrix with the receiver."
	| result |
	result := self class new.
	result a11: ((matrix a11 * self a11) + (matrix a12 * self a21) + 
				(matrix a13 * self a31) + (matrix a14 * self a41)).
	result a12: ((matrix a11 * self a12) + (matrix a12 * self a22) + 
				(matrix a13 * self a32) + (matrix a14 * self a42)).
	result a13: ((matrix a11 * self a13) + (matrix a12 * self a23) + 
				(matrix a13 * self a33) + (matrix a14 * self a43)).
	result a14: ((matrix a11 * self a14) + (matrix a12 * self a24) + 
				(matrix a13 * self a34) + (matrix a14 * self a44)).

	result a21: ((matrix a21 * self a11) + (matrix a22 * self a21) + 
				(matrix a23 * self a31) + (matrix a24 * self a41)).
	result a22: ((matrix a21 * self a12) + (matrix a22 * self a22) + 
				(matrix a23 * self a32) + (matrix a24 * self a42)).
	result a23: ((matrix a21 * self a13) + (matrix a22 * self a23) + 
				(matrix a23 * self a33) + (matrix a24 * self a43)).
	result a24: ((matrix a21 * self a14) + (matrix a22 * self a24) + 
				(matrix a23 * self a34) + (matrix a24 * self a44)).

	result a31: ((matrix a31 * self a11) + (matrix a32 * self a21) + 
				(matrix a33 * self a31) + (matrix a34 * self a41)).
	result a32: ((matrix a31 * self a12) + (matrix a32 * self a22) + 
				(matrix a33 * self a32) + (matrix a34 * self a42)).
	result a33: ((matrix a31 * self a13) + (matrix a32 * self a23) + 
				(matrix a33 * self a33) + (matrix a34 * self a43)).
	result a34: ((matrix a31 * self a14) + (matrix a32 * self a24) + 
				(matrix a33 * self a34) + (matrix a34 * self a44)).

	result a41: ((matrix a41 * self a11) + (matrix a42 * self a21) + 
				(matrix a43 * self a31) + (matrix a44 * self a41)).
	result a42: ((matrix a41 * self a12) + (matrix a42 * self a22) + 
				(matrix a43 * self a32) + (matrix a44 * self a42)).
	result a43: ((matrix a41 * self a13) + (matrix a42 * self a23) + 
				(matrix a43 * self a33) + (matrix a44 * self a43)).
	result a44: ((matrix a41 * self a14) + (matrix a42 * self a24) + 
				(matrix a43 * self a34) + (matrix a44 * self a44)).

	^result! !

!B3DMatrix4x4 methodsFor: 'double dispatching'!
productFromVector3: aVector3
	"Multiply aVector (temporarily converted to 4D) with the receiver"
	| x y z rx ry rz rw |
	x := aVector3 x.
	y := aVector3 y.
	z := aVector3 z.

	rx := (x * self a11) + (y * self a21) + (z * self a31) + self a41.
	ry := (x * self a12) + (y * self a22) + (z * self a32) + self a42.
	rz := (x * self a13) + (y * self a23) + (z * self a33) + self a43.
	rw := (x * self a14) + (y * self a24) + (z * self a34) + self a44.

	^B3DVector3 x:(rx/rw) y: (ry/rw) z: (rz/rw)! !

!B3DMatrix4x4 methodsFor: 'double dispatching'!
productFromVector4: aVector4
	"Multiply aVector with the receiver"
	| x y z w rx ry rz rw |
	x := aVector4 x.
	y := aVector4 y.
	z := aVector4 z.
	w := aVector4 w.

	rx := (x * self a11) + (y * self a21) + (z * self a31) + (w * self a41).
	ry := (x * self a12) + (y * self a22) + (z * self a32) + (w * self a42).
	rz := (x * self a13) + (y * self a23) + (z * self a33) + (w * self a43).
	rw := (x * self a14) + (y * self a24) + (z * self a34) + (w * self a44).

	^B3DVector4 x:rx y: ry z: rz w: rw! !


!B3DMatrix4x4 methodsFor: 'solving' stamp: 'ar 2/1/1999 21:50'!
inplaceDecomposeLU
	"Decompose the receiver in place by using gaussian elimination w/o pivot search"
	| x |
	1 to: 4 do:[:j|
		"i-th equation (row)"
		j+1 to: 4 do:[:i|
			x := (self at: i at: j) / (self at: j at: j).
			j to: 4 do:[:k|
				self at: i at: k put: (self at: i at: k) - ((self at: j at: k) * x)].
			self at: i at: j put: x]].
! !

!B3DMatrix4x4 methodsFor: 'solving' stamp: 'ar 5/22/2000 17:13'!
inplaceHouseHolderInvert
	"Solve the linear equation self * aVector = x by using HouseHolder's transformation.
	Note: This scheme is numerically better than using gaussian elimination even though it takes
	somewhat longer"
	| d x sigma beta sum s|
	<primitive:'b3dInplaceHouseHolderInvert' module:'Squeak3D'>
	x _ B3DMatrix4x4 identity.
	d _ B3DMatrix4x4 new.
	1 to: 4 do:[:j|
		sigma := 0.0.
		j to: 4 do:[:i| sigma := sigma + ((self at: i at: j) squared)].
		sigma isZero ifTrue:[^nil]. "matrix is singular"
		((self at: j at: j) < 0.0) 
			ifTrue:[ s:= sigma sqrt]
			ifFalse:[ s:= sigma sqrt negated].
		1 to: 4 do:[:r| d at: j at: r put: s].
		beta := 1.0 / ( s * (self at: j at: j) - sigma).
		self at: j at: j put: ((self at: j at: j) - s).
		"update remaining columns"
		j+1 to: 4 do:[:k|
			sum := 0.0.
			j to: 4 do:[:i| sum := sum + ((self at: i at: j) * (self at: i at: k))].
			sum := sum * beta.
			j to: 4 do:[:i| 
				self at: i at: k put: ((self at: i at: k) + ((self at: i at: j) * sum))]].
		"update vector"
		1 to: 4 do:[:r|
			sum := nil.
			j to: 4 do:[:i| 
				sum := sum isNil 
					ifTrue:[(x at: i at: r) * (self at: i at: j)] 
					ifFalse:[sum + ((x at: i at: r) * (self at: i at: j))]].
			sum := sum * beta.
			j to: 4 do:[:i| 
				x at: i at: r put:((x at: i at: r) + (sum * (self at: i at: j)))].
		].
	].
	"Now calculate result"
	1 to: 4 do:[:r|
		4 to: 1 by: -1 do:[:i|
			i+1 to: 4 do:[:j|
				x at: i at: r put: ((x at: i at: r) - ((x at: j at: r) * (self at: i at: j))) ].
			x at: i at: r put: ((x at: i at: r) / (d at: i at: r))].
	].
	self loadFrom: x.
	"Return receiver"! !

!B3DMatrix4x4 methodsFor: 'solving'!
inplaceHouseHolderTransform: aVector
	"Solve the linear equation self * aVector = x by using HouseHolder's transformation.
	Note: This scheme is numerically better than using gaussian elimination even though it takes
	somewhat longer"
	| d x sigma beta sum s|
	x := Array with: aVector x with: aVector y with: aVector z with: aVector w.
	d := Array new: 4.
	1 to: 4 do:[:j|
		sigma := 0.0.
		j to: 4 do:[:i| sigma := sigma + ((self at: i at: j) squared)].
		sigma isZero ifTrue:[^nil]. "matrix is singular"
		((self at: j at: j) < 0.0) 
			ifTrue:[ s:= d at: j put: (sigma sqrt)]
			ifFalse:[ s:= d at: j put: (sigma sqrt negated)].
		beta := 1.0 / ( s * (self at: j at: j) - sigma).
		self at: j at: j put: ((self at: j at: j) - s).
		"update remaining columns"
		j+1 to: 4 do:[:k|
			sum := 0.0.
			j to: 4 do:[:i| sum := sum + ((self at: i at: j) * (self at: i at: k))].
			sum := sum * beta.
			j to: 4 do:[:i| 
				self at: i at: k put: ((self at: i at: k) + ((self at: i at: j) * sum))]].
		"update vector"
		sum := nil.
		j to: 4 do:[:i| 
			sum := sum isNil 
				ifTrue:[(x at: i) * (self at: i at: j)] 
				ifFalse:[sum + ((x at: i) * (self at: i at: j))]].
		sum := sum * beta.
		j to: 4 do:[:i| 
			x at: i put:((x at: i) + (sum * (self at: i at: j)))].
	].
	"Now calculate result"
	4 to: 1 by: -1 do:[:i|
		i+1 to: 4 do:[:j|
			x at: i put: ((x at: i) - ((x at: j) * (self at: i at: j))) ].
		x at: i put: ((x at: i) / (d at: i))].
	^B3DVector4 x: (x at: 1) y: (x at: 2) z: (x at: 3) w: (x at: 4)
! !

!B3DMatrix4x4 methodsFor: 'solving' stamp: 'ar 2/1/1999 21:52'!
solve: aVector

	^self clone inplaceHouseHolderTransform: aVector
	"or:
	^self clone inplaceDecomposeLU solveLU: aVector
	"! !

!B3DMatrix4x4 methodsFor: 'solving'!
solveLU: aVector
	"Given a decomposed matrix using gaussian elimination solve the linear equations."
	| x v |
	v := Array with: aVector x with: aVector y with: aVector z with: aVector w.
	"L first"
	1 to: 4 do:[:i| "Top to bottom"
		x := 0.0.
		1 to: i-1 do:[:j|
			"From left to right w/o diagonal element"
			x := x + ((v at: j) * (self at: i at: j))].
		"No need to divide by the diagonal element - this is always 1.0 in L"
		v at: i put: (v at: i) - x].
	"Now U"
	4 to: 1 by: -1 do:[:i| "Bottom to top"
		x := 0.0.
		4 to: i+1 by: -1 do:[:j|
			"From right to left w/o diagonal element"
			x := x + ((v at: j) * (self at: i at: j))].
		"Divide by diagonal element"
		v at: i put: (v at: i) - x / (self at: i at: i)].
	^B3DVector4 x: (v at: 1) y: (v at: 2) z: (v at: 3) w: (v at: 4)
! !


!B3DMatrix4x4 methodsFor: 'comparing' stamp: 'ar 2/1/1999 21:53'!
squaredErrorDistanceTo: anotherMatrix
	| result temp |
	result := self - anotherMatrix.
	temp := 0.
	1 to: 4 do: [:i | 1 to: 4 do: [:j| temp := temp + ((result at: i-1*4+j) squared)]].
	^temp sqrt.! !


!B3DMatrix4x4 methodsFor: 'testing' stamp: 'ar 2/1/1999 21:54'!
isIdentity
	^self = B3DIdentityMatrix! !

!B3DMatrix4x4 methodsFor: 'testing' stamp: 'ar 2/1/1999 21:54'!
isZero
	^self = B3DZeroMatrix! !


!B3DMatrix4x4 methodsFor: 'converting'!
asMatrix4x4
	^self! !

!B3DMatrix4x4 methodsFor: 'converting' stamp: 'jsp 3/5/1999 15:31'!
asQuaternion
	"Convert the matrix to a quaternion"

	| x y z a a2 x2 y2 a4 |

	a2 _ 0.25 * (1.0 + (self a11) + (self a22) + (self a33)).

	(a2 > 0) ifTrue: [
						a _ a2 sqrt.
						a4 _ 4.0 * a.
						x _ ((self a32) - (self a23)) / a4.
						y _ ((self a13) - (self a31)) / a4.
						z _ ((self a21) - (self a12)) / a4.
					]
			ifFalse: [
						a _ 0.
						x2 _ -0.5 * ((self a22) + (self a33)).
						(x2 > 0) ifTrue: [
											x _ x2 sqrt.
											x2 _ 2 * x.
											y _ (self a21) / x2.
											z _ (self a31) / x2.
										]
								ifFalse: [
											x _ 0.
											y2 _ 0.5 * (1.0 - (self a33)).
											(y2 > 0) ifTrue: [
																y _ y2 sqrt.
																y2 _ 2 * y.
																z _ (self a32) / y2.
															]
													ifFalse: [
																y _ 0.0.
																z _ 1.0.
															]
										]
					].

	^ (B3DRotation a: a b: x c: y d: z).
! !


!B3DMatrix4x4 methodsFor: 'private' stamp: 'ar 11/7/2000 14:48'!
privateTransformMatrix: m1 with: m2 into: m3
	"Perform a 4x4 matrix multiplication
		m2 * m1 = m3
	being equal to first transforming points by m2 and then by m1.
	Note that m1 may be identical to m3.
	NOTE: The primitive implementation does NOT return m3 - and so don't we!!"
	| c1 c2 c3 c4 |
	<primitive: 'b3dTransformMatrixWithInto' module:'Squeak3D'>
	m2 == m3 ifTrue:[^self error:'Argument and result matrix identical'].
	c1 _ ((m1 a11 * m2 a11) + (m1 a12 * m2 a21) + 
				(m1 a13 * m2 a31) + (m1 a14 * m2 a41)).
	c2 _ ((m1 a11 * m2 a12) + (m1 a12 * m2 a22) + 
				(m1 a13 * m2 a32) + (m1 a14 * m2 a42)).
	c3 _ ((m1 a11 * m2 a13) + (m1 a12 * m2 a23) + 
				(m1 a13 * m2 a33) + (m1 a14 * m2 a43)).
	c4 _ ((m1 a11 * m2 a14) + (m1 a12 * m2 a24) + 
				(m1 a13 * m2 a34) + (m1 a14 * m2 a44)).

	m3 a11: c1; a12: c2; a13: c3; a14: c4.

	c1 _ ((m1 a21 * m2 a11) + (m1 a22 * m2 a21) + 
				(m1 a23 * m2 a31) + (m1 a24 * m2 a41)).
	c2 _ ((m1 a21 * m2 a12) + (m1 a22 * m2 a22) + 
				(m1 a23 * m2 a32) + (m1 a24 * m2 a42)).
	c3 _ ((m1 a21 * m2 a13) + (m1 a22 * m2 a23) + 
				(m1 a23 * m2 a33) + (m1 a24 * m2 a43)).
	c4 _ ((m1 a21 * m2 a14) + (m1 a22 * m2 a24) + 
				(m1 a23 * m2 a34) + (m1 a24 * m2 a44)).

	m3 a21: c1; a22: c2; a23: c3; a24: c4.

	c1 _ ((m1 a31 * m2 a11) + (m1 a32 * m2 a21) + 
				(m1 a33 * m2 a31) + (m1 a34 * m2 a41)).
	c2 _ ((m1 a31 * m2 a12) + (m1 a32 * m2 a22) + 
				(m1 a33 * m2 a32) + (m1 a34 * m2 a42)).
	c3 _ ((m1 a31 * m2 a13) + (m1 a32 * m2 a23) + 
				(m1 a33 * m2 a33) + (m1 a34 * m2 a43)).
	c4 _ ((m1 a31 * m2 a14) + (m1 a32 * m2 a24) + 
				(m1 a33 * m2 a34) + (m1 a34 * m2 a44)).

	m3 a31: c1; a32: c2; a33: c3; a34: c4.

	c1 _ ((m1 a41 * m2 a11) + (m1 a42 * m2 a21) + 
				(m1 a43 * m2 a31) + (m1 a44 * m2 a41)).
	c2 _ ((m1 a41 * m2 a12) + (m1 a42 * m2 a22) + 
				(m1 a43 * m2 a32) + (m1 a44 * m2 a42)).
	c3 _ ((m1 a41 * m2 a13) + (m1 a42 * m2 a23) + 
				(m1 a43 * m2 a33) + (m1 a44 * m2 a43)).
	c4 _ ((m1 a41 * m2 a14) + (m1 a42 * m2 a24) + 
				(m1 a43 * m2 a34) + (m1 a44 * m2 a44)).

	m3 a41: c1; a42: c2; a43: c3; a44: c4.! !


!B3DMatrix4x4 methodsFor: 'row-access' stamp: 'jsp 2/24/1999 17:10'!
row1
	"Return row 1"

	^ (B3DVector3 x: (self a11) y: (self a12) z: (self a13)).
! !

!B3DMatrix4x4 methodsFor: 'row-access' stamp: 'jsp 2/24/1999 17:11'!
row2
	"Return row 2"

	^ (B3DVector3 x: (self a21) y: (self a22) z: (self a23)).
! !

!B3DMatrix4x4 methodsFor: 'row-access' stamp: 'jsp 2/24/1999 17:11'!
row3
	"Return row 3"

	^ (B3DVector3 x: (self a31) y: (self a32) z: (self a33)).
! !

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

B3DMatrix4x4 class
	instanceVariableNames: ''!

!B3DMatrix4x4 class methodsFor: 'class initialization' stamp: 'ar 2/1/1999 21:58'!
initialize
	"B3DMatrix4x4 initialize"
	B3DZeroMatrix _ self new.
	B3DIdentityMatrix _ self new.
	B3DIdentityMatrix a11: 1.0; a22: 1.0; a33: 1.0; a44: 1.0.! !


!B3DMatrix4x4 class methodsFor: 'instance creation'!
identity
	^self new setIdentity! !

!B3DMatrix4x4 class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:25'!
numElements
	^16! !

!B3DMatrix4x4 class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 23:58'!
rotatedBy: angle around: axis centeredAt: origin
	"Create a matrix rotating points around the given origin using the angle/axis pair"
	| xform |
	xform _ self withOffset: origin negated.
	xform _ xform composedWithGlobal:(B3DRotation angle: angle axis: axis) asMatrix4x4.
	xform _ xform composedWithGlobal: (self withOffset: origin).
	^xform! !

!B3DMatrix4x4 class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 23:48'!
withOffset: amount
	^self identity setTranslation: amount! !

!B3DMatrix4x4 class methodsFor: 'instance creation'!
zero
	^self new! !
Morph subclass: #B3DMorph
	instanceVariableNames: 'camera geometry angle texture '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Demo Morphs'!

!B3DMorph methodsFor: 'initialize' stamp: 'mjg 9/28/1999 10:19'!
initialize
	super initialize.
	geometry _ B3DBox from: (-0.7@-0.7@-0.7) to: (0.7@0.7@0.7).
	camera _ B3DCamera new.
	(self confirm:'Put me into a clipping frame?')
		ifTrue:[camera position: 0@0@1.5]
		ifFalse:[camera position: 0@0@2. color _ nil].
	camera nearDistance: 0.1.
	camera farDistance: 5.0.
	self extent: 100@100.
	texture _ (Form extent: 100@100) asTexture.
	angle _ 0.! !


!B3DMorph methodsFor: 'drawing' stamp: 'ar 2/8/1999 02:48'!
drawOn: aCanvas
	color ifNotNil:["aCanvas frameAndFillRectangle: self bounds fillColor: color borderWidth: 1 borderColor: Color black."
		aCanvas frameRectangle: self bounds color: self color].
	aCanvas asBalloonCanvas render: self.
! !

!B3DMorph methodsFor: 'drawing' stamp: 'ar 2/16/1999 17:26'!
renderOn: aRenderer
	camera ifNotNil:[
		aRenderer viewport: (self bounds insetBy: 1@1).
		aRenderer clearDepthBuffer.
		aRenderer loadIdentity.
		camera renderOn: aRenderer].
	aRenderer texture: texture.
	aRenderer transformBy: (B3DRotation angle: angle axis: 0@1@0).
	geometry ifNotNil:[geometry renderOn: aRenderer].! !


!B3DMorph methodsFor: 'stepping' stamp: 'ar 2/4/1999 20:15'!
step
	angle _ angle + 5.
	self changed.! !

!B3DMorph methodsFor: 'stepping' stamp: 'ar 2/4/1999 20:15'!
stepTime
	^50! !

!B3DMorph methodsFor: 'stepping' stamp: 'ar 2/4/1999 20:15'!
wantsSteps
	^true! !


!B3DMorph methodsFor: 'menu' stamp: 'ar 2/16/1999 17:22'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add:'set texture' action: #setTexture.! !

!B3DMorph methodsFor: 'menu' stamp: 'ar 2/16/1999 17:28'!
setTexture
	| tex |
	tex _ B3DTexture fromDisplay:(Rectangle originFromUser: 128@128).
	tex wrap: true.
	tex interpolate: false.
	tex envMode: 0.
	texture _ tex.
	self changed! !
B3DGeometry subclass: #B3DMultiMesh
	instanceVariableNames: 'meshes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DMultiMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 19:32'!
meshes
	^meshes! !

!B3DMultiMesh methodsFor: 'accessing' stamp: 'ar 8/31/2000 19:32'!
meshes: aCollection
	meshes _ aCollection asArray! !

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

B3DMultiMesh class
	instanceVariableNames: ''!

!B3DMultiMesh class methodsFor: 'instance creation' stamp: 'ar 8/31/2000 19:31'!
withAll: meshList
	^self new meshes: meshList! !
B3DVertexRasterizer subclass: #B3DNullRasterizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!
!B3DNullRasterizer commentStamp: '<historical>' prior: 0!
The only purpose of this rasterizer is to measure the actual transform/lighting/clipping speed of an engine.!


!B3DNullRasterizer methodsFor: 'testing' stamp: 'ar 2/16/1999 02:31'!
needsClip
	"Yepp. We want to see how well our clipper performs."
	^true! !


!B3DNullRasterizer methodsFor: 'processing' stamp: 'ar 5/26/2000 15:34'!
clearViewport: aColor
	"Do nothing"! !

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

B3DNullRasterizer class
	instanceVariableNames: ''!

!B3DNullRasterizer class methodsFor: 'testing' stamp: 'ar 2/16/1999 17:37'!
isAvailable
	"Return true if this part of the engine is available"
	^true! !
B3DRenderEngine subclass: #B3DPickerEngine
	instanceVariableNames: 'pickMatrix pickList objects maxVtx '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!

!B3DPickerEngine methodsFor: 'initialize' stamp: 'ar 4/18/1999 00:21'!
flush
	"Ignored"! !

!B3DPickerEngine methodsFor: 'initialize' stamp: 'ar 6/2/1999 12:08'!
initialize
	"Do not call super initialize here. We get our components directly by the creating engine."
	pickList _ SortedCollection new: 100.
	pickList sortBlock:[:a1 :a2| a1 value rasterPosZ < a2 value rasterPosZ].
	objects _ OrderedCollection new: 100.
	objects resetTo: 1.
	maxVtx _ B3DPrimitiveVertex new.
	maxVtx rasterPosZ: 1.0e30.
	maxVtx rasterPosW: 1.0.! !

!B3DPickerEngine methodsFor: 'initialize' stamp: 'ar 4/17/1999 23:11'!
loadFrom: aRenderEngine
	"Load our components from the given render engine.
	The idea is that all of the state is shared so that transformations
	send during picking will be preserved in the given render engine."
	vertexBuffer _ aRenderEngine getVertexBuffer.
	transformer _ aRenderEngine getTransformer.
	shader _ aRenderEngine getShader.
	clipper _ aRenderEngine getClipper.
	rasterizer _ aRenderEngine getRasterizer. ! !


!B3DPickerEngine methodsFor: 'picking' stamp: 'ar 4/18/1999 02:25'!
pickAt: aPoint extent: extentPoint
	"Initialize the receiver for picking at the given point using the given extent."
	pickMatrix _ self pickingMatrixAt: aPoint extent: extentPoint.! !

!B3DPickerEngine methodsFor: 'picking' stamp: 'ar 6/2/1999 12:03'!
render: anObject
	| assoc |
	assoc _ Association key: anObject value: maxVtx.
	objects addLast: assoc.
	anObject renderOn: self.
	(objects removeLast == assoc) ifFalse:[^self error:'Object stack is confused'].
	assoc value rasterPosZ > 2.0 ifFalse:[pickList add: assoc].! !

!B3DPickerEngine methodsFor: 'picking' stamp: 'ar 4/18/1999 00:08'!
topMostObject
	"Return the top most of all picked objects"
	^pickList isEmpty
		ifTrue:[nil]
		ifFalse:[pickList first key]! !

!B3DPickerEngine methodsFor: 'picking' stamp: 'ar 6/2/1999 12:08'!
topMostVertex
	"Return the top most primitive vertex of all picked objects.
	Note: Except from the z value the vertex is *not* normalized yet 
		(e.g., there was no division by w)"
	^pickList isEmpty
		ifTrue:[nil]
		ifFalse:[pickList first value]! !


!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 6/2/1999 11:54'!
primComputeMinIndexZ: primType vtxArray: vtxArray vtxSize: vtxSize idxArray: idxArray idxSize: idxSize
	"<primitive: 'b3dComputeMinIndexZ' module: 'Squeak3D'>"
	^nil "Indicates failure"! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 03:01'!
primComputeMinZ: primType vtxArray: vtxArray vtxSize: vtxSize idxArray: idxArray idxSize: idxSize
	<primitive: 'b3dComputeMinZ' module: 'Squeak3D'>
	^nil "Indicates failure"! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 02:26'!
privateTransformVB: vb
	"Transform the contents of the vertex buffer.
	Transforming may include normals (if lighting enabled) and textures (if textures enabled)."
	^transformer processVertexBuffer: vb
					modelView: transformer modelViewMatrix
					projection: (transformer projectionMatrix composedWithGlobal: pickMatrix)! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 6/4/1999 10:28'!
processIndexed: vb
	| idxArray vtxArray index vtx zValue minIndex minZ wValue |
	idxArray _ vb indexArray.
	vtxArray _ vb vertexArray.
	minZ _ 10.0.
	minIndex _ 0.
	1 to: vb indexCount do:[:i|
		index _ idxArray at: i.
		index = 0 ifFalse:[
			vtx _ vtxArray at: index.
			zValue _ vtx rasterPosZ.
			wValue _ vtx rasterPosW.
			wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
			(minIndex = 0 or:[zValue < minZ]) ifTrue:[
				minIndex _ index.
				minZ _ zValue].
		].
	].
	^minIndex! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:42'!
processIndexedLines: vb
	^self processIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:41'!
processIndexedQuads: vb
	^self processIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:41'!
processIndexedTriangles: vb
	^self processIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:43'!
processLineLoop: vb
	^self processNonIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:43'!
processLines: vb
	^self processNonIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 6/2/1999 11:54'!
processNonIndexed: vb
	| vtxArray vtx zValue minZ minIndex wValue |
	vtxArray _ vb vertexArray.
	minZ _ 10.0.
	minIndex _ 0.
	1 to: vb vertexCount do:[:i|
		vtx _ vtxArray at: i.
		zValue _ vtx rasterPosZ.
		wValue _ vtx rasterPosW.
		wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
		(minIndex = 0 or:[zValue < minZ]) ifTrue:[
			minIndex _ i.
			minZ _ zValue].
	].
	^minIndex! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:44'!
processPoints: vb
	^self processNonIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 4/18/1999 00:43'!
processPolygon: vb
	^self processNonIndexed: vb! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 6/4/1999 10:28'!
processVertexBuffer: vb
	| minIndex minVertex minW |
	minIndex _ self primComputeMinIndexZ: vb primitive vtxArray: vb vertexArray vtxSize: vb vertexCount idxArray: vb indexArray idxSize: vb indexCount.
	minIndex == nil ifTrue:[minIndex _ super processVertexBuffer: vb].
	minIndex = 0 ifTrue:[^maxVtx].
	minVertex _ vb vertexArray at: minIndex.
	minW _ minVertex rasterPosW.
	minW = 0.0 ifFalse:[minVertex rasterPosZ: minVertex rasterPosZ / minW].
	^minVertex! !

!B3DPickerEngine methodsFor: 'private-rendering' stamp: 'ar 11/7/1999 18:12'!
renderPrimitive
	"This is the main rendering loop for all operations"
	| visible minVertex |
	"Step 1: Check if the mesh is visible at all"
	visible _ self privateVisibleVB: vertexBuffer.
	visible == false ifTrue:[^nil].

	"Step 2: Transform vertices, normals, texture coords of the mesh"
	self privateTransformVB: vertexBuffer.

	"Step 3: Clip the mesh if necessary"
	visible _ self privateClipVB: vertexBuffer.
	visible == false ifTrue:[^nil].

	"Step 4: Collect the minimal/maximal distances for the current object."
	minVertex _ self processVertexBuffer: vertexBuffer.
	objects isEmpty ifFalse:[
		objects last value rasterPosZ > minVertex rasterPosZ 
			ifTrue:[objects last value: minVertex].
	].
	^nil! !
B3DEnginePlugin subclass: #B3DPickerPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DPickerPlugin methodsFor: 'primitives' stamp: 'ar 6/2/1999 11:59'!
b3dComputeMinIndexZ
	"Primitive. Compute and return the index for the minimal z value of all objects in the vertex buffer."
	| idxSize vtxSize primType vtxArray idxArray minIndex |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #idxArray declareC:'int *idxArray'.
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	idxSize _ interpreterProxy stackIntegerValue: 0.
	vtxSize _ interpreterProxy stackIntegerValue: 2.
	primType _ interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	vtxArray _ self stackPrimitiveVertexArray: 3 ofSize: vtxSize.
	idxArray _ self stackPrimitiveIndexArray: 1 ofSize: idxSize validate: true forVertexSize: vtxSize.
	(vtxArray == nil or:[idxArray == nil or:[interpreterProxy failed]])
		ifTrue:[^interpreterProxy primitiveFail].
	(primType < 1 or:[primType > 6])
		ifTrue:[^interpreterProxy primitiveFail].
	primType <= 3 ifTrue:[
		minIndex _ self processNonIndexedIDX: vtxArray ofSize: vtxSize.
	] ifFalse:[
		minIndex _ self processIndexedIDX: vtxArray ofSize: vtxSize idxArray: idxArray idxSize: idxSize.
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 6. "nArgs+rcvr"
		interpreterProxy pushInteger: minIndex.
	].! !

!B3DPickerPlugin methodsFor: 'primitives' stamp: 'ar 4/18/1999 02:59'!
b3dComputeMinZ
	"Primitive. Compute and return the minimal z value of all objects in the vertex buffer."
	| idxSize vtxSize primType vtxArray idxArray minZ |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #idxArray declareC:'int *idxArray'.
	self var: #minZ declareC:'double minZ'.
	interpreterProxy methodArgumentCount = 5
		ifFalse:[^interpreterProxy primitiveFail].
	idxSize _ interpreterProxy stackIntegerValue: 0.
	vtxSize _ interpreterProxy stackIntegerValue: 2.
	primType _ interpreterProxy stackIntegerValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	vtxArray _ self stackPrimitiveVertexArray: 3 ofSize: vtxSize.
	idxArray _ self stackPrimitiveIndexArray: 1 ofSize: idxSize validate: true forVertexSize: vtxSize.
	(vtxArray == nil or:[idxArray == nil or:[interpreterProxy failed]])
		ifTrue:[^interpreterProxy primitiveFail].
	(primType < 1 or:[primType > 6])
		ifTrue:[^interpreterProxy primitiveFail].
	primType <= 3 ifTrue:[
		minZ _ self processNonIndexed: vtxArray ofSize: vtxSize.
	] ifFalse:[
		minZ _ self processIndexed: vtxArray ofSize: vtxSize idxArray: idxArray idxSize: idxSize.
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 6. "nArgs+rcvr"
		interpreterProxy pushFloat: minZ.
	].! !


!B3DPickerPlugin methodsFor: 'processing' stamp: 'ar 4/18/1999 03:05'!
processIndexed: vtxArray ofSize: vtxSize idxArray: idxArray idxSize: idxSize
	| vtxPtr zValue wValue minZ index |
	self returnTypeC:'double'.
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #vtxPtr declareC:'float *vtxPtr'.
	self var: #idxArray declareC:'int *idxArray'.
	self var: #wValue declareC:'double wValue'.
	self var: #zValue declareC:'double zValue'.
	self var: #minZ declareC:'double minZ'.
	minZ _ 10.0.
	1 to: idxSize do:[:i|
		index _ idxArray at: i.
		index > 0 ifTrue:[
			vtxPtr _ vtxArray + (index-1 * PrimVertexSize).
			zValue _ vtxPtr at: PrimVtxRasterPosZ.
			wValue _ vtxPtr at: PrimVtxRasterPosW.
			wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
			zValue < minZ ifTrue:[minZ _ zValue].
		].
	].
	^minZ! !

!B3DPickerPlugin methodsFor: 'processing' stamp: 'ar 6/2/1999 12:00'!
processIndexedIDX: vtxArray ofSize: vtxSize idxArray: idxArray idxSize: idxSize
	| vtxPtr zValue wValue minZ minIndex index |
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #vtxPtr declareC:'float *vtxPtr'.
	self var: #idxArray declareC:'int *idxArray'.
	self var: #wValue declareC:'double wValue'.
	self var: #zValue declareC:'double zValue'.
	self var: #minZ declareC:'double minZ'.
	minZ _ 10.0.
	minIndex _ 0.
	1 to: idxSize do:[:i|
		index _ idxArray at: i.
		index > 0 ifTrue:[
			vtxPtr _ vtxArray + (index-1 * PrimVertexSize).
			zValue _ vtxPtr at: PrimVtxRasterPosZ.
			wValue _ vtxPtr at: PrimVtxRasterPosW.
			wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
			(minIndex = 0 or:[zValue < minZ]) ifTrue:[
				minIndex _ i.
				minZ _ zValue].
		].
	].
	^minIndex! !

!B3DPickerPlugin methodsFor: 'processing' stamp: 'ar 4/18/1999 02:49'!
processNonIndexed: vtxArray ofSize: vtxSize
	| vtxPtr zValue wValue minZ |
	self returnTypeC:'double'.
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #vtxPtr declareC:'float *vtxPtr'.
	self var: #wValue declareC:'double wValue'.
	self var: #zValue declareC:'double zValue'.
	self var: #minZ declareC:'double minZ'.
	minZ _ 10.0.
	vtxPtr _ vtxArray.
	1 to: vtxSize do:[:i|
		zValue _ vtxPtr at: PrimVtxRasterPosZ.
		wValue _ vtxPtr at: PrimVtxRasterPosW.
		wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
		zValue < minZ ifTrue:[minZ _ zValue].
	].
	^minZ! !

!B3DPickerPlugin methodsFor: 'processing' stamp: 'ar 6/2/1999 12:00'!
processNonIndexedIDX: vtxArray ofSize: vtxSize
	| vtxPtr zValue wValue minZ minIndex |
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #vtxPtr declareC:'float *vtxPtr'.
	self var: #wValue declareC:'double wValue'.
	self var: #zValue declareC:'double zValue'.
	self var: #minZ declareC:'double minZ'.
	minZ _ 10.0.
	minIndex _ 0.
	vtxPtr _ vtxArray.
	1 to: vtxSize do:[:i|
		zValue _ vtxPtr at: PrimVtxRasterPosZ.
		wValue _ vtxPtr at: PrimVtxRasterPosW.
		wValue = 0.0 ifFalse:[zValue _ zValue / wValue].
		(minIndex = 0 or:[zValue < minZ]) ifTrue:[
			minIndex _ i.
			minZ _ zValue].
	].
	^minIndex! !
Object subclass: #B3DPoolDefiner
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!
!B3DPoolDefiner commentStamp: '<historical>' prior: 0!
This class is used to define the pool dictionary B3DConstants.!


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

B3DPoolDefiner class
	instanceVariableNames: ''!

!B3DPoolDefiner class methodsFor: 'class initialization' stamp: 'ar 2/8/1999 17:21'!
initialize
	"B3DPoolDefiner initialize"
	self initPool.! !


!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/13/1999 20:30'!
defineClipConstants: dict
	"Initialize the clipper constants"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		(InLeftBit		16r001)
		(OutLeftBit		16r002)
		(InRightBit		16r004)
		(OutRightBit		16r008)
		(InTopBit		16r010)
		(OutTopBit		16r020)
		(InBottomBit		16r040)
		(OutBottomBit	16r080)
		(InFrontBit		16r100)
		(OutFrontBit		16r200)
		(InBackBit		16r400)
		(OutBackBit		16r800)

		(InAllMask		16r555)
		(OutAllMask		16rAAA)
	) in: dict.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 9/9/2000 23:16'!
defineMaterialAndLights: dict
	"Initialize constants used for materials and lights"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		"MaterialColor stuff"
		(AmbientPart 0)
		(AmbientRed 0)
		(AmbientGreen 1)
		(AmbientBlue 2)
		(AmbientAlpha 3)

		(DiffusePart 4)
		(DiffuseRed 4)
		(DiffuseGreen 5)
		(DiffuseBlue 6)
		(DiffuseAlpha 7)

		(SpecularPart 8)	
		(SpecularRed 8)
		(SpecularGreen 9)
		(SpecularBlue 10)
		(SpecularAlpha 11)

		(MaterialColorSize 12)	"Size of B3DMaterialColor"

		"Material definition"
		(EmissionPart 12)
		(EmissionRed 12)
		(EmissionGreen 13)
		(EmissionBlue 14)
		(EmissionAlpha 15)

		(MaterialShininess 16)

		(MaterialSize 17)			"Size of B3DMaterial"

		"PrimitiveLight definition"
		(PrimLightPosition 12)
		(PrimLightPositionX 12)
		(PrimLightPositionY 13)
		(PrimLightPositionZ 14)

		(PrimLightDirection 15)
		(PrimLightDirectionX 15)
		(PrimLightDirectionY 16)
		(PrimLightDirectionZ 17)

		(PrimLightAttenuation 18)
		(PrimLightAttenuationConstant 18)
		(PrimLightAttenuationLinear 19)
		(PrimLightAttenuationSquared 20)

		(PrimLightFlags 21)
		"Spot light stuff"
		(SpotLightMinCos 22)
		(SpotLightMaxCos 23)
		(SpotLightDeltaCos 24)
		(SpotLightExponent 25)

		(PrimLightSize 32)		"Round up to power of 2"

		"Primitive light flags"
		(FlagPositional 16r0001)	"Light has an associated position"
		(FlagDirectional 16r0002)	"Light has an associated direction"
		(FlagAttenuated 16r0004)	"Light is attenuated"
		(FlagHasSpot 16r0008)	"Spot values are valid"
		(FlagAmbientPart 16r0100)	"Light has ambient part"
		(FlagDiffusePart 16r0200)	"Light has diffuse part"
		(FlagSpecularPart 16r0400)	"Light has specular part"

	) in: dict.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 20:15'!
defineMatrixFlags: dict
	"Define the flags for analyzing vertices"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		(FlagM44Identity 1)		"Matrix is identity"
		(FlagM44NoPerspective 2) "Matrix has no perspective part"
		(FlagM44NoTranslation 4) "Matrix has no translation"
	) in: dict! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/13/1999 23:41'!
definePrimitiveTypes: dict
	"Initialize the types of Primitives"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		(PrimTypePoints 1)
		(PrimTypeLines 2)
		(PrimTypePolygon 3)
		(PrimTypeIndexedLines 4)
		(PrimTypeIndexedTriangles 5)
		(PrimTypeIndexedQuads 6)
		(PrimTypeMax 6)	"Max used primitive type"
	) in: dict.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 4/4/1999 00:46'!
definePrimitiveVertexIndexes: dict
	"Define the indexes for primitive vertices"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		"Full vertex size is 16 to simplify index computation"
		(PrimVertexSize 16)

		"Position"
		(PrimVtxPosition 0)
		(PrimVtxPositionX 0)
		(PrimVtxPositionY 1)
		(PrimVtxPositionZ 2)

		"Normal"
		(PrimVtxNormal 3)
		(PrimVtxNormalX 3)
		(PrimVtxNormalY 4)
		(PrimVtxNormalZ 5)

		"Tex coord"
		(PrimVtxTexCoords 6)
		(PrimVtxTexCoordU 6)
		(PrimVtxTexCoordV 7)

		"RasterPos"
		(PrimVtxRasterPos 8)
		(PrimVtxRasterPosX 8)
		(PrimVtxRasterPosY 9)
		(PrimVtxRasterPosZ 10)
		(PrimVtxRasterPosW 11)

		"Color"
		(PrimVtxColor32 12)
		"Clip flags"
		(PrimVtxClipFlags 13)

		"(Integer) window position"
		(PrimVtxWindowPosX 14)
		(PrimVtxWindowPosY 15)
	) in: dict! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:34'!
defineVBConstants: dict
	"Initialize the vertex buffer constants"
	"B3DPoolDefiner initPool"
	self initFromSpecArray:
	#(
		"Vertex color tracking flags. These tracks define what part of 
		the material in the shader is determined by the vertex color (if given)."
		(VBTrackAmbient 1)		"ambient part"
		(VBTrackDiffuse 2)		"diffuse part"
		(VBTrackSpecular 4)		"specular part"
		(VBTrackEmission 8)		"emission part -- i.e. simply add vertex color to output"
		(VBNoTrackMask 4294967280) "Mask out the above flags"

		"Vertex attribute flags. These flags determine if the primitive
		vertices include these attributes. Note that color is not included
		below - it is fully specified by the color tracking flags above."
		(VBVtxHasNormals 16)	"per vertex normals included"
		(VBVtxHasTexCoords 32)	"per vertex tex coords inclueded"

		"Shader flags stored in the vertex buffer"
		(VBTwoSidedLighting 64)	"Do we shade front and back faces differently?!!"
		(VBUseLocalViewer 128)	"Do we use a local viewer model for specular colors?!!"
	) in: dict.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:20'!
initFromSpecArray: specArray in: aDictionary
	specArray do:[:spec|
		self initPoolVariable: spec first value: spec last in: aDictionary.
	]! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:23'!
initPool
	"B3DPoolDefiner initPool"
	| poolName |
	poolName _ self poolName asSymbol.
	(Smalltalk includesKey: poolName) ifFalse:[
		Smalltalk declare: poolName from: Undeclared.
	].
	(Smalltalk at: poolName) isNil ifTrue:[
		(Smalltalk associationAt: poolName) value: Dictionary new.
	].
	self initPool: (Smalltalk at: poolName).! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/15/1999 04:14'!
initPool: aDictionary
	"B3DPoolDefiner initPool"
	self defineVBConstants: aDictionary.
	self definePrimitiveVertexIndexes: aDictionary.
	self defineMatrixFlags: aDictionary.
	self defineClipConstants: aDictionary.
	self definePrimitiveTypes: aDictionary.
	self defineMaterialAndLights: aDictionary.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:23'!
initPoolFull	"B3DPoolDefiner initPoolFull"
	"Move old stuff to Undeclared and re-initialize the receiver"
	| pool |
	pool _ Smalltalk at: self poolName asSymbol ifAbsent:[Dictionary new].
	pool associationsDo:[:assoc|
		Undeclared declare: assoc key from: pool.
	].
	self initPool.
	Undeclared removeUnreferencedKeys.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:20'!
initPoolVariable: token value: value in: aDictionary
	aDictionary declare: token from: Undeclared.
	(aDictionary associationAt: token) value: value.! !

!B3DPoolDefiner class methodsFor: 'pool definition' stamp: 'ar 2/8/1999 17:22'!
poolName
	^#B3DEngineConstants! !
B3DLightSource subclass: #B3DPositionalLight
	instanceVariableNames: 'position attenuation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DPositionalLight methodsFor: 'initialize' stamp: 'ar 2/7/1999 19:14'!
from3DS: aDictionary
	"Initialize the receiver from a 3DS point light"
	| color |
	position _ aDictionary at: #position.
	color _ aDictionary at: #color.
	lightColor _ B3DMaterialColor color: color.
	attenuation _ B3DLightAttenuation constant: 1.0 linear: 0.0 squared: 0.0.! !


!B3DPositionalLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:05'!
attenuation
	^attenuation! !

!B3DPositionalLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:05'!
attenuation: aLightAttenuation
	attenuation _ aLightAttenuation! !

!B3DPositionalLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:04'!
position
	^position! !

!B3DPositionalLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:04'!
position: aVector
	position _ aVector! !


!B3DPositionalLight methodsFor: 'shading' stamp: 'ar 2/7/1999 16:54'!
computeAttenuationFor: distance
	"Compute the attenuation for the given distance"
	^attenuation computeAttenuationFor: distance! !

!B3DPositionalLight methodsFor: 'shading' stamp: 'ar 2/8/1999 02:01'!
computeDirectionTo: aB3DPrimitiveVertex
	"Compute the lights direction to the given vertex"
	^aB3DPrimitiveVertex position - position! !


!B3DPositionalLight methodsFor: 'converting' stamp: 'ar 2/15/1999 21:58'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight flags |
	primLight _ B3DPrimitiveLight new.
	primLight position: position.
	flags _ FlagPositional.
	self attenuation isIdentity not ifTrue:[
		primLight attenuation: self attenuation.
		flags _ flags bitOr: FlagAttenuated].
	lightColor ambientPart isZero ifFalse:[
		primLight ambientPart: lightColor ambientPart.
		flags _ flags bitOr: FlagAmbientPart].
	lightColor diffusePart isZero ifFalse:[
		primLight diffusePart: lightColor diffusePart.
		flags _ flags bitOr: FlagDiffusePart].
	lightColor specularPart isZero ifFalse:[
		primLight specularPart: lightColor specularPart.
		flags _ flags bitOr: FlagSpecularPart].
	primLight flags: flags.
	^primLight! !

!B3DPositionalLight methodsFor: 'converting' stamp: 'ar 2/8/1999 01:29'!
transformedBy: aTransformer
	^(super transformedBy: aTransformer) position: (aTransformer transformPosition: position)! !

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

B3DPositionalLight class
	instanceVariableNames: ''!

!B3DPositionalLight class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 23:42'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !
B3DVertexClipper subclass: #B3DPrimitiveClipper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-PrimitiveEngine'!

!B3DPrimitiveClipper methodsFor: 'clip flags' stamp: 'ar 4/18/1999 02:05'!
determineClipFlags: vtxArray count: vtxCount
	<primitive: 'b3dDetermineClipFlags' module:'Squeak3D'>
	^super determineClipFlags: vtxArray count: vtxCount! !


!B3DPrimitiveClipper methodsFor: 'clipping polygons' stamp: 'ar 4/18/1999 02:08'!
clipPolygon: vtxArray count: vtxCount with: tempVtxArray mask: outMask
	<primitive:'b3dClipPolygon' module:'Squeak3D'>
	^super clipPolygon: vtxArray count: vtxCount with: tempVtxArray mask: outMask! !


!B3DPrimitiveClipper methodsFor: 'private' stamp: 'ar 4/18/1999 02:07'!
primNextClippedTriangleAfter: firstIndex vertices: vtxArray count: vtxCount indexes: idxArray count: idxCount
	<primitive: 'b3dPrimitiveNextClippedTriangle' module:'Squeak3D'>
	^super primNextClippedTriangleAfter: firstIndex vertices: vtxArray count: vtxCount indexes: idxArray count: idxCount! !
Object subclass: #B3DPrimitiveEdge
	instanceVariableNames: 'v0 v1 leftFace rightFace flags xValue yValue zValue nLines xIncrement zIncrement '
	classVariableNames: 'DepthScale FixedScale FixedToInt '
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DPrimitiveEdge methodsFor: 'initialize' stamp: 'ar 4/3/1999 04:25'!
from: vtx0 to: vtx1
	(vtx0 sortsBefore: vtx1) 
		ifTrue:[v0 _ vtx0. v1 _ vtx1]
		ifFalse:[v1 _ vtx0. v0 _ vtx1].! !

!B3DPrimitiveEdge methodsFor: 'initialize' stamp: 'ar 4/18/1999 08:05'!
initializePass1
	"Assume: v0 sortsBefore: v1"
	xValue _ v0 windowPosX.
	yValue _ v0 windowPosY.
	zValue _ v0 rasterPosZ.
	xIncrement _ (v1 windowPosX - v0 windowPosX) // nLines.
	zIncrement _ (v1 rasterPosZ - v0 rasterPosZ) / nLines.! !

!B3DPrimitiveEdge methodsFor: 'initialize' stamp: 'ar 4/4/1999 21:34'!
v0: vtx0 v1: vtx1
	v0 _ vtx0.
	v1 _ vtx1.
	flags _ 0.
	nLines _ (vtx1 windowPosY bitShift: -12) - (vtx0 windowPosY bitShift: -12).! !


!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/4/1999 02:41'!
flags
	^flags! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/4/1999 02:41'!
flags: aNumber
	flags _ aNumber! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
leftFace
	^leftFace! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
leftFace: aFace
	leftFace _ aFace! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 03:25'!
nLines
	^nLines! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 03:25'!
nLines: aNumber
	nLines _ aNumber! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
rightFace
	^rightFace! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
rightFace: aFace
	rightFace _ aFace.! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/4/1999 20:58'!
vertex0
	^v0! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/4/1999 20:58'!
vertex1
	^v1! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/6/1999 23:21'!
xIncrement	
	^xIncrement! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:48'!
xValue
	^xValue! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/5/1999 22:25'!
xValue: aNumber
	xValue _ aNumber! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:48'!
yValue
	^yValue! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:48'!
zValue
	^zValue! !

!B3DPrimitiveEdge methodsFor: 'accessing' stamp: 'ar 4/6/1999 01:23'!
zValue: aNumber
	zValue _ aNumber! !


!B3DPrimitiveEdge methodsFor: 'processing' stamp: 'ar 4/5/1999 02:45'!
stepToNextLine
	"Step to the next scan line"
	xValue _ xValue + xIncrement.
	yValue _ yValue + 4096.
	zValue _ zValue + zIncrement.! !


!B3DPrimitiveEdge methodsFor: 'printing' stamp: 'ar 4/4/1999 23:35'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$(;
		print: (v0 windowPos bitShiftPoint:-12);
		nextPutAll:' - ';
		print: (v1 windowPos bitShiftPoint: -12);
		nextPutAll:' nLines = ';
		print: nLines;
		nextPut:$).! !
Object subclass: #B3DPrimitiveEdgeList
	instanceVariableNames: 'tally array '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DPrimitiveEdgeList methodsFor: 'initialize' stamp: 'ar 4/4/1999 01:38'!
initialize
	array _ Array new: 100.
	tally _ 0.! !

!B3DPrimitiveEdgeList methodsFor: 'initialize' stamp: 'ar 4/4/1999 21:20'!
reset
	1 to: tally do:[:i| array at: i put: nil].
	tally _ 0.! !


!B3DPrimitiveEdgeList methodsFor: 'accessing' stamp: 'ar 4/4/1999 21:42'!
at: index
	^array at: index! !

!B3DPrimitiveEdgeList methodsFor: 'accessing' stamp: 'ar 4/4/1999 21:01'!
first
	^array at: 1! !

!B3DPrimitiveEdgeList methodsFor: 'accessing' stamp: 'ar 4/4/1999 21:42'!
size
	^tally! !

!B3DPrimitiveEdgeList methodsFor: 'accessing' stamp: 'ar 4/6/1999 03:58'!
xValues
	^(array copyFrom: 1 to: tally) collect:[:e| e xValue]! !


!B3DPrimitiveEdgeList methodsFor: 'adding' stamp: 'ar 4/4/1999 23:44'!
add: edge1 and: edge2 beforeIndex: index
	tally+1 >= array size ifTrue:[self grow].
	tally+2 to: index+2 by: -1 do:[:i|array at: i put: (array at:i-2)].
	"array replaceFrom: index+2 to: tally+2 with: array startingAt: index."
	array at: index put: edge1.
	array at: index+1 put: edge2.
	tally _ tally + 2.! !

!B3DPrimitiveEdgeList methodsFor: 'adding' stamp: 'ar 4/4/1999 23:45'!
add: edge beforeIndex: index
	tally = array size ifTrue:[self grow].
	tally+1 to: index+1 by: -1 do:[:i|array at: i put: (array at:i-1)].
	"array replaceFrom: index+1 to: tally+1 with: array startingAt: index."
	array at: index put: edge.
	tally _ tally + 1! !


!B3DPrimitiveEdgeList methodsFor: 'enumerating' stamp: 'ar 4/5/1999 02:27'!
do: aBlock
	1 to: tally do:[:i| aBlock value: (array at: i)].! !

!B3DPrimitiveEdgeList methodsFor: 'enumerating' stamp: 'ar 4/4/1999 01:39'!
xValue: xValue from: firstIndex do: aBlock
	"Enumerate the entries in the insertion list starting at the given first index.
	Evaluate aBlock with the entries having the requested x value. Return the index
	after the last element touched."
	| edge |
	firstIndex to: tally do:[:i|
		edge _ array at: i.
		edge xValue = xValue ifFalse:[^i].
		aBlock value: edge.
	].
	^tally+1! !


!B3DPrimitiveEdgeList methodsFor: 'testing' stamp: 'ar 4/4/1999 23:09'!
isEmpty
	^tally = 0! !


!B3DPrimitiveEdgeList methodsFor: 'sorting' stamp: 'ar 4/5/1999 01:41'!
firstIndexForInserting: xValue
	"Return the first possible index for inserting an object with the given xValue"
	| index |
	index _ self indexForInserting: xValue.
	[index > 1 and:[(array at: index-1) xValue = xValue]]
		whileTrue:[index _ index-1].
	^index! !

!B3DPrimitiveEdgeList methodsFor: 'sorting' stamp: 'ar 4/5/1999 01:41'!
indexForInserting: xValue
	"Return the appropriate index for inserting the given x value"
	| index low high |
	low _ 1.
	high _ tally.
	[index _ high + low // 2.
	low > high]
		whileFalse:[
			(array at: index) xValue <= xValue
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]].
	^low! !


!B3DPrimitiveEdgeList methodsFor: 'private' stamp: 'ar 4/4/1999 01:38'!
grow
	| newArray |
	newArray _ array species new: array size + 100.
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray.! !

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

B3DPrimitiveEdgeList class
	instanceVariableNames: ''!

!B3DPrimitiveEdgeList class methodsFor: 'instance creation' stamp: 'ar 4/4/1999 04:27'!
new
	^super new initialize! !
B3DRenderEngine subclass: #B3DPrimitiveEngine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!
!B3DPrimitiveEngine commentStamp: '<historical>' prior: 0!
I am a basic render engine with some primitive level support for transformation, lighting and (once it is done) clipping.!


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

B3DPrimitiveEngine class
	instanceVariableNames: ''!

!B3DPrimitiveEngine class methodsFor: 'accessing' stamp: 'ar 4/16/1999 06:45'!
clipper
	^B3DPrimitiveClipper
	"^B3DVertexClipper"! !

!B3DPrimitiveEngine class methodsFor: 'accessing' stamp: 'ar 4/12/1999 03:47'!
rasterizer
	"Return the rasterizer to use with this engine"
	^B3DPrimitiveRasterizer! !

!B3DPrimitiveEngine class methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:24'!
shader
	"Return the shader to use with this engine"
	^B3DPrimitiveShader! !

!B3DPrimitiveEngine class methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:24'!
transformer
	"Return the transformer to use with this engine"
	^B3DPrimitiveTransformer! !
Object subclass: #B3DPrimitiveFace
	instanceVariableNames: 'v0 v1 v2 prevFace nextFace leftEdge rightEdge flags majorDx majorDy minorDx minorDy oneOverArea dzdx dzdy minZ maxZ texture attributes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/5/1999 18:29'!
initializeDepthBounds
	"Compute minZ/maxZ"
	v0 rasterPosZ <= v1 rasterPosZ ifTrue:[
		v1 rasterPosZ <= v2 rasterPosZ
			ifTrue:[minZ _ v0 rasterPosZ. maxZ _ v2 rasterPosZ]
			ifFalse:[v0 rasterPosZ <= v2 rasterPosZ
						ifTrue:[minZ _ v0 rasterPosZ. maxZ _ v1 rasterPosZ]
						ifFalse:[minZ _ v2 rasterPosZ. maxZ _ v1 rasterPosZ]].
	] ifFalse:[
		v2 rasterPosZ <= v1 rasterPosZ
			ifTrue:[minZ _ v2 rasterPosZ. maxZ _ v0 rasterPosZ]
			ifFalse:[v0 rasterPosZ <= v2 rasterPosZ
						ifTrue:[minZ _ v1 rasterPosZ. maxZ _ v2 rasterPosZ]
						ifFalse:[minZ _ v1 rasterPosZ. maxZ _ v0 rasterPosZ]].
	].
! !

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/8/1999 04:32'!
initializePass1
	"Assume: v0 sortsBefore: v1 sortsBefore: v2"
	| area majorDz minorDz |
	self initializeDepthBounds. "Compute minZ/maxZ"
	"Compute the major and minor reference edges"
	majorDx _ v2 rasterPosX - v0 rasterPosX.
	majorDy _ v2 rasterPosY - v0 rasterPosY.
	minorDx _ v1 rasterPosX - v0 rasterPosX.
	minorDy _ v1 rasterPosY - v0 rasterPosY.

	"Compute the inverse area of the face"
	area _ (majorDx * minorDy) - (minorDx * majorDy).
	((area > -0.001) and:[area < 0.001])
		ifTrue:[oneOverArea _ 0.0]
		ifFalse:[oneOverArea _ 1.0 / area].
	"Compute dzdx and dzdy"
	majorDz _ v2 rasterPosZ - v0 rasterPosZ.
	minorDz _ v1 rasterPosZ - v0 rasterPosZ.
	dzdx _ oneOverArea * ((majorDz * minorDy) - (minorDz * majorDy)).
	dzdy _ oneOverArea * ((majorDx * minorDz) - (majorDz * minorDx)).
! !

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/18/1999 06:35'!
initializePass2
	"The receiver is about to be drawn.
	Initialize all the attributes deferred until now."
	| majorDv minorDv dvdx dvdy w0 w1 w2 baseValue rAttr gAttr bAttr aAttr wAttr sAttr tAttr |
	"Red"
	majorDv _ v2 redValue - v0 redValue.
	minorDv _ v1 redValue - v0 redValue.
	dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
	dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
	attributes _ rAttr _ B3DPrimitiveFaceAttributes new.
	rAttr value: v0 redValue; dvdx: dvdx; dvdy: dvdy.
	"Green"
	majorDv _ v2 greenValue - v0 greenValue.
	minorDv _ v1 greenValue - v0 greenValue.
	dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
	dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
	gAttr _ B3DPrimitiveFaceAttributes new.
	gAttr value: v0 greenValue; dvdx: dvdx; dvdy: dvdy.
	rAttr nextAttr: gAttr.
	"Blue"
	majorDv _ v2 blueValue - v0 blueValue.
	minorDv _ v1 blueValue - v0 blueValue.
	dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
	dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
	bAttr _ B3DPrimitiveFaceAttributes new.
	bAttr value: v0 blueValue; dvdx: dvdx; dvdy: dvdy.
	gAttr nextAttr: bAttr.
	"Alpha"
	majorDv _ v2 alphaValue - v0 alphaValue.
	minorDv _ v1 alphaValue - v0 alphaValue.
	dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
	dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
	aAttr _ B3DPrimitiveFaceAttributes new.
	aAttr value: v0 alphaValue; dvdx: dvdx; dvdy: dvdy.
	bAttr nextAttr: aAttr.

	"W part"
	texture == nil ifFalse:[
		w0 _ v0 rasterPosW. w1 _ v1 rasterPosW. w2 _ v2 rasterPosW.
		majorDv _ w2 - w0.
		minorDv _ w1 - w0.
		dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
		dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
		wAttr _ B3DPrimitiveFaceAttributes new.
		wAttr value: w0; dvdx: dvdx; dvdy: dvdy.
		aAttr nextAttr: wAttr.

		baseValue _ v0 texCoordS * w0.
		majorDv _ (v2 texCoordS * w2) - baseValue.
		minorDv _ (v1 texCoordS * w1) - baseValue.
		dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
		dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
		sAttr _ B3DPrimitiveFaceAttributes new.
		sAttr value: baseValue; dvdx: dvdx; dvdy: dvdy.
		wAttr nextAttr: sAttr.

		baseValue _ v0 texCoordT * w0.
		majorDv _ (v2 texCoordT * w2) - baseValue.
		minorDv _ (v1 texCoordT * w1) - baseValue.
		dvdx _ oneOverArea * ((majorDv * minorDy) - (minorDv * majorDy)).
		dvdy _ oneOverArea * ((majorDx * minorDv) - (majorDv * minorDx)).
		tAttr _ B3DPrimitiveFaceAttributes new.
		tAttr value: baseValue; dvdx: dvdx; dvdy: dvdy.
		sAttr nextAttr: tAttr.
	].! !

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/4/1999 21:54'!
v0: vtx0 v1: vtx1 v2: vtx2
	v0 _ vtx0.
	v1 _ vtx1.
	v2 _ vtx2.
	flags _ 0.! !

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/7/1999 01:01'!
validateDepthSetup
	oneOverArea = 0.0 ifTrue:[^self].
	(v0 rasterPosZ - (self zValueAtX: v0 rasterPosX y: v0 rasterPosY)) abs >= 1.0e-10 
		ifTrue:[self error:'Depth problem'].
	(v1 rasterPosZ - (self zValueAtX: v1 rasterPosX y: v1 rasterPosY)) abs >= 1.0e-10 
		ifTrue:[self error:'Depth problem'].
	(v2 rasterPosZ - (self zValueAtX: v2 rasterPosX y: v2 rasterPosY)) abs >= 1.0e-10 
		ifTrue:[self error:'Depth problem'].! !

!B3DPrimitiveFace methodsFor: 'initialize' stamp: 'ar 4/3/1999 21:24'!
validateVertexOrder
	(v0 sortsBefore: v1) ifFalse:[self error:'Vertex order problem'].
	(v0 sortsBefore: v2) ifFalse:[self error:'Vertex order problem'].
	(v1 sortsBefore: v2) ifFalse:[self error:'Vertex order problem'].! !


!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/6/1999 22:40'!
attributes
	^attributes! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 04:13'!
dzdx
	^dzdx! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 04:13'!
dzdy
	^dzdy! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:34'!
flags
	^flags! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:34'!
flags: anInteger
	flags _ anInteger! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 19:05'!
leftEdge
	^leftEdge! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 19:06'!
leftEdge: anEdge
	leftEdge _ anEdge! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 18:22'!
maxZ
	^maxZ! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 18:21'!
minZ
	^minZ! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
nextFace
	^nextFace! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:34'!
nextFace: aFace
	nextFace _ aFace! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 19:03'!
oneOverArea
	^oneOverArea! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:33'!
prevFace
	^prevFace! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 00:34'!
prevFace: aFace
	prevFace _ aFace! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 19:05'!
rightEdge
	^rightEdge! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/5/1999 19:06'!
rightEdge: anEdge
	rightEdge _ anEdge! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:20'!
texture
	^texture! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:20'!
texture: aTexture
	texture _ aTexture! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 21:32'!
vertex0
	^v0! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 21:32'!
vertex1
	^v1! !

!B3DPrimitiveFace methodsFor: 'accessing' stamp: 'ar 4/3/1999 21:32'!
vertex2
	^v2! !


!B3DPrimitiveFace methodsFor: 'processing' stamp: 'ar 4/18/1999 06:34'!
attrValue: attr atX: xValue y: yValue
	"Return the value of the attribute at position xValue@yValue"
	^attr valueAtX: (xValue - v0 rasterPosX) y: (yValue - v0 rasterPosY).! !

!B3DPrimitiveFace methodsFor: 'processing' stamp: 'ar 4/8/1999 04:31'!
zValueAtX: xValue y: yValue
	"Return the z value of the receiver at position xValue@yValue"
	^v0 rasterPosZ +
		(yValue - v0 rasterPosY * dzdy) +
		(xValue - v0 rasterPosX * dzdx)! !


!B3DPrimitiveFace methodsFor: 'printing' stamp: 'ar 4/5/1999 01:22'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$(;
		print: (v0 windowPos bitShiftPoint:-12);
		nextPutAll:' - ';
		print: (v1 windowPos bitShiftPoint: -12);
		nextPutAll:' - ';
		print: (v2 windowPos bitShiftPoint: -12);
		nextPut:$).! !
Object subclass: #B3DPrimitiveFaceAttributes
	instanceVariableNames: 'nextAttr value dvdx dvdy '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:33'!
dvdx
	^dvdx! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:33'!
dvdx: aNumber
	dvdx _ aNumber! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:33'!
dvdy
	^dvdy! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:33'!
dvdy: aNumber
	dvdy _ aNumber! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:32'!
nextAttr
	^nextAttr! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:32'!
nextAttr: attr
	nextAttr _ attr.! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:32'!
value
	^value! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:32'!
value: aNumber
	value _ aNumber! !

!B3DPrimitiveFaceAttributes methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:34'!
valueAtX: xValue y: yValue
	"Return the value of the attribute at position xValue@yValue"
	^value + (yValue * dvdy) + (xValue * dvdx)! !
B3DMaterialColor variableWordSubclass: #B3DPrimitiveLight
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-PrimitiveEngine'!

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:51'!
attenuation
	"Return the light attenuation.
	This member is only valid if the light is attenuated."
	^B3DLightAttenuation
		constant: self constantAttenuation
		linear: self linearAttenuation
		squared: self squaredAttenuation! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:52'!
attenuation: aLightAttenuation
	"Set the light attenuation.
	This member is only valid if the light is attenuated."
	self constantAttenuation: aLightAttenuation constantPart.
	self linearAttenuation: aLightAttenuation linearPart.
	self squaredAttenuation: aLightAttenuation squaredPart.! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:47'!
direction
	"Return the direction of the light.
	This member is valid only if the light is not positional 
	(e.g., the direction must be computed for every vertex)"
	^B3DVector3
		x: self directionX
		y: self directionY
		z: self directionZ! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:49'!
direction: aB3DVector
	"Set the direction of the light.
	This member is valid only if the light is positional 
	(e.g., the direction must be computed for every vertex)"
	self directionX: aB3DVector x.
	self directionY: aB3DVector y.
	self directionZ: aB3DVector z.! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
flags
	^self wordAt: PrimLightFlags+1! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
flags: aValue
	^self wordAt: PrimLightFlags+1 put: aValue! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:49'!
position
	"Return the position of the light.
	This member is valid only if the light is not positional 
	(e.g., the direction must be computed for every vertex)"
	^B3DVector3
		x: self positionX
		y: self positionY
		z: self positionZ! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 03:48'!
position: aB3DVector
	"Set the position of the light.
	This member is valid only if the light is positional 
	(e.g., the direction must be computed for every vertex)"
	self positionX: aB3DVector x.
	self positionY: aB3DVector y.
	self positionZ: aB3DVector z.! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
spotDeltaCos
	^self floatAt: SpotLightDeltaCos+1! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
spotDeltaCos: aFloat
	^self floatAt: SpotLightDeltaCos+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
spotExponent
	^self floatAt: SpotLightExponent+1! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:17'!
spotExponent: aFloat
	^self floatAt: SpotLightExponent+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:18'!
spotMaxCos
	^self floatAt: SpotLightMaxCos+1! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:18'!
spotMaxCos: aFloat
	^self floatAt: SpotLightMaxCos+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:18'!
spotMinCos
	^self floatAt: SpotLightMinCos+1! !

!B3DPrimitiveLight methodsFor: 'accessing' stamp: 'ar 2/15/1999 22:18'!
spotMinCos: aFloat
	^self floatAt: SpotLightMinCos+1 put: aFloat! !


!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:14'!
constantAttenuation
	^self floatAt: PrimLightAttenuationConstant+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:14'!
constantAttenuation: aFloat
	^self floatAt: PrimLightAttenuationConstant+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:14'!
directionX
	^self floatAt: PrimLightDirectionX+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:14'!
directionX: aFloat
	^self floatAt: PrimLightDirectionX+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:14'!
directionY
	^self floatAt: PrimLightDirectionY+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
directionY: aFloat
	^self floatAt: PrimLightDirectionY+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
directionZ
	^self floatAt: PrimLightDirectionZ+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
directionZ: aFloat
	^self floatAt: PrimLightDirectionZ+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
linearAttenuation
	^self floatAt: PrimLightAttenuationLinear+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
linearAttenuation: aFloat
	^self floatAt: PrimLightAttenuationLinear+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionX
	^self floatAt: PrimLightPositionX+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionX: aFloat
	^self floatAt: PrimLightPositionX+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionY
	^self floatAt: PrimLightPositionY+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionY: aFloat
	^self floatAt: PrimLightPositionY+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionZ
	^self floatAt: PrimLightPositionZ+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
positionZ: aFloat
	^self floatAt: PrimLightPositionZ+1 put: aFloat! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
squaredAttenuation
	^self floatAt: PrimLightAttenuationSquared+1! !

!B3DPrimitiveLight methodsFor: 'element access' stamp: 'ar 2/15/1999 22:15'!
squaredAttenuation: aFloat
	^self floatAt: PrimLightAttenuationSquared+1 put: aFloat! !

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

B3DPrimitiveLight class
	instanceVariableNames: ''!

!B3DPrimitiveLight class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 22:11'!
numElements
	^PrimLightSize! !
Object subclass: #B3DPrimitiveObject
	instanceVariableNames: 'next prev texture bounds minZ maxZ start faces vertices '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:43'!
bounds
	^bounds! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 04:49'!
faces
	^faces! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 04:49'!
faces: anArray
	faces _ anArray! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:44'!
nextObj
	^next! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:44'!
nextObj: obj
	next _ obj! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:44'!
prevObj
	^prev! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:45'!
prevObj: obj
	prev _ obj! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:56'!
texture
	^texture! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 06:56'!
texture: aTexture
	texture _ aTexture! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 04:49'!
vertices
	^vertices! !

!B3DPrimitiveObject methodsFor: 'accessing' stamp: 'ar 4/18/1999 04:49'!
vertices: anArray
	vertices _ anArray! !


!B3DPrimitiveObject methodsFor: 'processing' stamp: 'ar 4/18/1999 05:44'!
mapVertices: viewport
	"Map all the vertices in the receiver"
	| xOfs yOfs xScale yScale w x y z scaledX scaledY first |
	xOfs _ (viewport origin x + viewport corner x) * 0.5 - 0.5.
	yOfs _ (viewport origin y + viewport corner y) * 0.5 - 0.5.
	xScale _ (viewport corner x - viewport origin x) * 0.5.
	yScale _ (viewport corner y - viewport origin y) * -0.5.
	bounds _ 16r3FFFFFFF asPoint extent: 0@0.
	minZ _ maxZ _ 0.0.
	first _ true.
	vertices do:[:vtx|
		w _ vtx rasterPosW.
		w = 0.0 ifFalse:[w _ 1.0 / w].
		x _ vtx rasterPosX * w * xScale + xOfs.
		y _ vtx rasterPosY * w * yScale + yOfs.
		z _ vtx rasterPosZ * w.
		vtx rasterPosW: w.
		vtx rasterPosZ: z.
		scaledX _ (x * 4096.0) asInteger.
		scaledY _ (y * 4096.0) asInteger.
		vtx windowPosX: scaledX.
		vtx windowPosY: scaledY.
		true ifTrue:[
			vtx rasterPosX: scaledX / 4096.0.
			vtx rasterPosY: scaledY / 4096.0.
		] ifFalse:[
			vtx rasterPosX: x.
			vtx rasterPosY: y.
		].
		first ifTrue:[
			bounds _ scaledX@scaledY extent: 0@0.
			minZ _ maxZ _ z.
			first _ false.
		] ifFalse:[
			bounds _ bounds encompass: scaledX@scaledY.
			minZ _ minZ min: z. 
			maxZ _ maxZ max: z.
		].
	].
	bounds _ (bounds origin bitShiftPoint: -12) corner: (bounds corner bitShiftPoint: -12).! !

!B3DPrimitiveObject methodsFor: 'processing' stamp: 'ar 4/18/1999 05:12'!
setupVertexOrder
	faces do:[:face| self setupVertexOrder: face].! !

!B3DPrimitiveObject methodsFor: 'processing' stamp: 'ar 4/18/1999 05:10'!
setupVertexOrder: face
	| p1 p2 i1 i2 i3 p3  |
	i1 _ face p1Index.
	i2 _ face p2Index.
	i3 _ face p3Index.
	p1 _ vertices at: i1.
	p2 _ vertices at: i2.
	p3 _ vertices at: i3.
	(p1 sortsBefore: p2) ifTrue:[
		(p2 sortsBefore: p3) ifTrue:[
			face p1Index: i1; p2Index: i2; p3Index: i3.
		] ifFalse:[
			(p1 sortsBefore: p3)
				ifTrue:[face p1Index: i1; p2Index: i3; p3Index: i2]
				ifFalse:[face p1Index: i3; p2Index: i1; p3Index: i2]
		].
	] ifFalse:[
		(p1 sortsBefore: p3) ifTrue:[
			face p1Index: i2; p2Index: i1; p3Index: i3.
		] ifFalse:[
			(p2 sortsBefore: p3)
				ifTrue:[face p1Index: i2; p2Index: i3; p3Index: i1]
				ifFalse:[face p1Index: i3; p2Index: i2; p3Index: i1]
		]
	].
	B3DScanner doDebug ifTrue:[
		p1 _ vertices at: face p1Index.
		p2 _ vertices at: face p2Index.
		p3 _ vertices at: face p3Index.
		((p1 sortsBefore: p2) and:[(p2 sortsBefore: p3) and:[p1 sortsBefore: p3]])
			ifFalse:[self error:'Vertex order problem'].
	].
! !

!B3DPrimitiveObject methodsFor: 'processing' stamp: 'ar 4/18/1999 05:13'!
sortInitialFaces
	faces _ faces sortBy:[:face1 :face2| (vertices at: face1 p1Index) sortsBefore: (vertices at: face2 p1Index)].! !


!B3DPrimitiveObject methodsFor: 'initialize' stamp: 'ar 4/18/1999 05:22'!
reset
	start _ 0.! !


!B3DPrimitiveObject methodsFor: 'streaming' stamp: 'ar 4/18/1999 05:26'!
atEnd
	^start >= faces size! !

!B3DPrimitiveObject methodsFor: 'streaming' stamp: 'ar 4/18/1999 06:55'!
next
	| iFace face |
	iFace _ faces at: (start _ start + 1).
	face _ B3DPrimitiveFace new.
	face 
		v0: (vertices at: iFace p1Index)
		v1: (vertices at: iFace p2Index)
		v2: (vertices at: iFace p3Index).
	face texture: texture.
	face initializePass1.
	B3DScanner doDebug ifTrue:[
		face validateVertexOrder.
		face validateDepthSetup].
	^face! !

!B3DPrimitiveObject methodsFor: 'streaming' stamp: 'ar 4/18/1999 05:25'!
peekY
	^(vertices at: (faces at: start+1) p1Index) windowPosY! !
B3DVertexRasterizer subclass: #B3DPrimitiveRasterizer
	instanceVariableNames: 'state primObjects textures '
	classVariableNames: 'B3DNoMoreAET B3DNoMoreAdded B3DNoMoreAttrs B3DNoMoreEdges B3DNoMoreFaces '
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!

!B3DPrimitiveRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:41'!
clipRect: aRectangle
	super clipRect: aRectangle.
	state bitBlt clipRect: aRectangle.! !

!B3DPrimitiveRasterizer methodsFor: 'initialize' stamp: 'ar 4/17/1999 21:10'!
flush
	self mainLoop.! !

!B3DPrimitiveRasterizer methodsFor: 'initialize' stamp: 'ar 4/16/1999 07:54'!
initialize
	super initialize.
	primObjects _ WriteStream on: (Array new: 100).
	state _ B3DPrimitiveRasterizerState new.
	state initialize.
	textures _ IdentityDictionary new: 33.! !

!B3DPrimitiveRasterizer methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:53'!
reset
	super reset.
	state reset.! !

!B3DPrimitiveRasterizer methodsFor: 'initialize' stamp: 'ar 5/28/2000 12:16'!
target: aForm
	| bb span sourceForm |
	super target: aForm.
	target ifNil:[^self].
	"Note: span must be Bitmap since software rasterizer expects canonical RGBA for now"
	span _ Bitmap new: 2048.
	sourceForm _ Form extent: span size@1 depth: 32 bits: span.
	bb _ BitBlt current toForm: target.
	self class primitiveSetBitBltPlugin: bb getPluginName.
	bb sourceForm: sourceForm.
	bb isFXBlt ifTrue:[
		"Specific setup for FXBlt is necessary"
		bb colorMap: (sourceForm colormapIfNeededFor: target).
		bb combinationRule: (target depth >= 8 ifTrue:[34] ifFalse:[Form paint]).
	] ifFalse:[
		bb colorMap: (sourceForm colormapIfNeededForDepth: target depth).
		bb combinationRule: (target depth >= 8 ifTrue:[34] ifFalse:[Form paint]).
	].
	bb destX: 0; destY: 0; sourceX: 0; sourceY: 0; width: 1; height: 1.
	state spanBuffer: span.
	state bitBlt: bb.! !



!B3DPrimitiveRasterizer methodsFor: 'testing' stamp: 'ar 4/14/1999 02:08'!
needsClip
	^true! !


!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 11/7/1999 18:47'!
addPrimitiveObject: vb ofSize: objSize
	| obj textureIndex |
	texture == nil
		ifTrue:[textureIndex _ 0]
		ifFalse:[textureIndex _ textures at: texture ifAbsentPut:[textures size+1]].
	obj _ B3DPrimitiveRasterizerData new: objSize.
	self primAddObject: obj
		primitive: vb primitive
		vertexArray: vb vertexArray
		size: vb vertexCount
		indexArray: vb indexArray
		size: vb indexCount
		viewport: viewport
		textureIndex: textureIndex.
	primObjects nextPut: obj.
	"AAARRRRGGGGGHHHH - we should do this differently!!!!!!!!"
	vbBounds _ (obj integerAt: 9) @ (obj integerAt: 11) corner: (obj integerAt: 10) @ (obj integerAt: 12).! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 5/26/2000 15:41'!
debugDrawVB: vb
	| vtx idx1 idx2 idx3 v1 v2 v3 vp myCanvas |
	myCanvas _ target getCanvas.
	vp _ viewport clone.
	vtx _ Array new: vb vertexCount.
	vb vertexArray upTo: vb vertexCount doWithIndex:[:v :i|
		vtx at: i put: (vp mapVertex4: v rasterPos).
	].
	1 to: vb indexCount-1 by: 3 do:[:i|
		idx1 _ vb indexArray at: i.
		idx2 _ vb indexArray at: i+1.
		idx3 _ vb indexArray at: i+2.
		idx1 = 0 ifFalse:[
			v1 _ vtx at: idx1.
			v2 _ vtx at: idx2.
			v3 _ vtx at: idx3.
			myCanvas line: v1 to: v2 width: 1 color: Color black.
			myCanvas line: v2 to: v3 width: 1 color: Color black.
			myCanvas line: v3 to: v1 width: 1 color: Color black.
		].
	].! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 11/7/1999 22:25'!
mainLoop
	"Do the actual rasterization"
	| errCode objects textureArray |
	objects _ primObjects contents.
	objects size = 0 ifTrue:[^self]. "Nothing to do"
	textureArray _ Array new: textures size.
	textures associationsDo:[:assoc| textureArray at: assoc value put: assoc key].
	state initObjects: objects size.
	state initTextures: textureArray size.
	textureArray do:[:tex| tex unhibernate].
	[errCode _ self primStartRasterizer: state objects: objects textures: textureArray.
	errCode = 0] whileFalse:[
		"Not yet finished"
		self processErrorCode: (errCode bitAnd: 255).
		state reset].
	primObjects reset.
	textures _ IdentityDictionary new: textures capacity.
	false ifTrue:[self printSpaceUsage: objects].
! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/12/1999 02:32'!
processErrorCode: errCode
	errCode = 0 ifTrue:[^true]. "This is allowed!!"
	(errCode = B3DNoMoreEdges) 
		ifTrue:[^state growEdges].
	(errCode = B3DNoMoreFaces)
		ifTrue:[^state growFaces].
	(errCode = B3DNoMoreAttrs)
		ifTrue:[^state growAttrs].
	(errCode = B3DNoMoreAET)
		ifTrue:[^state growAET].
	(errCode = B3DNoMoreAdded)
		ifTrue:[^state growAdded].
	self error:'Unknown rasterizer error code ', errCode printString.! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/17/1999 20:29'!
processIndexedLines: vb
	"Process an indexed line set"
	self error:'Indexed lines are not yet implemented'! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 10/30/2000 20:38'!
processIndexedQuads: vb
	"Process an indexed quad set"
	| objSize |
	self flag: #workAround. 
	"There's a bug in the primitive code (now fixed) overwriting more
	than the expected size of the buffer. But older VMs are likely to have
	it so here's what we do..."
	objSize _ self primObjectSize + (vb vertexCount + 1 * PrimVertexSize) + (
		"Workaround for bug in the primitive"
		vb indexCount // 4 * 6 "<- this is what we really need (nQuads * 2 * 3 words per tri)" 
		* 2 "BUG BUG BUG").
	self addPrimitiveObject: vb ofSize: objSize.! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 9/10/1999 14:59'!
processIndexedTriangles: vb
	| objSize |
	objSize _ self primObjectSize + (vb vertexCount + 1 * PrimVertexSize) + (vb indexCount).
	self addPrimitiveObject: vb ofSize: objSize.! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/17/1999 20:29'!
processLineLoop: vb
	"Process a closed line defined by the vertex buffer"
	self error:'Lines are not yet implemented'! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/17/1999 20:29'!
processLines: vb
	"Process a series of lines defined by each two points the vertex buffer"
	self error:'Lines are not yet implemented'! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/17/1999 20:30'!
processPoints: vertexBuffer
	"Process a series of points defined by the vertex buffer"
	self error:'Points are not yet implemented'! !

!B3DPrimitiveRasterizer methodsFor: 'processing' stamp: 'ar 4/17/1999 21:02'!
processPolygon: vb
	"Process a polygon defined by the vertex buffer"
	| objSize |
	objSize _ self primObjectSize + (vb vertexCount * PrimVertexSize) + (vb vertexCount - 2 * 3).
	self addPrimitiveObject: vb ofSize: objSize.! !


!B3DPrimitiveRasterizer methodsFor: 'primitives' stamp: 'ar 4/14/1999 05:12'!
primAddObject: obj primitive: primitive vertexArray: vertexArray size: vertexCount indexArray: indexArray size: indexCount viewport: vp textureIndex: txIndex
	<primitive:'b3dInitPrimitiveObject' module:'Squeak3D'>
	^self primitiveFailed! !

!B3DPrimitiveRasterizer methodsFor: 'primitives' stamp: 'ar 4/12/1999 02:17'!
primObjectSize
	<primitive: 'b3dPrimitiveObjectSize' module:'Squeak3D'>
	^self primitiveFailed! !

!B3DPrimitiveRasterizer methodsFor: 'primitives' stamp: 'ar 4/14/1999 05:18'!
primStartRasterizer: primState objects: primitiveObjects textures: textureArray
	"Primitive. Start the rasterizer. Return an error code."
	<primitive:'b3dStartRasterizer' module:'Squeak3D'>
	^self primitiveFailed! !


!B3DPrimitiveRasterizer methodsFor: 'private' stamp: 'ar 4/13/1999 02:13'!
printSpaceUsage: objects
	"Print out the maximum space used for processing the given objects"
	| spaceUsed |
	spaceUsed _ state spaceUsed.
	objects do:[:obj| spaceUsed _ spaceUsed + obj basicSize].
	spaceUsed _ spaceUsed * 4.
	Transcript cr; nextPutAll: spaceUsed asStringWithCommas; nextPutAll:' bytes max working set'; endEntry.! !

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

B3DPrimitiveRasterizer class
	instanceVariableNames: ''!

!B3DPrimitiveRasterizer class methodsFor: 'class initialization' stamp: 'ar 4/13/1999 01:52'!
initialize
	"B3DPrimitiveRasterizer initialize"
	B3DNoMoreEdges _ 1.
	B3DNoMoreFaces _ 2.
	B3DNoMoreAttrs _ 3.
	B3DNoMoreAET _ 4.
	B3DNoMoreAdded _ 5.! !


!B3DPrimitiveRasterizer class methodsFor: 'accessing' stamp: 'ar 4/12/1999 03:46'!
version
	"B3DPrimitiveRasterizer version"
	<primitive:'b3dRasterizerVersion' module:'Squeak3D'>
	^0! !


!B3DPrimitiveRasterizer class methodsFor: 'testing' stamp: 'ar 4/12/1999 03:48'!
isAvailable
	^self version > 0! !


!B3DPrimitiveRasterizer class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'!
primitiveSetBitBltPlugin: pluginName
	<primitive: 'primitiveSetBitBltPlugin' module: 'Squeak3D'>
	^nil! !
Object variableWordSubclass: #B3DPrimitiveRasterizerData
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!
!B3DPrimitiveRasterizerData commentStamp: '<historical>' prior: 0!
Instances of this class represent data on the primitive level. The major reason for the existance of this class is that all memory needed by the rasterizer is allocated from Smalltalk code[*]. Instances of this class should not be modified from Smalltalk code - they may contain pointers to other memory locations and thus modification of these instances could easily break the system.

[*] This is for two reasons:
	* Some systems (e.g., Mac) don't have the necessary allocation facilities from the primitive level (This REALLY sucks. We have 1999 and MacOS 8.5.1 still has static memory allocation!!)
	* Allocation from Smalltalk allows us to share memory between Smalltalk and C code, take advantage of GCs if the physically available space is small (e.g., on PDAs) as well as gracefully failing if there is no memory left (e.g., by signalling the low space condition).
!


!B3DPrimitiveRasterizerData methodsFor: 'accessing' stamp: 'ar 4/10/1999 05:36'!
at: index put: value
	"See the class comment"
	^self error:'You must not modify primitive level data'! !

!B3DPrimitiveRasterizerData methodsFor: 'accessing' stamp: 'ar 11/7/1999 18:09'!
integerAt: index
	"Return the integer at the given index"
	| word |
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !


!B3DPrimitiveRasterizerData methodsFor: 'private' stamp: 'ar 4/12/1999 02:36'!
replaceFrom: start to: stop with: replacement startingAt: repStart
	"Private. Used for growing rasterizer data only."
	<primitive: 105>
	^self primitiveFailed! !
Object subclass: #B3DPrimitiveRasterizerState
	instanceVariableNames: 'faceAlloc edgeAlloc attrAlloc aet addedEdges fillList objects textures spanBuffer bitBlt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!
!B3DPrimitiveRasterizerState commentStamp: '<historical>' prior: 0!
This class represents a set of objects that are known to the primitive level rasterizer. It should not be modified unless you know *exactly* what you're doing. The instance variables could actually be indexed but I decided to give them names for readability.

Instance variables:
	faceAlloc	<B3DPrimitiveRasterizerData>	- Source for primitive level face allocation.
	edgeAlloc	<B3DPrimitiveRasterizerData>	- Source for primitive level edge allocation.
	attrAlloc	<B3DPrimitiveRasterizerData>	- Source for primitive level attribute allocation.
	aet			<B3DPrimitiveRasterizerData>	- Primitive level active edge table.
	addedEdges	<B3DPrimitiveRasterizerData>	- Primitive level temporary edge storage.
	fillList		<B3DPrimitiveRasterizerData>	- Primitive level fill list.
	objects		<B3DPrimitiveRasterizerData> - Primitive level list of objects.
	textures		<B3DPrimitiveRasterizerData> - Primitive level lists of textures.
	spanBuffer	<Bitmap>						- 32bit bitmap to render into
	bitBlt		<BitBlt>						- Final output device
!


!B3DPrimitiveRasterizerState methodsFor: 'initialize' stamp: 'ar 4/14/1999 05:14'!
initObjects: nObjects
	objects _ B3DPrimitiveRasterizerData new: nObjects! !

!B3DPrimitiveRasterizerState methodsFor: 'initialize' stamp: 'ar 4/14/1999 05:13'!
initTextures: nTextures
	textures _ B3DPrimitiveRasterizerData new: (self primTextureSize * nTextures).! !

!B3DPrimitiveRasterizerState methodsFor: 'initialize' stamp: 'ar 4/13/1999 06:29'!
initialize
	faceAlloc ifNil:[faceAlloc _ B3DPrimitiveRasterizerData new: 32768].
	edgeAlloc ifNil:[edgeAlloc _ B3DPrimitiveRasterizerData new: 16384].
	attrAlloc ifNil:[attrAlloc _ B3DPrimitiveRasterizerData new: 4096].
	aet ifNil:[aet _ B3DPrimitiveRasterizerData new: 4096].
	addedEdges ifNil:[addedEdges _ B3DPrimitiveRasterizerData new: 4096].
	fillList ifNil:[fillList _ B3DPrimitiveRasterizerData new: 32].
	self primInitializeBuffers.! !

!B3DPrimitiveRasterizerState methodsFor: 'initialize' stamp: 'ar 4/11/1999 23:47'!
reset
	self primInitializeBuffers.! !


!B3DPrimitiveRasterizerState methodsFor: 'accessing' stamp: 'ar 4/13/1999 00:10'!
bitBlt
	^bitBlt! !

!B3DPrimitiveRasterizerState methodsFor: 'accessing' stamp: 'ar 4/13/1999 00:10'!
bitBlt: aBitBlt
	bitBlt _ aBitBlt.! !

!B3DPrimitiveRasterizerState methodsFor: 'accessing' stamp: 'ar 4/13/1999 02:09'!
spaceUsed
	^faceAlloc basicSize + edgeAlloc basicSize + attrAlloc basicSize + aet basicSize + addedEdges basicSize + fillList basicSize + objects basicSize + spanBuffer basicSize! !

!B3DPrimitiveRasterizerState methodsFor: 'accessing' stamp: 'ar 4/13/1999 00:10'!
spanBuffer
	^spanBuffer! !

!B3DPrimitiveRasterizerState methodsFor: 'accessing' stamp: 'ar 4/13/1999 00:10'!
spanBuffer: aBitmap
	spanBuffer _ aBitmap.! !


!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/14/1999 01:45'!
grow: anArray
	| newArray |
	newArray _ anArray species new: anArray size + (anArray size // 4 max: 100).
	newArray replaceFrom: 1 to: anArray size with: anArray startingAt: 1.
	^newArray! !

!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/13/1999 06:30'!
growAET
	"Transcript cr; show:'Growing AET'."
	aet _ self grow: aet.! !

!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/13/1999 06:30'!
growAdded
	"Transcript cr; show:'Growing addedEdges'."
	aet _ self grow: addedEdges.! !

!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/13/1999 06:30'!
growAttrs
	"Transcript cr; show:'Growing attrAlloc'."
	attrAlloc _ self grow: attrAlloc.! !

!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/13/1999 06:30'!
growEdges
	"Transcript cr; show:'Growing edgeAlloc'."
	edgeAlloc _ self grow: edgeAlloc.! !

!B3DPrimitiveRasterizerState methodsFor: 'growing' stamp: 'ar 4/13/1999 06:30'!
growFaces
	"Transcript cr; show:'Growing faceAlloc'."
	faceAlloc _ self grow: faceAlloc.! !


!B3DPrimitiveRasterizerState methodsFor: 'private' stamp: 'ar 4/10/1999 21:29'!
primInitializeBuffers
	<primitive: 'b3dInitializeRasterizerState' module:'Squeak3D'>
	^self primitiveFailed! !

!B3DPrimitiveRasterizerState methodsFor: 'private' stamp: 'ar 4/14/1999 05:13'!
primTextureSize
	<primitive:'b3dPrimitiveTextureSize' module:'Squeak3D'>
	^self primitiveFailed! !
B3DVertexShader subclass: #B3DPrimitiveShader
	instanceVariableNames: 'primitiveLights '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!
!B3DPrimitiveShader commentStamp: '<historical>' prior: 0!
I am a shader that uses primitive level support.
NOTE: Currently, primitive and non-primitive lights cannot be mixed.!


!B3DPrimitiveShader methodsFor: 'initialize' stamp: 'ar 2/17/1999 04:17'!
initialize
	super initialize.
	primitiveLights _ #().! !

!B3DPrimitiveShader methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:56'!
reset
	super reset.
	primitiveLights _ #().! !


!B3DPrimitiveShader methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:14'!
addLight: aLightSource
	"NOTE: This does not work if primitive/non-primitive lights are mixed!!"
	| primLight |
	self flag: #b3dBug. "See above"
	primLight _ aLightSource asPrimitiveLight.
	primLight ifNotNil:[primitiveLights _ primitiveLights copyWith: primLight].
	^super addLight: aLightSource! !

!B3DPrimitiveShader methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:17'!
removeLight: lightIndex
	| pLight |
	super removeLight: lightIndex.
	self flag: #b3dBug. 
	"There should be a better way then doing this."
	primitiveLights _ #().
	lights do:[:light| 
		light ifNotNil:[pLight _ light asPrimitiveLight].
		pLight ifNotNil:[primitiveLights _ primitiveLights copyWith: pLight]].! !


!B3DPrimitiveShader methodsFor: 'shading' stamp: 'ar 2/17/1999 04:10'!
primShadeVB: vertexArray count: vtxCount lights: lightArray material: aMaterial vbFlags: vbFlags
	"Primitive. Shade all the vertices in the vertex buffer using the given array of primitive light sources. Return true on success, false otherwise."
	<primitive: 'b3dShadeVertexBuffer' module:'Squeak3D'>
	self flag: #b3dDebug. self primitiveFailed.
	^false! !

!B3DPrimitiveShader methodsFor: 'shading' stamp: 'ar 2/17/1999 04:11'!
processVertexBuffer: vb
	"Do the primitive operation"
	(self primShadeVB: vb vertexArray 
				count: vb vertexCount 
				lights: primitiveLights 
				material: material 
				vbFlags: vb flags) ifTrue:[^self].
	"Run simulation instead"
	super processVertexBuffer: vb.! !

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

B3DPrimitiveShader class
	instanceVariableNames: ''!

!B3DPrimitiveShader class methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:09'!
version
	"Return the version of this shader"
	<primitive:'b3dShaderVersion' module:'Squeak3D'>
	^0! !


!B3DPrimitiveShader class methodsFor: 'testing' stamp: 'ar 2/17/1999 04:08'!
isAvailable
	^self version > 0! !
B3DVertexTransformer subclass: #B3DPrimitiveTransformer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-PrimitiveEngine'!
!B3DPrimitiveTransformer commentStamp: '<historical>' prior: 0!
I am a vertex transformer that uses some primitive level support.!


!B3DPrimitiveTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:19'!
privateTransformMatrix: m1 with: m2 into: m3
	"Use the primitive operation"
	<primitive: 'b3dTransformMatrixWithInto' module:'Squeak3D'>
	^super privateTransformMatrix: m1 with: m2 into: m3! !

!B3DPrimitiveTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:20'!
privateTransformPrimitiveNormal: primitiveVertex byMatrix: aMatrix rescale: scaleNeeded
	"Use the primitive operation"
	<primitive: 'b3dTransformPrimitiveNormal' module:'Squeak3D'>
	^super privateTransformPrimitiveNormal: primitiveVertex byMatrix: aMatrix rescale: scaleNeeded! !

!B3DPrimitiveTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:20'!
privateTransformPrimitiveVertex: primitiveVertex byModelView: aMatrix
	"Use the primitive operation"
	<primitive: 'b3dTransformPrimitivePosition' module:'Squeak3D'>
	^super privateTransformPrimitiveVertex: primitiveVertex byModelView: aMatrix! !

!B3DPrimitiveTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:21'!
privateTransformPrimitiveVertex: primitiveVertex byProjection: aMatrix
	"Use the primitive operation"
	<primitive: 'b3dTransformPrimitiveRasterPosition' module:'Squeak3D'>
	^super privateTransformPrimitiveVertex: primitiveVertex byProjection: aMatrix! !

!B3DPrimitiveTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:21'!
privateTransformVB: vertexArray count: vertexCount modelViewMatrix: modelViewMatrix projectionMatrix: projectionMatrix flags: flags
	"Use the primitive operation"
	<primitive: 'b3dTransformVertexBuffer' module:'Squeak3D'>
	^super privateTransformVB: vertexArray count: vertexCount modelViewMatrix: modelViewMatrix projectionMatrix: projectionMatrix flags: flags! !

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

B3DPrimitiveTransformer class
	instanceVariableNames: ''!

!B3DPrimitiveTransformer class methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:29'!
version
	"Return the version of this transformer"
	<primitive:'b3dTransformerVersion' module:'Squeak3D'>
	^0! !


!B3DPrimitiveTransformer class methodsFor: 'testing' stamp: 'ar 2/17/1999 04:22'!
isAvailable
	^self version > 0! !
Object variableWordSubclass: #B3DPrimitiveVertex
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Engine'!
!B3DPrimitiveVertex commentStamp: '<historical>' prior: 0!
I represent all per vertex information used in Balloon 3D primitive operations. I store either 32bit floats or integers depending on what is requested.

C representation:

	typedef struct B3DPrimitiveVertex {
		float position[3];
		float normal[3];
		float texCoord[2];
		float rasterPos[4];
		int pixelValue32;
		int clipFlags;
		int windowPos[2];
	} B3DPrimitiveVertex;!


!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/5/1999 19:27'!
b3dColor
	^self color asB3DColor! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/5/1999 19:28'!
b3dColor: aB3DColor4
	self color: aB3DColor4 asColor! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/4/1999 23:53'!
clipFlags
	^self wordAt: 14! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/4/1999 23:53'!
clipFlags: aNumber
	self wordAt: 14 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
color
	^self pixelValue32 asColorOfDepth: 32! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/4/1999 20:21'!
color: aColor
	self pixelValue32: (aColor asColor pixelWordForDepth: 32)! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 4/4/1999 00:29'!
integerAt: index
	| word |
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 4/4/1999 00:29'!
integerAt: index put: anInteger
	| word |
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
normal
	^B3DVector3 
		x: (self floatAt: 4) 
		y: (self floatAt: 5) 
		z: (self floatAt: 6)! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
normal: aVector
	self floatAt: 4 put: aVector x.
	self floatAt: 5 put: aVector y.
	self floatAt: 6 put: aVector z.
! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
pixelValue32
	^self wordAt: 13! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
pixelValue32: aNumber
	self wordAt: 13 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
position
	^B3DVector3 
		x: (self floatAt: 1) 
		y: (self floatAt: 2) 
		z: (self floatAt: 3)! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
position: aVector
	self floatAt: 1 put: aVector x.
	self floatAt: 2 put: aVector y.
	self floatAt: 3 put: aVector z.
! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
rasterPos
	^B3DVector4
		x: (self floatAt: 9) 
		y: (self floatAt: 10) 
		z: (self floatAt: 11)
		w: (self floatAt: 12)! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
rasterPos: aVector
	self floatAt: 9 put: aVector x.
	self floatAt: 10 put: aVector y.
	self floatAt: 11 put: aVector z.
	self floatAt: 12 put: aVector w.! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
texCoords
	^(self floatAt: 7) @ (self floatAt: 8)! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 2/5/1999 19:30'!
texCoords: aVector
	self floatAt: 7 put: aVector x.
	self floatAt: 8 put: aVector y.
! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 4/4/1999 00:21'!
windowPos
	^self windowPosX@self windowPosY! !

!B3DPrimitiveVertex methodsFor: 'accessing' stamp: 'ar 4/4/1999 00:22'!
windowPos: aPoint
	self windowPosX: aPoint x.
	self windowPosY: aPoint y.! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
wordAt: index
	<primitive: 60>
	^self primitiveFailed! !

!B3DPrimitiveVertex methodsFor: 'accessing'!
wordAt: index put: value
	<primitive: 61>
	^self primitiveFailed! !


!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:48'!
normalX
	^self floatAt: 4! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:50'!
normalX: aFloat
	self floatAt: 4 put: aFloat! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:48'!
normalY
	^self floatAt: 5! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:50'!
normalY: aFloat
	self floatAt: 5 put: aFloat! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:48'!
normalZ
	^self floatAt: 6! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 2/8/1999 17:50'!
normalZ: aFloat
	self floatAt: 6 put: aFloat! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionX
	^self floatAt: 1! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionX: aNumber
	self floatAt: 1 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionY
	^self floatAt: 2! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionY: aNumber
	self floatAt: 2 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionZ
	^self floatAt: 3! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
positionZ: aNumber
	self floatAt: 3 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosW
	^self floatAt: 12! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosW: aNumber
	self floatAt: 12 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosX
	^self floatAt: 9! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosX: aNumber
	self floatAt: 9 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosY
	^self floatAt: 10! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosY: aNumber
	self floatAt: 10 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosZ
	^self floatAt: 11! !

!B3DPrimitiveVertex methodsFor: 'transform-support'!
rasterPosZ: aNumber
	self floatAt: 11 put: aNumber! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 4/4/1999 00:31'!
windowPosX
	^self integerAt: 15! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 4/4/1999 00:31'!
windowPosX: anInteger
	self integerAt: 15 put: anInteger! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 4/4/1999 00:31'!
windowPosY
	^self integerAt: 16! !

!B3DPrimitiveVertex methodsFor: 'transform-support' stamp: 'ar 4/4/1999 00:31'!
windowPosY: anInteger
	self integerAt: 16 put: anInteger! !


!B3DPrimitiveVertex methodsFor: 'private'!
privateReplaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	start to: stop do:[:i|
		self basicAt: i put: (replacement basicAt: i - start + repStart).
	].! !


!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:27'!
aValue
	^self pixelValue32 bitShift: -24! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:29'!
alphaValue
	^self pixelValue32 bitShift: -24! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:28'!
bValue
	^self pixelValue32 bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:29'!
blueValue
	^self pixelValue32 bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:28'!
gValue
	^(self pixelValue32 bitShift: -8) bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:29'!
greenValue
	^(self pixelValue32 bitShift: -8) bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:28'!
rValue
	^(self pixelValue32 bitShift: -16) bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/6/1999 22:29'!
redValue
	^(self pixelValue32 bitShift: -16) bitAnd: 255! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/18/1999 06:26'!
texCoordS
	^self floatAt: 7! !

!B3DPrimitiveVertex methodsFor: 'rasterizer-support' stamp: 'ar 4/18/1999 06:26'!
texCoordT
	^self floatAt: 8! !


!B3DPrimitiveVertex methodsFor: 'testing' stamp: 'ar 4/4/1999 00:50'!
sortsBefore: pVertex
	"Return true if the receiver should be sorted before the given primitive vertex.
	Support for rasterizer simulation. Only valid if window position has been computed before."
	| y0 y1 |
	y0 _ self windowPosY.
	y1 _ pVertex windowPosY.
	y0 = y1 
		ifTrue:[^self windowPosX <= pVertex windowPosX]
		ifFalse:[^y0 < y1]! !

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

B3DPrimitiveVertex class
	instanceVariableNames: ''!

!B3DPrimitiveVertex class methodsFor: 'instance creation' stamp: 'ar 2/14/1999 01:23'!
new
	^self new: PrimVertexSize! !
ArrayedCollection variableWordSubclass: #B3DPrimitiveVertexArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Engine'!
!B3DPrimitiveVertexArray commentStamp: '<historical>' prior: 0!
I store Balloon 3D primitive vertices in place. I am used to pass data efficiently to the primitive level during high-bandwidth operations.!


!B3DPrimitiveVertexArray methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:24'!
at: index
	"Return the primitive vertex at the given index"
	| vtx |
	(index < 1 or:[index > self size]) ifTrue:[^self errorSubscriptBounds: index].
	vtx _ B3DPrimitiveVertex new.
	vtx privateReplaceFrom: 1 to: vtx size with: self startingAt: index-1*PrimVertexSize+1.
	^vtx! !

!B3DPrimitiveVertexArray methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:24'!
at: index put: aB3DPrimitiveVertex
	"Store the primitive vertex at the given index in the receiver"
	| idx |
	(index < 1 or:[index > self size]) ifTrue:[^self errorSubscriptBounds: index].
	idx _ index-1*PrimVertexSize.
	self privateReplaceFrom: idx+1 to: idx+PrimVertexSize with: aB3DPrimitiveVertex startingAt: 1.
	^aB3DPrimitiveVertex! !

!B3DPrimitiveVertexArray methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:24'!
size
	"Return the number of primitive vertices that can be stored in the receiver"
	^self basicSize // PrimVertexSize! !


!B3DPrimitiveVertexArray methodsFor: 'private'!
privateReplaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	start to: stop do:[:i|
		self basicAt: i put: (replacement at: i - start + repStart).
	].! !


!B3DPrimitiveVertexArray methodsFor: 'enumerating' stamp: 'ar 2/4/1999 23:57'!
upTo: max do: aBlock
	"Special enumeration message so the client can modify the vertices"
	| vtx |
	1 to: max do:[:i|
		vtx _ self at: i.
		aBlock value: vtx.
		self at: i put: vtx].! !

!B3DPrimitiveVertexArray methodsFor: 'enumerating' stamp: 'ar 2/4/1999 23:59'!
upTo: max doWithIndex: aBlock
	"Special enumeration message so the client can modify the vertices"
	| vtx |
	1 to: max do:[:i|
		vtx _ self at: i.
		aBlock value: vtx value: i.
		self at: i put: vtx].! !

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

B3DPrimitiveVertexArray class
	instanceVariableNames: ''!

!B3DPrimitiveVertexArray class methodsFor: 'instance creation' stamp: 'ar 2/14/1999 01:24'!
new: n
	^super new: (n * PrimVertexSize)! !
B3DEnginePlugin subclass: #B3DRasterizerPlugin
	instanceVariableNames: 'state viewport '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/17/1999 20:57'!
b3dInitPrimitiveObject
	| vtxSize vtxArray idxSize idxArray primitive primOop primObj primSize textureIndex |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'int *vtxArray'.
	self var: #idxArray declareC:'int *idxArray'.
	self var: #primObj declareC:'void *primObj'.
	"Check argument count"
	interpreterProxy methodArgumentCount = 8
		ifFalse:[^interpreterProxy primitiveFail].

	"Fetch the texture index"
	textureIndex _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].

	"Load the viewport"
	self loadViewportFrom: 1.
	interpreterProxy failed ifTrue:[^nil].

	"Fetch and validate the primitive vertex array"
	vtxSize _ interpreterProxy stackIntegerValue: 4.
	vtxArray _ self stackPrimitiveVertexArray: 5 ofSize: vtxSize.
	vtxArray = nil
		ifTrue:[^interpreterProxy primitiveFail].
	"Fetch and validate the primitive index array"
	idxSize _ interpreterProxy stackIntegerValue: 2.
	idxArray _ self stackPrimitiveIndexArray: 3 ofSize: idxSize validate: true forVertexSize: vtxSize.
	idxArray = nil
		ifTrue:[^interpreterProxy primitiveFail].

	"Fetch and validate the primitive type"
	primitive _ interpreterProxy stackIntegerValue: 6.
	(primitive < 1 or:[primitive > PrimTypeMax]) 
		ifTrue:[^interpreterProxy primitiveFail].

	"For now we only support indexed triangles, quads and polys"
	(primitive = 3 or:[primitive = 5 or:[primitive = 6]]) ifFalse:[^interpreterProxy primitiveFail].

	"Load the primitive object"
	primOop _ interpreterProxy stackObjectValue: 7.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: primOop)
		ifFalse:[^interpreterProxy primitiveFail].
	primObj _ interpreterProxy firstIndexableField: primOop.
	primSize _ interpreterProxy byteSizeOf: primOop.

	"Do the work"
	primitive = 3 ifTrue:[
		(self cCode: 'b3dAddPolygonObject((void*) primObj, primSize, B3D_FACE_RGB, textureIndex, (B3DPrimitiveVertex*) vtxArray, vtxSize, &viewport) !!= B3D_NO_ERROR')
			ifTrue:[^interpreterProxy primitiveFail].
	].
	primitive = 5 ifTrue:[
		(self cCode:'b3dAddIndexedTriangleObject((void*) primObj, primSize, B3D_FACE_RGB, textureIndex, (B3DPrimitiveVertex*) vtxArray, vtxSize, (B3DInputFace*) idxArray, idxSize / 3, &viewport) !!= B3D_NO_ERROR') 
			ifTrue:[^interpreterProxy primitiveFail].
	].
	primitive = 6 ifTrue:[
		(self cCode:'b3dAddIndexedQuadObject((void*) primObj, primSize, B3D_FACE_RGB, textureIndex, (B3DPrimitiveVertex*) vtxArray, vtxSize, (B3DInputQuad*) idxArray, idxSize / 4, &viewport) !!= B3D_NO_ERROR')
			ifTrue:[^interpreterProxy primitiveFail].
	].
	"Pop args+rcvr; return primitive object"
	interpreterProxy pop: 9.
	interpreterProxy push: primOop.! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/14/1999 05:59'!
b3dInitializeRasterizerState
	"Primitive. Initialize the primitive level objects of the given rasterizer."
	| stateOop objOop objLen obj |
	self export: true.
	self inline: false.
	self var: #obj declareC:'void *obj'.

	"Check argument count"
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].

	stateOop _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isPointers: stateOop) and:[(interpreterProxy slotSizeOf: stateOop) >= 7])
		ifFalse:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 0 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeFaceAllocator(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 1 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeEdgeAllocator(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 2 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeAttrAllocator(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 3 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeAET(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 4 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeEdgeList(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	objOop _ interpreterProxy fetchPointer: 5 ofObject: stateOop.
	((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop)  not])
		ifTrue:[^interpreterProxy primitiveFail].
	objLen _ interpreterProxy byteSizeOf: objOop.
	obj _ interpreterProxy firstIndexableField: objOop.
	(self cCode: 'b3dInitializeFillList(obj, objLen) !!= B3D_NO_ERROR') 
		ifTrue:[^interpreterProxy primitiveFail].

	"Don't pop anything - return the receiver"! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/14/1999 02:06'!
b3dPrimitiveObjectSize
	"Primitive. Return the minimal number of words needed for a primitive object."
	| objSize |
	self export: true.
	self inline: false.
	objSize _ (self cCode:'sizeof(B3DPrimitiveObject) + sizeof(B3DPrimitiveVertex)') // 4 + 1.
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: objSize.! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/14/1999 05:22'!
b3dPrimitiveTextureSize
	"Primitive. Return the minimal number of words needed for a primitive object."
	| objSize |
	self export: true.
	self inline: false.
	objSize _ (self cCode:'sizeof(B3DTexture)') // 4 + 1.
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: objSize.! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/12/1999 02:19'!
b3dRasterizerVersion
	"Primitive. Return the version of the rasterizer."
	self export: true.
	self inline: false.
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: 1. "Version 1"! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 4/14/1999 20:45'!
b3dStartRasterizer
	"Primitive. Start the rasterizer."
	| errCode |
	self export: true.
	self inline: false.
	"Check argument count"
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].

	"Load the base rasterizer state"
	(self loadRasterizerState: 2)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load the textures"
	self loadTexturesFrom: 0.
	interpreterProxy failed ifTrue:[^nil].
	"And the objects"
	self loadObjectsFrom: 1.
	interpreterProxy failed ifTrue:[^nil].
	"And go ..."
	errCode _ self cCode:'b3dMainLoop(&state, B3D_NO_ERROR)'.
	self storeObjectsInto: 1.
	interpreterProxy pop: 4.
	interpreterProxy pushInteger: errCode.! !

!B3DRasterizerPlugin methodsFor: 'primitives' stamp: 'ar 5/16/2000 20:06'!
primitiveSetBitBltPlugin
	"Primitive. Set the BitBlt plugin to use."
	| pluginName length ptr needReload |
	self export: true.
	self var: #ptr declareC:'char *ptr'.
	pluginName _ interpreterProxy stackValue: 0.
	"Must be string to work"
	(interpreterProxy isBytes: pluginName) 
		ifFalse:[^interpreterProxy primitiveFail].
	length _ interpreterProxy byteSizeOf: pluginName.
	length >= 256 
		ifTrue:[^interpreterProxy primitiveFail].
	ptr _ interpreterProxy firstIndexableField: pluginName.
	needReload _ false.
	0 to: length-1 do:[:i|
		"Compare and store the plugin to be used"
		(bbPluginName at: i) = (ptr at: i) ifFalse:[
			bbPluginName at: i put: (ptr at: i).
			needReload _ true]].
	(bbPluginName at: length) = 0 ifFalse:[
		bbPluginName at: length put: 0.
		needReload _ true].
	needReload ifTrue:[
		self initialiseModule 
			ifFalse:[^interpreterProxy primitiveFail]].
	interpreterProxy pop: 1. "Return receiver"! !


!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 4/12/1999 06:02'!
loadObjectsFrom: stackIndex
	| arrayOop arraySize objArray objOop objPtr |
	self var:#objArray declareC:'B3DPrimitiveObject **objArray'.
	self var:#objPtr declareC:'B3DPrimitiveObject *objPtr'.
	arrayOop _ interpreterProxy stackObjectValue: stackIndex.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: arrayOop) == (interpreterProxy classArray)
		ifFalse:[^interpreterProxy primitiveFail].
	arraySize _ interpreterProxy slotSizeOf: arrayOop.
	arraySize > (self cCode:'state.nObjects')
		ifTrue:[^interpreterProxy primitiveFail].
	objArray _ self cCode:'state.objects'.
	0 to: arraySize-1 do:[:i|
		objOop _ interpreterProxy fetchPointer: i ofObject: arrayOop.
		((interpreterProxy isIntegerObject: objOop) or:[(interpreterProxy isWords: objOop) not])
			ifTrue:[^interpreterProxy primitiveFail].
		objPtr _ self cCoerce: (interpreterProxy firstIndexableField: objOop) to:'B3DPrimitiveObject*'.
		(self cCode:'objPtr->magic !!= B3D_PRIMITIVE_OBJECT_MAGIC')
			ifTrue:[^interpreterProxy primitiveFail].
		self cCode:'objPtr->__oop__ = objOop'.
		objArray at: i put: objPtr.
	].! !

!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 5/16/2000 17:10'!
loadRasterizerState: stackIndex
	"Load the rasterizer state from the given stack index."
	| stateOop obj objPtr objLen |
	self var: #objPtr declareC:'void *objPtr'.
	(copyBitsFn = 0 or:[loadBBFn = 0]) ifTrue:[
		"We need loadBitBltFrom/copyBits here so try to load it implicitly"
		self initialiseModule ifFalse:[^false].
	].
	stateOop _ interpreterProxy stackObjectValue: stackIndex.
	interpreterProxy failed ifTrue:[^false].
	((interpreterProxy isPointers: stateOop) and:[(interpreterProxy slotSizeOf: stateOop) >= 10])
		ifFalse:[^false].

	obj _ interpreterProxy fetchPointer: 0 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.faceAlloc = objPtr'.

	obj _ interpreterProxy fetchPointer: 1 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.edgeAlloc = objPtr'.

	obj _ interpreterProxy fetchPointer: 2 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.attrAlloc = objPtr'.

	obj _ interpreterProxy fetchPointer: 3 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.aet = objPtr'.

	obj _ interpreterProxy fetchPointer: 4 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.addedEdges = objPtr'.

	obj _ interpreterProxy fetchPointer: 5 ofObject: stateOop.
	((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
		ifTrue:[^false].
	objPtr _ interpreterProxy firstIndexableField: obj.
	self cCode:'state.fillList = objPtr'.

	obj _ interpreterProxy fetchPointer: 6 ofObject: stateOop.
	obj == interpreterProxy nilObject ifTrue:[
		self cCode:'state.nObjects = 0'.
		self cCode:'state.objects = NULL'.
	] ifFalse:[
		((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
			ifTrue:[^false].
		objLen _ interpreterProxy slotSizeOf: obj.
		objPtr _ interpreterProxy firstIndexableField: obj.
		self cCode:'state.objects = (B3DPrimitiveObject **)objPtr'.
		self cCode:'state.nObjects = objLen'.
	].

	obj _ interpreterProxy fetchPointer: 7 ofObject: stateOop.
	obj == interpreterProxy nilObject ifTrue:[
		self cCode:'state.nTextures = 0'.
		self cCode:'state.textures = NULL'.
	] ifFalse:[
		((interpreterProxy isIntegerObject: obj) or:[(interpreterProxy isWords: obj) not])
			ifTrue:[^false].
		objLen _ interpreterProxy byteSizeOf: obj.
		objPtr _ interpreterProxy firstIndexableField: obj.
		self cCode:'state.textures = (B3DTexture *)objPtr'.
		self cCode:'state.nTextures = objLen / sizeof(B3DTexture)'.
	].

	obj _ interpreterProxy fetchPointer: 8 ofObject: stateOop.
	obj == interpreterProxy nilObject ifTrue:[
		self cCode:'state.spanSize = 0'.
		self cCode:'state.spanBuffer = NULL'.
	] ifFalse:[
		(interpreterProxy fetchClassOf: obj) == (interpreterProxy classBitmap)
			ifFalse:[^false].
		objLen _ interpreterProxy slotSizeOf: obj.
		objPtr _ interpreterProxy firstIndexableField: obj.
		self cCode:'state.spanBuffer = (unsigned int *)objPtr'.
		self cCode:'state.spanSize = objLen'.
	].

	obj _ interpreterProxy fetchPointer: 9 ofObject: stateOop.
	obj == interpreterProxy nilObject ifTrue:[
		self cCode:'state.spanDrawer = NULL'.
	] ifFalse:[
		(self cCode: '((int (*) (int))loadBBFn)(obj)') ifFalse:[^false].
		self cCode:'state.spanDrawer = (b3dDrawBufferFunction) copyBitsFn'.
	].

	^interpreterProxy failed not
! !

!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 4/14/1999 05:50'!
loadTexture: textureOop into: destPtr
	"Note: This still uses the old-style textures"
	| form formBits formWidth formHeight formDepth texWrap texInterpolate texEnvMode bitsPtr |
	self var: #bitsPtr declareC:'void *bitsPtr'.
	self var: #destPtr declareC:'B3DTexture *destPtr'.
	"Fetch and validate the form"
	form _ textureOop.
	(interpreterProxy isPointers: form) ifFalse:[^false].
	(interpreterProxy slotSizeOf: form) < 8 ifTrue:[^false].
	formBits _ interpreterProxy fetchPointer: 0 ofObject: form.
	formWidth _ interpreterProxy fetchInteger: 1 ofObject: form.
	formHeight _ interpreterProxy fetchInteger: 2 ofObject: form.
	formDepth _ interpreterProxy fetchInteger: 3 ofObject: form.
	texWrap _ interpreterProxy booleanValueOf: 
		(interpreterProxy fetchPointer: 5 ofObject: form).
	texInterpolate _ interpreterProxy booleanValueOf: 
		(interpreterProxy fetchPointer: 6 ofObject: form).
	texEnvMode _ interpreterProxy fetchInteger: 7 ofObject: form.
	interpreterProxy failed ifTrue:[^false].
	(formWidth < 1 or:[formHeight < 1 or:[formDepth ~= 32]]) ifTrue:[^false].
	(interpreterProxy fetchClassOf: formBits) = interpreterProxy classBitmap ifFalse:[^false].
	(interpreterProxy byteSizeOf: formBits) = (formWidth * formHeight * 4) ifFalse:[^false].
	(texEnvMode < 0 or:[texEnvMode > 1]) ifTrue:[^false].

	"Now fetch the bits"
	bitsPtr _ interpreterProxy firstIndexableField: formBits.
	"Set the texture parameters"
	^self cCode:'b3dLoadTexture(destPtr, formWidth, formHeight, formDepth, (unsigned int*) bitsPtr, 0, NULL) == B3D_NO_ERROR'.! !

!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 4/14/1999 05:52'!
loadTexturesFrom: stackIndex
	| arrayOop destPtr n textureOop |
	self var: #destPtr declareC:'B3DTexture *destPtr'.
	arrayOop _ interpreterProxy stackObjectValue: stackIndex.
	(interpreterProxy fetchClassOf: arrayOop) == interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	n _ interpreterProxy slotSizeOf: arrayOop.
	n _ n min: (self cCode: 'state.nTextures').
	0 to: n-1 do:[:i|
		destPtr _ self cCode:'state.textures + i'.
		textureOop _ interpreterProxy fetchPointer: i ofObject: arrayOop.
		(self loadTexture: textureOop into: destPtr) 
			ifFalse:[^interpreterProxy primitiveFail].
	].
	^0! !

!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 4/10/1999 23:24'!
loadViewportFrom: stackIndex
	"Load the viewport from the given stack index"
	| oop p1 p2 x0 y0 x1 y1 |
	oop _ interpreterProxy stackObjectValue: stackIndex.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isPointers: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: oop) < 2
		ifTrue:[^interpreterProxy primitiveFail].
	p1 _ interpreterProxy fetchPointer: 0 ofObject: oop.
	p2 _ interpreterProxy fetchPointer: 1 ofObject: oop.
	(interpreterProxy fetchClassOf: p1) = interpreterProxy classPoint
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy fetchClassOf: p2) = interpreterProxy classPoint
		ifFalse:[^interpreterProxy primitiveFail].
	x0 _ interpreterProxy fetchInteger: 0 ofObject: p1.
	y0 _ interpreterProxy fetchInteger: 1 ofObject: p1.
	x1 _ (interpreterProxy fetchInteger: 0 ofObject: p2).
	y1 _ (interpreterProxy fetchInteger: 1 ofObject: p2).
	interpreterProxy failed ifTrue:[^nil].
	self cCode:'viewport.x0 = x0'.
	self cCode:'viewport.y0 = y0'.
	self cCode:'viewport.x1 = x1'.
	self cCode:'viewport.y1 = y1'.
	^0! !

!B3DRasterizerPlugin methodsFor: 'primitive support' stamp: 'ar 4/12/1999 06:01'!
storeObjectsInto: stackIndex
	| arrayOop arraySize objOop |
	arrayOop _ interpreterProxy stackObjectValue: stackIndex.
	arraySize _ self cCode: 'state.nObjects'.
	0 to: arraySize-1 do:[:i|
		objOop _ self cCode:'state.objects[i]->__oop__'.
		interpreterProxy storePointer: i ofObject: arrayOop withValue: objOop.
	].! !

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

B3DRasterizerPlugin class
	instanceVariableNames: ''!

!B3DRasterizerPlugin class methodsFor: 'translation' stamp: 'ar 5/15/2000 23:12'!
declareCVarsIn: cg
	cg addHeaderFile:'"b3d.h"'.
	cg var: #viewport type: #'B3DPrimitiveViewport'.
	cg var: #state type: #'B3DRasterizerState'! !

!B3DRasterizerPlugin class methodsFor: 'translation' stamp: 'ar 4/18/1999 08:36'!
translateSupportCode: cSrc inlining: inlineFlag
	"Inline the given C support code if inlineFlag is set.
	Inlining converts any functions of the form:
		/* INLINE someFunction(args) */
		void someFunction(declaration args)
		{
			... actual code ...
		}
		/* --INLINE-- */
	into 
		#define someFunction(args) \
		/* void someFunction(declaration args) */ \
		{ \
			... actual code ... \
		} \
		/* --INLINE-- */
	thus using a hard way of forcing inlining by the C compiler."
	| in out postfix line |
	true ifTrue:[^cSrc]. "Disabled until I had time to actually test it ;-)"
	inlineFlag ifFalse:[^cSrc].
	in _ ReadStream on: cSrc.
	out _ WriteStream on: (String new: cSrc size).
	postfix _ ''.
	[in atEnd] whileFalse:[
		line _ in upTo: Character cr.
		(line includesSubString:' INLINE ') ifTrue:[
			"New inline start"
			postfix _ ' \'.
			line _ line copyFrom: (line findString: 'INLINE')+6 to: line size.
			line _ line copyFrom: 1 to: (line findString: '*/')-1.
			out nextPutAll:'#define'; nextPutAll: line; nextPutAll: postfix; cr.
			"Next line has function declaration -- comment this out"
			[line _ in upTo: Character cr.
			line includes: ${] whileFalse:[
				out nextPutAll:'/* '; nextPutAll: line; nextPutAll:' */'; nextPutAll: postfix; cr.
			].
			(line first = ${) ifTrue:[
				out nextPutAll: line; nextPutAll: postfix; cr.
			] ifFalse:[
				out nextPutAll: '/* '; 
					nextPutAll:(line copyFrom: 1 to: (line findString:'{')-1);
					nextPutAll:' */';
					nextPutAll:(line copyFrom: (line findString:'{') to: line size);
					nextPutAll: postfix;
					cr.
			].
		] ifFalse:[
			(line includesSubString:'--INLINE--') ifTrue:[postfix _ ''].
			out nextPutAll: line; nextPutAll: postfix; cr.
		].
	].
	^out contents.
	"| fs |
	fs _ FileStream newFileNamed:'b3dr.c'.
	fs nextPutAll: (B3DRasterizerPlugin translateSupportCode: B3DRasterizerPlugin b3dRemapC inlining: true).
	fs close."
! !

!B3DRasterizerPlugin class methodsFor: 'translation' stamp: 'ar 5/15/2000 23:10'!
writeSupportCode: inlineFlag
	"B3DRasterizerPlugin writeSupportCode: true"
	"B3DRasterizerPlugin writeSupportCode: false"
	"Translate all the C support files for the Balloon 3D rasterizer plugin."
	| src fs |
	#(
		(b3dTypesH 'b3dTypes.h')
		(b3dAllocH 'b3dAlloc.h')
		(b3dHeaderH 'b3d.h')

		(b3dInitC 'b3dInit.c')
		(b3dAllocC 'b3dAlloc.c')
		(b3dRemapC 'b3dRemap.c')
		(b3dDrawC 'b3dDraw.c')
		(b3dMainC 'b3dMain.c')
	) do:[:spec|
		src _ self perform: (spec at: 1).
		src _ self translateSupportCode: src inlining: inlineFlag.
		fs _ CrLfFileStream newFileNamed: (spec at: 2).
		fs nextPutAll: src.
		fs close.
	].! !


!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/18/1999 08:30'!
b3dAllocC
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dAlloc.c
*   CONTENT: Memory allocation for the Balloon 3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#include <assert.h>
#include "b3d.h"

#ifdef DEBUG_ALLOC
/* DEBUG versions of allocators */
B3DPrimitiveFace *dbg_b3dAllocFace(B3DFaceAllocList *list)
{
	B3DPrimitiveFace *result;
	if(list->firstFree) {
		result = list->firstFree;
		list->firstFree = list->firstFree->nextFree;
	    if(result->flags & B3D_ALLOC_FLAG)
			b3dAbort("list->firstFree has allocation bit set");
	} else {
		if(list->size < list->max) {
			result = list->data + list->size;
			list->size++;
		} else return NULL;
	}
	result->nextFree = NULL;
	result->flags = B3D_ALLOC_FLAG;
	list->nFree--;
	return result;
}

B3DPrimitiveEdge *dbg_b3dAllocEdge(B3DEdgeAllocList *list)
{
	B3DPrimitiveEdge *result;
	if(list->firstFree) {
		result = list->firstFree;
		list->firstFree = list->firstFree->nextFree;
	    if(result->flags & B3D_ALLOC_FLAG)
			b3dAbort("list->firstFree has allocation bit set");
	} else {
		if(list->size < list->max) {
			result = list->data + list->size;
			list->size++;
		} else return NULL;
	}
	result->nextFree = NULL;
	result->flags = B3D_ALLOC_FLAG;
	list->nFree--;
	return result;
}

void dbg_b3dFreeFace(B3DFaceAllocList *list, B3DPrimitiveFace *face)
{
	if(face < list->data || face >= (list->data + list->size))
		b3dAbort("face to free is not in list");
	if( !! (face->flags & B3D_ALLOC_FLAG) )
		b3dAbort("face to free has no allocation flag set");
	face->flags = 0;
	face->nextFree = list->firstFree;
	list->firstFree = face;
	list->nFree++;
}

void dbg_b3dFreeEdge(B3DEdgeAllocList *list, B3DPrimitiveEdge *edge)
{
	if(edge < list->data || edge >= (list->data + list->size))
		b3dAbort("edge to free is not in list");
	if( !! (edge->flags & B3D_ALLOC_FLAG) )
		b3dAbort("edge to free has no allocation flag set");
	edge->flags = 0;
	edge->nextFree = list->firstFree;
	list->firstFree = edge;
	list->nFree++;
}

B3DPrimitiveAttribute *dbg_b3dAllocSingleAttr(B3DAttrAllocList *list)
{
	B3DPrimitiveAttribute *result;
	if(list->firstFree) {
		result = list->firstFree;
		list->firstFree = list->firstFree->next;
	} else {
		if(list->size < list->max) {
			result = list->data + list->size;
			list->size++;
		} else return NULL;
	}
	list->nFree--;
	return result;
}

int dbg_b3dAllocAttrib(B3DAttrAllocList *attrList, B3DPrimitiveFace *face)
{
	B3DPrimitiveAttribute *firstAttr, *nextAttr;
	int i, nAttrs = 0;

	assert(face->attributes == NULL);
	if(face->flags & B3D_FACE_RGB) nAttrs += 3;
	if(face->flags & B3D_FACE_ALPHA) nAttrs += 1;
	if(face->flags & B3D_FACE_STW) nAttrs += 3;
	if(!!nAttrs) return 1;
	firstAttr = nextAttr = NULL;
	for(i=0;i<nAttrs; i++) {
		nextAttr = dbg_b3dAllocSingleAttr(attrList);
		if(!!nextAttr) return 0;
		nextAttr->next = firstAttr;
		firstAttr = nextAttr;
	}
	face->attributes = firstAttr;
	return 1;
}

void dbg_b3dFreeAttrib(B3DAttrAllocList *list, B3DPrimitiveFace *face)
{
	B3DPrimitiveAttribute *attr, *nextAttr = face->attributes;
	while(nextAttr) {
		attr = nextAttr;
		nextAttr = attr->next;
		if(attr < list->data || attr >= (list->data + list->size))
			b3dAbort("attributes to free are not in list");
		attr->next = list->firstFree;
		list->firstFree = attr;
		list->nFree++;
	}
}


#endif /* DEBUG */
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/18/1999 08:35'!
b3dAllocH
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dAlloc.h
*   CONTENT: Memory allocation for the Balloon 3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#ifndef B3D_ALLOC_H
#define B3D_ALLOC_H

#include "b3dTypes.h"

/************************ Allocator definitions ************************/
#define B3D_EDGE_ALLOC_MAGIC 0x45443341
typedef struct B3DEdgeAllocList {
	int magic;
	void *This;
	int max; /* Note: size is ALWAYS less than max */
	int size;
 	int nFree;
	B3DPrimitiveEdge *firstFree; /* pointer to the first free edge (< max) */
	B3DPrimitiveEdge data[1];
} B3DEdgeAllocList;

#define B3D_FACE_ALLOC_MAGIC 0x46443341
typedef struct B3DFaceAllocList {
	int magic;
	void *This;
	int max; /* Note: size is ALWAYS less than max */
	int size;
	int nFree;
	B3DPrimitiveFace *firstFree; /* pointer to the first free face (< max) */
	B3DPrimitiveFace data[1];
} B3DFaceAllocList;

#define B3D_ATTR_ALLOC_MAGIC  0x41443341
typedef struct B3DAttrAllocList {
	int magic;
	void *This;
	int max; /* Note: size is ALWAYS less than max */
	int size;
	int nFree;
	B3DPrimitiveAttribute *firstFree; /* pointer to the first free attribute (< max) */
	B3DPrimitiveAttribute data[1];
} B3DAttrAllocList;

/* The mapping from face flags to the number of attributes needed */
extern int B3D_ATTRIBUTE_SIZES[B3D_MAX_ATTRIBUTES];
#define B3D_FACE_ATTRIB_SIZE(face) (B3D_ATTRIBUTE_SIZES[(face->flags >> B3D_ATTR_SHIFT) & B3D_ATTR_MASK])

#ifdef DEBUG_ALLOC

B3DPrimitiveFace *dbg_b3dAllocFace(B3DFaceAllocList *list);
B3DPrimitiveEdge *dbg_b3dAllocEdge(B3DEdgeAllocList *list);
int dbg_b3dAllocAttrib(B3DAttrAllocList *attrList, B3DPrimitiveFace *face);
void dbg_b3dFreeFace(B3DFaceAllocList *list, B3DPrimitiveFace *face);
void dbg_b3dFreeEdge(B3DEdgeAllocList *list, B3DPrimitiveEdge *edge);
void dbg_b3dFreeAttrib(B3DAttrAllocList *list, B3DPrimitiveFace *face);

#define b3dAllocFace(list, face) face = dbg_b3dAllocFace(list);
#define b3dAllocEdge(list, edge) edge = dbg_b3dAllocEdge(list);
#define b3dAllocAttrib(attrList, face, result) result = dbg_b3dAllocAttrib(attrList, face);
#define b3dFreeFace(list, face) dbg_b3dFreeFace(list, face);
#define b3dFreeEdge(list, edge) dbg_b3dFreeEdge(list, edge);
#define b3dFreeAttrib(list, face) dbg_b3dFreeAttrib(list, face);

#else /* RELEASE */

#define b3dAlloc(list,object) \
{\
	if(list->firstFree) { \
		object = list->firstFree; \
		list->firstFree = object->nextFree; \
		object->flags = B3D_ALLOC_FLAG; \
		list->nFree--;\
	} else { \
		if(list->size < list->max) { \
			object = list->data + list->size; \
			list->size++;\
			object->flags = B3D_ALLOC_FLAG;\
			list->nFree--;\
		} else object = NULL;\
	}\
}

#define b3dFree(list, object) \
{\
	object->flags = 0;\
	object->nextFree = list->firstFree; \
	list->firstFree = object;\
	list->nFree++;\
}

#define b3dAllocFace(list, face) b3dAlloc(list,face)
#define b3dAllocEdge(list, edge) b3dAlloc(list, edge)
#define b3dFreeFace(list, face) b3dFree(list, face)
#define b3dFreeEdge(list, edge) b3dFree(list, edge)

#define b3dAllocSingleAttr(list,object) \
{\
	if(list->firstFree) { \
		object = list->firstFree; \
		list->firstFree = object->next; \
		list->nFree--;\
	} else { \
		if(list->size < list->max) { \
			object = list->data + list->size; \
			list->size++;\
			list->nFree--;\
		} else object = NULL;\
	}\
}

#define b3dAllocAttrib(attrList,face, result) \
{\
	B3DPrimitiveAttribute *firstAttr, *nextAttr;\
	int nAttrs = 0;\
\
	if(face->flags & B3D_FACE_RGB) nAttrs += 3;\
	if(face->flags & B3D_FACE_ALPHA) nAttrs += 1;\
	if(face->flags & B3D_FACE_STW) nAttrs += 3;\
	firstAttr = nextAttr = NULL;\
	while(nAttrs--) {\
		b3dAllocSingleAttr(attrList, nextAttr);\
		if(!!nextAttr) break;\
		nextAttr->next = firstAttr;\
		firstAttr = nextAttr;\
	};\
	face->attributes = firstAttr;\
	result = nextAttr !!= NULL;\
}


#define b3dFreeAttrib(list, face) \
{\
	B3DPrimitiveAttribute *attr, *nextAttr = face->attributes;\
	while(nextAttr) {\
		attr = nextAttr;\
		nextAttr = attr->next;\
		attr->next = list->firstFree;\
		list->firstFree = attr;\
		list->nFree++;\
	}\
}

#endif

#endif /* ifndef B3D_ALLOC_H */
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/21/1999 01:58'!
b3dDrawC
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dDraw.c
*   CONTENT: Pixel drawing functions for the B3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:  LOTS of stuff missing here...
*
*	- A note on RGBA interpolation:
*	For low polygon models it makes sense to compute both, the left and
*	the right attribute value if there might be any overflow at all.
*	Since we''re usually drawing many pixels in a row we can clamp the
*	left and right value and thus be safe during the interpolation stage.
*
*****************************************************************************/
#include "b3d.h"

#define rasterPosX rasterPos[0]
#define rasterPosY rasterPos[1]

#define redValue   color[RED_INDEX]
#define greenValue color[GREEN_INDEX]
#define blueValue  color[BLUE_INDEX]
#define alphaValue color[ALPHA_INDEX]

/* The following defines the maximum number of pixels 
   we treat in one loop. This value should be carefully
   chosen: Setting it high will increase speed for larger
   polygons but reduce speed for smaller ones. Setting
   it low will do the opposite. Also, since I''m assuming
   a smart compiler, the code size will probably increase
   with this number (if loops are unrolled by the compiler).

   The current value of 5 should be a good median (32 pixels
   are processed at most and we''ll have the overhead of 5
   tests for a one-pixel polygon).
*/
#define MAX_PIXEL_SHIFT 5


/* USE_MULTBL: Replace up a couple of multiplications by table lookups.
	On PowerPC, the lookup seems to be slightly slower.
	On Intel, the lookup is way faster.
*/
#ifndef USE_MULTBL
# ifdef __POWERPC__
#  define USE_MULTBL 0
# else
#  define USE_MULTBL 1
# endif
#endif

/* Clamp the given value */
#define CLAMP(value, min, max)\
	if((value) < (min)) (value) = (min); \
	else if((value) > (max)) (value) = (max);

/* Clamp a set of fixed point RGB values */
#define CLAMP_RGB(r,g,b) \
	CLAMP(r,B3D_FixedHalf, (255 << B3D_IntToFixedShift) + B3D_FixedHalf)\
	CLAMP(g,B3D_FixedHalf, (255 << B3D_IntToFixedShift) + B3D_FixedHalf)\
	CLAMP(b,B3D_FixedHalf, (255 << B3D_IntToFixedShift) + B3D_FixedHalf)


#ifdef DEBUG_ATTR
double attrValueAt(B3DPrimitiveFace *face, B3DPrimitiveAttribute *attr, double xValue, double yValue)
{
	return 
		(attr->value +
			((xValue - face->v0->rasterPosX) * attr->dvdx) +
			((yValue - face->v0->rasterPosY) * attr->dvdy));
}
#else
#define attrValueAt(face,attr,xValue,yValue) \
		((attr)->value + \
			(((double)(xValue) - (face)->v0->rasterPosX) * (attr)->dvdx) + \
			(((double)(yValue) - (face)->v0->rasterPosY) * (attr)->dvdy))
#endif


#define SETUP_RGB \
	rValue = (int)(attrValueAt(face, attr, floatX, floatY) * B3D_FloatToFixed); \
	deltaR = (int) (attr->dvdx * B3D_FloatToFixed);  \
	attr = attr->next; \
	gValue = (int)(attrValueAt(face, attr, floatX, floatY) * B3D_FloatToFixed);\
	deltaG = (int) (attr->dvdx * B3D_FloatToFixed); \
	attr = attr->next; \
	bValue = (int)(attrValueAt(face, attr, floatX, floatY) * B3D_FloatToFixed); \
	deltaB = (int) (attr->dvdx * B3D_FloatToFixed); \
	attr = attr->next;\
	CLAMP_RGB(rValue, gValue, bValue);

#define SETUP_STW \
	wValue = attrValueAt(face, attr, floatX, floatY); \
	wDelta = attr->dvdx; \
	attr = attr->next; \
	sValue = attrValueAt(face, attr, floatX, floatY); \
	sDelta = attr->dvdx; \
	attr = attr->next; \
	tValue = attrValueAt(face, attr, floatX, floatY); \
	tDelta = attr->dvdx; \
	attr = attr->next;

#define STEP_STW \
	sValue += sDelta;\
	tValue += tDelta;\
	wValue += wDelta;


/* Load the four neighbouring texels into tex00, tex01, tex10, and tex11 */
#define LOAD_4_RGB_TEXEL_32(fixedS, fixedT, texture) \
{\
	int sIndex, tIndex;\
\
	if(texture->sMask) {\
		sIndex = (fixedS >> B3D_FixedToIntShift) & texture->sMask;\
	} else {\
		sIndex = (fixedS >> B3D_FixedToIntShift) % texture->width;\
	}\
	if(texture->tMask) {\
		tIndex = (fixedT >> B3D_FixedToIntShift) & texture->tMask;\
	} else {\
		tIndex = (fixedT >> B3D_FixedToIntShift) % texture->height;\
	}\
	/* Load the 4 texels, wrapping if necessary */\
	tex00 = (struct b3dPixelColor *) texture->data + (tIndex * texture->width) + sIndex;\
	tex01 = tex00 + 1;\
	tex10 = tex00 + texture->width;\
	tex11 = tex10 + 1;\
	if(sIndex+1 == texture->width) {\
		tex01 -= texture->width;\
		tex11 -= texture->width;\
	}\
	if(tIndex+1 == texture->height) {\
		int tsize = texture->height * texture->width;\
		tex10 -= tsize;\
		tex11 -= tsize;\
	}\
}


#if USE_MULTBL /* Use a 16x256 table for lookups */

unsigned short MULTBL[17][256];

static int multblInit = 0;

static void MULTBL_Init(void)
{
	int i,j;
	for(i=0;i<17;i++)
		for(j=0; j<256; j++)
			MULTBL[i][j] = (i*j) >> 4;
	multblInit = 1;
}

#define INIT_MULTBL { if (!!multblInit) MULTBL_Init(); }

#define DO_RGB_INTERPOLATION(sf, si, tf, ti) \
	tr = (MULTBL[ti][(MULTBL[si][tex00->redValue] + MULTBL[sf][tex01->redValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->redValue] + MULTBL[sf][tex11->redValue])]);\
	tg = (MULTBL[ti][(MULTBL[si][tex00->greenValue] + MULTBL[sf][tex01->greenValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->greenValue] + MULTBL[sf][tex11->greenValue])]);\
	tb = (MULTBL[ti][(MULTBL[si][tex00->blueValue] + MULTBL[sf][tex01->blueValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->blueValue] + MULTBL[sf][tex11->blueValue])]);

#define DO_RGBA_INTERPOLATION(sf, si, tf, ti)\
	tr = (MULTBL[ti][(MULTBL[si][tex00->redValue] + MULTBL[sf][tex01->redValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->redValue] + MULTBL[sf][tex11->redValue])]);\
	tg = (MULTBL[ti][(MULTBL[si][tex00->greenValue] + MULTBL[sf][tex01->greenValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->greenValue] + MULTBL[sf][tex11->greenValue])]);\
	tb = (MULTBL[ti][(MULTBL[si][tex00->blueValue] + MULTBL[sf][tex01->blueValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->blueValue] + MULTBL[sf][tex11->blueValue])]); \
	ta = (MULTBL[ti][(MULTBL[si][tex00->alphaValue] + MULTBL[sf][tex01->alphaValue])] + \
			MULTBL[tf][(MULTBL[si][tex10->alphaValue] + MULTBL[sf][tex11->alphaValue])]);

#else

#define INIT_MULTBL

#define DO_RGB_INTERPOLATION(sf, si, tf, ti) \
	tr = (ti * (si * tex00->redValue + sf * tex01->redValue) +\
			tf * (si * tex10->redValue + sf * tex11->redValue)) >> 8;\
	tg = (ti * (si * tex00->greenValue + sf * tex01->greenValue) +\
			tf * (si * tex10->greenValue + sf * tex11->greenValue)) >> 8;\
	tb = (ti * (si * tex00->blueValue + sf * tex01->blueValue) +\
			tf * (si * tex10->blueValue + sf * tex11->blueValue)) >> 8;\

#define DO_RGBA_INTERPOLATION(sf, si, tf, ti) \
	tr = (ti * (si * tex00->redValue + sf * tex01->redValue) +\
			tf * (si * tex10->redValue + sf * tex11->redValue)) >> 8;\
	tg = (ti * (si * tex00->greenValue + sf * tex01->greenValue) +\
			tf * (si * tex10->greenValue + sf * tex11->greenValue)) >> 8;\
	tb = (ti * (si * tex00->blueValue + sf * tex01->blueValue) +\
			tf * (si * tex10->blueValue + sf * tex11->blueValue)) >> 8;\
	ta = (ti * (si * tex00->alphaValue + sf * tex01->alphaValue) +\
			tf * (si * tex10->alphaValue + sf * tex11->alphaValue)) >> 8;

#endif /* No MULTBL */

#define INTERPOLATE_RGB_TEXEL(fixedS, fixedT)\
{	int sf, si, tf, ti;\
	sf = (fixedS >> (B3D_FixedToIntShift - 4)) & 15; si = 16 - sf;\
	tf = (fixedT >> (B3D_FixedToIntShift - 4)) & 15; ti = 16 - tf;\
	DO_RGB_INTERPOLATION(sf, si, tf, ti)\
}

void b3dNoDraw     (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawRGB    (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawRGBA   (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawSTW    (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawSTWA   (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawSTWRGB (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
void b3dDrawSTWARGB(int leftX, int rightX, int yValue, B3DPrimitiveFace *face);

b3dPixelDrawer B3D_FILL_FUNCTIONS[B3D_MAX_ATTRIBUTES] = {
	b3dNoDraw,      /* No attributes */
	b3dDrawRGB,     /* B3D_FACE_RGB */
	b3dNoDraw,      /* B3D_FACE_ALPHA -- IGNORED!!!!!! */
	b3dDrawRGBA,    /* B3D_FACE_RGB | B3D_FACE_ALPHA */
	b3dDrawSTW,     /* B3D_FACE_STW */
	b3dDrawSTWRGB,  /* B3D_FACE_STW | B3D_FACE_RGB */
	b3dDrawSTWA,    /* B3D_FACE_STW | B3D_FACE_ALPHA */
	b3dDrawSTWARGB  /* B3D_FACE_STW | B3D_FACE_RGB | B3D_FACE_ALPHA */
};

void b3dNoDraw(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	if(b3dDebug)
		b3dAbort("b3dNoDraw called!!");
}

void b3dDrawRGBFlat(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	struct b3dPixelColor { B3DPrimitiveColor color; } pv, *bits;
	int rValue, gValue, bValue;
	int deltaR, deltaG, deltaB;


	{
		B3DPrimitiveAttribute *attr = face->attributes;
		/* Ughh ... I''m having a sampling problem somewhere.
		   In theory, the faces should be sampled *exactly* at integer
		   values (the necessary offset should be done before) so that
		   we always sample inside the triangle. For some reason that
		   doesn''t quite work yet and that''s why here is the strange
		   0.5 offset and the awful lot of tests. At some time I''ll
		   review this but for now I have more important things to do.
		*/
		double floatX = leftX;
		double floatY = yValue+0.5;

		if(b3dDebug)
			if(!!attr) b3dAbort("face has no RGB attributes");

		SETUP_RGB;
	}

	bits = (struct b3dPixelColor *) currentState->spanBuffer;
	pv.redValue   = (unsigned char) (rValue >> B3D_FixedToIntShift);
	pv.greenValue = (unsigned char) (gValue >> B3D_FixedToIntShift);
	pv.blueValue  = (unsigned char) (bValue >> B3D_FixedToIntShift);
	pv.alphaValue = 255;

	while(leftX <= rightX) {
		bits[leftX++] = pv;
	}
}

void b3dDrawRGB(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	struct b3dPixelColor { B3DPrimitiveColor color; } pv, *bits;
	int rValue, gValue, bValue;
	int deltaR, deltaG, deltaB;
	int deltaX, pixelShift;

	{
		B3DPrimitiveAttribute *attr = face->attributes;
		/* Ughh ... I''m having a sampling problem somewhere.
		   In theory, the faces should be sampled *exactly* at integer
		   values (the necessary offset should be done before) so that
		   we always sample inside the triangle. For some reason that
		   doesn''t quite work yet and that''s why here is the strange
		   0.5 offset and the awful lot of tests. At some time I''ll
		   review this but for now I have more important things to do.
		*/
		double floatX = leftX;
		double floatY = yValue+0.5;

		if(b3dDebug)
			if(!!attr) b3dAbort("face has no RGB attributes");

		SETUP_RGB;
	}

	bits = (struct b3dPixelColor *) currentState->spanBuffer;
	pv.alphaValue = 255;

	/*	Reduce the overhead of clamping by precomputing 
		the deltas for each power of two step. A good question here
		is whether or not it is a good idea to do 2 pixels by this... */
	deltaX = rightX - leftX + 1;

	/* Now do all the powers of two except the last one pixel */
	/* Note: A smart compiler (== gcc) should unroll the following loop */
	for(pixelShift= MAX_PIXEL_SHIFT; pixelShift> 0; pixelShift--) {
		int nPixels = 1 << pixelShift;
		/* Note: The ''if'' here is possible since 
		   we have dealt with huge polys above */
		while(deltaX >= nPixels) {	
			{	/* Compute right most values of color interpolation */
				int maxR = rValue + (deltaR << pixelShift);
				int maxG = gValue + (deltaG << pixelShift);
				int maxB = bValue + (deltaB << pixelShift);
				/* Clamp those guys */
				CLAMP_RGB(maxR, maxG, maxB);
				/* And compute the actual delta */
				deltaR = (maxR - rValue) >> pixelShift;
				deltaG = (maxG - gValue) >> pixelShift;
				deltaB = (maxB - bValue) >> pixelShift;
			}
			/* Do the inner loop */
			{	int n = nPixels;
				while(n--) {
					pv.redValue   = (unsigned char) (rValue >> B3D_FixedToIntShift);
					pv.greenValue = (unsigned char) (gValue >> B3D_FixedToIntShift);
					pv.blueValue  = (unsigned char) (bValue >> B3D_FixedToIntShift);
					bits[leftX++] = pv;
					rValue += deltaR;
					gValue += deltaG;
					bValue += deltaB;
				}
			}
			/* Finally, adjust the number of pixels left */
			deltaX -= nPixels;
		}
	}
	/* The last pixel is done separately */
	if(deltaX) {
		pv.redValue   = (unsigned char) (rValue >> B3D_FixedToIntShift);
		pv.greenValue = (unsigned char) (gValue >> B3D_FixedToIntShift);
		pv.blueValue  = (unsigned char) (bValue >> B3D_FixedToIntShift);
		bits[leftX++] = pv;
	}
}

void b3dDrawSTWRGB(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	struct b3dPixelColor { B3DPrimitiveColor color; } pv, *bits, *tex00, *tex10, *tex01, *tex11;
	double sValue, tValue, wValue, sDelta, tDelta, wDelta, oneOverW;
	int rValue, gValue, bValue;
	int deltaR, deltaG, deltaB;
	int tr, tg, tb, ta;
	int fixedLeftS, fixedRightS, fixedLeftT, fixedRightT, fixedDeltaS, fixedDeltaT;
	int deltaX, pixelShift;

	B3DTexture *texture = face->texture;

	INIT_MULTBL;

	if(!!texture || 0) {
		/* If no texture simply draw RGB */
		b3dDrawRGB(leftX, rightX, yValue, face);
		return;
	}
	if(texture->depth < 16 && (texture->cmSize < (1 << texture->depth)))
		return; /* Colormap not installed */

	{
		B3DPrimitiveAttribute *attr = face->attributes;
		/* See above */
		double floatX = leftX;
		double floatY = yValue+0.5;

		if(b3dDebug)
			if(!!attr) b3dAbort("face has no RGB attributes");

		SETUP_RGB;
		SETUP_STW;
	}

	tr = tg = tb = ta = 255;

	bits = (struct b3dPixelColor *) currentState->spanBuffer;
	pv.alphaValue = 255;

	/*	VERY Experimental: Reduce the overhead of clamping
		as well as division by W by precomputing the deltas 
		for each power of two step */
	deltaX = rightX - leftX + 1;
	if(wValue) oneOverW = 1.0 / wValue;
	else oneOverW = 0.0;
	fixedLeftS = (int) (sValue * oneOverW * (texture->width << B3D_IntToFixedShift));
	fixedLeftT = (int) (tValue * oneOverW * (texture->height << B3D_IntToFixedShift));

	for(pixelShift = MAX_PIXEL_SHIFT; pixelShift > 0; pixelShift--) {
		int nPixels = 1 << pixelShift;
		while(deltaX >= nPixels) {
			{	/* Compute right most values of color interpolation */
				int maxR = rValue + (deltaR << pixelShift);
				int maxG = gValue + (deltaG << pixelShift);
				int maxB = bValue + (deltaB << pixelShift);
				/* Clamp those guys */
				CLAMP_RGB(maxR, maxG, maxB);
				/* And compute the actual delta */
				deltaR = (maxR - rValue) >> pixelShift;
				deltaG = (maxG - gValue) >> pixelShift;
				deltaB = (maxB - bValue) >> pixelShift;
			}
			/* Compute the RIGHT s/t values (the left ones are kept from the last loop) */
			wValue += wDelta * nPixels;
			sValue += sDelta * nPixels;
			tValue += tDelta * nPixels;
			if(wValue) oneOverW = 1.0 / wValue;
			else oneOverW = 0.0;
			fixedRightS = (int) (sValue * oneOverW * (texture->width << B3D_IntToFixedShift));
			fixedDeltaS = (fixedRightS - fixedLeftS) >> pixelShift;
			fixedRightT = (int) (tValue * oneOverW * (texture->height << B3D_IntToFixedShift));
			fixedDeltaT = (fixedRightT - fixedLeftT) >> pixelShift;
			/* Do the inner loop */
			{	int n = nPixels;
				while(n--) {
					/* Do the texture load ... hmm ... there should be a way
					   to avoid loading the texture on each pixel... 
					   On the other hand, the texture load does not seem
					   too expensive if compared with the texture interpolation.
					*/
					LOAD_4_RGB_TEXEL_32(fixedLeftS, fixedLeftT, texture);
					/* Do the interpolation based on tex00, tex01, tex10, tex11.
					   THIS seems to be one of the real bottlenecks here...
					*/
					INTERPOLATE_RGB_TEXEL(fixedLeftS, fixedLeftT);
#if USE_MULTBL
					pv.redValue   = (unsigned char) (MULTBL[rValue >> (B3D_FixedToIntShift+4)][tr]);
					pv.greenValue = (unsigned char) (MULTBL[gValue >> (B3D_FixedToIntShift+4)][tg]);
					pv.blueValue  = (unsigned char) (MULTBL[bValue >> (B3D_FixedToIntShift+4)][tb]);
#else
					pv.redValue   = (unsigned char) ((tr * rValue) >> (B3D_FixedToIntShift + 8));
					pv.greenValue = (unsigned char) ((tg * gValue) >> (B3D_FixedToIntShift + 8));
					pv.blueValue  = (unsigned char) ((tb * bValue) >> (B3D_FixedToIntShift + 8));
#endif
					bits[leftX++] = pv;
					rValue += deltaR;
					gValue += deltaG;
					bValue += deltaB;
					fixedLeftS += fixedDeltaS;
					fixedLeftT += fixedDeltaT;
				}
			}
			/* Finally, adjust the number of pixels left and update s/t */
			deltaX -= nPixels;
			fixedLeftS = fixedRightS;
			fixedLeftT = fixedRightT;
		}
	}
	/* The last pixel is done separately */
	if(deltaX) {
		/* Do the texture load */
		LOAD_4_RGB_TEXEL_32(fixedLeftS, fixedLeftT, texture);
		/* Do the interpolation */
		INTERPOLATE_RGB_TEXEL(fixedLeftS, fixedLeftT);
#if USE_MULTBL
		pv.redValue   = (unsigned char) (MULTBL[rValue >> (B3D_FixedToIntShift+4)][tr]);
		pv.greenValue = (unsigned char) (MULTBL[gValue >> (B3D_FixedToIntShift+4)][tg]);
		pv.blueValue  = (unsigned char) (MULTBL[bValue >> (B3D_FixedToIntShift+4)][tb]);
#else
		pv.redValue   = (unsigned char) ((tr * rValue) >> (B3D_FixedToIntShift + 8));
		pv.greenValue = (unsigned char) ((tg * gValue) >> (B3D_FixedToIntShift + 8));
		pv.blueValue  = (unsigned char) ((tb * bValue) >> (B3D_FixedToIntShift + 8));
#endif
		bits[leftX++] = pv;
	}
}

void b3dDrawSTWARGB(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	/* not yet implemented */
}

void b3dDrawRGBA(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	/* not yet implemented */
}

void b3dDrawSTW(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	/* not yet implemented */
}

void b3dDrawSTWA(int leftX, int rightX, int yValue, B3DPrimitiveFace *face)
{
	/* not yet implemented */
}
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/18/1999 18:27'!
b3dHeaderH
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3d.h
*   CONTENT: Main include file
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#ifndef __B3D_H
#define __B3D_H

#ifdef DEBUG
#define b3dDebug 1
#else
#define b3dDebug 0
#endif

#define b3dDoStats 1

/* primary include file */

#include "b3dTypes.h"
#include "b3dAlloc.h"

typedef int (*b3dDrawBufferFunction) (int leftX, int rightX, int yValue);

typedef struct B3DRasterizerState {

	/* The three sources for allocating 
	   temporary rasterizer objects */
	B3DFaceAllocList *faceAlloc;
	B3DEdgeAllocList *edgeAlloc;
	B3DAttrAllocList *attrAlloc;

	/* The active edge table */
	B3DActiveEdgeTable *aet;
	/* The list for newly added edges */
	B3DPrimitiveEdgeList *addedEdges;

	/* The fill list */
	B3DFillList *fillList;

	/* The input objects for the rasterizer */
	int nObjects;
	B3DPrimitiveObject **objects;

	/* The input textures for the rasterizer */
	int nTextures;
	B3DTexture *textures;

	/* Length and location of span buffer to use */
	int spanSize;
	unsigned int *spanBuffer;

	/* Function to call on drawing the output buffer */
	b3dDrawBufferFunction spanDrawer;

} B3DRasterizerState;

extern B3DRasterizerState *currentState;

/* from b3dInit.c */
int b3dInitializeEdgeAllocator(void* base, int length);
int b3dInitializeFaceAllocator(void* base, int length);
int b3dInitializeAttrAllocator(void* base, int length);
int b3dInitializeAET(void* base, int length);
int b3dInitializeEdgeList(void* base, int length);
int b3dInitializeFillList(void* base, int length);
void b3dSetupObjects(B3DRasterizerState *state);

int b3dAddPolygonObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DPrimitiveViewport *vp);

int b3dAddIndexedQuadObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DInputQuad *quadPtr, int nQuads,
						  B3DPrimitiveViewport *vp);

int b3dAddIndexedTriangleObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DInputFace *facePtr, int nFaces,
						  B3DPrimitiveViewport *vp);

int b3dLoadTexture(B3DTexture *texture,
				   int width, int height, int depth, unsigned int *bits,
				   int cmSize, unsigned int *colormap);


/* from b3dRemap.c */
int b3dValidateAndRemapState(B3DRasterizerState *state);

/* from b3dDraw.c */
typedef void (*b3dPixelDrawer) (int leftX, int rightX, int yValue, B3DPrimitiveFace *face);
extern b3dPixelDrawer B3D_FILL_FUNCTIONS[];

/* from b3dMain.c */
void b3dAbort(char *msg);
int b3dMainLoop(B3DRasterizerState *state, int stopReason);

#endif
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 10/30/2000 20:48'!
b3dInitC
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dInit.c
*   CONTENT: Initialization functions for the B3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#include <string.h>
#include "b3d.h"

#define b3dCompensateWindowPos 1

/* helpers */
#define rasterPosX rasterPos[0]
#define rasterPosY rasterPos[1]
#define rasterPosZ rasterPos[2]
#define rasterPosW rasterPos[3]

#define windowPosX windowPos[0]
#define windowPosY windowPos[1]

#define texCoordS texCoord[0]
#define texCoordT texCoord[1]

/*************************************************************/
/*************************************************************/
/*************************************************************/
int b3dInitializeEdgeAllocator(void* base, int length)
{
	B3DEdgeAllocList *list = (B3DEdgeAllocList*) base;
	if(length < sizeof(B3DEdgeAllocList))
		return B3D_GENERIC_ERROR;
	list->magic = B3D_EDGE_ALLOC_MAGIC;
	list->This = base;
	list->max = (length - sizeof(B3DEdgeAllocList)) / sizeof(B3DPrimitiveEdge) + 1;
	list->size = 0;
	list->nFree = list->max;
	list->firstFree = NULL;
	return B3D_NO_ERROR;
}

int b3dInitializeFaceAllocator(void* base, int length)
{
	B3DFaceAllocList *list = (B3DFaceAllocList*) base;
	if(length < sizeof(B3DFaceAllocList))
		return B3D_GENERIC_ERROR;
	list->magic = B3D_FACE_ALLOC_MAGIC;
	list->This = base;
	list->max = (length - sizeof(B3DFaceAllocList)) / sizeof(B3DPrimitiveFace) + 1;
	list->size = 0;
	list->nFree = list->max;
	list->firstFree = NULL;
	return B3D_NO_ERROR;
}

int b3dInitializeAttrAllocator(void* base, int length)
{
	B3DAttrAllocList *list = (B3DAttrAllocList*) base;
	if(length < sizeof(B3DAttrAllocList))
		return B3D_GENERIC_ERROR;
	list->magic = B3D_ATTR_ALLOC_MAGIC;
	list->This = base;
	list->max = (length - sizeof(B3DAttrAllocList)) / sizeof(B3DPrimitiveAttribute) + 1;
	list->size = 0;
	list->nFree = list->max;
	list->firstFree = NULL;
	return B3D_NO_ERROR;
}

int b3dInitializeEdgeList(void* base, int length)
{
	B3DPrimitiveEdgeList *list = (B3DPrimitiveEdgeList*) base;
	if(length < sizeof(B3DPrimitiveEdgeList))
		return B3D_GENERIC_ERROR;
	list->magic = B3D_EDGE_LIST_MAGIC;
	list->This = base;
	list->max = (length - sizeof(B3DPrimitiveEdgeList)) / sizeof(B3DPrimitiveEdge*) + 1;
	list->size = 0;
	return B3D_NO_ERROR;
}

int b3dInitializeAET(void* base, int length)
{
	B3DActiveEdgeTable *aet = (B3DActiveEdgeTable *) base;
	if(length < sizeof(B3DActiveEdgeTable))
		return B3D_GENERIC_ERROR;
	aet->magic = B3D_AET_MAGIC;
	aet->This = base;
	aet->max = (length - sizeof(B3DActiveEdgeTable)) / sizeof(B3DPrimitiveEdge*) + 1;
	aet->size = 0;
	aet->leftEdge = aet->rightEdge = NULL;
	aet->lastIntersection = &aet->tempEdge0;
	aet->nextIntersection = &aet->tempEdge1;
	return B3D_NO_ERROR;
}

int b3dInitializeFillList(void* base, int length)
{
	B3DFillList *list = (B3DFillList*) base;
	if(length < sizeof(B3DFillList))
		return B3D_GENERIC_ERROR;
	list->magic = B3D_FILL_LIST_MAGIC;
	list->This = base;
	list->firstFace = list->lastFace = NULL;
	return B3D_NO_ERROR;
}

/*************************************************************/
/*************************************************************/
/*************************************************************/

/* b3dMapObjectVertices:
	 Map all the vertices of the given object into the designated viewport.
*/
void b3dMapObjectVertices(B3DPrimitiveObject *obj, B3DPrimitiveViewport *vp)
{
	double xScale, yScale, xOfs, yOfs;
	int minX, minY, maxX, maxY;
	double minZ, maxZ;
	B3DPrimitiveVertex *vtx;
	int i;

	xOfs = (vp->x0 + vp->x1) * 0.5 - 0.5;
	yOfs = (vp->y0 + vp->y1) * 0.5 - 0.5;
	xScale = (vp->x1 - vp->x0) * 0.5;
	yScale = (vp->y1 - vp->y0) * -0.5;

	minX = minY = maxX = maxY = 0x7FFFFFFF;
	minZ = maxZ = 0.0;
	vtx = obj->vertices + 1;
	for(i=1; i < obj->nVertices; i++, vtx++)
	{
		double x,y,z,w;
		int scaledX, scaledY;

		w = vtx->rasterPosW;
		if(w) w = 1.0 / w;
		x = vtx->rasterPosX * w * xScale + xOfs;
		y = vtx->rasterPosY * w * yScale + yOfs;
		z = vtx->rasterPosZ * w;

		if(!!b3dCompensateWindowPos) {
			vtx->rasterPosX = (float)x;
			vtx->rasterPosY = (float)y;
		}
		vtx->rasterPosZ = (float)z;
		vtx->rasterPosW = (float)w;

		scaledX = (int) (x * B3D_FloatToFixed);
		scaledY = (int) (y * B3D_FloatToFixed);

		vtx->windowPosX = scaledX;
		vtx->windowPosY = scaledY;
		if(b3dCompensateWindowPos) {
			vtx->rasterPosX = (float) (scaledX * B3D_FixedToFloat);
			vtx->rasterPosY = (float) (scaledY * B3D_FixedToFloat);
		}
		/* Update min/max */
		if(i == 1) {
			minX = maxX = scaledX;
			minY = maxY = scaledY;
			minZ = maxZ = z;
		} else {
			if(scaledX < minX) minX = scaledX;
			else if(scaledX > maxX) maxX = scaledX;
			if(scaledY < minY) minY = scaledY;
			else if(scaledY > maxY) maxY = scaledY;
			if(z < minZ) minZ = z;
			else if(z > maxZ) maxZ = z;
		}

	}

	obj->minX = minX >> B3D_FixedToIntShift;
	obj->maxX = maxX >> B3D_FixedToIntShift;
	obj->minY = minY >> B3D_FixedToIntShift;
	obj->maxY = maxY >> B3D_FixedToIntShift;
	obj->minZ = (float)minZ;
	obj->maxZ = (float)maxZ;
}

/* b3dSetupVertexOrder:
     Setup the ordering of the vertices in each face so that
	   v0 sorts before v1 sorts before v2.
	 Gather some stats on how much locally sorted and invalid
	 faces the object includes.
*/

void b3dSetupVertexOrder(B3DPrimitiveObject *obj)
{
	B3DInputFace *face;
	int i, nSorted, nInvalid;
	B3DPrimitiveVertex *vtx, *lastTopVtx, *newTopVtx;

	face = obj->faces;
	vtx = obj->vertices;
	nSorted = nInvalid = 0;
	lastTopVtx = NULL;
	for(i=0;i<obj->nFaces; i++,face++)
	{
		B3DPrimitiveVertex *vtx0, *vtx1, *vtx2;
		int idx0, idx1, idx2;
		idx0 = face->i0;
		idx1 = face->i1;
		idx2 = face->i2;
		if(0 == (idx0 && idx1 && idx2)) {
			nInvalid++;
			continue;
		}
		vtx0 = vtx + idx0;
		vtx1 = vtx + idx1;
		vtx2 = vtx + idx2;
		if(vtxSortsBefore(vtx0,vtx1))
		{
			if(vtxSortsBefore(vtx1,vtx2)) { 
				face->i0 = idx0; 
				face->i1 = idx1; 
				face->i2 = idx2; 
			} else if(vtxSortsBefore(vtx0,vtx2)) {
				face->i0 = idx0;
				face->i1 = idx2;
				face->i2 = idx1;
			} else {
				face->i0 = idx2;
				face->i1 = idx0;
				face->i2 = idx1;
			}
		} else if(vtxSortsBefore(vtx0, vtx2)) {
			face->i0 = idx1;
			face->i1 = idx0;
			face->i2 = idx2;
		} else if(vtxSortsBefore(vtx1, vtx2)) {
			face->i0 = idx1;
			face->i1 = idx2;
			face->i2 = idx0;
		} else {
			face->i0 = idx2;
			face->i1 = idx1;
			face->i2 = idx0;
		}

		if(b3dDebug) {
			vtx0 = vtx + face->i0;
			vtx1 = vtx + face->i1;
			vtx2 = vtx + face->i2;
			if( !!vtxSortsBefore(vtx0, vtx1) || 
				!!vtxSortsBefore(vtx0, vtx2) || 
				!!vtxSortsBefore(vtx1, vtx2))
					b3dAbort("Vertex order problem");
		}

		/* Experimental: Try to estimate how many faces are already sorted. */
		newTopVtx = vtx + face->i0;
		if(lastTopVtx)
			if(vtxSortsBefore(lastTopVtx, newTopVtx)) nSorted++;
		lastTopVtx = newTopVtx;
	}

	obj->nSortedFaces = nSorted;
	obj->nInvalidFaces = nInvalid;
}

/* b3dSortInitialFaces:
     Sort the faces of the given object according to the given sort order.
	 Note: It is assumed that the vertex order of the faces has been setup
	       before.
*/

void b3dQuickSortInitialFaces(B3DPrimitiveObject *obj, int i, int j)
{
	B3DInputFace tmp, *faces = obj->faces;
	int ij, k, l, n;
	B3DPrimitiveVertex *di, *dj, *dij, *tt, *vtx = obj->vertices;

	n = j + 1 - i;
	if(n <= 1) return;
	/* Sort di,dj. */
	di = vtx + faces[i].i0;
	dj = vtx + faces[j].i0;
	if(!!vtxSortsBefore(di,dj))
	{
		tmp = faces[i]; faces[i] = faces[j]; faces[j] = tmp;
		tt = di; di = dj; dj = tt;
	}

	if(n <= 2) return;

	/* More than two elements. */
	ij = (i+j) >> 1; /* ij is the midpoint of i and j. */
	dij = vtx + faces[ij].i0;
	/* Sort di,dij,dj.  Make dij be their median. */
	if(vtxSortsBefore(di, dij)) {/* i.e. should di precede dij? */
		if(!!vtxSortsBefore(dij, dj)) {/* i.e., should dij precede dj?*/
			tmp = faces[j]; faces[j] = faces[ij]; faces[ij] = tmp;
			dij = dj;
		}
	} else { /* i.e. di should come after dij */
		tmp = faces[i]; faces[i] = faces[ij]; faces[ij] = tmp;
		dij = di;
	}

	if(n <= 3) return;

	/* More than three elements.
	Find k>i and l<j such that dk,dij,dl are in reverse order.
	Swap k and l.  Repeat this procedure until k and l pass each other.*/
	k = i;
	l = j;

	while(k <= l) {
		while(k <= --l && (vtxSortsBefore(dij, vtx + faces[l].i0)));
		while(++k <= l && (vtxSortsBefore(vtx + faces[k].i0, dij)));
		if(k <= l) {
			tmp = faces[k];
			faces[k] = faces[l];
			faces[l] = tmp;
		}
	}
	/* Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments. */
	b3dQuickSortInitialFaces(obj, i, l);
	b3dQuickSortInitialFaces(obj, k, j);
}

/*************************************************************/
/*************************************************************/
/*************************************************************/


void b3dValidateObjectFaces(B3DPrimitiveObject *obj)
{
	int i;
	B3DInputFace *face,*nextFace;

	face = obj->faces;
	nextFace = face + 1;
	for(i=1; i < obj->nFaces; i++, face++, nextFace++) {
		if(!!vtxSortsBefore(obj->vertices + face->i0, obj->vertices + nextFace->i0))
			b3dAbort("Face sorting problem");
	}
}


#define InitObject(obj, objBase, objFlags, textureIndex) \
	obj = (B3DPrimitiveObject*) objBase; \
	obj->magic = B3D_PRIMITIVE_OBJECT_MAGIC; \
	obj->This = objBase; \
	obj->start = 0; \
	obj->next = NULL; \
	obj->flags = objFlags; \
	obj->textureIndex = textureIndex; \
	obj->texture = NULL;

#define InitVertex(vtx) \
		(vtx)->rasterPosX =				\
		(vtx)->rasterPosY =				\
		(vtx)->rasterPosZ =				\
		(vtx)->rasterPosW =				\
		(vtx)->texCoordS  =				\
		(vtx)->texCoordT  = (float) 0.0;\
		(vtx)->windowPosX =				\
		(vtx)->windowPosY = 0x7FFFFFFF;	\
		(vtx)->cc.pixelValue32 = 0;


/* b3dAddIndexedTriangleObject:
     Create a new primitive object.
*/
int b3dAddIndexedTriangleObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DInputFace *facePtr, int nFaces,
						  B3DPrimitiveViewport *vp)
{
	B3DPrimitiveObject *obj;
	int sizeNeeded;

	sizeNeeded = sizeof(B3DPrimitiveObject) + 
				 sizeof(B3DPrimitiveVertex) * (nVertices+1) +
				 sizeof(B3DInputFace) * nFaces;

	if(!!objBase || objLength < sizeNeeded) 
		return B3D_GENERIC_ERROR;

	InitObject(obj, objBase, objFlags, textureIndex);

	/* copy in the primitive vertices (starting immediately after the prim object) */
	obj->nVertices = nVertices+1; /* For one-based indexing leave one more entry */
	obj->vertices = (B3DPrimitiveVertex*) (obj + 1);
	memcpy(obj->vertices+1, vtxPointer, nVertices * sizeof(B3DPrimitiveVertex));

	/* copy in the input faces (starting after the vertices) */
	obj->nFaces = nFaces;
	obj->faces = (B3DInputFace*) (obj->vertices + obj->nVertices);
	memcpy(obj->faces, facePtr, nFaces * sizeof(B3DInputFace));

	/* Initialize the first vertex with something useful */
	InitVertex(obj->vertices);
	b3dMapObjectVertices(obj, vp);
	b3dSetupVertexOrder(obj);
	b3dQuickSortInitialFaces(obj,0,obj->nFaces-1);


	if(b3dDebug)
		b3dValidateObjectFaces(obj);

	return B3D_NO_ERROR;
}

/* b3dAddIndexedQuadObject:
     Create a new primitive object.
*/
int b3dAddIndexedQuadObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DInputQuad *quadPtr, int nQuads,
						  B3DPrimitiveViewport *vp)
{
	B3DPrimitiveObject *obj;
	int sizeNeeded;

	sizeNeeded = sizeof(B3DPrimitiveObject) + 
				 sizeof(B3DPrimitiveVertex) * (nVertices+1) +
				 sizeof(B3DInputFace) * nQuads * 2;

	if(!!objBase || objLength < sizeNeeded) 
		return B3D_GENERIC_ERROR;

	InitObject(obj, objBase, objFlags, textureIndex);

	/* copy in the primitive vertices (starting immediately after the prim object) */
	obj->nVertices = nVertices+1; /* For one-based indexing leave one more entry */
	obj->vertices = (B3DPrimitiveVertex*) (obj + 1);
	memcpy(obj->vertices+1, vtxPointer, nVertices * sizeof(B3DPrimitiveVertex));

	/* copy in the input faces (starting after the vertices) */
	obj->nFaces = nQuads * 2;
	obj->faces = (B3DInputFace*) (obj->vertices + obj->nVertices);
	{
		int i, nFaces = obj->nFaces;
		B3DInputQuad *src = quadPtr;
		B3DInputFace *dst = obj->faces;

		for(i=0; i < nQuads; i++, src++) {
			dst->i0 = src->i0;
			dst->i1 = src->i1;
			dst->i2 = src->i2;
			dst++;
			dst->i0 = src->i2;
			dst->i1 = src->i3;
			dst->i2 = src->i0;
			dst++;
		}
	}

	/* Initialize the first vertex with something useful */
	InitVertex(obj->vertices);
	b3dMapObjectVertices(obj, vp);
	b3dSetupVertexOrder(obj);
	b3dQuickSortInitialFaces(obj,0,obj->nFaces-1);

	if(b3dDebug)
		b3dValidateObjectFaces(obj);

	return B3D_NO_ERROR;
}

/* b3dAddPolygonObject:
     Create a new primitive object.
*/
int b3dAddPolygonObject(void *objBase, int objLength, int objFlags, int textureIndex,
						  B3DPrimitiveVertex *vtxPointer, int nVertices,
						  B3DPrimitiveViewport *vp)
{
	B3DPrimitiveObject *obj;
	int sizeNeeded;

	sizeNeeded = sizeof(B3DPrimitiveObject) + 
				 sizeof(B3DPrimitiveVertex) * (nVertices+1) +
				 sizeof(B3DInputFace) * (nVertices - 2);

	if(!!objBase || objLength < sizeNeeded) 
		return B3D_GENERIC_ERROR;

	InitObject(obj, objBase, objFlags, textureIndex);

	/* copy in the primitive vertices (starting immediately after the prim object) */
	obj->nVertices = nVertices+1; /* For one-based indexing leave one more entry */
	obj->vertices = (B3DPrimitiveVertex*) (obj + 1);
	memcpy(obj->vertices+1, vtxPointer, nVertices * sizeof(B3DPrimitiveVertex));

	/* copy in the input faces (starting after the vertices) */
	obj->nFaces = nVertices - 2;
	obj->faces = (B3DInputFace*) (obj->vertices + obj->nVertices);
	{
		B3DInputFace *dst = obj->faces;
		int i, nFaces = obj->nFaces;

		for(i=0; i < nFaces; i++, dst++) {
			dst->i0 = 1;
			dst->i1 = 2+i;
			dst->i2 = 3+i;
		}
	}

	/* Initialize the first vertex with something useful */
	InitVertex(obj->vertices);
	b3dMapObjectVertices(obj, vp);
	b3dSetupVertexOrder(obj);
	b3dQuickSortInitialFaces(obj,0,obj->nFaces-1);

	if(b3dDebug)
		b3dValidateObjectFaces(obj);

	return B3D_NO_ERROR;
}

/*************************************************************/
/*************************************************************/
/*************************************************************/

int b3dLoadTexture(B3DTexture *texture,
				   int width, int height, int depth, unsigned int *bits,
				   int cmSize, unsigned int *colormap)
{	int nBits;

	if(width < 1 || height < 1) return B3D_GENERIC_ERROR;
	if(depth !!= 32) return B3D_GENERIC_ERROR;
	if(depth !!= 8  && depth !!= 16 && depth !!= 32) return B3D_GENERIC_ERROR;
	if(depth == 8 && cmSize < 256) return B3D_GENERIC_ERROR;
	texture->width = width;
	texture->height = height;
	texture->depth = depth;
	texture->data = bits;
	texture->cmSize = cmSize;
	texture->colormap = colormap;
	texture->rowLength = width;
	nBits = 1;
	while((1 << nBits) < width) nBits++;
	if((1<<nBits) == width) {
		texture->sMask = (1<<nBits) - 1;
		texture->sShift = nBits;
	} else {
		texture->sMask = texture->sShift = 0;
	}
	while((1 << nBits) < height) nBits++;
	if((1<<nBits) == height) {
		texture->tMask = (1<<nBits) - 1;
		texture->tShift = nBits;
	} else {
		texture->tMask = texture->tShift = 0;
	}
	return B3D_NO_ERROR;
}
/*************************************************************/
/*************************************************************/
/*************************************************************/
/* b3dQuickSortObjects:
	Sort the objects in the given range.
*/

void b3dQuickSortObjects(B3DPrimitiveObject **array, int i, int j)
{
	int ij, k, l, n;
	B3DPrimitiveObject *di, *dj, *dij, *tmp;
	
	n = j + 1 - i;
	if(n <= 1) return;
	/* Sort di,dj. */
	di = array[i];
	dj = array[j];
	if(!!objSortsBefore(di,dj))
	{
		tmp = array[i]; array[i] = array[j]; array[j] = tmp;
		tmp = di; di = dj; dj = tmp;
	}

	if(n <= 2) return;

	/* More than two elements. */
	ij = (i+j) >> 1; /* ij is the midpoint of i and j. */
	dij = array[ij];
	/* Sort di,dij,dj.  Make dij be their median. */
	if(objSortsBefore(di, dij)) {/* i.e. should di precede dij? */
		if(!!objSortsBefore(dij, dj)) {/* i.e., should dij precede dj?*/
			tmp = array[j]; array[j] = array[ij]; array[ij] = tmp;
			dij = dj;
		}
	} else { /* i.e. di should come after dij */
		tmp = array[i]; array[i] = array[ij]; array[ij] = tmp;
		dij = di;
	}

	if(n <= 3) return;

	/* More than three elements.
	Find k>i and l<j such that dk,dij,dl are in reverse order.
	Swap k and l.  Repeat this procedure until k and l pass each other.*/
	k = i;
	l = j;

	while(k <= l) {
		while(k <= --l && (objSortsBefore(dij, array[l])));
		while(++k <= l && (objSortsBefore(array[k], dij)));
		if(k <= l) { tmp = array[k]; array[k] = array[l]; array[l] = tmp; }
	}
	/* Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments. */
	b3dQuickSortObjects(array, i, l);
	b3dQuickSortObjects(array, k, j);
}

/* b3dSetupObjects:
	Sort the objects and create a linked list between the objects.
*/
void b3dSetupObjects(B3DRasterizerState *state)
{
	int i, textureIndex, nTextures = state->nTextures, nObjects = state->nObjects;
	B3DPrimitiveObject *obj, **objects = state->objects;
	B3DTexture *textures = state->textures;

	b3dQuickSortObjects(objects, 0, nObjects-1);

	for(i=0; i<nObjects; i++) {

		if(b3dDebug && i) {
			if(!!objSortsBefore(objects[i-1], objects[i]))
				b3dAbort("Object sorting problem");
		}

		obj = objects[i];
		obj->flags &= ~(B3D_OBJECT_ACTIVE | B3D_OBJECT_DONE);
		obj->start = 0;
		/*-- Note: The following is important --*/
		obj->nFaces -= obj->nInvalidFaces;
		if(!!obj->nFaces) break;
		/*-- End --*/
		textureIndex = obj->textureIndex - 1;
		if(textureIndex >= 0 && textureIndex < nTextures) {
			obj->texture = textures + textureIndex;
			obj->flags |= B3D_FACE_STW;
		} else obj->texture = NULL;
		obj->next = NULL;
		if(i) {
			objects[i-1]->next = obj;
			obj->prev = objects[i-1];
		}
	}
}
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/18/1999 08:33'!
b3dMainC
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dMain.c
*   CONTENT: Main rasterizer body
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#include <stdio.h>  /* printf() */
#include <stdlib.h> /* exit()   */
#include <assert.h> /* assert() */
#include "b3d.h"

#ifndef NULL
#define NULL ((void*)0)
#endif

#ifdef B3D_PROFILE
unsigned int b3dObjSetupTime;
unsigned int b3dMapObjectTime;
unsigned int b3dVertexOrderTime;
unsigned int b3dSortFaceTime;
#endif

/* helpers */
#define rasterPosX rasterPos[0]
#define rasterPosY rasterPos[1]
#define rasterPosZ rasterPos[2]
#define rasterPosW rasterPos[3]

#define windowPosX windowPos[0]
#define windowPosY windowPos[1]

#define texCoordS texCoord[0]
#define texCoordT texCoord[1]

#define redValue   cc.color[RED_INDEX]
#define greenValue cc.color[GREEN_INDEX]
#define blueValue  cc.color[BLUE_INDEX]
#define alphaValue cc.color[ALPHA_INDEX]

/* globals */
B3DRasterizerState *currentState;

B3DActiveEdgeTable *aet;
B3DPrimitiveEdgeList *addedEdges;

B3DEdgeAllocList *edgeAlloc;
B3DFaceAllocList *faceAlloc;
B3DAttrAllocList *attrAlloc;

int nFaces = 0;
int maxFaces = 0;
int maxEdges = 0;
/*************************************************************/
/*************************************************************/
/*************************************************************/

void b3dAbort(char *msg){
	printf(msg);
	exit(-1);
}

void b3dValidateEdgeOrder(B3DPrimitiveEdgeList *list)
{
	int i;

	if(list->size)
		if(list->data[0]->leftFace == list->data[0]->rightFace) {
			b3dAbort("Left face == right face");
		}
	for(i=1; i<list->size; i++) {
		if(list->data[i-1]->xValue > list->data[i]->xValue) {
			b3dAbort("Edge list is broken");
		}
		if(list->data[i]->leftFace == list->data[i]->rightFace) {
			b3dAbort("Left face == right face");
		}
	}
}

void b3dValidateAETOrder(B3DActiveEdgeTable *list)
{
	int i;

	if(list->size)
		if(list->data[0]->leftFace == list->data[0]->rightFace) {
			b3dAbort("Left face == right face");
		}
	for(i=1; i<list->size; i++) {
		if(list->data[i-1]->xValue > list->data[i]->xValue) {
			b3dAbort("Edge list is broken");
		}
		if(list->data[i]->leftFace == list->data[i]->rightFace) {
			b3dAbort("Left face == right face");
		}
	}
}

/*************************************************************/
/*************************************************************/
/*************************************************************/
/* b3dInitializeFace:
	Allocate a new primitive face based on the given vertices.
	Do the necessary initial setup, but don''t set up any drawing attributes yet.
	Return the newly created face.
	NOTE: May cause allocation of one face!!
*/
B3DPrimitiveFace *b3dInitializeFace(B3DPrimitiveVertex *v0,
									B3DPrimitiveVertex *v1,
									B3DPrimitiveVertex *v2,
									B3DTexture *texture, 
									int attrFlags)
{
	B3DPrimitiveFace *face;

	/* Compute major and minor reference edges */
	{
		float majorDx = v2->rasterPosX - v0->rasterPosX;
		float majorDy = v2->rasterPosY - v0->rasterPosY;
		float minorDx = v1->rasterPosX - v0->rasterPosX;
		float minorDy = v1->rasterPosY - v0->rasterPosY;
		float area = (majorDx * minorDy) - (minorDx * majorDy);

		if(area > -0.001 && area < 0.001) return NULL;
		/* Now that we know the face is valid, do the actual allocation */
		b3dAllocFace(faceAlloc, face);

		if(b3dDebug)
			if(!!face) b3dAbort("Face allocation failed");

		face->v0 = v0;
		face->v1 = v1;
		face->v2 = v2;
		face->leftEdge = NULL;
		face->rightEdge = NULL;
		face->attributes = NULL;
		face->oneOverArea = (float) (1.0 / area);
		face->majorDx = majorDx;
		face->majorDy = majorDy;
		face->minorDx = minorDx;
		face->minorDy = minorDy;
		face->texture = texture;
		face->flags |= attrFlags & (B3D_ATTR_MASK << B3D_ATTR_SHIFT);

		{ /* Compute dzdx and dzdy */
			float majorDz = v2->rasterPosZ - v0->rasterPosZ;
			float minorDz = v1->rasterPosZ - v0->rasterPosZ;

			face->dzdx = face->oneOverArea * ((majorDz * minorDy) - (minorDz * majorDy));
			face->dzdy = face->oneOverArea * ((majorDx * minorDz) - (minorDx * majorDz));
		}
	}

	{/* Compute minZ/maxZ */
		float z0 = v0->rasterPosZ;
		float z1 = v1->rasterPosZ;
		float z2 = v2->rasterPosZ;
		if(z0 <= z1) {
			if(z1 <= z2) {
				face->minZ = z0;
				face->maxZ = z2;
			} else if(z0 <= z2) {
				face->minZ = z0;
				face->maxZ = z1;
			} else {
				face->minZ = z2;
				face->maxZ = z1;
			}
		} else if(z2 <= z1) {
			face->minZ = z2;
			face->maxZ = z0;
		} else if(z0 <= z2) {
			face->minZ = z1;
			face->maxZ = z0;
		} else {
			face->minZ = z1;
			face->maxZ = z0;
		}
	} /* End of minZ/maxZ */

	return face;
}

/* b3dInitializePass2:
	Do a second initialization pass if the face is known to be visible.
*/
int b3dInitializePass2(B3DPrimitiveFace *face)
{
	double majorDv, minorDv, baseValue;
	double dvdx, dvdy;
	B3DPrimitiveAttribute *attr;
	B3DPrimitiveVertex *v0 = face->v0;
	B3DPrimitiveVertex *v1 = face->v1;
	B3DPrimitiveVertex *v2 = face->v2;

	{
		int ok;
		b3dAllocAttrib(attrAlloc, face, ok);
		if(!!ok) return 0; /* NOT initalized */
	}

	attr = face->attributes;
	assert(attr);
	
	if(face->flags & B3D_FACE_RGB) {
		/* Setup RGB interpolation */
		majorDv = v2->redValue - v0->redValue;
		minorDv = v1->redValue - v0->redValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) v0->redValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;

		majorDv = v2->greenValue - v0->greenValue;
		minorDv = v1->greenValue - v0->greenValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) v0->greenValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;

		majorDv = v2->blueValue - v0->blueValue;
		minorDv = v1->blueValue - v0->blueValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) v0->blueValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;
	}
	if(face->flags & B3D_FACE_ALPHA) {
		/* Setup alpha interpolation */
		majorDv = v2->alphaValue - v0->alphaValue;
		minorDv = v1->alphaValue - v0->alphaValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) v0->alphaValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;
	}
	if(face->flags & B3D_FACE_STW) {
		/* Setup texture coordinate interpolation */
		double w0 = v0->rasterPosW;
		double w1 = v1->rasterPosW;
		double w2 = v2->rasterPosW;

		majorDv = w2 - w0;
		minorDv = w1 - w0;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) w0;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;

		baseValue = v0->texCoordS * w0;
		majorDv = (v2->texCoordS * w2) - baseValue;
		minorDv = (v1->texCoordS * w1) - baseValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) baseValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;

		baseValue = v0->texCoordT * w0;
		majorDv = (v2->texCoordT * w2) - baseValue;
		minorDv = (v1->texCoordT * w1) - baseValue;
		dvdx = face->oneOverArea * ((majorDv * face->minorDy) - (minorDv * face->majorDy));
		dvdy = face->oneOverArea * ((minorDv * face->majorDx) - (majorDv * face->minorDx));
		attr->value = (float) baseValue;
		attr->dvdx  = (float) dvdx;
		attr->dvdy  = (float) dvdy;
		attr = attr->next;
	}
	face->flags |= B3D_FACE_INITIALIZED;
	return 1;
}

/* b3dInitializeEdge:
	Initialize the incremental values of the given edge.
*/
/* INLINE b3dInitializeEdge(edge) */
void b3dInitializeEdge(B3DPrimitiveEdge *edge)
{
	assert(edge);
	assert(edge->nLines);
	edge->xValue = edge->v0->windowPosX;
	edge->zValue = edge->v0->rasterPosZ;
	if(edge->nLines > 1) {
		edge->xIncrement = (edge->v1->windowPosX - edge->v0->windowPosX) / edge->nLines;
		edge->zIncrement = (edge->v1->rasterPosZ - edge->v0->rasterPosZ) / (float) edge->nLines;
	} else {
		edge->xIncrement = (edge->v1->windowPosX - edge->v0->windowPosX);
		edge->zIncrement = (edge->v1->rasterPosZ - edge->v0->rasterPosZ);
	}
}
/* --INLINE-- */


/*************************************************************/
/*************************************************************/
/*************************************************************/

/* b3dFirstIndexForInserting:
	Return the first possible index for inserting an edge with the given x value.
*/

int b3dFirstIndexForInserting(B3DPrimitiveEdgeList *list, int xValue)
{
	int low, high, index;
	low = 0;
	high = list->size-1;
	while(low <= high) {
		index = (low + high) >> 1;
		if(list->data[index]->xValue <= xValue)
			low = index+1;
		else
			high = index-1;
	}
	index = low;
	while(index > 0 && (list->data[index-1]->xValue) == xValue)
		index--;
	return index;
}

/* b3dAddEdgeBeforeIndex:
	Insert the edge to the list before the given index.
*/
/* INLINE b3dAddEdgeBeforeIndex(list, edge, index) */
void b3dAddEdgeBeforeIndex(B3DPrimitiveEdgeList *list, B3DPrimitiveEdge *edge, int index)
{
	int i;

	if(b3dDebug)
		if(list->size == list->max)
			b3dAbort("No more space for adding edges");

	assert( (list->size == index) || (list->data[index]->xValue >= edge->xValue));
	for(i=list->size-1; i >= index; i--)
		list->data[i+1] = list->data[i];
	list->data[index] = edge;
	list->size++;
}
/* --INLINE-- */

/* b3d2AddEdgesBeforeIndex:
	Insert the two edge to the list before the given index.
*/
/* INLINE b3dAdd2EdgesBeforeIndex(list, edge1, edge2, index) */
void b3dAdd2EdgesBeforeIndex(B3DPrimitiveEdgeList *list, 
							 B3DPrimitiveEdge *edge1, 
							 B3DPrimitiveEdge *edge2, 
							 int index)
{
	int i;

	if(b3dDebug)
		if(list->size+1 >= list->max)
			b3dAbort("No more space for adding edges");

	assert( edge1->xValue == edge2->xValue);
	assert( (list->size == index) || (list->data[index]->xValue >= edge1->xValue));

	for(i=list->size-1; i >= index; i--)
		list->data[i+2] = list->data[i];
	list->data[index] = edge1;
	list->data[index+1] = edge2;
	list->size += 2;
}
/* --INLINE-- */

/* b3dAdjustFaceEdges:
	Assign left and right edges to the given face.
*/
/* INLINE b3dAdjustFaceEdges(face, edge1, edge2) */
void b3dAdjustFaceEdges(B3DPrimitiveFace *face, B3DPrimitiveEdge *edge1, B3DPrimitiveEdge *edge2)
{
	assert(face);
	assert(edge1);
	assert(edge2);
	if(edge1->xValue == edge2->xValue) {
		if(edge1->xIncrement <= edge2->xIncrement) {
			face->leftEdge = edge1;
			face->rightEdge = edge2;
		} else {
			face->leftEdge = edge2;
			face->rightEdge = edge1;
		}
	} else {
		if(edge1->xValue <= edge2->xValue) {
			face->leftEdge = edge1;
			face->rightEdge = edge2;
		} else {
			face->leftEdge = edge2;
			face->rightEdge = edge1;
		}
	}
}
/* --INLINE-- */

/* b3dAddLowerEdgeFromFace:
	Add a new lower edge from the given face.
	NOTE: oldEdge may be NULL!!
	NOTE: May cause allocation of one edge!!
*/
B3DPrimitiveEdge *b3dAddLowerEdgeFromFace(B3DPrimitiveFace *face, B3DPrimitiveEdge *oldEdge)
{
	B3DPrimitiveVertex *v0 = face->v0;
	B3DPrimitiveVertex *v1 = face->v1;
	B3DPrimitiveVertex *v2 = face->v2;
	int xValue = v1->windowPosX;
	int index;

	/* Search the list of added edges to merge the edges from the face */
	index = b3dFirstIndexForInserting(addedEdges, xValue);
	for(;index<addedEdges->size; index++) {
		B3DPrimitiveEdge *edge = addedEdges->data[index];
		if(edge->xValue !!= xValue) break;
		if(edge->rightFace) continue;
		if((edge->v0 == v1 && edge->v1 == v2) || /* The simple test*/
			/* The complex test */
			(edge->v0->windowPosX == v1->windowPosX &&
			 edge->v0->windowPosY == v1->windowPosY &&
			 edge->v0->rasterPosZ == v1->rasterPosZ &&
			 edge->v1->windowPosX == v2->windowPosX &&
			 edge->v1->windowPosY == v2->windowPosY &&
			 edge->v1->rasterPosZ == v2->rasterPosZ)) {
			/* Found the edge */
			if(face->leftEdge == oldEdge)
				face->leftEdge = edge;
			else
				face->rightEdge = edge;
			edge->rightFace = face;
			return edge;
		}
	}
	/* Need to create a new edge.
	   NOTE: Index already points to the right insertion point.
	*/
	{
		B3DPrimitiveEdge *minorEdge;
		int nLines = (v2->windowPosY >> B3D_FixedToIntShift) - (v1->windowPosY >> B3D_FixedToIntShift);
		if(!!nLines) return NULL; /* Edge is horizontal */
		b3dAllocEdge(edgeAlloc, minorEdge);

		if(b3dDebug)
			if(!!minorEdge)
				b3dAbort("Edge allocation failed");

		minorEdge->v0 = v1;
		minorEdge->v1 = v2;
		minorEdge->nLines = nLines;
		minorEdge->leftFace = face;
		minorEdge->rightFace = NULL;
		if(face->leftEdge == oldEdge)
			face->leftEdge = minorEdge;
		else
			face->rightEdge = minorEdge;
		b3dInitializeEdge(minorEdge);
		b3dAddEdgeBeforeIndex(addedEdges, minorEdge, index);
		return minorEdge;
	}
	/* NOT REACHED */
}

/* b3dAddEdgesFromFace:
	Add the two new edges from the given primitive face.
	NOTE: May cause allocation of two edges (but not three)!!
*/
void b3dAddEdgesFromFace(B3DPrimitiveFace *face, int yValue)
{
	int needMajor = 1;
	int needMinor = 1;
	B3DPrimitiveEdge *majorEdge = NULL;
	B3DPrimitiveEdge *minorEdge = NULL;
	B3DPrimitiveVertex *v0 = face->v0;
	B3DPrimitiveVertex *v1 = face->v1;
	B3DPrimitiveVertex *v2 = face->v2;
	int xValue = v0->windowPosX;
	int index;

	/* Search the list of added edges to merge the edges from the face */
	index = b3dFirstIndexForInserting(addedEdges, xValue);
	for(;index<addedEdges->size; index++) {
		B3DPrimitiveEdge *edge = addedEdges->data[index];
		if(edge->xValue !!= xValue) break;
		if(edge->rightFace) continue;
		if(edge->v0 !!= v0 &&
			(edge->v0->windowPosY !!= v0->windowPosY ||
			 edge->v0->rasterPosZ !!= v0->rasterPosZ)) continue;
		/* If we come to this point the edge might be usable for merging the face */
		if(needMajor && /* Test only if major edge is needed */
			(edge->v1 == v2 || /* Simple test */
			/* A more complex test */
			(edge->v1->windowPosX == v2->windowPosX &&
			 edge->v1->windowPosY == v2->windowPosY &&
			 edge->v1->rasterPosZ == v2->rasterPosZ))) {
			/* Yepp. That''s the new major */
			majorEdge = edge;
			majorEdge->rightFace = face;
			majorEdge->flags  |= B3D_EDGE_RIGHT_MAJOR;
			
			if(b3dDoStats) nFaces++;

			if(!!needMinor) {
				b3dAdjustFaceEdges(face, majorEdge, minorEdge);
				return; /* done */
			}
			needMajor = 0;
		} else if(needMinor && /* Test only if minor edge is needed */
			(edge->v1 == v1 || /* Simple test */
			/* A more complex test */
			(edge->v1->windowPosX == v1->windowPosX &&
			 edge->v1->windowPosY == v1->windowPosY &&
			 edge->v1->rasterPosZ == v1->rasterPosZ))) {
			/* Yepp. That''s the new minor */
			minorEdge = edge;
			minorEdge->rightFace = face;
			minorEdge->flags |= B3D_EDGE_CONTINUE_RIGHT;
			if(!!needMajor) {
				b3dAdjustFaceEdges(face, majorEdge, minorEdge);
				return; /* done */
			}
			needMinor = 0;
		}
	}
	/*  Need to create new edges.
		Note: index already points to the right insertion point in addedEdges 
	*/
	if(needMajor) {
		int nLines = (v2->windowPosY >> B3D_FixedToIntShift) - (v0->windowPosY >> B3D_FixedToIntShift);

		if(!!nLines) {
			/* The major edge is horizontal. */
			b3dFreeFace(faceAlloc, face);
			return;
		}
		b3dAllocEdge(edgeAlloc, majorEdge);
		if(b3dDebug)
			if(!!majorEdge) b3dAbort("Edge allocation failed");
		majorEdge->v0 = v0;
		majorEdge->v1 = v2;
		majorEdge->nLines = nLines;
		majorEdge->leftFace = face;
		majorEdge->rightFace = NULL;
		majorEdge->flags  |= B3D_EDGE_LEFT_MAJOR;
		b3dInitializeEdge(majorEdge);
		if(b3dDoStats) nFaces++;
	}

	if(needMinor) {
		int nLines = (v1->windowPosY >> B3D_FixedToIntShift) - (v0->windowPosY >> B3D_FixedToIntShift);

		if(!!nLines) {
			/* Note: If the (upper) minor edge is horizontal, use the lower one.
			   Note: The lower edge cannot be horizontal if the major edge isn''t
			*/
			if(needMajor) {
				b3dAddEdgeBeforeIndex(addedEdges, majorEdge, index);
			}
			minorEdge = b3dAddLowerEdgeFromFace(face,NULL);

			if(b3dDebug)
				if(!!minorEdge || minorEdge->nLines == 0)
					b3dAbort("minor edge is horizontal");

			b3dAdjustFaceEdges(face, majorEdge, minorEdge);
			return;
		}

		b3dAllocEdge(edgeAlloc, minorEdge);

		if(b3dDebug)
			if(!!minorEdge) b3dAbort("Edge allocation failed");

		minorEdge->v0 = v0;
		minorEdge->v1 = v1;
		minorEdge->nLines = nLines;
		minorEdge->leftFace = face;
		minorEdge->rightFace = NULL;
		minorEdge->flags  |= B3D_EDGE_CONTINUE_LEFT;
		b3dInitializeEdge(minorEdge);
	}

	/* Add the newly created edges to addedEdges */
	if(needMinor && needMajor) {
		b3dAdd2EdgesBeforeIndex(addedEdges, majorEdge, minorEdge, index);
	} else if(needMajor) {
		b3dAddEdgeBeforeIndex(addedEdges, majorEdge, index);
	} else {
		b3dAddEdgeBeforeIndex(addedEdges, minorEdge, index);
	}
	b3dAdjustFaceEdges(face, majorEdge, minorEdge);
}


/* b3dRemoveAETEdge:
	Remove the given edge from the AET.
	NOTE: May cause allocation of two edges!!
*/
/* INLINE b3dRemoveAETEdge(aet, edge, yValue, aetPos) */
void b3dRemoveAETEdge(B3DActiveEdgeTable *aet, B3DPrimitiveEdge *edge, int yValue, int aetPos)
{
	/* Remove edge and add lower edges if necessary */
	int j;
	B3DPrimitiveEdge **aetData = aet->data;

	assert(aetData[aetPos] == edge);

	if(b3dDebug)
		if( (edge->v1->windowPosY >> B3D_FixedToIntShift) !!= yValue )
			b3dAbort("Edge exceeds range");

	/* Remove the edge and adjust the stuff */
	for(j=aetPos+1; j < aet->size; j++) aetData[j-1] = aetData[j];
	aet->size--;
	/* Add new lower edges */
	if(edge->flags & B3D_EDGE_CONTINUE_LEFT) {
		b3dAddLowerEdgeFromFace(edge->leftFace, edge);
	}
	if(edge->flags & B3D_EDGE_CONTINUE_RIGHT) {
		b3dAddLowerEdgeFromFace(edge->rightFace, edge);
	}
	if(edge->flags & B3D_EDGE_LEFT_MAJOR) {
		/* Free left face */
		b3dFreeAttrib(attrAlloc, edge->leftFace);
		b3dFreeFace(faceAlloc, edge->leftFace);
		if(b3dDoStats) nFaces--;
	}
	if(edge->flags & B3D_EDGE_RIGHT_MAJOR) {
		/* Free right face */
		b3dFreeAttrib(attrAlloc, edge->rightFace);
		b3dFreeFace(faceAlloc, edge->rightFace);
		if(b3dDoStats) nFaces--;
	}
	/* And free old edge */
	b3dFreeEdge(edgeAlloc, edge);
}
/* --INLINE-- */

/* b3dMergeAETEdgesFrom:
	Merge the edges from the given source into the AET.
*/
void b3dMergeAETEdgesFrom(B3DActiveEdgeTable *aet, B3DPrimitiveEdgeList *src)
{
	int srcIndex, aetIndex, outIndex, i;
	B3DPrimitiveEdge *srcEdge, *aetEdge;

	assert(aet);
	assert(src);
	assert(src->size);
	assert(aet->size + src->size <= aet->max);

	if(!!aet->size) {
		for(i=0; i<src->size; i++) aet->data[i] = src->data[i];
		aet->size += src->size;
		return;
	}

	/* Merge the input by stepping backwards through the aet and checking each edge */
	outIndex = aet->size + src->size - 1;
	srcIndex = src->size-1;
	aetIndex = aet->size-1;
	srcEdge = src->data[srcIndex];
	aetEdge = aet->data[aetIndex];
	aet->size += src->size;
	while(1) {
		if(srcEdge->xValue >= aetEdge->xValue) {
			/* output srcEdge */
			aet->data[outIndex--] = srcEdge;
			if(!!srcIndex--) return;
			srcEdge = src->data[srcIndex];
		} else {
			/* output aetEdge */
			aet->data[outIndex--] = aetEdge;
			if(!!aetIndex--) {
				for(i=0; i <= srcIndex; i++) aet->data[i] = src->data[i];
				return;
			}
			aetEdge = aet->data[aetIndex];
		}
	}
}

/* INLINE b3dAdvanceAETEdge(edge, aetData, aetStart) */
void b3dAdvanceAETEdge(B3DPrimitiveEdge *edge,
					B3DPrimitiveEdge **aetData,
					int aetStart)
{
	/* Advance to next scan line */
	edge->zValue += edge->zIncrement;
	edge->xValue += edge->xIncrement;
	/* Check if AET sort order is okay */
	if(aetStart && aetData[aetStart-1]->xValue > edge->xValue) {
		/* Must resort rightEdge */
		int xValue = edge->xValue;
		int j = aetStart;
		/* Move the edge left */
		while(j>0 && aetData[j-1]->xValue > xValue) {
			aetData[j] = aetData[j-1];
			j--;
		}
		aetData[j] = edge;
	}
}
/* --INLINE-- */

/*************************************************************/
/*************************************************************/
/*************************************************************/
#ifdef DEBUG
double zValueAt(B3DPrimitiveFace *face, double xValue, double yValue)
{
	return 
		(face->v0->rasterPosZ +
			(((double)xValue - face->v0->rasterPosX) * face->dzdx) +
			(((double)yValue - face->v0->rasterPosY) * face->dzdy));
}
#else
#define zValueAt(face, xValue, yValue) \
		((face)->v0->rasterPosZ + \
			(((double)(xValue) - (face)->v0->rasterPosX) * (face)->dzdx) +\
			(((double)(yValue) - (face)->v0->rasterPosY) * (face)->dzdy))
#endif

/*************************************************************/
/*************************************************************/
/*************************************************************/

int b3dComputeIntersection(B3DPrimitiveFace *frontFace, 
						   B3DPrimitiveFace *backFace, 
						   int yValue, 
						   int errorValue)
{
	double dx1 = frontFace->rightEdge->xValue - frontFace->leftEdge->xValue;
	double dz1 = frontFace->rightEdge->zValue - frontFace->leftEdge->zValue;
	double dx2 = backFace->rightEdge->xValue - backFace->leftEdge->xValue;
	double dz2 = backFace->rightEdge->zValue - backFace->leftEdge->zValue;
	double px = backFace->leftEdge->xValue - frontFace->leftEdge->xValue;
	double pz = backFace->leftEdge->zValue - frontFace->leftEdge->zValue;
	double det = (dx1 * dz2) - (dx2 * dz1);
	if(det == 0.0) return errorValue;
	{ 
		double det2 = ((px * dz2) - (pz * dx2)) / det;
		return frontFace->leftEdge->xValue + (int)(dx1 * det2);
	}
	/* not reached */
}

/* b3dCheckIntersectionOfFaces:
	Compute the possible intersection of frontFace and backFace.
	Store the result in nextIntersection if it is before any other
	intersection. Return true if other intersections tests should
	be performed, false otherwise.
*/
int b3dCheckIntersectionOfFaces(B3DPrimitiveFace *frontFace,
								 B3DPrimitiveFace *backFace,
								 int yValue,
								 B3DPrimitiveEdge *leftEdge,
								 B3DPrimitiveEdge *nextIntersection)
{
	double frontZ, backZ;
	int xValue, rightX;

	/* Check if the backFace is completely behind the front face */
	if(backFace->minZ >= frontFace->maxZ) return 0; /* abort */

	/* Check if front and back face share any edges */
	if(frontFace->leftEdge == backFace->leftEdge) return 1; /* proceed */
	if(frontFace->rightEdge == backFace->rightEdge) return 1; /* proceed */

	/* Check if either front or back face are less than 1 pixel wide */
	if( (frontFace->leftEdge->xValue >> B3D_FixedToIntShift) ==
		(frontFace->rightEdge->xValue >> B3D_FixedToIntShift)) return 0; /* abort */
	if( (backFace->leftEdge->xValue >> B3D_FixedToIntShift) ==
		(backFace->rightEdge->xValue >> B3D_FixedToIntShift)) return 1; /* proceed */

	/* Choose the right x value of either front or back face,
		whichever is less (this is so we sample inside both faces) */
	if(frontFace->rightEdge->xValue <= backFace->rightEdge->xValue) {
		rightX = frontFace->rightEdge->xValue;
		frontZ = frontFace->rightEdge->zValue;
		backZ = zValueAt(backFace, rightX * B3D_FixedToFloat, yValue);
	} else {
		rightX = backFace->rightEdge->xValue;
		backZ = backFace->rightEdge->zValue;
		frontZ = zValueAt(frontFace, rightX * B3D_FixedToFloat, yValue);
	}

	if(backZ < frontZ) {
		/* possible intersection found */
		xValue = b3dComputeIntersection(frontFace, backFace, yValue, leftEdge->xValue);
		if(xValue > rightX) xValue = rightX;
		/* Ignore intersections at or before the leftEdge''s x value. Important. */
		if((xValue >> B3D_FixedToIntShift) <= (leftEdge->xValue >> B3D_FixedToIntShift))
			xValue = ((leftEdge->xValue >> B3D_FixedToIntShift) + 1) << B3D_IntToFixedShift;
		if(xValue < nextIntersection->xValue) {
			nextIntersection->xValue = xValue;
			nextIntersection->leftFace = frontFace;
			nextIntersection->rightFace = backFace;
		}
	}
	return 1;
}

/* b3dAdjustIntersections:
	Compute the possible intersections of the current front face
	with all active faces. Store the next intersection if any.
*/
/* INLINE b3dAdjustIntersections(fillList, yValue, topEdge, nextIntersection) */
void b3dAdjustIntersections(B3DFillList *fillList,
							int yValue,
							B3DPrimitiveEdge *topEdge,
							B3DPrimitiveEdge *nextIntersection)
{
	B3DPrimitiveFace *frontFace = fillList->firstFace;
	if(frontFace) {
		B3DPrimitiveFace *backFace = frontFace->nextFace;
		int proceed = 1;
		while(backFace && proceed) {
			proceed = b3dCheckIntersectionOfFaces(frontFace, backFace, yValue, topEdge, nextIntersection);
			backFace = backFace->nextFace;
		}
	}
}
/* --INLINE-- */

/*************************************************************/
/*************************************************************/
/*************************************************************/

void b3dValidateFillList(B3DFillList *list)
{
	B3DPrimitiveFace *firstFace = list->firstFace;
	B3DPrimitiveFace *lastFace = list->lastFace;
	B3DPrimitiveFace *face;

	if(!!firstFace && !!lastFace) return;
	if(firstFace->prevFace)
		b3dAbort("Bad fill list");
	if(lastFace->nextFace)
		b3dAbort("Bad fill list");
	face = firstFace;
	while(face !!= lastFace)
		face = face->nextFace;
	/* Validate sort order */
	if(firstFace == lastFace)
		return; /* 0 or 1 element */
	face = firstFace->nextFace;
	while(face->nextFace) {
		if(face->minZ > face->nextFace->minZ)
			b3dAbort("Fill list sorting problem");
		face = face->nextFace;
	}
}

/* INLINE b3dAddFirstFill(fillList, aFace) */
void b3dAddFirstFill(B3DFillList *fillList, B3DPrimitiveFace *aFace)
{
	B3DPrimitiveFace *firstFace = fillList->firstFace;
	if(firstFace)
		firstFace->prevFace = aFace;
	else
		fillList->lastFace = aFace;
	aFace->nextFace = firstFace;
	aFace->prevFace = NULL;
	fillList->firstFace = aFace;
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dAddLastFill(fillList, aFace) */
void b3dAddLastFill(B3DFillList *fillList, B3DPrimitiveFace *aFace)
{
	B3DPrimitiveFace *lastFace = fillList->lastFace;
	if(lastFace)
		lastFace->nextFace = aFace;
	else
		fillList->firstFace = aFace;
	aFace->prevFace = lastFace;
	aFace->nextFace = NULL;
	fillList->lastFace = aFace;
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dRemoveFill(fillList, aFace) */
void b3dRemoveFill(B3DFillList *fillList, B3DPrimitiveFace *aFace)
{
	if(b3dDebug) b3dValidateFillList(fillList);
	if(aFace->prevFace)
		aFace->prevFace->nextFace = aFace->nextFace;
	else
		fillList->firstFace = aFace->nextFace;
	if(aFace->nextFace)
		aFace->nextFace->prevFace = aFace->prevFace;
	else
		fillList->lastFace = aFace->prevFace;
}
/* --INLINE-- */

/* INLINE b3dInsertBeforeFill(fillList, aFace, otherFace) */
void b3dInsertBeforeFill(B3DFillList *fillList, B3DPrimitiveFace *aFace, B3DPrimitiveFace *otherFace)
{
	assert(otherFace !!= fillList->firstFace);

	aFace->nextFace = otherFace;
	aFace->prevFace = otherFace->prevFace;
	aFace->prevFace->nextFace = aFace;
	otherFace->prevFace = aFace;
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dAddFrontFill(fillList, aFace) */
void b3dAddFrontFill(B3DFillList *fillList, B3DPrimitiveFace *aFace)
{
	B3DPrimitiveFace *firstFace = fillList->firstFace;
	if(firstFace !!= fillList->lastFace) {
		/* Meaning that we must find the new position for the old front face */
		B3DPrimitiveFace *backFace = firstFace->nextFace;
		float minZ = firstFace->minZ;

		while(backFace && backFace->minZ < minZ)
			backFace = backFace->nextFace;

		/* Insert firstFace before backFace */
		if(firstFace->nextFace !!= backFace) {
			B3DPrimitiveFace *tempFace = firstFace;

			b3dRemoveFill(fillList, tempFace);
			if(backFace) {
				b3dInsertBeforeFill(fillList, tempFace, backFace);
			} else {
				b3dAddLastFill(fillList, tempFace);
			}
		}
	}
	b3dAddFirstFill(fillList, aFace);
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dAddBackFill(fillList, aFace) */
void b3dAddBackFill(B3DFillList *fillList, B3DPrimitiveFace *aFace)
{
	B3DPrimitiveFace *firstFace = fillList->firstFace;
	B3DPrimitiveFace *lastFace = fillList->lastFace;
	B3DPrimitiveFace *face;
	float minZ = aFace->minZ;

	assert(firstFace);

	if(firstFace == lastFace || minZ >= lastFace->minZ) {
		b3dAddLastFill(fillList, aFace);
	} else {
		/* Try an estimation on how to search */
		if(minZ <= (firstFace->minZ + lastFace->minZ) * 0.5) {
			/* search front to back */
			face = firstFace->nextFace;
			while(face->minZ < minZ) face = face->nextFace;
		} else {
			/* search back to front */
			face = lastFace->prevFace; /* already checked if lastFace->minZ <= minZ */
			while(face->minZ > minZ) face = face->prevFace;
			face = face->nextFace;
		}
		b3dInsertBeforeFill(fillList, aFace, face);
	}
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dCleanupFill(fillList) */
void b3dCleanupFill(B3DFillList *fillList)
{
	B3DPrimitiveFace *firstFace = fillList->firstFace;

	while(firstFace) {
		firstFace->flags ^= B3D_FACE_ACTIVE;
		firstFace = firstFace->nextFace;
	}
	fillList->firstFace = fillList->lastFace = NULL;
}
/* --INLINE-- */

void b3dSearchForNewTopFill(B3DFillList *fillList, int scaledX, int yValue)
{
	B3DPrimitiveFace *topFace = fillList->firstFace;

	if(b3dDebug) b3dValidateFillList(fillList);
	if(topFace) { /* only if there is any */
		B3DPrimitiveFace *face = topFace->nextFace;
		double xValue = scaledX * B3D_FixedToFloat;
		double topZ = zValueAt(topFace, xValue, yValue);

		/* Note: since the list is ordered we need only to search until face->minZ >= topZ */
		while(face && face->minZ <= topZ) {
			double faceZ = zValueAt(face, xValue, yValue);
			if(faceZ < topZ) {
				topZ = faceZ;
				topFace = face;
			}
			face = face->nextFace;
		}
		/* and move the guy to front */
		b3dRemoveFill(fillList, topFace);
		b3dAddFrontFill(fillList, topFace);
	}
}

/* INLINE b3dToggleTopFills(fillList, edge, yValue) */
void b3dToggleTopFills(B3DFillList *fillList, B3DPrimitiveEdge *edge, int yValue)
{
	B3DPrimitiveFace *leftFace = edge->leftFace;
	B3DPrimitiveFace *rightFace = edge->rightFace;
	if(b3dDebug) b3dValidateFillList(fillList);
	assert(leftFace !!= rightFace);
	if(rightFace) {
		int xorMask = leftFace->flags ^ rightFace->flags;
		if(xorMask & B3D_FACE_ACTIVE) {
			if(leftFace->flags & B3D_FACE_ACTIVE) {
				b3dRemoveFill(fillList, leftFace);
				b3dAddFrontFill(fillList, rightFace);
			} else {
				b3dRemoveFill(fillList, rightFace);
				b3dAddFrontFill(fillList, leftFace);
			}
		} else {
			if(leftFace->flags & B3D_FACE_ACTIVE) {
				b3dRemoveFill(fillList, leftFace);
				b3dRemoveFill(fillList, rightFace);
				b3dSearchForNewTopFill(fillList, edge->xValue, yValue);
			} else {
				if(leftFace->dzdx <= rightFace->dzdx) {
					b3dAddFrontFill(fillList, leftFace);
					b3dAddBackFill(fillList, rightFace);
				} else {
					b3dAddFrontFill(fillList, rightFace);
					b3dAddBackFill(fillList, leftFace);
				}
			}
		}
		leftFace->flags ^= B3D_FACE_ACTIVE;
		rightFace->flags ^= B3D_FACE_ACTIVE;
	} else {
		if(leftFace->flags & B3D_FACE_ACTIVE) {
			b3dRemoveFill(fillList, leftFace);
			b3dSearchForNewTopFill(fillList, edge->xValue, yValue);
		} else {
			b3dAddFrontFill(fillList, leftFace);
		}
		leftFace->flags ^= B3D_FACE_ACTIVE;
	}
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/* INLINE b3dToggleBackFills(fillList, edge, yValue, nextIntersection) */
void b3dToggleBackFills(B3DFillList *fillList, 
						B3DPrimitiveEdge *edge, 
						int yValue,
						B3DPrimitiveEdge *nextIntersection)
{
	B3DPrimitiveFace *face = edge->leftFace;
	if(b3dDebug) b3dValidateFillList(fillList);
	if(face->flags & B3D_FACE_ACTIVE) {
		b3dRemoveFill(fillList, face);
	} else {
		b3dAddBackFill(fillList, face);
		b3dCheckIntersectionOfFaces(fillList->firstFace, face, yValue, edge, nextIntersection);
	}
	face->flags ^= B3D_FACE_ACTIVE;
	face = edge->rightFace;
	if(face) {
		if(face->flags & B3D_FACE_ACTIVE) {
			b3dRemoveFill(fillList, face);
		} else {
			b3dAddBackFill(fillList, face);
			b3dCheckIntersectionOfFaces(fillList->firstFace, face, yValue, edge, nextIntersection);
		}
		face->flags ^= B3D_FACE_ACTIVE;
	}
	if(b3dDebug) b3dValidateFillList(fillList);
}
/* --INLINE-- */

/*************************************************************/
/*************************************************************/
/*************************************************************/

/* INLINE b3dClearSpanBuffer(aet) */
void b3dClearSpanBuffer(B3DActiveEdgeTable *aet)
{
	int i, leftX, rightX;
	unsigned int *buffer = currentState->spanBuffer;
	if(aet->size && buffer) {
		leftX = aet->data[0]->xValue >> B3D_FixedToIntShift;
		rightX = aet->data[aet->size-1]->xValue >> B3D_FixedToIntShift;
		if(leftX < 0) leftX = 0;
		if(rightX >= currentState->spanSize) rightX = currentState->spanSize-1;
		for(i=leftX;i<=rightX;i++) buffer[i] = 0;
	}
}
/* --INLINE-- */

/* INLINE b3dDrawSpanBuffer(aet, yValue) */
void b3dDrawSpanBuffer(B3DActiveEdgeTable *aet, int yValue)
{
	int leftX, rightX;
	if(aet->size && currentState->spanDrawer) {
		leftX = aet->data[0]->xValue >> B3D_FixedToIntShift;
		rightX = aet->data[aet->size-1]->xValue >> B3D_FixedToIntShift;
		if(leftX < 0) leftX = 0;
		if(rightX > currentState->spanSize) rightX = currentState->spanSize;
		currentState->spanDrawer(leftX, rightX, yValue);
	}
}
/* --INLINE-- */

/*************************************************************/
/*************************************************************/
/*************************************************************/
/* General failure */
#define FAIL(reason,resume) { aet->yValue = yValue; return reason | resume; }
#define PROCEED { yValue = aet->yValue; }

/* Failure adding objects */
#define FAIL_ADDING(reason) { obj->start = objStart; FAIL(reason, B3D_RESUME_ADDING) }
#define PROCEED_ADDING { objStart = obj->start; PROCEED }

/* Failure merging objects */
#define FAIL_MERGING(reason) { FAIL(reason, B3D_RESUME_MERGING); }
#define PROCEED_MERGING { PROCEED }

/* Failure during paint */
#define FAIL_PAINTING(reason) { aet->start = aetStart; aet->leftEdge = leftEdge; aet->rightEdge = rightEdge; FAIL(reason, B3D_RESUME_PAINTING) }
#define PROCEED_PAINTING(reason) { aetStart = aet->start; leftEdge = aet->leftEdge; rightEdge = aet->rightEdge; PROCEED }

#define FAIL_UPDATING(reason)

int b3dMainLoop(B3DRasterizerState *state, int stopReason)
{
	B3DPrimitiveObject *activeStart, *passiveStart;
	int yValue, nextObjY, nextEdgeY;
	B3DFillList *fillList;
	B3DPrimitiveEdge *lastIntersection, *nextIntersection;


	if(!!state)
		return B3D_GENERIC_ERROR;

	if(!!state->nObjects)
		return B3D_NO_ERROR;

	if(b3dValidateAndRemapState(state) !!= B3D_NO_ERROR)
		return B3D_GENERIC_ERROR;

	if(stopReason == B3D_NO_ERROR)
		b3dSetupObjects(state);

	if(b3dDebug) {
		/* check the sort order of objects */
		int i;
		for(i=2; i<state->nObjects;i++)
			if(!!objSortsBefore(state->objects[i-1], state->objects[i]))
				b3dAbort("Objects not sorted");
	}

	currentState = state;
	faceAlloc = state->faceAlloc;
	edgeAlloc = state->edgeAlloc;
	attrAlloc = state->attrAlloc;
	addedEdges = state->addedEdges;
	fillList = state->fillList;
	aet = state->aet;
	nextIntersection = aet->nextIntersection;
	lastIntersection = aet->lastIntersection;

	if(b3dDoStats) nFaces = 0;

	if(stopReason == B3D_NO_ERROR) {
		activeStart = passiveStart = state->objects[0];
		yValue = nextEdgeY = nextObjY = passiveStart->minY;
	} else {
		int resumeCode;
		resumeCode = stopReason & B3D_RESUME_MASK;
		if(resumeCode == B3D_RESUME_ADDING  ) goto RESUME_ADDING;
		if(resumeCode == B3D_RESUME_MERGING ) goto RESUME_MERGING;
		if(resumeCode == B3D_RESUME_PAINTING) goto RESUME_PAINTING;
		if(resumeCode == B3D_RESUME_UPDATING) goto RESUME_UPDATING;
		return B3D_GENERIC_ERROR;
	}

	/**** BEGIN MAINLOOP ****/
	while(activeStart || passiveStart || aet->size) {

RESUME_ADDING:

		/* STEP 1: Add new objects if necessary */
		if(yValue == nextObjY) {
			nextEdgeY = nextObjY;
			while(passiveStart && passiveStart->minY == nextObjY) {
				passiveStart->flags |= B3D_OBJECT_ACTIVE;
				passiveStart = passiveStart->next;
			}
			if(passiveStart)
				nextObjY = passiveStart->minY;
			else
				nextObjY = 99999;
		} /* End of adding objects */



		/* STEP 2: Add new edges if necessary */
		if(yValue == nextEdgeY) {
			B3DPrimitiveObject *obj = activeStart;
			int scaledY = (yValue+1) << B3D_IntToFixedShift;

			nextEdgeY = nextObjY << B3D_IntToFixedShift;
			while(obj !!= passiveStart) {
				B3DInputFace *objFaces = obj->faces;
				B3DPrimitiveVertex *objVtx = obj->vertices;
				int objStart = obj->start;
				int objSize = obj->nFaces;
				int tempY;

				assert(obj->flags & B3D_OBJECT_ACTIVE);

				while(objStart < objSize && ((tempY = objVtx[objFaces[objStart].i0].windowPosY) < scaledY)) {
					/* add edges from face at objFaces[objStart] */
					B3DInputFace *inputFace = objFaces + objStart;
					B3DPrimitiveFace *face;

					/* NOTE: If any of the following fails, 
					         we can re-enter the main loop later on. */

					if(faceAlloc->nFree == 0)
						FAIL_ADDING(B3D_NO_MORE_FACES);
					
					if(edgeAlloc->nFree < 2)
						FAIL_ADDING(B3D_NO_MORE_EDGES);

					if(addedEdges->size+2 > addedEdges->max)
						FAIL_ADDING(B3D_NO_MORE_ADDED);

					/* Allocate a new face and do the initial setup */
					face = b3dInitializeFace(objVtx + inputFace->i0, 
											 objVtx + inputFace->i1,
											 objVtx + inputFace->i2,
											 obj->texture,
											 obj->flags);
					if(face) {
						b3dAddEdgesFromFace(face, yValue);
					}
					objStart++;
				}

				obj->start = objStart;
				if(objStart !!= objSize) {
					if(tempY < nextEdgeY) nextEdgeY = tempY;
				} else {
					/* Unlink obj from activeStart list */
					obj->flags |= B3D_OBJECT_DONE;
					if(obj == activeStart) {
						activeStart = obj->next;
					} else {
						obj->prev->next = obj->next;
					}
				}
				obj = obj->next;
			}

			nextEdgeY >>= B3D_FixedToIntShift;
		} /* End of adding edges */


		/* STEP 3: Merge all newly added edges from addedList into the AET */
		if(addedEdges->size) {
RESUME_MERGING:
			if(b3dDebug)
				b3dValidateEdgeOrder(addedEdges);
			/* NOTE: If the following fails, we can re-enter the main loop later on. */
			if(aet->size + addedEdges->size > aet->max)
				FAIL_MERGING(B3D_NO_MORE_AET);
			b3dMergeAETEdgesFrom(aet, addedEdges);
			if(b3dDebug) {
				b3dValidateAETOrder(aet);
			}
			addedEdges->size = 0; /* reset added */
		} /* End of merging edges */


		/********** THIS IS THE CORE LOOP ********/
		/* while(yValue < nextEdgeY && !!addedEdges->size && aet->size) { */

			if(b3dDoStats) {
				/* Gather stats */
				if(aet->size > maxEdges) maxEdges = aet->size;
				if(nFaces > maxFaces) maxFaces = nFaces;
			}

			/* STEP 4: Draw the current span */

			/* STEP 4a: Clear the span buffer */
			b3dClearSpanBuffer(aet);

			/* STEP 4b: Scan out the AET */
			if(aet->size) {
				B3DPrimitiveEdge *leftEdge;
				B3DPrimitiveEdge *rightEdge;
				B3DPrimitiveEdge **aetData = aet->data;
				int aetStart = 1;
				int aetSize = aet->size;

				/* clean up old fills if any */
				b3dCleanupFill(fillList);

				nextIntersection->xValue = B3D_MAX_X;
				leftEdge = aetData[0];
				while(aetStart < aetSize) {

					/*-- Toggle the faces of the top edge (the left edge is always on top) --*/
					if(leftEdge == lastIntersection) {
						/* Special case if this is a intersection edge */
						assert(fillList->firstFace == leftEdge->leftFace);
						b3dRemoveFill(fillList, leftEdge->rightFace);
						b3dAddFrontFill(fillList, leftEdge->rightFace);
					} else {
						b3dToggleTopFills(fillList, leftEdge, yValue);
					}
					/*-- end of toggling top edge faces --*/

					/* after getting a new top fill we must adjust intersections */
					b3dAdjustIntersections(fillList, yValue, leftEdge, nextIntersection);

					/*-- search for the next top edge which will be the right edge --*/
					assert(aetStart < aetSize);
					if(!!fillList->firstFace)
						rightEdge = aetData[aetStart++]; /* If no current top fill just use the next edge */
					else while(aetStart < aetSize) { /* Search for the next top edge in the AET */
						rightEdge = aetData[aetStart];
						/* If we have an intersection use the intersection edge */
						if(nextIntersection->xValue <= rightEdge->xValue) {
							rightEdge = nextIntersection;
							break;
						}
						aetStart++;
						/* Check if this edge is on top */
						assert(fillList->firstFace);
						{
							double xValue = rightEdge->xValue * B3D_FixedToFloat;
							B3DPrimitiveFace *topFace = fillList->firstFace;
							if( rightEdge->leftFace == topFace || 
								rightEdge->rightFace == topFace || 
								rightEdge->zValue < zValueAt(topFace, xValue, yValue))
								break; /* rightEdge is on top */
						}
						/* If the edge is not on top toggle its (back) fills */
						b3dToggleBackFills(fillList, rightEdge, yValue, nextIntersection);
						rightEdge = NULL;
					}
					/*-- end of search for next top edge --*/

					/*-- Now do the drawing from leftEdge to rightEdge --*/
					assert(rightEdge);
					if(fillList->firstFace) {
						/* Note: We fill *including* leftX and rightX */
						int leftX = (leftEdge->xValue >> B3D_FixedToIntShift) + 1;
						int rightX = (rightEdge->xValue >> B3D_FixedToIntShift);
						B3DPrimitiveFace *topFace = fillList->firstFace;

						if(leftX < 0) leftX = 0;
						if(rightX >= currentState->spanSize) rightX = currentState->spanSize-1;
						if(leftX <= rightX) {
							/* Since we know now that some serious filling operation
							   will happen, initialize the attributes of the face if
							   this hasn''t been done before. */
RESUME_PAINTING:
							if( (topFace->flags & B3D_FACE_INITIALIZED) == 0) {
								assert(topFace->attributes == NULL);
								if(!!b3dInitializePass2(topFace))
									FAIL_PAINTING(B3D_NO_MORE_ATTRS);
							}
							/* And dispatch on the actual pixel drawers */
							(*B3D_FILL_FUNCTIONS[(topFace->flags >> B3D_ATTR_SHIFT) & B3D_ATTR_MASK])
								(leftX, rightX, yValue, topFace);
						}
					}
					/*-- End of drawing -- */

					/* prepare for new top edge */
					leftEdge = rightEdge;
					/* use a new intersection if necessary */
					if(leftEdge == nextIntersection) {
						nextIntersection = lastIntersection;
						lastIntersection = leftEdge;
					}
					nextIntersection->xValue = B3D_MAX_X;
				}
				/* clean up old fills if any */
				b3dCleanupFill(fillList);
			}

			/* STEP 4c: Display the pixels from the span buffer */
			b3dDrawSpanBuffer(aet, yValue);

			/* STEP 5: Go to next y value and update AET entries */
			yValue++;
			if(aet->size) {
				int aetStart = 0;
				int aetSize = aet->size;
				B3DPrimitiveEdge **aetData = aet->data;

				aetStart = 0;
				while(aetStart < aetSize) {
					B3DPrimitiveEdge *edge = aetData[aetStart];

					if(--(edge->nLines)) {
						/* Advance to next scan line and resort edge */
						b3dAdvanceAETEdge(edge, aetData, aetStart);
						aetStart++;
					} else {
						/* Remove edge and add lower edges if necessary */
RESUME_UPDATING:
						if(edgeAlloc->nFree < 2)
							FAIL_UPDATING(B3D_NO_MORE_EDGES);
						if(addedEdges->size + 2 > addedEdges->max)
							FAIL_UPDATING(B3D_NO_MORE_ADDED);
						b3dRemoveAETEdge(aet, edge, yValue, aetStart);
						aetSize = aet->size;
						/* Do NOT advance aetStart here */
					}
				}
			}
			/* End of AET update */
			if(b3dDebug) {
				b3dValidateAETOrder(aet);
			}

		/*}*/ /******** END OF CORE LOOP ********/

	}  /**** END MAINLOOP ****/

	return B3D_NO_ERROR;
}
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'ar 4/18/1999 08:33'!
b3dRemapC
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dRemap.c
*   CONTENT: Remapping functions for the B3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#include "b3d.h"

/* b3dRemapFaces:
	Remap all allocated faces using the given offsets
*/
/* INLINE b3dRemapFaces(list, attrOffset, edgeOffset) */
void b3dRemapFaces(B3DFaceAllocList *list, int attrOffset, int edgeOffset)
{
	int i;

	for(i=0; i<list->size;i++) {
		B3DPrimitiveFace *face = list->data + i;
		if(face->flags & B3D_ALLOC_FLAG) {
			if(face->attributes)
				(char*)face->attributes += attrOffset;
			if(face->leftEdge)
				(char*)face->leftEdge += edgeOffset;
			if(face->rightEdge)
				(char*)face->rightEdge += edgeOffset;
		}
	}
}
/* --INLINE-- */

/* b3dRemapEdges:
	Remap all allocated edges using the given offset
*/
/* INLINE b3dRemapEdges(list, faceOffset) */
void b3dRemapEdges(B3DEdgeAllocList *list, int faceOffset)
{
	int i;
	for(i=0; i<list->size;i++) {
		B3DPrimitiveEdge *edge = list->data + i;
		if(edge->flags & B3D_ALLOC_FLAG) {
			if(edge->leftFace)
				(char*)edge->leftFace += faceOffset;
			if(edge->rightFace)
				(char*)edge->rightFace += faceOffset;
		}
	}
}
/* --INLINE-- */

/* b3dRemapFills:
	Remap the fill list using the given offset
*/
/* INLINE b3dRemapFills(fillList, offset) */
void b3dRemapFills(B3DFillList *fillList, int offset)
{
	B3DPrimitiveFace *temp;
	if(fillList->firstFace)
		(char*)fillList->firstFace += offset;
	if(fillList->lastFace)
		(char*)fillList->lastFace  += offset;
	temp = fillList->firstFace;
	while(temp) {
		if(temp->nextFace)
			(char*)temp->nextFace += offset;
		if(temp->prevFace)
			(char*)temp->prevFace += offset;
		temp = temp->nextFace;
	}
}
/* --INLINE-- */

/* b3dRemapEdgeList:
	Remap all edge pointers using the given offset
*/
/* INLINE b3dRemapEdgeList(list, edgeOffset) */
void b3dRemapEdgeList(B3DPrimitiveEdgeList *list, int edgeOffset)
{
	int i;
	for(i=0; i<list->size;i++) {
		(char*) list->data[i] += edgeOffset;
	}
}
/* --INLINE-- */

/* b3dRemapAET:
	Remap all edge pointers using the given offset
*/
/* INLINE b3dRemapAET(list, edgeOffset, aetOffset, firstEdge, lastEdge) */
void b3dRemapAET(B3DActiveEdgeTable *list, int edgeOffset, int aetOffset, void *firstEdge, void *lastEdge)
{
	int i;
	if(edgeOffset)
		for(i=0; i<list->size;i++)
			(char*) list->data[i] += edgeOffset;

	if((void*)list->leftEdge >= firstEdge && (void*)list->leftEdge < lastEdge)
		(char*) list->leftEdge += edgeOffset;
	else if(list->leftEdge)
		(char*) list->leftEdge += aetOffset;

	if((void*)list->rightEdge >= firstEdge && (void*)list->rightEdge < lastEdge)
		(char*) list->rightEdge += edgeOffset;
	else if(list->rightEdge)
		(char*) list->rightEdge += aetOffset;

	if(aetOffset) {
		(char*) list->nextIntersection += aetOffset;
		(char*) list->lastIntersection += aetOffset;
	}
}
/* --INLINE-- */

/* b3dRemapEdgeVertices:
	Remap all vertices in the specified range using the given offset
*/
/* INLINE b3dRemapEdgeVertices(list, vtxOffset, firstVtx, lastVtx) */
void b3dRemapEdgeVertices(B3DEdgeAllocList *list, int vtxOffset, void *firstVtx, void *lastVtx)
{
	int i;
	for(i=0; i<list->size; i++) {
		B3DPrimitiveEdge *edge = list->data + i;
		if((edge->flags & B3D_ALLOC_FLAG) && ((void*)edge->v0 >= (void*)firstVtx) && ((void*)edge->v0 < (void*)lastVtx)) {
			(char*) edge->v0 += vtxOffset;
			(char*) edge->v1 += vtxOffset;
		}
	}
}
/* --INLINE-- */

/* b3dRemapFaceVertices:
	Remap all vertices in the specified range using the given offset
*/
/* INLINE b3dRemapFaceVertices(list, vtxOffset, firstVtx, lastVtx) */
void b3dRemapFaceVertices(B3DFaceAllocList *list, int vtxOffset, void *firstVtx, void *lastVtx)
{
	int i;
	for(i=0; i<list->size; i++) {
		B3DPrimitiveFace *face = list->data + i;
		if((face->flags & B3D_ALLOC_FLAG) && ((void*)face->v0 >= (void*)firstVtx) && ((void*)face->v0 < (void*)lastVtx)) {
			(char*) face->v0 += vtxOffset;
			(char*) face->v1 += vtxOffset;
			(char*) face->v2 += vtxOffset;
		}
	}
}
/* --INLINE-- */

/* b3dRemapFaceFree:
	Remap all free faces using the given offset
*/
/* INLINE b3dRemapFaceFree(list, faceOffset) */
void b3dRemapFaceFree(B3DFaceAllocList *list, int faceOffset)
{
	B3DPrimitiveFace *freeObj;
	if(list->firstFree) {
		(char*)list->firstFree += faceOffset;
		freeObj = list->firstFree;
		while(freeObj->nextFree) {
			(char*) freeObj->nextFree += faceOffset;
			freeObj = freeObj->nextFree;
		}
	}
}
/* --INLINE-- */

/* b3dRemapEdgeFree:
	Remap all free edges using the given offset
*/
/* INLINE b3dRemapEdgeFree(list, edgeOffset) */
void b3dRemapEdgeFree(B3DEdgeAllocList *list, int edgeOffset)
{
	B3DPrimitiveEdge *freeObj;
	if(list->firstFree) {
		(char*)list->firstFree += edgeOffset;
		freeObj = list->firstFree;
		while(freeObj->nextFree) {
			(char*) freeObj->nextFree += edgeOffset;
			freeObj = freeObj->nextFree;
		}
	}
}
/* --INLINE-- */

/* b3dRemapAttrFree:
	Remap all free attributes using the given offset
*/
/* INLINE b3dRemapAttrFree(list, attrOffset) */
void b3dRemapAttributes(B3DAttrAllocList *list, int attrOffset)
{
	int i;
	for(i=0; i < list->size; i++) {
		B3DPrimitiveAttribute *attr = list->data + i;
		if(attr->next)
			(char*) attr->next += attrOffset;
	}
}
/* --INLINE-- */

/* b3dValidateAndRemapState:
	Validate the rasterizer state and remap the objects if necessary.
*/
int b3dValidateAndRemapState(B3DRasterizerState *state)
{
	int faceOffset, edgeOffset, attrOffset, aetOffset, objOffset, i;
	B3DPrimitiveObject *obj;

	if(!!state) return B3D_GENERIC_ERROR;
	
	/* Check the magic numbers */
	if(state->faceAlloc->magic  !!= B3D_FACE_ALLOC_MAGIC) return B3D_MAGIC_ERROR;
	if(state->edgeAlloc->magic  !!= B3D_EDGE_ALLOC_MAGIC) return B3D_MAGIC_ERROR;
	if(state->attrAlloc->magic  !!= B3D_ATTR_ALLOC_MAGIC) return B3D_MAGIC_ERROR;
	if(state->aet->magic        !!= B3D_AET_MAGIC) return B3D_MAGIC_ERROR;
	if(state->addedEdges->magic !!= B3D_EDGE_LIST_MAGIC) return B3D_MAGIC_ERROR;
	if(state->fillList->magic   !!= B3D_FILL_LIST_MAGIC) return B3D_MAGIC_ERROR;

	/* Check if we need to relocate objects */
	faceOffset = (int)state->faceAlloc - (int)state->faceAlloc->This;
	edgeOffset = (int)state->edgeAlloc - (int)state->edgeAlloc->This;
	attrOffset = (int)state->attrAlloc - (int)state->attrAlloc->This;
	aetOffset = (int)state->aet - (int)state->aet->This;
	
	/* remap faces */
	if(attrOffset || edgeOffset)
		b3dRemapFaces(state->faceAlloc, attrOffset, edgeOffset);
	
	/* remap fills and edges */
	if(faceOffset) {
		b3dRemapFills(state->fillList, faceOffset);
		b3dRemapEdges(state->edgeAlloc, faceOffset);
		b3dRemapFaceFree(state->faceAlloc, faceOffset);
	}
	
	/* Remap AET */
	if(edgeOffset || aetOffset) {
		void *firstEdge = state->edgeAlloc->data;
		void *lastEdge = state->edgeAlloc->data + state->edgeAlloc->size;
		b3dRemapAET(state->aet, edgeOffset, aetOffset, firstEdge, lastEdge);
	}

	/* Remap addedEdges and edge free list*/
	if(edgeOffset) {
		b3dRemapEdgeList(state->addedEdges, edgeOffset);
		b3dRemapEdgeFree(state->edgeAlloc, edgeOffset);
	}

	if(attrOffset)
		b3dRemapAttributes(state->attrAlloc, attrOffset);
	
	state->faceAlloc->This = (void*) state->faceAlloc;
	state->edgeAlloc->This = (void*) state->edgeAlloc;
	state->attrAlloc->This = (void*) state->attrAlloc;
	state->aet->This = (void*) state->aet;

	/* Remap any vertex pointers */
	for(i=0; i<state->nObjects; i++) {
		obj = state->objects[i];
		if(obj->magic !!= B3D_PRIMITIVE_OBJECT_MAGIC) return B3D_MAGIC_ERROR;
		objOffset = (int)obj - (int)obj->This;
		if(objOffset) {
			if((obj->flags & B3D_OBJECT_ACTIVE)) {
				B3DPrimitiveVertex *firstVtx = obj->vertices;
				B3DPrimitiveVertex *lastVtx = obj->vertices + obj->nVertices;
				b3dRemapFaceVertices(state->faceAlloc, objOffset, firstVtx, lastVtx);
				b3dRemapEdgeVertices(state->edgeAlloc, objOffset, firstVtx, lastVtx);
			}
			obj->vertices = (B3DPrimitiveVertex*) (obj + 1);
			obj->faces = (B3DInputFace*) (obj->vertices + obj->nVertices);
		}
		obj->This = (void*) obj;
	}

	return B3D_NO_ERROR;
}
'! !

!B3DRasterizerPlugin class methodsFor: 'C source code' stamp: 'di 4/22/1999 09:14'!
b3dTypesH
^'/****************************************************************************
*   PROJECT: Balloon 3D Graphics Subsystem for Squeak
*   FILE:    b3dTypes.h
*   CONTENT: Type declarations for the B3D rasterizer
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*
*****************************************************************************/
#ifndef B3D_TYPES_H
#define B3D_TYPES_H

#ifndef NULL
#define NULL ((void*)0)
#endif

/* Error constants */
#define B3D_NO_ERROR 0
/* Generic error */
#define B3D_GENERIC_ERROR -1
/* Bad magic number */
#define B3D_MAGIC_ERROR -2

/* Note: The error codes that allow resuming
		must be positive. They''ll be combined
		with the resume codes */
/* no more space in edge allocation list */
#define B3D_NO_MORE_EDGES 1
/* no more space in face allocation list */
#define B3D_NO_MORE_FACES 2
/* no more space in attribute allocation list */
#define B3D_NO_MORE_ATTRS 3
/* no more space in active edge table */
#define B3D_NO_MORE_AET   4
/* no more space for added edges */
#define B3D_NO_MORE_ADDED 5

/* Resume codes */
#define B3D_RESUME_MASK 0xF0000
/* Resume adding objects/edges */
#define B3D_RESUME_ADDING   0x10000
/* Resume merging added edges */
#define B3D_RESUME_MERGING  0x20000
/* Resume painting faces */
#define B3D_RESUME_PAINTING 0x40000
/* Resume updating the AET */
#define B3D_RESUME_UPDATING 0x80000

/* Factor to convert from float to fixed pt */
#define B3D_FloatToFixed 4096.0
/* Factor to convert from fixed pt to float */
#define B3D_FixedToFloat 0.000244140625
/* Shift value to convert from integer to fixed pt */
#define B3D_IntToFixedShift 12
#define B3D_FixedToIntShift 12
/* 0.5 in fixed pt representation */
#define B3D_FixedHalf 2048

/* Max. possible x value */
#define B3D_MAX_X 0x7FFFFFFF

/* Allocation flag: If this flag is not set then the nextFree pointer is valid */
#define B3D_ALLOC_FLAG 1

/************************ PrimitiveColor definition ************************/
typedef unsigned char B3DPrimitiveColor[4];

/* An ugly hack but I can''t find the global defs in CodeWarrior on the Mac */
#ifndef LSB_FIRST
	#define MSB_FIRST
#endif

#ifndef MSB_FIRST
	#define RED_INDEX 0
	#define GREEN_INDEX 1
	#define BLUE_INDEX 2
	#define ALPHA_INDEX 3
#else
	#define ALPHA_INDEX 0
	#define BLUE_INDEX 1
	#define GREEN_INDEX 2
	#define RED_INDEX 3
#endif

/************************ PrimitiveVertex definition ************************/
typedef struct B3DPrimitiveVertex {
	float position[3];
	float normal[3];
	float texCoord[2];
	float rasterPos[4];
	union {
		int pixelValue32;
		B3DPrimitiveColor color;
	} cc;
	int clipFlags;
	int windowPos[2];
} B3DPrimitiveVertex;

/* sort order for primitive vertices */
#define vtxSortsBefore(vtx1, vtx2) ( (vtx1)->windowPosY == (vtx2)->windowPosY ? (vtx1)->windowPosX <= (vtx2)->windowPosX : (vtx1)->windowPosY <= (vtx2)->windowPosY)

/************************ InputFace definition ************************/
/* Note: The following is mainly so that we don''t need these weird int[3] declarations. */
typedef struct B3DInputFace {
	int i0;
	int i1;
	int i2;
} B3DInputFace;

typedef struct B3DInputQuad {
	int i0;
	int i1;
	int i2;
	int i3;
} B3DInputQuad;

/************************ PrimitiveEdge definition ************************/
/* Edge flags:
    B3D_EDGE_CONTINUE_LEFT  - continue with the lower edge of the left face
	B3D_EDGE_CONTINUE_RIGHT - continue with the lower edge of the right face
	B3D_EDGE_LEFT_MAJOR     - edge is major edge for left face
	B3D_EDGE_RIGHT_MAJOR    - edge is major edge for right face
*/

#define B3D_EDGE_CONTINUE_LEFT  0x10
#define B3D_EDGE_CONTINUE_RIGHT 0x20
#define B3D_EDGE_LEFT_MAJOR     0x40
#define B3D_EDGE_RIGHT_MAJOR    0x80

typedef struct B3DPrimitiveEdge {
	int flags;
	struct B3DPrimitiveEdge *nextFree;

	/* start/end of edge */
	struct B3DPrimitiveVertex *v0;
	struct B3DPrimitiveVertex *v1;

	/* left/right face of edge (NOT meant literally) */
	struct B3DPrimitiveFace *leftFace;
	struct B3DPrimitiveFace *rightFace;

	/* current x/z value */
	int xValue;
	float zValue;
	/* x/z increment per scan line */
	int xIncrement;
	float zIncrement;

	/* number of remaining scan lines */
	int nLines;
} B3DPrimitiveEdge;


/* B3DPrimitiveEdgeList: A list of pointers to primitive edges */
#define B3D_EDGE_LIST_MAGIC  0x45553342
typedef struct B3DPrimitiveEdgeList {
	int magic;
	void *This;
	int start;
	int size;
	int max;
	B3DPrimitiveEdge *data[1];
} B3DPrimitiveEdgeList;

/* B3DActiveEdgeTable: The active edge table (basically a primitive
	edge table with few additional entries) */
#define B3D_AET_MAGIC   0x41455420
typedef struct B3DActiveEdgeTable {
	int magic;
	void *This;
	int start;
	int size;
	int max;
	/* Backups for proceeding after failure */
	int yValue;
	B3DPrimitiveEdge *leftEdge;
	B3DPrimitiveEdge *rightEdge;
	B3DPrimitiveEdge *lastIntersection;
	B3DPrimitiveEdge *nextIntersection;
	/* That''s where lastIntersection and nextIntersection point to */
	B3DPrimitiveEdge tempEdge0;
	B3DPrimitiveEdge tempEdge1;
	/* Actual data */
	B3DPrimitiveEdge *data[1];
} B3DActiveEdgeTable ;

/************************ PrimitiveFace definition ************************/

/* Face flags:
	B3D_FACE_INITIALIZED - have the face attributes been initialized?!!
	B3D_FACE_ACTIVE      - is the face currently in the fill list?!!
	B3D_FACE_HAS_ALPHA   - can the face eventually be transparent?!!

    B3D_FACE_RGB         - R,G,B interpolation values
	B3D_FACE_ALPHA       - Alpha interpolation values
	B3D_FACE_STW         - S,T,W interpolation values
*/

#define B3D_FACE_INITIALIZED 0x10
#define B3D_FACE_ACTIVE      0x20
#define B3D_FACE_HAS_ALPHA   0x40

#define B3D_FACE_RGB         0x100
#define B3D_FACE_ALPHA       0x200
#define B3D_FACE_STW         0x400

/* # of possible combinations AND maximum (e.g., R+G+B+A+S+T+W) of attribs */
/* NOTE: This is a really ugly hack - I''ll have to fix that */
#define B3D_MAX_ATTRIBUTES 8
/* mask out the face attributes */
#define B3D_ATTR_MASK 0x7
/* shift for getting the attributes */
#define B3D_ATTR_SHIFT 8

typedef struct B3DPrimitiveFace {
	int flags;
	struct B3DPrimitiveFace *nextFree;

	/* The three vertices of the face */
	struct B3DPrimitiveVertex *v0;
	struct B3DPrimitiveVertex *v1;
	struct B3DPrimitiveVertex *v2;

	/* The links for the (depth sorted) list of fills */
	struct B3DPrimitiveFace *prevFace;
	struct B3DPrimitiveFace *nextFace;

	/* The left and right edge of the face (not taken too literally) */
	struct B3DPrimitiveEdge *leftEdge;
	struct B3DPrimitiveEdge *rightEdge;

	/* The deltas for the major (e.g., v0-v2) and the first minor (e.g., v0-v1) edge */
	float majorDx, majorDy;
	float minorDx, minorDy;

	/* The inverse area covered by (twice) the triangle */
	float oneOverArea;

	/* Depth attributes are kept here since we almost always need ''em */
	float minZ, maxZ;
	float dzdx, dzdy;

	/* The pointer to the texture */
	struct B3DTexture *texture;
	/* The pointer to the extended (per face) interpolation values */
	struct B3DPrimitiveAttribute *attributes;
} B3DPrimitiveFace;


/* B3DFillList: A (depth-sorted) list of primitive faces */
#define B3D_FILL_LIST_MAGIC  0x46443342
typedef struct B3DFillList {
	int magic;
	void *This;
	B3DPrimitiveFace *firstFace;
	B3DPrimitiveFace *lastFace;
} B3DFillList;

/************************ PrimitiveAttribute definition ************************/

typedef struct B3DPrimitiveAttribute {
	/* Note: next is either nextFree or or nextUsed */
	struct B3DPrimitiveAttribute *next;
	/* value at the face->v0 */
	float value;
	/* value / dx derivative for face */
	float dvdx;
	/* value / dy derivative for face */
	float dvdy;
} B3DPrimitiveAttribute;

/************************ Texture definition ************************/
#define B3D_TEXTURE_POWER_OF_2 0x10
typedef struct B3DTexture {
	int width;
	int height;
	int depth;
	int rowLength; /* 32bit words per scan line */
	int sMask;	/* Nonzero for power of two width */
	int sShift;
	int tMask;	/* Nonzero for power of two height */
	int tShift;
	int cmSize; /* length of color map */
	unsigned int *colormap;
	unsigned int *data;
} B3DTexture;

/************************ PrimitiveViewport definition ************************/

typedef struct B3DPrimitiveViewport {
	int x0, y0, x1, y1;
} B3DPrimitiveViewport;

/************************ PrimitiveObject definition ************************/
#define B3D_OBJECT_ACTIVE 0x10
#define B3D_OBJECT_DONE   0x20

#define B3D_PRIMITIVE_OBJECT_MAGIC  0x4F443342
typedef struct B3DPrimitiveObject {
	int magic;
	void *This;
	int __oop__; /* actual ST oop */
	struct B3DPrimitiveObject *next;
	struct B3DPrimitiveObject *prev;

	int flags;

	int textureIndex;
	struct B3DTexture *texture;

	int minX, maxX, minY, maxY;
	float minZ, maxZ;

	int nSortedFaces;
	int nInvalidFaces;
	

	int start;
	int nFaces;
	B3DInputFace *faces;
	int nVertices;
	B3DPrimitiveVertex *vertices;
} B3DPrimitiveObject;

/* sort order for primitive objects */
#define objSortsBefore(obj1, obj2) ( (obj1)->minY == (obj2)->minY ? (obj1)->minX <= (obj2)->minX : (obj1)->minY <= (obj2)->minY)

#endif /* ifndef B3D_TYPES_H */
'! !
B3DEnginePart subclass: #B3DRenderEngine
	instanceVariableNames: 'vertexBuffer transformer shader clipper rasterizer properties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!
!B3DRenderEngine commentStamp: '<historical>' prior: 0!
I represent a facade for all Balloon 3D operations. Clients should only interact with me, not with any of the parts of the engine directly. However, clients may configure me to use certain parts in the 3D rendering pipeline.

Instance variables: 
	vertexBuffer 	<B3DVertexBuffer>	The vertex buffer passed on through the entire pipeline
	transformer 	<B3DEnginePart>		The part performing transform operations
	shader 			<B3DEnginePart>		The part performing vertex shading operations
	clipper 			<B3DEnginePart>		The part performing view frustum clipping
	rasterizer		<B3DEnginePart>		The part performing final pixel rasterization
!


!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/14/1999 22:22'!
clearDepthBuffer
	^rasterizer clearDepthBuffer! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/16/1999 02:17'!
clearViewport: aColor
	^rasterizer clearViewport: aColor! !

!B3DRenderEngine methodsFor: 'attributes'!
color
	^vertexBuffer color! !

!B3DRenderEngine methodsFor: 'attributes'!
color: aColor
	^vertexBuffer color: aColor! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 19:34'!
material
	^shader material! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 19:34'!
material: aMaterial
	^shader material: aMaterial! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 16:19'!
materialColor
	^shader materialColor! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 16:19'!
materialColor: aColor
	^shader materialColor: aColor! !

!B3DRenderEngine methodsFor: 'attributes'!
normal
	^vertexBuffer normal! !

!B3DRenderEngine methodsFor: 'attributes'!
normal: aVector
	^vertexBuffer normal: aVector! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 19:35'!
popMaterial
	^shader popMaterial.! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/16/1999 03:14'!
popTexture
	^rasterizer popTexture! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/7/1999 19:34'!
pushMaterial
	^shader pushMaterial.! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/16/1999 03:14'!
pushTexture
	^rasterizer pushTexture! !

!B3DRenderEngine methodsFor: 'attributes'!
texCoords
	^vertexBuffer texCoords! !

!B3DRenderEngine methodsFor: 'attributes'!
texCoords: aVector
	^vertexBuffer texCoords: aVector! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/16/1999 03:14'!
texture
	^rasterizer texture! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 6/2/1999 14:00'!
texture: anObject
	"Note: For convenience; the object can be anything that understands #asTexture"
	^rasterizer texture: anObject asTexture! !

!B3DRenderEngine methodsFor: 'attributes'!
vertex
	^vertexBuffer vertex! !

!B3DRenderEngine methodsFor: 'attributes'!
vertex: aVector
	^vertexBuffer vertex: aVector.! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/4/1999 17:52'!
viewport
	^rasterizer viewport! !

!B3DRenderEngine methodsFor: 'attributes' stamp: 'ar 2/4/1999 17:52'!
viewport: aRect
	^rasterizer viewport: aRect! !


!B3DRenderEngine methodsFor: 'draw primitives' stamp: 'ar 11/7/1999 18:12'!
drawPolygonAfter: aBlock
	vertexBuffer reset.
	vertexBuffer primitive: 3.
	aBlock value.
	^self renderPrimitive.! !

!B3DRenderEngine methodsFor: 'draw primitives' stamp: 'ar 11/7/1999 18:15'!
drawPolygonMesh: aB3DPolygonMesh
	"Draw a generic polygon mesh"
	| hasVtxNormals hasTexCoords hasVtxColors bounds box |
	box _ nil.
	aB3DPolygonMesh polygonsDo:[:poly|
		hasVtxNormals _ poly hasVertexNormals.
		hasTexCoords _ poly hasTextureCoords.
		hasVtxColors _ poly hasVertexColors.
		"Set the normal of the polygon if we don't have normals per vertex"
		hasVtxNormals 
			ifFalse:[self normal: poly normal].
		bounds _ self drawPolygonAfter:[
			poly verticesDo:[:vtx|
				hasVtxColors ifTrue:[self color: (poly colorOfVertex: vtx)].
				hasVtxNormals ifTrue:[self normal: (poly normalOfVertex: vtx)].
				hasTexCoords ifTrue:[self texCoord: (poly texCoordOfVertex: vtx)].
				self vertex: vtx.
			].
		].
		box == nil ifTrue:[box _ bounds] ifFalse:[box _ box quickMerge: bounds].
	].
	^box! !

!B3DRenderEngine methodsFor: 'draw primitives' stamp: 'ar 2/4/1999 20:16'!
render: anObject
	anObject renderOn: self.! !


!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 11/7/2000 17:27'!
privateClipVB: vb
	"OBSOLETE. Clip the objects in the vertex buffer."
	^clipper processVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 2/2/1999 19:39'!
privateNeedsClipVB: visibleFlag
	"Determine if a vertex buffer with the given visibility flag must be clipped.
	Return false if either visibleFlag == true (meaning the vertex buffer is completely inside the view frustum) or the rasterizer can clip by itself (it usually can)."
	^visibleFlag ~~ true and:[rasterizer needsClip]! !

!B3DRenderEngine methodsFor: 'private-rendering'!
privateNeedsShadingVB
	"Return true if the objects in the vertex buffer needs separate shading.
	This is determined by checking if
		a) lighting is enabled
		b) at least one light exists
		c) at least one material exists
	"
	^true! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 11/7/2000 17:27'!
privatePostClipVB: vb
	"Clip the objects in the vertex buffer."
	^clipper postProcessVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 11/7/2000 17:25'!
privatePreClipVB: vb
	"Clip the objects in the vertex buffer."
	^clipper preProcessVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 2/4/1999 04:26'!
privateRasterizeVB: vb
	"Rasterize the current primitive from the vertex buffer."
	^rasterizer processVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 2/4/1999 04:26'!
privateShadeVB: vb
	"Shade all the vertices in the vertex buffer using selected materials and lights"
	^shader processVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 2/8/1999 21:18'!
privateTransformVB: vb
	"Transform the contents of the vertex buffer.
	Transforming may include normals (if lighting enabled) and textures (if textures enabled)."
	^transformer processVertexBuffer: vb! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 2/2/1999 19:31'!
privateVisibleVB: vb
	"Return the visibility of the objects in the vertex buffer.
	Return:
		true - if completely inside view frustum
		false - if completely outside view frustum
		nil - if partly inside/outside view frustum
	"! !

!B3DRenderEngine methodsFor: 'private-rendering' stamp: 'ar 11/7/2000 17:28'!
renderPrimitive
	"This is the main rendering loop for all operations"
	| visible |
	"Step 1: Check if the mesh is visible at all"
	visible _ self privateVisibleVB: vertexBuffer.
	visible == false ifTrue:[^nil].

	"Step 2: Transform vertices, normals, texture coords of the mesh"
	self privateTransformVB: vertexBuffer.

	"Step 4a: Pre-clip the mesh if needed so that we can reject invisible meshes before shading"
	(self privateNeedsClipVB: visible)
		ifTrue:[visible _ self privatePreClipVB: vertexBuffer]
		ifFalse:[visible _ true]. "don't bother clipping below"
	visible == false ifTrue:[^nil].

	"Step 3: Light the vertices of the mesh."
	self privateNeedsShadingVB
		ifTrue:[self privateShadeVB: vertexBuffer].

	"Step 4: Clip the mesh if necessary"
	(visible == nil)
		ifTrue:[visible _ self privatePostClipVB: vertexBuffer].

	"Step 5: Rasterize the mesh"
	^self privateRasterizeVB: vertexBuffer.! !


!B3DRenderEngine methodsFor: 'transforming' stamp: 'ar 2/4/1999 20:18'!
loadIdentity
	^transformer loadIdentity! !

!B3DRenderEngine methodsFor: 'transforming'!
lookFrom: position to: target up: upDirection
	^transformer lookFrom: position to: target up: upDirection! !

!B3DRenderEngine methodsFor: 'transforming'!
perspective: aPerspective
	^transformer perspective: aPerspective! !

!B3DRenderEngine methodsFor: 'transforming' stamp: 'ar 2/5/1999 23:27'!
popMatrix
	^transformer popMatrix! !

!B3DRenderEngine methodsFor: 'transforming' stamp: 'ar 2/5/1999 23:27'!
pushMatrix
	^transformer pushMatrix! !

!B3DRenderEngine methodsFor: 'transforming'!
rotateBy: aRotation
	^transformer rotateBy: aRotation! !

!B3DRenderEngine methodsFor: 'transforming' stamp: 'ar 2/15/1999 02:54'!
scaleBy: value
	^transformer scaleBy: value! !

!B3DRenderEngine methodsFor: 'transforming'!
transformBy: aTransformation
	^transformer transformBy: aTransformation! !

!B3DRenderEngine methodsFor: 'transforming' stamp: 'ar 2/4/1999 03:56'!
translateBy: aVector
	^transformer translateBy: aVector! !


!B3DRenderEngine methodsFor: 'initialize' stamp: 'ar 2/16/1999 01:46'!
destroy
	"Utility - destroy all resources associated with any part of the engine"
	transformer destroy.
	shader destroy.
	clipper destroy.
	rasterizer destroy.! !

!B3DRenderEngine methodsFor: 'initialize' stamp: 'ar 2/16/1999 01:45'!
finish
	"Flush the pipeline and force changes to the output medium"
	self flush.
	rasterizer finish.! !

!B3DRenderEngine methodsFor: 'initialize' stamp: 'ar 2/5/1999 21:34'!
flush
	"Flush the entire pipeline"
	transformer flush.
	shader flush.
	clipper flush.
	rasterizer flush.! !

!B3DRenderEngine methodsFor: 'initialize' stamp: 'ar 4/18/1999 00:35'!
initialize
	engine _ self. "Obviously ;-)"
	vertexBuffer _ B3DVertexBuffer new.
	transformer _ self class transformer engine: self.
	shader _ self class shader engine: self.
	clipper _ self class clipper engine: self.
	rasterizer _ self class rasterizer engine: self.
	self materialColor: Color white.! !

!B3DRenderEngine methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:51'!
reset
	vertexBuffer reset.
	transformer reset.
	shader reset.
	clipper reset.
	rasterizer reset.
	self materialColor: Color white.! !


!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/15/1999 20:24'!
addLight: aLightSource
	"Add the given light source to the engine.
	Return a handle that can be used to modify the light source later on"
	^shader addLight: (aLightSource transformedBy: transformer)! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/15/1999 20:25'!
removeLight: lightHandle
	"Remove the light with the given handle from the engine."
	^shader removeLight: lightHandle! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:30'!
trackAmbientColor
	^vertexBuffer trackAmbientColor! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:30'!
trackAmbientColor: aBoolean
	^vertexBuffer trackAmbientColor: aBoolean! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:31'!
trackDiffuseColor
	^vertexBuffer trackDiffuseColor! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:30'!
trackDiffuseColor: aBoolean
	^vertexBuffer trackDiffuseColor: aBoolean! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:31'!
trackEmissionColor
	^vertexBuffer trackEmissionColor! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:30'!
trackEmissionColor: aBoolean
	^vertexBuffer trackEmissionColor: aBoolean! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:31'!
trackSpecularColor
	^vertexBuffer trackSpecularColor! !

!B3DRenderEngine methodsFor: 'shading' stamp: 'ar 2/8/1999 02:30'!
trackSpecularColor: aBoolean
	^vertexBuffer trackSpecularColor: aBoolean! !


!B3DRenderEngine methodsFor: 'indexed primitives' stamp: 'ar 11/7/1999 18:12'!
drawIndexedLines: indexArray vertices: vertexArray normals: normalArray colors: colorArray texCoords: texCoordArray
	vertexBuffer reset.
	vertexBuffer primitive: 4.
	vertexBuffer 
		loadIndexed: indexArray
		vertices: vertexArray 
		normals: normalArray 
		colors: colorArray 
		texCoords: texCoordArray.
	^self renderPrimitive.! !

!B3DRenderEngine methodsFor: 'indexed primitives' stamp: 'ar 11/7/1999 18:12'!
drawIndexedQuads: indexArray vertices: vertexArray normals: normalArray colors: colorArray texCoords: texCoordArray
	vertexBuffer reset.
	vertexBuffer primitive: 6.
	vertexBuffer 
		loadIndexed: indexArray
		vertices: vertexArray 
		normals: normalArray 
		colors: colorArray 
		texCoords: texCoordArray.
	^self renderPrimitive.! !

!B3DRenderEngine methodsFor: 'indexed primitives' stamp: 'ar 11/7/1999 18:12'!
drawIndexedTriangles: indexArray vertices: vertexArray normals: normalArray colors: colorArray texCoords: texCoordArray
	vertexBuffer reset.
	vertexBuffer primitive: 5.
	vertexBuffer 
		loadIndexed: indexArray
		vertices: vertexArray 
		normals: normalArray 
		colors: colorArray 
		texCoords: texCoordArray.
	^self renderPrimitive.! !


!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:20'!
clipRect
	"Return the current clipRect"
	^rasterizer clipRect! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:20'!
clipRect: aRectangle
	"Set the current clipRect"
	^rasterizer clipRect: aRectangle! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 4/17/1999 23:12'!
getClipper
	"Private. Return the clipper used with this engine."
	^clipper! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 4/17/1999 23:13'!
getRasterizer
	"Private. Return the rasterizer used with this engine."
	^rasterizer! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 4/17/1999 23:12'!
getShader
	"Private. Return the shader used with this engine."
	^shader! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 4/17/1999 23:12'!
getTransformer
	"Private. Return the transformer used with this engine."
	^transformer! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 4/17/1999 23:11'!
getVertexBuffer
	"Private. Return the vertex buffer used with this engine."
	^vertexBuffer! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:19'!
target
	"Return the rendering target"
	^rasterizer target! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:19'!
target: aForm
	"Set the rendering target"
	^rasterizer target: aForm! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:18'!
viewportOffset
	"Return the offset for the viewport"
	^rasterizer viewportOffset! !

!B3DRenderEngine methodsFor: 'private-access' stamp: 'ar 5/26/2000 15:16'!
viewportOffset: aPoint
	"Set the offset for the viewport"
	^rasterizer viewportOffset: aPoint! !


!B3DRenderEngine methodsFor: 'picking' stamp: 'ar 4/18/1999 02:28'!
asPickerAt: aPoint
	^self asPickerAt: aPoint extent: 1@1! !

!B3DRenderEngine methodsFor: 'picking' stamp: 'ar 4/17/1999 23:56'!
asPickerAt: aPoint extent: extentPoint
	| picker |
	picker _ B3DPickerEngine new.
	picker loadFrom: self.
	picker pickAt: aPoint extent: extentPoint.
	^picker! !

!B3DRenderEngine methodsFor: 'picking' stamp: 'ar 2/27/2000 20:12'!
pickingMatrixAt: aPoint extent: extentPoint
	"Return a matrix for picking at the given point using the given extent."
	^self pickingMatrixFor: self viewport at: aPoint extent: extentPoint! !

!B3DRenderEngine methodsFor: 'picking' stamp: 'ar 2/27/2000 20:10'!
pickingMatrixFor: vp at: aPoint extent: extentPoint
	"Return a matrix for picking at the given point using the given extent."
	| m scaleX scaleY ofsX ofsY |
	scaleX _ vp width / extentPoint x.
	scaleY _ vp height / extentPoint y.
	ofsX _ (vp width + (2.0 * (vp origin x - aPoint x))) / extentPoint x.
	ofsY _ (vp height + (2.0 * (aPoint y - vp corner y))) / extentPoint y.
	m _ B3DMatrix4x4 identity.
	m a11: scaleX; a22: scaleY.
	m a14: ofsX; a24: ofsY.
	^m! !


!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:23'!
hasProperty: propName
	"Answer whether the receiver has the given property.  Deemed to have it only if I have a property dictionary entry for it and that entry is neither nil nor false"
	self valueOfProperty: propName ifAbsent:[^false].
	^true! !

!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:25'!
properties
	^properties ifNil:[properties _ IdentityDictionary new].! !

!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:23'!
removeProperty: propName
	self valueOfProperty: propName ifAbsent:[^self].
	self properties removeKey: propName.! !

!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:22'!
setProperty: propName toValue: aValue

	aValue ifNil: [^ self removeProperty: propName].
	self properties at: propName put: aValue.! !

!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:24'!
valueOfProperty: propName
	^self valueOfProperty: propName ifAbsent:[nil]! !

!B3DRenderEngine methodsFor: 'properties' stamp: 'ar 11/7/1999 18:36'!
valueOfProperty: propName ifAbsent: aBlock
	properties == nil ifTrue: [^ aBlock value].
	^properties at: propName ifAbsent: aBlock! !

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

B3DRenderEngine class
	instanceVariableNames: ''!

!B3DRenderEngine class methodsFor: 'instance creation' stamp: 'ar 5/26/2000 15:10'!
defaultForPlatformOn: aForm
	"Return the render engine that is most appropriate for the current host platform."
	(B3DHardwareEngine isAvailableFor: aForm) 
		ifTrue:[^B3DHardwareEngine newOn: aForm].
	(B3DPrimitiveEngine isAvailableFor: aForm) 
		ifTrue:[^B3DPrimitiveEngine newOn: aForm].
	^B3DRenderEngine newOn: aForm! !

!B3DRenderEngine class methodsFor: 'instance creation'!
new
	^super new initialize! !

!B3DRenderEngine class methodsFor: 'instance creation' stamp: 'ar 5/26/2000 15:49'!
newOn: aForm
	^(self new) target: aForm; yourself! !


!B3DRenderEngine class methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:37'!
clipper
	"Return the transformer to use with this engine"
	^B3DVertexClipper! !

!B3DRenderEngine class methodsFor: 'accessing' stamp: 'ar 4/18/1999 05:27'!
rasterizer
	"Return the rasterizer to use with this engine"
	^B3DSimulRasterizer! !

!B3DRenderEngine class methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:37'!
shader
	"Return the shader to use with this engine"
	^B3DVertexShader! !

!B3DRenderEngine class methodsFor: 'accessing' stamp: 'ar 2/14/1999 01:37'!
transformer
	"Return the transformer to use with this engine"
	^B3DVertexTransformer! !


!B3DRenderEngine class methodsFor: 'testing' stamp: 'ar 2/14/1999 01:39'!
isAvailable
	"Return true if this engine is available (e.g., all of its parts are avaiable)"
	^(self transformer isAvailable and:[
		self shader isAvailable and:[
			self clipper isAvailable and:[
				self rasterizer isAvailable]]])! !

!B3DRenderEngine class methodsFor: 'testing' stamp: 'ar 2/16/1999 17:34'!
isAvailableFor: anOutputMedium
	"Return true if this engine is available for the given output medium"
	^(self transformer isAvailableFor: anOutputMedium)  and:[
		(self shader isAvailableFor: anOutputMedium) and:[
			(self clipper isAvailableFor: anOutputMedium) and:[
				(self rasterizer isAvailableFor: anOutputMedium)]]]! !
B3DFloatArray variableWordSubclass: #B3DRotation
	instanceVariableNames: ''
	classVariableNames: 'B3DIdentityRotation '
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DRotation commentStamp: '<historical>' prior: 0!
I represent general 3d rotations by using Unit-Quaternions. Unit-Quaternions are one of the best available representation for rotations in computer graphics because they provide an easy way of doing arithmetic with them and also because they allow us to use spherical linear interpolation (so-called "slerps") of rotations.

Indexed Variables:
	a	<Float>	the real part of the quaternion
	b	<Float>	the first imaginary part of the quaternion
	c	<Float>	the second imaginary part of the quaternion
	d	<Float>	the third imaginary part of the quaternion

!


!B3DRotation methodsFor: 'initialize' stamp: 'ar 2/1/1999 22:02'!
a: aValue b: bValue c: cValue d: dValue

	self a: aValue.
	self b: bValue.
	self c: cValue.
	self d: dValue.
	(aValue < 0.0) ifTrue:[self *= -1.0].
	self normalize.! !

!B3DRotation methodsFor: 'initialize' stamp: 'ar 2/1/1999 22:02'!
angle: anAngle axis: aVector3

	self radiansAngle: anAngle degreesToRadians axis: aVector3
! !

!B3DRotation methodsFor: 'initialize' stamp: 'ar 2/1/1999 22:02'!
from: startVector to: endVector
	"Create a rotation from startVector to endVector"
	| axis cos sin |
	axis := startVector cross: endVector.
	cos := (startVector dot: endVector) arcCos.
	sin := axis length.
	axis safelyNormalize.
	self a: cos b: axis x * sin c: axis y * sin d: axis z * sin. ! !

!B3DRotation methodsFor: 'initialize' stamp: 'ar 2/1/1999 22:03'!
radiansAngle: anAngle axis: aVector3

	| angle sin cos |
	angle := anAngle / 2.0.
	cos := angle cos.
	sin := angle sin.
	self a: cos b: aVector3 x * sin c: aVector3 y * sin d: aVector3 z * sin.! !

!B3DRotation methodsFor: 'initialize'!
setIdentity
	^self loadFrom: B3DIdentityRotation! !

!B3DRotation methodsFor: 'initialize' stamp: 'ar 2/1/1999 22:03'!
x: xValue y: yValue z: zValue a: anAngle

	| angle sin cos |
	angle := (anAngle degreesToRadians) / 2.0.
	cos := angle cos.
	sin := angle sin.
	self a: cos b: xValue * sin c: yValue * sin d: zValue * sin! !


!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:59'!
a
	^self at: 1! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:59'!
a: aFloat
	self at: 1 put: aFloat! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 22:04'!
angle
	^(self a arcCos * 2.0 radiansToDegrees)! !

!B3DRotation methodsFor: 'accessing'!
angle: newAngle
	self angle: newAngle axis: self axis! !

!B3DRotation methodsFor: 'accessing'!
axis
	| sinAngle |
	sinAngle := self a arcCos sin.
	sinAngle isZero ifTrue:[^B3DVector3 zero].
	^B3DVector3 
		x: (self b / sinAngle)
		y: (self c / sinAngle)
		z: (self d / sinAngle)! !

!B3DRotation methodsFor: 'accessing'!
axis: newAxis
	self angle: self angle axis: newAxis! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:59'!
b
	^self at: 2! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 22:00'!
b: aFloat
	self at: 2 put: aFloat! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:59'!
c
	^self at: 3! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 22:00'!
c: aFloat
	self at: 3 put: aFloat! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:59'!
d
	^self at: 4! !

!B3DRotation methodsFor: 'accessing' stamp: 'ar 2/1/1999 22:00'!
d: aFloat
	self at: 4 put: aFloat! !


!B3DRotation methodsFor: 'arithmetic' stamp: 'ar 2/1/1999 22:05'!
* aRotation
	"Multiplying two rotations is the same as concatenating the two rotations."
	| v1 v2 v3 vv |
	v1 := self bcd * aRotation a.
	v2 := aRotation bcd * self a.
	v3 := aRotation bcd cross: self bcd.
	vv := v1 + v2 + v3.
	^B3DRotation
		a: (self a * aRotation a) - (self bcd dot: aRotation bcd)
		b: vv x
		c: vv y
		d: vv z! !

!B3DRotation methodsFor: 'arithmetic' stamp: 'ar 2/1/1999 22:06'!
negated
	"Negating a quaternion is the same as reversing the angle of rotation"
	^B3DRotation
		a: self a negated
		b: self b
		c: self c
		d: self d! !

!B3DRotation methodsFor: 'arithmetic' stamp: 'ar 9/17/1999 12:43'!
normalize
	"Normalize the receiver. Note that the actual angle (a) determining the amount of 
	rotation is fixed, since we do not want to modify angles. This leads to:
		a^2 + b^2 + c^2 + d^2 = 1.
		b^2 + c^2 + d^2 = 1 - a^2.
	Note also that the angle (a) can not exceed 1.0 (due its creation by cosine) and
	if it is 1.0 we have exactly the unit quaternion ( 1, [ 0, 0, 0]).
	"
	| oneMinusASquared length |
	oneMinusASquared := 1.0 - (self a squared).
	(oneMinusASquared < 1.0e-10) ifTrue:[^self setIdentity].
	length := ((self b squared + self c squared + self d squared) / oneMinusASquared) sqrt.
	length = 0.0 ifTrue:[^self setIdentity].
	self b: self b / length.
	self c: self c / length.
	self d: self d / length.
! !


!B3DRotation methodsFor: 'converting'!
asMatrix4x4
	"Given a quaternion q = (a, [ b, c , d]) the rotation matrix can be calculated as
			|	1 -	2(cc+dd),		2(bc-da),		2(db+ca)	|
		m =	|		2(bc+da),	1 - 	2(bb+dd),		2(cd-ba)		|
			|		2(db-ca),		2(cd+ba),	1 -	2(bb+cc)	|
	"
	| a b c d m bb cc dd bc cd db ba ca da |
	a _ self a. b _ self b. c _ self c. d _ self d.
	bb := (b * b).	cc := (c * c).	dd := (d * d).
	bc := (b * c).	cd := (c * d).	db := (d * b).
	ba := (b * a).	ca := (c * a).	da := (d * a).
	m := self matrixClass identity.
	m 
		a11: 1.0 - (cc + dd * 2.0);a12: (bc - da * 2.0); 		a13: (db + ca * 2.0);
		a21: (bc + da * 2.0);		a22: 1.0 - (bb + dd * 2.0);a23: (cd - ba * 2.0);
		a31: (db - ca * 2.0);		a32: (cd + ba * 2.0);		a33: 1.0 - (bb + cc * 2.0).
	^m
! !

!B3DRotation methodsFor: 'converting' stamp: 'ar 2/1/1999 22:08'!
normalized
	^self copy normalize! !


!B3DRotation methodsFor: 'interpolating' stamp: 'jsp 2/25/1999 15:57'!
interpolateTo: aRotation at: t
	"Spherical linear interpolation (slerp) from the receiver to aQuaternion"
	^self slerpTo: aRotation at: t extraSpins: 0! !

!B3DRotation methodsFor: 'interpolating' stamp: 'ar 2/1/1999 22:08'!
slerpTo: aRotation at: t
	"Spherical linear interpolation (slerp) from the receiver to aQuaternion"
	^self slerpTo: aRotation at: t extraSpins: 0! !

!B3DRotation methodsFor: 'interpolating' stamp: 'ar 3/24/1999 14:58'!
slerpTo: aRotation at: t extraSpins: spin
	"Sperical Linear Interpolation (slerp).
	Calculate the new quaternion when applying slerp from the receiver (t = 0.0)
	to aRotation (t = 1.0). spin indicates the number of extra rotations to be added.
	The code shown below is from Graphics Gems III"
	| cosT alpha beta flip theta phi sinT |
	alpha := t.
	flip := false.
	"calculate the cosine of the two quaternions on the 4d sphere"
	cosT := self dot: aRotation.
	"if aQuaternion is on the opposite hemisphere reverse the direction
	(note that in quaternion space two points describe the same rotation)"
	cosT < 0.0 ifTrue:[
		flip := true.
		cosT := cosT negated].
	"If the aQuaternion is nearly the same as I am use linear interpolation"
	cosT > 0.99999 ifTrue:[
		"Linear Interpolation"
		beta := 1.0 - alpha
	] ifFalse:[
		"Spherical Interpolation"
		theta := cosT arcCos.
		phi := (spin * Float pi) + theta.
		sinT := theta sin.
		beta := (theta - (alpha * phi)) sin / sinT.
		alpha := (alpha * phi) sin / sinT].

	flip ifTrue:[alpha := alpha negated].
	^B3DRotation 
		a: (alpha * aRotation a) + (beta * self a)
		b: (alpha * aRotation b) + (beta * self b)
		c: (alpha * aRotation c) + (beta * self c)
		d: (alpha * aRotation d) + (beta * self d)! !


!B3DRotation methodsFor: 'printing' stamp: 'ar 2/1/1999 22:09'!
printOn: aStream

	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: self angle;
		nextPut: Character space;
		print: self axis;
		nextPut:$).! !


!B3DRotation methodsFor: 'private'!
bcd
	^B3DVector3 x: self b y: self c z: self d! !

!B3DRotation methodsFor: 'private' stamp: 'ar 2/1/1999 22:10'!
matrixClass
	^B3DMatrix4x4! !

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

B3DRotation class
	instanceVariableNames: ''!

!B3DRotation class methodsFor: 'instance creation'!
a: aValue b: bValue c: cValue d: dValue
	^self new a: aValue b: bValue c: cValue d: dValue! !

!B3DRotation class methodsFor: 'instance creation'!
angle: anAngle axis: aVector3
	^self new angle: anAngle axis: aVector3! !

!B3DRotation class methodsFor: 'instance creation'!
axis: aVector3 angle: anAngle
	^self angle: anAngle axis: aVector3! !

!B3DRotation class methodsFor: 'instance creation'!
from: startVector to: endVector
	^self new from: startVector to: endVector! !

!B3DRotation class methodsFor: 'instance creation'!
identity
	^self new setIdentity! !

!B3DRotation class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:32'!
numElements
	^4! !

!B3DRotation class methodsFor: 'instance creation'!
radiansAngle: anAngle axis: aVector3
	^self new radiansAngle: anAngle axis: aVector3! !

!B3DRotation class methodsFor: 'instance creation'!
x: xValue y: yValue z: zValue a: anAngle
	^self new x: xValue y: yValue z: zValue a: anAngle! !


!B3DRotation class methodsFor: 'class initialization'!
initialize
	"B3DRotation initialize"
	B3DIdentityRotation _ self new.
	B3DIdentityRotation floatAt: 1 put: 1.0.! !
B3DInplaceArray variableWordSubclass: #B3DRotationArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!

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

B3DRotationArray class
	instanceVariableNames: ''!

!B3DRotationArray class methodsFor: 'instance creation' stamp: 'ar 5/4/2000 15:45'!
contentsClass
	^B3DRotation! !
B3DIndexedTriangleMesh subclass: #B3DSTriangleMesh
	instanceVariableNames: 'edgeFlags smoothFlags '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!
!B3DSTriangleMesh commentStamp: '<historical>' prior: 0!
I represent a mesh from Autodesk 3D Studio.!


!B3DSTriangleMesh methodsFor: 'initialize' stamp: 'ar 2/7/1999 20:57'!
from3DS: aDictionary
	| triList triSpec triSize tri flags |
	aDictionary isEmpty ifTrue:[^nil].
	vertices _ aDictionary at: #vertexList.
	"matrix _ aDictionary at: #matrix ifAbsent:[nil].
	matrix ifNotNil:[matrix quickTransformV3ArrayFrom: vertices to: vertices]."
	vtxTexCoords _ aDictionary at: #textureVertices ifAbsent:[nil].
	triList _ aDictionary at: #triList.
	triSpec _ triList first.
	triSize _ triSpec size.
	faces _ B3DIndexedTriangleArray new: triSize.
	edgeFlags _ ByteArray new: triSize.
	1 to: triSize do:[:i|
		tri _ (triSpec at: i) key.
		flags _ (triSpec at: i) value.
		faces at: i put: (B3DIndexedTriangle with: tri first with: tri second with: tri third).
		edgeFlags at: i put: flags].
	triList second ifNotNil:[
		smoothFlags _ WordArray new: triSize.
		triList second doWithIndex:[:smoothFlag :index| smoothFlags at: index put: smoothFlag]].
! !


!B3DSTriangleMesh methodsFor: 'private' stamp: 'ar 2/15/1999 06:44'!
collectSplitVertices: aSet
	"Collect the non smooth vertices into a Dictionary
		vertex index -> Dictionary
							smoothing group -> list of face indexes.
	"
	| face flag vtxIndex groups groupDict |
	groupDict _ Dictionary new: aSet size * 2.
	1 to: faces size do:[:faceIndex|
		face _ faces at: faceIndex.
		flag _ smoothFlags at: faceIndex.
		1 to: 3 do:[:j|
			vtxIndex _ face at: j.
			(aSet includes: vtxIndex) ifTrue:[ 
				groups _ groupDict at: vtxIndex ifAbsentPut:[Dictionary new].
				(groups at: flag ifAbsentPut:[OrderedCollection new]) add: faceIndex.
			].
		].
	].
	^groupDict! !

!B3DSTriangleMesh methodsFor: 'private' stamp: 'ar 2/17/1999 15:59'!
computeFunkyVertexNormals
	"Compute the vertex normals for the receiver.
	Don't split the faces so we'll get some funky lighting effects."
	vtxNormals _ super computeVertexNormals
! !

!B3DSTriangleMesh methodsFor: 'private' stamp: 'ar 2/17/1999 15:57'!
computeVertexNormals
	"Compute the vertex normals for the receiver.
	Note: This is a multi pass process here - we may have to split up vertices"
	| set dict |
	set _ self detectNonSmoothVertices.
	set isEmpty ifFalse:[
		"Collect the dictionary of vertices to split"
		dict _ self collectSplitVertices: set.
		"And actually split them"
		self splitVerticesFrom: dict.
	].
	"Now do the actual computation"
	^super computeVertexNormals! !

!B3DSTriangleMesh methodsFor: 'private' stamp: 'ar 2/15/1999 06:54'!
detectNonSmoothVertices
	"Detect all the vertices in the receiver that cannot be easily smoothed"
	| mask face flag vtxIndex out newMask |
	smoothFlags ifNil:[^#()].
	mask _ WordArray new: vertices size.
	mask atAllPut: 16rFFFFFFFF.
	out _ Set new: 1000. "Leave us enough space to avoid collisions"
	1 to: faces size do:[:i|
		face _ faces at: i.
		flag _ smoothFlags at: i.
		1 to: 3 do:[:j|
			vtxIndex _ face at: j.
			newMask _ ((mask at: vtxIndex) bitAnd: flag).
			newMask = 0 ifTrue:[out add: vtxIndex].
			mask at: vtxIndex put: newMask.
		].
	].
	^out! !

!B3DSTriangleMesh methodsFor: 'private' stamp: 'ar 2/15/1999 06:49'!
splitVerticesFrom: aDictionary
	"Split the non smooth vertices from the Dictionary
		vertex index -> Dictionary
							smoothing group -> list of face indexes.
	"
	| newVertices newColors newTexCoords nextIndex vtxIndex nValues skipAssoc faceList iFace |
	newVertices _ WriteStream with: vertices.
	vtxColors ifNotNil:[newColors _ WriteStream with: vtxColors].
	vtxTexCoords ifNotNil:[newTexCoords _ WriteStream with: vtxTexCoords].
	nextIndex _ vertices size.
	aDictionary associationsDo:[:vertexAssoc|
		vtxIndex _ vertexAssoc key.
		nValues _ vertexAssoc value size - 1.
		"We have to copy n values"
		newVertices next: nValues put: (vertices at: vtxIndex).
		newColors ifNotNil:[newColors next: nValues put: (vtxColors at: vtxIndex)].
		newTexCoords ifNotNil:[newTexCoords next: nValues put: (vtxTexCoords at: vtxIndex)].
		skipAssoc _ true. "Skip the first association - we can reuse the original vertex"
		vertexAssoc value associationsDo:[:smoothAssoc|
			skipAssoc ifFalse:[
				faceList _ smoothAssoc value.
				nextIndex _ nextIndex + 1.
				faceList do:[:faceIndex|
					iFace _ faces at: faceIndex.
					1 to: 3 do:[:i| (iFace at: i) = vtxIndex ifTrue:[iFace at: i put: nextIndex]].
					faces at: faceIndex put: iFace.
				].
			].
			skipAssoc _ false.
		].
	].
	"Cleanup"
	vtxNormals _ nil. "Must be recomputed"
	vertices _ newVertices contents.
	newColors ifNotNil:[vtxColors _ newColors contents].
	newTexCoords ifNotNil:[vtxTexCoords _ newTexCoords contents].! !

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

B3DSTriangleMesh class
	instanceVariableNames: ''!

!B3DSTriangleMesh class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 21:26'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !
Object subclass: #B3DScanner
	instanceVariableNames: 'aet fillList added lastIntersection nextIntersection objects spanBuffer bitBlt nFaces maxFaces maxEdges '
	classVariableNames: 'DebugMode FlagContinueLeftEdge FlagContinueRightEdge FlagEdgeLeftMajor FlagEdgeRightMajor FlagFaceActive FlagFaceInitialized '
	poolDictionaries: ''
	category: 'VMConstruction-B3DSimulator'!

!B3DScanner methodsFor: 'initialize' stamp: 'ar 4/18/1999 07:59'!
initialize
	aet _ B3DActiveEdgeTable new.
	fillList _ B3DFillList new.
	added _ B3DPrimitiveEdgeList new.
	lastIntersection _ B3DPrimitiveEdge new.
	nextIntersection _ B3DPrimitiveEdge new.
	objects _ OrderedCollection new.! !

!B3DScanner methodsFor: 'initialize' stamp: 'ar 4/18/1999 05:21'!
setupObjects
	"Set up the list of objects (e.g., triangle inputs)
	by creating a linked list of objects which is sorted by the initial
	yValue of the tris."
	| lastObj |
	objects _ objects sortBy: [:obj1 :obj2| obj1 bounds origin sortsBefore: obj2 bounds origin].
	lastObj _ nil.
	objects do:[:nextObj|
		nextObj reset.
		nextObj prevObj: lastObj.
		lastObj == nil ifFalse:[lastObj nextObj: nextObj].
		lastObj _ nextObj.
	].
	lastObj == nil ifFalse:[lastObj nextObj: nil].
! !


!B3DScanner methodsFor: 'public' stamp: 'ar 4/18/1999 05:15'!
addObject: primObj
	objects add: primObj.! !

!B3DScanner methodsFor: 'public' stamp: 'kfr 6/26/2000 14:50'!
bitBlt
	^bitBlt! !

!B3DScanner methodsFor: 'public' stamp: 'ar 4/18/1999 05:29'!
bitBlt: aBitBlt
	bitBlt _ aBitBlt.! !

!B3DScanner methodsFor: 'public' stamp: 'ar 4/18/1999 07:55'!
mainLoop
	| yValue nextObjY nextEdgeY obj activeStart passiveStart scaledY |
	objects size = 0 ifTrue:[^self]. "No input"
	self setupObjects. "Sort objects and create linked list"
	nFaces _ maxFaces _ maxEdges _ 0.
	"Pre-fetch first object to start from"
	activeStart _ passiveStart _ objects at: 1.
	yValue _ nextEdgeY _ nextObjY _ passiveStart bounds origin y.
	[activeStart == nil and:[passiveStart == nil and:[aet isEmpty]]] whileFalse:[
		"Add new objects if necessary"
		yValue = nextObjY ifTrue:[
			"Make sure we add edges from newly created objects"
			nextEdgeY _ nextObjY.
			"Add new objects"
			[passiveStart notNil and:[passiveStart bounds origin y = nextObjY]]
				whileTrue:[passiveStart _ passiveStart nextObj].
			passiveStart == nil 
				ifTrue:[nextObjY _ 99999]"Some large value"
				ifFalse:[nextObjY _ passiveStart bounds origin y]. 
		]. "End of adding new objects"

		"Add new edges if necessary"
		yValue = nextEdgeY ifTrue:[
			nextEdgeY _ nextObjY bitShift: 12. "Some VERY large value"
			scaledY _ (yValue+1) bitShift: 12.
			obj _ activeStart.
			[obj == passiveStart] whileFalse:[
				[obj atEnd not and:[obj peekY < scaledY]]
					whileTrue:[self addEdgesFromFace: obj next at: yValue].
				obj atEnd ifTrue:[
					obj == activeStart
						ifTrue:[activeStart _ obj nextObj]
						ifFalse:[obj prevObj nextObj: obj nextObj].
				] ifFalse:[obj peekY < nextEdgeY ifTrue:[nextEdgeY _ obj peekY]].
				obj _ obj nextObj.
			].
			nextEdgeY _ (nextEdgeY bitShift: -12).
		].
		added isEmpty ifFalse:[
			"Merge new edges into AET"
			"Note: These may be lower half edges."
			B3DScanner doDebug ifTrue:[self validateAETOrder].
			aet mergeEdgesFrom: added.
			B3DScanner doDebug ifTrue:[
				self validateAETOrder.
				self validateEdgesFrom: aet].
			added reset. "Clean up the list"
		].

		"This is the core loop."
		"[yValue < nextEdgeY and:[added isEmpty and:[aet isEmpty not]]] whileTrue:["
			B3DScanner doDebug ifTrue:[yValue printString displayAt: 0@0].
			"gather stats"
			maxEdges _ maxEdges max: aet size.
			maxFaces _ maxFaces max: nFaces.

			"Scan out the AET"
			aet isEmpty ifFalse:[
				self clearSpanBufferAt: yValue.
				self scanAETAt: yValue.
				self drawSpanBufferAt: yValue.

				"Advance to next y and update AET"
			].
			yValue _ yValue + 1.
			aet isEmpty ifFalse:[self updateAETAt: yValue].
		"]."
	].
	nFaces = 0 ifFalse:[self error: nFaces printString,' remaining faces'].! !

!B3DScanner methodsFor: 'public' stamp: 'ar 4/18/1999 05:31'!
resetObjects
	objects _ OrderedCollection new.! !

!B3DScanner methodsFor: 'public' stamp: 'ar 4/18/1999 05:28'!
spanBuffer: aBitmap
	spanBuffer _ aBitmap.! !


!B3DScanner methodsFor: 'aet adding' stamp: 'ar 4/18/1999 08:14'!
addEdgesFromFace: face at: yValue
	"Add the two top edges from the given face to the aet.
	The top edges are (v0-v1) and (v0-v2) where (v0-v1) is 
	the 'upper' half-edge of the triangle"
	| xValue index needMajor needMinor majorEdge minorEdge |
	face oneOverArea = 0.0 ifTrue:[^self].
	needMinor _ needMajor _ true. "We need both edges"
	majorEdge _ minorEdge _ nil.
	xValue _ face vertex0 windowPosX.
	"Search the insertion list to merge the edges of the face"
	index _ added firstIndexForInserting: xValue.
	index _ added xValue: xValue from: index do:[:edge|
		(edge rightFace == nil and:[
			"Note: edge vertex0 == face vertex0 should be the case for most meshes.
				But since it is advantegous for the scanner to have two faces per edge
				we're also checking for the actual vertex values."
			edge vertex0 == face vertex0 or:[
				edge vertex0 rasterPos = face vertex0 rasterPos]]) ifTrue:[
			"This edge is a possible candidate for adding the face"
			(needMajor and:["See above comment"
				edge vertex1 == face vertex2 or:[
					edge vertex1 rasterPos = face vertex2 rasterPos]]) ifTrue:[
				majorEdge _ edge.
				edge rightFace: face.
				edge flags: (edge flags bitOr: FlagEdgeRightMajor).
				nFaces _ nFaces + 1.
				needMinor ifFalse:[
					^self adjustFace: face major: majorEdge minor: minorEdge]. "Done."
				needMajor _ false.
			] ifFalse:[
				(needMinor and:["See above comment"
					edge vertex1 == face vertex1 or:[
						edge vertex1 rasterPos = face vertex1 rasterPos]]) ifTrue:[
					minorEdge _ edge.
					edge rightFace: face.
					edge flags: (edge flags bitOr: FlagContinueRightEdge).
					needMajor ifFalse:[
						^self adjustFace: face major: majorEdge minor: minorEdge]. "Done."
					needMinor _ false.
				].
			].
		].
	].
	"Need to add new edges.
	NOTE: index already points to the right point for insertion."
	needMajor ifTrue:[
		majorEdge _ B3DPrimitiveEdge new.
		majorEdge v0: face vertex0 v1: face vertex2.
		majorEdge nLines = 0 ifTrue:[^self]. "Horizontal edge"
		majorEdge leftFace: face.
		majorEdge initializePass1.
		majorEdge flags: (majorEdge flags bitOr: FlagEdgeLeftMajor).
		nFaces _ nFaces + 1.
	].
	needMinor ifTrue:[
		minorEdge _ B3DPrimitiveEdge new.
		minorEdge v0: face vertex0 v1: face vertex1.
		minorEdge leftFace: face.
		minorEdge flags: FlagContinueLeftEdge.

		"Note: If the (upper) minor edge is horizontal, use the lower one.
		Note: The lower minor edge cannot be horizontal if the major one isn't"
		minorEdge nLines = 0 ifTrue:[
			needMajor ifTrue:[added add: majorEdge beforeIndex: index].
			minorEdge _ self addLowerEdge: minorEdge fromFace: face.
			minorEdge nLines = 0 ifTrue:[self error:'Minor edge is horizontal'].
			^self adjustFace: face major: majorEdge minor: minorEdge].

		minorEdge flags: FlagContinueLeftEdge.
		minorEdge initializePass1.
		minorEdge xValue = xValue ifFalse:[self error:'Problem with minor edge'].
		minorEdge nLines = 0 ifTrue:[self error:'Minor edge is horizontal'].
	].
	needMajor & needMinor ifTrue:[
		added add: majorEdge and: minorEdge beforeIndex: index.
	] ifFalse:[
		needMajor
			ifTrue:[added add: majorEdge beforeIndex: index]
			ifFalse:[added add: minorEdge beforeIndex: index].
	].
	^self adjustFace: face major: majorEdge minor: minorEdge.! !

!B3DScanner methodsFor: 'aet adding' stamp: 'ar 4/18/1999 05:56'!
addLowerEdge: oldEdge fromFace: face
	"Add the lower edge (v1-v2) from the given face.
	Return the newly created edge."
	| index minorEdge xValue |
	xValue _ face vertex1 windowPosX.
	index _ added firstIndexForInserting: xValue.
	index _ added xValue: xValue from: index do:[:edge|
		(edge rightFace == nil and:[
			"See the comment in #addEdgesFromFace:at:"
			(edge vertex0 == face vertex1 and:[edge vertex1 == face vertex2]) or:[
			edge vertex0 rasterPos = face vertex1 rasterPos and:[
				edge vertex1 rasterPos = face vertex2 rasterPos]]]) ifTrue:[
				"Adjust the left or right edge of the face"
				face leftEdge == oldEdge
					ifTrue:[face leftEdge: edge]
					ifFalse:[face rightEdge: edge].
				edge rightFace: face.
				^edge
			].
	].
	"Need to add new edge.
	NOTE: index already points to the right point for insertion."
	minorEdge _ B3DPrimitiveEdge new.
	minorEdge v0: face vertex1 v1: face vertex2.
	minorEdge nLines = 0 ifTrue:[^self]. "Horizontal"
	"Adjust left/right edge of the face"
	face leftEdge == oldEdge
		ifTrue:[face leftEdge: minorEdge]
		ifFalse:[face rightEdge: minorEdge].
	minorEdge leftFace: face.
	minorEdge initializePass1.
	added add: minorEdge beforeIndex: index.
	^minorEdge! !

!B3DScanner methodsFor: 'aet adding' stamp: 'ar 4/8/1999 03:02'!
adjustFace: face major: majorEdge minor: minorEdge
	"Set the left/right edge of the face to the appropriate edges"
	(majorEdge == nil or:[minorEdge == nil]) 
		ifTrue:[^self error:'Edges must be non-nil'].
	majorEdge xValue = minorEdge xValue ifTrue:[
		"Most likely case. Both edges start at the same point.
		Use dx/dy slope for determining which one is left and which one is right.
		NOTE: 	We have this already computed during face>>initializePass1.
				The value to use is the x increment at each scan line.
		NOTE2: 	There is also a border case when minorEdge is actually the lower
				edge of the triangle. If both xValues are equal, then the triangle
				is degenerate (e.g., it's area is zero) in which case the meaning of
				'left' or 'right' does not matter at all (and can thus be handled
				by this simple test)."
		majorEdge xIncrement <= minorEdge xIncrement
			ifTrue:[	face leftEdge: majorEdge.
					face rightEdge: minorEdge]
			ifFalse:[	face leftEdge: minorEdge.
					face rightEdge: majorEdge].
	] ifFalse:[
		"If the x values are not equal, simply use the edge with the smaller x value as 'left' edge"
		majorEdge xValue < minorEdge xValue 
			ifTrue:[	face leftEdge: majorEdge.
					face rightEdge: minorEdge]
			ifFalse:[	face leftEdge: minorEdge.
					face rightEdge: majorEdge].
	].! !


!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/18/1999 05:57'!
adjustIntersectionsAt: yValue from: topEdge
	"The top face has changed. Adjust for possible intersections in the same scan line."
	| frontFace backFace |
	frontFace _ fillList first.

	"If frontFace is nil then the fillList is empty.
	If frontFace nextFace is nil then there is only one face in the list."
	(frontFace == nil or:[frontFace nextFace == nil]) ifTrue:[^self].

	"Now, search the fill list until we reach the first face with minZ > face maxZ.
	Note that we have a linked list and can thus start from frontFace nextFace 
	until we reach the end of the face list (nil)."
	backFace _ frontFace nextFace.
	[backFace == nil] whileFalse:[
		(self checkIntersectionOf: frontFace with: backFace at: yValue edge: topEdge)
			ifFalse:[^self]. "Aborted."
		backFace _ backFace nextFace.
	].! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/13/1999 01:00'!
checkIntersectionOf: frontFace with: backFace at: yValue edge: leftEdge
	"Compute the possible intersection of frontFace and backFace at the given y value.
	Store the earliest intersection in nextIntersection. Return false if the face enumeration
	should be aborted, true otherwise. leftEdge is the edge defining the left-most boundary
	for possible intersections (e.g., all intersections have to be >= leftEdge xValue)"
	| floatX floatY frontZ backZ xValue rightX |
	backFace minZ >= frontFace maxZ ifTrue:[^false]. "Abort. Everything behind will be further away."
	"Check for shared edge of faces"
	frontFace leftEdge == backFace leftEdge ifTrue:[^true]. "Proceed."
	frontFace rightEdge == backFace rightEdge ifTrue:[^true]. "Proceed."

	"Check for newly created front face"
	(frontFace leftEdge xValue bitShift: -12) = 
		(frontFace rightEdge xValue bitShift: -12) ifTrue:[^false]. "Abort"
	"Check for newly created back face"
	(backFace leftEdge xValue bitShift: -12) = 
		(backFace rightEdge xValue bitShift: -12) ifTrue:[^true]. "Proceed"

	"Compute the z value of either frontFace or backFace depending on whose
	right edge x value is less (so we test a point that is inside both faces)"
	floatY _ yValue.
	frontFace rightEdge xValue <= backFace rightEdge xValue ifTrue:[
		"Use frontFace rightEdge as reference value"
		frontZ _ frontFace rightEdge zValue.
		rightX _ frontFace rightEdge xValue.
		floatX _ rightX / 4096.0.
		backZ _ backFace zValueAtX: floatX y: floatY.
	] ifFalse:[
		"Use backFace rightEdge as reference value"
		backZ _ backFace rightEdge zValue.
		rightX _ backFace rightEdge xValue.
		floatX _ rightX / 4096.0.
		frontZ _ frontFace zValueAtX: floatX y: floatY.
	].
	backZ < frontZ ifTrue:[
		"Found a possible intersection."
		xValue _ self computeIntersectionOf: frontFace with: backFace at: yValue ifError: leftEdge xValue.
		"The following tests for numerical inaccuracies"
		xValue > rightX ifTrue:[xValue _ rightX].
		xValue < leftEdge xValue ifTrue:[
			"In theory, this cannot happen. We may, however, have slight
			numerical inaccuracies here, too. Conceptually, we treat these
			intersections as if they occured immediately at the same 
			fractional pixel in the scan line."
			xValue _ leftEdge xValue].
		(xValue bitShift: -12) = (leftEdge xValue bitShift: -12) ifTrue:[
			"Intersections at the same pixel are ignored. Process it at the next pixel.
			NOTE: This step is incredibly important!! It is by ignoring intersections
			at the same pixel that we can never run in an endless repetition of
			intersections at the same pixel value."
			xValue _ (leftEdge xValue bitShift: -12) + 1 bitShift: 12.
		].
		xValue < nextIntersection xValue ifTrue:[
			nextIntersection xValue: xValue.
			nextIntersection leftFace: frontFace.
			nextIntersection rightFace: backFace.
		].
	].
	^true "proceed"! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/8/1999 03:14'!
computeIntersectionOf: frontFace with: backFace at: yValue ifError: errorValue
	"Compute the z intersection at the given y value"
	| dx1 dz1 dx2 dz2 px pz det det2 |
	dx1 _ frontFace rightEdge xValue - frontFace leftEdge xValue.
	dz1 _ frontFace rightEdge zValue - frontFace leftEdge zValue.
	dx2 _ backFace rightEdge xValue - backFace leftEdge xValue.
	dz2 _ backFace rightEdge zValue - backFace leftEdge zValue.
	px _ backFace leftEdge xValue - frontFace leftEdge xValue.
	pz _ backFace leftEdge zValue - frontFace leftEdge zValue.
	"Solve the linear equation using cramers rule"
	det _ (dx1 * dz2) - (dx2 * dz1).
	det = 0.0 ifTrue:[^errorValue].
	"det1 _ (dx1 * pz) - (px * dz1)."
	det2 _ (px * dz2) - (pz * dx2).
	"det1 _ det1 / det."
	det2 _ det2 / det.
	^frontFace leftEdge xValue + (dx1 * det2) truncated! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/8/1999 03:15'!
isOnTop: edge at: yValue
	"Return true if the edge is on top of the current front face"
	| topFace floatX floatY |
	topFace _ fillList first.
	topFace == nil ifTrue:[^true].
	"Note: It is important to return true if the edge is shared by the top face"
	(edge leftFace == topFace or:[edge rightFace == topFace]) ifTrue:[^true].
	floatX _ edge xValue / 4096.0.
	floatY _ yValue.
	^edge zValue < (fillList first zValueAtX: floatX y:  floatY).! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/18/1999 07:23'!
scanAETAt: yValue
	"Scan out and draw the active edge table"
	| leftEdge rightEdge tmp |
	aet reset.
	aet atEnd ifTrue:[^nil].

	"Note the following is debug code that allows restarting this method
	without getting confused by the face flags. In release mode, having
	faces in the fillList here would be either an error or due to clipping
	at the right boundary."
	fillList do:[:face| face flags: (face flags bitXor: FlagFaceActive)].
	fillList reset.

	nextIntersection xValue: 16r3FFFFFFF. "Out of reach"
	leftEdge _ aet next.
	"No do the AET scan"
	[aet atEnd] whileFalse:[
		"The left edge here is always a top edge. Toggle its fills."
		self toggleTopFillsOf: leftEdge at: yValue.
		"After we got a new top face we have to adjust possible intersections."
		self adjustIntersectionsAt: yValue from: leftEdge. 
		"Search for the next top edge, which will be the right boundary."
		rightEdge _ self searchForNewTopEdgeFrom: leftEdge at: yValue.
		"And fill the stuff"
		self fillFrom: leftEdge to: rightEdge at: yValue.

		leftEdge _ rightEdge.
		"Use a new intersection edge if necessary"
		leftEdge == nextIntersection ifTrue:[
			tmp _ nextIntersection.
			nextIntersection _ lastIntersection.
			lastIntersection _ tmp].
		nextIntersection xValue: 16r3FFFFFFF "Must be waaaay off to the right ;-)"
	].
	self toggleBackFillsOf: leftEdge at: yValue validate: false.
	fillList isEmpty ifFalse:[self error:'FillList not empty'].! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/18/1999 05:59'!
searchForNewTopEdgeFrom: leftEdge at: yValue
	"Find the next top edge in the AET. 
	Note: We have to make sure that intersection edges are returned appropriately."
	| edge topFace |
	topFace _ fillList first.
	topFace == nil ifTrue:[^aet next]. "Next edge must be top"
	[aet atEnd] whileFalse:[
		"Check if we have an intersection first."
		nextIntersection xValue <= aet peek xValue ifTrue:[^nextIntersection].
		edge _ aet next.
		"Check if the edge is on top"
		(self isOnTop: edge at: yValue) ifTrue:[^edge].
		"If the edge is not on top, toggle the (back) fills of it"
		self toggleBackFillsOf: edge at: yValue validate: true.
	].
	^nil! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/7/1999 04:40'!
toggleBackFillsOf: edge at: yValue validate: aBool
	"Toggle the faces of the (back) edge"
	| face |
	face _ edge leftFace.
	(face flags anyMask: FlagFaceActive)
		ifTrue:[	(aBool and:[face == fillList first]) ifTrue:[self error:'Not a back face'].
				fillList remove: face]
		ifFalse:[	fillList addBack: face.
				"Check for possible intersections of back and front face"
				self checkIntersectionOf: fillList first
					with: face at: yValue edge: edge].
	face flags: (face flags bitXor: FlagFaceActive).
	face _ edge rightFace.
	face == nil ifTrue:[^self].
	(face flags anyMask: FlagFaceActive)
		ifTrue:[	(aBool and:[face == fillList first]) ifTrue:[self error:'Not a back face'].
				fillList remove: face]
		ifFalse:[	fillList addBack: face.
				"Check for possible intersections of back and front face"
				self checkIntersectionOf: fillList first
					with: face at: yValue edge: edge].
	face flags: (face flags bitXor: FlagFaceActive).
! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/5/1999 23:44'!
toggleIntersectionEdge: edge
	"Toggle the faces of the given intersection edge.
	This is a *very* special case."
	fillList first == edge leftFace ifFalse:[^self error:'Left face of intersection edge not top face'].
	fillList remove: edge rightFace.
	fillList addFront: edge rightFace. ! !

!B3DScanner methodsFor: 'aet scanning' stamp: 'ar 4/18/1999 06:01'!
toggleTopFillsOf: edge at: yValue
	"Toggle the faces of the (new top) edge.
	We must carefully treat each of the following cases:
		1) rightFace notNil (e.g., two faces)
			a) rightFace active ~= leftFace active
				=> simply swap leftFace and rightFace in the face list
			b) rightFace active not & leftFace active not
				=> edge defines new boundary entry; check for minimal dxdz and insert in order
			c) rightFace active & leftFace active
				=> edge defines boundary exit; search all faces for minimal z value
		2) rightFace isNil (e.g., single face)
			a) leftFace active
				=> edge defines boundary exit; see 1c)
			b) leftFace active not
				=> edge defines boundary entry; simply put it on top.
	"
	| leftFace rightFace xorMask noTest |
	edge == lastIntersection 
		ifTrue:[^self toggleIntersectionEdge: edge].
	noTest _ true.
	leftFace _ edge leftFace.
	rightFace _ edge rightFace.
	rightFace == nil ifTrue:[
		(leftFace flags anyMask: FlagFaceActive)
			ifTrue:[	leftFace == fillList first | noTest ifFalse:[self error:'Oops'].
					fillList remove: leftFace.
					fillList searchForNewTopAtX: edge xValue y: yValue]
			ifFalse:[	fillList addFront: leftFace].
		leftFace flags: (leftFace flags bitXor: FlagFaceActive).
		^self].
	"rightFace notNil"
	xorMask _ leftFace flags bitXor: rightFace flags.
	(xorMask anyMask: FlagFaceActive) ifTrue:[
		"Simply swap"
		(leftFace flags anyMask: FlagFaceActive)
			ifTrue:[	leftFace == fillList first | noTest ifFalse:[self error:'Oops'].
					fillList remove: leftFace.
					fillList addFront: rightFace]
			ifFalse:[	rightFace == fillList first | noTest ifFalse:[self error:'Oops'].
					fillList remove: rightFace.
					fillList addFront: leftFace].
	] ifFalse:["rightFace active = leftFace active"
		(leftFace flags anyMask: FlagFaceActive) ifTrue:[
			(leftFace == fillList or:[rightFace == fillList first]) | noTest ifFalse:[self error:'Oops'].
			fillList remove: leftFace.
			fillList remove: rightFace.
			fillList searchForNewTopAtX: edge xValue y: yValue.
		] ifFalse:[
			leftFace dzdx <= rightFace dzdx
				ifTrue:[	fillList addFront: leftFace.
						fillList addBack: rightFace]
				ifFalse:[	fillList addFront: rightFace.
						fillList addBack: leftFace].
		].
	].
	leftFace flags: (leftFace flags bitXor: FlagFaceActive).
	rightFace flags: (rightFace flags bitXor: FlagFaceActive).
! !


!B3DScanner methodsFor: 'aet updating' stamp: 'ar 4/18/1999 06:02'!
updateAETAt: yValue
	"Advance all entries in the AET by one scan line step"
	| edge count |
	aet reset.
	[aet atEnd] whileFalse:[
		edge _ aet next.
		count _ edge nLines - 1.
		count = 0 ifTrue:[
			"Remove the edge from the AET.
			If the continuation flag is set, create new (lower) edge(s)."
			(edge vertex1 windowPosY bitShift: -12) = yValue
				ifFalse:[self error:'Edge exceeds range'].
			aet removeFirst.
			(edge flags anyMask: FlagContinueLeftEdge)
				ifTrue:[self addLowerEdge: edge fromFace: edge leftFace].
			(edge flags anyMask: FlagContinueRightEdge) 
				ifTrue:[self addLowerEdge: edge fromFace: edge rightFace].
			(edge flags anyMask: FlagEdgeLeftMajor)
				ifTrue:[nFaces _ nFaces - 1].
			(edge flags anyMask: FlagEdgeRightMajor)
				ifTrue:[nFaces _ nFaces - 1].
		] ifFalse:[
			"Edge continues. Adjust the number of scan lines remaining
			and update the incremental values. Make sure that the sorting
			order of the AET is not getting confused."
			edge nLines: count. "# of scan lines"
			edge stepToNextLine. "update incremental values"
			aet resortFirst. "make sure edge is sorted right"
		].
	].
! !


!B3DScanner methodsFor: 'span drawing' stamp: 'ar 4/18/1999 05:45'!
clearSpanBufferAt: yValue
	spanBuffer primFill: 0.! !

!B3DScanner methodsFor: 'span drawing' stamp: 'ar 4/18/1999 06:46'!
drawSpanBufferAt: yValue
	| leftX rightX |
	leftX _ aet first xValue bitShift: -12.
	rightX _ aet last xValue bitShift: -12.
	bitBlt copyBitsFrom: leftX to: rightX at: yValue.! !

!B3DScanner methodsFor: 'span drawing' stamp: 'ar 4/18/1999 06:55'!
fillFrom: leftEdge to: rightEdge at: yValue
	| face |
	leftEdge xValue >= rightEdge xValue ifTrue:[^self]. "Nothing to do"
	face _ fillList first.
	face == nil ifTrue:[^self].
	face texture == nil
		ifTrue:[self rgbFill: face from: leftEdge to: rightEdge at: yValue]
		ifFalse:[self rgbstwFill: face from: leftEdge to: rightEdge at: yValue]! !

!B3DScanner methodsFor: 'span drawing' stamp: 'ar 4/18/1999 06:48'!
rgbFill: face from: leftEdge to: rightEdge at: yValue
	"Using only RGB (no alpha no textures)"
	| leftX rightX floatY floatX rValue gValue bValue pv rAttr gAttr bAttr |
	"Note: We always sample at pixel centers.
	If the edges do not include this pixel center, do nothing.
	Otherwise fill from leftX to rightX, including both pixels."
	leftX _ (leftEdge xValue bitShift: -12) + 1.
	rightX _ rightEdge xValue bitShift: -12.
	leftX < 0 ifTrue:[leftX _ 0].
	rightX >= spanBuffer size ifTrue:[rightX _ spanBuffer size-1].
	leftX > rightX ifTrue:[^self].

	B3DScanner doDebug ifTrue:[
		"Sanity check."
		(face leftEdge xValue > leftEdge xValue)
			ifTrue:[
				(face rightEdge xValue < rightEdge xValue)
					ifTrue:[self error:'Filling outside face']
					ifFalse:[self error:'Filling left of face'].
		] ifFalse:[(face rightEdge xValue < rightEdge xValue)
						ifTrue:[self error:'Filling right of face']].
	].

	(face flags anyMask: FlagFaceInitialized) ifFalse:[
		face initializePass2.
		face flags: (face flags bitOr: FlagFaceInitialized)].

	"@@: Sampling problem!!"
	floatY _ yValue + 0.5.
	floatX _ leftX.

	rAttr _ face attributes.
	gAttr _ rAttr nextAttr.
	bAttr _ gAttr nextAttr.

	rValue _ (face attrValue: rAttr atX: floatX y: floatY).
	gValue _ (face attrValue: gAttr atX: floatX y: floatY).
	bValue _ (face attrValue: bAttr atX: floatX y: floatY).

	[leftX <= rightX] whileTrue:[
		rValue _ rValue min: 255.0 max: 0.0.
		gValue _ gValue min: 255.0 max: 0.0.
		bValue _ bValue min: 255.0 max: 0.0.

		pv _ (bValue truncated) +
				(gValue truncated bitShift: 8) +
					(rValue truncated bitShift: 16).
		spanBuffer at: (leftX _ leftX+1) put: (pv bitOr: 4278190080).
		rValue _ rValue + rAttr dvdx.
		gValue _ gValue + gAttr dvdx.
		bValue _ bValue + bAttr dvdx].
! !

!B3DScanner methodsFor: 'span drawing' stamp: 'ar 4/18/1999 07:22'!
rgbstwFill: face from: leftEdge to: rightEdge at: yValue
	"Using only RGB & STW (no alpha)"
	| leftX rightX floatY floatX rValue gValue bValue pv rAttr gAttr bAttr aAttr wAttr sAttr tAttr wValue sValue tValue texColor |
	"Note: We always sample at pixel centers.
	If the edges do not include this pixel center, do nothing.
	Otherwise fill from leftX to rightX, including both pixels."
	leftX _ (leftEdge xValue bitShift: -12) + 1.
	rightX _ rightEdge xValue bitShift: -12.
	leftX < 0 ifTrue:[leftX _ 0].
	rightX >= spanBuffer size ifTrue:[rightX _ spanBuffer size-1].
	leftX > rightX ifTrue:[^self].
	B3DScanner doDebug ifTrue:[
		"Sanity check."
		(face leftEdge xValue > leftEdge xValue)
			ifTrue:[
				(face rightEdge xValue < rightEdge xValue)
					ifTrue:[self error:'Filling outside face']
					ifFalse:[self error:'Filling left of face'].
		] ifFalse:[(face rightEdge xValue < rightEdge xValue)
						ifTrue:[self error:'Filling right of face']].
	].

	(face flags anyMask: FlagFaceInitialized) ifFalse:[
		face initializePass2.
		face flags: (face flags bitOr: FlagFaceInitialized)].

	"@@: Sampling problem!!"
	floatY _ yValue + 0.5.
	floatX _ leftX.

	rAttr _ face attributes.
	gAttr _ rAttr nextAttr.
	bAttr _ gAttr nextAttr.
	aAttr _ bAttr nextAttr.
	wAttr _ aAttr nextAttr.
	sAttr _ wAttr nextAttr.
	tAttr _ sAttr nextAttr.

	rValue _ (face attrValue: rAttr atX: floatX y: floatY).
	gValue _ (face attrValue: gAttr atX: floatX y: floatY).
	bValue _ (face attrValue: bAttr atX: floatX y: floatY).
	wValue _ (face attrValue: wAttr atX: floatX y: floatY).
	sValue _ (face attrValue: sAttr atX: floatX y: floatY).
	tValue _ (face attrValue: tAttr atX: floatX y: floatY).

	[leftX <= rightX] whileTrue:[
		rValue _ rValue min: 255.0 max: 0.0.
		gValue _ gValue min: 255.0 max: 0.0.
		bValue _ bValue min: 255.0 max: 0.0.

		texColor _ self textureColor: face texture atS: (sValue / wValue) atT: (tValue / wValue).

		pv _ (bValue * texColor blue) truncated +
				((gValue * texColor green) truncated bitShift: 8) +
					((rValue * texColor red) truncated bitShift: 16).
		spanBuffer at: (leftX _ leftX+1) put: (pv bitOr: 4278190080).
		rValue _ rValue + rAttr dvdx.
		gValue _ gValue + gAttr dvdx.
		bValue _ bValue + bAttr dvdx.
		wValue _ wValue + wAttr dvdx.
		sValue _ sValue + sAttr dvdx.
		tValue _ tValue + tAttr dvdx].! !

!B3DScanner methodsFor: 'span drawing' stamp: 'ar 5/28/2000 12:19'!
textureColor: aTexture atS: sValue atT: tValue
	"Return the interpolated color of the given texture at s/t"
	| w h fragS fragT sIndex tIndex peeker tex00 tex01 tex10 tex11 sFrac tFrac mixed |
	w _ aTexture width.
	h _ aTexture height.
	fragS _ w * sValue.
	fragT _ h * tValue.
	sIndex _ fragS truncated.
	tIndex _ fragT truncated.
	peeker _ BitBlt current bitPeekerFromForm: aTexture.
	tex00 _ (peeker pixelAt: (sIndex \\ w)@(tIndex \\ h)) asColorOfDepth: aTexture depth.
	tex01 _ (peeker pixelAt: (sIndex+1 \\ w)@(tIndex \\ h)) asColorOfDepth: aTexture depth.
	tex10 _ (peeker pixelAt: (sIndex \\ w)@(tIndex+1 \\ h)) asColorOfDepth: aTexture depth.
	tex11 _ (peeker pixelAt: (sIndex+1 \\ w)@(tIndex+1 \\ h)) asColorOfDepth: aTexture depth.
	sFrac _ fragS \\ 1.0.
	tFrac _ fragT \\ 1.0.
	mixed _ ((1.0 - tFrac) * (((1.0 - sFrac) * tex00 asB3DColor) + (sFrac * tex01 asB3DColor))) +
			(tFrac * (((1.0 - sFrac) * tex10 asB3DColor) + (sFrac * tex11 asB3DColor))).
	^mixed! !


!B3DScanner methodsFor: 'misc' stamp: 'ar 4/6/1999 03:49'!
validateAETOrder
	| last next |
	aet isEmpty ifTrue:[^self].
	aet reset.
	last _ aet next.
	[aet atEnd] whileFalse:[
		next _ aet next.
		last xValue <= next xValue ifFalse:[^self error:'AET is broken'].
		last _ next].! !

!B3DScanner methodsFor: 'misc' stamp: 'ar 4/7/1999 05:20'!
validateEdgesFrom: aCollection
	"aCollection must contain two entries for each face."
	| faceNum face faces |
	faceNum _ 0.
	aCollection do:[:edge|
		edge leftFace ifNil:[self error:'Bad edge'] ifNotNil:[faceNum _ faceNum + 1].
		edge rightFace ifNotNil:[faceNum _ faceNum + 1].
	].
	faceNum \\ 2 = 0 ifTrue:[^self].
	faces _ Bag new.
	aCollection do:[:edge|
		face _ edge leftFace.
		faces add: face.
		(aet indexOf: face leftEdge) = 0 ifTrue:[self error:'Left edge not in AET'].
		(aet indexOf: face rightEdge) = 0 ifTrue:[self error:'Right edge not in AET'].
		face _ edge rightFace.
		face == nil ifFalse:[
			faces add: face.
			(aet indexOf: face leftEdge) = 0 ifTrue:[self error:'Left edge not in AET'].
			(aet indexOf: face rightEdge) = 0 ifTrue:[self error:'Right edge not in AET'].
		].
	].
	self error:'Something *IS* wrong here'.! !

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

B3DScanner class
	instanceVariableNames: ''!

!B3DScanner class methodsFor: 'class initialization' stamp: 'ar 4/8/1999 18:30'!
initialize
	"B3DScanner initialize"
	FlagContinueLeftEdge _ 1.
	FlagContinueRightEdge _ 2.
	FlagEdgeLeftMajor _ 4.
	FlagEdgeRightMajor _ 8.
	FlagFaceActive _ 1.
	FlagFaceInitialized _ 2.! !


!B3DScanner class methodsFor: 'instance creation' stamp: 'ar 4/4/1999 04:27'!
new
	^super new initialize! !


!B3DScanner class methodsFor: 'accessing' stamp: 'ar 4/18/1999 07:24'!
doDebug
	^DebugMode == true! !

!B3DScanner class methodsFor: 'accessing' stamp: 'ar 4/18/1999 07:25'!
doDebug: aBool
	"B3DScanner doDebug: true"
	"B3DScanner doDebug: false"
	DebugMode _ aBool.! !
Object subclass: #B3DScene
	instanceVariableNames: 'box objects cameras lights materials defaultCamera clearColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Objects'!

!B3DScene methodsFor: 'initialize' stamp: 'ti 3/28/2000 13:14'!
from3DS: aDictionary
	"Remove the globals from the scene - the remaining objects are
	name->sceneObject "
	| globals constants ambient texture funkyNormals r1 |
	globals _ aDictionary at: #globals.
	constants _ globals at: #constants ifAbsent: [Dictionary new].
	aDictionary removeKey: #globals.
	"Collect the scene objects and assign the names"
	objects _ OrderedCollection new.
	aDictionary associationsDo: [:assoc | objects add: ((B3DSceneObject
from3DS: assoc value)
				name: assoc key)].
	"Fetch the cameras and set a default camera"
	cameras _ globals at: #cameras.
	cameras isEmpty
		ifTrue: [defaultCamera _ B3DCamera new position: 0 @ 0 @ 0]
		ifFalse: [defaultCamera _ cameras at: cameras keys
asSortedCollection first].
	"Fetch the lights"
	lights _ globals at: #lights.
	"Add the ambient light if possible.
	Note: The name $AMBIENT$ is used in the keyframe section of the 3DS
	file. "
	ambient _ constants at: 'ambientColor'
				ifAbsent: [B3DColor4
						r: 0.0
						g: 0.0
						b: 0.0
						a: 0.0].
	ambient ifNotNil: [lights at: '$AMBIENT$' put: (B3DAmbientLight
color: ambient)].
	"Fetch the background color"
	clearColor _ constants at: 'backgroundColor' ifAbsent: [Color white].
	"Fetch the materials and replace names in sceneObjects by actual
	materials "
	materials _ globals at: #materials.
	"Compute the per vertex normals"
	funkyNormals _ self confirm: 'Do you want funky normals instead of
accurate normals?
(It will give the model a somewhat strange, but interesting look)'.
	'Computing vertex normals'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: objects size
		during: [:bar | objects
				doWithIndex:
					[:obj :index |
					bar value: index.
					obj material ifNotNil: [obj
material: (materials at: obj material ifAbsent: [])].
					funkyNormals
						ifTrue: [obj geometry
computeFunkyVertexNormals]
						ifFalse: [obj geometry
vertexNormals]]].
	(self confirm: 'Do you want to use a texture with the model?')
		ifTrue:
			[Utilities informUser: 'Choose a rectangle with
interesting stuff'
				during:
					[r1 _ Rectangle originFromUser: 128
@ 128.
					Sensor waitNoButton].
			texture _ B3DTexture fromDisplay: r1.
			texture wrap: true.
			texture interpolate: false.
			texture envMode: 0].
	objects do: [:obj | obj texture ifNotNil: [obj texture: texture]]! !

!B3DScene methodsFor: 'initialize' stamp: 'ar 2/17/1999 05:09'!
initialize
	objects _ OrderedCollection new.
	cameras _ OrderedCollection new.
	lights _ OrderedCollection new.
	materials _OrderedCollection new.
! !

!B3DScene methodsFor: 'initialize' stamp: 'ti 3/28/2000 13:11'!
withoutQuestionsFrom3DS: aDictionary
	"Remove the globals from the scene - the remaining objects are
	name->sceneObject "
	| globals constants ambient texture funkyNormals |
	globals _ aDictionary at: #globals.
	constants _ globals at: #constants ifAbsent: [Dictionary new].
	aDictionary removeKey: #globals.
	"Collect the scene objects and assign the names"
	objects _ OrderedCollection new.
	aDictionary associationsDo: [:assoc | objects add: ((B3DSceneObject
from3DS: assoc value)
				name: assoc key)].
	"Fetch the cameras and set a default camera"
	cameras _ globals at: #cameras.
	cameras isEmpty
		ifTrue: [defaultCamera _ B3DCamera new position: 0 @ 0 @ 0]
		ifFalse: [defaultCamera _ cameras at: cameras keys
asSortedCollection first].
	"Fetch the lights"
	lights _ globals at: #lights.
	"Add the ambient light if possible.
	Note: The name $AMBIENT$ is used in the keyframe section of the 3DS
	file. "
	ambient _ constants at: 'ambientColor'
				ifAbsent: [B3DColor4
						r: 0.0
						g: 0.0
						b: 0.0
						a: 0.0].
	ambient ifNotNil: [lights at: '$AMBIENT$' put: (B3DAmbientLight
color: ambient)].
	"Fetch the background color"
	clearColor _ constants at: 'backgroundColor' ifAbsent: [Color white].
	"Fetch the materials and replace names in sceneObjects by actual
	materials "
	materials _ globals at: #materials.
	"Compute the per vertex normals"
	funkyNormals _ false.
	'Computing vertex normals'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: objects size
		during: [:bar | objects
				doWithIndex:
					[:obj :index |
					bar value: index.
					obj material ifNotNil: [obj
material: (materials at: obj material ifAbsent: [])].
					funkyNormals
						ifTrue: [obj geometry
computeFunkyVertexNormals]
						ifFalse: [obj geometry
vertexNormals]]].
	objects do: [:obj | obj texture ifNotNil: [obj texture: texture]]! !


!B3DScene methodsFor: 'accessing' stamp: 'ar 2/15/1999 01:01'!
boundingBox
	|bBox|
	box ifNotNil:[^box].
	bBox _ nil.
	objects do:[:obj|
		bBox _ bBox ifNil:[obj boundingBox] ifNotNil:[bBox merge: obj boundingBox]
	].
	^box _ bBox! !

!B3DScene methodsFor: 'accessing' stamp: 'ti 3/21/2000 11:57'!
cameras
	^cameras! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:44'!
clearColor
	^clearColor! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:44'!
clearColor: aColor
	clearColor _ aColor! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/15/1999 05:29'!
defaultCamera
	^defaultCamera! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/17/1999 05:08'!
defaultCamera: aCamera
	defaultCamera _ aCamera.! !

!B3DScene methodsFor: 'accessing' stamp: 'jsp 3/1/1999 10:46'!
lights
	^lights! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/17/1999 05:14'!
objects
	^objects! !

!B3DScene methodsFor: 'accessing' stamp: 'ar 2/17/1999 05:14'!
objects: aCollection
	objects _ aCollection! !


!B3DScene methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:24'!
render
	| b3d |
	b3d _ (B3DRenderEngine defaultForPlatformOn: Display).
	b3d viewport: (0@0 extent: 600@600).
	clearColor ifNotNil:[b3d clearViewport: clearColor].
	b3d clearDepthBuffer.
	"b3d addLight: (B3DAmbientLight color: Color white)."
	self renderOn: b3d.
	b3d finish.
	b3d destroy.! !

!B3DScene methodsFor: 'displaying' stamp: 'ar 2/16/1999 05:58'!
renderOn: aRenderer
	defaultCamera ifNotNil:[
		defaultCamera setClippingPlanesFrom: self.
		defaultCamera aspectRatio: aRenderer viewport aspectRatio.
		defaultCamera renderOn: aRenderer].
	lights do:[:light| aRenderer addLight: light].
	objects do:[:obj| obj renderOn: aRenderer].! !

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

B3DScene class
	instanceVariableNames: ''!

!B3DScene class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 23:59'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !

!B3DScene class methodsFor: 'instance creation' stamp: 'ar 2/17/1999 05:14'!
new
	^super new initialize! !

!B3DScene class methodsFor: 'instance creation' stamp: 'ti 3/21/2000 15:05'!
withoutQuestionsFrom3DS: aDictionary
	^self new withoutQuestionsFrom3DS: aDictionary! !
BorderedMorph subclass: #B3DSceneExplorerMorph
	instanceVariableNames: 'wheels frameWidth b3DSceneMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!
!B3DSceneExplorerMorph commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!B3DSceneExplorerMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 17:16'!
scene
	^b3DSceneMorph scene! !

!B3DSceneExplorerMorph methodsFor: 'accessing' stamp: 'ti 3/24/2000 17:04'!
scene: aScene
	b3DSceneMorph scene: aScene.! !


!B3DSceneExplorerMorph methodsFor: 'actions'!
openThreeDSFile
	| menu result newFileString myScene |
	menu := StandardFileMenu oldFileMenu: (FileDirectory default) withPattern: '*.3ds'.
	result := menu startUpWithCaption: 'Select 3DS model file ...'.
	result ifNotNil: [	
		newFileString := (result directory pathName),(result directory pathNameDelimiter asString),(result name).
		myScene := (B3DScene withoutQuestionsFrom3DS: (ThreeDSParser parseFileNamed: newFileString)).
		self scene: myScene].! !

!B3DSceneExplorerMorph methodsFor: 'actions'!
selectNewCamera
	| menu sel |
	((self scene cameras isNil) or: [self scene cameras size = 0]) ifTrue: [
		(SelectionMenu selections: #('OK'))
			startUpWithCaption: 'No cameras defined!!'.
		^self].
	menu _ SelectionMenu
		selections: self scene cameras keys asArray.
	sel := menu startUp.
	sel ifNotNil: [
		self scene defaultCamera: (self scene cameras at: sel) copy.
		b3DSceneMorph updateUpVectorForCamera: self scene defaultCamera.
		self changed.]! !

!B3DSceneExplorerMorph methodsFor: 'actions' stamp: 'ti 3/21/2000 14:28'!
selectNewCamera: aCameraString
	aCameraString ifNotNil: [
		self scene defaultCamera: (self scene cameras at: aCameraString) copy.
		self updateUpVectorForCamera: self scene defaultCamera.
		self changed.]! !

!B3DSceneExplorerMorph methodsFor: 'actions'!
switchHeadLightStatus
	b3DSceneMorph switchHeadLightStatus! !

!B3DSceneExplorerMorph methodsFor: 'actions' stamp: 'ti 3/24/2000 17:04'!
switchRotationStatus
	b3DSceneMorph switchRotationStatus! !


!B3DSceneExplorerMorph methodsFor: 'change reporting' stamp: 'ti 3/24/2000 17:11'!
layoutChanged
	| ctrl |
	super layoutChanged.

	b3DSceneMorph ifNil: [^self].
	b3DSceneMorph extent: (self extent - ((frameWidth * 2)@(frameWidth * 2))).
	b3DSceneMorph position: (self bounds origin + ((frameWidth)@(frameWidth))).

	wheels ifNil: [^self].
	wheels isEmpty ifTrue: [^self].

	ctrl := wheels at: #fov ifAbsent: [nil].
	ctrl ifNotNil: [
		ctrl position:
			self bounds corner -
				ctrl extent - 
				(frameWidth@((frameWidth - ctrl extent y) / 2) rounded)].

	ctrl := wheels at: #dolly ifAbsent: [nil].
	ctrl ifNotNil: [
		ctrl position:
			self bounds corner -
				ctrl extent - 
				((((frameWidth - ctrl extent x) / 2) rounded)@frameWidth)].

	ctrl := wheels at: #rotX ifAbsent: [nil].
	ctrl ifNotNil: [
		ctrl position:
			(self bounds origin x + (((frameWidth - ctrl extent x) / 2) rounded))@(self bounds corner y - ctrl extent y - frameWidth)].

	ctrl := wheels at: #rotY ifAbsent: [nil].
	ctrl ifNotNil: [
		ctrl position:
			(self bounds origin x + frameWidth)@(self bounds corner y - ctrl extent y - (((frameWidth - ctrl extent y) / 2) rounded))].

	ctrl := wheels at: #rotZ ifAbsent: [nil].
	ctrl ifNotNil: [
		ctrl position:
			self bounds origin +
			((((frameWidth - ctrl extent x) / 2) rounded)@frameWidth)].! !


!B3DSceneExplorerMorph methodsFor: 'drawing' stamp: 'ti 3/24/2000 17:27'!
drawOn: aCanvas
	super drawOn: aCanvas.
	aCanvas fillRectangle: (self bounds insetBy: frameWidth) color: Color black.! !


!B3DSceneExplorerMorph methodsFor: 'event handling' stamp: 'ti 3/24/2000 17:13'!
handlesMouseDown: evt
	^evt yellowButtonPressed
! !

!B3DSceneExplorerMorph methodsFor: 'event handling' stamp: 'ti 3/24/2000 17:14'!
mouseDown: evt
	evt yellowButtonPressed ifTrue: [
		self yellowButtonMenu.
		^super mouseDown: evt].! !


!B3DSceneExplorerMorph methodsFor: 'initialization' stamp: 'ti 3/24/2000 17:23'!
initialize
	| ctrl |
	super initialize.
	self extent: 300@300.
	self borderRaised.
	color := Color gray: 0.8.
	frameWidth := 25.

	b3DSceneMorph := AdvancedB3DSceneMorph new.
	self addMorphFront: b3DSceneMorph.
	
	wheels := Dictionary new.
	ctrl := WheelMorph new.
	ctrl target: b3DSceneMorph.
	ctrl actionSelector: #addFovAngle:.
	ctrl factor: -0.07.
	ctrl setBalloonText: 'FOV'.
	self addMorphFront: ctrl.
	wheels at: #fov put: ctrl.

	ctrl := WheelMorph new.
	ctrl target: b3DSceneMorph.
	ctrl actionSelector: #addDolly:.
	ctrl factor: 0.005.
	ctrl beVertical.
	ctrl setBalloonText: 'Dolly'.
	self addMorphFront: ctrl.
	wheels at: #dolly put: ctrl.

	ctrl := WheelMorph new.
	ctrl target: b3DSceneMorph.
	ctrl actionSelector: #rotateZ:.
	ctrl beVertical.
	ctrl setBalloonText: 'z Axis'.
	self addMorphFront: ctrl.
	wheels at: #rotZ put: ctrl.

	ctrl := WheelMorph new.
	ctrl target: b3DSceneMorph.
	ctrl actionSelector: #rotateY:.
	ctrl setBalloonText: 'y Axis'.
	self addMorphFront: ctrl.
	wheels at: #rotY put: ctrl.

	ctrl := WheelMorph new.
	ctrl target: b3DSceneMorph.
	ctrl actionSelector: #rotateX:.
	ctrl beVertical.
	ctrl setBalloonText: 'x Axis'.
	self addMorphFront: ctrl.
	wheels at: #rotX put: ctrl.! !


!B3DSceneExplorerMorph methodsFor: 'menus'!
addCustomMenuItems: aCustomMenu

	(aCustomMenu isKindOf: MenuMorph)
		ifTrue: [aCustomMenu addUpdating: #rotationString action: #switchRotationStatus]
		ifFalse: [aCustomMenu add: 'swich rotation status' action: #switchRotationStatus].
	(aCustomMenu isKindOf: MenuMorph)
		ifTrue: [aCustomMenu addUpdating: #headLightString action: #switchHeadLightStatus]
		ifFalse: [aCustomMenu add: 'swich headlight' action: #switchHeadLightStatus].
	aCustomMenu add: 'open 3DS file' action: #openThreeDSFile.
	aCustomMenu add: 'select new camera' action: #selectNewCamera.! !

!B3DSceneExplorerMorph methodsFor: 'menus' stamp: 'ti 3/22/2000 18:51'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	self addCustomMenuItems: aCustomMenu.! !

!B3DSceneExplorerMorph methodsFor: 'menus'!
headLightString
	^b3DSceneMorph headLightIsOn
		ifTrue: ['swich headlight off']
		ifFalse: ['swich headlight on']! !

!B3DSceneExplorerMorph methodsFor: 'menus' stamp: 'ti 3/24/2000 17:04'!
rotationString
	^b3DSceneMorph isRotating
		ifTrue: ['stop rotating']
		ifFalse: ['start rotating']! !

!B3DSceneExplorerMorph methodsFor: 'menus' stamp: 'ti 3/22/2000 18:57'!
yellowButtonMenu
	| menu sel |
	menu _ CustomMenu new.
	menu title: self class name.
	self addCustomMenuItems: menu.
	sel := menu startUp.
	sel ifNotNil: [self perform: sel]! !


!B3DSceneExplorerMorph methodsFor: 'visual properties' stamp: 'ti 3/21/2000 14:45'!
defaultColor
	^Color gray! !
Morph subclass: #B3DSceneMorph
	instanceVariableNames: 'scene '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Demo Morphs'!

!B3DSceneMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 17:57'!
debugDraw
	self fullDrawOn: (Display getCanvas).
	Display forceToScreen: bounds.! !

!B3DSceneMorph methodsFor: 'drawing' stamp: 'ar 2/17/1999 05:05'!
drawOn: aCanvas
	aCanvas asBalloonCanvas render: self.
! !

!B3DSceneMorph methodsFor: 'drawing' stamp: 'ar 2/17/1999 05:34'!
renderOn: aRenderer
	aRenderer viewport: (self bounds insetBy: 1@1).
	aRenderer clearDepthBuffer.
	aRenderer loadIdentity.
	scene renderOn: aRenderer.! !


!B3DSceneMorph methodsFor: 'initialize' stamp: 'ar 2/17/1999 05:27'!
createDefaultScene
	| sceneObj camera |
	sceneObj _ B3DSceneObject named: 'Sample Cube'.
	sceneObj geometry: (B3DBox from: (-0.7@-0.7@-0.7) to: (0.7@0.7@0.7)).
	camera _ B3DCamera new.
	camera position: 0@0@-1.5.
	self extent: 100@100.
	scene _ B3DScene new.
	scene defaultCamera: camera.
	scene objects add: sceneObj.! !

!B3DSceneMorph methodsFor: 'initialize' stamp: 'ar 2/17/1999 05:24'!
initialize
	super initialize.
	self createDefaultScene.! !


!B3DSceneMorph methodsFor: 'accessing' stamp: 'ar 2/17/1999 05:34'!
scene
	^scene! !

!B3DSceneMorph methodsFor: 'accessing' stamp: 'ar 2/17/1999 05:34'!
scene: aScene
	scene _ aScene! !


!B3DSceneMorph methodsFor: 'stepping' stamp: 'ar 2/17/1999 05:31'!
step
	scene defaultCamera rotateBy: 15.
	self changed.! !

!B3DSceneMorph methodsFor: 'stepping' stamp: 'ar 2/17/1999 05:31'!
stepTime
	^1! !

!B3DSceneMorph methodsFor: 'stepping' stamp: 'ar 2/17/1999 05:30'!
wantsSteps
	^true! !
Object subclass: #B3DSceneObject
	instanceVariableNames: 'name matrix material texture geometry children '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Objects'!

!B3DSceneObject methodsFor: 'initialize' stamp: 'ar 2/16/1999 03:09'!
from3DS: aDictionary
	aDictionary isEmpty ifTrue:[^nil].
	geometry _ B3DSTriangleMesh from3DS: aDictionary.
	material _ (aDictionary at: #triList) last.! !


!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/14/1999 22:37'!
boundingBox
	| bBox |
	bBox _ geometry ifNotNil:[geometry boundingBox].
	children ifNil:[^bBox].
	children do:[:obj|
		bBox _ bBox ifNil:[obj boundingBox] ifNotNil:[bBox merge: obj boundingBox]
	].
	^bBox! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:29'!
geometry
	^geometry! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:30'!
geometry: aGeometry
	geometry _ aGeometry.! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:30'!
material
	^material! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:10'!
material: aMaterial
	material _ aMaterial.
	material class == Association ifTrue:[
		texture _ material key.
		material _ material value.
	].! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:30'!
matrix
	^matrix! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:30'!
matrix: aMatrix
	matrix _ aMatrix! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:06'!
name
	^name! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:06'!
name: aString
	name _ aString.! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:01'!
texture
	^texture! !

!B3DSceneObject methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:01'!
texture: aTexture
	texture _ aTexture! !


!B3DSceneObject methodsFor: 'displaying' stamp: 'ar 2/16/1999 03:13'!
renderOn: aRenderer
	material ifNotNil:[
		aRenderer pushMaterial.
		aRenderer material: material].
	texture ifNotNil:[
		aRenderer pushTexture.
		aRenderer texture: texture].
	matrix ifNotNil:[
		aRenderer pushMatrix.
		aRenderer transformBy: matrix].
	geometry ifNotNil:[geometry renderOn: aRenderer].
	children ifNotNil:[children do:[:child| child renderOn: aRenderer]].
	matrix ifNotNil:[aRenderer popMatrix].
	texture ifNotNil:[aRenderer popTexture].
	material ifNotNil:[aRenderer popMaterial].! !


!B3DSceneObject methodsFor: 'printing' stamp: 'ar 2/8/1999 01:15'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$(;
		print: self name;
		nextPut: $).! !

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

B3DSceneObject class
	instanceVariableNames: ''!

!B3DSceneObject class methodsFor: 'instance creation' stamp: 'ar 2/8/1999 01:06'!
from3DS: aDictionary
	^self new from3DS: aDictionary! !

!B3DSceneObject class methodsFor: 'instance creation' stamp: 'ar 2/7/1999 20:06'!
named: aString
	^self new name: aString! !
B3DEnginePlugin subclass: #B3DShaderPlugin
	instanceVariableNames: 'litVertex primLight primMaterial l2vDirection l2vDistance l2vSpecDir lightFlags vbFlags lightScale vtxInColor vtxOutColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DShaderPlugin methodsFor: 'primitives' stamp: 'ar 2/17/1999 19:40'!
b3dShadeVertexBuffer
	"Primitive. Shade all the vertices in the vertex buffer using the given array of primitive light sources. Return true on success."
	| lightArray vtxCount vtxArray lightCount |
	self export: true.
	self inline: false.
	self var: #vtxArray declareC:'float *vtxArray'.
	vbFlags _ interpreterProxy stackIntegerValue: 0.
	primMaterial _ self stackMaterialValue: 1.
	lightArray _ self stackLightArrayValue: 2.
	vtxCount _ interpreterProxy stackIntegerValue: 3.
	vtxArray _ self stackPrimitiveVertexArray: 4 ofSize: vtxCount.
	(vtxArray = nil or:[primMaterial = nil or:[interpreterProxy failed]])
		ifTrue:[^interpreterProxy primitiveFail].
	"Setup"
	litVertex _ vtxArray.
	lightCount _ interpreterProxy slotSizeOf: lightArray.
	"Go over all vertices"
	1 to: vtxCount do:[:i|
		"Load the primitive vertex"
		self loadPrimitiveVertex.
		"Load initial color (e.g., emissive part of vertex and/or material)"
		(vbFlags anyMask: VBTrackEmission) ifTrue:[
			"Load color from vertex"
			vtxOutColor at: 0 put: (vtxInColor at: 0) + (primMaterial at: EmissionRed).
			vtxOutColor at: 1 put: (vtxInColor at: 1) + (primMaterial at: EmissionGreen).
			vtxOutColor at: 2 put: (vtxInColor at: 2) + (primMaterial at: EmissionBlue).
			vtxOutColor at: 3 put: (vtxInColor at: 3) + (primMaterial at: EmissionAlpha).
		] ifFalse:[
			vtxOutColor at: 0 put: (primMaterial at: EmissionRed).
			vtxOutColor at: 1 put: (primMaterial at: EmissionGreen).
			vtxOutColor at: 2 put: (primMaterial at: EmissionBlue).
			vtxOutColor at: 3 put: (primMaterial at: EmissionAlpha).
		].
		"For each enabled light source"
		0 to: lightCount-1 do:[:j|
			"Fetch the light source"
			primLight _ self fetchLightSource: j ofObject: lightArray.
			"Setup values"
			self loadPrimitiveLightSource.
			"Compute the color from the light source"
			self shadeVertex.
		].
		"Store the computed color back"
		self storePrimitiveVertex.
		"And step on to the next vertex"
		litVertex _ litVertex + PrimVertexSize.
	].
	"Clean up stack"
	interpreterProxy pop: 6. "Pop args+rcvr"
	interpreterProxy pushBool: true.! !

!B3DShaderPlugin methodsFor: 'primitives' stamp: 'ar 2/17/1999 04:32'!
b3dShaderVersion
	"Return the current shader version."
	self export: true.
	self inline: false.
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: 1.	"Version 1"! !


!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 2/17/1999 19:40'!
addPart: lightPart from: materialPart trackFlag: vbTrackFlag scale: scale
	"Add the given light part to the output color, scaled by the given scale factor.
	If the given flag is set in vbFlags then load the part from the primitive vertex"
	| rPart gPart bPart aPart |
	self var: #lightPart declareC:'float *lightPart'.
	self var: #materialPart declareC:'float *materialPart'.
	self var: #scale declareC:'double scale'.
	self var: #rPart declareC:'double rPart'.
	self var: #gPart declareC:'double gPart'.
	self var: #bPart declareC:'double bPart'.
	self var: #aPart declareC:'double aPart'.
	self inline: true.
	(vbFlags anyMask: vbTrackFlag) ifTrue:[
		rPart _ (vtxInColor at: 0) * (lightPart at: 0) * scale.
		gPart _ (vtxInColor at: 1) * (lightPart at: 1) * scale.
		bPart _ (vtxInColor at: 2) * (lightPart at: 2) * scale.
		aPart _ (vtxInColor at: 3) * (lightPart at: 3) * scale.
	] ifFalse:[
		"Note: This should be pre-computed."
		rPart _ (materialPart at: 0) * (lightPart at: 0) * scale.
		gPart _ (materialPart at: 1) * (lightPart at: 1) * scale.
		bPart _ (materialPart at: 2) * (lightPart at: 2) * scale.
		aPart _ (materialPart at: 3) * (lightPart at: 3) * scale.
	].
	vtxOutColor at: 0 put: (vtxOutColor at: 0) + rPart.
	vtxOutColor at: 1 put: (vtxOutColor at: 1) + gPart.
	vtxOutColor at: 2 put: (vtxOutColor at: 2) + bPart.
	vtxOutColor at: 3 put: (vtxOutColor at: 3) + aPart.! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 2/17/1999 19:39'!
computeAttenuation
	"Compute the attenuation for the current light and vertex"
	lightScale _ 1.0.
	(lightFlags anyMask: FlagAttenuated) ifTrue:[
		lightScale _ 1.0 / ((primLight at: PrimLightAttenuationConstant) + 
			(l2vDistance * ((primLight at: PrimLightAttenuationLinear) + 
				(l2vDistance * (primLight at: PrimLightAttenuationSquared)))))].
! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:31'!
computeDirection
	"Compute the direction for the current light and vertex"
	| scale |
	self inline: true.
	self var: #scale declareC:'double scale'.
	(lightFlags anyMask: FlagPositional) ifTrue:[
		"Must compute the direction for this vertex"
		l2vDirection at: 0 put: (litVertex at: PrimVtxPositionX) - (primLight at: PrimLightPositionX).
		l2vDirection at: 1 put: (litVertex at: PrimVtxPositionY) - (primLight at: PrimLightPositionY).
		l2vDirection at: 2 put: (litVertex at: PrimVtxPositionZ) - (primLight at: PrimLightPositionZ).
		"l2vDistance _ self dotProductOf: l2vDirection with: l2vDirection."
		l2vDistance _ ((l2vDirection at: 0) * (l2vDirection at: 0)) +
						((l2vDirection at: 1) * (l2vDirection at: 1)) +
							((l2vDirection at: 2) * (l2vDirection at: 2)).
		(l2vDistance = 0.0 or:[l2vDistance = 1.0]) 
			ifFalse:[	l2vDistance _ l2vDistance sqrt.
					scale _ -1.0/l2vDistance].
		l2vDirection at: 0 put: (l2vDirection at: 0) * scale.
		l2vDirection at: 1 put: (l2vDirection at: 1) * scale.
		l2vDirection at: 2 put: (l2vDirection at: 2) * scale.
	] ifFalse:[
		(lightFlags anyMask: FlagDirectional) ifTrue:[
			l2vDirection at: 0 put: (primLight at: PrimLightDirectionX).
			l2vDirection at: 1 put: (primLight at: PrimLightDirectionY).
			l2vDirection at: 2 put: (primLight at: PrimLightDirectionZ).
		].
	].
! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:39'!
computeSpecularDirection
	"Computes
		l2vSpecDir _ l2vSpecDir - vtx position safelyNormalized.
	"
	| scale |
	self var: #scale declareC:'double scale'.
	scale _ self inverseLengthOfFloat: litVertex + PrimVtxPosition.
	l2vSpecDir at: 0 put: (l2vSpecDir at: 0) - ((litVertex at: PrimVtxPositionX) * scale).
	l2vSpecDir at: 1 put: (l2vSpecDir at: 1) - ((litVertex at: PrimVtxPositionY) * scale).
	l2vSpecDir at: 2 put: (l2vSpecDir at: 2) - ((litVertex at: PrimVtxPositionZ) * scale).
! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:39'!
computeSpotFactor
	"Compute the spot factor for a spot light"
	| cosAngle minCos deltaCos |
	self returnTypeC:'double'.
	self var: #cosAngle declareC:'double cosAngle'.
	self var: #minCos declareC:'double minCos'.
	self var: #deltaCos declareC:'double deltaCos'.
	"Compute cos angle between direction of the spot light and direction to vertex"
	cosAngle _ self dotProductOfFloat: primLight + PrimLightDirection withDouble: l2vDirection.
	cosAngle _ 0.0 - cosAngle.
	minCos _ primLight at: SpotLightMinCos.
	cosAngle < minCos ifTrue:[^0.0].
	deltaCos _ primLight at: SpotLightDeltaCos.
	deltaCos <= 0.00001 ifTrue:[
		"No delta -- a sharp boundary between on and off.
		Since off has already been determined above, we are on"
		^1.0].
	"Scale the angle to 0/1 range"
	cosAngle _ (cosAngle - minCos) / deltaCos.
	^cosAngle raisedTo: (primLight at: SpotLightExponent)
! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:39'!
dotProductOfFloat: v1 withDouble: v2
	self var: #v1 declareC:'float * v1'.
	self var: #v2 declareC:'double *v2'.
	self returnTypeC:'double'.
	^((v1 at: 0) * (v2 at: 0)) +
		((v1 at: 1) * (v2 at: 1)) +
			((v1 at: 2) * (v2 at: 2)).
! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:38'!
inverseLengthOfDouble: aVector
	| scale |
	self returnTypeC:'double'.
	self var: #aVector declareC:'double * aVector'.
	self var: #scale declareC:'double scale'.
	"scale _ self dotProductOf: aVector with: aVector."
	scale _ ((aVector at: 0) * (aVector at: 0)) +
				((aVector at: 1) * (aVector at: 1)) +
					((aVector at: 2) * (aVector at: 2)).
	(scale = 0.0 or:[scale = 1.0]) ifTrue:[^scale].
	^1.0 / scale sqrt! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:38'!
inverseLengthOfFloat: aVector
	| scale |
	self returnTypeC:'double'.
	self var: #aVector declareC:'float * aVector'.
	self var: #scale declareC:'double scale'.
	"scale _ self dotProductOf: aVector with: aVector."
	scale _ ((aVector at: 0) * (aVector at: 0)) +
				((aVector at: 1) * (aVector at: 1)) +
					((aVector at: 2) * (aVector at: 2)).
	(scale = 0.0 or:[scale = 1.0]) ifTrue:[^scale].
	^1.0 / scale sqrt! !

!B3DShaderPlugin methodsFor: 'shading' stamp: 'ar 4/17/1999 22:40'!
shadeVertex
	| cosAngle specularFactor |
	self var: #cosAngle declareC:'double cosAngle'.
	self var: #specularFactor declareC:'double specularFactor'.
	self computeDirection.
	self computeAttenuation.

	(lightFlags anyMask: FlagHasSpot) ifTrue:[
		lightScale _ lightScale * self computeSpotFactor.
	].

	"Compute ambient and diffuse part only if lightScale is non-zero."
	(lightScale > 0.001) ifTrue:[
		"Compute the ambient part"
		(lightFlags anyMask: FlagAmbientPart) ifTrue:[
			self addPart: (primLight + AmbientPart) 
				from: primMaterial + AmbientPart 
				trackFlag: VBTrackAmbient 
				scale: lightScale.
		].

		"Compute the diffuse part"
		(lightFlags anyMask: FlagDiffusePart) ifTrue:[
			"Compute angle from light->vertex to vertex normal"
			cosAngle _ self dotProductOfFloat: (litVertex + PrimVtxNormal) withDouble: l2vDirection.
			"For one-sided lighting negate cosAngle if necessary"
			((vbFlags bitAnd: VBTwoSidedLighting) = 0 and:[cosAngle < 0.0])
				ifTrue:[cosAngle _ 0.0 - cosAngle].
			"For two-sided lighting check if cosAngle > 0.0 meaning that it is a front face"
			cosAngle > 0.0 ifTrue:[
				self addPart: primLight + DiffusePart 
					from: primMaterial + DiffusePart 
					trackFlag: VBTrackDiffuse 
					scale: lightScale * cosAngle.
			].
		].
	]. "lightScale > 0.001"

	"Compute the specular part"
	((lightFlags anyMask: FlagSpecularPart) and:[
		(primMaterial at: MaterialShininess) > 0.0]) ifTrue:[
		"Compute specular part"
		l2vSpecDir at: 0 put: (l2vDirection at: 0).
		l2vSpecDir at: 1 put: (l2vDirection at: 1).
		l2vSpecDir at: 2 put: (l2vDirection at: 2).
		(vbFlags anyMask: VBUseLocalViewer) 
			ifTrue:[self computeSpecularDirection]
			ifFalse:[l2vSpecDir at: 2 put: (l2vSpecDir at: 2) - 1.0].
		cosAngle _ self dotProductOfFloat: (litVertex + PrimVtxNormal) withDouble: l2vSpecDir.
		cosAngle > 0.0 ifTrue:[
			"Normalize the angle"
			cosAngle _ cosAngle * (self inverseLengthOfDouble: l2vSpecDir).
			"cosAngle should be somewhere between 0 and 1.
			If not, then the vertex normal was not normalized"
			cosAngle > 1.0 ifTrue:[
				specularFactor _ cosAngle raisedTo: (primMaterial at: MaterialShininess).
			] ifFalse:[
				cosAngle = 0.0 
					ifTrue:[specularFactor _ 1.0]
					ifFalse:[specularFactor _ cosAngle raisedTo: (primMaterial at: MaterialShininess)].
			].
			self addPart: primLight + SpecularPart 
				from: primMaterial + SpecularPart 
				trackFlag: VBTrackSpecular 
				scale: specularFactor.
		].
	].! !


!B3DShaderPlugin methodsFor: 'primitive support' stamp: 'ar 2/15/1999 22:33'!
fetchLightSource: index ofObject: anArray
	"Fetch the primitive light source from the given array.
	Note: No checks are done within here - that happened in stackLightArrayValue:"
	| lightOop |
	self inline: true.
	self returnTypeC:'void*'.
	lightOop _ interpreterProxy fetchPointer: index ofObject: anArray.
	^interpreterProxy firstIndexableField: lightOop! !

!B3DShaderPlugin methodsFor: 'primitive support' stamp: 'ar 2/15/1999 22:29'!
stackLightArrayValue: stackIndex
	"Load an Array of B3DPrimitiveLights from the given stack index"
	| oop array arraySize |
	self inline: false.
	array _ interpreterProxy stackObjectValue: stackIndex.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
		ifFalse:[^interpreterProxy primitiveFail].
	arraySize _ interpreterProxy slotSizeOf: array.
	0 to: arraySize-1 do:[:i|
		oop _ interpreterProxy fetchPointer: i ofObject: array.
		(interpreterProxy isIntegerObject: oop)
			ifTrue:[^interpreterProxy primitiveFail].
		((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = PrimLightSize])
			ifFalse:[^interpreterProxy primitiveFail].
	].
	^array! !

!B3DShaderPlugin methodsFor: 'primitive support' stamp: 'ar 2/15/1999 19:22'!
stackMaterialValue: stackIndex
	"Load a B3DMaterial from the given stack index"
	| oop |
	self inline: false.
	self returnTypeC:'void *'.
	oop _ interpreterProxy stackObjectValue: stackIndex.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: oop) and:[(interpreterProxy slotSizeOf: oop) = MaterialSize])
		ifTrue:[^interpreterProxy firstIndexableField: oop].
	^nil! !


!B3DShaderPlugin methodsFor: 'other' stamp: 'ar 2/17/1999 19:35'!
loadPrimitiveLightSource
	self inline: true.
	lightFlags _ (self cCoerce: primLight to: 'int*') at: PrimLightFlags.! !

!B3DShaderPlugin methodsFor: 'other' stamp: 'ar 2/17/1999 19:40'!
loadPrimitiveVertex
	"Load the necessary values from the current primitive vertex"
	| rgba |
	self inline: true.
	rgba _ (self cCoerce: litVertex to:'int*') at: PrimVtxColor32.
	vtxInColor at: 2 put: (rgba bitAnd: 255) * (1.0 / 255.0).
	rgba _ rgba >> 8.
	vtxInColor at: 1 put: (rgba bitAnd: 255) * (1.0 / 255.0).
	rgba _ rgba >> 8.
	vtxInColor at: 0 put: (rgba bitAnd: 255) * (1.0 / 255.0).
	rgba _ rgba >> 8.
	vtxInColor at: 3 put: (rgba bitAnd: 255) * (1.0 / 255.0).
! !

!B3DShaderPlugin methodsFor: 'other' stamp: 'ar 2/17/1999 19:41'!
storePrimitiveVertex
	"Store the computed output color back into the current primitive vertex.
	Clamp the r,g,b,a part to be in the range 0-255."
	| r g b a |
	self inline: true.
	r _ ((vtxOutColor at: 0) * 255) asInteger.
	r _ (r min: 255) max: 0.
	g _ ((vtxOutColor at: 1) * 255) asInteger.
	g _ (g min: 255) max: 0.
	b _ ((vtxOutColor at: 2) * 255) asInteger.
	b _ (b min: 255) max: 0.
	a _ ((vtxOutColor at: 3) * 255) asInteger.
	a _ (a min: 255) max: 0.
	"The following is equal to b + (g << 8) + (r << 16) + (a << 24)"
	(self cCoerce: litVertex to:'int*') 
		at: PrimVtxColor32 put: b + (g + (r + (a << 8) << 8) << 8). 
! !

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

B3DShaderPlugin class
	instanceVariableNames: ''!

!B3DShaderPlugin class methodsFor: 'translation' stamp: 'ar 5/15/2000 23:13'!
declareCVarsIn: cg
	cg var: #litVertex type: #'float*'.
	cg var: #primLight type: #'float*'.
	cg var: #primMaterial type: #'float*'.
	cg var: #l2vDirection declareC: 'double l2vDirection[3]'.
	cg var: #l2vSpecDir declareC: 'double l2vSpecDir[3]'.
	cg var: #vtxInColor declareC: 'double vtxInColor[4]'.
	cg var: #vtxOutColor declareC: 'double vtxOutColor[4]'.
	cg var: #l2vDistance type: #'double'.
	cg var: #lightScale type: #'double'! !
B3DGeometry variableSubclass: #B3DSimpleMesh
	instanceVariableNames: 'bBox '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:54'!
boundingBox
	^bBox ifNil:[bBox _ self computeBoundingBox]! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:53'!
colorOfVertex: vtx
	^vtx color! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:55'!
computeBoundingBox
	| min max |
	min _ max _ nil.
	self vertexPositionsDo:[:vtx|
		min ifNil:[min _ vtx] ifNotNil:[min _ min min: vtx].
		max ifNil:[max _ vtx] ifNotNil:[max _ max max: vtx].
	].
	^Rectangle origin: min corner: max! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:54'!
faces
	^self! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:54'!
faces: aCollection
	^self shouldNotImplement! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:53'!
normalOfVertex: vtx
	^vtx normal! !

!B3DSimpleMesh methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:54'!
texCoordOfVertex: vtx
	^vtx texCoord! !


!B3DSimpleMesh methodsFor: 'testing' stamp: 'ar 9/14/1999 22:53'!
hasTextureCoords
	1 to: self size do:[:i|
		(self at: i) hasTextureCoords ifFalse:[^false]].
	^true! !

!B3DSimpleMesh methodsFor: 'testing' stamp: 'ar 9/14/1999 22:52'!
hasVertexColors
	1 to: self size do:[:i|
		(self at: i) hasVertexColors ifFalse:[^false]].
	^true! !


!B3DSimpleMesh methodsFor: 'enumerating' stamp: 'ar 9/17/1999 12:38'!
do: aBlock
	1 to: self size do:[:i| aBlock value: (self at: i)]! !

!B3DSimpleMesh methodsFor: 'enumerating' stamp: 'ar 9/14/1999 22:02'!
trianglesDo: aBlock
	1 to: self size do:[:i|
		(self at: i) trianglesDo: aBlock.
	].! !

!B3DSimpleMesh methodsFor: 'enumerating' stamp: 'ar 9/14/1999 21:56'!
vertexPositionsDo: aBlock
	1 to: self size do:[:i|
		(self at: i) vertexPositionsDo: aBlock.
	]! !


!B3DSimpleMesh methodsFor: 'converting' stamp: 'ar 9/14/1999 22:26'!
asIndexedMesh
	"Convert the receiver into (the more compact) indexed representation"
	^self asIndexedTriangleMesh! !

!B3DSimpleMesh methodsFor: 'converting' stamp: 'ar 9/14/1999 22:17'!
asIndexedTriangleMesh
	"Convert the receiver into (the more compact) indexed triangle representation"
	| map faces face vtx nrm tex col mesh |
	map _ Dictionary new: (self size * 4). "Need some space for the vertices"
	faces _ WriteStream on: (B3DIndexedTriangleArray new: self size).
	self trianglesDo:[:tri|
		tri assureVertexNormals.
		face _ B3DIndexedTriangle
					with: (map at: tri first ifAbsentPut:[map size + 1])
					with: (map at: tri second ifAbsentPut:[map size + 1])
					with: (map at: tri third ifAbsentPut:[map size + 1]).
		faces nextPut: face].
	faces _ faces contents.
	vtx _ B3DVector3Array new: map size.
	nrm _ B3DVector3Array new: map size.
	self hasTextureCoords ifTrue:[tex _ B3DTexture2Array new: map size].
	self hasVertexColors ifTrue:[col _ B3DColor4Array new: map size].
	map keysAndValuesDo:[:vertex :idx|
		vtx at: idx put: vertex position.
		nrm at: idx put: vertex normal.
		tex == nil ifFalse:[tex at: idx put: vertex texCoord].
		col == nil ifFalse:[col at: idx put: vertex color].
	].
	mesh _ B3DIndexedTriangleMesh new.
	mesh faces: faces.
	mesh vertices: vtx.
	mesh texCoords: tex.
	mesh vertexColors: col.
	mesh vertexNormals: nrm.
	^mesh! !

!B3DSimpleMesh methodsFor: 'converting' stamp: 'ar 9/14/1999 22:05'!
asSimpleMesh
	^self! !

!B3DSimpleMesh methodsFor: 'converting' stamp: 'ar 9/17/1999 12:31'!
transformedBy: aMatrix
	"Return a copy of the receiver with its vertices transformed by the given matrix"
	| newFaces|
	newFaces _ Array new: self size.
	1 to: self size do:[:i| newFaces at: i put: ((self at: i) transformedBy: aMatrix)].
	^self class withAll: newFaces! !


!B3DSimpleMesh methodsFor: 'rendering' stamp: 'ar 11/7/1999 18:15'!
renderOn: aRenderer
	| box bounds |
	box _ nil.
	1 to: self size do:[:i|
		bounds _ (self at: i) renderOn: aRenderer.
		box == nil ifTrue:[box _ bounds] ifFalse:[box _ box quickMerge: bounds].
	].
	^box! !


!B3DSimpleMesh methodsFor: 'private' stamp: 'ar 9/14/1999 23:01'!
withAll: aCollection
	1 to: self size do:[:i|
		self at: i put: (aCollection at: i).
	].! !

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

B3DSimpleMesh class
	instanceVariableNames: ''!

!B3DSimpleMesh class methodsFor: 'instance creation' stamp: 'ar 9/14/1999 23:00'!
withAll: aCollection
	^(self new: aCollection size) withAll: aCollection! !
B3DGeometry variableSubclass: #B3DSimpleMeshFace
	instanceVariableNames: 'normal '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:50'!
first
	^self at: 1! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:50'!
fourth
	^self at: 4! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:51'!
normal
	^normal ifNil:[normal _ self computeFaceNormal].! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:53'!
normal: aB3DVector3
	normal _ aB3DVector3! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:50'!
second
	^self at: 2! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 22:50'!
third
	^self at: 3! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:53'!
vertices
	^self! !

!B3DSimpleMeshFace methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:53'!
vertices: aCollection
	^self shouldNotImplement.! !


!B3DSimpleMeshFace methodsFor: 'testing' stamp: 'ar 9/14/1999 23:05'!
hasTextureCoords
	1 to: self size do:[:i|
		(self at: i) hasTextureCoords ifFalse:[^false]].
	^true! !

!B3DSimpleMeshFace methodsFor: 'testing' stamp: 'ar 9/14/1999 23:05'!
hasVertexColors
	1 to: self size do:[:i|
		(self at: i) hasVertexColors ifFalse:[^false]].
	^true! !


!B3DSimpleMeshFace methodsFor: 'enumerating' stamp: 'ar 9/17/1999 12:38'!
do: aBlock
	1 to: self size do:[:i| aBlock value: (self at: i)]! !

!B3DSimpleMeshFace methodsFor: 'enumerating' stamp: 'ar 9/14/1999 22:01'!
trianglesDo: aBlock
	"Evaluate aBlock with triangular faces"
	| face |
	self size = 3
		ifTrue:[^aBlock value: self].
	3 to: self size do:[:i|
		face _ self class with: (self at: 1) with: (self at: i-1) with: (self at: i).
		aBlock value: face].! !

!B3DSimpleMeshFace methodsFor: 'enumerating' stamp: 'ar 9/14/1999 21:56'!
vertexPositionsDo: aBlock
	1 to: self size do:[:i|
		(self at: i) vertexPositionsDo: aBlock.
	]! !


!B3DSimpleMeshFace methodsFor: 'rendering' stamp: 'ar 11/7/1999 18:14'!
renderOn: aRenderer
	^aRenderer drawPolygonAfter:[
		aRenderer normal: self normal.
		1 to: self size do:[:i| (self at: i) renderOn: aRenderer].
	].! !


!B3DSimpleMeshFace methodsFor: 'private' stamp: 'ar 9/14/1999 23:09'!
computeFaceNormal
	| d1 d2 nrml |
	self size < 3 ifTrue:[^B3DVector3 zero].
	d1 _ (self at: 1) position - (self at: 2) position.
	d2 _ (self at: 3) position - (self at: 2) position.
	d1 safelyNormalize.
	d2 safelyNormalize.
	nrml _ d1 cross: d2.
	^nrml safelyNormalize! !

!B3DSimpleMeshFace methodsFor: 'private' stamp: 'ar 9/14/1999 22:04'!
with: v1 with: v2 with: v3
	self at: 1 put: v1;
		at: 2 put: v2;
		at: 3 put: v3! !

!B3DSimpleMeshFace methodsFor: 'private' stamp: 'ar 9/14/1999 22:04'!
with: v1 with: v2 with: v3 with: v4
	self at: 1 put: v1;
		at: 2 put: v2;
		at: 3 put: v3;
		at: 4 put: v4! !

!B3DSimpleMeshFace methodsFor: 'private' stamp: 'ar 9/14/1999 22:05'!
withAll: aCollection
	1 to: self size do:[:i|
		self at: i put: (aCollection at: i).
	].! !


!B3DSimpleMeshFace methodsFor: 'misc' stamp: 'ar 9/14/1999 22:51'!
assureVertexNormals
	| vtx |
	1 to: self size do:[:i|
		vtx _ self at: i.
		vtx normal == nil ifTrue:[
			vtx _ vtx copy.
			vtx normal: self normal.
			self at: i put: vtx]].! !


!B3DSimpleMeshFace methodsFor: 'converting' stamp: 'ar 9/17/1999 12:31'!
transformedBy: aMatrix
	"Return a copy of the receiver with its vertices transformed by the given matrix"
	| newVtx |
	newVtx _ Array new: self size.
	1 to: self size do:[:i| newVtx at: i put: ((self at: i) transformedBy: aMatrix)].
	^self class withAll: newVtx! !

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

B3DSimpleMeshFace class
	instanceVariableNames: ''!

!B3DSimpleMeshFace class methodsFor: 'instance creation' stamp: 'ar 9/14/1999 22:03'!
with: v0 with: v1 with: v2
	^(self new: 3) with: v0 with: v1 with: v2! !

!B3DSimpleMeshFace class methodsFor: 'instance creation' stamp: 'ar 9/14/1999 22:03'!
with: v0 with: v1 with: v2 with: v3
	^(self new: 4) with: v0 with: v1 with: v2 with: v3! !

!B3DSimpleMeshFace class methodsFor: 'instance creation' stamp: 'ar 9/14/1999 22:03'!
withAll: aCollection
	^(self new: aCollection size) withAll: aCollection! !
Object subclass: #B3DSimpleMeshVertex
	instanceVariableNames: 'position normal color texCoord '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Meshes'!

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:46'!
color
	^color! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:46'!
color: aB3DColor4
	color _ aB3DColor4! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:45'!
normal
	^normal! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:46'!
normal: aB3DVector3
	normal _ aB3DVector3! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:45'!
position
	^position! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:45'!
position: aB3DVector3
	position _ aB3DVector3! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:46'!
texCoord
	^texCoord! !

!B3DSimpleMeshVertex methodsFor: 'accessing' stamp: 'ar 9/14/1999 21:46'!
texCoord: aB3DVector2
	texCoord _ aB3DVector2! !


!B3DSimpleMeshVertex methodsFor: 'testing' stamp: 'ar 9/14/1999 23:06'!
hasTextureCoords
	^texCoord notNil! !

!B3DSimpleMeshVertex methodsFor: 'testing' stamp: 'ar 9/14/1999 23:06'!
hasVertexColors
	^color notNil! !


!B3DSimpleMeshVertex methodsFor: 'comparing' stamp: 'ar 9/14/1999 21:48'!
= aVertex
	^self class == aVertex class
		and:[self position = aVertex position
			and:[self normal = aVertex normal
				and:[self color = aVertex color
					and:[self texCoord = aVertex texCoord]]]]! !

!B3DSimpleMeshVertex methodsFor: 'comparing' stamp: 'ar 9/14/1999 21:49'!
hash
	"Hash is re-implemented because #= is re-implemented"
	^(position hash bitXor: texCoord hash) bitXor:
		(normal hash bitXor: color hash)! !


!B3DSimpleMeshVertex methodsFor: 'enumerating' stamp: 'ar 9/14/1999 21:56'!
vertexPositionsDo: aBlock
	position vertexPositionsDo: aBlock.! !


!B3DSimpleMeshVertex methodsFor: 'rendering' stamp: 'ar 9/14/1999 21:59'!
renderOn: aRenderer
	color == nil ifFalse:[aRenderer color: color].
	texCoord == nil ifFalse:[aRenderer texCoord: texCoord].
	normal == nil ifFalse:[aRenderer normal: normal].
	aRenderer vertex: position.! !


!B3DSimpleMeshVertex methodsFor: 'printing' stamp: 'ar 9/16/1999 22:48'!
printOn: aStream
	aStream nextPutAll:'['; print: position; nextPutAll:']'.! !


!B3DSimpleMeshVertex methodsFor: 'converting' stamp: 'ar 9/17/1999 13:30'!
transformedBy: aMatrix
	"Return a copy of the receiver with its vertices transformed by the given matrix"
	| transformer copy |
	transformer _ B3DVertexTransformer new.
	transformer loadIdentity.
	transformer transformBy: aMatrix.
	copy _ self copy.
	copy position: (transformer transformPosition: position).
	normal == nil
		ifFalse:[copy normal: (transformer transformDirection: normal) safelyNormalize].
	^copy! !
B3DVertexRasterizer subclass: #B3DSimulRasterizer
	instanceVariableNames: 'canvas scanner '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!

!B3DSimulRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:45'!
clipRect: aRectangle
	super clipRect: aRectangle.
	scanner bitBlt clipRect: aRectangle.! !

!B3DSimulRasterizer methodsFor: 'initialize' stamp: 'ar 4/18/1999 04:35'!
flush
	self mainLoop.! !

!B3DSimulRasterizer methodsFor: 'initialize' stamp: 'ar 4/18/1999 04:36'!
initialize
	super initialize.
	scanner _ B3DScanner new.! !

!B3DSimulRasterizer methodsFor: 'initialize' stamp: 'ar 4/18/1999 04:36'!
reset
	super reset.
	scanner _ B3DScanner new.! !

!B3DSimulRasterizer methodsFor: 'initialize' stamp: 'ar 5/28/2000 12:18'!
target: destForm
	| bb span sourceForm |
	super target: destForm.
	span _ Bitmap new: 2048.
	sourceForm _ Form extent: span size@1 depth: 32 bits: span.
	bb _ BitBlt current toForm: destForm.
	bb sourceForm: sourceForm.
	bb isFXBlt ifTrue:[
		bb colorMap: (sourceForm colormapIfNeededFor: destForm).
		bb combinationRule: 34 "Form paint". "Later we'll change this to 34 for alpha blending"
	] ifFalse:[
		bb colorMap: (sourceForm colormapIfNeededForDepth: destForm depth).
		bb combinationRule: 34 "Form paint". "Later we'll change this to 34 for alpha blending"
	].
	bb destX: 0; destY: 0; sourceX: 0; sourceY: 0; width: 1; height: 1.
	scanner spanBuffer: span.
	scanner bitBlt: bb.! !



!B3DSimulRasterizer methodsFor: 'testing' stamp: 'ar 4/18/1999 04:36'!
needsClip
	^true! !


!B3DSimulRasterizer methodsFor: 'processing' stamp: 'ar 4/18/1999 04:48'!
loadVerticesFrom: vb
	| out vtxArray |
	vtxArray _ vb vertexArray.
	out _ Array new: vb vertexCount.
	1 to: vb vertexCount do:[:i|
		out at: i put: (vtxArray at: i).
	].
	^out! !

!B3DSimulRasterizer methodsFor: 'processing' stamp: 'ar 4/18/1999 05:31'!
mainLoop
	scanner mainLoop.
	scanner resetObjects.! !

!B3DSimulRasterizer methodsFor: 'processing' stamp: 'ar 4/18/1999 07:34'!
processIndexedQuads: vb
	| vtxArray out idx1 idxArray idx2 idx3 face obj idx4 |
	vtxArray _ self loadVerticesFrom: vb.
	idxArray _ vb indexArray.
	out _ WriteStream on: (B3DIndexedTriangleArray new: vb indexCount // 3 * 2).
	1 to: vb indexCount by: 4 do:[:i|
		idx1 _ idxArray at: i.
		idx2 _ idxArray at: i+1.
		idx3 _ idxArray at: i+2.
		idx4 _ idxArray at: i+3.
		idx1 = 0 ifFalse:[
			face _ B3DIndexedTriangle with: idx1 with: idx2 with: idx3.
			out nextPut: face.
			face _ B3DIndexedTriangle with: idx3 with: idx4 with: idx1.
			out nextPut: face].
	].
	obj _ B3DPrimitiveObject new.
	obj faces: out contents.
	obj vertices: vtxArray.
	obj texture: texture.
	obj mapVertices: viewport.
	obj setupVertexOrder.
	obj sortInitialFaces.
	scanner addObject: obj.! !

!B3DSimulRasterizer methodsFor: 'processing' stamp: 'ar 4/18/1999 06:55'!
processIndexedTriangles: vb
	| vtxArray out idx1 idxArray idx2 idx3 face obj |
	vtxArray _ self loadVerticesFrom: vb.
	idxArray _ vb indexArray.
	out _ WriteStream on: (B3DIndexedTriangleArray new: vb indexCount // 3).
	1 to: vb indexCount by: 3 do:[:i|
		idx1 _ idxArray at: i.
		idx2 _ idxArray at: i+1.
		idx3 _ idxArray at: i+2.
		idx1 = 0 ifFalse:[
			face _ B3DIndexedTriangle with: idx1 with: idx2 with: idx3.
			out nextPut: face].
	].
	obj _ B3DPrimitiveObject new.
	obj faces: out contents.
	obj vertices: vtxArray.
	obj texture: texture.
	obj mapVertices: viewport.
	obj setupVertexOrder.
	obj sortInitialFaces.
	scanner addObject: obj.! !

!B3DSimulRasterizer methodsFor: 'processing' stamp: 'ar 4/18/1999 07:56'!
processPolygon: vb
	| vtxArray out face obj |
	vtxArray _ self loadVerticesFrom: vb.
	out _ WriteStream on: (B3DIndexedTriangleArray new: vtxArray size - 2).
	3 to: vb vertexCount do:[:i|
		face _ B3DIndexedTriangle with: 1 with: i-1 with: i.
		out nextPut: face.
	].
	obj _ B3DPrimitiveObject new.
	obj faces: out contents.
	obj vertices: vtxArray.
	obj texture: texture.
	obj mapVertices: viewport.
	obj setupVertexOrder.
	obj sortInitialFaces.
	scanner addObject: obj.! !

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

B3DSimulRasterizer class
	instanceVariableNames: ''!

!B3DSimulRasterizer class methodsFor: 'testing'!
isAvailable
	^true "Always"! !
B3DPositionalLight subclass: #B3DSpotLight
	instanceVariableNames: 'target minCos maxCos deltaCos direction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!

!B3DSpotLight methodsFor: 'initialize' stamp: 'ar 2/7/1999 18:44'!
from3DS: aDictionary
	"Initialize the receiver from a 3DS point light"
	| spotValues hotSpot fallOff |
	super from3DS: aDictionary.
	spotValues _ aDictionary at: #spot.
	target _ spotValues at: #target.
	hotSpot _ spotValues at: #hotspotAngle.
	self minAngle: hotSpot.
	fallOff _ spotValues at: #falloffAngle.
	self maxAngle: hotSpot + fallOff.! !


!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:18'!
direction
	^direction ifNil:[direction _ (target - position) safelyNormalize].! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/8/1999 01:40'!
direction: aVector
	direction _ aVector! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:47'!
hotSpotDeltaCosine
	^deltaCos! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:45'!
hotSpotMaxCosine
	^maxCos! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:45'!
hotSpotMinCosine
	^minCos! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:46'!
maxAngle
	^maxCos arcCos radiansToDegrees! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:25'!
maxAngle: angle
	minCos _ angle degreesToRadians cos.
	maxCos ifNotNil:[deltaCos _ maxCos - minCos].! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 18:46'!
minAngle
	^minCos arcCos radiansToDegrees! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:25'!
minAngle: angle
	maxCos _ angle degreesToRadians cos.
	minCos ifNotNil:[deltaCos _ maxCos - minCos].! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:16'!
target
	^target! !

!B3DSpotLight methodsFor: 'accessing' stamp: 'ar 2/7/1999 20:16'!
target: aVector
	target _ aVector! !


!B3DSpotLight methodsFor: 'testing' stamp: 'ar 2/15/1999 02:18'!
hasSpot
	^true! !


!B3DSpotLight methodsFor: 'converting' stamp: 'ar 2/15/1999 22:01'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight |
	primLight _ super asPrimitiveLight.
	primLight flags: (primLight flags bitOr: FlagHasSpot).
	primLight spotMinCos: minCos.
	primLight spotMaxCos: maxCos.
	primLight spotDeltaCos: deltaCos.
	primLight spotExponent: self spotExponent.
	primLight direction: (target - position) safelyNormalize.
	^primLight! !

!B3DSpotLight methodsFor: 'converting' stamp: 'ar 2/8/1999 01:39'!
transformedBy: aTransformer
	^(super transformedBy: aTransformer) 
		target: (aTransformer transformPosition: target);
		direction: nil! !
Form subclass: #B3DTexture
	instanceVariableNames: 'wrap interpolate envMode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Lights'!
!B3DTexture commentStamp: '<historical>' prior: 0!
I represent a simple 2D texture.

Instance variables:
	wrap		<Boolean>	If true, wrap the texture - otherwise clamp it.
	interpolate	<Boolean>	If true, interpolate the pixels of the texture.
	envMode	<Integer>	How we combine colors with the texture.
		Possible values:
			0 - OpenGL style modulate texture
			1 - OpenGL style decal texture!


!B3DTexture methodsFor: 'accessing' stamp: 'ar 6/9/2000 19:16'!
contentsOfArea: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	^self contentsOfArea: aRect 
		into: ((self class extent: aRect extent depth: depth)
				wrap: self wrap;
				envMode: self envMode;
				interpolate: self interpolate;
				yourself)! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:36'!
envMode
	^envMode! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:36'!
envMode: aNumber
	envMode _ aNumber.! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:33'!
interpolate
	^interpolate! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:34'!
interpolate: aBool
	interpolate _ aBool! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:34'!
wrap
	^wrap! !

!B3DTexture methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:33'!
wrap: aBool
	wrap _ aBool! !


!B3DTexture methodsFor: 'flipping' stamp: 'jsp 3/15/1999 14:20'!
flipVertically
	"Flip the texture vertically"

	| temp h w row |

	h _ self height.
	w _ self width.

	0 to: ((h // 2) - 1) do: [:i |
		row _ h - i - 1.
		1 to: w do: [:j |
				temp _ bits at: ((i * w) + j).
				bits at:  ((i * w) + j) put: (bits at: ((row * w) + j)).
				bits at: ((row * w) + j) put: temp.
					].
				].
! !


!B3DTexture methodsFor: 'converting' stamp: 'ar 5/27/1999 17:49'!
asTexture
	^self! !
B3DInplaceArray variableWordSubclass: #B3DTexture2Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!

!B3DTexture2Array methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:30'!
at: index put: value
	value isPoint
		ifTrue:[super at: index put: (B3DVector2 u: value x v: value y)]
		ifFalse:[super at: index put: value].
	^value! !

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

B3DTexture2Array class
	instanceVariableNames: ''!

!B3DTexture2Array class methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:31'!
contentsClass
	^B3DVector2! !
B3DEnginePlugin subclass: #B3DTransformerPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 5/22/2000 17:12'!
b3dInplaceHouseHolderInvert
	"Primitive. Perform an inplace house holder matrix inversion"
	| rcvr d x sigma beta sum s m |
	self export: true.
	self var: #rcvr declareC:'float *rcvr'.
	self var: #m declareC:'double m[4][4]'.
	self var: #x declareC:'double x[4][4] = { {1, 0, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1} }'.
	self var: #d declareC:'double d[4][4]'.
	self var: #sigma declareC:'double sigma'.
	self var: #beta declareC:'double beta'.
	self var: #sum declareC:'double sum'.
	self var: #s declareC:'double s'.

	self cCode:'' inSmalltalk:[
		m _ CArrayAccessor on: 
				((1 to: 4) collect:[:i| CArrayAccessor on: (Array new: 4)]).
		x _ CArrayAccessor on: (Array
				with: (CArrayAccessor on: #(1.0 0.0 0.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 1.0 0.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 0.0 1.0 0.0) copy)
				with: (CArrayAccessor on: #(0.0 0.0 0.0 1.0) copy)).
		d _ CArrayAccessor on: 
				((1 to: 4) collect:[:i| CArrayAccessor on: (Array new: 4)]).
	].
	rcvr _ self stackMatrix: 0.
	0 to: 3 do:[:i| 0 to: 3 do:[:j|
		(m at: i) at: j put: (rcvr at: i*4+j)]].
	0 to: 3 do:[:j|
		sigma := 0.0.
		j to: 3 do:[:i| sigma := sigma + (((m at: i) at: j)  * ((m at: i) at: j))].
		sigma < 1.0e-10 ifTrue:[^interpreterProxy primitiveFail]. "matrix is singular"
		(((m at: j) at: j) < 0.0) 
			ifTrue:[ s:= sigma sqrt]
			ifFalse:[ s:= 0.0 - sigma sqrt].
		0 to: 3 do:[:r| (d at: j) at: r put: s].
		beta := 1.0 / ( s * ((m at: j) at: j) - sigma).
		(m at: j) at: j put: (((m at: j) at: j) - s).
		"update remaining columns"
		j+1 to: 3 do:[:k|
			sum := 0.0.
			j to: 3 do:[:i| sum := sum + (((m at: i) at: j) * ((m at: i) at: k))].
			sum := sum * beta.
			j to: 3 do:[:i| 
				(m at: i) at: k put: (((m at: i) at: k) + (((m at: i) at: j) * sum))]].
		"update vector"
		0 to: 3 do:[:r|
			sum := 0.0.
			j to: 3 do:[:i| 
				sum _ sum + (((x at: i) at: r) * ((m at: i) at: j))].
			sum := sum * beta.
			j to: 3 do:[:i| 
				(x at: i) at: r put:(((x at: i) at: r) + (sum * ((m at: i) at: j)))].
		].
	].
	"Now calculate result"
	0 to: 3 do:[:r|
		3 to: 0 by: -1 do:[:i|
			i+1 to: 3 do:[:j|
				(x at: i) at: r put: (((x at: i) at: r) - (((x at: j) at: r) * ((m at: i) at: j))) ].
			(x at: i) at: r put: (((x at: i) at: r) / ((d at: i) at: r))].
	].
	0 to: 3 do:[:i| 0 to: 3 do:[:j|
		rcvr at: i*4+j put: (self cCoerce: ((x at: i) at: j) to:'float')]].
	"Return receiver"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 00:02'!
b3dTransformMatrixWithInto
	"Transform two matrices into the third"
	| m1 m2 m3 |
	self export: true.
	self inline: false.
	self var: #m1 declareC:'float *m1'.
	self var: #m2 declareC:'float *m2'.
	self var: #m3 declareC:'float *m3'.

	m3 _ self stackMatrix: 0.
	m2 _ self stackMatrix: 1.
	m1 _ self stackMatrix: 2.
	(m1 = nil) | (m2 = nil) | (m3 = nil) 
		ifTrue:[^interpreterProxy primitiveFail].
	m2 == m3 ifTrue:[^interpreterProxy primitiveFail].
	self transformMatrix: m1 with: m2 into: m3.
	interpreterProxy pop: 3. "Leave rcvr on stack"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 00:03'!
b3dTransformPrimitiveNormal
	"Transform the normal of the given primitive vertex using the argument matrix and rescale the normal if necessary."
	| pVertex matrix rescale |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self var: #pVertex declareC:'float *pVertex'.

	rescale _ interpreterProxy stackValue: 0.
	rescale == interpreterProxy nilObject 
		ifFalse:[rescale _ interpreterProxy booleanValueOf: rescale].
	matrix _ self stackMatrix: 1.
	pVertex _ self stackPrimitiveVertex: 2.
	(matrix = nil) | (pVertex = nil) 
		ifTrue:[^interpreterProxy primitiveFail].
	(rescale ~~ true and:[rescale ~~ false])
		ifTrue:[rescale _ self analyzeMatrix3x3Length: matrix].
	self transformPrimitiveNormal: pVertex by: matrix rescale: rescale.
	interpreterProxy pop: 3. "Leave rcvr on stack"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 00:03'!
b3dTransformPrimitivePosition
	"Transform the position of the given primitive vertex the given matrix
	and store the result back inplace."
	| pVertex matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self var: #pVertex declareC:'float *pVertex'.

	matrix _ self stackMatrix: 0.
	pVertex _ self stackPrimitiveVertex: 1.
	(matrix = nil) | (pVertex = nil) 
		ifTrue:[^interpreterProxy primitiveFail].
	self transformPrimitivePosition: pVertex by: matrix.
	interpreterProxy pop: 2. "Leave rcvr on stack"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 00:03'!
b3dTransformPrimitiveRasterPosition
	"Transform the position of the given primitive vertex the given matrix
	and store the result in homogenous coordinates at rasterPos."
	| pVertex matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self var: #pVertex declareC:'float *pVertex'.

	matrix _ self stackMatrix: 0.
	pVertex _ self stackPrimitiveVertex: 1.
	(matrix = nil) | (pVertex = nil) 
		ifTrue:[^interpreterProxy primitiveFail].
	self transformPrimitiveRasterPosition: pVertex by: matrix.
	interpreterProxy pop: 2. "Leave rcvr on stack"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 00:05'!
b3dTransformVertexBuffer
	"Transform an entire vertex buffer using the supplied modelview and projection matrix."
	| flags projectionMatrix modelViewMatrix vtxCount vtxArray |
	self export: true.
	self inline: false.
	self var: #projectionMatrix declareC:'float *projectionMatrix'.
	self var: #modelViewMatrix declareC:'float *modelViewMatrix'.
	self var: #vtxArray declareC:'float *vtxArray'.

	flags _ interpreterProxy stackIntegerValue: 0.
	projectionMatrix _ self stackMatrix: 1.
	modelViewMatrix _ self stackMatrix: 2.
	vtxCount _ interpreterProxy stackIntegerValue: 3.
	vtxArray _ self stackPrimitiveVertexArray: 4 ofSize: vtxCount.
	(projectionMatrix = nil) | (modelViewMatrix = nil) | (vtxArray = nil)
		ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifTrue:[^nil].
	self transformVB: vtxArray 
		count: vtxCount 
		by: modelViewMatrix 
		and: projectionMatrix 
		flags: flags.
	interpreterProxy pop: 5. "Leave rcvr on stack"! !

!B3DTransformerPlugin methodsFor: 'primitives' stamp: 'ar 2/17/1999 04:31'!
b3dTransformerVersion
	"Return the current version of the transformer"
	self export: true.
	self inline: false.
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: 1.	"Version 1"! !


!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 2/13/1999 23:45'!
analyzeMatrix3x3Length: m
	"Check if the matrix scales normals to non-unit length."
	| det |
	self var: #m declareC:'float *m'.
	self var: #det declareC:'double det'.
	det _ 	((m at: 0) * (m at: 5) * (m at: 10)) -
			((m at: 2) * (m at: 5) * (m at: 8)) + 
			((m at: 4) * (m at: 9) * (m at: 2)) - 
			((m at: 6) * (m at: 9) * (m at: 0)) +
			((m at: 8) * (m at: 1) * (m at: 6)) -
			((m at: 10) * (m at: 1) * (m at: 4)).
	^det < 0.99 or:[det > 1.01]! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 2/13/1999 23:45'!
analyzeMatrix: m
	"Analyze the matrix and return the appropriate flags"
	| flags |
	self var: #m declareC:'float *m'.
	"Check the perspective"
	flags _ 0.
	((m at: 12) = 0.0 and:[(m at: 13) = 0.0 and:[(m at: 14) = 0.0 and:[(m at: 15) = 1.0]]]) ifTrue:[
		flags _ flags bitOr: FlagM44NoPerspective.
		"Check translation"
		((m at: 3) = 0.0 and:[(m at: 7) = 0.0 and:[(m at: 11) = 0.0]]) ifTrue:[
			flags _ flags bitOr: FlagM44NoTranslation.
			"Check for identity"
			((m at: 0) = 1.0 and:[(m at: 5) = 1.0 and:[(m at: 10) = 1.0 and:[
				(m at: 1) = 0.0 and:[(m at: 2) = 0.0 and:[
				(m at: 4) = 0.0 and:[(m at: 6) = 0.0 and:[
				(m at: 8) = 0.0 and:[(m at: 9) = 0.0]]]]]]]]) ifTrue:[
					flags _ flags bitOr: FlagM44Identity.
			].
		].
	].
	^flags! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 2/13/1999 23:45'!
transformMatrix: src with: arg into: dst
	"Transform src with arg into dst.
	It is allowed that src == dst but not arg == dst"
	| m1 m2 m3 c1 c2 c3 c4 |
	self var: #src declareC:'float *src'.
	self var: #arg declareC:'float *arg'.
	self var: #dst declareC:'float *dst'.
	self var: #m1 declareC:'float *m1'.
	self var: #m2 declareC:'float *m2'.
	self var: #m3 declareC:'float *m3'.
	self var: #c1 declareC:'float c1'.
	self var: #c2 declareC:'float c2'.
	self var: #c3 declareC:'float c3'.
	self var: #c4 declareC:'float c4'.

	m1 _ self cCoerce: src to:'float *'.
	m2 _ self cCoerce: arg to: 'float *'.
	m3 _ self cCoerce: dst to: 'float *'.

	0 to: 3 do:[:i|

		"Compute next row"
		c1 _ ((m1 at: 0) * (m2 at: 0)) + ((m1 at: 1) * (m2 at: 4)) +
				((m1 at: 2) * (m2 at: 8)) + ((m1 at: 3) * (m2 at: 12)).

		c2 _ ((m1 at: 0) * (m2 at: 1)) + ((m1 at: 1) * (m2 at: 5)) +
				((m1 at: 2) * (m2 at: 9)) + ((m1 at: 3) * (m2 at: 13)).

		c3 _ ((m1 at: 0) * (m2 at: 2)) + ((m1 at: 1) * (m2 at: 6)) +
				((m1 at: 2) * (m2 at: 10)) + ((m1 at: 3) * (m2 at: 14)).

		c4 _ ((m1 at: 0) * (m2 at: 3)) + ((m1 at: 1) * (m2 at: 7)) +
				((m1 at: 2) * (m2 at: 11)) + ((m1 at: 3) * (m2 at: 15)).

		"Store result"
		m3 at: 0 put: c1.
		m3 at: 1 put: c2.
		m3 at: 2 put: c3.
		m3 at: 3 put: c4.

		"Skip src and dst to next row"
		m1 _ m1 + 4.
		m3 _ m3 + 4.
	].
! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 4/17/1999 22:22'!
transformPrimitiveNormal: pVertex by: matrix rescale: rescale
	"Transform the normal of the given primitive vertex"
	| x y z rx ry rz dot |
	self var: #pVertex declareC:'float *pVertex'.
	self var: #matrix declareC:'float *matrix'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #rx declareC:'double rx'.
	self var: #ry declareC:'double ry'.
	self var: #rz declareC:'double rz'.
	self var: #dot declareC:'double dot'.

	x _ pVertex at: PrimVtxNormalX.
	y _ pVertex at: PrimVtxNormalY.
	z _ pVertex at: PrimVtxNormalZ.

	rx _ (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)).
	ry _ (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)).
	rz _ (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)).

	rescale ifTrue:[
		dot _ (rx * rx) + (ry * ry) + (rz * rz).
		dot < 1.0e-20 
			ifTrue:[rx _ ry _ rz _ 0.0]
			ifFalse:[dot = 1.0 ifFalse:[dot _ 1.0 / dot sqrt.
									rx _ rx * dot. ry _ ry * dot. rz _ rz * dot]]].

	pVertex at: PrimVtxNormalX put: (self cCoerce: rx to:'float').
	pVertex at: PrimVtxNormalY put: (self cCoerce: ry to:'float').
	pVertex at: PrimVtxNormalZ put: (self cCoerce: rz to:'float').
! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 4/17/1999 22:24'!
transformPrimitivePosition: pVertex by: matrix
	"Transform the normal of the given primitive vertex"
	| x y z rx ry rz rw |
	self var: #pVertex declareC:'float *pVertex'.
	self var: #matrix declareC:'float *matrix'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #rx declareC:'double rx'.
	self var: #ry declareC:'double ry'.
	self var: #rz declareC:'double rz'.
	self var: #rw declareC:'double rw'.

	x _ pVertex at: PrimVtxPositionX.
	y _ pVertex at: PrimVtxPositionY.
	z _ pVertex at: PrimVtxPositionZ.

	rx _ (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)) + (matrix at: 3).
	ry _ (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)) + (matrix at: 7).
	rz _ (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)) + (matrix at: 11).
	rw _ (x * (matrix at: 12)) + (y * (matrix at: 13)) + (z * (matrix at: 14)) + (matrix at: 15).

	rw = 1.0 ifTrue:[
		pVertex at: PrimVtxPositionX put: (self cCoerce: rx to: 'float').
		pVertex at: PrimVtxPositionY put: (self cCoerce: ry to:'float').
		pVertex at: PrimVtxPositionZ put: (self cCoerce: rz to: 'float').
	] ifFalse:[
		rw = 0.0 
			ifTrue:[rw _ 0.0]
			ifFalse:[rw _ 1.0 / rw].
		pVertex at: PrimVtxPositionX put: (self cCoerce: rx*rw to:'float').
		pVertex at: PrimVtxPositionY put: (self cCoerce: ry*rw to:'float').
		pVertex at: PrimVtxPositionZ put: (self cCoerce: rz*rw to: 'float').
	].
! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 4/17/1999 22:24'!
transformPrimitivePositionFast: pVertex by: matrix
	"Transform the position of the given primitive vertex assuming that 
	matrix a41 = a42 = a43 = 0.0 and a44 = 1.0"
	| x y z rx ry rz |
	self var: #pVertex declareC:'float *pVertex'.
	self var: #matrix declareC:'float *matrix'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #rx declareC:'double rx'.
	self var: #ry declareC:'double ry'.
	self var: #rz declareC:'double rz'.

	x _ pVertex at: PrimVtxPositionX.
	y _ pVertex at: PrimVtxPositionY.
	z _ pVertex at: PrimVtxPositionZ.

	rx _ (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)) + (matrix at: 3).
	ry _ (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)) + (matrix at: 7).
	rz _ (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)) + (matrix at: 11).

	pVertex at: PrimVtxPositionX put: (self cCoerce: rx to: 'float').
	pVertex at: PrimVtxPositionY put: (self cCoerce: ry to: 'float').
	pVertex at: PrimVtxPositionZ put: (self cCoerce: rz to: 'float').! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 4/17/1999 22:25'!
transformPrimitivePositionFaster: pVertex by: matrix
	"Transform the position of the given primitive vertex assuming that 
	matrix a14 = a24 = a34 = a41 = a42 = a43 = 0.0 and a44 = 1.0"
	| x y z rx ry rz |
	self var: #pVertex declareC:'float *pVertex'.
	self var: #matrix declareC:'float *matrix'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #rx declareC:'double rx'.
	self var: #ry declareC:'double ry'.
	self var: #rz declareC:'double rz'.

	x _ pVertex at: PrimVtxPositionX.
	y _ pVertex at: PrimVtxPositionY.
	z _ pVertex at: PrimVtxPositionZ.

	rx _ (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)).
	ry _ (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)).
	rz _ (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)).

	pVertex at: PrimVtxPositionX put: (self cCoerce: rx to:'float').
	pVertex at: PrimVtxPositionY put: (self cCoerce: ry to:'float').
	pVertex at: PrimVtxPositionZ put: (self cCoerce: rz to: 'float').! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 4/17/1999 22:26'!
transformPrimitiveRasterPosition: pVertex by: matrix
	"Transform the normal of the given primitive vertex"
	| x y z rx ry rz rw |
	self var: #pVertex declareC:'float *pVertex'.
	self var: #matrix declareC:'float *matrix'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #z declareC:'double z'.
	self var: #rx declareC:'double rx'.
	self var: #ry declareC:'double ry'.
	self var: #rz declareC:'double rz'.
	self var: #rw declareC:'double rw'.

	x _ pVertex at: PrimVtxPositionX.
	y _ pVertex at: PrimVtxPositionY.
	z _ pVertex at: PrimVtxPositionZ.

	rx _ (x * (matrix at: 0)) + (y * (matrix at: 1)) + (z * (matrix at: 2)) + (matrix at: 3).
	ry _ (x * (matrix at: 4)) + (y * (matrix at: 5)) + (z * (matrix at: 6)) + (matrix at: 7).
	rz _ (x * (matrix at: 8)) + (y * (matrix at: 9)) + (z * (matrix at: 10)) + (matrix at: 11).
	rw _ (x * (matrix at: 12)) + (y * (matrix at: 13)) + (z * (matrix at: 14)) + (matrix at: 15).

	pVertex at: PrimVtxRasterPosX put: (self cCoerce: rx to:'float').
	pVertex at: PrimVtxRasterPosY put: (self cCoerce: ry to:'float').
	pVertex at: PrimVtxRasterPosZ put: (self cCoerce: rz to:'float').
	pVertex at: PrimVtxRasterPosW put: (self cCoerce: rw to:'float').
! !

!B3DTransformerPlugin methodsFor: 'transforming' stamp: 'ar 2/13/1999 23:47'!
transformVB: vtxArray count: vtxCount by: modelViewMatrix and: projectionMatrix flags: flags
	"Transform the entire vertex array by the given matrices"
	"TODO: Check the actual trade-offs between vtxCount and analyzing"
	| mvFlags prFlags pVertex hasNormals rescale |
	self var: #projectionMatrix declareC:'float *projectionMatrix'.
	self var: #modelViewMatrix declareC:'float *modelViewMatrix'.
	self var: #vtxArray declareC:'float *vtxArray'.
	self var: #pVertex declareC:'float *pVertex'.

	"Analyze the matrices for better performance"
	mvFlags _ self analyzeMatrix: modelViewMatrix.
	prFlags _ self analyzeMatrix: projectionMatrix.

	pVertex _ self cCoerce: vtxArray to: 'float *'.
	hasNormals _ flags anyMask: VBVtxHasNormals.

	"Check if we have to rescale the normals"
	hasNormals ifTrue:[
		(mvFlags anyMask: FlagM44Identity)
			ifTrue:[rescale _ false]
			ifFalse:[rescale _ self analyzeMatrix3x3Length: modelViewMatrix]].

	"<---- NOTE: The most likely case goes first ---->"
	((mvFlags anyMask: FlagM44NoPerspective) and:[prFlags = 0]) ifTrue:[
		"Modelview matrix has no perspective part and projection is not optimized"
		(mvFlags = FlagM44NoTranslation) = 0 ifTrue:[
			"Modelview matrix with translation"
			1 to: vtxCount do:[:i|
				hasNormals ifTrue:[self transformPrimitiveNormal: pVertex by: modelViewMatrix rescale: rescale].
				self transformPrimitivePositionFast: pVertex by: modelViewMatrix.
				self transformPrimitiveRasterPosition: pVertex by: projectionMatrix.
				pVertex _ pVertex + PrimVertexSize].
		] ifFalse:[
			"Modelview matrix without translation"
			1 to: vtxCount do:[:i|
				hasNormals ifTrue:[self transformPrimitiveNormal: pVertex by: modelViewMatrix rescale: rescale].
				self transformPrimitivePositionFaster: pVertex by: modelViewMatrix.
				self transformPrimitiveRasterPosition: pVertex by: projectionMatrix.
				pVertex _ pVertex + PrimVertexSize].
		].
		^nil]. "done"
	"<---- End of most likely case ---->"

	((mvFlags bitAnd: prFlags) anyMask: FlagM44Identity) ifTrue:[
		"If both are identity matrices just copy entries"
		1 to: vtxCount do:[:i|
			pVertex at: PrimVtxRasterPosX put: (pVertex at: PrimVtxPositionX).
			pVertex at: PrimVtxRasterPosY put: (pVertex at: PrimVtxPositionY).
			pVertex at: PrimVtxRasterPosZ put: (pVertex at: PrimVtxPositionZ).
			pVertex at: PrimVtxRasterPosW put: 1.0.
			pVertex _ pVertex + PrimVertexSize].
		^nil]."done"

	(mvFlags anyMask: FlagM44Identity) ifTrue:[
		"If model view matrix is identity just perform projection"
		1 to: vtxCount do:[:i|
			self transformPrimitiveRasterPosition: pVertex by: projectionMatrix.
			pVertex _ pVertex + PrimVertexSize].
		^nil]. "done"

	"<--- modelview matrix not identity --->"

	(prFlags anyMask: FlagM44Identity) ifTrue:[
		"If projection matrix is identity just transform and copy.
		Note: This case is not very likely so it's not been unrolled."
		1 to: vtxCount do:[:i|
			hasNormals ifTrue:[self transformPrimitiveNormal: pVertex by: modelViewMatrix rescale: rescale].
			mvFlags = (FlagM44NoPerspective + FlagM44NoPerspective) ifTrue:[
				self transformPrimitivePositionFaster: pVertex by: modelViewMatrix.
			] ifFalse:[mvFlags = FlagM44NoPerspective ifTrue:[
				self transformPrimitivePositionFast: pVertex by: modelViewMatrix.
			] ifFalse:[
				self transformPrimitivePosition: pVertex by: modelViewMatrix.
			]].
			pVertex at: PrimVtxRasterPosX put: (pVertex at: PrimVtxPositionX).
			pVertex at: PrimVtxRasterPosY put: (pVertex at: PrimVtxPositionY).
			pVertex at: PrimVtxRasterPosZ put: (pVertex at: PrimVtxPositionZ).
			pVertex at: PrimVtxRasterPosW put: 1.0.
			pVertex _ pVertex + PrimVertexSize].
		^nil]. "done"

	"<----- None of the matrices is identity ---->"

	"Generic transformation"
	1 to: vtxCount do:[:i|
		hasNormals ifTrue:[self transformPrimitiveNormal: pVertex by: modelViewMatrix rescale: rescale].
		self transformPrimitivePosition: pVertex by: modelViewMatrix.
		self transformPrimitiveRasterPosition: pVertex by: projectionMatrix.
		pVertex _ pVertex + PrimVertexSize].! !
B3DFloatArray variableWordSubclass: #B3DVector2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DVector2 commentStamp: '<historical>' prior: 0!
I represent simple 2D coordinates in the Balloon 3D framework. I may be used to represent both, 2D points and 2D texture coordinates. !


!B3DVector2 methodsFor: 'initialize' stamp: 'ar 2/6/1999 23:30'!
u: uValue v: vValue
	self u: uValue.
	self v: vValue.! !

!B3DVector2 methodsFor: 'initialize' stamp: 'ar 5/4/2000 15:50'!
x: uValue y: vValue
	self x: uValue.
	self y: vValue.! !


!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:26'!
u
	^self floatAt: 1! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:27'!
u: aFloat
	self floatAt: 1 put: aFloat! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:27'!
v
	^self floatAt: 2! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/6/1999 23:27'!
v: aFloat
	self floatAt: 2 put: aFloat! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:58'!
x
	^self at: 1! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 5/4/2000 16:00'!
x: aFloat
	self floatAt: 1 put: aFloat! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:58'!
y
	^self at: 2! !

!B3DVector2 methodsFor: 'accessing' stamp: 'ar 5/4/2000 16:00'!
y: aFloat
	self floatAt: 2 put: aFloat! !


!B3DVector2 methodsFor: 'converting' stamp: 'ar 2/13/1999 20:03'!
asPoint
	^self x @ self y! !

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

B3DVector2 class
	instanceVariableNames: ''!

!B3DVector2 class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 23:31'!
numElements
	^2! !

!B3DVector2 class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 23:31'!
u: uValue v: vValue
	^self new u: uValue v: vValue! !

!B3DVector2 class methodsFor: 'instance creation' stamp: 'ar 5/4/2000 15:49'!
x: uValue y: vValue
	^self new x: uValue y: vValue! !
B3DInplaceArray variableWordSubclass: #B3DVector2Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!

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

B3DVector2Array class
	instanceVariableNames: ''!

!B3DVector2Array class methodsFor: 'instance creation' stamp: 'ar 5/4/2000 15:59'!
contentsClass
	^B3DVector2! !
B3DFloatArray variableWordSubclass: #B3DVector3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DVector3 commentStamp: '<historical>' prior: 0!
I represent simple 3D coordinates, used throughout the entire Balloon 3D engine.!


!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
x
	^self at: 1! !

!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
x: aFloat
	self at: 1 put: aFloat! !

!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
y
	^self at: 2! !

!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
y: aFloat
	self at: 2 put: aFloat! !

!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
z
	^self at: 3! !

!B3DVector3 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:24'!
z: aFloat
	self at: 3 put: aFloat! !


!B3DVector3 methodsFor: 'vector functions'!
cross: aVector 
	"calculate the cross product from the receiver with aVector"
	^self species
		x: self y * aVector z - (aVector y * self z)
		y: self z * aVector x - (aVector z * self x)
		z: self x * aVector y - (aVector x * self y)! !

!B3DVector3 methodsFor: 'vector functions'!
length: newLength
	self safelyNormalize *= newLength! !

!B3DVector3 methodsFor: 'vector functions' stamp: 'ar 2/6/1999 00:32'!
max: aVector
	^B3DVector3 
		x: (self x max: aVector x)
		y: (self y max: aVector y)
		z: (self z max: aVector z)! !

!B3DVector3 methodsFor: 'vector functions' stamp: 'ar 2/6/1999 00:31'!
min: aVector
	^B3DVector3 
		x: (self x min: aVector x)
		y: (self y min: aVector y)
		z: (self z min: aVector z)! !

!B3DVector3 methodsFor: 'vector functions'!
normalize
	self /= self length! !

!B3DVector3 methodsFor: 'vector functions'!
normalized
	^self / self length! !

!B3DVector3 methodsFor: 'vector functions' stamp: 'ar 2/7/1999 00:43'!
safelyNormalize
	"Safely normalize the receiver, e.g. check if the length is non-zero"
	| length |
	length _ self length.
	length = 1.0 ifTrue:[^self].
	length = 0.0 ifFalse:[self /= length].! !

!B3DVector3 methodsFor: 'vector functions'!
safelyNormalized
	"Safely normalize the receiver, e.g. check if the length is non-zero"
	^self copy safelyNormalize! !

!B3DVector3 methodsFor: 'vector functions'!
squaredLength: newLength
	self length: newLength sqrt! !


!B3DVector3 methodsFor: 'private'!
privateLoadFrom: srcObject
	self x: srcObject x y: srcObject y z: srcObject z.! !


!B3DVector3 methodsFor: 'initialize'!
x: x y: y z: z
	self x: x.
	self y: y.
	self z: z.! !


!B3DVector3 methodsFor: 'converting' stamp: 'ar 2/6/1999 00:06'!
asB3DVector3
	^self! !

!B3DVector3 methodsFor: 'converting' stamp: 'ar 2/6/1999 00:07'!
asB3DVector4
	^B3DVector4 x: self x y: self y z: self z w: 1.0! !


!B3DVector3 methodsFor: 'interpolating' stamp: 'jsp 2/9/1999 11:17'!
interpolateTo: end at: amountDone
	"Interpolates a new vector based on the instance vector, the end state vector, and the amount already done (between 0 and 1)."

	| tX tY tZ |
	tX _ self x.
	tY _ self y.
	tZ _ self z.

	^ (B3DVector3 x: (tX + (((end x) - tX) * amountDone))
				y: (tY + (((end y) - tY) * amountDone))
				z: (tZ + (((end z) - tZ) * amountDone))).
! !


!B3DVector3 methodsFor: 'testing' stamp: 'laza 3/16/2000 16:30'!
isZero
	^self = B3DVector3 zero! !

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

B3DVector3 class
	instanceVariableNames: ''!

!B3DVector3 class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:23'!
numElements
	^3! !

!B3DVector3 class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 02:56'!
value: aFloat
	^self x: aFloat y: aFloat z: aFloat! !

!B3DVector3 class methodsFor: 'instance creation'!
x: x y: y z: z
	^self new x: x y: y z: z! !

!B3DVector3 class methodsFor: 'instance creation'!
zero
	^self new! !
B3DInplaceArray variableWordSubclass: #B3DVector3Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Arrays'!

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

B3DVector3Array class
	instanceVariableNames: ''!

!B3DVector3Array class methodsFor: 'instance creation' stamp: 'ar 2/5/1999 22:51'!
contentsClass
	^B3DVector3! !
B3DFloatArray variableWordSubclass: #B3DVector4
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Vectors'!
!B3DVector4 commentStamp: '<historical>' prior: 0!
I represent 3D points in homogenous coordinates.!


!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:16'!
w
	^self at: 4! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:17'!
w: aFloat
	self at: 4 put: aFloat! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:16'!
x
	^self at: 1! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:17'!
x: aFloat
	self at: 1 put: aFloat! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:16'!
y
	^self at: 2! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:17'!
y: aFloat
	self at: 2 put: aFloat! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:16'!
z
	^self at: 3! !

!B3DVector4 methodsFor: 'accessing' stamp: 'ar 2/1/1999 21:17'!
z: aFloat
	self at: 3 put: aFloat! !


!B3DVector4 methodsFor: 'private'!
privateLoadFrom: srcObject
	self x: srcObject x y: srcObject y z: srcObject z w: srcObject w.! !


!B3DVector4 methodsFor: 'initialize'!
x: x y: y z: z w: w
	self x: x.
	self y: y.
	self z: z.
	self w: w.! !


!B3DVector4 methodsFor: 'converting' stamp: 'ar 2/6/1999 00:08'!
asB3DVector3
	| wValue |
	wValue _ self w.
	wValue = 0.0 ifTrue:[^B3DVector3 zero].
	^B3DVector3 x: self x / wValue y: self y / wValue z: self z / wValue! !

!B3DVector4 methodsFor: 'converting' stamp: 'ar 2/6/1999 00:07'!
asB3DVector4
	^self! !

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

B3DVector4 class
	instanceVariableNames: ''!

!B3DVector4 class methodsFor: 'instance creation' stamp: 'ar 2/1/1999 21:21'!
numElements
	^4! !

!B3DVector4 class methodsFor: 'instance creation'!
x: x y: y z: z
	^self x: x y: y z: z w: 1.0! !

!B3DVector4 class methodsFor: 'instance creation'!
x: x y: y z: z w: w
	^self new x: x y: y z: z w: w! !

!B3DVector4 class methodsFor: 'instance creation'!
zero
	^self new! !
Object subclass: #B3DVertexBuffer
	instanceVariableNames: 'current vertexArray vertexCount indexArray indexCount primitive clipFlags flags '
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Engine'!
!B3DVertexBuffer commentStamp: '<historical>' prior: 0!
I represent the vertex buffer passed on throughout the entire Balloon 3D rendering pipeline. I store all information that may be needed by either part of the pipeline.

Instance variables:
	current 		<B3DPrimitiveVertex>	Tracking the current attributes of vertices
	vertexArray 	<B3DPrimitiveVertexArray>	Container for all primitive vertices
	vertexCount 	<Integer>	The number of vertices in the vertex array
	indexArray 		<WordArray>	Stores the indexes for indexed primitives
	indexCount 		<Integer>	Number of indexes in the index array
	primitive 		<Integer>	The type of primitive currently in the buffer
	clipFlags 		<Integer>	The clip mask of the vertices in the buffer
	flags			<Integer>	Various state flags !


!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:44'!
clipFlags
	^clipFlags! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:44'!
clipFlags: aNumber
	clipFlags _ aNumber! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/8/1999 17:39'!
flags
	^flags! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/8/1999 17:40'!
flags: newFlags
	"Note: should be used with CARE!!"
	flags _ newFlags! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:13'!
indexArray
	^indexArray! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:13'!
indexArray: aWordArray
	indexArray _ aWordArray! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:13'!
indexCount
	^indexCount! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/7/1999 02:14'!
indexCount: aNumber
	indexCount _ aNumber! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:48'!
primitive
	^primitive! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:49'!
primitive: aNumber
	primitive _ aNumber.! !

!B3DVertexBuffer methodsFor: 'accessing'!
vertexArray
	^vertexArray! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:44'!
vertexArray: aB3DVertexArray
	vertexArray _ aB3DVertexArray! !

!B3DVertexBuffer methodsFor: 'accessing'!
vertexCount
	^vertexCount! !

!B3DVertexBuffer methodsFor: 'accessing' stamp: 'ar 2/5/1999 18:44'!
vertexCount: aNumber
	vertexCount _ aNumber! !


!B3DVertexBuffer methodsFor: 'initialize' stamp: 'ar 2/13/1999 20:24'!
initialize
	vertexArray _ B3DPrimitiveVertexArray new: 100.
	vertexCount _ 0.
	indexArray _ WordArray new: 100.
	indexCount _ 0.
	current _ B3DPrimitiveVertex new.
	flags _ 0.
	primitive _ nil.! !

!B3DVertexBuffer methodsFor: 'initialize' stamp: 'ar 2/13/1999 20:24'!
reset
	vertexCount _ 0.
	indexCount _ 0.! !


!B3DVertexBuffer methodsFor: 'attributes'!
color
	^current color! !

!B3DVertexBuffer methodsFor: 'attributes'!
color: aColor
	current color: aColor! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/15/1999 00:09'!
loadIndexed: idxArray vertices: vertices normals: normals colors: colors texCoords: texCoords
	| vtxSize idxSize maxVtx maxIdx |
	"Check the size of the vertex array"
	vtxSize _ vertices size.	
	vertexCount + vtxSize >= vertexArray size ifTrue:[
		self growVertexArray: (vtxSize + vertexArray size + 100).
	].
	"Check the size of the index array"
	idxSize _ idxArray basicSize.
	indexCount + idxSize >= indexArray size ifTrue:[
		self growIndexArray: (idxSize + indexArray size + 100).
	].
	"Check the sizes of normals, colors, and texCoords"
	(normals notNil and:[vtxSize ~= normals size]) ifTrue:[^self errorSizeMismatch].
	(colors notNil and:[vtxSize ~= colors size]) ifTrue:[^self errorSizeMismatch].
	(texCoords notNil and:[vtxSize ~= texCoords size]) ifTrue:[^self errorSizeMismatch].
	"Turn off the appropriate flags if no attributes are given.
	Default to having vertex normals and texture coords."
	flags _ flags bitOr: (VBVtxHasNormals + VBVtxHasTexCoords).
	"Turn off tracking flags if no colors are given"
	colors ifNil:[flags _ flags bitAnd: VBNoTrackMask].
	normals ifNil:[flags _ flags bitAnd: VBVtxHasNormals bitInvert32].
	texCoords ifNil:[flags _ flags bitAnd: VBVtxHasTexCoords bitInvert32].
	"Load the vertices"
	maxVtx _ self primLoadVB: vertexArray
					startingAt: vertexCount
					vertices: vertices 
					normals: normals 
					colors: colors 
					texCoords: texCoords 
					count: vtxSize
					default: current.
	"Load the indexes"
	maxIdx _ self 
				primLoadIndexArrayInto: indexArray 
				startingAt: indexCount 
				from: idxArray 
				count: idxSize 
				max: maxVtx 
				offset: vertexCount.
	"Adjust the size of the vertex array and the index array"
	vertexCount _ vertexCount + maxVtx.
	indexCount _ indexCount + maxIdx.! !

!B3DVertexBuffer methodsFor: 'attributes'!
normal
	^current normal! !

!B3DVertexBuffer methodsFor: 'attributes'!
normal: aVector
	current normal: aVector! !

!B3DVertexBuffer methodsFor: 'attributes'!
texCoords
	^current texCoords! !

!B3DVertexBuffer methodsFor: 'attributes'!
texCoords: aVector
	current texCoords: aVector! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/8/1999 17:37'!
trackAmbientColor: aBool
	aBool
		ifTrue:[flags _ flags bitOr: VBTrackAmbient]
		ifFalse:[flags _ flags bitAnd: VBTrackAmbient bitInvert32]! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/8/1999 17:37'!
trackDiffuseColor: aBool
	aBool
		ifTrue:[flags _ flags bitOr: VBTrackDiffuse]
		ifFalse:[flags _ flags bitAnd: VBTrackDiffuse bitInvert32]! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/8/1999 17:37'!
trackEmissionColor: aBool
	aBool
		ifTrue:[flags _ flags bitOr: VBTrackEmission]
		ifFalse:[flags _ flags bitAnd: VBTrackEmission bitInvert32]! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/8/1999 17:37'!
trackSpecularColor: aBool
	aBool
		ifTrue:[flags _ flags bitOr: VBTrackSpecular]
		ifFalse:[flags _ flags bitAnd: VBTrackSpecular bitInvert32]! !

!B3DVertexBuffer methodsFor: 'attributes'!
vertex
	^current position! !

!B3DVertexBuffer methodsFor: 'attributes' stamp: 'ar 2/7/1999 04:05'!
vertex: aVector
	current position: aVector.
	self addPrimitiveVertex: current.! !


!B3DVertexBuffer methodsFor: 'private' stamp: 'ar 2/7/1999 02:31'!
errorSizeMismatch
	^self error:'Vertex size mismatch'! !

!B3DVertexBuffer methodsFor: 'private' stamp: 'ar 2/7/1999 02:41'!
growIndexArray: newSize
	| newIdxArray |
	newIdxArray _ indexArray species new: newSize.
	newIdxArray replaceFrom: 1 to: indexArray size with: indexArray startingAt: 1.
	indexArray _ newIdxArray.! !

!B3DVertexBuffer methodsFor: 'private' stamp: 'ar 4/14/1999 02:35'!
growVertexArray: newSize
	| newVtxArray |
	newVtxArray _ vertexArray species new: newSize.
	newVtxArray privateReplaceFrom: 1 to: vertexArray basicSize with: vertexArray startingAt: 1.
	vertexArray _ newVtxArray.! !


!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:32'!
hasVertexNormals
	^flags anyMask: VBVtxHasNormals! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:32'!
hasVertexTexCoords
	^flags anyMask: VBVtxHasTexCoords! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:32'!
trackAmbientColor
	"Return true if the vertex colors override the ambient part of material entries."
	^flags anyMask: VBTrackAmbient! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:32'!
trackDiffuseColor
	"Return true if the vertex colors override the diffuse part of material entries."
	^flags anyMask: VBTrackDiffuse! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:32'!
trackEmissionColor
	"Return true if the vertex colors override the emissive part of material entries."
	^flags anyMask: VBTrackEmission! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:33'!
trackSpecularColor
	"Return true if the vertex colors override the specular part of material entries."
	^flags anyMask: VBTrackSpecular! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:35'!
twoSidedLighting
	"Return true if we shade front and back facing polygons differently"
	^flags anyMask: VBTwoSidedLighting! !

!B3DVertexBuffer methodsFor: 'testing' stamp: 'ar 2/8/1999 17:35'!
useLocalViewer
	^flags anyMask: VBUseLocalViewer! !


!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 4/19/1999 16:16'!
addClipIndex: index
	"Add a primitive index to the list of indexes."
	indexCount >= indexArray size 
		ifTrue:[self growIndexArray: indexCount + (indexCount // 4) + 10].
	indexArray at: (indexCount _ indexCount + 1) put: index.! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 4/19/1999 16:16'!
addClipVertex: pVtx
	"Add a primitive vertex to the list of vertices processed.
	Return the index of the vertex."
	vertexCount >= vertexArray size 
		ifTrue:[self growVertexArray: vertexCount + (vertexCount // 4) + 10].
	vertexArray at: (vertexCount _ vertexCount + 1) put: pVtx.
	^vertexCount! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 23:13'!
addPrimitiveIndex: index
	"Add a primitive index to the list of indexes."
	indexCount >= indexArray size 
		ifTrue:[self growIndexArray: indexCount * 3 // 2 + 100].
	indexArray at: (indexCount _ indexCount + 1) put: index.! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 04:02'!
addPrimitiveVertex: pVtx
	"Add a primitive vertex to the list of vertices processed.
	Return the index of the vertex."
	vertexCount >= vertexArray size 
		ifTrue:[self growVertexArray: vertexCount * 3 // 2 + 100].
	vertexArray at: (vertexCount _ vertexCount + 1) put: pVtx.
	^vertexCount! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 23:16'!
growForClip
	vertexCount*2+100 > vertexArray size ifTrue:[self growVertexArray: vertexCount*2+100].
	indexCount*2+100 > indexArray size ifTrue:[self growIndexArray: indexCount*2+100].! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 16:07'!
primitiveColorAt: index
	^(vertexArray at: index) color! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 04:04'!
primitiveIndexAt: index
	^indexArray at: index! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 04:05'!
primitiveIndexAt: index put: value
	^indexArray at: index put: value! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 04:04'!
primitiveVertexAt: index
	^vertexArray at: index! !

!B3DVertexBuffer methodsFor: 'protected' stamp: 'ar 2/7/1999 04:04'!
primitiveVertexAt: index put: aPrimitiveVertex
	^vertexArray at: index put: aPrimitiveVertex! !


!B3DVertexBuffer methodsFor: 'primitives' stamp: 'ar 4/5/1999 11:48'!
primLoadIndexArrayInto: dstArray startingAt: dstStart from: idxArray count: count max: maxValue offset: vtxOffset
	"Primitive. Load the given index array into the receiver.
	NOTE: dstStart is a zero-based index."
	| idx |
	<primitive:'b3dLoadIndexArray' module:'Squeak3D'>
	"self flag: #b3dDebug.	self primitiveFailed."
	1 to: count do:[:i|
		idx _ idxArray basicAt: i.
		(idx < 1 or:[idx > maxValue]) ifTrue:[^self error:'Index out of range'].
		dstArray at: dstStart + i put: idx + vtxOffset.
	].
	^count! !

!B3DVertexBuffer methodsFor: 'primitives' stamp: 'ar 4/5/1999 11:48'!
primLoadVB: dstArray startingAt: dstStart vertices: vertices normals: normals colors: colors texCoords: texCoords count: count default: defaultValues
	| hasNormals hasColors hasTexCoords pVtx defaultNormal defaultColor defaultTexCoords |
	<primitive:'b3dLoadVertexBuffer' module:'Squeak3D'>
	"self flag: #b3dDebug.	self primitiveFailed."
	defaultNormal _ defaultValues normal.
	defaultColor _ defaultValues color.
	defaultTexCoords _ defaultValues texCoords.
	hasNormals _ normals notNil.
	hasColors _ colors notNil.
	hasTexCoords _ texCoords notNil.
	1 to: count do:[:i|
		pVtx _ dstArray at: dstStart + i.
		pVtx position: (vertices at: i).
		pVtx normal: (hasNormals ifTrue:[normals at: i] ifFalse:[defaultNormal]).
		pVtx color: (hasColors ifTrue:[colors at: i] ifFalse:[defaultColor]).
		pVtx texCoords: (hasTexCoords ifTrue:[texCoords at: i] ifFalse:[defaultTexCoords]).
		dstArray at: dstStart + i put: pVtx.
	].
	^count! !

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

B3DVertexBuffer class
	instanceVariableNames: ''!

!B3DVertexBuffer class methodsFor: 'instance creation'!
new
	^super new initialize! !
B3DEnginePlugin subclass: #B3DVertexBufferPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!B3DVertexBufferPlugin methodsFor: 'primitives' stamp: 'ar 2/14/1999 23:32'!
b3dLoadIndexArray
	"Primitive. Load the given index array into the receiver.
	NOTE: dstStart is a zero-based index."
	| vtxOffset maxValue count srcArray srcPtr idx dstStart dstArray dstSize dstPtr |
	self export: true.
	self inline: false.
	self var: #dstPtr declareC:'int *dstPtr'.
	self var: #srcPtr declareC:'int *srcPtr'.
	"Load the arguments"
	vtxOffset _ interpreterProxy stackIntegerValue: 0.
	maxValue _ interpreterProxy stackIntegerValue: 1.
	count _ interpreterProxy stackIntegerValue: 2.
	srcArray _ interpreterProxy stackObjectValue: 3.
	dstStart _ interpreterProxy stackIntegerValue: 4.
	dstArray _ interpreterProxy stackObjectValue: 5.
	interpreterProxy failed ifTrue:[^nil]. "Will cover all possible problems above"
	"Check srcArray"
	(interpreterProxy isWords: srcArray)
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy slotSizeOf: srcArray) < count)
		ifTrue:[^interpreterProxy primitiveFail].
	srcPtr _ self cCoerce: (interpreterProxy firstIndexableField: srcArray) to:'int*'.
	"Check dstArray"
 	dstSize _ interpreterProxy slotSizeOf: dstArray.
	"Check if there is enough room left in dstArray"
	dstStart + count > dstSize
		ifTrue:[^interpreterProxy primitiveFail].
	dstPtr _ self cCoerce: (interpreterProxy firstIndexableField: dstArray) to:'int *'.
	"Do the actual work"
	0 to: count-1 do:[:i|
		idx _ srcPtr at: i.
		(idx < 1 or:[idx > maxValue]) 
			ifTrue:[^interpreterProxy primitiveFail].
		dstPtr at: dstStart + i put: idx + vtxOffset.
	].
	"Clean up the stack"
	interpreterProxy pop: 7. "Pop args+rcvr"
	interpreterProxy pushInteger: count.
! !

!B3DVertexBufferPlugin methodsFor: 'primitives' stamp: 'ar 11/20/2000 22:48'!
b3dLoadVertexBuffer
	"Primitive. Load the data into the given vertex buffer.
	NOTE: dstStart is a zero-based index."
	| defaultVtx defaultNormal defaultTexCoords defaultColor count texPtr colorPtr normalPtr vtxPtr dstStart dstPtr pVtx |

	self export: true.
	self inline: false.

	self var: #defaultVtx declareC:'int *defaultVtx'.
	self var: #defaultNormal declareC:'int *defaultNormal'.
	self var: #defaultTexCoords declareC:'int *defaultTexCoords'.
	self var: #defaultColor declareC:'int *defaultColor'.

	self var: #texPtr declareC:'int *texPtr'.
	self var: #colorPtr declareC:'int *colorPtr'.
	self var: #normalPtr declareC:'int *normalPtr'.
	self var: #vtxPtr declareC:'int *vtxPtr'.
	self var: #dstPtr declareC:'int *dstPtr'.
	self var: #pVtx declareC:'int *pVtx'.

	defaultVtx _ self stackPrimitiveVertex: 0.
	count _ interpreterProxy stackIntegerValue: 1.
	texPtr _ self vbLoadArray: (interpreterProxy stackObjectValue: 2) 
				size: 2*count.
	colorPtr _ self vbLoadArray: (interpreterProxy stackObjectValue: 3) 
				size: count.
	normalPtr _ self vbLoadArray: (interpreterProxy stackObjectValue: 4) 
				size: 3*count.
	vtxPtr _ self vbLoadArray: (interpreterProxy stackObjectValue: 5) 
				size: 3*count.
	dstStart _ interpreterProxy stackIntegerValue: 6.
	dstPtr _ self stackPrimitiveVertexArray: 7 ofSize: dstStart + count.
	"Check for all problems above"
	(dstPtr = nil or:[defaultVtx == nil or:[interpreterProxy failed]]) 
		ifTrue:[^interpreterProxy primitiveFail].

	"Install default values"
	normalPtr = nil
		ifTrue:[defaultNormal _ defaultVtx + PrimVtxNormal]
		ifFalse:[defaultNormal _ normalPtr].
	texPtr = nil
		ifTrue:[defaultTexCoords _ defaultVtx + PrimVtxTexCoords]
		ifFalse:[defaultTexCoords _ texPtr].
	colorPtr = nil
		ifTrue:[defaultColor _ defaultVtx + PrimVtxColor32]
		ifFalse:[defaultColor _ colorPtr].
	"Do the actual stuff"
	pVtx _ dstPtr + (dstStart * PrimVertexSize).
	0 to: count-1 do:[:i|
		pVtx at: PrimVtxPositionX put: (vtxPtr at: 0).
		pVtx at: PrimVtxPositionY put: (vtxPtr at: 1).
		pVtx at: PrimVtxPositionZ put: (vtxPtr at: 2).
		pVtx at: PrimVtxNormalX put: (defaultNormal at: 0).
		pVtx at: PrimVtxNormalY put: (defaultNormal at: 1).
		pVtx at: PrimVtxNormalZ put: (defaultNormal at: 2).
		pVtx at: PrimVtxColor32 put: (defaultColor at: 0).
		pVtx at: PrimVtxTexCoordU put: (defaultTexCoords at: 0).
		pVtx at: PrimVtxTexCoordV put: (defaultTexCoords at: 1).
		"And go to the next vertex"
		pVtx _ pVtx + PrimVertexSize.
		vtxPtr _ vtxPtr + 3.
		normalPtr = nil ifFalse:[defaultNormal _ defaultNormal + 3].
		colorPtr = nil ifFalse:[defaultColor _ defaultColor + 1].
		texPtr = nil ifFalse:[defaultTexCoords _ defaultTexCoords + 2].
	].
	"Clean up stack"
	interpreterProxy pop: 9. "Pop args+rcvr"
	interpreterProxy pushInteger: count.! !


!B3DVertexBufferPlugin methodsFor: 'private' stamp: 'ar 4/17/1999 22:29'!
vbLoadArray: oop size: count
	"Load the word based array of size count from the given oop"
	self returnTypeC: 'void*'.
	self inline: false.
	oop == nil ifTrue:[interpreterProxy primitiveFail. ^nil].
	oop == interpreterProxy nilObject ifTrue:[^nil].
	(interpreterProxy isWords: oop) 
		ifFalse:[interpreterProxy primitiveFail. ^nil].
	(interpreterProxy slotSizeOf: oop) = count
		ifFalse:[interpreterProxy primitiveFail. ^nil].
	^interpreterProxy firstIndexableField: oop! !
B3DEnginePart subclass: #B3DVertexClipper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Engine'!
!B3DVertexClipper commentStamp: '<historical>' prior: 0!
I provide clipping capabilities for rasterizers needing explicit clipping.!


!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 11/7/2000 17:24'!
postProcessVertexBuffer: vb
	"Clip individual items depending on the primitive type"
	vb growForClip. "Make sure we have enough space during primitive operation"
	^super processVertexBuffer: vb.! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 11/7/2000 17:24'!
preProcessVertexBuffer: vb
	"Clip the elements in the vertex buffer. Return true if all vertices are inside.
	Return false if all vertices are outside. If partial clipping occurs, return nil."
	| fullMask |
	fullMask _ self determineClipFlags: vb vertexArray count: vb vertexCount.
	vb clipFlags: fullMask.
	"Check if all vertices are inside, so no clipping is necessary"
	(fullMask allMask: InAllMask) ifTrue:[^true].
	"Check if all vertices are outside, so we can get rid of the entire buffer"
	(fullMask anyMask: OutAllMask) ifTrue:[
		"Reset the number of vertices in the vertex buffer to zero to indicate all outside"
		vb reset.
		^false].
	^nil! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 4/17/1999 23:06'!
processIndexedLines: vb
	"Process an indexed line set"
	^self error:'Lines are not yet implemented'! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 9/17/1999 20:08'!
processIndexedQuads: vb
	"Clip an indexed quad set"
	| vtxArray idxArray tempVB idx1 idx2 idx3 maxVtx maxIdx index lastIndex clipFlags vtx returnValue |
	self flag: #b3dPrimitive.
	returnValue _ false. "Assume we don't see nothing"
	tempVB _ B3DVertexBuffer new.
	vtxArray _ vb vertexArray.
	idxArray _ vb indexArray.
	maxVtx _ vb indexCount.
	maxIdx _ vb indexCount.
	lastIndex _ -3. "Hack the lastIndex ;-)"
	[index _ self primNextClippedQuadAfter: lastIndex + 4
					vertices: vtxArray count: maxVtx
					indexes: idxArray count: maxIdx.
	index = 0] whileFalse:[
		"Need a partial clip here, storing the triangulated polygon at the end"
		tempVB reset.
		clipFlags _ InAllMask + OutAllMask.
		"Copy the poly into tempVB"
		0 to: 3 do:[:i|
			vtx _ vtxArray at: (idxArray at: index+i).
			idxArray at: index+i put: 0.
			tempVB addClipVertex: vtx.
			clipFlags _ clipFlags bitAnd: vtx clipFlags].
		tempVB clipFlags: clipFlags.
		self processPolygon: tempVB.
		tempVB vertexCount > 2 ifTrue:[
			returnValue _ nil. "We see some parts and not others"
			idx1 _ vb addClipVertex: (tempVB vertexArray at: 1).
			3 to: tempVB vertexCount do:[:j|
				idx2 _ vb addClipVertex: (tempVB vertexArray at: j-1).
				idx3 _ vb addClipVertex: (tempVB vertexArray at: j).
				vb addClipIndex: idx1.
				vb addClipIndex: idx2.
				vb addClipIndex: idx3.
				vb addClipIndex: idx3.
			].
		].
		lastIndex _ index.
	].
	^returnValue! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 9/17/1999 20:08'!
processIndexedTriangles: vb
	"Clip an indexed triangle set"
	| vtxArray idxArray tempVB idx1 idx2 idx3 maxVtx maxIdx index lastIndex clipFlags vtx returnValue |
	self flag: #b3dPrimitive.
	returnValue _ false. "Assume we don't see nothing"
	tempVB _ B3DVertexBuffer new.
	vtxArray _ vb vertexArray.
	idxArray _ vb indexArray.
	maxVtx _ vb indexCount.
	maxIdx _ vb indexCount.
	lastIndex _ -2. "Hack the lastIndex ;-)"
	[index _ self primNextClippedTriangleAfter: lastIndex + 3
					vertices: vtxArray count: maxVtx
					indexes: idxArray count: maxIdx.
	index = 0] whileFalse:[
		"Need a partial clip here, storing the triangulated polygon at the end"
		tempVB reset.
		clipFlags _ InAllMask + OutAllMask.
		"Copy the poly into tempVB"
		0 to: 2 do:[:i|
			vtx _ vtxArray at: (idxArray at: index+i).
			idxArray at: index+i put: 0.
			tempVB addClipVertex: vtx.
			clipFlags _ clipFlags bitAnd: vtx clipFlags].
		tempVB clipFlags: clipFlags.
		self processPolygon: tempVB.
		tempVB vertexCount > 2 ifTrue:[
			returnValue _ nil. "We see some parts and not others"
			idx1 _ vb addClipVertex: (tempVB vertexArray at: 1).
			3 to: tempVB vertexCount do:[:j|
				idx2 _ vb addClipVertex: (tempVB vertexArray at: j-1).
				idx3 _ vb addClipVertex: (tempVB vertexArray at: j).
				vb addClipIndex: idx1.
				vb addClipIndex: idx2.
				vb addClipIndex: idx3.
			].
		].
		lastIndex _ index.
	].
	^returnValue! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 4/17/1999 23:06'!
processLineLoop: vertexBuffer
	"Process a closed line defined by the vertex buffer"
	^self error:'Lines are not yet implemented'! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 4/17/1999 23:06'!
processLines: vertexBuffer
	"Process a series of lines defined by each two points the vertex buffer"
	^self error:'Lines are not yet implemented'! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 4/17/1999 23:06'!
processPoints: vertexBuffer
	"Process a series of points defined by the vertex buffer"
	^self error:'Points are not yet implemented'! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 9/17/1999 20:10'!
processPolygon: vb
	"Process a polygon from the vertex buffer that requires partial clipping"
	| outMask vtxArray tempVtxArray count |
	outMask := vb clipFlags bitAnd: OutAllMask.
	vtxArray _ vb vertexArray.
	tempVtxArray _ vtxArray clone.
	"Note: tempVtxArray has the SAME contents as vtxArray since the data is stored inplace.
	Thus we can decide from which buffer to start the clipping operation later on."
	count _ self clipPolygon: vtxArray count: vb vertexCount with: tempVtxArray mask: outMask.
	vb vertexCount: count.
	count < 3 ifTrue:[^false].
	^nil! !

!B3DVertexClipper methodsFor: 'processing' stamp: 'ar 11/7/2000 17:25'!
processVertexBuffer: vb
	"Clip the elements in the vertex buffer. Return true if all vertices are inside.
	Return false if all vertices are outside. If partial clipping occurs, return nil."
	| result |
	result _ self preProcessVertexBuffer: vb.
	result == nil ifFalse:[^result].
	^self postProcessVertexBuffer: vb! !


!B3DVertexClipper methodsFor: 'clip flags' stamp: 'ar 2/16/1999 19:20'!
clipFlagsX: x y: y z: z w: w
	"Determine the clip flags for the given vector.
	The clip flags are a combination of inside and outside flags that can be used to easily reject an entire buffer if it is completely inside or outside and can also be used to detect the most commen cases in clipping (e.g., intersection with one boundary only)."
	| w2 flags |
	w2 _ w negated.
	flags _ 0.
	flags _ flags bitOr:(x >= w2 ifTrue:[InLeftBit] ifFalse:[OutLeftBit]).
	flags _ flags bitOr:(x <= w ifTrue:[InRightBit] ifFalse:[OutRightBit]).
	flags _ flags bitOr:(y >= w2 ifTrue:[InBottomBit] ifFalse:[OutBottomBit]).
	flags _ flags bitOr:(y <= w ifTrue:[InTopBit] ifFalse:[OutTopBit]).
	flags _ flags bitOr:(z >= w2 ifTrue:[InFrontBit] ifFalse:[OutFrontBit]).
	flags _ flags bitOr:(z <= w ifTrue:[InBackBit] ifFalse:[OutBackBit]).
	^flags! !

!B3DVertexClipper methodsFor: 'clip flags' stamp: 'ar 2/16/1999 19:20'!
determineClipFlags: vtxArray count: vtxCount
	"Determine the clip flags for all the vertices in the vertex array"
	| fullMask flags |
	self flag: #b3dPrimitive.
	fullMask _ InAllMask + OutAllMask.
	vtxArray upTo: vtxCount do:[:vtx|
		flags _ (self clipFlagsX: vtx rasterPosX 
							y: vtx rasterPosY 
							z: vtx rasterPosZ 
							w: vtx rasterPosW).
		vtx clipFlags: flags.
		fullMask _ fullMask bitAnd: flags.
	].
	^fullMask! !


!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygon: vtxArray count: vtxCount with: tempVtxArray mask: outMask
	"Clip the polygon defined by vtxCount vertices in vtxArray. tempVtxArray is a temporary storage area used for copying the vertices back and forth during clipping operation. outMask is the full clip mask of the vertex buffer, allowing some optimizations of the clipping code.
	NOTE: It is significant here that the contents of vtxArray and tempVtxArray are equal."
	| count |
	self flag: #b3dPrimitive.
	"Check if the polygon is outside one boundary only.
	If so, just do this single clipping operation avoiding multiple enumeration."
	outMask = OutLeftBit 
		ifTrue:[^self clipPolygonLeftFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutRightBit 
		ifTrue:[^self clipPolygonRightFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutTopBit 
		ifTrue:[^self clipPolygonTopFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutBottomBit 
		ifTrue:[^self clipPolygonBottomFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutFrontBit 
		ifTrue:[^self clipPolygonFrontFrom: tempVtxArray to: vtxArray count: vtxCount].
	outMask = OutBackBit 
		ifTrue:[^self clipPolygonBackFrom: tempVtxArray to: vtxArray count: vtxCount].
	"Just do each of the clipping operations"
	count _ vtxCount.
	count _ self clipPolygonLeftFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonRightFrom: tempVtxArray to: vtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonTopFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonBottomFrom: tempVtxArray to: vtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonFrontFrom: vtxArray to: tempVtxArray count: count.
	count = 0 ifTrue:[^0].
	count _ self clipPolygonBackFrom: tempVtxArray to: vtxArray count: count.
	^count! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygonBackFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InBackBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InBackBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self backClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygonBottomFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InBottomBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InBottomBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self bottomClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygonFrontFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InFrontBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InFrontBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self frontClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 4/16/1999 06:01'!
clipPolygonLeftFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InLeftBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InLeftBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self leftClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygonRightFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InRightBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InRightBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self rightClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !

!B3DVertexClipper methodsFor: 'clipping polygons' stamp: 'ar 2/16/1999 19:21'!
clipPolygonTopFrom: buf1 to: buf2 count: n
	| last next t outIndex inLast inNext outVtx |
	outIndex _ 0.
	last _ buf1 at: n.
	inLast _ last clipFlags anyMask: InTopBit.
	1 to: n do:[:i|
		next _ buf1 at: i.
		inNext _ next clipFlags anyMask: InTopBit.
		inLast = inNext ifFalse:["Passes clip boundary"
			t _ self topClipValueFrom: last to: next.
			outVtx _ self interpolateFrom: last to: next at: t.
			buf2 at: (outIndex _ outIndex+1) put: outVtx].
		inNext ifTrue:[buf2 at: (outIndex _ outIndex+1) put: next].
		last _ next.
		inLast _ inNext.
	].
	^outIndex! !


!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
backClipValueFrom: last to: next
	^(last rasterPosZ - last rasterPosW) /
		((next rasterPosW - last rasterPosW) - (next rasterPosZ - last rasterPosZ)).! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
bottomClipValueFrom: last to: next
	^(last rasterPosY + last rasterPosW) negated /
		((next rasterPosW - last rasterPosW) + (next rasterPosY - last rasterPosY)).! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
frontClipValueFrom: last to: next
	^(last rasterPosZ + last rasterPosW) negated /
		((next rasterPosW - last rasterPosW) + (next rasterPosZ - last rasterPosZ)).! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 4/16/1999 06:43'!
interpolateFrom: last to: next at: t
	"Interpolate the primitive vertices last/next at the parameter t"
	| out |
	out _ next clone.
	"Interpolate raster position"
	out rasterPos: ((next rasterPos - last rasterPos) * t) + last rasterPos.
	out clipFlags: (self clipFlagsX: out rasterPosX y: out rasterPosY z: out rasterPosZ w: out rasterPosW).
	"Interpolate color"
	out b3dColor: ((next b3dColor - last b3dColor) * t) + last b3dColor.
	"Interpolate texture coordinates"
	out texCoords: ((next texCoords - last texCoords) * t) + last texCoords.
	^out! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
leftClipValueFrom: last to: next
	^(last rasterPosX + last rasterPosW) negated /
		((next rasterPosW - last rasterPosW) + (next rasterPosX - last rasterPosX)).! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
rightClipValueFrom: last to: next
	^(last rasterPosX - last rasterPosW) /
		((next rasterPosW - last rasterPosW) - (next rasterPosX - last rasterPosX)).! !

!B3DVertexClipper methodsFor: 'clipping utilitites' stamp: 'ar 2/16/1999 19:21'!
topClipValueFrom: last to: next
	^(last rasterPosY - last rasterPosW) /
		((next rasterPosW - last rasterPosW) - (next rasterPosY - last rasterPosY)).! !


!B3DVertexClipper methodsFor: 'private' stamp: 'ar 2/16/1999 19:21'!
primNextClippedQuadAfter: firstIndex vertices: vtxArray count: vtxCount indexes: idxArray count: idxCount
	"Find the next partially clipped quad from the vertex buffer and return its index.
	If there are no more partially clipped quads return zero."
	| quadMask |
	self flag: #b3dPrimitive.
	firstIndex to: idxCount by: 4 do:[:i|
		quadMask _
			((vtxArray at: (idxArray at: i)) clipFlags bitAnd:
				(vtxArray at: (idxArray at: i+1)) clipFlags) bitAnd:
					((vtxArray at: (idxArray at: i+2)) clipFlags bitAnd:
						(vtxArray at: (idxArray at: i+3)) clipFlags).
		"Check if quad is completely inside"
		(quadMask allMask: InAllMask) ifFalse:[
			"Quad is not completely inside -> needs clipping."
			(quadMask anyMask: OutAllMask) ifTrue:[
				"quad is completely outside. Store all zeros"
				idxArray at: i put: 0.
				idxArray at: i+1 put: 0.
				idxArray at: i+2 put: 0.
				idxArray at: i+3 put: 0.
			] ifFalse:[
				"quad must be partially clipped."
				^i
			].
		].
	].
	^0 "No more entries"! !

!B3DVertexClipper methodsFor: 'private' stamp: 'ar 2/16/1999 19:22'!
primNextClippedTriangleAfter: firstIndex vertices: vtxArray count: vtxCount indexes: idxArray count: idxCount
	"Find the next partially clipped triangle from the vertex buffer and return its index.
	If there are no more partially clipped triangles return zero."
	| triMask |
	self flag: #b3dPrimitive.
	firstIndex to: idxCount by: 3 do:[:i|
		triMask _
			((vtxArray at: (idxArray at: i)) clipFlags bitAnd:
				(vtxArray at: (idxArray at: i+1)) clipFlags) bitAnd:
					(vtxArray at: (idxArray at: i+2)) clipFlags.
		"Check if tri is completely inside"
		(triMask allMask: InAllMask) ifFalse:[
			"Tri is not completely inside -> needs clipping."
			(triMask anyMask: OutAllMask) ifTrue:[
				"tri is completely outside. Store all zeros"
				idxArray at: i put: 0.
				idxArray at: i+1 put: 0.
				idxArray at: i+2 put: 0.
			] ifFalse:[
				"tri must be partially clipped."
				^i
			].
		].
	].
	^0 "No more entries"! !

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

B3DVertexClipper class
	instanceVariableNames: ''!

!B3DVertexClipper class methodsFor: 'class initialization' stamp: 'ar 2/13/1999 20:31'!
initialize
	"B3DClipper initialize"
	"InLeftBit _ 16r01.	OutLeftBit _ 16r02.
	InRightBit _ 16r04.	OutRightBit _ 16r08.
	InTopBit _ 16r10.		OutTopBit _ 16r20.
	InBottomBit _ 16r40.	OutBottomBit _ 16r80.
	InFrontBit _ 16r100.	OutFrontBit _ 16r200.
	InBackBit _ 16r400.	OutBackBit _ 16r800.

	InAllMask  _ 16r555. 1365
	OutAllMask  _ 16rAAA 2730."! !


!B3DVertexClipper class methodsFor: 'testing' stamp: 'ar 2/14/1999 01:40'!
isAvailable
	"Return true if this part of the engine is available"
	^true! !
B3DEnginePart subclass: #B3DVertexRasterizer
	instanceVariableNames: 'target offset clipRect viewport dirtyRect texture textureStack vbBounds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!
!B3DVertexRasterizer commentStamp: '<historical>' prior: 0!
I am the superclass for all rasterizers in the Balloon 3D engine. Rasterizers perform the final pixel generation of the primitives and are the most time-critical part of the engine. Rasterizers keep a viewport, defining the destination rectangle and a dirtyRect, defining the actual affected 2D region of the rasterization process.

Instance variables:
	viewport	<B3DViewport>	the destination rectangle
	dirtyRect	<Rectangle>		the affected region of all rasterization operations performed!


!B3DVertexRasterizer methodsFor: 'initialize' stamp: 'ar 2/16/1999 04:30'!
finish
	"Force everything on the output device"! !

!B3DVertexRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:29'!
flush
	"Flush pending operations."! !

!B3DVertexRasterizer methodsFor: 'initialize' stamp: 'ar 2/16/1999 03:15'!
initialize
	super initialize.
	textureStack _ OrderedCollection new.! !

!B3DVertexRasterizer methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:53'!
reset
	super reset.
	textureStack _ OrderedCollection new.! !

!B3DVertexRasterizer methodsFor: 'initialize' stamp: 'ar 5/26/2000 15:12'!
target: aForm
	"Set the target for rendering operations"
	target _ aForm! !


!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 5/26/2000 15:18'!
clipRect
	"Return the current clipping rectangle"
	^clipRect! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 5/26/2000 15:18'!
clipRect: aRectangle
	"Install a clipping rectangle if necessary"
	clipRect _ aRectangle! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/7/1999 03:38'!
dirtyRect
	"If the dirtyRect is not known (e.g., not implemented by a particular rasterizer) return the full viewport"
	^dirtyRect ifNil:[viewport]! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/7/1999 03:35'!
dirtyRect: aRectangle
	dirtyRect _ aRectangle! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:16'!
popTexture
	texture _ textureStack removeLast.! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:15'!
pushTexture
	textureStack addLast: texture! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:15'!
texture
	^texture! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 2/16/1999 03:15'!
texture: aForm
	texture _ aForm! !

!B3DVertexRasterizer methodsFor: 'accessing'!
viewport
	^viewport! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 7/11/2000 11:04'!
viewport: aRectangle
	| r |
	r _ aRectangle.
	offset ifNotNil:[r _ r translateBy: offset].
	viewport _ B3DViewport origin: r origin truncated corner: r corner truncated.
	viewport toggleYScale.! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 5/26/2000 15:17'!
viewportOffset
	"Return the viewport offset"
	^offset! !

!B3DVertexRasterizer methodsFor: 'accessing' stamp: 'ar 5/26/2000 15:17'!
viewportOffset: aPoint
	"Set the viewport offset"
	offset _ aPoint! !


!B3DVertexRasterizer methodsFor: 'testing'!
needsClip
	"Return true if we need to clip polygons before rasterization.
	Generally, this should not be the case."
	^self subclassResponsibility! !


!B3DVertexRasterizer methodsFor: 'processing' stamp: 'ar 2/16/1999 02:02'!
clearDepthBuffer
	"If the rasterizer uses a depth buffer, clear it."! !

!B3DVertexRasterizer methodsFor: 'processing' stamp: 'ar 5/28/2000 02:25'!
clearViewport: aColor
	"Clear the current viewport using the given color"
	target ifNotNil:[
		target 
			fill: viewport 
			rule: Form over 
			fillColor: aColor asColor
	].! !

!B3DVertexRasterizer methodsFor: 'processing' stamp: 'ar 11/7/1999 18:04'!
processVertexBuffer: vb
	vbBounds _ nil.
	super processVertexBuffer: vb.
	^vbBounds! !
B3DEnginePart subclass: #B3DVertexShader
	instanceVariableNames: 'lights material materialStack '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!

!B3DVertexShader methodsFor: 'initialize' stamp: 'ar 2/17/1999 04:17'!
initialize
	super initialize.
	lights _ OrderedCollection new.
	material _ B3DMaterial new.
	materialStack _ OrderedCollection new: 10.! !

!B3DVertexShader methodsFor: 'initialize' stamp: 'ar 4/10/1999 22:55'!
reset
	super reset.
	lights _ OrderedCollection new.
	material _ B3DMaterial new.
	materialStack _ OrderedCollection new: 10.! !


!B3DVertexShader methodsFor: 'shading' stamp: 'ar 4/3/1999 20:10'!
processVertexBuffer: vb
	| colors emissionPart |
	colors _ B3DColor4Array new: vb vertexCount.
	"Load initial colors (e.g., emission part)"
	vb trackEmissionColor ifFalse:[
		emissionPart _ material emission.
		1 to: vb vertexCount do:[:i| colors at: i put: emissionPart].
	] ifTrue:[
		1 to: vb vertexCount do:[:i| colors at: i put: (vb primitiveVertexAt: i) b3dColor].
	].
	lights do:[:light|
		light shadeVertexBuffer: vb with: material into: colors.
	].
	colors clampAllFrom: 0.0 to: 1.0.
	vb vertexArray upTo: vb vertexCount doWithIndex:[:vtx :i| vtx color: (colors at: i)].
! !


!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:14'!
addLight: aLightSource
	lights add: aLightSource.
	^lights size! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:36'!
material
	^material! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:36'!
material: aMaterial
	material _ aMaterial.! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/7/1999 16:19'!
materialColor: aColor
	material ambientPart: aColor.
	material diffusePart: aColor.
	material specularPart: aColor.! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:35'!
popMaterial
	material _ materialStack removeLast.! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/7/1999 19:35'!
pushMaterial
	materialStack addLast: material.! !

!B3DVertexShader methodsFor: 'accessing' stamp: 'ar 2/17/1999 04:16'!
removeLight: lightIndex
	"Remove the light with the given index"
	(lightIndex < 1 or:[lightIndex > lights size]) ifTrue:[^nil].
	lights at: lightIndex put: nil. "So we don't change the indexes"! !

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

B3DVertexShader class
	instanceVariableNames: ''!

!B3DVertexShader class methodsFor: 'testing' stamp: 'ar 2/14/1999 01:41'!
isAvailable
	"Return true if this part of the engine is available"
	^true! !
B3DEnginePart subclass: #B3DVertexTransformer
	instanceVariableNames: 'modelMatrix viewMatrix textureMatrix currentMatrix needsUpdate matrixStack matrixState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Engine'!

!B3DVertexTransformer methodsFor: 'initialize' stamp: 'ar 4/18/1999 02:23'!
initialize
	super initialize.
	modelMatrix _ B3DMatrix4x4 identity.
	viewMatrix _ B3DMatrix4x4 identity.
	textureMatrix _ B3DMatrix4x4 identity.
	currentMatrix _ modelMatrix.
	matrixStack _ OrderedCollection new: 30.
	matrixStack resetTo: 1.
	needsUpdate _ false.! !

!B3DVertexTransformer methodsFor: 'initialize' stamp: 'ar 4/16/1999 07:59'!
reset
	super reset.
	modelMatrix := B3DMatrix4x4 identity.
	viewMatrix := B3DMatrix4x4 identity.
	textureMatrix := B3DMatrix4x4 identity.
	currentMatrix := modelMatrix.
	matrixStack := OrderedCollection new: 30.
	matrixStack resetTo: 1.
	needsUpdate := false.! !


!B3DVertexTransformer methodsFor: 'public' stamp: 'ar 8/19/1999 16:31'!
transformDirection: aVector3
	| zero one |
	zero _ B3DVector3 new.
	one _ zero + aVector3.
	zero _ self transformPosition: zero.
	one _ self transformPosition: one.
	^one - zero! !

!B3DVertexTransformer methodsFor: 'public' stamp: 'ar 2/8/1999 01:33'!
transformPosition: aVector3
	| pVtx |
	pVtx _ B3DPrimitiveVertex new.
	pVtx position: aVector3.
	self privateTransformPrimitiveVertex: pVtx byModelView: self modelViewMatrix.
	^pVtx position! !


!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:58'!
currentMatrix
	^currentMatrix! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:58'!
matrixMode
	currentMatrix == modelMatrix ifTrue:[^#modelView].
	currentMatrix == viewMatrix ifTrue:[^#projection].
	currentMatrix == textureMatrix ifTrue:[^#texture].
	self error:'Bad matrix state'.! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:58'!
matrixMode: aSymbol
	aSymbol == #modelView ifTrue:[currentMatrix := modelMatrix. ^self].
	aSymbol == #projection ifTrue:[currentMatrix := viewMatrix. ^self].
	aSymbol == #texture ifTrue:[currentMatrix := textureMatrix. ^self].
	self error:'Bad matrix mode'.! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:58'!
modelViewMatrix
	^modelMatrix! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:59'!
popMatrix
	"Pop the current matrix from the stack"
	matrixStack isEmpty ifTrue:[^self error:'Empty matrix stack'].
	currentMatrix loadFrom: matrixStack removeLast.! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:59'!
projectionMatrix
	^viewMatrix! !

!B3DVertexTransformer methodsFor: 'accessing' stamp: 'ar 2/2/1999 18:59'!
pushMatrix
	"Push the current matrix"
	| theMatrix |
	theMatrix := B3DMatrix4x4 new.
	theMatrix loadFrom: currentMatrix.
	matrixStack addLast: theMatrix.! !


!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/2/1999 19:00'!
loadIdentity
	currentMatrix setIdentity.
	needsUpdate := true.! !

!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/2/1999 19:00'!
loadMatrix: aMatrix
	currentMatrix loadFrom: aMatrix.
	needsUpdate := true.! !

!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/7/1999 01:39'!
lookFrom: position to: target up: upDirection
	"create a matrix such that we look from eyePoint to centerPoint using upDirection"
	| xDir yDir zDir m |
	"calculate z vector"
	zDir _ target - position.
	zDir safelyNormalize.
	"calculate x vector"
	xDir _ upDirection cross: zDir.
	xDir safelyNormalize.
	"recalc y vector"
	yDir _ zDir cross: xDir.
	yDir safelyNormalize.
	m := B3DMatrix4x4 new.
	m	a11: xDir x;		a12: xDir y;		a13: xDir z;		a14: 0.0;
		a21: yDir x;		a22: yDir y;		a23: yDir z;		a24: 0.0;
		a31: zDir x;		a32: zDir y;		a33: zDir z;		a34: 0.0;
		a41: 0.0;			a42: 0.0;		a43: 0.0;		a44: 1.0.
	self transformBy: m.
	self translateBy: position negated.! !

!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/2/1999 19:00'!
multiplyMatrix: aMatrix
	"Multiply aMatrix with the current matrix"
	currentMatrix *= aMatrix! !

!B3DVertexTransformer methodsFor: 'modifying'!
rotateBy: aRotation
	self transformBy: aRotation asMatrix4x4.! !

!B3DVertexTransformer methodsFor: 'modifying'!
scaleBy: aVector
	self transformBy: (B3DMatrix4x4 identity setScale: aVector)! !

!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/2/1999 19:01'!
scaleByX: x y: y z: z
	currentMatrix scaleByX: x y: y z: z.
	needsUpdate := true.! !

!B3DVertexTransformer methodsFor: 'modifying'!
transformBy: aTransformation
	self privateTransformMatrix: currentMatrix 
			with: aTransformation asMatrix4x4 
			into: currentMatrix.
	needsUpdate := true.! !

!B3DVertexTransformer methodsFor: 'modifying'!
translateBy: aVector
	"Add the translation defined by aVector to the current matrix"
	self transformBy: (B3DMatrix4x4 identity setTranslation: aVector).! !

!B3DVertexTransformer methodsFor: 'modifying' stamp: 'ar 2/2/1999 19:01'!
translateByX: x y: y z: z
	"Add the translation defined by aVector to the current matrix"
	currentMatrix translateByX: x y: y z: z.
	needsUpdate := true.! !


!B3DVertexTransformer methodsFor: 'processing' stamp: 'ar 4/18/1999 02:23'!
processVertexBuffer: vb
	^self processVertexBuffer: vb modelView: self modelViewMatrix projection: self projectionMatrix! !

!B3DVertexTransformer methodsFor: 'processing' stamp: 'ar 4/18/1999 02:22'!
processVertexBuffer: vb modelView: modelViewMatrix projection: projectionMatrix
	^self privateTransformVB: vb vertexArray 
			count: vb vertexCount
			modelViewMatrix: modelViewMatrix
			projectionMatrix: projectionMatrix
			flags: vb flags! !


!B3DVertexTransformer methodsFor: 'view transformation'!
ortho: aFrustum
	viewMatrix _ aFrustum asFrustum asOrthoMatrix.
	needsUpdate _ true.! !

!B3DVertexTransformer methodsFor: 'view transformation'!
perspective: aPerspectiveOrFrustum
	viewMatrix _ aPerspectiveOrFrustum asFrustum asPerspectiveMatrix.
	needsUpdate _ true.! !


!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:19'!
privateTransformMatrix: m1 with: m2 into: m3
	"Perform a 4x4 matrix multiplication
		m2 * m1 = m3
	being equal to first transforming points by m2 and then by m1.
	Note that m1 may be identical to m3."
	| c1 c2 c3 c4 |
	m2 == m3 ifTrue:[^self error:'Argument and result matrix identical'].
	c1 _ ((m1 a11 * m2 a11) + (m1 a12 * m2 a21) + 
				(m1 a13 * m2 a31) + (m1 a14 * m2 a41)).
	c2 _ ((m1 a11 * m2 a12) + (m1 a12 * m2 a22) + 
				(m1 a13 * m2 a32) + (m1 a14 * m2 a42)).
	c3 _ ((m1 a11 * m2 a13) + (m1 a12 * m2 a23) + 
				(m1 a13 * m2 a33) + (m1 a14 * m2 a43)).
	c4 _ ((m1 a11 * m2 a14) + (m1 a12 * m2 a24) + 
				(m1 a13 * m2 a34) + (m1 a14 * m2 a44)).

	m3 a11: c1; a12: c2; a13: c3; a14: c4.

	c1 _ ((m1 a21 * m2 a11) + (m1 a22 * m2 a21) + 
				(m1 a23 * m2 a31) + (m1 a24 * m2 a41)).
	c2 _ ((m1 a21 * m2 a12) + (m1 a22 * m2 a22) + 
				(m1 a23 * m2 a32) + (m1 a24 * m2 a42)).
	c3 _ ((m1 a21 * m2 a13) + (m1 a22 * m2 a23) + 
				(m1 a23 * m2 a33) + (m1 a24 * m2 a43)).
	c4 _ ((m1 a21 * m2 a14) + (m1 a22 * m2 a24) + 
				(m1 a23 * m2 a34) + (m1 a24 * m2 a44)).

	m3 a21: c1; a22: c2; a23: c3; a24: c4.

	c1 _ ((m1 a31 * m2 a11) + (m1 a32 * m2 a21) + 
				(m1 a33 * m2 a31) + (m1 a34 * m2 a41)).
	c2 _ ((m1 a31 * m2 a12) + (m1 a32 * m2 a22) + 
				(m1 a33 * m2 a32) + (m1 a34 * m2 a42)).
	c3 _ ((m1 a31 * m2 a13) + (m1 a32 * m2 a23) + 
				(m1 a33 * m2 a33) + (m1 a34 * m2 a43)).
	c4 _ ((m1 a31 * m2 a14) + (m1 a32 * m2 a24) + 
				(m1 a33 * m2 a34) + (m1 a34 * m2 a44)).

	m3 a31: c1; a32: c2; a33: c3; a34: c4.

	c1 _ ((m1 a41 * m2 a11) + (m1 a42 * m2 a21) + 
				(m1 a43 * m2 a31) + (m1 a44 * m2 a41)).
	c2 _ ((m1 a41 * m2 a12) + (m1 a42 * m2 a22) + 
				(m1 a43 * m2 a32) + (m1 a44 * m2 a42)).
	c3 _ ((m1 a41 * m2 a13) + (m1 a42 * m2 a23) + 
				(m1 a43 * m2 a33) + (m1 a44 * m2 a43)).
	c4 _ ((m1 a41 * m2 a14) + (m1 a42 * m2 a24) + 
				(m1 a43 * m2 a34) + (m1 a44 * m2 a44)).

	m3 a41: c1; a42: c2; a43: c3; a44: c4.! !

!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:20'!
privateTransformPrimitiveNormal: primitiveVertex byMatrix: aMatrix rescale: scaleNeeded
	| x y z rx ry rz dot |
	x _ primitiveVertex normalX.
	y _ primitiveVertex normalY.
	z _ primitiveVertex normalZ.
	rx := (x * aMatrix a11) + (y * aMatrix a12) + (z * aMatrix a13).
	ry := (x * aMatrix a21) + (y * aMatrix a22) + (z * aMatrix a23).
	rz := (x * aMatrix a31) + (y * aMatrix a32) + (z * aMatrix a33).
	scaleNeeded ifTrue:[
		dot _ (rx * rx) + (ry * ry) + (rz * rz).
		dot < 1.0e-20 ifTrue:[
			rx _ ry _ rz _ 0.0.
		] ifFalse:[
			dot = 1.0 ifFalse:[
				dot _ 1.0 / dot sqrt.
				rx _ rx * dot.
				ry _ ry * dot.
				rz _ rz * dot.
			].
		].
	].
	primitiveVertex normalX: rx.
	primitiveVertex normalY: ry.
	primitiveVertex normalZ: rz.
! !

!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:20'!
privateTransformPrimitiveVertex: primitiveVertex byModelView: aMatrix
	| x y z rx ry rz rw oneOverW |
	x _ primitiveVertex positionX.
	y _ primitiveVertex positionY.
	z _ primitiveVertex positionZ.
	rx := (x * aMatrix a11) + (y * aMatrix a12) + (z * aMatrix a13) + aMatrix a14.
	ry := (x * aMatrix a21) + (y * aMatrix a22) + (z * aMatrix a23) + aMatrix a24.
	rz := (x * aMatrix a31) + (y * aMatrix a32) + (z * aMatrix a33) + aMatrix a34.
	rw := (x * aMatrix a41) + (y * aMatrix a42) + (z * aMatrix a43) + aMatrix a44.
	rw = 1.0 ifTrue:[
		primitiveVertex positionX: rx.
		primitiveVertex positionY: ry.
		primitiveVertex positionZ: rz.
	] ifFalse:[
		rw = 0.0 
			ifTrue:[oneOverW _ 0.0]
			ifFalse:[oneOverW _ 1.0 / rw].
		primitiveVertex positionX: rx * oneOverW.
		primitiveVertex positionY: ry * oneOverW.
		primitiveVertex positionZ: rz * oneOverW.
	].
! !

!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/8/1999 18:19'!
privateTransformPrimitiveVertex: primitiveVertex byModelViewWithoutW: aMatrix
	"Special case of aMatrix a41 = a42 = a43 = 0.0 and a44 = 1.0"
	| x y z rx ry rz |
	"Note: This is not supported by primitive level operations."
	self flag: #b3dPrimitive.
	x _ primitiveVertex positionX.
	y _ primitiveVertex positionY.
	z _ primitiveVertex positionZ.
	rx := (x * aMatrix a11) + (y * aMatrix a12) + (z * aMatrix a13) + aMatrix a14.
	ry := (x * aMatrix a21) + (y * aMatrix a22) + (z * aMatrix a23) + aMatrix a24.
	rz := (x * aMatrix a31) + (y * aMatrix a32) + (z * aMatrix a33) + aMatrix a34.
	primitiveVertex positionX: rx.
	primitiveVertex positionY: ry.
	primitiveVertex positionZ: rz.! !

!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:21'!
privateTransformPrimitiveVertex: primitiveVertex byProjection: aMatrix
	| x y z rx ry rz rw |
	x _ primitiveVertex positionX.
	y _ primitiveVertex positionY.
	z _ primitiveVertex positionZ.
	rx := (x * aMatrix a11) + (y * aMatrix a12) + (z * aMatrix a13) + aMatrix a14.
	ry := (x * aMatrix a21) + (y * aMatrix a22) + (z * aMatrix a23) + aMatrix a24.
	rz := (x * aMatrix a31) + (y * aMatrix a32) + (z * aMatrix a33) + aMatrix a34.
	rw := (x * aMatrix a41) + (y * aMatrix a42) + (z * aMatrix a43) + aMatrix a44.
	primitiveVertex rasterPosX: rx.
	primitiveVertex rasterPosY: ry.
	primitiveVertex rasterPosZ: rz.
	primitiveVertex rasterPosW: rw.! !

!B3DVertexTransformer methodsFor: 'private-transforming' stamp: 'ar 2/17/1999 04:22'!
privateTransformVB: vertexArray count: vertexCount modelViewMatrix: modelViewMatrix projectionMatrix: projectionMatrix flags: flags
	| noW |
	(modelViewMatrix a41 = 0.0 and:[
		modelViewMatrix a42 = 0.0 and:[
			modelViewMatrix a43 = 0.0 and:[
				modelViewMatrix a44 = 1.0]]]) ifTrue:[noW _ true].
	noW ifTrue:[
		vertexArray upTo: vertexCount do:[:primitiveVertex|
			self privateTransformPrimitiveVertex: primitiveVertex
				byModelViewWithoutW: modelViewMatrix.
			self privateTransformPrimitiveVertex: primitiveVertex
				byProjection: projectionMatrix.
			(flags anyMask: VBVtxHasNormals)
				ifTrue:[self privateTransformPrimitiveNormal: primitiveVertex
							byMatrix: modelViewMatrix
							rescale: true].
		].
	] ifFalse:[
		vertexArray upTo: vertexCount do:[:primitiveVertex|
			self privateTransformPrimitiveVertex: primitiveVertex
				byModelView: modelViewMatrix.
			self privateTransformPrimitiveVertex: primitiveVertex
				byProjection: projectionMatrix.
			(flags anyMask: VBVtxHasNormals)
				ifTrue:[self privateTransformPrimitiveNormal: primitiveVertex
							byMatrix: modelViewMatrix
							rescale: true].
		].
	].! !

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

B3DVertexTransformer class
	instanceVariableNames: ''!

!B3DVertexTransformer class methodsFor: 'testing' stamp: 'ar 2/14/1999 01:41'!
isAvailable
	"Return true if this part of the engine is available"
	^true! !
B3DFloatArray variableWordSubclass: #B3DViewingFrustum
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!
!B3DViewingFrustum commentStamp: '<historical>' prior: 0!
I represent a viewing frustum, defined by the following values:

	typedef struct B3DViewingFrustum {
		float left;
		float right;
		float top;
		float bottom;
		float near;
		float far;
	} B3DViewingFrustum;

The frustum can be converted into either a ortho matrix (having no perspective distortion) or a perspective matrix for use in the Balloon 3D render engine.!


!B3DViewingFrustum methodsFor: 'private'!
asOrthoMatrixInto: aB3DMatrix4x4
	| x y z tx ty tz dx dy dz |
	(self near <= 0.0 or:[self far <= 0.0]) ifTrue: [^self error:'Clipping plane error'].
	dx := self right - self left.
	dy := self top - self bottom.
	dz := self far - self near.
	x := dx * 0.5.
	y := dy * 0.5.
	z := dz * -0.5.
	tx := (self left + self right) / dx.
	ty := (self top + self bottom) / dy.
	tz := (self near + self far) / dz.
	aB3DMatrix4x4
		a11: x;		a12: 0.0;		a13: 0.0;		a14: tx;
		a21: 0.0;		a22: y;		a23: 0.0;	a24: ty;
		a31: 0.0;		a32: 0.0;	a33: z;		a34: tz;
		a41: 0.0;		a42: 0.0;	a43: 0.0;	a44: 1.0.
	^aB3DMatrix4x4! !

!B3DViewingFrustum methodsFor: 'private' stamp: 'ar 2/7/1999 01:30'!
asPerspectiveMatrixInto: aB3DMatrix4x4
	| x y a b c d dx dy dz z2 |
	(self near <= 0.0 or:[self far <= 0.0 or:[self near >= self far]]) 
		ifTrue: [^self error:'Clipping plane error'].
	dx := self right - self left.
	dy := self top - self bottom.
	dz := self far - self near.
	z2 := 2.0 * self near.
	x := z2 / dx.
	y := z2 / dy.
	a := (self left + self right) / dx.
	b := (self top + self bottom) / dy.
	c := (self near + self far) "*negated*" / dz.
	d := (-2.0 * self near * self far) / dz.
	aB3DMatrix4x4
		a11: x;		a12: 0.0;		a13: a;		a14: 0.0;
		a21: 0.0;		a22: y;		a23: b;		a24: 0.0;
		a31: 0.0;		a32: 0.0;	a33: c;		a34: d;
		a41: 0.0;		a42: 0.0;	a43: "*-1*"1;		a44: 0.0.
	^aB3DMatrix4x4! !

!B3DViewingFrustum methodsFor: 'private'!
computeFromNear: nearDistance far: farDistance fov: fieldOfView aspect: aspectRatio
	"Compute the viewing frustum from the given values"
	| top bottom |
	top := nearDistance * fieldOfView degreesToRadians tan.
	bottom := top negated.
	self left: bottom * aspectRatio.
	self right: top * aspectRatio.	
	self top: top.
	self bottom: bottom.
	self near: nearDistance.
	self far: farDistance.! !


!B3DViewingFrustum methodsFor: 'accessing'!
bottom
	^self floatAt: 4.! !

!B3DViewingFrustum methodsFor: 'accessing'!
bottom: aFloat
	self floatAt: 4 put: aFloat! !

!B3DViewingFrustum methodsFor: 'accessing'!
far
	^self floatAt: 6! !

!B3DViewingFrustum methodsFor: 'accessing'!
far: aFloat
	self floatAt: 6 put: aFloat! !

!B3DViewingFrustum methodsFor: 'accessing'!
left
	^self floatAt: 1! !

!B3DViewingFrustum methodsFor: 'accessing'!
left: aFloat
	self floatAt: 1 put: aFloat! !

!B3DViewingFrustum methodsFor: 'accessing'!
near
	^self floatAt: 5! !

!B3DViewingFrustum methodsFor: 'accessing'!
near: aFloat
	self floatAt: 5 put: aFloat! !

!B3DViewingFrustum methodsFor: 'accessing'!
right
	^self floatAt: 2! !

!B3DViewingFrustum methodsFor: 'accessing'!
right: aFloat
	self floatAt: 2 put: aFloat! !

!B3DViewingFrustum methodsFor: 'accessing'!
top
	^self floatAt: 3! !

!B3DViewingFrustum methodsFor: 'accessing'!
top: aFloat
	self floatAt: 3 put: aFloat! !


!B3DViewingFrustum methodsFor: 'converting'!
asFrustum
	^self! !

!B3DViewingFrustum methodsFor: 'converting'!
asOrthoMatrix
	^self asOrthoMatrixInto: B3DMatrix4x4 new! !

!B3DViewingFrustum methodsFor: 'converting'!
asPerspectiveMatrix
	^self asPerspectiveMatrixInto: B3DMatrix4x4 new! !

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

B3DViewingFrustum class
	instanceVariableNames: ''!

!B3DViewingFrustum class methodsFor: 'instance creation'!
near: nearDistance far: farDistance fov: fieldOfView aspect: aspectRatio
	^self new computeFromNear: nearDistance far: farDistance fov: fieldOfView aspect: aspectRatio! !

!B3DViewingFrustum class methodsFor: 'instance creation'!
numElements
	^6! !
Rectangle subclass: #B3DViewport
	instanceVariableNames: 'center scale '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!
!B3DViewport commentStamp: '<historical>' prior: 0!
I represent a viewport for the Ballon 3D graphics engine. Since all positions are computed in the unit-coordinate system (-1,-1,-1) (1,1,1) after the render pipeline has completed, I am used to map these positions into the physical (pixel) coordinates of the output device before rasterization takes place.

Instance variables:
	center 	<Point>	The center of the viewport
	scale 	<Point>	The scale for points!


!B3DViewport methodsFor: 'mapping'!
asMatrixTransform2x3
	^(MatrixTransform2x3 withScale: scale) offset: center! !

!B3DViewport methodsFor: 'mapping'!
mapVertex4: aVector
	| w x y oneOverW |
	w _ aVector w.
	w = 1.0 ifTrue:[
		x _ aVector x.
		y _ aVector y.
	] ifFalse:[
		w = 0.0
			ifTrue:[oneOverW _ 0.0]
			ifFalse:[oneOverW _ 1.0 / w].
		x _ aVector x * oneOverW.
		y _ aVector y * oneOverW.
	].
	^((x@y) * scale + center) truncated! !


!B3DViewport methodsFor: 'private' stamp: 'ar 2/8/1999 21:45'!
setOrigin: topLeft corner: bottomRight
	super setOrigin: topLeft corner: bottomRight.
	center _ (self origin + self corner) / 2.0.
	scale _ corner - center + (0.5@-0.5). "Rasterizer offset"! !

!B3DViewport methodsFor: 'private' stamp: 'ar 2/7/1999 01:42'!
toggleYScale
	scale _ scale x @ scale y negated.! !


!B3DViewport methodsFor: 'accessing' stamp: 'ar 2/15/1999 02:53'!
aspectRatio
	^self width asFloat / self height asFloat! !

!B3DViewport methodsFor: 'accessing' stamp: 'ar 4/3/1999 20:29'!
center
	^center! !

!B3DViewport methodsFor: 'accessing' stamp: 'ar 4/3/1999 20:29'!
scale
	^scale! !
TransformationMorph subclass: #BOBTransformationMorph
	instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/10/2000 14:22'!
adjustAfter: changeBlock 
	"Cause this morph to remain cetered where it was before, and
	choose appropriate smoothing, after a change of scale or rotation."
	| |

		"oldRefPos _ self referencePosition."
	changeBlock value.
	self chooseSmoothing.
		"self penUpWhile: [self position: self position + (oldRefPos - self referencePosition)]."
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]
! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/26/2000 19:24'!
changeWorldBoundsToShow: aRectangle

	aRectangle area = 0 ifTrue: [^self].
	worldBoundsToShow _ aRectangle.
	owner myWorldChanged.! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/28/2000 11:45'!
drawSubmorphsOn: aCanvas

	(self innerBounds intersects: aCanvas clipRect) ifFalse: [^self].
	useRegularWarpBlt == true ifTrue: [
		^aCanvas 
			transformBy: transform
			clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) rounded
			during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
			]
			smoothing: smoothing
	].
	aCanvas 
		transform2By: transform		"#transformBy: for pure WarpBlt"
		clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) truncated
		during: [:myCanvas |
			submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
		]
		smoothing: smoothing
! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 12:39'!
extent: aPoint

	| newExtent |

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

! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/26/2000 19:23'!
extentFromParent: aPoint

	| newExtent |

	submorphs isEmpty ifTrue: [^self extent: aPoint].
	newExtent _ aPoint truncated.
	bounds _ bounds topLeft extent: newExtent.
	newExtent _ self recomputeExtent.
	newExtent ifNil: [^self].
	bounds _ bounds topLeft extent: newExtent.

! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/15/2000 11:57'!
layoutChanged

	| myGuy |
	"use the version from Morph"

	fullBounds _ nil.
	owner ifNotNil: [owner layoutChanged].
	submorphs size > 0 ifTrue: [
		(myGuy _ self firstSubmorph) isWorldMorph ifFalse: [
			worldBoundsToShow = myGuy bounds ifFalse: [
				self changeWorldBoundsToShow: (worldBoundsToShow _ myGuy bounds).
			].
		].

		"submorphs do: [:m | m ownerChanged]"		"<< I don't see any reason for this"
	].
! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 12:39'!
recomputeExtent

	| scalePt newScale theGreenThingie greenIBE myNewExtent |

	submorphs isEmpty ifTrue: [^self extent].
	worldBoundsToShow ifNil: [worldBoundsToShow _ self firstSubmorph bounds].
	worldBoundsToShow area = 0 ifTrue: [^self extent].
	scalePt _ owner innerBounds extent / worldBoundsToShow extent.
	newScale _ scalePt x min: scalePt y.
	theGreenThingie _ owner.
	greenIBE _ theGreenThingie innerBounds extent.
	myNewExtent _ (greenIBE min: worldBoundsToShow extent * newScale) truncated.
	self
		scale: newScale;
		offset: worldBoundsToShow origin * newScale.
	smoothing _ (newScale < 1.0) ifTrue: [2] ifFalse: [1].
	^myNewExtent! !

!BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/28/2000 11:26'!
useRegularWarpBlt: aBoolean

	useRegularWarpBlt _ aBoolean! !
Morph subclass: #BackgroundMorph
	instanceVariableNames: 'image offset delta running '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BackgroundMorph commentStamp: '<historical>' prior: 0!
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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ar 6/17/1999 01:06'!
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 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 | aCanvas translateBy: (x@y) - d clippingTo: bounds
				during:[:tileCanvas| self drawSubmorphsOn: tileCanvas]]].! !

!BackgroundMorph methodsFor: 'as yet unclassified'!
fullBounds
	^ self bounds! !

!BackgroundMorph methodsFor: 'as yet unclassified' stamp: 'ar 5/29/1999 08:32'!
fullDrawOn: aCanvas

	running ifFalse: [
		^aCanvas clipBy: (bounds translateBy: aCanvas origin)
				during:[:clippedCanvas| super fullDrawOn: clippedCanvas]].
	aCanvas drawMorph: self.
! !

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

!BackgroundMorph methodsFor: 'as yet unclassified'!
layoutChanged
	"Do nothing, since I clip my submorphs"! !

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

!BackgroundMorph methodsFor: 'as yet unclassified'!
startRunning
	running _ true.
	self changed! !

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

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

	^ 20! !

!BackgroundMorph methodsFor: 'as yet unclassified'!
stopRunning
	running _ false.
	self changed! !

!BackgroundMorph methodsFor: 'as yet unclassified'!
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: 'as yet unclassified'!
test
	^ self new image: Form fromUser! !
Collection subclass: #Bag
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Bag commentStamp: '<historical>' prior: 0!
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' stamp: 'sma 5/12/2000 17:23'!
at: index 
	self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'!
at: index put: anObject 
	self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'!
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' stamp: 'sma 5/12/2000 11:35'!
size
	"Answer how many elements the receiver contains."

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

!Bag methodsFor: 'accessing' stamp: 'sma 6/15/2000 17:00'!
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: 'adding' stamp: 'sma 5/12/2000 17:18'!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject."

	^ self add: newObject withOccurrences: 1! !

!Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'!
add: newObject withOccurrences: anInteger 
	"Add newObject anInteger times to the receiver. Answer newObject."

	contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger.
	^ newObject! !


!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'!
asBag
	^ self! !

!Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:30'!
asSet
	"Answer a set with the elements of the receiver."

	^ contents keys! !


!Bag methodsFor: 'copying' stamp: 'sma 5/12/2000 14:53'!
copy
	^ self shallowCopy setContents: contents copy! !


!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' stamp: 'sma 5/12/2000 14:49'!
setContents: aDictionary
	contents _ aDictionary! !


!Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'!
remove: oldObject ifAbsent: exceptionBlock 
	"Refer to the comment in Collection|remove:ifAbsent:."

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


!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 class
	instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'!
new
	^ self new: 4! !

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 14:49'!
new: nElements
	^ super new setContents: (Dictionary new: nElements)! !

!Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ self withAll: aCollection

"Examples:
	Bag newFrom: {1. 2. 3. 3}
	{1. 2. 3. 3} as: Bag
"! !
Object subclass: #BalloonBezierSimulation
	instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps '
	classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions '
	poolDictionaries: ''
	category: 'Balloon-Simulation'!

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
end
	^end! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
end: aPoint
	end _ aPoint! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'!
inTangent
	"Return the tangent at the start point"
	^via - start! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialX
	^start y <= end y
		ifTrue:[start x]
		ifFalse:[end x]! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialY
	^start y <= end y
		ifTrue:[start y]
		ifFalse:[end y]! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
initialZ
	^0 "Assume no depth given"! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'!
outTangent
	"Return the tangent at the end point"
	^end - via! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
start
	^start! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
start: aPoint
	start _ aPoint! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
via
	^via! !

!BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'!
via: aPoint
	via _ aPoint! !


!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:46'!
computeInitialStateFrom: source with: transformation
	"Compute the initial state in the receiver."
	start _ (transformation localPointToGlobal: source start) asIntegerPoint.
	end _ (transformation localPointToGlobal: source end) asIntegerPoint.
	via _ (transformation localPointToGlobal: source via) asIntegerPoint.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:39'!
computeSplitAt: t
	"Split the receiver at the parametric value t"
	| left right newVia1 newVia2 newPoint |
	left _ self clone.
	right _ self clone.
	"Compute new intermediate points"
	newVia1 _ (via - start) * t + start.
	newVia2 _ (end - via) * t + via.
	"Compute new point on curve"
	newPoint _ ((newVia1 - newVia2) * t + newVia2) asIntegerPoint.
	left via: newVia1 asIntegerPoint.
	left end: newPoint.
	right start: newPoint.
	right via: newVia2 asIntegerPoint.
	^Array with: left with: right! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 01:34'!
floatStepToFirstScanLineAt: yValue in: edgeTableEntry
	"Float version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	steps scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[
		^edgeTableEntry lines: 0].

	fwX1 _ (startX + endX - (2 * via x)) asFloat.
	fwX2 _ (via x - startX * 2) asFloat.
	fwY1 _ (startY + endY - (2 * via y)) asFloat.
	fwY2 _ ((via y - startY) * 2) asFloat.
	steps _ deltaY asInteger * 2.
	scaledStepSize _ 1.0 / steps asFloat.
	squaredStepSize _ scaledStepSize * scaledStepSize.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2.0 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2.0 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx * 0.5).
	fwDy _ fwDy + (fwDDy * 0.5).

	lastX _ startX asFloat.
	lastY _ startY asFloat.

	"self xDirection: xDir.
	self yDirection: yDir."
	edgeTableEntry xValue: startX.
	edgeTableEntry yValue: startY.
	edgeTableEntry zValue: 0.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		self stepToNextScanLineAt: yValue in: edgeTableEntry.
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:45'!
floatStepToNextScanLineAt: yValue in: edgeTableEntry
	"Float version of forward differencing"
	[yValue asFloat > lastY] whileTrue:[
		(fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt].
		(fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt].
		(fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt].
		(fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt].
		lastX _ lastX + fwDx.
		lastY _ lastY + fwDy.
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
	].
	edgeTableEntry xValue: lastX asInteger.
	edgeTableEntry zValue: 0.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 16:23'!
intStepToFirstScanLineAt: yValue in: edgeTableEntry
	"Scaled integer version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	 scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[
		^edgeTableEntry lines: 0].

	fwX1 _ (startX + endX - (2 * via x)).
	fwX2 _ (via x - startX * 2).
	fwY1 _ (startY + endY - (2 * via y)).
	fwY2 _ ((via y - startY) * 2).
	maxSteps _ deltaY asInteger * 2.
	scaledStepSize _ 16r1000000 // maxSteps.
	"@@: Okay, we need some fancy 64bit multiplication here"
	squaredStepSize _ self absoluteSquared8Dot24: scaledStepSize.
	squaredStepSize = ((scaledStepSize * scaledStepSize) bitShift: -24)
		ifFalse:[self error:'Bad computation'].
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx // 2).
	fwDy _ fwDy + (fwDDy // 2).

	self validateIntegerRange.

	lastX _ startX * 256.
	lastY _ startY * 256.

	edgeTableEntry xValue: startX.
	edgeTableEntry yValue: startY.
	edgeTableEntry zValue: 0.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		self stepToNextScanLineAt: yValue in: edgeTableEntry.
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 04:02'!
intStepToNextScanLineAt: yValue in: edgeTableEntry
	"Scaled integer version of forward differencing"
	[maxSteps >= 0 and:[yValue * 256 > lastY]] whileTrue:[
		self validateIntegerRange.
		lastX _ lastX + ((fwDx + 16r8000) // 16r10000).
		lastY _ lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
		maxSteps _ maxSteps - 1.
	].
	edgeTableEntry xValue: lastX // 256.
	edgeTableEntry zValue: 0.! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 22:14'!
isMonoton
	"Return true if the receiver is monoton along the y-axis,
	e.g., check if the tangents have the same sign"
	^(via y - start y) * (end y - via y) >= 0! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/31/1998 16:36'!
stepToFirstScanLineAt: yValue in: edgeTableEntry
	"Compute the initial x value for the scan line at yValue"
	^self intStepToFirstScanLineAt: yValue in: edgeTableEntry! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 03:40'!
stepToNextScanLineAt: yValue in: edgeTableEntry
	"Compute the next x value for the scan line at yValue.
	This message is sent during incremental updates. 
	The yValue parameter is passed in here for edges
	that have more complicated computations,"
	^self intStepToNextScanLineAt: yValue in: edgeTableEntry! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/1/1998 00:31'!
subdivide
	"Subdivide the receiver"
	| dy dx |
	"Test 1: If the bezier curve is not monoton in Y, we need a subdivision"
	self isMonoton ifFalse:[
		MonotonSubdivisions _ MonotonSubdivisions + 1.
		^self subdivideToBeMonoton].

	"Test 2: If the receiver is horizontal, don't do anything"
	(end y = start y) ifTrue:[^nil].

	"Test 3: If the receiver can be represented as a straight line,
			make a line from the receiver and declare it invalid"
	((end - start) crossProduct: (via - start)) = 0 ifTrue:[
		LineConversions _ LineConversions + 1.
		^self subdivideToBeLine].

	"Test 4: If the height of the curve exceeds 256 pixels, subdivide 
			(forward differencing is numerically not very stable)"
	dy _ end y - start y.
	dy < 0 ifTrue:[dy _ dy negated].
	(dy > 255) ifTrue:[
		HeightSubdivisions _ HeightSubdivisions + 1.
		^self subdivideAt: 0.5].

	"Test 5: Check if the incremental values could possibly overflow the scaled integer range"
	dx _ end x - start x.
	dx < 0 ifTrue:[dx _ dx negated].
	dy * 32 < dx ifTrue:[
		OverflowSubdivisions _ OverflowSubdivisions + 1.
		^self subdivideAt: 0.5].

	^nil! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 22:13'!
subdivideAt: parameter
	"Subdivide the receiver at the given parameter"
	| both |
	(parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt].
	both _ self computeSplitAt: parameter.
	"Transcript cr.
	self quickPrint: self.
	Transcript space.
	self quickPrint: both first.
	Transcript space.
	self quickPrint: both last.
	Transcript endEntry."
	self via: both first via.
	self end: both first end.
	^both last! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 11/11/1998 22:15'!
subdivideToBeLine
	"Not a true subdivision.
	Just return a line representing the receiver and fake me to be of zero height"
	| line |
	line _ BalloonLineSimulation new.
	line start: start.
	line end: end.
	"Make me invalid"
	end _ start.
	via _ start.
	 ^line! !

!BalloonBezierSimulation methodsFor: 'computing' stamp: 'ar 10/30/1998 02:24'!
subdivideToBeMonoton
	"Subdivide the receiver at it's extreme point"
	| v1 v2 t other |
	v1 _ (via - start).
	v2 _ (end - via).
	t _ (v1 y / (v2 y - v1 y)) negated asFloat.
	other _ self subdivideAt: t.
	self isMonoton ifFalse:[self halt].
	other isMonoton ifFalse:[self halt].
	^other! !


!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 16:37'!
absoluteSquared8Dot24: value
	"Compute the squared value of a 8.24 number with 0.0 <= value < 1.0,
	e.g., compute (value * value) bitShift: -24"
	| halfWord1 halfWord2 result |
	(value >= 0 and:[value < 16r1000000]) ifFalse:[^self error:'Value out of range'].
	halfWord1 _ value bitAnd: 16rFFFF.
	halfWord2 _ (value bitShift: -16) bitAnd: 255.

	result _ (halfWord1 * halfWord1) bitShift: -16. "We don't need the lower 16bits at all"
	result _ result + ((halfWord1 * halfWord2) * 2).
	result _ result + ((halfWord2 * halfWord2) bitShift: 16).
	"word1 _ halfWord1 * halfWord1.
	word2 _ (halfWord2 * halfWord1) + (word1 bitShift: -16).
	word1 _ word1 bitAnd: 16rFFFF.
	word2 _ word2 + (halfWord1 * halfWord2).
	word2 _ word2 + ((halfWord2 * halfWord2) bitShift: 16)."

	^result bitShift: -8! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDraw
	| entry minY maxY lX lY canvas |
	entry _ BalloonEdgeData new.
	canvas _ Display getCanvas.
	minY _ (start y min: end y) min: via y.
	maxY _ (start y max: end y) max: via y.
	entry yValue: minY.
	self stepToFirstScanLineAt: minY in: entry.
	lX _ entry xValue.
	lY _ entry yValue.
	minY+1 to: maxY do:[:y|
		self stepToNextScanLineAt: y in: entry.
		canvas line: lX@lY to: entry xValue @ y width: 2 color: Color black.
		lX _ entry xValue.
		lY _ y.
	].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDraw2
	| canvas last max t next |
	canvas _ Display getCanvas.
	max _ 100.
	last _ nil.
	0 to: max do:[:i|
		t _ i asFloat / max asFloat.
		next _ self valueAt: t.
		last ifNotNil:[
			canvas line: last to: next rounded width: 2 color: Color blue.
		].
		last _ next rounded.
	].! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 5/25/2000 17:57'!
debugDrawWide: n
	| entry minY maxY canvas curve p1 p2 entry2 y |
	curve _ self class new.
	curve start: start + (0@n).
	curve via: via + (0@n).
	curve end: end + (0@n).
	entry _ BalloonEdgeData new.
	entry2 _ BalloonEdgeData new.
	canvas _ Display getCanvas.
	minY _ (start y min: end y) min: via y.
	maxY _ (start y max: end y) max: via y.
	entry yValue: minY.
	entry2 yValue: minY + n.
	self stepToFirstScanLineAt: minY in: entry.
	curve stepToFirstScanLineAt: minY+n in: entry2.
	y _ minY.
	1 to: n do:[:i|
		y _ y + 1.
		self stepToNextScanLineAt: y in: entry.
		p1 _ entry xValue @ y.
		canvas line: p1 to: p1 + (n@0) width: 1 color: Color black.
	].
	[y < maxY] whileTrue:[
		y _ y + 1.
		self stepToNextScanLineAt: y in: entry.
		p2 _ (entry xValue + n) @ y.
		curve stepToNextScanLineAt: y in: entry2.
		p1 _ entry2 xValue @ y.
		canvas line: p1 to: p2 width: 1 color: Color black.
	].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:35'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPutAll:' - ';
		print: via;
		nextPutAll:' - ';
		print: end;
		nextPut:$)! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'MPW 1/1/1901 21:55'!
printOnStream: aStream
	aStream 
		print: self class name;
		print:'(';
		write: start;
		print:' - ';
		write: via;
		print:' - ';
		write: end;
		print:')'.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 21:56'!
quickPrint: curve
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 22:13'!
quickPrint: curve first: aBool
	aBool ifTrue:[Transcript cr].
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).
	Transcript endEntry.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:53'!
stepToFirst
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	steps scaledStepSize squaredStepSize |
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(deltaY = 0) ifTrue:[^self].

	fwX1 _ (startX + endX - (2 * via x)) asFloat.
	fwX2 _ (via x - startX * 2) asFloat.
	fwY1 _ (startY + endY - (2 * via y)) asFloat.
	fwY2 _ ((via y - startY) * 2) asFloat.
	steps _ deltaY asInteger * 2.
	scaledStepSize _ 1.0 / steps asFloat.
	squaredStepSize _ scaledStepSize * scaledStepSize.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2.0 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2.0 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx * 0.5).
	fwDy _ fwDy + (fwDDy * 0.5).

	lastX _ startX asFloat.
	lastY _ startY asFloat.
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:50'!
stepToFirstInt
	"Scaled integer version of forward differencing"
	|  startX endX startY endY deltaY fwX1 fwX2 fwY1 fwY2 
	 scaledStepSize squaredStepSize |
	self halt.
	(end y) >= (start y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
	].

	deltaY _ endY - startY.

	"Quickly check if the line is visible at all"
	(deltaY = 0) ifTrue:[^nil].

	fwX1 _ (startX + endX - (2 * via x)).
	fwX2 _ (via x - startX * 2).
	fwY1 _ (startY + endY - (2 * via y)).
	fwY2 _ ((via y - startY) * 2).
	maxSteps _ deltaY asInteger * 2.
	scaledStepSize _ 16r1000000 // maxSteps.
	"@@: Okay, we need some fancy 64bit multiplication here"
	squaredStepSize _ (scaledStepSize * scaledStepSize) bitShift: -24.
	fwDx _ fwX2 * scaledStepSize.
	fwDDx _ 2 * fwX1 * squaredStepSize.
	fwDy _ fwY2 * scaledStepSize.
	fwDDy _ 2 * fwY1 * squaredStepSize.
	fwDx _ fwDx + (fwDDx // 2).
	fwDy _ fwDy + (fwDDy // 2).

	self validateIntegerRange.

	lastX _ startX * 256.
	lastY _ startY * 256.
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 00:26'!
stepToNext
		lastX _ lastX + fwDx.
		lastY _ lastY + fwDy.
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 04:01'!
stepToNextInt
	"Scaled integer version of forward differencing"
	self halt.
	(maxSteps >= 0) ifTrue:[
		self validateIntegerRange.
		lastX _ lastX + ((fwDx + 16r8000) // 16r10000).
		lastY _ lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx _ fwDx + fwDDx.
		fwDy _ fwDy + fwDDy.
		maxSteps _ maxSteps - 1.
	].! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:27'!
validateIntegerRange
	fwDx class == SmallInteger ifFalse:[self halt].
	fwDy class == SmallInteger ifFalse:[self halt].
	fwDDx class == SmallInteger ifFalse:[self halt].
	fwDDy class == SmallInteger ifFalse:[self halt].
! !

!BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/29/1998 21:26'!
valueAt: parameter
	"Return the point at the value parameter:
		p(t) =	(1-t)^2 * p1 + 
				2*t*(1-t) * p2 + 
				t^2 * p3.
	"
	| t1 t2 t3 |
	t1 _ (1.0 - parameter) squared.
	t2 _ 2 * parameter * (1.0 - parameter).
	t3 _ parameter squared.
	^(start * t1) + (via * t2) + (end * t3)! !

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

BalloonBezierSimulation class
	instanceVariableNames: ''!

!BalloonBezierSimulation class methodsFor: 'class initialization' stamp: 'ar 10/30/1998 03:04'!
initialize
	"GraphicsBezierSimulation initialize"
	HeightSubdivisions _ 0.
	LineConversions _ 0.
	MonotonSubdivisions _ 0.
	OverflowSubdivisions _ 0.! !
Object variableWordSubclass: #BalloonBuffer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'!
at: index
	"For simulation only"
	| word |
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 10/26/1998 21:12'!
at: index put: anInteger
	"For simulation only"
	| word |
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index
	"For simulation only"
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!BalloonBuffer methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
floatAt: index put: value
	"For simulation only"
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

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

BalloonBuffer class
	instanceVariableNames: ''!

!BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'!
mew: n
	^self new: (n max: 256)! !

!BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'!
new
	^self new: 256.! !
FormCanvas subclass: #BalloonCanvas
	instanceVariableNames: 'transform colorTransform engine aaLevel deferred '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!

!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'!
flush
	"Force all pending primitives onscreen"
	engine ifNotNil:[engine flush].! !

!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 12/30/1998 10:54'!
initialize
	aaLevel _ 1.
	deferred _ false.! !

!BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'!
resetEngine
	engine _ nil.! !


!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 11/13/1998 01:02'!
aaLevel
	^aaLevel! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:53'!
aaLevel: newLevel
	"Only allow changes to aaLevel if we're working on >= 8 bit forms"
	form depth >= 8 ifFalse:[^self].
	aaLevel = newLevel ifTrue:[^self].
	self flush.	"In case there are pending primitives in the engine"
	aaLevel _ newLevel.
	engine ifNotNil:[engine aaLevel: aaLevel].! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:54'!
deferred
	^deferred! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'!
deferred: aBoolean
	deferred == aBoolean ifTrue:[^self].
	self flush. "Force pending prims on screen"
	deferred _ aBoolean.
	engine ifNotNil:[engine deferred: aBoolean].! !

!BalloonCanvas methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:55'!
ensuredEngine
	engine ifNil:[
		true
			ifTrue:[engine _ BalloonEngine new]
			ifFalse:[engine _ BalloonDebugEngine new].
		engine aaLevel: aaLevel.
		engine bitBlt: port.
		engine destOffset: origin.
		engine clipRect: clipRect.
		engine deferred: deferred.
		engine].
	engine colorTransform: colorTransform.
	engine edgeTransform: transform.
	^engine! !


!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'!
isBalloonCanvas
	^true! !

!BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/12/1998 01:07'!
isVisible: aRectangle
	^transform 
		ifNil:[super isVisible: aRectangle]
		ifNotNil:[super isVisible: (transform localBoundsToGlobal: aRectangle)]! !


!BalloonCanvas methodsFor: 'copying' stamp: 'ar 11/24/1998 22:33'!
copy
	self flush.
	^super copy resetEngine! !


!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'!
fillColor: c
	"Note: This always fills, even if the color is transparent."
	"Note2: To achieve the above we must make sure that c is NOT transparent"
	self frameAndFillRectangle: form boundingBox 
		fillColor: (c alpha: 1.0)
		borderWidth: 0
		borderColor: nil! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:51'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a filled and outlined oval"
	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super fillOval: r color: c borderWidth: borderWidth borderColor: borderColor].

	^self drawOval: (r insetBy: borderWidth // 2) 
			color: c 
			borderWidth: borderWidth 
			borderColor: borderColor! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:40'!
fillRectangle: r color: c
	"Fill the rectangle with the given color"
	^self frameAndFillRectangle: r
			fillColor: c
			borderWidth: 0
			borderColor: nil! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 06:26'!
frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor
	"Draw a filled and outlined rectangle"
	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super frameAndFillRectangle: r fillColor: c borderWidth: borderWidth borderColor: borderColor].

	^self drawRectangle: (r insetBy: borderWidth // 2) 
			color: c 
			borderWidth: borderWidth 
			borderColor: borderColor! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:52'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw a beveled or raised rectangle"
	| bw |

	"Note: The optimization test below should actually read:
		self ifNoTransformWithIn: (r insetBy: borderWidth // 2)
	but since borderWidth is assumed to be very small related to r we don't check it."

	(self ifNoTransformWithIn: r)
		ifTrue:[^super frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor].

	"Fill rectangle and draw top and left border"
	bw _ borderWidth // 2.
	self drawRectangle: (r insetBy: bw)
		color: fillColor
		borderWidth: borderWidth
		borderColor: topLeftColor.
	"Now draw bottom right border."
	self drawPolygon: (Array with: r topRight + (bw negated@bw) 
							with: r bottomRight - bw asPoint
							with: r bottomLeft + (bw@bw negated))
		color: nil
		borderWidth: borderWidth
		borderColor: bottomRightColor.! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/9/1999 05:41'!
frameRectangle: r width: w color: c
	"Draw a frame around the given rectangle"
	^self frameAndFillRectangle: r
			fillColor: nil
			borderWidth: w
			borderColor: c! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 2/12/1999 17:45'!
line: pt1 to: pt2 width: w color: c
	"Draw a line from pt1 to: pt2"
	(self ifNoTransformWithIn:(pt1 rect: pt2))
		ifTrue:[^super line: pt1 to: pt2 width: w color: c].
	^self drawPolygon: (Array with: pt1 with: pt2)
		color: c
		borderWidth: w
		borderColor: c! !

!BalloonCanvas methodsFor: 'drawing' stamp: 'ar 11/11/1998 19:39'!
point: pt color: c
	"Is there any use for this?"
	| myPt |
	transform 
		ifNil:[myPt _ pt]
		ifNotNil:[myPt _ transform localPointToGlobal: pt].
	^super point: myPt color: c! !


!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:14'!
drawBezier3Shape: vertices color: c borderWidth: borderWidth borderColor:
borderColor
	self drawBezierShape: (Bezier3Segment convertBezier3ToBezier2:
vertices) color: c borderWidth: borderWidth borderColor: borderColor! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:25'!
drawBezierShape: vertices color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a boundary shape that is defined by a list of vertices.
	Each three subsequent vertices define a quadratic bezier segment.
	For lines, the control point should be set to either the start or the end
	of the bezier curve."
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawBezierShape: vertices
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 11/24/1998 15:16'!
drawCompressedShape: compressedShape
	"Draw a compressed shape"
	self ensuredEngine
		drawCompressedShape: compressedShape
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'DSM 10/15/1999 15:18'!
drawGeneralBezier3Shape: contours color: c borderWidth: borderWidth
borderColor: borderColor
	| b2 |
	b2 _ contours collect: [:b3 | Bezier3Segment
convertBezier3ToBezier2: b3 ].
	self drawGeneralBezierShape: b2 color: c borderWidth: borderWidth
borderColor: borderColor! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawGeneralBezierShape: contours color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a general boundary shape (e.g., possibly containing holes)"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawGeneralBezierShape: contours
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawGeneralPolygon: contours color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a general polygon (e.g., a polygon that can contain holes)"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawGeneralPolygon: contours
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw the oval defined by the given rectangle"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawOval: r
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 2/17/2000 00:24'!
drawRectangle: r color: c borderWidth: borderWidth borderColor: borderColor
	"Draw a rectangle"
	| fillC borderC |
	fillC _ self shadowColor ifNil:[c].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawRectangle: r
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

!BalloonCanvas methodsFor: 'balloon drawing' stamp: 'ar 5/28/2000 12:23'!
render: anObject
	| b3d |
	b3d _ (B3DRenderEngine defaultForPlatformOn: form).
	"Install the viewport offset"
	b3d viewportOffset: origin.
	"Install the clipping rectangle for the target form"
	b3d clipRect: clipRect.
	anObject renderOn: b3d.
	b3d flush.! !


!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 2/9/1999 05:46'!
line: point1 to: point2 brushForm: brush
	"Who's gonna use this?"
	| pt1 pt2 |
	self flush. "Sorry, but necessary..."
	transform 
		ifNil:[pt1 _ point1. pt2 _ point2]
		ifNotNil:[pt1 _ transform localPointToGlobal: point1.
				pt2 _ transform localPointToGlobal: point2].
	^super line: pt1 to: pt2 brushForm: brush! !

!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 2/9/1999 05:46'!
paragraph: para bounds: bounds color: c
	(self ifNoTransformWithIn: bounds)
		ifTrue:[^super paragraph: para bounds: bounds color: c].! !

!BalloonCanvas methodsFor: 'TODO' stamp: 'ar 2/9/1999 05:38'!
text: s bounds: boundsRect font: fontOrNil color: c
	(self ifNoTransformWithIn: boundsRect)
		ifTrue:[^super text: s bounds: boundsRect font: fontOrNil color: c]! !


!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/24/1998 14:45'!
colorTransformBy: aColorTransform
	aColorTransform ifNil:[^self].
	colorTransform 
		ifNil:[colorTransform _ aColorTransform]
		ifNotNil:[colorTransform _ colorTransform composedWithLocal: aColorTransform]! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 12/30/1998 10:47'!
preserveStateDuring: aBlock
	| state result |
	state _ BalloonState new.
	state transform: transform.
	state colorTransform: colorTransform.
	state aaLevel: self aaLevel.
	result _ aBlock value: self.
	transform _ state transform.
	colorTransform _ state colorTransform.
	self aaLevel: state aaLevel.
	^result! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 11/12/1998 00:32'!
transformBy: aTransform
	aTransform ifNil:[^self].
	transform 
		ifNil:[transform _ aTransform]
		ifNotNil:[transform _ transform composedWithLocal: aTransform]! !

!BalloonCanvas methodsFor: 'transforming' stamp: 'ar 5/29/1999 08:59'!
transformBy: aDisplayTransform during: aBlock
	| myTransform result |
	myTransform _ transform.
	self transformBy: aDisplayTransform.
	result _ aBlock value: self.
	transform _ myTransform.
	^result! !


!BalloonCanvas methodsFor: 'private' stamp: 'ar 2/9/1999 06:29'!
ifNoTransformWithIn: box
	"Return true if the current transformation does not affect the given bounding box"
	| delta |
	"false ifFalse:[^false]."
	transform isNil ifTrue:[^true].
	delta _ (transform localPointToGlobal: box origin) - box origin.
	^(transform localPointToGlobal: box corner) - box corner = delta! !

!BalloonCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 12:12'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	| warp dstRect srcQuad dstOffset center |
	(self ifNoTransformWithIn: sourceRect) & false
		ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule].
	dstRect _ (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)).
	dstOffset _ 0@0. "dstRect origin."
	"dstRect _ 0@0 corner: dstRect extent."
	center _ 0@0."transform globalPointToLocal: dstRect origin."
	srcQuad _ transform globalPointsToLocal: (dstRect innerCorners).
	srcQuad _ srcQuad collect:[:pt| pt - aPoint].
	warp _ (WarpBlt current toForm: Display)
			sourceForm: aForm;
			cellSize: 2;  "installs a new colormap if cellSize > 1"
			combinationRule: Form over.
	warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset).

	self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green.

	"... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! !


!BalloonCanvas methodsFor: 'converting' stamp: 'ar 11/11/1998 22:57'!
asBalloonCanvas
	^self! !


!BalloonCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 08:48'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	^self drawRectangle: aRectangle
			color: aFillStyle "@@: Name confusion!!!!!!"
			borderWidth: 0
			borderColor: nil
! !


!BalloonCanvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given rectangle."
	^self drawOval: (aRectangle insetBy: bw // 2)
			color: aFillStyle "@@: Name confusion!!!!!!"
			borderWidth: bw
			borderColor: bc
! !


!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 09:00'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Generalize for the BalloonCanvas"
	^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! !

!BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 2/17/2000 00:25'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor
	"Draw a simple polygon defined by the list of vertices."
	| fillC borderC |
	fillC _ self shadowColor ifNil:[aFillStyle].
	borderC _ self shadowColor ifNil:[borderColor].
	self ensuredEngine
		drawPolygon: (vertices copyWith: vertices first)
		fill: fillC
		borderWidth: borderWidth
		borderColor: borderC
		transform: transform.! !

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

BalloonCanvas class
	instanceVariableNames: ''!

!BalloonCanvas class methodsFor: 'instance creation' stamp: 'ar 11/11/1998 19:14'!
new
	^super new initialize! !
BalloonEngine subclass: #BalloonDebugEngine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!

!BalloonDebugEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:30'!
initialize
	super initialize.
	deferred _ true.! !

!BalloonDebugEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 01:45'!
reset
	workBuffer _ BalloonBuffer new: 400000.
	super reset.! !


!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:04'!
primClipRectInto: rect
	^BalloonEnginePlugin doPrimitive:'gePrimitiveGetClipRect'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/25/1998 22:29'!
primFlushNeeded
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveNeedsFlush'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:04'!
primGetAALevel
	"Set the AA level"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetAALevel'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:04'!
primGetBezierStats: statsArray
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetBezierStats'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:04'!
primGetClipRect: rect
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetClipRect'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primGetCounts: statsArray
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetCounts'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:55'!
primGetDepth
	"Set the AA level"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetDepth'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primGetFailureReason
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetFailureReason'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primGetOffset
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetOffset'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primGetTimes: statsArray
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveGetTimes'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/25/1998 22:20'!
primNeedsFlush
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveNeedsFlush'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primSetAALevel: level
	"Set the AA level"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetAALevel'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:05'!
primSetClipRect: rect
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetClipRect'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:06'!
primSetColorTransform: transform
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetColorTransform'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:06'!
primSetDepth: depth
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetDepth'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:06'!
primSetEdgeTransform: transform
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetEdgeTransform'! !

!BalloonDebugEngine methodsFor: 'primitives-access' stamp: 'ar 11/24/1998 21:06'!
primSetOffset: point
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveSetOffset'! !


!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:11'!
primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddBezier'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:01'!
primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddBezierShape'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/27/1998 14:27'!
primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddBitmapFill'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:01'!
primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddCompressedShape'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:02'!
primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveRegisterExternalEdge'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:02'!
primAddExternalFill: index
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveRegisterExternalFill'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:02'!
primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddGradientFill'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:16'!
primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddLine'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:03'!
primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddOval'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:03'!
primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddPolygon'! !

!BalloonDebugEngine methodsFor: 'primitives-adding' stamp: 'ar 11/24/1998 21:20'!
primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddRect'! !


!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 20:59'!
primAddActiveEdgeTableEntryFrom: edgeEntry
	"Add edge entry to the AET."
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveAddActiveEdgeEntry'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 20:59'!
primChangeActiveEdgeTableEntryFrom: edgeEntry
	"Change the entry in the active edge table from edgeEntry"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveChangedActiveEdgeEntry'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 20:59'!
primDisplaySpanBuffer
	"Display the current scan line if necessary"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveDisplaySpanBuffer'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 20:59'!
primFinishedProcessing
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveFinishedProcessing'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primInitializeProcessing
	"Initialize processing in the GE.
	Create the active edge table and sort it."
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveInitializeProcessing'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primMergeFill: fillBitmap from: fill
	"Merge the filled bitmap into the current output buffer."
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveMergeFillFrom'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primNextActiveEdgeEntryInto: edgeEntry
	"Store the next entry of the AET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveNextActiveEdgeEntry'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primNextFillEntryInto: fillEntry
	"Store the next fill entry of the active edge table in fillEntry.
	Return false if there is no such entry, true otherwise"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveNextFillEntry'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primNextGlobalEdgeEntryInto: edgeEntry
	"Store the next entry of the GET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveNextGlobalEdgeEntry'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primRenderImage: edge with: fill
	"Start/Proceed rendering the current scan line"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveRenderImage'! !

!BalloonDebugEngine methodsFor: 'primitives-incremental' stamp: 'ar 11/24/1998 21:00'!
primRenderScanline: edge with: fill
	"Start/Proceed rendering the current scan line"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveRenderScanline'! !


!BalloonDebugEngine methodsFor: 'primitives-misc' stamp: 'ar 11/24/1998 20:59'!
primCopyBufferFrom: oldBuffer to: newBuffer
	"Copy the contents of oldBuffer into the (larger) newBuffer"
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveCopyBuffer'! !

!BalloonDebugEngine methodsFor: 'primitives-misc' stamp: 'ar 11/24/1998 20:59'!
primInitializeBuffer: buffer
	^BalloonEnginePlugin doPrimitive: 'gePrimitiveInitializeBuffer'! !
Object subclass: #BalloonEdgeData
	instanceVariableNames: 'index xValue yValue zValue lines source '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!
!BalloonEdgeData commentStamp: '<historical>' prior: 0!
BalloonEdgeData defines an entry in the internal edge table of the Balloon engine.

Instance Variables:
	index	<Integer>	The index into the external objects array of the associated graphics engine
	xValue	<Integer>	The computed x-value of the requested operation
	yValue	<Integer>	The y-value for the requested operation
	height	<Integer>	The (remaining) height of the edge
	source	<Object>		The object from the external objects array!


!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
index
	^index! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
index: anInteger
	index _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'!
lines
	^lines! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'!
lines: anInteger
	^lines _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
source
	^source! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'!
source: anObject
	source _ anObject! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
xValue
	^xValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
xValue: anInteger
	xValue _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'!
yValue
	^yValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'!
yValue: anInteger
	yValue _ anInteger! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'!
zValue
	^zValue! !

!BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'!
zValue: anInteger
	zValue _ anInteger! !


!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'!
stepToFirstScanLine
	source stepToFirstScanLineAt: yValue in: self! !

!BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'!
stepToNextScanLine
	source stepToNextScanLineAt: yValue in: self! !
Object subclass: #BalloonEngine
	instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded '
	classVariableNames: 'BezierStats BufferCache CacheProtect Counts Debug Times '
	poolDictionaries: 'BalloonEngineConstants '
	category: 'Balloon-Engine'!

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:29'!
flush
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	self copyBits.
	self release.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 12/30/1998 11:24'!
initialize
	externals _ OrderedCollection new: 100.
	span _ Bitmap new: 2048.
	bitBlt _ nil.
	self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself).
	forms _ #().
	deferred _ false.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:42'!
postFlushIfNeeded
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	(deferred not or:[postFlushNeeded]) ifTrue:[
		self copyBits.
		self release].! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:43'!
preFlushIfNeeded
	"Force all pending primitives onscreen"
	workBuffer ifNil:[^self].
	self primFlushNeeded ifTrue:[
		self copyBits.
		self reset].! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/11/1998 22:52'!
release
	self class recycleBuffer: workBuffer.
	workBuffer _ nil.! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:34'!
reset
	workBuffer ifNil:[workBuffer _ self class allocateOrRecycleBuffer: 10000].
	self primInitializeBuffer: workBuffer.
	self primSetAALevel: self aaLevel.
	self primSetOffset: destOffset.
	self primSetClipRect: clipRect.
	self primSetEdgeTransform: edgeTransform.
	self primSetColorTransform: colorTransform.
	forms _ #().! !

!BalloonEngine methodsFor: 'initialize' stamp: 'ar 11/25/1998 22:39'!
resetIfNeeded
	workBuffer ifNil:[self reset].
	self primSetEdgeTransform: edgeTransform.
	self primSetColorTransform: colorTransform.
	self primSetDepth: self primGetDepth + 1.
	postFlushNeeded _ false.! !


!BalloonEngine methodsFor: 'drawing' stamp: 'ar 10/11/1999 16:49'!
drawBezierShape: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform
	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	self primAddBezierShape: points
		segments: (points size) // 3
		fill: (fills at: 1)
		lineWidth: borderWidth
		lineFill: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:44'!
drawCompressedShape: shape transform: aTransform
	| fillIndexList |
	self edgeTransform: aTransform.
	self resetIfNeeded.

	fillIndexList _ self registerFills: shape fillStyles.

	self primAddCompressedShape: shape points
		segments: shape numSegments
		leftFills: shape leftFills
		rightFills: shape rightFills
		lineWidths: shape lineWidths
		lineFills: shape lineFills
		fillIndexList: fillIndexList.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'!
drawGeneralBezierShape: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	contours do:[:points|
		self primAddBezierShape: points
			segments: (points size // 3)
			fill: (fills at: 1)
			lineWidth: borderWidth
			lineFill: (fills at: 2).
		"Note: To avoid premature flushing of the pipeline we need to
		reset the flush bit within the engine."
		self primFlushNeeded: false.
	].
	"And set the flush bit afterwards"
	self primFlushNeeded: true.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/15/1999 03:02'!
drawGeneralPolygon: contours fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	contours do:[:points|
		self primAddPolygon: points
			segments: points size
			fill: (fills at: 1)
			lineWidth: borderWidth
			lineFill: (fills at: 2).
		"Note: To avoid premature flushing of the pipeline we need to
		reset the flush bit within the engine."
		self primFlushNeeded: false.
	].
	"And set the flush bit afterwards"
	self primFlushNeeded: true.
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawOval: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix

	| fills |
	self edgeTransform: aMatrix.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderColor.
	self primAddOvalFrom: rect origin 
			to: rect corner
			fillIndex: (fills at: 1)
			borderWidth: borderWidth
			borderColor: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawPolygon: points fill: fillStyle borderWidth: borderWidth borderColor: borderFill transform: aTransform

	| fills |
	self edgeTransform: aTransform.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderFill.
	self primAddPolygon: points
		segments: points size
		fill: (fills at: 1)
		lineWidth: borderWidth
		lineFill: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
drawRectangle: rect fill: fillStyle borderWidth: borderWidth borderColor: borderColor transform: aMatrix

	| fills |
	self edgeTransform: aMatrix.
	self resetIfNeeded.
	fills _ self registerFill: fillStyle and: borderColor.
	self primAddRectFrom: rect origin 
			to: rect corner
			fillIndex: (fills at: 1)
			borderWidth: borderWidth
			borderColor: (fills at: 2).
	self postFlushIfNeeded.! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/14/1999 15:24'!
registerFill: aFillStyle
	"Register the given fill style."
	| theForm |
	aFillStyle ifNil:[^0].
	aFillStyle isSolidFill 
		ifTrue:[^aFillStyle scaledPixelValue32].

	aFillStyle isGradientFill ifTrue:[
		^self primAddGradientFill: aFillStyle pixelRamp
			from: aFillStyle origin
			along: aFillStyle direction
			normal: aFillStyle normal
			radial: aFillStyle isRadialFill
		].
	aFillStyle isBitmapFill ifTrue:[
		theForm _ aFillStyle form.
		theForm unhibernate.
		forms _ forms copyWith: theForm.
		^self primAddBitmapFill: theForm
				colormap: (theForm colormapIfNeededForDepth: 32)
				tile: aFillStyle isTiled
				from: aFillStyle origin
				along: aFillStyle direction
				normal: aFillStyle normal
				xIndex: forms size].
	^0! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 11/26/1998 19:45'!
registerFill: fill1 and: fill2
	^self registerFills: (Array with: fill1 with: fill2)! !

!BalloonEngine methodsFor: 'drawing' stamp: 'ar 1/14/1999 15:24'!
registerFill: aFillStyle transform: aTransform

	aFillStyle ifNil:[^0].
	aFillStyle isSolidFill 
		ifTrue:[^aFillStyle scaledPixelValue32].

	aFillStyle isGradientFill ifTrue:[
		^self primAddGradientFill: aFillStyle pixelRamp
			from: aFillStyle origin
			along: aFillStyle direction
			normal: aFillStyle normal
			radial: aFillStyle isRadialFill
			matrix: aTransform.
		].
	^0! !

!BalloonEngine methodsFor: 'drawing' stamp: 'di 11/21/1999 20:15'!
registerFills: fills

	| fillIndexList index fillIndex |
	((colorTransform notNil and:[colorTransform isAlphaTransform]) or:[
		fills anySatisfy: [:any| any notNil and:[any isTranslucent]]])
			ifTrue:[	self flush.
					self reset.
					postFlushNeeded _ true].
	fillIndexList _ WordArray new: fills size.
	index _ 1.
	[index <= fills size] whileTrue:[
		fillIndex _ self registerFill: (fills at: index).
		fillIndex == nil 
			ifTrue:[index _ 1] "Need to start over"
			ifFalse:[fillIndexList at: index put: fillIndex.
					index _ index+1]
	].
	^fillIndexList! !


!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/25/1998 00:45'!
canProceedAfter: failureReason
	"Check if we can proceed after the failureReason indicated."
	| newBuffer |
	failureReason = GErrorNeedFlush ifTrue:[
		"Need to flush engine before proceeding"
		self copyBits.
		self reset.
		^true].
	failureReason = GErrorNoMoreSpace ifTrue:[
		"Work buffer is too small"
		newBuffer _ workBuffer species new: workBuffer size * 2.
		self primCopyBufferFrom: workBuffer to: newBuffer.
		workBuffer _ newBuffer.
		^true].
	"Not handled"
	^false! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/29/1998 18:22'!
copyBits
	self copyLoopFaster.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'!
copyLoop
	"This is the basic rendering loop using as little primitive support as possible."
	| finished edge fill |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	self primInitializeProcessing. "Initialize the GE for processing"
	[self primFinishedProcessing] whileFalse:[
		"Step 1: Process the edges in the global edge table that will be added in this step"
		[finished _ self primNextGlobalEdgeEntryInto: edge.
		finished] whileFalse:[
			edge source: (externals at: edge index).
			edge stepToFirstScanLine.
			self primAddActiveEdgeTableEntryFrom: edge].

		"Step 2: Scan the active edge table"
		[finished _ self primNextFillEntryInto: fill.
		finished] whileFalse:[
			fill source: (externals at: fill index).
			"Compute the new fill"
			fill computeFill.
			"And mix it in the out buffer"
			self primMergeFill: fill destForm bits from: fill].

		"Step 3: Display the current span buffer if necessary"
		self primDisplaySpanBuffer.

		"Step 4: Advance and resort the active edge table"
		[finished _ self primNextActiveEdgeEntryInto: edge.
		finished] whileFalse:[
			"If the index is zero then the edge has been handled by the GE"
			edge source: (externals at: edge index).
			edge stepToNextScanLine.
			self primChangeActiveEdgeTableEntryFrom: edge].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:32'!
copyLoopFaster
	"This is a copy loop drawing one scan line at a time"
	| edge fill reason |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	[self primFinishedProcessing] whileFalse:[
		reason _ self primRenderScanline: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/14/1998 19:33'!
copyLoopFastest
	"This is a copy loop drawing the entire image"
	| edge fill reason |
	edge _ BalloonEdgeData new.
	fill _ BalloonFillData new.
	[self primFinishedProcessing] whileFalse:[
		reason _ self primRenderImage: edge with: fill.
		"reason ~= 0 means there has been a problem"
		reason = 0 ifFalse:[
			self processStopReason: reason edge: edge fill: fill.
		].
	].
	self primGetTimes: Times.
	self primGetCounts: Counts.
	self primGetBezierStats: BezierStats.! !

!BalloonEngine methodsFor: 'copying' stamp: 'ar 11/11/1998 21:19'!
processStopReason: reason edge: edge fill: fill
	"The engine has stopped because of some reason.
	Try to figure out how to respond and do the necessary actions."
	"Note: The order of operations below can affect the speed"

	"Process unknown fills first"
	reason = GErrorFillEntry ifTrue:[
		fill source: (externals at: fill index).
		"Compute the new fill"
		fill computeFill.
		"And mix it in the out buffer"
		^self primMergeFill: fill destForm bits from: fill].

	"Process unknown steppings in the AET second"
	reason = GErrorAETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToNextScanLine.
		^self primChangeActiveEdgeTableEntryFrom: edge].

	"Process unknown entries in the GET third"
	reason = GErrorGETEntry ifTrue:[
		edge source: (externals at: edge index).
		edge stepToFirstScanLine.
		^self primAddActiveEdgeTableEntryFrom: edge].

	"Process generic problems last"
	(self canProceedAfter: reason) ifTrue:[^self]. "Okay."

	^self error:'Unkown stop reason in graphics engine'
! !


!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'!
aaLevel
	^aaLevel ifNil:[1]! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'!
aaLevel: anInteger
	aaLevel _ (anInteger min: 4) max: 1.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'!
aaTransform
	"Return a transformation for the current anti-aliasing level"
	| matrix |
	matrix _ MatrixTransform2x3 withScale: (self aaLevel) asFloat asPoint.
	matrix offset: (self aaLevel // 2) asFloat asPoint.
	^matrix composedWith:(MatrixTransform2x3 withOffset: destOffset asFloatPoint)! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'!
bitBlt
	^bitBlt! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:02'!
bitBlt: aBitBlt
	bitBlt _ aBitBlt.
	bitBlt isNil ifTrue:[^self].
	self class primitiveSetBitBltPlugin: bitBlt getPluginName.
	self clipRect: bitBlt clipRect.
	bitBlt 
		sourceForm: (Form extent: span size @ 1 depth: 32 bits: span);
		sourceRect: (0@0 extent: 1@span size);
		colorMap: (Color colorMapIfNeededFrom: 32 to: bitBlt destForm depth);
		combinationRule: (bitBlt destForm depth >= 8 ifTrue:[34] ifFalse:[Form paint]).! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:57'!
clipRect
	^clipRect! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'!
clipRect: aRect
	clipRect _ aRect truncated! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'!
colorTransform
	^colorTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'!
colorTransform: aColorTransform
	colorTransform _ aColorTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'!
deferred
	^deferred! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'!
deferred: aBoolean
	deferred _ aBoolean.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'!
destOffset
	^destOffset! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'!
destOffset: aPoint
	destOffset _ aPoint asIntegerPoint.
	bitBlt destX: aPoint x; destY: aPoint y.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'!
edgeTransform
	^edgeTransform! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'!
edgeTransform: aTransform
	edgeTransform _ aTransform.! !

!BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/29/1998 01:51'!
fullTransformFrom: aMatrix
	| m |
	m _ self aaTransform composedWith: aMatrix.
	"m offset: m offset + destOffset."
	^m! !


!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:48'!
primClipRectInto: rect
	<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primFlushNeeded
	<primitive: 'primitiveNeedsFlush' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primFlushNeeded: aBoolean
	<primitive: 'primitiveNeedsFlushPut' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetAALevel
	"Set the AA level"
	<primitive: 'primitiveGetAALevel' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetBezierStats: statsArray
	<primitive: 'primitiveGetBezierStats' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetClipRect: rect
	<primitive: 'primitiveGetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetCounts: statsArray
	<primitive: 'primitiveGetCounts' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primGetDepth
	<primitive: 'primitiveGetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetFailureReason
	<primitive: 'primitiveGetFailureReason' module: 'B2DPlugin'>
	^0! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetOffset
	<primitive: 'primitiveGetOffset' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primGetTimes: statsArray
	<primitive: 'primitiveGetTimes' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetAALevel: level
	"Set the AA level"
	<primitive: 'primitiveSetAALevel' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetClipRect: rect
	<primitive: 'primitiveSetClipRect' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetColorTransform: transform
	<primitive: 'primitiveSetColorTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetDepth: depth
	<primitive: 'primitiveSetDepth' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'!
primSetEdgeTransform: transform
	<primitive: 'primitiveSetEdgeTransform' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'!
primSetOffset: point
	<primitive: 'primitiveSetOffset' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveAddBezier' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBezierFrom: start to: end via: via leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddBezierShape' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBezierShape: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	<primitive: 'primitiveAddBitmapFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddBitmapFill: form colormap: cmap tile: tileFlag from: origin along: direction normal: normal xIndex: xIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	<primitive: 'primitiveAddCompressedShape' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveRegisterExternalEdge' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddExternalEdge: index initialX: initialX initialY: initialY initialZ: initialZ leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddExternalFill: index
	<primitive: 'primitiveRegisterExternalFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddExternalFill: index
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddGradientFill: colorRamp from: origin along: direction normal: normal radial: isRadial
	<primitive: 'primitiveAddGradientFill' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddGradientFill: colorRamp 
				from: origin 
				along: direction 
				normal: normal 
				radial: isRadial
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	<primitive: 'primitiveAddLine' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddLineFrom: start to: end leftFillIndex: leftFillIndex rightFillIndex: rightFillIndex
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddOval' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddOvalFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	<primitive: 'primitiveAddPolygon' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddPolygon: points segments: nSegments fill: fillStyle lineWidth: lineWidth lineFill: lineFill
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-adding' stamp: 'ar 2/2/2001 15:47'!
primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	<primitive: 'primitiveAddRect' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddRectFrom: start to: end fillIndex: fillIndex borderWidth: width borderColor: pixelValue32
	].
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primAddActiveEdgeTableEntryFrom: edgeEntry
	"Add edge entry to the AET."
	<primitive: 'primitiveAddActiveEdgeEntry' module: 'B2DPlugin'>
	(self canProceedAfter: self primGetFailureReason) ifTrue:[
		^self primAddActiveEdgeTableEntryFrom: edgeEntry
	].
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primChangeActiveEdgeTableEntryFrom: edgeEntry
	"Change the entry in the active edge table from edgeEntry"
	<primitive: 'primitiveChangedActiveEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:48'!
primDisplaySpanBuffer
	"Display the current scan line if necessary"
	<primitive: 'primitiveDisplaySpanBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primFinishedProcessing
	"Return true if there are no more entries in AET and GET and the last scan line has been displayed"
	<primitive: 'primitiveFinishedProcessing' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primInitializeProcessing
	"Initialize processing in the GE.
	Create the active edge table and sort it."
	<primitive: 'primitiveInitializeProcessing' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primMergeFill: fillBitmap from: fill
	"Merge the filled bitmap into the current output buffer."
	<primitive: 'primitiveMergeFillFrom' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextActiveEdgeEntryInto: edgeEntry
	"Store the next entry of the AET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	<primitive: 'primitiveNextActiveEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextFillEntryInto: fillEntry
	"Store the next fill entry of the active edge table in fillEntry.
	Return false if there is no such entry, true otherwise"
	<primitive: 'primitiveNextFillEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primNextGlobalEdgeEntryInto: edgeEntry
	"Store the next entry of the GET at the current y-value in edgeEntry.
	Return false if there is no entry, true otherwise."
	<primitive: 'primitiveNextGlobalEdgeEntry' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primRenderImage: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderImage' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-incremental' stamp: 'ar 2/2/2001 15:49'!
primRenderScanline: edge with: fill
	"Start/Proceed rendering the current scan line"
	<primitive: 'primitiveRenderScanline' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:48'!
primCopyBufferFrom: oldBuffer to: newBuffer
	"Copy the contents of oldBuffer into the (larger) newBuffer"
	<primitive: 'primitiveCopyBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !

!BalloonEngine methodsFor: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'!
primInitializeBuffer: buffer
	<primitive: 'primitiveInitializeBuffer' module: 'B2DPlugin'>
	^self primitiveFailed! !


!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:53'!
registerBezier: aCurve transformation: aMatrix
	self primAddBezierFrom: aCurve start
		to: aCurve end
		via: aCurve via
		leftFillIndex: (self registerFill: aCurve leftFill transform: aMatrix)
		rightFillIndex: (self registerFill: aCurve rightFill transform: aMatrix)
		matrix: aMatrix! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/11/1998 21:15'!
registerBoundary: boundaryObject transformation: aMatrix
	| external |
	external _ boundaryObject asEdgeRepresentation: (self fullTransformFrom: aMatrix).
	self subdivideExternalEdge: external from: boundaryObject.
! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:54'!
registerExternalEdge: externalEdge from: boundaryObject
	externals addLast: externalEdge.
	self primAddExternalEdge: externals size
		initialX: externalEdge initialX
		initialY: externalEdge initialY
		initialZ: externalEdge initialZ
		leftFillIndex: (self registerFill: boundaryObject leftFill transform: nil)
		rightFillIndex: (self registerFill: boundaryObject rightFill transform: nil)! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/12/1998 19:54'!
registerLine: aLine transformation: aMatrix
	self primAddLineFrom: aLine start to: aLine end
		leftFillIndex: (self registerFill: aLine leftFill transform: aMatrix)
		rightFillIndex: (self registerFill: aLine rightFill transform: aMatrix)
		matrix: aMatrix! !

!BalloonEngine methodsFor: 'experimental' stamp: 'ar 11/11/1998 21:15'!
subdivideExternalEdge: external from: boundaryObject
	| external2 |
	external2 _ external subdivide.
	external2 notNil ifTrue:[
		self subdivideExternalEdge: external from: boundaryObject.
		self subdivideExternalEdge: external2 from: boundaryObject.
	] ifFalse:[
		self registerExternalEdge: external from: boundaryObject.
	].! !


!BalloonEngine methodsFor: 'profiling' stamp: 'ar 11/11/1998 21:16'!
doAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix
	"Note: This method is for profiling the overhead of loading a compressed shape into the engine."
	^self primAddCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList matrix: aMatrix! !

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

BalloonEngine class
	instanceVariableNames: ''!

!BalloonEngine class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 21:44'!
new
	^super new initialize! !


!BalloonEngine class methodsFor: 'class initialization' stamp: 'ar 11/11/1998 22:49'!
initialize
	"BalloonEngine initialize"
	BufferCache _ WeakArray new: 1.
	Smalltalk garbageCollect. "Make the cache old"
	CacheProtect _ Semaphore forMutualExclusion.
	Times _ WordArray new: 10.
	Counts _ WordArray new: 10.
	BezierStats _ WordArray new: 4.
	Debug ifNil:[Debug _ false].! !


!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'!
debug: aBoolean
	"BalloonEngine debug: true"
	"BalloonEngine debug: false"
	Debug _ aBoolean! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
doProfileStats: aBool
	"Note: On Macintosh systems turning on profiling can significantly
	degrade the performance of Balloon since we're using the high
	accuracy timer for measuring."
	"BalloonEngine doProfileStats: true"
	"BalloonEngine doProfileStats: false"
	<primitive: 'primitiveDoProfileStats' module: 'B2DPlugin'>
	^false! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'!
printBezierStats
	"BalloonEngine printBezierStats"
	"BalloonEngine resetBezierStats"
	Transcript 
		cr; nextPutAll:'Bezier statistics:';
		crtab; print: (BezierStats at: 1); tab; nextPutAll:' non-monoton curves splitted';
		crtab; print: (BezierStats at: 2); tab; nextPutAll:' curves splitted for numerical accuracy';
		crtab; print: (BezierStats at: 3); tab; nextPutAll:' curves splitted to avoid integer overflow';
		crtab; print: (BezierStats at: 4); tab; nextPutAll:' curves internally converted to lines';
	endEntry.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:59'!
printStat: time count: n string: aString
	Transcript
		cr;
		print: time; tab;
		nextPutAll:' mSecs -- ';
		print: n; tab;
		nextPutAll:' ops -- ';
		print: ((time asFloat / (n max: 1) asFloat) roundTo: 0.01); tab;
		nextPutAll: ' avg. mSecs/op -- ';
		nextPutAll: aString.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 1/12/1999 10:52'!
printStats
	"BalloonEngine doProfileStats: true"
	"BalloonEngine printStats"
	"BalloonEngine resetStats"
	Transcript cr; nextPutAll:'/************** BalloonEngine statistics ****************/'.
	self printStat: (Times at: 1) count: (Counts at: 1) string: 'Initialization'.
	self printStat: (Times at: 2) count: (Counts at: 2) string: 'Finish test'.
	self printStat: (Times at: 3) count: (Counts at: 3) string: 'Fetching/Adding GET entries'.
	self printStat: (Times at: 4) count: (Counts at: 4) string: 'Adding AET entries'.
	self printStat: (Times at: 5) count: (Counts at: 5) string: 'Fetching/Computing fills'.
	self printStat: (Times at: 6) count: (Counts at: 6) string: 'Merging fills'.
	self printStat: (Times at: 7) count: (Counts at: 7) string: 'Displaying span buffer'.
	self printStat: (Times at: 8) count: (Counts at: 8) string: 'Fetching/Updating AET entries'.
	self printStat: (Times at: 9) count: (Counts at: 9) string: 'Changing AET entries'.
	Transcript cr; print: Times sum; nextPutAll:' mSecs for all operations'.
	Transcript cr; print: Counts sum; nextPutAll: ' overall operations'.
	Transcript endEntry.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/30/1998 23:57'!
resetBezierStats
	BezierStats _ WordArray new: 4.! !

!BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'!
resetStats
	Times _ WordArray new: 10.
	Counts _ WordArray new: 10.! !


!BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:50'!
allocateOrRecycleBuffer: initialSize
	"Try to recycly a buffer. If this is not possibly, create a new one."
	| buffer |
	CacheProtect critical:[
		buffer _ BufferCache at: 1.
		BufferCache at: 1 put: nil.
	].
	^buffer ifNil:[BalloonBuffer new: initialSize]! !

!BalloonEngine class methodsFor: 'private' stamp: 'ar 5/28/2000 22:17'!
primitiveSetBitBltPlugin: pluginName
	<primitive: 'primitiveSetBitBltPlugin' module: 'B2DPlugin'>
	^nil! !

!BalloonEngine class methodsFor: 'private' stamp: 'ar 11/11/1998 22:51'!
recycleBuffer: balloonBuffer
	"Try to keep the buffer for later drawing operations."
	| buffer |
	CacheProtect critical:[
		buffer _ BufferCache at: 1.
		(buffer isNil or:[buffer size < balloonBuffer size] )
			ifTrue:[BufferCache at: 1 put: balloonBuffer].
	].! !
InterpreterPlugin subclass: #BalloonEngineBase
	instanceVariableNames: 'workBuffer objBuffer getBuffer aetBuffer spanBuffer engine formArray engineStopped geProfileTime dispatchedValue dispatchReturnValue objUsed doProfileStats copyBitsFn loadBBFn bbPluginName '
	classVariableNames: 'EdgeInitTable EdgeStepTable FillTable WideLineFillTable WideLineWidthTable '
	poolDictionaries: 'BalloonEngineConstants '
	category: 'VMConstruction-Plugins'!

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorMaskGet
	^workBuffer at: GWAAColorMask! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorMaskPut: value
	^workBuffer at: GWAAColorMask put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorShiftGet
	^workBuffer at: GWAAColorShift! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaColorShiftPut: value
	^workBuffer at: GWAAColorShift put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:34'!
aaHalfPixelGet
	^workBuffer at: GWAAHalfPixel! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaHalfPixelPut: value
	^workBuffer at: GWAAHalfPixel put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaLevelGet
	^workBuffer at: GWAALevel! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaLevelPut: value
	^workBuffer at: GWAALevel put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaScanMaskGet
	^workBuffer at: GWAAScanMask! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaScanMaskPut: value
	^workBuffer at: GWAAScanMask put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:35'!
aaShiftGet
	^workBuffer at: GWAAShift! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 00:36'!
aaShiftPut: value
	^workBuffer at: GWAAShift put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
aetStartGet
	^workBuffer at: GWAETStart! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
aetStartPut: value
	^workBuffer at: GWAETStart put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
aetUsedGet
	^workBuffer at: GWAETUsed! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
aetUsedPut: value
	^workBuffer at: GWAETUsed put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 00:43'!
clearSpanBufferGet
	^workBuffer at: GWClearSpanBuffer! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 00:44'!
clearSpanBufferPut: value
	^workBuffer at: GWClearSpanBuffer put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxXGet
	^workBuffer at: GWClipMaxX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxXPut: value
	^workBuffer at: GWClipMaxX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxYGet
	^workBuffer at: GWClipMaxY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMaxYPut: value
	^workBuffer at: GWClipMaxY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:46'!
clipMinXGet
	^workBuffer at: GWClipMinX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinXPut: value
	^workBuffer at: GWClipMinX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinYGet
	^workBuffer at: GWClipMinY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 18:47'!
clipMinYPut: value
	^workBuffer at: GWClipMinY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
colorTransform
	self returnTypeC:'float *'.
	^self cCoerce: workBuffer + GWColorTransform to:'float *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
currentYGet
	^workBuffer at: GWCurrentY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 21:27'!
currentYPut: value
	^workBuffer at: GWCurrentY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 20:28'!
currentZGet
	^workBuffer at: GWCurrentZ! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 20:29'!
currentZPut: value
	^workBuffer at: GWCurrentZ put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:23'!
destOffsetXGet
	^workBuffer at: GWDestOffsetX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:24'!
destOffsetXPut: value
	^workBuffer at: GWDestOffsetX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:23'!
destOffsetYGet
	^workBuffer at: GWDestOffsetY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 16:24'!
destOffsetYPut: value
	^workBuffer at: GWDestOffsetY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
edgeTransform
	self returnTypeC:'float *'.
	^self cCoerce: workBuffer + GWEdgeTransform to:'float *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMaxXGet
	^workBuffer at: GWFillMaxX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:29'!
fillMaxXPut: value
	^workBuffer at: GWFillMaxX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMaxYGet
	^workBuffer at: GWFillMaxY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMaxYPut: value
	^workBuffer at: GWFillMaxY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMinXGet
	^workBuffer at: GWFillMinX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMinXPut: value
	^workBuffer at: GWFillMinX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillMinYGet
	^workBuffer at: GWFillMinY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillMinYPut: value
	^workBuffer at: GWFillMinY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillOffsetXGet
	^workBuffer at: GWFillOffsetX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillOffsetXPut: value
	^workBuffer at: GWFillOffsetX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
fillOffsetYGet
	^workBuffer at: GWFillOffsetY! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
fillOffsetYPut: value
	^workBuffer at: GWFillOffsetY put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 17:08'!
firstPointListGet
	^workBuffer at: GWPointListFirst! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/29/1998 17:08'!
firstPointListPut: value
	^workBuffer at: GWPointListFirst put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
getStartGet
	^workBuffer at: GWGETStart! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:30'!
getStartPut: value
	^workBuffer at: GWGETStart put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:27'!
getUsedGet
	^workBuffer at: GWGETUsed! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
getUsedPut: value
	^workBuffer at: GWGETUsed put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasColorTransformGet
	^workBuffer at: GWHasColorTransform! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasColorTransformPut: value
	^workBuffer at: GWHasColorTransform put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:36'!
hasEdgeTransformGet
	^workBuffer at: GWHasEdgeTransform! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/24/1998 21:35'!
hasEdgeTransformPut: value
	^workBuffer at: GWHasEdgeTransform put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/9/1998 15:36'!
incrementStat: statIndex by: value

	^workBuffer at: statIndex put: (workBuffer at: statIndex) + value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
lastExportedEdgeGet
	^workBuffer at: GWLastExportedEdge! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 20:11'!
lastExportedEdgePut: value
	^workBuffer at: GWLastExportedEdge put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 14:24'!
lastExportedFillGet
	^workBuffer at: GWLastExportedFill! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 14:24'!
lastExportedFillPut: value
	^workBuffer at: GWLastExportedFill put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedLeftXGet
	^workBuffer at: GWLastExportedLeftX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedLeftXPut: value
	^workBuffer at: GWLastExportedLeftX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedRightXGet
	^workBuffer at: GWLastExportedRightX! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:51'!
lastExportedRightXPut: value
	^workBuffer at: GWLastExportedRightX put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
magicNumberGet
	^workBuffer at: GWMagicIndex! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:39'!
magicNumberPut: value
	^workBuffer at: GWMagicIndex put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/25/1998 00:20'!
needsFlushGet
	^workBuffer at: GWNeedsFlush! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/25/1998 00:20'!
needsFlushPut: value
	^workBuffer at: GWNeedsFlush put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
objStartGet
	^workBuffer at: GWObjStart! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
objStartPut: value
	^workBuffer at: GWObjStart put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
objUsedGet
	^workBuffer at: GWObjUsed! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
objUsedPut: value
	^workBuffer at: GWObjUsed put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:33'!
point1Get
	self returnTypeC:'int *'.
	^self cCoerce: workBuffer + GWPoint1 to:'int *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:34'!
point2Get
	self returnTypeC:'int *'.
	^self cCoerce: workBuffer + GWPoint2 to:'int *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/28/1998 16:34'!
point3Get
	self returnTypeC:'int *'.
	^self cCoerce: workBuffer + GWPoint3 to:'int *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 11/1/1998 03:13'!
point4Get
	self returnTypeC:'int *'.
	^self cCoerce: workBuffer + GWPoint4 to:'int *'! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanEndAAGet
	^workBuffer at: GWSpanEndAA! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanEndAAPut: value
	^workBuffer at: GWSpanEndAA put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanEndGet
	^workBuffer at: GWSpanEnd! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanEndPut: value
	^workBuffer at: GWSpanEnd put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanSizeGet
	^workBuffer at: GWSpanSize! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanSizePut: value
	^workBuffer at: GWSpanSize put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
spanStartGet
	^workBuffer at: GWSpanStart! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
spanStartPut: value
	^workBuffer at: GWSpanStart put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
stateGet
	^workBuffer at: GWState! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
statePut: value
	^workBuffer at: GWState put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
stopReasonGet
	^workBuffer at: GWStopReason! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:31'!
stopReasonPut: value
	^workBuffer at: GWStopReason put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:28'!
wbSizeGet
	^workBuffer at: GWSize! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:37'!
wbSizePut: value
	^workBuffer at: GWSize put: value! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 23:29'!
wbTopGet
	^workBuffer at: GWBufferTop! !

!BalloonEngineBase methodsFor: 'accessing state' stamp: 'ar 10/27/1998 18:32'!
wbTopPut: value
	^workBuffer at: GWBufferTop put: value! !


!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:22'!
obj: object at: index
	^objBuffer at: object + index! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:22'!
obj: object at: index put: value
	^objBuffer at: object + index put: value! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:02'!
objectHeaderOf: obj

	^self makeUnsignedFrom:(self obj: obj at: GEObjectType)! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectIndexOf: obj

	^self obj: obj at: GEObjectIndex! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectIndexOf: obj put: value

	^self obj: obj at: GEObjectIndex put: value! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectLengthOf: obj

	^self obj: obj at: GEObjectLength! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectLengthOf: obj put: value

	^self obj: obj at: GEObjectLength put: value! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectTypeOf: obj

	^(self makeUnsignedFrom:(self obj: obj at: GEObjectType)) bitAnd: GEPrimitiveTypeMask! !

!BalloonEngineBase methodsFor: 'accessing objects' stamp: 'ar 11/24/1998 22:03'!
objectTypeOf: obj put: value

	^self obj: obj at: GEObjectType put: value! !


!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeFillsInvalidate: edge

	^self objectTypeOf: edge put: 
		((self objectTypeOf: edge) bitOr: GEEdgeFillsInvalid)! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeFillsValidate: edge

	^self objectTypeOf: edge put: 
		((self objectTypeOf: edge) bitAnd: GEEdgeFillsInvalid bitInvert32)! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeLeftFillOf: edge

	^self obj: edge at: GEFillIndexLeft! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeLeftFillOf: edge put: value

	^self obj: edge at: GEFillIndexLeft put: value! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeNumLinesOf: edge

	^self obj: edge at: GENumLines! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:04'!
edgeNumLinesOf: edge put: value

	^self obj: edge at: GENumLines put: value! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeRightFillOf: edge

	^self obj: edge at: GEFillIndexRight! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeRightFillOf: edge put: value

	^self obj: edge at: GEFillIndexRight put: value! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/9/1998 15:35'!
edgeTypeOf: edge
	"Return the edge type (e.g., witout the wide edge flag)"

	^(self objectTypeOf: edge) >> 1! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeXValueOf: edge

	^self obj: edge at: GEXValue! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeXValueOf: edge put: value

	^self obj: edge at: GEXValue put: value! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:05'!
edgeYValueOf: edge

	^self obj: edge at: GEYValue! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeYValueOf: edge put: value

	^self obj: edge at: GEYValue put: value! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeZValueOf: edge

	^self obj: edge at: GEZValue! !

!BalloonEngineBase methodsFor: 'accessing edges' stamp: 'ar 11/24/1998 22:06'!
edgeZValueOf: edge put: value

	^self obj: edge at: GEZValue put: value! !


!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/31/1998 00:43'!
wbStackClear
	self wbTopPut: self wbSizeGet.! !

!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackPop: nItems

	self wbTopPut: self wbTopGet + nItems.! !

!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/30/1998 17:16'!
wbStackPush: nItems
	(self allocateStackEntry: nItems) ifFalse:[^false].
	self wbTopPut: self wbTopGet - nItems.
	^true! !

!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 10/30/1998 17:17'!
wbStackSize
	^self wbSizeGet - self wbTopGet! !

!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackValue: index

	^workBuffer at: self wbTopGet + index! !

!BalloonEngineBase methodsFor: 'accessing stack' stamp: 'ar 11/9/1998 15:34'!
wbStackValue: index put: value

	^workBuffer at: self wbTopGet + index put: value! !


!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/7/1998 22:25'!
fillTypeOf: fill
	^((self objectTypeOf: fill) bitAnd: GEPrimitiveFillMask) >> 8! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:08'!
stackFillDepth: index
	^self wbStackValue: index+1! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:08'!
stackFillDepth: index put: value
	^self wbStackValue: index+1 put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:31'!
stackFillEntryLength
	^3! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:35'!
stackFillRightX: index
	^self wbStackValue: index+2! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:35'!
stackFillRightX: index put: value
	^self wbStackValue: index+2 put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:10'!
stackFillSize
	^self wbStackSize! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:09'!
stackFillValue: index
	^self wbStackValue: index! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:09'!
stackFillValue: index put: value
	^self wbStackValue: index put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:49'!
topDepth
	self stackFillSize = 0
		ifTrue:[^-1]
		ifFalse:[^self topFillDepth].! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:28'!
topFill
	self stackFillSize = 0
		ifTrue:[^0]
		ifFalse:[^self topFillValue].! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillDepth
	^self stackFillDepth: self stackFillSize - self stackFillEntryLength! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillDepthPut: value
	^self stackFillDepth: self stackFillSize - self stackFillEntryLength put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:36'!
topFillRightX
	^self stackFillRightX: self stackFillSize - self stackFillEntryLength! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 14:36'!
topFillRightXPut: value
	^self stackFillRightX: self stackFillSize - self stackFillEntryLength put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillValue
	^self stackFillValue: self stackFillSize - self stackFillEntryLength! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 10/30/1998 19:27'!
topFillValuePut: value
	^self stackFillValue: self stackFillSize - self stackFillEntryLength put: value! !

!BalloonEngineBase methodsFor: 'accessing fills' stamp: 'ar 11/25/1998 15:19'!
topRightX
	self stackFillSize = 0
		ifTrue:[^999999999]
		ifFalse:[^self topFillRightX].! !


!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/24/1998 20:05'!
loadArrayTransformFrom: transformOop into: destPtr length: n
	"Load a transformation from the given array."
	| value |
	self inline: false.
	self var: #destPtr declareC:'float *destPtr'.
	0 to: n-1 do:[:i|
		value _ interpreterProxy fetchPointer: i ofObject: transformOop.
		((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
			ifFalse:[^interpreterProxy primitiveFail].
		(interpreterProxy isIntegerObject: value)
			ifTrue:[destPtr at: i put: 
				(self cCoerce: (interpreterProxy integerValueOf: value) asFloat to:'float')]
			ifFalse:[destPtr at: i put: 
				(self cCoerce: (interpreterProxy floatValueOf: value) to: 'float')].
	].! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/25/1998 21:04'!
loadColorTransformFrom: transformOop
	"Load a 2x3 transformation matrix from the given oop.
	Return true if the matrix is not nil, false otherwise"
	| okay transform |
	self var: #transform declareC:'float *transform'.
	transform _ self colorTransform.
	self hasColorTransformPut: 0.
	okay _ self loadTransformFrom: transformOop into: transform length: 8.
	okay ifFalse:[^false].
	self hasColorTransformPut: 1.
	"Scale transform to be in 0-256 range"
	transform at: 1 put: (transform at: 1) * (self cCoerce: 256.0 to:'float').
	transform at: 3 put: (transform at: 3) * (self cCoerce: 256.0 to:'float').
	transform at: 5 put: (transform at: 5) * (self cCoerce: 256.0 to:'float').
	transform at: 7 put: (transform at: 7) * (self cCoerce: 256.0 to:'float').
	^okay! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/11/1998 22:21'!
loadEdgeStateFrom: edgeOop
	| edge |
	self inline: false.
	edge _ self lastExportedEdgeGet.
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	self edgeXValueOf: edge 
		put: (interpreterProxy fetchInteger: ETXValueIndex ofObject: edgeOop).
	self edgeYValueOf: edge 
		put: (interpreterProxy fetchInteger: ETYValueIndex ofObject: edgeOop).
	self edgeZValueOf: edge 
		put: (interpreterProxy fetchInteger: ETZValueIndex ofObject: edgeOop).
	self edgeNumLinesOf: edge 
		put: (interpreterProxy fetchInteger: ETLinesIndex ofObject: edgeOop).
	^edge! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/24/1998 21:33'!
loadEdgeTransformFrom: transformOop
	"Load a 2x3 transformation matrix from the given oop.
	Return true if the matrix is not nil, false otherwise"
	| transform okay |
	self inline: false.
	self var: #transform declareC:'float *transform'.
	self hasEdgeTransformPut: 0.
	transform _ self edgeTransform.
	okay _ self loadTransformFrom: transformOop into: transform length: 6.
	interpreterProxy failed ifTrue:[^nil].
	okay ifFalse:[^false].
	self hasEdgeTransformPut: 1.
	"Add the fill offset to the matrix"
	transform at: 2 put: 
		(self cCoerce: (transform at: 2) + self destOffsetXGet asFloat to:'float').
	transform at: 5 put: 
		(self cCoerce: (transform at: 5) + self destOffsetYGet asFloat to:'float').
	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/25/1998 17:26'!
loadFormsFrom: arrayOop
	"Check all the forms from arrayOop."
	| formOop bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
	(interpreterProxy fetchClassOf: arrayOop) == interpreterProxy classArray
		ifFalse:[^false].
	formArray _ arrayOop.
	0 to: (interpreterProxy slotSizeOf: formArray) - 1 do:[:i|
		formOop _ interpreterProxy fetchPointer: i ofObject: formArray.
		(interpreterProxy isIntegerObject: formOop) ifTrue:[^false].
		(interpreterProxy isPointers: formOop) ifFalse:[^false].
		(interpreterProxy slotSizeOf: formOop) < 5 ifTrue:[^false].
		bmBits _ interpreterProxy fetchPointer: 0 ofObject: formOop.
		(interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
			ifFalse:[^false].
		bmBitsSize _ interpreterProxy slotSizeOf: bmBits.
		bmWidth _ interpreterProxy fetchInteger: 1 ofObject: formOop.
		bmHeight _ interpreterProxy fetchInteger: 2 ofObject: formOop.
		bmDepth _ interpreterProxy fetchInteger: 3 ofObject: formOop.
		interpreterProxy failed ifTrue:[^false].
		(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^false].
		ppw _ 32 // bmDepth.
		bmRaster _ bmWidth + (ppw-1) // ppw.
		bmBitsSize = (bmRaster * bmHeight)
			ifFalse:[^false].
	].
	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 10/27/1998 21:24'!
loadPoint: pointArray from: pointOop
	"Load the contents of pointOop into pointArray"
	| value |
	self inline: false.
	self var: #pointArray declareC:'int *pointArray'.
	(interpreterProxy fetchClassOf: pointOop) = interpreterProxy classPoint 
		ifFalse:[^interpreterProxy primitiveFail].
	value _ interpreterProxy fetchPointer: 0 ofObject: pointOop.
	((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isIntegerObject: value)
		ifTrue:[pointArray at: 0 put: (interpreterProxy integerValueOf: value)]
		ifFalse:[pointArray at: 0 put: (interpreterProxy floatValueOf: value) asInteger].
	value _ interpreterProxy fetchPointer: 1 ofObject: pointOop.
	((interpreterProxy isIntegerObject: value) or:[interpreterProxy isFloatObject: value])
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isIntegerObject: value)
		ifTrue:[pointArray at: 1 put: (interpreterProxy integerValueOf: value)]
		ifFalse:[pointArray at: 1 put: (interpreterProxy floatValueOf: value) asInteger].
! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 10/28/1998 00:46'!
loadSpanBufferFrom: spanOop
	"Load the span buffer from the given oop."
	self inline: false.
	(interpreterProxy fetchClassOf: spanOop) = (interpreterProxy classBitmap) ifFalse:[^false].
	spanBuffer _ interpreterProxy firstIndexableField: spanOop.
	"Leave last entry unused to avoid complications"
	self spanSizePut: (interpreterProxy slotSizeOf: spanOop) - 1.
	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/25/1998 23:22'!
loadTransformFrom: transformOop into: destPtr length: n
	"Load a transformation from transformOop into the float array
	defined by destPtr. The transformation is assumed to be either
	an array or a FloatArray of length n."
	self inline: false.
	self var: #destPtr declareC:'float *destPtr'.
	transformOop = interpreterProxy nilObject ifTrue:[^false].
	(interpreterProxy isIntegerObject: transformOop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: transformOop) = n 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isWords: transformOop) 
		ifTrue:[self loadWordTransformFrom: transformOop into: destPtr length: n]
		ifFalse:[self loadArrayTransformFrom: transformOop into: destPtr length: n].
	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/24/1998 20:03'!
loadWordTransformFrom: transformOop into: destPtr length: n
	"Load a float array transformation from the given oop"
	| srcPtr |
	self inline: false.
	self var: #srcPtr declareC:'float *srcPtr'.
	self var: #destPtr declareC:'float *destPtr'.
	srcPtr _ self cCoerce: (interpreterProxy firstIndexableField: transformOop) to: 'float *'.
	0 to: n-1 do:[:i| destPtr at: i put: (srcPtr at: i)].! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 10/28/1998 19:37'!
loadWorkBufferFrom: wbOop
	"Load the working buffer from the given oop"
	self inline: false.
	(interpreterProxy isIntegerObject: wbOop) ifTrue:[^false].
	(interpreterProxy isWords: wbOop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: wbOop) < GWMinimalSize ifTrue:[^false].
	workBuffer _ interpreterProxy firstIndexableField: wbOop.
	self magicNumberGet = GWMagicNumber ifFalse:[^false].
	"Sanity checks"
	(self wbSizeGet = (interpreterProxy slotSizeOf: wbOop)) ifFalse:[^false].
	self objStartGet = GWHeaderSize ifFalse:[^false].

	"Load buffers"
	objBuffer _ workBuffer + self objStartGet.
	getBuffer _ objBuffer + self objUsedGet.
	aetBuffer _ getBuffer + self getUsedGet.

	"Make sure we don't exceed the work buffer"
	GWHeaderSize + self objUsedGet + self getUsedGet + self aetUsedGet > self wbSizeGet ifTrue:[^false].

	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 11/25/1998 00:36'!
quickLoadEngineFrom: engineOop
	"Load the minimal required state from the engineOop, e.g., just the work buffer."
	self inline: false.
	interpreterProxy failed ifTrue:[^false].
	(interpreterProxy isIntegerObject: engineOop) ifTrue:[^false].
	(interpreterProxy isPointers: engineOop) ifFalse:[^false].
	(interpreterProxy slotSizeOf: engineOop) < BEBalloonEngineSize ifTrue:[^false].
	engine _ engineOop.
	(self loadWorkBufferFrom: 
		(interpreterProxy fetchPointer: BEWorkBufferIndex ofObject: engineOop))
			ifFalse:[^false].
	self stopReasonPut: 0.
	objUsed _ self objUsedGet.
	engineStopped _ false.
	^true! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 10/28/1998 21:06'!
quickLoadEngineFrom: oop requiredState: requiredState
	self inline: false.
	(self quickLoadEngineFrom: oop) ifFalse:[^false].
	self stateGet = requiredState ifTrue:[^true].
	self stopReasonPut: GErrorBadState.
	^false! !

!BalloonEngineBase methodsFor: 'loading state' stamp: 'ar 10/31/1998 17:23'!
quickLoadEngineFrom: oop requiredState: requiredState or: alternativeState
	self inline: false.
	(self quickLoadEngineFrom: oop) ifFalse:[^false].
	self stateGet = requiredState ifTrue:[^true].
	self stateGet = alternativeState ifTrue:[^true].
	self stopReasonPut: GErrorBadState.
	^false! !


!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/11/1998 22:21'!
storeEdgeStateFrom: edge into: edgeOop

	self inline: false.
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy storeInteger: ETIndexIndex ofObject: edgeOop withValue: 
		(self objectIndexOf: edge).
	interpreterProxy storeInteger: ETXValueIndex ofObject: edgeOop withValue: 
		(self edgeXValueOf: edge).
	interpreterProxy storeInteger: ETYValueIndex ofObject: edgeOop withValue: 
		(self currentYGet).
	interpreterProxy storeInteger: ETZValueIndex ofObject: edgeOop withValue: 
		(self edgeZValueOf: edge).
	interpreterProxy storeInteger: ETLinesIndex ofObject: edgeOop withValue: 
		(self edgeNumLinesOf: edge).
	self lastExportedEdgePut: edge.! !

!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/25/1998 00:36'!
storeEngineStateInto: oop
	self objUsedPut: objUsed.! !

!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/11/1998 22:24'!
storeFillStateInto: fillOop
	| fillIndex leftX rightX |
	self inline: false.
	fillIndex _ self lastExportedFillGet.
	leftX _ self lastExportedLeftXGet.
	rightX _ self lastExportedRightXGet.

	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize 
		ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy storeInteger: FTIndexIndex ofObject: fillOop withValue: 
		(self objectIndexOf: fillIndex).
	interpreterProxy storeInteger: FTMinXIndex ofObject: fillOop withValue: leftX.
	interpreterProxy storeInteger: FTMaxXIndex ofObject: fillOop withValue: rightX.
	interpreterProxy storeInteger: FTYValueIndex ofObject: fillOop withValue: self currentYGet.! !

!BalloonEngineBase methodsFor: 'storing state' stamp: 'ar 11/9/1998 15:34'!
storeStopStateIntoEdge: edgeOop fill: fillOop
	| reason edge |
	reason _ self stopReasonGet.

	reason = GErrorGETEntry ifTrue:[
		edge _ getBuffer at: self getStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		self getStartPut: self getStartGet + 1.
	].

	reason = GErrorFillEntry ifTrue:[
		self storeFillStateInto: fillOop.
	].

	reason = GErrorAETEntry ifTrue:[
		edge _ aetBuffer at: self aetStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		"Do not advance to the next aet entry yet"
		"self aetStartPut: self aetStartGet + 1."
	].! !


!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/9/1998 15:34'!
areEdgeFillsValid: edge

	^((self objectHeaderOf: edge) bitAnd: GEEdgeFillsInvalid) = 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/31/1998 17:06'!
finishedProcessing
	"Return true if processing is finished"
	^self stateGet = GEStateCompleted! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/24/1998 19:39'!
hasColorTransform
	^self hasColorTransformGet ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/24/1998 19:38'!
hasEdgeTransform
	^self hasEdgeTransformGet ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/29/1998 19:36'!
isEdge: edge
	| type |
	type _ self objectTypeOf: edge.
	type > GEPrimitiveEdgeMask ifTrue:[^false].
	^((self objectTypeOf: edge) bitAnd: GEPrimitiveEdgeMask) ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/7/1998 21:28'!
isFill: fill
	^(self isFillColor: fill) or:[self isRealFill: fill]! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/29/1998 19:31'!
isFillColor: fill
	^((self makeUnsignedFrom: fill) bitAnd: 16rFF000000) ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/25/1998 00:43'!
isObject: obj
	^obj >= 0 and:[obj < objUsed]! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/7/1998 21:28'!
isRealFill: fill
	^((self objectTypeOf: fill) bitAnd: GEPrimitiveFillMask) ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/31/1998 23:12'!
isStackEntry: entry
	^entry >= self wbTopGet and:[entry < self wbSizeGet]! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 10/30/1998 17:38'!
isStackIndex: index
	^index >= 0 and:[index < self wbStackSize]! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/9/1998 15:36'!
isWide: object

	^((self objectTypeOf: object) bitAnd: GEPrimitiveWide) ~= 0! !

!BalloonEngineBase methodsFor: 'testing' stamp: 'ar 11/25/1998 00:21'!
needsFlush
	^self needsFlushGet ~= 0! !


!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:08'!
primitiveGetAALevel
	self export: true.	
	self inline: false.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self aaLevelGet.! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:10'!
primitiveGetClipRect
	| rectOop pointOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	rectOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isPointers: rectOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rectOop) < 2
		ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy pushRemappableOop: rectOop.
	pointOop _ interpreterProxy makePointwithxValue: self clipMinXGet yValue: self clipMinYGet.
	rectOop _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: rectOop withValue: pointOop.
	interpreterProxy pushRemappableOop: rectOop.
	pointOop _ interpreterProxy makePointwithxValue: self clipMaxXGet yValue: self clipMaxYGet.
	rectOop _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: rectOop withValue: pointOop.

	interpreterProxy pop: 2.
	interpreterProxy push: rectOop.! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:13'!
primitiveGetCounts
	| statOop stats |
	self export: true.
	self inline: false.
	self var: #stats declareC:'int *stats'.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 9
		ifTrue:[^interpreterProxy primitiveFail].
	stats _ interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWCountInitializing).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWCountFinishTest).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWCountNextGETEntry).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWCountAddAETEntry).
	stats at: 4 put: (stats at: 4) + (workBuffer at: GWCountNextFillEntry).
	stats at: 5 put: (stats at: 5) + (workBuffer at: GWCountMergeFill).
	stats at: 6 put: (stats at: 6) + (workBuffer at: GWCountDisplaySpan).
	stats at: 7 put: (stats at: 7) + (workBuffer at: GWCountNextAETEntry).
	stats at: 8 put: (stats at: 8) + (workBuffer at: GWCountChangeAETEntry).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:14'!
primitiveGetDepth
	self export: true.	
	self inline: false.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self currentZGet.! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:10'!
primitiveGetFailureReason
	"Return the reason why the last operation failed."
	self export: true.	
	self inline: false.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	"Note -- don't call loadEngineFrom here because this will override the stopReason with Zero"
	(interpreterProxy isIntegerObject: engine) ifTrue:[^false].
	(interpreterProxy isPointers: engine) ifFalse:[^false].
	(interpreterProxy slotSizeOf: engine) < BEBalloonEngineSize ifTrue:[^false].
	(self loadWorkBufferFrom: 
		(interpreterProxy fetchPointer: BEWorkBufferIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.
	interpreterProxy pushInteger: self stopReasonGet.! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:11'!
primitiveGetOffset
	| pointOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].

	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	pointOop _ interpreterProxy makePointwithxValue: self destOffsetXGet yValue: self destOffsetYGet.
	interpreterProxy pop: 1.
	interpreterProxy push: pointOop.! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:07'!
primitiveGetTimes
	| statOop stats |
	self export: true.
	self inline: false.
	self var: #stats declareC:'int *stats'.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 9
		ifTrue:[^interpreterProxy primitiveFail].
	stats _ interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWTimeInitializing).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWTimeFinishTest).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWTimeNextGETEntry).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWTimeAddAETEntry).
	stats at: 4 put: (stats at: 4) + (workBuffer at: GWTimeNextFillEntry).
	stats at: 5 put: (stats at: 5) + (workBuffer at: GWTimeMergeFill).
	stats at: 6 put: (stats at: 6) + (workBuffer at: GWTimeDisplaySpan).
	stats at: 7 put: (stats at: 7) + (workBuffer at: GWTimeNextAETEntry).
	stats at: 8 put: (stats at: 8) + (workBuffer at: GWTimeChangeAETEntry).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:12'!
primitiveNeedsFlush
	| needFlush |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush _ self needsFlush.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: needFlush.

! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:14'!
primitiveNeedsFlushPut
	| needFlush |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	needFlush _ interpreterProxy booleanValueOf: needFlush.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	needFlush == true 
		ifTrue:[self needsFlushPut: 1]
		ifFalse:[self needsFlushPut: 0].
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:12'!
primitiveSetAALevel
	| level |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	level _ interpreterProxy stackIntegerValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].
	self setAALevel: level.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leace rcvr on stack"! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/16/2000 20:03'!
primitiveSetBitBltPlugin
	"Primitive. Set the BitBlt plugin to use."
	| pluginName length ptr needReload |
	self export: true.
	self var: #ptr declareC:'char *ptr'.
	pluginName _ interpreterProxy stackValue: 0.
	"Must be string to work"
	(interpreterProxy isBytes: pluginName) 
		ifFalse:[^interpreterProxy primitiveFail].
	length _ interpreterProxy byteSizeOf: pluginName.
	length >= 256 
		ifTrue:[^interpreterProxy primitiveFail].
	ptr _ interpreterProxy firstIndexableField: pluginName.
	needReload _ false.
	0 to: length-1 do:[:i|
		"Compare and store the plugin to be used"
		(bbPluginName at: i) = (ptr at: i) ifFalse:[
			bbPluginName at: i put: (ptr at: i).
			needReload _ true]].
	(bbPluginName at: length) = 0 ifFalse:[
		bbPluginName at: length put: 0.
		needReload _ true].
	needReload ifTrue:[
		self initialiseModule 
			ifFalse:[^interpreterProxy primitiveFail]].
	interpreterProxy pop: 1. "Return receiver"! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:05'!
primitiveSetClipRect
	| rectOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	rectOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isPointers: rectOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rectOop) < 2
		ifTrue:[^interpreterProxy primitiveFail].
	self loadPoint: self point1Get from: (interpreterProxy fetchPointer: 0 ofObject: rectOop).
	self loadPoint: self point2Get from: (interpreterProxy fetchPointer: 1 ofObject: rectOop).
	interpreterProxy failed ifFalse:[
		self clipMinXPut: (self point1Get at: 0).
		self clipMinYPut: (self point1Get at: 1).
		self clipMaxXPut: (self point2Get at: 0).
		self clipMaxYPut: (self point2Get at: 1).
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:11'!
primitiveSetColorTransform
	| transformOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	transformOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadColorTransformFrom: transformOop.
	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:06'!
primitiveSetDepth
	| depth |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	depth _ interpreterProxy stackIntegerValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self currentZPut: depth.

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:14'!
primitiveSetEdgeTransform
	| transformOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	transformOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadEdgeTransformFrom: transformOop.
	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !

!BalloonEngineBase methodsFor: 'primitives-access' stamp: 'ar 5/11/2000 23:13'!
primitiveSetOffset
	| pointOop |
	self export: true.	
	self inline: false.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	pointOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy fetchClassOf: pointOop) = interpreterProxy classPoint
		ifFalse:[^interpreterProxy primitiveFail].
	self loadPoint: self point1Get from: pointOop.
	interpreterProxy failed ifFalse:[
		self destOffsetXPut: (self point1Get at: 0).
		self destOffsetYPut: (self point1Get at: 1).
		self storeEngineStateInto: engine.
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !


!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:58'!
primitiveAddActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop edge |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingForEdge)
		ifFalse:[^interpreterProxy primitiveFail].

	edge _ self loadEdgeStateFrom: edgeOop.
	interpreterProxy failed ifTrue:[^nil].

	(self needAvailableSpace: 1) 
		ifFalse:[^interpreterProxy primitiveFail].

	(self edgeNumLinesOf: edge) > 0 ifTrue:[
		self insertEdgeIntoAET: edge.
	].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	self statePut: GEStateAddingFromGET. "Back to adding edges from GET"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountAddAETEntry by: 1.
		self incrementStat: GWTimeAddAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveChangedActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop edge |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingChange)
		ifFalse:[^interpreterProxy primitiveFail].

	edge _ self loadEdgeStateFrom: edgeOop.
	interpreterProxy failed ifTrue:[^nil].

	(self edgeNumLinesOf: edge) = 0 
		ifTrue:[	self removeFirstAETEntry]
		ifFalse:[	self resortFirstAETEntry.
				self aetStartPut: self aetStartGet + 1].

	self statePut: GEStateUpdateEdges. "Back to updating edges"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountChangeAETEntry by: 1.
		self incrementStat: GWTimeChangeAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveDisplaySpanBuffer
	"Note: Must load bitBlt and spanBuffer"
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateBlitBuffer)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer and bitBlt"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self loadBitBltFrom: 
		(interpreterProxy fetchPointer: BEBitBltIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
		self displaySpanBufferAt: self currentYGet.
		self postDisplayAction.
	].
	self finishedProcessing ifFalse:[
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.
		self statePut: GEStateUpdateEdges].
	self storeEngineStateInto: engine.
	doProfileStats ifTrue:[
		self incrementStat: GWCountDisplaySpan by: 1.
		self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveInitializeProcessing
	"Note: No need to load bitBlt but must load spanBuffer"
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for clear operation"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	self initializeGETProcessing.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].
	self statePut: GEStateAddingFromGET. "Initialized"
	interpreterProxy failed ifFalse:[self storeEngineStateInto: engine].
	doProfileStats ifTrue:[
		self incrementStat: GWCountInitializing by: 1.
		self incrementStat: GWTimeInitializing by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveMergeFillFrom
	"Note: No need to load bitBlt but must load spanBuffer"
	| fillOop bitsOop value |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop _ interpreterProxy stackObjectValue: 0.
	bitsOop _ interpreterProxy stackObjectValue: 1.
	engine _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateWaitingForFill)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for merging the fill"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	"Check bitmap"
	(interpreterProxy fetchClassOf: bitsOop) = interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	"Check fillOop"
	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize
		ifTrue:[^interpreterProxy primitiveFail].
	"Check if this was the fill we have exported"
	value _ interpreterProxy fetchInteger: FTIndexIndex ofObject: fillOop.
	(self objectIndexOf: self lastExportedFillGet) = value
		ifFalse:[^interpreterProxy primitiveFail].
	value _ interpreterProxy fetchInteger: FTMinXIndex ofObject: fillOop.
	self lastExportedLeftXGet = value
		ifFalse:[^interpreterProxy primitiveFail].
	value _ interpreterProxy fetchInteger: FTMaxXIndex ofObject: fillOop.
	self lastExportedRightXGet = value
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy slotSizeOf: bitsOop) < (self lastExportedRightXGet - self lastExportedLeftXGet)
		ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifTrue:[^nil].

	self fillBitmapSpan: (interpreterProxy firstIndexableField: bitsOop)
		from: self lastExportedLeftXGet
		to: self lastExportedRightXGet.

	self statePut: GEStateScanningAET. "Back to scanning AET"
	self storeEngineStateInto: engine.
	interpreterProxy pop: 2. "Leave rcvr on stack"
	doProfileStats ifTrue:[
		self incrementStat: GWCountMergeFill by: 1.
		self incrementStat: GWTimeMergeFill by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveNextActiveEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop hasEdge edge |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUpdateEdges or: GEStateCompleted)
		ifFalse:[^interpreterProxy primitiveFail].

	hasEdge _ false.
	self stateGet = GEStateCompleted ifFalse:[
		hasEdge _ self findNextExternalUpdateFromAET.
		hasEdge ifTrue:[
			edge _ aetBuffer at: self aetStartGet.
			self storeEdgeStateFrom: edge into: edgeOop.
			"Do not advance to the next aet entry yet"
			"self aetStartPut: self aetStartGet + 1."
			self statePut: GEStateWaitingChange. "Wait for changed edge"
		] ifFalse:[self statePut: GEStateAddingFromGET]. "Start over"
	].
	interpreterProxy failed ifTrue:[^nil].

	self storeEngineStateInto: engine.

	interpreterProxy pop: 2.
	interpreterProxy pushBool: hasEdge not.
	doProfileStats ifTrue:[
		self incrementStat: GWCountNextAETEntry by: 1.
		self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 14:59'!
primitiveNextFillEntry
	"Note: No need to load bitBlt but must load spanBuffer"
	| fillOop hasFill |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateScanningAET)
		ifFalse:[^interpreterProxy primitiveFail].
	"Load span buffer for internal handling of fills"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].
	(self loadFormsFrom:
		(interpreterProxy fetchPointer: BEFormsIndex ofObject: engine))
			ifFalse:[^interpreterProxy primitiveFail].

	"Check if we have to clear the span buffer before proceeding"
	(self clearSpanBufferGet = 0) ifFalse:[
		(self currentYGet bitAnd: self aaScanMaskGet) = 0
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0].

	hasFill _ self findNextExternalFillFromAET.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].
	hasFill ifTrue:[self storeFillStateInto: fillOop].
	interpreterProxy failed ifFalse:[
		hasFill
			ifTrue:[	self statePut: GEStateWaitingForFill]
			ifFalse:[	self wbStackClear.
					self spanEndAAPut: 0.
					self statePut: GEStateBlitBuffer].
		self storeEngineStateInto: engine.
		interpreterProxy pop: 2.
		interpreterProxy pushBool: hasFill not.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
	].! !

!BalloonEngineBase methodsFor: 'primitives-incremental' stamp: 'ar 5/13/2000 15:00'!
primitiveNextGlobalEdgeEntry
	"Note: No need to load either bitBlt or spanBuffer"
	| edgeOop hasEdge edge |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	edgeOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateAddingFromGET)
		ifFalse:[^interpreterProxy primitiveFail].

	hasEdge _ self findNextExternalEntryFromGET.
	hasEdge ifTrue:[
		edge _ getBuffer at: self getStartGet.
		self storeEdgeStateFrom: edge into: edgeOop.
		self getStartPut: self getStartGet + 1].

	interpreterProxy failed ifTrue:[^nil].

	hasEdge
		ifTrue:[	self statePut: GEStateWaitingForEdge] "Wait for adding edges"
		ifFalse:[ "Start scanning the AET"
				self statePut: GEStateScanningAET.
				self clearSpanBufferPut: 1. "Clear span buffer at next entry"
				self aetStartPut: 0.
				self wbStackClear].
	self storeEngineStateInto: engine.

	interpreterProxy pop: 2.
	interpreterProxy pushBool: hasEdge not.
	doProfileStats ifTrue:[
		self incrementStat: GWCountNextGETEntry by: 1.
		self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !


!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 5/12/2000 16:40'!
loadRenderingState
	"Load the entire state from the interpreter for the rendering primitives"
	| edgeOop fillOop state |
	self inline: false.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	fillOop _ interpreterProxy stackObjectValue: 0.
	edgeOop _ interpreterProxy stackObjectValue: 1.
	engine _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^false].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^false].

	"Load span buffer and bitBlt"
	(self loadSpanBufferFrom:
		(interpreterProxy fetchPointer: BESpanIndex ofObject: engine))
			ifFalse:[^false].
	(self loadBitBltFrom: 
		(interpreterProxy fetchPointer: BEBitBltIndex ofObject: engine))
			ifFalse:[^false].
	(self loadFormsFrom:
		(interpreterProxy fetchPointer: BEFormsIndex ofObject: engine))
			ifFalse:[^false].
	"Check edgeOop and fillOop"
	(interpreterProxy slotSizeOf: edgeOop) < ETBalloonEdgeDataSize 
		ifTrue:[^false].
	(interpreterProxy slotSizeOf: fillOop) < FTBalloonFillDataSize 
		ifTrue:[^false].

	"Note: Rendering can only take place if we're not in one of the intermediate
	(e.g., external) states."
	state _ self stateGet.
	(state = GEStateWaitingForEdge or:[
		state = GEStateWaitingForFill or:[
			state = GEStateWaitingChange]]) ifTrue:[^false].

	^true! !

!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 5/11/2000 23:08'!
primitiveRenderImage
	"Start/Proceed rendering the entire image"
	self export: true.
	self inline: false.

	self loadRenderingState ifFalse:[^interpreterProxy primitiveFail].

	self proceedRenderingScanline. "Finish this scan line"
	engineStopped ifTrue:[^self storeRenderingState].
	self proceedRenderingImage. "And go on as usual"

	self storeRenderingState.! !

!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 5/11/2000 23:07'!
primitiveRenderScanline
	"Start rendering the entire image"
	self export: true.
	self inline: false.

	self loadRenderingState ifFalse:[^interpreterProxy primitiveFail].

	self proceedRenderingScanline. "Finish the current scan line"

	self storeRenderingState.! !

!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 5/13/2000 15:00'!
proceedRenderingImage
	"This is the main rendering entry"
	| external |
	self inline: false.
	[self finishedProcessing] whileFalse:[
		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		external _ self findNextExternalEntryFromGET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextGETEntry by: 1.
			self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateAddingFromGET].
		external ifTrue:[
			self statePut: GEStateWaitingForEdge.
			^self stopBecauseOf: GErrorGETEntry.
		]. 
		self aetStartPut: 0.
		self wbStackClear.
		self clearSpanBufferPut: 1.

		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		(self clearSpanBufferGet ~= 0 and:[(self currentYGet bitAnd: self aaScanMaskGet) = 0])
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0.
		external _ self findNextExternalFillFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateScanningAET].
		external ifTrue:[
			self statePut: GEStateWaitingForFill.
			^self stopBecauseOf: GErrorFillEntry.
		].
		self wbStackClear.
		self spanEndAAPut: 0.

		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
			self displaySpanBufferAt: self currentYGet.
			self postDisplayAction.
		].
		doProfileStats ifTrue:[
			self incrementStat: GWCountDisplaySpan by: 1.
			self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateBlitBuffer].
		self finishedProcessing ifTrue:[^0].
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.

		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		external _ self findNextExternalUpdateFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextAETEntry by: 1.
			self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateUpdateEdges].
		external ifTrue:[
			self statePut: GEStateWaitingChange.
			^self stopBecauseOf: GErrorAETEntry.
		].
	].! !

!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 5/13/2000 15:00'!
proceedRenderingScanline
	"Proceed rendering the current scan line.
	This method may be called after some Smalltalk code has been executed inbetween."
	"This is the main rendering entry"
	| external state |
	self inline: false.
	state _ self stateGet.

	state = GEStateUnlocked ifTrue:[
		self initializeGETProcessing.
		engineStopped ifTrue:[^0].
		state _ GEStateAddingFromGET.
	]. 

	state = GEStateAddingFromGET ifTrue:[
		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		external _ self findNextExternalEntryFromGET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextGETEntry by: 1.
			self incrementStat: GWTimeNextGETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateAddingFromGET].
		external ifTrue:[
			self statePut: GEStateWaitingForEdge.
			^self stopBecauseOf: GErrorGETEntry.
		]. 
		self aetStartPut: 0.
		self wbStackClear.
		self clearSpanBufferPut: 1.
		state _ GEStateScanningAET.
	].

	state = GEStateScanningAET ifTrue:[
		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		(self clearSpanBufferGet ~= 0 and:[(self currentYGet bitAnd: self aaScanMaskGet) = 0])
			ifTrue:[self clearSpanBuffer].
		self clearSpanBufferPut: 0.
		external _ self findNextExternalFillFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextFillEntry by: 1.
			self incrementStat: GWTimeNextFillEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateScanningAET].
		external ifTrue:[
			self statePut: GEStateWaitingForFill.
			^self stopBecauseOf: GErrorFillEntry.
		].
		state _ GEStateBlitBuffer.
		self wbStackClear.
		self spanEndAAPut: 0.
	].

	state = GEStateBlitBuffer ifTrue:[
		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		(self currentYGet bitAnd: self aaScanMaskGet) = self aaScanMaskGet ifTrue:[
			self displaySpanBufferAt: self currentYGet.
			self postDisplayAction.
		].
		doProfileStats ifTrue:[
			self incrementStat: GWCountDisplaySpan by: 1.
			self incrementStat: GWTimeDisplaySpan by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateBlitBuffer].
		self finishedProcessing ifTrue:[^0].
		state _ GEStateUpdateEdges.
		self aetStartPut: 0.
		self currentYPut: self currentYGet + 1.
	].

	state = GEStateUpdateEdges ifTrue:[
		doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
		external _ self findNextExternalUpdateFromAET.
		doProfileStats ifTrue:[
			self incrementStat: GWCountNextAETEntry by: 1.
			self incrementStat: GWTimeNextAETEntry by: (interpreterProxy ioMicroMSecs - geProfileTime)].
		engineStopped ifTrue:[^self statePut: GEStateUpdateEdges].
		external ifTrue:[
			self statePut: GEStateWaitingChange.
			^self stopBecauseOf: GErrorAETEntry.
		].
		self statePut: GEStateAddingFromGET.
	].! !

!BalloonEngineBase methodsFor: 'primitives-rendering' stamp: 'ar 10/31/1998 23:54'!
storeRenderingState
	self inline: false.
	interpreterProxy failed ifTrue:[^nil].
	engineStopped ifTrue:[
		"Check the stop reason and store the required information"
		self storeStopStateIntoEdge: (interpreterProxy stackObjectValue: 1) 
			fill: (interpreterProxy stackObjectValue: 0).
	].
	self storeEngineStateInto: engine.
	interpreterProxy pop: 3.
	interpreterProxy pushInteger: self stopReasonGet.! !


!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:06'!
primitiveAbortProcessing
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	self statePut: GEStateCompleted.
	self storeEngineStateInto: engine.! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:12'!
primitiveCopyBuffer
	| buf1 buf2 diff src dst |
	self export: true.
	self inline: false.

	self var: #src declareC:'int * src'.
	self var: #dst declareC:'int * dst'.

	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].

	buf2 _ interpreterProxy stackObjectValue: 0.
	buf1 _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	"Make sure the old buffer is properly initialized"
	(self loadWorkBufferFrom: buf1) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Make sure the buffers are of the same type"
	(interpreterProxy fetchClassOf: buf1) = (interpreterProxy fetchClassOf: buf2)
		ifFalse:[^interpreterProxy primitiveFail].
	"Make sure buf2 is at least of the size of buf1"
	diff _ (interpreterProxy slotSizeOf: buf2) - (interpreterProxy slotSizeOf: buf1).
	diff < 0 ifTrue:[^interpreterProxy primitiveFail].

	"Okay - ready for copying. First of all just copy the contents up to wbTop"
	src _ workBuffer.
	dst _ interpreterProxy firstIndexableField: buf2.
	0 to: self wbTopGet-1 do:[:i|
		dst at: i put: (src at: i).
	].
	"Adjust wbSize and wbTop in the new buffer"
	dst at: GWBufferTop put: self wbTopGet + diff.
	dst at: GWSize put: self wbSizeGet + diff.
	"Now copy the entries from wbTop to wbSize"
	src _ src + self wbTopGet.
	dst _ dst + self wbTopGet + diff.
	0 to: (self wbSizeGet - self wbTopGet - 1) do:[:i|
		dst at: i put: (src at: i).
	].
	"Okay, done. Check the new buffer by loading the state from it"
	(self loadWorkBufferFrom: buf2) 
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 2. "Leave rcvr on stack"
! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:05'!
primitiveDoProfileStats
	"Turn on/off profiling. Return the old value of the flag."
	| oldValue newValue |
	self inline: false.
	self export: true.
	oldValue _ doProfileStats.
	newValue _ interpreterProxy stackObjectValue: 0.
	newValue _ interpreterProxy booleanValueOf: newValue.
	interpreterProxy failed ifFalse:[
		doProfileStats _ newValue.
		interpreterProxy pop: 2. "Pop rcvr, arg"
		interpreterProxy pushBool: oldValue.
	].! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/13/2000 14:59'!
primitiveFinishedProcessing
	| finished |
	self export: true.
	self inline: false.
	doProfileStats ifTrue:[geProfileTime _ interpreterProxy ioMicroMSecs].
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	engine _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].
	finished _ self finishedProcessing.
	self storeEngineStateInto: engine.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: finished.
	doProfileStats ifTrue:[
		self incrementStat: GWCountFinishTest by: 1.
		self incrementStat: GWTimeFinishTest by: (interpreterProxy ioMicroMSecs - geProfileTime)].
! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:09'!
primitiveInitializeBuffer
	| wbOop size |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].
	wbOop _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: wbOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(size _ interpreterProxy slotSizeOf: wbOop) < GWMinimalSize
		ifTrue:[^interpreterProxy primitiveFail].
	workBuffer _ interpreterProxy firstIndexableField: wbOop.
	objBuffer _ workBuffer + GWHeaderSize.
	self magicNumberPut: GWMagicNumber.
	self wbSizePut: size.
	self wbTopPut: size.
	self statePut: GEStateUnlocked.
	self objStartPut: GWHeaderSize.
	self objUsedPut: 4.	"Dummy fill object"
	self objectTypeOf: 0 put: GEPrimitiveFill.
	self objectLengthOf: 0 put: 4.
	self objectIndexOf: 0 put: 0.
	self getStartPut: 0.
	self getUsedPut: 0.
	self aetStartPut: 0.
	self aetUsedPut: 0.
	self stopReasonPut: 0.
	self needsFlushPut: 0.
	self clipMinXPut: 0.
	self clipMaxXPut: 0.
	self clipMinYPut: 0.
	self clipMaxYPut: 0.
	self currentZPut: 0.
	self resetGraphicsEngineStats.
	self initEdgeTransform.
	self initColorTransform.
	interpreterProxy pop: 2.
	interpreterProxy push: wbOop.! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:08'!
primitiveRegisterExternalEdge
	| rightFillIndex leftFillIndex initialZ initialY initialX index  edge |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 6 
		ifFalse:[^interpreterProxy primitiveFail].
	rightFillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	initialZ _ interpreterProxy stackIntegerValue: 2.
	initialY _ interpreterProxy stackIntegerValue: 3.
	initialX _ interpreterProxy stackIntegerValue: 4.
	index _ interpreterProxy stackIntegerValue: 5.
	engine _ interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	(self allocateObjEntry: GEBaseEdgeSize) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	(self isFillOkay: leftFillIndex)
		ifFalse:[^interpreterProxy primitiveFail].
	(self isFillOkay: rightFillIndex)
		ifFalse:[^interpreterProxy primitiveFail].

	edge _ objUsed.
	objUsed _ edge + GEBaseEdgeSize.
	"Install type and length"
	self objectTypeOf: edge put: GEPrimitiveEdge.
	self objectLengthOf: edge put: GEBaseEdgeSize.
	self objectIndexOf: edge put: index.
	"Install remaining stuff"
	self edgeXValueOf: edge put: initialX.
	self edgeYValueOf: edge put: initialY.
	self edgeZValueOf: edge put: initialZ.
	self edgeLeftFillOf: edge put: (self transformColor: leftFillIndex).
	self edgeRightFillOf: edge put: (self transformColor: rightFillIndex).
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 6. "Leave rcvr on stack"
	].! !

!BalloonEngineBase methodsFor: 'primitives-other' stamp: 'ar 5/11/2000 23:14'!
primitiveRegisterExternalFill
	| index  fill |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	index _ interpreterProxy stackIntegerValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Note: We *must* not allocate any fill with index 0"
	fill _ 0.
	[fill = 0] whileTrue:[
		(self allocateObjEntry: GEBaseEdgeSize) 
			ifFalse:[^interpreterProxy primitiveFail].
		fill _ objUsed.
		objUsed _ fill + GEBaseFillSize.
		"Install type and length"
		self objectTypeOf: fill put: GEPrimitiveFill.
		self objectLengthOf: fill put: GEBaseFillSize.
		self objectIndexOf: fill put: index.
	].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 2.
		interpreterProxy pushInteger: fill.
	].! !


!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/29/1998 18:37'!
allocateAETEntry: nSlots
	"Allocate n slots in the active edge table"
	^self needAvailableSpace: nSlots! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/28/1998 21:06'!
allocateGETEntry: nSlots
	"Allocate n slots in the global edge table"
	| srcIndex dstIndex |
	self inline: false.
	"First allocate nSlots in the AET"
	(self allocateAETEntry: nSlots) ifFalse:[^false].
	self aetUsedGet = 0 ifFalse:["Then move the AET upwards"
		srcIndex _ self aetUsedGet.
		dstIndex _ self aetUsedGet + nSlots.
		1 to: self aetUsedGet do:[:i|
			aetBuffer at: (dstIndex _ dstIndex - 1) put: (aetBuffer at: (srcIndex _ srcIndex - 1))].
	].
	aetBuffer _ aetBuffer + nSlots.
	^true! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/28/1998 21:16'!
allocateObjEntry: nSlots
	"Allocate n slots in the object buffer"
	| srcIndex dstIndex |
	self inline: false.
	"First allocate nSlots in the GET"
	(self allocateGETEntry: nSlots) ifFalse:[^false].
	self getUsedGet = 0 ifFalse:["Then move the GET upwards"
		srcIndex _ self getUsedGet.
		dstIndex _ self getUsedGet + nSlots.
		1 to: self getUsedGet do:[:i|
			getBuffer at: (dstIndex _ dstIndex - 1) put: (getBuffer at: (srcIndex _ srcIndex - 1))].
	].
	getBuffer _ getBuffer + nSlots.
	^true! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/29/1998 18:37'!
allocateStackEntry: nSlots
	"AET and Stack allocation are symmetric"
	^self needAvailableSpace: nSlots! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/30/1998 19:24'!
allocateStackFillEntry
	^self wbStackPush: self stackFillEntryLength! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 10/30/1998 19:24'!
freeStackFillEntry
	self wbStackPop: self stackFillEntryLength.! !

!BalloonEngineBase methodsFor: 'allocating' stamp: 'ar 11/25/1998 02:19'!
needAvailableSpace: nSlots
	"Check if we have n slots available"
	GWHeaderSize + objUsed + self getUsedGet + self aetUsedGet + nSlots > self wbTopGet ifTrue:[
		self stopBecauseOf: GErrorNoMoreSpace.
		^false
	].
	^true! !


!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 11/1/1998 01:07'!
addEdgeToGET: edge
	self inline: false.
	(self allocateGETEntry: 1) ifFalse:[^0].
	"Install edge in the GET"
	getBuffer at: self getUsedGet put: edge.
	self getUsedPut: self getUsedGet + 1.! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 11/25/1998 00:41'!
createGlobalEdgeTable
	"Create the global edge table"
	| object end |
	self inline: false.
	object _ 0.
	end _ objUsed.
	[object < end] whileTrue:[
		"Note: addEdgeToGET: may fail on insufficient space but that's not a problem here"
		(self isEdge: object) ifTrue:[
			"Check if the edge starts below fillMaxY."
			(self edgeYValueOf: object) >= self fillMaxYGet ifFalse:[
				self checkedAddEdgeToGET: object.
			].
		].
		object _ object + (self objectLengthOf: object).
	].! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 11/9/1998 15:36'!
findNextExternalEntryFromGET
	"Check the global edge table for any entries that cannot be handled by the engine itself.
	If there are any, return true. Otherwise, initialize the the edge and add it to the AET"
	| yValue edge type |
	yValue _ self currentYGet.
	"As long as we have entries in the GET"
	[self getStartGet < self getUsedGet] whileTrue:[
		edge _ getBuffer at: self getStartGet.
		(self edgeYValueOf: edge) > yValue ifTrue:[^false]. "No more edges to add"
		type _ self objectTypeOf: edge.
		(type bitAnd: GEPrimitiveWideMask) = GEPrimitiveEdge 
			ifTrue:[^true]. "This is an external edge"
		"Note: We must make sure not to do anything with the edge if there is not
		enough room in the AET"
		(self needAvailableSpace: 1) ifFalse:[^false]. "No more room"
		"Process the edge in the engine itself"
		self dispatchOn: type in: EdgeInitTable.
		"Insert the edge into the AET"
		self insertEdgeIntoAET: edge.
		self getStartPut: self getStartGet + 1.
	].
	"No entries in GET"
	^false! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 10/28/1998 21:07'!
getSorts: edge1 before: edge2
	"Return true if the edge at index i should sort before the edge at index j."
	| diff |
	self inline: false.
	edge1 = edge2 ifTrue:[^true].
	"First, sort by Y"
	diff _ (self edgeYValueOf: edge1) - (self edgeYValueOf: edge2).
	diff = 0 ifFalse:[^diff < 0].
	"Then, by X"
	diff _ (self edgeXValueOf: edge1) - (self edgeXValueOf: edge2).
	^diff < 0! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 11/25/1998 00:41'!
initializeGETProcessing
	"Initialization stuff that needs to be done before any processing can take place."
	self inline: false.

	"Make sure aaLevel is initialized"
	self setAALevel: self aaLevelGet.

	self clipMinXGet < 0 ifTrue:[self clipMinXPut: 0].
	self clipMaxXGet > self spanSizeGet ifTrue:[self clipMaxXPut: self spanSizeGet].
	"Convert clipRect to aaLevel"
	self fillMinXPut: self clipMinXGet << self aaShiftGet.
	self fillMinYPut: self clipMinYGet << self aaShiftGet.
	self fillMaxXPut: self clipMaxXGet << self aaShiftGet.
	self fillMaxYPut: self clipMaxYGet << self aaShiftGet.

	"Reset GET and AET"
	self getUsedPut: 0.
	self aetUsedPut: 0.
	getBuffer _ aetBuffer _ objBuffer + objUsed.

	"Create the global edge table"
	self createGlobalEdgeTable.
	engineStopped ifTrue:[^nil].

	self getUsedGet = 0 ifTrue:[
		"Nothing to do"
		self currentYPut: self fillMaxYGet.
		^0].

	"Sort entries in the GET"
	self sortGlobalEdgeTable.

	"Find the first y value to be processed"
	self currentYPut: (self edgeYValueOf: (getBuffer at: 0)).
	self currentYGet < self fillMinYGet ifTrue:[self currentYPut: self fillMinYGet].

	"Load and clear the span buffer"
	self spanStartPut: 0.
	self spanEndPut: (self spanSizeGet << self aaShiftGet) - 1.
	self clearSpanBuffer. "@@: Is this really necessary?!!"! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 10/27/1998 17:55'!
quickSortGlobalEdgeTable: array from: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."
	"Note: The original loop has been heavily re-written for C translation"
	| di dij dj tt ij k l n tmp again before |
	self var: #array declareC:'int *array'.
	self inline: false.
	"The prefix d means the data at that index."
	(n _ j + 1  - i) <= 1 ifTrue: [^0].	"Nothing to sort." 
	 "Sort di,dj."
	di _ array at: i.
	dj _ array at: j.
	before _ self getSorts: di before: dj. "i.e., should di precede dj?"
	before ifFalse:[
		tmp _ array at: i.
		array at: i put: (array at: j).
		array at: j put: tmp.
		tt _ di.	di _ dj.	dj _ tt].
	n <= 2 ifTrue:[^0].

	"More than two elements."
	ij _ (i + j) // 2.  "ij is the midpoint of i and j."
	dij _ array at: ij.  "Sort di,dij,dj.  Make dij be their median."
	before _ (self getSorts: di before: dij). "i.e. should di precede dij?"
	before ifTrue:[
		before _ (self getSorts: dij before: dj). "i.e., should dij precede dj?"
		before ifFalse:["i.e., should dij precede dj?"
			tmp _ array at: j.
			array at: j put: (array at: ij).
			array at: ij put: tmp.
			dij _ dj]
	] ifFalse:[  "i.e. di should come after dij"
		tmp _ array at: i.
		array at: i put: (array at: ij).
		array at: ij put: tmp.
		 dij _ di].
	n <= 3 ifTrue:[^0].

	 "More than three elements."
	"Find k>i and l<j such that dk,dij,dl are in reverse order.
	Swap k and l.  Repeat this procedure until k and l pass each other."
	k _ i.
	l _ j.

	again _ true.
	[again] whileTrue:[
		before _ true.
		[before] whileTrue:[
			k <= (l _ l - 1)
				ifTrue:[	tmp _ array at: l.
						before _ self getSorts: dij before: tmp]
				ifFalse:[before _ false].
		].
		before _ true.
		[before] whileTrue:[
			(k _ k + 1) <= l
				ifTrue:[	tmp _ array at: k.
						before _ self getSorts: tmp before: dij]
				ifFalse:[before _ false]].

		again _ k <= l.
		again ifTrue:[
			tmp _ array at: k.
			array at: k put: (array at: l).
			array at: l put: tmp]].

	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
	self quickSortGlobalEdgeTable: array from: i to: l.
	self quickSortGlobalEdgeTable: array from: k to: j.! !

!BalloonEngineBase methodsFor: 'GET processing' stamp: 'ar 10/27/1998 23:34'!
sortGlobalEdgeTable
	"Sort the entire global edge table"
	self quickSortGlobalEdgeTable: getBuffer from: 0 to: self getUsedGet-1.! !


!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 11/24/1998 22:47'!
findNextAETEdgeFrom: leftEdge
	| depth rightEdge |
	depth _ self edgeZValueOf: leftEdge.
	[self aetStartGet < self aetUsedGet] whileTrue:[
		rightEdge _ aetBuffer at: self aetStartGet.
		(self edgeZValueOf: rightEdge) >= depth ifTrue:[^rightEdge].
		self aetStartPut: self aetStartGet + 1.
	].
	^nil! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 11/25/1998 23:21'!
findNextExternalFillFromAET
	"Scan the active edge table. If there is any fill that cannot be handled by the engine itself,  return true. Otherwise handle the fills and return false."
	| leftEdge rightEdge leftX rightX |
"self currentYGet >= 680 ifTrue:[
self printAET.
self halt.
]."

	self inline: false.
	leftX _ rightX _ self fillMaxXGet.
	[self aetStartGet < self aetUsedGet] whileTrue:[
		leftEdge _ rightEdge _ aetBuffer at: self aetStartGet.
		"TODO: We should check if leftX from last operation 
			is  greater than leftX from next edge.
			Currently, we rely here on spanEndAA
			from the span buffer fill."
		leftX _ rightX _ self edgeXValueOf: leftEdge.
		leftX >= self fillMaxXGet ifTrue:[^false]. "Nothing more visible"
		self quickRemoveInvalidFillsAt: leftX.
		"Check if we need to draw the edge"
		(self isWide: leftEdge) ifTrue:[
			self toggleWideFillOf: leftEdge.
			"leftX _ rightX _ self drawWideEdge: leftEdge from: leftX."
		].
		(self areEdgeFillsValid: leftEdge) ifTrue:[
			self toggleFillsOf: leftEdge. "Adjust the fills"
			engineStopped ifTrue:[^false].
		].
		self aetStartPut: self aetStartGet + 1.
		self aetStartGet < self aetUsedGet ifTrue:[
			rightEdge _ aetBuffer at: self aetStartGet.
			rightX _ self edgeXValueOf: rightEdge.
			rightX >= self fillMinXGet ifTrue:["This is the visible portion"
				self fillAllFrom: leftX to: rightX.
				"Fetch the currently active fill"
				"fill _ self makeUnsignedFrom: self topFill.
				fill = 0 ifFalse:[self fillSpan: fill from: leftX to: rightX max: self topRightX]"
			].
		].
	].
	"Note: Due to pre-clipping we may have to draw remaining stuff with the last fill"
	rightX < self fillMaxXGet ifTrue:[
		self fillAllFrom: rightX to: self fillMaxXGet.
		"fill _ self makeUnsignedFrom: self topFill.
		fill = 0 ifFalse:[self fillSpan: fill from: rightX to: self fillMaxXGet max: self topRightX]."
	].
	^false! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 11/9/1998 15:36'!
findNextExternalUpdateFromAET
	"Check the active edge table for any entries that cannot be handled by the engine itself.
	If there are any, return true. Otherwise, step the the edge to the next y value."
	| edge count type |
	self inline: false.
	[self aetStartGet < self aetUsedGet] whileTrue:[
		edge _ aetBuffer at: self aetStartGet.
		count _ (self edgeNumLinesOf: edge) - 1.
		count = 0 ifTrue:[
			"Edge at end -- remove it"
			self removeFirstAETEntry
		] ifFalse:[
			"Store remaining lines back"
			self edgeNumLinesOf: edge put: count.
			type _ self objectTypeOf: edge.
			(type bitAnd: GEPrimitiveWideMask) = GEPrimitiveEdge 
				ifTrue:[^true]. "This is an external edge"
			self dispatchOn: type in: EdgeStepTable.
			self resortFirstAETEntry.
			self aetStartPut: self aetStartGet+1.
		].
	].
	^false! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 21:07'!
indexForInsertingIntoAET: edge
	"Find insertion point for the given edge in the AET"
	| initialX index |
	self inline: false.
	initialX _ self edgeXValueOf: edge.
	index _ 0.
	[index < self aetUsedGet and:[
		(self edgeXValueOf: (aetBuffer at: index)) < initialX]]
			whileTrue:[index _ index + 1].
	[index < self aetUsedGet and:[
		(self edgeXValueOf: (aetBuffer at: index)) = initialX and:[
			(self getSorts: (aetBuffer at: index) before: edge)]]]
				whileTrue:[index _ index + 1].
	^index! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 19:52'!
insertEdgeIntoAET: edge
	"Insert the edge with the given index from the global edge table into the active edge table.
	The edge has already been stepped to the initial yValue -- thus remainingLines and rasterX
	are both set."
	| index |
	self inline: false.

	"Check for the number of lines remaining"
	(self edgeNumLinesOf: edge) <= 0 ifTrue:[^nil]. "Nothing to do"

	"Find insertion point"
	index _ self indexForInsertingIntoAET: edge.

	"And insert edge"
	self insertToAET: edge beforeIndex: index.! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 21:07'!
insertToAET: edge beforeIndex: index
	"Insert the given edge into the AET."
	| i |
	self inline: false.
	"Make sure we have space in the AET"
	(self allocateAETEntry: 1) ifFalse:[^nil]. "Insufficient space in AET"

	i _ self aetUsedGet-1.
	[i < index] whileFalse:[
		aetBuffer at: i+1 put: (aetBuffer at: i).
		i _ i - 1.
	].
	aetBuffer at: index put: edge.
	self aetUsedPut: self aetUsedGet + 1.! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 01:39'!
moveAETEntryFrom: index edge: edge x: xValue
	"The entry at index is not in the right position of the AET. 
	Move it to the left until the position is okay."
	| newIndex |
	self inline: false.
	newIndex _ index.
	[newIndex > 0 and:[(self edgeXValueOf: (aetBuffer at: newIndex-1)) > xValue]]
		whileTrue:[	aetBuffer at: newIndex put: (aetBuffer at: newIndex-1).
					newIndex _ newIndex - 1].
	aetBuffer at: newIndex put: edge.! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 21:07'!
removeFirstAETEntry
	| index |
	self inline: false.
	index _ self aetStartGet.
	self aetUsedPut: self aetUsedGet - 1.
	[index < self aetUsedGet] whileTrue:[
		aetBuffer at: index put: (aetBuffer at: index + 1).
		index _ index + 1.
	].! !

!BalloonEngineBase methodsFor: 'AET processing' stamp: 'ar 10/28/1998 21:07'!
resortFirstAETEntry
	| edge xValue leftEdge |
	self inline: false.
	self aetStartGet = 0 ifTrue:[^nil]. "Nothing to resort"
	edge _ aetBuffer at: self aetStartGet.
	xValue _ self edgeXValueOf: edge.
	leftEdge _ aetBuffer at: (self aetStartGet - 1).
	(self edgeXValueOf: leftEdge) <= xValue ifTrue:[^nil]. "Okay"
	self moveAETEntryFrom: self aetStartGet edge: edge x: xValue.! !


!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/24/1998 22:42'!
fillSorts: fillEntry1 before: fillEntry2
	"Return true if fillEntry1 should be drawn before fillEntry2"
	| diff |
	self inline: false.
	"First check the depth value"
	diff _ (self stackFillDepth: fillEntry1) - (self stackFillDepth: fillEntry2).
	diff = 0 ifFalse:[^diff > 0].
	"See the class comment for aetScanningProblems"
	^(self cCoerce: (self makeUnsignedFrom: (self stackFillValue: fillEntry1)) to:'unsigned') <
		(self cCoerce: (self makeUnsignedFrom: (self stackFillValue: fillEntry2)) to: 'unsigned')! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:47'!
findStackFill: fillIndex depth: depth
	| index |
	index _ 0.
	[index < self stackFillSize and:[
		(self stackFillValue: index) ~= fillIndex or:[
			(self stackFillDepth: index) ~= depth]]]
				whileTrue:[index _ index + self stackFillEntryLength].
	index >= self stackFillSize 
		ifTrue:[^-1]
		ifFalse:[^index].
! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:48'!
hideFill: fillIndex depth: depth
	"Make the fill style with the given index invisible"
	| index newTopIndex newTop newDepth newRightX |
	self inline: false.
	index _ self findStackFill: fillIndex depth: depth.
	index = -1 ifTrue:[^false].

	index = 0 ifTrue:[
		self freeStackFillEntry.
		^true].

	"Fill is visible - replace it with the last entry on the stack"
	self stackFillValue: index put: (self stackFillValue: 0).
	self stackFillDepth: index put: (self stackFillDepth: 0).
	self stackFillRightX: index put: (self stackFillRightX: 0).
	self freeStackFillEntry.
	(self stackFillSize <= self stackFillEntryLength) ifTrue:[^true]. "Done"

	"Find the new top fill"
	newTopIndex _ 0.
	index _ self stackFillEntryLength.
	[index < self stackFillSize] whileTrue:[
		(self fillSorts: index before: newTopIndex)
			ifTrue:[newTopIndex _ index].
		index _ index + self stackFillEntryLength.
	].
	(newTopIndex + self stackFillEntryLength = self stackFillSize) 
		ifTrue:[^true]. "Top fill not changed"
	newTop _ self stackFillValue: newTopIndex.
	self stackFillValue: newTopIndex put: self topFillValue.
	self topFillValuePut: newTop.
	newDepth _ self stackFillDepth: newTopIndex.
	self stackFillDepth: newTopIndex put: self topFillDepth.
	self topFillDepthPut: newDepth.
	newRightX _ self stackFillRightX: newTopIndex.
	self stackFillRightX: newTopIndex put: self topFillRightX.
	self topFillRightXPut: newRightX.
	^true! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:16'!
quickRemoveInvalidFillsAt: leftX
	"Remove any top fills if they have become invalid."
	self stackFillSize = 0 ifTrue:[^nil].
	[self topRightX <= leftX] whileTrue:[
		self hideFill: self topFill depth: self topDepth.
		self stackFillSize = 0 ifTrue:[^nil].
	].! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 14:38'!
showFill: fillIndex depth: depth rightX: rightX
	self inline: false.
	(self allocateStackFillEntry) ifFalse:[^nil]. "Insufficient space"
	self stackFillValue: 0 put: fillIndex.
	self stackFillDepth: 0 put: depth.
	self stackFillRightX: 0 put: rightX.
	self stackFillSize = self stackFillEntryLength ifTrue:[^nil]. "No need to update"

	(self fillSorts: 0 before: self stackFillSize - self stackFillEntryLength) ifTrue:[
		"New top fill"
		self stackFillValue: 0 put: self topFillValue.
		self stackFillDepth: 0 put: self topFillDepth.
		self stackFillRightX: 0 put: self topFillRightX.
		self topFillValuePut: fillIndex.
		self topFillDepthPut: depth.
		self topFillRightXPut: rightX.
	].! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 14:38'!
toggleFill: fillIndex depth: depth rightX: rightX
	"Make the fill style with the given index either visible or invisible"
	| hidden |
	self inline: false.

	self stackFillSize = 0 ifTrue:[
		(self allocateStackFillEntry) ifTrue:[
			self topFillValuePut: fillIndex.
			self topFillDepthPut: depth.
			self topFillRightXPut: rightX.
		].
	] ifFalse:[
		hidden _ self hideFill: fillIndex depth: depth.
		hidden ifFalse:[self showFill: fillIndex depth: depth rightX: rightX].
	].! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:19'!
toggleFillsOf: edge
	| depth fillIndex |
	self inline: false.

	(self needAvailableSpace: self stackFillEntryLength * 2) 
		ifFalse:[^nil]. "Make sure we have enough space left"
	depth _ (self edgeZValueOf: edge) << 1.
	fillIndex _ self edgeLeftFillOf: edge.
	fillIndex = 0 ifFalse:[self toggleFill: fillIndex depth: depth rightX: 999999999].
	fillIndex _ self edgeRightFillOf: edge.
	fillIndex = 0 ifFalse:[self toggleFill: fillIndex depth: depth rightX: 999999999].
	self quickRemoveInvalidFillsAt: (self edgeXValueOf: edge).! !

!BalloonEngineBase methodsFor: 'FILL processing' stamp: 'ar 11/25/1998 15:50'!
toggleWideFillOf: edge
	| fill type lineWidth depth rightX index |
	self inline: false.
	type _ self edgeTypeOf: edge.
	dispatchedValue _ edge.
	self dispatchOn: type in: WideLineWidthTable.
	lineWidth _ dispatchReturnValue.
	self dispatchOn: type in: WideLineFillTable.
	fill _ dispatchReturnValue.
	fill = 0 ifTrue:[^nil].
	(self needAvailableSpace: self stackFillEntryLength) 
		ifFalse:[^nil]. "Make sure we have enough space left"
	depth _ (self edgeZValueOf: edge) << 1 + 1. "So lines sort before interior fills"
	rightX _ (self edgeXValueOf: edge) + lineWidth.
	index _ self findStackFill: fill depth: depth.
	index = -1 ifTrue:[
		self showFill: fill 
			depth: depth
			rightX: rightX.
	] ifFalse:[
		(self stackFillRightX: index) < rightX
			ifTrue:[self stackFillRightX: index put: rightX].
	].
	self quickRemoveInvalidFillsAt: (self edgeXValueOf: edge).! !


!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/9/1998 00:53'!
aaFirstPixelFrom: leftX to: rightX
	"Common function to compute the first full pixel for AA drawing"
	| firstPixel |
	self inline: true.
	firstPixel _ (leftX + self aaLevelGet - 1) bitAnd: (self aaLevelGet - 1) bitInvert32.
	firstPixel > rightX 
		ifTrue:[^rightX]
		ifFalse:[^firstPixel]! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/9/1998 00:53'!
aaLastPixelFrom: leftX to: rightX
	"Common function to compute the last full pixel for AA drawing"
	self inline: true.
	^(rightX - 1) bitAnd: (self aaLevelGet - 1) bitInvert32.! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/9/1998 00:50'!
adjustAALevel

		"NOTE: 	This method is (hopefully) obsolete due to unrolling 
				the fill loops to deal with full pixels."

	"Adjust the span buffers values by the appropriate color offset for anti-aliasing.
	We do this by replicating the top bits of each color in the lower bits. The idea is that we can scale each color value uniquely from 0 to 255 and thus fill the entire range of colors."
	| adjustShift adjustMask x0 x1 pixelValue |
	self inline: false.
	adjustShift _ 8 - self aaColorShiftGet.
	adjustMask _ self aaColorMaskGet bitInvert32.
	x0 _ self spanStartGet >> self aaShiftGet.
	x1 _ self spanEndGet >> self aaShiftGet.
	[x0 < x1] whileTrue:[
		pixelValue _ spanBuffer at: x0.
		spanBuffer at: x0 put: (pixelValue bitOr: (pixelValue >> adjustShift bitAnd: adjustMask)).
		x0 _ x0 + 1].! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/14/1998 19:31'!
clearSpanBuffer
	"Clear the current span buffer.
	The span buffer is only cleared in the area that has been used by the previous scan line."
	| x0 x1 |
	self inline: false.
	x0 _ self spanStartGet >> self aaShiftGet.
	x1 _ self spanEndGet >> self aaShiftGet + 1.
	x0 < 0 ifTrue:[x0 _ 0].
	x1 > self spanSizeGet ifTrue:[x1 _ self spanSizeGet].
	[x0 < x1] whileTrue:[
		spanBuffer at: x0 put: 0.
		x0 _ x0 + 1].
	self spanStartPut: self spanSizeGet.
	self spanEndPut: 0.! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 5/12/2000 16:42'!
displaySpanBufferAt: y
	"Display the span buffer at the current scan line."
	| targetX0 targetX1 targetY |
	self inline: false.
	"self aaLevelGet > 1 ifTrue:[self adjustAALevel]."
	targetX0 _ self spanStartGet >> self aaShiftGet.
	targetX0 < self clipMinXGet ifTrue:[targetX0 _ self clipMinXGet].
	targetX1 _ (self spanEndGet + self aaLevelGet - 1) >> self aaShiftGet.
	targetX1 > self clipMaxXGet ifTrue:[targetX1 _ self clipMaxXGet].
	targetY _ y >> self aaShiftGet.
	(targetY < self clipMinYGet or:[targetY >= self clipMaxYGet or:[
		targetX1 < self clipMinXGet or:[targetX0 >= self clipMaxXGet]]]) ifTrue:[^0].
	self copyBitsFrom: targetX0 to: targetX1 at: targetY.! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/25/1998 02:34'!
drawWideEdge: edge from: leftX
	"Draw the given edge starting from leftX with the edge's fill.
	Return the end value of the drawing operation."
	| rightX fill type lineWidth |
	self inline: false. "Not for the moment"
	type _ self edgeTypeOf: edge.
	dispatchedValue _ edge.
	self dispatchOn: type in: WideLineWidthTable.
	lineWidth _ dispatchReturnValue.
	self dispatchOn: type in: WideLineFillTable.
	fill _ self makeUnsignedFrom: dispatchReturnValue.
	fill = 0 ifTrue:[^leftX].
	"Check if this line is only partially visible"
	"self assert:(self isFillColor: fill)."
	rightX _ leftX + lineWidth.
	self fillSpan: fill from: leftX to: rightX.
	^rightX! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/25/1998 15:12'!
fillAllFrom: leftX to: rightX
	"Fill the span buffer from leftX to rightX with the given fill."
	| fill startX stopX |
	self inline: true.
	fill _ self topFill.
	startX _ leftX.
	stopX _ self topRightX.
	[stopX < rightX] whileTrue:[
		fill _ self makeUnsignedFrom: self topFill.
		fill = 0 ifFalse:[
			(self fillSpan: fill from: startX to: stopX) ifTrue:[^true]].
		self quickRemoveInvalidFillsAt: stopX.
		startX _ stopX.
		stopX _ self topRightX].
	fill _ self makeUnsignedFrom: self topFill.
	fill = 0 ifFalse:[^self fillSpan: fill from: startX to: rightX].
	^false! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/9/1998 16:10'!
fillBitmapSpan: bits from: leftX to: rightX
	"Fill the span buffer between leftEdge and rightEdge using the given bits.
	Note: We always start from zero - this avoids using huge bitmap buffers if the bitmap is to be displayed at the very far right hand side and also gives us a chance of using certain bitmaps (e.g., those with depth 32) directly."
	| x0 x1 x bitX colorMask colorShift baseShift fillValue |
	self inline: false.
	self var: #bits declareC:'int *bits'.

	x0 _ leftX.
	x1 _ rightX.
	bitX _ -1. "Hack for pre-increment"
	self aaLevelGet = 1 ifTrue:["Speedy version for no anti-aliasing"
		[x0 < x1] whileTrue:[
			fillValue _ (self cCoerce: bits to: 'int *') at: (bitX _ bitX + 1).
			spanBuffer at: x0 put: fillValue.
			x0 _ x0 + 1.
		].
	] ifFalse:["Generic version with anti-aliasing"
		colorMask _ self aaColorMaskGet.
		colorShift _ self aaColorShiftGet.
		baseShift _ self aaShiftGet.
		[x0 < x1] whileTrue:[
			x _ x0 >> baseShift.
			fillValue _ (self cCoerce: bits to: 'int *') at: (bitX _ bitX + 1).
			fillValue _ (fillValue bitAnd: colorMask) >> colorShift.
			spanBuffer at: x put: (spanBuffer at: x) + fillValue.
			x0 _ x0 + 1.
		].
	].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/8/1998 03:30'!
fillColorSpan: pixelValue32 from: leftX to: rightX
	"Fill the span buffer between leftEdge and rightEdge with the given pixel value."
	| x0 x1 |
	self inline: true.
	"Use a unrolled version for anti-aliased fills..."
	self aaLevelGet = 1
		ifFalse:[^self fillColorSpanAA: pixelValue32 x0: leftX x1: rightX].
	x0 _ leftX.
	x1 _ rightX.
	"Unroll the inner loop four times, since we're only storing data."
	[x0 + 4 < x1] whileTrue:[
		spanBuffer at: x0 put: pixelValue32.
		spanBuffer at: x0+1 put: pixelValue32.
		spanBuffer at: x0+2 put: pixelValue32.
		spanBuffer at: x0+3 put: pixelValue32.
		x0 _ x0+4.
	].
	[x0 < x1] whileTrue:[
		spanBuffer at: x0 put: pixelValue32.
		x0 _ x0 + 1.
	].! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/9/1998 00:52'!
fillColorSpanAA: pixelValue32 x0: leftX x1: rightX
	"This is the inner loop for solid color fills with anti-aliasing.
	This loop has been unrolled for speed and quality into three parts:
		a) copy all pixels that fall into the first full pixel.
		b) copy aaLevel pixels between the first and the last full pixel
		c) copy all pixels that fall in the last full pixel"
	| colorMask baseShift x idx firstPixel lastPixel aaLevel pv32 |
	self inline: false. "Not now -- maybe later"
	"Compute the pixel boundaries."
	firstPixel _ self aaFirstPixelFrom: leftX to: rightX.
	lastPixel _ self aaLastPixelFrom: leftX to: rightX.
	aaLevel _ self aaLevelGet.
	baseShift _ self aaShiftGet.
	x _ leftX.

	"Part a: Deal with the first n sub-pixels"
	x < firstPixel ifTrue:[
		pv32 _ (pixelValue32 bitAnd: self aaColorMaskGet) >> self aaColorShiftGet.
		[x < firstPixel] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x _ x + 1.
		].
	].

	"Part b: Deal with the full pixels"
	x < lastPixel ifTrue:[
		colorMask _ (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		pv32 _ (pixelValue32 bitAnd: colorMask) >> self aaShiftGet.
		[x < lastPixel] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x _ x + aaLevel.
		].
	].

	"Part c: Deal with the last n sub-pixels"
	x < rightX ifTrue:[
		pv32 _ (pixelValue32 bitAnd: self aaColorMaskGet) >> self aaColorShiftGet.
		[x < rightX] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + pv32.
			x _ x + 1.
		].
	].! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/15/1998 02:04'!
fillSpan: fill from: leftX to: rightX
	"Fill the span buffer from leftX to rightX with the given fill.
	Clip before performing any operations. Return true if the fill must
	be handled by some Smalltalk code."
	| x0 x1 type |
	self inline: false.
	fill = 0 ifTrue:[^false]. "Nothing to do"
	"Start from spEnd - we must not paint pixels twice at a scan line"
	leftX < self spanEndAAGet 
		ifTrue:[x0 _ self spanEndAAGet]
		ifFalse:[x0 _ leftX].
	rightX > (self spanSizeGet << self aaShiftGet) 
		ifTrue:[x1 _ (self spanSizeGet << self aaShiftGet)]
		ifFalse:[x1 _ rightX].

	"Clip left and right values"
	x0 < self fillMinXGet ifTrue:[x0 _ self fillMinXGet].
	x1 > self fillMaxXGet ifTrue:[x1 _ self fillMaxXGet].

	"Adjust start and end values of span"
	x0 < self spanStartGet ifTrue:[self spanStartPut: x0].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].

	x0 >= x1 ifTrue:[^false]. "Nothing to do"

	(self isFillColor: fill) ifTrue:[
		self fillColorSpan: fill from: x0 to: x1.
	] ifFalse:[
		"Store the values for the dispatch"
		self lastExportedFillPut: fill.
		self lastExportedLeftXPut: x0.
		self lastExportedRightXPut: x1.
		type _ self fillTypeOf: fill.
		type <= 1 ifTrue:[^true].
		self dispatchOn: type in: FillTable.
	].
	^false! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/25/1998 14:57'!
fillSpan: fill from: leftX to: rightX max: maxRightX
	"Fill the span buffer from leftX to rightX with the given fill.
	Clip before performing any operations. Return true if the fill must
	be handled by some Smalltalk code."
	| x0 x1 type |
	self inline: false.
	fill = 0 ifTrue:[^false]. "Nothing to do"
	"Start from spEnd - we must not paint pixels twice at a scan line"
	leftX < self spanEndAAGet 
		ifTrue:[x0 _ self spanEndAAGet]
		ifFalse:[x0 _ leftX].
	rightX > (self spanSizeGet << self aaShiftGet) 
		ifTrue:[x1 _ (self spanSizeGet << self aaShiftGet)]
		ifFalse:[x1 _ rightX].

	maxRightX < x1 ifTrue:[x1 _ maxRightX].

	"Clip left and right values"
	x0 < self fillMinXGet ifTrue:[x0 _ self fillMinXGet].
	x1 > self fillMaxXGet ifTrue:[x1 _ self fillMaxXGet].

	"Adjust start and end values of span"
	x0 < self spanStartGet ifTrue:[self spanStartPut: x0].
	x1 > self spanEndGet ifTrue:[self spanEndPut: x1].
	x1 > self spanEndAAGet ifTrue:[self spanEndAAPut: x1].

	x0 >= x1 ifTrue:[^false]. "Nothing to do"

	(self isFillColor: fill) ifTrue:[
		self fillColorSpan: fill from: x0 to: x1.
	] ifFalse:[
		"Store the values for the dispatch"
		self lastExportedFillPut: fill.
		self lastExportedLeftXPut: x0.
		self lastExportedRightXPut: x1.
		type _ self fillTypeOf: fill.
		type <= 1 ifTrue:[^true].
		self dispatchOn: type in: FillTable.
	].
	^false! !

!BalloonEngineBase methodsFor: 'displaying' stamp: 'ar 11/8/1998 15:13'!
postDisplayAction
	"We have just blitted a scan line to the screen.
	Do whatever seems to be a good idea here."
	"Note: In the future we may check the time needed for this scan line and interrupt processing to give the Smalltalk code a chance to run at a certain time."

	self inline: false.

	"Check if there is any more work to do."
	(self getStartGet >= self getUsedGet and:[self aetUsedGet = 0]) ifTrue:[
		"No more entries to process"
		self statePut: GEStateCompleted.
	].
	(self currentYGet >= self fillMaxYGet) ifTrue:[
		"Out of clipping range"
		self statePut: GEStateCompleted.
	].! !


!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/8/1998 14:26'!
incrementPoint: point by: delta
	self var: #point declareC:'int *point'.
	point at: 0 put: (point at: 0) + delta.
	point at: 1 put: (point at: 1) + delta.! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 9/5/1999 14:13'!
transformColor: fillIndex
	| r g b a transform alphaScale |
	self var: #transform declareC:'float *transform'.
	self var: #alphaScale declareC:'double alphaScale'.
	(fillIndex = 0 or:[self isFillColor: fillIndex]) ifFalse:[^fillIndex].
	b _ fillIndex bitAnd: 255.
	g _ (fillIndex >> 8) bitAnd: 255.
	r _ (fillIndex >> 16) bitAnd: 255.
	a _ (fillIndex >> 24) bitAnd: 255.
	(self hasColorTransform) ifTrue:[
		transform _ self colorTransform.
		alphaScale _ (a * (transform at: 6) + (transform at: 7)) / a.
		r _ (r * (transform at: 0) + (transform at: 1) * alphaScale) asInteger.
		g _ (g * (transform at: 2) + (transform at: 3) * alphaScale) asInteger.
		b _ (b * (transform at: 4) + (transform at: 5) * alphaScale) asInteger.
		a _ a * alphaScale.
		r _ r max: 0. r _ r min: 255.
		g _ g max: 0. g _ g min: 255.
		b _ b max: 0. b _ b min: 255.
		a _ a max: 0. a _ a min: 255.
	].
	a < 1 ifTrue:[^0]."ALWAYS return zero for transparent fills"
	"If alpha is not 255 (or close thereto) then we need to flush the engine before proceeding"
	(a < 255 and:[self needsFlush]) 
		ifTrue:[self stopBecauseOf: GErrorNeedFlush].
	^b + (g << 8) + (r << 16) + (a << 24)! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/24/1998 19:47'!
transformPoint: point
	"Transform the given point. If haveMatrix is true then use the current transformation."
	self var:#point declareC:'int *point'.
	self hasEdgeTransform ifFalse:[
		"Multiply each component by aaLevel and add a half pixel"
		point at: 0 put: (point at: 0) + self destOffsetXGet * self aaLevelGet.
		point at: 1 put: (point at: 1) + self destOffsetYGet * self aaLevelGet.
	] ifTrue:[
		"Note: AA adjustment is done in #transformPoint: for higher accuracy"
		self transformPoint: point into: point.
	].! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/1/1998 16:59'!
transformPoint: srcPoint into: dstPoint
	"Transform srcPoint into dstPoint by using the currently loaded matrix"
	"Note: This method has been rewritten so that inlining works (e.g., removing
	the declarations and adding argument coercions at the appropriate points)"
	self inline: true.
	self transformPointX: ((self cCoerce: srcPoint to: 'int *') at: 0) asFloat 
		y: ((self cCoerce: srcPoint to:'int *') at: 1) asFloat
		into: (self cCoerce: dstPoint to: 'int *')! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/24/1998 19:25'!
transformPointX: xValue y: yValue into: dstPoint
	"Transform srcPoint into dstPoint by using the currently loaded matrix"
	"Note: This should be rewritten so that inlining works (e.g., removing
	the declarations and adding argument coercions at the appropriate points)"
	| x y transform |
	self inline: true. "Won't help at the moment ;-("
	self var: #dstPoint declareC:'int *dstPoint'.
	self var: #xValue declareC: 'double xValue'.
	self var: #yValue declareC: 'double yValue'.
	self var: #transform declareC:'float *transform'.
	transform _ self edgeTransform.
	x _ ((((transform at: 0) * xValue) +
		((transform at: 1) * yValue) +
		(transform at: 2)) * self aaLevelGet asFloat) asInteger.
	y _ ((((transform at: 3) * xValue) +
		((transform at: 4) * yValue) +
		(transform at: 5)) * self aaLevelGet asFloat) asInteger.
	dstPoint at: 0 put: x.
	dstPoint at: 1 put: y.! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/24/1998 19:48'!
transformPoints: n
	"Transform n (n=1,2,3) points.
	If haveMatrix is true then the matrix contains the actual transformation."
	self inline: true.
	n > 0 ifTrue:[self transformPoint: self point1Get].
	n > 1 ifTrue:[self transformPoint: self point2Get].
	n > 2 ifTrue:[self transformPoint: self point3Get].
	n > 3 ifTrue:[self transformPoint: self point4Get].! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 10/25/1999 00:57'!
transformWidth: w
	"Transform the given width"
	| deltaX deltaY dstWidth dstWidth2 |
	self inline: false.
	self var: #deltaX declareC:'double deltaX'.
	self var: #deltaY declareC:'double deltaY'.
	w = 0 ifTrue:[^0].
	self point1Get at: 0 put: 0.
	self point1Get at: 1 put: 0.
	self point2Get at: 0 put: w * 256.
	self point2Get at: 1 put: 0.
	self point3Get at: 0 put: 0.
	self point3Get at: 1 put: w * 256.
	self transformPoints: 3.
	deltaX _ ((self point2Get at: 0) - (self point1Get at: 0)) asFloat.
	deltaY _ ((self point2Get at: 1) - (self point1Get at: 1)) asFloat.
	dstWidth _ (((deltaX * deltaX) + (deltaY * deltaY)) sqrt asInteger + 128) // 256.
	deltaX _ ((self point3Get at: 0) - (self point1Get at: 0)) asFloat.
	deltaY _ ((self point3Get at: 1) - (self point1Get at: 1)) asFloat.
	dstWidth2 _ (((deltaX * deltaX) + (deltaY * deltaY)) sqrt asInteger + 128) // 256.
	dstWidth2 < dstWidth ifTrue:[dstWidth _ dstWidth2].
	dstWidth = 0
		ifTrue:[^1]
		ifFalse:[^dstWidth]! !

!BalloonEngineBase methodsFor: 'transforming' stamp: 'ar 11/25/1998 21:33'!
uncheckedTransformColor: fillIndex
	| r g b a transform |
	self var: #transform declareC:'float *transform'.
	(self hasColorTransform) ifFalse:[^fillIndex].
	b _ fillIndex bitAnd: 255.
	g _ (fillIndex >> 8) bitAnd: 255.
	r _ (fillIndex >> 16) bitAnd: 255.
	a _ (fillIndex >> 24) bitAnd: 255.
	transform _ self colorTransform.
	r _ (r * (transform at: 0) + (transform at: 1)) asInteger.
	g _ (g * (transform at: 2) + (transform at: 3)) asInteger.
	b _ (b * (transform at: 4) + (transform at: 5)) asInteger.
	a _ (a * (transform at: 6) + (transform at: 7)) asInteger.
	r _ r max: 0. r _ r min: 255.
	g _ g max: 0. g _ g min: 255.
	b _ b max: 0. b _ b min: 255.
	a _ a max: 0. a _ a min: 255.
	a < 16 ifTrue:[^0]."ALWAYS return zero for transparent fills"
	^b + (g << 8) + (r << 16) + (a << 24)! !


!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/9/1998 02:06'!
accurateLengthOf: deltaX with: deltaY
	"Return the accurate length of the vector described by deltaX and deltaY"
	| length2 |
	deltaX = 0 ifTrue:[deltaY < 0 ifTrue:[^0-deltaY] ifFalse:[^deltaY]].
	deltaY = 0 ifTrue:[deltaX < 0 ifTrue:[^0-deltaX] ifFalse:[^deltaX]].
	length2 _ (deltaX * deltaX) + (deltaY * deltaY).
	^self computeSqrt: length2! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/7/1998 14:26'!
computeSqrt: length2
	length2 < 32 
		ifTrue:[^self smallSqrtTable at: length2]
		ifFalse:[^(length2 asFloat sqrt + 0.5) asInteger]! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/8/1998 14:33'!
estimatedLengthOf: deltaX with: deltaY
	"Estimate the length of the vector described by deltaX and deltaY.
	This method may be extremely inaccurate - use it only
	if you know exactly that this doesn't matter. Otherwise
	use #accurateLengthOf:width:"
	| absDx absDy |
	deltaX >= 0 ifTrue:[absDx _ deltaX] ifFalse:[absDx _ 0 - deltaX].
	deltaY >= 0 ifTrue:[absDy _ deltaY] ifFalse:[absDy _ 0 - deltaY].
	absDx > absDy 
		ifTrue:[^absDx + (absDy // 2)]
		ifFalse:[^absDy + (absDx // 2)]

! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/24/1998 19:45'!
initColorTransform
	| transform |
	self inline: false.
	self var: #transform declareC:'float *transform'.
	transform _ self colorTransform.
	transform at: 0 put: (self cCoerce: 1.0 to: 'float').
	transform at: 1 put: (self cCoerce: 0.0 to: 'float').
	transform at: 2 put: (self cCoerce: 1.0 to: 'float').
	transform at: 3 put: (self cCoerce: 0.0 to: 'float').
	transform at: 4 put: (self cCoerce: 1.0 to: 'float').
	transform at: 5 put: (self cCoerce: 0.0 to: 'float').
	transform at: 6 put: (self cCoerce: 1.0 to: 'float').
	transform at: 7 put: (self cCoerce: 0.0 to: 'float').
	self hasColorTransformPut: 0.! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/24/1998 19:45'!
initEdgeTransform
	| transform |
	self inline: false.
	self var: #transform declareC:'float *transform'.
	transform _ self edgeTransform.
	transform at: 0 put: (self cCoerce: 1.0 to: 'float').
	transform at: 1 put: (self cCoerce: 0.0 to: 'float').
	transform at: 2 put: (self cCoerce: 0.0 to: 'float').
	transform at: 3 put: (self cCoerce: 0.0 to: 'float').
	transform at: 4 put: (self cCoerce: 1.0 to: 'float').
	transform at: 5 put: (self cCoerce: 0.0 to: 'float').
	self hasEdgeTransformPut: 0.! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/7/1998 14:26'!
resetGraphicsEngineStats
	self inline: false.
	workBuffer at: GWTimeInitializing put: 0.
	workBuffer at: GWTimeFinishTest put: 0.
	workBuffer at: GWTimeNextGETEntry put: 0.
	workBuffer at: GWTimeAddAETEntry put: 0.
	workBuffer at: GWTimeNextFillEntry put: 0.
	workBuffer at: GWTimeMergeFill put: 0.
	workBuffer at: GWTimeDisplaySpan put: 0.
	workBuffer at: GWTimeNextAETEntry put: 0.
	workBuffer at: GWTimeChangeAETEntry put: 0.

	workBuffer at: GWCountInitializing put: 0.
	workBuffer at: GWCountFinishTest put: 0.
	workBuffer at: GWCountNextGETEntry put: 0.
	workBuffer at: GWCountAddAETEntry put: 0.
	workBuffer at: GWCountNextFillEntry put: 0.
	workBuffer at: GWCountMergeFill put: 0.
	workBuffer at: GWCountDisplaySpan put: 0.
	workBuffer at: GWCountNextAETEntry put: 0.
	workBuffer at: GWCountChangeAETEntry put: 0.

	workBuffer at: GWBezierMonotonSubdivisions put: 0.
	workBuffer at: GWBezierHeightSubdivisions put: 0.
	workBuffer at: GWBezierOverflowSubdivisions put: 0.
	workBuffer at: GWBezierLineConversions put: 0.
! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/7/1998 14:26'!
setAALevel: level
	"Set the anti-aliasing level. Three levels are supported:
		1 - No antialiasing
		2 - 2x2 unweighted anti-aliasing
		4 - 4x4 unweighted anti-aliasing.
	"
	| aaLevel |
	self inline: false.
	level >= 4 ifTrue:[aaLevel _ 4].
	(level >= 2) & (level < 4) ifTrue:[aaLevel _ 2].
	level < 2 ifTrue:[aaLevel _ 1].
	self aaLevelPut: aaLevel.
	aaLevel = 1 ifTrue:[
		self aaShiftPut: 0.
		self aaColorMaskPut: 16rFFFFFFFF.
		self aaScanMaskPut: 0.
	].
	aaLevel = 2 ifTrue:[
		self aaShiftPut: 1.
		self aaColorMaskPut: 16rFCFCFCFC.
		self aaScanMaskPut: 1.
	].
	aaLevel = 4 ifTrue:[
		self aaShiftPut: 2.
		self aaColorMaskPut: 16rF0F0F0F0.
		self aaScanMaskPut: 3.
	].
	self aaColorShiftPut: self aaShiftGet * 2.
	self aaHalfPixelPut: self aaShiftGet.
! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/8/1998 15:25'!
smallSqrtTable
	| theTable |
	self inline: false.
	self returnTypeC:'int *'.
	self var: #theTable declareC:'static int theTable[32] = 
	{0, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6}'.
	^theTable! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/8/1998 20:57'!
squaredLengthOf: deltaX with: deltaY
	^(deltaX * deltaX) + (deltaY * deltaY)! !

!BalloonEngineBase methodsFor: 'other' stamp: 'ar 11/25/1998 02:22'!
stopBecauseOf: stopReason
	self stopReasonPut: stopReason.
	engineStopped _ true.! !


!BalloonEngineBase methodsFor: 'private' stamp: 'ar 5/16/2000 17:09'!
copyBitsFrom: x0 to: x1 at: yValue
	copyBitsFn = 0 ifTrue:[
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse:[^false].
	].
	^self cCode:' ((int (*) (int, int, int)) copyBitsFn)(x0, x1, yValue)'! !

!BalloonEngineBase methodsFor: 'private' stamp: 'ar 5/13/2000 14:55'!
errorWrongIndex
	"Ignore dispatch errors when translating to C
	(since we have no entry point for #error in the VM proxy)"
	self cCode:'' inSmalltalk:[self error:'BalloonEngine: Fatal dispatch error']! !

!BalloonEngineBase methodsFor: 'private' stamp: 'ar 5/16/2000 17:08'!
loadBitBltFrom: bbObj
	loadBBFn = 0 ifTrue:[
		"We need copyBits here so try to load it implicitly"
		self initialiseModule ifFalse:[^false].
	].
	^self cCode: '((int (*) (int))loadBBFn)(bbObj)'! !

!BalloonEngineBase methodsFor: 'private' stamp: 'ar 10/28/1998 20:58'!
makeUnsignedFrom: someIntegerValue
	^someIntegerValue! !


!BalloonEngineBase methodsFor: 'initialize-release' stamp: 'ar 5/16/2000 19:56'!
initialiseModule
	self export: true.
	loadBBFn _ interpreterProxy ioLoadFunction: 'loadBitBltFrom' From: bbPluginName.
	copyBitsFn _ interpreterProxy ioLoadFunction: 'copyBitsFromtoat' From: bbPluginName.
	^(loadBBFn ~= 0 and:[copyBitsFn ~= 0])! !

!BalloonEngineBase methodsFor: 'initialize-release' stamp: 'ar 5/16/2000 19:57'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	self export: true.
	self var: #aModuleName type: 'char *'.
	(aModuleName strcmp: bbPluginName) = 0 ifTrue:[
		"BitBlt just shut down. How nasty."
		loadBBFn _ 0.
		copyBitsFn _ 0.
	].! !

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

BalloonEngineBase class
	instanceVariableNames: ''!

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 5/16/2000 20:03'!
declareCVarsIn: cg
	"Buffers"
	cg var: #workBuffer type: #'int*'.
	cg var: #objBuffer type: #'int*'.
	cg var: #getBuffer type: #'int*'.
	cg var: #aetBuffer type: #'int*'.
	cg var: #spanBuffer type: #'unsigned int*'.
	cg var: #edgeTransform declareC: 'float edgeTransform[6]'.
	cg var: #doProfileStats declareC: 'int doProfileStats = 0'.
	cg var: 'bbPluginName' declareC:'char bbPluginName[256] = "BitBltPlugin"'.
! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/7/1998 22:26'!
initialize
	"BalloonEngineBase initialize"
	"BalloonEnginePlugin translateDoInlining: true."
	EdgeInitTable _ self initializeEdgeInitTable.
	EdgeStepTable _ self initializeEdgeStepTable.
	WideLineWidthTable _ self initializeWideLineWidthTable.
	WideLineFillTable _ self initializeWideLineFillTable.
	FillTable _ self initializeFillTable.! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 21:52'!
initializeEdgeInitTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex

		stepToFirstLine
		stepToFirstWideLine
		stepToFirstBezier
		stepToFirstWideBezier
	)! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 21:52'!
initializeEdgeStepTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex
		errorWrongIndex

		stepToNextLine
		stepToNextWideLine
		stepToNextBezier
		stepToNextWideBezier
	)! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/25/1998 19:46'!
initializeFillTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex "Type zero - undefined"
		errorWrongIndex "Type one - external fill"

		fillLinearGradient "Linear gradient fill"
		fillRadialGradient "Radial gradient fill"

		fillBitmapSpan	"Clipped bitmap fill"
		fillBitmapSpan	"Repeated bitmap fill"
	)! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 23:03'!
initializeWideLineFillTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		returnWideLineFill
		returnWideBezierFill
	)! !

!BalloonEngineBase class methodsFor: 'class initialization' stamp: 'ar 11/4/1998 23:03'!
initializeWideLineWidthTable
	"BalloonEngineBase initialize"
	^#(
		errorWrongIndex
		errorWrongIndex
		returnWideLineWidth
		returnWideBezierWidth
	)! !


!BalloonEngineBase class methodsFor: 'accessing' stamp: 'ar 5/11/2000 23:48'!
moduleName
	^'B2DPlugin'! !

!BalloonEngineBase class methodsFor: 'accessing' stamp: 'ar 11/11/1998 21:56'!
simulatorClass
	^BalloonEngineSimulation! !


!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:33'!
a1EngineOutline
	"The following is a brief outline on how the engine works.

	In general, we're using a pretty straight-forward active edge approach, e.g., 
	we classify all edges into three different states:
		a) Waiting for processing
		b) Active (e.g., being processed)
		c) Finished
	Before the engine starts all edges are sorted by their y-value in a so-called
	'global edge table' (furthermore referred to as GET) and processed in top 
	to bottom order (the edges are also sorted by x-value but this is only for 
	simplifying the insertion when adding edges).

	Then, we start at the first visible scan line and execute the following steps:

	1) Move all edges starting at the current scan line from state a) to state b)

	This step requires the GET to be sorted so that we only need to check
	the first edges of the GET. After the initial state of the edge (e.g., it's current
	pixel value and data required for incremental updates) the edges are then 
	inserted in the 'active edge table' (called AET). The sort order in the AET is 
	defined by the pixel position of each edge at the current scan line and thus 
	edges are kept in increasing x-order.

	This step does occur for every edge only once and is therefore not the most
	time-critical part of the approach.

	2) Draw the current scan line

	This step includes two sub-parts. In the first part, the scan line is assembled.
	This involves walking through the AET and drawing the pixels between
	each two neighbour edges. Since each edge can have two associated fills
	(a 'left' and a 'right' fill) we need to make sure that edges falling on the
	same pixel position do not affect the painted image. This issue is discussed
	in the aetScanningProblems documentation.

	Wide edges (e.g., edges having an associated width) are also handled during
	this step. Wide edges are always preferred over interior fills - this ensures
	that the outline of an object cannot be overdrawn by any interior fill of
	a shape that ends very close to the edge (for more information see wideEdges 
	documentation).

	After the scan is assembled it is blitted to the screen. This only happens all
	'aaLevel' scan lines (for further information see the antiAliasing documentation).

	This second step is done at each scan line in the image, and is usually the most
	time-critical part.

	3) Update all currently active edges

	Updating the active edges basically means either to remove the edge from the AET
	(if it is at the end y value) or incrementally computing the pixel value for the
	next scan line. Based on the information gathered in the first step, this part
	should be executed as fast as possible - it happens for each edge in the AET
	at each scan line and may be the bottleneck if many edges are involved in
	the drawing operations (see the TODO list; part of it probably deals with the
	issue).

"
	^self error:'Comment only'! !

!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:55'!
a2AntiAliasing
	"The engine currently used a very simple, but efficient anti-aliasing scheme. It is based on a square unweighted filter of size 1, 2, or 4 resulting in three levels of anti-aliasing:

	* No anti-aliasing (filter size 1)
	This simply draws each pixel 'as is' on the screen

	* Slight anti-aliasing (filter size 2)
	Doubles the rasterization size in each direction and assembles the pixel value as the medium of the four sub-pixels falling into the full pixel

	* Full anti-aliasing (filter size 4)
	Quadruples the rasterization in each direction and assembles the pixel value as the medium of the sixteen sub-pixels falling into the full pixel


The reason for using these three AA levels is simply efficiency of computing. Since the above filters (1x1, 2x2, 4x4) have all power of two elements (1, 4, and 16) we can compute the weighted sum of the final pixel by computing

	destColor _ destColor + (srcColor // subPixels)

And, since we're only working on 32bit destination buffer we do not need to compute the components of each color separately but can neatly put the entire color into a single formula:

	destPixel32 _ destPixel32 + ((srcPixel32 bitAnd: aaMask) >> aaShift).

with aaMask = 16rFFFFFFFF for aaLevel = 1, aaMask = 16rFCFCFCFC for aaLevel = 2, aaMask = 16rF0F0F0F0 for aaLevel = 4 and aaShift = 0, 2, or 4 for the different levels. However, while the above is efficient to compute, it also drops accuracy. So, for the 4x4 anti-aliasing we're effectively only using the high 4 bits of each color component. While is generally not a problem (we add 16 sub-pixels into this value) there is a simple arithmetic difficulty because the above cannot fill the entire range of values, e.g.,

	16 * (255 // 16) = 16 * 15 = 240

and not 255 as expected. We solve this problem by replicating the top n (n=0, 2, 4) bits of each component as the low bits in an adjustment step before blitting to scan line to the screen. This has the nice effect that a zero pixel value (e.g., transparent) will remain zero, a white pixel (as computed above) will result in a value of 255 for each component (defining opaque white) and each color inbetween linearly mapped between 0 and 255. 

"
	^self error:'Comment only'! !

!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:35'!
a3RasterizationRules


	^self error:'Comment only'! !

!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:35'!
a4WideEdges! !

!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/7/1998 03:36'!
a5AETScanningProblems
	"Due to having two fill entries (one left and one right) there can be problems while scanning the active edge table. In general, the AET should look like the following (ri - regions, ei - edges, fi - fills):

			|				\				|
	r1		|		r2		 \		r3		|		r4
			|				  \				|
			e1				 e2				e3		

	with:
		f(r1) = fLeft(e1) = 0				(empty fill, denoted -)
		f(r2) = fRight(e1) = fLeft(e2)		(denoted x)
		f(r3) = fRight(e2) = fLeft(e3)	(denoted o)
		f(r4) = fRight(e3) = 0

	However, due to integer arithmetic used during computations the AET may look like the following:
			X
			\|						|
			 | \						|
			 |   \					|
	r1		 | r2 \			r3		|		r4
			 |	   \					|
			e1		e2				e3		

	In this case, the starting point of e1 and e2 have the same x value at the first scan line but e2 has been sorted before e1 (Note: This can happen in *many* cases - the above is just a very simple example). Given the above outlined fill relations we have a problem. So, for instance, using the left/right fills as defined by the edges would lead to the effect that in the first scan line region r3 is actually filled with the right fill of e1 while it should actually be filled with the right fill of e2. This leads to noticable artifacts in the image and increasing resolution does not help.

	What we do here is defining an arbitrary sort order between fills (you can think of it as a depth value but the only thing that matters is that you can order the fills by this number and that the empty fill is always sorted at the end), and toggle the fills between an 'active' and an 'inactive' state at each edge. This is done as follows:
	For each edge ei in the AET do:
		* if fLeft(ei) isActive then removeActive(fLeft(ei)) else addActive(fLeft(ei))
		* if fRight(ei) isActive then removeActive(fRight(ei)) else addActive(fRight(ei))
		* draw the span from ei to ei+1 with currentActive
	where addActive adds the fill to the list of currently active fills, removeActive() removes the fill from the active list and currentActive returns the fill AS DEFINED BY THE SORT ORDER from the list of active fills. Note that this does not change anything in the first example above because the list will only contain one entry (besides the empty fill). In the second case however, it will lead to the following sequence:

	* toggle fLeft(e2) = f(r2) = 'x'
		- makes fLeft(e2) active
		- activeList = 'x'
	* toggle fRight(e2) = f(r3) = 'o'
		- makes fRight(e2) active
		- activeList = 'xo'
	* draw span from e2 to e1
		Depending on the sort order between 'x' and 'o' the region will be drawn with either one of the fills. It is significant to note here that the occurence of such a problem is generally only *very* few pixels large (in the above example zero pixels) and will therefore not be visually noticable. In any case, there is a unique decision for the fill to use here and that is what we need if the problem did not happen accidentally (e.g., someone has manually changed one fill of an edge but not the fill of the opposite edge).

	* toggle fLeft(e1) = f(r1) = '-'
		- makes fLeft(r1) visible
		- activeList = 'xo-'
		[Note: empty fills are a special case. 
		They can be ignored since they sort last
		and the activeList can return the empty
		fill if it is itself empty].
	* toggle fRight(e1) = f(r2) = 'x'
		- makes fRight(e1) invisible
		- activeList = 'o-'
	* draw span from e2 to e3
		Since the active list contains (besides the empty fill) only one fill value this will be used. Fortunately, this is the correct fill because it is the fill we had initially defined for the region r2.

An interesting side effect of the above is that there is no such notion as a 'left' or 'right' fill anymore. Another (not-so-nice) side effect is that the entire AET has to be scanned from the beginning even if only the last few edges actually affect the visible region.

PS. I need to find a way of clipping the edges for this. More on it later...
"
	^self error:'Comment only'! !

!BalloonEngineBase class methodsFor: 'documentation' stamp: 'ar 11/8/1998 00:06'!
a6StuffTODO
	"This is an unordered list of things to do:

BalloonEnginePlugin>>stepToFirstBezierIn:at:
	1)	Check if reducing maxSteps from 2*deltaY to deltaY 
		brings a *significant* performance improvement.
		In theory this should make for double step performance
		but will cost in quality. Might be that the AA stuff will
		compensate for this - but I'm not really sure.

BalloonEngineBase>>dispatchOn:in:
	1)	Check what dispatches cost most and must be inlined
		by an #inlinedDispatchOn:in: Probably this will be
		stepping and eventually wide line stuff but we'll see.

BalloonEngineBase
	1)	Check which variables should become inst vars, if any.
		This will remove an indirection during memory access
		and might allow a couple of optimizations by the C compiler.

Anti-Aliasing:
	1)	Check if we can use a weighted 3x3 filter function of the form
				1	2	1
				2	4	2
				1	2	1
		Which should be *extremely* nice for fonts (it's sharpening
		edges). The good thing about the above is that it sums up to
		16 (as in the 4x4 case) but I don't know how to keep a history
		without needing two extra scan lines.

	2)	Check if we can - somehow - integrate more general filters.

	3) Unroll the loops during AA so we can copy and mask aaLevel pixels
	   in each step between start and end. This should speed up filling
	   by a factor of 2-4 (in particular for difficult stuff like radial gradients).

Clipping
	1)	Find a way of clipping edges left of the clip rectangle
		or at least ignoring most of them after the first scan line.
		The AET scanning problems discuss the issue but it should be
		possible to keep the color list between spans (if not empty)
		and speed up drawing at the very right (such as in the
		Winnie Pooh example where a lot of stuff is between the
		left border and the clipping rect.

	2)	Check if we can determine empty states of the color list and
		an edge that is longer than anything left of it. This should
		work in theory but might be relatively expensive to compute.

"
	^self error:'Comment only'! !



!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/24/1998 23:54'!
initEdgeConstants: dict
	"Initialize the edge constants"
	self initFromSpecArray:
	#(
		"Edge primitive types"
		(GEPrimitiveEdge 2)			"External edge - not handled by the GE"
		(GEPrimitiveWideEdge 3)		"Wide external edge"
		(GEPrimitiveLine 4)			"Straight line"
		(GEPrimitiveWideLine 5)		"Wide line"
		(GEPrimitiveBezier 6)		"Quadratic bezier curve"
		(GEPrimitiveWideBezier 7)	"Wide bezier curve"

		"Special flags"
		(GEPrimitiveWide 16r01)		"Flag determining a wide primitive"
		(GEPrimitiveWideMask 16rFE)	"Mask for clearing the wide flag"
		(GEEdgeFillsInvalid 16r10000) "Flag determining if left/right fills of an edge are invalid"
		(GEEdgeClipFlag 16r20000)	"Flag determining if this is a clip edge"

		"General edge state constants"
		(GEXValue 4)					"Current raster x"
		(GEYValue 5)					"Current raster y"
		(GEZValue 6)					"Current raster z"
		(GENumLines 7)					"Number of scan lines remaining"
		(GEFillIndexLeft 8)				"Left fill index"
		(GEFillIndexRight 9)				"Right fill index"
		(GEBaseEdgeSize 10)				"Basic size of each edge"

		"General fill state constants"
		(GEBaseFillSize 4)				"Basic size of each fill"

		"General Line state constants"
		(GLXDirection 10)				"Direction of edge (1: left-to-right; -1: right-to-left)"
		(GLYDirection 11)				"Direction of edge (1: top-to-bottom; -1: bottom-to-top)"
		(GLXIncrement 12)				"Increment at each scan line"
		(GLError 13)						"Current error"
		(GLErrorAdjUp 14)				"Error to add at each scan line"
		(GLErrorAdjDown 15)				"Error to subtract on roll-over"
			"Note: The following entries are only needed before the incremental
			state is computed. They are therefore aliased to the error values above"
		(GLEndX 14)						"End X of line"
		(GLEndY 15)						"End Y of line"
		(GLBaseSize 16)					"Basic size of each line"

		"Additional stuff for wide lines"
		(GLWideFill 16)					"Current fill of line"
		(GLWideWidth 17)				"Current width of line"
		(GLWideEntry 18)				"Initial steps"
		(GLWideExit 19)					"Final steps"
		(GLWideExtent 20)				"Target width"
		(GLWideSize 21)					"Size of wide lines"

		"General Bezier state constants"
		(GBUpdateData 10)				"Incremental update data for beziers"
			(GBUpdateX 0)				"Last computed X value (24.8)"
			(GBUpdateY 1)				"Last computed Y value (24.8)"
			(GBUpdateDX 2)				"Delta X forward difference step (8.24)"
			(GBUpdateDY 3)				"Delta Y forward difference step (8.24)"
			(GBUpdateDDX 4)				"Delta DX forward difference step (8.24)"
			(GBUpdateDDY 5)				"Delta DY forward difference step (8.24)"
		"Note: The following four entries are only needed before the incremental
			state is computed. They are therefore aliased to the incremental values above"
		(GBViaX 12)						"via x"
		(GBViaY 13)						"via y"
		(GBEndX 14)						"end x"
		(GBEndY 15)						"end y"
		(GBBaseSize 16)					"Basic size of each bezier.
										Note: MUST be greater or equal to the size of lines"
		"Additional stuff for wide beziers"
		(GBWideFill 16)					"Current fill of line"
		(GBWideWidth 17)				"Current width of line"
		(GBWideEntry 18)				"Initial steps"
		(GBWideExit 19)					"Final steps"
		(GBWideExtent 20)				"Target extent"
		(GBFinalX 21)					"Final X value"
		(GBWideUpdateData 22)	"Update data for second curve"
		(GBWideSize 28)					"Size of wide beziers"

	) in: dict.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/27/1998 14:19'!
initFillConstants: dict
	"Initialize the fill constants"
	"BalloonEngineBase initPool"
	self initFromSpecArray:
	#(
		"Fill primitive types"
		(GEPrimitiveFill 16r100)
		(GEPrimitiveLinearGradientFill 16r200)
		(GEPrimitiveRadialGradientFill 16r300)
		(GEPrimitiveClippedBitmapFill 16r400)
		(GEPrimitiveRepeatedBitmapFill 16r500)

		"General fill state constants"
		(GEBaseFillSize 4)				"Basic size of each fill"

		"Oriented fill constants"
		(GFOriginX 4)				"X origin of fill"
		(GFOriginY 5)				"Y origin of fill"
		(GFDirectionX 6)				"X direction of fill"
		(GFDirectionY 7)				"Y direction of fill"
		(GFNormalX 8)				"X normal of fill"
		(GFNormalY 9)				"Y normal of fill"

		"Gradient fill constants"
		(GFRampLength 10)			"Length of following color ramp"
		(GFRampOffset 12)			"Offset of first ramp entry"
		(GGBaseSize 12)

		"Bitmap fill constants"
		(GBBitmapWidth 10)			"Width of bitmap"
		(GBBitmapHeight 11)			"Height of bitmap"
		(GBBitmapDepth 12)			"Depth of bitmap"
		(GBBitmapSize 13)			"Size of bitmap words"
		(GBBitmapRaster 14)			"Size of raster line"
		(GBColormapSize 15)			"Size of colormap, if any"
		(GBTileFlag 16)				"True if the bitmap is tiled"
		(GBColormapOffset 18)		"Offset of colormap, if any"
		(GBMBaseSize 18)			"Basic size of bitmap fill"
	) in: dict.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:26'!
initFromSpecArray: specArray in: aDictionary
	specArray do:[:spec|
		self initPoolVariable: spec first value: spec last in: aDictionary.
	]! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initPool
	"BalloonEngineBase initPool"
	(Smalltalk includesKey: #BalloonEngineConstants) ifFalse:[
		Smalltalk declare: #BalloonEngineConstants from: Undeclared.
	].
	(Smalltalk at: #BalloonEngineConstants) isNil ifTrue:[
		(Smalltalk associationAt: #BalloonEngineConstants) value: Dictionary new.
	].
	self initPool: (Smalltalk at: #BalloonEngineConstants).! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initPool: aDictionary
	self initStateConstants: aDictionary.
	self initWorkBufferConstants: aDictionary.
	self initPrimitiveConstants: aDictionary.
	self initEdgeConstants: aDictionary.
	self initFillConstants: aDictionary.
	self initializeInstVarNames: BalloonEngine in: aDictionary prefixedBy: 'BE'.
	self initializeInstVarNames: BalloonEdgeData in: aDictionary prefixedBy: 'ET'.
	self initializeInstVarNames: BalloonFillData in: aDictionary prefixedBy: 'FT'.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initPoolFull	"BalloonEngineBase initPoolFull"
	"Move old stuff to Undeclared and re-initialize the receiver"
	BalloonEngineConstants associationsDo:[:assoc|
		Undeclared declare: assoc key from: BalloonEngineConstants.
	].
	self initPool.
	Undeclared removeUnreferencedKeys.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initPoolVariable: token value: value in: aDictionary
	aDictionary declare: token from: Undeclared.
	(aDictionary associationAt: token) value: value.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initPrimitiveConstants: dict
	"Initialize the primitive constants"
	self initFromSpecArray:
	#(
		"Primitive type constants"
		(GEPrimitiveUnknown 0)
		(GEPrimitiveEdgeMask 16rFF)
		(GEPrimitiveFillMask 16rFF00)
		(GEPrimitiveTypeMask 16rFFFF)

		"General state constants (Note: could be compressed later)"
		(GEObjectType 0)				"Type of object"
		(GEObjectLength 1)			"Length of object"
		(GEObjectIndex 2)			"Index into external objects"
		(GEObjectUnused 3)			"Currently unused"

	) in: dict.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/25/1998 00:25'!
initStateConstants: dict
	"Initialize the state Constants"
	"BalloonEngineBase initPool"
	self initFromSpecArray:
	#(
		(GEStateUnlocked 0)			"Buffer is unlocked and can be modified as wanted"
		(GEStateAddingFromGET 1)	"Adding edges from the GET"
		(GEStateWaitingForEdge 2)	"Waiting for edges added to GET"
		(GEStateScanningAET 3)		"Scanning the active edge table"
		(GEStateWaitingForFill 4)		"Waiting for a fill to mix in during AET scan"
		(GEStateBlitBuffer 5)			"Blt the current scan line"
		(GEStateUpdateEdges 6)		"Update edges to next scan line"
		(GEStateWaitingChange 7)	"Waiting for a changed edge"
		(GEStateCompleted 8)			"Rendering completed"

		"Error constants"
		(GErrorNoMoreSpace 1)		"No more space in collection"
		(GErrorBadState 2)			"Tried to call a primitive while engine in bad state"
		(GErrorNeedFlush 3)			"Tried to call a primitive that requires flushing before"

		"Incremental error constants"
		(GErrorGETEntry 4)			"Unknown entry in GET"
		(GErrorFillEntry 5)			"Unknown FILL encountered"
		(GErrorAETEntry 6)			"Unknown entry in AET"
	) in: dict.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/25/1998 00:20'!
initWorkBufferConstants: dict
	"Initialize the work buffer constants"
	"BalloonEngineBase initPool"
	self initFromSpecArray:
	#(
		"General work buffer constants"
		(GWMagicNumber 16r416E6469)	"Magic number"
		(GWHeaderSize 128)				"Size of header"
		(GWMinimalSize 256)				"Minimal size of work buffer"

		"Header entries"
		(GWMagicIndex 0)				"Index of magic number"
		(GWSize 1)						"Size of full buffer"
		(GWState 2)						"Current state (e.g., locked or not)"
		"Buffer entries"
		(GWObjStart 8)					"objStart"
		(GWObjUsed 9)					"objUsed"
		(GWBufferTop 10)				"wbTop"
		(GWGETStart 11)					"getStart"
		(GWGETUsed 12)					"getUsed"
		(GWAETStart 13)					"aetStart"
		(GWAETUsed 14)					"aetUsed"

		"Transform entries"
		(GWHasEdgeTransform 16)		"True if we have an edge transformation"
		(GWHasColorTransform 17)		"True if we have a color transformation"
		(GWEdgeTransform 18)			"2x3 edge transformation"
		(GWColorTransform 24)			"8 word RGBA color transformation"

		"Span entries"
		(GWSpanStart 32)				"spStart"
		(GWSpanSize 33)					"spSize"
		(GWSpanEnd 34)					"spEnd"
		(GWSpanEndAA 35)				"spEndAA"

		"Bounds entries"
		(GWFillMinX 36)					"fillMinX"
		(GWFillMaxX 37)					"fillMaxX"
		(GWFillMinY 38)					"fillMinY"
		(GWFillMaxY 39)					"fillMaxY"
		(GWFillOffsetX 40)				"fillOffsetX"
		(GWFillOffsetY 41)				"fillOffsetY"
		(GWClipMinX 42)
		(GWClipMaxX 43)
		(GWClipMinY 44)
		(GWClipMaxY 45)
		(GWDestOffsetX 46)
		(GWDestOffsetY 47)

		"AA entries"
		(GWAALevel 48)					"aaLevel"
		(GWAAShift 49)					"aaShift"
		(GWAAColorShift 50)				"aaColorShift"
		(GWAAColorMask 51)				"aaColorMask"
		(GWAAScanMask 52)				"aaScanMask"
		(GWAAHalfPixel 53)				"aaHalfPixel"

		"Misc entries"
		(GWNeedsFlush 63)				"True if the engine may need a flush"
		(GWStopReason 64)				"stopReason"
		(GWLastExportedEdge 65)			"last exported edge"
		(GWLastExportedFill 66)			"last exported fill"
		(GWLastExportedLeftX 67)			"last exported leftX"
		(GWLastExportedRightX 68)		"last exported rightX"
		(GWClearSpanBuffer 69)			"Do we have to clear the span buffer?"
		(GWPointListFirst 70)				"First point list in buffer"

		(GWPoint1 80)
		(GWPoint2 82)
		(GWPoint3 84)
		(GWPoint4 86)

		(GWCurrentY 88)

		"Profile stats"
		(GWTimeInitializing 90)
		(GWCountInitializing 91)
		(GWTimeFinishTest 92)
		(GWCountFinishTest 93)
		(GWTimeNextGETEntry 94)
		(GWCountNextGETEntry 95)
		(GWTimeAddAETEntry 96)
		(GWCountAddAETEntry 97)
		(GWTimeNextFillEntry 98)
		(GWCountNextFillEntry 99)
		(GWTimeMergeFill 100)
		(GWCountMergeFill 101)
		(GWTimeDisplaySpan 102)
		(GWCountDisplaySpan 103)
		(GWTimeNextAETEntry 104)
		(GWCountNextAETEntry 105)
		(GWTimeChangeAETEntry 106)
		(GWCountChangeAETEntry 107)

		"Bezier stats"
		(GWBezierMonotonSubdivisions 108) 	"# of subdivision due to non-monoton beziers"
		(GWBezierHeightSubdivisions 109)		"# of subdivisions due to excessive height"
		(GWBezierOverflowSubdivisions 110)	"# of subdivisions due to possible int overflow"
		(GWBezierLineConversions 111)		"# of beziers converted to lines"

		(GWHasClipShapes 112)		"True if the engine contains clip shapes"
		(GWCurrentZ 113)			"Current z value of primitives"
	) in: dict.! !

!BalloonEngineBase class methodsFor: 'pool initialization' stamp: 'ar 11/11/1998 22:27'!
initializeInstVarNames: aClass in: aDictionary prefixedBy: aString

	| token value |
	aClass instVarNames doWithIndex:[:instVarName :index|
		token _ (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol.
		value _ index - 1.
		aDictionary declare: token from: Undeclared.
		(aDictionary associationAt: token) value: value.
	].
	token _ (aString, aClass name,'Size') asSymbol.
	aDictionary declare:  token from: Undeclared.
	(aDictionary associationAt: token) value: aClass instSize.! !
BalloonEngineBase subclass: #BalloonEnginePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:07'!
primitiveAddBezier
	| leftFill rightFill viaOop endOop startOop nSegments |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	rightFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	viaOop _ interpreterProxy stackObjectValue: 2.
	endOop _ interpreterProxy stackObjectValue: 3.
	startOop _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: leftFill) and:[self isFillOkay: rightFill])
			ifFalse:[^interpreterProxy primitiveFail].

	"Do a quick check if the fillIndices are equal - if so, just ignore it"
	leftFill = rightFill & false ifTrue:[
		^interpreterProxy pop: 6. "Leave rcvr on stack"
	].


	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: viaOop.
	self loadPoint: self point3Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	self transformPoints: 3.

	nSegments _ self loadAndSubdivideBezierFrom: self point1Get 
						via: self point2Get 
						to: self point3Get 
						isWide: false.
	self needAvailableSpace: nSegments * GBBaseSize.
	engineStopped ifFalse:[
		leftFill _ self transformColor: leftFill.
		rightFill _ self transformColor: rightFill].
	engineStopped ifFalse:[
		self loadWideBezier: 0 lineFill: 0 leftFill: leftFill rightFill: rightFill n: nSegments.
	].
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		self wbStackClear.
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:08'!
primitiveAddBezierShape
	| points lineFill lineWidth fillIndex length isArray segSize nSegments |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	lineFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	lineWidth _ interpreterProxy stackIntegerValue: 1.
	fillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	nSegments _ interpreterProxy stackIntegerValue: 3.
	points _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the points look okay"
	length _ interpreterProxy slotSizeOf: points.
	(interpreterProxy isWords: points) ifTrue:[
		isArray _ false.
		"Either PointArray or ShortPointArray"
		(length = (nSegments * 3) or:[length = (nSegments * 6)])
			ifFalse:[^interpreterProxy primitiveFail].
	] ifFalse:["Must be Array of points"
		(interpreterProxy fetchClassOf: points) = interpreterProxy classArray
			ifFalse:[^interpreterProxy primitiveFail].
		length = (nSegments * 3)
			ifFalse:[^interpreterProxy primitiveFail].
		isArray _ true.
	].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nPoints boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[segSize _ GLBaseSize]
		ifFalse:[segSize _ GLWideSize].
	(self needAvailableSpace: segSize * nSegments)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check the fills"
	((self isFillOkay: lineFill) and:[self isFillOkay: fillIndex])
		ifFalse:[^interpreterProxy primitiveFail]. 

	"Transform colors"
	lineFill _ self transformColor: lineFill.
	fillIndex _ self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if have anything at all to do"
	((lineFill = 0 or:[lineWidth = 0]) and:[fillIndex = 0])
		ifTrue:[^interpreterProxy pop: 5].

	"Transform the lineWidth"
	lineWidth = 0 ifFalse:[
		lineWidth _ self transformWidth: lineWidth.
		lineWidth < 1 ifTrue:[lineWidth _ 1]].

	"And load the actual shape"
	isArray ifTrue:[
		self loadArrayShape: points nSegments: nSegments
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill.
	] ifFalse:[
		self loadShape: (interpreterProxy firstIndexableField: points) nSegments: nSegments
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
			pointsShort: (nSegments * 3 = length)].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:10'!
primitiveAddBitmapFill

	| nrmOop dirOop originOop tileFlag fill xIndex cmOop formOop |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 7 
		ifFalse:[^interpreterProxy primitiveFail].

	xIndex _ interpreterProxy stackIntegerValue: 0.
	xIndex <= 0 ifTrue:[^interpreterProxy primitiveFail].
	nrmOop _ interpreterProxy stackObjectValue: 1.
	dirOop _ interpreterProxy stackObjectValue: 2.
	originOop _ interpreterProxy stackObjectValue: 3.
	tileFlag _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 4).
	tileFlag ifTrue:[tileFlag _ 1] ifFalse:[tileFlag _ 0].
	cmOop _ interpreterProxy stackObjectValue: 5.
	formOop _ interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 7) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadPoint: self point1Get from: originOop.
	self loadPoint: self point2Get from: dirOop.
	self loadPoint: self point3Get from: nrmOop.
	interpreterProxy failed ifTrue:[^0].

	fill _ self loadBitmapFill: formOop 
				colormap: cmOop
				tile: tileFlag
				from: self point1Get 
				along: self point2Get 
				normal: self point3Get 
				xIndex: xIndex-1.
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 8.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: fill).
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:06'!
primitiveAddCompressedShape
	| fillIndexList lineFills lineWidths rightFills leftFills nSegments points pointsShort |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 7 
		ifFalse:[^interpreterProxy primitiveFail].

	fillIndexList _ interpreterProxy stackObjectValue: 0.
	lineFills _ interpreterProxy stackObjectValue: 1.
	lineWidths _ interpreterProxy stackObjectValue: 2.
	rightFills _ interpreterProxy stackObjectValue: 3.
	leftFills _ interpreterProxy stackObjectValue: 4.
	nSegments _ interpreterProxy stackIntegerValue: 5.
	points _ interpreterProxy stackObjectValue: 6.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 7) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the compressed shape is okay"
	(self checkCompressedShape: points 
			segments: nSegments 
			leftFills: leftFills 
			rightFills: rightFills 
			lineWidths: lineWidths 
			lineFills: lineFills 
			fillIndexList: fillIndexList) ifFalse:[^interpreterProxy primitiveFail].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nSegments boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(self needAvailableSpace: (GBBaseSize max: GLBaseSize) * nSegments)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if the points are short"
	pointsShort _ (interpreterProxy slotSizeOf: points) = (nSegments * 3).

	"Then actually load the compressed shape"
	self loadCompressedShape: (interpreterProxy firstIndexableField: points)
			segments: nSegments 
			leftFills: (interpreterProxy firstIndexableField: leftFills)
			rightFills: (interpreterProxy firstIndexableField: rightFills)
			lineWidths: (interpreterProxy firstIndexableField: lineWidths)
			lineFills: (interpreterProxy firstIndexableField: lineFills)
			fillIndexList: (interpreterProxy firstIndexableField: fillIndexList)
			pointShort: pointsShort.

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 7. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:13'!
primitiveAddGradientFill

	| isRadial nrmOop dirOop originOop rampOop fill |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	isRadial _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	nrmOop _ interpreterProxy stackValue: 1.
	dirOop _ interpreterProxy stackValue: 2.
	originOop _ interpreterProxy stackValue: 3.
	rampOop _ interpreterProxy stackValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	self loadPoint: self point1Get from: originOop.
	self loadPoint: self point2Get from: dirOop.
	self loadPoint: self point3Get from: nrmOop.
	interpreterProxy failed ifTrue:[^0].

	fill _ self loadGradientFill: rampOop 
				from: self point1Get 
				along: self point2Get 
				normal: self point3Get 
				isRadial: isRadial.
	engineStopped ifTrue:[
		"Make sure the stack is okay"
		^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 6.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: fill).
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:08'!
primitiveAddLine
	| leftFill rightFill endOop startOop |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].

	rightFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	leftFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
	endOop _ interpreterProxy stackObjectValue: 2.
	startOop _ interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 4) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: leftFill) and:[self isFillOkay: rightFill])
			ifFalse:[^interpreterProxy primitiveFail].

	"Load the points"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	"Transform points"
	self transformPoints: 2.

	"Transform colors"
	leftFill _ self transformColor: leftFill.
	rightFill _ self transformColor: rightFill.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Load line"
	self loadWideLine: 0 from: self point1Get to: self point2Get 
		lineFill: 0 leftFill: leftFill rightFill: rightFill.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self storeEngineStateInto: engine.
		interpreterProxy pop: 4. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:12'!
primitiveAddOval
	| fillIndex borderWidth borderIndex endOop startOop |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	borderIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	borderWidth _ interpreterProxy stackIntegerValue: 1.
	fillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	endOop _ interpreterProxy stackObjectValue: 3.
	startOop _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: borderIndex) and:[self isFillOkay: fillIndex])
			ifFalse:[^interpreterProxy primitiveFail].

	"Transform colors"
	fillIndex _ self transformColor: fillIndex.
	borderIndex _ self transformColor: borderIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if we have anything at all to do"
	(fillIndex = 0 and:[borderIndex = 0 or:[borderWidth <= 0]]) ifTrue:[
		^interpreterProxy pop: 5. "Leave rcvr on stack"
	].

	"Make sure we have some space"
	(self needAvailableSpace: (16 * GBBaseSize)) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if we need a border"
	(borderWidth > 0 and:[borderIndex ~= 0]) 
		ifTrue:[borderWidth _ self transformWidth: borderWidth]
		ifFalse:[borderWidth _ 0].


	"Load the rectangle points"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point2Get from: endOop.
	interpreterProxy failed ifTrue:[^0].

	self loadOval: borderWidth lineFill: borderIndex 
		leftFill: 0 rightFill: fillIndex.

	engineStopped ifTrue:[
		self wbStackClear.
		^interpreterProxy primitiveFail.
	].
	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:11'!
primitiveAddPolygon
	| points lineFill lineWidth fillIndex nPoints length isArray segSize |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	lineFill _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	lineWidth _ interpreterProxy stackIntegerValue: 1.
	fillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	nPoints _ interpreterProxy stackIntegerValue: 3.
	points _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"First, do a check if the points look okay"
	length _ interpreterProxy slotSizeOf: points.
	(interpreterProxy isWords: points) ifTrue:[
		isArray _ false.
		"Either PointArray or ShortPointArray"
		(length = nPoints or:[nPoints * 2 = length])
			ifFalse:[^interpreterProxy primitiveFail].
	] ifFalse:["Must be Array of points"
		(interpreterProxy fetchClassOf: points) = interpreterProxy classArray
			ifFalse:[^interpreterProxy primitiveFail].
		length = nPoints
			ifFalse:[^interpreterProxy primitiveFail].
		isArray _ true.
	].

	"Now check that we have some hope to have enough free space.
	Do this by assuming nPoints boundaries of maximum size,
	hoping that most of the fills will be colors and many boundaries
	will be line segments"

	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[segSize _ GLBaseSize]
		ifFalse:[segSize _ GLWideSize].
	(self needAvailableSpace: segSize * nPoints)
		ifFalse:[^interpreterProxy primitiveFail].

	"Check the fills"
	((self isFillOkay: lineFill) and:[self isFillOkay: fillIndex])
		ifFalse:[^interpreterProxy primitiveFail]. 

	"Transform colors"
	lineFill _ self transformColor: lineFill.
	fillIndex _ self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if have anything at all to do"
	((lineFill = 0 or:[lineWidth = 0]) and:[fillIndex = 0])
		ifTrue:[^interpreterProxy pop: 6].

	"Transform the lineWidth"
	lineWidth = 0 ifFalse:[lineWidth _ self transformWidth: lineWidth].

	"And load the actual polygon"
	isArray ifTrue:[
		self loadArrayPolygon: points nPoints: nPoints
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill
	] ifFalse:[
		self loadPolygon: (interpreterProxy firstIndexableField: points) nPoints: nPoints 
			fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
			pointsShort: (nPoints = length)].

	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:09'!
primitiveAddRect
	| fillIndex borderWidth borderIndex endOop startOop |
	self export: true.
	self inline: false.

	"Fail if we have the wrong number of arguments"
	interpreterProxy methodArgumentCount = 5 
		ifFalse:[^interpreterProxy primitiveFail].

	borderIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	borderWidth _ interpreterProxy stackIntegerValue: 1.
	fillIndex _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 2).
	endOop _ interpreterProxy stackObjectValue: 3.
	startOop _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].

	(self quickLoadEngineFrom: (interpreterProxy stackObjectValue: 5) requiredState: GEStateUnlocked)
		ifFalse:[^interpreterProxy primitiveFail].

	"Make sure the fills are okay"
	((self isFillOkay: borderIndex) and:[self isFillOkay: fillIndex])
			ifFalse:[^interpreterProxy primitiveFail].

	"Transform colors"
	borderIndex _ self transformColor: borderIndex.
	fillIndex _ self transformColor: fillIndex.
	engineStopped ifTrue:[^interpreterProxy primitiveFail].

	"Check if we have anything at all to do"
	(fillIndex = 0 and:[borderIndex = 0 or:[borderWidth = 0]]) ifTrue:[
		^interpreterProxy pop: 5. "Leave rcvr on stack"
	].

	"Make sure we have some space"
	(self needAvailableSpace: (4 * GLBaseSize)) 
		ifFalse:[^interpreterProxy primitiveFail].

	"Check if we need a border"
	(borderWidth > 0 and:[borderIndex ~= 0]) 
		ifTrue:[borderWidth _ self transformWidth: borderWidth]
		ifFalse:[borderWidth _ 0].

	"Load the rectangle"
	self loadPoint: self point1Get from: startOop.
	self loadPoint: self point3Get from: endOop.
	interpreterProxy failed ifTrue:[^nil].
	self point2Get at: 0 put: (self point3Get at: 0).
	self point2Get at: 1 put: (self point1Get at: 1).
	self point4Get at: 0 put: (self point1Get at: 0).
	self point4Get at: 1 put: (self point3Get at: 1).
	"Transform the points"
	self transformPoints: 4.

	self loadRectangle: borderWidth lineFill: borderIndex leftFill: 0 rightFill: fillIndex.

	interpreterProxy failed ifFalse:[
		self needsFlushPut: 1.
		self storeEngineStateInto: engine.
		interpreterProxy pop: 5. "Leave rcvr on stack"
	].! !

!BalloonEnginePlugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:06'!
primitiveGetBezierStats
	| statOop stats |
	self export: true.
	self inline: false.
	self var: #stats declareC:'int *stats'.

	interpreterProxy methodArgumentCount = 1
		ifFalse:[^interpreterProxy primitiveFail].

	statOop _ interpreterProxy stackObjectValue: 0.
	engine _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(self quickLoadEngineFrom: engine)
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: statOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: statOop) < 4
		ifTrue:[^interpreterProxy primitiveFail].
	stats _ interpreterProxy firstIndexableField: statOop.
	stats at: 0 put: (stats at: 0) + (workBuffer at: GWBezierMonotonSubdivisions).
	stats at: 1 put: (stats at: 1) + (workBuffer at: GWBezierHeightSubdivisions).
	stats at: 2 put: (stats at: 2) + (workBuffer at: GWBezierOverflowSubdivisions).
	stats at: 3 put: (stats at: 3) + (workBuffer at: GWBezierLineConversions).

	interpreterProxy pop: 1. "Leave rcvr on stack"! !


!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndXOf: line

	^self obj: line at: GLEndX! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndXOf: line put: value

	^self obj: line at: GLEndX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndYOf: line

	^self obj: line at: GLEndY! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineEndYOf: line put: value

	^self obj: line at: GLEndY put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineErrorAdjDownOf: line

	^self obj: line at: GLErrorAdjDown! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:07'!
lineErrorAdjDownOf: line put: value

	^self obj: line at: GLErrorAdjDown put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorAdjUpOf: line

	^self obj: line at: GLErrorAdjUp! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorAdjUpOf: line put: value

	^self obj: line at: GLErrorAdjUp put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorOf: line

	^self obj: line at: GLError! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineErrorOf: line put: value

	^self obj: line at: GLError put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:08'!
lineXDirectionOf: line

	^self obj: line at: GLXDirection! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXDirectionOf: line put: value

	^self obj: line at: GLXDirection put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXIncrementOf: line

	^self obj: line at: GLXIncrement! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineXIncrementOf: line put: value

	^self obj: line at: GLXIncrement put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineYDirectionOf: line

	^self obj: line at: GLYDirection! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
lineYDirectionOf: line put: value

	^self obj: line at: GLYDirection put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:09'!
wideLineEntryOf: line

	^self obj: line at: GLWideEntry! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineEntryOf: line put: value

	^self obj: line at: GLWideEntry put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExitOf: line

	^self obj: line at: GLWideExit! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExitOf: line put: value

	^self obj: line at: GLWideExit put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExtentOf: line

	^self obj: line at: GLWideExtent! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineExtentOf: line put: value

	^self obj: line at: GLWideExtent put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:10'!
wideLineFillOf: line

	^self obj: line at: GLWideFill! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineFillOf: line put: value

	^self obj: line at: GLWideFill put: value! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineWidthOf: line

	^self obj: line at: GLWideWidth! !

!BalloonEnginePlugin methodsFor: 'accessing lines' stamp: 'ar 11/24/1998 22:11'!
wideLineWidthOf: line put: value

	^self obj: line at: GLWideWidth put: value! !


!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
bezierEndXOf: bezier

	^self obj: bezier at: GBEndX! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierEndXOf: bezier put: value

	^self obj: bezier at: GBEndX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierEndYOf: bezier

	^self obj: bezier at: GBEndY! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierEndYOf: bezier put: value

	^self obj: bezier at: GBEndY put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:19'!
bezierFinalXOf: bezier

	^self obj: bezier at: GBFinalX! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierFinalXOf: bezier put: value

	^self obj: bezier at: GBFinalX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:24'!
bezierUpdateDataOf: bezier
	self returnTypeC: 'int *'.

	^objBuffer + bezier + GBUpdateData! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
bezierViaXOf: bezier

	^self obj: bezier at: GBViaX! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierViaXOf: bezier put: value

	^self obj: bezier at: GBViaX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
bezierViaYOf: bezier

	^self obj: bezier at: GBViaY! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
bezierViaYOf: bezier put: value

	^self obj: bezier at: GBViaY put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndX: index
	^self wbStackValue: self wbStackSize - index + 4! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndX: index put: value
	^self wbStackValue: self wbStackSize - index + 4 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndY: index
	^self wbStackValue: self wbStackSize - index + 5! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzEndY: index put: value
	^self wbStackValue: self wbStackSize - index + 5 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartX: index
	^self wbStackValue: self wbStackSize - index + 0! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartX: index put: value
	^self wbStackValue: self wbStackSize - index + 0 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzStartY: index
	^self wbStackValue: self wbStackSize - index + 1! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzStartY: index put: value
	^self wbStackValue: self wbStackSize - index + 1 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzViaX: index
	^self wbStackValue: self wbStackSize - index + 2! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzViaX: index put: value
	^self wbStackValue: self wbStackSize - index + 2 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:53'!
bzViaY: index
	^self wbStackValue: self wbStackSize - index + 3! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 10/30/1998 20:54'!
bzViaY: index put: value
	^self wbStackValue: self wbStackSize - index + 3 put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierEntryOf: line

	^self obj: line at: GBWideEntry! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierEntryOf: line put: value

	^self obj: line at: GBWideEntry put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierExitOf: line

	^self obj: line at: GBWideExit! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:18'!
wideBezierExitOf: line put: value

	^self obj: line at: GBWideExit put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierExtentOf: bezier

	^self obj: bezier at: GBWideExtent! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierExtentOf: bezier put: value

	^self obj: bezier at: GBWideExtent put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:19'!
wideBezierFillOf: bezier

	^self obj: bezier at: GBWideFill! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:17'!
wideBezierFillOf: bezier put: value

	^self obj: bezier at: GBWideFill put: value! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:25'!
wideBezierUpdateDataOf: bezier
	self returnTypeC: 'int *'.

	^objBuffer + bezier +  GBWideUpdateData! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierWidthOf: line

	^self obj: line at: GBWideWidth! !

!BalloonEnginePlugin methodsFor: 'accessing beziers' stamp: 'ar 11/24/1998 22:20'!
wideBezierWidthOf: line put: value

	^self obj: line at: GBWideWidth put: value! !


!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar 11/24/1998 22:18'!
gradientRampLengthOf: fill

	^self obj: fill at: GFRampLength! !

!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar 11/24/1998 22:17'!
gradientRampLengthOf: fill put: value

	^self obj: fill at: GFRampLength put: value! !

!BalloonEnginePlugin methodsFor: 'accessing gradients' stamp: 'ar 11/24/1998 22:25'!
gradientRampOf: fill
	self returnTypeC:'int *'.

	^objBuffer + fill +  GFRampOffset! !


!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 21:46'!
isBezier: bezier
	^((self objectTypeOf: bezier) bitAnd: GEPrimitiveWideMask) = GEPrimitiveBezier! !

!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/8/1998 15:14'!
isFillOkay: fill
	self inline: false.
	^(fill = 0 or:[(self isFillColor: fill) or:[((self isObject: fill) and:[self isFill: fill])]]) 
! !

!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 21:46'!
isLine: line
	^((self objectTypeOf: line) bitAnd: GEPrimitiveWideMask) = GEPrimitiveLine! !

!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/6/1998 01:53'!
isWideBezier: bezier
	^(self isBezier: bezier) and:[self isWide: bezier]! !

!BalloonEnginePlugin methodsFor: 'testing' stamp: 'ar 11/4/1998 22:08'!
isWideLine: line
	^(self isLine: line) and:[self isWide: line]! !


!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar 11/4/1998 21:52'!
stepToFirstLine
	"Initialize the current entry in the GET by stepping to the current scan line"
	self inline: true.
	^self stepToFirstLineIn: (getBuffer at: self getStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar 11/9/1998 15:38'!
stepToFirstLineIn: line at: yValue
	"Initialize the line at yValue"
	| deltaX deltaY xDir widthX error xInc errorAdjUp startY |
	self inline: false.

	"Do a quick check if there is anything at all to do"
	((self isWide: line) not and:[yValue >= (self lineEndYOf: line)])
		ifTrue:[^self edgeNumLinesOf: line put: 0].

	deltaX _ (self lineEndXOf: line) - (self edgeXValueOf: line).
	deltaY _ (self lineEndYOf: line) - (self edgeYValueOf: line).

	"Check if edge goes left to right"
	deltaX >= 0 
		ifTrue:[	xDir _ 1.
				widthX _ deltaX.
				error _ 0]
		ifFalse:[	xDir _ -1.
				widthX _ 0 - deltaX.
				error _ 1 - deltaY].

	"Check if deltaY is zero.
	Note: We could actually get out here immediately 
	but wide lines rely on an accurate setup in this case"
	deltaY = 0
		ifTrue:[	error _ 0.			"No error for horizontal edges"
				xInc _ deltaX.		"Encodes width and direction"
				errorAdjUp _ 0]
		ifFalse:["Check if edge is y-major"
				deltaY > widthX "Note: The '>' instead of '>=' could be important here..."
					ifTrue:[	xInc _ 0.
							errorAdjUp _ widthX]
					ifFalse:[	xInc _ (widthX // deltaY) * xDir.
							errorAdjUp _ widthX \\ deltaY]].

	"Store the values"
	self edgeNumLinesOf: line put: deltaY.
	self lineXDirectionOf: line put: xDir.
	"self lineYDirectionOf: line put: yDir." "<-- Already set"
	self lineXIncrementOf: line put: xInc.
	self lineErrorOf: line put: error.
	self lineErrorAdjUpOf: line put: errorAdjUp.
	self lineErrorAdjDownOf: line put: deltaY.

	"And step to the first scan line"
	(startY _ self edgeYValueOf: line) = yValue ifFalse:[
		startY to: yValue-1 do:[:i| self stepToNextLineIn: line at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: line put: deltaY - (yValue - startY).
	].! !

!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar 11/4/1998 21:53'!
stepToNextLine
	"Process the current entry in the AET by stepping to the next scan line"
	self inline: true.
	^self stepToNextLineIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'lines-simple' stamp: 'ar 11/9/1998 15:39'!
stepToNextLineIn: line at: yValue
	"Incrementally step to the next scan line in the given line"
	| x  err |
	self inline: true.
	x _ (self edgeXValueOf: line) + (self lineXIncrementOf: line).
	err _ (self lineErrorOf: line) + (self lineErrorAdjUpOf: line).
	err > 0 ifTrue:[
		x _ x + (self lineXDirectionOf: line).
		err _ err - (self lineErrorAdjDownOf: line).
	].
	self lineErrorOf: line put: err.
	self edgeXValueOf: line put: x.! !


!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'ar 11/24/1998 23:15'!
loadLine: line from: point1 to: point2 offset: yOffset leftFill: leftFill rightFill: rightFill
	"Load the line defined by point1 and point2."
	| p1 p2 yDir |
	self var: #point1 declareC:'int *point1'.
	self var: #point2 declareC:'int *point2'.
	self var: #p1 declareC:'int *p1'.
	self var: #p2 declareC:'int *p2'.

	(point1 at: 1) <= (point2 at: 1) 
		ifTrue:[	p1 _ point1.
				p2 _ point2.
				yDir _ 1]
		ifFalse:[	p1 _ point2.
				p2 _ point1.
				yDir _ -1].
	self edgeXValueOf: line put: (p1 at: 0).
	self edgeYValueOf: line put: (p1 at: 1) - yOffset.
	self edgeZValueOf: line put: self currentZGet.
	self edgeLeftFillOf: line put: leftFill.
	self edgeRightFillOf: line put: rightFill.
	self lineEndXOf: line put: (p2 at: 0).
	self lineEndYOf: line put: (p2 at: 1) - yOffset.
	self lineYDirectionOf: line put: yDir.! !

!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'ar 11/6/1998 17:07'!
loadRectangle: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a rectangle currently defined by point1-point4"

	self loadWideLine: lineWidth from: self point1Get to: self point2Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point2Get to: self point3Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point3Get to: self point4Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
	self loadWideLine: lineWidth from: self point4Get to: self point1Get
		lineFill: lineFill leftFill: leftFill rightFill: rightFill.
! !

!BalloonEnginePlugin methodsFor: 'lines-loading' stamp: 'ar 11/8/1998 19:24'!
loadWideLine: lineWidth from: p1 to: p2 lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a (possibly wide) line defined by the points p1 and p2"
	| line offset |
	self var: #p1 declareC:'int *p1'.
	self var: #p2 declareC:'int *p2'.
	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[	line _ self allocateLine.
				offset _ 0]
		ifFalse:[	line _ self allocateWideLine.
				offset _ self offsetFromWidth: lineWidth].
	engineStopped ifTrue:[^0].
	self loadLine: line 
		from: p1
		to: p2
		offset: offset 
		leftFill: leftFill
		rightFill: rightFill.
	(self isWide: line) ifTrue:[
		self wideLineFillOf: line put: lineFill.
		self wideLineWidthOf: line put: lineWidth.
		self wideLineExtentOf: line put: lineWidth].! !


!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/9/1998 15:34'!
adjustWideLine: line afterSteppingFrom: lastX to: nextX
	"Adjust the wide line after it has been stepped from lastX to nextX.
	Special adjustments of line width and start position are made here
	to simulate a rectangular brush"
	|  yEntry yExit lineWidth lineOffset deltaX xDir baseWidth |
	self inline: false.	"Don't inline this"


	"Fetch the values the adjustment decisions are based on"
	yEntry _ (self wideLineEntryOf: line).
	yExit _ (self wideLineExitOf: line).
	baseWidth _ self wideLineExtentOf: line.
	lineOffset _ self offsetFromWidth: baseWidth.
	lineWidth _ self wideLineWidthOf: line.
	xDir _ self lineXDirectionOf: line.
	deltaX _ nextX - lastX.

	"Adjust the start of the line to fill an entire rectangle"
	yEntry < baseWidth ifTrue:[
		xDir < 0
			ifTrue:[	lineWidth _ lineWidth - deltaX] "effectively adding"
			ifFalse:[	lineWidth _ lineWidth + deltaX.
					self edgeXValueOf: line put: lastX].
	].

	"Adjust the end of x-major lines"
	((yExit + lineOffset) = 0) ifTrue:[
		xDir > 0
			ifTrue:[lineWidth _ lineWidth - (self lineXIncrementOf: line)]
			ifFalse:[lineWidth _ lineWidth + (self lineXIncrementOf: line).	"effectively subtracting"
					self edgeXValueOf: line put: lastX].
	].

	"Adjust the end of the line to fill an entire rectangle"
	(yExit + lineOffset) > 0 ifTrue:[
		xDir < 0
			ifTrue:[	lineWidth _ lineWidth + deltaX. "effectively subtracting"
					self edgeXValueOf: line put: lastX]
			ifFalse:[	lineWidth _ lineWidth - deltaX]
	].

	"Store the manipulated line width back"
	self wideLineWidthOf: line put: lineWidth.! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/6/1998 17:08'!
returnWideLineFill
	"Return the fill of the (wide) line - this method is called from a case."
	^(dispatchReturnValue _ self wideLineFillOf: dispatchedValue).! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/6/1998 17:08'!
returnWideLineWidth
	"Return the width of the (wide) line - this method is called from a case."
	^(dispatchReturnValue _ self wideLineWidthOf: dispatchedValue).! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/4/1998 21:54'!
stepToFirstWideLine
	"Initialize the current entry in the GET by stepping to the current scan line"
	self inline: true.
	^self stepToFirstWideLineIn: (getBuffer at: self getStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/9/1998 15:38'!
stepToFirstWideLineIn: line at: yValue
	"Initialize the wide line at yValue."
	| startY yEntry yExit lineWidth nLines lineOffset startX xDir |
	self inline: false.

	"Get some values"
	lineWidth _ self wideLineExtentOf: line.
	lineOffset _ self offsetFromWidth: lineWidth.

	"Compute the incremental values of the line"
	startX _ self edgeXValueOf: line.
	startY _ self edgeYValueOf: line.
	self stepToFirstLineIn: line at: startY.
	nLines _ (self edgeNumLinesOf: line).
	xDir _ self lineXDirectionOf: line.

	"Adjust the line to start at the correct X position"
	self edgeXValueOf: line put: startX - lineOffset.

	"Adjust the number of lines to include the lineWidth"
	self edgeNumLinesOf: line put: nLines + lineWidth.

	"Adjust the values for x-major lines"
	xDir > 0 ifTrue:[
		self wideLineWidthOf: line put: (self lineXIncrementOf: line) + lineWidth.
	] ifFalse:[
		self wideLineWidthOf: line put: lineWidth - (self lineXIncrementOf: line). "adding"
		self edgeXValueOf: line put: (self edgeXValueOf: line) + (self lineXIncrementOf: line).
	].

	"Compute the points where we have to turn on/off the fills"
	yEntry _ 0.						"turned on at lineOffset"
	yExit _ 0 - nLines - lineOffset.	"turned off at zero"
	self wideLineEntryOf: line put: yEntry.
	self wideLineExitOf: line put: yExit.

	"Turn the fills on/off as necessary"
	(yEntry >= lineOffset and:[yExit < 0])
		ifTrue:[self edgeFillsValidate: line]
		ifFalse:[self edgeFillsInvalidate: line].

	"And step to the first scan line"
	startY = yValue ifFalse:[
		startY to: yValue-1 do:[:i| self stepToNextWideLineIn: line at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: line put: (self edgeNumLinesOf: line) - (yValue - startY).
	].
! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/4/1998 21:55'!
stepToNextWideLine
	"Process the current entry in the AET by stepping to the next scan line"
	self inline: true.
	^self stepToNextWideLineIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'lines-wide' stamp: 'ar 11/9/1998 15:39'!
stepToNextWideLineIn: line at: yValue
	"Incrementally step to the next scan line in the given wide line"
	|  yEntry yExit lineWidth lineOffset lastX nextX |
	self inline: true.

	"Adjust entry/exit values"
	yEntry _ (self wideLineEntryOf: line) + 1.
	yExit _ (self wideLineExitOf: line) + 1.
	self wideLineEntryOf: line put: yEntry.
	self wideLineExitOf: line put: yExit.

	"Turn fills on/off"
	lineWidth _ self wideLineExtentOf: line.
	lineOffset _ self offsetFromWidth: lineWidth.
	yEntry >= lineOffset ifTrue:[self edgeFillsValidate: line].
	yExit >= 0 ifTrue:[self edgeFillsInvalidate: line].

	"Step to the next scan line"
	lastX _ self edgeXValueOf: line.
	self stepToNextLineIn: line at: yValue.
	nextX _ self edgeXValueOf: line.

	"Check for special start/end adjustments"
	(yEntry <= lineWidth or:[yExit+lineOffset >= 0]) ifTrue:[
		"Yes, need an update"
		self adjustWideLine: line afterSteppingFrom: lastX to: nextX.
	].! !


!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/9/1998 01:56'!
assureValue: val1 between: val2 and: val3
	"Make sure that val1 is between val2 and val3."
	self inline: true.
	val2 > val3 ifTrue:[
		val1 > val2 ifTrue:[^val2].
		val1 < val3 ifTrue:[^val3].
	] ifFalse:[
		val1 < val2 ifTrue:[^val2].
		val1 > val3 ifTrue:[^val3].
	].
	^val1	! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/9/1998 01:57'!
computeBezier: index splitAt: param
	"Split the bezier curve at the given parametric value.
	Note: Since this method is only invoked to make non-monoton
		beziers monoton we must check for the resulting y values
		to be *really* between the start and end value."
	| startX startY viaX viaY endX endY newIndex 
	leftViaX  leftViaY rightViaX rightViaY sharedX sharedY |
	self inline: false.

	self var: #param declareC:'double param'.
	leftViaX _ startX _ self bzStartX: index.
	leftViaY _ startY _ self bzStartY: index.
	rightViaX _ viaX _ self bzViaX: index.
	rightViaY _ viaY _ self bzViaY: index.
	endX _ self bzEndX: index.
	endY _ self bzEndY: index.

	"Compute intermediate points"
	sharedX _ leftViaX _ leftViaX + ((viaX - startX) asFloat * param) asInteger.
	sharedY _ leftViaY _ leftViaY + ((viaY - startY) asFloat * param) asInteger.
	rightViaX _ rightViaX + ((endX - viaX) asFloat * param) asInteger.
	rightViaY _ rightViaY + ((endY - viaY) asFloat * param) asInteger.
	"Compute new shared point"
	sharedX _ sharedX + ((rightViaX - leftViaX) asFloat * param) asInteger.
	sharedY _ sharedY + ((rightViaY - leftViaY) asFloat * param) asInteger.

	"Check the new via points"
	leftViaY _ self assureValue: leftViaY between: startY and: sharedY.
	rightViaY _ self assureValue: rightViaY between: sharedY and: endY.

	newIndex _ self allocateBezierStackEntry.
	engineStopped ifTrue:[^0]. "Something went wrong"

	"Store the first part back"
	self bzViaX: index put: leftViaX.
	self bzViaY: index put: leftViaY.
	self bzEndX: index put: sharedX.
	self bzEndY: index put: sharedY.
	"Store the second point back"
	self bzStartX: newIndex put: sharedX.
	self bzStartY: newIndex put: sharedY.
	self bzViaX: newIndex put: rightViaX.
	self bzViaY: newIndex put: rightViaY.
	self bzEndX: newIndex put: endX.
	self bzEndY: newIndex put: endY.

	^newIndex! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/6/1998 01:26'!
computeBezierSplitAtHalf: index
	"Split the bezier curve at 0.5."
	| startX startY viaX viaY endX endY newIndex 
	leftViaX  leftViaY rightViaX rightViaY sharedX sharedY |
	self inline: false.

	newIndex _ self allocateBezierStackEntry.
	engineStopped ifTrue:[^0]. "Something went wrong"

	leftViaX _ startX _ self bzStartX: index.
	leftViaY _ startY _ self bzStartY: index.
	rightViaX _ viaX _ self bzViaX: index.
	rightViaY _ viaY _ self bzViaY: index.
	endX _ self bzEndX: index.
	endY _ self bzEndY: index.
	"Compute intermediate points"
	leftViaX _ leftViaX + ((viaX - startX) // 2).
	leftViaY _ leftViaY + ((viaY - startY) // 2).
	sharedX _ rightViaX _ rightViaX + ((endX - viaX) // 2).
	sharedY _ rightViaY _ rightViaY + ((endY - viaY) // 2).
	"Compute new shared point"
	sharedX _ sharedX + ((leftViaX - rightViaX) // 2).
	sharedY _ sharedY + ((leftViaY - rightViaY) // 2).
	"Store the first part back"
	self bzViaX: index put: leftViaX.
	self bzViaY: index put: leftViaY.
	self bzEndX: index put: sharedX.
	self bzEndY: index put: sharedY.
	"Store the second point back"
	self bzStartX: newIndex put: sharedX.
	self bzStartY: newIndex put: sharedY.
	self bzViaX: newIndex put: rightViaX.
	self bzViaY: newIndex put: rightViaY.
	self bzEndX: newIndex put: endX.
	self bzEndY: newIndex put: endY.

	^newIndex! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 20:15'!
loadAndSubdivideBezierFrom: point1 via: point2 to: point3 isWide: wideFlag
	"Load and subdivide the bezier curve from point1/point2/point3.
	If wideFlag is set then make sure the curve is monoton in X."
	| bz1 bz2 index2 index1 |
	self inline: false.
	self var: #point1 declareC:'int *point1'.
	self var: #point2 declareC:'int *point2'.
	self var: #point3 declareC:'int *point3'.
	bz1 _ self allocateBezierStackEntry.	
	engineStopped ifTrue:[^0].
	"Load point1/point2/point3 on the top of the stack"
	self bzStartX: bz1 put: (point1 at: 0).
	self bzStartY: bz1 put: (point1 at: 1).
	self bzViaX: bz1 put: (point2 at: 0).
	self bzViaY: bz1 put: (point2 at: 1).
	self bzEndX: bz1 put: (point3 at: 0).
	self bzEndY: bz1 put: (point3 at: 1).

	"Now check if the bezier curve is monoton. If not, subdivide it."
	index2 _ bz2 _ self subdivideToBeMonoton: bz1 inX: wideFlag.
	bz1 to: bz2 by: 6 do:[:index|
		index1 _ self subdivideBezierFrom: index.
		index1 > index2 ifTrue:[index2 _ index1].
		engineStopped ifTrue:[^0]. "Something went wrong"
	].
	"Return the number of segments"
	^index2 // 6! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/24/1998 23:15'!
loadBezier: bezier segment: index leftFill: leftFillIndex rightFill: rightFillIndex offset: yOffset
	"Initialize the bezier segment stored on the stack"
	self inline: false.
	(self bzEndY: index) >= (self bzStartY: index) ifTrue:[
		"Top to bottom"
		self edgeXValueOf: bezier put: (self bzStartX: index).
		self edgeYValueOf: bezier put: (self bzStartY: index) - yOffset.
		self bezierViaXOf: bezier put: (self bzViaX: index).
		self bezierViaYOf: bezier put: (self bzViaY: index) - yOffset.
		self bezierEndXOf: bezier put: (self bzEndX: index).
		self bezierEndYOf: bezier put: (self bzEndY: index) - yOffset.
	] ifFalse:[
		self edgeXValueOf: bezier put: (self bzEndX: index).
		self edgeYValueOf: bezier put: (self bzEndY: index) - yOffset.
		self bezierViaXOf: bezier put: (self bzViaX: index).
		self bezierViaYOf: bezier put: (self bzViaY: index) - yOffset.
		self bezierEndXOf: bezier put: (self bzStartX: index).
		self bezierEndYOf: bezier put: (self bzStartY: index) - yOffset.
	].
	self edgeZValueOf: bezier put: self currentZGet.
	self edgeLeftFillOf: bezier put: leftFillIndex.
	self edgeRightFillOf: bezier put: rightFillIndex.
	"self debugDrawBezier: bezier."! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/25/1998 23:21'!
loadOval: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill
	"Load a rectangular oval currently defined by point1/point2"
	| w h cx cy nSegments |
	self inline: false.
	w _ ((self point2Get at: 0) - (self point1Get at: 0)) // 2.
	h _ ((self point2Get at: 1) - (self point1Get at: 1)) // 2.
	cx _ ((self point2Get at: 0) + (self point1Get at: 0)) // 2.
	cy _ ((self point2Get at: 1) + (self point1Get at: 1)) // 2.
	0 to: 15 do:[:i|
		self loadOvalSegment: i w: w h: h cx: cx cy: cy.
		self transformPoints: 3.
		nSegments _ self loadAndSubdivideBezierFrom: self point1Get 
							via: self point2Get to: self point3Get
							isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
		engineStopped ifTrue:[^nil].
		self loadWideBezier: lineWidth lineFill: lineFill 
			leftFill: leftFill rightFill: rightFill n: nSegments.
		engineStopped ifTrue:[^nil].
	].! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 15:17'!
loadOvalSegment: seg w: w h: h cx: cx cy: cy
	| x0 y0 x2 y2 x1 y1 |
	self inline: false.
	"Load start point of segment"
	x0 _ ((self circleCosTable at: seg * 2 + 0) * w asFloat + cx) asInteger.
	y0 _ ((self circleSinTable at: seg * 2 + 0) * h asFloat + cy) asInteger.
	self point1Get at: 0 put: x0.
	self point1Get at: 1 put: y0.
	"Load end point of segment"
	x2 _ ((self circleCosTable at: seg * 2 + 2) * w asFloat + cx) asInteger.
	y2 _ ((self circleSinTable at: seg * 2 + 2) * h asFloat + cy) asInteger.
	self point3Get at: 0 put: x2.
	self point3Get at: 1 put: y2.
	"Load intermediate point of segment"
	x1 _ ((self circleCosTable at: seg * 2 + 1) * w asFloat + cx) asInteger.
	y1 _ ((self circleSinTable at: seg * 2 + 1) * h asFloat + cy) asInteger.
	"NOTE: The intermediate point is the point ON the curve
	and not yet the control point (which is OFF the curve)"
	x1 _ (x1 * 2) - (x0 + x2 // 2).
	y1 _ (y1 * 2) - (y0 + y2 // 2).
	self point2Get at: 0 put: x1.
	self point2Get at: 1 put: y1.! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 03:41'!
loadWideBezier: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill n: nSegments
	"Load the (possibly wide) bezier from the segments currently on the bezier stack."
	| index bezier wide offset |
	self inline: false.
	(lineWidth = 0 or:[lineFill = 0])
		ifTrue:[wide _ false.
				offset _ 0]
		ifFalse:[wide _ true.
				offset _ self offsetFromWidth: lineWidth].
	index _ nSegments * 6.
	[index > 0] whileTrue:[
		wide 
			ifTrue:[bezier _ self allocateWideBezier]
			ifFalse:[bezier _ self allocateBezier].
		engineStopped ifTrue:[^0].
		self loadBezier: bezier 
			segment: index 
			leftFill: leftFill 
			rightFill: rightFill 
			offset: offset.
		wide ifTrue:[
			self wideBezierFillOf: bezier put: lineFill.
			self wideBezierWidthOf: bezier put: lineWidth.
			self wideBezierExtentOf: bezier put: lineWidth.
		].
		index _ index - 6.
	].
	self wbStackClear.! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 14:36'!
subdivideBezier: index
	"Subdivide the given bezier curve if necessary"
	| startX startY endX endY deltaX deltaY |
	self inline: false.
	startY _ self bzStartY: index.
	endY _ self bzEndY: index.

	"If the receiver is horizontal, don't do anything"
	(endY = startY) ifTrue:[^index].

	"TODO: If the curve can be represented as a line, then do so"

	"If the height of the curve exceeds 256 pixels, subdivide 
	(forward differencing is numerically not very stable)"
	deltaY _ endY - startY.
	deltaY < 0 ifTrue:[deltaY _ 0 - deltaY].
	(deltaY > 255) ifTrue:[
		self incrementStat: GWBezierHeightSubdivisions by: 1.
		^self computeBezierSplitAtHalf: index].

	"Check if the incremental values could possibly overflow the scaled integer range"
	startX _ self bzStartX: index.
	endX _ self bzEndX: index.
	deltaX _ endX - startX.
	deltaX < 0 ifTrue:[deltaX _ 0 - deltaX].
	deltaY * 32 < deltaX ifTrue:[
		self incrementStat: GWBezierOverflowSubdivisions by: 1.
		^self computeBezierSplitAtHalf: index].
	^index
! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 03:43'!
subdivideBezierFrom: index
	"Recursively subdivide the curve on the bezier stack."
	| otherIndex index1 index2 |
	self inline: false.
	otherIndex _ self subdivideBezier: index.
	otherIndex = index ifFalse:[
		index1 _ self subdivideBezierFrom: index.
		engineStopped ifTrue:[^0].
		index2 _ self subdivideBezierFrom: otherIndex.
		engineStopped ifTrue:[^0].
		index1 >= index2
			ifTrue:[^index1]
			ifFalse:[^index2]
	].
	^index! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/8/1998 15:17'!
subdivideToBeMonoton: base inX: doTestX
	"Check if the given bezier curve is monoton in Y, and, if desired in X. 
	If not, subdivide it"
	| index1 index2 base2 |
	self inline: false.
	base2 _ index1 _ index2 _ self subdivideToBeMonotonInY: base.
	doTestX ifTrue:[index1 _ self subdivideToBeMonotonInX: base].
	index1 > index2 ifTrue:[index2 _ index1].
	(base ~= base2 and:[doTestX]) ifTrue:[index1 _ self subdivideToBeMonotonInX: base2].
	index1 > index2 ifTrue:[index2 _ index1].
	^index2! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/7/1998 19:42'!
subdivideToBeMonotonInX: index
	"Check if the given bezier curve is monoton in X. If not, subdivide it"
	| denom num startX viaX endX dx1 dx2 |
	self inline: false.
	startX _ self bzStartX: index.
	viaX _ self bzViaX: index.
	endX _ self bzEndX: index.

	dx1 _ viaX - startX.
	dx2 _ endX - viaX.
	(dx1 * dx2) >= 0 ifTrue:[^index]. "Bezier is monoton"

	self incrementStat: GWBezierMonotonSubdivisions by: 1.
	"Compute split value"
	denom _ dx2 - dx1.
	num _ dx1.
	num < 0 ifTrue:[num _ 0 - num].
	denom < 0 ifTrue:[denom _ 0 - denom].
	^self computeBezier: index splitAt: (num asFloat / denom asFloat).! !

!BalloonEnginePlugin methodsFor: 'bezier-loading' stamp: 'ar 11/7/1998 19:42'!
subdivideToBeMonotonInY: index
	"Check if the given bezier curve is monoton in Y. If not, subdivide it"
	| startY viaY endY dy1 dy2 denom num |
	self inline: false.
	startY _ self bzStartY: index.
	viaY _ self bzViaY: index.
	endY _ self bzEndY: index.

	dy1 _ viaY - startY.
	dy2 _ endY - viaY.
	(dy1 * dy2) >= 0 ifTrue:[^index]. "Bezier is monoton"

	self incrementStat: GWBezierMonotonSubdivisions by: 1.
	"Compute split value"
	denom _ dy2 - dy1.
	num _ dy1.
	num < 0 ifTrue:[num _ 0 - num].
	denom < 0 ifTrue:[denom _ 0 - denom].
	^self computeBezier: index splitAt: (num asFloat / denom asFloat).! !


!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar 11/6/1998 00:07'!
stepToFirstBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	self inline: true.
	^self stepToFirstBezierIn: (getBuffer at: self getStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar 11/9/1998 15:38'!
stepToFirstBezierIn: bezier at: yValue
	"Initialize the bezier at yValue.
	TODO: Check if reducing maxSteps from 2*deltaY to deltaY 
		brings a *significant* performance improvement.
		In theory this should make for double step performance
		but will cost in quality. Might be that the AA stuff will
		compensate for this - but I'm not really sure."
	| updateData deltaY maxSteps scaledStepSize squaredStepSize 
	startX startY viaX viaY endX endY 
	fwX1 fwX2 fwY1 fwY2 
	fwDx fwDDx fwDy fwDDy |
	self inline: false. "Too many temps for useful inlining"
	self var: #updateData declareC:'int *updateData'.


	"Do a quick check if there is anything at all to do"
	((self isWide: bezier) not and:[yValue >= (self bezierEndYOf: bezier)])
		ifTrue:[^self edgeNumLinesOf: bezier put: 0].

	"Now really initialize bezier"
	startX _ self edgeXValueOf: bezier.
	startY _ self edgeYValueOf: bezier.
	viaX _ self bezierViaXOf: bezier.
	viaY _ self bezierViaYOf: bezier.
	endX _ self bezierEndXOf: bezier.
	endY _ self bezierEndYOf: bezier.
	deltaY _ endY - startY.

	"Initialize integer forward differencing"
	fwX1 _ (viaX - startX) * 2.
	fwX2 _ startX + endX - (viaX * 2).
	fwY1 _ (viaY - startY) * 2.
	fwY2 _ startY + endY - (viaY * 2).
	maxSteps _ deltaY * 2.
	maxSteps < 2 ifTrue:[maxSteps _ 2].
	scaledStepSize _ 16r1000000 // maxSteps.
	squaredStepSize _ self absoluteSquared8Dot24: scaledStepSize.
	fwDx _ fwX1 * scaledStepSize.
	fwDDx _ fwX2 * squaredStepSize * 2.
	fwDx _ fwDx + (fwDDx // 2).
	fwDy _ fwY1 * scaledStepSize.
	fwDDy _ fwY2 * squaredStepSize * 2.
	fwDy _ fwDy + (fwDDy // 2).

	"Store the values"
	self edgeNumLinesOf: bezier put: deltaY.

	updateData _ self bezierUpdateDataOf: bezier.
	updateData at: GBUpdateX put: (startX * 256).
	updateData at: GBUpdateY put: (startY * 256).
	updateData at: GBUpdateDX put: fwDx.
	updateData at: GBUpdateDY put: fwDy.
	updateData at: GBUpdateDDX put: fwDDx.
	updateData at: GBUpdateDDY put: fwDDy.

	"And step to the first scan line"
	(startY _ self edgeYValueOf: bezier) = yValue ifFalse:[
		self stepToNextBezierIn: bezier at: yValue.
		"Adjust number of lines remaining"
		self edgeNumLinesOf: bezier put: deltaY - (yValue - startY).
	].! !

!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar 11/6/1998 00:08'!
stepToNextBezier
	"Process the current entry in the AET by stepping to the next scan line"
	self inline: true.
	^self stepToNextBezierIn: (aetBuffer at: self aetStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar 11/9/1998 01:49'!
stepToNextBezierForward: updateData at: yValue
	"Incrementally step to the next scan line in the given bezier update data.
	Note: This method has been written so that inlining works, e.g.,
		not declaring updateData as 'int*' but casting it on every use."
	| minY lastX lastY fwDx fwDy |
	self inline: true.
	lastX _ (self cCoerce: updateData to: 'int*') at: GBUpdateX.
	lastY _ (self cCoerce: updateData to: 'int*') at: GBUpdateY.
	fwDx _ (self cCoerce: updateData to: 'int*') at: GBUpdateDX.
	fwDy _ (self cCoerce: updateData to: 'int*') at: GBUpdateDY.
	minY _ yValue * 256.
	"Step as long as we haven't yet reached minY and also
	as long as fwDy is greater than zero thus stepping down.
	Note: The test for fwDy should not be necessary in theory
		but is a good insurance in practice."
	[minY > lastY and:[fwDy >= 0]] whileTrue:[
		lastX _ lastX + ((fwDx + 16r8000) // 16r10000).
		lastY _ lastY + ((fwDy + 16r8000) // 16r10000).
		fwDx _ fwDx + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDX).
		fwDy _ fwDy + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDY).
	].
	(self cCoerce: updateData to: 'int*') at: GBUpdateX put: lastX.
	(self cCoerce: updateData to: 'int*') at: GBUpdateY put: lastY.
	(self cCoerce: updateData to: 'int*') at: GBUpdateDX put: fwDx.
	(self cCoerce: updateData to: 'int*') at: GBUpdateDY put: fwDy.
	^lastX // 256
! !

!BalloonEnginePlugin methodsFor: 'beziers-simple' stamp: 'ar 11/9/1998 15:39'!
stepToNextBezierIn: bezier at: yValue
	"Incrementally step to the next scan line in the given bezier"
	|  xValue |
	self inline: true.
	xValue _ self stepToNextBezierForward: (self bezierUpdateDataOf: bezier) at: yValue.
	self edgeXValueOf: bezier put: xValue.! !


!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/8/1998 15:18'!
adjustWideBezierLeft: bezier width: lineWidth offset: lineOffset endX: endX
	"Adjust the wide bezier curve (dx < 0) to start/end at the right point"
	| lastX lastY |
	self inline: false.
	(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
		(((self bezierUpdateDataOf: bezier) at: GBUpdateX) - (lineOffset * 256)).
	"Set the lastX/Y value of the second curve lineWidth pixels right/down"
	lastX _ (self wideBezierUpdateDataOf: bezier) at: GBUpdateX.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateX put: lastX + (lineWidth - lineOffset * 256).
	"Set lineWidth pixels down"
	lastY _ (self wideBezierUpdateDataOf: bezier) at: GBUpdateY.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateY put: lastY + (lineWidth * 256).
	"Record the last X value"
	self bezierFinalXOf: bezier put: endX - lineOffset.
! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/8/1998 15:18'!
adjustWideBezierRight: bezier width: lineWidth offset: lineOffset endX: endX
	"Adjust the wide bezier curve (dx >= 0) to start/end at the right point"
	| lastX lastY |
	self inline: false.
	(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
		(((self bezierUpdateDataOf: bezier) at: GBUpdateX) + (lineOffset * 256)).
	"Set the lastX/Y value of the second curve lineWidth pixels right/down"
	"Set lineWidth-lineOffset pixels left"
	lastX _ (self wideBezierUpdateDataOf: bezier) at: GBUpdateX.
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateX put: lastX - (lineWidth - lineOffset * 256).
	lastY _ (self wideBezierUpdateDataOf: bezier) at: GBUpdateY.
	"Set lineWidth pixels down"
	(self wideBezierUpdateDataOf: bezier) at: GBUpdateY put: lastY + (lineWidth * 256).
	"Record the last X value"
	self bezierFinalXOf: bezier put: endX - lineOffset + lineWidth.! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/8/1998 03:44'!
computeFinalWideBezierValues: bezier width: lineWidth
	"Get both values from the two boundaries of the given bezier 
	and compute the actual position/width of the line"
	| leftX rightX temp |
	leftX _ ((self bezierUpdateDataOf: bezier) at: GBUpdateX) // 256.
	rightX _ ((self wideBezierUpdateDataOf: bezier) at: GBUpdateX) // 256.
	leftX > rightX ifTrue:[temp _ leftX. leftX _ rightX. rightX _ temp].
	self edgeXValueOf: bezier put: leftX.
	(rightX - leftX) > lineWidth ifTrue:[
		self wideBezierWidthOf: bezier put: (rightX - leftX).
	] ifFalse:[
		self wideBezierWidthOf: bezier put: lineWidth.
	].! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 01:54'!
returnWideBezierFill
	^(dispatchReturnValue _ self wideBezierFillOf: dispatchedValue).! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 01:54'!
returnWideBezierWidth
	^(dispatchReturnValue _ self wideBezierWidthOf: dispatchedValue).! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 02:00'!
stepToFirstWideBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	self inline: true.
	^self stepToFirstWideBezierIn: (getBuffer at: self getStartGet) at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/9/1998 15:38'!
stepToFirstWideBezierIn: bezier at: yValue
	"Initialize the bezier at yValue"	
	| lineWidth startY nLines yEntry yExit lineOffset endX xDir |
	self inline: false.

	"Get some values"
	lineWidth _ self wideBezierExtentOf: bezier.
	lineOffset _ self offsetFromWidth: lineWidth.

	"Compute the incremental values of the bezier"
	endX _ self bezierEndXOf: bezier.
	startY _ self edgeYValueOf: bezier.
	self stepToFirstBezierIn: bezier at: startY.
	nLines _ (self edgeNumLinesOf: bezier).

	"Copy the incremental update data"
	0 to: 5 do:[:i|
		(self wideBezierUpdateDataOf: bezier) at: i put:
			((self bezierUpdateDataOf: bezier) at: i).
	].

	"Compute primary x direction of curve (e.g., 1: left to right; -1: right to left)."
	xDir _ ((self bezierUpdateDataOf: bezier) at: GBUpdateDX).
	xDir = 0 ifTrue:[((self bezierUpdateDataOf: bezier) at: GBUpdateDDX)].
	xDir >= 0 ifTrue:[xDir _ 1] ifFalse:[xDir _ -1].

	"Adjust the curve to start/end at the right position"
	xDir < 0
		ifTrue:[self adjustWideBezierLeft: bezier width: lineWidth offset: lineOffset endX: endX]
		ifFalse:[self adjustWideBezierRight: bezier width: lineWidth offset: lineOffset endX: endX].

	"Adjust the last value for horizontal lines"
	nLines = 0 ifTrue:[(self bezierUpdateDataOf: bezier) at: GBUpdateX put: 
						(self bezierFinalXOf: bezier) * 256].
	"Adjust the number of lines to include the lineWidth"
	self edgeNumLinesOf: bezier put: nLines + lineWidth.

	"Compute the points where we have to turn on/off the fills"
	yEntry _ 0.						"turned on at lineOffset"
	yExit _ 0 - nLines - lineOffset.	"turned off at zero"
	self wideBezierEntryOf: bezier put: yEntry.
	self wideBezierExitOf: bezier put: yExit.

	"Turn the fills on/off as necessary"
	(yEntry >= lineOffset and:[yExit < 0])
		ifTrue:[self edgeFillsValidate: bezier]
		ifFalse:[self edgeFillsInvalidate: bezier].

	self computeFinalWideBezierValues: bezier width: lineWidth.

	"And step to the first scan line"
	startY = yValue ifFalse:[
		"Note: Must single step here so that entry/exit works"
		startY to: yValue-1 do:[:i| self stepToNextWideBezierIn: bezier at: i].
		"Adjust number of lines remaining"
		self edgeNumLinesOf: bezier put: (self edgeNumLinesOf: bezier) - (yValue - startY).
	].! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/6/1998 02:34'!
stepToNextWideBezier
	"Initialize the current entry in the GET by stepping to the current scan line"
	self inline: true.
	self stepToNextWideBezierIn: (aetBuffer at: self aetStartGet) at: self currentYGet.! !

!BalloonEnginePlugin methodsFor: 'beziers-wide' stamp: 'ar 11/9/1998 15:39'!
stepToNextWideBezierIn: bezier at: yValue
	"Incrementally step to the next scan line in the given wide bezier"
	|  yEntry yExit lineWidth lineOffset |
	self inline: false.	"Don't inline this"

	lineWidth _ self wideBezierExtentOf: bezier.
	lineOffset _ self offsetFromWidth: lineWidth.

	yEntry _ (self wideBezierEntryOf: bezier) + 1.
	yExit _ (self wideBezierExitOf: bezier) + 1.
	self wideBezierEntryOf: bezier put: yEntry.
	self wideBezierExitOf: bezier put: yExit.
	yEntry >= lineOffset ifTrue:[self edgeFillsValidate: bezier].
	yExit >= 0 ifTrue:[self edgeFillsInvalidate: bezier].

	"Check if we have to step the upper curve"
	(yExit + lineOffset < 0) ifTrue:[
		self stepToNextBezierForward: (self bezierUpdateDataOf: bezier) at: yValue.
	] ifFalse:[
		"Adjust the last x value to the final x recorded previously"
		(self bezierUpdateDataOf: bezier) at: GBUpdateX put: (self bezierFinalXOf: bezier) * 256.
	].
	"Step the lower curve"
	self stepToNextBezierForward: (self wideBezierUpdateDataOf: bezier) at: yValue.

	self computeFinalWideBezierValues: bezier width: lineWidth.! !


!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/9/1998 16:07'!
checkCompressedFillIndexList: fillList max: maxIndex segments: nSegs
	"Check the fill indexes in the run-length encoded fillList"
	| length runLength runValue nFills fillPtr |
	self inline: false.
	self var: #fillPtr declareC:'int *fillPtr'.
	length _ interpreterProxy slotSizeOf: fillList.
	fillPtr _ interpreterProxy firstIndexableField: fillList.
	nFills _ 0.
	0 to: length-1 do:[:i|
		runLength _ self shortRunLengthAt: i from: fillPtr.
		runValue _ self shortRunValueAt: 0 from: fillPtr.
		(runValue >= 0 and:[runValue <= maxIndex]) ifFalse:[^false].
		nFills _ nFills + runLength.
	].
	^nFills = nSegs! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/25/1998 00:42'!
checkCompressedFills: indexList
	"Check if the indexList (containing fill handles) is okay."
	| fillPtr length fillIndex |
	self inline: false.
	self var: #fillPtr declareC:'int *fillPtr'.
	"First check if the oops have the right format"
	(interpreterProxy isWords: indexList) ifFalse:[^false].

	"Then check the fill entries"
	length _ interpreterProxy slotSizeOf: indexList.
	fillPtr _ interpreterProxy firstIndexableField: indexList.
	1 to: length do:[:i|
		fillIndex _ fillPtr at: 0.
		"Make sure the fill is okay"
		(self isFillOkay: fillIndex) ifFalse:[^false].
		fillPtr _ fillPtr + 1].

	^true! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/9/1998 16:07'!
checkCompressedLineWidths: lineWidthList segments: nSegments
	"Check the run-length encoded lineWidthList matches nSegments"
	| length runLength nItems ptr |
	self inline: false.
	self var: #ptr declareC:'int *ptr'.
	length _ interpreterProxy slotSizeOf: lineWidthList.
	ptr _ interpreterProxy firstIndexableField: lineWidthList.
	nItems _ 0.
	0 to: length-1 do:[:i|
		runLength _ self shortRunLengthAt: i from: ptr.
		nItems _ nItems + runLength.
	].
	^nItems = nSegments! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/8/1998 15:19'!
checkCompressedPoints: points segments: nSegments
	"Check if the given point array can be handled by the engine."
	| pSize |
	self inline: false.
	(interpreterProxy isWords: points) ifFalse:[^false].
	pSize _ interpreterProxy slotSizeOf: points.
	"The points must be either in PointArray format or ShortPointArray format.
	Also, we currently handle only quadratic segments (e.g., 3 points each) and thus either
		pSize = nSegments * 3,		for ShortPointArrays or,
		pSize = nSegments * 6,		for PointArrays"
	(pSize = (nSegments * 3) or:[pSize = (nSegments * 6)]) 
		ifFalse:[^false]. "Can't handle this"
	^true! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/12/1998 21:22'!
checkCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList
	"Check if the given shape can be handled by the engine. 
	Since there are a number of requirements this is an extra method."
	| maxFillIndex |
	self inline: false.
	(self checkCompressedPoints: points segments: nSegments) 
		ifFalse:[^false].
	(self checkCompressedFills: fillIndexList)
		ifFalse:[^false].
	maxFillIndex _ interpreterProxy slotSizeOf: fillIndexList.
	(self checkCompressedFillIndexList: leftFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedFillIndexList: rightFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedFillIndexList: lineFills max: maxFillIndex segments: nSegments)
		ifFalse:[^false].
	(self checkCompressedLineWidths: lineWidths segments: nSegments)
		ifFalse:[^false].
	^true! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/24/1998 21:13'!
loadCompressedSegment: segmentIndex from: points short: pointsShort leftFill: leftFill rightFill: rightFill lineWidth: lineWidth lineColor: lineFill 
	"Load the compressed segment identified by segment index"
	| x0 y0 x1 y1 x2 y2 index segs |
	self inline: true.

	"Check if have anything to do at all"
	(leftFill = rightFill and:[lineWidth = 0 or:[lineFill = 0]]) 
		ifTrue:[^nil]. "Nothing to do"

	index _ segmentIndex * 6. "3 points with x/y each"
	pointsShort ifTrue:["Load short points"
		x0 _ self loadPointShortAt: (index+0) from: points.
		y0 _ self loadPointShortAt: (index+1) from: points.
		x1 _ self loadPointShortAt: (index+2) from: points.
		y1 _ self loadPointShortAt: (index+3) from: points.
		x2 _ self loadPointShortAt: (index+4) from: points.
		y2 _ self loadPointShortAt: (index+5) from: points.
	] ifFalse:[
		x0 _ self loadPointIntAt: (index+0) from: points.
		y0 _ self loadPointIntAt: (index+1) from: points.
		x1 _ self loadPointIntAt: (index+2) from: points.
		y1 _ self loadPointIntAt: (index+3) from: points.
		x2 _ self loadPointIntAt: (index+4) from: points.
		y2 _ self loadPointIntAt: (index+5) from: points.
	].
	"Briefly check if can represent the bezier as a line"
	((x0 = x1 and:[y0 = y1]) or:[x1 = x2 and:[y1 = y2]]) ifTrue:[
		"We can use a line from x0/y0 to x2/y2"
		(x0 = x2 and:[y0 = y2]) ifTrue:[^nil]. "Nothing to do"
		"Load and transform points"
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x2.
		self point2Get at: 1 put: y2.
		self transformPoints: 2.
		^self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: leftFill 
			rightFill: rightFill.
	].
	"Need bezier curve"
	"Load and transform points"
	self point1Get at: 0 put: x0.
	self point1Get at: 1 put: y0.
	self point2Get at: 0 put: x1.
	self point2Get at: 1 put: y1.
	self point3Get at: 0 put: x2.
	self point3Get at: 1 put: y2.
	self transformPoints: 3.
	segs _ self loadAndSubdivideBezierFrom: self point1Get 
				via: self point2Get 
				to: self point3Get 
				isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
	engineStopped ifTrue:[^nil].
	self loadWideBezier: lineWidth lineFill: lineFill leftFill: leftFill rightFill: rightFill n: segs.
! !

!BalloonEnginePlugin methodsFor: 'shapes-compressed' stamp: 'ar 11/25/1998 00:28'!
loadCompressedShape: points segments: nSegments leftFills: leftFills rightFills: rightFills lineWidths: lineWidths lineFills: lineFills fillIndexList: fillIndexList pointShort: pointsShort
	"Load a compressed shape into the engine.
		WARNING: THIS METHOD NEEDS THE FULL FRAME SIZE!!!!!!!!
	"
	| leftRun rightRun widthRun lineFillRun
	leftLength rightLength widthLength lineFillLength
	leftValue rightValue widthValue lineFillValue |

	self inline: false. "Don't you!!!!!!!!"

	self var: #points declareC:'int *points'.
	self var: #leftFills declareC:'int *leftFills'.
	self var: #rightFills declareC:'int *rightFills'.
	self var: #lineWidths declareC:'int *lineWidths'.
	self var: #lineFills declareC:'int *lineFills'.
	self var: #fillIndexList declareC:'int *fillIndexList'.

	nSegments = 0 ifTrue:[^0].

	"Initialize run length encodings"
	leftRun _  rightRun _ widthRun _ lineFillRun _ -1.
	leftLength _ rightLength _ widthLength _ lineFillLength _ 1.
	leftValue _ rightValue _ widthValue _ lineFillValue _ 0.

	1 to: nSegments do:[:i|
		"Decrement current run length and load new stuff"
		(leftLength _ leftLength - 1) <= 0 ifTrue:[
			leftRun _ leftRun + 1.
			leftLength _ self shortRunLengthAt: leftRun from: leftFills.
			leftValue _ self shortRunValueAt: leftRun from: leftFills.
			leftValue = 0 ifFalse:[
				leftValue _ fillIndexList at: leftValue-1.
				leftValue _ self transformColor: leftValue.
				engineStopped ifTrue:[^nil]]].
		(rightLength _ rightLength - 1) <= 0 ifTrue:[
			rightRun _ rightRun + 1.
			rightLength _ self shortRunLengthAt: rightRun from: rightFills.
			rightValue _ self shortRunValueAt: rightRun from: rightFills.
			rightValue = 0 ifFalse:[
				rightValue _ fillIndexList at: rightValue-1.
				rightValue _ self transformColor: rightValue]].
		(widthLength _ widthLength - 1) <= 0 ifTrue:[
			widthRun _ widthRun + 1.
			widthLength _ self shortRunLengthAt: widthRun from: lineWidths.
			widthValue _ self shortRunValueAt: widthRun from: lineWidths.
			widthValue = 0 ifFalse:[widthValue _ self transformWidth: widthValue]].
		(lineFillLength _ lineFillLength - 1) <= 0 ifTrue:[
			lineFillRun _ lineFillRun + 1.
			lineFillLength _ self shortRunLengthAt: lineFillRun from: lineFills.
			lineFillValue _ self shortRunValueAt: lineFillRun from: lineFills.
			lineFillValue = 0 ifFalse:[lineFillValue _ fillIndexList at: lineFillValue-1]].
		self loadCompressedSegment: i - 1
			from: points 
			short: pointsShort 
			leftFill: leftValue 
			rightFill: rightValue 
			lineWidth: widthValue 
			lineColor: lineFillValue.
		engineStopped ifTrue:[^nil].
	].! !


!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar 11/24/1998 23:09'!
loadArrayPolygon: points nPoints: nPoints fill: fillIndex lineWidth: lineWidth lineFill: lineFill
	| x0 y0 x1 y1 |
	self loadPoint: self point1Get from: (interpreterProxy fetchPointer: 0 ofObject: points).
	interpreterProxy failed ifTrue:[^nil].
	x0 _ self point1Get at: 0.
	y0 _ self point1Get at: 1.
	1 to: nPoints-1 do:[:i|
		self loadPoint: self point1Get from: (interpreterProxy fetchPointer: i ofObject: points).
		interpreterProxy failed ifTrue:[^nil].
		x1 _ self point1Get at: 0.
		y1 _ self point1Get at: 1.
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x1.
		self point2Get at: 1 put: y1.
		self transformPoints: 2.
		self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: fillIndex
			rightFill: 0.
		engineStopped ifTrue:[^nil].
		x0 _ x1.
		y0 _ y1.
	].! !

!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar 11/24/1998 23:14'!
loadArrayShape: points nSegments: nSegments fill: fillIndex lineWidth: lineWidth lineFill: lineFill 
	| pointOop x0 y0 x1 y1 x2 y2 segs |
	self inline: false.
	0 to: nSegments-1 do:[:i|
		pointOop _ interpreterProxy fetchPointer: (i * 3) ofObject: points.
		self loadPoint: self point1Get from: pointOop.
		pointOop _ interpreterProxy fetchPointer: (i * 3 + 1) ofObject: points.
		self loadPoint: self point2Get from: pointOop.
		pointOop _ interpreterProxy fetchPointer: (i * 3 + 2) ofObject: points.
		self loadPoint: self point3Get from: pointOop.
		interpreterProxy failed ifTrue:[^nil].
		self transformPoints: 3.
		x0 _ self point1Get at: 0.
		y0 _ self point1Get at: 1.
		x1 _ self point2Get at: 0.
		y1 _ self point2Get at: 1.
		x2 _ self point3Get at: 0.
		y2 _ self point3Get at: 1.
		"Check if we can use a line"
		((x0 = y0 and:[x1 = y1]) or:[x1 = x2 and:[y1 = y2]]) ifTrue:[
			self loadWideLine: lineWidth
				from: self point1Get
				to: self point3Get
				lineFill: lineFill
				leftFill: fillIndex
				rightFill: 0.
		] ifFalse:["Need bezier"
			segs _ self loadAndSubdivideBezierFrom: self point1Get
					via: self point2Get
					to: self point3Get
					isWide: (lineWidth ~= 0 and:[lineFill ~= 0]).
			engineStopped ifTrue:[^nil].
			self loadWideBezier: lineWidth
				lineFill: lineFill
				leftFill: fillIndex
				rightFill: 0
				n: segs.
		].
		engineStopped ifTrue:[^nil].
	].! !

!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar 11/24/1998 23:10'!
loadPolygon: points nPoints: nPoints fill: fillIndex lineWidth: lineWidth lineFill: lineFill pointsShort: isShort
	| x0 y0 x1 y1 |
	self var:#points declareC:'int *points'.
	isShort ifTrue:[
		x0 _ self loadPointShortAt: 0 from: points.
		y0 _ self loadPointShortAt: 1 from: points.
	] ifFalse:[
		x0 _ self loadPointIntAt: 0 from: points.
		y0 _ self loadPointIntAt: 1 from: points.
	].
	1 to: nPoints-1 do:[:i|
		isShort ifTrue:[
			x1 _ self loadPointShortAt: i*2 from: points.
			y1 _ self loadPointShortAt: i*2+1 from: points.
		] ifFalse:[
			x1 _ self loadPointIntAt: i*2 from: points.
			y1 _ self loadPointIntAt: i*2+1 from: points.
		].
		self point1Get at: 0 put: x0.
		self point1Get at: 1 put: y0.
		self point2Get at: 0 put: x1.
		self point2Get at: 1 put: y1.
		self transformPoints: 2.
		self loadWideLine: lineWidth 
			from: self point1Get
			to: self point2Get
			lineFill: lineFill 
			leftFill: fillIndex
			rightFill: 0.
		engineStopped ifTrue:[^nil].
		x0 _ x1.
		y0 _ y1.
	].! !

!BalloonEnginePlugin methodsFor: 'shapes-polygons' stamp: 'ar 11/24/1998 21:14'!
loadShape: points nSegments: nSegments fill: fillIndex lineWidth: lineWidth lineFill: lineFill  pointsShort: pointsShort
	self inline: false.
	self var:#points declareC:'int *points'.
	1 to: nSegments do:[:i|
		self loadCompressedSegment: i-1
			from: points
			short: pointsShort
			leftFill: fillIndex
			rightFill: 0
			lineWidth: lineWidth
			lineColor: lineFill.
		engineStopped ifTrue:[^nil].
	].! !


!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/8/1998 15:20'!
fillLinearGradient
	self inline: true.
	^self fillLinearGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/24/1998 21:50'!
fillLinearGradient: fill from: leftX to: rightX at: yValue
	"Draw a linear gradient fill."
	| x0 x1 ramp rampSize dsX ds x rampIndex |
	self inline: false.
	self var: #ramp declareC:'int *ramp'.
	ramp _ self gradientRampOf: fill.
	rampSize _ self gradientRampLengthOf: fill.

	dsX _ self fillDirectionXOf: fill.
	ds _ ((leftX - (self fillOriginXOf: fill)) * dsX) + 
			((yValue - (self fillOriginYOf: fill)) * (self fillDirectionYOf: fill)).

	x _ x0 _ leftX.
	x1 _ rightX.

	"Note: The inner loop has been divided into three parts for speed"
	"Part one: Fill everything outside the left boundary"
	[(rampIndex _ ds // 16r10000) < 0 and:[x < x1]] 
		whileTrue:[	x _ x + 1.
					ds _ ds + dsX].
	x > x0 ifTrue:[self fillColorSpan: (self makeUnsignedFrom: (ramp at: 0)) from: x0 to: x].

	"Part two: Fill everything inside the boundaries"
	self aaLevelGet = 1 ifTrue:[
		"Fast version w/o anti-aliasing"
		[((rampIndex _ ds // 16r10000) < rampSize and:[rampIndex >= 0]) and:[x < x1]] whileTrue:[
			spanBuffer at: x put: (self makeUnsignedFrom: (ramp at: rampIndex)).
			x _ x + 1.
			ds _ ds + dsX.
		].
	] ifFalse:[x _ self fillLinearGradientAA: fill ramp: ramp ds: ds dsX: dsX from: x to: rightX].
	"Part three fill everything outside right boundary"
	x < x1 ifTrue:[
		rampIndex < 0 ifTrue:[rampIndex _ 0].
		rampIndex >= rampSize ifTrue:[rampIndex _ rampSize-1].
		self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampIndex)) from: x to: x1].
! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/10/1998 17:18'!
fillLinearGradientAA: fill ramp: ramp ds: deltaS dsX: dsX from: leftX to: rightX
	"This is the AA version of linear gradient filling."
	| colorMask colorShift baseShift rampIndex ds rampSize x idx rampValue 
	 aaLevel firstPixel lastPixel |
	self inline: false.
	self var: #ramp declareC:'int *ramp'.

	aaLevel _ self aaLevelGet.
	baseShift _ self aaShiftGet.
	rampSize _ self gradientRampLengthOf: fill.
	ds _ deltaS.
	x _ leftX.
	rampIndex _ ds // 16r10000.

	firstPixel _ self aaFirstPixelFrom: leftX to: rightX.
	lastPixel _ self aaLastPixelFrom: leftX to: rightX.

	"Deal with the first n sub-pixels"
	colorMask _ self aaColorMaskGet.
	colorShift _ self aaColorShiftGet.
	[x < firstPixel and:[rampIndex < rampSize and:[rampIndex >= 0]]] whileTrue:[
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < firstPixel and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x _ x + 1.
			ds _ ds + dsX].
		rampIndex _ ds // 16r10000.
	].

	"Deal with the full pixels"
	colorMask _ (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
	colorShift _ self aaShiftGet.
	[x < lastPixel and:[rampIndex < rampSize and:[rampIndex >= 0]]] whileTrue:[
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < lastPixel and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x _ x + aaLevel.
			ds _ ds + (dsX << colorShift)].
		rampIndex _ ds // 16r10000.
	].

	"Deal with the last n sub-pixels"
	colorMask _ self aaColorMaskGet.
	colorShift _ self aaColorShiftGet.
	[x < rightX and:[rampIndex < rampSize and:[rampIndex>=0]]] whileTrue:[
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		"Copy as many pixels as possible"
		[x < rightX and:[(ds//16r10000) = rampIndex]] whileTrue:[
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + rampValue.
			x _ x + 1.
			ds _ ds + dsX].
		rampIndex _ ds // 16r10000.
	].
	^x! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/24/1998 19:02'!
fillRadialDecreasing: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2a) Compute the decreasing part of the ramp"
	| ds dt rampIndex rampValue length2 x x1 nextLength |
	self inline: true.
	ds _ (self cCoerce: deltaST to:'int*') at: 0.
	dt _ (self cCoerce: deltaST to:'int*') at: 1.
	rampIndex _ self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
	length2 _ (rampIndex-1) * (rampIndex-1).

	x _ leftX.
	x1 _ rightX.
	x1 > (self fillOriginXOf: fill) ifTrue:[x1 _ self fillOriginXOf: fill].
	[x < x1] whileTrue:[
		"Try to copy the current value more than just once"
		[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
			whileTrue:[	spanBuffer at: x put: rampValue.
						x _ x + 1.
						ds _ ds + dsX.
						dt _ dt + dtX].
		"Step to next ramp value"
		nextLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
		[nextLength < length2] whileTrue:[
			rampIndex _ rampIndex - 1.
			rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
			length2 _ (rampIndex-1) * (rampIndex-1).
		].
	].

	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/24/1998 19:02'!
fillRadialDecreasingAA: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2a) Compute the decreasing part of the ramp"
	| ds dt rampIndex rampValue length2 x nextLength x1
	aaLevel colorMask colorShift baseShift index firstPixel lastPixel |
	self inline: false.
	self var: #ramp declareC:'int *ramp'.
	self var: #deltaST declareC:' int *deltaST'.

	ds _ (self cCoerce: deltaST to:'int*') at: 0.
	dt _ (self cCoerce: deltaST to:'int*') at: 1.
	aaLevel _ self aaLevelGet.
	baseShift _ self aaShiftGet.
	rampIndex _ self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	length2 _ (rampIndex-1) * (rampIndex-1).

	x _ leftX.
	x1 _ self fillOriginXOf: fill.
	x1 > rightX ifTrue:[x1 _ rightX].
	firstPixel _ self aaFirstPixelFrom: leftX to: x1.
	lastPixel _ self aaLastPixelFrom: leftX to: x1.

	"Deal with the first n sub-pixels"
	(x < firstPixel) ifTrue:[
		colorMask _ self aaColorMaskGet.
		colorShift _ self aaColorShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < firstPixel] whileTrue:[
			"Try to copy the current value more than just once"
			[x < firstPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + 1.
							ds _ ds + dsX.
							dt _ dt + dtX].
			"Step to next ramp value"
			nextLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex _ rampIndex - 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				length2 _ (rampIndex-1) * (rampIndex-1).
			].
		].
	].

	"Deal with the full pixels"
	(x < lastPixel) ifTrue:[
		colorMask _ (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		colorShift _ self aaShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < lastPixel] whileTrue:[
			"Try to copy the current value more than just once"
			[x < lastPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + aaLevel.
							ds _ ds + (dsX << colorShift).
							dt _ dt + (dtX << colorShift)].
			"Step to next ramp value"
			nextLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex _ rampIndex - 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				length2 _ (rampIndex-1) * (rampIndex-1).
			].
		].
	].

	"Deal with the last n sub-pixels"
	(x < x1) ifTrue:[
		colorMask _ self aaColorMaskGet.
		colorShift _ self aaColorShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < x1] whileTrue:[
			"Try to copy the current value more than just once"
			[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) >= length2]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + 1.
							ds _ ds + dsX.
							dt _ dt + dtX].
			"Step to next ramp value"
			nextLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[nextLength < length2] whileTrue:[
				rampIndex _ rampIndex - 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				length2 _ (rampIndex-1) * (rampIndex-1).
			].
		].
	].
	"Done -- store stuff back"
	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/8/1998 15:20'!
fillRadialGradient
	self inline: true.
	^self fillRadialGradient: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/24/1998 19:02'!
fillRadialGradient: fill from: leftX to: rightX at: yValue
	"Draw a radial gradient fill."
	| x x1 ramp rampSize dsX ds dtX dt length2 deltaX deltaY deltaST |
	self inline: false.
	self var: #ramp declareC:'int *ramp'.
	self var: #deltaST declareC:'int *deltaST'.

	ramp _ self gradientRampOf: fill.
	rampSize _ self gradientRampLengthOf: fill.

	deltaX _ leftX - (self fillOriginXOf: fill).
	deltaY _ yValue - (self fillOriginYOf: fill).

	dsX _ self fillDirectionXOf: fill.
	dtX _ self fillNormalXOf: fill.

	ds _ (deltaX * dsX) + (deltaY * (self fillDirectionYOf: fill)).
	dt _ (deltaX * dtX) + (deltaY * (self fillNormalYOf: fill)).

	x _ leftX.
	x1 _ rightX.

	"Note: The inner loop has been divided into three parts for speed"
	"Part one: Fill everything outside the left boundary"
	length2 _ (rampSize-1) * (rampSize-1). "This is the upper bound"
	[(self squaredLengthOf: ds // 16r10000 with: dt // 16r10000) >= length2 and:[x < x1]]
		whileTrue:[	x _ x + 1.	ds _ ds + dsX.	dt _ dt + dtX].
	x > leftX ifTrue:[self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampSize-1)) from: leftX to: x].

	"Part two: Fill everything inside the boundaries"
	deltaST _ self point1Get.
	deltaST at: 0 put: ds.
	deltaST at: 1 put: dt.
	(x < (self fillOriginXOf: fill)) ifTrue:[
		"Draw the decreasing part"
		self aaLevelGet = 1 
			ifTrue:[x _ self fillRadialDecreasing: fill ramp: ramp deltaST: deltaST 
							dsX: dsX dtX: dtX from: x to: x1]
			ifFalse:[x _ self fillRadialDecreasingAA: fill ramp: ramp deltaST: deltaST 
							dsX: dsX dtX: dtX from: x to: x1].
	].
	x < x1 ifTrue:[
		"Draw the increasing part"
		self aaLevelGet = 1
			ifTrue:[x _ self fillRadialIncreasing: fill ramp: ramp deltaST: deltaST
							dsX: dsX dtX: dtX from: x to: x1]
			ifFalse:[x _ self fillRadialIncreasingAA: fill ramp: ramp deltaST: deltaST
							dsX: dsX dtX: dtX from: x to: x1].
	].

	"Part three fill everything outside right boundary"
	x < rightX ifTrue:[self fillColorSpan: (self makeUnsignedFrom: (ramp at: rampSize-1)) from: x to: rightX].
! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/9/1998 01:21'!
fillRadialIncreasing: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2b) Compute the increasing part of the ramp"
	| ds dt rampIndex rampValue length2 x x1 nextLength rampSize lastLength |
	self inline: true.
	ds _ (self cCoerce: deltaST to:'int*') at: 0.
	dt _ (self cCoerce: deltaST to:'int*') at: 1.
	rampIndex _ self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
	rampSize _ self gradientRampLengthOf: fill.
	length2 _ (rampSize-1) * (rampSize-1). "This is the upper bound"
	nextLength _ (rampIndex+1) * (rampIndex+1).
	lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.

	x _ leftX.
	x1 _ rightX.

	[x < x1 and:[lastLength < length2]] whileTrue:[
		"Try to copy the current value more than once"
		[x < x1 and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
			whileTrue:[	spanBuffer at: x put: rampValue.
						x _ x + 1.
						ds _ ds + dsX.
						dt _ dt + dtX].
		lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
		[lastLength > nextLength] whileTrue:[
			rampIndex _ rampIndex + 1.
			rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
			nextLength _ (rampIndex+1) * (rampIndex+1).
		].
	].

	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/9/1998 16:09'!
fillRadialIncreasingAA: fill ramp: ramp deltaST: deltaST dsX: dsX dtX: dtX from: leftX to: rightX
	"Part 2b) Compute the increasing part of the ramp"
	| ds dt rampIndex rampValue length2 x nextLength rampSize lastLength 
	aaLevel colorMask colorShift baseShift index firstPixel lastPixel |
	self inline: false.
	self var: #ramp declareC:'int *ramp'.
	self var: #deltaST declareC:' int *deltaST'.

	ds _ (self cCoerce: deltaST to:'int*') at: 0.
	dt _ (self cCoerce: deltaST to:'int*') at: 1.
	aaLevel _ self aaLevelGet.
	baseShift _ self aaShiftGet.
	rampIndex _ self accurateLengthOf: ds // 16r10000 with: dt // 16r10000.
	rampSize _ self gradientRampLengthOf: fill.
	length2 _ (rampSize-1) * (rampSize-1). "This is the upper bound"
	nextLength _ (rampIndex+1) * (rampIndex+1).
	lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.

	x _ leftX.

	firstPixel _ self aaFirstPixelFrom: leftX to: rightX.
	lastPixel _ self aaLastPixelFrom: leftX to: rightX.

	"Deal with the first n subPixels"
	(x < firstPixel and:[lastLength < length2]) ifTrue:[
		colorMask _ self aaColorMaskGet.
		colorShift _ self aaColorShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < firstPixel and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < firstPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + 1.
							ds _ ds + dsX.
							dt _ dt + dtX].
			lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex _ rampIndex + 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				nextLength _ (rampIndex+1) * (rampIndex+1).
			].
		].
	].

	"Deal with the full pixels"
	(x < lastPixel and:[lastLength < length2]) ifTrue:[
		colorMask _ (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
		colorShift _ self aaShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < lastPixel and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < lastPixel and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + aaLevel.
							ds _ ds + (dsX << colorShift).
							dt _ dt + (dtX << colorShift)].
			lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex _ rampIndex + 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				nextLength _ (rampIndex+1) * (rampIndex+1).
			].
		].
	].

	"Deal with last n sub-pixels"
	(x < rightX and:[lastLength < length2]) ifTrue:[
		colorMask _ self aaColorMaskGet.
		colorShift _ self aaColorShiftGet.
		rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
		rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
		[x < rightX and:[lastLength < length2]] whileTrue:[
			"Try to copy the current value more than once"
			[x < rightX and:[(self squaredLengthOf: ds //  16r10000 with: dt // 16r10000) <= nextLength]]
				whileTrue:[	index _ x >> baseShift.
							spanBuffer at: index put: (spanBuffer at: index) + rampValue.
							x _ x + 1.
							ds _ ds + dsX.
							dt _ dt + dtX].
			lastLength _ self squaredLengthOf: ds //  16r10000 with: dt // 16r10000.
			[lastLength > nextLength] whileTrue:[
				rampIndex _ rampIndex + 1.
				rampValue _ self makeUnsignedFrom: ((self cCoerce: ramp to:'int *') at: rampIndex).
				rampValue _ (rampValue bitAnd: colorMask) >> colorShift.
				nextLength _ (rampIndex+1) * (rampIndex+1).
			].
		].
	].
	"Done -- store stuff back"
	(self cCoerce: deltaST to: 'int *') at: 0 put: ds.
	(self cCoerce: deltaST to: 'int *') at: 1 put: dt.
	^x! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/27/1998 13:36'!
loadFillOrientation: fill from: point1 along: point2 normal: point3 width: fillWidth height: fillHeight
	"Transform the points"
	| dirX dirY nrmX nrmY dsLength2 dsX dsY dtLength2 dtX dtY |
	self var: #point1 declareC:'int *point1'.
	self var: #point2 declareC:'int *point2'.
	self var: #point3 declareC:'int *point3'.

	point2 at: 0 put: (point2 at: 0) + (point1 at: 0).
	point2 at: 1 put: (point2 at: 1) + (point1 at: 1).
	point3 at: 0 put: (point3 at: 0) + (point1 at: 0).
	point3 at: 1 put: (point3 at: 1) + (point1 at: 1).
	self transformPoint: point1.
	self transformPoint: point2.
	self transformPoint: point3.
	dirX _ (point2 at: 0) - (point1 at: 0).
	dirY _ (point2 at: 1) - (point1 at: 1).
	nrmX _ (point3 at: 0) - (point1 at: 0).
	nrmY _ (point3 at: 1) - (point1 at: 1).

	"Compute the scale from direction/normal into ramp size"
	dsLength2 _ (dirX * dirX) + (dirY * dirY).
	dsLength2 > 0 ifTrue:[
		dsX _ (dirX asFloat * fillWidth asFloat * 65536.0 / dsLength2 asFloat) asInteger.
		dsY _ (dirY asFloat * fillWidth asFloat * 65536.0 / dsLength2 asFloat) asInteger.
	] ifFalse:[ dsX _ 0. dsY _ 0].
	dtLength2 _ (nrmX * nrmX) + (nrmY * nrmY).
	dtLength2 > 0 ifTrue:[
		dtX _ (nrmX asFloat * fillHeight asFloat * 65536.0 / dtLength2 asFloat) asInteger.
		dtY _ (nrmY asFloat * fillHeight asFloat * 65536.0 / dtLength2 asFloat) asInteger.
	] ifFalse:[dtX _ 0. dtY _ 0].
	self fillOriginXOf: fill put: (point1 at: 0).
	self fillOriginYOf: fill put: (point1 at: 1).
	self fillDirectionXOf: fill put: dsX.
	self fillDirectionYOf: fill put: dsY.
	self fillNormalXOf: fill put: dtX.
	self fillNormalYOf: fill put: dtY.
! !

!BalloonEnginePlugin methodsFor: 'fills-gradient' stamp: 'ar 11/25/1998 16:44'!
loadGradientFill: rampOop from: point1 along: point2 normal: point3 isRadial: isRadial
	"Load the gradient fill as defined by the color ramp."
	| rampWidth fill |
	self inline: false.
	self var: #point1 declareC:'int *point1'.
	self var: #point2 declareC:'int *point2'.
	self var: #point3 declareC:'int *point3'.
	(interpreterProxy fetchClassOf: rampOop) = interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	rampWidth _ interpreterProxy slotSizeOf: rampOop.
	fill _ self allocateGradientFill: (interpreterProxy firstIndexableField: rampOop)
				rampWidth: rampWidth isRadial: isRadial.
	engineStopped ifTrue:[^nil].
	self loadFillOrientation: fill 
		from: point1 along: point2 normal: point3 
		width: rampWidth height: rampWidth.
	^fill! !


!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:38'!
allocateBezier
	| bezier |
	(self allocateObjEntry: GBBaseSize) ifFalse:[^0].
	bezier _ objUsed.
	objUsed _ bezier + GBBaseSize.
	self objectTypeOf: bezier put: GEPrimitiveBezier.
	self objectIndexOf: bezier put: 0.
	self objectLengthOf: bezier put: GBBaseSize.
	^bezier! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 10/30/1998 20:52'!
allocateBezierStackEntry
	self wbStackPush: 6.
	^self wbStackSize! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 16:40'!
allocateBitmapFill: cmSize colormap: cmBits
	| fill fillSize cm |
	self var:#cm declareC:'int *cm'.
	self var:#cmBits declareC:'int *cmBits'.
	fillSize _ GBMBaseSize + cmSize.
	(self allocateObjEntry: fillSize) ifFalse:[^0].
	fill _ objUsed.
	objUsed _ fill + fillSize.
	self objectTypeOf: fill put: GEPrimitiveClippedBitmapFill.
	self objectIndexOf: fill put: 0.
	self objectLengthOf: fill put: fillSize.
	cm _ self colormapOf: fill.
	self hasColorTransform ifTrue:[
		0 to: cmSize-1 do:[:i| cm at: i put: (self transformColor: (cmBits at: i))].
	] ifFalse:[
		0 to: cmSize-1 do:[:i| cm at: i put: (cmBits at: i)].
	].
	self bitmapCmSizeOf: fill put: cmSize.
	^fill! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:38'!
allocateGradientFill: ramp rampWidth: rampWidth isRadial: isRadial
	| fill fillSize rampPtr |
	self var:#ramp declareC:'int *ramp'.
	self var:#rampPtr declareC:'int *rampPtr'.
	fillSize _ GGBaseSize + rampWidth.
	(self allocateObjEntry: fillSize) ifFalse:[^0].
	fill _ objUsed.
	objUsed _ fill + fillSize.
	isRadial
		ifTrue:[self objectTypeOf: fill put: GEPrimitiveRadialGradientFill]
		ifFalse:[self objectTypeOf: fill put: GEPrimitiveLinearGradientFill].
	self objectIndexOf: fill put: 0.
	self objectLengthOf: fill put: fillSize.
	rampPtr _ self gradientRampOf: fill.
	self hasColorTransform ifTrue:[
		0 to: rampWidth-1 do:[:i| rampPtr at: i put: (self transformColor: (ramp at: i))].
	] ifFalse:[
		0 to: rampWidth-1 do:[:i| rampPtr at: i put: (ramp at: i)].
	].
	self gradientRampLengthOf: fill put: rampWidth.
	^fill! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateLine
	| line |
	(self allocateObjEntry: GLBaseSize) ifFalse:[^0].
	line _ objUsed.
	objUsed _ line + GLBaseSize.
	self objectTypeOf: line put: GEPrimitiveLine.
	self objectIndexOf: line put: 0.
	self objectLengthOf: line put: GLBaseSize.
	^line! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateWideBezier
	| bezier |
	(self allocateObjEntry: GBWideSize) ifFalse:[^0].
	bezier _ objUsed.
	objUsed _ bezier + GBWideSize.
	self objectTypeOf: bezier put: GEPrimitiveWideBezier.
	self objectIndexOf: bezier put: 0.
	self objectLengthOf: bezier put: GBWideSize.
	^bezier! !

!BalloonEnginePlugin methodsFor: 'allocation' stamp: 'ar 11/25/1998 00:39'!
allocateWideLine
	| line |
	(self allocateObjEntry: GLWideSize) ifFalse:[^0].
	line _ objUsed.
	objUsed _ line + GLWideSize.
	self objectTypeOf: line put: GEPrimitiveWideLine.
	self objectIndexOf: line put: 0.
	self objectLengthOf: line put: GLWideSize.
	^line! !


!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar 11/9/1998 15:37'!
checkedAddBezierToGET: bezier
	"Add the bezier to the global edge table if it intersects the clipping region"
	| lineWidth |
	self inline: true.

	(self isWide: bezier) 
		ifTrue:[lineWidth _ (self wideBezierExtentOf: bezier)]
		ifFalse:[lineWidth _ 0].
	(self bezierEndYOf: bezier) + lineWidth < (self fillMinYGet) ifTrue:[^0].
	"Overlaps in Y but may still be entirely right of clip region"
	((self edgeXValueOf: bezier) - lineWidth >= self fillMaxXGet and:[
		(self bezierEndXOf: bezier) - lineWidth >= self fillMaxXGet]) ifTrue:[^0].
	self addEdgeToGET: bezier.
! !

!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar 11/9/1998 15:37'!
checkedAddEdgeToGET: edge
	"Add the edge to the global edge table.
	For known edge types, check if the edge intersects the visible region"
	self inline: true.

	(self isLine: edge) ifTrue:[^self checkedAddLineToGET: edge].
	(self isBezier: edge) ifTrue:[^self checkedAddBezierToGET: edge].
	self addEdgeToGET: edge.
! !

!BalloonEnginePlugin methodsFor: 'GET processing' stamp: 'ar 11/9/1998 15:37'!
checkedAddLineToGET: line
	"Add the line to the global edge table if it intersects the clipping region"
	| lineWidth |
	self inline: true.

	(self isWide: line) 
		ifTrue:[lineWidth _ (self wideLineExtentOf: line)]
		ifFalse:[lineWidth _ 0].
	(self lineEndYOf: line) + lineWidth < (self fillMinYGet) ifTrue:[^0].
	"Overlaps in Y but may still be entirely right of clip region"
	((self edgeXValueOf: line) - lineWidth >= self fillMaxXGet and:[
		(self lineEndXOf: line) - lineWidth >= self fillMaxXGet]) ifTrue:[^0].
	self addEdgeToGET: line.
! !


!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 10/30/1998 20:02'!
absoluteSquared8Dot24: value
	"Compute the squared value of a 8.24 number with 0.0 <= value < 1.0,
	e.g., compute (value * value) bitShift: -24"
	| word1 word2 |
	self inline: true.
	word1 _ value bitAnd: 16rFFFF.
	word2 _ (value bitShift: -16) bitAnd: 255.
	^(( (self cCoerce: (word1 * word1) to:'unsigned') bitShift: -16) +
		((word1 * word2) * 2) +
			((word2 * word2) bitShift: 16)) bitShift: -8! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/1/1998 17:06'!
circleCosTable
	| theTable |
	self returnTypeC:'double *'.
	self inline: false. "Don't you inline this!!!!!!"
	self var:#theTable declareC:'static double theTable[33] =
		{1.0, 0.98078528040323, 0.923879532511287, 0.831469612302545,
		0.7071067811865475, 0.555570233019602, 0.38268343236509, 0.1950903220161286,
		0.0, -0.1950903220161283, -0.3826834323650896, -0.555570233019602,
		-0.707106781186547, -0.831469612302545, -0.9238795325112865, -0.98078528040323,
		-1.0, -0.98078528040323, -0.923879532511287, -0.831469612302545,
		-0.707106781186548, -0.555570233019602, -0.3826834323650903, -0.1950903220161287,
		0.0, 0.1950903220161282, 0.38268343236509, 0.555570233019602,
		0.707106781186547, 0.831469612302545, 0.9238795325112865, 0.98078528040323,
		1.0 }'.
	^theTable! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/1/1998 17:06'!
circleSinTable
	| theTable |
	self returnTypeC:'double *'.
	self inline: false. "Don't you inline this!!!!!!"
	self var:#theTable declareC:'static double theTable[33] =
		{0.0, 0.1950903220161282, 0.3826834323650897, 0.555570233019602,
		0.707106781186547, 0.831469612302545, 0.923879532511287, 0.98078528040323,
		1.0, 0.98078528040323, 0.923879532511287, 0.831469612302545,
		0.7071067811865475, 0.555570233019602, 0.38268343236509, 0.1950903220161286,
		0.0, -0.1950903220161283, -0.3826834323650896, -0.555570233019602,
		-0.707106781186547, -0.831469612302545, -0.9238795325112865, -0.98078528040323,
		-1.0, -0.98078528040323, -0.923879532511287, -0.831469612302545,
		-0.707106781186548, -0.555570233019602, -0.3826834323650903, -0.1950903220161287,
		 0.0 }'.
	^theTable! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 23:24'!
loadPointIntAt: index from: intArray
	"Load the int value from the given index in intArray"
	^(self cCoerce: intArray to: 'int *') at: index! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 23:23'!
loadPointShortAt: index from: shortArray
	"Load the short value from the given index in shortArray"
	self returnTypeC:'short'.
	^(self cCoerce: shortArray to: 'short *') at: index! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/1/1998 03:16'!
makeRectFromPoints
	self point2Get at: 0 put: (self point3Get at: 0).
	self point2Get at: 1 put: (self point1Get at: 1).
	self point4Get at: 0 put: (self point1Get at: 0).
	self point4Get at: 1 put: (self point3Get at: 1).! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/6/1998 17:55'!
offsetFromWidth: lineWidth
	"Common function so that we don't compute that wrong in any place
	and can easily find all the places where we deal with one-pixel offsets."
	self inline: true.
	^lineWidth // 2! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/25/1998 19:27'!
rShiftTable
	| theTable |
	self returnTypeC:'int *'.
	self inline: false. "Don't you inline this!!!!!!"
	self var:#theTable declareC:'static int theTable[17] =
		{0, 5, 4, 0, 3, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 1}'.
	^theTable! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 22:55'!
shortRunLengthAt: i from: runArray
	"Return the run-length value from the given ShortRunArray."
	^((self cCoerce: runArray to:'int *') at: i) bitShift: - 16! !

!BalloonEnginePlugin methodsFor: 'private' stamp: 'ar 11/3/1998 22:54'!
shortRunValueAt: i from: runArray
	"Return the run-length value from the given ShortRunArray.
	Note: We don't need any coercion to short/int here, since
	we deal basically only with unsigned values."
	^(((self cCoerce: runArray to:'int *') at: i) bitAnd: 16rFFFF)! !


!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionXOf: fill

	^self obj: fill at: GFDirectionX! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionXOf: fill put: value

	^self obj: fill at: GFDirectionX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:19'!
fillDirectionYOf: fill

	^self obj: fill at: GFDirectionY! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillDirectionYOf: fill put: value

	^self obj: fill at: GFDirectionY put: value! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalXOf: fill

	^self obj: fill at: GFNormalX! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalXOf: fill put: value

	^self obj: fill at: GFNormalX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillNormalYOf: fill

	^self obj: fill at: GFNormalY! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:16'!
fillNormalYOf: fill put: value

	^self obj: fill at: GFNormalY put: value! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginXOf: fill

	^self obj: fill at: GFOriginX! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginXOf: fill put: value

	^self obj: fill at: GFOriginX put: value! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:17'!
fillOriginYOf: fill

	^self obj: fill at: GFOriginY! !

!BalloonEnginePlugin methodsFor: 'accessing fills' stamp: 'ar 11/24/1998 22:18'!
fillOriginYOf: fill put: value

	^self obj: fill at: GFOriginY put: value! !


!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:20'!
bitmapCmSizeOf: bmFill

	^self obj: bmFill at: GBColormapSize! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:19'!
bitmapCmSizeOf: bmFill put: value

	^self obj: bmFill at: GBColormapSize put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapDepthOf: bmFill

	^self obj: bmFill at: GBBitmapDepth! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:20'!
bitmapDepthOf: bmFill put: value

	^self obj: bmFill at: GBBitmapDepth put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapHeightOf: bmFill

	^self obj: bmFill at: GBBitmapHeight! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapHeightOf: bmFill put: value

	^self obj: bmFill at: GBBitmapHeight put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapRasterOf: bmFill

	^self obj: bmFill at: GBBitmapRaster! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapRasterOf: bmFill put: value

	^self obj: bmFill at: GBBitmapRaster put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:19'!
bitmapSizeOf: bmFill

	^self obj: bmFill at: GBBitmapSize! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapSizeOf: bmFill put: value

	^self obj: bmFill at: GBBitmapSize put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/27/1998 14:20'!
bitmapTileFlagOf: bmFill

	^self obj: bmFill at: GBTileFlag! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/27/1998 14:20'!
bitmapTileFlagOf: bmFill put: value

	^self obj: bmFill at: GBTileFlag put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:18'!
bitmapWidthOf: bmFill

	^self obj: bmFill at: GBBitmapWidth! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/24/1998 22:17'!
bitmapWidthOf: bmFill put: value

	^self obj: bmFill at: GBBitmapWidth put: value! !

!BalloonEnginePlugin methodsFor: 'accessing bitmaps' stamp: 'ar 11/25/1998 16:39'!
colormapOf: bmFill
	self returnTypeC:'int *'.
	^objBuffer + bmFill + GBColormapOffset! !


!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/25/1998 21:33'!
bitmapValue: bmFill bits: bits atX: xp y: yp
	| bmDepth bmRaster value rShift cMask r g b a |
	self inline: true.
	bmDepth _ self bitmapDepthOf: bmFill.
	bmRaster _ self bitmapRasterOf: bmFill.
	bmDepth = 32 ifTrue:[
		value _ (self cCoerce: bits to:'int*') at: (bmRaster * yp) + xp.
		(value ~= 0 and:[(value bitAnd: 16rFF000000) = 0])
				ifTrue:[value _ value bitOr: 16rFF000000].
		^self uncheckedTransformColor: value].
	"rShift - shift value to convert from pixel to word index"
	rShift _ self rShiftTable at: bmDepth.
	value _ self makeUnsignedFrom: 
		((self cCoerce: bits to:'int*') at: (bmRaster * yp) + (xp >> rShift)).
	"cMask - mask out the pixel from the word"
	cMask _ (1 << bmDepth) - 1.
	"rShift - shift value to move the pixel in the word to the lowest bit position"
	rShift _ 32 - bmDepth - ((xp bitAnd: (1 << rShift - 1)) * bmDepth).
	value _ (value >> rShift) bitAnd: cMask.
	bmDepth = 16 ifTrue:[
		"Must convert by expanding bits"
		value = 0 ifFalse:[
			b _ (value bitAnd: 31) << 3.		b _ b + (b >> 5).
			g _ (value >> 5 bitAnd: 31) << 3.	g _ g + (g >> 5).
			r _ (value >> 10 bitAnd: 31) << 3.	r _ r + (r >> 5).
			a _ 255.
			value _ b + (g << 8) + (r << 16) + (a << 24)].
	] ifFalse:[
		"Must convert by using color map"
		(self bitmapCmSizeOf: bmFill) = 0
			ifTrue:[value _ 0]
			ifFalse:[value _ self makeUnsignedFrom: ((self colormapOf: bmFill) at: value)].
	].
	^self uncheckedTransformColor: value.! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/27/1998 14:19'!
clampValue: value max: maxValue

	self inline: true.
	value < 0 
		ifTrue:[^0]
		ifFalse:[value >= maxValue 
					ifTrue:[^maxValue-1]
					ifFalse:[^value]]! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/25/1998 19:46'!
fillBitmapSpan
	self inline: true.
	^self fillBitmapSpan: self lastExportedFillGet from: self lastExportedLeftXGet to: self lastExportedRightXGet at: self currentYGet! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/27/1998 14:23'!
fillBitmapSpan: bmFill from: leftX to: rightX at: yValue
	| x x1 dsX ds dtX dt deltaX deltaY bits xp yp bmWidth bmHeight fillValue tileFlag |
	self inline: false.
	self var: #bits declareC:'int *bits'.
	self aaLevelGet = 1
		ifFalse:[^self fillBitmapSpanAA: bmFill from: leftX to: rightX at: yValue].

	bits _ self loadBitsFrom: bmFill.
	bits == nil ifTrue:[^nil].
	bmWidth _ self bitmapWidthOf: bmFill.
	bmHeight _ self bitmapHeightOf: bmFill.
	tileFlag _ (self bitmapTileFlagOf: bmFill) = 1.
	deltaX _ leftX - (self fillOriginXOf: bmFill).
	deltaY _ yValue - (self fillOriginYOf: bmFill).
	dsX _ self fillDirectionXOf: bmFill.
	dtX _ self fillNormalXOf: bmFill.

	ds _ (deltaX * dsX) + (deltaY * (self fillDirectionYOf: bmFill)).
	dt _ (deltaX * dtX) + (deltaY * (self fillNormalYOf: bmFill)).

	x _ leftX.
	x1 _ rightX.
	[x < x1] whileTrue:[
		tileFlag ifTrue:[
			ds _ self repeatValue: ds max: bmWidth << 16.
			dt _ self repeatValue: dt max: bmHeight << 16].
		xp _ ds // 16r10000.
		yp _ dt // 16r10000.
		tileFlag ifFalse:[
			xp _ self clampValue: xp max: bmWidth.
			yp _ self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue _ self bitmapValue: bmFill bits: bits atX: xp y: yp.
			spanBuffer at: x put: fillValue.
		].
		ds _ ds + dsX.
		dt _ dt + dtX.
		x _ x + 1.
	].! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/27/1998 14:23'!
fillBitmapSpanAA: bmFill from: leftX to: rightX at: yValue
	| x dsX ds dtX dt deltaX deltaY bits xp yp bmWidth bmHeight fillValue baseShift cMask cShift idx aaLevel firstPixel lastPixel tileFlag |
	self inline: false.
	self var: #bits declareC:'int *bits'.
	bits _ self loadBitsFrom: bmFill.
	bits == nil ifTrue:[^nil].
	bmWidth _ self bitmapWidthOf: bmFill.
	bmHeight _ self bitmapHeightOf: bmFill.
	tileFlag _ (self bitmapTileFlagOf: bmFill) = 1.
	deltaX _ leftX - (self fillOriginXOf: bmFill).
	deltaY _ yValue - (self fillOriginYOf: bmFill).
	dsX _ self fillDirectionXOf: bmFill.
	dtX _ self fillNormalXOf: bmFill.

	ds _ (deltaX * dsX) + (deltaY * (self fillDirectionYOf: bmFill)).
	dt _ (deltaX * dtX) + (deltaY * (self fillNormalYOf: bmFill)).

	aaLevel _ self aaLevelGet.
	firstPixel _ self aaFirstPixelFrom: leftX to: rightX.
	lastPixel _ self aaLastPixelFrom: leftX to: rightX.
	baseShift _ self aaShiftGet.
	cMask _ self aaColorMaskGet.
	cShift _ self aaColorShiftGet.
	x _ leftX.
	[x < firstPixel] whileTrue:[
		tileFlag ifTrue:[
			ds _ self repeatValue: ds max: bmWidth << 16.
			dt _ self repeatValue: dt max: bmHeight << 16].
		xp _ ds // 16r10000.
		yp _ dt // 16r10000.
		tileFlag ifFalse:[
			xp _ self clampValue: xp max: bmWidth.
			yp _ self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue _ self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue _ (fillValue bitAnd: cMask) >> cShift.
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds _ ds + dsX.
		dt _ dt + dtX.
		x _ x + 1.
	].

	cMask _ (self aaColorMaskGet >> self aaShiftGet) bitOr: 16rF0F0F0F0.
	cShift _ self aaShiftGet.
	[x < lastPixel] whileTrue:[
		tileFlag ifTrue:[
			ds _ self repeatValue: ds max: bmWidth << 16.
			dt _ self repeatValue: dt max: bmHeight << 16].
		xp _ ds // 16r10000.
		yp _ dt // 16r10000.
		tileFlag ifFalse:[
			xp _ self clampValue: xp max: bmWidth.
			yp _ self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue _ self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue _ (fillValue bitAnd: cMask) >> cShift.
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds _ ds + (dsX << cShift).
		dt _ dt + (dtX << cShift).
		x _ x + aaLevel.
	].

	cMask _ self aaColorMaskGet.
	cShift _ self aaColorShiftGet.
	[x < rightX] whileTrue:[
		tileFlag ifTrue:[
			ds _ self repeatValue: ds max: bmWidth << 16.
			dt _ self repeatValue: dt max: bmHeight << 16].
		xp _ ds // 16r10000.
		yp _ dt // 16r10000.
		tileFlag ifFalse:[
			xp _ self clampValue: xp max: bmWidth.
			yp _ self clampValue: yp max: bmHeight].
		(xp >= 0 and:[yp >= 0 and:[xp < bmWidth and:[yp < bmHeight]]]) ifTrue:[
			fillValue _ self bitmapValue: bmFill bits: bits atX: xp y: yp.
			fillValue _ (fillValue bitAnd: cMask) >> cShift.
			idx _ x >> baseShift.
			spanBuffer at: idx put: (spanBuffer at: idx) + fillValue.
		].
		ds _ ds + dsX.
		dt _ dt + dtX.
		x _ x + 1.
	].
! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/27/1998 14:24'!
loadBitmapFill: formOop colormap: cmOop tile: tileFlag from: point1 along: point2 normal: point3 xIndex: xIndex
	"Load the bitmap fill."
	| bmFill cmSize cmBits bmBits bmBitsSize bmWidth bmHeight bmDepth ppw bmRaster |
	self var: #cmBits declareC:'int *cmBits'.
	self var: #point1 declareC:'int *point1'.
	self var: #point2 declareC:'int *point2'.
	self var: #point3 declareC:'int *point3'.

	cmOop == interpreterProxy nilObject ifTrue:[
		cmSize _ 0.
		cmBits _ nil.
	] ifFalse:[
		(interpreterProxy fetchClassOf: cmOop) == interpreterProxy classBitmap
			ifFalse:[^interpreterProxy primitiveFail].
		cmSize _ interpreterProxy slotSizeOf: cmOop.
		cmBits _ interpreterProxy firstIndexableField: cmOop.
	].
	(interpreterProxy isIntegerObject: formOop) 
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: formOop) 
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: formOop) < 5 
		ifTrue:[^interpreterProxy primitiveFail].
	bmBits _ interpreterProxy fetchPointer: 0 ofObject: formOop.
	(interpreterProxy fetchClassOf: bmBits) == interpreterProxy classBitmap
		ifFalse:[^interpreterProxy primitiveFail].
	bmBitsSize _ interpreterProxy slotSizeOf: bmBits.
	bmWidth _ interpreterProxy fetchInteger: 1 ofObject: formOop.
	bmHeight _ interpreterProxy fetchInteger: 2 ofObject: formOop.
	bmDepth _ interpreterProxy fetchInteger: 3 ofObject: formOop.
	interpreterProxy failed ifTrue:[^nil].
	(bmWidth >= 0 and:[bmHeight >= 0]) ifFalse:[^interpreterProxy primitiveFail].
	(bmDepth = 32) | (bmDepth = 8) | (bmDepth = 16) | 
		(bmDepth = 1) | (bmDepth = 2) | (bmDepth = 4)
			ifFalse:[^interpreterProxy primitiveFail].
	(cmSize = 0 or:[cmSize = (1 << bmDepth)])
		ifFalse:[^interpreterProxy primitiveFail].
	ppw _ 32 // bmDepth.
	bmRaster _ bmWidth + (ppw-1) // ppw.
	bmBitsSize = (bmRaster * bmHeight)
		ifFalse:[^interpreterProxy primitiveFail].
	bmFill _ self allocateBitmapFill: cmSize colormap: cmBits.
	engineStopped ifTrue:[^nil].
	self bitmapWidthOf: bmFill put: bmWidth.
	self bitmapHeightOf: bmFill put: bmHeight.
	self bitmapDepthOf: bmFill put: bmDepth.
	self bitmapRasterOf: bmFill put: bmRaster.
	self bitmapSizeOf: bmFill put: bmBitsSize.
	self bitmapTileFlagOf: bmFill put: tileFlag.
	self objectIndexOf: bmFill put: xIndex.
	self loadFillOrientation: bmFill
		from: point1 along: point2 normal: point3
		width: bmWidth height: bmHeight.
	^bmFill! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/25/1998 17:25'!
loadBitsFrom: bmFill
	"Note: Assumes that the contents of formArray has been checked before"
	| xIndex formOop bitsOop bitsLen |
	self returnTypeC:'int *'.
	xIndex _ self objectIndexOf: bmFill.
	xIndex > (interpreterProxy slotSizeOf: formArray) ifTrue:[^nil].
	formOop _ interpreterProxy fetchPointer: xIndex ofObject: formArray.
	bitsOop _ interpreterProxy fetchPointer: 0 ofObject: formOop.
	bitsLen _ interpreterProxy slotSizeOf: bitsOop.
	bitsLen = (self bitmapSizeOf: bmFill) ifFalse:[^nil].
	^interpreterProxy firstIndexableField: bitsOop! !

!BalloonEnginePlugin methodsFor: 'fills-bitmaps' stamp: 'ar 11/27/1998 14:14'!
repeatValue: delta max: maxValue
	| newDelta |
	self inline: true.
	newDelta _ delta.
	[newDelta < 0] whileTrue:[newDelta _ newDelta + maxValue].
	[newDelta >= maxValue] whileTrue:[newDelta _ newDelta - maxValue].
	^newDelta! !

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

BalloonEnginePlugin class
	instanceVariableNames: ''!

!BalloonEnginePlugin class methodsFor: 'class initialization' stamp: 'ar 11/11/1998 22:01'!
declareCVarsIn: cg
	"Nothing to declare"! !
BalloonEnginePlugin subclass: #BalloonEngineSimulation
	instanceVariableNames: 'bbObj '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 20:46'!
assert: bool
	bool ifFalse:[^self error:'Assertion failed'].! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/9/1998 01:23'!
circleCosTable
	^CArrayAccessor on:
#(1.0 0.98078528040323 0.923879532511287 0.831469612302545 0.7071067811865475 0.555570233019602 0.38268343236509 0.1950903220161286 0.0 -0.1950903220161283 -0.3826834323650896 -0.555570233019602 -0.707106781186547 -0.831469612302545 -0.9238795325112865 -0.98078528040323 -1.0 -0.98078528040323 -0.923879532511287 -0.831469612302545 -0.707106781186548 -0.555570233019602 -0.3826834323650903 -0.1950903220161287 0.0 0.1950903220161282 0.38268343236509 0.555570233019602 0.707106781186547 0.831469612302545 0.9238795325112865 0.98078528040323 1.0 )! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/9/1998 01:23'!
circleSinTable
	^CArrayAccessor on:
#(0.0 0.1950903220161282 0.3826834323650897 0.555570233019602 0.707106781186547 0.831469612302545 0.923879532511287 0.98078528040323 1.0 0.98078528040323 0.923879532511287 0.831469612302545 0.7071067811865475 0.555570233019602 0.38268343236509 0.1950903220161286 0.0 -0.1950903220161283 -0.3826834323650896 -0.555570233019602 -0.707106781186547 -0.831469612302545 -0.9238795325112865 -0.98078528040323 -1.0 -0.98078528040323 -0.923879532511287 -0.831469612302545 -0.707106781186548 -0.555570233019602 -0.3826834323650903 -0.1950903220161287 0.0 )! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/24/1998 20:50'!
colorTransform
	^super colorTransform asPluggableAccessor:
		(Array 
			with:[:obj :index| obj floatAt: index]
			with:[:obj :index :value| obj floatAt: index put: value])! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 13:32'!
copyBitsFrom: x0 to: x1 at: y
	bbObj copyBitsFrom: x0 to: x1 at: y.! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/29/1998 18:44'!
dispatchOn: anInteger in: selectorArray
	"Simulate a case statement via selector table lookup.
	The given integer must be between 0 and selectorArray size-1, inclusive.
	For speed, no range test is done, since it is done by the at: operation."
	self perform: (selectorArray at: (anInteger + 1)).! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/24/1998 20:50'!
edgeTransform
	^super edgeTransform asPluggableAccessor:
		(Array 
			with:[:obj :index| obj floatAt: index]
			with:[:obj :index :value| obj floatAt: index put: value])! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/29/1998 19:19'!
ioMicroMSecs
	^Time millisecondClockValue! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 01:05'!
loadBitBltFrom: oop
	bbObj _ oop.
	^true! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 14:05'!
loadPointIntAt: index from: intArray
	"Load the int value from the given index in intArray"
	^(index bitAnd: 1) = 0
		ifTrue:[(intArray getObject at: (index // 2) + 1) x]
		ifFalse:[(intArray getObject at: (index // 2) + 1) y]! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 14:04'!
loadPointShortAt: index from: intArray
	"Load the int value from the given index in intArray"
	^(index bitAnd: 1) = 0
		ifTrue:[(intArray getObject at: (index // 2) + 1) x]
		ifFalse:[(intArray getObject at: (index // 2) + 1) y]! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/28/1998 01:05'!
makeUnsignedFrom: integer
	integer < 0 
		ifTrue:[^(0 - integer - 1) bitInvert32]
		ifFalse:[^integer]! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/25/1998 19:24'!
rShiftTable
	^CArrayAccessor on: #(0 5 4 0 3 0 0 0 2 0 0 0 0 0 0 0 1).! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 13:54'!
shortRunLengthAt: i from: runArray
	^runArray getObject lengthAtRun: i+1! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 13:55'!
shortRunValueAt: i from: runArray
	^runArray getObject valueAtRun: i+1! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 10/31/1998 23:07'!
showDisplayBits
	"Do nothing."! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/4/1998 19:51'!
smallSqrtTable
	"Return a lookup table for rounded integer square root values from 0 to 31"
	^CArrayAccessor on:#(0 1 1 2 2 2 2 3 3 3 3 3 3 4 4 4 4 4 4 4 4 5 5 5 5 5 5 5 5 5 5 6 )! !

!BalloonEngineSimulation methodsFor: 'simulation' stamp: 'ar 11/25/1998 02:23'!
stopBecauseOf: stopReason
	"Don't stop because of need to flush."
	stopReason = GErrorNeedFlush ifFalse:[
		^super stopBecauseOf: stopReason.
	].! !


!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawBezier: line
	| canvas p1 p2 p3 |
	self assert:(self isBezier: line).
	p1 _ (self edgeXValueOf: line) @ (self edgeYValueOf: line) // self aaLevelGet.
	p2 _ (self bezierViaXOf: line) @ (self bezierViaYOf: line) // self aaLevelGet.
	p3 _ (self bezierEndXOf: line) @ (self bezierEndYOf: line) // self aaLevelGet.
	canvas _ Display getCanvas.
	canvas
		line: p1 to: p2 width: 2 color: Color blue;
		line: p2 to: p3 width: 2 color: Color blue.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/1/1998 01:16'!
debugDrawEdge: edge
	self assert: (self isEdge: edge).
	(self isLine: edge) ifTrue:[^self debugDrawLine: edge].
	(self isBezier: edge) ifTrue:[^self debugDrawBezier: edge].
	self halt.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawHLine: yValue
	| canvas |
	canvas _ Display getCanvas.
	canvas
		line: 0 @ (yValue // self aaLevelGet)
		to: Display extent x @ (yValue // self aaLevelGet)
		width: 2
		color: Color green.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawLine: line
	| canvas |
	self assert: (self isLine: line).
	canvas _ Display getCanvas.
	canvas
		line: (self edgeXValueOf: line) @ (self edgeYValueOf: line) // self aaLevelGet
		to: (self lineEndXOf: line) @ (self lineEndYOf: line) // self aaLevelGet
		width: 2
		color: Color red.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawLineFrom: pt1 to: pt2
	| canvas |
	canvas _ Display getCanvas.
	canvas
		line: (pt1 at: 0) @ (pt1 at: 1) // self aaLevelGet
		to: (pt2 at: 0) @ (pt2 at: 1) // self aaLevelGet
		width: 1
		color: Color red.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawPt: pt
	| canvas |
	canvas _ Display getCanvas.
	canvas
		fillRectangle:((pt-2) corner: pt+2) color: Color red! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 5/25/2000 17:58'!
debugDrawPtLineFrom: pt1 to: pt2
	| canvas |
	canvas _ Display getCanvas.
	canvas
		line: pt1
		to: pt2
		width: 1
		color: Color red.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/25/1998 00:43'!
debugPrintObjects
	| object end |
	self inline: false.
	object _ 0.
	end _ objUsed.
	[object < end] whileTrue:[
		Transcript cr; 
			nextPut:$#; print: object; space;
			print: (self objectHeaderOf: object); space.
		(self isEdge: object) 
			ifTrue:[Transcript nextPutAll:'(edge) '].
		(self isFill:object)
			ifTrue:[Transcript nextPutAll:'(fill) '].
		Transcript print: (self objectLengthOf: object); space.
		Transcript endEntry.
		object _ object + (self objectLengthOf: object).
	].! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/1/1998 17:21'!
debugPrintPoints: n
	Transcript cr.
	n > 0 ifTrue:[
		Transcript print: (self point1Get at: 0) @ (self point1Get at: 1); space.
	].
	n > 1 ifTrue:[
		Transcript print: (self point2Get at: 0) @ (self point2Get at: 1); space.
	].
	n > 2 ifTrue:[
		Transcript print: (self point3Get at: 0) @ (self point3Get at: 1); space.
	].
	n > 3 ifTrue:[
		Transcript print: (self point4Get at: 0) @ (self point4Get at: 1); space.
	].
	Transcript endEntry.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/5/1998 21:15'!
printAET

	| edge |
	Transcript cr; show:'************* ActiveEdgeTable **************'.
	0 to: self aetUsedGet - 1 do:[:i|
		edge _ aetBuffer at: i.
		Transcript cr;
			print: i; space;
			nextPutAll:'edge #';print: edge; space;
			nextPutAll:'x: '; print: (self edgeXValueOf: edge); space;
			nextPutAll:'y: '; print: (self edgeYValueOf: edge); space;
			nextPutAll:'z: '; print: (self edgeZValueOf: edge); space;
			nextPutAll:'fill0: '; print: (self edgeLeftFillOf: edge); space;
			nextPutAll:'fill1: '; print: (self edgeRightFillOf: edge); space;
			nextPutAll:'lines: '; print: (self edgeNumLinesOf: edge); space.
		(self areEdgeFillsValid: edge) ifFalse:[Transcript nextPutAll:' disabled'].
		Transcript endEntry.
	].! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 11/5/1998 21:14'!
printGET

	| edge |
	Transcript cr; show:'************* GlobalEdgeTable **************'.
	0 to: self getUsedGet - 1 do:[:i|
		edge _ getBuffer at: i.
		Transcript cr;
			print: i; space;
			nextPutAll:'edge #';print: edge; space;
			nextPutAll:'x: '; print: (self edgeXValueOf: edge); space;
			nextPutAll:'y: '; print: (self edgeYValueOf: edge); space;
			nextPutAll:'z: '; print: (self edgeZValueOf: edge); space;
			nextPutAll:'fill0: '; print: (self edgeLeftFillOf: edge); space;
			nextPutAll:'fill1: '; print: (self edgeRightFillOf: edge); space;
			nextPutAll:'lines: '; print: (self edgeNumLinesOf: edge); space.
		(self areEdgeFillsValid: edge) ifFalse:[Transcript nextPutAll:' disabled'].
		Transcript endEntry.
	].! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 21:57'!
quickPrint: curve
	Transcript nextPut:$(;
		print: curve start;
		space;
		print: curve via;
		space;
		print: curve end;
		nextPut:$).! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 22:18'!
quickPrintBezier: bezier
	Transcript cr.
	Transcript nextPut:$(;
		print: (self edgeXValueOf: bezier)@(self edgeYValueOf: bezier);
		space;
		print: (self bezierViaXOf: bezier)@(self bezierViaYOf: bezier);
		space;
		print: (self bezierEndXOf: bezier)@(self bezierEndYOf: bezier);
		nextPut:$).
	Transcript endEntry.! !

!BalloonEngineSimulation methodsFor: 'debug support' stamp: 'ar 10/30/1998 22:00'!
quickPrintBezier: index first: aBool
	aBool ifTrue:[Transcript cr].
	Transcript nextPut:$(;
		print: (self bzStartX: index)@(self bzStartY: index);
		space;
		print: (self bzViaX: index)@(self bzViaY: index);
		space;
		print: (self bzEndX: index)@(self bzEndY: index);
		nextPut:$).
	Transcript endEntry.! !


!BalloonEngineSimulation methodsFor: 'initialize' stamp: 'ar 1/12/1999 10:38'!
initialize
	doProfileStats _ false.! !

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

BalloonEngineSimulation class
	instanceVariableNames: ''!

!BalloonEngineSimulation class methodsFor: 'instance creation' stamp: 'ar 10/29/1998 19:18'!
new
	^super new initialize! !
Object subclass: #BalloonFillData
	instanceVariableNames: 'index minX maxX yValue source destForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
destForm
	^destForm! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
destForm: aForm
	destForm _ aForm! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
index
	^index! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
index: anInteger
	index _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
maxX
	^maxX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
maxX: anInteger
	maxX _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
minX
	^minX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
minX: anInteger
	minX _ anInteger! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
source
	^source! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'!
source: anObject
	source _ anObject! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'!
width
	^maxX - minX! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
yValue
	^yValue! !

!BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'!
yValue: anInteger
	yValue _ anInteger! !


!BalloonFillData methodsFor: 'computing' stamp: 'ar 11/14/1998 19:32'!
computeFill
	(destForm isNil or:[destForm width < self width]) ifTrue:[
		destForm _ Form extent: (self width + 10) @ 1 depth: 32.
	].
	source computeFillFrom: minX to: maxX at: yValue in: destForm! !
Object subclass: #BalloonLineSimulation
	instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
end
	^end! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
end: aPoint
	end _ aPoint! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialX
	^start y <= end y
		ifTrue:[start x]
		ifFalse:[end x]! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialY
	^start y <= end y
		ifTrue:[start y]
		ifFalse:[end y]! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'!
initialZ
	^0 "Assume no depth given"! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
start
	^start! !

!BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'!
start: aPoint
	start _ aPoint! !


!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:52'!
computeInitialStateFrom: source with: aTransformation
	"Compute the initial state in the receiver."
	start _ (aTransformation localPointToGlobal: source start) asIntegerPoint.
	end _ (aTransformation localPointToGlobal: source end) asIntegerPoint.! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:22'!
stepToFirstScanLineAt: yValue in: edgeTableEntry
	"Compute the initial x value for the scan line at yValue"
	|  startX endX startY endY yDir deltaY deltaX widthX |
	(start y) <= (end y) ifTrue:[
		startX _ start x.	endX _ end x.
		startY _ start y.	endY _ end y.
		yDir _ 1.
	] ifFalse:[
		startX _ end x.	endX _ start x.
		startY _ end y.	endY _ start y.
		yDir _ -1.
	].

	deltaY _ endY - startY.
	deltaX _ endX - startX.

	"Quickly check if the line is visible at all"
	(yValue >= endY or:[deltaY = 0]) ifTrue:[^edgeTableEntry lines: 0].

	"Check if edge goes left to right"
	deltaX >= 0 ifTrue:[
		xDirection _ 1.
		widthX _ deltaX.
		error _ 0.
	] ifFalse:[
		xDirection _ -1.
		widthX _ 0 - deltaX.
		error _ 1 - deltaY.
	].

	"Check if edge is horizontal"
	deltaY = 0 
		ifTrue:[	xIncrement _ 0.
				errorAdjUp _ 0]
		ifFalse:["Check if edge is y-major"
			deltaY > widthX 
				ifTrue:[	xIncrement _ 0.
						errorAdjUp _ widthX]
				ifFalse:[	xIncrement _ (widthX // deltaY) * xDirection.
						errorAdjUp _ widthX \\ deltaY]].

	errorAdjDown _ deltaY.

	edgeTableEntry xValue: startX.
	edgeTableEntry lines: deltaY.

	"If not at first scan line then step down to yValue"
	yValue = startY ifFalse:[
		startY to: yValue do:[:y| self stepToNextScanLineAt: y in: edgeTableEntry].
		"And adjust remainingLines"
		edgeTableEntry lines: deltaY - (yValue - startY).
	].! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 20:39'!
stepToNextScanLineAt: yValue in: edgeTableEntry
	"Compute the next x value for the scan line at yValue.
	This message is sent during incremental updates. 
	The yValue parameter is passed in here for edges
	that have more complicated computations,"
	| x |
	x _ edgeTableEntry xValue + xIncrement.
	error _ error + errorAdjUp.
	error > 0 ifTrue:[
		x _ x + xDirection.
		error _ error - errorAdjDown.
	].
	edgeTableEntry xValue: x.! !

!BalloonLineSimulation methodsFor: 'computing' stamp: 'ar 10/29/1998 23:42'!
subdivide
	^nil! !


!BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPutAll:' - ';
		print: end;
		nextPut:$)! !

!BalloonLineSimulation methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:57'!
printOnStream: aStream
	aStream 
		print: self class name;
		print:'(';
		write: start;
		print:' - ';
		write: end;
		print:')'.! !
PolygonMorph subclass: #BalloonMorph
	instanceVariableNames: 'target offsetFromTarget balloonOwner '
	classVariableNames: 'BalloonColor BalloonFont '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!BalloonMorph commentStamp: '<historical>' prior: 0!
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.

Balloons should not be duplicated with veryDeepCopy unless their target is also duplicated at the same time.!


!BalloonMorph methodsFor: 'initialization' stamp: 'sma 11/11/2000 16:08'!
initialize
	super initialize.
	self beSmoothCurve.
	color _ self class balloonColor.
	borderColor _ Color black.
	borderWidth _ 1.
	offsetFromTarget _ 0@0! !

!BalloonMorph methodsFor: 'initialization' stamp: 'ar 10/4/2000 10:13'!
popUpFor: aMorph hand: aHand
	"Pop up the receiver as balloon help for the given hand"
	balloonOwner _ aMorph.
	self popUpForHand: aHand.! !

!BalloonMorph methodsFor: 'initialization' stamp: 'ar 12/14/2000 23:59'!
popUpForHand: aHand
	"Pop up the receiver as balloon help for the given hand"
	| worldBounds |
	self lock.
	self fullBounds. "force layout"
	aHand world addMorphFront: self.
	"So that if the translation below makes it overlap the receiver, it won't
	interfere with the rootMorphsAt: logic and hence cause flashing.  Without
	this, flashing happens, believe me!!"
	((worldBounds _ aHand world bounds) containsRect: self bounds) ifFalse:
		[self bounds: (self bounds translatedToBeWithin: worldBounds)].
	aHand balloonHelp: self.! !


!BalloonMorph methodsFor: 'stepping' stamp: 'sma 12/23/1999 14:05'!
step
	"Move with target."

	target ifNotNil: [self position: target position + offsetFromTarget].
! !

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


!BalloonMorph methodsFor: 'private' stamp: 'sw 2/7/2000 01:49'!
adjustedCenter
	"This horizontal adjustment is needed because we want the interior TextMorph to be centered within the visual balloon rather than simply within the BalloonMorph's bounding box.  Without this, balloon-help text would be a bit off-center"

	^ self center + (offsetFromTarget x sign * (5 @ 0))! !

!BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'!
setTarget: aMorph
	(target _ aMorph) ifNotNil: [offsetFromTarget _ self position - target position]! !


!BalloonMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 18:07'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^5		"Balloons are very front-like things"! !


!BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'!
balloonOwner
	^balloonOwner! !


!BalloonMorph methodsFor: 'testing' stamp: 'ar 9/15/2000 17:56'!
isBalloonHelp
	^true! !


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

BalloonMorph class
	instanceVariableNames: ''!

!BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'!
string: str for: morph
	^ self string: str for: morph corner: #bottomLeft! !

!BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:04'!
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"

	| tm vertices |
	tm _ self getTextMorph: str.
	vertices _ self getVertices: tm bounds.
	vertices _ self getBestLocation: vertices for: morph corner: cornerName.
	^ self new
		color: morph balloonColor;
		setVertices: vertices;
		addMorph: tm;
		setTarget: morph! !


!BalloonMorph class methodsFor: 'private' stamp: 'sw 10/26/2000 09:44'!
getBestLocation: vertices for: morph corner: cornerName
	"Try four rel locations of the balloon for greatest unclipped area.   12/99 sma"

	| rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea |
	rect _ vertices first rect: (vertices at: 5).
	maxArea _ -1.
	verts _ vertices.
	usableArea _ (morph world ifNil: [self currentWorld]) viewBox.
	1 to: 4 do: [:i |
		dir _ #(vertical horizontal) atWrap: i.
		verts _ verts collect: [:p | p flipBy: dir centerAt: rect center].
		rectCorner _ #(bottomLeft bottomRight topRight topLeft) at: i.
		morphPoint _ #(topCenter topCenter bottomCenter bottomCenter) at: i.
		a _ ((rect
			align: (rect perform: rectCorner)
			with: (mbc _ morph boundsForBalloon perform: morphPoint))
				intersect: usableArea) area.
		(a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue:
			[maxArea _ a.
			bestVerts _ verts.
			mp _ mbc]].
	result _ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:".
	^ result! !

!BalloonMorph class methodsFor: 'private' stamp: 'sw 2/2/2000 22:13'!
getTextMorph: aStringOrMorph
	"Construct text morph."

	| m text |
	aStringOrMorph isMorph
		ifTrue: [m _ aStringOrMorph]
		ifFalse:
			[BalloonFont
				ifNil: [text _ aStringOrMorph]
				ifNotNil: [text _ Text
					string: aStringOrMorph
					attribute: (TextFontReference toFont: BalloonFont)].
			m _ (TextMorph new contents: text) centered].
	m setToAdhereToEdge: #adjustedCenter.
	^ m! !

!BalloonMorph class methodsFor: 'private' stamp: 'sma 12/23/1999 15:34'!
getVertices: bounds
	"Construct vertices for a balloon up and to left of anchor"

	| corners |
	corners _ bounds corners atAll: #(1 4 3 2).
	^ (Array
		with: corners first + (0 - bounds width // 3 @ 0)
		with: corners first + (0 - bounds width // 6 @ (bounds height // 2))) , corners! !


!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'!
balloonColor
	^ BalloonColor! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:43'!
balloonFont
	^ BalloonFont! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:39'!
chooseBalloonFont
	"BalloonMorph chooseBalloonFont"

	Preferences chooseFontWithPrompt:  'Select the font to be
used for balloon help'
		andSendTo: self withSelector: #setBalloonFontTo:! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'!
setBalloonColorTo: aColor 
	aColor ifNotNil: [BalloonColor _ aColor]! !

!BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:40'!
setBalloonFontTo: aFont
	aFont ifNotNil: [BalloonFont _ aFont]! !
RectangleMorph subclass: #BalloonRectangleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!

!BalloonRectangleMorph methodsFor: 'initialize' stamp: 'ar 11/15/1998 22:31'!
initialize
	super initialize.
	color _ GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}.
	color radial: true.
	borderColor _ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}.
	borderWidth _ 10.
	self extent: 100@100.! !


!BalloonRectangleMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 22:24'!
doesBevels
	"To return true means that this object can show bevelled borders, and
	therefore can accept, eg, #raised or #inset as valid borderColors.
	Must be overridden by subclasses that do not support bevelled borders."

	^ false! !


!BalloonRectangleMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 22:20'!
newTransformationMorph
	^MatrixTransformMorph new! !


!BalloonRectangleMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:40'!
drawOn: aCanvas
	(color isKindOf: OrientedFillStyle) ifTrue:[
		color origin: bounds center.
		color direction: (bounds extent x * 0.7) @ 0.
		color normal: 0@(bounds extent y * 0.7).
	].
	(borderColor isKindOf: OrientedFillStyle) ifTrue:[
		borderColor origin: bounds topLeft.
		borderColor direction: (bounds extent x) @ 0.
		borderColor normal: 0@(bounds extent y).
	].
	aCanvas asBalloonCanvas
		drawRectangle: (bounds insetBy: borderWidth // 2)
		color: color
		borderWidth: borderWidth
		borderColor: borderColor.! !
Object subclass: #BalloonSolidFillSimulation
	instanceVariableNames: 'color '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Simulation'!

!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:07'!
computeFillFrom: minX to: maxX at: yValue in: form
	| bb |
	color isTransparent ifFalse:[
		bb _ BitBlt toForm: form.
		bb fillColor: color.
		bb destX: 0 destY: 0 width: (maxX - minX) height: 1.
		bb combinationRule: Form over.
		bb copyBits].! !

!BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'!
computeInitialStateFrom: source with: aColorTransform
	color _ source asColor.! !
Object subclass: #BalloonState
	instanceVariableNames: 'transform colorTransform aaLevel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Engine'!

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'!
aaLevel
	^aaLevel! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:47'!
aaLevel: aNumber
	aaLevel _ aNumber! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
colorTransform
	^colorTransform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
colorTransform: aColorTransform
	colorTransform _ aColorTransform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'!
transform
	^transform! !

!BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'!
transform: aMatrixTransform
	transform _ aMatrixTransform! !
MimeConverter subclass: #Base64MimeConverter
	instanceVariableNames: 'data '
	classVariableNames: 'FromCharTable ToCharTable '
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Base64MimeConverter commentStamp: '<historical>' 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: '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 2/19/2000 15:53'!
decodeInteger: mimeString
	| bytes sum |
	"Decode the MIME string into an integer of any length"

	bytes _ (Base64MimeConverter mimeDecodeToBytes: 
				(ReadStream on: mimeString)) contents.
	sum _ 0.
	bytes reverseDo: [:by | sum _ sum * 256 + by].
	^ sum! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 2/21/2000 17:22'!
encodeInteger: int
	| strm |
	"Encode an integer of any length and return the MIME string"

	strm _ ReadWriteStream on: (ByteArray new: int digitLength).
	1 to: int digitLength do: [:ii | strm nextPut: (int digitAt: ii)].
	strm reset.
	^ ((self mimeEncode: strm) contents) copyUpTo: $=	"remove padding"! !

!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! !
RectangleMorph subclass: #BasicButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!BasicButton commentStamp: '<historical>' prior: 0!
A minimalist button-like object intended for use with the tile-scripting system.!


!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1998 17:02'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label...' action: #setLabel.! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 17:36'!
initialize
	super initialize.
	self borderWidth: 1.
	self borderColor: Color yellow darker.
	self useRoundedCorners.
	self color: Color yellow.
	self label: 'Button'! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1998 16:49'!
label
	| s |
	s _ ''.
	self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s _ m contents]].
	^ s! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 12/7/1999 18:14'!
label: aString

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: TextStyle defaultFont.
	self extent: m extent + (borderWidth + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 12/10/1999 09:07'!
label: aString font: aFontOrNil

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [Preferences standardButtonFont].
	m _ StringMorph contents: aString font: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!BasicButton methodsFor: 'as yet unclassified' stamp: 'sw 12/10/1999 09:08'!
setLabel
	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Enter a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel font: nil].
! !

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

BasicButton class
	instanceVariableNames: ''!

!BasicButton class methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1998 16:58'!
defaultNameStemForInstances
	^ 'button'! !
Object subclass: #Behavior
	instanceVariableNames: 'superclass methodDict format '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Behavior commentStamp: '<historical>' prior: 0!
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' stamp: 'ar 7/19/1999 23:00'!
forgetDoIts
	"get rid of old DoIt methods"
	self 
		removeSelectorSimply: #DoIt;
		removeSelectorSimply: #DoItIn:! !

!Behavior methodsFor: 'initialize-release' stamp: 'di 3/10/2000 08:40'!
nonObsoleteClass
	"Attempt to find and return the current version of this obsolete class"

	| obsName |
	obsName _ self name.
	[obsName beginsWith: 'AnObsolete']
		whileTrue: [obsName _ obsName copyFrom: 'AnObsolete' size + 1 to: obsName size].
	^ Smalltalk at: obsName asSymbol! !

!Behavior methodsFor: 'initialize-release' stamp: 'ar 9/10/1999 17:33'!
obsolete
	"Invalidate and recycle local messages,
	e.g., zap the method dictionary if can be done safely."
	self canZapMethodDictionary
		ifTrue:[ methodDict _ MethodDictionary new ].! !

!Behavior methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 16:39'!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver.
	Must only be sent to a new instance; else we would need Object flushCache."
	superclass _ aClass.
	format _ fmt.
	methodDict _ mDict.! !


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

	^Compiler! !

!Behavior methodsFor: 'accessing' stamp: 'sw 3/10/2000 16:55'!
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."

	| count aMenu answer caption allCalls |
	allCalls _ Smalltalk allCallsOn: aSelector.
	(count _ allCalls size) == 0 ifTrue: [^ 1].  "no senders -- let the removal happen without warning"
	count == 1 ifTrue:
		[MessageSet parse: allCalls first toClassAndSelector:
			[:aClass :aSel |
				(aClass == self and: [aSel == aSelector]) ifTrue: [^ 1]]].   "only sender is itself"

	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! !

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

	^Decompiler! !

!Behavior methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:17'!
environment
	"Return the environment in which the receiver is visible"
	^Smalltalk! !

!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' stamp: 'di 3/27/1999 23:19'!
methodDict
	methodDict == nil ifTrue: [self recoverFromMDFault].
	^ methodDict! !

!Behavior methodsFor: 'accessing' stamp: 'rca 7/26/2000 16:53'!
name
	"Answer a String that is the name of the receiver."
	^'a subclass of ', superclass name! !

!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: 'accessing' stamp: 'ar 7/13/1999 22:00'!
typeOfClass
	"Answer a symbol uniquely describing the type of the receiver"
	self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!"
	self isBytes ifTrue:[^#bytes].
	(self isWords and:[self isPointers not]) ifTrue:[^#words].
	self isWeak ifTrue:[^#weak].
	self isVariable ifTrue:[^#variable].
	^#normal.! !


!Behavior methodsFor: 'testing' stamp: 'ar 7/15/1999 14:03'!
autoMutateInstances
	"Return true if the receiver should automatically mutate its instances to a new class layout on recompilation."
	^true! !

!Behavior methodsFor: 'testing' stamp: 'ar 9/10/1999 17:29'!
canZapMethodDictionary
	"Return true if it is safe to zap the method dictionary on #obsolete"
	^true! !

!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' stamp: 'ar 7/9/1999 18:18'!
isBehavior
	"Return true if the receiver is a behavior"
	^true! !

!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' stamp: 'ar 7/14/1999 02:38'!
isObsolete
	"Return true if the receiver is obsolete."
	^self instanceCount = 0! !

!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' stamp: 'ar 3/21/98 02:36'!
isWeak
	"Answer whether the receiver has contains weak references."
	^ self instSpec = 4! !

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

	^self isBytes not! !

!Behavior methodsFor: 'testing' stamp: 'ar 7/11/1999 05:36'!
shouldNotBeRedefined
	"Return true if the receiver should not be redefined.
	The assumption is that compact classes,
	classes in Smalltalk specialObjects and 
	Behaviors should not be redefined"
	^(Smalltalk compactClassesArray includes: self)
		or:[(Smalltalk specialObjectsArray includes: self)
			or:[self isKindOf: self]]! !


!Behavior methodsFor: 'copying' stamp: 'di 2/17/2000 22:37'!
copy
	"Answer a copy of the receiver without a list of subclasses."

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

!Behavior methodsFor: 'copying' stamp: 'di 2/17/2000 22:37'!
copyOfMethodDictionary
	"Return a copy of the receiver's method dictionary"

	^ self methodDict copy! !

!Behavior methodsFor: 'copying' stamp: 'tk 4/16/1999 17:30'!
deepCopy
	"Classes should only be shallowCopied or made anew."

^ self shallowCopy! !


!Behavior methodsFor: 'printing' stamp: 'sw 10/13/2000 12:59'!
defaultNameStemForInstances
	"Answer a basis for external names for default instances of the receiver.  For classees, the class-name itself is a good one."

	^ 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' stamp: 'MPW 1/1/1901 21:56'!
printOnStream: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream print: 'a descendent of '; write:superclass.! !

!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' stamp: 'ar 7/10/1999 12:10'!
superclass: aClass 
	"Change the receiver's superclass to be aClass."
	"Note: Do not use 'aClass isKindOf: Behavior' here
		in case we recompile from Behavior itself."
	(aClass == nil or: [aClass isBehavior])
		ifTrue: [superclass _ aClass.
				Object flushCache]
		ifFalse: [self error: 'superclass must be a class-describing object']! !


!Behavior methodsFor: 'creating method dictionary' stamp: 'di 2/17/2000 22:41'!
addSelector: selector withMethod: compiledMethod 
	"Add the message selector with the corresponding compiled method to the 
	receiver's method dictionary."

	| oldMethod |
	oldMethod _ self lookupSelector: selector.
	self methodDict at: selector put: compiledMethod.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethod == nil ifFalse: [oldMethod flushCache].
	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' stamp: 'di 9/10/1999 15:53'!
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"
	"ar 7/10/1999: Use oldClass selectors not self selectors"
	oldClass selectorsDo: [:sel | self recompile: sel from: oldClass].
	Smalltalk currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'di 2/17/2000 22:37'!
compress
	"Compact the method dictionary of the receiver."

	self 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' stamp: 'ar 7/11/1999 05:11'!
methodDictionary
	"Convenience"
	^self methodDict! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'ar 7/12/1999 07:45'!
methodDictionary: aDictionary 
	"Store the argument, aDictionary, as the method dictionary of the 
	receiver."
	methodDict _ aDictionary.! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'di 5/24/2000 16:05'!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."
	"ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:"
	| method trailer methodNode |
	method _ oldClass compiledMethodAt: selector.
	trailer _ (method endPC + 1 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 4/1/2000 10:11'!
recompileNonResidentMethod: method atSelector: selector from: oldClass
	"Recompile the method supplied in the context of this class."

	| trailer methodNode |
	trailer _ (method size - 3 to: method size) collect: [:i | method at: i].
	methodNode _ self compilerClass new
				compile: (method getSourceFor: selector in: oldClass)
				in: self
				notifying: nil
				ifFail: ["We're in deep doo-doo if this fails (syntax error).
						Presumably the user will correct something and proceed,
						thus installing the result in this methodDict.  We must
						retrieve that new method, and restore the original (or remove)
						and then return the method we retrieved."
						^ self error: 'see comment'].
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	^ methodNode generate: trailer
! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'di 1/2/1999 15:16'!
removeSelector: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method."

	^ self removeSelectorSimply: selector! !


!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' stamp: 'di 8/18/2000 22:10'!
basicNew: sizeRequested 
	"Primitive. Answer an instance of this class with the number
	of indexable variables specified by the argument, sizeRequested.
	Fail if this class is not indexable or if the argument is not a
	positive Integer, or if there is not enough memory available. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 71>
	self isVariable ifFalse:
		[self error: self printString, ' cannot have variable sized instances'].
	(sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue:
		["arg okay; space must be low."
		Smalltalk signalLowSpace.
		^ self basicNew: sizeRequested  "retry if user proceeds"].
	self primitiveFailed! !

!Behavior methodsFor: 'instance creation' stamp: 'sw 5/4/2000 20:47'!
initializedInstance
	"Answer an instance of the receiver which in some sense is initialized.  In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu.   Return nil if the receiver is reluctant for some reason to return such a thing"

	^ self new! !

!Behavior methodsFor: 'instance creation' stamp: 'di 8/18/2000 20:27'!
new
	"Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."

	<primitive: 70>  "This method runs primitively if successful"
	^ self basicNew  "Exceptional conditions will be handled in basicNew"
! !

!Behavior methodsFor: 'instance creation' stamp: 'di 8/18/2000 20:32'!
new: sizeRequested 
	"Answer an instance of this class with the number of indexable
	variables specified by the argument, sizeRequested."

	<primitive: 71>  "This method runs primitively if successful"
	^ self basicNew: sizeRequested  "Exceptional conditions will be handled in basicNew:"
! !


!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'!
superclass
	"Answer the receiver's superclass, a Class."

	^superclass! !

!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' stamp: 'bf 9/27/1999 17:23'!
>> selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^self compiledMethodAt: selector 
! !

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

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

	"Point allSelectors"! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 10/19/1999 15:12'!
changeRecordsAt: selector
	"Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one.  Return nil if the method is absent."

	"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
	| aList |
	aList _ VersionsBrowser new
			scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil])
			class: self meta: self isMeta
			category: (self whichCategoryIncludesSelector: selector)
			selector: selector.
	^ aList ifNotNil: [aList changeList]! !

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

	^ self methodDict at: selector! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'!
compiledMethodAt: selector ifAbsent: aBlock
	"Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"

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

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

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

	| sourceString commentStart  pos nextQuotePos |

	sourceString _ (self sourceCodeAt: selector) asString.
	sourceString size == 0 ifTrue: [^ ''].
	commentStart _ sourceString findString: '"' startingAt: 1.
	commentStart == 0 ifTrue: [^ ''].
	pos _ commentStart + 1.
	[(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)]
		whileTrue:
			[pos _ nextQuotePos + 2].
	
	commentStart == nextQuotePos ifTrue: [^ ''].  "Must have been a quote in string literal"

	^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'


"Behavior firstCommentAt: #firstCommentAt:"! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 12/5/2000 08:53'!
firstPrecodeCommentFor:  selector
	"If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil"

	| parser lastHeaderChar firstCommentPosition |
	"Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:"

	(parser _ self parserClass new) parseSelector: (self sourceCodeAt: selector).
	lastHeaderChar _ parser endOfLastToken.
	firstCommentPosition _ self positionOfFirstCommentAt: selector.
	^ (firstCommentPosition == nil or: [firstCommentPosition <= (lastHeaderChar + 4)])
		ifFalse:
			[nil]
		ifTrue:
			[self firstCommentAt: selector]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 4/26/1999 07:28'!
formalParametersAt: aSelector
	"Return the names of the arguments used in this method."

	| source parser message list params |
	source _ self sourceCodeAt: aSelector ifAbsent: [^ #()].	"for now"
	(parser _ self parserClass new) parseSelector: source.
	message _ source copyFrom: 1 to: (parser endOfLastToken min: source size).
	list _ message string findTokens: Character separators.
	params _ OrderedCollection new.
	list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]].
	^ params! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'!
lookupSelector: selector
	"Look up the given selector in my methodDictionary.
	Return the corresponding method if found.
	Otherwise chase the superclass chain and try again.
	Return nil if no method is found."
	| lookupClass |
	lookupClass _ self.
	[lookupClass == nil]
		whileFalse: 
			[(lookupClass includesSelector: selector)
				ifTrue: [^ lookupClass compiledMethodAt: selector].
			lookupClass _ lookupClass superclass].
	^ nil! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 12/1/2000 20:25'!
methodHeaderFor: selector 
	"Answer the string corresponding to the method header for the given selector"

	| sourceString parser |
	sourceString _ self ultimateSourceCodeAt: selector ifAbsent: [self error: 'not found'].
	(parser _ self parserClass new) parseSelector: sourceString.
	^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size)

"Behavior methodHeaderFor: #methodHeaderFor: "
! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'!
methodsDo: aBlock
	"Evaluate aBlock for all the compiled methods in my method dictionary."

	^ self methodDict valuesDo: aBlock! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/30/2000 10:29'!
positionOfFirstCommentAt:  aSelector
	"Answer the position in the source string associated with aSelector of the first comment therein, or an empty string if none"

	| sourceString commentStart  |
	sourceString _ (self sourceCodeAt: aSelector) asString.
	sourceString size == 0 ifTrue: [^ 0].
	commentStart _ sourceString findString: '"' startingAt: 1.
	^ commentStart! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 12/5/2000 11:06'!
precodeCommentOrInheritedCommentFor:  selector
	"Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code.  If the version recorded in the receiver is uncommented, look up the inheritance chain.  Return an empty string if none found.  Not smart enough to bypass quotes in string constants, but does map doubled quote into a single quote."

	| aSuper aComment |
	^ (aComment _ self firstPrecodeCommentFor: selector) isEmptyOrNil
		ifFalse:
			[aComment]
		ifTrue:
			[(self == Behavior or: [superclass == nil or:
							[(aSuper _ superclass classThatUnderstands: selector) == nil]])
				ifTrue:
					['']
				ifFalse:
					[aSuper precodeCommentOrInheritedCommentFor: selector]]

"Utilities class precodeCommentOrInheritedCommentFor: #testingComment"! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 3/27/1999 13:02'!
rootStubInImageSegment: imageSegment 

	^ ImageSegmentRootStub new
		xxSuperclass: superclass
		format: format
		segment: imageSegment! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 3/27/1999 23:21'!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

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

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:38'!
selectors
	"Answer a Set of all the message selectors specified in the receiver's 
	method dictionary."

	^ self methodDict keys  

	"Point selectors."! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'!
selectorsAndMethodsDo: aBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^ self methodDict keysAndValuesDo: aBlock! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:38'!
selectorsDo: selectorBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^ self methodDict keysDo: selectorBlock! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 3/24/1999 07:44'!
selectorsWithArgs: numberOfArgs
	"Return all selectors defined in this class that take this number of arguments.  Could use String.keywords.  Could see how compiler does this."

	| list num |
	list _ OrderedCollection new.
	self selectorsDo: [:aSel | 
		num _ aSel count: [:char | char == $:].
		num = 0 ifTrue: [aSel last isLetter ifFalse: [num _ 1]].
		num = numberOfArgs ifTrue: [list add: aSel]].
	^ list! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:40'!
sourceCodeAt: selector

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

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:40'!
sourceCodeAt: selector ifAbsent: aBlock

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

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

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

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

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


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

	^superclass allClassVarNames! !

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

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

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

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

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

	^superclass allSharedPools! !

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

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

	^Set new! !

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

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

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

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

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

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

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

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

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

	^ OrderedCollection new! !

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

	<primitive: 77>
	^nil! !

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


!Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'!
includesBehavior: aClass
	^self == aClass or:[self inheritsFrom: aClass]! !

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

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

!Behavior methodsFor: 'testing class hierarchy' stamp: 'sma 11/11/2000 14:09'!
kindOfSubclass 
	"Answer a String that is the keyword that describes the receiver's kind
	of subclass, either a regular subclass, a variableSubclass, a 
	variableByteSubclass, a variableWordSubclass, or a weakSubclass."

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


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

	^ Smalltalk allUnSentMessagesIn: self selectors! !

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

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

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

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

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:40'!
hasMethods
	"Answer whether the receiver has any methods in its method dictionary."

	^ self methodDict size > 0! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 3/27/1999 23:20'!
includesSelector: aSymbol 
	"Answer whether the message whose selector is the argument is in the 
	method dictionary of the receiver's class."

	^ self methodDict includesKey: aSymbol! !

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

	^superclass scopeHas: name ifTrue: assocBlock! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'sma 6/3/2000 22:03'!
thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a 
	literal. Dives into the compact literal notation, making it slow but 
	thorough "

	| who |
	who _ Set new.
	self selectorsAndMethodsDo:
		[:sel :method |
		((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isMemberOf: Association) not
					or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
						ifTrue: [who add: sel]]].
	^ who! !

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

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

	"Rectangle whichClassIncludesSelector: #inspect."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:40'!
whichSelectorsAccess: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."

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

	"Point whichSelectorsAccess: 'x'."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'ls 10/10/1999
13:22'!
whichSelectorsReferTo: literal 
	"Answer a Set of selectors whose methods access the argument as a
literal."

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

	"Rectangle whichSelectorsReferTo: #+."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'sma 6/3/2000 22:01'!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal."

	| who |
	who _ Set new.
	self selectorsAndMethodsDo: 
		[:sel :method |
		((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]])
			ifTrue:
				[((literal isMemberOf: Association) not
					or: [method sendsToSuper not
					or: [method literals allButLast includes: literal]])
						ifTrue: [who add: sel]]].
	^ who! !

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

	"Point whichSelectorsStoreInto: 'x'."! !


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

!Behavior methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:36'!
allInstancesEverywhereDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the receiver.  Including those in ImageSegments that are out on the disk.  Bring each in briefly."

	self ==  UndefinedObject ifTrue: [^ aBlock value: nil].
	self allInstancesDo: aBlock.
	"Now iterate over instances in segments that are out on the disk."
	ImageSegment allSubInstancesDo: [:seg |
		seg allInstancesOf: self do: aBlock].
! !

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

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

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

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

!Behavior methodsFor: 'enumerating' stamp: 'tk 8/18/1999 17:38'!
allSubclassesDoGently: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

	self subclassesDoGently: 
		[:cl | 
		cl isInMemory ifTrue: [
			aBlock value: cl.
			cl allSubclassesDoGently: aBlock]]! !

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

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

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

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

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

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

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

	aBlock value: self.
	self allSubclassesDo: aBlock! !

!Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'!
withAllSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."
	aBlock value: self.
	superclass == nil
		ifFalse: [superclass withAllSuperclassesDo: aBlock]! !


!Behavior methodsFor: 'user interface' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

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

!Behavior methodsFor: 'user interface' stamp: 'sw 4/4/2000 11:22'!
allUnreferencedInstanceVariables
	"Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses"

	| any definingClass |

	^ self allInstVarNames copy reject:
		[:ivn | any _ false.
		definingClass _ self classThatDefinesInstanceVariable: ivn.
		definingClass withAllSubclasses do:
			[:class |  any ifFalse:
				[(class whichSelectorsAccess: ivn asSymbol) do: 
					[:sel | sel ~~ #DoIt ifTrue: [any _ true]]]].
			any]! !

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

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

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

	"Number browseAllCallsOn: #/."! !

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

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

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

	"Point crossReference."! !

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

	| any |

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

"Ob unreferencedInstanceVariables"! !


!Behavior methodsFor: 'private' stamp: 'tk 12/29/1999 22:04'!
becomeCompact
	"Here are the restrictions on compact classes in order for export segments to work:  A compact class index may not be reused.  If a class was compact in a release of Squeak, no other class may use that index.  The class might not be compact later, and there should be nil in its place in the array."
	| cct index |

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

!Behavior methodsFor: 'private' stamp: 'tk 1/10/2000 14:50'!
becomeCompactSimplyAt: index
	"Make me compact, but don't update the instances.  For importing segments."
"Here are the restrictions on compact classes in order for export segments to work:  A compact class index may not be reused.  If a class was compact in a release of Squeak, no other class may use that index.  The class might not be compact later, and there should be nil in its place in the array."
	| cct |

	self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact'].
	cct _ Smalltalk compactClassesArray.
	(self indexIfCompact > 0 or: [cct includes: self])
		ifTrue: [^ self halt: self name , 'is already compact'].
	(cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use'].
	"Install this class in the compact class table"
	cct at: index put: self.
	"Update instspec so future instances will be compact"
	format _ format + (index bitShift: 11).
	"Caller must convert the instances"
! !

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

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

	<primitive: 89>
	self primitiveFailed! !

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

!Behavior methodsFor: 'private' stamp: 'di 2/17/2000 22:38'!
removeSelectorSimply: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in my method dictionary, remove it and its method."

	| oldMethod |
	oldMethod _ self methodDict at: selector ifAbsent: [^ self].
	self methodDict removeKey: selector.

	"Now flush Squeak's method cache, either by selector or by method"
	oldMethod flushCache.
	selector flushCache.! !


!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!
shutDown
	"This message is sent on system shutdown to registered classes"
! !

!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!
shutDown: quitting
	"This message is sent on system shutdown to registered classes"
	^self shutDown.! !

!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!
startUp
	"This message is sent to registered classes when the system is coming up."
! !

!Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'!
startUp: resuming
	"This message is sent to registered classes when the system is coming up."
	^self startUp! !

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

Behavior class
	instanceVariableNames: ''!

!Behavior class methodsFor: 'testing' stamp: 'ar 9/10/1999 17:28'!
canZapMethodDictionary
	"Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail."
	^false! !
LineSegment subclass: #Bezier2Segment
	instanceVariableNames: 'via '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!Bezier2Segment commentStamp: '<historical>' prior: 0!
This class represents a quadratic bezier segment between two points

Instance variables:
	via		<Point>	The additional control point (OFF the curve)!


!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'!
from: startPoint to: endPoint
	"Initialize the receiver as straight line"
	start _ startPoint.
	end _ endPoint.
	via _ (start + end) // 2.! !

!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:13'!
from: startPoint to: endPoint via: viaPoint
	"Initialize the receiver"
	start _ startPoint.
	end _ endPoint.
	via _ viaPoint.! !

!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:14'!
from: startPoint to: endPoint withMidPoint: pointOnCurve
	"Initialize the receiver with the pointOnCurve assumed at the parametric value 0.5"
	start _ startPoint.
	end _ endPoint.
	"Compute via"
	via _ (pointOnCurve * 2) - ((start+end) // 2).! !

!Bezier2Segment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:14'!
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
	"Initialize the receiver with the pointOnCurve at the given parametric value"
	| t1 t2 t3 |
	start _ startPoint.
	end _ endPoint.
	"Compute via"
	t1 _ (1.0 - parameter) squared.
	t2 _ 2 * parameter * (1.0 - parameter).
	t3 _ parameter squared.
	via _ (pointOnCurve * t2) - (start * t1)  - (end * t3)! !


!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'!
bounds
	"Return the bounds containing the receiver"
	^super bounds encompass: via! !

!Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'!
via
	"Return the control point"
	^via! !


!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'!
hasZeroLength
	"Return true if the receiver has zero length"
	^start = end and:[start = via]! !

!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'!
isBezier2Segment
	"Return true if the receiver is a quadratic bezier segment"
	^true! !

!Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'!
isStraight
	"Return true if the receiver represents a straight line"
	^(self tangentAtStart crossProduct: self tangentAtEnd) = 0! !


!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:15'!
length
	"Return the length of the receiver"
	"Note: Overestimates the length"
	^(start dist: via) + (via dist: end)! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/6/1998 23:39'!
lineSegmentsDo: aBlock
	"Evaluate aBlock with the receiver's line segments"
	"Note: We could use forward differencing here."
	| steps last deltaStep t next |
	steps _ 1 max: (self length // 10). "Assume 10 pixels per step"
	last _ start.
	deltaStep _ 1.0 / steps asFloat.
	t _ deltaStep.
	1 to: steps do:[:i|
		next _ self valueAt: t.
		aBlock value: last value: next.
		last _ next.
		t _ t + deltaStep].! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'!
tangentAt: parameter
	"Return the tangent at the given parametric value along the receiver"
	| in out |
	in _ self tangentAtStart.
	out _ self tangentAtEnd.
	^in + (out - in * parameter)! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'!
tangentAtEnd
	"Return the tangent for the last point"
	^end - via! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'!
tangentAtStart
	"Return the tangent for the first point"
	^via - start! !

!Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:17'!
valueAt: parameter
	"Evaluate the receiver at the given parametric value"
	"Return the point at the parametric value t:
		p(t) =	(1-t)^2 * p1 + 
				2*t*(1-t) * p2 + 
				t^2 * p3.
	"
	| t1 t2 t3 |
	t1 _ (1.0 - parameter) squared.
	t2 _ 2 * parameter * (1.0 - parameter).
	t3 _ parameter squared.
	^(start * t1) + (via * t2) + (end * t3)! !


!Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^self! !

!Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:18'!
asIntegerSegment
	"Convert the receiver into integer representation"
	^self species 
			from: start asIntegerPoint 
			to: end asIntegerPoint 
			via: via asIntegerPoint! !


!Bezier2Segment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:18'!
printOn: aStream
	"Print the receiver on aStream"
	aStream 
		nextPutAll: self class name;
		nextPutAll:' from: ';
		print: start;
		nextPutAll: ' via: ';
		print: via;
		nextPutAll: ' to: ';
		print: end;
		space.! !

!Bezier2Segment methodsFor: 'printing' stamp: 'MPW 1/1/1901 21:59'!
printOnStream: aStream
	aStream 
		print: self class name;
		print:'from: ';
		write: start;
		print:'via: ';
		write: via;
		print:'to: ';
		write: end;
		print:' '.! !

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

Bezier2Segment class
	instanceVariableNames: ''!

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:14'!
from: startPoint to: endPoint via: viaPoint
	^self new from: startPoint to: endPoint via: viaPoint! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'!
from: startPoint to: endPoint withMidPoint: pointOnCurve
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'!
from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'!
from: startPoint via: viaPoint to: endPoint 
	^self new from: startPoint to: endPoint via: viaPoint! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:32'!
from: startPoint withMidPoint: pointOnCurve at: parameter to: endPoint 
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve at: parameter! !

!Bezier2Segment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:30'!
from: startPoint withMidPoint: pointOnCurve to: endPoint 
	^self new from: startPoint to: endPoint withMidPoint: pointOnCurve! !
LineSegment subclass: #Bezier3Segment
	instanceVariableNames: 'via1 via2 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!Bezier3Segment commentStamp: '<historical>' prior: 0!
This class represents a cubic bezier segment between two points

Instance variables:
	via1, via2	<Point>	The additional control points (OFF the curve)!


!Bezier3Segment methodsFor: 'initialization' stamp: 'DSM 10/14/1999 15:33'!
from: aPoint1 via: aPoint2 and: aPoint3 to: aPoint4
	start _ aPoint1.
	via1 _ aPoint2.
	via2 _ aPoint3.
	end _ aPoint4! !


!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:20'!
bounds
	^ ((super bounds encompassing: via1) encompassing: via2)! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:01'!
valueAt: t
	| a b c d |

	"| p1 p2 p3 |
	p1 _ start interpolateTo: via1 at: t.
	p2 _ via1 interpolateTo: via2 at: t.
	p3 _ via2 interpolateTo: end at: t.
	p1 _ p1 interpolateTo: p2 at: t.
	p2 _ p2 interpolateTo: p3 at: t.
	^ p1 interpolateTo: p2 at: t"

	a _ (start negated) + (3 * via1) - (3 * via2) + (end).
	b _ (3 * start) - (6 * via1) + (3 * via2).
	c _ (3 * start negated) + (3 * via1).
	d _ start.
	^ ((a * t + b) * t + c) * t + d

! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'!
via1: aPoint
	via1 _ aPoint! !

!Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'!
via2: aPoint
	via2 _ aPoint! !


!Bezier3Segment methodsFor: 'converting' stamp: 'DSM 10/15/1999 15:55'!
asBezierShape
	"Demote a cubic bezier to a set of approximating quadratic beziers.
	Should convert to forward differencing someday"

	| curves pts step prev index a b f |
	curves _ self bezier2SegmentCount: 0.5.
	pts _ PointArray new: curves * 3.
	step _ 1.0 / (curves * 2).
	prev _ start.
	1 to: curves do: [ :c |
		index _ 3*c.
		a _ pts at: index-2 put: prev.
		b _ (self valueAt: (c*2-1)*step).
		f _ pts at: index put: (self valueAt: (c*2)*step).
		pts at: index-1 put: (4 * b - a - f) / 2.
		prev _ pts at: index.
		].
	^ pts.
	! !

!Bezier3Segment methodsFor: 'converting' stamp: 'DSM 10/15/1999 15:45'!
asPointArray
	| p |
	p _ PointArray new: 4.
	p at: 1 put: start.
	p at: 2 put: via1.
	p at: 3 put: via2.
	p at: 4 put: end.
	^ p! !

!Bezier3Segment methodsFor: 'converting' stamp: 'DSM 3/10/2000 12:10'!
bezier2SegmentCount: pixelError
	"Compute the number of quadratic bezier segments needed to approximate
	this cubic with no more than a specified error"
	| a |
	a _ (start x negated @ start y negated) + (3 * via1) - (3 * via2) +
(end).
	^ (((a r / (20.0 * pixelError)) raisedTo: 0.333333) ceiling) max: 1.

! !


!Bezier3Segment methodsFor: 'private' stamp: 'DSM 10/14/1999 16:25'!
bezier2SegmentCount
	"Compute the number of quadratic bezier segments needed to approximate
	this cubic with less than a 1-pixel error"
	^ self bezier2SegmentCount: 1.0! !

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

Bezier3Segment class
	instanceVariableNames: ''!

!Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM
10/15/1999 15:23'!
from: p1 to: p2
	^ self new from: p1 via: (p1 interpolateTo: p2 at: 0.3333) and: (p1
interpolateTo: p2 at: 0.66667) to: p2! !

!Bezier3Segment class methodsFor: 'instance creation' stamp: 'DSM
10/15/1999 15:24'!
from: p1 via: p2 and: p3 to: p4
	^ self new from: p1 via: p2 and: p3 to: p4! !


!Bezier3Segment class methodsFor: 'utilities' stamp: 'DSM 10/15/1999 16:06'!
convertBezier3ToBezier2: vertices
	| pa pts index c |
	pts _ OrderedCollection new.
	1 to: vertices size // 4 do:
		[:i |
		index _ i * 4 - 3.
		c _ Bezier3Segment new
					from: (vertices at: index)
					via: (vertices at: index + 1)
					and: (vertices at: index + 2)
					to: (vertices at: index + 3).
		pts addAll: c asBezierShape].
	pa _ PointArray new: pts size.
	pts withIndexDo: [:p :i | pa at: i put: p ].
	^ pa! !


!Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 15:49'!
example1
	| c |
	c _ Bezier3Segment new from: 0@0 via: 0@100 and: 100@0 to: 100@100.
	^ c asBezierShape! !

!Bezier3Segment class methodsFor: 'examples' stamp: 'DSM 10/15/1999 16:00'!
example2
	"draws a cubic bezier on the screen"
	| c canvas |
	c _ Bezier3Segment new
				from: 0 @ 0
				via: 0 @ 100
				and: 100 @ 0
				to: 100 @ 100.
	canvas _ BalloonCanvas on: Display.
	canvas aaLevel: 4.
	canvas
		drawBezier3Shape: c asPointArray
		color: Color transparent
		borderWidth: 1
		borderColor: Color black! !
Object subclass: #BitBlt
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap '
	classVariableNames: 'CachedFontColorMaps '
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!BitBlt commentStamp: '<historical>' prior: 0!
I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm.  The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm.  If both are specified, their pixel values are combined with a logical AND function prior to transfer.  In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.

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

In addition to the original 16 combination rules, this BitBlt supports
	16	fails (to simulate paint bits)
	17	fails (to simulate erase bits)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord.  Sum of color components
	21	rgbSub: sourceWord with: destinationWord.  Difference of color components
	22	OLDrgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
	23	OLDtallyIntoMap: destinationWord.  Tallies pixValues into a colorMap
			these old versions don't do bitwise dest clipping.  Use 32 and 33 now.
	24	alphaBlend: sourceWord with: destinationWord.  32-bit source and dest only
	25	pixPaint: sourceWord with: destinationWord.  Wherever the sourceForm is non-zero, it replaces the destination.  Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1.
	26	pixMask: sourceWord with: destinationWord.  Like pixPaint, but fills with 0.
	27	rgbMax: sourceWord with: destinationWord.  Max of each color component.
	28	rgbMin: sourceWord with: destinationWord.  Min of each color component.
	29	rgbMin: sourceWord bitInvert32 with: destinationWord.  Min with (max-source)
	30	alphaBlendConst: sourceWord with: destinationWord.  alpha is an arg. works in 16 bits.
	31	alphaPaintConst: sourceWord with: destinationWord.  alpha is an arg. works in 16 bits.
	32	rgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
	33	tallyIntoMap: destinationWord.  Tallies pixValues into a colorMap
	34	alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord.

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

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

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


!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'!
clipHeight
	^clipHeight! !

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

	clipHeight _ anInteger! !

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

	^clipX @ clipY extent: clipWidth @ clipHeight! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 10/4/2000 16:37'!
clipRect: aRectangle 
	"Set the receiver's clipping area rectangle to be the argument, aRectangle."

	clipX _ aRectangle left truncated.
	clipY _ aRectangle top truncated.
	clipWidth _ aRectangle right truncated - clipX.
	clipHeight _ aRectangle bottom truncated - clipY.! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'!
clipWidth
	^clipWidth! !

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

	clipWidth _ anInteger! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'!
clipX
	^clipX! !

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

	clipX _ anInteger! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'!
clipY
	^clipY! !

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

	clipY _ anInteger! !

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

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:43'!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	(map notNil and:[map isColormap])
		ifTrue:[colorMap _ map colors]
		ifFalse:[colorMap _ map]! !

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

	combinationRule _ anInteger! !

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

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

	destX _ aPoint x.
	destY _ aPoint y! !

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

	^ destX @ destY extent: width @ height! !

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

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

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

	destX _ anInteger! !

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

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

	destY _ anInteger! !

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

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

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

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

	height _ anInteger! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 2/21/2000 22:06'!
isFXBlt
	^false! !

!BitBlt methodsFor: 'accessing'!
sourceForm

	^ sourceForm! !

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

	sourceForm _ aForm! !

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

	sourceX _ aPoint x.
	sourceY _ aPoint y! !

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

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

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

	sourceX _ anInteger! !

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

	sourceY _ anInteger! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'!
tallyMap
	"Return the map used for tallying pixels"
	^colorMap! !

!BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'!
tallyMap: aBitmap
	"Install the map used for tallying pixels"
	colorMap _ aBitmap! !

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

	width _ anInteger! !


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

!BitBlt methodsFor: 'copying' stamp: 'di 12/26/1998 15:04'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	srcForm == nil ifFalse:
		[colorMap _ srcForm colormapIfNeededForDepth: destForm depth].
	^ self copyBits! !

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

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

	"Check for compressed source, destination or halftone forms"
	(combinationRule >= 30 and: [combinationRule <= 31]) ifTrue:
		["No alpha specified -- re-run with alpha = 1.0"
		^ self copyBitsTranslucent: 255].
	((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
		ifTrue: [^ self copyBits].
	((destForm isKindOf: Form) and: [destForm unhibernate])
		ifTrue: [^ self copyBits].
	((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self copyBits].

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

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

!BitBlt methodsFor: 'copying' stamp: 'ar 10/27/1999 23:36'!
copyBitsSimulated
	^BitBltSimulation copyBitsFrom: self.! !

!BitBlt methodsFor: 'copying' stamp: 'ar 2/2/2001 15:09'!
copyBitsTranslucent: factor
	"This entry point to BitBlt supplies an extra argument to specify translucency
	for operations 30 and 31.  The argument must be an integer between 0 and 255."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>

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

	self primitiveFailed  "Later do nicer error recovery -- share copyBits recovery"! !

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

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

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

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

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

!BitBlt methodsFor: 'copying' stamp: 'RAA 9/27/2000 16:48'!
displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta

	destY _ aPoint y.
	destX _ aPoint x.

	"the following are not really needed, but theBitBlt primitive will fail if not set"
	sourceX ifNil: [sourceX _ 100].
	width ifNil: [width _ 100].

	^self primDisplayString: aString from: startIndex to: stopIndex
			map: font characterToGlyphMap xTable: font xTable
			kern: kernDelta.! !

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

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

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


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

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

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

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


!BitBlt methodsFor: 'private' stamp: 'hg 6/27/2000 12:27'!
cachedFontColormapFrom: sourceDepth to: destDepth

	| srcIndex map |
	CachedFontColorMaps class == Array 
		ifFalse: [CachedFontColorMaps _ (1 to: 9) collect: [:i | Array new: 32]].
	srcIndex _ sourceDepth.
	sourceDepth > 8 ifTrue: [srcIndex _ 9].
	(map _ (CachedFontColorMaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [^ map].

	map _ (Color cachedColormapFrom: sourceDepth to: destDepth) copy.
	(CachedFontColorMaps at: srcIndex) at: destDepth put: map.
	^ map
! !

!BitBlt methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
copyBitsAgain
	"Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>
	self primitiveFailed! !

!BitBlt methodsFor: 'private' stamp: 'ar 10/25/1998 17:30'!
copyBitsFrom: x0 to: x1 at: y
	destX _ x0.
	destY _ y.
	sourceX _ x0.
	width _ (x1 - x0).
	self copyBits.! !

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

!BitBlt methodsFor: 'private' stamp: 'ar 5/26/2000 16:38'!
getPluginName
	"Private. Return the name of the plugin representing BitBlt.
	Used for dynamically switching between different BB representations only."
	^'BitBltPlugin'! !

!BitBlt methodsFor: 'private' stamp: 'hg 6/27/2000 12:28'!
installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor
	| lastSourceDepth |
	sourceForm ifNotNil:[lastSourceDepth _ sourceForm depth].
	sourceForm _ aStrikeFont glyphs.
	(colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse:
		["Set up color map for a different source depth (color font)"
		"Uses caching for reasonable efficiency"
		colorMap _ self cachedFontColormapFrom: sourceForm depth to: destForm depth.
		colorMap at: 1 put: (backgroundColor pixelValueForDepth: destForm depth)].
	sourceForm depth = 1 ifTrue:
		[colorMap at: 2 put: (foregroundColor pixelValueForDepth: destForm depth).
		"Ignore any halftone pattern since we use a color map approach here"
		halftoneForm _ nil].
	sourceY _ 0.
	height _ aStrikeFont height.
! !

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

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

!BitBlt methodsFor: 'private' stamp: 'ar 5/18/2000 21:49'!
primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta
	| ascii glyph |
	<primitive:'primitiveDisplayString' module:'BitBltPlugin'>
	startIndex to: stopIndex do:[:charIndex|
		ascii _ (aString at: charIndex) asciiValue.
		glyph _ glyphMap at: ascii + 1.
		sourceX _ xTable at: glyph + 1.
		width _ (xTable at: glyph + 2) - sourceX.
		self copyBits.
		destX _ destX + width + kernDelta.
	].! !

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

!BitBlt methodsFor: 'private' stamp: 'di 9/11/1998 13:07'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

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

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

BitBlt class
	instanceVariableNames: ''!

!BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:04'!
asGrafPort
	"Return the GrafPort associated with the receiver"
	^GrafPort! !

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

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

!BitBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'!
current
	"Return the class currently to be used for BitBlt"
	^Display defaultBitBltClass! !

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	"BitBlt exampleOne"! !

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

	"BitBlt exampleTwo"! !


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

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

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

	d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
	aBitBlt _ BitBlt
		destForm: Display
		sourceForm: s
		fillColor: mask
		combinationRule: rule
		destOrigin: originPoint + (s extent // (2 @ 1))
		sourceOrigin: 0 @ 0
		extent: s extent
		clipRect: Display computeBoundingBox.
	aBitBlt copyBits.
	border 
		displayOn: Display at: originPoint + (s extent // (2 @ 1))
		rule: Form under.
   
	"BitBlt exampleAt: 100@100 rule: Form over fillColor: Display gray"! !


!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 10/28/1999 23:38'!
benchDiffsFrom: before to: afterwards
	"Given two outputs of BitBlt>>benchmark show the relative improvements."
	| old new log oldLine newLine oldVal newVal improvement |
	log _ WriteStream on: String new.
	old _ ReadStream on: before.
	new _ ReadStream on: afterwards.
	[old atEnd or:[new atEnd]] whileFalse:[
		oldLine _ old upTo: Character cr.
		newLine _ new upTo: Character cr.
		(oldLine includes: Character tab) ifTrue:[
			oldLine _ ReadStream on: oldLine.
			newLine _ ReadStream on: newLine.
			Transcript cr; show: (oldLine upTo: Character tab); tab.
			log cr; nextPutAll: (newLine upTo: Character tab); tab.

			[oldLine skipSeparators. newLine skipSeparators.
			oldLine atEnd] whileFalse:[
				oldVal _ Integer readFrom: oldLine.
				newVal _ Integer readFrom: newLine.
				improvement _ oldVal asFloat / newVal asFloat roundTo: 0.1.
				Transcript show: improvement printString; tab.
				log print: improvement; tab].
		] ifFalse:[
			Transcript cr; show: oldLine.
			log cr; nextPutAll: oldLine.
		].
	].
	^log contents! !

!BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/25/2000 17:58'!
benchmark		"BitBlt benchmark"
	"Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else.
	Attention: *this*may*take*a*while*"
	| bb source dest destRect log t |
	log _ WriteStream on: String new.
	destRect _ 0@0 extent: 600@600.
	"Form paint/Form over - the most common rules"
	#( 25 3 ) do:[:rule|
		Transcript cr; show:'---- Combination rule: ', rule printString,' ----'.
		log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'.
		#(1 2 4 8 16 32) do:[:destDepth|
			dest _ nil.
			dest _ Form extent: destRect extent depth: destDepth.
			Transcript cr.
			log cr.
			#(1 2 4 8 16 32) do:[:sourceDepth|
				Transcript cr; show: sourceDepth printString, ' => ', destDepth printString.
				log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString.
				source _ nil. bb _ nil.
				source _ Form extent: destRect extent depth: sourceDepth.
				(source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black.
				bb _ WarpBlt toForm: dest.
				bb sourceForm: source.
				bb sourceRect: source boundingBox.
				bb destRect: dest boundingBox.
				bb colorMap: (source colormapIfNeededForDepth: dest depth).
				bb combinationRule: rule.

				"Measure speed of copyBits"
				t _ Time millisecondsToRun:[bb copyBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				bb sourceForm: source destRect: source boundingBox.

				"Measure speed of 1x1 warpBits"
				bb cellSize: 1.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 2x2 warpBits"
				bb cellSize: 2.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 3x3 warpBits"
				bb cellSize: 3.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.
			].
		].
	].
	^log contents! !
InterpreterPlugin subclass: #BitBltSimulation
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceBits sourcePitch sourcePixSize destBits destPitch destPixSize pixPerWord bitCount skew mask1 mask2 preload nWords destMask hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH srcWidth srcHeight destWidth destHeight halftoneHeight noSource noHalftone halftoneBase colorMap sourceAlpha cmBitsPerColor srcBitShift dstBitShift scanStart scanStop scanString scanRightX scanStopArray scanDisplayFlag scanXTable stopCode bitBltOop affectedL affectedR affectedT affectedB opTable maskTable ditherMatrix4x4 ditherThresholds16 ditherValues16 hasSurfaceLock warpSrcShift warpSrcMask warpAlignShift warpAlignMask warpBitShiftTable cmDeltaBits cmRedMask cmBlueMask cmGreenMask cmRedShift cmBlueShift cmGreenShift '
	classVariableNames: 'AllOnes BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex OpTable OpTableSize '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!BitBltSimulation commentStamp: '<historical>' prior: 0!
This class implements BitBlt, much as specified in the Blue Book spec.

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

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

In addition to the original 16 combination rules, this BitBlt supports
	16	fail (for old paint mode)
	17	fail (for old mask mode)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	OLDrgbDiff: sourceWord with: destinationWord
	23	OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
	30	alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg
	31	alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg
	32	rgbDiff: sourceWord with: destinationWord
	33	tallyIntoMap: destinationWord
	34	alphaBlendScaled: sourceWord with: destinationWord

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

To add a new rule to BitBlt...
	1.  add the new rule method or methods in the category 'combination rules' of BBSim
	2.  describe it in the class comment  of BBSim and in the class comment for BitBlt
	3.  add refs to initializeRuleTable in proper positions
	4.  add refs to initBBOpTable, following the pattern
!


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

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

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

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 21:23'!
fetchIntOrFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	| fieldOop floatValue |
	self var: #floatValue declareC:'double floatValue'.
	fieldOop _ interpreterProxy fetchPointer: fieldIndex ofObject: objectPointer.
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	floatValue _ interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail. ^0].
	^floatValue asInteger! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 20:51'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	| fieldOop floatValue |
	self var: #floatValue declareC:'double floatValue'.
	fieldOop _ interpreterProxy fetchPointer: fieldIndex ofObject: objectPointer.
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	floatValue _ interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail. ^0].
	^floatValue asInteger! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/28/1999 22:21'!
loadBitBltDestForm
	"Load the dest form for BitBlt. Return false if anything is wrong, true otherwise."
	| destBitsSize |
	self inline: true.
	destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
	destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
	destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
	(destWidth >= 0 and: [destHeight >= 0])
		ifFalse: [^ false].
	destPixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: destBits) ifTrue:[
		"Query for actual surface dimensions"
		(self queryDestSurface: (interpreterProxy integerValueOf: destBits))
			ifFalse:[^false].
		pixPerWord _ 32 // destPixSize.
		destBits _ destPitch _ 0.
	] ifFalse:[
		pixPerWord _ 32 // destPixSize.
		destPitch _ destWidth + (pixPerWord-1) // pixPerWord * 4.
		destBitsSize _ interpreterProxy byteSizeOf: destBits.
		((interpreterProxy isWordsOrBytes: destBits)
			and: [destBitsSize = (destPitch * destHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		destBits _ self cCoerce: (interpreterProxy firstIndexableField: destBits) to:'int'.
	].
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/20/2000 19:42'!
loadBitBltFrom: bbObj
	"Load BitBlt from the oop.
	This function is exported for the Balloon engine."
	self export: true.
	^self loadBitBltFrom: bbObj warping: false.! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 5/11/2000 20:39'!
loadBitBltFrom: bbObj warping: aBool
	"Load context from BitBlt instance.  Return false if anything is amiss"
	"NOTE this should all be changed to minX/maxX coordinates for simpler clipping
		-- once it works!!"
	| ok |
	self inline: false.
	bitBltOop _ bbObj.
	colorMap _ nil. "Assume no color map"
	combinationRule _ interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.
	(interpreterProxy failed
		or: [combinationRule < 0 or: [combinationRule > (OpTableSize - 2)]])
		 ifTrue: [^ false  "operation out of range"].
	(combinationRule >= 16 and: [combinationRule <= 17])
		 ifTrue: [^ false  "fail for old simulated paint, erase modes"].
	sourceForm _ interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.
	noSource _ self ignoreSourceOrHalftone: sourceForm.
	halftoneForm _ interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.
	noHalftone _ self ignoreSourceOrHalftone: halftoneForm.

	destForm _ interpreterProxy fetchPointer: BBDestFormIndex ofObject: bbObj.
	((interpreterProxy isPointers: destForm) and: [(interpreterProxy slotSizeOf: destForm) >= 4])
		ifFalse: [^ false].
	ok _ self loadBitBltDestForm.
	ok ifFalse:[^false].

	destX _ self fetchIntOrFloat: BBDestXIndex ofObject: bitBltOop.
	destY _ self fetchIntOrFloat: BBDestYIndex ofObject: bitBltOop.
	width _ self fetchIntOrFloat: BBWidthIndex ofObject: bitBltOop.
	height _ self fetchIntOrFloat: BBHeightIndex ofObject: bitBltOop.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].

	noSource ifTrue:
		[sourceX _ sourceY _ 0]
		ifFalse: 
		[((interpreterProxy isPointers: sourceForm) and: [(interpreterProxy slotSizeOf: sourceForm) >= 4])
			ifFalse: [^ false].
		ok _ self loadBitBltSourceForm.
		ok ifFalse:[^false].
		colorMap _ interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.
		ok _ self loadColorMap: aBool.
		ok ifFalse:[^false].
		self setupColorMasks.
		sourceX _ self fetchIntOrFloat: BBSourceXIndex ofObject: bitBltOop.
		sourceY _ self fetchIntOrFloat: BBSourceYIndex ofObject: bitBltOop].

	ok _ self loadHalftoneForm.
	ok ifFalse:[^false].
	clipX _ self fetchIntOrFloat: BBClipXIndex ofObject: bitBltOop.
	clipY _ self fetchIntOrFloat: BBClipYIndex ofObject: bitBltOop.
	clipWidth _ self fetchIntOrFloat: BBClipWidthIndex ofObject: bitBltOop.
	clipHeight _ self fetchIntOrFloat: BBClipHeightIndex ofObject: bitBltOop.
		interpreterProxy failed ifTrue: [^ false  "non-integer value"].
	clipX < 0 ifTrue: [clipWidth _ clipWidth + clipX.  clipX _ 0].
	clipY < 0 ifTrue: [clipHeight _ clipHeight + clipY.  clipY _ 0].
	clipX+clipWidth > destWidth ifTrue: [clipWidth _ destWidth - clipX].
	clipY+clipHeight > destHeight ifTrue: [clipHeight _ destHeight - clipY].
	^ true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 21:24'!
loadBitBltSourceForm
	"Load the source form for BitBlt. Return false if anything is wrong, true otherwise."
	| sourcePixPerWord sourceBitsSize |
	self inline: true.
	sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
	srcWidth _ self fetchIntOrFloat: FormWidthIndex ofObject: sourceForm.
	srcHeight _ self fetchIntOrFloat: FormHeightIndex ofObject: sourceForm.
	(srcWidth >= 0 and: [srcHeight >= 0])
		ifFalse: [^ false].
	sourcePixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: sourceBits) ifTrue:[
		"Query for actual surface dimensions"
		(self querySourceSurface: (interpreterProxy integerValueOf: sourceBits))
			ifFalse:[^false].
		sourcePixPerWord _ 32 // sourcePixSize.
		sourceBits _ sourcePitch _ 0.
	] ifFalse:[
		sourcePixPerWord _ 32 // sourcePixSize.
		sourcePitch _ srcWidth + (sourcePixPerWord-1) // sourcePixPerWord * 4.
		sourceBitsSize _ interpreterProxy byteSizeOf: sourceBits.
		((interpreterProxy isWordsOrBytes: sourceBits)
			and: [sourceBitsSize = (sourcePitch * srcHeight)])
			ifFalse: [^ false].
		"Skip header since external bits don't have one"
		sourceBits _ self cCoerce: (interpreterProxy firstIndexableField: sourceBits) to:'int'.
	].
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/28/1999 22:21'!
loadColorMap: warping
	"ColorMap, if not nil, must be longWords, and 
	2^N long, where N = sourcePixSize for 1, 2, 4, 8 bits, 
	or N = 9, 12, or 15 (3, 4, 5 bits per color) for 16 or 32 bits."
	| cmSize |
	self inline: true.
	cmBitsPerColor _ 0.
	colorMap = interpreterProxy nilObject ifTrue:[
		colorMap _ nil.
	] ifFalse:[
		(interpreterProxy isWords: colorMap) ifTrue:[
			cmSize _ interpreterProxy slotSizeOf: colorMap.
			cmSize = 512 ifTrue: [cmBitsPerColor _ 3].
			cmSize = 4096 ifTrue: [cmBitsPerColor _ 4].
			cmSize = 32768 ifTrue: [cmBitsPerColor _ 5].
			warping ifFalse:[
				"WarpBlt has different checks on the color map"
				sourcePixSize <= 8
					ifTrue: [cmSize = (1 << sourcePixSize) ifFalse: [^ false] ]
					ifFalse: [cmBitsPerColor = 0 ifTrue: [^ false] ]].
			colorMap _ self cCoerce: (interpreterProxy firstIndexableField: colorMap) to: 'int'.
			self setupColorMasks.
		] ifFalse: [^ false]].
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/28/1999 22:22'!
loadHalftoneForm
	"Load the halftone form"
	| halftoneBits |
	self inline: true.
	noHalftone ifTrue:[
		halftoneBase _ nil.
		^true].
	((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy slotSizeOf: halftoneForm) >= 4])
		ifTrue:
		["Old-style 32xN monochrome halftone Forms"
		halftoneBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.
		halftoneHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.
		(interpreterProxy isWords: halftoneBits)
			ifFalse: [noHalftone _ true]]
		ifFalse:
		["New spec accepts, basically, a word array"
		((interpreterProxy isPointers: halftoneForm) not
			and: [interpreterProxy isWords: halftoneForm])
			ifFalse: [^ false].
		halftoneBits _ halftoneForm.
		halftoneHeight _ interpreterProxy slotSizeOf: halftoneBits].
	halftoneBase _ self cCoerce: (interpreterProxy firstIndexableField: halftoneBits) to:'int'.
	^true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 21:24'!
loadScannerFrom: bbObj
	start: start stop: stop string: string rightX: rightX
	stopArray: stopArray displayFlag: displayFlag

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

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

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

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/27/1999 16:03'!
loadWarpBltFrom: bbObj
	^self loadBitBltFrom: bbObj warping: true! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'di 1/4/2000 14:19'!
scanCharacters
	self inline: true.
	scanDisplayFlag ifTrue: [
		self clipRange.
		(combinationRule = 30) | (combinationRule = 31) ifTrue:
			[^ interpreterProxy primitiveFail].
		self lockSurfaces ifFalse: [^ interpreterProxy primitiveFail]].
	self scanCharactersLockedAndClipped.
	scanDisplayFlag ifTrue:[self unlockSurfaces].! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/28/1999 18:03'!
setupColorMasks
	| bits targetBits |
	bits _ targetBits _ 0.
	sourcePixSize <= 8 ifTrue:[^nil].
	sourcePixSize = 16 ifTrue:[bits _ 5].
	sourcePixSize = 32 ifTrue:[bits _ 8].

	colorMap == nil
		ifTrue:["Convert between RGB values"
				destPixSize <= 8 ifTrue:[^nil].
				destPixSize = 16 ifTrue:[targetBits _ 5].
				destPixSize = 32 ifTrue:[targetBits _ 8]]
		ifFalse:[targetBits _ cmBitsPerColor].

	self setupColorMasksFrom: bits to: targetBits! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 10/28/1999 23:50'!
setupColorMasksFrom: srcBits to: targetBits
	"Setup color masks for converting an incoming RGB pixel value from srcBits to targetBits."
	| delta mask |
	cmDeltaBits _ targetBits - srcBits.
	cmDeltaBits <= 0
		ifTrue:[	mask _ 1 << targetBits - 1.
				delta _ srcBits - targetBits.
				"Mask for extracting a color part of the source"
				cmRedMask _ mask << (srcBits*2 - cmDeltaBits).
				cmGreenMask _ mask << (srcBits - cmDeltaBits).
				cmBlueMask _ mask << (0 - cmDeltaBits)]
		ifFalse:[	mask _ 1 << srcBits - 1.
				delta _ targetBits - srcBits.
				"Mask for extracting a color part of the source"
				cmRedMask _ mask << (srcBits*2).
				cmGreenMask _ mask << srcBits.
				cmBlueMask _ mask].

	"Shifts for adjusting each value in a cm RGB value"
	cmRedShift _ delta * 3.
	cmGreenShift _ delta * 2.
	cmBlueShift _ delta.! !

!BitBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 20:46'!
showDisplayBits
	interpreterProxy 
		showDisplayBits: destForm
		Left: affectedL
		Top: affectedT
		Right: affectedR
		Bottom: affectedB! !


!BitBltSimulation methodsFor: 'accessing'!
affectedBottom

	^affectedB! !

!BitBltSimulation methodsFor: 'accessing'!
affectedLeft

	^affectedL! !

!BitBltSimulation methodsFor: 'accessing'!
affectedRight

	^affectedR! !

!BitBltSimulation methodsFor: 'accessing'!
affectedTop

	^affectedT! !

!BitBltSimulation methodsFor: 'accessing'!
stopReason

	^stopCode! !


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

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

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 2/20/2000 19:43'!
copyBits
	"This function is exported for the Balloon engine"
	self export: true.
	self inline: true.
	self clipRange.
	(bbW <= 0 or: [bbH <= 0]) ifTrue:
		["zero width or height; noop"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		^ nil].
	"Lock the surfaces"
	self lockSurfaces ifFalse:[^interpreterProxy primitiveFail].
	self copyBitsLockedAndClipped.
	self unlockSurfaces.! !

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 2/20/2000 19:42'!
copyBitsFrom: startX to: stopX at: yValue
	"Support for the balloon engine."
	self export: true.
	destX _ startX.
	destY _ yValue.
	sourceX _ startX.
	width _ (stopX - startX).
	self copyBits.
	self showDisplayBits.! !

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 2/19/2000 20:58'!
copyBitsLockedAndClipped
	"Perform the actual copyBits operation.
	Assume: Surfaces have been locked and clipping was performed."
	| done |
	self inline: true.
	"Try a shortcut for stuff that should be run as quickly as possible"
 	done _ self tryCopyingBitsQuickly.
	done ifTrue:[^nil].

	(combinationRule = 30) | (combinationRule = 31) ifTrue:
		["Check and fetch source alpha parameter for alpha blend"
		interpreterProxy methodArgumentCount = 1
			ifTrue: [sourceAlpha _ interpreterProxy stackIntegerValue: 0.
					(interpreterProxy failed not and: [(sourceAlpha >= 0) & (sourceAlpha <= 255)])
						ifTrue: [interpreterProxy pop: 1]
						ifFalse: [^ interpreterProxy primitiveFail]]
			ifFalse: [^ interpreterProxy primitiveFail]].

	bitCount _ 0.
	"Choose and perform the actual copy loop."
	self performCopyLoop.

	(combinationRule = 22) | (combinationRule = 32) ifTrue:
		["zero width and height; return the count"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		interpreterProxy pop: 1.
		^ interpreterProxy pushInteger: bitCount].
 
	hDir > 0
		ifTrue: [affectedL _ dx.
				affectedR _ dx + bbW]
		ifFalse: [affectedL _ dx - bbW + 1.
				affectedR _ dx + 1].
	vDir > 0
		ifTrue: [affectedT _ dy.
				affectedB _ dy + bbH]
		ifFalse: [affectedT _ dy - bbH + 1.
				affectedB _ dy + 1]! !

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

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

!BitBltSimulation methodsFor: 'setup'!
ignoreSourceOrHalftone: formPointer

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

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 10/25/1999 21:56'!
performCopyLoop
	"Based on the values provided during setup choose and
	perform the appropriate inner loop function."
	self inline: true. "Should be inlined into caller for speed"
	self destMaskAndPointerInit.
	noSource ifTrue: ["Simple fill loop"
		self copyLoopNoSource.
	] ifFalse: ["Loop using source and dest"
		self checkSourceOverlap.
		(sourcePixSize ~= destPixSize or: [colorMap ~= nil]) ifTrue: [
			"If we must convert between pixel depths or use
			color lookups use the general version"
			self copyLoopPixMap.
		] ifFalse: [
			"Otherwise we simple copy pixels and can use a faster version"
			self sourceSkewAndPointerInit.
			self copyLoop.
		]
	].
! !

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

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

!BitBltSimulation methodsFor: 'setup' stamp: 'di 1/4/2000 14:19'!
scanCharactersLockedAndClipped
	"Perform the actual scanCharacters operation.
	Assume: Surfaces have been locked and clipping was performed."
	| left top lastIndex charVal ascii sourceX2 nextDestX |
	self inline: true.
	scanDisplayFlag ifTrue:
		[left _ dx.
		top _ dy].
	lastIndex _ scanStart.
	[lastIndex <= scanStop]
		whileTrue: [
			charVal _ interpreterProxy stObject: scanString at: lastIndex.
			ascii _ interpreterProxy integerValueOf: charVal.
			interpreterProxy failed ifTrue: [^ nil].
			stopCode _ interpreterProxy stObject: scanStopArray at: ascii + 1.
			interpreterProxy failed ifTrue: [^ nil].
			stopCode = interpreterProxy nilObject
				ifFalse: [^ self returnAt: ascii + 1
							 lastIndex: lastIndex
								  left: left
								  top: top].
			sourceX _ interpreterProxy stObject: scanXTable at: ascii + 1.
			sourceX2 _ interpreterProxy stObject: scanXTable at: ascii + 2.
			interpreterProxy failed ifTrue: [^ nil].
			(interpreterProxy isIntegerObject: sourceX) & (interpreterProxy isIntegerObject: sourceX2)
				ifTrue: [sourceX _ interpreterProxy integerValueOf: sourceX.
						sourceX2 _ interpreterProxy integerValueOf: sourceX2]
				ifFalse: [interpreterProxy primitiveFail. ^ nil].
			nextDestX _ destX + (width _ sourceX2 - sourceX).
			nextDestX > scanRightX
				ifTrue: [^ self returnAt: CrossedX
							 lastIndex: lastIndex
								  left: left
								  top: top].
			(scanDisplayFlag) ifTrue:[
				self clipRange.	"Must clip again"
				(bbW > 0 and:[bbH > 0])
					ifTrue: [self copyBitsLockedAndClipped].
			].
			destX _ nextDestX.
			interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
			lastIndex _ lastIndex + 1].
	self returnAt: EndOfRun
		 lastIndex: scanStop
			  left: left
			  top: top! !

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

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

	"Calc byte addr and delta from longWord info"
	sourceIndex _ sourceBits + (sy * sourcePitch) + ((sx // (32//sourcePixSize)) *4).
	"calculate increments from end of 1 line to start of next"
	sourceDelta _ (sourcePitch * vDir) - (4 * (nWords * hDir)).

	preload ifTrue:
		["Compensate for extra source word fetched"
		sourceDelta _ sourceDelta - (4*hDir)].! !

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 10/23/1999 20:40'!
tryCopyingBitsQuickly
	"Shortcut for stuff that's being run from the balloon engine.
	Since we do this at each scan line we should avoid the expensive 
	setup for source and destination."
	self inline: true.
	"We need a source."
	noSource ifTrue:[^false].
	"We handle only combinationRule 34"
	(combinationRule = 34) ifFalse:[^false].
	"We handle only sourcePixSize 32"
	(sourcePixSize = 32) ifFalse:[^false].
	"We don't handle overlaps"
	(sourceForm = destForm) ifTrue:[^false].
	"We need at least 8bit deep dest forms"
	(destPixSize < 8) ifTrue:[^false].
	"If 8bit, then we want a color map"
	(destPixSize = 8 and:[colorMap = nil]) ifTrue:[^false].
	destPixSize = 32 
		ifTrue:[self alphaSourceBlendBits32].
	destPixSize = 16
		ifTrue:[self alphaSourceBlendBits16].
	destPixSize = 8
		ifTrue:[self alphaSourceBlendBits8].
	affectedL _ dx.
	affectedR _ dx + bbW.
	affectedT _ dy.
	affectedB _ dy + bbH.
	^true! !

!BitBltSimulation methodsFor: 'setup' stamp: 'ar 10/27/1999 17:05'!
warpBits
	| ns |
	self inline: true.
	ns _ noSource.  noSource _ true.
		self clipRange.  "noSource suppresses sourceRect clipping"
		noSource _ ns.
	(noSource or: [bbW <= 0 or: [bbH <= 0]]) ifTrue:
		["zero width or height; noop"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		^ nil].

 	self lockSurfaces.
	self destMaskAndPointerInit.
	self xWarpLoop.
 
	hDir > 0
		ifTrue: [affectedL _ dx.
				affectedR _ dx + bbW]
		ifFalse: [affectedL _ dx - bbW + 1.
				affectedR _ dx + 1].
	vDir > 0
		ifTrue: [affectedT _ dy.
				affectedB _ dy + bbH]
		ifFalse: [affectedT _ dy - bbH + 1.
				affectedB _ dy + 1].
	self unlockSurfaces.! !


!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 10/28/1999 19:52'!
alphaSourceBlendBits16
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 16
		sourceForm ~= destForm.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift ditherBase ditherIndex ditherThreshold |
	self inline: false. "This particular method should be optimized in itself"
	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.
	(dx bitAnd: 1) = 0 
		ifTrue:[	mask1 _ 16r0000FFFF.
				srcShift _ 16]
		ifFalse:[mask1 _ 16rFFFF0000.
				srcShift _ 0].
	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx // 2 * 4).
		ditherBase _ (dstY bitAnd: 3) * 4.
		ditherIndex _ (sx bitAnd: 3) - 1. "For pre-increment"
		deltaX _ bbW + 1. "So we can pre-decrement"
		dstMask _ mask1.
		dstMask = 16rFFFF ifTrue:[srcShift _ 16] ifFalse:[srcShift _ 0].

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			ditherThreshold _ ditherMatrix4x4 at: ditherBase + (ditherIndex _ ditherIndex + 1 bitAnd: 3).
			sourceWord _ self srcLongAt: srcIndex.
			srcAlpha _ sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				"Dither from 32 to 16 bit"
				sourceWord _ self dither32To16: sourceWord threshold: ditherThreshold.
				sourceWord = 0 ifTrue:[sourceWord _ 1].
				sourceWord _ sourceWord << srcShift.
				"Store masked value"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord _ self dstLongAt: dstIndex.
					destWord _ destWord bitAnd: dstMask bitInvert32.
					destWord _ destWord >> srcShift.
					"Expand from 16 to 32 bit by adding zero bits"
					destWord _ (((destWord bitAnd: 16r7C00) bitShift: 9) bitOr:
									((destWord bitAnd: 16r3E0) bitShift: 6)) bitOr:
								(((destWord bitAnd: 16r1F) bitShift: 3) bitOr:
									16rFF000000).
					"Mix colors"
					sourceWord _ self alphaBlendScaled: sourceWord with: destWord.
					"And dither"
					sourceWord _ self dither32To16: sourceWord threshold: ditherThreshold.
					sourceWord = 0 ifTrue:[sourceWord _ 1].
					sourceWord _ sourceWord << srcShift.
					"Store back"
					self dstLongAt: dstIndex put: sourceWord mask: dstMask.
				].
			].
			srcIndex _ srcIndex + 4.
			srcShift = 0 ifTrue:[dstIndex _ dstIndex + 4].
			srcShift _ srcShift bitXor: 16. "Toggle between 0 and 16"
			dstMask _ dstMask bitInvert32. "Mask other half word"
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 10/25/1999 19:16'!
alphaSourceBlendBits32
	"This version assumes 
		combinationRule = 34
		sourcePixSize = destPixSize = 32
		sourceForm ~= destForm.
	Note: The inner loop has been optimized for dealing
		with the special cases of srcAlpha = 0.0 and srcAlpha = 1.0 
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY |
	self inline: false. "This particular method should be optimized in itself"

	"Give the compile a couple of hints"
	self var: #sourceWord declareC:'register int sourceWord'.
	self var: #deltaX declareC:'register int deltaX'.

	"The following should be declared as pointers so the compiler will
	notice that they're used for accessing memory locations 
	(good to know on an Intel architecture) but then the increments
	would be different between ST code and C code so must hope the
	compiler notices what happens (MS Visual C does)"
	self var: #srcIndex declareC:'register int srcIndex'.
	self var: #dstIndex declareC:'register int dstIndex'.

	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.

	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx * 4).
		deltaX _ bbW + 1. "So we can pre-decrement"

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			sourceWord _ self srcLongAt: srcIndex.
			srcAlpha _ sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				self dstLongAt: dstIndex put: sourceWord.
				srcIndex _ srcIndex + 4.
				dstIndex _ dstIndex + 4.
				"Now copy as many words as possible with alpha = 255"
				[(deltaX _ deltaX - 1) ~= 0 and:[
					(sourceWord _ self srcLongAt: srcIndex) >> 24 = 255]]
						whileTrue:[
							self dstLongAt: dstIndex put: sourceWord.
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
				"Adjust deltaX"
				deltaX _ deltaX + 1.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
					"Now skip as many words as possible,"
					[(deltaX _ deltaX - 1) ~= 0 and:[
						(sourceWord _ self srcLongAt: srcIndex) >> 24 = 0]]
						whileTrue:[
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
					"Adjust deltaX"
					deltaX _ deltaX + 1.
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord _ self dstLongAt: dstIndex.
					destWord _ self alphaBlendScaled: sourceWord with: destWord.
					self dstLongAt: dstIndex put: destWord.
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
				].
			].
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 10/28/1999 19:53'!
alphaSourceBlendBits8
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 8
		sourceForm ~= destForm.
	Note: This is not real blending since we don't have the source colors available.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift adjust mappingTable |
	self inline: false. "This particular method should be optimized in itself"
	self var: #mappingTable declareC:'unsigned int *mappingTable'.
	mappingTable _ self default8To32Table.
	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.
	mask1 _ 24 - ((dx bitAnd: 3) * 8).
	mask2 _ AllOnes bitXor:(16rFF << mask1).
	(dx bitAnd: 1) = 0 
		ifTrue:[adjust _ 0]
		ifFalse:[adjust _ 16r1F1F1F1F].
	(dy bitAnd: 1) = 0
		ifTrue:[adjust _ adjust bitXor: 16r1F1F1F1F].
	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		adjust _ adjust bitXor: 16r1F1F1F1F.
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx // 4 * 4).
		deltaX _ bbW + 1. "So we can pre-decrement"
		srcShift _ mask1.
		dstMask _ mask2.

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			sourceWord _ ((self srcLongAt: srcIndex) bitAnd: (adjust bitInvert32)) + adjust.
			srcAlpha _ sourceWord >> 24.
			srcAlpha > 31 ifTrue:["Everything below 31 is transparent"
				srcAlpha < 224 ifTrue:["Everything above 224 is opaque"
					destWord _ self dstLongAt: dstIndex.
					destWord _ destWord bitAnd: dstMask bitInvert32.
					destWord _ destWord >> srcShift.
					destWord _ mappingTable at: destWord.
					sourceWord _ self alphaBlendScaled: sourceWord with: destWord.
				].
				sourceWord _ self rgbMap: sourceWord from: 8 to: cmBitsPerColor.
				sourceWord _ self colormapAt: sourceWord.
				sourceWord _ sourceWord << srcShift.
				"Store back"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			].
			srcIndex _ srcIndex + 4.
			srcShift = 0 ifTrue:[
				dstIndex _ dstIndex + 4.
				srcShift _ 24.
				dstMask _ 16r00FFFFFF.
			] ifFalse:[
				srcShift _ srcShift - 8.
				dstMask _ (dstMask >> 8) bitOr: 16rFF000000.
			].
			adjust _ adjust bitXor: 16r1F1F1F1F.
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 3/21/2000 09:11'!
copyLoop
	| prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith destWord |
	"This version of the inner loop assumes noSource = false."
	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"
	hInc _ hDir*4.  "Byte delta"
	"degenerate skew fixed for Sparc. 10/20/96 ikp"
	skew == -32
		ifTrue: [skew _ unskew _ skewMask _ 0]
		ifFalse: [skew < 0
			ifTrue:
				[unskew _ skew+32.
				skewMask _ AllOnes << (0-skew)]
			ifFalse:
				[skew = 0
					ifTrue:
						[unskew _ 0.
						skewMask _ AllOnes]
					ifFalse:
						[unskew _ skew-32.
						skewMask _ AllOnes >> skew]]].
	notSkewMask _ skewMask bitInvert32.
	noHalftone
		ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]
		ifFalse: [halftoneWord _ self halftoneAt: 0].

	y _ dy.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
			[halftoneWord _ self halftoneAt: y.
			y _ y + vDir].
		preload ifTrue:
			["load the 64-bit shifter"
			prevWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc]
			ifFalse:
			[prevWord _ 0].

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

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

		"This central horizontal loop requires no store masking"
		destMask _ AllOnes.
combinationRule = 3
ifTrue: [(skew = 0) & (halftoneWord = AllOnes)
		ifTrue:  
		["Very special inner loop for STORE mode with no skew -- just move words"
		2 to: nWords-1 do: 
			[ :word |  "Note loop starts with prevWord loaded (due to preload)"
			self dstLongAt: destIndex put: prevWord.
			destIndex _ destIndex + hInc.
			prevWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc]]
		ifFalse:
		["Special inner loop for STORE mode -- no need to call merge"
		2 to: nWords-1 do: 
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			self dstLongAt: destIndex put: (skewWord bitAnd: halftoneWord).
			destIndex _ destIndex + hInc]]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
							with: (self dstLongAt: destIndex).
			self dstLongAt: destIndex put: mergeWord.
			destIndex _ destIndex + hInc]
].

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

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

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 12/7/1999 21:37'!
copyLoopNoSource
	| halftoneWord mergeWord mergeFnwith destWord |
	"Faster copyLoop when source not used.  hDir and vDir are both
	positive, and perload and skew are unused"

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

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].

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

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

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

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

	destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 12/7/1999 20:58'!
copyLoopPixMap
	"This version of the inner loop maps source pixels
	to a destination form with different depth.  Because it is already
	unweildy, the loop is not unrolled as in the other versions.
	Preload, skew and skewMask are all overlooked, since pickSourcePixels
	delivers its destination word already properly aligned.
	Note that pickSourcePixels could be copied in-line at the top of
	the horizontal loop, and some of its inits moved out of the loop."
	"ar 12/7/1999:
	The loop has been rewritten to use only one pickSourcePixels call.
	The idea is that the call itself could be inlined. If we decide not
	to inline pickSourcePixels we could optimize the loop instead."
	| skewWord halftoneWord mergeWord srcPixPerWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask nullMap mergeFnwith nPix srcShift dstShift destWord words |
	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"

	"Additional inits peculiar to unequal source and dest pix size..."
	srcPixPerWord _ 32//sourcePixSize.
	sourcePixMask _ maskTable at: sourcePixSize.
	destPixMask _ maskTable at: destPixSize.
	nullMap _ colorMap = nil.
	sourceIndex _ sourceBits +
					(sy * sourcePitch) + ((sx // srcPixPerWord) *4).
	scrStartBits _ srcPixPerWord - (sx bitAnd: srcPixPerWord-1).
	bbW < scrStartBits
		ifTrue: [nSourceIncs _ 0]
		ifFalse: [nSourceIncs _ (bbW - scrStartBits)//srcPixPerWord + 1].
	sourceDelta _ sourcePitch - (nSourceIncs * 4).

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

	bbW < startBits ifTrue:[startBits _ bbW].

	"Precomputed shifts for pickSourcePixels"
	srcShift _ 32 - ((sx bitAnd: srcPixPerWord - 1) + 1 * sourcePixSize).
	dstShift _ 32 - ((dx bitAnd: pixPerWord - 1) + 1 * destPixSize).

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		"*** is it possible at all that noHalftone == false? ***"
		noHalftone
			ifTrue:[halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		"setup first load"
		srcBitShift _ srcShift.
		dstBitShift _ dstShift.
		destMask _ mask1.
		nPix _ startBits.
		"Here is the horizontal loop..."
		words _ nWords.
			["pick up the word"
			skewWord _ self pickSourcePixels: nPix nullMap: nullMap 
								srcMask: sourcePixMask destMask: destPixMask.

			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord _ self dstLongAt: destIndex.
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord _ (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ pixPerWord].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		sourceIndex _ sourceIndex + sourceDelta.
		destIndex _ destIndex + destDelta]
! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 2/19/2000 21:24'!
warpLoop
	"ar 12/7/1999: This version is unused but kept as reference implemenation"
	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
	| skewWord halftoneWord mergeWord startBits
	  deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy
	  xDelta yDelta pBx pBy smoothingCount sourceMapOop nSteps t |
	self inline: false.
 
	(interpreterProxy slotSizeOf: bitBltOop) >= (BBWarpBase+12)
		ifFalse: [^ interpreterProxy primitiveFail].
	nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

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

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

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

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

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

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

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

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

!BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 2/19/2000 21:24'!
xWarpLoop
	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
	| skewWord halftoneWord mergeWord startBits
	  deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy pBx pBy
	  xDelta yDelta smoothingCount sourceMapOop 
	  nSteps nPix words destWord endBits mergeFnwith |
	self inline: false.
	self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
	mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
	mergeFnwith.  "null ref for compiler"
 
	(interpreterProxy slotSizeOf: bitBltOop) >= (BBWarpBase+12)
		ifFalse: [^ interpreterProxy primitiveFail].
	nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

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

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

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

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

	interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"
	interpreterProxy methodArgumentCount = 2
		ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.
				sourceMapOop _ interpreterProxy stackValue: 0.
				sourceMapOop = interpreterProxy nilObject
				ifTrue: [sourcePixSize < 16 ifTrue:
					["color map is required to smooth non-RGB dest"
					^ interpreterProxy primitiveFail]]
				ifFalse: [(interpreterProxy slotSizeOf: sourceMapOop)
							< (1 << sourcePixSize) ifTrue:
					["sourceMap must be long enough for sourcePixSize"
					^ interpreterProxy primitiveFail].
					sourceMapOop _ self cCoerce: (interpreterProxy firstIndexableField: sourceMapOop) to:'int']]
		ifFalse: [smoothingCount _ 1.
				sourceMapOop _ interpreterProxy nilObject].
	nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].
	startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).
	endBits _ ((dx + bbW - 1) bitAnd: pixPerWord-1) + 1.
 	bbW < startBits ifTrue:[startBits _ bbW].

	destY < clipY ifTrue:[
		"Advance increments if there was clipping in y"
		pAx _ pAx + (clipY - destY * deltaP12x).
		pAy _ pAy + (clipY - destY * deltaP12y).
		pBx _ pBx + (clipY - destY * deltaP43x).
		pBy _ pBy + (clipY - destY * deltaP43y)].

	"Setup values for faster pixel fetching.
	Note: this should really go into a separate method
	since it only sets up globals so there is no need to
	have it in this method."

		"warpSrcShift = log2(sourcePixSize)"
		warpSrcShift _ 0.
		words _ sourcePixSize. "recycle temp"
		[words = 1] whileFalse:[
			warpSrcShift _ warpSrcShift + 1.
			words _ words >> 1].

		"warpSrcMask = mask for extracting one pixel from source word"
		warpSrcMask _ maskTable at: sourcePixSize.

		"warpAlignShift: Shift for aligning x position to word boundary"
		warpAlignShift _ 5 - warpSrcShift.

		"warpAlignMask: Mask for extracting the pixel position from an x position"
		warpAlignMask _ 1 << warpAlignShift - 1.

		"Setup the lookup table for source bit shifts"
		"warpBitShiftTable: given an sub-word x value what's the bit shift?"
		0 to: warpAlignMask do:[:i|
			warpBitShiftTable at: i put: 32 - ( i + 1 << warpSrcShift )].

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

		dstBitShift _ 32 - ((dx bitAnd: pixPerWord - 1) + 1 * destPixSize).

		(destX < clipX) ifTrue:[
			"Advance increments if there was clipping in x"
			sx _ sx + (clipX - destX * xDelta).
			sy _ sy + (clipX - destX * yDelta).
		].

		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		destMask _ mask1.
		nPix _ startBits.
		"Here is the inner loop..."
		words _ nWords.
			["pick up word"
			smoothingCount = 1 ifTrue:["Faster if not smoothing"
				skewWord _ self warpPickSourcePixels: nPix
								xDeltah: xDelta yDeltah: yDelta
								xDeltav: deltaP12x yDeltav: deltaP12y.
			] ifFalse:["more difficult with smoothing"
				skewWord _ self warpPickSmoothPixels: nPix
						xDeltah: xDelta yDeltah: yDelta
						xDeltav: deltaP12x yDeltav: deltaP12y
						sourceMap: sourceMapOop
						smoothing: smoothingCount.
			].
			destMask = AllOnes ifTrue:["avoid read-modify-write"
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (self dstLongAt: destIndex).
				self dstLongAt: destIndex put: (destMask bitAnd: mergeWord).
			] ifFalse:[ "General version using dest masking"
				destWord _ self dstLongAt: destIndex.
				mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
								with: (destWord bitAnd: destMask).
				destWord _ (destMask bitAnd: mergeWord) bitOr:
								(destWord bitAnd: destMask bitInvert32).
				self dstLongAt: destIndex put: destWord.
			].
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ pixPerWord].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		pAx _ pAx + deltaP12x.
		pAy _ pAy + deltaP12y.
		pBx _ pBx + deltaP43x.
		pBy _ pBy + deltaP43y.
		destIndex _ destIndex + destDelta]! !


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

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

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

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

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:55'!
alphaBlendConst: sourceWord with: destinationWord

	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: false! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:21'!
alphaBlendConst: sourceWord with: destinationWord paintMode: paintMode
	"Blend sourceWord with destinationWord using a constant alpha.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	The blend produced is alpha*source + (1.0-alpha)*dest, with the
	computation being performed independently on each color component.
	This function could eventually blend into any depth destination,
	using the same color averaging and mapping as warpBlt.
	paintMode = true means do nothing if the source pixel value is zero."

	"This first implementation works with dest depths of 16 and 32 bits only.
	Normal color mapping will allow sources of lower depths in this case,
	and results can be mapped directly by truncation, so no extra color maps are needed.
	To allow storing into any depth will require subsequent addition of two other
	colormaps, as is the case with WarpBlt."

	| pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor |
	self inline: false.
	destPixSize < 16 ifTrue: [^ destinationWord "no-op"].
	unAlpha _ 255 - sourceAlpha.
	pixMask _ maskTable at: destPixSize.
	destPixSize = 16 
		ifTrue: [bitsPerColor _ 5]
		ifFalse:[bitsPerColor _ 8].
	rgbMask _ (1<<bitsPerColor) - 1.
	maskShifted _ destMask.
	destShifted _ destinationWord.
	sourceShifted _ sourceWord.
	result _ destinationWord.
	1 to: pixPerWord do:
		[:j |
		sourcePixVal _ sourceShifted bitAnd: pixMask.
		((maskShifted bitAnd: pixMask) = 0  "no effect if outside of dest rectangle"
			or: [paintMode & (sourcePixVal = 0)  "or painting a transparent pixel"])
		ifFalse:
			[destPixVal _ destShifted bitAnd: pixMask.
			pixBlend _ 0.
			1 to: 3 do:
				[:i | shift _ (i-1)*bitsPerColor.
				blend _ (((sourcePixVal>>shift bitAnd: rgbMask) * sourceAlpha)
							+ ((destPixVal>>shift bitAnd: rgbMask) * unAlpha))
					 	+ 254 // 255 bitAnd: rgbMask.
				pixBlend _ pixBlend bitOr: blend<<shift].
			destPixSize = 16
				ifTrue: [result _ (result bitAnd: (pixMask << (j-1*16)) bitInvert32)
									bitOr: pixBlend << (j-1*16)]
				ifFalse: [result _ pixBlend]].
		maskShifted _ maskShifted >> destPixSize.
		sourceShifted _ sourceShifted >> destPixSize.
		destShifted _ destShifted >> destPixSize].
	^ result
! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 11/27/1998 23:56'!
alphaBlendScaled: sourceWord with: destinationWord
	"Blend sourceWord with destinationWord using the alpha value from sourceWord.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	In contrast to alphaBlend:with: the color produced is

		srcColor + (1-srcAlpha) * dstColor

	e.g., it is assumed that the source color is already scaled."
	| unAlpha dstMask srcMask b g r a |
	self inline: false.	"Do NOT inline this into optimized loops"
	unAlpha _ 255 - (sourceWord >> 24).  "High 8 bits of source pixel"
	dstMask _ destinationWord.
	srcMask _ sourceWord.
	b _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	b > 255 ifTrue:[b _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	g _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	g > 255 ifTrue:[g _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	r _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	r > 255 ifTrue:[r _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	a _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	a > 255 ifTrue:[a _ 255].
	^(((((a << 8) + r) << 8) + g) << 8) + b! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:56'!
alphaPaintConst: sourceWord with: destinationWord

	sourceWord = 0 ifTrue: [^ destinationWord  "opt for all-transparent source"].
	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: true! !

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	^ self mergeFn: sourceWord with: destinationWord! !

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

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

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

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

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

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

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

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

!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:12'!
rgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination, color by color,
	and return the sum of the absolute value of all the differences.
	For non-rgb, return the number of differing pixels."
	| pixMask destShifted sourceShifted destPixVal bitsPerColor rgbMask sourcePixVal diff maskShifted |
	self inline: false.
	pixMask _ maskTable at: destPixSize.
	destPixSize = 16
		ifTrue: [bitsPerColor _ 5.  rgbMask _ 16r1F]
		ifFalse: [bitsPerColor _ 8.  rgbMask _ 16rFF].
	maskShifted _ destMask.
	destShifted _ destinationWord.
	sourceShifted _ sourceWord.
	1 to: pixPerWord do:
		[:i |
		(maskShifted bitAnd: pixMask) > 0 ifTrue:
			["Only tally pixels within the destination rectangle"
			destPixVal _ destShifted bitAnd: pixMask.
			sourcePixVal _ sourceShifted bitAnd: pixMask.
			destPixSize < 16
				ifTrue: [sourcePixVal = destPixVal
							ifTrue: [diff _ 0]
							ifFalse: [diff _ 1]]
				ifFalse: [diff _ (self partitionedSub: sourcePixVal from: destPixVal
								nBits: bitsPerColor nPartitions: 3).
						diff _ (diff bitAnd: rgbMask)
							+ (diff>>bitsPerColor bitAnd: rgbMask)
							+ ((diff>>bitsPerColor)>>bitsPerColor bitAnd: rgbMask)].
			bitCount _ bitCount + diff].
		maskShifted _ maskShifted >> destPixSize.
		sourceShifted _ sourceShifted >> destPixSize.
		destShifted _ destShifted >> destPixSize].
	^ destinationWord  "For no effect on dest"
! !

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

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

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

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

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

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

!BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 10/23/1999 20:46'!
tallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the color map.  Those tallied are exactly those
	in the destination rectangle.  Note that the source should be 
	specified == destination, in order for the proper color map checks 
	to be performed at setup."
	| mapIndex pixMask destShifted maskShifted pixVal |
	self inline: false.
	colorMap = nil
		ifTrue: [^ destinationWord "no op"].
	pixMask _ maskTable at: destPixSize.
	destShifted _ destinationWord.
	maskShifted _ destMask.
	1 to: pixPerWord do:
		[:i |
		(maskShifted bitAnd: pixMask) = 0 ifFalse:
			["Only tally pixels within the destination rectangle"
			pixVal _ destShifted bitAnd: pixMask.
			destPixSize < 16
				ifTrue: [mapIndex _ pixVal]
				ifFalse: [destPixSize = 16
					ifTrue: [mapIndex _ self rgbMap: pixVal from: 5 to: cmBitsPerColor]
					ifFalse: [mapIndex _ self rgbMap: pixVal from: 8 to: cmBitsPerColor]].
			self colormapAt: mapIndex put: (self colormapAt: mapIndex) + 1].
		maskShifted _ maskShifted >> destPixSize.
		destShifted _ destShifted >> destPixSize].
	^ destinationWord  "For no effect on dest"! !


!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 11/16/1998 00:23'!
default8To32Table
	"Return the default translation table from 1..8 bit indexed colors to 32bit"
	"The table has been generated by the following statements"
	"| pvs hex |
	String streamContents:[:s|
		s nextPutAll:'static unsigned int theTable[256] = { '.
		pvs _ (Color colorMapIfNeededFrom: 8 to: 32) asArray.
		1 to: pvs size do:[:i|
			i > 1 ifTrue:[s nextPutAll:', '].
			(i-1 \\ 8) = 0 ifTrue:[s cr].
			s nextPutAll:'0x'.
			hex _ (pvs at: i) printStringBase: 16.
			s nextPutAll: (hex copyFrom: 4 to: hex size).
		].
		s nextPutAll:'};'.
	]."
	| theTable |
	self returnTypeC:'unsigned int *'.
	self var: #theTable declareC:'static unsigned int theTable[256] = { 
0x0, 0xFF000001, 0xFFFFFFFF, 0xFF808080, 0xFFFF0000, 0xFF00FF00, 0xFF0000FF, 0xFF00FFFF, 
0xFFFFFF00, 0xFFFF00FF, 0xFF202020, 0xFF404040, 0xFF606060, 0xFF9F9F9F, 0xFFBFBFBF, 0xFFDFDFDF, 
0xFF080808, 0xFF101010, 0xFF181818, 0xFF282828, 0xFF303030, 0xFF383838, 0xFF484848, 0xFF505050, 
0xFF585858, 0xFF686868, 0xFF707070, 0xFF787878, 0xFF878787, 0xFF8F8F8F, 0xFF979797, 0xFFA7A7A7, 
0xFFAFAFAF, 0xFFB7B7B7, 0xFFC7C7C7, 0xFFCFCFCF, 0xFFD7D7D7, 0xFFE7E7E7, 0xFFEFEFEF, 0xFFF7F7F7, 
0xFF000001, 0xFF003300, 0xFF006600, 0xFF009900, 0xFF00CC00, 0xFF00FF00, 0xFF000033, 0xFF003333, 
0xFF006633, 0xFF009933, 0xFF00CC33, 0xFF00FF33, 0xFF000066, 0xFF003366, 0xFF006666, 0xFF009966, 
0xFF00CC66, 0xFF00FF66, 0xFF000099, 0xFF003399, 0xFF006699, 0xFF009999, 0xFF00CC99, 0xFF00FF99, 
0xFF0000CC, 0xFF0033CC, 0xFF0066CC, 0xFF0099CC, 0xFF00CCCC, 0xFF00FFCC, 0xFF0000FF, 0xFF0033FF, 
0xFF0066FF, 0xFF0099FF, 0xFF00CCFF, 0xFF00FFFF, 0xFF330000, 0xFF333300, 0xFF336600, 0xFF339900, 
0xFF33CC00, 0xFF33FF00, 0xFF330033, 0xFF333333, 0xFF336633, 0xFF339933, 0xFF33CC33, 0xFF33FF33, 
0xFF330066, 0xFF333366, 0xFF336666, 0xFF339966, 0xFF33CC66, 0xFF33FF66, 0xFF330099, 0xFF333399, 
0xFF336699, 0xFF339999, 0xFF33CC99, 0xFF33FF99, 0xFF3300CC, 0xFF3333CC, 0xFF3366CC, 0xFF3399CC, 
0xFF33CCCC, 0xFF33FFCC, 0xFF3300FF, 0xFF3333FF, 0xFF3366FF, 0xFF3399FF, 0xFF33CCFF, 0xFF33FFFF, 
0xFF660000, 0xFF663300, 0xFF666600, 0xFF669900, 0xFF66CC00, 0xFF66FF00, 0xFF660033, 0xFF663333, 
0xFF666633, 0xFF669933, 0xFF66CC33, 0xFF66FF33, 0xFF660066, 0xFF663366, 0xFF666666, 0xFF669966, 
0xFF66CC66, 0xFF66FF66, 0xFF660099, 0xFF663399, 0xFF666699, 0xFF669999, 0xFF66CC99, 0xFF66FF99, 
0xFF6600CC, 0xFF6633CC, 0xFF6666CC, 0xFF6699CC, 0xFF66CCCC, 0xFF66FFCC, 0xFF6600FF, 0xFF6633FF, 
0xFF6666FF, 0xFF6699FF, 0xFF66CCFF, 0xFF66FFFF, 0xFF990000, 0xFF993300, 0xFF996600, 0xFF999900, 
0xFF99CC00, 0xFF99FF00, 0xFF990033, 0xFF993333, 0xFF996633, 0xFF999933, 0xFF99CC33, 0xFF99FF33, 
0xFF990066, 0xFF993366, 0xFF996666, 0xFF999966, 0xFF99CC66, 0xFF99FF66, 0xFF990099, 0xFF993399, 
0xFF996699, 0xFF999999, 0xFF99CC99, 0xFF99FF99, 0xFF9900CC, 0xFF9933CC, 0xFF9966CC, 0xFF9999CC, 
0xFF99CCCC, 0xFF99FFCC, 0xFF9900FF, 0xFF9933FF, 0xFF9966FF, 0xFF9999FF, 0xFF99CCFF, 0xFF99FFFF, 
0xFFCC0000, 0xFFCC3300, 0xFFCC6600, 0xFFCC9900, 0xFFCCCC00, 0xFFCCFF00, 0xFFCC0033, 0xFFCC3333, 
0xFFCC6633, 0xFFCC9933, 0xFFCCCC33, 0xFFCCFF33, 0xFFCC0066, 0xFFCC3366, 0xFFCC6666, 0xFFCC9966, 
0xFFCCCC66, 0xFFCCFF66, 0xFFCC0099, 0xFFCC3399, 0xFFCC6699, 0xFFCC9999, 0xFFCCCC99, 0xFFCCFF99, 
0xFFCC00CC, 0xFFCC33CC, 0xFFCC66CC, 0xFFCC99CC, 0xFFCCCCCC, 0xFFCCFFCC, 0xFFCC00FF, 0xFFCC33FF, 
0xFFCC66FF, 0xFFCC99FF, 0xFFCCCCFF, 0xFFCCFFFF, 0xFFFF0000, 0xFFFF3300, 0xFFFF6600, 0xFFFF9900, 
0xFFFFCC00, 0xFFFFFF00, 0xFFFF0033, 0xFFFF3333, 0xFFFF6633, 0xFFFF9933, 0xFFFFCC33, 0xFFFFFF33, 
0xFFFF0066, 0xFFFF3366, 0xFFFF6666, 0xFFFF9966, 0xFFFFCC66, 0xFFFFFF66, 0xFFFF0099, 0xFFFF3399, 
0xFFFF6699, 0xFFFF9999, 0xFFFFCC99, 0xFFFFFF99, 0xFFFF00CC, 0xFFFF33CC, 0xFFFF66CC, 0xFFFF99CC, 
0xFFFFCCCC, 0xFFFFFFCC, 0xFFFF00FF, 0xFFFF33FF, 0xFFFF66FF, 0xFFFF99FF, 0xFFFFCCFF, 0xFFFFFFFF};'.
	^theTable! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/27/1999 17:54'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments."
	self inline: true.
	x2 > x1
		ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 7/24/1999 19:16'!
dither32To16: srcWord threshold: ditherValue
	"Dither the given 32bit word to 16 bit. Ignore alpha."
	| pv threshold value out |
	self inline: true. "You bet"
	pv _ srcWord bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ value + 1]
		ifFalse:[out _ value].
	pv _ (srcWord bitShift: -8) bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ out bitOr: (value+1 bitShift:5)]
		ifFalse:[out _ out bitOr: (value bitShift: 5)].
	pv _ (srcWord bitShift: -16) bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ out bitOr: (value+1 bitShift:10)]
		ifFalse:[out _ out bitOr: (value bitShift: 10)].
	^out! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 12/7/1999 21:00'!
pickSourcePixels: nPixels nullMap: nullMap srcMask: srcMask destMask: dstMask
	"Pick nPix pixels starting at srcBitIndex from the source, map by the
	color map, and justify them according to dstBitIndex in the resulting destWord.
	Incoming pixels of 16 or 32 bits are first reduced to cmBitsPerColor.
	With no color map, pixels are just masked or zero-filled or
	if 16- or 32-bit pixels, the r, g, and b are so treated individually."
	"ar 12/7/1999:
	- the method currently has a side effect (see at the end)
	- the idea is to inline this into a single sender and do 
	most of the color space stuff here
	- the '[...] whileFalse' is intended to generate 
	'do { ... } while(...)' loops which are faster"
	| sourceWord destWord sourcePix destPix srcShift dstShift nPix |
	self inline: true. "oh please"
	sourceWord _ self srcLongAt: sourceIndex.
	destWord _ 0.
	srcShift _ srcBitShift. "Hint: Keep in register"
	dstShift _ dstBitShift. "Hint: Keep in register"
	nPix _ nPixels. "always > 0 so we can use do { } while(--nPix);"
	(nullMap or:[sourcePixSize > 8]) ifTrue:[
		"Extract the degenerate case of sourcePixSize <= 8 and nullMap.
		Note: The case is considered degenerate because there should always
		be a colormap when copying between indexed color forms of differing depth."
		sourcePixSize <= 8 ifTrue:[
			"Degenerate so the dirty version w/o comments..."
			[destWord _ destWord bitOr: 
				((sourceWord >> srcShift bitAnd: srcMask) bitAnd: dstMask) << dstShift.
			dstShift _ dstShift - destPixSize.
			(srcShift _ srcShift - sourcePixSize) < 0 ifTrue:
				[srcShift _ srcShift + 32.
				sourceWord _ self srcLongAt: (sourceIndex _ sourceIndex + 4)].
			(nPix _ nPix - 1) = 0] whileFalse.
		] ifFalse:["sourcePixSize > 8"
			"Convert RGB pixels. Since the cmMasks and cmShifts have been
			setup initially we only need one version here."
			["pick source pixel"
			sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
			"map the pixel(either into colorMap or destFormat)"
			cmDeltaBits = 0 "e.g., srcFormat == dstFormat"
				ifTrue:[destPix _ sourcePix]
				ifFalse:[	destPix _ self rgbMap: sourcePix.
						"Avoid transparency by color conversion"
						(destPix = 0 and:[sourcePix ~= 0]) ifTrue:[destPix _ 1]].
			"if nullMap == false do colormap lookup after color reduction"
			nullMap ifFalse:[destPix _ self colormapAt: destPix].
			"Mix it in (note: in theory we could avoid the bitAnd but its safer for now)"
			destWord _ destWord bitOr: (destPix bitAnd: dstMask) << dstShift.
			dstShift _ dstShift - destPixSize.
			"Adjust source if at pixel boundary"
			(srcShift _ srcShift - sourcePixSize) < 0 ifTrue:
				[srcShift _ srcShift + 32.
				sourceWord _ self srcLongAt: (sourceIndex _ sourceIndex + 4)].
			(nPix _ nPix - 1) = 0] whileFalse.
		].
	] ifFalse:[
		"This part executed if we have a source pix size <= 8
		and a colormap lookup as in the regular text display."
		[
			"pick source pixel"
			sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
			"Map it by color map"
			destPix _ (self colormapAt: sourcePix) bitAnd: dstMask.
			"**** How do we find out if we have to do color space conversion here ****"
			"Mix it in"
			destWord _ destWord bitOr: destPix << dstShift.
			"adjust shift"
			dstShift _ dstShift - destPixSize.
			"Adjust source if at pixel boundary"
			(srcShift _ srcShift - sourcePixSize) < 0 ifTrue:
				[srcShift _ srcShift + 32.
				sourceWord _ self srcLongAt: (sourceIndex _ sourceIndex + 4)].
		(nPix _ nPix - 1) = 0] whileFalse.
	].
	srcBitShift _ srcShift. "Store back"
	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	dstBitShift _ 32 - destPixSize. "Shift towards leftmost pixel"
	^destWord! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/29/1999 00:11'!
pickWarpPixelAtX: xx y: yy
	"Pick a single pixel from the source for WarpBlt.
	Note: This method is crucial for WarpBlt speed w/o smoothing
	and still relatively important when smoothing is used."
	| x y srcIndex sourceWord sourcePix |
	self inline: true. "*please*"

	"note: it would be much faster if we could just
	avoid these stupid tests for being inside sourceForm."
	(xx < 0 or:[yy < 0 or:[
		(x _ xx >> BinaryPoint) >= srcWidth or:[
			(y _ yy >> BinaryPoint) >= srcHeight]]]) ifTrue:[^0]. "out of bounds"

	"Fetch source word.
	Note: We should really update srcIndex with sx and sy so that
	we don't have to do the computation below. We might even be
	able to simplify the out of bounds test from above."
	srcIndex _ sourceBits + (y * sourcePitch) + (x >> warpAlignShift * 4).
	sourceWord _ self srcLongAt: srcIndex.

	"Extract pixel from word"
	srcBitShift _ warpBitShiftTable at: (x bitAnd: warpAlignMask).
	sourcePix _ sourceWord >> srcBitShift bitAnd: warpSrcMask.
	^sourcePix! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/28/1999 18:30'!
rgbMap: sourcePixel
	"Color map the given source pixel.
	Note: This relies on an accurate setup of the cmShifts and cmMasks
	by BitBlt and can therefore not be used from WarpBlt in smoothing
	mode (but hey, then we have to go over lots of different pixels
	before we even come to the output color conversion so that doesn't
	really matter)."
	self inline: true. "you bet"
	cmDeltaBits < 0 "Compress or expand RGB values?!!"
		ifTrue:[^((sourcePixel bitAnd: cmRedMask) >> cmRedShift) bitOr:
					(((sourcePixel bitAnd: cmGreenMask) >> cmGreenShift) bitOr:
						((sourcePixel bitAnd: cmBlueMask) >> cmBlueShift))]
		ifFalse:[^((sourcePixel bitAnd: cmRedMask) << cmRedShift) bitOr:
					(((sourcePixel bitAnd: cmGreenMask) << cmGreenShift) bitOr:
						((sourcePixel bitAnd: cmBlueMask) << cmBlueShift))]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 4/10/1999 17:27'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
	| mask d srcPix destPix |
	self inline: true.
	(d _ nBitsOut - nBitsIn) > 0
		ifTrue:
			["Expand to more bits by zero-fill"
			mask _ (1 << nBitsIn) - 1.  "Transfer mask"
			srcPix _ sourcePixel << d.
			mask _ mask << d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix << d.
			^ destPix + (srcPix bitAnd: mask)
				 	+ (srcPix << d bitAnd: mask << nBitsOut)]
		ifFalse:
			["Compress to fewer bits by truncation"
			d = 0 ifTrue:
				[nBitsIn = 5 ifTrue:
					["Sometimes called with 16 bits, though pixel is 15,
					but we must never return more than 15."
					^ sourcePixel bitAnd: 16r7FFF].
				nBitsIn = 8 ifTrue:
					["Sometimes called with 32 bits, though pixel is 24,
					but we must never return more than 24."
					^ sourcePixel bitAnd: 16rFFFFFF].
				^ sourcePixel].  "no compression"
			sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
			d _ nBitsIn - nBitsOut.
			mask _ (1 << nBitsOut) - 1.  "Transfer mask"
			srcPix _ sourcePixel >> d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix >> d.
			destPix _ destPix + (srcPix bitAnd: mask)
					+ (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
			^ destPix]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/23/1999 20:45'!
smoothPix: n atXf: xf yf: yf dxh: dxh dyh: dyh dxv: dxv dyv: dyv
	pixPerWord: srcPixPerWord pixelMask: sourcePixMask
	sourceMap: sourceMap
	| sourcePix r g b x y rgb bitsPerColor d nPix maxPix |
	self inline: false.
	r _ g _ b _ 0.  "Separate r, g, b components"
	maxPix _ n*n.
	x _ xf.  y _ yf.
	nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
	0 to: n-1 do:
		[:i |
		0 to: n-1 do:
			[:j |
			sourcePix _ (self sourcePixAtX: x + (dxh*i) + (dxv*j)  >> BinaryPoint
									y: y + (dyh*i) + (dyv*j)  >> BinaryPoint
									pixPerWord: srcPixPerWord)
									bitAnd: sourcePixMask.
			(combinationRule=25 "PAINT" and: [sourcePix = 0]) ifFalse:  
			["If not clipped and not transparent, then tally rgb values"
			nPix _ nPix + 1.
			sourcePixSize < 16
				ifTrue: ["Get 24-bit RGB values from sourcemap table"
						rgb _ (interpreterProxy fetchWord: sourcePix ofObject: sourceMap) bitAnd: 16rFFFFFF]
				ifFalse: ["Already in RGB format"
						sourcePixSize = 32
						ifTrue: [rgb _ sourcePix bitAnd: 16rFFFFFF]
						ifFalse: ["Note could be faster"
								rgb _ self rgbMap: sourcePix from: 5 to: 8]].
			r _ r + ((rgb >> 16) bitAnd: 16rFF).
			g _ g + ((rgb >> 8) bitAnd: 16rFF).
			b _ b + (rgb bitAnd: 16rFF).
			]].
		].
	(nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (maxPix//2)]])
		ifTrue: [^ 0  "All pixels were 0, or most were transparent"].
	colorMap ~= nil
		ifTrue: [bitsPerColor _ cmBitsPerColor]
		ifFalse: [destPixSize = 16 ifTrue: [bitsPerColor _ 5].
				destPixSize = 32 ifTrue: [bitsPerColor _ 8]].
	d _ 8 - bitsPerColor.
	rgb _ ((r // nPix >> d) << (bitsPerColor*2))
		+ ((g // nPix >> d) << bitsPerColor)
		+ ((b // nPix >> d)).
	rgb = 0 ifTrue: [
		"only generate zero if pixel is really transparent"
		(r + g + b) > 0 ifTrue: [rgb _ 1]].
	colorMap ~= nil
		ifTrue: [^self colormapAt: rgb]
		ifFalse: [^ rgb]
! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/25/1999 19:24'!
sourcePixAtX: x y: y pixPerWord: srcPixPerWord
	| sourceWord index |
	self inline: true.
	(x < 0 or: [x >= srcWidth]) ifTrue: [^ 0].
	(y < 0 or: [y >= srcHeight]) ifTrue: [^ 0].
	index _ (y * sourcePitch) + ((x // srcPixPerWord) *4).
	sourceWord _ self srcLongAt: sourceBits + index.
	^ sourceWord >> ((32-sourcePixSize) - (x\\srcPixPerWord*sourcePixSize))! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/27/1999 17:10'!
warpPickSmoothPixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	sourceMap: sourceMap
	smoothing: n
	"Pick n (sub-) pixels from the source form, mapped by sourceMap,
	average the RGB values, map by colorMap and return the new word.
	This version is only called from WarpBlt with smoothingCount > 1"
	| rgb x y a r g b xx yy xdh ydh xdv ydv dstMask destWord i j k nPix |
	self inline: false. "nope - too much stuff in here"
	dstMask _ maskTable at: destPixSize.
	destWord _ 0.
	n = 2 "Try avoiding divides for most common n (divide by 2 is generated as shift)"
		ifTrue:[xdh _ xDeltah // 2. ydh _ yDeltah // 2. 
				xdv _ xDeltav // 2. ydv _ yDeltav // 2]
		ifFalse:[xdh _ xDeltah // n. ydh _ yDeltah // n. 
				xdv _ xDeltav // n. ydv _ yDeltav // n].
	i _ nPixels.
	[
		x _ sx. y _ sy.
		a _ r _ g _ b _ 0.
		"Pick and average n*n subpixels"
		nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
		j _ n.
		[
			xx _ x. yy _ y.
			k _ n.
			[
				"get a single subpixel"
				rgb _ self pickWarpPixelAtX: xx y: yy.
				(combinationRule=25 "PAINT" and: [rgb = 0]) ifFalse:[
					"If not clipped and not transparent, then tally rgb values"
					nPix _ nPix + 1.
					sourcePixSize < 16 ifTrue:[
						"Get RGBA values from sourcemap table"
						rgb _ interpreterProxy longAt: sourceMap + (rgb << 2).
					] ifFalse:["Already in RGB format"
						sourcePixSize = 16 
								ifTrue:[rgb _ self rgbMap16To32: rgb]
								ifFalse:[rgb _ self rgbMap32To32: rgb]].
					b _ b + (rgb bitAnd: 255).
					g _ g + (rgb >> 8 bitAnd: 255).
					r _ r + (rgb >> 16 bitAnd: 255).
					a _ a + (rgb >> 24)].
				xx _ xx + xdh.
				yy _ yy + ydh.
			(k _ k - 1) = 0] whileFalse.
			x _ x + xdv.
			y _ y + ydv.
		(j _ j - 1) = 0] whileFalse.

		(nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (n * n // 2)]]) ifTrue:[
			rgb _ 0  "All pixels were 0, or most were transparent"
		] ifFalse:[
			"normalize rgba sums"
			nPix = 4 "Try to avoid divides for most common n"
				ifTrue:[r _ r >> 2.	g _ g >> 2.	b _ b >> 2.	a _ a >> 2]
				ifFalse:[	r _ r // nPix.	g _ g // nPix.	b _ b // nPix.	a _ a // nPix].
			rgb _ (a << 24) + (r << 16) + (g << 8) + b.

			"map the pixel"
			colorMap == nil "means we have different src/dst format"
				ifTrue:[rgb _ self rgbMap32ToX: rgb]
				ifFalse:[rgb _ self rgbMap32: rgb to: cmBitsPerColor].
			rgb = 0 ifTrue: [
				"only generate zero if pixel is really transparent"
				(r + g + b + a) > 0 ifTrue: [rgb _ 1]].
			colorMap = nil
				ifFalse:[rgb _ self colormapAt: rgb].
		].
		"Mix it in (note: in theory we could avoid the bitAnd but its safer for now)"
		destWord _ destWord bitOr: (rgb bitAnd: dstMask) << dstBitShift.
		dstBitShift _ dstBitShift - destPixSize.
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
	(i _ i - 1) = 0] whileFalse.

	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	dstBitShift _ 32 - destPixSize. "Shift towards leftmost pixel"

	^destWord
! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/29/1999 00:08'!
warpPickSourcePixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	"Pick n pixels from the source form,
	map by colorMap and return aligned by dstBitShift.
	This version is only called from WarpBlt with smoothingCount = 1"
	| dstMask destWord nPix sourcePix destPix |
	self inline: true. "Yepp - this should go into warpLoop"
	dstMask _ maskTable at: destPixSize.
	destWord _ 0.
	nPix _ nPixels.
	[
		"Pick a single pixel"
		sourcePix _ self pickWarpPixelAtX: sx y: sy.
		destPix _ sourcePix.
		sourcePixSize > 8 ifTrue:["Color map RGB pix"
			cmDeltaBits = 0 ifFalse:[ "but only if necessary"
				destPix _ self rgbMap: sourcePix.
				(destPix = 0 and:[sourcePix ~= 0]) ifTrue:[destPix _ 1]]].
		"map by colormap if necessary"
		colorMap == nil
			ifFalse:[destPix _ self colormapAt: destPix].
		"Mix it in (note: in theory we could avoid the bitAnd but its safer for now)"
		destWord _ destWord bitOr: (destPix bitAnd: dstMask) << dstBitShift.
		dstBitShift _ dstBitShift - destPixSize.
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
	(nPix _ nPix - 1) = 0] whileFalse.

	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	dstBitShift _ 32 - destPixSize. "Shift towards leftmost pixel"

	^destWord
! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/23/1999 20:45'!
warpSourcePixels: nPix xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	smoothing: n sourceMap: sourceMapOop
	"Pick nPix pixels using these x- and y-incs, and map color if necess."

	| destWord sourcePix sourcePixMask destPixMask srcPixPerWord destPix |
	self inline: false.
	sourcePixMask _ maskTable at: sourcePixSize.
	destPixMask _ maskTable at: destPixSize.
	srcPixPerWord _ 32 // sourcePixSize.
	destWord _ 0.
	1 to: nPix do:
		[:i |
		n > 1
		ifTrue:
			["Average n pixels and compute dest pixel from color map"
			destPix _ (self smoothPix: n atXf: sx yf: sy
				dxh: xDeltah//n dyh: yDeltah//n dxv: xDeltav//n dyv: yDeltav//n
				pixPerWord: srcPixPerWord pixelMask: sourcePixMask
				sourceMap: sourceMapOop)
					bitAnd: destPixMask]
		ifFalse:
			["No smoothing -- just pick pixel and map if difft depths or color map supplied"
			sourcePix _ (self sourcePixAtX: sx >> BinaryPoint
									y: sy >> BinaryPoint
									pixPerWord: srcPixPerWord)
						bitAnd: sourcePixMask.
			colorMap = nil
				ifTrue:
				[destPixSize = sourcePixSize
				ifTrue:
					[destPix _ sourcePix]
				ifFalse:
					[sourcePixSize >= 16 ifTrue:
						["Map between RGB pixels"
						sourcePixSize = 16
							ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]
							ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]
					ifFalse: [destPix _ sourcePix bitAnd: destPixMask]]]
			ifFalse:
				[sourcePixSize >= 16 ifTrue:
					["RGB pixels first get reduced to cmBitsPerColor"
					sourcePixSize = 16
						ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]
						ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor]].
				"Then look up sourcePix in colorMap"
				destPix _ (self colormapAt: sourcePix) bitAnd: destPixMask]].
		destPixSize = 32
			ifTrue:[destWord _ destPix]
			ifFalse:[destWord _ (destWord << destPixSize) bitOr: destPix].
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
		].
	^ destWord! !


!BitBltSimulation methodsFor: 'translation support' stamp: 'ar 10/12/1998 17:43'!
initBBOpTable
	self cCode: 'opTable[0+1] = (int)clearWordwith'.
	self cCode: 'opTable[1+1] = (int)bitAndwith'.
	self cCode: 'opTable[2+1] = (int)bitAndInvertwith'.
	self cCode: 'opTable[3+1] = (int)sourceWordwith'.
	self cCode: 'opTable[4+1] = (int)bitInvertAndwith'.
	self cCode: 'opTable[5+1] = (int)destinationWordwith'.
	self cCode: 'opTable[6+1] = (int)bitXorwith'.
	self cCode: 'opTable[7+1] = (int)bitOrwith'.
	self cCode: 'opTable[8+1] = (int)bitInvertAndInvertwith'.
	self cCode: 'opTable[9+1] = (int)bitInvertXorwith'.
	self cCode: 'opTable[10+1] = (int)bitInvertDestinationwith'.
	self cCode: 'opTable[11+1] = (int)bitOrInvertwith'.
	self cCode: 'opTable[12+1] = (int)bitInvertSourcewith'.
	self cCode: 'opTable[13+1] = (int)bitInvertOrwith'.
	self cCode: 'opTable[14+1] = (int)bitInvertOrInvertwith'.
	self cCode: 'opTable[15+1] = (int)destinationWordwith'.
	self cCode: 'opTable[16+1] = (int)destinationWordwith'.
	self cCode: 'opTable[17+1] = (int)destinationWordwith'.
	self cCode: 'opTable[18+1] = (int)addWordwith'.
	self cCode: 'opTable[19+1] = (int)subWordwith'.
	self cCode: 'opTable[20+1] = (int)rgbAddwith'.
	self cCode: 'opTable[21+1] = (int)rgbSubwith'.
	self cCode: 'opTable[22+1] = (int)OLDrgbDiffwith'.
	self cCode: 'opTable[23+1] = (int)OLDtallyIntoMapwith'.
	self cCode: 'opTable[24+1] = (int)alphaBlendwith'.
	self cCode: 'opTable[25+1] = (int)pixPaintwith'.
	self cCode: 'opTable[26+1] = (int)pixMaskwith'.
	self cCode: 'opTable[27+1] = (int)rgbMaxwith'.
	self cCode: 'opTable[28+1] = (int)rgbMinwith'.
	self cCode: 'opTable[29+1] = (int)rgbMinInvertwith'.
	self cCode: 'opTable[30+1] = (int)alphaBlendConstwith'.
	self cCode: 'opTable[31+1] = (int)alphaPaintConstwith'.
	self cCode: 'opTable[32+1] = (int)rgbDiffwith'.
	self cCode: 'opTable[33+1] = (int)tallyIntoMapwith'.
	self cCode: 'opTable[34+1] = (int)alphaBlendScaledwith'.! !


!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:22'!
colormapAt: idx
	"Return the word at position idx from the colorMap"
	^interpreterProxy longAt: colorMap + (idx << 2)! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:22'!
colormapAt: idx put: value
	"Store the word at position idx in the colorMap"
	^interpreterProxy longAt: colorMap + (idx << 2) put: value! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:23'!
dstLongAt: idx
	^interpreterProxy longAt: idx! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/26/1999 18:08'!
dstLongAt: idx put: value
	^interpreterProxy longAt: idx put: value! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 12/7/1999 21:09'!
dstLongAt: idx put: srcValue mask: dstMask
	"Store the given value back into destination form, using dstMask
	to mask out the bits to be modified. This is an essiantial
	read-modify-write operation on the destination form."
	| dstValue |
	self inline: true.
	dstValue _ self dstLongAt: idx.
	dstValue _ dstValue bitAnd: dstMask.
	dstValue _ dstValue bitOr: srcValue.
	self dstLongAt: idx put: dstValue.! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:22'!
halftoneAt: idx
	"Return a value from the halftone pattern."
	^interpreterProxy longAt: halftoneBase + (idx \\ halftoneHeight * 4)! !

!BitBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:23'!
srcLongAt: idx
	^interpreterProxy longAt: idx! !


!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 12/7/1999 21:08'!
rgbMap16: sourcePixel downTo: nBitsOut
	"Convert the given 16bit pixel value to a color map index 
	using nBitsOut bits for each color component. 
	Note: This method is intended to deal with different source formats."
	| delta |
	self inline: true.
	delta _ 5 - nBitsOut.
	"note: evaluated strictly left to right"
	^((sourcePixel >> 10 bitAnd: 31) >> delta) << nBitsOut +
		((sourcePixel >> 5 bitAnd: 31) >> delta) << nBitsOut +
			((sourcePixel bitAnd: 31) >> delta)! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 12/7/1999 21:08'!
rgbMap16: sourcePixel to: nBitsOut
	"Convert the given 16bit pixel value to a color map index 
	using nBitsOut bits for each color component. 
	Note: This method is intended to deal with different source formats."
	self inline: true.
	nBitsOut > 5
		ifTrue:[^self rgbMap16: sourcePixel upTo: nBitsOut]
		ifFalse:[^self rgbMap16: sourcePixel downTo: nBitsOut]! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 12/7/1999 21:07'!
rgbMap16: sourcePixel upTo: nBitsOut
	"Convert the given 16bit pixel value to a color map index 
	using nBitsOut bits for each color component. 
	Note: This method is intended to deal with different source formats."
	| delta |
	self inline: true.
	delta _ nBitsOut - 5.
	"note: evaluated strictly left to right"
	^((sourcePixel >> 10 bitAnd: 31) << (5 + delta)) +
		(sourcePixel >> 5 bitAnd: 31) << (5 + delta) +
			(sourcePixel bitAnd: 31) << (delta)! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/28/1999 16:02'!
rgbMap16To32: sourcePixel
	"Convert the given 16bit pixel value to a 32bit RGBA value.
 	Note: This method is intended to deal with different source formats."
	^(((sourcePixel bitAnd: 31) << 3) bitOr:
		((sourcePixel bitAnd: 16r3E0) << 6)) bitOr:
			((sourcePixel bitAnd: 16r7C00) << 9)! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/28/1999 16:03'!
rgbMap16ToX: sourcePixel
	"Convert the given 16 pixel value to a color value in destination format.
	Note: This method is intended to deal with different destination formats."
	destPixSize = 32
		ifTrue:[^self rgbMap16To32: sourcePixel]
		ifFalse:[^sourcePixel]
	"The above assumes that the caller is pickSourcePixels: using the standard
	16bit to 32bit conversion"! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 12/7/1999 21:07'!
rgbMap32: sourcePixel to: nBitsOut
	"Convert the given 32bit pixel value to a color map index 
	using nBitsOut bits for each color component. 
	Note: This method is intended to deal with different source formats."
	| delta |
	self inline: true.
	delta _ 8 - nBitsOut.
	"note: evaluated strictly left to right"
	^((sourcePixel >> 16 bitAnd: 255) >> delta) << nBitsOut +
		((sourcePixel >> 8 bitAnd: 255) >> delta) << nBitsOut +
			((sourcePixel bitAnd: 255) >> delta)! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/27/1999 14:28'!
rgbMap32To32: sourcePixel
	"Convert the given 32bit pixel value to a 32bit RGBA value.
 	Note: This method is intended to deal with different source formats."
	^sourcePixel "For now do it simple"! !

!BitBltSimulation methodsFor: 'color mapping' stamp: 'ar 10/27/1999 17:31'!
rgbMap32ToX: sourcePixel
	"Convert the given 32bit pixel value to a color value in destination format.
	Note: This method is intended to deal with different destination formats."
	destPixSize = 16
		ifTrue:[^self rgbMap32: sourcePixel to: 5]
		ifFalse:[^sourcePixel]
	"The above assumes that the caller is pickSourcePixels: using the standard
	32bit to 16bit conversion"! !


!BitBltSimulation methodsFor: 'surface support' stamp: 'ar 10/25/1999 22:21'!
lockSurfaces
	"Get a pointer to the bits of any OS surfaces."

	"Note: The VM support code must robustly handle multiple attempts to lock
	the same surface and return the same values since one might blt just a portion
	of the surface from one location to another (see below; ioLockSurfaceBits()
	is called twice if sourceForm == destForm)."

	"Note: It is possible to query for the actual regions (e.g., after clipping)
	that might be affected by the BB operation during ioLockSurfaceBits since
	clipping is always performed before ioLockSurfaceBits is called. This
	might an improvement on some platforms (e.g., Unix w/ X-Windows) where
	getting actual bits requires a round-trip to the server. Right now we don't
	have accessors for these values (basically sx, sy, dx, dy, bbW, and bbH)
	but it would be trivial to add them -- iff somebody is interested..."
	"ar 10/20/1999: Just noted that the above is not true for scanCharacters..."

	"ar 10/19/1999: This *should* be inlined but how do we pass a pointer to the pitch
	of the surfaces in this case?!!"

	| surfaceHandle |
	self inline: true. "If the CCodeGen learns how to inline #cCode: methods"
	hasSurfaceLock _ false.
	destBits == 0 ifTrue:["Blitting *to* OS surface"
		surfaceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: destForm.
		"destBits _ self cCode: 'ioLockSurfaceBits(surfaceHandle, &destPitch)'."
		hasSurfaceLock _ true.
	].
	(sourceBits == 0 and:[noSource not]) ifTrue:["Blitting *from* OS surface"
		surfaceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
		"sourceBits _ self cCode:'ioLockSurfaceBits(surfaceHandle, &sourcePitch)'."
		hasSurfaceLock _ true.
	].
	^destBits ~~ 0 and:[sourceBits ~~ 0 or:[noSource]].! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ar 12/7/1999 21:05'!
queryDestSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	"^(self cCode:'ioGetSurfaceFormat(handle, &destWidth, &destHeight, &destPixSize, &dstFormat)')
		~~ 0"
	^false! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ar 12/7/1999 21:05'!
querySourceSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	"^(self cCode:'ioGetSurfaceFormat(handle, &srcWidth, &srcHeight, &sourcePixSize, &srcFormat)')
		~~ 0"
	^false! !

!BitBltSimulation methodsFor: 'surface support' stamp: 'ar 10/25/1999 22:22'!
unlockSurfaces
	"Unlock the bits of any OS surfaces."

	"Note: It is possible to query for the dirty rectangle from ioUnlockSurfaceBits()
	since the affected regions are set before this method is called. This is currently
	not part of the InterpreterProxy interface but one can query for affectedLeft(),
	affectedRight(), affectedTop(), and affectedBottom() if the surface support
	is compiled with the VM."

	| surfaceHandle |
	hasSurfaceLock ifTrue:[
		surfaceHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
		(interpreterProxy isIntegerObject: surfaceHandle) ifTrue:[
			surfaceHandle _ interpreterProxy integerValueOf: surfaceHandle.
			"self ioUnlockSurfaceBits: surfaceHandle."
			sourceBits _ sourcePitch _ 0.
		].
		surfaceHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
		(interpreterProxy isIntegerObject: surfaceHandle) ifTrue:[
			surfaceHandle _ interpreterProxy integerValueOf: surfaceHandle.
			"self ioUnlockSurfaceBits: surfaceHandle."
			destBits _ destPitch _ 0.
		].
		hasSurfaceLock _ false.
	].! !


!BitBltSimulation methodsFor: 'initialize-release' stamp: 'ar 5/11/2000 20:39'!
initialiseModule
	self export: true.
	self initBBOpTable.
	^true! !


!BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/19/2000 20:40'!
primitiveCopyBits
	"Invoke the copyBits primitive. If the destination is the display, then copy it to the screen."
	| rcvr |
	self export: true.
	rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	(self loadBitBltFrom: rcvr) 
		ifFalse:[^interpreterProxy primitiveFail].
	self copyBits.
	self showDisplayBits.! !

!BitBltSimulation methodsFor: 'primitives' stamp: 'ar 5/23/2000 23:54'!
primitiveDisplayString
	| kernDelta xTable glyphMap stopIndex startIndex sourceString bbObj maxGlyph ascii glyphIndex sourcePtr left |
	self export: true.
	self var: #sourcePtr type: 'unsigned char *'.
	interpreterProxy methodArgumentCount = 6 
		ifFalse:[^interpreterProxy primitiveFail].
	kernDelta _ interpreterProxy stackIntegerValue: 0.
	xTable _ interpreterProxy stackObjectValue: 1.
	glyphMap _ interpreterProxy stackObjectValue: 2.
	((interpreterProxy fetchClassOf: xTable) = interpreterProxy classArray and:[
		(interpreterProxy fetchClassOf: glyphMap) = interpreterProxy classArray])
			ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: glyphMap) = 256 ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifTrue:[^nil].
	maxGlyph _ (interpreterProxy slotSizeOf: xTable) - 2.

	stopIndex _ interpreterProxy stackIntegerValue: 3.
	startIndex _ interpreterProxy stackIntegerValue: 4.
	sourceString _ interpreterProxy stackObjectValue: 5.
	(interpreterProxy isBytes: sourceString) ifFalse:[^interpreterProxy primitiveFail].
	(startIndex > 0 and:[stopIndex > 0 and:[
		stopIndex <= (interpreterProxy byteSizeOf: sourceString)]])
			ifFalse:[^interpreterProxy primitiveFail].

	bbObj _ interpreterProxy stackObjectValue: 6.
	(self loadBitBltFrom: bbObj) ifFalse:[^interpreterProxy primitiveFail].
	left _ destX.
	sourcePtr _ interpreterProxy firstIndexableField: sourceString.
	startIndex to: stopIndex do:[:charIndex|
		ascii _ sourcePtr at: charIndex-1.
		glyphIndex _ interpreterProxy fetchInteger: ascii ofObject: glyphMap.
		(glyphIndex < 0 or:[glyphIndex > maxGlyph]) 
			ifTrue:[^interpreterProxy primitiveFail].
		sourceX _ interpreterProxy fetchInteger: glyphIndex ofObject: xTable.
		width _ (interpreterProxy fetchInteger: glyphIndex+1 ofObject: xTable) - sourceX.
		interpreterProxy failed ifTrue:[^nil].
		self clipRange.	"Must clip here"
		(bbW > 0 and:[bbH > 0]) ifTrue: [self copyBits].
		interpreterProxy failed ifTrue:[^nil].
		destX _ destX + width + kernDelta.
	].
	affectedL _ left.
	self showDisplayBits.
	interpreterProxy pop: 6. "pop args, return rcvr"! !

!BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/19/2000 20:42'!
primitiveDrawLoop
	"Invoke the line drawing primitive."
	| rcvr xDelta yDelta |
	self export: true.
	rcvr _ interpreterProxy stackValue: 2.
	xDelta _ interpreterProxy stackIntegerValue: 1.
	yDelta _ interpreterProxy stackIntegerValue: 0.
	(self loadBitBltFrom: rcvr) 
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifFalse:[
		self drawLoopX: xDelta Y: yDelta.
		self showDisplayBits].
	interpreterProxy failed ifFalse:[interpreterProxy pop: 2].! !

!BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/19/2000 20:44'!
primitiveScanCharacters
	"Invoke the scanCharacters primitive."
	| rcvr start stop string rightX stopArray displayFlag |
	self export: true.
	rcvr _ interpreterProxy stackValue: 6.
	start _ interpreterProxy stackIntegerValue: 5.
	stop _ interpreterProxy stackIntegerValue: 4.
	string _ interpreterProxy stackValue: 3.
	rightX _ interpreterProxy stackIntegerValue: 2.
	stopArray _ interpreterProxy stackValue: 1.
	displayFlag _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifTrue: [^ nil].
	(self loadScannerFrom: rcvr
			start: start stop: stop string: string rightX: rightX
			stopArray: stopArray displayFlag: displayFlag)
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed
		ifFalse: [self scanCharacters].
	interpreterProxy failed
		ifFalse: [
			displayFlag ifTrue: [self showDisplayBits].
			interpreterProxy pop: 7.
			interpreterProxy push: self stopReason].! !

!BitBltSimulation methodsFor: 'primitives' stamp: 'ar 2/19/2000 20:47'!
primitiveWarpBits
	"Invoke the warpBits primitive. If the destination is the display, then copy it to the screen."
	| rcvr |
	self export: true.
	rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	(self loadWarpBltFrom: rcvr) 
		ifFalse:[^interpreterProxy primitiveFail].
	self warpBits.
	self showDisplayBits.! !

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

BitBltSimulation class
	instanceVariableNames: ''!

!BitBltSimulation class methodsFor: 'initialization' stamp: 'di 6/29/1998 23:24'!
initialize
	"BitBltSimulation initialize"
  
	self initializeRuleTable.

	"Mask constants"
	AllOnes _ 16rFFFFFFFF.
	BinaryPoint _ 14.
	FixedPt1 _ 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"
 
	"Indices into stopConditions for scanning"
	EndOfRun _ 257.
	CrossedX _ 258.
 
	"Form fields"
	FormBitsIndex _ 0.
	FormWidthIndex _ 1.
	FormHeightIndex _ 2.
	FormDepthIndex _ 3.
 
	"BitBlt fields"
	BBDestFormIndex _ 0.
	BBSourceFormIndex _ 1.
	BBHalftoneFormIndex _ 2.
	BBRuleIndex _ 3.
	BBDestXIndex _ 4.
	BBDestYIndex _ 5.
	BBWidthIndex _ 6.
	BBHeightIndex _ 7.
	BBSourceXIndex _ 8.
	BBSourceYIndex _ 9.
	BBClipXIndex _ 10.
	BBClipYIndex _ 11.
	BBClipWidthIndex _ 12.
	BBClipHeightIndex _ 13.
	BBColorMapIndex _ 14.
	BBWarpBase _ 15.
	BBLastIndex _ 15.
	BBXTableIndex _ 16.! !

!BitBltSimulation class methodsFor: 'initialization' stamp: 'ar 10/12/1998 17:42'!
initializeRuleTable
	"BitBltSimulation initializeRuleTable"
	"**WARNING** You MUST change initBBOpTable if you change this"
	OpTable _ #(
		"0" clearWord:with:
		"1" bitAnd:with:
		"2" bitAndInvert:with:
		"3" sourceWord:with:
		"4" bitInvertAnd:with:
		"5" destinationWord:with:
		"6" bitXor:with:
		"7" bitOr:with:
		"8" bitInvertAndInvert:with:
		"9" bitInvertXor:with:
		"10" bitInvertDestination:with:
		"11" bitOrInvert:with:
		"12" bitInvertSource:with:
		"13" bitInvertOr:with:
		"14" bitInvertOrInvert:with:
		"15" destinationWord:with:
		"16" destinationWord:with: "unused - was old paint"
		"17" destinationWord:with: "unused - was old mask"
		"18" addWord:with:
		"19" subWord:with:
		"20" rgbAdd:with:
		"21" rgbSub:with:
		"22" OLDrgbDiff:with:
		"23" OLDtallyIntoMap:with:
		"24" alphaBlend:with:
		"25" pixPaint:with:
		"26" pixMask:with:
		"27" rgbMax:with:
		"28" rgbMin:with:
		"29" rgbMinInvert:with:
		"30" alphaBlendConst:with:
		"31" alphaPaintConst:with:
		"32" rgbDiff:with:
		"33" tallyIntoMap:with:
		"34" alphaBlendScaled:with:
	).
	OpTableSize _ OpTable size + 1.  "0-origin indexing"
! !

!BitBltSimulation class methodsFor: 'initialization'!
test2  "BitBltSimulation test2"
	| f |
	Display fillWhite: (0@0 extent: 300@140).
	1 to: 12 do:
		[:i | f _ (Form extent: i@5) fillBlack.
		0 to: 20 do:
			[:x | f displayOn: Display
					at: (x*13) @ (i*10)]]! !

!BitBltSimulation class methodsFor: 'initialization'!
timingTest: extent  "BitBltSimulation timingTest: 640@480"
	| f f2 map |
	f _ Form extent: extent depth: 8.
	f2 _ Form extent: extent depth: 8.
	map _ Bitmap new: 1 << f2 depth.
	^ Array with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f fillWithColor: Color white]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copy: f boundingBox from: 0@0 in: f2 rule: Form over]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copyBits: f boundingBox from: f2 at: 0@0 colorMap: map]])! !


!BitBltSimulation class methodsFor: 'translation' stamp: 'ar 5/12/2000 01:11'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: 'opTable'
		declareC: 'int opTable[' , OpTableSize printString , ']'.
	aCCodeGenerator var: 'maskTable'
		declareC:'int maskTable[33] = {
0, 1, 3, 0, 15, 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 65535,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1
}'.
	aCCodeGenerator var: 'ditherMatrix4x4'
		declareC:'const int ditherMatrix4x4[16] = {
0,	8,	2,	10,
12,	4,	14,	6,
3,	11,	1,	9,
15,	7,	13,	5
}'.
	aCCodeGenerator var: 'ditherThresholds16'
		declareC:'const int ditherThresholds16[8] = { 0, 2, 4, 6, 8, 12, 14, 16 }'.
	aCCodeGenerator var: 'ditherValues16'
		declareC:'const int ditherValues16[32] = {
0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30
}'.

	aCCodeGenerator var: 'warpBitShiftTable'
		declareC:'int warpBitShiftTable[32]'.! !

!BitBltSimulation class methodsFor: 'translation' stamp: 'ar 2/19/2000 20:55'!
moduleName
	^'BitBltPlugin'! !

!BitBltSimulation class methodsFor: 'translation' stamp: 'jm 5/12/1999 12:02'!
opTable

	^ OpTable
! !


!BitBltSimulation class methodsFor: 'system simulation' stamp: 'ar 10/27/1999 23:34'!
copyBitsFrom: aBitBlt
	"Simulate the copyBits primitive"
	| proxy bb |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	bb _ self simulatorClass new.
	bb setInterpreter: proxy.
	proxy success: (bb loadBitBltFrom: aBitBlt).
	bb copyBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm 
				Left: bb affectedLeft Top: bb affectedTop 
				Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !

!BitBltSimulation class methodsFor: 'system simulation' stamp: 'ar 10/27/1999 14:06'!
simulatorClass
	^BitBltSimulator! !

!BitBltSimulation class methodsFor: 'system simulation' stamp: 'ar 10/27/1999 23:35'!
warpBitsFrom: aBitBlt
	"Simulate the warpBits primitive"
	| proxy bb |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	bb _ self simulatorClass new.
	bb setInterpreter: proxy.
	proxy success: (bb loadWarpBltFrom: aBitBlt).
	bb warpBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm 
				Left: bb affectedLeft Top: bb affectedTop 
				Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !
BitBltSimulation subclass: #BitBltSimulator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!

!BitBltSimulator methodsFor: 'as yet unclassified' stamp: 'ar 10/28/1999 22:13'!
initBBOpTable
	opTable _ OpTable.
	maskTable _ Array new: 32.
	#(1 2 4 8 16 32) do:[:i| maskTable at: i put: (1 << i)-1].
	self initializeDitherTables.
	warpBitShiftTable _ CArrayAccessor on: (Array new: 32).! !

!BitBltSimulator methodsFor: 'as yet unclassified' stamp: 'ar 7/24/1999 23:20'!
initializeDitherTables
	ditherMatrix4x4 _ CArrayAccessor on:
		#(	0	8	2	10
			12	4	14	6
			3	11	1	9
			15	7	13	5).
	ditherThresholds16 _ CArrayAccessor on:#(0 2 4 6 8 10 12 14 16).
	ditherValues16 _ CArrayAccessor on: 
		#(0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
		15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30).! !

!BitBltSimulator methodsFor: 'as yet unclassified' stamp: 'di 12/30/97 11:07'!
mergeFn: arg1 with: arg2
	^ self perform: (opTable at: combinationRule+1) with: arg1 with: arg2! !


!BitBltSimulator methodsFor: 'debug support' stamp: 'ar 10/27/1999 14:22'!
dstLongAt: dstIndex
	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex longAt: 0].
	((dstIndex anyMask: 3) or:[dstIndex + 4 < destBits or:[
		dstIndex > (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: dstIndex! !

!BitBltSimulator methodsFor: 'debug support' stamp: 'ar 10/27/1999 14:23'!
dstLongAt: dstIndex put: value
	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex longAt: 0 put: value].
	((dstIndex anyMask: 3) or:[dstIndex < destBits or:[
		dstIndex >= (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: dstIndex put: value! !

!BitBltSimulator methodsFor: 'debug support' stamp: 'ar 10/27/1999 14:22'!
srcLongAt: srcIndex
	interpreterProxy isInterpreterProxy
		ifTrue:[^srcIndex longAt: 0].
	((srcIndex anyMask: 3) or:[srcIndex + 4 < sourceBits or:[
		srcIndex > (sourceBits + (sourcePitch * srcHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: srcIndex! !

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

BitBltSimulator class
	instanceVariableNames: ''!


!BitBltSimulator class methodsFor: 'instance creation' stamp: 'ar 5/11/2000 22:06'!
new
	^super new! !
MouseMenuController subclass: #BitEditor
	instanceVariableNames: 'scale squareForm color transparent '
	classVariableNames: 'YellowButtonMenu '
	poolDictionaries: ''
	category: 'ST80-Editors'!
!BitEditor commentStamp: '<historical>' prior: 0!
I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.!


!BitEditor methodsFor: 'initialize-release'!
release

	super release.
	squareForm release.
	squareForm _ nil! !


!BitEditor methodsFor: 'view access'!
view: aView

	super view: aView.
	scale _ aView transformation scale.	
	scale _ scale x rounded @ scale y rounded.
	squareForm _ Form extent: scale depth: aView model depth.
	squareForm fillBlack! !


!BitEditor methodsFor: 'basic control sequence'!
controlInitialize

	super controlInitialize.
	Cursor crossHair show! !

!BitEditor methodsFor: 'basic control sequence'!
controlTerminate

	Cursor normal show! !


!BitEditor methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:52'!
isControlActive
	^ super isControlActive and: [sensor keyboardPressed not]! !

!BitEditor methodsFor: 'control defaults'!
redButtonActivity
	| formPoint displayPoint |
	model depth = 1 ifTrue:
		["If this is just a black&white form, then set the color to be
		the opposite of what it was where the mouse was clicked"
		formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
		color _ 1-(view workingForm pixelValueAt: formPoint).
		squareForm fillColor: (color=1 ifTrue: [Color black] ifFalse: [Color white])].
	[sensor redButtonPressed]
	  whileTrue: 
		[formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
		displayPoint _ view displayTransform: formPoint.
		squareForm 
			displayOn: Display
			at: displayPoint 
			clippingBox: view insetDisplayBox 
			rule: Form over
			fillColor: nil.
		view changeValueAt: formPoint put: color]! !


!BitEditor methodsFor: 'menu messages'!
accept
	"The edited information should now be accepted by the view."

	view accept! !

!BitEditor methodsFor: 'menu messages'!
cancel
	"The edited informatin should be forgotten by the view."

	view cancel! !

!BitEditor methodsFor: 'menu messages' stamp: 'jm 3/27/98 14:52'!
fileOut

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [model writeOnFileNamed: fileName].
! !

!BitEditor methodsFor: 'menu messages'!
setColor: aColor
	"Set the color that the next edited dots of the model to be the argument, 
	aSymbol. aSymbol can be any color changing message understood by a 
	Form, such as white or black."

	color _ aColor pixelValueForDepth: model depth.
	squareForm fillColor: aColor.
! !

!BitEditor methodsFor: 'menu messages' stamp: 'sma 3/15/2000 21:10'!
setTransparentColor
	squareForm fillColor: Color gray.
	color _ Color transparent! !

!BitEditor methodsFor: 'menu messages'!
test
	view workingForm follow: [Sensor cursorPoint] while: [Sensor noButtonPressed].
	Sensor waitNoButton! !



!BitEditor methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:04'!
getPluggableYellowButtonMenu: shiftKeyState
	^ YellowButtonMenu! !

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

BitEditor class
	instanceVariableNames: ''!

!BitEditor class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 14:48'!
initialize
	"The Bit Editor is the only controller to override the use of the blue
	button with a different pop-up menu. Initialize this menu."

	YellowButtonMenu _ SelectionMenu
		labels:
'cancel
accept
file out
test'
		lines: #(2 3)
		selections: #(cancel accept fileOut test)

	"BitEditor initialize"! !


!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm 
	"Create and schedule a BitEditor on the form aForm at its top left corner. 
	Show the small and magnified view of aForm."

	| scaleFactor |
	scaleFactor _ 8 @ 8.
	^self openOnForm: aForm
		at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft
		scale: scaleFactor! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation 
	"Create and schedule a BitEditor on the form aForm at magnifiedLocation. 
	Show the small and magnified view of aForm."

	^self openOnForm: aForm
		at: magnifiedLocation
		scale: 8 @ 8! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation scale: scaleFactor 
	"Create and schedule a BitEditor on the form aForm. Show the small and 
	magnified view of aForm."

	| aScheduledView |
	aScheduledView _ self
				bitEdit: aForm
				at: magnifiedLocation
				scale: scaleFactor
				remoteView: nil.
	aScheduledView controller openDisplayAt:
		aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)! !

!BitEditor class methodsFor: 'instance creation' stamp: 'sma 3/11/2000 11:29'!
openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor
	"Create and schedule a BitEditor on the form aForm. Show the magnified
	view of aForm in a scheduled window."
	| smallFormView bitEditor savedForm r |
	smallFormView _ FormView new model: aForm.
	smallFormView align: smallFormView viewport topLeft with: formLocation.
	bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView.
	savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).
	bitEditor controller startUp.
	savedForm displayOn: Display at: r topLeft.
	bitEditor release.
	smallFormView release.

	"BitEditor magnifyOnScreen."! !


!BitEditor class methodsFor: 'examples'!
magnifyOnScreen
	"Bit editing of an area of the display screen. User designates a 
	rectangular area that is magnified by 8 to allow individual screens dots to
	be modified. red button is used to set a bit to black and yellow button is
	used to set a bit to white. Editor is not scheduled in a view. Original
	screen location is updated immediately. This is the same as FormEditor
	magnify."
	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8 @ 8.
	smallRect _ Rectangle fromUser.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.
	tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor.
	"show magnified form size until mouse is depressed"
	self
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor

	"BitEditor magnifyOnScreen."! !

!BitEditor class methodsFor: 'examples'!
magnifyWithSmall
"	Also try:
	BitEditor openOnForm:
		(Form extent: 32@32 depth: Display depth)
	BitEditor openOnForm:
		((MaskedForm extent: 32@32 depth: Display depth)
		withTransparentPixelValue: -1)
"
	"Open a BitEditor viewing an area on the screen which the user chooses"
	| area form |
	area _ Rectangle fromUser.
	area isNil ifTrue: [^ self].
	form _ Form fromDisplay: area.
	self openOnForm: form

	"BitEditor magnifyWithSmall."! !


!BitEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'!
bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView
	"Create a BitEditor on aForm. That is, aForm is a small image that will 
	change as a result of the BitEditor changing a second and magnified 
	view of me. magnifiedFormLocation is where the magnified form is to be 
	located on the screen. scaleFactor is the amount of magnification. This 
	method implements a scheduled view containing both a small and 
	magnified view of aForm. Upon accept, aForm is updated."

	| aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent |
	scaledFormView _ FormHolderView new model: aForm.
	scaledFormView scaleBy: scaleFactor.
	bitEditor _ self new.
	scaledFormView controller: bitEditor.
	bitEditor setColor: Color black.
	topView _ StandardSystemView new.
	remoteView == nil ifTrue: [topView label: 'Bit Editor'].
	topView borderWidth: 2.

	topView addSubView: scaledFormView.
	remoteView == nil
		ifTrue:  "If no remote view, then provide a local view of the form"
			[aFormView _ FormView new model: scaledFormView workingForm.
			aFormView controller: NoController new.
			aForm height < 50
				ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2]
				ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0].
			topView addSubView: aFormView below: scaledFormView]
		 ifFalse:  "Otherwise, the remote one should view the same form"
			[remoteView model: scaledFormView workingForm].
	lowerRightExtent _ remoteView == nil
			ifTrue:
				[(scaledFormView viewport width - aFormView viewport width) @
					(aFormView viewport height max: 50)]
			ifFalse:
				[scaledFormView viewport width @ 50].
	menuView _ self buildColorMenu: lowerRightExtent colorCount: 1.
	menuView model: bitEditor.
	menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0.
	topView
		addSubView: menuView
		align: menuView viewport topRight
		with: scaledFormView viewport bottomRight.
	extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y)
			+ (4 @ 4).  "+4 for borders"
	topView minimumSize: extent.
	topView maximumSize: extent.
	topView translateBy: magnifiedFormLocation.
	topView insideColor: Color white.
	^topView! !

!BitEditor class methodsFor: 'private' stamp: 'jm 4/7/98 20:43'!
buildColorMenu: extent colorCount: nColors
	"See BitEditor magnifyWithSmall."

	| menuView form aSwitchView
	 button formExtent highlightForm color leftOffset |
	menuView _ FormMenuView new.
	menuView window: (0@0 corner: extent).
	formExtent _ 30@30 min: extent//(nColors*2+1@2).  "compute this better"
	leftOffset _ extent x-(nColors*2-1*formExtent x)//2.
	highlightForm _ Form extent: formExtent.
	highlightForm borderWidth: 4.
	1 to: nColors do: [:index | 
		color _ (nColors = 1
			ifTrue: [#(black)]
			ifFalse: [#(black gray)]) at: index.
		form _ Form extent: formExtent.
		form fill: form boundingBox fillColor: (Color perform: color).
		form borderWidth: 5.
		form border: form boundingBox width: 4 fillColor: Color white.
		button _ Button new.
		index = 1
			ifTrue: [button onAction: [menuView model setColor: Color fromUser]]
			ifFalse: [button onAction: [menuView model setTransparentColor]].

		aSwitchView _ PluggableButtonView
			on: button
			getState: #isOn
			action: #turnOn.
		aSwitchView
			shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index);
			label: form;
			window: (0@0 extent: form extent);
			translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2);
			borderWidth: 1.
		menuView addSubView: aSwitchView].
	^ menuView
! !

!BitEditor class methodsFor: 'private'!
locateMagnifiedView: aForm scale: scaleFactor
	"Answer a rectangle at the location where the scaled view of the form,
	aForm, should be displayed."

	^ Rectangle originFromUser: (aForm extent * scaleFactor + (0@50)).
	! !
ArrayedCollection variableWordSubclass: #Bitmap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Bitmap commentStamp: '<historical>' prior: 0!
My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.!


!Bitmap methodsFor: 'initialize-release' stamp: 'ar 12/23/1999 14:35'!
fromByteStream: aStream 
	"Initialize the array of bits by reading integers from the argument, 
	aStream."
	aStream nextWordsInto: self! !


!Bitmap methodsFor: 'filing' stamp: 'ar 2/3/2001 16:11'!
compress: bm toByteArray: ba
	"Store a run-coded compression of the receiver into the byteArray ba,
	and return the last index stored into. ba is assumed to be large enough.
	The encoding is as follows...
		S {N D}*.
		S is the size of the original bitmap, followed by run-coded pairs.
		N is a run-length * 4 + data code.
		D, the data, depends on the data code...
			0	skip N words, D is absent
			1	N words with all 4 bytes = D (1 byte)
			2	N words all = D (4 bytes)
			3	N words follow in D (4N bytes)
		S and N are encoded as follows...
			0-223	0-223
			224-254	(0-30)*256 + next byte (0-7935)
			255		next 4 bytes"		
	| size k word j lowByte eqBytes i |
	<primitive: 'primitiveCompressToByteArray' module: 'MiscPrimitivePlugin'>
	self var: #bm declareC: 'int *bm'.
	self var: #ba declareC: 'unsigned char *ba'.
	size _ bm size.
	i _ self encodeInt: size in: ba at: 1.
	k _ 1.
	[k <= size] whileTrue:
		[word _ bm at: k.
		lowByte _ word bitAnd: 16rFF.
		eqBytes _ ((word >> 8) bitAnd: 16rFF) = lowByte
				and: [((word >> 16) bitAnd: 16rFF) = lowByte
				and: [((word >> 24) bitAnd: 16rFF) = lowByte]].
		j _ k.
		[j < size and: [word = (bm at: j+1)]]  "scan for = words..."
			whileTrue: [j _ j+1].
		j > k ifTrue:
			["We have two or more = words, ending at j"
			eqBytes
				ifTrue: ["Actually words of = bytes"
						i _ self encodeInt: j-k+1*4+1 in: ba at: i.
						ba at: i put: lowByte.  i _ i+1]
				ifFalse: [i _ self encodeInt: j-k+1*4+2 in: ba at: i.
						i _ self encodeBytesOf: word in: ba at: i].
			k _ j+1]
			ifFalse:
			["Check for word of 4 = bytes"
			eqBytes ifTrue:
				["Note 1 word of 4 = bytes"
				i _ self encodeInt: 1*4+1 in: ba at: i.
				ba at: i put: lowByte.  i _ i+1.
				k _ k + 1]
				ifFalse:
				["Finally, check for junk"
				[j < size and: [(bm at: j) ~= (bm at: j+1)]]  "scan for ~= words..."
					whileTrue: [j _ j+1].
				j = size ifTrue: [j _ j + 1].
				"We have one or more unmatching words, ending at j-1"
				i _ self encodeInt: j-k*4+3 in: ba at: i.
				k to: j-1 do:
					[:m | i _ self encodeBytesOf: (bm at: m) in: ba at: i].
				k _ j]]].
	^ i - 1  "number of bytes actually stored"
"
Space check:
 | n rawBytes myBytes b |
n _ rawBytes _ myBytes _ 0.
Form allInstancesDo:
	[:f | f unhibernate.
	b _ f bits.
	n _ n + 1.
	rawBytes _ rawBytes + (b size*4).
	myBytes _ myBytes + (b compressToByteArray size).
	f hibernate].
Array with: n with: rawBytes with: myBytes
ColorForms: (116 230324 160318 )
Forms: (113 1887808 1325055 )

Integerity check:
Form allInstances do:
	[:f | f unhibernate.
	f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray)
		ifFalse: [self halt].
	f hibernate]

Speed test:
MessageTally spyOn: [Form allInstances do:
	[:f | Bitmap decompressFromByteArray: f bits compressToByteArray]]
"! !

!Bitmap methodsFor: 'filing' stamp: 'RAA 7/28/2000 08:40'!
compressGZip
	| ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining bufferStream gZipStream |

"just hacking around to see if further compression would help Nebraska"

	bufferStream _ RWBinaryOrTextStream on: (ByteArray new: 5000).
	gZipStream _ GZipWriteStream on: bufferStream.

	ba _ nil.
	rowsAtATime _ 20000.		"or 80000 bytes"
	hackwa _ Form new hackBits: self.
	sourceOrigin _ 0@0.
	[(rowsRemaining _ hackwa height - sourceOrigin y) > 0] whileTrue: [
		rowsAtATime _ rowsAtATime min: rowsRemaining.
		(ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [
			ba _ ByteArray new: rowsAtATime * 4.
			hackba _ Form new hackBits: ba.
			blt _ (BitBlt toForm: hackba) sourceForm: hackwa.
		].
		blt 
			combinationRule: Form over;
			sourceOrigin: sourceOrigin;
			destX: 0 destY: 0 width: 4 height: rowsAtATime;
			copyBits.
		"bufferStream nextPutAll: ba."
		sourceOrigin _ sourceOrigin x @ (sourceOrigin y + rowsAtATime).
	].
	gZipStream close.
	^bufferStream contents
! !

!Bitmap methodsFor: 'filing' stamp: 'di 8/5/1998 11:31'!
compressToByteArray
	"Return a run-coded compression of this bitmap into a byteArray"		
	| byteArray lastByte |
	"Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original.  The run-code cases are...
	N >= 1 words of equal bytes:  4N bytes -> 2 bytes (at worst 4 -> 2)
	N > 1 equal words:  4N bytes -> 5 bytes (at worst 8 -> 5)
	N > 1 unequal words:  4N bytes -> 4N + M, where M is the number of bytes required to encode the run length.

The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes.  Thus we require a run-length at the beginning, and after every interspersed word of equal bytes.  However, each of these saves 2 bytes, so it must be followed by a run of 1984 (7936//4) or more (for which M jumps from 2 to 5) to add any extra overhead.  Therefore the worst case is a series of runs of 1984 or more, with single interspersed words of equal bytes.  At each break we save 2 bytes, but add 5.  Thus the overhead would be no more than 5 (encoded size) + 2 (first run len) + (S//1984*3)."
	
"NOTE: This code is copied in Form hibernate for reasons given there."
	byteArray _ ByteArray new: (self size*4) + 7 + (self size//1984*3).
	lastByte _ self compress: self toByteArray: byteArray.
	^ byteArray copyFrom: 1 to: lastByte! !

!Bitmap methodsFor: 'filing' stamp: 'ar 2/3/2001 16:11'!
decompress: bm fromByteArray: ba at: index
	"Decompress the body of a byteArray encoded by compressToByteArray (qv)...
	The format is simply a sequence of run-coded pairs, {N D}*.
		N is a run-length * 4 + data code.
		D, the data, depends on the data code...
			0	skip N words, D is absent
				(could be used to skip from one raster line to the next)
			1	N words with all 4 bytes = D (1 byte)
			2	N words all = D (4 bytes)
			3	N words follow in D (4N bytes)
		S and N are encoded as follows (see decodeIntFrom:)...
			0-223	0-223
			224-254	(0-30)*256 + next byte (0-7935)
			255		next 4 bytes"	
	"NOTE:  If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm."
	| i code n anInt data end k pastEnd |
	<primitive: 'primitiveDecompressFromByteArray' module: 'MiscPrimitivePlugin'>
	self var: #bm declareC: 'int *bm'.
	self var: #ba declareC: 'unsigned char *ba'.
	i _ index.  "byteArray read index"
	end _ ba size.
	k _ 1.  "bitmap write index"
	pastEnd _ bm size + 1.
	[i <= end] whileTrue:
		["Decode next run start N"
		anInt _ ba at: i.  i _ i+1.
		anInt <= 223 ifFalse:
			[anInt <= 254
				ifTrue: [anInt _ (anInt-224)*256 + (ba at: i).  i _ i+1]
				ifFalse: [anInt _ 0.
						1 to: 4 do: [:j | anInt _ (anInt bitShift: 8) + (ba at: i).  i _ i+1]]].
		n _ anInt >> 2.
		(k + n) > pastEnd ifTrue: [^ self primitiveFail].
		code _ anInt bitAnd: 3.
		code = 0 ifTrue: ["skip"].
		code = 1 ifTrue: ["n consecutive words of 4 bytes = the following byte"
						data _ ba at: i.  i _ i+1.
						data _ data bitOr: (data bitShift: 8).
						data _ data bitOr: (data bitShift: 16).
						1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
		code = 2 ifTrue: ["n consecutive words = 4 following bytes"
						data _ 0.
						1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
						1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
		code = 3 ifTrue: ["n consecutive words from the data..."
						1 to: n do:
							[:m | data _ 0.
							1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
							bm at: k put: data.  k _ k+1]]]! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'!
encodeBytesOf: anInt in: ba at: i
	"Copy the integer anInt into byteArray ba at index i, and return the next index"

	self inline: true.
	self var: #ba declareC: 'unsigned char *ba'.
	0 to: 3 do:
		[:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)].
	^ i+4! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/12/98 17:32'!
encodeInt: int
	"Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray"
	| byteArray next |
	byteArray _ ByteArray new: 5.
	next _ self encodeInt: int in: byteArray at: 1.
	^ byteArray copyFrom: 1 to: next - 1
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'!
encodeInt: anInt in: ba at: i
	"Encode the integer anInt in byteArray ba at index i, and return the next index.
	The encoding is as follows...
		0-223	0-223
		224-254	(0-30)*256 + next byte (0-7935)
		255		next 4 bytes"		

	self inline: true.
	self var: #ba declareC: 'unsigned char *ba'.
	anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1].
	anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256.  ^ i+2].
	ba at: i put: 255.
	^ self encodeBytesOf: anInt in: ba at: i+1! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/11/98 21:34'!
readCompressedFrom: strm
	"Decompress an old-style run-coded stream into this bitmap:
		[0 means end of runs]
		[n = 1..127] [(n+3) copies of next byte]
		[n = 128..191] [(n-127) next bytes as is]
		[n = 192..255] [(n-190) copies of next 4 bytes]"
	| n byte out outBuff bytes |
	out _ WriteStream on: (outBuff _ ByteArray new: self size*4).
	[(n _ strm next) > 0] whileTrue:
		[(n between: 1 and: 127) ifTrue:
			[byte _ strm next.
			1 to: n+3 do: [:i | out nextPut: byte]].
		(n between: 128 and: 191) ifTrue:
			[1 to: n-127 do: [:i | out nextPut: strm next]].
		(n between: 192 and: 255) ifTrue:
			[bytes _ (1 to: 4) collect: [:i | strm next].
			1 to: n-190 do: [:i | bytes do: [:b | out nextPut: b]]]].
	out position = outBuff size ifFalse: [self error: 'Decompression size error'].
	"Copy the final byteArray into self"
	self copyFromByteArray: outBuff.! !

!Bitmap methodsFor: 'filing' stamp: 'tk 1/24/2000 22:37'!
restoreEndianness
	"This word object was just read in from a stream.  Bitmaps are always compressed and serialized in a machine-independent way.  Do not correct the Endianness."

	"^ self"
! !

!Bitmap methodsFor: 'filing'!
storeBits:startBit to:stopBit on:aStream
	self do: [:word | 
		startBit to:stopBit by:-4 do:[:shift |		
				aStream print:((word >>shift) bitAnd:15) asHexDigit.
		]
	].! !

!Bitmap methodsFor: 'filing' stamp: 'di 10/2/97 00:02'!
swapBytesFrom: start to: stop
	"Perform a bigEndian/littleEndian byte reversal of my words"
	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
	blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
	blt sourceX: 3; destX: 0; copyBits.
	blt sourceX: 0; destX: 3; copyBits.
	blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
	blt sourceX: 2; destX: 1; copyBits.
	blt sourceX: 1; destX: 2; copyBits.
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/18/98 14:19'!
writeOn: aStream 
	"Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)."

	| b |
	aStream nextPut: 16r80.
	b _ self compressToByteArray.
	aStream
		nextPutAll: (self encodeInt: b size);
		nextPutAll: b.
! !

!Bitmap methodsFor: 'filing' stamp: 'tk 2/19/1999 07:36'!
writeUncompressedOn: aStream 
	"Store the array of bits onto the argument, aStream.
	(leading byte ~= 16r80) identifies this as raw bits (uncompressed)."

	aStream nextInt32Put: self size.
	aStream nextPutAll: self
! !


!Bitmap methodsFor: 'printing' stamp: 'sma 6/1/2000 09:42'!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' of length '; print: self size! !

!Bitmap methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:00'!
printOnStream: aStream

	aStream print: 'a Bitmap of length '; write:self size.
! !


!Bitmap methodsFor: 'accessing'!
bitPatternForDepth: depth
	"The raw call on BitBlt needs a Bitmap to represent this color.  I already am Bitmap like.  I am already adjusted for a specific depth.  Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress
	"Extract a byte from a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:.  See Form pixelAt:  7/1/96 tk"
	| lowBits |
	lowBits _ byteAddress - 1 bitAnd: 3.
	^((self at: byteAddress - 1 - lowBits // 4 + 1)
		bitShift: (lowBits - 3) * 8)
		bitAnd: 16rFF! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress put: byte
	"Insert a byte into a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:put:.  See Form pixelAt:put:  7/1/96 tk"

	| longWord shift lowBits longAddr |
	lowBits _ byteAddress - 1 bitAnd: 3.
	longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1).
	shift _ (3 - lowBits) * 8.
	longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) 
		+ (byte bitShift: shift).
	self at: longAddr put: longWord.
	^ byte! !

!Bitmap methodsFor: 'accessing' stamp: 'di 10/4/97 11:56'!
copyFromByteArray: byteArray
	"This method should work with either byte orderings"
	| long |
	(self size * 4) = byteArray size ifFalse: [self halt].
	1 to: byteArray size by: 4 do:
		[:i | long _ Integer
				byte1: (byteArray at: i+3)
				byte2: (byteArray at: i+2)
				byte3: (byteArray at: i+1)
				byte4: (byteArray at: i).
		self at: i+3//4 put: long]! !

!Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !

!Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'!
pixelValueForDepth: depth
	"Self is being used to represent a single color.  Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32.  Returns an integer.  First pixel only.  "

	^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! !

!Bitmap methodsFor: 'accessing'!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."

	<primitive: 145>
	self errorImproperStore.! !

!Bitmap methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !


!Bitmap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:42'!
isColormap
	"Bitmaps were used as color maps for BitBlt.
	This method allows to recognize real color maps."
	^false! !


!Bitmap methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 21:51'!
copy

	^self clone! !

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

Bitmap class
	instanceVariableNames: ''!

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/9/98 16:02'!
decodeIntFrom: s
	"Decode an integer in stream s as follows...
		0-223	0-223
		224-254	(0-30)*256 + next byte (0-7935)
		255		next 4 bytes	"		
	| int |
	int _ s next.
	int <= 223 ifTrue: [^ int].
	int <= 254 ifTrue: [^ (int-224)*256 + s next].
	int _ s next.
	1 to: 3 do: [:j | int _ (int bitShift: 8) + s next].
	^ int! !

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/12/98 14:34'!
decompressFromByteArray: byteArray
	| s bitmap size |
	s _ ReadStream on: byteArray.
	size _ self decodeIntFrom: s.
	bitmap _ self new: size.
	bitmap decompress: bitmap fromByteArray: byteArray at: s position+1.
	^ bitmap! !

!Bitmap class methodsFor: 'instance creation' stamp: 'ar 12/23/1999 14:35'!
newFromStream: s
	| len |
	s next = 16r80 ifTrue:
		["New compressed format"
		len _ self decodeIntFrom: s.
		^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len))].
	s skip: -1.
	len _ s nextInt32.
	len <= 0
		ifTrue: ["Old compressed format"
				^ (self new: len negated) readCompressedFrom: s]
		ifFalse: ["Old raw data format"
				^ s nextWordsInto: (self new: len)]! !
OrientedFillStyle subclass: #BitmapFillStyle
	instanceVariableNames: 'form tileFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!

!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'!
form
	^form! !

!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'!
form: aForm
	form _ aForm! !

!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:37'!
tileFlag
	^tileFlag! !

!BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:30'!
tileFlag: aBoolean
	tileFlag _ aBoolean! !


!BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/11/1998 22:40'!
isBitmapFill
	^true! !

!BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/27/1998 14:37'!
isTiled
	"Return true if the receiver should be repeated if the fill shape is larger than the form"
	^tileFlag == true! !

!BitmapFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:31'!
isTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !


!BitmapFillStyle methodsFor: 'converting' stamp: 'ar 11/11/1998 22:41'!
asColor
	^form colorAt: 0@0! !


!BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 12:05'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'choose new graphic' target: self selector: #chooseNewGraphicIn:event: argument: aMorph.
	aMenu add: 'grab new graphic' target: self selector: #grabNewGraphicIn:event: argument: aMorph.
	super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! !

!BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 11:55'!
chooseNewGraphicIn: aMorph event: evt
	"Used by any morph that can be represented by a graphic"
	| reasonableForms aGraphicalMenu myGraphic |
	reasonableForms _ (SketchMorph allSubInstances collect: [:m | m form]) asOrderedCollection.
	reasonableForms addAll: (Smalltalk imageImports collect: [:f | f]).
	reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]).
	reasonableForms _ reasonableForms asSet asOrderedCollection.
	(reasonableForms includes: (myGraphic _ self form))
		ifTrue:
			[reasonableForms remove: myGraphic].
	reasonableForms addFirst: myGraphic.

	aGraphicalMenu _ GraphicalMenu new initializeFor: self withForms: reasonableForms coexist: true.
	aGraphicalMenu selector: #newForm:forMorph:; argument: aMorph.
	evt hand attachMorph: aGraphicalMenu.! !

!BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 12:06'!
grabNewGraphicIn: aMorph event: evt
	"Used by any morph that can be represented by a graphic"
	self form: Form fromUser.
	self direction: self form width @ 0.
	self normal: 0 @ self form height.
	aMorph changed.! !

!BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 11:57'!
newForm: aForm forMorph: aMorph
	self form: aForm.
	self direction: (aForm width @ 0).
	self normal: (0 @ aForm height).
	aMorph changed.! !

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

BitmapFillStyle class
	instanceVariableNames: ''!

!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/13/1998 20:32'!
form: aForm
	^self new form: aForm! !

!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 6/25/1999 12:01'!
fromForm: aForm
	| fs |
	fs _ self form: aForm.
	fs direction: aForm width @ 0.
	fs normal: 0 @ aForm height.
	fs tileFlag: true.
	^fs! !

!BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 6/18/1999 07:09'!
fromUser
	| fill |
	fill _ self form: Form fromUser.
	fill origin: 0@0.
	fill direction: fill form width @ 0.
	fill normal: 0 @ fill form height.
	fill tileFlag: true. "So that we can fill arbitrary objects"
	^fill! !
PolygonMorph subclass: #BlobMorph
	instanceVariableNames: 'random velocity sneaky '
	classVariableNames: 'AllBlobs '
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!BlobMorph commentStamp: '<historical>' prior: 0!
The Blob was written by David N Smith.  It started out as a simple test of the CurveMorph and ended up as an oozing, pulsating, repulsive mess which will wander across your screen until killed.  Each instance has its own rate of oozing, so some are faster than others.  It's not good for anything.

Try:
	BlobMorph new openInWorld

15 Jan 2000 by Bob Arning, a change so that the blob tries to be a color like the color under itself.
16 Jan 2000 by David N Smith, added blob merging: if two blobs meet then one eats the other.
18 Jan 2000
 by Sean McGrath, smother color changes.
06 Feb 2000 by Stefan Matthias Aust, refactoring and support for duplication, dragging and translucent colors.!


!BlobMorph methodsFor: 'copying' stamp: 'sma 2/6/2000 18:07'!
veryDeepCopy
	^ self class remember: super veryDeepCopy! !


!BlobMorph methodsFor: 'geometry' stamp: 'sma 2/6/2000 18:39'!
setConstrainedPositionFrom: aPoint
	"Deal with dragging the blob over another blob
	which results in spontaneous deletations."

	self owner ifNil: [^ self].
	super setConstrainedPositionFrom: aPoint! !


!BlobMorph methodsFor: 'initialization' stamp: 'di 9/7/2000 17:21'!
initialize

	super initialize.
	self beSmoothCurve.

	random _ Random new.
	sneaky _ random next < 0.75.
	self initializeColor.
	self initializeBlobShape.
	self setVelocity! !

!BlobMorph methodsFor: 'initialization' stamp: 'sma 2/6/2000 18:22'!
initializeBlobShape

	self
		vertices: {59@40. 74@54. 79@74. 77@93. 57@97. 37@97. 22@83. 15@67. 22@50. 33@35. 47@33}
		color: self color
		borderWidth: 1
		borderColor: Color black! !

!BlobMorph methodsFor: 'initialization' stamp: 'dns 2/9/2000 16:37'!
initializeColor
	color _ random next < 0.25
		ifTrue: [Color random]
		ifFalse: [Color random alpha: random next * 0.4 + 0.4]! !

!BlobMorph methodsFor: 'initialization' stamp: 'sma 2/6/2000 18:28'!
maximumVelocity
	^ 6.0! !

!BlobMorph methodsFor: 'initialization' stamp: 'sma 2/6/2000 18:28'!
setVelocity

	velocity _
		((random next - 0.5) * self maximumVelocity) @ 
		((random next - 0.5) * self maximumVelocity)! !


!BlobMorph methodsFor: 'stepping' stamp: 'tk 7/4/2000 12:02'!
adjustColors
	"Bob Arning <arning@charm.net>"
	"Color mixing - Sean McGrath <sean@email.ces.ucsf.edu>"
	| nearbyColors center r degrees |
	center _ bounds center.
	nearbyColors _ vertices collect:
		[:each |
		degrees _ (each - center) degrees.
		r _ (each - center) r.
		Display colorAt: (Point r: r + 6 degrees: degrees) + center].
		self color: ((self color alphaMixed: 0.95 with: (Color
			r: (nearbyColors collect: [:each | each red]) average
			g: (nearbyColors collect: [:each | each green]) average
			b: (nearbyColors collect: [:each | each blue]) average))
				alpha: self color alpha).
        sneaky ifFalse: [self color: color negated]! !

!BlobMorph methodsFor: 'stepping' stamp: 'sma 3/24/2000 11:40'!
bounceOffWalls
	" Change sign of velocity when we hit a wall of the container "
	| ob sb |

	" If owned by a handmorph we're being dragged or something;
	  don't bounce since the boundaries are different than our real parent "
	owner isHandMorph ifTrue: [ ^ self ].

	" If we're entirely within the parents bounds, we don't bounce "
	ob := owner bounds.
	sb := self bounds.
	(ob containsRect: sb) ifTrue: [ ^ self ].

	" We're partly outside the parents bounds; better bounce or we disappear!! "
	sb top < ob top ifTrue: [ velocity := velocity x @ velocity y abs ].
	sb left < ob left ifTrue: [ velocity := velocity x abs @ velocity y ].
	sb bottom > ob bottom ifTrue: [ velocity := velocity x @ velocity y abs negated ].
	sb right > ob right ifTrue: [ velocity := velocity x abs negated @ velocity y ].
! !

!BlobMorph methodsFor: 'stepping' stamp: 'dns 1/16/2000 16:29'!
limitRange: verts
	" limit radius to range 20-120; limit interpoint angle to surrounding angles with max of twice of average separation. "
	| cent new prevn nextn prevDeg nextDeg thisDeg dincr |

	cent := self bounds center.
	new := Array new: verts size.
	dincr := 360 // verts size.
	verts doWithIndex: [ :pt :n |

		"Find prev/next points, allowing for wrapping around "
		prevn := n-1 < 1 ifTrue: [new size] ifFalse: [n-1].
		nextn := n+1 > new size ifTrue: [1] ifFalse: [n+1].

		"Get prev/this/next point's angles "
		prevDeg := ((verts at: prevn)-cent) degrees.
		thisDeg := ((verts at: n)-cent) degrees.
		nextDeg := ((verts at: nextn)-cent) degrees.

		"Adjust if this is where angles wrap from 0 to 360"
		(thisDeg - prevDeg) abs > 180 ifTrue: [ prevDeg := prevDeg - 360 ].
		(thisDeg - nextDeg) abs > 180 ifTrue: [ nextDeg := nextDeg + 360 ].

		"Put adjusted point into new collection"
		new at: n put: cent +
			(self selfPolarPointRadius: ((((pt - cent) r) min: 80) max: 20)
				degrees: (((thisDeg min: nextDeg-5) max: prevDeg+5) min: dincr*2+prevDeg)) ].
	^ new
! !

!BlobMorph methodsFor: 'stepping' stamp: 'sma 2/6/2000 18:36'!
mergeBlobs
	"See if we need to merge by checking our bounds against all other Blob
	bounds, then all our vertices against any Blob with overlapping bounds.
	If we find a need to merge, then someone else does all the work."

	AllBlobs size < 2 ifTrue: [^ self].
	AllBlobs
		do:
			[:aBlob |
			aBlob owner == self owner ifTrue:
				[(self bounds intersects: aBlob bounds) ifTrue:
					[vertices do:
						[:aPoint |
						(aBlob containsPoint: aPoint) ifTrue:
							[^ self mergeSelfWithBlob: aBlob atPoint: aPoint]]]]]
		without: self! !

!BlobMorph methodsFor: 'stepping' stamp: 'dns 1/17/2000 13:34'!
mergeSelfWithBlob: aBlob atPoint: aPoint
	" It has already been determined that we merge with aBlob; we do all the work here. "
	| v v2 c |

	c := self bounds center.

	" Merge the vertices by throwing them all together in one pot "
	v := vertices, aBlob vertices.

	" Sort the vertices by degrees to keep them in order "
	v := (v asSortedCollection: [ :a :b | (a-c) degrees < (b-c) degrees ]) asArray.

	" Now, pick half of the vertices so the count stays the same "
	v2 := Array new: v size // 2.
	1 to: v2 size do: [ :n |
		v2 at: n put: (v at: n+n) ].
	v := v2.

	" Average each contiguous pair to help minimize jaggies "
	2 to: v size do: [ :n |
		v at: n put: ((v at: n) + (v at: n-1)) / 2.0 ].

	" Remember the new vertices, set a new velocity, then delete the merged blob "
	vertices := v.
	self setVelocity.
	aBlob delete
! !

!BlobMorph methodsFor: 'stepping' stamp: 'dns 1/17/2000 13:36'!
oozeAFewPointsOf: verts
	" change some points at random to cause oozing across screen "
	| n v |

	(verts size sqrt max: 2) floor timesRepeat: [
		n := (verts size * random next) floor + 1.
		v := verts at: n.
		v := (v x + (random next * 2.0 - 1.0))  @ 
			(v y + (random next * 2.0 - 1.0)).
		verts at: n put: v + velocity ].

! !

!BlobMorph methodsFor: 'stepping' stamp: 'dns 1/14/2000 17:47'!
selfPolarPointRadius: rho degrees: theta
	" Same as Point>>#r:degrees: in Point class except that x and y are not truncated to integers "
	| radians x y |

	radians _ theta asFloat degreesToRadians.
	x _ rho asFloat * radians cos.
	y _ rho asFloat * radians sin.
	^ Point x: x y: y! !

!BlobMorph methodsFor: 'stepping' stamp: 'sma 2/12/2000 13:09'!
step
	| verts |
	self comeToFront.
	self mergeBlobs.
	verts := vertices copy.

	" change two points at random to cause oozing across screen "
	self oozeAFewPointsOf: verts.

	" limit radius and interpoint angle "
	verts := self limitRange: verts.

	" Set new vertices; bounce off a wall if necessary "
	self setVertices: verts.
	self bounceOffWalls.
	self adjustColors
! !

!BlobMorph methodsFor: 'stepping' stamp: 'sma 2/6/2000 18:41'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 125! !


!BlobMorph methodsFor: 'submorphs-add/remove' stamp: 'sma 2/6/2000 17:41'!
delete
	self class delete: self.
	super delete! !


!BlobMorph methodsFor: 'debug and other' stamp: 'sma 2/12/2000 13:08'!
installModelIn: aWorld
	"Overwritten to not add handles to the receiver."! !


!BlobMorph methodsFor: 'geometry testing' stamp: 'sma 2/12/2000 13:10'!
containsPoint: aPoint
	(self color alpha = 1.0 or: [Sensor blueButtonPressed])
		ifTrue: [^ super containsPoint: aPoint].
	^ false! !

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

BlobMorph class
	instanceVariableNames: ''!

!BlobMorph class methodsFor: 'instance creation' stamp: 'dns 1/16/2000 15:11'!
new

	^ self remember: super new
		! !


!BlobMorph class methodsFor: 'instance remembering' stamp: 'sma 2/6/2000 18:36'!
delete: anInstance
	AllBlobs ifNotNil: [AllBlobs remove: anInstance ifAbsent: []]! !

!BlobMorph class methodsFor: 'instance remembering' stamp: 'sma 2/6/2000 18:35'!
remember: anInstance
	AllBlobs isNil ifTrue: [AllBlobs := IdentitySet new].
	^ AllBlobs add: anInstance! !
ParseNode subclass: #BlockArgsNode
	instanceVariableNames: 'temporaries '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
Exception subclass: #BlockCannotReturn
	instanceVariableNames: 'result '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!BlockCannotReturn commentStamp: '<historical>' prior: 0!
This class is private to the EHS implementation.  Its use allows for ensured execution to survive code such as:

[self doThis.
^nil]
	ensure: [self doThat]

Signaling or handling this exception is not recommended.!


!BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'!
result

	^result! !

!BlockCannotReturn methodsFor: 'accessing' stamp: 'tfei 3/30/1999 12:54'!
result: r

	result := r! !


!BlockCannotReturn methodsFor: 'exceptionDescription' stamp: 'tfei 3/30/1999 12:55'!
defaultAction

	self messageText: 'Block cannot return'.
	^super defaultAction! !

!BlockCannotReturn methodsFor: 'exceptionDescription' stamp: 'tfei 4/2/1999 15:49'!
isResumable

	^true! !
ContextPart variableSubclass: #BlockContext
	instanceVariableNames: 'nargs startpc home '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!BlockContext commentStamp: '<historical>' prior: 0!
My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.
	
My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.

BlockContexts must only be created using the method newForMethod:.  Note that it is impossible to determine the real object size of a BlockContext except by asking for the frameSize of its method.  Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector.  Any store into stackp other than by the primitive method stackp: is potentially fatal.!


!BlockContext methodsFor: 'initialize-release' stamp: 'ls 6/21/2000 17:42'!
home: aContextPart startpc: position nargs: anInteger 
	"This is the initialization message. The receiver has been initialized with 
	the correct size only."

	home _ aContextPart.
	pc _ startpc _ position.
	nargs _ anInteger.
	stackp _ 0.! !


!BlockContext methodsFor: 'accessing' stamp: 'di 9/9/2000 10:44'!
copyForSaving
	"Fix the values of the temporary variables used in the block that are 
	ordinarily shared with the method in which the block is defined."

	home _ home copy.
	home swapSender: nil! !

!BlockContext methodsFor: 'accessing'!
fixTemps
	"Fix the values of the temporary variables used in the block that are 
	ordinarily shared with the method in which the block is defined."

	home _ home copy.
	home swapSender: nil! !

!BlockContext methodsFor: 'accessing' stamp: 'RAA 1/5/2001 08:50'!
hasInstVarRef
	"Answer whether the receiver references an instance variable."

	| method scanner end printer |

	home ifNil: [^false].
	method _ self method.
	"Determine end of block from long jump preceding it"
	end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
	scanner _ InstructionStream new method: method pc: startpc.
	printer _ InstVarRefLocator new.

	[scanner pc <= end] whileTrue: [
		(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !

!BlockContext methodsFor: 'accessing'!
hasMethodReturn
	"Answer whether the receiver has a return ('^') in its code."

	| method scanner end |
	method _ self method.
	"Determine end of block from long jump preceding it"
	end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
	scanner _ InstructionStream new method: method pc: startpc.
	scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]].
	^scanner pc <= end! !

!BlockContext methodsFor: 'accessing'!
home
	"Answer the context in which the receiver was defined."

	^home! !

!BlockContext methodsFor: 'accessing'!
method
	"Answer the compiled method in which the receiver was defined."

	^home method! !

!BlockContext methodsFor: 'accessing'!
numArgs

	^nargs! !

!BlockContext methodsFor: 'accessing'!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^home receiver! !

!BlockContext methodsFor: 'accessing'!
tempAt: index 
	"Refer to the comment in ContextPart|tempAt:."

	^home at: index! !

!BlockContext methodsFor: 'accessing'!
tempAt: index put: value 
	"Refer to the comment in ContextPart|tempAt:put:."

	^home at: index put: value! !


!BlockContext methodsFor: 'evaluating' stamp: 'bf 9/27/1999 16:50'!
ifError: errorHandlerBlock
	"Evaluate the block represented by the receiver. If an error occurs the given is evaluated with the error message and the receiver as parameters. The error handler block may return a value to be used if the receiver block gets an error. The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around."
	"Examples:
		[1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?'].
		[1 / 0] ifError: [:err :rcvr |
			'ZeroDivide' = err
				ifTrue: [^ Float infinity]
				ifFalse: [self error: err]]
"
	| lastHandler val activeProcess |
	activeProcess _ Processor activeProcess.
	lastHandler _ activeProcess errorHandler.
	activeProcess errorHandler: [:aString :aReceiver |
		activeProcess errorHandler: lastHandler.
		^ errorHandlerBlock value: aString value: aReceiver].
	val _ self on: Error do: [:ex |
		activeProcess errorHandler: lastHandler.
		^errorHandlerBlock value: ex description value: ex receiver].
	activeProcess errorHandler: lastHandler.
	^ val


! !

!BlockContext methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'!
timeToRun
	"Answer the number of milliseconds taken to execute this block."

	^ Time millisecondsToRun: self
! !

!BlockContext methodsFor: 'evaluating'!
value
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects any arguments or if the block is already being executed. 
	Optional. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: #()! !

!BlockContext methodsFor: 'evaluating'!
value: arg 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than one argument or if the block is already being 
	executed. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 ifError: aBlock
	"Evaluate the block represented by the receiver. If an error occurs aBlock is evaluated
	 with the error message and the receiver as parameters. The receiver should not contain
	 an explicit return statement as this would leave an obsolete error handler hanging around."

	| lastHandler val activeProcess |
	activeProcess _ Processor activeProcess.
	lastHandler _ activeProcess errorHandler.
	activeProcess errorHandler: [:aString :aReceiver |
		activeProcess errorHandler: lastHandler.
		^ aBlock value: aString value: aReceiver].
	val _ self value: arg1.
	activeProcess errorHandler: lastHandler.
	^ val! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than two arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg1 with: arg2)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 value: arg3 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3)! !

!BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'!
value: arg1 value: arg2 value: arg3 value: arg4 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3
			with: arg4)! !

!BlockContext methodsFor: 'evaluating' stamp: 'mdr 10/5/2000 10:33'!
valueWithArguments: anArray 
	"Primitive. Evaluate the block represented by the receiver. The argument 
	is an Array whose elements are the arguments for the block. Fail if the 
	length of the Array is not the same as the the number of arguments that 
	the block was expecting. Fail if the block is already being executed. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 82>
	self numArgs = anArray size
		ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
		ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments and is being evaluated with ', anArray size printString]! !


!BlockContext methodsFor: 'controlling' stamp: 'sma 5/12/2000 13:22'!
repeat
	"Evaluate the receiver repeatedly, ending only if the block explicitly returns."

	[self value. true] whileTrue! !

!BlockContext methodsFor: 'controlling' stamp: 'ls 9/24/1999 09:45'!
repeatWithGCIf: testBlock
	| ans |
	"run the receiver, and if testBlock returns true, garbage collect and run the receiver again"
	ans _ self value.
	(testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans _ self value ].
	^ans! !

!BlockContext methodsFor: 'controlling'!
whileFalse
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is false."
 
	^ [self value] whileFalse: []! !

!BlockContext methodsFor: 'controlling'!
whileFalse: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is false."

	^ [self value] whileFalse: [aBlock value]! !

!BlockContext methodsFor: 'controlling'!
whileTrue
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is true."
 
	^ [self value] whileTrue: []! !

!BlockContext methodsFor: 'controlling'!
whileTrue: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is true."

	^ [self value] whileTrue: [aBlock value]! !


!BlockContext methodsFor: 'scheduling' stamp: 'di 9/12/1998 11:53'!
fork
	"Create and schedule a Process running the code in the receiver."

	^ self newProcess resume! !

!BlockContext methodsFor: 'scheduling' stamp: 'jm 11/9/1998 10:16'!
forkAt: priority 
	"Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process."

	| forkedProcess |
	forkedProcess _ self newProcess.
	forkedProcess priority: priority.
	^ forkedProcess resume
! !

!BlockContext methodsFor: 'scheduling' stamp: 'ar 6/5/1998 21:44'!
newProcess
	"Answer a Process running the code in the receiver. The process is not 
	scheduled."
	<primitive: 19> "Simulation guard"
	^Process
		forContext: 
			[self value.
			Processor terminateActive]
		priority: Processor activePriority! !

!BlockContext methodsFor: 'scheduling' stamp: 'ar 6/5/1998 21:44'!
newProcessWith: anArray 
	"Answer a Process running the code in the receiver. The receiver's block 
	arguments are bound to the contents of the argument, anArray. The 
	process is not scheduled."
	<primitive: 19> "Simulation guard"
	^Process
		forContext: 
			[self valueWithArguments: anArray.
			Processor terminateActive]
		priority: Processor activePriority! !


!BlockContext methodsFor: 'instruction decoding'!
blockReturnTop
	"Simulate the interpreter's action when a ReturnTopOfStack bytecode is 
	encountered in the receiver."

	| save dest |
	save _ home.	"Needed because return code will nil it"
	dest _ self return: self pop to: self sender.
	home _ save.
	sender _ nil.
	^dest! !


!BlockContext methodsFor: 'printing'!
printOn: aStream

	home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream! !

!BlockContext methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:01'!
printOnStream: aStream

	home == nil ifTrue: [^aStream print: 'a BlockContext with home=nil'].
	aStream print: '[] in '.
	super printOnStream: aStream! !


!BlockContext methodsFor: 'private' stamp: 'tfei 3/31/1999 17:40'!
cannotReturn: result
	"The receiver tried to return result to a method context that no longer exists."

	| ex newResult |
	ex := BlockCannotReturn new.
	ex result: result.
	newResult := ex signal.
	^newResult! !

!BlockContext methodsFor: 'private' stamp: 'di 1/14/1999 22:28'!
instVarAt: index put: value
	index = 3 ifTrue: [self stackp: value. ^ value].
	^ super instVarAt: index put: value! !

!BlockContext methodsFor: 'private'!
startpc
	"for use by the System Tracer only"

	^startpc! !

!BlockContext methodsFor: 'private'!
valueError

	self error: 'Incompatible number of args, or already active'! !


!BlockContext methodsFor: 'system simulation' stamp: 'di 1/11/1999 10:24'!
pushArgs: args from: sendr 
	"Simulates action of the value primitive."

	args size ~= nargs ifTrue: [^self error: 'incorrect number of args'].
	self stackp: 0.
	args do: [:arg | self push: arg].
	sender _ sendr.
	pc _ startpc! !


!BlockContext methodsFor: 'exceptions' stamp: 'sma 5/11/2000 19:38'!
assert
	self assert: self! !

!BlockContext methodsFor: 'exceptions' stamp: 'tfei 6/5/1999 18:54'!
ensure: aBlock
	"Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes."

	| returnValue |
	returnValue := self valueUninterruptably.
	"aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated"
	aBlock == nil
		ifFalse: [aBlock value].
	^returnValue! !

!BlockContext methodsFor: 'exceptions' stamp: 'tfei 6/5/1999 18:53'!
ifCurtailed: aBlock
	"Evaluate the receiver with an abnormal termination action."

	^self valueUninterruptably! !

!BlockContext methodsFor: 'exceptions' stamp: 'ikp 9/18/2000 21:42'!
on: exception do: handlerAction
	"Evaluate the receiver in the scope of an exception handler."
	| handlerActive |
	handlerActive _ true.
	^self value! !


!BlockContext methodsFor: 'private-exceptions' stamp: 'tfei 6/9/1999 16:39'!
valueUninterruptably
	"Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior."

	| sendingContext result homeSender |
	sendingContext := thisContext sender sender.
	homeSender _ home swapSender: nil.
	[[result := self
				on: BlockCannotReturn
				do:
					[:ex |
					thisContext unwindTo: sendingContext.
					sendingContext home answer: ex result.
					ex return: ex result]]
						on: ExceptionAboutToReturn
						do:
							[:ex |
							home sender == nil
								ifTrue:
									[home swapSender: homeSender.
									ex resume: homeSender]
								ifFalse: [ex resume: nil]]]
		on: Exception
		do:
			[:ex |
			home swapSender: homeSender.
			ex pass].
	home swapSender: homeSender.
	^result! !


!BlockContext methodsFor: 'private-debugger' stamp: 'tfei 3/20/2000 00:24'!
hideFromDebugger

	^home ~~ nil and: [home hideFromDebugger]! !


!BlockContext methodsFor: 'Worlds' stamp: 'RAA 7/5/2000 11:13'!
valueWithWorld: aWorldOrNil

	^self
		on: RequestCurrentWorldNotification
		do: [ :ex | ex resume: aWorldOrNil ]! !


!BlockContext methodsFor: 'tiles' stamp: 'RAA 8/16/1999 13:52'!
valueWithPossibleArgs: anArray 

	self numArgs = 0 ifTrue: [^self value].
	self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray].
	self numArgs > anArray size ifTrue: [
		^self valueWithArguments: anArray,
				(Array new: (self numArgs - anArray size))
	].
	^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs)

! !
ParseNode subclass: #BlockNode
	instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!BlockNode commentStamp: '<historical>' prior: 0!
I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.!


!BlockNode methodsFor: 'initialize-release'!
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder
	"Compile."

	arguments _ argNodes.
	statements _ statementsCollection size > 0
				ifTrue: [statementsCollection]
				ifFalse: [argNodes size > 0
						ifTrue: [statementsCollection copyWith: arguments last]
						ifFalse: [Array with: NodeNil]].
	returns _ returnBool! !

!BlockNode methodsFor: 'initialize-release' stamp: 'sma 3/3/2000 13:38'!
statements: statementsCollection returns: returnBool 
	"Decompile."

	| returnLast |
	returnLast _ returnBool.
	returns _ false.
	statements _ 
		(statementsCollection size > 1 
			and: [(statementsCollection at: statementsCollection size - 1) 
					isReturningIf])
				ifTrue: 
					[returnLast _ false.
					statementsCollection allButLast]
				ifFalse: [statementsCollection size = 0
						ifTrue: [Array with: NodeNil]
						ifFalse: [statementsCollection]].
	arguments _ #().
	temporaries _ #().
	returnLast ifTrue: [self returnLast]! !


!BlockNode methodsFor: 'accessing'!
arguments: argNodes 
	"Decompile."

	arguments _ argNodes! !

!BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'!
block
	^ self! !

!BlockNode methodsFor: 'accessing'!
firstArgument
	^ arguments first! !

!BlockNode methodsFor: 'accessing'!
numberOfArguments

	^arguments size! !

!BlockNode methodsFor: 'accessing'!
returnLast

	self returns
		ifFalse: 
			[returns _ true.
			statements at: statements size put: statements last asReturnNode]! !

!BlockNode methodsFor: 'accessing'!
returnSelfIfNoOther

	self returns
		ifFalse: 
			[statements last == NodeSelf ifFalse: [statements add: NodeSelf].
			self returnLast]! !

!BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'!
temporaries: aCollection
	temporaries _ aCollection! !


!BlockNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^arguments size = 0! !

!BlockNode methodsFor: 'testing'!
isComplex

	^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! !

!BlockNode methodsFor: 'testing'!
isJust: node

	returns ifTrue: [^false].
	^statements size = 1 and: [statements first == node]! !

!BlockNode methodsFor: 'testing'!
isJustCaseError

	^ statements size = 1 and:
		[statements first
			isMessage: #caseError
			receiver: [:r | r==NodeSelf]
			arguments: nil]! !

!BlockNode methodsFor: 'testing'!
isQuick
	^ statements size = 1
		and: [statements first isVariableReference
				or: [statements first isSpecialConstant]]! !

!BlockNode methodsFor: 'testing'!
returns

	^returns or: [statements last isReturningIf]! !


!BlockNode methodsFor: 'code generation'!
code

	^statements first code! !

!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:32'!
emitExceptLast: stack on: aStream
	| nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ self].  "Only one statement"
	1 to: nextToLast do:
		[:i | (statements at: i) emitForEffect: stack on: aStream].
! !

!BlockNode methodsFor: 'code generation'!
emitForEvaluatedEffect: stack on: aStream

	self returns
		ifTrue: 
			[self emitForEvaluatedValue: stack on: aStream.
			stack pop: 1]
		ifFalse: 
			[self emitExceptLast: stack on: aStream.
			statements last emitForEffect: stack on: aStream]! !

!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:44'!
emitForEvaluatedValue: stack on: aStream
	self emitExceptLast: stack on: aStream.
	statements last emitForValue: stack on: aStream.
! !

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

	aStream nextPut: LdThisContext.
	stack push: 1.
	nArgsNode emitForValue: stack on: aStream.
	remoteCopyNode
		emit: stack
		args: 1
		on: aStream.
	"Force a two byte jump."
	self emitLong: size code: JmpLong on: aStream.
	stack push: arguments size.
	arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream].
	self emitForEvaluatedValue: stack on: aStream.
	self returns ifFalse: [aStream nextPut: EndRemote].
	stack pop: 1! !

!BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:33'!
sizeExceptLast: encoder
	| codeSize nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ 0]. "Only one statement"
	codeSize _ 0.
	1 to: nextToLast do: 
		[:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)].
	^ codeSize! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedEffect: encoder

	self returns ifTrue: [^self sizeForEvaluatedValue: encoder].
	^(self sizeExceptLast: encoder)
		+ (statements last sizeForEffect: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedValue: encoder

	^(self sizeExceptLast: encoder)
		+ (statements last sizeForValue: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForValue: encoder
	nArgsNode _ encoder encodeLiteral: arguments size.
	remoteCopyNode _ encoder encodeSelector: #blockCopy:.
	size _ (self sizeForEvaluatedValue: encoder)
				+ (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
	arguments _ arguments collect:  "Chance to prepare debugger remote temps"
				[:arg | arg asStorableNode: encoder].
	arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
	^1 + (nArgsNode sizeForValue: encoder) 
		+ (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! !


!BlockNode methodsFor: 'printing' stamp: 'RAA 7/5/2000 11:43'!
printArgumentsOn: aStream indent: level
	arguments size = 0
		ifTrue: [^ self].
	aStream dialect = #SQ00
		ifTrue: [aStream
				withStyleFor: #setOrReturn
				do: [aStream nextPutAll: 'With'].
			arguments
				do: [:arg | 
					aStream space.
					aStream
						withStyleFor: #blockArgument
						do: [aStream nextPutAll: arg key]].
			aStream nextPutAll: '. ']
		ifFalse: [arguments
				do: [:arg | aStream
						withStyleFor: #blockArgument
						do: [aStream nextPutAll: ':';
								 nextPutAll: arg key;
								 space]].
			aStream nextPutAll: '| '].
	"If >0 args and >1 statement, put all statements on separate lines"
	statements size > 1
		ifTrue: [aStream crtab: level]! !

!BlockNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:49'!
printOn: aStream indent: level

	"statements size <= 1 ifFalse: [aStream crtab: level]."
	aStream nextPut: $[.
	self printArgumentsOn: aStream indent: level.
	self printTemporariesOn: aStream indent: level.
	self printStatementsOn: aStream indent: level.
	aStream nextPut: $]! !

!BlockNode methodsFor: 'printing' stamp: 'di 4/3/1999 23:25'!
printStatementsOn: aStream indent: levelOrZero
	| len shown thisStatement level |
	level _ 1 max: levelOrZero.
	comment == nil
		ifFalse: 
			[self printCommentOn: aStream indent: level.
			aStream crtab: level].
	len _ shown _ statements size.
	(levelOrZero = 0 "top level" and: [statements last isReturnSelf])
		ifTrue: [shown _ 1 max: shown - 1]
		ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])
					ifTrue: [shown _ shown - 1]].
	1 to: shown do: 
		[:i | 
		thisStatement _ statements at: i.
		thisStatement printOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; crtab: level].
		(thisStatement comment ~~ nil and: [thisStatement comment size > 0])
			ifTrue: 
				[i = shown ifTrue: [aStream crtab: level].
				thisStatement printCommentOn: aStream indent: level.
				i < shown ifTrue: [aStream crtab: level]]]! !

!BlockNode methodsFor: 'printing' stamp: 'di 4/5/2000 15:09'!
printTemporariesOn: aStream indent: level

	(temporaries == nil or: [temporaries size = 0])
		ifFalse: 
			[aStream nextPut: $|.
			temporaries do: 
				[:arg | 
				aStream
					space;
					withStyleFor: #temporaryVariable
						do: [aStream nextPutAll: arg key]].
			aStream nextPutAll: ' | '.
			"If >0 args and >1 statement, put all statements on separate lines"
			statements size > 1 ifTrue: [aStream crtab: level]]! !


!BlockNode methodsFor: 'equation translation'!
statements
	^statements! !

!BlockNode methodsFor: 'equation translation'!
statements: val
	statements _ val! !


!BlockNode methodsFor: 'C translation' stamp: 'hg 8/14/2000 15:33'!
asTranslatorNode
	| statementList newS |
	statementList _ OrderedCollection new.
	statements do: [ :s |
		newS _ s asTranslatorNode.
		newS isStmtList ifTrue: [
			"inline the statement list returned when a CascadeNode is translated"
			statementList addAll: newS statements.
		] ifFalse: [
			statementList add: newS.
		].
	].
	^TStmtListNode new
		setArguments: (arguments asArray collect: [ :arg | arg key ])
		statements: statementList;
		comment: comment! !


!BlockNode methodsFor: 'tiles' stamp: 'di 11/13/2000 20:32'!
asMorphicSyntaxIn: parent

	| row column |
	(column _ parent addColumn: #block on: self) layoutInset: 2@-1.
	self addCommentToMorph: column.
	arguments size > 0 ifTrue:
		[row _ column addRow: #blockarg1 on: (BlockArgsNode new).
		arguments do: [:arg | (arg asMorphicSyntaxIn: row) color: #blockarg2]].
	statements do: [ :each | 
		(each asMorphicSyntaxIn: column) borderWidth: 1.
		each addCommentToMorph: column].
	^ column! !

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

BlockNode class
	instanceVariableNames: ''!

!BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'!
statements: statements returns: returns
	^ self new statements: statements returns: returns! !

!BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'!
withJust: aNode
	^ self statements: (Array with: aNode) returns: false! !
BooklikeMorph subclass: #BookMorph
	instanceVariableNames: 'pages currentPage '
	classVariableNames: 'MethodHolders VersionNames VersionTimes '
	poolDictionaries: ''
	category: 'Morphic-Books'!
!BookMorph commentStamp: '<historical>' prior: 0!
A collection of pages, each of which is a place to put morphs.  Allows one or another page to show; orchestrates the page transitions; offers control panel for navigating among pages and for adding and deleting pages.

To write a book out to the disk or to a file server, decide what folder it goes in.  Construct a url to a typical page:
	file://myDisk/folder/myBook1.sp
or
	ftp://aServer/folder/myBook1.sp

Choose "send all pages to server" from the book's menu (press the <> part of the controls).  Choose "use page numbers".  Paste in the url.

To load an existing book, find its ".bo" file in the file list browser.  Choose "load as book".

To load an existing book from its url, execute:
Ã(URLMorph grabURL: 'ftp://aServer/folder/myBook1.sp') book: true.

Multiple people may modify a book.  If other people may have changed a book you have on your screen, choose "reload all from server".

Add or modify a page, and choose "send this page to server".

The polite thing to do is to reload before changing a book.  Then write one or all pages soon after making your changes.  If you store a stale book, it will wipe out changes that other people made in the mean time.

Pages may be linked to each other.  To create a named link to a new page, type the name of the page in a text area in a page.  Select it and do Cmd-6.  Choose 'link to'.  A new page of that name will be added at the back of the book.  Clicking on the blue text flips to that page.  
	To create a link to an existing page, first name the page.  Go to that page and Cmd-click on it.  The name of the page is below the page.  Click in it and backspace and type.  Return to the page you are linking from.  Type the name. Cmd-6, 'link to'.  

Text search:  Search for a set of fragments.  allStrings collects text of fields.  Turn to page with all fragments on it and highlight the first one.  Save the container and offset in properties: #searchContainer, #searchOffset, #searchKey.  Search again from there.  Clear those at each page turn, or change of search key.  

[rules about book indexes and pages:  Index and pages must live in the same directory. They have the same file prefix, followed by .bo for the index or 4.sp for a page (or x4.sp).  When a book is moved to a new directory, the load routine gets the new urls for all pages and saves those in the index.  Book stores index url in property #url.  
    Allow mulitple indexes (books) on the same shared set of pages.  If book has a url in same directory as pages, allow them to have different prefixes.
	save all pages first time, save one page first time, fromRemoteStream: (first time)
	save all pages normal , save one page normal, reload
	where I check if same dir]
URLMorph holds url of both page and book.!


!BookMorph methodsFor: 'initialization' stamp: 'tk 1/24/1999 15:29'!
fromRemoteStream: strm
	"Make a book from an index and a bunch of pages on a server.  NOT showing any page!!  Index and pages must live in the same directory.  If the book has moved, save the current correct urls for each of the pages.  Self must already have a url stored in property #url."

	| remote dict bookUrl oldStem stem oldUrl endPart |
	remote _ strm fileInObjectAndCode.
	bookUrl _ (SqueakPage new) url: (self valueOfProperty: #url); url.
		"expand a relative url"
	oldStem _ SqueakPage stemUrl: (remote at: 2) url.
	oldStem _ oldStem copyUpToLast: $/.
	stem _ SqueakPage stemUrl: bookUrl.
	stem _ stem copyUpToLast: $/.
	oldStem = stem ifFalse: [
		"Book is in new directory, fix page urls"
		2 to: remote size do: [:ii | 
			oldUrl _ (remote at: ii) url.
			endPart _ oldUrl copyFrom: oldStem size+1 to: oldUrl size.
			(remote at: ii) url: stem, endPart]].
	self initialize.
	pages _ OrderedCollection new.
	2 to: remote size do: [:ii | pages add: (remote at: ii)].
	currentPage fullReleaseCachedState; delete.	"the blank one"
	currentPage _ remote at: 2.
	dict _ remote at: 1.
	self setProperty: #modTime toValue: (dict at: #modTime).
	dict at: #allText ifPresent: [:val |
		self setProperty: #allText toValue: val].
	dict at: #allTextUrls ifPresent: [:val |
		self setProperty: #allTextUrls toValue: val].
	#(color borderWidth borderColor pageSize) with: 
		#(color: borderWidth: borderColor: pageSize:) do: [:key :sel |
			dict at: key ifPresent: [:val | 
			 	self perform: sel with: val]].
	^ self! !

!BookMorph methodsFor: 'initialization' stamp: 'tk 1/15/1999 08:02'!
fromURL: url
	"Make a book from an index and a bunch of pages on a server.  NOT showing any page!!"

	| strm |
	Cursor wait showWhile: [
		strm _ (ServerFile new fullPath: url) asStream].
	strm class == String ifTrue: [self inform: 'Sorry, ',strm. ^ nil].
	self setProperty: #url toValue: url.
	self fromRemoteStream: strm.
	^ self! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 7/4/1998 16:43'!
initialize

	super initialize.
	self setInitialState.
	pages _ OrderedCollection new.
	self showPageControls.
	self class turnOffSoundWhile: [self insertPage].
! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 6/24/1998 09:23'!
newPages: pageList
	"Replace all my pages with the given list of BookPageMorphs.  After this call, currentPage may be invalid."

	pages _ pages species new.
	pages addAll: pageList! !

!BookMorph methodsFor: 'initialization' stamp: 'jm 11/17/97 17:26'!
newPages: pageList currentIndex: index
	"Replace all my pages with the given list of BookPageMorphs. Make the current page be the page with the given index."

	pages _ pages species new.
	pages addAll: pageList.
	pages isEmpty ifTrue: [^ self insertPage].
	self goToPage: index.
! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 7/4/1998 16:45'!
removeEverything
	currentPage _ nil.
	pages _ OrderedCollection new.
	self removeAllMorphs! !

!BookMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:10'!
setInitialState
	self listDirection: #topToBottom.
	self wrapCentering: #topLeft.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self layoutInset: 5.
	color _ Color white.
							"pageSize _ 1060@800."
	pageSize _ 160@300.		"back to the original since the pother was way too big"
	self enableDragNDrop! !


!BookMorph methodsFor: 'sorting' stamp: 'RAA 6/28/2000 19:44'!
acceptSortedContentsFrom: aHolder
	"Update my page list from the given page sorter."

	| goodPages rejects toAdd sqPage |
	goodPages _ OrderedCollection new.
	rejects _ OrderedCollection new.
	aHolder submorphs doWithIndex: [:m :i |
		toAdd _ nil.
		(m isKindOf: PasteUpMorph) ifTrue: [toAdd _ m].
		(m isKindOf: BookPageThumbnailMorph) ifTrue: [
			toAdd _ m page.
			m bookMorph == self ifFalse: [
				"borrowed from another book. preserve the original"
				toAdd _ toAdd veryDeepCopy.	

				"since we came from elsewhere, cached strings are wrong"
				self removeProperty: #allTextUrls.
				self removeProperty: #allText.
			].
		].
		toAdd class == String ifTrue: ["a url"
			toAdd _ pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]].
		toAdd class == String ifTrue: [
			sqPage _ SqueakPageCache atURL: toAdd.
			toAdd _ sqPage contentsMorph 
				ifNil: [sqPage copyForSaving]	"a MorphObjectOut"
				ifNotNil: [sqPage contentsMorph]].
		toAdd ifNil: [rejects add: m]
			ifNotNil: [goodPages add: toAdd]].

	self newPages: goodPages.
	goodPages size = 0 ifTrue: [self insertPage].
	rejects size > 0 ifTrue: [self inform: rejects size printString, ' objects vanished in this process.']
! !

!BookMorph methodsFor: 'sorting' stamp: 'sw 3/5/1999 17:38'!
morphsForPageSorter
	| i thumbnails |
	'Assembling thumbnail images...'
		displayProgressAt: self cursorPoint
		from: 0 to: pages size
		during:
			[:bar | i _ 0.
			thumbnails _ pages collect:
				[:p | bar value: (i_ i+1).
				pages size > 40 
					ifTrue: [p smallThumbnailForPageSorter inBook: self]
					ifFalse: [p thumbnailForPageSorter inBook: self]]].
	^ thumbnails! !

!BookMorph methodsFor: 'sorting' stamp: 'di 1/4/1999 13:52'!
sortPages

	currentPage ifNotNil: [currentPage updateCachedThumbnail].
	^ super sortPages! !

!BookMorph methodsFor: 'sorting' stamp: 'di 1/4/1999 12:12'!
sortPages: evt

	^ self sortPages! !


!BookMorph methodsFor: 'accessing' stamp: 'tk 12/17/1998 11:19'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy.  Especially the non-showing pages in BookMorphs.    (As needed, make a variant of this that brings in all pages that are not in memory.)"

	| coll |
	coll _ OrderedCollection new.
	pages do: [:pg |
		pg isInMemory ifTrue: [
			pg == currentPage ifFalse: [coll add: pg]]].
	^ coll! !

!BookMorph methodsFor: 'accessing' stamp: 'sw 10/16/1998 22:39'!
currentPage
	(submorphs includes: currentPage) ifFalse: [currentPage _ nil].
	^ currentPage! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 1/3/2001 08:54'!
pageNamed: aName
	^ pages detect: [:p | p knownName = aName] ifNone: [nil]! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 12/24/1998 07:27'!
pageNumberOf: aMorph
	"Modified so that if the page IS in memory, other pages don't have to be brought in.  (This method may wrongly say a page is not here if pages has a tombstone (MorphObjectOut) and that tombstone would resolve to an object already in this image.  This is an unlikely case, and callers just have to tolerate it.)"

	^ pages identityIndexOf: aMorph ifAbsent: [0]
! !

!BookMorph methodsFor: 'accessing'!
pages

	^ pages
! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 10/22/1998 15:47'!
pages: aMorphList

	pages _ aMorphList asOrderedCollection.

	"It is tempting to force the first page to be the current page.  But then, two pages might be shown at once!!  Just trust the copying mechanism and let currentPage be copied correctly. --Ted."! !

!BookMorph methodsFor: 'accessing' stamp: 'mjg 9/28/1999 11:57'!
setAllPagesColor: aColor
	"Set the color of all the pages to a new color"

	self pages do: [:page | page color: aColor].! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 12:05'!
userString
	"Do I have a text string to be searched on?"

	| list |
	self getAllText.
	list _ OrderedCollection new.
	(self valueOfProperty: #allText ifAbsent: #()) do: [:aList |
		list addAll: aList].
	^ list! !


!BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to add submorphs just by dropping them on this morph."

	(currentPage allMorphs includes: aMorph)
		ifFalse: [currentPage addMorph: aMorph]! !

!BookMorph methodsFor: 'dropping/grabbing'!
allowSubmorphExtraction

	^ false! !

!BookMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/30/1998 10:38'!
wantsDroppedMorph: aMorph event: evt
	(currentPage bounds containsPoint: (self pointFromWorld: evt cursorPoint)) ifFalse: [^ false].
	^ super wantsDroppedMorph: aMorph event: evt! !


!BookMorph methodsFor: 'insert and delete' stamp: 'sw 10/13/2000 12:59'!
defaultNameStemForNewPages
	"Answer a stem onto which to build default names for fresh pages"

	^ 'page'
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'sw 6/24/1998 18:50'!
deletePage

	| message |
	message _ 
'Are you certain that you
want to delete this page and
everything that is on it? '.
	(self confirm: message) ifTrue: 
			[self deletePageBasic].
	! !

!BookMorph methodsFor: 'insert and delete' stamp: 'di 9/7/1999 21:57'!
deletePageBasic
	| thisPage |
	thisPage _ self pageNumberOf: currentPage.
	pages remove: currentPage.
	currentPage delete.
	currentPage _ nil.
	pages isEmpty ifTrue: [^ self insertPage].
	self goToPage: (thisPage min: pages size)
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'sw 10/12/97 21:48'!
insertPage: aPage pageSize: aPageSize
	^ self insertPage: aPage pageSize: aPageSize atIndex: (pages size + 1)! !

!BookMorph methodsFor: 'insert and delete' stamp: 'sw 5/14/1998 11:06'!
insertPage: aPage pageSize: aPageSize atIndex: anIndex

	| sz  predecessor |
	sz _ aPageSize
		ifNil: [currentPage == nil
			ifTrue: [pageSize]
			ifFalse: [currentPage extent]]
		ifNotNil:
			[aPageSize].
	aPage extent: sz.
	((pages isEmpty | anIndex == nil) or: [anIndex > pages size])
		ifTrue:
			[pages add: aPage]
		ifFalse:
			[anIndex <= 1
				ifTrue:
					[pages addFirst: aPage]
				ifFalse:
					[predecessor _ anIndex == nil
						ifTrue:
							[currentPage]
						ifFalse:
							[pages at: anIndex].
					self pages add: aPage after: predecessor]].

	self goToPageMorph: aPage
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'sw 10/13/2000 13:00'!
insertPageColored: aColor
	"Insert a new page for the receiver, using the given color as its background color"

	| sz newPage bw bc |
	currentPage == nil
		ifTrue:
			[sz _ pageSize.
			bw _ 0.
			bc _ Color blue muchLighter]
		ifFalse:
			[sz _ currentPage extent.
			bw _ currentPage borderWidth.
			bc _ currentPage borderColor].
	newPagePrototype
		ifNil:
			[newPage _ PasteUpMorph new extent: sz; color: aColor.
			newPage borderWidth: bw; borderColor: bc]
		ifNotNil: [Cursor wait showWhile: 
				[newPage _ newPagePrototype veryDeepCopy]].
	newPage setNameTo: self defaultNameStemForNewPages.
	newPage resizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: (currentPage _ newPage)]
		ifFalse: [pages add: newPage after: currentPage].
	self nextPage
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'ar 11/9/2000 21:10'!
insertPageLabel: labelString morphs: morphList

	| m c labelAllowance |
	self insertPage.
	labelString ifNotNil:
			[m _ (TextMorph new extent: currentPage width@20; contents: labelString).
		m lock.
		m position: currentPage position + (((currentPage width - m width) // 2) @ 5).
		currentPage addMorph: m.
		labelAllowance _ 40]
		ifNil:
			[labelAllowance _ 0].

	"use a column to align the given morphs, then add them to the page"
	c _ AlignmentMorph newColumn wrapCentering: #center; cellPositioning: #topCenter.
	c addAllMorphs: morphList.
	c position: currentPage position + (0 @ labelAllowance).
	currentPage addAllMorphs: morphList.
	^ currentPage
! !

!BookMorph methodsFor: 'insert and delete' stamp: 'sw 10/13/2000 13:01'!
insertPageSilentlyAtEnd
	"Create a new page at the end of the book.  Do not turn to it."

	| sz newPage bw bc cc | 
	currentPage == nil
		ifTrue: [sz _ pageSize.
			bw _ 0.
			bc _ Color blue muchLighter.
			cc _ color]
		ifFalse: [sz _ currentPage extent.
			bw _ currentPage borderWidth.
			bc _ currentPage borderColor.
			cc _ currentPage color].
	newPagePrototype
		ifNil: [newPage _ PasteUpMorph new extent: sz; color: cc.
			newPage borderWidth: bw; borderColor: bc]
		ifNotNil: [Cursor wait showWhile: 
				[newPage _ newPagePrototype veryDeepCopy]].
	newPage setNameTo: self defaultNameStemForNewPages.
	newPage resizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: (currentPage _ newPage)]	"had been none"
		ifFalse: [pages add: newPage after: pages last].
	^ newPage! !


!BookMorph methodsFor: 'navigation' stamp: 'ar 11/9/2000 20:37'!
buildFloatingPageControls

	| pageControls |
	pageControls _ self makePageControlsFrom: self fullControlSpecs.
	pageControls borderWidth: 0; layoutInset: 4.
	pageControls  setProperty: #pageControl toValue: true.
	pageControls setNameTo: 'Page Controls'.
	pageControls color: Color yellow.
	^FloatingBookControlsMorph new addMorph: pageControls.
! !

!BookMorph methodsFor: 'navigation' stamp: 'di 12/20/1998 10:18'!
goToPage: pageNumber

	^ self goToPage: pageNumber transitionSpec: nil! !

!BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:07'!
goToPage: pageNumber transitionSpec: transitionSpec

	| pageMorph |
	pages isEmpty ifTrue: [^ self].
	pageMorph _ (self hasProperty: #dontWrapAtEnd)
		ifTrue: [pages atPin: pageNumber]
		ifFalse: [pages atWrap: pageNumber].
	^ self goToPageMorph: pageMorph transitionSpec: transitionSpec! !

!BookMorph methodsFor: 'navigation' stamp: 'tk 12/24/1998 07:17'!
goToPageMorph: aMorph

	self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]).
! !

!BookMorph methodsFor: 'navigation' stamp: 'di 1/4/1999 12:37'!
goToPageMorph: aMorph fromBookmark: aBookmark
	"This protocol enables sensitivity to a transitionSpec on the bookmark"
	
	self goToPageMorph: aMorph
		transitionSpec: (aBookmark valueOfProperty: #transitionSpec).
! !

!BookMorph methodsFor: 'navigation' stamp: 'RAA 11/20/2000 12:44'!
goToPageMorph: newPage transitionSpec: transitionSpec
	| pageIndex aWorld oldPageIndex ascending tSpec readIn |
	pages isEmpty ifTrue: [^ self].

	self setProperty: #searchContainer toValue: nil.	"forget previous search"
	self setProperty: #searchOffset toValue: nil.
	self setProperty: #searchKey toValue: nil.
	pageIndex _ pages identityIndexOf: newPage ifAbsent: [^ self "abort"].
	readIn _ newPage isInMemory not.
	oldPageIndex _ pages identityIndexOf: currentPage ifAbsent: [nil].
	ascending _ ((oldPageIndex == nil) or: [newPage == currentPage])
			ifTrue: [nil]
			ifFalse: [oldPageIndex < pageIndex].

	tSpec _ transitionSpec ifNil:  "If transition not specified by requestor..."
		[newPage valueOfProperty: #transitionSpec  " ... then consult new page"
			ifAbsent: [self transitionSpecFor: self  " ... otherwise this is the default"]].

	self flag: #arNote. "Probably unnecessary"
	(aWorld _ self world) ifNotNil:
		[self primaryHand releaseKeyboardFocus].

	currentPage ifNotNil: [currentPage updateCachedThumbnail].
	self currentPage ~~ nil
		ifTrue:
		[(((pages at: pageIndex) owner isKindOf: TransitionMorph)
			and: [(pages at: pageIndex) isInWorld])
			ifTrue: [^ self  "In the process of a prior pageTurn"].
		self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts].
		ascending ifNotNil:
			["Show appropriate page transition and start new page when done"
			currentPage stopStepping.
			(pages at: pageIndex) position: currentPage position.
			^ (TransitionMorph
					effect: tSpec second
					direction: tSpec third
					inverse: (ascending or: [transitionSpec notNil]) not)
				showTransitionFrom: currentPage
				to: (pages at: pageIndex)
				in: self
				whenStart: [self playPageFlipSound: tSpec first]
				whenDone:
					[currentPage delete; fullReleaseCachedState.
					self insertPageMorphInCorrectSpot: (pages at: pageIndex).
					self adjustCurrentPageForFullScreen.
					self snapToEdgeIfAppropriate.
					aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
					self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts].
					(aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld].
					readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url.
						currentPage sqkPage computeThumbnail].	"just store it"
					]].

		"No transition, but at least decommission current page"
		currentPage delete; fullReleaseCachedState].

	self insertPageMorphInCorrectSpot: (pages at: pageIndex).
	self adjustCurrentPageForFullScreen.
	self snapToEdgeIfAppropriate.
	aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage].
	self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts].
	(aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld].
	readIn ifTrue: [currentPage updateThumbnailUrl.
		currentPage sqkPage computeThumbnail].	"just store it"

! !

!BookMorph methodsFor: 'navigation' stamp: 'tk 3/28/2000 13:40'!
goToPageUrl: aUrl

	| pp short |
	pp _ pages detect: [:pg | pg url = aUrl] ifNone: [nil].
	pp ifNil: [short _ (aUrl findTokens: '/') last.
			pp _ pages detect: [:pg | pg url ifNil: [false]
						ifNotNil: [(pg url findTokens: '/') last = short]] "it moved"
					ifNone: [pages at: 1]].
	self goToPageMorph: pp.
! !

!BookMorph methodsFor: 'navigation' stamp: 'sw 10/26/1998 15:41'!
goto: aPlayer
	self goToPageMorph: aPlayer costume! !

!BookMorph methodsFor: 'navigation' stamp: 'RAA 11/20/2000 12:43'!
insertPageMorphInCorrectSpot: aPageMorph

	self addMorphBack: (currentPage _ aPageMorph).
! !

!BookMorph methodsFor: 'navigation' stamp: 'sw 8/4/97 12:05'!
lastPage
	self goToPage: pages size
! !

!BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:01'!
nextPage

	currentPage == nil ifTrue: [^ self goToPage: 1].
	self goToPage: (self pageNumberOf: currentPage) + 1.
! !

!BookMorph methodsFor: 'navigation' stamp: 'tk 12/24/1998 07:19'!
pageNumber

	^ self pageNumberOf: currentPage! !

!BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:01'!
previousPage

	currentPage == nil ifTrue: [^ self goToPage: 1].
	self goToPage: (self pageNumberOf: currentPage) - 1.
! !

!BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:20'!
setWrapPages: doWrap
	doWrap
		ifTrue: [self removeProperty: #dontWrapAtEnd]
		ifFalse: [self setProperty: #dontWrapAtEnd toValue: true].
! !

!BookMorph methodsFor: 'navigation' stamp: 'sw 5/23/2000 13:11'!
showMoreControls
	self currentEvent shiftPressed
		ifTrue:
			[self hidePageControls]
		ifFalse:
			[self showPageControls: self fullControlSpecs]! !

!BookMorph methodsFor: 'navigation' stamp: 'di 12/21/1998 11:15'!
transitionSpecFor: aMorph
	^ aMorph valueOfProperty: #transitionSpec  " check for special propety"
		ifAbsent: [Array with: 'camera'  " ... otherwise this is the default"
						with: #none
						with: #none]! !


!BookMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:55'!
addBookMenuItemsTo: aMenu hand: aHandMorph
	| controlsShowing subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'previous page' action: #previousPage.
	subMenu add: 'next page' action: #nextPage.
	subMenu add: 'goto page' action: #goToPage.
	subMenu add: 'insert a page' action: #insertPage.
	subMenu add: 'delete this page' action: #deletePage.

	controlsShowing _ self hasSubmorphWithProperty: #pageControl.
	controlsShowing
		ifTrue:
			[subMenu add: 'hide page controls' action: #hidePageControls.
			subMenu add: 'fewer page controls' action: #fewerPageControls]
		ifFalse:
			[subMenu add: 'show page controls' action: #showPageControls].
	self isInFullScreenMode ifTrue: [
		subMenu add: 'exit full screen' action: #exitFullScreen.
	] ifFalse: [
		subMenu add: 'show full screen' action: #goFullScreen.
	].
	subMenu addLine.
	subMenu add: 'sound effect for all pages' action: #menuPageSoundForAll:.
	subMenu add: 'sound effect this page only' action: #menuPageSoundForThisPage:.
	subMenu add: 'visual effect for all pages' action: #menuPageVisualForAll:.
	subMenu add: 'visual effect this page only' action: #menuPageVisualForThisPage:.

	subMenu addLine.
	subMenu add: 'sort pages' action: #sortPages:.
	subMenu add: 'uncache page sorter' action: #uncachePageSorter.
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [subMenu add: 'wrap after last page' selector: #setWrapPages: argument: true]
		ifFalse: [subMenu add: 'stop at last page' selector: #setWrapPages: argument: false].

	subMenu addLine.
	subMenu add: 'search for text' action: #textSearch.
	(aHandMorph pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[subMenu add: 'paste book page'	action: #pasteBookPage].

	subMenu add: 'send all pages to server' action: #savePagesOnURL.
	subMenu add: 'send this page to server' action: #saveOneOnURL.
	subMenu add: 'reload all from server' action: #reload.
	subMenu add: 'copy page url to clipboard' action: #copyUrl.
	subMenu add: 'keep in one file' action: #keepTogether.
	subMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil:
		[subMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	aMenu add: 'book...' subMenu: subMenu
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/17/1999 12:52'!
bookmarkForThisPage
	"If this book exists on a server, make the reference via a URL"
	| bb url um |
	(url _ self url) ifNil: [
		bb _ SimpleButtonMorph new target: self.
		bb actionSelector: #goToPageMorph:fromBookmark:.
		bb label: 'Bookmark'.
		bb arguments: (Array with: currentPage with: bb).
		self primaryHand attachMorph: bb.
		^ bb].
	currentPage url ifNil: [currentPage saveOnURLbasic].
	um _ URLMorph newForURL: currentPage url.
	um setURL: currentPage url page: currentPage sqkPage.
	(SqueakPage stemUrl: url) = (SqueakPage stemUrl: currentPage url) 
		ifTrue: [um book: true]
		ifFalse: [um book: url].  	"remember which book"
	um isBookmark: true; label: 'Bookmark'.
	um borderWidth: 1; borderColor: #raised.
	um color: (Color r: 0.4 g: 0.8 b: 0.6).
	self primaryHand attachMorph: um.
	^ um! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 11/10/2000 11:27'!
buildThreadOfProjects

	| thisPVM projectNames threadName |

	projectNames _ pages collect: [ :each |
		(thisPVM _ each findA: ProjectViewMorph) ifNil: [
			nil
		] ifNotNil: [
			{thisPVM project name}.
		].
	].
	projectNames _ projectNames reject: [ :each | each isNil].
	threadName _ FillInTheBlank 
		request: 'Please name this thread.' 
		initialAnswer: (
			self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade']
		).
	threadName isEmptyOrNil ifTrue: [^self].
	InternalThreadNavigationMorph 
		know: projectNames as: threadName;
		openThreadNamed: threadName.
! !

!BookMorph methodsFor: 'menu' stamp: 'ar 1/15/2001 18:37'!
copyUrl
	"Copy this page's url to the clipboard"
	| str |
	str _ currentPage url ifNil: [str _ 'Page does not have a url.  Send page to server first.'].
	Clipboard clipboardText: str asText.
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 1/26/1999 10:10'!
findText: wants
	"Turn to the next page that has all of the strings mentioned on it.  Highlight where it is found.  allText and allTextUrls have been set.  Case insensitive search.
	Resuming a search.  If container's text is still in the list and secondary keys are still in the page, (1) search rest of that container.  (2) search rest of containers on that page (3) pages till end of book, (4) from page 1 to this page again."

	"Later sort wants so longest key is first"
	| allText good thisWord here fromHereOn startToHere oldContainer oldIndex otherKeys strings |
	allText _ self valueOfProperty: #allText ifAbsent: [#()].
	here _ pages identityIndexOf: currentPage ifAbsent: [1].
	fromHereOn _ here+1 to: pages size.
	startToHere _ 1 to: here.		"repeat this page"
	(self valueOfProperty: #searchKey ifAbsent: [#()]) = wants ifTrue: [
		"does page have all the other keys?  No highlight if found!!"
		otherKeys _ wants allButFirst.
		strings _ allText at: here.
		good _ true.
		otherKeys do: [:searchString | "each key"
			good ifTrue: [thisWord _ false.
				strings do: [:longString |
					(longString findString: searchString startingAt: 1 
						caseSensitive: false) > 0 ifTrue: [
							thisWord _ true]].
				good _ thisWord]].
		good ifTrue: ["all are on this page.  Look in rest for string again."
			oldContainer _ self valueOfProperty: #searchContainer.
			oldIndex _ self valueOfProperty: #searchOffset.
			(self findText: (OrderedCollection with: wants first) inStrings: strings	
				startAt: oldIndex+1 container: oldContainer 
				pageNum: here) ifTrue: [
					self setProperty: #searchKey toValue: wants.
					^ true]]]
		ifFalse: [fromHereOn _ here to: pages size].	"do search this page"
	"other pages"
	fromHereOn do: [:pageNum |
		(self findText: wants inStrings: (allText at: pageNum) startAt: 1 container: nil 
				pageNum: pageNum) 
					ifTrue: [^ true]].
	startToHere do: [:pageNum |
		(self findText: wants inStrings: (allText at: pageNum) startAt: 1 container: nil 
				pageNum: pageNum) 
					ifTrue: [^ true]].
	"if fail"
	self setProperty: #searchContainer toValue: nil.
	self setProperty: #searchOffset toValue: nil.
	self setProperty: #searchKey toValue: nil.
	^ false! !

!BookMorph methodsFor: 'menu' stamp: 'tk 11/8/2000 13:08'!
findText: keys inStrings: rawStrings	startAt: startIndex container: oldContainer pageNum: pageNum
	"Call once to search a page of the book.  Return true if found and highlight the text.  oldContainer should be NIL.  
	(oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element.  oldContainer is a TextMorph.)"

	| good thisWord index insideOf place container start wasIn strings |
	good _ true.
	start _ startIndex.
	strings _ oldContainer ifNil: [rawStrings]	"normal case"
		ifNotNil: [(pages at: pageNum) isInMemory 
					ifFalse: [rawStrings]
					ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]].
	keys do: [:searchString | "each key"
		good ifTrue: [thisWord _ false.
			strings do: [:longString |
				(index _ longString findString: searchString startingAt: start 
					caseSensitive: false) > 0 ifTrue: [
						thisWord not & (searchString == (keys at: 1)) ifTrue: [
							insideOf _ longString. place _ index].
						thisWord _ true].
				start _ 1].	"only first key on first container"
			good _ thisWord]].
	good ifTrue: ["all are on this page"
		wasIn _ (pages at: pageNum) isInMemory.
		self goToPage: pageNum.
		wasIn ifFalse: ["search again, on the real current text.  Know page is in."
			^ self findText: keys 
				inStrings: ((pages at: pageNum) allStringsAfter: nil) "recompute"	
				startAt: startIndex container: oldContainer 
				pageNum: pageNum]].
	good ifTrue: ["have the exact string object"
		(container _ oldContainer)
			ifNil: [container _ self highlightText: (keys at: 1) at: place in: insideOf]
			ifNotNil: [
				container userString == insideOf 
					ifFalse: [
						container _ self highlightText: (keys at: 1) at: place 
							in: insideOf]
					ifTrue: [(container isKindOf: TextMorph) ifTrue: [
						container editor selectFrom: place to: 
								(keys at: 1) size - 1 + place.
						container changed].
						]].
		self setProperty: #searchContainer toValue: container.
		self setProperty: #searchOffset toValue: place.
		self setProperty: #searchKey toValue: keys.		"override later"
		^ true].
	^ false! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/26/1999 22:39'!
forgetURLs
	"About to save these objects in a new place.  Forget where stored now.  Must bring in all pages we don't have."

| pg |
pages do: [:aPage |
	aPage yourself.	"bring it into memory"
	(pg _ aPage valueOfProperty: #SqueakPage) ifNotNil: [
		SqueakPageCache removeURL: pg url.
		pg contentsMorph setProperty: #SqueakPage toValue: nil]].
self setProperty: #url toValue: nil.! !

!BookMorph methodsFor: 'menu' stamp: 'tk 1/26/1999 09:26'!
getAllText
	"Collect the text for each page.  Just point at strings so don't have to recopy them.  Parallel array of urls for ID of pages.
	allText = Array (pages size) of arrays (fields in it) of strings of text.
	allTextUrls = Array (pages size) of urls or page numbers.
	For any page that is out, text data came from .bo file on server.  
	Is rewritten when one or all pages are stored."

	| oldUrls oldStringLists allText allTextUrls aUrl which |
	oldUrls _ self valueOfProperty: #allTextUrls ifAbsent: [#()].
	oldStringLists _ self valueOfProperty: #allText ifAbsent: [#()].
	allText _ pages collect: [:pg | OrderedCollection new].
	allTextUrls _ Array new: pages size.
	pages doWithIndex: [:aPage :ind | aUrl _ aPage url.  aPage isInMemory 
		ifTrue: [(allText at: ind) addAll: (aPage allStringsAfter: nil).
			aUrl ifNil: [aUrl _ ind].
			allTextUrls at: ind put: aUrl]
		ifFalse: ["Order of pages on server may be different.  (later keep up to date?)"
			which _ oldUrls indexOf: aUrl.
			allTextUrls at: ind put: aUrl.
			which = 0 ifFalse: [allText at: ind put: (oldStringLists at: which)]]].
	self setProperty: #allText toValue: allText.
	self setProperty: #allTextUrls toValue: allTextUrls.
	^ allText! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 7/5/2000 11:25'!
getStemUrl
	"Try to find the old place where this book was stored. Confirm with the 
	user. Else ask for new place."
	| initial pg url knownURL |

	knownURL _ false.
	initial _ ''.
	(pg _ currentPage valueOfProperty: #SqueakPage)
		ifNotNil: [pg contentsMorph == currentPage
				ifTrue: [initial _ pg url.
					knownURL _ true]].
	"If this page has a url"
	pages
		doWithIndex: [:aPage :ind | initial isEmpty
				ifTrue: [aPage isInMemory
						ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage)
								ifNotNil: [initial _ pg url]]]].
	"any page with a url"
	initial isEmpty
		ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp'].
	"A new legal place"
	url _ knownURL
		ifTrue: [initial]
		ifFalse: [[FillInTheBlank request: 'url of the place to store a typical page in this book.
Must begin with file:// or ftp://' initialAnswer: initial]
				valueWithWorld: self world].
	^ SqueakPage stemUrl: url! !

!BookMorph methodsFor: 'menu' stamp: 'sge 2/13/2000 05:33'!
goToPage
	| pageNum |
	pageNum _ FillInTheBlank request: 'Page?' initialAnswer: '0'.
	pageNum isEmptyOrNil ifTrue: [^true].
	self goToPage: pageNum asNumber.
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 1/19/1999 07:11'!
highlightText: stringToHilite at: index in: insideOf
	"Find the container with this text and highlight it.  May not be able to do it for stringMorphs."

	"Find the container with that text"
	| container |
	self allMorphsDo: [:sub | 
		insideOf == sub userString ifTrue: [container _ sub]].
	container ifNil: [
		self allMorphsDo: [:sub | 
			insideOf = sub userString ifTrue: [container _ sub]]].	"any match"
	container ifNil: [^ nil].

	"Order it highlighted"
	(container isKindOf: TextMorph) ifTrue: [
		container editor selectFrom: index to: stringToHilite size - 1 + index].
	container changed.
	^ container
! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 11/10/2000 11:27'!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	aMenu add: 'find...' action: #textSearch.
	aMenu add: 'go to page...' action: #goToPage.
	aMenu addLine.

	aMenu addList:
		#(('sort pages'			sortPages)
		('uncache page sorter'	uncachePageSorter)).
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [aMenu add: 'wrap after last page' selector: #setWrapPages: argument: true]
		ifFalse: [aMenu add: 'stop at last page' selector: #setWrapPages: argument: false].
	aMenu addList:
		#(('make bookmark'		bookmarkForThisPage)
		('make thumbnail'		thumbnailForThisPage)).
	aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls.
	aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen.

	aMenu addLine.
	aMenu add: 'sound effect for all pages' action: #menuPageSoundForAll:.
	aMenu add: 'sound effect this page only' action: #menuPageSoundForThisPage:.
	aMenu add: 'visual effect for all pages' action: #menuPageVisualForAll:.
	aMenu add: 'visual effect this page only' action: #menuPageVisualForThisPage:.

	aMenu addLine.
	(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[aMenu add: 'paste book page'   action: #pasteBookPage].

	aMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil: [
		aMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	aMenu add: (self dragNDropEnabled ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
			action: #toggleDragNDrop.
	aMenu add: 'make all pages this size' action: #makeUniformPageSize.
	aMenu add: 'send all pages to server' action: #savePagesOnURL.
	aMenu add: 'send this page to server' action: #saveOneOnURL.
	aMenu add: 'reload all from server' action: #reload.
	aMenu add: 'copy page url to clipboard' action: #copyUrl.
	aMenu add: 'keep in one file' action: #keepTogether.

	aMenu addLine.
	aMenu add: 'load PPT images from slide #1' action: #loadImagesIntoBook.
	aMenu add: 'background color for all pages...' action: #setPageColor.
	aMenu add: 'make a thread of projects in this book' action: #buildThreadOfProjects.

	aMenu popUpEvent: self world activeHand lastEvent in: self world! !

!BookMorph methodsFor: 'menu' stamp: 'tk 12/2/1998 19:31'!
keepTogether
	"Mark this book so that each page will not go into a separate file.  Do this when pages share referenes to a common Player.  Don't want many copies of that Player when bring in.  Do not write pages of book out.  Write the PasteUpMorph that the entire book lives in."

	self setProperty: #keepTogether toValue: true.! !

!BookMorph methodsFor: 'menu' stamp: 'mjg 5/15/2000 16:29'!
loadImagesIntoBook
	"PowerPoint stores GIF presentations as individual slides named Slide1, Slide2, etc.
	Load these into the book.  mjg 9/99"

	| directory filenumber form newpage |
	directory _ ((StandardFileMenu oldFileFrom: FileDirectory default) ifNil: [^ nil]) directory.
	directory isNil ifTrue: [^ nil].

	"Start loading 'em up!!"
	filenumber _ 1.
	[directory fileExists: 'Slide',(filenumber asString)] whileTrue:
		[Transcript show: 'Slide',(filenumber asString); cr.
		(Smalltalk bytesLeft < 1000000) ifTrue: ["Make some room"
			(self valueOfProperty: #url) == nil ifTrue:
				[self savePagesOnURL]
			ifFalse: [self saveAsNumberedURLs].].
		form _ Form fromFileNamed: 
			(directory fullNameFor: 'Slide', (filenumber asString)).
		newpage _ PasteUpMorph new extent: (form extent).
		newpage addMorph: (SketchMorph withForm: form).
		self pages addLast: newpage.
		filenumber _ filenumber + 1.].

	"After adding all, delete the first page."
	self goToPage: 1.
	self deletePageBasic.

	"Save the book"
	(self valueOfProperty: #url) == nil ifTrue:
				[self savePagesOnURL]
			ifFalse: [self saveAsNumberedURLs].! !

!BookMorph methodsFor: 'menu' stamp: 'sw 1/25/1999 16:15'!
makeUniformPageSize
	"Make all pages be of the same size as the current page."
	currentPage ifNil: [^ self beep].
	self resizePagesTo: currentPage extent.
	newPagePrototype ifNotNil:
		[newPagePrototype extent: currentPage extent]! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
menuPageSoundFor: target event: evt
	| tSpec menu |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: 'Choose a sound
(it is now ' , tSpec first , ')') defaultTarget: target.
	SampledSound soundNames do:
		[:soundName |
		menu add: soundName target: target
			selector: #setProperty:toValue:
			argumentList: (Array with: #transitionSpec
								with: (tSpec copy at: 1 put: soundName; yourself))].

	menu popUpEvent: evt in: self world! !

!BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:53'!
menuPageSoundForAll: evt

	^ self menuPageSoundFor: self event: evt! !

!BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:55'!
menuPageSoundForThisPage: evt

	currentPage ifNotNil:
		[^ self menuPageSoundFor: currentPage event: evt]! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
menuPageVisualFor: target event: evt
	| tSpec menu subMenu directionChoices |
	tSpec _ self transitionSpecFor: target.
	menu _ (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: target.
	TransitionMorph allEffects do:
		[:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect target: target
					selector: #setProperty:toValue:
					argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: #none))]
		ifFalse: [subMenu _ MenuMorph new.
				directionChoices do:
					[:dir |
					subMenu add: dir target: target
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect subMenu: subMenu]].

	menu popUpEvent: evt in: self world! !

!BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 17:16'!
menuPageVisualForAll: evt

	^ self menuPageVisualFor: self event: evt! !

!BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:55'!
menuPageVisualForThisPage: evt

	currentPage ifNotNil:
		[^ self menuPageVisualFor: currentPage event: evt]! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/23/2000 02:14'!
pageControlsVisible
	^ self hasSubmorphWithProperty: #pageControl! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:04'!
pasteBookPage
	| aPage |
	aPage _ self primaryHand objectToPaste.

	self insertPage: aPage pageSize: aPage extent atIndex: ((pages indexOf: currentPage) - 1).
	"self goToPageMorph: aPage"! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 7/5/2000 11:14'!
reload
	"Fetch the pages of this book from the server again.  For all pages that have not been modified, keep current ones.  Use new pages.  For each, look up in cache, if time there is equal to time of new, and its in, use the current morph.
	Later do fancy things when a page has changed here, and also on the server."

	| url onServer onPgs sq which |
	(url _ self valueOfProperty: #url) ifNil: ["for .bo index file"
		[
			url _ FillInTheBlank 
				request: 'url of the place where this book''s index is stored.
Must begin with file:// or ftp://' 
				initialAnswer: (self getStemUrl, '.bo').
		] valueWithWorld: self world.
		url size > 0 ifTrue: [self setProperty: #url toValue: url]
			ifFalse: [^ self]].
	onServer _ self class new fromURL: url.
	"Later: test book times?"
	onPgs _ onServer pages collect: [:out |
		sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil].
		(sq ~~ nil and: [sq contentsMorph isInMemory])
			ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: 
					  [sq contentsMorph == nil]) 
						ifTrue: [SqueakPageCache atURL: out url put: out sqkPage.
							out]
						ifFalse: [sq contentsMorph]]
			ifFalse: [SqueakPageCache atURL: out url put: out sqkPage.
				out]].
	which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1.
	self newPages: onPgs currentIndex: which.
		"later stay at current page"
	self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime).
	self setProperty: #allText toValue: (onServer valueOfProperty: #allText).
	self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls).
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 3/28/2000 22:03'!
reserveUrls
	"Save a dummy version of the book first, assign all pages URLs, write dummy files to reserve the url, and write the index.  Good when I have pages with interpointing bookmarks."

| stem |
(stem _ self getStemUrl) size = 0 ifTrue: [^ self].
pages doWithIndex: [:pg :ind | 	"does write the current page too"
	pg url ifNil: [pg reserveUrl: stem,(ind printString),'.sp']].

"self saveIndexOnURL."
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/25/1999 10:37'!
reserveUrlsIfNeeded
	"See if this book needs to pre-allocate urls.  Harmless if have urls already.  Actually writes dummy files to reserve names."

| baddies bad2 |
pages size > 25 ifTrue: [^ self reserveUrls].
baddies _ BookPageThumbnailMorph withAllSubclasses.
bad2 _ FlexMorph withAllSubclasses.
pages do: [:aPage |
	aPage allMorphsDo: [:mm | 
		(baddies includes: mm class) ifTrue: [^ self reserveUrls].
		(bad2 includes: mm class) ifTrue: [
			mm originalMorph class == aPage class ifTrue: [
				^ self reserveUrls]]]].
		
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/27/1999 14:24'!
saveAsNumberedURLs
	"Write out all pages in this book that are not showing, onto a server.  The local disk could be the server.  For any page that does not have a SqueakPage and a url already, name that page file by its page number.  Any pages that are already totally out will stay that way."

	| stem list firstTime |
firstTime _ (self valueOfProperty: #url) == nil.
stem _ self getStemUrl.	"user must approve"
stem size = 0 ifTrue: [^ self].
firstTime ifTrue: [self setProperty: #futureUrl toValue: stem, '.bo'].
self reserveUrlsIfNeeded.
pages doWithIndex: [:aPage :ind | 	"does write the current page too"
	aPage isInMemory ifTrue: ["not out now"
		aPage presenter ifNotNil: [aPage presenter flushPlayerListCache].
		aPage saveOnURL: stem,(ind printString),'.sp'.
		]].

list _ pages collect: [:aPage |	 aPage sqkPage prePurge].
	"knows not to purge the current page"
list _ (list select: [:each | each notNil]) asArray.
"do bulk become:"
(list collect: [:each | each contentsMorph])
	elementsExchangeIdentityWith:
		(list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]).

self saveIndexOnURL.
self presenter ifNotNil: [self presenter flushPlayerListCache].
firstTime ifTrue: ["Put a thumbnail into the hand"
	URLMorph grabForBook: self.
	self setProperty: #futureUrl toValue: nil].	"clean up"
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 3/28/2000 21:42'!
saveIndexOfOnly: aPage
	"Modify the index of this book on a server.  Read the index, modify the entry for just this page, and write back.  See saveIndexOnURL. (page file names must be unique even if they live in different directories.)"

	| mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName |
	mine _ self valueOfProperty: #url.
	mine ifNil: [^ self saveIndexOnURL].
	Cursor wait showWhile: [strm _ (ServerFile new fullPath: mine)].
	strm ifNil: [^ self saveIndexOnURL].
	strm class == String ifTrue: [^ self saveIndexOnURL].
	strm exists ifFalse: [^ self saveIndexOnURL].	"write whole thing if missing"
	strm _ strm asStream.
	strm class == String ifTrue: [^ self saveIndexOnURL].
	remote _ strm fileInObjectAndCode.
	dict _ remote at: 1.
	allText _ dict at: #allText ifAbsent: [nil].	"remote, not local"
	allTextUrls _ dict at: #allTextUrls ifAbsent: [nil].
	allText size + 1 ~= remote size ifTrue: [self error: '.bo size mismatch.  Please tell Ted what you just did to this book.'].


	(pageURL _ aPage url) ifNil: [self error: 'just had one!!'].
	fName _ pageURL copyAfterLast: $/.
	2 to: remote size do: [:ii | 
		((remote at: ii) url findString: fName startingAt: 1 
						caseSensitive: false) > 0 ifTrue: [index _ ii].	"fast"
		(remote at: ii) xxxReset].
	index ifNil: ["new page, what existing page does it follow?"
		num _ self pageNumberOf: aPage.
		1 to: num-1 do: [:ii | (pages at: ii) url ifNotNil: [pre _ (pages at: ii) url]].
		pre ifNil: [after _ remote size+1]
			ifNotNil: ["look for it on disk, put me after"
				pre _ pre copyAfterLast: $/.
				2 to: remote size do: [:ii | 
					((remote at: ii) url findString: pre startingAt: 1 
								caseSensitive: false) > 0 ifTrue: [after _ ii+1]].
				after ifNil: [after _ remote size+1]].
		remote _ remote copyReplaceFrom: after to: after-1 with: #(1).
		allText ifNotNil: [
			dict at: #allText put: (allText copyReplaceFrom: after-1 to: after-2 with: #(())).
			dict at: #allTextUrls put: (allTextUrls copyReplaceFrom: after-1 to: after-2 with: #(()))].
		index _ after].

	remote at: index put: (aPage sqkPage copyForSaving).

	(dict at: #modTime ifAbsent: [0]) < Time totalSeconds ifTrue:
		[dict at: #modTime put: Time totalSeconds].
	allText ifNotNil: [
		(dict at: #allText) at: index-1 put: (aPage allStringsAfter: nil).
		(dict at: #allTextUrls) at: index-1 put: pageURL].

	sf _ ServerDirectory new fullPath: mine.
	Cursor wait showWhile: [
		remoteFile _ sf fileNamed: mine.
		remoteFile fileOutClass: nil andObject: remote.
		"remoteFile close"].
! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 8/30/2000 11:47'!
saveIndexOnURL
	"Make up an index to the pages of this book, with thumbnails, and store it on the server.  (aDictionary, aMorphObjectOut, aMorphObjectOut, aMorphObjectOut).  The last part corresponds exactly to what pages looks like when they are all out.  Each holds onto a SqueakPage, which holds a url and a thumbnail."

	| dict list mine sf remoteFile urlList |
	pages size = 0 ifTrue: [^ self].
	dict _ Dictionary new.  dict at: #modTime put: Time totalSeconds.
	"self getAllText MUST have been called at start of this operation."
	dict at: #allText put: (self valueOfProperty: #allText).
	#(color borderWidth borderColor pageSize) do: [:sel |
		dict at: sel put: (self perform: sel)].

	self reserveUrlsIfNeeded.	"should already be done"
	list _ pages copy.	"paste dict on front below"
	"Fix up the entries, should already be done"
	list doWithIndex: [:out :ind |
		out isInMemory ifTrue: [  
			(out valueOfProperty: #SqueakPage) ifNil: [
				out saveOnURLbasic].
			list at: ind put: (out sqkPage copyForSaving)]].
	urlList _ list collect: [:ppg | ppg url].
	self setProperty: #allTextUrls toValue: urlList.
	dict at: #allTextUrls put: urlList.
	list _ (Array with: dict), list.
	mine _ self valueOfProperty: #url.
	mine ifNil: [mine _ self getStemUrl, '.bo'.
		self setProperty: #url toValue: mine].
	sf _ ServerDirectory new fullPath: mine.
	Cursor wait showWhile: [
		remoteFile _ sf fileNamed: mine.
			remoteFile dataIsValid.
		remoteFile fileOutClass: nil andObject: list.
		"remoteFile close"].
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/25/1999 10:22'!
saveOnUrlPage: pageMorph
	"Write out this single page in this book onto a server.  See savePagesOnURL.  (Don't compute the texts, only this page's is written.)"
	| stem ind response rand newPlace dir |
	(self valueOfProperty: #keepTogether) ifNotNil: [
		self inform: 'This book is marked ''keep in one file''. 
Several pages use a common Player.
Save the owner of the book instead.'.
		^ self].
	"Don't give the chance to put in a different place.  Assume named by number"
	((self valueOfProperty: #url) == nil and: [pages first url ~~ nil]) ifTrue: [
		response _ (PopUpMenu labels: 'Old book\New book sharing old pages' 
					withCRs)
				startUpWithCaption: 'Modify the old book, or make a new\book sharing its pages?' withCRs.
		response = 2 ifTrue: [
			"Make up new url for .bo file and confirm with user."  "Mark as shared"
			[rand _ String new: 4.
			1 to: rand size do: [:ii |
				rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
			(newPlace _ self getStemUrl) size = 0 ifTrue: [^ self].
			newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'.
			dir _ ServerFile new fullPath: newPlace.
			(dir includesKey: dir fileName)] whileTrue.	"keep doing until a new file"
			self setProperty: #url toValue: newPlace].
		response = 0 ifTrue: [^ self]].

	stem _ self getStemUrl.	"user must approve"
	stem size = 0 ifTrue: [^ self].
	ind _ pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?'].
	pageMorph isInMemory ifTrue: ["not out now"
			pageMorph saveOnURL: stem,(ind printString),'.sp'].
	self saveIndexOfOnly: pageMorph.! !

!BookMorph methodsFor: 'menu' stamp: 'tk 1/12/1999 18:58'!
saveOneOnURL
	"Write out this single page onto a server.  See savePagesOnURL.  (Don't compute the texts, only this page's is written.)"

	^ self saveOnUrlPage: currentPage! !

!BookMorph methodsFor: 'menu' stamp: 'tk 2/27/1999 14:23'!
savePagesOnURL
	"Write out all pages in this book onto a server.  For any page that does not have a SqueakPage and a url already, ask the user for one.  Give the option of naming all page files by page number.  Any pages that are not in memory will stay that way.  The local disk could be the server."

	| response list firstTime newPlace rand dir bookUrl |
	(self valueOfProperty: #keepTogether) ifNotNil: [
		self inform: 'This book is marked ''keep in one file''. 
Several pages use a common Player.
Save the owner of the book instead.'.
		^ self].
	self getAllText.	"stored with index later"
	response _ (PopUpMenu labels: 'Use page numbers\Type in file names\Save in a new place (using page numbers)\Save in a new place (typing names)\Save new book sharing old pages' withCRs)
			startUpWithCaption: 'Each page will be a file on the server.  \Do you want to page numbers be the names of the files? \or name each one yourself?' withCRs.
	response = 1 ifTrue: [self saveAsNumberedURLs. ^ self].
	response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^ self].
	response = 4 ifTrue: [self forgetURLs].
	response = 5 ifTrue: [
		"Make up new url for .bo file and confirm with user."  "Mark as shared"
		[rand _ String new: 4.
		1 to: rand size do: [:ii |
			rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
		(newPlace _ self getStemUrl) size = 0 ifTrue: [^ self].
		newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'.
		dir _ ServerFile new fullPath: newPlace.
		(dir includesKey: dir fileName)] whileTrue.	"keep doing until a new file"

		self setProperty: #url toValue: newPlace.
		self saveAsNumberedURLs. 
		bookUrl _ self valueOfProperty: #url.
		(SqueakPage stemUrl: bookUrl) = 
			(SqueakPage stemUrl: currentPage url) ifTrue: [
				bookUrl _ true].		"not a shared book"
		(URLMorph grabURL: currentPage url) book: bookUrl.
		^ self].
	response = 0 ifTrue: [^ self].

"self reserveUrlsIfNeeded.	Need two passes here -- name on one, write on second"
pages do: [:aPage |	"does write the current page too"
	aPage isInMemory ifTrue: ["not out now"
		aPage presenter ifNotNil: [aPage presenter flushPlayerListCache].
		aPage saveOnURLbasic.
		]].	"ask user if no url"

list _ pages collect: [:aPage |	 aPage sqkPage prePurge].
	"knows not to purge the current page"
list _ (list select: [:each | each notNil]) asArray.
"do bulk become:"
(list collect: [:each | each contentsMorph])
	elementsExchangeIdentityWith:
		(list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]).

firstTime _ (self valueOfProperty: #url) == nil.
self saveIndexOnURL.
self presenter ifNotNil: [self presenter flushPlayerListCache].
firstTime ifTrue: ["Put a thumbnail into the hand"
	URLMorph grabForBook: self.
	self setProperty: #futureUrl toValue: nil].	"clean up"
! !

!BookMorph methodsFor: 'menu' stamp: 'tk 8/13/1998 12:09'!
setNewPagePrototype
	"Record the current page as the prototype to be copied when inserting new pages."

	currentPage ifNotNil:
		[newPagePrototype _ currentPage veryDeepCopy].
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 9/6/2000 18:43'!
setPageColor
	"Get a color from the user, then set all the pages to that color"

	self currentPage ifNil: [^ self].
	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setAllPagesColor:;
		originalColor: self currentPage color;
		putUpFor: self near: self fullBoundsInWorld! !

!BookMorph methodsFor: 'menu' stamp: 'tk 11/8/2000 11:44'!
textSearch
	"search the text on all pages of this book"

	| wanted wants list str |
	list _ self valueOfProperty: #searchKey ifAbsent: [#()].
	str _ String streamContents: [:strm | 
			list do: [:each | strm nextPutAll: each; space]].
	wanted _ FillInTheBlank request: 'words to search for.  Order is not important.
Beginnings of words are OK.'
		initialAnswer: str.
	wants _ wanted findTokens: Character separators.
	wants size = 0 ifTrue: [^ self].
	self getAllText.		"save in allText, allTextUrls"
	^ self findText: wants	"goes to the page and highlights the text"! !

!BookMorph methodsFor: 'menu' stamp: 'tk 11/8/2000 11:48'!
textSearch: stringWithKeys
	"search the text on all pages of this book"

	| wants |
	wants _ stringWithKeys findTokens: Character separators.
	wants size = 0 ifTrue: [^ self].
	self getAllText.		"save in allText, allTextUrls"
	^ self findText: wants	"goes to the page and highlights the text"! !

!BookMorph methodsFor: 'menu' stamp: 'di 1/4/1999 12:49'!
thumbnailForThisPage
	self primaryHand attachMorph:
		(currentPage thumbnailForPageSorter pageMorph: currentPage inBook: self)
! !

!BookMorph methodsFor: 'menu' stamp: 'RAA 8/23/2000 12:20'!
toggleFullScreen
	self isInFullScreenMode
		ifTrue:	[self exitFullScreen]
		ifFalse:	[self goFullScreen]! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/23/2000 02:18'!
toggleShowingOfPageControls
	self pageControlsVisible
		ifTrue:	[self hidePageControls]
		ifFalse:	[self showPageControls]! !

!BookMorph methodsFor: 'menu' stamp: 'di 12/23/1998 14:55'!
uncachePageSorter
	pages do: [:aPage | aPage removeProperty: #cachedThumbnail].! !


!BookMorph methodsFor: 'copying' stamp: 'tk 8/13/97 15:00'!
copyRecordingIn: dict
	"Overridden to copy the pages of this book as well."

	| new |
	new _ super copyRecordingIn: dict.
	new pages: (pages collect: [:pg |
		"the current page was copied with the submorphs"
		(dict includesKey: pg)
			ifTrue: [dict at: pg]  "current page; already copied"
			ifFalse: [pg copyRecordingIn: dict]]).
	^ new
! !

!BookMorph methodsFor: 'copying' stamp: 'jm 7/1/97 17:06'!
updateReferencesUsing: aDictionary

	super updateReferencesUsing: aDictionary.
	pages do: [:page |
		page allMorphsDo: [:m | m updateReferencesUsing: aDictionary]].
! !


!BookMorph methodsFor: 'other' stamp: 'tk 12/15/1998 14:32'!
abandon
	"Like delete, but we really intend not to use this morph again.  Make the page cache release the page object."

	| pg |
	self delete.
	pages do: [:aPage |
		(pg _ aPage sqkPage) ifNotNil: [
			pg contentsMorph == aPage ifTrue: [
					pg contentsMorph: nil]]].! !

!BookMorph methodsFor: 'other' stamp: 'RAA 8/23/2000 13:02'!
adjustCurrentPageForFullScreen

	self isInFullScreenMode ifTrue: [
		(currentPage hasProperty: #sizeWhenNotFullScreen) ifFalse: [
			currentPage setProperty: #sizeWhenNotFullScreen toValue: currentPage extent.
		].
		currentPage extent: Display extent.
	] ifFalse: [
		(currentPage hasProperty: #sizeWhenNotFullScreen) ifTrue: [
			currentPage extent: (currentPage valueOfProperty: #sizeWhenNotFullScreen).
			currentPage removeProperty: #sizeWhenNotFullScreen.
		].
	].! !

!BookMorph methodsFor: 'other' stamp: 'sw 10/2/97 15:22'!
configureForKids
	super configureForKids.
	pages do:
		[:aPage | aPage configureForKids].! !

!BookMorph methodsFor: 'other' stamp: 'ar 9/14/2000 16:46'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	^ currentPage notNil and:
		[aSubMorph hasOwner: currentPage]
	! !

!BookMorph methodsFor: 'other' stamp: 'RAA 8/23/2000 12:43'!
exitFullScreen

	| floater |

	self isInFullScreenMode ifFalse: [^self].
	self setProperty: #fullScreenMode toValue: false.
	floater _ self valueOfProperty: #floatingPageControls ifAbsent: [nil].
	floater ifNotNil: [
		floater delete.
		self removeProperty: #floatingPageControls.
	].
	self position: 0@0.
	self adjustCurrentPageForFullScreen.
! !

!BookMorph methodsFor: 'other' stamp: 'RAA 8/23/2000 12:42'!
goFullScreen

	| floater |

	self isInFullScreenMode ifTrue: [^self].
	self setProperty: #fullScreenMode toValue: true.
	self position: (currentPage topLeft - self topLeft) negated.
	self adjustCurrentPageForFullScreen.
	floater _ self buildFloatingPageControls.
	self setProperty: #floatingPageControls toValue: floater.
	floater openInWorld.
! !

!BookMorph methodsFor: 'other' stamp: 'RAA 8/23/2000 11:58'!
isInFullScreenMode

	^self valueOfProperty: #fullScreenMode ifAbsent: [false]! !

!BookMorph methodsFor: 'other' stamp: 'ar 11/9/2000 20:38'!
makeMinimalControlsWithColor: aColor title: aString

	| aButton aColumn aRow but |
	aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0.
	aColumn _ AlignmentMorph newColumn.
	aColumn color: aButton color; borderWidth: 0; layoutInset: 0.
	aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

	aRow _ AlignmentMorph newRow.
	aRow color: aButton color; borderWidth: 0; layoutInset: 0.
	aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	aRow addTransparentSpacerOfSize: 40@0.
	aRow addMorphBack: (but _ aButton fullCopy label: ' < ' ; actionSelector: #previousPage).
		"fullCopy is OK, since we just made it and it can't own any Players"
	but setBalloonText: 'Go to previous page'.
	aRow addTransparentSpacerOfSize: 82@0.
	aRow addMorphBack: (StringMorph contents: aString) lock.
	aRow addTransparentSpacerOfSize: 82@0.
	aRow addMorphBack: (but _ aButton fullCopy label: ' > ' ; actionSelector: #nextPage).
	but setBalloonText: 'Go to next page'.
	aRow addTransparentSpacerOfSize: 40@0.

	aColumn addMorphBack: aRow.

	aColumn setNameTo: 'Page Controls'.
	
	^ aColumn! !

!BookMorph methodsFor: 'other' stamp: 'tk 10/22/1998 15:42'!
releaseCachedState
	"Release the cached state of all my pages."

	super releaseCachedState.
	pages do: [:page | page fullReleaseCachedState].
! !

!BookMorph methodsFor: 'other' stamp: 'sw 10/1/1998 13:40'!
resizePagesTo: anExtent
	pages do:
		[:aPage | aPage extent: anExtent]! !

!BookMorph methodsFor: 'other' stamp: 'sw 8/11/1998 16:50'!
succeededInRevealing: aPlayer
	currentPage ifNotNil: [currentPage player == aPlayer ifTrue: [^ true]].
	pages do:
		[:aPage |
			(aPage succeededInRevealing: aPlayer) ifTrue:
				[self goToPageMorph: aPage.
				^ true]].
	^ false! !

!BookMorph methodsFor: 'other' stamp: 'RAA 12/26/2000 14:31'!
wrappedInPartsWindowWithTitle: aTitle
	| aWindow |

	self fullBounds.
	aWindow _ (PartsWindow labelled: aTitle) model: Model new.
	aWindow book: self.
	^ aWindow! !



!BookMorph methodsFor: 'drawing' stamp: 'mpw 9/13/1999 20:22'!
fullDrawPostscriptOn:aCanvas
	^aCanvas fullDrawBookMorph:self.
! !


!BookMorph methodsFor: 'printing'!
asPostscript
	^self asPostscriptPrintJob.
! !

!BookMorph methodsFor: 'printing' stamp: 'RAA 2/1/2001 17:41'!
pagesHandledAutomatically

	^true! !

!BookMorph methodsFor: 'printing' stamp: 'di 9/22/1999 10:51'!
printPSToFile
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName _ ('MyBook') asFileName.
	fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' 
			initialAnswer: fileName.
	fileName size == 0 ifTrue: [^ self beep].
	(fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps'].

	rotateFlag _ ((PopUpMenu labels:
'portrait (tall)
landscape (wide)')
			startUpWithCaption: 'Choose orientation...') = 2.

	(FileStream newFileNamed: fileName)
		nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close.

! !


!BookMorph methodsFor: 'scripting' stamp: 'tk 9/7/2000 15:10'!
chooseAndRevertToVersion
	| time which |
	"Let the user choose an older version for all code in MethodMorphs in this book.  Run through that code and revert each one to that time."

	self methodHolders.	"find them in me"
	self methodHolderVersions.
	which _ PopUpMenu withCaption: 
					'Put all scripts in this book back 
the way they were at this time:' 
				chooseFrom: #('leave as is'), VersionNames.
	which <= 1 ifTrue: [^ self].
	time _ VersionTimes at: which-1.
	self revertToCheckpoint: time.! !

!BookMorph methodsFor: 'scripting' stamp: 'tk 9/8/2000 14:42'!
installRollBackButtons
	| all |
	"In each script in me, put a versions button it the upper right."

	all _ IdentitySet new.
	self allMorphsAndBookPagesInto: all.
	all _ all select: [:mm | mm class = MethodMorph].
	all do: [:mm | mm installRollBackButtons: self].! !

!BookMorph methodsFor: 'scripting' stamp: 'tk 9/6/2000 23:31'!
methodHolderVersions
	| arrayOfVersions vTimes strings |
	"Create lists of times of older versions of all code in MethodMorphs in this book."

	arrayOfVersions _ MethodHolders collect: [:mh | 
		mh versions].	"equality, hash for MethodHolders?"
	vTimes _ SortedCollection new.
	arrayOfVersions do: [:versionBrowser |  
		versionBrowser changeList do: [:cr | 
			(strings _ cr stamp findTokens: ' ') size > 2 ifTrue: [
				vTimes add: strings second asDate asSeconds + 
						strings third asTime asSeconds]]].
	VersionTimes _ Time condenseBunches: vTimes.
	VersionNames _ Time namesForTimes: VersionTimes.
! !

!BookMorph methodsFor: 'scripting' stamp: 'tk 9/8/2000 14:41'!
methodHolders
	| all |
	"search for all scripts that are in MethodHolders.  These are the ones that have versions."

	all _ IdentitySet new.
	self allMorphsAndBookPagesInto: all.
	all _ all select: [:mm | mm class = MethodMorph].
	MethodHolders _ all asArray collect: [:mm | mm model].

! !

!BookMorph methodsFor: 'scripting' stamp: 'tk 9/7/2000 15:08'!
revertToCheckpoint: secsSince1901
	| cngRecord |
	"Put all scripts (that appear in MethodPanes) back to the way they were at an earlier time."

	MethodHolders do: [:mh | 
		cngRecord _ mh versions versionFrom: secsSince1901.
		cngRecord ifNotNil: [
			(cngRecord stamp: Utilities changeStamp) fileIn]].
		"does not delete method if no earlier version"

! !

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

BookMorph class
	instanceVariableNames: ''!

!BookMorph class methodsFor: 'scripting' stamp: 'sw 9/8/2000 15:24'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((#'book navigation'
			((command goto: 'go to the given page' player)
			(command nextPage 'go to next page')
			(command previousPage 'go to previous page')
			(command firstPage 'go to first page')
			(command lastPage 'go to last page'))))! !

!BookMorph class methodsFor: 'scripting' stamp: 'sw 3/6/1999 01:21'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| book |
	book _ self new markAsPartsDonor.
	book removeEverything; pageSize: 360@228; color: (Color gray: 0.9).
	book borderWidth: 1; borderColor: Color black.
	book beSticky.
	book showPageControls; insertPage.
	^ book! !


!BookMorph class methodsFor: 'url' stamp: 'tk 1/13/1999 09:07'!
alreadyInFromUrl: aUrl
	"Does a bookMorph living in some world in this image represent the same set of server pages? If so, don't create another one.  It will steal pages from the existing one.  Go delete the first one."
	
	self withAllSubclassesDo: [:cls |
		cls allInstancesDo: [:aBook | 
			 (aBook valueOfProperty: #url) = aUrl ifTrue: [
				aBook world ifNotNil: [
					self inform: 'This book is already open in some project'.
					^ true]]]].
	^ false! !

!BookMorph class methodsFor: 'url' stamp: 'sma 4/30/2000 10:36'!
grabURL: aURLString
	"Create a BookMorph for this url and put it in the hand."

	| book |
	book _ self new fromURL: aURLString.
	"If this book is already in, we will steal the pages out of it!!!!!!!!"
	book goToPage: 1.	"install it"
	HandMorph attach: book! !

!BookMorph class methodsFor: 'url' stamp: 'tk 3/28/2000 13:30'!
isInWorld: aWorld withUrl: aUrl
	| urls bks short |
	"If a book with this url is in the that (current) world, return it.  Say if it is out or in another world."

	urls _ OrderedCollection new.
	bks _ OrderedCollection new.
	aWorld allMorphsDo: [:aBook | (aBook isKindOf: BookMorph) ifTrue: [
			bks add: aBook.
			 (urls add: (aBook valueOfProperty: #url)) = aUrl ifTrue: [
				aBook world == aWorld 
					ifTrue: [^ aBook]]]]. 	"shortcut"
		
	self withAllSubclassesDo: [:cls |
		cls allInstancesDo: [:aBook | 
			 (aBook valueOfProperty: #url) = aUrl ifTrue: [
				aBook world == aWorld 
					ifTrue: [^ aBook]
					ifFalse: [
						self inform: 'Book may be open in some other project'.
						^ aBook]]]].

	"if same book name, use it"
	short _ (aUrl findTokens: '/') last.
	urls withIndexDo: [:kk :ind | (kk findTokens: '/') last = short ifTrue: [
			^ bks at: ind]].
	^ #out! !


!BookMorph class methodsFor: 'booksAsProjects' stamp: 'RAA 11/10/2000 11:26'!
makeBookOfProjects: aListOfProjects named: aString
"
BookMorph makeBookOfProjects: (Project allProjects select: [ :each | each world isMorph])
"
	| book pvm page |

	book _ self new.
	book setProperty: #transitionSpec toValue: {'silence'. #none. #none}.
	aListOfProjects do: [ :each |
		pvm _ ProjectViewMorph on: each.
		page _ PasteUpMorph new addMorph: pvm; extent: pvm extent.
		book insertPage: page pageSize: page extent
	].
	book goToPage: 1.
	book deletePageBasic.
	book setProperty: #nameOfThreadOfProjects toValue: aString.
	book removeProperty: #transitionSpec.
	book openInWorld! !
AlignmentMorph subclass: #BookPageSorterMorph
	instanceVariableNames: 'book pageHolder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Books'!

!BookPageSorterMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:36'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals."

super veryDeepFixupWith: deepCopier.
book _ deepCopier references at: book ifAbsent: [book].
! !

!BookPageSorterMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:36'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"book _ book.		Weakly copied"
pageHolder _ pageHolder veryDeepCopyWith: deepCopier.! !


!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 6/17/1998 21:27'!
acceptSort

	book acceptSortedContentsFrom: pageHolder.
	self delete.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:11'!
addControls

	| b r aButton str |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0.
	r wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (self wrapperFor: (b fullCopy label: 'Okay';	actionSelector: #acceptSort)).
	r addMorphBack: (self wrapperFor: (b fullCopy label: 'Cancel';	actionSelector: #delete)).

	r addTransparentSpacerOfSize: 8 @ 0.
	r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)).
	aButton
		target: self;
		actionSelector: #togglePartsBinStatus;
		arguments: #();
		getSelector: #getPartsBinStatus.
	str _ StringMorph contents: 'Parts bin'.
	r addMorphBack: (self wrapperFor: str lock).

	self addMorphFront: r.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/8/2000 22:49'!
book: aBookMorph morphsToSort: morphList

	| innerBounds |
	book _ aBookMorph.
	pageHolder removeAllMorphs.
	pageHolder addAllMorphs: morphList.
	pageHolder extent: pageHolder width@pageHolder fullBounds height.
	innerBounds _ Rectangle merging: (morphList collect: [:m | m bounds]).
	pageHolder extent: innerBounds extent + pageHolder borderWidth + 6.! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/2000 12:10'!
changeExtent: aPoint

	self extent: aPoint.
	pageHolder extent: self extent - borderWidth.

! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:11'!
closeButtonOnly
	"Replace my default control panel with one that has only a close button."

	| b r |
	self firstSubmorph delete.  "remove old control panel"
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r wrapCentering: #topLeft.
	r addMorphBack: (b fullCopy label: 'Close'; actionSelector: #delete).
	self addMorphFront: r.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:11'!
columnWith: aMorph

	^AlignmentMorph newColumn
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #topCenter;
		layoutInset: 1;
		addMorph: aMorph
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'di 1/8/1999 16:27'!
forBook: aBookMorph 

	^ self book: aBookMorph
		morphsToSort: (aBookMorph pages collect: [:p | p thumbnailForPageSorter])! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 11:57'!
getPartsBinStatus

	^pageHolder isPartsBin! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 16:45'!
initialize

	super initialize.
	self extent: Display extent - 100;
		listDirection: #topToBottom;
		wrapCentering: #topLeft;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 3;
		color: Color lightGray;
		borderWidth: 2.
	pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent - borderWidth.
	pageHolder hResizing: #shrinkWrap.
	pageHolder cursor: 0.
	self addControls.
	self addMorphBack: pageHolder.
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/17/97 16:46'!
pageHolder

	^ pageHolder
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:11'!
rowWith: aMorph

	^AlignmentMorph newColumn
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		wrapCentering: #center;
		cellPositioning: #topCenter;
		layoutInset: 1;
		addMorph: aMorph
! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 11:58'!
togglePartsBinStatus

	pageHolder isPartsBin: pageHolder isPartsBin not! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph "only into worlds"! !

!BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 12:10'!
wrapperFor: aMorph

	^self columnWith: (self rowWith: aMorph)
! !
SketchMorph subclass: #BookPageThumbnailMorph
	instanceVariableNames: 'page pageNumber bookMorph flipOnClick '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Books'!
!BookPageThumbnailMorph commentStamp: '<historical>' prior: 0!
A small picture representing a page of a BookMorph here or somewhere else.  When clicked, make that book turn to the page and do a visual effect and a noise.

page			either the morph of the page, or a url
pageNumber
bookMorph		either the book, or a url
flipOnClick!


!BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:37'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  It would be bad to write a whole BookMorph out.  Store a string that is the url of the book or page in my inst var."

	| clone bookUrl bb stem ind |
	(bookMorph class == String) & (page class == String) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph == nil) & (page class == String) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph == nil) & (page url ~~ nil) ifTrue: [
		^ super objectForDataStream: refStrm].
	(bookMorph == nil) & (page url == nil) ifTrue: [
		self error: 'page should already have a url'.
		"find page's book, and remember it"
		"bookMorph _ "].
	
	clone _ self clone.
	(bookUrl _ bookMorph url)
		ifNil: [bookUrl _ self valueOfProperty: #futureUrl].
	bookUrl 
		ifNil: [	bb _ RectangleMorph new.	"write out a dummy"
			bb bounds: bounds.
			refStrm replace: self with: bb.
			^ bb]
		ifNotNil: [clone instVarNamed: 'bookMorph' put: bookUrl].

	page url ifNil: [
			"Need to assign a url to a page that will be written later.
			It might have bookmarks too.  Don't want to recurse deeply.  
			Have that page write out a dummy morph to save its url on the server."
		stem _ SqueakPage stemUrl: bookUrl.
		ind _ bookMorph pages identityIndexOf: page.
		page reserveUrl: stem,(ind printString),'.sp'].
	clone instVarNamed: 'page' put: page url.
	refStrm replace: self with: clone.
	^ clone! !

!BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'tk 2/24/1999 15:00'!
objectsInMemory
	"See if page or bookMorph need to be brought in from a server."
	| bookUrl bk wld try |
	bookMorph ifNil: ["fetch the page"
		page class == String ifFalse: [^ self].	"a morph"
		try _ (SqueakPageCache atURL: page) fetchContents.
		try ifNotNil: [page _ try].
		^ self].
	bookMorph class == String ifTrue: [
		bookUrl _ bookMorph.
		(wld _ self world) ifNil: [wld _ Smalltalk currentWorld].
		bk _ BookMorph isInWorld: wld withUrl: bookUrl.
		bk == #conflict ifTrue: [
			^ self inform: 'This book is already open in some other project'].
		bk == #out ifTrue: [
			(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]].
		bookMorph _ bk].
	page class == String ifTrue: [
		page _ (bookMorph pages detect: [:pg | pg url = page] 
					ifNone: [bookMorph pages at: 1])].
! !


!BookPageThumbnailMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 19:35'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
page _ deepCopier references at: page ifAbsent: [page].
bookMorph _ deepCopier references at: bookMorph ifAbsent: [bookMorph].
! !

!BookPageThumbnailMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:35'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"page _ page.		Weakly copied"
pageNumber _ pageNumber veryDeepCopyWith: deepCopier.
"bookMorph _ bookMorph.		All weakly copied"
flipOnClick _ flipOnClick veryDeepCopyWith: deepCopier. ! !


!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:57'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'make a flex morph' selector: #makeFlexMorphFor: argument: aHandMorph.
	flipOnClick
		ifTrue: [aCustomMenu add: 'disable bookmark action' action: #toggleBookmark]
		ifFalse: [aCustomMenu add: 'enable bookmark action' action: #toggleBookmark].
	(bookMorph isKindOf: BookMorph)
		ifTrue:
			[aCustomMenu add: 'set page sound' action: #setPageSound:.
			aCustomMenu add: 'set page visual' action: #setPageVisual:]
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:50'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	t > rightTime ifTrue: [^ self].  
	t < leftTime ifTrue: [^ self].

	morphList add: (self left: (pianoRoll xForTime: t)).
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 11:12'!
bookMorph

	^bookMorph! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 00:01'!
computeThumbnail
	| f scale |
	self objectsInMemory.
	f _ page imageForm.
	scale _ (self height / f height).  "keep height invariant"
"(Sensor shiftPressed) ifTrue: [scale _ scale * 1.4]."
	self form: (f magnify: f boundingBox by: scale@scale smoothing: 2).

! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 13:24'!
doPageFlip
	"Flip to this page"

	self objectsInMemory.
	bookMorph ifNil: [^ self].
	bookMorph goToPageMorph: page
			transitionSpec: (self valueOfProperty: #transitionSpec).
	(owner isKindOf: PasteUpMorph) ifTrue:
		[owner cursor: (owner submorphs indexOf: self ifAbsent: [1])]! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:57'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick
	"Flip to this page with no extra sound"
	BookMorph turnOffSoundWhile: [self doPageFlip]! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:19'!
handlesMouseDown: event

	^ event shiftPressed or: [flipOnClick and: [event controlKeyPressed not]]! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:52'!
inBook: book
	bookMorph _ book! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:45'!
initialize
	| f |
	super initialize.
	flipOnClick _ false.
	color _ Color lightGray.  "background color"
	f _ Form extent: 60@80 depth: Display depth.
	f fill: f boundingBox fillColor: color.
	self form: f.
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 19:03'!
justDroppedIntoPianoRoll: pianoRoll event: evt
	
	| ambientEvent startTimeInScore |
	startTimeInScore _ pianoRoll timeForX: self left.

	ambientEvent _ AmbientEvent new 
		morph: self;
		time: startTimeInScore.

	pianoRoll score addAmbientEvent: ambientEvent.

	"self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
		[pianoRoll scorePlayer updateDuration]"
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/6/2000 16:36'!
makeFlexMorphFor: aHand

	aHand grabMorph: (FlexMorph new originalMorph: page)! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'tk 3/10/1999 11:25'!
mouseDown: event
	"turn the book to that page"

	event setButtons: 0.	"Lie to it.  So mouseUp won't go to menu that may come up 
		during fetch of a page in doPageFlip"
	self doPageFlip.
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/17/97 17:30'!
page

	^ page
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 13:39'!
page: aMorph

	page _ aMorph.
	self computeThumbnail.
	self setNameTo: aMorph externalName.
	page fullReleaseCachedState.
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:48'!
pageMorph: pageMorph inBook: book
	page _ pageMorph.
	bookMorph _ book! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 8/6/1998 23:45'!
pageNumber: n inBook: b
	pageNumber _ n.
	bookMorph _ b! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:28'!
pauseFrom: x! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:29'!
resetFrom: scorePlayer

	"Ignored"! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:30'!
resumeFrom: scorePlayer

	"Ignored"! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/20/1998 17:29'!
setPageSound: event

	^ bookMorph menuPageSoundFor: self event: event! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/20/1998 17:29'!
setPageVisual: event

	^ bookMorph menuPageVisualFor: self event: event! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 8/8/1998 14:06'!
smaller
	self form: (self form copy: (0@0 extent: self form extent//2)).
! !

!BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:53'!
toggleBookmark
	"Enable or disable sensitivity as a bookmark
		enabled means that a normal click will cause a pageFlip
		disabled means this morph can be picked up normally by the hand."

	flipOnClick _ flipOnClick not! !
AlignmentMorph subclass: #BooklikeMorph
	instanceVariableNames: 'pageSize newPagePrototype '
	classVariableNames: 'PageFlipSoundOn '
	poolDictionaries: ''
	category: 'Morphic-Books'!
!BooklikeMorph commentStamp: '<historical>' prior: 0!
A common superclass for BookMorph and WebBookMorph!


!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 5/23/2000 13:07'!
fewerPageControls
	self currentEvent shiftPressed
		ifTrue:
			[self hidePageControls]
		ifFalse:
			[self showPageControls: self shortControlSpecs]! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/8/1999 10:22'!
fullControlSpecs

	^ #(
		spacer
		variableSpacer
		('-'			deletePage		'Delete this page')
		spacer
		( 'Ç'		firstPage		'First page')
		spacer
		( '<' 		previousPage	'Previous page')
		spacer
		('¥'		invokeBookMenu 'Click here to get a menu of options for this book.')
		spacer
		('>'			nextPage		'Next page')
		spacer
		( 'È'		lastPage			'Final page')
		spacer
		('+'			insertPage		'Add a new page after this one')
		variableSpacer
		('×'			fewerPageControls	'Fewer controls')
)! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 7/4/1998 16:12'!
hidePageControls
	"Delete all submorphs answering to the property #pageControl"
	self deleteSubmorphsWithProperty: #pageControl! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'ar 11/9/2000 20:38'!
makePageControlsFrom: controlSpecs
	"From the controlSpecs, create a set of page control and return them -- this method does *not* add the controls to the receiver."

	| c aButton col row b lastGuy |
	c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker].
	aButton _ SimpleButtonMorph new target: self; borderWidth: 1; borderColor: Color veryLightGray; color: c.
	col _ AlignmentMorph newColumn.
	col color: c; borderWidth: 0; layoutInset: 0.
	col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5.

	row _ AlignmentMorph newRow.
	row color: c; borderWidth: 0; layoutInset: 0.
	row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5.
	controlSpecs do: [:spec |
		spec == #spacer
			ifTrue:
				[row addTransparentSpacerOfSize: (10 @ 0)]
			ifFalse:
				[spec == #variableSpacer
					ifTrue:
						[row addMorphBack: AlignmentMorph newVariableTransparentSpacer]
					ifFalse:
						[b _ aButton fullCopy
						label: spec first;
						actionSelector: spec second;
						borderWidth: 0;
	 					setBalloonText: spec third.
						row addMorphBack: b.
						(((lastGuy _ spec last asLowercase) includesSubString: 'menu') or:
								[lastGuy includesSubString: 'designations'])
							ifTrue: [b actWhen: #buttonDown]]]].  "pop up menu on mouseDown"
		col addMorphBack: row.
	^ col! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/8/1999 10:22'!
shortControlSpecs
	^ #(
		spacer
		variableSpacer
		( '<'	previousPage		'Previous page')
		spacer
		('¥'		invokeBookMenu 'Click here to get a menu of options for this book.')
		spacer
		('>'	nextPage			'Next page')
		variableSpacer
		('×'	showMoreControls	'More controls'))! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/2/1999 15:01'!
showPageControls
	self showPageControls: self shortControlSpecs! !

!BooklikeMorph methodsFor: 'page controls' stamp: 'ar 11/9/2000 20:38'!
showPageControls: controlSpecs 
	| spacer pageControls anIndex |
	self hidePageControls.
	anIndex _ (submorphs size > 0 and: [submorphs first hasProperty: #header])
		ifTrue:	[2]
		ifFalse:	[1].
	spacer _ Morph new color: color; extent: 0@10.
	spacer  setProperty: #pageControl toValue: true.
	self privateAddMorph: spacer atIndex: anIndex.

	pageControls _ self makePageControlsFrom: controlSpecs.
	pageControls borderWidth: 0; layoutInset: 4.
	pageControls  setProperty: #pageControl toValue: true.
	pageControls setNameTo: 'Page Controls'.
	pageControls eventHandler: (EventHandler new on: #mouseDown send: #move to: self).
	self privateAddMorph:  pageControls beSticky atIndex: anIndex! !


!BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 17:36'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"This factoring allows subclasses to have different menu yet still use the super call for the rest of the metamenu."

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addBookMenuItemsTo: aCustomMenu hand: aHandMorph! !

!BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 15:39'!
clearNewPagePrototype
	newPagePrototype _ nil
! !

!BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 15:40'!
firstPage
	self goToPage: 1! !

!BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 17:18'!
insertPage
	self insertPageColored: self color! !

!BooklikeMorph methodsFor: 'menu commands' stamp: 'tk 2/25/1999 11:04'!
sortPages
	| sorter |
	sorter _ BookPageSorterMorph new
		book: self morphsToSort: self morphsForPageSorter.
	sorter pageHolder cursor: self pageNumber.
	"Align at bottom right of screen, but leave 20-pix margin."
	self bottom + sorter height < Display height ifTrue: "Place it below if it fits"
		[^ self world addMorphFront: (sorter align: sorter topLeft with: self bottomLeft)].
	self right + sorter width < Display width ifTrue: "Place it below if it fits"
		[^ self world addMorphFront: (sorter align: sorter bottomLeft with: self bottomRight)].
	"Otherwise, place it at lower right of screen"
	self world addMorphFront: (sorter position: Display extent - (20@20) - sorter extent).
! !


!BooklikeMorph methodsFor: 'misc' stamp: 'sw 7/4/1998 15:56'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
	(self hasSubmorphWithProperty: #pageControl)
		ifTrue: [aCustomMenu add: 'hide page controls' action: #hidePageControls]
		ifFalse: [aCustomMenu add: 'show page controls' action: #showPageControls]! !

!BooklikeMorph methodsFor: 'misc' stamp: 'sw 8/11/1998 16:51'!
currentPlayerDo: aBlock
	| aPlayer aPage |
	(aPage _ self currentPage) ifNil: [^ self].
	(aPlayer _ aPage player) ifNotNil:
		[aBlock value: aPlayer]! !

!BooklikeMorph methodsFor: 'misc' stamp: 'ar 10/10/2000 16:09'!
move
	(owner isWorldMorph and:[self isSticky not]) ifTrue: [self activeHand grabMorph: self]! !

!BooklikeMorph methodsFor: 'misc' stamp: 'sw 7/4/1998 15:36'!
pageSize
	^ pageSize
! !

!BooklikeMorph methodsFor: 'misc' stamp: 'sw 7/4/1998 16:51'!
pageSize: aPoint
	pageSize _ aPoint! !

!BooklikeMorph methodsFor: 'misc' stamp: 'sw 2/15/1999 19:17'!
playPageFlipSound: soundName
	self presenter ifNil: [^ self].  "Avoid failures when called too early"
	(Preferences soundsEnabled "user-controllable" and:
		[PageFlipSoundOn])  "mechanism to suppress sounds at init time"
			ifTrue: [self playSoundNamed: soundName].
! !

!BooklikeMorph methodsFor: 'misc' stamp: 'RAA 8/23/2000 12:19'!
showingFullScreenString
	^ self isInFullScreenMode
		ifTrue:
			['exit full screen']
		ifFalse:
			['show full screen']! !

!BooklikeMorph methodsFor: 'misc' stamp: 'sw 5/23/2000 02:16'!
showingPageControlsString
	^ self pageControlsVisible
		ifTrue:
			['hide page controls']
		ifFalse:
			['show page controls']! !


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

BooklikeMorph class
	instanceVariableNames: ''!

!BooklikeMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/4/1998 15:59'!
initialize
	"BooklikeMorph initialize"
	PageFlipSoundOn _ true
! !

!BooklikeMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/4/1998 16:43'!
turnOffSoundWhile: aBlock
	"Turn off page flip sound during the given block."
	| old |
	old _ PageFlipSoundOn.
	PageFlipSoundOn _ false.
	aBlock value.
	PageFlipSoundOn _ old! !
Object subclass: #Boolean
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Boolean commentStamp: '<historical>' prior: 0!
Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False.

Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.!


!Boolean methodsFor: 'logical operations'!
& aBoolean 
	"Evaluating conjunction. Evaluate the argument. Then answer true if 
	both the receiver and the argument are true."

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
eqv: aBoolean 
	"Answer true if the receiver is equivalent to aBoolean."

	^self == aBoolean! !

!Boolean methodsFor: 'logical operations'!
not
	"Negation. Answer true if the receiver is false, answer false if the 
	receiver is true."

	self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
xor: aBoolean 
	"Exclusive OR. Answer true if the receiver is not equivalent to aBoolean."

	^(self == aBoolean) not! !

!Boolean methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR). Evaluate the argument. Then answer true 
	if either the receiver or the argument is true."

	self subclassResponsibility! !


!Boolean methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction. If the receiver is true, answer the value of 
	the argument, alternativeBlock; otherwise answer false without 
	evaluating the argument."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"If the receiver is true (i.e., the condition is true), then the value is the 
	true alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Same as ifTrue:ifFalse:."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"If the receiver is false (i.e., the condition is false), then the value is the 
	false alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
	"If the receiver is true (i.e., the condition is true), then answer the value 
	of the argument trueAlternativeBlock. If the receiver is false, answer the 
	result of evaluating the argument falseAlternativeBlock. If the receiver 
	is a nonBoolean then create an error notification. Execution does not 
	actually reach here because the expression is compiled in-line."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction. If the receiver is false, answer the value of 
	the argument, alternativeBlock; otherwise answer true without 
	evaluating the argument."

	self subclassResponsibility! !


!Boolean methodsFor: 'copying' stamp: 'tk 6/26/1998 11:32'!
clone 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'copying'!
deepCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'copying'!
shallowCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!Boolean methodsFor: 'printing' stamp: 'sw 4/25/1998 12:51'!
basicType
	^ #boolean! !

!Boolean methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	self printOn: aStream! !


!Boolean methodsFor: 'misc' stamp: 'sw 8/20/1999 17:42'!
newTileMorphRepresentative
	^ TileMorph new addArrows; setLiteral: self
! !

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

Boolean class
	instanceVariableNames: ''!

!Boolean class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:31'!
initializedInstance
	^ nil! !

!Boolean class methodsFor: 'instance creation'!
new
	self error: 'You may not create any more Booleans - this is two-valued logic'! !


!Boolean class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:06'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asBooleanValueFrom: anInteger on: aStream ! !

!Boolean class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:05'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToBooleanObjectFrom: aNode on: aStream! !

!Boolean class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToBooleanValueFrom: aNode on: aStream! !

!Boolean class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:08'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asBooleanValueFrom: anInteger! !
ScriptEditorMorph subclass: #BooleanScriptEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!
!BooleanScriptEditor commentStamp: '<historical>' prior: 0!
A ScriptEditor required to hold a Boolean!


!BooleanScriptEditor methodsFor: 'as yet unclassified' stamp: 'jm 5/28/1998 19:17'!
storeCodeOn: aStream indent: tabCount

	((submorphs size > 0) and:
	 [submorphs first submorphs size > 0]) ifTrue: [
			aStream nextPutAll: '(('.
			super storeCodeOn: aStream indent: tabCount.
			aStream nextPutAll: ') ~~ false)'.
			^ self].
	aStream nextPutAll: ' true '.
! !

!BooleanScriptEditor methodsFor: 'as yet unclassified' stamp: 'tk 8/6/1999 14:31'!
tilesFrom: parseTree
	"Fill myself with tiles to corresponding to an existing boolean expression.  parseTree is the MessageNode that is the top of a parse tree."

	| lineOfTiles msgNode | 
	msgNode _ parseTree.
	lineOfTiles _ Array with: (PhraseTileMorph new tilesFrom: msgNode in: self).
	self insertTileRow: lineOfTiles after: 0.	"no row of control buttons"

! !

!BooleanScriptEditor methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2000 00:04'!
wantsDroppedMorph: aMorph event: evt
	((aMorph isKindOf: PhraseTileMorph) and:
		[submorphs size == 1]) ifTrue: [^ false].
	^ aMorph isTileLike and: [aMorph resultType ~~ #command]
! !
TileMorph subclass: #BooleanTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!BooleanTile commentStamp: '<historical>' prior: 0!
A tile whose result type is boolean.!


!BooleanTile methodsFor: 'type' stamp: 'sw 8/5/1998 17:52'!
resultType
	^ #boolean! !
Morph subclass: #BorderedMorph
	instanceVariableNames: 'borderWidth borderColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!

!BorderedMorph methodsFor: 'initialization' stamp: 'sw 11/29/1999 17:35'!
initialize
	super initialize.
	borderColor _ Color black.
	borderWidth _ 2! !


!BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'!
borderColor
	^ borderColor! !

!BorderedMorph methodsFor: 'accessing' stamp: 'jm 5/14/1998 11:07'!
borderColor: colorOrSymbolOrNil

	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor _ colorOrSymbolOrNil.
		self changed].
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'!
borderInset
	self borderColor: #inset! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'!
borderRaised
	self borderColor: #raised! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'!
borderWidth
	^ borderWidth! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/4/1999 09:42'!
borderWidth: anInteger
	borderColor ifNil: [borderColor _ Color black].
	borderWidth _ anInteger max: 0.
	self changed! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:52'!
cornerStyle
	^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:32'!
cornerStyle: aSymbol
	aSymbol == #square
		ifTrue:
			[self removeProperty: #cornerStyle]
		ifFalse:
			[self setProperty: #cornerStyle toValue: aSymbol].
	self changed! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:56'!
couldHaveRoundedCorners
	"subclases unhappy with rounded corners reimplement"

	^ true! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'!
doesBevels
	"To return true means that this object can show bevelled borders, and
	therefore can accept, eg, #raised or #inset as valid borderColors.
	Must be overridden by subclasses that do not support bevelled borders."

	^ true! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:24'!
hasTranslucentColor
	"Answer true if this any of this morph is translucent but not transparent."

	(color isColor and: [color isTranslucentColor]) ifTrue: [^ true].
	(borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true].
	^ false
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'!
toggleCornerRounding
	self cornerStyle == #rounded
		ifTrue: [self useSquareCorners]
		ifFalse: [self useRoundedCorners].
	self changed! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'!
useRoundedCorners
	self cornerStyle: #rounded! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'!
useSquareCorners
	self cornerStyle: #square! !


!BorderedMorph methodsFor: 'drawing' stamp: 'di 3/25/2000 11:13'!
areasRemainingToFill: aRectangle
	(color isColor and: [color isTranslucent]) ifTrue: [^ Array with: aRectangle].
	self wantsRoundedCorners
	ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
				ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)]
				ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]]
	ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]])
				ifTrue: [^ aRectangle areasOutside: self innerBounds]
				ifFalse: [^ aRectangle areasOutside: self bounds]]! !

!BorderedMorph methodsFor: 'drawing' stamp: 'di 3/25/2000 11:13'!
boundsWithinCorners

	^ CornerRounder rectWithinCornersOf: self bounds! !

!BorderedMorph methodsFor: 'drawing' stamp: 'RAA 7/14/2000 09:36'!
drawOn: aCanvas 
	"Draw a rectangle with a solid, inset, or raised border.
	Note: the raised border color is generated from the receiver's own color,
	while the inset border color is generated from the color of its owner.
	This behavior is visually more consistent. Thanks to Hans-Martin Mosner."

	| insetColor |
	borderWidth = 0 ifTrue: [  "no border"
		"Note: This is the hook for border styles.
			When converting to the new borders we'll just put 0 into the borderWidth"
		super drawOn: aCanvas.
		^ self].

	borderColor == #raised ifTrue: [
		"Use a hack for now"
		aCanvas fillRectangle: self bounds fillStyle: self fillStyle.
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: Color transparent
			borderWidth: borderWidth
			topLeftColor: (borderWidth = 1 ifTrue: [color twiceLighter]
										ifFalse: [color lighter])
			bottomRightColor: (borderWidth = 1 ifTrue: [color twiceDarker]
										ifFalse: [color darker])].

	borderColor == #inset ifTrue: [
		insetColor _ owner ifNil: [Color black] ifNotNil: [owner colorForInsets].
		aCanvas fillRectangle: self bounds fillStyle: self fillStyle.
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: Color transparent
			borderWidth: borderWidth
			topLeftColor: (borderWidth = 1 ifTrue: [insetColor twiceDarker]
										ifFalse: [insetColor darker])
			bottomRightColor: (borderWidth = 1 ifTrue: [insetColor twiceLighter]
										ifFalse: [insetColor lighter])].

	"solid color border"
	aCanvas fillRectangle: (self bounds insetBy: borderWidth) fillStyle: self fillStyle.
	aCanvas frameAndFillRectangle: bounds
		fillColor: Color transparent
		borderWidth: borderWidth
		borderColor: borderColor.! !

!BorderedMorph methodsFor: 'drawing' stamp: 'sw 11/29/1999 17:34'!
wantsRoundedCorners
	^ self cornerStyle == #rounded! !


!BorderedMorph methodsFor: 'geometry' stamp: 'di 6/20/97 11:15'!
innerBounds
	^ bounds insetBy: borderWidth! !


!BorderedMorph methodsFor: 'menu' stamp: 'sw 9/6/2000 05:14'!
addCustomMenuItems: aMenu hand: aHandMorph
	super addCustomMenuItems: aMenu hand: aHandMorph.
	self isWorldMorph ifFalse:
		[aMenu addList: 
			#(('border color...' changeBorderColor:)
			('border width...' changeBorderWidth:)).
		self couldHaveRoundedCorners ifTrue:
			[aMenu addUpdating: #roundedCornersString target: self action: #toggleCornerRounding].

		self doesBevels ifTrue:
			[borderColor == #raised ifFalse: [aMenu add: 'raised bevel' action: #borderRaised].
			borderColor == #inset ifFalse: [aMenu add: 'inset bevel' action: #borderInset]]]
! !

!BorderedMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:50'!
changeBorderColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand! !

!BorderedMorph methodsFor: 'menu' stamp: 'ar 10/3/2000 17:04'!
changeBorderWidth: evt
	| handle origin aHand newWidth oldWidth |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	oldWidth _ borderWidth.
	handle _ HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			newWidth _ (newPoint - origin) r asInteger // 5.
			self borderWidth: newWidth]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo doIfNotNil: [:halo | halo addHandles].
			self rememberCommand:
				(Command new cmdWording: 'border change';
					undoTarget: self selector: #borderWidth: argument: oldWidth;
					redoTarget: self selector: #borderWidth: argument: newWidth)].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor farther from
this point to increase border width.
Click when done.' hand: evt hand.
	handle startStepping! !


!BorderedMorph methodsFor: 'printing' stamp: 'di 6/20/97 11:20'!
fullPrintOn: aStream
	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') setBorderWidth: '; print: borderWidth;
		nextPutAll: ' borderColor: ' , (self colorString: borderColor)! !


!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:21'!
setBorderWidth: w borderColor: bc
	self borderWidth: w.
	self borderColor: bc.! !

!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:22'!
setColor: c borderWidth: w borderColor: bc
	self color: c.
	self borderWidth: w.
	self borderColor: bc.! !
Morph subclass: #BouncingAtomsMorph
	instanceVariableNames: 'damageReported infectionHistory transmitInfection recentTemperatures temperature '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!BouncingAtomsMorph commentStamp: '<historical>' prior: 0!
This morph shows how an ideal gas simulation might work. When it gets step messages, it makes all its atom submorphs move along their velocity vectors, bouncing when they hit a wall. It also exercises the Morphic damage reporting and display architecture. Here are some things to try:

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


!BouncingAtomsMorph methodsFor: 'initialization' stamp: 'jm 7/30/97 09:45'!
initialize

	super initialize.
	damageReported _ false.
	self extent: 400@250.
	self color: (Color r: 0.8 g: 1.0 b: 0.8).
	infectionHistory _ OrderedCollection new.
	transmitInfection _ false.
 	self addAtoms: 30.
! !


!BouncingAtomsMorph methodsFor: 'menu' stamp: 'jm 6/28/1998 18:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

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

!BouncingAtomsMorph methodsFor: 'menu' stamp: 'jm 6/28/1998 18:04'!
setAtomCount

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

!BouncingAtomsMorph methodsFor: 'menu'!
startInfection

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


!BouncingAtomsMorph methodsFor: 'stepping' stamp: 'sw 7/15/1999 07:32'!
step
	"Bounce those atoms!!"

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

!BouncingAtomsMorph methodsFor: 'stepping' stamp: 'jm 6/28/1998 18:10'!
stepTime
	"As fast as possible."

	^ 0
! !


!BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 6/28/1998 18:10'!
addAtoms: n
	"Add a bunch of new atoms."

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

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

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

!BouncingAtomsMorph methodsFor: 'other' stamp: 'di 1/4/1999 20:22'!
areasRemainingToFill: aRectangle
	color isTranslucent
		ifTrue: [^ Array with: aRectangle]
		ifFalse: [^ aRectangle areasOutside: self bounds]! !

!BouncingAtomsMorph methodsFor: 'other' stamp: 'ls 10/10/1999 13:59'!
collisionPairs
	"Return a list of pairs of colliding atoms, which are assumed to be
circles of known radius. This version uses the morph's positions--i.e.
the top-left of their bounds rectangles--rather than their centers."

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

!BouncingAtomsMorph methodsFor: 'other'!
drawOn: aCanvas
	"Clear the damageReported flag when redrawn."

	super drawOn: aCanvas.
	damageReported _ false.! !

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

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

!BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 6/28/1998 18:31'!
showInfectionHistory: evt
	"Place a graph of the infection history in the world."

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

!BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 6/28/1998 18:20'!
transmitInfection

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

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

!BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 8/10/1998 18:32'!
updateTemperature: currentTemperature
	"Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged."

	recentTemperatures == nil ifTrue: [
		recentTemperatures _ OrderedCollection new.
		20 timesRepeat: [recentTemperatures add: 0]].

	recentTemperatures removeLast.
	recentTemperatures addFirst: currentTemperature.
	temperature _ recentTemperatures sum asFloat / recentTemperatures size.
! !
ParseNode subclass: #BraceNode
	instanceVariableNames: 'elements sourceLocations emitNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!BraceNode commentStamp: '<historical>' prior: 0!
Used for compiling and decompiling brace constructs.

These now compile into either a fast short form for 4 elements or less:
	Array braceWith: a with: b ... 
or a long form of indefinfite length:
	(Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray.

The erstwhile brace assignment form is no longer supported.!


!BraceNode methodsFor: 'initialize-release'!
elements: collection
	"Decompile."

	elements _ collection! !

!BraceNode methodsFor: 'initialize-release'!
elements: collection sourceLocations: locations
	"Compile."

	elements _ collection.
	sourceLocations _ locations! !

!BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:06'!
matchBraceStreamReceiver: receiver messages: messages

	((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber])
		and: [messages last isMessage: #braceArray receiver: nil arguments: nil])
		ifFalse: [^ nil "no match"].

	"Appears to be a long form brace construct"
	self elements: (messages allButLast collect:
		[:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil)
					ifFalse: [^ nil "not a brace element"].
		msg arguments first])! !

!BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:19'!
matchBraceWithReceiver: receiver selector: selector arguments: arguments

	selector = (self selectorForShortForm: arguments size)
		ifFalse: [^ nil "no match"].

	"Appears to be a short form brace construct"
	self elements: arguments! !


!BraceNode methodsFor: 'testing'!
blockAssociationCheck: encoder
	"If all elements are MessageNodes of the form [block]->[block], and there is at
	 least one element, answer true.
	 Otherwise, notify encoder of an error."

	elements size = 0
		ifTrue: [^encoder notify: 'At least one case required'].
	elements with: sourceLocations do:
			[:x :loc |
			(x 	isMessage: #->
				receiver:
					[:rcvr |
					(rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]]
				arguments:
					[:arg |
					(arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]])
			  ifFalse:
				[^encoder notify: 'Association between 0-argument blocks required' at: loc]].
	^true! !

!BraceNode methodsFor: 'testing'!
numElements

	^ elements size! !


!BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 08:58'!
emitForValue: stack on: aStream

	^ emitNode emitForValue: stack on: aStream! !

!BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'!
selectorForShortForm: nElements

	nElements > 4 ifTrue: [^ nil].
	^ #(braceWithNone braceWith: braceWith:with:
			braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! !

!BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 11:13'!
sizeForValue: encoder

	emitNode _ elements size <= 4
		ifTrue: ["Short form: Array braceWith: a with: b ... "
				MessageNode new
					receiver: (encoder encodeVariable: #Array)
					selector: (self selectorForShortForm: elements size)
					arguments: elements precedence: 3 from: encoder]
		ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray"
				CascadeNode new
					receiver: (MessageNode new
								receiver: (encoder encodeVariable: #Array)
								selector: #braceStream:
								arguments: (Array with: (encoder encodeLiteral: elements size))
								precedence: 3 from: encoder)
					messages: ((elements collect: [:elt | MessageNode new receiver: nil
														selector: #nextPut:
														arguments: (Array with: elt)
														precedence: 3 from: encoder])
								copyWith: (MessageNode new receiver: nil
														selector: #braceArray
														arguments: (Array new)
														precedence: 1 from: encoder))].
	^ emitNode sizeForValue: encoder! !


!BraceNode methodsFor: 'enumerating'!
casesForwardDo: aBlock
	"For each case in forward order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	1 to: (numCases _ elements size) do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]! !

!BraceNode methodsFor: 'enumerating'!
casesReverseDo: aBlock
	"For each case in reverse order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	(numCases _ elements size) to: 1 by: -1 do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]! !


!BraceNode methodsFor: 'printing' stamp: 'di 11/19/1999 09:17'!
printOn: aStream indent: level

	aStream nextPut: ${.
	1 to: elements size do: 
		[:i | (elements at: i) printOn: aStream indent: level.
		i < elements size ifTrue: [aStream nextPutAll: '. ']].
	aStream nextPut: $}! !


!BraceNode methodsFor: 'tiles' stamp: 'di 11/13/2000 21:17'!
asMorphicSyntaxIn: parent

	| row |

	row _ (parent addRow: #brace on: self) layoutInset: 1.
	row addMorphBack: (StringMorph new contents: 
		(String streamContents: [:aStream | self printOn: aStream indent: 0])).
	^row
! !

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

BraceNode class
	instanceVariableNames: ''!

!BraceNode class methodsFor: 'examples' stamp: 'di 11/19/1999 09:05'!
example
	"Test the {a. b. c} syntax."

	| x |
	x _ {1. {2. 3}. 4}.
	^ {x first. x second first. x second last. x last. 5} as: Set

"BraceNode example Set (0 1 2 3 4 5 )"
! !
CodeHolder subclass: #Browser
	instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated '
	classVariableNames: 'RecentClasses '
	poolDictionaries: ''
	category: 'Tools-Browser'!
!Browser commentStamp: '<historical>' prior: 0!
I represent a query path into the class descriptions, the software of the system.!


!Browser methodsFor: 'accessing' stamp: 'sma 6/18/2000 18:14'!
contents
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information. This information is the
	method of the currently selected class and message."
	| comment theClass latestCompiledMethod |
	latestCompiledMethod _ currentCompiledMethod.
	currentCompiledMethod _ nil.

	editSelection == #none ifTrue: [^ ''].
	editSelection == #editSystemCategories 
		ifTrue: [^ systemOrganizer printString].
	editSelection == #newClass 
		ifTrue: [^ (theClass _ self selectedClass)
			ifNil:
				[Class template: self selectedSystemCategoryName]
			ifNotNil:
				[Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]].
	editSelection == #editClass 
		ifTrue: [^ self selectedClassOrMetaClass definitionST80: Preferences printAlternateSyntax not].
	editSelection == #editComment 
		ifTrue: [(theClass _ self selectedClass) ifNil: [^ ''].
				comment _ theClass comment.
				comment size = 0
				ifTrue: [^ 'This class has not yet been commented.']
				ifFalse: [^ comment]].
	editSelection == #hierarchy 
		ifTrue: [^ self selectedClassOrMetaClass printHierarchy].
	editSelection == #editMessageCategories 
		ifTrue: [^ self classOrMetaClassOrganizer printString].
	editSelection == #newMessage
		ifTrue: [^ self selectedClassOrMetaClass sourceCodeTemplate].
	editSelection == #editMessage
		ifTrue:
			[currentCompiledMethod _ latestCompiledMethod.
			^ self selectedMessage].
	editSelection == #byteCodes ifTrue:
		[^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			symbolic asText].

	self error: 'Browser internal error: unknown edit selection.'! !

!Browser methodsFor: 'accessing' stamp: 'sw 9/30/1999 13:19'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be
	 updated. The information can be a variety of things, depending on
	 the list selections (such as templates for class or message definition,
	 methods) or the user menu commands (such as definition, comment,
	 hierarchy).  Answer the result of updating the source."

	| aString aText theClass |
	self changed: #annotation.
	aString _ input asString.
	aText _ input asText.
	editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController].
	editSelection == #editComment
		ifTrue: 
			[theClass _ self selectedClass.
			theClass
				ifNil: 
					[PopUpMenu notify: 'You must select a class
before giving it a comment.'.
					^ false].
			theClass comment: aText stamp: Utilities changeStamp.
			^ true].
	editSelection == #hierarchy ifTrue: [^ true].
	editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString].
	editSelection == #editMessage | (editSelection == #newMessage)
		ifTrue:
			[^ self okayToAccept
				ifFalse:
					[false]
				ifTrue:
					[self compileMessage: aText notifying: aController]].
	editSelection == #none
		ifTrue: 
			[PopUpMenu notify: 'This text cannot be accepted
in this part of the browser.'.
			^ false].
	self error: 'unacceptable accept'! !

!Browser methodsFor: 'accessing' stamp: 'dew 7/28/2000 00:44'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	messageCategoryListIndex > 1 & (messageListIndex = 0) 
		ifTrue: [^ 1 to: 500]	"entire empty method template"
		ifFalse: [^ 1 to: 0]  "null selection"! !

!Browser methodsFor: 'accessing' stamp: 'di 6/21/1998 22:20'!
couldBrowseAnyClass
	"Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name.  This implementation is clearly ugly, but the feature it enables is handsome enough.  3/1/96 sw"

	self dependents
		detect: [:d |
			((d isKindOf: PluggableListView) or: [d isKindOf: PluggableListMorph]) and: 
			[d getListSelector == #systemCategoryList]]
		ifNone: [^ false].
	^ true
! !

!Browser methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:28'!
doItReceiver
	"This class's classPool has been jimmied to be the classPool of the class 
	being browsed. A doIt in the code pane will let the user see the value of 
	the class variables."

	^ self selectedClass ifNil: [FakeClassPool new]! !

!Browser methodsFor: 'accessing'!
editSelection
	^editSelection! !

!Browser methodsFor: 'accessing' stamp: 'sw 12/17/2000 23:24'!
editSelection: aSelection
	"Set the editSelection as requested."

	editSelection _ aSelection! !

!Browser methodsFor: 'accessing' stamp: 'sw 10/30/1999 22:59'!
noteSelectionIndex: anInteger for: aSymbol
	aSymbol == #systemCategoryList
		ifTrue:
			[systemCategoryListIndex _ anInteger].
	aSymbol == #classList
		ifTrue:
			[classListIndex _ anInteger].
	aSymbol == #messageCategoryList
		ifTrue:
			[messageCategoryListIndex _ anInteger].
	aSymbol == #messageList
		ifTrue:
			[messageListIndex _ anInteger].! !

!Browser methodsFor: 'accessing' stamp: 'jm 4/28/1998 05:55'!
request: prompt initialAnswer: initialAnswer

	^ FillInTheBlank
		request: prompt
		initialAnswer: initialAnswer
! !

!Browser methodsFor: 'accessing' stamp: 'sw 1/4/2001 12:24'!
spawn: aString 
	"Create and schedule a fresh browser and place aString in its code pane.  This method is called when the user issues the #spawn command (cmd-o) in any code pane.  Whatever text was in the original code pane comes in to this method as the aString argument; the changes in the original code pane have already been cancelled by the time this method is called, so aString is the only copy of what the user had in his code pane."

	self selectedClassOrMetaClass ifNotNil: [^ super spawn: aString].

	systemCategoryListIndex ~= 0
		ifTrue:
			["This choice is slightly useless but is the historical implementation"
			^ self buildSystemCategoryBrowserEditString: aString].
		
	^ super spawn: aString  
	"This bail-out at least saves the text being spawned, which would otherwise be lost"! !


!Browser methodsFor: 'class functions' stamp: 'sw 1/30/2001 15:52'!
addAllMethodsToCurrentChangeSet
	"Add all the methods in the selected class or metaclass to the current change set.  You ought to know what you're doing before you invoke this!!"

	| aClass |
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[aClass selectors do:
			[:sel |
				Smalltalk changes adoptSelector: sel forClass: aClass].
		self changed: #annotation]
! !

!Browser methodsFor: 'class functions'!
buildClassBrowser
	"Create and schedule a new class category browser for the current class 
	selection, if one exists."

	self buildClassBrowserEditString: nil! !

!Browser methodsFor: 'class functions' stamp: 'sw 12/6/2000 16:32'!
classListMenu: aMenu 
	"For backward compatibility with old browers stored in image segments"

	^ self classListMenu: aMenu shifted: false! !

!Browser methodsFor: 'class functions' stamp: 'sw 1/30/2001 15:46'!
classListMenu: aMenu shifted: shifted
	"Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"

	^ aMenu addList: (shifted
		ifFalse: [#(
			-
			('browse full (b)'			browseMethodFull)
			('browse hierarchy (h)'		spawnHierarchy)
			('browse protocol (p)'		browseFullProtocol)
			-
			('printOut'					printOutClass)
			('fileOut'					fileOutClass)
			-
			('show hierarchy'			hierarchy)
			('show definition'			editClass)
			('show comment'			editComment)
			-
			('inst var refs...'			browseInstVarRefs)
			('inst var defs...'			browseInstVarDefs)
			-
			('class var refs...'			browseClassVarRefs)
			('class vars'					browseClassVariables)
			('class refs (N)'				browseClassRefs)
			-
			('rename class ...'			renameClass)
			('copy class'				copyClass)
			('remove class (x)'			removeClass)
			-
			('find method...'				findMethod)
			-
			('more...'					shiftedYellowButtonActivity))]
		ifTrue: [#(
			-
			('unsent methods'			browseUnusedMethods)
			('unreferenced inst vars'	showUnreferencedInstVars)
			('subclass template'			makeNewSubclass)
			-
			('sample instance'			makeSampleInstance)
			('inspect instances'			inspectInstances)
			('inspect subinstances'		inspectSubInstances)
			-
			('fetch documentation'		fetchClassDocPane)
			('add all meths to current chgs'		addAllMethodsToCurrentChangeSet)
			-
			('more...'					unshiftedYellowButtonActivity))])! !

!Browser methodsFor: 'class functions' stamp: 'dwh 11/23/1999 00:09'!
copyClass
	| originalName copysName class oldDefinition newDefinition |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	originalName _ self selectedClass name.
	copysName _ self request: 'Please type new class name' initialAnswer: originalName.
	copysName = '' ifTrue: [^ self].  " Cancel returns '' "
	copysName _ copysName asSymbol.
	copysName = originalName ifTrue: [^ self].
	(Smalltalk includesKey: copysName)
		ifTrue: [^ self error: copysName , ' already exists'].
	oldDefinition _ self selectedClass definition.
	newDefinition _ oldDefinition copyReplaceAll: '#' , originalName asString with: '#' , copysName asString.
	Cursor wait 
		showWhile: [class _ Compiler evaluate: newDefinition logged: true.
					class copyAllCategoriesFrom: (Smalltalk at: originalName).
					class class copyAllCategoriesFrom: (Smalltalk at: originalName) class].
	self classListIndex: 0.
	self changed: #classList! !

!Browser methodsFor: 'class functions' stamp: 'bf 10/19/2000 11:39'!
defineClass: defString notifying: aController  
	"The receiver's textual content is a request to define a new class. The
	source code is defString. If any errors occur in compilation, notify
	aController."
	| oldClass class newClassName defTokens keywdIx envt |
	oldClass _ self selectedClassOrMetaClass.
	defTokens _ defString findTokens: Character separators.
	keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category'].
	envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $').
	keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x].
	newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
	((oldClass isNil or: [oldClass name asString ~= newClassName])
		and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue:
			["Attempting to define new class over existing one when
				not looking at the original one in this browser..."
			(self confirm: ((newClassName , ' is an existing class in this system.
Redefining it might cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size))
				ifFalse: [^ false]].
	"ar 8/29/1999: Use oldClass superclass for defining oldClass
	since oldClass superclass knows the definerClass of oldClass."
	oldClass ifNotNil:[oldClass _ oldClass superclass].
	class _ oldClass subclassDefinerClass
				evaluate: defString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: [self changed: #classList.
				self classListIndex: 
					(self classList indexOf: 
						((class isKindOf: Metaclass)
							ifTrue: [class soleInstance name]
							ifFalse: [class name])).
				self clearUserEditFlag; editClass.
				^ true]
		ifFalse: [^ false]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'!
editClass
	"Retrieve the description of the class definition."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editClass.
	self changed: #editClass.
	self changed: #contents.
! !

!Browser methodsFor: 'class functions' stamp: 'sw 1/28/1999 22:56'!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editComment.
	self changed: #classSelectionChanged.
	self contentsChanged
! !

!Browser methodsFor: 'class functions'!
explainSpecial: string 
	"Answer a string explaining the code pane selection if it is displaying 
	one of the special edit functions."

	| classes whole lits reply |
	(editSelection == #editClass or: [editSelection == #newClass])
		ifTrue: 
			["Selector parts in class definition"
			string last == $: ifFalse: [^nil].
			lits _ Array with:
				#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
			(whole _ lits detect: [:each | (each keywords
					detect: [:frag | frag = string] ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.']
				ifFalse: [^nil].
			classes _ Smalltalk allClassesImplementing: whole.
			classes _ 'these classes ' , classes printString.
			^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

	editSelection == #hierarchy
		ifTrue: 
			["Instance variables in subclasses"
			classes _ self selectedClassOrMetaClass allSubclasses.
			classes _ classes detect: [:each | (each instVarNames
						detect: [:name | name = string] ifNone: []) ~~ nil]
					ifNone: [^nil].
			classes _ classes printString.
			^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
	editSelection == #editSystemCategories ifTrue: [^nil].
	editSelection == #editMessageCategories ifTrue: [^nil].
	^nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 3/12/1999 18:30'!
fetchClassDocPane
	"Look on servers to see if there is documentation pane for the selected class. Take into account the current update number.  If not, ask the user if she wants to create one."

	DocLibrary external fetchDocSel: '' class: self selectedClassName! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
fileOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .st."

Cursor write showWhile:
		[classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
findMethod
	"Pop up a list of the current class's methods, and select the one chosen by the user.
	5/21/96 sw, based on a suggestion of John Maloney's."
	| aClass selectors reply cat messageCatIndex messageIndex |

	self classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	aClass _ self selectedClassOrMetaClass.
	selectors _ aClass selectors asSortedArray.
	reply _ (SelectionMenu labelList: selectors selections: selectors) startUp.
	reply == nil ifTrue: [^ self].
	cat _ aClass whichCategoryIncludesSelector: reply.
	messageCatIndex _ self messageCategoryList indexOf: cat.
	self messageCategoryListIndex: messageCatIndex.
	messageIndex _ (self messageList indexOf: reply).
	self messageListIndex: messageIndex.
! !

!Browser methodsFor: 'class functions' stamp: 'sw 1/28/1999 12:30'!
hierarchy
	"Display the inheritance hierarchy of the receiver's selected class."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection := #hierarchy.
	self changed: #editComment.
	self contentsChanged.
	^ self! !

!Browser methodsFor: 'class functions' stamp: 'sw 5/4/2000 20:19'!
makeNewSubclass

	self selectedClassOrMetaClass ifNil: [^ self].
	self okToChange ifFalse: [^ self].
	editSelection _ #newClass.
	self contentsChanged! !

!Browser methodsFor: 'class functions' stamp: 'sw 1/5/2001 07:20'!
plusButtonHit
	"Cycle among definition, comment, and hierachy"

	editSelection == #editComment
		ifTrue: [self hierarchy. ^ self].
	editSelection == #hierarchy
		ifTrue: [editSelection := #editClass.
			classListIndex = 0 ifTrue: [^ self].
			self okToChange ifFalse: [^ self].
			self changed: #editComment.
			self contentsChanged.
			^self].
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection := #editComment.
	self changed: #classSelectionChanged.
	self decorateButtons.
	self contentsChanged.! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
printOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .html."

Cursor write showWhile:
		[classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'!
removeClass
	"The selected class should be removed from the system. Use a Confirmer 
	to make certain the user intends this irrevocable command to be carried 
	out."
	| message class className |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	class _ self selectedClass.
	className _ class name.
	message _ 'Are you certain that you
want to delete the class ', className, '?'.
	(self confirm: message) ifTrue: 
			[class subclasses size > 0
				ifTrue: [self notify: 'class has subclasses: ' , message].
			class removeFromSystem.
			self classListIndex: 0].
	self changed: #classList.
! !

!Browser methodsFor: 'class functions' stamp: 'dwh 11/23/1999 00:25'!
renameClass
	| oldName newName obs |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ self request: 'Please type new class name' initialAnswer: oldName.
	newName = '' ifTrue: [^ self].  " Cancel returns '' "
	newName _ newName asSymbol.
	newName = oldName ifTrue: [^ self].
	(Smalltalk includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self selectedClass rename: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
	obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName).
	obs isEmpty ifFalse:
		[Smalltalk browseMessageList: obs
			name: 'Obsolete References to ' , oldName
			autoSelect: oldName].
! !


!Browser methodsFor: 'class list'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	systemCategoryListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! !

!Browser methodsFor: 'class list'!
classListIndex
	"Answer the index of the current class selection."

	^classListIndex! !

!Browser methodsFor: 'class list' stamp: 'dew 7/28/2000 01:10'!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."

	| className |
	classListIndex _ anInteger.
	self setClassOrganizer.
	messageCategoryListIndex _ 1.
	messageListIndex _ 0.
	self classCommentIndicated
		ifTrue: []
		ifFalse: [editSelection _ anInteger = 0
					ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0)
						ifTrue: [#none]
						ifFalse: [#newClass]]
					ifFalse: [#editClass]].
	contents _ nil.
	self selectedClass isNil
		ifFalse: [className _ self selectedClass name.
					(RecentClasses includes: className)
				ifTrue: [RecentClasses remove: className].
			RecentClasses addFirst: className.
			RecentClasses size > 16
				ifTrue: [RecentClasses removeLast]].
	self changed: #classSelectionChanged.
	self changed: #classListIndex.	"update my selection"
	self changed: #messageCategoryList.
	self changed: #messageList.
	self contentsChanged! !

!Browser methodsFor: 'class list' stamp: 'tk 4/5/98 12:25'!
classListSingleton

	| name |
	name _ self selectedClassName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'class list' stamp: 'stp 01/13/2000 12:57'!
recent
	"Let the user select from a list of recently visited classes.  11/96 stp.
	 12/96 di:  use class name, not classes themselves.
	 : dont fall into debugger in empty case"

	| className class recentList |
	recentList _ RecentClasses select: [:n | Smalltalk includesKey: n].
	recentList size == 0 ifTrue: [^ self beep].
	className := (SelectionMenu selections: recentList) startUp.
	className == nil ifTrue: [^ self].
	class := Smalltalk at: className.
	self selectCategoryForClass: class.
	self classListIndex: (self classList indexOf: class name)! !

!Browser methodsFor: 'class list' stamp: 'sr 10/29/1999 20:28'!
selectClass: classNotMeta
	self classListIndex: (self classList indexOf: classNotMeta name)! !

!Browser methodsFor: 'class list' stamp: 'di 12/6/1999 20:41'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	| name envt |
	(name _ self selectedClassName) ifNil: [^ nil].
	(envt _ self selectedEnvironment) ifNil: [^ nil].
	^ envt at: name! !

!Browser methodsFor: 'class list' stamp: 'sw 11/24/1999 14:48'!
selectedClassName
	| aClassList |
	"Answer the name of the current class. Answer nil if no selection exists."

	(classListIndex = 0 or: [classListIndex > (aClassList _ self classList) size]) ifTrue: [^ nil].
	^ aClassList at: classListIndex! !

!Browser methodsFor: 'class list'!
toggleClassListIndex: anInteger 
	"If anInteger is the current class index, deselect it. Else make it the 
	current class selection."

	self classListIndex: 
		(classListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'code pane' stamp: 'sw 5/26/1999 23:43'!
compileMessage: aText notifying: aController
	"Compile the code that was accepted by the user, placing the compiled method into an appropriate message category.  Return true if the compilation succeeded, else false."

	| fallBackCategoryIndex fallBackMethodIndex originalSelectorName result |
	self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory
		ifTrue:
			[ "User tried to save a method while the ALL category was selected"
			fallBackCategoryIndex _ messageCategoryListIndex.
			fallBackMethodIndex _ messageListIndex.
			editSelection == #newMessage
				ifTrue:
					[ "Select the 'as yet unclassified' category"
					messageCategoryListIndex _ 0.
					(result _ self defineMessageFrom: aText notifying: aController)
						ifNil:
							["Compilation failure:  reselect the original category & method"
							messageCategoryListIndex _ fallBackCategoryIndex.
							messageListIndex _ fallBackMethodIndex]
						ifNotNil:
							[self setSelector: result]]
				ifFalse:
					[originalSelectorName _ self selectedMessageName.
					self setOriginalCategoryIndexForCurrentMethod.
					messageListIndex _ fallBackMethodIndex _ self messageList indexOf: originalSelectorName.			
					(result _ self defineMessageFrom: aText notifying: aController)
						ifNotNil:
							[self setSelector: result]
						ifNil:
							[ "Compilation failure:  reselect the original category & method"
							messageCategoryListIndex _ fallBackCategoryIndex.
							messageListIndex _ fallBackMethodIndex.
							^ result notNil]].
			self changed: #messageCategoryList.
			^ result notNil]
		ifFalse:
			[ "User tried to save a method while the ALL category was NOT selected"
			^ (self defineMessageFrom: aText notifying: aController) notNil]! !

!Browser methodsFor: 'code pane' stamp: 'sma 5/28/2000 11:03'!
showBytecodes
	"Show or hide the bytecodes of the selected method."

	(messageListIndex = 0 or: [self okToChange not])
		ifTrue: [^ self changed: #flash].
	editSelection == #byteCodes
		ifTrue: [editSelection _ #editMessage]
		ifFalse: [editSelection _ #byteCodes].
	self contentsChanged! !


!Browser methodsFor: 'copying' stamp: 'tk 12/5/1999 17:59'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"systemOrganizer _ systemOrganizer. 	clone has the old value. we share it"
"classOrganizer _ classOrganizer		clone has the old value. we share it"
"metaClassOrganizer 	_ metaClassOrganizer	clone has the old value. we share it"
systemCategoryListIndex _ systemCategoryListIndex veryDeepCopyWith: deepCopier.
classListIndex _ classListIndex veryDeepCopyWith: deepCopier.
messageCategoryListIndex _ messageCategoryListIndex veryDeepCopyWith: deepCopier.
messageListIndex _ messageListIndex veryDeepCopyWith: deepCopier.
editSelection _ editSelection veryDeepCopyWith: deepCopier.
metaClassIndicated _ metaClassIndicated veryDeepCopyWith: deepCopier.
! !


!Browser methodsFor: 'drag and drop' stamp: 'mir 5/23/2000 17:25'!
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 
	"Here we are fetching informations from the dropped transferMorph and 
	             performing the correct action for this drop."

	| srcType success srcBrowser |
	success _ false.
	srcType _ transferMorph dragTransferType.
	srcBrowser _ transferMorph source model.
	srcType == #messageList ifTrue: [success _ self
					acceptMethod: transferMorph passenger value
					messageCategory: srcBrowser selectedMessageCategoryName
					class: transferMorph passenger key
					atListMorph: dstListMorph
					internal: self == srcBrowser
					copy: transferMorph shouldCopy].
	srcType == #classList
		ifTrue: 
			[success _ self
				changeCategoryForClass: transferMorph passenger
				srcSystemCategory: srcBrowser selectedSystemCategoryName
				atListMorph: dstListMorph
				internal: self == srcBrowser
				copy: transferMorph shouldCopy].
	^success!
]style[(67 620 4 223)f1b,f1,f1cblue;b,f1! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:08'!
acceptMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel dstClass: dstClass dstClassOrMeta: dstClassOrMeta srcClassOrMeta: srcClassOrMeta internal: internal copySemantic: copyFlag 
	| success hierarchyChange higher checkForOverwrite |
	(success _ dstClassOrMeta ~~ nil) ifFalse: [^false].
	checkForOverwrite _ dstClassOrMeta selectors includes: methodSel.
	hierarchyChange _ (higher _ srcClassOrMeta inheritsFrom: dstClassOrMeta) | (dstClassOrMeta inheritsFrom: srcClassOrMeta).
	success _ (checkForOverwrite not
				or: [self
						overwriteDialogHierarchyChange: hierarchyChange
						higher: higher
						sourceClassName: srcClassOrMeta name
						destinationClassName: dstClassOrMeta name
						methodSelector: methodSel])
				and: [self
						message: methodSel
						compileInClass: dstClassOrMeta
						fromClass: srcClassOrMeta
						dstMessageCategory: dstMessageCategorySel
						srcMessageCategory: srcMessageCategorySel
						internal: internal
						copySemantic: copyFlag].
	^ success! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:27'!
acceptMethod: methodSel messageCategory: srcMessageCategorySel class: srcClassOrMeta atListMorph: dstListMorph internal: internal copy: copyFlag 
	| success dstClassOrMeta dstClass dstMessageCategorySel |
	dstClass _ self dstClassDstListMorph: dstListMorph.
	dstClassOrMeta _ dstClass
				ifNotNil: [self metaClassIndicated
						ifTrue: [dstClass class]
						ifFalse: [dstClass]].
	dstMessageCategorySel _ self dstMessageCategoryDstListMorph: dstListMorph.
	success _ (dstClassOrMeta notNil
				and: [dstClassOrMeta == srcClassOrMeta])
						ifTrue: ["one class"
							self
								changeMessageCategoryForMethod: methodSel
								dstMessageCategory: dstMessageCategorySel
								srcMessageCategory: srcMessageCategorySel
								insideClassOrMeta: dstClassOrMeta
								internal: internal
								copySemantic: copyFlag]
						ifFalse: ["different classes"
							self
								acceptMethod: methodSel
								dstMessageCategory: dstMessageCategorySel
								srcMessageCategory: srcMessageCategorySel
								dstClass: dstClass
								dstClassOrMeta: dstClassOrMeta
								srcClassOrMeta: srcClassOrMeta
								internal: internal
								copySemantic: copyFlag].
	^ success! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:27'!
changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag 
	"only move semantic"
	| newClassCategory success |
	self flag: #stringSymbolProblem.
	success _ copyFlag not ifFalse: [^ false].
	newClassCategory _ self dstCategoryDstListMorph: dstListMorph.
	(success _ newClassCategory notNil & (newClassCategory ~= class category))
		ifTrue: 
			[class category: newClassCategory.
			self changed: #classList.
			internal ifFalse: [self selectClass: class]].
	^ success! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/23/2000 17:27'!
changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag 
	"only move semantic"
	| success messageCategorySel |
	(success _ copyFlag not) ifFalse: [^ false].
	messageCategorySel _ dstMessageCategorySel ifNil: [srcMessageCategorySel].
	(success _ messageCategorySel notNil & (messageCategorySel ~= '-- all --' asSymbol)
				and: [messageCategorySel ~= srcMessageCategorySel and: [classOrMeta organization categories includes: messageCategorySel]])
		ifTrue: 
			[classOrMeta organization
				classify: methodSel
				under: messageCategorySel
				suppressIfDefault: false.
			self changed: #messageList].
	success & internal not ifTrue: [self setSelector: methodSel].
	^ success! !

!Browser methodsFor: 'drag and drop' stamp: 'sr 4/25/2000 07:12'!
codeTextMorph
	^ self dependents
		detect: [:dep | (dep isKindOf: PluggableTextMorph)
				and: [dep getTextSelector == #contents]]
		ifNone: []! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/16/2000 11:35'!
dragAnimationFor: item transferMorph: transferMorph 
	TransferMorphLineAnimation on: transferMorph! !

!Browser methodsFor: 'drag and drop' stamp: 'len 5/17/2000 12:35'!
dragPassengerFor: item inMorph: dragSource 
	| transferType |
	(dragSource isKindOf: PluggableListMorph)
		ifFalse: [^item].
	transferType _ self dragTransferTypeForMorph: dragSource.
	transferType == #messageList
		ifTrue: [^self selectedClassOrMetaClass->item contents].
	transferType == #classList
		ifTrue: [^self selectedClass].
	^item contents! !

!Browser methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:18'!
dragTransferTypeForMorph: dragSource 
	^(dragSource isKindOf: PluggableListMorph)
		ifTrue: [dragSource getListSelector]! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:26'!
dstCategoryDstListMorph: dstListMorph
	| dropMorph |
	^(dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [(dropMorph _ dstListMorph potentialDropMorph) ifNotNil: [dropMorph contents]]
		ifFalse: [self selectedSystemCategoryName]! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:45'!
dstClassDstListMorph: dstListMorph
	| dropMorph |
	^(dstListMorph getListSelector == #classList)
		ifTrue: [(dropMorph _ dstListMorph potentialDropMorph) ifNotNil: [Smalltalk at: dropMorph contents withBlanksCondensed asSymbol]]
		ifFalse: [dstListMorph model selectedClass]! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:27'!
dstMessageCategoryDstListMorph: dstListMorph
	| dropMorph |
	^dstListMorph getListSelector == #messageCategoryList
		ifTrue: 
			[dropMorph _ dstListMorph potentialDropMorph.
			dropMorph ifNotNil: [dropMorph contents asSymbol]]
		ifFalse: [self selectedMessageCategoryName]! !

!Browser methodsFor: 'drag and drop' stamp: 'mir 5/25/2000 13:47'!
message: messageSel compileInClass: dstClassOrMeta fromClass: srcClassOrMeta dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel internal: internal copySemantic: copyFlag 
	| source messageCategorySel tm success oldOrNoMethod newMethod |
	source _ srcClassOrMeta sourceCodeAt: messageSel.
	messageCategorySel _ dstMessageCategorySel ifNil: [srcMessageCategorySel].
	self selectClass: dstClassOrMeta theNonMetaClass.
	(self messageCategoryList includes: messageCategorySel)
		ifFalse: ["create message category"
			self classOrMetaClassOrganizer addCategory: messageCategorySel].
	self selectMessageCategoryNamed: messageCategorySel.
	tm _ self codeTextMorph.
	tm setText: source.
	tm setSelection: (0 to: 0).
	tm hasUnacceptedEdits: true.
	oldOrNoMethod _ srcClassOrMeta compiledMethodAt: messageSel ifAbsent: [].
	tm accept.
	"compilation successful?"
	newMethod _ dstClassOrMeta compiledMethodAt: messageSel ifAbsent: [].
	success _ newMethod ~~ nil & (newMethod ~~ oldOrNoMethod).
	"	success ifFalse: [TransferMorph allInstances do: [:e | e delete]].            
	 "
	success
		ifTrue: 
			[copyFlag not ifTrue: ["remove old method in move semantic if new exists"
		srcClassOrMeta removeSelector: messageSel].internal
				ifTrue: [self selectClass: srcClassOrMeta]
				ifFalse: [self selectClass: dstClassOrMeta].
			self setSelector: messageSel].
	^ success! !

!Browser methodsFor: 'drag and drop'!
overwriteDialogHierarchyChange: hierarchyChange higher: higherFlag sourceClassName: srcClassName destinationClassName: dstClassName methodSelector: methodSelector 
	| lf success |
	lf _ Character cr asString.
	success _ SelectionMenu
				confirm: 'There is a conflict.' , ' Overwrite' , (hierarchyChange
							ifTrue: [higherFlag
									ifTrue: [' superclass']
									ifFalse: [' subclass']]
							ifFalse: ['']) , ' method' , lf , dstClassName , '>>' , methodSelector , lf , 'by ' , (hierarchyChange
							ifTrue: ['moving']
							ifFalse: ['copying']) , ' method' , lf , srcClassName name , '>>' , methodSelector , ' ?'
				trueChoice: 'Yes, don''t care.'
				falseChoice: 'No, I have changed my opinion.'.
	^ success! !

!Browser methodsFor: 'drag and drop' stamp: 'jcg 11/5/2000 22:23'!
wantsDroppedMorph: transferMorph event: anEvent inMorph: destinationLM 
	"We are only interested in TransferMorphs as wrappers for             
	informations. If their content is really interesting for us, will             
	determined later in >>acceptDroppingMorph:event:."

	| srcType dstType |

	"only want drops on lists (not, for example, on pluggable texts)"
	(destinationLM isKindOf: PluggableListMorph) ifFalse: [^ false].

	srcType _ transferMorph dragTransferType.
	dstType _ destinationLM getListSelector.

	(srcType == #messageList
		and: [dstType == #messageCategoryList or: [dstType == #classList]])
		ifTrue: [^true].
	(srcType == #classList
		and: [dstType == #systemCategoryList])
		ifTrue: [^true].
"			[
			srcLS == #messageList ifTrue: [^ dstLS == #messageList | (dstLS == #messageCategoryList) | (dstLS == #classList)].
			srcLS == #classList ifTrue: [^ dstLS == #classList | (dstLS == #systemCategoryList)]].
"
	^ false! !


!Browser methodsFor: 'initialize-release' stamp: 'JW 2/3/2001 09:45'!
addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset

	| row switchHeight |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		layoutPolicy: ProportionalLayout new.
	switchHeight _ 25.
	row 
		addMorph: aListPane
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@0 corner: 0@switchHeight negated)
		).	

	row 
		addMorph: SubpaneDividerMorph forTopEdge
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@switchHeight negated corner: 0@(1-switchHeight))
		).	

	self 
		addMorphicSwitchesTo: row 
		at: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-switchHeight)  corner: 0@0)
		).

	window 
		addMorph: row
		fullFrame: (
			LayoutFrame 
				fractions: nominalFractions 
				offsets: (0@verticalOffset corner: 0@0)
		).	
	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.

! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/10/2001 11:46'!
addClassAndSwitchesTo: window at: nominalFractions plus: verticalOffset

	^self
		addAListPane: self buildMorphicClassList 
		to: window 
		at: nominalFractions 
		plus: verticalOffset
! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/9/2001 10:39'!
addMorphicSwitchesTo: window at: aLayoutFrame

	window 
		addMorph: (self buildMorphicSwitches borderWidth: 0)
		fullFrame: aLayoutFrame.

! !

!Browser methodsFor: 'initialize-release'!
browserWindowActivated
	"Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes.  The default is to do nothing.  8/5/96 sw"! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 15:22'!
buildClassSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	aSwitchView
		label: 'class';
		window: (0@0 extent: 15@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'di 4/13/1999 13:54'!
buildCommentSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
	aSwitchView
		label: '?' asText allBold;
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 10@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:11'!
buildInstanceClassSwitchView
	| aView aSwitchView instSwitchView comSwitchView |

	aView _ View new model: self.
	aView window: (0 @ 0 extent: 50 @ 8).
	instSwitchView _ self buildInstanceSwitchView.
	aView addSubView: instSwitchView.
	comSwitchView _ self buildCommentSwitchView.
	aView addSubView: comSwitchView toRightOf: instSwitchView.
	aSwitchView _ self buildClassSwitchView.
	aView addSubView: aSwitchView toRightOf: comSwitchView.
	^aView! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'!
buildInstanceSwitchView

	| aSwitchView |
	aSwitchView _ PluggableButtonView
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	aSwitchView
		label: 'instance';
		borderWidthLeft: 0 right: 1 top: 0 bottom: 0;	
		window: (0@0 extent: 25@8);
		askBeforeChanging: true.
	^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'JW 2/2/2001 16:07'!
buildMorphicClassList

	| myClassList |

	myClassList _ PluggableListMorph on: self list: #classList
			selected: #classListIndex changeSelected: #classListIndex:
			menu: #classListMenu:shifted: keystroke: #classListKey:from:.
	myClassList borderWidth: 0.
	myClassList enableDragNDrop: Preferences browseWithDragNDrop.
	myClassList highlightSelector: #highlightClassList:with:.
	^myClassList

! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:58'!
buildMorphicMessageCatList

	| myMessageCatList |
	myMessageCatList _ PluggableMessageCategoryListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu: 
			keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList.
	myMessageCatList enableDragNDrop: Preferences browseWithDragNDrop.
	myMessageCatList highlightSelector: #highlightMessageCategoryList:with:.
	^myMessageCatList
! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:58'!
buildMorphicMessageList

	| aListMorph |

	aListMorph _ PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	aListMorph enableDragNDrop: Preferences browseWithDragNDrop.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	aListMorph highlightSelector: #highlightMessageList:with:.
	^aListMorph

! !

!Browser methodsFor: 'initialize-release' stamp: 'JW 2/3/2001 09:33'!
buildMorphicSwitches

	| instanceSwitch divider1 divider2 commentSwitch classSwitch row aColor |

	instanceSwitch _ PluggableButtonMorph
		on: self
		getState: #instanceMessagesIndicated
		action: #indicateInstanceMessages.
	instanceSwitch
		label: 'instance';
		askBeforeChanging: true;
		borderWidth: 0.
	commentSwitch _ PluggableButtonMorph
		on: self
		getState: #classCommentIndicated
		action: #plusButtonHit.
	commentSwitch
		label: '?' asText allBold;
		askBeforeChanging: true;
		setBalloonText: 'class comment';
		borderWidth: 0.
	classSwitch _ PluggableButtonMorph
		on: self
		getState: #classMessagesIndicated
		action: #indicateClassMessages.
	classSwitch
		label: 'class';
		askBeforeChanging: true;
		borderWidth: 0.
	divider1 := SubpaneDividerMorph vertical.
	divider2 := SubpaneDividerMorph vertical.
	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		addMorphBack: instanceSwitch;
		addMorphBack: divider1;
		addMorphBack: commentSwitch;
		addMorphBack: divider2;
		addMorphBack: classSwitch.

	aColor _ Color colorFrom: self defaultBackgroundColor.
	{instanceSwitch. commentSwitch. classSwitch} do: [:m | 
		m 
			color: aColor;
			onColor: aColor darker offColor: aColor;
			hResizing: #spaceFill;
			vResizing: #spaceFill.
	].

	^ row
! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:58'!
buildMorphicSystemCatList
	| dragNDropFlag myCatList |
	dragNDropFlag _ Preferences browseWithDragNDrop.
	myCatList _ PluggableListMorph on: self list: #systemCategoryList
			selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
			menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:.
	myCatList enableDragNDrop: dragNDropFlag.
	myCatList highlightSelector: #highlightSystemCategoryList:with:.
	^myCatList
! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/4/2001 15:55'!
buildOptionalButtonsView
	"Build the view for the optional buttons (mvc)"

	| aView buttonView offset bWidth bHeight first previousView |
	aView _ View new model: self.
	bHeight _ self optionalButtonHeight.
	aView window: (0 @ 0 extent: 200 @ bHeight).
	offset _ 0.
	first _ true.
	previousView _ nil.
	self optionalButtonPairs do: [:pair |
		buttonView _ PluggableButtonView on: self
			getState: nil
			action: pair second.
		buttonView
			label: pair first asParagraph.
		bWidth _ buttonView label boundingBox width // 2.  "Need something more deterministic."
		buttonView window: (offset@0 extent: bWidth@bHeight).
		offset _ offset + bWidth + 0.
		first
			ifTrue:
				[aView addSubView: buttonView.
				first _ false]
			ifFalse:
				[buttonView borderWidthLeft: 1 right: 0 top: 0 bottom: 0.
				aView addSubView: buttonView toRightOf: previousView]. 
		previousView _ buttonView].
	^ aView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/13/2000 16:45'!
defaultBrowserTitle
	^ 'System Browser'! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightClassList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightMessageCategoryList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightMessageList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:56'!
highlightSystemCategoryList: list with: morphList! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 9/22/1999 17:13'!
methodCategoryChanged
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #annotation.
	self messageListIndex: 0! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/10/2001 11:02'!
openAsMorphClassEditing: editString
	"Create a pluggable version a Browser on just a single class."
	| window dragNDropFlag hSepFrac switchHeight mySingletonClassList |

	window _ (SystemWindow labelled: 'later') model: self.
	dragNDropFlag _ Preferences browseWithDragNDrop.
	hSepFrac _ 0.3.
	switchHeight _ 25.
	mySingletonClassList _ PluggableListMorph on: self list: #classListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #classListMenu:shifted: keystroke: #classListKey:from:.
	mySingletonClassList enableDragNDrop: dragNDropFlag.
	window 
		addMorph: mySingletonClassList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 0.5@0) 
				offsets: (0@0 corner: 0@switchHeight)
		).
	
	self 
		addMorphicSwitchesTo: window 
		at: (
			LayoutFrame 
				fractions: (0.5@0 corner: 1.0@0) 
				offsets: (0@0 corner: 0@switchHeight)
		).

	window 
		addMorph: self buildMorphicMessageCatList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 0.5@hSepFrac) 
				offsets: (0@switchHeight corner: 0@0)
		).

	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0.5@0 corner: 1.0@hSepFrac) 
				offsets: (0@switchHeight corner: 0@0)
		).

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.
	window setUpdatablePanesFrom: #(messageCategoryList messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'ar 1/31/2001 20:55'!
openAsMorphEditing: editString
	"Create a pluggable version of all the morphs for a Browser in Morphic"
	| window hSepFrac |

	hSepFrac _ 0.4.
	window _ (SystemWindow labelled: 'later') model: self.

	window 
		addMorph: self buildMorphicSystemCatList
		frame: (0@0 corner: 0.25@hSepFrac).
	self 
		addClassAndSwitchesTo: window 
		at: (0.25@0 corner: 0.5@hSepFrac)
		plus: 0.
	window 
		addMorph: self buildMorphicMessageCatList
		frame: (0.5@0 extent: 0.25@hSepFrac).
	window addMorph: self buildMorphicMessageList
		frame: (0.75@0 extent: 0.25@hSepFrac).
	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.
	window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/9/2001 11:31'!
openAsMorphMessageEditing: editString
	"Create a pluggable version a Browser that shows just one message"
	| window mySingletonMessageList verticalOffset nominalFractions |
	window _ (SystemWindow labelled: 'later') model: self.

	mySingletonMessageList _ PluggableListMorph on: self list: #messageListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageListMenu:shifted:
			keystroke: #messageListKey:from:.
	mySingletonMessageList enableDragNDrop: Preferences browseWithDragNDrop.
	verticalOffset _ 25.
	nominalFractions _ 0@0 corner: 1@0.
	window 
		addMorph: mySingletonMessageList
		fullFrame: (
			LayoutFrame 
				fractions: nominalFractions 
				offsets: (0@0 corner: 0@verticalOffset)
		).

	verticalOffset _ self addOptionalAnnotationsTo: window at: nominalFractions plus: verticalOffset.
	verticalOffset _ self addOptionalButtonsTo: window  at: nominalFractions plus: verticalOffset.

	window 
		addMorph: (self buildMorphicCodePaneWith: editString)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@verticalOffset corner: 0@0)
		).

	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/10/2001 10:59'!
openAsMorphMsgCatEditing: editString
	"Create a pluggable version a Browser on just a message category."

	| window hSepFrac |
	window _ (SystemWindow labelled: 'later') model: self.
	hSepFrac _ 0.3.
	window 
		addMorph: ((PluggableListMorph on: self list: #messageCatListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageCategoryMenu:) enableDragNDrop: Preferences browseWithDragNDrop)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@0) 
				offsets: (0@0 corner: 0@25)
		).
	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@hSepFrac) 
				offsets: (0@25 corner: 0@0)
		).

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.
	window setUpdatablePanesFrom: #(messageCatListSingleton messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/10/2001 11:31'!
openAsMorphSysCatEditing: editString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window hSepFrac switchHeight mySingletonList nextOffsets |

	window _ (SystemWindow labelled: 'later') model: self.
	hSepFrac _ 0.30.
	switchHeight _ 25.
	mySingletonList _ PluggableListMorph on: self list: #systemCategorySingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:.
 	mySingletonList enableDragNDrop: Preferences browseWithDragNDrop.
	window 
		addMorph: mySingletonList
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@0) 
				offsets: (0@0  corner: 0@switchHeight)
		).	

	self 
		addClassAndSwitchesTo: window 
		at: (0@0 corner: 0.3333@hSepFrac)
		plus: switchHeight.

	nextOffsets _ 0@switchHeight corner: 0@0.
	window 
		addMorph: self buildMorphicMessageCatList
		fullFrame: (
			LayoutFrame 
				fractions: (0.3333@0 corner: 0.6666@hSepFrac) 
				offsets: nextOffsets
		).	

	window 
		addMorph: self buildMorphicMessageList
		fullFrame: (
			LayoutFrame 
				fractions: (0.6666@0 corner: 1@hSepFrac) 
				offsets: nextOffsets
		).	

	self 
		addLowerPanesTo: window 
		at: (0@hSepFrac corner: 1@1) 
		with: editString.

	window setUpdatablePanesFrom: #( classList messageCategoryList messageList).
	^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/24/2001 21:24'!
openEditString: aString
        "Create a pluggable version of all the views for a Browser, including views and controllers."
        | systemCategoryListView classListView 
        messageCategoryListView messageListView browserCodeView topView switchView underPane y optionalButtonsView annotationPane |

        self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString].
        "Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString].
                uncomment-out for testing morphic browser embedded in mvc project"

        topView _ StandardSystemView new model: self.
        topView borderWidth: 1. "label and minSize taken care of by caller"

        systemCategoryListView _ PluggableListView on: self
                list: #systemCategoryList
                selected: #systemCategoryListIndex
                changeSelected: #systemCategoryListIndex:
                menu: #systemCategoryMenu:
                keystroke: #systemCatListKey:from:.
        systemCategoryListView window: (0 @ 0 extent: 50 @ 70).
        topView addSubView: systemCategoryListView.

        classListView _ PluggableListView on: self
                list: #classList
                selected: #classListIndex
                changeSelected: #classListIndex:
                menu: #classListMenu:shifted:
                keystroke: #classListKey:from:.
        classListView window: (0 @ 0 extent: 50 @ 62).
        topView addSubView: classListView toRightOf: systemCategoryListView.

        switchView _ self buildInstanceClassSwitchView.
        switchView borderWidth: 1.
        topView addSubView: switchView below: classListView.

        messageCategoryListView _ PluggableListView on: self
                list: #messageCategoryList
                selected: #messageCategoryListIndex
                changeSelected: #messageCategoryListIndex:
                menu: #messageCategoryMenu:.
        messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
        topView addSubView: messageCategoryListView toRightOf: classListView.

        messageListView _ PluggableListView on: self
                list: #messageList
                selected: #messageListIndex
                changeSelected: #messageListIndex:
                menu: #messageListMenu:shifted:
                keystroke: #messageListKey:from:.
        messageListView window: (0 @ 0 extent: 50 @ 70).
        messageListView menuTitleSelector: #messageListSelectorTitle.
        topView addSubView: messageListView toRightOf: messageCategoryListView.

       self wantsAnnotationPane
                ifTrue:
                        [annotationPane _ PluggableTextView on: self
                                text: #annotation accept: nil
                                readSelection: nil menu: nil.
                        annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
                        topView addSubView: annotationPane below: systemCategoryListView.
                        underPane _ annotationPane.
                        y _ 110 - self optionalAnnotationHeight]
                ifFalse: [
                        underPane _ systemCategoryListView.
                        y _ 110].

        self wantsOptionalButtons ifTrue:
                [optionalButtonsView _ self buildOptionalButtonsView.
                optionalButtonsView borderWidth: 1.
                topView addSubView: optionalButtonsView below: underPane.
                underPane _ optionalButtonsView.
                y _ y - self optionalButtonHeight].

        browserCodeView _ PluggableTextView on: self 
                        text: #contents accept: #contents:notifying:
                        readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        browserCodeView window: (0@0 extent: 200@y).
        topView addSubView: browserCodeView below: underPane.
        aString ifNotNil: [browserCodeView editString: aString.
                        browserCodeView hasUnacceptedEdits: true].
        topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList).

        ^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/24/2001 21:24'!
openMessageCatEditString: aString
        "Create a pluggable version of the views for a Browser that just shows one message category."
        | messageCategoryListView messageListView browserCodeView topView annotationPane underPane y optionalButtonsView |

        self couldOpenInMorphic ifTrue: [^ self openAsMorphMsgCatEditing: aString].

        topView _ (StandardSystemView new) model: self.
        topView borderWidth: 1.
                "label and minSize taken care of by caller"

        messageCategoryListView _ PluggableListView on: self
                list: #messageCatListSingleton
                selected: #indexIsOne 
                changeSelected: #indexIsOne:
                menu: #messageCategoryMenu:.
        messageCategoryListView window: (0 @ 0 extent: 200 @ 12).
        topView addSubView: messageCategoryListView.

        messageListView _ PluggableListView on: self
                list: #messageList
                selected: #messageListIndex
                changeSelected: #messageListIndex:
                menu: #messageListMenu:shifted:
                keystroke: #messageListKey:from:.
        messageListView menuTitleSelector: #messageListSelectorTitle.
        messageListView window: (0 @ 0 extent: 200 @ 70).
        topView addSubView: messageListView below: messageCategoryListView.

        self wantsAnnotationPane
                ifTrue:
                        [annotationPane _ PluggableTextView on: self
                                text: #annotation accept: nil
                                readSelection: nil menu: nil.
                        annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
                        topView addSubView: annotationPane below: messageListView.
                        underPane _ annotationPane.
                        y _ (200 - 12 - 70) - self optionalAnnotationHeight]
                ifFalse:
                        [underPane _ messageListView.
                        y _ (200 - 12 - 70)].

        self wantsOptionalButtons ifTrue:
                [optionalButtonsView _ self buildOptionalButtonsView.
                optionalButtonsView borderWidth: 1.
                topView addSubView: optionalButtonsView below: underPane.
                underPane _ optionalButtonsView.
                y _ y - self optionalButtonHeight].

        browserCodeView _ PluggableTextView on: self 
                        text: #contents accept: #contents:notifying:
                        readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        browserCodeView window: (0@0 extent: 200@y).
        topView addSubView: browserCodeView below: underPane.
        aString ifNotNil: [browserCodeView editString: aString.
                        browserCodeView hasUnacceptedEdits: true].
        topView setUpdatablePanesFrom: #(messageCatListSingleton messageList).
        ^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/24/2001 21:24'!
openMessageEditString: aString
	"Create a pluggable version of the views for a Browser that just shows one message."
	| messageListView browserCodeView topView annotationPane underPane y |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphMessageEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	messageListView _ PluggableListView on: self
		list: #messageListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #messageListMenu:shifted:.
	messageListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: messageListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: messageListView.
			underPane _ annotationPane.
			y _ (200 - 12) - self optionalAnnotationHeight]
		ifFalse:
			[underPane _ messageListView.
			y _ 200 - 12].

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/24/2001 21:24'!
openOnClassWithEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| classListView messageCategoryListView messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphClassEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	classListView _ PluggableListView on: self
		list: #classListSingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #classListMenu:shifted:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 100 @ 12).
	topView addSubView: classListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageCategoryListView below: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView menuTitleSelector: #messageListSelectorTitle.
	messageListView window: (0 @ 0 extent: 100 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	switchView _ self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	switchView 
		window: switchView window 
		viewport: (classListView viewport topRight 
					corner: messageListView viewport topRight).
	topView addSubView: switchView toRightOf: classListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: messageCategoryListView.
			underPane _ annotationPane.
			y _ (200-12-70) - self optionalAnnotationHeight]
		ifFalse:
			[underPane _ messageCategoryListView.
			y _ (200-12-70)].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView _ self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane _ optionalButtonsView.
		y _ y - self optionalButtonHeight].

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].

	topView setUpdatablePanesFrom: #(messageCategoryList messageList).
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 1/24/2001 21:24'!
openSystemCatEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."
	| systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView y annotationPane underPane optionalButtonsView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphSysCatEditing: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	systemCategoryListView _ PluggableListView on: self
		list: #systemCategorySingleton
		selected: #indexIsOne 
		changeSelected: #indexIsOne:
		menu: #systemCatSingletonMenu:
		keystroke: #systemCatSingletonKey:from:.
	systemCategoryListView window: (0 @ 0 extent: 200 @ 12).
	topView addSubView: systemCategoryListView.

	classListView _ PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:shifted:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 67 @ 62).
	topView addSubView: classListView below: systemCategoryListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 66 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	switchView _ self buildInstanceClassSwitchView.
	switchView 
		window: switchView window 
		viewport: (classListView viewport bottomLeft 
					corner: messageCategoryListView viewport bottomLeft).
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView menuTitleSelector: #messageListSelectorTitle.
	messageListView window: (0 @ 0 extent: 67 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	 self wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: switchView.
			y _ 110 - 12 - self optionalAnnotationHeight.
			underPane _ annotationPane]
		ifFalse:
			[y _ 110 - 12.
			underPane _ switchView].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView _ self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane _ optionalButtonsView.
		y _ y - self optionalButtonHeight].

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	topView setUpdatablePanesFrom: #(classList messageCategoryList messageList).
	^ topView! !

!Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:37'!
optionalAnnotationHeight

	^ 10! !

!Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:23'!
optionalButtonHeight

	^ 10! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 12/28/2000 17:42'!
optionalButtonPairs
	"Answer a tuple (formerly pairs) defining buttons, in the format:
			button label
			selector to send
			help message"

	^ #(
	('senders' 			browseSendersOfMessages	'browse senders of...')
	('implementors'		browseMessages				'browse implementors of...')
	('versions'			browseVersions				'browse versions')
	('inheritance'		methodHierarchy			'browse method inheritance
green: sends to super
tan: has override(s)
mauve: both of the above')
	('hierarchy'		classHierarchy				'browse class hierarchy')
	('inst vars'			browseInstVarRefs			'inst var refs...')
	('class vars'			browseClassVarRefs			'class var refs...'))! !

!Browser methodsFor: 'initialize-release' stamp: 'RAA 1/17/2001 14:18'!
optionalButtonRow
	"Answer a row of control buttons"

	| aRow aButton |
	aRow _ AlignmentMorph newRow.
	aRow setNameTo: 'buttonPane'.
	aRow beSticky.
	aRow hResizing: #spaceFill.
	aRow wrapCentering: #center; cellPositioning: #leftCenter.
	aRow clipSubmorphs: true.
	aRow addTransparentSpacerOfSize: (5@0).
	self optionalButtonPairs  do:
			[:tuple |
				aButton _ PluggableButtonMorph
					on: self
					getState: nil
					action: tuple second.
				aButton 
					useRoundedCorners;
					hResizing: #spaceFill;
					vResizing: #spaceFill;
					label: tuple first asString;
					onColor: Color transparent offColor: Color transparent.
				tuple size > 2 ifTrue: [aButton setBalloonText: tuple third].
				aRow addMorphBack: aButton.
				aRow addTransparentSpacerOfSize: (3 @ 0)].
	aRow addMorphBack: self diffButton.
	Preferences sourceCommentToggleInBrowsers ifTrue: [aRow addMorphBack: self sourceOrInfoButton].
	^ aRow! !

!Browser methodsFor: 'initialize-release' stamp: 'm3r 3/5/1999 22:58'!
setClass: aBehavior selector: aSymbol
	"Set the state of a new, uninitialized Browser."

	| isMeta aClass systemCatIndex messageCatIndex |
	aBehavior ifNil: [^ self].
	(aBehavior isKindOf: Metaclass)
		ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance]
		ifFalse: [isMeta _ false. aClass _ aBehavior].
	systemCatIndex _ SystemOrganization categories indexOf: aClass category.
	self systemCategoryListIndex: systemCatIndex.
	self classListIndex:
			((SystemOrganization listAtCategoryNumber: systemCatIndex)
					indexOf: aClass name).
	self metaClassIndicated: isMeta.
	aSymbol ifNil: [^ self].
	messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: messageCatIndex + 1. "<- FIXED offset"
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol)! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 5/26/1999 23:46'!
setSelector: aSymbol
	"Make the receiver point at the given selector, in the currently chosen class"

	| aClass messageCatIndex |
	aSymbol ifNil: [^ self].
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ self].
	messageCatIndex _ aClass organization numberOfCategoryOfElement: aSymbol.
	self messageCategoryListIndex: messageCatIndex + 1.
	messageCatIndex = 0 ifTrue: [^ self].
	self messageListIndex:
			((aClass organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol)! !

!Browser methodsFor: 'initialize-release' stamp: 'sw 11/8/1999 13:36'!
systemCatSingletonKey: aChar from: aView
	^ self messageListKey: aChar from: aView! !

!Browser methodsFor: 'initialize-release'!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super initialize.
	contents _ nil.
	systemOrganizer _ aSystemOrganizer.
	systemCategoryListIndex _ 0.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	metaClassIndicated _ false.
	self setClassOrganizer.
	editSelection _ #none! !


!Browser methodsFor: 'message category functions' stamp: 'mir 5/5/2000 16:02'!
addCategory
	"Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection"
	| labels reject lines cats menuIndex oldIndex newName |
	self okToChange ifFalse: [^ self].
	classListIndex = 0 ifTrue: [^ self].
	labels _ OrderedCollection with: 'new...'.
	reject _ Set new.
	reject
		addAll: self selectedClassOrMetaClass organization categories;
		add: ClassOrganizer nullCategory;
		add: ClassOrganizer default.
	lines _ OrderedCollection new.
	self selectedClassOrMetaClass allSuperclasses do: [:cls |
		cls = Object ifFalse: [
			cats _ cls organization categories reject:
				 [:cat | reject includes: cat].
			cats isEmpty ifFalse: [
				lines add: labels size.
				labels addAll: cats asSortedCollection.
				reject addAll: cats]]].
	newName _ (labels size = 1 or: [
		menuIndex _ (PopUpMenu labelArray: labels lines: lines)
		startUpWithCaption: 'Add Category'.
		menuIndex = 0 ifTrue: [^ self].
		menuIndex = 1])
			ifTrue: [
				self request: 'Please type new category name'
					initialAnswer: 'category name']
			ifFalse: [
				labels at: menuIndex].
	oldIndex _ messageCategoryListIndex.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	self classOrMetaClassOrganizer
		addCategory: newName
		before: (messageCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedMessageCategoryName]).
	self changed: #messageCategoryList.
	self messageCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self classOrMetaClassOrganizer categories size + 1]
			ifFalse: [oldIndex]).
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'SqR 11/16/2000 13:53'!
alphabetizeMessageCategories
	classListIndex = 0 ifTrue: [^ false].
	self okToChange ifFalse: [^ false].
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer sortCategories.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions'!
buildMessageCategoryBrowser
	"Create and schedule a message category browser for the currently 
	selected message category."

	self buildMessageCategoryBrowserEditString: nil! !

!Browser methodsFor: 'message category functions' stamp: 'wod 6/24/1998 02:10'!
buildMessageCategoryBrowserEditString: aString 
	"Create and schedule a message category browser for the currently 
	selected	 message category. The initial text view contains the characters 
	in aString."
	"wod 6/24/1998: set newBrowser classListIndex so that it works whether the
	receiver is a standard or a Hierarchy Browser."

	| newBrowser |
	messageCategoryListIndex ~= 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName).
			newBrowser metaClassIndicated: metaClassIndicated.
			newBrowser messageCategoryListIndex: messageCategoryListIndex.
			newBrowser messageListIndex: messageListIndex.
			Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
				label: 'Message Category Browser (' , 
						newBrowser selectedClassOrMetaClassName , ')']! !

!Browser methodsFor: 'message category functions' stamp: 'sw 1/4/2001 12:05'!
categoryOfCurrentMethod
	"Determine the method category associated with the receiver.  If there is a method currently selected, answer its category.  If no that owns the current method.  Return the category name."

	| aCategory |
	^ super categoryOfCurrentMethod ifNil:
		[(aCategory _ self messageCategoryListSelection) == ClassOrganizer allCategory
					ifTrue:
						[nil]
					ifFalse:
						[aCategory]]! !

!Browser methodsFor: 'message category functions' stamp: 'di 3/28/2000 15:56'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer changeFromString: aString.
	self clearUserEditFlag.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!Browser methodsFor: 'message category functions' stamp: 'sw 1/28/1999 12:30'!
editMessageCategories
	"Indicate to the receiver and its dependents that the message categories of 
	the selected class have been changed."

	self okToChange ifFalse: [^ self].
	classListIndex ~= 0
		ifTrue: 
			[self messageCategoryListIndex: 0.
			editSelection _ #editMessageCategories.
			self changed: #editMessageCategories.
			self contentsChanged]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
fileOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! !

!Browser methodsFor: 'message category functions' stamp: 'sw 10/14/1999 16:53'!
messageCategoryMenu: aMenu

^ aMenu labels:
'browse
printOut
fileOut
reorganize
alphabetize
remove empty categories
new category...
rename...
remove'
	lines: #(3 7)
	selections:
		#(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
		editMessageCategories alphabetizeMessageCategories removeEmptyCategories
		addCategory renameCategory removeMessageCategory)
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
printOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file in Html format."

Cursor write showWhile:
	[messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
										asHtml: true]]! !

!Browser methodsFor: 'message category functions' stamp: 'sma 2/27/2000 10:14'!
removeEmptyCategories
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self selectedClassOrMetaClass organization removeEmptyCategories.
	self changed: #messageCategoryList
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'!
removeMessageCategory
	"If a message category is selected, create a Confirmer so the user can 
	verify that the currently selected message category should be removed
 	from the system. If so, remove it."

	| messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName _ self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?'])
		ifTrue: 
			[self selectedClassOrMetaClass removeCategory: messageCategoryName.
			self messageCategoryListIndex: 0.
			self changed: #classSelectionChanged].
	self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'di 3/28/2000 15:56'!
renameCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self].
	oldName _ self selectedMessageCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	newName = oldName ifTrue: [^ self].
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex.
	self changed: #messageCategoryList.
! !


!Browser methodsFor: 'message category list' stamp: 'tk 4/5/98 12:25'!
messageCatListSingleton

	| name |
	name _ self selectedMessageCategoryName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:56'!
messageCategoryList
	"Answer the selected category of messages."

	classListIndex = 0
		ifTrue: [^ Array new]
		ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list'!
messageCategoryListIndex
	"Answer the index of the selected message category."

	^messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'dew 7/28/2000 01:13'!
messageCategoryListIndex: anInteger 
	"Set the selected message category to be the one indexed by anInteger."

	messageCategoryListIndex _ anInteger.
	messageListIndex _ 0.
	editSelection _ 
		anInteger <= 1
			ifTrue: [#editClass]
			ifFalse: [#newMessage].
	contents _ nil.
	self changed: #messageCategorySelectionChanged.
	self changed: #messageCategoryListIndex.	"update my selection"
	self changed: #messageList.
	self contentsChanged
! !

!Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'!
messageCategoryListSelection
	"Return the selected category name or nil."

	^ ((self messageCategoryList size = 0 
		or: [self messageCategoryListIndex = 0]) 
		or: [self messageCategoryList size < self messageCategoryListIndex])
			ifTrue: [nil]
			ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! !

!Browser methodsFor: 'message category list' stamp: 'sw 10/16/1999 22:56'!
rawMessageCategoryList
	^ classListIndex = 0
		ifTrue: [Array new]
		ifFalse: [self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list' stamp: 'ccn+ceg 2/9/1999 20:25'!
selectMessageCategoryNamed: aSymbol 
	"Given aSymbol, select the category with that name.  Do nothing if 
	aSymbol doesn't exist."
	(self messageCategoryList includes: aSymbol)
		ifFalse: [^ self].
	self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol)! !

!Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:57'!
selectOriginalCategoryForCurrentMethod
	"private - Select the message category for the current method. 
	 
	 Note:  This should only be called when somebody tries to save  
	 a method that they are modifying while ALL is selected. 
	 
	 Returns: true on success, false on failure."
	| aSymbol |
	aSymbol _ self categoryOfCurrentMethod.
	(aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory])
		ifTrue: 
			[self selectMessageCategoryNamed: aSymbol.
			^ true].
	^ false! !

!Browser methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the selected message category, if any. Answer nil 
	otherwise."

	messageCategoryListIndex = 0 ifTrue: [^nil].
	^self messageCategoryList at: messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'ccn+ceg 5/13/1999 19:54'!
setOriginalCategoryIndexForCurrentMethod
	"private - Set the message category index for the currently selected method. 
	 
	 Note:  This should only be called when somebody tries to save  
	 a method that they are modifying while ALL is selected."

	messageCategoryListIndex _ self messageCategoryList indexOf: self categoryOfCurrentMethod
	! !

!Browser methodsFor: 'message category list'!
toggleMessageCategoryListIndex: anInteger 
	"If the currently selected message category index is anInteger, deselect 
	the category. Otherwise select the category whose index is anInteger."

	self messageCategoryListIndex: 
		(messageCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !


!Browser methodsFor: 'message functions' stamp: 'sw 1/11/2001 07:22'!
addExtraShiftedItemsTo: aMenu
	"The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate.  If any is added here, a line should be added first -- browse reimplementors of this message for examples."
! !

!Browser methodsFor: 'message functions'!
browseImplementors
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."

	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]! !

!Browser methodsFor: 'message functions'!
buildMessageBrowser
	"Create and schedule a message browser on the currently selected 
	message. Do nothing if no message is selected. The initial text view 
	contains nothing."

	self buildMessageBrowserEditString: nil! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/6/98 21:47'!
buildMessageBrowserEditString: aString 
	"Create and schedule a message browser for the receiver in which the 
	argument, aString, contains characters to be edited in the text view."

	messageListIndex = 0 ifTrue: [^ self].
	^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass 
		selector: self selectedMessageName editString: aString! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:08'!
defineMessage: aString notifying: aController 
	"Compile the expressions in aString. Notify aController if a syntax error 
	occurs. Install the compiled method in the selected class classified under 
	the currently selected message category name. Answer true if 
	compilation succeeds, false otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ true! !

!Browser methodsFor: 'message functions' stamp: 'di 11/24/1999 13:40'!
defineMessageFrom: aString notifying: aController
	"Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under  the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
	| selectedMessageName selector category oldMessageList |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ (Parser new parseSelector: aString).
	(self metaClassIndicated
		and: [(self selectedClassOrMetaClass includesSelector: selector) not
		and: [Metaclass isScarySelector: selector]])
		ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
				(self confirm: ((selector , ' is used in the existing class system.
Overriding it could cause serious problems.
Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
				ifFalse: [^nil]].
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	selector == nil ifTrue: [^ nil].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self changed: #classList.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageList].
			self messageListIndex: (self messageList indexOf: selector)].
	^ selector! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectInstances
	"Inspect all instances of the selected class.  1/26/96 sw"

	| myClass |
	myClass _ self selectedClassOrMetaClass.
	myClass ~~ nil ifTrue:
		[myClass theNonMetaClass inspectAllInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses  1/26/96 sw"

	| aClass |
	aClass _ self selectedClassOrMetaClass.
	aClass ~~ nil ifTrue:
		[aClass _ aClass theNonMetaClass.
		 aClass inspectSubInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'sw 12/28/2000 17:50'!
messageListMenu: aMenu shifted: shifted
	"Answer the message-list menu"

	shifted ifTrue: [^ self shiftedMessageListMenu: aMenu].

	aMenu addList:#(
			('browse full (b)' 						browseMethodFull)
			('browse hierarchy (h)'					classHierarchy)
			('browse method (O)'					openSingleMessageBrowser)
			('browse protocol (p)'					browseFullProtocol)
			-
			('fileOut'								fileOutMessage)
			('printOut'								printOutMessage)
			-
			('senders of... (n)'						browseSendersOfMessages)
			('implementors of... (m)'					browseMessages)
			('inheritance (i)'						methodHierarchy)
			('tile scriptor'							openSyntaxView)
			('versions (v)'							browseVersions)
			-
			('inst var refs...'						browseInstVarRefs)
			('inst var defs...'						browseInstVarDefs)
			('class var refs...'						browseClassVarRefs)
			('class variables'						browseClassVariables)
			('class refs (N)'							browseClassRefs)
			-
			('remove method (x)'					removeMessage)
			-
			('more...'								shiftedYellowButtonActivity)).
	^ aMenu
! !

!Browser methodsFor: 'message functions' stamp: 'di 5/27/1998 15:45'!
removeMessage
	"If a message is selected, create a Confirmer so the user can verify that 
	the currently selected message should be removed from the system. If so, 
	remove it.  If the Preference 'confirmMethodRemoves' is set to false, the 
	confirmer is bypassed."
	| messageName confirmation |

	messageListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageName _ self selectedMessageName.
	confirmation _ self selectedClassOrMetaClass confirmRemovalOf: messageName.
	confirmation == 3 ifTrue: [^ self].

	self selectedClassOrMetaClass removeSelector: self selectedMessageName.
	self messageListIndex: 0.
	self changed: #messageList.
	self setClassOrganizer.  "In case organization not cached"

	confirmation == 2 ifTrue:
		[Smalltalk browseAllCallsOn: messageName]
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeMessageFromBrowser
	"Our list speaks the truth and can't have arbitrary things removed"

	^ self changed: #flash! !

!Browser methodsFor: 'message functions' stamp: 'sw 1/25/2001 07:24'!
shiftedMessageListMenu: aMenu
	"Fill aMenu with the items appropriate when the shift key is held down"

	aMenu addList: #(
		('method pane' 							makeIsolatedCodePane)
		"('make a scriptor'						makeScriptor)"
		('toggle diffing (D)'						toggleDiffing)
		('implementors of sent messages'			browseAllMessages)
		-
		('spawn sub-protocol'					spawnProtocol)
		('spawn full protocol'					spawnFullProtocol)
		-
		('sample instance'						makeSampleInstance)
		('inspect instances'						inspectInstances)
		('inspect subinstances'					inspectSubInstances)).

	self addExtraShiftedItemsTo: aMenu.
	aMenu addList: #(
		-
		('change category...'					changeCategory)
		-
		('change sets with this method'			findMethodInChangeSets)
		('revert to previous version'				revertToPreviousVersion)
		('remove from current change set'		removeFromCurrentChanges)
		('revert & remove from changes'		revertAndForget)
		('add to current change set'				adoptMessageInCurrentChangeset)
		-
		('fetch documentation'					fetchDocPane)
		('more...' 								unshiftedYellowButtonActivity)).
	^ aMenu
! !


!Browser methodsFor: 'message list' stamp: 'ccn 3/24/1999 10:48'!
messageList
	"Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range.  Otherwise, answer an empty Array  If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero."
	| sel |
	(sel _ self messageCategoryListSelection) ifNil: [^ Array new].
	^ sel = ClassOrganizer allCategory
		ifTrue: 
			[self classOrMetaClassOrganizer
				ifNil:		[Array new]
				ifNotNil:	[self classOrMetaClassOrganizer allMethodSelectors]]
		ifFalse:
			[(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1)
				ifNil: [messageCategoryListIndex _ 0.  Array new]]! !

!Browser methodsFor: 'message list'!
messageListIndex
	"Answer the index of the selected message selector into the currently 
	selected message category."

	^messageListIndex! !

!Browser methodsFor: 'message list' stamp: 'sw 1/5/2001 07:20'!
messageListIndex: anInteger 
	"Set the selected message selector to be the one indexed by anInteger."

	messageListIndex _ anInteger.
	editSelection _ 
		anInteger = 0
			ifTrue: [#newMessage]
			ifFalse: [#editMessage].
	contents _ nil.
	self changed: #messageListIndex.	"update my selection"
	self contentsChanged.
	self decorateButtons! !

!Browser methodsFor: 'message list' stamp: 'tk 4/6/98 10:48'!
messageListSingleton

	| name |
	name _ self selectedMessageName.
	^ name ifNil: [Array new]
		ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message list' stamp: 'sw 12/1/2000 11:17'!
reformulateList
	"If the receiver has a way of reformulating its message list, here is a chance for it to do so"

	super reformulateList.
	self messageListIndex: 0! !

!Browser methodsFor: 'message list' stamp: 'sw 12/5/2000 11:32'!
selectedMessage
	"Answer a copy of the source code for the selected message."

	| class selector method tempNames |
	contents == nil ifFalse: [^ contents copy].
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	method _ class compiledMethodAt: selector ifAbsent: [
		^ ''].	"method deleted while in another project"
	currentCompiledMethod _ method.

	(Sensor controlKeyPressed
		or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])
		ifTrue:
		["Emergency or no source file -- decompile without temp names"
		contents _ (class decompilerClass new decompile: selector in: class method: method)
			decompileString.
		contents _ contents asText makeSelectorBoldIn: class.
		^ contents copy].

	Sensor leftShiftDown ifTrue:
		["Special request to decompile -- get temps from source file"
		tempNames _ (class compilerClass new
						parse: method getSourceFromFile asString in: class notifying: nil)
						tempNames.
		contents _ ((class decompilerClass new withTempNames: tempNames)
				decompile: selector in: class method: method) decompileString.
		contents _ contents asText makeSelectorBoldIn: class.
		^ contents copy].

	self showComment
		ifFalse:
			[contents _ class sourceCodeAt: selector.
			self validateMessageSource: selector.

			Preferences browseWithPrettyPrint ifTrue:
				[contents _ class compilerClass new
					format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting].
			self showDiffs ifTrue:
				[contents _ self diffFromPriorSourceFor: contents].

			contents _ contents asText makeSelectorBoldIn: class]
		ifTrue:
			[contents _ self commentContents].
	^ contents copy! !

!Browser methodsFor: 'message list' stamp: 'sw 10/19/1999 17:39'!
selectedMessageName
	| aList |
	"Answer the message selector of the currently selected message, if any. 
	Answer nil otherwise."

	messageListIndex = 0 ifTrue: [^ nil].
	^ (aList _ self messageList) size >= messageListIndex
		ifTrue:
			[aList at: messageListIndex]
		ifFalse:
			[nil]! !

!Browser methodsFor: 'message list'!
toggleMessageListIndex: anInteger 
	"If the currently selected message index is anInteger, deselect the message 
	selector. Otherwise select the message selector whose index is anInteger."

	self messageListIndex: 
		(messageListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

!Browser methodsFor: 'message list' stamp: 'hg 3/13/2000 12:07'!
validateMessageSource: selector
	(self selectedClass compilerClass == Object compilerClass 
			and: [(contents asString findString: selector keywords first ) ~= 1])
		ifTrue: [
			PopUpMenu notify: 'Possible problem with source file!!

The method source should start with the method selector 
but this is not the case!! You may proceed with caution 
but it is recommended that you get a new source file.

This can happen if you download the "SqueakV2.sources" file, 
or the ".changes" file you use, as TEXT. It must be transfered 
in BINARY mode, even if it looks like a text file, 
to preserve the CR line ends.

Mac users: This may have been caused by Stuffit Expander. 
To prevent the files above to be converted to Mac line ends 
when they are expanded, do this: Start the program, then 
from Preferences... in the File menu, choose the Cross 
Platform panel, then select "Never" and press OK. 
Then expand the compressed archive again.'].! !


!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'!
classCommentIndicated
	"Answer true iff we're viewing the class comment."

	^ editSelection == #editComment 
! !

!Browser methodsFor: 'metaclass' stamp: 'ak 11/24/2000 21:46'!
classMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	metaclass."

	^ self metaClassIndicated and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass'!
classOrMetaClassOrganizer
	"Answer the class organizer for the metaclass or class, depending on 
	which (instance or class) is indicated."

	self metaClassIndicated
		ifTrue: [^metaClassOrganizer]
		ifFalse: [^classOrganizer]! !

!Browser methodsFor: 'metaclass'!
indicateClassMessages
	"Indicate that the message selection should come from the metaclass 
	messages."

	self metaClassIndicated: true! !

!Browser methodsFor: 'metaclass'!
indicateInstanceMessages
	"Indicate that the message selection should come from the class (instance) 
	messages."

	self metaClassIndicated: false! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'!
instanceMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	class."

	^metaClassIndicated not and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'sr 6/21/2000 17:23'!
metaClassIndicated
	"Answer the boolean flag that indicates which of the method dictionaries, 
	class or metaclass."

	^ metaClassIndicated! !

!Browser methodsFor: 'metaclass' stamp: 'sw 1/5/2001 07:20'!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."

	metaClassIndicated _ trueOrFalse.
	self setClassOrganizer.
	systemCategoryListIndex > 0 ifTrue:
		[editSelection _ classListIndex = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass]].
	messageCategoryListIndex _ 1.
	messageListIndex _ 0.
	contents _ nil.
	self changed: #classSelectionChanged.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self changed: #contents.
	self decorateButtons
! !

!Browser methodsFor: 'metaclass' stamp: 'tk 4/9/98 10:48'!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

	| cls |
	self metaClassIndicated
		ifTrue: [^ (cls _ self selectedClass) ifNil: [nil] ifNotNil: [cls class]]
		ifFalse: [^ self selectedClass]! !

!Browser methodsFor: 'metaclass'!
selectedClassOrMetaClassName
	"Answer the selected class name or metaclass name."

	^self selectedClassOrMetaClass name! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:27'!
setClassOrganizer
	"Install whatever organization is appropriate"
	| theClass |
	classOrganizer _ nil.
	metaClassOrganizer _ nil.
	classListIndex = 0 ifTrue: [^ self].
	classOrganizer _ (theClass _ self selectedClass) organization.
	metaClassOrganizer _ theClass class organization.! !


!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:56'!
addSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	oldIndex _ systemCategoryListIndex.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: 'Category-Name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	systemOrganizer
		addCategory: newName
		before: (systemCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedSystemCategoryName]).
	self systemCategoryListIndex:
		(oldIndex = 0
			ifTrue: [systemOrganizer categories size]
			ifFalse: [oldIndex]).
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/6/98 21:09'!
browseAllClasses
	"Create and schedule a new browser on all classes alphabetically."
	| newBrowser |
	newBrowser _ HierarchyBrowser new initAlphabeticListing.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: 'All Classes Alphabetically'! !

!Browser methodsFor: 'system category functions'!
buildSystemCategoryBrowser
	"Create and schedule a new system category browser."

	self buildSystemCategoryBrowserEditString: nil! !

!Browser methodsFor: 'system category functions' stamp: 'tk 5/4/1998 15:56'!
buildSystemCategoryBrowserEditString: aString 
	"Create and schedule a new system category browser with initial textual 
	contents set to aString."

	| newBrowser |
	systemCategoryListIndex > 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
			Browser openBrowserView: (newBrowser openSystemCatEditString: aString)
				label: 'Classes in category ', newBrowser selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'!
changeSystemCategories: aString 
	"Update the class categories by parsing the argument aString."

	systemOrganizer changeFromString: aString.
	self changed: #systemCategoryList.
	^ true! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'!
classNotFound

	self changed: #flash.! !

!Browser methodsFor: 'system category functions' stamp: 'sw 1/28/1999 12:30'!
editSystemCategories
	"Retrieve the description of the class categories of the system organizer."

	self okToChange ifFalse: [^ self].
	self systemCategoryListIndex: 0.
	editSelection _ #editSystemCategories.
	self changed: #editSystemCategories.
	self contentsChanged! !

!Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'!
fileOutSystemCategory
	"Print a description of each class in the selected category onto a file 
	whose name is the category name followed by .st."

	systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'stp 01/13/2000 12:26'!
findClass
	"Search for a class by name."
	| pattern foundClass classNames index toMatch exactMatch potentialClassNames |

	self okToChange ifFalse: [^ self classNotFound].
	pattern _ FillInTheBlank request: 'Class name or fragment?'.
	pattern isEmpty ifTrue: [^ self classNotFound].
	toMatch _ (pattern copyWithout: $.) asLowercase.
	potentialClassNames _ self potentialClassNames asOrderedCollection.
	classNames _ pattern last = $. 
		ifTrue: [potentialClassNames select:
					[:nm |  nm asLowercase = toMatch]]
		ifFalse: [potentialClassNames select: 
					[:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames isEmpty ifTrue: [^ self classNotFound].
	exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil].

	index _ classNames size = 1
		ifTrue:	[1]
		ifFalse:	[exactMatch
			ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUp]
			ifNotNil: [classNames addFirst: exactMatch.
				(PopUpMenu labelArray: classNames lines: #(1)) startUp]].
	index = 0 ifTrue: [^ self classNotFound].
	foundClass _ Smalltalk at: (classNames at: index) asSymbol.
 	self selectCategoryForClass: foundClass.
	self selectClass: foundClass
! !

!Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 10:04'!
potentialClassNames
	"Answer the names of all the classes that could be viewed in this browser.  This hook is provided so that HierarchyBrowsers can indicate their restricted subset.  For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers."

	^ Smalltalk classNames! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:46'!
printOutSystemCategory
	"Print a description of each class in the selected category as Html."

Cursor write showWhile:
	[systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName
								asHtml: true ]]
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self classList size = 0
		or: [self confirm: 'Are you sure you want to
remove this system category 
and all its classes?'])
		ifTrue: 
		[systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
		self systemCategoryListIndex: 0.
		self changed: #systemCategoryList]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
renameSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	(oldIndex _ systemCategoryListIndex) = 0
		ifTrue: [^ self].  "no selection"
	self okToChange ifFalse: [^ self].
	oldName _ self selectedSystemCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	oldName = newName ifTrue: [^ self].
	systemOrganizer
		renameCategory: oldName
		toBe: newName.
	self systemCategoryListIndex: oldIndex.
	self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 14:07'!
systemCatSingletonMenu: aMenu

	^ aMenu labels:
'browse all
browse
printOut
fileOut
update
rename...
remove' 
	lines: #(2 4)
	selections:
		#(browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory updateSystemCategories
		renameSystemCategory removeSystemCategory)
! !

!Browser methodsFor: 'system category functions' stamp: 'sma 2/5/2000 13:24'!
systemCategoryMenu: aMenu

^ aMenu labels:
'find class... (f)
recent classes... (r)
browse all
browse
printOut
fileOut
reorganize
update
add item...
rename...
remove' 
	lines: #(2 4 6 8)
	selections:
		#(findClass recent browseAllClasses buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory
		editSystemCategories updateSystemCategories
		addSystemCategory renameSystemCategory removeSystemCategory )! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'!
updateSystemCategories
	"The class categories were changed in another browser. The receiver must 
	reorganize its lists based on these changes."

	self okToChange ifFalse: [^ self].
	self changed: #systemCategoryList! !


!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne
	"When used as a singleton list, index is always one"
	^ 1! !

!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne: value
	"When used as a singleton list, can't change it"

	^ self! !

!Browser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:25'!
selectCategoryForClass: theClass

	self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category)
! !

!Browser methodsFor: 'system category list' stamp: 'di 12/6/1999 20:11'!
selectedEnvironment
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^ Smalltalk environmentForCategory: self selectedSystemCategoryName! !

!Browser methodsFor: 'system category list'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^self systemCategoryList at: systemCategoryListIndex! !

!Browser methodsFor: 'system category list'!
systemCategoryList
	"Answer the class categories modelled by the receiver."

	^systemOrganizer categories! !

!Browser methodsFor: 'system category list'!
systemCategoryListIndex
	"Answer the index of the selected class category."

	^systemCategoryListIndex! !

!Browser methodsFor: 'system category list' stamp: 'sw 1/28/1999 12:30'!
systemCategoryListIndex: anInteger 
	"Set the selected system category index to be anInteger. Update all other 
	selections to be deselected."

	systemCategoryListIndex _ anInteger.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newClass].
	metaClassIndicated _ false.
	self setClassOrganizer.
	contents _ nil.
	self changed: #systemCategorySelectionChanged.
	self changed: #systemCategoryListIndex.	"update my selection"
	self changed: #classList.
	self changed: #messageCategoryList.
	self changed: #messageList.
	self contentsChanged.
! !

!Browser methodsFor: 'system category list' stamp: 'tk 4/3/98 10:30'!
systemCategorySingleton

	| cat |
	cat _ self selectedSystemCategoryName.
	^ cat ifNil: [Array new]
		ifNotNil: [Array with: cat]! !

!Browser methodsFor: 'system category list'!
toggleSystemCategoryListIndex: anInteger 
	"If anInteger is the current system category index, deselect it. Else make 
	it the current system category selection."

	self systemCategoryListIndex: 
		(systemCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

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

Browser class
	instanceVariableNames: ''!

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 17:37'!
fullOnClass: aClass 
	"Open a new full browser set to class."
	| brow |
	brow _ Browser new.
	brow setClass: aClass selector: nil.
	Browser openBrowserView: (brow openEditString: nil)
		label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'sw 1/13/2000 16:45'!
fullOnClass: aClass selector: aSelector
	"Open a new full browser set to class."

	| brow classToUse |
	classToUse _ Preferences browseToolClass.
	brow _ classToUse new.
	brow setClass: aClass selector: aSelector.
	classToUse openBrowserView: (brow openEditString: nil)
		label: brow defaultBrowserTitle! !

!Browser class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:03'!
new

	^super new systemOrganizer: SystemOrganization! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:04'!
newOnCategory: aCategory
	"Browse the system category of the given name.  7/13/96 sw"

	"Browser newOnCategory: 'Interface-Browser'"

	| newBrowser catList |
	newBrowser _ Browser new.
	catList _ newBrowser systemCategoryList.
	newBrowser systemCategoryListIndex: 
		(catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
				label: 'Classes in category ', aCategory
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'!
newOnClass: aClass 
	"Open a new class browser on this class."
	^ self newOnClass: aClass label: 'Class Browser: ', aClass name! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:55'!
newOnClass: aClass label: aLabel
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser _ Browser new.
	newBrowser setClass: aClass selector: nil.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
			label: aLabel
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:29'!
newOnClass: aClass selector: aSymbol
	"Open a new class browser on this class."
	| newBrowser |

	newBrowser _ Browser new.
	newBrowser setClass: aClass selector: aSymbol.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
			label: 'Class Browser: ', aClass name
! !

!Browser class methodsFor: 'instance creation' stamp: 'sw 1/13/2000 16:46'!
openBrowser
	"Create and schedule a BrowserView with label 'System Browser'. The 
	view consists of five subviews, starting with the list view of system 
	categories of SystemOrganization. The initial text view part is empty."

	Browser openBrowserView: (Browser new openEditString: nil)
			label: 'System Browser'

! !

!Browser class methodsFor: 'instance creation' stamp: 'di 5/14/1998 09:43'!
openBrowserView: aBrowserView label: aString 
	"Schedule aBrowserView, labelling the view aString."
	
	aBrowserView isMorph
		ifTrue:  [(aBrowserView setLabel: aString) openInWorld]
		ifFalse: [aBrowserView label: aString.
				aBrowserView minimumSize: 300 @ 200.
				aBrowserView subViews do: [:each | each controller].
				aBrowserView controller open]! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:44'!
openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString
	"Create and schedule a message browser for the class, aBehavior, in 
	which the argument, aString, contains characters to be edited in the text 
	view. These characters are the source code for the message selector 
	aSymbol."

	| newBrowser |
	(newBrowser _ Browser new) setClass: aBehavior selector: aSymbol.
	^ Browser openBrowserView: (newBrowser openMessageEditString: aString)
		label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName
! !


!Browser class methodsFor: 'class initialization'!
initialize
        "Browser initialize"

        RecentClasses := OrderedCollection new! !
GenericUrl subclass: #BrowserUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!BrowserUrl commentStamp: '<historical>' prior: 0!
URLs that instruct a browser to do something.!


!BrowserUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'!
hasContents
	^true! !

!BrowserUrl methodsFor: 'downloading' stamp: 'ls 7/26/1998 21:21'!
retrieveContentsForBrowser: aBrowser
	^aBrowser browserUrlContents: locator! !
PluggableCanvas subclass: #BufferedCanvas
	instanceVariableNames: 'remote previousVersion lastTick dirtyRect mirrorOfScreen '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 13:52'!
apply: aBlock

	"self checkIfTimeToDisplay"! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 15:04'!
asBufferedCanvas

	^self! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 15:03'!
checkIfTimeToDisplay

	remote backlog > 0 ifTrue: [^self].	"why bother if network full?"
	dirtyRect ifNil: [^self].
	self sendDeltas.
	lastTick _ Time millisecondClockValue.

! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 20:44'!
clipBy: aRectangle during: aBlock
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 13:04'!
clipRect
	
	^0@0 extent: 99999@99999
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 14:35'!
connection: connection clipRect: newClipRect transform: transform remoteCanvas: remoteCanvas

	remote _ remoteCanvas.
	lastTick _ 0.
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 13:54'!
displayIsFullyUpdated

	self checkIfTimeToDisplay! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 20:32'!
drawMorph: x
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 22:36'!
extent

	^Display extent! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 15:00'!
forceToScreen: rect

	mirrorOfScreen ifNil: [
		mirrorOfScreen _ (previousVersion ifNil: [Display]) deepCopy.
	].
	mirrorOfScreen copy: rect from: rect origin in: Display rule: Form over.
	dirtyRect _ dirtyRect ifNil: [rect] ifNotNil: [dirtyRect merge: rect].
! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 22:36'!
origin

	^0@0! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue! !

!BufferedCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 18:08'!
sendDeltas
"
NebraskaDebug showStats: #sendDeltas
"
	| t deltas dirtyFraction |

	previousVersion ifNil: [
		previousVersion _ Display deepCopy.
		remote 
			image: previousVersion 
			at: 0@0 
			sourceRect: previousVersion boundingBox 
			rule: Form paint.
		^remote forceToScreen: previousVersion boundingBox.
	].
	dirtyRect ifNil: [^self].
	t _ Time millisecondClockValue.
	dirtyFraction _ dirtyRect area / previousVersion boundingBox area roundTo: 0.0001.

	deltas _ mirrorOfScreen deltaFrom: (previousVersion copy: dirtyRect) at: dirtyRect origin.
	previousVersion _ mirrorOfScreen.
	mirrorOfScreen _ nil.

	remote 
		image: deltas at: dirtyRect origin sourceRect: deltas boundingBox rule: Form reverse;
		forceToScreen: dirtyRect.

	t _ Time millisecondClockValue - t.
	NebraskaDebug at: #sendDeltas add: {t. dirtyFraction. deltas boundingBox}.
	dirtyRect _ nil.
! !

Switch subclass: #Button
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!Button commentStamp: '<historical>' prior: 0!
I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.!


!Button methodsFor: 'state'!
turnOff
	"Sets the state of the receiver to 'off'. The off action of the receiver is not  
	executed."

	on _ false! !

!Button methodsFor: 'state'!
turnOn
	"The receiver remains in the 'off' state'."

	self doAction: onAction.
	self doAction: offAction! !

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

Button class
	instanceVariableNames: ''!

!Button class methodsFor: 'instance creation'!
newOn 
	"Refer to the comment in Switch|newOn."

	self error: 'Buttons cannot be created in the on state'.
	^nil! !
ArrayedCollection variableByteSubclass: #ByteArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!ByteArray commentStamp: '<historical>' prior: 0!
I represent an ArrayedCollection whose elements are integers between 0 and 255.
!


!ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'!
byteAt: index
	<primitive: 60>
	^self at: index! !

!ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'!
byteAt: index put: value
	<primitive: 61>
	^self at: index put: value! !

!ByteArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 1! !


!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:44'!
longAt: index bigEndian: aBool
	"Return a 32bit integer quantity starting from the given byte index"
	| b0 b1 b2 w h |
	aBool ifTrue:[
		b0 _ self at: index.
		b1 _ self at: index+1.
		b2 _ self at: index+2.
		w _ self at: index+3.
	] ifFalse:[
		w _ self at: index.
		b2 _ self at: index+1.
		b1 _ self at: index+2.
		b0 _ self at: index+3.
	].
	"Minimize LargeInteger arithmetic"
	h _ ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1.
	b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
	h = 0 ifFalse:[w _ (h bitShift: 16) + w].
	^w! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:47'!
longAt: index put: value bigEndian: aBool
	"Return a 32bit integer quantity starting from the given byte index"
	| b0 b1 b2 b3 |
	b0 _ value bitShift: -24.
	b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80).
	b1 _ (value bitShift: -16) bitAnd: 255.
	b2 _ (value bitShift: -8) bitAnd: 255.
	b3 _ value bitAnd: 255.
	aBool ifTrue:[
		self at: index put: b0.
		self at: index+1 put: b1.
		self at: index+2 put: b2.
		self at: index+3 put: b3.
	] ifFalse:[
		self at: index put: b3.
		self at: index+1 put: b2.
		self at: index+2 put: b1.
		self at: index+3 put: b0.
	].
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:57'!
shortAt: index bigEndian: aBool
	"Return a 16 bit integer quantity starting from the given byte index"
	| uShort |
	uShort _ self unsignedShortAt: index bigEndian: aBool.
	^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/3/1998 14:20'!
shortAt: index put: value bigEndian: aBool
	"Store a 16 bit integer quantity starting from the given byte index"
	self unsignedShortAt: index put: (value bitAnd: 16r7FFF) - (value bitAnd: -16r8000) bigEndian: aBool.
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'!
unsignedLongAt: index bigEndian: aBool
	"Return a 32bit unsigned integer quantity starting from the given byte index"
	| b0 b1 b2 w |
	aBool ifTrue:[
		b0 _ self at: index.
		b1 _ self at: index+1.
		b2 _ self at: index+2.
		w _ self at: index+3.
	] ifFalse:[
		w _ self at: index.
		b2 _ self at: index+1.
		b1 _ self at: index+2.
		b0 _ self at: index+3.
	].
	"Minimize LargeInteger arithmetic"
	b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w].
	b1 = 0 ifFalse:[w _ (b1 bitShift: 16) + w].
	b0 = 0 ifFalse:[w _ (b0 bitShift: 24) + w].
	^w! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:49'!
unsignedLongAt: index put: value bigEndian: aBool
	"Store a 32bit unsigned integer quantity starting from the given byte index"
	| b0 b1 b2 b3 |
	b0 _ value bitShift: -24.
	b1 _ (value bitShift: -16) bitAnd: 255.
	b2 _ (value bitShift: -8) bitAnd: 255.
	b3 _ value bitAnd: 255.
	aBool ifTrue:[
		self at: index put: b0.
		self at: index+1 put: b1.
		self at: index+2 put: b2.
		self at: index+3 put: b3.
	] ifFalse:[
		self at: index put: b3.
		self at: index+1 put: b2.
		self at: index+2 put: b1.
		self at: index+3 put: b0.
	].
	^value! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:51'!
unsignedShortAt: index bigEndian: aBool
	"Return a 16 bit unsigned integer quantity starting from the given byte index"
	^aBool 
		ifTrue:[((self at: index) bitShift: 8) + (self at: index+1)]
		ifFalse:[((self at: index+1) bitShift: 8) + (self at: index)].! !

!ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:53'!
unsignedShortAt: index put: value bigEndian: aBool
	"Store a 16 bit unsigned integer quantity starting from the given byte index"
	aBool ifTrue:[
		self at: index put: (value bitShift: -8).
		self at: index+1 put: (value bitAnd: 255).
	] ifFalse:[
		self at: index+1 put: (value bitShift: -8).
		self at: index put: (value bitAnd: 255).
	].
	^value! !


!ByteArray methodsFor: 'converting' stamp: 'sma 5/12/2000 17:35'!
asByteArray
	^ self! !

!ByteArray methodsFor: 'converting'!
asString
	"Convert to a String with Characters for each byte.
	Fast code uses primitive that avoids character conversion"

	^ (String new: self size) replaceFrom: 1 to: self size with: self! !


!ByteArray methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'!
asByteArrayPointer
	"Return a ByteArray describing a pointer to the contents of the receiver."
	^self shouldNotImplement! !

!ByteArray methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'!
asExternalPointer
	"Convert the receiver assuming that it describes a pointer to an object."
	^(ExternalAddress new)
		basicAt: 1 put: (self byteAt: 1);
		basicAt: 2 put: (self byteAt: 2);
		basicAt: 3 put: (self byteAt: 3);
		basicAt: 4 put: (self byteAt: 4);
	yourself! !

!ByteArray methodsFor: 'private'!
defaultElement

	^0! !

!ByteArray methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
	<primitive: 105>
	super replaceFrom: start to: stop with: replacement startingAt: repStart! !


!ByteArray methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:30'!
hash
	| hash |

	hash _ 0.
	1 to: self size do: [:i | hash _ (hash + (self at: i)) hashMultiply].
	^hash! !


!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:15'!
booleanAt: byteOffset
	"bool is only valid with function declarations"
	^self shouldNotImplement! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:15'!
booleanAt: byteOffset put: value
	"bool is only valid with function declarations"
	^self shouldNotImplement! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:44'!
doubleAt: byteOffset
	<primitive:'primitiveFFIDoubleAt' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:13'!
doubleAt: byteOffset put: value
	<primitive:'primitiveFFIDoubleAtPut' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:13'!
floatAt: byteOffset
	<primitive:'primitiveFFIFloatAt' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:13'!
floatAt: byteOffset put: value
	<primitive:'primitiveFFIFloatAtPut' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:56'!
integerAt: byteOffset put: value size: nBytes signed: aBoolean
	"Primitive. Store the given value as integer of nBytes size
	in the receiver. Fail if the value is out of range.
	Note: This primitive will access memory in the outer space if
	invoked from ExternalAddress."
	<primitive: 'primitiveFFIIntegerAtPut' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:55'!
integerAt: byteOffset size: nBytes signed: aBoolean
	"Primitive. Return an integer of nBytes size from the receiver.
	Note: This primitive will access memory in the outer space if
	invoked from ExternalAddress."
	<primitive: 'primitiveFFIIntegerAt' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:09'!
isExternalAddress
	"Return true if the receiver describes an object in the outside world"
	^false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:15'!
pointerAt: byteOffset
	"Return a pointer object stored at the given byte address"
	| addr |
	addr _ ExternalAddress new.
	1 to: 4 do:[:i|
		addr basicAt: i put: (self unsignedByteAt: byteOffset+i-1)].
	^addr! !

!ByteArray methodsFor: 'external access' stamp: 'hg 2/28/2000 15:34'!
pointerAt: byteOffset put: value
	"Store a pointer object at the given byte address"
	value isExternalAddress ifFalse:[^self error:'Only external addresses can be stored'].
	1 to: 4 do:[:i|
		self unsignedByteAt: byteOffset+i-1 put: (value basicAt: i)].
	^value! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:39'!
signedByteAt: byteOffset
	"Return a 8bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset size: 1 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:39'!
signedByteAt: byteOffset put: value
	"Store a 8bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 1 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:53'!
signedCharAt: byteOffset
	^(self unsignedByteAt: byteOffset) asCharacter! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:54'!
signedCharAt: byteOffset put: aCharacter
	^self unsignedByteAt: byteOffset put: aCharacter asciiValue! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 15:54'!
signedLongAt: byteOffset
	"Return a 32bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset size: 4 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 15:54'!
signedLongAt: byteOffset put: value
	"Store a 32bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 4 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:16'!
signedLongLongAt: byteOffset
	"This is not yet supported"
	^self notYetImplemented! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:17'!
signedLongLongAt: byteOffset put: value
	"This is not yet supported"
	^self notYetImplemented! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 15:54'!
signedShortAt: byteOffset
	"Return a 16bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset size: 2 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 15:54'!
signedShortAt: byteOffset put: value
	"Store a 16bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 2 signed: true! !

!ByteArray methodsFor: 'external access' stamp: 'hg 2/28/2000 13:56'!
structAt: byteOffset length: length
	"Return a structure of the given length starting at the indicated byte offset."
	| value |
	value _ ByteArray new: length.
	1 to: length do:[:i|
		value unsignedByteAt: i put: (self unsignedByteAt: byteOffset+i-1)].
	^value! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 21:11'!
structAt: byteOffset put: value length: length
	"Store a structure of the given length starting at the indicated byte offset."
	1 to: length do:[:i|
		self unsignedByteAt: byteOffset+i-1 put: (value unsignedByteAt: i)].
	^value! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:40'!
unsignedByteAt: byteOffset
	"Return a 8bit unsigned integer starting at the given byte offset"
	^self integerAt: byteOffset size: 1 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:40'!
unsignedByteAt: byteOffset put: value
	"Store a 8bit unsigned integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 1 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:53'!
unsignedCharAt: byteOffset
	^(self unsignedByteAt: byteOffset) asCharacter! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/28/1999 23:54'!
unsignedCharAt: byteOffset put: aCharacter
	^self unsignedByteAt: byteOffset put: aCharacter asciiValue! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:23'!
unsignedLongAt: byteOffset
	"Return a 32bit unsigned integer starting at the given byte offset"
	^self integerAt: byteOffset size: 4 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 01:23'!
unsignedLongAt: byteOffset put: value
	"Store a 32bit signed integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 4 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:17'!
unsignedLongLongAt: byteOffset
	"This is not yet supported"
	^self notYetImplemented! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:17'!
unsignedLongLongAt: byteOffset put: value
	"This is not yet supported"
	^self notYetImplemented! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 00:55'!
unsignedShortAt: byteOffset
	"Return a 16bit unsigned integer starting at the given byte offset"
	^self integerAt: byteOffset size: 2 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/21/1999 00:56'!
unsignedShortAt: byteOffset put: value
	"Store a 16bit unsigned integer starting at the given byte offset"
	^self integerAt: byteOffset put: value size: 2 signed: false! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:16'!
voidAt: byteOffset
	"no accessors for void"
	^self shouldNotImplement! !

!ByteArray methodsFor: 'external access' stamp: 'ar 11/29/1999 00:16'!
voidAt: byteOffset put: value
	"no accessors for void"
	^self shouldNotImplement! !

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

ByteArray class
	instanceVariableNames: ''!

!ByteArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:13'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asCharPtrFrom: anInteger on: aStream! !

!ByteArray class methodsFor: 'plugin generation' stamp: 'acg 9/19/1999 00:25'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asCharPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isBytes')! !

!ByteArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:13'!
ccgDeclareCForVar: aSymbolOrString

	^'char *', aSymbolOrString! !
FlattenEncoder subclass: #ByteEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

!ByteEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 01:33'!
elementSeparator
	^' '.! !

!ByteEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 22:45'!
numberDefaultBase
	^self class numberDefaultBase.
! !


!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 15:17'!
cr
	^target cr.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:48'!
print:encodedObject
	^target write:encodedObject.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:18'!
space
	^target space.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 15:16'!
tab
	^target tab.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 20:51'!
writeArray:aCollection
	^self writeArrayedCollection:aCollection.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 20:53'!
writeAssocation:anAssociation
	^self write:anAssociation key; print:'->'; write:anAssociation value.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:31'!
writeCollection:aCollection
	^self print:aCollection class name; 
		writeCollectionContents:aCollection.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 02:31'!
writeCollectionContents:aCollection
	self print:'( '.
		super writeCollectionContents:aCollection.
		self print:')'.
	^self.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 22:44'!
writeNumber:aNumber
	^self writeNumber:aNumber base:self numberDefaultBase.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:03'!
writeNumber:aNumber base:aBase
	^aNumber byteEncode:self base:aBase.

! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:25'!
writeObject:anObject
	^self print:anObject stringRepresentation.
! !

!ByteEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 00:21'!
writeString:aString
	^aString encodeDoublingQuoteOn:self.! !

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

ByteEncoder class
	instanceVariableNames: ''!

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 01:18'!
defaultTarget
	^WriteStream on:(String new: 40000).! !

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:41'!
filterSelector
	^#byteEncode:.! !

!ByteEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 22:46'!
numberDefaultBase
	^10.
! !
CObjectAccessor subclass: #CArrayAccessor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!CArrayAccessor commentStamp: '<historical>' prior: 0!
I am used to simulate the indexed access to arrays during plugin simulation.!


!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index
	^object at: index + offset + 1! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index put: value
	^object at: index + offset + 1 put: value! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:50'!
cPtrAsOop

	offset = 0 ifFalse: [self error: 'offset must be zero'].
	^object! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/10/1998 16:26'!
longAt: index
	| idx |
	idx _ (offset + index) // 4 + 1.
	"Note: This is a special hack for BitBlt."
	(idx = (object basicSize + 1)) ifTrue:[^0].
	^object basicAt: idx! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'ar 10/10/1998 16:26'!
longAt: index put: value
	^object basicAt: (offset + index) // 4 + 1 put: value! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:48'!
next

	|val|
	val _ self at: 0.
	offset _ offset + 1.
	^val! !

!CArrayAccessor methodsFor: 'accessing' stamp: 'acg 9/19/1999 01:46'!
size

	^object size! !
Object subclass: #CCodeGenerator
	instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations methods variablesSetCache headerFiles pluginPrefix extraDefs postProcesses isCPP '
	classVariableNames: 'UseRightShiftForDivide '
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!
!CCodeGenerator commentStamp: '<historical>' prior: 0!
This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.  Executing

	Interpreter translate: 'interp.c' doInlining: true.

(with single quotes) will cause all the methods of Interpreter, ObjectMemory and BitBltSimulation to be translated to C, and stored in the named file.  This file together with the files emitted by InterpreterSupportCode (qv) should be adequate to produce a complete interpreter for the Macintosh environment.!


!CCodeGenerator methodsFor: 'public' stamp: 'TPR 3/2/2000 11:22'!
addAllClassVarsFor: aClass
	"Add the class variables for the given class (and its superclasses) to the code base as constants."

	| allClasses |
	allClasses _ aClass withAllSuperclasses.
	allClasses do: [:c | self addClassVarsFor: c].
! !

!CCodeGenerator methodsFor: 'public' stamp: 'TPR 3/2/2000 11:26'!
addClass: aClass 
	"Add the variables and methods of the given class to the code base."
	| source |
	self checkClassForNameConflicts: aClass.
	self addClassVarsFor: aClass.
	"ikp..."
	self addPoolVarsFor: aClass.
	variables addAll: aClass instVarNames.
	'Adding Class ' , aClass name , '...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: aClass selectors size
		during: [:bar | aClass selectors
				doWithIndex: 
					[:sel :i | 
					bar value: i.
					source _ aClass sourceCodeAt: sel.
					self addMethod: ((Compiler new
							parse: source
							in: aClass
							notifying: nil)
							asTranslationMethodOfClass: self translationMethodClass)]]! !

!CCodeGenerator methodsFor: 'public'!
addClassVarsFor: aClass
	"Add the class variables for the given class to the code base as constants."

	aClass classPool associationsDo: [:assoc | 
		constants at: assoc key asString
			put: (TConstantNode new setValue: assoc value)]! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/14/1999 01:08'!
addHeaderFile: aString
	"Add a header file. The argument must be a quoted string!!"
	headerFiles addLast: aString.! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/3/2001 17:55'!
addMethodsForPrimitives: classAndSelectorList 
	| sel aClass source verbose meth |
	classAndSelectorList do: 
		[:classAndSelector | 
		aClass _ Smalltalk at: (classAndSelector at: 1).
		self addAllClassVarsFor: aClass.
"TPR - should pool vars also be added here?"

		"find the method in either the class or the metaclass"
		sel _ classAndSelector at: 2.
		(aClass includesSelector: sel)
			ifTrue: [source _ aClass sourceCodeAt: sel]
			ifFalse: [source _ aClass class sourceCodeAt: sel].

		"compile the method source and convert to a suitable translation 
		method "
		meth _ (Compiler new
					parse: source
					in: aClass
					notifying: nil)
					asTranslationMethodOfClass: self translationMethodClass.

		(aClass includesSelector: sel)
			ifTrue: [meth definingClass: aClass]
			ifFalse: [meth definingClass: aClass class].
		meth primitive > 0 ifTrue:[meth preparePrimitiveName].
		"for old-style array accessing: 
		meth covertToZeroBasedArrayReferences."
		meth replaceSizeMessages.
		self addMethod: meth].

	"method preparation"
	verbose _ false.
	self prepareMethods.
	verbose
		ifTrue: 
			[self printUnboundCallWarnings.
			self printUnboundVariableReferenceWarnings.
			Transcript cr].

	"code generation"
	self doInlining: true.

	methods do:[:m|
		"if this method is supposed to be a primitive (rather than a helper 
		routine), add assorted prolog and epilog items"
		m primitive > 0 ifTrue: [m preparePrimitivePrologue]].! !

!CCodeGenerator methodsFor: 'public'!
addPoolVarsFor: aClass 
	"Add the pool variables for the given class to the code base as constants."
	aClass sharedPools do: [:pool |
		pool associationsDo: [:assoc |
			constants at: assoc key asString 
				put: (TConstantNode new setValue: assoc value)]]! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:48'!
codeString
	"Return a string containing all the C code for the code base. Used for testing."

	| stream |
	stream _ ReadWriteStream on: (String new: 1000).
	self emitCCodeOn: stream doInlining: true doAssertions: true.
	^stream contents! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/3/2001 18:10'!
codeStringForPrimitives: classAndSelectorList 
	self addMethodsForPrimitives: classAndSelectorList.
	^self generateCodeStringForPrimitives! !

!CCodeGenerator methodsFor: 'public' stamp: 'TPR 5/23/2000 17:10'!
declareModuleName: nameString local: bool
	"add the declaration of a module name, version and local/external tag"

	self var: #moduleName declareC:'const char *moduleName = "', nameString, (bool ifTrue:[' (i)"'] ifFalse:[' (e)"'])

! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 5/9/2000 12:24'!
exportedPrimitiveNames
	"Return an array of all exported primitives"
	^methods select:[:m| m export] thenCollect:[:m| m selector copyWithout: $:].
! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/3/2001 17:04'!
generateCodeStringForPrimitives
	| s methodList |
	s _ ReadWriteStream on: (String new: 1000).
	methodList _ methods asSortedCollection: [:m1 :m2 | m1 selector < m2 selector].
	self emitCHeaderForPrimitivesOn: s.
	self emitCVariablesOn: s.
	self emitCFunctionPrototypes: methodList on: s.
	methodList do: [:m | m emitCCodeOn: s generator: self].
	^ s contents
! !

!CCodeGenerator methodsFor: 'public'!
globalsAsSet
	"Used by the inliner to avoid name clashes with global variables."

	((variablesSetCache == nil) or:
	 [variablesSetCache size ~= variables size]) ifTrue: [
		variablesSetCache _ variables asSet.
	].
	^ variablesSetCache! !

!CCodeGenerator methodsFor: 'public' stamp: 'RMF 3/27/2000 09:53'!
initialize
	translationDict _ Dictionary new.
	inlineList _ Array new.
	constants _ Dictionary new: 100.
	variables _ OrderedCollection new: 100.
	variableDeclarations _ Dictionary new: 100.
	methods _ Dictionary new: 500.
	self initializeCTranslationDictionary.
	headerFiles _ OrderedCollection new.
	isCPP _ false! !

!CCodeGenerator methodsFor: 'public' stamp: 'sma 4/22/2000 12:33'!
isCPP: aBoolean
	isCPP _ aBoolean! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/21/2000 14:58'!
isTranslatingLocally
	"Return true if the CG has been setup to translate a plugin locally."
	^pluginPrefix notNil! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/21/2000 14:58'!
pluginPrefix
	"Return the plugin prefix when generating local plugins.
	Local plugins are plugins compiled with the main interpreter
	source but are not included (nor inlined into) interp.c"
	^pluginPrefix! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 2/21/2000 14:58'!
pluginPrefix: aString
	"Set the plugin prefix when generating local plugins.
	Local plugins are plugins compiled with the main interpreter
	source but are not included (nor inlined into) interp.c"
	pluginPrefix _ aString.! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag
	"Store C code for this code base on the given file."

	self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: true! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 5/9/2000 14:53'!
storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag
	"Store C code for this code base on the given file."

	| stream realName |
	"(self isTranslatingLocally and:[(fileName beginsWith: 'sq') not])
		ifTrue:[realName _ 'sq', fileName]
		ifFalse:[realName _ fileName]."
	stream _ CrLfFileStream newFileNamed: fileName.
	stream ifNil: [Error signal: 'Could not open C code file: ', realName].
	self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag.
	stream close! !

!CCodeGenerator methodsFor: 'public' stamp: 'ar 3/10/2000 17:58'!
var: varName declareC: declarationString
	"Record the given C declaration for a global variable."

	variableDeclarations at: varName asString put: declarationString.! !

!CCodeGenerator methodsFor: 'public' stamp: 'sma 3/3/2000 12:01'!
var: varName type: type
	self var: varName declareC: type , ' ' , varName! !

!CCodeGenerator methodsFor: 'public' stamp: 'sma 3/3/2000 12:00'!
var: varName type: type array: array
	self
		var: varName
		declareC: (String streamContents: [:s |
			s nextPutAll: type.
			s space.
			s nextPutAll: varName.
			s nextPutAll: '[] = {'.
			self printArray: array on: s.
			s nextPut: $}])! !


!CCodeGenerator methodsFor: 'error notification'!
checkClassForNameConflicts: aClass
	"Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."

	"check for constant name collisions"
	aClass classPool associationsDo: [ :assoc |
		(constants includesKey: assoc key asString) ifTrue: [
			self error: 'Constant was defined in a previously added class: ', assoc key.
		].
	].
	"ikp..."
	aClass sharedPools do: [:pool |
		pool associationsDo: [ :assoc |
			(constants includesKey: assoc key asString) ifTrue: [
				self error: 'Constant was defined in a previously added class: ', assoc key.
			].
		].
	].

	"check for instance variable name collisions"
	aClass instVarNames do: [ :varName |
		(variables includes: varName) ifTrue: [
			self error: 'Instance variable was defined in a previously added class: ', varName.
		].
	].

	"check for method name collisions"
	aClass selectors do: [ :sel |
		(methods includesKey: sel) ifTrue: [
			self error: 'Method was defined in a previously added class: ', sel.
		].
	].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundCallWarnings
	"Print a warning message for every unbound method call in the code base."

	| knownSelectors undefinedCalls |
	undefinedCalls _ Dictionary new.
	knownSelectors _ translationDict keys asSet.
	knownSelectors add: #error:.
	methods do: [ :m | knownSelectors add: m selector ].
	methods do: [ :m |
		m allCalls do: [ :sel |
			(knownSelectors includes: sel) ifFalse: [
				(undefinedCalls includesKey: sel)
					ifTrue: [ (undefinedCalls at: sel) add: m selector ]
					ifFalse: [ undefinedCalls at: sel put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedCalls keys asSortedCollection do: [ :undefined |
		Transcript show: undefined, ' -- undefined method sent by:'; cr.
		(undefinedCalls at: undefined) do: [ :caller |
			Transcript tab; show: caller; cr.
		].
	].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundVariableReferenceWarnings
	"Print a warning message for every unbound variable reference in the code base."

	| undefinedRefs globalVars knownVars |
	undefinedRefs _ Dictionary new.
	globalVars _ Set new: 100.
	globalVars addAll: variables.
	methods do: [ :m |
		knownVars _ globalVars copy.
		m args do: [ :var | knownVars add: var ].
		m locals do: [ :var | knownVars add: var ].
		m freeVariableReferences do: [ :varName |
			(knownVars includes: varName) ifFalse: [
				(undefinedRefs includesKey: varName)
					ifTrue: [ (undefinedRefs at: varName) add: m selector ]
					ifFalse: [ undefinedRefs at: varName put: (OrderedCollection with: m selector) ].
			].
		].
	].

	Transcript cr.
	undefinedRefs keys asSortedCollection do: [ :var |
		Transcript show: var, ' -- undefined variable used in:'; cr.
		(undefinedRefs at: var) do: [ :sel |
			Transcript tab; show: sel; cr.
		].
	].! !


!CCodeGenerator methodsFor: 'inlining' stamp: 'ls 10/10/1999 13:56'!
collectInlineList
	"Make a list of methods that should be inlined."
	"Details: The method must not include any inline C, since the
translator cannot currently map variable names in inlined C code.
Methods to be inlined must be small or called from only one place."

	| methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount
sel |
	methodsNotToInline _ Set new: methods size.

	"build dictionary to record the number of calls to each method"
	callsOf _ Dictionary new: methods size * 2.
	methods keys do: [ :s | callsOf at: s put: 0 ].

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"
	inlineList _ Set new: methods size * 2.
	methods do: [ :m |
		inlineIt _ #dontCare.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					sel _ node selector.
					(sel = #cCode: or: [sel = #cCode:inSmalltalk:])
						ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: sel ifAbsent: [ nil ].
					nil = senderCount ifFalse: [
						callsOf at: sel put: senderCount + 1.
					].
				].
				nodeCount _ nodeCount + 1.
			].
			inlineIt _ m extractInlineDirective.  "may be true, false, or
#dontCare"
		].
		(hasCCode or: [inlineIt = false]) ifTrue: [
			"don't inline if method has C code and is contains negative inline
directive"
			methodsNotToInline add: m selector.
		] ifFalse: [
			((nodeCount < 40) or: [inlineIt = true]) ifTrue: [
				"inline if method has no C code and is either small or contains
inline directive"
				inlineList add: m selector.
			].
		].
	].

	callsOf associationsDo: [ :assoc |
		((assoc value = 1) and: [(methodsNotToInline includes: assoc key)
not]) ifTrue: [
			inlineList add: assoc key.
		].
	].! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'jm 5/17/1999 13:05'!
doInlining: inlineFlag
	"Inline the bodies of all methods that are suitable for inlining."
	"Modified slightly for the translator, since the first level of inlining for the interpret loop must be performed in order that the instruction implementations can easily discover their addresses."

	| pass progress |
	inlineFlag ifFalse: [
		self inlineDispatchesInMethodNamed: #interpret localizingVars: #().
		^ self].

	self collectInlineList.
	pass _ 0.
	progress _ true.
	[progress] whileTrue: [
		"repeatedly attempt to inline methods until no further progress is made"
		progress _ false.
		('Inlining pass ', (pass _ pass + 1) printString, '...')
			displayProgressAt: Sensor cursorPoint
			from: 0 to: methods size
			during: [:bar |
				methods doWithIndex: [:m :i |
					bar value: i.
					(m tryToInlineMethodsIn: self)
						ifTrue: [progress _ true]]]].

	'Inlining bytecodes'
		displayProgressAt: Sensor cursorPoint
		from: 1 to: 2
		during: [:bar |
			self inlineDispatchesInMethodNamed: #interpret
				localizingVars: #(currentBytecode localIP localSP localHomeContext).
			bar value: 1.
			self removeMethodsReferingToGlobals: #(
					currentBytecode localIP localSP localHomeContext)
				except: #interpret.
			bar value: 2].

	"make receiver on the next line false to generate code for all methods, even those that are inlined or unused"
	true ifTrue: [
		(methods includesKey: #interpret) ifTrue: [
			"only prune when generating the interpreter itself"
			self pruneUnreachableMethods]].
! !

!CCodeGenerator methodsFor: 'inlining'!
inlineDispatchesInMethodNamed: selector localizingVars: varsList
	"Inline dispatches (case statements) in the method with the given name."

	| m varString |
	m _ self methodNamed: selector.
	m = nil ifFalse: [
		m inlineCaseStatementBranchesIn: self localizingVars: varsList.
		m parseTree nodesDo: [ :n |
			n isCaseStmt ifTrue: [
				n customizeShortCasesForDispatchVar: 'currentBytecode'.
			].
		].
	].
	variables _ variables asOrderedCollection.
	varsList do: [ :v |
		varString _ v asString.
		variables remove: varString ifAbsent: [].
		(variableDeclarations includesKey: varString) ifTrue: [
			m declarations at: v asString put: (variableDeclarations at: varString).
			variableDeclarations removeKey: varString.
		].
	].
! !

!CCodeGenerator methodsFor: 'inlining'!
mayInline: sel
	"Answer true if the method with the given selector may be inlined."

	^ inlineList includes: sel! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ls 10/10/1999 13:55'!
methodStatsString
	"Return a string describing the size, # of locals, and # of senders of
each method. Note methods that have inline C code or C declarations."

	| methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s
calls registers selr m |
	methodsWithCCode _ Set new: methods size.
	sizesOf _ Dictionary new: methods size * 2.  "selector -> nodeCount"
	callsOf _ Dictionary new: methods size * 2.  "selector -> senderCount"

	"For each method, scan its parse tree once to:
		1. determine if the method contains C code or declarations
		2. determine how many nodes it has
		3. increment the sender counts of the methods it calls
		4. determine if it includes any C declarations or code"

	methods do: [ :m0 |  m _ m0.
		(translationDict includesKey: m selector) ifTrue: [
			hasCCode _ true.
		] ifFalse: [
			hasCCode _ m declarations size > 0.
			nodeCount _ 0.
			m parseTree nodesDo: [ :node |
				node isSend ifTrue: [
					selr _ node selector.
					selr = #cCode: ifTrue: [ hasCCode _ true ].
					senderCount _ callsOf at: selr ifAbsent: [ 0 ].
					callsOf at: selr put: senderCount + 1.
				].
				nodeCount _ nodeCount + 1.
			].
		].
		hasCCode ifTrue: [ methodsWithCCode add: m selector ].
		sizesOf at: m selector put: nodeCount.
	].

	s _ WriteStream on: (String new: 5000).
	methods keys asSortedCollection do: [ :sel |
		m _ methods at: sel.
		registers _ m locals size + m args size.
		calls _ callsOf at: sel ifAbsent: [0].
		registers > 11 ifTrue: [
			s nextPutAll: sel; tab.
			s nextPutAll: (sizesOf at: sel) printString; tab.
			s nextPutAll: calls printString; tab.
			s nextPutAll: registers printString; tab.
			(methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].
		s cr.
		].
	].
	^ s contents! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ar 2/3/2001 17:08'!
pruneMethods: selectorList
	"Explicitly prune some methods"
	selectorList do:[:sel| methods removeKey: sel ifAbsent:[]].! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 10/27/2000 15:02'!
pruneUnreachableMethods
	"Remove any methods that are not reachable. Retain methods needed by the BitBlt operation table, primitives, plug-ins, or interpreter support code."
 
	| retain |
	"Build a set of selectors for methods that should be output even though they have no apparent callers. Some of these are stored in tables for indirect lookup, some are called by the C support code or by primitives."
	retain _ BitBltSimulation opTable asSet.
	#(checkedLongAt: fullDisplayUpdate interpret printCallStack
	   readImageFromFile:HeapSize:StartingAt: success:
		"Windows needs the following two for startup and debug"
	   readableFormat: getCurrentBytecode
		"Jitter reuses all of these"
	   allocateChunk: characterForAscii:
	   findClassOfMethod:forReceiver: findSelectorOfMethod:forReceiver:
	   firstAccessibleObject loadInitialContext noteAsRoot:headerLoc:
	   nullCompilerHook
	   primitiveFloatAdd primitiveFloatDivide primitiveFloatMultiply
	   primitiveFloatSubtract primitiveFlushExternalPrimitives
	   setCompilerInitialized: splObj:)
			do: [:sel | retain add: sel].
	InterpreterProxy organization categories do: [:cat |
		((cat ~= 'initialize') and: [cat ~= 'private']) ifTrue: [
			retain addAll: (InterpreterProxy organization listAtCategoryNamed: cat)]].

	"Remove all the unreachable methods that aren't retained for the reasons above."
	self unreachableMethods do: [:sel |
		(retain includes: sel) ifFalse: [
			methods removeKey: sel ifAbsent: []]].
! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	"Remove all assertions in method bodies.  This is for the benefit of inlining, which
	fails to recognise and disregard empty method bodies when checking the inlinability
	of sends."

	| newMethods |
	newMethods _ Dictionary new.
	'Removing assertions...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: methods size
		during: [ :bar |
			methods doWithIndex: [ :m :i |
				bar value: i.
				m isAssertion ifFalse: [
					newMethods at: m selector put: m.
					m removeAssertions]]].
	methods _ newMethods.! !

!CCodeGenerator methodsFor: 'inlining'!
removeMethodsReferingToGlobals: varList except: methodName
	"Remove any methods (presumably inlined) that still contain references to the given obsolete global variables."

	| varListAsStrings removeIt mVars |
	varListAsStrings _ varList collect: [ :sym | sym asString ].
	methods keys copy do: [ :sel |
		removeIt _ false.
		mVars _ (self methodNamed: sel) freeVariableReferences asSet.
		varListAsStrings do: [ :v |
			(mVars includes: v) ifTrue: [ removeIt _ true ].
		].
		(removeIt and: [sel ~= methodName]) ifTrue: [
			methods removeKey: sel ifAbsent: [].
		].
	].! !


!CCodeGenerator methodsFor: 'utilities'!
addMethod: aTMethod
	"Add the given method to the code base."

	(methods includesKey:  aTMethod selector) ifTrue: [
		self error: 'Method name conflict: ', aTMethod selector.
	].
	methods at: aTMethod selector put: aTMethod.! !

!CCodeGenerator methodsFor: 'utilities'!
builtin: sel
	"Answer true if the given selector is one of the builtin selectors."

	((sel = #longAt:) or: [(sel = #longAt:put:) or: [sel = #error:]]) ifTrue: [ ^true ].
	((sel = #byteAt:) or: [sel = #byteAt:put:]) ifTrue: [ ^true ].
	^translationDict includesKey: sel! !

!CCodeGenerator methodsFor: 'utilities'!
cCodeForMethod: selector
	"Answer a string containing the C code for the given method."
	"Example:
		((CCodeGenerator new initialize addClass: TestCClass1; prepareMethods)
			cCodeForMethod: #ifTests)"

	| m s |
	m _ self methodNamed: selector.
	m = nil ifTrue: [ self error: 'method not found in code base: ', selector ].

	s _ (ReadWriteStream on: '').
	m emitCCodeOn: s generator: self.
	^ s contents! !

!CCodeGenerator methodsFor: 'utilities'!
emitBuiltinConstructFor: msgNode on: aStream level: level
	"If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."

	| action |
	action _ translationDict at: msgNode selector ifAbsent: [ ^false ].
	self perform: action with: msgNode with: aStream with: level.
	^true! !

!CCodeGenerator methodsFor: 'utilities' stamp: 'ar 10/7/1998 17:53'!
isGeneratingPluginCode
	^false! !

!CCodeGenerator methodsFor: 'utilities'!
methodNamed: selector
	"Answer the method in the code base with the given selector."

	^ methods at: selector ifAbsent: [ nil ]! !

!CCodeGenerator methodsFor: 'utilities'!
methodsReferringToGlobal: v
	"Return a collection of methods that refer to the given global variable."

	| out |
	out _ OrderedCollection new.
	methods associationsDo: [ :assoc |
		(assoc value freeVariableReferences includes: v) ifTrue: [
			out add: assoc key.
		].
	].
	^ out! !

!CCodeGenerator methodsFor: 'utilities'!
methodsThatCanInvoke: aSelectorList
	"Return a set of methods that can invoke one of the given selectors, either directly or via a sequence of intermediate methods."

	| out todo sel mSelector |
	out _ Set new.
	todo _ aSelectorList copy asOrderedCollection.
	[todo isEmpty] whileFalse: [
		sel _ todo removeFirst.
		out add: sel.
		methods do: [ :m |
			(m allCalls includes: sel) ifTrue: [
				mSelector _ m selector.
				((out includes: mSelector) or:
				 [todo includes: mSelector]) ifFalse: [
					todo add: mSelector.
				].
			].
		].
	].
	^ out
	! !

!CCodeGenerator methodsFor: 'utilities' stamp: 'jm 11/25/1998 19:02'!
nilOrBooleanConstantReceiverOf: sendNode
	"Answer nil or the boolean constant that is the receiver of the given message send. Used to suppress conditional code when the condition is a translation-time constant."

	| rcvr val |
	rcvr _ sendNode receiver.
	rcvr isConstant ifTrue: [
		val _ rcvr value.
		((val == true) or: [val == false]) ifTrue: [^ val]].
	^ nil
! !

!CCodeGenerator methodsFor: 'utilities'!
prepareMethods
	"Prepare methods for browsing."

	| globals |
	globals _ Set new: 200.
	globals addAll: variables.
	methods do: [ :m |
		(m locals, m args) do: [ :var |
			(globals includes: var) ifTrue: [
				self error: 'Local variable name may mask global when inlining: ', var.
			].
			(methods includesKey: var) ifTrue: [
				self error: 'Local variable name may mask method when inlining: ', var.
			].	
		].
		m bindClassVariablesIn: constants.
		m prepareMethodIn: self.
	].! !

!CCodeGenerator methodsFor: 'utilities'!
reportRecursiveMethods
	"Report in transcript all methods that can call themselves directly or indirectly or via a chain of N intermediate methods."

	| visited calls newCalls sel called |
	methods do: [: m |
		visited _ translationDict keys asSet.
		calls _ m allCalls asOrderedCollection.
		5 timesRepeat: [
			newCalls _ Set new: 50.
			[calls isEmpty] whileFalse: [
				sel _ calls removeFirst.
				sel = m selector ifTrue: [
					Transcript show: m selector, ' is recursive'; cr.
				] ifFalse: [
					(visited includes: sel) ifFalse: [
						called _ self methodNamed: sel.
						called = nil ifFalse: [ newCalls addAll: called allCalls ].
					].
					visited add: sel.
				].
			].
			calls _ newCalls asOrderedCollection.
		].
	].! !

!CCodeGenerator methodsFor: 'utilities' stamp: 'TPR 3/2/2000 11:45'!
translationMethodClass
	"return the class used to produce C translation methods from MethodNodes"
	^TMethod! !

!CCodeGenerator methodsFor: 'utilities' stamp: 'ar 7/17/1999 15:06'!
unreachableMethods
	"Return a collection of methods that are never invoked."

	| sent out |
	sent _ Set new.
	methods do: [ :m |
		m export ifTrue:[sent add: m selector].
		sent addAll: m allCalls.
	].

	out _ OrderedCollection new.
	methods keys do: [ :sel |
		(sent includes: sel) ifFalse: [ out add: sel ].
	].
	^ out! !


!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 2/21/2000 14:58'!
cFunctionNameFor: aSelector
	"Create a C function name from the given selector by omitting colons
	and prefixing with the plugin name if the method is exported."
	| meth |
	pluginPrefix == nil ifTrue:[^aSelector copyWithout: $:].
	meth _ methods at: aSelector ifAbsent:[nil].
	(meth notNil and:[meth export])
		ifTrue:[^pluginPrefix,'_', (aSelector copyWithout: $:)]
		ifFalse:[^aSelector copyWithout: $:].! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 11/19/1999 14:44'!
cLiteralFor: anObject
	"Return a string representing the C literal value for the given object."
	(anObject isKindOf: Integer) ifTrue: [
		(anObject < 16r7FFFFFFF)
			ifTrue: [^ anObject printString]
			ifFalse: [^ anObject printString , 'U']].
	(anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].
	(anObject isKindOf: Float) ifTrue: [^ anObject printString ].
	anObject == nil ifTrue: [^ 'null' ].
	anObject == true ifTrue: [^ '1' ].			"ikp"
	anObject == false ifTrue: [^ '0' ].			"ikp"
	(anObject isKindOf: Character) ifTrue:[^anObject asString printString]. "ar"
	self error:								"ikp"
		'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
	^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 2/21/2000 19:53'!
emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag
	"Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."

	| verbose methodList |
	"method preparation"
	verbose _ false.
	self prepareMethods.
	verbose ifTrue: [
		self printUnboundCallWarnings.
		self printUnboundVariableReferenceWarnings.
		Transcript cr.
	].
	assertionFlag ifFalse: [ self removeAssertions ].
	self doInlining: inlineFlag.

	"code generation"
	methodList _ methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].
	self emitCHeaderOn: aStream.
	self emitCVariablesOn: aStream.
	self emitCFunctionPrototypes: methodList on: aStream.
'Writing Translated Code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: methods size
during: [:bar |
	methodList doWithIndex: [ :m :i | bar value: i.
		m emitCCodeOn: aStream generator: self.
]].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCExpression: aParseNode on: aStream
	"Emit C code for the expression described by the given parse node."

	aParseNode isLeaf ifTrue: [
		"omit parens"
		aParseNode emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aStream nextPut: $(.
		aParseNode emitCCodeOn: aStream level: 0 generator: self.
		aStream nextPut: $).
	].! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 5/9/2000 11:58'!
emitCFunctionPrototypes: methodList on: aStream 
	"Store prototype declarations for all non-inlined methods on the given stream."
	| exporting |
	aStream nextPutAll: '/*** Function Prototypes ***/'; cr.
	isCPP ifTrue: [aStream nextPutAll: 'extern "C" {'; cr].
	exporting _ false.
	methodList do: [:m | 
		m export
			ifTrue: [exporting
					ifFalse: 
						[aStream nextPutAll: '#pragma export on'; cr.
						exporting _ true]]
			ifFalse: [exporting
					ifTrue: 
						[aStream nextPutAll: '#pragma export off'; cr.
						exporting _ false]].
		m emitCFunctionPrototype: aStream generator: self.
		aStream nextPutAll: ';'; cr].
	exporting ifTrue: [aStream nextPutAll: '#pragma export off'; cr].
	isCPP ifTrue: [aStream nextPutAll: '}'; cr]! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'TPR 4/10/2000 10:56'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: '#include "sq.h"'; cr; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
/* Memory Access Macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

/*** Imported Functions/Variables ***/
extern int stackValue(int);
extern int stackIntegerValue(int);
extern int successFlag;

/* allows accessing Strings in both C and Smalltalk */
#define asciiValue(c) c
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 5/17/1999 13:01'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: '#include "sq.h"'; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
/* memory access macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

int printCallStack(void);
void error(char *s);
void error(char *s) {
	/* Print an error message and exit. */
	static int printingStack = false;

	printf("\n%s\n\n", s);
	if (!!printingStack) {
		/* flag prevents recursive error when trying to print a broken stack */
		printingStack = true;
		printCallStack();
	}
	exit(-1);
}
'.
	aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCTestBlock: aBlockNode on: aStream
	"Emit C code for the given block node to be used as a loop test."

	aBlockNode statements size > 1 ifTrue: [
		aBlockNode emitCCodeOn: aStream level: 0 generator: self.
	] ifFalse: [
		aBlockNode statements first emitCCodeOn: aStream level: 0 generator: self.
	].! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ar 5/9/2000 14:50'!
emitCVariablesOn: aStream
	"Store the global variable declarations on the given stream."
	| varString |
	aStream nextPutAll: '/*** Variables ***/'; cr.
	variables asSortedCollection do: [ :var |
		(self isGeneratingPluginCode and:[self isTranslatingLocally])
			ifTrue:[aStream nextPutAll:'static '].
		varString _ var asString.
		(variableDeclarations includesKey: varString) ifTrue: [
			aStream nextPutAll: (variableDeclarations at: varString), ';'; cr.
		] ifFalse: [
			"default variable declaration"
			aStream nextPutAll: 'int ', varString, ';'; cr.
		].
	].
	aStream cr.! !


!CCodeGenerator methodsFor: 'C translation'!
generateAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 10/3/1998 13:45'!
generateAsFloat: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((double) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' )'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 10/3/1998 13:45'!
generateAsInteger: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'((int) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' )'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAt: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '['.
	msgNode args first emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ']'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAtPut: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '['.
	msgNode args first emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: '] = '.
	self emitCExpression: msgNode args last on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' & '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitInvert32: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '~'.
	self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' | '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitShift: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| arg rcvr |
	arg _ msgNode args first.
	rcvr _ msgNode receiver.
	arg isConstant ifTrue: [
		"bit shift amount is a constant"
		aStream nextPutAll: '((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		arg value < 0 ifTrue: [
			aStream nextPutAll: ' >> ', arg value negated printString.
		] ifFalse: [
			aStream nextPutAll: ' << ', arg value printString.
		].
		aStream nextPutAll: ')'.
	] ifFalse: [
		"bit shift amount is an expression"
		aStream nextPutAll: '(('.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ' < 0) ? ((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> -'.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: ') : ((unsigned) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' << '.
		self emitCExpression: arg on: aStream.
		aStream nextPutAll: '))'.
	].! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitXor: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' ^ '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateCCoercion: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	aStream nextPutAll: msgNode args last value.
	aStream nextPutAll: ') '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ')'.

! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'len 2/13/1999 06:33'!
generateDivide: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| rcvr arg divisor |
	rcvr _ msgNode receiver.
	arg _ msgNode args first.
	(arg isConstant and:
	 [UseRightShiftForDivide and:
	 [(divisor _ arg value) isInteger and:
	 [divisor isPowerOfTwo and:
	 [divisor > 0 and:
	 [divisor <= (1 bitShift: 31)]]]]])
	ifTrue: [
		"use signed (arithmetic) right shift instead of divide"
		aStream nextPutAll: '((int) '.
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString.
		aStream nextPutAll: ')'.
	] ifFalse: [
		self emitCExpression: rcvr on: aStream.
		aStream nextPutAll: ' / '.
		self emitCExpression: arg on: aStream].
! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:40'!
generateDoWhileFalse: msgNode on: aStream indent: level
	"Generate do {stmtList} while(!!(cond))"

	| stmts testStmt |
	stmts _ msgNode receiver statements asOrderedCollection.
	testStmt _ stmts removeLast.
	msgNode receiver setStatements: stmts.
	aStream nextPutAll: 'do {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} while(!!('.
	testStmt emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: '))'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:39'!
generateDoWhileTrue: msgNode on: aStream indent: level
	"Generate do {stmtList} while(cond)"

	| stmts testStmt |
	stmts _ msgNode receiver statements asOrderedCollection.
	testStmt _ stmts removeLast.
	msgNode receiver setStatements: stmts.
	aStream nextPutAll: 'do {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} while('.
	testStmt emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' > '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' >= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 11/25/1998 19:04'!
generateIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler produces two arguments for ifFalse:, presumably
	 to help with inlining later. Taking the last agument should do the correct
	 thing even if your compiler is different."

	| const |
	const _ self nilOrBooleanConstantReceiverOf: msgNode.
	const ifNotNil: [
		const ifFalse: [msgNode args first emitCCodeOn: aStream level: level generator: self].
		^ self].

	aStream nextPutAll: 'if (!!('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ')) {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 11/25/1998 19:06'!
generateIfFalseIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler reverses the argument blocks for ifFalse:ifTrue:,
       presumably to help with inlining later. That is, the first argument
       is the block to be evaluated if the condition is true. Squeak's compiler
	  does not reverse the blocks, but you may need to fix this method if
	  you wish to cross-compile using VisualWorks."

	| const |
	const _ self nilOrBooleanConstantReceiverOf: msgNode.
	const ifNotNil: [
		const
			ifTrue: [msgNode args last emitCCodeOn: aStream level: level generator: self]
			ifFalse: [msgNode args first emitCCodeOn: aStream level: level generator: self].
		^ self].

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} else {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 11/25/1998 19:04'!
generateIfTrue: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| const |
	const _ self nilOrBooleanConstantReceiverOf: msgNode.
	const ifNotNil: [
		const ifTrue: [msgNode args first emitCCodeOn: aStream level: level generator: self].
		^ self].

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 11/25/1998 19:04'!
generateIfTrueIfFalse: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| const |
	const _ self nilOrBooleanConstantReceiverOf: msgNode.
	const ifNotNil: [
		const
			ifTrue: [msgNode args first emitCCodeOn: aStream level: level generator: self]
			ifFalse: [msgNode args last emitCCodeOn: aStream level: level generator: self].
		^ self].

	aStream nextPutAll: 'if ('.
	msgNode receiver emitCCodeOn: aStream level: level generator: self.
	aStream nextPutAll: ') {'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '} else {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineCCode: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: msgNode args first value.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* inline: '.
	aStream nextPutAll: msgNode args first name.
	aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerObjectOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' << 1) | 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerValueOf: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' >> 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsIntegerObject: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '('.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' & 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' == '.
	aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThan: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThanOrEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' <= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMax: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMin: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '(('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' < '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ') ? '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' : '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMinus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' - '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateModulo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' % '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNot: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '!!'.
	self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotEqual: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotNil: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' !!= '.
	aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 5/25/2000 16:36'!
generatePerform: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '('.
	(msgNode args copyFrom: 2 to: msgNode args size) do:[:arg|
		self emitCExpression: arg on: aStream.
	] separatedBy:[aStream nextPutAll:', '].
	aStream nextPutAll:')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePlus: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' + '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreDecrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode _ msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preDecrement can only be applied to variables' ].
	aStream nextPutAll: '--'.
	aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreIncrement: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode _ msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'preIncrement can only be applied to variables' ].
	aStream nextPutAll: '++'.
	aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 2/15/1999 21:43'!
generateRaisedTo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll:'pow('.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll:')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialAnd: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' && ('.
	self emitCTestBlock: msgNode args first on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialOr: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."
	"Note: PP 2.3 compiler produces two arguments for or:, presumably
	 to help with inlining later. Taking the last agument should do the correct
	 thing even if your compiler is different."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' || ('.
	self emitCTestBlock: msgNode args last on: aStream.
	aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSharedCodeDirective: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '/* common code: '.
	aStream nextPutAll: msgNode args first value.
	aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftLeft: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' << '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftRight: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	aStream nextPutAll: '((unsigned) '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ')'.
	aStream nextPutAll: ' >> '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateTimes: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: ' * '.
	self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'len 2/13/1999 07:36'!
generateToByDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar step |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar _ msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar,
		(((step _ msgNode args at: 2) isConstant and: [step value > 0])
			ifTrue: [' <= '] ifFalse: [' >= ']).
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' += '.
	self emitCExpression: step on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateToDo: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| iterationVar |
	(msgNode args last args size = 1) ifFalse: [
		self error: 'wrong number of block arguments'.
	].
	iterationVar _ msgNode args last args first.
	aStream nextPutAll: 'for (', iterationVar, ' = '.
	self emitCExpression: msgNode receiver on: aStream.
	aStream nextPutAll: '; ', iterationVar, ' <= '.
	self emitCExpression: msgNode args first on: aStream.
	aStream nextPutAll: '; ', iterationVar, '++) {'; cr.
	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileFalse: msgNode on: aStream indent: level
	"Generate C code for a loop in one of the following formats, as appropriate:
		while(!!(cond)) { stmtList }
		do {stmtList} while(!!(cond))
		while(1) {stmtListA; if (cond) break; stmtListB}"

	msgNode receiver statements size <= 1
		ifTrue: [^self generateWhileFalseLoop: msgNode on: aStream indent: level].
	msgNode args first isNilStmtListNode
		ifTrue: [^self generateDoWhileFalse: msgNode on: aStream indent: level].
	^self generateWhileForeverBreakTrueLoop: msgNode on: aStream indent: level! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileFalseLoop: msgNode on: aStream indent: level
	"Generate while(!!(cond)) {stmtList}."

	aStream nextPutAll: 'while (!!('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ')) {'; cr.
	msgNode args first isNilStmtListNode ifFalse:
		[msgNode args first emitCCodeOn: aStream level: level + 1 generator: self].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:40'!
generateWhileForeverBreakFalseLoop: msgNode on: aStream indent: level
	"Generate while(1) {stmtListA; if(!!(cond)) break; stmtListB}."

	| stmts testStmt |
	stmts _ msgNode receiver statements asOrderedCollection.
	testStmt _ stmts removeLast.
	msgNode receiver setStatements: stmts.
	level - 1 timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'while (1) {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	(level + 1) timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'if (!!('.
	testStmt emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ')) break;'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:38'!
generateWhileForeverBreakTrueLoop: msgNode on: aStream indent: level
	"Generate while(1) {stmtListA; if(cond) break; stmtListB}."

	| stmts testStmt |
	stmts _ msgNode receiver statements asOrderedCollection.
	testStmt _ stmts removeLast.
	msgNode receiver setStatements: stmts.
	level - 1 timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'while (1) {'; cr.
	msgNode receiver emitCCodeOn: aStream level: level + 1 generator: self.
	(level + 1) timesRepeat: [ aStream tab ].
	aStream nextPutAll: 'if ('.
	testStmt emitCCodeOn: aStream level: 0 generator: self.
	aStream nextPutAll: ') break;'; cr.
	msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:41'!
generateWhileTrue: msgNode on: aStream indent: level
	"Generate C code for a loop in one of the following formats, as appropriate:
		while(cond) { stmtList }
		do {stmtList} while(cond)
		while(1) {stmtListA; if (!!(cond)) break; stmtListB}"

	msgNode receiver statements size <= 1
		ifTrue: [^self generateWhileTrueLoop: msgNode on: aStream indent: level].
	msgNode args first isNilStmtListNode
		ifTrue: [^self generateDoWhileTrue: msgNode on: aStream indent: level].
	^self generateWhileForeverBreakFalseLoop: msgNode on: aStream indent: level! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'acg 12/22/1999 01:38'!
generateWhileTrueLoop: msgNode on: aStream indent: level
	"Generate while(cond) {stmtList}."

	aStream nextPutAll: 'while ('.
	self emitCTestBlock: msgNode receiver on: aStream.
	aStream nextPutAll: ') {'; cr.
	msgNode args first isNilStmtListNode ifFalse:
		[msgNode args first emitCCodeOn: aStream level: level + 1 generator: self].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'ar 5/25/2000 16:36'!
initializeCTranslationDictionary 
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	translationDict _ Dictionary new: 200.
	pairs _ #(
	#&				#generateAnd:on:indent:
	#|				#generateOr:on:indent:
	#and:			#generateSequentialAnd:on:indent:
	#or:			#generateSequentialOr:on:indent:
	#not			#generateNot:on:indent:

	#+				#generatePlus:on:indent:
	#-				#generateMinus:on:indent:
	#*				#generateTimes:on:indent:
	#/				#generateDivide:on:indent:
	#//				#generateDivide:on:indent:
	#\\				#generateModulo:on:indent:
	#<<				#generateShiftLeft:on:indent:
	#>>				#generateShiftRight:on:indent:
	#min:			#generateMin:on:indent:
	#max:			#generateMax:on:indent:

	#bitAnd:		#generateBitAnd:on:indent:
	#bitOr:			#generateBitOr:on:indent:
	#bitXor:			#generateBitXor:on:indent:
	#bitShift:		#generateBitShift:on:indent:
	#bitInvert32	#generateBitInvert32:on:indent:

	#<				#generateLessThan:on:indent:
	#<=				#generateLessThanOrEqual:on:indent:
	#=				#generateEqual:on:indent:
	#>				#generateGreaterThan:on:indent:
	#>=				#generateGreaterThanOrEqual:on:indent:
	#~=				#generateNotEqual:on:indent:
	#==				#generateEqual:on:indent:
	#~~				#generateNotEqual:on:indent:
	#isNil			#generateIsNil:on:indent:
	#notNil			#generateNotNil:on:indent:

	#whileTrue: 	#generateWhileTrue:on:indent:
	#whileFalse:	#generateWhileFalse:on:indent:
	#whileTrue 		#generateDoWhileTrue:on:indent:
	#whileFalse		#generateDoWhileFalse:on:indent:
	#to:do:			#generateToDo:on:indent:
	#to:by:do:		#generateToByDo:on:indent:

	#ifTrue:		#generateIfTrue:on:indent:
	#ifFalse:		#generateIfFalse:on:indent:
	#ifTrue:ifFalse:	#generateIfTrueIfFalse:on:indent:
	#ifFalse:ifTrue:	#generateIfFalseIfTrue:on:indent:

	#at:				#generateAt:on:indent:
	#at:put:			#generateAtPut:on:indent:
	#basicAt:		#generateAt:on:indent:
	#basicAt:put:	#generateAtPut:on:indent:

	#integerValueOf:	#generateIntegerValueOf:on:indent:
	#integerObjectOf:	#generateIntegerObjectOf:on:indent:
	#isIntegerObject: 	#generateIsIntegerObject:on:indent:
	#cCode:				#generateInlineCCode:on:indent:
	#cCode:inSmalltalk:	#generateInlineCCode:on:indent:
	#cCoerce:to:			#generateCCoercion:on:indent:
	#preIncrement		#generatePreIncrement:on:indent:
	#preDecrement		#generatePreDecrement:on:indent:
	#inline:				#generateInlineDirective:on:indent:
	#sharedCodeNamed:inCase:	#generateSharedCodeDirective:on:indent:
	#asFloat				#generateAsFloat:on:indent:
	#asInteger			#generateAsInteger:on:indent:
	#anyMask:			#generateBitAnd:on:indent:
	#raisedTo:			#generateRaisedTo:on:indent:

	#perform:						#generatePerform:on:indent:
	#perform:with:					#generatePerform:on:indent:
	#perform:with:with:				#generatePerform:on:indent:
	#perform:with:with:with:		#generatePerform:on:indent:
	#perform:with:with:with:with:	#generatePerform:on:indent:

	).

	1 to: pairs size by: 2 do: [:i |
		translationDict at: (pairs at: i) put: (pairs at: i + 1)].
! !


!CCodeGenerator methodsFor: 'private' stamp: 'sma 3/3/2000 12:08'!
printArray: array on: aStream
	| first |
	first _ true.
	1 to: array size do:
		[:i |
		first 
			ifTrue: [first _ false]
			ifFalse: [aStream nextPutAll: ', '].
		i \\ 16 = 1 ifTrue: [aStream cr].
		self printInt: (array at: i) on: aStream]! !

!CCodeGenerator methodsFor: 'private' stamp: 'sma 3/3/2000 12:13'!
printInt: int on: aStream
	aStream print: int.
	(int between: -2147483648 and: 2147483647)
		ifFalse: [(int between: 2147483648 and: 4294967295)
			ifTrue: [aStream nextPut: $U]
			ifFalse: [aStream nextPut: $L]]! !

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

CCodeGenerator class
	instanceVariableNames: ''!

!CCodeGenerator class methodsFor: 'removing from system' stamp: 'jm 5/16/1998 10:26'!
removeCompilerMethods
	"Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes."

	ParseNode withAllSubclasses do: [ :nodeClass |
		nodeClass removeCategory: 'C translation'.
	].
	Smalltalk at: #AbstractSound ifPresent: [:abstractSound |
		 abstractSound class removeCategory: 'primitive generation'].
! !


!CCodeGenerator class methodsFor: 'class initialization' stamp: 'jm 8/19/1998 10:03'!
initialize
	"CCodeGenerator initialize"

	UseRightShiftForDivide _ true.
		"If UseRightShiftForDivide is true, the translator will generate a right-shift when it encounters a division by a constant that is a small power of two. For example, 'x / 8' will generate '((int) x >> 3)'. The coercion to int is done to make it clear that the C compiler should generate a signed shift."
		"Note: The Kernighan and Ritchie 2nd Edition C manual, p. 49, leaves the semantics of right-shifting a negative number open to the discretion of the compiler implementor. However, it strongly suggests that most compilers should generate an arithmetic right shift (i.e., shifting in the sign bit), which is the same as dividing by a power of two. If your compiler does not generate or simulate an arithmetic shift, then make this class variable false and re-translate."
! !
Object subclass: #CObjectAccessor
	instanceVariableNames: 'object offset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!CObjectAccessor commentStamp: '<historical>' prior: 0!
I am used to simulate the indexed access to any object during plugin simulation.!


!CObjectAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index
	^object instVarAt: index + offset + 1! !

!CObjectAccessor methodsFor: 'accessing' stamp: 'ar 10/9/1998 21:56'!
at: index put: value
	^object instVarAt: index + offset + 1 put: value! !


!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:57'!
+ increment
	^self clone += increment! !

!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:57'!
+= increment
	offset _ offset + increment! !

!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:58'!
- decrement
	^self clone -= decrement! !

!CObjectAccessor methodsFor: 'pointer arithmetic' stamp: 'ar 10/9/1998 21:58'!
-= decrement
	offset _ offset - decrement! !


!CObjectAccessor methodsFor: 'printing' stamp: 'ar 9/16/1998 21:38'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll:' on: ';
		print: object.! !

!CObjectAccessor methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:01'!
printOnStream: aStream
	super printOnStream: aStream.
	aStream
		print:' on: ';
		write: object.! !


!CObjectAccessor methodsFor: 'private' stamp: 'ar 11/3/1998 22:37'!
getObject
	^object! !

!CObjectAccessor methodsFor: 'private' stamp: 'ar 10/9/1998 21:56'!
setObject: anObject
	object _ anObject.
	offset _ 0.! !


!CObjectAccessor methodsFor: 'converting' stamp: 'acg 9/20/1999 11:08'!
asOop: aClass

	(aClass ccgCanConvertFrom: object)
		ifFalse: [^self error: 'incompatible object for autocoercion'].
	^object! !

!CObjectAccessor methodsFor: 'converting' stamp: 'ar 11/24/1998 20:51'!
asPluggableAccessor: accessorArray
	^((CPluggableAccessor on: object) += offset)
		readBlock: accessorArray first
		writeBlock: accessorArray last! !

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

CObjectAccessor class
	instanceVariableNames: ''!

!CObjectAccessor class methodsFor: 'instance creation' stamp: 'ar 9/16/1998 21:36'!
on: anObject
	^self new setObject: anObject! !
CArrayAccessor subclass: #CPluggableAccessor
	instanceVariableNames: 'readBlock writeBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!CPluggableAccessor methodsFor: 'initialize' stamp: 'ar 11/24/1998 20:51'!
readBlock: rBlock writeBlock: wBlock
	readBlock _ rBlock.
	writeBlock _ wBlock! !


!CPluggableAccessor methodsFor: 'accessing' stamp: 'ar 11/24/1998 20:45'!
at: index
	^readBlock value: object value: index + offset + 1! !

!CPluggableAccessor methodsFor: 'accessing' stamp: 'ar 11/24/1998 20:45'!
at: index put: value
	^writeBlock value: object value: index + offset + 1 value: value! !
HTTPRequest subclass: #CachedHTTPRequest
	instanceVariableNames: 'cachedName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!

!CachedHTTPRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'!
cachedName
	^cachedName! !

!CachedHTTPRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 14:53'!
cachedName: aString
	cachedName _ aString.! !

!CachedHTTPRequest methodsFor: 'accessing' stamp: 'ar 12/14/1999 15:00'!
startRetrieval
	| fileStream |
	cachedName == nil ifTrue:[^super startRetrieval].
	(FileDirectory default fileExists: cachedName) ifTrue:[
		fileStream _ FileStream concreteStream new open: cachedName forWrite: false.
		fileStream == nil ifFalse:[^self content: 
			(MIMEDocument 
				contentType: 'text/plain' 
				content: fileStream contentsOfEntireFile)].
		FileDirectory default deleteFileNamed: cachedName ifAbsent:[]].
	super startRetrieval. "fetch from URL"
	"and cache in file dir"
	fileStream _ FileStream concreteStream new open: cachedName forWrite: true.
	fileStream == nil ifFalse:[
		fileStream nextPutAll: (content content).
		fileStream close].! !
SwikiAction subclass: #CachedSwikiAction
	instanceVariableNames: 'cacheDirectory cacheURL pwsURL '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!CachedSwikiAction commentStamp: '<historical>' prior: 0!
CachedSwikiAction caches SwikiAction pages so that they can be served as plain HTML files (no embedded Squeak code) even by a native webServer. 

You must edit three class methods in CachedSwikiAction to get it to serve appropriately.

* CachedSwikiAction class defaultCacheDirectory is where to store cached pages
* CachedSwikiAction class defaultCacheURL is the URL to precede cached pages
* CachedSwikiAction class defaultPWSURL is where the PWS is that can handle editing and searching.

!
]style[(25 12 201 45 34 39 38 37 61)f1,f1LSwikiAction Comment;,f1,f1LCachedSwikiAction class defaultCacheDirectory;,f1,f1LCachedSwikiAction class defaultCacheURL;,f1,f1LCachedSwikiAction class defaultPWSURL;,f1!


!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/18/98 12:44'!
restore: nameOfSwiki
	super restore: nameOfSwiki.
	self source: 'cswiki',(ServerAction pathSeparator).
	self cacheDirectory: (self class defaultCacheDirectory).
	self cacheURL: (self class defaultCacheURL).
	self pwsURL: (self class defaultPWSURL).
	self generate.
! !

!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/23/98 11:35'!
restoreNoGen: nameOfSwiki
	super restore: nameOfSwiki.
	self source: 'cswiki',(ServerAction pathSeparator).
	self cacheDirectory: (self class defaultCacheDirectory).
	self cacheURL: (self class defaultCacheURL).
	self pwsURL: (self class defaultPWSURL).
	"self generate."
! !


!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 9/1/1998 12:44'!
browse: pageRef from: request
	"Just reply with a page in HTML format"

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

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:34'!
generate
	1 to: (urlmap pages size) do: [:ref |
		self generate: (urlmap atID: ref) from: 'Beginning'.].
	self generateRecent.
! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'TPR 7/21/1998 18:14'!
generate: pageRef from: request
	"Just reply with a page in HTML format"

	| formattedPage peer cacheFile file|
	(request isKindOf: PWS)
	ifFalse: [(request isKindOf: String) ifTrue: [peer _ request]
ifFalse: [peer _ ' ']]
	ifTrue: [peer _ request peerName].
	formattedPage _ pageRef copy.
	"Make a copy, then format the text."
	formattedPage formatted: (HTMLformatter swikify: pageRef text
			linkhandler: [:link | urlmap
					linkFor: link
					from: peer
					storingTo: OrderedCollection new]).
	cacheFile _ (self cacheDirectory),(self name),(ServerAction
pathSeparator),(pageRef coreID),'.html'.
	(StandardFileStream isAFileNamed: cacheFile)
	ifTrue: [FileDirectory deleteFilePath: cacheFile].
	file _ FileStream fileNamed: cacheFile.
	file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents:
source ,'page.html')
			with: formattedPage).
	file close.

! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'TPR 7/21/1998 18:15'!
generateRecent
	| file |
	file _ FileStream fileNamed: (self cacheDirectory),(self
name),(ServerAction pathSeparator),'recent.html'.
	file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents:
source, 'recent.html')
					with: urlmap recent).
	file close.! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 10/13/1998 12:29'!
inputFrom: request
	"Take user's input and respond with a searchresult or store the edit"

	| coreRef page theText |
	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].
	(theText _ request fields at: 'text' ifAbsent: [nil]) ifNotNil: [
		"It's a response from an edit, so store the page"
		page _ urlmap atID: coreRef.
		page user: request peerName.  "Address is machine, user only if logged in"
		 page pageStatus = #new ifTrue: [page pageStatus: #standard].
		page _ urlmap
			storeID: coreRef
			text: theText withSqueakLineEndings
			from: request peerName.
		self generate: (urlmap atID: coreRef) from: request.
		self generateRecent.

		^ self].	"return self means do serve the edited page afterwards"
	request fields keys do: [:aTag |
		(aTag beginsWith: 'text-') ifTrue: [
			urlmap
				storeID: coreRef
				text: (request fields at: aTag) withSqueakLineEndings
				insertAt: (aTag copyFrom: 6 to: aTag size).
	"string"
		self generate: (urlmap atID: coreRef) from: request.
		self generateRecent.
			^ self]].		"oops, a new kind!!"
	Transcript show: 'Unknown data from client. '; show: request fields
printString; cr.! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'BJP 9/9/1998 21:34'!
pageURL: aPage
	"make the url suited to aPage"
	^(self url),(self name),'/',aPage coreID,'.html'! !


!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory
	^cacheDirectory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory: directory
	cacheDirectory _ directory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL
	^cacheURL! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL: urlString
	cacheURL _ urlString! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL
	^pwsURL	! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL: urlString
	pwsURL _ urlString	! !

!CachedSwikiAction methodsFor: 'access' stamp: 'TPR 7/21/1998 18:05'!
url
	^cacheURL! !

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

CachedSwikiAction class
	instanceVariableNames: ''!

!CachedSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:58'!
setUp: named
	| newAction |
	super setUp: named.
	newAction _ PWS actions at: named.
	newAction cacheDirectory: (self defaultCacheDirectory).
	newAction cacheURL: (self defaultCacheURL).
	newAction source: 'cswiki',(ServerAction pathSeparator).
	^ newAction! !


!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheDirectory
	^'Guz 7600:WebSTAR 2.0:'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheURL
	^'http://guzdial.cc.gatech.edu/'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultPWSURL
	^'http://guzdial.cc.gatech.edu:8080/'! !
PluggableCanvas subclass: #CachingCanvas
	instanceVariableNames: 'cacheCanvas mainCanvas '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!CachingCanvas commentStamp: '<historical>' prior: 0!
A canvas which has a hidden form caching the events.  contentsOfArea:into: uses the cache, instead of the main canvas.  This is typically used with remote canvases, where querying the bits would involve a network transaction.
!


!CachingCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
mainCanvas: mainCanvas0
	mainCanvas := mainCanvas0.
	cacheCanvas := FormCanvas extent: mainCanvas extent depth: mainCanvas depth.! !


!CachingCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/20/2000 13:08'!
allocateForm: extentPoint

	^cacheCanvas form allocateForm: extentPoint! !

!CachingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/26/2000 13:35'!
apply: aBlock
	aBlock value: cacheCanvas.
	aBlock value: mainCanvas.! !

!CachingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/27/2000 22:50'!
contentsOfArea: area  into: aForm
	^cacheCanvas contentsOfArea: area  into: aForm! !

!CachingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/26/2000 20:21'!
form
	^cacheCanvas form! !

!CachingCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/21/2000 09:54'!
showAt: pt  invalidRects: rects

	mainCanvas showAt: pt  invalidRects: rects! !

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

CachingCanvas class
	instanceVariableNames: ''!

!CachingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/26/2000 13:37'!
on: aCanvas
	^super new mainCanvas: aCanvas! !
CodeLoader subclass: #CachingCodeLoader
	instanceVariableNames: 'cacheDir '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
cacheDir
	^cacheDir! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
cacheDir: aString
	cacheDir _ aString.! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
localCache: stringArray
	| fd |
	fd _ FileDirectory default.
	stringArray do:[:part|
		(fd directoryNames includes: part) 
			ifFalse:[fd createDirectory: part].
		fd _ fd directoryNamed: part].
	self cacheDir: (fd pathName copyWith: fd pathNameDelimiter).! !

!CachingCodeLoader methodsFor: 'accessing' stamp: 'mir 12/22/1999 14:10'!
localCacheDir: aString
	self cacheDir:
		(FileDirectory default pathName,
		FileDirectory slash,
		aString,
		FileDirectory slash)! !


!CachingCodeLoader methodsFor: 'private' stamp: 'mir 12/22/1999 14:11'!
createRequestFor: name in: aLoader
	| request |
	request _ super createRequestFor: name in: aLoader.
	request cachedName: cacheDir, name.
	^request! !

!CachingCodeLoader methodsFor: 'private' stamp: 'mir 12/22/1999 14:12'!
httpRequestClass
	^CachedHTTPRequest
! !
Morph subclass: #CachingMorph
	instanceVariableNames: 'damageRecorder cacheCanvas '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!CachingMorph commentStamp: '<historical>' prior: 0!
This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.!


!CachingMorph methodsFor: 'as yet unclassified'!
drawOn: aCanvas

	submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'ar 5/28/2000 17:12'!
fullDrawOn: aCanvas

	self updateCacheCanvas: aCanvas.
	aCanvas cache: self fullBounds
			using: cacheCanvas form
			during:[:cachingCanvas| super fullDrawOn: cachingCanvas].
! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'ar 5/28/2000 17:12'!
imageForm

	self updateCacheCanvas: Display getCanvas.
	^ cacheCanvas form offset: self fullBounds topLeft
! !

!CachingMorph methodsFor: 'as yet unclassified'!
initialize

	super initialize.
	color _ Color veryLightGray.
	damageRecorder _ DamageRecorder new.
! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/12/2000 18:43'!
invalidRect: damageRect from: aMorph
	"Record the given rectangle in the damage list."
	damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated).
	super invalidRect: damageRect from: aMorph! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/13/97 16:31'!
releaseCachedState

	super releaseCachedState.
	cacheCanvas _ nil.
! !

!CachingMorph methodsFor: 'as yet unclassified' stamp: 'ar 5/28/2000 17:12'!
updateCacheCanvas: aCanvas
	"Update the cached image of the morphs being held by this hand."

	| myBnds rectList |
	myBnds _ self fullBounds.
	(cacheCanvas == nil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [
		cacheCanvas _ (aCanvas allocateForm: myBnds extent) getCanvas.
		cacheCanvas translateBy: myBnds origin negated
			during:[:tempCanvas| super fullDrawOn: tempCanvas].
		^self].

	"incrementally update the cache canvas"
	rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: myBnds extent).
	damageRecorder reset.
	rectList do: [:r |
		cacheCanvas translateTo: myBnds origin negated clippingTo: r during:[:c|
			c fillColor: Color transparent.  "clear to transparent"
			super fullDrawOn: c]].
! !
FlattenEncoder subclass: #Canvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!Canvas commentStamp: '<historical>' prior: 0!
A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).

Subclasses must implement (at least) the following methods:
	* Drawing:
		#fillOval:color:borderWidth:borderColor:
		#frameAndFillRectangle:fillColor:borderWidth:borderColor:
		#drawPolygon:color:borderWidth:borderColor:
		#image:at:sourceRect:rule:
		#stencil:at:sourceRect:rule:
		#line:to:width:color:
		#paragraph:bounds:color:
		#text:bounds:font:color:
	* Support
		#clipBy:during:
		#translateBy:during:
		#translateBy:clippingTo:during:
		#transformBy:clippingTo:during:
!


!Canvas methodsFor: 'initialization' stamp: 'ar 5/27/2000 21:50'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
	^self flush! !

!Canvas methodsFor: 'initialization' stamp: 'ar 2/9/1999 06:29'!
flush! !

!Canvas methodsFor: 'initialization' stamp: 'di 9/22/1999 19:21'!
reset
	"Reset the canvas."

	super initWithTarget:self class defaultTarget.
! !


!Canvas methodsFor: 'copying' stamp: 'jm 8/2/97 13:54'!
copy

	^ self clone
! !

!Canvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:24'!
copyClipRect: newClipRect

	^ ClippingCanvas canvas: self clipRect: newClipRect
! !


!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:07'!
clipRect
	"Return the currently active clipping rectangle"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'!
contentsOfArea: aRectangle
	"Return the contents of the given area"
	^self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth)! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/12/2000 18:17'!
contentsOfArea: aRectangle into: aForm
	"Return the contents of the given area"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing'!
depth

	^ Display depth
! !

!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'!
extent
	"Return the physical extent of the output device"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'!
form

	^ Display
! !

!Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'!
origin
	"Return the current origin for drawing operations"
	^self subclassResponsibility! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'!
shadowColor
	"Return the current override color or nil if no such color exists"
	^nil! !

!Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'!
shadowColor: aColor
	"Set a shadow color. If set this color overrides any client-supplied color."! !


!Canvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'!
doesRoundedCorners 

	^ true! !

!Canvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'!
isBalloonCanvas
	^false! !

!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 19:03'!
isShadowDrawing
	^false! !

!Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:10'!
isVisible: aRectangle
	"Return true if the given rectangle is (partially) visible"
	^self clipRect intersects: aRectangle
! !

!Canvas methodsFor: 'testing' stamp: 'di 9/24/2000 16:10'!
seesNothingOutside: aRectangle
	"Return true if this canvas will not touch anything outside aRectangle"
	^ aRectangle containsRect: self clipRect
! !


!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:18'!
fillColor: aColor
	"Fill the receiver with the given color.
	Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent"
	^self fillRectangle: self clipRect color: (aColor alpha: 1.0).! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:30'!
line: pt1 to: pt2 brushForm: brush
	"Obsolete - will be removed in the future"! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
line: pt1 to: pt2 color: c

	self line: pt1 to: pt2 width: 1 color: c.
! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'!
line: pt1 to: pt2 width: w color: c
	"Draw a line using the given width and color"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: 'di 9/9/2000 12:51'!
line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset
	"Draw a line using the given width, colors and dash lengths.
	Originally written by Stephan Rudlof; tweaked by Dan Ingalls
	to use startingOffset for sliding offset as in 'ants' animations.
	Returns the sum of the starting offset and the length of this line."

	| dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens |
	dist _ pt1 dist: pt2.
	dist = 0 ifTrue: [^ startingOffset].
	s1 = 0 & (s2 = 0) ifTrue: [^ startingOffset].
	deltaBig _ pt2 - pt1.
	colors _ {color1. color2}.
	segLens _ {s1 asFloat. s2 asFloat}.
	nextPhase _ {2. 1}.

	"Figure out what phase we are in and how far, given startingOffset."
	segmentOffset _ startingOffset \\ (s1 + s2).
	segmentOffset < s1
		ifTrue: [phase _ 1.  segmentLength _ s1 - segmentOffset]
		ifFalse: [phase _ 2. segmentLength _ s1 + s2 - segmentOffset].
	startPoint _ pt1.
	distDone _ 0.0.

	[distDone < dist] whileTrue:
		[segmentLength _ segmentLength min: dist - distDone.
		endPoint _ startPoint + (deltaBig * segmentLength / dist).
		self line: startPoint truncated to: endPoint truncated
			width: width color: (colors at: phase).
		distDone _ distDone + segmentLength.
		phase _ nextPhase at: phase.
		startPoint _ endPoint.
		segmentLength _ segLens at: phase].

	^ startingOffset + dist! !

!Canvas methodsFor: 'drawing' stamp: 'sr 4/27/2000 03:31'!
line: pt1 to: pt2 width: w1 color: c1 stepWidth: s1 secondWidth: w2 secondColor: c2 secondStepWidth: s2 
	"Draw a line using the given width, colors and steps; both steps can  
	have different stepWidths (firstStep, secondStep), draw widths and  
	colors."
	| bigSteps offsetPoint dist p1p2Vec deltaBig delta1 delta2 lastPoint bigStep |
	s1 = 0 & (s2 = 0) ifTrue: [^ self].
	dist _ pt1 dist: pt2.
	dist = 0 ifTrue: [^ self].
	bigStep _ s1 + s2.
	bigSteps _ dist / bigStep.
	p1p2Vec _ pt2 - pt1.
	deltaBig _ p1p2Vec / bigSteps.
	delta1 _ deltaBig * (s1 / bigStep).
	delta2 _ deltaBig * (s2 / bigStep).
	dist <= s1
		ifTrue: 
			[self
				line: pt1 rounded
				to: pt2 rounded
				width: w1
				color: c1.
			^ self].
	0 to: bigSteps truncated - 1 do: 
		[:bigStepIx | 
		self
			line: (pt1 + (offsetPoint _ deltaBig * bigStepIx)) rounded
			to: (pt1 + (offsetPoint _ offsetPoint + delta1)) rounded
			width: w1
			color: c1.
		self
			line: (pt1 + offsetPoint) rounded
			to: (pt1 + (offsetPoint + delta2)) rounded
			width: w2
			color: c2].
	"if there was no loop, offsetPoint is nil"
	lastPoint _ pt1 + ((offsetPoint ifNil: [0 @ 0])
					+ delta2).
	(lastPoint dist: pt2)
		<= s1
		ifTrue: [self
				line: lastPoint rounded
				to: pt2 rounded
				width: w1
				color: c1]
		ifFalse: 
			[self
				line: lastPoint rounded
				to: (lastPoint + delta1) rounded
				width: w1
				color: c1.
			self
				line: (lastPoint + delta1) rounded
				to: pt2
				width: w1
				color: c2]! !

!Canvas methodsFor: 'drawing' stamp: 'ls 3/19/2000 15:12'!
paragraph2: para bounds: bounds color: c

	| scanner |
	scanner _ CanvasCharacterScanner new.
	scanner
		 canvas: self;
		text: para text textStyle: para textStyle;
		textColor: c.

	para displayOn: self using: scanner at: bounds topLeft.
! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:31'!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:32'!
point: p color: c
	"Obsolete - will be removed in the future"! !

!Canvas methodsFor: 'drawing' stamp: 'ar 2/5/1999 18:28'!
render: anObject
	"Do some 3D operations with the object if possible"! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
text: s at: pt font: fontOrNil color: c

	^ self text: s bounds: (pt extent: 10000@10000) font: fontOrNil color: c
! !

!Canvas methodsFor: 'drawing' stamp: 'ar 6/17/1999 01:32'!
text: s bounds: boundsRect font: fontOrNil color: c
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
	^self subclassResponsibility! !


!Canvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:12'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect."
	^self subclassResponsibility! !


!Canvas methodsFor: 'drawing-general' stamp: 'ar 5/29/1999 05:14'!
draw: anObject
	^anObject drawOn: self! !

!Canvas methodsFor: 'drawing-general'!
drawMorph: aMorph
	(self isVisible: aMorph bounds) ifTrue:[self draw: aMorph]! !

!Canvas methodsFor: 'drawing-general'!
fullDraw: anObject
	^anObject fullDrawOn: self! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 10/26/2000 19:45'!
fullDrawMorph: aMorph
	(self isVisible: aMorph fullBounds) ifTrue:[self fullDraw: aMorph].! !

!Canvas methodsFor: 'drawing-general' stamp: 'ar 10/26/2000 19:39'!
roundCornersOf: aMorph during: aBlock
	^aBlock value! !


!Canvas methodsFor: 'drawing-support' stamp: 'ar 2/12/2000 18:05'!
cache: aRectangle using: aCache during: aBlock
	"Cache the execution of aBlock by the given cache.
	Note: At some point we may want to actually *create* the cache here;
		for now we're only using it."
	(aCache notNil and:[(aCache isKindOf: Form) and:[aCache extent = aRectangle extent]]) 
		ifTrue:[^self paintImage: aCache at: aRectangle origin].
	aBlock value: self.! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:53'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 01:43'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock"
	^aBlock value: self copy! !

!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:02'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock
	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	^ self transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: 1
! !

!Canvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 15:56'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	^ self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:00'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 14:08'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	self translateBy: newOrigin - self origin 
		clippingTo: (aRectangle translateBy: self origin negated) 
		during: aBlock! !


!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'!
fillRectangle: r color: c
	"Fill the rectangle using the given color"
	^self 
		frameAndFillRectangle: r
		fillColor: c
		borderWidth: 0
		borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:34'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle.
	Note: The default implementation does not recognize any enhanced fill styles"
	self fillRectangle: aRectangle color: aFillStyle asColor.! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'RAA 8/14/2000 14:22'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw the rectangle using the given attributes.
	Note: This is a *very* simple implementation"
	| bw pt |
	self frameAndFillRectangle: r
		fillColor: fillColor
		borderWidth: borderWidth
		borderColor: bottomRightColor.
	bottomRightColor = topLeftColor ifFalse: [
		bw _ borderWidth asPoint.
		pt _ r topLeft + (bw // 2).
		self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor.
		self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor.
	].! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'!
frameRectangle: r color: c

	self frameRectangle: r width: 1 color: c.
! !

!Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'!
frameRectangle: r width: w color: c
	^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c.! !


!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
fillOval: r color: c

	self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.
! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:51'!
fillOval: aRectangle fillStyle: aFillStyle
	"Fill the given oval."
	^self fillOval: aRectangle fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:50'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval.
	Note: The default implementation does not recognize any enhanced fill styles"
	self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
frameOval: r color: c

	self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.
! !

!Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'!
frameOval: r width: w color: c

	self fillOval: r color: Color transparent borderWidth: w borderColor: c.
! !


!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:56'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Draw the given polygon."
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/25/1999 12:18'!
drawPolygon: vertices fillStyle: aFillStyle
	"Fill the given polygon."
	self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: Color transparent! !

!Canvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:58'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given polygon.
	Note: The default implementation does not recognize any enhanced fill styles"
	self drawPolygon: vertices color: aFillStyle asColor borderWidth: bw borderColor: bc! !


!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:45'!
drawImage: aForm at: aPoint
	"Draw the given Form, which is assumed to be a Form or ColorForm"

	self drawImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:47'!
drawImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given form."
	self shadowColor ifNotNil:[
		^self fillRectangle: ((aForm boundingBox intersect: sourceRect) translateBy: aPoint)
				color: self shadowColor].
	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form over! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:48'!
paintImage: aForm at: aPoint
	"Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."

	self paintImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox
! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'!
paintImage: aForm at: aPoint sourceRect: sourceRect
	"Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value."
	self shadowColor ifNotNil:[
		^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
	^self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form paint! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'!
stencil: stencilForm at: aPoint color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	^self stencil: stencilForm
		at: aPoint
		sourceRect: stencilForm boundingBox
		color: aColor! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	^self subclassResponsibility! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 14:05'!
translucentImage: aForm at: aPoint
	"Draw a translucent image using the best available way of representing translucency."
	self translucentImage: aForm
		at: aPoint
		sourceRect: aForm boundingBox! !

!Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'!
translucentImage: aForm at: aPoint sourceRect: sourceRect
	"Draw a translucent image using the best available way of representing translucency.
	Note: This will be fixed in the future."
	self shadowColor ifNotNil:[
		^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor].
	(self depth < 32 or:[aForm depth < 32]) 
		ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect].
	self image: aForm
		at: aPoint
		sourceRect: sourceRect
		rule: Form blend! !


!Canvas methodsFor: 'converting' stamp: 'ar 6/24/1999 17:46'!
asShadowDrawingCanvas
	^self asShadowDrawingCanvas: (Color black alpha: 0.5).! !

!Canvas methodsFor: 'converting' stamp: 'ar 6/22/1999 18:59'!
asShadowDrawingCanvas: aColor
	^(ShadowDrawingCanvas on: self) shadowColor: aColor! !


!Canvas methodsFor: 'other'!
flushDisplay
		" Dummy ."! !

!Canvas methodsFor: 'other'!
forceToScreen:rect
	" dummy "
! !

!Canvas methodsFor: 'other'!
translateBy:aPoint clippingTo:aRect during:aBlock
	^aBlock value:(self copyOffset:aPoint clipRect:aRect).! !


!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:10'!
image: aForm at: aPoint
	"Note: This protocol is deprecated. Use #paintImage: instead."
	self image: aForm
		at: aPoint
		sourceRect: aForm boundingBox
		rule: Form paint.
! !

!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'!
image: aForm at: aPoint rule: combinationRule
	"Note: This protocol is deprecated. Use one of the explicit image drawing messages (#paintImage, #drawImage) instead."
	self image: aForm
		at: aPoint
		sourceRect: aForm boundingBox
		rule: combinationRule.
! !

!Canvas methodsFor: 'drawing-obsolete' stamp: 'ar 2/12/2000 18:11'!
imageWithOpaqueWhite: aForm at: aPoint
	"Note: This protocol is deprecated. Use #drawImage: instead"
	self image: aForm
		at: aPoint
		sourceRect: (0@0 extent: aForm extent)
		rule: Form over.
! !


!Canvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 11/7/2000 13:54'!
displayIsFullyUpdated! !

!Canvas methodsFor: 'Nebraska/embeddedWorlds' stamp: 'RAA 12/5/2000 18:28'!
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	"an attempt to use #displayInterpolatedOn: instead of WarpBlt."

	| patchRect subCanvas pureRect biggerPatch biggerClip interForm |

	self flag: #bob.		"added to Canvas in hopes it will work for Nebraska"
	(aDisplayTransform isPureTranslation) ifTrue: [
		^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect)
	].
	"Prepare an appropriate warp from patch to aClipRect"
	pureRect _ (aDisplayTransform globalBoundsToLocal: aClipRect).
	patchRect _ pureRect rounded.
	patchRect area = 0 ifTrue: [^self]. 	"oh, well!!"
	biggerPatch _ patchRect expandBy: 1.
	biggerClip _ (aDisplayTransform localBoundsToGlobal: biggerPatch) rounded.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	subCanvas _ FormCanvas extent: biggerPatch extent depth: self depth.
	self isShadowDrawing ifTrue: [
		subCanvas shadowColor: self shadowColor
	].

	"this biggerPatch/biggerClip is an attempt to improve positioning of the final image in high magnification conditions. Since we cannot grab fractional pixels from the source, take one extra and then take just the part we need from the expanded form"

	subCanvas 
		translateBy: biggerPatch topLeft negated rounded
		during: [ :offsetCanvas | aBlock value: offsetCanvas].
	interForm _ Form extent: biggerClip extent depth: self depth.
	subCanvas form 
		displayInterpolatedIn: interForm boundingBox
		on: interForm.
	self 
		drawImage: interForm 
		at: aClipRect origin 
		sourceRect: (aClipRect origin - biggerClip origin extent: aClipRect extent)

! !

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

Canvas class
	instanceVariableNames: ''!

!Canvas class methodsFor: 'configuring'!
filterSelector
	^#drawOnCanvas:.! !
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: 'canvas fillBlt foregroundColor runX lineY '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!CanvasCharacterScanner commentStamp: '<historical>' prior: 0!
A displaying scanner which draws its output to a Morphic canvas.!


!CanvasCharacterScanner methodsFor: 'private' stamp: 'ls 9/26/1999 10:03'!
doesDisplaying
	^false   "it doesn't do displaying using copyBits"! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'ls 9/30/1999 12:34'!
setFont
	foregroundColor _ Color black.
	super setFont.
	destY _ lineY + line baseline - font ascent! !

!CanvasCharacterScanner methodsFor: 'private' stamp: 'ls 9/25/1999 16:24'!
textColor: color
	foregroundColor _ color! !


!CanvasCharacterScanner methodsFor: 'scanning' stamp: 'RAA 7/22/2000 10:06'!
displayLine: textLine  offset: offset  leftInRun: leftInRun
	|  nowLeftInRun done startLoc startIndex stopCondition |
	"largely copied from DisplayScanner's routine"

	line _ textLine.
	foregroundColor ifNil: [ foregroundColor _ Color black ].
	leftMargin _ (line leftMarginForAlignment: textStyle alignment) + offset x.

	rightMargin _ line rightMargin + offset x.
	lineY _ line top + offset y.
	lastIndex _ textLine first.
	leftInRun <= 0
		ifTrue: [self setStopConditions.  "also sets the font"
				nowLeftInRun _ text runLengthFor: lastIndex]
		ifFalse: [nowLeftInRun _ leftInRun].
	runX _ destX _ leftMargin.

	runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount _ 0.
	done _ false.

	[done] whileFalse: [
		"remember where this portion of the line starts"
		startLoc _ destX@destY.
		startIndex _ lastIndex.

		"find the end of this portion of the line"
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: text string rightX: rightMargin stopConditions: stopConditions
						kern: kern "displaying: false".

		"display that portion of the line"
		canvas text: (text string copyFrom: startIndex to: lastIndex)
			bounds: (startLoc corner: 99999@99999)
			font: font
			color: foregroundColor.

		"handle the stop condition"
		done _ self perform: stopCondition
	].

	^runStopIndex - lastIndex! !


!CanvasCharacterScanner methodsFor: 'accessing' stamp: 'ls 9/25/1999 15:59'!
canvas: aCanvas
	"set the canvas to draw on"
	canvas ifNotNil: [ self inform: 'initializing twice!!' ].
	canvas _ aCanvas! !


!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:07'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:10'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	"self fillLeading."
	^ true ! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:11'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |

	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/29/1999 20:13'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).

	lastIndex _ lastIndex + 1.
	^ false! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:14'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	stopConditions 
		at: Space asciiValue + 1 
		put: (textStyle alignment = Justified ifTrue: [#paddedSpace])! !

!CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ls 9/25/1999 16:14'!
tab

	destX _ (textStyle alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].

	lastIndex _ lastIndex + 1.
	^ false! !
Object subclass: #CanvasDecoder
	instanceVariableNames: 'drawingCanvas clipRect transform connection fonts '
	classVariableNames: 'CachedForms '
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!CanvasDecoder commentStamp: '<historical>' prior: 0!
Decodes commands encoded by MREncoder, and draws them onto a canvas.!


!CanvasDecoder methodsFor: 'initialization' stamp: 'ls 4/9/2000 14:26'!
initialize
	"set the canvas to draw on"
	drawingCanvas := FormCanvas extent: 100@100 depth: 16.
	clipRect _ drawingCanvas extent.
	transform _ MorphicTransform identity.

	fonts := Array new: 2.! !


!CanvasDecoder methodsFor: 'network' stamp: 'ls 9/26/1999 14:59'!
connection: aStringSocket
	"set this terminal to talk over the given socket"
	connection _ aStringSocket! !

!CanvasDecoder methodsFor: 'network' stamp: 'ls 3/18/2000 13:38'!
processIO
	| command didSomething |
	connection ifNil: [ ^self ].
	connection processIO.
	didSomething := false.
	[ command _ connection nextOrNil.  command notNil ] whileTrue: [
		didSomething := true.
		self processCommand: command ].

	^didSomething! !

!CanvasDecoder methodsFor: 'network' stamp: 'ls 3/26/2000 22:16'!
processIOOnForce: forceBlock
	| command didSomething |
	connection ifNil: [ ^self ].
	connection processIO.
	didSomething := false.
	[ command _ connection nextOrNil.  command notNil ] whileTrue: [
		didSomething := true.
		self processCommand: command onForceDo: forceBlock].

	^didSomething! !


!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/27/2000 17:57'!
addFontToCache: command
	| index font |
	index := self class decodeInteger: command second.
	font := self class decodeFont: command third.

	index > fonts size ifTrue: [
		| newFonts |
		newFonts  := Array new: index.
		newFonts replaceFrom: 1 to: fonts size with: fonts.
		fonts := newFonts ].

	fonts at: index put: font! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 11/6/2000 15:40'!
drawBalloonOval: command

	| aRectangle aFillStyle borderWidth borderColor |

	aRectangle _ self class decodeRectangle: (command at: 2).
	aFillStyle _ self class decodeFillStyle: (command at: 3).
	borderWidth _ self class decodeInteger: (command at: 4).
	borderColor _ self class decodeColor: (command at: 5).

	self drawCommand: [ :c |
		c asBalloonCanvas 
			fillOval: aRectangle
			fillStyle: aFillStyle
			borderWidth: borderWidth
			borderColor: borderColor
	].! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 7/28/2000 07:55'!
drawBalloonRect: command

	| aRectangle aFillStyle |

	aRectangle _ self class decodeRectangle: (command at: 2).
	aFillStyle _ self class decodeFillStyle: (command at: 3).

	self drawCommand: [ :c |
		c asBalloonCanvas 
			fillRectangle: aRectangle 
			fillStyle: aFillStyle.
	].! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 4/9/2000 14:26'!
drawCommand: aBlock
	"call aBlock with the canvas it should actually draw on so that the clipping rectangle and transform are set correctly"
	drawingCanvas transformBy: transform clippingTo: clipRect during: aBlock! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 11/1/2000 23:23'!
drawImage: command
	| image point sourceRect rule cacheID cacheNew previousImage |

	image := self class decodeImage: (command at: 2).
	point := self class decodePoint: (command at: 3).
	sourceRect := self class decodeRectangle: (command at: 4).
	rule := self class decodeInteger: (command at: 5).
	command size >= 7 ifTrue: [
		false ifTrue: [self showSpaceUsed].		"debugging"
		cacheID _ self class decodeInteger: (command at: 6).
		cacheNew _ (self class decodeInteger: (command at: 7)) = 1.
		cacheID > 0 ifTrue: [
			CachedForms ifNil: [CachedForms _ Array new: 100].
			cacheNew ifTrue: [
				CachedForms at: cacheID put: image
			] ifFalse: [
				previousImage _ CachedForms at: cacheID.
				image ifNil: [
					image _ previousImage
				] ifNotNil: [
					(previousImage notNil and: [image depth > 8]) ifTrue: [
						image _ previousImage addDeltasFrom: image.
					].
					CachedForms at: cacheID put: image
				].
			].
		].
	].
	self drawCommand: [ :c |
		c image: image  at: point  sourceRect: sourceRect rule: rule
	]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 8/25/2000 13:37'!
drawInfiniteFill: command

	| aRectangle aFillStyle |

	aRectangle _ self class decodeRectangle: (command at: 2).
	aFillStyle _ InfiniteForm with: (self class decodeImage: (command at: 3)).

	self drawCommand: [ :c |
		c asBalloonCanvas 
			fillRectangle: aRectangle 
			fillStyle: aFillStyle.
	].! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 2/28/2000 00:22'!
drawLine: command
	| verb pt1Enc pt2Enc widthEnc colorEnc pt1 pt2 width color |
	verb := command at: 1.
	pt1Enc := command at: 2.
	pt2Enc := command at: 3.
	widthEnc := command at: 4.
	colorEnc := command at: 5.

	pt1 _ self class decodePoint: pt1Enc.
	pt2 _ self class decodePoint: pt2Enc.
	width _ self class decodeInteger: widthEnc.
	color _ self class decodeColor: colorEnc.

	self drawCommand: [ :c |
		c line: pt1 to: pt2 width: width color: color ]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 2/28/2000 00:24'!
drawOval: command
	| verb rectEnc colorEnc borderWidthEnc borderColorEnc rect color borderWidth borderColor |
	verb := command at: 1.
	rectEnc := command at: 2.
	colorEnc := command at: 3.
	borderWidthEnc := command at: 4.
	borderColorEnc := command at: 5.

	rect _ self class decodeRectangle: rectEnc.
	color _ self class decodeColor: colorEnc.
	borderWidth _ self class decodeInteger: borderWidthEnc.
	borderColor _ self class decodeColor: borderColorEnc.

	self drawCommand: [ :c |
		c fillOval: rect color: color borderWidth: borderWidth borderColor: borderColor ]
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 4/8/2000 22:28'!
drawPoly: command
	|  verticesEnc fillColorEnc borderWidthEnc borderColorEnc vertices fillColor borderWidth borderColor |


	fillColorEnc := command at: 2.
	borderWidthEnc := command at: 3.
	borderColorEnc := command at: 4.

	verticesEnc := command copyFrom: 5 to: command size.

	fillColor := self class decodeColor: fillColorEnc.
	borderWidth := self class decodeInteger: borderWidthEnc.
	borderColor := self class decodeColor: borderColorEnc.
	vertices := verticesEnc collect: [ :enc | self class decodePoint: enc ].


	self drawCommand: [ :c |
		c drawPolygon: vertices color: fillColor borderWidth: borderWidth borderColor: borderColor ].
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 2/28/2000 00:24'!
drawRect: command
	| verb rectEnc fillColorEnc borderWidthEnc borderColorEnc rect fillColor borderWidth borderColor |
	verb := command at: 1.
	rectEnc := command at: 2.
	fillColorEnc := command at: 3.
	borderWidthEnc := command at: 4.
	borderColorEnc := command at: 5.

	rect _ self class decodeRectangle: rectEnc.
	fillColor _ self class decodeColor: fillColorEnc.
	borderWidth _ self class decodeInteger: borderWidthEnc.
	borderColor _ self class decodeColor: borderColorEnc.

	self drawCommand: [ :c |
		c frameAndFillRectangle: rect  fillColor: fillColor  borderWidth: borderWidth  borderColor: borderColor ]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/26/2000 13:20'!
drawStencil: command
	| stencilFormEnc locationEnc sourceRectEnc colorEnc stencilForm location sourceRect color |
	stencilFormEnc := command at: 2.
	locationEnc := command at: 3.
	sourceRectEnc := command at: 4.
	colorEnc := command at: 5.

	stencilForm := self class decodeImage: stencilFormEnc.
	location := self class decodePoint: locationEnc.
	sourceRect := self class decodeRectangle: sourceRectEnc.
	color := self class decodeColor: colorEnc.

	self drawCommand: [ :executor |
		executor stencil: stencilForm at: location sourceRect: sourceRect  color: color ]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/27/2000 18:02'!
drawText: command
	| boundsEnc colorEnc  text bounds color fontIndexEnc fontIndex |

	text := command at: 2.
	boundsEnc := command at: 3.
	fontIndexEnc := command at: 4.
	colorEnc := command at: 5.


	bounds _ self class decodeRectangle: boundsEnc.
	fontIndex := self class decodeInteger: fontIndexEnc.
	color _ self class decodeColor: colorEnc.

	self drawCommand: [ :c |
		c text: text bounds: bounds font: (fonts at: fontIndex) color: color ]! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 4/9/2000 14:40'!
extentDepth: command
	| depth extent |
	extent := self class decodePoint: (command at: 2).
	depth := self class decodeInteger: (command at: 3).

	drawingCanvas := FormCanvas  extent: extent depth: depth.! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 3/26/2000 22:04'!
forceToScreen: aCommand  withBlock: forceBlock
	| region |
	region := self class decodeRectangle: aCommand second.
	forceBlock value: region.! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 11/6/2000 15:36'!
processCommand: command  onForceDo: forceBlock
	| verb verbCode |
	command isEmpty ifTrue: [ ^self ].

	verb _ command first.
	verbCode := verb at: 1.

	verbCode = CanvasEncoder codeClip ifTrue: [ ^self setClip: command ].
	verbCode = CanvasEncoder codeTransform ifTrue: [ ^self setTransform: command ].
	verbCode = CanvasEncoder codeText ifTrue: [ ^self drawText: command ].
	verbCode = CanvasEncoder codeLine ifTrue: [ ^self drawLine: command ].
	verbCode = CanvasEncoder codeRect ifTrue: [ ^self drawRect: command ].
	verbCode = CanvasEncoder codeBalloonRect ifTrue: [ ^self drawBalloonRect: command ].
	verbCode = CanvasEncoder codeBalloonOval ifTrue: [ ^self drawBalloonOval: command ].
	verbCode = CanvasEncoder codeInfiniteFill ifTrue: [ ^self drawInfiniteFill: command ].

	verbCode = CanvasEncoder codeOval ifTrue: [ ^self drawOval: command ].
	verbCode = CanvasEncoder codeImage ifTrue: [ ^self drawImage: command ].
	verbCode = CanvasEncoder codeReleaseCache ifTrue: [ ^self releaseImage: command ].
	verbCode = CanvasEncoder codePoly ifTrue: [ ^self drawPoly: command ].
	verbCode = CanvasEncoder codeStencil ifTrue: [ ^self drawStencil: command ].
	verbCode = CanvasEncoder codeForce ifTrue: [ ^self forceToScreen: command withBlock: forceBlock ].
	verbCode = CanvasEncoder codeFont ifTrue: [ ^self addFontToCache: command ].
	verbCode = CanvasEncoder codeExtentDepth ifTrue: [ ^self extentDepth: command ].

self error: 'unknown command: ', command first.! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 7/28/2000 17:13'!
releaseImage: command
	| cacheID |

	CachedForms ifNil: [^self].
	cacheID _ self class decodeInteger: (command at: 2).
	CachedForms at: cacheID put: nil.
! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 10/9/1999 20:28'!
setClip: command
	| clipRectEnc |
	clipRectEnc _ command at: 2.
	clipRect _ self class decodeRectangle: clipRectEnc! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'ls 10/9/1999 20:28'!
setTransform: command
	| transformEnc |
	transformEnc _ command at: 2.
	transform _ self class decodeTransform: transformEnc! !

!CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 8/28/2000 11:46'!
showSpaceUsed

	| total |
	CachedForms ifNil: [^self].
	total _ 0.
	CachedForms do: [ :each |
		each ifNotNil: [
			total _ total + (each depth * each width * each height // 8).
		].
	].
	(total // 1024) printString,'     ',
	(Smalltalk garbageCollectMost // 1024) printString,'     ' displayAt: 0@0! !


!CanvasDecoder methodsFor: 'attributes' stamp: 'ls 4/9/2000 14:29'!
drawingForm
	"return the form that we are drawing on behind thescenes"
	^drawingCanvas form! !


!CanvasDecoder methodsFor: 'shutting down' stamp: 'ls 4/9/2000 14:33'!
delete
	connection ifNotNil: [ connection destroy ].! !

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

CanvasDecoder class
	instanceVariableNames: ''!

!CanvasDecoder class methodsFor: 'decoding' stamp: 'RAA 7/25/2000 13:06'!
decodeColor: string
	| rgb a rgb1 rgb2 |
	rgb1 := string getInteger32: 1.
	rgb2 := string getInteger32: 5.
	a := string getInteger32: 9.
	rgb := rgb2 << 16 + rgb1.

	a < 255
		ifTrue: [ ^TranslucentColor basicNew setRgb: rgb  alpha: a/255.0 ]
		ifFalse: [ ^Color basicNew setRGB: rgb ]! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'RAA 7/28/2000 08:33'!
decodeFillStyle: string

	^DataStream unStream: string! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/27/2000 17:57'!
decodeFont: fontString
	^StrikeFont decodedFromRemoteCanvas: fontString! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'RAA 9/19/2000 15:14'!
decodeImage: string
	| bitsStart depth width height bits rs numColors colorArray |

	bitsStart _ string indexOf: $|.
	bitsStart = 0 ifTrue: [^nil].
	rs := ReadStream on: string.
	rs peek == $C ifTrue: [
		rs next.
		numColors _ Integer readFromString: (rs upTo: $,).
		colorArray _ Array new: numColors.
		1 to: numColors do: [ :i |
			colorArray at: i put: (self decodeColor: (rs next: 12))
		].
	].
	depth := Integer readFromString: (rs upTo: $,).
	width :=  Integer readFromString: (rs upTo: $,).
	height :=  Integer readFromString: (rs upTo: $|).

	bits _ Bitmap newFromStream: (RWBinaryOrTextStream with: rs upToEnd) binary reset.

	colorArray ifNil: [
		^Form extent: width@height depth: depth bits: bits
	].
	^(ColorForm extent: width@height depth: depth bits: bits)
		colors: colorArray
! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 9/24/1999 20:10'!
decodeInteger: string
	^Integer readFromString: string! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/27/2000 00:36'!
decodePoint: string
	| x y |
	x := string getInteger32: 1.
	y := string getInteger32: 5.

	^x@y! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/25/2000 23:02'!
decodePoints: aString
	^(aString findTokens: '|') asArray collect: [ :encPoint | self decodePoint: encPoint ]! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 3/27/2000 22:24'!
decodeRectangle: string
	| x y cornerX cornerY |
	x := string getInteger32: 1.
	y := string getInteger32: 5.
	cornerX := string getInteger32: 9.
	cornerY := string getInteger32: 13.

	^x@y corner: cornerX@cornerY! !

!CanvasDecoder class methodsFor: 'decoding' stamp: 'ls 10/9/1999 20:28'!
decodeTransform: transformEnc
	"decode an encoded transform"
	^DisplayTransform fromRemoteCanvasEncoding: transformEnc! !


!CanvasDecoder class methodsFor: 'instance creation' stamp: 'ls 4/9/2000 14:24'!
connection: aConnection
	^self new initialize;
		connection: aConnection;
		yourself! !
Object subclass: #CanvasEncoder
	instanceVariableNames: 'connection lastClipRect lastTransform fontCache cachedObjects cachingEnabled '
	classVariableNames: 'SentTypesAndSizes SimpleCounters '
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!CanvasEncoder commentStamp: '<historical>' prior: 0!
Encodes canvas commands into string-arrays format.

---possible further compression for forms ---
600 * 359 * 4    861600

self encodeForRemoteCanvas size 76063
Time millisecondsToRun: [self encodeForRemoteCanvas]

| raw data |
data _ self encodeForRemoteCanvas.
raw _ RWBinaryOrTextStream on: (String new: 1000).
Time millisecondsToRun: [(GZipWriteStream on: raw) nextPutAll: data; close].
raw contents size
(GZipReadStream on: (ReadStream on: raw contents)) upToEnd size

| raw |
raw _ RWBinaryOrTextStream on: (String new: bits size).
raw nextPutAll: bits

Time millisecondsToRun: [bits compressGZip]   50

bits compressGZip size 861620!


!CanvasEncoder methodsFor: 'connection' stamp: 'RAA 8/1/2000 00:17'!
backlog

	^connection backlog! !

!CanvasEncoder methodsFor: 'connection' stamp: 'RAA 11/7/2000 17:54'!
connection: aStringSocket
	"set this connection to talk over the given socket"

	cachingEnabled _ true.
	connection _ aStringSocket! !

!CanvasEncoder methodsFor: 'connection' stamp: 'ls 9/26/1999 15:47'!
disconnect
	connection ifNotNil: [
		connection destroy.
		connection _ nil.
	].! !

!CanvasEncoder methodsFor: 'connection' stamp: 'ls 9/26/1999 15:45'!
isConnected
	^connection notNil and: [ connection isConnected ]! !

!CanvasEncoder methodsFor: 'connection' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue

	connection purgeOutputQueue.! !


!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'ls 4/11/2000 18:59'!
setClipRect: newClipRect
	self sendCommand: {
		String with: CanvasEncoder codeClip.
		self class encodeRectangle: newClipRect }! !

!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'ls 4/11/2000 18:59'!
setTransform: newTransform
	self sendCommand: {
		String with: CanvasEncoder codeTransform.
		self class encodeTransform: newTransform }! !

!CanvasEncoder methodsFor: 'clipping and transforming' stamp: 'ls 10/9/1999 18:19'!
updateTransform: aTransform andClipRect: aClipRect
	"sets the given transform and clip rectangle, if they aren't already the ones being used"
	aTransform = lastTransform ifFalse: [
		self setTransform: aTransform.
		lastTransform _ aTransform ].

	aClipRect = lastClipRect ifFalse: [
		self setClipRect: aClipRect.
		lastClipRect _ aClipRect. ].! !


!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 11/6/2000 15:38'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self sendCommand: {
		String with: CanvasEncoder codeBalloonOval.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas.
		self class encodeInteger: bw.
		self class encodeColor: bc.
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:30'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self sendCommand: {
		String with: CanvasEncoder codeBalloonRect.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 11/7/2000 17:56'!
cachingEnabled: aBoolean

	(cachingEnabled _ aBoolean) ifFalse: [
		cachedObjects _ nil.
	].
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	| encodedVertices |
	encodedVertices := vertices collect: [ :vertex | self class encodePoint: vertex ].

	self sendCommand: {
		String with: CanvasEncoder codePoly.
		self class encodeColor: aColor.
		self class encodeInteger: bw.
		self class encodeColor: bc},  encodedVertices .! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/9/2000 14:39'!
extent: newExtent  depth: newDepth
	self sendCommand: {
		self class codeExtentDepth asString.
		self class encodePoint: newExtent. 
		self class encodeInteger: newDepth.
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	self sendCommand: {
		String with: CanvasEncoder codeOval.
		self class encodeRectangle: r.
		self class encodeColor: c.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
forceToScreen: aRectangle
	self sendCommand: {
		String with: CanvasEncoder codeForce.
		self class encodeRectangle: aRectangle }! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:12'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor

	self sendCommand: {
		String with: CanvasEncoder codeRect.
		self class encodeRectangle: r.
		fillColor encodeForRemoteCanvas.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 11/1/2000 23:21'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule

	| cacheID cacheNew cacheReply formToSend cacheEntry destRect visRect aFormArea d2 |

	"first if we are only going to be able to draw a small part of the form,
	it may be faster just to send the part of the form that will actually show up"

	destRect _ aPoint extent: sourceRect extent.
	d2 _ (lastTransform invertBoundsRect: destRect) expandBy: 1.
	(d2 intersects: lastClipRect) ifFalse: [
		^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
	].
	aFormArea _ aForm boundingBox area.
	(aFormArea > 20000 and: [aForm isStatic not and: [lastTransform isPureTranslation]]) ifTrue: [
		visRect _ destRect intersect: lastClipRect.
		visRect area < (aFormArea // 20) ifTrue: [
			"NebraskaDebug 
				at: #bigImageReduced 
				add: {lastClipRect. aPoint. sourceRect extent. lastTransform}."
			formToSend _ aForm copy: (visRect translateBy: sourceRect origin - aPoint).
			^self 
				image: formToSend 
				at: visRect origin 
				sourceRect: formToSend boundingBox
				rule: rule
				cacheID: 0 		"no point in trying to cache this - it's a one-timer"
				newToCache: false.
		].
	].

	cacheID _ 0.
	cacheNew _ false.
	formToSend _ aForm.
	(aFormArea > 1000 and: [(cacheReply _ self testCache: aForm) notNil]) ifTrue: [
		cacheID _ cacheReply first.
		cacheEntry _ cacheReply third.
		(cacheNew _ cacheReply second) ifFalse: [
			formToSend _ aForm isStatic 
				ifTrue: [nil] 
				ifFalse: [aForm depth <= 8 ifTrue: [aForm] ifFalse: [aForm deltaFrom: cacheEntry fourth]].
		].
		cacheEntry at: 4 put: (aForm isStatic ifTrue: [aForm] ifFalse: [aForm deepCopy]).
	].
	self
		image: formToSend 
		at: aPoint 
		sourceRect: sourceRect 
		rule: rule 
		cacheID: cacheID 
		newToCache: cacheNew.

! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 12/14/2000 11:30'!
image: aFormOrNil at: aPoint sourceRect: sourceRect rule: rule cacheID: cacheID newToCache: newToCache

	| t destRect d2 |

	destRect _ aPoint extent: sourceRect extent.
	d2 _ (lastTransform invertBoundsRect: destRect) expandBy: 1.
	(d2 intersects: lastClipRect) ifFalse: [
		^NebraskaDebug at: #bigImageSkipped add: {lastClipRect. d2}.
	].
	t _ Time millisecondsToRun: [
		self sendCommand: {
			String with: CanvasEncoder codeImage.
			self class encodeImage: aFormOrNil.
			self class encodePoint: aPoint.
			self class encodeRectangle: sourceRect.
			self class encodeInteger: rule.
			self class encodeInteger: cacheID.
			self class encodeInteger: (newToCache ifTrue: [1] ifFalse: [0]).
		}.
	].
	(aFormOrNil notNil and: [aFormOrNil boundingBox area > 10000]) ifTrue: [
		NebraskaDebug 
			at: #bigImage 
			add: {lastClipRect. aPoint. sourceRect extent. t. cacheID. newToCache}.
	].

! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:32'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self sendCommand: {
		String with: CanvasEncoder codeInfiniteFill.
		self class encodeRectangle: aRectangle.
		aFillStyle encodeForRemoteCanvas
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/14/2000 14:27'!
line: pt1  to: pt2  width: w  color: c

"Smalltalk at: #Q3 put: thisContext longStack."
	self sendCommand: {
		String with: CanvasEncoder codeLine.
		self class encodePoint: pt1.
		self class encodePoint: pt2.
		self class encodeInteger: w.
		self class encodeColor: c
	}! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/28/2000 11:52'!
purgeCache

	| spaceUsed spaceBefore s | 
	spaceBefore _ spaceUsed _ self purgeCacheInner.
	spaceBefore > 8000000 ifTrue: [
		Smalltalk garbageCollect.
		spaceUsed _ self purgeCacheInner.
	].
	false ifTrue: [
		s _ (spaceBefore // 1024) printString,'  ',(spaceUsed // 1024) printString,'  ',
			Time now printString,'     '.
		WorldState addDeferredUIMessage: [s displayAt: 0@0.] fixTemps.
	].
	^spaceUsed
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 8/25/2000 17:27'!
purgeCacheInner

	| cachedObject totalSize thisSize |

	cachedObjects ifNil: [^0].
	totalSize _ 0.
	cachedObjects withIndexDo: [ :each :index |
		cachedObject _ each first first.
		cachedObject ifNil: [
			each second ifNotNil: [
				2 to: each size do: [ :j | each at: j put: nil].
				self sendCommand: {
					String with: CanvasEncoder codeReleaseCache.
					self class encodeInteger: index.
				}.
			].
		] ifNotNil: [
			thisSize _ cachedObject depth * cachedObject width * cachedObject height // 8.
			totalSize _ totalSize + thisSize.
		].
	].
	^totalSize
	"---
	newEntry _ {
		WeakArray with: anObject.
		1.
		Time millisecondClockValue.
		nil.
	}.
	---"
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	self sendCommand: {
		String with: CanvasEncoder codeStencil.
		self class encodeImage: stencilForm.
		self class encodePoint: aPoint.
		self class encodeRectangle: sourceRect.
		self class encodeColor: aColor }! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 11/7/2000 17:55'!
testCache: anObject

	| firstFree cachedObject newEntry |

	cachingEnabled ifFalse: [
		cachedObjects _ nil.
		^nil
	].
	cachedObjects ifNil: [
		cachedObjects _ (1 to: 100) collect: [ :x | {WeakArray new: 1. nil. nil. nil}].
	].
	self purgeCache.
	firstFree _ nil.
	cachedObjects withIndexDo: [ :each :index |
		cachedObject _ each first first.
		firstFree ifNil: [cachedObject ifNil: [firstFree _ index]].
		cachedObject == anObject ifTrue: [
			each at: 2 put: (each at: 2) + 1.
			^{index. false. each}
		].
	].
	firstFree ifNil: [^nil].
	newEntry _ {
		WeakArray with: anObject.
		1.
		Time millisecondClockValue.
		nil.
	}.
	cachedObjects at: firstFree put: newEntry.
	^{firstFree. true. newEntry}
! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 7/22/2000 08:02'!
testRectangleFillTiming
| r fillColor borderWidth borderColor t |
"
CanvasEncoder new testRectangleFillTiming
"
	r _ 100@100 extent: 300@300.
	fillColor _ Color blue.
	borderWidth _ 1.
	borderColor _ Color red.
	t _ Time millisecondsToRun: [
		1000 timesRepeat: [
		{
		String with: CanvasEncoder codeRect.
		self class encodeRectangle: r.
		self class encodeColor: fillColor.
		self class encodeInteger: borderWidth.
		self class encodeColor: borderColor }
		].
	].
	t inspect.! !

!CanvasEncoder methodsFor: 'drawing' stamp: 'ls 4/11/2000 18:59'!
text: s bounds: boundsRect font: fontOrNil color: c
	| fontIndex |
	fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]).
	self sendCommand: {
		String with: CanvasEncoder codeText.
		s.
		self class encodeRectangle: boundsRect.
		self class encodeInteger: fontIndex.
		self class encodeColor: c
	}! !


!CanvasEncoder methodsFor: 'private' stamp: 'RAA 7/28/2000 09:05'!
sendCommand: stringArray

	| bucket |
	connection ifNil: [ ^self ].
	connection isConnected ifFalse: [ ^self ].
	connection nextPut: stringArray.
	
	SentTypesAndSizes ifNil: [^self].
	bucket _ SentTypesAndSizes at: stringArray first ifAbsentPut: [{0. 0. 0}].
	bucket at: 1 put: (bucket at: 1) + 1.
	bucket at: 2 put: (bucket at: 2) + (
		stringArray inject: 4 into: [ :sum :array | sum + (array size + 4) ]
	).


	! !


!CanvasEncoder methodsFor: 'network' stamp: 'ls 9/24/1999 19:52'!
destroy
	self disconnect.! !

!CanvasEncoder methodsFor: 'network' stamp: 'ls 3/21/2000 23:22'!
flush
	connection ifNotNil: [
		connection flush ]! !

!CanvasEncoder methodsFor: 'network' stamp: 'ls 9/24/1999 19:52'!
processIO
	connection ifNil: [ ^self ].
	connection isConnected ifFalse: [ ^self ].
	connection processIO.! !


!CanvasEncoder methodsFor: 'initialization' stamp: 'RAA 11/7/2000 17:55'!
initialize

	cachingEnabled _ true.
	fontCache := FontCache new: 5.! !


!CanvasEncoder methodsFor: 'fonts' stamp: 'ls 3/27/2000 18:06'!
establishFont: aFont
	"make sure that the given font is in the fonts cache.  If it is not there already, then transmit it.  Either way, after this returns, the font is in the cache at the index specified by the return value"
	| index |
	(fontCache includesFont: aFont) ifTrue: [ ^fontCache indexOf: aFont ].
	index := fontCache indexForNewFont: aFont.
	self sendFont: aFont atIndex: index.
	^index! !

!CanvasEncoder methodsFor: 'fonts' stamp: 'ls 4/11/2000 18:59'!
sendFont: aFont atIndex: index
	"transmit the given fint to the other side"
	self sendCommand: {
		String with: CanvasEncoder codeFont.
		self class encodeInteger: index.
		self class encodeFont: aFont }.
! !


!CanvasEncoder methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:44'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	cachingEnabled ifNil: [cachingEnabled _ true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

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

CanvasEncoder class
	instanceVariableNames: ''!

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/24/2000 13:24'!
encodeColor: color
	
	^color encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/28/2000 07:53'!
encodeFillStyle: aFillStyle
	
	^aFillStyle encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 3/27/2000 17:57'!
encodeFont: aFont
	^aFont encodedForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 12/14/2000 11:30'!
encodeImage: form
	
	| t answer |

	form ifNil: [^''].
	t _ Time millisecondsToRun: [answer _ form encodeForRemoteCanvas].
	form boundingBox area > 5000 ifTrue: [
		NebraskaDebug at: #FormEncodeTimes add: {t. form extent. answer size}
	].
	^answer

	"HandMorph>>restoreSavedPatchOn: is one culprit here"

! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 3/26/2000 23:12'!
encodeInteger: integer
	^integer asInteger storeString! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 7/28/2000 08:20'!
encodePoint: point
	
	^point encodeForRemoteCanvas! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'RAA 8/9/2000 16:11'!
encodeRectangle: rectangle
	| x y encoded cornerX cornerY |

	x _ rectangle origin x asInteger.
	y _ rectangle origin y asInteger.
	cornerX _ rectangle corner x asInteger.
	cornerY _ rectangle corner y asInteger.

	CanvasEncoder at: 2 count:  1.
	encoded := String new: 16.
	encoded putInteger32: x at: 1.
	encoded putInteger32: y at: 5.
	encoded putInteger32: cornerX at: 9.
	encoded putInteger32: cornerY at: 13.

	^encoded! !

!CanvasEncoder class methodsFor: 'encoding' stamp: 'ls 10/9/1999 18:54'!
encodeTransform: transform
	^transform encodeForRemoteCanvas! !


!CanvasEncoder class methodsFor: 'instance creation' stamp: 'ls 9/26/1999 16:22'!
new
	^super new initialize! !

!CanvasEncoder class methodsFor: 'instance creation' stamp: 'ls 10/20/1999 21:17'!
on: connection
	^self new connection: connection! !


!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:29'!
aaaReadme
	"these codes are used instead of strings, because String>>= was taking around 20% of the decoder's time"
	! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 11/6/2000 15:28'!
codeBalloonOval

	^$O! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 7/28/2000 07:43'!
codeBalloonRect
	^$R! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeClip
	^$A! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 4/9/2000 14:39'!
codeExtentDepth
	^$M! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeFont
	^$L! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeForce
	^$J! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeImage
	^$G! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 8/25/2000 13:31'!
codeInfiniteFill

	^$i! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeLine
	^$D! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeOval
	^$F! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codePoly
	^$H! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeRect
	^$E! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 7/28/2000 16:50'!
codeReleaseCache
	^$z! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeStencil
	^$I! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:34'!
codeText
	^$C! !

!CanvasEncoder class methodsFor: 'codes' stamp: 'ls 3/27/2000 22:35'!
codeTransform
	^$B! !


!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:27'!
at: anIndex count: anInteger

	SimpleCounters ifNil: [(SimpleCounters _ Array new: 10) atAllPut: 0].
	SimpleCounters at: anIndex put: (SimpleCounters at: anIndex) + anInteger.! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 09:01'!
beginStats

	SentTypesAndSizes _ Dictionary new.! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:30'!
clearTestVars
"
CanvasEncoder clearTestVars
"
	SimpleCounters _ nil

! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:47'!
explainTestVars
"
CanvasEncoder explainTestVars
"
	| answer total oneBillion data putter nReps |

	SimpleCounters ifNil: [^1 beep].
	total _ 0.
	oneBillion _ 1000 * 1000 * 1000.
	answer _ String streamContents: [ :strm |
		data _ SimpleCounters copy.
		putter _ [ :msg :index :nSec |
			nReps _ data at: index.
			total _ total + (nSec * nReps).
			strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ',
					(nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr
		].
		putter value: 'string socket' value: 1 value: 8000.
		putter value: 'rectangles' value: 2 value: 40000.
		putter value: 'points' value: 3 value: 18000.
		putter value: 'colors' value: 4 value: 8000.
	].
	StringHolder new
		contents: answer;
		openLabel: 'put integer times'.

! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:26'!
inspectTestVars
"
CanvasEncoder inspectTestVars
"
	^SimpleCounters

! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 09:01'!
killStats

	SentTypesAndSizes _ nil! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 11/6/2000 15:29'!
nameForCode: aStringOrChar

	| ch |
	ch _ (aStringOrChar isKindOf: String) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar].
	ch == self codeBalloonOval ifTrue: [^'balloon oval'].
	ch == self codeBalloonRect ifTrue: [^'balloon rectangle'].
	ch == self codeClip ifTrue: [^'clip'].
	ch == self codeExtentDepth ifTrue: [^'codeExtentDepth'].
	ch == self codeFont ifTrue: [^'codeFont'].
	ch == self codeForce ifTrue: [^'codeForce'].
	ch == self codeImage ifTrue: [^'codeImage'].
	ch == self codeLine ifTrue: [^'codeLine'].
	ch == self codeOval ifTrue: [^'codeOval'].
	ch == self codePoly ifTrue: [^'codePoly'].
	ch == self codeRect ifTrue: [^'codeRect'].
	ch == self codeReleaseCache ifTrue: [^'codeReleaseCache'].
	ch == self codeStencil ifTrue: [^'codeStencil'].
	ch == self codeText ifTrue: [^'codeText'].
	ch == self codeTransform ifTrue: [^'codeTransform'].
	ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill'].

	^'????'
! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 14:18'!
showStats
"
CanvasEncoder showStats
"
	| answer bucket |

	SentTypesAndSizes ifNil: [^1 beep].
	answer _ WriteStream on: String new.
	SentTypesAndSizes keys asSortedCollection do: [ :each |
		bucket _ SentTypesAndSizes at: each.
		answer nextPutAll: each printString,' ',
				bucket first printString,'  ',
				bucket second asStringWithCommas,' ',
				(self nameForCode: each); cr.
	].
	StringHolder new contents: answer contents; openLabel: 'send/receive stats'.
! !

!CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:48'!
timeSomeThings
"
CanvasEncoder timeSomeThings
"
	| s iter answer ms pt rect bm writer array color |

	iter _ 1000000.
	array _ Array new: 4.
	color _ Color red.
	answer _ String streamContents: [ :strm |
		writer _ [ :msg :doer |
			ms _ [iter timesRepeat: doer] timeToRun.
			strm nextPutAll: msg,((ms * 1000 / iter) roundTo: 0.01) printString,' usec'; cr.
		].
		s _ String new: 4.
		bm _ Bitmap new: 20.
		pt _ 100@300.
		rect _ pt extent: pt.
	iter _ 1000000.
		writer value: 'empty loop ' value: [self].
		writer value: 'modulo ' value: [12345678 \\ 256].
		writer value: 'bitAnd: ' value: [12345678 bitAnd: 255].
		strm cr.
	iter _ 100000.
		writer value: 'putInteger ' value: [s putInteger32: 12345678 at: 1].
		writer value: 'bitmap put ' value: [bm at: 1 put: 12345678].
		writer value: 'encodeBytesOf: (big) ' value: [bm encodeInt: 12345678 in: bm at: 1].
		writer value: 'encodeBytesOf: (small) ' value: [bm encodeInt: 5000 in: bm at: 1].
		writer value: 'array at: (in) ' value: [array at: 1].
		writer value: 'array at: (out) ' value: [array at: 6 ifAbsent: []].
		strm cr.
	iter _ 10000.
		writer value: 'color encode ' value: [color encodeForRemoteCanvas].
		writer value: 'pt encode ' value: [pt encodeForRemoteCanvas].
		writer value: 'rect encode ' value: [self encodeRectangle: rect].
		writer value: 'rect encode2 ' value: [rect encodeForRemoteCanvas].
		writer value: 'rect encodeb ' value: [rect encodeForRemoteCanvasB].
	].

	StringHolder new contents: answer; openLabel: 'send/receive stats'.
! !
Player subclass: #CardPlayer
	instanceVariableNames: 'privateMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Stacks'!
!CardPlayer commentStamp: '<historical>' prior: 0!
CardPlayer
	Instance variables of the Uniclass represent the data in the "fields" of each card in the stack.
	Each Instance variable is some kind of value holder.

	The code for the *buttons* on the background resides in the CardPlayer uniclass.
	!


!CardPlayer methodsFor: 'printing' stamp: 'sw 10/23/2000 17:58'!
printOn: aStream
	"Print out a human-readable representation of the receiver onto aStream"

	super printOn: aStream.
	self class instVarNames do:
		[:aName | aStream nextPutAll: ', ', aName, ' = ', (self instVarNamed: aName) printString]! !


!CardPlayer methodsFor: 'card data' stamp: 'sw 10/13/2000 16:46'!
commitCardPlayerData
	"Transport data back from the morphs that may be holding it into the instance variables that must hold it when the receiver is not being viewed"

	| prior |
	self class variableDocks do:
		[:aDock | aDock storeMorphDataInInstance: self].
	prior _ nil.
	privateMorphs _ OrderedCollection new.
	self costume ifNotNil:
		[self costume submorphs do:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[aMorph setProperty: #priorMorph toValue: prior.
					privateMorphs add: aMorph.
					aMorph delete].
			prior _ aMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'sw 11/14/2000 11:21'!
commitCardPlayerDataFrom: aPlayfield
	"Transport data back from the morphs that may be holding it into the instance variables that must hold it when the receiver is not being viewed"

	| prior itsOrigin |
	itsOrigin _ aPlayfield topLeft.
	self class variableDocks do:
		[:aDock | aDock storeMorphDataInInstance: self].
	prior _ nil.
	privateMorphs _ OrderedCollection new.
	self costume ifNotNil:
		[self costume submorphs do:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[aMorph setProperty: #priorMorph toValue: prior.
					privateMorphs add: aMorph.
					aMorph delete.
					aMorph position: (aMorph position - itsOrigin)].
			prior _ aMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 1/16/2001 16:12'!
installPrivateMorphsInto: aBackground
	"The receiver is being installed as the current card in a given pasteup morph being used as a background.  Install the receiver's private morphs into that playfield"

	| prior originToUse |
	self flag: #deferred.  "not robust if the background is showing a list view"
	privateMorphs ifNotNil: [privateMorphs do:
		[:aMorph |
			originToUse _ aBackground topLeft.
			prior _ aMorph valueOfProperty: #priorMorph ifAbsent: [nil].
			aMorph position: (aMorph position + originToUse).
			(prior notNil and: [aBackground submorphs includes: prior])
				ifTrue:
					[aBackground addMorph: aMorph after: prior]
				ifFalse:
					[aBackground addMorphFront: aMorph].
		aMorph removeProperty: #priorMorph]]! !

!CardPlayer methodsFor: 'card data' stamp: 'tk 1/30/2001 23:42'!
privateMorphs

	^ privateMorphs! !

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

CardPlayer class
	instanceVariableNames: 'variableDocks '!

!CardPlayer class methodsFor: 'class properties' stamp: 'sw 10/13/2000 13:05'!
isUniClass
	"Answer, for the purpose of providing annotation in a method holder, whether the receiver is a uniClass."

	^ self ~~ CardPlayer! !

!CardPlayer class methodsFor: 'class properties' stamp: 'sw 10/13/2000 13:07'!
officialClass
	"Answer (for the purpose of copying mechanisms) the system class underlying the receiver."

	^ CardPlayer! !


!CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 10/13/2000 13:03'!
compileAccessorsFor: varName
	"Compile instance-variable accessor methods for the given variable name"

	| nameString |
	nameString _ varName asString capitalized.
	self compileUnlogged: ('get', nameString, '
	^ ', varName)
		classified: 'access' notifying: nil.
	self compileUnlogged: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access' notifying: nil! !

!CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 10/27/2000 17:09'!
removeAccessorsFor: varName
	"Remove the instance-variable accessor methods associated with varName"

	| nameString |
	nameString _ varName asString capitalized.
	self removeSelectorUnlogged: ('get', nameString) asSymbol.
	self removeSelectorUnlogged: ('set', nameString, ':') asSymbol! !

!CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 10/13/2000 16:37'!
setNewInstVarNames: listOfStrings
	"Make listOfStrings be the new list of instance variable names for the receiver"

	| disappearing firstAppearing instVarString instVarList |
	instVarList _ self instVarNames asOrderedCollection.
	disappearing _ instVarList copy.
	disappearing removeAllFoundIn: listOfStrings.
	disappearing do:
		[:oldName | 	self removeAccessorsFor: oldName].
	firstAppearing _ listOfStrings copy.
	firstAppearing removeAllFoundIn: instVarList.
	firstAppearing do:
		[:newName | self compileAccessorsFor: newName].
	instVarString _ String streamContents:
		[:aStream | listOfStrings do: [:aString | aStream nextPutAll: aString; nextPut: $ ]].

	superclass subclass: self name instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses
! !


!CardPlayer class methodsFor: 'logging' stamp: 'sw 10/13/2000 13:02'!
acceptsLoggingOfCompilation
	"Answer whether methods of the receiver should be logged when submitted."

	^ #(CardPlayer) includes: self class theNonMetaClass name! !

!CardPlayer class methodsFor: 'logging' stamp: 'sw 10/13/2000 16:45'!
wantsChangeSetLogging
	"Log changes for CardPlayer itself, but not for automatically-created subclasses like CardPlayer1, CardPlayer2, but *do* log it for uniclasses that have been manually renamed."

	^ self == CardPlayer or:
		[(self name beginsWith: 'CardPlayer') not]! !


!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:36'!
newVariableDocks: dockList
	"Set the receiver's variableDocks to be the list provided in dockList.  Assimilate this new information into the receiver's slotInfo, which contains both automatically-generated variables such as the variable docks and also explicitly-user-specified variables"

	self variableDocks: dockList.
	self setSlotInfoFromVariableDocks! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/9/2000 07:51'!
setSlotInfoFromVariableDocks
	"Get the slotInfo fixed up after a change in background shape.  Those instance variables that are proactively added by the user will persist, whereas those that are automatically generated will be updated"

	| aDock newInfo |
	
	self slotInfo copy do:  "Remove old automatically-created slots"
		[:aSlotInfo | (aDock _ aSlotInfo variableDock) ifNotNil:
			[slotInfo removeKey: aDock variableName]].

	self variableDocks do:  "Generate fresh slots from variable docks"
		[:dock |
			newInfo _ SlotInformation new type: dock variableType.
			newInfo variableDock: dock.
			slotInfo at: dock variableName asSymbol put: newInfo]! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:39'!
variableDocks
	"Answer the list of variable docks in the receiver.  Initialize the variable-dock list if not already done."

	variableDocks ifNil: [variableDocks _ OrderedCollection new].
	^ variableDocks! !

!CardPlayer class methodsFor: 'variable docks' stamp: 'sw 10/13/2000 16:39'!
variableDocks: dockList
	"Set the variable-dock list as indicated"

	variableDocks _ dockList! !
ParseNode subclass: #CascadeNode
	instanceVariableNames: 'receiver messages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!CascadeNode commentStamp: '<historical>' prior: 0!
The first message has the common receiver, the rest have receiver == nil, which signifies cascading.!


!CascadeNode methodsFor: 'initialize-release'!
receiver: receivingObject messages: msgs
	" Transcript show: 'abc'; cr; show: 'def' "

	receiver _ receivingObject.
	messages _ msgs! !


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

	receiver emitForValue: stack on: aStream.
	1 to: messages size - 1 do: 
		[:i | 
		aStream nextPut: Dup.
		stack push: 1.
		(messages at: i) emitForValue: stack on: aStream.
		aStream nextPut: Pop.
		stack pop: 1].
	messages last emitForValue: stack on: aStream! !

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

	| size |
	size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
	messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
	^size! !


!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level
	self printOn: aStream indent: level precedence: 0! !

!CascadeNode methodsFor: 'printing' stamp: 'di 4/25/2000 19:17'!
printOn: aStream indent: level precedence: p 

	p > 0 ifTrue: [aStream nextPut: $(].
	messages first printReceiver: receiver on: aStream indent: level.
	1 to: messages size do: 
		[:i | (messages at: i) printOn: aStream indent: level.
		i < messages size ifTrue: 
				[aStream nextPut: $;.
				messages first precedence >= 2 ifTrue: [aStream crtab: level + 1]]].
	p > 0 ifTrue: [aStream nextPut: $)]! !


!CascadeNode methodsFor: 'C translation' stamp: 'hg 8/14/2000 15:33'!
asTranslatorNode
	^TStmtListNode new
		setArguments: #()
		statements: (messages collect:
			[ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ]);
		comment: comment! !


!CascadeNode methodsFor: 'tiles' stamp: 'tk 1/15/2001 22:08'!
asMorphicSyntaxIn: parent
	| row |

	row _ parent addRow: #cascade on: self.
	receiver asMorphicSyntaxIn: row.
	messages do: [:m | m asMorphicSyntaxIn: row].
	^ row

"	(node2 _ self copy) receiver: nil messages: messages.
	cascadeMorph _ row addColumn: #cascade2 on: node2.
	messages do: [ :m | m asMorphicSyntaxIn: cascadeMorph].
	^row
"
! !


!CascadeNode methodsFor: 'accessing' stamp: 'tk 10/22/2000 16:55'!
receiver
	^receiver! !
MailDBFile variableSubclass: #CategoriesFile
	instanceVariableNames: 'categories '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!CategoriesFile commentStamp: '<historical>' prior: 0!
I represent the organization of the mail database into set of message lists called "categories". Each category contains a collection of message ID's. The same message may be cross-filed quite cheaply by storing it's ID in multiple categories.

The categories information is kept in a binary file on the disk. It is read into memory in its entirety when the mail database is opened. To make changes persist, the categories information must be saved out to disk. This should be done after fetching new mail and when the mail database is closed. It could also be done periodically by some sort of background process. Note that the categories file, unlike the index file, cannot be re-created from the messages file.
!


!CategoriesFile methodsFor: 'categories access' stamp: 'dvf 6/10/2000 18:32'!
addCategory: categoryName 
	"Add a new category, if it doesn't already exist."
	(self categories includes: categoryName)
		ifFalse: [categories at: categoryName put: PluggableSet integerSet]! !

!CategoriesFile methodsFor: 'categories access'!
categories
	"Answer a collection of my categories, including the pseudo-categories '.unclassified.' and '.all.'. '.unclassified.' contains the orphaned messages that would otherwise not appear in any category. '.all.' contains all the messages in the database. Since these pseudo-categories are computed on the fly, there may be a noticable delay when one of them is selected."

	^(categories keys)
		add: '.all.';
		add: '.unclassified.';
		yourself! !

!CategoriesFile methodsFor: 'categories access' stamp: 'dvf 6/10/2000 18:32'!
file: messageID inCategory: categoryName 
	"Add the given message ID to the given category. The target category  
	must be a real category, not a pseudo-category."
	categoryName = '.unclassified.' | categoryName = '.all.' ifTrue: [^ self].
	(categories includesKey: categoryName)
		ifFalse: [categories at: categoryName put: PluggableSet integerSet].
	(categories at: categoryName)
		add: messageID! !

!CategoriesFile methodsFor: 'categories access'!
isUnclassified: messageID
	"Answer true if the given message ID does not appear in any of my real (not pseudo) categories."

	categories do:
		[: category | (category includes: messageID) ifTrue: [^false]].
	^true! !

!CategoriesFile methodsFor: 'categories access'!
messagesIn: category
	"Answer a collection of message ID's for the messages in the given category. The pseudo-categories are dynamically computed and so they cannot be accessed in this manner."

	^categories at: category ifAbsent: [#()]! !

!CategoriesFile methodsFor: 'categories access'!
remove: messageID fromCategory: categoryName
	"Remove the given message ID from the given category."

	| msgList |
	msgList _ categories at: categoryName ifAbsent: [^self].
	msgList remove: messageID ifAbsent: [].! !

!CategoriesFile methodsFor: 'categories access'!
removeCategory: categoryName
	"Remove the given category, if it exists."

	categories removeKey: categoryName ifAbsent: [].! !

!CategoriesFile methodsFor: 'categories access'!
removeMessagesInCategory: categoryName butNotIn: indexFile
	"Used to clean the dead wood out of a category."

	| oldMsgs newMsgs |
	oldMsgs _ categories at: categoryName ifAbsent: [^self].
	newMsgs _ oldMsgs copy.
	oldMsgs do:
		[: msgID |
		 (indexFile includesKey: msgID) ifFalse:
			[newMsgs remove: msgID]].
	categories at: categoryName put: newMsgs.! !

!CategoriesFile methodsFor: 'categories access' stamp: 'dvf 6/10/2000 19:21'!
renameCategory: oldName to: newName 
	"Rename the given category."
	| oldEntry |
	oldName = '.all.' | oldName = '.unclassified.' | (self categories includes: newName) ifTrue: [^ self].
	"can't rename a special category or overwrite an existing one"
	oldEntry _ categories removeKey: oldName ifAbsent: [PluggableSet integerSet].
	categories at: newName put: oldEntry! !

!CategoriesFile methodsFor: 'categories access'!
unclassifiedFrom: messageIDs
	"Answer the subset of the given set of message ID's that do not appear in any category."

	^messageIDs select:
		[: msgID | self isUnclassified: msgID]! !


!CategoriesFile methodsFor: 'read-write' stamp: 'dvf 6/10/2000 18:33'!
readFrom: aFileStream 
	"Read the categories from the given FileStream."
	| name categorySize messageIDs |
	categories _ Dictionary new: 64.
	aFileStream binary; position: 0.
	[aFileStream atEnd]
		whileFalse: 
			[name _ aFileStream ascii; nextString.
			categorySize _ aFileStream binary; nextWord.
			messageIDs _ PluggableSet integerSet.
			categorySize timesRepeat: [messageIDs add: aFileStream nextInt32].
			categories at: name put: messageIDs]! !

!CategoriesFile methodsFor: 'read-write'!
writeOn: aFileStream
	"Write the categories to the given FileStream. The categories data is stored in binary (as opposed to a human-readable form) to save space."

	aFileStream binary; position: 0.
	categories associationsDo:
		[: category |
		 "(category key) is the category name"
		 "(category value) is the set of message ID's in that category"
		 aFileStream nextStringPut: (category key).
		 aFileStream nextWordPut: (category value) size.
		 (category value) do:
			[: messageID |
			 aFileStream nextInt32Put: messageID]].! !
Viewer subclass: #CategoryViewer
	instanceVariableNames: 'namePane '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!CategoryViewer commentStamp: '<historical>' prior: 0!
A viewer on an object.  Consists of three panes:
   Header pane -- category-name, arrows for moving among categories, etc.
   List pane -- contents are a list of subparts in the chosen category.
   Editing pane -- optional, a detail pane with info relating to the selected element of the list pane.!


!CategoryViewer methodsFor: 'initialization' stamp: 'sw 9/8/2000 10:58'!
initializeFor: aPlayer
	"Initialize the category pane to show the #basic category by default"

	^ self initializeFor: aPlayer categoryChoice: #basic
! !

!CategoryViewer methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:52'!
initializeFor: aPlayer categoryChoice: aChoice
	"Initialize the receiver to be associated with the player and category specified"

	self listDirection: #topToBottom;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		borderWidth: 1;
		beSticky.
	self color: Color green muchLighter muchLighter.
	scriptedPlayer _ aPlayer.
	self addHeaderMorph.

	self categoryChoice: aChoice asSymbol
! !


!CategoryViewer methodsFor: 'categories' stamp: 'ar 11/9/2000 20:52'!
categoryChoice: aCategory
	"Temporarily switch-hits in support of two competing ui designs for the list"
	| bin actualPane |
	((actualPane _ namePane renderedMorph) isKindOf: StringMorph)
		ifTrue:
			[namePane contents: aCategory; color: Color black]
		ifFalse:
			[(actualPane isKindOf: RectangleMorph)
				ifTrue:	[actualPane firstSubmorph contents: aCategory; color: Color black.
						actualPane extent: actualPane firstSubmorph extent]
				ifFalse:
					[actualPane selection: (scriptedPlayer categories indexOf: aCategory)]].

	bin _ PhraseWrapperMorph new borderWidth: 0; listDirection: #topToBottom.
	bin addAllMorphs:
		((scriptedPlayer tilePhrasesForCategory: aCategory inViewer: self) collect:
			[:aViewerRow | self viewerEntryFor: aViewerRow]).
	bin enforceTileColorPolicy.
	submorphs size < 2
		ifTrue:
			[self addMorphBack: bin]
		ifFalse:
			[self replaceSubmorph: self listPane by: bin].
	self world ifNotNil: [self world startSteppingSubmorphsOf: self]

! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/5/2000 10:03'!
chooseCategory
	"The mouse went down on the receiver; pop up a list of category choices"

	| aList aMenu reply aLinePosition lineList |
	aList _ scriptedPlayer categoriesForViewer: self.
	aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil].
	lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition].
	aMenu _ CustomMenu labels: aList lines: lineList selections: aList.
	reply _ aMenu startUpWithCaption: 'category'.
	reply ifNil: [^ self].
	self categoryChoice: reply asSymbol
! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 9/8/2000 16:31'!
currentCategory
	"Answer the symbol representing the receiver's currently-selected category"

	| current actualPane |
	actualPane _ namePane renderedMorph.
	current _ (actualPane isKindOf: StringMorph)
				ifTrue:	[actualPane contents]
				ifFalse:	[actualPane firstSubmorph contents].
	^ current ifNotNil: [current asSymbol] ifNil: [#basic]! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/24/1998 14:24'!
downArrowHit
	self previousCategory! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 11/6/2000 15:57'!
nextCategory
	"Change the receiver to point at the category following the one currently seen"

	| aList anIndex newIndex already aChoice |
	aList _ scriptedPlayer categoriesForViewer: self.
	already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing].
	anIndex _ aList indexOf: self currentCategory ifAbsent: [0].
	newIndex _ anIndex = aList size
		ifTrue:		[1]
		ifFalse:		[anIndex + 1].
	[already includes: (aChoice _ aList at: newIndex)] whileTrue:
		[newIndex _ (newIndex \\ aList size) + 1].
	self categoryChoice: aChoice! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 11/6/2000 15:57'!
previousCategory
	"Change the receiver to point at the category preceding the one currently seen"

	| aList anIndex newIndex already aChoice |
	aList _ scriptedPlayer categoriesForViewer: self.
	already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing].
	anIndex _ aList indexOf: self currentCategory ifAbsent: [aList size + 1].
	newIndex _ anIndex = 1
		ifTrue:		[aList size]
		ifFalse:		[anIndex - 1].
	[already includes: (aChoice _ aList at: newIndex)] whileTrue:
		[newIndex _ newIndex = 1 ifTrue: [aList size] ifFalse: [newIndex - 1]].

	self categoryChoice: aChoice! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 10/24/1998 14:25'!
upArrowHit
	self nextCategory! !

!CategoryViewer methodsFor: 'categories' stamp: 'sw 11/5/1998 09:09'!
viewerEntryFor: aViewerRow
	| anEntry |
	anEntry _ ViewerEntry newColumn.
	anEntry addMorphBack: aViewerRow.
	^ anEntry! !


!CategoryViewer methodsFor: 'editing pane' stamp: 'sw 10/30/1998 18:16'!
contents: c notifying: k
	"later, spruce this up so that it can accept input such as new method source"
	self beep.
	^ false! !


!CategoryViewer methodsFor: 'header pane' stamp: 'ar 11/9/2000 21:12'!
addHeaderMorph
	"Add the header at the top of the viewer, with a control for choosing the category, etc."

	| header aFont aButton wrpr |
	header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter.
	aFont _ Preferences standardButtonFont.
	header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont).
	aButton target: self;
			color:  Color tan;
			actionSelector: #delete;
			setBalloonText: 'remove this pane from the screen
don''t worry -- nothing will be lost!!.'.
	header addTransparentSpacerOfSize: 5@5.

	header addUpDownArrowsFor: self.
	(wrpr _ header submorphs last) submorphs second setBalloonText: 'previous category'.	
	wrpr submorphs first  setBalloonText: 'next category'.
	header beSticky.
	self addMorph: header.

	namePane _ RectangleMorph newSticky color: Color brown veryMuchLighter.
	namePane borderWidth: 0.
	aButton _ (StringButtonMorph contents: '-----' font: (StrikeFont familyName: #NewYork size: 12)) color: Color black.
	aButton target: self; arguments: Array new; actionSelector: #chooseCategory.
	aButton actWhen: #buttonDown.
	namePane addMorph: aButton.
	aButton position: namePane position.
	namePane align: namePane topLeft with: (bounds topLeft + (50 @ 0)).
	namePane setBalloonText: 'category (click here to choose a different one)'.

	header addMorphBack: namePane.
	(namePane isKindOf: RectangleMorph) ifTrue:
		[namePane addDropShadow.
		namePane shadowColor: Color gray].

	self categoryChoice: #basic! !


!CategoryViewer methodsFor: 'list pane' stamp: 'sw 10/23/1998 13:50'!
listPane
	^ submorphs second! !


!CategoryViewer methodsFor: 'entries' stamp: 'sw 10/30/1998 18:23'!
addIsOverColorDetailTo: aRow
	| clrTile readout aTile |
	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer".
	aRow addMorphBack: (clrTile _ Color blue newTileMorphRepresentative).
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"
	readout _ UpdatingStringMorphWithArgument new
			target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
			argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
	readout useDefaultFormat.
	aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
	aTile addMorphBack: readout.
	aRow addMorphBack: aTile.
	aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30! !

!CategoryViewer methodsFor: 'entries' stamp: 'RAA 1/13/2001 09:37'!
addTouchesADetailTo: aRow
	| clrTile readout aTile |
	aRow addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer".
	aRow addMorphBack: (clrTile _ self tileForSelf).
	aRow addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"

	"readout _ UpdatingStringMorphWithArgument new
			target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil;
			argumentTarget: clrTile colorSwatch argumentGetSelector: #color.
	readout useDefaultFormat.
	aTile _ StringReadoutTile new typeColor: Color lightGray lighter.
	aTile addMorphBack: readout.
	aRow addMorphBack: aTile.
	aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 10/9/2000 16:54'!
infoButtonFor: aScriptOrSlotSymbol
	"Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol"

	| aButton balloonTextSelector |
	balloonTextSelector _ nil.
	((scriptedPlayer isKindOf: Player) and: [scriptedPlayer slotInfo includesKey: aScriptOrSlotSymbol asSymbol])
		ifTrue: [balloonTextSelector _ #userSlot].

	(scriptedPlayer belongsToUniClass and:
			[scriptedPlayer class includesSelector: aScriptOrSlotSymbol])
		ifTrue: [balloonTextSelector _ #userScript].

	aButton _ SimpleButtonMorph new.
	aButton target: scriptedPlayer;
		actionSelector: #infoFor:inViewer:;
		arguments: (Array with: aScriptOrSlotSymbol with: self);
		label: '¥' font: (StrikeFont familyName: #ComicBold size: 12);
		color: Color transparent;
		borderWidth: 0;
		actWhen: #buttonDown.
	balloonTextSelector
		ifNotNil:	[aButton balloonTextSelector: balloonTextSelector]
		ifNil:		[aButton setBalloonText: 'Press here to get a menu'].
	^ aButton! !

!CategoryViewer methodsFor: 'entries' stamp: 'tk 1/27/2001 12:06'!
phraseForSlot: slotSpec
	"Return a PhraseTileMorph representing a variable belonging to the player"

	"The slot spec if a tuple with the following structure:
		1	#slot
		2	slot name
		3	balloon help
		4	slot type
		5	#readOnly,# readWrite, or #writeOnly
		6	getter receiver indicator
		7	getter selector
		8	setter receiver indicator
		9	setter selector

	NB:	all are symbols except #3, which is a string"

	| r anArrow slotName getterButton ut cover inner |

	r _ ViewerRow newRow
		color: self color;
		beSticky;
		elementSymbol: (slotName _ slotSpec second);
		wrapCentering: #center;
		cellPositioning: #leftCenter.

	r addMorphBack: (self slotHeaderFor: slotName).
	r addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"

	r addMorphBack: (self infoButtonFor: slotName).
	r addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"

	ut _ scriptedPlayer isUniversalTiles.
	ut ifTrue: [inner _ self newTilesFor: scriptedPlayer getter: slotSpec.
			cover _ (Morph new) color: Color transparent.
			cover extent: inner fullBounds extent.
			(getterButton _ cover copy) addMorph: cover; addMorphBack: inner.
			cover on: #mouseDown send: #newMakeGetter:from:forPart:
					to: self withValue: slotSpec]
		ifFalse: [r addMorphBack: self tileForSelf bePossessive.
			r addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
			getterButton _ self getterButtonFor: slotName type: slotSpec fourth].
	r addMorphBack: getterButton.
	getterButton setBalloonText: slotSpec third.

	(slotName == #isOverColor) ifTrue: [
		self addIsOverColorDetailTo: r.
		^ r
	].
	(slotName == #touchesA) ifTrue: [
		self addTouchesADetailTo: r.
		^ r
	].

	(slotSpec fifth == #readOnly) ifFalse:
		[r addMorphBack: (Morph new color: self color; extent: 2@10).  " spacer"
		anArrow _ ut 
			ifTrue: [self arrowSetterButton: #newMakeSetter:from:forPart:
						args: slotSpec]
			ifFalse: [self arrowSetterButton: #makeSetter:from:forPart:
						args: (Array with: slotName with: slotSpec fourth)].
		r addMorphBack: anArrow.
		].
	r addMorphBack: (AlignmentMorph new beTransparent).  "flexible spacer"
	(#(colorSees playerSeeingColor copy touchesA) includes: slotName) ifFalse:
 		[r addMorphBack: (self readoutFor: slotName type: slotSpec fourth readOnly: slotSpec fifth getSelector: slotSpec seventh putSelector: slotSpec ninth)].

	anArrow ifNotNil: [anArrow step].
	^ r! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 3/10/2000 17:25'!
readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector
	| readout |
 	(partType == #player) ifTrue:
		[readout _ PlayerReferenceReadout new objectToView: scriptedPlayer viewSelector: getSelector putSelector: putSelector].

	(partType == #color) ifTrue:
		[readout _ UpdatingRectangleMorph new
		getSelector: (ScriptingSystem getterSelectorFor: partName);
		target: scriptedPlayer costume renderedMorph;
		borderWidth: 1;
		extent:  22@22.
		putSelector == #unused ifFalse: [readout putSelector: (ScriptingSystem setterSelectorFor: partName)]].

	readout ifNil: [readout _ scriptedPlayer costume updatingTileForArgType: partType partName: partName getSelector: getSelector putSelector: putSelector].
	readout step.
	^ readout! !

!CategoryViewer methodsFor: 'entries' stamp: 'sw 1/13/1999 13:00'!
slotHeaderFor: aSlotName
	^ Morph new beTransparent extent:  9@22! !


!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 11/8/2000 21:59'!
arrowSetterButton: sel args: argArray

	| m |
	m _ RectangleMorph new
		color: (ScriptingSystem colorForType: #command);
		extent: 24@TileMorph defaultH;
		borderWidth: 0.
	m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')).
	m setBalloonText: 'drag from here to obtain an assignment phrase.'.
	m on: #mouseDown send: sel
		to: self
		withValue: argArray.
	^ m
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 10/28/1999 08:49'!
arrowSetterButtonFor: partName type: partType

	| m |
	m _ RectangleMorph new
		color: (ScriptingSystem colorForType: #command);
		extent: 24@TileMorph defaultH;
		borderWidth: 0.
	m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')).
	m setBalloonText: 'drag from here to obtain an assignment phrase.'.
	m on: #mouseDown send: #makeSetter:from:forPart:
		to: self
		withValue: (Array with: partName with: partType).
	^ m
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 10/29/1998 15:59'!
getterButtonFor: partName type: partType

	| m |
	m _ TileMorph new setOperator: partName.
	m typeColor: (ScriptingSystem colorForType: partType).
	m on: #mouseDown send: #makeGetter:from:forPart:
		to: self
		withValue: (Array with: partName with: partType).
	^ m! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 1/13/2001 11:42'!
makeGetter: evt from: aMorph forPart: args

	| m selfTile selector aType firstArg |
	(aType _ args last) == #unknown ifTrue: [^ self beep].

	(#(colorSees isOverColor touchesA) includes: (firstArg _ args first))
		ifFalse:
			[m _ PhraseTileMorph new setSlotRefOperator: args first asSymbol type: aType]
		ifTrue:
			[(firstArg == #colorSees) ifTrue: [m _ self colorSeesPhrase].
			(firstArg == #isOverColor) ifTrue: [m _ self seesColorPhrase].
			(firstArg == #touchesA) ifTrue: [m _ self touchesAPhrase].
		].

	selfTile _ self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.

	selector _ m submorphs at: 2.
	(aType == #number) ifTrue:
		[selector addSuffixArrow].
	selector updateLiteralLabel.

	m enforceTileColorPolicy.

	owner ifNotNil: [self primaryHand attachMorph: m]
		ifNil: [^ m].
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 8/3/1999 15:47'!
makeSetter: evt from: aMorph forPart: args

	| argType m argTile selfTile argValue |
	argType _ args last.
	m _ PhraseTileMorph new setAssignmentRoot: args first asSymbol
		type: #command
		rcvrType: #player
		argType: argType.

	argValue _ self scriptedPlayer perform: (ScriptingSystem getterSelectorFor: args first asSymbol).
	(argValue isKindOf: Player)
		ifTrue:
			[argTile _ argValue tileReferringToSelf]
		ifFalse:
			[argTile _ scriptedPlayer tileForArgType: argType inViewer: self.
			argTile setLiteral: argValue; updateLiteralLabel.].
	argTile position: m lastSubmorph position.

	m lastSubmorph addMorph: argTile.

	selfTile _ self tileForSelf bePossessive.
	selfTile position: m firstSubmorph position.
	m firstSubmorph addMorph: selfTile.

	m enforceTileColorPolicy.
	owner ifNotNil: [self primaryHand attachMorph: m]
		ifNil: [^ m].
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 11/9/2000 13:48'!
newMakeGetter: evt from: aMorph forPart: aSpec
	"Button in viewer performs this to make a new style tile and attach to hand."

	| m |
	m _ self newTilesFor: scriptedPlayer getter: aSpec.
	owner ifNotNil: [self primaryHand attachMorph: m.
			m align: m topLeft with: evt hand position + (7@14)]
		ifNil: [^ m].
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 11/9/2000 13:48'!
newMakeSetter: evt from: aMorph forPart: aSpec
	"Button in viewer performs this to make a new style tile and attach to hand."

	| m |
	m _ self newTilesFor: scriptedPlayer setter: aSpec.
	owner ifNotNil: [self primaryHand attachMorph: m.
			m align: m topLeft with: evt hand position + (7@14)]
		ifNil: [^ m].
! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 2/3/2001 01:57'!
newTilesFor: aPlayer command: aSpec
	| ms argTile argArray sel |
	"Return universal tiles for a command.  Record who self is."

	sel _ aSpec second.
	aSpec size > 3 
		ifTrue: [argTile _ aPlayer tileForArgType: aSpec fourth inViewer: nil.
				argArray _ Array with: (aSpec fourth == #player 
					ifTrue: [argTile actualObject]
					ifFalse: [argTile literal]).	"default value for each type"
				sel == #colorSees ifTrue: [sel _ #color:sees:.  
							argArray _ argArray, argArray].	"two colors"
				sel == #isOverColor ifTrue: [sel _ #seesColor:].
				sel == #touchesA ifTrue: [sel _ #touchesA:].
		]
		ifFalse: [argArray _ #()].
	ms _ MessageSend receiver: aPlayer selector: sel arguments: argArray.
	^ ms asTilesIn: aPlayer class! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 1/26/2001 13:02'!
newTilesFor: aPlayer getter: aSpec
	| ms argTile argArray |
	"Return universal tiles for a getter on this property.  Record who self is."

	ms _ MessageSend receiver: aPlayer selector: aSpec seventh arguments: #().
	aSpec second == #colorSees ifTrue: [
		ms selector: #color:sees:.
		argTile _ aPlayer tileForArgType: #color inViewer: nil.
		argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy. 
		ms arguments: argArray].
	aSpec second == #isOverColor ifTrue: [
		ms selector: #seesColor:.
		argTile _ aPlayer tileForArgType: #color inViewer: nil.
		ms arguments: (Array with: argTile colorSwatch color)].
	aSpec second == #touchesA ifTrue: [
		ms selector: #touchesA:.
		argTile _ aPlayer tileForArgType: #player inViewer: nil.
		ms arguments: (Array with: argTile actualObject)].
	^ ms asTilesIn: aPlayer class! !

!CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 1/26/2001 12:44'!
newTilesFor: aPlayer setter: aSpec
	| ms  argValue |
	"Return universal tiles for a getter on this property.  Record who self is."

	argValue _ aPlayer perform: (ScriptingSystem getterSelectorFor: aSpec second asSymbol).
	ms _ MessageSend receiver: aPlayer selector: aSpec ninth arguments: (Array with: argValue).
	^ ms asTilesIn: aPlayer class! !


!CategoryViewer methodsFor: 'support' stamp: 'sw 9/21/2000 22:36'!
booleanPhraseForRetrieverOfType: retrieverType retrieverOp: retrieverOp player: aPlayer
	"Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result"

	| outerPhrase getterPhrase receiverTile  rel finalTile |
	rel _ (retrieverType == #number)
		ifTrue:		[#<]
		ifFalse:		[#=].
	outerPhrase _ PhraseTileMorph new setOperator: rel type: #boolean rcvrType: retrieverType argType: retrieverType.
	getterPhrase _  PhraseTileMorph new setOperator: retrieverOp type: retrieverType rcvrType: #player.
	getterPhrase submorphs last setSlotRefOperator: (Utilities inherentSelectorForGetter: retrieverOp).
	receiverTile _ (self tileForPlayer: aPlayer) bePossessive.
	receiverTile position: getterPhrase firstSubmorph position.
	getterPhrase firstSubmorph addMorph: receiverTile.

	outerPhrase firstSubmorph addMorph: getterPhrase.
	finalTile _ aPlayer tileForArgType: retrieverType.	"comes with arrows"
	outerPhrase submorphs last addMorph: finalTile.
	outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel).    
	^ outerPhrase! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 3/1/1999 11:56'!
booleanPhraseFromPhrase: phrase

	|  retrieverOp retrieverTile |
	phrase isBoolean ifTrue: [^ phrase].
	scriptedPlayer costume isInWorld ifFalse: [^ Array new].
	((retrieverTile _ phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase].
	retrieverOp _ retrieverTile operatorOrExpression.

	(#(color number player) includes: phrase resultType) ifTrue:
		[^ self booleanPhraseForRetrieverOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject].

	^ phrase! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 10/30/1998 18:15'!
contentsSelection
	"Not well understood why this needs to be here!!"
	^ 1 to: 0! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 3/1/1999 11:57'!
invisiblySetPlayer: aPlayer
	scriptedPlayer _ aPlayer! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 11/18/1999 16:04'!
outerViewer
	"Answer the StandardViewer or equivalent that contains this object"
	^ self ownerThatIsA: Viewer! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 10/29/1998 15:59'!
tileForPlayer: aPlayer
	"Return a tile representing aPlayer"

	^ TileMorph new
		setObjectRef: nil "disused parm" actualObject: aPlayer;
		typeColor: (ScriptingSystem colorForType: #player)
! !

!CategoryViewer methodsFor: 'support' stamp: 'sw 10/21/1998 14:55'!
tileForSelf
	"Return a tile representing the target morph itself."

	^ self tileForPlayer: scriptedPlayer
! !

WorldViewModel subclass: #CautiousModel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Morphic'!
!CautiousModel commentStamp: '<historical>' prior: 0!
A model for a morphic world view which will ask for confirmation before being closed, unless the corresponding preference is set to false. !


!CautiousModel methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1998 16:45'!
okToChange
	Preferences cautionBeforeClosing ifFalse: [^ true].
	Sensor leftShiftDown ifTrue: [^ true].

	self beep.
	^ self confirm: 'Warning!!
If you answer "yes" here, this
window will disappear and
its contents will be lost!!
Do you really want to do that?'

"CautiousModel new okToChange"! !
Model subclass: #Celeste
	instanceVariableNames: 'mailDB currentCategory currentMessages currentTOC currentMsgID lastCategory subjectFilter fromFilter dateFilter customFilterBlock formatMessages lastCategoryList lastCategoryMenu messageTextView userPassword status tocLists participantFilter '
	classVariableNames: 'CCList CustomFilters DeleteInboxAfterFetching FormatWhenFetching MessageCountLimit PopServer PopUserName SmtpServer SuppressWorthlessHeaderFields TimeZone UserName '
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!Celeste commentStamp: '<historical>' prior: 0!
I am the core of a mail reading and organizing program. The name "Celeste" is a reference to an earlier mail reader named "Babar", which was written at Xerox PARC by Steve Putz and John Maloney.

This object provides a user interface and some higher-level functionality for the application. The foundation of of the mail reader is really the mail database, implemented by the class MailDB.
!


!Celeste methodsFor: 'open-close' stamp: 'jm 10/4/1998 14:01'!
close
	"Close the mail database."

	userPassword _ nil.
	mailDB ifNotNil: [
		mailDB close; release.
		mailDB _ nil].
! !

!Celeste methodsFor: 'open-close' stamp: 'dvf 11/18/2000 17:06'!
isActive
	^mailDB notNil! !

!Celeste methodsFor: 'open-close' stamp: 'ls 1/27/2001 18:21'!
openOnDatabase: aMailDB
	"Initialize myself for the mail database with the given root filename."

	mailDB _ aMailDB.
	mailDB addDependent: self.
	currentCategory _ 'new'.
	lastCategory _ ''.
	subjectFilter _ ''.
	fromFilter _ ''.
	participantFilter _ ''.
	dateFilter _ nil.
	self setCategory: currentCategory.
! !

!Celeste methodsFor: 'open-close' stamp: 'jm 8/20/1998 18:37'!
windowIsClosing
	"Close the mail database when my window is closed."

	self close.
! !


!Celeste methodsFor: 'categories pane' stamp: 'mdr 11/22/1999 14:05'!
addCategory
	"Create a new category with the user-specified name. This does nothing if the category already exists."

	| newCatName |
	newCatName _ FillInTheBlank request: 'Name for new category?'.
	(newCatName isEmpty) ifTrue: [^self].	"user aborted"

	self requiredCategory: newCatName.
	self setCategory: newCatName.
! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/28/2001 23:14'!
cacheTOC
	"Caches a version of the TOC"
	| s tocString tocStringColumns |
	self initializeTocLists.
	currentTOC _ OrderedCollection new: currentMessages size.
	'Processing ' , currentMessages size printString , ' messages.'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: currentMessages size
		during: [:bar | 1
				to: currentMessages size
				do: [:i | 
					bar value: i.
					s _ WriteStream
								on: (String new: 100).
					s nextPutAll: i printString;
						 space.
					(self tocLists at: 1)
						add: i printString.
					[s position < 4]
						whileTrue: [s space].
					tocString _ mailDB
								getTOCstring: (currentMessages at: i).
					"columns from the database are 5"
					tocStringColumns _ mailDB
								getTOCstringAsColumns: (currentMessages at: i).
					s nextPutAll: tocString.
					currentTOC add: s contents.
					(self tocLists at: 2)
						add: ((tocStringColumns at: 5)
								ifTrue: ['@']
								ifFalse: [' ']).
					(self tocLists at: 3)
						add: (tocStringColumns at: 1).
					(self tocLists at: 4)
						add: (tocStringColumns at: 2).
					(self tocLists at: 5)
						add: (tocStringColumns at: 4).
					(self tocLists at: 6)
						add: (tocStringColumns at: 3)]].
	currentTOC _ currentTOC asArray.
	(currentMessages includes: currentMsgID)
		ifFalse: [currentMsgID _ nil]! !

!Celeste methodsFor: 'categories pane' stamp: 'jm
 8/20/1998 09:24'!
categoriesKeystroke: aCharacter

	aCharacter asciiValue = 30 ifTrue: [self previousCategory].
	aCharacter asciiValue = 31 ifTrue: [self nextCategory].
! !

!Celeste methodsFor: 'categories pane'!
category
	"Answer the currently selected category or nil."

	^currentCategory! !

!Celeste methodsFor: 'categories pane' stamp: 'jm
 8/20/1998 10:25'!
categoryList
	"Answer a list of categories for the categories pane."

	^ mailDB allCategories
! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 21:29'!
categoryMenu: aMenu 
	"Answer the menu for the categories pane."
	aMenu add: 'save' action: #save.
	aMenu balloonTextForLastItem: 'Save the database'.
	aMenu addLine.
	aMenu add: 'fetch mail' action: #fetchMail.
	aMenu balloonTextForLastItem: 'Fetch new mail from the server'.
	aMenu add: 'send queued mail' action: #sendQueuedMail.
	aMenu balloonTextForLastItem: 'Send newly written mail'.
	aMenu addLine.
	aMenu add: 'add category' action: #addCategory.
	aMenu balloonTextForLastItem: 'Add a new organizational category'.
	currentCategory notNil
		ifTrue: [aMenu add: 'view all messages' action: #viewAllMessages.
			aMenu balloonTextForLastItem: 'View all the messages'].
	"add extra commands if a normal category is selected"
	(currentCategory notNil
			and: [currentCategory ~= '.all.' & (currentCategory ~= '.unclassified.')])
		ifTrue: [aMenu add: 'edit category filter' action: #editCategoryFilter.
			aMenu balloonTextForLastItem: 'Edit a custom filter for this category'.
			aMenu add: 'rename category' action: #renameCategory.
			aMenu balloonTextForLastItem: 'Rename this organizational category'.
			aMenu add: 'remove category' action: #removeCategory.
			aMenu balloonTextForLastItem: 'Remove this organizational category
(NB: all messages will be safely available in other categories)'.
			aMenu addLine.
			aMenu add: 'import into category' action: #importIntoCategory.
			aMenu balloonTextForLastItem: 'Import messages from a Unix/Eudora file into this category'.
			aMenu add: 'export category (Celeste)' action: #exportCategory.
			aMenu balloonTextForLastItem: 'Copy all messages from this category to another Celeste database'.
			aMenu add: 'export category (Unix/Eudora)' action: #exportCategoryUnix.
			aMenu balloonTextForLastItem: 'Write a copy of all messages from this category to a Unix/Eudora file'].
	aMenu addLine.
	aMenu add: 'empty trash' action: #emptyTrash.
	aMenu balloonTextForLastItem: 'Completely remove all messages in the category .trash. from Celeste'.
	aMenu add: 'salvage & compact' action: #compact.
	aMenu balloonTextForLastItem: 'Salvage any work done since the last database save & recover space used by old deleted messages.
(This may be a bit slow)'.
	aMenu add: 'find duplicates' action: #findDuplicates.
	aMenu balloonTextForLastItem: 'Find messages which are exact duplicates'.
	aMenu addLine.
	aMenu addUpdating: #suppressingHeadersString action: #toggleSuppressHeaders.
	aMenu balloonTextForLastItem: 'Show either a complete or an easy-to-read message header'.
	aMenu add: 'change max current messages (' , self class messageCountLimit printString , ')' action: #changeMaxMessageCount.
	aMenu addLine.
	aMenu add: 'set user name' action: #setUserName.
	aMenu balloonTextForLastItem: 'Specify the ''From:'' user name for new messages'.
	aMenu add: 'set cc: list' action: #setCCList.
	aMenu balloonTextForLastItem: 'Specify a cc: list that is added to each new message'.
	aMenu add: 'set POP server' action: #setPopServer.
	aMenu balloonTextForLastItem: 'Specify which (POP3) server to check for new messages'.
	aMenu add: 'set POP username' action: #setPopUserName.
	aMenu balloonTextForLastItem: 'Specify the username to use when checking for new messages'.
	aMenu add: 'set SMTP server' action: #setSmtpServer.
	aMenu balloonTextForLastItem: 'Specify which (SMTP) server to use when sending messages'.
	aMenu addLine.
	aMenu addUpdating: #messagesOnServerString action: #toggleKeepMessagesOnServer.
	aMenu balloonTextForLastItem: 'When true, messages are not deleted from the server when you retreive them (typically used for testing only).  When false, messages are deleted from the server after you retreive them'.
	^ aMenu! !

!Celeste methodsFor: 'categories pane'!
compact
	"Compact the messages file."

	| stats |
	Transcript cr; show: 'Compacting message file...'.
	Cursor execute showWhile: [stats _ mailDB compact].
	Transcript show: 'Done.'; cr.
	Transcript show:
		'Recovered ',
		(stats at: 1) printString, ' message',
		(((stats at: 1) > 1) ifTrue: ['s, '] ifFalse: [', ']),
		(stats at: 2) printString, ' bytes.'; cr.! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/12/1998 01:45'!
deleteMessagesAfterFetching
	"start deleting messages off the server after POP-ing"
	DeleteInboxAfterFetching _ true! !

!Celeste methodsFor: 'categories pane' stamp: 'mdr 8/17/2000 17:38'!
emptyTrash
	"Delete all messages in the '.trash.' category.
	WARNING: The messages will be totally removed from the Celeste index, and the .messages file will be marked so that the message contents are removed when it is next compressed."

	| msgList |

	self requiredCategory: '.trash.'.

	msgList _ mailDB messagesIn: '.trash.'.			"Look at ALL messages in the trash"
	"Remove from the list messages which are also in other categories"
	msgList _ msgList select: [ :msgID | (mailDB categoriesThatInclude: msgID) size = 1].

	mailDB deleteAll: msgList.
	mailDB cleanUpCategories.
	self updateTOC.

	(mailDB messagesIn: '.trash.') isEmpty ifFalse:
		[self inform: 'Some messages were not removed because they are also filed in other categories'].! !

!Celeste methodsFor: 'categories pane' stamp: 'mdr 11/22/1999 12:54'!
exportCategory
	"Store the filtered message list of the current category to another mail database. The user is prompted for the name of the other database."

	| destDBName destDB |
	currentCategory ifNil: [ ^self ].

	destDBName _ FillInTheBlank
		request: 'Destination mail database?'
		initialAnswer: ''.
	(destDBName isEmpty) ifTrue: [^self].
	destDB _ MailDB openOn: destDBName.
	(destDB isNil) ifTrue: [^self].
	destDB mergeMessages: (self filteredMessagesIn: currentCategory) from: mailDB.
	destDB saveDB.
! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/17/1998 05:42'!
exportCategoryUnix
	"Store the filtered message list of the current category into a Eudora/Unix database"
	| destFileName destFile messageIds count |

	currentCategory ifNil: [ ^self ].

	destFileName _ FillInTheBlank
		request: 'Destination mail file?'
		initialAnswer: ''.
	(destFileName isEmpty) ifTrue: [^self].
	destFile _ FileStream fileNamed: destFileName.
	destFile ifNil: [ ^self error: 'could not open file' ].
	destFile setToEnd.

	messageIds _ self filteredMessagesIn: currentCategory.

	('exporting ', messageIds size printString, ' messages')
		displayProgressAt: Sensor mousePoint
		from: 0
		to: messageIds size
		during: [ :bar |
			count _ 0.
			messageIds do: [ :messageId |
				destFile nextPutAll: Celeste eudoraSeparator.
				(mailDB getMessage: messageId) text linesDo: [ :line |
					(line beginsWith: 'From ') ifTrue: [ destFile nextPut: $> ].
					destFile nextPutAll: line.
					destFile cr ].
				count _ count + 1.
				bar value: count. ].
		].

	destFile close.
! !

!Celeste methodsFor: 'categories pane' stamp: 'mdr 11/22/1999 12:55'!
fetchMail
	"Append messages from the user's mailbox to this mail database."

	| server password msgCount |
	server _ self class popServer.
	password _ self popPassword.
	(password isNil or: [password isEmpty]) ifTrue: [^ self].

	self requiredCategory: 'new'.

	msgCount _ mailDB fetchMailFromPOP: server
		userName: self class popUserName
		password: password
		doFormatting: FormatWhenFetching
		deleteFromServer: DeleteInboxAfterFetching.
	msgCount < 0
		ifTrue: [self inform: 'could not connect to the mail server']
		ifFalse: [self inform: msgCount printString, ' messages fetched'].
	msgCount <= 0 ifTrue: [^ self].

	self setCategory: 'new'.

! !

!Celeste methodsFor: 'categories pane' stamp: 'mdr 11/22/1999 15:52'!
findDuplicates
	"Find duplicate messages, and move the redundant copies to a given category."

	| duplicatesCategory |
	duplicatesCategory _ FillInTheBlank
		request: 'File duplicates in category?'
		initialAnswer: '.duplicates.'.
	duplicatesCategory isEmpty ifTrue:[^ self].

	self requiredCategory: duplicatesCategory.

	Utilities informUser: 'Searching for duplicates...'
		during: [mailDB fileDuplicatesIn: duplicatesCategory].

	self setCategory: duplicatesCategory.
! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/17/1998 05:17'!
importIntoCategory
	"Add the messages from a Unix or Eudora format file into this category"

	| inboxPath count |

	currentCategory ifNil: [ ^self ].

	"get the file to import from"
	inboxPath _ ''.
	[	inboxPath _ FillInTheBlank request: 'file to import from?\(should be Eudora or Unix format)' withCRs.
		inboxPath isEmpty ifTrue: [ ^self ].
		FileStream isAFileNamed: inboxPath 
	] whileFalse: [
		self inform: 'file does not exist' ].

	Utilities informUser: 'Fetching mail from ', inboxPath during: [
		count _ mailDB importMailFrom: inboxPath  intoCategory: currentCategory. ].
	self inform: count printString, ' messages imported'.

	self updateTOC.! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/12/1998 01:45'!
keepMessagesOnServer
	"start keeping messages on the server after POP-ing"
	DeleteInboxAfterFetching _ false! !

!Celeste methodsFor: 'categories pane' stamp: 'sma 4/22/2000 20:17'!
maxMessageCount
	^ 200! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 20:12'!
maxMessagesToDisplay
	"return the maximum number of mesasges to display at one time; the  
	motivation is that huge lists of messages are impractical"
	^ self class messageCountLimit! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 20:25'!
messages: actuallyShown from: possible 
	self class includeStatusPane ifTrue: [
	self status: 'Showing ' , actuallyShown printString , ' of ' , possible printString , ' messages in "' , self category , '"']! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 21:07'!
messagesOnServerString
	| string |
	string _ 'leave messages on server'.
	^ DeleteInboxAfterFetching 
		ifTrue: ['<no>' , string]
		ifFalse: ['<yes>' , string]! !

!Celeste methodsFor: 'categories pane' stamp: 'jm 10/4/1998 10:39'!
nextCategory
	"Select the next category."

	| catList i |
	catList _ self categoryList.
	(currentCategory isNil) ifTrue: [currentCategory _ catList last].
	i _ catList indexOf: currentCategory.
	i < catList size
		ifTrue: [self setCategory: (catList at: i + 1)]
		ifFalse: [self setCategory: (catList at: 1)].
! !

!Celeste methodsFor: 'categories pane' stamp: 'jm 10/4/1998 10:39'!
previousCategory
	"Select the next category."

	| catList i |
	catList _ self categoryList.
	(currentCategory isNil) ifTrue: [currentCategory _ catList last].
	i _ catList indexOf: currentCategory.
	i > 1
		ifTrue: [self setCategory: (catList at: i - 1)]
		ifFalse: [self setCategory: (catList at: catList size)].
! !

!Celeste methodsFor: 'categories pane' stamp: 'jm 10/4/1998 10:37'!
removeCategory
	"Remove the existing category with the user-specified name."

	| msgList |
	currentCategory ifNil: [ ^self ].

	msgList _ mailDB messagesIn: currentCategory.
	(mailDB messagesIn: '.trash.') do: [: id |
		msgList remove: id ifAbsent: []].
	msgList isEmpty ifFalse: [
		(self confirm:
'This category is not empty. Are
you sure you wish to remove it?') ifFalse: [^self]].
	mailDB removeCategory: currentCategory.

	self changed: #categoryList.
	self setCategory: nil.
! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/17/1998 05:45'!
renameCategory
	"Rename the category with the user-specified name."

	| newCatName |
	currentCategory ifNil: [ ^self ].

	newCatName _ FillInTheBlank
		request: 'New name?'
		initialAnswer: currentCategory.
	(newCatName isEmpty) ifTrue: [^self].	"user aborted"
	mailDB renameCategory: currentCategory to: newCatName.
	currentCategory _ newCatName.
	self changed: #categoryList.! !

!Celeste methodsFor: 'categories pane' stamp: 'jm 8/20/1998 18:34'!
save
	"Snapshot the database to disk."

	mailDB saveDB.
! !

!Celeste methodsFor: 'categories pane'!
setCCList
	"Change the default cc: list for use in composing messages."

	self class setCCList.! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 20:20'!
setCategory: newCategory 
	"Change the currently selected category. We must also compute the table  
	of contents and message list for the new category."
	| messageCount |
	currentCategory _ newCategory.
	newCategory isNil
		ifTrue: [currentMessages _ currentTOC _ currentMsgID _ nil.
			self class includeStatusPane
				ifTrue: [status _ nil]]
		ifFalse: [currentMessages _ self filteredMessagesIn: newCategory.
			messageCount _ currentMessages size.
			messageCount > self maxMessagesToDisplay
				ifTrue: [self messages: self maxMessagesToDisplay from: messageCount.
				currentMessages _ currentMessages copyLast: self maxMessagesToDisplay]
				ifFalse: [self messages: messageCount from: messageCount].
			self cacheTOC].
	self changed: #category.
	self changed: #tocEntryList.
	self changed: #tocEntry.
	self changed: #messageText.
	self changed: #status! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/12/1998 00:37'!
setPopServer
	^self class setPopServer! !

!Celeste methodsFor: 'categories pane' stamp: 'mdr 7/31/2000 19:03'!
setPopUserName
	userPassword _ nil.   "Clear the password when a new username is set"
	^self class setPopUserName! !

!Celeste methodsFor: 'categories pane' stamp: 'ls 9/13/1998 02:31'!
setSmtpServer
	^self class setSmtpServer! !

!Celeste methodsFor: 'categories pane'!
setUserName
	"Change the user's email name for use in composing messages."

	self class setUserName.! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 21:02'!
suppressingHeadersString
	| string |
	string _ 'suppress header'.
	^ SuppressWorthlessHeaderFields
		ifTrue: ['<yes>' , string]
		ifFalse: ['<no>' , string]! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 21:22'!
toggleKeepMessagesOnServer
	DeleteInboxAfterFetching _ DeleteInboxAfterFetching not! !

!Celeste methodsFor: 'categories pane' stamp: 'jm
 8/20/1998 10:35'!
toggleSuppressHeaders

	SuppressWorthlessHeaderFields _ SuppressWorthlessHeaderFields not.
	self changed: #messageText.
! !

!Celeste methodsFor: 'categories pane' stamp: 'sbw 1/30/2001 19:50'!
viewAllMessages
	currentMessages _ self filteredMessagesIn: self category.
	self messages: currentMessages size from:  currentMessages size.
	self cacheTOC.
	self changed: #tocEntryList.
	self changed: #tocEntry.
	self changed: #messageText! !


!Celeste methodsFor: 'table of contents pane' stamp: 'ls 1/27/2001 17:04'!
autoFile
	"automatically pick a folder for the current message, and file the current message there"
	| folder |
	folder := self chooseFilterForCurrentMessage.
	folder ifNil: [ ^self].
	mailDB file: currentMsgID inCategory: folder.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 1/27/2001 17:04'!
autoMove
	"automatically pick a folder for the current message, and move the message there"
	| folder |
	folder := self chooseFilterForCurrentMessage.
	folder ifNil: [ ^self].
	mailDB file: currentMsgID inCategory: folder.
	self removeMessage.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:01'!
deleteAll
	"Move all visible messages in the current category to '.trash.'."

	| |

	self requiredCategory: '.trash.'.

	mailDB fileAll: currentMessages inCategory: '.trash.'.

	self removeAll.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'sbw 2/1/2001 10:25'!
deleteMessage
	"Move the current message to the '.trash.' category and select the next  
	message. Deleted messages can later purged by the 'empty trash' menu  
	item"
	currentMsgID isNil
		ifTrue: [^ self].
	self requiredCategory: '.trash.'.
	mailDB file: currentMsgID inCategory: '.trash.'.
	self removeMessage! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:11'!
fileAgain
	"File the current message in the same category as last time."

	| newCatName |
	(lastCategory isEmpty not)
		ifTrue: [newCatName _ lastCategory]
		ifFalse: [newCatName _ self getCategoryNameIfNone: [^self]].
	mailDB file: currentMsgID inCategory: newCatName.
! !

!Celeste methodsFor: 'table of contents pane'!
fileAll
	"File all visible messages in the current category in some other category as well."

	| newCatName msgList |
	newCatName _ self getCategoryNameIfNone: [^self].
	msgList _ self filteredMessagesIn: currentCategory.
	mailDB fileAll: msgList inCategory: newCatName.
	self updateTOC.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:07'!
fileMessage
	"File the current message in another category."

	| newCatName |
	newCatName _ self getCategoryNameIfNone: [^self].
	mailDB file: currentMsgID inCategory: newCatName.
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'jm
 8/20/1998 08:14'!
getCategoryNameIfNone: aBlock
	"Prompt the user for a category name, remembering it for the next time."

	| catList categoryName |
	catList _ self categoryList.
	catList remove: '.all.' ifAbsent: [].
	catList remove: '.trash.' ifAbsent: [].
	catList remove: '.unclassified.' ifAbsent: [].
	catList add: '<new category>'.
	((lastCategoryList ~= catList) or: [lastCategoryMenu = nil])
		ifTrue: [lastCategoryMenu _ CustomMenu selections: catList].
	categoryName _ lastCategoryMenu startUp.
	categoryName = nil ifTrue: [^aBlock value].
	categoryName = '<new category>' ifTrue: [
		categoryName _ FillInTheBlank
			request: 'New category name?'
			initialAnswer: ''.
		(categoryName isEmpty) ifTrue: [^aBlock value].
		lastCategoryMenu _ nil.
		mailDB addCategory: categoryName.
		self changed: #categoryList.
	].
	lastCategoryList _ catList.
	^lastCategory _ categoryName! !

!Celeste methodsFor: 'table of contents pane' stamp: 'mdr 8/31/2000 11:47'!
moveAgain
	"Move the current message to the same category as last time."

	| newCatName |

	currentMsgID ifNil: [ ^self ].
	(lastCategory isEmpty not)
		ifTrue: [newCatName _ lastCategory]
		ifFalse: [newCatName _ self getCategoryNameIfNone: [^self]].
	newCatName = currentCategory ifTrue: [ ^self ].

	mailDB file: currentMsgID inCategory: newCatName.
	self removeMessage.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:09'!
moveAll
	"Move all visible messages in the current category to another category."

	| newCatName |
	newCatName _ self getCategoryNameIfNone: [^self].
	newCatName = currentCategory ifTrue:[ ^self ].
	mailDB fileAll: currentMessages inCategory: newCatName.

	self removeAll.! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:08'!
moveMessage
	"Move the current message to another category; this consists of filing it in the new category, and then removing it from the current category"

	| newCatName |
	newCatName _ self getCategoryNameIfNone: [^self].
	newCatName = currentCategory ifTrue: [ ^self ].
	mailDB file: currentMsgID inCategory: newCatName.

	self removeMessage.
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'mdr 7/12/1999 15:16'!
nextMessage
	"Select the next message."

	| index |
	(currentCategory isNil | currentMsgID isNil) ifTrue: [^ self].
	index _ currentMessages indexOf: currentMsgID.
	index < currentMessages size
		ifTrue: [self setTOCEntry: (currentTOC at: index + 1)]
		ifFalse: [self setTOCEntry: (currentTOC at: 1)].
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'jm
 8/20/1998 08:14'!
otherCategories
	"Prompt the user with a menu of all other categories in which the currently selected message appears. If the user chooses a category from this menu, go to that category."

	| otherCategories choice |
	otherCategories _
		(mailDB categoriesThatInclude: currentMsgID) asOrderedCollection.
	otherCategories remove: currentCategory ifAbsent: [].
	(otherCategories isEmpty) ifTrue: [^self].
	choice _ (CustomMenu selections: otherCategories) startUp.
	choice = nil ifFalse: [self setCategory: choice].! !

!Celeste methodsFor: 'table of contents pane' stamp: 'dvf 4/27/2000 18:58'!
partsMenu
	| menu currMessage part |
	menu _ CustomMenu new.
	currMessage _ self currentMessage.
	currMessage body atomicParts do: [:e | menu add: 'save ' , e printString action: e].
	part _ menu startUp.
	part ifNotNil: [part save]! !

!Celeste methodsFor: 'table of contents pane' stamp: 'mdr 7/12/1999 15:16'!
previousMessage
	"Select the previous message."

	| index |
	(currentCategory isNil | currentMsgID isNil) ifTrue: [^ self].
	index _ currentMessages indexOf: currentMsgID.
	index > 1
		ifTrue: [self setTOCEntry: (currentTOC  at: index - 1)]
		ifFalse: [self setTOCEntry: (currentTOC  at: currentMessages size)].

! !

!Celeste methodsFor: 'table of contents pane' stamp: 'di 2/3/2001 12:30'!
removeAll
	"Remove all messages from the current category."
	mailDB removeAll: currentMessages fromCategory: currentCategory.
	currentMsgID _ nil.
	currentMessages _ #().
	currentTOC _ #().
	self initializeTocLists.
	self changed: #tocEntryList.
	self changed: #tocEntry.
	self changed: #messageText
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'sbw 2/1/2001 10:44'!
removeMessage
	"Remove the current message from the current category."
	| currentMessageIndex |
	currentMsgID
		ifNil: [^ self].
	mailDB remove: currentMsgID fromCategory: currentCategory.
	"remove the message from the listing"
	currentMessageIndex _ currentMessages indexOf: currentMsgID.
	currentMessages _ currentMessages copyWithout: currentMsgID.
	currentTOC _ currentTOC copyWithoutIndex: currentMessageIndex.
	1
		to: self tocLists size
		do: [:index | (tocLists at: index) removeAt: currentMessageIndex].
	"update the message index and message ID"
	currentMessages isEmpty
		ifTrue: [currentMsgID _ nil]
		ifFalse: [currentMsgID _ currentMessages
						at: (currentMessageIndex min: currentMessages size)].
	self changed: #tocEntryList.
	self changed: #tocEntry.
	self changed: #messageText! !

!Celeste methodsFor: 'table of contents pane' stamp: 'dvf 4/27/2000 00:14'!
saveMessage
	"save the currently selected message to a file"
	| fileName file |
	currentMsgID ifNil: [^ self].
	fileName _ FillInTheBlank request: 'file to save in'.
	fileName isEmpty ifTrue: [^ self].
	file _ FileStream fileNamed: fileName.
	file nextPutAll: (self currentMessage) text.
	file close! !

!Celeste methodsFor: 'table of contents pane' stamp: 'mdr 11/22/1999 13:14'!
search
	"Search the text of all messages in the present category"

	| destCat matchString msgText |

	destCat _ FillInTheBlank
		request: 'In what category should the search results be filed?'
		initialAnswer: '.search results.'.
	(destCat isEmpty) ifTrue: [^self].
	matchString _ FillInTheBlank
		request: 'String sought in message text?'
		initialAnswer: ''.
	(matchString isEmpty) ifTrue: [^self].

	self requiredCategory: destCat.

	(self filteredMessagesIn: currentCategory) do:
		[: msgID |
		 msgText _ mailDB getText: msgID.
		 ((msgText findString: matchString startingAt: 1) > 0) ifTrue:
			[mailDB file: msgID inCategory: destCat]].

	self setCategory: destCat.

! !

!Celeste methodsFor: 'table of contents pane' stamp: 'bf 3/10/2000 11:29'!
selectMessage: id
	"Change the currently selected message."

	currentMsgID _ id.
	self changed: #tocEntry.
	self changed: #messageText
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'sbw 2/2/2001 13:03'!
setTOCEntry: newTOCentry 
	"Change the currently selected message. This is done by finding the  
	message ID corresponding to the selected table of contents entry."
	| i |
	newTOCentry isNil | currentTOC isNil
		ifTrue: [currentMsgID _ nil]
		ifFalse: [i _ (self tocLists at: 1)
						indexOf: newTOCentry
						ifAbsent: [].
			i isNil
				ifTrue: [currentMsgID _ nil]
				ifFalse: [currentMsgID _ currentMessages at: i]].
	self changed: #tocEntry.
	Cursor read
		showWhile: [self changed: #messageText]! !

!Celeste methodsFor: 'table of contents pane' stamp: 'sbw 1/28/2001 23:18'!
tocEntry
	"Answer the table of contents entry for the currently selected message  
	or nil."
	currentMsgID isNil
		ifTrue: [^ nil]
		ifFalse: [^ (self tocLists at: 1)
				at: (currentMessages indexOf: currentMsgID)]! !

!Celeste methodsFor: 'table of contents pane' stamp: 'sbw 1/28/2001 23:18'!
tocEntryList
	currentCategory isNil
		ifTrue: [self initializeTocLists].
	self tocLists == nil
		ifTrue: [self initializeTocLists].
	^ self tocLists! !

!Celeste methodsFor: 'table of contents pane' stamp: 'dvf 7/1/2000 15:24'!
tocKeystroke: aCharacter 
	aCharacter = Character backspace
		ifTrue: [self deleteMessage].
	aCharacter asciiValue = 30
		ifTrue: [self previousMessage].
	aCharacter asciiValue = 31
		ifTrue: [self nextMessage].
	aCharacter = $c
		ifTrue: [self customFilterOn].
	aCharacter = $m
		ifTrue: [self customFilterMove].
	aCharacter = $s
		ifTrue: [self subjectFilterOn]
! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 1/27/2001 18:18'!
tocMenu: aMenu 
	"Answer the menu for the table of contents pane."
	| messageSelected autoFolder |
	currentCategory ifNil: [^ nil].
	messageSelected _ currentMsgID isNil not.
	messageSelected
		ifTrue: 
			[aMenu add: 'delete' action: #deleteMessage.
			aMenu balloonTextForLastItem: 'Move this message to the .trash. category'.
			aMenu addLine.
			aMenu add: 'compose' action: #compose.
			aMenu balloonTextForLastItem: 'Compose a new message'.
			aMenu add: 'reply' action: #reply.
			aMenu balloonTextForLastItem: 'Reply to this message'.
			aMenu add: 'forward' action: #forward.
			aMenu balloonTextForLastItem: 'Forward this message'.
			self currentMessage body isMultipart
				ifTrue: 
					[aMenu add: 'parts...' action: #partsMenu.
					aMenu balloonTextForLastItem: 'Forward this message'].
			aMenu addLine.
			lastCategory isEmpty
				ifFalse: 
					[aMenu add: 'file -> ' , lastCategory action: #fileAgain.
					aMenu balloonTextForLastItem: 'Add this message also to the category ' , lastCategory.
					aMenu add: 'move -> ' , lastCategory action: #moveAgain.
					aMenu balloonTextForLastItem: 'Move this message to the category ' , lastCategory.
					aMenu addLine].
			autoFolder := self chooseFilterForCurrentMessage.
			autoFolder ifNotNil: [
				aMenu add: ('file -> ', autoFolder) action: #autoFile.
				aMenu add: ('move -> ', autoFolder) action: #autoMove.
				aMenu addLine ].

			aMenu add: 'file' action: #fileMessage.
			aMenu balloonTextForLastItem: 'Add this message also to a different category'.
			aMenu add: 'move' action: #moveMessage.
			aMenu balloonTextForLastItem: 'Move this message to a different category'.
			aMenu add: 'remove' action: #removeMessage.
			aMenu balloonTextForLastItem: 'Remove this message from this category
(NB: the message will be safely available in another category)'.
			aMenu addLine]
		ifFalse: 
			[aMenu add: 'compose' action: #compose.
			aMenu balloonTextForLastItem: 'Compose a new message'.
			aMenu addLine].

	"The following are common for all menus"
	aMenu add: 'file all' action: #fileAll.
	aMenu balloonTextForLastItem: 'Add all messages also to another category'.
	aMenu add: 'move all' action: #moveAll.
	aMenu balloonTextForLastItem: 'Move all messages to another category'.
	aMenu add: 'remove all' action: #removeAll.
	aMenu balloonTextForLastItem: 'Remove all messages from this catgegory
(NB: each message will be safely available in other categories)'.
	aMenu add: 'delete all' action: #deleteAll.
	aMenu balloonTextForLastItem: 'Move all messages to the .trash. category'.
	aMenu addLine.
	messageSelected
		ifTrue: 
			[aMenu add: 'other categories' action: #otherCategories.
			aMenu balloonTextForLastItem: 'Check which other categories also contain this message'.
			aMenu add: 'save message' action: #saveMessage.
			aMenu balloonTextForLastItem: 'Save this message'.
			aMenu addLine].
	self tocEntryList size = self maxMessagesToDisplay ifTrue: [
		"the test above is not exactly correct, but is usually correct."
		aMenu add: 'view all messages' action: #viewAllMessages.
		aMenu balloonTextForLastItem: 'View all messages that match the current filters,	even if there are many thousands of such messages'. ].

	aMenu add: 'search' action: #search.
	aMenu balloonTextForLastItem: 'Search all messages in this category for something'.
	^ aMenu! !

!Celeste methodsFor: 'table of contents pane' stamp: 'ls 6/20/2000 11:33'!
updateTOC
	"Update the table of contents after a moving, removing, or deleting a message. Select a message near the removed message in the table of contents if possible."

	| savedMsgID |
	"remember the currently selected message"
	savedMsgID _ currentMsgID.

	"update the TOC listing"
	currentMsgID _ nil.
	self setCategory: currentCategory.  "update currentMessages, currentTOC"

	"try to select the previously selected message; if impossible, select the first message"
	currentMessages isEmptyOrNil ifFalse: [
		(currentMessages includes: savedMsgID) 
			ifTrue: [ currentMsgID _ savedMsgID ]
			ifFalse: [ currentMsgID _ currentMessages first ] ].

	"NB: self changed: #tocEntryList  is already done above by setCategory: and can be slow"
	self changed: #tocEntry.
	self changed: #messageText.
! !


!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:19'!
chooseFilterFor: msgID from: filterNames
	| res |
	res _ self filtersFor: msgID from: filterNames.
	res isEmpty ifTrue:[^nil].
	res size = 1 ifTrue: [^res anyOne].
	^self selectFilterFrom: res ! !

!Celeste methodsFor: 'filtering' stamp: 'ls 1/27/2001 17:00'!
chooseFilterForCurrentMessage
	"automatically choose a filter to move the selected message.  Returns nil if there isn't a message selected, or if there isn't exactly 1 matching filter"
	| matchingFilters |
	currentMsgID ifNil: [ ^nil ].
	matchingFilters := self filtersFor: currentMsgID from: CustomFilters keys.
	matchingFilters size = 1
		ifTrue: [ ^matchingFilters someElement ]
		ifFalse: [ ^nil ]! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:28'!
customFilterMove
	"Select or define and activate a custom filter."
	| filterList filterName msgList |
	filterList _ CustomFilters keys select: [:e | self categoryList includes: e].

	filterName _ currentMsgID ifNil: [self selectFilterFrom: filterList] ifNotNil: [self chooseFilterFor: currentMsgID from: filterList].
	((filterName isNil or: [filterName isEmpty]) or: [filterName = 'none']) ifTrue: [^ self].
	customFilterBlock _ self customFilterNamed: filterName.
	msgList _ self filteredMessagesIn: currentCategory.
	mailDB removeAll: msgList fromCategory: currentCategory.
	mailDB fileAll: msgList inCategory: filterName.
	customFilterBlock _ nil.
	self updateTOC! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:06'!
customFilterNamed: filterName
 ^self makeFilterFor: (CustomFilters at: filterName)
! !

!Celeste methodsFor: 'filtering' stamp: 'ls 10/17/1998 16:20'!
customFilterOff
	"Cancel custom filtering."

	customFilterBlock ifNil: [
		"it's already turned off"
		^self ].

	customFilterBlock _ nil.
	self updateTOC.
	self changed: #isCustomFilterOn.! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 1/28/2001 19:16'!
customFilterOn
	"Select or define and activate a custom filter."

	| filterName filterExpr filterMenu |
	filterMenu := CustomMenu new.

	currentMsgID ifNotNil: [
		(self filtersFor: currentMsgID from: (CustomFilters keys asSortedArray)) do: [ :name |
			filterMenu add: name action: name ].
		filterMenu addLine.].

	filterMenu add: '(none)' action: #none.
	filterMenu add: '<define new filter...>' action: #define.
	filterMenu add: '<edit exising filter...>' action: #edit.
	filterMenu add: '<delete a filter...>' action: #delete.
	filterMenu addLine.

	(CustomFilters keys asSortedArray) do: [ :name |
		filterMenu add: name action: name ].

	filterName _ filterMenu startUpWithCaption: 'Select a filter:'.

	filterName ifNil: [ ^self ].
	filterName = #none ifTrue: [^self customFilterOff ].
	filterName = #delete ifTrue: [ ^self deleteFilter].
	filterName = #edit
		ifTrue: [filterExpr _ self editFilter]
		ifFalse: [
			filterName = #define
				ifTrue: [filterExpr _ self defineFilter]
				ifFalse: [filterExpr _ CustomFilters at: filterName]].
	filterExpr isEmpty ifTrue: [^self].

	customFilterBlock _ Compiler evaluate: '[ :m | ', filterExpr, ']'.

	self updateTOC.
	self changed: #isCustomFilterOn.! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/4/2000 00:48'!
defineFilter
	| filterName |
	filterName _ FillInTheBlank request: 'Filter name?'.
	filterName isEmpty ifTrue: [^ ''].
	^self editFilterNamed: filterName ! !

!Celeste methodsFor: 'filtering' stamp: 'jm
 8/20/1998 08:14'!
deleteFilter

	| filterList filterName |
	CustomFilters isEmpty ifTrue: [^''].
	filterList _ CustomFilters keys asOrderedCollection.
	filterName _ (CustomMenu selections: filterList)
		startUpWithCaption: 'Filter to delete?'.
	filterName = nil ifTrue: [^''].
	CustomFilters removeKey: filterName ifAbsent: [].! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/4/2000 00:49'!
editCategoryFilter
	self editFilterNamed: currentCategory! !

!Celeste methodsFor: 'filtering' stamp: 'jm
 8/20/1998 08:14'!
editFilter

	| filterList filterName |
	CustomFilters isEmpty ifTrue: [^''].
	filterList _ CustomFilters keys asOrderedCollection.
	filterName _ (CustomMenu selections: filterList)
		startUpWithCaption: 'Filter to edit?'.
	filterName = nil ifTrue: [^''].
	^self editFilterNamed: filterName filterExpr: (CustomFilters at: filterName)! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/4/2000 00:47'!
editFilterNamed: filterName
	| expr |
	(CustomFilters includesKey: filterName)
		ifTrue: [expr _ CustomFilters at: filterName]
		ifFalse: [expr _ ''].
	^ self editFilterNamed: filterName filterExpr: expr! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:22'!
editFilterNamed: filterName filterExpr: oldExpr

	| newDefinition |
	newDefinition _ FillInTheBlank
		request:
'Enter a filter definition where "m" is the message being testing. The expression can send
"fromHas:", "toHas:", "ccHas:", "subjectHas:", "participantHas:", or "textHas:" to m to test for
inclusion of a string--or one of an array of strings--in a field. It can also test m''s time
and/or date and can combine several tests with logical operators. Examples:
 
     m fromHas: ''johnm''                       -- messages from johnm
     m participantHas: ''johnm''                -- messages from, to, or cc-ing johnm
     m textHas: #(squeak smalltalk java)      -- messages with any of these words
     m subjectHas: #(0 1 2 3 4 5 6 7 8 9)       -- numbers in lists treated as strings
 
NOTE: "textHas:" is very slow, since it must read the message from disk.'
		initialAnswer: oldExpr.
	newDefinition isEmpty ifTrue: [^''].
	CustomFilters at: filterName put: newDefinition.
	^filterName! !

!Celeste methodsFor: 'filtering' stamp: 'ls 1/27/2001 18:33'!
filteredMessagesIn: categoryName

	| msgList |
	msgList _ mailDB messagesIn: categoryName.

	(customFilterBlock notNil) ifTrue:
		[msgList _ msgList select:
			[: id | customFilterBlock value: (mailDB getTOCentry: id) ]].
	(fromFilter size > 0) ifTrue:
		[msgList _ msgList select:
			[: id | (mailDB getTOCentry: id) fromHas: fromFilter ]].
	(participantFilter size > 0) ifTrue:
		[msgList _ msgList select:
			[: id | (mailDB getTOCentry: id) participantHas: participantFilter ]].
	(subjectFilter size > 0) ifTrue:
		[msgList _ msgList select:
			[: id | (mailDB getTOCentry: id) subject includesSubstring: subjectFilter caseSensitive: false]].
	^msgList! !

!Celeste methodsFor: 'filtering' stamp: 'ls 1/27/2001 17:24'!
filtersFor: msgID from: filterNames
	| currentTocEntry |
	currentTocEntry := mailDB getTOCentry: msgID.
	^filterNames select: [:e | (self customFilterNamed: e) value: currentTocEntry].! !

!Celeste methodsFor: 'filtering'!
fromFilterOff
	"Cancel from filtering."

	fromFilter _ ''.
	self updateTOC.! !

!Celeste methodsFor: 'filtering' stamp: 'mdr 1/14/2000 14:49'!
fromFilterOn: aSwitch
	"Show only those messages from the same person as the currently selected message. The user is given a chance to edit the pattern string used to match 'From:' fields."

	fromFilter _
		(currentMsgID isNil)
			ifTrue: ['']
			ifFalse: [(mailDB getTOCentry: currentMsgID) from].
	fromFilter _ FillInTheBlank
		request: '''From:'' filter pattern?'
		initialAnswer: fromFilter.
	fromFilter = '' ifTrue: [aSwitch turnOff.  ^self]. "User cancelled, so turn off the switch"
	fromFilter _ fromFilter withoutTrailingBlanks.
	self updateTOC.! !

!Celeste methodsFor: 'filtering' stamp: 'ls 10/15/1998 14:57'!
isCustomFilterOn
	"whether there is a custom filter in effect"
	^customFilterBlock ~~ nil! !

!Celeste methodsFor: 'filtering' stamp: 'ls 1/27/2001 18:25'!
isParticipantFilterOn
	"return whether a non-trivial participant filter is installed"
	^participantFilter notNil and: [ participantFilter isEmpty not ]! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 7/1/2000 15:45'!
isSubjectFilterOn
	"whether there is a subject filter in effect"
	^ subjectFilter isEmptyOrNil not!
]style[(17 2 45 4 13 17)f3b,f3,f3c150048000,f3,f3cblack;,f3! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:06'!
makeFilterFor: filterExpr
 ^Compiler evaluate: '[ :m | ', filterExpr, ']'.
! !

!Celeste methodsFor: 'filtering' stamp: 'ls 1/27/2001 18:33'!
participantFilterOn
	"Show only those messages where a specified user is either the sender or a receiver."

	participantFilter _
		(currentMsgID isNil)
			ifTrue: ['']
			ifFalse: [(mailDB getTOCentry: currentMsgID) from].
	participantFilter _ FillInTheBlank
		request: '''Participant:'' filter pattern?'
		initialAnswer: participantFilter.

	participantFilter _ participantFilter withBlanksTrimmed.
	self updateTOC.
	self changed: #isParticipantFilterOn.! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 6/17/2000 22:24'!
selectFilterFrom: filters
	| filterName filterList |
	filterList _ filters asSortedCollection asOrderedCollection.
	filterList addFirst: '(none)'.
	filterList addLast: '<define new filter...>'.
	filterList addLast: '<edit exising filter...>'.
	filterList addLast: '<delete a filter...>'.
	filterName _ (CustomMenu selections: filterList)
			startUpWithCaption: 'Select a filter:'.
	(filterName isNil or: [filterName isEmpty]) ifTrue: [ ^nil ].
	filterName = '(none)' ifTrue: [^'none'].
	filterName = '<delete a filter...>' ifTrue: [ ^self deleteFilter].
	filterName = '<edit exising filter...>'
		ifTrue: [filterName _ self editFilter]
		ifFalse: [
			filterName = '<define new filter...>'
				ifTrue: [filterName _ self defineFilter]].
	^filterName! !

!Celeste methodsFor: 'filtering'!
subjectFilterOff
	"Cancel subject filter."

	subjectFilter _ ''.
	self updateTOC.! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 7/1/2000 15:42'!
subjectFilterOn
	"Show only those messages whose subject matches the currently selected  
	message. The user is given a chance to edit the pattern string used to match  
	'Subject:' fields."
	subjectFilter _ currentMsgID isNil
				ifTrue: ['']
				ifFalse: [(mailDB getTOCentry: currentMsgID) subject].
	subjectFilter _ subjectFilter normalizedSubject.
	subjectFilter _ FillInTheBlank request: '''Subject:'' filter pattern?' initialAnswer: subjectFilter.
	self updateTOC.
	self changed: #isSubjectFilterOn!
]style[(15 2 173 2 13 3 12 20 2 17 6 14 12 13 13 3 13 21 13 3 14 10 30 16 13 3 4 27 18)f3b,f3,f3c150048000,f3,f3cblack;,f3,f3cblack;,f3,f3cblue;,f3,f3cblack;,f3,f3cblack;,f3,f3cblack;,f3,f3cblack;,f3,f3cblack;,f3,f3cblack;,f3,f3cblue;,f3,f3cblack;,f3,f3cblack;,f3,f3cblue;! !

!Celeste methodsFor: 'filtering' stamp: 'dvf 7/1/2000 14:17'!
subjectFilterOn: aSwitch 
	"Show only those messages whose subject matches the currently selected 
	message. The user is given a chance to edit the pattern string used to match 
	'Subject:' fields."
	subjectFilter _ currentMsgID isNil
				ifTrue: ['']
				ifFalse: [(mailDB getTOCentry: currentMsgID) subject].
	subjectFilter _ subjectFilter normalizedSubject.
	subjectFilter _ FillInTheBlank request: '''Subject:'' filter pattern?' initialAnswer: subjectFilter.
	subjectFilter = ''
		ifTrue: [aSwitch turnOff.
			^ self].
	"User cancelled so turn off the switch and return"
	self updateTOC! !


!Celeste methodsFor: 'message text pane' stamp: 'ls 9/13/1998 02:56'!
compose
	"Make a MailSendTool for composing a new message."

	self openSender: self composeText.! !

!Celeste methodsFor: 'message text pane' stamp: 'ls 9/14/1998 22:23'!
doItContext
	^nil! !

!Celeste methodsFor: 'message text pane' stamp: 'ls 9/14/1998 22:23'!
doItReceiver
	^nil! !

!Celeste methodsFor: 'message text pane' stamp: 'jm
 8/20/1998 11:59'!
format

	messageTextView
		editString: self formatedMessageText;
		hasUnacceptedEdits: true.
! !

!Celeste methodsFor: 'message text pane' stamp: 'dvf 4/27/2000 00:14'!
formatedMessageText
	"Answer a string that is my formatted mail message."
	| message header body bodyText |
	currentMsgID isNil ifTrue: [^ ''].
	message _ self currentMessage.
	header _ message cleanedHeader.
	body _ message body.
	body contentType = 'text/html'
		ifTrue: [bodyText _ (HtmlParser parse: (ReadStream on: body content)) formattedText]
		ifFalse: [bodyText _ body content].
	^ header asText , String cr , bodyText! !

!Celeste methodsFor: 'message text pane' stamp: 'ls 9/13/1998 02:57'!
forward
	"Make a MailSendTool for forwarding the current message."

	(currentMsgID notNil) ifTrue:
		[self openSender: (self forwardTextFor: currentMsgID)].! !

!Celeste methodsFor: 'message text pane'!
message
	"Answer the text of the currently selected message or nil if there isn't one."

	(currentMsgID isNil)
		ifTrue: [^'']
		ifFalse: [^(mailDB getText: currentMsgID) asText]! !

!Celeste methodsFor: 'message text pane' stamp: 'jm
 8/20/1998 08:14'!
messageMenu
	"Answer the menu for the message text pane."

	(currentMsgID notNil)
		ifTrue: [^CustomMenu
			labels: 'again\undo\copy\cut\paste\format\accept\cancel
compose\reply\forward' withCRs
			lines: #(2 5 6 8)
			selections: #(again undo copySelection cut paste format accept cancel
compose reply forward)]
		ifFalse: [^SelectionMenu
			labels: 'again\undo\copy\cut\paste\compose' withCRs
			lines: #(2 5)
			selections: #(again undo copySelection cut paste compose)].! !

!Celeste methodsFor: 'message text pane' stamp: 'jm
 8/20/1998 11:28'!
messageMenu: aMenu shifted: shifted
	"Use the standard text menu."

	^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
! !

!Celeste methodsFor: 'message text pane' stamp: 'ls 4/30/2000 18:33'!
messageText
	"Answer the text which makes up the complete message (header+body)"

	(currentMsgID isNil) ifTrue: [^''].

	"Always show the full message header for messages in the category .tosend. so that all special header lines are preserved, shown and can be edited."
	(currentCategory = '.tosend.')
		ifTrue: [^ mailDB getText: currentMsgID].

	SuppressWorthlessHeaderFields
		ifTrue: [^ self currentMessage formattedText]
		ifFalse: [^ mailDB getText: currentMsgID].
! !

!Celeste methodsFor: 'message text pane' stamp: 'bf 3/9/2000 17:54'!
messageText: aStringOrText

	currentCategory isNil | currentMsgID isNil ifTrue: [^ self].
	mailDB newText: aStringOrText asString squeakToIso for: currentMsgID.
	self updateTOC.  "in case the message header was changed"
	messageTextView hasUnacceptedEdits: false.
	self changed: #messageText.
	^ true
! !

!Celeste methodsFor: 'message text pane' stamp: 'jm 8/14/1998 15:13'!
messageTextView: aView

	messageTextView _ aView.
! !

!Celeste methodsFor: 'message text pane' stamp: 'ls 9/13/1998 03:08'!
reply
	"Make a MailSendTool for replying to the current message."

	(currentMsgID notNil) ifTrue:
		[self openSender: (self replyTextFor: currentMsgID)].! !


!Celeste methodsFor: 'other' stamp: 'sbw 1/30/2001 20:14'!
changeMaxMessageCount
	| countString count |
	countString _ FillInTheBlank request: 'Maximum number of messages displayed?' initialAnswer: self class messageCountLimit printString.
	countString isEmpty
		ifTrue: [^ self].
	count _ Integer
				readFrom: (ReadStream on: countString).
	count _ count max: 10.
	count _ count min: 500.
	"Arbitrary. We could calculate the real upper bound."
	self class messageCountLimit: count.
	self setCategory: currentCategory! !

!Celeste methodsFor: 'other' stamp: 'jm 8/14/1998 15:26'!
clearUserEditFlag

	messageTextView hasUnacceptedEdits: false.
! !

!Celeste methodsFor: 'other' stamp: 'dvf 4/27/2000 00:12'!
currentMessage
	^mailDB getMessage: currentMsgID! !

!Celeste methodsFor: 'other' stamp: 'jm
 8/20/1998 08:14'!
okToChange
	"This message is sent when changing the selection in either the message cateory or message list panes. Eventually, this should ask the user if it is okay to throw away and unaccepted edits of the current message. For now, it always gives permission."

	currentCategory isNil | currentMsgID isNil ifTrue: [
		"no message selected; discard edits in message pane silently"
		messageTextView hasUnacceptedEdits: false.
		^ true].

	messageTextView hasUnacceptedEdits ifFalse: [^ true].
	(CustomMenu confirm: 'Discard changes to currently selected message?')
		ifTrue: [messageTextView hasUnacceptedEdits: false. ^ true]
		ifFalse: [^ false].
! !

!Celeste methodsFor: 'other' stamp: 'di 10/27/1999 08:48'!
perform: selector orSendTo: otherTarget
	"Celeste handles all menu commands."

	selector = #format ifTrue: [^ self perform: selector].

	((#(yellowButtonActivity shiftedYellowButtonActivity) includes: selector) or:
		[(ParagraphEditor yellowButtonMessages includes: selector) or:
		[ParagraphEditor shiftedYellowButtonMenu selections includes: selector]])
			ifTrue: [otherTarget perform: selector]
			ifFalse: [self perform: selector].
! !

!Celeste methodsFor: 'other' stamp: 'mdr 11/22/1999 13:29'!
requiredCategory: catName
	"catName is a required category.  If it does not exist in the database, then create it, and update the category list to reflect that it now exists."

	(self categoryList includes: catName)
		ifFalse:
			[mailDB addCategory: catName.
			self changed: #categoryList.]

! !

!Celeste methodsFor: 'other' stamp: 'dvf 4/26/2000 20:58'!
status
	^ status! !

!Celeste methodsFor: 'other' stamp: 'sge 5/29/2000 20:29'!
status: aStringOrNil
	status _ aStringOrNil.
	self changed: #status! !


!Celeste methodsFor: 'sending mail' stamp: 'RAA 6/1/2000 17:55'!
PROTOqueueMessageWithText: aStringOrText
	"Queue a message to be sent later. The message is added to the database and filed in the '.tosend.' category."

	| messageText id |
	messageText _
		'X-Mailer: ', Celeste versionString, String cr,
		'Date: ', MailMessage dateStampNow, String cr.

	messageText _ messageText,
		aStringOrText asString.
	
	self requiredCategory: '.tosend.'.

	"queue the message"
	id _ mailDB addNewMessage: (MailMessage from: messageText).
	mailDB file: id inCategory: '.tosend.'.

	(self category = '.tosend.') ifTrue: [self updateTOC].
	^id
! !

!Celeste methodsFor: 'sending mail' stamp: 'RAA 6/1/2000 17:55'!
PROTOsendQueuedMail
	"Post queued messages to the SMTP server."

	| outgoing |

	outgoing _ mailDB messagesIn: '.tosend.'.
	outgoing isEmpty ifTrue: [^ self inform: 'no mail to be sent'].
	self sendMail: outgoing.! !

!Celeste methodsFor: 'sending mail' stamp: 'jm 10/4/1998 10:55'!
composeText
	"Answer the template for a new message."

	^ String streamContents: [:str |
		str nextPutAll: 'From: '.
		str nextPutAll: Celeste userName; cr.

		str nextPutAll: 'To: '; cr.
		str nextPutAll: 'Subject: '; cr.

		Celeste ccList isEmpty ifFalse: [
			str nextPutAll: 'Cc: '.
			str nextPutAll: Celeste ccList; cr].
		str cr].
! !

!Celeste methodsFor: 'sending mail' stamp: 'sge 6/9/2000 20:42'!
forwardTextFor: msgID
	"Answer the template for forwarding the message with the given ID."
	| msg separator |
	msg := self currentMessage.

	^String streamContents: [ :str |
		"From header"
		str nextPutAll: 'From: ';
		nextPutAll: Celeste userName; cr.

		"Put a blank To"
		str nextPutAll: 'To: '; cr.

		"Add a subject modified from the original"
		str nextPutAll: 'Subject: (fwd) '.
		str nextPutAll: msg subject.
		str cr.


		"Add auto-cc if it's been set"
		Celeste ccList isEmpty ifFalse: [
			str nextPutAll: 'Cc: '.
			str nextPutAll: Celeste ccList; cr].

		"add the mime headers to make it multi-part"
		separator := MailMessage generateSeparator.
		str nextPutAll: 'MIME-Version: 1.0'; cr.
		str nextPutAll: 'Content-type: multipart/mixed; boundary="'.
		str nextPutAll: separator; nextPut: $".
		str cr.

		"skip down to the main part of the message"
		str cr.
		str nextPutAll: '--'; nextPutAll: separator; cr.
		str nextPutAll: 'Content-type: text/plain'; cr; cr.

		"insert the forwarded message"
		str cr; cr; nextPutAll: '====forwarded===='; cr; cr.
		str nextPutAll: '--'; nextPutAll: separator; cr.
		str nextPutAll: 'Content-type: message/rfc822'; cr; cr.
		str nextPutAll: msg text; cr.

		"final separator"
		str nextPutAll: '--'; nextPutAll: separator; nextPutAll: '--'; cr.
	].! !

!Celeste methodsFor: 'sending mail' stamp: 'ls 10/16/1998 09:09'!
openSender: initialText
	CelesteComposition openForCeleste: self  initialText: initialText.! !

!Celeste methodsFor: 'sending mail' stamp: 'jdr 6/4/2000 15:05'!
popPassword
	"Answer the password to use when retrieving mail via POP3. The password is stored in an instance variable, which disappears when you close the Celeste window."

	userPassword ifNotNil: [^ userPassword].
	userPassword _ FillInTheBlank requestPassword: 'POP password'.
	^ userPassword
! !

!Celeste methodsFor: 'sending mail' stamp: 'mdr 11/22/1999 15:55'!
preSendAuthentication
	"Where required, authenticate ourselves to the SMTP server before sending mail"

	"This is a placeholder for any required authentication"! !

!Celeste methodsFor: 'sending mail' stamp: 'dvf 5/17/2000 20:48'!
queueMessageWithText: aStringOrText 
	"Queue a message to be sent later. The message is added to the database 
	and filed in the '.tosend.' category."
	| messageText id |
	messageText _ 'X-Mailer: ' , Celeste versionString , String cr , 'Date: ' , MailMessage dateStampNow, ' ' , self timeZoneString, ' ', String cr.
	messageText _ messageText , aStringOrText asString.
	self requiredCategory: '.tosend.'.
	"queue the message"
	id _ mailDB addNewMessage: (MailMessage from: messageText).
	mailDB file: id inCategory: '.tosend.'.
	self category = '.tosend.' ifTrue: [self updateTOC]! !

!Celeste methodsFor: 'sending mail' stamp: 'mdr 2/18/1999 09:07'!
replyTextFor: msgID
	"Answer the template for a reply to the message with the given ID."

	| msg s anyCCs replyaddress |
	msg _ mailDB getMessage: msgID.
	s _ WriteStream on: (String new: 500).

	"add From:"
	s nextPutAll: 'From: ', Celeste userName; cr.


	"add Subject:"
	((msg subject asLowercase indexOfSubCollection: 're:' startingAt: 1) ~= 0)
		ifTrue: [s nextPutAll: 'Subject: ', msg subject]
		ifFalse: [s nextPutAll: 'Subject: Re: ', msg subject].
	s cr.


	"add To:"
	"Use the Reply-To: address if there is one, otherwise the From: address"
	replyaddress _ msg from.
	msg headerFieldsNamed: 'reply-to' do: [ :destAdd | replyaddress _ destAdd ].
	s nextPutAll: 'To: ', replyaddress; cr.
	

	"add CC:s from the message and from the user's CC list"
	s nextPutAll: 'CC: '.
	anyCCs _ false.
	(msg to isEmpty) ifFalse: [
		anyCCs ifTrue:[ s nextPutAll: ', '] ifFalse: [ anyCCs _ true ].
		s nextPutAll: msg to ].
	(msg cc isEmpty) ifFalse: [
		anyCCs ifTrue: [ s nextPutAll: ', ' ] ifFalse: [ anyCCs _ true ].
		s nextPutAll: msg cc ].
	(Celeste ccList isEmpty) ifFalse: [
		anyCCs ifTrue: [ s nextPutAll: ', ' ] ifFalse: [ anyCCs _ true ].	
		s nextPutAll: Celeste ccList ].
	s cr.


	"add contents of previous message"
	s cr.
	s nextPutAll: msg from; nextPutAll: ' wrote:'; cr.
	msg bodyText linesDo: [ :line |
		s nextPutAll: '> '.
		s nextPutAll: line.
		s cr ].
	s cr.

	^s contents! !

!Celeste methodsFor: 'sending mail' stamp: 'RAA 5/19/2000 12:27'!
sendMail: aCollectionOfMessages
	"Send <aCollectionOfMessages> to the SMTP server."

	| sender n message recipients socket |

	self requiredCategory: '.sent.'.

	self preSendAuthentication.

	sender _ (MailAddressParser addressesIn: self class userName) first.

	[socket _ SMTPSocket usingServer: Celeste smtpServer]
		ifError: [ :a :b | self error: 'error opening connection to mail server'].

	('sending ', aCollectionOfMessages size printString, ' messages...')
		displayProgressAt: Sensor mousePoint
		from: 1
		to: aCollectionOfMessages size
		during: [:progressBar |
			n _ 0.
			aCollectionOfMessages do: [:id |
				progressBar value: (n _ n + 1).
				message _ mailDB getMessage: id.

				recipients _ Set new.
				recipients addAll: (MailAddressParser addressesIn: message to).
				recipients addAll: (MailAddressParser addressesIn: message cc).

				[socket 
					mailFrom: sender
					to: recipients 
					text: message text.	"send this one message on the stream"

				mailDB remove: id fromCategory: '.tosend.'.
				mailDB file: id inCategory: '.sent.'
				] ifError: [ :a :b | self error: 'error posting mail']
		]].

	socket quit; close.
	mailDB saveDB.

	(self category = '.tosend.') |  (self category = '.sent.') ifTrue: [self updateTOC].

! !

!Celeste methodsFor: 'sending mail' stamp: 'mdr 11/22/1999 14:32'!
sendQueuedMail
	"Post queued messages to the SMTP server."

	| outgoing sender n message recipients socket |
	outgoing _ mailDB messagesIn: '.tosend.'.
	outgoing isEmpty ifTrue: [^ self inform: 'no mail to be sent'].

	self requiredCategory: '.sent.'.

	self preSendAuthentication.

	sender _ (MailAddressParser addressesIn: self class userName) first.

	[socket _ SMTPSocket usingServer: Celeste smtpServer]
		ifError: [ :a :b | self error: 'error opening connection to mail server'].

	('sending ', outgoing size printString, ' messages...')
		displayProgressAt: Sensor mousePoint
		from: 1
		to: outgoing size
		during: [:progressBar |
			n _ 0.
			outgoing do: [:id |
				progressBar value: (n _ n + 1).
				message _ mailDB getMessage: id.

				recipients _ Set new.
				recipients addAll: (MailAddressParser addressesIn: message to).
				recipients addAll: (MailAddressParser addressesIn: message cc).

				[socket 
					mailFrom: sender
					to: recipients 
					text: message text.	"send this one message on the stream"

				mailDB remove: id fromCategory: '.tosend.'.
				mailDB file: id inCategory: '.sent.'
				] ifError: [ :a :b | self error: 'error posting mail']
		]].

	socket quit; close.
	mailDB saveDB.

	(self category = '.tosend.') |  (self category = '.sent.') ifTrue: [self updateTOC].

! !

!Celeste methodsFor: 'sending mail' stamp: 'dvf 5/17/2000 20:48'!
timeZoneString
	^Celeste userTimeZone! !


!Celeste methodsFor: 'initialize variables' stamp: 'sbw 1/28/2001 23:10'!
initializeTocLists
	tocLists _ Array new: 6.
	1
		to: tocLists size
		do: [:index | tocLists at: index put: OrderedCollection new]! !


!Celeste methodsFor: 'accessing' stamp: 'sbw 1/28/2001 22:36'!
tocLists
	"Generated - Return the value of tocLists."

	tocLists == nil ifTrue: [self initializeTocLists].
	^tocLists! !

!Celeste methodsFor: 'accessing' stamp: 'sbw 1/28/2001 22:36'!
tocLists: anObject
	"Generated - Set the value of tocLists to <anObject>."

	tocLists _ anObject! !

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

Celeste class
	instanceVariableNames: ''!

!Celeste class methodsFor: 'class initialization' stamp: 'jm 10/4/1998 13:55'!
initialize
	"Celeste initialize"

	"user preferences"
	CCList _ nil.
	DeleteInboxAfterFetching _ false.
	PopServer _ nil.
	PopUserName _ nil.
	SmtpServer _ nil.
	SuppressWorthlessHeaderFields _ true.
	UserName _ nil.

	"options with no UI; just set their values directly"
	FormatWhenFetching _ false.

	"dictionary of custom filters"
	CustomFilters _ Dictionary new.
! !

!Celeste class methodsFor: 'class initialization' stamp: 'sbw 1/30/2001 20:10'!
initializeMessageCountLimit
	"An arbitrary bound."
	self messageCountLimit: 200! !

!Celeste class methodsFor: 'class initialization' stamp: 'ls 6/19/2000 12:20'!
versionString
	"Answer a short string describing this version of Celeste."

	| highestChangeSet versionAddendum |

	"the changeset number should probably be removed whenever Celeste settles down"
	highestChangeSet _ ChangeSorter highestNumberedChangeSet.
	versionAddendum _ highestChangeSet
		ifNil: ['.x']
		ifNotNil: ['.' , highestChangeSet name initialIntegerOrNil printString].
	^ 'Celeste 2.0' , versionAddendum! !


!Celeste class methodsFor: 'instance creation' stamp: 'dvf 11/18/2000 17:08'!
current
	"Answer the currently active Celeste (assuming that there's
	only one Celeste open at a given time) or open a new one."

	^Celeste allInstances detect: [:e | e isActive] ifNone: [self open].
! !

!Celeste class methodsFor: 'instance creation' stamp: 'sma 6/12/2000 12:09'!
open
	"Open a MailReader on the default mail database."

	^ self openOn: 'EMAIL'! !

!Celeste class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 03:05'!
openOn: rootFilename
	"Open a MailReader on the mail database with the given root filename."
	|database |

	database _  MailDB openOn: rootFilename.
	database ifNotNil: [ ^ self openOnDatabase: database ].! !


!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:46'!
ccList
	"Answer the default cc list to be used in composing messages."

	CCList isNil ifTrue: [CCList _ ''].
	^CCList! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:51'!
popServer
	"Answer the server for downloading email via POP"

	(PopServer isNil or: [PopServer isEmpty])
		ifTrue: [self setPopServer].

	PopServer isEmpty ifTrue: [
		self error: 'POP server not specified' ].

	^PopServer! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:51'!
popUserName
	"Answer the user's username on the POP server"

	(PopUserName isNil or: [PopUserName isEmpty])
		ifTrue: [self setPopUserName].

	PopUserName isEmpty ifTrue: [ 
		self error: 'no POP user name specified' ].

	^PopUserName! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:46'!
setCCList
	"Change the list of names used in the default cc list. Items in the list should be valid mail addresses and should be separated by commas."

	| newList |
	(CCList isNil) ifTrue: [CCList _ ''].
	newList _ FillInTheBlank
		request: 'addresses to automatically add to CC: fields?'
		initialAnswer: CCList.
	CCList _ newList.! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:48'!
setPopServer
	"Change the user's email name for use in composing messages."

	(PopServer isNil) ifTrue: [PopServer _ ''].
	PopServer _ FillInTheBlank
		request: 'What is your POP server''s hostname?'
		initialAnswer: PopServer.
! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:48'!
setPopUserName
	"set the POP server used for downloading email"

	(PopUserName isNil) ifTrue: [PopUserName _ ''].
	PopUserName _ FillInTheBlank
		request: 'What is your username on your POP server?'
		initialAnswer: PopUserName.

	"be kind, if they include the host name here"
	(PopUserName includes: $@) ifTrue: [
		PopUserName _ PopUserName copyFrom: 1 to: (PopUserName indexOf: $@)-1 ].! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:48'!
setSmtpServer
	"Set the SMTP server used to send outgoing messages via"

	(SmtpServer isNil) ifTrue: [
		PopServer isNil
			ifTrue: [ SmtpServer _ '' ]
			ifFalse: [ SmtpServer _ PopServer ] ].

	SmtpServer _ FillInTheBlank
		request: 'What is your mail server for outgoing mail?'
		initialAnswer: SmtpServer.
! !

!Celeste class methodsFor: 'user preferences' stamp: 'dvf 5/18/2000 00:08'!
setTimeZone
	TimeZone _ FillInTheBlank request: 'What is your time zone ?' initialAnswer: '+0300'! !

!Celeste class methodsFor: 'user preferences' stamp: 'bf 3/9/2000 18:11'!
setUserName
	"Change the user's email name for use in composing messages."

	(UserName isNil) ifTrue: [UserName _ ''].
	UserName _ FillInTheBlank
		request: 'What is your email address?\(This is the address other people will reply to you)' withCRs
		initialAnswer: UserName isoToSqueak.
	UserName ifNotNil: [UserName _ UserName squeakToIso]! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:50'!
smtpServer
	"Answer the server for sending email"

	(SmtpServer isNil or: [SmtpServer isEmpty])
		ifTrue: [self setSmtpServer].
	SmtpServer isEmpty ifTrue: [
		self error: 'no SMTP server specified' ].

	^SmtpServer! !

!Celeste class methodsFor: 'user preferences' stamp: 'ls 9/17/1998 05:50'!
userName
	"Answer the user name to be used in composing messages."

	(UserName isNil or: [UserName isEmpty])
		ifTrue: [self setUserName].

	UserName isEmpty ifTrue: [ self error: 'no user name specified' ].

	^UserName! !

!Celeste class methodsFor: 'user preferences' stamp: 'sma 5/20/2000 10:18'!
userTimeZone
	"Answer the user's timezone string to be used when sending messages."

	TimeZone isEmptyOrNil ifTrue: [self setTimeZone].
	^ TimeZone ifNil: ['']! !


!Celeste class methodsFor: 'sending' stamp: 'di 4/13/1999 14:44'!
addMVCMailSenderButtons: topView textView: mailTextView
	"Add some handy buttons to the mail sender window."

	| sendButton sendAndKeepButton doneButton |
	sendButton _
		PluggableButtonView new
			model: (Button new onAction:
					[mailTextView controller accept.
					 mailTextView controller controlTerminate.
					 Celeste postMessage: mailTextView model contents]);
			action: #turnOn;
			label: 'Send';
			window: (0@0 extent: 34@10);
			borderWidth: 1.
	sendAndKeepButton _
		PluggableButtonView new
			model: (Button new onAction:
					[mailTextView controller accept.
					 mailTextView controller controlTerminate.
					 Celeste postMessage: mailTextView model contents.
					 Celeste addMessageToInbox: mailTextView model contents]);
			action: #turnOn;
			label: 'Send&Keep';
			window: (0@0 extent: 33@10);
			borderWidth: 1.
	doneButton _
		PluggableButtonView new
			model: (Button new onAction: [topView controller close]);
			action: #turnOn;
			label: 'Done';
			window: (0@0 extent: 33@10);
			borderWidth: 1.
	topView
		addSubView: sendButton above: topView firstSubView;
		addSubView: sendAndKeepButton toRightOf: sendButton;
		addSubView: doneButton toRightOf: sendAndKeepButton.
! !

!Celeste class methodsFor: 'sending' stamp: 'sbw 1/30/2001 19:37'!
addMVCViews: views andButtons: buttons to: topWindow 
	(views at: 1)
		window: (0 @ 0 extent: 20 @ 25).
	(views at: 2)
		window: (0 @ 0 extent: 80 @ 25).
	(views at: 3)
		window: (0 @ 0 extent: 100 @ 70).
	(buttons at: 1)
		window: (0 @ 0 extent: 12 @ 5).
	(buttons at: 2)
		window: (0 @ 0 extent: 12 @ 5).
	(buttons at: 3)
		window: (0 @ 0 extent: 12 @ 5).
	(buttons at: 4)
		window: (0 @ 0 extent: 10 @ 5).
	(buttons at: 5)
		window: (0 @ 0 extent: 13 @ 5).
	(buttons at: 6)
		window: (0 @ 0 extent: 13 @ 5).
	(buttons at: 7)
		window: (0 @ 0 extent: 15 @ 5).
	(buttons at: 8)
		window: (0 @ 0 extent: 13 @ 5).
	topWindow
		addSubView: (buttons at: 1);
		
		addSubView: (buttons at: 2)
		toRightOf: (buttons at: 1);
		
		addSubView: (buttons at: 3)
		toRightOf: (buttons at: 2);
		
		addSubView: (buttons at: 4)
		toRightOf: (buttons at: 3);
		
		addSubView: (buttons at: 5)
		toRightOf: (buttons at: 4);
		
		addSubView: (buttons at: 6)
		toRightOf: (buttons at: 5);
		
		addSubView: (buttons at: 7)
		toRightOf: (buttons at: 6);
		
		addSubView: (buttons at: 8)
		toRightOf: (buttons at: 7);
		
		addSubView: (views at: 1)
		below: (buttons at: 1);
		
		addSubView: (views at: 2)
		toRightOf: (views at: 1);
		
		addSubView: (views at: 3)
		below: (views at: 1)! !

!Celeste class methodsFor: 'sending' stamp: 'jm 10/2/1998 16:24'!
addMessageToInbox: msgString
	"Append a copy of the given message to the inbox file."

	self inform:
'The "keep" feature is not yet implemented;
please cc: yourself to retain a copy of your message.'! !

!Celeste class methodsFor: 'sending'!
eudoraSeparator
	"Return a Eudora-style message separator string."

	| s today dateString |
	s _ WriteStream on: (String new: 50).
	today _ Date today.
	dateString _ today printFormat: #(2 1 3 32 2 1).
	dateString _ dateString copyFrom: 1 to: dateString size - 4.
	s nextPutAll: 'From ???@??? '.
	s nextPutAll: (today weekday copyFrom: 1 to: 3); space.
	s nextPutAll: dateString.
	Time now print24: true on: s.
	s space.
	s print: today year; cr.
	^s contents
! !


!Celeste class methodsFor: 'options' stamp: 'sbw 1/28/2001 22:32'!
includeStatusPane

	^Preferences celesteHasStatusPane! !


!Celeste class methodsFor: 'enhancements documentation' stamp: 'sbw 2/2/2001 12:48'!
postLoadOperationsForEnhancements
	"Celeste postLoadOperationsForEnhancements."
	Preferences addPreferenceForOptionalCelesteStatusPane.
	true ifFalse: [Celeste postReadMeEnhancements]! !

!Celeste class methodsFor: 'enhancements documentation' stamp: 'sbw 1/28/2001 22:28'!
postReadMeEnhancements
	"Celeste postReadMeEnhancements."
	Workspace new textContents: self readMeEnhancementsString; openLabel: 'Celeste Enhancements'! !

!Celeste class methodsFor: 'enhancements documentation' stamp: 'sbw 1/30/2001 21:40'!
readMeEnhancementsString
	^ 'These enhancements are a joint effort between Lex Spoon and Steve Wessels.
	1. The custom menu button always presents a menu; matching filters are
	   listed at the top of the the menu.

	2. The auto-move button is removed.  Instead, the regular TOC menu will
	   give the option of an automove.

	3. Huge message lists are not shown, but a menu item is added to forcibly
	   show all messages.  You can also specify the maximum number to display.

	4. The From Filter is switched to a Participant Filter.

	5. The table of contents pane uses a new multi-column list morph, which makes
	   for nicer looking lists.

	6. Messages that have attachments are indicated with @.

	7. If attachments are jpeg or gif then open view will correctly process the image,
	   and save will suggest a proper extension for the file name.

	8. The delete button is back.

	9. The morphic panes use the new fixed pane scheme (layouts).

	10. The status pane is displayed depending on an option in Preferences.  Default is
	    to not show the status pane.

	11. Menus use checkbox style for some of the options:
	    (suppress header, and leave messages on server).'! !


!Celeste class methodsFor: 'common build' stamp: 'sbw 1/28/2001 23:22'!
buildButtonFromSpec: spec forModel: model 
	| buttonViewClass b |
	Smalltalk isMorphic
		ifTrue: [buttonViewClass _ self morphicButtonsClass]
		ifFalse: [buttonViewClass _ PluggableButtonView].
	b _ buttonViewClass
				on: model
				getState: (self specificationFromList: spec at: 1)
				action: (self specificationFromList: spec at: 2).
	b
		label: (self specificationFromList: spec at: 3);
		 borderWidth: 1.
	b
		setBalloonText: (self specificationFromList: spec at: 4).
	^ b! !

!Celeste class methodsFor: 'common build' stamp: 'sbw 1/28/2001 23:22'!
buildButtonFromSpec: spec withBlock: aBlock 
	| b buttonViewClass |
	Smalltalk isMorphic
		ifTrue: [buttonViewClass _ self morphicButtonsClass]
		ifFalse: [buttonViewClass _ PluggableButtonView].
	b _ buttonViewClass new
				model: (Button new onAction: aBlock);
				
				action: (self specificationFromList: spec at: 1);
				
				label: (self specificationFromList: spec at: 2);
				 borderWidth: 1.
	b
		setBalloonText: (self specificationFromList: spec at: 3).
	^ b! !

!Celeste class methodsFor: 'common build' stamp: 'sbw 1/30/2001 20:42'!
buildButtonsFor: model 
	"Answer a collection of handy buttons for the Celeste user interface."
	| buttons b |
	buttons _ OrderedCollection new.
	b _ self buildButtonFromSpec: self specForSubjectFilterButton forModel: model.
	buttons add: b.
	true
		ifFalse: ["Skip these buttons..."
			b _ self buildFromFilterButtonForModel: model.
			buttons add: b].
	b _ self buildButtonFromSpec: self specForParticipantFilterButton forModel: model.
	buttons add: b.
	b _ self buildButtonFromSpec: self specForCustomFilterButton forModel: model.
	buttons add: b.
	true
		ifFalse: ["Skip these buttons..."
	b _ self buildButtonFromSpec: self specForCustomFilterMoveButton forModel: model.
	buttons add: b].
	b _ self
				buildButtonFromSpec: self specForComposeButton
				withBlock: [model compose].
	buttons add: b.
	b _ self
				buildButtonFromSpec: self specForReplyButton
				withBlock: [model reply].
	buttons add: b.
	b _ self
				buildButtonFromSpec: self specForForwardButton
				withBlock: [model forward].
	buttons add: b.
	b _ self
				buildButtonFromSpec: self specForMoveAgainButton
				withBlock: [model moveAgain].
	buttons add: b.
	b _ self
				buildButtonFromSpec: self specForDeleteButton
				withBlock: [model deleteMessage].
	buttons add: b.
	^ buttons! !

!Celeste class methodsFor: 'common build' stamp: 'sbw 1/28/2001 23:22'!
buildFromFilterButtonForModel: model 
	| sw b buttonViewClass |
	Smalltalk isMorphic
		ifTrue: [buttonViewClass _ self morphicButtonsClass]
		ifFalse: [buttonViewClass _ PluggableButtonView].
	sw _ Switch new.
	b _ buttonViewClass on: (sw
					onAction: [model fromFilterOn: sw];
					
					offAction: [model fromFilterOff]).
	b label: 'From F.';
		 borderWidth: 1.
	b setBalloonText: 'Show messages with specific From: line content'.
	^ b! !

!Celeste class methodsFor: 'common build' stamp: 'sbw 1/21/2001 22:03'!
openOnDatabase: aMailDB 
	"Open a MailReader on the given mail database."
	| model topWindow title |
	model _ self new openOnDatabase: aMailDB.
	title _ self defaultWindowTitle.
	Smalltalk isMorphic
		ifTrue: [topWindow _ self
						buildTopMorphicWindowTitled: title
						model: model.
			topWindow openInWorld]
		ifFalse: [topWindow _ self buildTopMVCWindowTitled: title model: model.
			topWindow controller open].
	"in case the sender wants to know"
	^ model! !

!Celeste class methodsFor: 'common build' stamp: 'sbw 1/28/2001 23:23'!
specificationFromList: list at: index 
	| value |
	value _ list at: index.
	value = #nil
		ifTrue: [value _ nil].
	^ value! !


!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:19'!
specForComposeButton
	"action label helpText"
	^ #(#turnOn 'New' 'Compose a new message' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/30/2001 20:38'!
specForCustomFilterButton
	"getState action label helpText"
	^ #(#isCustomFilterOn #customFilterOn 'Custom F.' 'Select messages with a general custom filter' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:20'!
specForCustomFilterMoveButton
	"getState action label helpText"
	^ #(#nil #customFilterMove 'Custom F. Move' 'Move messages which match a custom filter to appropriate category' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:20'!
specForDeleteButton
	"action label helpText"
	^ #(#turnOn 'Delete' 'Delete the selected message' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:20'!
specForForwardButton
	"action label helpText"
	^ #(#turnOn 'Forward' 'Forward the selected message' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:20'!
specForMoveAgainButton
	"action label helpText"
	^ #(#turnOn 'Move Again' 'Move the selected message to the same category as previously' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/30/2001 20:40'!
specForParticipantFilterButton
	"getState action label helpText"
	^ #(#isParticipantFilterOn #participantFilterOn 'Part. F.' 'Select messages by their From:, To:, and Cc: lines' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/28/2001 23:20'!
specForReplyButton
	"action label helpText"
	^ #(#turnOn 'Reply' 'Reply to the selected message' )! !

!Celeste class methodsFor: 'button specs' stamp: 'sbw 1/30/2001 20:35'!
specForSubjectFilterButton
	"getState action label helpText"
	^ #(#isSubjectFilterOn #subjectFilterOn 'Subj. F.' 'Select messages by their subject' )! !


!Celeste class methodsFor: 'build-common' stamp: 'sbw 1/30/2001 19:44'!
defaultWindowTitle
	^ 'Celeste'! !


!Celeste class methodsFor: 'build-mvc' stamp: 'sbw 1/21/2001 22:02'!
buildTopMVCWindowTitled: title model: model 
	| topWindow views buttons |
	topWindow _ StandardSystemView new model: model;
				 label: title;
				 minimumSize: 400 @ 250.
	views _ self buildViewsFor: model.
	buttons _ self buildButtonsFor: model.
	self
		addMVCViews: views
		andButtons: buttons
		to: topWindow.
	^ topWindow! !

!Celeste class methodsFor: 'build-mvc' stamp: 'sbw 1/22/2001 00:09'!
buildViewsFor: model 
	"Answer a collection of window panes for the Celeste user interface."
	| listViewClass textViewClass listFont views v multiListViewClass |
	listViewClass _ PluggableListViewByItem.
	multiListViewClass _ PluggableListViewByItem.
	textViewClass _ PluggableTextView.
	listFont _ StrikeFont allSubInstances
				detect: [:f | (f name beginsWith: 'CourierFixed')
						and: [f height = 11]]
				ifNone: [TextStyle defaultFont].
	views _ OrderedCollection new.
	v _ listViewClass
				on: model
				list: #categoryList
				selected: #category
				changeSelected: #setCategory:
				menu: #categoryMenu:
				keystroke: #categoriesKeystroke:.
	views add: v.
	v _ multiListViewClass
				on: model
				list: #tocEntryList
				selected: #tocEntry
				changeSelected: #setTOCEntry:
				menu: #tocMenu:
				keystroke: #tocKeystroke:.
	v font: listFont.
	views add: v.
	v _ textViewClass new
				on: model
				text: #messageText
				accept: #messageText:
				readSelection: nil
				menu: #messageMenu:shifted:.
	v borderWidth: 1.
	model messageTextView: v.
	views add: v.
	v _ textViewClass new
				on: model
				text: #status
				accept: nil
				readSelection: nil
				menu: nil.
	v borderWidth: 1.
	model messageTextView: v.
	views add: v.
	^ views! !


!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/30/2001 20:04'!
addLowerMorphicViews: views andButtons: buttons to: topWindow offset: offset 
	| row verticalOffset innerFractions |
	row _ AlignmentMorph newColumn hResizing: #spaceFill;
				 vResizing: #spaceFill;
				 layoutInset: 0;
				 borderWidth: 1;
				 borderColor: Color black;
				 layoutPolicy: ProportionalLayout new.
	verticalOffset _ 0.
	innerFractions _ 0 @ 0 corner: 1 @ 0.
	verticalOffset _ self
				addMorphicButtons: buttons
				to: row
				at: innerFractions
				plus: verticalOffset.
	self includeStatusPane ifTrue: [
	verticalOffset _ self
				addMorphicStatusPaneTo: row
				from: views
				at: innerFractions
				plus: verticalOffset].
	self
		addMorphicTextPaneTo: row
		from: views
		at: innerFractions
		plus: verticalOffset.
	topWindow
		addMorph: row
		frame: (0 @ offset extent: 1 @ (1 - offset)).
	row
		on: #mouseEnter
		send: #paneTransition:
		to: topWindow.
	row
		on: #mouseLeave
		send: #paneTransition:
		to: topWindow! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/22/2001 20:53'!
addMorphicButtons: buttons to: row at: innerFractions plus: verticalOffset 
	| delta buttonRow |
	delta _ 25.
	buttonRow _ self morphicButtonRowFrom: buttons.
	buttonRow 
				color: (Color gray alpha: 0.2);
				 borderWidth: 1;
				 borderColor: Color lightGray.
	row addMorph: buttonRow
				fullFrame: (LayoutFrame
						fractions: innerFractions
						offsets: (0@verticalOffset corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/30/2001 19:46'!
addMorphicStatusPaneTo: row from: views at: innerFractions plus: verticalOffset 
	| delta |
	delta _ 20.
	row
		addMorph: (views at: #status)
		fullFrame: (LayoutFrame
				fractions: innerFractions
				offsets: (0 @ verticalOffset corner: 0 @ (verticalOffset + delta))).
	^ verticalOffset + delta! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/22/2001 20:43'!
addMorphicTextPaneTo: row from: views at: innerFractions plus: verticalOffset 
	row
		addMorph: (views at: #messageText)
		fullFrame: (LayoutFrame
				fractions: (innerFractions withBottom: 1)
				offsets: (0 @ verticalOffset corner: 0@0)).
	^ verticalOffset

! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/22/2001 20:22'!
addMorphicViews: views andButtons: buttons to: topWindow 
	topWindow
		addMorph: (views at: #categoryList)
		frame: (0.0 @ 0.0 extent: 0.2 @ 0.25).
	topWindow
		addMorph: (views at: #tocEntryList)
		frame: (0.2 @ 0.0 extent: 0.8 @ 0.25).
	self
		addLowerMorphicViews: views
		andButtons: buttons
		to: topWindow
		offset: 0.25 ! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 22:17'!
buildMorphicCategoryListFor: model
	^PluggableListMorphByItem
				on: model
				list: #categoryList
				selected: #category
				changeSelected: #setCategory:
				menu: #categoryMenu:
				keystroke: #categoriesKeystroke:.
! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 22:19'!
buildMorphicMessageTextPaneFor: model 
	^ PluggableTextMorph new
				on: model
				text: #messageText
				accept: #messageText:
				readSelection: nil
				menu: #messageMenu:shifted:! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 22:20'!
buildMorphicStatusPaneFor: model 
	^ PluggableTextMorph new
				on: model
				text: #status
				accept: nil
				readSelection: nil
				menu: nil.! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 22:18'!
buildMorphicTocEntryListFor: model 
	^ PluggableMultiColumnListMorphByItem
				on: model
				list: #tocEntryList
				selected: #tocEntry
				changeSelected: #setTOCEntry:
				menu: #tocMenu:
				keystroke: #tocKeystroke:! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 22:21'!
buildMorphicViewsFor: model 
	"Answer a dictionary of window panes for the Celeste user interface."
	| listFont views v |
	listFont _ StrikeFont allSubInstances
				detect: [:f | (f name beginsWith: 'CourierFixed')
						and: [f height = 11]]
				ifNone: [TextStyle defaultFont].
	views _ Dictionary new.
	v _ self buildMorphicCategoryListFor: model.
	views at: #categoryList put: v.
	v _ self buildMorphicTocEntryListFor: model.
	v font: listFont.
	views at: #tocEntryList put: v.
	v _ self buildMorphicMessageTextPaneFor: model.
	v borderWidth: 1.
	model messageTextView: v.
	views at: #messageText put: v.
	v _ self buildMorphicStatusPaneFor: model.
	v borderWidth: 1.
	views at: #status put: v.
	^ views! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/22/2001 00:50'!
buildTopMorphicWindowTitled: title model: model 
	| topWindow views buttons |
	topWindow _ (SystemWindow labelled: title)
				model: model.
	buttons _ self buildButtonsFor: model.
	views _ self buildMorphicViewsFor: model.
	self addMorphicViews: views andButtons: buttons to: topWindow .
	buttons
		do: [:b | b onColor: Color lightGray offColor: Color white].
	^ topWindow! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 2/2/2001 13:01'!
morphicButtonRowFrom: buttons 
	| aRow |
	aRow _ AlignmentMorph newRow.
	aRow setNameTo: 'buttonPane'.
	aRow beSticky.
	aRow hResizing: #spaceFill.
	aRow wrapCentering: #center;
		 cellPositioning: #leftCenter.
	aRow clipSubmorphs: true.
	aRow addTransparentSpacerOfSize: 5 @ 0.
	buttons
		do: [:btn | 
			btn useRoundedCorners;
			 hResizing: #spaceFill;
						 vResizing: #spaceFill.
			aRow addMorphBack: btn.
			aRow addTransparentSpacerOfSize: 3 @ 0].
	^ aRow! !

!Celeste class methodsFor: 'build-morphic' stamp: 'sbw 1/21/2001 20:55'!
morphicButtonsClass

	^PluggableButtonMorph! !


!Celeste class methodsFor: 'accessing' stamp: 'sbw 1/30/2001 20:11'!
messageCountLimit
	MessageCountLimit == nil ifTrue: [self initializeMessageCountLimit].
	^ MessageCountLimit! !

!Celeste class methodsFor: 'accessing' stamp: 'sbw 1/30/2001 20:09'!
messageCountLimit: anInteger
	MessageCountLimit _ anInteger! !
Model subclass: #CelesteComposition
	instanceVariableNames: 'celeste messageText textEditor attachmentSeparator morphicWindow mvcWindow '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!CelesteComposition commentStamp: '<historical>' prior: 0!
a message being composed.  When finished, it will be submitted via a Celeste.!


!CelesteComposition methodsFor: 'private' stamp: 'ls 12/8/1999 22:04'!
breakLines: aString  atWidth: width
	"break lines in the given string into shorter lines"
	| result start end pastHeader atAttachment |

	result _ WriteStream on: (String new: (aString size * 50 // 49)).

	pastHeader _ false.
	atAttachment _ false.
	aString asString linesDo: [ :line | 
		line isEmpty ifTrue: [ pastHeader _ true ].
		pastHeader ifFalse: [ result nextPutAll: line.  result cr. ] ifTrue: [
			(line beginsWith: '====') ifTrue: [ atAttachment _ true ].
			atAttachment ifTrue: [
				"at or after an attachment line; no more wrapping for the rest of the message"
				result nextPutAll: line.  result cr ]
			ifFalse: [
				(line beginsWith: '>') ifTrue: [
					"it's quoted text; don't wrap it"
					result nextPutAll: line. result cr. ]
				ifFalse: [
					"regular old line.  Wrap it to multiple lines"
					start _ 1.
	
					"output one shorter line each time through this loop"
					[ start + width <= line size ] whileTrue: [
	
						"find the end of the line"
						end _ start + width - 1.
						[end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [
							end _ end - 1 ].
						end < start ifTrue: [
							"a word spans the entire width!!"
							end _ start + width - 1 ].

						"copy the line to the output"
						result nextPutAll: (line copyFrom: start to: end).
						result cr.

						"get ready for next iteration"
						start _ end+1.
						(line at: start) isSeparator ifTrue: [ start _ start + 1 ].
					].
					"write out the final part of the line"
					result nextPutAll: (line copyFrom: start to: line size).
					result cr.
				].
			].
		].
	].

	^result contents! !

!CelesteComposition methodsFor: 'private' stamp: 'dvf 4/28/2000 02:19'!
hasAttachments
	^ attachmentSeparator notNil! !


!CelesteComposition methodsFor: 'access' stamp: 'bf 3/9/2000 18:02'!
messageText
	"return the current text"
	^messageText isoToSqueak! !

!CelesteComposition methodsFor: 'access' stamp: 'bf 3/9/2000 18:26'!
messageText: aText
	"change the current text"
	messageText _ aText squeakToIso.
	self changed: #messageText.
	^true! !

!CelesteComposition methodsFor: 'access' stamp: 'dvf 5/13/2000 16:51'!
submit
	"submit the message"
	textEditor
		ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
	celeste queueMessageWithText: (MailMessage from: messageText asString) asSendableText.
	morphicWindow ifNotNil: [morphicWindow delete].
	mvcWindow ifNotNil: [mvcWindow controller close]! !


!CelesteComposition methodsFor: 'initialization' stamp: 'ls 10/15/1998 21:51'!
celeste: aCeleste  initialText: aText
	celeste _ aCeleste.
	messageText _ aText.! !


!CelesteComposition methodsFor: 'interface' stamp: 'mdr 8/31/2000 18:37'!
addAttachment
	| file fileResult fileName |
	textEditor
		ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]].
	"transform into multipart if needed"
	self hasAttachments ifFalse: [self transformToMultipart].
	"then simply append another attachment section"
	(fileResult _ StandardFileMenu oldFile)
		ifNotNil: 
			[fileName _ fileResult directory fullNameFor: fileResult name.
			file _ FileStream readOnlyFileNamed: fileName.
			file ifNotNil: [self messageText: ((MailMessage from: self messageText)
						asTextEncodingNewPart: file named: fileResult name)]] ! !

!CelesteComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:11'!
open
	"open an interface"
	Smalltalk isMorphic
		ifTrue: [ self openInMorphic ]
		ifFalse: [ self openInMVC ]! !

!CelesteComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:17'!
openInMVC
	| textView sendButton  |

	mvcWindow _ StandardSystemView new
		label: 'Mister Postman';
		minimumSize: 400@250;
		model: self.

	textView _ PluggableTextView
		on: self
		text: #messageText
		accept: #messageText:.
	textEditor _ textView controller.

	sendButton _ PluggableButtonView 
		on: self
		getState: nil
		action: #submit.
	sendButton label: 'Send'.
	sendButton borderWidth: 1.

	sendButton window: (1@1 extent: 398@38).
	mvcWindow addSubView: sendButton.

	textView window: (0@40 corner: 400@250).
	mvcWindow addSubView: textView below: sendButton.

	mvcWindow controller open.

		
! !

!CelesteComposition methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:20'!
openInMorphic
	"open an interface for sending a mail message with the given initial 
	text "
	| textMorph buttonsList sendButton attachmentButton |
	morphicWindow _ SystemWindow labelled: 'Mister Postman'.
	morphicWindow model: self.
	textEditor _ textMorph _ PluggableTextMorph
						on: self
						text: #messageText
						accept: #messageText:.
	morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1).
	buttonsList _ AlignmentMorph newRow.
	sendButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #submit.
	sendButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'send message';
		setBalloonText: 'add this to the queue of messages to be sent';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: sendButton.
	
	attachmentButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: #addAttachment.
	attachmentButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'add attachment';
		setBalloonText: 'Send a file with the message';
		onColor: Color white offColor: Color white.
	buttonsList addMorphBack: attachmentButton.
	
	morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1).
	morphicWindow openInMVC! !

!CelesteComposition methodsFor: 'interface' stamp: 'dvf 5/13/2000 12:16'!
transformToMultipart
	| oldPart |
	oldPart _ MailMessage from: self messageText asString.
	self messageText: oldPart asMultipartText

	! !

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

CelesteComposition class
	instanceVariableNames: ''!

!CelesteComposition class methodsFor: 'instance creation' stamp: 'ls 10/16/1998 09:08'!
celeste: aCeleste  initialText: initialText
	"create an instance for the given mail reader, editting the given text"
	^self new celeste: aCeleste  initialText: initialText! !

!CelesteComposition class methodsFor: 'instance creation' stamp: 'ls 10/16/1998 09:08'!
openForCeleste: aCeleste  initialText: initialText
	"open a composition window for the given mail reader, editting the given text"
	(self celeste: aCeleste  initialText: initialText) open! !
CodeHolder subclass: #ChangeList
	instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeList commentStamp: '<historical>' prior: 0!
A ChangeList represents a list of changed methods that reside on a file in fileOut format.  The classes and methods in my list are not necessarily in this image!!  Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...).  Note that the two kinds of window have different controller classes!!!!

It holds three lists:
	changeList - a list of ChangeRecords
	list - a list of one-line printable headers
	listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
	listIndex 
Items that are removed (removeDoits, remove an item) are removed from all three lists.
Most recently clicked item is the one showing in the bottom pane.!


!ChangeList methodsFor: 'initialization-release'!
addItem: item text: text
	| cr |
	cr _ Character cr.
	changeList addLast: item.
	list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/7/2000 12:42'!
changeListButtonSpecs

	^#(
		('select all' 			selectAll				'select all entries')
		('deselect all'		deselectAll			'deselect all entries')
		('select conflicts'	selectAllConflicts	'select all methods that occur in any change set')
		('file in selections' 	fileInSelections		'file in all selected entries')
		)! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/13/2000 10:50'!
initialize
	showDiffs _ Preferences diffsInChangeList.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	super initialize! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/18/2001 13:09'!
openAsMorphName: labelString multiSelect: multiSelect
	"Open a morphic view for the messageSet, whose label is labelString.
	The listView may be either single or multiple selection type"

	| window listHeight listPane |
	listHeight _ 0.4.

	window _ (SystemWindow labelled: labelString)
		model: self.

	listPane _ (multiSelect
				ifTrue: [PluggableListMorphOfMany]
				ifFalse: [PluggableListMorph])
			on: self
			list: #list
			selected: #listIndex
			changeSelected: #toggleListIndex:
			menu: (self showsVersions
				ifTrue: [#versionsMenu:]
				ifFalse: [#changeListMenu:]).
	listPane keystrokeActionSelector: #changeListKey:from:.
	window addMorph: listPane
		frame: (0 @ 0 extent: 1 @ listHeight).

	self 
		addLowerPanesTo: window 
		at: (0@listHeight corner: 1@1) 
		with: nil.

	^ window openInWorld! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sbw 12/30/1999 11:02'!
optionalButtonHeight

	^ 15! !

!ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/18/2001 16:35'!
optionalButtonsView
	"Answer the a View containing the optional buttons"

	| view bHeight vWidth first offset previousView bWidth button |
	vWidth _ 200.
	bHeight _ self optionalButtonHeight.
	previousView _ nil.
	offset _ 0.
	first _ true.

	view _ View new
		model: self;
		window: (0 @ 0 extent: vWidth @ bHeight).

	self changeListButtonSpecs do: [:triplet |
		button _ PluggableButtonView
			on: self
			getState: nil
			action: triplet second.
		button label: triplet first asParagraph.
		bWidth _ button label boundingBox width // 2.
		button
			window: (offset@0 extent: bWidth@bHeight);
			borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
		offset _ offset + bWidth.
		first
			ifTrue:
				[view addSubView: button.
				first _ false.]
			ifFalse:
				[view addSubView: button toRightOf: previousView].
		previousView _ button].

	button _ PluggableButtonView
		on: self
		getState: #showDiffs
		action: #toggleDiffing.
	button
		label: 'diffs' asParagraph;
		window: (offset@0 extent: (vWidth - offset)@bHeight).
	view addSubView: button toRightOf: previousView.

	^ view! !


!ChangeList methodsFor: 'scanning' stamp: 'sw 1/15/98 21:56'!
scanCategory  
	"Scan anything that involves more than one chunk; method name is historical only"

	| itemPosition item tokens stamp isComment anIndex |
	itemPosition _ file position.
	item _ file nextChunk.

	isComment _ (item includesSubString: 'commentStamp:').
	(isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
		["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
		^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
				 text: ('preamble: ' , item contractTo: 50)].

	tokens _ Scanner new scanTokens: item.
	tokens size >= 3 ifTrue:
		[stamp _ ''.
		anIndex _ tokens indexOf: #stamp: ifAbsent: [nil].
		anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

		tokens second == #methodsFor:
			ifTrue: [^ self scanCategory: tokens third class: tokens first
							meta: false stamp: stamp].
		tokens third == #methodsFor:
			ifTrue: [^ self scanCategory: tokens fourth class: tokens first
							meta: true stamp: stamp]].

		tokens second == #commentStamp:
			ifTrue:
				[stamp _ tokens third.
				self addItem:
						(ChangeRecord new file: file position: file position type: #classComment
										class: tokens first category: nil meta: false stamp: stamp)
						text: 'class comment for ' , tokens first, 
							  (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
				file nextChunk.
				^ file skipStyleChunk]! !

!ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:56'!
scanCategory: category class: class meta: meta stamp: stamp
	| itemPosition method |
	[itemPosition _ file position.
	method _ file nextChunk.
	file skipStyleChunk.
	method size > 0]						"done when double terminators"
		whileTrue:
		[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: category meta: meta stamp: stamp)
			text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, (Parser new parseSelector: method)
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !

!ChangeList methodsFor: 'scanning' stamp: 'sw 10/19/1999 15:13'!
scanFile: aFile from: startPosition to: stopPosition
	| itemPosition item prevChar |
	file _ aFile.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	file position: startPosition.
'Scanning ', aFile localName, '...'
	displayProgressAt: Sensor cursorPoint
	from: startPosition to: stopPosition
	during: [:bar |
	[file position < stopPosition]
		whileTrue:
		[bar value: file position.
		[file atEnd not and: [file peek isSeparator]]
				whileTrue: [prevChar _ file next].
		(file peekFor: $!!)
		ifTrue:
			[(prevChar = Character cr or: [prevChar = Character lf])
				ifTrue: [self scanCategory]]
		ifFalse:
			[itemPosition _ file position.
			item _ file nextChunk.
			file skipStyleChunk.
			item size > 0 ifTrue:
				[self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
					text: 'do it: ' , (item contractTo: 50)]]]].
	listSelections _ Array new: list size withAll: false! !


!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/3/1998 19:15'!
acceptFrom: aView

	aView controller text = aView controller initialText ifFalse: [
		aView flash.
		^ self inform: 'You can only accept this version as-is.
If you want to edit, copy the text to a browser'].
	(aView setText: aView controller text from: self) ifTrue:
		[aView ifNotNil: [aView controller accept]].	"initialText"
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/7/2000 12:59'!
browseCurrentVersionsOfSelections
	"Opens a message-list browser on the current in-memory versions of all methods that are currently seleted"
	|  aClass aChange aList |
	aList _ OrderedCollection new.
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | (listSelections at: i) ifTrue:
			 [aChange _ changeList at: i.
			(aChange type = #method
				and: [(aClass _ aChange methodClass) notNil
				and: [aClass includesSelector: aChange methodSelector]])
					ifTrue:
						[aList add: aClass name, ' ', aChange methodSelector]]]].

	aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts'].
	MessageSet openMessageList: aList name: 'Current versions of selected methods in ', file localName! !

!ChangeList methodsFor: 'menu actions' stamp: 'RAA 1/11/2001 08:42'!
buildMorphicCodePaneWith: editString

	| codePane |

	codePane _ AcceptableCleanTextMorph
		on: self
		text: #contents 
		accept: #contents:
		readSelection: #contentsSelection 
		menu: #codePaneMenu:shifted:.
	editString ifNotNil: [
		codePane editString: editString.
		codePane hasUnacceptedEdits: true
	].
	^codePane
! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 07:22'!
changeListKey: aChar from: view
	"Respond to a Command key in the list pane."

	aChar == $D ifTrue: [^ self toggleDiffing].
	aChar == $a ifTrue: [^ self selectAll].

	^ self arrowKey: aChar from: view! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 08:40'!
changeListMenu: aMenu
	"Fill aMenu up so that it comprises the primary changelist-browser menu"

	Smalltalk isMorphic ifTrue:
		[aMenu addTitle: 'change list'.
		aMenu addStayUpItemSpecial].

	aMenu addList: #(

	('fileIn selections'							fileInSelections)
	('fileOut selections...	'						fileOutSelections)
	-
	('compare to current'						compareToCurrentVersion)
	('toggle diffing (D)'							toggleDiffing)
	-
	('select conflicts with any changeset'		selectAllConflicts)
	('select conflicts with current changeset'	selectConflicts)
	-
	('select conflicts with...'						selectConflictsWith)
	('select unchanged methods'					selectUnchangedMethods)
	('select methods for this class'				selectMethodsForThisClass)
	('invert selections'							invertSelections)
	-
	('select all (a)'								selectAll)
	('deselect all'								deselectAll)
	-
	('browse current versions of selections'		browseCurrentVersionsOfSelections)
	('remove current methods of selections'		destroyCurrentCodeOfSelections)
	-
	('remove doIts'								removeDoIts)
	('remove older versions'						removeOlderMethodVersions)
	('remove selected items'						removeSelections)
	('remove unselected items'					removeNonSelections)).

	^ aMenu

! !

!ChangeList methodsFor: 'menu actions' stamp: 'nk 10/29/2000 12:34'!
compareToCurrentVersion
	"If the current selection corresponds to a method in the system, 
	then spawn a window showing the diffs as text"
	| change class s1 s2 |
	listIndex = 0
		ifTrue: [^ self].
	change _ changeList at: listIndex.
	((class _ change methodClass) notNil
			and: [class includesSelector: change methodSelector])
		ifTrue: [s1 _ (class sourceCodeAt: change methodSelector) asString.
			s2 _ change string.
			s1 = s2
				ifTrue: [^ self inform: 'Exact Match'].
			(StringHolder new
				textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: class))
				openLabel: 'Comparison to Current Version']
		ifFalse: [self flash]! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 08:38'!
deselectAll 
	"Deselect all items in the list pane, and clear the code pane"

	listIndex _ 0.
	listSelections atAllPut: false.
	self changed: #allSelections.
	self contentsChanged! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 09:04'!
destroyCurrentCodeOfSelections
	"Actually remove from the system any in-memory methods with class and selector identical to items current selected.  This may seem rather arcane but believe me it has its great uses, when trying to split out code.  To use effectively, first file out a change set that you wish to split off.  Then open a ChangeList browser on that fileout.  Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command.  For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!"

	|  aClass aChange aList |
	aList _ OrderedCollection new.
	1 to: changeList size do:
		[:index |
			(listSelections at: index) ifTrue:
				[aChange _ changeList at: index.
				(aChange type = #method
					and: [(aClass _ aChange methodClass) notNil
					and: [aClass includesSelector: aChange methodSelector]])
						ifTrue:
							[aList add: {aClass. aChange methodSelector}]]].

	aList size > 0 ifTrue:
		[(self confirm: 'Warning!! This will actually remove ', aList size printString,  ' method(s) from the system!!') ifFalse: [^ self]].
	aList do:
		[:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second.
			aPair first removeSelector: aPair second]! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 10/11/1999 17:10'!
fileInSelections 
	| any |
	any _ false.
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [any _ true. item fileIn]].
	any ifFalse:
		[self inform: 'nothing selected, so nothing done']! !

!ChangeList methodsFor: 'menu actions' stamp: 'sma 2/5/2000 19:13'!
fileOutSelections 
	| f |
	f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st').
	f ifNil: [^ self].
	f header; timeStamp.
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileOutOn: f]].
	f close! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/25/2001 08:35'!
invertSelections
	"Invert the selectedness of each item in the changelist"

	listSelections _ listSelections collect: [ :ea | ea not].
	listIndex _ 0.
	self changed: #allSelections.
	self contentsChanged! !

!ChangeList methodsFor: 'menu actions' stamp: 'RAA 1/17/2001 14:25'!
optionalButtonRow
	| aRow aButton |
	aRow _ AlignmentMorph newRow.
	aRow hResizing: #spaceFill.
	aRow clipSubmorphs: true.
	aRow addTransparentSpacerOfSize: (5@0).
	aRow wrapCentering: #center; cellPositioning: #leftCenter.
	self changeListButtonSpecs do:
		[:triplet |
			aButton _ PluggableButtonMorph
				on: self
				getState: nil
				action: triplet second.
			aButton
				hResizing: #spaceFill;
				vResizing: #spaceFill;
				useRoundedCorners;
				label: triplet first asString;
				askBeforeChanging: true;
				onColor: Color transparent offColor: Color transparent.

			aRow addMorphBack: aButton.
			aRow addTransparentSpacerOfSize: (3 @ 0).
			aButton setBalloonText: triplet third.
		].
	aRow addMorphBack: self diffButton.	
	^ aRow! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 10/11/1999 17:18'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If I can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	(#accept == selector) ifTrue:
		[otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]].
			"weird special case just for mvc changlist"

	^ super perform: selector orSendTo: otherTarget! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/8/98 12:38'!
removeDoIts
	"Remove doits from the receiver, other than initializes. 1/26/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	changeList with: list do:
		[:chRec :str |
			(chRec type ~~ #doIt or:
				[str endsWith: 'initialize'])
					ifTrue:
						[newChangeList add: chRec.
						newList add: str]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list.

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 9/18/2000 12:21'!
removeNonSelections
	"Remove the unselected items from the receiver."

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifTrue:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size == 0 ifTrue:
		[^ self inform: 'That would remove everything.
Why would you want to do that?'].

	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list

	! !

!ChangeList methodsFor: 'menu actions' stamp: 'di 6/13/97 23:10'!
removeOlderMethodVersions
	"Remove older versions of entries from the receiver."
	| newChangeList newList found str |
	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.
	found _ OrderedCollection new.

	changeList reverseWith: list do:
		[:chRec :strNstamp | str _ strNstamp copyUpTo: $;.
			(found includes: str)
				ifFalse:
					[found add: str.
					newChangeList add: chRec.
					newList add: strNstamp]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList reversed.
			list _ newList reversed.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list! !

!ChangeList methodsFor: 'menu actions'!
removeSelections
	"Remove the selected items from the receiver.  9/18/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifFalse:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list

	! !

!ChangeList methodsFor: 'menu actions'!
selectAll
	listIndex _ 0.
	listSelections atAllPut: true.
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 12/27/1999 12:24'!
selectAllConflicts
	"Selects all method definitions in the receiver which are also in any existing change set in the system.  This makes no statement about whether the content of the methods differ, only whether there is a change represented.
"
	|  aClass aChange |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | aChange _ changeList at: i.
		listSelections at: i put:
			(aChange type = #method
			and: [(aClass _ aChange methodClass) notNil
			and: [(ChangeSorter allChangeSetsWithClass: aClass selector: aChange methodSelector) size > 0]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts
	"Selects all method definitions for which there is ALSO an entry in changes"
	| change class systemChanges |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(Smalltalk changes atSelector: change methodSelector
						class: class) ~~ #none]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts: changeSetOrList
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
	| change class systemChanges |
	Cursor read showWhile: 
	[(changeSetOrList isKindOf: ChangeSet) ifTrue: [
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(changeSetOrList atSelector: change methodSelector
						class: class) ~~ #none]])]]
	ifFalse: ["a ChangeList"
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [changeSetOrList list includes: (list at: i)]])]]
	].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 6/24/1999 07:22'!
selectConflictsWith
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk"
	| aStream all index |
	aStream _ WriteStream on: (String new: 200).
	all _ ChangeSet allSubInstances asOrderedCollection.
	all do:
		[:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
	ChangeList allSubInstancesDo:
		[:sel | aStream nextPutAll: (sel file name); cr.
			all addLast: sel].
	aStream skip: -1.
	index _ (PopUpMenu labels: aStream contents) startUp.
	index > 0 ifTrue: [
		self selectConflicts: (all at: index)].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'ls 11/14/1998 14:30'!
selectMethodsForThisClass
	| name |
	self currentChange ifNil: [ ^self ].
	name _ self currentChange methodClassName.
	name ifNil: [ ^self ].
	^self selectSuchThat: [ :change |
		change methodClassName = name ].! !

!ChangeList methodsFor: 'menu actions' stamp: 'sw 1/7/2000 15:04'!
selectSuchThat
	"query the user for a selection criterio.  By Lex Spoon.  NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:"
	| code block |
	code _ FillInTheBlank request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs.

	code isEmpty ifTrue: [^ self ].

	block _ Compiler evaluate: '[:aChangeRecord | ', code, ']'.

	self selectSuchThat: block! !

!ChangeList methodsFor: 'menu actions' stamp: 'ls 5/12/1999 07:56'!
selectSuchThat: aBlock
	"select all changes for which block returns true"
	listSelections _ changeList collect: [ :change | aBlock value: change ].
	self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 1/7/98 10:12'!
selectUnchangedMethods
	"Selects all method definitions for which there is already a method in the current image, whose source is exactly the same.  9/18/96 sw"
	| change class |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			((change type = #method and:
				[(class _ change methodClass) notNil]) and:
					[(class includesSelector: change methodSelector) and:
						[change string = (class sourceCodeAt: change methodSelector) asString]])]].
	self changed: #allSelections! !


!ChangeList methodsFor: 'viewing access' stamp: 'sw 12/28/2000 10:12'!
annotation
	"Answer the string to be shown in an annotation pane.  Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version."

	| annot |

	annot _ super annotation.
	^ annot asString = '------'
		ifTrue:
			[annot]
		ifFalse:
			['current version: ', annot]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 9/27/1999 16:01'!
contents
	^ self showDiffs
		ifFalse:
			[self undiffedContents]
		ifTrue:
			[self showsVersions
				ifTrue:
					[self diffedVersionContents]
				ifFalse:
					[self contentsDiffedFromCurrent]]! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'!
contents: aString
	listIndex = 0 ifTrue: [self changed: #flash. ^ false].
	lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
	self okToChange "means not dirty" ifFalse: ["is dirty"
		self inform: 'This is a view of a method on a file.\Please cancel your changes.  You may\accept, but only when the method is untouched.' withCRs.  ^ false].
		"Can't accept changes here.  Method text must be unchanged!!"
	(changeList at: listIndex) fileIn.
	^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/12/1999 12:40'!
contentsDiffedFromCurrent
	| aChange aClass |
	listIndex = 0
		ifTrue: [^ ''].
	aChange _ changeList at: listIndex.
	^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector])
		ifTrue:
			 [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector]
		ifFalse:
			[(changeList at: listIndex) text]! !

!ChangeList methodsFor: 'viewing access' stamp: 'nk 10/29/2000 12:38'!
diffedVersionContents
	| thisText change class |
	(listIndex = 0
			or: [changeList size < listIndex])
		ifTrue: [^ ''].
	change _ changeList at: listIndex.
	thisText _ change text.
	class _ change methodClass.
	^ listIndex == changeList size
		ifTrue: [thisText]
		ifFalse: [TextDiffBuilder buildDisplayPatchFrom: (changeList at: listIndex + 1) text to: thisText inClass: class]! !

!ChangeList methodsFor: 'viewing access'!
list
	^ list! !

!ChangeList methodsFor: 'viewing access'!
listIndex
	^ listIndex! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index
	^ listSelections at: index! !

!ChangeList methodsFor: 'viewing access' stamp: 'di 1/13/1999 14:59'!
listSelectionAt: index put: value

	^ listSelections at: index put: value! !

!ChangeList methodsFor: 'viewing access' stamp: 'di 6/15/97 16:46'!
restoreDeletedMethod
	"If lostMethodPointer is not nil, then this is a version browser for a method that has been removed.  In this case we want to establish a sourceCode link to prior versions.  We do this by installing a dummy method with the correct source code pointer prior to installing this version."
	| dummyMethod class selector |
	dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.
	class _ (changeList at: listIndex) methodClass.
	selector _ (changeList at: listIndex) methodSelector.
	class addSelector: selector withMethod: dummyMethod.
	(changeList at: listIndex) fileIn.
	"IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."
	(class compiledMethodAt: selector) == dummyMethod
		ifTrue: [class removeSelectorSimply: selector].
	^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'sma 2/5/2000 19:09'!
selectedClassOrMetaClass
	| c |
	^ (c _ self currentChange) ifNotNil: [c methodClass]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sma 2/5/2000 19:10'!
selectedMessageName
	| c |
	^ (c _ self currentChange) ifNotNil: [c methodSelector]! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/28/1999 12:30'!
toggleListIndex: newListIndex

	listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false].
	newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true].
	listIndex _ newListIndex.
	self changed: #listIndex.
	self contentsChanged! !

!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/25/1999 14:45'!
undiffedContents
	^ listIndex = 0
		ifTrue: ['']
		ifFalse: [(changeList at: listIndex) text]! !


!ChangeList methodsFor: 'accessing'!
changeList
	^ changeList! !

!ChangeList methodsFor: 'accessing' stamp: 'ls 5/12/1999 07:55'!
currentChange
	"return the current change being viewed, or nil if none"
	listIndex = 0 ifTrue: [ ^nil ].
	^changeList at: listIndex! !

!ChangeList methodsFor: 'accessing'!
file
	^file! !

!ChangeList methodsFor: 'accessing' stamp: 'TPR 11/28/1998 17:38'!
listHasSingleEntry
	"does the list of changes have only a single item?"
	^list size = 1! !

!ChangeList methodsFor: 'accessing' stamp: 'tk 6/21/1999 20:43'!
listSelections
	listSelections ifNil: [
		list ifNotNil: [
			listSelections _ Array new: list size withAll: false]].
	^ listSelections! !

!ChangeList methodsFor: 'accessing' stamp: 'di 6/15/97 15:13'!
setLostMethodPointer: sourcePointer
	lostMethodPointer _ sourcePointer! !

!ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'!
showsVersions
	^ false! !

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

ChangeList class
	instanceVariableNames: ''!

!ChangeList class methodsFor: 'public access' stamp: 'di 1/18/2001 15:30'!
browseFile: fileName    "ChangeList browseFile: 'AutoDeclareFix.st'"
	"Opens a changeList on the file named fileName"

	^ self browseStream: (FileStream readOnlyFileNamed: fileName)! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'!
browseRecent: charCount    "ChangeList browseRecent: 5000"
	"Opens a changeList on the end of the changes log file"
	| changesFile changeList end |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	end _ changesFile size.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: (0 max: end-charCount) to: end].
	changesFile close.
	self open: changeList name: 'Recent changes' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'di 6/12/1998 16:33'!
browseRecentLog    "ChangeList browseRecentLog"
	"Prompt with a menu of how far back to go"
	| end changesFile banners positions pos chunk i |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ Smalltalk lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk _ changesFile nextChunk.
		i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos _ 0]].
	changesFile close.
	pos _ (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: 'Browse as far back as...'.
	pos == nil ifTrue: [^ self].
	self browseRecent: end-pos! !

!ChangeList class methodsFor: 'public access' stamp: 'di 1/18/2001 15:23'!
browseStream: changesFile
	"Opens a changeList on a fileStream"
	| changeList charCount |
	changesFile readOnly.
	charCount _ changesFile size.
	charCount > 1000000 ifTrue:
		[(self confirm: 'The file ', changesFile name , '
is really long (' , charCount printString , ' characters).
Would you prefer to view only the last million characters?')
			ifTrue: [charCount _ 1000000]].
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: changesFile size-charCount to: changesFile size].
	changesFile close.
	self open: changeList name: changesFile localName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'sw 2/3/2000 16:16'!
getRecentLocatorWithPrompt: aPrompt
	"Prompt with a menu of how far back to go.  Return nil if user backs out.  Otherwise return the number of characters back from the end of the .changes file the user wishes to include"
	 "ChangeList getRecentPosition"
	| end changesFile banners positions pos chunk i |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	banners _ OrderedCollection new.
	positions _ OrderedCollection new.
	end _ changesFile size.
	pos _ Smalltalk lastQuitLogPosition.
	[pos = 0 or: [banners size > 20]] whileFalse:
		[changesFile position: pos.
		chunk _ changesFile nextChunk.
		i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
		i > 0 ifTrue: [positions addLast: pos.
					banners addLast: (chunk copyFrom: 5 to: i-2).
					pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
			ifFalse: [pos _ 0]].
	changesFile close.
	pos _ (SelectionMenu labelList: banners selections: positions)
				startUpWithCaption: aPrompt.
	pos == nil ifTrue: [^ nil].
	^ end - pos! !


!ChangeList class methodsFor: 'instance creation' stamp: 'sw 1/25/2001 08:44'!
open: aChangeList name: aString multiSelect: multiSelect
	"Create a standard system view for the messageSet, whose label is aString.
	The listView may be either single or multiple selection type"

	| topView listHeight annoHeight optButtonHeight codeHeight aListView underPane annotationPane buttonsView aBrowserCodeView |
	Smalltalk isMorphic
		ifTrue: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect].

	listHeight _ 70.
	annoHeight _ 10.
	optButtonHeight _ aChangeList optionalButtonHeight.
	codeHeight _ 110.

	topView _ (StandardSystemView new)
		model: aChangeList;
		label: aString;
		minimumSize: 200 @ 120;
		borderWidth: 1.

	aListView _ (multiSelect
			ifTrue: [PluggableListViewOfMany]
			ifFalse: [PluggableListView])
		on: aChangeList
		list: #list
		selected: #listIndex
		changeSelected: #toggleListIndex:
		menu: (aChangeList showsVersions
			ifTrue: [#versionsMenu:]
			ifFalse: [#changeListMenu:])
		keystroke: #changeListKey:from:.
	aListView window: (0 @ 0 extent: 200 @ listHeight).
	topView addSubView: aListView.

	underPane _ aListView.
	aChangeList wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView
				on: aChangeList
				text: #annotation
				accept: nil
				readSelection: nil
				menu: nil.
			annotationPane window: (0 @ 0 extent: 200 @ 10).
			topView addSubView: annotationPane below: underPane.
			underPane _ annotationPane.
			codeHeight _ codeHeight - annoHeight].

	aChangeList wantsOptionalButtons
		ifTrue:
			[buttonsView _ aChangeList optionalButtonsView.
			buttonsView borderWidth: 1.
			topView addSubView: buttonsView below: underPane.
			underPane _ buttonsView.
			codeHeight _ codeHeight - optButtonHeight].

	aBrowserCodeView _ PluggableTextView
			on: aChangeList
			text: #contents
			accept: #contents:
			readSelection: #contentsSelection
			menu: #codePaneMenu:shifted:.
	aBrowserCodeView
			controller: ReadOnlyTextController new;
			window: (0 @ 0 extent: 200 @ codeHeight).
	topView addSubView: aBrowserCodeView below: underPane.

	topView controller open.! !

!ChangeList class methodsFor: 'instance creation' stamp: 'RAA 1/11/2001 08:20'!
openAsMorph: aChangeList name: labelString multiSelect: multiSelect
	"Open a morphic view for the messageSet, whose label is labelString.
	The listView may be either single or multiple selection type"

	^aChangeList openAsMorphName: labelString multiSelect: multiSelect
! !
ChangeList subclass: #ChangeListForProjects
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!

!ChangeListForProjects methodsFor: 'as yet unclassified' stamp: 'sw 1/13/2000 12:48'!
contents

	^ self showDiffs
		ifFalse: [self undiffedContents]
		ifTrue: [self currentDiffedFromContents]
			"Current is writing over one in list.  Show how I would change it"! !

!ChangeListForProjects methodsFor: 'as yet unclassified' stamp: 'nk 10/29/2000 12:39'!
currentDiffedFromContents
	| aChange aClass |
	listIndex = 0
		ifTrue: [^ ''].
	aChange _ changeList at: listIndex.
	^ ((aChange type == #method
				and: [(aClass _ aChange methodClass) notNil])
			and: [aClass includesSelector: aChange methodSelector])
		ifTrue: [TextDiffBuilder
				buildDisplayPatchFrom: aChange text
				to: (aClass sourceCodeAt: aChange methodSelector)
				inClass: aClass]
		ifFalse: [(changeList at: listIndex) text]! !
Object subclass: #ChangeRecord
	instanceVariableNames: 'file position type class category meta stamp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeRecord commentStamp: '<historical>' prior: 0!
A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.!


!ChangeRecord methodsFor: 'access'!
category
	^category! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 8/24/1998 08:16'!
fileIn
	| methodClass |
	Cursor read showWhile:
		[(methodClass _ self methodClass) notNil ifTrue:
			[methodClass compile: self text classified: category withStamp: stamp notifying: nil].
		(type == #doIt) ifTrue:
			[Compiler evaluate: self string].
		(type == #classComment) ifTrue:
			[(Smalltalk at: class asSymbol) comment: self text stamp: stamp]]! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:09'!
fileOutOn: f
	type == #method
		ifTrue:
			[f nextPut: $!!.
			f nextChunkPut: class asString
					, (meta ifTrue: [' class methodsFor: ']
							ifFalse: [' methodsFor: '])
					, category asString printString.
			f cr].

	type == #preamble ifTrue: [f nextPut: $!!].

	type == #classComment
		ifTrue:
			[f nextPut: $!!.
			f nextChunkPut: class asString, ' commentStamp: ', stamp storeString.
			f cr].

	f nextChunkPut: self string.
	type == #method ifTrue: [f nextChunkPut: ' '].
	f cr! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/24/1999 15:27'!
headerFor: selector

	^ '    ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
				, selector
				, (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])! !

!ChangeRecord methodsFor: 'access'!
isMetaClassChange
	^meta! !

!ChangeRecord methodsFor: 'access'!
methodClass 
	| methodClass |
	type == #method ifFalse: [^ nil].
	(Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
	methodClass _ Smalltalk at: class asSymbol.
	meta ifTrue: [^ methodClass class]
		ifFalse: [^ methodClass]! !

!ChangeRecord methodsFor: 'access'!
methodClassName
	^class! !

!ChangeRecord methodsFor: 'access'!
methodSelector
	type == #method ifFalse: [^ nil].
	^ Parser new parseSelector: self string! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/21/1999 20:34'!
readStamp
	"Get the time stamp of this method off the file"

	| item tokens anIndex |
	stamp _ ''.
	file ifNil: [^ stamp].
	file position: position.
	item _ file nextChunk.
	tokens _ Scanner new scanTokens: item.
	tokens size < 3 ifTrue: [^ stamp].
	anIndex _ tokens indexOf: #stamp: ifAbsent: [^ stamp].
	^ stamp _ tokens at: (anIndex + 1).
! !

!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'!
stamp
	^ stamp! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 9/7/2000 15:09'!
stamp: threePartString

	stamp _ threePartString! !

!ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'!
string 
	| string |
	file openReadOnly.
	file position: position.
	string _ file nextChunk.
	file close.
	^ string! !

!ChangeRecord methodsFor: 'access' stamp: 'tk 6/23/1999 08:20'!
text
	| text |
	^ file ifNil: ['']
		ifNotNil: [
			file openReadOnly.
			file position: position.
			text _ file nextChunkText.
			file close.
			text]! !

!ChangeRecord methodsFor: 'access'!
type
	^ type! !


!ChangeRecord methodsFor: 'initialization' stamp: 'tk 6/24/1999 14:51'!
class: clsName category: cat method: method sourceFiles: fileArray
	"This should be enough to find all the information for a method, or method deletion"

	file _ fileArray at: method fileIndex.
	position _ method filePosition.
	type _ #method.
	class _ clsName copyUpTo: $ .	"the non-meta part of a class name"
	category _ cat.
	meta _ clsName endsWith: ' class'.
	self readStamp.! !

!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
	file _ f.
	position _ p.
	type _ t! !

!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'!
file: f position: p type: t class: c category: cat meta: m stamp: s
	self file: f position: p type: t.
	class _ c.
	category _ cat.
	meta _ m.
	stamp _ s! !
Object subclass: #ChangeSet
	instanceVariableNames: 'name preamble postscript revertable isolationSet isolatedProject changeRecords structures superclasses '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeSet commentStamp: '<historical>' prior: 0!
ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut").  Every project has an associated changeSet.  For simple projects, a different changeSet may be designated to capture changes at any time.

This implementation of ChangeSet is capable of remembering and manipulating methods for which the classes are not present in the system.  However at the present time, this capability is not used in normal rearranging and fileOuts, but only for invoking and revoking associated with isolation layers.

For isolated projects (see Project class comment), the changeSet binding is semi-permanent.  Every project exists in an isolation layer defined by its closest enclosing parent (or itself) that is isolated.  If a project is not isolated, then changes reported to its designated changeSet must also be reported to the permanent changeSet for that layer, designated in the isolated project.  This ensures that that outer project will be able to revert all changes upon exit.

Note that only certain changes may be reverted.  Classes may not be added, removed, renamed or reshaped except in the layer in which they are defined because these operations on non-local classes are not revertable.

If a Squeak Project is established as being isolated, then its associated changeSet will be declared to be revertable.  In this case all changes stored can be reverted.  The changeSet associated with an isolated project is tied to that project, and cannot be edited in a changeSorter.
------

name - a String used to name the changeSet, and thus any associated project or fileOut.

preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.

revertable - a Boolean
If this variable is true, then all of the changes recorded by this changeSet can be reverted.

isolationSet - a ChangeSet or nil
The isolationSet is the designated changeSet for an isolation layer.  If this changeSet is an isolationSet, then this variable will be nil.  If not, then it points to the isolationSet for this layer, and all changes reported here will also be reported to the isolationSet.

isolatedProject - a Project or nil
If this is an isolationSet, then this variable points to the project with which it is associated.

changeRecords -  Dictionary {class name -> a ClassChangeRecord}.
These classChangeRecords (qv) remember all of the system changes.

structures -    Dictionary {#Rectangle -> #(<classVersionInteger> 'origin' 'corner')}.
Of  the names of the instances variables before any changes for all classes in classChanges, and all of their superclasses.  In the same format used in SmartRefStream.  Inst var names are strings.  

superclasses -    Dictionary {#Rectangle -> #Object}.
Of all classes in classChanges, and all of their superclasses.

Structures and superclasses save the instance variable names of this class and all of its superclasses.  Later we can tell how it changed and write a conversion method.  The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp).

NOTE:  It should be fairly simple, by adding a bit more information to the classChangeRecords, to reconstruct the information now stored in 'structures' and 'superclasses'.  This would be a welcome simplification.
!


!ChangeSet methodsFor: 'initialize-release' stamp: 'di 3/29/2000 20:42'!
beIsolationSetFor: aProject

	self isEmpty ifFalse: [self error: 'Must be empty at the start.'].
	isolatedProject _ aProject.
	revertable _ true.! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/1/2000 12:00'!
clear 
	"Reset the receiver to be empty.  "

	changeRecords _ Dictionary new.
	preamble _ nil.
	postscript _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/3/2000 14:46'!
initialize 
	"Reset the receiver to be empty."

	revertable _ false.
	self clear.
 	"Avoid duplicate entries in AllChanges if initialize gets called twice"
	name _ ChangeSet defaultName.
! !

!ChangeSet methodsFor: 'initialize-release'!
isMoribund
	"Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter.  2/7/96 sw"

	^ name == nil ! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 3/6/1999 09:31'!
veryDeepCopyWith: deepCopier
	"Return self; this is NOT the way to launch new change sets!! Having this method here allows Change Sorters to be in parts bins"! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 3/23/2000 12:14'!
wither
	"The receiver is to be clobbered.  Clear it out.  2/7/96 sw"

	self clear.
	name _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 9/21/2000 15:29'!
zapHistory 
	"Much stronger than trimHistory, but it should still leave the changeSet in good shape.
	Must not be done on revertable changeSets
		ChangeSet allInstancesDo: [:cs | cs zapHistory]."

	revertable ifTrue: [^ self].  "No can do"
	changeRecords do: [:chgRecord | chgRecord zapHistory]! !


!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 13:10'!
addClass: class 
	"Include indication that a new class was created."

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet addClass: class].
	self atClass: class add: #new.
	self atClass: class add: #change.
	self addCoherency: class name! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 13:08'!
changeClass: class from: oldClass
	"Remember that a class definition has been changed.  Record the original structure, so that a conversion method can be built."

	class wantsChangeSetLogging ifFalse: [^ self]. 
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet changeClass: class from: oldClass].
	self atClass: class add: #change.
	self addCoherency: class name.
	(self changeRecorderFor: class) notePriorDefinition: oldClass.
	self noteClassStructure: oldClass! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 11:08'!
noteNewMethod: newMethod forClass: class selector: selector priorMethod: methodOrNil

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet noteNewMethod: newMethod forClass: class selector: selector
				priorMethod: methodOrNil].
	(self changeRecorderFor: class)
		noteNewMethod: newMethod selector: selector priorMethod: methodOrNil
! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 3/29/2000 12:29'!
removeSelector: selector class: class priorMethod: priorMethod lastMethodInfo: info
	"Include indication that a method has been forgotten.
	info is a pair of the source code pointer and message category
	for the method that was removed."

	class wantsChangeSetLogging ifFalse: [^ self].
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet removeSelector: selector class: class
				priorMethod: priorMethod lastMethodInfo: info].
	(self changeRecorderFor: class)
		noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: info
! !

!ChangeSet methodsFor: 'change logging' stamp: 'di 5/8/2000 20:40'!
renameClass: class as: newName 
	"Include indication that a class has been renamed."

	| recorder |
	isolationSet ifNotNil:
		["If there is an isolation layer above me, inform it as well."
		isolationSet renameClass: class as: newName].
	(recorder _ self changeRecorderFor: class)
		noteChangeType: #rename;
		noteNewName: newName asSymbol.
		
	"store under new name (metaclass too)"
	changeRecords at: newName put: recorder.
	changeRecords removeKey: class name.

	recorder _ changeRecords at: class class name ifAbsent: [^ nil].
	changeRecords at: (newName, ' class') put: recorder.
	changeRecords removeKey: class class name.
	recorder noteNewName: newName , ' class'! !


!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:25'!
compileAll: newClass from: oldClass
	"If I have changes for this class, recompile them"

	(changeRecords at: newClass ifAbsent: [^ self])
		compileAll: newClass from: oldClass
! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'!
invoke

	"Do the first part of the invoke operation -- no particular hurry."
	changeRecords do: [:changeRecord | changeRecord invokePhase1].

	"Complete the invoke process -- this must be very simple."
	"Replace method dicts for any method changes."
	changeRecords do: [:changeRecord | changeRecord invokePhase2].
	Behavior flushCache.

! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 4/13/2000 12:47'!
isolatedProject
	"Return the isolated project for which I am the changeSet."

	^ isolatedProject! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 13:59'!
isolationSet: setOrNil

	setOrNil == self
		ifTrue: [isolationSet _ nil]  "Means this IS the isolation set"
		ifFalse: [isolationSet _ setOrNil]! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:47'!
revoke

	"Do the first part of the revoke operation -- this must be very simple."
	"Replace original method dicts if there are method changes."
	changeRecords do: [:changeRecord | changeRecord revokePhase1].
	Behavior flushCache.

	"Complete the revoke process -- no particular hurry."
	changeRecords do: [:changeRecord | changeRecord revokePhase2].
! !

!ChangeSet methodsFor: 'isolation layers' stamp: 'di 3/23/2000 12:00'!
uninstall

	self halt.
! !


!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'!
classRemoves

	^ changeRecords keys select:
		[:className | (changeRecords at: className) isClassRemoval]! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 4/8/2000 23:16'!
editPostscript
	"edit the receiver's postscript, in a separate window.  "

	| deps found |
	self assurePostscriptExists.
	deps _ postscript dependents select:
		[:m | (m isKindOf: SystemWindow) or:
			[m isKindOf: StandardSystemView]].
	deps size > 0 ifTrue:
		[Smalltalk isMorphic
			ifTrue:
				[found _ deps detect: [:obj | (obj isKindOf: SystemWindow) and: [obj world == self currentWorld]] ifNone: [nil].
				found ifNotNil:  [^ found activate]]
			ifFalse:
				[found _ deps detect: [:obj | (obj isKindOf: StandardSystemView) and: [ScheduledControllers scheduledControllers includes: obj controller]] ifNone: [nil].
				found ifNotNil: [^ ScheduledControllers activateController: found controller]].
.
		self inform:
'Caution -- there', (deps size isOrAreStringWith: 'other window'), '
already open on this postscript elsewhere'].

	postscript openLabel: 'Postscript for ChangeSet named ', name! !

!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:44'!
hasPostscript
	^ postscript notNil! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'!
methodChanges

	| methodChangeDict changeTypes |
	methodChangeDict _ Dictionary new.
	changeRecords associationsDo:
		[:assn |
		changeTypes _ assn value methodChangeTypes.
		changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]].
	^ methodChangeDict! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 3/29/2000 16:22'!
methodInfoFromRemoval: classAndSelector

	^ (self changeRecorderFor: classAndSelector first)
		infoFromRemoval: classAndSelector last! !

!ChangeSet methodsFor: 'accessing'!
name
	"The name of this changeSet.
	 2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

	^ name == nil
		ifTrue:
			['<no name -- garbage?>']
		ifFalse:
			[name]! !

!ChangeSet methodsFor: 'accessing'!
name: anObject
	name _ anObject! !

!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 20:51'!
postscriptHasDependents
	^ postscript dependents size > 0! !

!ChangeSet methodsFor: 'accessing'!
printOn: aStream
	"2/7/96 sw: provide the receiver's name in the printout"
	super printOn: aStream.
	aStream nextPutAll: ' named ', self name! !

!ChangeSet methodsFor: 'accessing' stamp: 'MPW 1/1/1901 22:02'!
printOnStream: aStream
	"2/7/96 sw: provide the receiver's name in the printout"
	super printOnStream: aStream.
	aStream print: ' named ', self name! !

!ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'!
removePostscript
	postscript _ nil! !

!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'!
structures
	^structures! !

!ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'!
superclasses
	^superclasses! !


!ChangeSet methodsFor: 'testing' stamp: 'RAA 10/1/2000 12:28'!
belongsToAProject

	Smalltalk at: #Project ifPresent:
		[:projClass | projClass allProjects do:
			[:proj | proj projectChangeSet == self ifTrue: [^ true]]].
	^ false! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 11/13/2000 17:15'!
correspondingProject
	"If the receiver is the current change set for any project, answer it, else answer nil"

	^Project allProjects 
		detect: [ :proj |
			proj projectChangeSet == self
		]
		ifNone: [nil]

! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 10/19/2000 13:17'!
isEmpty
	"Answer whether the receiver contains any elements."
	
	changeRecords ifNil: [^true].
	^ changeRecords isEmpty ! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'!
okayToRemove
	^ self okayToRemoveInforming: true! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'!
okayToRemoveInforming: aBoolean
	"Answer whether it is okay to remove the receiver.  If aBoolean is true, inform the receiver if it is not okay"

	| aName |
	aName _ self name.
	self == Smalltalk changes ifTrue:
		[aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '"
because it is the 
current change set.'].
		^ false].

	self belongsToAProject ifTrue:
		[aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" 
because it belongs to a 
project.'].
			^ false].

	^ true
! !

!ChangeSet methodsFor: 'testing' stamp: 'RAA 9/27/2000 22:40'!
projectsBelongedTo
	"Answer a list of all the projects for which the receiver is the current change set"

	^ Project allProjects select: [:proj | proj projectChangeSet == self]
! !


!ChangeSet methodsFor: 'converting' stamp: 'RAA 12/20/2000 16:02'!
convertApril2000: varDict using: smartRefStrm
	| cls info selector pair classChanges methodChanges methodRemoves classRemoves |
	"These variables are automatically stored into the new instance:
		('name' 'preamble' 'postscript' 'structures' 'superclasses' ).
	This method is for additional changes.
	It initializes the isolation variables, and then duplicates the logic fo
		assimilateAllChangesFoundIn:."

	revertable _ false.
	isolationSet _ nil.
	isolatedProject _ nil.
	changeRecords _ Dictionary new.

	classChanges _ varDict at: 'classChanges'.
	classChanges keysDo:
		[:className |
	  	(cls _ Smalltalk classNamed: className) ifNotNil:
			[info _ classChanges at: className ifAbsent: [Set new].
			info do: [:each | self atClass: cls add: each]]].

	methodChanges _ varDict at: 'methodChanges'.
	methodRemoves _ varDict at: 'methodRemoves'.
	methodChanges keysDo:
		[:className |
	  	(cls _ Smalltalk classNamed: className) ifNotNil:
			[info _ methodChanges at: className ifAbsent: [Dictionary new].
			info associationsDo:
				[:assoc | selector _ assoc key.
				(assoc value == #remove or: [assoc value == #addedThenRemoved])
					ifTrue:
						[assoc value == #addedThenRemoved
							ifTrue: [self atSelector: selector class: cls put: #add].
						pair _ methodRemoves at: {cls name. selector} ifAbsent: [nil] .
						self removeSelector: selector class: cls priorMethod: nil lastMethodInfo: pair]
					ifFalse: 
						[self atSelector: selector class: cls put: assoc value]]]].

	classRemoves _ varDict at: 'classRemoves'.
	classRemoves do:
		[:className | self noteRemovalOf: className].

! !

!ChangeSet methodsFor: 'converting' stamp: 'RAA 12/20/2000 17:57'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"major change - 4/4/2000"
	varDict at: 'classChanges' ifPresent: [ :x | 
		self convertApril2000: varDict using: smartRefStrm
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!ChangeSet methodsFor: 'method changes' stamp: 'sw 12/28/2000 18:08'!
adoptSelector: aSelector forClass: aClass
	"Adopt the given selector/class combination as a change in the receiver"

	self noteNewMethod: (aClass methodDictionary at: aSelector)
			forClass: aClass selector: aSelector priorMethod: nil! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 3/29/2000 11:01'!
atSelector: selector class: class put: changeType

	(selector == #DoIt or: [selector == #DoItIn:]) ifTrue: [^ self].
	(self changeRecorderFor: class) atSelector: selector put: changeType.
! !

!ChangeSet methodsFor: 'method changes' stamp: 'sw 10/19/1999 15:01'!
browseMessagesWithPriorVersions
	"Open a message list browser on the new and changed methods in the receiver which have at least one prior version.  6/28/96 sw"

	| aList aSelector aClass |

	aList _ self changedMessageListAugmented select:
		[:msg |  Utilities setClassAndSelectorFrom: msg in: 
				[:cl :sl | aClass _ cl.  aSelector _ sl].
			(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1].
	aList size > 0 ifFalse: [self inform: 'None!!'.  ^ nil].
	Smalltalk browseMessageList: aList name: (self name, ' methods that have prior versions')! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'!
changedMessageList
	"Used by a message set browser to access the list view information."

	| messageList |
	messageList _ SortedCollection new.
	changeRecords associationsDo: 
		[:clAssoc | 
		clAssoc value methodChangeTypes associationsDo: 
			[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
				[messageList add: clAssoc key asString, ' ' , mAssoc key]]].
	^ messageList asArray! !

!ChangeSet methodsFor: 'method changes' stamp: 'tk 6/7/1999 18:57'!
changedMessageListAugmented
	"Even added classes have all messages in changedMessageList."
	^ self changedMessageList asArray! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'!
methodChangesAtClass: className
	"Return an old-style dictionary of method change types."

	^(changeRecords at: className ifAbsent: [^ Dictionary new])
		methodChangeTypes! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 4/4/2000 11:14'!
removeSelectorChanges: selector class: class 
	"Remove all memory of changes associated with the argument, selector, in 
	this class."

	| chgRecord |
	(chgRecord _ changeRecords at: class name ifAbsent: [^ self])
		removeSelector: selector.
	chgRecord hasNoChanges ifTrue: [changeRecords removeKey: class name]! !

!ChangeSet methodsFor: 'method changes' stamp: 'SqR 6/13/2000 19:16'!
selectorsInClass: aClassName
	"Used by a ChangeSorter to access the list methods."

	^ (changeRecords at: aClassName ifAbsent: [^#()]) changedSelectors! !


!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'!
changedClassNames
	"Answer a OrderedCollection of the names of changed or edited classes.
	DOES include removed classes.  Sort alphabetically."

	^ changeRecords keysSortedSafely ! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 3/23/2000 08:12'!
changedClasses
	"Answer an OrderedCollection of changed or edited classes.
	Does not include removed classes.  Sort alphabetically by name."

	"Much faster to sort names first, then convert back to classes.  Because metaclasses reconstruct their name at every comparison in the sorted collection.
	8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames"

	^ self changedClassNames
		collect: [:className | Smalltalk classNamed: className]
		thenSelect: [:aClass | aClass notNil]! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'!
classChangeAt: className
	"Return what we know about class changes to this class."

	^ (changeRecords at: className ifAbsent: [^ Set new])
		allChangeTypes! !

!ChangeSet methodsFor: 'class changes'!
commentClass: class 
	"Include indication that a class comment has been changed."

	self atClass: class add: #comment! !

!ChangeSet methodsFor: 'class changes' stamp: 'RAA 6/16/2000 15:13'!
fatDefForClass: class

	| newDef oldDef oldStrm newStrm outStrm oldVars newVars addedVars |
	newDef _ class definition.
	oldDef _ (self changeRecorderFor: class) priorDefinition.
	oldDef ifNil: [^ newDef].
	oldDef = newDef ifTrue: [^ newDef].

	oldStrm _ ReadStream on: oldDef.
	newStrm _ ReadStream on: newDef.
	outStrm _ WriteStream on: (String new: newDef size * 2).

	"Merge inst vars from old and new defs..."
	oldStrm upToAll: 'instanceVariableNames'; upTo: $'.
	outStrm 
		nextPutAll: (newStrm upToAll: 'instanceVariableNames'); 
		nextPutAll: 'instanceVariableNames:'.
	newStrm peek = $: ifTrue: [newStrm next].	"may or may not be there, but already written"
	outStrm
		nextPutAll: (newStrm upTo: $'); nextPut: $'.
	oldVars _ (oldStrm upTo: $') findTokens: Character separators.
	newVars _ (newStrm upTo: $') findTokens: Character separators.
	addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection.
	oldVars , addedVars do: [:var | outStrm nextPutAll: var; space].
	outStrm nextPut: $'.

	class isMeta ifFalse:
		["Merge class vars from old and new defs..."
		oldStrm upToAll: 'classVariableNames:'; upTo: $'.
		outStrm nextPutAll: (newStrm upToAll: 'classVariableNames:'); nextPutAll: 'classVariableNames:';
			nextPutAll: (newStrm upTo: $'); nextPut: $'.
		oldVars _ (oldStrm upTo: $') findTokens: Character separators.
		newVars _ (newStrm upTo: $') findTokens: Character separators.
		addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection.
		oldVars , addedVars do: [:var | outStrm nextPutAll: var; space].
		outStrm nextPut: $'].

	outStrm nextPutAll: newStrm upToEnd.
	^ outStrm contents
! !

!ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 19:54'!
noteClassForgotten: className
	"Remove from structures if class is not a superclass of some other one we are remembering"

	structures ifNil: [^ self].
	Smalltalk at: className ifPresent: [:cls |
		cls subclasses do: [:sub | (structures includesKey: sub) ifTrue: [
			^ self]]].  "No delete"
	structures removeKey: className ifAbsent: [].! !

!ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 21:51'!
noteClassStructure: aClass
	"Save the instance variable names of this class and all of its superclasses.  Later we can tell how it changed and write a conversion method.  The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp)."

	| clsName |
	aClass ifNil: [^ self].
	structures ifNil: [structures _ Dictionary new.
				superclasses _ Dictionary new].
	clsName _ (aClass name asLowercase beginsWith: 'anobsolete') 
		ifTrue: [(aClass name copyFrom: 11 to: aClass name size) asSymbol]
		ifFalse: [aClass name].
	(structures includesKey: clsName) ifFalse: [
		structures at: clsName put: 
			((Array with: aClass classVersion), (aClass allInstVarNames)).
		superclasses at: clsName put: aClass superclass name].
	"up the superclass chain"
	aClass superclass ifNotNil: [self noteClassStructure: aClass superclass].
! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 23:17'!
noteRemovalOf: class
	"The class is about to be removed from the system.
	Adjust the receiver to reflect that fact."

	(self changeRecorderFor: class)
		noteChangeType: #remove fromClass: class.
	changeRecords removeKey: class class name ifAbsent: [].! !

!ChangeSet methodsFor: 'class changes'!
reorganizeClass: class 
	"Include indication that a class was reorganized."

	self atClass: class add: #reorganize! !

!ChangeSet methodsFor: 'class changes' stamp: 'di 5/16/2000 09:03'!
trimHistory 
	"Drop non-essential history:  methods added and then removed, as well as rename and reorganization of newly-added classes."

	changeRecords do: [:chgRecord | chgRecord trimHistory]! !


!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 09:37'!
absorbClass: className from: otherChangeSet
	"Absorb into the receiver all the changes found in the class in the other change set.
	*** Classes renamed in otherChangeSet may have problems"

	| cls |
	(self changeRecorderFor: className)
			assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className).

	(cls _ Smalltalk classNamed: className) ifNotNil:
		[self absorbStructureOfClass: cls from: otherChangeSet].
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 3/23/2000 11:52'!
absorbMethod: selector class: aClass from: aChangeSet
	"Absorb into the receiver all the changes for the method in the class in the other change set."

	| info |
	info _ aChangeSet methodChanges at: aClass name ifAbsent: [Dictionary new].
	self atSelector: selector class: aClass put: (info at: selector).

! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 1/30/2001 15:41'!
absorbStructureOfClass: aClass from: otherChangeSet
	"Absorb into the receiver all the structure and superclass info in the other change set.  Used to write conversion methods."

	| sup next |
	otherChangeSet structures ifNil: [^ self].
	(otherChangeSet structures includesKey: aClass name) ifFalse: [^ self].
	structures ifNil:
		[structures _ Dictionary new.
		superclasses _ Dictionary new].
	sup _ aClass name.
	[(structures includesKey: sup) 
		ifTrue: ["use what is here" true]
		ifFalse: [self flag: #noteToDan.  "sw 1/30/2001 13:57 emergency workaround -- a case arose where the otherChangeSet's structures did not have the key, and it gummed up the works."
				(otherChangeSet structures includesKey: sup) ifTrue:
					[structures at: sup put: (otherChangeSet structures at: sup)].
				next _ otherChangeSet superclasses at: sup.
				superclasses at: sup put: next.
				(sup _ next) = 'nil']
	] whileFalse.


! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:21'!
assimilateAllChangesFoundIn: otherChangeSet
	"Make all changes in otherChangeSet take effect on self as if they happened just now."

	otherChangeSet changedClassNames do:
		[:className | self absorbClass: className from: otherChangeSet]
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/8/2000 23:16'!
editPreamble
	"edit the receiver's preamble, in a separate window.  "

	self assurePreambleExists.
	preamble openLabel: 'Preamble for ChangeSet named ', name! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:49'!
expungeEmptyClassChangeEntries

	changeRecords keysAndValuesRemove:
		[:className :classRecord | classRecord hasNoChanges]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 4/19/2000 16:17'!
expungeUniclasses

	changeRecords keysAndValuesRemove:
		[:className :classRecord | className endsWithDigit]! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:40'!
forgetAllChangesFoundIn: otherChangeSet
	"Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets.  To use:  in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner."

	otherChangeSet == self ifTrue: [^ self].
	otherChangeSet changedClassNames do:
		[:className | self forgetChangesForClass: className in: otherChangeSet].
	self expungeEmptyClassChangeEntries.

"  Old code...
	aChangeSet changedClassNames do: 
		[:className |
			(cls _ Smalltalk classNamed: className) ~~ nil ifTrue:
				[itsMethodChanges _ aChangeSet methodChanges at: className 
						ifAbsent: [Dictionary new].
				itsMethodChanges associationsDo: [:assoc | 
					self forgetChange: assoc value forSelector: assoc key class: cls].
				myClassChange _ self classChangeAt: className.
				myClassChange size > 0 ifTrue:
					[(aChangeSet classChangeAt: className) do:
						[:aChange | myClassChange remove: aChange ifAbsent: []]].
				self noteClassForgotten: className]].

	aChangeSet classRemoves do:
		[:className | (recorder _ changeRecords at: className ifAbsent: [])
			ifNotNil: [recorder forgetClassRemoval]].
	self expungeEmptyClassChangeEntries
"
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:04'!
forgetChangesForClass: className in: otherChangeSet
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	(self changeRecorderFor: className)
			forgetChangesIn: (otherChangeSet changeRecorderFor: className).
	self noteClassForgotten: className
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'!
hasPreamble
	^ preamble notNil! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 10/29/2000 17:39'!
methodsWithInitialsOtherThan: myInits
	"Return a collection of method refs whose author appears to be different from the given one"
	| slips method aTimeStamp |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
					method ifNotNil:
						[((aTimeStamp _ Utilities timeStampForMethod: method) notNil and:
							[(aTimeStamp beginsWith: myInits) not])
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips

	"Smalltalk browseMessageList: (Smalltalk changes methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 10/30/2000 08:42'!
methodsWithoutComments
	"Return a collection representing methods in the receiver which have no comments"

	| slips |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[(aClass selectors includes:  mAssoc key) ifTrue:
						[(aClass firstCommentAt: mAssoc key) isEmptyOrNil
								ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips

	"Smalltalk browseMessageList: (Smalltalk changes methodsWithoutComments) name: 'methods lacking comments'"! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'!
removeClassAndMetaClassChanges: class
	"Remove all memory of changes associated with this class and its metaclass.  7/18/96 sw"

	changeRecords removeKey: class name ifAbsent: [].
	changeRecords removeKey: class class name ifAbsent: [].
! !

!ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'!
removeClassChanges: class
	"Remove all memory of changes associated with this class"
	| cname |
	(class isKindOf: String)
		ifTrue: [ cname _ class ]
		ifFalse: [ cname _ class name ].

	changeRecords removeKey: cname ifAbsent: [].
	self noteClassForgotten: cname.! !

!ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'!
removePreamble
	preamble _ nil! !


!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/11/1998 16:13'!
assurePostscriptExists
	"Make sure there is a StringHolder holding the postscript.  "

	"NOTE: FileIn recognizes the postscript by the line with Postscript: on it"
	postscript == nil ifTrue: [postscript _ StringHolder new contents: '"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 4/7/1999 17:45'!
assurePreambleExists
	"Make sure there is a StringHolder holding the preamble; if it's found to have reverted to empty contents, put up the template"

	(preamble == nil or: [preamble contents isEmptyOrNil])
		ifTrue: [preamble _ StringHolder new contents: self preambleTemplate]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 1/27/2001 22:30'!
checkForAlienAuthorship
	"Check to see if there are any methods in the receiver that have author initials other than that of the current author, and open a browser on all found"

	| aList initials |
	(initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image'].
	(aList _ self methodsWithInitialsOtherThan: initials) size > 0
		ifFalse:
			[^ self inform: 'All methods in "', self name, '"
have authoring stamps which start with "', initials, '"']
		ifTrue:
			[Smalltalk browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', initials, '"']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'ls 10/10/1999 11:37'!
checkForConversionMethods
	"See if any conversion methods are needed"

	| needConversion oldList newList tell choice list need oldVer newVer
sel smart restore |
	"Check preference"
	Preferences conversionMethodsAtFileOut ifFalse: [^ self].
	structures ifNil: [^ self].

	needConversion _ false.
	list _ OrderedCollection new.
	smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345').
	self changedClasses do: [:class |
		need _ (self atClass: class includes: #new) not.
		need ifTrue: [
			"Also consider renamed classes."
			(self atClass: class includes: #rename) ifTrue: [
				needConversion _ true.  list add: class].
			need _ (self atClass: class includes: #change)].
		need ifTrue: [oldList _ structures at: class name 
								ifAbsent: [need _ false.  #()]].
		need ifTrue: [
			newList _ (Array with: class classVersion), (class allInstVarNames).
			need _ (oldList ~= newList)].
		need ifTrue: [
			oldVer _ smart versionSymbol: oldList.
			newVer _ smart versionSymbol: newList.
			sel _ 'convert',oldVer,':',newVer, ':'.	
			(Symbol hasInterned: sel ifTrue: [:ignored |]) ifFalse: [
				need _ false.
				needConversion _ true.
				list add: class]].
		need ifTrue: [sel _ sel asSymbol.
			(#(add change) includes: (self atSelector: sel class: class))
ifFalse: [
				needConversion _ true.
				list add: class]].
		].

	needConversion ifTrue: ["Ask user if want to do this"
		tell _ 'If there might be instances of ', list asArray printString,
		'\in a file full of objects on someone''s disk, please fill in
conversion methods.\'
			withCRs,
		'After you edit the methods, you''ll have to fileOut again.\' withCRs,
		'The preference conversionMethodsAtFileOut controls this feature.'.
		choice _ (PopUpMenu labels: 
'Write a conversion method by editing a prototype
These classes are not used in any object file.  fileOut my changes now.
I''m too busy.  fileOut my changes now.
Don''t ever ask again.  fileOut my changes now.') startUpWithCaption:
tell. 
		choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut].
		choice = 2 ifTrue: [
				list do: [:cls | cls withAllSubclassesDo: [:ccc | 
						structures removeKey: ccc name ifAbsent: []]]].
		choice ~= 1 ifTrue: [^ self]].

	list isEmpty ifTrue: [^ self].
	smart structures: structures.	"we will test all classes in structures."
	smart superclasses: superclasses.
	(restore _ Smalltalk changes) == self ifFalse: [
		Smalltalk newChanges: self].
	[smart verifyStructure = 'conversion method needed'] whileTrue.
		"new method is added to changeSet.  Then filed out with the rest."
	restore == self ifFalse: [Smalltalk newChanges: restore].
	"tell 'em to fileout again after modifying methods."
	self inform: 'Remember to fileOut again after modifying these
methods.'.! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/26/2000 10:06'!
checkForSlips
	"Return a collection of method refs with possible debugging code in them."
	| slips method |
	slips _ OrderedCollection new.
	self changedClasses do:
		[:aClass |
		(self methodChangesAtClass: aClass name) associationsDo: 
				[:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
					[method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
					method ifNotNil:
						[method hasReportableSlip
							ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]].
	^ slips! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 10/30/2000 10:44'!
checkForUncommentedMethods
	| aList |
	"Check to see if there are any methods in the receiver that have no comments, and open a browser on all found"

	(aList _ self methodsWithoutComments) size > 0
		ifFalse:
			[^ self inform: 'All methods in "', self name, '" have comments']
		ifTrue:
			[Smalltalk browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 12/14/2000 10:59'!
checkForUnsentMessages
	"Check the change set for unsent messages, and if any are found, open up a message-list browser on them"

	| nameLine allChangedSelectors augList unsent messageList |
	nameLine _ '"', self name, '"'.
	allChangedSelectors _ Set new.
	(augList _ self changedMessageListAugmented) do:
		[:aChange |
			MessageSet parse: aChange toClassAndSelector: [:cls :sel | (cls notNil and:
				[cls includesSelector: sel]) ifTrue: [allChangedSelectors add: sel]]].

	unsent _ Smalltalk allUnSentMessagesIn: allChangedSelectors.
	unsent size = 0
		ifTrue:
			[self inform: 'There are no unsent 
messages in change set
', nameLine]
		ifFalse:
			[messageList _ augList select:
				[:aChange |
					MessageSet parse: aChange toClassAndSelector:
						[:cls :sel | unsent includes: sel]].

			Smalltalk browseMessageList: messageList name: 'Unsent messages in ', nameLine]
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'dew 8/26/2000 21:45'!
chooseSubjectPrefixForEmail

	| subjectIndex |

	subjectIndex _
		(PopUpMenu labels: 'Bug fix [FIX]\Enhancement [ENH]\Goodie [GOODIE]\None of the above (will not be archived)' withCRs)
			startUpWithCaption: 'What type of change set\are you submitting to the list?' withCRs.

	^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[CS] ') at: subjectIndex + 1! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 10/27/2000 08:22'!
fileOut
	"File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'sequentialChangeSetRevertableFileNames'"

	| file slips nameToUse |
	self checkForConversionMethods.
	nameToUse _ Preferences changeSetVersionNumbers
		ifTrue:
			[FileDirectory default nextNameFor: self name extension: 'cs']
		ifFalse:
			[(self name, FileDirectory dot, Utilities dateTimeSuffix, 
				FileDirectory dot, 'cs') asFileName].
	Cursor write showWhile:
		[[file _ FileStream newFileNamed: nameToUse.
		file header; timeStamp.
		self fileOutPreambleOn: file.
		self fileOutOn: file.
		self fileOutPostscriptOn: file.
		file trailer] ensure: [file close]].

	Preferences checkForSlips ifFalse: [^ self].

	slips _ self checkForSlips.
	(slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2])
		ifTrue: [Smalltalk browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/28/2000 09:35'!
fileOutChangesFor: class on: stream 
	"Write out all the method changes for this class."

	| changes |
	changes _ Set new.
	(self methodChangesAtClass: class name) associationsDo: 
		[:mAssoc | (mAssoc value = #remove or: [mAssoc value = #addedThenRemoved])
			ifFalse: [changes add: mAssoc key]].
	changes isEmpty ifFalse: 
		[class fileOutChangedMessages: changes on: stream.
		stream cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 4/3/2000 14:46'!
fileOutOn: stream 
	"Write out all the changes the receiver knows about"

	| classList |
	(self isEmpty and: [stream isKindOf: FileStream])
		ifTrue: [self notify: 'Warning: no changes to file out'].
	classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection.

	"First put out rename, max classDef and comment changes."
	classList do: [:aClass | self fileOutClassDefinition: aClass on: stream].

	"Then put out all the method changes"
	classList do: [:aClass | self fileOutChangesFor: aClass on: stream].

	"Finally put out removals, final class defs and reorganization if any"
	classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream].

	self classRemoves asSortedCollection do:
		[:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 5/8/2000 20:47'!
fileOutPSFor: class on: stream 
	"Write out removals and initialization for this class."

	| dict changeType classRecord currentDef |
	classRecord _ changeRecords at: class name ifAbsent: [^ self].
	dict _ classRecord methodChangeTypes.
	dict keysSortedSafely do:
		[:key | changeType _ dict at: key.
		(#(remove addedThenRemoved) includes: changeType)
			ifTrue: [stream nextChunkPut: class name,
						' removeSelector: ', key storeString; cr]
			ifFalse: [(key = #initialize and: [class isMeta]) ifTrue:
						[stream nextChunkPut: class soleInstance name, ' initialize'; cr]]].
	((classRecord includesChangeType: #change)
		and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue:
		[stream command: 'H3'; nextChunkPut: currentDef; cr; command: '/H3'].
	(classRecord includesChangeType: #reorganize) ifTrue:
		[class fileOutOrganizationOn: stream.
		stream cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 13:35'!
fileOutPostscriptOn: stream 
	"If the receiver has a postscript, put it out onto the stream.  "

	| aString |
	aString _ self postscriptString.
	(aString ~~ nil and: [aString size > 0])
		ifTrue:
			[stream nextChunkPut: aString "surroundedBySingleQuotes".
			stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 14:58'!
fileOutPreambleOn: stream 
	"If the receiver has a preamble, put it out onto the stream.  "

	| aString |
	aString _ self preambleString.
	(aString ~~ nil and: [aString size > 0])
		ifTrue:
			[stream nextChunkPut: aString "surroundedBySingleQuotes".
			stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 10/27/2000 08:21'!
lookForSlips
	"Scan the receiver for changes that the user may regard as slips to be remedied"

	| slips nameLine msg |
	nameLine _ '
"', self name, '"
'.
	(slips _ self checkForSlips) size == 0 ifTrue:
		[^ self inform: 'No slips detected in change set', nameLine].

	msg _ slips size == 1
		ifTrue:
			[ 'One method in change set', nameLine, 
'has a halt, reference to the Transcript,
and/or some other ''slip'' in it.
Would you like to browse it? ?']
		ifFalse:
			[ slips size printString,
' methods in change set', nameLine, 'have halts or references to the
Transcript or other ''slips'' in them.
Would you like to browse them?'].

	(PopUpMenu withCaption: msg chooseFrom: 'Ignore\Browse slips') = 2
		ifTrue: [Smalltalk browseMessageList: slips
							name: 'Possible slips in ', name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'dew 8/27/2000 14:25'!
mailOut
	"File out the receiver, to a file whose name is a function of the           
	change-set name and either of the date & time or chosen to have a
	unique numeric tag, depending on the preference
	'sequentialChangeSetRevertableFileNames'."

	| subjectPrefix slips messageStrm message compressBuffer compressStream data compressedStream compressTarget |
	(Smalltalk includesKey: #Celeste)
		ifFalse: [^ self notify: 'no mail reader present'].

	subjectPrefix _ self chooseSubjectPrefixForEmail.

	self checkForConversionMethods.
	Cursor write
		showWhile: 
			["Prepare the message"
			messageStrm _ WriteStream on: (String new: 30).
			messageStrm nextPutAll: 'From: ';
			 nextPutAll: Celeste userName;
			 cr;
			 nextPutAll: 'To: squeak@cs.uiuc.edu';
			 cr;
			 nextPutAll: 'Subject: ';
			 nextPutAll: subjectPrefix;
			 nextPutAll: name;
			 cr;
			 nextPutAll: 'from preamble:';
			 cr;
			 cr.
			self fileOutPreambleOn: messageStrm.
			"Prepare the gzipped data"
			message _ MailMessage from: messageStrm contents.
			message _ MailMessage from: message asMultipartText.
			data _ WriteStream on: String new.
			data header.
			self fileOutPreambleOn: data.
			self fileOutOn: data.
			self fileOutPostscriptOn: data.
			data trailer.
			data _ ReadStream on: data contents.
			compressBuffer _ ByteArray new: 1000.
			compressStream _ GZipWriteStream on: (compressTarget _ WriteStream on: (ByteArray new: 1000)).
			[data atEnd]
				whileFalse: [compressStream nextPutAll: (data nextInto: compressBuffer)].
			compressStream close.
			compressedStream _ ReadStream on: compressTarget contents asString.
			CelesteComposition
				openForCeleste: Celeste current 
				initialText: (message asTextEncodingNewPart: compressedStream named: name , '.cs.gz')].
	Preferences suppressCheckForSlips ifTrue: [^ self].
	slips _ self checkForSlips.
	(slips size > 0 and: [self confirm: 'Methods in this fileOut have halts
or references to the Transcript
or other ''slips'' in them.
Would you like to browse them?'])
		ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'RAA 10/19/2000 13:17'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	refStrm projectChangeSet == self ifTrue: [^ self].

	"try to write reference for me".
	^ DiskProxy 
		global: #ChangeSorter
		selector: #existingOrNewChangeSetNamed: 
		args: (Array with: self name)
"===
	refStrm replace: self with: nil.
	^ nil
==="
! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:16'!
postscriptString
	"Answer the string representing the postscript.  "

	^ postscript == nil
		ifTrue:
			[postscript]
		ifFalse:
			[postscript contents asString]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
postscriptString: aString
	"Establish aString as the new contents of the postscript.  "

	postscript _ StringHolder new contents: aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:08'!
preambleString
	"Answer the string representing the preamble"

	^ preamble == nil
		ifTrue:
			[preamble]
		ifFalse:
			[preamble contents asString]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
preambleString: aString
	"Establish aString as the new contents of the preamble.  "

	preamble _ StringHolder new contents: aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 9/10/1998 12:37'!
preambleTemplate
	"Answer a string that will form the default contents for a change set's preamble.
	Just a first stab at what the content should be."

	^ String streamContents: [:strm |
		strm nextPutAll: '"Change Set:'.  "NOTE: fileIn recognizes preambles by this string."
		strm tab;tab; nextPutAll: self name.
		strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString.
		strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Preferences defaultAuthorName.
		strm cr; cr; nextPutAll: '<your descriptive text goes here>"']
"Smalltalk changes preambleTemplate"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:33'!
summaryString
	"Answer the string summarizing this changeSet"

	^ self summaryStringDelta: 0
"
To summarize all recent changeSets on a file...
(FileStream newFileNamed: 'Summaries.txt') nextPutAll:
	(String streamContents:
		[:s | (ChangeSorter changeSetsNamedSuchThat:
			[:name | name first isDigit and: [name initialIntegerOrNil >= 948]])
			 do: [:cs | s nextPutAll: cs summaryString; cr]]);
		close

To list all changeSets with a certain string in the preamble...
	(FileStream newFileNamed: 'MyUpdates.txt') nextPutAll:
		(String streamContents:
			[:s | ChangeSorter gatherChangeSetRevertables do:
				[:cs | (cs preambleString notNil
					and: [cs preambleString includesSubString: 'Author Name'])
				 	ifTrue: [s nextPutAll: cs summaryString; cr]]]);
		close
"! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:27'!
summaryStringDelta: delta
	"Answer the string summarizing this changeSet"
	| ps s2 date author line intName |
	^ String streamContents:
		[:s |
		intName _ self name splitInteger.
		intName first isNumber
			ifTrue: [s nextPutAll: (intName first + delta) printString , intName last]
			ifFalse: [s nextPutAll: intName first  "weird convention of splitInteger"].
		(ps _ self preambleString)
			ifNil: [s cr]
			ifNotNil:
			[s2 _ ReadStream on: ps.
			s2 match: 'Date:'; skipSeparators.  date _ s2 upTo: Character cr.
			s2 match: 'Author:'; skipSeparators.  author _ s2 upTo: Character cr.
			s nextPutAll: ' -- '; nextPutAll: author; nextPutAll: ' -- '; nextPutAll: date; cr.
			[s2 atEnd] whileFalse:
				[line _ s2 upTo: Character cr.
				(line isEmpty or: [line = '"']) ifFalse: [s nextPutAll: line; cr]]]].
! !


!ChangeSet methodsFor: 'private' stamp: 'di 3/23/2000 08:37'!
addCoherency: className
	"SqR!! 19980923: If I recreate the class then don't remove it"

	(self changeRecorderFor: className)
		checkCoherence.
"
	classRemoves remove: className ifAbsent: [].
	(classChanges includesKey: className) ifTrue:
		[(classChanges at: className) remove: #remove ifAbsent: []]
"! !

!ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 14:40'!
atClass: class add: changeType

	(self changeRecorderFor: class)
		noteChangeType: changeType fromClass: class! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
atClass: class includes: changeType

	^(changeRecords at: class name ifAbsent: [^false])
		includesChangeType: changeType! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
atSelector: selector class: class

	^ (changeRecords at: class name ifAbsent: [^ #none])
		atSelector: selector ifAbsent: [^ #none]! !

!ChangeSet methodsFor: 'private' stamp: 'di 3/29/2000 20:46'!
changeRecorderFor: class

	| cname |
	(class isKindOf: String)
		ifTrue: [ cname _ class ]
		ifFalse: [ cname _ class name ].

	"Later this will init the changeRecords so according to whether they should be revertable."
	^ changeRecords at: cname
			ifAbsent: [^ changeRecords at: cname
							put: (ClassChangeRecord new initFor: cname revertable: revertable)]! !

!ChangeSet methodsFor: 'private' stamp: 'di 9/8/2000 11:28'!
fileOutClassDefinition: class on: stream 
	"Write out class definition for the given class on the given stream, if the class definition was added or changed."

	(self atClass: class includes: #rename) ifTrue:
		[stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr].

	(self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes"
		stream command: 'H3'; nextChunkPut: (self fatDefForClass: class); cr; command: '/H3'
	] ifFalse: [
		(self atClass: class includes: #add) ifTrue: [ "use current definition for add"
			stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3'
		].
	].

	(self atClass: class includes: #comment) ifTrue:
		[class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass.
		stream cr].

! !

!ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'!
oldNameFor: class

	^ (changeRecords at: class name) priorName! !

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

ChangeSet class
	instanceVariableNames: ''!

!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'SqR 11/14/2000 11:36'!
doWeFileOut: aClass given: aSet cache: cache
	| aClassAllSuperclasses aClassSoleInstanceAllSuperclasses |

	aClassAllSuperclasses _ cache at: aClass
		ifAbsent: [cache at: aClass put: aClass allSuperclasses asArray].
	(aSet includesAnyOf: aClassAllSuperclasses) ifTrue: [^false].
	aClass isMeta ifFalse: [^true].
	(aSet includes: aClass soleInstance) ifTrue: [^false].
	aClassSoleInstanceAllSuperclasses _ cache at: aClass soleInstance
		ifAbsent: [cache at: aClass soleInstance put: aClass soleInstance allSuperclasses asArray].
	(aSet includesAnyOf: aClassSoleInstanceAllSuperclasses) ifTrue: [^false].
	^true! !

!ChangeSet class methodsFor: 'fileIn/Out' stamp: 'SqR 11/14/2000 11:37'!
superclassOrder: classes
	"Arrange the classes in the collection, classes, in superclass order so the 
	classes can be properly filed in. Do it in sets instead of ordered collections.
	SqR 4/12/2000 22:04"

	| all list aClass inclusionSet aClassIndex cache |

	list _ classes copy. "list is indexable"
	inclusionSet _ list asSet. cache _ Dictionary new.
	all _ OrderedCollection new: list size.
	list size timesRepeat:
		[
			aClassIndex _ list findFirst: [:one | one isNil not and: 
				[self doWeFileOut: one given: inclusionSet cache: cache]].
			aClass _ list at: aClassIndex.
			all addLast: aClass.
			inclusionSet remove: aClass.
			list at: aClassIndex put: nil
		].
	^all! !


!ChangeSet class methodsFor: 'defaults' stamp: 'di 1/10/2001 12:03'!
defaultName
	| namesInUse try |
	namesInUse _ ChangeSorter gatherChangeSets collect: [:each | each name].
	1 to: 999999 do:
		[:i | try _ 'Unnamed' , i printString.
		(namesInUse includes: try) ifFalse: [^ try]]
! !

!ChangeSet class methodsFor: 'defaults' stamp: 'RAA 7/15/2000 18:38'!
uniqueNameLike: aString

	| namesInUse try |

	namesInUse _ ChangeSorter gatherChangeSets collect: [:each | each name].
	1 to: 999999 do: [:i |
		try _ aString , i printString.
		(namesInUse includes: try) ifFalse: [^ try]
	]! !
CodeHolder subclass: #ChangeSorter
	instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList '
	classVariableNames: 'AllChangeSets '
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ChangeSorter commentStamp: '<historical>' prior: 0!
I display a ChangeSet.  Two of me are in a DualChangeSorter.!


!ChangeSorter methodsFor: 'creation' stamp: 'sw 3/6/1999 09:33'!
morphicWindow
	"ChangeSorter new openAsMorph"
	|  window |

	myChangeSet ifNil: [self myChangeSet: Smalltalk changes]. 
	window _ (SystemWindow labelled: self labelString) model: self.
	self openAsMorphIn: window rect: (0@0 extent: 1@1).
	^ window
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sma 4/30/2000 09:29'!
open
	"ChangeSorterPluggable new open"
	| topView |
	Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph].

	topView _ StandardSystemView new.
	topView model: self.
	myChangeSet ifNil: [self myChangeSet: Smalltalk changes]. 
	topView label: self labelString.
	topView borderWidth: 1; minimumSize: 360@360.
	self openView: topView offsetBy: 0@0.
	topView controller open.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'sw 3/6/1999 09:34'!
openAsMorph
	"ChangeSorter new openAsMorph"
	^ self morphicWindow openInWorld.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'JW 2/2/2001 21:47'!
openAsMorphIn: window rect: rect
	"Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0."

	| csListHeight msgListHeight csMsgListHeight |
	contents _ ''.
	csListHeight _ 0.25.
	msgListHeight _ 0.25.
	csMsgListHeight _ csListHeight + msgListHeight.
	self addDependent: window.		"so it will get changed: #relabel"

	window addMorph: ((PluggableListMorphByItem on: self
				list: #changeSetList
				selected: #currentCngSet
				changeSelected: #showChangeSetNamed:
				menu: #changeSetMenu:shifted:
				keystroke: #changeSetListKey:from:)
			autoDeselect: false)
		frame: (((0@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #classList
				selected: #currentClassName
				changeSelected: #currentClassName:
				menu: #classMenu:shifted:
				keystroke: #classListKey:from:)
		frame: (((0.5@0 extent: 0.5@csListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	window addMorph: (PluggableListMorphByItem on: self
				list: #messageList
				selected: #currentSelector
				changeSelected: #currentSelector:
				menu: #messageMenu:shifted:
				keystroke: #messageListKey:from:)
		frame: (((0@csListHeight extent: 1@msgListHeight)
			scaleBy: rect extent) translateBy: rect origin).

	 self addLowerPanesTo: window
		at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin)
		with: nil.! !

!ChangeSorter methodsFor: 'creation' stamp: 'sw 1/24/2001 21:24'!
openView: topView offsetBy: offset
	"Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0."

	| classView messageView codeView cngSetListView basePane annoPane annoHeight |
	contents _ ''.
	annoHeight _ 20.
	self addDependent: topView. "so it will get changed: #relabel"

	cngSetListView _ PluggableListViewByItem on: self
		list: #changeSetList
		selected: #currentCngSet
		changeSelected: #showChangeSetNamed:
		menu: #changeSetMenu:shifted:
		keystroke: #changeSetListKey:from:.
	cngSetListView window: ((0@0 extent: 180@100) translateBy: offset).
	topView addSubView: cngSetListView.

	classView _ PluggableListViewByItem on: self
		list: #classList
		selected: #currentClassName
		changeSelected: #currentClassName:
		menu: #classMenu:shifted:
		keystroke: #classListKey:from:.
	classView window: ((0@0 extent: 180@100) translateBy: offset).
	topView addSubView: classView toRightOf: cngSetListView.

	messageView _ PluggableListViewByItem on: self
		list: #messageList
		selected: #currentSelector
		changeSelected: #currentSelector:
		menu: #messageMenu:shifted:
		keystroke: #messageListKey:from:.
	messageView menuTitleSelector: #messageListSelectorTitle.
	messageView window: ((0@0 extent: 360@100) translateBy: offset).
	topView addSubView: messageView below: cngSetListView.

	 self wantsAnnotationPane
		ifFalse:
			[basePane _ messageView]
		ifTrue:
			[annoPane _ PluggableTextView on: self
				text: #annotation
				accept: nil
				readSelection: nil
				menu: nil.
			annoPane window: ((0@0 extent: 360@annoHeight) translateBy: offset).
			topView addSubView: annoPane below: messageView.
			basePane _ annoPane].

	codeView _ PluggableTextView on: self 
		text: #contents
		accept: #contents:notifying:
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	codeView window: ((0 @ 0 extent: 360 @ 180) translateBy: offset).
	topView addSubView: codeView below: basePane.! !

!ChangeSorter methodsFor: 'creation' stamp: 'tk 12/7/1999 12:53'!
veryDeepFixupWith: deepCopier

	super veryDeepFixupWith: deepCopier.
	parent _ deepCopier references at: parent ifAbsent: [parent].
	self updateIfNecessary! !

!ChangeSorter methodsFor: 'creation' stamp: 'tk 12/7/1999 12:51'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared."

super veryDeepInner: deepCopier.
"parent _ parent.		Weakly copied"
"myChangeSet _ myChangeSet.		Weakly copied"
currentClassName _ currentClassName veryDeepCopyWith: deepCopier.
"currentSelector _ currentSelector.		Symbol"
priorChangeSetList _ priorChangeSetList veryDeepCopyWith: deepCopier.
! !


!ChangeSorter methodsFor: 'access' stamp: 'tk 4/29/1998 08:22'!
changeSet
	^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'sw 1/27/2000 11:19'!
changeSetCurrentlyDisplayed
	^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 13:37'!
label
	^ self labelString! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 14:03'!
labelString
	"The label for my entire window.  The large button that displays my name is gotten via mainButtonName"
	^ parent 
		ifNil: [Smalltalk changes == myChangeSet
			ifTrue: ['Changes go to "', myChangeSet name, '"']
			ifFalse: ['ChangeSet: ', myChangeSet name]]
		ifNotNil: ['Changes go to "', (Smalltalk changes name), '"']! !

!ChangeSorter methodsFor: 'access' stamp: 'sma 11/11/2000 23:28'!
modelWakeUp
	"A window with me as model is being entered.
	Make sure I am up-to-date with the changeSets."

	self canDiscardEdits ifTrue: [self update]! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:43'!
myChangeSet: anObject
	myChangeSet _ anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'!
parent
	^ parent! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'!
parent: anObject
	parent _ anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'sw 1/28/1999 12:31'!
showChangeSet: chgSet

	myChangeSet == chgSet ifFalse: [
		myChangeSet _ chgSet.
		currentClassName _ nil.
		currentSelector _ nil].
	self changed: #relabel.
	self changed: #currentCngSet.	"new -- list of sets"
	self changed: #mainButtonName.	"old, button"
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 6/10/1998 07:38'!
showChangeSetNamed: aName

	aName ifNil: [^ self showChangeSet: nil].
	self showChangeSet: 
		(AllChangeSets detect: [:each | each name = aName]) ! !


!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/1999 23:22'!
addPreamble
	myChangeSet assurePreambleExists.
	self okToChange ifTrue:
		[currentClassName _ nil.
		currentSelector _ nil.
		self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:27'!
browseChangeSet
	"Open a message list browser on the new and changed methods in the current change set"

	ChangedMessageSet openFor: myChangeSet

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/1/2000 15:48'!
browseMethodConflicts
	"Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such."

	| aList aClass aSelector |
	aList _ myChangeSet changedMessageListAugmented select:
		[:aChange |
			MessageSet parse: aChange toClassAndSelector: [:cls :sel | aClass _ cls.  aSelector _ sel].
			(ChangeSorter allChangeSetsWithClass: aClass selector: aSelector) size > 1].

	aList size == 0 ifTrue: [^ self inform: 'No other change set has changes
for any method in this change set.'].
	
	MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')'
	! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sma 11/11/2000 23:32'!
changeSetList
	"Answer a list of ChangeSet names. If there're new
	ChangeSet instances, create a new list of change sets."

	ChangeSet instanceCount > AllChangeSets size
		ifTrue: [self class gatherChangeSets].
	^ AllChangeSets reversed collect: [:each | each name]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/25/2001 07:22'!
changeSetListKey: aChar from: view
	"Respond to a Command key.  I am a model with a listView that has a list of changeSets."

	aChar == $b ifTrue: [^ self browseChangeSet].
	aChar == $f ifTrue: [^ self findCngSet].
	aChar == $m ifTrue: [^ self newCurrent].
	aChar == $n ifTrue: [^ self newSet].
	aChar == $o ifTrue: [^ self fileOut].
	aChar == $r ifTrue: [^ self rename].
	aChar == $x ifTrue: [^ self remove].
	aChar == $p ifTrue: [^ self addPreamble].
	aChar == $c ifTrue: [^ self copyAllToOther].
	aChar == $D ifTrue: [^ self toggleDiffing]. 

	^ self messageListKey: aChar from: view! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/28/2001 19:18'!
changeSetMenu: aMenu shifted: isShifted 
	"Set up aMenu to hold commands for the change-set-list pane.  This could be for a single or double changeSorter"

	isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu].
	Smalltalk isMorphic
		ifTrue:
			[aMenu title: 'Change Set'.
			aMenu addStayUpItemSpecial]
		ifFalse:
			[aMenu title: 'Change Set:
' , myChangeSet name].


	aMenu add: 'make changes go to me (m)' action: #newCurrent.
	aMenu addLine.
	aMenu add: 'new change set... (n)' action: #newSet.
	aMenu add: 'find...(f)' action: #findCngSet.
	aMenu add: 'show...' action: #chooseCngSet.
	aMenu add: 'rename change set (r)' action: #rename.
	aMenu addLine.
	aMenu add: 'file out (o)' action: #fileOut.
	aMenu add: 'mail to list' action: #mailOut.
	aMenu add: 'browse methods (b)' action: #browseChangeSet.
	aMenu addLine.
	parent
		ifNotNil: 
			[aMenu add: 'copy all to other side (c)' action: #copyAllToOther.
			aMenu add: 'submerge into other side' action: #submergeIntoOtherSide.
			aMenu add: 'subtract other side' action: #subtractOtherSide.
			aMenu addLine].
	myChangeSet hasPreamble
		ifTrue: 
			[aMenu add: 'edit preamble (p)' action: #addPreamble.
			aMenu add: 'remove preamble' action: #removePreamble]
		ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble].
	myChangeSet hasPostscript
		ifTrue: 
			[aMenu add: 'edit postscript...' action: #editPostscript.
			aMenu add: 'remove postscript' action: #removePostscript]
		ifFalse: [aMenu add: 'add postscript...' action: #editPostscript].
	aMenu addLine.
	aMenu add: 'destroy change set (x)' action: #remove.
	aMenu addLine.
	aMenu add: 'more...' action: #shiftedYellowButtonActivity.
	^ aMenu! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/30/2000 10:48'!
checkForAlienAuthorship
	"Open a message list browser on all uncommented methods in the current change set that have alien authorship"

	myChangeSet checkForAlienAuthorship

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/30/2000 10:39'!
checkForUncommentedMethods
	"Open a message list browser on all uncommented methods in the current change set"

	myChangeSet checkForUncommentedMethods

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/27/1999 14:20'!
checkForUnsentMessages
	"Open a message list browser on all unsent messages in the current change set"

	myChangeSet checkForUnsentMessages

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 13:36'!
checkThatSidesDiffer: escapeBlock
	"If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily"

	(myChangeSet == (parent other: self) changeSet)
		ifTrue:
			[self inform: 
'This command requires that the
change sets selected on the two
sides of the change sorter *not*
be the same.'.
			^ escapeBlock value]
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 11/3/2000 17:07'!
chooseCngSet
	"Present the user with an alphabetical list of change set names, and let her choose one"
	| index changeSetsSortedAlphabetically |
	self okToChange ifFalse: [^ self].
	ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets].
	changeSetsSortedAlphabetically _ AllChangeSets asSortedCollection:
		[:a :b | a name asLowercase withoutLeadingDigits < b name asLowercase withoutLeadingDigits].

	index _ (PopUpMenu labels: Smalltalk changes name , ' (active)' , Character cr asString ,
				(changeSetsSortedAlphabetically collect: [:each | each name]) asStringWithCr)
			startUp.
	index = 0 ifTrue: [^ self].
	index = 1 ifTrue: [^ self showChangeSet: Smalltalk changes].
	self showChangeSet: (changeSetsSortedAlphabetically at: index-1).
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/28/1999 12:30'!
clearChangeSet
	"Clear out the current change set, after getting a confirmation."
	| message |

	self okToChange ifFalse: [^ self].
	myChangeSet isEmpty ifFalse:
		[message _ 'Are you certain that you want to\forget all the changes in this set?' withCRs.
		(self confirm: message) ifFalse: [^ self]].
	myChangeSet clear.
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/27/2000 11:21'!
copyAllToOther
	"Copy this entire change set into the one on the other side"
	| companionSorter |
	self checkThatSidesDiffer: [^ self].
	(companionSorter _ parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet.
	companionSorter changed: #classList.	"Later the changeSet itself will notice..."
	companionSorter changed: #messageList! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/5/1998 06:47'!
currentCngSet
	^ myChangeSet name! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPostscript
	"Allow the user to edit the receiver's change-set's postscript -- in a separate window"

	myChangeSet editPostscript! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPreamble
	"Allow the user to edit the receiver's change-set's preamble -- in a separate window."

	myChangeSet editPreamble! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/19/2000 16:18'!
expungeUniclasses
	"remove all memory of uniclasses in the receiver"

	self okToChange ifFalse: [^ self].
	myChangeSet expungeUniclasses.
	self changed: #classList.
	self changed: #messageList.

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 11/22/1998 23:57'!
fileIntoNewChangeSet
	"Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename.  Show the new set and leave the current changeSet unaltered."
	| aFileName  aNewChangeSet |

	self okToChange ifFalse: [^ self].
	aFileName _ FillInTheBlank request: 'Name of file to be imported: '.
	aFileName size == 0 ifTrue: [^ self].
	(FileDirectory default fileExists: aFileName) ifFalse:
		[^ self inform: 'Sorry -- cannot find that file'].

	aNewChangeSet _ self class 
			newChangesFromStream: (FileStream readOnlyFileNamed: aFileName) 
			named: aFileName.
	aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/10/1999 12:44'!
fileOut
	"File out the current change set."

	myChangeSet fileOut.
	parent modelWakeUp.	"notice object conversion methods created"
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/4/2001 10:04'!
fileOutUnnumberedChangeSets
	"File out all nonempty change sets whose names do not start with numbers, without checking for slips"

	Utilities fileOutUnnumberedChangeSets! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/16/1999 13:30'!
findCngSet 
	"Search for a changeSet by name.  Pop up a menu of all changeSets whose name contains the string entered by the user.  If only one matches, then the pop-up menu is bypassed"
	| index pattern candidates |
	self okToChange ifFalse: [^ self].
	ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets].
	pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'.
	pattern isEmpty ifTrue: [^ self].
	candidates _ AllChangeSets select:
			[:c | c name includesSubstring: pattern caseSensitive: false].
	candidates size = 0 ifTrue: [^ self beep].
	candidates size = 1 ifTrue:
		[^ self showChangeSet: candidates first].
	index _ (PopUpMenu labels: 
		(candidates collect: [:each | each name]) asStringWithCr) startUp.
	index = 0 ifFalse: [self showChangeSet: (candidates at: index)].
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 10/26/1999 14:24'!
goToChangeSetsProject
	"Transport the user to a project which bears the selected changeSet as its current changeSet"

	| aProject |
	(aProject _ myChangeSet correspondingProject) 
		ifNotNil:
			[aProject enter: false revert: false saveForRevert: false]
		ifNil:
			[self inform: 'Has no project']! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/10/1999 01:01'!
inspectChangeSet
	"Open a message list browser on the new and changed methods in the current change set"

	myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/17/1999 11:05'!
lookForSlips
	"Open a message list browser on the new and changed methods in the current change set"

	myChangeSet lookForSlips

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'dvf 5/13/2000 05:08'!
mailOut
	"Create a mail with a gzipped attachment holding out the current change 
	set. "
	myChangeSet mailOut.
	parent modelWakeUp! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:10'!
mainButtonName

	^ myChangeSet name! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/1/2000 15:48'!
methodConflictsWithOtherSide
	"Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such."

	| aList aClass aSelector other |
	self checkThatSidesDiffer: [^ self].
	other _ (parent other: self) changeSet.
	aList _ myChangeSet changedMessageListAugmented select:
		[:aChange |
			MessageSet parse: aChange toClassAndSelector: [:cls :sel | aClass _ cls.  aSelector _ sel].
			aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector]].

	aList size == 0 ifTrue: [^ self inform: 'There are no methods that appear
both in this change set and
in the one on the other side.'].
	
	MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')'
	! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/30/1998 13:47'!
newCurrent
	"make my change set be the current one that changes go into"
	Smalltalk newChanges: myChangeSet.
	self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 9/4/1998 09:00'!
newSet
	"Create a new changeSet and show it., making it the current one.  Reject name if already in use."

	| aSet |
	self okToChange ifFalse: [^ self].
	aSet _ self class newChangeSet.
	aSet ifNotNil:
		[self update.
		self showChangeSet: aSet.
		self changed: #relabel]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/27/2000 15:03'!
promoteToTopChangeSet
	self class promoteToTop: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/14/1998 12:00'!
remove
	"Completely destroy my change set.  Check if it's OK first"

	self okToChange ifFalse: [^ self].
	self removePrompting: true.
	self update! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 6/29/1999 20:53'!
removePostscript
	(myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue:
		[^ self inform:
'Cannot remove the postscript right
now because there is at least one
window open on that postscript.
Close that window and try again.'].

	myChangeSet removePostscript.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/1999 19:32'!
removePreamble
	myChangeSet removePreamble.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 5/26/2000 22:34'!
removePrompting: doPrompt
	"Completely destroy my change set.  Check if it's OK first,  and if doPrompt is true, get the user to confirm his intentions first"
	| message aName |

	aName _ myChangeSet name.
	myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project"
	(myChangeSet isEmpty or: [doPrompt not]) ifFalse:
		[message _ 'Are you certain that you want to 
remove (destroy) the change set
named  "', aName, '" ?'.
		(self confirm: message) ifFalse: [^ self]].

	(doPrompt and: [myChangeSet hasPreamble or: [myChangeSet hasPostscript]])
		ifTrue:
			[(self confirm: 
'Caution!!  This change set has a preamble
and/or a postscript, which will be lost if 
you destroy the change set.
Do you really want to go ahead with this?') ifFalse: [^ self]].

	"Go ahead and remove the change set"
	AllChangeSets remove: myChangeSet.
	myChangeSet wither.		"clear out its contents"
	self showChangeSet: Smalltalk changes.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/14/1998 11:58'!
rename
	"Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

	| newName |
	newName _ FillInTheBlank request: 'New name for this change set'
						initialAnswer: myChangeSet name.
	(newName = myChangeSet name or: [newName size == 0]) ifTrue:
			[^ self inform: 'No change made'].

	(self class changeSetNamed: newName) ifNotNil:
			[^ Utilities inform: 'Sorry that name is already used'].

	myChangeSet name: newName.
	self update.
	self changed: #mainButtonName.
	self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/29/2001 02:46'!
shiftedChangeSetMenu: aMenu
	"Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"

	Smalltalk isMorphic ifTrue:
		[aMenu title: 'Change set (shifted)'.
		aMenu addStayUpItemSpecial].
	aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts.
	aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in at least one other change set.'.

	parent ifNotNil:
		[aMenu add: 'conflicts with opposite side' action: #methodConflictsWithOtherSide.
			aMenu balloonTextForLastItem: 
'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'.
].
	aMenu addLine.
	aMenu add: 'check for slips' action: #lookForSlips.
	aMenu balloonTextForLastItem: 
'Check this change set for halts and references to Transcript.'.

	aMenu add: 'check for unsent messages' action: #checkForUnsentMessages.
	aMenu balloonTextForLastItem:
'Check this change set for messages that are not sent anywhere in the system'.

	aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods.
	aMenu balloonTextForLastItem:
'Check this change set for methods that do not have comments'.

	Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
		[aMenu add: 'check for other authors' action: #checkForAlienAuthorship.
		aMenu balloonTextForLastItem:
'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'].

	aMenu addLine.

	aMenu add: 'inspect change set' action: #inspectChangeSet.
	aMenu balloonTextForLastItem: 
'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'.

	aMenu add: 'update' action: #update.
	aMenu balloonTextForLastItem: 
'Update the display for this change set.  (This is done automatically when you activate this window, so is seldom needed.)'.

	aMenu add: 'go to change set''s project' action: #goToChangeSetsProject.
	aMenu balloonTextForLastItem: 
'If this change set is currently associated with a Project, go to that project right now.'.

	aMenu add: 'promote to top of list' action: #promoteToTopChangeSet.
	aMenu balloonTextForLastItem:
'Make this change set appear first in change-set lists in all change sorters.'.

	aMenu add: 'trim history' action: #trimHistory.
	aMenu balloonTextForLastItem: 
' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes.  NOTE: can cause confusion if later filed in over an earlier version of these changes'.

	aMenu add: 'clear this change set' action: #clearChangeSet.
	aMenu balloonTextForLastItem: 
'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'.
	aMenu add: 'expunge uniclasses' action: #expungeUniclasses.
	aMenu balloonTextForLastItem:
'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'.

	aMenu add: 'uninstall this change set' action: #uninstallChangeSet.
	aMenu balloonTextForLastItem: 
'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'.

	aMenu addLine.
	aMenu add: 'file into new...' action: #fileIntoNewChangeSet.
	aMenu balloonTextForLastItem: 
'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'.

	aMenu add: 'file out all change sets' action: #fileOutUnnumberedChangeSets.
	aMenu balloonTextForLastItem:
'File out every change set in the system whose name does not begin with a digit, except those that are empty or whose names start with "Play with me".  The usual checks for slips are suppressed when this command is done.'.

	aMenu addLine.
	aMenu add: 'more...' action: #unshiftedYellowButtonActivity.
	aMenu balloonTextForLastItem: 
'Takes you back to the primary change-set menu.'.

	^ aMenu! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 5/26/2000 18:23'!
submergeIntoOtherSide
	"Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
	| other message nextToView i |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ self].
	other _ (parent other: self) changeSet.
	other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!'].
	myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy.  To remove,
simply choose "remove".'].

	myChangeSet okayToRemove ifFalse: [^ self].
	message _ 'Please confirm:  copy all changes
in "', myChangeSet name, '" into "', other name, '"
and then destroy the change set
named "', myChangeSet name, '"?'.
 
	(self confirm: message) ifFalse: [^ self].

	(myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue:
		[(self confirm: 
'Caution!!  This change set has a preamble or
a postscript or both.  If you submerge it into
the other side, these will be lost.
Do you really want to go ahead with this?') ifFalse: [^ self]].

	other assimilateAllChangesFoundIn: myChangeSet.

	nextToView _ ((AllChangeSets includes: myChangeSet)
		and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size])
		ifTrue: [AllChangeSets at: i+1]
		ifFalse: [other].

	self removePrompting: false.
	self showChangeSet: nextToView.
	self class gatherChangeSets.
	parent modelWakeUp.
	"(parent other: self) changed: #classList.
	(parent other: self) changed: #messageList."! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 12:32'!
subtractOtherSide
	"Subtract the changes found on the other side from the requesting side."
	self checkThatSidesDiffer: [^ self].
	myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet).
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 5/12/2000 15:03'!
trimHistory
	"Drop non-essential history (rename, reorg, method removals) from newly-added classes."

	myChangeSet trimHistory

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 3/8/2000 14:18'!
uninstallChangeSet
	"Attempt to uninstall the current change set, after confirmation."

	self okToChange ifFalse: [^ self].
	(self confirm: 'Uninstalling a changeSet is unreliable at best.
It will only work if the changeSet consists only of single
changes, additions and removals of methods, and if
no subsequent changes have been to any of them.
No changes to classes will be undone.
The changeSet will be cleared after uninstallation.
Do you still wish to attempt to uninstall this changeSet?')
	ifFalse: [^ self].

	myChangeSet uninstall.
	self changed: #relabel.
	self changed: #classList.
	self changed: #messageList.
	self setContents.
	self contentsChanged.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/21/1998 13:02'!
update
	"recompute all of my panes"

	self updateIfNecessary.
	parent ifNotNil: [(parent other: self) updateIfNecessary]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'sma 11/11/2000 23:37'!
updateIfNecessary
	"Recompute all of my panes."

	| newList |
	self okToChange ifFalse: [^ self].
	myChangeSet isMoribund ifTrue: [^ self showChangeSet: Smalltalk changes].
	newList _ self changeSetList.
	(priorChangeSetList == nil or: [priorChangeSetList ~= newList])
		ifTrue:
			[priorChangeSetList _ newList.
			self changed: #changeSetList].
	self showChangeSet: myChangeSet! !


!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:01'!
classList
	"Computed.  View should try to preserve selections, even though index changes"

	^ myChangeSet changedClassNames
! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 1/19/2001 01:33'!
classListKey: aChar from: view
	"Overridden to obviate spurious StringHolder processing of $f for findClass"

	^ self messageListKey: aChar from: view! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 12/6/2000 16:34'!
classMenu: aMenu
	"Set up aMenu for the class-list.  Retained for backward compatibility with old change sorters in image segments"

	^ self classMenu: aMenu shifted: false! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 2/1/2001 08:42'!
classMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the class list"

	aMenu title: 'class list'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].
	(parent notNil and: [shifted not])
		ifTrue: [aMenu addList: #( "These two only apply to dual change sorters"
			('copy class chgs to other side'			copyClassToOther)	
			('move class chgs to other side'			moveClassToOther))].

	^ aMenu addList: (shifted
		ifFalse: [#(
			-
			('delete class chgs from this change set'	forgetClass)
			-
			('browse full (b)'						browseMethodFull)
			('browse hierarchy (h)'					spawnHierarchy)
			('browse protocol (p)'					browseFullProtocol)
			-
			('printOut'								printOutClass)
			('fileOut'								fileOutClass)
			-
			('inst var refs...'						browseInstVarRefs)
			('inst var defs...'						browseInstVarDefs)
			('class var refs...'						browseClassVarRefs)
			('class vars'								browseClassVariables)
			('class refs (N)'							browseClassRefs)
			-
			('more...'								shiftedYellowButtonActivity))]
		ifTrue: [#(
			-
			('unsent methods'						browseUnusedMethods)
			('unreferenced inst vars'				showUnreferencedInstVars)
			-
			('sample instance'						makeSampleInstance)
			('inspect instances'						inspectInstances)
			('inspect subinstances'					inspectSubInstances)
			-
			('more...'								unshiftedYellowButtonActivity))])! !

!ChangeSorter methodsFor: 'class list' stamp: 'di 4/4/2000 09:37'!
copyClassToOther
	"Place these changes in the other changeSet also"

	| otherSorter otherChangeSet |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ self beep].
	currentClassName ifNil: [^ self beep].
	otherSorter _ parent other: self.
	otherChangeSet _ otherSorter changeSet.

	otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
	otherSorter showChangeSet: otherChangeSet.! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 09:14'!
currentClassName

	^ currentClassName! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 1/28/1999 12:30'!
currentClassName: aString

	currentClassName _ aString.
	currentSelector _ nil.	"fix by wod"
	self changed: #currentClassName.
	self changed: #messageList.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'class list' stamp: 'kfr 6/16/2000 16:27'!
fileOutClass
	"this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000" 
	| aSet |
	"File out the selected class set."
     aSet _ self class newChangeSet: currentClassName.
	aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
	aSet fileOut.
	self class removeChangeSet: aSet.
	parent modelWakeUp.	"notice object conversion methods created"

! !

!ChangeSorter methodsFor: 'class list' stamp: 'ls 8/12/1998 23:47'!
forgetClass
	"Remove all mention of this class from the changeSet"

	self okToChange ifFalse: [^ self].
	currentClassName ifNotNil: [
		myChangeSet removeClassChanges: currentClassName.
		currentClassName _ nil.
		currentSelector _ nil.
		self showChangeSet: myChangeSet].
! !

!ChangeSorter methodsFor: 'class list' stamp: 'di 4/3/2000 20:31'!
moveClassToOther
	"Place class changes in the other changeSet and remove them from this one"

	self copyClassToOther.
	self forgetClass! !

!ChangeSorter methodsFor: 'class list' stamp: 'sw 12/7/1998 09:43'!
selectedClass
	"Answer the currently-selected class.  If there is no selection, or if the selection refers to a class no longer extant, return nil"
	| c |
	^ currentClassName ifNotNil: [(c _ self selectedClassOrMetaClass)
		ifNotNil: [c theNonMetaClass]]! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:48'!
selectedClassOrMetaClass
	"Careful, the class may have been removed!!"

	| cName |
	currentClassName ifNil: [^ nil].
	(currentClassName endsWith: ' class')
		ifTrue: [cName _ (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol.
				^ (Smalltalk at: cName ifAbsent: [^nil]) class]
		ifFalse: [cName _ currentClassName asSymbol.
				^ Smalltalk at: cName ifAbsent: [nil]]! !


!ChangeSorter methodsFor: 'message list' stamp: 'di 3/23/2000 13:34'!
browseVersions
	"Create and schedule a changelist browser on the versions of the 
	selected message."
	| class selector method category pair sourcePointer |

	(selector _ self selectedMessageName) ifNil: [^ self].
	class _ self selectedClassOrMetaClass.
	(class includesSelector: selector)
		ifTrue: [method _ class compiledMethodAt: selector.
				category _ class whichCategoryIncludesSelector: selector.
				sourcePointer _ nil]
		ifFalse: [pair _ myChangeSet methodInfoFromRemoval: {class name. selector}.
				pair ifNil: [^ nil].
				sourcePointer _ pair first.
				method _ CompiledMethod toReturnSelf setSourcePointer: sourcePointer.
				category _ pair last].
	VersionsBrowser
		browseVersionsOf: method
		class: self selectedClass meta: class isMeta
		category: category selector: selector
		lostMethodPointer: sourcePointer.
! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 7/8/1999 12:31'!
copyMethodToOther
	"Place this change in the other changeSet also"
	| other cls sel |
	self checkThatSidesDiffer: [^ self].
	currentSelector ifNotNil:
		[other _ (parent other: self) changeSet.
		cls _ self selectedClassOrMetaClass.
		sel _ currentSelector asSymbol.

		other absorbMethod: sel class: cls from: myChangeSet.
		(parent other: self) showChangeSet: other]
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/24/1998 09:15'!
currentSelector

	^ currentSelector! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 1/28/1999 12:31'!
currentSelector: messageName

	currentSelector _ messageName.
	self changed: #currentSelector.
	self setContents.
	self contentsChanged.! !

!ChangeSorter methodsFor: 'message list' stamp: 'di 6/22/1998 02:08'!
forget
	"Drop this method from the changeSet"

	self okToChange ifFalse: [^ self].
	currentSelector ifNotNil: [
		myChangeSet removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
		currentSelector _ nil.
		self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'message list' stamp: 'di 4/25/2000 10:33'!
messageList 

	| probe newSelectors |
	currentClassName ifNil: [^ #()].
	probe _ (currentClassName endsWith: ' class')
		ifTrue: [currentClassName]
		ifFalse: [currentClassName asSymbol].
	newSelectors _ myChangeSet selectorsInClass: probe.
	(newSelectors includes: currentSelector) ifFalse: [currentSelector _ nil].
	^ newSelectors asSortedCollection
! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 2/1/2001 08:40'!
messageMenu: aMenu shifted: shifted
	"Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"

	shifted ifTrue: [^ self shiftedMessageMenu: aMenu].

	aMenu title: 'message list'.
	Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial].

	parent ifNotNil:
		[aMenu addList: #(
			('copy method to other side'			copyMethodToOther)
			('move method to other side'			moveMethodToOther))].

	aMenu addList: #(
			('delete method from change set'		forget)
			-
			('remove method from system (x)'	removeMessage)
				-
			('browse full (b)'					browseMethodFull)
			('browse hierarchy (h)'				spawnHierarchy)
			('browse method (O)'				openSingleMessageBrowser)
			('browse protocol (p)'				browseFullProtocol)
			-
			('fileOut'							fileOutMessage)
			('printOut'							printOutMessage)
			-
			('senders of... (n)'					browseSendersOfMessages)
			('implementors of... (m)'				browseMessages)
			('inheritance (i)'					methodHierarchy)
			('versions (v)'						browseVersions)
			-
			('more...'							shiftedYellowButtonActivity)).
	^ aMenu
! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 7/8/1999 12:31'!
moveMethodToOther
	"Place this change in the other changeSet and remove it from this side"
	| other cls sel |
	self checkThatSidesDiffer: [^ self].
	self okToChange ifFalse: [^ self beep].
	currentSelector ifNotNil:
		[other _ (parent other: self) changeSet.
		other == myChangeSet ifTrue: [^ self beep].
		cls _ self selectedClassOrMetaClass.
		sel _ currentSelector asSymbol.
		other absorbMethod: sel class: cls from: myChangeSet.
	
		(parent other: self) showChangeSet: other.
		self forget "removes the method from this side"]
! !

!ChangeSorter methodsFor: 'message list' stamp: 'di 6/21/1998 23:13'!
removeFromCurrentChanges
	"Redisplay after removal in case we are viewing the current changeSet"

	super removeFromCurrentChanges.
	currentSelector _ nil.
	self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'message list' stamp: 'di 4/4/2000 10:54'!
removeMessage
	"Remove the selected msg from the system.  Real work done by the parent, a ChangeSorter"

	| confirmation sel |
	self okToChange ifFalse: [^ self].
	currentSelector ifNotNil: [
		confirmation _ self selectedClassOrMetaClass 
			confirmRemovalOf: (sel _ self selectedMessageName).
		confirmation == 3 ifTrue: [^ self].
		self selectedClassOrMetaClass removeSelector: sel.
		self update.
		confirmation == 2 ifTrue:
			[Smalltalk browseAllCallsOn: sel]]! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 2/7/2000 11:01'!
selectedMessage
	"Answer a copy of the source code for the selected message selector." 

	^ contents ifNil: [''] ifNotNil: [contents copy]! !

!ChangeSorter methodsFor: 'message list' stamp: 'jm 5/4/1998 07:32'!
selectedMessageName

	currentSelector ifNil: [^ nil].
	^ currentSelector asSymbol! !

!ChangeSorter methodsFor: 'message list' stamp: 'sw 1/25/2001 07:25'!
shiftedMessageMenu: aMenu
	"Arm the menu so that it holds items appropriate to the message-list while the shift key is down.  Answer the menu."

	^ aMenu addList: #(
		-
		('method pane'						makeIsolatedCodePane)
		('toggle diffing (D)'					toggleDiffing)
		('implementors of sent messages'		browseAllMessages)
		('change category...'				changeCategory)
			-
		('sample instance'					makeSampleInstance)
		('inspect instances'					inspectInstances)
		('inspect subinstances'				inspectSubInstances)
		-
		('change sets with this method'		findMethodInChangeSets)
		('revert to previous version'			revertToPreviousVersion)
		('revert & remove from changes'	revertAndForget)
		-
		('more...'							unshiftedYellowButtonActivity))! !


!ChangeSorter methodsFor: 'code pane' stamp: 'tk 5/10/1999 17:24'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Create an error if the category of the selected message is unknown. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer true."
	| category selector class oldSelector |

	(class _ self selectedClassOrMetaClass) ifNil:
		[(myChangeSet preambleString == nil or: [aString size == 0]) ifTrue: [ ^ false].
		(aString count: [:char | char == $"]) odd 
			ifTrue: [self inform: 'unmatched double quotes in preamble']
			ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [
				self inform: 'Part of the preamble is not within double-quotes.
To put a double-quote inside a comment, type two double-quotes in a row.
(Ignore this warning if you are including a doIt in the preamble.)']].
		myChangeSet preambleString: aString.
		self currentSelector: nil.  "forces update with no 'unsubmitted chgs' feedback"
		^ true].
	oldSelector _ self selectedMessageName.
	category _ class organization categoryOfElement: oldSelector.
	selector _ class compile: aString
				classified: category
				notifying: aController.
	selector ifNil: [^ false].
	(self messageList includes: selector)
		ifTrue: [self currentSelector: selector]
		ifFalse: [self currentSelector: oldSelector].
	self update.
	^ true! !

!ChangeSorter methodsFor: 'code pane' stamp: 'mas 5/20/2000 22:03'!
setContents
	"return the source code that shows in the bottom pane"
	| sel class strm changeType |
	self clearUserEditFlag.
	currentClassName ifNil: [^ contents _ myChangeSet preambleString ifNil: ['']].
	class _ self selectedClassOrMetaClass.
	(sel _ currentSelector) == nil
		ifFalse: [changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class).
			changeType == #remove
				ifTrue: [^ contents _ 'Method has been removed (see versions)'].
			changeType == #addedThenRemoved
				ifTrue: [^ contents _ 'Added then removed (see versions)'].
			class ifNil: [^ contents _ 'Method was added, but cannot be found!!'].
			(class includesSelector: sel)
				ifFalse: [^ contents _ 'Method was added, but cannot be found!!'].
			contents _ class sourceCodeAt: sel.
			Preferences browseWithPrettyPrint ifTrue:
				[contents _ class compilerClass new
					format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting].
			self showDiffs
				ifTrue: [contents _ self diffFromPriorSourceFor: contents].
			^ contents _ contents asText makeSelectorBoldIn: class]
		ifTrue: [strm _ WriteStream on: (String new: 100).
			(myChangeSet classChangeAt: currentClassName) do:
				[:each |
				each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].
				each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.'].
				each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr].
				each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr].
				each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].
				each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr].
				each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr.
				]].
			^ contents _ strm contents].! !

!ChangeSorter methodsFor: 'code pane' stamp: 'sw 1/19/2001 15:43'!
toggleDiffing
	"Toggle whether diffs should be shown in the code pane"

	self okToChange ifTrue:
		[self showDiffs: self showDiffs not.
		self changed: #contents.
		self update]

! !

!ChangeSorter methodsFor: 'code pane' stamp: 'JW 2/2/2001 21:41'!
wantsOptionalButtons
	"No optional buttons for ChangeSorter"
	^false! !

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

ChangeSorter class
	instanceVariableNames: ''!

!ChangeSorter class methodsFor: 'enumerating' stamp: 'tk 5/1/1998 15:26'!
allChangeSetNames
	^ self gatherChangeSets collect: [:c | c name]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 2/21/2000 14:36'!
allChangeSetsWithClass: class selector: selector
	class ifNil: [^ #()].
	^ self gatherChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'tk 4/24/1998 16:42'!
changeSetNamed: aName
	"Return the change set of the given name, or nil if none found.  1/22/96 sw"

	self gatherChangeSets.
	AllChangeSets do:
		[:aChangeSet | aChangeSet name = aName ifTrue:
			[^ aChangeSet]].
	^ nil! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/1/2000 17:25'!
changeSetsNamedSuchThat: nameBlock
	"(ChangeSorter changeSetsNamedSuchThat:
		[:name | name first isDigit and: [name initialInteger >= 373]])
		do: [:cs | AllChangeSets remove: cs wither]"

	self gatherChangeSets.
	^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'RAA 10/19/2000 13:17'!
existingOrNewChangeSetNamed: aName

	| newSet |

	^(self changeSetNamed: aName) ifNil: [
		newSet _ ChangeSet new initialize name: aName.
		AllChangeSets add: newSet.
		newSet
	]! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/3/2000 14:51'!
gatherChangeSets		"ChangeSorter gatherChangeSets"
	"Collect any change sets created in other projects"
	| allChangeSets obsolete |
	allChangeSets _ AllChangeSets asSet.
	ChangeSet allSubInstances do: [:each |
		(allChangeSets includes: each) == (obsolete _ each isMoribund) ifTrue:[
			obsolete
				ifTrue: ["Was included and is obsolete."
						AllChangeSets remove: each]
				ifFalse: ["Was not included and is not obsolete."
						AllChangeSets add: each]]].
	^ AllChangeSets
! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 8/20/1999 10:27'!
highestNumberedChangeSet
	"ChangeSorter highestNumberedChangeSet"
	| aList |
	aList _ (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect:
		[:aString | aString initialIntegerOrNil]).
	^ (aList size > 0)
		ifTrue:
			[aList max]
		ifFalse:
			[nil]
! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 2/15/1999 23:02'!
mostRecentChangeSetWithChangeForClass: class selector: selector
	| hits |
	hits _ self gatherChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none].
	hits isEmpty ifTrue: [^ 'not in any change set'].
	^ 'recent cs: ', hits last name! !

!ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 1/27/2000 15:04'!
promoteToTop: aChangeSet
	"make aChangeSet the first in the list from now on"
	self gatherChangeSets.
	AllChangeSets remove: aChangeSet ifAbsent: [^ self].
	AllChangeSets add: aChangeSet.
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! !


!ChangeSorter class methodsFor: 'class initialization' stamp: 'tk 4/24/1998 13:52'!
initialize
	AllChangeSets == nil ifTrue:
		[AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.
! !


!ChangeSorter class methodsFor: 'adding' stamp: 'sma 11/11/2000 23:22'!
basicNewChangeSet: newName
	| newSet |
	(self changeSetNamed: newName) ifNotNil:
		[self inform: 'Sorry that name is already used'.
		^ nil].
	newSet _ ChangeSet new initialize name: newName.
	AllChangeSets add: newSet.
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sma 11/11/2000 23:22'!
newChangeSet
	"Prompt the user for a name, and establish a new change set of
	that name (if ok), making it the current changeset.  Return nil
	of not ok, else return the actual changeset."

	| newName newSet |
	newName _ FillInTheBlank
		request: 'Please name the new change set:'
		initialAnswer: ChangeSet defaultName.
	newName isEmpty ifTrue:
		[self inform: 'nothing done'.
		^ nil].
	newSet _ self basicNewChangeSet: newName.
	newSet ifNotNil:
		[Smalltalk newChanges: newSet.
		Transcript cr; show: newName, ' is now the current change set'].
	^ newSet! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sma 11/11/2000 23:23'!
newChangeSet: aName
	"Makes a new change set called aName, add author initials to try to
	ensure a unique change set name."

	| newName |
	newName _ aName , FileDirectory dot , Utilities authorInitials.
	^ self basicNewChangeSet: newName! !

!ChangeSorter class methodsFor: 'adding' stamp: 'sma 11/11/2000 23:24'!
newChangesFromStream: aStream named: aName
	"File in the code from the stream into a new change set whose
	name is derived from aName. Leave the 'current change set'
	unchanged. Return the new change set or nil on failure."

	| oldChanges newName newSet |
	oldChanges _ Smalltalk changes.
	newName _ aName sansPeriodSuffix.
	newSet _ self basicNewChangeSet: newName.
	newSet ifNotNil:
		[Smalltalk newChanges: newSet.
		aStream fileInAnnouncing: 'Loading ', newName, '...'.
		Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName].
	aStream close.
	Smalltalk newChanges: oldChanges.
	^ newSet! !


!ChangeSorter class methodsFor: 'removing' stamp: 'sw 1/6/2001 06:21'!
deleteChangeSetsNumberedLowerThan: anInteger
	"Delete all changes sets whose names start with integers smaller than anInteger"

	ChangeSorter removeChangeSetsNamedSuchThat:
		[:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]].

	"ChangeSorter deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)"
! !

!ChangeSorter class methodsFor: 'removing' stamp: 'sw 8/18/1999 09:44'!
removeChangeSet: aChangeSet
	"Remove the given changeSet.  Caller must assure that it's cool to do this"

	AllChangeSets remove: aChangeSet ifAbsent: [].
	aChangeSet wither
! !

!ChangeSorter class methodsFor: 'removing' stamp: 'tk 6/24/1999 11:32'!
removeChangeSetsBefore: stopName
	"Remove all change sets before the one with the given name."
	"ChangeSorter removeChangeSetsBefore: 'Beyond'" 

	| stop |
	(self confirm:
'Really remove all change sets before
"', stopName, '"?')
		ifFalse: [^ self].

	self gatherChangeSets.
	stop _ false.
	ChangeSet allSubInstancesDo: [:changeSet |
		changeSet name = stopName ifTrue: [stop _ true].
		stop ifFalse: [
			changeSet okayToRemove ifTrue: [
				AllChangeSets remove: changeSet ifAbsent: [].
				changeSet wither]]].
	Smalltalk garbageCollect.
	AllChangeSets _ OrderedCollection new.
	self gatherChangeSets.
! !

!ChangeSorter class methodsFor: 'removing' stamp: 'di 11/8/1998 16:32'!
removeChangeSetsNamedSuchThat: nameBlock
	(ChangeSorter changeSetsNamedSuchThat: nameBlock)
		do: [:cs | AllChangeSets remove: cs wither]! !

!ChangeSorter class methodsFor: 'removing' stamp: 'di 11/9/1998 10:23'!
removeEmptyUnnamedChangeSets
	"Remove all change sets that are empty, whose names start with Unnamed,
		and which are not nailed down by belonging to a Project."
	"ChangeSorter removeEmptyUnnamedChangeSets"
	| toGo |
	(toGo _ (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed'])
		select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]])
		do: [:cs | AllChangeSets remove: cs wither].
	self inform: toGo size printString, ' change set(s) removed.'! !


!ChangeSorter class methodsFor: 'services' stamp: 'di 5/6/1998 16:40'!
browseChangeSetsWithClass: class selector: selector
	| hits index |
	hits _ self gatherChangeSets select: 
		[:cs | (cs atSelector: selector class: class) ~~ #none].
	hits isEmpty ifTrue: [^ PopUpMenu notify: class name,'.',selector , '
is not in any change set'].
	index _ hits size == 1
		ifTrue:	[1]
		ifFalse:	[(PopUpMenu labelArray: (hits collect: [:cs | cs name])
					lines: #()) startUp].
	index = 0 ifTrue: [^ self].
	(ChangeSorter new myChangeSet: (hits at: index)) open.
! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 1/19/2001 17:06'!
buildAggregateChangeSet
	"Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate).  This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image.  Formerly very useful, now some of its unique contributions have been overtaken by new features"

	| aggregateChangeSet |
	aggregateChangeSet _ self existingOrNewChangeSetNamed: 'Aggregate'.
	aggregateChangeSet clear.
	(self gatherChangeSets copyWithout: aggregateChangeSet) do:
		[:aChangeSet | aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]

"ChangeSorter buildAggregateChangeSet"

	! !

!ChangeSorter class methodsFor: 'services' stamp: 'sw 1/4/2000 16:31'!
reorderChangeSets
	"ChangeSorter reorderChangeSets"
	"Change the order of the change sets to something more convenient:
		First come the unnumbered changesets that come with the release.
		Next come the numbered updates.
		Next come all remaining changesets
	In a ChangeSorter, they will appear in the reversed order."

	| newHead newMid newTail itsName |

	self gatherChangeSets.
	newHead _ OrderedCollection new.
	newMid _ OrderedCollection new.
	newTail _ OrderedCollection new.
	AllChangeSets do:
		[:aSet |
			itsName _ aSet name.
			((itsName beginsWith:  'Play With Me') or: [#('New Changes' 'MakeInternal') includes: itsName])
				ifTrue:
					[newHead add: aSet]
				ifFalse:
					[itsName startsWithDigit
						ifTrue:
							[newMid add: aSet]
						ifFalse:
							[newTail add: aSet]]].
	AllChangeSets _ newHead, newMid, newTail.
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! !

!ChangeSorter class methodsFor: 'services' stamp: 'tk 4/30/1998 13:43'!
secondaryChangeSet
	"Answer a likely change set to use as the second initial one in a Dual Change Sorter.  "
	| last |
	self gatherChangeSets.
	AllChangeSets size == 1 ifTrue: [^ AllChangeSets first].
	^ (last _ AllChangeSets last) == Smalltalk changes
		ifTrue: 	[AllChangeSets at: (AllChangeSets size - 1)]
		ifFalse:	[last]! !
MessageSet subclass: #ChangedMessageSet
	instanceVariableNames: 'changeSet '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!ChangedMessageSet methodsFor: 'everything'!
changeSet: aChangeSet
	changeSet _ aChangeSet! !

!ChangedMessageSet methodsFor: 'everything' stamp: 'sw 8/29/2000 16:30'!
contents: aString notifying: aController
	"Accept the string as new source for the current method, and make certain the annotation pane gets invalidated"

	| selectedMessageName selector oldMessageList cls |
	self okayToAccept ifFalse: [^ false].
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ self selectedClassOrMetaClass
				compile: aString
				classified:  self selectedMessageCategoryName
				notifying: aController.
	selector == nil ifTrue: [^ false].
	cls _ self selectedClassOrMetaClass.
	contents _ aString copy.
	self changed: #annotation.
	selector ~~ selectedMessageName ifTrue: 
			[(oldMessageList includes: selector) ifFalse:
					[self initializeMessageList: changeSet changedMessageListAugmented.
					self changed: #messageList].
			self messageListIndex: (self messageList indexOf: (cls name, ' ', selector))].
	^ true! !

!ChangedMessageSet methodsFor: 'everything' stamp: 'sw 1/28/2001 20:59'!
growable
	"Answer whether the receiver can be changed by manual additions & deletions"

	^ false! !

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

ChangedMessageSet class
	instanceVariableNames: ''!

!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sw 1/27/2001 12:20'!
openFor: aChangeSet
	"Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet.  After any method submission, the message list is refigured, making it plausibly dynamic"

	| messageSet |
	messageSet _ MessageSet extantMethodsIn: aChangeSet changedMessageListAugmented.
	self openMessageList: messageSet name: ('Methods in Change Set ', aChangeSet name) autoSelect: nil changeSet: aChangeSet! !

!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sma 4/30/2000 09:22'!
openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet
	| messageSet |
	messageSet _ self messageList: messageList.
	messageSet changeSet: aChangeSet.
	messageSet autoSelectString: autoSelectString.
	Smalltalk isMorphic
		ifTrue: [self openAsMorph: messageSet name: labelString]
		ifFalse: [ScheduledControllers scheduleActive:  (self open: messageSet name: labelString)]! !
Object subclass: #CharRecog
	instanceVariableNames: 'mp p sts pts bmin bmax op cPat in dirs ftrs prevFeatures textMorph '
	classVariableNames: 'CharacterDictionary '
	poolDictionaries: 'TextConstants '
	category: 'System-Support'!
!CharRecog commentStamp: '<historical>' prior: 0!
Alan Kay's "one-page" character recognizer.  Currently hooked up to text panes and to text morphs, such that you can get it started by hitting cmd-r in such text area that currently has focus.  

To reinitialize the recognition dictionary, evaluate

	CharRecog reinitializeCharacterDictionary

 !


!CharRecog methodsFor: 'recognizer'!
extractFeatures | xl xr yl yh reg px py |
"get extent bounding box"	in _ bmax - bmin. 

"Look for degenerate forms first: . - |"
"look for a dot"				in < (3@3) ifTrue: [^' dot... '].

"Feature 5: turns (these are already in ftrs)"

"Feature 4: absolute size"	in < (10@10) ifTrue: [ftrs _  'SML ', ftrs] ifFalse:
							[in <=  (70@70) ifTrue: [ftrs _ 'REG ', ftrs] ifFalse:
							[in > (70@70) ifTrue: [ftrs _ 'LRG ', ftrs]]].

"Feature 3: aspect ratio"
	"horizontal shape"		((in y = 0) or: [(in x/in y) abs > 3]) ifTrue:
								[ftrs _ 'HOR ', ftrs] ifFalse:
	"vertical shape"			[((in x = 0) or: [(in y/in x) abs >= 3]) ifTrue:
								[ftrs _ 'VER ', ftrs] ifFalse:
	"boxy shape"			[((in x/in y) abs <= 3) ifTrue:
								[ftrs _ 'BOX ', ftrs.
"Now only for boxes"
"Feature 2: endstroke reg"	ftrs _ (self regionOf: (pts last)), ftrs.
							
"Feature 1: startstroke reg"	ftrs _ (self regionOf: (pts contents at: 1)), ftrs.]]].

^ftrs



! !

!CharRecog methodsFor: 'recognizer'!
fourDirsFrom:  p1 to: p2 | ex |

"get the bounding box"		ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"				ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"			((ex y = 0) or: [(ex x/ex y) abs > 1]) ifTrue:
	"look for w-e"					[ex x > 0 ifTrue:[^'WE ']
	"it's an e-w"						ifFalse:[^'EW ']].
"look for vertical line"		((ex x = 0) or: [(ex y/ex x) abs >= 1]) ifTrue:
	"look for n-s"				[(ex y > 0) ifTrue:[ ^'NS ']
	"it's a s-n"						ifFalse:[^'SN ']].

"look for a diagonal			(ex x/ex y) abs <= 2 ifTrue:"
	"se or ne					[ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']."
	"sw or nw									ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']."
! !

!CharRecog methodsFor: 'recognizer'!
recognizeAndDispatch: charDispatchBlock ifUnrecognized: unrecognizedFeaturesBlock until: terminationBlock
	"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true.  This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method.  2/2/96 sw.   2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window.  8/17/96 tk: Turn cr, tab, bs into strings so they work.
	 9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt.  unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none."

	| prv cdir features char r s t dir |

"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
					[terminationBlock value] whileFalse:

"First-Time"			[pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
"ink raw input"			[p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[pts nextPut: t. 
"bounding box"				bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue:
"store new dirs"					[cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 				p place: t; go: 1; place: r]].
 "End Each-Time Loop"

"Last-Time"	
"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
							[unrecognizedFeaturesBlock value: features].

"special chars"		char size > 0 ifTrue:
						[char = 'tab' ifTrue: [char _ Tab].
						char = 'cr' ifTrue:	[char _ CR].
"must be a string"		char class == Character ifTrue: 
							[char _ String with: char].
						char = 'bs' ifTrue:	[char _ BS].
"control the editor"		charDispatchBlock value: char]]]
 ! !

!CharRecog methodsFor: 'recognizer'!
recognizeAndDispatch: charDispatchBlock until: terminationBlock
	"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. 9/18/96 sw"

	^ self recognizeAndDispatch: charDispatchBlock
		ifUnrecognized: 
			[:features | self stringForUnrecognizedFeatures: features]
		until: terminationBlock
 ! !

!CharRecog methodsFor: 'recognizer'!
regionOf: pt 

| px py reg xl yl yh xr rg |
"it's some other character"	rg _ in/3. 	xl _ bmin x + rg x. xr _ bmax x - rg x.
"divide box into 9 regions"				yl _ bmin y + rg y. yh _ bmax y - rg y.

					px _ pt x. py _ pt y.
					reg _ (px < xl ifTrue: [py < yl ifTrue: ['NW ']
										"py >= yl"	ifFalse:[ py < yh ifTrue:['W ']
																	ifFalse: ['SW ']]]
					ifFalse: [px < xr ifTrue: [py < yl ifTrue: ['N ']
													ifFalse: [py < yh ifTrue: ['C ']
																	ifFalse: ['S ']]]
					ifFalse: [py < yl ifTrue: ['NE ']
									ifFalse: [py < yh ifTrue: ['E ']
													ifFalse: ['SE ']]]]).
^reg.
					! !

!CharRecog methodsFor: 'recognizer' stamp: 'di 3/14/1999 16:45'!
stringForUnrecognizedFeatures: features
	"Prompt the user for what string the current features represent, and return the result.  9/18/96 sw"

	| result |
	result _ FillInTheBlank request:
('Not recognized. type char, or "tab", "cr" or "bs",
or hit return to ignore 
', features).

	textMorph ifNotNil:
		[textMorph world displayWorld "take down the FillInTheBlank morph"].

	^ (result = '~' | result = '')
		ifTrue:
			['']
		ifFalse:
			[CharacterDictionary at: features put: result. result]! !


!CharRecog methodsFor: 'morphic dockup' stamp: 'sw 12/16/1998 13:17'!
textMorph: aTextMorph
	textMorph _ aTextMorph! !


!CharRecog methodsFor: 'historical & disused'!
directionFrom: p1 to: p2 | ex |

"This does 8 directions and is not used in current recognizer"
"get the bounding box"		ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"				ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"			((ex y = 0) or: [(ex x/ex y) abs > 2]) ifTrue:
	"look for w-e"					[ex x > 0 ifTrue:[^' we-- ']
	"it's an e-w"						ifFalse:[^' ew-- ']].
"look for vertical line"		((ex x = 0) or: [(ex y/ex x) abs > 2]) ifTrue:
	"look for n-s"				[(ex y > 0) ifTrue:[ ^' ns||']
	"it's a s-n"						ifFalse:[^' sn|| ']].
"look for a diagonal"			(ex x/ex y) abs <= 2 ifTrue:
	"se or ne"					[ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// '].
	"sw or nw"									ex y > 0 ifTrue:[^' sw// ']. ^' nw// '].
! !

!CharRecog methodsFor: 'historical & disused' stamp: 'jm 4/28/1998 05:37'!
learnPrev
	"The character recognized before this one was wrong.  (Got here via the gesture for 'wrong'.)  Bring up a dialog box on that char.  8/21/96 tk"

						| old result |
	old _ CharacterDictionary at: prevFeatures ifAbsent: [^ ''].
"get right char from user"	result _ FillInTheBlank request:
						('Redefine the gesture we thought was "', old asString, '".', '
(Letter or:  tab  cr  wrong  bs  select  caret)
', prevFeatures).

"ignore or..."				(result = '~' | result = '') ifTrue: ['']
"...enter new char"			ifFalse: [
								CharacterDictionary at: prevFeatures 
									put: result].
					"caller erases bad char"
"good char"			^ result! !

!CharRecog methodsFor: 'historical & disused'!
recogPar | prv cdir result features char r s t dir |

"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
		[Sensor anyButtonPressed] whileFalse: [(Sensor mousePoint x < 50) ifTrue: [^''].].

"First-Time"			pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
						[
"ink raw input"			p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[ pts nextPut: t. 
"bounding box"			bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue: [
"store new dirs"					cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 			p place: t; go: 1; place: r.
							].
 "End Each-Time Loop"	].

"Last-Time"	
"start a new recog for next point"	[CharRecog new recognize] fork.

"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
"...or get from user"			[ result _ FillInTheBlank request:
							 'Not recognized. type char, or type ~: ', features.
"ignore or..."				result = '~' ifTrue: ['']
"...enter new char"			ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"		(char = 'cr' ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]). 

"End First-Time Loop"	]. 



			   
 ! !

!CharRecog methodsFor: 'historical & disused'!
recognize | prv cdir result features char r s t dir |

"Alan Kay's recognizer as of 1/31/96.  This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar.  Within the current image, the recognizer is now called via #recognizeAndDispatch:until:"


"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
					[(Sensor mousePoint x) < 50] whileFalse:

"First-Time"			[pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
						[
"ink raw input"			p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[ pts nextPut: t. 
"bounding box"			bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue: [
"store new dirs"					cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 			p place: t; go: 1; place: r.
							].
 "End Each-Time Loop"	].

"Last-Time"	

"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
"...or get from user"			[ result _ FillInTheBlank request:
							 'Not recognized. type char, or type ~: ', features.
"ignore or..."				result = '~' ifTrue: ['']
"...enter new char"			ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"		(char = 'cr' ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]). 

"End First-Time Loop"	]. 

"End Event-Loop" ]. 

			   
 ! !

!CharRecog methodsFor: 'historical & disused'!
recognizeAndPutInTranscript
	"Call Alan's recognizer repeatedly until the mouse is near the left edge of the screen, and dispatch keystrokes inferred to the Trancript.  2/2/96 sw"

	^ self recognizeAndDispatch:

		[:char | (char = 'cr') ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]]

		until:
			[Sensor mousePoint x < 50]

"CharRecog new recognizeAndPutInTranscript"! !

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

CharRecog class
	instanceVariableNames: ''!

!CharRecog class methodsFor: 'initialization'!
initialize
	"Iniitialize the character dictionary if it doesn't exist yet.  2/5/96 sw"

	CharacterDictionary == nil ifTrue:
		[CharacterDictionary _ Dictionary new]! !

!CharRecog class methodsFor: 'initialization'!
reinitializeCharacterDictionary
	"Reset the character dictionary to be empty, ready for a fresh start.  2/5/96 sw"

	CharacterDictionary _ Dictionary new

"CharRecog reinitializeCharacterDictionary" ! !


!CharRecog class methodsFor: 'saving dictionary'!
readRecognizerDictionaryFrom: aFileName
	"Read a fresh version of the Recognizer dictionary in from a file of the given name.  7/26/96 sw"
	"CharRecog readRecognizerDictionaryFrom: 'RecogDictionary.2 fixed'"

   | aReferenceStream |
   aReferenceStream _ ReferenceStream fileNamed: aFileName.
   CharacterDictionary _ aReferenceStream next.
   aReferenceStream close.
! !

!CharRecog class methodsFor: 'saving dictionary'!
saveRecognizerDictionaryTo: aFileName
	"Save the current state of the Recognizer dictionary to disk.  7/26/96 sw"

   | aReferenceStream |
aReferenceStream _ ReferenceStream fileNamed: aFileName.
   aReferenceStream nextPut: CharacterDictionary.
   aReferenceStream close! !
Magnitude subclass: #Character
	instanceVariableNames: 'value '
	classVariableNames: 'CharacterTable '
	poolDictionaries: ''
	category: 'Collections-Text'!
!Character commentStamp: '<historical>' prior: 0!
I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.!


!Character methodsFor: 'accessing'!
asciiValue
	"Answer the value of the receiver that represents its ascii encoding."

	^value! !

!Character methodsFor: 'accessing'!
digitValue
	"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 
	otherwise. This is used to parse literal numbers of radix 2-36."

	value <= $9 asciiValue 
		ifTrue: [^value - $0 asciiValue].
	value >= $A asciiValue 
		ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].
	^ -1! !


!Character methodsFor: 'comparing'!
< aCharacter 
	"Answer true if the receiver's value < aCharacter's value."

	^self asciiValue < aCharacter asciiValue! !

!Character methodsFor: 'comparing'!
= aCharacter 
	"Primitive. Answer true if the receiver and the argument are the same
	object (have the same object pointer) and false otherwise. Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 110>
	^self == aCharacter! !

!Character methodsFor: 'comparing'!
> aCharacter 
	"Answer true if the receiver's value > aCharacter's value."

	^self asciiValue > aCharacter asciiValue! !

!Character methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^value! !


!Character methodsFor: 'testing'!
isAlphaNumeric
	"Answer whether the receiver is a letter or a digit."

	^self isLetter or: [self isDigit]! !

!Character methodsFor: 'testing'!
isDigit
	"Answer whether the receiver is a digit."

	^value >= 48 and: [value <= 57]! !

!Character methodsFor: 'testing'!
isLetter
	"Answer whether the receiver is a letter."

	^(8r141 <= value and: [value <= 8r172])
		or: [8r101 <= value and: [value <= 8r132]]! !

!Character methodsFor: 'testing'!
isLowercase
	"Answer whether the receiver is a lowercase letter.
	(The old implementation answered whether the receiver is not an uppercase letter.)"

	^8r141 <= value and: [value <= 8r172]! !

!Character methodsFor: 'testing' stamp: 'ls 7/26/1998 20:27'!
isSafeForHTTP
	"whether a character is 'safe', or needs to be escaped when used, eg, in a URL"
	^self isAlphaNumeric or: [ '.~-_' includes: self ]! !

!Character methodsFor: 'testing'!
isSeparator
	"Answer whether the receiver is one of the separator characters--space, 
	cr, tab, line feed, or form feed."

	value = 32 ifTrue: [^true].	"space"
	value = 13 ifTrue: [^true].	"cr"
	value = 9 ifTrue: [^true].	"tab"
	value = 10 ifTrue: [^true].	"line feed"
	value = 12 ifTrue: [^true].	"form feed"
	^false! !

!Character methodsFor: 'testing' stamp: 'di 4/3/1999 00:38'!
isSpecial
	"Answer whether the receiver is one of the special characters"

	^'+-/\*~<>=@,%|&?!!' includes: self! !

!Character methodsFor: 'testing'!
isUppercase
	"Answer whether the receiver is an uppercase letter.
	(The old implementation answered whether the receiver is not a lowercase letter.)"

	^8r101 <= value and: [value <= 8r132]! !

!Character methodsFor: 'testing'!
isVowel
	"Answer whether the receiver is one of the vowels, AEIOU, in upper or 
	lower case."

	^'AEIOU' includes: self asUppercase! !

!Character methodsFor: 'testing'!
tokenish
	"Answer whether the receiver is a valid token-character--letter, digit, or 
	colon."

	^self isLetter or: [self isDigit or: [self = $:]]! !


!Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'!
clone
	"Answer with the receiver, because Characters are unique."! !

!Character methodsFor: 'copying'!
copy
	"Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'copying'!
deepCopy
	"Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'copying' stamp: 'tk 1/7/1999 16:50'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied."! !


!Character methodsFor: 'printing'!
hex
	^ String with: ('0123456789ABCDEF' at: value//16+1)
			with:  ('0123456789ABCDEF' at: value\\16+1)! !

!Character methodsFor: 'printing'!
isLiteral

	^true! !

!Character methodsFor: 'printing'!
printOn: aStream

	aStream nextPut: $$.
	aStream nextPut: self! !

!Character methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:04'!
printOnStream: aStream

	aStream print:'$', (String with:self).! !

!Character methodsFor: 'printing'!
storeOn: aStream
	"Character literals are preceded by '$'."

	aStream nextPut: $$; nextPut: self! !


!Character methodsFor: 'converting'!
asCharacter
	"Answer the receiver itself."

	^self! !

!Character methodsFor: 'converting' stamp: 'ls 9/5/1998 01:18'!
asIRCLowercase
	"convert to lowercase, using IRC's rules"

	self == $[ ifTrue: [ ^ ${ ].
	self == $] ifTrue: [ ^ $} ].
	self == $\ ifTrue: [ ^ $| ].

	^self asLowercase! !

!Character methodsFor: 'converting'!
asInteger
	"Answer the value of the receiver."

	^value! !

!Character methodsFor: 'converting'!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	
	(8r101 <= value and: [value <= 8r132])  "self isUppercase"
		ifTrue: [^ Character value: value + 8r40]
		ifFalse: [^ self]! !

!Character methodsFor: 'converting' stamp: 'sma 3/11/2000 17:21'!
asString
	^ String with: self! !

!Character methodsFor: 'converting' stamp: 'SqR 8/23/2000 16:19'!
asSymbol 
	"Answer a Symbol consisting of the receiver as the only element."

	^Symbol intern: self asString! !

!Character methodsFor: 'converting' stamp: 'tk 9/4/2000 12:05'!
asText
	^ self asString asText! !

!Character methodsFor: 'converting'!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	
	(8r141 <= value and: [value <= 8r172])  "self isLowercase"
		ifTrue: [^ Character value: value - 8r40]
		ifFalse: [^ self]! !

!Character methodsFor: 'converting' stamp: 'sma 3/15/2000 22:57'!
isoToSqueak
	"Convert receiver from iso8895-1 (actually CP1252) to mac encoding.
	Does not do lf/cr conversion!! Characters not available in MacRoman
	encoding have been remapped to their base characters or to $?."

	value < 128 ifTrue: [^ self].
	^ Character value: (#(
		219 63 226 196 227 201 160 224 246 228 83 220 206 63 90 63		"80-8F"
		63 212 213 210 211 165 208 209 247 170 115 221 207 63 122 217		"90-9F"
		202 193 162 163 63 180 124 164 172 169 187 199 194 45 168 248	 	"A0-AF"
		161 177 50 51 171 181 166 225 252 49 188 200 63 63 63 192 			"B0-BF"
		203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 	"C0-CF"
		63 132 241 238 239 205 133 42 175 244 242 243 134 89 63 167	 	"D0-DF"
		136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149		"E0-EF"
		63 150 152 151 153 155 154 214 191 157 156 158 159 121 63 216		"F0-FF"
	) at: value - 127)! !

!Character methodsFor: 'converting' stamp: 'bf 3/9/2000 16:52'!
squeakToIso
	"Convert from mac to iso8895-1 encoding. Does not do lf/cr conversion!!"
	value < 128 ifTrue: [^self].
	^ Character value: (#(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 185 176 162 163 167 130 182 223 174 169 142 180 168 173 198 216 141 177 178 179 165 181 166 183 184 160 188 170 186 189 230 248 191 161 172 146 128 129 140 171 187 131 190 192 195 213 145 147 208 132 150 148 149 144 247 215 255 221 152 151 134 153 222 164 136 135 137 139 138 194 202 193 203 200 205 206 207 204 211 212 240 210 218 219 217 155 154 133 143 157 156 158 159 253 254 175) at: value - 127)! !

!Character methodsFor: 'converting'!
to: other
	"Answer with a collection in ascii order -- $a to: $z"
	^ (self asciiValue to: other asciiValue) collect:
				[:ascii | Character value: ascii]! !


!Character methodsFor: 'object fileIn' stamp: 'tk 1/17/2000 11:27'!
comeFullyUpOnReload: smartRefStream
	"Use existing an Character.  Don't use the new copy."

	^ self class value: value! !

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

Character class
	instanceVariableNames: ''!

!Character class methodsFor: 'class initialization'!
initialize
	"Create the table of unique Characters. This code is not shown so that the
	user can not destroy the system by trying to recreate the table."! !


!Character class methodsFor: 'instance creation' stamp: 'ls 8/15/1998 06:56'!
allCharacters
	^ (0 to: 255)
		collect: [:v | Character value: v]

	
! !

!Character class methodsFor: 'instance creation'!
digitValue: x 
	"Answer the Character whose digit value is x. For example, answer $9 for 
	x=9, $0 for x=0, $A for x=10, $Z for x=35."

	| index |
	index _ x asInteger.
	^CharacterTable at: 
		(index < 10
			ifTrue: [48 + index]
			ifFalse: [55 + index])
		+ 1! !

!Character class methodsFor: 'instance creation'!
new
	"Creating new characters is not allowed."

	self error: 'cannot create new characters'! !

!Character class methodsFor: 'instance creation'!
separators
	^ #(32 "space"
		13 "cr"
		9 "tab"
		10 "line feed"
		12 "form feed")
		collect: [:v | Character value: v]

	
! !

!Character class methodsFor: 'instance creation'!
value: anInteger 
	"Answer the Character whose value is anInteger."

	^CharacterTable at: anInteger + 1! !


!Character class methodsFor: 'accessing untypeable characters'!
backspace
	"Answer the Character representing a backspace."

	^self value: 8! !

!Character class methodsFor: 'accessing untypeable characters'!
cr
	"Answer the Character representing a carriage return."

	^self value: 13! !

!Character class methodsFor: 'accessing untypeable characters'!
enter
	"Answer the Character representing enter."

	^self value: 3! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/2/1999 08:06'!
escape
	"Answer the ASCII ESC character"

	^self value: 27! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'sma 3/15/2000 22:33'!
euro
	"The Euro currency sign, that E with two dashes. The key code is a wild guess"

	^ Character value: 219! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'ls 9/8/1998 22:15'!
lf
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: 'accessing untypeable characters'!
linefeed
	"Answer the Character representing a linefeed."

	^self value: 10! !

!Character class methodsFor: 'accessing untypeable characters' stamp: 'sma 3/11/2000 20:47'!
nbsp
	"non-breakable space."

	^ Character value: 202! !

!Character class methodsFor: 'accessing untypeable characters'!
newPage
	"Answer the Character representing a form feed."

	^self value: 12! !

!Character class methodsFor: 'accessing untypeable characters'!
space
	"Answer the Character representing a space."

	^self value: 32! !

!Character class methodsFor: 'accessing untypeable characters'!
tab
	"Answer the Character representing a tab."

	^self value: 9! !


!Character class methodsFor: 'constants' stamp: 'rhi 9/8/2000 14:57'!
alphabet
	"($a to: $z) as: String"

	^ 'abcdefghijklmnopqrstuvwxyz' copy! !

!Character class methodsFor: 'constants'!
characterTable
	"Answer the class variable in which unique Characters are stored."

	^CharacterTable! !
Rectangle subclass: #CharacterBlock
	instanceVariableNames: 'stringIndex text textLine '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!CharacterBlock commentStamp: '<historical>' prior: 0!
My instances contain information about displayed characters. They are used to return the results of methods:
	Paragraph characterBlockAtPoint: aPoint and
	Paragraph characterBlockForIndex: stringIndex.
Any recomposition or movement of a Paragraph can make the instance obsolete.!


!CharacterBlock methodsFor: 'accessing' stamp: 'di 6/7/2000 17:33'!
copy
	"Overridden because Rectangle does a deepCopy, which goes nuts with the text"

	^ self clone! !

!CharacterBlock methodsFor: 'accessing'!
stringIndex
	"Answer the position of the receiver in the string it indexes."

	^stringIndex! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine
	^ textLine! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine: aLine
	textLine _ aLine! !


!CharacterBlock methodsFor: 'comparing'!
< aCharacterBlock 
	"Answer whether the string index of the receiver precedes that of 
	aCharacterBlock."

	^stringIndex < aCharacterBlock stringIndex! !

!CharacterBlock methodsFor: 'comparing'!
<= aCharacterBlock 
	"Answer whether the string index of the receiver does not come after that 
	of aCharacterBlock."

	^(self > aCharacterBlock) not! !

!CharacterBlock methodsFor: 'comparing'!
= aCharacterBlock

	self species = aCharacterBlock species
		ifTrue: [^stringIndex = aCharacterBlock stringIndex]
		ifFalse: [^false]! !

!CharacterBlock methodsFor: 'comparing'!
> aCharacterBlock 
	"Answer whether the string index of the receiver comes after that of 
	aCharacterBlock."

	^aCharacterBlock < self! !

!CharacterBlock methodsFor: 'comparing'!
>= aCharacterBlock 
	"Answer whether the string index of the receiver does not precede that of 
	aCharacterBlock."

	^(self < aCharacterBlock) not! !


!CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'!
printOn: aStream

	aStream nextPutAll: 'a CharacterBlock with index '.
	stringIndex printOn: aStream.
	(text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]])
		ifTrue: [aStream nextPutAll: ' and character '.
				(text at: stringIndex) printOn: aStream].
	aStream nextPutAll: ' and rectangle '.
	super printOn: aStream.
	textLine ifNotNil: [aStream cr; nextPutAll: ' in '.
				textLine printOn: aStream].
! !


!CharacterBlock methodsFor: 'private'!
moveBy: aPoint 
	"Change the corner positions of the receiver so that its area translates by 
	the amount defined by the argument, aPoint."

	origin _ origin + aPoint.
	corner _ corner + aPoint! !

!CharacterBlock methodsFor: 'private' stamp: 'di 10/23/97 22:33'!
stringIndex: anInteger text: aText topLeft: topLeft extent: extent

	stringIndex _ anInteger.
	text _ aText.
	super setOrigin: topLeft corner: topLeft + extent ! !
CharacterScanner subclass: #CharacterBlockScanner
	instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!CharacterBlockScanner commentStamp: '<historical>' prior: 0!
My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.!


!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:51'!
cr 
	"Answer a CharacterBlock that specifies the current location of the mouse 
	relative to a carriage return stop condition that has just been 
	encountered. The ParagraphEditor convention is to denote selections by 
	CharacterBlocks, sometimes including the carriage return (cursor is at 
	the end) and sometimes not (cursor is in the middle of the text)."

	((characterIndex ~= nil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + line lineHeight) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY _ destY +  line lineHeight.
				lastCharacter _ nil.
				characterPoint _ ((text at: lastIndex) = CR
								ifTrue: [leftMargin]
								ifFalse: [nextLeftMargin]) @ destY.
				lastIndex _ lastIndex + 1.
				self lastCharacterExtentSetX: 0.
				^ true].
		lastCharacter _ CR.
		characterPoint _ destX @ destY.
		self lastCharacterExtentSetX: rightMargin - destX.
		^true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 13:09'!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	| leadingTab currentX |
	characterPoint x <= (destX + (lastCharacterExtent x // 2))
		ifTrue:	[lastCharacter _ (text at: lastIndex).
				characterPoint _ destX @ destY.
				^true].
	lastIndex >= line last 
		ifTrue:	[lastCharacter _ (text at: line last).
				characterPoint _ destX @ destY.
				^true].

	"Pointing past middle of a character, return the next character."
	lastIndex _ lastIndex + 1.
	lastCharacter _ text at: lastIndex.
	currentX _ destX + lastCharacterExtent x + kern.
	self lastCharacterExtentSetX: (font widthOf: lastCharacter).
	characterPoint _ currentX @ destY.
	lastCharacter = Space ifFalse: [^ true].

	"Yukky if next character is space or tab."
	textStyle alignment = Justified ifTrue:
		[self lastCharacterExtentSetX:
			(lastCharacterExtent x + 	(line justifiedPadFor: (spaceCount + 1))).
		^ true].

	true ifTrue: [^ true].
	"NOTE:  I find no value to the following code, and so have defeated it - DI"

	"See tabForDisplay for illumination on the following awfulness."
	leadingTab _ true.
	line first to: lastIndex - 1 do:
		[:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]].
	(textStyle alignment ~= Justified or: [leadingTab])
		ifTrue:	[self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX
					leftMargin: leftMargin rightMargin: rightMargin) -
						currentX]
		ifFalse:	[self lastCharacterExtentSetX:  (((currentX + (textStyle tabWidth -
						(line justifiedTabDeltaFor: spaceCount))) -
							currentX) max: 0)].
	^ true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:50'!
endOfRun
	"Before arriving at the cursor location, the selection has encountered an 
	end of run. Answer false if the selection continues, true otherwise. Set 
	up indexes for building the appropriate CharacterBlock."

	| runLength lineStop |
	((characterIndex ~~ nil and:
		[runStopIndex < characterIndex and: [runStopIndex < text size]])
			or:	[characterIndex == nil and: [lastIndex < line last]])
		ifTrue:	["We're really at the end of a real run."
				runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
				characterIndex ~~ nil
					ifTrue:	[lineStop _ characterIndex	"scanning for index"]
					ifFalse:	[lineStop _ line last			"scanning for point"].
				(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
					ifTrue: 	[runStopIndex _ lineStop].
				self setStopConditions.
				^false].

	lastCharacter _ text at: lastIndex.
	characterPoint _ destX @ destY.
	((lastCharacter = Space and: [textStyle alignment = Justified])
		or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
	characterIndex ~~ nil
		ifTrue:	["If scanning for an index and we've stopped on that index,
				then we back destX off by the width of the character stopped on
				(it will be pointing at the right side of the character) and return"
				runStopIndex = characterIndex
					ifTrue:	[self characterPointSetX: destX - lastCharacterExtent x.
							^true].
				"Otherwise the requested index was greater than the length of the
				string.  Return string size + 1 as index, indicate further that off the
				string by setting character to nil and the extent to 0."
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].

	"Scanning for a point and either off the end of the line or off the end of the string."
	runStopIndex = text size
		ifTrue:	["off end of string"
				lastIndex _  lastIndex + 1.
				lastCharacter _ nil.
				self lastCharacterExtentSetX: 0.
				^true].
	"just off end of line without crossing x"
	lastIndex _ lastIndex + 1.
	^true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:51'!
paddedSpace
	"When the line is justified, the spaces will not be the same as the font's 
	space character. A padding of extra space must be considered in trying 
	to find which character the cursor is pointing at. Answer whether the 
	scanning has crossed the cursor."

	| pad |
	pad _ 0.
	spaceCount _ spaceCount + 1.
	pad _ line justifiedPadFor: spaceCount.
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX:  spaceWidth + pad.
	(destX + lastSpaceOrTabExtent x)  >= characterPoint x
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
				^self crossedX].
	lastIndex _ lastIndex + 1.
	destX _ destX + lastSpaceOrTabExtent x.
	^ false
! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:32'!
setFont
	specialWidth _ nil.
	super setFont! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:47'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	textStyle alignment = Justified ifTrue:[
		"Make a local copy of stop conditions so we don't modify the default"
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:50'!
tab
	| currentX |
	currentX _ (textStyle alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse:
			[textStyle
				nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].
	lastSpaceOrTabExtent _ lastCharacterExtent copy.
	self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
	currentX >= characterPoint x
		ifTrue: 
			[lastCharacterExtent _ lastSpaceOrTabExtent copy.
			^ self crossedX].
	destX _ currentX.
	lastIndex _ lastIndex + 1.
	^false! !


!CharacterBlockScanner methodsFor: 'private' stamp: 'di 9/3/2000 15:44'!
buildCharacterBlockIn: para
	| lineIndex runLength lineStop done stopCondition |
	"handle nullText"
	(para numberOfLines = 0 or: [text size = 0])
		ifTrue:	[^ CharacterBlock new stringIndex: 1  "like being off end of string"
					text: para text
					topLeft: (para leftMarginForDisplayForLine: 1)
								@ para compositionRectangle top
					extent: 0 @ textStyle lineGrid].
	"find the line"
	lineIndex _ para lineIndexOfTop: characterPoint y.
	destY _ para topAtLineIndex: lineIndex.
	line _ para lines at: lineIndex.
	rightMargin _ para rightMarginForDisplay.

	(lineIndex = para numberOfLines and:
		[(destY + line lineHeight) < characterPoint y])
			ifTrue:	["if beyond lastLine, force search to last character"
					self characterPointSetX: rightMargin]
			ifFalse:	[characterPoint y < (para compositionRectangle) top
						ifTrue: ["force search to first line"
								characterPoint _ (para compositionRectangle) topLeft].
					characterPoint x > rightMargin
						ifTrue:	[self characterPointSetX: rightMargin]].
	destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex).
	nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1.
	lastIndex _ line first.

	self setStopConditions.		"also sets font"
	runLength _ (text runLengthFor: line first).
	characterIndex == nil
		ifTrue:	[lineStop _ line last  "characterBlockAtPoint"]
		ifFalse:	[lineStop _ characterIndex  "characterBlockForIndex"].
	(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
		ifTrue:	[runStopIndex _ lineStop].
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0. done  _ false.

	[done]
	whileFalse:
	[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.

	"see setStopConditions for stopping conditions for character block 	operations."
	self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).
	(self perform: stopCondition) ifTrue:
		[characterIndex == nil
			ifTrue: ["characterBlockAtPoint"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + (font descentKern @ 0)
						extent: lastCharacterExtent]
			ifFalse: ["characterBlockForIndex"
					^ CharacterBlock new stringIndex: lastIndex text: text
						topLeft: characterPoint + ((font descentKern) - kern @ 0)
						extent: lastCharacterExtent]]]! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
characterPointSetX: xVal
	characterPoint _ xVal @ characterPoint y! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
lastCharacterExtentSetX: xVal
	lastCharacterExtent _ xVal @ lastCharacterExtent y! !

!CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'!
lastSpaceOrTabExtentSetX: xVal
	lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! !


!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 19:14'!
characterBlockAtPoint: aPoint in: aParagraph
	"Answer a CharacterBlock for character in aParagraph at point aPoint. It 
	is assumed that aPoint has been transformed into coordinates appropriate 
	to the text's destination form rectangle and the composition rectangle."

	self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
	characterPoint _ aPoint.
	^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'di 9/3/2000 11:39'!
characterBlockAtPoint: aPoint index: index in: textLine
	"This method is the Morphic characterBlock finder.  It combines
	MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:"
	| runLength lineStop done stopCondition |
	line _ textLine.
	characterIndex _ index.  " == nil means scanning for point"
	characterPoint _ aPoint.
	(characterPoint == nil or: [characterPoint y > line bottom])
		ifTrue: [characterPoint _ line bottomRight].
	(text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
				or: [characterIndex ~~ nil and: [characterIndex < line first]]])
		ifTrue:	[^ (CharacterBlock new stringIndex: line first text: text
					topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
					textLine: line].
	rightMargin _ line rightMargin.
	destX _ leftMargin _ line leftMarginForAlignment: textStyle alignment.
	destY _ line top.
	lastIndex _ line first.
	self setStopConditions.		"also sets font"
	runLength _ text runLengthFor: line first.
	characterIndex ~~ nil
		ifTrue:	[lineStop _ characterIndex  "scanning for index"]
		ifFalse:	[lineStop _ line last  "scanning for point"].
	runStopIndex _ lastIndex + (runLength - 1) min: lineStop.
	lastCharacterExtent _ 0 @ line lineHeight.
	spaceCount _ 0.

	done  _ false.
	[done] whileFalse:
		[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions kern: kern.
		"see setStopConditions for stopping conditions for character block 	operations."
		self lastCharacterExtentSetX: (specialWidth == nil
			ifTrue: [font widthOf: (text at: lastIndex)]
			ifFalse: [specialWidth]).
		(self perform: stopCondition) ifTrue:
			[characterIndex == nil
				ifTrue: ["Result for characterBlockAtPoint: "
						^ (CharacterBlock new stringIndex: lastIndex
							text: text topLeft: characterPoint + (font descentKern @ 0)
							extent: lastCharacterExtent - (font baseKern @ 0))
									textLine: line]
				ifFalse: ["Result for characterBlockForIndex: "
						^ (CharacterBlock new stringIndex: characterIndex
							text: text topLeft: characterPoint + ((font descentKern) - kern @ 0)
							extent: lastCharacterExtent)
									textLine: line]]]! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 19:14'!
characterBlockForIndex: targetIndex in: aParagraph 
	"Answer a CharacterBlock for character in aParagraph at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destination form rectangle and the composition rectangle."

	self 
		initializeFromParagraph: aParagraph 
		clippedBy: aParagraph clippingRectangle.
	characterIndex _ targetIndex.
	characterPoint _ 
		aParagraph rightMarginForDisplay @ 
			(aParagraph topAtLineIndex: 
				(aParagraph lineIndexOfCharacterIndex: characterIndex)).
	^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/19/2000 14:46'!
characterNotInFont 
	"See the note in CharacterScanner>>characterNotInFont.
	This does not handle character selection nicely, i.e., illegal characters are a 
	little tricky to select.  Since the end of a run or line is subverted here by actually
	having the scanner scan a different string in order to manage the illegal 
	character, things are not in an absolutely correct state for the character 
	location code.  If this becomes too odious in use, logic will be added to accurately 
	manage the situation."

	lastCharacterExtent _ 
		(font widthOf: (font maxAscii + 1) asCharacter) @ line lineHeight.
	^super characterNotInFont! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 17:35'!
placeEmbeddedObject: anchoredMorph
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	specialWidth _ anchoredMorph width.
	^ true! !
Object subclass: #CharacterScanner
	instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel '
	classVariableNames: 'DefaultStopConditions '
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!CharacterScanner commentStamp: '<historical>' prior: 0!
My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.!


!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
addEmphasis: code
	"Set the bold-ital-under-strike emphasis."
	emphasisCode _ emphasisCode bitOr: code! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
addKern: kernDelta
	"Set the current kern amount."
	kern _ kern + kernDelta! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 5/17/2000 17:13'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	text _ aParagraph text.
	textStyle _ aParagraph textStyle. 
! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'!
setActualFont: aFont
	"Set the basal font to an isolated font reference."

	font _ aFont! !

!CharacterScanner methodsFor: 'private' stamp: 'di 9/3/2000 13:47'!
setFont
	| priorFont |
	"Set the font and other emphasis."
	priorFont _ font.
	text == nil ifFalse:[
		emphasisCode _ 0.
		kern _ 0.
		indentationLevel _ 0.
		alignment _ textStyle alignment.
		font _ nil.
		(text attributesAt: lastIndex forStyle: textStyle)
			do: [:att | att emphasizeScanner: self]].
	font == nil ifTrue:
		[self setFont: textStyle defaultFontIndex].
	font _ font emphasized: emphasisCode.
	priorFont ifNotNil: [destX _ destX + priorFont descentKern].
	destX _ destX - font descentKern.
	"NOTE: next statement should be removed when clipping works"
	leftMargin ifNotNil: [destX _ destX max: leftMargin].
	kern _ kern - font baseKern.

	"Install various parameters from the font."
	spaceWidth _ font widthOf: Space.
	xTable _ font xTable.
	map _ font characterToGlyphMap.
	stopConditions _ DefaultStopConditions.! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
setFont: fontNumber
	"Set the font by number from the textStyle."

	self setActualFont: (textStyle fontAt: fontNumber)! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
text: t textStyle: ts
	text _ t.
	textStyle _ ts! !

!CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'!
textColor: ignored
	"Overridden in DisplayScanner"! !


!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/19/2000 14:45'!
characterNotInFont
	"Note: All fonts should have some sort of a character to glyph mapping.
	If a character is not in the font it should be mapped to the appropriate
	glyph (that is the glyph describing a non-existing character). If done
	correctly, this method should never be called. It is mainly provided
	for backward compatibility (and I'd really like to get rid of it - ar).

	All fonts have an illegal character to be used when a character is not 
	within the font's legal range. When characters out of ranged are 
	encountered in scanning text, then this special character indicates the 
	appropriate behavior. The character is usually treated as a unary 
	message understood by a subclass of CharacterScanner."

	| illegalAsciiString saveIndex stopCondition | 
	saveIndex _ lastIndex.
	illegalAsciiString _ String with: (font maxAscii + 1) asCharacter.
	stopCondition _ self scanCharactersFrom: 1 to: 1
			in: illegalAsciiString
			rightX: rightMargin stopConditions: stopConditions
			kern: kern.
	lastIndex _ saveIndex + 1.
	stopCondition ~= (stopConditions at: EndOfRun)
		ifTrue:	[^self perform: stopCondition]
		ifFalse: [lastIndex = runStopIndex
					ifTrue:	[^self perform: (stopConditions at: EndOfRun)].
				^false]
! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 18:20'!
indentationLevel
	"return the number of tabs that are currently being placed at the beginning of each line"
	^indentationLevel ifNil:[0]! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'!
indentationLevel: anInteger
	"set the number of tabs to put at the beginning of each line"
	indentationLevel _ anInteger! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'!
leadingTab
	"return true if only tabs lie to the left"
	line first to: lastIndex do:
		[:i | (text at: i) == Tab ifFalse: [^ false]].
	^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 18:20'!
placeEmbeddedObject: anchoredMorph
	"Place the anchoredMorph or return false if it cannot be placed.
	In any event, advance destX by its width."
	| w |
	destX _ destX + (w _ anchoredMorph width).
	(destX > rightMargin and: [(leftMargin + w) <= rightMargin])
		ifTrue: ["Won't fit, but would on next line"
				^ false].
	lastIndex _ lastIndex + 1.
	self setFont.  "Force recalculation of emphasis for next run"
	^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/23/2000 12:59'!
primScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
	"Primitive. This is the inner loop of text display--but see 
	scanCharactersFrom: to:rightX: which would get the string, 
	stopConditions and displaying from the instance. March through source 
	String from startIndex to stopIndex. If any character is flagged with a 
	non-nil entry in stops, then return the corresponding value. Determine 
	width of each character from xTable, indexed by map. 
	If dextX would exceed rightX, then return stops at: 258. 
	Advance destX by the width of the character. If stopIndex has been
	reached, then return stops at: 257. Optional. 
	See Object documentation whatIsAPrimitive."
	| ascii nextDestX char |
	<primitive: 103>
	lastIndex _ startIndex.
	[lastIndex <= stopIndex]
		whileTrue: 
			[char _ (sourceString at: lastIndex).
			ascii _ char asciiValue + 1.
			(stops at: ascii) == nil ifFalse: [^stops at: ascii].
			"Note: The following is querying the font about the width
			since the primitive may have failed due to a non-trivial
			mapping of characters to glyphs or a non-existing xTable."
			nextDestX _ destX + (font widthOf: char).
			nextDestX > rightX ifTrue: [^stops at: CrossedX].
			destX _ nextDestX + kernDelta.
			lastIndex _ lastIndex + 1].
	lastIndex _ stopIndex.
	^stops at: EndOfRun! !

!CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/19/2000 14:42'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta
	"This method will perform text scanning with kerning."
	line first = startIndex ifTrue: [
		"handle indentation"
		self indentationLevel timesRepeat: [ self tab ] ].
	^self primScanCharactersFrom: startIndex to: stopIndex in: sourceString 
			rightX: rightX stopConditions: stops kern: kernDelta
! !


!CharacterScanner methodsFor: 'initialize' stamp: 'ar 5/17/2000 17:33'!
initialize
	destX _ destY _ 0.! !


!CharacterScanner methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 13:31'!
setYFor: anchoredMorph

! !

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

CharacterScanner class
	instanceVariableNames: ''!

!CharacterScanner class methodsFor: 'class initialization' stamp: 'ar 5/18/2000 16:50'!
initialize
	"CharacterScanner initialize"
	"NewCharacterScanner initialize"
	| stopConditions |
	stopConditions _ Array new: 258.
	stopConditions atAllPut: nil.
	stopConditions at: Space asciiValue + 1 put: nil.
	stopConditions at: Tab asciiValue + 1 put: #tab.
	stopConditions at: CR asciiValue + 1 put: #cr.
	stopConditions at: EndOfRun put: #endOfRun.
	stopConditions at: CrossedX put: #crossedX.
	DefaultStopConditions _ stopConditions.! !


!CharacterScanner class methodsFor: 'instance creation' stamp: 'ar 1/8/2000 15:00'!
new
	^super new initialize! !
Collection subclass: #CharacterSet
	instanceVariableNames: 'map '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!CharacterSet commentStamp: '<historical>' prior: 0!
A set of characters.  Lookups for inclusion are very fast.!


!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:33'!
add: aCharacter
	map at: aCharacter asciiValue+1  put: 1.! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:41'!
do: aBlock
	"evaluate aBlock with each character in the set"

	Character allCharacters do: [ :c |
		(self includes: c) ifTrue: [ aBlock value: c ] ]
! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:31'!
includes: aCharacter
	^(map at: aCharacter asciiValue + 1) > 0! !

!CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:34'!
remove: aCharacter
	map at: aCharacter asciiValue + 1  put: 0! !


!CharacterSet methodsFor: 'conversion' stamp: 'ls 8/17/1998 20:39'!
complement
	"return a character set containing precisely the characters the receiver does not"
	| set |
	set _ CharacterSet allCharacters.
	self do: [ :c | set remove: c ].
	^set! !


!CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'!
= anObject
	^self class == anObject class and: [
		self byteArrayMap = anObject byteArrayMap ]! !

!CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'!
hash
	^self byteArrayMap hash! !


!CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:35'!
byteArrayMap
	"return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't.  Intended for use by primitives only"
	^map! !

!CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:30'!
initialize
	map _ ByteArray new: 256 withAll: 0.! !

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

CharacterSet class
	instanceVariableNames: ''!

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:42'!
allCharacters
	"return a set containing all characters"

	| set |
	set _ self empty.
	0 to: 255 do: [ :ascii | set add: (Character value: ascii) ].
	^set! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:36'!
empty
 	"return an empty set of characters"
	^super new initialize! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:31'!
new
	^super new initialize! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 1/3/1999 12:52'!
newFrom: aCollection
	| newCollection |
	newCollection _ self new.
	newCollection addAll: aCollection.
	^newCollection! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'!
nonSeparators
	"return a set containing everything but the whitespace characters"

	^self separators complement! !

!CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'!
separators
	"return a set containing just the whitespace characters"

	| set |
	set _ self empty.
	set addAll: Character separators.
	^set! !
SimpleButtonMorph subclass: #ChatButtonMorph
	instanceVariableNames: 'actionDownSelector actionUpSelector labelDown labelUp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Audio-Chat'!

!ChatButtonMorph methodsFor: 'initialization' stamp: 'Tbp 4/11/2000 16:13'!
setDefaultLabel
	self label: 'Flash'.
! !


!ChatButtonMorph methodsFor: 'accessing' stamp: 'Tbp 4/11/2000 16:25'!
actionDownSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	['nil' = aSymbolOrString or:
	[aSymbolOrString isEmpty]])
		ifTrue: [^actionDownSelector _ nil].

	actionDownSelector _ aSymbolOrString asSymbol.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'Tbp 4/11/2000 16:27'!
actionUpSelector: aSymbolOrString


	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionUpSelector _ nil].

	actionUpSelector _ aSymbolOrString asSymbol.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'Tbp 4/11/2000 16:31'!
labelDown: aString

	labelDown _ aString.! !

!ChatButtonMorph methodsFor: 'accessing' stamp: 'Tbp 4/11/2000 16:32'!
labelUp: aString

	labelUp _ aString! !


!ChatButtonMorph methodsFor: 'events' stamp: 'Tbp 4/11/2000 16:19'!
doButtonDownAction

	(target ~~ nil and: [actionDownSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionDownSelector]].! !

!ChatButtonMorph methodsFor: 'events' stamp: 'Tbp 4/11/2000 16:20'!
doButtonUpAction

	(target ~~ nil and: [actionUpSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionUpSelector]].! !

!ChatButtonMorph methodsFor: 'events' stamp: 'RAA 8/6/2000 18:30'!
mouseDown: evt

	oldColor _ color.
	self label: labelDown.
	self doButtonDownAction.

! !

!ChatButtonMorph methodsFor: 'events' stamp: 'RAA 8/6/2000 18:37'!
mouseUp: evt

	"if oldColor nil, it signals that mouse had not gone DOWN inside me, e.g. because of a cmd-drag; in this case we want to avoid triggering the action!!"

	oldColor ifNil: [^self].
	self color: oldColor.
	(self containsPoint: evt cursorPoint) ifTrue: [
		self label: labelUp.
		self doButtonUpAction.
	].
! !
StringHolder subclass: #ChatNotes
	instanceVariableNames: 'name notesIndex names notes recorder player sound isPlaying isRecording isSaving nameTextMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Audio-Chat'!

!ChatNotes methodsFor: 'accessing' stamp: 'RAA 8/1/2000 17:59'!
name

	^name ifNil: [name _ '']! !

!ChatNotes methodsFor: 'accessing' stamp: 'TBP 2/23/2000 21:07'!
name: aString
	name _ aString.
	self changed: #name.! !

!ChatNotes methodsFor: 'accessing' stamp: 'RAA 8/1/2000 18:01'!
notesList
	
	self flag: #why.
	^names copy asArray! !

!ChatNotes methodsFor: 'accessing' stamp: 'RAA 8/1/2000 18:02'!
notesListIndex

	^notesIndex ifNil: [notesIndex _ 0]! !

!ChatNotes methodsFor: 'accessing' stamp: 'RAA 8/1/2000 18:02'!
notesListIndex: index
	
	notesIndex _ index = notesIndex ifTrue: [0] ifFalse: [index].
	self name: (self notesList at: notesIndex ifAbsent: ['']).
	self changed: #notesListIndex.! !

!ChatNotes methodsFor: 'accessing' stamp: 'TBP 2/23/2000 21:07'!
recorder
	^recorder! !


!ChatNotes methodsFor: 'button commands' stamp: 'RAA 8/1/2000 19:05'!
record

	self isRecording: true.
	notesIndex = 0 ifFalse: [self notesListIndex: 0].
	sound _ nil.
	recorder clearRecordedSound.
	recorder resumeRecording.! !

!ChatNotes methodsFor: 'button commands' stamp: 'RAA 8/1/2000 18:03'!
save

	self isSaving: true.
	notesIndex = 0
		ifTrue: [self saveSound]
		ifFalse: [self saveName].
	self isSaving: false.! !

!ChatNotes methodsFor: 'button commands' stamp: 'TBP 2/23/2000 21:07'!
stop
	recorder pause.
	self isRecording: false! !


!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:03'!
isPlaying

	^isPlaying ifNil: [isPlaying _ false]! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:04'!
isPlaying: aBoolean

	isPlaying = aBoolean ifTrue: [^self].
	isPlaying _ aBoolean.
	self changed: #isPlaying	! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:04'!
isRecording

	^isRecording ifNil: [isRecording _ false]! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:05'!
isRecording: aBoolean
	
	isRecording = aBoolean ifTrue: [^self].
	isRecording _ aBoolean.
	self changed: #isRecording	! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:05'!
isSaving

	^isSaving ifNil: [isSaving _ false]! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:05'!
isSaving: aBoolean

	isSaving = aBoolean ifTrue: [^self].
	isSaving _ aBoolean.
	self changed: #isSaving! !

!ChatNotes methodsFor: 'testing' stamp: 'RAA 8/1/2000 18:05'!
isStopped

	^false! !


!ChatNotes methodsFor: 'initialization' stamp: 'RAA 8/1/2000 18:05'!
initialize

	self loadNotes.
	notesIndex _ 0.
	recorder _ ChatRecorder new.
	recorder initialize.! !

!ChatNotes methodsFor: 'initialization' stamp: 'RAA 8/1/2000 18:09'!
loadNotes
	"Load notes from the files"
	| dir |

	names _ OrderedCollection new.
	notes _ OrderedCollection new.
	(FileDirectory default directoryExists: 'audio')
		ifFalse: [FileDirectory default createDirectory: 'audio'].
	dir _ self audioDirectory.
	dir fileNames do: [:fname |
		(fname endsWith: '.name') ifTrue: [
			names add: ((dir fileNamed: fname) contentsOfEntireFile).
			notes add: (fname copyFrom: 1 to: (fname size - 4))]].! !

!ChatNotes methodsFor: 'initialization' stamp: 'RAA 8/2/2000 01:15'!
openAsMorph
	| window aColor recordButton stopButton playButton saveButton |

	window _ (SystemWindow labelled: 'Audio Notes') model: self.

	window addMorph: (
		(PluggableListMorph 
			on: self 
			list: #notesList 
			selected: #notesListIndex 
			changeSelected: #notesListIndex: 
			menu: #notesMenu:
		) autoDeselect: false) frame: (0@0 corner: 0.5@1.0).

	nameTextMorph _ PluggableTextMorph on: self text: #name accept: nil.
	nameTextMorph askBeforeDiscardingEdits: false.
	window addMorph: nameTextMorph frame: (0.5@0 corner: 1.0@0.4).

	aColor _ Color colorFrom: self defaultBackgroundColor.

	(recordButton _ PluggableButtonMorph on: self getState: #isRecording action: #record)
		label: 'record';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: recordButton frame: (0.5@0.4 corner: 0.75@0.7).

	(stopButton _ PluggableButtonMorph on: self getState: #isStopped action: #stop)
		label: 'stop';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: stopButton frame: (0.75@0.4 corner: 1.0@0.7).

	(playButton _ PluggableButtonMorph on: self getState: #isPlaying action: #play)
		label: 'play';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: playButton frame: (0.5@0.7 corner: 0.75@1.0).

	(saveButton _ PluggableButtonMorph on: self getState: #isSaving action: #save)
		label: 'save';
		askBeforeChanging: true;
		color: aColor;
		onColor: aColor darker offColor: aColor.
	window addMorph: saveButton frame: (0.75@0.7 corner: 1.0@1.0).

	window openInWorld.! !


!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
defaultBackgroundColor
	"In a better design, this would be handled by preferences."
	^Color r: 1.0 g: 0.7 b: 0.8! !

!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
initialExtent
	"Nice and small--that was the idea.
	It shouldn't take up much screen real estate."
	^200@100! !

!ChatNotes methodsFor: 'morphic' stamp: 'TBP 2/23/2000 21:07'!
notesMenu: aMenu
	"Simple menu to delete notes"
	^(notesIndex = 0)
		ifTrue: [aMenu labels: 'update notes' lines: #() selections: #(updateNotes)]
		ifFalse: [aMenu labels: ('delete', String cr, 'update notes') lines: #() selections: #(deleteSelection updateNotes)]! !

!ChatNotes methodsFor: 'morphic' stamp: 'RAA 8/2/2000 01:11'!
textMorphString

	^nameTextMorph text string! !


!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/1/2000 18:08'!
audioDirectory

	^FileDirectory default directoryNamed: 'audio'! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/1/2000 18:08'!
deleteSelection
	"Delete the selection in the list"
	| dir |

	notesIndex <= 0 ifTrue: [^self].
	dir _ self audioDirectory.
	dir deleteFileNamed: ((notes at: notesIndex), 'name') ifAbsent: [].
	dir deleteFileNamed: ((notes at: notesIndex), 'aiff') ifAbsent: [].
	names removeAt: notesIndex.
	notes removeAt: notesIndex.
	self notesListIndex: 0.
	self changed: #notesList.
	self changed: #name.! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/1/2000 18:09'!
getNextName
	"Return the next name available.
	All names are of the form '#.name' and '#.aiff'."
	| dir num |

	dir _ self audioDirectory.
	num _ 1.
	[dir fileExists: (num asString, '.name')] whileTrue: [num _ num + 1].
	^(num asString, '.')! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/1/2000 19:05'!
play
	| separator |
	self isPlaying: true.
	notesIndex = 0 ifTrue: [
		recorder pause.
		recorder playback.
		self isPlaying: false.
		^self
	].
	separator _ FileDirectory pathNameDelimiter asString.
	sound _ (AIFFFileReader new readFromFile: (
		FileDirectory default pathName, 
		separator, 'audio', separator, (notes at: notesIndex), 'aiff')) sound.
	[
		sound playAndWaitUntilDone.
		self isPlaying: false
	] fork! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/2/2000 01:09'!
saveName
	"Save the name to the '.name' file."
	| dir file |

	self name: self textMorphString.
	dir _ self audioDirectory.
	file _ (notes at: notesIndex), 'name'.
	(dir fileExists: file) ifTrue: [dir deleteFileNamed: file].
	file _ dir newFileNamed: file.
	file nextPutAll: name.
	file close.
	names at: notesIndex put: name.
	self changed: #notesList.! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/2/2000 01:09'!
saveSound
	"Move the sound from the recorder to the files."
	| fname file |
	
	recorder recordedSound ifNil: [^self].
	self isSaving: true.
	fname _ self getNextName.
	"Create .name file"
	file _ self audioDirectory newFileNamed: (fname, 'name').
	file nextPutAll: self textMorphString.
	file close.
	"Create .aiff file"
	file _ (self audioDirectory newFileNamed: (fname, 'aiff')) binary.
	self storeAIFFOnFile: file.
	file close.
	"Add to names and notes"
	names add: self textMorphString.
	notes add: fname.
	self changed: #notesList.
	self notesListIndex: (notes size).
	"Clear Recorder"
	recorder _ SoundRecorder new.
	"Stop Button"
	self isSaving: false! !

!ChatNotes methodsFor: 'file i/o' stamp: 'RAA 8/1/2000 18:12'!
storeAIFFOnFile: file
	"In a better design, this would be handled by SequentialSound,
	but I figure you will need a new primitive anyway, so it can
	be implemented at that time."
	| sampleCount s |

	sampleCount _ recorder recordedSound sounds inject: 0 into: [ :sum :rsound |
		sum + rsound samples monoSampleCount
	].
	file nextPutAll: 'FORM' asByteArray.
	file nextInt32Put: (2 * sampleCount) + 46.
	file nextPutAll: 'AIFF' asByteArray.
	file nextPutAll: 'COMM' asByteArray.
	file nextInt32Put: 18.
	file nextNumber: 2 put: 1. "channels"
	file nextInt32Put: sampleCount.
	file nextNumber: 2 put: 16. "bits/sample"
	(AbstractSound new) storeExtendedFloat: (recorder samplingRate) on: file.
	file nextPutAll: 'SSND' asByteArray.
	file nextInt32Put: (2 * sampleCount) + 8.
	file nextInt32Put: 0.
	file nextInt32Put: 0.
	(recorder recordedSound sounds) do: [:rsound |
		1 to: (rsound samples monoSampleCount) do: [:i |
			s _ rsound samples at: i.
			file nextPut: ((s bitShift: -8) bitAnd: 16rFF).
			file nextPut: (s bitAnd: 16rFF)]].! !

!ChatNotes methodsFor: 'file i/o' stamp: 'TBP 2/23/2000 21:07'!
updateNotes
	"Probably not necessary unless several audio notes are
	open at the same time"

	"Clear Notes"
	self loadNotes.
	self changed: #notesList.
	self notesListIndex: 0.
	self name: ''.! !

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

ChatNotes class
	instanceVariableNames: ''!

!ChatNotes class methodsFor: 'instance creation' stamp: 'RAA 8/2/2000 01:06'!
openAsMorph

	^self new openAsMorph! !
ServerAction subclass: #ChatPage
	instanceVariableNames: 'current '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!ChatPage commentStamp: '<historical>' prior: 0!
Simple ServerAction that allows a primitive chat session shown as a web page.  It maintains a list of the 20 most recent submissions.  There is a form on the page for typing your contribution to the session. 

The default Swiki has a chat page enabled.

Get to the page by this URL:
machine:80/chat!


!ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/25/97 13:33'!
add: aMessage 
	current isNil ifTrue: [current _ OrderedCollection new].
	current add: aMessage.
	(current size > 20) 
		ifTrue: [current _ current copyFrom: (current size - 20) to: (current size)]! !

!ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/17/97 13:32'!
current
	^current
! !


!ChatPage methodsFor: 'URL processing' stamp: 'mjg 11/25/97 13:34'!
process: request 
	| author note |
	request fields isNil
		ifTrue: 
			[current isNil ifTrue: [current _ OrderedCollection new].
			request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html')
					with: current)]
		ifFalse: 
			[author _ request fields at: 'author'.
			note _ request fields at: 'note'.
			self add: '<b>' , author , '</b> 
			<i>' , Time now printString , '-' , Date today printString , '</i><p>' , note , '<p>'.
			request fields at: 'current' put: current.
			request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html')
					with: request)]! !
SoundRecorder subclass: #ChatRecorder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Audio-Chat'!

!ChatRecorder methodsFor: 'accessing' stamp: 'TBP 2/23/2000 20:54'!
recordedSound: aSound

	self clearRecordedSound.
	recordedSound _ aSound.! !


!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'RAA 8/11/2000 09:47'!
initialize
	
	"setting a higher desired recording rate seemed to fix certain powerbook problems.
	I'm still trying to understand it all, but there it is for now"

	super initialize.
	samplingRate _ 44100.

! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'RAA 8/13/2000 11:34'!
pause
	"Go into pause mode. The record level continues to be updated, but no sound is recorded."

	paused _ true.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer.
				self allocateBuffer].

	soundPlaying ifNotNil: [
		soundPlaying pause.
		soundPlaying _ nil].

	self stopRecording.

	"Preferences canRecordWhilePlaying ifFalse: [self stopRecording]."
! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'RAA 8/13/2000 11:34'!
playback
	"Playback the sound that has been recorded."

	self pause.
	soundPlaying _ self recordedSound ifNil: [^self].
	soundPlaying play.
! !

!ChatRecorder methodsFor: 'as yet unclassified' stamp: 'RAA 8/13/2000 11:38'!
resumeRecording
	"Continue recording from the point at which it was last paused."

	self startRecording.
	paused _ false.
! !
EllipseMorph subclass: #ChineseCheckerPiece
	instanceVariableNames: 'boardLoc myBoard '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!ChineseCheckerPiece commentStamp: '<historical>' prior: 0!
I represent a player piece for Chinese Checkers.  Mostly I act as an ellipse, but my special methods ensure that I cannot be picked up or dropped except in the proper circumstances.

Structure:
 myBoard		a ChineseCheckers morph
 boardLoc		my current logical position on the board.
!


!ChineseCheckerPiece methodsFor: 'all' stamp: 'di 4/9/2000 08:31'!
boardLoc

	^ boardLoc! !

!ChineseCheckerPiece methodsFor: 'all' stamp: 'di 4/11/2000 08:36'!
handlesMouseDown: evt

	^ true! !

!ChineseCheckerPiece methodsFor: 'all' stamp: 'ar 10/5/2000 20:02'!
justDroppedInto: newOwner event: evt

	newOwner == myBoard ifFalse:
		["Only allow dropping into my board."
		^self rejectDropMorphEvent: evt].
	^super justDroppedInto: newOwner event: evt! !

!ChineseCheckerPiece methodsFor: 'all' stamp: 'di 4/9/2000 09:27'!
mouseDown: evt

	((owner isKindOf: ChineseCheckers)
		and: [owner okToPickUpPieceAt: boardLoc])
		ifTrue: [evt hand grabMorph: self]! !

!ChineseCheckerPiece methodsFor: 'all' stamp: 'di 4/11/2000 08:34'!
setBoard: aBoard loc: aBoardLoc

	myBoard _ aBoard.
	boardLoc _ aBoardLoc! !

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

ChineseCheckerPiece class
	instanceVariableNames: ''!

!ChineseCheckerPiece class methodsFor: 'as yet unclassified' stamp: 'di 4/9/2000 11:17'!
includeInNewMorphMenu

	^ false! !
BorderedMorph subclass: #ChineseCheckers
	instanceVariableNames: 'board sixDeltas teams homes autoPlay whoseMove plannedMove plannedMovePhase colors movePhase animateMoves pathMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!ChineseCheckers commentStamp: '<historical>' prior: 0!
An implementation of Chinese Checkers by Dan Ingalls.  April 9, 2000.

board:  A 19x19 rhombic array, addressed by row@col points, in which is imbedded the familiar six-pointed layout of cells.  A cell outside the board is nil (-).
  - - - - - - - - - - - - - - - - - - -
   - - - - - - - - - - - - - 5 - - - - -
    - - - - - - - - - - - - 5 5 - - - - -
     - - - - - - - - - - - 5 5 5 - - - - -
      - - - - - - - - - - 5 5 5 5 - - - - -
       - - - - - 6 6 6 6 0 0 0 0 0 4 4 4 4 -
        - - - - - 6 6 6 0 0 0 0 0 0 4 4 4 - -
         - - - - - 6 6 0 0 0 0 0 0 0 4 4 - - -
          - - - - - 6 0 0 0 0 0 0 0 0 4 - - - -
           - - - - - 0 0 0 0 0 0 0 0 0 - - - - -
            - - - - 1 0 0 0 0 0 0 0 0 3 - - - - -
             - - - 1 1 0 0 0 0 0 0 0 3 3 - - - - -
              - - 1 1 1 0 0 0 0 0 0 3 3 3 - - - - -
               - 1 1 1 1 0 0 0 0 0 3 3 3 3 - - - - -
                - - - - - 2 2 2 2 - - - - - - - - - -
                 - - - - - 2 2 2 - - - - - - - - - - -
                  - - - - - 2 2 - - - - - - - - - - - -
                   - - - - - 2 - - - - - - - - - - - - -
                    - - - - - - - - - - - - - - - - - - -
Cells within the board contain 0 if empty, or a team number (1..6) if occupied by a piece of that team.  An extra border of nils around the whole reduces bounds checking to a nil test.

sixDeltas:  An array giving the x@y deltas for the 6 valid steps in CCW order from a given cell.  For team 1 they are: in fr, fl, l, bl, br, r.  To get, eg fl for a given team, use (sixDeltas atWrap: team+1).

teams:  An array of six teams, each of which is an array of the x@y locations of the 10 pieces.

homes:  The x@y coordinates of the six home points, namely 14@2, 18@6, 14@14, 6@18, 2@14, 6@6.  The goal, or farthest point in destination triangle, is thus (homes atWrap: teamNo+3).

autoPlay:  An array of booleans, parallel to teams, where true means that Squeak will make the moves for the corresponding team.

whoseMove:  A team number specifying whose turn it is next.  Set to 0 when game is over.

plannedMove:  If not nil, it means the board is in a state where it is animating the next move to be made so that it can be seen.

movePhase:  Holds the state of display of the planned move so that, eg, it can appear one jump at a time.  Advances from 1 to (plannedMove size * 2).

A move is an array of locs which are the path of the move.

Once the morph is open, the menu command 'reset...' allows you to reset the board and change the number of players.  The circle at turnIndicatorLoc indicates the color of the team whose turn it is.  If it is a human, play waits for drag and drop of a piece of that color.

The current strategy is very simple: generate all moves, score them and pick the best.  Beyond this, it will look ahead a number of moves, but this becomes very expensive without pruning.  Pruning would help the speed of play, especially in the end game where we look a little deeper.  A more effective strategy would consider opponents' possible moves as well, but this is left as an exercise for the serious programmer.!


!ChineseCheckers methodsFor: 'initialization'!
board: b teams: t
	board := b.
	teams := t! !

!ChineseCheckers methodsFor: 'initialization' stamp: 'di 4/9/2000 20:55'!
copyBoard
	"Return a copy of the board for the purpose of looking ahead one or more moves."

	^ self copy
		board: (board collect: [:row | row copy])
		teams: (teams collect: [:team | team copy])! !

!ChineseCheckers methodsFor: 'initialization' stamp: 'di 4/13/2000 13:35'!
initialize
	"Default creation is for one person against Squeak."

	super initialize.
	self extent: 382@413.
	self color: (Color r: 0.6 g: 0.4 b: 0.0).
	self borderWidth: 2.
	animateMoves _ true.
	self teams: #(2 5) autoPlay: {false. true}.
! !

!ChineseCheckers methodsFor: 'initialization' stamp: 'di 4/12/2000 23:44'!
teams: teamsPlaying autoPlay: ifAuto
	"Initialize board, teams, steps, jumps"
	| p q teamInPlay |
	colors _ (#(gray) , #(red green blue cyan magenta yellow white) shuffled)
				collect: [:c | Color perform: c].  "New set of colors each time."
	self removeAllMorphs.  "eg, from previous game."
	board := (1 to: 19) collect: [:i | Array new: 19].
	sixDeltas := {0@1. -1@1. -1@0. 0@-1. 1@-1. 1@0}.
	homes := {14@2. 18@6. 14@14. 6@18. 2@14. 6@6}.
	teams := (1 to: 6) collect: [:i | OrderedCollection new].
	autoPlay := (1 to: 6) collect: [:i | false].
	1 to: 6 do:
		[:team | p:= homes at: team.
		(teamInPlay := teamsPlaying includes: team) ifTrue:
			[autoPlay at: team put: (ifAuto at: (teamsPlaying indexOf: team))].
		"Place empty cells in rhombus extending out from each
		home, and occupied cells in active home triangles."
		1 to: 5 do: [:i | q := p.
			1 to: 5 do: [:j |
				(teamInPlay and: [j <= (5 - i)])
					ifTrue: [self at: q put: team.
							(teams at: team) add: q.
							self addMorph:
								((ChineseCheckerPiece
									newBounds: ((self cellPointAt: q) extent: self pieceSize)
									color: (colors at: team+1))
										setBoard: self loc: q)]
					ifFalse: [self at: q put: 0].
				q := q + (sixDeltas at: team).  "right,forward"].
			p := p + (sixDeltas atWrap: team+1).  "left,forward"].
		teams at: team put: (teams at: team) asArray].
	whoseMove _ teamsPlaying first.
	self addMorph:
		((ChineseCheckerPiece
			newBounds: ((self cellPointAt: self turnIndicatorLoc) extent: self pieceSize)
			color: (colors at: whoseMove+1))
				setBoard: self loc: self turnIndicatorLoc).
	plannedMove _ nil.
	self changed! !


!ChineseCheckers methodsFor: 'board geometry'!
at: p
	^ (board at: p x) at: p y! !

!ChineseCheckers methodsFor: 'board geometry'!
at: p put: x
	^ (board at: p x) at: p y put: x! !

!ChineseCheckers methodsFor: 'board geometry'!
boardCenter
	^ 10@10! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 4/9/2000 10:00'!
boardLocAt: cellPoint

	| dx dy row col |
	dx _ self width/15.0.  dy _ dx * 0.8660254037844385 "(Float pi / 3) sin".
	row _ (cellPoint y - self position y) // dy + 1.
	col _ (cellPoint x - self position x) / (dx/2.0) + 16 - row // 2.
	^ row @ col! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 4/11/2000 17:18'!
cellPointAt: boardLoc
	| dx dy row col |
	dx _ self width/15.0.  dy _ dx * 0.8660254037844385 "(Float pi / 3) sin".
	row _ boardLoc x.
	col _ boardLoc y.
	^ self position + ((col*2+row-16*dx//2)@(row-1*dy)) asIntegerPoint! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 3/13/2000 19:50'!
distFrom: a to: b
	"The six possible moves are: 1@0, 1@-1, 0@1, 0@-1, -1@0, -1@1."
	| dx dy |
	dx _ b x - a x.
	dy _ b y - a y.
	dx abs >= dy abs
	ifTrue: ["Major change is in x-coord..."
			dx >= 0
			ifTrue: [(dy between: (0-dx) and: 0)
						ifTrue: [^ dx  "no lateral motion"].
					^ dx + ((0-dx) - dy max: dy - 0)  "added lateral dist"]
			ifFalse: ["Reverse sign and rerun same code"
					^ self distFrom: b to: a]]
	ifFalse: ["Transpose and re-run same code"
			^ self distFrom: a transposed to: b transposed]! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 4/11/2000 09:21'!
extent: newExtent

	| extraY |
	extraY _ (newExtent x / 15.0 * 1.25) asInteger.
	super extent: (newExtent x) @ (newExtent x + extraY).
	self submorphsDo:
		[:m | (m isKindOf: ChineseCheckerPiece) ifTrue:
				[m position: (self cellPointAt: m boardLoc); extent: self pieceSize]]! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 4/11/2000 09:20'!
pieceSize

	^ self width asPoint // 20! !

!ChineseCheckers methodsFor: 'board geometry' stamp: 'di 4/9/2000 09:44'!
turnIndicatorLoc

	^ 16@11! !


!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/13/2000 14:18'!
allMovesFrom: boardLoc  "boardLoc must be occupied"
	| team stepMoves jumpDict |
	team := self at: boardLoc.
	stepMoves := (sixDeltas collect: [:d | boardLoc + d])
		select: [:p | (self at: p) notNil and: [(self at: p) = 0]].
	jumpDict := Dictionary new.
	jumpDict at: boardLoc put: (Array with: boardLoc).
	self jumpFor: team from: boardLoc havingVisited: jumpDict.
	jumpDict removeKey: boardLoc.
	^ (stepMoves collect: [:p | {boardLoc. p}]) , jumpDict values
		reject:
		[:move |  "Don't include any moves that land in other homes."
		(self distFrom: move last to: self boardCenter) >= 5  "In a home..."
			and: [(self distFrom: move last to: (homes atWrap: team+3)) > 3  "...not my goal..."
			and: [(self distFrom: move last to: (homes at: team)) > 3  "...nor my home"]]]! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/12/2000 23:23'!
bestMove: ply forTeam: team
	| score bestScore bestMove |
	bestScore := -999.
	(teams at: team) do:
		[:boardLoc |
		(self allMovesFrom: boardLoc) do:
			[:move |
			score := self score: move for: team.
			(score > -99 and: [ply > 0]) ifTrue: 
				[score := score  "Add 0.7 * score of next move (my guess)"
					+ (0 max: ((self score: ((self copyBoard makeMove: move)
							bestMove: ply - 1 forTeam: team) for: team) * 0.7))].
			score > bestScore ifTrue:
				[bestScore := score.  bestMove := move]]].
	^ bestMove! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/10/2000 08:27'!
checkDoneAfter: move

	| team locsAfterMove |
	(team := self at: move first) = 0 ifTrue: [^ false].
	(locsAfterMove _ (teams at: team) copy) replaceAll: move first with: move last.
	^ self testDone: locsAfterMove for: team! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/12/2000 23:40'!
endGameFor: team
	"Return true if we are in the end game (all players within 1 of home triangle)."

	| goalLoc |
	goalLoc _ homes atWrap: team+3.  "Farthest cell across the board"
	(teams at: team)
		do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 4 ifTrue: [^ false]].
	^ true! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/12/2000 20:36'!
jumpFor: team from: loc havingVisited: dict
	"Recursively explore all jumps from loc, leaving in dict
	the prior position from which we got there"

	"Fasten seatbelts..."
	((((sixDeltas
		collect: [:d | loc + d])
		select: [:p | (self at: p) notNil and: [(self at: p) > 0]])
		collect: [:p | p + (p - loc)])
		select: [:p | (self at: p) notNil and: [(self at: p) = 0]])
		do: [:p | (dict includesKey: p) ifFalse:
			[dict at: p put: ((dict at: loc) copyWith: p).
			self jumpFor: team from: p havingVisited: dict]]! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/10/2000 08:17'!
makeMove: move
	| team |
	team := self at: move first.
	self at: move last put: team.
	self at: move first put: 0.
	(teams at: team) replaceAll: move first with: move last! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/13/2000 14:21'!
score: move for: team
	"Return the decrease in distance toward this team's goal"

	| goal closerToGoal wasBack nowBack |
	goal _ homes atWrap: team+3.
	wasBack _ self distFrom: move first to: goal.
	nowBack _ self distFrom: move last to: goal.
	closerToGoal _ wasBack - nowBack.
	closerToGoal < -1 ifTrue: [^ -99].  "Quick rejection if move backward more than 1"
	(nowBack <= 3 and: [self checkDoneAfter: move]) ifTrue: [^ 999].
	"Reward closerToGoal, but add bias to move those left far behind."
	^ (closerToGoal*5) + wasBack! !

!ChineseCheckers methodsFor: 'moves' stamp: 'di 4/12/2000 23:40'!
testDone: teamLocs for: team
	"Return true if we are done (all players in home triangle)."

	| goalLoc |
	goalLoc _ homes atWrap: team+3.
	teamLocs
		do: [:boardLoc | (self distFrom: boardLoc to: goalLoc) > 3 ifTrue: [^ false]].
	^ true! !


!ChineseCheckers methodsFor: 'drag and drop' stamp: 'ar 10/5/2000 19:23'!
acceptDroppingMorph: aPiece event: evt

	| dropLoc |
	super acceptDroppingMorph: aPiece event: evt.
	dropLoc _ self boardLocAt: evt cursorPoint.
	dropLoc = aPiece boardLoc ifTrue:  "Null move"
		[^ aPiece rejectDropMorphEvent: evt].
	(plannedMove _ (self allMovesFrom: aPiece boardLoc)
				detect: [:move | move last = dropLoc]
				ifNone: [nil])
		ifNil: [^ aPiece rejectDropMorphEvent: evt.   "Not a valid move"].

	movePhase _ 1.  "Start the animation if any."
! !

!ChineseCheckers methodsFor: 'drag and drop' stamp: 'di 4/8/2000 23:45'!
okToPickUpPieceAt: boardLoc

	^ (self at: boardLoc) = whoseMove and: [(autoPlay at: whoseMove) not]! !

!ChineseCheckers methodsFor: 'drag and drop' stamp: 'di 4/9/2000 08:30'!
pieceAt: boardLoc

	self submorphsDo:
		[:m | ((m isMemberOf: ChineseCheckerPiece) and: [m boardLoc = boardLoc])
				ifTrue: [^ m]].
	^ nil! !

!ChineseCheckers methodsFor: 'drag and drop' stamp: 'di 4/9/2000 10:44'!
wantsDroppedMorph: aPiece event: evt

	^ aPiece isKindOf: ChineseCheckerPiece
! !


!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 13:23'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Include our modest command set in the ctrl-menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	self addMenuItemsTo: aCustomMenu hand: aHandMorph! !

!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 14:01'!
addMenuItemsTo: aMenu hand: aHandMorph

	aMenu add: 'new game' target: self action: #newGame.
	aMenu add: 'reset...' target: self action: #reset.
	animateMoves
		ifTrue: [aMenu add: 'don''t animate moves' target: self action: #dontAnimateMoves]
		ifFalse: [aMenu add: 'animate moves' target: self action: #animateMoves]

! !

!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 13:36'!
animateMoves

	animateMoves _ true! !

!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 13:36'!
dontAnimateMoves

	animateMoves _ false! !

!ChineseCheckers methodsFor: 'menu' stamp: 'sma 4/30/2000 09:23'!
handlesMouseDown: evt
	"Prevent stray clicks from picking up the whole game in MVC."

	^ Smalltalk isMorphic not or: [evt yellowButtonPressed]! !

!ChineseCheckers methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:57'!
mouseDown: evt

	| menu |
	evt yellowButtonPressed ifFalse: [^ self].
	menu _ MenuMorph new defaultTarget: self.
	self addMenuItemsTo: menu hand: evt hand.
	menu popUpEvent: evt in: self world.
! !

!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 13:32'!
newGame
	"Reset the board, with same teams."

	| teamNumbers |
	teamNumbers _ (1 to: 6) reject: [:i | (teams at: i) isEmpty].
	self teams: teamNumbers
		 autoPlay: (teamNumbers collect: [:i | autoPlay at: i]).
! !

!ChineseCheckers methodsFor: 'menu' stamp: 'di 4/13/2000 13:31'!
reset
	"Reset the board, choosing anew how many teams."

	| nPlayers nHumans |
	nPlayers _ (SelectionMenu selections: (1 to: 6)) startUpWithCaption: 'How many players?'.
	nPlayers ifNil: [nPlayers _ 2].
	nHumans _ (SelectionMenu selections: (0 to: nPlayers)) startUpWithCaption: 'How many humans?'.
	nHumans ifNil: [nHumans _ 1].
	self teams: (#((1) (2 5) (2 4 6) (1 2 4 5) (1 2 3 4 6) (1 2 3 4 5 6)) at: nPlayers)
		 autoPlay: ((1 to: nPlayers) collect: [:i | i > nHumans]).
! !


!ChineseCheckers methodsFor: 'display' stamp: 'di 8/10/2000 09:40'!
drawOn: aCanvas 

	| row1 row2 offset dotExtent |
	super drawOn: aCanvas.   "Draw square board"

	"Only draw rows in the clipping region"
	dotExtent _ (self width//25) asPoint.
	offset _ self pieceSize - dotExtent + 1 // 2.  "Offset of smaller dots rel to larger"
	row1 _ (self boardLocAt: aCanvas clipRect topLeft) x max: 1.
	row2 _ (self boardLocAt: aCanvas clipRect bottomRight) x min: board size.
	row1 to: row2 do:
		[:row | (board at: row) doWithIndex:
			[:cell :i | cell ifNotNil:
				[aCanvas fillOval: ((self cellPointAt: (row@i)) + offset extent: dotExtent)
					color: (colors at: cell+1)]]]! !

!ChineseCheckers methodsFor: 'display' stamp: 'di 4/10/2000 11:29'!
printOn: s  "For testing only"

	1 to: board size do: [:row |
		s cr; next: row put: $ .
		(board at: row) do:
			[:cell | s space; nextPut:
				(cell == nil
					ifTrue: [$-]
					ifFalse: [cell printString last])]]! !


!ChineseCheckers methodsFor: 'game sequence' stamp: 'di 4/13/2000 14:25'!
nextTurn

	(self testDone: (teams at: whoseMove) for: whoseMove) ifTrue:
		[(self pieceAt: self turnIndicatorLoc) extent: self width asPoint//6; borderWidth: 2.
		^ whoseMove _ 0.  "Game over."].	

	[whoseMove _ whoseMove\\6 + 1.
	(teams at: whoseMove) isEmpty]  "Turn passes to the next player"
		whileTrue: [].
	(self pieceAt: self turnIndicatorLoc) color: (colors at: whoseMove+1)! !

!ChineseCheckers methodsFor: 'game sequence' stamp: 'di 4/11/2000 08:35'!
showNextMoveSegment
	"Display the current move in progress.  Starts with movePhase = 1.
	Increments movePhase at each tick.  Ends by setting movePhase to 0."

	| dot p1 p2 delta secondPhase line |
	delta _ self width//40.
	movePhase <= plannedMove size
	ifTrue:
		["First we trace the move with dots and lines..."
		movePhase = 1 ifTrue: [pathMorphs _ OrderedCollection new].
		p1 _ self cellPointAt: (plannedMove at: movePhase).
		dot _ (ImageMorph new image: (Form dotOfSize: 7)) position: p1 + delta - (7//2).
		self addMorph: dot.  pathMorphs addLast: dot.
		movePhase > 1 ifTrue:
			[p2 _ self cellPointAt: (plannedMove at: movePhase-1).
			line _ PolygonMorph vertices: {p2 + delta. p1 + delta} color: Color black
					borderWidth: 3 borderColor: Color black.
			self addMorph: line.  pathMorphs addLast: line]]
	ifFalse:
		["...then we erase the path while moving the piece."
		secondPhase _ movePhase - plannedMove size.
		pathMorphs removeFirst delete.
		secondPhase > 1 ifTrue:
			[pathMorphs removeFirst delete.
			self makeMove: {plannedMove at: secondPhase - 1. plannedMove at: secondPhase}.
			(self pieceAt: (plannedMove at: secondPhase - 1))
				position: (self cellPointAt: (plannedMove at: secondPhase));
				setBoard: self loc: (plannedMove at: secondPhase).
			self changed]].

	(movePhase _ movePhase + 1) > (plannedMove size * 2)
		ifTrue: [movePhase _ 0  "End of animated move"].

! !

!ChineseCheckers methodsFor: 'game sequence' stamp: 'di 4/13/2000 13:52'!
step

	whoseMove = 0 ifTrue: [^ self].  "Game over."

	plannedMove == nil ifTrue:
		[(autoPlay at: whoseMove) ifFalse: [^ self].  "Waiting for a human."
		(self endGameFor: whoseMove)  "Look deeper at the end."
			ifTrue: [plannedMove _ self bestMove: 2 forTeam: whoseMove]
			ifFalse: [plannedMove _ self bestMove: 1 forTeam: whoseMove].
		movePhase _ 1.  "Start the animated move"].

	animateMoves
		ifTrue: ["Display the move in phases..."
				movePhase > 0 ifTrue: [^ self showNextMoveSegment]]
		ifFalse: ["... or skip the entire animated move if requested."
				self makeMove: plannedMove.
				(self pieceAt: plannedMove first)
						position: (self cellPointAt: plannedMove last);
						setBoard: self loc: plannedMove last.
				self changed.
				movePhase _ 0].

	plannedMove _ nil.  "End the animated move"

	self nextTurn! !

!ChineseCheckers methodsFor: 'game sequence' stamp: 'di 4/12/2000 23:43'!
stepTime

	^ 200! !
WordGamePanelMorph subclass: #CipherPanel
	instanceVariableNames: 'originalText quote originalMorphs decodingMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!CipherPanel commentStamp: '<historical>' prior: 0!
The CipherPanel, as its name suggests, is a tool for decoding simple substitution codes, such as are presented on the puzzle pages of many Sunday newspapers.  Most of the capability is inherited from the two WordGame classes used.  To try it out, choose newMorph/Games/CipherPanel in a morphic project, or execute, in any project:

	CipherPanel new openInWorld
!


!CipherPanel methodsFor: 'initialization' stamp: 'di 5/12/2000 00:53'!
encodedQuote: aString
	"World addMorph: CipherPanel test"

	| morph prev |
	haveTypedHere _ false.
	quote _ aString asUppercase.
	prev _ nil.
	originalMorphs _ quote asArray collectWithIndex:
		[:c :i | WordGameLetterMorph new plain indexInQuote: i id1: nil;
						setLetter: (quote at: i)].
	letterMorphs _ OrderedCollection new.
	decodingMorphs _ quote asArray collectWithIndex:
		[:c :i | (quote at: i) isLetter
		ifTrue:
			[morph _ WordGameLetterMorph new underlined indexInQuote: i id1: nil.
			morph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
			morph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
			letterMorphs addLast: morph.
			morph predecessor: prev.
			prev ifNotNil: [prev successor: morph].
			prev _ morph]
		ifFalse:
			[WordGameLetterMorph new plain indexInQuote: i id1: nil; setLetter: (quote at: i)]].
	self color: originalMorphs first color.
	self extent: 500@500
! !

!CipherPanel methodsFor: 'initialization' stamp: 'di 11/23/2000 19:36'!
extent: newExtent 
	"Lay out with word wrap, alternating bewteen decoded and encoded lines."
	"Currently not tolerant of narrow (less than a word) margins"

	| w h relLoc topLeft thisWord i m corner row |
	self removeAllMorphs.
	w _ originalMorphs first width - 1.  h _ originalMorphs first height * 2 + 10.
	topLeft _ self position + self borderWidth + (0@10).
	thisWord _ OrderedCollection new.
	i _ 1.  relLoc _ 0@0.  corner _ topLeft.
	[i <= originalMorphs size] whileTrue:
		[m _ originalMorphs at: i.
		thisWord addLast: ((decodingMorphs at: i) position: topLeft + relLoc).
		thisWord addLast: (m position: topLeft + relLoc + (0@m height)).
		(m letter = Character space or: [i = originalMorphs size])
			ifTrue: [self addAllMorphs: thisWord.
					corner _ corner max: thisWord last bounds bottomRight.
					thisWord reset].
		relLoc _ relLoc + (w@0).
		(relLoc x + w) > newExtent x
			ifTrue: [i _ i - (thisWord size//2) + 1.
					thisWord reset.
					relLoc _ 0@(relLoc y + h)]
			ifFalse: [i _ i + 1]].
	row _ self buttonRow.
	self addMorph: row.
	super extent: (corner - topLeft) + (self borderWidth * 2) + (0@row height+10).
	row align: row fullBounds bottomCenter with: self fullBounds bottomCenter - (0@2).
! !


!CipherPanel methodsFor: 'menu' stamp: 'di 5/11/2000 08:32'!
addMenuItemsTo: aMenu hand: aHandMorph

	aMenu add: 'show cipher help' target: self action: #showHelpWindow.
	aMenu add: 'show cipher hints' target: self action: #showHintsWindow.
	aMenu add: 'clear cipher typing' target: self action: #clearTyping.
	aMenu add: 'enter a new cipher' target: self action: #enterANewCipher.
! !

!CipherPanel methodsFor: 'menu' stamp: 'di 5/8/2000 20:21'!
buttonRow

	| row aButton |
	row _ AlignmentMorph newRow
		color: self color;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	aButton _ SimpleButtonMorph new target: self.
	aButton color: Color transparent; borderWidth: 1; borderColor: Color black.

	#('show help' 'show hints' 'clear typing' 'enter a new cipher')
	with: 
	#(showHelpWindow showHintsWindow clearTyping enterANewCipher)
	do: [:label :selector |
		aButton _ aButton fullCopy.
		aButton actionSelector: selector.
		aButton label: label.
		row addMorphBack: aButton.
		row addTransparentSpacerOfSize: (3 @ 0)].

	^ row
! !

!CipherPanel methodsFor: 'menu' stamp: 'di 5/8/2000 10:46'!
cipherStats

	| letterCounts digraphs d digraphCounts |
	letterCounts _ (quote copyWithout: Character space) asBag sortedCounts.
	digraphs _ Bag new.
	quote withIndexDo:
		[:c :i |
		i < quote size ifTrue:
			[d _ quote at: i+1.
			(c ~= Character space and: [d ~= Character space]) ifTrue:
				[digraphs add: (String with: c with: d)]]].
	digraphCounts _ digraphs sortedCounts.
	^ String streamContents:
		[:strm |
		1 to: 10 do:
			[:i |
			strm cr; tab; nextPut: (letterCounts at: i) value.
			strm tab; print: (letterCounts at: i) key.
			(digraphCounts at: i) key > 1 ifTrue:
				[strm tab; tab; tab; nextPutAll: (digraphCounts at: i) value.
				strm tab; print: (digraphCounts at: i) key]]]! !

!CipherPanel methodsFor: 'menu' stamp: 'di 5/12/2000 00:28'!
clearTyping

	self isClean ifTrue: [^ self].
	(self confirm: 'Are you sure you want to discard all typing?') ifFalse: [^ self].
	super clearTyping.
! !

!CipherPanel methodsFor: 'menu' stamp: 'sma 6/18/2000 10:32'!
enterANewCipher
	self encodedQuote:
		(FillInTheBlank request: 'Type a cipher text to work on here below...')! !

!CipherPanel methodsFor: 'menu' stamp: 'di 5/8/2000 10:53'!
showHelpWindow

	((StringHolder new contents: 
'The Cipher Panel displays an encrypted message.  The encryption is a simple substitution code;  each letter of the alphabet has been changed to a different one.

You can solve the cipher by clicking above any letter in the message, and typing the letter you think it should be.  The Cipher Panel automatically makes the same substitution anywhere else that letter occurs in the encoded message.

If you are having trouble, you can use the command menu to ''show cipher hints''.  That will display how many of each letter occurs, which is often a help in solving ciphers.')
		embeddedInMorphicWindowLabeled: 'About the Cipher Panel')
			setWindowColor: (Color r: 1.0 g: 0.6 b: 0.0);
			openInWorld: self world extent: 389@209! !

!CipherPanel methodsFor: 'menu' stamp: 'di 5/8/2000 12:19'!
showHintsWindow

	((StringHolder new contents: 
'Most bodies of english text follow a general pattern of letter usage.  The following are the most common letters, in approximate order of frequency:
	E  T  A  O  N  I  R  S  H
The following are the most common digraphs:
	EN  ER  RE  NT  TH  ON  IN

The message you are trying to decode has the following specific statistics:'
	, self cipherStats , '

Good luck!!')
		embeddedInMorphicWindowLabeled: 'Some Useful Statistics')
			setWindowColor: (Color r: 1.0 g: 0.6 b: 0.0);
			openInWorld: self world extent: 318@326! !


!CipherPanel methodsFor: 'events' stamp: 'di 5/12/2000 00:52'!
keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus

	| encodedLetter |
	encodedLetter _ quote at: indexInQuote.
	originalMorphs with: decodingMorphs do:
		[:e :d | e letter = encodedLetter ifTrue: [d setLetter: aLetter color: Color red]].
! !

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

CipherPanel class
	instanceVariableNames: ''!

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/10/2000 09:52'!
includeInNewMorphMenu

	^ true! !

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/10/2000 10:08'!
new
	"NOTE: Use newFromQuote: rather than new to create new CipherPanels"

	^ self newFromQuote: self sampleString

" Here are some other examples...
World addMorph: (CipherPanel newFromQuote: 'BPFFXY LZY PK ROY RPBY PG XPAY HOYG EJCM SXJROYK FJG''R APR QCR PR''K EJC HOJ GYYF ROY LXRYMLRPJGK.  KJCMSY CGNGJHG')

World addMorph: (CipherPanel newFromQuote: 'Y FRV TRK HJRH QVL QS HJL BPLRHLTH WZLRTXPLT YV ZYSL YT OQYVB MJRH WLQWZL TRK KQX FRVVQH OQ.')

World addMorph: (CipherPanel newFromQuote: 'XI''H SAZRG: SDCIZCIZT EZDEAZ TD CDI SGZRIZ EGDPGZHH.')

World addMorph: (CipherPanel newFromQuote: 'PY MOJ WPMMWJ MZGYR ZL MOJ GZSWH PM''R YZ RZZYJS HZYJ MOBY RBPH.')

World addMorph: (CipherPanel newFromQuote: 'PYSLHYA DJP VBHHLXYAA BPY BGNBMA PLUVQ LX AQMGY; QVY HPLXSLHBG LXUPYCLYXQA BPY NBPK BXC DPLYXCGM AKLGYA.')

World addMorph: (CipherPanel newFromQuote: 'U HWVS RJ AHOST RLO FOOQOST TJUSM AJIO LOVNC WUXRUSM VST HWVCUSM LVSTZVWW. -- TVNUT WORROEIVS VXROE LUA KGUSRGHWO-ZCHVAA LOVER JHOEVRUJS')
"! !

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/10/2000 10:06'!
newFromQuote: encodedString
	"Use this to creat new panels instead of new."

	^ super new encodedQuote: encodedString! !

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 9/19/2000 23:23'!
quoteToScramble: aString
	"World addMorph: (CipherPanel quoteToScramble: 'Now is the time for all good men to come to the aid of their country.')"

	| dict |
	dict _ Dictionary new.
	($A to: $Z) with: ($A to: $Z) shuffled do: [:a :b | dict at: a put: b].
	^ self newFromQuote: (aString asUppercase collect: [:a | dict at: a ifAbsent: [a]])! !

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/8/2000 11:58'!
sampleString
	^
'E SGJC OSCVC LICGNV, ENGRCV, JEVEMAV. E SGJC OSEV QGVVEMA XMI [SMWWDHMML] ... EO''V HMALCIXKW OM SGJC VMNCOSEAR OSGO EAVQEICV GAL LIEJCV DMK. -- ZGIZIG VOICEVGAL'! !

!CipherPanel class methodsFor: 'as yet unclassified' stamp: 'di 9/19/2000 23:39'!
tedsHack  
	"Generate cryptic puzzles from method comments in the system"
	| c s | s _ 'none'.
	[s = 'none'] whileTrue:
		[s _ ((c _ Smalltalk allClasses atRandom) selectors
					collect: [:sel | (c firstCommentAt: sel) asString])
		 			detect: [:str | str size between: 100 and: 200] ifNone: ['none']].
	(CipherPanel quoteToScramble: s) openInWorld

"CipherPanel tedsHack"! !
Arc subclass: #Circle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Circle commentStamp: '<historical>' prior: 0!
I represent a full circle. I am made from four Arcs.!


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

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

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

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !


!Circle methodsFor: 'display box access'!
computeBoundingBox

	^center - radius + form offset extent: form extent + (radius * 2) asPoint! !

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

Circle class
	instanceVariableNames: ''!

!Circle class methodsFor: 'examples'!
exampleOne 
	"Click any button somewhere on the screen. The point will be the center
	of the circcle of radius 150."

	| aCircle aForm |
	aForm _ Form extent: 1@30.
	aForm fillBlack.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display
	
	"Circle exampleOne"! !

!Circle class methodsFor: 'examples'!
exampleTwo
	"Designate a rectangular area that should be used as the brush for
	displaying the circle. Click any button at a point on the screen which
	will be the center location for the circle. The curve will be displayed
	with a long black form."

	| aCircle aForm |
	aForm _ Form fromUser.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display at: 0 @ 0 rule: Form reverse
 
	 "Circle exampleTwo"! !
ClassDescription subclass: #Class
	instanceVariableNames: 'subclasses name classPool sharedPools environment category '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Class commentStamp: '<historical>' prior: 0!
I add a number of facilities to those in ClassDescription:
	A set of all my subclasses (defined in ClassDescription, but only used here and below)
	A name by which I can be found in a SystemDictionary
	A classPool for class variables shared between this class and its metaclass
	A list of sharedPools which probably should be supplanted by some better mechanism.

My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription.

The slot 'subclasses' is a redundant structure.  It is never used during execution, but is used by the development system to simplify or speed certain operations.  !


!Class methodsFor: 'initialize-release'!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts assoc class |
	newVars _ 
		(Scanner new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do:
		[:var | var first isLowercase
			ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool == nil 
		ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 
					[:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self scopeHas: var ifTrue: [:ignored | ignored])
				ifTrue: 
					[self error: var , ' is defined elsewhere'.
					conflicts _ true]].
	newVars size > 0
		ifTrue: 
			[classPool _ self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: Undeclared]].
	^conflicts! !

!Class methodsFor: 'initialize-release' stamp: 'ar 9/10/1999 17:34'!
obsolete
	"Change the receiver and all of its subclasses to an obsolete class."
	self == Object 
		ifTrue:[^self error:'Object is NOT obsolete'].
	name _ 'AnObsolete' , name.
	Object class instSize + 1 to: self class instSize do:
		[:i | self instVarAt: i put: nil]. "Store nil over class instVars."
	classPool _ nil.
	sharedPools _ nil.
	self class obsolete.
	super obsolete.
! !

!Class methodsFor: 'initialize-release' stamp: 'di 12/20/1999 12:37'!
removeFromSystem
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."

	self environment removeClassFromSystem: self.
	self obsolete! !

!Class methodsFor: 'initialize-release' stamp: 'sw 8/11/1998 13:23'!
removeFromSystemUnlogged
	"Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver.  Do not log the removal either to the current change set nor to the system changes log"

	Smalltalk removeClassFromSystemUnlogged: self.
	self obsolete! !

!Class methodsFor: 'initialize-release' stamp: 'ar 2/13/1999 21:04'!
sharing: poolString 
	"Set up sharedPools. Answer whether recompilation is advisable."
	| oldPools found |
	oldPools _ self sharedPools.
	sharedPools _ OrderedCollection new.
	(Scanner new scanFieldNames: poolString) do: 
		[:poolName | 
		sharedPools add: (Smalltalk at: poolName asSymbol ifAbsent:[
			(self confirm: 'The pool dictionary ', poolName,' does not exist.',
						'\Do you want it automatically created?' withCRs)
				ifTrue:[Smalltalk at: poolName asSymbol put: Dictionary new]
				ifFalse:[^self error: poolName,' does not exist']])].
	sharedPools isEmpty ifTrue: [sharedPools _ nil].
	oldPools do: [:pool | found _ false.
				self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
				found ifFalse: [^ true "A pool got deleted"]].
	^ false! !

!Class methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 16:39'!
superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet 
	"Answer an instance of me, a new class, using the arguments of the 
	message as the needed information.
	Must only be sent to a new instance; else we would need Object flushCache."

	superclass _ sup.
	methodDict _ md.
	format _ ft.
	name _ nm.
	organization _ org.
	instanceVariables _ nilOrArray.
	classPool _ pool.
	sharedPools _ poolSet! !

!Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	subclasses _ nil. "Important for moving down the subclasses field into Class"
! !


!Class methodsFor: 'accessing'!
classPool
	"Answer the dictionary of class variables."

	classPool == nil
		ifTrue: [^Dictionary new]
		ifFalse: [^classPool]! !

!Class methodsFor: 'accessing'!
name
	"Answer the name of the receiver."

	name == nil
		ifTrue: [^super name]
		ifFalse: [^name]! !


!Class methodsFor: 'testing'!
hasMethods
	"Answer a Boolean according to whether any methods are defined for the 
	receiver (includes whether there are methods defined in the receiver's 
	metaclass)."

	^super hasMethods or: [self class hasMethods]! !

!Class methodsFor: 'testing' stamp: 'ar 7/15/1999 15:36'!
isObsolete
	"Return true if the receiver is obsolete."
	^(self environment at: name ifAbsent:[nil]) ~~ self! !

!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:47'!
isSystemDefined
	"Answer true if the receiver is a system-defined class, and not a UniClass (an instance-specific lightweight class)"

	^ self == self officialClass! !

!Class methodsFor: 'testing' stamp: 'tk 8/12/1999 15:49'!
officialClass
	"I am not a UniClass.  (See Player officialClass).  Return the class you use to make new subclasses."

	^ self! !


!Class methodsFor: 'copying' stamp: 'di 2/17/2000 22:43'!
copy 
	| newClass |
	newClass _ self class copy new
		superclass: superclass
		methodDict: self methodDict copy
		format: format
		name: name
		organization: self organization copy
		instVarNames: instanceVariables copy
		classPool: classPool copy
		sharedPools: sharedPools.
	Class instSize+1 to: self class instSize do:
		[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
	^ newClass! !


!Class methodsFor: 'class name' stamp: 'bf 5/31/2000 17:24'!
rename: aString
	"The new name of the receiver is the argument, aString."

	| newName |
	(newName _ aString asSymbol) ~= self name
		ifTrue:
			[(Smalltalk includesKey: newName)
				ifTrue: [^self error: newName , ' already exists'].
			(Undeclared includesKey: newName)
				ifTrue: [SelectionMenu notify: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
			Smalltalk renameClass: self as: newName.
			name _ newName]! !

!Class methodsFor: 'class name' stamp: 'sw 12/1/2000 20:40'!
uniqueNameForReference
	"Answer a unique name by which the receiver can be referred to from user scripts, for example"

	^ name! !


!Class methodsFor: 'instance variables' stamp: 'ar 7/15/1999 18:56'!
addInstVarName: aString
	"Add the argument, aString, as one of the receiver's instance variables."
	^(ClassBuilder new)
		name: self name
		inEnvironment: self environment
		subclassOf: superclass
		type: self typeOfClass
		instanceVariableNames: self instanceVariablesString , aString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
! !

!Class methodsFor: 'instance variables' stamp: 'ar 7/15/1999 18:56'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newInstVarString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newInstVarString _ ''.
	(self instVarNames copyWithout: aString) do: 
		[:varName | newInstVarString _ newInstVarString , ' ' , varName].
	^(ClassBuilder new)
		name: self name
		inEnvironment: self environment
		subclassOf: superclass
		type: self typeOfClass
		instanceVariableNames: newInstVarString
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category! !


!Class methodsFor: 'class variables' stamp: 'di 3/27/2000 21:54'!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		subclass scopeHas: symbol
			ifTrue: [:temp | 
					^ self error: aString 
						, ' is already used as a variable name in class ' 
						, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		Smalltalk changes changeClass: self from: self.
		classPool declare: symbol from: Undeclared]! !

!Class methodsFor: 'class variables'!
allClassVarNames
	"Answer a Set of the names of the receiver's class variables, including those
	defined in the superclasses of the receiver."

	| aSet |
	superclass == nil
		ifTrue: 
			[^self classVarNames]  "This is the keys so it is a new Set."
		ifFalse: 
			[aSet _ superclass allClassVarNames.
			aSet addAll: self classVarNames.
			^aSet]! !

!Class methodsFor: 'class variables'!
classVarNames
	"Answer a Set of the names of the class variables defined in the receiver."

	^self classPool keys! !

!Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'!
ensureClassPool

	classPool ifNil: [classPool _ Dictionary new].! !

!Class methodsFor: 'class variables'!
initialize
	"Typically used for the initialization of class variables and metaclass 
	instance variables. Does nothing, but may be overridden in Metaclasses."

	^self! !

!Class methodsFor: 'class variables' stamp: 'jm 7/24/1999 12:58'!
removeClassVarName: aString 
	"Remove the class variable whose name is the argument, aString, from 
	the names defined in the receiver, a class. Create an error notification if 
	aString is not a class variable or if it is still being used in the code of 
	the class."

	| aSymbol |
	aSymbol _ aString asSymbol.
	(classPool includesKey: aSymbol)
		ifFalse: [^self error: aString, ' is not a class variable'].
	self withAllSubclasses do:[:subclass |
		(Array with: subclass with: subclass class) do:[:classOrMeta |
			(classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol))
				isEmpty ifFalse: [
					(self confirm: (aString,' is still used in code of class ', classOrMeta name,
						'.\Is it okay to move it to Undeclared?') withCRs)
						ifTrue:[^Undeclared declare: aSymbol from: classPool]
						ifFalse:[^self]]]].
	classPool removeKey: aSymbol.
	classPool isEmpty ifTrue: [classPool _ nil].
! !


!Class methodsFor: 'pool variables'!
addSharedPool: aDictionary 
	"Add the argument, aDictionary, as one of the receiver's pool dictionaries. 
	Create an error if the dictionary is already one of the pools."

	(self sharedPools includes: aDictionary)
		ifTrue: [^self error: 'The dictionary is already in my pool'].
	sharedPools == nil
		ifTrue: [sharedPools _ OrderedCollection with: aDictionary]
		ifFalse: [sharedPools add: aDictionary]! !

!Class methodsFor: 'pool variables'!
allSharedPools
	"Answer a Set of the pools the receiver shares, including those defined 
	in the superclasses of the receiver."

	| aSet |
	superclass == nil
		ifTrue:
			[^self sharedPools copy]
		ifFalse: 
			[aSet _ superclass allSharedPools.
			aSet addAll: self sharedPools.
			^aSet]! !

!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'!
removeSharedPool: aDictionary 
	"Remove the pool dictionary, aDictionary, as one of the receiver's pool 
	dictionaries. Create an error notification if the dictionary is not one of 
	the pools.
	: Note that it removes the wrong one if there are two empty Dictionaries in the list."

	| satisfiedSet workingSet aSubclass |
	(self sharedPools includes: aDictionary)
		ifFalse: [^self error: 'the dictionary is not in my pool'].

	"first see if it is declared in a superclass in which case we can remove it."
	(self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty
		ifFalse: [sharedPools remove: aDictionary.
				sharedPools isEmpty ifTrue: [sharedPools _ nil].
				^self]. 

	"second get all the subclasses that reference aDictionary through me rather than a 
	superclass that is one of my subclasses."

	workingSet _ self subclasses asOrderedCollection.
	satisfiedSet _ Set new.
	[workingSet isEmpty] whileFalse:
		[aSubclass _ workingSet removeFirst.
		(aSubclass sharedPools includes: aDictionary)
			ifFalse: 
				[satisfiedSet add: aSubclass.
				workingSet addAll: aSubclass subclasses]].

	"for each of these, see if they refer to any of the variables in aDictionary because 
	if they do, we can not remove the dictionary."
	satisfiedSet add: self.
	satisfiedSet do: 
		[:sub | 
		aDictionary associationsDo: 
			[:aGlobal | 
			(sub whichSelectorsReferTo: aGlobal) isEmpty 
				ifFalse: [^self error: aGlobal key 
								, ' is still used in code of class '
								, sub name]]].
	sharedPools remove: aDictionary.
	sharedPools isEmpty ifTrue: [sharedPools _ nil]! !

!Class methodsFor: 'pool variables'!
sharedPools
	"Answer a Set of the pool dictionaries declared in the receiver."

	sharedPools == nil
		ifTrue: [^OrderedCollection new]
		ifFalse: [^sharedPools]! !


!Class methodsFor: 'compiling' stamp: 'di 12/4/1999 07:18'!
canFindWithoutEnvironment: varName
	"This method is used for analysis of system structure -- see senders."
	"Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment."

	| assoc |
	"First look in classVar dictionary."
	(assoc _ self classPool associationAt: varName ifAbsent: []) == nil
		ifFalse: [^ true].

	"Next look in shared pools."
	self sharedPools do: 
		[:pool | 
		assoc _ pool associationAt: varName ifAbsent: [
			"Hideous string key hack from Hypersqueak now used in Wonderland"
			pool associationAt: varName asString ifAbsent: []].
		assoc == nil ifFalse: 
				[^ true]].

	"Finally look higher up the superclass chain and fail at the end."
	superclass == nil
		ifTrue: [^ false]
		ifFalse: [^ superclass scopeHas: varName ifTrue: [:ignored]].

! !

!Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'!
compileAll
	super compileAll.
	self class compileAll.! !

!Class methodsFor: 'compiling'!
compileAllFrom: oldClass
	"Recompile all the methods in the receiver's method dictionary (not the
	subclasses). Also recompile the methods in the metaclass."

	super compileAllFrom: oldClass.
	self class compileAllFrom: oldClass class! !

!Class methodsFor: 'compiling'!
possibleVariablesFor: misspelled continuedFrom: oldResults

	| results |
	results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
	self sharedPools do: [:pool | 
		results _ misspelled correctAgainstDictionary: pool continuedFrom: results ].
	superclass == nil
		ifTrue: 
			[ ^ misspelled correctAgainstDictionary: Smalltalk continuedFrom: results ]
		ifFalse:
			[ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! !

!Class methodsFor: 'compiling' stamp: 'di 12/4/1999 16:51'!
scopeHas: varName ifTrue: assocBlock
	"Look up the first argument, varName, in the context of the receiver. If it is there,
	pass the association to the second argument, assocBlock, and answer true."

	| assoc |
	"First look in classVar dictionary."
	(assoc _ self classPool associationAt: varName ifAbsent: []) == nil
		ifFalse: [assocBlock value: assoc.
				^ true].

	"Next look in shared pools."
	self sharedPools do: 
		[:pool | 
		assoc _ pool associationAt: varName ifAbsent: [
			"String key hack from Hypersqueak now used in Wonderland  **Eliminate this**"
			pool associationAt: varName asString ifAbsent: []].
		assoc == nil ifFalse: 
				[assocBlock value: assoc.
				^true]].

	"Next look in declared environment."
	(assoc _ self environment associationAtOrAbove: varName ifAbsent: [nil]) == nil
		ifFalse: [assocBlock value: assoc.
				^ true].

	"Finally look higher up the superclass chain and fail at the end."
	superclass == nil
		ifTrue: [^ false]
		ifFalse: [^ superclass scopeHas: varName ifTrue: assocBlock].

! !


!Class methodsFor: 'subclass creation' stamp: 'RAA 6/22/2000 14:17'!
newSubclass
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [i _ i + 1].

	^ self subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: Object categoryForUniclasses

"Point newSubclass new"! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver)."
	^(ClassBuilder new)
		superclass: self
		subclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'!
variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	^(ClassBuilder new)
		superclass: self
		variableByteSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!
variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."
	^(ClassBuilder new)
		superclass: self
		variableSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'!
variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable word-sized nonpointer variables."
	^(ClassBuilder new)
		superclass: self
		variableWordSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat
! !

!Class methodsFor: 'subclass creation' stamp: 'dwh 11/20/1999 23:44'!
weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	^(ClassBuilder new)
		superclass: self
		weakSubclass: t
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !


!Class methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:58'!
fileOut
	"Create a file whose name is the name of the receiver with '.st' as the 
	extension, and file a description of the receiver onto it."
	^ self fileOutAsHtml: false! !

!Class methodsFor: 'fileIn/Out' stamp: 'tk 1/8/1999 08:01'!
fileOutAsHtml: useHtml
	"File a description of the receiver onto a new file whose base name is the name of the receiver."

	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml]
		ifFalse: [FileStream newFileNamed: self name, FileDirectory dot, 'st'].
	fileStream header; timeStamp.
	self sharedPools size > 0 ifTrue: [
		self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: fileStream]].
	self fileOutOn: fileStream moveSource: false toFile: 0.
	fileStream trailer; close.

	DeepCopier new checkVariables.
! !

!Class methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:32'!
fileOutInitializerOn: aStream
	^self class fileOutInitializerOn: aStream! !

!Class methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:30'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."
	^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !

!Class methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:29'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."

	Transcript cr; show: name.
	super
		fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	self class nonTrivial
		ifTrue:
			[aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
			self class
				fileOutOn: aFileStream
				moveSource: moveSource
				toFile: fileIndex
				initializing: aBool]! !

!Class methodsFor: 'fileIn/Out' stamp: 'dtl 1/15/2000 17:54'!
fileOutPool: aPool onFileStream: aFileStream 
	| aPoolName aValue |
	aPoolName _ Smalltalk keyAtIdentityValue: aPool.
	Transcript cr; show: aPoolName.
	aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr.
	aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr.
	aPool keys asSortedCollection do: [ :aKey |
		aValue _ aPool at: aKey.
		aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put:  '.
		(aValue isKindOf: Number)
			ifTrue: [aValue printOn: aFileStream]
			ifFalse: [aFileStream nextPutAll: '('.
					aValue printOn: aFileStream.
					aFileStream nextPutAll: ')'].
		aFileStream nextPutAll: '!!'; cr].
	aFileStream cr! !

!Class methodsFor: 'fileIn/Out' stamp: 'ar 2/13/1999 21:17'!
fileOutSharedPoolsOn: aFileStream
	"file out the shared pools of this class after prompting the user about each pool"
	| poolsToFileOut |
	poolsToFileOut _ self sharedPools select: 
		[:aPool | (self shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool))].
	poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream].
	! !

!Class methodsFor: 'fileIn/Out' stamp: 'tk 11/6/2000 20:58'!
objectForDataStream: refStrm
	| |
	"I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

	refStrm insideASegment
		ifFalse: ["Normal use"
			^ DiskProxy global: self theNonMetaClass name selector: #yourself
				args: #()]
		ifTrue: ["recording objects to go into an ImageSegment"
			self isSystemDefined ifFalse: [^ self].		"do trace Player classes"
			(refStrm rootObject includes: self) ifTrue: [^ self].
				"is in roots, intensionally write out, ^ self"
			
			"A normal class.  remove it from references.  Do not trace."
			refStrm references removeKey: self ifAbsent: []. 	"already there"
			^ nil]
! !

!Class methodsFor: 'fileIn/Out'!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	super reformatAll.		"me..."
	self class reformatAll	"...and my metaclass"! !

!Class methodsFor: 'fileIn/Out'!
removeFromChanges
	"References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet.
	7/18/96 sw: call removeClassAndMetaClassChanges:"

	Smalltalk changes removeClassAndMetaClassChanges: self! !

!Class methodsFor: 'fileIn/Out'!
shouldFileOutPool: aPoolName
	"respond with true if the user wants to file out aPoolName"
	^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! !

!Class methodsFor: 'fileIn/Out'!
shouldFileOutPools
	"respond with true if the user wants to file out the shared pools"
	^self confirm: 'FileOut selected sharedPools?'! !

!Class methodsFor: 'fileIn/Out' stamp: 'tk 9/27/2000 11:40'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	(aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ super storeDataOn: aDataStream].	"do trace me"
	self error: 'use a DiskProxy to store a Class'! !


!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'!
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'].
	subclasses == nil
		ifTrue:	[subclasses _ Array with: aSubclass.
				^self].
	subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass"
	subclasses _ subclasses copyWith: aSubclass.! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	subclasses == nil ifFalse:
		[subclasses _  subclasses copyWithout: aSubclass.
		subclasses isEmpty ifTrue: [subclasses _ nil]].
! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!
subclasses
	"Answer a Set containing the receiver's subclasses."

	^subclasses == nil
		ifTrue: [#()]
		ifFalse: [subclasses copy]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil 
		ifFalse:[subclasses do: aBlock]! !

!Class methodsFor: 'accessing class hierarchy' stamp: 'tk 8/18/1999 17:42'!
subclassesDoGently: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil 
		ifFalse: [subclasses do: aBlock]! !


!Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'!
setName: aSymbol
	"Private - set the name of the class"
	name _ aSymbol.! !


!Class methodsFor: 'organization' stamp: 'di 11/16/1999 16:25'!
environment

	environment == nil ifTrue: [^ super environment].
	^ environment! !

!Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'!
environment: anEnvironment

	environment _ anEnvironment! !

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

Class class
	instanceVariableNames: ''!

!Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 22:01'!
template: aSystemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class."

	^ self templateForSubclassOf: Object name category: aSystemCategoryName ! !

!Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 21:57'!
templateForSubclassOf: priorClassName category: systemCategoryName 
	"Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given"

	Preferences printAlternateSyntax 
		ifTrue: [^ priorClassName asString, ' subclass (#NameOfSubclass)
	instanceVariableNames ('''')
	classVariableNames ('''')
	poolDictionaries ('''')
	category (''' , systemCategoryName asString , ''')']
		ifFalse: [^ priorClassName asString, ' subclass: #NameOfSubclass
	instanceVariableNames: ''''
	classVariableNames: ''''
	poolDictionaries: ''''
	category: ''' , systemCategoryName asString , '''']! !


!Class class methodsFor: 'fileIn/Out'!
fileOutPool: aString
	"file out the global pool named aString"
	| f |
	f _ FileStream newFileNamed: aString, '.st'.
	self new fileOutPool: (Smalltalk at: aString asSymbol) onFileStream: f. 	f close.
	! !
Object subclass: #ClassBuilder
	instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex '
	classVariableNames: 'QuietMode '
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassBuilder commentStamp: '<historical>' prior: 0!
Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more.

You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works.
!


!ClassBuilder methodsFor: 'initialize' stamp: 'ar 11/22/1999 10:09'!
doneCompiling: aClass
	"The receiver has finished modifying the class hierarchy.
	Do any necessary cleanup."
	aClass doneCompiling.! !

!ClassBuilder methodsFor: 'initialize' stamp: 'ar 8/29/1999 12:32'!
initialize
	environ _ Smalltalk.
	instVarMap _ IdentityDictionary new.! !


!ClassBuilder methodsFor: 'class definition' stamp: 'ar 11/22/1999 03:21'!
class: oldClass instanceVariableNames: instVarString unsafe: unsafe
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	| instVars newClass |
	environ _ oldClass environment.
	instVars _ Scanner new scanFieldNames: instVarString.
	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil].
		(self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]].
	"Create a template for the new class (will return oldClass when there is no change)"
	newClass _ self 
		newSubclassOf: oldClass superclass 
		type: oldClass typeOfClass
		instanceVariables: instVars
		from: oldClass
		unsafe: unsafe.

	newClass == nil ifTrue:[^nil]. "Some error"
	newClass _ self recompile: false from: oldClass to: newClass mutate: false.
	self doneCompiling: newClass.
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/26/1999 12:54'!
mutate: oldClass to: newClass
	"Mutate oldClass to newClass.
	Convert all instances of oldClass and recursively update
	the subclasses."
	| subs newSubclass oldSubclass |
	subs _ oldClass subclasses asArray.

	"Walk down"
	1 to: subs size do:[:i|
		oldSubclass _ subs at: i.
		self showProgressFor: oldSubclass.
		"Create the new class"
		newSubclass _ self reshapeClass: oldSubclass to: nil super: newClass.
		self mutate: oldSubclass to: newSubclass.
	].
	oldClass obsolete.
	newClass isObsolete ifTrue:[newClass obsolete].
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'!
name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category
	"Define a new class in the given environment"
	^self 
		name: className 
		inEnvironment: env 
		subclassOf: newSuper 
		type: type 
		instanceVariableNames: instVarString 
		classVariableNames: classVarString 
		poolDictionaries: poolString 
		category: category
		unsafe: false! !

!ClassBuilder methodsFor: 'class definition' stamp: 'di 12/23/1999 15:23'!
name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe
	"Define a new class in the given environment.
	If unsafe is true do not run any validation checks.
	This facility is provided to implement important system changes."
	| oldClass newClass organization instVars classVars force |
	environ _ env.
	instVars _ Scanner new scanFieldNames: instVarString.
	classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol].

	"Validate the proposed name"
	unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]].
	oldClass _ env at: className ifAbsent:[nil].
	oldClass isBehavior 
		ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:"

	unsafe ifFalse:[
		"Run validation checks so we know that we have a good chance for recompilation"
		(self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil].
		(self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil].
		(self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]].

	"Create a template for the new class (will return oldClass when there is no change)"
	newClass _ self 
		newSubclassOf: newSuper 
		type: type 
		instanceVariables: instVars
		from: oldClass
		unsafe: unsafe.

	newClass == nil ifTrue:[^nil]. "Some error"

	newClass == oldClass ifFalse:[newClass setName: className].

	"Install the class variables and pool dictionaries... "
	force _ (newClass declare: classVarString) | (newClass sharing: poolString).

	"... classify ..."
	organization _ environ ifNotNil:[environ organization].
	organization classify: newClass name under: category asSymbol.
	newClass environment: environ.

	"... recompile ..."
	newClass _ self recompile: force from: oldClass to: newClass mutate: false.

	"... export if not yet done ..."
	(environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[
		environ at: newClass name put: newClass.
		Smalltalk flushClassNameCache.
	].
	"... and fix eventual references to obsolete globals."
	oldClass _ nil. "So we have no references to the old class anymore"
	self fixGlobalReferences.
	self doneCompiling: newClass.
	^newClass
! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:36'!
newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe
	"Create a new subclass of the given superclass.
	Note: The new class may be meta."
	| newFormat newClass meta |
	"Compute the format of the new class"
	newFormat _ 
		self computeFormat: type 
			instSize: instVars size 
			forSuper: newSuper 
			ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]).
	newFormat == nil ifTrue:[^nil].

	"Check if we really need a new subclass"
	(oldClass ~~ nil and:[
		newSuper == oldClass superclass and:[
			newFormat = oldClass format and:[
				instVars = oldClass instVarNames]]]) 
					ifTrue:[^oldClass].

	unsafe ifFalse:[
		"Make sure we don't redefine any dangerous classes"
		(self tooDangerousClasses includes: oldClass name) ifTrue:[
			self error: oldClass name, ' cannot be changed'.
			^nil].

		"Check if the receiver should not be redefined"
		(oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[
			self notify: oldClass name asText allBold, 
						' should not be redefined!! \Proceed to store over it.' withCRs]].

	oldClass == nil ifTrue:["Requires new metaclass"
		meta _ Metaclass new.
		meta
			superclass: (newSuper ifNil:[Class] ifNotNil:[newSuper class])
			methodDictionary: MethodDictionary new
			format: (newSuper ifNil:[Class format] ifNotNil:[newSuper class format]).
		meta superclass addSubclass: meta. "In case of Class"
		newClass _ meta new.
	] ifFalse:[ newClass _ oldClass shallowCopy ].
	newClass 
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: newFormat;
		setInstVarNames: instVars;
		organization: (oldClass ifNotNil:[oldClass organization]).
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/9/1999 16:00'!
recompile: force from: oldClass to: aClass mutate: forceMutation
	"Do the necessary recompilation after changine oldClass to newClass.
	If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass
	and all its subclasses. If forceMutation is true force a mutation even
	if oldClass and newClass are the same."
	| newClass |
	newClass _ aClass.

	oldClass == nil ifTrue:[
		"newClass has an empty method dictionary
		so we don't need to recompile"
		Smalltalk changes addClass: newClass.
		newClass superclass addSubclass: newClass.
		^newClass].

	(newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[
		"No recompilation necessary but we might have added
		class vars or class pools so record the change"
		Smalltalk changes changeClass: newClass from: oldClass.
		^newClass].

	currentClassIndex _ 0.
	maxClassIndex _ oldClass withAllSubclasses size.

	(oldClass == newClass and:[forceMutation not]) ifTrue:[
		Smalltalk changes changeClass: newClass from: oldClass.
		"Recompile from newClass without mutating"
		self informUserDuring:[
			newClass isSystemDefined ifFalse:[progress _ nil].
			newClass withAllSubclassesDo:[:cl|
				self showProgressFor: cl.
				cl compileAll]].
		^newClass].
	"Recompile and mutate oldClass to newClass"
	classMap _ WeakValueDictionary new.
	self informUserDuring:[
		newClass isSystemDefined ifFalse:[progress _ nil].
		self showProgressFor: oldClass.
		newClass _ self reshapeClass: oldClass to: newClass super: newClass superclass.
		Smalltalk changes changeClass: newClass from: oldClass.
		self mutate: oldClass to: newClass.
	].
	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/5/1999 15:23'!
reshapeClass: aClass to: templateClass super: newSuper
	"Reshape the given class to the new super class.
	If templateClass is not nil then it defines the shape of the new class"
	| fmt newClass newMeta newSuperMeta oldMeta instVars oldClass |
	templateClass == nil
		ifTrue:[oldClass _ aClass]
		ifFalse:[oldClass _ templateClass].
	aClass becomeUncompact.
	"Compute the new format of the class"
	instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames].
	fmt _ self computeFormat: oldClass typeOfClass
				instSize: instVars size
				forSuper: newSuper
				ccIndex: 0."Known to be 0 since we uncompacted aClass first"
	fmt == nil ifTrue:[^nil].
	aClass isMeta ifFalse:["Create a new meta class"
		oldMeta _ aClass class.
		newMeta _ oldMeta clone.
		newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class].
		newMeta 
			superclass: newSuperMeta
			methodDictionary: MethodDictionary new
			format: (self computeFormat: oldMeta typeOfClass 
							instSize: oldMeta instVarNames size 
							forSuper: newSuperMeta
							ccIndex: 0);
			setInstVarNames: oldMeta instVarNames;
			organization: oldMeta organization.
		"Recompile the meta class"
		oldMeta hasMethods 
			ifTrue:[newMeta compileAllFrom: oldMeta].
		"Fix up meta class structure"
		oldMeta superclass removeSubclass: oldMeta.
		newMeta superclass addSubclass: newMeta.
		"And record the change so we can fix global refs later"
		self recordClass: oldMeta replacedBy: newMeta.
	].
	newClass _ newMeta == nil
		ifTrue:[oldClass clone]
		ifFalse:[newMeta adoptInstance: oldClass from: oldMeta].
	newClass
		superclass: newSuper
		methodDictionary: MethodDictionary new
		format: fmt;
		setInstVarNames: instVars;
		organization: aClass organization.

	"Recompile the new class"
	aClass hasMethods 
		ifTrue:[newClass compileAllFrom: aClass].

	"Export the new class into the environment"
	aClass isMeta ifFalse:[
		"Derefence super sends in the old class"
		self fixSuperSendsFrom: aClass.
		"Export the class"
		environ at: newClass name put: newClass.
		"And use the ST association in the new class"
		self fixSuperSendsTo: newClass].

	"Fix up the class hierarchy"
	aClass superclass removeSubclass: aClass.
	newClass superclass addSubclass: newClass.

	"Adopt all the instances of the old class"
	aClass autoMutateInstances
		ifTrue:[newClass updateInstancesFrom: aClass].

	"And record the change"
	self recordClass: aClass replacedBy: newClass.

	^newClass! !

!ClassBuilder methodsFor: 'class definition' stamp: 'ar 11/22/1999 03:20'!
silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName
	"Move the instvar from srcClass to dstClass.
	Do not perform any checks."
	| srcVars dstVars dstIndex |
	srcVars _ srcClass instVarNames copyWithout: instVarName.
	srcClass == dstClass
		ifTrue:[dstVars _ srcVars]
		ifFalse:[dstVars _ dstClass instVarNames].
	dstIndex _ dstVars indexOf: prevInstVarName.
	dstVars _ (dstVars copyFrom: 1 to: dstIndex),
				(Array with: instVarName),
				(dstVars copyFrom: dstIndex+1 to: dstVars size).
	instVarMap at: srcClass name put: srcVars.
	instVarMap at: dstClass name put: dstVars.
	(srcClass inheritsFrom: dstClass) ifTrue:[
		self recompile: false from: dstClass to: dstClass mutate: true.
	] ifFalse:[
		(dstClass inheritsFrom: srcClass) ifTrue:[
			self recompile: false from: srcClass to: srcClass mutate: true.
		] ifFalse:[ "Disjunct hierarchies"
			srcClass == dstClass ifFalse:[
				self recompile: false from: dstClass to: dstClass mutate: true.
			].
			self recompile: false from: srcClass to: srcClass mutate: true.
		].
	].
	self doneCompiling: srcClass.
	self doneCompiling: dstClass.! !


!ClassBuilder methodsFor: 'class format' stamp: 'ar 9/10/1999 12:55'!
computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
	"Compute the new format for making oldClass a subclass of newSuper.
	Return the format or nil if there is any problem."
	| instSize isVar isWords isPointers isWeak |
	instSize _ newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
	instSize > 254 ifTrue:[
		self error: 'Class has too many instance variables (', instSize printString,')'.
		^nil].
	type == #compiledMethod
		ifTrue:[^CompiledMethod instSpec].
	type == #normal ifTrue:[isVar _ isWeak _ false. isWords _ isPointers _ true].
	type == #bytes ifTrue:[isVar _ true. isWords _ isPointers _ isWeak _ false].
	type == #words ifTrue:[isVar _ isWords _ true. isPointers _ isWeak _ false].
	type == #variable ifTrue:[isVar _ isPointers _ isWords _ true. isWeak _ false].
	type == #weak ifTrue:[isVar _ isWeak _ isWords _ isPointers _ true].
	(isPointers not and:[instSize > 0]) ifTrue:[
		self error:'A non-pointer class cannot have instance variables'.
		^nil].
	^(self format: instSize 
		variable: isVar 
		words: isWords 
		pointers: isPointers 
		weak: isWeak) + (ccIndex bitShift: 11).! !

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


!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:41'!
validateClass: srcClass forMoving: iv downTo: dstClass
	"Make sure that we don't have any accesses to the instVar left"
	srcClass withAllSubclassesDo:[:cls|
		(cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[
			cls forgetDoIts.
			(cls whichSelectorsAccess: iv) isEmpty ifFalse:[
				self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'.
Proceed to move it to Undeclared'.
			].
		].
	].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'!
validateClass: srcClass forMoving: iv upTo: dstClass
	"Make sure we don't have this instvar already"
	dstClass withAllSubclassesDo:[:cls|
		(cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[
			cls isPointers ifFalse:[
				self error: dstClass name, ' cannot have instance variables'.
				^false].
			cls instSize >= 254 ifTrue:[
				self error: cls name, ' has more than 254 instance variables'.
				^false].
			(cls instVarNames includes: iv) ifTrue:[
				self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,'
Proceed to move it up to ', dstClass name asText allBold,' as well'.
				instVarMap at: cls name put: (cls instVarNames copyWithout: iv)].
		].
	].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/13/1999 05:26'!
validateClassName: aString
	"Validate the new class name"
	aString first isUppercase ifFalse:[
		self error: 'Class names must be capitalized'.
		^false].
	environ at: aString ifPresent:[:old|
		(old isKindOf: Behavior) ifFalse:[
			self notify: aString asText allBold, 
						' already exists!!\Proceed will store over it.' withCRs]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:48'!
validateClassvars: classVarArray from: oldClass forSuper: newSuper
	"Check if any of the classVars of oldClass conflict with the new superclass"
	| usedNames classVars temp |
	classVarArray isEmpty ifTrue:[^true]. "Okay"

	"Validate the class var names"
	usedNames _ classVarArray asSet.
	usedNames size = classVarArray size 
		ifFalse:[	classVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper == nil ifFalse:[
		usedNames _ newSuper allClassVarNames asSet.
		classVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl classVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv, ' is already defined in ', temp name.
				^false]]].

	oldClass == nil ifFalse:[
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl classVarNames].
		classVars _ classVarArray.
		newSuper == nil ifFalse:[classVars _ classVars, newSuper allClassVarNames asArray].
		classVars do:[:iv|
			(usedNames includes: iv) ifTrue:[
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:49'!
validateInstvars: instVarArray from: oldClass forSuper: newSuper
	"Check if any of the instVars of oldClass conflict with the new superclass"
	| instVars usedNames temp |
	instVarArray isEmpty ifTrue:[^true]. "Okay"

	"Validate the inst var names"
	usedNames _ instVarArray asSet.
	usedNames size = instVarArray size 
		ifFalse:[	instVarArray do:[:var|
					usedNames remove: var ifAbsent:[temp _ var]].
				self error: temp,' is multiply defined'. ^false].
	(usedNames includesAnyOf: self reservedNames) 
		ifTrue:[	self reservedNames do:[:var|
					(usedNames includes: var) ifTrue:[temp _ var]].
				self error: temp,' is a reserved name'. ^false].

	newSuper == nil ifFalse:[
		usedNames _ newSuper allInstVarNames asSet.
		instVarArray do:[:iv|
			(usedNames includes: iv) ifTrue:[
				newSuper withAllSuperclassesDo:[:cl|
					(cl instVarNames includes: iv) ifTrue:[temp _ cl]].
				self error: iv,' is already defined in ', temp name.
				^false]]].
	oldClass == nil ifFalse:[
		usedNames _ Set new: 20.
		oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames].
		instVars _ instVarArray.
		newSuper == nil ifFalse:[instVars _ instVars, newSuper allInstVarNames].
		instVars do:[:iv|
			(usedNames includes: iv) ifTrue:[
				self error: iv, ' is already defined in a subclass of ', oldClass name.
				^false]]].
	^true! !

!ClassBuilder methodsFor: 'validation' stamp: 'di 11/24/1999 13:09'!
validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize
	"Validate the # of instVars and the format of the subclasses"
	| deltaSize oldType |
	oldClass == nil ifTrue: [^ true]. "No subclasses"
	"Compute the # of instvars needed for all subclasses"
	deltaSize _ newInstSize.
	(oldClass notNil)
		ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size].
	(newSuper notNil)
		ifTrue: [deltaSize _ deltaSize + newSuper instSize].
	(oldClass notNil and: [oldClass superclass notNil]) 
		ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize].
	oldClass == nil ifTrue: [
		deltaSize > 254 ifTrue: [
			self error: 'More than 254 instance variables'.
			^ false].
		^ true].
	oldClass withAllSubclassesDo: [:sub |
		sub instSize + deltaSize > 254 ifTrue: [
			self error: sub name,' has more than 254 instance variables'.
			^ false]].
	newType ~~ #normal ifTrue:
		["And check if the immediate subclasses of oldClass can keep its layout"
		oldClass subclassesDo:[:sub|
			oldType _ sub typeOfClass.
			oldType == newType ifFalse: [
				self error: sub name,' cannot be recompiled'.
				^ false]]].
	^ true! !

!ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'!
validateSuperclass: aSuperClass forSubclass: aClass
	"Check if it is okay to use aSuperClass as the superclass of aClass"
	aClass == nil ifTrue:["New class"
		(aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]])
			ifFalse:[self error: aSuperClass name,' is not a valid superclass'.
					^false].
		^true].
	aSuperClass == aClass superclass ifTrue:[^true]. "No change"
	(aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy"
		ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name].
	"Check for circular references"
	(aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]])
		ifTrue:[self error: aSuperClass name,' inherits from ', aClass name.
				^false].
	^true! !


!ClassBuilder methodsFor: 'private' stamp: 'ls 10/23/2000 14:10'!
fixGlobalReferences
	"Fix all the references to globals which are now outdated.
	Care must be taken that we do not accidentally 'fix' dangerous stuff."
	| oldClasses newClasses condition any |
	classMap == nil ifTrue:[^self].
	(self retryWithGC: [condition _ classMap anySatisfy: [:any0 | any _ any0. any0 _ nil. any notNil and:[any
isObsolete]]. any_nil. condition]
		until:[:obsRef| obsRef = false])
		ifFalse:[^self]. "GC cleaned up the remaining refs"
	"Collect the old and the new refs"
	oldClasses _ OrderedCollection new.
	newClasses _ OrderedCollection new.
	classMap keysAndValuesDo:[:new :old|
		old == nil ifFalse:[
			newClasses add: new.
			oldClasses add: old]].
	oldClasses isEmpty ifTrue:[^self]. "GC cleaned up the rest"

	"Now fix all the known dangerous pointers to old classes by creating
	copies of those still needed. Dangerous pointers should come only
	from obsolete subclasses (where the superclass must be preserved)."
	self fixObsoleteReferencesTo: oldClasses.

	"After this has been done fix the remaining references"
	progress == nil ifFalse:[progress value: 'Fixing references to
globals'].
	"Forward all old refs to the new ones"
	(oldClasses asArray) elementsForwardIdentityTo: (newClasses asArray).
	"Done"! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 7/20/1999 10:45'!
fixObsoleteMethodsFrom: oldClasses map: obsoleteClasses
	"Fix the methods of the obsolete classes"
	| nLits tempMethod |
	oldClasses do:[:class|
		obsoleteClasses at: class ifPresent:[:tempClass|
			class selectorsAndMethodsDo:[:sel :meth|
				"Create a clean copy for the temps"
				tempMethod _ meth copy.
				"Fix the super sends"
				tempMethod sendsToSuper ifTrue:[
					nLits _ tempMethod numLiterals.
					"Hack the method class in the temp class"
					tempMethod literalAt: nLits put: 
						(Association new value: 
							(obsoleteClasses at: class ifAbsent:[class])).
				].
				"Install in tempClass"
				tempClass addSelector: sel withMethod: tempMethod.
			].
		].
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'tk 2/15/2000 13:58'!
fixObsoleteReferencesTo: oldClasses
	"Fix all obsolete references to the given set of outdated classes"
	| obsoleteClasses obj |
	progress == nil ifFalse:[progress value:'Fixing obsolete class references...'].
	"Prepare a map of obsolete classes"
	obsoleteClasses _ self mapObsoleteClassesToTemps: oldClasses.
	"Sanity check for debugging"
	"oldClasses size = obsoleteClasses size ifFalse:[self error:'Obsolete classes size mismatch']."
	"Fix the methods"
	self fixObsoleteMethodsFrom: oldClasses map: obsoleteClasses.
	"Now search and fix all dangerous objects"
	obj _ 0 someObject.
	[0 == obj] whileFalse:[
		"Avoid proxies on the disk.  See below."
		obj isInMemory ifTrue:[
			(obj isBehavior and:[obsoleteClasses includesKey: obj superclass]) ifTrue:[
				(obsoleteClasses includesKey: obj) ifFalse:[
						obj superclass: (obsoleteClasses at: obj superclass)]]].
		obj _ obj nextObject.
	].

"Three kinds of ProtoObjects need to be considered:
ObjectTracer and ObjectViewer		OK to test.  They are not Behaviors, and the object they represent will be found and fixed.  Traces may be recorded, but they should be.

ObjectOut and MorphObjectOut		Skip them.  The objects they represent are in SqueakPages, and are not really in this image.  Do not want to bring them all in!!

ImageSegmentRootStub		Skip them.  Might stand for a class, or its segment might contain a class.  But, that class can't be the one being cleaned up now.  If instances of the class being fixed are in a segment, the class is in the outPointers, and will be found normally.
"
! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:03'!
fixSuperSendsFrom: oldClass
	"The oldClass is about to be removed from the environment.
	Fix all references to super so that the association is different from
	the original ST association."
	| newSuper nLits lastLiteral |
	newSuper _ Association key: nil value: oldClass.
	oldClass methodsDo:[:meth|
		nLits _ meth numLiterals.
		nLits > 0 
			ifTrue:[lastLiteral _ meth literalAt: nLits]
			ifFalse:[lastLiteral _ nil].
		(lastLiteral class == Association and:[meth sendsToSuper]) ifTrue:[
			meth literalAt: nLits put: newSuper.
		].
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:04'!
fixSuperSendsTo: newClass
	"The newClass has been exported into the environment.
	Fix all references to super so that the association is
	the original ST association."
	| newSuper nLits lastLiteral |
	newSuper _ Smalltalk associationAt: newClass name ifAbsent:[nil].
	newSuper == nil ifTrue:[^self].
	newSuper value == newClass ifTrue:[^self].
	newClass methodsDo:[:meth|
		nLits _ meth numLiterals.
		nLits > 0 
			ifTrue:[lastLiteral _ meth literalAt: nLits]
			ifFalse:[lastLiteral _ nil].
		(lastLiteral class == Association and:[meth sendsToSuper]) ifTrue:[
			meth literalAt: nLits put: newSuper.
		].
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 13:03'!
informUserDuring: aBlock
	self class isSilent ifTrue:[^aBlock value].
	Utilities informUserDuring:[:bar|
		progress _ bar.
		aBlock value].
	progress _ nil.! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:29'!
mapObsoleteClassesToTemps: oldClasses
	"Map the old classes to temporary classes.
	These temporary classes will survive the #become:
	operation and be used as the class of any instances
	or subclasses of the obsolete classes."
	| oldMeta tempMeta obsoleteClasses |
	obsoleteClasses _ IdentityDictionary new: oldClasses size.
	oldClasses do:[:oldClass| 
		"Note: If a class is getting obsolete here so is its metaclass"
		oldMeta _ oldClass isMeta ifTrue:[oldClass] ifFalse:[oldClass class].
		tempMeta _ obsoleteClasses at: oldMeta ifAbsentPut:[oldMeta clone].
		oldClass isMeta ifFalse:[
			tempMeta adoptInstance: oldClass from: oldMeta.
			obsoleteClasses at: oldClass put: tempMeta soleInstance.
			"Note: If we haven't mutated the instances of the old class to the new
			layout we must do it here."
			oldClass autoMutateInstances ifFalse:[
				tempMeta soleInstance updateInstancesFrom: oldClass]]].
	"Fix the superclasses of the clones"
	obsoleteClasses keysAndValuesDo:[:old :temp|
		temp superclass: 
			(obsoleteClasses 
				at: temp superclass
				"Might be a subclass of a live class"
				ifAbsent:[temp superclass])].
	"And install new method dictionaries"
	obsoleteClasses valuesDo:[:temp|
		temp methodDictionary: temp methodDictionary copy.
	].
	^obsoleteClasses! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 7/20/1999 00:00'!
recordClass: oldClass replacedBy: newClass
	"Record the replacement of oldClass by newClass so that we can
	fix any references to oldClass later on."
	classMap at: newClass put: oldClass.
	(classMap includesKey: oldClass) ifTrue:[
		"This will happen if we recompile from Class
		in which case the metaclass gets recorded twice"
		classMap at: newClass put: (classMap at: oldClass).
		classMap removeKey: oldClass.
	].
	"And keep the changes up to date"
	(instVarMap includesKey: oldClass name) ifTrue:[
		Smalltalk changes changeClass: newClass from: oldClass.
	].! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 7/15/1999 13:39'!
reservedNames
	"Return a list of names that must not be used for variables"
	^#('self' 'super' 'thisContext' 'true' 'false' 'nil' 
		self super thisContext true false nil).! !

!ClassBuilder methodsFor: 'private' stamp: 'sw 7/31/2000 12:57'!
showProgressFor: aClass
	"Announce that we're processing aClass"
	progress == nil ifTrue:[^self].
	currentClassIndex _ currentClassIndex + 1.
	(aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue:
		[progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! !

!ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 15:43'!
tooDangerousClasses
	"Return a list of class names which will not be modified in the public interface"
	^#(
		"Object will break immediately"
		Object
		"Contexts and their superclasses"
		InstructionStream ContextPart BlockContext MethodContext
		"Superclasses of basic collections"
		Collection SequenceableCollection ArrayedCollection
		"Collections known to the VM"
		Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod
		"Basic Numbers"
		Magnitude Number SmallInteger Float
		"Misc other"
		LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject
	)
! !


!ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'!
class: oldClass instanceVariableNames: instVarString
	"This is the basic initialization message to change the definition of
	an existing Metaclass"
	oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass'].
	^self class: oldClass instanceVariableNames: instVarString unsafe: false! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'!
moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName
	"Move the given instVar from srcClass to dstClass"
	(srcClass instVarNames includes: instVarName)
		ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name].
	(prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName])
		ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name].
	(srcClass inheritsFrom: dstClass) ifTrue:[
		"Move the instvar up the hierarchy."
		(self validateClass: srcClass forMoving: instVarName upTo: dstClass)
			ifFalse:[^false].
	].
	(dstClass inheritsFrom: srcClass) ifTrue:[
		"Move the instvar down the hierarchy"
		(self validateClass: srcClass forMoving: instVarName downTo: dstClass)
			ifFalse:[^false].
	].
	^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: newSuper
	subclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class."
	^self 
		name: t
		inEnvironment: newSuper environment
		subclassOf: newSuper
		type: newSuper typeOfClass
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: aClass
	variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable byte-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(aClass isVariable and: [aClass isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #bytes
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'!
superclass: aClass
	variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #variable
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!
superclass: aClass
	variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class in which the subclass is to 
	have indexable word-sized nonpointer variables."
	(aClass instSize > 0)
		ifTrue: [^self error: 'cannot make a word subclass of a class with named fields'].
	(aClass isVariable and: [aClass isBytes])
		ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
	(aClass isVariable and: [aClass isPointers])
		ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields'].

	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #words
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

!ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'!
superclass: aClass
	weakSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have weak indexable pointer variables."
	aClass isBits 
		ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields'].
	^self 
		name: t
		inEnvironment: aClass environment
		subclassOf: aClass
		type: #weak
		instanceVariableNames: f
		classVariableNames: d
		poolDictionaries: s
		category: cat! !

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

ClassBuilder class
	instanceVariableNames: ''!

!ClassBuilder class methodsFor: 'testing' stamp: 'ar 7/15/1999 14:04'!
autoMutateInstances
	"Don't mutate me while I'm compiling myself"
	^false! !


!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'!
beSilent: aBool
	"ClassDefiner beSilent: true"
	"ClassDefiner beSilent: false"
	QuietMode _ aBool.! !

!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'!
beSilentDuring: aBlock
	"Temporarily suppress information about what is going on"
	| wasSilent result |
	wasSilent _ self isSilent.
	self beSilent: true.
	result _ aBlock value.
	self beSilent: wasSilent.
	^result! !

!ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'!
isSilent
	^QuietMode == true! !


!ClassBuilder class methodsFor: 'instance creation' stamp: 'ar 7/19/1999 23:28'!
new
	^super new initialize.! !
Object subclass: #ClassCategoryReader
	instanceVariableNames: 'class category changeStamp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassCategoryReader commentStamp: '<historical>' prior: 0!
I represent a mechanism for retrieving class descriptions stored on a file.!


!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 12/15/97 16:26'!
scanFrom: aStream 
	"File in methods from the stream, aStream."
	| methodText |
	[methodText _ aStream nextChunkText.
	 methodText size > 0]
		whileTrue:
		[class compile: methodText classified: category
			withStamp: changeStamp
			notifying: (SyntaxError new category: category)]! !

!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 23:24'!
scanFromNoCompile: aStream 
	"Just move the source code for the methods from aStream."
	| methodText selector |

	[methodText _ aStream nextChunkText.
	 methodText size > 0]
		whileTrue:
		[(SourceFiles at: 2) ifNotNil: [
			selector _ class parserClass new parseSelector: methodText.
			(class compiledMethodAt: selector) putSource: methodText 
				fromParseNode: nil class: class category: category
				withStamp: changeStamp inFile: 2 priorMethod: nil]]! !

!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'RAA 6/22/2000 16:08'!
scanFromNoCompile: aStream forSegment: anImageSegment

	^self scanFromNoCompile: aStream 	"subclasses may care about the segment"! !


!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory
	^ self setClass: aClass category: aCategory changeStamp: String new
! !

!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory changeStamp: aString

	class _ aClass.
	category _ aCategory.
	changeStamp _ aString
! !
Object subclass: #ClassChangeRecord
	instanceVariableNames: 'inForce revertable changeTypes thisDefinition priorDefinition thisName priorName thisOrganization priorOrganization thisComment priorComment thisMD priorMD methodChanges '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!ClassChangeRecord commentStamp: '<historical>' prior: 0!
A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not.

Structure:
inForce		a boolean
			Tells whether these changes are in effect.
			true for all changeSets in and above the current project.
			It should be sufficient only to record this for the changeSet
			as a whole, but this redundancy could help in error recovery.
classIsLocal	a boolean
			True if and only if this class is defined in this layer of the
			project structure.
changeTypes an identitySet
			Summarizes which changes have been made in this class.
			Values include #comment, #reorganize, #rename,
			and the four more summarized below.
thisName	a string
			Retains the class name for this layer.
priorName	a string
			Preserves the prior name.
thisComment	a text
			Retains the class comment for this layer.
priorComment	a text
			Preserves the prior comment.
thisOrganization	a classOrganizer
			Retains the class organization for this layer.
priorOrganization	a classOrganizer
			Preserves the prior organization.
thisMD	a methodDictionary
			Used to prepare changes for nearly atomic invocation
			of this layer (see below).
priorMD	a methodDictionary
			Preserves the state of an altered class as it exists in the next
			outer layer of the project structure.
methodChanges		a dictionary of classChangeRecords
			Retains all the method changes for this layer.

Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords.  Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state
			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

A classChangeRecorder is notified of changes by the method
		noteMethodChange: <ClassChangeRecord>.
ClassChangeRecorders are designed to invoke a set of changes relative to the definition of a class in an prior layer.  It is important that both invocation and revocation of these changes take place in a nearly atomic fashion so that interdependent changes will be adopted as a whole, and so that only one flush of the method cache should be necessary.  A further reason for revocation to be simple is that it may be requested as an attempt to recover from an error in a project that is failing.!


!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:39'!
allChangeTypes

	| chgs |
	(priorName ~~ nil and: [changeTypes includes: #rename]) ifTrue:
		[(chgs _ changeTypes copy) add: 'oldName: ' , priorName.
		^ chgs].
	^ changeTypes! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:59'!
assimilateAllChangesIn: otherRecord

	| selector changeRecord changeType |
	otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove].

	otherRecord allChangeTypes do:
		[:chg | self noteChangeType: chg fromClass: self realClass].

	otherRecord methodChanges associationsDo:
		[:assn | selector _ assn key. changeRecord _ assn value.
		changeType _ changeRecord changeType.
		(changeType == #remove or: [changeType == #addedThenRemoved])
			ifTrue:
				[changeType == #addedThenRemoved
					ifTrue: [self atSelector: selector put: #add].
				self noteRemoveSelector: selector priorMethod: nil
						lastMethodInfo: changeRecord methodInfoFromRemoval]
			ifFalse: 
				[self atSelector: selector put: changeType]].
! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 10:59'!
hasNoChanges

	^ changeTypes isEmpty and: [methodChanges isEmpty]! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/24/2000 09:36'!
includesChangeType: changeType

	changeType == #new ifTrue: [^ changeTypes includes: #add].  "Backwd compat"
	^ changeTypes includes: changeType! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 15:14'!
noteChangeType: changeSymbol

	^ self noteChangeType: changeSymbol fromClass: nil! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/5/2000 08:05'!
noteChangeType: changeSymbol fromClass: class

	(changeSymbol = #new or: [changeSymbol = #add]) ifTrue:
		[changeTypes add: #add.
		changeTypes remove: #change ifAbsent: [].
		revertable _ false.
		^ self].
	changeSymbol = #change ifTrue:
		[(changeTypes includes: #add) ifTrue: [^ self].
		^ changeTypes add: changeSymbol].
	changeSymbol = #comment ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #reorganize ifTrue:
		[^ changeTypes add: changeSymbol].
	changeSymbol = #rename ifTrue:
		[^ changeTypes add: changeSymbol].
	(changeSymbol beginsWith: 'oldName: ') ifTrue:
		["Must only be used when assimilating other changeSets"
		(changeTypes includes: #add) ifTrue: [^ self].
		priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size.
		^ changeTypes add: #rename].
	changeSymbol = #remove ifTrue:
		[(changeTypes includes: #add)
			ifTrue: [changeTypes add: #addedThenRemoved]
			ifFalse: [changeTypes add: #remove].
		^ changeTypes removeAllFoundIn: #(add change comment reorganize)].

	self error: 'Unrecognized changeType'! !

!ClassChangeRecord methodsFor: 'all changes' stamp: 'di 5/16/2000 08:43'!
trimHistory
	"Drop non-essential history."

	"Forget methods added and later removed"
	methodChanges keysAndValuesRemove:
		[:sel :chgRecord | chgRecord changeType == #addedThenRemoved].

	"Forget renaming and reorganization of newly-added classes."
	(changeTypes includes: #add) ifTrue:
		[changeTypes removeAllFoundIn: #(rename reorganize)].
! !


!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 22:00'!
invokePhase1

	| selector changeRecord type elements |
	revertable ifFalse: [^ self].
	inForce ifTrue: [self error: 'Can invoke only when not in force.'].

	"Do the first part of the invoke operation -- no particular hurry."
	"Save the outer method dictionary for quick revert of method changes."
	priorMD _ self realClass methodDict.

	"Prepare a methodDictionary for switcheroo."
	thisMD _ self realClass methodDict copy.
	methodChanges associationsDo:
		[:assn | selector _ assn key. changeRecord _ assn value.
		type _ changeRecord changeType.
		type = #remove ifTrue: [thisMD removeKey: selector].
		type = #add ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		type = #change ifTrue: [thisMD at: selector put: changeRecord currentMethod].
		].

	"Replace the original organization (and comment)."
	priorOrganization _ self realClass organization.
	thisOrganization elementArray copy do:
		[:sel | (thisMD includesKey: sel) ifFalse: [thisOrganization removeElement: sel]].
	#(DoIt DoItIn:) do: [:sel | thisMD removeKey: sel ifAbsent: []].
	thisOrganization elementArray size = thisMD size ifFalse:
		[elements _ thisOrganization elementArray asSet.
		thisMD keysDo:
			[:sel | (elements includes: sel) ifFalse:
				[thisOrganization classify: sel
					under: (priorOrganization categoryOfElement: sel)]]].
	self realClass organization: thisOrganization.


! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
invokePhase2

	revertable ifFalse: [^ self].

	"Do the second part of the revert operation.  This must be very simple."
	"Replace original method dicts if there are method changes."
	self realClass methodDictionary: thisMD.  "zap.  Must flush Cache in outer loop."
	inForce _ true.
! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/30/2000 18:03'!
realClass
	"Return the actual class (or meta), as determined from my name."

	thisName ifNil: [^ nil].
	(thisName endsWith: ' class')
		ifTrue: [^ (Smalltalk at: (thisName copyFrom: 1 to: thisName size - 6) asSymbol
						ifAbsent: [^ nil]) class]
		ifFalse: [^ Smalltalk at: thisName ifAbsent: [^ nil]]! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
revokePhase1

	revertable ifFalse: [^ self].
	inForce ifFalse: [self error: 'Can revoke only when in force.'].

	"Do the first part of the revoke operation.  This must be very simple."
	"Replace original method dict if there are method changes."
	self realClass methodDictionary: priorMD  "zap.  Must flush Cache in outer loop."! !

!ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/29/2000 14:50'!
revokePhase2

	revertable ifFalse: [^ self].

	"Replace the original organization (and comment)."
	thisOrganization _ self realClass organization.
	self realClass organization: priorOrganization.
	inForce _ false.
! !


!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:06'!
checkCoherence
	"If I recreate the class then don't remove it"

	(changeTypes includes: #remove) ifTrue:
		[changeTypes remove: #remove.
		changeTypes add: #change].
	(changeTypes includes: #addedThenRemoved) ifTrue:
		[changeTypes remove: #addedThenRemoved.
		changeTypes add: #add].
! !

!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:08'!
notePriorDefinition: oldClass

	oldClass ifNil: [^ self].
	priorDefinition ifNil: [priorDefinition _ oldClass definition]! !

!ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'!
priorDefinition

	^ priorDefinition! !


!ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'!
noteNewName: newName

	thisName _ newName! !

!ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'!
priorName

	^ priorName! !



!ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/4/2000 12:49'!
forgetChangesIn: otherRecord
	"See forgetAllChangesFoundIn:.  Used in culling changeSets."

	| cls otherMethodChanges selector actionToSubtract |
	(cls _ self realClass) == nil ifTrue: [^ self].  "We can do better now, though..."
	otherMethodChanges _ otherRecord methodChangeTypes.
	otherMethodChanges associationsDo:
		[:assoc | selector _ assoc key. actionToSubtract _ assoc value.
		(cls includesSelector: selector)
			ifTrue: [(#(add change) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: []]]
			ifFalse: [(#(remove addedThenRemoved) includes: actionToSubtract)
					ifTrue: [methodChanges removeKey: selector ifAbsent: []]]].
	changeTypes isEmpty ifFalse:
		[changeTypes removeAllFoundIn: otherRecord allChangeTypes.
		(changeTypes includes: #rename) ifFalse:
			[changeTypes removeAllSuchThat: [:x | x beginsWith: 'oldName: ']]]! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'di 3/23/2000 12:27'!
forgetClassRemoval

	self halt.! !

!ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/1/2000 23:05'!
isClassRemoval
	"NOTE: there are other removals with changeType #addedThenRemoved,
	but this message is used to write out removals in fileOut, and those
	cases should not be written out."

	^ (changeTypes includes: #remove) or: [changeTypes includes: #removeClass]! !



!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:38'!
atSelector: selector ifAbsent: absentBlock

	^ (methodChanges at: selector ifAbsent: absentBlock)
		changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'!
atSelector: selector put: changeType

	(self findOrMakeMethodChangeAt: selector priorMethod: nil)
		noteChangeType: changeType! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:07'!
changedSelectors
	"Return a set of the changed or removed selectors."

	^ methodChanges keys! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 10:45'!
compileAll: newClass from: oldClass
	"Something about this class has changed.  Locally retained methods must be recompiled.
	NOTE:  You might think that if this changeSet is in force, then we can just note
	the new methods but a lower change set may override and be in force which
	would mean that only the overriding copies go recompiled.  Just do it."

	| sel changeType changeRecord newMethod |
	methodChanges associationsDo:
		[:assn | sel _ assn key.  changeRecord _ assn value.
		changeType _ changeRecord changeType.
		(changeType == #add or: [changeType == #change]) ifTrue:
			[newMethod _ newClass
				recompileNonResidentMethod: changeRecord currentMethod
				atSelector: sel from: oldClass.
			changeRecord noteNewMethod: newMethod]]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'!
findOrMakeMethodChangeAt: selector priorMethod: priorMethod

	^ methodChanges at: selector
		ifAbsent: [methodChanges at: selector
						put: (MethodChangeRecord new priorMethod: priorMethod)]! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/29/2000 16:26'!
infoFromRemoval: selector

	^ (methodChanges at: selector ifAbsent: [^ nil])
		methodInfoFromRemoval

! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/24/2000 09:46'!
methodChangeTypes
	"Return an old-style dictionary of method change types."

	| dict selector record |
	dict _ IdentityDictionary new.
	methodChanges associationsDo:
		[:assn | selector _ assn key.  record _ assn value.
		dict at: selector put: record changeType].
	^ dict! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 23:49'!
methodChanges

	^ methodChanges! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 23:28'!
noteNewMethod: newMethod selector: selector priorMethod: methodOrNil

	| methodChange |
	methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil.
	methodOrNil == nil
		ifTrue: [methodChange noteChangeType: #add]
		ifFalse: [methodChange noteChangeType: #change].
	methodChange noteNewMethod: newMethod.
! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 23:00'!
noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: infoOrNil

	| methodChange |
	methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: priorMethod.
	methodChange changeType == #add
		ifTrue: [methodChange noteChangeType: #addedThenRemoved]
		ifFalse: [methodChange noteChangeType: #remove].

	infoOrNil ifNotNil:
		["Save the source code pointer and category so can still browse old versions"
		methodChange noteMethodInfoFromRemoval: infoOrNil]

! !

!ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 11:58'!
removeSelector: selector
	"Remove all memory of changes associated with the argument, selector, in 
	this class."

	methodChanges removeKey: selector ifAbsent: []! !


!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 4/5/2000 08:11'!
initFor: className revertable: isRevertable

	inForce _ isRevertable.
	changeTypes _ IdentitySet new.
	methodChanges _ IdentityDictionary new.
	priorName _ thisName _ className.
	revertable _ isRevertable and: [self realClass notNil].
	revertable ifTrue:
		[priorMD _ self realClass methodDict copy.
		priorOrganization _ self realClass organization deepCopy].
! !

!ClassChangeRecord methodsFor: 'initialization' stamp: 'di 9/21/2000 12:34'!
zapHistory
	"Drop all recorded information not needed to simply keep track of what has been changed.
	Saves a lot of space."

	methodChanges do: [:r | r noteNewMethod: nil].  "Drop all refes to old methods"
	thisOrganization _ nil.
	priorOrganization _ nil.
	thisComment _ nil.
	priorComment _ nil.
	thisMD _ nil.
	priorMD _ nil.! !
ClassCategoryReader subclass: #ClassCommentReader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 12/15/97 15:56'!
scanFrom: aStream 
	"File in the class comment from aStream.  Not string-i-fied, just a text, exactly as it is in the browser.  Move to changes file."

	class theNonMetaClass classComment: (aStream nextChunkText).
		"Writes it on the disk and saves a RemoteString ref"! !

!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 1/27/2000 22:56'!
scanFromNoCompile: aStream 
	"File in the class comment from aStream.  Not string-i-fied, just a text, exactly as it is in the browser.  Move to changes file."

	self scanFrom: aStream.	"for comments, the same as usual"! !
Behavior subclass: #ClassDescription
	instanceVariableNames: 'instanceVariables organization '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassDescription commentStamp: '<historical>' prior: 0!
I add a number of facilities to basic Behaviors:
	Named instance variables
	Category organization for methods
	The notion of a name of this class (implemented as subclass responsibility)
	The maintenance of a ChangeSet, and logging changes on a file
	Most of the mechanism for fileOut.
	
I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.

The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).!


!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 11/22/1999 10:09'!
doneCompiling
	"A ClassBuilder has finished the compilation of the receiver.
	This message is a notification for a class that needs to do some
	cleanup / reinitialization after it has been recompiled."! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'ar 7/14/1999 04:41'!
obsolete
	"Make the receiver obsolete."
	superclass removeSubclass: self.
	organization _ nil.
	super obsolete.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'di 7/21/1999 11:05'!
superclass: aClass methodDictionary: mDict format: fmt
	"Basic initialization of the receiver"
	super superclass: aClass methodDictionary: mDict format: fmt.
	organization _ nil.
	instanceVariables _ nil.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'tk 10/4/1999 09:43'!
updateInstances: oldInstances from: oldClass isMeta: isMeta
	"Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary."
	"If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout."
	| map variable instSize newInstances |

	oldInstances isEmpty ifTrue:[^self]. "no instances to convert"
	isMeta ifTrue: [
		oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance'].
		self soleInstance class == self ifTrue:[
			^self error:'Metaclasses can only have one instance']].
	map _ self instVarMappingFrom: oldClass.
	variable _ self isVariable.
	instSize _ self instSize.
	newInstances _ Array new: oldInstances size.
	1 to: oldInstances size do:[:i|
		newInstances at: i put: (
			self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)].
	"Now perform a bulk mutation of old instances into new ones"
	oldInstances elementsExchangeIdentityWith: newInstances.! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'RAA 12/20/2000 23:27'!
updateInstancesFrom: oldClass 
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary."
	"ar 7/15/1999: The updating below is possibly dangerous. If there are any
	contexts having an old instance as receiver it might crash the system if
	the new receiver in which the context is executed has a different layout.
	See bottom below for a simple example:"
	| oldInstances |

	Smalltalk garbageCollect.	"ensure that allInstances is correct"
	oldInstances _ oldClass allInstances asArray.
	self updateInstances: oldInstances from: oldClass isMeta: self isMeta.
	"Now fix up instances in segments that are out on the disk."
	ImageSegment allSubInstancesDo: [:seg |
		seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta].
	oldInstances _ nil.
	Smalltalk garbageCollect.	"ensure that old instances are gone"


"	| crashingBlock class |
	class _ Object subclass: #CrashTestDummy
		instanceVariableNames: 'instVar'
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	class compile:'instVar: value instVar _ value'.
	class compile:'crashingBlock ^[instVar]'.
	crashingBlock _ (class new) instVar: 42; crashingBlock.
	Object subclass: #CrashTestDummy
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Crash-Test'.
	crashingBlock.
	crashingBlock value.
	"
! !


!ClassDescription methodsFor: 'accessing'!
classVersion
	"Default.  Any class may return a later version to inform readers that use ReferenceStream.  8/17/96 tk"
	^ 0! !

!ClassDescription methodsFor: 'accessing' stamp: 'di 2/9/2000 17:54'!
comment
	"Answer the receiver's comment. (If missing, supply a template) "
	| aString |
	aString _ self theNonMetaClass organization classComment.
	aString isEmpty ifFalse: [^ aString].
	^
'Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.'! !

!ClassDescription methodsFor: 'accessing' stamp: 'tk 12/16/97 07:49'!
comment: aStringOrText
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText.
	Smalltalk changes commentClass: self! !

!ClassDescription methodsFor: 'accessing' stamp: 'sw 9/8/1998 14:43'!
comment: aStringOrText stamp: aStamp
	"Set the receiver's comment to be the argument, aStringOrText."

	self theNonMetaClass classComment: aStringOrText stamp: aStamp.
	Smalltalk changes commentClass: self theNonMetaClass! !

!ClassDescription methodsFor: 'accessing'!
isMeta
	^ false! !

!ClassDescription methodsFor: 'accessing'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self! !


!ClassDescription methodsFor: 'copying'!
copy: sel from: class 
	"Install the method associated with the first argument, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under -As yet not 
	classified-."

	self copy: sel
		from: class
		classified: nil! !

!ClassDescription methodsFor: 'copying' stamp: 'di 2/17/2000 22:35'!
copy: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code _ class sourceMethodAt: sel.
	code == nil
		ifFalse: 
			[cat == nil
				ifTrue: [category _ class organization categoryOfElement: sel]
				ifFalse: [category _ cat].
			(self methodDict includesKey: sel)
				ifTrue: [code asString = (self sourceMethodAt: sel) asString 
							ifFalse: [self error: self name 
										, ' ' 
										, sel 
										, ' will be redefined if you proceed.']].
			self compile: code classified: category]! !

!ClassDescription methodsFor: 'copying'!
copyAll: selArray from: class 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	-As yet not classified-."

	self copyAll: selArray
		from: class
		classified: nil! !

!ClassDescription methodsFor: 'copying'!
copyAll: selArray from: class classified: cat 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	the third argument, cat."

	selArray do: 
		[:s | self copy: s
				from: class
				classified: cat]! !

!ClassDescription methodsFor: 'copying'!
copyAllCategoriesFrom: aClass 
	"Specify that the categories of messages for the receiver include all of 
	those found in the class, aClass. Install each of the messages found in 
	these categories into the method dictionary of the receiver, classified 
	under the appropriate categories."

	aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! !

!ClassDescription methodsFor: 'copying'!
copyCategory: cat from: class 
	"Specify that one of the categories of messages for the receiver is cat, as 
	found in the class, class. Copy each message found in this category."

	self copyCategory: cat
		from: class
		classified: cat! !

!ClassDescription methodsFor: 'copying'!
copyCategory: cat from: aClass classified: newCat 
	"Specify that one of the categories of messages for the receiver is the 
	third argument, newCat. Copy each message found in the category cat in 
	class aClass into this new category."

	self copyAll: (aClass organization listAtCategoryNamed: cat)
		from: aClass
		classified: newCat! !

!ClassDescription methodsFor: 'copying' stamp: 'sw 6/16/1998 15:01'!
copyMethodDictionaryFrom: donorClass
	"Copy the method dictionary of the donor class over to the receiver"

	methodDict _ donorClass copyOfMethodDictionary.
	organization _ donorClass organization deepCopy! !


!ClassDescription methodsFor: 'printing'!
classVariablesString
	"Answer a string of my class variable names separated by spaces."
	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self classPool keys asSortedCollection do: [:key | aStream nextPutAll: key; space].
	^aStream contents! !

!ClassDescription methodsFor: 'printing' stamp: 'di 6/7/2000 22:23'!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	^ String streamContents:
		[:strm | self instVarNames do: [:varName | strm nextPutAll: varName; space]]! !

!ClassDescription methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: self name! !

!ClassDescription methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:05'!
printOnStream: aStream 

	aStream print: self name! !

!ClassDescription methodsFor: 'printing' stamp: 'di 12/19/1999 14:37'!
sharedPoolsString
	"Answer a string of my shared pool names separated by spaces."

	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self sharedPools do: [:x | aStream nextPutAll: (self environment keyAtIdentityValue: x ifAbsent: ['private']); space].
	^ aStream contents! !

!ClassDescription methodsFor: 'printing'!
storeOn: aStream
	"Classes and Metaclasses have global names."

	aStream nextPutAll: self name! !


!ClassDescription methodsFor: 'instance variables'!
addInstVarName: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables' stamp: 'sw 10/23/2000 18:05'!
allInstVarNamesEverywhere
	"Answer the set of inst var names used by the receiver, all superclasses, and all subclasses"

	| aList |
	aList _ OrderedCollection new.
	(self allSuperclasses , self withAllSubclasses asOrderedCollection) do:
		[:cls | aList addAll: cls instVarNames].
	^ aList asSet

	"BorderedMorph allInstVarNamesEverywhere"! !

!ClassDescription methodsFor: 'instance variables' stamp: 'RAA 8/9/1999 19:32'!
browseClassVarRefs 
	"1/17/96 sw: moved here from Browser so that it could be used from a variety of places."

	| lines labelStream vars allVars index owningClasses |

	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	owningClasses _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class classVarNames asSortedCollection.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var.
			owningClasses add: class].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream contents isEmpty ifTrue: [^1 beep]. "handle nil superclass better"
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ self].
	Smalltalk browseAllCallsOn:
		((owningClasses at: index) classPool associationAt: (allVars at: index))! !

!ClassDescription methodsFor: 'instance variables'!
browseClassVariables
	"Put up a browser showing the receiver's class variables.  2/1/96 sw"

	self classPool inspectWithLabel: 'Class Variables in ', self name! !

!ClassDescription methodsFor: 'instance variables'!
browseInstVarDefs 
	"Copied from browseInstVarRefs.  Should be consolidated some day. 7/29/96 di
	7/30/96 sw: did the consolidation"

	self chooseInstVarThenDo:	
		[:aVar | self browseAllStoresInto: aVar]! !

!ClassDescription methodsFor: 'instance variables'!
browseInstVarRefs 
	"1/16/96 sw: moved here from Browser so that it could be used from a variety of places.
	 7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice"

	self chooseInstVarThenDo: 
		[:aVar | self browseAllAccessesTo: aVar]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'di 11/9/1998 20:21'!
checkForInstVarsOK: instVarString
	"Return true if instVarString does no include any names used in a subclass"
	| instVarArray |
	instVarArray _ Scanner new scanFieldNames: instVarString.
	self allSubclasses do:
		[:cl | cl instVarNames do:
			[:n | (instVarArray includes: n)
				ifTrue: [self error: n , ' is already used in ' , cl name.
						^ false]]].
	^ true! !

!ClassDescription methodsFor: 'instance variables' stamp: 'sw 9/28/1999 17:04'!
chooseInstVarAlphabeticallyThenDo: aBlock
	| allVars index |
	"Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter."

	allVars _ self allInstVarNames asSortedArray.
	allVars isEmpty ifTrue: [^ self inform: 'There are no
instance variables'].

	index _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in
', self name.
	index = 0 ifTrue: [^ self].
	aBlock value: (allVars at: index)! !

!ClassDescription methodsFor: 'instance variables' stamp: 'ls 12/5/1999
13:40'!
chooseInstVarThenDo: aBlock 
	"Put up a menu of all the instance variables in the receiver, and when
the user chooses one, evaluate aBlock with the chosen variable as its
parameter.  If the list is 6 or larger, then offer an alphabetical
formulation as an alternative. triggered by a 'show alphabetically' item
at the top of the list."

	| lines labelStream vars allVars index count offerAlpha |
	(count _ self allInstVarNames size) = 0 ifTrue: 
		[^ self inform: 'There are no
instance variables.'].

	allVars _ OrderedCollection new.
	lines _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).

	(offerAlpha _ count > 5)
		ifTrue:
			[lines add: 1.
			allVars add: 'show alphabetically'.
			labelStream nextPutAll: allVars first; cr].
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class instVarNames.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream skip: -1 "cut last CR".
	(lines size > 0 and: [lines last = allVars size]) ifTrue:
		[lines removeLast].  "dispense with inelegant line beneath last item"
	index _ (PopUpMenu labels: labelStream contents lines: lines)
startUpWithCaption: 'Instance variables in
', self name.
	index = 0 ifTrue: [^ self].
	(index = 1 and: [offerAlpha]) ifTrue: [^ self
chooseInstVarAlphabeticallyThenDo: aBlock].
	aBlock value: (allVars at: index)! !

!ClassDescription methodsFor: 'instance variables' stamp: 'sw 5/27/1999 16:46'!
classThatDefinesInstanceVariable: instVarName
	(instanceVariables notNil and: [instanceVariables includes: instVarName asString]) ifTrue: [^ self]. 
	^ superclass ifNotNil: [superclass classThatDefinesInstanceVariable: instVarName]! !

!ClassDescription methodsFor: 'instance variables'!
forceNewFrom: anArray
    "Create a new instance of the class and fill
    its instance variables up with the array."
    | object max |

    object _ self new.
    max _ self instSize.
    anArray doWithIndex: [:each :index |
        index > max ifFalse:
            [object instVarAt: index put: each]].
    ^ object! !

!ClassDescription methodsFor: 'instance variables'!
instVarNames
	"Answer an Array of the receiver's instance variable names."

	instanceVariables == nil
		ifTrue: [^#()]
		ifFalse: [^instanceVariables]! !

!ClassDescription methodsFor: 'instance variables'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance 
	variables. Create an error notification if the argument is not found."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables' stamp: 'di 9/14/1998 08:40'!
renameInstVar: oldName to: newName

	(self confirm: 'WARNING: Renaming of instance variables
is subject to substitution ambiguities.
Do you still wish to attempt it?') ifFalse: [self halt].
	"...In other words, this does a dumb text search-and-replace,
	which might improperly alter, eg, a literal string.  As long as
	the oldName is unique, everything should work jes' fine. - di"

	^ self renameSilentlyInstVar: oldName to: newName! !

!ClassDescription methodsFor: 'instance variables' stamp: 'tk 12/12/2000 11:59'!
renameSilentlyInstVar: old  to: new
	| i oldName newName |
	oldName _ old asString.
	newName _ new asString.
	(i _ instanceVariables indexOf: oldName) = 0 ifTrue:
		[self error: oldName , ' is not defined in ', self name].
	self allSuperclasses , self withAllSubclasses asOrderedCollection do:
		[:cls | (cls instVarNames includes: newName) ifTrue:
			[self error: newName , ' is already used in ', cls name]].

	instanceVariables replaceFrom: i to: i with: (Array with: newName).
	self replaceSilently: oldName to: newName.	"replace in text body of all methods"! !

!ClassDescription methodsFor: 'instance variables' stamp: 'tk 12/12/2000 11:58'!
replaceSilently: old to: new
	"text-replace any part of a method.  Used for class and pool variables.  Don't touch the header.  Not guaranteed to work if name appears in odd circumstances"
	| oldCode newCode parser header body sels oldName newName |

	oldName _ old asString.
	newName _ new asString.
	self withAllSubclasses do:
		[:cls | sels _ cls selectors.
		sels removeAllFoundIn: #(DoIt DoItIn:).
		sels do:
			[:sel |
			oldCode _ cls sourceCodeAt: sel.
			"Don't make changes in the method header"
			(parser _ cls parserClass new) parseSelector: oldCode.
			header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size).
			body _ header size > oldCode size
					ifTrue: ['']
					ifFalse: [oldCode copyFrom: header size+1 to: oldCode size].
			newCode _ header , (body copyReplaceTokens: oldName with: newName).
			newCode ~= oldCode ifTrue:
				[cls compile: newCode
					classified: (cls organization categoryOfElement: sel)
					notifying: nil]].
			cls isMeta ifFalse:
				[oldCode _ cls comment.
				newCode _ oldCode copyReplaceTokens: oldName with: newName.
				newCode ~= oldCode ifTrue:
					[cls comment: newCode]]]! !


!ClassDescription methodsFor: 'method dictionary' stamp: 'di 2/17/2000 22:17'!
induceMDFault
	"Stache a copy of the methodDict in the organization slot (hack!!),
	and set the methodDict to nil.  This will induce an MD fault on any message send.
	See: ClassDescription>>recoverFromMDFault
	and ImageSegment>>discoverActiveClasses."

	organization _ Array with: methodDict with: organization.
	methodDict _ nil.
	self flushCache! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'di 3/27/1999 23:53'!
recoverFromMDFault
	(organization isMemberOf: Array) ifFalse: [^ self error: 'oops'].
	methodDict _ organization first.
	organization _ organization second.! !

!ClassDescription methodsFor: 'method dictionary'!
removeCategory: aString 
	"Remove each of the messages categorized under aString in the method 
	dictionary of the receiver. Then remove the category aString."
	| categoryName |
	categoryName _ aString asSymbol.
	(self organization listAtCategoryNamed: categoryName) do:
		[:sel | self removeSelector: sel].
	self organization removeCategory: categoryName! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'di 3/23/2000 23:08'!
removeSelector: selector 
	| priorMethod | 
	"Remove the message whose selector is given from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(self methodDict includesKey: selector) ifFalse: [^ nil].
	priorMethod _ self compiledMethodAt: selector.
	Smalltalk changes removeSelector: selector class: self
		priorMethod: priorMethod
		lastMethodInfo: {priorMethod sourcePointer.
						(self whichCategoryIncludesSelector: selector)}.
	super removeSelector: selector.
	self organization removeElement: selector.
	self acceptsLoggingOfCompilation ifTrue:
		[Smalltalk logChange: self name , ' removeSelector: #' , selector]! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'di 2/17/2000 22:34'!
removeSelectorUnlogged: aSymbol 
	"Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise.  Do not log the action either to the current change set or to the changes log"

	(self methodDict includesKey: aSymbol) ifFalse: [^ nil].
	super removeSelector: aSymbol.
	self organization removeElement: aSymbol! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'sw 5/18/1999 10:11'!
ultimateSourceCodeAt: selector ifAbsent: aBlock
	"Return the source code at selector, deferring to superclass if necessary"
	^ self sourceCodeAt: selector ifAbsent:
		[superclass
			ifNil:
				[aBlock value]
			 ifNotNil:
				[superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! !


!ClassDescription methodsFor: 'organization'!
category
	"Answer the system organization category for the receiver."

	^SystemOrganization categoryOfElement: self name! !

!ClassDescription methodsFor: 'organization'!
category: cat 
	"Categorize the receiver under the system category, cat, removing it from 
	any previous categorization."

	(cat isKindOf: String)
		ifTrue: [SystemOrganization classify: self name under: cat asSymbol]
		ifFalse: [self errorCategoryName]! !

!ClassDescription methodsFor: 'organization' stamp: 'di 2/17/2000 22:36'!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization ifNil:
		[organization _ ClassOrganizer defaultList: 
						self methodDict keys asSortedCollection asArray].
	(organization isMemberOf: Array) ifTrue:
		[self recoverFromMDFault].
	^ organization! !

!ClassDescription methodsFor: 'organization' stamp: 'tk 6/21/1999 12:59'!
organization: aClassOrg
	"Install an instance of ClassOrganizer that represents the organization of the messages of the receiver."

	organization _ aClassOrg! !

!ClassDescription methodsFor: 'organization' stamp: 'di 7/17/97 00:06'!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	(self includesSelector: aSelector)
		ifTrue: [^ self organization categoryOfElement: aSelector]
		ifFalse: [^nil]! !

!ClassDescription methodsFor: 'organization' stamp: 'di 9/10/1999 10:21'!
zapAllMethods
	"Remove all methods in this class which is assumed to be obsolete"

	methodDict _ MethodDictionary new.
	self isMeta ifFalse: [self class zapAllMethods]! !

!ClassDescription methodsFor: 'organization'!
zapOrganization
	"Remove the organization of this class by message categories.
	This is typically done to save space in small systems.  Classes and methods
	created or filed in subsequently will, nonetheless, be organized"

	organization _ nil.
	self isMeta ifFalse: [self class zapOrganization]! !


!ClassDescription methodsFor: 'compiling'!
acceptsLoggingOfCompilation
	"weird name is so that it will come lexically before #compile, so that a clean build can make it through.  7/7/96 sw"

	^ true! !

!ClassDescription methodsFor: 'compiling'!
compile: code classified: heading 
	"Compile the argument, code, as source code in the context of the 
	receiver and install the result in the receiver's method dictionary under 
	the classification indicated by the second argument, heading. nil 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 on an object that 
	converts to a string."

	^self
		compile: code
		classified: heading
		notifying: (SyntaxError new category: heading)! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 8/21/97 00:26'!
compile: text classified: category notifying: requestor
	| stamp |
	stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil].
	^ self compile: text classified: category
		withStamp: stamp notifying: requestor

 ! !

!ClassDescription methodsFor: 'compiling' stamp: 'di 2/17/2000 22:34'!
compile: text classified: category withStamp: changeStamp notifying: requestor 
	| selector priorMethod method methodNode newText |
	method _ self
		compile: text asString
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel.
			priorMethod _ self methodDict at: selector ifAbsent: [nil].
			methodNode _ node].
	self acceptsLoggingOfCompilation ifTrue:
		[newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not
						and: [Preferences confirmFirstUseOfStyle])
			ifTrue: [text askIfAddStyle: priorMethod req: requestor]
			ifFalse: [text].
		 method putSource: newText
				fromParseNode: methodNode
				class: self category: category withStamp: changeStamp 
				inFile: 2 priorMethod: priorMethod].
	self organization classify: selector under: category.
	^selector! !

!ClassDescription methodsFor: 'compiling'!
compile: code notifying: requestor 
	"Refer to the comment in Behavior|compile:notifying:." 

	^self compile: code
		 classified: ClassOrganizer default
		 notifying: requestor! !

!ClassDescription methodsFor: 'compiling' stamp: 'di 3/23/2000 20:47'!
compile: code notifying: requestor trailer: bytes 
		ifFail: failBlock
		elseSetSelectorAndNode: selAndNodeBlock
	"Intercept this message in order to remember system changes.
	 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set.
	7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set"

	| methodNode selector newMethod priorMethodOrNil |
	methodNode _ self compilerClass new
				compile: code
				in: self
				notifying: requestor
				ifFail: failBlock.
	selector _ methodNode selector.
	selAndNodeBlock value: selector value: methodNode.
	requestor ifNotNil:
		["Note this change for recent submissions list"
		Utilities noteMethodSubmission: selector forClass: self].
	methodNode encoder requestor: requestor.  "Why was this not preserved?"
	newMethod _ methodNode generate: bytes.
	priorMethodOrNil _ (methodDict includesKey: selector)
		ifTrue: [self compiledMethodAt: selector]
		ifFalse: [nil].
	Smalltalk changes noteNewMethod: newMethod forClass: self
		selector: selector priorMethod: priorMethodOrNil.
	self addSelector: selector withMethod: newMethod.
	^ newMethod! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 7/1/1999 23:07'!
compileProgrammatically: code classified: cat 

	| oldInitials |
	oldInitials _ Utilities authorInitialsPerSe.
	Utilities setAuthorInitials: 'programmatic'.
	self compile: code classified: cat.
	Utilities setAuthorInitials: oldInitials.
! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 8/11/1998 14:40'!
compileUnlogged: text classified: category notifying: requestor 
	| selector  |
	self compile: text asString
		notifying: requestor
		trailer: #(0 0 0 0)
		ifFail: [^ nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel].
	self organization classify: selector under: category.
	^ selector! !

!ClassDescription methodsFor: 'compiling' stamp: 'ar 7/20/1999 11:04'!
moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName
	"Move the given instance variable to another class."
	self == anotherClass ifFalse:[
		self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly.
Proceed to do it anyways.'].
	^(ClassBuilder new)
		moveInstVarNamed: instVarName 
		from: self 
		to: anotherClass 
		after: prevInstVarName! !

!ClassDescription methodsFor: 'compiling'!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.  7/12/96 sw"


	^ true! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 7/31/2000 12:55'!
wantsRecompilationProgressReported
	"Answer whether the receiver would like progress of its recompilation reported interactively to the user."

	^ true! !


!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/8/1998 14:44'!
classComment: aString
	"Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing.  Empty string gets stored only if had a non-empty one before."
	^ self classComment: aString stamp: '<historical>'! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 3/28/2000 14:34'!
classComment: aString stamp: aStamp
	"Store the comment, aString or Text or RemoteString, associated with the class we are organizing.  Empty string gets stored only if had a non-empty one before."

	| ptr header file oldCommentRemoteStr |
	(aString isKindOf: RemoteString) ifTrue: [^ self organization classComment: aString].
	oldCommentRemoteStr _ self organization commentRemoteStr.
	(aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
		"never had a class comment, no need to write empty string out"

	ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
	SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [
		file setToEnd; cr; nextPut: $!!.	"directly"
		"Should be saying (file command: 'H3') for HTML, but ignoring it here"
		header _ String streamContents: [:strm | strm nextPutAll: self name;
			nextPutAll: ' commentStamp: '.
			aStamp storeOn: strm.
			strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
		file nextChunkPut: header]].
	Smalltalk changes commentClass: self.
	aStamp size > 0 ifTrue: [self commentStamp: aStamp].
	organization classComment: (RemoteString newString: aString onFileNumber: 2).
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:20'!
commentFollows 
	"Answer a ClassCommentReader who will scan in the comment."

	^ ClassCommentReader new setClass: self category: #Comment

	"False commentFollows inspect"! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/2/1998 14:22'!
commentStamp: changeStamp
	self organization commentStamp: changeStamp.
    ^ self commentStamp: changeStamp prior: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:21'!
commentStamp: changeStamp prior: indexAndOffset
	"Prior source link ignored when filing in."

	^ ClassCommentReader new setClass: self
				category: #Comment
				changeStamp: changeStamp
! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/7/2000 22:46'!
definition
	"Answer a String that defines the receiver in good old ST-80."

	^ self definitionST80! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/7/2000 22:38'!
definitionST80
	"Answer a String that defines the receiver."

	| aStream path |
	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'nil']
		ifFalse: [path _ ''.
				self environment scopeFor: superclass name from: nil
						envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutAll: self kindOfSubclass;
			store: self name.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: ';
			store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: ';
			store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: ';
			store: (SystemOrganization categoryOfElement: self name) asString.
	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/7/2000 22:42'!
definitionST80: isST80
	"Answer a String that defines the receiver."

	| aStream path |
	isST80 ifTrue: [^ self definitionST80].

	aStream _ WriteStream on: (String new: 300).
	superclass == nil
		ifTrue: [aStream nextPutAll: 'nil']
		ifFalse: [path _ ''.
				self environment scopeFor: superclass name from: nil
						envtAndPathIfFound: [:envt :remotePath | path _ remotePath].
				aStream nextPutAll: path , superclass name].
	aStream nextPutKeyword: self kindOfSubclass
			withArg: self name.
	aStream cr; tab; nextPutKeyword: 'instanceVariableNames: '
			withArg: self instanceVariablesString.
	aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString.
	aStream cr; tab; nextPutKeyword: 'poolDictionaries: '
			withArg: self sharedPoolsString.
	aStream cr; tab; nextPutKeyword: 'category: '
			withArg: (SystemOrganization categoryOfElement: self name) asString.
	^ aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:06'!
fileOutCategory: catName 
	^ self fileOutCategory: catName asHtml: false! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:05'!
fileOutCategory: catName asHtml: useHtml
	"FileOut the named category, possibly in Html format."
	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: self name , '-' , catName , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: self name , '-' , catName , '.st'].
	fileStream header; timeStamp.
	self fileOutCategory: catName on: fileStream moveSource: false toFile: 0.
	fileStream trailer; close! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 10/15/1999 14:45'!
fileOutCategory: aSymbol on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver's category, aString, onto aFileStream. If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.sources file, and should only write one preamble per method category."

	| selectors |

	aFileStream cr.
	selectors := (aSymbol asString = ClassOrganizer allCategory)
				ifTrue: [ self organization allMethodSelectors ]
				ifFalse: [ self organization listAtCategoryNamed: aSymbol ].

	"Overridden to preserve author stamps in sources file regardless"
	selectors do: [:sel |
		self printMethodChunk: sel 
			withPreamble: true
			on: aFileStream 
			moveSource: moveSource 
			toFile: fileIndex].
	^ self! !

!ClassDescription methodsFor: 'fileIn/Out'!
fileOutChangedMessages: aSet on: aFileStream 
	"File a description of the messages of the receiver that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream."

	self fileOutChangedMessages: aSet
		on: aFileStream
		moveSource: false
		toFile: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/26/97 21:41'!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the messages of this class that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream.  If 
	moveSource, is true, then set the method source pointer to the new file position.
	Note when this method is called with moveSource=true, it is condensing the
	.changes file, and should only write a preamble for every method."
	| org sels |
	(org _ self organization) categories do: 
		[:cat | 
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		sels do:
			[:sel |  self printMethodChunk: sel withPreamble: true on: aFileStream
							moveSource: moveSource toFile: fileIndex]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:52'!
fileOutMethod: selector
	"Write source code of a single method on a file.  Make up a name for the file."
	self fileOutMethod: selector asHtml: false! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:51'!
fileOutMethod: selector asHtml: useHtml
	"Write source code of a single method on a file in .st or .html format"
	| fileStream nameBody |
	(self includesSelector: selector) ifFalse: [^ self halt: 'Selector not found'].
	nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: '').
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: nameBody , '.st'].
	fileStream header; timeStamp.
	self printMethodChunk: selector withPreamble: true
		on: fileStream moveSource: false toFile: 0.
	fileStream close! !

!ClassDescription methodsFor: 'fileIn/Out'!
fileOutOn: aFileStream 
	"File a description of the receiver on aFileStream."

	self fileOutOn: aFileStream
		moveSource: false
		toFile: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/15/98 23:38'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
	"File a description of the receiver on aFileStream. If the boolean 
	argument, moveSource, is true, then set the trailing bytes to the position 
	of aFileStream and to fileIndex in order to indicate where to find the 
	source code."

	aFileStream command: 'H3'.
		aFileStream nextChunkPut: self definition.
		aFileStream command: '/H3'.

	self organization
		putCommentOnFile: aFileStream
		numbered: fileIndex
		moveSource: moveSource
		forClass: self.
	self organization categories do: 
		[:heading |
		self fileOutCategory: heading
			on: aFileStream
			moveSource: moveSource
			toFile: fileIndex]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 20:35'!
fileOutOrganizationOn: aFileStream
	"File a description of the receiver's organization on aFileStream."

	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: self name, ' reorganize'; cr.
	aFileStream nextChunkPut: self organization printString; cr! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 11/13/1998 15:25'!
methods
	"Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"

	^ ClassCategoryReader new setClass: self category: ClassOrganizer default! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 13:00'!
methodsFor: categoryName 
	"Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver."

	^ ClassCategoryReader new setClass: self category: categoryName asSymbol

	"(False methodsFor: 'logical operations') inspect"! !

!ClassDescription methodsFor: 'fileIn/Out'!
methodsFor: aString priorSource: sourcePosition inFile: fileIndex
	"Prior source pointer ignored when filing in."
	^ self methodsFor: aString! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 13:51'!
methodsFor: categoryName stamp: changeStamp 
	^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 8/15/1998 22:02'!
methodsFor: categoryName stamp: changeStamp prior: indexAndOffset
	"Prior source link ignored when filing in."
	^ ClassCategoryReader new setClass: self
				category: categoryName asSymbol
				changeStamp: changeStamp

"Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control.  So method will be placed in the proper category.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"!
]style[(65 333 22 17)f1b,f1,f1LReadWriteStream fileIn;,f1! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:42'!
moveChangesTo: newFile 
	"Used in the process of condensing changes, this message requests that 
	the source code of all methods of the receiver that have been changed 
	should be moved to newFile."

	| changes |
	self organization moveChangedCommentToFile: newFile numbered: 2.
	changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1].
	self fileOutChangedMessages: changes
		on: newFile
		moveSource: true
		toFile: 2! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
printCategoryChunk: categoryName on: aFileStream
	^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
printCategoryChunk: category on: aFileStream priorMethod: priorMethod
	^ self printCategoryChunk: category on: aFileStream
		withStamp: Utilities changeStamp priorMethod: priorMethod! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 4/4/1999 11:43'!
printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod 
	"Print a method category preamble.  This must have a category name.
	It may have an author/date stamp, and it may have a prior source link.
	If it has a prior source link, it MUST have a stamp, even if it is empty."

"The current design is that changeStamps and prior source links are preserved in the changes file.  All fileOuts include changeStamps.  Condensing sources, however, eliminates all stamps (and links, natch)."

	aFileStream cr; command: 'H3'; nextPut: $!!.
	aFileStream nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString.
		(changeStamp ~~ nil and:
			[changeStamp size > 0 or: [priorMethod ~~ nil]]) ifTrue:
			[strm nextPutAll: ' stamp: '; print: changeStamp].
		priorMethod ~~ nil ifTrue:
			[strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]).
	aFileStream command: '/H3'.! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/6/97 di'!
printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream
	^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp
		priorMethod: nil! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'RAA 5/5/2000 09:08'!
printMethodChunk: selector withPreamble: doPreamble on: outStream
		moveSource: moveSource toFile: fileIndex
	"Copy the source code for the method associated with selector onto the fileStream.  If moveSource true, then also set the source code pointer of the method."
	| preamble method oldPos newPos sourceFile endPos |
	doPreamble 
		ifTrue: [preamble _ self name , ' methodsFor: ' ,
					(self organization categoryOfElement: selector) asString printString]
		ifFalse: [preamble _ ''].
	method _ self methodDict at: selector.
	((method fileIndex = 0
		or: [(SourceFiles at: method fileIndex) == nil])
		or: [(oldPos _ method filePosition) = 0])
		ifTrue:
		["The source code is not accessible.  We must decompile..."
		preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr].
		outStream nextChunkPut: (self decompilerClass new decompile: selector
											in: self method: method) decompileString]
		ifFalse:
		[sourceFile _ SourceFiles at: method fileIndex.
		sourceFile position: oldPos.
		preamble size > 0 ifTrue:    "Copy the preamble"
			[outStream copyPreamble: preamble from: sourceFile].
		"Copy the method chunk"
		newPos _ outStream position.
		outStream copyMethodChunkFrom: sourceFile.
		sourceFile skipSeparators.      "The following chunk may have ]style["
		sourceFile peek == $] ifTrue: [
			outStream cr; copyMethodChunkFrom: sourceFile].
		moveSource ifTrue:    "Set the new method source pointer"
			[endPos _ outStream position.
			method checkOKToAdd: endPos - newPos at: newPos.
			method setSourcePosition: newPos inFile: fileIndex]].
	preamble size > 0 ifTrue: [outStream nextChunkPut: ' '].
	^ outStream cr! !

!ClassDescription methodsFor: 'fileIn/Out'!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	self selectorsDo: [:sel | self reformatMethodAt: sel]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 11/6/1999 23:08'!
reformatMethodAt: selector 
	| newCodeString method | 
	newCodeString _ (self compilerClass new)
		format: (self sourceCodeAt: selector)
		in: self
		notifying: nil
		decorated: false.
	method _ self compiledMethodAt: selector.
	method
		putSource: newCodeString
		fromParseNode: nil
		class: self
		category: (self organization categoryOfElement: selector)
		inFile: 2 priorMethod: method! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 8/15/1998 15:26'!
reorganize
	"During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"

	Smalltalk changes reorganizeClass: self.
	^self organization!
]style[(10 156 22 80)f1b,f1,f1LReadWriteStream fileIn;,f1! !


!ClassDescription methodsFor: 'private'!
errorCategoryName
	self error: 'Category name must be a String'! !

!ClassDescription methodsFor: 'private' stamp: 'ar 7/11/1999 11:41'!
instVarMappingFrom: oldClass
	"Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass."
	| oldInstVarNames |
	oldInstVarNames _ oldClass allInstVarNames.
	^self allInstVarNames 
			collect: [:instVarName | oldInstVarNames indexOf: instVarName].
! !

!ClassDescription methodsFor: 'private' stamp: 'di 4/3/1999 22:29'!
linesOfCode  "InterpreterSimulator linesOfCode 790"
	"An approximate measure of lines of code.
	Includes comments, but excludes blank lines."

	| lines code strm line |
	lines _ 0.
	self selectorsDo: [:sel |
		code _ self sourceCodeAt: sel.
		strm _ ReadStream on: code.
		[strm atEnd] whileFalse:
			[line _ strm upTo: Character cr.
			line isEmpty ifFalse: [lines _ lines+1]]].
	self isMeta
		ifTrue: [^ lines]
		ifFalse: [^ lines + self class linesOfCode]
"
(SystemOrganization categories select: [:c | 'Fabrik*' match: c]) detectSum:
		[:c | (SystemOrganization superclassOrder: c) detectSum: [:cl | cl linesOfCode]] 24878
"! !

!ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'!
newInstanceFrom: oldInstance variable: variable size: instSize map: map
	"Create a new instance of the receiver based on the given old instance.
	The supplied map contains a mapping of the old instVar names into
	the receiver's instVars"
	| new |
	variable
		ifTrue: [new _ self basicNew: oldInstance basicSize]
		ifFalse: [new _ self basicNew].
	1 to: instSize do: 
		[:offset |  (map at: offset) > 0 ifTrue:
			[new instVarAt: offset
					put: (oldInstance instVarAt: (map at: offset))]].
	variable 
		ifTrue: [1 to: oldInstance basicSize do: 
					[:offset |
					new basicAt: offset put: (oldInstance basicAt: offset)]].
	^new! !

!ClassDescription methodsFor: 'private' stamp: 'ar 7/15/1999 17:04'!
setInstVarNames: instVarArray
	"Private - for class initialization only"
	| required |
	required _ self instSize.
	superclass notNil ifTrue:[required _ required - superclass instSize].
	instVarArray size = required
		ifFalse:[^self error: required printString, ' instvar names are required'].
	instVarArray isEmpty
		ifTrue:[instanceVariables _ nil]
		ifFalse:[instanceVariables _ instVarArray asArray].! !

!ClassDescription methodsFor: 'private' stamp: 'jm 11/1/1998 11:47'!
spaceUsed
	"Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables."

	| space method |
	space _ 0.
	self selectorsDo: [:sel |
		space _ space + 16.  "dict and org'n space"
		method _ self compiledMethodAt: sel.
		space _ space + (method size + 6 "hdr + avg pad").
		method literals do: [:lit |
			(lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: Float) ifTrue: [space _ space + 12].
			(lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)].
			(lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)].
			(lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]].
	(self isMemberOf: Metaclass)
		ifTrue: [^ space]
		ifFalse: [^ space + self class spaceUsed].
! !


!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'sma 6/1/2000 12:22'!
allSubclasses
	"Answer a Set of the receiver's and the receiver's descendent's subclasses."

	| scan scanTop |
	scan _ OrderedCollection withAll: self subclasses.
	scanTop _ 1.
	[scanTop > scan size] whileFalse:
		[scan addAll: (scan at: scanTop) subclasses.
		scanTop _ scanTop + 1].
	^ scan asSet! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 2/17/2000 22:36'!
classesThatImplementAllOf: selectorSet
	"Return an array of any classes that implement all the messages in selectorSet."

	| found remaining |
	found _ OrderedCollection new.
	selectorSet do:
		[:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]].
	found isEmpty
		ifTrue: [^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: selectorSet)]]
		ifFalse: [remaining _ selectorSet copyWithoutAll: found.
				remaining isEmpty ifTrue: [^ Array with: self].
				^ self subclasses inject: Array new
						into: [:subsThatDo :sub |
							subsThatDo , (sub classesThatImplementAllOf: remaining)]]! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:57'!
printSubclassesOn: aStream level: level 
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."

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

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 6/10/1999 12:05'!
removeUninstantiatedSubclassesSilently
	"Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
	"Player removeUninstantiatedSubclassesSilently"

	| candidatesForRemoval  oldFree |

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

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 7/21/1999 11:05'!
subclasses
	^ Array new! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 08:22'!
subclassesDo: aBlock
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	^self subclasses do: aBlock! !

!ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'SqR 5/25/2000 16:54'!
withAllSubclasses
	"Answer a Set of the receiver, the receiver's descendent's, and the 
	receiver's descendent's subclasses."

	^ self allSubclasses add: self; yourself! !
TextDiffBuilder subclass: #ClassDiffBuilder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!ClassDiffBuilder methodsFor: 'initialize'!
split: aString
	| lines in out c |
	lines := OrderedCollection new.
	in := ReadStream on: aString.
	out := WriteStream on: String new.
	[in atEnd] whileFalse:[
		(c := in next) isSeparator ifTrue:[
			out nextPut: c.
			lines add: out contents.
			out reset.
		] ifFalse:[
			out nextPut: c.
		].
	].
	out position = 0 ifFalse:[
		lines add: out contents.
	].
	^lines! !


!ClassDiffBuilder methodsFor: 'printing'!
printPatchSequence: ps on: aStream
	| type line attr |
	ps do:[:assoc|
		type := assoc key.
		line := assoc value.
		attr := TextEmphasis normal.
		type == #insert ifTrue:[attr := TextColor red].
		type == #remove ifTrue:[attr := TextEmphasis struckOut].
		aStream withAttribute: attr do:[aStream nextPutAll: line].
	].! !
Object subclass: #ClassOrganizer
	instanceVariableNames: 'globalComment categoryArray categoryStops elementArray commentStamp '
	classVariableNames: 'Default NullCategory '
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!ClassOrganizer commentStamp: '<historical>' prior: 0!
I represent method categorization information for classes.  The handling of class comments has gone through a tortuous evolution.   Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted.   Such grandfathered comments now go out on fileouts with '<historical>' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments.  Everything in good time!!!


!ClassOrganizer methodsFor: 'accessing'!
categories
	"Answer an Array of categories (names)."
	(categoryArray size = 1 
		and: [categoryArray first = Default & (elementArray size = 0)])
		ifTrue: [^Array with: NullCategory].
	^categoryArray! !

!ClassOrganizer methodsFor: 'accessing'!
categories: anArray 
	"Reorder my categories to be in order of the argument, anArray. If the 
	resulting organization does not include all elements, then give an error."

	| newCategories newStops newElements catName list runningTotal | 
	newCategories _ Array new: anArray size.
	newStops _ Array new: anArray size.
	newElements _ Array new: 0.
	runningTotal _ 0.
	1 to: anArray size do:
		[:i |
		catName _ (anArray at: i) asSymbol.
		list _ self listAtCategoryNamed: catName.
				newElements _ newElements, list.
				newCategories at: i put: catName.
				newStops at: i put: (runningTotal _ runningTotal + list size)].
	elementArray do:
		[:element | "check to be sure all elements are included"
		(newElements includes: element)
			ifFalse: [^self error: 'New categories must match old ones']].
	"Everything is good, now update my three arrays."
	categoryArray _ newCategories.
	categoryStops _ newStops.
	elementArray _ newElements! !

!ClassOrganizer methodsFor: 'accessing'!
categoryOfElement: element 
	"Answer the category associated with the argument, element."

	| index |
	index _ self numberOfCategoryOfElement: element.
	index = 0
		ifTrue: [^nil]
		ifFalse: [^categoryArray at: index]! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'di 12/2/1999 20:36'!
changeFromCategorySpecs: categorySpecs 
	"Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment."

	| oldElements newElements newCategories newStops currentStop temp ii cc catSpec |
	oldElements _ elementArray asSet.
	newCategories _ Array new: categorySpecs size.
	newStops _ Array new: categorySpecs size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: categorySpecs size do: 
		[:i | 
		catSpec _ categorySpecs at: i.
		newCategories at: i put: catSpec first asSymbol.
		catSpec allButFirst asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
				[newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect:
		[:elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	(cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element"
		temp _ categoryArray asOrderedCollection.
		temp removeAll: categoryArray asSet asOrderedCollection.
		temp do: [:dup | 
			ii _ categoryArray indexOf: dup.
			[dup _ (dup,' #2') asSymbol.  cc includes: dup] whileTrue.
			cc add: dup.
			categoryArray at: ii put: dup]].
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first].! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'di 12/2/1999 10:54'!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| categorySpecs |
	categorySpecs _ Scanner new scanTokens: aString.
	"If nothing was scanned and I had no elements before, then default me"
	(categorySpecs isEmpty and: [elementArray isEmpty])
		ifTrue: [^ self setDefaultList: Array new].

	^ self changeFromCategorySpecs: categorySpecs! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/12/97 13:32'!
classComment
	"Answer the comment associated with the object that refers to the 
	receiver."

	globalComment == nil ifTrue: [^''].
	^globalComment text! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'di 5/4/1999 20:14'!
classComment: aString 
	"Store the comment, aString, associated with the object that refers to the 
	receiver."

	(aString isKindOf: RemoteString) 
		ifTrue: [globalComment _ aString]
		ifFalse: [(aString == nil or: [aString size = 0])
			ifTrue: [globalComment _ nil]
			ifFalse: [
				self error: 'use aClass classComment:'.
				globalComment _ RemoteString newString: aString onFileNumber: 2]]
				"Later add priorSource and date and initials?"! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/15/97 14:41'!
commentRemoteStr
	^ globalComment! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'sw 8/24/1998 12:29'!
commentStamp
	^ commentStamp! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'sw 8/24/1998 12:29'!
commentStamp: aStamp
	commentStamp _ aStamp! !

!ClassOrganizer methodsFor: 'accessing'!
hasNoComment
	"Answer whether the class classified by the receiver has a comment."

	^globalComment == nil! !

!ClassOrganizer methodsFor: 'accessing'!
listAtCategoryNamed: categoryName
	"Answer the array of elements associated with the name, categoryName."

	| i |
	i _ categoryArray indexOf: categoryName ifAbsent: [^Array new].
	^self listAtCategoryNumber: i! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'sw 3/23/1999 15:58'!
listAtCategoryNumber: anInteger 
	"Answer the array of elements stored at the position indexed by anInteger.  Answer nil if anInteger is larger than the number of categories."

	| firstIndex lastIndex |
	firstIndex _ 
		(anInteger > 1
			ifTrue: [categoryStops at: anInteger - 1]
			ifFalse: [0])
		+ 1.
	(categoryStops size < anInteger) ifTrue:
		[^ nil].  "It can happen, if Default category got aggressively removed by some automatic operation"
	lastIndex _ categoryStops at: anInteger.
	^elementArray copyFrom: firstIndex to: lastIndex! !

!ClassOrganizer methodsFor: 'accessing'!
numberOfCategoryOfElement: element 
	"Answer the index of the category with which the argument, element, is 
	associated."

	| categoryIndex elementIndex |
	categoryIndex _ 1.
	elementIndex _ 0.
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			["point to correct category"
			[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: [categoryIndex _ categoryIndex + 1].
			"see if this is element"
			element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]].
	^0! !

!ClassOrganizer methodsFor: 'accessing'!
removeElement: element 
	"Remove the selector, element, from all categories."
	| categoryIndex elementIndex nextStop newElements |
	categoryIndex _ 1.
	elementIndex _ 0.
	nextStop _ 0.
	"nextStop keeps track of the stops in the new element array"
	newElements _ WriteStream on: (Array new: elementArray size).
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			[[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: 
					[categoryStops at: categoryIndex put: nextStop.
					categoryIndex _ categoryIndex + 1].
			(elementArray at: elementIndex) = element
				ifFalse: 
					[nextStop _ nextStop + 1.
					newElements nextPut: (elementArray at: elementIndex)]].
	[categoryIndex <= categoryStops size]
		whileTrue: 
			[categoryStops at: categoryIndex put: nextStop.
			categoryIndex _ categoryIndex + 1].
	elementArray _ newElements contents! !

!ClassOrganizer methodsFor: 'accessing'!
removeEmptyCategories
	"Remove empty categories."

	| categoryIndex currentStop keptCategories keptStops |
	keptCategories _ WriteStream on: (Array new: 16).
	keptStops _ WriteStream on: (Array new: 16).
	currentStop _ categoryIndex _ 0.
	[(categoryIndex _ categoryIndex + 1) <= categoryArray size]
		whileTrue: 
			[(categoryStops at: categoryIndex) > currentStop
				ifTrue: 
					[keptCategories nextPut: (categoryArray at: categoryIndex).
					keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]].
	categoryArray _ keptCategories contents.
	categoryStops _ keptStops contents.
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]

	"ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'SqR 11/16/2000 13:52'!
sortCategories
	| privateCategories publicCategories newCategories |

	privateCategories _ self categories select:
		[:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1].
	publicCategories _ self categories copyWithoutAll: privateCategories.
	newCategories _ publicCategories asSortedCollection asOrderedCollection
		addAll: privateCategories asSortedCollection;
		asArray.
	self categories: newCategories! !


!ClassOrganizer methodsFor: 'compiler access' stamp: 'sw 3/23/1999 17:04'!
classify: element under: heading 
	self classify: element under: heading suppressIfDefault: true! !

!ClassOrganizer methodsFor: 'compiler access' stamp: 'sw 3/23/1999 17:02'!
classify: element under: heading suppressIfDefault: aBoolean
	"Store the argument, element, in the category named heading.   If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein"

	| catName catIndex elemIndex realHeading |
	((heading = NullCategory) or: [heading == nil])
		ifTrue: [realHeading _ Default]
		ifFalse: [realHeading _ heading asSymbol].
	(catName _ self categoryOfElement: element) = realHeading
		ifTrue: [^ self].  "done if already under that category"

	catName ~~ nil ifTrue: 
		[(aBoolean and: [realHeading = Default])
				ifTrue: [^ self].	  "return if non-Default category already assigned in memory"
		self removeElement: element].	"remove if in another category"

	(categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].

	catIndex _ categoryArray indexOf: realHeading.
	elemIndex _ 
		catIndex > 1
			ifTrue: [categoryStops at: catIndex - 1]
			ifFalse: [0].
	[(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) 
		and: [element >= (elementArray at: elemIndex)]] whileTrue.

	"elemIndex is now the index for inserting the element. Do the insertion before it."
	elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1
						with: (Array with: element).

	"add one to stops for this and later categories"
	catIndex to: categoryArray size do: 
		[:i | categoryStops at: i put: (categoryStops at: i) + 1].
	(self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! !

!ClassOrganizer methodsFor: 'compiler access'!
classifyAll: aCollection under: heading

	aCollection do:
		[:element | self classify: element under: heading]! !


!ClassOrganizer methodsFor: 'method dictionary'!
addCategory: newCategory
	^ self addCategory: newCategory before: nil ! !

!ClassOrganizer methodsFor: 'method dictionary'!
addCategory: catString before: nextCategory
	"Add a new category named heading.
	If default category exists and is empty, remove it.
	If nextCategory is nil, then add the new one at the end,
	otherwise, insert it before nextCategory."
	| index newCategory |
	newCategory _ catString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^self].	"heading already exists, so done"
	index _ categoryArray indexOf: nextCategory
		ifAbsent: [categoryArray size + 1].
	categoryArray _ categoryArray
		copyReplaceFrom: index
		to: index-1
		with: (Array with: newCategory).
	categoryStops _ categoryStops
		copyReplaceFrom: index
		to: index-1
		with: (Array with: (index = 1
				ifTrue: [0]
				ifFalse: [categoryStops at: index-1])).
	"remove empty default category"
	(newCategory ~= Default
			and: [(self listAtCategoryNamed: Default) isEmpty])
		ifTrue: [self removeCategory: Default]! !

!ClassOrganizer methodsFor: 'method dictionary' stamp: 'di 3/29/2000 21:41'!
allMethodSelectors
	"give a list of all method selectors."

	^ elementArray copy sort! !

!ClassOrganizer methodsFor: 'method dictionary' stamp: 'sw 3/23/1999 17:04'!
letUserReclassify: anElement
	"Put up a list of categories and solicit one from the user.  Answer true if user indeed made a change, else false"
	"ClassOrganizer organization letUserReclassify: #letUserReclassify:"
	| currentCat newCat |
	currentCat _ self categoryOfElement: anElement.
	newCat _ self categoryFromUserWithPrompt: 'Choose Category (currently "', currentCat, '")'.
	(newCat ~~ nil and: [newCat ~= currentCat])
		ifTrue:
			[self classify: anElement under: newCat suppressIfDefault: false.
			^ true]
		ifFalse:
			[^ false]! !

!ClassOrganizer methodsFor: 'method dictionary'!
removeCategory: cat 
	"Remove the category named, cat. Create an error notificiation if the 
	category has any elements in it."

	| index lastStop |
	index _ categoryArray indexOf: cat ifAbsent: [^self].
	lastStop _ 
		index = 1
			ifTrue: [0]
			ifFalse: [categoryStops at: index - 1].
	(categoryStops at: index) - lastStop > 0 
		ifTrue: [^self error: 'cannot remove non-empty category'].
	categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new.
	categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new.
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]
! !

!ClassOrganizer methodsFor: 'method dictionary' stamp: 'sw 10/20/1999 16:24'!
renameCategory: oldCatString toBe: newCatString
	"Rename a category. No action if new name already exists, or if old name does not exist."
	| index oldCategory newCategory |
	oldCategory _ oldCatString asSymbol.
	newCategory _ newCatString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^ self].	"new name exists, so no action"
	(index _ categoryArray indexOf: oldCategory) = 0
		ifTrue: [^ self].	"old name not found, so no action"
	categoryArray _ categoryArray copy.  "need to change identity so smart list update will notice the change"
	categoryArray at: index put: newCategory! !


!ClassOrganizer methodsFor: 'printing' stamp: 'di 4/26/2000 20:22'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	| elementIndex |
	elementIndex _ 1.
	1 to: categoryArray size do: 
		[:i | 
		aStream nextPut: $(.
		(categoryArray at: i) asString printOn: aStream.
		[elementIndex <= (categoryStops at: i)]
			whileTrue: 
				[aStream space; nextPutAll: (elementArray at: elementIndex).
				elementIndex _ elementIndex + 1].
		aStream nextPut: $); cr]! !

!ClassOrganizer methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:16'!
printOnStream: aStream 
	"Refer to the comment in Object|printOn:."

	| elementIndex  |
	elementIndex _ 1.
	1 to: categoryArray size do: 
		[:i | 
		aStream print: '(';
		write:(categoryArray at:i).		" is the asString redundant? "

		[elementIndex <= (categoryStops at: i)]
			whileTrue: 
				[aStream print:' '; write:(elementArray at: elementIndex).
				elementIndex _ elementIndex + 1].
		aStream print:')'.
		aStream cr]! !


!ClassOrganizer methodsFor: 'fileIn/Out'!
fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex
	"Copy the class comment to aFileStream.  If moveSource is true (as in compressChanges or compressSources, then update globalComment to point to the new file."
	| fileComment |
	globalComment ifNotNil: 
			[aFileStream cr.
			fileComment _ RemoteString newString: globalComment text
							onFileNumber: fileIndex toFile: aFileStream.
			moveSource ifTrue: [globalComment _ fileComment]]! !

!ClassOrganizer methodsFor: 'fileIn/Out'!
moveChangedCommentToFile: aFileStream numbered: fileIndex 
	"If the comment is in the changes file, then move it to a new file."

	(globalComment ~~ nil and: [globalComment sourceFileNumber > 1]) ifTrue: 
		[self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! !

!ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:39'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

Smalltalk allBehaviorsDo: [:aClass | 
	aClass organization == self ifTrue: [
		(refStrm insideASegment and: [aClass isSystemDefined not]) ifTrue: [
			^ self].	"do trace me"
		(aClass isKindOf: Class) ifTrue: [
			dp _ DiskProxy global: aClass name selector: #organization args: #().
			refStrm replace: self with: dp.
			^ dp]]].
^ self	"in desparation"
! !

!ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'sw 8/24/1998 12:33'!
putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass
	"Store the comment about the class onto file, aFileStream."
	| header |
	globalComment ifNotNil:
		[aFileStream cr; nextPut: $!!.
		header _ String streamContents: [:strm | 
				strm nextPutAll: aClass name;
				nextPutAll: ' commentStamp: '.
				commentStamp ifNil: [commentStamp _ '<historical>'].
				commentStamp storeOn: strm.
				strm nextPutAll: ' prior: '; nextPutAll: '0'].
		aFileStream nextChunkPut: header.
		aClass organization fileOutCommentOn: aFileStream
				moveSource: moveSource toFile: sourceIndex.
		aFileStream cr]! !

!ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:57'!
scanFrom: aStream
	"Reads in the organization from the next chunk on aStream.
	Categories or elements not found in the definition are not affected.
	New elements are ignored."

	self changeFromString: aStream nextChunk.
	aStream skipStyleChunk.! !


!ClassOrganizer methodsFor: 'private' stamp: 'sw 2/24/1999 15:26'!
categoryFromUserWithPrompt: aPrompt
	"SystemDictionary organization categoryFromUserWithPrompt: 'testing'"
	| aMenu  |
	aMenu _ CustomMenu new.
	self categories do:
		[:cat | aMenu add: cat asString action: cat].
	^ aMenu startUpWithCaption: aPrompt! !

!ClassOrganizer methodsFor: 'private' stamp: 'di 3/29/2000 21:42'!
elementArray

	^ elementArray! !

!ClassOrganizer methodsFor: 'private' stamp: 'tk 12/16/97 07:35'!
setDefaultList: aSortedCollection

	self classComment: ''.
	categoryArray _ Array with: Default.
	categoryStops _ Array with: aSortedCollection size.
	elementArray _ aSortedCollection asArray! !


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

ClassOrganizer class
	instanceVariableNames: ''!

!ClassOrganizer class methodsFor: 'class initialization' stamp: 'ccn 3/22/1999 17:43'!
allCategory
	"Return a symbol that represents the virtual all methods category."

	^ '-- all --' asSymbol! !

!ClassOrganizer class methodsFor: 'class initialization'!
default 
	^ Default! !

!ClassOrganizer class methodsFor: 'class initialization'!
initialize
	Default _ 'as yet unclassified' asSymbol.
	NullCategory _ 'no messages' asSymbol.
	"ClassOrganizer initialize"! !

!ClassOrganizer class methodsFor: 'class initialization'!
nullCategory
	^ NullCategory! !


!ClassOrganizer class methodsFor: 'instance creation'!
defaultList: aSortedCollection 
	"Answer an instance of me with initial elements from the argument, 
	aSortedCollection."

	^self new setDefaultList: aSortedCollection! !


!ClassOrganizer class methodsFor: 'documentation'!
documentation
	"Instances consist of an Array of category names (categoryArray), each of 
	which refers to an Array of elements (elementArray). This association is 
	made through an Array of stop indices (categoryStops), each of which is 
	the index in elementArray of the last element (if any) of the 
	corresponding category. For example: categories _ Array with: 'firstCat' 
	with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. 
	elements _ Array with: #a with: #b with: #c with: #d. This means that 
	category firstCat has only #a, secondCat has #b, #c, and #d, and 
	thirdCat has no elements. This means that stops at: stops size must be the 
	same as elements size." ! !
ObjectRepresentativeMorph subclass: #ClassRepresentativeMorph
	instanceVariableNames: 'classRepresented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
Object subclass: #Clause
	instanceVariableNames: 'string phrases accent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Clause commentStamp: '<historical>' prior: 0!
My instances are clauses. They can carry a phrase accent (applicable to their last phrase) and a boundary tone: 'L- L%' (for declarative sentences in American English), 'H- H%' (for Yes-No questions), etc.!


!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:46'!
accent
	^ accent! !

!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:46'!
accent: aString
	accent _ aString! !

!Clause methodsFor: 'accessing' stamp: 'len 12/13/1999 02:32'!
accept: anObject
	anObject clause: self! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:53'!
events
	| answer |
	answer _ CompositeEvent new.
	self phrases do: [ :each | answer addAll: each events].
	^ answer! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:50'!
lastSyllable
	^ self phrases last lastSyllable! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:49'!
phrases
	^ phrases! !

!Clause methodsFor: 'accessing' stamp: 'len 12/8/1999 17:50'!
phrases: aCollection
	phrases _ aCollection! !

!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string
	^ string! !

!Clause methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string: aString
	string _ aString! !


!Clause methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:19'!
eventsDo: aBlock
	self phrases do: [ :phrase | phrase eventsDo: aBlock]! !

!Clause methodsFor: 'enumarating' stamp: 'len 12/14/1999 04:22'!
syllablesDo: aBlock
	self wordsDo: [ :each | each syllables do: aBlock]! !

!Clause methodsFor: 'enumarating' stamp: 'len 12/13/1999 02:40'!
wordsDo: aBlock
	self phrases do: [ :each | each words do: aBlock]! !


!Clause methodsFor: 'printing' stamp: 'len 12/8/1999 18:17'!
printOn: aStream
	self phrases do: [ :each | aStream print: each; nextPutAll: '- ']! !
Object subclass: #Clipboard
	instanceVariableNames: 'contents recent '
	classVariableNames: 'Default '
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!Clipboard commentStamp: '<historical>' prior: 0!
The Clipboard class implements a basic buffering scheme for text. The currently selected text is also exported to the OS so that text can be copied from and to other applications. Commonly only a single instance is used (the default clipboard) but applications are free to use other than the default clipboard if necessary.!


!Clipboard methodsFor: 'initialize' stamp: 'ar 1/15/2001 18:34'!
initialize
	contents _ '' asText.
	recent _ OrderedCollection new.! !


!Clipboard methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:32'!
chooseRecentClipping  "Clipboard chooseRecentClipping"
	"Choose by menu from among the recent clippings"

	recent ifNil: [^ nil].
	^ (SelectionMenu
		labelList: (recent collect: [:txt | ((txt asString contractTo: 50)
									copyReplaceAll: Character cr asString with: '\')
									copyReplaceAll: Character tab asString with: '|'])
		selections: recent) startUp.

! !

!Clipboard methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:31'!
clipboardText
	"Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard."

	| s |
	s _ self primitiveClipboardText.
	(s isEmpty or: [s = contents string])
		ifTrue: [^ contents]
		ifFalse: [^ s asText]! !

!Clipboard methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:40'!
clipboardText: text
	"Set text currently on the clipboard.  Also export to OS"
	contents _ text.
	self noteRecentClipping: text.
	self primitiveClipboardText: text string! !


!Clipboard methodsFor: 'primitives' stamp: 'ar 1/15/2001 18:28'!
primitiveClipboardText
	"Get the current clipboard text. Return the empty string if the primitive fails."
	<primitive: 141>
	^ ''! !

!Clipboard methodsFor: 'primitives' stamp: 'ar 1/15/2001 18:30'!
primitiveClipboardText: aString
	"Set the current clipboard text to the given string."

	<primitive: 141>
	"don't fail if the primitive is not implemented"! !


!Clipboard methodsFor: 'private' stamp: 'ar 1/15/2001 18:34'!
noteRecentClipping: text
	"Keep most recent clippings in a queue for pasteRecent (paste... command)"
	text isEmpty ifTrue: [^ self].
	text size > 50000 ifTrue: [^ self].
	(recent includes: text) ifTrue: [^ self].
	recent addFirst: text.
	[recent size > 5] whileTrue: [recent removeLast].
! !

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

Clipboard class
	instanceVariableNames: ''!

!Clipboard class methodsFor: 'instance creation' stamp: 'ar 1/15/2001 18:33'!
new
	^super new initialize.! !


!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:45'!
chooseRecentClipping  "Clipboard chooseRecentClipping"
	"Choose by menu from among the recent clippings"
	^self default chooseRecentClipping! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'!
clipboardText "Clipboard clipboardText"
	^self default clipboardText.! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'!
clipboardText: aText 
	^self default clipboardText: aText! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:33'!
default
	^Default ifNil:[Default _ self new].! !

!Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:48'!
default: aClipboard
	"So that clients can switch between different default clipboards"
	Default _ aClipboard.! !
PluggableCanvas subclass: #ClippingCanvas
	instanceVariableNames: 'canvas clipRect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!ClippingCanvas commentStamp: '<historical>' prior: 0!
A modified canvas which clips all drawing commands.!


!ClippingCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:44'!
apply: aBlock
	"apply the given block to the inner canvas with clipRect as the clipping rectangle"
	canvas clipBy: clipRect during: aBlock! !


!ClippingCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 20:44'!
canvas: aCanvas  clipRect: aRectangle
	canvas := aCanvas.
	clipRect := aRectangle.! !


!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/25/2000 22:56'!
clipRect
	^clipRect! !

!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/26/2000 14:22'!
contentsOfArea: aRectangle into: aForm
	self flag: #hack.    "ignore the clipping specification for this command.  This is purely so that CachingCanvas will work properly when clipped.  There *has* to be a clean way to do this...."
	^canvas contentsOfArea: aRectangle into: aForm! !

!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:17'!
form
	^canvas form! !

!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:17'!
isBalloonCanvas
	^canvas isBalloonCanvas! !

!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:18'!
isShadowDrawing
	^canvas isShadowDrawing! !

!ClippingCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:15'!
shadowColor
	^canvas shadowColor! !

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

ClippingCanvas class
	instanceVariableNames: ''!

!ClippingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:45'!
canvas: aCanvas  clipRect: aRectangle
	^self new canvas: aCanvas  clipRect: aRectangle! !
StringMorph subclass: #ClockMorph
	instanceVariableNames: 'showSeconds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ClockMorph methodsFor: 'as yet unclassified' stamp: 'sw 2/24/1999 12:51'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time"
	| item |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	item _ showSeconds == true
		ifTrue:	['stop showing seconds']
		ifFalse: ['start showing seconds'].
	aCustomMenu add: item target: self action: #toggleShowingSeconds
! !

!ClockMorph methodsFor: 'as yet unclassified' stamp: 'sw 2/17/1999 14:39'!
initialize
	super initialize.
	showSeconds _ true.
	self step! !

!ClockMorph methodsFor: 'as yet unclassified' stamp: 'sw 2/17/1999 14:39'!
showSeconds: aBoolean
	showSeconds _ aBoolean! !

!ClockMorph methodsFor: 'as yet unclassified' stamp: 'sw 2/17/1999 14:49'!
step
	| time |
	super step.
	time _ String streamContents:
		[:aStrm | Time now print24: false showSeconds: (showSeconds == true) on: aStrm].

	self contents: time			! !

!ClockMorph methodsFor: 'as yet unclassified'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 1000! !

!ClockMorph methodsFor: 'as yet unclassified' stamp: 'sw 2/17/1999 14:53'!
toggleShowingSeconds
	showSeconds _ (showSeconds == true) not
! !

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

ClockMorph class
	instanceVariableNames: ''!

!ClockMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/16/1998 15:36'!
authoringPrototype
	^ super authoringPrototype contents: Time now printString! !
StringHolder subclass: #CodeHolder
	instanceVariableNames: 'showDiffs currentCompiledMethod contentsSymbol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!CodeHolder commentStamp: '<historical>' prior: 0!
An ancestor class for all models which can show code.  Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.!


!CodeHolder methodsFor: 'annotation' stamp: 'sw 1/25/2001 06:40'!
annotation
	"Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver."

	|  aSelector aClass |

	((aSelector _ self selectedMessageName) == nil or: [(aClass _ self selectedClassOrMetaClass) == nil])
		ifTrue: [^ '------'].
	^ self annotationForSelector: aSelector ofClass: aClass! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 1/25/2001 06:17'!
annotationForSelector: aSelector ofClass: aClass
	"Provide a line of content for an annotation pane, representing information about the given selector and class"

	| stamp  sendersCount implementorsCount toShow aCategory separator aString aList versionsCount  aComment |

	toShow _ ReadWriteStream on: ''.
	separator _ ' ¥ '.
	self annotationRequests do:
		[:aRequest |
		(aRequest == #firstComment) ifTrue:
			[aComment _ aClass firstCommentAt:  aSelector.
			aComment isEmptyOrNil ifFalse:
				[toShow nextPutAll: (aComment, separator)]].

		(aRequest == #timeStamp) ifTrue:
			[stamp _ self timeStamp.
			toShow nextPutAll: (stamp size > 0
				ifTrue: [stamp, separator]
				ifFalse: ['no timeStamp', separator])].

		(aRequest == #messageCategory) ifTrue:
			[aCategory _ aClass organization categoryOfElement: aSelector.
			aCategory ifNotNil: "woud be nil for a method no longer present, e.g. in a recent-submissions browser"
				[toShow nextPutAll: aCategory, separator]].

		(aRequest == #sendersCount) ifTrue:
			[sendersCount _ (Smalltalk allCallsOn: aSelector) size.
			sendersCount _ sendersCount == 1
				ifTrue:
					['1 sender']
				ifFalse:
					[sendersCount printString, ' senders'].
			toShow nextPutAll: sendersCount, separator].

		(aRequest == #implementorsCount) ifTrue:
			[implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector.
			implementorsCount _ implementorsCount == 1
				ifTrue:
					['1 implementor']
				ifFalse:
					[implementorsCount printString, ' implementors'].
			toShow nextPutAll: implementorsCount,  separator].

		(aRequest == #priorVersionsCount) ifTrue:
			[versionsCount _ VersionsBrowser versionCountForSelector: aSelector class: aClass.
			toShow nextPutAll: 
				((versionsCount > 1
					ifTrue:
						[versionsCount == 2 ifTrue:
							['1 prior version']
							ifFalse:
								[versionsCount printString, ' prior versions']]
					ifFalse:
						['no prior versions']), separator)].

		(aRequest == #priorTimeStamp) ifTrue:
			[stamp _ VersionsBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2.
			stamp ifNotNil: [toShow nextPutAll: 'prior time stamp: ', stamp, separator]].

		(aRequest == #recentChangeSet) ifTrue:
			[aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector.
			aString size > 0 ifTrue: [toShow nextPutAll: aString, separator]].

		(aRequest == #allChangeSets) ifTrue:
			[aList _ ChangeSorter allChangeSetsWithClass: aClass selector: aSelector.
			aList size > 0
				ifTrue:
					[aList size = 1
						ifTrue:
							[toShow nextPutAll: 'only in change set ']
						ifFalse:
							[toShow nextPutAll: 'in change sets: '].
					aList do:
						[:aChangeSet | toShow nextPutAll: aChangeSet name, ' ']]
				ifFalse:
					[toShow nextPutAll: 'in no change set'].
			toShow nextPutAll: separator]].
		
	^ toShow contents! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 9/27/1999 14:13'!
annotationRequests
	^ Preferences defaultAnnotationRequests! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 1/24/2001 22:30'!
defaultAnnotationPaneHeight
	"Answer the receiver's preferred default height for new annotation panes."

	^ Preferences parameterAt: #defaultAnnotationPaneHeight default: [25]! !

!CodeHolder methodsFor: 'annotation' stamp: 'sw 1/24/2001 22:30'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ Preferences parameterAt: #defaultButtonPaneHeight default: [25]! !


!CodeHolder methodsFor: 'categories' stamp: 'sw 1/4/2001 12:04'!
categoryOfCurrentMethod
	"Answer the category that owns the current method.  If unable to determine a category, answer nil."

	| aClass aSelector |
	^ (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 9/27/1999 14:14'!
changeCategory
	"Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message"

	| aClass aSelector |
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[(aSelector _ self selectedMessageName) ifNotNil:
			[(aClass organization letUserReclassify: aSelector) ifTrue:
				["Smalltalk changes reorganizeClass: aClass."
				"Decided on further review that the above, when present, could cause more
                    unexpected harm than good"
				self methodCategoryChanged]]]! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 9/27/1999 14:11'!
methodCategoryChanged
	self changed: #annotation! !

!CodeHolder methodsFor: 'categories' stamp: 'sw 3/22/2000 23:04'!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the currently selected context."

	^ self selectedClass organization categoryOfElement: self selectedMessageName! !


!CodeHolder methodsFor: 'diffs' stamp: 'sw 1/18/2001 13:54'!
diffButton
	|  outerButton aButton |
	"Return a checkbox that lets the user decide whether diffs should be shown or not"
	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleDiffing;
		getSelector: #showDiffs.
	outerButton addMorphBack: (StringMorph contents: 'diffs') lock.
	outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'.

	^ outerButton
! !

!CodeHolder methodsFor: 'diffs' stamp: 'nk 10/29/2000 12:42'!
diffFromPriorSourceFor: sourceCode 
	"If there is a prior version of source for the selected method, return a 
	diff, else just return the source code"
	| prior |
	^ (prior _ self priorSourceOrNil)
		ifNil: [sourceCode]
		ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass]! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/27/1999 13:56'!
showDiffs
	^ showDiffs == true
! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 9/27/1999 13:56'!
showDiffs: aBoolean
	showDiffs _ aBoolean! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 1/18/2001 13:58'!
toggleDiff
	"Retained for backward compatibility with existing buttons in existing images"

	self toggleDiffing! !

!CodeHolder methodsFor: 'diffs' stamp: 'sw 1/18/2001 13:56'!
toggleDiffing
	"Toggle whether diffs should be shown in the code pane"

	self okToChange ifTrue:
		[self showDiffs: self showDiffs not.
		contents _ nil.
		self changed: #contents]

! !


!CodeHolder methodsFor: 'contents' stamp: 'sw 12/11/2000 10:42'!
commentContents
	"documentation for the selected method"

	| poss aClass aSelector |
	^ (poss _ (aClass _ self selectedClassOrMetaClass)
						ifNil:
							['----']
						ifNotNil:
							[(aSelector _ self selectedMessageName)
								ifNil:
									['---']
								ifNotNil:
									[(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp"
"which however misses comments that are between the temps  declaration and the body of the method; those are picked up by ¥aClass commentOrInheritedCommentFor: aSelector¥ but that method will get false positives from comments *anywhere* in the method source"]])
		isEmptyOrNil
			ifTrue:
				[aSelector
					ifNotNil:
						[((aClass methodHeaderFor: aSelector), '

Has no comment') asText makeSelectorBoldIn: aClass]
					ifNil:
						['Hamna']]
			ifFalse:	[aSelector
				ifNotNil: [((aClass methodHeaderFor: aSelector), '

', poss) asText makeSelectorBoldIn: aClass]
				ifNil: [poss]]! !

!CodeHolder methodsFor: 'contents' stamp: 'sw 12/5/2000 12:16'!
contents
	"Answer the source code or documentation for the selected method"

	^ self showingDocumentation
		ifFalse:
			[super contents]
		ifTrue:
			[self commentContents]! !

!CodeHolder methodsFor: 'contents' stamp: 'sw 9/27/1999 14:11'!
contentsChanged
	self changed: #contents.
	self changed: #annotation! !

!CodeHolder methodsFor: 'contents' stamp: 'sw 11/29/2000 09:50'!
contentsSymbol
	"Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source.  A nil value in the contentsSymbol slot will be set to #source by this method"

	^ contentsSymbol ifNil: [contentsSymbol _ #source]! !

!CodeHolder methodsFor: 'contents' stamp: 'sw 11/29/2000 09:51'!
contentsSymbol: aSymbol
	"Set the contentsSymbol as indicated.  #source means to show source code, #comment means to show the first comment found in the source code"

	contentsSymbol _ aSymbol! !


!CodeHolder methodsFor: 'commands' stamp: 'sw 12/28/2000 18:09'!
adoptMessageInCurrentChangeset
	"Add the receiver's method to the current change set if not already there"

	self setClassAndSelectorIn: [:cl :sel |
		cl ifNotNil:
			[Smalltalk changes adoptSelector: sel forClass: cl.
			self changed: #annotation]]
! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 5/8/2000 12:38'!
makeSampleInstance
	| aClass nonMetaClass anInstance |
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ self].
	nonMetaClass _ aClass theNonMetaClass.
	anInstance _ self sampleInstanceOfSelectedClass.
	(anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue: 
		[^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name].

	(Smalltalk isMorphic and: [anInstance isMorph])
		ifTrue:
			[self currentHand attachMorph: anInstance]
		ifFalse:
			[anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 5/5/2000 09:23'!
showUnreferencedInstVars
	"Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system.  The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced"

	| cls aList aReport |
	(cls _ self selectedClass) ifNil: [^ self].
	aList _ cls allUnreferencedInstanceVariables.
	aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced
instance variables in
', cls name].
	aReport _ String streamContents:
		[:aStream |
			aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr.
			aList do: [:el | aStream tab; nextPutAll: el; cr]].
	Transcript cr; show: aReport.
	(SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced
instance variables in 
', cls name! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 1/4/2001 12:17'!
spawn: aString 
	"Create and schedule a spawned message category browser for the currently selected message category.  The initial text view contains the characters in aString.  In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change"

	| newBrowser aCategory aClass |
	(aClass _ self selectedClassOrMetaClass) isNil ifTrue:
		[^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']].

	(aCategory _ self categoryOfCurrentMethod)
		ifNil:
			[self buildClassBrowserEditString: aString]
		ifNotNil:
			[newBrowser _ Browser new setClass: aClass selector: self selectedMessageName.
			newBrowser setOriginalCategoryIndexForCurrentMethod.
			Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
		label: 'category "', aCategory, '" in ', 
				newBrowser selectedClassOrMetaClassName]! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 12/4/2000 12:07'!
spawnFullProtocol
	"Create and schedule a new protocol browser on the currently selected class or meta."

	| aClassOrMetaclass |
	(aClassOrMetaclass _ self selectedClassOrMetaClass) ifNotNil:
       	[ProtocolBrowser openFullProtocolForClass: aClassOrMetaclass]! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 5/8/2000 03:18'!
spawnHierarchy
	"Create and schedule a new class hierarchy browser on the currently selected class or meta."
	| newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass |
	(selectedClassOrMetaClass _ self selectedClassOrMetaClass) ifNil: [^ self].
	newBrowser _ HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass.
	(aSymbol _ self selectedMessageName) ifNotNil:
		[aBehavior _ selectedClassOrMetaClass.
		messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
		newBrowser messageCategoryListIndex: messageCatIndex + 1.
		newBrowser messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
						indexOf: aSymbol)].
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: self selectedClassName , ' hierarchy'! !

!CodeHolder methodsFor: 'commands' stamp: 'sw 5/8/2000 14:24'!
spawnProtocol
	| aClassOrMetaclass |
	"Create and schedule a new protocol browser on the currently selected class or meta."
	(aClassOrMetaclass _ self selectedClassOrMetaClass) ifNotNil:
       	[ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]! !


!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 11:32'!
showComment
	"Answer whether the receiver should show documentation rather than, say, source code"

	^ self contentsSymbol == #documentation
! !

!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 12:25'!
showDocumentation: aBoolean
	"Set the showDocumentation toggle as indicated"

	self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])! !

!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 12:12'!
showingDocumentation
	"Answer whether the receiver should show documentation rather than, say, source code"

	^ self contentsSymbol == #documentation
! !

!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 11:48'!
showingSource
	"Answer whether the receiver is currently showing source code"

	^ self contentsSymbol == #source
! !

!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 11:51'!
sourceOrInfoButton
	"Return a checkbox that lets the user decide whether the full source or just documentation should show in the code pane"

	|  outerButton aButton |
	outerButton _ AlignmentMorph newRow.
	outerButton wrapCentering: #center; cellPositioning: #leftCenter.
	outerButton color:  Color transparent.
	outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #toggleShowDocumentation;
		getSelector: #showingSource.
	outerButton addMorphBack: (StringMorph contents: 'source') lock.
	outerButton setBalloonText: 'If checked, then source code is shown in the text pane, if not, then documentation is shown'.

	^ outerButton
! !

!CodeHolder methodsFor: 'source vs documentation' stamp: 'sw 12/5/2000 12:17'!
toggleShowDocumentation
	"Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard"

	self okToChange ifTrue:
		[self showDocumentation: self showingDocumentation not.
		contents _ nil.
		self changed: #contents]

! !


!CodeHolder methodsFor: 'misc' stamp: 'JW 2/3/2001 09:38'!
addLowerPanesTo: window at: nominalFractions with: editString

	| verticalOffset row innerFractions |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		borderColor: Color black;
		layoutPolicy: ProportionalLayout new.

	verticalOffset _ 0.
	innerFractions _ 0@0 corner: 1@0.
	verticalOffset _ self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset.
	verticalOffset _ self addOptionalButtonsTo: row  at: innerFractions plus: verticalOffset.

	row 
		addMorph: ((self buildMorphicCodePaneWith: editString) borderWidth: 0)
		fullFrame: (
			LayoutFrame 
				fractions: (innerFractions withBottom: 1) 
				offsets: (0@verticalOffset corner: 0@0)
		).
	window 
		addMorph: row
		frame: nominalFractions.

	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.! !

!CodeHolder methodsFor: 'misc' stamp: 'JW 2/3/2001 10:12'!
addOptionalAnnotationsTo: window at: fractions plus: verticalOffset
	"Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any"

	| aTextMorph divider delta |
	self wantsAnnotationPane ifFalse: [^ verticalOffset].
	aTextMorph _ PluggableTextMorph 
		on: self
		text: #annotation 
		accept: nil
		readSelection: nil
		menu: #annotationPaneMenu:shifted:.
	aTextMorph
		askBeforeDiscardingEdits: false;
		borderWidth: 0;
		hideScrollBarIndefinitely.
	divider _ SubpaneDividerMorph forBottomEdge.
	delta _ self defaultAnnotationPaneHeight.
	window 
		addMorph: aTextMorph 
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'misc' stamp: 'JW 2/3/2001 09:39'!
addOptionalButtonsTo: window at: fractions plus: verticalOffset
	"If the receiver wishes it, add a button pane to the window, and answer the verticalOffset plus the height added"

	| delta buttons divider |
	self wantsOptionalButtons ifFalse: [^verticalOffset].
	delta _ self defaultButtonPaneHeight.
	buttons _ self optionalButtonRow 
		color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]);
		borderWidth: 0.
	divider _ SubpaneDividerMorph forBottomEdge.
	window 
		addMorph: buttons
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))).
	window 
		addMorph: divider
		fullFrame: (LayoutFrame 
				fractions: fractions 
				offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))).
	^ verticalOffset + delta! !

!CodeHolder methodsFor: 'misc' stamp: 'RAA 1/13/2001 07:20'!
annotationPaneMenu: aMenu shifted: shifted

	^ aMenu 
		labels: 'change pane size'
		lines: #()
		selections: #(toggleAnnotationPaneSize)! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/28/2001 00:11'!
browseSenders
	"Create and schedule a message set browser on all senders of the currently selected message selector. Do nothing if no message is selected."

	| aMessageName |
	(aMessageName _ self selectedMessageName) ifNotNil: 
		[Smalltalk browseAllCallsOn: aMessageName]! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/4/2001 12:34'!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, with initial textual contents set to aString.  This is used specifically in spawning where a class is established but a method-category is not."

	| newBrowser  |
	newBrowser _ Browser new.
	newBrowser setClass: self selectedClassOrMetaClass selector: nil.
	newBrowser editSelection: #newMessage.
	Browser openBrowserView: (newBrowser openOnClassWithEditString: aString)
			label: 'Class Browser: ', self selectedClassOrMetaClass name
! !

!CodeHolder methodsFor: 'misc' stamp: 'RAA 1/11/2001 08:54'!
buildMorphicCodePaneWith: editString

	| codePane |

	codePane _ PluggableTextMorph 
		on: self 
		text: #contents 
		accept: #contents:notifying:
		readSelection: #contentsSelection 
		menu: #codePaneMenu:shifted:.
	editString ifNotNil: [
		codePane editString: editString.
		codePane hasUnacceptedEdits: true
	].
	^codePane
! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/7/2001 07:15'!
buttonWithSelector: aSelector
	"If receiver has a control button with the given action selector answer it, else answer nil.  morphic only at this point"

	| aWindow aPane |
	((aWindow _ self containingWindow) isKindOf: SystemWindow) ifFalse: [^ nil].
	(aPane _ aWindow submorphNamed: 'buttonPane') ifNil: [^ nil].
	^  aPane submorphThat: [:m | (m isKindOf: PluggableButtonMorph) and:
		[m actionSelector == aSelector]] ifNone: [^ nil]! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/5/2001 07:19'!
decorateButtons
	"Change screen feedback for any buttons in the UI of the receiver that may wish it.  Initially, it is only the Inheritance button that is decorated, but one can imagine others."

	self decorateForInheritance ! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/5/2001 07:15'!
decorateForInheritance
	"Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to."

	| aColor aButton |
	(aButton _ self inheritanceButton) ifNil: [^ self].

	aColor _ (currentCompiledMethod == nil or: [Preferences decorateBrowserButtons not])
		ifTrue:
			[Color transparent]
		ifFalse:
			[currentCompiledMethod sendsToSuper
				ifTrue:
					[self isThereAnOverride
						ifTrue:
							[Color blue muchLighter]
						ifFalse:
							[Color green muchLighter ]]
				ifFalse:
					[self isThereAnOverride
						ifTrue:
							[Color tan lighter]
						ifFalse:
							[Color transparent]]].
	aButton offColor: aColor! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/25/2001 14:44'!
inheritanceButton
	"If receiver has an Inheritance button, answer it, else answer nil.  morphic only at this point"

	^ self buttonWithSelector: #methodHierarchy! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 12/28/2000 16:43'!
isThereAnOverride
	"Answer whether any subclass of my selected class implements my selected selector"

	| aName aList aClass |
	(aName _ self selectedMessageName) ifNil: [^ false].

	aList _ Smalltalk allImplementorsOf: aName.
	aClass _ self selectedClassOrMetaClass.
	aList do:
		[:element | MessageSet parse: element toClassAndSelector:
			[:cl :sel | (cl inheritsFrom: aClass) ifTrue: [^ true]]].
	^ false! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 1/5/2001 07:31'!
modelWakeUpIn: aWindow
	"The window has been activated.  Respond to possible changes that may have taken place while it was inactive"

	self updateListsAndCodeIn: aWindow.
	self decorateButtons.
	super modelWakeUpIn: aWindow! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 12/5/2000 11:33'!
okayToAccept
	"Answer whether it is okay to accept the receiver's input"

	self showComment ifTrue:
		[self inform: 
'Sorry, for the moment you can
only submit changes here when
you are showing source.  Later, you
will be able to edit the isolated comment
here and save it back, but only if YOU
implement it!!.'.
		^ false].

	self showDiffs ifFalse:
		[^ true]. 
	^ SelectionMenu confirm: 
'Caution!!  You are "showing diffs" here, so 
there is a danger that some of the text in the
code pane is contaminated by the "diff" display'
	trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider'
! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/1999 14:09'!
priorSourceOrNil
	"If the currently-selected method has a previous version, return its source, else return nil"
	| aClass aSelector  changeRecords |
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ nil].
	(aSelector _ self selectedMessageName) ifNil: [^ nil].
	changeRecords _ aClass changeRecordsAt: aSelector.
	(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
	^ (changeRecords at: 2) string 
! !

!CodeHolder methodsFor: 'misc' stamp: 'tk 9/9/2000 21:08'!
releaseCachedState
	"Can always be found again.  Don't write on a file."
	currentCompiledMethod _ nil.! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 5/8/2000 12:34'!
sampleInstanceOfSelectedClass
	| aClass |
	"Return a sample instance of the class currently being pointed at"
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ nil].
	^ aClass theNonMetaClass initializedInstance! !

!CodeHolder methodsFor: 'misc' stamp: 'sw 12/28/2000 15:32'!
setClassAndSelectorIn: csBlock
	"Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected"

	| aName |
	(aName _ self selectedMessageName)
		ifNil:
			[csBlock value: nil value: nil]
		ifNotNil:
			[csBlock value: self selectedClassOrMetaClass value: aName]
! !


!CodeHolder methodsFor: 'self-updating' stamp: 'di 1/17/2001 16:05'!
didCodeChangeElsewhere
	"Determine whether the code for the currently selected method and class has been changed somewhere else."

	| aClass aSelector aCompiledMethod |
	currentCompiledMethod ifNil: [^ false].
	(aClass _ self selectedClassOrMetaClass) ifNil: [^ false].
	(aSelector _ self selectedMessageName) ifNil: [^ false].
	^ ((aCompiledMethod _ aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod)
		and: [aCompiledMethod last ~= 0 "either not yet installed"
				or: [currentCompiledMethod last = 0 "or these methods don't have source pointers"]]
	! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 08:37'!
stepIn: aSystemWindow
	self updateListsAndCodeIn: aSystemWindow! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 17:30'!
updateCodePaneIfNeeded
	"If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits"

	self didCodeChangeElsewhere
		ifTrue:
			[self hasUnacceptedEdits
				ifFalse:
					[contents _ nil.
					self contentsChanged]
				ifTrue:
					[self changed: #codeChangedElsewhere]]! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/19/1999 14:14'!
updateListsAndCodeIn: aWindow
	super updateListsAndCodeIn: aWindow.
	self updateCodePaneIfNeeded! !

!CodeHolder methodsFor: 'self-updating' stamp: 'sw 10/20/1999 12:22'!
wantsStepsIn: aWindow
	^ Preferences smartUpdating! !
Object subclass: #CodeLoader
	instanceVariableNames: 'baseURL sourceFiles segments publicKey '
	classVariableNames: 'DefaultBaseURL DefaultKey '
	poolDictionaries: ''
	category: 'Framework-Download'!
!CodeLoader commentStamp: '<historical>' prior: 0!
CodeLoader provides a simple facility for loading code from the network.

Examples:
	| loader |
	loader _ CodeLoader new.
	loader baseURL:'http://isgwww.cs.uni-magdeburg.de/~raab/test/'.
	loader localCache: #('.cache' 'source').
	"Sources and segments can be loaded in parallel"
	loader loadSourceFiles: #('file1.st' 'file2.st.gz').
	loader localCache: #('.cache' 'segments').
	loader loadSegments: #('is1.extseg' 'is2.extseg.gz').
	"Install sources first - will wait until the files are actually loaded"
	loader installSourceFiles.
	"And then the segments"
	loader installSegments.!


!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'!
baseURL
	^baseURL! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/13/1999 18:19'!
baseURL: aString
	baseURL _ aString.! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'!
publicKey
	^publicKey! !

!CodeLoader methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:07'!
publicKey: aPublicKey
	publicKey _ aPublicKey! !


!CodeLoader methodsFor: 'loading' stamp: 'mir 10/13/2000 12:24'!
loadSegments: anArray
	"Load all the source files in the given array."
	| loader request reqName |
	loader _ HTTPLoader default.
	segments _ anArray collect:[:name |
		reqName _ (FileDirectory extensionFor: name) isEmpty
			ifTrue: [FileDirectory fileName: name extension: ImageSegment compressedFileExtension]
			ifFalse: [name].
		request _ self createRequestFor: reqName in: loader.
		name->request].
! !

!CodeLoader methodsFor: 'loading' stamp: 'ar 12/14/1999 14:40'!
loadSourceFiles: anArray
	"Load all the source files in the given array."
	| loader request |
	loader _ HTTPLoader default.
	sourceFiles _ anArray collect:[:name|
		request _ self createRequestFor: name in: loader.
		request].
! !


!CodeLoader methodsFor: 'installing' stamp: 'ar 1/19/2001 16:28'!
installProject
	"Assume that we're loading a single file and it's a project"
	| aStream |
	aStream _ sourceFiles first contentStream.
	aStream ifNil:[^self error:'Project was not loaded'].
	ProjectLoading
			openFromFile: aStream
			fromDirectory: nil
			withProjectView: nil.
! !

!CodeLoader methodsFor: 'installing' stamp: 'mir 2/23/2000 12:58'!
installSegment: reqEntry
	"Install the previously loaded segment"
	| secured contentStream contents |
	contentStream _ reqEntry value contentStream.
	contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString].
	secured _ self positionedToSecuredContentsOf: contentStream.

	secured
		ifFalse: [
			(contentStream respondsTo: #close) ifTrue:[contentStream close].
			^self error:'Insecure content encountered: ', reqEntry key printString].
	contents _ contentStream upToEnd unzipped.
	(contentStream respondsTo: #close) ifTrue:[contentStream close].
	^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! !

!CodeLoader methodsFor: 'installing' stamp: 'mir 1/20/2000 13:37'!
installSegments
	"Install the previously loaded segments"
	segments == nil ifTrue:[^self].
	segments do:[:req| self installSegment: req].
	segments _ nil.! !

!CodeLoader methodsFor: 'installing' stamp: 'mir 2/23/2000 12:59'!
installSourceFile: aStream
	"Install the previously loaded source file"
	| contents secured |
	aStream ifNil:[^self error:'No content to install'].
	secured _ self positionedToSecuredContentsOf: aStream.

	secured
		ifFalse: [
			(aStream respondsTo: #close) ifTrue:[aStream close].
			^self error:'Insecure content encountered'].
	contents _ aStream upToEnd unzipped.
	(aStream respondsTo: #close) ifTrue:[aStream close].
	^(RWBinaryOrTextStream with: contents) reset fileIn! !

!CodeLoader methodsFor: 'installing' stamp: 'ar 12/22/1999 15:02'!
installSourceFiles
	"Install the previously loaded source files"
	sourceFiles == nil ifTrue:[^self].
	sourceFiles do:[:req| self installSourceFile: req contentStream].
	sourceFiles _ nil.! !


!CodeLoader methodsFor: 'private' stamp: 'mir 1/10/2000 18:56'!
createRequestFor: name in: aLoader
	"Create a URL request for the given string, which can be cached locally."
	| request |
	request _ self httpRequestClass for: self baseURL , name in: aLoader.
	aLoader addRequest: request. "fetch from URL"
	^request! !

!CodeLoader methodsFor: 'private' stamp: 'mir 12/22/1999 14:13'!
httpRequestClass
	^HTTPRequest! !

!CodeLoader methodsFor: 'private' stamp: 'mir 2/23/2000 12:57'!
positionedToSecuredContentsOf: aStream
	"Private - return the 'secured' part of the given stream, e.g., the actual contents without the verification checksum. If the verification fails return nil (since there is no secured contents)."

	| hash signature part1 part2 dsa okay |

	"No key, no security..."
	publicKey == nil
		ifTrue: [^true].
	aStream position: 0.
	aStream binary.
	part1 _ aStream nextInto: (LargePositiveInteger basicNew: 20).
	part2 _ aStream nextInto: (LargePositiveInteger basicNew: 20).
	signature _ Array with: part1 with: part2.
	hash _ SecureHashAlgorithm new hashStream: aStream.
	dsa _ DigitalSignatureAlgorithm new.
	okay _ dsa verifySignature: signature ofMessageHash: hash publicKey: publicKey.
	okay
		ifFalse: [^false].
	aStream ascii.
	aStream position: 40.
	^true! !


!CodeLoader methodsFor: 'initialize-release' stamp: 'mir 1/11/2000 13:47'!
initialize
	publicKey _ DefaultKey.
	baseURL _ self class defaultBaseURL! !

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

CodeLoader class
	instanceVariableNames: ''!

!CodeLoader class methodsFor: 'instance creation' stamp: 'ar 12/22/1999 15:08'!
new
	^super new initialize! !


!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'!
defaultBaseURL
	^DefaultBaseURL ifNil: ['']! !

!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/11/2000 13:45'!
defaultBaseURL: aURLString
	DefaultBaseURL _ aURLString! !

!CodeLoader class methodsFor: 'accessing' stamp: 'ar 12/22/1999 15:08'!
defaultKey
	"Return the default key used for verifying signatures of loaded code"
	^DefaultKey! !

!CodeLoader class methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:16'!
defaultKey: aPublicKey
	"Store the default key used for verifying signatures of loaded code"
	DefaultKey _ aPublicKey
	"CodeLoader defaultKey: DOLPublicKey"
	"CodeLoader defaultKey: (DigitalSignatureAlgorithm testKeySet at: 2)"! !


!CodeLoader class methodsFor: 'utilities' stamp: 'mir 9/6/2000 15:03'!
compressFileNamed: aFileName
	self compressFileNamed: aFileName in: FileDirectory default! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/13/2000 13:27'!
compressFileNamed: aFileName in: aDirectory
	"Compress the currently selected file"
	| zipped buffer unzipped zipFileName |
	unzipped _ aDirectory readOnlyFileNamed: (aDirectory fullNameFor: aFileName).
	unzipped binary.
	zipFileName _ aFileName copyUpToLast: $. .
	zipped _ aDirectory newFileNamed: (zipFileName, FileDirectory dot, ImageSegment compressedFileExtension).
	zipped binary.
	zipped _ GZipWriteStream on: zipped.
	buffer _ ByteArray new: 50000.
	'Compressing ', zipFileName displayProgressAt: Sensor cursorPoint
		from: 0 to: unzipped size
		during:[:bar|
			[unzipped atEnd] whileFalse:[
				bar value: unzipped position.
				zipped nextPutAll: (unzipped nextInto: buffer)].
			zipped close.
			unzipped close].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 16:22'!
exportCategories: catList to: aFileName
	"CodeLoader exportCategories: #( 'Game-Animation' 'Game-Framework' ) to: 'Game-Framework'"

	| list classList |
	classList _ OrderedCollection new.
	catList do: [:catName |
		list _ SystemOrganization listAtCategoryNamed: catName asSymbol.
		list do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class]].
	self exportCodeSegment: aFileName classes: classList keepSource: true! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'!
exportCategoryNamed: catName
	"CodeLoader exportCategoryNamed: 'OceanicPanic' "

	| list |
	list _ SystemOrganization listAtCategoryNamed: catName asSymbol.
	self exportClassesNamed: list to: catName! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 20:53'!
exportClassesNamed: classNameList to: aFileName

	| classList |
	classList _ OrderedCollection new.
	classNameList do: [:nm | classList add: (Smalltalk at: nm); add: (Smalltalk at: nm) class].
	self exportCodeSegment: aFileName classes: classList keepSource: true! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/11/2000 19:12'!
exportCodeSegment: exportName classes: aClassList keepSource: keepSources

	"Code for writing out a specific category of classes as an external image segment.  Perhaps this should be a method."

	| is oldMethods newMethods m oldCodeString argsAndTemps classList symbolHolder fileName |
	keepSources
		ifTrue: [
			self confirm: 'We are going to abandon sources.
Quit without saving after this has run.' orCancel: [^self]].

	classList _ aClassList asArray.

	"Strong pointers to symbols"
	symbolHolder := Symbol allInstances.

	oldMethods _ OrderedCollection new: classList size * 150.
	newMethods _ OrderedCollection new: classList size * 150.
	keepSources
		ifTrue: [
			classList do: [:cl |
				cl selectors do:
					[:selector |
					m _ cl compiledMethodAt: selector.
					m fileIndex > 0 ifTrue:
						[oldCodeString _ cl sourceCodeAt: selector.
						argsAndTemps _ (cl compilerClass new
							parse: oldCodeString in: cl notifying: nil) tempNames.
						oldMethods addLast: m.
						newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	oldMethods _ newMethods _ m _ oldCodeString _ argsAndTemps _ nil.

	Smalltalk garbageCollect.
	is _ ImageSegment new copyFromRootsForExport: classList.	"Classes and MetaClasses"

	fileName _ FileDirectory fileName: exportName extension: ImageSegment fileExtension.
	is writeForExport: fileName.
	self compressFileNamed: fileName

! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/12/2000 17:39'!
loadCode: codeSegmentName from: baseURL ifClassNotLoaded: testClass

	CodeLoader defaultBaseURL: baseURL.
	(Smalltalk includesKey: testClass)
		ifFalse: [CodeLoader loadCodeSegment: codeSegmentName].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 10/11/2000 19:14'!
loadCodeSegment: segmentName
	| loader |
	loader _ PluginCodeLoader new.
	loader loadSegments: (Array with: segmentName). 
	loader installSegments.! !

!CodeLoader class methodsFor: 'utilities' stamp: 'ar 12/22/1999 15:09'!
signFile: fileName renameAs: destFile key: privateKey dsa: dsa
	"Sign the given file using the private key."
	| in hash sig out |
	in _ FileStream readOnlyFileNamed: fileName.
	in binary.
	hash _ SecureHashAlgorithm new hashStream: in.
	sig _ dsa computeSignatureForMessageHash: hash privateKey: privateKey.
	out _ FileStream newFileNamed: destFile.
	out binary.
	out nextPutAll: sig first; nextPutAll: sig last.
	in position: 0.
	[in atEnd] whileFalse:[out nextPutAll: (in next: 4096)].
	in close.
	out close.! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/14/2000 16:47'!
signFiles: fileNames in: dirName key: privateKey
	"Sign the files in the current directory and put them into a folder signed."

	|  newNames oldNames |
	oldNames _ fileNames collect:[:fileName | dirName , FileDirectory slash, fileName].
	newNames _ fileNames collect:[:fileName | dirName , FileDirectory slash, 'signed', FileDirectory slash, fileName].
	CodeLoader
		signFilesFrom: oldNames
		to: newNames
		key: privateKey! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 18:49'!
signFiles: fileNames key: privateKey
	"Sign the files in the current directory and put them into a folder signed."

	|  newNames |
	newNames _ fileNames collect:[:fileName | 'signed', FileDirectory slash, fileName].
	CodeLoader
		signFilesFrom: fileNames
		to: newNames
		key: privateKey! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 1/18/2000 11:14'!
signFilesFrom: sourceNames to: destNames key: privateKey
	"Sign all the given files using the private key.
	This will add an 's' to the extension of the file."
	"| fd oldNames newNames |
	fd _ FileDirectory default directoryNamed:'unsigned'.
	oldNames _ fd fileNames.
	newNames _ oldNames collect:[:name| 'signed', FileDirectory slash, name].
	oldNames _ oldNames collect:[:name| 'unsigned', FileDirectory slash, name].
	CodeLoader
		signFilesFrom: oldNames
		to: newNames
		key: DOLPrivateKey."
	| dsa |
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandom: (dsa randomBitsFromSoundInput: 512).
	'Signing files...' displayProgressAt: Sensor cursorPoint
		from: 1 to: sourceNames size during:[:bar|
			1 to: sourceNames size do:[:i|
				bar value: i.
				self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]].
! !

!CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/23/2000 12:57'!
verifySignedFileNamed: aFileName
	"CodeLoader verifySignedFileNamed: 'signed\dummy1.dsq' "

	| secured signedFileStream |
	signedFileStream _ FileStream fileNamed: aFileName.
	secured _ CodeLoader new positionedToSecuredContentsOf: signedFileStream.
	signedFileStream close.
	Transcript show: aFileName , ' verified: '; show: secured printString; cr.

! !
ServerAction subclass: #CodeServer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!CodeServer commentStamp: '<historical>' prior: 0!
Return the source code from Smalltalk, as web page text, or as a raw Squeak file chunk.
URLs are of the form:	
	machine:80/smtlk.Point|min;			<-- NOTE: use ; instead of :
	machine:80/smtlk.{Class}|{selector}
	machine:80/chunk.{Class}|{selector}

	machine:80/smtlk.{Class}|class|{selector}
	machine:80/chunk.{Class}|class|{selector}

	machine:80/smtlk.{Class}|Definition
	machine:80/chunk.{Class}|Definition

	machine:80/smtlk.{Class}|Hierarchy
	machine:80/chunk.{Class}|Hierarchy

	machine:80/smtlk.{Class}|Comment
	machine:80/chunk.{Class}|Comment
NOTE: use ; semicolon instead of : colon in selector names
!


!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'!
chunk: request
	"Return Smalltalk source code as a chunk from the changes file.  
URL = machine:80/chunk.Point|min;  included are:  Point|at;   Point|Comment   Point|Hierarchy  Point|Definition   Point|class|x;y;
	Meant to be received by a Squeak client, not a browser.  Reply not in HTML"

	| classAndMethod set strm chunk |
	classAndMethod _ request message atPin: 2.
	classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '.
	classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'.
	set _ LinkedMessageSet messageList: (Array with: classAndMethod).
	strm _ WriteStream on: (String new: 300).
	strm nextChunkPutWithStyle: (set selectedMessage). "String or text"
	chunk _ strm contents.

	request reply: 'content-length: ', chunk size printString, PWS crlfcrlf.
	request reply: chunk.
! !

!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:35'!
process: request
	"Return the source code from Smalltalk, as text or as a chunk.
URLs are of this form.  Each may have 'chunk' or 'smtlk' as the thing after the slash
	machine:80/smtlk.Point|min;
	machine:80/chunk.{Class}|{selector}		
	machine:80/smtlk.{Class}|{selector}
	machine:80/smtlk.{Class}|class|{selector}
	machine:80/smtlk.{Class}|Definition
	machine:80/smtlk.{Class}|Hierarchy
	machine:80/smtlk.{Class}|Comment
NOTE: use ; semicolon instead of : colon in selector names!!!!!!"

	| coreRef |
	coreRef _ (request message at: 1) asLowercase.
	request reply: PWS success; reply: PWS contentHTML.
	Transcript show: 'In process: ', request message printString; cr.
	coreRef = 'smtlk' ifTrue: [^ self smtlk: request].
	coreRef = 'chunk' ifTrue: [^ self chunk: request].
	request reply: ( 'HTTP/1.0 400 Bad Request', PWS crlfcrlf, 
		'expected smtlk.{Class}|{selector} or chunk.{Class}|{selector}').	"failure"! !

!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'!
smtlk: request
	"Return Smalltalk sourcecode in HTML.  URL = machine:80/myswiki.smtlk.Point|min;  included are:  Point|min;   Point|Comment   Point|Hierarchy  Point|Definition   Point|class|x;y;  
NOTE: use ; instead of : in selector names!!!!!!"

	| classAndMethod set |
	classAndMethod _ request message atPin: 2.
	classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '.
	classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'.
	set _ LinkedMessageSet messageList: (Array with: classAndMethod).

	request reply: PWS crlf, (HTMLformatter 
				evalEmbedded: (self fileContents: 'swiki',(ServerAction pathSeparator),'smtlk.html')
				with: set).! !
RectangleMorph subclass: #CodecDemoMorph
	instanceVariableNames: 'codecClassName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:37'!
acceptDroppingMorph: aMorph event: evt

	| codecClass |
	'None' = codecClassName
		ifTrue: [aMorph sound play]
		ifFalse: [
			codecClass _ Smalltalk at: codecClassName ifAbsent: [^ self].
			(codecClass new compressAndDecompress: aMorph sound) play].
	aMorph position: self topRight + (10@0).
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:33'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'select codec' action: #selectCodec.
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:36'!
codecClassName: aStringOrSymbol

	| label |
	codecClassName _ aStringOrSymbol asSymbol.
	self removeAllMorphs.
	label _ StringMorph contents: aStringOrSymbol.
	label position: self position + (5@5).
	self addMorph: label.
	label lock: true.
	self extent: label extent + (10@10).
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:18'!
initialize

	super initialize.
	self borderWidth: 2.
	self color: (Color r: 1.0 g: 0.806 b: 0.677).
	self codecClassName: 'MuLawCodec'.
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:33'!
selectCodec

	| aMenu codecs newCodec |
	aMenu _ CustomMenu new title: 'Codec:'.
	codecs _ (SoundCodec allSubclasses collect: [:c | c name]) asSortedCollection.
	codecs add: 'None'.
	codecs do:[:cName | aMenu add: cName action: cName].
	newCodec _ aMenu startUp.
	newCodec ifNil: [^ self].
	self codecClassName: newCodec.
! !

!CodecDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/4/1999 12:19'!
wantsDroppedMorph: aMorph event: evt

	^ aMorph isMemberOf: SoundTile
! !
SystemWindow subclass: #CollapsedMorph
	instanceVariableNames: 'uncollapsedMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!CollapsedMorph methodsFor: 'as yet unclassified' stamp: 'sw 5/9/2000 00:18'!
beReplacementFor: aMorph

	| itsWorld priorPosition |
	(itsWorld _ aMorph world) ifNil: [^self].
	uncollapsedMorph _ aMorph.
			
	self setLabel: aMorph externalName.
	aMorph delete.
	itsWorld addMorphFront: self.
	self collapseOrExpand.
	(priorPosition _ aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil])
	ifNotNil:
		[self position: priorPosition].
! !

!CollapsedMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/1/2000 11:06'!
buildWindowMenu
	"Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title.  Specialized for CollapsedMorphs."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'change name...' action: #relabel.
	aMenu addLine.
	aMenu add: 'send to back' action: #sendToBack.
	aMenu add: 'make next-to-topmost' action: #makeSecondTopmost.
	aMenu addLine.
	self mustNotClose
		ifFalse:
			[aMenu add: 'make unclosable' action: #makeUnclosable]
		ifTrue:
			[aMenu add: 'make closable' action: #makeClosable].
	aMenu add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) 
		action: #toggleStickiness.
	^aMenu! !

!CollapsedMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/1/2000 11:07'!
collapseOrExpand
	"Toggle the expand/collapsd state of the receiver.  If expanding, copy the window title back to the name of the expanded morph"

	| aWorld |
	isCollapsed
		ifTrue: 
			[uncollapsedMorph setProperty: #collapsedPosition toValue: self position.
			labelString ifNotNil: [uncollapsedMorph setNameTo: labelString].
			mustNotClose _ false.	"We're not closing but expanding"
			self delete.
			(aWorld _ self currentWorld) addMorphFront: uncollapsedMorph.
			aWorld startSteppingSubmorphsOf: uncollapsedMorph]
		ifFalse:
			[super collapseOrExpand]! !
Object subclass: #Collection
	instanceVariableNames: ''
	classVariableNames: 'RandomForPicking '
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!Collection commentStamp: '<historical>' prior: 0!
I am the abstract superclass of all classes that represent a group of elements.!


!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'!
anyOne
	"Answer a representative sample of the receiver. This method can
	be helpful when needing to preinfer the nature of the contents of 
	semi-homogeneous collections."

	self emptyCheck.
	self do: [:each | ^ each]! !

!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:41'!
capacity
	"Answer the current capacity of the receiver."

	^ self size! !

!Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:34'!
size
	"Answer how many elements the receiver contains."

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


!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:34'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with another Collection, return a Collection of
	the results of each element combined with the scalar in that expression."

	rcvr isSequenceable & self isSequenceable ifFalse:
		[self error: 'Only sequenceable collections may be combined arithmetically'].
	^ rcvr with: self collect:
		[:rcvrElement :myElement | rcvrElement perform: selector with: myElement]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/9/1998 12:16'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a scalar, return a Collection of
	the results of each element combined with the scalar in that expression."

	^ self collect: [:element | rcvr perform: selector with: element]! !

!Collection methodsFor: 'adapting' stamp: 'di 11/6/1998 13:37'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !


!Collection methodsFor: 'adding'!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject. 
	ArrayedCollections cannot respond to this message."

	self subclassResponsibility! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:21'!
add: newObject withOccurrences: anInteger
	"Add newObject anInteger times to the receiver. Answer newObject."

	anInteger timesRepeat: [self add: newObject].
	^ newObject! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:26'!
addAll: aCollection 
	"Include all the elements of aCollection as the receiver's elements. Answer 
	aCollection. Actually, any object responding to #do: can be used as argument."

	aCollection do: [:each | self add: each].
	^ aCollection! !

!Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:23'!
addIfNotPresent: anObject
	"Include anObject as one of the receiver's elements, but only if there
	is no such element already. Anwser anObject."

	(self includes: anObject) ifFalse: [self add: anObject].
	^ anObject! !


!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
* arg

	^ arg adaptToCollection: self andSend: #*! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
+ arg

	^ arg adaptToCollection: self andSend: #+! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
- arg

	^ arg adaptToCollection: self andSend: #-! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:53'!
/ arg

	^ arg adaptToCollection: self andSend: #/! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
// arg

	^ arg adaptToCollection: self andSend: #//! !

!Collection methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
\\ arg

	^ arg adaptToCollection: self andSend: #\\! !


!Collection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:36'!
hash
	"Answer an integer hash value for the receiver such that,
	  -- the hash value of an unchanged object is constant over time, and
	  -- two equal objects have equal hash values"

	| hash |

	hash _ self species hash.
	self size <= 10 ifTrue:
		[self do: [:elem | hash _ hash bitXor: elem hash]].
	^hash bitXor: self size hash! !


!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'!
asArray
	"Answer an Array whose elements are the elements of the receiver.
	Implementation note: Cannot use ''Array withAll: self'' as that only
	works for SequenceableCollections which support the replacement 
	primitive."

	| array index |
	array _ Array new: self size.
	index _ 0.
	self do: [:each | array at: (index _ index + 1) put: each].
	^ array! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:10'!
asBag
	"Answer a Bag whose elements are the elements of the receiver."

	^ Bag withAll: self! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'!
asByteArray
	"Answer a ByteArray whose elements are the elements of the receiver.
	Implementation note: Cannot use ''ByteArray withAll: self'' as that only
	works for SequenceableCollections which support the replacement 
	primitive."

	| array index |
	array _ ByteArray new: self size.
	index _ 0.
	self do: [:each | array at: (index _ index + 1) put: each].
	^ array! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:26'!
asCharacterSet
	"Answer a CharacterSet whose elements are the unique elements of the receiver.
	The reciever should only contain characters."

	^ CharacterSet newFrom: self! !

!Collection methodsFor: 'converting' stamp: 'ar 9/22/2000 10:12'!
asIdentitySet
	^(IdentitySet new: self size) addAll: self; yourself! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:43'!
asOrderedCollection
	"Answer an OrderedCollection whose elements are the elements of the
	receiver. The order in which elements are added depends on the order
	in which the receiver enumerates its elements. In the case of unordered
	collections, the ordering is not necessarily the same for multiple 
	requests for the conversion."

	^ self as: OrderedCollection! !

!Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:29'!
asSet
	"Answer a Set whose elements are the unique elements of the receiver."

	^ Set withAll: self! !

!Collection methodsFor: 'converting'!
asSortedArray
	"Return a copy of the receiver in sorted order, as an Array.  6/10/96 sw"

	^ self asSortedCollection asArray! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:44'!
asSortedCollection
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is the default less than or equal."

	^ self as: SortedCollection! !

!Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:46'!
asSortedCollection: aSortBlock 
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aSortBlock."

	| aSortedCollection |
	aSortedCollection _ SortedCollection new: self size.
	aSortedCollection sortBlock: aSortBlock.
	aSortedCollection addAll: self.
	^ aSortedCollection! !


!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:41'!
copyWith: newElement
	"Answer a new collection with newElement added (as last
	element if sequenceable)."

	^ self copy
		add: newElement;
		yourself! !

!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:43'!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."

	^ self reject: [:each | each = oldElement]

"Examples:
	'fred the bear' copyWithout: $e
	#(2 3 4 5 5 6) copyWithout: 5
"! !

!Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 18:08'!
copyWithoutAll: aCollection
	"Answer a copy of the receiver that does not contain any elements 
	equal to those in aCollection."

	^ self reject: [:each | aCollection includes: each]! !


!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'!
allSatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns false for any element return false.
	Otherwise return true."

	self do: [:each | (aBlock value: each) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'!
anySatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns true for any element return true.
	Otherwise return false."

	self do: [:each | (aBlock value: each) ifTrue: [^ true]].
	^ false! !

!Collection methodsFor: 'enumerating'!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations).  If any non-association is within, the error is not caught now,
	but later, when a key or value message is sent to it."

	self do: aBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:45'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newCollection |
	newCollection _ self species new.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:51'!
collect: collectBlock thenSelect: selectBlock
	"Utility method to improve readability."

	^ (self collect: collectBlock) select: selectBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'!
count: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the number of elements that answered true."

	| sum |
	sum _ 0.
	self do: [:each | (aBlock value: each) ifTrue: [sum _ sum + 1]].
	^ sum! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:20'!
detect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the first element for which aBlock evaluates to true."

	^ self detect: aBlock ifNone: [self errorNotFound: aBlock]! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'!
detect: aBlock ifNone: exceptionBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Answer the first element for which aBlock evaluates to true. If none  
	evaluate to true, then evaluate the argument, exceptionBlock."

	self do: [:each | (aBlock value: each) ifTrue: [^ each]].
	^ exceptionBlock value! !

!Collection methodsFor: 'enumerating'!
detectMax: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the highest magnitude.
	If collection empty, return nil.  This method might also be called elect:."

	| maxElement maxValue val |
	self do: [:each | 
		maxValue == nil
			ifFalse: [
				(val _ aBlock value: each) > maxValue ifTrue: [
					maxElement _ each.
					maxValue _ val]]
			ifTrue: ["first element"
				maxElement _ each.
				maxValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ maxElement! !

!Collection methodsFor: 'enumerating'!
detectMin: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the lowest number.
	If collection empty, return nil."

	| minElement minValue val |
	self do: [:each | 
		minValue == nil
			ifFalse: [
				(val _ aBlock value: each) < minValue ifTrue: [
					minElement _ each.
					minValue _ val]]
			ifTrue: ["first element"
				minElement _ each.
				minValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ minElement! !

!Collection methodsFor: 'enumerating'!
detectSum: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Return the sum of the answers."
	| sum |
	sum _ 0.
	self do: [:each | 
		sum _ (aBlock value: each) + sum].  
	^ sum! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'!
difference: aCollection
	"Answer the set theoretic difference of two collections."

	^ self reject: [:each | aCollection includes: each]! !

!Collection methodsFor: 'enumerating'!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	self subclassResponsibility! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:57'!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	| beforeFirst | 
	beforeFirst _ true.
	self do:
		[:each |
		beforeFirst
			ifTrue: [beforeFirst _ false]
			ifFalse: [separatorBlock value].
		elementBlock value: each]! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'!
do: aBlock without: anItem 
	"Enumerate all elements in the receiver. 
	Execute aBlock for those elements that are not equal to the given item"

	^ self do: [:each | anItem = each ifFalse: [aBlock value: each]]! !

!Collection methodsFor: 'enumerating' stamp: 'dvf 6/10/2000 18:32'!
groupBy: keyBlock having: selectBlock 
	"Like in SQL operation - Split the recievers contents into collections of 
	elements for which keyBlock returns the same results, and return those 
	collections allowed by selectBlock. keyBlock should return an Integer."
	| result key |
	result _ PluggableDictionary integerDictionary.
	self do: 
		[:e | 
		key _ keyBlock value: e.
		(result includesKey: key)
			ifFalse: [result at: key put: OrderedCollection new].
		(result at: key)
			add: e].
	^ result _ result select: selectBlock! !

!Collection methodsFor: 'enumerating'!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:52'!
intersection: aCollection
	"Answer the set theoretic intersection of two collections."

	^ self select: [:each | aCollection includes: each]! !

!Collection methodsFor: 'enumerating' stamp: 'bf 3/10/2000 08:51'!
noneSatisfy: aBlock
	"Evaluate aBlock with the elements of the receiver.
	If aBlock returns false for all elements return true.
	Otherwise return false"

	self do: [:item | (aBlock value: item) ifTrue: [^ false]].
	^ false! !

!Collection methodsFor: 'enumerating'!
reject: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new collection like the receiver only those elements for 
	which aBlock evaluates to false. Answer the new collection."

	^self select: [:element | (aBlock value: element) == false]! !

!Collection methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new collection like the receiver, only those elements for 
	which aBlock evaluates to true. Answer the new collection."

	| newCollection |
	newCollection _ self species new.
	self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
	^newCollection! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:59'!
select: selectBlock thenCollect: collectBlock
	"Utility method to improve readability."

	^ (self select: selectBlock) collect: collectBlock! !

!Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 17:54'!
union: aCollection
	"Answer the set theoretic union of two collections."

	^ self asSet addAll: aCollection; yourself! !


!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'!
contents
	^ self! !

!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:08'!
flattenOnStream: aStream 
	^ aStream writeCollection: self! !

!Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'!
write: anObject 
	^ self add: anObject! !


!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
abs
	"Absolute value of all elements in the collection"
	^ self collect: [:a | a abs]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:57'!
average
	^ self sum / self size! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
ceiling
	^ self collect: [:a | a ceiling]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:51'!
floor
	^ self collect: [:a | a floor]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'!
log
	^ self collect: [:each | each log]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:58'!
max
	^ self inject: self anyOne into: [:max :each | max max: each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
median
	^ self asSortedCollection median! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
min
	^ self inject: self anyOne into: [:min :each | min min: each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:52'!
negated
	"Negated value of all elements in the collection"
	^ self collect: [:a | a negated]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'!
range
	^ self max - self min! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
reciprocal
	"Return the reciever full of reciprocated elements"
	^ self collect: [:a | a reciprocal]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
rounded
	^ self collect: [:a | a rounded]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
sqrt
	^ self collect: [:each | each sqrt]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:53'!
squared
	^ self collect: [:each | each * each]! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:02'!
sum
	"This is implemented using a variant of the normal inject:into: pattern. 
	The reason for this is that it is not known whether we're in the normal 
	number line, i.e. whether 0 is a good initial value for the sum. 
	Consider a collection of measurement objects, 0 would be the unitless 
	value and would not be appropriate to add with the unit-ed objects."
	| sum sample |
	sample _ self anyOne.
	sum _ self inject: sample into: [:accum :each | accum + each].
	^ sum - sample! !

!Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 15:54'!
truncated
	^ self collect: [:a | a truncated]! !


!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:39'!
printElementsOn: aStream
	aStream nextPut: $(.
	self do: [:element | aStream print: element; space].
	self isEmpty ifFalse: [aStream skip: -1].
	aStream nextPut: $)! !

!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'!
printNameOn: aStream
	super printOn: aStream! !

!Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'!
printOn: aStream 
	"Append a sequence of characters that identify the receiver to aStream."

	self printNameOn: aStream.
	self printElementsOn: aStream! !

!Collection methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self do: 
		[:each | 
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' add: '.
		aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!Collection methodsFor: 'private'!
emptyCheck

	self isEmpty ifTrue: [self errorEmptyCollection]! !

!Collection methodsFor: 'private'!
errorEmptyCollection

	self error: 'this collection is empty'! !

!Collection methodsFor: 'private'!
errorNoMatch

	self error: 'collection sizes do not match'! !

!Collection methodsFor: 'private' stamp: 'sma 5/12/2000 11:22'!
errorNotFound: anObject
	"Actually, this should raise a special Exception not just an error."

	self error: 'Object is not in the collection.'! !

!Collection methodsFor: 'private'!
errorNotKeyed

	self error: self class name, 's do not respond to keyed accessing messages.'! !

!Collection methodsFor: 'private'!
toBraceStack: itsSize 
	"Push receiver's elements onto the stack of thisContext sender.  Error if receiver does
	 not have itsSize elements or if receiver is unordered.
	 Do not call directly: this is called by {a. b} _ ... constructs."

	self size ~= itsSize ifTrue:
		[self error: 'Trying to store ', self size printString,
					' values into ', itsSize printString, ' variables.'].
	thisContext sender push: itsSize fromIndexable: self! !


!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:22'!
remove: oldObject 
	"Remove oldObject from the receiver's elements. Answer oldObject 
	unless no element is equal to oldObject, in which case, raise an error.
	ArrayedCollections cannot respond to this message."

	^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'!
remove: oldObject ifAbsent: anExceptionBlock 
	"Remove oldObject from the receiver's elements. If several of the 
	elements are equal to oldObject, only one is removed. If no element is 
	equal to oldObject, answer the result of evaluating anExceptionBlock. 
	Otherwise, answer the argument, oldObject. ArrayedCollections cannot 
	respond to this message."

	self subclassResponsibility! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'!
removeAll: aCollection 
	"Remove each element of aCollection from the receiver. If successful for 
	each, answer aCollection. Otherwise create an error notification.
	ArrayedCollections cannot respond to this message."

	aCollection do: [:each | self remove: each].
	^ aCollection! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:16'!
removeAllFoundIn: aCollection 
	"Remove each element of aCollection which is present in the receiver 
	from the receiver. Answer aCollection. No error is raised if an element
	isn't found. ArrayedCollections cannot respond to this message."

	aCollection do: [:each | self remove: each ifAbsent: []].
	^ aCollection! !

!Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:19'!
removeAllSuchThat: aBlock 
	"Evaluate aBlock for each element and remove all that elements from
	the receiver for that aBlock evaluates to true.  Use a copy to enumerate 
	collections whose order changes when an element is removed (i.e. Sets)."

	self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! !


!Collection methodsFor: 'testing' stamp: 'ls 3/27/2000 17:25'!
identityIncludes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	self do: [:each | anObject == each ifTrue: [^true]].
	^false! !

!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:07'!
includes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	^ self anySatisfy: [:each | each = anObject]! !

!Collection methodsFor: 'testing'!
includesAllOf: aCollection 
	"Answer whether all the elements of aCollection are in the receiver."
	aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
	^ true! !

!Collection methodsFor: 'testing'!
includesAnyOf: aCollection 
	"Answer whether any element of aCollection is one of the receiver's elements."
	aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]].
	^ false! !

!Collection methodsFor: 'testing' stamp: 'sw 8/12/97 20:59'!
includesSubstringAnywhere: testString
	"Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring"
	self do:
		[:element |
			(element isKindOf: String)
				ifTrue:
					[(element includesSubString: testString) ifTrue: [^ true]].
			(element isKindOf: Collection)
				ifTrue:
					[(element includesSubstringAnywhere: testString) ifTrue: [^ true]]].
	^ false

"#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere:  'lvi'"! !

!Collection methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'!
isCollection
	"Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:"
	^true! !

!Collection methodsFor: 'testing'!
isEmpty
	"Answer whether the receiver contains any elements."

	^self size = 0! !

!Collection methodsFor: 'testing' stamp: 'bf 3/10/2000 09:29'!
isEmptyOrNil
	"Answer whether the receiver contains any elements, or is nil.  Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"

	^ self isEmpty! !

!Collection methodsFor: 'testing' stamp: 'di 11/6/1998 09:16'!
isSequenceable
	^ false! !

!Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 17:49'!
notEmpty
	"Answer whether the receiver contains any elements."

	^ self isEmpty not! !

!Collection methodsFor: 'testing'!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| tally |
	tally _ 0.
	self do: [:each | anObject = each ifTrue: [tally _ tally + 1]].
	^tally! !

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

Collection class
	instanceVariableNames: ''!

!Collection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:05'!
ofSize: n
	"Create a new collection of size n with nil as its elements.
	This method exists because OrderedCollection new: n creates an
	empty collection,  not one of size n."
	^ self new: n! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 19:58'!
with: anObject 
	"Answer an instance of me containing anObject."

	^ self new
		add: anObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:01'!
with: firstObject with: secondObject 
	"Answer an instance of me containing the two arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:03'!
with: firstObject with: secondObject with: thirdObject 
	"Answer an instance of me containing the three arguments as elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer an instance of me, containing the four arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer an instance of me, containing the five arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject
	"Answer an instance of me, containing the six arguments as the elements."

	^ self new
		add: firstObject;
		add: secondObject;
		add: thirdObject;
		add: fourthObject;
		add: fifthObject;
		add: sixthObject;
		yourself! !

!Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:07'!
withAll: aCollection
	"Create a new collection containing all the elements from aCollection."

	^ (self new: aCollection size)
		addAll: aCollection;
		yourself! !


!Collection class methodsFor: 'private' stamp: 'sma 3/3/2000 10:45'!
initialize
	"Set up a Random number generator to be used by atRandom when the 
	user does not feel like creating his own Random generator."

	RandomForPicking _ Random new! !

!Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'!
randomForPicking
	^ RandomForPicking! !
Object subclass: #Color
	instanceVariableNames: 'rgb cachedDepth cachedBitPattern '
	classVariableNames: 'Black Blue BlueShift Brown CachedColormaps ColorChart ColorNames ComponentMask ComponentMax Cyan DarkGray Gray GrayToIndexMap Green GreenShift HalfComponentMask HighLightBitmaps IndexedColors LightBlue LightBrown LightCyan LightGray LightGreen LightMagenta LightOrange LightRed LightYellow Magenta MaskingMap Orange PaleBlue PaleBuff PaleGreen PaleMagenta PaleOrange PalePeach PaleRed PaleTan PaleYellow PureBlue PureCyan PureGreen PureMagenta PureRed PureYellow RandomStream Red RedShift TranslucentPatterns Transparent VeryDarkGray VeryLightGray VeryPaleRed VeryVeryDarkGray VeryVeryLightGray White Yellow '
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Color commentStamp: '<historical>' prior: 0!
This class represents abstract color, regardless of the depth of bitmap it will be shown in.  At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with.  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.  (See comment in BitBlt.)  To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8).  (See comment in DisplayMedium)
	Color is represented as the amount of light in red, green, and blue.  White is (1.0, 1.0, 1.0) and black is (0, 0, 0).  Pure red is (1.0, 0, 0).  These colors are "additive".  Think of Color's instance variables as:
	r	amount of red, a Float between 0.0 and 1.0.
	g	amount of green, a Float between 0.0 and 1.0.
	b	amount of blue, a Float between 0.0 and 1.0.
(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb.  The user does not need to know this.)
	Many colors are named.  You find a color by name by sending a message to class Color, for example (Color lightBlue).  Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below)
	A color is essentially immutable.  Once you set red, green, and blue, you cannot change them.  Instead, create a new Color and use it.
	Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number.  Convert the range of this number to an integer from 1 to N.  Then call (Color green lightShades: N) to get an Array of colors from white to green.  Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array.  atPin: gives the first (or last) color if the index is out of range.  atWrap: wraps around to the other end if the index is out of range.
	Here are some fun things to run in when your screen has color:
		Pen new mandala: 30 diameter: Display height-100.
		Pen new web  "Draw with the mouse, opt-click to end"
		Display fillWhite.  Pen new hilberts: 5.
		Form toothpaste: 30  "Draw with mouse, opt-click to end"
You might also want to try the comment in
	Form>class>examples>tinyText...


Messages:
	mixed: proportion with: aColor	Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix.

	+ 	add two colors
	- 	subtract two colors
	*	multiply the values of r, g, b by a number or an Array of factors.  ((Color named: #white) * 0.3) gives a darkish gray.  (aColor * #(0 0 0.9)) gives a color with slightly less blue.
	/	divide a color by a factor or an array of three factors.

	errorForDepth: d     How close the nearest color at this depth is to this abstract color.  Sum of the squares of the RGB differences, square rooted and normalized to 1.0.  Multiply by 100 to get percent.

	hue			Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360.
	saturation	Returns the saturation of the color.  0.0 to 1.0
	brightness	Returns the brightness of the color.  0.0 to 1.0

	name    Look to see if this Color has a name.
	display	Show a swatch of this color tracking the cursor.

	lightShades: thisMany		An array of thisMany colors from white to the receiver. 
	darkShades: thisMany		An array of thisMany colors from black to the receiver.  Array is of length num.
	mix: color2 shades: thisMany		An array of thisMany colors from the receiver to color2.
	wheel: thisMany			An array of thisMany colors around the color wheel starting and ending at the receiver.

	pixelValueForDepth: d    Returns the bits that appear be in a Bitmap of this depth for this color.  Represents the nearest available color at this depth.  Normal users do not need to know which pixelValue is used for which color. 

Messages to Class Color.
	red: r green: g blue: b		Return a color with the given r, g, and b components.
	r: g: b:		Same as above, for fast typing.

 	hue: h saturation: s brightness: b		Create a color with the given hue, saturation, and brightness.

	pink
 	blue
	red ...	Many colors have messages that return an instance of Color.
	canUnderstand: #brown	  Returns true if #brown is a defined color.
	names		An OrderedCollection of the names of the colors.
	named: #notAllThatGray put: aColor    Add a new color to the list and create an access message and a class variable for it.
	fromUser	Shows the palette of colors available at this display depth.  Click anywhere to return the color you clicked on.

	hotColdShades: thisMany	An array of thisMany colors showing temperature from blue to red to white hot.

    stdColorsForDepth: d        An Array of colors available at this depth.  For 16 bit and 32 bits, returns a ColorGenerator.  It responds to at: with a Color for that index, simulating a very big Array. 

   colorFromPixelValue: value depth: d    Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified.  Normal users do not need to use this.

(See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)!


!Color methodsFor: 'access'!
alpha
	"Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors."

	^ 1.0
! !

!Color methodsFor: 'access'!
blue
	"Return the blue component of this color, a float in the range [0.0..1.0]."

	^ self privateBlue asFloat / ComponentMax! !

!Color methodsFor: 'access'!
brightness
	"Return the brightness of this color, a float in the range [0.0..1.0]."

	^ ((self privateRed max:
	    self privateGreen) max:
	    self privateBlue) asFloat / ComponentMax! !

!Color methodsFor: 'access'!
green
	"Return the green component of this color, a float in the range [0.0..1.0]."

	^ self privateGreen asFloat / ComponentMax! !

!Color methodsFor: 'access'!
hue
	"Return the hue of this color, an angle in the range [0.0..360.0]."

	| r g b max min span h |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ ((r max: g) max: b).
	min _ ((r min: g) min: b).
	span _ (max - min) asFloat.
	span = 0.0 ifTrue: [ ^ 0.0 ].

	r = max ifTrue: [
		h _ ((g - b) asFloat / span) * 60.0.
	] ifFalse: [
		g = max
			ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ]
			ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ].
	].

	h < 0.0 ifTrue: [ h _ 360.0 + h ].
	^ h! !

!Color methodsFor: 'access'!
luminance
	"Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity."

	^ ((299 * self privateRed) +
	   (587 * self privateGreen) +
	   (114 * self privateBlue)) / (1000 * ComponentMax)
! !

!Color methodsFor: 'access'!
red
	"Return the red component of this color, a float in the range [0.0..1.0]."

	^ self privateRed asFloat / ComponentMax! !

!Color methodsFor: 'access'!
saturation
	"Return the saturation of this color, a value between 0.0 and 1.0."

	| r g b max min |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ min _ r.
	g > max ifTrue: [max _ g].
	b > max ifTrue: [max _ b].
	g < min ifTrue: [min _ g].
	b < min ifTrue: [min _ b].

	max = 0
		ifTrue: [ ^ 0.0 ]
		ifFalse: [ ^ (max - min) asFloat / max asFloat ].
! !


!Color methodsFor: 'equality' stamp: 'di 1/6/1999 20:26'!
= aColor
	"Return true if the receiver equals the given color. This method handles TranslucentColors, too."

	aColor isColor ifFalse: [^ false].
	^ aColor privateRGB = rgb and:
		[aColor privateAlpha = self privateAlpha]
! !

!Color methodsFor: 'equality' stamp: 'di 9/27/2000 08:07'!
diff: theOther
	"Returns a number between 0.0 and 1.0"

	^ ((self privateRed - theOther privateRed) abs
		+ (self privateGreen - theOther privateGreen) abs
		+ (self privateBlue - theOther privateBlue) abs)
		/ 3.0 / ComponentMax! !

!Color methodsFor: 'equality'!
hash

	^ rgb! !


!Color methodsFor: 'queries' stamp: 'sw 4/25/1998 12:51'!
basicType
	^ #color! !

!Color methodsFor: 'queries' stamp: 'ar 1/14/1999 15:27'!
isBitmapFill
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:43'!
isBlack
	"Return true if the receiver represents black"
	^rgb = 0! !

!Color methodsFor: 'queries'!
isColor

	^ true
! !

!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 06:58'!
isGradientFill
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:44'!
isGray
	"Return true if the receiver represents a shade of gray"
	^(self privateRed = self privateGreen) and:[self privateRed = self privateBlue]! !

!Color methodsFor: 'queries' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!Color methodsFor: 'queries' stamp: 'ar 11/7/1998 20:20'!
isSolidFill
	^true! !

!Color methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTranslucent

	^ false
! !

!Color methodsFor: 'queries' stamp: 'di 1/3/1999 12:23'!
isTranslucentColor
	"This means: self isTranslucent, but isTransparent not"
	^ false! !

!Color methodsFor: 'queries'!
isTransparent

	^ false
! !


!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
* aNumber
	"Answer this color with its RGB multiplied by the given number. "
	"(Color brown * 2) display"

	^ Color basicNew
		setPrivateRed: (self privateRed * aNumber) asInteger
		green: (self privateGreen * aNumber) asInteger
		blue: (self privateBlue * aNumber) asInteger
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
+ aColor
	"Answer this color mixed with the given color in an additive color space.  "
	"(Color blue + Color green) display"

	^ Color basicNew
		setPrivateRed: self privateRed + aColor privateRed
		green: self privateGreen + aColor privateGreen
		blue: self privateBlue + aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
- aColor
	"Answer aColor is subtracted from the given color in an additive color space.  "
	"(Color white - Color red) display"

	^ Color basicNew
		setPrivateRed: self privateRed - aColor privateRed
		green: self privateGreen - aColor privateGreen
		blue: self privateBlue - aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'!
/ aNumber
	"Answer this color with its RGB divided by the given number. "
	"(Color red / 2) display"

	^ Color basicNew
		setPrivateRed: (self privateRed / aNumber) asInteger
		green: (self privateGreen / aNumber) asInteger
		blue: (self privateBlue / aNumber) asInteger
! !

!Color methodsFor: 'transformations' stamp: 'sma 6/25/2000 15:36'!
alpha: alphaValue 
	"Answer a new Color with the given amount of opacity ('alpha')."

	alphaValue = 1.0
		ifFalse: [^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue]! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 11:55'!
alphaMixed: proportion with: aColor 
	"Answer this color mixed with the given color. The proportion, a number 
	between 0.0 and 1.0, determines what what fraction of the receiver to  
	use in the mix. For example, 0.9 would yield a color close to the  
	receiver. This method uses RGB interpolation; HSV interpolation can lead 
	to surprises.  Mixes the alphas (for transparency) also."

	| frac1 frac2 |
	frac1 _ proportion asFloat min: 1.0 max: 0.0.
	frac2 _ 1.0 - frac1.
	^ Color
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)
		alpha: self alpha * frac1 + (aColor alpha * frac2)! !

!Color methodsFor: 'transformations' stamp: 'RAA 6/2/2000 08:47'!
atLeastAsLuminentAs: aFloat

	| revisedColor |
	revisedColor _ self.
	[revisedColor luminance < aFloat] whileTrue: [revisedColor _ revisedColor slightlyLighter].
	^revisedColor
! !

!Color methodsFor: 'transformations' stamp: 'di 5/15/1998 21:54'!
dansDarker
	"Return a darker shade of the same color.
	An attempt to do better than the current darker method."
	^ Color h: self hue s: self saturation
		v: (self brightness - 0.16 max: 0.0)! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
darker
	"Answer a darker shade of this color."

	^ self alphaMixed: 0.8333 with: Color black
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
lighter
	"Answer a lighter shade of this color."

	^ self alphaMixed: 0.8333 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:00'!
mixed: proportion with: aColor 
	"Mix with another color and do not preserve transpareny.  Only use this for extracting the RGB value and mixing it.  All other callers should use instead: 
	aColor alphaMixed: proportion with: anotherColor
	"

	| frac1 frac2 |
	frac1 _ proportion asFloat min: 1.0 max: 0.0.
	frac2 _ 1.0 - frac1.
	^ Color
		r: self red * frac1 + (aColor red * frac2)
		g: self green * frac1 + (aColor green * frac2)
		b: self blue * frac1 + (aColor blue * frac2)! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
muchLighter

	^ self alphaMixed: 0.233 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'!
negated
	"Return an RGB inverted color"
	^Color
		r: 1.0 - self red
		g: 1.0 - self green
		b: 1.0 - self blue! !

!Color methodsFor: 'transformations' stamp: 'di 9/27/2000 08:14'!
orColorUnlike: theOther
	"If this color is a lot like theOther, then return its complement, otherwide, return self"

	(self diff: theOther) < 0.3
		ifTrue: [^ theOther negated]
		ifFalse: [^ self]! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
slightlyDarker
	"Answer a slightly darker shade of this color."

	^ self alphaMixed: 0.93 with: Color black
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
slightlyLighter
	"Answer a slightly lighter shade of this color."

	^ self alphaMixed: 0.93 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
twiceDarker
	"Answer a significantly darker shade of this color."

	^ self alphaMixed: 0.5 with: Color black
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
twiceLighter
	"Answer a significantly lighter shade of this color."

	^ self alphaMixed: 0.5 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'!
veryMuchLighter

	^ self alphaMixed: 0.1165 with: Color white
! !


!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
darkShades: thisMany
	"An array of thisMany colors from black to the receiver.  Array is of length num. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red darkShades: 12)"

	^ self class black mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
lightShades: thisMany
	"An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red lightShades: 12)"

	^ self class white mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
mix: color2 shades: thisMany
	"Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program.  "
	"Color showColors: (Color red mix: Color green shades: 12)"

	| redInc greenInc blueInc rr gg bb c out |
	thisMany = 1 ifTrue: [^ Array with: color2].
	redInc _ color2 red - self red / (thisMany-1).
	greenInc _ color2 green - self green / (thisMany-1).
	blueInc _ color2 blue - self blue / (thisMany-1).
	rr _ self red.  gg _ self green.  bb _ self blue.
	out _ (1 to: thisMany) collect: [:num |
		c _ Color r: rr g: gg b: bb.
		rr _ rr + redInc.
		gg _ gg + greenInc.
		bb _ bb + blueInc.
		c].
	out at: out size put: color2.	"hide roundoff errors"
	^ out
! !

!Color methodsFor: 'groups of shades' stamp: 'di 10/23/2000 09:45'!
wheel: thisMany
	"An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self.  Array is of length thisMany.  Very useful for displaying color based on a variable in your program.  "

	| sat bri hue step c |
	sat _ self saturation.
	bri _ self brightness.
	hue _ self hue.
	step _ 360.0 / (thisMany max: 1).
	^ (1 to: thisMany) collect: [:num |
		c _ Color h: hue s: sat v: bri.  "hue is taken mod 360"
		hue _ hue + step.
		c].
"
(Color wheel: 8) withIndexDo: [:c :i | Display fill: (i*10@20 extent: 10@20) fillColor: c]
"! !


!Color methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:14'!
byteEncode: aStream

	aStream
		print: '(';
		print: self class name;
		print: ' r: ';
		write: (self red roundTo: 0.001);
		print: ' g: ';
		write: (self green roundTo: 0.001);
		print: ' b: ';
		write: (self blue roundTo: 0.001) ;
		print: ')'.
! !

!Color methodsFor: 'printing' stamp: 'RAA 7/31/2000 17:25'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 4 count:  1.
	(encoded := String new: 12)
		putInteger32: (rgb bitAnd: 16rFFFF) at: 1;
		putInteger32: (rgb >> 16) at: 5;
		putInteger32: self privateAlpha at: 9.
	^encoded! !

!Color methodsFor: 'printing'!
encodePostscriptOn: aStream

	aStream setrgbcolor:self.

! !

!Color methodsFor: 'printing' stamp: 'bf 5/25/2000 16:52'!
printOn: aStream
	| name |
	(name _ self name) ifNotNil:
		[^ aStream
			nextPutAll: 'Color ';
			nextPutAll: name].
	self storeOn: aStream.
! !

!Color methodsFor: 'printing'!
shortPrintString
	"Return a short (but less precise) print string for use where space is tight."

	| s |
	s _ WriteStream on: ''.
	s
		nextPutAll: '(' , self class name;
		nextPutAll: ' r: ';
		nextPutAll: (self red roundTo: 0.01) printString;
		nextPutAll: ' g: ';
		nextPutAll: (self green roundTo: 0.01) printString;
		nextPutAll: ' b: ';
		nextPutAll: (self blue roundTo: 0.01) printString;
		nextPutAll: ')'.
	^ s contents
! !

!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'!
storeArrayOn: aStream

	aStream nextPutAll: '#('.
	self storeArrayValuesOn: aStream.
	aStream nextPutAll: ') '
! !

!Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'!
storeArrayValuesOn: aStream

	(self red roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self green roundTo: 0.001) storeOn: aStream.
	aStream space.
	(self blue roundTo: 0.001) storeOn: aStream.

! !

!Color methodsFor: 'printing' stamp: 'di 9/27/2000 13:34'!
storeOn: aStream

	aStream
		nextPutAll: '(' , self class name;
		nextPutAll: ' r: '; print: (self red roundTo: 0.001);
		nextPutAll: ' g: '; print: (self green roundTo: 0.001);
		nextPutAll: ' b: '; print: (self blue roundTo: 0.001);
		nextPutAll: ')'.
! !


!Color methodsFor: 'other' stamp: 'sw 2/16/98 03:42'!
colorForInsets
	^ self! !

!Color methodsFor: 'other' stamp: 'tk 6/14/96'!
display
	"Show a swatch of this color tracking the cursor until the next mouseClick. "
	"Color red display"
	| f |
	f _ Form extent: 40@20 depth: Display depth.
	f fillColor: self.
	Cursor blank showWhile:
		[f follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:24'!
name
	"Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color."

	ColorNames do:
		[:name | (Color perform: name) = self ifTrue: [^ name]].
	^ nil
! !

!Color methodsFor: 'other' stamp: 'sw 6/10/1998 17:50'!
newTileMorphRepresentative
	^ ColorTileMorph new colorSwatchColor: self! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'!
rgbTriplet
	"Color fromUser rgbTriplet"

	^ Array
		with: (self red roundTo: 0.01)
		with: (self green roundTo: 0.01)
		with: (self blue roundTo: 0.01)
! !


!Color methodsFor: 'conversions' stamp: 'ar 2/5/1999 19:30'!
asB3DColor
	"Convert the receiver into a color"
	^B3DColor4 new loadFrom: self! !

!Color methodsFor: 'conversions' stamp: 'ar 11/2/1998 12:19'!
asColor
	"Convert the receiver into a color"
	^self! !

!Color methodsFor: 'conversions' stamp: 'TBn 6/15/2000 20:37'!
asColorref
	"Convert the receiver into a colorref"
	^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self green * 255) asInteger << 16)! !

!Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'!
asNontranslucentColor
	^ self! !

!Color methodsFor: 'conversions' stamp: 'di 3/25/2000 10:13'!
balancedPatternForDepth: depth
	"A generalization of bitPatternForDepth: as it exists.  Generates a 2x2 stipple of color.
	The topLeft and bottomRight pixel are closest approx to this color"
	| pv1 pv2 mask1 mask2 pv3 c |
	(depth == cachedDepth and:[cachedBitPattern size = 2]) ifTrue: [^ cachedBitPattern].
	(depth between: 4 and: 16) ifFalse: [^ self bitPatternForDepth: depth].
	cachedDepth _ depth.
	pv1 _ self pixelValueForDepth: depth.
"
	Subtract error due to pv1 to get pv2.
	pv2 _ (self - (err1 _ (Color colorFromPixelValue: pv1 depth: depth) - self))
						pixelValueForDepth: depth.
	Subtract error due to 2 pv1's and pv2 to get pv3.
	pv3 _ (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self))
						pixelValueForDepth: depth.
"
	"Above two statements computed faster by the following..."
	pv2 _ (c _ self - ((Color colorFromPixelValue: pv1 depth: depth) - self))
						pixelValueForDepth: depth.
	pv3 _ (c + (c - (Color colorFromPixelValue: pv2 depth: depth)))
						pixelValueForDepth: depth.

	"Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues."
	mask1 _ (#(- - -	
			16r01010101 - - -			"replicates every other 4 bits"
			16r00010001 - - - - - - -	"replicates every other 8 bits"
			16r00000001) at: depth).	"replicates every other 16 bits"
	mask2 _ (#(- - -	
			16r10101010 - - -			"replicates the other 4 bits"
			16r01000100 - - - - - - -	"replicates the other 8 bits"
			16r00010000) at: depth).	"replicates the other 16 bits"
	^ cachedBitPattern _ Bitmap with: (mask1*pv1) + (mask2*pv2) with: (mask1*pv3) + (mask2*pv1)! !

!Color methodsFor: 'conversions' stamp: 'hmm 4/25/2000 09:40'!
bitPatternForDepth: depth
	"Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines.  "
	"See also:	pixelValueAtDepth:	-- value for single pixel
				pixelWordAtDepth:	-- a 32-bit word filled with the pixel value"
	"Details: The pattern for the most recently requested depth is cached."
	"Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned"

	(depth == cachedDepth and: [depth <= 2 or: [cachedBitPattern size = 1]]) ifTrue: [^ cachedBitPattern].
	cachedDepth _ depth.

	depth > 2 ifTrue: [^ cachedBitPattern _ Bitmap with: (self pixelWordForDepth: depth)].
	depth = 1 ifTrue: [^ cachedBitPattern _ self halfTonePattern1].
	depth = 2 ifTrue: [^ cachedBitPattern _ self halfTonePattern2].
! !

!Color methodsFor: 'conversions'!
closestPixelValue1
	"Return the nearest approximation to this color for a monochrome Form."

	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 0].  "white"

	self luminance > 0.5
		ifTrue: [^ 0]  "white"
		ifFalse: [^ 1].  "black"
! !

!Color methodsFor: 'conversions'!
closestPixelValue2
	"Return the nearest approximation to this color for a 2-bit deep Form."

	| lum |
	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

	lum _ self luminance.
	lum < 0.2 ifTrue: [^ 1].  "black"
	lum > 0.6 ifTrue: [^ 2].  "opaque white"
	^ 3  "50% gray"
! !

!Color methodsFor: 'conversions'!
closestPixelValue4
	"Return the nearest approximation to this color for a 4-bit deep Form."

	| bIndex |
	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

	rgb = PureRed privateRGB ifTrue: [^ 4].
	rgb = PureGreen privateRGB ifTrue: [^ 5].
	rgb = PureBlue privateRGB ifTrue: [^ 6].
	rgb = PureCyan privateRGB ifTrue: [^ 7].
	rgb = PureYellow privateRGB ifTrue: [^ 8].
	rgb = PureMagenta privateRGB ifTrue: [^ 9].

	bIndex _ (self luminance * 8.0) rounded.  "bIndex in [0..8]"
	^ #(
		1	"black"
		10	"1/8 gray"
		11	"2/8 gray"
		12	"3/8 gray"
		3	"4/8 gray"
		13	"5/8 gray"
		14	"6/8 gray"
		15	"7/8 gray"
		2	"opaque white"
	) at: bIndex + 1.
! !

!Color methodsFor: 'conversions'!
closestPixelValue8
	"Return the nearest approximation to this color for an 8-bit deep Form."

	"fast special cases"
	rgb = 0 ifTrue: [^ 1].  "black"
	rgb = 16r3FFFFFFF ifTrue: [^ 255].  "white"

	self saturation < 0.2 ifTrue: [
		^ GrayToIndexMap at: (self privateGreen >> 2) + 1.  "nearest gray"
	] ifFalse: [
		"compute nearest entry in the color cube"
		^ 40 +
		  ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) +
		  ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) +
		  (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)].
! !

!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'!
dominantColor
	^ self! !

!Color methodsFor: 'conversions' stamp: 'di 6/23/97 23:27'!
halfTonePattern1
	"Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms."

	| lum |
	lum _ self luminance.
	lum < 0.1 ifTrue: [^ Bitmap with: 16rFFFFFFFF]. "black"
	lum < 0.4 ifTrue: [^ Bitmap with: 16rBBBBBBBB with: 16rEEEEEEEE]. "dark gray"
	lum < 0.6 ifTrue: [^ Bitmap with: 16r55555555 with: 16rAAAAAAAA]. "medium gray"
	lum < 0.9 ifTrue: [^ Bitmap with: 16r44444444 with: 16r11111111]. "light gray"
	^ Bitmap with: 0  "1-bit white"
! !

!Color methodsFor: 'conversions'!
halfTonePattern2
	"Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms."

	| lum |
	lum _ self luminance.
	lum < 0.125 ifTrue: [^ Bitmap with: 16r55555555].  "black"
	lum < 0.25 ifTrue: [^ Bitmap with: 16r55555555 with: 16rDDDDDDDD].  "1/8 gray"
	lum < 0.375 ifTrue: [^ Bitmap with: 16rDDDDDDDD with: 16r77777777].  "2/8 gray"
	lum < 0.5 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16r77777777].  "3/8 gray"
	lum < 0.625 ifTrue: [^ Bitmap with: 16rFFFFFFFF].  "4/8 gray"
	lum < 0.75 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16rBBBBBBBB].  "5/8 gray"
	lum < 0.875 ifTrue: [^ Bitmap with: 16rEEEEEEEE with: 16rBBBBBBBB].  "6/8 gray"
	lum < 1.0 ifTrue: [^ Bitmap with: 16rAAAAAAAA with: 16rBBBBBBBB].  "7/8 gray"
	^ Bitmap with: 16rAAAAAAAA  "opaque white"

"handy expression for computing patterns for 2x2 tiles;
 set p to a string of 4 letters (e.g., 'wggw' for a gray-and-
 white checkerboard) and print the result of evaluating:
| p d w1 w2 |
p _ 'wggw'.
d _ Dictionary new.
d at: $b put: '01'.
d at: $w put: '10'.
d at: $g put: '11'.
w1 _ (d at: (p at: 1)), (d at: (p at: 2)).
w1 _ '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'.
w2 _ (d at: (p at: 3)), (d at: (p at: 4)).
w2 _ '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'.
Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2) 
"! !

!Color methodsFor: 'conversions' stamp: 'tk 4/24/97'!
indexInMap: aColorMap
	"Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap.  "

	aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1].
	aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1].
	aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1].
	aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1].
	aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1].
	aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1].
	aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1].
	self error: 'unknown pixel depth'.
! !

!Color methodsFor: 'conversions' stamp: 'bf 10/13/1999 14:22'!
makeForegroundColor
        "Make a foreground color contrasting with me"
        ^self luminance >= "Color red luminance" 0.299
                ifTrue: [Color black]
                ifFalse: [Color white]! !

!Color methodsFor: 'conversions' stamp: 'jm 6/2/1998 14:56'!
pixelValueForDepth: d
	"Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:"
	"Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component."
	"Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue."

	| rgbBlack val rgbBlack32 |
	d = 8 ifTrue: [^ self closestPixelValue8].  "common case"
	d < 8 ifTrue: [
		d = 4 ifTrue: [^ self closestPixelValue4].
		d = 2 ifTrue: [^ self closestPixelValue2].
		d = 1 ifTrue: [^ self closestPixelValue1]].

	rgbBlack _ 1.  "closest black that is not transparent in RGB"

	d = 16 ifTrue: [
		"five bits per component; top bits ignored"
		val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr:
			 ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr:
			 ((rgb bitShift: -5) bitAnd: 16r001F).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	d = 32 ifTrue: [
		rgbBlack32 _ 16rFF000001.  "closest black for 32-bit depth, with opaque alpha"
		"eight bits per component; top 8 bits set to all ones (opaque)"
		val _ (((rgb bitShift: -6) bitAnd: 16rFF0000) bitOr:
			 ((rgb bitShift: -4) bitAnd: 16r00FF00)) bitOr:
			 ((rgb bitShift: -2) bitAnd: 16r0000FF).
		^ val = 0 ifTrue: [rgbBlack32] ifFalse: [16rFF000000 + val]].

	d = 12 ifTrue: [  "for indexing a color map with 4 bits per color component"
		val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr:
			 ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr:
			 ((rgb bitShift: -6) bitAnd: 16r000F).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	d = 9 ifTrue: [  "for indexing a color map with 3 bits per color component"
		val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr:
			 ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr:
			 ((rgb bitShift: -7) bitAnd: 16r0007).
		^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

	self error: 'unknown pixel depth: ', d printString
! !

!Color methodsFor: 'conversions' stamp: 'di 11/30/1998 09:03'!
pixelWordFor: depth filledWith: pixelValue
	"Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."
	| halfword |
	depth = 32 ifTrue: [^ pixelValue].
	depth = 16
		ifTrue: [halfword _ pixelValue]
		ifFalse: [halfword _ pixelValue * 
					(#(16rFFFF				"replicates at every bit"
						16r5555 -			"replicates every 2 bits"
						16r1111 - - -			"replicates every 4 bits"
						16r0101) at: depth)	"replicates every 8 bits"].
	^ halfword bitOr: (halfword bitShift: 16)! !

!Color methodsFor: 'conversions'!
pixelWordForDepth: depth
	"Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."

	| pixelValue |
	pixelValue _ self pixelValueForDepth: depth.
	^ self pixelWordFor: depth filledWith: pixelValue
! !

!Color methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:28'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	^self pixelWordForDepth: 32! !


!Color methodsFor: 'private'!
attemptToMutateError
	"A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it."

	self error: 'Color objects are immutable once created'
! !

!Color methodsFor: 'private'!
flushCache
	"Flush my cached bit pattern."

	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
privateAlpha
	"Private!! Return the raw alpha value for opaque. Used only for equality testing."

	^ 255! !

!Color methodsFor: 'private'!
privateBlue
	"Private!! Return the internal representation of my blue component."

	^ rgb bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateGreen
	"Private!! Return the internal representation of my green component.
	Replaced >> by bitShift: 0 -. SqR!! 2/25/1999 23:08"

	^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateRGB
	"Private!! Return the internal representation of my RGB components."

	^ rgb
! !

!Color methodsFor: 'private'!
privateRed
	"Private!! Return the internal representation of my red component."

	^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
setHue: hue saturation: saturation brightness: brightness
	"Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."

	| s v hf i f p q t | 
	s _ (saturation asFloat max: 0.0) min: 1.0.
	v _ (brightness asFloat max: 0.0) min: 1.0.

	"zero saturation yields gray with the given brightness"
	s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ].

	hf _ hue asFloat.
	(hf < 0.0 or: [hf >= 360.0])
		ifTrue: [hf _ hf - ((hf quo: 360.0) asFloat * 360.0)].
	hf _ hf / 60.0.
	i _ hf asInteger.  "integer part of hue"
	f _ hf fractionPart.         "fractional part of hue"
	p _ (1.0 - s) * v.
	q _ (1.0 - (s * f)) * v.
	t _ (1.0 - (s * (1.0 - f))) * v.

	0 = i ifTrue: [ ^ self setRed: v green: t blue: p ].
	1 = i ifTrue: [ ^ self setRed: q green: v blue: p ].
	2 = i ifTrue: [ ^ self setRed: p green: v blue: t ].
	3 = i ifTrue: [ ^ self setRed: p green: q blue: v ].
	4 = i ifTrue: [ ^ self setRed: t green: p blue: v ].
	5 = i ifTrue: [ ^ self setRed: v green: p blue: q ].

	self error: 'implementation error'.
! !

!Color methodsFor: 'private' stamp: 'di 11/2/97 12:19'!
setPrivateRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ ((r min: ComponentMask max: 0) bitShift: RedShift) +
		((g min: ComponentMask max: 0) bitShift: GreenShift) +
		 (b min: ComponentMask max: 0).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private' stamp: 'ls 9/24/1999 20:04'!
setRGB: rgb0
	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ rgb0! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _
		(((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +
		(((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +
		 ((b * ComponentMax) rounded bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b range: range
	"Initialize this color's r, g, and b components to the given values in the range [0..r]."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _
		((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +
		((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +
		 (((b * ComponentMask) // range) bitAnd: ComponentMask).
	cachedDepth _ nil.
	cachedBitPattern _ nil.
! !


!Color methodsFor: 'copying' stamp: 'tk 8/19/1998 16:12'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Color methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 08:35'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change color...' target: self selector: #changeColorIn:event: argument: aMorph! !

!Color methodsFor: 'Morphic menu' stamp: 'ar 10/5/2000 18:50'!
changeColorIn: aMorph event: evt
	"Note: This is just a workaround to make sure we don't use the old color inst var"
	aMorph changeColorTarget: aMorph selector: #fillStyle: originalColor: self hand: evt hand! !

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

Color class
	instanceVariableNames: ''!

!Color class methodsFor: 'instance creation' stamp: 'sw 11/9/1998 19:25'!
colorFrom: parm
	"Return an instantiated color from parm.  If parm is already a color, return it, else return the result of my performing it if it's a symbol, else just return the thing"
	(parm isKindOf: Color) ifTrue: [^ parm].
	(parm isKindOf: Symbol) ifTrue: [^ self perform: parm].
	^ parm! !

!Color class methodsFor: 'instance creation' stamp: 'RAA 9/22/2000 15:19'!
colorFromPixelValue: p depth: d
	"Convert a pixel value for the given display depth into a color."
	"Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color."

	| r g b alpha |
	d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1].
	d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1].
	d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1].
	d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1].

	(d = 16) | (d = 15) ifTrue: [
		"five bits per component"
		r _ (p bitShift: -10) bitAnd: 16r1F.
		g _ (p bitShift: -5) bitAnd: 16r1F.
		b _ p bitAnd: 16r1F.
		(r = 0 and: [g = 0 and: [b = 0]])  ifTrue: [^Color transparent].
		^ Color r: r g: g b: b range: 31].

	d = 32 ifTrue: [
		"eight bits per component; 8 bits of alpha"
		r _ (p bitShift: -16) bitAnd: 16rFF.
		g _ (p bitShift: -8) bitAnd: 16rFF.
		b _ p bitAnd: 16rFF.
		alpha _ p bitShift: -24.
		alpha = 0 ifTrue: [^Color transparent].
		(r = 0 and: [g = 0 and: [b = 0]])  ifTrue: [^Color transparent].
		alpha < 255
			ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)]
			ifFalse: [^ (Color r: r g: g b: b range: 255)]].

	d = 12 ifTrue: [
		"four bits per component"
		r _ (p bitShift: -8) bitAnd: 16rF.
		g _ (p bitShift: -4) bitAnd: 16rF.
		b _ p bitAnd: 16rF.
		^ Color r: r g: g b: b range: 15].

	d = 9 ifTrue: [
		"three bits per component"
		r _ (p bitShift: -6) bitAnd: 16r7.
		g _ (p bitShift: -3) bitAnd: 16r7.
		b _ p bitAnd: 16r7.
		^ Color r: r g: g b: b range: 7].

	self error: 'unknown pixel depth: ', d printString
! !

!Color class methodsFor: 'instance creation' stamp: 'mir 7/21/1999 11:54'!
fromArray: colorDef
	colorDef size == 3
			ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)].
	colorDef size == 0
			ifTrue: [^Color transparent].
	colorDef size == 4
			ifTrue: [^(TranslucentColor r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)].
	self error: 'Undefined color definition'! !

!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'!
fromRgbTriplet: list
	^ self r: list first g: list second b: list last! !

!Color class methodsFor: 'instance creation' stamp: 'dvf 6/16/2000 17:48'!
fromString: aString
	"for HTML color spec: #FFCCAA or white/black"
	"Color fromString: '#FFCCAA'.
	 Color fromString: 'white'.
	 Color fromString: 'orange'"
	| aColorHex red green blue |
	aString isEmptyOrNil ifTrue: [^ Color white].
	aString first = $#
		ifTrue: [aColorHex _ aString copyFrom: 2 to: aString size]
		ifFalse: [aColorHex _ aString].
	[aColorHex size = 6
		ifTrue:
			[aColorHex _ aColorHex asUppercase.
			red _ ('16r', (aColorHex copyFrom: 1 to: 2)) asNumber/255.
			green _ ('16r', (aColorHex copyFrom: 3 to: 4)) asNumber/255.
			blue _ ('16r', (aColorHex copyFrom: 5 to: 6)) asNumber/255.
			^ self r: red g: green b: blue]]
	ifError: [:err :rcvr | "not a hex color triplet" ].
	
	"try to match aColorHex with known named colors"
	aColorHex _ aColorHex asLowercase.

	^self perform: (ColorNames detect: [:i | i asString asLowercase = aColorHex]
		ifNone: [#white])! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'!
gray: brightness
	"Return a gray shade with the given brightness in the range [0.0..1.0]."

	^ self basicNew setRed: brightness green: brightness blue: brightness
! !

!Color class methodsFor: 'instance creation'!
h: hue s: saturation v: brightness
	"Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red."
	"Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue."

	^ self basicNew setHue: hue saturation: saturation brightness: brightness! !

!Color class methodsFor: 'instance creation'!
new

	^ self r: 0.0 g: 0.0 b: 0.0! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:04'!
r: r g: g b: b
	"Return a color with the given r, g, and b components in the range [0.0..1.0]."

	^ self basicNew setRed: r green: g blue: b
! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b alpha: alpha

	^ (self r: r g: g b: b) alpha: alpha! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b range: range
	"Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."

	^ self basicNew setRed: r green: g blue: b range: range! !

!Color class methodsFor: 'instance creation'!
random
	"Return a random color that isn't too dark or under-saturated."

	^ self basicNew
		setHue: (360.0 * RandomStream next)
		saturation: (0.3 + (RandomStream next * 0.7))
		brightness: (0.4 + (RandomStream next * 0.6))! !


!Color class methodsFor: 'class initialization'!
initialize
	"Color initialize"

	"Details: Externally, the red, green, and blue components of color
	are floats in the range [0.0..1.0]. Internally, they are represented
	as integers in the range [0..ComponentMask] packing into a
	small integer to save space and to allow fast hashing and
	equality testing.

	For a general description of color representations for computer
	graphics, including the relationship between the RGB and HSV
	color models used here, see Chapter 17 of Foley and van Dam,
	Fundamentals of Interactive Computer Graphics, Addison-Wesley,
	1982."

	ComponentMask _ 1023.
	HalfComponentMask _ 512.  "used to round up in integer calculations"
	ComponentMax _ 1023.0.  "a Float used to normalize components"
	RedShift _ 20.
	GreenShift _ 10.
	BlueShift _ 0.

	PureRed		 _ self r: 1 g: 0 b: 0.
	PureGreen	 _ self r: 0 g: 1 b: 0.
	PureBlue	 _ self r: 0 g: 0 b: 1.
	PureYellow	 _ self r: 1 g: 1 b: 0.
	PureCyan	 _ self r: 0 g: 1 b: 1.
	PureMagenta _ self r: 1 g: 0 b: 1.

	RandomStream _ Random new.

	self initializeIndexedColors.
	self initializeGrayToIndexMap.
	self initializeNames.
	self initializeHighLights.
! !

!Color class methodsFor: 'class initialization'!
initializeGrayToIndexMap
	"Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level."
	"Note: This method must be called after initializeIndexedColors, since it uses IndexedColors."
	"Color initializeGrayToIndexMap"

	| grayLevels grayIndices c distToClosest dist indexOfClosest |
	"record the level and index of each gray in the 8-bit color table"
	grayLevels _ OrderedCollection new.
	grayIndices _ OrderedCollection new.
	"Note: skip the first entry, which is reserved for transparent"
	2 to: IndexedColors size do: [:i |
		c _ IndexedColors at: i.
		c saturation = 0.0 ifTrue: [  "c is a gray"
			grayLevels add: (c privateBlue) >> 2.  "top 8 bits; R, G, and B are the same"
			grayIndices add: i - 1]].  "pixel values are zero-based"
	grayLevels _ grayLevels asArray.
	grayIndices _ grayIndices asArray.

	"for each gray level in [0..255], select the closest match"
	GrayToIndexMap _ ByteArray new: 256.
	0 to: 255 do: [:level |
		distToClosest _ 10000.  "greater than distance to any real gray"
		1 to: grayLevels size do: [:i |
			dist _ (level - (grayLevels at: i)) abs.
			dist < distToClosest ifTrue: [
				distToClosest _ dist.
				indexOfClosest _ grayIndices at: i]].
		GrayToIndexMap at: (level + 1) put: indexOfClosest].
! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/22/96'!
initializeHighLights
	"Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. "
	"Color initializeHighLights"

	| t |
	t _ Array new: 32.
	t at: 1 put: (Bitmap with: 16rFFFFFFFF).
	t at: 2 put: (Bitmap with: 16rFFFFFFFF).
	t at: 4 put: (Bitmap with: 16r55555555).
	t at: 8 put: (Bitmap with: 16r7070707).
	t at: 16 put: (Bitmap with: 16rFFFFFFFF).
	t at: 32 put: (Bitmap with: 16rFFFFFFFF).
	HighLightBitmaps _ t.
! !

!Color class methodsFor: 'class initialization'!
initializeIndexedColors
	"Build an array of colors corresponding to the fixed colormap used
	 for display depths of 1, 2, 4, or 8 bits."
	"Color initializeIndexedColors"

	| a index grayVal |
	a _ Array new: 256.

	"1-bit colors (monochrome)"
	a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0).		"white or transparent"
	a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0).	"black"

	"additional colors for 2-bit color"
	a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0).	"opaque white"
	a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5).	"1/2 gray"

	"additional colors for 4-bit color"
	a at:  5 put: (Color r: 1.0 g: 0.0 b: 0.0).	"red"
	a at:  6 put: (Color r: 0.0 g: 1.0 b: 0.0).	"green"
	a at:  7 put: (Color r: 0.0 g: 0.0 b: 1.0).	"blue"
	a at:  8 put: (Color r: 0.0 g: 1.0 b: 1.0).	"cyan"
	a at:  9 put: (Color r: 1.0 g: 1.0 b: 0.0).	"yellow"
	a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0).	"magenta"

	a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125).		"1/8 gray"
	a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25).		"2/8 gray"
	a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375).		"3/8 gray"
	a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625).		"5/8 gray"
	a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75).		"6/8 gray"
	a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875).		"7/8 gray"

	"additional colors for 8-bit color"
	"24 more shades of gray (1/32 increments but not repeating 1/8 increments)"
	index _ 17.
	1 to: 31 do: [:v |
		(v \\ 4) = 0 ifFalse: [
			grayVal _ v / 32.0.
			a at: index put: (Color r: grayVal g: grayVal b: grayVal).
			index _ index + 1]].

	"The remainder of color table defines a color cube with six steps
	 for each primary color. Note that the corners of this cube repeat
	 previous colors, but this simplifies the mapping between RGB colors
	 and color map indices. This color cube spans indices 40 through 255
	 (indices 41-256 in this 1-based array)."
	0 to: 5 do: [:r |
		0 to: 5 do: [:g |
			0 to: 5 do: [:b |
				index _ 41 + ((36 * r) + (6 * b) + g).
				index > 256 ifTrue: [
					self error: 'index out of range in color table compuation'].
				a at: index put: (Color r: r g: g b: b range: 5)]]].

	IndexedColors _ a.
! !

!Color class methodsFor: 'class initialization' stamp: 'dwh 7/7/1999 23:57'!
initializeNames
	"Name some colors."
	"Color initializeNames"

	ColorNames _ OrderedCollection new.
	self named: #black put: (Color r: 0 g: 0 b: 0).
	self named: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125).
	self named: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25).
	self named: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375).
	self named: #gray put: (Color r: 0.5 g: 0.5 b: 0.5).
	self named: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625).
	self named: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75).
	self named: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875).
	self named: #white put: (Color r: 1.0 g: 1.0 b: 1.0).
	self named: #red put: (Color r: 1.0 g: 0 b: 0).
	self named: #yellow put: (Color r: 1.0 g: 1.0 b: 0).
	self named: #green put: (Color r: 0 g: 1.0 b: 0).
	self named: #cyan put: (Color r: 0 g: 1.0 b: 1.0).
	self named: #blue put: (Color r: 0 g: 0 b: 1.0).
	self named: #magenta put: (Color r: 1.0 g: 0 b: 1.0).
	self named: #brown put: (Color r: 0.6 g: 0.2 b: 0).
	self named: #orange put: (Color r: 1.0 g: 0.6 b: 0).
	self named: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8).
	self named: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8).
	self named: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6).
	self named: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0).
	self named: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0).
	self named: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0).
	self named: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2).
	self named: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4).
	self named: #transparent put: (TranslucentColor new alpha: 0.0).
	self named: #paleBuff put: (Color r: 254 g: 250 b: 235 range: 255).
	self named: #paleBlue put: (Color r: 222 g: 249 b: 254 range: 255).
	self named: #paleYellow put: (Color r: 255 g: 255 b: 217 range: 255).
	self named: #paleGreen put: (Color r: 223 g: 255 b: 213 range: 255).
	self named: #paleRed put: (Color r: 255 g: 230 b: 230 range: 255).
	self named: #veryPaleRed put: (Color r: 255 g: 242 b: 242 range: 255).
	self named: #paleTan put: (Color r: 235 g: 224 b: 199 range: 255).
	self named: #paleMagenta put: (Color r: 255 g: 230 b: 255 range: 255).
	self named: #paleOrange put: (Color r: 253 g: 237 b: 215 range: 255).
	self named: #palePeach put: (Color r: 255 g: 237 b: 213 range: 255).

! !

!Color class methodsFor: 'class initialization' stamp: 'ar 2/16/2000 21:56'!
initializeTranslucentPatterns
	"Color initializeTranslucentPatterns"
	| mask bits pattern patternList |
	TranslucentPatterns _ Array new: 8.
	#(1 2 4 8) do:[:d|
		patternList _ Array new: 5.
		mask _ (1 bitShift: d) - 1.
		bits _ 2 * d.
		[bits >= 32] whileFalse: [
			mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
			bits _ bits + bits].
		"0% pattern"
		pattern _ Bitmap with: 0 with: 0.
		patternList at: 1 put: pattern.
		"25% pattern"
		pattern _ Bitmap with: mask with: 0.
		patternList at: 2 put: pattern.
		"50% pattern"
		pattern _ Bitmap with: mask with: mask bitInvert32.
		patternList at: 3 put: pattern.
		"75% pattern"
		pattern _ Bitmap with: mask with: 16rFFFFFFFF.
		patternList at: 4 put: pattern.
		"100% pattern"
		pattern _ Bitmap with: 16rFFFFFFFF with: 16rFFFFFFFF.
		patternList at: 5 put: pattern.
		TranslucentPatterns at: d put: patternList.
	].! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/13/96'!
named: newName put: aColor
	"Add a new color to the list and create an access message and a class variable for it.  The name should start with a lowercase letter.  (The class variable will start with an uppercase letter.)  (Color colorNames) returns a list of all color names.  "
	| str cap sym accessor csym |
	(aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].
	str _ newName asString.
	sym _ str asSymbol.
	cap _ str capitalized.
	csym _ cap asSymbol.
	(self class canUnderstand: sym) ifFalse: [
		"define access message"
		accessor _ str, (String with: Character cr with: Character tab), 			'^', cap.
		self class compile: accessor
			classified: 'named colors'].
	(self classPool includesKey: csym) ifFalse: [
		self addClassVarName: cap].
	(ColorNames includes: sym) ifFalse: [
		ColorNames add: sym].
	^ self classPool at: csym put: aColor! !


!Color class methodsFor: 'examples'!
colorRampForDepth: depth extent: aPoint
	"Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths."
	"(Color colorRampForDepth: Display depth extent: 256@80) display"
	"(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint"

	| f dx dy r |
	f _ Form extent: aPoint depth: depth.
	dx _ aPoint x // 256.
	dy _ aPoint y // 4.
	0 to: 255 do: [:i |
		r _ (dx * i)@0 extent: dx@dy.
		f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255).
		r _ r translateBy: 0@dy.
		f fill: r fillColor: (Color r: i g: i b: i range: 255)].
	^ f
! !

!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'!
hotColdShades: thisMany
	"An array of thisMany colors showing temperature from blue to red to white hot.  (Later improve this by swinging in hue.)  "
	"Color showColors: (Color hotColdShades: 25)"

	| n s1 s2 s3 s4 s5 |
	thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades'].
	n _ thisMany // 5.
	s1 _ self white mix: self yellow shades: (thisMany - (n*4)).
	s2 _ self yellow mix: self red shades: n+1.
	s2 _ s2 copyFrom: 2 to: n+1.
	s3 _ self red mix: self green darker shades: n+1.
	s3 _ s3 copyFrom: 2 to: n+1.
	s4 _ self green darker mix: self blue shades: n+1.
	s4 _ s4 copyFrom: 2 to: n+1.
	s5 _ self blue mix: self black shades: n+1.
	s5 _ s5 copyFrom: 2 to: n+1.
	^ s1, s2, s3, s4, s5
! !

!Color class methodsFor: 'examples'!
showColorCube
	"Show a 12x12x12 color cube."
	"Color showColorCube"

	0 to: 11 do: [:r |
		0 to: 11 do: [:g |
			0 to: 11 do: [:b |	
				Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5)
					fillColor: (Color r: r g: g b: b range: 11)]]].
! !

!Color class methodsFor: 'examples'!
showColors: colorList
	"Display the given collection of colors across the top of the Display."

	| w r |
	w _ Display width // colorList size.
	r _ 0@0 extent: w@((w min: 30) max: 10).
	colorList do: [:c |
		Display fill: r fillColor: c.
		r _ r translateBy: w@0].
! !

!Color class methodsFor: 'examples'!
showHSVPalettes
	"Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32."
	"Color showHSVPalettes"

	| left top c |
	left _ top _ 0.
	0 to: 179 by: 15 do: [:h |
		0 to: 10 do: [:s |
			left _ (h * 4) + (s * 4).
			0 to: 10 do: [:v |
				c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0.
				top _ (v * 4).
				Display fill: (left@top extent: 4@4) fillColor: c.

				c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0.
				top _ (v * 4) + 50.
				Display fill: (left@top extent: 4@4) fillColor: c]]].
! !

!Color class methodsFor: 'examples'!
showHuesInteractively
	"Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point."
	"Color showHuesInteractively"

	| p s v |
	[Sensor anyButtonPressed] whileFalse: [
		p _ Sensor cursorPoint.
		s _ p x asFloat / 300.0.
		v _ p y asFloat / 300.0.
		self showColors: (self wheel: 12 saturation: s brightness: v)].
	^ (s min: 1.0) @ (v min: 1.0)! !

!Color class methodsFor: 'examples'!
wheel: thisMany
	"Return a collection of thisMany colors evenly spaced around the color wheel."
	"Color showColors: (Color wheel: 12)"

	^ Color wheel: thisMany saturation: 0.9 brightness: 0.7
! !

!Color class methodsFor: 'examples'!
wheel: thisMany saturation: s brightness: v
	"Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness."
	"Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)"
	"Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)"

	^ (Color h: 0.0 s: s v: v) wheel: thisMany
! !


!Color class methodsFor: 'named colors'!
black
	^Black! !

!Color class methodsFor: 'named colors'!
blue
	^Blue! !

!Color class methodsFor: 'named colors'!
brown
	^Brown! !

!Color class methodsFor: 'named colors'!
cyan
	^Cyan! !

!Color class methodsFor: 'named colors'!
darkGray
	^DarkGray! !

!Color class methodsFor: 'named colors'!
gray
	^Gray! !

!Color class methodsFor: 'named colors'!
green
	^Green! !

!Color class methodsFor: 'named colors'!
lightBlue
	^LightBlue! !

!Color class methodsFor: 'named colors'!
lightBrown
	^LightBrown! !

!Color class methodsFor: 'named colors'!
lightCyan
	^LightCyan! !

!Color class methodsFor: 'named colors'!
lightGray
	^LightGray! !

!Color class methodsFor: 'named colors'!
lightGreen
	^LightGreen! !

!Color class methodsFor: 'named colors'!
lightMagenta
	^LightMagenta! !

!Color class methodsFor: 'named colors'!
lightOrange
	^LightOrange! !

!Color class methodsFor: 'named colors'!
lightRed
	^LightRed! !

!Color class methodsFor: 'named colors'!
lightYellow
	^LightYellow! !

!Color class methodsFor: 'named colors'!
magenta
	^Magenta! !

!Color class methodsFor: 'named colors'!
orange
	^Orange! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleBlue
	^PaleBlue! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleBuff
	^PaleBuff! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleGreen
	^PaleGreen! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleMagenta
	^PaleMagenta! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleOrange
	^PaleOrange! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
palePeach
	^PalePeach! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleRed
	^PaleRed! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleTan
	^PaleTan! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
paleYellow
	^PaleYellow! !

!Color class methodsFor: 'named colors'!
red
	^Red! !

!Color class methodsFor: 'named colors' stamp: 'wod 5/24/1998 01:56'!
tan
	^  Color r: 0.8 g: 0.8 b: 0.5! !

!Color class methodsFor: 'named colors'!
transparent
	^Transparent! !

!Color class methodsFor: 'named colors'!
veryDarkGray
	^VeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryLightGray
	^VeryLightGray! !

!Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'!
veryPaleRed
	^VeryPaleRed! !

!Color class methodsFor: 'named colors'!
veryVeryDarkGray
	^VeryVeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryVeryLightGray
	^VeryVeryLightGray! !

!Color class methodsFor: 'named colors'!
white
	^White! !

!Color class methodsFor: 'named colors'!
yellow
	^Yellow! !


!Color class methodsFor: 'colormaps' stamp: 'jm 5/2/1999 07:24'!
cachedColormapFrom: sourceDepth to: destDepth
	"Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations."
	"Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"
	"Note: The colormap cache may be cleared by evaluating 'Color shutDown'."

	| srcIndex map |
	CachedColormaps class == Array ifFalse: [CachedColormaps _ (1 to: 9) collect: [:i | Array new: 32]].
	srcIndex _ sourceDepth.
	sourceDepth > 8 ifTrue: [srcIndex _ 9].
	(map _ (CachedColormaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [^ map].

	map _ self computeColormapFrom: sourceDepth to: destDepth.
	(CachedColormaps at: srcIndex) at: destDepth put: map.
	^ map
! !

!Color class methodsFor: 'colormaps'!
colorMapIfNeededFrom: sourceDepth to: destDepth
	"Return a colormap for mapping between the given depths, or nil if no colormap is needed."
	"Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"

	sourceDepth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"

	(sourceDepth >= 16) & (destDepth >= 16) ifTrue: [
		"mapping is done in BitBlt by zero-filling or truncating each color component"
		^ nil].

	^ Color cachedColormapFrom: sourceDepth to: destDepth
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 3/25/1999 19:48'!
computeColormapFrom: sourceDepth to: destDepth
	"Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead."

	| map bitsPerColor |
	sourceDepth < 16 ifTrue: [
		"source is 1-, 2-, 4-, or 8-bit indexed color"
		map _ (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth))
					collect: [:c | c pixelValueForDepth: destDepth].
		map _ map as: Bitmap.
	] ifFalse: [
		"source is 16-bit or 32-bit RGB"
		destDepth > 8
			ifTrue: [bitsPerColor _ 5]  "retain maximum color resolution"
			ifFalse: [bitsPerColor _ 4].
		map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor].

	"Note: zero is transparent except when source depth is one-bit deep"
	sourceDepth > 1 ifTrue: [map at: 1 put: 0].
	^ map
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 12/4/97 15:25'!
computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor
	"Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component."

	| mask map c |
	(#(3 4 5) includes: bitsPerColor)
		ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component'].
	mask _ (1 bitShift: bitsPerColor) - 1.
	map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)).
	0 to: map size - 1 do: [:i |
		c _ Color
			r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask)
			g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask)
			b: ((i bitShift: 0) bitAnd: mask)
			range: mask.
		map at: i + 1 put: (c pixelValueForDepth: destDepth)].

	map at: 1 put: (Color transparent pixelWordForDepth: destDepth).  "zero always transparent"
	^ map
! !


!Color class methodsFor: 'other'!
colorNames
	"Return a collection of color names."

	^ ColorNames! !

!Color class methodsFor: 'other'!
indexedColors

	^ IndexedColors! !

!Color class methodsFor: 'other' stamp: 'di 3/29/1999 13:33'!
maskingMap: depth
	"Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map."

	| sizeNeeded |
	depth <= 8
		ifTrue: [sizeNeeded _ 1 bitShift: depth]
		ifFalse: [sizeNeeded _ 4096].

	(MaskingMap == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue:
		[MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF.
		MaskingMap at: 1 put: 0.  "transparent"].

	^ MaskingMap
! !

!Color class methodsFor: 'other'!
pixelScreenForDepth: depth
	"Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth."

	| mask bits |
	mask _ (1 bitShift: depth) - 1.
	bits _ 2 * depth.
	[bits >= 32] whileFalse: [
		mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
		bits _ bits + bits].
	^ Bitmap with: mask with: mask bitInvert32
! !

!Color class methodsFor: 'other'!
quickHighLight: depth
	"Quickly return a Bitblt-ready raw colorValue for highlighting areas.  6/22/96 tk"

	^ HighLightBitmaps at: depth! !

!Color class methodsFor: 'other'!
shutDown
	"Color shutDown"

	ColorChart _ nil.		"Palette of colors for the user to pick from"
	CachedColormaps _ nil.	"Maps to translate between color depths"
	MaskingMap _ nil.		"Maps all colors except transparent to black for creating a mask"
! !

!Color class methodsFor: 'other' stamp: 'ar 2/16/2000 21:56'!
translucentMaskFor: alphaValue depth: d
	"Return a pattern representing a mask usable for stipple transparency"
	^(TranslucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! !


!Color class methodsFor: 'color from user' stamp: 'jm 12/5/97 18:35'!
colorPaletteForDepth: depth extent: chartExtent
	"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorPaletteForDepth: 16 extent: 190@60) display"

	| basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette _ Form extent: chartExtent depth: depth.
	transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt _ transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth _ 10.
	startHue _ 338.0.
	vSteps _ palette height - transHt // 2.
	hSteps _ palette width - grayWidth.
	x _ 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
		basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
		y _ transHt+1.
		0 to: vSteps do: [:n |
 			c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		1 to: vSteps do: [:n |
 			c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		x _ x + 1].
	y _ transHt + 1.
	1 to: vSteps * 2 do: [:n |
 		c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y _ y + 1].
	^ palette
! !

!Color class methodsFor: 'color from user' stamp: 'jm 1/19/1999 11:33'!
colorTest: depth extent: chartExtent colorMapper: colorMapper
	"Create a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
	"Note: It is slow to build this palette, so it should be cached for quick access."
	"(Color colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 7) asInteger / 7
			g: (c green * 7) asInteger / 7
			b: (c blue * 3) asInteger / 3]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 5) asInteger / 5
			g: (c green * 5) asInteger / 5
			b: (c blue * 5) asInteger / 5]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 15) asInteger / 15
			g: (c green * 15) asInteger / 15
			b: (c blue * 15) asInteger / 15]) display"
	"(Color colorTest: 32 extent: 570@180 colorMapper:
		[:c | Color
			r: (c red * 31) asInteger / 31
			g: (c green * 31) asInteger / 31
			b: (c blue * 31) asInteger / 31]) display"

	| basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
	palette _ Form extent: chartExtent depth: depth.
	transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
		(Form extent: 34@9 depth: 1
			fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
			offset: 0@0).
	transHt _ transCaption height.
	palette fillWhite: (0@0 extent: palette width@transHt).
	palette fillBlack: (0@transHt extent: palette width@1).
	transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
	grayWidth _ 10.
	startHue _ 338.0.
	vSteps _ palette height - transHt // 2.
	hSteps _ palette width - grayWidth.
	x _ 0.
	startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
		basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
		y _ transHt+1.
		0 to: vSteps do: [:n |
 			c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
			c _ colorMapper value: c.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		1 to: vSteps do: [:n |
 			c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
			c _ colorMapper value: c.
			palette fill: (x@y extent: 1@1) fillColor: c.
			y _ y + 1].
		x _ x + 1].
	y _ transHt + 1.
	1 to: vSteps * 2 do: [:n |
 		c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
		c _ colorMapper value: c.
		palette fill: (x@y extent: 10@1) fillColor: c.
		y _ y + 1].
	^ palette
! !

!Color class methodsFor: 'color from user' stamp: 'di 4/13/1999 14:30'!
fromUser
	"Displays a color palette of colors, waits for a mouse click, and returns the selected color. Any pixel on the Display can be chosen, not just those in the color palette."
	"Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the oldColorPaletteForDepth:extent: method."
	"Color fromUser"

	| d startPt save tr oldColor c here s |
	d _ Display depth.
	((ColorChart == nil) or: [ColorChart depth ~= Display depth]) 
		ifTrue: [ColorChart _ self oldColorPaletteForDepth: d extent: (2 * 144)@80].
	Sensor cursorPoint y < Display center y 
		ifTrue: [startPt _ 0@(Display boundingBox bottom - ColorChart height)]
		ifFalse: [startPt _ 0@0].

	save _ Form fromDisplay: (startPt extent: ColorChart extent).
	ColorChart displayAt: startPt.
	tr _ ColorChart extent - (50@19) corner: ColorChart extent.
	tr _ tr translateBy: startPt.

	oldColor _ nil.
	[Sensor anyButtonPressed] whileFalse: [
		c _ Display colorAt: (here _ Sensor cursorPoint).
		(tr containsPoint: here)
			ifFalse: [Display fill: (0@61+startPt extent: 20@19) fillColor: c]
			ifTrue: [
				c _ Color transparent.
				Display fill: (0@61+startPt extent: 20@19) fillColor: Color white].
		c = oldColor ifFalse: [
			Display fillWhite: (20@61 + startPt extent: 135@19).
			c isTransparent
				ifTrue: [s _ 'transparent']
				ifFalse: [s _ c shortPrintString.
						s _ s copyFrom: 7 to: s size - 1].
			s displayAt: 20@61 + startPt.
			oldColor _ c]].
	save displayAt: startPt.
	Sensor waitNoButton.
	^ c
! !

!Color class methodsFor: 'color from user' stamp: 'di 4/13/1999 14:28'!
oldColorPaletteForDepth: depth extent: paletteExtent
	"Returns a form of the given size showing a color palette for the given depth."
	"(Color oldColorPaletteForDepth: Display depth extent: 720@100) display"

	| c p f nSteps rect w h q |
	f _ Form extent: paletteExtent depth: depth.
	f fill: f boundingBox fillColor: Color white.
	nSteps _ depth > 8 ifTrue: [12] ifFalse: [6].
	w _ paletteExtent x // (nSteps * nSteps).
	h _ paletteExtent y - 20 // nSteps.
	0 to: nSteps-1 do: [:r |
		0 to: nSteps-1 do: [:g |
			0 to: nSteps-1 do: [:b |
				c _ Color r: r g: g b: b range: nSteps - 1.
				rect _ ((r * nSteps * w) + (b * w)) @ (g * h) extent: w@(h + 1).
				f fill: rect fillColor: c]]].
	q _ Quadrangle origin: paletteExtent - (50@19) corner: paletteExtent.
	q displayOn: f.
	'Trans.' displayOn: f at: q origin + (9@1).

	w _ ((paletteExtent x - q width - 130) // 64) max: 1.
	p _ paletteExtent x - q width - (64 * w) - 1 @ (paletteExtent y - 19).
	0 to: 63 do:
		[:v | c _ Color r: v g: v b: v range: 63.
		f fill: ((v * w)@0 + p extent: (w + 1)@19) fillColor: c].
	^ f
! !
Form subclass: #ColorForm
	instanceVariableNames: 'colors cachedDepth cachedColormap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!ColorForm commentStamp: '<historical>' prior: 0!
ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors.

ColorForms have several uses:
  1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette.
  2) Easy transparency. Just store (Color transparent) at the desired position in the color map.
  3) Cheap color remapping by changing the color map.

A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache.

ColorForms can be a bit tricky. Note that:
  a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm.
  b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps.
  c) The default map for 8 bit depth has black in the first entry, not transparent.  Say (cform colors at: 1 put: Color transparent).
!


!ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'!
colors
	"Return my color palette."

	self ensureColorArrayExists.
	^ colors
! !

!ColorForm methodsFor: 'accessing'!
colors: colorList
	"Set my color palette to the given collection."

	| colorArray colorCount newColors |
	colorList ifNil: [
		colors _ cachedDepth _ cachedColormap _ nil.
		^ self].

	colorArray _ colorList asArray.
	colorCount _ colorArray size.
	newColors _ Array new: (1 bitShift: depth).
	1 to: newColors size do: [:i |
		i <= colorCount
			ifTrue: [newColors at: i put: (colorArray at: i)]
			ifFalse: [newColors at: i put: Color transparent]].

	colors _ newColors.
	cachedDepth _ nil.
	cachedColormap _ nil.
! !

!ColorForm methodsFor: 'accessing' stamp: 'mir 7/21/1999 11:51'!
colorsFromArray: colorArray
	| colorList |
	colorList _ colorArray collect: [:colorDef |
		Color fromArray: colorDef].
	self colors: colorList! !


!ColorForm methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm

	aDisplayMedium copyBits: self boundingBox
		from: self
		at: aDisplayPoint + self offset
		clippingBox: clipRectangle
		rule: rule
		fillColor: aForm
		map: (self colormapIfNeededForDepth: aDisplayMedium depth).
! !

!ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'!
displayOnPort: port at: location

	port copyForm: self to: location rule: Form paint! !


!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint
	"Return the color of the pixel at aPoint."

	^ self colors at: (self pixelValueAt: aPoint) + 1
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint put: aColor
	"Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap."

	| i |
	i _ self colors indexOf: aColor
		ifAbsent: [^ self error: 'trying to use a color that is not in my colormap'].
	self pixelValueAt: aPoint put: i - 1.
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'tk 10/21/97 12:27'!
isTransparentAt: aPoint 
	"Return true if the receiver is transparent at the given point."

	^ (self colorAt: aPoint) isTransparent
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'ar 5/28/2000 12:06'!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color."
	"Details: To get the raw pixel value, be sure the peeker's colorMap is nil."

	^ (BitBlt current bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint
! !


!ColorForm methodsFor: 'color manipulation' stamp: 'di 11/11/1998 13:20'!
asGrayScale
	"Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent"
	^ self copy colors:
		(colors collect:
			[:c | c isTransparent ifTrue: [c]
						ifFalse: [Color gray: c luminance]])! !

!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/25/2000 19:51'!
colormapIfNeededForDepth: destDepth
	"Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

	| newMap |
	colors == nil ifTrue: [
		"use the standard colormap"
		^ Color colorMapIfNeededFrom: depth to: destDepth].

	(destDepth = cachedDepth and:[cachedColormap isColormap not]) 
		ifTrue: [^ cachedColormap].
	newMap _ Bitmap new: colors size.
	1 to: colors size do: [:i |
		newMap
			at: i
			put: ((colors at: i) pixelValueForDepth: destDepth)].

	cachedDepth _ destDepth.
	^ cachedColormap _ newMap.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 4/18/98 20:34'!
colorsUsed
	"Return a list of the colors actually used by this ColorForm."

	| myColor list |
	myColor _ self colors.
	list _ OrderedCollection new.
	self tallyPixelValues doWithIndex: [:count :i |
		count > 0 ifTrue: [list add: (myColor at: i)]].
	^ list asArray
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'!
ensureTransparentColor
	"Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map."

	| i |
self error: 'not yet implemented'.
	(colors includes: Color transparent)
		ifTrue: [
			(colors indexOf: Color transparent) = 1 ifTrue: [^ self].
			"shift the entry for color transparent"]
		ifFalse: [
			i _ self unusedColormapEntry.
			i = 0 ifTrue: [self error: 'no color map entry is available'].
			colors at: i put: Color transparent.
			"shift the entry for color transparent"].
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:48'!
indexOfColor: aColor
	"Return the index of aColor in my color array"

	self ensureColorArrayExists.
	^ colors indexOf: aColor ifAbsent: [0]! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 10/19/1998 10:52'!
mapColor: oldColor to: newColor
	"Replace all occurances of the given color with the given new color in my color map."

	self ensureColorArrayExists.
	1 to: colors size do: [:i | 
		(colors at: i) = oldColor ifTrue: [colors at: i put: newColor]].
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 3/27/98 13:24'!
readFrom: aBinaryStream

	self error: 'not yet implemented'.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'!
replaceColor: oldColor with: newColor
	"Replace all occurances of the given color with the given new color in my color map."

	self ensureColorArrayExists.
	1 to: colors size do: [:i | 
		(colors at: i) = oldColor ifTrue: [colors at: i put: newColor]].
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'!
replaceColorAt: aPoint with: newColor
	"Replace a color map entry with newColor.  The entry replaced is the one used by aPoint.  If there are are two entries in the colorMap for the oldColor, just replace ONE!!!!  There are often two whites or two blacks, and this is what you want, when replacing one."

	| oldIndex |
	self ensureColorArrayExists.
	oldIndex _ self pixelValueAt: aPoint.
	colors at: oldIndex+1 put: newColor.
	self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'di 8/28/1998 15:49'!
replaceColorAtIndex: index with: newColor
	"Replace a color map entry with newColor."

	self ensureColorArrayExists.
	colors at: index put: newColor.
	cachedColormap == nil ifFalse:
		[cachedColormap at: index put: (newColor pixelValueForDepth: cachedDepth)]! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'!
transparentAllPixelsLike: aPoint
	"Make all occurances of the given pixel value transparent.  Very useful when two entries in the colorMap have the same value.  This only changes ONE."

	self replaceColorAt: aPoint with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'!
transparentColor: aColor
	"Make all occurances of the given color transparent.  Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them.  Not always what you want."

	self replaceColor: aColor with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/28/2000 12:06'!
twoToneFromDisplay: aRectangle backgroundColor: bgColor
	"Copy one-bit deep ColorForm from the Display using a color map that maps all colors except the background color to black. Used for caching the contents of inactive MVC windows."

	| map |
	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].

	"make a color map mapping the background color
	 to zero and all other colors to one"
	map _ Bitmap new: (1 bitShift: (Display depth min: 9)).
	1 to: map size do: [:i | map at: i put: 16rFFFFFFFF].
	map at: (bgColor indexInMap: map) put: 0.

	(BitBlt current toForm: self)
		destOrigin: 0@0;
		sourceForm: Display;
		sourceRect: aRectangle;
		combinationRule: Form over;
		colorMap: map;
		copyBits.
! !


!ColorForm methodsFor: 'copying' stamp: 'RAA 8/14/2000 10:45'!
asCursorForm

	^ (self asFormOfDepth: 32) offset: offset; as: StaticForm! !

!ColorForm methodsFor: 'copying' stamp: 'RAA 9/28/1999 11:22'!
blankCopyOf: aRectangle scaledBy: scale

        | newForm |
        newForm _ self class extent: (aRectangle extent * scale) truncated depth: depth.
        colors ifNotNil: [newForm colors: colors copy].
        ^ newForm! !

!ColorForm methodsFor: 'copying' stamp: 'ar 5/28/2000 12:06'!
copy: aRect
 	"Return a new ColorForm containing the portion of the receiver delineated by aRect."

	| newForm |
	newForm _ self class extent: aRect extent depth: depth.
	((BitBlt current
		destForm: newForm
		sourceForm: self
		fillColor: nil
		combinationRule: Form over
		destOrigin: 0@0
		sourceOrigin: aRect origin
		extent: aRect extent
		clipRect: newForm boundingBox)
		colorMap: nil) copyBits.
	colors ifNotNil: [newForm colors: colors copy].
	^ newForm
! !

!ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy;
		colors: colors
! !


!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'!
clearColormapCache

	cachedDepth _ nil.
	cachedColormap _ nil.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'!
depth: bitsPerPixel

	bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
	super depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'!
ensureColorArrayExists
	"Return my color palette."

	colors ifNil: [
		depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits'].
		self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: depth))].
! !

!ColorForm methodsFor: 'private' stamp: 'jm 4/5/1999 10:11'!
setColors: colorArray cachedColormap: aBitmap depth: anInteger
	"Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations."

	colors _ colorArray.
	cachedDepth _ anInteger.
	cachedColormap _ aBitmap.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'!
setExtent: extent depth: bitsPerPixel
	"Create a virtual bit map with the given extent and bitsPerPixel."

	bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
	super setExtent: extent depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'!
unusedColormapEntry
	"Return the index of an unused color map entry, or zero if there isn't one."

	| tallies |
	tallies _ self tallyPixelValues.
	1 to: tallies size do: [:i |
		(tallies at: i) = 0 ifTrue: [^ i]].
	^ 0
! !


!ColorForm methodsFor: 'scaling, rotation' stamp: 'ar 3/15/1999 14:28'!
flipBy: direction centerAt: aPoint
	| oldColors newForm |
	oldColors _ colors.
	self colors: nil.
	newForm _ super flipBy: direction centerAt: aPoint.
	self colors: oldColors.
	newForm colors: oldColors.
	^newForm ! !

!ColorForm methodsFor: 'scaling, rotation' stamp: 'RAA 8/5/2000 18:12'!
scaledToSize: newExtent

	"super method did not seem to work so well on ColorForms"

	^(self asFormOfDepth: 16) scaledToSize: newExtent! !


!ColorForm methodsFor: 'fileIn/Out' stamp: 'RAA 7/24/2000 13:32'!
encodeForRemoteCanvas

	"encode into a bitstream for use with RemoteCanvas."

	| colorsToSend |

	colorsToSend _ self colors.
	^String streamContents: [ :str |
		str
			nextPut: $C;		"indicates color form"
			nextPutAll: colorsToSend size printString;
			nextPut: $,.
		colorsToSend do: [ :each |
			str nextPutAll: each encodeForRemoteCanvas
		].
		str nextPutAll: super encodeForRemoteCanvas
	].

! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'jm 7/23/1999 20:42'!
hibernate
	"Make myself take up less space. See comment in Form>hibernate."

	super hibernate.
	self clearColormapCache.
! !

!ColorForm methodsFor: 'fileIn/Out' stamp: 'bf 5/25/2000 16:31'!
storeOn: aStream
	aStream nextPut: $(.
	super storeOn: aStream.
	aStream
		cr; tab;
		nextPutAll: 'colorsFromArray: #('.
	self colors do: [:color |
		color storeArrayOn: aStream].
	aStream nextPutAll: ' ))'.! !


!ColorForm methodsFor: 'postscript generation'!
asFormWithSingleTransparentColors
	| transparentIndexes |
	transparentIndexes _ self transparentColorIndexes.
	transparentIndexes size <= 1 ifTrue:[^self]
		ifFalse:[^self mapTransparencies:transparentIndexes].! !

!ColorForm methodsFor: 'postscript generation'!
decodeArray
	^self depth = 1 ifTrue:['[1 0]'] ifFalse:['[0 255]'].! !

!ColorForm methodsFor: 'postscript generation' stamp: 'sma 6/14/2000 14:20'!
encodePostscriptOn: aStream 
	self unhibernate.
	aStream print: '% form contains ';
	 write: (colors select: [:c | c = Color transparent]) size;
	 print: ' transparent colors';
	 cr.
	^ self asFormWithSingleTransparentColors 
		printPostscript: aStream operator: (self depth = 1
			ifTrue: ['imagemask']
			ifFalse: [(self indexOfColor: Color transparent) printString , ' transparentimage'])! !

!ColorForm methodsFor: 'postscript generation'!
getTransparencyUnificationLUT
	| lut transparentIndex |
	lut _ Array new:colors size.
	transparentIndex _ self indexOfColor:Color transparent.
	1 to: colors size do:
		[ :i | lut at:i put:(((colors at:i) = Color transparent) ifTrue:[transparentIndex] ifFalse:[i])].
 ! !

!ColorForm methodsFor: 'postscript generation'!
mapTransparencies:transparentIndexes
	^self deepCopy mapColors:transparentIndexes to:(transparentIndexes at:1).! !

!ColorForm methodsFor: 'postscript generation'!
printPostscript:aStream
	aStream nextPutAll:'% form contains '; 
			print:((colors select:[:c| c=Color transparent]) size); 
			nextPutAll:' transparent colors'; cr.
	^self asFormWithSingleTransparentColors printPostscript:aStream operator:(self depth=1 ifTrue:['imagemask'] 
	ifFalse:[ (self indexOfColor:Color transparent) printString ,' transparentimage']) .
! !

!ColorForm methodsFor: 'postscript generation'!
setColorspaceOn:aStream
	self depth = 1 ifTrue:[
		aStream print:'/DeviceRGB setcolorspace 0 setgray'; cr.
	]
	ifFalse:[
	aStream print:'[ /Indexed /DeviceRGB ';
	write:self colors size-1;
	print:' <'.
	(self colormapIfNeededForDepth: 32 ) storeBits:20 to:0 on:aStream.
	aStream print:'> ] setcolorspace'; cr.].
! !

!ColorForm methodsFor: 'postscript generation'!
transparentColorIndexes
	^(1 to: colors size) select: [ :index | (colors at:index) isTransparent ].
! !


!ColorForm methodsFor: 'color mapping' stamp: 'ar 6/8/2000 20:39'!
colormapIfNeededFor: destForm
	| newMap color pv |
	colors == nil ifTrue: [
		"use the standard colormap"
		^ super colormapIfNeededFor: destForm].

	(destForm depth = cachedDepth and:[cachedColormap isColormap]) 
		ifTrue: [^ cachedColormap].
	newMap _ WordArray new: (1 bitShift: depth).
	1 to: colors size do: [:i |
		color _ colors at: i.
		pv _ destForm pixelValueFor: color.
		(pv = 0 and:[color isTransparent not]) ifTrue:[pv _ 1].
		newMap at: i put: pv].

	cachedDepth _ destForm depth.
	^cachedColormap _ ColorMap shifts: nil masks: nil colors: newMap.! !

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

ColorForm class
	instanceVariableNames: ''!

!ColorForm class methodsFor: 'as yet unclassified' stamp: 'jm 11/16/97 09:17'!
mappingWhiteToTransparentFrom: aFormOrCursor
	"Return a ColorForm copied from the given Form or Cursor with white mapped to transparent."

	| f map |
	aFormOrCursor depth <= 8 ifFalse: [
		^ self error: 'argument depth must be 8-bits per pixel or less'].
	(aFormOrCursor isKindOf: ColorForm) ifTrue: [
		f _ aFormOrCursor deepCopy.
		map _ aFormOrCursor colors.
	] ifFalse: [
		f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.
		f copyBits: aFormOrCursor boundingBox
			from: aFormOrCursor
			at: 0@0
			clippingBox: aFormOrCursor boundingBox
			rule: Form over
			fillColor: nil.
		map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].
	map _ map collect: [:c |
		c = Color white ifTrue: [Color transparent] ifFalse: [c]].
	f colors: map.
	^ f
! !

!ColorForm class methodsFor: 'as yet unclassified'!
twoToneFromDisplay: aRectangle using: oldForm backgroundColor: bgColor
	"Return a 1-bit deep ColorForm copied from the given rectangle of the display. All colors except the background color will be mapped to black."

	| f |
	((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [
		f _ oldForm fromDisplay: aRectangle.
	] ifFalse: [
		f _ ColorForm extent: aRectangle extent depth: 1.
		f twoToneFromDisplay: aRectangle backgroundColor: bgColor.
		f colors: (Array
			with: bgColor
			with: Color black)].
	^ f
! !
Object subclass: #ColorMap
	instanceVariableNames: 'shifts masks colors '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:54'!
alphaMask
	^masks at: 4! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:55'!
alphaMask: value
	masks at: 4 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
alphaShift
	^shifts at: 4! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
alphaShift: value
	shifts at: 4 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'!
at: index
	^colors at: index! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'!
at: index put: value
	^colors at: index put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueMask
	^masks at: 3! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueMask: value
	masks at: 3 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'!
blueShift
	^shifts at: 3! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
blueShift: value
	shifts at: 3 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'!
colors
	^colors! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenMask
	^masks at: 2! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenMask: value
	masks at: 2 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'!
greenShift
	^shifts at: 2! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'!
greenShift: value
	shifts at: 2 put: value.! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/28/2000 22:08'!
inverseMap
	"Return the inverse map of the receiver"
	| newMasks newShifts |
	colors ifNotNil:[^self error:'Not yet implemented'].
	newMasks _ WriteStream on: (Array new: 4).
	newShifts _ WriteStream on: (Array new: 4).
	masks with: shifts do:[:mask :shift|
		newMasks nextPut: (mask bitShift: shift).
		newShifts nextPut: shift negated].
	^ColorMap
		shifts: newShifts contents
		masks: newMasks contents! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'!
masks
	^masks! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'!
redMask
	^masks at: 1! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redMask: value
	masks at: 1 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redShift
	^shifts at: 1! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'!
redShift: value
	shifts at: 1 put: value! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:48'!
rgbaBitMasks
	"Return the rgba bit masks for the receiver"
	^masks asArray with: shifts collect:[:m :s| m bitShift: s]! !

!ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'!
shifts
	^shifts! !


!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 1/16/2000 20:52'!
mapPixel: pixelValue
	"Perform a forward pixel mapping operation"
	| pv |
	(shifts == nil and:[masks == nil]) ifFalse:[
		pv _ (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr:
			((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr:
			(((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr:
			((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)).
	] ifTrue:[pv _ pixelValue].
	colors == nil
		ifTrue:[^pv]
		ifFalse:[^colors at: pv].! !

!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 6/8/2000 20:36'!
mappingTo: aColorMap
	"Compute a new color map through the receiver and aColorMap.
	Both maps are assumed to be mappings into canonical ARGB space"
	| fixedMap |
	self = aColorMap ifTrue:[^nil]. "No mapping needed"
	aColorMap isIndexed ifTrue:[^nil]. "We can't compute mappings to an indexed map yet"
	fixedMap _ self class mappingFrom: self rgbaBitMasks to: aColorMap rgbaBitMasks.
	self isIndexed ifFalse:[^fixedMap].
	"If the receiver is indexed then we need to map the colors as well"
	self flag: #untested.
	^ColorMap
		shifts: fixedMap shifts
		masks: fixedMap masks
		colors: (colors collect:[:pv| aColorMap pixelMap: pv]).
! !

!ColorMap methodsFor: 'pixel mapping' stamp: 'ar 1/16/2000 20:52'!
pixelMap: pixelValue
	"Perform a reverse pixel mapping operation"
	| pv |
	colors == nil
		ifTrue:[pv _ pixelValue]
		ifFalse:[pv _ colors at: pixelValue].
	(shifts == nil and:[masks == nil]) 
		ifTrue:[^pv]
		ifFalse:[^(((pv bitAnd: self redMask) bitShift: self redShift) bitOr: 
				((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr:
					(((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: 
						((pv bitAnd: self alphaMask) bitShift: self alphaShift))]! !


!ColorMap methodsFor: 'private' stamp: 'ar 2/22/2000 16:47'!
setShifts: shiftArray masks: maskArray colors: colorArray
	shiftArray ifNotNil:[shifts _ shiftArray asIntegerArray].
	maskArray ifNotNil:[masks _ maskArray asWordArray].
	colorArray ifNotNil:[colors _ colorArray asWordArray].! !


!ColorMap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:41'!
isColormap
	^true! !

!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'!
isFixed
	"Return true if the receiver does not use a lookup mechanism for pixel mapping"
	^self isIndexed not! !

!ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'!
isIndexed
	"Return true if the receiver uses a lookup mechanism for pixel mapping"
	^colors notNil! !


!ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:28'!
= aColorMap
	"Return true if the receiver is equal to aColorMap"
	self species = aColorMap species ifFalse:[^false].
	self isIndexed = aColorMap isIndexed ifFalse:[^false].
	^self colors = aColorMap colors and:[
		self shifts = aColorMap shifts and:[
			self masks = aColorMap masks]]! !

!ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:29'!
hash
	"Hash is re-implemented because #= is re-implemented"
	^colors hash bitXor: (shifts hash bitXor: masks hash)! !

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

ColorMap class
	instanceVariableNames: ''!

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 2/22/2000 14:08'!
colors: colorArray
	^self new setShifts: nil masks: nil colors: colorArray! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:09'!
mapBitsFrom: srcBitMask to: dstBitMask
	"Return an array consisting of the shift and the mask for
	mapping component values out of srcBitMask and into dstBitMask.
	While this computation is somewhat complicated it eases the batch
	conversion of all the pixels in BitBlt."
	| srcBits dstBits srcLow srcHigh dstLow dstHigh bits mask shift |
	(srcBitMask = 0 or:[dstBitMask = 0]) ifTrue:[^#(0 0)]. "Zero mask and shift"
	"Compute low and high bit position for source and dest bit mask"
	srcLow _ srcBitMask lowBit - 1.	srcHigh _ srcBitMask highBit.
	dstLow _ dstBitMask lowBit - 1.	dstHigh _ dstBitMask highBit.
	"Compute the number of bits in source and dest bit mask"
	srcBits _ srcHigh - srcLow.		dstBits _ dstHigh - dstLow.
	"Compute the maximum number of bits we can transfer inbetween"
	bits _ srcBits min: dstBits.
	"Compute the (unshifted) transfer mask"
	mask _ (1 bitShift: bits) - 1.
	"Shift the transfer mask to the mask the highest n bits of srcBitMask"
	mask _ mask bitShift: (srcHigh - bits).
	"Compute the delta shift so that the most significant bit of the
	source bit mask falls on the most significant bit of the dest bit mask.
	Note that delta is used for #bitShift: so
		shift > 0 : shift right
		shift < 0 : shift left
	e.g., if dstHigh > srcHigh we need to shift left and if dstHigh < srcHigh
	we need to shift right. This leads to:"
	shift _ dstHigh - srcHigh.
	"And that's all we need"
	^Array with: shift with: mask! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 19:41'!
mappingFrom: srcBitMasks to: dstBitMasks
	"Return a color map mapping from the array of source bit masks
	to the array of dest bit masks."
	| shifts masks shiftAndMask |
	shifts _ IntegerArray new: 4.
	masks _ WordArray new: 4.
	1 to: 4 do:[:i|
		shiftAndMask _ self mapBitsFrom: (srcBitMasks at: i) to: (dstBitMasks at: i).
		shifts at: i put: (shiftAndMask at: 1).
		masks at: i put: (shiftAndMask at: 2).
	].
	^self shifts: shifts masks: masks! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'!
mappingFromARGB: dstBitMasks
	"Return a ColorMap mapping from canonical ARGB space into dstBitMasks"
	^self mappingFrom: #(16rFF0000 16rFF00 16rFF 16rFF000000) to: dstBitMasks! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:08'!
mappingToARGB: srcBitMasks
	"Return a ColorMap mapping from srcBitMasks into canonical ARGB space"
	^self mappingFrom: srcBitMasks to: #(16rFF0000 16rFF00 16rFF 16rFF000000)! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'!
shifts: shiftArray masks: maskArray
	^self shifts: shiftArray masks: maskArray colors: nil.! !

!ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'!
shifts: shiftArray masks: maskArray colors: colorArray
	^self new setShifts: shiftArray masks: maskArray colors: colorArray! !
FormCanvas subclass: #ColorPatchCanvas
	instanceVariableNames: 'stopMorph foundMorph doStop '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!ColorPatchCanvas commentStamp: '<historical>' prior: 0!
I generate patches of Morphic worlds that views below certain Morphs. This facility is used for the end-user scripting system.!


!ColorPatchCanvas methodsFor: 'initialize-release' stamp: 'ar 6/22/1999 16:18'!
reset
	"Initialize the receiver to act just as a FormCanvas"
	super reset.
	foundMorph _ false.
	doStop _ false.
	stopMorph _ nil.! !


!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
doStop
	^doStop! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
doStop: aBoolean
	doStop _ aBoolean! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:15'!
foundMorph
	^foundMorph! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:38'!
foundMorph: aBoolean
	foundMorph _ aBoolean! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'!
stopMorph
	^stopMorph! !

!ColorPatchCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 16:14'!
stopMorph: aMorph
	stopMorph _ aMorph! !


!ColorPatchCanvas methodsFor: 'drawing-general' stamp: 'ar 6/22/1999 16:14'!
fullDrawMorph: aMorph
	(foundMorph and:[doStop]) ifTrue:[^self]. "Found it and should stop"
	aMorph == stopMorph ifTrue:[
		"Never draw the stopMorph"
		foundMorph _ true.
		^self].
	^super fullDrawMorph: aMorph.! !


!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:34'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	| tempCanvas |
	tempCanvas _ (self copyClipRect: aRectangle).
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:42'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock.
	Note: This does *not* include the state in the receiver (e.g., foundMorph)."
	| tempCanvas |
	tempCanvas _ self copy.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 2/17/2000 00:15'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"Note: This method has been originally copied from TransformationMorph."
	| innerRect patchRect sourceQuad warp start subCanvas |
	(aDisplayTransform isPureTranslation) ifTrue:[
		subCanvas _ self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect.
		aBlock value: subCanvas.
		foundMorph _ subCanvas foundMorph.
		^self
	].
	"Prepare an appropriate warp from patch to innerRect"
	innerRect _ aClipRect.
	patchRect _ aDisplayTransform globalBoundsToLocal:
					(self clipRect intersect: innerRect).
	sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect)
					collect: [:p | p - patchRect topLeft].
	warp _ self warpFrom: sourceQuad toRect: innerRect.
	warp cellSize: cellSize.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	start _ (self depth = 1 and: [self isShadowDrawing not])
		"If this is true B&W, then we need a first pass for erasure."
		ifTrue: [1] ifFalse: [2].
	start to: 2 do:
		[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
		subCanvas _ ColorPatchCanvas extent: patchRect extent depth: self depth.
		subCanvas stopMorph: stopMorph.
		subCanvas foundMorph: foundMorph.
		subCanvas doStop: doStop.
		i=1	ifTrue: [subCanvas shadowColor: Color black.
					warp combinationRule: Form erase]
			ifFalse: [self isShadowDrawing ifTrue:
					[subCanvas shadowColor: self shadowColor].
					warp combinationRule: Form paint].
		subCanvas translateBy: patchRect topLeft negated
			during:[:offsetCanvas| aBlock value: offsetCanvas].
		i = 2 ifTrue:[foundMorph _ subCanvas foundMorph].
		warp sourceForm: subCanvas form; warpBits.
		warp sourceForm: nil.  subCanvas _ nil "release space for next loop"]
! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:39'!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOffset: delta clipRect: aRectangle.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:39'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOffset: delta.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !

!ColorPatchCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 16:40'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	| tempCanvas |
	tempCanvas _ self copyOrigin: newOrigin clipRect: aRectangle.
	aBlock value: tempCanvas.
	foundMorph _ tempCanvas foundMorph.! !


!ColorPatchCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 16:18'!
setForm: aForm
	"Initialize the receiver to act just as a FormCanvas"
	super setForm: aForm.
	stopMorph _ nil.
	doStop _ false.
	foundMorph _ false.! !
SketchMorph subclass: #ColorPickerMorph
	instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency '
	classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransText TransparentBox '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ColorPickerMorph methodsFor: 'initialization' stamp: 'di 9/28/2000 12:05'!
buildChartForm
	| chartForm |
	chartForm _ ColorChart deepCopy asFormOfDepth: Display depth.
	chartForm fill: ((TransparentBox left + 9)@0 extent: 1@9) fillColor: Color lightGray.
	chartForm fill: ((TransparentBox right - 10)@0 extent: 1@9) fillColor: Color lightGray.
	TransText displayOn: chartForm at: 62@0.
	Display depth = 32 ifTrue:
		["Set opaque bits for 32-bit display"
		chartForm fill: chartForm boundingBox rule: Form under
				fillColor: (Color r: 0.0 g: 0.0 b: 0.0 alpha: 1.0)].
	chartForm borderWidth: 1.
	self form: chartForm.
	selectedColor ifNotNil: [self updateAlpha: selectedColor alpha].
	self updateSelectorDisplay.

! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'sw 9/8/2000 18:14'!
choseModalityFromPreference
	"Decide whether to be modal or not by consulting the prevailing preference"

	self initializeModal: Preferences modalColorPickers! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'RAA 2/1/2001 13:43'!
initialize
	"Initialize the receiver.  Obey the modalColorPickers preference when deciding how to configure myself.  This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here"

	super initialize.
	self buildChartForm.
	
	selectedColor _ Color white.
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	clickedTranslucency _ false.
	updateContinuously _ true.
	selector _ nil.
	target _ nil! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'di 9/27/2000 13:29'!
initializeModal: beModal
	"Initialize the receiver.  If beModal is true, it will be a modal color picker, else not"

	isModal _ beModal.
	self removeAllMorphs.
	isModal ifFalse:
		[theSelectorDisplayMorph _ AlignmentMorph newRow
			color: Color white;
			borderWidth: 1;
			borderColor: Color red;
			hResizing: #shrinkWrap;
			vResizing: #shrinkWrap;
			addMorph: (StringMorph contents: 'theSelector').
		self addMorph: theSelectorDisplayMorph.

		self addMorph: (SimpleButtonMorph new borderWidth: 0;
			label: 'x' font: nil; color: Color transparent;
			actionSelector: #delete; target: self; useSquareCorners;
			position: self topLeft - (0@3); extent: 10@12;
			setCenteredBalloonText: 'dismiss color picker')].

	self addMorph: ((Morph newBounds: (DragBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'put me somewhere').
	self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'restore original color').
	self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'shows selected color').
	self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft))
			color: Color transparent; setCenteredBalloonText: 'adjust translucency').

	self buildChartForm.
	
	selectedColor ifNil: [selectedColor _ Color white].
	sourceHand _ nil.
	deleteOnMouseUp _ false.
	updateContinuously _ true.
! !

!ColorPickerMorph methodsFor: 'initialization' stamp: 'sma 4/22/2000 19:39'!
updateSelectorDisplay
	theSelectorDisplayMorph ifNil: [^self].
	theSelectorDisplayMorph position: self bottomLeft.
	theSelectorDisplayMorph firstSubmorph contents: selector asString , ' ' , selectedColor printString! !


!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'!
argument
	^argument! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'!
argument: anObject
	argument _ anObject! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp

	^ deleteOnMouseUp
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp: aBoolean

	deleteOnMouseUp _ aBoolean.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'di 9/28/2000 11:47'!
originalColor: colorOrSymbol
	"Set the receiver's original color.  It is at this point that a command is launched to represent the action of the picker, in support of Undo."

	originalColor _ (colorOrSymbol isKindOf: Color)
		ifTrue: [colorOrSymbol]
		ifFalse: [Color lightGreen].
	originalForm fill: RevertBox fillColor: originalColor.
	selectedColor _ originalColor.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selectedColor

	^ selectedColor
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selector

	^ selector
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'di 8/30/2000 13:40'!
selector: aSymbol
	"Set the selector to be associated with the receiver.  Store it in the receiver's command, if appropriate"

	selector _ aSymbol.
	self updateSelectorDisplay! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand

	^ sourceHand
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand: aHand

	sourceHand _ aHand.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
target

	^ target
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'sw 3/8/1999 14:28'!
target: anObject

	target _ anObject.
	(target respondsTo: #color)
		ifTrue: [selectedColor _ target color]
		ifFalse: [selectedColor _ Color white].
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously

	^ updateContinuously
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously: aBoolean

	updateContinuously _ aBoolean.
! !


!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'di 9/27/2000 13:19'!
mouseDown: evt
	| localPt |
	localPt _ evt cursorPoint - self topLeft.
	self deleteAllBalloons.
	clickedTranslucency _ TransparentBox containsPoint: localPt.
	(DragBox containsPoint: localPt)
		ifTrue: [^ evt hand grabMorph: self].
	(RevertBox containsPoint: localPt)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].
	self comeToFront.
	sourceHand _ evt hand.
	self startStepping.
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:46'!
mouseUp: evt

	self stopStepping.
	sourceHand _ nil.
	deleteOnMouseUp ifTrue: [self delete].
	self updateTargetColor.
! !


!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'!
step

	sourceHand ifNotNil:
		[self pickColorAt: sourceHand position].
! !

!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'!
stepTime

	^ 50
! !


!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/27/2000 10:36'!
anchorAndRunModeless: aHand
	"If user clicks on the drag-dot of a modal picker,
	anchor it, and change to modeless operation."

	aHand showTemporaryCursor: nil.  "revert to normal cursor"
	self initializeModal: false; originalColor: originalColor.  "reset as modeless"
	aHand flushEvents.  "Drop any events gathered during modal loop"
	aHand position: Sensor cursorPoint; grabMorph: self.  "Slip into drag operation"
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 8/30/2000 13:47'!
argumentsWith: aColor
	"Return an argument array appropriate to this action selector"

	| nArgs |
	nArgs _ selector numArgs.
	nArgs = 1 ifTrue:[^ {aColor}].
	nArgs = 2 ifTrue:[^ {aColor. sourceHand}].
	nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/27/2000 12:55'!
deleteAllBalloons

	self submorphsDo: [:m | m deleteBalloon].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'ar 10/3/2000 17:05'!
modalBalloonHelpAtPoint: cursorPoint
	self flag: #arNote. "Throw this away. There needs to be another way."
	self submorphsDo:
		[:m | m wantsBalloon ifTrue:
			[(m valueOfProperty: #balloon) == nil
				ifTrue: [(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]]
				ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! !

!ColorPickerMorph methodsFor: 'private' stamp: 'RAA 2/1/2001 13:43'!
pickColorAt: aGlobalPoint 

	| alpha selfRelativePoint pickedColor |

	clickedTranslucency ifNil: [clickedTranslucency _ false].
	selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft.
	(FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
	(RevertBox containsPoint: selfRelativePoint)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].

	"check for transparent color and update using appropriate feedback color "
	(TransparentBox containsPoint: selfRelativePoint) ifTrue:
		[clickedTranslucency ifFalse: [^ self].  "Can't wander into translucency control"
		alpha _ (selfRelativePoint x - TransparentBox left - 10) asFloat /
							(TransparentBox width - 20)
							min: 1.0 max: 0.0.
					"(alpha roundTo: 0.01) printString , '   ' displayAt: 0@0." " -- debug"
		self 
			updateColor: (selectedColor alpha: alpha)
			feedbackColor: (selectedColor alpha: alpha).
		^ self].

	"pick up color, either inside or outside this world"
	clickedTranslucency ifTrue: [^ self].  "Can't wander out of translucency control"
	pickedColor _ Display colorAt: aGlobalPoint.
	self 
		updateColor: (
			(selectedColor isColor and: [selectedColor isTranslucentColor])
						ifTrue: [pickedColor alpha: selectedColor alpha]
						ifFalse: [pickedColor]
		)
		feedbackColor: pickedColor! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/30/2000 10:07'!
trackColorAt: aGlobalPoint 
	"Before the mouse comes down in a modal color picker, track the color under the cursor, and show it in the feedback box, but do not make transparency changes"

	| selfRelativePoint pickedColor |
	selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft.
	(FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self].
	(RevertBox containsPoint: selfRelativePoint)
		ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor].

	"check for transparent color and update using appropriate feedback color "
	(TransparentBox containsPoint: selfRelativePoint) ifTrue: [^ self].

	"pick up color, either inside or outside this world"
	pickedColor _ Display colorAt: aGlobalPoint.
	self updateColor: (pickedColor alpha: originalColor alpha)
		feedbackColor: pickedColor! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/28/2000 11:10'!
updateAlpha: alpha
	| sliderRect |
	sliderRect _ (TransparentBox left + 10)@1 corner: (TransparentBox right - 9)@9.
	originalForm fill: (sliderRect withRight: sliderRect left + (alpha*sliderRect width))
				fillColor: Color lightGray.
	originalForm fillWhite: (sliderRect withLeft: sliderRect left + (alpha*sliderRect width)).
	originalForm fill: ((TransparentBox right - 9)@1 extent: 8@8)
				fillColor: (alpha < 1.0 ifTrue: [Color white] ifFalse: [Color lightGray]).
	TransText displayOn: originalForm at: 62@1 rule: Form paint.
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 9/28/2000 10:38'!
updateColor: aColor feedbackColor: feedbackColor
	"Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil." 

	selectedColor = aColor ifTrue: [^ self].  "do nothing if color doesn't change"

	self updateAlpha: aColor alpha.
	originalForm fill: FeedbackBox fillColor: feedbackColor.
	self form: originalForm.
	selectedColor _ aColor.
	updateContinuously ifTrue: [self updateTargetColor].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'LC 2/2/2000 03:17'!
updateTargetColor
	| nArgs |
	(target ~~ nil and: [selector ~~ nil]) ifTrue:
		[self updateSelectorDisplay.
		nArgs _ selector numArgs.
		nArgs = 1 ifTrue:[^target perform: selector with: selectedColor].
		nArgs = 2 ifTrue:[^target perform: selector with: selectedColor with: sourceHand].
		nArgs = 3 ifTrue:[^target perform: selector with: selectedColor with: argument with: sourceHand]].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'di 8/30/2000 13:47'!
updateTargetColorWith: aColor
	"Update the target so that it reflects aColor as the color choice"

	(target ~~ nil and: [selector ~~ nil]) ifTrue:
		[self updateSelectorDisplay.
		^ target perform: selector withArguments: (self argumentsWith: aColor)]
! !


!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	deleteOnMouseUp
		ifTrue: [aCustomMenu add: 'stay up' action: #toggleDeleteOnMouseUp]
		ifFalse: [aCustomMenu add: 'do not stay up' action: #toggleDeleteOnMouseUp].
	updateContinuously
		ifTrue: [aCustomMenu add: 'update only at end' action: #toggleUpdateContinuously]
		ifFalse: [aCustomMenu add: 'update continuously' action: #toggleUpdateContinuously].
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'di 9/28/2000 11:44'!
pickUpColorFor: aMorph
	"Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle"

      | aHand localPt |
	aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand].
	aHand ifNil: [aHand _ self currentHand].
	self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds.
	self owner ifNil: [^ self].

	aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) 
			hotSpotOffset: 6 negated @ 4 negated.    "<<<< the form was changed a bit??"

	self updateContinuously: false.
	[Sensor anyButtonPressed]
		whileFalse: 
			 [self trackColorUnderMouse].
	self deleteAllBalloons.

	(DragBox containsPoint: (localPt _ Sensor cursorPoint - self topLeft)) ifTrue:
		["Click or drag the drag-dot means to anchor as a modeless picker"
		^ self anchorAndRunModeless: aHand].
	(clickedTranslucency _ TransparentBox containsPoint: localPt)
		ifTrue: [selectedColor _ originalColor].

	self updateContinuously: true.
	[Sensor anyButtonPressed]
		whileTrue:
			 [self updateTargetColorWith: self indicateColorUnderMouse].
	aHand newMouseFocus: nil;
		showTemporaryCursor: nil;
		flushEvents.
	self delete.
		 
 ! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleDeleteOnMouseUp

	deleteOnMouseUp _ deleteOnMouseUp not.
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleUpdateContinuously

	updateContinuously _ updateContinuously not.
! !


!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 09:12'!
addToWorld: world near: box
	| goodLocation |
	goodLocation _ self bestPositionNear: box inWorld: world.
	world allMorphsDo:
		[:p | (p isMemberOf: ColorPickerMorph) ifTrue:
		[(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue:
			[(p selector == selector and: [p argument == argument])
				ifTrue: [^ p comeToFront  "uncover existing picker"]
				ifFalse: ["place second picker relative to first"
						goodLocation _ self bestPositionNear: p bounds inWorld: world]]]].
	self position: goodLocation.
	world addMorphFront: self.
	self changed
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 11/27/1999 08:51'!
bestPositionNear: box inWorld: world
	| points b |
	points _ #(topCenter rightCenter bottomCenter leftCenter).  "possible anchors"
	1 to: 4 do:
		[:i |  "Try the four obvious anchor points"
		b _ self bounds align: (self bounds perform: (points at: i))
					with: (box perform: (points atWrap: i + 2)).
		(world viewBox containsRect: b) ifTrue:
			[^ b topLeft"  Yes, it fits"]].

	^ 20@20  "when all else fails"
! !

!ColorPickerMorph methodsFor: 'other' stamp: 'LC 2/2/2000 04:28'!
containsPoint: aPoint 
	^ (super containsPoint: aPoint)
		or: [RevertBox containsPoint: aPoint - self topLeft]! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/12/2000 10:00'!
delete
	"The moment of departure has come.  If the receiver has an affiliated command, finalize it and have the system remember it.  In any case, delete the receiver"

	self rememberCommand: 
		(Command new
			cmdWording: 'color change';
			undoTarget: target selector: selector arguments: (self argumentsWith: originalColor);
			redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)).
	super delete! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/3/1999 13:34'!
drawOn: aCanvas
	aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: self bounds color: Color white].
	Display depth = originalForm depth ifFalse: [self buildChartForm].
	super drawOn: aCanvas! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/25/2000 15:38'!
indicateColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt |
	self pickColorAt: (pt _ Sensor cursorPoint).
	isModal ifTrue:
		[self activeHand position: pt.
		self world displayWorldSafely; runStepMethods].
	^ selectedColor	! !

!ColorPickerMorph methodsFor: 'other' stamp: 'sw 7/6/1999 09:00'!
isCandidateForAutomaticViewing
	^ false! !

!ColorPickerMorph methodsFor: 'other' stamp: 'sw 7/6/1999 09:07'!
isLikelyRecipientForMouseOverHalos
	^ false! !

!ColorPickerMorph methodsFor: 'other' stamp: 'ar 12/8/2000 15:32'!
putUpFor: aMorph near: aRectangle
	"Put the receiver up on the screen.   Note highly variant behavior depending on the setting of the #modalColorPickers preference"
	| layerNumber |
	aMorph isMorph ifTrue: [
		layerNumber _ aMorph morphicLayerNumber.
		aMorph allOwnersDo:[:m|
			layerNumber _ layerNumber min: m morphicLayerNumber].
		self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
	].

	isModal == true "backward compatibility"
		ifTrue:
			[self pickUpColorFor: aMorph]
		ifFalse:
			[self addToWorld:
				((aMorph notNil and: [aMorph world notNil])
					ifTrue:
						[aMorph world]
					ifFalse:
						[self currentWorld])
		  		near:
					(aRectangle ifNil:
						[aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]! !

!ColorPickerMorph methodsFor: 'other' stamp: 'di 9/27/2000 11:48'!
trackColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt |
	selectedColor _ originalColor.
	self trackColorAt: (pt _ Sensor cursorPoint).
	isModal ifTrue:
		[self activeHand position: pt.
		self world displayWorldSafely; runStepMethods.
		self modalBalloonHelpAtPoint: pt].
	^ selectedColor	! !


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

ColorPickerMorph class
	instanceVariableNames: ''!

!ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'di 9/28/2000 11:09'!
initialize
	"ColorPickerMorph initialize"

	ColorChart _ Color colorPaletteForDepth: 16 extent: 190@60.
	DragBox _  (11@0) extent: 9@8.
	RevertBox _ (ColorChart width - 20)@1 extent: 9@8.
	FeedbackBox _ (ColorChart width - 10)@1 extent: 9@8.
	TransparentBox _ DragBox topRight corner: RevertBox bottomLeft.

		ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1@9).
		ColorChart fillBlack: ((TransparentBox left)@0 extent: 1@9).
		ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1@9).
		ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1@9).
		(Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0@1).

	TransText _ (Form extent: 63@8 depth: 1   "Where there's a will there's a way..."
			fromArray: #(4194306 1024 4194306 1024 15628058 2476592640
					4887714 2485462016 1883804850 2486772764 4756618
					2485462016 4748474 1939416064 0 0)
			offset: 0@0).
	TransText _ ColorForm mappingWhiteToTransparentFrom: TransText
! !

!ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 11:40'!
perniciousBorderColor
	"Answer the color of the border lines of a color picker; this color gets reported as you drag the mouse through from the translucent box to the true color area, for example, and can cause some difficulties in some special cases, so it is faithfully reported here in this hard-coded fashion in order that energetic clients wishing to handle it as special-case it can do so."

	^ Color r: 0.0 g: 0.0 b: 0.032! !
ColorTileMorph subclass: #ColorSeerTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!ColorSeerTile methodsFor: 'initialization' stamp: 'sw 9/17/1999 08:02'!
initialize

	| m1 m2 desiredW |
	super initialize.
	self removeAllMorphs.	"get rid of the parts of a regular Color tile"
	type _ #operator.
	operatorOrExpression _ #color:sees:.
	m1 _ StringMorph contents: 'color    sees' font: ScriptingSystem fontForTiles.
	m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0).
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 5).
	m2 position: (bounds center x - (m2 width // 2) + 3) @ (bounds top + 8).
	self addMorph: m1; addMorphFront: m2.
	colorSwatch _ m2.
	! !


!ColorSeerTile methodsFor: 'code generation' stamp: 'jm 5/28/1998 19:19'!
storeCodeOn: aStream indent: tabCount
	"We have a hidden arg. Output two keywords with interspersed arguments."

	| parts |
	parts _ operatorOrExpression keywords.	"color:sees:"
	^ aStream nextPutAll: (parts at: 1); space;
		nextPutAll: colorSwatch color printString; space;
		nextPutAll: (parts at: 2).
! !


!ColorSeerTile methodsFor: 'display' stamp: 'tk 12/3/97 09:51'!
updateLiteralLabel
	"Do nothing"! !
UpdatingRectangleMorph subclass: #ColorSwatch
	instanceVariableNames: 'argument '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!

!ColorSwatch methodsFor: 'as yet unclassified' stamp: 'sw 7/13/1999 13:39'!
argument: arg
	argument _ arg! !

!ColorSwatch methodsFor: 'as yet unclassified' stamp: 'sw 7/13/1999 15:09'!
readFromTarget

	| v |
	((target == nil) or: [getSelector == nil]) ifTrue: [^ contents].
	v _ target scriptPerformer perform: getSelector with: argument.
	lastValue _ v.
	^ v ! !

!ColorSwatch methodsFor: 'as yet unclassified' stamp: 'sw 7/13/1999 13:48'!
setTargetColor: aColor
	putSelector ifNotNil:
		[self color: aColor.
		contents _ aColor.
		target scriptPerformer perform: self putSelector withArguments: (Array with: argument with: aColor)]
! !

!ColorSwatch methodsFor: 'as yet unclassified' stamp: 'sw 7/13/1999 18:39'!
stepTime
	^ 1000! !
StandardSystemView subclass: #ColorSystemView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!

!ColorSystemView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !

!ColorSystemView methodsFor: 'as yet unclassified' stamp: 'di 2/26/98 08:58'!
displayDeEmphasized 
	"Display this view with emphasis off.
	If windowBits is not nil, then simply BLT if possible."
	bitsValid
		ifTrue: [self lock.
				windowBits displayAt: self windowOrigin]
		ifFalse: [super displayDeEmphasized]
! !
TileMorph subclass: #ColorTileMorph
	instanceVariableNames: 'colorSwatch '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!ColorTileMorph methodsFor: 'initialization'!
initialize

	super initialize.
	type _ #literal.
	self addColorSwatch.
! !


!ColorTileMorph methodsFor: 'events'!
handlesMouseDown: evt

	(colorSwatch containsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!ColorTileMorph methodsFor: 'events'!
mouseDown: evt

	(colorSwatch containsPoint: evt cursorPoint)
		ifFalse: [super mouseDown: evt].
! !

!ColorTileMorph methodsFor: 'events' stamp: 'ar 10/5/2000 18:51'!
mouseUp: evt
	self changeColorTarget: colorSwatch selector: #userSelectedColor: originalColor: colorSwatch color hand: evt hand! !


!ColorTileMorph methodsFor: 'other' stamp: 'sw 12/7/1999 18:51'!
addColorSwatch

	| m1 m2 desiredW |
	m1 _ StringMorph contents: 'color' font: (StrikeFont familyName: #NewYork size: 12).
	m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0).
	desiredW _ m1 width + 6.
	self extent: (desiredW max: self basicWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
	m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1).
	self addMorph: m1; addMorph: m2.
	colorSwatch _ m2! !

!ColorTileMorph methodsFor: 'other' stamp: 'sw 10/25/1998 00:25'!
colorSwatch
	^ colorSwatch! !

!ColorTileMorph methodsFor: 'other' stamp: 'sw 6/10/1998 17:49'!
colorSwatchColor: aColor
	colorSwatch color: aColor! !

!ColorTileMorph methodsFor: 'other' stamp: 'jm 6/25/97 17:38'!
resultType

	^ #color! !

!ColorTileMorph methodsFor: 'other' stamp: 'sw 1/6/1999 10:41'!
setLiteral: aLiteral
	colorSwatch color: aLiteral! !

!ColorTileMorph methodsFor: 'other' stamp: 'jm 5/28/1998 19:02'!
storeCodeOn: aStream indent: tabCount

	aStream nextPutAll: colorSwatch color printString.
! !

!ColorTileMorph methodsFor: 'other' stamp: 'sw 1/6/1999 10:43'!
updateLiteralLabel
	"Do nothing"! !
StringHolder subclass: #ColumnsTester
	instanceVariableNames: 'mainIndex listMorph theList smallTest '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'sbw-experiments'!
!ColumnsTester commentStamp: '<historical>' prior: 0!
A lot of code in here was cloned from ChatNotes.

This class is a tester for the PluggableMultiColumnListMorph.


See the instance method #listArray for two ways you can exercise this widget.

To use it just evaluate the #test class method.!


!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:17'!
addToTestList
	| entry |
	entry _ self queryForNewEntry.
	entry isNil
		ifTrue: [^ nil].
	1 to: entry size do: [:index |
		(theList at: index) add: (entry at: index)].
	self changed: #listArray! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:18'!
bigList
	^ Array
		with: Smalltalk classNames asOrderedCollection
		with: Smalltalk classNames reversed asOrderedCollection
		with: Smalltalk classNames asSet asArray asOrderedCollection
		with: (Smalltalk classNames
				collect: [:each | each size printString]) asOrderedCollection! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 11/30/2000 22:14'!
defaultBackgroundColor
	"In a better design, this would be handled by preferences."
	^ Color
		r: 1.0
		g: 0.9
		b: 0.8! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 11/30/2000 22:15'!
initialExtent
	^ 300 @ 200! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:01'!
inspectList
	theList inspect! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:01'!
inspectListMorph
	listMorph inspect! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:02'!
inspectMe
	self inspect! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:01'!
listArray
	"Use #bigList here for a large four column list amd #smallList for a  
	short three column test."
	theList == nil ifTrue: [self populateInitialList].
	^ theList! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:02'!
listMenu: aMenu 
	^ aMenu
		labels: 'add
remove
inspect me
inspect list
inspect list morph'
		lines: #(2 )
		selections: #(#addToTestList #removeFromTestList #inspectMe #inspectList inspectListMorph)! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 12/25/2000 22:29'!
mainList
	^ #('One' 'Two' 'Three Little Pigs Went To Market' 'Fourteen' 'Linux')! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 11/30/2000 22:21'!
mainListIndex

	mainIndex == nil ifTrue: [mainIndex _ 0].
	^mainIndex! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 11/30/2000 22:23'!
mainListIndex: index 
	mainIndex _ index.
	self changed: #mainListIndex! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 12/25/2000 22:29'!
minorList
	^ #(1.2 3.4 5.6 7.8 0.006)
		collect: [:n | n printString]! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 06:56'!
openAsMorph
	| window |
	window _ (SystemWindow labelled: 'Columns Tester')
				model: self.
	listMorph _ PluggableMultiColumnListMorph
				on: self
				list: #listArray
				selected: #mainListIndex
				changeSelected: #mainListIndex:
				menu: #listMenu:.
	window
		addMorph: (listMorph
				autoDeselect: false)
		frame: (0 @ 0 corner: 1.0 @ 1.0).
	window openInWorld! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:25'!
populateInitialList
	"Use #bigList here for a large four column list amd #smallList for a  
	short three column test."
	smallTest == nil ifTrue: [smallTest _ true].
	theList _ (smallTest
				ifTrue: [self smallList]
				ifFalse: [self bigList]) asOrderedCollection! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:06'!
queryColumnEntry: column default: defaultString
	^FillInTheBlank
		request: 'New entry for column ', column printString, '?'
		initialAnswer: defaultString! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:10'!
queryForNewEntry

	| array entry |
	array _ Array new: theList size.
	1 to: array size do: [:column |
		entry _ self queryColumnEntry: column default: column printString.
		entry isEmpty ifTrue: [^nil].
		array at: column put: entry].
	^array
! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 2/1/2001 10:59'!
removeFromTestList
	mainIndex = 0
		ifTrue: [^ self].
	(self confirm: 'Really delete row ' , mainIndex printString , '?')
		ifFalse: [^ self].
	1
		to: theList size
		do: [:index | (theList at: index)
				removeAt: mainIndex].
	self changed: #listArray.
	self mainListIndex: 0! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 12/25/2000 22:29'!
secondList
	^ #('aaaa' 'bbbb' 'cccc' 'dddd' 'linux')! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:22'!
setBigTest
	smallTest _ false! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:21'!
setSmallTest

	smallTest _ true! !

!ColumnsTester methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:18'!
smallList
	^ Array
		with: self mainList asOrderedCollection
		with: self secondList asOrderedCollection
		with: self minorList asOrderedCollection! !

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

ColumnsTester class
	instanceVariableNames: ''!

!ColumnsTester class methodsFor: 'as yet unclassified' stamp: 'sbw 11/30/2000 22:13'!
openAsMorph
	^ self new openAsMorph! !

!ColumnsTester class methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:24'!
test
	"(Smalltalk at: #ColumnsTester) test"
	self testSmall! !

!ColumnsTester class methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:23'!
testBig
	"(Smalltalk at: #ColumnsTester) testBig"
	| model |
	model _ self new.
	model setBigTest.
	model openAsMorph! !

!ColumnsTester class methodsFor: 'as yet unclassified' stamp: 'sbw 1/31/2001 07:23'!
testSmall
	"(Smalltalk at: #ColumnsTester) testSmall"
	| model |
	model _ self new.
	model setSmallTest.
	model openAsMorph! !
Object subclass: #Command
	instanceVariableNames: 'phase cmdWording undoTarget undoSelector undoArguments redoTarget redoSelector redoArguments parameters '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Undo'!
!Command commentStamp: '<historical>' prior: 0!
An object representing an undoable command to be done in the environment.

Structure:
	phase			indicates whether the cmd is current in undone or redone mode
 	cmdWording		The wording of the command (used in arming the "undo"/"redo" menu items
 	parameters		an IdentityDictionary /NOT USED/
	undoTarget		Receiver, selector and arguments to accomplish undo
	undoSelector
	undoArguments
	redoTarget		Receiver, selector and arguments to accomplish redo
	redoSelector
	redoArguments

To use this, for any command you wish to use, you
	*	Create an instance of Command, as follows...
			cmd _ Command new cmdWording: 'resizing'.
	*	Give the the command undo state and redo state, as follows...
			cmd undoTarget: target selector: #extent: argument: oldExtent.
			cmd redoTarget: target selector: #extent: argument: newExtent.
	*	Send a message of the form
			Command rememberCommand: cmd

LastCommand is the last command that was actually done or undone.

CommandHistory, applicable only when infiniteUndo is set, holds a 'tape' of the complete history of commands, as far back as it's possible to go.

CommandExcursions, also applicable only in the infiniteUndo case, and rather at the fringe even then, holds segments of former CommandHistory that have been lopped off because of variant paths taken.!


!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:12'!
cmdWording: wrd
	"Set the wording to be used in a menu item referring to the receiver"

	cmdWording _ wrd! !

!Command methodsFor: 'initialization' stamp: 'sw 8/29/2000 14:13'!
phase: aPhase
	"Set the phase of the command to the supplied symbol"

	phase _ aPhase! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 14:09'!
printOn: aStream
	"Provide more detailed info about the receiver, put in for debugging, maybe should be removed"

	super printOn: aStream.
	aStream nextPutAll: ' phase: ', phase printString.
	cmdWording ifNotNil: [aStream nextPutAll: '; ', cmdWording asString].
	parameters ifNotNil:
		[parameters associationsDo:
			[:assoc | aStream nextPutAll: ': ', assoc printString]]! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'!
redoTarget: target selector: aSymbol argument: argument

	^ self redoTarget: target selector: aSymbol arguments: {argument}! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'!
redoTarget: target selector: selector arguments: arguments
	"Give target morph a chance to refine its undo operation"

	target refineRedoTarget: target selector: selector arguments: arguments in:
		[:rTarget :rSelector :rArguments |
		redoTarget _ rTarget.
		redoSelector _ rSelector.
		redoArguments _ rArguments]! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 13:04'!
undoTarget: target selector: aSymbol argument: argument

	^ self undoTarget: target selector: aSymbol arguments: {argument}! !

!Command methodsFor: 'initialization' stamp: 'di 8/30/2000 20:53'!
undoTarget: target selector: selector arguments: arguments
	"Give target morph a chance to refine its undo operation"

	target refineUndoTarget: target selector: selector arguments: arguments in:
		[:rTarget :rSelector :rArguments |
		undoTarget _ rTarget.
		undoSelector _ rSelector.
		undoArguments _ rArguments]! !


!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol
	"Answer the parameter stored at the given symbol, or nil if none"

	^ self parameterAt: aSymbol ifAbsent: [nil]! !

!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol ifAbsent: aBlock
	"Answer the parameter stored at the aSymbol, but if none, return the result of evaluating aBlock"

	^ self assuredParameterDictionary at: aSymbol ifAbsent: [aBlock value]! !

!Command methodsFor: 'parameters' stamp: 'sw 8/29/2000 14:12'!
parameterAt: aSymbol put: aValue
	"Place aValue in the parameters dictionary using aSymbol as key"

	^ self assuredParameterDictionary at: aSymbol put: aValue! !


!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'!
doCommand
	"Do the command represented by the receiver.  Not actually called by active current code, but reachable by the not-yet-unsealed promoteToCurrent: action."

	redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! !

!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:04'!
redoCommand
	"Perform the 'redo' operation"

	redoTarget ifNotNil: [redoTarget perform: redoSelector withArguments: redoArguments]! !

!Command methodsFor: 'command execution' stamp: 'di 8/30/2000 16:02'!
undoCommand
	"Perform the 'undo' operation"

	undoTarget ifNotNil: [undoTarget perform: undoSelector withArguments: undoArguments]! !


!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:09'!
assuredParameterDictionary
	"Private!!  Answer the parameters dictionary, creating it if necessary"

	^ parameters ifNil: [parameters _ IdentityDictionary new]! !

!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:12'!
cmdWording
	"Answer the wording to be used to refer to the command in a menu"

	^ cmdWording ifNil: ['last command']! !

!Command methodsFor: 'private' stamp: 'sw 8/29/2000 14:13'!
phase
	"Answer the phase of the command"

	^ phase! !

!Command methodsFor: 'private' stamp: 'di 12/12/2000 12:36'!
undoTarget
	^ undoTarget! !

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

Command class
	instanceVariableNames: ''!

!Command class methodsFor: 'class initialization' stamp: 'RAA 9/21/2000 14:02'!
zapObsolete
"Command zapObsolete"
	"kill some obsolete stuff still retained by the CompiledMethods in change records"

	| before after histories lastCmd histCount lastCount |
	Smalltalk garbageCollect.
	before _ Command allInstances size.
	histories _ Association allInstances select: [ :each | 
		each key == #CommandHistory and: [
			(each value isKindOf: OrderedCollection) and: [
				each value isEmpty not and: [
					each value first isKindOf: Command]]]
	].
	histCount _ histories size.
	lastCmd _ Association allInstances select: [ :each | 
		each key == #LastCommand and: [each value isKindOf: Command]
	].
	lastCount _ lastCmd size.
	histories do: [ :each | each value: OrderedCollection new].
	lastCmd do: [ :each | each value: Command new].
	Smalltalk garbageCollect.
	Smalltalk garbageCollect.
	after _ Command allInstances size.
	Transcript show: {before. after. histCount. histories. lastCount. lastCmd} printString; cr; cr.
	! !







!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
redoEnabled
	| w |
	^(w _ self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory redoEnabled]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
redoNextCommand
	| w |
	^(w _ self currentWorld) == nil ifFalse:[w commandHistory redoNextCommand]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:13'!
undoEnabled
	| w |
	^(w _ self currentWorld) == nil ifTrue:[false] ifFalse:[w commandHistory undoEnabled]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 8/31/2000 23:14'!
undoLastCommand
	| w |
	^(w _ self currentWorld) == nil ifFalse:[w commandHistory undoLastCommand]! !

!Command class methodsFor: 'dog simple ui' stamp: 'ar 11/9/2000 20:38'!
undoRedoButtons
	"Answer a morph that offers undo and redo buttons"

	| aButton wrapper |
	"self currentHand attachMorph: Command undoRedoButtons"
	wrapper _ AlignmentMorph newColumn.
	wrapper color: Color veryVeryLightGray lighter;
		borderWidth: 0;
		layoutInset: 0;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap.
	#((CrudeUndo undoLastCommand 'undo last command done' undoEnabled CrudeUndoDisabled CrudeUndoDisabled) 
	(CrudeRedo redoNextCommand 'redo last undone command' redoEnabled CrudeRedoDisabled CrudeRedoDisabled)) do:
		[:tuple |
			wrapper addTransparentSpacerOfSize: (8@0).
			aButton _ UpdatingThreePhaseButtonMorph new.
			aButton
				onImage: (ScriptingSystem formAtKey: tuple first);
				offImage: (ScriptingSystem formAtKey: tuple fifth);
				pressedImage: (ScriptingSystem formAtKey: tuple sixth);
				getSelector: tuple fourth;
				color: Color transparent; 
				target: self;
				actionSelector: tuple second;
				setNameTo: tuple second;
				setBalloonText: tuple third;
				extent: aButton onImage extent.
			wrapper addMorphBack: aButton.
			wrapper addTransparentSpacerOfSize: (8@0)].
	^ wrapper! !
Object subclass: #CommandHistory
	instanceVariableNames: 'lastCommand history excursions '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Undo'!

!CommandHistory methodsFor: 'initialize' stamp: 'ar 8/31/2000 22:50'!
initialize
	lastCommand _ nil.
	history _ OrderedCollection new.
	excursions _ OrderedCollection new.! !


!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:41'!
nextCommandToUndo
	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #done ifTrue: [^ lastCommand].
	(lastCommand phase == #undone and:
		[(anIndex _ history indexOf: lastCommand) > 1])
		ifTrue: [^ history at: anIndex - 1]
		ifFalse: [^ nil]! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:39'!
redoEnabled
	"Answer whether the redo command is currently available"

	^ self nextCommand notNil! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:39'!
redoMenuWording
	"Answer the wording to be used in a menu offering the current Redo command"

	| nextCommand |

	((nextCommand _ self nextCommand) == nil or: [Preferences useUndo not]) ifTrue:  [^ 'can''t redo'].
	^ String streamContents:
		[:aStream | 
			aStream nextPutAll: 'redo "'.
			aStream nextPutAll: (nextCommand cmdWording truncateTo: 12).
			aStream nextPut: $".
			lastCommand phase == #done ifFalse:
				[aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:40'!
undoEnabled
	"Answer whether there is an undoable command at the ready"

	^ lastCommand notNil! !

!CommandHistory methodsFor: 'menu' stamp: 'sw 9/1/2000 11:00'!
undoMenuWording
	"Answer the wording to be used in an 'undo' menu item"

	(((lastCommand == nil or: [Preferences useUndo not]) or:
		[Preferences infiniteUndo not and: [lastCommand phase == #undone]])  or: 
			[self nextCommandToUndo == nil]) ifTrue: [^ 'can''t undo'].

	^ String streamContents:
		[:aStream | 
			aStream nextPutAll: 'undo "'.
			aStream nextPutAll: (self nextCommandToUndo cmdWording truncateTo: 12).
			aStream nextPut: $".
			lastCommand phase == #done ifTrue:
				[aStream nextPutAll: ' (z)']]! !

!CommandHistory methodsFor: 'menu' stamp: 'ar 8/31/2000 22:40'!
undoOrRedoMenuWording
	"Answer the wording to be used in a menu item offering undo/redo"

	| pre |
	lastCommand ifNil: [^ 'can''t undo'].
	pre _ lastCommand phase == #done
		ifTrue:		['undo']
		ifFalse:		['redo'].
	^ ((pre, ' ', lastCommand cmdWording) truncateTo: 30), ' (z)'! !


!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:44'!
historyIndexOfLastCommand
	"Answer which position of the CommandHistory list is occupied by the LastCommand"

	^ history indexOf: lastCommand ifAbsent: [0]! !

!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'!
lastCommand
	"Answer the last command done or undone"

	^ lastCommand! !

!CommandHistory methodsFor: 'command history' stamp: 'ar 8/31/2000 22:45'!
nextCommand
	"Answer the command object that would be sent the #redoCommand message if the user were to request Redo, or nil if none"

	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #undone ifTrue: [^ lastCommand].
	anIndex _ history indexOf: lastCommand ifAbsent: [^ nil].
	^ anIndex = history size ifTrue: [nil] ifFalse: [history at: (anIndex + 1)]! !

!CommandHistory methodsFor: 'command history' stamp: 'di 12/12/2000 13:46'!
resetCommandHistory    "CommandHistory allInstancesDo: [:ch | ch resetCommandHistory]"
	"Clear out the command history so that no commands are held"

	lastCommand _ nil.
	history _ OrderedCollection new.! !


!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:46'!
cantUndo
	"Called by client to indicate that the prior undoable command is no longer undoable"

	lastCommand _ nil.
	history _ OrderedCollection new.! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'ar 8/31/2000 22:47'!
promoteToCurrent: aCommand
	"Very unusual and speculative and unfinished!!.  Not currently reachable.  For the real thing, we presumably march forward or backward from the current command pointer to the target command in an orderly fashion, doing or undoing each command in turn."

	| itsIndex |
	Preferences useUndo ifFalse: [^ self].
	itsIndex _ history indexOf: aCommand ifAbsent: [nil].
	itsIndex ifNotNil:
		[history remove: aCommand ifAbsent: []].
	history add: (lastCommand _ aCommand).
	itsIndex < history size ifTrue:
		[excursions add: (history copyFrom: (itsIndex to: history size))].
	history _ (history copyFrom: 1 to: itsIndex) copyWith: aCommand.

	lastCommand _ aCommand.
	aCommand doCommand.
	lastCommand phase: #done.! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'di 12/12/2000 13:08'!
purgeAllCommandsSuchThat: cmdBlock
	"Remove a bunch of commands, as in [:cmd | cmd undoTarget == zort]"

	Preferences useUndo ifFalse: [^ self].
	history _ history reject: cmdBlock.
	history isEmpty
		ifTrue: [lastCommand _ nil]
		ifFalse: [lastCommand _ history last]! !

!CommandHistory methodsFor: 'called by programmer' stamp: 'di 12/12/2000 10:16'!
rememberCommand: aCommand
	"Make the supplied command be the 'LastCommand', and mark it 'done'"

	| currentCommandIndex |
	Preferences useUndo ifFalse: [^ self].  "Command initialize"

	Preferences infiniteUndo ifTrue:
		[currentCommandIndex _ history indexOf: lastCommand.
		((currentCommandIndex < history size) and: [Preferences preserveCommandExcursions]) ifTrue:
			[excursions add: (history copyFrom: (currentCommandIndex to: history size)).
			history _ history copyFrom: 1 to: currentCommandIndex].
		history addLast: aCommand].

	lastCommand _ aCommand.
	lastCommand phase: #done.! !


!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
commandToUndo
	"Undo the last command, i.e. move backward in the recent-commands tape, if possible."

	| anIndex |
	lastCommand ifNil: [^ nil].
	lastCommand phase == #done ifTrue: [^ lastCommand].
	(lastCommand phase == #undone and:
		[(anIndex _ history indexOf: lastCommand) > 1])
		ifTrue: [^ history at: anIndex - 1]
		ifFalse: [^ nil]
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
redoNextCommand
	"If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it."

	| anIndex |
	lastCommand ifNil: [^ self beep].
	lastCommand phase == #undone
		ifFalse:
			[anIndex _ history indexOf: lastCommand.
			(anIndex < history size)
				ifTrue:
					[lastCommand _ history at: anIndex + 1]
				ifFalse:
					[^ self beep]].

	lastCommand redoCommand.
	lastCommand phase: #done
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
undoLastCommand
	"Undo the last command, i.e. move backward in the recent-commands tape, if possible."

	| aPhase anIndex |
	lastCommand ifNil: [^ self beep].

	(aPhase _ lastCommand phase) == #done
		ifFalse:
			[aPhase == #undone
				ifTrue:
					[anIndex _ history indexOf: lastCommand.
					anIndex > 1 ifTrue:
						[lastCommand _ history at: anIndex - 1]]].

	lastCommand undoCommand.
	lastCommand phase: #undone

	"Command undoLastCommand"
! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
undoOrRedoCommand
	"This gives a feature comparable to standard Mac undo/redo.  If the undo/redo action taken was a simple do or a redo, then undo it.  But if the last undo/redo action taken was an undo, then redo it."

	"Command undoOrRedoCommand"
	| aPhase |
	lastCommand ifNil: [^ self beep].

	(aPhase _ lastCommand phase) == #done
		ifTrue:
			[lastCommand undoCommand.
			lastCommand phase: #undone]
		ifFalse:
			[aPhase == #undone
				ifTrue:
					[lastCommand redoCommand.
					lastCommand phase: #done]]! !

!CommandHistory methodsFor: 'called from the ui' stamp: 'ar 8/31/2000 22:49'!
undoTo
	"Incomplete.  Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there.   Applicable only if infiniteUndo is set.  Not yet functional."

	| anIndex commandList aMenu reply |
	(anIndex _ self historyIndexOfLastCommand) ifNil: [^ self beep].
	commandList _ history
		copyFrom:	((anIndex - 10) max: 1)
		to:			((anIndex + 10) min: history size).
	aMenu _ SelectionMenu labels:  (commandList collect: [:cmd | cmd cmdWording]) selections: commandList.
	reply _ aMenu startUpWithCaption: 'undo or redo to...'.
	reply ifNotNil: [self halt: 'now for the rest...!!']

	"Command undoTo"
! !

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

CommandHistory class
	instanceVariableNames: ''!

!CommandHistory class methodsFor: 'instance creation' stamp: 'ar 8/31/2000 22:50'!
new
	^super new initialize! !


!CommandHistory class methodsFor: 'system startup' stamp: 'di 12/12/2000 13:41'!
initialize    "CommandHistory initialize"

	Smalltalk addToShutDownList: self.
! !

!CommandHistory class methodsFor: 'system startup' stamp: 'di 12/12/2000 13:48'!
resetAllHistory

	CommandHistory allInstancesDo: [:c | c resetCommandHistory].
! !

!CommandHistory class methodsFor: 'system startup' stamp: 'di 12/12/2000 13:48'!
shutDown: aboutToQuit

	aboutToQuit ifTrue: [self resetAllHistory].
! !
AbstractLauncher subclass: #CommandLineLauncherExample
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!
!CommandLineLauncherExample commentStamp: '<historical>' prior: 0!
CommandLineLauncherExample provides an example for a command line application. if you start squeak with a command line 'class Integer' it will launch a class browser on class Integer.
To enable this execute
CommandLineLauncherExample activate
before you save the image.
To disable execute
CommandLineLauncherExample deactivate!


!CommandLineLauncherExample methodsFor: 'running' stamp: 'mir 7/26/2000 15:56'!
startUp
	| className |
	className _ self parameterAt: 'class'.
	(Smalltalk at: className asSymbol ifAbsent: [Object]) browse! !
TileLikeMorph subclass: #CommandTilesMorph
	instanceVariableNames: 'morph playerScripted '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!CommandTilesMorph commentStamp: '<historical>' prior: 0!
An entire Smalltalk statement in tiles.  A line of code.!


!CommandTilesMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:13'!
initialize

	super initialize.
	self wrapCentering: #center; cellPositioning: #leftCenter.
	self hResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	self extent: 5@5.  "will grow to fit"
! !

!CommandTilesMorph methodsFor: 'initialization' stamp: 'sw 1/29/98 18:32'!
setMorph: aMorph
	playerScripted _ aMorph playerScripted
! !


!CommandTilesMorph methodsFor: 'miscellaneous'!
tileRows

	^ Array with: self submorphs! !
Object subclass: #Comment
	instanceVariableNames: ''
	classVariableNames: 'CommentsTable '
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!Comment commentStamp: '<historical>' prior: 0!
A Comment space is like a bulletin board.  It is a web page with a list statements from many different people.  At the bottom there is a form for you to add your own statement.

Anyone may start a new comment page, just by asking for a page with a new key, and there can be any number of pages.  The default Swiki has a page called 'pws' already created.

The administrator must take special action to save the accumulated comments (Comment saveTo: 'aFileName').  Comments are not automatically stored on the disk like regular Swiki pages are.  So, for the moment, it is likely that Comments will get lost when the server is restarted.

URLs are of the form 
machine:80/Comment.{commentKey}
machine:80/Comment.{commentKey}.{number}
machine:80/Comment.{commentKey}.note   -- Does this really work???  -tk
machine:80/Comment.{commentKey}.gif!


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

Comment class
	instanceVariableNames: ''!

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/10/97 10:44'!
initialize
	CommentsTable := Dictionary new.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'!
readIn: filename
	|f|
	f _ ReferenceStream fileNamed: filename.
	CommentsTable _ f next.
	f close.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'!
saveTo: filename
	|f|
	f _ ReferenceStream fileNamed: filename.
	f nextPut: CommentsTable.
	f close.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/17/97 14:52'!
setUpExample
	| newDiscussion |
	newDiscussion _ Discussion new.
	newDiscussion title: 'pws'.
	newDiscussion description: 'Here is a space for talking about the Pluggable Web Server.'.
	CommentsTable at: 'pws' put: newDiscussion.

! !


!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/10/97 11:18'!
comments
	^CommentsTable! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 12/19/97 13:44'!
createComment: request
	"Create a new comment from a Web request"
	| newNote newMap |
	request fields isNil ifTrue: [self error: 'No request to create a comment from!!'].
	newNote := Note new.
	newMap := URLmap new.
	newNote author: (request fields at: 'author' ifAbsent: ['Anonymous']).
	newNote title: (request fields at: 'title' ifAbsent: ['Untitled']).
	newNote text: (HTMLformatter swikify: 
		(request fields at: 'text' ifAbsent: ['Nothing much to say'])
		linkhandler: [:phrase | newMap linkFor: phrase from: (request peerName) 
			storingTo: OrderedCollection new]).
	newNote timestamp: (Date today printString),' ',(Time now printString).
	newNote children: OrderedCollection new. "For later addition of threaded comments"
	^newNote
! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 9/1/1998 12:58'!
process: request
	"URLs are of the form Comment.commentKey or
	Comment.commentKey.note of Comment.commentKey.gif.

	If commentKey is accessed but not created, create an empty one.
	If note is accessed, display it."
	| commentKey noteIndex newNote |
	(request message size > 1) ifTrue: [commentKey _ request message at: 2]
	ifFalse: [^request reply: (self showAllComments: CommentsTable)].
	(CommentsTable includesKey: commentKey)
		ifFalse:
			[CommentsTable at: commentKey put: Discussion new.
			(CommentsTable at: commentKey)
				title: commentKey.
			(CommentsTable at: commentKey)
				description: 'Discussion on ' , commentKey].
	request fields isNil
		ifFalse:
			["Are there input fields?"
			newNote _ self createComment: request.
			newNote parent: commentKey.
			(CommentsTable at: commentKey)
				addNote: newNote.
			newNote url: ('Comment.',commentKey,'.',
				(CommentsTable at: commentKey) notes size
printString)].
	request message size > 2
		ifTrue:
			["There's a note reference or a request for a
status image"
			noteIndex _ request message at: 3.
			noteIndex asUppercase = 'GIF'
			ifTrue: [
			request reply: (PWS success),(PWS content:
'image/gif').
			request reply: (HTMLformatter textToGIF:
				(CommentsTable at: commentKey) status)]
			ifFalse: [request reply: (self showNote:
((CommentsTable at: commentKey)
						at: noteIndex asNumber))]]
		ifFalse: [request reply: (self showComment: (CommentsTable
at: commentKey))]! !

!Comment class methodsFor: 'URL processing' stamp: 'TPR 7/20/1998 18:07'!
showAllComments: aDictionaryOfCommentSpaces
	| fileName |
	fileName := (ServerAction serverDirectory) , 'ShowAllComments.html'.
	^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName)
contentsOfEntireFile with: aDictionaryOfCommentSpaces

! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'!
showComment: aComment
	| fileName |
	fileName := (ServerAction serverDirectory) , 'ShowComment.html'.
	^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aComment.

! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'!
showNote: aNote
	| fileName |
	fileName := (ServerAction serverDirectory) , 'ShowNote.html'.
	^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aNote.
! !
ParseNode subclass: #CommentNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
ByteArray variableByteSubclass: #CompiledApplescript
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!CompiledApplescript commentStamp: '<historical>' prior: 0!
I represent a stored persistent representation of a compiled Applescript.  Ultimately, Squeak interfaces should endeavor to coerce Applescript information to me in one form or the other as soon as possible, as I require no special treatment with respect to memory management.  I *WILL*, however, retain state information between executions of applescripts if I was compiled using modes with bits 2 or 3 set.

I am generally kept as an internal value inside of Applescript or Context objects.  To operate on my instances, they are first generally converted to an AEDesc of type 'scpt', and then "loaded" into an Applescript scripting component (represented by an OSAID handle).  The OSAID is used to "work on" the instance.  If changed state information is desired, the modified OSAID must be "stored" from Applescript back to an AEDesc, and then ultimately converted back into another persistent CompiledScript, which can then replace the first instance.!


!CompiledApplescript methodsFor: 'accessing' stamp: 'acg 9/26/1999 22:19'!
source

	^self sourceWith: Applescript generic! !

!CompiledApplescript methodsFor: 'accessing' stamp: 'acg 9/26/1999 22:18'!
sourceWith: anApplescriptInstance

	| theOSAID theSource|
	(theOSAID _ self asOSAIDWith: anApplescriptInstance) ifNil: [^''].
	theSource _ anApplescriptInstance sourceOfOSAID: theOSAID.
	theOSAID disposeWith: anApplescriptInstance.
	^theSource ifNil: [^''].! !


!CompiledApplescript methodsFor: 'processing' stamp: 'acg 9/25/1999 23:27'!
value

	^self valueWith: Applescript generic in: (OSAID new) mode: 0
! !

!CompiledApplescript methodsFor: 'processing' stamp: 'acg 9/25/1999 23:27'!
valueIn: contextOSAID

	^self valueWith: Applescript generic in: contextOSAID mode: 0
! !

!CompiledApplescript methodsFor: 'processing' stamp: 'acg 9/22/1999 08:51'!
valueWith: anApplescriptInstance in: contextOSAID mode: anInteger

	^anApplescriptInstance 
		doCompiledScript: self 
		in: contextOSAID 
		mode: anInteger
! !


!CompiledApplescript methodsFor: 'converting' stamp: 'acg 9/22/1999 08:07'!
asAEDesc

	^AEDesc scptTypeOn: self! !

!CompiledApplescript methodsFor: 'converting' stamp: 'acg 9/26/1999 18:33'!
asOSAIDWith: anApplescriptInstance

	^self asAEDesc asOSAIDThenDisposeAEDescWith: anApplescriptInstance! !


!CompiledApplescript methodsFor: 'intermediate actions' stamp: 'acg 9/26/1999 01:06'!
loadWith: anApplescriptInstance

	^self loadWith: anApplescriptInstance mode: 0! !

!CompiledApplescript methodsFor: 'intermediate actions' stamp: 'acg 9/26/1999 01:05'!
loadWith: anApplescriptInstance mode: anInteger

	^anApplescriptInstance loadAndDisposeAEDesc: (self asAEDesc) mode: anInteger! !


!CompiledApplescript methodsFor: 'printing' stamp: 'sma 6/1/2000 09:44'!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' ('; print: self size; nextPutAll: ' bytes)'! !
ByteArray variableByteSubclass: #CompiledMethod
	instanceVariableNames: ''
	classVariableNames: 'LargeFrame SmallFrame SpecialConstants TempNameCache '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!CompiledMethod commentStamp: '<historical>' prior: 0!
I represent a method suitable for interpretation by the virtual machine. My instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation).
	
An extra three bytes are added after the executable code. These contain an external file address to the source code for the method.!


!CompiledMethod methodsFor: 'initialize-release'!
copyWithTrailerBytes: bytes
"Testing:
	(CompiledMethod compiledMethodAt: #copyWithTrailerBytes:)
		tempNamesPut: 'copy end '
"
	| copy end start |
	start _ self initialPC.
	end _ self endPC.
	copy _ CompiledMethod newMethod: end - start + 1 + bytes size
				header: self header.
	1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)].
	start to: end do: [:i | copy at: i put: (self at: i)].
	1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)].
	^ copy! !

!CompiledMethod methodsFor: 'initialize-release' stamp: 'di 10/22/1999 13:14'!
needsFrameSize: newFrameSize
	"Set the largeFrameBit to accomodate the newFrameSize"
	| largeFrameBit header |
	largeFrameBit _ 16r20000.
	(self numTemps + newFrameSize) > LargeFrame ifTrue:
		[^ self error: 'Cannot compile -- stack including temps is too deep'].
	header _ self objectAt: 1.
	(header bitAnd: largeFrameBit) ~= 0
		ifTrue: [header _ header - largeFrameBit].
	self objectAt: 1 put: header
			+ ((self numTemps + newFrameSize) > SmallFrame
					ifTrue: [largeFrameBit]
					ifFalse: [0])! !


!CompiledMethod methodsFor: 'accessing'!
endPC
	"Answer the index of the last bytecode."
	| flagByte |
	flagByte _ self last.
	flagByte = 0 ifTrue:
		["If last byte = 0, may be either 0, 0, 0, 0 or just 0"
		1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]].
	flagByte < 252 ifTrue:
		["Magic sources (tempnames encoded in last few bytes)"
		^ self size - self last - 1].
	"Normal 4-byte source pointer"
	^ self size - 4! !

!CompiledMethod methodsFor: 'accessing' stamp: 'di 1/2/1999 17:00'!
flushCache
	"Tell the interpreter to remove all references to this method from its method lookup cache, if it has one.  This primitive must be called whenever a method is defined or removed.
	NOTE:  Only one of two selective flush methods needs to be used.
	Squeak 2.2 and earlier uses 119 (See Symbol flushCache).
	Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."

	<primitive: 116>
! !

!CompiledMethod methodsFor: 'accessing' stamp: 'di 10/23/1999 22:00'!
frameSize
	"Answer the size of temporary frame needed to run the receiver."
	"NOTE:  Versions 2.7 and later use two sizes of contexts."

	(self header noMask: 16r20000)
		ifTrue: [^ SmallFrame]
		ifFalse: [^ LargeFrame]
! !

!CompiledMethod methodsFor: 'accessing'!
initialPC
	"Answer the program counter for the receiver's first bytecode."

	^ (self numLiterals + 1) * 4 + 1! !

!CompiledMethod methodsFor: 'accessing' stamp: 'ar 6/2/1998 16:26'!
numArgs
	"Answer the number of arguments the receiver takes."

	^ (self header bitShift: -24) bitAnd: 16r0F! !

!CompiledMethod methodsFor: 'accessing'!
numLiterals
	"Answer the number of literals used by the receiver."
	
	^ (self header bitShift: -9) bitAnd: 16rFF! !

!CompiledMethod methodsFor: 'accessing'!
numTemps
	"Answer the number of temporary variables used by the receiver."
	
	^ (self header bitShift: -18) bitAnd: 16r3F! !

!CompiledMethod methodsFor: 'accessing' stamp: 'jm 9/18/97 21:06'!
primitive
	"Answer the primitive index associated with the receiver.
	Zero indicates that this is not a primitive method.
	We currently allow 11 bits of primitive index, but they are in two places
	for  backward compatibility.  The time to unpack is negligible,
	since the reconstituted full index is stored in the method cache."
	| primBits |
	primBits _ self header bitAnd: 16r300001FF.
	primBits > 16r1FF
		ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19)]
		ifFalse: [^ primBits]! !

!CompiledMethod methodsFor: 'accessing'!
returnField
	"Answer the index of the instance variable returned by a quick return 
	method."
	| prim |
	prim _ self primitive.
	prim < 264
		ifTrue: [self error: 'only meaningful for quick-return']
		ifFalse: [^ prim - 264]! !

!CompiledMethod methodsFor: 'accessing' stamp: 'sw 8/15/97 16:17'!
selector
	"This is slow, so don't call it frivolously"
	^ self who last! !


!CompiledMethod methodsFor: 'comparing' stamp: 'di 6/6/2000 17:53'!
= method
	| myLits otherLits |
	"Answer whether the receiver implements the same code as the 
	argument, method."
	(method isKindOf: CompiledMethod) ifFalse: [^false].
	self size = method size ifFalse: [^false].
	self header = method header ifFalse: [^false].
	self initialPC to: self endPC do:
		[:i | (self at: i) = (method at: i) ifFalse: [^false]].
	(myLits _ self literals) = (otherLits _ method literals) ifFalse:
		[myLits size = otherLits size ifFalse: [^ false].
		"Dont bother checking FFI and named primitives"
		(#(117 120) includes: self primitive) ifTrue: [^ true].
		myLits with: otherLits do:
			[:lit1 :lit2 | lit1 = lit2 ifFalse:
			[(lit1 isMemberOf: Association)
			ifTrue:
				["Associations match if value is equal, since associations
				used for super may have key = nil or name of class."
				lit1 value == lit2 value ifFalse: [^ false]]
			ifFalse:
				[(lit1 isMemberOf: Float)
				ifTrue:
					["Floats match if values are close, due to roundoff error."
					(lit1 closeTo: lit2) ifFalse: [^ false]]
				ifFalse:
					["any other discrepancy is a failure"
					^ false]]]]].
	^ true! !


!CompiledMethod methodsFor: 'testing' stamp: 'sw 8/20/1998 09:31'!
hasReportableSlip
	"Answer whether the receiver contains anything that might be brought to the attention of the author when filing out.   Customize the lists to suit your preferences.  If slips do not get reported in spite of your best efforts here, make certain that the Preference 'suppressCheckForSlips' has not been hard-coded to true."

	| assoc | 
	#(halt halt: urgent hottest) do:
		[:aLit | (self hasLiteral: aLit) ifTrue: [^ true]].

	#(Transcript AA BB CC DD EE) do:
		[:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil:
			[(self hasLiteral: assoc) ifTrue: [^ true]]].

	^ false! !

!CompiledMethod methodsFor: 'testing' stamp: 'di 12/26/1998 21:31'!
isQuick
	"Answer whether the receiver is a quick return (of self or of an instance 
	variable)."
	^ self primitive between: 256 and: 519! !

!CompiledMethod methodsFor: 'testing' stamp: 'ar 6/2/1998 16:11'!
isReturnField
	"Answer whether the receiver is a quick return of an instance variable."
	^ self primitive between: 264 and: 519! !

!CompiledMethod methodsFor: 'testing'!
isReturnSelf
	"Answer whether the receiver is a quick return of self."

	^ self primitive = 256! !

!CompiledMethod methodsFor: 'testing'!
isReturnSpecial
	"Answer whether the receiver is a quick return of self or constant."

	^ self primitive between: 256 and: 263! !


!CompiledMethod methodsFor: 'printing' stamp: 'sma 2/12/2000 14:01'!
decompileString
	| clAndSel cl sel |
	clAndSel _ self who.
	clAndSel = #(unknown unknown)
		ifTrue:
			[cl _ Object.
			sel _ #xxxUnknown.
			self numArgs >= 1
				ifTrue:
					[sel _ sel , ':'.
					2 to: self numArgs do: [:i | sel _ sel , 'with:'].
					sel _ sel asSymbol]]
		ifFalse:
			[cl _ clAndSel first.
			sel _ clAndSel last].
	^ (cl decompilerClass new
			decompile: sel in: cl method: self) decompileString! !

!CompiledMethod methodsFor: 'printing' stamp: 'sma 6/1/2000 09:45'!
printOn: aStream 
	"Overrides method inherited from the byte arrayed collection."

	self printNameOn: aStream.
	aStream space; nextPutAll: self identityHashPrintString! !

!CompiledMethod methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:09'!
printOnStream: aStream 
	"Overrides method inherited from the byte arrayed collection."

	aStream print: 'a CompiledMethod'! !

!CompiledMethod methodsFor: 'printing' stamp: 'ar 11/28/1999 19:37'!
printPrimitiveOn: aStream
	"Print the primitive on aStream"
	| primIndex primDecl |
	primIndex _ self primitive.
	primIndex = 0 ifTrue:[^self].
	primIndex = 120 "External call spec"
		ifTrue:[^aStream print: (self literalAt: 1); cr].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117 ifTrue:[
		primDecl _ self literalAt: 1.
		aStream 
			nextPut: $';
			nextPutAll: (primDecl at: 2);
			nextPut:$'.
		(primDecl at: 1) notNil ifTrue:[
			aStream 
				nextPutAll:' module:';
				nextPut:$';
				nextPutAll: (primDecl at: 1);
				nextPut:$'.
		].
	] ifFalse:[aStream print: primIndex].
	aStream nextPut: $>; cr! !

!CompiledMethod methodsFor: 'printing'!
storeLiteralsOn: aStream forClass: aBehavior
	"Store the literals referenced by the receiver on aStream, each terminated by a space."

	| literal |
	2 to: self numLiterals + 1 do:
		[:index |
		 aBehavior storeLiteral: (self objectAt: index) on: aStream.
		 aStream space]! !

!CompiledMethod methodsFor: 'printing'!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' newMethod: '.
	aStream store: self size - self initialPC + 1.
	aStream nextPutAll: ' header: '.
	aStream store: self header.
	aStream nextPut: $).
	noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream.
	1 to: self numLiterals do:
		[:index |
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' literalAt: '.
		aStream store: index.
		aStream nextPutAll: ' put: '.
		aStream store: (self literalAt: index)].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!CompiledMethod methodsFor: 'printing' stamp: 'di 12/26/1998 21:30'!
symbolic
	"Answer a String that contains a list of all the byte codes in a method 
	with a short description of each." 
	| aStream |
	self isQuick ifTrue: 
		[self isReturnSpecial ifTrue:
			[^ 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2')
									at: self primitive - 255)].
		^ 'Quick return field ' , self returnField printString , ' (0-based)'].
	aStream _ WriteStream on: (String new: 1000).
	self printPrimitiveOn: aStream.
	(InstructionPrinter on: self) printInstructionsOn: aStream.
	^aStream contents! !

!CompiledMethod methodsFor: 'printing' stamp: 'di 2/4/2000 21:13'!
who 
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."

	| sel |
	Smalltalk allBehaviorsDo:
		[:class |
		(sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil])
			ifNotNil: [^Array with: class with: sel]].
	^ Array with: #unknown with: #unknown
! !


!CompiledMethod methodsFor: 'literals' stamp: 'di 10/17/97 22:38'!
hasLiteral: literal 
	"Answer whether the receiver references the argument, literal."

	<primitive: 132>  "a fast primitive operation equivalent to..."

	2 to: self numLiterals + 1 do:
		[:index |
		literal == (self objectAt: index) ifTrue: [^ true]].
	^ false! !

!CompiledMethod methodsFor: 'literals' stamp: 'di 8/15/97 09:51'!
hasLiteralSuchThat: litBlock
	"Answer true if litBlock returns true for any literal in this method, even if imbedded in array structure."
	| lit |
	2 to: self numLiterals + 1 do:
		[:index | lit _ self objectAt: index.
		(litBlock value: lit) ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
	^false! !

!CompiledMethod methodsFor: 'literals' stamp: 'sma 6/3/2000 21:39'!
hasLiteralThorough: literal
	"Answer true if any literal in this method is literal,
	even if embedded in array structure."

	| lit |
	2 to: self numLiterals + 1 do: 
		[:index | 
		(lit _ self objectAt: index) == literal ifTrue: [^ true].
		(lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]].
	^ false! !

!CompiledMethod methodsFor: 'literals'!
header
	"Answer the word containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	^self objectAt: 1! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index 
	"Answer the literal indexed by the argument."

	^self objectAt: index + 1! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index put: value 
	"Replace the literal indexed by the first argument with the second 
	argument. Answer the second argument."

	^self objectAt: index + 1 put: value! !

!CompiledMethod methodsFor: 'literals'!
literalStrings
	| lits litStrs |
	lits _ self literals.
	litStrs _ OrderedCollection new: lits size * 3.
	self literals do:
		[:lit | 
		(lit isMemberOf: Association)
			ifTrue: [litStrs addLast: lit key]
			ifFalse: [(lit isMemberOf: Symbol)
				ifTrue: [litStrs addAll: lit keywords]
				ifFalse: [litStrs addLast: lit printString]]].
	^ litStrs! !

!CompiledMethod methodsFor: 'literals'!
literals
	"Answer an Array of the literals referenced by the receiver."
	| literals numberLiterals |
	literals _ Array new: (numberLiterals _ self numLiterals).
	1 to: numberLiterals do:
		[:index |
		literals at: index put: (self objectAt: index + 1)].
	^literals! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index 
	"Primitive. Answer the method header (if index=1) or a literal (if index 
	>1) from the receiver. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 68>
	self primitiveFailed! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index put: value 
	"Primitive. Store the value argument into a literal in the receiver. An 
	index of 2 corresponds to the first literal. Fails if the index is less than 2 
	or greater than the number of literals. Answer the value as the result. 
	Normally only the compiler sends this message, because only the 
	compiler stores values in CompiledMethods. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 69>
	self primitiveFailed! !


!CompiledMethod methodsFor: 'scanning'!
messages
	"Answer a Set of all the message selectors sent by this method."

	| scanner aSet |
	aSet _ Set new.
	scanner _ InstructionStream on: self.
	scanner	
		scanFor: 
			[:x | 
			scanner addSelectorTo: aSet.
			false	"keep scanning"].
	^aSet! !

!CompiledMethod methodsFor: 'scanning'!
readsField: varIndex 
	"Answer whether the receiver loads the instance variable indexed by the 
	argument."

	self isReturnField ifTrue: [^self returnField + 1 = varIndex].
	varIndex <= 16 ifTrue: [^ self scanFor: varIndex - 1].
	varIndex <= 64 ifTrue: [^ self scanLongLoad: varIndex - 1].
	^ self scanVeryLongLoad: 64 offset: varIndex - 1! !

!CompiledMethod methodsFor: 'scanning'!
readsRef: literalAssociation 
	"Answer whether the receiver loads the argument."
	| lit |
	lit _ self literals indexOf: literalAssociation ifAbsent: [^false].
	lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].
	lit <= 64 ifTrue: [^self scanLongLoad: 192 + lit - 1].
	^ self scanVeryLongLoad: 128 offset: lit - 1! !

!CompiledMethod methodsFor: 'scanning'!
scanFor: byte 
	"Answer whether the receiver contains the argument as a bytecode."

	^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"! !

!CompiledMethod methodsFor: 'scanning'!
scanLongLoad: extension 
	"Answer whether the receiver contains a long load whose extension is the 
	argument."

	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanLongStore: extension 
	"Answer whether the receiver contains a long store whose extension is 
	the argument."
	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: 
		[:instr |  (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanVeryLongLoad: extension offset: offset
	"Answer whether the receiver contains a long load whose extension is the 
	argument."
	| scanner |
	scanner _ InstructionStream on: self.
	^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])
											and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning' stamp: 'di 6/25/97 19:08'!
scanVeryLongStore: extension offset: offset
	"Answer whether the receiver contains a long load with the given offset.
	Note that the constant +32 is the known difference between a
	store and a storePop for instVars, and it will always fail on literal variables,
	but these only use store (followed by pop) anyway."
	| scanner ext |
	scanner _ InstructionStream on: self.
	^ scanner scanFor:
		[:instr | (instr = 132 and: [(ext _ scanner followingByte) = extension
											or: ["might be a store/pop into rcvr"
												ext = (extension+32)]])
							and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning'!
sendsToSuper
	"Answer whether the receiver sends any message to super."
	| scanner |
	scanner _ InstructionStream on: self.
	^ scanner scanFor: 
		[:instr |  instr = 16r85 or: [instr = 16r84
						and: [scanner followingByte between: 16r20 and: 16r3F]]]! !

!CompiledMethod methodsFor: 'scanning' stamp: 'di 12/26/1998 21:30'!
writesField: field 
	"Answer whether the receiver stores into the instance variable indexed 
	by the argument."

	self isQuick ifTrue: [^ false].
	field <= 8 ifTrue:
		[^ (self scanFor: 96 + field - 1) or: [self scanLongStore: field - 1]].
	field <= 64 ifTrue:
		[^ self scanLongStore: field - 1].
	^ self scanVeryLongStore: 160 offset: field - 1! !

!CompiledMethod methodsFor: 'scanning'!
writesRef: ref 
	"Answer whether the receiver stores the argument."
	| lit |
	lit _ self literals indexOf: ref ifAbsent: [^false].
	lit <= 64 ifTrue: [^ self scanLongStore: 192 + lit - 1].
	^ self scanVeryLongStore: 224 offset: lit - 1! !


!CompiledMethod methodsFor: 'source code management'!
cacheTempNames: names

	TempNameCache _ Association key: self value: names! !

!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/7/2000 12:28'!
checkOKToAdd: size at: filePosition
	"Issue several warnings as the end of the changes file approaches its limit,
	and finally halt with an error when the end is reached."

	| fileSizeLimit margin |
	fileSizeLimit _ 16r2000000.
	3 to: 1 by: -1 do:
		[:i | margin _ i*100000.
		(filePosition + size + margin) > fileSizeLimit
			ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse:
						[self inform: 'WARNING: your changes file is within
' , margin printString , ' characters of its size limit.
You should take action soon to reduce its size.
You may proceed.']]
			ifFalse: [^ self]].
	(filePosition + size > fileSizeLimit) ifFalse: [^ self].
	self error: 'You have reached the size limit of the changes file.
You must take action now to reduce it.
Close this error.  Do not attempt to proceed.'! !

!CompiledMethod methodsFor: 'source code management'!
copyWithTempNames: tempNames
	| tempStr |
	tempStr _ String streamContents:
		[:strm | tempNames do: [:n | strm nextPutAll: n; space]].
	^ self copyWithTrailerBytes: (self qCompress: tempStr)! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'!
fileIndex
	^SourceFiles fileIndexFromSourcePointer: self sourcePointer! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'!
filePosition
	^SourceFiles filePositionFromSourcePointer: self sourcePointer! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 12/26/1998 22:34'!
getSourceFor: selector in: class
	"Retrieve or reconstruct the source code for this method."
	| source flagByte |
	flagByte _ self last.
	(flagByte = 0
		or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0"
			and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]])
		ifTrue:
		["No source pointer -- decompile without temp names"
		^ (class decompilerClass new decompile: selector in: class method: self)
			decompileString].
	flagByte < 252 ifTrue:
		["Magic sources -- decompile with temp names"
		^ ((class decompilerClass new withTempNames: self tempNames)
				decompile: selector in: class method: self)
			decompileString].

	"Situation normal;  read the sourceCode from the file"
	(source _ self getSourceFromFile) == nil ifFalse: [^ source].

	"Something really wrong -- decompile blind (no temps)"
	^ (class decompilerClass new decompile: selector in: class method: self)
			decompileString! !

!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/12/97 13:03'!
getSourceFromFile
	"Read the source code from file, determining source file index and
	file position from the last 3 bytes of this method."
	| position |
	(position _ self filePosition) = 0 ifTrue: [^ nil].
	^ (RemoteString newFileNumber: self fileIndex position: position)
			text! !

!CompiledMethod methodsFor: 'source code management'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
	inFile: fileIndex priorMethod: priorMethod

	^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
			[:file | class printCategoryChunk: catName on: file priorMethod: priorMethod.
			file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
	withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod

	^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
			[:file |
			class printCategoryChunk: catName on: file
				withStamp: changeStamp priorMethod: priorMethod.
			file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 5/30/2000 21:26'!
putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock
	"Store the source code for the receiver on an external file.
	If no sources are available, i.e., SourceFile is nil, then store
	temp names for decompilation at the end of the method.
	If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,
	in each case, storing a 4-byte source code pointer at the method end."

	| file remoteString  st80str |
	(SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:
		[^ self become: (self copyWithTempNames: methodNode tempNames)].

	Smalltalk assureStartupStampLogged.
	file setToEnd.

	preambleBlock value: file.  "Write the preamble"
	(methodNode isKindOf: DialectMethodNode)
		ifTrue:
		["This source was parsed from an alternate syntax.
		We must convert to ST80 before logging it."
		st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm])
						asString.
		remoteString _ RemoteString newString: st80str
						onFileNumber: fileIndex toFile: file]
		ifFalse:
		[remoteString _ RemoteString newString: sourceStr
						onFileNumber: fileIndex toFile: file].

	file nextChunkPut: ' '; flush.
	self checkOKToAdd: sourceStr size at: remoteString position.
	self setSourcePosition: remoteString position inFile: fileIndex! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 9/23/1998 19:22'!
qCompress: str
	"A very simple text compression routine designed for method temp names.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble.
	Last char of str must be a space so it may be dropped without
	consequence if output ends on odd nibble."
	| charTable odd ix oddNibble |
	charTable _  "Character encoding table must match qDecompress:"
	' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ ByteArray streamContents:
		[:strm | odd _ true.  "Flag for odd or even nibble out"
		str do:
			[:char | ix _ (charTable indexOf: char) - 1.
			(ix <= 12 ifTrue: [Array with: ix]
				ifFalse: [Array with: ix//16+12 with: ix\\16])
				do:
				[:nibble | (odd _ odd not)
					ifTrue: [strm nextPut: oddNibble*16 + nibble]
					ifFalse: [oddNibble _ nibble]]].
		strm nextPut: strm position]
"
  | m s |  m _ CompiledMethod new.
s _ 'charTable odd ix oddNibble '.
^ Array with: s size with: (m qCompress: s) size
	with: (m qDecompress: (m qCompress: s))
"
! !

!CompiledMethod methodsFor: 'source code management'!
qDecompress: byteArray
	"Decompress strings compressed by qCompress:.
	Most common 12 chars get values 0-11 packed in one 4-bit nibble;
	others get values 12-15 (2 bits) * 16 plus next nibble"
	|  charTable extended ext |
	charTable _  "Character encoding table must match qCompress:"
	' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
	^ String streamContents:
		[:strm | extended _ false.  "Flag for 2-nibble characters"
		byteArray do:
			[:byte | 
			(Array with: byte//16 with: byte\\16)
				do:
				[:nibble | extended
					ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]
					ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]
									ifFalse: [ext _ nibble-12.  extended _ true]]]]]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:00'!
setSourcePointer: srcPointer
	srcPointer = 0 ifTrue: [
		self at: self size put: 0.
		^self].
	(srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range'].
	self at: self size put: (srcPointer bitShift: -24) + 251.
	1 to: 3 do: [:i |
		self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:02'!
setSourcePosition: position inFile: fileIndex 
	self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! !

!CompiledMethod methodsFor: 'source code management'!
setTempNamesIfCached: aBlock
	"This is a cache used by the debugger, independent of the storage of
	temp names when the system is converted to decompilation with temps."
	TempNameCache == nil ifTrue: [^self].
	TempNameCache key == self
		ifTrue: [aBlock value: TempNameCache value]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'!
sourcePointer
	"Answer the integer which can be used to find the source file and position for this method.
	The returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF.
	The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles."

	| pos |
	self last < 252 ifTrue: [^ 0  "no source"].
	pos _ self last - 251.
	self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)].
	^pos! !

!CompiledMethod methodsFor: 'source code management'!
tempNames
	| byteCount bytes |
	byteCount _ self at: self size.
	byteCount = 0 ifTrue: [^ Array new].
	bytes _ (ByteArray new: byteCount)
		replaceFrom: 1 to: byteCount with: self 
		startingAt: self size - byteCount.
	^ (self qDecompress: bytes) findTokens: ' '! !


!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 10/6/2000 14:22'!
readDataFrom: aDataStream size: varsOnDisk
	"Fill in my fields.  My header and number of literals are already installed.  Must read both objects for the literals and bytes for the bytecodes."

	self error: 'Must use readMethod'.! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/26/98 09:10'!
storeDataOn: aDataStream
	"Store myself on a DataStream.  I am a mixture of objects and raw data bytes.  Only use this for blocks.  Normal methodDictionaries should not be put out using ReferenceStreams.  Their fileOut should be attached to the beginning of the file."

	| byteLength lits |
	"No inst vars of the normal type"
	byteLength _ self basicSize.
	aDataStream
		beginInstance: self class
		size: byteLength.
	lits _ self numLiterals + 1.	"counting header"
	1 to: lits do:
		[:ii | aDataStream nextPut: (self objectAt: ii)].
	lits*4+1 to: byteLength do:
		[:ii | aDataStream byteStream nextPut: (self basicAt: ii)].
			"write bytes straight through to the file"! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 8/19/1998 16:20'!
veryDeepCopyWith: deepCopier
	"Return self.  I am always shared.  Do not record me.  Only use this for blocks.  Normally methodDictionaries should not be copied this way."! !


!CompiledMethod methodsFor: 'evaluating' stamp: 'sma 6/12/2000 14:29'!
valueWithReceiver: aReceiver arguments: anArray 
	| selector |
	selector _ Symbol new.
	aReceiver class addSelector: selector withMethod: self.
	^ [aReceiver perform: selector withArguments: anArray]
		ensure: [aReceiver class removeSelectorSimply: selector]! !

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

CompiledMethod class
	instanceVariableNames: ''!

!CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/11/1999 22:13'!
fullFrameSize  "CompiledMethod fullFrameSize"
	^ LargeFrame! !

!CompiledMethod class methodsFor: 'class initialization' stamp: 'di 10/22/1999 09:56'!
initialize    "CompiledMethod initialize"
	"Initialize class variables specifying the size of the temporary frame
	needed to run instances of me."

	SmallFrame _ 16.	"Context range for temps+stack"
	LargeFrame _ 56.! !


!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 9/9/2000 20:36'!
basicNew: size

	self error: 'CompiledMethods may only be created with newMethod:header:' ! !

!CompiledMethod class methodsFor: 'instance creation'!
new
	"This will not make a meaningful method, but it could be used
	to invoke some otherwise useful method in this class."
	^ self newMethod: 0 header: 0! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 1/21/2000 15:25'!
new: size

	self error: 'CompiledMethods may only be created with newMethod:header:'! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:37'!
newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
	"Answer an instance of me. The header is specified by the message 
	arguments. The remaining parts are not as yet determined."
	| largeBit primBits method |
	nTemps > 64 ifTrue:
		[^ self error: 'Cannot compile -- too many temporary variables'].	
	largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
	primBits _ primitiveIndex <= 16r1FF
		ifTrue: [primitiveIndex]
		ifFalse: ["For now the high 2 bits of primitive no. are in high bits of header"
				(primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r600) bitShift: 19)].
	method _ self newMethod: numberOfBytes + trailer size
		header: (nArgs bitShift: 24) +
				(nTemps bitShift: 18) +
				(largeBit bitShift: 17) +
				(nLits bitShift: 9) +
				primBits.
	1 to: trailer size do:  "Copy the source code trailer to the end"
		[:i | method at: method size - trailer size + i put: (trailer at: i)].
	^ method! !

!CompiledMethod class methodsFor: 'instance creation'!
newMethod: numberOfBytes header: headerWord 
	"Primitive. Answer an instance of me. The number of literals (and other 
	information) is specified the headerWord. The first argument specifies 
	the number of fields for bytecodes in the method. Fail if either 
	argument is not a SmallInteger, or if numberOfBytes is negative. Once 
	the header of a method is set by this primitive, it cannot be changed in 
	any way. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79>
	(numberOfBytes isInteger and:
	 [headerWord isInteger and:
	 [numberOfBytes >= 0]]) ifTrue: [
		"args okay; space must be low"
		Smalltalk signalLowSpace.
		"retry if user proceeds"
		^ self newMethod: numberOfBytes header: headerWord
	].
	^self primitiveFailed! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:43'!
toReturnConstant: index trailerBytes: trailer
	"Answer an instance of me that is a quick return of the constant
	indexed in (true false nil -1 0 1 2)."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + index
! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:44'!
toReturnField: field trailerBytes: trailer
	"Answer an instance of me that is a quick return of the instance variable 
	indexed by the argument, field."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 264 + field
! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:51'!
toReturnSelf
	"Answer an instance of me that is a quick return of the instance (^self)."

	^ self toReturnSelfTrailerBytes: #(0 0 0 0)! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:44'!
toReturnSelfTrailerBytes: trailer
	"Answer an instance of me that is a quick return of the instance (^self)."

	^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256
! !
Object subclass: #Compiler
	instanceVariableNames: 'sourceStream requestor class context '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!Compiler commentStamp: '<historical>' prior: 0!
The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.!


!Compiler methodsFor: 'error handling'!
interactive 
	"Answer whether there is a requestor of the compiler who should be 
	informed that an error occurred."

	^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! !

!Compiler methodsFor: 'error handling'!
notify: aString 
	"Refer to the comment in Object|notify:."

	^self notify: aString at: sourceStream position + 1! !

!Compiler methodsFor: 'error handling' stamp: 'di 10/9/1998 16:50'!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	requestor == nil
		ifTrue: [^SyntaxError 
					errorInClass: class
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)
					doitFlag: false]
		ifFalse: [^requestor
					notify: aString
					at: location
					in: sourceStream]! !


!Compiler methodsFor: 'public access'!
compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock 
	"Answer a MethodNode for the argument, textOrStream. If the 
	MethodNode can not be created, notify the argument, aRequestor; if 
	aRequestor is nil, evaluate failBlock instead. The MethodNode is the root 
	of a parse tree. It can be told to generate a CompiledMethod to be 
	installed in the method dictionary of the argument, aClass."

	self from: textOrStream
		class: aClass
		context: nil
		notifying: aRequestor.
	^self
		translate: sourceStream
		noPattern: false
		ifFail: failBlock! !

!Compiler methodsFor: 'public access' stamp: 'bf 10/14/1999 19:55'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock
	"Compiles the sourceStream into a parse tree, then generates code into a 
	method. This method is then installed in the receiver's class so that it 
	can be invoked. In other words, if receiver is not nil, then the text can 
	refer to instance variables of that receiver (the Inspector uses this). If 
	aContext is not nil, the text can refer to temporaries in that context (the 
	Debugger uses this). If aRequestor is not nil, then it will receive a 
	notify:at: message before the attempt to evaluate is aborted. Finally, the 
	compiled method is invoked from here as DoIt or (in the case of 
	evaluation in aContext) DoItIn:. The method is subsequently removed 
	from the class, but this will not get done if the invocation causes an 
	error which is terminated. Such garbage can be removed by executing: 
	Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: 
	#DoItIn:]."

	| methodNode method value |
	class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
	self from: textOrStream class: class context: aContext notifying: aRequestor.
	methodNode _ self translate: sourceStream noPattern: true ifFail:
		[^failBlock value].
	method _ methodNode generate: #(0 0 0 0).
	self interactive ifTrue:
		[method _ method copyWithTempNames: methodNode tempNames].
	context == nil
		ifTrue: [class addSelector: #DoIt withMethod: method.
				value _ receiver DoIt.
				class removeSelectorSimply: #DoIt.
				^value]
		ifFalse: [class addSelector: #DoItIn: withMethod: method.
				value _ receiver DoItIn: context.
				class removeSelectorSimply: #DoItIn:.
				^value]! !

!Compiler methodsFor: 'public access' stamp: 'sw 11/7/1999 00:11'!
format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean
	"Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely.  If aBoolean is true, then decorate the resulting text with color and hypertext actions"
	| aNode |
	self from: textOrStream
		class: aClass
		context: nil
		notifying: aRequestor.
	aNode _ self format: sourceStream noPattern: false ifFail: [^ nil].
	^ aBoolean
		ifTrue: [aNode decompileText]
		ifFalse: [aNode decompileString]! !

!Compiler methodsFor: 'public access' stamp: 'di 4/24/2000 07:46'!
parse: textOrStream in: aClass notifying: req
	"Compile the argument, textOrStream, with respect to the class, aClass, 
	and answer the MethodNode that is the root of the resulting parse tree. 
	Notify the argument, req, if an error occurs. The failBlock is defaulted to 
	an empty block."

	^ self parse: textOrStream in: aClass notifying: req dialect: false! !

!Compiler methodsFor: 'public access' stamp: 'RAA 6/14/2000 13:49'!
parse: textOrStream in: aClass notifying: req dialect: useDialect
        "Compile the argument, textOrStream, with respect to the class, aClass, 
        and answer the MethodNode that is the root of the resulting parse tree. 
        Notify the argument, req, if an error occurs. The failBlock is defaulted to 
        an empty block."

        self from: textOrStream class: aClass context: nil notifying: req.
        ^ ((useDialect and: [RequestAlternateSyntaxSetting signal])
                ifTrue: [DialectParser]
                ifFalse: [Parser]) new
                        parse: sourceStream
                        class: class
                        noPattern: false
                        context: context
                        notifying: requestor
                        ifFail: []! !


!Compiler methodsFor: 'private' stamp: 'mn 5/25/2000 07:36'!
format: aStream noPattern: noPattern ifFail: failBlock
	| tree |
	tree _ 
		self class parserClass new
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^ failBlock value].
	^ tree! !

!Compiler methodsFor: 'private'!
from: textOrStream class: aClass context: aContext notifying: req

	(textOrStream isKindOf: PositionableStream)
		ifTrue: [sourceStream _ textOrStream]
		ifFalse: [sourceStream _ ReadStream on: textOrStream asString].
	class _ aClass.
	context _ aContext.
	requestor _ req! !

!Compiler methodsFor: 'private' stamp: 'mn 5/25/2000 07:37'!
translate: aStream noPattern: noPattern ifFail: failBlock
	| tree |
	tree _ 
		self class parserClass new
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^ failBlock value].
	^ tree! !

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

Compiler class
	instanceVariableNames: ''!

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

	^Parser! !


!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object, and the 
	invocation is not logged."

	^self evaluate: textOrString for: nil logged: false! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString for: anObject logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor."

	^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString for: anObject notifying: aController logged: logFlag
	"Compile and execute the argument, textOrString with respect to the class 
	of anObject. If a compilation error occurs, notify aController. If both 
	compilation and execution are successful then, if logFlag is true, log 
	(write) the text onto a system changes file so that it can be replayed if 
	necessary."

	| val |
	val _ self new
				evaluate: textOrString
				in: nil
				to: anObject
				notifying: aController
				ifFail: [^nil].
	logFlag ifTrue: [Smalltalk logChange: textOrString].
	^val! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString notifying: aController logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. Compilation is carried out 
	with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil notifying: aController logged: logFlag! !
Object subclass: #ComplexProgressIndicator
	instanceVariableNames: 'formerWorld targetMorph estimate prevData formerProcess translucentMorph userSuppliedMorph specificHistory historyCategory cumulativeStageTime formerProject newRatio stageCompleted start '
	classVariableNames: 'History '
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ComplexProgressIndicator commentStamp: '<historical>' prior: 0!
Note: in an effort to remove the progress indicator if a walkback occurs, #withProgressDo: must be sent from the current uiProcess. Hopefully we can relax this restriction in the future. !


!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 15:31'!
backgroundWorldDisplay

	| f |

	self flag: #bob.		"really need a better way to do this"

			"World displayWorldSafely."

	"ugliness to try to track down a possible error"


	[World displayWorld] ifError: [ :a :b |
		stageCompleted _ 999.
		f _ FileDirectory default fileNamed: 'bob.errors'.
		f nextPutAll: a printString,'  ',b printString; cr; cr.
		f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr.
		f nextPutAll: thisContext longStack; cr; cr.
		f nextPutAll: formerProcess suspendedContext longStack; cr; cr.
		f close. 1 beep.
	].
! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 17:29'!
forkProgressWatcher

	| killTarget |
	[
		[stageCompleted < 999 and: 
				[formerProject == Project current and: 
				[formerWorld == World and: 
				[translucentMorph world notNil and:
				[formerProcess suspendedContext notNil and: 
				[Project uiProcess == formerProcess]]]]]] whileTrue: [

			translucentMorph setProperty: #revealTimes toValue: 
					{(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}.
			translucentMorph changed.
			translucentMorph owner addMorphInLayer: translucentMorph.
			(Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [
				self backgroundWorldDisplay
			].
			(Delay forMilliseconds: 100) wait.
		].
		translucentMorph removeProperty: #revealTimes.
		self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1).
		killTarget _ targetMorph ifNotNil: [
			targetMorph valueOfProperty: #deleteOnProgressCompletion
		].
		formerWorld == World ifTrue: [
			translucentMorph delete.
			killTarget ifNotNil: [killTarget delete].
		] ifFalse: [
			translucentMorph privateDeleteWithAbsolutelyNoSideEffects.
			killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects].
		].
	] forkAt: 6.
! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 10:00'!
historyCategory: aKey

	History ifNil: [History _ Dictionary new].
	specificHistory _ History
		at: aKey
		ifAbsentPut: [Dictionary new].
	^specificHistory
! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 09:55'!
loadingHistoryAt: aKey add: aNumber

	(self loadingHistoryDataForKey: aKey) add: aNumber.

! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 10:02'!
loadingHistoryDataForKey: anObject

	| answer |
	answer _ specificHistory 
		at: anObject
		ifAbsentPut: [OrderedCollection new].
	answer size > 50 ifTrue: [
		answer _ answer copyFrom: 25 to: answer size.
		specificHistory at: anObject put: answer.
	].
	^answer

! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:31'!
targetMorph: aMorph

	targetMorph _ aMorph! !

!ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 17:00'!
withProgressDo: aBlock

	| safetyFactor totals trialRect delta stageCompletedString |

	Smalltalk isMorphic ifFalse: [^aBlock value].
	formerProject _ Project current.
	formerWorld _ World.
	formerProcess _ Processor activeProcess.
	targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal].
	targetMorph ifNil: [
		trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80.
		delta _ trialRect amountToTranslateWithin: formerWorld bounds.
		trialRect _ trialRect translateBy: delta.
		translucentMorph _ TranslucentProgessMorph new
			opaqueBackgroundColor: Color white;
			bounds: trialRect;
			openInWorld: formerWorld.
	] ifNotNil: [
		translucentMorph _ TranslucentProgessMorph new
			setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
			bounds: targetMorph boundsInWorld;
			openInWorld: targetMorph world.
	].
	stageCompleted _ 0.
	safetyFactor _ 1.1.	"better to guess high than low"
	translucentMorph setProperty: #progressStageNumber toValue: 1.
	totals _ self loadingHistoryDataForKey: 'total'.
	newRatio _ 1.0.
	estimate _ totals size < 2 ifTrue: [
		15000		"be a pessimist"
	] ifFalse: [
		(totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor.
	].
	start _ Time millisecondClockValue.
	self forkProgressWatcher.

	[
		aBlock 
			on: ProgressInitiationException
			do: [ :ex | 
				ex sendNotificationsTo: [ :min :max :curr |
					"ignore this as it is inaccurate"
				].
			].
	] on: ProgressNotification do: [ :note |
		stageCompletedString _ (note messageText findTokens: ' ') first.
		stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber.
		cumulativeStageTime _ Time millisecondClockValue - start max: 1.
		prevData _ self loadingHistoryDataForKey: stageCompletedString.
		prevData isEmpty ifFalse: [
			newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat.
		].
		self 
			loadingHistoryAt: stageCompletedString 
			add: cumulativeStageTime.
		translucentMorph 
			setProperty: #progressStageNumber 
			toValue: stageCompleted + 1.
		note resume.
	].

	stageCompleted _ 999.	"we may or may not get here"

! !

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

ComplexProgressIndicator class
	instanceVariableNames: ''!

!ComplexProgressIndicator class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 11:40'!
historyReport
"
ComplexProgressIndicator historyReport
"
	| answer data |
	History ifNil: [^1 beep].
	answer _ String streamContents: [ :strm |
		(History keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :k |
			strm nextPutAll: k printString; cr.
			data _ History at: k.
			(data keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :dataKey |
				strm tab; nextPutAll: dataKey printString,'  ',
					(data at: dataKey) asArray printString; cr.
			].
			strm cr.
		].
	].
	StringHolder new
		contents: answer contents;
		openLabel: 'Progress History'! !
Player subclass: #Component
	instanceVariableNames: 'model pinSpecs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!Component methodsFor: 'initialize' stamp: 'di 5/3/1998 20:23'!
initComponentIn: aLayout
	model _ aLayout model.
	self nameMeIn: aLayout world.
	self color: Color lightCyan.
	self showPins.
	model addDependent: self! !


!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:48'!
chooseNameLike: someName 
	| stem otherNames i partName |
	stem _ someName.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ self class allInstVarNames asSet.
	"otherNames addAll: self world allKnownNames."
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	partName _ FillInTheBlank request: 'Please give this part a name'
						initialAnswer: partName.
	partName isEmpty ifTrue: [^ nil].
	(otherNames includes: partName) ifTrue:
			[self inform: 'Sorry, that name is already used'.
			^ nil].
	^ partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:58'!
externalName 
	^ self class name! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:50'!
nameMeIn: aWorld
	| stem otherNames i partName className |
	className _ self class name.
	stem _ className.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ Set newFrom: aWorld allKnownNames.
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	self setNamePropertyTo: partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:51'!
renameMe
	| newName |
	newName _ self chooseNameLike: self knownName.
	newName ifNil: [^ nil].
	self setNamePropertyTo: newName! !


!Component methodsFor: 'drag and drop' stamp: 'ar 10/5/2000 20:03'!
justDroppedInto: aMorph event: anEvent
	| theModel |
	theModel _ aMorph model.
	((aMorph isKindOf: ComponentLayout) 
		and: [theModel isKindOf: Component]) ifFalse:
		["Disconnect prior to removal by move"
		(theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
		^ super justDroppedInto: aMorph event: anEvent].
	theModel == model ifTrue: [^ self  "Presumably just a move"].
	self initComponentIn: aMorph.
	super justDroppedInto: aMorph event: anEvent.! !


!Component methodsFor: 'variables' stamp: 'di 1/18/2000 16:10'!
addVariableNamed: varName
	| otherNames i partName |
	"Adjust name if necessary and add it"
	otherNames _ self class allInstVarNames.
	i _ nil.
	[i == nil ifTrue: [partName _ varName] ifFalse: [partName _ varName, i printString].
	otherNames includes: partName]
		whileTrue: [i == nil ifTrue: [i _ 1] ifFalse: [i _ i + 1]].
	self class addInstVarName: partName.

	"Now compile read method and write-with-change method"
	self class compile: (String streamContents:
			[:s | s nextPutAll: partName; cr;
			tab; nextPutAll: '^', partName])
		classified: 'view access'
		notifying: nil.
	self class compile: (String streamContents:
			[:s | s nextPutAll: partName, 'Set: newValue'; cr;
				tab; nextPutAll: partName, ' _ newValue.'; cr;
				tab; nextPutAll: 'self changed: #', partName, '.'; cr;
				tab; nextPutAll: '^ true' "for components that expect a boolean for accept"])
		classified: 'view access'
		notifying: nil.

	^ Array with: partName asSymbol with: (partName , 'Set:') asSymbol! !

!Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:58'!
removeVariableNamed: varName 
	self class removeSelector: varName.
	self class removeSelector: (varName , 'Set:') asSymbol.
	self class removeInstVarName: varName asString! !


!Component methodsFor: 'misc' stamp: 'ar 10/5/2000 17:30'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

	super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
	aMenu add: 'delete' target: self action: #dismissMorph:! !

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

Component class
	instanceVariableNames: ''!

!Component class methodsFor: 'as yet unclassified' stamp: 'di 4/17/1998 14:02'!
acceptsLoggingOfCompilation
	"Log everything for now"

	^ true! !

!Component class methodsFor: 'as yet unclassified' stamp: 'di 4/18/1998 11:08'!
addSlotNamed: aName
	(self allInstVarNames includes: aName) ifTrue: [self error: 'Duplicate slot name'].
	self addInstVarName: aName.
! !

!Component class methodsFor: 'as yet unclassified' stamp: 'di 4/13/98 12:15'!
includeInNewMorphMenu
	"Only include instances of subclasses of me"
	^ self ~~ Component! !

!Component class methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 19:55'!
wantsChangeSetLogging
	"Log changes for Component itself, but not for automatically-created subclasses like Component1, Component2"

	"^ self == Component or:
		[(self class name beginsWith: 'Component') not]"

	"Log everything for now"
	false ifTrue: [self halt  "DONT FORGET TO REORDER FILEOUT"].
	^ true! !
Component subclass: #Component1
	instanceVariableNames: 'printComponent1value listComponent1selectedItem functionComponent1output functionComponent3output listComponent3selectedItem functionComponent4output listComponent4selectedItem functionComponent5output listComponent2selectedItem functionComponent2output '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components Built'!

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'!
functionComponent1output
	^functionComponent1output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'!
functionComponent1outputSet: newValue
	functionComponent1output _ newValue.
	self changed: #functionComponent1output! !

!Component1 methodsFor: 'view access' stamp: 'di 9/15/1998 17:13'!
functionComponent2output
	^functionComponent2output! !

!Component1 methodsFor: 'view access' stamp: 'di 9/15/1998 17:13'!
functionComponent2outputSet: newValue
	functionComponent2output _ newValue.
	self changed: #functionComponent2output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent3output
	^functionComponent3output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent3outputSet: newValue
	functionComponent3output _ newValue.
	self changed: #functionComponent3output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'!
functionComponent4output
	^functionComponent4output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'!
functionComponent4outputSet: newValue
	functionComponent4output _ newValue.
	self changed: #functionComponent4output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'!
functionComponent5output
	^functionComponent5output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'!
functionComponent5outputSet: newValue
	functionComponent5output _ newValue.
	self changed: #functionComponent5output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'!
listComponent1selectedItem
	^listComponent1selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'!
listComponent1selectedItemSet: newValue
	listComponent1selectedItem _ newValue.
	self changed: #listComponent1selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 9/15/1998 17:12'!
listComponent2selectedItem
	^listComponent2selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 9/15/1998 17:12'!
listComponent2selectedItemSet: newValue
	listComponent2selectedItem _ newValue.
	self changed: #listComponent2selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'!
listComponent3selectedItem
	^listComponent3selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'!
listComponent3selectedItemSet: newValue
	listComponent3selectedItem _ newValue.
	self changed: #listComponent3selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'!
listComponent4selectedItem
	^listComponent4selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'!
listComponent4selectedItemSet: newValue
	listComponent4selectedItem _ newValue.
	self changed: #listComponent4selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'!
printComponent1value
	^printComponent1value! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'!
printComponent1valueSet: newValue
	printComponent1value _ newValue.
	self changed: #printComponent1value! !


!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:31'!
functionComponent1a: a 
	^ SystemOrganization listAtCategoryNamed: a! !

!Component1 methodsFor: 'functions' stamp: 'di 9/15/1998 17:10'!
functionComponent2a: a 
	^ Smalltalk at: a! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:36'!
functionComponent3a: a 
	^ a organization categories! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:43'!
functionComponent4a: a b: b 
	^ a organization listAtCategoryNamed: b! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:51'!
functionComponent5a: a b: b 
	^ a sourceCodeAt: b! !
MacExternalData variableWordSubclass: #ComponentInstance
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!ComponentInstance commentStamp: '<historical>' prior: 0!
I am an ExternalData representation of a MacOS Scripting Component.  I am typically subclassed to generate the relevant scripting component, for example, by ApplescriptInstance.!




!ComponentInstance methodsFor: 'private' stamp: 'acg 9/21/1999 21:14'!
primOpenDefaultConfiguration: type subtype: subtype

	<primitive: 'primOpenDefaultConfiguration' module: 'TestOSAPlugin'>
	^TestOSAPlugin 
		doPrimitive: 'primOpenDefaultConfiguration:subtype:'
		withArguments: {type. subtype}! !

!ComponentInstance methodsFor: 'private' stamp: 'acg 9/21/1999 21:18'!
type: typeString subtype: subtypeString
"Associate this object instance with an instance of the generic scripting component.  Answer self."

	self 
		primOpenDefaultConfiguration: (DescType of: typeString)
		subtype: (DescType of: subtypeString)! !

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

ComponentInstance class
	instanceVariableNames: ''!

!ComponentInstance class methodsFor: 'instance creation' stamp: 'acg 9/21/1999 21:24'!
new

	^super new: 1! !

!ComponentInstance class methodsFor: 'instance creation' stamp: 'acg 9/21/1999 21:24'!
new: anInteger

	^self error: 'Create ComponentInstances with #new or #type:subtype'! !

!ComponentInstance class methodsFor: 'instance creation' stamp: 'acg 9/21/1999 21:20'!
type: typeString subtype: subtypeString

	^(super new: 1) type: typeString subtype: subtypeString! !
PasteUpMorph subclass: #ComponentLayout
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 10:17'!
acceptDroppingMorph: aMorph event: evt
	"Eschew all of PasteUp's mechanism for now"

	self addMorph: aMorph.
! !

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 09:44'!
addCustomMenuItems: menu hand: aHandMorph

	super addCustomMenuItems: menu hand: aHandMorph.
	menu addLine.
	menu add: 'inspect model in morphic' action: #inspectModelInMorphic! !

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'ar 10/6/2000 19:20'!
allKnownNames
	^ super allKnownNames, (self submorphs collect: [:m | m knownName] thenSelect: [:m | m ~~ nil])! !

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'di 5/2/1998 21:36'!
createCustomModel
	"Create a model object for this world if it does not yet have one.
	The default model for an EditView is a Component."

	model == nil ifFalse: [^ self].  "already has a model"
	model _ Component newSubclass new.
! !

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'di 1/17/2000 16:36'!
initialize
	super initialize.
	self createCustomModel.
	self extent: 384@256! !

!ComponentLayout methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 09:41'!
inspectModelInMorphic
	| insp |
	insp _ InspectorBrowser openAsMorphOn: self model.
	self world addMorph: insp; startStepping: insp! !
MorphicModel subclass: #ComponentLikeModel
	instanceVariableNames: 'pinSpecs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!ComponentLikeModel methodsFor: 'initialization' stamp: 'di 5/3/1998 09:24'!
duplicate: newGuy from: oldGuy
	"oldGuy has just been duplicated and will stay in this world.  Make sure all the ComponentLikeModel requirements are carried out for the copy.  Ask user to rename it.  "

	newGuy installModelIn: oldGuy pasteUpMorph.
	newGuy copySlotMethodsFrom: oldGuy slotName.! !


!ComponentLikeModel methodsFor: 'compilation' stamp: 'di 5/3/1998 09:25'!
choosePartName
	"When I am renamed, get a slot, make default methods, move any existing methods."
	| old |
	(self pasteUpMorph model isKindOf: Component) ifTrue:
		[self knownName ifNil: [^ self nameMeIn: self pasteUpMorph]
					ifNotNil: [^ self renameMe]].
	old _ slotName.
	super choosePartName.
	slotName ifNil: [^ self].  "user chose bad slot name"
	self model: self world model slotName: slotName.
	old == nil 
		ifTrue: [self compilePropagationMethods]
		ifFalse: [self copySlotMethodsFrom: old].
			"old ones not erased!!"! !


!ComponentLikeModel methodsFor: 'components' stamp: 'ar 10/5/2000 17:25'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

	super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
	aMenu addLine.
	aMenu add: 'inspect' target: self action: #inspectInMorphic.
	aMenu add: 'delete' target: self action: #dismissMorph:.! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:14'!
addPinFromSpec: pinSpec
	| pin |
	pin _ PinMorph new component: self pinSpec: pinSpec.
	self addMorph: pin.
	pin placeFromSpec.
	^ pin! !

!ComponentLikeModel methodsFor: 'components' stamp: 'sw 10/23/2000 18:13'!
delete
	"Delete the receiver.  Possibly put up confirming dialog.  Abort if user changes mind"

	(model isKindOf: Component) ifTrue: [^ self deleteComponent].
	(model isKindOf: MorphicModel) ifFalse: [^ super delete].
	slotName ifNotNil:
		[(PopUpMenu confirm:
	'Shall I remove the slot ', slotName, '
	along with all associated methods?')
		ifTrue:
			[(model class selectors select: [:s | s beginsWith: slotName])
				do: [:s | model class removeSelector: s].
			(model class instVarNames includes: slotName)
				ifTrue: [model class removeInstVarName: slotName]]
		ifFalse:
			[(PopUpMenu confirm:
	'...but should I at least dismiss this morph?
	[choose no to leave everything unchanged]')
				ifFalse: [^ self]]].

	super delete.
! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:07'!
deleteComponent
	model removeDependent: self.
	self pinsDo: [:pin | pin delete].
	^ super delete! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 09:49'!
extent: newExtent
	super extent: newExtent.
	self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [m placeFromSpec]]! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/5/1998 00:57'!
initComponentIn: aLayout
	model _ aLayout model.
	self nameMeIn: aLayout.
	self color: Color lightCyan.
	self initPinSpecs.
	self initFromPinSpecs.
	self showPins.
	model addDependent: self! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:31'!
initFromPinSpecs
	"no-op for default"! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:11'!
initPinSpecs
	"no-op for default"
	pinSpecs _ Array new.
! !

!ComponentLikeModel methodsFor: 'components' stamp: 'ar 10/5/2000 20:03'!
justDroppedInto: aMorph event: anEvent
	| theModel |
	theModel _ aMorph modelOrNil.
	((aMorph isKindOf: ComponentLayout) 
		and: [theModel isKindOf: Component]) ifFalse:
		["Disconnect prior to removal by move"
		(theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
		^ super justDroppedInto: aMorph event: anEvent].
	theModel == model ifTrue: [^ self  "Presumably just a move"].
	self initComponentIn: aMorph.
	super justDroppedInto: aMorph event: anEvent! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/26/1998 10:40'!
nameMeIn: aWorld
	| stem otherNames i partName className |
	className _ self class name.
	stem _ className.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString , stem allButFirst.
	otherNames _ Set newFrom: aWorld allKnownNames.
	i _ 1.
	[otherNames includes: (partName _ stem , i printString)]
		whileTrue: [i _ i + 1].
	self setNamePropertyTo: partName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:18'!
pinSpecs
	^ pinSpecs! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:09'!
pinsDo: pinBlock
	self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [pinBlock value: m]]! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 09:26'!
renameMe
	| otherNames newName |
	otherNames _ Set newFrom: self pasteUpMorph allKnownNames.
	newName _ FillInTheBlank request: 'Please give this new a name'
						initialAnswer: self knownName.
	newName isEmpty ifTrue: [^ nil].
	(otherNames includes: newName) ifTrue:
			[self inform: 'Sorry, that name is already used'. ^ nil].
	self setNamePropertyTo: newName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 15:16'!
showPins
	"Make up sensitized pinMorphs for each of my interface variables"
	self pinSpecs do: [:pinSpec | self addPinFromSpec: pinSpec]! !
AbstractAnimation subclass: #CompositeAnimation
	instanceVariableNames: 'children childLoopCounts '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!CompositeAnimation commentStamp: '<historical>' prior: 0!
This class extends the basic Animation class for composite animations (animations built of other animations). It adds an instance variable for the component child animations, and a method for adding them to this collection.
!


!CompositeAnimation methodsFor: 'initialization' stamp: 'jsp 2/26/1999 13:53'!
append: child
	"Adds a child animation to the composite animation."

	child stop.
	children addLast: child.
	childLoopCounts addLast: (child getLoopCount).


! !

!CompositeAnimation methodsFor: 'initialization' stamp: 'jsp 2/26/1999 12:39'!
initialize
	"Creates an empty OrderedCollection for the child animations."

	children _ OrderedCollection new.
	childLoopCounts _ OrderedCollection new.
! !


!CompositeAnimation methodsFor: 'management' stamp: 'jsp 2/26/1999 13:55'!
prologue: currentTime
	"comment stating purpose of message"

	| index |

	super prologue: currentTime.

	index _ 1.
	children do: [:child | child setLoopCount: (childLoopCounts at: index).
						 index _ index + 1. ].
! !


!CompositeAnimation methodsFor: 'private' stamp: 'jsp 2/26/1999 14:35'!
getComponents
	"Return the component animations of the sequential animation"

	^ children.
! !

!CompositeAnimation methodsFor: 'private' stamp: 'jsp 2/26/1999 14:28'!
scaleDuration: scaleAmount
	"Scales the animation's duration by the specified amount"

	| i |

	super scaleDuration: scaleAmount.

	i _ 1.
	children do: [:child | child scaleDuration: (scaleAmount / (childLoopCounts at: i)).
						 i _ i + 1 ].
! !


!CompositeAnimation methodsFor: 'reversing' stamp: 'jsp 2/26/1999 14:41'!
reverseDirection
	"Changes the direction an animation runs in (forward or in reverse)"

	super reverseDirection.

	children do: [:child | child reverseDirection ].
! !

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

CompositeAnimation class
	instanceVariableNames: ''!

!CompositeAnimation class methodsFor: 'initialization' stamp: 'jsp 2/11/1999 14:52'!
new
	"Creates a new Composite animation and makes sure it gets initialized."

	^ super new initialize.
! !
VoiceEvent subclass: #CompositeEvent
	instanceVariableNames: 'timedEvents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!CompositeEvent methodsFor: 'initialization' stamp: 'len 8/28/1999 23:15'!
initialize: anInteger
	timedEvents _ SortedCollection new: anInteger! !


!CompositeEvent methodsFor: 'accessing-private' stamp: 'len 8/28/1999 22:54'!
timedEvents
	^ timedEvents! !

!CompositeEvent methodsFor: 'accessing-private' stamp: 'len 8/28/1999 22:54'!
timedEvents: aCollection
	timedEvents _ aCollection! !


!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:57'!
add: aVoiceEvent
	^ self add: aVoiceEvent at: self lastTime! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:57'!
add: aVoiceEvent at: time
	^ self timedEvents add: time -> aVoiceEvent! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 22:56'!
add: aVoiceEvent delayed: time
	^ self add: aVoiceEvent at: self lastTime + time! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:16'!
addAll: aCollection
	aCollection do: [ :each | self add: each].
	^ aCollection! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:08'!
at: anInteger
	^ (self timedEvents at: anInteger) value! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:18'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ self lastTime / 1000.0! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:09'!
first
	^ self at: 1! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 03:09'!
last
	^ self at: self size! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:17'!
lastTime
	| last |
	self isEmpty ifTrue: [^ 0].
	last _ self timedEvents last.
	^ last key + (last value duration * 1000) rounded! !

!CompositeEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:16'!
size
	^ self timedEvents size! !


!CompositeEvent methodsFor: 'converting' stamp: 'len 9/29/1999 02:52'!
asArray	
	^ (1 to: self size) collect: [ :each | self at: each]! !

!CompositeEvent methodsFor: 'converting' stamp: 'len 9/27/1999 22:48'!
asPHOString
	| stream |
	stream _ WriteStream on: String new.
	self do: [ :each | stream nextPutAll: each asPHOString; nextPut: Character cr].
	^ stream contents! !


!CompositeEvent methodsFor: 'copying' stamp: 'len 8/28/1999 23:16'!
copy
	| answer |
	answer _ self class new: self size.
	self timedEvents do: [ :each | answer add: each value copy at: each key].
	^ answer! !


!CompositeEvent methodsFor: 'enumerating' stamp: 'len 12/14/1999 05:49'!
detect: aBlock
	self detect: aBlock ifNone: [self error: 'event not found']! !

!CompositeEvent methodsFor: 'enumerating' stamp: 'len 12/14/1999 05:49'!
detect: aBlock ifNone: exceptionBlock
	self do: [ :each | (aBlock value: each) ifTrue: [^ each]].
	^ exceptionBlock value! !

!CompositeEvent methodsFor: 'enumerating' stamp: 'len 8/28/1999 23:09'!
do: aBlock
	self timedEvents do: [ :each | aBlock value: each value]! !


!CompositeEvent methodsFor: 'playing' stamp: 'len 12/22/1999 03:32'!
playOn: aVoice at: time
	self timedEvents do: [ :each | each value playOn: aVoice at: each key + time].
	aVoice flush! !


!CompositeEvent methodsFor: 'testing' stamp: 'len 8/28/1999 22:56'!
isEmpty
	^ self timedEvents isEmpty! !


!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:12'!
compress: aNumber
	self stretch: aNumber reciprocal! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:11'!
delay: time
	self timedEvents do: [ :each | each key: each key + time]! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 9/29/1999 05:16'!
pitchBy: aNumber
	self do: [ :each | each pitchBy: aNumber]! !

!CompositeEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
stretch: aNumber
	self do: [ :each | each stretch: aNumber].
	self timedEvents do: [ :each | each key: (each key * aNumber) rounded]! !


!CompositeEvent methodsFor: 'editing' stamp: 'len 9/28/1999 01:08'!
inspect
	"Open a OrderedCollectionInspector on the receiver.  Use basicInspect to get a normal (less useful) type of inspector."

	OrderedCollectionInspector openOn: self withEvalPane: true! !

!CompositeEvent methodsFor: 'editing' stamp: 'len 9/28/1999 01:08'!
inspectWithLabel: aLabel
	"Open a OrderedCollectionInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector."

	OrderedCollectionInspector openOn: self withEvalPane: true withLabel: aLabel! !


!CompositeEvent methodsFor: 'private' stamp: 'len 12/13/1999 02:47'!
recomputeTimes
	| oldTimedEvents |
	oldTimedEvents _ timedEvents.
	timedEvents _ SortedCollection new: oldTimedEvents size.
	oldTimedEvents do: [ :each | self add: each value]! !

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

CompositeEvent class
	instanceVariableNames: ''!

!CompositeEvent class methodsFor: 'instance creation' stamp: 'len 8/28/1999 23:14'!
new
	^ self new: 10! !

!CompositeEvent class methodsFor: 'instance creation' stamp: 'len 8/28/1999 23:15'!
new: anInteger
	^ self basicNew initialize: anInteger! !
DisplayTransform subclass: #CompositeTransform
	instanceVariableNames: 'globalTransform localTransform '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!CompositeTransform commentStamp: '<historical>' prior: 0!
A composite transform provides the effect of several levels of coordinate transformations.!


!CompositeTransform methodsFor: 'initialization' stamp: 'di 10/26/1999 17:08'!
composedWith: aTransform
	"Return a new transform that has the effect of transforming points first by the receiver and then by the argument."

	self isIdentity ifTrue: [^ aTransform].
	aTransform isIdentity ifTrue: [^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransform! !

!CompositeTransform methodsFor: 'initialization' stamp: 'di 3/4/98 19:17'!
globalTransform: gt localTransform: lt
	globalTransform _ gt.
	localTransform _ lt! !


!CompositeTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:00'!
isCompositeTransform
	^true! !

!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isIdentity
	^ globalTransform isIdentity and: [localTransform isIdentity]! !

!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isPureTranslation
	^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! !


!CompositeTransform methodsFor: 'transformations' stamp: 'di 10/1/1998 13:51'!
invert: aPoint
	^ globalTransform invert: (localTransform invert: aPoint)! !

!CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'!
transform: aPoint
	^ localTransform transform: (globalTransform transform: aPoint)! !


!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'!
angle
	^ localTransform angle + globalTransform angle! !

!CompositeTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:45'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self species new
		globalTransform: localTransform inverseTransformation
		localTransform: globalTransform inverseTransformation! !

!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:40'!
offset
	^ (self localPointToGlobal: 0@0) negated! !

!CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'!
scale
	^ localTransform scale * globalTransform scale! !


!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^localTransform globalPointToLocal:
		(globalTransform globalPointToLocal: aPoint)! !

!CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^globalTransform localPointToGlobal:
		(localTransform localPointToGlobal: aPoint)! !


!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'!
asCompositeTransform
	^self! !

!CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'!
asMatrixTransform2x3
	^globalTransform asMatrixTransform2x3
		composedWithLocal: localTransform asMatrixTransform2x3! !

!CompositeTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'!
asMorphicTransform
	"Squash a composite transform down to a simple one"
	^ MorphicTransform offset: self offset angle: self angle scale: self scale! !


!CompositeTransform methodsFor: 'encoding' stamp: 'ls 3/19/2000 16:28'!
encodeForRemoteCanvas
	^String streamContents: [ :str |
		str
			nextPutAll: 'Composite,';
			nextPutAll: '(';
			nextPutAll: globalTransform encodeForRemoteCanvas;
			nextPutAll: ')(';
			nextPutAll: localTransform encodeForRemoteCanvas;
			nextPutAll: ')' ]! !

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

CompositeTransform class
	instanceVariableNames: ''!

!CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:49'!
fromRemoteCanvasEncoding: encoding
	| firstStart firstEnd firstEncoding firstTransform secondStart secondEnd secondEncoding secondTransform |
	"format: Composite,(enc1)(enc2)"

	"decode the first encoding"
	firstStart := encoding indexOf: $(.
	firstStart = 0 ifTrue: [ self error: 'invalid encoding' ].
	firstEnd := encoding findCloseParenthesisFor: firstStart.
	firstEncoding := encoding copyFrom: firstStart+1 to: firstEnd-1.
	firstTransform := DisplayTransform fromRemoteCanvasEncoding: firstEncoding.

	"decode the second encoding"
	secondStart := firstEnd + 1.
	(encoding at: secondStart) = $( ifFalse: [ ^self error: 'invalid encoding' ].
	secondEnd := encoding findCloseParenthesisFor: secondStart.
	secondEncoding := encoding copyFrom: secondStart+1 to: secondEnd-1.
	secondTransform := DisplayTransform fromRemoteCanvasEncoding: secondEncoding.
	

	"put it together"
	^self globalTransform: firstTransform localTransform: secondTransform! !

!CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'!
globalTransform: gt localTransform: lt
	^self new globalTransform: gt localTransform: lt! !
Voice subclass: #CompositeVoice
	instanceVariableNames: 'voices '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!CompositeVoice methodsFor: 'initialization' stamp: 'len 8/28/1999 04:00'!
initialize
	super initialize.
	self voices: OrderedCollection new! !


!CompositeVoice methodsFor: 'accessing' stamp: 'len 9/13/1999 00:00'!
add: aVoice
	^ self voices add: aVoice! !

!CompositeVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 04:01'!
voices
	^ voices! !

!CompositeVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 04:00'!
voices: aCollection
	voices _ aCollection! !


!CompositeVoice methodsFor: 'enumerating' stamp: 'len 8/29/1999 02:21'!
do: aBlock
	self voices do: aBlock! !


!CompositeVoice methodsFor: 'playing' stamp: 'len 12/22/1999 03:51'!
flush
	"Play all the events in the queue."
	super flush.
	self do: [ :each | each flush]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:21'!
playGesturalEvent: event at: time
	self do: [ :each | each playGesturalEvent: event at: time]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:21'!
playPhoneticEvent: event at: time
	self do: [ :each | each playPhoneticEvent: event at: time]! !

!CompositeVoice methodsFor: 'playing' stamp: 'len 9/26/1999 17:22'!
reset
	"Reset the state of the receiver."
	super reset.
	self do: [ :each | each reset]! !
CharacterScanner subclass: #CompositionScanner
	instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!CompositionScanner commentStamp: '<historical>' prior: 0!
CompositionScanners are used to measure text and determine where line breaks and space padding should occur.!


!CompositionScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 17:21'!
composeFrom: startIndex inRectangle: lineRectangle
	firstLine: firstLine leftSide: leftSide rightSide: rightSide
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	"Set up margins"
	leftMargin _ lineRectangle left.
	leftSide ifTrue: [leftMargin _ leftMargin +
						(firstLine ifTrue: [textStyle firstIndent]
								ifFalse: [textStyle restIndent])].
	destX _ spaceX _ leftMargin.
	rightMargin _ lineRectangle right.
	rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent].
	lastIndex _ startIndex.	"scanning sets last index"
	destY _ lineRectangle top.
	lineHeight _ baseline _ 0.  "Will be increased by setFont"
	self setStopConditions.	"also sets font"
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
				rectangle: lineRectangle;
				leftMargin: leftMargin.
	
	spaceCount _ 0.
	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [^ line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 17:21'!
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 
	"Answer an instance of TextLineInterval that represents the next line in the paragraph."
	| runLength done stopCondition |
	destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
	destY _ 0.
	rightMargin _ aParagraph rightMarginForComposition.
	leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
	lastIndex _ startIndex.	"scanning sets last index"
	lineHeight _ textStyle lineGrid.  "may be increased by setFont:..."
	baseline _ textStyle baseline.
	self setStopConditions.	"also sets font"
	runLength _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
	line _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	spaceCount _ 0.
	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
				in: text string rightX: rightMargin stopConditions: stopConditions
				kern: kern.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [^line lineHeight: lineHeight + textStyle leading
							baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:36'!
setActualFont: aFont
	"Keep track of max height and ascent for auto lineheight"
	| descent |
	super setActualFont: aFont.
	lineHeight == nil
		ifTrue: [descent _ font descent.
				baseline _ font ascent.
				lineHeight _ baseline + descent]
		ifFalse: [descent _ lineHeight - baseline max: font descent.
				baseline _ baseline max: font ascent.
				lineHeight _ lineHeight max: baseline + descent]! !


!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	spaceX _ destX.
	line paddingWidth: rightMargin - spaceX.
	^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
crossedX
	"There is a word that has fallen across the right edge of the composition 
	rectangle. This signals the need for wrapping which is done to the last 
	space that was encountered, as recorded by the space stop condition."

	spaceCount >= 1 ifTrue:
		["The common case. First back off to the space at which we wrap."
		line stop: spaceIndex.
		lineHeight _ lineHeightAtSpace.
		baseline _ baselineAtSpace.
		spaceCount _ spaceCount - 1.
		spaceIndex _ spaceIndex - 1.

		"Check to see if any spaces preceding the one at which we wrap.
			Double space after punctuation, most likely."
		[(spaceCount > 1 and: [(text at: spaceIndex) = Space])]
			whileTrue:
				[spaceCount _ spaceCount - 1.
				"Account for backing over a run which might
					change width of space."
				font _ text fontAt: spaceIndex withStyle: textStyle.
				spaceIndex _ spaceIndex - 1.
				spaceX _ spaceX - (font widthOf: Space)].
		line paddingWidth: rightMargin - spaceX.
		line internalSpaces: spaceCount]
	ifFalse:
		["Neither internal nor trailing spaces -- almost never happens."
		lastIndex _ lastIndex - 1.
		[destX <= rightMargin]
			whileFalse:
				[destX _ destX - (font widthOf: (text at: lastIndex)).
				lastIndex _ lastIndex - 1].
		spaceX _ destX.
		line paddingWidth: rightMargin - destX.
		line stop: (lastIndex max: line first)].
	^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'!
endOfRun
	"Answer true if scanning has reached the end of the paragraph. 
	Otherwise step conditions (mostly install potential new font) and answer 
	false."

	| runLength |
	lastIndex = text size
	ifTrue:	[line stop: lastIndex.
			spaceX _ destX.
			line paddingWidth: rightMargin - destX.
			^true]
	ifFalse:	[runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
			runStopIndex _ lastIndex + (runLength - 1).
			self setStopConditions.
			^false]
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'!
placeEmbeddedObject: anchoredMorph
	| descent |
	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	descent _ lineHeight - baseline.
	lineHeight _ lineHeight max: anchoredMorph height.
	baseline _ lineHeight - descent.
	^ true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:48'!
setFont
	super setFont.
	stopConditions == DefaultStopConditions 
		ifTrue:[stopConditions _ stopConditions copy].
	stopConditions at: Space asciiValue + 1 put: #space.! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:55'!
space
	"Record left x and character index of the space character just encounted. 
	Used for wrap-around. Answer whether the character has crossed the 
	right edge of the composition rectangle of the paragraph."

	spaceX _ destX.
	destX _ spaceX + spaceWidth.
	spaceIndex _ lastIndex.
	lineHeightAtSpace _ lineHeight.
	baselineAtSpace _ baseline.
	lastIndex _ lastIndex + 1.
	spaceCount _ spaceCount + 1.
	destX > rightMargin ifTrue: 	[^self crossedX].
	^false
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:59'!
tab
	"Advance destination x according to tab settings in the paragraph's 
	textStyle. Answer whether the character has crossed the right edge of 
	the composition rectangle of the paragraph."

	destX _ textStyle
				nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin.
	destX > rightMargin ifTrue:	[^self crossedX].
	lastIndex _ lastIndex + 1.
	^false
! !


!CompositionScanner methodsFor: 'accessing' stamp: 'ar 1/8/2000 14:35'!
rightX
	"Meaningful only when a line has just been composed -- refers to the 
	line most recently composed. This is a subtrefuge to allow for easy 
	resizing of a composition rectangle to the width of the maximum line. 
	Useful only when there is only one line in the form or when each line 
	is terminated by a carriage return. Handy for sizing menus and lists."

	^spaceX! !


!CompositionScanner methodsFor: 'intialize-release' stamp: 'ar 5/17/2000 19:14'!
forParagraph: aParagraph
	"Initialize the receiver for scanning the given paragraph."

	self
		initializeFromParagraph: aParagraph
		clippedBy: aParagraph clippingRectangle.
! !
TileLikeMorph subclass: #CompoundTileMorph
	instanceVariableNames: 'type testPart yesPart noPart '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!CompoundTileMorph commentStamp: '<historical>' prior: 0!
A statement with other whole statements inside it.  If-Then.  Test.!


!CompoundTileMorph methodsFor: 'initialization' stamp: 'sw 2/1/2001 16:36'!
initialize

	| r |
	super initialize.
	self color: Color orange muchLighter.
	self borderWidth: 1.
	self layoutInset: 2.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	r _ AlignmentMorph newRow color: color; layoutInset: 0.
	r setProperty: #demandsBoolean toValue: true.
	r addMorphBack: (Morph new color: color; extent: 2@5).  "spacer"
	r addMorphBack: (StringMorph new contents: 'Test').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1).
	testPart color: Color transparent.
	self addMorphBack: r.

	r _ AlignmentMorph newRow color: color; layoutInset: 0.
	r addMorphBack: (Morph new color: color; extent: 30@5).  "spacer"
	r addMorphBack: (StringMorph new contents: 'Yes').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2).
	yesPart color: Color transparent.
	self addMorphBack: r.

	r _ AlignmentMorph newRow color: color; layoutInset: 0.
	r addMorphBack: (Morph new color: color; extent: 35@5).  "spacer"
	r addMorphBack: (StringMorph new contents: 'No').
	r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
	r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2).
	noPart color: Color transparent.
	self addMorphBack: r.

	self extent: 5@5.  "will grow to fit"
! !


!CompoundTileMorph methodsFor: 'access' stamp: 'sw 8/11/1998 16:42'!
associatedPlayer
	^ nil! !

!CompoundTileMorph methodsFor: 'access' stamp: 'di 11/12/2000 15:31'!
enclosingEditor
	"Return the next scriptor outward in the containment hierarchy"
	^ self firstOwnerSuchThat:
		[:m | (m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]]! !

!CompoundTileMorph methodsFor: 'access' stamp: 'sw 10/13/97 21:23'!
scriptee
	 "Pertains only when the test is outside a script?!!"
	^ nil! !


!CompoundTileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:22'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!CompoundTileMorph methodsFor: 'code generation' stamp: 'jm 5/29/1998 10:26'!
storeCodeBlockFor: scriptPart on: aStream indent: tabCount

	| rows r |
	rows _ scriptPart tileRows.
	1 to: rows size do: [:i |
		tabCount timesRepeat: [aStream tab].
		r _ rows at: i.
		r do: [:t | t storeCodeOn: aStream indent: tabCount].
		i < rows size ifTrue: [aStream nextPut: $.; cr]].
! !

!CompoundTileMorph methodsFor: 'code generation' stamp: 'jm 5/29/1998 10:31'!
storeCodeOn: aStream indent: tabCount

	aStream nextPut: $(.
	testPart storeCodeOn: aStream indent: 0.
	aStream nextPut: $); cr.

	tabCount + 1 timesRepeat: [aStream tab].
	aStream nextPutAll: 'ifTrue: ['; cr.
	self storeCodeBlockFor: yesPart on: aStream indent: tabCount + 2.
	aStream nextPut: $]; cr.
	tabCount + 1 timesRepeat: [aStream tab].
	aStream nextPutAll: 'ifFalse: ['; cr.
	self storeCodeBlockFor: noPart on: aStream indent: tabCount + 2.
	aStream nextPut: $].
! !


!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/18/97 18:03'!
install
	"Backstop for obscure cases"! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/13/97 21:25'!
markEdited
	"Pertains only when the test is outside a script?!!"
! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'di 10/17/97 16:31'!
resultType
	^ #command! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 5/13/1998 15:19'!
rowOfRightTypeFor: aLayoutMorph forActor: anActor
	aLayoutMorph demandsBoolean ifTrue:
		[^ self error: 'oops, cannot do that, please close this'].
	^ self! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/13/97 21:23'!
scriptEdited
	 "Pertains only when the test is outside a script?!!"! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'di 5/6/1998 21:10'!
tile: tile isOnLineAfter: previousTile
	"Return true if the given tile is not on the same line at the previous tile or if the previous tile is nil."

	| tileRow previousRow |
	previousTile ifNil: [^ true].
	tileRow _ tile owner.
	[tileRow isMemberOf: AlignmentMorph]
		whileFalse: [tileRow _ tileRow owner].  "find the owning row"
	previousRow _ previousTile owner.
	[previousRow isMemberOf: AlignmentMorph]
		whileFalse: [previousRow _ previousRow owner].  "find the owning row"
	^ tileRow ~~ previousRow
! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/20/2001 00:30'!
tileRows
	"Answer a list of tile rows, in this case just one though it's compound"

	^ Array with: (Array with: self fullCopyWithoutFormerOwner)! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'tk 8/4/1999 23:03'!
tilesFrom: msgNode in: aScriptor
	"Construct an if-then from a parseTree."

	| sel |
	testPart playerScripted: aScriptor playerScripted.
	yesPart playerScripted: aScriptor playerScripted.
	noPart playerScripted: aScriptor playerScripted.
	testPart tilesFrom: msgNode receiver receiver. 	"strip off (test ~~ false)"
	sel _ msgNode selector key.
	sel == #ifTrue:ifFalse: ifTrue: [
		yesPart tilesFrom: msgNode arguments first.
		noPart tilesFrom: msgNode arguments second].
	sel == #ifTrue: ifTrue: [
		yesPart tilesFrom: msgNode arguments first].
	sel == #ifFalse: ifTrue: [
		noPart tilesFrom: msgNode arguments first].

! !

!CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/13/97 20:25'!
topEditor
	| editor |
	editor _ self outermostMorphThat: [:m | (m isKindOf: ScriptEditorMorph) or:
		 [m isKindOf: CompoundTileMorph]].
	^ editor ifNil: [self] ifNotNil: [editor]! !

!CompoundTileMorph methodsFor: 'miscellaneous'!
type

	^ #compound
! !


!CompoundTileMorph methodsFor: 'mouse'!
acceptDroppingMorph: aMorph event: evt
	"Forward the dropped morph to the appropriate part."

	(self targetPartFor: aMorph) acceptDroppingMorph: aMorph event: evt.
! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'di 7/3/1998 14:25'!
handlesDragOver: evt

	^ true
! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'di 10/17/97 21:36'!
handlesMouseOver: evt

	^ true
! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 07:50'!
handlesMouseOverDragging: evt

	^ true
! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'jm 10/18/97 21:03'!
mouseEnter: evt
	"Resume drop-tracking in enclosing editor"
	| ed |
	(ed _ self enclosingEditor) ifNotNil:
		[ed mouseLeave: evt]! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'jm 10/18/97 21:02'!
mouseLeave: evt
	"Resume drop-tracking in enclosing editor"
	| ed |
	(ed _ self enclosingEditor) ifNotNil:
		[ed mouseEnter: evt]! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!CompoundTileMorph methodsFor: 'mouse' stamp: 'sw 2/1/98 16:40'!
prepareToUndoDropOf: aMorph
	"needs to be here, as a no-op, owing to being hit obscurely on occasion"! !

!CompoundTileMorph methodsFor: 'mouse'!
targetPartFor: aMorph
	"Return the row into which the given morph should be inserted."

	| centerY |
	centerY _ aMorph fullBounds center y.
	(Array with: testPart with: yesPart with: noPart) do: [:m |
		(centerY <= m bounds bottom) ifTrue: [^ m]].
	^ noPart
! !

!CompoundTileMorph methodsFor: 'mouse'!
wantsDroppedMorph: aMorph event: evt

	^ (aMorph isKindOf: TileMorph) or:
	   [(aMorph isKindOf: ScriptEditorMorph) or:
	   [(aMorph isKindOf: CompoundTileMorph) or:
	   [aMorph isKindOf: CommandTilesMorph]]]
! !

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

CompoundTileMorph class
	instanceVariableNames: ''!

!CompoundTileMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Object subclass: #CompressedBoundaryShape
	instanceVariableNames: 'points leftFills rightFills lineWidths lineFills fillStyles '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!CompressedBoundaryShape commentStamp: '<historical>' prior: 0!
This class represents a very compact representation of a boundary shape. It consists of a number of compressed arrays that can be handled by the balloon engine directly. Due to this, there are certain restrictions (see below). Boundaries are always represented by three subsequent points that define a quadratic bezier segment. It is recommended that for straight line segments the control point is set either to the previous or the next point.

Instance variables:
	points		<PointArray | ShortPointArray>	Point storage area
	leftFills		<ShortRunArray>	Containing the "left" fill index of each segment
	rightFills	<ShortRunArray>	Containing the "right" fill index of each segment
	lineWidths	<ShortRunArray>	Containing the line width of each segment
	lineFills		<ShortRunArray>	Containing the line fill (e.g., line color) of each segment
	fillStyles	<Collections>			Contains the actual fill styles referenced by the indexes

RESTRICTIONS:
None of the ShortRunArrays may contain a run of length Zero.
Also, due to the use of ShortRunArrays 
	a) you cannot have more than 32768 different fill styles
	b) you cannot have a line width that exceeds 32768
In case you have trouble with a), try to merge some of the fills into one. You might do so by converting colors to 32bit pixel values. In case you have trouble with b) you might change the general resolution of the compressed shape to have less accuracy.
!


!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ls 10/10/1999
13:52'!
bounds
	| min max width |
	points isEmpty ifTrue:[^0@0 corner: 1@1].
	min _ max _ points first.
	points do:[:pt|
		min _ min min: pt.
		max _ max max: pt
	].
	width _ 0.
	lineWidths valuesDo:[:w| width _ width max: w].
	^(min corner: max) insetBy: (width negated asPoint)! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
fillStyles
	^fillStyles! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
leftFills
	^leftFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
lineFills
	^lineFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
lineWidths
	^lineWidths! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/4/1998 13:50'!
numSegments
	^points size // 3! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 20:42'!
points
	^points! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'!
rightFills
	^rightFills! !

!CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:09'!
segments
	"Return all the segments in the receiver"
	| out |
	out _ WriteStream on: Array new.
	self segmentsDo:[:seg| out nextPut: seg].
	^out contents! !


!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:12'!
collectFills: aBlock
	fillStyles _ fillStyles collect: aBlock.! !

!CompressedBoundaryShape methodsFor: 'editing' stamp: 'ar 11/12/1998 21:11'!
copyAndCollectFills: aBlock
	^self copy collectFills: aBlock! !


!CompressedBoundaryShape methodsFor: 'enumerating' stamp: 'ar 11/9/1998 14:10'!
segmentsDo: aBlock
	"Enumerate all segments in the receiver and execute aBlock"
	| p1 p2 p3 |
	1 to: points size by: 3 do:[:i|
		p1 _ points at: i.
		p2 _ points at: i+1.
		p3 _ points at: i+2.
		(p1 = p2 or:[p2 = p3]) ifTrue:[
			aBlock value: (LineSegment from: p1 to: p3).
		] ifFalse:[
			aBlock value: (Bezier2Segment from: p1 via: p2 to: p3).
		].
	].! !


!CompressedBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 18:03'!
setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
	points _ pointList.
	leftFills _ leftFillList.
	rightFills _ rightFillList.
	lineWidths _ lineWidthList.
	lineFills _ lineFillList.
	fillStyles _ fillStyleList.! !


!CompressedBoundaryShape methodsFor: 'morphing' stamp: 'ar 9/3/1999 17:19'!
morphFrom: srcShape to: dstShape at: ratio
	| scale unscale srcPoints dstPoints pt1 pt2 x y |
	scale _ (ratio * 1024) asInteger.
	scale < 0 ifTrue:[scale _ 0].
	scale > 1024 ifTrue:[scale _ 1024].
	unscale _ 1024 - scale.
	srcPoints _ srcShape points.
	dstPoints _ dstShape points.
	1 to: points size do:[:i|
		pt1 _ srcPoints at: i.
		pt2 _ dstPoints at: i.
		x _ ((pt1 x * unscale) + (pt2 x * scale)) bitShift: -10.
		y _ ((pt1 y * unscale) + (pt2 y * scale)) bitShift: -10.
		points at: i put: x@y].! !

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

CompressedBoundaryShape class
	instanceVariableNames: ''!

!CompressedBoundaryShape class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 16:28'!
points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList
	^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList! !

!CompressedBoundaryShape class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 18:02'!
points: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList
	^self new setPoints: pointList leftFills: leftFillList rightFills: rightFillList fillStyles: fillStyleList lineWidths: lineWidthList lineFills: lineFillList! !
Object subclass: #CompressedSoundData
	instanceVariableNames: 'channels soundClassName codecName loopEnd loopLength perceivedPitch samplingRate gain firstSample cachedSound '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!CompressedSoundData commentStamp: '<historical>' prior: 0!
Instances of this class hold the data resulting from compressing a sound.  Each carries a reference to the codec class that created it, so that it can reconstruct a sound similar to the original in response to the message asSound.

In order to facilitate integration with existing sounds, a CompressedSoundData instance can masquerade as a sound by caching a copy of its original sound and delegating the essential sound-playing protocol to that cached copy.  It should probably be made a subclass of AbstractSound to complete the illusion.!


!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:10'!
channels
	"Answer an array of ByteArrays containing the compressed sound data for each channel."

	^ channels
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'!
channels: anArray

	channels _ anArray.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'!
codecName
	"Answer the name of the sound codec used to compress this sound. Typically, this is the name of a class that can be used to decode the sound, but it is possible that the codec has not yet been implemented or is not filed into this image."

	^ codecName
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:45'!
codecName: aStringOrSymbol

	codecName _ aStringOrSymbol asSymbol.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'!
firstSample
	"Answer the firstSample of the original sound."

	^ firstSample
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'!
firstSample: anInteger

	firstSample _ anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:55'!
gain
	"Answer the gain of the original sound."

	^ gain
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'!
gain: aNumber

	gain _ aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'!
loopEnd
	"Answer index of the last sample of the loop, or nil if the original sound was not looped."

	^ loopEnd
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'!
loopEnd: anInteger

	loopEnd _ anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'!
loopLength
	"Answer length of the loop, or nil if the original sound was not looped."

	^ loopLength
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'!
loopLength: anInteger

	loopLength _ anInteger.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'!
perceivedPitch
	"Answer the perceived pitch of the original sound. By convention, unpitched sounds (like drum hits) are given an arbitrary pitch of 100.0."

	^ perceivedPitch
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'!
perceivedPitch: aNumber

	perceivedPitch _ aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:13'!
samplingRate
	"Answer the samplingRate of the original sound."

	^ samplingRate
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:36'!
samplingRate: aNumber

	samplingRate _ aNumber.
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'!
soundClassName
	"Answer the class name of the uncompressed sound."

	^ soundClassName
! !

!CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'!
soundClassName: aStringOrSymbol

	soundClassName _ aStringOrSymbol asSymbol.
! !


!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:15'!
asSound
	"Answer the result of decompressing the receiver."

	| codecClass |
	codecClass _ Smalltalk at: codecName
		ifAbsent: [^ self error: 'The codec for decompressing this sound is not available'].
	^ (codecClass new decompressSound: self) reset
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'!
doControl

	cachedSound doControl
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol

	cachedSound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:49'!
reset
	"This message is the cue to start behaving like a real sound in order to be played.
	We do this by caching a decompressed version of this sound.
	See also samplesRemaining."

	cachedSound == nil ifTrue: [cachedSound _ self asSound].
	cachedSound reset
! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:44'!
samples

	^ self asSound samples! !

!CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:49'!
samplesRemaining
	"This message is the cue that the cached sound may no longer be needed.
	We know it is done playing when samplesRemaining=0."

	| samplesRemaining |
	samplesRemaining _ cachedSound samplesRemaining.
	samplesRemaining <= 0 ifTrue: [cachedSound _ nil].
	^ samplesRemaining! !


!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 09:50'!
compressWith: codecClass

	codecName == codecClass name asSymbol ifTrue: [^self].
	^self asSound compressWith: codecClass! !

!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 12/24/2000 08:53'!
compressWith: codecClass atRate: aSamplingRate

	(codecName == codecClass name asSymbol and: [samplingRate = aSamplingRate]) ifTrue: [^self].
	^self asSound compressWith: codecClass atRate: aSamplingRate! !

!CompressedSoundData methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 19:25'!
withEToySound: aByteArray samplingRate: anInteger

	soundClassName _ #SampledSound.
	channels _ {aByteArray}.
	codecName _ #GSMCodec.
	loopEnd _ nil.	"???"
	loopLength _  nil.
	perceivedPitch _ 100.0.
	samplingRate  _ anInteger.
	gain  _ 1.0.	"???"
	firstSample _ 1.
	cachedSound  _ nil.	"???"! !
Object subclass: #ConnectionQueue
	instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ConnectionQueue commentStamp: '<historical>' prior: 0!
A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones.
!


!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 17:31'!
connectionCount
	"Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment."

	| count |
	self pruneStaleConnections.
	accessSema critical: [count _ connections size].
	^ count
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'!
destroy
	"Terminate the listener process and destroy all sockets in my possesion."

	process ifNotNil: [
		process terminate.
		process _ nil].
	socket ifNotNil: [
		socket destroy.
		socket _ nil].
	connections do: [:s | s destroy].
	connections _ OrderedCollection new.
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 09:18'!
getConnectionOrNil
	"Return a connected socket, or nil if no connection has been established."

	| result |
	accessSema critical: [
		connections isEmpty
			ifTrue: [result _ nil]
			ifFalse: [
				result _ connections removeFirst.
				((result isValid) and: [result isConnected]) ifFalse: [  "stale connection"
					result destroy.
					result _ nil]]].
	^ result
! !

!ConnectionQueue methodsFor: 'public' stamp: 'RAA 7/15/2000 12:36'!
getConnectionOrNilLenient
	"Return a connected socket, or nil if no connection has been established."

	| result |
	accessSema critical: [
		connections isEmpty ifTrue: [
			result _ nil
		] ifFalse: [
			result _ connections removeFirst.
			(result isValid and: [result isConnected or: [result isOtherEndClosed]]) ifFalse: [
				"stale connection"
				result destroy.
				result _ nil
			]
		]
	].
	^ result
! !

!ConnectionQueue methodsFor: 'public' stamp: 'ls 9/26/1999 15:34'!
isValid
	^process notNil! !


!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'!
initPortNumber: anInteger queueLength: queueLength
	"Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued."

	portNumber _ anInteger.
	maxQueueLength _ queueLength.
	connections _ OrderedCollection new.
	accessSema _ Semaphore forMutualExclusion.
	socket _ nil.
	process _ [self listenLoop] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!ConnectionQueue methodsFor: 'private' stamp: 'ls 4/8/2000 20:39'!
listenLoop
	"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
	"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
	"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."


	| newConnection |
	Socket initializeNetwork.
	socket _ Socket newTCP.
	"We'll accept four simultanous connections at the same time"
	socket listenOn: portNumber backlogSize: 4.
	"If the listener is not valid then the we cannot use the
	BSD style accept() mechanism."
	socket isValid ifFalse: [^self oldStyleListenLoop].
	[true] whileTrue: [
		socket isValid ifFalse: [
			"socket has stopped listening for some reason"
			socket destroy.
			(Delay forMilliseconds: 10) wait.
			^self listenLoop ].
		newConnection _ socket waitForAcceptUntil: (Socket deadlineSecs: 10).
		(newConnection notNil and:[newConnection isConnected]) ifTrue:
			[accessSema critical: [connections addLast: newConnection].
			newConnection _ nil].
		self pruneStaleConnections]. ! !

!ConnectionQueue methodsFor: 'private' stamp: 'bolot 7/16/1999 14:27'!
oldStyleListenLoop
	"Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
	"Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."
	"Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms."

	[true] whileTrue: [
		((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [
			"try to create a new socket for listening"
			socket _ Socket createIfFail: [nil]].

		socket == nil
			ifTrue: [(Delay forMilliseconds: 100) wait]
			ifFalse: [
				socket isUnconnected ifTrue: [socket listenOn: portNumber].
				socket waitForConnectionUntil: (Socket deadlineSecs: 10).
				socket isConnected
					ifTrue: [  "connection established"
						accessSema critical: [connections addLast: socket].
						socket _ nil]
					ifFalse: [
						socket isWaitingForConnection
							ifFalse: [socket destroy. socket _ nil]]].  "broken socket; start over"
		self pruneStaleConnections].
! !

!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 17:30'!
pruneStaleConnections
	"Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections."

	| foundStaleConnection |
	accessSema critical: [
		foundStaleConnection _ false.
		connections do: [:s |
			s isUnconnected ifTrue: [
				s destroy.
				foundStaleConnection _ true]].
		foundStaleConnection ifTrue: [
			connections _ connections select: [:s | s isValid]]].
! !

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

ConnectionQueue class
	instanceVariableNames: ''!

!ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'!
portNumber: anInteger queueLength: queueLength

	^ self new initPortNumber: anInteger queueLength: queueLength
! !
InstructionStream subclass: #ContextPart
	instanceVariableNames: 'stackp '
	classVariableNames: 'PrimitiveFailToken '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!ContextPart commentStamp: '<historical>' prior: 0!
To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.
	
The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
	Transcript show: (ContextPart runSimulated: [3 factorial]) printString.!


!ContextPart methodsFor: 'accessing'!
client
	"Answer the client, that is, the object that sent the message that created this context."

	^sender receiver! !

!ContextPart methodsFor: 'accessing'!
home
	"Answer the context in which the receiver was defined."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
method
	"Answer the method of this context."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
receiver
	"Answer the receiver of the message that created this context."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index
	"Answer the value of the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index put: value 
	"Store the argument, value, as the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility! !


!ContextPart methodsFor: 'instruction decoding'!
doDup
	"Simulate the action of a 'duplicate top of stack' bytecode."

	self push: self top! !

!ContextPart methodsFor: 'instruction decoding'!
doPop
	"Simulate the action of a 'remove top of stack' bytecode."

	self pop! !

!ContextPart methodsFor: 'instruction decoding'!
jump: distance 
	"Simulate the action of a 'unconditional jump' bytecode whose offset is 
	the argument, distance."

	pc _ pc + distance! !

!ContextPart methodsFor: 'instruction decoding'!
jump: distance if: condition 
	"Simulate the action of a 'conditional jump' bytecode whose offset is the 
	argument, distance, and whose condition is the argument, condition."

	(self pop eqv: condition) ifTrue: [self jump: distance]! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnConstant: value 
	"Simulate the action of a 'return constant' bytecode whose value is the 
	argument, value. This corresponds to a source expression like '^0'."

	^self return: value to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^self'."

	^self return: self receiver to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnTop
	"Simulate the action of a 'return top of stack' bytecode. This corresponds 
	to source expressions like '^something'."

	^self return: self pop to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into a literal variable of my method."

	value value: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into one of my temporary variables."

	self home at: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
pushActiveContext
	"Simulate the action of bytecode that pushes the the active context on the 
	top of its own stack."

	self push: self! !

!ContextPart methodsFor: 'instruction decoding'!
pushConstant: value 
	"Simulate the action of bytecode that pushes the constant, value, on the 
	top of the stack."

	self push: value! !

!ContextPart methodsFor: 'instruction decoding'!
pushLiteralVariable: value 
	"Simulate the action of bytecode that pushes the contents of the literal 
	variable whose index is the argument, index, on the top of the stack."

	self push: value value! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiver
	"Simulate the action of bytecode that pushes the active context's receiver 
	on the top of the stack."

	self push: self receiver! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiverVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the receiver's 
	instance variable whose index is the argument, index, on the top of the 
	stack."

	self push: (self receiver instVarAt: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the 
	temporary variable whose index is the argument, index, on the top of 
	the stack."

	self push: (self home at: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'ar 5/25/2000 20:45'!
send: selector super: superFlag numArgs: numArgs
	"Simulate the action of bytecodes that send a message with selector, 
	selector. The argument, superFlag, tells whether the receiver of the 
	message was specified with 'super' in the source method. The arguments 
	of the message are found in the top numArgs locations on the stack and 
	the receiver just below them."

	| receiver arguments answer |
	arguments _ Array new: numArgs.
	numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop].
	receiver _ self pop.
	(selector == #halt or: [selector == #halt:]) ifTrue:
		[self error: 'Cant simulate halt.  Proceed to bypass it.'.
		self push: nil. ^self].
	selector == #doPrimitive:method:receiver:args:
		ifTrue: [answer _ receiver 
					doPrimitive: (arguments at: 1)
					method: (arguments at: 2)
					receiver: (arguments at: 3)
					args: (arguments at: 4).
				self push: answer.
				^self].
	^self send: selector to: receiver with: arguments super: superFlag! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: value 
	"Simulate the action of bytecode that stores the top of the stack into a 
	literal variable of my method."

	value value: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into an 
	instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into one 
	of my temporary variables."

	self home at: offset + 1 put: self top! !


!ContextPart methodsFor: 'debugger access'!
depthBelow: aContext
	"Answer how many calls there are between this and aContext."

	| this depth |
	this _ self.
	depth _ 0.
	[this == aContext or: [this == nil]]
		whileFalse:
			[this _ this sender.
			depth _ depth + 1].
	^depth! !

!ContextPart methodsFor: 'debugger access' stamp: 'RAA 5/16/2000 12:14'!
longStack
	"Answer a String showing the top 100 contexts on my sender chain."

	^ String streamContents:
		[:strm |
		(self stackOfSize: 100)
			do: [:item | strm print: item; cr]]! !

!ContextPart methodsFor: 'debugger access' stamp: 'ls 12/5/1999 13:43'!
mclass 
	"Answer the class in which the receiver's method was found."
	| mclass |
	self receiver class selectorAtMethod: self method setClass: [:mc |
mclass _ mc ].
	^mclass! !

!ContextPart methodsFor: 'debugger access'!
pc
	"Answer the index of the next bytecode to be executed."

	^pc! !

!ContextPart methodsFor: 'debugger access'!
release
	"Remove information from the receiver and all of the contexts on its 
	sender chain in order to break circularities."

	self releaseTo: nil! !

!ContextPart methodsFor: 'debugger access'!
releaseTo: caller 
	"Remove information from the receiver and the contexts on its sender 
	chain up to caller in order to break circularities."

	| c s |
	c _ self.
	[c == nil or: [c == caller]]
		whileFalse: 
			[s _ c sender.
			c singleRelease.
			c _ s]! !

!ContextPart methodsFor: 'debugger access'!
selector
	"Answer the selector of the method that created the receiver."

	^self receiver class 
		selectorAtMethod: self method 
		setClass: [:ignored]! !

!ContextPart methodsFor: 'debugger access'!
sender
	"Answer the context that sent the message that created the receiver."

	^sender! !

!ContextPart methodsFor: 'debugger access' stamp: 'di 8/31/1999 09:42'!
shortStack
	"Answer a String showing the top ten contexts on my sender chain."

	^ String streamContents:
		[:strm |
		(self stackOfSize: 10)
			do: [:item | strm print: item; cr]]! !

!ContextPart methodsFor: 'debugger access'!
singleRelease
	"Remove information from the receiver in order to break circularities."

	stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]].
	sender _ nil! !

!ContextPart methodsFor: 'debugger access' stamp: 'ar 7/9/1999 19:01'!
sourceCode
	| selector methodClass |
	selector _ self receiver class selectorAtMethod: self method
		setClass: [:mclass | methodClass _ mclass].
	^self method getSourceFor: selector in: methodClass
	"Note: The above is a bit safer than
		^ methodClass sourceCodeAt: selector
	which may fail if the receiver's method has been changed in
	the debugger (e.g., the method is no longer in the methodDict
	and thus the above selector is something like #Doit:with:with:with:)
	but the source code is still available."! !

!ContextPart methodsFor: 'debugger access'!
stack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 9999! !

!ContextPart methodsFor: 'debugger access' stamp: 'tfei 3/20/2000 00:51'!
stackOfSize: limit 
	"Answer an OrderedCollection of the top 'limit' contexts
		on the receiver's sender chain."

	| a stack cachedStackTop newLimit |
	stack _ OrderedCollection new.
	stack addLast: (a _ self).
	[(a _ a sender) ~~ nil and: [stack size < limit]]
		whileTrue:
			[a hideFromDebugger ifFalse: [stack addLast: a].
			a cachesStack ifTrue: [cachedStackTop := a cachedStackTop]].
	^cachedStackTop == nil 
		ifTrue: [stack]
		ifFalse:
			[newLimit := limit - stack size.
			newLimit > 0
				ifTrue: [stack addAllLast: (cachedStackTop stackOfSize: newLimit); yourself]
				ifFalse: [stack]]! !

!ContextPart methodsFor: 'debugger access'!
swapSender: coroutine 
	"Replace the receiver's sender with coroutine and answer the receiver's 
	previous sender. For use in coroutining."

	| oldSender |
	oldSender _ sender.
	sender _ coroutine.
	^oldSender! !

!ContextPart methodsFor: 'debugger access' stamp: 'ls 10/10/1999 13:53'!
tempNames
	"Answer an OrderedCollection of the names of the receiver's temporary 
	variables, which are strings."
	| names |
	self method setTempNamesIfCached: [:n | ^n].
	names _ (self mclass compilerClass new
			parse: self sourceCode
			in: self mclass
			notifying: nil) tempNames.
	self method cacheTempNames: names.
	^names! !

!ContextPart methodsFor: 'debugger access'!
tempsAndValues
	"Return a string of the temporary variabls and their current values"
	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self tempNames
		doWithIndex: [:title :index |
			aStream nextPutAll: title; nextPut: $:; space; tab.
			(self tempAt: index) printOn: aStream.
			aStream cr].
	^aStream contents! !


!ContextPart methodsFor: 'controlling'!
activateMethod: newMethod withArgs: args receiver: rcvr class: class 
	"Answer a ContextPart initialized with the arguments."

	^MethodContext 
		sender: self
		receiver: rcvr
		method: newMethod
		arguments: args! !

!ContextPart methodsFor: 'controlling' stamp: 'di 10/23/1999 17:03'!
blockCopy: numArgs 
	"Primitive. Distinguish a block of code from its enclosing method by 
	creating a new BlockContext for that block. The compiler inserts into all 
	methods that contain blocks the bytecodes to send the message 
	blockCopy:. Do not use blockCopy: in code that you write!! Only the 
	compiler can decide to send the message blockCopy:. Fail if numArgs is 
	not a SmallInteger. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 80>
	^ (BlockContext newForMethod: self home method)
		home: self home
		startpc: pc + 2
		nargs: numArgs! !

!ContextPart methodsFor: 'controlling'!
hasSender: context 
	"Answer whether the receiver is strictly above context on the stack."

	| s |
	self == context ifTrue: [^false].
	s _ sender.
	[s == nil]
		whileFalse: 
			[s == context ifTrue: [^true].
			s _ s sender].
	^false! !

!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:40'!
pop
	"Answer the top of the receiver's stack and remove the top of the stack."
	| val |
	val _ self at: stackp.
	self stackp: stackp - 1.
	^ val! !

!ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:39'!
push: val 
	"Push val on the receiver's stack."

	self stackp: stackp + 1.
	self at: stackp put: val! !

!ContextPart methodsFor: 'controlling'!
return: value to: sendr 
	"Simulate the return of value to sendr."

	self releaseTo: sendr.
	^sendr push: value! !

!ContextPart methodsFor: 'controlling' stamp: 'di 11/26/1999 19:34'!
send: selector to: rcvr with: args super: superFlag 
	"Simulate the action of sending a message with selector, selector, and 
	arguments, args, to receiver. The argument, superFlag, tells whether the 
	receiver of the message was specified with 'super' in the source method."

	| class meth val |
	class _ superFlag
			ifTrue: [(self method literalAt: self method numLiterals) value superclass]
			ifFalse: [rcvr class].
	meth _ class lookupSelector: selector.
	meth == nil
		ifTrue: [^ self send: #doesNotUnderstand:
					to: rcvr
					with: (Array with: (Message selector: selector arguments: args))
					super: superFlag]
		ifFalse: [val _ self tryPrimitiveFor: meth
						receiver: rcvr
						args: args.
				val == PrimitiveFailToken ifFalse: [^ val].
				(selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue:
					[^ self error: 'Simulated message ' , (args at: 1) selector
									, ' not understood'].
				^ self activateMethod: meth
					withArgs: args
					receiver: rcvr
					class: class]! !

!ContextPart methodsFor: 'controlling' stamp: 'crl 2/26/1999 15:34'!
terminate
	"Make myself unresumable."

	sender _ nil! !

!ContextPart methodsFor: 'controlling' stamp: 'crl 2/26/1999 15:34'!
terminateTo: previousContext
	"Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender."

	| currentContext sendingContext |

	(self hasSender: previousContext) ifTrue: [
		currentContext _ sender.
		[currentContext == previousContext] whileFalse: [
			sendingContext _ currentContext sender.
			currentContext terminate.
			currentContext _ sendingContext]].
	sender _ previousContext! !

!ContextPart methodsFor: 'controlling'!
top
	"Answer the top of the receiver's stack."

	^self at: stackp! !


!ContextPart methodsFor: 'printing' stamp: 'ls 10/10/1999 11:57'!
printOn: aStream 
	| selector class mclass |
	self method == nil ifTrue: [^ super printOn: aStream].
	selector _ 
		(class _ self receiver class) 
			selectorAtMethod: self method 
			setClass: [:c | mclass _ c].
	selector == #?
		ifTrue: 
			[aStream nextPut: $?; print: self method who.
			^self].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector! !


!ContextPart methodsFor: 'system simulation' stamp: 'di 1/5/98 11:20'!
completeCallee: aContext
	"Simulate the execution of bytecodes until a return to the receiver."
	| ctxt current |
	ctxt _ aContext.
	[ctxt == current or: [ctxt hasSender: self]]
		whileTrue: 
			[current _ ctxt.
			ctxt _ ctxt step].
	self stepToSendOrReturn! !

!ContextPart methodsFor: 'system simulation' stamp: 'di 1/5/98 11:20'!
runSimulated: aBlock contextAtEachStep: block2
	"Simulate the execution of the argument, aBlock, until it ends. aBlock 
	MUST NOT contain an '^'. Evaluate block2 with the current context 
	prior to each instruction executed. Answer the simulated value of aBlock."
	| current |
	aBlock hasMethodReturn
		ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
	current _ aBlock.
	current pushArgs: Array new from: self.
	[current == self]
		whileFalse:
			[block2 value: current.
			current _ current step].
	^self pop! !

!ContextPart methodsFor: 'system simulation'!
step
	"Simulate the execution of the receiver's next bytecode. Answer the 
	context that would be the active context after this bytecode."

	^self interpretNextInstructionFor: self! !

!ContextPart methodsFor: 'system simulation' stamp: 'sn 8/22/97 21:55'!
stepToSendOrReturn
	"Simulate the execution of bytecodes until either sending a message or 
	returning a value to the receiver (that is, until switching contexts)."

	[self willReallySend | self willReturn]
		whileFalse: [self step]! !


!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:47'!
doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments 
	"Simulate a primitive method whose index is primitiveIndex.  The
	simulated receiver and arguments are given as arguments to this message."

	| value |
	<primitive: 19> "Simulation guard"
	"If successful, push result and return resuming context,
		else ^ PrimitiveFailToken"
	(primitiveIndex = 19) ifTrue:[
		Debugger 
			openContext: self
			label:'Code simulation error'
			contents: self shortStack].

	(primitiveIndex = 80 and: [receiver isKindOf: ContextPart])
		ifTrue: [^self push: ((BlockContext newForMethod: receiver home method)
						home: receiver home
						startpc: pc + 2
						nargs: (arguments at: 1))].
	(primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])
		ifTrue: [^receiver pushArgs: arguments from: self].
	primitiveIndex = 83 "afr 9/11/1998 19:50"
		ifTrue: [^ self send: arguments first to: receiver
					with: arguments allButFirst
					super: false].
	primitiveIndex = 84 "afr 9/11/1998 19:50"
		ifTrue: [^ self send: arguments first to: receiver
					with: (arguments at: 2)
					super: false].
	arguments size > 6 ifTrue: [^ PrimitiveFailToken].
	primitiveIndex = 117 
		ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
		ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments].
	value == PrimitiveFailToken
		ifTrue: [^ PrimitiveFailToken]
		ifFalse: [^ self push: value]! !

!ContextPart methodsFor: 'private' stamp: 'di 1/11/1999 10:12'!
push: numObjects fromIndexable: anIndexableCollection
	"Push the elements of anIndexableCollection onto the receiver's stack.
	 Do not call directly.  Called indirectly by {1. 2. 3} constructs."

	1 to: numObjects do:
		[:i | self push: (anIndexableCollection at: i)]! !

!ContextPart methodsFor: 'private'!
stackPtr  "For use only by the SystemTracer"
	^ stackp! !

!ContextPart methodsFor: 'private' stamp: 'di 10/23/1999 17:31'!
stackp: newStackp
	"Storing into the stack pointer is a potentially dangerous thing.
	This primitive stores nil into any cells that become accessible as a result,
	and it performs the entire operation atomically."
	"Once this primitive is implemented, failure code should cause an error"

	<primitive: 76>
	self error: 'stackp store failure'.
"
	stackp == nil ifTrue: [stackp _ 0].
	newStackp > stackp  'effectively checks that it is a number'
		ifTrue: [oldStackp _ stackp.
				stackp _ newStackp.
				'Nil any newly accessible cells'
				oldStackp + 1 to: stackp do: [:i | self at: i put: nil]]
		ifFalse: [stackp _ newStackp]
"! !

!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:41'!
tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
	"Hack. Attempt to execute the named primitive from the given compiled method"
	| selector theMethod spec |
	arguments size > 8 ifTrue:[^PrimitiveFailToken].
	selector _ #(
		tryNamedPrimitive 
		tryNamedPrimitive: 
		tryNamedPrimitive:with: 
		tryNamedPrimitive:with:with: 
		tryNamedPrimitive:with:with:with:
		tryNamedPrimitive:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:
		tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1.
	theMethod _ aReceiver class lookupSelector: selector.
	theMethod == nil ifTrue:[^PrimitiveFailToken].
	spec _ theMethod literalAt: 1.
	spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1.
	^aReceiver perform: selector withArguments: arguments! !

!ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:45'!
tryPrimitiveFor: method receiver: receiver args: arguments 
	"If this method has a primitive index, then run the primitive and return its result.
	Otherwise (and also if the primitive fails) return PrimitiveFailToken,
	as an indication that the method should be activated and run as bytecodes."
	| primIndex |
	(primIndex _ method primitive) = 0 ifTrue: [^ PrimitiveFailToken].
	^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! !


!ContextPart methodsFor: 'private-exceptions' stamp: 'tfei 4/1/1999 18:02'!
isHandlerContext

	^self method == (BlockContext compiledMethodAt: #on:do:)! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'tfei 4/1/1999 18:17'!
isUnwindContext

	| m |
	^(m := self method) == (BlockContext compiledMethodAt: #ensure:)
		or: [m == (BlockContext compiledMethodAt: #ifCurtailed:)]! !

!ContextPart methodsFor: 'private-exceptions' stamp: 'tfei 4/13/1999 19:02'!
unwindTo: aContext

	| ctx returnValue aContextSender unwindBlock |
	ctx := self.
	returnValue := nil.
	aContext == nil
		ifTrue: [aContextSender := nil]
		ifFalse: [aContextSender := aContext sender]. "if aContext itself is marked for unwind, then need to use sender for whileFalse: loop check"
	[ctx == aContextSender or: [ctx == nil]]
		whileFalse:
			[ctx isUnwindContext
				ifTrue:
					[unwindBlock := ctx tempAt: 1.
					ctx tempAt: 1 put: nil.	"see comment in #ensure:"
					unwindBlock == nil
						ifFalse: [returnValue := unwindBlock value]].
			ctx := ctx sender].
	^returnValue! !


!ContextPart methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 22:54'!
storeDataOn: aDataStream
	"Contexts are not allowed go to out in DataStreams.  They must be included inside an ImageSegment."

	aDataStream insideASegment ifTrue: [^ super storeDataOn: aDataStream].

	self error: 'This Context was not included in the ImageSegment'.
		"or perhaps ImageSegments were not used at all"
	^ nil! !


!ContextPart methodsFor: 'private-debugger' stamp: 'tfei 3/19/2000 23:24'!
cachesStack

	^false! !

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

ContextPart class
	instanceVariableNames: ''!

!ContextPart class methodsFor: 'examples'!
tallyInstructions: aBlock
	"This method uses the simulator to count the number of occurrences of
	each of the Smalltalk instructions executed during evaluation of aBlock.
	Results appear in order of the byteCode set."
	| tallies |
	tallies _ Bag new.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current | tallies add: current nextByte].
	^tallies sortedElements

	"ContextPart tallyInstructions: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples'!
tallyMethods: aBlock
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. Results are given in order of decreasing counts."
	| prev tallies |
	tallies _ Bag new.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: "call or return"
				[prev sender == nil ifFalse: "call only"
					[tallies add: current printString].
				prev _ current]].
	^tallies sortedCounts

	"ContextPart tallyMethods: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'!
trace: aBlock		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls and returned values in the Transcript."

	Transcript clear.
	^ self trace: aBlock on: Transcript! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'!
trace: aBlock on: aStream		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls to a file."
	| prev |
	prev _ aBlock.
	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			Sensor anyButtonPressed ifTrue: [^ nil].
			current == prev
				ifFalse:
					[prev sender ifNil:
						[aStream space; nextPut: $^.
						self carefullyPrint: current top on: aStream].
					aStream cr.
					(current depthBelow: aBlock) timesRepeat: [aStream space].
					self carefullyPrint: current receiver on: aStream.
					aStream space; nextPutAll: current selector; flush.
					prev _ current]]! !

!ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:05'!
trace: aBlock onFileNamed: fileName		"ContextPart trace: [3 factorial] onFileNamed: 'trace'"
	"This method uses the simulator to print calls to a file."

	| aStream |
	^ [aStream _ FileStream fileNamed: fileName.
		self trace: aBlock on: aStream] ensure: [aStream close]! !


!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'!
initialize

	"A unique object to be returned when a primitive fails during simulation"
	PrimitiveFailToken _ Object new  ! !

!ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'!
primitiveFailToken

	^ PrimitiveFailToken! !

!ContextPart class methodsFor: 'simulation'!
runSimulated: aBlock
	"Simulate the execution of the argument, current. Answer the result it 
	returns."

	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep: [:ignored]

	"ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! !


!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
basicNew: size

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 00:30'!
initializedInstance
	^ nil! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
new

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'!
new: size

	self error: 'Contexts must only be created with newForMethod:'! !

!ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:55'!
newForMethod: aMethod
	"This is the only method for creating new contexts, other than primitive cloning.
	Any other attempts, such as inherited methods like shallowCopy, should be
	avoided or must at least be rewritten to determine the proper size from the
	method being activated.  This is because asking a context its size (even basicSize!!)
	will not return the real object size but only the number of fields currently
	accessible, as determined by stackp."

	^ super basicNew: aMethod frameSize! !


!ContextPart class methodsFor: 'private' stamp: 'sma 4/22/2000 17:01'!
carefullyPrint: anObject on: aStream
	aStream nextPutAll: ([anObject printString]
		on: Error
		do: ['unprintable ' , anObject class name])! !
Inspector subclass: #ContextVariablesInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!ContextVariablesInspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.!


!ContextVariablesInspector methodsFor: 'accessing'!
fieldList 
	"Refer to the comment in Inspector|fieldList."

	object == nil ifTrue: [^Array with: 'thisContext'].
	^(Array with: 'thisContext' with: 'all temp vars') , object tempNames! !


!ContextVariablesInspector methodsFor: 'selecting'!
replaceSelectionValue: anObject 
	"Refer to the comment in Inspector|replaceSelectionValue:."

	selectionIndex = 1
		ifTrue: [^object]
		ifFalse: [^object tempAt: selectionIndex - 2 put: anObject]! !

!ContextVariablesInspector methodsFor: 'selecting' stamp: 'ar 5/29/1998 18:32'!
selection 
	"Refer to the comment in Inspector|selection."
	selectionIndex = 0 ifTrue:[^''].
	selectionIndex = 1 ifTrue: [^object].
	selectionIndex = 2
		ifTrue: [^object tempsAndValues]
		ifFalse: [^object tempAt: selectionIndex - 2]! !


!ContextVariablesInspector methodsFor: 'code'!
doItContext

	^object! !

!ContextVariablesInspector methodsFor: 'code'!
doItReceiver

	^object receiver! !
AbstractScoreEvent subclass: #ControlChangeEvent
	instanceVariableNames: 'control value channel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel: midiChannel

	channel _ midiChannel.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
control

	^ control
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'!
control: midiControl

	control _ midiControl.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'!
control: midiControl value: midiControlValue channel: midiChannel

	control _ midiControl.
	value _ midiControlValue.
	channel _ midiChannel.
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:02'!
value

	^ value
! !

!ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'!
value: midiControlValue

	value _ midiControlValue.
! !


!ControlChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'!
isControlChange

	^ true
! !


!ControlChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rB0
		channel: channel
		byte: control
		byte: value.
! !


!ControlChangeEvent methodsFor: 'printing' stamp: 'sma 6/1/2000 09:34'!
printOn: aStream
	aStream
		nextPut: $(;
		print: time;
		nextPutAll: ': ctrl[';
		print: control;
		nextPutAll: ']=';
		print: value;
		nextPut: $)! !

!ControlChangeEvent methodsFor: 'printing' stamp: 'MPW 1/1/1901 22:27'!
printOnStream: aStream
	aStream
		print:'('; write:time;
		print:': ctrl['; write:control;
		print:']=';write:value;
		print:')'.
! !
Object subclass: #ControlManager
	instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController newTopClicked '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!ControlManager commentStamp: '<historical>' prior: 0!
I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.!


!ControlManager methodsFor: 'initialize-release'!
initialize
	"Initialize the receiver to refer to only the background controller."
	| screenView |
	screenController _ ScreenController new.
	screenView _ FormView new.
	screenView model: (InfiniteForm with: Color gray) controller: screenController.
	screenView window: Display boundingBox.
	scheduledControllers _ OrderedCollection with: screenController! !

!ControlManager methodsFor: 'initialize-release'!
release 
	"Refer to the comment in Object|release."

	scheduledControllers == nil
		ifFalse: 
			[scheduledControllers 
				do: [:controller | (controller isKindOf: Controller)
								ifTrue: [controller view release]
								ifFalse: [controller release]].
			scheduledControllers _ nil]! !


!ControlManager methodsFor: 'accessing'!
activeController
	"Answer the currently active controller."

	^activeController! !

!ControlManager methodsFor: 'accessing' stamp: 'ar 6/5/1998 21:49'!
activeController: aController 
	"Set aController to be the currently active controller. Give the user 
	control in it."
	<primitive: 19> "Simulation guard"
	activeController _ aController.
	(activeController == screenController)
		ifFalse: [self promote: activeController].
	activeControllerProcess _ 
			[activeController startUp.
			self searchForActiveController] newProcess.
	activeControllerProcess priority: Processor userSchedulingPriority.
	activeControllerProcess resume! !

!ControlManager methodsFor: 'accessing'!
activeControllerNoTerminate: aController andProcess: aProcess
	"Set aController to be the currently active controller and aProcess to be 
	the the process that handles controller scheduling activities in the 
	system. This message differs from activeController:andProcess: in that it 
	does not send controlTerminate to the currently active controller."

	self inActiveControllerProcess
		ifTrue: 
			[aController~~nil
				ifTrue: [(scheduledControllers includes: aController)
							ifTrue: [self promote: aController]
							ifFalse: [self error: 'Old controller not scheduled']].
			activeController _ aController.
			activeController == nil
				ifFalse: [activeController controlInitialize].
			activeControllerProcess _ aProcess.
			activeControllerProcess resume]
		ifFalse: 
			[self error: 'New active controller process must be set from old one'] ! !

!ControlManager methodsFor: 'accessing'!
activeControllerProcess
	"Answer the process that is currently handling controller scheduling 
	activities in the system."

	^activeControllerProcess! !

!ControlManager methodsFor: 'accessing'!
controllerSatisfying: aBlock
	"Return the first scheduled controller which satisfies the 1-argument boolean-valued block, or nil if none.  7/25/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController) == true ifTrue: [^ aController]].
	^ nil! !

!ControlManager methodsFor: 'accessing'!
controllerWhoseModelSatisfies: aBlock
	"Return the first scheduled controller whose model satisfies the 1-argument boolean-valued block, or nil if none.  5/6/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController model) == true ifTrue: [^ aController]].
	^ nil! !

!ControlManager methodsFor: 'accessing' stamp: 'sw 9/27/96'!
controllersSatisfying: aBlock
	"Return a list of scheduled controllers satisfying aBlock.  "

	^ scheduledControllers select:
		[:aController | (aBlock value: aController) == true]! !

!ControlManager methodsFor: 'accessing'!
includes: aController
	^ scheduledControllers includes: aController! !

!ControlManager methodsFor: 'accessing'!
noteNewTop
	newTopClicked _ true! !

!ControlManager methodsFor: 'accessing' stamp: 'sw 10/9/96'!
removeAllControllersSatisfying: aBlock
	"Unschedule and delete all controllers satisfying aBlock.  May not leave the screen exactly right sometimes. "

	(self controllersSatisfying:  aBlock) do:
		[:aController | aController closeAndUnschedule]! !

!ControlManager methodsFor: 'accessing'!
scheduledControllers
	"Answer a copy of the ordered collection of scheduled controllers."

	^scheduledControllers copy! !

!ControlManager methodsFor: 'accessing' stamp: 'di 10/4/97 09:05'!
scheduledWindowControllers
	"Same as scheduled controllers, but without ScreenController.
	Avoids null views just after closing, eg, a debugger."

	^ scheduledControllers select:
		[:c | c ~~ screenController and: [c view ~~ nil]]! !

!ControlManager methodsFor: 'accessing'!
screenController
	^ screenController! !

!ControlManager methodsFor: 'accessing'!
windowOriginsInUse
	"Answer a collection of the origins of windows currently on the screen in the current project.  5/21/96 sw"

	^ self scheduledWindowControllers collect: [:aController | aController view displayBox origin].! !


!ControlManager methodsFor: 'scheduling'!
activateController: aController
	"Make aController, which must already be a scheduled controller, the active window.  5/8/96 sw"

	self activeController: aController.
	(activeController view labelDisplayBox
		intersect: Display boundingBox) area < 200
			ifTrue: [activeController move].
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
activateTranscript
	"There is known to be a Transcript open in the current project; activate it.  2/5/96 sw"

	| itsController |
	itsController _ scheduledControllers detect:
			[:controller | controller model == Transcript]
		ifNone:
			[^ self].

	self activeController: itsController.
	(activeController view labelDisplayBox
			intersect: Display boundingBox) area < 200
				ifTrue: [activeController move].
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling' stamp: 'di 5/19/1998 09:03'!
findWindow
	"Present a menu of window titles, and activate the one that gets chosen."

	^ self findWindowSatisfying: [:c | true]! !

!ControlManager methodsFor: 'scheduling' stamp: 'wod 6/17/1998 15:46'!
findWindowSatisfying: aBlock
	"Present a menu of window titles, and activate the one that gets chosen"

	| sortAlphabetically controllers listToUse labels index |
	sortAlphabetically _ Sensor shiftPressed.
	controllers _ OrderedCollection new.
	scheduledControllers do: [:controller |
		controller == screenController ifFalse:
			[(aBlock value: controller) ifTrue: [controllers addLast: controller]]].
	controllers size == 0 ifTrue: [^ self].
	listToUse _ sortAlphabetically
		ifTrue: [controllers asSortedCollection: [:a :b | a view label < b view label]]
		ifFalse: [controllers].
	labels _ String streamContents:
		[:strm | 
			listToUse do: [:controller | strm nextPutAll: (controller view label contractTo: 40); cr].
		strm skip: -1  "drop last cr"].
	index _ (PopUpMenu labels: labels) startUp.
	index > 0 ifTrue:
		[self activateController: (listToUse at: index)].
! !

!ControlManager methodsFor: 'scheduling'!
inActiveControllerProcess
	"Answer whether the active scheduling process is the actual active 
	process in the system."

	^activeControllerProcess == Processor activeProcess! !

!ControlManager methodsFor: 'scheduling' stamp: 'ar 11/19/1998 18:31'!
interruptName: labelString
	"Create a Notifier on the active scheduling process with the given label. Make the Notifier the active controller."
	| suspendingList newActiveController |
	(suspendingList _ activeControllerProcess suspendingList) == nil
		ifTrue: [activeControllerProcess == Processor activeProcess
					ifTrue: [activeControllerProcess suspend]]
		ifFalse: [suspendingList remove: activeControllerProcess ifAbsent:[].
				activeControllerProcess offList].

	activeController ~~ nil ifTrue: [
		"Carefully de-emphasis the current window."
		activeController view topView deEmphasizeForDebugger].

	newActiveController _
		(Debugger
			openInterrupt: labelString
			onProcess: activeControllerProcess) controller.
	newActiveController centerCursorInView.
	self activeController: newActiveController.
! !

!ControlManager methodsFor: 'scheduling'!
promote: aController
	"Make aController be the first scheduled controller in the ordered 
	collection."
	
	scheduledControllers remove: aController.
	scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling' stamp: 'RAA 7/7/2000 09:22'!
resetActiveController
	"When saving a morphic project whose parent is mvc, we need to set this up first"

	activeController _ nil.
	activeControllerProcess _ Processor activeProcess.
! !

!ControlManager methodsFor: 'scheduling' stamp: 'ar 6/5/1998 21:48'!
scheduleActive: aController 
	"Make aController be scheduled as the active controller. Presumably the 
	active scheduling process asked to schedule this controller and that a 
	new process associated this controller takes control. So this is the last act 
	of the active scheduling process."
	<primitive: 19> "Simulation guard"
	self scheduleActiveNoTerminate: aController.
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
scheduleActiveNoTerminate: aController 
	"Make aController be the active controller. Presumably the process that 
	requested the new active controller wants to keep control to do more 
	activites before the new controller can take control. Therefore, do not 
	terminate the currently active process."

	self schedulePassive: aController.
	self scheduled: aController
		from: Processor activeProcess! !

!ControlManager methodsFor: 'scheduling'!
scheduleOnBottom: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the end of the ordered collection of controllers."

	scheduledControllers addLast: aController! !

!ControlManager methodsFor: 'scheduling'!
schedulePassive: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the beginning of the ordered collection of 
	controllers."

	scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling'!
searchForActiveController
	"Find a scheduled controller that wants control and give control to it. If 
	none wants control, then see if the System Menu has been requested."
	| aController |
	activeController _ nil.
	activeControllerProcess _ Processor activeProcess.
	self activeController: self nextActiveController.
	Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
unschedule: aController
	"Remove the view, aController, from the collection of scheduled 
	controllers."

	scheduledControllers remove: aController ifAbsent: []! !

!ControlManager methodsFor: 'scheduling'!
windowFromUser
	"Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none"
	| controllers labels index |
	controllers _ OrderedCollection new.
	labels _ String streamContents:
		[:strm |
		scheduledControllers do:
			[:controller | controller == screenController ifFalse:
				[controllers addLast: controller.
				strm nextPutAll: (controller view label contractTo: 40); cr]].
		strm skip: -1  "drop last cr"].
	index _ (PopUpMenu labels: labels) startUp.
	^ index > 0
		ifTrue:
			[controllers at: index]
		ifFalse:
			[nil]! !


!ControlManager methodsFor: 'displaying'!
backgroundForm: aForm
	screenController view model: aForm.
	ScheduledControllers restore
"
	QDPen new mandala: 30 diameter: 640.
	ScheduledControllers backgroundForm:
		(Form fromDisplay: Display boundingBox).

	ScheduledControllers backgroundForm:
		(InfiniteForm with: Form gray).
"! !

!ControlManager methodsFor: 'displaying' stamp: 'di 2/26/98 08:58'!
restore 
	"Clear the screen to gray and then redisplay all the scheduled views.  Try to be a bit intelligent about the view that wants control and not display it twice if possible."

	scheduledControllers first view uncacheBits.  "assure refresh"
	self unschedule: screenController; scheduleOnBottom: screenController.
	screenController view window: Display boundingBox; displayDeEmphasized.
	self scheduledWindowControllers reverseDo:
		[:aController | aController view displayDeEmphasized].
! !

!ControlManager methodsFor: 'displaying' stamp: 'hmm 1/5/2000 07:00'!
restore: aRectangle
	"Restore all windows visible in aRectangle"
	^ self restore: aRectangle without: nil! !

!ControlManager methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:06'!
restore: aRectangle below: index without: aView
	"Restore all windows visible in aRectangle, but without aView"
	| view | 
	view _ (scheduledControllers at: index) view.
	view == aView ifTrue: 
		[index >= scheduledControllers size ifTrue: [^ self].
		^ self restore: aRectangle below: index+1 without: aView].
	view displayOn: ((BitBlt current toForm: Display) clipRect: aRectangle).
	index >= scheduledControllers size ifTrue: [^ self].
	(aRectangle areasOutside: view windowBox) do:
		[:rect | self restore: rect below: index + 1 without: aView]! !

!ControlManager methodsFor: 'displaying' stamp: 'hmm 12/30/1999 19:35'!
restore: aRectangle without: aView
	"Restore all windows visible in aRectangle"
	Display deferUpdates: true.
	self restore: aRectangle below: 1 without: aView.
	Display deferUpdates: false; forceToScreen: aRectangle! !

!ControlManager methodsFor: 'displaying'!
updateGray
	"From Georg Gollmann - 11/96.  tell the Screen Controller's model to use the currently-preferred desktop color."

	"ScheduledControllers updateGray"
	(screenController view model isMemberOf: InfiniteForm)
		ifTrue: [screenController view model: (InfiniteForm with:
Preferences desktopColor)]! !


!ControlManager methodsFor: 'private'!
nextActiveController
	"Answer the controller that would like control.  
	If there was a click outside the active window, it's the top window
	that now has the mouse, otherwise it's just the top window."

	(newTopClicked notNil and: [newTopClicked])
		ifTrue: [newTopClicked _ false.
				^ scheduledControllers 
					detect: [:aController | aController isControlWanted]
					ifNone: [scheduledControllers first]]
		ifFalse: [^ scheduledControllers first]! !

!ControlManager methodsFor: 'private'!
scheduled: aController from: aProcess

	activeControllerProcess==aProcess
		ifTrue: 
			[activeController ~~ nil
					ifTrue: [activeController controlTerminate].
			aController centerCursorInView.
			self activeController: aController]! !

!ControlManager methodsFor: 'private' stamp: 'sw 12/6/1999 23:40'!
unCacheWindows
	scheduledControllers ifNotNil: [scheduledControllers do:
		[:aController | aController view uncacheBits]]! !

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

ControlManager class
	instanceVariableNames: ''!

!ControlManager class methodsFor: 'instance creation'!
new
	^super new initialize! !


!ControlManager class methodsFor: 'exchange'!
newScheduler: controlManager
	"When switching projects, the control scheduler has to be exchanged. The 
	active one is the one associated with the current project."

	Smalltalk at: #ScheduledControllers put: controlManager.
	ScheduledControllers restore.
	controlManager searchForActiveController! !


!ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 15:16'!
shutDown  "Saves space in snapshots"

	Smalltalk isMorphic ifFalse: [ScheduledControllers unCacheWindows]! !

!ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 09:00'!
startUp
	Smalltalk isMorphic ifFalse: [ScheduledControllers restore]! !
Object subclass: #Controller
	instanceVariableNames: 'model view sensor lastActivityTime '
	classVariableNames: 'MinActivityLapse '
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!Controller commentStamp: '<historical>' prior: 0!
A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.!


!Controller methodsFor: 'initialize-release'!
initialize
	"Initialize the state of the receiver. Subclasses should include 'super 
	initialize' when redefining this message to insure proper initialization."

	sensor _ InputSensor default! !

!Controller methodsFor: 'initialize-release'!
release
	"Breaks the cycle between the receiver and its view. It is usually not 
	necessary to send release provided the receiver's view has been properly 
	released independently."

	model _ nil.
	view ~~ nil
		ifTrue: 
			[view controller: nil.
			view _ nil]! !


!Controller methodsFor: 'model access'!
model
	"Answer the receiver's model which is the same as the model of the 
	receiver's view."

	^model! !

!Controller methodsFor: 'model access'!
model: aModel 
	"Controller|model: and Controller|view: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: so that the receiver's model and view links can be set 
	up by the view."

	model _ aModel! !


!Controller methodsFor: 'view access'!
inspectView
	view notNil ifTrue: [^ view inspect]! !

!Controller methodsFor: 'view access'!
view
	"Answer the receiver's view."

	^view! !

!Controller methodsFor: 'view access'!
view: aView 
	"Controller|view: and Controller|model: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: and the receiver's model and view links are set up 
	automatically by the view."

	view _ aView! !


!Controller methodsFor: 'sensor access'!
sensor
	"Answer the receiver's sensor. Subclasses may use other objects that are 
	not instances of Sensor or its subclasses if more general kinds of 
	input/output functions are required."

	^sensor! !

!Controller methodsFor: 'sensor access'!
sensor: aSensor
	"Set the receiver's sensor to aSensor."

	sensor _ aSensor! !


!Controller methodsFor: 'basic control sequence'!
controlInitialize
	"Sent by Controller|startUp as part of the standard control sequence, it 
	provides a place in the standard control sequence for initializing the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self! !

!Controller methodsFor: 'basic control sequence' stamp: 'ls 7/11/1998 06:33'!
controlLoop 
	"Sent by Controller|startUp as part of the standard control sequence. 
	Controller|controlLoop sends the message Controller|isControlActive to test 
	for loop termination. As long as true is returned, the loop continues. 
	When false is returned, the loop ends. Each time through the loop, the 
	message Controller|controlActivity is sent."

	[self isControlActive] whileTrue: [
		self interActivityPause. self controlActivity. Processor yield]! !

!Controller methodsFor: 'basic control sequence'!
controlTerminate
	"Provide a place in the standard control sequence for terminating the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self! !

!Controller methodsFor: 'basic control sequence' stamp: 'RAA 1/30/2001 19:06'!
interActivityPause
	"if we are looping quickly, insert a short delay.  Thus if we are just doing UI stuff, we won't take up much CPU"
	| currentTime wait |
	MinActivityLapse ifNotNil: [
		lastActivityTime ifNotNil: [ 
			currentTime _ Time millisecondClockValue.
			wait _ lastActivityTime + MinActivityLapse - currentTime.
			wait > 0 ifTrue: [ 
				wait <= MinActivityLapse  "big waits happen after a snapshot"
					ifTrue: [DisplayScreen checkForNewScreenSize.
							(Delay forMilliseconds: wait) wait ]. ]. ]. ].

	lastActivityTime _ Time millisecondClockValue.! !

!Controller methodsFor: 'basic control sequence'!
startUp
	"Give control to the receiver. The default control sequence is to initialize 
	(see Controller|controlInitialize), to loop (see Controller|controlLoop), and 
	then to terminate (see Controller|controlTerminate). After this sequence, 
	control is returned to the sender of Control|startUp. The receiver's control 
	sequence is used to coordinate the interaction of its view and model. In 
	general, this consists of polling the sensor for user input, testing the 
	input with respect to the current display of the view, and updating the 
	model to reflect intended changes."

	self controlInitialize.
	self controlLoop.
	self controlTerminate! !

!Controller methodsFor: 'basic control sequence'!
terminateAndInitializeAround: aBlock
	"1/12/96 sw"
	self controlTerminate.
	aBlock value.
	self controlInitialize! !


!Controller methodsFor: 'control defaults'!
controlActivity
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. It is sent by 
	Controller|controlLoop each time through the main control loop. It should 
	be redefined in a subclass if some other action is needed."

	self controlToNextLevel! !

!Controller methodsFor: 'control defaults'!
controlToNextLevel
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. The receiver finds the 
	subView (if any) of its view whose inset display box (see 
	View|insetDisplayBox) contains the sensor's cursor point. The Controller 
	of this subView is then given control if it answers true in response to 
	the message Controller|isControlWanted."

	| aView |
	aView _ view subViewWantingControl.
	aView ~~ nil ifTrue: [aView controller startUp]! !

!Controller methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:23'!
isControlActive
	"Answer whether receiver wishes to continue evaluating its controlLoop 
	method. It is sent by Controller|controlLoop in order to determine when 
	the receiver's control loop should terminate, and should be redefined in 
	a subclass if some special condition for terminating the main control loop 
	is needed."

	^ self viewHasCursor
		and: [sensor blueButtonPressed not
		and: [sensor yellowButtonPressed not]]! !

!Controller methodsFor: 'control defaults'!
isControlWanted
	"Answer whether the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view. It is sent by 
	Controller|controlNextLevel in order to determine whether or not control 
	should be passed to this receiver from the Controller of the superView of 
	this receiver's view."

	^self viewHasCursor! !


!Controller methodsFor: 'cursor'!
centerCursorInView
	"Position sensor's mousePoint (which is assumed to be connected to the 
	cursor) to the center of its view's inset display box (see 
	Sensor|mousePoint: and View|insetDisplayBox)."

	^sensor cursorPoint: view insetDisplayBox center! !

!Controller methodsFor: 'cursor' stamp: 'sw 7/13/1999 18:42'!
viewHasCursor
	"Answer whether the cursor point of the receiver's sensor lies within the 
	inset display box of the receiver's view (see View|insetDisplayBox). 
	Controller|viewHasCursor is normally used in internal methods."

	^ view ifNotNil: [view containsPoint: sensor cursorPoint] ifNil: [false]! !

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

Controller class
	instanceVariableNames: ''!

!Controller class methodsFor: 'instance creation'!
new

	^super new initialize! !


!Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'!
MinActivityLapse: milliseconds
	"minimum time to delay between calls to controlActivity"
	MinActivityLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! !

!Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'!
initialize
	"Controller initialize"
	self MinActivityLapse: 10.! !
Object subclass: #CornerRounder
	instanceVariableNames: 'cornerMasks cornerOverlays underBits '
	classVariableNames: 'CR0 CR1 CR2 '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!CornerRounder commentStamp: '<historical>' prior: 0!
This class is a quick hack to support rounded corners in morphic.

Rather than produce rounded rectangles, it tweaks the display of corners.
Rather than work for any radius, it only supports a radius of 6.
Rather than work for any border width, it only supports widths 0, 1 and 2.
The corners, while apparently transparent, still behave opaquely to mouse clicks.

Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display.  This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv).  It will also make a postscript printer very unhappy.

But, hey, it's cute.!


!CornerRounder methodsFor: 'all' stamp: 'di 6/24/1999 09:35'!
masterMask: maskForm masterOverlay: overlayForm

	cornerMasks _ #(none left pi right) collect:
		[:dir | (maskForm rotateBy: dir centerAt: 0@0) offset: 0@0].
	cornerOverlays _ #(none left pi right) collect:
		[:dir | (overlayForm rotateBy: dir centerAt: 0@0) offset: 0@0].
! !

!CornerRounder methodsFor: 'all' stamp: 'ar 2/12/2000 18:33'!
saveBitsUnderCornersOf: aMorph on: aCanvas

	| offset corner mask form |
	underBits _ (1 to: 4) collect:
		[:i | 
		mask _ cornerMasks at: i.
		corner _ aMorph bounds corners at: i.
		i = 1 ifTrue: [offset _ 0@0].
		i = 2 ifTrue: [offset _ 0@mask height negated].
		i = 3 ifTrue: [offset _ mask extent negated].
		i = 4 ifTrue: [offset _ mask width negated@0].
		form _ aCanvas contentsOfArea: (corner + offset extent: mask extent).
		form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0)].
! !

!CornerRounder methodsFor: 'all' stamp: 'ar 3/24/2000 01:10'!
tweakCornersOf: aMorph on: aCanvas borderWidth: w

	| offset corner saveBits c fourColors c14 c23 mask nonShadowCanvas outBits |
	nonShadowCanvas _ aCanvas copy shadowColor: nil.
	w > 0 ifTrue:
		[c _ aMorph borderColor.
		fourColors _ Array new: 4 withAll: c.
		c == #raised ifTrue:
			[c _ aMorph color.
			w = 1
				ifTrue: [c14 _ c twiceLighter. c23 _ c twiceDarker]
				ifFalse: [c14 _ c lighter. c23 _ c darker].
			fourColors _ Array with: c14 with: c with: c23 with: c].
		(c == #inset and: [aMorph owner notNil]) ifTrue:
			[c _ aMorph owner colorForInsets.
			w = 1
				ifTrue: [c14 _ c twiceLighter. c23 _ c twiceDarker]
				ifFalse: [c14 _ c lighter. c23 _ c darker].
			fourColors _ Array with: c23 with: c with: c14 with: c]].
	mask _ Form extent: cornerMasks first extent depth: aCanvas depth.
	(1 to: 4) do:
		[:i | 
		corner _ aMorph bounds corners at: i.
		saveBits _ underBits at: i.
		i = 1 ifTrue: [offset _ 0@0].
		i = 2 ifTrue: [offset _ 0@saveBits height negated].
		i = 3 ifTrue: [offset _ saveBits extent negated].
		i = 4 ifTrue: [offset _ saveBits width negated@0].

		"Mask out corner area (painting saveBits won't clear if transparent)."
		mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF).
		outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent).
		mask displayOn: outBits at: 0@0 rule: Form and.


		"Paint back corner bits."
		saveBits displayOn: outBits at: 0@0 rule: Form paint.
		nonShadowCanvas drawImage: outBits at: corner + offset.

		w > 0 ifTrue:
			["Paint over with border if any"
			aCanvas stencil: (cornerOverlays at: i) at: corner + offset
					color: (fourColors at: i)]].

! !

!CornerRounder methodsFor: 'all' stamp: 'ar 10/26/2000 20:03'!
tweakCornersOf: aMorph on: aCanvas borderWidth: w corners: cornerList
	"This variant has a cornerList argument, to allow some corners to be rounded and others not"
	| offset corner saveBits c fourColors c14 c23 insetColor mask outBits shadowColor |
	shadowColor _ aCanvas shadowColor.
	aCanvas shadowColor: nil. "for tweaking it's essential"
	w > 0 ifTrue:
		[c _ shadowColor ifNil:[aMorph borderColor].
		fourColors _ Array new: 4 withAll: c.
		c == #raised ifTrue:
			[c14 _ aMorph color lighter. c23 _ aMorph color darker.
			fourColors _ Array with: c14 with: c23 with: c23 with: c14].
		(c == #inset and: [aMorph owner notNil]) ifTrue:
			[insetColor _ aMorph owner colorForInsets.
			c14 _ insetColor lighter. c23 _ insetColor darker.
			fourColors _ Array with: c14 with: c23 with: c23 with: c14]].
	mask _ Form extent: cornerMasks first extent depth: aCanvas depth.
	1 to: 4 do:[:i | 
		(cornerList includes: i) ifTrue:
			[corner _ aMorph bounds corners at: i.
			saveBits _ underBits at: i.
			i = 1 ifTrue: [offset _ 0@0].
			i = 2 ifTrue: [offset _ 0@saveBits height negated].
			i = 3 ifTrue: [offset _ saveBits extent negated].
			i = 4 ifTrue: [offset _ saveBits width negated@0].

			"Mask out corner area (painting saveBits won't clear if transparent)."
			mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF).
			outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent).
			mask displayOn: outBits at: 0@0 rule: Form and.
			"Paint back corner bits."
			saveBits displayOn: outBits at: 0@0 rule: Form paint.
			"Paint back corner bits."
			aCanvas drawImage: outBits at: corner + offset.

			w > 0 ifTrue:
				["Paint over with border if any"
				aCanvas stencil: (cornerOverlays at: i) at: corner + offset
						color: (fourColors at: i)]]].
	aCanvas shadowColor: shadowColor. "restore shadow color"
! !

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

CornerRounder class
	instanceVariableNames: ''!

!CornerRounder class methodsFor: 'all' stamp: 'di 6/28/1999 15:51'!
initialize  "CornerRounder initialize"

	CR0 _ CR1 _ self new
		masterMask:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26)
				offset: 0@0)
		masterOverlay:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r110e26 2r1000e26 2r10000e26 2r10000e26 2r100000e26)
				offset: 0@0).
	CR2 _ self new
		masterMask:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26)
				offset: 0@0)
		masterOverlay:
			(Form extent: 6@6
				fromArray: #(2r1e26 2r111e26 2r1111e26 2r11100e26 2r11000e26 2r111000e26)
				offset: 0@0).

! !

!CornerRounder class methodsFor: 'all' stamp: 'di 3/25/2000 11:12'!
rectWithinCornersOf: aRectangle
	"Return a single sub-rectangle that lies entirely inside corners
	that are made by me.
	Used to identify large regions of window that do not need to be redrawn."

	^ aRectangle insetBy: 0@6! !

!CornerRounder class methodsFor: 'all' stamp: 'hmm 3/8/2000 17:42'!
roundCornersOf: aMorph on: aCanvas displayBlock: displayBlock borderWidth: w

	| rounder |
	rounder _ CR0.
	w = 1 ifTrue: [rounder _ CR1].
	w = 2 ifTrue: [rounder _ CR2].
	rounder _ rounder copy.
	rounder saveBitsUnderCornersOf: aMorph on: aCanvas.
	displayBlock value.
	rounder tweakCornersOf: aMorph on: aCanvas borderWidth: w! !

!CornerRounder class methodsFor: 'all' stamp: 'hmm 3/8/2000 17:42'!
roundCornersOf: aMorph on: aCanvas displayBlock: displayBlock borderWidth: w corners: aList

	| rounder |
	rounder _ CR0.
	w = 1 ifTrue: [rounder _ CR1].
	w = 2 ifTrue: [rounder _ CR2].
	rounder _ rounder copy.
	rounder saveBitsUnderCornersOf: aMorph on: aCanvas.
	displayBlock value.
	rounder tweakCornersOf: aMorph on: aCanvas borderWidth: w corners: aList! !
Object subclass: #CosineInterpolator
	instanceVariableNames: 'origin points stack '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!

!CosineInterpolator methodsFor: 'initialization' stamp: 'len 12/13/1999 02:42'!
initialize
	points _ SortedCollection new.
	stack _ SortedCollection new.
	origin _ 0! !


!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/14/1999 00:49'!
at: time
	"Answer the value of the receiver at a given time. (Do linear interpolation.)"
	^ self cosineAt: time + self origin! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 11/24/1999 01:59'!
at: time put: value
	self points add: time + self origin -> value.
	^ value! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/4/1999 17:30'!
commit
	self cleanBetween: stack first key and: stack last key.
	self points addAll: stack.
	stack _ SortedCollection new! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/4/1999 17:22'!
duration
	^ self points last key - self points first key! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 11/24/1999 01:59'!
origin
	^ origin! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 11/24/1999 01:59'!
origin: aNumber
	origin _ aNumber! !

!CosineInterpolator methodsFor: 'accessing' stamp: 'len 12/4/1999 17:20'!
x: x y: y
	stack add: x + self origin -> y! !


!CosineInterpolator methodsFor: 'private' stamp: 'len 11/23/1999 01:08'!
cleanBetween: start and: end
	self points: (self points reject: [ :each | each key between: start and: end])! !

!CosineInterpolator methodsFor: 'private' stamp: 'len 11/23/1999 00:42'!
cosineAt: time
	"Answer the value of the receiver at a given time. (Do cosine interpolation.)"
	| xVal count x1 x2 y1 y2 |
	points isNil ifTrue: [^ nil].
	xVal _ points first key.
	count _ 1.
	[xVal < time]
		whileTrue: [count _ count + 1.
					count > points size ifTrue: [^ points last value].
					xVal _ (points at: count) key].
	xVal = time ifTrue: [^ (points at: count) value].
	count = 1 ifTrue: [^ points first value].
	x1 _ (points at: count - 1) key.
	x2 _ (points at: count) key.
	y1 _ (points at: count - 1) value.
	y2 _ (points at: count) value.
	^ ((time - x1 / (x2 - x1) * Float pi) cos - 1 / -2.0) * (y2 - y1) + y1! !

!CosineInterpolator methodsFor: 'private' stamp: 'len 12/4/1999 15:54'!
linearAt: time
	"Answer the value of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	points isNil ifTrue: [^ nil].
	xVal _ points first key.
	count _ 1.
	[xVal < time]
		whileTrue: [count _ count + 1.
					count > points size ifTrue: [^ points last value].
					xVal _ (points at: count) key].
	xVal = time ifTrue: [^ (points at: count) value].
	count = 1 ifTrue: [^ points first value].
	x1 _ (points at: count - 1) key.
	x2 _ (points at: count) key.
	y1 _ (points at: count - 1) value.
	y2 _ (points at: count) value.
	^ (time - x1) / (x2 - x1) * (y2 - y1) + y1! !

!CosineInterpolator methodsFor: 'private' stamp: 'len 12/4/1999 17:29'!
points
	^ points! !

!CosineInterpolator methodsFor: 'private' stamp: 'len 11/23/1999 00:41'!
points: aCollection
	points _ aCollection! !

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

CosineInterpolator class
	instanceVariableNames: ''!

!CosineInterpolator class methodsFor: 'instance creation' stamp: 'len 12/13/1999 02:15'!
fromArray: anArray
	| answer |
	answer _ self new.
	1 to: anArray size by: 2 do: [ :each | answer at: (anArray at: each) put: (anArray at: each + 1)].
	^ answer! !

!CosineInterpolator class methodsFor: 'instance creation' stamp: 'len 12/4/1999 17:29'!
new
	^ super new initialize! !
StandardFileStream subclass: #CrLfFileStream
	instanceVariableNames: 'lineEndConvention '
	classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount '
	poolDictionaries: ''
	category: 'System-Files'!

!CrLfFileStream methodsFor: 'open/close' stamp: 'ar 1/20/98 16:15'!
open: aFileName forWrite: writeMode 
	"Open the receiver.  If writeMode is true, allow write, else access will be 
	read-only. "
	| result |
	result _ super open: aFileName forWrite: writeMode.
	result ifNotNil: [self detectLineEndConvention].
	^ result! !


!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'!
ascii
	super ascii.
	self detectLineEndConvention! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'!
binary
	super binary.
	lineEndConvention _ nil! !

!CrLfFileStream methodsFor: 'access' stamp: 'ls 7/10/1998 23:35'!
detectLineEndConvention
	"Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf."
	| char numRead pos |
	self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams'].
	lineEndConvention _ LineEndDefault.
	"Default if nothing else found"
	numRead _ 0.
	pos _ super position.
	[super atEnd not and: [numRead < LookAheadCount]]
		whileTrue: 
			[char _ super next.
			char = Lf
				ifTrue: 
					[super position: pos.
					^ lineEndConvention _ #lf].
			char = Cr
				ifTrue: 
					[super peek = Lf
						ifTrue: [lineEndConvention _ #crlf]
						ifFalse: [lineEndConvention _ #cr].
					super position: pos.
					^ lineEndConvention].
			numRead _ numRead + 1].
	super position: pos.
	^ lineEndConvention! !

!CrLfFileStream methodsFor: 'access' stamp: 'ls 11/5/1998 23:37'!
next
    | char secondChar |
    char _ super next.
    self isBinary ifTrue: [^char].
    char == Cr ifTrue:
        [secondChar _ super next.
        secondChar ifNotNil: [secondChar == Lf ifFalse: [self skip: -1]].
        ^Cr].
    char == Lf ifTrue: [^Cr].
    ^char! !

!CrLfFileStream methodsFor: 'access' stamp: 'ls 12/29/1998 17:15'!
next: n

		| string peekChar |
		string _ super next: n.
		string size = 0 ifTrue: [ ^string ].
		self isBinary ifTrue: [ ^string ].

		"if we just read a CR, and the next character is an LF, then skip the LF"
		( string last = Character cr ) ifTrue: [
			peekChar _ super next.		"super peek doesn't work because it relies on #next"
			peekChar ~= Character lf ifTrue: [
				super position: (super position - 1) ]. ].
 
		string _ string withSqueakLineEndings.

		string size = n ifTrue: [ ^string ].

		"string shrunk due to embedded crlfs; make up the difference"
		^string, (self next: n - string size)! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
nextPut: char 
	(lineEndConvention notNil and: [char = Cr])
		ifTrue: [super nextPutAll: (LineEndStrings at: lineEndConvention)]
		ifFalse: [super nextPut: char].
	^ char! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
nextPutAll: aString 
	super nextPutAll: (self convertStringFromCr: aString).
	^ aString
! !

!CrLfFileStream methodsFor: 'access' stamp: 'wod 6/18/1998 13:52'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "
	| next pos |
	self atEnd ifTrue: [^ nil].
	pos _ self position.
	next _ self next.
	self position: pos.
	^ next! !

!CrLfFileStream methodsFor: 'access' stamp: 'wod 11/5/1998 14:15'!
upTo: aCharacter
	| newStream char |
	newStream _ WriteStream on: (String new: 100).
	[(char _ self next) isNil or: [char == aCharacter]]
		whileFalse: [newStream nextPut: char].
	^ newStream contents
! !

!CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'!
verbatim: aString 
	super verbatim: (self convertStringFromCr: aString).
	^ aString! !


!CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21'!
convertStringFromCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf].
	"lineEndConvention == #crlf"
	inStream _ ReadStream on: aString.
	outStream _ WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: [outStream nextPutAll: CrLf]].
	^ outStream contents! !

!CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21'!
convertStringToCr: aString 
	| inStream outStream |
	lineEndConvention ifNil: [^ aString].
	lineEndConvention == #cr ifTrue: [^ aString].
	lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr].
	"lineEndConvention == #crlf"
	inStream _ ReadStream on: aString.
	outStream _ WriteStream on: (String new: aString size).
	[inStream atEnd]
		whileFalse: 
			[outStream nextPutAll: (inStream upTo: Cr).
			(inStream atEnd not or: [aString last = Cr])
				ifTrue: 
					[outStream nextPut: Cr.
					inStream peek = Lf ifTrue: [inStream next]]].
	^ outStream contents! !

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

CrLfFileStream class
	instanceVariableNames: ''!

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToCR
	"CrLfFileStream defaultToCR"
	LineEndDefault := #cr.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToCRLF
	"CrLfFileStream defaultToCRLF"
	LineEndDefault := #crlf.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'!
defaultToLF
	"CrLfFileStream defaultToLF"
	LineEndDefault := #lf.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:13'!
guessDefaultLineEndConvention
	"Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory."
	FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR].
	FileDirectory pathNameDelimiter = $/ ifTrue:[^self defaultToLF].
	FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF].
	"in case we don't know"
	^self defaultToCR! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:16'!
initialize
	"CrLfFileStream initialize"
	Cr := Character cr.
	Lf := Character lf.
	CrLf := String with: Cr with: Lf.
	LineEndStrings := Dictionary new.
	LineEndStrings at: #cr put: (String with: Character cr).
	LineEndStrings at: #lf put: (String with: Character lf).
	LineEndStrings at: #crlf put: (String with: Character cr with: Character lf).
	LookAheadCount := 2048.
	Smalltalk addToStartUpList: self.
	self startUp.! !

!CrLfFileStream class methodsFor: 'class initialization' stamp: 'djp 1/28/1999 22:08'!
startUp
	self guessDefaultLineEndConvention! !
WordGamePanelMorph subclass: #CrosticPanel
	instanceVariableNames: 'crosticPanel quotePanel cluesCol2 answers quote clues cluesPanel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!CrosticPanel commentStamp: '<historical>' prior: 0!
The CrosticPanel, as its name suggests, is a tool for decoding acrostic puzzles, such as are presented on the puzzle pages of some Sunday newspapers.  Much of the capability is inherited from the two WordGame classes used.  To try it out, choose newMorph/Games/CrosticPanel in a morphic project, or execute, in any project:

	CrosticPanel new openInWorld

The instance variables of this class include...
	letterMorphs (in superclass)  a collection of all the letterMorphs in this panel
	quote		a string, being the entire quote in uppercase with no blanks
	clues		a collection of the clue strings
	answers		a collection of the answer indices.
				For each answer, this is an array of the indices into the quote string.

The final structure of a CrosticPanel is as follows
	self					a CrosticPanel			the overall holder
		quotePanel		a CrosticQuotePanel		holds the grid of letters from the quote
		cluesPanel		an AlignmentMorph		holds most of the clue rows
		cluesCol2		an AlignmentMorph		holds the rest of the clue rows

Each clue row is a horizontal AlignmentMorph with a textMorph and another alignmentMorph full of the letterMorphs for the answer.
!


!CrosticPanel methodsFor: 'initialization' stamp: 'di 11/25/2000 19:17'!
breakColumnAndResizeWithButtons: buttonRow
	| indexToSplit yToSplit |
	"The column of clues has been laid out, and the crostic panel has been resized to that width and embedded as a submorph.  This method breaks the clues in two, placing the long part to the left of the crostic and the short one below it."

	yToSplit _ cluesPanel height + quotePanel height // 2 + self top.
	indexToSplit _ cluesPanel submorphs findFirst: [:m | m bottom > yToSplit].
	cluesCol2 _ AlignmentMorph newColumn color: self color;
		hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0;
		cellPositioning: #topLeft.
	cluesCol2 addAllMorphs: (cluesPanel submorphs copyFrom: indexToSplit + 1
							to: cluesPanel submorphs size).
	cluesPanel position: self position + self borderWidth + (0 @ 4).
	quotePanel position: self position + (quotePanel width @ 0).
	cluesCol2 position: self position + quotePanel extent + (0 @ 4).
	self addMorph: cluesCol2.
	self addMorph: buttonRow.
	buttonRow align: buttonRow topLeft with: cluesCol2 bottomLeft.
	self extent: 100@100; bounds: ((self fullBounds topLeft - self borderWidth asPoint)
							corner: (self fullBounds bottomRight - (2@0))).
! !

!CrosticPanel methodsFor: 'initialization' stamp: 'di 11/28/2000 10:40'!
quote: indexableQuote clues: clueStrings answers: answerIndices quotePanel: panel

	| row clue answer answerMorph letterMorph prev clueText clueStyle |
	quote _ indexableQuote.
	quotePanel _ panel.
	clues _ clueStrings.
	answers _ answerIndices.
	cluesPanel _ AlignmentMorph newColumn color: self color;
		hResizing: #shrinkWrap; vResizing: #shrinkWrap;
		cellPositioning: #topLeft; layoutInset: 1.
	letterMorphs _ Array new: quotePanel letterMorphs size.
	clueStyle _ nil.
	1 to: clues size do:
		[:i |  clue _ clues at: i.  answer _ answers at: i.
		row _ AlignmentMorph newRow cellPositioning: #bottomLeft.
		clueText _ (TextMorph newBounds: (0@0 extent: 120@20) color: Color black)
				string: (CrosticPanel oldStyle
							ifTrue: [(($A to: $Z) at: i) asString , '.  ' , clue]
							ifFalse: [clue])
				fontName: 'ComicPlain' size: 13.
		clueStyle ifNil: ["Make up a special style with decreased leading"
						clueStyle _ clueText textStyle copy.
						clueStyle gridForFont: 1 withLead: -2].
		clueText text: clueText asText textStyle: clueStyle.  "All clues share same style"
		clueText composeToBounds.
		row addMorphBack: clueText.
		answerMorph _ AlignmentMorph newRow layoutInset: 0.
		prev _ nil.
		answer do:
			[:n | letterMorph _ WordGameLetterMorph new underlined
						indexInQuote: n
						id1: (CrosticPanel oldStyle ifTrue: [n printString] ifFalse: [nil]);
						setLetter: Character space.
			letterMorph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
			letterMorph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
			letterMorph predecessor: prev.
			prev ifNotNil: [prev successor: letterMorph].
			prev _ letterMorph.
			letterMorphs at: n put: letterMorph.
			answerMorph addMorphBack: letterMorph].
		answerMorph color: answerMorph firstSubmorph color.
		row addMorphBack: answerMorph.
row fullBounds.
		row color: answerMorph firstSubmorph color.
		cluesPanel addMorphBack: row].
	self addMorph: cluesPanel.
	self bounds: cluesPanel fullBounds.
! !


!CrosticPanel methodsFor: 'events' stamp: 'di 5/11/2000 20:44'!
highlight: morph

	self unhighlight.
	quotePanel unhighlight.
	morph startOfWord morphsInWordDo:
		[:m | m color: Color lightGreen.
		(quotePanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
	morph color: Color green.
	(quotePanel letterMorphs at: morph indexInQuote) color: Color magenta.
! !

!CrosticPanel methodsFor: 'events' stamp: 'di 5/11/2000 20:44'!
keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus

	(self letterMorphs at: indexInQuote) setLetter: aLetter.
	(quotePanel letterMorphs at: indexInQuote) setLetter: aLetter.
	self highlight: nextFocus
! !

!CrosticPanel methodsFor: 'events' stamp: 'di 5/11/2000 20:44'!
lostFocus

	self unhighlight.
	quotePanel unhighlight! !


!CrosticPanel methodsFor: 'menu' stamp: 'di 5/11/2000 23:38'!
addMenuItemsTo: aMenu hand: aHandMorph

	aMenu add: 'show crostic help' target: self action: #showHelpWindow.
	aMenu add: 'show crostic hints' target: self action: #showHintsWindow.
	aMenu add: 'show crostic errors' target: self action: #showErrors.
	aMenu add: 'clear crostic typing' target: self action: #clearTyping.
	aMenu add: 'open crostic file...' target: self action: #openFile.
! !

!CrosticPanel methodsFor: 'menu' stamp: 'di 5/12/2000 00:17'!
buttonRow

	| row aButton |
	row _ AlignmentMorph newRow
		color: self color;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	aButton _ SimpleButtonMorph new target: self.
	aButton color: Color transparent; borderWidth: 1; borderColor: Color black.

	#('show help' 'show errors' 'show hints' 'clear' 'open...')
	with: 
	#(showHelpWindow showErrors showHintsWindow clearTyping openFile)
	do: [:label :selector |
		aButton _ aButton fullCopy.
		aButton actionSelector: selector.
		aButton label: label.
		row addMorphBack: aButton.
		row addTransparentSpacerOfSize: (3 @ 0)].

	^ row
! !

!CrosticPanel methodsFor: 'menu' stamp: 'di 5/12/2000 00:25'!
clearTyping

	self isClean ifTrue: [^ self].
	(self confirm: 'Are you sure you want to discard all typing?') ifFalse: [^ self].
	super clearTyping.
	quotePanel clearTyping! !

!CrosticPanel methodsFor: 'menu' stamp: 'mdr 8/31/2000 18:43'!
openFile

	| stdFileMenuResult crostic file |
	stdFileMenuResult _ ((StandardFileMenu new) pattern: '*.crostic'; 
		oldFileFrom: FileDirectory default ) 
			startUpWithCaption: 'Select a Crostic File...'.
	stdFileMenuResult ifNil: [^ nil].
	file _ stdFileMenuResult directory readOnlyFileNamed: stdFileMenuResult name.
	crostic _ CrosticPanel newFromFile: file.  file close.
	(self isClean or: [self confirm: 'Is it OK to discard this crostic?'])
		ifTrue: [self world addMorphFront: (crostic position: self position).
				self delete]
		ifFalse: [self world addMorphFront: crostic].

! !

!CrosticPanel methodsFor: 'menu' stamp: 'di 5/12/2000 15:09'!
showErrors

	letterMorphs do:
		[:m | (m letter ~= Character space and: [m letter ~= (quote at: m indexInQuote)])
			ifTrue: [m color: Color red.
					(quotePanel letterMorphs at: m indexInQuote) color: Color red]]! !

!CrosticPanel methodsFor: 'menu' stamp: 'di 5/11/2000 16:44'!
showHelpWindow

	((StringHolder new contents: 
'The Crostic Panel presents an acrostic puzzle for solution.  As you type in answers for the clues, the letters also get entered in the text of the hidden quote.  Conversely, as you guess words in the quote, those letters will fill in missing places in your answers.  In addition, the first letters of all the answers together form the author''s name and title of the work from which the quote is taken.

If you wish to make up other acrostic puzzles, follow the obvious file format in the sampleFile method.  If you wish to print an acrostic to work it on paper, then change the oldStyle method to return true, and it will properly cross-index all the cells.

Have fun.')
		embeddedInMorphicWindowLabeled: 'About the Crostic Panel')
			setWindowColor: (Color r: 1.0 g: 0.6 b: 0.0);
			openInWorld: self world extent: 409@207! !

!CrosticPanel methodsFor: 'menu' stamp: 'di 5/11/2000 21:07'!
showHintsWindow

	| hints |
	(self confirm: 'As hints, you will be given the five longest answers.
Do you really want to do this?') ifFalse: [^ self].
	hints _ (answers asSortedCollection: [:x :y | x size > y size]) asArray
		copyFrom: 1 to: 5.
	((StringHolder new contents: 
	'The five longest answers are...
'	,
	(String streamContents:
		[:strm | hints do: 
			[:hint | strm cr; nextPutAll: (hint collect: [:i | quote at: i])].
		strm cr; cr])
	,
'Good luck!!')
		embeddedInMorphicWindowLabeled: 'Crostic Hints')
			setWindowColor: (Color r: 1.0 g: 0.6 b: 0.0);
			openInWorld: self world extent: 198@154! !

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

CrosticPanel class
	instanceVariableNames: ''!

!CrosticPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/11/2000 20:37'!
includeInNewMorphMenu

	^ true! !

!CrosticPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/11/2000 20:37'!
new
	"NOTE: Use newFromFile: rather than new to create new CrosticPanels"

	^ self newFromFile: (ReadStream on: self sampleFile)! !

!CrosticPanel class methodsFor: 'as yet unclassified' stamp: 'di 11/30/2000 09:51'!
newFromFile: aStream  "World addMorph: CrosticPanel new"
	"World addMorph: (CrosticPanel newFromFile: (FileStream readOnlyFileNamed: 'first.crostic'))"

	| quoteWithBlanks citation clue numberLine numbers clues answers indexableQuote quotePanel crosticPanel buttonRow quoteWidth |
	(aStream next asciiValue = 16r1F) & (aStream next asciiValue = 16r8B) ifTrue:
		["It's gzipped..."  aStream skip: -2.
		^ self newFromFile: aStream asUnZippedStream ascii].
	aStream skip: -2.
	quoteWithBlanks _ aStream nextLine.
	quoteWithBlanks _ quoteWithBlanks asUppercase select: [:c | c isLetter or: [' -' includes: c]].
	indexableQuote _ quoteWithBlanks select: [:c | c isLetter].
	citation _ aStream nextLine.
	aStream nextLine.
	clues _ OrderedCollection new.
	answers _ OrderedCollection new.
	[aStream atEnd] whileFalse:
		[clue _ aStream nextLine.
		"Transcript cr; show: clue."
		clues addLast: clue.
		numberLine _ aStream nextLine.
		numbers _ Scanner new scanTokens: numberLine.
		answers addLast: numbers].
	aStream close.

	"Consistency check: "
	(citation asUppercase select: [:c | c isLetter]) =
		(String withAll: (answers collect: [:a | indexableQuote at: a first]))
		ifFalse: [self error: 'mal-formed crostic file'].
	
	crosticPanel _ super new.
	quotePanel _ CrosticQuotePanel new quote: quoteWithBlanks answers: answers cluesPanel: crosticPanel.
	crosticPanel color: quotePanel firstSubmorph color;
		quote: indexableQuote clues: clues answers: answers quotePanel: quotePanel.
	buttonRow _ crosticPanel buttonRow.
	quoteWidth _ (crosticPanel width + quotePanel firstSubmorph width)
					max: buttonRow width.
	quotePanel extent: quoteWidth @ 9999.
	crosticPanel addMorph: quotePanel.
	^ crosticPanel breakColumnAndResizeWithButtons: buttonRow

! !

!CrosticPanel class methodsFor: 'as yet unclassified' stamp: 'di 5/12/2000 15:12'!
oldStyle
	"return true if we should cross-index all the cells (takes more space)."

	^ false! !

!CrosticPanel class methodsFor: 'as yet unclassified' stamp: 'di 11/30/2000 10:15'!
sampleFile 
	"If you want to enter a new acrostic, follow this format exactly with regard to CRs and the like, and store it in a file.  Do not double the string quotes as here -- that is only because they are embedded in a string.  Finally, compress the file in the fileList (so it will be easy to transport and hard to read), and name it 'yourName.crostic' so that the 'open' button on the panel will recognize it."
	^
'Men and women do not feel the same way about dirt.  Women for some hormonal reason can see individual dirt molecules, whereas men tend not to notice them until they join together into clumps large enough to support commercial agriculture.
Dave Barry''s Guide to Marriage

Boccaccio''s collection of tales
74 19 175 156 9 122 84 113 104
Wooden instrument of Swiss herders
67 184 153 103 14 142 148 54 3
Evening service
76 99 154 171 89 194 69
Russian-born American anarchist (2 wds)
159 102 177 25 186 134 128 82 50 62 11
Apple-polish (2 wds)
32 190 129 126 179 157 79 170
Visual-gesture means of communication
4 178 27 168 150 185 114
Postponed contest
173 58 77 65 8 124 85
Groundbreaking invention
98 15 116 162 112 37 92 155 70 187
Material used to make English longbows
132 195 28
Gracile
48 191 145 152
Have the effrontery; experience a high (2 wds)
164 61 137 33 17 45
Florentine painter who experimented with perspective
91 181 189 2 20 81 167
Sondheim opus (3 wds)
72 109 147 13 192 165 93 40 115 138 6 63
Spanish rake
108 56 44 133 193 29 125
Emergence  as of an adult butterfly
106 149 59 41 24 135 87 68
Type of rifle (hyph)
111 7 143 73 39 30 105 95 53
Free of charge (3 wds)
176 107 120 130 160 22 46 34 94 71
Pie filling
86 75 136 118 43
Master filmmaker
31 151 174 51 163 144
Longtime sportswriter for the NY Herald tribune (2 wds)
60 140 12 101 55 188 166 121
Birthplace of Erasmus
47 64 141 21 10 180 36 80 1
Mae West classic (3 wds)
127 123 161 110 183 5 139 97 88
Element that glows blue in the dark
100 90 35 182 146 117 169 26
Sturm und Drang writer
158 172 119 16 52 23
Starfish or sea cucumber
18 66 96 83 57 49 78 131 38 42
'! !
WordGamePanelMorph subclass: #CrosticQuotePanel
	instanceVariableNames: 'cluesPanel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!CrosticQuotePanel methodsFor: 'initialization' stamp: 'di 5/7/2000 11:59'!
extent: newExtent

	| w h nAcross relLoc topLeft |
	w _ self firstSubmorph width - 1.  h _ self firstSubmorph height - 1.
	nAcross _ newExtent x - (self borderWidth-1*2)-1 // w.
	topLeft _ self position + self borderWidth - 1.
	submorphs withIndexDo:
		[:m :i | 
		relLoc _ (i-1 \\ nAcross * w) @ (i-1 // nAcross * h).
		m position: topLeft + relLoc].
	super extent: ((w * nAcross + 1) @ (submorphs size - 1 // nAcross + 1 * h+1))
					+ (self borderWidth - 1 * 2).
! !

!CrosticQuotePanel methodsFor: 'initialization' stamp: 'di 5/12/2000 00:07'!
quote: quoteWithBlanks answers: theAnswers cluesPanel: panel

	| n morph prev clueIxs |
	cluesPanel _ panel.
	self color: Color gray.
	clueIxs _ Array new: quoteWithBlanks size.
	theAnswers withIndexDo: [:a :i | a do: [:j | clueIxs at: j put: i]].
	letterMorphs _ OrderedCollection new.
	prev _ nil.
	self addAllMorphs: (quoteWithBlanks asArray collect:
		[:c |
		c isLetter
			ifTrue: [n _ letterMorphs size + 1.
					morph _ WordGameLetterMorph new boxed.
					CrosticPanel oldStyle
						ifTrue: [morph indexInQuote: n id1: n printString.
								morph id2: (($A to: $Z) at: (clueIxs at: n)) asString]
						ifFalse: [morph indexInQuote: n id1: nil].
					morph setLetter: Character space.
					morph on: #mouseDown send: #mouseDownEvent:letterMorph: to: self.
					morph on: #keyStroke send: #keyStrokeEvent:letterMorph: to: self.
					letterMorphs addLast: morph]
			ifFalse: [morph _ WordGameLetterMorph new boxed indexInQuote: nil id1: nil.
					CrosticPanel oldStyle ifTrue: [morph extent: 26@24  "Oops"]].
		morph predecessor: prev.
		prev ifNotNil: [prev successor: morph].
		prev _ morph]).
! !


!CrosticQuotePanel methodsFor: 'events' stamp: 'di 5/11/2000 09:37'!
highlight: morph

	self unhighlight.
	cluesPanel unhighlight.
	morph startOfWord morphsInWordDo:
		[:m | m color: Color lightGreen.
		(cluesPanel letterMorphs at: m indexInQuote) color: Color lightMagenta].
	morph color: Color green.
	(cluesPanel letterMorphs at: morph indexInQuote) color: Color magenta.
! !

!CrosticQuotePanel methodsFor: 'events' stamp: 'di 5/10/2000 09:25'!
keyCharacter: aLetter atIndex: indexInQuote nextFocus: nextFocus

	(self letterMorphs at: indexInQuote) setLetter: aLetter.
	(cluesPanel letterMorphs at: indexInQuote) setLetter: aLetter.
	self highlight: nextFocus
! !

!CrosticQuotePanel methodsFor: 'events' stamp: 'di 5/10/2000 08:49'!
lostFocus

	self unhighlight.
	cluesPanel unhighlight! !
Object subclass: #CurrentProjectRefactoring
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

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

CurrentProjectRefactoring class
	instanceVariableNames: ''!

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 10:55'!
currentAddGuard: anObject
"
CurrentProjectRefactoring currentAddGuard:
"
	^self xxxCurrent addGuard: anObject! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 11:00'!
currentBeIsolated
"
CurrentProjectRefactoring currentBeIsolated
"
	^self xxxCurrent beIsolated! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:50'!
currentBeParentTo: anotherProject
"
CurrentProjectRefactoring currentBeParentTo:
"
	^anotherProject setParent: self xxxCurrent! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:50'!
currentBeParentToCurrent
"
CurrentProjectRefactoring currentBeParentToCurrent
"
	^self xxxCurrent setParent: self xxxCurrent! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:50'!
currentFlapsSuppressed
"
CurrentProjectRefactoring currentFlapsSuppressed
"
	^self xxxCurrent flapsSuppressed! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 11:02'!
currentFromMyServerLoad: aProjectName
"
CurrentProjectRefactoring currentFromMyServerLoad:
"
	^self xxxCurrent fromMyServerLoad: aProjectName! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 18:58'!
currentInterruptName: aString
"
CurrentProjectRefactoring currentInterruptName:
"
	^Project interruptName: aString! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:50'!
currentIsolationHead
"
CurrentProjectRefactoring currentIsolationHead
"
	^self xxxCurrent isolationHead! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:50'!
currentProjectName
"
CurrentProjectRefactoring currentProjectName
"
	^self xxxCurrent name! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 11:01'!
currentPropagateChanges
"
CurrentProjectRefactoring currentPropagateChanges
"
	^self xxxCurrent propagateChanges! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 18:51'!
currentSpawnNewProcessAndTerminateOld: aBoolean
"
CurrentProjectRefactoring currentSpawnNewProcessAndTerminateOld:
"
	^Project spawnNewProcessAndTerminateOld: aBoolean

! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 11:18'!
currentToggleFlapsSuppressed
"
CurrentProjectRefactoring currentToggleFlapsSuppressed
"
	^self xxxCurrent flapsSuppressed: self xxxCurrent flapsSuppressed not.


! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:51'!
exitCurrentProject
"
CurrentProjectRefactoring exitCurrentProject
"
	^self xxxCurrent exit
! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'sw 11/6/2000 15:37'!
isFlapEnabled: aFlapTab
	"Answer whether the given flap tab is enabled in the current project"

	^ self xxxCurrent isFlapEnabled: aFlapTab! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 18:50'!
newProcessIfUI: aDeadOrDyingProcess
"
CurrentProjectRefactoring newProcessIfUI:
used ONLY for Morphic
"
	^Project spawnNewProcessIfThisIsUI: aDeadOrDyingProcess! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:51'!
projectWithNameOrCurrent: aString
"
CurrentProjectRefactoring projectWithNameOrCurrent:
"
	^(Project named: aString) ifNil: [self xxxCurrent]! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:51'!
updateProjectFillsIn: aFlashPlayerMorph
"
CurrentProjectRefactoring updateProjectFillsIn:
"
	^aFlashPlayerMorph updateProjectFillsFrom: self xxxCurrent
! !

!CurrentProjectRefactoring class methodsFor: 'as yet unclassified' stamp: 'RAA 6/3/2000 09:49'!
xxxCurrent

	^Project current! !
Form subclass: #Cursor
	instanceVariableNames: ''
	classVariableNames: 'BlankCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor RightArrowCursor SquareCursor UpCursor WaitCursor WriteCursor XeqCursor '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!Cursor commentStamp: '<historical>' prior: 0!
I am a 16 x 16 dot matrix suitable for use as the Alto hardware cursor.!


!Cursor methodsFor: 'updating'!
changed: aParameter

	self == CurrentCursor ifTrue: [self beCursor].
	super changed: aParameter! !


!Cursor methodsFor: 'displaying'!
beCursor
	"Primitive. Tell the interpreter to use the receiver as the current cursor 
	image. Fail if the receiver does not match the size expected by the 
	hardware. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 101>
	self primitiveFailed! !

!Cursor methodsFor: 'displaying' stamp: 'jm 9/22/1998 23:33'!
beCursorWithMask: maskForm
	"Primitive. Tell the interpreter to use the receiver as the current cursor image with the given mask Form. Both the receiver and the mask should have extent 16@16 and a depth of one. The mask and cursor bits are combined as follow:
			mask	cursor	effect
			 0		  0		transparent (underlying pixel shows through)
			 1		  1		opaque black
			 1		  0		opaque white
			 0		  1		invert the underlying pixel"
"Essential. See Object documentation whatIsAPrimitive."

	<primitive: 101>
	self primitiveFailed
! !

!Cursor methodsFor: 'displaying'!
show
	"Make the current cursor shape be the receiver."

	Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying'!
showGridded: gridPoint 
	"Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint."
	
	Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint).
	Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying' stamp: 'bf 10/13/1999 13:05'!
showWhile: aBlock 
	"While evaluating the argument, aBlock, make the receiver be the cursor 
	shape."

	| oldcursor |
	oldcursor _ Sensor currentCursor.
	self show.
	^aBlock ensure: [oldcursor show]
! !


!Cursor methodsFor: 'printing'!
printOn: aStream

	self storeOn: aStream base: 2! !


!Cursor methodsFor: 'testing' stamp: 'bf 2/2/1999 19:34'!
hasMask
	^false! !


!Cursor methodsFor: 'converting' stamp: 'RAA 8/14/2000 10:14'!
asCursorForm
	| form |
	form _ StaticForm extent: self extent depth: 8.
	form fillShape: self fillColor: Color black at: offset negated.
	^ form offset: offset! !

!Cursor methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'!
withMask
	^CursorWithMask derivedFrom: self! !

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

Cursor class
	instanceVariableNames: ''!

!Cursor class methodsFor: 'class initialization'!
initCorner

	CornerCursor _ 
		(Cursor 
			extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
! !

!Cursor class methodsFor: 'class initialization'!
initCrossHair

	CrossHairCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r1111111111111110
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0)
			offset: -7@-7).
	
	! !

!Cursor class methodsFor: 'class initialization'!
initDown

	DownCursor  _
		     (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r1111110000000000
		2r111100000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initMarker

	MarkerCursor _ 
		Cursor
			extent: 16@16
			fromArray: #(
		2r0111000000000000
		2r1111100000000000
		2r1111100000000000
		2r0111000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
			offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization'!
initMenu 

	MenuCursor  _
		        (Cursor
	extent: 16@16
	fromArray: #(
		2r1111111111100000
		2r1000000000100000
		2r1010011000100000
		2r1000000000100000
		2r1011001010100000
		2r1000000000100000
		2r1010110010100000
		2r1000000000100000
		2r1010010100100000
		2r1000000000100000
		2r1111111111100000
		2r1101001101100000
		2r1111111111100000
		2r1000000000100000
		2r1010101100100000
		2r1111111111100000)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initMove

	MoveCursor _ 
		Cursor 
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1111111111111111
		2r1111111111111111
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1111111111111111
		2r1111111111111111)
			offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization'!
initNormal

	NormalCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000000000
		2r1100000000000000
		2r1110000000000000
		2r1111000000000000
		2r1111100000000000
		2r1111110000000000
		2r1111111000000000
		2r1111100000000000
		2r1111100000000000
		2r1001100000000000
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).

	
	! !

!Cursor class methodsFor: 'class initialization' stamp: 'di 10/8/1998 17:04'!
initNormalWithMask    "Cursor initNormalWithMask.  Cursor normal show"
	"Next two lines work simply for any cursor..."
	self initNormal.
	NormalCursor _ CursorWithMask derivedFrom: NormalCursor.

	"But for a good looking cursor, you have to tweak things..."
	NormalCursor _ (CursorWithMask extent: 16@16 depth: 1
			fromArray: #( 0 1073741824 1610612736 1879048192
				2013265920 2080374784 2113929216 2130706432
				2080374784 2080374784 1275068416 100663296
				100663296 50331648 50331648 0)
			offset: -1@-1)
		setMaskForm: (Form extent: 16@16 depth: 1
			fromArray: #( 3221225472 3758096384 4026531840 4160749568
				4227858432 4261412864 4278190080 4286578688
				4278190080 4261412864 4261412864 3472883712
				251658240 125829120 125829120 50331648)
			offset: 0@0).! !

!Cursor class methodsFor: 'class initialization'!
initOrigin

	OriginCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initRead

	ReadCursor _  
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000110000000110
		2r0001001000001001
		2r0001001000001001
		2r0010000000010000
		2r0100000000100000
		2r1111101111100000
		2r1000010000100000
		2r1000010000100000
		2r1011010110100000
		2r0111101111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initRightArrow 

	RightArrowCursor  _
		      (Cursor
	extent: 16@16
	fromArray: #(
		2r100000000000
		2r111000000000
		2r1111111110000000
		2r111000000000
		2r100000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
	
	"Cursor initRightArrow"! !

!Cursor class methodsFor: 'class initialization'!
initSquare

	SquareCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: -8@-8).

	! !

!Cursor class methodsFor: 'class initialization'!
initUp

	UpCursor _ 
		    (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r111100000000000
		2r1111110000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initWait

	WaitCursor _ 
		  (Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1000000000000001
		2r0100000000000010
		2r0010000000000100
		2r0001110000111000
		2r0000111101110000
		2r0000011011100000
		2r0000001111000000
		2r0000001111000000
		2r0000010110100000
		2r0000100010010000
		2r0001000110001000
		2r0010001101000100
		2r0100111111110010
		2r1011111111111101
		2r1111111111111111)
			offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initWrite

	WriteCursor _ (Cursor
	extent: 16@16
	fromArray: #(
		2r0000000000000110
		2r0000000000001111
		2r0000000000010110
		2r0000000000100100
		2r0000000001001000
		2r0000000010010000
		2r0000000100100000
		2r0000001001000011
		2r0000010010000010
		2r0000100100000110
		2r0001001000001000
		2r0010010000001000
		2r0111100001001000
		2r0101000010111000
		2r0110000110000000
		2r1111111100000000)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initXeq

	XeqCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000010000
		2r1100000000010000
		2r1110000000111000
		2r1111000111111111
		2r1111100011000110
		2r1111110001000100
		2r1111111001111100
		2r1111000001101100
		2r1101100011000110
		2r1001100010000010
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization' stamp: 'di 3/6/1999 21:27'!
initialize
	"Create all the standard cursors..."
		self initOrigin.
		self initRightArrow.
		self initMenu.
		self initCorner.
		self initRead.
		self initWrite.
		self initWait.
		BlankCursor _ Cursor new.
		self initXeq.
		self initSquare.
		self initNormalWithMask.
		self initCrossHair.
		self initMarker.
		self initUp.
		self initDown.
		self initMove.

		self makeCursorsWithMask.

		"Cursor initialize"
! !

!Cursor class methodsFor: 'class initialization' stamp: 'bf 2/2/1999 19:33'!
makeCursorsWithMask
	"Cursor initialize;makeCursorsWithMask"

	self classPool associationsDo: [:var |
		var value hasMask
			ifFalse: [var value: var value withMask]] ! !

!Cursor class methodsFor: 'class initialization'!
startUp
	self currentCursor: self currentCursor! !


!Cursor class methodsFor: 'instance creation'!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer a new instance of me with width and height specified by
	extentPoint, offset by offsetPoint, and bits from anArray.
	NOTE: This has been kluged to take an array of 16-bit constants,
	and shift them over so they are left-justified in a 32-bit bitmap"

	extentPoint = (16 @ 16)
		ifTrue: 
			[^ super
				extent: extentPoint
				fromArray: (anArray collect: [:bits | bits bitShift: 16])
				offset: offsetPoint]
		ifFalse: [self error: 'cursors must be 16@16']! !

!Cursor class methodsFor: 'instance creation' stamp: 'di 10/6/1998 13:53'!
new

	^ self extent: 16 @ 16
		fromArray: (Array new: 16 withAll: 0)
		offset: 0 @ 0

	"Cursor new bitEdit show"! !


!Cursor class methodsFor: 'current cursor'!
currentCursor
	"Answer the instance of Cursor that is the one currently displayed."

	^CurrentCursor! !

!Cursor class methodsFor: 'current cursor' stamp: 'di 10/6/1998 13:57'!
currentCursor: aCursor 
	"Make the instance of cursor, aCursor, be the current cursor. Display it. 
	Create an error if the argument is not a Cursor."

	(aCursor isKindOf: self)
		ifTrue: [CurrentCursor _ aCursor.
				aCursor beCursor]
		ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! !


!Cursor class methodsFor: 'constants'!
blank
	"Answer the instance of me that is all white."

	^BlankCursor! !

!Cursor class methodsFor: 'constants'!
bottomLeft
	"Cursor bottomLeft showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1111111111111111
		2r1111111111111111)
			offset: 0@-16).
! !

!Cursor class methodsFor: 'constants'!
bottomRight
	"Cursor bottomRight showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
! !

!Cursor class methodsFor: 'constants'!
corner
	"Answer the instance of me that is the shape of the bottom right corner 
	of a rectangle."

	^CornerCursor! !

!Cursor class methodsFor: 'constants'!
crossHair
	"Answer the instance of me that is the shape of a cross."

	^CrossHairCursor! !

!Cursor class methodsFor: 'constants'!
down
	"Answer the instance of me that is the shape of an arrow facing 
	downward."

	^DownCursor! !

!Cursor class methodsFor: 'constants'!
execute
	"Answer the instance of me that is the shape of an arrow slanted left 
	with a star next to it."

	^XeqCursor! !

!Cursor class methodsFor: 'constants'!
marker
	"Answer the instance of me that is the shape of a small ball."

	^MarkerCursor! !

!Cursor class methodsFor: 'constants'!
menu 
	"Answer the instance of me that is the shape of a menu."

	^MenuCursor! !

!Cursor class methodsFor: 'constants'!
move
	"Answer the instance of me that is the shape of a cross inside a square."

	^MoveCursor! !

!Cursor class methodsFor: 'constants'!
normal
	"Answer the instance of me that is the shape of an arrow slanted left."

	^NormalCursor! !

!Cursor class methodsFor: 'constants'!
origin
	"Answer the instance of me that is the shape of the top left corner of a 
	rectangle."

	^OriginCursor! !

!Cursor class methodsFor: 'constants'!
read
	"Answer the instance of me that is the shape of eyeglasses."

	^ReadCursor! !

!Cursor class methodsFor: 'constants'!
rightArrow 
	"Answer the instance of me that is the shape of an arrow pointing to the right."

	^RightArrowCursor! !

!Cursor class methodsFor: 'constants'!
square
	"Answer the instance of me that is the shape of a square."

	^SquareCursor! !

!Cursor class methodsFor: 'constants'!
topLeft
	"Cursor topLeft showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
! !

!Cursor class methodsFor: 'constants'!
topRight
	"Cursor topRight showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011)
			offset: -16@0).
! !

!Cursor class methodsFor: 'constants'!
up
	"Answer the instance of me that is the shape of an arrow facing upward."

	^UpCursor! !

!Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'!
wait
	"Answer the instance of me that is the shape of an Hourglass (was in the 
	shape of three small balls)."

	^WaitCursor! !

!Cursor class methodsFor: 'constants' stamp: 'ar 11/18/1998 15:33'!
webLink
	"Return a cursor that can be used for emphasizing web links"
	"Cursor webLink showWhile: [Sensor waitButton]"
	^ (CursorWithMask extent: 16@16
			fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 )
			offset: -5@0) setMaskForm:
		(Form extent: 16@16 
			fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 )  collect: [:bits | bits bitShift: 16])
			offset: 0@0).! !

!Cursor class methodsFor: 'constants'!
write
	"Answer the instance of me that is the shape of a pen writing."

	^WriteCursor! !
Cursor subclass: #CursorWithMask
	instanceVariableNames: 'maskForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:14'!
asCursorForm
	| form |
	form _ StaticForm extent: self extent depth: 8.
	form fillShape: maskForm fillColor: Color white.
	form fillShape: self fillColor: Color black at: offset negated.
	^ form offset: offset! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/6/1998 15:16'!
beCursor
	maskForm unhibernate.
	^ self beCursorWithMask: maskForm! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:34'!
hasMask
	^true! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/8/1998 16:46'!
maskForm
	^ maskForm! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/8/1998 16:46'!
setMaskForm: aForm
	maskForm _ aForm! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:30'!
storeOn: aStream base: anInteger

	aStream nextPut: $(.
	super storeOn: aStream base: anInteger.
	aStream nextPutAll: ' setMaskForm: '.
	maskForm storeOn: aStream base: anInteger.
	aStream nextPut: $)! !

!CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:31'!
withMask
	^self! !

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

CursorWithMask class
	instanceVariableNames: ''!

!CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'di 2/18/1999 08:56'!
derivedFrom: aForm      "Cursor initNormalWithMask.  Cursor normal show"
	"aForm is presumably a cursor"
	| cursor mask ext |
	ext _ aForm extent.
	cursor _ self extent: ext.
	cursor copy: (1@1 extent: ext) from: 0@0 in: aForm rule: Form over.
	mask _ Form extent: ext.
	(1@1) eightNeighbors do:
		[:p | mask copy: (p extent: ext) from: 0@0 in: aForm rule: Form under].
	cursor setMaskForm: mask.
	cursor offset: ((aForm offset - (1@1)) max: ext negated).
	^ cursor! !
Path subclass: #CurveFitter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!CurveFitter commentStamp: '<historical>' prior: 0!
I represent a conic section determined by three points p1, p2 and p3. I interpolate p1 and p3 and am tangent to line p1, p2 at p1 and line p3, p2 at p3.!


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

	| pa pb k s p1 p2 p3 line |
	line _ Line new.
	line form: self form.
	collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points'].
	p1 _ self firstPoint.
	p2 _ self secondPoint.
	p3 _ self thirdPoint.
	s _ Path new.
	s add: p1.
	pa _ p2 - p1.
	pb _ p3 - p2.
	k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20.
	"k is a guess as to how many line segments to use to approximate 
	the curve."
	1 to: k do: 
		[:i | 
		s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)].
	s add: p3.
	1 to: s size - 1 do: 
		[:i | 
		line beginPoint: (s at: i).
		line endPoint: (s at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!CurveFitter methodsFor: 'displaying' stamp: '6/9/97 10:16 di'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| transformedPath newCurveFitter |
	transformedPath _ aTransformation applyTo: self.
	newCurveFitter _ CurveFitter new.
	newCurveFitter firstPoint: transformedPath firstPoint.
	newCurveFitter secondPoint: transformedPath secondPoint.
	newCurveFitter thirdPoint: transformedPath thirdPoint.
	newCurveFitter form: self form.
	newCurveFitter
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

CurveFitter class
	instanceVariableNames: ''!

!CurveFitter class methodsFor: 'instance creation'!
new

	| newSelf | 
	newSelf _ super new: 3.
	newSelf add: 0@0.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !


!CurveFitter class methodsFor: 'examples' stamp: '6/9/97 10:16 di'!
example
	"Designate three locations on the screen by clicking any button. The
	curve determined by the points will be displayed with a long black form."

	| aCurveFitter aForm |  
	aForm _ Form extent: 1@30.			"make a long thin Form for display "
	aForm fillBlack.							"turn it black"
	aCurveFitter _ CurveFitter new.
	aCurveFitter form: aForm.						"set the form for display"
				"collect three Points and show them on the dispaly"
	aCurveFitter firstPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter firstPoint.
	aCurveFitter secondPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter secondPoint.
	aCurveFitter thirdPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurveFitter thirdPoint.

	aCurveFitter displayOn: Display					"display the CurveFitter"

	"CurveFitter example"! !
PolygonMorph subclass: #CurveMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!CurveMorph commentStamp: '<historical>' prior: 0!
This is really only a shell for creating Shapes with smooth outlines.!


!CurveMorph methodsFor: 'initialization' stamp: 'di 9/10/2000 14:28'!
initialize

	super initialize.
	self beSmoothCurve.
! !

SelectionMenu subclass: #CustomMenu
	instanceVariableNames: 'labels dividers lastDivider title '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!CustomMenu commentStamp: '<historical>' prior: 0!
I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:

	add: aString action: anAction
	addLine

After the menu is constructed, it may be invoked with one of the following messages:

	startUp: initialSelection
	startUp

I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:

	items _ an OrderedCollection of strings to appear in the menu
	selectors _ an OrderedCollection of Symbols to be used as message selectors
	lineArray _ an OrderedCollection of line positions
	lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray!


!CustomMenu methodsFor: 'initialize-release'!
initialize

	labels _ OrderedCollection new.
	selections _ OrderedCollection new.
	dividers _ OrderedCollection new.
	lastDivider _ 0.! !

!CustomMenu methodsFor: 'initialize-release' stamp: 'sw 8/18/1998 12:01'!
title: aTitle
	title _ aTitle! !


!CustomMenu methodsFor: 'construction' stamp: 'dhhi 9/14/2000 22:39'!
add: aString action: actionItem
	"Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."

	| s |
	aString ifNil: [^ self addLine].
	s _ String new: aString size + 2.
	s at: 1 put: Character space.
	s replaceFrom: 2 to: s size - 1 with: aString.
	s at: s size put: Character space.
	labels addLast: s.
	selections addLast: actionItem.! !

!CustomMenu methodsFor: 'construction'!
addLine
	"Append a line to the menu after the last entry. Suppress duplicate lines."

	(lastDivider ~= selections size) ifTrue: [
		lastDivider _ selections size.
		dividers addLast: lastDivider].! !

!CustomMenu methodsFor: 'construction' stamp: 'jm 3/29/98 07:09'!
addList: listOfPairs
	"Add a menu item to the receiver for each pair in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list."
	"CustomMenu new addList: #(
		('apples' buyApples)
		('oranges' buyOranges)
		-
		('milk' buyMilk)); startUp"

	listOfPairs do: [:pair |
		#- = pair
			ifTrue: [self addLine]
			ifFalse: [self add: pair first action: pair last]].
! !

!CustomMenu methodsFor: 'construction' stamp: 'sw 7/20/1999 18:47'!
balloonTextForLastItem: aString
	"Vacuous backstop provided for compatibility with MorphicMenu"! !

!CustomMenu methodsFor: 'construction' stamp: 'jm
 8/20/1998 08:34'!
labels: aString font: aFont lines: anArrayOrNil
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."

	| labelList linesArray |
	labelList _ (aString findTokens: String cr) asArray.
	anArrayOrNil
		ifNil: [linesArray _ #()]
		ifNotNil: [linesArray _ anArrayOrNil].
	1 to: labelList size do: [:i |
		self add: (labelList at: i) action: (labelList at: i).
		(linesArray includes: i) ifTrue: [self addLine]].
	font ifNotNil: [font _ aFont].
! !

!CustomMenu methodsFor: 'construction' stamp: 'di 8/20/1998 09:24'!
labels: labelList lines: linesArray selections: selectionsArray
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."
	"Labels can be either a sting with embedded crs, or a collection of strings."

	| labelArray |
	(labelList isMemberOf: String)
		ifTrue: [labelArray _ labelList findTokens: String cr]
		ifFalse: [labelArray _ labelList].
	1 to: labelArray size do: [:i |
		self add: (labelArray at: i) action: (selectionsArray at: i).
		(linesArray includes: i) ifTrue: [self addLine]].
! !


!CustomMenu methodsFor: 'invocation' stamp: 'jm 11/17/97 16:54'!
invokeOn: targetObject defaultSelection: defaultSelection
	"Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."

	| sel |
	sel _ self startUp: defaultSelection.
	sel = nil ifFalse: [
		sel numArgs = 0
			ifTrue: [^ targetObject perform: sel]
			ifFalse: [^ targetObject perform: sel with: nil]].
	^ nil
! !

!CustomMenu methodsFor: 'invocation'!
startUp
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	^ self startUp: nil! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 8/18/1998 12:01'!
startUp: initialSelection
	"Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	^ self startUp: initialSelection withCaption: title! !

!CustomMenu methodsFor: 'invocation'!
startUp: initialSelection withCaption: caption
	"Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	self build.
	(initialSelection notNil) ifTrue: [self preSelect: initialSelection].
	^ super startUpWithCaption: caption! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 7/31/97 19:31'!
startUpWithCaption: caption
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption"

	^ self startUp: nil withCaption: caption! !


!CustomMenu methodsFor: 'private' stamp: 'sw 12/10/1999 11:21'!
build
	"Turn myself into an invokable ActionMenu."

	| stream |
	stream _ WriteStream on: (String new).
	labels do: [:label | stream nextPutAll: label; cr].
	(labels isEmpty) ifFalse: [stream skip: -1].  "remove final cr"
	super labels: stream contents
		font: MenuStyle defaultFont
		lines: dividers! !

!CustomMenu methodsFor: 'private' stamp: 'di 4/14/1999 21:28'!
preSelect: action
	"Pre-select and highlight the menu item associated with the given action."

	| i |
	i _ selections indexOf: action ifAbsent: [^ self].
	marker ifNil: [self computeForm].
	marker _ marker
		align: marker topLeft
		with: (marker left)@(frame inside top + (marker height * (i - 1))).
	selection _ i.! !

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

CustomMenu class
	instanceVariableNames: ''!

!CustomMenu class methodsFor: 'instance creation'!
new

	^ super new initialize! !


!CustomMenu class methodsFor: 'example' stamp: 'sw 11/8/1999 17:27'!
example
	"CustomMenu example"

	| menu |
	menu _ CustomMenu new.
	menu add: 'apples' action: #apples.
	menu add: 'oranges' action: #oranges.
	menu addLine.
	menu addLine.  "extra lines ignored"
	menu add: 'peaches' action: #peaches.
	menu addLine.
	menu add: 'pears' action: #pears.
	menu addLine.
	^ menu startUp: #apples


"NB:  The following is equivalent to the above, but uses the compact #fromArray: consruct:
	(CustomMenu fromArray:
		#(	('apples'		apples)
			('oranges'		oranges)
			-
			-
			('peaches'		peaches)
			-
			('pears'			pears)
			-))
				startUp: #apples"! !
Object subclass: #DECTalkReader
	instanceVariableNames: 'stream phonemes durations events currentDuration currentPitch f0Contour '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!

!DECTalkReader methodsFor: 'initialization' stamp: 'len 12/24/1999 03:20'!
initialize
	phonemes _ PhonemeSet dectalkToArpabet.
	events _ CompositeEvent new.
	currentDuration _ 80.
	currentPitch _ 100.
	f0Contour _ CosineInterpolator new.
	durations _ Dictionary new.
	#(
	('ae'	230.0	80.0)
	('aa'	240.0	100.0)
	('ax'	120.0	60.0)
	('er'	180.0	80.0)
	('ay'	250.0	150.0)
	('aw'	240.0	100.0)
	('b'		85.0		60.0)
	('ch'	70.0		50.0)
	('d'		75.0		50.0)
	('dh'	50.0		30.0)
	('eh'	150.0	70.0)
	('ea'	270.0	130.0)
	('ey'	180.0	100.0)
	('f'		100.0	80.0)
	('g'		80.0		60.0)
	('hh'	80.0		20.0)
	('ih'	135.0	40.0)
	('ia'	230.0	100.0)
	('iy'	155.0	55.0)
	('jh'	70.0		50.0)
	('k'		80.0		60.0)
	('l'		80.0		40.0)
	('m'		70.0		60.0)
	('n'		60.0		50.0)
	('ng'	95.0		60.0)
"	('oh'	240.0	130.0)"
	('oy'	280.0	150.0)
	('ao'	240.0	130.0)
	('ow'	220.0	80.0)
	('p'		90.0		50.0)
	('r'		80.0		30.0)
	('s'		105.0	60.0)
	('sh'	105.0	80.0)
	('t'		75.0		50.0)
	('th'	90.0		60.0)
	('uh'	210.0	70.0)
	('ua'	230.0	110.0)
	('ah'	160.0	60.0)
	('uw'	230.0	150.0)
	('v'		60.0		40.0)
	('w'		80.0		60.0)
	('y'		80.0		40.0)
	('z'		75.0		40.0)
	('zh'	70.0		40.0)
	('sil'	100.0	100.0)) do: [ :each |
		durations at: (PhonemeSet arpabet at: each first) put: each second / 1000.0]! !


!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:28'!
defaultDurationFor: aPhoneme
	^ durations at: aPhoneme ifAbsent: [0.080]! !

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:04'!
events
	^ events! !

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:04'!
phonemes
	^ phonemes! !

!DECTalkReader methodsFor: 'accessing' stamp: 'len 12/20/1999 03:04'!
stream: aStream
	stream _ aStream! !


!DECTalkReader methodsFor: 'reading' stamp: 'len 12/20/1999 03:37'!
addPitches
	| offset |
	offset _ 0.0.
	events do: [ :each |
		each pitchPoints: (self pitchesBetween: offset and: offset + each duration).
		offset _ offset + each duration].! !

!DECTalkReader methodsFor: 'reading' stamp: 'len 12/20/1999 04:31'!
nextPhoneme
	| try try2 phon |
	try _ stream next asString.
	(',.;-' includes: try first) ifTrue: [^ phonemes at: 'sil'].
	try2 _ try, stream peek asString.
	(phon _ phonemes at: try2 ifAbsent: []) notNil ifTrue: [stream next. ^ phon].
	^ phonemes at: try! !

!DECTalkReader methodsFor: 'reading' stamp: 'len 12/20/1999 03:37'!
pitchesBetween: t1 and: t2
	| step |
	step _ (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (f0Contour at: each)]! !

!DECTalkReader methodsFor: 'reading' stamp: 'len 12/24/1999 05:35'!
read
	| phoneme time |
	time _ 0.
	[stream skipSeparators; atEnd]
		whileFalse: [phoneme _ self nextPhoneme.
					currentDuration _ self defaultDurationFor: phoneme.
					stream peek = $< ifTrue: [self readPitchAndDuration].
					f0Contour at: time + (currentDuration / 2.0 min: 0.1) put: currentPitch.
					time _ time + currentDuration.
					f0Contour at: time put: currentPitch.
					events add: (PhoneticEvent new phoneme: phoneme; duration: currentDuration; loudness: 1.0)].
	self addPitches! !

!DECTalkReader methodsFor: 'reading' stamp: 'len 12/24/1999 03:17'!
readPitchAndDuration
	| tokens code |
	stream next.
	tokens _ (stream upTo: $>) findTokens: ','.
	currentDuration _ tokens first asNumber / 1000.0.
	tokens size > 1 ifFalse: [^ self].
	code _ tokens last asNumber.
	currentPitch _ code > "37" 64 ifTrue: [code] ifFalse: [AbstractSound pitchForMIDIKey: 35 + code]! !

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

DECTalkReader class
	instanceVariableNames: ''!

!DECTalkReader class methodsFor: 'instance creation' stamp: 'len 12/20/1999 03:52'!
eventsFromStream: aStream
	^ self new stream: aStream; read; events! !

!DECTalkReader class methodsFor: 'instance creation' stamp: 'len 12/20/1999 03:52'!
eventsFromString: aString
	^ self eventsFromStream: (ReadStream on: aString)! !

!DECTalkReader class methodsFor: 'instance creation' stamp: 'len 12/20/1999 03:52'!
new
	^ super new initialize! !


!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:14'!
daisy
	"
	DECTalkReader daisy playOn: KlattVoice new delayed: 10000
	"
	^ self eventsFromString: '_<50,22>dey<400,22>ziy<400,19>dey<400,15>ziy<400,10>
gih<200,12>vmiy<200,14>yurr<200,15>ae<400,12>nsax<200,15>
rduw<400,10>.
ay<400,17>mhxae<400,22>fkrey<400,19>ziy<400,15>ao<200,12>
lfao<200,14>rdhax<200,15>lah<400,17>vao<200,19>vyu<400,17>.
ih<200,19>twow<200,20>ntbiy<200,19>ax<200,17>stay<400,22>
lih<200,19>shmae<200,17>rih<400,15>jh<50,15>.
ay<200,17>kae<400,19>ntax<200,15>fow<400,12>rdax<200,15>
kae<200,12>rih<400,10>jh<50,10>.
bah<200,10>tyu<400,15>lluh<200,19>kswiy<400,17>tah<200,10>
pao<400,15>ndhax<200,19>siy<400,17>t<50,17>.
ao<200,17>vax<200,19>bay<200,22>six<200,19>kel<200,15>
bih<400,17>ltfao<200,10>rtuw<800,15>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:48'!
flower
	"
	DECTalkReader flower playOn: KlattVoice new delayed: 15000
	"
	^ self eventsFromString: '_<25,22>ow<200,22>flaw<400,22>rax<200,20>vskao<400,18>
ao<200,18>tlae<800,13>nd<200,13>
weh<200,13>nwih<400,18>lwiy<200,22>siy<800,20>yu<200,20>
rlay<400,18>kax<200,20>geh<1600,22>n<25,22>
dhax<200,22>tfao<300,23>ao<100,22>tae<200,23>nday<400,25>
d<200,25>fao<800,18>r<25,18>
yu<200,13>rwiy<400,20>bih<200,20>t hxih<200,20>ih<200,18>
lae<200,20>ndgleh<400,22>nae<200,23>ndstuh<400,22>dax<200,20>
geh<600,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<800,18>eh<400,18>n<200,18>
_<600,22>dhax<200,22>hxih<400,22>lzax<200,20>rbey<400,18>
rr<200,18>naw<800,13>
ae<200,13>ndao<400,18>tah<200,22>mliy<800,20>vzlay<200,20>
thih<400,18>kax<200,20>ndstih<800,22>ih<800,22>l<25,22>
ow<200,22>rlae<300,23>nddhax<100,22>tih<200,23>zlao<400,25>
ao<200,25>stnaw<800,18>
wih<200,13>chdhow<400,20>zsow<200,20>diy<200,20>ax<200,18>
lih<200,20>hxeh<400,22>ldhax<200,23>tstuh<400,22>dax<200,20>
geh<400,18>eh<200,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<1200,18>n<200,18>
_<600,22>dhow<200,22>zdey<400,22>zax<200,20>rpae<400,18>
ae<200,18>stnaw<800,13>
ae<200,13>ndih<400,18>ndhax<200,22>pae<800,20>stdhey<200,20>
mah<400,18>strix<200,20>mey<800,22>ey<800,22>n<25,22>
bah<200,22>twiy<300,23>kae<100,22>nstih<200,23>lray<600,25>
znaw<800,18>
ae<200,13>ndbiy<400,20>dhax<200,20>ney<200,20>shax<200,18>
nax<200,20>geh<400,22>ndhax<200,23>tstuh<400,22>dax<200,20>
geh<600,18>nst hxih<800,13>m<200,13>
praw<200,22>deh<300,23>eh<100,22>dwax<200,23>rdzaa<400,25>
aa<200,25>rmih<800,18>ih<200,18>
ae<200,22>ndseh<200,23>eh<200,22>nt hxih<200,20>mhxow<300,22>
ow<100,20>ow<200,18>mwax<800,18>ax<200,18>rdtey<200,18>
thih<400,16>nxkax<200,20>geh<1200,18>n<200,18>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:43'!
great
	"
	(DECTalkReader great pitchBy: 0.5) playOn: (KlattVoice new tract: 19; flutter: 0.5) delayed: 10000
	"
	^ self eventsFromString: '_<50,20>ax<200,20>_<1>ax<500,22>_<10>ow<300,20>yxeh<1000,17>
say<200,15>mdhax<80,13>grey<1000,15>t_priy<200,17>iy<200,18>
teh<200,17>eh<200,15>ndrr<1600,13>
_<200,13>priy<200,13>teh<1000,22>ndih<200,22>nxdhae<100,22>
day<1000,18>mduh<200,20>ix<200,22>nweh<1600,20>l<600,20>
_<60,25>may<300,25>niy<1200,22>dix<200,22>zsah<1000,24>chay<200,22>
priy<200,24>teh<1000,25>ndtuh<200,22>_<10>uw<200,25>mah<1000,20>ch<100,20>
_<20,20>ay<300,20>mlow<300,20>neliy<800,17>bah<200,13>
tnow<1000,15>wah<200,13>nkae<200,15>nteh<1800,13>l<400,13>
_<50,20>ax<200,20>_<1>ax<500,22>_<1>ow<300,20>yxeh<1000,17>
say<200,15>mdhax<80,13>grey<1000,15>t_priy<200,17>iy<200,18>
teh<200,17>eh<200,15>ndrr<1800,13>
_<10,13>ah<200,13>drih<1000,22>ftih<50,22>nax<200,22>
wrr<1000,18>ldax<200,20>vmay<200,22>ax<200,22>_<1>ow<1400,20>n<600,20>
_<60,25>ay<300,25>pley<1100,22>dhax<200,22>gey<1000,24>
m<100,24>bah<200,22>tuh<200,24>may<1000,25>riy<200,22>ax<200,25>
lshey<600,20>m<400,20>
_<20,20>yu<200,20>vleh<200,20>ftmiy<800,17>tuw<200,13>
driy<800,15>mao<200,13>lah<200,15>low<1600,13>n<400,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:25'!
hawaii
	"
	DECTalkReader hawaii playOn: (KlattVoice new tract: 14.4) delayed: 10000
	"
	^ self eventsFromString: '_<300> naa<600,23> ay<300,23>t ae<300,22>nd yuw<1200,23> ,<600>
ae<600,24>nd
bluw<900,25> hxah<300,24> waa<940,23> aa<240,22> aa<240,21> iy<1200,20>
,<600> dhah<600,32> naa<600,33> ay<300,33>t ih<300,32>z hxeh<900,30>
veh<300,22>n liy<1200,25>
,<600> ae<300,30> ae<300,31>nd yu<900,32> aa<300,30>rx
hxeh<440,28> veh<440,28>n tuw<440,25> miy<2400,23> ,<600> lah<900,23>v
liy<300,22> yuw<1200,23> ,<600> ae<600,24>nd bluw<900,25> hxah<300,24>
waa<940,23>-aa<240,22>-aa<240,21>-iy<1200,20>
,<600> wih<600,32>dh ao<900,33>lx dhih<300,32>s lah<880,30> v<40,30>
liy<300,22> neh<1200,25>s
,<600> dheh<300,30> eh<300,31>rx shuh<900,32>d biy<300,27>
lah<4140,28> v<60,28> ,<600> kah<900,25>m wih<300,32>dh miy<1800,30> ,<600>
waa<400,28> ay<200,28>lx dhah<600,25> muw<300,28>n ih<300,25>z aa<300,28>n
dhah<300,25> siy<2400,23> ,<600> dhah<600,24> naa<600,25> ay<300,25>t
ih<300,32>z yxah<1200,30>nx ,<600> ae<600,28>nd sow<600,25>
aa<600,28>rx-wiy<4200,30> ,<600> driy<900,23>mz kah<300,22>m truw<1000,23>
uw<200,23> ,<600> ih<600,24>n
bluw<900,25> hxah<300,24> waa<940,23> aa<240,22> aa<240,21> iy<1200,20>
,<600> ae<600,32>nd maa<600,33> iy<300>n kuh<300,32>d ao<900,30>lx
kah<300,22>m truw<1200,25> ,<600> dhih<300,30> ih<300,31>s mae<900,32>
jhih<330,27>k naa<600,28> ay<350,28>t ah<350,27>v naa<600,28> ay<350,28>ts
,<40> wih<380,27>dh yuw<1000,28>-uw<600,455>-uw<1800,35>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:14'!
silentNightDuetExample
	"
	DECTalkReader silentNightDuetExample
	"

	| song1 song2 voice1 voice2 time |
	song1 _ DECTalkReader silentNightVoice1.
	song2 _ DECTalkReader silentNightVoice2.
	voice1 _ KlattVoice new tract: 14.4.
	voice2 _ KlattVoice new tract: 18.5; turbulence: 59.
	time _ Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:14'!
silentNightDuetExample2
	"
	DECTalkReader silentNightDuetExample2
	"

	| song1 song2 voice1 voice2 time |
	song1 _ DECTalkReader silentNightVoice1 pitchBy: 0.5.
	song2 _ DECTalkReader silentNightVoice2 pitchBy: 0.5.
	voice1 _ KlattVoice new tract: 14.4.
	voice2 _ KlattVoice new tract: 18.5; turbulence: 59.
	time _ Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:14'!
silentNightDuetExample3
	"
	DECTalkReader silentNightDuetExample3
	"

	| song1 song2 voice1 voice2 time |
	song1 _ DECTalkReader silentNightVoice1 pitchBy: 0.25.
	song2 _ DECTalkReader silentNightVoice2 pitchBy: 0.25.
	voice1 _ KlattVoice new tract: 18.5; turbulence: 59.
	voice2 _ KlattVoice new tract: 20; flutter: 0.5.
	time _ Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:18'!
silentNightDuetExample4
	"
	DECTalkReader silentNightDuetExample4
	"

	| song1 song2 voice1 voice2 gestural1 gestural2 time |
	song1 _ DECTalkReader silentNightVoice1 pitchBy: 0.5.
	song2 _ DECTalkReader silentNightVoice2 pitchBy: 0.5.
	gestural1 _ GesturalVoice new.
	gestural1 newHead position: 1 @ 50.
	voice1 _ (KlattVoice new tract: 14.4) + gestural1.
	gestural2 _ GesturalVoice new.
	gestural2 newHead position: 150 @ 50.
	voice2 _ (KlattVoice new tract: 18.5; turbulence: 59) + gestural2.
	time _ Time millisecondClockValue + 30000. "give it 30 secounds for precomputing"
	song1 playOn: voice1 at: time.
	song2 playOn: voice2 at: time! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 04:58'!
silentNightVoice1
	"
	(DECTalkReader silentNightVoice1 pitchBy: 0.5) playOn: KlattVoice new delayed: 1000
	"

	^ self eventsFromString: 'sae<600,32>ay<200,34>leh<400,32>nt nae<600,29>ay<400>t.
hxow<600,32>ow<200,34>liy<400,32> nae<600,29>ay<400>t.
ao<600,39>l ih<200>z kaa<800,36>lm.
ao<600,37>l ih<200>z bray<800,32>t.
raw<600,34>nd yah<400>ng ver<600,37>er<200,36>jhah<400,34>n
mah<600,32>dher<200,32> ae<400>nd chah<600,29>ay<200>ld.
hxow<800,34>liy<400> ih<600,37>nfah<200,36>nt
sow<400,34> teh<600,32>nder<400,34> ae<400,32>nd may<600,29>ld.
sliy<600,39>p ah<400>n hxeh<400,42>vah<400,39>nliy<400,36> piy<1000,37>iy<800,41>s.
sliy<400,37>iy<400,32>p ah<400,29>n hxeh<400,32>vah<400,30>nliy<600,27> piy<1800,25>s.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/24/1999 05:06'!
silentNightVoice2
	"
	(DECTalkReader silentNightVoice2 pitchBy: 0.5) playOn: KlattVoice new delayed: 1000
	"

	^ self eventsFromString: 'sae<600,29>ay<200,30>leh<400,29>nt nae<600,25>ay<400>t.
hxow<600,29>ow<200,30>liy<400,29> nae<600,25>ay<400>t.
ao<600,30>l ih<200>z kaa<800,27>lm.
ao<600,29>l ih<200>z bray<800,29>t.
raw<600,30>nd yah<400>ng ver<600,34>er<200,32>jhah<400,30>n
mah<600,29>dher<200,30> ae<400,29>nd chah<600,25>ay<200>ld.
hxow<800,30>liy<400> ih<600,34>nfah<200,32>nt
sow<400,30> teh<600,29>nder<400,30> ae<400,29>nd may<600,25>ld.
sliy<600,30>p ah<400>n hxeh<400,27>vah<400,30>nliy<400,27> piy<1000,29>iy<800,32>s.
sliy<400,29>iy<400,29>p ah<400,25>n hxeh<400,24>vah<400,24>nliy<600,24> piy<1800,25>s.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:52'!
startrek
	"
	DECTalkReader startrek playOn: KlattVoice new delayed: 15000
	"
	^ self eventsFromString: '_<50,17>dhey<400,17>rsklih<100,17>nxao<100,17>nzao<100,17>
ndhax<100,17>staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>
rbao<100,18>rdbaw<200,15>staa<100,17>rbao<100,17>rdbaw<200,13>.

dhey<100,17>rsklih<100,17>nxao<100,17>nzao<100,17>ndhax<100,17>
staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>rbao<100,18>
rdbaw<200,15>jhih<400,13>m<50,13>.

_<50,17>ih<400,17>tslay<100,17>fjhih<100,17>mbah<100,17>
tnao<50,20>tax<50,20>zwiy<100,20>now<100,17>ih<200,17>
tnao<50,18>tax<50,18>zwiy<100,18>now<100,15>ih<200,15>
tnao<50,17>tax<50,17>zwiy<100,17>now<100,13>ih<200,13>
t<50,13>.

ih<100,17>tslay<100,17>fjhih<100,17>mbah<100,17>tnao<50,20>
tax<50,20>zwiy<100,20>now<100,17>ih<200,17>tnao<50,18>
tax<50,18>zwiy<100,18>now<100,15>ih<200,15>tkae<200,13>
ptix<200,13>n<50,13>.

_<50,17>ih<400,17>tswah<100,17>rsdhae<100,17>ndhae<100,17>
t_hxiy<100,20>zdeh<200,20>djhih<200,17>mdeh<200,18>djhih<200,15>
mdeh<200,17>djhih<200,13>m<50,13>.

ih<100,17>tswah<100,17>rsdhae<100,17>ndhae<100,17>t_hxiy<100,20>
zdeh<200,20>djhih<200,17>mdeh<200,18>djhih<200,15>mdeh<400,13>
d<50,13>.

_<50,17>wiy<400,17>kah<100,17>mih<100,17>npiy<200,17>
sshuh<100,20>tuh<100,20>kih<200,17>lshuh<100,18>tuh<100,18>
kih<200,15>lshuh<100,17>tuh<100,17>kih<200,13>l<50,13>.

wiy<100,17>kah<100,17>mih<100,17>npiy<200,17>sshuh<100,20>
tuh<100,20>kih<200,17>lshuh<100,18>tuh<100,18>kih<200,15>
lmeh<400,13>n<50,13>.

_<50,17>yxih<400,17>kaa<100,17>naa<100,17>chey<100,17>
njhdhax<50,17>lao<50,20>zax<100,20>fih<100,17>zih<100,17>
kslao<50,18>zax<100,18>fih<100,15>zih<100,15>kslao<50,17>
zax<100,17>fih<100,13>zih<100,13>ks<50,13>.

yxih<400,17>kaa<100,17>naa<100,17>chey<100,17>njhdhax<50,17>
lao<50,20>zax<100,20>fih<100,17>zih<100,17>kslao<50,18>
zax<100,18>fih<100,15>zih<100,15>kskaa<200,13>ptix<200,13>
n<50,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:52'!
startrek1
	"
	DECTalkReader startrek1 playOn: KlattVoice new delayed: 5000
	"
	^ self eventsFromString: '_<50,17>dhey<400,17>rsklih<100,17>nxao<100,17>nzao<100,17>
ndhax<100,17>staa<100,20>rbao<100,20>rdbaw<200,17>staa<100,18>
rbao<100,18>rdbaw<200,15>staa<100,17>rbao<100,17>rdbaw<200,13>.'! !

!DECTalkReader class methodsFor: 'examples' stamp: 'len 12/20/1999 04:38'!
vermont
	"
	(DECTalkReader vermont pitchBy: 0.5) playOn: (KlattVoice new tract: 18.5; turbulence: 59) delayed: 15000
	"
	^ self eventsFromString: 'peh<400,25> niy<400,23>z ih<400,20>n ah<400,18> striy<1200,20>m
,<400> fao<400,25> lih<400,23>nx liy<500,20>vz ,<100> ah<200,16>v 
sih<200,18> kah<200,20> mao<1000,12>rx ,<200> muw<400,20>n lay<400,18>t
ih<400,16>n vrr<400,13> maa<1200,16>nt ,<400> ay<400,25> siy<400,23> 
fih<400,20>nx grr<400,18> wey<1200,20>vz ,<400> skiy<400,25> trae<300,23>lxz  
,<100> aa<600,20>n ah<200,16> maw<200,18>n tih<200,20>n 
saa<800,12>-ay<200,12>d ,<200> snow<400,20> lay<400,18>t
ih<400,16>n vrr<400,13> maa<1200,16>nt ,<400> teh<200,15> lah<200,15>
grae<200,15>f key<400,15> bah<300,15>lxz ,<100> dhey<200,15> sih<200,15>nx 
daw<400,15>n dhah<200,15> hxay<200,15> wey<300,15> ,<100> ae<200,15>nd
trae<200,15> vuh<200,15>lx iy<200,15>ch beh<500,27>nd,<100> ih<200,25>n 
dhah<200,27> row<1200,24>d ,<400> piy<200,16> pah<200,16>lx hxuw<200,16>
miy<200,16>t ,<200> 
ih<400,16>n-dhih<200,16>s-row<200,16>-mae<400,16>n-tih<160,16>k ,<40> 
seh<200,16> tih<300,16>nx ,<100> aa<200,16>rx sow<200,16>
hxih<200,16>p nah<200,16> tay<400,28>zd ,<200> bay<200,26> dhah<200,28>
lah<900,25>v liy<700,24> ,<200> iy<400,25>v nih<400,23>nx sah<400,20>
mrr<400,18> briy<1200,20>z ,<400> wao<400,25>rx blih<400,23>nx ah<400,20>v
,<200> ah<200,16> meh<200,18> dow<200,20> laa<800,12>rxk ,<400> muw<400,20>n
lay<400,18>t ih<400,16>n vrr<400,13> maa<1300,16>nt ,<400>
iy<40,12>-yuw<280,12> ae<350,13>n day<420,16> ,<60> ae<340,20>nd
muw<380,25>n lay<340,27>t ,<100> ih<500,24>n vrr<540,26> maa<2000,23>nt.'! !
HtmlFormatter subclass: #DHtmlFormatter
	instanceVariableNames: 'fontSpecs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Formatter'!
!DHtmlFormatter commentStamp: '<historical>' prior: 0!
an attempt to improve HtmlFormatter...
make it a bit more DOMish (eventually)

roadmap
-1-	support for font specs (color, size)
-2-	support for tabless!


!DHtmlFormatter methodsFor: 'private-formatting' stamp: 'bolot 5/18/2000 11:26'!
setAttributes
	"set attributes on the output stream"
	| attribs |
	attribs _ OrderedCollection new.
	indentLevel > 0 ifTrue: [ attribs add: (TextIndent tabs: indentLevel) ].
	boldLevel > 0 ifTrue: [ attribs add: TextEmphasis bold ].
	italicsLevel >  0 ifTrue: [ attribs add: TextEmphasis italic ].
	underlineLevel > 0 ifTrue: [ attribs add: TextEmphasis underlined ].
	strikeLevel > 0 ifTrue: [ attribs add: TextEmphasis struckOut ].
	urlLink isNil ifFalse: [ attribs add: (TextURL new url: urlLink) ].
	fontSpecs isEmptyOrNil
		ifFalse: [attribs addAll: fontSpecs last]
		ifTrue: [attribs add: (TextFontChange defaultFontChange)].
	outputStream currentAttributes: attribs! !


!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:55'!
decreaseFontBy: relSize
	self startFont: (TextFontChange fontNumber: ((self lastFontSize - relSize) min: 4))! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:23'!
endFont: aFont
	fontSpecs isEmptyOrNil
		ifFalse: [fontSpecs removeLast].
	self setAttributes! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 12:01'!
endHeader: level
	boldLevel _ boldLevel - 1. "self decreaseBold"
	self ensureNewlines: 2.
	self endFont: nil.! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 12:00'!
headerFont: level
	^{TextFontChange fontNumber: ((5 - level) max: 1)}! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:50'!
increaseFontBy: relSize
	self startFont: (TextFontChange fontNumber: ((self lastFontSize + relSize) min: 4))! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:55'!
lastFontSize
	| textAttrib |
	fontSpecs isEmptyOrNil ifTrue: [^1].

	fontSpecs reverseDo: [:specs |
		textAttrib _ specs detect: [:attrib | attrib isKindOf: TextFontChange] ifNone: [].
		textAttrib ifNotNil: [^textAttrib fontNumber]].

	^1 "default font size in Squeak (1) corresponds to HTML's default 4"! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:57'!
resetFont
	"probably need use document defaults"
	self startFont:
		{TextColor black.
		TextFontChange fontNumber: 1}! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 11:57'!
startFont: aTextAttribList
	"aTextAttribList is a collection of TextAttributes"
	fontSpecs ifNil: [fontSpecs _ OrderedCollection new].
	fontSpecs add: aTextAttribList.
	self setAttributes! !

!DHtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 12:00'!
startHeader: level
	self ensureNewlines: 3.
	boldLevel _ boldLevel + 1. "self increaseBold"
	self startFont: (self headerFont: level).! !
InterpreterPlugin subclass: #DSAPlugin
	instanceVariableNames: 'dsaRemainder dsaDivisor dsaQuotient remainderDigitCount divisorDigitCount '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!DSAPlugin commentStamp: '<historical>' prior: 0!
This plugin defines primitives that support the DigitalSignatureAlgorithm class. Three of these primitives support fast multiplication and division of very large integers, three others support the SecureHashAlgorithm.
!


!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'jm 12/21/1999 22:52'!
primitiveExpandBlock
	"Expand a 64 byte ByteArray (the first argument) into and an Bitmap of 80 32-bit words (the second argument). When reading a 32-bit integer from the ByteArray, consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	| expanded buf wordPtr bytePtr src v |
	self export: true.
	self var: #wordPtr declareC: 'unsigned int *wordPtr'.
	self var: #bytePtr declareC: 'unsigned char *bytePtr'.

	expanded _ interpreterProxy stackObjectValue: 0.
	buf _ interpreterProxy stackObjectValue: 1.
	interpreterProxy success: (interpreterProxy isWords: expanded).
	interpreterProxy success: (interpreterProxy isBytes: buf).
	interpreterProxy failed ifTrue: [^ nil].

	interpreterProxy success: ((interpreterProxy stSizeOf: expanded) = 80).
	interpreterProxy success: ((interpreterProxy stSizeOf: buf) = 64).
	interpreterProxy failed ifTrue: [^ nil].

	wordPtr _ interpreterProxy firstIndexableField: expanded.
	bytePtr _ interpreterProxy firstIndexableField: buf.

	src _ 0.
	0 to: 15 do: [:i |
		v _ ((bytePtr at: src) << 24) +
			((bytePtr at: src + 1) << 16) +
			((bytePtr at: src + 2) << 8) +
			(bytePtr at: src + 3).
		wordPtr at: i put: v.
		src _ src + 4].

	16 to: 79 do: [:i |
		v _ (((wordPtr at: i - 3) bitXor:
			 (wordPtr at: i - 8)) bitXor:
			 (wordPtr at: i - 14)) bitXor:
			 (wordPtr at: i - 16).
		v _ self leftRotate: v by: 1.
		wordPtr at: i put: v].

	interpreterProxy pop: 2.
! !

!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'jm 12/21/1999 20:43'!
primitiveHasSecureHashPrimitive
	"Answer true if the secure hash primitive is implemented."

	self export: true.
	interpreterProxy pop: 1.
	interpreterProxy pushBool: true.
! !

!DSAPlugin methodsFor: 'primitives-SHA' stamp: 'jm 12/21/1999 23:35'!
primitiveHashBlock
	"Hash a Bitmap of 80 32-bit words (the first argument), using the given state (the second argument)."

	| state buf statePtr bufPtr a b c d e tmp |
	self export: true.
	self var: #statePtr declareC: 'unsigned int *statePtr'.
	self var: #bufPtr declareC: 'unsigned int *bufPtr'.

	state _ interpreterProxy stackObjectValue: 0.
	buf _ interpreterProxy stackObjectValue: 1.
	interpreterProxy success: (interpreterProxy isWords: state).
	interpreterProxy success: (interpreterProxy isWords: buf).
	interpreterProxy failed ifTrue: [^ nil].

	interpreterProxy success: ((interpreterProxy stSizeOf: state) = 5).
	interpreterProxy success: ((interpreterProxy stSizeOf: buf) = 80).
	interpreterProxy failed ifTrue: [^ nil].

	statePtr _ interpreterProxy firstIndexableField: state.
	bufPtr _ interpreterProxy firstIndexableField: buf.

	a _ statePtr at: 0.
	b _ statePtr at: 1.
	c _ statePtr at: 2.
	d _ statePtr at: 3.
	e _ statePtr at: 4.
 
	0 to: 19 do: [:i |
		tmp _ 16r5A827999 + ((b bitAnd: c) bitOr: (b bitInvert32 bitAnd: d)) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e _ d.  d _ c.  c _ self leftRotate: b by: 30.  b _ a.  a _ tmp].

	20 to: 39 do: [:i |
		tmp _ 16r6ED9EBA1 + ((b bitXor: c) bitXor: d) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e _ d.  d _ c.  c _ self leftRotate: b by: 30.  b _ a.  a _ tmp].

	40 to: 59 do: [:i |
		tmp _ 16r8F1BBCDC + (((b bitAnd: c) bitOr: (b bitAnd: d)) bitOr: (c bitAnd: d)) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e _ d.  d _ c.  c _ self leftRotate: b by: 30.  b _ a.  a _ tmp].

	60 to: 79 do: [:i |
		tmp _ 16rCA62C1D6 + ((b bitXor: c) bitXor: d) +
				(self leftRotate: a by: 5) +  e + (bufPtr at: i).
		e _ d.  d _ c.  c _ self leftRotate: b by: 30.  b _ a.  a _ tmp].

	statePtr at: 0 put: (statePtr at: 0) + a.
	statePtr at: 1 put: (statePtr at: 1) + b.
	statePtr at: 2 put: (statePtr at: 2) + c.
	statePtr at: 3 put: (statePtr at: 3) + d.
	statePtr at: 4 put: (statePtr at: 4) + e.

	interpreterProxy pop: 2.
! !


!DSAPlugin methodsFor: 'primitives-integers' stamp: 'jm 12/21/1999 18:48'!
primitiveBigDivide
	"Called with three LargePositiveInteger arguments, rem, div, quo. Divide div into rem and store the quotient into quo, leaving the remainder in rem."
	"Assume: quo starts out filled with zeros."

	| rem div quo |
	self export: true.
	quo _ interpreterProxy stackObjectValue: 0.
	div _ interpreterProxy stackObjectValue: 1.
	rem _ interpreterProxy stackObjectValue: 2.

	interpreterProxy success:
		(interpreterProxy fetchClassOf: rem) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: div) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: quo) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue:[^ nil].

	dsaRemainder _ interpreterProxy firstIndexableField: rem.
	dsaDivisor _ interpreterProxy firstIndexableField: div.
	dsaQuotient _ interpreterProxy firstIndexableField: quo.

	divisorDigitCount _ interpreterProxy stSizeOf: div.
	remainderDigitCount _ interpreterProxy stSizeOf: rem.

	"adjust pointers for base-1 indexing"
	dsaRemainder _ dsaRemainder - 1.
	dsaDivisor _ dsaDivisor - 1.
	dsaQuotient _ dsaQuotient - 1.

	self bigDivideLoop.
	interpreterProxy pop: 3.
! !

!DSAPlugin methodsFor: 'primitives-integers' stamp: 'jm 12/21/1999 08:09'!
primitiveBigMultiply
	"Multiple f1 by f2, placing the result into prod. f1, f2, and prod must be LargePositiveIntegers, and the length of prod must be the sum of the lengths of f1 and f2."
	"Assume: prod starts out filled with zeros"

	| prod f2 f1 prodLen f1Len f2Len prodPtr f2Ptr f1Ptr digit carry k sum |
	self export: true.
	self var: #prodPtr declareC: 'unsigned char *prodPtr'.
	self var: #f2Ptr declareC: 'unsigned char *f2Ptr'.
	self var: #f1Ptr declareC: 'unsigned char *f1Ptr'.

	prod _ interpreterProxy stackObjectValue: 0.
	f2 _ interpreterProxy stackObjectValue: 1.
	f1 _ interpreterProxy stackObjectValue: 2.
	interpreterProxy success: (interpreterProxy isBytes: prod).
	interpreterProxy success: (interpreterProxy isBytes: f2).
	interpreterProxy success: (interpreterProxy isBytes: f1).
	interpreterProxy success:
		(interpreterProxy fetchClassOf: prod) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: f2) = interpreterProxy classLargePositiveInteger.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: f1) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue:[^ nil].

	prodLen _ interpreterProxy stSizeOf: prod.
	f1Len _ interpreterProxy stSizeOf: f1.
	f2Len _ interpreterProxy stSizeOf: f2.
	interpreterProxy success: (prodLen = (f1Len + f2Len)).
	interpreterProxy failed ifTrue:[^ nil].

	prodPtr _ interpreterProxy firstIndexableField: prod.
	f2Ptr _ interpreterProxy firstIndexableField: f2.
	f1Ptr _ interpreterProxy firstIndexableField: f1.

	0 to: f1Len-1 do: [:i | 
		(digit _ f1Ptr at: i) ~= 0 ifTrue: [
			carry _ 0.
			k _ i.
			"Loop invariants: 0 <= carry <= 16rFF, k = i + j - 1"
			0 to: f2Len-1 do: [:j | 
				sum _ ((f2Ptr at: j) * digit) + (prodPtr at: k) + carry.
				carry _ sum bitShift: -8.
				prodPtr at: k put: (sum bitAnd: 255).
				k _ k + 1].
			prodPtr at: k put: carry]].

	interpreterProxy pop: 3.
! !

!DSAPlugin methodsFor: 'primitives-integers' stamp: 'jm 12/21/1999 09:31'!
primitiveHighestNonZeroDigitIndex
	"Called with one LargePositiveInteger argument. Answer the index of the top-most non-zero digit."

	| arg bigIntPtr i |
	self export: true.
	self var: #bigIntPtr declareC: 'unsigned char *bigIntPtr'.

	arg _ interpreterProxy stackObjectValue: 0.
	interpreterProxy success:
		(interpreterProxy fetchClassOf: arg) = interpreterProxy classLargePositiveInteger.
	interpreterProxy failed ifTrue: [^ nil].

	bigIntPtr _ interpreterProxy firstIndexableField: arg.
	i _ interpreterProxy stSizeOf: arg.
	[(i > 0) and: [(bigIntPtr at: (i _ i - 1)) = 0]]
		whileTrue: ["scan down from end to first non-zero digit"].

	interpreterProxy pop: 1.
	interpreterProxy pushInteger: i + 1.
! !


!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 08:10'!
addBackDivisorDigitShift: digitShift
	"Add back the divisor shifted left by the given number of digits. This is done only when the estimate of quotient digit was one larger than the correct value."

	| carry rIndex sum |
	carry _ 0.
	rIndex _ digitShift + 1.
	1 to: divisorDigitCount do: [:i |
		sum _ (dsaRemainder at: rIndex) + (dsaDivisor at: i) + carry.
		dsaRemainder at: rIndex put: (sum bitAnd: 16rFF).
		carry _ sum bitShift: -8.
		rIndex _ rIndex + 1].

	"do final carry"
	sum _ (dsaRemainder at: rIndex) + carry.
	dsaRemainder at: rIndex put: (sum bitAnd: 16rFF).

	"Note: There should be a final carry that cancels out the excess borrow."
	"Assert: (sum bitShift: -8) ~= 1 ifTrue: [self halt: 'no carry!!']."
! !

!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 18:48'!
bigDivideLoop
	"This is the core of the divide algorithm. This loop steps through the digit positions of the quotient, each time estimating the right quotient digit, subtracting from the remainder the divisor times the quotient digit shifted left by the appropriate number of digits. When the loop terminates, all digits of the quotient have been filled in and the remainder contains a value less than the divisor. The tricky bit is estimating the next quotient digit. Knuth shows that the digit estimate computed here will never be less than it should be and cannot be more than one over what it should be. Furthermore, the case where the estimate is one too large is extremely rare. For example, in a typical test of 100000 random 60-bit division problems, the rare case only occured five times. See Knuth, volume 2 ('Semi-Numerical Algorithms') 2nd edition, pp. 257-260"

	| d1 d2 firstDigit firstTwoDigits thirdDigit q digitShift qTooBig |
	"extract the top two digits of the divisor"
	d1 _ dsaDivisor at: divisorDigitCount.
	d2 _ dsaDivisor at: divisorDigitCount - 1.

	remainderDigitCount to: divisorDigitCount + 1 by: -1 do: [:j |
		"extract the top several digits of remainder."
		firstDigit _ dsaRemainder at: j.
		firstTwoDigits _ (firstDigit bitShift: 8) + (dsaRemainder at: j - 1).
		thirdDigit _ dsaRemainder at: j - 2.

		"estimate q, the next digit of the quotient"
		firstDigit = d1
			ifTrue: [q _ 255]
			ifFalse: [q _ firstTwoDigits // d1].

		"adjust the estimate of q if necessary"
		(d2 * q) > (((firstTwoDigits - (q * d1)) bitShift: 8) + thirdDigit) ifTrue: [	
			q _ q - 1.
			(d2 * q) > (((firstTwoDigits - (q * d1)) bitShift: 8) + thirdDigit) ifTrue: [
				q _ q - 1]].

		digitShift _ j - divisorDigitCount - 1.
		q > 0 ifTrue: [
			qTooBig _ self subtractDivisorMultipliedByDigit: q digitShift: digitShift.
			qTooBig ifTrue: [  "this case is extremely rare"
				self addBackDivisorDigitShift: digitShift.
				q _ q - 1]].

		"record this digit of the quotient"
		dsaQuotient at: digitShift + 1 put: q].
! !

!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 21:54'!
leftRotate: anInteger by: bits
	"Rotate the given 32-bit integer left by the given number of bits and answer the result."

	self var: #anInteger declareC: 'unsigned int anInteger'.
	^ (anInteger << bits) bitOr: (anInteger >> (32 - bits))
! !

!DSAPlugin methodsFor: 'private' stamp: 'jm 12/21/1999 08:13'!
subtractDivisorMultipliedByDigit: digit digitShift: digitShift
	"Multiply the divisor by the given digit (an integer in the range 0..255), shift it left by the given number of digits, and subtract the result from the current remainder. Answer true if there is an excess borrow, indicating that digit was one too large. (This case is quite rare.)"

	| borrow rIndex prod resultDigit |
	borrow _ 0.
	rIndex _ digitShift + 1.
	1 to: divisorDigitCount do: [:i |
		prod _ ((dsaDivisor at: i) * digit) + borrow.
		borrow _ prod bitShift: -8.
		resultDigit _ (dsaRemainder at: rIndex) - (prod bitAnd: 16rFF).
		resultDigit < 0 ifTrue: [  "borrow from the next digit"
			resultDigit _ resultDigit + 256.
			borrow _ borrow + 1].
		dsaRemainder at: rIndex put: resultDigit.
		rIndex _ rIndex + 1].

	"propagate the final borrow if necessary"
	borrow = 0 ifTrue: [^ false].
	resultDigit _ (dsaRemainder at: rIndex) - borrow.
	resultDigit < 0
		ifTrue: [  "digit was too large (this case is quite rare)"
			dsaRemainder at: rIndex put: resultDigit + 256.
			^ true]
		ifFalse: [
			dsaRemainder at: rIndex put: resultDigit.
			^ false].
! !

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

DSAPlugin class
	instanceVariableNames: ''!

!DSAPlugin class methodsFor: 'plugin translation' stamp: 'sma 3/3/2000 12:44'!
declareCVarsIn: cg
	cg var: #dsaRemainder type: #'unsigned char*'.
	cg var: #dsaDivisor type:  #'unsigned char*'.
	cg var: #dsaQuotient type: #'unsigned char*'! !

!DSAPlugin class methodsFor: 'plugin translation' stamp: 'ar 5/15/2000 22:51'!
moduleName
	"Time millisecondsToRun: [
		DSAPlugin translateDoInlining: true]"

	^ 'DSAPrims' "Yes - it needs to be named this way or else we'll not find it"
! !
PostscriptCanvas subclass: #DSCPostscriptCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!DSCPostscriptCanvas commentStamp: '<historical>' prior: 0!
I generate multi-page Postscript files, for example of Book morphs.  The goal is to crete Adobe Document Structuring Conventions compliant, but this is currently not the case.
!


!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'mpw 9/15/1999 20:14'!
defaultImageableArea
	^ self defaultPageSize insetBy:self defaultMargin.
! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'di 8/3/2000 14:18'!
defaultMargin  "In Points"
	^ (0.25 * 72) asInteger.
! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'di 8/5/2000 22:56'!
defaultPageSize
	" This is Letter size in points.  European A4 is 595 @ 842 "
	^ 0 @ 0 extent: ((8.5 @ 11.0) * 72) asIntegerPoint.
! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 17:43'!
fullDraw: aMorph

	super fullDraw: aMorph.
	(morphLevel = 0 and: [aMorph pagesHandledAutomatically not]) ifTrue: [
		target showpage.
	].! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'mpw 9/12/1999 21:53'!
fullDrawBookMorph:aBookMorph
	" draw all the pages in a book morph, but only if it is the top-level morph "

	morphLevel == 1 ifTrue:[
		self drawPages:aBookMorph pages.
	] ifFalse:[
		^super fullDrawBookMorph:aBookMorph.
	].
	target print:'%%EOF'; cr.
! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 12:23'!
pageBBox

	| pageSize offset bbox trueExtent |

	EPSCanvas bobsPostScriptHacks ifTrue: [
		trueExtent _ savedMorphExtent	"this one has been rotated"
	] ifFalse: [
		trueExtent _ psBounds extent
	].
	pageSize _ self defaultImageableArea.
	offset _ ((pageSize extent - trueExtent) / 2 max: 0@0) + self defaultMargin.
	bbox _ offset extent: psBounds extent.

	^bbox! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 11:51'!
pageOffset
	|  offset  |

	EPSCanvas bobsPostScriptHacks ifTrue: [^0@0].		"seems like we were adding it twice"

	offset _ self pageBBox origin.
	^ (offset x @ offset y).! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 18:08'!
setupGStateForMorph: aMorph
	" position the morph on the page  "

	morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue:[ 
		target print: '% pageOffset'; cr.
		target translate: self pageOffset.
		self writeSetupForRect: aMorph bounds.
		target print: '% negate morph offset';cr.
		target translate: aMorph bounds origin negated.
	].
! !

!DSCPostscriptCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 16:01'!
writePSIdentifierRotated: rotateFlag
	| morphExtent pageExtent scaledBox |

	target	print:'%!!PS-Adobe-2.0'; cr; 
			print:'%%Pages: (atend)'; cr.

	"Define initialScale so that the morph will fit the page rotated or not"
	savedMorphExtent _ morphExtent _ rotateFlag ifTrue: [psBounds extent transposed]
							ifFalse: [psBounds extent].

	pageExtent _ self defaultImageableArea extent asFloatPoint.
	initialScale _ pageExtent x/morphExtent x min: pageExtent y/morphExtent y.
	target print:'% initialScale: '; write:initialScale; cr.
	scaledBox _ self pageBBox rounded.
	target print: '%%BoundingBox: '; write: scaledBox rounded; cr.
	rotateFlag ifTrue: [
		target
			print: '90 rotate'; cr;
			write: self defaultMargin * initialScale;
			space;
			write: (self defaultMargin + scaledBox height * initialScale) negated;
			print: ' translate'; cr
	] ifFalse: [
		target
			write: self defaultMargin * initialScale;
			space;
			write: (self defaultMargin * initialScale);
			print: ' translate'; cr
	].
	target print: '%%EndComments'; cr.

! !
DSCPostscriptCanvas subclass: #DSCPostscriptCanvasToDisk
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!

!DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 16:19'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset

	self reset.
	psBounds _ offset extent: aMorph bounds extent.
	topLevelMorph _ aMorph.
	self writeHeaderRotated: rotateFlag.
	self fullDrawMorph: aMorph.

	^self close

! !

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

DSCPostscriptCanvasToDisk class
	instanceVariableNames: ''!

!DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 22:14'!
defaultTarget

	^PostscriptEncoderToDisk stream.
! !

!DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 09:30'!
morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset

	| newFileName stream |

	^[
		(self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close
	]
		on: PickAFileToWriteNotification
		do: [ :ex |
			newFileName _ FillInTheBlank
				request: 'Name of file to write:' 
				initialAnswer: 'xxx',Time millisecondClockValue printString,'.eps'. 
			newFileName isEmptyOrNil ifFalse: [
				stream _ FileStream fileNamed: newFileName.
				stream ifNotNil: [ex resume: stream].
			].
		].

! !
Object subclass: #DamageRecorder
	instanceVariableNames: 'invalidRects totalRepaint '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'!
reset
	"Clear the damage list."

	invalidRects _ OrderedCollection new: 15.
	totalRepaint _ false
! !


!DamageRecorder methodsFor: 'recording'!
doFullRepaint
	"Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."

	^ totalRepaint _ true.
! !

!DamageRecorder methodsFor: 'recording'!
invalidRectsFullBounds: aRectangle
	"Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle."

	totalRepaint
		ifTrue: [^ Array with: aRectangle]
		ifFalse: [^ invalidRects copy].

! !

!DamageRecorder methodsFor: 'recording' stamp: 'tk 9/25/2000 23:06'!
recordInvalidRect: aRectangle
	"Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle."
	"Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle."

	| mergeRect |
	totalRepaint ifTrue: [^ self].  "planning full repaint; don't bother collecting damage"

	invalidRects do: [:rect |
		(rect intersects: aRectangle) ifTrue: [
			"merge rectangle in place (see note below) if there is any overlap"
			rect setOrigin: (rect origin min: aRectangle origin) truncated
				corner: (rect corner max: aRectangle corner) truncated.
			^ self]].


	invalidRects size >= 15 ifTrue: [
		"if there are too many separate areas, just repaint all"
		"totalRepaint _ true."
"Note:  The totalRepaint policy has poor behavior when many local rectangles (such as parts of a text selection) force repaint of the entire screen.  As an alternative, this code performs a simple merge of all rects whenever there are more than 10."
		mergeRect _ Rectangle merging: invalidRects.
		self reset.
		invalidRects addLast: mergeRect].

	"add the given rectangle to the damage list"
	"Note: We make a deep copy of all rectangles added to the damage list,
	 since rectangles in this list may be extended in place."
	invalidRects addLast: (aRectangle topLeft truncated corner: aRectangle bottomRight truncated).
! !


!DamageRecorder methodsFor: 'testing'!
updateIsNeeded
	"Return true if the display needs to be updated."

	^ totalRepaint or: [invalidRects size > 0]
! !

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

DamageRecorder class
	instanceVariableNames: ''!

!DamageRecorder class methodsFor: 'instance creation'!
new

	^ super new reset
! !
Stream subclass: #DataStream
	instanceVariableNames: 'byteStream topCall basePos '
	classVariableNames: 'TypeMap '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DataStream commentStamp: '<historical>' prior: 0!
This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form.

To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream.  (Or SmartRefStream.)  ReferenceStream is typically
faster and produces smaller files because it doesn't repeatedly write the same Symbols.

Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	<your object> _ rr next.
	rr close.

Each object to be stored has two opportunities to control what gets stored.  On the high level, objectToStoreOnDataStream allows you to substitute another object on the way out.  The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload and (class) readDataFrom:size:. See these methods, and the class DiskProxy, for more information about externalizing and internalizing.

NOTE: A DataStream should be treated as a write-stream for writing.  It is a read-stream for reading.  It is not a ReadWriteStream.
!


!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:14 tk'!
beginInstance: aClass size: anInteger
	"This is for use by storeDataOn: methods.
	 Cf. Object>>storeDataOn:."

		"Addition of 1 seems to make extra work, since readInstance
		has to compensate.  Here for historical reasons dating back
		to Kent Beck's original implementation in late 1988.

		In ReferenceStream, class is just 5 bytes for shared symbol.

		SmartRefStream puts out the names and number of class's instances variables for checking."

	byteStream nextNumber: 4 put: anInteger + 1.

	self nextPut: aClass name! !

!DataStream methodsFor: 'write and read'!
beginReference: anObject
    "WeÕre starting to read anObject. Remember it and its reference
     position (if we care; ReferenceStream cares). Answer the
     reference position."

    ^ 0! !

!DataStream methodsFor: 'write and read'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.
     Overridden by ReferenceStream."

    ^ 0! !

!DataStream methodsFor: 'write and read' stamp: 'tk 4/8/1999 13:11'!
maybeBeginReference: internalObject
	"Do nothing.  See ReferenceStream|maybeBeginReference:"

	^ internalObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 10/4/2000 10:33'!
next
	"Answer the next object in the stream."
	| type selector anObject isARefType pos internalObject |

	type _ byteStream next.
	type ifNil: [pos _ byteStream position.	"absolute!!!!"
		byteStream close.	"clean up"
		byteStream position = 0 
			ifTrue: [self error: 'The file did not exist in this directory'] 
			ifFalse: [self error: 'Unexpected end of object file'].
		pos.	"so can see it in debugger"
		^ nil].
	type = 0 ifTrue: [pos _ byteStream position.	"absolute!!!!"
		byteStream close.	"clean up"
		self error: 'Expected start of object, but found 0'.
		^ nil].
	isARefType _ self noteCurrentReference: type.
	selector _ #(readNil readTrue readFalse readInteger	"<-4"
			readStringOld readSymbol readByteArray		"<-7"
			readArray readInstance readReference readBitmap	"<-11"
			readClass readUser readFloat readRectangle readShortInst 	"<-16"
			readString readWordArray readWordArrayForSegment 	"<-19"
			readWordLike readMethod "<-21") at: type.
	selector == 0 ifTrue: [pos _ byteStream position.	"absolute!!!!"
			byteStream close. 
			self error: 'file is more recent than this system'. ^ nil].
	anObject _ self perform: selector. "A method that recursively
		calls next (readArray, readInstance, objectAt:) must save &
		restore the current reference position."
	isARefType ifTrue: [self beginReference: anObject].

		"After reading the externalObject, internalize it.
		 #readReference is a special case. Either:
		   (1) We actually have to read the object, recursively calling
			   next, which internalizes the object.
		   (2) We just read a reference to an object already read and
			   thus already interalized.
		 Either way, we must not re-internalize the object here."
	selector == #readReference ifTrue: [^ anObject].
	internalObject _ anObject comeFullyUpOnReload: self.
	^ self maybeBeginReference: internalObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 10/4/2000 10:35'!
nextPut: anObject
	"Write anObject to the receiver stream. Answer anObject."
	| typeID selector objectToStore |

	typeID _ self typeIDFor: anObject.
	(self tryToPutReference: anObject typeID: typeID)
		ifTrue: [^ anObject].

	objectToStore _ (self objectIfBlocked: anObject) objectForDataStream: self.
	objectToStore == anObject ifFalse: [typeID _ self typeIDFor: objectToStore].

	byteStream nextPut: typeID.
	selector _ #(writeNil: writeTrue: writeFalse: writeInteger: 
		writeStringOld: writeSymbol: writeByteArray:
		writeArray: writeInstance: errorWriteReference: writeBitmap:
		writeClass: writeUser: writeFloat: writeRectangle: == "<-16 short inst" 
		writeString: writeBitmap: writeBitmap: writeWordLike: 
		writeInstance: "CompiledMethod") at: typeID.
	self perform: selector with: objectToStore.

	^ anObject


"NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectForDataStream:) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form
 but not add to 'references'. Putting that object again should just put its
 external form again. That's more compact and avoids seeks when reading.
 But we just do the simple thing here, allowing backward-references for
 non-reference types like nil. So objectAt: has to compensate. Objects that
 externalize nicely won't contain the likes of ViewStates, so this shouldn't
 hurt much.
	 writeReference: -> errorWriteReference:."! !

!DataStream methodsFor: 'write and read'!
nextPutAll: aCollection
    "Write each of the objects in aCollection to the
     receiver stream. Answer aCollection."

    ^ aCollection do: [:each | self nextPut: each]! !

!DataStream methodsFor: 'write and read'!
noteCurrentReference: typeID
    "PRIVATE -- If we support references for type typeID, remember
     the current byteStream position so we can add the next object to
     the ÔobjectsÕ dictionary, and return true. Else return false.
     This method is here to be overridden by ReferenceStream"

    ^ false! !

!DataStream methodsFor: 'write and read' stamp: ' 
	6/9/97'!
objectAt: anInteger
	"PRIVATE -- Read & return the object at a given stream position.  08:18 tk  anInteger is a relative file position. "
	| savedPosn anObject refPosn |

	savedPosn _ byteStream position.	"absolute"
	refPosn _ self getCurrentReference.	"relative position"

	byteStream position: anInteger + basePos.	"was relative"
	anObject _ self next.

	self setCurrentReference: refPosn.	"relative position"
	byteStream position: savedPosn.		"absolute"
	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/13/98 22:16'!
objectIfBlocked: anObject
	"We don't do any blocking"

	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:46 tk'!
outputReference: referencePosn
	"PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn."

	byteStream nextPut: 10. "reference typeID"
	byteStream nextNumber: 4 put: referencePosn	"relative position"! !

!DataStream methodsFor: 'write and read' stamp: '6/9/97 08:32 tk'!
readArray
	"PRIVATE -- Read the contents of an Array.
	 We must do beginReference: here after instantiating the Array
	 but before reading its contents, in case the contents reference
	 the Array. beginReference: will be sent again when we return to
	 next, but that's ok as long as we save and restore the current
	 reference position over recursive calls to next."
	| count array refPosn |

	count _ byteStream nextNumber: 4.

	refPosn _ self beginReference: (array _ Array new: count).		"relative pos"
	1 to: count do: [:i |
		array at: i put: self next].
	self setCurrentReference: refPosn.		"relative pos"
	^ array! !

!DataStream methodsFor: 'write and read'!
readBitmap
	"PRIVATE -- Read the contents of a Bitmap."

	^ Bitmap newFromStream: byteStream
	"Note that the reader knows that the size is in long words, but the data is in bytes."! !

!DataStream methodsFor: 'write and read'!
readBoolean
	"PRIVATE -- Read the contents of a Boolean.
	 This is here only for compatibility with old data files."

	^ byteStream next ~= 0! !

!DataStream methodsFor: 'write and read' stamp: 'jm 8/19/1998 17:00'!
readByteArray
	"PRIVATE -- Read the contents of a ByteArray."

	| count |
	count _ byteStream nextNumber: 4.
	^ byteStream next: count  "assume stream is in binary mode"
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:29'!
readClass
	"Should never be executed because a DiskProxy, not a clas comes in."

	^ self error: 'Classes should be filed in'! !

!DataStream methodsFor: 'write and read'!
readFalse
    "PRIVATE -- Read the contents of a False."

    ^ false! !

!DataStream methodsFor: 'write and read'!
readFloat
	"PRIVATE -- Read the contents of a Float.
	 This is the fast way to read a Float.
	 We support 8-byte Floats here.  Non-IEEE"

	| new |
	new _ Float new: 2.		"To get an instance"
	new at: 1 put: (byteStream nextNumber: 4).
	new at: 2 put: (byteStream nextNumber: 4).
	^ new! !

!DataStream methodsFor: 'write and read'!
readFloatString
	"PRIVATE -- Read the contents of a Float string.
	 This is the slow way to read a Float--via its string repÕn.
	 It's here for compatibility with old data files."

	^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'!
readInstance
	"PRIVATE -- Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize aSymbol refPosn anObject newClass |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	aSymbol _ self next.
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass isVariable 	"Create object here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].
	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	anObject _ anObject readDataFrom: self size: instSize.
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject! !

!DataStream methodsFor: 'write and read'!
readInteger
    "PRIVATE -- Read the contents of a SmallInteger."

    ^ byteStream nextInt32	"signed!!!!!!"! !

!DataStream methodsFor: 'write and read' stamp: 'tk 10/6/2000 14:36'!
readMethod
	"PRIVATE -- Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize refPosn newClass className xxHeader nLits byteCodeSizePlusTrailer newMethod lits |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	className _ self next.
	newClass _ Smalltalk at: className asSymbol.

	xxHeader _ self next.
		"nArgs _ (xxHeader >> 24) bitAnd: 16rF."
		"nTemps _ (xxHeader >> 18) bitAnd: 16r3F."
		"largeBit _ (xxHeader >> 17) bitAnd: 1."
	nLits _ (xxHeader >> 9) bitAnd: 16rFF.
		"primBits _ ((xxHeader >> 19) bitAnd: 16r600) + (xxHeader bitAnd: 16r1FF)."
	byteCodeSizePlusTrailer _ instSize - (newClass instSize "0") - (nLits + 1 * 4).

	newMethod _ newClass 
		newMethod: byteCodeSizePlusTrailer
		header: xxHeader.

	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	self beginReference: newMethod.
	lits _ newMethod numLiterals + 1.	"counting header"
	2 to: lits do:
		[:ii | newMethod objectAt: ii put: self next].
	lits*4+1 to: newMethod basicSize do:
		[:ii | newMethod basicAt: ii put: byteStream next].
			"Get raw bytes directly from the file"
	self setCurrentReference: refPosn.  "before returning to next"
	^ newMethod! !

!DataStream methodsFor: 'write and read'!
readNil
    "PRIVATE -- Read the contents of an UndefinedObject."

    ^ nil! !

!DataStream methodsFor: 'write and read' stamp: ' 6/9/97'!
readRectangle
    "Read a compact Rectangle.  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  They will not come here.  17:22 tk"

	"Encoding is four 12-bit signed numbers.  48 bits in next 6 bytes.  17:24 tk"
	| acc left top right bottom |
	acc _ byteStream nextNumber: 3.
	left _ acc bitShift: -12.
	(left bitAnd: 16r800) ~= 0 ifTrue: [left _ left - 16r1000].	"sign"
	top _ acc bitAnd: 16rFFF.
	(top bitAnd: 16r800) ~= 0 ifTrue: [top _ top - 16r1000].	"sign"

	acc _ byteStream nextNumber: 3.
	right _ acc bitShift: -12.
	(right bitAnd: 16r800) ~= 0 ifTrue: [right _ right - 16r1000].	"sign"
	bottom _ acc bitAnd: 16rFFF.
	(bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom _ bottom - 16r1000].	"sign"
	
    ^ Rectangle left: left right: right top: top bottom: bottom
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/5/2000 11:47'!
readReference
	"Read the contents of an object reference. (Cf. outputReference:)  File is not now positioned at this object."
	| referencePosition |

	^ (referencePosition _ (byteStream nextNumber: 4)) = self vacantRef	"relative"
		ifTrue:  [nil]
		ifFalse: [self objectAt: referencePosition]		"relative pos"! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/8/97'!
readShortInst
	"Read the contents of an arbitrary instance that has a short header.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
	Let the instance, not the class read the data.  "
	| instSize aSymbol refPosn anObject newClass |

	instSize _ (byteStream next) - 1.	"one byte of size"
	refPosn _ self getCurrentReference.
	aSymbol _ self readShortRef.	"class symbol in two bytes of file pos"
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass isVariable 	"Create object here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].
	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	anObject _ anObject readDataFrom: self size: instSize.
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject! !

!DataStream methodsFor: 'write and read' stamp: 'tk 7/12/1998 13:32'!
readShortRef
	"Read an object reference from two bytes only.  Original object must be in first 65536 bytes of the file.  Relative to start of data.  vacantRef not a possibility."

	^ self objectAt: (byteStream nextNumber: 2)! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:03'!
readString

	| str |
	byteStream ascii.
	str _ byteStream nextString.
	byteStream binary.
	^ str
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:27'!
readStringOld

   ^ byteStream nextStringOld! !

!DataStream methodsFor: 'write and read'!
readSymbol
    "PRIVATE -- Read the contents of a Symbol."

    ^ self readString asSymbol! !

!DataStream methodsFor: 'write and read'!
readTrue
    "PRIVATE -- Read the contents of a True."

    ^ true! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/4/1999 22:58'!
readUser
	"Reconstruct both the private class and the instance.  Still used??"

	^ self readInstance.		"Will create new unique class"
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:20'!
readWordArray
	"PRIVATE -- Read the contents of a WordArray."

	^ WordArray newFromStream: byteStream
	"Size is number of long words."! !

!DataStream methodsFor: 'write and read' stamp: 'tk 1/24/2000 23:23'!
readWordArrayForSegment
	"Read the contents of a WordArray ignoring endianness."

	^ WordArrayForSegment newFromStream: byteStream
	"Size is number of long words."! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/3/2000 21:11'!
readWordLike
	| refPosn aSymbol newClass anObject |
	"Can be used by any class that is bits and not bytes (WordArray, Bitmap, SoundBuffer, etc)."

	refPosn _ self getCurrentReference.
	aSymbol _ self next.
	newClass _ Smalltalk at: aSymbol asSymbol.
	anObject _ newClass newFromStream: byteStream.
	"Size is number of long words."
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject
! !

!DataStream methodsFor: 'write and read' stamp: 'tk 9/24/2000 15:39'!
replace: original with: proxy
	"We may wish to remember that in some field, the original object is being replaced by the proxy.  For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced."

	"do nothing"! !

!DataStream methodsFor: 'write and read'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.
     Noop here. Cf. ReferenceStream."! !

!DataStream methodsFor: 'write and read'!
tryToPutReference: anObject typeID: typeID
    "PRIVATE -- If we support references for type typeID, and if
       anObject already appears in my output stream, then put a
       reference to the place where anObject already appears. If we
       support references for typeID but didnÕt already put anObject,
       then associate the current stream position with anObject in
       case one wants to nextPut: it again.
     Return true after putting a reference; false if the object still
       needs to be put.
     For DataStream this is trivial. ReferenceStream overrides this."

    ^ false! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/20/1999 23:02'!
typeIDFor: anObject
	"Return the typeID for anObject's class.  This is where the tangle of objects is clipped to stop everything from going out.  
	Classes can control their instance variables by defining objectToStoreOnDataStream.
	Any object in blockers is not written out.  See ReferenceStream.objectIfBlocked: and DataStream nextPut:.
	Morphs do not write their owners.  See Morph.storeDataOn:   Each morph tells itself to 'prepareToBeSaved' before writing out."
	
	^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"]	
"See DataStream initialize.  nil=1. true=2. false=3. a SmallInteger=4. (a String was 5). a Symbol=6.  a ByteArray=7. an Array=8. other = 9.  a Bitmap=11. a Metaclass=12. a Float=14.  a Rectangle=15. any instance that can have a short header=16.  a String=17 (new format). a WordArray=18."! !

!DataStream methodsFor: 'write and read'!
writeArray: anArray
	"PRIVATE -- Write the contents of an Array."

	byteStream nextNumber: 4 put: anArray size.
	self nextPutAll: anArray.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:07'!
writeBitmap: aBitmap
	"PRIVATE -- Write the contents of a Bitmap."

	aBitmap writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words."! !

!DataStream methodsFor: 'write and read'!
writeBoolean: aBoolean
    "PRIVATE -- Write the contents of a Boolean.
     This method is now obsolete."

    byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:06'!
writeByteArray: aByteArray
	"PRIVATE -- Write the contents of a ByteArray."

	byteStream nextNumber: 4 put: aByteArray size.
	"May have to convert types here..."
	byteStream nextPutAll: aByteArray.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 3/24/98 10:27'!
writeClass: aClass
	"Write out a DiskProxy for the class.  It will look up the class's name in Smalltalk in the new sustem.  Never write classes or methodDictionaries as objects.  For novel classes, front part of file is a fileIn of the new class."

	"This method never executed because objectToStoreOnDataStream returns a DiskProxy.  See DataStream.nextPut:"
    ^ self error: 'Write a DiskProxy instead'! !

!DataStream methodsFor: 'write and read'!
writeFalse: aFalse
    "PRIVATE -- Write the contents of a False."! !

!DataStream methodsFor: 'write and read'!
writeFloat: aFloat
	"PRIVATE -- Write the contents of a Float.
	  We support 8-byte Floats here."

	byteStream nextNumber: 4 put: (aFloat at: 1).
	byteStream nextNumber: 4 put: (aFloat at: 2).
! !

!DataStream methodsFor: 'write and read'!
writeFloatString: aFloat
    "PRIVATE -- Write the contents of a Float string.
     This is the slow way to write a Float--via its string repÕn."

    self writeByteArray: (aFloat printString)! !

!DataStream methodsFor: 'write and read'!
writeInstance: anObject
    "PRIVATE -- Write the contents of an arbitrary instance."

    ^ anObject storeDataOn: self! !

!DataStream methodsFor: 'write and read'!
writeInteger: anInteger
	"PRIVATE -- Write the contents of a SmallInteger."

	byteStream nextInt32Put: anInteger	"signed!!!!!!!!!!"! !

!DataStream methodsFor: 'write and read'!
writeNil: anUndefinedObject
    "PRIVATE -- Write the contents of an UndefinedObject."! !

!DataStream methodsFor: 'write and read' stamp: 'jm 7/31/97 16:16'!
writeRectangle: anObject
    "Write the contents of a Rectangle.  See if it can be a compact Rectangle (type=15).  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  17:22 tk"

	| ok right bottom top left acc |
	ok _ true.
	(right _ anObject right) > 2047 ifTrue: [ok _ false].
	right < -2048 ifTrue: [ok _ false].
	(bottom _ anObject bottom) > 2047 ifTrue: [ok _ false].
	bottom < -2048 ifTrue: [ok _ false].
	(top _ anObject top) > 2047 ifTrue: [ok _ false].
	top < -2048 ifTrue: [ok _ false].
	(left _ anObject left) > 2047 ifTrue: [ok _ false].
	left < -2048 ifTrue: [ok _ false].
	ok _ ok & left isInteger & right isInteger & top isInteger & bottom isInteger.

	ok ifFalse: [
		byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance"
	    ^ anObject storeDataOn: self].

	acc _ ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF).
	byteStream nextNumber: 3 put: acc.
	acc _ ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF).
	byteStream nextNumber: 3 put: acc.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 20:57'!
writeString: aString
	"PRIVATE -- Write the contents of a String."

	byteStream nextStringPut: aString.! !

!DataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:23'!
writeStringOld: aString
	"PRIVATE -- Write the contents of a String."

	| length |
	aString size < 16384 
		ifTrue: [
			(length _ aString size) < 192
				ifTrue: [byteStream nextPut: length]
				ifFalse: 
					[byteStream nextPut: (length // 256 + 192).
					byteStream nextPut: (length \\ 256)].
			aString do: [:char | byteStream nextPut: char asciiValue]]
		ifFalse: [self writeByteArray: aString].	"takes more space"! !

!DataStream methodsFor: 'write and read'!
writeSymbol: aSymbol
    "PRIVATE -- Write the contents of a Symbol."

    self writeString: aSymbol! !

!DataStream methodsFor: 'write and read'!
writeTrue: aTrue
    "PRIVATE -- Write the contents of a True."! !

!DataStream methodsFor: 'write and read'!
writeUser: anObject
    "Write the contents of an arbitrary User instance (and its devoted class)."
    " 7/29/96 tk"

	"If anObject is an instance of a unique user class, will lie and say it has a generic class"
    ^ anObject storeDataOn: self! !

!DataStream methodsFor: 'write and read' stamp: 'tk 2/5/2000 21:53'!
writeWordLike: aWordArray
	"Note that we put the class name before the size."

	self nextPut: aWordArray class name.
	aWordArray writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words or double-bytes."! !


!DataStream methodsFor: 'other'!
atEnd
    "Answer true if the stream is at the end."

    ^ byteStream atEnd! !

!DataStream methodsFor: 'other'!
byteStream
	^ byteStream! !

!DataStream methodsFor: 'other'!
close
	"Close the stream."

	| bytes |
	byteStream closed 
		ifFalse: [
			bytes _ byteStream position.
			byteStream close]
		ifTrue: [bytes _ 'unknown'].
	^ bytes! !

!DataStream methodsFor: 'other'!
errorWriteReference: anInteger
    "PRIVATE -- Raise an error because this case of nextPut:Õs perform:
     shouldn't be called. -- 11/15/92 jhm"

    self error: 'This should never be called'! !

!DataStream methodsFor: 'other'!
flush
    "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm"

    ^ byteStream flush! !

!DataStream methodsFor: 'other'!
next: anInteger
    "Answer an Array of the next anInteger objects in the stream."
    | array |

    array _ Array new: anInteger.
    1 to: anInteger do: [:i |
        array at: i put: self next].
    ^ array! !

!DataStream methodsFor: 'other' stamp: 'tk 11/24/97 16:31'!
nextAndClose
	"Speedy way to grab one object.  Only use when we are inside an object binary file.  Do not use for the start of a SmartRefStream mixed code-and-object file."

	| obj |
	byteStream peek = 4 ifFalse: ["Try to fix the user's sins..."
		self inform: 'Should be using fileInObjectAndCode'.
		byteStream ascii.
		byteStream fileIn.
		obj _ SmartRefStream scannedObject.
		SmartRefStream scannedObject: nil.
		^ obj].

	obj _ self next.
	self close.
	^ obj! !

!DataStream methodsFor: 'other'!
reset
    "Reset the stream."

    byteStream reset! !

!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'!
rootObject
	"Return the object at the root of the tree we are filing out.  "

	^ topCall! !

!DataStream methodsFor: 'other' stamp: 'tk 5/29/97'!
rootObject: anObject
	"Return the object at the root of the tree we are filing out.  "

	topCall _ anObject! !

!DataStream methodsFor: 'other' stamp: '6/9/97 08:03 di'!
setStream: aStream
	"PRIVATE -- Initialization method."

	aStream binary.
	basePos _ aStream position.	"Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."
	byteStream _ aStream.! !

!DataStream methodsFor: 'other' stamp: 'tk 8/18/1998 08:59'!
setStream: aStream reading: isReading
	"PRIVATE -- Initialization method."

	aStream binary.
	basePos _ aStream position.	"Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."
	byteStream _ aStream.! !

!DataStream methodsFor: 'other'!
size
    "Answer the stream's size."

    ^ byteStream size! !

!DataStream methodsFor: 'other' stamp: 'tk 7/12/1998 13:16'!
vacantRef
	"Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference
	 position' to identify a reference that's not yet filled in. This must be a
	 value that won't be used as an ordinary reference. Cf. outputReference: and
	 readReference. -- 
	 NOTE: We could use a different type ID for vacant-refs rather than writing
		object-references with a magic value. (The type ID and value are
		overwritten by ordinary object-references when weak refs are fullfilled.)"

	^ SmallInteger maxVal! !

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

DataStream class
	instanceVariableNames: ''!

!DataStream class methodsFor: 'as yet unclassified'!
example
    "An example and test of DataStream/ReferenceStream.
     11/19/92 jhm: Use self testWith:."
    "DataStream example"
    "ReferenceStream example"
    | input sharedPoint |

    "Construct the test data."
    input _ Array new: 9.
    input at: 1 put: nil.
    input at: 2 put: true.
    input at: 3 put: (Form extent: 63 @ 50 depth: 8).
		(input at: 3) fillWithColor: Color lightBlue.
    input at: 4 put: #(3 3.0 'three').
    input at: 5 put: false.
    input at: 6 put: 1024 @ -2048.
    input at: 7 put: #x.
    input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
    input at: 9 put: sharedPoint.

    "Write it out, read it back, and return it for inspection."
    ^ self testWith: input! !

!DataStream class methodsFor: 'as yet unclassified'!
exampleWithPictures
	"DataStream exampleWithPictures"
	| file result |
	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	(DataStream on: file) nextPut: (Form fromUser).
	file close.

	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	result _ (DataStream on: file) next.
	file close.
	result display.
	^ result! !

!DataStream class methodsFor: 'as yet unclassified'!
fileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	| strm |
	strm _ self on: (FileStream fileNamed: aString).		"will be binary"
	strm byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'tk 10/4/2000 10:09'!
initialize
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.  
	Classes named here have special formats in the file.  If such a class has a subclass, it will use type 9 and write correctly.  It will just be slow.  (Later write the class name in the special format, then subclasses can use the type also.)
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
	"DataStream initialize"

	| refTypes t |
	refTypes _ OrderedCollection new.
	t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing"

	t at: UndefinedObject put: 1.   refTypes add: 0.
	t at: True put: 2.   refTypes add: 0.
	t at: False put: 3.   refTypes add: 0.
	t at: SmallInteger put: 4.	 refTypes add: 0.
	t at: String put: 5.   refTypes add: 1.
	t at: Symbol put: 6.   refTypes add: 1.
	t at: ByteArray put: 7.   refTypes add: 1.
	t at: Array put: 8.   refTypes add: 1.
	"(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)"
		refTypes add: 1.
	"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
		refTypes add: 0.
	t at: Bitmap put: 11.   refTypes add: 1.
	t at: Metaclass put: 12.   refTypes add: 0.
	"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
		refTypes add: 1.
	t at: Float put: 14.  refTypes add: 1.
	t at: Rectangle put: 15.  refTypes add: 1.	"Allow compact Rects."
	"type ID 16 is an instance with short header.  See beginInstance:size:"
		refTypes add: 1.
	t at: String put: 17.   refTypes add: 1.	"new String format, 1 or 4 bytes of length"
	t at: WordArray put: 18.  refTypes add: 1.	"bitmap-like"
	t at: WordArrayForSegment put: 19.  refTypes add: 1.		"bitmap-like"
	t at: SoundBuffer put: 20.  refTypes add: 1.		"And all other word arrays"
	t at: CompiledMethod put: 21.  refTypes add: 1.	"special creation method"
	"t at:  put: 22.  refTypes add: 0."
	ReferenceStream refTypes: refTypes.		"save it"! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 2/15/98 14:03'!
new
	^ self basicNew! !

!DataStream class methodsFor: 'as yet unclassified'!
newFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	| strm |
	strm _  self on: (FileStream newFileNamed: aString).		"will be binary"
	strm byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified'!
oldFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream oldFileNamed: 'test.obj'.
^ rr nextAndClose.
"

	| strm ff |
	ff _ FileStream oldFileOrNoneNamed: aString.
	ff ifNil: [^ nil].
	strm _ self on: (ff binary).
	^ strm! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'di 6/24/97 00:18'!
on: aStream
	"Open a new DataStream onto a low-level I/O stream."

	^ self basicNew setStream: aStream
		"aStream binary is in setStream:"
! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:38'!
streamedRepresentationOf: anObject

	| file |
	file _ (RWBinaryOrTextStream on: (ByteArray new: 5000)).
	file binary.
	(self on: file) nextPut: anObject.
	^file contents! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'jm 12/3/97 19:36'!
testWith: anObject
	"As a test of DataStream/ReferenceStream, write out anObject and read it back.
	11/19/92 jhm: Set the file type. More informative file name."
	"DataStream testWith: 'hi'"
	"ReferenceStream testWith: 'hi'"
	| file result |

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	(self on: file) nextPut: anObject.
	file close.

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	result _ (self on: file) next.
	file close.
	^ result! !

!DataStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:33'!
unStream: aString

	^(self on: ((RWBinaryOrTextStream with: aString) reset; binary)) next! !
Magnitude subclass: #Date
	instanceVariableNames: 'julianDayNumber '
	classVariableNames: 'DaysInMonth FirstDayOfMonth MonthNames SecondsInDay WeekDayNames '
	poolDictionaries: ''
	category: 'Kernel-Magnitudes'!
!Date commentStamp: '<historical>' prior: 0!
Refactored to use Julian Day Numbers internally.

Julian Day Numbers are the number of days which have elapsed since 24 November -4713 Gregorian.

The algorithm was published in the Communications of the ACM, volume 11, Number 10, October 1968.

See also: 
http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
http://www.cs.ubc.ca/spider/flinn/docs/scham/primitives/time.html

!


!Date methodsFor: 'accessing' stamp: 'BP 5/21/2000 19:17'!
day
	"Answer the day of the year represented by the receiver."

	^self dayOfYear! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:28'!
julianDayNumber
	"Answer the number of days (or part of a day) elapsed since noon GMT on January 1st, 4713 B.C."

	^julianDayNumber

! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:29'!
julianDayNumber: anInteger
	"Set the number of days (or part of a day) elapsed since noon GMT on January 1st, 4713 B.C."

	julianDayNumber _ anInteger.

! !

!Date methodsFor: 'accessing' stamp: 'BP 5/21/2000 16:39'!
leap
	"Answer whether the receiver's year is a leap year."

	^Date leapYear: self year! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 19:34'!
monthIndex
	"Answer the index of the month in which the receiver falls."

	^self asGregorian middle! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:05'!
monthName
	"Answer the name of the month in which the receiver falls."

	^MonthNames at: self monthIndex! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:05'!
weekday
	"Answer the name of the day of the week on which the receiver falls."

	^WeekDayNames at: self weekdayIndex! !

!Date methodsFor: 'accessing' stamp: 'rca 6/15/2000 14:51'!
weekdayIndex
	"Monday=1, ... , Sunday=7"
	^ (self julianDayNumber rem: 7) + 1! !

!Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 19:34'!
year
	"Answer the year in which the receiver falls."

	^self asGregorian last! !


!Date methodsFor: 'arithmetic' stamp: 'BP 5/18/2000 18:46'!
addDays: dayCount 
	"Answer a Date that is dayCount days after the receiver."

	^self class fromJulianDayNumber: self julianDayNumber + dayCount.! !

!Date methodsFor: 'arithmetic' stamp: 'RAH 5/23/2000 11:32'!
subtractDate: aDate 
	"Answer the number of days between the receiver and aDate."

	^self julianDayNumber - aDate asJulianDayNumber! !

!Date methodsFor: 'arithmetic' stamp: 'BP 5/18/2000 18:48'!
subtractDays: dayCount 
	"Answer a Date that is dayCount days before the receiver."

	^self addDays: dayCount negated.! !


!Date methodsFor: 'comparing' stamp: 'RAH 5/23/2000 11:04'!
< aDate 
	"Answer whether aDate precedes the date of the receiver." 

	^julianDayNumber < aDate asJulianDayNumber! !

!Date methodsFor: 'comparing' stamp: 'BP 5/18/2000 18:31'!
= aDate 
	"Answer whether aDate is the same day as the receiver."

	^julianDayNumber = aDate asJulianDayNumber.
! !

!Date methodsFor: 'comparing' stamp: 'BP 5/18/2000 19:09'!
hash
	"Hash is reimplemented because = is implemented."

	^julianDayNumber hash! !


!Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 19:18'!
dayOfMonth
	"Answer which day of the month is represented by the receiver."

	^self asGregorian first! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 19:18'!
dayOfYear

	^self firstDayOfMonth + self dayOfMonth - 1! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/18/2000 18:05'!
daysInMonth
	"Answer the number of days in the month represented by the receiver."

	^(DaysInMonth at: self monthIndex)
		+ (self monthIndex = 2
				ifTrue: [self leap]
				ifFalse: [0])! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 16:40'!
daysInYear
	"Answer the number of days in the year represented by the receiver."

	^Date daysInYear: self year! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 17:28'!
daysLeftInYear
	"Answer the number of days in the year after the date of the receiver."

	^self daysInYear - self dayOfYear! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 17:31'!
firstDayOfMonth
	"Answer the index of the day of the year that is the first day of the receiver's month."

	^(FirstDayOfMonth at: self monthIndex)
		+ (self monthIndex > 2
				ifTrue: [self leap]
				ifFalse: [0])! !

!Date methodsFor: 'inquiries' stamp: 'BP 5/18/2000 19:10'!
previous: dayName 
	"Answer the previous date whose weekday name is dayName."

	^self subtractDays: 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7! !


!Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:21'!
asDate

	^self! !

!Date methodsFor: 'converting' stamp: 'BP 5/21/2000 17:32'!
asGregorian
	"Return an array of integers #(dd mm yyyy)"

	| l n i j dd mm yyyy |

	l _ self julianDayNumber + 68569.
	n _ (4 * l) // 146097.
	l _ l - ( (146097 * n + 3) // 4 ).
	i _ (4000 * (l + 1) ) // 1461001.
	l _ l - ( (1461 * i) // 4 ) + 31.
	j _ (80 *l) // 2447.
	dd _ l - ( (2447 * j) // 80 ).
	l _ j // 11.
	mm _ j + 2 - (12 * l).
	yyyy _ 100 * (n -49) + i + l.

	^Array with: dd with: mm with: yyyy.! !

!Date methodsFor: 'converting' stamp: 'BP 5/21/2000 19:19'!
asJulianDayNumber

	^self julianDayNumber
! !

!Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:05'!
asSeconds
	"Answer the seconds between a time on 1 January 1901 and the same 
	time in the receiver's day."

	^SecondsInDay * (self subtractDate: (Date newDay: 1 year: 1901))! !

!Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:05'!
month
	^ Month fromDate: self! !

!Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:05'!
week
	^ Week fromDate: self! !


!Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:05'!
mmddyyyy
	"Answer the receiver rendered in standard fmt mm/dd/yyyy.  Good for avoiding year 2000 bugs.  Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96"

	"Date today mmddyyyy"

	^ self printFormat: #(2 1 3 $/ 1 1)! !

!Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:22'!
printFormat: formatArray 
	"Answer a String describing the receiver using the argument formatArray."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	self printOn: aStream format: formatArray.
	^aStream contents! !

!Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:05'!
printOn: aStream

	self printOn: aStream format: #(1 2 3 $  3 1 )! !

!Date methodsFor: 'printing' stamp: 'rca 6/13/2000 12:31'!
printOn: aStream format: formatArray 
	"Print a description of the receiver on aStream using the format denoted the argument, formatArray:
		#(item item item sep monthfmt yearfmt twoDigits)
		items:  1=day  2=month  3=year  will appear in the order given,
		separated by sep which is eaither an ascii code or character.
		monthFmt:  1=09  2=Sep  3=September
		yearFmt:  1=1996  2=96
		digits:  (missing or)1=9  2=09.
	See the examples in printOn: and mmddyy"

	| gregorian twoDigits element monthFormat  |
	gregorian _ self asGregorian.
	twoDigits _ formatArray size > 6 and: [ (formatArray at: 7) > 1 ].

	1 to: 3 do: 
	[ :i | 
		element _ formatArray at: i.
		element = 1 ifTrue:
		[ 
			twoDigits 
				ifTrue: [ aStream nextPutAll: (gregorian first asString padded: #left to: 2 with: $0) ]
				ifFalse: [ gregorian first printOn: aStream ]
		].
		element = 2 ifTrue: 
		[
			monthFormat _ formatArray at: 5.
			monthFormat = 1 ifTrue:
			[
				twoDigits 
					ifTrue: [ aStream nextPutAll: (gregorian middle asString padded: #left to: 2 with: $0) ]
					ifFalse: [ gregorian middle printOn: aStream ].
			].
			monthFormat = 2 ifTrue:
			[
				aStream nextPutAll: ((MonthNames at: gregorian middle) copyFrom: 1 to: 3)
			].
			monthFormat = 3 ifTrue:
			[
				aStream nextPutAll: (MonthNames at: gregorian middle)
			].
		].
		element = 3 ifTrue: 
		[
			(formatArray at: 6) = 1
				ifTrue: [ gregorian last printOn: aStream ]
				ifFalse: [ aStream nextPutAll: ((gregorian last \\ 100) asString padded: #left to: 2 with: $0) ].
		].
		i < 3 ifTrue: 
		[
			(formatArray at: 4) ~= 0 
				ifTrue: [ aStream nextPut: (formatArray at: 4) asCharacter ] 
		].
	].! !

!Date methodsFor: 'printing' stamp: 'di 9/22/2000 12:47'!
storeOn: aStream

	aStream print: self printString; nextPutAll: ' asDate'! !


!Date methodsFor: 'obsolete' stamp: 'BP 5/21/2000 17:24'!
day: dayInteger year: yearInteger

	self error: 'obsolete'
! !

!Date methodsFor: 'obsolete' stamp: 'BP 5/21/2000 17:30'!
firstDayOfMonthIndex: monthIndex 
	"Answer the day of the year (an Integer) that is the first day of my month"

	self error: 'obsolete'! !

!Date methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:23'!
mmddyy
	"Please use mmddyyyy instead, so dates in 2000 will be unambiguous"

	^ self printFormat: #(2 1 3 $/ 1 2)! !


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

Date class
	instanceVariableNames: ''!

!Date class methodsFor: 'class initialization' stamp: 'BP 5/18/2000 18:59'!
initialize
	"Initialize class variables representing the names of the months and days and
	the number of seconds, days in each month, and first day of each month."

	MonthNames _
		#(January February March April May June July August September October November December ).
	SecondsInDay _ 24 * 60 * 60.
	DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31 ).
	FirstDayOfMonth _ #(1 32 60 91 121 152 182 213 244 274 305 335 ).
	WeekDayNames _ #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday ).

	"Date initialize."
! !


!Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 17:36'!
fromDays: dayCount
	"Answer an instance of me which is dayCount days after January 1, 1901.  Works for negative days before 1901.  Works over a huge range, both BC and AD."

	^self fromJulianDayNumber: dayCount +  2415386 "Julian Day Number of 1 Jan 1901" 
! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/18/2000 18:38'!
fromJulianDayNumber: aJulianDayNumber

	^self new julianDayNumber: aJulianDayNumber.! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 19:26'!
fromSeconds: seconds
	"Answer an instance of me which is 'seconds' seconds after January 1, 1901."

	^self fromDays: seconds // SecondsInDay! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/18/2000 18:57'!
fromString: aString
	"Answer an instance of created from a string with format DD.MM.YYYY."

	^self readFrom: (ReadStream on: aString).
! !

!Date class methodsFor: 'instance creation' stamp: 'sma 11/11/2000 13:57'!
newDay: day month: month year: year 
	"Arguments day, month and year are all integers, except month may be a string.
	For compatibility, two digit dates in the range 00..49 are from 2000, 50..99 from 1900.
	Please use ALWAYS four digits year numbers."

	| monthIndex daysInMonth p q r s |

	year < 100 ifTrue: [^self
			newDay: day
			month: month
			year: (year < 50 ifTrue: [2000] ifFalse: [1900]) + year].

	monthIndex _ month isInteger ifTrue: [month] ifFalse: [self indexOfMonth: month].
	monthIndex = 2
		ifTrue: [ daysInMonth _ (DaysInMonth at: monthIndex) + (self leapYear: year) ]
		ifFalse: [ daysInMonth _ DaysInMonth at: monthIndex ].
	(day < 1 or: [day > daysInMonth]) ifTrue: [ self error: 'illegal day in month' ].

	p _ (monthIndex - 14) quo: 12.
	q _ year + 4800 + p.
	r _ monthIndex - 2 - (12 * p).
	s _ (year + 4900 + p) quo: 100.
 
	^self fromJulianDayNumber: 
		( (1461 * q) quo: 4 ) + 
			( (367 * r) quo: 12 ) - 
				( (3 * s) quo: 4 ) + 
					( day - 32075 )! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/22/2000 16:46'!
newDay: dayCount year: referenceYear 
	"Answer an instance of me which is dayCount days after the beginning of the year referenceYear."

	| day year daysInYear date |
	day _ dayCount.
	year _ referenceYear.
	[ day > (daysInYear _ self daysInYear: year) ] whileTrue: 
	[
		year _ year + 1.
		day _ day - daysInYear
	].

	[ day <= 0 ] whileTrue: 
	[
		year _ year - 1.
		day _ day + (self daysInYear: year)
	].
	
	date _ self newDay: 1 month: 1 year: year.
	^date addDays: (day - 1).
! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 16:48'!
readFrom: aStream
	"Read a Date from the stream in any of the forms:
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)
		<monthName> <day> <year>		(April 5, 1982)
		<monthNumber> <day> <year>	(4/5/82)"

	| day month |
	aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue:		"number/name... or name..."
			[month _ WriteStream on: (String new: 10).
			[aStream peek isLetter] whileTrue: [month nextPut: aStream next].
			month _ month contents.
			day isNil ifTrue:		"name/number..."
				[[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
				day _ Integer readFrom: aStream]]
		ifFalse:		"number/number..."
			[month _ Date nameOfMonth: day.
			day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	^self newDay: day month: month year: (Integer readFrom: aStream)

	"Date readFrom: (ReadStream on: '5APR82')"
! !

!Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 19:26'!
today
	"Answer an instance of me representing the day and year right now."

	^self dateAndTimeNow first! !


!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'!
dateAndTimeNow
	"Answer an Array whose first element is Date today and second element 
	is Time now."

	^Time dateAndTimeNow! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:59'!
dayOfWeek: dayName 
	"Answer the index in a week, 1-7, of the day named dayName. Create an 
	error notification if no such day exists."

	1 to: 7 do: [ :index | (WeekDayNames at: index) = dayName ifTrue: [^index] ].

	self error: dayName asString , ' is not a day of the week'! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 19:00'!
daysInMonth: monthName forYear: yearInteger 
	"Answer the number of days in the month named monthName in the year yearInteger."

	^(self newDay: 1 month: monthName year: yearInteger) daysInMonth! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'!
daysInYear: yearInteger 
	"Answer the number of days in the year, yearInteger."

	^365 + (self leapYear: yearInteger)! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'!
firstWeekdayOfMonth: mn year: yr
	"Answer the weekday index (Sunday=1, etc) of the first day in the month named mn in the year yr."

	^(self newDay: 1 month: mn year: yr) weekdayIndex + 7 \\ 7 + 1! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'!
indexOfMonth: monthName 
	"Answer the index, 1-12, of the month monthName. Create an error 
	notification if no such month exists."

	1 to: 12 do: 
		[ :index | 
			(monthName , '*' match: (MonthNames at: index))
						ifTrue: [^index]].
	self error: monthName , ' is not a recognized month name'! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'!
leapYear: yearInteger
 "Answer 1 if the year yearInteger is a leap year; answer 0 if it is not."

    | adjustedYear |
    adjustedYear := yearInteger > 0
        ifTrue: [yearInteger]
        ifFalse: [(yearInteger + 1) negated "There is no year 0!!!!"].
     (adjustedYear \\ 4 ~= 0 or: [adjustedYear \\ 100 = 0 and: [adjustedYear \\ 400 ~= 0]])
        ifTrue: [^0]
        ifFalse: [^1]! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 19:01'!
nameOfDay: dayIndex 
	"Answer a symbol representing the name of the day indexed by dayIndex, 1-7."

	^WeekDayNames at: dayIndex! !

!Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 19:01'!
nameOfMonth: monthIndex 
	"Answer a String representing the name of the month indexed by monthIndex, 1-12."

	^MonthNames at: monthIndex! !


!Date class methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:05'!
absoluteDaysToYear: gregorianYear
	"Computes the number of days from (or until) January 1 of the year 1 A.D. upto (or since) January 1 of a given year. [Alan Lovejoy]"

	| days yearDelta quadCenturies centuries quadYears years isInADEra |
	days := 0.
	isInADEra := gregorianYear > 0.

	gregorianYear = 0 ifTrue: [gregorianYear = -1]. "There is no year 0"
	isInADEra
		ifTrue: [yearDelta := gregorianYear - 1]
		ifFalse: [yearDelta := (gregorianYear + 1) negated].
	quadCenturies := yearDelta // 400.
	yearDelta := yearDelta rem: 400.
	centuries := yearDelta // 100.
	yearDelta := yearDelta rem: 100.
	quadYears := yearDelta // 4.
	years := yearDelta rem: 4.
	days := (quadCenturies * 146097 "days per quad century") +
		(centuries * 36524 "days per century")  +
		(quadYears * 1461 "days per quad year") +
		(years * 365).
	isInADEra ifFalse:
			[days := days + 366.  "1 B.C. is a leap year"
			days := days negated].
	^ days! !

!Date class methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:05'!
yearAndDaysFromDays: days into: aTwoArgBlock
	"Compute the Gregorian year, and the day of the year, from the number of days since (or until) January 1 of the year 1 A.D. Return the values in a block.  [Alan Lovejoy]"

	| quadCentury year dayInYear isInADEra century quadYear |
	dayInYear := days.
	isInADEra := days >= 0.

	isInADEra
		ifTrue: [year := 0]
		ifFalse: [dayInYear := dayInYear abs.
			dayInYear >= 366 "days per leap year" 
				ifTrue: [year := 1.
						dayInYear := dayInYear - 366]	"Subtract the year 1 B.C."
				ifFalse: [year := 0]].

	quadCentury := dayInYear // 146097 "days per quad century".
	dayInYear := dayInYear \\ 146097 "days per quad century".
	century := dayInYear // 36524 "days per century".
	dayInYear := dayInYear \\ 36524 "days per century".
	quadYear := dayInYear // 1461 "days per quad year".
	dayInYear := dayInYear \\ 1461 "days per quad year".
	dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 1 AD or 2 BC"
		dayInYear := dayInYear - 365 "days per standard year".
		year := year + 1.
		dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 2 AD or 3 BC"
			dayInYear := dayInYear - 365 "days per standard year".
			year := year + 1.
			dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 3 AD or 4 BC"
				dayInYear := dayInYear - 365 "days per standard year".
				year := year + 1.
				dayInYear >= 366 "days per leap year" ifTrue: [
					"e.g., 4 AD or 5 BC (although this won't occur in the AD case)"
					dayInYear := dayInYear - 366 "days per leap year".
					year := year + 1]]]].

	year := year + (quadCentury * 400) + (century * 100) + (quadYear * 4) + 1.
	isInADEra ifFalse: [
		year := year negated.
		dayInYear > 0 ifTrue: [
			(Date leapYear: year) = 1
				ifTrue: [dayInYear := 366 "days per leap year" - dayInYear]
				ifFalse: [dayInYear := 365 "days per standard year" - dayInYear]]].
	^ aTwoArgBlock value: year value: dayInYear+1 "the way Dates do it"! !
CodeHolder subclass: #Debugger
	instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames savedCursor isolationHead failedProject errorWasInUIProcess '
	classVariableNames: 'ContextStackKeystrokes ErrorRecursion '
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!Debugger commentStamp: '<historical>' prior: 0!
I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context.

Special note on recursive errors:
Some errors affect Squeak's ability to present a debugger.  This is normally an unrecoverable situation.  However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger.  Here is the chain of events in such a recovery.

	* A recursive error is detected.
	* The current project is queried for an isolationHead
	* Changes in the isolationHead are revoked
	* The parent project of isolated project is returned to
	* The debugger is opened there and execution resumes.

If the user closes that debugger, execution continues in the outer project and layer.  If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. !


!Debugger methodsFor: 'initialize' stamp: 'RAA 1/30/2001 13:05'!
buildMVCDebuggerViewLabel: aString minSize: aPoint
	"Build an MVC debugger view around the receiver, and return the StandardSystemView thus created."

	| topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView deltaY underPane annotationPane buttonsView oldContextStackIndex |

	oldContextStackIndex _ contextStackIndex.
	self expandStack. "Sets contextStackIndex to zero."
	contextStackIndex _ oldContextStackIndex.

	topView _ StandardSystemView new model: self.
	topView borderWidth: 1.
	stackListView _ PluggableListView on: self
			list: #contextStackList
			selected: #contextStackIndex
			changeSelected: #toggleContextStackIndex:
			menu: #contextStackMenu:shifted:
			keystroke: #contextStackKey:from:.
		stackListView menuTitleSelector: #messageListSelectorTitle.
		stackListView window: (0 @ 0 extent: 150 @ 50).
		topView addSubView: stackListView.
	deltaY _ 0.
	 self wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView on: self
				text: #annotation accept: nil readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 150@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: stackListView.
			deltaY _ deltaY + self optionalAnnotationHeight.
			underPane _ annotationPane]
		ifFalse:
			[underPane _ stackListView].
	self wantsOptionalButtons
		ifTrue:
			[buttonsView _ self buildMVCOptionalButtonsButtonsView.
			buttonsView borderWidth: 1.
			topView addSubView: buttonsView below: underPane.
			underPane _ buttonsView.
			deltaY _ deltaY + self optionalButtonHeight].
	stackCodeView _ PluggableTextView on: self
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		stackCodeView window: (0 @ 0 extent: 150 @ (75 - deltaY)).
		topView addSubView: stackCodeView below: underPane.
	rcvrVarView _ PluggableListView on: self receiverInspector
			list: #fieldList
			selected: #selectionIndex
			changeSelected: #toggleIndex:
			menu: #fieldListMenu:
			keystroke: #inspectorKey:from:.
		rcvrVarView window: (0 @ 0 extent: 25 @ (50 - deltaY)).
		topView addSubView: rcvrVarView below: stackCodeView.
	rcvrValView _ PluggableTextView on: self receiverInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		rcvrValView window: (0 @ 0 extent: 50 @ (50 - deltaY)).
		topView addSubView: rcvrValView toRightOf: rcvrVarView.
	ctxtVarView _ PluggableListView on: self contextVariablesInspector
			list: #fieldList
			selected: #selectionIndex
			changeSelected: #toggleIndex:
			menu: #fieldListMenu:
			keystroke: #inspectorKey:from:.
		ctxtVarView window: (0 @ 0 extent: 25 @ (50 - deltaY)).
		topView addSubView: ctxtVarView toRightOf: rcvrValView.
	ctxtValView _ PluggableTextView on: self contextVariablesInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		ctxtValView window: (0 @ 0 extent: 50 @ (50 - deltaY)).
		topView addSubView: ctxtValView toRightOf: ctxtVarView.
	topView label: aString.
	topView minimumSize: aPoint.
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:12'!
buildMVCNotifierButtonView

	| aView bHeight priorButton buttonView |
	aView _ View new model: self.
	bHeight _ self notifierButtonHeight.
	aView window: (0@0 extent: 350@bHeight).
	priorButton _ nil.
	self preDebugButtonQuads do:
		[:aSpec |
			buttonView _ PluggableButtonView
				on: self
				getState: nil
				action: aSpec second..
			buttonView
				label: aSpec first;
				insideColor: (Color perform: aSpec third) muchLighter lighter;
				borderWidthLeft: 1 right: 1 top: 0 bottom: 0;
				window: (0@0 extent: 117@bHeight).
			priorButton
				ifNil:
					[aView addSubView: buttonView]
				ifNotNil:
					[aView addSubView: buttonView toRightOf: priorButton].
			priorButton _ buttonView].
	^ aView! !

!Debugger methodsFor: 'initialize' stamp: 'rhi 12/20/2000 16:50'!
buildMVCNotifierViewLabel: aString message: messageString minSize: aPoint

	| topView notifyView buttonView x y bHeight |
	self expandStack.
	topView _ StandardSystemView new model: self.
	topView borderWidth: 1.
	buttonView _ self buildMVCNotifierButtonView.
	topView addSubView: buttonView.
	notifyView _ PluggableListView on: self
		list: #contextStackList
		selected: #contextStackIndex
		changeSelected: #debugAt:
		menu: nil
		keystroke: nil.
	x _ 350 max: (aPoint x).
	y _ ((4 * 15) + 16) max: (aPoint y - 16 - self optionalButtonHeight).
	bHeight _ self optionalButtonHeight.
	y _ y - bHeight.
	notifyView window: (0@0 extent: x@y).
	topView
		addSubView: notifyView below: buttonView;
		label: aString;
		minimumSize: aPoint.
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/28/1999 11:38'!
buildMVCOptionalButtonsButtonsView

	| aView bHeight offset aButtonView wid pairs windowWidth previousView |
	aView _ View new model: self.
	bHeight _ self optionalButtonHeight.
	windowWidth _ 150.
	aView window: (0@0 extent: windowWidth@bHeight).
	offset _ 0.
	pairs _ self optionalButtonPairs.
	previousView _ nil.
	pairs do: [:pair |
		aButtonView _ PluggableButtonView on: self getState: nil action: pair last.
		pair last = pairs last last
			ifTrue:
				[wid _ windowWidth - offset]
			ifFalse:
				[aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
				wid _ windowWidth // (pairs size)].
		aButtonView
			label: pair first asParagraph;
			insideColor: Color red muchLighter lighter;
			window: (offset@0 extent: wid@bHeight).
		offset _ offset + wid.
		pair last = pairs first last
			ifTrue: [aView addSubView: aButtonView]
			ifFalse: [aView addSubView: aButtonView toRightOf: previousView].
		previousView _ aButtonView].
	^ aView! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/22/1999 16:21'!
buttonRowForPreDebugWindow: aDebugWindow
	| aRow aButton |
	aRow _ AlignmentMorph newRow hResizing: #spaceFill.
	aRow beSticky.
	aButton _ SimpleButtonMorph new target: aDebugWindow.
	aButton color: Color transparent; borderWidth: 1.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	self preDebugButtonQuads do:
			[:quad |
				aButton _ aButton fullCopy.
				aButton actionSelector: quad second.
				aButton label: quad first.
				aButton submorphs first color: (Color colorFrom: quad third).
				aButton setBalloonText: quad fourth.
				aRow addMorphBack: aButton.
				aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'kfr 10/4/2000 22:13'!
debugAt: anInteger
	self toggleContextStackIndex: anInteger. 
	 ^ self debug.! !

!Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:07'!
notifierButtonHeight

	^ 18! !

!Debugger methodsFor: 'initialize' stamp: 'RAA 1/30/2001 13:20'!
openFullMorphicLabel: labelString
	| window aListMorph oldContextStackIndex |

	oldContextStackIndex _ contextStackIndex.
	self expandStack. "Sets contextStackIndex to zero."

	window _ (SystemWindow labelled: labelString) model: self.
	aListMorph _ PluggableListMorph on: self list: #contextStackList
			selected: #contextStackIndex changeSelected: #toggleContextStackIndex:
			menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:.
	aListMorph menuTitleSelector: #messageListSelectorTitle.
	window addMorph: aListMorph
		frame: (0@0 corner: 1@0.3).

	self addLowerPanesTo: window at: (0@0.3 corner: 1@0.7) with: nil.

	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self receiverInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:)
		frame: (0@0.7 corner: 0.2@1).
	window addMorph: (PluggableTextMorph on: self receiverInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.2@0.7 corner: 0.5@1).
	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: self contextVariablesInspector list: #fieldList
			selected: #selectionIndex changeSelected: #toggleIndex:
			menu: #fieldListMenu: keystroke: #inspectorKey:from:)
		frame: (0.5@0.7 corner: 0.7@1).
	window addMorph: (PluggableTextMorph on: self contextVariablesInspector
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (0.7@0.7 corner: 1@1).
	window openInWorld.
	self toggleContextStackIndex: oldContextStackIndex.
	^ window ! !

!Debugger methodsFor: 'initialize' stamp: 'RAA 8/8/2000 10:44'!
openFullNoSuspendLabel: aString
	"Create and schedule a full debugger with the given label. Do not terminate the current active process."

	| topView |

	Smalltalk isMorphic ifTrue: [
		self openFullMorphicLabel: aString.
		errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: interruptedProcess.
		^self
	].
	topView _ self buildMVCDebuggerViewLabel: aString minSize: 300@200.
	topView controller openNoTerminate.
	^ topView
! !

!Debugger methodsFor: 'initialize' stamp: 'RAA 8/8/2000 10:45'!
openNotifierContents: msgString label: label
	"Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired."
	"NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended.  The sender will do this."
	| msg topView p |
	Sensor flushKeyboard.
	savedCursor _ Sensor currentCursor.
	Sensor currentCursor: Cursor normal.
	msg _ msgString.
	(label beginsWith: 'Space is low') ifTrue: [msg _ self lowSpaceChoices, msgString].
	isolationHead ifNotNil:
		["We have already revoked the isolation layer -- now jump to the parent project."
		msg _ self isolationRecoveryAdvice, msgString.
		failedProject _ Project current.
		isolationHead parent enterForEmergencyRecovery].

	Smalltalk isMorphic ifTrue: [
		self buildMorphicNotifierLabelled: label message: msg.
		errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: interruptedProcess.
		^self
	].

	Display fullScreen.
	topView _ self buildMVCNotifierViewLabel: label message: msg minSize: 350@((14 * 5) + 16 + self optionalButtonHeight).
	ScheduledControllers activeController
		ifNil: [p _ Display boundingBox center]
		ifNotNil: [p _ ScheduledControllers activeController view displayBox center].
	topView controller openNoTerminateDisplayAt: (p max: (200@60)).
	^ topView! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 09:50'!
optionalAnnotationHeight

	^ 10! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 08:31'!
optionalButtonHeight

	^ 10! !

!Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 09:28'!
optionalButtonPairs

	^ #(('Proceed'		proceed)
		('Restart'		restart)
		('Send'			send)
		('Step'			doStep)
		('Full Stack'		fullStack)
		('Where'		where)
		('Browse'		browseMethodFull))! !

!Debugger methodsFor: 'initialize' stamp: 'RAA 1/17/2001 14:26'!
optionalButtonRow
	"Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane"

	| aRow aButton |
	aRow _ AlignmentMorph newRow beSticky.
	aRow setNameTo: 'buttonPane'.
	aRow clipSubmorphs: true.
	aButton _ SimpleButtonMorph new target: self.
	aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker.
	aRow addTransparentSpacerOfSize: (5@0).
	self optionalButtonPairs do:
		[:pair |
				aButton _ PluggableButtonMorph
					on: self
					getState: nil
					action: pair second.
				aButton
					hResizing: #spaceFill;
					vResizing: #spaceFill;
					useRoundedCorners;
					label: pair first asString;
					askBeforeChanging: true;
					onColor: Color transparent offColor: Color transparent.
				aRow addMorphBack: aButton.
				aRow addTransparentSpacerOfSize: (3 @ 0)].
	^ aRow! !

!Debugger methodsFor: 'initialize' stamp: 'sw 8/14/2000 13:20'!
preDebugButtonQuads

	^ #(('Proceed'		proceed 	blue 	'continue execution' )
		('Abandon'		abandon 	black 	'abandon this execution by closing this window')
		('Debug'		debug 		red 		'bring up a debugger'))! !

!Debugger methodsFor: 'initialize' stamp: 'sw 8/8/2000 13:13'!
preDebugNotifierContentsFrom: messageString
	^ Preferences eToyFriendly
		ifFalse:
			[messageString]
		ifTrue:
			['An error has occurred; you should probably just hit ''abandon''.  Sorry!!'] ! !

!Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'!
release

	self windowIsClosing.
	super release.
! !

!Debugger methodsFor: 'initialize' stamp: 'sw 1/24/2001 21:22'!
wantsOptionalButtons
	"The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting.  Some traditionalists will want to change this method manually!!"

	^ true! !

!Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:30'!
windowIsClosing
	"My window is being closed; clean up. Restart the low space watcher."

	interruptedProcess == nil ifTrue: [^ self].
	interruptedProcess terminate.
	interruptedProcess _ nil.
	interruptedController _ nil.
	contextStack _ nil.
	contextStackTop _ nil.
	receiverInspector _ nil.
	contextVariablesInspector _ nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
! !


!Debugger methodsFor: 'accessing' stamp: 'di 10/9/1998 17:15'!
contents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents == nil ifTrue: [^ String new].
	^ contents copy! !

!Debugger methodsFor: 'accessing' stamp: 'di 1/17/2001 16:28'!
contents: aText notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. In this case, the retrieved information is the method of the 
	selected context."
	| selector classOfMethod category method priorMethod parseNode |
	contextStackIndex = 0 ifTrue: [^ false].
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^ false]].
	classOfMethod _ self selectedClass.
	category _ self selectedMessageCategoryName.
	Cursor execute showWhile:
		[method _ classOfMethod
		compile: aText
		notifying: aController
		trailer: #(0 0 0 0)
		ifFail: [^ false]
		elseSetSelectorAndNode: 
			[:sel :methodNode | selector _ sel.
			selector == self selectedMessageName
				ifFalse: [self notify: 'can''t change selector'. ^ false].
			priorMethod _ (classOfMethod includesSelector: selector)
				ifTrue: [classOfMethod compiledMethodAt: selector]
				ifFalse: [nil].
			sourceMap _ methodNode sourceMap.
			tempNames _ methodNode tempNames.
			parseNode _ methodNode].
		method cacheTempNames: tempNames].
	category isNil ifFalse: "Skip this for DoIts"
		[method putSource: aText
				fromParseNode: parseNode
				class: classOfMethod
				category: category
				inFile: 2 priorMethod: priorMethod.
		classOfMethod organization classify: selector under: category].
	contents _ aText copy.
	self selectedContext restartWith: method.
	contextVariablesInspector object: nil.
	self resetContext: self selectedContext.
	^true! !

!Debugger methodsFor: 'accessing'!
contextVariablesInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context."

	^contextVariablesInspector! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 12:16'!
doNothing: newText
	"Notifier window can't accept text"! !

!Debugger methodsFor: 'accessing'!
interruptedContext
	"Answer the suspended context of the interrupted process."

	^contextStackTop! !

!Debugger methodsFor: 'accessing'!
interruptedProcess
	"Answer the interrupted process."

	^interruptedProcess! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:47'!
isNotifier
	"Return true if this debugger has not been expanded into a full sized window"

	^ receiverInspector == nil! !

!Debugger methodsFor: 'accessing'!
proceedValue
	"Answer the value to return to the selected context when the interrupted 
	process proceeds."

	^proceedValue! !

!Debugger methodsFor: 'accessing'!
proceedValue: anObject 
	"Set the value to be returned to the selected context when the interrupted 
	process proceeds."

	proceedValue _ anObject! !

!Debugger methodsFor: 'accessing'!
receiver
	"Answer the receiver of the selected context, if any. Answer nil 
	otherwise."

	contextStackIndex = 0
		ifTrue: [^nil]
		ifFalse: [^self selectedContext receiver]! !

!Debugger methodsFor: 'accessing'!
receiverInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context's receiver."

	^receiverInspector! !


!Debugger methodsFor: 'notifier menu' stamp: 'RAA 1/30/2001 14:36'!
debug
	"Open a full DebuggerView."
	| topView |
	topView _ self topView.
	topView model: nil.  "so close won't release me."
	Smalltalk isMorphic
		ifTrue:
			[self breakDependents.
			self openFullMorphicLabel: topView label.
			^ topView delete].

	topView controller controlTerminate.
	topView deEmphasize; erase.

	"a few hacks to get the scroll selection artifacts out when we got here by clicking in the list"
	topView subViewWantingControl ifNotNil: [
		topView subViewWantingControl controller controlTerminate
	].
	topView controller status: #closed.

	self openFullNoSuspendLabel: topView label.
	topView controller closeAndUnscheduleNoErase.
	Processor terminateActive.
! !


!Debugger methodsFor: 'context stack (message list)'!
contextStackIndex
	"Answer the index of the selected context."

	^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)'!
contextStackList
	"Answer the array of contexts."

	^contextStackList! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'tk 4/17/1998 18:05'!
expandStack
	"A Notifier is being turned into a full debugger.  Show a substantial amount of stack in the context pane."

	self newStack: (contextStackTop stackOfSize: 20).
	contextStackIndex _ 0.
	receiverInspector _ Inspector inspect: nil.
	contextVariablesInspector _ ContextVariablesInspector inspect: nil.
	proceedValue _ nil! !

!Debugger methodsFor: 'context stack (message list)'!
fullyExpandStack
	"Expand the stack to include all of it, rather than the first four or five
	contexts."

	self okToChange ifFalse: [^ self].
	self newStack: contextStackTop stack.
	self changed: #contextStackList! !

!Debugger methodsFor: 'context stack (message list)'!
messageListIndex
	"Answer the index of the currently selected context."

	^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'sw 11/6/1999 22:58'!
selectedMessage
	"Answer the source code of the currently selected context."
	contents _ [self selectedContext sourceCode] ifError: [ :err :rcvr |
		'ERROR
"',(err reject: [ :each | each == $"]),'"'
	].
	Preferences browseWithPrettyPrint ifTrue: [contents _ self selectedClass compilerClass new
					format: contents
					in: self selectedClass
					notifying: nil
					decorated: Preferences colorWhenPrettyPrinting].
	^ contents _ contents asText makeSelectorBoldIn: self selectedClass! !

!Debugger methodsFor: 'context stack (message list)'!
selectedMessageName
	"Answer the message selector of the currently selected context."

	^self selectedContext selector! !

!Debugger methodsFor: 'context stack (message list)'!
toggleContextStackIndex: anInteger 
	"If anInteger is the same as the index of the selected context, deselect it. 
	Otherwise, the context whose index is anInteger becomes the selected 
	context."

	self contextStackIndex: 
		(contextStackIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])
		oldContextWas:
		(contextStackIndex = 0
			ifTrue: [nil]
			ifFalse: [contextStack at: contextStackIndex])! !


!Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:04'!
abandon
	"abandon the debugger from its pre-debug notifier"
	self abandon: self topView! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:05'!
abandon: aTopView 
	"abandon the notifier represented by aTopView"
	aTopView controller close! !

!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'!
browseMessages
	"Present a menu of all messages sent by the currently selected message.
	Open a message set browser of all implementors of the message chosen.
	Do nothing if no message is chosen."

	contextStackIndex = 0 ifTrue: [^ self].
	super browseMessages.! !

!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all
	messages sent by it.  Open a message set browser of all implementors
	of the message chosen."

	contextStackIndex = 0 ifTrue: [^ self].
	super browseSendersOfMessages! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 10/12/1999 17:41'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	| class selector |
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	VersionsBrowser
		browseVersionsOf: (class compiledMethodAt: selector)
		class: self selectedClass
		meta: self selectedClass isMeta
		category: self selectedMessageCategoryName
		selector: selector! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/6/98 23:00'!
buildMessageBrowser
	"Create and schedule a message browser on the current method."

	contextStackIndex = 0 ifTrue: [^ self].
	^ Browser
		openMessageBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName
		editString: nil! !

!Debugger methodsFor: 'context stack menu' stamp: 'rhi 12/20/2000 16:56'!
buildMorphicNotifierLabelled: label message: messageString
	| notifyPane window contentTop extentToUse |
	self expandStack.
	window _ (PreDebugWindow labelled: label) model: self.

	contentTop _ 0.2.
	extentToUse _ 450 @ 156. "nice and wide to show plenty of the error msg"
	window addMorph: (self buttonRowForPreDebugWindow: window)
				frame: (0@0 corner: 1 @ contentTop).

	Preferences eToyFriendly
		ifFalse:
			[notifyPane _ PluggableListMorph on: self list: #contextStackList
				selected: #contextStackIndex changeSelected: #debugAt:
				menu: nil keystroke: nil]
		ifTrue:
			[notifyPane _ PluggableTextMorph on: self text: nil accept: nil
				readSelection: nil menu: #debugProceedMenu:.
			notifyPane editString: (self preDebugNotifierContentsFrom: messageString);
				askBeforeDiscardingEdits: false].

	window addMorph: notifyPane frame: (0@contentTop corner: 1@1).
	"window deleteCloseBox.
		chickened out by commenting the above line out, sw 8/14/2000 12:54"
	window setBalloonTextForCloseBox.

	^ window openInWorldExtent: extentToUse! !

!Debugger methodsFor: 'context stack menu'!
close: aScheduledController 
	"The argument is a controller on a view of the receiver.
	That view is closed."

	aScheduledController close
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/18/1998 09:24'!
contextStackKey: aChar from: view
	"Respond to a keystroke in the context list"

 	| selector |
	selector _ ContextStackKeystrokes at: aChar ifAbsent: [nil].
	selector ifNil: [self messageListKey: aChar from: view]
		ifNotNil: [self perform: selector]! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 1/4/2001 10:23'!
contextStackMenu: aMenu shifted: shifted
	"Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"

	^ shifted ifFalse: [aMenu labels: 
'fullStack (f)
restart (r)
proceed (p)
step (t)
send (e)
where (w)
peel to first like this
senders of... (n)
implementors of... (m)
inheritance (i)
versions (v)
inst var refs...
inst var defs...
class var refs...
class variables
class refs (N)
browse full (b)
file out 
mail out bug report
more...'
	lines: #(7 11 13 16 19)
	selections: #(fullStack restart proceed doStep send where peelToFirst
browseSendersOfMessages browseMessages methodHierarchy browseVersions
browseInstVarRefs browseInstVarDefs
browseClassVarRefs browseClassVariables browseClassRefs
browseMethodFull fileOutMessage mailOutBugReport
shiftedYellowButtonActivity)]

	ifTrue: [aMenu labels: 
'browse class hierarchy
browse class
browse method (O)
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
revert to previous version
remove from current change set
revert & remove from changes
more...' 
	lines: #(5 7 10)
	selections: #(classHierarchy browseClass 
		openSingleMessageBrowser browseAllMessages findMethodInChangeSets 
		inspectInstances inspectSubInstances
		revertToPreviousVersion 
		removeFromCurrentChanges revertAndForget
		unshiftedYellowButtonActivity)]

! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 8/6/97 13:45'!
currentCompiledMethod
	^ self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 12:19'!
debugProceedMenu: aMenu
	^ aMenu labels: 
'proceed
debug'
	lines: #()
	selections: #(proceed debug )
! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 1/14/1999 09:18'!
doStep
	"Send the selected message in the accessed method, and regain control 
	after the invoked method returns."
	
	| currentContext oldMethod |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext.
	self contextStackIndex > 1
		ifTrue: 
			[currentContext completeCallee: contextStackTop.
			self resetContext: currentContext]
		ifFalse: 
			[currentContext stepToSendOrReturn.
			currentContext willReturn
				ifTrue: 
					[oldMethod _ currentContext method.
					currentContext _ currentContext step.
					currentContext stepToSendOrReturn.
					self resetContext: currentContext.
					oldMethod == currentContext method "didnt used to update pc here"
						ifTrue: [self changed: #contentsSelection]]
				ifFalse: 
					[currentContext completeCallee: currentContext step.
					self changed: #contentsSelection.
					self updateInspectors]]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
down
	"move down the context stack to the previous (enclosing) context"

	self toggleContextStackIndex: contextStackIndex+1! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/17/1998 18:06'!
fullStack
	"Change from displaying the minimal stack to a full one."

	self contextStackList size > 20 "Already expanded"
		ifTrue:
			[self changed: #flash]
		ifFalse:
			[self contextStackIndex = 0 ifFalse: [
				self toggleContextStackIndex: self contextStackIndex].
			self fullyExpandStack]! !

!Debugger methodsFor: 'context stack menu' stamp: 'dvf 11/16/2000 03:12'!
mailOutBugReport
	"Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 
'Squeak could pre-fill the bug form with lots of vital, but
oft-repeated, information like what is the image version, last update
number, VM version, platform, available RAM, author...'

and address it to the list with the appropriate subject prefix."

	| subjectPrefix messageStrm |
	(Smalltalk includesKey: #Celeste)
		ifFalse: [^ self notify: 'no mail reader present'].

	subjectPrefix _ '[BUG]'.

	Cursor write
		showWhile: 
			["Prepare the message"
			messageStrm _ WriteStream on: (String new: 30).
			messageStrm nextPutAll: 'From: ';
			 nextPutAll: Celeste userName;
			 cr;
			 nextPutAll: 'To: squeak@cs.uiuc.edu';
			 cr;
			 nextPutAll: 'Subject: ';
			 nextPutAll: subjectPrefix; 
			 nextPutAll: self interruptedContext printString;
			 cr;cr;
			 nextPutAll: 'here insert explanation of what you were doing, suspect changes youd made and so forth.';cr;cr;
			 nextPutAll: 'Image version: ';
			 nextPutAll: Smalltalk systemInformationString ; cr;cr;
			 nextPutAll: 'VM version: ';
			 nextPutAll: Smalltalk vmVersion, String cr, 'for: ', Smalltalk platformName ; cr;cr;
			 nextPutAll: 'Receiver: ';
			 nextPutAll: receiverInspector object printString; cr;cr;
			 nextPutAll: 'Instance variables: ';cr;
			 nextPutAll: receiverInspector object longPrintString; cr;
			 nextPutAll: 'Method (temp) variables: ';cr;
			 nextPutAll: contextVariablesInspector object tempsAndValues; cr;
			 nextPutAll: 'Stack: '; cr.
			self contextStackList do: [:e | messageStrm nextPutAll: e; cr].

			CelesteComposition
				openForCeleste: Celeste current 
				initialText: messageStrm contents].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 7/18/1999 23:01'!
peelToFirst
	"Peel the stack back to the second occurance of the currently selected message.  Very useful for an infinite recursion.  Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning.  Also frees a lot of space!!"

	| upperGuy meth second |
	contextStackIndex = 0 ifTrue: [^ self beep].
	"self okToChange ifFalse: [^ self]."
	upperGuy _ contextStack at: contextStackIndex.
	meth _ upperGuy method.
	contextStackIndex+1 to: contextStack size do: [:ind |
		(contextStack at: ind) method == meth ifTrue: [
			second _ upperGuy.
			upperGuy _ contextStack at: ind]].
	second ifNil: [second _ upperGuy].
	self resetContext: second.
	interruptedProcess popTo: self selectedContext.! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'!
proceed
	"Proceed execution of the receiver's model, starting after the expression at 
	which an interruption occurred."

	Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [
		self proceed: self topView].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'!
proceed: aTopView 
	"Proceed from the interrupted state of the currently selected context. The 
	argument is the topView of the receiver. That view is closed."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	contextStackIndex > 1 | externalInterrupt not 
		ifTrue: [self selectedContext push: proceedValue].
	self resumeProcess: aTopView! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'!
restart
	"Proceed execution of the receiver's model, starting at the beginning of 
	the currently selected method."

	self restart: self topView.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'!
restart: aTopView 
	"Proceed from the initial state of the currently selected context. The 
	argument is a controller on a view of the receiver. That view is closed."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^self]].
	self selectedContext restart.
	self resumeProcess: aTopView! !

!Debugger methodsFor: 'context stack menu'!
selectPC
	"Toggle the flag telling whether to automatically select the expression 
	currently being executed by the selected context."

	selectingPC _ selectingPC not! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 11:36'!
send
	"Send the selected message in the accessed method, and take control in 
	the method invoked to allow further step or 
send."

	| currentContext |
	"Sensor leftShiftDown ifTrue: [self halt]."
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext.
	currentContext stepToSendOrReturn.
	self contextStackIndex > 1 | currentContext willReturn
		ifTrue: 
			[self changed: #notChanged]
		ifFalse: 
			[currentContext _ currentContext step.
			currentContext stepToSendOrReturn.
			self resetContext: currentContext]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
up
	"move up the context stack to the next (enclosed) context"

	contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:54'!
where
	"Select the expression whose evaluation was interrupted."

	self selectPC! !


!Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'!
contentsSelection

	^ self pcRange! !

!Debugger methodsFor: 'code pane' stamp: 'di 11/16/2000 16:03'!
createSyntaxMorph

	| methodNode rootMorph |
	methodNode _ self selectedClass compilerClass new
			parse: contents
			in: self selectedClass
			notifying: nil.
	(rootMorph _ methodNode asMorphicSyntaxUsing: SyntaxMorph)
		parsedInClass: self selectedClass;
		debugger: self.
	self addDependent: rootMorph.
	^rootMorph

! !

!Debugger methodsFor: 'code pane'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	contextStackIndex = 0
		ifTrue: [^super doItContext]
		ifFalse: [^self selectedContext]! !

!Debugger methodsFor: 'code pane'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^self receiver! !

!Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'!
pc

	^ self pcRange! !

!Debugger methodsFor: 'code pane' stamp: 'di 4/24/2000 07:49'!
pcRange
	"Answer the indices in the source code for the method corresponding to 
	the selected context's program counter value."

	| i methodNode pc end |
	(selectingPC and: [contextStackIndex ~= 0])
		ifFalse: [^1 to: 0].
	sourceMap == nil ifTrue:
		[methodNode _ self selectedClass compilerClass new
			parse: contents in: self selectedClass
			notifying: nil dialect: true.
		sourceMap _ methodNode sourceMap.
		tempNames _ methodNode tempNames.
		self selectedContext method cacheTempNames: tempNames].
	sourceMap size = 0 ifTrue: [^1 to: 0].
	pc_ self selectedContext pc -
		((externalInterrupt and: [contextStackIndex=1])
			ifTrue: [1]
			ifFalse: [2]).
	i _ sourceMap indexForInserting: (Association key: pc value: nil).
	i < 1 ifTrue: [^1 to: 0].
	i > sourceMap size
		ifTrue:
			[end _ sourceMap inject: 0 into:
				[:prev :this | prev max: this value last].
			^ end+1 to: end].
	^(sourceMap at: i) value! !

!Debugger methodsFor: 'code pane' stamp: 'di 1/31/2001 11:14'!
toggleSyntaxMorph
"
	syntaxMorph ifNil:
		[syntaxMorph _ self createSyntaxMorph inAScrollPane.
		syntaxMorph color: Color paleOrange].
	standardTextMorph visible ifTrue: [
		standardTextMorph owner replacePane: standardTextMorph with: syntaxMorph.
		syntaxMorph scroller firstSubmorph update: #contentsSelection.
	] ifFalse: [
		syntaxMorph owner replacePane: syntaxMorph with: standardTextMorph.
	].
"
! !


!Debugger methodsFor: 'code pane menu' stamp: 'tk 4/17/1998 17:25'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	| result |
	(#(debug proceed) includes: selector)		"When I am a notifier window"
		ifTrue: [^ self perform: selector]
		ifFalse: [result _ super perform: selector orSendTo: otherTarget.
				selector == #doIt ifTrue: [
					result ~~ #failedDoit ifTrue: [self proceedValue: result]].
				^ result]! !


!Debugger methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the 
	currently selected context."

	^self selectedClass organization categoryOfElement: self selectedMessageName! !


!Debugger methodsFor: 'class list'!
selectedClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext mclass! !

!Debugger methodsFor: 'class list'!
selectedClassOrMetaClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext mclass! !


!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:28'!
step 
	"Update the inspectors."

	receiverInspector ifNotNil: [receiverInspector step].
	contextVariablesInspector ifNotNil: [contextVariablesInspector step].
! !

!Debugger methodsFor: 'dependents access'!
updateInspectors 
	"Update the inspectors on the receiver's variables."

	receiverInspector update.
	contextVariablesInspector update! !

!Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:25'!
wantsSteps
 
	^ true! !


!Debugger methodsFor: 'private'!
checkContextSelection

	contextStackIndex = 0 ifTrue: [contextStackIndex _ 1]! !

!Debugger methodsFor: 'private' stamp: 'sw 9/23/1999 15:58'!
contextStackIndex: anInteger oldContextWas: oldContext

	| newMethod |
	contextStackIndex _ anInteger.
	anInteger = 0
		ifTrue:
			[tempNames _ sourceMap _ contents _ nil.
			self changed: #contextStackIndex.
			self contentsChanged.
			contextVariablesInspector object: nil.
			receiverInspector object: self receiver.
			^self].
	(newMethod _ oldContext == nil or:
		[oldContext method ~~ self selectedContext method])
		ifTrue:
			[tempNames _ sourceMap _ nil.
			contents _ self selectedMessage.
			self contentsChanged.
			self pcRange "will compute tempNamesunless noFrills"].
	self changed: #contextStackIndex.
	tempNames == nil
		ifTrue: [tempNames _ 
					self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil].
	contextVariablesInspector object: self selectedContext.
	receiverInspector object: self receiver.
	newMethod ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private'!
externalInterrupt: aBoolean

	externalInterrupt _ aBoolean ! !

!Debugger methodsFor: 'private' stamp: 'tk 8/17/2000 15:36'!
isolationRecoveryAdvice
	"Return a notifier message string to be presented in case of recovery from recursive error by revoking the changes in an isolation layer.  This surely ranks as one of Squeak's longer help messages."

	^ 'Warning!! You have encountered a recursive error situation.

Don''t panic, but do read the following advice.  If you were just fooling around, the simplest thing to do is to quit and NOT save, and restart Squeak.  If you care about recovery, then read on...

In the process of diagnosing one error, further errors occurred, making it impossible to give you a debugger to work with.  Squeak has jumped to an outer project where many of the objects and code changes that might have caused this problem are not involved in normal operation.  If you are looking at this window, chances are that this first level of recovery was successful.  If there are changes you care a lot about, try to save them now.  Then, hopefully, from the state in this debugger, you can determine what the problem was and fix it.  Do not save this image until you are confident of its recovery.

You are no longer in the world that is damaged.  The two most likely causes of recursive errors are malformed objects (for instance a corrupt value encountered in any display of the desktop) and recurring code errors (such as a change that causes errors in any attempt to display the desktop).

In the case of malformed objects, you can attempt to repair them by altering various bindings in the corrupted environment.  Open this debugger and examine the state of the objects closest to the error.

In the case of code errors, note that you are no longer in a world where the erroneous code is in effect.  The only simple option available is for you to browse to the changeSet for the project in distress, and remove one or more of the changes (later it will be possible to edit the code remotely from here).

If you feel you have repaired the problem, then you may proceed from this debugger.  This will put you back in the project that failed with the changes that failed for another try.  Note that the debugger from which you are proceeding is the second one that occurred;  you will likely find the first one waiting for you when you reenter the failed project!!  Also note that if your error occurred while displaying a morph, it may now be flagged as undisplayable (red with yellow cross);  if so, use the morph debug menu to choose ''start drawing again''.

If you have not repaired the problem, you should close this debugger and delete the failed project after retrieving whatever may be of value in it.

Good luck.

	- The Squeak Fairy Godmother

PS:  If you feel you need the help of a quantum mechanic, do NOT close this window.  Instead, the best thing to do (after saving anything that seems safe to save) would be to use the ''save as...'' command in the world menu, and give it a new image name, such as OOPS.  There is a good chance that someone who knows their way around Squeak can help you out.
'! !

!Debugger methodsFor: 'private' stamp: 'jm 5/1/1998 16:20'!
lowSpaceChoices
	"Return a notifier message string to be presented when space is running low."

	^ 'Warning!! Squeak is almost out of memory!!

Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution.

Here are some suggestions:

Ä If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem.

Ä If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available...
   > Close any windows that are not needed.
   > Get rid of some large objects (e.g., images).
   > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window.

Ä If you want to investigate further, choose "debug" in this window.  Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!).

'
! !

!Debugger methodsFor: 'private'!
newStack: stack
	| oldStack diff |
	oldStack _ contextStack.
	contextStack _ stack.
	(oldStack == nil or: [oldStack last ~~ stack last])
		ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString].
				^ self].
	"May be able to re-use some of previous list"
	diff _ stack size - oldStack size.
	contextStackList _ diff <= 0
		ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size]
		ifFalse: [diff > 1
				ifTrue: [contextStack collect: [:ctx | ctx printString]]
				ifFalse: [(Array with: stack first printString) , contextStackList]]! !

!Debugger methodsFor: 'private' stamp: 'di 4/14/2000 16:24'!
process: aProcess controller: aController context: aContext

	^ self process: aProcess controller: aController context: aContext isolationHead: nil! !

!Debugger methodsFor: 'private' stamp: 'di 4/14/2000 16:31'!
process: aProcess controller: aController context: aContext isolationHead: projectOrNil

	super initialize.
	Smalltalk at: #MessageTally ifPresent: [:c | c new close].
	contents _ nil. 
	interruptedProcess _ aProcess.
	interruptedController _ aController.
	contextStackTop _ aContext.
	self newStack: (contextStackTop stackOfSize: 1).
	contextStackIndex _ 1.
	externalInterrupt _ false.
	selectingPC _ true.
	isolationHead _ projectOrNil! !

!Debugger methodsFor: 'private' stamp: 'tk 4/15/1998 19:04'!
resetContext: aContext 
	"Used when a new context becomes top-of-stack, for instance when the
	method of the selected context is re-compiled, or the simulator steps or
	returns to a new method. There is room for much optimization here, first
	to save recomputing the whole stack list (and text), and secondly to avoid
	recomposing all that text (by editing the paragraph instead of recreating it)."

	| oldContext |
	oldContext _ self selectedContext.
	contextStackTop _ aContext.
	self newStack: contextStackTop stack.
	self changed: #contextStackList.
	self contextStackIndex: 1 oldContextWas: oldContext.
	self changed: #content.! !

!Debugger methodsFor: 'private' stamp: 'RAA 8/8/2000 10:48'!
resumeProcess: aTopView 
	Smalltalk isMorphic
		ifFalse: [aTopView erase].
	savedCursor
		ifNotNil: [Sensor currentCursor: savedCursor].
	isolationHead
		ifNotNil: [failedProject enterForEmergencyRecovery.
			isolationHead invoke.
			isolationHead _ nil].
	interruptedProcess suspendedContext method
			== (Process compiledMethodAt: #terminate)
		ifFalse: [contextStackIndex > 1
				ifTrue: [interruptedProcess popTo: self selectedContext]
				ifFalse: [interruptedProcess install: self selectedContext].
			Smalltalk isMorphic
				ifTrue: [errorWasInUIProcess
						ifTrue: [Project resumeProcess: interruptedProcess]
						ifFalse: [interruptedProcess resume]]
				ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]].
	"if old process was terminated, just terminate current one"
	interruptedProcess _ nil.
	"Before delete, so release doesn't terminate it"
	Smalltalk isMorphic
		ifTrue: [aTopView delete.
			Display repaintMorphicDisplayNow]
		ifFalse: [aTopView controller closeAndUnscheduleNoErase].
	Smalltalk installLowSpaceWatcher.
	"restart low space handler"
	errorWasInUIProcess == false
		ifFalse: [Processor terminateActive]! !

!Debugger methodsFor: 'private'!
selectedContext

	contextStackIndex = 0
		ifTrue: [^contextStackTop]
		ifFalse: [^contextStack at: contextStackIndex]! !

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

Debugger class
	instanceVariableNames: ''!

!Debugger class methodsFor: 'class initialization' stamp: 'di 1/14/1999 09:17'!
initialize
	ErrorRecursion _ false.
	ContextStackKeystrokes _ Dictionary new
		at: $e put: #send;
		at: $t put: #doStep;
		at: $p put: #proceed;
		at: $r put: #restart;
		at: $f put: #fullStack;
		at: $w put: #where;
		yourself.

	"Debugger initialize"! !


!Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'!
context: aContext 
	"Answer an instance of me for debugging the active process starting with the given context."

	^ self context: aContext isolationHead: nil! !

!Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'!
context: aContext isolationHead: isolationHead
	"Answer an instance of me for debugging the active process starting with the given context."

	^ self new
		process: Processor activeProcess
		controller:
			((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess])
				ifTrue: [ScheduledControllers activeController]
				ifFalse: [nil])
		context: aContext
		isolationHead: isolationHead
! !


!Debugger class methodsFor: 'opening' stamp: 'RAA 6/3/2000 09:18'!
openContext: aContext label: aString contents: contentsString
	| isolationHead |
	"Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
	<primitive: 19> "Simulation guard"
	ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue:
		[Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log'].
	ErrorRecursion ifTrue:
		[ErrorRecursion _ false.
		(isolationHead _ CurrentProjectRefactoring currentIsolationHead)
			ifNil: [self primitiveError: aString]
			ifNotNil: [isolationHead revoke]].
	ErrorRecursion _ true.
	(Debugger context: aContext isolationHead: isolationHead)
		openNotifierContents: contentsString
		label: aString.
	ErrorRecursion _ false.
	Processor activeProcess suspend.
! !

!Debugger class methodsFor: 'opening' stamp: 'ar 5/1/1999 09:25'!
openInterrupt: aString onProcess: interruptedProcess
	"Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
	| debugger |
	<primitive: 19> "Simulation guard"
	debugger _ self new.
	debugger
		process: interruptedProcess
		controller: ((Smalltalk isMorphic not
					and: [ScheduledControllers activeControllerProcess == interruptedProcess])
						ifTrue: [ScheduledControllers activeController])
		context: interruptedProcess suspendedContext.
	debugger externalInterrupt: true.

Preferences logDebuggerStackToFile ifTrue:
	[(aString includesSubString: 'Space') & 
		(aString includesSubString: 'low') ifTrue: [
			Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']].

	^ debugger
		openNotifierContents: debugger interruptedContext shortStack
		label: aString
! !
InstructionStream subclass: #Decompiler
	instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit lastJumpPc lastReturnPc limit hasValue blockStackBase '
	classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag '
	poolDictionaries: ''
	category: 'System-Compiler'!
!Decompiler commentStamp: '<historical>' prior: 0!
I decompile a method in three phases:
	Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
	Parser: prefix symbolic codes -> node tree (same as the compiler)
	Printer: node tree -> text (done by the nodes)!


!Decompiler methodsFor: 'initialize-release'!
initSymbols: aClass
	| nTemps namedTemps |
	constructor method: method class: aClass literals: method literals.
	constTable _ constructor codeConstants.
	instVars _ Array new: aClass instSize.
	nTemps _ method numTemps.
	namedTemps _ tempVars == nil ifTrue: [Array new] ifFalse: [tempVars].
	tempVars _ (1 to: nTemps) collect:
				[:i | i <= namedTemps size
					ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]
					ifFalse: [constructor codeTemp: i - 1]]! !

!Decompiler methodsFor: 'initialize-release'!
withTempNames: tempNameArray
	tempVars _ tempNameArray! !


!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!
blockForCaseTo: end
	"Decompile a range of code as in statementsForCaseTo:, but return a block node."
	| exprs block oldBase |
	oldBase _ blockStackBase.
	blockStackBase _ stack size.
	exprs _ self statementsForCaseTo: end.
	block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
	blockStackBase _ oldBase.
	lastReturnPc _ -1.  "So as not to mislead outer calls"
	^block! !

!Decompiler methodsFor: 'control'!
blockTo: end
	"Decompile a range of code as in statementsTo:, but return a block node."
	| exprs block oldBase |
	oldBase _ blockStackBase.
	blockStackBase _ stack size.
	exprs _ self statementsTo: end.
	block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
	blockStackBase _ oldBase.
	lastReturnPc _ -1.  "So as not to mislead outer calls"
	^block! !

!Decompiler methodsFor: 'control'!
checkForBlock: receiver
	"We just saw a blockCopy: message. Check for a following block."

	| savePc jump args argPos block |
	receiver == constructor codeThisContext ifFalse: [^false].
	savePc _ pc.
	(jump _ self interpretJump) notNil
		ifFalse:
			[pc _ savePc.  ^nil].
	"Definitely a block"
	jump _ jump + pc.
	argPos _ statements size.
	[self willStorePop]
		whileTrue:
			[stack addLast: ArgumentFlag.  "Flag for doStore:"
			self interpretNextInstructionFor: self].
	args _ Array new: statements size - argPos.
	1 to: args size do:  "Retrieve args"
		[:i | args at: i put: statements removeLast.
		(args at: i) scope: -1  "flag args as block temps"].
	block _ self blockTo: jump.
	stack addLast: (constructor codeArguments: args block: block).
	^true! !

!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!
statementsForCaseTo: end
	"Decompile the method from pc up to end and return an array of
	expressions. If at run time this block will leave a value on the stack,
	set hasValue to true. If the block ends with a jump or return, set exit
	to the destination of the jump, or the end of the method; otherwise, set
	exit = end. Leave pc = end.
	Note that stack initially contains a CaseFlag which will be removed by
	a subsequent Pop instruction, so adjust the StackPos accordingly."

	| blockPos stackPos t |
	blockPos _ statements size.
	stackPos _ stack size - 1. "Adjust for CaseFlag"
	[pc < end]
		whileTrue:
			[lastPc _ pc.  limit _ end.  "for performs"
			self interpretNextInstructionFor: self].
	"If there is an additional item on the stack, it will be the value
	of this block."
	(hasValue _ stack size > stackPos)
		ifTrue:
			[statements addLast: stack removeLast].
	lastJumpPc = lastPc ifFalse: [exit _ pc].
	^self popTo: blockPos! !

!Decompiler methodsFor: 'control'!
statementsTo: end
	"Decompile the method from pc up to end and return an array of
	expressions. If at run time this block will leave a value on the stack,
	set hasValue to true. If the block ends with a jump or return, set exit
	to the destination of the jump, or the end of the method; otherwise, set
	exit = end. Leave pc = end."

	| blockPos stackPos t |
	blockPos _ statements size.
	stackPos _ stack size.
	[pc < end]
		whileTrue:
			[lastPc _ pc.  limit _ end.  "for performs"
			self interpretNextInstructionFor: self].
	"If there is an additional item on the stack, it will be the value
	of this block."
	(hasValue _ stack size > stackPos)
		ifTrue:
			[statements addLast: stack removeLast].
	lastJumpPc = lastPc ifFalse: [exit _ pc].
	^self popTo: blockPos! !


!Decompiler methodsFor: 'instruction decoding'!
blockReturnTop
	"No action needed"! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'tao 8/20/97 22:49'!
case: dist
	"statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"

	| nextCase end thenJump stmtStream elements b node cases otherBlock |
	nextCase _ pc + dist.
	end _ limit.
	"Now add CascadeFlag & keyValueBlock to statements"
	statements addLast: stack removeLast.
	stack addLast: CaseFlag. "set for next pop"
	statements addLast: (self blockForCaseTo: nextCase).
	stack last == CaseFlag
		ifTrue: "Last case"
			["ensure jump is within block (in case thenExpr returns wierdly I guess)"
			stack removeLast. "get rid of CaseFlag".
			thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase].
			stmtStream _ ReadStream on: (self popTo: stack removeLast).
			elements _ OrderedCollection new.
			b _ OrderedCollection new.
			[stmtStream atEnd] whileFalse:
				[(node _ stmtStream next) == CascadeFlag
					ifTrue:
						[elements addLast: (constructor
							codeMessage: (constructor codeBlock: b returns: false)
							selector: (constructor codeSelector: #-> code: #macro)
							arguments: (Array with: stmtStream next)).
						 b _ OrderedCollection new]
					ifFalse: [b addLast: node]].
			b size > 0 ifTrue: [self error: 'Bad cases'].
			cases _ constructor codeBrace: elements.
			otherBlock _ self blockTo: thenJump.
			stack addLast:
				(constructor
					codeMessage: stack removeLast
					selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
					arguments: (Array with: cases with: otherBlock))]! !

!Decompiler methodsFor: 'instruction decoding'!
doDup

	stack last == CascadeFlag
		ifFalse:
			["Save position and mark cascade"
			stack addLast: statements size.
			stack addLast: CascadeFlag].
	stack addLast: CascadeFlag! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/5/2000 09:34'!
doPop

	stack isEmpty ifTrue:
		["Ignore pop in first leg of ifNil for value"
		^ self].
	stack last == CaseFlag
		ifTrue: [stack removeLast]
		ifFalse: [statements addLast: stack removeLast].! !

!Decompiler methodsFor: 'instruction decoding'!
doStore: stackOrBlock
	"Only called internally, not from InstructionStream. StackOrBlock is stack
	for store, statements for storePop."

	| var expr |
	var _ stack removeLast.
	expr _ stack removeLast.
	stackOrBlock addLast: (expr == ArgumentFlag
		ifTrue: [var]
		ifFalse: [constructor codeAssignTo: var value: expr])! !

!Decompiler methodsFor: 'instruction decoding'!
jump: dist

	exit _ pc + dist.
	lastJumpPc _ lastPc! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/6/2000 08:46'!
jump: dist if: condition

	| savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump
		elseJump condHasValue b isIfNil saveStack |
	stack last == CascadeFlag ifTrue: [^ self case: dist].
	elsePc _ lastPc.
	elseStart _ pc + dist.
	end _ limit.
	"Check for bfp-jmp to invert condition.
	Don't be fooled by a loop with a null body."
	sign _ condition.
	savePc _ pc.
	((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])
		ifTrue: [sign _ sign not.  elseStart _ pc + elseDist].
	pc _ savePc.
	ifExpr _ stack removeLast.
	(stack size > 0 and: [stack last == IfNilFlag])
		ifTrue: [stack removeLast.  isIfNil _ true]
		ifFalse: [isIfNil _ false].
	saveStack _ stack.
	stack _ OrderedCollection new.
	thenBlock _ self blockTo: elseStart.
	condHasValue _ hasValue or: [isIfNil].
	"ensure jump is within block (in case thenExpr returns)"
	thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].
	"if jump goes back, then it's a loop"
	thenJump < elseStart
		ifTrue:
			["Must be a while loop...
			thenJump will jump to the beginning of the while expr.  In the case of
			while's with a block in the condition, the while expr
			should include more than just the last expression: find all the
			statements needed by re-decompiling."
			stack _ saveStack.
			pc _ thenJump.
			b _ self statementsTo: elsePc.
			"discard unwanted statements from block"
			b size - 1 timesRepeat: [statements removeLast].
			statements addLast: (constructor
					codeMessage: (constructor codeBlock: b returns: false)
					selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)
					arguments: (Array with: thenBlock)).
			pc _ elseStart.
			self convertToDoLoop]
		ifFalse:
			["Must be a conditional..."
			elseBlock _ self blockTo: thenJump.
			elseJump _ exit.
			"if elseJump is backwards, it is not part of the elseExpr"
			elseJump < elsePc
				ifTrue: [pc _ lastPc].
			isIfNil
			ifTrue: [cond _ constructor
						codeMessage: ifExpr ifNilReceiver
						selector: (sign
							ifTrue: [constructor codeSelector: #ifNotNil: code: #macro]
							ifFalse: [constructor codeSelector: #ifNil: code: #macro])
						arguments: (Array with: thenBlock)]
			ifFalse: [cond _ constructor
						codeMessage: ifExpr
						selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
						arguments:
							(sign
								ifTrue: [Array with: elseBlock with: thenBlock]
								ifFalse: [Array with: thenBlock with: elseBlock])].
			stack _ saveStack.
			condHasValue
				ifTrue: [stack addLast: cond]
				ifFalse: [statements addLast: cond]]! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnConstant: value

	self pushConstant: value; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnReceiver

	self pushReceiver; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'th 3/17/2000 20:48'!
methodReturnTop
	| last |
	last _ stack removeLast "test test" asReturnNode.
	stack size > blockStackBase  "get effect of elided pop before return"
		ifTrue: [statements addLast: stack removeLast].
	exit _ method size + 1.
	lastJumpPc _ lastReturnPc _ lastPc.
	statements addLast: last! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value

	self pushLiteralVariable: value; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
pushActiveContext

	stack addLast: constructor codeThisContext! !

!Decompiler methodsFor: 'instruction decoding'!
pushConstant: value

	| node |
	node _ value == true ifTrue: [constTable at: 2]
		ifFalse: [value == false ifTrue: [constTable at: 3]
		ifFalse: [value == nil ifTrue: [constTable at: 4]
		ifFalse: [constructor codeAnyLiteral: value]]].
	stack addLast: node! !

!Decompiler methodsFor: 'instruction decoding'!
pushLiteralVariable: assoc

	stack addLast: (constructor codeAnyLitInd: assoc)! !

!Decompiler methodsFor: 'instruction decoding'!
pushReceiver

	stack addLast: (constTable at: 1)! !

!Decompiler methodsFor: 'instruction decoding'!
pushReceiverVariable: offset

	| var |
	(var _ instVars at: offset + 1) == nil
		ifTrue:
			["Not set up yet"
			instVars at: offset + 1 put: (var _ constructor codeInst: offset)].
	stack addLast: var! !

!Decompiler methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset

	stack addLast: (tempVars at: offset + 1)! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'di 1/29/2000 08:38'!
send: selector super: superFlag numArgs: numArgs

	| args rcvr selNode msgNode messages |
	args _ Array new: numArgs.
	(numArgs to: 1 by: -1) do:
		[:i | args at: i put: stack removeLast].
	rcvr _ stack removeLast.
	superFlag ifTrue: [rcvr _ constructor codeSuper].
	(selector == #blockCopy: and: [self checkForBlock: rcvr])
		ifFalse:
			[selNode _ constructor codeAnySelector: selector.
			rcvr == CascadeFlag
				ifTrue:
					["May actually be a cascade or an ifNil: for value."
					self willJumpIfFalse
						ifTrue: "= generated by a case macro"
							[selector == #= ifTrue:
								[" = signals a case statement..."
								statements addLast: args first.
								stack addLast: rcvr. "restore CascadeFlag"
								^ self].
							selector == #== ifTrue:
								[" == signals an ifNil: for value..."
								stack removeLast; removeLast.
								rcvr _ stack removeLast.
								stack addLast: IfNilFlag;
									addLast: (constructor
										codeMessage: rcvr
										selector: selNode
										arguments: args).
								^ self].
							self error: 'bad case: ', selector]
						ifFalse:
							[(self willJumpIfTrue and: [selector == #==]) ifTrue:
								[" == signals an ifNotNil: for value..."
								stack removeLast; removeLast.
								rcvr _ stack removeLast.
								stack addLast: IfNilFlag;
									addLast: (constructor
										codeMessage: rcvr
										selector: selNode
										arguments: args).
								^ self].
							msgNode _ constructor codeCascadedMessage: selNode
											arguments: args].
					stack last == CascadeFlag
						ifFalse:
							["Last message of a cascade"
							statements addLast: msgNode.
							messages _ self popTo: stack removeLast.  "Depth saved by first dup"
							msgNode _ constructor
								codeCascade: stack removeLast
								messages: messages]]
				ifFalse:
					[msgNode _ constructor
								codeMessage: rcvr
								selector: selNode
								arguments: args].
			stack addLast: msgNode]! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: assoc

	self pushLiteralVariable: assoc; doStore: stack! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: stack! !

!Decompiler methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: stack! !


!Decompiler methodsFor: 'public access'!
decompile: aSelector in: aClass 
	"See Decompiler|decompile:in:method:. The method is found by looking up 
	the message, aSelector, in the method dictionary of the class, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: (aClass compiledMethodAt: aSelector)! !

!Decompiler methodsFor: 'public access'!
decompile: aSelector in: aClass method: aMethod
	"Answer a MethodNode that is the root of the parse tree for the 
	argument, aMethod, which is the CompiledMethod associated with the 
	message, aSelector. Variables are determined with respect to the 
	argument, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: aMethod
		using: DecompilerConstructor new! !

!Decompiler methodsFor: 'public access'!
tempAt: offset
	"Needed by BraceConstructor<PopIntoTemporaryVariable"

	^tempVars at: offset + 1! !


!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 11:06'!
convertToDoLoop
	"If statements contains the pattern
		var _ startExpr.
		[var <= limit] whileTrue: [...statements... var _ var + incConst]
	then replace this by
		startExpr to: limit by: incConst do: [:var | ...statements...]"
	| initStmt toDoStmt limitStmt |
	statements size < 2 ifTrue: [^ self].
	initStmt _ statements at: statements size-1.
	(toDoStmt _ statements last toDoFromWhileWithInit: initStmt)
		== nil ifTrue: [^ self].
	initStmt variable scope: -1.  "Flag arg as block temp"
	statements removeLast; removeLast; addLast: toDoStmt.

	"Attempt further conversion of the pattern
		limitVar _ limitExpr.
		startExpr to: limitVar by: incConst do: [:var | ...statements...]
	to
		startExpr to: limitExpr by: incConst do: [:var | ...statements...]"
	statements size < 2 ifTrue: [^ self].
	limitStmt _ statements at: statements size-1.
	((limitStmt isMemberOf: AssignmentNode)
		and: [limitStmt variable isTemp
		and: [limitStmt variable == toDoStmt arguments first
		and: [self methodRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]])
		ifFalse: [^ self].
	toDoStmt arguments at: 1 put: limitStmt value.
	limitStmt variable scope: -2.  "Flag limit var so it won't print"
	statements removeLast; removeLast; addLast: toDoStmt.

! !

!Decompiler methodsFor: 'private'!
decompile: aSelector in: aClass method: aMethod using: aConstructor

	| block |
	constructor _ aConstructor.
	method _ aMethod.
	self initSymbols: aClass.  "create symbol tables"
	method isQuick
		ifTrue: [block _ self quickMethod]
		ifFalse: 
			[stack _ OrderedCollection new: method frameSize.
			statements _ OrderedCollection new: 20.
			super method: method pc: method initialPC.
			block _ self blockTo: method endPC + 1.
			stack isEmpty ifFalse: [self error: 'stack not empty']].
	^constructor
		codeMethod: aSelector
		block: block
		tempVars: (tempVars select: [:t | t scope >=0])
		primitive: method primitive
		class: aClass! !

!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 08:49'!
interpretNextInstructionFor: client

	| code varNames |

"Change false here will trace all state in Transcript."
true ifTrue: [^ super interpretNextInstructionFor: client].

	varNames _ Decompiler allInstVarNames.
	code _ (self method at: pc) radix: 16.
	Transcript cr; cr; print: pc; space;
		nextPutAll: '<' , (code copyFrom: 4 to: code size) , '>'.
	8 to: varNames size do:
		[:i | i <= 10 ifTrue: [Transcript cr]
				ifFalse: [Transcript space; space].
		Transcript nextPutAll: (varNames at: i);
				nextPutAll: ': '; print: (self instVarAt: i)].
	Transcript endEntry.
	^ super interpretNextInstructionFor: client! !

!Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 10:55'!
methodRefersOnlyOnceToTemp: offset
	| nRefs byteCode extension scanner |
	nRefs _ 0.
	offset <= 15
		ifTrue:
			[byteCode _ 16 + offset.
			(InstructionStream on: method) scanFor:
				[:instr | instr = byteCode ifTrue: [nRefs _ nRefs + 1].
				nRefs > 1]]
		ifFalse:
			[extension _ 64 + offset.
			scanner _ InstructionStream on: method.
			scanner scanFor:
				[:instr | (instr = 128 and: [scanner followingByte = extension])
							ifTrue: [nRefs _ nRefs + 1].
				nRefs > 1]].
	^ nRefs = 1
! !

!Decompiler methodsFor: 'private'!
popTo: oldPos

	| t |
	t _ Array new: statements size - oldPos.
	(t size to: 1 by: -1) do:
		[:i | t at: i put: statements removeLast].
	^t! !

!Decompiler methodsFor: 'private' stamp: 'di 12/26/1998 21:29'!
quickMethod
	| |
	method isReturnSpecial
		ifTrue: [^ constructor codeBlock:
				(Array with: (constTable at: method primitive - 255)) returns: true].
	method isReturnField
		ifTrue: [^ constructor codeBlock:
				(Array with: (constructor codeInst: method returnField)) returns: true].
	self error: 'improper short method'! !

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

Decompiler class
	instanceVariableNames: ''!

!Decompiler class methodsFor: 'class initialization' stamp: 'di 1/28/2000 22:21'!
initialize

	CascadeFlag _ 'cascade'.  "A unique object"
	CaseFlag _ 'case'. "Ditto"
	ArgumentFlag _ 'argument'.  "Ditto"
	IfNilFlag _ 'ifNil'.  "Ditto"

	"Decompiler initialize"! !
ParseNode subclass: #DecompilerConstructor
	instanceVariableNames: 'method instVars nArgs literalValues tempVars '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!DecompilerConstructor commentStamp: '<historical>' prior: 0!
I construct the node tree for a Decompiler.!


!DecompilerConstructor methodsFor: 'initialize-release'!
method: aMethod class: aClass literals: literals

	method _ aMethod.
	instVars _ aClass allInstVarNames.
	nArgs _ method numArgs.
	literalValues _ literals! !


!DecompilerConstructor methodsFor: 'constructor'!
codeAnyLitInd: association

	^VariableNode new
		name: association key
		key: association
		index: 0
		type: LdLitIndType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAnyLiteral: value

	^LiteralNode new
		key: value
		index: 0
		type: LdLitType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAnySelector: selector

	^SelectorNode new
		key: selector
		index: 0
		type: SendType! !

!DecompilerConstructor methodsFor: 'constructor'!
codeArguments: args block: block

	^block arguments: args! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAssignTo: variable value: expression

	^AssignmentNode new variable: variable value: expression! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'!
codeBlock: statements returns: returns
	^ BlockNode statements: statements returns: returns! !

!DecompilerConstructor methodsFor: 'constructor'!
codeBrace: elements

	^BraceNode new elements: elements! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 11/19/1999 11:06'!
codeCascade: receiver messages: messages

	^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages)
		ifNil: [CascadeNode new receiver: receiver messages: messages]! !

!DecompilerConstructor methodsFor: 'constructor'!
codeCascadedMessage: selector arguments: arguments

	^self
		codeMessage: nil
		selector: selector
		arguments: arguments! !

!DecompilerConstructor methodsFor: 'constructor'!
codeConstants
	"Answer with an array of the objects representing self, true, false, nil,
	-1, 0, 1, 2."

	^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)
		, ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:35'!
codeEmptyBlock
	^ BlockNode withJust: NodeNil! !

!DecompilerConstructor methodsFor: 'constructor'!
codeInst: index

	^VariableNode new
		name: (instVars at: index + 1)
		index: index
		type: LdInstType! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'!
codeMessage: receiver selector: selector arguments: arguments
	| symbol node |
	symbol _ selector key.
	(node _ BraceNode new
			matchBraceWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	(node _ self decodeIfNilWithReceiver: receiver
			selector: symbol
			arguments: arguments) ifNotNil: [^ node].
	^ MessageNode new
			receiver: receiver selector: selector
			arguments: arguments
			precedence: symbol precedence! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'!
codeMethod: selector block: block tempVars: vars primitive: primitive class: class

	| node |
	node _ self codeSelector: selector code: nil.
	tempVars _ vars.
	^MethodNode new
		selector: node
		arguments: (tempVars copyFrom: 1 to: nArgs)
		precedence: selector precedence
		temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size)
		block: block
		encoder: (Encoder new initScopeAndLiteralTables
					nTemps: tempVars size
					literals: literalValues
					class: class)
		primitive: primitive! !

!DecompilerConstructor methodsFor: 'constructor'!
codeSelector: sel code: code

	^SelectorNode new key: sel code: code! !

!DecompilerConstructor methodsFor: 'constructor'!
codeSuper

	^NodeSuper! !

!DecompilerConstructor methodsFor: 'constructor'!
codeTemp: index

	^ TempVariableNode new
		name: 't' , (index + 1) printString
		index: index
		type: LdTempType
		scope: 0! !

!DecompilerConstructor methodsFor: 'constructor'!
codeTemp: index named: tempName

	^ TempVariableNode new
		name: tempName
		index: index
		type: LdTempType
		scope: 0! !

!DecompilerConstructor methodsFor: 'constructor'!
codeThisContext

	^NodeThisContext! !

!DecompilerConstructor methodsFor: 'constructor' stamp: 'di 1/28/2000 21:23'!
decodeIfNilWithReceiver: receiver selector: selector arguments: arguments

	selector == #ifTrue:ifFalse:
		ifFalse: [^ nil].
	(receiver isMessage: #==
				receiver: nil
				arguments: [:argNode | argNode == NodeNil])
		ifFalse: [^ nil].
	^ (MessageNode new
			receiver: receiver
			selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro)
			arguments: arguments
			precedence: 3)
		noteSpecialSelector: #ifNil:ifNotNil:! !
Object subclass: #DeepCopier
	instanceVariableNames: 'references uniClasses '
	classVariableNames: 'NextVariableCheckTime '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DeepCopier commentStamp: '<historical>' prior: 0!
I do veryDeepCopy.  I hold the dictionary of objects seen, and the correspondance (uniClass -> new uniClass).  See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier).

When a tree of Morphs points at a morph outside of it, that morph should not be copied.  Use our own kind of weak pointers for the potentially outside morphs.   Default is that any new class will have all of its newly defined fields deeply copied.  If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:.
     veryDeepInner: has the loop that actually copies the fields.  If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end.  veryDeepInner: can find an alternate object to put in a field.
(Object veryDeepCopyWith: notes which superclasses did not do veryDeepInner:, and very deep copies those vars).

Key to seeing if you have to add the methods veryDeepFixupWith:   and   veryDeepInner:
Does field X contain a morph?  If not, no action needed.
Is the morph in field X a submorph of the object?  Is it down lower in the submorph tree?
	If so, no action needed.
Could the morph in field X every appear on the screen (be a submorph of some other morph)?
	If not, no action needed.
	If so, you must write the methods veryDeepFixupWith:   and   veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X.


Rule:  If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there.   Each uniClass instance does have a new class created for it.  (fix this by putting the old class in references and allow lookup?  Wrong if encounter it before seeing an instance?)

Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C.  (just be aware of it)

Dependents are now fixed up.  Suppose a model has a dependent view.  In the DependentFields dictionary, model -> (view ...).  
	If only the model is copied, no dependents are created (no one knows about the new model).  
	If only the view is copied, it is inserted into DependentFields on the right side.  model -> (view  copiedView ...).  
	If both are copied, the new model has the new view as its dependent.
	If additional things depend on a model that is copied, the caller must add them to its dependents.
!


!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 1/8/1999 09:37'!
checkDeep
	"Write exceptions in the Transcript.  Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  This check is only run by hand once in a while to make sure nothing was forgotten.
	DeepCopier new checkDeep 	"

| mm |
Transcript cr; show: 'Instance variables shared with the original object when it is copied'.
(Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | 
	(mm _ aClass instVarNames size) > 0 ifTrue: [
		(aClass instSize - mm + 1) to: aClass instSize do: [:index |
			((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [
				Transcript cr; show: aClass name; space; 
					show: (aClass allInstVarNames at: index)]]]].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'di 11/28/1999 20:59'!
checkVariables
	"Check that no indexes of instance vars have changed in certain classes.  If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated.  The idea is to catch a change while it is still in the system of the programmer who made it.  
	DeepCopier new checkVariables	"

	| str str2 meth |
	str _ '|veryDeepCopyWith: or veryDeepInner: is out of date.'.
	Object instSize = 0 ifFalse: [self error: 'Many implementers of veryDeepCopyWith: are out of date'].
	Morph superclass == Object ifFalse: [self error: 'Morph', str].
	(Morph instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 
			'fullBounds' 'color' 'extension') 
		ifFalse: [self error: 'Morph', str].	"added ones are OK"

	"Every class that implements veryDeepInner: must copy all its inst vars.  Danger is that a user will add a new instance variable and forget to copy it.  So check that the last one is mentioned in the copy method."
	(Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | 
		((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [
			aClass instSize > 0 ifTrue: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]].
	(Smalltalk allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | 
		meth _ aClass compiledMethodAt: #veryDeepCopyWith:.
		(meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [
			(meth writesField: aClass instSize) ifFalse: [
				self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]].

	str2 _ 'Player|copyUniClass and DeepCopier|mapUniClasses are out of date'.
	Behavior instVarNames = #('superclass' 'methodDict' 'format' )
		ifFalse: [self error: str2].
	ClassDescription instVarNames = #('instanceVariables' 'organization' )
		ifFalse: [self error: str2].
	Class instVarNames = #('subclasses' 'name' 'classPool' 'sharedPools' 'environment' 'category' )
		ifFalse: [self error: str2].
	Model superclass == Object ifFalse: [self error: str2].
	Player superclass == Model ifFalse: [self error: str2].
	Model class instVarNames = #() ifFalse: [self error: str2].
	Player class instVarNames = #('scripts' 'slotInfo')
		ifFalse: [self error: str2].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'hg 11/23/1999 13:36'!
initialize

	self initialize: 4096.
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'hg 11/23/1999 13:35'!
initialize: size

	references _ IdentityDictionary new: size.
	uniClasses _ IdentityDictionary new.	"UniClass -> new UniClass"
	self isItTimeToCheckVariables ifTrue: [self checkVariables].
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/24/1999 17:53'!
intervalForChecks
	"set delay interval for checking for new instance variables to 10 minutes. hg 11/23/1999"

	^600
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/25/1999 14:37'!
isItTimeToCheckVariables

	| now isIt |
	NextVariableCheckTime ifNil: [
		NextVariableCheckTime _ Time totalSeconds.
		^ true].
	now _ Time totalSeconds.
	isIt _ NextVariableCheckTime < now.
	isIt ifTrue: ["update time for next check"
		NextVariableCheckTime _ now + self intervalForChecks].
	^isIt
! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'di 2/3/2001 16:52'!
mapUniClasses
	"For new Uniclasses, map their class vars to the new objects.  And their additional class instance vars.  (scripts slotInfo) and cross references like (player321)."
	"Players also refer to each other using associations in the References dictionary.  Search the methods of our Players for those.  Make new entries in References and point to them."
| pp oldPlayer newKey newAssoc oldSelList newSelList |

"Uniclasses use class vars to hold onto siblings who are referred to in code"
pp _ Object class instSize + 1.
uniClasses do: [:playersClass | "values = new ones"
	playersClass classPool associationsDo: [:assoc |
		assoc value: (assoc value veryDeepCopyWith: self)].
	playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self).	"pp+0"
	"(pp+1) slotInfo was deepCopied in copyUniClass and that's all it needs"
	pp+2 to: playersClass class instSize do: [:i | 
		playersClass instVarAt: i put: 
			((playersClass instVarAt: i) veryDeepCopyWith: self)].
	].

"Make new entries in References and point to them."
References keys "copy" do: [:playerName |
	oldPlayer _ References at: playerName.
	(references includesKey: oldPlayer) ifTrue: [
		newKey _ (references at: oldPlayer) "new player" uniqueNameForReference.
		"now installed in References"
		(references at: oldPlayer) renameTo: newKey]].
uniClasses "values" do: [:newClass |
	oldSelList _ OrderedCollection new.   newSelList _ OrderedCollection new.
	newClass selectorsDo: [:sel | 
		(newClass compiledMethodAt: sel)	 literals do: [:assoc |
			assoc class == Association ifTrue: [
				(References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [
					newKey _ (references at: assoc value ifAbsent: [assoc value]) 
									externalName asSymbol.
					(assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [
						newAssoc _ References associationAt: newKey.
						newClass methodDictionary at: sel put: 
							(newClass compiledMethodAt: sel) clone.	"were sharing it"
						(newClass compiledMethodAt: sel)
							literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc)
							put: newAssoc.
						(oldSelList includes: assoc key) ifFalse: [
							oldSelList add: assoc key.  newSelList add: newKey]]]]]].
	oldSelList with: newSelList do: [:old :new |
			newClass replaceSilently: old to: new]].	"This is text replacement and can be wrong"! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/20/1998 22:13'!
references
	^ references! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/19/1998 15:48'!
uniClasses
	^uniClasses! !

!DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 1/8/1999 07:17'!
warnIverNotCopiedIn: aClass sel: sel
	"Warn the user to update veryDeepCopyWith: or veryDeepInner:"

	self inform: ('Your file operation succeeded.\\An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs.
	Browser openMessageBrowserForClass: aClass selector: sel editString: nil.
! !
StandardSystemController subclass: #DeferredActionStandardSystemController
	instanceVariableNames: 'queue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NK-Process Browser'!
!DeferredActionStandardSystemController commentStamp: '<historical>' prior: 0!
This is a StandardSystemController that can queue up objects to be evaluated before its control loop.!


!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'nk 10/28/2000 22:28'!
addDeferredUIMessage: valuableObject 
	queue nextPut: valuableObject! !

!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'nk 10/28/2000 22:27'!
controlActivity
	[queue isEmpty]
		whileFalse: [queue next value].
	^super controlActivity! !

!DeferredActionStandardSystemController methodsFor: 'as yet unclassified' stamp: 'nk 10/28/2000 22:28'!
initialize
	super initialize.
	queue _ SharedQueue new.! !
InflatePlugin subclass: #DeflatePlugin
	instanceVariableNames: 'zipHashHead zipHashTail zipHashValue zipBlockPos zipBlockStart zipLiterals zipDistances zipLiteralFreq zipDistanceFreq zipLiteralCount zipLiteralSize zipMatchCount zipMatchLengthCodes zipDistanceCodes zipCrcTable zipExtraLengthBits zipExtraDistanceBits zipBaseLength zipBaseDistance '
	classVariableNames: 'DeflateHashBits DeflateHashMask DeflateHashShift DeflateHashTableSize DeflateMaxDistance DeflateMaxDistanceCodes DeflateMaxLiteralCodes DeflateMaxMatch DeflateMinMatch DeflateWindowMask DeflateWindowSize '
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!DeflatePlugin methodsFor: 'primitives' stamp: 'ar 12/29/1999 22:21'!
primitiveDeflateBlock
	"Primitive. Deflate the current contents of the receiver."
	| goodMatch chainLength lastIndex rcvr result |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 3
		ifFalse:[^interpreterProxy primitiveFail].
	goodMatch _ interpreterProxy stackIntegerValue: 0.
	chainLength _ interpreterProxy stackIntegerValue: 1.
	lastIndex _ interpreterProxy stackIntegerValue: 2.
	rcvr _ interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^nil].
	self cCode:'' inSmalltalk:[
		zipMatchLengthCodes _ CArrayAccessor on: ZipWriteStream matchLengthCodes.
		zipDistanceCodes _ CArrayAccessor on: ZipWriteStream distanceCodes].
	(self loadDeflateStreamFrom: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	result _ self deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch.
	interpreterProxy failed ifFalse:[
		"Store back modified values"
		interpreterProxy storeInteger: 6 ofObject: rcvr withValue: zipHashValue.
		interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipBlockPos.
		interpreterProxy storeInteger: 13 ofObject: rcvr withValue: zipLiteralCount.
		interpreterProxy storeInteger: 14 ofObject: rcvr withValue: zipMatchCount].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 4.
		interpreterProxy pushBool: result.
	].! !

!DeflatePlugin methodsFor: 'primitives' stamp: 'ar 12/27/1999 20:42'!
primitiveDeflateUpdateHashTable
	"Primitive. Update the hash tables after data has been moved by delta."
	| delta table tableSize tablePtr entry |
	self export: true.
	self var: #tablePtr declareC:'int *tablePtr'.
	interpreterProxy methodArgumentCount = 2
		ifFalse:[^interpreterProxy primitiveFail].
	delta _ interpreterProxy stackIntegerValue: 0.
	table _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: table)
		ifFalse:[^interpreterProxy primitiveFail].
	tableSize _ interpreterProxy slotSizeOf: table.
	tablePtr _ interpreterProxy firstIndexableField: table.
	0 to: tableSize-1 do:[:i|
		entry _ tablePtr at: i.
		entry >= delta
			ifTrue:[tablePtr at: i put: entry - delta]
			ifFalse:[tablePtr at: i put: 0]].
	interpreterProxy pop: 2. "Leave rcvr on stack"! !

!DeflatePlugin methodsFor: 'primitives' stamp: 'ar 12/30/1999 14:38'!
primitiveUpdateGZipCrc32
	"Primitive. Update a 32bit CRC value."
	| collection stopIndex startIndex crc length bytePtr |
	self export: true.
	self var: #crc declareC:'unsigned int crc'.
	self var: #bytePtr declareC:'unsigned char *bytePtr'.
	self var: #crcTable declareC:'unsigned int *crcTable'.
	interpreterProxy methodArgumentCount = 4
		ifFalse:[^interpreterProxy primitiveFail].
	collection _ interpreterProxy stackObjectValue: 0.
	stopIndex _ interpreterProxy stackIntegerValue: 1.
	startIndex _ interpreterProxy stackIntegerValue: 2.
	crc _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 3).
	interpreterProxy failed ifTrue:[^0].
	((interpreterProxy isBytes: collection) and:[stopIndex >= startIndex and:[startIndex > 0]])
		ifFalse:[^interpreterProxy primitiveFail].
	length _ interpreterProxy byteSizeOf: collection.
	(stopIndex <= length) ifFalse:[^interpreterProxy primitiveFail].
	bytePtr _ interpreterProxy firstIndexableField: collection.
	self cCode:'' inSmalltalk:[zipCrcTable _ CArrayAccessor on: GZipWriteStream crcTable].
	startIndex _ startIndex - 1.
	stopIndex _ stopIndex - 1.
	startIndex to: stopIndex do:[:i|
		crc _ (zipCrcTable at: ((crc bitXor: (bytePtr at: i)) bitAnd: 255)) bitXor: (crc >> 8).
	].
	interpreterProxy pop: 5. "args + rcvr"
	interpreterProxy push: (interpreterProxy positive32BitIntegerFor: crc).! !

!DeflatePlugin methodsFor: 'primitives' stamp: 'ar 12/30/1999 15:54'!
primitiveZipSendBlock
	| distTree litTree distStream litStream rcvr result |
	self export: true.
	interpreterProxy methodArgumentCount = 4 
		ifFalse:[^interpreterProxy primitiveFail].
	distTree _ interpreterProxy stackObjectValue: 0.
	litTree _ interpreterProxy stackObjectValue: 1.
	distStream _ interpreterProxy stackObjectValue: 2.
	litStream _ interpreterProxy stackObjectValue: 3.
	rcvr _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^nil].
	(self loadZipEncoderFrom: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: distTree) and:[
		(interpreterProxy slotSizeOf: distTree) >= 2])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: litTree) and:[
		(interpreterProxy slotSizeOf: litTree) >= 2])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: litStream) and:[
		(interpreterProxy slotSizeOf: litStream) >= 3])
			ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isPointers: distStream) and:[
		(interpreterProxy slotSizeOf: distStream) >= 3])
			ifFalse:[^interpreterProxy primitiveFail].
	self cCode:'' inSmalltalk:[
		zipMatchLengthCodes _ CArrayAccessor on: ZipWriteStream matchLengthCodes.
		zipDistanceCodes _ CArrayAccessor on: ZipWriteStream distanceCodes.
		zipExtraLengthBits _ CArrayAccessor on: ZipWriteStream extraLengthBits.
		zipExtraDistanceBits _ CArrayAccessor on: ZipWriteStream extraDistanceBits.
		zipBaseLength _ CArrayAccessor on: ZipWriteStream baseLength.
		zipBaseDistance _ CArrayAccessor on: ZipWriteStream baseDistance].
	result _ self sendBlock: litStream with: distStream with: litTree with: distTree.
	interpreterProxy failed ifFalse:[
		interpreterProxy storeInteger: 1 ofObject: rcvr withValue: zipPosition.
		interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
		interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 5. "rcvr + args"
		interpreterProxy pushInteger: result.
	].! !


!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 21:59'!
compare: here with: matchPos min: minLength
	"Compare the two strings and return the length of matching characters.
	minLength is a lower bound for match lengths that will be accepted.
	Note: here and matchPos are zero based."
	| length |
	self inline: true.
	"First test if we can actually get longer than minLength"
	(zipCollection at: here+minLength) = (zipCollection at: matchPos+minLength)
		ifFalse:[^0].
	(zipCollection at: here+minLength-1) = (zipCollection at: matchPos+minLength-1)
		ifFalse:[^0].
	"Then test if we have an initial match at all"
	(zipCollection at: here) = (zipCollection at: matchPos)
		ifFalse:[^0].
	(zipCollection at: here+1) = (zipCollection at: matchPos+1)
		ifFalse:[^1].
	"Finally do the real comparison"
	length _ 2.
	[length < DeflateMaxMatch and:[
		(zipCollection at: here+length) = (zipCollection at: matchPos+length)]]
			whileTrue:[length _ length + 1].
	^length! !

!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 22:00'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"Continue deflating the receiver's collection from blockPosition to lastIndex.
	Note that lastIndex must be at least MaxMatch away from the end of collection"
	| here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch |
	self inline: false.
	zipBlockPos > lastIndex ifTrue:[^false]. "Nothing to deflate"
	zipLiteralCount >= zipLiteralSize ifTrue:[^true].
	hasMatch _ false.
	here _ zipBlockPos.
	[here <= lastIndex] whileTrue:[
		hasMatch ifFalse:[
			"Find the first match"
			matchResult _ self findMatch: here
								lastLength: DeflateMinMatch-1
								lastMatch: here
								chainLength: chainLength
								goodMatch: goodMatch.
			self insertStringAt: here. "update hash table"
			hereMatch _ matchResult bitAnd: 16rFFFF.
			hereLength _ matchResult bitShift: -16].

		"Look ahead if there is a better match at the next position"
		matchResult _ self findMatch: here+1
							lastLength: hereLength
							lastMatch: hereMatch
							chainLength: chainLength
							goodMatch: goodMatch.
		newMatch _ matchResult bitAnd: 16rFFFF.
		newLength _ matchResult bitShift: -16.

		"Now check if the next match is better than the current one.
		If not, output the current match (provided that the current match
		is at least MinMatch long)"
		(hereLength >= newLength and:[hereLength >= DeflateMinMatch]) ifTrue:[
			"Encode the current match"
			flushNeeded _ self
				encodeMatch: hereLength
				distance: here - hereMatch.
			"Insert all strings up to the end of the current match.
			Note: The first string has already been inserted."
			1 to: hereLength-1 do:[:i| self insertStringAt: (here _ here + 1)].
			hasMatch _ false.
			here _ here + 1.
		] ifFalse:[
			"Either the next match is better than the current one or we didn't
			have a good match after all (e.g., current match length < MinMatch).
			Output a single literal."
			flushNeeded _ self encodeLiteral: (zipCollection at: here).
			here _ here + 1.
			(here <= lastIndex and:[flushNeeded not]) ifTrue:[
				"Cache the results for the next round"
				self insertStringAt: here.
				hasMatch _ true.
				hereMatch _ newMatch.
				hereLength _ newLength].
		].
		flushNeeded ifTrue:[zipBlockPos _ here. ^true].
	].
	zipBlockPos _ here.
	^false! !

!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 22:00'!
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
	"Find the longest match for the string starting at here.
	If there is no match longer than lastLength return lastMatch/lastLength.
	Traverse at most maxChainLength entries in the hash table.
	Stop if a match of at least goodMatch size has been found."
	| matchResult matchPos distance chainLength limit bestLength length |
	self inline: false.
	"Compute the default match result"
	matchResult _ (lastLength bitShift: 16) bitOr: lastMatch.

	"There is no way to find a better match than MaxMatch"
	lastLength >= DeflateMaxMatch ifTrue:[^matchResult].

	"Start position for searches"
	matchPos _ zipHashHead at: (self updateHashAt: here + DeflateMinMatch - 1).

	"Compute the distance to the (possible) match"
	distance _ here - matchPos.

	"Note: It is required that 0 < distance < MaxDistance"
	(distance > 0 and:[distance < DeflateMaxDistance]) ifFalse:[^matchResult].

	chainLength _ maxChainLength.	"Max. nr of match chain to search"
	here > DeflateMaxDistance	"Limit for matches that are too old"
		ifTrue:[limit _ here - DeflateMaxDistance]
		ifFalse:[limit _ 0].

	"Best match length so far (current match must be larger to take effect)"
	bestLength _ lastLength.

	[true] whileTrue:[
		"Compare the current string with the string at match position"
		length _ self compare: here with: matchPos min: bestLength.
		"Truncate accidental matches beyound stream position"
		(here + length > zipPosition) ifTrue:[length _ zipPosition - here].
		"Ignore very small matches if they are too far away"
		(length = DeflateMinMatch and:[(here - matchPos) > (DeflateMaxDistance // 4)])
			ifTrue:[length _ DeflateMinMatch - 1].
		length > bestLength ifTrue:["We have a new (better) match than before"
			"Compute the new match result"
			matchResult _ (length bitShift: 16) bitOr: matchPos.
			bestLength _ length.
			"There is no way to find a better match than MaxMatch"
			bestLength >= DeflateMaxMatch ifTrue:[^matchResult].
			"But we may have a good, fast match"
			bestLength > goodMatch ifTrue:[^matchResult].
		].
		(chainLength _ chainLength - 1) > 0 ifFalse:[^matchResult].
		"Compare with previous entry in hash chain"
		matchPos _ zipHashTail at: (matchPos bitAnd: DeflateWindowMask).
		matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
	].! !

!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 21:59'!
insertStringAt: here
	"Insert the string at the given start position into the hash table.
	Note: The hash value is updated starting at MinMatch-1 since
	all strings before have already been inserted into the hash table
	(and the hash value is updated as well)."
	| prevEntry |
	self inline: true.
	zipHashValue _ self updateHashAt: (here + DeflateMinMatch - 1).
	prevEntry _ zipHashHead at: zipHashValue.
	zipHashHead at: zipHashValue put: here.
	zipHashTail at: (here bitAnd: DeflateWindowMask) put: prevEntry.! !

!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:28'!
updateHash: nextValue
	"Update the running hash value based on the next input byte.
	Return the new updated hash value."
	^((zipHashValue bitShift: DeflateHashShift) bitXor: nextValue) bitAnd: DeflateHashMask.! !

!DeflatePlugin methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:29'!
updateHashAt: here
	"Update the hash value at position here (one based)"
	^self updateHash: (zipCollection at: here)! !


!DeflatePlugin methodsFor: 'encoding' stamp: 'ar 12/29/1999 20:37'!
encodeLiteral: lit
	"Encode the given literal"
	self inline: true.
	zipLiterals at: zipLiteralCount put: lit.
	zipDistances at: zipLiteralCount put: 0.
	zipLiteralFreq at: lit put: (zipLiteralFreq at: lit) + 1.
	zipLiteralCount _ zipLiteralCount + 1.
	^zipLiteralCount = zipLiteralSize "We *must* flush"
		or:[(zipLiteralCount bitAnd: 16rFFF) = 0 "Only check every N kbytes"
			and:[self shouldFlush]]! !

!DeflatePlugin methodsFor: 'encoding' stamp: 'ar 12/29/1999 20:37'!
encodeMatch: length distance: dist
	"Encode the given match of length length starting at dist bytes ahead"
	| literal distance |
	self inline: true.
	zipLiterals at: zipLiteralCount put: length - DeflateMinMatch.
	zipDistances at: zipLiteralCount put: dist.
	literal _ (zipMatchLengthCodes at: length - DeflateMinMatch).
	zipLiteralFreq at: literal put: (zipLiteralFreq at: literal) + 1.
	dist < 257
		ifTrue:[distance _ zipDistanceCodes at: dist - 1]
		ifFalse:[distance _ zipDistanceCodes at: 256 + (dist - 1 bitShift: -7)].
	zipDistanceFreq at: distance put: (zipDistanceFreq at: distance) + 1.
	zipLiteralCount _ zipLiteralCount + 1.
	zipMatchCount _ zipMatchCount + 1.
	^zipLiteralCount = zipLiteralSize "We *must* flush"
		or:[(zipLiteralCount bitAnd: 16rFFF) = 0 "Only check every N kbytes"
			and:[self shouldFlush]]! !

!DeflatePlugin methodsFor: 'encoding' stamp: 'ar 12/30/1999 15:26'!
nextZipBits: nBits put: value
	"Require:
		zipCollection, zipCollectionSize, zipPosition,
		zipBitBuf, zipBitPos.
	"
	self inline: true.
	(value >= 0 and:[(1 << nBits) > value])
		ifFalse:[^interpreterProxy primitiveFail].
	zipBitBuf _ zipBitBuf bitOr: (value bitShift: zipBitPos).
	zipBitPos _ zipBitPos + nBits.
	[zipBitPos >= 8 and:[zipPosition < zipCollectionSize]] whileTrue:[
		zipCollection at: zipPosition put: (zipBitBuf bitAnd: 255).
		zipPosition _ zipPosition + 1.
		zipBitBuf _ zipBitBuf >> 8.
		zipBitPos _ zipBitPos - 8].
! !

!DeflatePlugin methodsFor: 'encoding' stamp: 'ar 12/30/1999 18:15'!
sendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Require: 
		zipCollection, zipCollectionSize, zipPosition,
		zipBitBuf, zipBitPos.
	"
	| oop litPos litLimit litArray distArray lit dist sum llBitLengths llCodes distBitLengths distCodes code extra litBlCount distBlCount |
	self var: #litArray declareC:'unsigned char *litArray'.
	self var: #distArray declareC:'unsigned int *distArray'.
	self var: #llBitLengths declareC:'unsigned int *llBitLengths'.
	self var: #llCodes declareC:'unsigned int *llCodes'.
	self var: #distBitLengths declareC:'unsigned int *distBitLengths'.
	self var: #distCodes declareC:'unsigned int *distCodes'.
	oop _ interpreterProxy fetchPointer: 0 ofObject: literalStream.
	litPos _ interpreterProxy fetchInteger: 1 ofObject: literalStream.
	litLimit _ interpreterProxy fetchInteger: 2 ofObject: literalStream.
	((interpreterProxy isIntegerObject: oop) not and:[litPos <= litLimit and:[
		litLimit <= (interpreterProxy byteSizeOf: oop) and:[interpreterProxy isBytes: oop]]])
			ifFalse:[^interpreterProxy primitiveFail].
	litArray _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 0 ofObject: distanceStream.
	((interpreterProxy isIntegerObject: oop) not and:[
		(interpreterProxy fetchInteger: 1 ofObject: distanceStream) = litPos and:[
			(interpreterProxy fetchInteger: 2 ofObject: distanceStream) = litLimit]])
				ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isWords: oop) and:[
		litLimit <= (interpreterProxy slotSizeOf: oop)])
			ifFalse:[^interpreterProxy primitiveFail].
	distArray _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 0 ofObject: litTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	litBlCount _ interpreterProxy slotSizeOf: oop.
	llBitLengths _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 1 ofObject: litTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	(litBlCount = (interpreterProxy slotSizeOf: oop))
		ifFalse:[^interpreterProxy primitiveFail].
	llCodes _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 0 ofObject: distTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	distBlCount _ interpreterProxy slotSizeOf: oop.
	distBitLengths _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 1 ofObject: distTree.
	((interpreterProxy isIntegerObject: oop) not and:[interpreterProxy isWords: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	(distBlCount = (interpreterProxy slotSizeOf: oop))
		ifFalse:[^interpreterProxy primitiveFail].
	distCodes _ interpreterProxy firstIndexableField: oop.

	interpreterProxy failed ifTrue:[^nil].

	self nextZipBits: 0 put: 0. "Flush pending bits if necessary"
	sum _ 0.
	[litPos < litLimit and:[zipPosition + 4 < zipCollectionSize]] whileTrue:[
		lit _ litArray at: litPos.
		dist _ distArray at: litPos.
		litPos _ litPos + 1.
		dist = 0 ifTrue:["literal"
			sum _ sum + 1.
			lit < litBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (llBitLengths at: lit) put: (llCodes at: lit).
		] ifFalse:["match"
			sum _ sum + lit + DeflateMinMatch.
			lit < 256 ifFalse:[^interpreterProxy primitiveFail].
			code _ zipMatchLengthCodes at: lit.
			code < litBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (llBitLengths at: code) put: (llCodes at: code).
			extra _ zipExtraLengthBits at: code - 257.
			extra = 0 ifFalse:[
				lit _ lit - (zipBaseLength at: code - 257).
				self nextZipBits: extra put: lit].
			dist _ dist - 1.
			dist < 16r8000 ifFalse:[^interpreterProxy primitiveFail].
			dist < 256
				ifTrue:[code _ zipDistanceCodes at: dist]
				ifFalse:[code _ zipDistanceCodes at: 256 + (dist >> 7)].
			code < distBlCount ifFalse:[^interpreterProxy primitiveFail].
			self nextZipBits: (distBitLengths at: code) put: (distCodes at: code).
			extra _ zipExtraDistanceBits at: code.
			extra = 0 ifFalse:[
				dist _ dist - (zipBaseDistance at: code).
				self nextZipBits: extra put: dist].
		].
	].
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy storeInteger: 1 ofObject: literalStream withValue: litPos.
	interpreterProxy storeInteger: 1 ofObject: distanceStream withValue: litPos.
	^sum! !

!DeflatePlugin methodsFor: 'encoding' stamp: 'ar 12/29/1999 22:00'!
shouldFlush
	"Check if we should flush the current block.
	Flushing can be useful if the input characteristics change."
	| nLits |
	self inline: false.
	zipLiteralCount = zipLiteralSize ifTrue:[^true]. "We *must* flush"
	(zipLiteralCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
	zipMatchCount * 10 <= zipLiteralCount ifTrue:[
		"This is basically random data. 
		There is no need to flush early since the overhead
		for encoding the trees will add to the overall size"
		^false].
	"Try to adapt to the input data.
	We flush if the ratio between matches and literals
	changes beyound a certain threshold"
	nLits _ zipLiteralCount - zipMatchCount.
	nLits <= zipMatchCount ifTrue:[^false]. "whow!! so many matches"
	^nLits * 4 <= zipMatchCount! !


!DeflatePlugin methodsFor: 'primitive support' stamp: 'ar 12/30/1999 15:28'!
loadDeflateStreamFrom: rcvr
	| oop |
	self inline: false.
	((interpreterProxy isPointers: rcvr) and:[
		(interpreterProxy slotSizeOf: rcvr) >= 15]) ifFalse:[^false].
	oop _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection _ interpreterProxy firstIndexableField: oop.
	zipCollectionSize _ interpreterProxy byteSizeOf: oop.

	zipPosition _ interpreterProxy fetchInteger: 1 ofObject: rcvr.
	zipReadLimit _ interpreterProxy fetchInteger: 2 ofObject: rcvr.
	"zipWriteLimit _ interpreterProxy fetchInteger: 3 ofObject: rcvr."

	oop _ interpreterProxy fetchPointer: 4 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateHashTableSize ifFalse:[^false].
	zipHashHead _ interpreterProxy firstIndexableField: oop.
	oop _ interpreterProxy fetchPointer: 5 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateWindowSize ifFalse:[^false].
	zipHashTail _ interpreterProxy firstIndexableField: oop.
	zipHashValue _ interpreterProxy fetchInteger: 6 ofObject: rcvr.
	zipBlockPos _ interpreterProxy fetchInteger: 7 ofObject: rcvr.
	"zipBlockStart _ interpreterProxy fetchInteger: 8 ofObject: rcvr."
	oop _ interpreterProxy fetchPointer: 9 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isBytes: oop) not]) ifTrue:[^false].
	zipLiteralSize _ interpreterProxy slotSizeOf: oop.
	zipLiterals _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 10 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) < zipLiteralSize ifTrue:[^false].
	zipDistances _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 11 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateMaxLiteralCodes ifFalse:[^false].
	zipLiteralFreq _ interpreterProxy firstIndexableField: oop.

	oop _ interpreterProxy fetchPointer: 12 ofObject: rcvr.
	((interpreterProxy isIntegerObject: oop) or:[
		(interpreterProxy isWords: oop) not]) ifTrue:[^false].
	(interpreterProxy slotSizeOf: oop) = DeflateMaxDistanceCodes ifFalse:[^false].
	zipDistanceFreq _ interpreterProxy firstIndexableField: oop.

	zipLiteralCount _ interpreterProxy fetchInteger: 13 ofObject: rcvr.
	zipMatchCount _ interpreterProxy fetchInteger: 14 ofObject: rcvr.

	^interpreterProxy failed not! !

!DeflatePlugin methodsFor: 'primitive support' stamp: 'ar 12/30/1999 15:28'!
loadZipEncoderFrom: rcvr
	| oop |
	self inline: false.
	((interpreterProxy isPointers: rcvr) and:[
		(interpreterProxy slotSizeOf: rcvr) >= 6]) ifFalse:[^false].
	oop _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection _ interpreterProxy firstIndexableField: oop.
	zipCollectionSize _ interpreterProxy byteSizeOf: oop.

	zipPosition _ interpreterProxy fetchInteger: 1 ofObject: rcvr.
	zipReadLimit _ interpreterProxy fetchInteger: 2 ofObject: rcvr.
	"zipWriteLimit _ interpreterProxy fetchInteger: 3 ofObject: rcvr."
	zipBitBuf _ interpreterProxy fetchInteger: 4 ofObject: rcvr.
	zipBitPos _ interpreterProxy fetchInteger: 5 ofObject: rcvr.

	^interpreterProxy failed not! !

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

DeflatePlugin class
	instanceVariableNames: ''!

!DeflatePlugin class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 20:54'!
initialize
	"DeflatePlugin initialize"
	DeflateWindowSize _ 16r8000.
	DeflateWindowMask _ DeflateWindowSize - 1.
	DeflateMinMatch _ 3.
	DeflateMaxMatch _ 258.
	DeflateMaxDistance _ DeflateWindowSize.
	DeflateHashBits _ 15.
	DeflateHashTableSize _ 1 << DeflateHashBits.
	DeflateHashMask _ DeflateHashTableSize - 1.
	DeflateHashShift _ (DeflateHashBits + DeflateMinMatch - 1) // DeflateMinMatch.
	DeflateMaxLiteralCodes _ ZipWriteStream maxLiteralCodes.
	DeflateMaxDistanceCodes _ ZipWriteStream maxDistanceCodes.! !


!DeflatePlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:33'!
declareCVarsIn: cg
	super declareCVarsIn: cg. "Required since we share some instVars"
	cg var: #zipHashHead type: #'unsigned int*'.
	cg var: #zipHashTail type: #'unsigned int*'.
	cg var: #zipLiterals type: #'unsigned char*'.
	cg var: #zipDistances type: #'unsigned int*'.
	cg var: #zipLiteralFreq type: #'unsigned int*'.
	cg var: #zipDistanceFreq type: #'unsigned int*'.
	cg var: #zipMatchLengthCodes type: #'unsigned int' array: ZipWriteStream matchLengthCodes.
	cg var: #zipDistanceCodes type: #'unsigned int' array: ZipWriteStream distanceCodes.
	cg var: #zipCrcTable type: #'unsigned int' array: GZipWriteStream crcTable.
	cg var: #zipExtraLengthBits type: #'unsigned int' array: ZipWriteStream extraLengthBits.
	cg var: #zipExtraDistanceBits type: #'unsigned int' array: ZipWriteStream extraDistanceBits.
	cg var: #zipBaseLength type: #'unsigned int' array: ZipWriteStream baseLength.
	cg var: #zipBaseDistance type: #'unsigned int' array: ZipWriteStream baseDistance! !
WriteStream subclass: #DeflateStream
	instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart '
	classVariableNames: ''
	poolDictionaries: 'ZipConstants '
	category: 'System-Compression'!

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:30'!
flush
	"Force compression"
	self deflateBlock.! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/31/1999 18:00'!
initialize
	blockStart _ nil.
	blockPosition _ 0.
	hashValue _ 0.
	self initializeHashTables.! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:32'!
initializeHashTables
	hashHead _ WordArray new: 1 << HashBits.
	hashTail _ WordArray new: WindowSize.
! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:33'!
on: aCollection
	self initialize.
	super on: (aCollection species new: WindowSize * 2).! !

!DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/28/1999 17:34'!
on: aCollection from: firstIndex to: lastIndex
	"Not for DeflateStreams please"
	^self shouldNotImplement! !


!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'!
goodMatchLength
	"Return the length that is considered to be a 'good' match.
	Higher values will result in better compression but take more time."
	^MaxMatch "Best compression"! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'!
hashChainLength
	"Return the max. number of hash chains to traverse.
	Higher values will result in better compression but take more time."
	^4096 "Best compression"! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 17:33'!
nextPutAll: aCollection
	| start count max |
	aCollection species = collection species
		ifFalse:[
			aCollection do:[:ch| self nextPut: ch].
			^aCollection].
	start _ 1.
	count _ aCollection size.
	[count = 0] whileFalse:[
		position = writeLimit ifTrue:[self deflateBlock].
		max _ writeLimit - position.
		max > count ifTrue:[max _ count].
		collection replaceFrom: position+1
			to: position+max
			with: aCollection
			startingAt: start.
		start _ start + max.
		count _ count - max.
		position _ position + max].
	^aCollection! !

!DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'!
pastEndPut: anObject
	self deflateBlock.
	^self nextPut: anObject! !


!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'!
compare: here with: matchPos min: minLength
	"Compare the two strings and return the length of matching characters.
	minLength is a lower bound for match lengths that will be accepted.
	Note: here and matchPos are zero based."
	| length |
	"First test if we can actually get longer than minLength"
	(collection at: here+minLength+1) = (collection at: matchPos+minLength+1)
		ifFalse:[^0].
	(collection at: here+minLength) = (collection at: matchPos+minLength)
		ifFalse:[^0].
	"Then test if we have an initial match at all"
	(collection at: here+1) = (collection at: matchPos+1)
		ifFalse:[^0].
	(collection at: here+2) = (collection at: matchPos+2)
		ifFalse:[^1].
	"Finally do the real comparison"
	length _ 3.
	[length <= MaxMatch and:[
		(collection at: here+length) = (collection at: matchPos+length)]]
			whileTrue:[length _ length + 1].
	^length - 1! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/31/1999 18:00'!
deflateBlock
	"Deflate the current contents of the stream"
	| flushNeeded lastIndex |
	(blockStart == nil) ifTrue:[
		"One time initialization for the first block"
		1 to: MinMatch-1 do:[:i| self updateHashAt: i].
		blockStart _ 0].

	[blockPosition < position] whileTrue:[
		(position + MaxMatch > writeLimit)
			ifTrue:[lastIndex _ writeLimit - MaxMatch]
			ifFalse:[lastIndex _ position].
		flushNeeded _ self deflateBlock: lastIndex-1
							chainLength: self hashChainLength
							goodMatch: self goodMatchLength.
		flushNeeded ifTrue:[
			self flushBlock.
			blockStart _ blockPosition].
		"Make room for more data"
		self moveContentsToFront].
! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 18:05'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"Continue deflating the receiver's collection from blockPosition to lastIndex.
	Note that lastIndex must be at least MaxMatch away from the end of collection"
	| here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch |
	blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate"
	hasMatch _ false.
	here _ blockPosition.
	[here <= lastIndex] whileTrue:[
		hasMatch ifFalse:[
			"Find the first match"
			matchResult _ self findMatch: here
								lastLength: MinMatch-1
								lastMatch: here
								chainLength: chainLength
								goodMatch: goodMatch.
			self insertStringAt: here. "update hash table"
			hereMatch _ matchResult bitAnd: 16rFFFF.
			hereLength _ matchResult bitShift: -16].

		"Look ahead if there is a better match at the next position"
		matchResult _ self findMatch: here+1
							lastLength: hereLength
							lastMatch: hereMatch
							chainLength: chainLength
							goodMatch: goodMatch.
		newMatch _ matchResult bitAnd: 16rFFFF.
		newLength _ matchResult bitShift: -16.

		"Now check if the next match is better than the current one.
		If not, output the current match (provided that the current match
		is at least MinMatch long)"
		(hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[
			self assert:[self validateMatchAt: here
							from: hereMatch to: hereMatch + hereLength - 1].
			"Encode the current match"
			flushNeeded _ self
				encodeMatch: hereLength
				distance: here - hereMatch.
			"Insert all strings up to the end of the current match.
			Note: The first string has already been inserted."
			1 to: hereLength-1 do:[:i| self insertStringAt: (here _ here + 1)].
			hasMatch _ false.
			here _ here + 1.
		] ifFalse:[
			"Either the next match is better than the current one or we didn't
			have a good match after all (e.g., current match length < MinMatch).
			Output a single literal."
			flushNeeded _ self encodeLiteral: (collection byteAt: (here + 1)).
			here _ here + 1.
			(here <= lastIndex and:[flushNeeded not]) ifTrue:[
				"Cache the results for the next round"
				self insertStringAt: here.
				hasMatch _ true.
				hereMatch _ newMatch.
				hereLength _ newLength].
		].
		flushNeeded ifTrue:[blockPosition _ here. ^true].
	].
	blockPosition _ here.
	^false! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'!
findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch
	"Find the longest match for the string starting at here.
	If there is no match longer than lastLength return lastMatch/lastLength.
	Traverse at most maxChainLength entries in the hash table.
	Stop if a match of at least goodMatch size has been found."
	| matchResult matchPos distance chainLength limit bestLength length |
	"Compute the default match result"
	matchResult _ (lastLength bitShift: 16) bitOr: lastMatch.

	"There is no way to find a better match than MaxMatch"
	lastLength >= MaxMatch ifTrue:[^matchResult].

	"Start position for searches"
	matchPos _ hashHead at: (self updateHashAt: here + MinMatch) + 1.

	"Compute the distance to the (possible) match"
	distance _ here - matchPos.

	"Note: It is required that 0 < distance < MaxDistance"
	(distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult].

	chainLength _ maxChainLength.	"Max. nr of match chain to search"
	here > MaxDistance	"Limit for matches that are too old"
		ifTrue:[limit _ here - MaxDistance]
		ifFalse:[limit _ 0].

	"Best match length so far (current match must be larger to take effect)"
	bestLength _ lastLength.

	["Compare the current string with the string at match position"
	length _ self compare: here with: matchPos min: bestLength.
	"Truncate accidental matches beyound stream position"
	(here + length > position) ifTrue:[length _ position - here].
	"Ignore very small matches if they are too far away"
	(length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)])
		ifTrue:[length _ MinMatch - 1].
	length > bestLength ifTrue:["We have a new (better) match than before"
		"Compute the new match result"
		matchResult _ (length bitShift: 16) bitOr: matchPos.
		bestLength _ length.
		"There is no way to find a better match than MaxMatch"
		bestLength >= MaxMatch ifTrue:[^matchResult].
		"But we may have a good, fast match"
		bestLength > goodMatch ifTrue:[^matchResult].
	].
	(chainLength _ chainLength - 1) > 0] whileTrue:[
		"Compare with previous entry in hash chain"
		matchPos _ hashTail at: (matchPos bitAnd: WindowMask) + 1.
		matchPos <= limit ifTrue:[^matchResult]. "Match position is too old"
	].
	^matchResult! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'!
flushBlock
	"Flush a deflated block"! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'!
insertStringAt: here
	"Insert the string at the given start position into the hash table.
	Note: The hash value is updated starting at MinMatch-1 since
	all strings before have already been inserted into the hash table
	(and the hash value is updated as well)."
	| prevEntry |
	hashValue _ self updateHashAt: (here + MinMatch).
	prevEntry _ hashHead at: hashValue+1.
	hashHead at: hashValue+1 put: here.
	hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'!
updateHash: nextValue
	"Update the running hash value based on the next input byte.
	Return the new updated hash value."
	^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'!
updateHashAt: here
	"Update the hash value at position here (one based)"
	^self updateHash: (collection byteAt: here)! !

!DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'!
validateMatchAt: pos from: startPos to: endPos
	| here |
	here _ pos.
	startPos+1 to: endPos+1 do:[:i|
		(collection at: i) = (collection at: (here _ here + 1))
			ifFalse:[^self error:'Not a match']].
	^true! !


!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'!
encodeLiteral: literal
	"Encode the given literal.
	Return true if the current block needs to be flushed."
	^false! !

!DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'!
encodeMatch: matchLength distance: matchDistance
	"Encode a match of the given length and distance.
	Return true if the current block should be flushed."
	^false! !


!DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'!
moveContentsToFront
	"Move the contents of the receiver to the front"
	| delta |
	delta _ (blockPosition - WindowSize).
	delta <= 0 ifTrue:[^self].
	"Move collection"
	collection 
		replaceFrom: 1 
		to: collection size - delta 
		with: collection 
		startingAt: delta+1.
	position _ position - delta.
	"Move hash table entries"
	blockPosition _ blockPosition - delta.
	blockStart _ blockStart - delta.
	self updateHashTable: hashHead delta: delta.
	self updateHashTable: hashTail delta: delta.! !

!DeflateStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'!
updateHashTable: table delta: delta
	| pos |
	<primitive: 'primitiveDeflateUpdateHashTable' module: 'ZipPlugin'>
	1 to: table size do:[:i|
		"Discard entries that are out of range"
		(pos _ table at: i) >= delta
			ifTrue:[table at: i put: pos - delta]
			ifFalse:[table at: i put: 0]].! !

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

DeflateStream class
	instanceVariableNames: ''!

!DeflateStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 00:24'!
initialize
	"DeflateStream initialize"
	#(	WindowSize WindowMask 
		MaxDistance MinMatch MaxMatch
		HashBits HashMask HashShift
	) do:[:sym|
			ZipConstants declare: sym from: Undeclared.
		].

	WindowSize _ 16r8000.
	WindowMask _ WindowSize - 1.
	MaxDistance _ WindowSize.

	MinMatch _ 3.
	MaxMatch _ 258.

	HashBits _ 15.
	HashMask _ (1 << HashBits) - 1.
	HashShift _ (HashBits + MinMatch - 1) // MinMatch.
! !
Object subclass: #Delay
	instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn '
	classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime SuspendedDelays TimingSemaphore '
	poolDictionaries: ''
	category: 'Kernel-Processes'!

!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 11:11'!
unschedule
	"Unschedule this Delay. Do nothing if it wasn't scheduled."

	| done |
	AccessProtect critical: [
		done _ false.
		[done] whileFalse:
			[SuspendedDelays remove: self ifAbsent: [done _ true]].
		ActiveDelay == self ifTrue: [
			SuspendedDelays isEmpty
				ifTrue: [
					ActiveDelay _ nil.
					ActiveDelayStartTime _ nil]
				ifFalse: [
					SuspendedDelays removeFirst activate]]].
! !

!Delay methodsFor: 'delaying' stamp: 'jm 9/12/97 09:10'!
wait
	"Schedule this Delay, then wait on its semaphore. The current process will be suspended for the amount of time specified when this Delay was created."

	self schedule.
	delaySemaphore wait.
! !


!Delay methodsFor: 'private' stamp: 'jm 9/11/97 13:31'!
activate
	"Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore."

	ActiveDelay _ self.
	ActiveDelayStartTime _ Time millisecondClockValue.
	TimingSemaphore initSignals.
	Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime.
! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 14:49'!
adjustResumptionTimeOldBase: oldBaseTime newBase: newBaseTime
	"Private!! Adjust the value of the system's millisecond clock at which this Delay will be awoken. Used to adjust resumption times after a snapshot or clock roll-over."

	resumptionTime _ newBaseTime + (resumptionTime - oldBaseTime).
! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!
resumptionTime
	"Answer the value of the system's millisecondClock at which the receiver's suspended Process will resume."

	^ resumptionTime
! !

!Delay methodsFor: 'private' stamp: 'jm 9/12/97 11:10'!
schedule
	"Private!! Schedule this Delay, but return immediately rather than waiting. The receiver's semaphore will be signalled when its delay duration has elapsed."

	beingWaitedOn ifTrue: [self error: 'This Delay has already been scheduled.'].
	AccessProtect critical: [
		beingWaitedOn _ true.
		resumptionTime _ Time millisecondClockValue + delayDuration.
		ActiveDelay == nil
			ifTrue: [self activate]
			ifFalse: [
				resumptionTime < ActiveDelay resumptionTime
					ifTrue: [
						SuspendedDelays add: ActiveDelay.
						self activate]
					ifFalse: [SuspendedDelays add: self]]].
! !

!Delay methodsFor: 'private' stamp: 'jm 9/12/97 08:56'!
setDelay: millisecondCount forSemaphore: aSemaphore
	"Private!! Initialize this delay to signal the given semaphore after the given number of milliseconds."

	delayDuration _ millisecondCount.
	delaySemaphore _ aSemaphore.
	beingWaitedOn _ false.
! !

!Delay methodsFor: 'private' stamp: 'jm 9/11/97 11:54'!
signalWaitingProcess
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn _ false.
	delaySemaphore signal.
! !

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

Delay class
	instanceVariableNames: ''!

!Delay class methodsFor: 'instance creation' stamp: 'jm 9/15/97 17:09'!
forMilliseconds: anInteger
	"Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time."

	anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].
	^ self new
		setDelay: anInteger
		forSemaphore: Semaphore new
! !

!Delay class methodsFor: 'instance creation' stamp: 'di 6/16/1999 23:04'!
forSeconds: aNumber
	"Return a new Delay for the given number of seconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time."

	aNumber < 0 ifTrue: [self error: 'delay times cannot be negative'].
	^ self new
		setDelay: (aNumber * 1000) asInteger
		forSemaphore: Semaphore new
! !

!Delay class methodsFor: 'instance creation' stamp: 'jm 9/12/97 11:06'!
howToUse
	"An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay.
	The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs."
! !

!Delay class methodsFor: 'instance creation' stamp: 'jm 9/15/97 17:10'!
timeoutSemaphore: aSemaphore afterMSecs: anInteger
	"Create and schedule a Delay to signal the given semaphore when the given number of milliseconds has elapsed. Return the scheduled Delay. The timeout can be cancelled by sending 'unschedule' to this Delay."
	"Details: This mechanism is used to provide a timeout when waiting for an external event, such as arrival of data over a network connection, to signal a semaphore. The timeout ensures that the semaphore will be signalled within a reasonable period of time even if the event fails to occur. Typically, the waiting process cancels the timeout request when awoken, then determines if the awaited event has actually occurred."

	anInteger < 0 ifTrue: [self error: 'delay times cannot be negative'].
	^ (self new setDelay: anInteger forSemaphore: aSemaphore) schedule
! !


!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 14:59'!
restoreResumptionTimes
	"Private!! Restore the resumption times of all scheduled Delays after a snapshot or clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| newBaseTime |
	newBaseTime _ Time millisecondClockValue.
	SuspendedDelays do: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime].
	ActiveDelay == nil ifFalse: [
		ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime.
		ActiveDelay activate].
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:15'!
saveResumptionTimes
	"Private!! Record the resumption times of all Delays relative to a base time of zero. This is done prior to snapshotting or adjusting the resumption times after a clock roll-over. This method should be called only while the AccessProtect semaphore is held."

	| oldBaseTime |
	oldBaseTime _ Time millisecondClockValue.
	ActiveDelay == nil
		ifFalse: [
			oldBaseTime < ActiveDelayStartTime
				ifTrue: [oldBaseTime _ ActiveDelayStartTime].  "clock rolled over"
			ActiveDelay adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
	SuspendedDelays do:
		[:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0].
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:00'!
shutDown
	"Suspend the active delay, if any, before snapshotting. It will be reactived when the snapshot is resumed."
	"Details: This prevents a timer interrupt from waking up the active delay in the midst snapshoting, since the active delay will be restarted when resuming the snapshot and we don't want to process the delay twice."

	AccessProtect wait.
	self primSignal: nil atMilliseconds: 0.
	self saveResumptionTimes.
! !

!Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:01'!
startUp
	"Restart active delay, if any, when resuming a snapshot."

	self restoreResumptionTimes.
	ActiveDelay == nil ifFalse: [ActiveDelay activate].
	AccessProtect signal.
! !


!Delay class methodsFor: 'timer process' stamp: 'jm 9/11/97 15:15'!
startTimerInterruptWatcher
	"Reset the class variables that keep track of active Delays and re-start the timer interrupt watcher process. Any currently scheduled delays are forgotten."
	"Delay startTimerInterruptWatcher"

	| p |
	self primSignal: nil atMilliseconds: 0.
	TimingSemaphore == nil
		ifFalse: [TimingSemaphore terminateProcess].
	TimingSemaphore _ Semaphore new.
	AccessProtect _ Semaphore forMutualExclusion.
	SuspendedDelays _ 
		SortedCollection sortBlock: 
			[:d1 :d2 | d1 resumptionTime <= d2 resumptionTime].
	ActiveDelay _ nil.
	p _ [self timerInterruptWatcher] newProcess.
	p priority: Processor timingPriority.
	p resume.
! !

!Delay class methodsFor: 'timer process' stamp: 'jm 9/11/97 15:13'!
timerInterruptWatcher
	"This loop runs in its own process. It waits for a timer interrupt and wakes up the active delay. Note that timer interrupts are only enabled when there are active delays."

	[true] whileTrue: [
		TimingSemaphore wait.
		AccessProtect critical: [
			ActiveDelay == nil ifFalse: [
				ActiveDelay signalWaitingProcess.
				Time millisecondClockValue < ActiveDelayStartTime
					ifTrue: [  "clock wrapped"
						self saveResumptionTimes.
						self restoreResumptionTimes]].
			SuspendedDelays isEmpty
				ifTrue: [
					ActiveDelay _ nil.
					ActiveDelayStartTime _ nil]
				ifFalse: [
					SuspendedDelays removeFirst activate]]].
! !


!Delay class methodsFor: 'example' stamp: 'jm 9/11/97 11:23'!
testDelayOf: delay for: testCount rect: r
	"Delay testDelayOf: 100 for: 20 rect: (10@10 extent: 30@30).
	 Delay testDelayOf: 400 for: 20 rect: (50@10 extent: 30@30)."

	| onDelay offDelay |
	onDelay _ Delay forMilliseconds: 50.
	offDelay _ Delay forMilliseconds: delay - 50.
	Display fillBlack: r.
	[1 to: testCount do: [:i |
		Display fillWhite: r.
		onDelay wait.
		Display reverse: r.
		offDelay wait].
	] forkAt: Processor userInterruptPriority.
! !


!Delay class methodsFor: 'primitives' stamp: 'jm 9/11/97 10:54'!
primSignal: aSemaphore atMilliseconds: aSmallInteger
	"Signal the semaphore when the millisecond clock reaches the value of the second argument. Fail if the first argument is neither a Semaphore nor nil. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 136>
	self primitiveFailed
! !


!Delay class methodsFor: 'testing' stamp: 'ar 9/6/1999 17:05'!
anyActive
	"Return true if there is any delay currently active"
	^ActiveDelay notNil! !
MacExternalData variableWordSubclass: #DescType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!DescType commentStamp: '<historical>' prior: 0!
I am an ExternalData representation of a MacOS DescType or OSID!


!DescType methodsFor: 'printing' stamp: 'acg 9/20/1999 14:36'!
printOn: aStream

	aStream 
		nextPutAll: self species asString;
		nextPutAll: '(''';
		nextPutAll: (self fourBytesAt: 1);
		nextPutAll: ''')'! !

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

DescType class
	instanceVariableNames: ''!

!DescType class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 14:29'!
fromString: aString

	^(super new: 1) 
		fourBytesAt: 1 put: aString;
		yourself! !

!DescType class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 14:28'!
fromUnsigned: anInteger

	^(super new: 1) 
		at: 1 put: anInteger;
		yourself! !

!DescType class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 14:37'!
of: aString

	^self fromString: aString! !
MethodNode subclass: #DialectMethodNode
	instanceVariableNames: 'dialect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!DialectMethodNode commentStamp: '<historical>' prior: 0!
The purpose of this class is to carry along with theinformation in a regular method node the further information that it was parsed from an laternate dialect of Squeak.  Which dialect that was is carried as a symbol in the dialect variable.!


!DialectMethodNode methodsFor: 'as yet unclassified' stamp: 'di 4/13/2000 20:46'!
setDialect: dialectSymbol

	dialect _ dialectSymbol! !

!DialectMethodNode methodsFor: 'as yet unclassified' stamp: 'di 4/13/2000 21:31'!
test: arg1 with: arg2 
	^ 3 between: arg1 and: arg2! !
Parser subclass: #DialectParser
	instanceVariableNames: 'dialect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!DialectParser commentStamp: '<historical>' prior: 0!
This Parser is part of a package designed to allow for experiments with alternatives to ST-80 syntax.  The particular alternative offered by this parser eliminates colons, left-arrows and up-arrows, and adds prefix keywords for common control constructs.

ST-80									SQ-00
-------									-------
a + b between: c and: c + 4				a + b between (c) and (c + 4)
a _ 3.0									Set a to 3.0
^ self size + 3							Return self size + 3
a > b									Test (a > b)
	ifTrue: ['greater']						ifTrue ['greater']
	ifFalse: ['less']							ifFalse ['less']
1 to: 9 do:								Repeat (1) to (9) do
	[:i | Transcript cr; show: i]				[Set i. | Transcript cr; show (i)]

The use of prefix keywords is currently ad-hoc;  in other words they are built into the parser, and there is not a way to define a method pattern to include a prefix keyword.  Most of the work has been done to support this, though, as selectors can now have the form
	#:prefix:kwd1:kwd2:
and they will respond appropriately to #keywords and #numArgs.

A test method in the class ensures that every method in the system can be pretty-printed in the alternative syntax, and that compiling the resulting text produces exactly the same bytecodes as the original method.!


!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/23/2000 22:18'!
assignment: varNode
	" 'set' (var) 'to' (expression) => AssignmentNode."
	| loc |
	(loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
		ifTrue: [^self notify: 'Cannot store into' at: loc].
	varNode nowHasDef.
	self advance.  " to "
	self expression ifFalse: [^self expected: 'Expression'].
	parseNode _ AssignmentNode new
				variable: varNode
				value: parseNode
				from: encoder.
	^ true! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 6/13/2000 00:34'!
blockExpression
	"[ ({:var} |) (| {temps} |) (statements) ] => BlockNode."

	| variableNodes temporaryBlockVariables |
	variableNodes _ OrderedCollection new.

	"Gather parameters."
	(self matchToken: 'With') ifTrue:
		[[self match: #period]
			whileFalse: [variableNodes addLast: (encoder autoBind: self argumentName)]].

	temporaryBlockVariables _ self temporaryBlockVariables.
	self statements: variableNodes innerBlock: true.
	parseNode temporaries: temporaryBlockVariables.

	(self match: #rightBracket) ifFalse: [^ self expected: 'Period or right bracket'].

	"The scope of the parameters and temporary block variables is no longer active."
	temporaryBlockVariables do: [:variable | variable scope: -1].
	variableNodes do: [:variable | variable scope: -1]! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/22/2000 17:11'!
expression

	^ self expressionWithInitialKeyword: ''
! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 6/7/2000 09:51'!
expressionWithInitialKeyword: kwdIfAny

	| checkpoint |
	(hereType == #word and: [here = 'Set' and: [tokenType == #word]]) ifTrue:
			["Parse assignment statement 'Set' var 'to' expression"
			checkpoint _ self checkpoint.
			self advance.
			token = 'to'
				ifTrue: [^ self assignment: self variable]
				ifFalse: [self revertToCheckpoint: checkpoint]].
	self matchKeyword
		ifTrue: ["It's an initial keyword."
				kwdIfAny isEmpty ifFalse: [self error: 'compiler logic error'].
				^ self expressionWithInitialKeyword: ':' , self advance , ':'].
	hereType == #leftBrace
		ifTrue: [self braceExpression]
		ifFalse: [self primaryExpression ifFalse: [^ false]].
	(self messagePart: 3 repeat: true initialKeyword: kwdIfAny)
		ifTrue: [hereType == #semicolon ifTrue: [self cascade]].
	^ true! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/25/2000 22:36'!
matchKeyword
	"Return true if we are looking at a keyword (and its argument)."

	hereType == #word ifFalse: [^ false].
	tokenType == #leftParenthesis ifTrue: [^ true].
	tokenType == #leftBracket ifTrue: [^ true].
	tokenType == #leftBrace ifTrue: [^ true].
	^ false! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 6/11/2000 15:27'!
matchReturn

	^ self matchToken: 'Answer'! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/22/2000 16:56'!
messagePart: level repeat: repeat

	^ self messagePart: level repeat: repeat initialKeyword: ''! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/25/2000 22:46'!
messagePart: level repeat: repeat initialKeyword: kwdIfAny

	| start receiver selector args precedence words keywordStart |
	[receiver _ parseNode.
	(self matchKeyword and: [level >= 3])
		ifTrue: 
			[start _ self startOfNextToken.
			selector _ WriteStream on: (String new: 32).
			selector nextPutAll: kwdIfAny.
			args _ OrderedCollection new.
			words _ OrderedCollection new.
			[self matchKeyword]
				whileTrue: 
					[keywordStart _ self startOfNextToken + requestorOffset.
					selector nextPutAll: self advance , ':'.
					words addLast: (keywordStart to: hereMark + self previousTokenSize + requestorOffset).
					self primaryExpression ifFalse: [^ self expected: 'Argument'].
					args addLast: parseNode].
			(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
				ifFalse: [ selector _ self correctSelector: selector contents
										wordIntervals: words
										exprInterval: (start to: self endOfLastToken)
										ifAbort: [ ^ self fail ] ].
			precedence _ 3]
		ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
				and: [level >= 2])
				ifTrue: 
					[start _ self startOfNextToken.
					selector _ self advance asSymbol.
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 1 repeat: true.
					args _ Array with: parseNode.
					precedence _ 2]
				ifFalse: [(hereType == #word
							and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not])
						ifTrue: 
							[start _ self startOfNextToken.
							selector _ self advance.
							args _ #().
							words _ OrderedCollection with: (start  + requestorOffset to: self endOfLastToken + requestorOffset).
							(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
								ifFalse: [ selector _ self correctSelector: selector
													wordIntervals: words
													exprInterval: (start to: self endOfLastToken)
													ifAbort: [ ^ self fail ] ].
							precedence _ 1]
						ifFalse: [^args notNil]]].
	parseNode _ MessageNode new
				receiver: receiver
				selector: selector
				arguments: args
				precedence: precedence
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	repeat]
		whileTrue: [].
	^true! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 5/30/2000 22:01'!
newMethodNode

	^ DialectMethodNode new setDialect: #SQ00! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 4/5/2000 17:02'!
parseArgsAndTemps: aString notifying: req 
	"Parse the argument, aString, notifying req if an error occurs. Otherwise, 
	answer a two-element Array containing Arrays of strings (the argument 
	names and temporary variable names)."

	aString == nil ifTrue: [^#()].
	doitFlag _ false.		"Don't really know if a doit or not!!"
	^self initPattern: aString
		notifying: req
		return: [:pattern | (pattern at: 2) , self temporaries]! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 6/11/2000 15:27'!
pattern: fromDoit inContext: ctxt 
	" unarySelector | binarySelector arg | keyword arg {keyword arg} =>  
	{selector, arguments, precedence}."
	| args selector checkpoint |
	doitFlag _ fromDoit.
	fromDoit ifTrue:
			[ctxt == nil
				ifTrue: [^ {#DoIt. {}. 1}]
				ifFalse: [^ {#DoItIn:. {encoder encodeVariable: 'homeContext'}. 3}]].

	"NOTE: there is now an ambiguity between
	keywordSelector (argName) -and- unarySelector (first expression).
	Also, there is an amibuity (if there are no temp declarations) between
	keywordSelector (argName) -and- PrefixKeyword (some expression).
	We use duct tape for now."
	(hereType == #word and: [tokenType == #leftParenthesis]) ifTrue:
		[checkpoint _ self checkpoint.  "in case we have to back out"
		selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			[hereType == #word
				and: [tokenType == #leftParenthesis
				and: [here first isLowercase
						or: [(#('Test' 'Repeat' 'Answer') includes: here) not]]]]
				whileTrue: 
					[selector nextPutAll: self advance , ':'.  "selector part"
					self advance.  "open paren"
					(args size = 0 and: [tokenType ~~ #rightParenthesis]) ifTrue:
						["This is really a unary selector on a method that
						begins with a parenthesized expression.  Back out now"
						self revertToCheckpoint: checkpoint.
						^ {self advance asSymbol. {}. 1}].
					args addLast: (encoder bindArg: self argumentName).
			(self match: #rightParenthesis)
						ifFalse: [^ self expected: 'right parenthesis']].
			^ {selector contents asSymbol. args. 3}].

	hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}].

	(hereType == #binary or: [hereType == #verticalBar])
		ifTrue: 
			[selector _ self advance asSymbol.
			args _ Array with: (encoder bindArg: self argumentName).
			^ {selector. args. 2}].

	^ self expected: 'Message pattern'! !

!DialectParser methodsFor: 'as yet unclassified' stamp: 'di 6/13/2000 00:31'!
temporaries
	" [ 'Use' (variable)* '.' ]"
	| vars theActualText |
	(self matchToken: #'Use') ifFalse: 
		["no temps"
		doitFlag ifTrue: [requestor
				ifNil: [tempsMark _ 1]
				ifNotNil: [tempsMark _ requestor selectionInterval first].
			^ #()].
		tempsMark _ prevMark + prevToken.
		tempsMark > 0 ifTrue:
			[theActualText _ source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark _ tempsMark + 1]].
			^ #()].
	vars _ OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance)].
	(self match: #period) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Period'! !

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

DialectParser class
	instanceVariableNames: ''!

!DialectParser class methodsFor: 'as yet unclassified' stamp: 'di 6/7/2000 09:32'!
test    "DialectParser test"

"PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code.  No changes are actually made to the system.  At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running):

	BalloonEngineSimulation circleCosTable and
	BalloonEngineSimulation circleSinTable.

These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors.

Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on.

NOTE:  Some methods may not compare properly until the system has been recompiled once.  Do this by executing...
		Smalltalk recompileAllFrom: 'AARDVAARK'.
"

	 | newCodeString methodNode oldMethod newMethod badOnes n heading |
	Preferences enable: #printAlternateSyntax.
	badOnes _ OrderedCollection new.
	Transcript clear.
	Smalltalk forgetDoIts.
'Formatting and recompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allClassesDo:  "{MethodNode} do:"  "<- to check one class"
		[:nonMeta |  "Transcript cr; show: nonMeta name."
		{nonMeta. nonMeta class} do:
		[:cls |
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			newCodeString _ (cls compilerClass new)
				format: (cls sourceCodeAt: selector)
				in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
			heading _ cls organization categoryOfElement: selector.
			methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls notifying: (SyntaxError new category: heading)
						ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldMethod _ cls compiledMethodAt: selector.
			"Transcript cr; show: cls name , ' ' , selector."
			oldMethod = newMethod ifFalse:
				[Transcript cr; show: '***' , cls name , ' ' , selector.
				oldMethod size = newMethod size ifFalse:
					[Transcript show: ' difft size'].
				oldMethod header = newMethod header ifFalse:
					[Transcript show: ' difft header'].
				oldMethod literals = newMethod literals ifFalse:
					[Transcript show: ' difft literals'].
				Transcript endEntry.
				badOnes add: cls name , ' ' , selector]]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'.
	Preferences disable: #printAlternateSyntax.
! !
TextStream subclass: #DialectStream
	instanceVariableNames: 'dialect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!DialectStream methodsFor: 'as yet unclassified' stamp: 'di 4/5/2000 08:48'!
dialect

	^ dialect! !

!DialectStream methodsFor: 'as yet unclassified' stamp: 'di 4/5/2000 08:48'!
setDialect: dialectSymbol

	dialect _ dialectSymbol! !

!DialectStream methodsFor: 'as yet unclassified' stamp: 'di 4/5/2000 15:36'!
withColor: colorSymbol emphasis: emphasisSymbol do: aBlock

	^ self withAttributes: {TextColor color: (Color perform: colorSymbol).
							TextEmphasis perform: emphasisSymbol}
		do: aBlock! !

!DialectStream methodsFor: 'as yet unclassified' stamp: 'di 6/13/2000 00:48'!
withStyleFor: elementType do: aBlock

	"For each element type, associate a color and emphasis"
	elementType == #temporaryVariable ifTrue:
		[^ self withColor: #black emphasis: #normal do: aBlock].
	elementType == #methodArgument ifTrue:
		[^ self withColor: #black emphasis: #normal do: aBlock].
	elementType == #methodSelector ifTrue:
		[^ self withColor: #black emphasis: #bold do: aBlock].
	elementType == #blockArgument ifTrue:
		[^ self withColor: #black emphasis: #normal do: aBlock].
	elementType == #comment ifTrue:
		[^ self withColor: #brown emphasis: #normal do: aBlock].
	elementType == #variable ifTrue:
		[^ self withColor: #black emphasis: #normal do: aBlock].
	elementType == #literal	 ifTrue:
		[^ self withColor: #blue emphasis: #normal do: aBlock].
	elementType == #keyword ifTrue:
		[^ self withColor: #darkGray emphasis: #bold do: aBlock].
	elementType == #prefixKeyword ifTrue:
		[^ self withColor: #veryDarkGray emphasis: #bold do: aBlock].
	elementType == #setOrReturn ifTrue:
		[^ self withColor: #black emphasis: #bold do: aBlock].
	^ self withColor: #black emphasis: #normal do: aBlock! !

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

DialectStream class
	instanceVariableNames: ''!

!DialectStream class methodsFor: 'as yet unclassified' stamp: 'di 4/5/2000 09:49'!
dialect: dialectSymbol contents: blockWithArg 
	| stream |
	stream _ self on: (Text new: 400).
	stream setDialect: dialectSymbol.
	blockWithArg value: stream.
	^ stream contents! !
Set subclass: #Dictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!Dictionary commentStamp: '<historical>' prior: 0!
I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a set of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key.!


!Dictionary methodsFor: 'accessing'!
associationAt: key 
	^ self associationAt: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'accessing'!
associationAt: key ifAbsent: aBlock 
	"Answer the association with the given key.
	If key is not found, return the result of evaluating aBlock."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	nil == assoc ifTrue: [ ^ aBlock value ].
	^ assoc! !

!Dictionary methodsFor: 'accessing' stamp: 'tk 4/9/1999 10:22'!
associationDeclareAt: aKey
	"Return an existing association, or create and return a new one.  Needed as a single message by ImageSegment.prepareToBeSaved."

	| existing |
	^ self associationAt: aKey ifAbsent: [
		(Undeclared includesKey: aKey)
			ifTrue: 
				[existing _ Undeclared associationAt: aKey.
				Undeclared removeKey: aKey.
				self add: existing]
			ifFalse: 
				[self add: aKey -> false]]! !

!Dictionary methodsFor: 'accessing'!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:59'!
at: key ifAbsent: aBlock 
	"Answer the value associated with the key or, if key isn't found,
	answer the result of evaluating aBlock."

	| assoc |
	assoc _ array at: (self findElementOrNil: key).
	assoc ifNil: [^ aBlock value].
	^ assoc value! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:01'!
at: key ifAbsentPut: aBlock 
	"Return the value at the given key. 
	If key is not included in the receiver store the result 
	of evaluating aBlock as new value."

	^ self at: key ifAbsent: [self at: key put: aBlock value]! !

!Dictionary methodsFor: 'accessing' stamp: 'jm 5/15/1998 07:20'!
at: key ifPresent: aBlock
	"Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil."

	| v |
	v _ self at: key ifAbsent: [^ nil].
	^ aBlock value: v
! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:00'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a
	new entry for key and set is value to anObject. Answer anObject."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc
		ifNil: [self atNewIndex: index put: (Association key: key value: anObject)]
		ifNotNil: [assoc value: anObject].
	^ anObject! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'!
keyAtIdentityValue: value 
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer nil.
	Note: There can be multiple keys with the same value. Only one is returned."

	^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock.
	Note: There can be multiple keys with the same value. Only one is returned."
 
	self associationsDo: 
		[:association | value == association value ifTrue: [^association key]].
	^exceptionBlock value! !

!Dictionary methodsFor: 'accessing'!
keyAtValue: value 
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer nil."

	^self keyAtValue: value ifAbsent: [self errorValueNotFound]! !

!Dictionary methodsFor: 'accessing' stamp: 'tk 2/18/97'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock.
	: Use =, not ==, so stings like 'this' can be found.  Note that MethodDictionary continues to use == so it will be fast."
 
	self associationsDo: 
		[:association | value = association value ifTrue: [^association key]].
	^exceptionBlock value! !

!Dictionary methodsFor: 'accessing'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet _ Set new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !

!Dictionary methodsFor: 'accessing' stamp: 'sma 6/18/2000 12:56'!
keysSortedSafely
	"Answer a SortedCollection containing the receiver's keys."
	| sortedKeys |
	sortedKeys _ SortedCollection new: self size.
	sortedKeys sortBlock:
		[:x :y |  "Should really be use <obj, string, num> compareSafely..."
		((x isString and: [y isString])
			or: [x isNumber and: [y isNumber]])
			ifTrue: [x < y]
			ifFalse: [x class == y class
				ifTrue: [x printString < y printString]
				ifFalse: [x class name < y class name]]].
	self keysDo: [:each | sortedKeys addLast: each].
	^ sortedKeys reSort! !

!Dictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 07:28'!
values
	"Answer a Collection containing the receiver's values."
	| out |
	out _ WriteStream on: (Array new: self size).
	self valuesDo: [:value | out nextPut: value].
	^ out contents! !


!Dictionary methodsFor: 'testing' stamp: 'bf 8/20/1999 15:07'!
hasContentsInExplorer

	^self isEmpty not! !

!Dictionary methodsFor: 'testing'!
includes: anObject

	self do: [:each | anObject = each ifTrue: [^true]].
	^false! !

!Dictionary methodsFor: 'testing' stamp: 'sw 2/14/2000 14:34'!
includesIdentity: anObject
	"Answer whether anObject is one of the values of the receiver.  Contrast #includes: in which there is only an equality check, here there is an identity check"

	self do: [:each | anObject == each ifTrue: [^ true]].
	^ false! !

!Dictionary methodsFor: 'testing'!
includesKey: key 
	"Answer whether the receiver has a key equal to the argument, key."
	| index |
	index _ self findElementOrNil: key.
	(array at: index) == nil	
		ifTrue: [^ false]
		ifFalse: [^ true]! !

!Dictionary methodsFor: 'testing' stamp: 'sw 3/23/2000 01:12'!
keyForIdentity: anObject
	"If anObject is one of the values of the receive, return its key, else return nil.  Contrast #keyAtValue: in which there is only an equality check, here there is an identity check"

	self associationsDo: [:assoc | assoc value == anObject ifTrue: [^ assoc key]].
	^ nil! !

!Dictionary methodsFor: 'testing'!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| count |
	count _ 0.
	self do: [:each | anObject = each ifTrue: [count _ count + 1]].
	^count! !


!Dictionary methodsFor: 'adding'!
add: anAssociation
	| index element |
	index _ self findElementOrNil: anAssociation key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: anAssociation]
		ifFalse: [element value: anAssociation value].
	^ anAssociation! !

!Dictionary methodsFor: 'adding'!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: (aDictionary associationAt: key).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: key -> nil]! !


!Dictionary methodsFor: 'removing' stamp: 'di 4/4/2000 11:47'!
keysAndValuesRemove: keyValueBlock
	"Removes all entries for which keyValueBlock returns true."
	"When removing many items, you must not do it while iterating over the dictionary, since it may be changing.  This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward.  Many places in the sytem could be simplified by using this method."

	| removals |
	removals _ OrderedCollection new.
	self associationsDo:
		[:assoc | (keyValueBlock value: assoc key value: assoc value)
			ifTrue: [removals add: assoc key]].
 	removals do:
		[:aKey | self removeKey: aKey]! !

!Dictionary methodsFor: 'removing'!
remove: anObject

	self shouldNotImplement! !

!Dictionary methodsFor: 'removing'!
remove: anObject ifAbsent: exceptionBlock

	self shouldNotImplement! !

!Dictionary methodsFor: 'removing'!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."

	^ self removeKey: key ifAbsent: [self errorKeyNotFound]! !

!Dictionary methodsFor: 'removing'!
removeKey: key ifAbsent: aBlock 
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ assoc value! !

!Dictionary methodsFor: 'removing'!
removeUnreferencedKeys   "Undeclared removeUnreferencedKeys"

	^ self unreferencedKeys do: [:key | self removeKey: key].! !

!Dictionary methodsFor: 'removing'!
unreferencedKeys		"TextConstants unreferencedKeys"
	| n |
	^ 'Scanning for references . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
		[:bar | n _ 0.
		self keys select:
			[:key | bar value: (n _ n+1).
			(Smalltalk allCallsOn: (self associationAt: key)) isEmpty]]! !


!Dictionary methodsFor: 'enumerating'!
associationsDo: aBlock 
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations)."

	super do: aBlock! !

!Dictionary methodsFor: 'enumerating'!
collect: aBlock 
	"Evaluate aBlock with each of my values as the argument.  Collect the
	resulting values into a collection that is like me. Answer with the new
	collection."
	| newCollection |
	newCollection _ OrderedCollection new: self size.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection! !

!Dictionary methodsFor: 'enumerating'!
do: aBlock

	super do: [:assoc | aBlock value: assoc value]! !

!Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 08:04'!
keysAndValuesDo: aBlock
	^self associationsDo:[:assoc|
		aBlock value: assoc key value: assoc value].! !

!Dictionary methodsFor: 'enumerating'!
keysDo: aBlock 
	"Evaluate aBlock for each of the receiver's keys."

	self associationsDo: [:association | aBlock value: association key]! !

!Dictionary methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of my values as the argument. Collect into a
	new dictionary, only those associations for which aBlock evaluates to
	true."

	| newCollection |
	newCollection _ self species new.
	self associationsDo: 
		[:each | 
		(aBlock value: each value) ifTrue: [newCollection add: each]].
	^newCollection! !

!Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 07:29'!
valuesDo: aBlock 
	"Evaluate aBlock for each of the receiver's keys."

	self associationsDo: [:association | aBlock value: association value]! !


!Dictionary methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:33'!
flattenOnStream:aStream
	^aStream writeDictionary:self.
! !

!Dictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:52'!
printElementsOn: aStream
	aStream nextPut: $(.
	self keysSortedSafely do:
		[:key | aStream print: key; nextPutAll: '->'; print: (self at: key); space].
	aStream nextPut: $)! !

!Dictionary methodsFor: 'printing'!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self associationsDo: 
			[:each | 
			noneYet
				ifTrue: [noneYet _ false]
				ifFalse: [aStream nextPut: $;].
			aStream nextPutAll: ' add: '.
			aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !


!Dictionary methodsFor: 'private' stamp: 'tk 8/21/97 16:12'!
copy
	"Must copy the associations, or later store will effect both the
original and the copy"

	^ self shallowCopy withArray:
		(array collect: [:assoc |
			assoc ifNil: [nil]
				ifNotNil: [Association key: assoc key
value: assoc value]])! !

!Dictionary methodsFor: 'private'!
errorKeyNotFound

	self error: 'key not found'! !

!Dictionary methodsFor: 'private'!
errorValueNotFound

	self error: 'value not found'! !

!Dictionary methodsFor: 'private'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	| assn |
	assn _ array at: index.
	assn == nil ifTrue: [^ nil]
				ifFalse: [^ assn key]! !

!Dictionary methodsFor: 'private'!
noCheckAdd: anObject
	"Must be defined separately for Dictionary because (self findElementOrNil:) expects a key, not an association.  9/7/96 tk"

	array at: (self findElementOrNil: anObject key) put: anObject.
	tally _ tally + 1! !

!Dictionary methodsFor: 'private'!
rehash
	"Smalltalk rehash."
	| newSelf |
	newSelf _ self species new: self size.
	self associationsDo: [:each | newSelf noCheckAdd: each].
	array _ newSelf array! !

!Dictionary methodsFor: 'private'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!Dictionary methodsFor: 'private'!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	"Support for coordinating class variable and global declarations
	with variables that have been put in Undeclared so as to
	redirect all references to the undeclared variable."

	(aDictionary includesKey: aKey)
		ifTrue: 
			[self atNewIndex: index 
				put: ((aDictionary associationAt: aKey) value: anObject).
			aDictionary removeKey: aKey]
		ifFalse: 
			[self atNewIndex: index put: (Association key: aKey value: anObject)]! !


!Dictionary methodsFor: 'user interface' stamp: 'tk 4/12/1998 08:54'!
inspect
	"Open a DictionaryInspector on the receiver.  Use basicInspect to get a normal (less useful) type of inspector."

	DictionaryInspector openOn: self withEvalPane: true! !

!Dictionary methodsFor: 'user interface' stamp: 'RAA 6/14/2000 18:24'!
inspectFormsWithLabel: aLabel
        "Open a Form Dictionary inspector on the receiver, with the given label."

        | viewClass aList aGraphicalMenu |
        
        self couldOpenInMorphic
                ifTrue:
                        [aList _ self collect: [:f | f].
                        aList isEmpty ifTrue: [^ self inform: 'Empty!!'].
                        aGraphicalMenu _ GraphicalDictionaryMenu new 
                                initializeFor: nil
                                fromDictionary: self.
                        ^ HandMorph attach: (aGraphicalMenu wrappedInWindowWithTitle: aLabel)].

        viewClass _ PluggableTextView.
        Smalltalk at: #FormInspectView
                ifPresent: [:formInspectView | viewClass _ formInspectView].
        ^ DictionaryInspector
                openOn: self
                withEvalPane: true
                withLabel: aLabel
                valueViewClass: viewClass! !

!Dictionary methodsFor: 'user interface' stamp: 'tk 4/12/1998 08:54'!
inspectWithLabel: aLabel
	"Open a DictionaryInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector."

	DictionaryInspector openOn: self withEvalPane: true withLabel: aLabel! !

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

Dictionary class
	instanceVariableNames: ''!

!Dictionary class methodsFor: 'instance creation'!
newFrom: aDict 
	"Answer an instance of me containing the same associations as aDict.
	 Error if any key appears twice."
	| newDictionary |
	newDictionary _ self new: aDict size.
	aDict associationsDo:
		[:x |
		(newDictionary includesKey: x key)
			ifTrue: [self error: 'Duplicate key: ', x key printString]
			ifFalse: [newDictionary add: x]].
	^ newDictionary

"	NewDictionary newFrom: {1->#a. 2->#b. 3->#c}
	{1->#a. 2->#b. 3->#c} as: NewDictionary
	NewDictionary newFrom: {1->#a. 2->#b. 1->#c}
	{1->#a. 2->#b. 1->#c} as: NewDictionary
"! !
Inspector subclass: #DictionaryInspector
	instanceVariableNames: 'keyArray '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!DictionaryInspector methodsFor: 'accessing'!
fieldList
	^ keyArray collect: [ :key | key printString ]! !

!DictionaryInspector methodsFor: 'accessing'!
inspect: aDictionary
	"Initialize the receiver so that it is inspecting aDictionary. There is no 
	current selection."

	self initialize.
	(aDictionary isKindOf: Dictionary) ifFalse:
		[^ self error: 'DictionaryInspectors can only inspect dictionaries' ].
	object _ aDictionary.
	contents _ ''.
	self calculateKeyArray! !


!DictionaryInspector methodsFor: 'selecting' stamp: 'tk 4/11/1998 13:09'!
addEntry: aKey
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'di 3/8/2000 09:14'!
calculateKeyArray
	"Recalculate the KeyArray from the object being inspected"

	keyArray _ object keysSortedSafely asArray.
	selectionIndex _ 0.
! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:25'!
contentsIsString
	"Hacked so contents empty when deselected"

	^ (selectionIndex = 0)! !

!DictionaryInspector methodsFor: 'selecting'!
replaceSelectionValue: anObject
	^ object at: (keyArray at: selectionIndex) put: anObject! !

!DictionaryInspector methodsFor: 'selecting' stamp: 'ar 12/7/1999 18:12'!
selection

	selectionIndex = 0 ifTrue: [^ ''].
	^ object at: (keyArray at: selectionIndex) ifAbsent:[nil]! !

!DictionaryInspector methodsFor: 'selecting'!
selectionUnmodifiable
	"For dicionary inspectors, any selection is modifiable"

	^ selectionIndex <= 0! !


!DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:15'!
addEntry
	| newKey aKey |

	newKey _ FillInTheBlank request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)
Examples:  #Fred    ''a string''   3+4'.
	aKey _ Compiler evaluate: newKey.
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self changed: #fieldList.
	self update! !

!DictionaryInspector methodsFor: 'menu' stamp: 'ar 1/15/2001 18:37'!
copyName
	"Copy the name of the current variable, so the user can paste it into the window below and work with is.  If collection, do (xxx at: 1). "

	| sel |
	sel _ '(self at: ', 
		(String streamContents: [:strm | (keyArray at: selectionIndex) storeOn: strm]) ,
		')'.
	Clipboard clipboardText: sel asText.	"no undo allowed"! !

!DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 09:01'!
dictionaryMenu: aMenu

	^ aMenu labels:
'inspect
copy name
references
objects pointing to this value
add key
remove
basic inspect'
	lines: #( 4 6)
	selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection addEntry removeSelection inspectBasic)
! !

!DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:19'!
removeSelection
	selectionIndex = 0 ifTrue: [^ self changed: #flash].
	object removeKey: (keyArray at: selectionIndex).
	selectionIndex _ 0.
	contents _ ''.
	self calculateKeyArray.
	self changed: #inspectObject.
	self changed: #fieldList.
	self changed: #selection.
	self changed: #selectionIndex.! !

!DictionaryInspector methodsFor: 'menu' stamp: 'tk 4/12/1998 08:42'!
selectionReferences
	"Create a browser on all references to the association of the current selection."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	object class == MethodDictionary ifTrue: [^ self changed: #flash].
	Smalltalk browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex)).
! !
Object subclass: #DigitalSignatureAlgorithm
	instanceVariableNames: 'randKey randSeed '
	classVariableNames: 'HighBitOfByte SmallPrimes '
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!DigitalSignatureAlgorithm commentStamp: '<historical>' prior: 0!
This class implements the Digital Signature Algorithm (DSA) of the U.S. government's "Digital Signature Standard" (DSS). The DSA algorithm was proposed in 1991 and became a standard in May 1994. The official description is available as a Federal Information Processing Standards Publication (FIPS PUB 186, May 19, 1994). A companion standard, the Secure Hash Standard, or SHS (FIPS PUB 180-1, April 17, 1995), describes a 160-bit message digest algorithm known as the Secure Hash Algorithm (SHA). This message digest is used to compute the document signature.

Here's how to use it:

  1. The "signer" creates a pair of keys. One of these must be kept private. The other may be freely distributed. For example, it could be built into the signature checking code of an application.

  2. When the signer wishes to sign a packet of data (a "message") , he uses the secure hash algorithm to create a 160-bit message digest (hash) which is used as the input to DSA. The result of this is a pair of large numbers called a "signature" that is attached to the original message.

  3. When someone receives a signed message purported to have come from the signer, they compute the 160-bit hash of the message and pass that, along with the message signature and the signer's public key, to the signature verification algorithm. If the signature checks, then it is virtually guaranteed that the message originated from someone who had the signer's private key. That is, the message is not a forgery and has not been modified since it was signed. For example, if the message contains a program, and the recipient trusts the signer, then the recipient can run the program with the assurance that it won't do anything harmful. (At least, not intentionally. A digital signature is no guarantee against bugs!! :->)

The signer must keep the private key secure, since anyone who has the private key can forge the signer's signature on any message they like. As long as the secret key is not stolen, cryptographers believe it to be virtually impossible either to forge a signature, to find a message that matches an existing sigature, or to discover the signer's private key by analyzing message signatures. Knowing the public key (which, for example, could be recovered from an application that had it built in), does not weaken the security at all.

An excellent reference work on digital signatures and cryptography in general is:

  Schneier, Bruce
  "Applied Cryptography: Protocols, Algorithms, and Source Code in C"
  John Wiley and Sons, 1996.

I used this book as a guide to implementing many of the numerical algorithms required by DSA.

Patents and Export Restrictions:

Many digital signature technologies are patented. DSA is also patented, but the patent is owned by the U.S. government which has made DSA available royalty-free. There is a claim that the government patent infringes on an earlier patent by Schnorr, but the government is requiring the use of DSA, so they apparently believe this claim is not strong enough to be a serious threat to their own patent.

Most cryptography technology, including digital signature technology, requires an export license for it to be distributed outside the U.S. Recent legislation may have relaxed the export license requirements, but it would be prudent to check the current regulations before exporting this code.!


!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 1/11/2000 00:25'!
initRandom: randomInteger
	"Initialize the the secure random number generator with the given value. The argument should be a positive integer of up to 512 bits chosen randomly to avoid someone being able to predict the sequence of random values generated."
	"Note: The random generator must be initialized before generating a key set or signature. Signature verification does not require initialization of the random generator."

	randSeed _ 16rEFCDAB8998BADCFE10325476C3D2E1F067452301.  "initial seed"
	randKey _ randomInteger.
	Transcript show: 'Random seed: ', randomInteger printString; cr.
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 12/12/1999 23:08'!
initRandomFromUser
	"Ask the user to type a long random string and use the result to seed the secure random number generator."

	| s k srcIndex |
	s _ FillInTheBlank request: 'Enter a long random string to seed the random generator.'.
	k _ LargePositiveInteger new: (s size min: 64).
	srcIndex _ 0.
	k digitLength to: 1 by: -1 do: [:i |
		k digitAt: i put: (s at: (srcIndex _ srcIndex + 1)) asciiValue].
	k _ k + (Random new next * 16r7FFFFFFF) asInteger.  "a few additional bits randomness"
	k highBit > 512 ifTrue: [k _ k bitShift: k highBit - 512].
	self initRandom: k.
! !

!DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'jm 1/11/2000 00:13'!
randomBitsFromSoundInput: bitCount
	"Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes."
	"(1 to: 10) collect: [:i | DigitalSignatureAlgorithm new randomBitsFromSoundInput: 512]"

	| recorder buf mid samples bitMask randomBits bit |
	"collect some sound data"
	recorder _ SoundRecorder new clearRecordedSound.
	recorder resumeRecording.
	(Delay forSeconds: 1) wait.
	recorder stopRecording.
	buf _ recorder condensedSamples.

	"grab bitCount samples from the middle"
	mid _ buf monoSampleCount // 2.
	samples _ buf copyFrom: mid to: mid + bitCount - 1.

	"find the least significant bit that varies"
	bitMask _ 1.
	[bitMask < 16r10000 and:
	 [(samples collect: [:s | s bitAnd: bitMask]) asSet size < 2]]
		whileTrue: [bitMask _ bitMask bitShift: 1].
	bitMask = 16r10000 ifTrue: [^ self error: 'sound samples do not vary'].

	"pack the random bits into a positive integer"
	randomBits _ 0.
	1 to: samples size do: [:i |
		bit _ ((samples at: i) bitAnd: bitMask) = 0 ifTrue: [0] ifFalse: [1].
		randomBits _ (randomBits bitShift: 1) + bit].

	^ randomBits	! !


!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:17'!
computeSignatureForMessageHash: hash privateKey: privateKey
	"Answer the digital signature of the given message hash using the given private key. A signature is a pair of large integers. The private key is an array of four large integers: (p, q, g, x)."

	| p q g x r s k tmp |
	p _ privateKey first.
	q _ privateKey second.
	g _ privateKey third.
	x _ privateKey fourth.

	r _ s _ 0.
	[r = 0 or: [s = 0]] whileTrue: [
		k _ self nextRandom160 \\ q.
		r _ (g raisedTo: k modulo: p) \\ q.
		tmp _ (hash + (x * r)) \\ q.
		s _ ((self inverseOf: k mod: q) * tmp) \\ q].

	^ Array with: r with: s
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:19'!
generateKeySet
	"Generate and answer a key set for DSA. The result is a pair (<private key><public key>). Each key is an array of four large integers. The private key is (p, q, g, x); the public one is (p, q, g, y). The signer must be sure to record (p, q, g, x), and must keep x secret to prevent someone from forging their signature."
	"Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!"

	| qAndPandS q p exp g h x y |
	qAndPandS _ self generateQandP.
	Transcript show: 'Computing g...'.
	q _ qAndPandS first.
	p _ qAndPandS second.
	exp _ (p - 1) / q.
	h _ 2.
	[g _ h raisedTo: exp modulo: p. g = 1] whileTrue: [h _ h + 1].
	Transcript show: 'done.'; cr.
	Transcript show: 'Computing x and y...'.
	x _ self nextRandom160.
	y _ g raisedTo: x modulo: p.
	Transcript show: 'done.'; cr.
	Transcript show: 'Key generation complete!!'; cr.
	^ Array
		with: (Array with: p with: q with: g with: x)
		with: (Array with: p with: q with: g with: y)
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 13:34'!
signatureToString: aSignature
	"Answer a string representation of the given signature. This string can be parsed using the stringToSignature: method."

	| s hex |
	s _ WriteStream on: (String new: 2000).
	s nextPutAll: '[DSA digital signature '.
	hex _ aSignature first printStringBase: 16.
	s nextPutAll: (hex copyFrom: 4 to: hex size).
	s space.
	hex _ aSignature second printStringBase: 16.
	s nextPutAll: (hex copyFrom: 4 to: hex size).
	s nextPutAll: ']'.
	^ s contents
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 13:33'!
stringToSignature: aString
	"Answer the signature stored in the given string. A signature string has the format:

		 '[DSA digital signature <r> <s>]'

	where <r> and <s> are large positive integers represented by strings of hexidecimal digits."

	| prefix stream r s |
	prefix _ '[DSA digital signature '.
	(aString beginsWith: prefix) ifFalse: [self error: 'bad signature prefix'].
	stream _ ReadStream on: aString.
	stream position: prefix size.
	r _ Integer readFrom: stream base: 16.
	stream next.
	s _ Integer readFrom: stream base: 16.
	^ Array with: r with: s
! !

!DigitalSignatureAlgorithm methodsFor: 'public' stamp: 'hh 8/3/2000 18:18'!
verifySignature: aSignature ofMessageHash: hash publicKey: publicKey
	"Answer true if the given signature is the authentic signature of the given message hash. That is, if the signature must have been computed using the private key set corresponding to the given public key. The public key is an array of four large integers: (p, q, g, y)."

	| p q g y r s w u1 u2 v0 v |
	p _ publicKey first.
	q _ publicKey second.
	g _ publicKey third.
	y _ publicKey fourth.
	r _ aSignature first.
	s _ aSignature last.
	((r > 0) and: [r < q]) ifFalse: [^ false].  "reject"
	((s > 0) and: [s < q]) ifFalse: [^ false].  "reject"

	w _ self inverseOf: s mod: q.
	u1 _ (hash * w) \\ q.
	u2 _ (r * w) \\ q.
	v0 _ (g raisedTo: u1 modulo: p) * (y raisedTo: u2 modulo: p).
	v _ ( v0 \\ p) \\ q.
	^ v = r
! !


!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'jm 12/9/1999 21:49'!
inverseOf: x mod: n
	"Answer the inverse of x modulus n. That is, the integer y such that (x * y) \\ n is 1. Both x and n must be positive, and it is assumed that x < n and that x and n are integers."
	"Details: Use the extended Euclidean algorithm, Schneier, p. 247."

	| v u k u1 u2 u3 t1 t2 t3 tmp |
	((x <= 0) or: [n <= 0]) ifTrue: [self error: 'x and n must be greater than zero'].
	x >= n ifTrue: [self error: 'x must be < n'].

	v _ x.
	u _ n.
	k _ 0.
	[x even and: [n even and: [u > 0]]] whileTrue: [  "eliminate common factors of two"
		k _ k + 1.
		u _ u bitShift: -1.
		v _ v bitShift: -1].

	u1 _ 1. u2 _ 0. u3 _ u.
	t1 _ v. t2 _ u - 1. t3 _ v.
	[	[u3 even ifTrue: [
			((u1 odd) or: [u2 odd]) ifTrue: [
				u1 _ u1 + v.
				u2 _ u2 + u].
			u1 _ u1 bitShift: -1.
			u2 _ u2 bitShift: -1.
			u3 _ u3 bitShift: -1].
		((t3 even) or: [u3 < t3]) ifTrue: [
			tmp _ u1. u1 _ t1. t1 _ tmp.
			tmp _ u2. u2 _ t2. t2 _ tmp.
			tmp _ u3. u3 _ t3. t3 _ tmp].
		u3 even and: [u3 > 0]] whileTrue: ["loop while u3 is even"].

		[((u1 < t1) or: [u2 < t2]) and: [u1 > 0]] whileTrue: [
			u1 _ u1 + v.
			u2 _ u2 + u].
	
		u1 _ u1 - t1.
		u2 _ u2 - t2.
		u3 _ u3 - t3.
		t3 > 0] whileTrue: ["loop while t3 > 0"].

	[u1 >= v and: [u2 >= u]] whileTrue: [
		u1 _ u1 - v.
		u2 _ u2 - u].

	u1 _ u1 bitShift: k.
	u2 _ u2 bitShift: k.
	u3 _ u3 bitShift: k.

	u3 = 1 ifFalse: [self error: 'no inverse'].
	^ u - u2
! !

!DigitalSignatureAlgorithm methodsFor: 'large integer arithmetic' stamp: 'hh 8/3/2000 18:18'!
isProbablyPrime: p
	"Answer true if p is prime with very high probability. Such a number is sometimes called an 'industrial grade prime'--a large number that is so extremely likely to be prime that it can assumed that it actually is prime for all practical purposes. This implementation uses the Rabin-Miller algorithm (Schneier, p. 159)."

	| iterations factor pMinusOne b m r a j z couldBePrime |
	iterations _ 50.  "Note: The DSA spec requires >50 iterations; Schneier says 5 are enough (p. 260)"

	"quick elimination: check for p divisible by a small prime"
	SmallPrimes ifNil: [  "generate list of small primes > 2"
		SmallPrimes _ Integer primesUpTo: 2000.
		SmallPrimes _ SmallPrimes copyFrom: 2 to: SmallPrimes size].
	factor _ SmallPrimes detect: [:f | (p \\ f) = 0] ifNone: [nil].
	factor ifNotNil: [^ p = factor].

	pMinusOne _ p - 1.
	b _ self logOfLargestPowerOfTwoDividing: pMinusOne.
	m _ pMinusOne // (2 raisedTo: b).
	"Assert: pMinusOne = m * (2 raisedTo: b) and m is odd"

	Transcript show: '      Prime test pass '.
	r _ Random new.
	1 to: iterations do: [:i |
		Transcript show: i printString; space.
		a _ (r next * 16rFFFFFF) truncated.
		j _ 0.
		z _ (a raisedTo: m modulo: p) normalize.
		couldBePrime _ z = 1.
		[couldBePrime] whileFalse: [
			z = 1 ifTrue: [Transcript show: 'failed!!'; cr. ^ false].  "not prime"
			z = pMinusOne
				ifTrue: [couldBePrime _ true]
				ifFalse: [
					(j _ j + 1) < b
						ifTrue: [z _ (z * z) \\ p]
						ifFalse: [Transcript show: 'failed!!'; cr. ^ false]]]].  "not prime"

	Transcript show: 'passed!!'; cr.
	^ true  "passed all tests; probably prime"
! !



!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:47'!
generateQandP
	"Generate the two industrial-grade primes, q (160-bits) and p (512-bit) needed to build a key set. Answer the array (q, p, s), where s is the seed that from which q and p were created. This seed is normally discarded, but can be used to verify the key generation process if desired."

	| pBits halfTwoToTheP chunkCount sAndq q twoQ n c w x p s |
	pBits _ 512.  "desired size of p in bits"
	halfTwoToTheP _ 2 raisedTo: (pBits - 1).
	chunkCount _ pBits // 160.

	Transcript show: 'Searching for primes q and p...'; cr.
	[true] whileTrue: [
		sAndq _ self generateSandQ.
		Transcript show: '  Found a candidate q.'; cr.
		s _ sAndq first.
		q _ sAndq last.
		twoQ _ q bitShift: 1.
		n _ 2.
		c _ 0.
		[c < 4096] whileTrue: [
			w _ self generateRandomLength: pBits s: s n: n.
			x _ w + halfTwoToTheP.
			p _ (x - ( x \\ twoQ)) + 1.
			p highBit = pBits ifTrue: [
				Transcript show: '    Testing potential p ', (c + 1) printString, '...'; cr.
				(self isProbablyPrime: p) ifTrue: [
					Transcript show: '  Found p!!'; cr.
					^ Array with: q with: p with: s]].
			n _ n + chunkCount + 1.
			c _ c + 1]].
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 16:36'!
generateRandomLength: bitLength s: s n: n
	"Answer a random number of bitLength bits generated using the secure hash algorithm."

	| sha out count extraBits v |
	sha _ SecureHashAlgorithm new.
	out _ 0.
	count _ (bitLength // 160).
	extraBits _ bitLength - (count * 160).
	0 to: count do: [:k |
		v _ sha hashInteger: (s + n + k).
		k = count ifTrue: [
			v _ v - ((v >> extraBits) << extraBits)].
		out _ out bitOr: (v bitShift: (160 * k))].
	^ out
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'raa 5/30/2000 15:46'!
generateSandQ
	"Generate a 160-bit random seed s and an industrial grade prime q."

	| hasher s sPlusOne u q |
	hasher _ SecureHashAlgorithm new.
	[true] whileTrue: [
		s _ self nextRandom160.
		sPlusOne _ s + 1.
		sPlusOne highBit > 160 ifTrue: [sPlusOne _ sPlusOne \\ (2 raisedTo: 160)].
		u _ (hasher hashInteger: s) bitXor: (hasher hashInteger: sPlusOne).
		q _ u bitOr: ((1 bitShift: 159) bitOr: 1).
		(self isProbablyPrime: q) ifTrue: [^ Array with: s with: q]].
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 11:12'!
logOfLargestPowerOfTwoDividing: aPositiveInteger
	"Answer the base-2 log of the largest power of two that divides the given integer. For example, the largest power of two that divides 24 is 8, whose log base-2 is 3. Do this efficiently even when the given number is a large integer. Assume that the given integer is > 0."
	"DigitalSignatureAlgorithm new largestPowerOfTwoDividing: (32 * 3)"

	| digitIndex power d |
	digitIndex _ (1 to: aPositiveInteger digitLength) detect: [:i | (aPositiveInteger digitAt: i) ~= 0].
	power _ (digitIndex - 1) * 8.
	d _ aPositiveInteger digitAt: digitIndex.
	[d odd] whileFalse: [
		power _ power + 1.
		d _ d bitShift: -1].
	^ power
! !

!DigitalSignatureAlgorithm methodsFor: 'private' stamp: 'jm 12/13/1999 14:39'!
nextRandom160
	"Answer a newly generated 160-bit random number in the range [1..(2^160 - 1)]."
	"Details: Try again in the extremely unlikely chance that zero is encountered."

	| result |
	result _ 0.
	[result = 0] whileTrue: [
		result _ SecureHashAlgorithm new hashInteger: randKey seed: randSeed.
		randKey _ randKey + result + 1].
	^ result
! !

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

DigitalSignatureAlgorithm class
	instanceVariableNames: ''!

!DigitalSignatureAlgorithm class methodsFor: 'class initialization' stamp: 'jm 12/21/1999 19:15'!
initialize
	"DigitalSignatureAlgorithm initialize"

	"SmallPrimes is a list of small primes greater than two."
	SmallPrimes _ Integer primesUpTo: 2000.
	SmallPrimes _ SmallPrimes copyFrom: 2 to: SmallPrimes size.

	"HighBitOfByte maps a byte to the index of its top non-zero bit."
	HighBitOfByte _ (0 to: 255) collect: [:byte | byte highBit].
! !


!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'jm 1/11/2000 00:08'!
generateKeySet
	"Generate and answer a key set for code signing. The result is a pair (<private key><public key>). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature."
	"Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!"
	"Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."
	"DigitalSignatureAlgorithm generateKeySet"

	| dsa |
	dsa _ DigitalSignatureAlgorithm new.
	(self confirm: 'Shall I seed the random generator from the current sound input?')
		ifTrue: [dsa initRandom: (dsa randomBitsFromSoundInput: 512)]
		ifFalse: [dsa initRandomFromUser].
	^ dsa generateKeySet
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'jm 12/22/1999 11:18'!
sign: aStringOrStream privateKey: privateKey
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."

	| dsa hasher h sig |
	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.
	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa computeSignatureForMessageHash: h privateKey: privateKey.
	^ dsa signatureToString: sig
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'RAA 5/31/2000 08:46'!
sign: aStringOrStream privateKey: privateKey dsa: dsa
	"Sign the given message (a stream or string) and answer a signature string."
	"Note: Unguessable random numbers are needed for message signing. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before signing a message. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams."

	| hasher h sig |

	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa computeSignatureForMessageHash: h privateKey: privateKey.
	^ dsa signatureToString: sig
! !

!DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'jm 12/22/1999 11:20'!
verify: signatureString isSignatureOf: aStringOrStream publicKey: publicKey
	"Answer true if the given signature string signs the given message (a stream or string)."
	"Note: Random numbers are not needed for signature verification; thus, there is no need to call initRandomFromUser before verifying a signature."

	| dsa hasher h sig |
	dsa _ DigitalSignatureAlgorithm new.
	hasher _ SecureHashAlgorithm new.
	(aStringOrStream class isBytes)
		ifTrue: [h _ hasher hashMessage: aStringOrStream]
		ifFalse: [h _ hasher hashStream: aStringOrStream].
	sig _ dsa stringToSignature: signatureString.
	^ dsa verifySignature: sig ofMessageHash: h publicKey: publicKey
! !


!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:23'!
example
	"Example of signing a message and verifying its signature."
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm example"

	| msg keys sig |
	msg _ 'This is a test...'.
	keys _ self testKeySet.
	sig _ self sign: msg privateKey: keys first.
	self inform: 'Signature created'.
	(self verify: sig isSignatureOf: msg publicKey: keys last)
		ifTrue: [self inform: 'Signature verified.']
		ifFalse: [self error: 'ERROR!! Signature verification failed'].
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'mdr 8/31/2000 18:43'!
testExamplesFromDisk
	"verify messages from file on disk"
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm testExamplesFromDisk"

	| msg  sig file publicKey |

	file _ FileStream readOnlyFileNamed: 'dsa.test.out'.
	[
		[file atEnd] whileFalse: [
			sig _ file nextChunk.
			msg _ file nextChunk.
			publicKey _ Compiler evaluate: file nextChunk.
			(self verify: sig isSignatureOf: msg publicKey: publicKey) ifTrue: [
				Transcript show: 'SUCCESS: ',msg; cr.
			] ifFalse: [
				self error: 'ERROR!! Signature verification failed'
			].
		].
	] ensure: [file close]
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'jm 12/22/1999 11:28'!
testKeySet
	"Answer a pair of keys for testing. The first key is the private key, the second one is the public key."
	"WARNING: This test key set is public should be used only for testing!! In a real application, the user would create a set of keys using generateKeySet and would keep the private key secret."

	^ #(
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 957348690772296812)
		(8343811888543852523216773185009428259187948644369498021763210776677854991854533186365944349987509452133156416880596803846631577352387751880552969116768071 1197175832754339660404549606408619548226315875117 1433467472198821951822151391684734233265646022897503720591270330985699984763922266163182803556189497900262038518780931942996381297743579119123094520048965 4645213122572190617807944614677917601101008235397095646475699959851618402406173485853587185431290863173614335452934961425661774118334228449202337038283799))
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 08:46'!
timeDecode: count
	"Example of signing a message and verifying its signature."
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm timeDecode: 20"

	| msg keys sig s dsa |

	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.

	#(1 10 100 1000 10000 100000) do: [ :extraLen |
		s _ String new: extraLen.
		1 to: s size do: [ :i | s at: i put: (Character value: 200 atRandom)].
		msg _ 'This is a test...',s.
		keys _ self testKeySet.
		sig _ self sign: msg privateKey: keys first dsa: dsa.
		"self inform: 'Signature created'."
		self timeDirect: [
			count timesRepeat: [
				(self verify: sig isSignatureOf: msg publicKey: keys last)
					ifFalse: [self error: 'ERROR!! Signature verification failed'].
			].
		] as: 'verify msgLen = ',msg size printString count: count
	].
! !

!DigitalSignatureAlgorithm class methodsFor: 'examples' stamp: 'RAA 5/31/2000 13:13'!
writeExamplesToDisk
	"Example of signing a message and verifying its signature. Used to create samples from one implementation that could later be tested with a different implementation"
	"Note: Secure random numbers are needed for key generation and message signing, but not for signature verification. There is no need to call initRandomFromUser if you are merely checking a signature."
	"DigitalSignatureAlgorithm writeExamplesToDisk"

	| sig file keyList dsa msgList |

	dsa _ DigitalSignatureAlgorithm new.
	dsa initRandomFromUser.
	self inform: 'About to generate 5 key sets. Will take a while'.
	keyList _ {self testKeySet},((1 to: 5) collect: [ :ignore | self generateKeySet]).
	msgList _ {'This is a test...'. 'This is the second test period.'. 'And finally, a third message'}.
	file _ FileStream newFileNamed: 'dsa.test.out'.
	[
		msgList do: [ :msg |
			keyList do: [ :keys |
				sig _ self sign: msg privateKey: keys first dsa: dsa.
				(self verify: sig isSignatureOf: msg publicKey: keys last) ifTrue: [
					file
						nextChunkPut: sig;
						nextChunkPut: msg;
						nextChunkPut: keys last storeString.
				] ifFalse: [
					self error: 'ERROR!! Signature verification failed'
				].
			].
		].
	] ensure: [file close]
! !


!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:35'!
runTiming
"
DigitalSignatureAlgorithm runTiming
"
	| results ops modeNames |

	modeNames _ #('standard dsa' 'standard integer' 'digitDiv:neg:').
	results _ OrderedCollection new.
	1 to: 3 do: [ :mode |
		results add: (DigitalSignatureAlgorithm timeMultiply: 100000 mode: mode),{mode}.
		results add: (DigitalSignatureAlgorithm timeRemainder: 100000 mode: mode),{mode}.
		results add: (DigitalSignatureAlgorithm timeToDivide: 100000 mode: mode),{mode}.
	].
	ops _ (results collect: [ :each | each second]) asSet asSortedCollection.
	ops do: [ :eachOp |
		results do: [ :eachResult |
			eachResult second = eachOp ifTrue: [
				Transcript show: eachResult first asStringWithCommas,'  ',
					eachResult second ,' took ',
					eachResult third asStringWithCommas,' ms using ',
					(modeNames at: eachResult fourth); cr
			].
		].
		Transcript cr.
	].

! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:21'!
time: aBlock as: aString count: anInteger

	^{anInteger. aString. (Time millisecondsToRun: aBlock)}! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:40'!
timeDirect: aBlock as: aString count: anInteger

	Transcript show: anInteger asStringWithCommas,'  ',
		aString ,' took ',
		(Time millisecondsToRun: aBlock) asStringWithCommas,' ms'; cr
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:18'!
timeMultiply: iterationCount mode: mode
	"Exercise the multiply primitive on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeMultiply: 100000 mode: 1"

	| dsa r x y |
	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		x _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		y _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa multiply: x by: y].
			mode = 2 ifTrue: [x * y].
		].

	] as: 'multiply' count: iterationCount
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:19'!
timeRemainder: iterationCount mode: mode
	"Exercise the remainder method on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeRemainder: 100000 mode: 1"

	| dsa r c d tmp |

	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		c _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		d _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		c < d ifTrue: [tmp _ c. c _ d. d _ tmp].
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa remainder: c mod: d].
			mode = 2 ifTrue: [c \\ d].
			mode = 3 ifTrue: [(c digitDiv: d neg: false) second].
		].
	] as: 'remainder' count: iterationCount
! !

!DigitalSignatureAlgorithm class methodsFor: 'testing' stamp: 'RAA 5/31/2000 08:19'!
timeToDivide: iterationCount mode: mode
	"Exercise the divide primitive on iterationCount pairs of random 60 bit integers."
	"DigitalSignatureAlgorithm timeToDivide: 100000 mode: 1"

	| dsa r c d tmp |
	dsa _ DigitalSignatureAlgorithm new.
	r _ Random new.
		c _ ((r next * 16r3FFFFFFF highBit) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		d _ ((r next * 16r3FFFFFFF) asInteger bitShift: 30) +
			 (r next * 16r3FFFFFFF) asInteger.
		c < d ifTrue: [tmp _ c. c _ d. d _ tmp].
	^self time: [
		iterationCount timesRepeat: [
			mode = 1 ifTrue: [dsa divide: c by: d].
			mode = 2 ifTrue: [c // d. c \\ d].
			mode = 3 ifTrue: [(c digitDiv: d neg: false) second].
		].
	] as: 'divide' count: iterationCount
! !
ArrayedCollection subclass: #DirectoryEntry
	instanceVariableNames: 'name creationTime modificationTime dirFlag fileSize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!DirectoryEntry commentStamp: '<historical>' prior: 0!
an entry in a directory; a reference to either a file or a directory.!


!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
creationTime
	"time the entry was created.  (what's its type?)"
	^creationTime! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'!
fileSize
	"size of the entry, if it's a file"
	^fileSize! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:38'!
isDirectory
	"whether this entry represents a directory"
	^dirFlag! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
modificationTime
	"time the entry was last modified"
	^modificationTime! !

!DirectoryEntry methodsFor: 'access' stamp: 'ls 7/15/1998 21:37'!
name
	"name of the entry"
	^name! !


!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:29'!
at: index
	"compatibility interface"
	"self halt: 'old-style access to DirectoryEntry'"
	index = 1 ifTrue: [ ^self name ].
	index = 2 ifTrue: [ ^self creationTime ].
	index = 3 ifTrue: [ ^self modificationTime ].
	index = 4 ifTrue:[ ^self isDirectory ].
	index = 5 ifTrue:[ ^self fileSize ].
	self error: 'invalid index specified'.! !

!DirectoryEntry methodsFor: 'access-compatibility' stamp: 'ls 7/15/1998 22:16'!
size
	^5! !


!DirectoryEntry methodsFor: 'private-initialization' stamp: 'ls 7/15/1998 21:42'!
privateName: name0  creationTime: creationTime0  modificationTime: modificationTime0  isDirectory: isDirectory0  fileSize: fileSize0
	name _ name0.
	creationTime _ creationTime0.
	modificationTime _ modificationTime0.
	dirFlag _ isDirectory0.
	fileSize _ fileSize0.! !

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

DirectoryEntry class
	instanceVariableNames: ''!

!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:42'!
fromArray: array
	^self name: (array at: 1) creationTime: (array at: 2) modificationTime: (array at: 3) isDirectory: (array at: 4) fileSize: (array at: 5) ! !

!DirectoryEntry class methodsFor: 'instance creation' stamp: 'ls 7/15/1998 21:41'!
name: name0  creationTime: creationTime  modificationTime: modificationTime   isDirectory: isDirectory  fileSize: fileSize
	^self new privateName: name0  creationTime: creationTime  modificationTime: modificationTime  isDirectory: isDirectory  fileSize: fileSize! !
Object subclass: #Discussion
	instanceVariableNames: 'notes title description relatedURL '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!Discussion commentStamp: '<historical>' prior: 0!
A Discussion has some header information and a collection of related notes.!


!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:25'!
addNote: aNote
	notes isNil ifTrue: [notes _ OrderedCollection new.].
	notes add: aNote.
	^notes size
! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:29'!
at: aKey
	^notes at: aKey! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:24'!
at: aKey addNote: aNote
	notes isNil ifTrue: [notes _ Dictionary new.].
	notes at: aKey put: aNote.
! !

!Discussion methodsFor: 'access' stamp: 'TPR 7/21/1998 10:57'!
author
	^self description! !

!Discussion methodsFor: 'access' stamp: 'TPR 7/21/1998 10:57'!
children
	^#()
! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'!
description
	^description! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'!
description: aString
	description _ aString! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:20'!
notes
	^notes
! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'!
relatedURL
	^relatedURL! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'!
relatedURL: aString
	relatedURL _ aString! !

!Discussion methodsFor: 'access' stamp: 'mjg 12/8/97 11:11'!
status
	| reply |
	reply _ WriteStream on: String new.
	reply nextPutAll: 'Number of notes: ', (notes size printString).
	notes size > 0
		ifTrue: [reply nextPutAll: '. Last note: ',(notes last timestamp).].
	^reply contents! !

!Discussion methodsFor: 'access' stamp: 'TPR 7/21/1998 10:45'!
timestamp
	^String new:0! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:20'!
title
	^title! !

!Discussion methodsFor: 'access' stamp: 'mjg 11/17/97 14:21'!
title: aString
	title _ aString! !

!Discussion methodsFor: 'access' stamp: 'TPR 7/21/1998 10:53'!
url
	"fake the url as the title"
	^'Comment.', self title! !
Object subclass: #DiskProxy
	instanceVariableNames: 'globalObjectName preSelector constructorSelector constructorArgs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DiskProxy commentStamp: '<historical>' prior: 0!
A DiskProxy is an externalized form of an object to write on a
DataStream. It contains a "constructor" message to regenerate
the object, in context, when sent a comeFullyUpOnReload message
(i.e. "internalize").

We are now using DiskProxy for shared system objects like StrikeFonts.

The idea is to define, for each kind of object that needs special
externalization, a class method that will internalize the object by
reconstructing it from its defining state. We call this a
"constructor" method. Then externalize such an object as a frozen
message that invokes this method--a DiskProxy.

(Here is the old comment:
Constructing a new object is good for any object that (1) can not be
externalized simply by snapshotting and reloading its instance
variables (like a CompiledMethod or a Picture), or (2) wants to be
free to evolve its internal representation without making stored
instances obsolete (and dangerous). Snapshotting and reloading an
object"s instance variables is a dangerous breach of encapsulation.

The internal structure of the class is then free to evolve. All
externalized instances will be useful as long as the
constructor methods are maintained with the same semantics.

There may be several constructor methods for a particular class. This
is useful for (1) instances with characteristically different
defining state, and (2) newer, evolved forms of an object and its
constructors, with the old constructor methods kept around so old
data can still be properly loaded.)

Create one like this example from class Picture

    DiskProxy global: #Picture
            selector: #fromByteArray:
                args: (Array with: self storage asByteArray)

* See also subclass DiskProxyQ that will construct an object in
the above manner and then send it a sequence of messages. This may save
creating a wide variety of constructor methods. It is also useful because
the newly read-in DiskProxyQ can catch messages like #objectContainedIn:
(via #doesNotUnderstand:) and add them to the queue of messages to
send to the new object.

* We may also want a subclass of DiskProxy that evaluates a string
expression to compute the receiver of the constructor message.

My instance variables:
* globalObjectName -- the Symbol name of a global object in the
    System dictionary (usually a class).
* constructorSelector -- the constructor message selector Symbol to
    send to the global object (perform:withArguments:), typically a
    variation on newFrom:.
* constructorArgs -- the Array of arguments to pass in the
    constructor message.

-- 11/9/92 Jerry Morrison
!


!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 11/7/2000 11:28'!
comeFullyUpOnReload: smartRefStream
	"Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.)  DataStream will substitute the object from this eval for the DiskProxy."
	| globalObj symbol pr nn arrayIndex |

	symbol _ globalObjectName.
	"See if class is mapped to another name"
	(smartRefStream respondsTo: #renamed) ifTrue: [
		"If in outPointers in an ImageSegment, remember original class name.  
		 See mapClass:installIn:.  Would be lost otherwise."
		((thisContext sender sender sender sender sender sender 
			sender sender receiver class == ImageSegment) and: [ 
		thisContext sender sender sender sender method == 
			(DataStream compiledMethodAt: #readArray)]) ifTrue: [
				arrayIndex _ (thisContext sender sender sender sender) tempAt: 4.
					"index var in readArray.  Later safer to find i on stack of context."
				smartRefStream renamedConv at: arrayIndex put: symbol].	"save original name"
		symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]].	"map"
	globalObj _ Smalltalk at: symbol 
		ifAbsent: [^ self error: 'Global not found'].
	((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [
		self inform: 'These objects will work better if opened in a Morphic World.
Dismiss and reopen all menus.'].

	preSelector ifNotNil: [
		Symbol hasInterned: preSelector ifTrue: [:selector |
			globalObj _ globalObj perform: selector]].
	symbol == #Project ifTrue: [
		(constructorSelector = #fromUrl:) ifTrue: [
			nn _ (constructorArgs first findTokens: '/') last.
			nn _ (nn findTokens: '.|') first.
			pr _ Project named: nn. 
			^ pr ifNil: [self] ifNotNil: [pr]].
		pr _ globalObj perform: constructorSelector withArguments: constructorArgs.
		^ pr ifNil: [self] ifNotNil: [pr]].	"keep the Proxy if Project does not exist"

	constructorSelector ifNil: [^ globalObj].
	constructorSelector ifNotNil: [
		Symbol hasInterned: constructorSelector ifTrue: [:selector |
			^ globalObj perform: selector
					withArguments: constructorArgs]].
					"args not checked against Renamed"
	^ nil 	"was not in proper form"! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 3/10/2000 23:50'!
constructorArgs
	^ constructorArgs! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 11/6/2000 22:38'!
constructorSelector
	^ constructorSelector! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 4/8/1999 12:58'!
global: globalNameSymbol preSelector: aSelector selector: selectorSymbol args: argArray
	"Initialize self as a DiskProxy constructor with the given
	globalNameSymbol, selectorSymbol, and argument Array.
	I will internalize by looking up the global object name in the
	SystemDictionary (Smalltalk) and sending it this message with
	these arguments."

	globalObjectName _ globalNameSymbol asSymbol.
	preSelector _ aSelector asSymbol.
	constructorSelector _ selectorSymbol asSymbol.
	constructorArgs _ argArray.! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 11/4/1999 19:28'!
global: globalNameSymbol selector: selectorSymbol args: argArray
	"Initialize self as a DiskProxy constructor with the given
	globalNameSymbol, selectorSymbol, and argument Array.
	I will internalize by looking up the global object name in the
	SystemDictionary (Smalltalk) and sending it this message with
	these arguments."

	(globalNameSymbol beginsWith: 'AnObsolete') ifTrue: [
		self error: 'Trying to write out, ', globalNameSymbol].
	globalObjectName _ globalNameSymbol asSymbol.
	constructorSelector _ selectorSymbol asSymbol.
	constructorArgs _ argArray.! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 11/6/2000 22:38'!
globalObjectName
	^ globalObjectName! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 11/6/2000 22:35'!
preSelector

	^ preSelector! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 4/8/1999 12:54'!
preSelector: aSelector

	preSelector _ aSelector! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 3/22/2000 14:23'!
printOn: aStream
	"Try to report the name of the project"

	globalObjectName == #Project ifFalse: [^ super printOn: aStream].
	constructorArgs size > 0 ifFalse: [^ super printOn: aStream].
	constructorArgs first class == String ifFalse: [^ super printOn: aStream].
	aStream nextPutAll: constructorArgs first, ' (on server)'! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 10/6/2000 15:18'!
simpleGlobalOrNil
	"Return the object I refer to if it is a simple global in Smalltalk."

	preSelector ifNotNil: [^ nil].
	constructorSelector == #yourself ifFalse: [^ nil].
	^ Smalltalk at: globalObjectName ifAbsent: [nil].
! !

!DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 3/26/98 11:17'!
storeDataOn: aDataStream
	"Besides just storing, get me inserted into references, so structures will know about class DiskProxy."

	super storeDataOn: aDataStream.
	aDataStream references at: self put: #none.
		"just so instVarInfo: will find it and put it into structures"! !



!DiskProxy methodsFor: 'exceptions' stamp: 'tk 3/14/2000 16:27'!
enter
	"Enter the new project"
	self enter: false revert: false saveForRevert: false.! !

!DiskProxy methodsFor: 'exceptions' stamp: 'RAA 6/3/2000 11:02'!
enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
	"Look for our project on the server, then try to enter it!!  DiskProxy is acting as a stub for the real thing.  Called from a ProjectViewMorph in the current project.  If have url, use it.  Else look in current Project's server and folder."

	constructorSelector == #namedUrl: ifTrue: ["Project namedUrl: xxx"
		^ ((Smalltalk at: globalObjectName) perform: #fromUrl:
					withArguments: constructorArgs) ].
	constructorSelector == #named: ifTrue: [
		CurrentProjectRefactoring currentFromMyServerLoad: constructorArgs first].	"name"
! !

!DiskProxy methodsFor: 'exceptions' stamp: 'RAA 5/17/2000 11:51'!
loadFromServer

	"In support of check for newer version in ProjectViewMorph menu"

	self enter
! !

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

DiskProxy class
	instanceVariableNames: ''!

!DiskProxy class methodsFor: 'as yet unclassified'!
global: globalNameSymbol selector: selectorSymbol args: argArray
    "Create a new DiskProxy constructor with the given
     globalNameSymbol, selectorSymbol, and argument Array.
     It will internalize itself by looking up the global object name
     in the SystemDictionary (Smalltalk) and sending it this message
     with these arguments."

    ^ self new global: globalNameSymbol
             selector: selectorSymbol
                 args: argArray! !
DisplayObject subclass: #DisplayMedium
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayMedium commentStamp: '<historical>' prior: 0!
I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.!


!DisplayMedium methodsFor: 'coloring'!
fill: aRectangle fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule over."

	self fill: aRectangle rule: Form over fillColor: aForm! !

!DisplayMedium methodsFor: 'coloring'!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule anInteger."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'coloring'!
fillBlack
	"Set all bits in the receiver to black (ones)."

	self fill: self boundingBox fillColor: Color black! !

!DisplayMedium methodsFor: 'coloring'!
fillBlack: aRectangle 
	"Set all bits in the receiver's area defined by aRectangle to black (ones)."

	self fill: aRectangle rule: Form over fillColor: Color black! !

!DisplayMedium methodsFor: 'coloring'!
fillColor: aColor
	"Set all pixels in the receiver to the color.  Must be a correct color for this depth of medium.  TK 1 Jun 96"

	self fill: self boundingBox fillColor: aColor! !

!DisplayMedium methodsFor: 'coloring'!
fillGray
	"Set all bits in the receiver to gray."

	self fill: self boundingBox fillColor: Color gray! !

!DisplayMedium methodsFor: 'coloring'!
fillGray: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to the gray mask."

	self fill: aRectangle rule: Form over fillColor: Color gray! !

!DisplayMedium methodsFor: 'coloring'!
fillShape: aShapeForm fillColor: aColor
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	^ self fillShape: aShapeForm fillColor: aColor at: 0@0! !

!DisplayMedium methodsFor: 'coloring' stamp: 'ar 5/28/2000 12:06'!
fillShape: aShapeForm fillColor: aColor at: location
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	((BitBlt current destForm: self sourceForm: aShapeForm fillColor: aColor
		combinationRule: Form paint
		destOrigin: location + aShapeForm offset sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits! !

!DisplayMedium methodsFor: 'coloring'!
fillWhite
	"Set all bits in the form to white."

	self fill: self boundingBox fillColor: Color white.
! !

!DisplayMedium methodsFor: 'coloring'!
fillWhite: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to white."

	self fill: aRectangle rule: Form over fillColor: Color white.
! !

!DisplayMedium methodsFor: 'coloring'!
fillWithColor: aColor
	"Fill the receiver's bounding box with the given color."

	self fill: self boundingBox fillColor: aColor.
! !

!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:01'!
reverse
	"Change all the bits in the receiver that are white to black, and the ones 
	that are black to white."

	self fill: self boundingBox rule: Form reverse fillColor: (Color quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:00'!
reverse: aRectangle
	"Change all the bits in the receiver's area that intersects with aRectangle 
	that are white to black, and the ones that are black to white."

	self fill: aRectangle rule: Form reverse fillColor: (Color quickHighLight: self depth)! !

!DisplayMedium methodsFor: 'coloring'!
reverse: aRectangle fillColor: aMask	
	"Change all the bits in the receiver's area that intersects with aRectangle 
	according to the mask. Black does not necessarily turn to white, rather it 
	changes with respect to the rule and the bit in a corresponding mask 
	location. Bound to give a surprise."

	self fill: aRectangle rule: Form reverse fillColor: aMask! !


!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses black for 
	drawing the border."

	self border: aRectangle width: borderWidth fillColor: Color black.
! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: Form over
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: combinationRule
		fillColor: aHalfTone! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of each edge of the border is determined by the four coordinates 
	of insets. Uses aHalfTone and combinationRule for drawing the border."

	(aRectangle areasOutside: (aRectangle insetBy: insets)) do:
		[:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! !


!DisplayMedium methodsFor: 'displaying'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	self subclassResponsibility! !

!DisplayMedium methodsFor: 'displaying'!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Draw line by copying the argument, sourceForm, starting at location 
	beginPoint and ending at endPoint, clipped by the rectangle, clipRect. 
	The rule and mask for copying are the arguments anInteger and aForm."

	self subclassResponsibility! !
Object subclass: #DisplayObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayObject commentStamp: '<historical>' prior: 0!
The abstract protocol for most display primitives that are used by Views for presenting information on the screen.!


!DisplayObject methodsFor: 'accessing'!
extent
	"Answer the point that represents the width and height of the receiver's 
	bounding box."

	^self boundingBox extent! !

!DisplayObject methodsFor: 'accessing'!
height
	"Answer the number that represents the height of the receiver's 
	bounding box."

	^self boundingBox height! !

!DisplayObject methodsFor: 'accessing'!
offset
	"Answer the amount by which the receiver should be offset when it is 
	displayed or its position is tested."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'accessing'!
offset: aPoint 
	"Set the amount by which the receiver's position is offset."

	^self! !

!DisplayObject methodsFor: 'accessing'!
relativeRectangle
	"Answer a Rectangle whose top left corner is the receiver's offset position 
	and whose width and height are the same as the receiver."

	^Rectangle origin: self offset extent: self extent! !

!DisplayObject methodsFor: 'accessing'!
width
	"Answer the number that represents the width of the receiver's bounding 
	box."

	^self boundingBox width! !


!DisplayObject methodsFor: 'truncation and round off'!
rounded
	"Convert the offset of the receiver to integer coordinates."

	self offset: self offset rounded! !


!DisplayObject methodsFor: 'transforming'!
align: alignmentPoint with: relativePoint 
	"Translate the receiver's offset such that alignmentPoint aligns with 
	relativePoint."

	self offset: (self offset translateBy: relativePoint - alignmentPoint)! !

!DisplayObject methodsFor: 'transforming'!
scaleBy: aPoint 
	"Scale the receiver's offset by aPoint."

	self offset: (self offset scaleBy: aPoint)! !

!DisplayObject methodsFor: 'transforming'!
translateBy: aPoint 
	"Translate the receiver's offset."

	self offset: (self offset translateBy: aPoint)! !


!DisplayObject methodsFor: 'display box access'!
boundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's space of information."

	^self computeBoundingBox! !

!DisplayObject methodsFor: 'display box access'!
center

	^ self boundingBox center! !

!DisplayObject methodsFor: 'display box access'!
computeBoundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's area for displaying information. This is the primitive for 
	computing the area if it is not already known."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'display box access'!
initialExtent
	"Included here for when a FormView is being opened
	as a window.  (4@4) covers border widths."

	^ self extent + (4@4) ! !


!DisplayObject methodsFor: 'displaying-generic'!
displayAt: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	the displayMedium, rule and halftone."

	self displayOn: Display
		at: aDisplayPoint
		clippingBox: Display boundingBox
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium
	"Simple default display in order to see the receiver in the upper left 
	corner of screen."

	self displayOn: aDisplayMedium at: 0 @ 0! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone. Information to be displayed must be confined to the 
	area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: clipRectangle
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the basic display primitive for graphic display objects. Display 
	the receiver located at aDisplayPoint with rule, ruleInteger, and mask, 
	aForm. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger
	"Display the receiver located at aPoint with default setting for the 
	halftone and clippingBox."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: ruleInteger
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle 
	"Display primitive for the receiver where a DisplayTransformation is 
	provided as an argument. Alignment is defaulted to the receiver's 
	rectangle. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle center
		with: self relativeRectangle center
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint 
	"Display primitive where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. Information to be 
	displayed must be confined to the area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: alignmentPoint
		with: relativePoint
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. Translate by 
	relativePoint-alignmentPoint. Information to be displayed must be 
	confined to the area that intersects with clipRectangle."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	self displayOn: aDisplayMedium
		at: (absolutePoint - alignmentPoint) 
		clippingBox: clipRectangle 
		rule: ruleInteger 
		fillColor: aForm ! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: aPoint
		with: aPoint
		rule: Form over
		fillColor: nil! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle origin
		with: self relativeRectangle origin
		rule: ruleInteger
		fillColor: aForm! !

!DisplayObject methodsFor: 'displaying-generic'!
displayOnPort: aPort 
	self displayOnPort: aPort at: 0@0! !

!DisplayObject methodsFor: 'displaying-generic' stamp: 'jm 10/21/97 16:56'!
displayOnPort: port at: location rule: rule

	port copyForm: self to: location rule: rule.
! !

!DisplayObject methodsFor: 'displaying-generic'!
followCursor
	"Just show the Form following the mouse. 6/21/96 tk"
	Cursor blank showWhile:
		[self follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]
! !


!DisplayObject methodsFor: 'displaying-Display'!
display 
	"Display the receiver on the Display at location 0,0."

	self displayOn: Display! !

!DisplayObject methodsFor: 'displaying-Display'!
follow: locationBlock while: durationBlock
   "Move an image around on the Display. Restore the background
   continuously without causing flashing. The argument, locationBlock,
   supplies each new location, and the argument, durationBlock, supplies
   true to continue, and then false to stop.
   8/20/96 sw: call follow:while:bitsBehind: to do the real work.  Note that th
method
   now returns the final bits behind as method value."
 
   | bitsBehind loc |
   bitsBehind _ Form fromDisplay: ((loc _ locationBlock value) extent: self extent).
   ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'ar 5/28/2000 12:06'!
follow: locationBlock while: durationBlock bitsBehind: initialBitsBehind startingLoc: loc
   "Move an image around on the Display. Restore the background continuously without causing flashing. The argument, locationBlock, supplies each new location, and the argument, durationBlock, supplies true to continue or false to stop. This variant takes the bitsBehind as an input argument, and returns the final saved saved bits as method value."

   | location rect1 save1 save1Blt buffer bufferBlt newLoc rect2 bothRects |
   location _ loc.
   rect1 _ location extent: self extent.
   save1 _ initialBitsBehind.
   save1Blt _ BitBlt current toForm: save1.
   buffer _ Form extent: self extent*2 depth: Display depth.  "Holds overlapping region"
   bufferBlt _ BitBlt current toForm: buffer.
   Display deferUpdates: true.
   self displayOn: Display at: location rule: Form paint.
   Display deferUpdates: false; forceToScreen: (location extent: self extent).
   [durationBlock value] whileTrue: [
		newLoc _ locationBlock value.
		newLoc ~= location ifTrue: [
			rect2 _ newLoc extent: self extent.
			bothRects _ rect1 merge: rect2.
			(rect1 intersects: rect2)
				ifTrue: [  "when overlap, buffer background for both rectangles"
					bufferBlt copyFrom: bothRects in: Display to: 0@0.
					bufferBlt copyFrom: save1 boundingBox in: save1 to: rect1 origin - bothRects origin.
					"now buffer is clean background; get new bits for save1"
					save1Blt copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: buffer.
					self displayOnPort: bufferBlt at: rect2 origin - bothRects origin rule: Form paint.
					Display deferUpdates: true.
					Display copy: bothRects from: 0@0 in: buffer rule: Form over.
					Display deferUpdates: false; forceToScreen: bothRects]
				ifFalse: [  "when no overlap, do the simple thing (both rects might be too big)"
					Display deferUpdates: true.
					Display copy: (location extent: save1 extent) from: 0@0 in: save1 rule: Form over.
					save1Blt copyFrom: rect2 in: Display to: 0@0.
					self displayOn: Display at: newLoc rule: Form paint.
					Display deferUpdates: false; 
						forceToScreen: (location extent: save1 extent); 
						forceToScreen: (newLoc extent: self extent)].
			location _ newLoc.
			rect1 _ rect2]].

	^ save1 displayOn: Display at: location
! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'di 9/12/97 11:09'!
isTransparent
	^ false! !

!DisplayObject methodsFor: 'displaying-Display'!
slideFrom: startPoint to: stopPoint nSteps: nSteps 
	"does not display at the first point, but does at the last"
	| i p delta |
	i_0.  p_ startPoint.
	delta _ (stopPoint-startPoint) // nSteps.
	^ self follow: [p_ p+delta]
		while: [(i_i+1) < nSteps]! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'jm 10/22/97 07:43'!
slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs
	"Slide this object across the display over the given number of steps, pausing for the given number of milliseconds after each step."
	"Note: Does not display at the first point, but does at the last."

	| i p delta |
	i _ 0.
	p _ startPoint.
	delta _ (stopPoint - startPoint) / nSteps asFloat.
	^ self
		follow: [(p _ p + delta) truncated]
		while: [
			(Delay forMilliseconds: milliSecs) wait.
			(i _ i + 1) < nSteps]
! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'di 10/19/97 12:05'!
slideFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs andStay: stayAtEnd
	"Does not display at the first point, but does at the last.
	Moreover, if stayAtEnd is true, it leaves the dragged image at the stopPoint"
	| i done |
	i _ 0.
	^ self follow: [startPoint + ((stopPoint-startPoint) * i // nSteps)]
		while: [milliSecs ifNotNil: [(Delay forMilliseconds: milliSecs) wait].
				((done _ (i _ i+1) > nSteps) and: [stayAtEnd])
					ifTrue: [^ self "Return without clearing the image"].
				done not]! !

!DisplayObject methodsFor: 'displaying-Display' stamp: 'sr 6/6/2000 05:37'!
slideWithFirstFrom: startPoint to: stopPoint nSteps: nSteps delay: milliSecs 
	"Slide this object across the display over the given number of steps, 
	pausing for the given number of milliseconds after each step."
	"Note: Does display at the first point and at the last."
	| i p delta |
	i _ 0.
	delta _ stopPoint - startPoint / nSteps asFloat.
	p _ startPoint - delta.
	^ self follow: [(p _ p + delta) truncated]
		while: 
			[(Delay forMilliseconds: milliSecs) wait.
			(i _ i + 1) <= nSteps]! !


!DisplayObject methodsFor: 'fileIn/Out'!
writeOnFileNamed: fileName 
	"Saves the receiver on the file fileName in the format:
		fileCode, depth, extent, offset, bits."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	self writeOn: file.
	file close
"
 | f |
[(f _ Form fromUser) boundingBox area>25] whileTrue:
	[f writeOnFileNamed: 'test.form'.
	(Form newFromFileNamed: 'test.form') display].
"! !

!DisplayObject methodsFor: 'fileIn/Out' stamp: 'tk 2/19/1999 07:20'!
writeUncompressedOnFileNamed: fileName 
	"Saves the receiver on the file fileName in the format:
		fileCode, depth, extent, offset, bits."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	self writeUncompressedOn: file.
	file close
"
 | f |
[(f _ Form fromUser) boundingBox area>25] whileTrue:
	[f writeUncompressedOnFileNamed: 'test.form'.
	(Form fromBinaryStream: (FileStream oldFileNamed: 'test.form')) display].
"! !

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

DisplayObject class
	instanceVariableNames: ''!

!DisplayObject class methodsFor: 'fileIn/Out' stamp: 'mdr 8/31/2000 19:11'!
collectionFromFileNamed: fileName 
	"Answer a collection of Forms read from the external file 
	named fileName. The file format is: fileCode, {depth, extent, offset, bits}."

	| formList f fileCode |
	formList _ OrderedCollection new.
	f _ (FileStream readOnlyFileNamed: fileName) binary.
	fileCode _ f next.
	fileCode = 1
		ifTrue: [
			[f atEnd] whileFalse: [formList add: (self new readFromOldFormat: f)]]
		ifFalse: [
			fileCode = 2 ifFalse: [self error: 'unknown Form file format'. ^ formList].
			[f atEnd] whileFalse: [formList add: (self new readFrom: f)]].
	f close.
	^ formList
! !

!DisplayObject class methodsFor: 'fileIn/Out'!
writeCollection: coll onFileNamed: fileName 
	"Saves a collection of Forms on the file fileName in the format:
		fileCode, {depth, extent, offset, bits}."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	coll do: [:f | f writeOn: file].
	file close
"
 | f c | c _ OrderedCollection new.
[(f _ Form fromUser) boundingBox area>25] whileTrue: [c add: f].
Form writeCollection: c onFileNamed: 'test.forms'.
c _ Form collectionFromFileNamed: 'test.forms'.
1 to: c size do: [:i | (c at: i) displayAt: 0@(i*100)].
"! !
CharacterScanner subclass: #DisplayScanner
	instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!DisplayScanner commentStamp: '<historical>' prior: 0!
My instances are used to scan text and display it on the screen or in a hidden form.!


!DisplayScanner methodsFor: 'scanning' stamp: 'di 9/3/2000 16:21'!
displayLine: textLine offset: offset leftInRun: leftInRun
	"The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated).  leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions."
	| done stopCondition nowLeftInRun startIndex string lastPos |
	line _ textLine.
	morphicOffset _ offset.
	leftMargin _ (line leftMarginForAlignment: textStyle alignment) + offset x.
	destX _ runX _ leftMargin.
	rightMargin _ line rightMargin + offset x.
	lineY _ line top + offset y.
	lineHeight _ line lineHeight.
	fillBlt == nil ifFalse:
		["Not right"
		fillBlt destX: line left destY: lineY
			width: line width left height: lineHeight; copyBits].
	lastIndex _ line first.
	leftInRun <= 0
		ifTrue: [self setStopConditions.  "also sets the font"
				nowLeftInRun _ text runLengthFor: lastIndex]
		ifFalse: [nowLeftInRun _ leftInRun].
	destY _ lineY + line baseline - font ascent.
	runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last.
	spaceCount _ 0.
	done _ false.
	string _ text string.
	[done] whileFalse:[
		startIndex _ lastIndex.
		lastPos _ destX@destY.
		stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: string rightX: rightMargin stopConditions: stopConditions
						kern: kern.
		lastIndex >= startIndex ifTrue:[
			font displayString: string on: bitBlt 
				from: startIndex to: lastIndex at: lastPos kern: kern].
		"see setStopConditions for stopping conditions for displaying."
		done _ self perform: stopCondition].
	^ runStopIndex - lastIndex   "Number of characters remaining in the current run"! !

!DisplayScanner methodsFor: 'scanning' stamp: 'di 9/3/2000 16:18'!
displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle
	"The central display routine [MVC only]. The call on the primitive 
	(scanCharactersFrom:to:in:rightX:) will be interrupted according to an 
	array of stop conditions passed to the scanner at which time the code to 
	handle the stop condition is run and the call on the primitive continued 
	until a stop condition returns true (which means the line has 
	terminated)."
	| runLength done stopCondition leftInRun startIndex string lastPos |
	"leftInRun is the # of characters left to scan in the current run;
		when 0, it is time to call 'self setStopConditions'"
	leftInRun _ 0.
	self initializeFromParagraph: aParagraph clippedBy: visibleRectangle.
	ignoreColorChanges _ false.
	paragraph _ aParagraph.
	foregroundColor _ paragraphColor _ aParagraph foregroundColor.
	backgroundColor _ aParagraph backgroundColor.
	aParagraph backgroundColor isTransparent
		ifTrue: [fillBlt _ nil]
		ifFalse: [fillBlt _ bitBlt copy.  "Blt to fill spaces, tabs, margins"
				fillBlt sourceForm: nil; sourceOrigin: 0@0.
				fillBlt fillColor: aParagraph backgroundColor].
	rightMargin _ aParagraph rightMarginForDisplay.
	lineY _ aParagraph topAtLineIndex: linesInterval first.
	linesInterval do: 
		[:lineIndex | 
		leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex.
		destX _ (runX _ leftMargin).
		line _ aParagraph lines at: lineIndex.
		lineHeight _ line lineHeight.
		fillBlt == nil ifFalse:
			[fillBlt destX: visibleRectangle left destY: lineY
				width: visibleRectangle width height: lineHeight; copyBits].
		lastIndex _ line first.
		leftInRun <= 0
			ifTrue: [self setStopConditions.  "also sets the font"
					leftInRun _ text runLengthFor: line first].
		destY _ lineY + line baseline - font ascent.  "Should have happened in setFont"
		runLength _ leftInRun.
		runStopIndex _ lastIndex + (runLength - 1) min: line last.
		leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).
		spaceCount _ 0.
		done _ false.
		string _ text string.
		[done] whileFalse:[
			startIndex _ lastIndex.
			lastPos _ destX@destY.
			stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
						in: string rightX: rightMargin stopConditions: stopConditions
						kern: kern.
			lastIndex >= startIndex ifTrue:[
				font displayString: string on: bitBlt 
					from: startIndex to: lastIndex at: lastPos kern: kern].
		"see setStopConditions for stopping conditions for displaying."
		done _ self perform: stopCondition].
		lineY _ lineY + lineHeight]! !

!DisplayScanner methodsFor: 'scanning' stamp: 'RAA 7/15/2000 10:23'!
placeEmbeddedObject: anchoredMorph

	(super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
	anchoredMorph isMorph ifTrue: [
		anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset
	] ifFalse: [
		destY _ lineY.
		runX _ destX.
		anchoredMorph 
			displayOn: bitBlt destForm 
			at: destX - anchoredMorph width @ destY
			clippingBox: bitBlt clipRect
	].
	^ true! !


!DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:49'!
doesDisplaying
	^true! !

!DisplayScanner methodsFor: 'private' stamp: 'di 9/3/2000 16:03'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	super initializeFromParagraph: aParagraph clippedBy: clippingRectangle.
	bitBlt _ BitBlt current toForm: aParagraph destinationForm.
	bitBlt combinationRule: Form paint.
	bitBlt colorMap:
		(Bitmap with: 0      "Assumes 1-bit deep fonts"
				with: (aParagraph foregroundColor pixelValueForDepth: bitBlt destForm depth)).
	bitBlt clipRect: clippingRectangle.
! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 19:26'!
setDestForm: df
	bitBlt setDestForm: df.! !

!DisplayScanner methodsFor: 'private' stamp: 'di 9/3/2000 16:13'!
setFont 
	foregroundColor _ paragraphColor.
	super setFont.  "Sets font and emphasis bits, and maybe foregroundColor"
	font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent.
	text ifNotNil:[destY _ lineY + line baseline - font ascent]! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 20:25'!
setPort: aBitBlt
	"Install the BitBlt to use"
	bitBlt _ aBitBlt.
	bitBlt sourceForm: nil. "Make sure font installation won't be confused"
! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'!
text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode
	text _ t.
	textStyle _ ts. 
	foregroundColor _ paragraphColor _ foreColor.
	(backgroundColor _ backColor) isTransparent ifFalse:
		[fillBlt _ blt.
		fillBlt fillColor: backgroundColor].
	ignoreColorChanges _ shadowMode! !

!DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'!
textColor: textColor
	ignoreColorChanges ifTrue: [^ self].
	foregroundColor _ textColor! !


!DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 5/19/2000 14:46'!
characterNotInFont
	"See the note in CharacterScanner>>characterNotInFont.
	All fonts have an illegal character to be used when a character is not 
	within the font's legal range. When characters out of ranged are 
	encountered in scanning text, then this special character indicates the 
	appropriate behavior. The character is usually treated as a unary 
	message understood by a subclass of CharacterScanner."

	| illegalAsciiString saveIndex stopCondition lastPos |
	saveIndex _ lastIndex.
	lastPos _ destX @ destY.
	illegalAsciiString _ String with: (font maxAscii + 1) asCharacter.
	stopCondition _ self scanCharactersFrom: 1 to: 1
			in: illegalAsciiString
			rightX: rightMargin stopConditions: stopConditions
			kern: kern.
	font displayString: illegalAsciiString 
			on: bitBlt from: 1 to: 1 at: lastPos kern: kern.
	lastIndex _ saveIndex + 1.
	stopCondition ~= (stopConditions at: EndOfRun)
		ifTrue:	[^self perform: stopCondition]
		ifFalse: [lastIndex = runStopIndex
					ifTrue:	[^self perform: (stopConditions at: EndOfRun)].
				^false]
! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:42'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:24'!
crossedX
	"This condition will sometimes be reached 'legally' during display, when, 
	for instance the space that caused the line to wrap actually extends over 
	the right boundary. This character is allowed to display, even though it 
	is technically outside or straddling the clipping ectangle since it is in 
	the normal case not visible and is in any case appropriately clipped by 
	the scanner."

	^ true ! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:24'!
endOfRun
	"The end of a run in the display case either means that there is actually 
	a change in the style (run code) to be associated with the string or the 
	end of this line has been reached."
	| runLength |
	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	runStopIndex _ lastIndex + (runLength - 1) min: line last.
	self setStopConditions.
	^ false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:20'!
paddedSpace
	"Each space is a stop condition when the alignment is right justified. 
	Padding must be added to the base width of the space according to 
	which space in the line this space is and according to the amount of 
	space that remained at the end of the line when it was composed."

	spaceCount _ spaceCount + 1.
	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
	lastIndex _ lastIndex + 1.
	^ false! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:47'!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	textStyle alignment = Justified ifTrue:[
		"Make a local copy of stop conditions so we don't modify the default"
		stopConditions == DefaultStopConditions 
			ifTrue:[stopConditions _ stopConditions copy].
		stopConditions at: Space asciiValue + 1 put: #paddedSpace]! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'RAA 9/6/2000 15:56'!
setYFor: anchoredMorph

	anchoredMorph top: (lineY - morphicOffset y).
	^ true! !

!DisplayScanner methodsFor: 'stop conditions' stamp: 'di 9/3/2000 16:19'!
tab
	destX _ (textStyle alignment == Justified and: [self leadingTab not])
		ifTrue:		"imbedded tabs in justified text are weird"
			[destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
		ifFalse: 
			[textStyle nextTabXFrom: destX
				leftMargin: leftMargin
				rightMargin: rightMargin].
	lastIndex _ lastIndex + 1.
	^ false! !


!DisplayScanner methodsFor: 'quick print' stamp: 'RAA 6/16/2000 16:16'!
drawString: aString at: aPoint
	"Draw the given string."

	destX _ aPoint x asInteger.
	destY _ aPoint y asInteger.
	lastIndex _ 1.		"else the prim will fail"
	self primScanCharactersFrom: 1 to: aString size in: aString
		rightX: bitBlt clipX + bitBlt clipWidth + font maxWidth
		stopConditions: stopConditions kern: kern.
	font displayString: aString on: bitBlt from: 1 to: lastIndex at: aPoint kern: kern.! !

!DisplayScanner methodsFor: 'quick print' stamp: 'ar 5/17/2000 17:41'!
lineHeight
	"Answer the height of the font used by QuickPrint."

	^ font height! !

!DisplayScanner methodsFor: 'quick print' stamp: 'ar 5/28/2000 12:07'!
quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor
	"Initialize myself."
	bitBlt _ BitBlt current toForm: aForm.
	backgroundColor _ Color transparent.
	paragraphColor _ textColor.
	font _ aStrikeFont ifNil: [TextStyle defaultFont].
	emphasisCode _ 0.
	kern _ 0.
	indentationLevel _ 0.
	self setFont.
	"Override cbrule and map"
	bitBlt combinationRule: Form paint.
	bitBlt colorMap: (Bitmap with: 0      "Assumes 1-bit deep fonts"
						with: (textColor pixelValueForDepth: bitBlt destForm depth)).
	bitBlt clipRect: aRectangle.! !

!DisplayScanner methodsFor: 'quick print' stamp: 'RAA 6/16/2000 16:16'!
stringWidth: aString
	"Answer the width of the given string."
	destX _ destY _ 0.
	aString ifNil: [^ 0].
	lastIndex _ 1.		"else the prim will fail"
	self primScanCharactersFrom: 1 to: aString size in: aString
		rightX: 99999	"virtual infinity"
		stopConditions: stopConditions
		kern: kern.
	^ destX
"
	(1 to: 10) collect: [:i | QuickPrint new stringWidth: (String new: i withAll: $A)]
"! !

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

DisplayScanner class
	instanceVariableNames: ''!

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'!
defaultFont
	^ TextStyle defaultFont! !

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'!
quickPrintOn: aForm
	"Create an instance to print on the given form in the given rectangle."

	^(super new) quickPrintOn: aForm box: aForm boundingBox font: self defaultFont color: Color black! !

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'!
quickPrintOn: aForm box: aRectangle
	"Create an instance to print on the given form in the given rectangle."

	^(super new) quickPrintOn: aForm box: aRectangle font: self defaultFont color: Color black! !

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'!
quickPrintOn: aForm box: aRectangle font: aStrikeFont
	"Create an instance to print on the given form in the given rectangle."

	^(super new) quickPrintOn: aForm box: aRectangle font: aStrikeFont color: Color black! !

!DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'!
quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor
	"Create an instance to print on the given form in the given rectangle."

	^ (super new) quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor! !


!DisplayScanner class methodsFor: 'examples' stamp: 'ar 5/17/2000 17:41'!
example
	"This will quickly print all the numbers from 1 to 100 on the display,
	and then answer the default width and height of the string 'hello world'."
	"NewDisplayScanner example"
	| scanner |
	scanner _ self quickPrintOn: Display.
	0 to: 99 do: [: i | scanner drawString: i printString at: (i//10*20) @ (i\\10*12) ].
	^ (scanner stringWidth: 'hello world') @ (scanner lineHeight)! !
Form subclass: #DisplayScreen
	instanceVariableNames: 'clippingBox '
	classVariableNames: 'DisplayChangeSignature OuterMorphicWorld ScreenSave '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!DisplayScreen commentStamp: '<historical>' prior: 0!
There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. 
	Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system.
	To change the depth of your Display...
		Display newDepth: 16.
		Display newDepth: 8.
		Display newDepth: 1.
Valid display depths are 1, 2, 4, 8, 16 and 32.  It is suggested that you run with your monitors setting the same, for better speed and color fidelity.  Note that this can add up to 4Mb for the Display form.  Finally, note that newDepth: ends by executing a 'ControlManager restore' which currently terminates the active process, so nothing that follows in the doit will get executed.

Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely).  The color choice an be observed by executing Color fromUser in whatever depth you are using.
!


!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'!
copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf 
	(BitBlt current
		destForm: self
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: rect origin
		extent: rect extent
		clipRect: (clipRect intersect: clippingBox)) copyBits! !

!DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:07'!
copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map
	((BitBlt current
		destForm: self
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: rect origin
		extent: rect extent
		clipRect: (clipRect intersect: clippingBox)) colorMap: map) copyBits! !

!DisplayScreen methodsFor: 'displaying' stamp: 'jm 5/22/1998 01:23'!
flash: aRectangle 
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: 100) wait.
	self reverse: aRectangle.
	self forceDisplayUpdate.
! !

!DisplayScreen methodsFor: 'displaying' stamp: 'RAA 6/2/2000 12:09'!
flash: aRectangle andWait: msecs
	"Flash the area of the screen defined by the given rectangle."

	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
	self reverse: aRectangle.
	self forceDisplayUpdate.
	(Delay forMilliseconds: msecs) wait.
! !


!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 10:15'!
bestGuessOfCurrentWorld

	^World
! !

!DisplayScreen methodsFor: 'other'!
boundingBox
	clippingBox == nil
		ifTrue: [clippingBox _ super boundingBox].
	^ clippingBox! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 6/14/2000 17:05'!
changeMorphicWorldTo: aWorldOrNil

        self flag: #bob.        
        OuterMorphicWorld _ World _ aWorldOrNil.
! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 10/5/2000 18:59'!
checkCurrentHandForObjectToPaste

	| response |
	self flag: #bob.	
	World currentHand pasteBuffer ifNil: [^self].
	response _ (PopUpMenu labels: 'Delete\Keep' withCRs)
		startUpWithCaption: 'Hand is holding a Morph in its paste buffer:\' withCRs,
			World currentHand pasteBuffer printString.
	response = 1 ifTrue: [World currentHand pasteBuffer: nil].
! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 10/5/2000 18:59'!
checkCurrentHandForObjectToPaste2

	self flag: #bob.	
	World currentHand pasteBuffer ifNil: [^self].
	self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
		World currentHand pasteBuffer printString.

! !

!DisplayScreen methodsFor: 'other'!
clippingTo: aRect do: aBlock
	"Display clippingTo: Rectangle fromUser do:
	[ScheduledControllers restore: Display fullBoundingBox]"
	| saveClip |
	saveClip _ clippingBox.
	clippingBox _ aRect.
	aBlock value.
	clippingBox _ saveClip! !

!DisplayScreen methodsFor: 'other' stamp: 'jm 5/17/1998 08:29'!
deferUpdates: aBoolean
	"Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails."

	<primitive: 126>
	^ nil  "answer nil if primitive fails"
! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 11/27/1999 15:48'!
displayChangeSignature

	^DisplayChangeSignature! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 6/2/2000 10:52'!
doOneCycleMorphic

	self getOuterMorphicWorld doOneCycle.

! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 6/2/2000 10:50'!
doOneCycleNowMorphic

	self getOuterMorphicWorld doOneCycleNow.

! !

!DisplayScreen methodsFor: 'other' stamp: 'jm 5/21/1998 23:48'!
forceDisplayUpdate
	"On platforms that buffer screen updates, force the screen to be updated immediately. On other platforms, or if the primitive is not implemented, do nothing."

	<primitive: 231>
	"do nothing if primitive fails"! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 2/11/1999 18:14'!
forceToScreen
	"Force the entire display area to the screen"
	^self forceToScreen: self boundingBox! !

!DisplayScreen methodsFor: 'other' stamp: 'jm 5/19/1998 17:50'!
forceToScreen: aRectangle
	"Force the given rectangular section of the Display to be copied to the screen. The primitive call does nothing if the primitive is not implemented. Typically used when the deferUpdates flag in the virtual machine is on; see deferUpdates:."

	self primShowRectLeft: aRectangle left
		right: aRectangle right
		top: aRectangle top
		bottom: aRectangle bottom.
! !

!DisplayScreen methodsFor: 'other'!
fullBoundingBox
	^ super boundingBox! !

!DisplayScreen methodsFor: 'other'!
fullScreen   "Display fullScreen"

	ScreenSave notNil ifTrue: [Display _ ScreenSave].
	clippingBox _ super boundingBox! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 6/14/2000 17:04'!
getCurrentMorphicWorld

        ^RequestCurrentWorldNotification signal ifNil: [
                (self morphicWorldAt: Sensor cursorPoint) ifNil: [
                        self getOuterMorphicWorld
                ].
        ]

! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/26/2000 09:53'!
getOuterMorphicWorld

	^OuterMorphicWorld ifNil: [OuterMorphicWorld _ World]
! !

!DisplayScreen methodsFor: 'other'!
height
	^ self boundingBox height! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 10:01'!
isCurrentMorphicWorld: aWorld

	self flag: #bob.	
	^aWorld == World

! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 11/6/2000 12:11'!
lastKnownCursorPoint

	self flag: #bob.		"maybe Sensor cursorPoint is adequate"
	^Sensor cursorPoint

"==== World cursorPoint sometimes seems to be 0@0 (fake events or World that has yet had no events??)
	^Smalltalk isMorphic ifTrue: [World cursorPoint] ifFalse: [Sensor cursorPoint]
===="! !

!DisplayScreen methodsFor: 'other' stamp: 'di 9/24/2000 12:49'!
morphicWorldAt: aPoint 
	| roots outer worldCount |

	outer _ self getOuterMorphicWorld ifNil: [^ nil].
	worldCount _ 0.
	outer worldMorphsDo: [ :each | worldCount _ worldCount + 1].
	worldCount < 2 ifTrue: [^outer].
	roots _ outer rootMorphsAt: aPoint.
	roots isEmpty ifTrue: [^ outer].
	^ ((roots first morphsAt: aPoint)
		detect: [:each | true]
		ifNone: [roots first]) world! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 6/2/2000 17:23'!
morphicWorldString

	^(self morphicWorldAt: Sensor cursorPoint) hash printString

"===
	aString _ UpdatingStringMorph new target: Display.
	aString useStringFormat; color: Color blue; stepTime: 1000; getSelector: #morphicWorldString.
	aString openInWorld.
==="
! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:44'!
newDepth: pixelSize
"
	Display newDepth: 8.
	Display newDepth: 1.
"
	(self supportsDisplayDepth: pixelSize)
		ifFalse:[^self inform:'Display depth ', pixelSize printString, ' is not supported on this system'].
	self newDepthNoRestore: pixelSize.
	self restore.! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 10:03'!
pauseMorphicEventRecorder

	self flag: #bob.	
	Smalltalk isMorphic ifTrue: [^World pauseEventRecorder].
	^nil

! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 09:40'!
reinstallMorphicWorldAfterError

	self flag: #bob.	
	Smalltalk isMorphic ifTrue:
		[World install "To init hand events and redisplay world"].
! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/26/2000 09:54'!
repaintMorphicDisplay

	"this merely says everything needs to be redrawn, but the actual redraw will happen later"

	(self getOuterMorphicWorld ifNil: [^self]) fullRepaintNeeded.	
! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/26/2000 09:53'!
repaintMorphicDisplayNow

	(self getOuterMorphicWorld ifNil: [^self]) displayWorld.! !

!DisplayScreen methodsFor: 'other'!
replacedBy: aForm do: aBlock
	"Permits normal display to draw on aForm instead of the display."

	ScreenSave _ self.
	Display _ aForm.
	aBlock value.
	Display _ self.
	ScreenSave _ nil.! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 08:05'!
restore
	Smalltalk isMorphic
		ifTrue: [self repaintMorphicDisplay]
		ifFalse: [ScheduledControllers unCacheWindows; restore].! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 08:06'!
restoreAfter: aBlock
	"Evaluate the block, wait for a mouse click, and then restore the screen."

	aBlock value.
	Sensor waitButton.
	Smalltalk isMorphic
		ifTrue: [self repaintMorphicDisplay]
		ifFalse: [(ScheduledControllers restore; activeController) view emphasize]! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 12/12/2000 15:50'!
restoreMorphicDisplay

	DisplayScreen startUp.
	(self getOuterMorphicWorld ifNil: [^ self])
		extent: self extent;
		viewBox: self boundingBox;
		handsDo: [:h | h visible: true; showTemporaryCursor: nil];
		restoreFlapsDisplay;
		fullRepaintNeeded.
	WorldState addDeferredUIMessage: [
		Cursor normal show.
	].
! !

!DisplayScreen methodsFor: 'other' stamp: 'bf 9/18/1999 19:46'!
supportedDisplayDepths
	"Return all pixel depths supported on the current host platform."
	^#(1 2 4 8 16 32) select: [:d | self supportsDisplayDepth: d]! !

!DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:45'!
supportsDisplayDepth: pixelDepth
	"Return true if this pixel depth is supported on the current host platform.
	Primitive. Optional."
	<primitive: 91>
	^#(1 2 4 8 16 32) includes: pixelDepth! !

!DisplayScreen methodsFor: 'other'!
usableArea
	"Answer the usable area of the receiver.  5/22/96 sw."

	^ self boundingBox deepCopy! !

!DisplayScreen methodsFor: 'other' stamp: 'RAA 5/25/2000 10:29'!
useTemporaryHandDuring: aBlock

	| lastHand tmpHand w |

	w _ Display bestGuessOfCurrentWorld.
	w removeHand: (lastHand _ w activeHand).
	w addHand: (tmpHand _ lastHand copy).
	aBlock value: tmpHand.
	w removeHand: tmpHand.
	w addHand: lastHand.
! !

!DisplayScreen methodsFor: 'other'!
width
	^ self boundingBox width! !


!DisplayScreen methodsFor: 'disk I/O' stamp: 'tk 9/28/2000 15:41'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to the Display in the other system instead.  "

	"A path to me"
	dp _ DiskProxy global: #Display selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp
! !


!DisplayScreen methodsFor: 'private'!
beDisplay
	"Primitive. Tell the interpreter to use the receiver as the current display 
	image. Fail if the form is too wide to fit on the physical display. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 102>
	self primitiveFailed! !

!DisplayScreen methodsFor: 'private' stamp: 'di 3/3/1999 10:00'!
copyFrom: aForm
	"Take on all state of aForm, with complete sharing"

	super copyFrom: aForm.
	clippingBox _ super boundingBox! !

!DisplayScreen methodsFor: 'private' stamp: 'ar 5/25/2000 23:43'!
findAnyDisplayDepth
	"Return any display depth that is supported on this system."
	^self findAnyDisplayDepthIfNone:[
		"Ugh .... now this is a biggie - a system that does not support
		any of the Squeak display depths at all."
		Smalltalk
			logError:'Fatal error: This system has no support for any display depth at all.'
			inContext: thisContext
			to: 'SqueakDebug.log'.
		Smalltalk quitPrimitive. "There is no way to continue from here"
	].! !

!DisplayScreen methodsFor: 'private' stamp: 'ar 5/25/2000 23:44'!
findAnyDisplayDepthIfNone: aBlock
	"Return any display depth that is supported on this system.
	If there is none, evaluate aBlock."
	#(1 2 4 8 16 32) do:[:bpp|
		(self supportsDisplayDepth: bpp) ifTrue:[^bpp].
	].
	^aBlock value! !

!DisplayScreen methodsFor: 'private' stamp: 'di 4/15/1999 10:58'!
newDepthNoRestore: pixelSize
	"Change depths.  Check if there is enough space!!  , di"
	| area need |
	pixelSize = depth ifTrue: [^ self  "no change"].
	pixelSize < depth ifFalse:
		["Make sure there is enough space"
		area _ Display boundingBox area. "pixels"
		Smalltalk isMorphic ifFalse:
			[ScheduledControllers scheduledWindowControllers do:
				[:aController | "This should be refined..."
				aController view cacheBitsAsTwoTone ifFalse:
					[area _ area + aController view windowBox area]]].
		need _ (area * (pixelSize-depth) // 8)  "new bytes needed"
				+ Smalltalk lowSpaceThreshold.
		(Smalltalk garbageCollectMost <= need
			and: [Smalltalk garbageCollect <= need])
			ifTrue: [self error: 'Insufficient free space']].
	self setExtent: self extent depth: pixelSize.
	Smalltalk isMorphic ifFalse: [ScheduledControllers updateGray].
	DisplayScreen startUp! !

!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:00'!
primRetryShowRectLeft: l right: r top: t bottom: b
	"Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. Do nothing if it fails. "

	<primitive: 127>
	"do nothing if primitive fails"
! !

!DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:02'!
primShowRectLeft: l right: r top: t bottom: b
	"Copy the given rectangular section of the Display to to the screen. This primitive is not implemented on all platforms. If this fails, retry integer coordinates."

	<primitive: 127>
	"if this fails, coerce coordinates to integers and try again"
	self primRetryShowRectLeft: l truncated
		right: r rounded
		top: t truncated
		bottom: b rounded.
! !

!DisplayScreen methodsFor: 'private' stamp: 'RAA 11/27/1999 15:48'!
setExtent: aPoint depth: bitsPerPixel  "DisplayScreen startUp"
	"This method is critical.  If the setExtent fails, there will be no
	proper display on which to show the error condition..."
	"ar 5/1/1999: ... and that is exactly why we check for the available display depths first."

	"RAA 27 Nov 99 - if depth and extent are the same and acceptable, why go through this.
	also - record when we change so worlds can tell if it is time to repaint"

	(depth == bitsPerPixel and: [aPoint = self extent and: 
					[self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [
		bits _ nil.  "Free up old bitmap in case space is low"
		DisplayChangeSignature _ (DisplayChangeSignature ifNil: [0]) + 1.
		(self supportsDisplayDepth: bitsPerPixel)
			ifTrue:[super setExtent: aPoint depth: bitsPerPixel]
			ifFalse:["Search for a suitable depth"
					super setExtent: aPoint depth: self findAnyDisplayDepth].
	].
	clippingBox _ super boundingBox! !


!DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:07'!
release
	"I am no longer Display. Release any resources if necessary"! !

!DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 11:25'!
shutDown 
	"Minimize Display memory saved in image"
	self setExtent: 240@120 depth: depth! !


!DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'!
isB3DDisplayScreen
	^false! !

!DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'!
isDisplayScreen
	^true! !


!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'!
defaultBitBltClass
	"Return the BitBlt version to use when I am active"
	^BitBlt! !

!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:02'!
defaultCanvasClass
	"Return the WarpBlt version to use when I am active"
	^FormCanvas! !

!DisplayScreen methodsFor: 'blitter defaults' stamp: 'ar 5/28/2000 12:01'!
defaultWarpBltClass
	"Return the WarpBlt version to use when I am active"
	^WarpBlt! !


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

DisplayScreen class
	instanceVariableNames: ''!

!DisplayScreen class methodsFor: 'display box access'!
boundingBox
	"Answer the bounding box for the form representing the current display 
	screen."

	^Display boundingBox! !

!DisplayScreen class methodsFor: 'display box access' stamp: 'RAA 5/25/2000 08:04'!
checkForNewScreenSize
	Display extent = DisplayScreen actualScreenSize ifTrue: [^ self].
	DisplayScreen startUp.
	Smalltalk isMorphic
		ifTrue: [Display restoreMorphicDisplay]
		ifFalse: [ScheduledControllers restore; searchForActiveController]! !

!DisplayScreen class methodsFor: 'display box access' stamp: 'sma 4/28/2000 19:07'!
depth: depthInteger width: widthInteger height: heightInteger fullscreen: aBoolean
	"Force Squeak's window (if there's one) into a new size and depth."
	"DisplayScreen depth: 8 width: 1024 height: 768 fullscreen: false"

	<primitive: 92>
	self primitiveFail! !


!DisplayScreen class methodsFor: 'snapshots'!
actualScreenSize
	<primitive: 106>
	^ 640@480! !

!DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'!
shutDown 
	"Minimize Display memory saved in image"
	Display shutDown.! !

!DisplayScreen class methodsFor: 'snapshots' stamp: 'di 3/1/1999 17:04'!
startUp  "DisplayScreen startUp"
	Display setExtent: self actualScreenSize depth: Display depth.
	Display beDisplay! !
DisplayObject subclass: #DisplayText
	instanceVariableNames: 'text textStyle offset form foreColor backColor '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Display Objects'!
!DisplayText commentStamp: '<historical>' prior: 0!
I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.!


!DisplayText methodsFor: 'accessing'!
alignedTo: alignPointSelector
	"Return a copy with offset according to alignPointSelector which is one of...
	#(topLeft, topCenter, topRight, leftCenter, center, etc)"
	| boundingBox |
	boundingBox _ 0@0 corner: self form extent.
	^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)! !

!DisplayText methodsFor: 'accessing'!
fontsUsed
	"Return a list of all fonts used currently in this text.  8/19/96 tk"

	^ text runs values asSet collect: [:each | textStyle fontAt: each]! !

!DisplayText methodsFor: 'accessing'!
form 
	"Answer the form into which the receiver's display bits are cached."

	form == nil ifTrue: [self composeForm].
	^form! !

!DisplayText methodsFor: 'accessing'!
lineGrid
	"Answer the relative space between lines of the receiver's text."

	^textStyle lineGrid! !

!DisplayText methodsFor: 'accessing'!
numberOfLines 
	"Answer the number of lines of text in the receiver."

	^self height // text lineGrid! !

!DisplayText methodsFor: 'accessing'!
offset 
	"Refer to the comment in DisplayObject|offset."

	^offset! !

!DisplayText methodsFor: 'accessing'!
offset: aPoint 
	"Refer to the comment in DisplayObject|offset:."

	offset _ aPoint! !

!DisplayText methodsFor: 'accessing'!
string
	"Answer the string of the characters displayed by the receiver."

	^text string! !

!DisplayText methodsFor: 'accessing'!
text 
	"Answer the text displayed by the receiver."

	^text! !

!DisplayText methodsFor: 'accessing'!
text: aText 
	"Set the receiver to display the argument, aText."
	
	text _ aText.
	form _ nil.
	self changed.
	! !

!DisplayText methodsFor: 'accessing'!
textStyle 
	"Answer the style by which the receiver displays its text."

	^textStyle! !

!DisplayText methodsFor: 'accessing'!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."

	textStyle _ aTextStyle.
	form _ nil.
	self changed.
	! !


!DisplayText methodsFor: 'displaying' stamp: 'di 2/2/1999 17:12'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayObject|displayOn:at:clippingBox:rule:mask:."

	self form
		displayOn: aDisplayMedium
		at: aDisplayPoint + offset
		clippingBox: clipRectangle
		rule: ((ruleInteger = Form over and: [backColor isTransparent])
				ifTrue: [Form paint]
				ifFalse: [ruleInteger])
		fillColor: aForm! !

!DisplayText methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	self displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !

!DisplayText methodsFor: 'displaying'!
displayOnPort: aPort at: location
	self form displayOnPort: aPort at: location + offset! !


!DisplayText methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in DisplayObject|boundingBox."

	^self form boundingBox! !

!DisplayText methodsFor: 'display box access'!
computeBoundingBox 
	"Compute minimum enclosing rectangle around characters."

	| character font width carriageReturn lineWidth lineHeight |
	carriageReturn _ Character cr.
	width _ lineWidth _ 0.
	font _ textStyle defaultFont.
	lineHeight _ textStyle lineGrid.
	1 to: text size do: 
		[:i | 
		character _ text at: i.
		character = carriageReturn
		  ifTrue: 
			[lineWidth _ lineWidth max: width.
			lineHeight _ lineHeight + textStyle lineGrid.
			width _ 0]
		  ifFalse: [width _ width + (font widthOf: character)]].
	lineWidth _ lineWidth max: width.
	^offset extent: lineWidth @ lineHeight! !


!DisplayText methodsFor: 'converting' stamp: 'tk 10/21/97 12:28'!
asParagraph
	"Answer a Paragraph whose text and style are identical to that of the 
	receiver."
	| para |
	para _ Paragraph withText: text style: textStyle.
	para foregroundColor: foreColor backgroundColor: backColor.
	backColor isTransparent ifTrue: [para rule: Form paint].
	^ para! !


!DisplayText methodsFor: 'private' stamp: 'sma 4/30/2000 09:28'!
composeForm
	| form1 |
	Smalltalk isMorphic
		ifTrue:
			[form1 _ (TextMorph new contentsAsIs: text) imageFormDepth: 1.
			form _ (ColorForm extent: form1 extent)
				offset: offset;
				colors: (Array
					with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor])
					with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])).
			form1 displayOn: form]
		ifFalse: [form _ self asParagraph asForm]! !

!DisplayText methodsFor: 'private'!
setText: aText textStyle: aTextStyle offset: aPoint

	text _ aText.
	textStyle _ aTextStyle.
	offset _ aPoint.
	form _ nil! !


!DisplayText methodsFor: 'color'!
backgroundColor
	backColor == nil ifTrue: [^ Color transparent].
	^ backColor! !

!DisplayText methodsFor: 'color'!
foregroundColor
	foreColor == nil ifTrue: [^ Color black].
	^ foreColor! !

!DisplayText methodsFor: 'color'!
foregroundColor: cf backgroundColor: cb
	foreColor _ cf.
	backColor _ cb! !

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

DisplayText class
	instanceVariableNames: ''!

!DisplayText class methodsFor: 'instance creation'!
text: aText 
	"Answer an instance of me such that the text displayed is aText 
	according to the system's default text style."

	^self new
		setText: aText
		textStyle: DefaultTextStyle copy
		offset: 0 @ 0! !

!DisplayText class methodsFor: 'instance creation'!
text: aText textStyle: aTextStyle 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: 0 @ 0! !

!DisplayText class methodsFor: 'instance creation'!
text: aText textStyle: aTextStyle offset: aPoint 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle. The display of the 
	information should be offset by the amount given as the argument, 
	aPoint."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: aPoint! !


!DisplayText class methodsFor: 'examples' stamp: 'mjg 4/28/2000 14:31'!
example
	"Continually prints two lines of text wherever you point with the cursor
	and press any mouse button.  Terminate by pressing any button on the
	mouse."
	| tx |
	tx _ 'this is a line of characters and
this is the second line.' asDisplayText.
	tx foregroundColor: Color black backgroundColor: Color transparent.
	tx _ tx alignedTo: #center.
	[Sensor anyButtonPressed]
		whileFalse:
			[tx displayOn: Display at: Sensor cursorPoint]

	"DisplayText example."! !
View subclass: #DisplayTextView
	instanceVariableNames: 'rule mask editParagraph centered '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!DisplayTextView commentStamp: '<historical>' prior: 0!
I represent a view of an instance of DisplayText.!


!DisplayTextView methodsFor: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	centered _ false! !


!DisplayTextView methodsFor: 'accessing'!
centered

	centered _ true.
	self centerText! !

!DisplayTextView methodsFor: 'accessing'!
fillColor
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask! !

!DisplayTextView methodsFor: 'accessing'!
fillColor: aForm 
	"Set aForm to be the mask used when displaying the receiver's model."

	mask _ aForm! !

!DisplayTextView methodsFor: 'accessing'!
isCentered

	^centered! !

!DisplayTextView methodsFor: 'accessing'!
mask
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask! !

!DisplayTextView methodsFor: 'accessing'!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules is to be used when copying the receiver's model (a 
	DisplayText) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]! !

!DisplayTextView methodsFor: 'accessing'!
rule: anInteger 
	"Set anInteger to be the rule used when displaying the receiver's model."

	rule _ anInteger! !


!DisplayTextView methodsFor: 'controller access'!
defaultController 
	"Refer to the comment in View|defaultController."

	^self defaultControllerClass newParagraph: editParagraph! !

!DisplayTextView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ParagraphEditor! !


!DisplayTextView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^self inverseDisplayTransform: (editParagraph boundingBox expandBy: 6 @ 6)! !

!DisplayTextView methodsFor: 'window access'!
window: aWindow 
	"Refer to the comment in View|window:."

	super window: aWindow.
	self centerText! !


!DisplayTextView methodsFor: 'model access'!
model: aDisplayText 
	"Refer to the comment in View|model:."

	super model: aDisplayText.
	editParagraph _ model asParagraph.
	self centerText! !


!DisplayTextView methodsFor: 'displaying'!
display 
	"Refer to the comment in View|display."

	self isUnlocked ifTrue: [self positionText].
	super display! !

!DisplayTextView methodsFor: 'displaying'!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	(self controller isKindOf: ParagraphEditor )
		ifTrue: [controller changeParagraph: editParagraph].
	editParagraph foregroundColor: self foregroundColor
				backgroundColor: self backgroundColor.
	self isCentered
		ifTrue: 
			[editParagraph displayOn: Display
				transformation: self displayTransformation
				clippingBox: self insetDisplayBox
				fixedPoint: editParagraph boundingBox center]
		ifFalse: 
			[editParagraph displayOn: Display]! !

!DisplayTextView methodsFor: 'displaying'!
uncacheBits
	"Normally only sent to a StandardSystemView, but for casees where a DisplayTextView is used alone, without a superview, in which we make this a no-op, put in so that the Character Recognizer doesn't fail.  8/9/96 sw"! !


!DisplayTextView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	(self controller isKindOf: ParagraphEditor)
	 	ifTrue: [controller deselect]! !


!DisplayTextView methodsFor: 'private'!
centerText

	self isCentered
		ifTrue: 
			[editParagraph
				align: editParagraph boundingBox center
				with: self getWindow center]! !

!DisplayTextView methodsFor: 'private'!
defaultRule

	^Form over! !

!DisplayTextView methodsFor: 'private'!
positionText

	| box |
	box _ (self displayBox insetBy: 6@6) origin extent: editParagraph boundingBox extent.
	editParagraph wrappingBox: box clippingBox: box.
	self centerText! !


!DisplayTextView methodsFor: 'lock access'!
lock 
	"Refer to the comment in View|lock.  Must do what would be done by displaying..."

	self isUnlocked ifTrue: [self positionText].
	super lock! !

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

DisplayTextView class
	instanceVariableNames: ''!

!DisplayTextView class methodsFor: 'examples'!
example2	
	"Create a standarad system view with two parts, one editable, the other not."
	| topView aDisplayTextView |
	topView _ StandardSystemView new.
	topView label: 'Text Editor'.
	aDisplayTextView _ self new model: 'test string label' asDisplayText.
	aDisplayTextView controller: NoController new.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	topView addSubView: aDisplayTextView.

	aDisplayTextView _ self new model: 'test string' asDisplayText.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidth: 2.
	topView
		addSubView: aDisplayTextView
		align: aDisplayTextView viewport topLeft
		with: topView lastSubView viewport topRight.
	topView controller open

	"DisplayTextView example2"! !

!DisplayTextView class methodsFor: 'examples'!
example3	
	"Create a passive view of some text on the screen."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 2.
	view display.
	view release

	"DisplayTextView example3"! !

!DisplayTextView class methodsFor: 'examples'!
example4	
	"Create four passive views of some text on the screen with fat borders."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 5.
	view display.
	3 timesRepeat: [view translateBy: 100@100. view display].
	view release

	"DisplayTextView example4"! !
Object subclass: #DisplayTransform
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!DisplayTransform commentStamp: '<historical>' prior: 0!
This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined.

It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument).

Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order:

		globalPointToLocal: globalPoint
			"globalPoint -> globalTransform -> localTransform -> locaPoint"
			^localTransform globalPointToLocal:
				(globalTransform globalPointToLocal: globalPoint)

		localPointToGlobal: localPoint
			"localPoint -> localTransform -> globalTransform -> globalPoint"
			^globalTransform localPointToGlobal:
				(localTransform localPointToGlobal: localPoint)

!


!DisplayTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:18'!
setIdentity
	"Initialize the receiver to the identity transformation (e.g., not affecting points)"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:43'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:47'!
isCompositeTransform
	"Return true if the receiver is a composite transformation.
	Composite transformations may have impact on the accuracy."
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:17'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'!
isMorphicTransform
	"Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly."
	^false! !

!DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:16'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:15'!
composedWithGlobal: aTransformation
	"Return the composition of the receiver and the global transformation passed in.
	A 'global' transformation is defined as a transformation that takes place
	between the receiver (the 'local') transformation and any 'global' point
	computations, e.g., for the methods

		globalPointToLocal: globalPoint
			globalPoint -> globalTransform -> localTransform -> locaPoint

		localPointToGlobal: localPoint
			localPoint -> localTransform -> globalTransform -> globalPoint

		"
	^aTransformation composedWithLocal: self! !

!DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:41'!
composedWithLocal: aTransformation
	"Return the composition of the receiver and the local transformation passed in.
	A 'local' transformation is defined as a transformation that takes place
	between the receiver (the 'global') transformation and any 'local' point
	computations, e.g., for the methods

		globalPointToLocal: globalPoint
			globalPoint -> globalTransform -> localTransform -> locaPoint

		localPointToGlobal: localPoint
			localPoint -> localTransform -> globalTransform -> globalPoint

		"
	self isIdentity ifTrue:[^ aTransformation].
	aTransformation isIdentity ifTrue:[^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransformation! !


!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:17'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray collect:[:pt| self globalPointToLocal: pt]! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:18'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^self subclassResponsibility! !

!DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray collect:[:pt| self localPointToGlobal: pt]! !


!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! !

!DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! !

!DisplayTransform methodsFor: 'transforming rects' stamp: 'di 10/25/1999 12:49'!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners collect: 
		[:p | self globalPointToLocal: p]! !


!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:59'!
asCompositeTransform
	"Represent the receiver as a composite transformation"
	^CompositeTransform new
		globalTransform: self
		localTransform: self species identity! !

!DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:01'!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^self subclassResponsibility! !


!DisplayTransform methodsFor: 'encoding' stamp: 'ls 10/9/1999 18:56'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^self subclassResponsibility! !

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

DisplayTransform class
	instanceVariableNames: ''!

!DisplayTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'!
fromRemoteCanvasEncoding: encoded
	| type |
	"decode a transform from the given encoded string"
	type _ (ReadStream on: encoded) upTo: $,.
	type = 'Morphic' ifTrue: [
		^MorphicTransform fromRemoteCanvasEncoding: encoded ].
	type = 'Matrix' ifTrue: [
		^MatrixTransform2x3 fromRemoteCanvasEncoding: encoded ].
	type = 'Composite' ifTrue: [
		^CompositeTransform fromRemoteCanvasEncoding: encoded ].
	^self error: 'invalid transform encoding'! !

!DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'!
identity
	^self new setIdentity! !
BorderedMorph subclass: #DoCommandOnceMorph
	instanceVariableNames: 'target command actionBlock innerArea '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!DoCommandOnceMorph commentStamp: '<historical>' prior: 0!
I am used to execute a once-only command. My first use was in loading/saving the current project. In such cases it is necessary to be in another project to do the actual work. So an instance of me is added to a new world/project and that project is entered. I do my stuff (save/load followed by a re-enter of the previous project) and everyone is happy.!


!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 11:49'!
actionBlock: aBlock

	actionBlock _ aBlock! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 17:30'!
addText: aString

	| t |
	t _ TextMorph new 
		beAllFont: (TextStyle default fontOfSize: 26);
		contents: aString.
	self extent: t extent * 3.
	innerArea _ Morph new 
		color: Color white; 
		extent: self extent - (16@16);
		position: self position + (8@8);
		lock.
	self addMorph: innerArea. 
	self addMorph: (t position: self position + t extent; lock).! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 17:35'!
initialize

	super initialize.
	borderColor _ Color blue.
	borderWidth _ 8.
	self useRoundedCorners.! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 12:19'!
openInWorld: aWorld

	self position: aWorld topLeft + (aWorld extent - self extent // 2).
	super openInWorld: aWorld! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 17:30'!
step

	| goForIt |

	actionBlock ifNil: [^self stopStepping].
	goForIt _ actionBlock.
	actionBlock _ nil.
	[
		goForIt value.
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: innerArea].		"in case a save/load progress display needs a home"
! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 11:46'!
stepTime

	^1
! !

!DoCommandOnceMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 11:50'!
wantsSteps

	^actionBlock notNil
! !
Object subclass: #DocLibrary
	instanceVariableNames: 'group lastUpdate lastUpdateName methodVersions '
	classVariableNames: 'DocsCachePath DropBox External '
	poolDictionaries: ''
	category: 'Tools-Changes'!
!DocLibrary commentStamp: '<historical>' prior: 0!
Method and Class shared documentation.  Pane in browser.  url for each official version of each method. Each update server group have a prefix (i=internal, e=external).  Point.x;.738.sp  Pane holds a pasteupmorph with comments and examples.  
	Must be very careful to give the right options for when to look for docs.  Could be annoying.  Look on disk.  If there, bring it in in background.  If not there, and network has been active this session, or within 15 mins, get from server (in background) and cache on disk.  
	When get updates, check for latest version of all comments in the cache.  
	Need quick registration of version of inst vars (less bulky and quick to check.)  If all inst var lists are the same as a certain release, mark it as that.  Each release (or update?) have an automatic known registration.
	Get doc, Get all docs for this class. //  Net: When you ask, If net has been used, Always (always gets in background) // From disk:  When you ask, always (laptop users do the former).
  	Security: Squeakers can write anything, including players.  Users can only add Morphic objects, not players.  (No new code)
	Mech:  Users write file to a server with open drop box.  Our server in Alan's office (the librarian) grabs the files once every two minutes, and scans them.  Code must be same as before.  Saves a copy.  Writes on official directory on two outside servers.
	Any combo of objects of existing classes that can crash the system, or deny service?  Should the librarian try all buttons first?  If it crashes, won't post it.
	Need another machine to check if the librarian is up, and beep Ted.  Could check a time stamp on the main server.  Users could also tell if librarian is up.  Number of docs in the queue.
	If we had mime really down, could have squeak email the page to the librarian.  What if the user does not know his pop server?  Use a standard one?  How keep spam out?
-----
[ ] set up folders, get reader going (no good interface yet)
group		Name of group of servers (internal/external)
lastUpdate	Number of last update we have.
lastUpdateName		File name without number for checking against ChangeSets.
methodVersions	Dictionary (class.method -> #(45 secs 120 secs 198 secs)) updates 
	that this method  appeared in.  From my version, check backwards till find a doc file on server.  secs is (Time totalSeconds) of file on the server (by its directory) of last version I have.  so can tell if have most recent one.  (use one day slop for older ones)
	point.x;.205.sp
	rectangle.205.sp
Names of this form that are too long are run through a dictionary and given a serial number.  It is (first two letters of class name), (crc16 of first half), (crc16 of second half).205.sp.  
	Can't store over a file in the drop box, so append random number to end of name.  Look at times to figure out which one is most recent when empty drop box.
			
localCachePath 	name of cache directory on local disk.  (Is shared between Squeaks on this machine, so might have things too new.)  In the form of a url 'file://disk/folder/'

Algorithm for finding the doc file:  
	Find my version
	Find version of current def of method relative to me.
	make file name.
	look locally
	check server, might have changed.

When put new update, no extra work needed.
When put a new version of the system, include External with methodVersions filled in.  If methods changed and not in a numbered update, must run a method to put them in the database.

When get updates, add new entries as we read updates.

Default method update number is 0.

AA _ DocLibrary new initialize.
AA scanFolder: 'file://Ted''s/Updates 328-/' from: 595.
DocLibrary classPool at: #External put: AA.

DocLibrary new setUp.

[How use internal updates, but do documentation for external?  Disable feature of adding to table when get updates.  Point to UIUC external directory and scan the latest ext updates.]
	When a docPane comes in, store property: #classAndMethod.  To put out, menu item "Broadcast Documentation" in PasteUpMorph that has the property.  DocLibrary puts out this morph.  Writes to drop box and local cache.
	In codePane, on more menu, "Fetch Documentation" (if none, ask if want blank one).  Creates a new pasteUpMorph after verifying that it doesn't have one.
	Later need preference and do fetch always and in the background.

	Crude review process -- a method here that brings up each pane that is in drop box (10 at a time).  First just shows code and text, not bring in.  Then bring in.  And a way for me to store it in the official directory.  (Do as menu items in file list?)  And archives and deletes for drop box.  (I do manually twice a day?)

	When write a file, take lastUpdateName and look for it in ChangeSet names.  When find, see if this method occurs in any newer changeSet.  If so, writing to an older version.  "The documentation will be attached to the version of this method in xxx.cs.  You have a newer version of that method in yyy.cs.  If what you are storing applies only to the newer version, please do not broadcast it!!  Wait until the new version is in an external update." Broadcast to all Squeak users \ Cancel.  (Otherwise "Make this documentation available to all Squeak users?")

When fetch any updates, look for "latest.ix"  Has format:
External   407   'aChangeSet.cs'
376.ix
'class method:' updateNumber
'class method' updateNumber
'class' updateNumber
	Keep local copy of updates.list and read it for files not mentioned yet in latest.ix.

¥Warn the user if the method he is documenting is too new to be on the External updates server.
¥Correcting the database of method versions when new External Updates are released.
¥Create the file to put on the server with the database info for a new update.
¥Methods to help the reviewer (me) scan files.  It will show me all the code, all the doits in text, and all the text.
¥Allow documentation for classes, as opposed to methods. (written in file, in dict, just need interface)

self scanUpdatesIn: (ServerDirectory serverNamed: 'UpdatesExtUIUC') realUrl, '/'.

self updateMethodVersions.

[ ] When write, write to cache also.
[ ] If can't write to server, tell user to store again later.
[ ] Sparse database to tell if method has a docPane -- user fetches it explicitly.
[ ] Write to both servers.  Retrieve from either.  Drop box on just UIUC.
!


!DocLibrary methodsFor: 'initialize' stamp: 'tk 2/4/1999 12:29'!
initialize
	lastUpdate _ 0.
	methodVersions _ Dictionary new.! !

!DocLibrary methodsFor: 'initialize' stamp: 'tk 3/9/1999 12:55'!
setUp
	"set up the External version"
	| email |
	self initialize.
	External _ self.
	group _ 'Squeak Public Updates'.	"right for http, but not for ftp"
	lastUpdate _ 599.
	lastUpdateName _ 'MTMcontainsPoint-ar.cs'.
	DropBox _ ServerDirectory new.
	DropBox server: 'squeak.cs.uiuc.edu'; directory: 'incoming'.
	DropBox type: #ftp.
	email _ nil.  "Celeste popUserName."	"If nil, we ask at drop time"
	DropBox user: 'anonymous'; password: email.
	DropBox moniker: 'Doc Pane DropBox'.
		"later allow a second server"
! !


!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/13/1999 13:45'!
assureCacheFolder
	"Make sure there is a folder docPaneCache and a file: url for it in DocsCachePath.  In local folder or one level up.  User may wish to install a different path and folder name (as a url).  Could be a url to a local server."

	| dir local |
	DocsCachePath ifNil: [
		dir _ FileDirectory default.
		(dir includesKey: 'docPaneCache') ifTrue: [
			DocsCachePath _ dir url, 'docPaneCache/']].
	DocsCachePath ifNil: [
		dir _ FileDirectory default containingDirectory.
		DocsCachePath _ dir url, 'docPaneCache/'.
		(dir includesKey: 'docPaneCache') ifFalse: [
			^ dir createDirectory: 'docPaneCache']].	"create the folder"
	local _ ServerDirectory new fullPath: DocsCachePath.
	local exists ifFalse: [
		DocsCachePath _ nil.	"we must be on a new disk"
		self assureCacheFolder].! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/13/1999 14:03'!
cache: strm as: fileName
	"Save the file locally in case the network is not available."

	| local |
	local _ ServerDirectory new fullPath: DocsCachePath.
	(local fileNamed: fileName) nextPutAll: strm contents; close.! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/5/1999 07:33'!
docNamesAt: classAndMethod
	"Return a list of fileNames to try for this method.  'Point x:' is form of classAndMethod."

	| key verList fileNames |
	key _ DocLibrary properStemFor: classAndMethod.
	verList _ methodVersions at: key ifAbsent: [#()].
	fileNames _ OrderedCollection new.
	1 to: verList size by: 2 do: [:ind |
		fileNames addFirst: key,'.',(verList at: ind) printString, '.sp'].
	fileNames addLast: key,'.0.sp'.
	^ fileNames! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/5/1999 07:33'!
docNamesAt: classAndMethod asOf: currentUpdate
	"Return a list of fileNames to try for this method.  'Point x:' is form of classAndMethod."

	| key verList fileNames |
	key _ DocLibrary properStemFor: classAndMethod.
	verList _ methodVersions at: key ifAbsent: [#()].
	fileNames _ OrderedCollection new.
	1 to: verList size by: 2 do: [:ind |
		(verList at: ind) <= currentUpdate ifTrue: [
			fileNames addFirst: key,'.',(verList at: ind) printString, '.sp']].
	fileNames addLast: key,'.0.sp'.
	^ fileNames! !

!DocLibrary methodsFor: 'doc pane' stamp: 'mdr 8/31/2000 18:48'!
docObjectAt: classAndMethod
	"Return a morphic object that is the documentation pane for this method.  nil if none can be found.  Look on both the network and the disk."

	| fileNames server aUrl strm local obj |
	methodVersions size = 0 ifTrue: [self updateMethodVersions].	"first time"
	fileNames _ self docNamesAt: classAndMethod.
	self assureCacheFolder.
	self haveNetwork ifTrue: [
		"server _ (ServerDirectory groupNamed: group) clone."  "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up"
		server _ ServerDirectory groupNamed: group.
			"later try multiple servers"
		aUrl _ server altUrl, 'docpane/'.
		fileNames do: [:aVersion | 
			strm _ HTTPSocket httpGetNoError: aUrl,aVersion 
				args: nil accept: 'application/octet-stream'.
			strm class == RWBinaryOrTextStream ifTrue: [
				self cache: strm as: aVersion.
				strm reset.
				obj _ strm fileInObjectAndCode asMorph.
				(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
					self inform: 'suspicious object'.
					obj setProperty: #classAndMethod toValue: classAndMethod].
				^ obj].	"The pasteUpMorph itself"
			"If file not there, error 404, just keep going"]].
	local _ ServerDirectory new fullPath: DocsCachePath.
	"check that it is really there -- let user respecify"
	fileNames do: [:aVersion | 
		(local includesKey: aVersion) ifTrue: [
			strm _ local readOnlyFileNamed: aVersion.
			obj _ strm fileInObjectAndCode asMorph.
			(obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [
				self inform: 'suspicious object'.
				obj setProperty: #classAndMethod toValue: classAndMethod].
			Transcript cr; show: 'local cache: ', aVersion.
			^ obj].	"The pasteUpMorph itself"
		"If file not there, just keep looking"].
	"Never been documented"
	^ nil! !

!DocLibrary methodsFor: 'doc pane' stamp: 'RAA 5/25/2000 08:16'!
fetchDocSel: aSelector class: className
	"Look on servers to see if there is documentation pane for the selected message. Take into account the current update number.  If not, ask the user if she wants to create a blank one."

	| key response docPane ext |
	key _ aSelector size = 0 
		ifFalse: [className, ' ', aSelector]
		ifTrue: [className].
	(self openDocAt: key) ifNil: [
		response _ (PopUpMenu labels: 'Create new page\Cancel' withCRs)
				startUpWithCaption: 'No documentation exists for this method.\
Would you like to write some?' withCRs.
		response = 1 ifTrue: [
			docPane _ PasteUpMorph new.
			docPane color: Color white; borderWidth: 2; borderColor: Color green.
			docPane setProperty: #classAndMethod toValue: key.
			docPane setProperty: #initialExtent toValue: (ext _ 200@200).
			docPane topLeft: (RealEstateAgent initialFrameFor: docPane world: Smalltalk currentWorld) origin.
			docPane extent: ext.
			docPane addMorph: (TextMorph new topLeft: docPane topLeft + (10@10);
					extent: docPane width - 15 @ 30).
			Smalltalk currentWorld addMorph: docPane]].

	"If found, openDocAt: put it on the screen"! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/15/1999 16:30'!
haveNetwork
	
	| hn ask |
	(hn _ NetNameResolver haveNetwork) class == Symbol ifFalse: [^ hn].
	hn == #expired ifTrue: [
		ask _ self confirm: 'OK to connect to the internet?'.
		ask ifFalse: [NetNameResolver haveNetwork: false].
		^ ask].
	^ false! !

!DocLibrary methodsFor: 'doc pane' stamp: 'RAA 5/25/2000 08:17'!
openDocAt: classAndMethod

	| docPane |
	(docPane _ self docObjectAt: classAndMethod) ifNotNil: [
		docPane setProperty: #initialExtent toValue: docPane bounds extent.
		docPane topLeft: (RealEstateAgent initialFrameFor: docPane world: Smalltalk currentWorld) origin.
		Smalltalk currentWorld addMorph: docPane].
	^ docPane! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/15/1999 17:10'!
saveDoc: aMorph
	"Broadcast this documentation to the Squeak community.  Associate it with the method it documents.  Send to a drop box, where it can be inspected before being posted on External servers."

	| classAndMethod fName remoteFile |
	classAndMethod _ aMorph valueOfProperty: #classAndMethod.
	classAndMethod ifNil: [
		^ self error: 'need to know the class and method'].	"later let user set it"
	fName _ (self docNamesAt: classAndMethod) first.
	DropBox user asLowercase = 'anonymous' ifTrue: [
		fName _ fName, 1000 atRandom printString].	"trusted users store directly"
	DropBox password.	"In case user has to type it.  Avoid timeout from server"
	Cursor wait showWhile: [
		remoteFile _ DropBox fileNamed: fName.
		remoteFile fileOutClass: nil andObject: aMorph.
		"remoteFile close"].
! !

!DocLibrary methodsFor: 'doc pane' stamp: 'tk 2/14/1999 20:40'!
saveDocCheck: aMorph
	"Make sure the document gets attached to the version of the code that the user was looking at.  Is there a version of this method in a changeSet beyond the updates we know about?  Works even when the user has internal update numbers and the documentation is for external updates (It always is)."

	| classAndMethod parts selector class lastUp beyond ours docFor unNum ok key verList ext response |
	classAndMethod _ aMorph valueOfProperty: #classAndMethod.
	classAndMethod ifNil: [
		^ self error: 'need to know the class and method'].	"later let user set it"
	parts _ classAndMethod findTokens: ' .'.
	selector _ parts last asSymbol.
	class _ Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph].
	parts size = 3 ifTrue: [class _ class class].
	"Four indexes we are looking for:
		docFor = highest numbered below lastUpdate that has method.
		unNum = a higher unnumbered set that has method.
		lastUp = lastUpdate we know about in methodVersions
		beyond = any set about lastUp that has the method."
	ChangeSorter gatherChangeSets doWithIndex: [:cs :ind | "youngest first"
		(cs name includesSubString: lastUpdateName) ifTrue: [lastUp _ ind].
		(cs atSelector: selector class: class) ~~ #none ifTrue: [
			lastUp ifNotNil: [beyond _ ind. ours _ cs name]
				ifNil: [cs name first isDigit ifTrue: [docFor _ ind] 
						ifFalse: [unNum _ ind. ours _ cs name]]]].
	"See if version the user sees is the version he is documenting"
	ok _ beyond == nil.
	unNum ifNotNil: [docFor ifNotNil: [ok _ docFor > unNum]
						ifNil: [ok _ false]].  "old changeSets gone"
	ok ifTrue: [^ self saveDoc: aMorph].

	key _ DocLibrary properStemFor: classAndMethod.
	verList _ (methodVersions at: key ifAbsent: [#()]), #(0 0).
	ext _ verList first.	"external update number we will write to"
	response _ (PopUpMenu labels: 'Cancel\Broadcast Page' withCRs)
				startUpWithCaption: 'You are documenting a method in External Update ', ext asString, '.\There is a more recent version of that method in ' withCRs, ours, 
'.\If you are explaining the newer version, please Cancel.\Wait until that version appears in an External Update.' withCRs.
	response = 2 ifTrue: [self saveDoc: aMorph].
! !


!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/13/1999 11:53'!
absorbAfter: oldVersion from: fileName
	"Read the .ix file and add to the methodVersions database.  See class comment."

	| server aUrl strm newUpdate newName prevFile classAndMethod updateID key verList new |
	server _ ServerDirectory groupNamed: group.
		"later try multiple servers"
	aUrl _ server altUrl, 'docpane/', fileName.
	strm _ HTTPSocket httpGetNoError: aUrl
		args: nil accept: 'application/octet-stream'.
	strm class == RWBinaryOrTextStream ifFalse: [^ false].

	(strm upTo: $ ) = 'External' ifFalse: [strm close. ^ false].
	newUpdate _ Integer readFrom: strm.
	newUpdate = oldVersion ifTrue: [strm close. ^ false].		"already have it"
 	strm upTo: $'.
	newName _ strm nextDelimited: $'.  strm upTo: Character cr.
	prevFile _ strm upTo: Character cr.
	"does this report on updates just after what I know?"
	oldVersion = (prevFile splitInteger first) ifFalse: [
		strm close. ^ prevFile].	"see earlier sucessor file"
	[strm atEnd] whileFalse: [
		strm upTo: $'.
		classAndMethod _ strm nextDelimited: $'.  strm next.
		updateID _ Integer readFrom: strm.
		key _ DocLibrary properStemFor: classAndMethod.
		verList _ methodVersions at: key ifAbsent: [#()].
		(verList includes: updateID) ifFalse: [
			new _ verList, (Array with: updateID with: -1 "file date seen").
			methodVersions at: key put: new]].
	strm close.
	lastUpdate _ newUpdate.
	lastUpdateName _ newName.
	^ true! !

!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/5/1999 08:07'!
scan: updateStream updateID: updateID
	"Scan this update file and remember the update numbers of the methods."

	| changeList ee semi key verList new |
	updateStream reset; readOnly.
	Cursor read showWhile:
		[changeList _ ChangeList new
			scanFile: updateStream from: 0 to: updateStream size].
	changeList list do: [:entry |
		ee _ nil.
		(entry beginsWith: 'method: ') ifTrue: [
			(semi _ entry indexOf: $;) = 0 
				ifTrue: [semi _ entry size]
				ifFalse: [semi _ semi-1].
			ee _ entry copyFrom: 9 to: semi].
		(entry beginsWith: 'class comment for ') ifTrue: [
			(semi _ entry indexOf: $;) = 0 
				ifTrue: [semi _ entry size]
				ifFalse: [semi _ semi-1].
			ee _ entry copyFrom: 19 to: semi].	"comment for whole class"
		ee ifNotNil: [
			key _ DocLibrary properStemFor: ee.
			Transcript show: key; cr.
			verList _ methodVersions at: key ifAbsent: [#()].
			(verList includes: updateID) ifFalse: [
				new _ verList, (Array with: updateID with: -1 "file date seen").
				methodVersions at: key put: new]].
		].! !

!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/13/1999 11:22'!
scan: updateStream updateID: updateID writeOn: strm
	"Scan this update file and remember the update numbers of the methods."

	| changeList ee semi |
	updateStream reset; readOnly.
	Cursor read showWhile:
		[changeList _ ChangeList new
			scanFile: updateStream from: 0 to: updateStream size].
	changeList list do: [:entry |
		ee _ nil.
		(entry beginsWith: 'method: ') ifTrue: [
			(semi _ entry indexOf: $;) = 0 
				ifTrue: [semi _ entry size]
				ifFalse: [semi _ semi-1].
			ee _ entry copyFrom: 9 to: semi].
		(entry beginsWith: 'class comment for ') ifTrue: [
			(semi _ entry indexOf: $;) = 0 
				ifTrue: [semi _ entry size]
				ifFalse: [semi _ semi-1].
			ee _ entry copyFrom: 19 to: semi].	"comment for whole class"
		ee ifNotNil: [
			Transcript show: ee; cr.
			strm cr; nextPutAll: ee surroundedBySingleQuotes; space;
				nextPutAll: updateID asString].
		].! !

!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/11/1999 12:06'!
scanFolder: directoryUrl from: updateID
	"Scan all update files in the directory starting at updateID+1.  updates.list must be present to tell us the file names."

	| updateList line num |
	updateList _ (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
	[line _ updateList upTo: Character cr.
	updateList atEnd] whileFalse: [
		line first isDigit ifTrue: [
			num _ line splitInteger first.
			num > updateID ifTrue: [
				self scan: (ServerFile new fullPath: directoryUrl,line) asStream
					updateID: num]
			]].
	lastUpdate <= num ifTrue: [
		lastUpdate _ num.
		lastUpdateName _ line splitInteger last].

! !

!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/13/1999 11:25'!
scanUpdatesIn: directoryUrl
	"Scan all update files in the directory starting at lastUpdate+1.  Create a .ix file on my local hard disk.  updates.list must be present to tell us the file names."

	| updateList line num temp out |
	updateList _ (ServerFile new fullPath: directoryUrl,'updates.list') asStream.
	temp _ WriteStream on: (String new: 2000).
	[line _ updateList upTo: Character cr.
	updateList atEnd] whileFalse: [
		line first isDigit ifTrue: [
			num _ line splitInteger first.
			num > lastUpdate ifTrue: [
				self scan: (ServerFile new fullPath: directoryUrl,line) asStream
					updateID: num writeOn: temp]
			]].
	num >= lastUpdate ifTrue: [
		out _ FileStream newFileNamed: 'to', num asString, '.ix'.
		out nextPutAll: 'External ', num asString; space. 
		line splitInteger last storeOn: out.	"quoted"
		out cr; nextPutAll: lastUpdate asString, '.ix' "; cr".	"temp begins with cr"
		out nextPutAll: temp contents; close.
		self inform: 'Rename latest.ix to ', lastUpdate asString, 
			'.ix on both external servers.
Put to', num asString, '.ix on both and call it latest.ix'].
	! !

!DocLibrary methodsFor: 'database of updates' stamp: 'tk 2/15/1999 14:49'!
updateMethodVersions
	"See if any new updates have occurred, and put their methods into the database."

	| indexFile list result |
	self haveNetwork ifFalse: [^ self].
	indexFile _ 'latest.ix'.
	list _ OrderedCollection new.
	[result _ self absorbAfter: lastUpdate from: indexFile.
	"boolean if succeeded, or we are up to date, or server not available"
	result class == String] whileTrue: [
		"result is the prev file name"
		list addFirst: indexFile.
		indexFile _ result].
	list do: [:aFile | self absorbAfter: lastUpdate from: aFile].
		"should always work this time"
! !

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

DocLibrary class
	instanceVariableNames: ''!

!DocLibrary class methodsFor: 'as yet unclassified' stamp: 'tk 2/4/1999 15:58'!
external
	"The dictionary for the External Updates"
	^ External! !

!DocLibrary class methodsFor: 'as yet unclassified' stamp: 'tk 2/5/1999 08:11'!
properStemFor: classAndMethod
	"Put 'class method' into proper form as a file name.  Leave upper and lower case.  The fileName must be short enough and have proper characters for all platforms and servers."

	| sz |
	classAndMethod size > 23 ifTrue: ["too long"
		sz _ classAndMethod size.
		"input contains space and :, not . and ;"
		^ (classAndMethod copyFrom: 1 to: 2), 
			((classAndMethod copyFrom: 3 to: sz//2) crc16 printString),
			((classAndMethod copyFrom: sz//2+1 to: sz) crc16 printString)
		].
	^ (classAndMethod copyReplaceAll: ' ' with: '.')
		copyReplaceAll: ':' with: ';'
! !
FileDirectory subclass: #DosFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!DosFileDirectory commentStamp: '<historical>' prior: 0!
I represent a DOS or Windows FileDirectory.
!


!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'di 6/18/1998 08:57'!
checkName: aFileName fixErrors: fixing
	"Check if the file name contains any invalid characters"
	| fName badChars hasBadChars |
	fName _ super checkName: aFileName fixErrors: fixing.
	badChars _ #( $: $< $> $| $/ $\ $? $* $") asSet.
	hasBadChars _ fName includesAnyOf: badChars.
	(hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name'].
	hasBadChars ifFalse:[^ fName].
	^ fName collect:
		[:char | (badChars includes: char) 
				ifTrue:[$#] 
				ifFalse:[char]]! !

!DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'bf 3/21/2000 17:06'!
setPathName: pathString
	"Ensure pathString is absolute - relative directories aren't supported on all platforms."

	(pathString isEmpty
		or: [pathString first = $\
			or: [pathString size >= 2 and: [pathString second = $: and: [pathString first isLetter]]]])
				ifTrue: [^ super setPathName: pathString].

	self error: 'Fully qualified path expected'! !


!DosFileDirectory methodsFor: 'path access' stamp: 'je 11/8/2000 20:02'!
driveName

   "return a possible drive letter and colon at the start of a Path name, empty string otherwise"

   | firstTwoChars |

   ( pathName size >= 2 ) ifTrue: [
      firstTwoChars _ (pathName copyFrom: 1 to: 2).
      (self class isDrive: firstTwoChars) ifTrue: [^firstTwoChars]
   ].
   ^''! !

!DosFileDirectory methodsFor: 'path access' stamp: 'je 11/8/2000 19:57'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmpty ifTrue:[^pathName].
	(path at: 1) = $\ ifTrue:[
		(path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^path]. "e.g., \\pipe\"
		^self driveName , path "e.g., \windows\"].
	(path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]])
		ifTrue:[^path]. "e.g., c:"
	^pathName, self slash, path! !

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

DosFileDirectory class
	instanceVariableNames: ''!

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^false! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'sma 3/24/2000 11:15'!
isDrive: fullName
	^ (fullName size = 2 and: [fullName first isLetter and: [fullName last = $:]])
		or: [(fullName beginsWith: '\\') and: [(fullName occurrencesOf: $\) <= 3]]! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'!
maxFileNameLength

	^ 255
! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'!
pathNameDelimiter

	^ $\
! !

!DosFileDirectory class methodsFor: 'platform specific' stamp: 'sma 3/24/2000 11:15'!
splitName: fullName to: pathAndNameBlock
	(self isDrive: fullName)
		ifTrue: [^ pathAndNameBlock value: fullName value: ''].
	^ super splitName: fullName to: pathAndNameBlock! !
RectangleMorph subclass: #DoubleClickExample
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!DoubleClickExample commentStamp: '<historical>' prior: 0!
Illustrates the double-click capabilities of Morphic.

If you have a kind of morph you wish to have respond specially to a double-click, it should:

(1)  Respond "true" to #handlesMouseDown:

(2)  In its mouseDown: method, send #waitForClicksOrDrag:event: to the hand.

(3)  Reimplement #click: to react to single-clicked mouse-down.

(4)  Reimplement #doubleClick: to make the appropriate response to a double-click.

(5)  Reimplement #drag: to react to non-clicks.  This message is sent continuously until the button is released.  You can check the event argument to react differently on the first, intermediate, and last calls.!


!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 16:51'!
balloonText
	^ 
'Double-click on me to change my color; 
single-click on me to change border color;
hold mouse down within me to grow 
(if I''m red) or shrink (if I''m blue).'! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'ar 10/3/2000 17:05'!
click: evt
	self showBalloon: 'click' hand: evt hand.
	self borderColor: (self borderColor = Color black ifTrue: [Color yellow] ifFalse: [Color black])
! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'ar 10/3/2000 17:05'!
doubleClick: evt
	self showBalloon: 'doubleClick' hand: evt hand.
	self color: ((color = Color blue) ifTrue: [Color red] ifFalse: [Color blue])
! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/14/1999 16:05'!
handlesMouseDown: evt
	^ true! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/23/1999 17:55'!
initialize
	super initialize.
	self color: Color red! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'bf 9/28/1999 17:20'!
mouseDown: evt
	"Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"

	evt hand waitForClicksOrDrag: self event: evt! !

!DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'ar 10/3/2000 17:05'!
startDrag: evt
	"We'll get a mouseDown first, some mouseMoves, and a mouseUp event last"
	| oldCenter |
	evt isMouseDown ifTrue:
		[self showBalloon: 'drag (mouse down)' hand: evt hand.
		self world displayWorld.
		(Delay forMilliseconds: 750) wait].
	evt isMouseUp ifTrue:
		[self showBalloon: 'drag (mouse up)' hand: evt hand].
	(evt isMouseUp or: [evt isMouseDown]) ifFalse:
		[self showBalloon: 'drag (mouse still down)' hand: evt hand].
	(self containsPoint: evt cursorPoint)
		ifFalse: [^ self].

	oldCenter _ self center.
	color = Color red
		ifTrue:
			[self extent: self extent + (1@1)]
		ifFalse:
			[self extent: ((self extent - (1@1)) max: (16@16))].
	self center: oldCenter! !
Morph subclass: #DownloadingImageMorph
	instanceVariableNames: 'url altText defaultExtent image downloadQueue imageMapName formatter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Formatter'!
!DownloadingImageMorph commentStamp: '<historical>' prior: 0!
a placeholder for an image that is downloading!


!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'bolot 11/2/1999 14:30'!
altText: aString
	"set the text to be displayed while downloading"
	altText _ aString.
	aString ifNotNil: [self setBalloonText: aString].
	self setContents! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'ls 9/9/1998 06:59'!
defaultExtent: aPoint
	"set the size to use when the image hasn't yet downloaded"
	defaultExtent _ aPoint! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 23:08'!
downloadStateIn: aScamper
	"download the image"
	| doc |
	doc _ url retrieveContents.
	downloadQueue nextPut: doc.

! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'ls 9/15/1998 19:21'!
initialize
	super initialize.

	altText _ '[image]'.
	self color: Color transparent.
	downloadQueue _ SharedQueue new.! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'bolot 2/27/2000 23:54'!
setContents
	"set up our morphic contents"
	| imageMorph imageMap |
	self removeAllMorphs.

	image ifNil: [^self setNoImageContents].

	imageMorph _ ImageMorph new.
	(imageMapName notNil
	and: [formatter notNil
	and: [(imageMap _ formatter imageMapNamed: imageMapName) notNil]])
		ifTrue: [imageMap buildImageMapForImage: imageMorph andBrowser: formatter browser].

	imageMorph image: image.
	imageMorph position: self position.
	self addMorph: imageMorph.
	imageMorph extent ~= self extent
		ifTrue: [self extent: imageMorph extent].! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'bolot 2/28/2000 00:14'!
setNoImageContents
	"set up our morphic contents in case image download/decoding failed"
	| stringMorph outlineMorph extent |
	altText isEmptyOrNil
		ifTrue: [ self extent: 0@0. "don't display anything..." ^self ].

	stringMorph _ StringMorph new.
	stringMorph contents: altText.
	stringMorph position: self position+(2@2).
	self addMorph: stringMorph.

	outlineMorph _ RectangleMorph new.
	outlineMorph borderWidth: 1.
	outlineMorph color: Color transparent.
	outlineMorph position: self position.

	"figure out how big to make the box"
	extent _ defaultExtent ifNil: [ 0 @ 0 ].
	stringMorph width + 4 > extent x ifTrue: [
		extent _ (stringMorph width + 4) @ extent y ].
	stringMorph height + 4 > extent y ifTrue: [
		extent _ extent x @ (stringMorph height + 4) ].
	outlineMorph extent: extent.
	self addMorph: outlineMorph.

	self extent: outlineMorph extent
! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'bolot 11/30/1999 23:22'!
step
	| doc |
	downloadQueue size > 0 ifTrue: [
		doc _ downloadQueue next.
		doc mainType = 'image' 
		ifTrue: [
			[image _ ImageReadWriter  formFromStream: doc contentStream binary]
				ifError: [:err :rcvr | "ignore" image _ nil].
			self setContents ] ].! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'ls 9/15/1998 19:19'!
stepTime
	"this check doesn't need to be frequent"
	^500! !

!DownloadingImageMorph methodsFor: 'as yet unclassified' stamp: 'ls 9/5/1998 17:48'!
url: aUrl
	"set the url to download"
	url _ aUrl asUrl.! !


!DownloadingImageMorph methodsFor: 'accessing' stamp: 'bolot 2/27/2000 23:38'!
formatter
	^formatter! !

!DownloadingImageMorph methodsFor: 'accessing' stamp: 'bolot 2/27/2000 23:38'!
formatter: aFormatter
	formatter _ aFormatter! !

!DownloadingImageMorph methodsFor: 'accessing' stamp: 'bolot 2/27/2000 23:34'!
imageMapName
	^imageMapName! !

!DownloadingImageMorph methodsFor: 'accessing' stamp: 'bolot 2/27/2000 23:35'!
imageMapName: aString
	imageMapName _ aString! !
Morph subclass: #DrawErrorMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!DrawErrorMorph commentStamp: '<historical>' prior: 0!
This morph simply invokes errors during drawing and stepping.!


!DrawErrorMorph methodsFor: 'drawing' stamp: 'ar 4/2/1999 12:13'!
drawOn: aCanvas
	aCanvas error:'DrawErrorMorph drawOn: invoked'! !


!DrawErrorMorph methodsFor: 'printing' stamp: 'ar 4/2/1999 12:15'!
printOn: aStream
	"Indirectly invokes an error during stepping in an Inspector"
	aStream error:'DrawErrorMorph>>printOn: invoked'! !
PopUpChoiceMorph subclass: #DropDownChoiceMorph
	instanceVariableNames: 'items border '
	classVariableNames: 'SubMenuMarker '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!DropDownChoiceMorph methodsFor: 'copying' stamp: 'bolot 11/2/1999 12:17'!
veryDeepInner: deepCopier
	super veryDeepInner: deepCopier.
	items _ items veryDeepCopyWith: deepCopier.
	border _ border veryDeepCopyWith: deepCopier! !


!DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:05'!
drawOn: aCanvas

	aCanvas text: contents bounds: (bounds insetBy: 2)  font: self fontToUse color: color.

	border ifNotNil: [aCanvas frameAndFillRectangle: bounds
		fillColor: Color transparent
		borderWidth: 1
		borderColor: Color black].

	aCanvas
			paintImage: SubMenuMarker
			at: (self right - 8 @ ((self top + self bottom - SubMenuMarker height) // 2))! !

!DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 5/18/2000 18:34'!
maxExtent: listOfStrings

	| scanner h w maxW |
	maxW _ 0.
	listOfStrings do: [:str |
		scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse.
		w _ (scanner stringWidth: str).
		h _ scanner lineHeight.
		maxW _ maxW max: w].
	self extent: (maxW + 4 + h) @ (h + 4).
	self changed! !


!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
border
	^border! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
border: newBorder
	border _ newBorder! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
items
	(target notNil and: [getItemsSelector notNil])
		ifTrue: [items _ target perform: getItemsSelector withArguments: getItemsArgs].
	items ifNil: [items _ #()].
	^items! !

!DropDownChoiceMorph methodsFor: 'accessing' stamp: 'bolot 11/2/1999 12:20'!
items: someItems
	items _ someItems! !


!DropDownChoiceMorph methodsFor: 'list access' stamp: 'bolot 11/2/1999 12:21'!
getCurrentSelectionIndex
	^self items indexOf: contents! !

!DropDownChoiceMorph methodsFor: 'list access' stamp: 'bolot 11/2/1999 12:21'!
selection: val
	self contentsClipped: val! !


!DropDownChoiceMorph methodsFor: 'event handling' stamp: 'bolot 11/2/1999 12:22'!
mouseDown: evt

	| menu selectedItem |
	self items isEmpty ifTrue: [^ self].
	menu _ CustomMenu new.
	self items do: [:item | menu add: item action: item].
	selectedItem _ menu startUp.
	selectedItem ifNil: [^ self].
	self contentsClipped: selectedItem.  "Client can override this if necess"
	actionSelector ifNotNil: [
		target
			perform: actionSelector
			withArguments: (arguments copyWith: selectedItem)].
! !

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

DropDownChoiceMorph class
	instanceVariableNames: ''!

!DropDownChoiceMorph class methodsFor: 'class initialization' stamp: 'bolot 11/2/1999 12:19'!
initialize
	"DropDownChoiceMorph initialize"

	| f |
	f _ Form
		extent: 5@9
		fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)
		offset: 0@0.
	SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f.
! !
MorphicEvent subclass: #DropEvent
	instanceVariableNames: 'position contents wasHandled '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
contents
	^contents! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 19:21'!
cursorPoint
	"For compatibility with mouse events"
	^position! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
position
	^position! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'!
type
	^#dropEvent! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'!
wasHandled
	^wasHandled! !

!DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'!
wasHandled: aBool
	wasHandled _ aBool.! !


!DropEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 18:33'!
isDropEvent
	^true! !


!DropEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:24'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	self type == #dropEvent ifTrue:[^anObject handleDropMorph: self].! !


!DropEvent methodsFor: 'printing' stamp: 'ar 9/14/2000 18:15'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self position printString; space.
	aStream nextPutAll: self type.
	aStream nextPut: $].! !


!DropEvent methodsFor: 'private' stamp: 'ar 9/13/2000 19:23'!
setPosition: pos contents: aMorph hand: aHand
	position _ pos.
	contents _ aMorph.
	source _ aHand.
	wasHandled _ false.! !


!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.! !

!DropEvent methodsFor: 'transforming' stamp: 'ar 10/7/2000 18:28'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !


!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:19'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	wasHandled _ anEvent wasHandled.! !

!DropEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	wasHandled _ false.! !
DropEvent subclass: #DropFilesEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!DropFilesEvent methodsFor: 'accessing' stamp: 'ar 1/10/2001 21:35'!
type
	^#dropFilesEvent! !


!DropFilesEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:35'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].! !
InterpreterPlugin subclass: #DropPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!DropPlugin methodsFor: 'initialize' stamp: 'ar 1/10/2001 19:57'!
initialiseModule
	self export: true.
	^self cCode: 'dropInit()' inSmalltalk:[true]! !

!DropPlugin methodsFor: 'initialize' stamp: 'ar 1/10/2001 19:57'!
shutdownModule
	self export: true.
	^self cCode: 'dropShutdown()' inSmalltalk:[true]! !


!DropPlugin methodsFor: 'primitives' stamp: 'ar 1/10/2001 20:46'!
primitiveDropRequestFileHandle
	"Note: File handle creation needs to be handled by specific support code explicitly bypassing the plugin file sand box."
	| dropIndex handleOop |
	self export: true.
	self inline: false.
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	dropIndex _ interpreterProxy stackIntegerValue: 0.
	handleOop _ self dropRequestFileHandle: dropIndex.
	"dropRequestFileHandle needs to return the actual oop returned"
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2.
		interpreterProxy push: handleOop.
	].! !

!DropPlugin methodsFor: 'primitives' stamp: 'ar 1/10/2001 20:46'!
primitiveDropRequestFileName
	"Note: File handle creation needs to be handled by specific support code explicitly bypassing the plugin file sand box."
	| dropIndex dropName nameLength nameOop namePtr |
	self export: true.
	self inline: false.
	self var: #dropName type: 'char *'.
	self var: #namePtr type: 'char *'.
	interpreterProxy methodArgumentCount = 1 
		ifFalse:[^interpreterProxy primitiveFail].
	dropIndex _ interpreterProxy stackIntegerValue: 0.
	dropName _ self dropRequestFileName: dropIndex.
	"dropRequestFileName returns name or NULL on error"
	dropName == nil 
		ifTrue:[^interpreterProxy primitiveFail].
	nameLength _ self strlen: dropName.
	nameOop _ interpreterProxy instantiateClass: interpreterProxy classString indexableSize: nameLength.
	namePtr _ interpreterProxy firstIndexableField: nameOop.
	0 to: nameLength-1 do:[:i| namePtr at: i put: (dropName at: i)].
	interpreterProxy pop: 2.
	interpreterProxy push: nameOop.
! !

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

DropPlugin class
	instanceVariableNames: ''!

!DropPlugin class methodsFor: 'translation' stamp: 'ar 1/10/2001 20:02'!
headerFile
^'/* drop support primitives */

/* module initialization/shutdown */
int dropInit(void);
int dropShutdown(void);

char* dropRequestFileName(int dropIndex); /* return name of file or NULL if error */
/* note: dropRequestFileHandle needs to bypass plugin security checks when implemented */
int dropRequestFileHandle(int dropIndex); /* return READ-ONLY file handle OOP or nilObject if error */
'! !
Model subclass: #DualChangeSorter
	instanceVariableNames: 'leftCngSorter rightCngSorter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!DualChangeSorter commentStamp: '<historical>' prior: 0!
This class presents a view of a two change sets at once, and supports copying changes between change sets.
!


!DualChangeSorter methodsFor: 'as yet unclassified'!
isLeftSide: theOne
	"Which side am I?"
	^ theOne == leftCngSorter! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'tk 4/30/1998 13:44'!
labelString
	"The window label"
	^ leftCngSorter labelString! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'tk 5/8/1998 16:30'!
modelWakeUp
	"A window with me as model is being entered.  Make sure I am up-to-date with the changeSets."

	"Dumb way"
	leftCngSorter canDiscardEdits 
		ifTrue: [leftCngSorter update]	"does both"
		ifFalse: [rightCngSorter update].
! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'sw 3/6/1999 09:34'!
morphicWindow
	
	| window |
	leftCngSorter _ ChangeSorter new myChangeSet: Smalltalk changes.
	leftCngSorter parent: self.
	rightCngSorter _ ChangeSorter new myChangeSet: 
			ChangeSorter secondaryChangeSet.
	rightCngSorter parent: self.

	window _ (SystemWindow labelled: leftCngSorter label) model: self.
	"topView minimumSize: 300 @ 200."
	leftCngSorter openAsMorphIn: window rect: (0@0 extent: 0.5@1).
	rightCngSorter openAsMorphIn: window rect: (0.5@0 extent: 0.5@1).
	^ window
! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'di 5/20/1998 21:44'!
okToChange
	^ leftCngSorter okToChange & rightCngSorter okToChange! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'sma 4/30/2000 09:29'!
open
	| topView |
	Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph].

	leftCngSorter _ ChangeSorter new myChangeSet: Smalltalk changes.
	leftCngSorter parent: self.
	rightCngSorter _ ChangeSorter new myChangeSet: 
			ChangeSorter secondaryChangeSet.
	rightCngSorter parent: self.

	topView _ (StandardSystemView new) model: self; borderWidth: 1.
	topView label: leftCngSorter label.
	topView minimumSize: 300 @ 200.
	leftCngSorter openView: topView offsetBy: 0@0.
	rightCngSorter openView: topView offsetBy: 360@0.
	topView controller open.
! !

!DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'sw 3/6/1999 09:34'!
openAsMorph
	^ self morphicWindow openInWorld
! !

!DualChangeSorter methodsFor: 'as yet unclassified'!
other: theOne
	"Return the other side's ChangeSorter"
	^ theOne == leftCngSorter
		ifTrue: [rightCngSorter]
		ifFalse: [leftCngSorter]! !

!DualChangeSorter methodsFor: 'as yet unclassified'!
release
	leftCngSorter release.
	rightCngSorter release.! !

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

DualChangeSorter class
	instanceVariableNames: ''!

!DualChangeSorter class methodsFor: 'opening' stamp: 'sw 3/24/1999 17:50'!
open
	"Open a new instance of the receiver's class"

	self new open! !
MenuMorph subclass: #DumberMenuMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!DumberMenuMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!DumberMenuMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:40'!
setInvokingView: invokingView
	"I'd rather not, if that's OK"! !
Stream subclass: #DummyStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!DummyStream commentStamp: '<historical>' prior: 0!
The purpose of this class is to absorb all steam messages and do nothing.  This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write.  We need to know what those object are.  8/17/96 tk
!


!DummyStream methodsFor: 'as yet unclassified'!
binary
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified' stamp: 'tk 10/31/97 11:43'!
close
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified'!
nextInt32Put: arg
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified'!
nextNumber: cnt put: num
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified' stamp: 'tk 6/8/1998 21:07'!
nextPut: aByte
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified' stamp: 'tk 6/8/1998 21:06'!
nextPutAll: aByteArray
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified'!
nextStringPut: aString
	"do nothing"! !

!DummyStream methodsFor: 'as yet unclassified' stamp: 'tk 3/6/2000 11:10'!
originalContents

	^ ''! !

!DummyStream methodsFor: 'as yet unclassified'!
position
	"Return any random number.  Here is where the real lying begins.  We are a DummyStream afterall.  8/17/96 tk"

	^ 47 ! !

!DummyStream methodsFor: 'as yet unclassified' stamp: 'tk 7/12/1998 12:51'!
position: anOffset
	"Pretend to position wherever the caller says!!"
! !

!DummyStream methodsFor: 'as yet unclassified' stamp: '6/10/97 17:14 tk'!
skip: aNumber
	"Do nothing."! !

!DummyStream methodsFor: 'as yet unclassified'!
subclassResponsibility
	"Do nothing.  Most messages to class Stream are defined as subclassResponsibility.  Just accept them.  8/17/96 tk"

	"No error.  Just go on."! !

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

DummyStream class
	instanceVariableNames: ''!

!DummyStream class methodsFor: 'as yet unclassified' stamp: 'jm 12/3/97 20:25'!
on: aFile
	"Return a new DummyStream instance, ignoring the argument."

	^ self basicNew
! !
UtteranceVisitor subclass: #DurationsVisitor
	instanceVariableNames: 'inherents lowers speed '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!DurationsVisitor commentStamp: '<historical>' prior: 0!
This is an implementation of the Klatt rule system as described in chapter 9 of "From text to speech: The MITalk system", Allen, Hunnicutt and Klatt.!


!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:38'!
defaultDurationFor: aPhoneme
	"Some hardcoded durations for phonemes."
	aPhoneme isVoiced ifTrue: [^ 0.0565].
	aPhoneme isUnvoiced ifTrue: [^ 0.0751].
	aPhoneme isConsonant ifTrue: [^ 0.06508].
	aPhoneme isDiphthong ifTrue: [^ 0.1362].
	^ 0.0741! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
inherentDurationAt: aPhoneme
	^ self inherents at: aPhoneme ifAbsent: [Transcript show: ' default duration for ', aPhoneme name. self defaultDurationFor: aPhoneme]! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
inherents
	^ inherents! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
inherents: aDictionary
	inherents _ aDictionary! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
lowerDurationAt: aPhoneme
	^ self lowers at: aPhoneme ifAbsent: [self inherentDurationAt: aPhoneme]! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
lowers
	^ lowers! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 16:39'!
lowers: aDictionary
	lowers _ aDictionary! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 18:28'!
speed
	^ speed! !

!DurationsVisitor methodsFor: 'accessing' stamp: 'len 12/8/1999 18:28'!
speed: aNumber
	speed _ aNumber! !


!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 04:22'!
clause: aClause
	| min |
	super clause: aClause.

	self rule2.

	clause wordsDo: [ :eachWord |
		eachWord events do: [ :each |
			min _ self lowerDurationAt: each phoneme.
			eachWord isAccented ifFalse: [min _ min / 2.0].
			each duration: each duration + min / 1.4 / self speed]].
	clause syllablesDo: [ :each | each events recomputeTimes]! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:04'!
phrase: aPhrase
	super phrase: aPhrase.
	self rule3; rule3b! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 18:27'!
speaker: aSpeaker
	self speed: aSpeaker speed! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:05'!
syllable: aSyllable
	super syllable: aSyllable.

	syllable events do: [ :each | each duration: (self inherentDurationAt: each phoneme) - (self lowerDurationAt: each phoneme)].
	self rule4; rule5; rule9a; rule9b; rule10! !

!DurationsVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 17:06'!
word: aWord
	super word: aWord.

	self rule6; rule7; rule8! !


!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:55'!
rule10
	"Rule 10: Shortening in clusters."
	| current next previous stream |
	phrase lastSyllable == syllable ifTrue: [^ self].
	stream _ ReadStream on: syllable events.
	current _ nil.
	next _ stream next.
	[stream atEnd]
		whileFalse: [previous _ current.
					current _ next.
					next _ stream next.
					current phoneme isVowel
						ifTrue: [next phoneme isVowel
									ifTrue: [current stretch: 1.2]
									ifFalse: [(previous notNil and: [previous phoneme isVowel])
												ifTrue: [current stretch: 0.7]]]
						ifFalse: [next phoneme isConsonant
									ifTrue: [(previous notNil and: [previous phoneme isConsonant])
												ifTrue: [current stretch: 0.5]
												ifFalse: [current stretch: 0.7]]
									ifFalse: [(previous notNil and: [previous phoneme isConsonant])
												ifTrue: [current stretch: 0.5]]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:53'!
rule2
	"Rule 2: Clause Final Lengthening."

	clause lastSyllable events stretch: 1.4! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/13/1999 02:36'!
rule3
	"Rule 3: Non-phrase-final shortening.
	Syllabic segments are shortened by 60 if not in a phrase-final syllable."

	phrase syllablesDo: [ :each |
		phrase lastSyllable == each
			ifFalse: [each events do: [ :event | event phoneme isSyllabic ifTrue: [event stretch: 0.6]]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:53'!
rule3b
	"A phrase-final postvocalic liquid or nasal is lengthened by 140"

	phrase lastSyllable events do: [ :each | (each phoneme isNasal or: [each phoneme isLiquid]) ifTrue: [each stretch: 1.4]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:56'!
rule4
	"Rule 4: Non-word-final shortening.
	Syllabic segments are shortened by 85 if not in a word-final syllable."

	word lastSyllable == syllable ifTrue: [^ self].
	syllable events do: [ :each | each phoneme isSyllabic ifTrue: [each stretch: 0.85]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:56'!
rule5
	"Rule 5: Polysyllabic Shortening.
	Syllabic segments in a polysyllabic word are shortened by 80."

	word isPolysyllabic ifFalse: [^ self].
	syllable events do: [ :each | each phoneme isSyllabic ifTrue: [each stretch: 0.8]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:59'!
rule6
	"Rule 6: Non-initial-consonant shortening."

	| nonInitial |
	nonInitial _ false.
	word events do: [ :each |
		(nonInitial and: [each phoneme isConsonant]) ifTrue: [each stretch: 0.85].
		nonInitial _ true]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:59'!
rule7
	"Rule 7: Unstressed shortening."

	word syllables
		do: [ :each |
			each stress > 0
				ifFalse: [each events do: [ :event | event phoneme isSyllabic ifTrue: [event stretch: 0.5]].
						each events first phoneme isSyllabic ifTrue: [each events first stretch: 0.7 / 0.5].
						(each events last phoneme isSyllabic and: [each events size > 1]) ifTrue: [each events last stretch: 0.7 / 0.5]]]
! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/13/1999 02:33'!
rule8
	"Rule 8: Lengthening for emphasis."

	word isAccented
		ifTrue: [word events do: [ :each | each phoneme isVowel ifTrue: [each stretch: 1.4]]]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:57'!
rule9a
	"Rule 9a: Postvocalic context of vowels."

	| events current next nextnext |
	phrase lastSyllable == syllable ifTrue: [^ self].
	events _ syllable events.
	1 to: events size do: [ :i |
		current _ events at: i.
		next _ i + 1 <= events size ifTrue: [(events at: i + 1) phoneme].
		nextnext _ i + 2 <= events size ifTrue: [(events at: i + 2) phoneme].
		current stretch: (self rule9a: current phoneme next: next nextnext: nextnext)]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 17:00'!
rule9a: current next: next nextnext: nextnext
	"Rule 9a: Postvocalic context of vowels."

	current isVowel
		ifTrue: [next isNil ifTrue: [^ 1.2].
				nextnext isNil ifTrue: [^ self subRule9a: next].
				(next isSonorant and: [nextnext isObstruent]) ifTrue: [^ self subRule9a: nextnext]]
		ifFalse: [current isSonorant
					ifTrue: [next isNil ifTrue: [^ 1.2].
							next isObstruent ifTrue: [^ self subRule9a: next]]].
	^ 1.0! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 16:58'!
rule9b
	"Rule 9b: Postvocalic context of vowels."

	| events current next nextnext |
	phrase lastSyllable == syllable ifFalse: [^ self].
	events _ syllable events.
	1 to: events size do: [ :i |
		current _ events at: i.
		next _ i + 1 <= events size ifTrue: [(events at: i + 1) phoneme].
		nextnext _ i + 2 <= events size ifTrue: [(events at: i + 2) phoneme].
		current stretch: 0.3 * (self rule9a: current phoneme next: next nextnext: nextnext) + 0.7]! !

!DurationsVisitor methodsFor: 'rules' stamp: 'len 12/8/1999 17:01'!
subRule9a: aPhoneme
	"Sub-rule 9a, independent of segment position."
	aPhoneme isVoiced ifFalse: [^ aPhoneme isStop ifTrue: [0.7] ifFalse: [1.0]].
	aPhoneme isFricative ifTrue: [^ 1.6].
	aPhoneme isStop ifTrue: [^ 1.2].
	aPhoneme isNasal ifTrue: [^ 0.85].
	^ 1.0! !

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

DurationsVisitor class
	instanceVariableNames: ''!

!DurationsVisitor class methodsFor: 'instance creation' stamp: 'len 12/8/1999 16:40'!
inherents: aDictionary lowers: anotherDictionary
	^ self new inherents: aDictionary; lowers: anotherDictionary! !


!DurationsVisitor class methodsFor: 'examples' stamp: 'len 12/8/1999 16:40'!
default
	| phonemes inherents lowers |
	phonemes _ PhonemeSet arpabet.
	inherents _ Dictionary new.
	lowers _ Dictionary new.
	#(
	('ae'	230.0	80.0)
	('aa'	240.0	100.0)
	('ax'	120.0	60.0)
	('er'	180.0	80.0)
	('ay'	250.0	150.0)
	('aw'	240.0	100.0)
	('b'		85.0		60.0)
	('ch'	70.0		50.0)
	('d'		75.0		50.0)
	('dh'	50.0		30.0)
	('eh'	150.0	70.0)
	('ea'	270.0	130.0)
	('ey'	180.0	100.0)
	('f'		100.0	80.0)
	('g'		80.0		60.0)
	('hh'	80.0		20.0)
	('ih'	135.0	40.0)
	('ia'	230.0	100.0)
	('iy'	155.0	55.0)
	('jh'	70.0		50.0)
	('k'		80.0		60.0)
	('l'		80.0		40.0)
	('m'		70.0		60.0)
	('n'		60.0		50.0)
	('ng'	95.0		60.0)
"	('oh'	240.0	130.0)"
	('oy'	280.0	150.0)
	('ao'	240.0	130.0)
	('ow'	220.0	80.0)
	('p'		90.0		50.0)
	('r'		80.0		30.0)
	('s'		105.0	60.0)
	('sh'	105.0	80.0)
	('t'		75.0		50.0)
	('th'	90.0		60.0)
	('uh'	210.0	70.0)
	('ua'	230.0	110.0)
	('ah'	160.0	60.0)
	('uw'	230.0	150.0)
	('v'		60.0		40.0)
	('w'		80.0		60.0)
	('y'		80.0		40.0)
	('z'		75.0		40.0)
	('zh'	70.0		40.0)
	('sil'	100.0	100.0)) do: [ :each |
		inherents at: (phonemes at: each first) put: each second / 1000.0.
		lowers at: (phonemes at: each first) put: each last / 1000.0].
	^ self inherents: inherents lowers: lowers! !
PostscriptCanvas subclass: #EPSCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!EPSCanvas commentStamp: '<historical>' prior: 0!
I am a canvas for generating Encapsulates PostScript (EPS) files from single morphs, for example for screen-dumps.

I make sure that the bounding box of the EPS surrounds exactly the morph, and am not capable of generating multiple pages.  I do not generate an on-screen Preview for the EPS file, though that should be possible.
!


!EPSCanvas methodsFor: 'as yet unclassified' stamp: 'mpw 9/12/1999 07:29'!
fullDraw:aMorph
	super fullDraw:aMorph.
	morphLevel = 0 ifTrue: [
		target showpage.
	].! !

!EPSCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 16:27'!
setupGStateForMorph: aMorph

	target comment: 'setupGState in EPSCanvas'.
	morphLevel == 1 ifTrue: [ 
		EPSCanvas bobsPostScriptHacks ifTrue: [	"needed to print RectangleMorph"
			self writeSetupForRect: aMorph bounds.
			target translate: aMorph bounds origin negated.
		] ifFalse: [
			target translate: aMorph bounds origin negated.
			self writeSetupForRect: aMorph bounds.
		].
	].
! !

!EPSCanvas methodsFor: 'as yet unclassified' stamp: 'di 8/9/2000 21:43'!
writePSIdentifierRotated: rotateFlag

	target print:'%!!PS-Adobe-2.0 EPSF-1.2'; cr.
	rotateFlag
		ifTrue: [target print: '%%BoundingBox: '; write: psBounds rounded; cr;
					print: '90 rotate'; cr;
					print: '0 -'; write: psBounds height rounded; print: ' translate'; cr]
		ifFalse: [target print: '%%BoundingBox: '; write: psBounds rounded; cr].
	target print:'%%Title: '; write:self topLevelMorph externalName; cr.

! !

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

EPSCanvas class
	instanceVariableNames: ''!

!EPSCanvas class methodsFor: 'as yet unclassified' stamp: 'mpw 9/18/1999 11:04'!
baseOffset
	^10@10.
! !

!EPSCanvas class methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 16:56'!
bobsPostScriptHacks

	^true! !
EToyChatOrBadgeMorph subclass: #EToyChatMorph
	instanceVariableNames: 'listener receivingPane myForm recipientForm acceptOnCR sendingPane '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyChatMorph commentStamp: '<historical>' prior: 0!
EToyChatMorph new open setIPAddress: '1.2.3.4'

"
EToyChatMorph represents a chat session with another person. Type your message in the top text pane and press cmd-S.
"!
]style[(46 122)f2cblue;,f1!


!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/5/2000 14:14'!
acceptTo: someText forMorph: aMorph

	| betterText |

	betterText _ self improveText: someText forMorph: aMorph.
	self 
		transmitStreamedObject: (betterText eToyStreamedRepresentationNotifying: self) 
		to: self ipAddress.
	aMorph setText: '' asText.
	self appendMessage: 
		self startOfMessageFromMe,
		' - ',
		betterText,
		String cr.

	^true! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 22:34'!
appendMessage: aText

	receivingPane appendTextEtoy: aText.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/16/2000 12:26'!
chatFrom: ipAddress name: senderName text: text

	| initialText attrib |

	recipientForm ifNil: [
		initialText _ senderName asText allBold.
	] ifNotNil: [
		attrib _ TextAnchor new anchoredMorph: recipientForm "asMorph".
		initialText _ '*' asText.
		initialText addAttribute: attrib from: 1 to: 1.
	].
	self appendMessage: initialText,' - ',text,String cr.
	EToyCommunicatorMorph playArrivalSound.


! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 10:37'!
getChoice: aSymbol
	
	aSymbol == #acceptOnCR ifTrue: [^acceptOnCR ifNil: [true]].
	^false.
! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/5/2000 14:14'!
improveText: someText forMorph: aMorph

	| betterText conversions newAttr fontForAll |

	fontForAll _ aMorph eToyGetMainFont.
	betterText _ someText veryDeepCopy.
	conversions _ OrderedCollection new.
	betterText runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextFontChange) ifTrue: [
				conversions add: {att. start. stop}
			]
		]
	].
	conversions do: [ :old |
		betterText removeAttribute: old first from: old second to: old third.
		newAttr _ TextFontReference toFont: (fontForAll fontAt: old first fontNumber).
		newAttr fontNumber: old first fontNumber.
		betterText addAttribute: newAttr from: old second to: old third.
	].
	^betterText! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:30'!
initialize

	super initialize.
	acceptOnCR _ true.
	self listDirection: #topToBottom.
	color _ Color paleYellow.
	self layoutInset: 0.
	borderColor _ self standardBorderColor.
	borderWidth _ 8.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self rubberBandCells: false.
	self minWidth: 200.
	self minHeight: 200.
	bounds _ 400@100 extent:  200@150.
	self rebuild.
! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 16:14'!
insetTheScrollbars

	self allMorphsDo: [ :each | 
		(each isKindOf: PluggableTextMorph) ifTrue: [each retractable: false]
	].! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 06:09'!
ipAddress
	
	^(fields at: #ipAddress) contents! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 11:30'!
open
	
	^self openIn: self currentWorld! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:40'!
openIn: aWorld

	"open an a chat window"

	aWorld ifNil: [^self].
	self 
		position: 400@100;
		extent:  200@150;
		openInWorld: aWorld.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:17'!
rebuild
	| r1 r2 |

	r1 _ self addARow: {
		self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
		self inAColumn: {StringMorph new contents: 'Your message to:'; lock}.
		self textEntryFieldNamed: #ipAddress with: ''
					help: 'IP address for chat partner'.
	}.
	recipientForm ifNotNil: [
		r1 addMorphBack: recipientForm asMorph lock
	].
	sendingPane _ PluggableTextMorph
				on: self
				text: nil
				accept: #acceptTo:forMorph:.
	sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: sendingPane.
	r2 _ self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
	receivingPane _ PluggableTextMorph
				on: self
				text: nil
				accept: nil.
	receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: receivingPane.
	receivingPane spaceFillWeight: 3.
	{r1. r2} do: [ :each |
		each
			vResizing: #shrinkWrap; minHeight: 18;
			color: Color veryLightGray.
	].
	sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR _ true])! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 08:50'!
recipientForm: aForm

	recipientForm _ aForm.
	recipientForm ifNotNil: [recipientForm _ recipientForm scaledToSize: 20@20].! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:43'!
reportError: aString

	receivingPane appendTextEtoy: (aString asText addAttribute: TextColor red), String cr.! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 05:39'!
setIPAddress: aString
	
	(fields at: #ipAddress) contents: aString! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:04'!
standardBorderColor

	^Color darkGray! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 14:50'!
startOfMessageFromMe

	myForm ifNil: [
		myForm _ EToySenderMorph pictureForIPAddress: NetNameResolver localAddressString.
		myForm ifNotNil: [
			myForm _ myForm scaledToSize: 20@20
		].
	].
	myForm ifNil: [
		^(Preferences defaultAuthorName asText allBold addAttribute: TextColor blue)
	].
	^'*' asText
		addAttribute: (TextAnchor new anchoredMorph: myForm);
		yourself

! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 10:41'!
toggleChoice: aSymbol
	
	aSymbol == #acceptOnCR ifTrue: [
		acceptOnCR _ (acceptOnCR ifNil: [true]) not.
		sendingPane ifNotNil: [sendingPane acceptOnCR: acceptOnCR].
		^self
	].

! !

!EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:58'!
transmittedObjectCategory

	^EToyIncomingMessage typeKeyboardChat! !


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

EToyChatMorph class
	instanceVariableNames: ''!

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 14:51'!
chatFrom: ipAddress name: senderName text: text

	| chatWindow |

	chatWindow _ self 
		chatWindowForIP: ipAddress 
		name: senderName 
		picture: (EToySenderMorph pictureForIPAddress: ipAddress) 
		inWorld: self currentWorld.
	chatWindow
		chatFrom: ipAddress 
		name: senderName 
		text: text
! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/16/2000 12:26'!
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld

	| makeANewOne aSenderBadge existing |

	existing _ self instanceForIP: ipAddress inWorld: aWorld.
	existing ifNotNil: [^existing].
	makeANewOne _ [
		self new
			recipientForm: aForm; 
			open; 
			setIPAddress: ipAddress
	].
	EToyCommunicatorMorph playArrivalSound.
	self doChatsInternalToBadge ifTrue: [
		aSenderBadge _ EToySenderMorph instanceForIP: ipAddress inWorld: aWorld.
		aSenderBadge ifNotNil: [
			aSenderBadge startChat: false.
			^aSenderBadge 
				findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
				ifAbsent: makeANewOne
		].
		aSenderBadge _ EToySenderMorph instanceForIP: ipAddress.
		aSenderBadge ifNotNil: [
			aSenderBadge _ aSenderBadge veryDeepCopy.
			aSenderBadge 
				killExistingChat;
				openInWorld: aWorld;
				startChat: false.
			^aSenderBadge 
				findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
				ifAbsent: makeANewOne
		].
		(aSenderBadge _ EToySenderMorph new)
			userName: senderName 
			userPicture: aForm
			userEmail: 'unknown' 
			userIPAddress: ipAddress;
			position: 200@200;
			openInWorld: aWorld;
			startChat: false.
		^aSenderBadge 
			findDeepSubmorphThat: [ :x | x isKindOf: EToyChatMorph] 
			ifAbsent: makeANewOne
	].
	^makeANewOne value.

! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 17:12'!
doChatsInternalToBadge

	^true! !

!EToyChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:48'!
instanceForIP: ipAddress inWorld: aWorld

	^self allInstances detect: [ :x | 
		x world == aWorld and: [x ipAddress = ipAddress]
	] ifNone: [nil]

! !
EToyCommunicatorMorph subclass: #EToyChatOrBadgeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

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

EToyChatOrBadgeMorph class
	instanceVariableNames: ''!

!EToyChatOrBadgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:51'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ self ~~ EToyChatOrBadgeMorph! !
AlignmentMorphBob1 subclass: #EToyCommunicatorMorph
	instanceVariableNames: 'fields resultQueue '
	classVariableNames: 'LastFlashTime '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyCommunicatorMorph commentStamp: '<historical>' prior: 0!
====== find and report all instances =====
	EToySenderMorph instanceReport


====== zap a bunch of ipAddresses =====
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = '11.11.11.11' ifTrue: [each ipAddress: 'whizzbang']
	].
==================== now change one of the whizzbang's back to the right address=====
====== delete the whizzbangs ======
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = 'whizzbang' ifTrue: [each stopStepping; delete]
	].
!
]style[(44 32 41 64 13 42 1 85 37 115 1)f1,f1cblue;,f1,f1cblue;,f1cred;,f1cblue;,f1,f1cred;,f1,f1cblue;,f1!


!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:39'!
addGateKeeperMorphs

	| list currentTime choices age row |

	self setProperty: #gateKeeperCounterValue toValue: EToyGateKeeperMorph updateCounter.
	choices _ #(
		(60 'm' 'in the last minute')
		(3600 'h' 'in the last hour')
		(86400 'd' 'in the last day')
	).
	currentTime _ Time totalSeconds.
	list _ EToyGateKeeperMorph knownIPAddresses.
	list do: [ :each |
		age _ each timeBetweenLastAccessAnd: currentTime.
		age _ choices
			detect: [ :x | age <= x first]
			ifNone: [{0. '-'. (age // 86400) printString,'days ago'}].
		row _ self addARow:
		(EToyIncomingMessage allTypes collect: [ :type |
				self toggleButtonFor: each attribute: type]
		),
		{

			(self inAColumn: {
				(StringMorph contents: age second) lock.
			}) layoutInset: 2; hResizing: #shrinkWrap; setBalloonText: 'Last attempt was ',age third.

			(self inAColumn: {
				(StringMorph contents: each ipAddress) lock.
			}) layoutInset: 2; hResizing: #shrinkWrap.

			(self inAColumn: {
				(StringMorph contents: each latestUserName) lock.
			}) layoutInset: 2.
		}.
		row
			color: (Color r: 0.6 g: 0.8 b: 1.0);
			borderWidth: 1;
			borderColor: #raised;
			vResizing: #spaceFill;
			"on: #mouseUp send: #mouseUp:in: to: self;"
			setBalloonText: each fullInfoString
	].! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 11:33'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 05:57'!
commResult: anArrayOfAssociations

	| aDictionary |
	aDictionary _ Dictionary new.
	anArrayOfAssociations do: [ :each | aDictionary add: each].
	resultQueue nextPut: aDictionary! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 17:45'!
delete

	super delete.
	self breakDependents! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 18:33'!
editEvent: anEvent for: aMorph

	| answer |

	(aMorph bounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	answer _ FillInTheBlankMorph
		request: 'Enter a new ',aMorph balloonText
		initialAnswer: aMorph contents.
	answer isEmptyOrNil ifTrue: [^self].
	aMorph contents: answer
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 16:59'!
field: fieldName is: anObject

	fields at: fieldName put: anObject.
	^anObject! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 10:05'!
flashIndicator: aSymbol

	| now |

	now _ Time millisecondClockValue.
	(LastFlashTime notNil and: [(Time millisecondClockValue - now) abs < 500]) ifTrue: [^self].
	LastFlashTime _ now.
	self trulyFlashIndicator: aSymbol
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:42'!
handleResult: aDictionary

	| m |

	aDictionary at: #commFlash ifPresent: [ :ignore | ^self flashIndicator: #communicating].
	self resetIndicator: #communicating.
	m _ aDictionary at: #message ifAbsent: ['unknown message'].
	m = 'OK' ifTrue: [^self].
	self reportError: m! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 17:32'!
indicatorFieldNamed: aSymbol color: aColor help: helpString

	| f col |
	f _ EllipseMorph new
		extent: 10@10;
		color: aColor;
		setBalloonText: helpString.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/30/2000 15:30'!
initialize

	super initialize.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	resultQueue _ SharedQueue new.
	fields _ Dictionary new.
	self useRoundedCorners.
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 16:48'!
open

	self openInWorld! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 16:41'!
reportError: aString

	self inform: aString! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 08:18'!
resetIndicator: aSymbol

	| indicator firstColor |
	indicator _ fields at: aSymbol ifAbsent: [^self].
	firstColor _ indicator 
		valueOfProperty: #firstColor
		ifAbsent: [^self].
	indicator color: firstColor.
	self world displayWorldSafely.
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 10:14'!
step

	| state |

	[resultQueue isEmpty] whileFalse: [
		self handleResult: resultQueue next
	].
	(state _ self valueOfProperty: #flashingState ifAbsent: [0]) > 0 ifTrue: [
		self borderColor: (
			(self valueOfProperty: #flashingColors ifAbsent: [{Color green. Color red}]) atWrap: state
		).
		self setProperty: #flashingState toValue: state + 1
	].! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 10:27'!
stepTime

	(self valueOfProperty: #flashingState ifAbsent: [0]) > 0 ifTrue: [
		^200
	] ifFalse: [
		^1000
	].! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:19'!
stopFlashing

	self setProperty: #flashingState toValue: 0.
	self borderColor: (self valueOfProperty: #normalBorderColor ifAbsent: [Color blue]).
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/8/2000 18:35'!
textEntryFieldNamed: aSymbol with: aString help: helpString

	| f col |
	f _ (StringMorph new contents: aString)
		setBalloonText: helpString;
		on: #mouseUp send: #editEvent:for: to: self.
	self field: aSymbol is: f.
	col _ (self inAColumn: {f}) color: Color white; hResizing: #shrinkWrap.
	^col! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/2000 12:42'!
toggleButtonFor: entry attribute: attribute

	^(self inAColumn: {
		self
			simpleToggleButtonFor: entry 
			attribute: attribute 
			help: 'Whether you want "',attribute,'" messages'
	}) hResizing: #shrinkWrap
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'mir 10/12/2000 14:55'!
transmitStreamedObject: outData as: objectCategory to: anIPAddress

	EToyPeerToPeer transmitStreamedObject: outData as: objectCategory to: anIPAddress for: self! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'mir 10/10/2000 12:47'!
transmitStreamedObject: outData to: anIPAddress

	self transmitStreamedObject: outData as: self transmittedObjectCategory to: anIPAddress
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 10:05'!
trulyFlashIndicator: aSymbol

	| indicator firstColor |

	indicator _ fields at: aSymbol ifAbsent: [^self].
	firstColor _ indicator 
		valueOfProperty: #firstColor
		ifAbsent: [
			indicator setProperty: #firstColor toValue: indicator color.
			indicator color
		].
	indicator color: (indicator color = firstColor ifTrue: [Color white] ifFalse: [firstColor]).
	self world displayWorldSafely.
! !

!EToyCommunicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 06:25'!
wantsSteps

	^true! !

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

EToyCommunicatorMorph class
	instanceVariableNames: ''!

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:19'!
allForIPAddress: ipString	"for cleaning up Alan's demo"
"
EToySenderMorph allForIPAddress: '1.2.3.4'
"
	Smalltalk garbageCollect.
	(self allInstances select: [ :each | each ipAddress = ipString]) explore! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ self ~~ EToyCommunicatorMorph! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:13'!
instanceReport	"for cleaning up Alan's demo"
"
EToySenderMorph instanceReport
"
	| answer resp |

	Smalltalk garbageCollect.
	answer _ self allInstances collect: [ :each |
		{
			each.
			[each ipAddress] on: Error do: [ 'no ipAddress'].
			each owner 
					ifNil: ['* no owner *'] 
					ifNotNil: [each owner innocuousName,' ',each owner printString].
			each world ifNil: ['-----no project-----'] ifNotNil: [each world project name].
		}
	].
	resp _ (PopUpMenu labels: 'IP Address\Project\Owner' withCRs) startUpWithCaption: 
					'Sorted by'.
	resp = 1 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a second <= b second]) asArray explore
	].
	resp = 2 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a fourth <= b fourth]) asArray explore
	].
	resp = 3 ifTrue: [
		^(answer asSortedCollection: [ :a :b | a third <= b third]) asArray explore
	].
	answer explore! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 17:09'!
otherCleanup
">>>
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = '11.11.11.11' ifTrue: [each ipAddress: 'whizzbang']
	].
<<<"
	"==================== now change one of the whizzbang's back to the right address====="
">>>
	EToySenderMorph allInstances do: [ :each | 
		each ipAddress = 'whizzbang' ifTrue: [each delete]
	].
<<<"
! !

!EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/16/2000 12:27'!
playArrivalSound

	Preferences soundsEnabled ifTrue: [
		SampledSound playSoundNamed: 'chirp'.
	] ifFalse: [
		1 beep
	].! !
EToyCommunicatorMorph subclass: #EToyFridgeMorph
	instanceVariableNames: 'recipients incomingRow recipientRow updateCounter groupMode '
	classVariableNames: 'FridgeRecipients NewItems TheFridgeForm UpdateCounter '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyFridgeMorph commentStamp: '<historical>' prior: 0!
EToyFridgeMorph new openInWorld!
]style[(31)f4cblue;!


!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 19:24'!
acceptDroppingMorph: morphToDrop event: evt

	| outData |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [		"don't send these"
		^morphToDrop rejectDropMorphEvent: evt
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we will keep a copy"
	(morphToDrop isKindOf: EToySenderMorph) ifTrue: [
		self class addRecipient: morphToDrop.
		^self rebuild
	].
	self stopFlashing.

	outData _ morphToDrop veryDeepCopy eToyStreamedRepresentationNotifying: self.
	self resetIndicator: #working.
	self class fridgeRecipients do: [ :each |
		self transmitStreamedObject: outData to: each ipAddress
	].

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 12:07'!
drawOn: aCanvas

	| f cache |
	f _ self class fridgeForm ifNil: [^super drawOn: aCanvas].
	cache _ Form extent: bounds extent depth: aCanvas depth.
	f
		displayInterpolatedIn: cache boundingBox truncated
		on: cache.
	cache replaceColor: Color black withColor: Color transparent.
	aCanvas 
		translucentImage: cache
		at: bounds origin.
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 12:47'!
getChoice: aString

	aString = 'group' ifTrue: [^groupMode ifNil: [true]].! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 13:13'!
groupToggleButton

	^(self inAColumn: {
		(EtoyUpdatingThreePhaseButtonMorph checkBox)
			target: self;
			actionSelector: #toggleChoice:;
			arguments: {'group'};
			getSelector: #getChoice:;
			setBalloonText: 'Changes between group mode and individuals';
			step
	}) hResizing: #shrinkWrap
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 09:21'!
handlesMouseDown: globalEvt

	| localCursorPoint |
	localCursorPoint _ self globalPointToLocal: globalEvt cursorPoint.
	groupMode ifFalse: [
		self allMorphsDo: [ :each |
			(each isKindOf: EToySenderMorph) ifTrue: [
				(each bounds containsPoint: localCursorPoint) ifTrue: [^false].
			].
		].
	].
	^true! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:47'!
handlesMouseOver: globalEvt

	^true! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:51'!
handlesMouseOverDragging: globalEvt

	^true! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:53'!
initialize

	super initialize.
	groupMode _ true.
	color _ Color paleRed.
	self listDirection: #topToBottom.
	self layoutInset: 10.
	borderColor _ #raised.
	borderWidth _ 4.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self setProperty: #normalBorderColor toValue: borderColor.
	self setProperty: #flashingColors toValue: {Color red. Color yellow}.
	self rebuild.
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:55'!
mouseDown: localEvt

	self addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:51'!
mouseEnter: evt

	^self mouseEnterEither: evt
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:51'!
mouseEnterDragging: evt

	^self mouseEnterEither: evt
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:51'!
mouseEnterEither: evt

	evt hand hasSubmorphs ifFalse: [
		^self addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).
	].
	(evt hand firstSubmorph isKindOf: EToySenderMorph) ifTrue: [
		^self addMouseActionIndicatorsWidth: 10 color: (Color magenta alpha: 0.3).
	].
	self addMouseActionIndicatorsWidth: 10 color: (Color green alpha: 0.3).

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:53'!
mouseLeave: evt

	^self mouseLeaveEither: evt
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:54'!
mouseLeaveDragging: evt

	^self mouseLeaveEither: evt
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:53'!
mouseLeaveEither: evt

	self deleteAnyMouseActionIndicators.

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:55'!
mouseUp: localEvt

	(self containsPoint: localEvt cursorPoint) ifFalse: [^self].
	Project enterIfThereOrFind: 'Fridge'! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 11:05'!
noteRemovalOf: aSenderMorph

	self class removeRecipientWithIPAddress: aSenderMorph ipAddress! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:35'!
rebuild

	| row filler fudge people maxPerRow |

	updateCounter _ self class updateCounter.
	self removeAllMorphs.
	(self addARow: {
		filler _ Morph new color: Color transparent; extent: 4@4.
	}) vResizing: #shrinkWrap.
	self addARow: {
		(StringMorph contents: 'the Fridge') lock.
		self groupToggleButton.
	}.
	row _ self addARow: {}.
	people _ self class fridgeRecipients.
	maxPerRow _ people size < 7 ifTrue: [2] ifFalse: [3].	
		"how big can this get before we need a different approach?"
	people do: [ :each |
		row submorphCount >= maxPerRow ifTrue: [row _ self addARow: {}].
		row addMorphBack: (
			groupMode ifTrue: [
				(each userPicture scaledToSize: 35@35) asMorph lock
			] ifFalse: [
				each veryDeepCopy killExistingChat
			]
		)
	].
	fullBounds _ nil.
	self fullBounds.
	"htsBefore _ submorphs collect: [ :each | each height]."

	fudge _ 20.
	filler extent: 4 @ (self height - filler height * 0.37 - self layoutInset - borderWidth - fudge) truncated.

	"self fixLayout.
	htsAfter _ submorphs collect: [ :each | each height].
	{htsBefore. htsAfter} explore."

! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 12:31'!
step

	super step.
	updateCounter = self class updateCounter ifFalse: [self rebuild].
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 12:50'!
toggleChoice: aString

	updateCounter _ nil.		"force rebuild"
	aString = 'group' ifTrue: [^groupMode _ (groupMode ifNil: [true]) not].
! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:50'!
transmittedObjectCategory

	^EToyIncomingMessage typeFridge! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 10:16'!
trulyFlashIndicator: aSymbol

	| state |

	state _ (self 
		valueOfProperty: #fridgeFlashingState
		ifAbsent: [false]) not.
	self setProperty: #fridgeFlashingState toValue: state.

	self 
		addMouseActionIndicatorsWidth: 15 
		color: (Color green alpha: (state ifTrue: [0.3] ifFalse: [0.7])). 1 beep.
	"self world displayWorldSafely."! !

!EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 15:53'!
wantsDroppedMorph: aMorph event: evt

	^true! !


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

EToyFridgeMorph class
	instanceVariableNames: ''!

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 12:19'!
addRecipient: aSenderMorph

	self fridgeRecipients do: [ :each |
		aSenderMorph ipAddress = each ipAddress ifTrue: [^self]
	].
	self fridgeRecipients add: aSenderMorph.
	UpdateCounter _ self updateCounter + 1
! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 12:09'!
fridgeForm

	| fridgeFileName |

	fridgeFileName _ 'fridge.form'.
	TheFridgeForm ifNotNil: [^TheFridgeForm].
	(FileDirectory default fileExists: fridgeFileName) ifFalse: [^nil].
	^TheFridgeForm _ Form fromFileNamed: fridgeFileName.! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 19:23'!
fridgeRecipients

	^FridgeRecipients ifNil: [FridgeRecipients _ OrderedCollection new]! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:55'!
newItem: newMorph

	| theFridge fridgeWorld trialRect |

	theFridge _ Project named: 'Fridge'.
	theFridge ifNil: [^self newItems add: newMorph].
	fridgeWorld _ theFridge world.
	trialRect _ fridgeWorld randomBoundsFor: newMorph.
	fridgeWorld 
		addMorphFront: (newMorph position: trialRect topLeft);
		startSteppingSubmorphsOf: newMorph
! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 19:19'!
newItems

	^NewItems ifNil: [NewItems _ OrderedCollection new]! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 11:04'!
removeRecipientWithIPAddress: ipString

	FridgeRecipients _ self fridgeRecipients reject: [ :each |
		ipString = each ipAddress
	].
	UpdateCounter _ self updateCounter + 1
! !

!EToyFridgeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 19:22'!
updateCounter

	^UpdateCounter ifNil: [0]! !
MorphicModel subclass: #EToyGateKeeperEntry
	instanceVariableNames: 'ipAddress accessAttempts lastTimes acceptableTypes latestUserName attempsDenied lastRequests '
	classVariableNames: 'KnownIPAddresses '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:42'!
acceptableTypes

	^acceptableTypes! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:11'!
dateAndTimeStringFrom: totalSeconds

	| dateAndTime |
	dateAndTime _ Time dateAndTimeFromSeconds: totalSeconds.
	^dateAndTime first printString,' ',dateAndTime second printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:51'!
fullInfoString

	^self latestUserName,
		' at ',
		ipAddress ,
		' attempts: ',
		accessAttempts printString,
		'/',
		attempsDenied printString,
		' last: ',
		(self lastIncomingMessageTimeString)
	 
"acceptableTypes"

 ! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 12:19'!
getChoice: aString

	^acceptableTypes includes: aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:49'!
initialize

	self flag: #bob.		"need to decide better initial types"

	super initialize.
	ipAddress _ '???'.
	accessAttempts _ attempsDenied _ 0.
	lastRequests _ OrderedCollection new.
	acceptableTypes _ Set withAll: EToyIncomingMessage allTypes.

 ! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:33'!
ipAddress

	^ipAddress! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:18'!
ipAddress: aString

	ipAddress _ aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:37'!
lastIncomingMessageTimeString

	lastRequests isEmpty ifTrue: [^'never'].
	^self dateAndTimeStringFrom: lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:56'!
lastTimeChecked

	^self valueOfProperty: #lastTimeChecked
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:57'!
lastTimeChecked: aDateAndTimeInSeconds

	self setProperty: #lastTimeChecked toValue: aDateAndTimeInSeconds
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:22'!
lastTimeCheckedString

	| statusTime |
	statusTime _ self valueOfProperty: #lastTimeChecked ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime)! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:49'!
latestUserName

	^latestUserName ifNil: ['???']! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:46'!
latestUserName: aString

	latestUserName _ aString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:09'!
requestAccessOfType: aString

	| ok |

	accessAttempts _ accessAttempts + 1.
	lastRequests addFirst: {Time totalSeconds. aString}.
	lastRequests size > 10 ifTrue: [
		lastRequests _ lastRequests copyFrom: 1 to: 10.
	].
	ok _ (acceptableTypes includes: aString) or: [acceptableTypes includes: 'all'].
	ok ifFalse: [attempsDenied _ attempsDenied + 1].
	^ok! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:10'!
statusReplyReceived: anArray

	self setProperty: #lastStatusReplyTime toValue: Time totalSeconds.
	self setProperty: #lastStatusReply toValue: anArray.! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 14:16'!
statusReplyReceivedString

	| statusTime |
	statusTime _ self valueOfProperty: #lastStatusReplyTime ifAbsent: [^'none'].
	^(self dateAndTimeStringFrom: statusTime),' accepts:
', (self valueOfProperty: #lastStatusReply) asArray printString! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:38'!
timeBetweenLastAccessAnd: currentTime

	lastRequests isEmpty ifTrue: [^0].
	^currentTime - lastRequests first first
! !

!EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:39'!
toggleChoice: aString

	(acceptableTypes includes: aString) ifTrue: [
		acceptableTypes remove: aString ifAbsent: []
	] ifFalse: [
		acceptableTypes add: aString
	].! !

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

EToyGateKeeperEntry class
	instanceVariableNames: ''!

!EToyGateKeeperEntry class methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
EToyCommunicatorMorph subclass: #EToyGateKeeperMorph
	instanceVariableNames: 'counter '
	classVariableNames: 'KnownIPAddresses UpdateCounter '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyGateKeeperMorph commentStamp: '<historical>' prior: 0!
EToyGateKeeperMorph new open

"
I am used to control the types of connections a user is willing to allow.
"!
]style[(28 79)f4cblue;,f1!


!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:53'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	color _ Color lightGray.
	self layoutInset: 4.
	borderColor _ #raised "Color brown".
	borderWidth _ 4.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	self useRoundedCorners.

	self rebuild.
	! !

!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:29'!
open

	self rebuild.
	self openInWorld.! !

!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:27'!
rebuild

	self removeAllMorphs.
	self addGateKeeperMorphs.
! !

!EToyGateKeeperMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:28'!
step

	(self valueOfProperty: #gateKeeperCounterValue) = 
			EToyGateKeeperMorph updateCounter ifTrue: [^self].
	self rebuild.
! !

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

EToyGateKeeperMorph class
	instanceVariableNames: ''!

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 11:06'!
acceptRequest: requestType from: senderName at: ipAddressString

	| entry |

	UpdateCounter _ self updateCounter + 1.
	entry _ self entryForIPAddress: ipAddressString.
	senderName isEmpty ifFalse: [entry latestUserName: senderName].
	^entry requestAccessOfType: requestType! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:43'!
acceptableTypesFor: ipAddressString

	^(self knownIPAddresses at: ipAddressString ifAbsent: [^#()]) acceptableTypes! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:13'!
entryForIPAddress: ipAddressString

	| known entry |

	UpdateCounter _ self updateCounter + 1.
	known _ self knownIPAddresses.
	entry _ known at: ipAddressString ifAbsentPut: [
		entry _ EToyGateKeeperEntry new.
		entry ipAddress: ipAddressString.
		entry
	].
	^entry! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/2000 07:48'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 08:42'!
knownIPAddresses

	^KnownIPAddresses ifNil: [KnownIPAddresses _ Dictionary new]! !

!EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:28'!
updateCounter

	^UpdateCounter ifNil: [UpdateCounter _ 0]! !
AlignmentMorphBob1 subclass: #EToyGenericDialogMorph
	instanceVariableNames: 'namedFields '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 10:17'!
genericTextFieldNamed: aString

	| newField |

	newField _ TextMorph new
		beAllFont: self myFont;
		extent: 300@20;
		contentsWrapped: ''.
	namedFields at: aString put: newField.
	^newField
! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 10:20'!
inAColumnForText: someMorphs

	^(self inAColumn: someMorphs)
		hResizing: #shrinkWrap; 
		color: Color white; 
		borderColor: Color black; 
		borderWidth: 1
! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 10:15'!
initialize

	namedFields _ Dictionary new.
	super initialize.
	self rebuild.
! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 10:20'!
lockedString: aString

	^self inAColumn: {(StringMorph contents: aString font: self myFont) lock}.
! !

!EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 10:16'!
myFont

	^TextStyle default fontOfSize: 12! !
AbstractHierarchicalList subclass: #EToyHierarchicalTextGizmo
	instanceVariableNames: 'topNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!
!EToyHierarchicalTextGizmo commentStamp: '<historical>' prior: 0!
EToyHierarchicalTextGizmo example!


!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:53'!
addChild

	self addNewChildAfter: nil.
! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:52'!
addNewChildAfter: aNodeOrNil

	currentSelection addNewChildAfter: aNodeOrNil.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:41'!
addSibling

	currentSelection addSibling.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:29'!
deleteSelectedItem

	currentSelection delete.
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:57'!
expandAllBelow

	currentSelection withoutListWrapper withAllChildrenDo: [ :each |
		each setProperty: #showInOpenedState toValue: true
	].
	self changed: #getList.! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:57'!
genericMenu: aMenu

	| menu |

	currentSelection ifNil: [
		aMenu add: '*nothing selected*' target: self selector: #yourself.
		^aMenu
	].
	menu _ DumberMenuMorph new defaultTarget: self.
	menu 
		add: 'expand all below me' target: self selector: #expandAllBelow;
		add: 'addChild' target: self selector: #addChild;
		add: 'delete' target: self  selector: #deleteSelectedItem.
	^ menu! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:50'!
getList

	^Array with: (EToyTextNodeWrapper with: topNode model: self parent: nil)
! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:36'!
inAWindow
	| window  |

	window _ (SystemWindow labelled: 'HText') model: self.
	window 
		addMorph: self notInAWindow
		frame: (0@0 corner: 1@1).
     ^ window! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:43'!
notInAWindow
	| listMorph |

	(listMorph _ EToyHierarchicalTextMorph 
		on: self
		list: #getList
		selected: #getCurrentSelection
		changeSelected: #noteNewSelection:
		menu: #genericMenu:
		keystroke: nil).
	listMorph autoDeselect: false.
     ^ listMorph! !

!EToyHierarchicalTextGizmo methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 00:40'!
topNode: aTextNode

	topNode _ aTextNode! !


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

EToyHierarchicalTextGizmo class
	instanceVariableNames: ''!

!EToyHierarchicalTextGizmo class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:28'!
example
"
EToyHierarchicalTextGizmo example
"

	(EToyHierarchicalTextGizmo new 
		topNode: EToyTextNode newNode;
		notInAWindow) openInWorld! !
SimpleHierarchicalListMorph subclass: #EToyHierarchicalTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 02:08'!
adjustSubmorphPositions

	| p h w |

	p _ 0@0.
	w _ self width.
	scroller submorphsDo: [ :each |
		h _ each position: p andWidth: w.
		p _ p + (0@h)
	].
	self 
		changed;
		layoutChanged;
		setScrollDeltas.
! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 01:50'!
extent: aPoint

	| wasDifferent |
	wasDifferent _ self extent ~= aPoint.
	super extent: aPoint.
	wasDifferent ifTrue: [self adjustSubmorphPositions].! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 22:20'!
indentingItemClass

	^IndentingListParagraphMorph! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:27'!
initialize

	super initialize.
	color _ Color white.
	self useRoundedCorners.
! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 15:05'!
keyStroke: evt

	selectedMorph ifNil: [^self].
	selectedMorph keyStroke: evt
! !

!EToyHierarchicalTextMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:05'!
selectedMorph: aMorph

	selectedMorph == aMorph ifTrue: [^self].
	self unhighlightSelection.
	selectedMorph _ aMorph.
	self highlightSelection! !

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

EToyHierarchicalTextMorph class
	instanceVariableNames: ''!

!EToyHierarchicalTextMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:34'!
new

	| listMorph model |

	model _ EToyHierarchicalTextGizmo new 
		topNode: EToyTextNode newNode.
	(listMorph _ EToyHierarchicalTextMorph 
		on: model
		list: #getList
		selected: #getCurrentSelection
		changeSelected: #noteNewSelection:
		menu: #genericMenu:
		keystroke: nil).
	listMorph autoDeselect: false.
     ^ listMorph! !

!EToyHierarchicalTextMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:32'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self basicNew initialize
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
Object subclass: #EToyIncomingMessage
	instanceVariableNames: ''
	classVariableNames: 'MessageHandlers MessageTypes '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyIncomingMessage methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:22'!
incomingMessgage: dataStream fromIPAddress: ipAddress

	| nullChar messageType senderName  selectorAndReceiver |

	nullChar _ 0 asCharacter.
	messageType _ dataStream upTo: nullChar.
	senderName _ dataStream upTo: nullChar.
	(EToyGateKeeperMorph acceptRequest: messageType from: senderName at: ipAddress) ifFalse: [
		^self
	].
	selectorAndReceiver _ self class messageHandlers at: messageType ifAbsent: [^self].
	^selectorAndReceiver second 
		perform: selectorAndReceiver first 
		withArguments: {dataStream. senderName. ipAddress}

! !


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

EToyIncomingMessage class
	instanceVariableNames: ''!

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:21'!
forType: aMessageType send: aSymbol to: anObject

	self messageHandlers at: aMessageType put: {aSymbol. anObject}! !

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 07:52'!
initializeMessageHandlers

	self
		forType: self typeMorph 
		send: #handleNewMorphFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeFridge 
		send: #handleNewFridgeMorphFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeKeyboardChat 
		send: #handleNewChatFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeMultiChat 
		send: #handleNewMultiChatFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeStatusRequest 
		send: #handleNewStatusRequestFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeStatusReply 
		send: #handleNewStatusReplyFrom:sentBy:ipAddress: 
		to: self;

		forType: self typeSeeDesktop 
		send: #handleNewSeeDesktopFrom:sentBy:ipAddress: 
		to: self.


! !

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:35'!
messageHandlers

	^MessageHandlers ifNil: [MessageHandlers _ Dictionary new].! !

!EToyIncomingMessage class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 13:36'!
newObjectFromStream: dataStream

	| newObject |

	[newObject _ SmartRefStream objectFromStreamedRepresentation: dataStream upToEnd.]
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				"self flashIndicator: #working."
			].
		].
	"self resetIndicator: #working."
	^newObject
! !


!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:32'!
handleNewChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: (self newObjectFromStream: dataStream).
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:33'!
handleNewFridgeMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| newObject |

	newObject _ self newObjectFromStream: dataStream.
	newObject
		setProperty: #fridgeSender toValue: senderName;
		setProperty: #fridgeIPAddress toValue: ipAddressString;
		setProperty: #fridgeDate toValue: Time dateAndTimeNow.
	WorldState addDeferredUIMessage: [EToyFridgeMorph newItem: newObject] fixTemps.
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/16/2000 12:26'!
handleNewMorphFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	| newObject thumbForm targetWorld |

	newObject _ self newObjectFromStream: dataStream.
	EToyCommunicatorMorph playArrivalSound.
	targetWorld _ self currentWorld.
	(EToyMorphsWelcomeMorph morphsWelcomeInWorld: targetWorld) ifTrue: [
		newObject position: (
			newObject 
				valueOfProperty: #positionInOriginatingWorld 
				ifAbsent: [(targetWorld randomBoundsFor: newObject) topLeft]
		).
		WorldState addDeferredUIMessage: [
			newObject openInWorld: targetWorld.
		] fixTemps.
		^self
	].
	thumbForm _ newObject imageForm scaledToSize: 50@50.
	EToyListenerMorph addToGlobalIncomingQueue: {
		thumbForm. newObject. senderName. ipAddressString
	}.
	WorldState addDeferredUIMessage: [
		EToyListenerMorph ensureListenerInCurrentWorld
	] fixTemps.
! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/17/2000 09:22'!
handleNewMultiChatFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	^ EToyMultiChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: (self newObjectFromStream: dataStream).
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewSeeDesktopFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	"more later"

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: ipAddressString,' would like to see your desktop'.
	! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewStatusReplyFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	(EToyGateKeeperMorph entryForIPAddress: ipAddressString) statusReplyReceived: (
		self newObjectFromStream: dataStream
	)
! !

!EToyIncomingMessage class methodsFor: 'handlers' stamp: 'RAA 8/4/2000 13:34'!
handleNewStatusRequestFrom: dataStream sentBy: senderName ipAddress: ipAddressString

	"more later"

	^ EToyChatMorph 
		chatFrom: ipAddressString 
		name: senderName 
		text: ipAddressString,' would like to know if you are available'.
	! !


!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 11/13/2000 14:39'!
allTypes

	^MessageTypes ifNil: [
		MessageTypes _ {
			self typeKeyboardChat.
			self typeMorph.
			self typeFridge.
			self typeStatusRequest.
			self typeStatusReply.
			self typeSeeDesktop.
			self typeAudioChat.
			self typeAudioChatContinuous.
			self typeMultiChat.
		}
	]
! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 11/13/2000 14:39'!
registerType: aMessageType

	MessageTypes _ self allTypes copyWith: aMessageType! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 13:20'!
typeAudioChat

	^'audiochat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/5/2000 19:21'!
typeAudioChatContinuous

	^'audiochat2'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:49'!
typeFridge

	^'fridge'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:46'!
typeKeyboardChat

	^'chat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:59'!
typeMorph

	^'morph'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/17/2000 07:41'!
typeMultiChat

	^'multichat'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:56'!
typeSeeDesktop

	^'seedesktop'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:53'!
typeStatusReply

	^'statusreply'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 8/4/2000 11:51'!
typeStatusRequest

	^'statusrequest'! !

!EToyIncomingMessage class methodsFor: 'message types' stamp: 'RAA 11/13/2000 14:39'!
unregisterType: aMessageType

	MessageTypes _ self allTypes copyWithout: aMessageType! !
EToyCommunicatorMorph subclass: #EToyListenerMorph
	instanceVariableNames: 'listener updateCounter '
	classVariableNames: 'GlobalIncomingQueue GlobalListener QueueSemaphore UpdateCounter WasListeningAtShutdown '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyListenerMorph commentStamp: '<historical>' prior: 0!
EToyListenerMorph new open
EToyListenerMorph startListening.
EToyListenerMorph stopListening.

"
EToyListenerMorph listens for messgaes from other EToy communicators. You need one of these open to receive messages from elsewhere.
- Received Morphs are shown in a list. Items can be grabbed (a copy) or deleted.
- Chat messages are sent to an appropriate EToyChatMorph (created if necessary)
"

!
]style[(45 16 18 15 1 299)cblue;f3,bf3,cblue;f3,bf3,cblue;f3,f1!


!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:17'!
addNewObject: newObject thumbForm: aForm sentBy: senderName ipAddress: ipAddressString

	| thumb row |

	thumb _ aForm asMorph.
	thumb setProperty: #depictedObject toValue: newObject.
	row _ self addARow: {
		thumb. 
		self inAColumn: {
			StringMorph new contents: senderName; lock.
			StringMorph new contents: ipAddressString; lock.
		}
	}.
	row on: #mouseDown send: #mouseDownEvent:for: to: self.

! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 10:44'!
delete

	listener ifNotNil: [listener stopListening. listener _ nil].	
					"for old instances that were locally listening"
	super delete.! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:53'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	color _ Color lightBlue.
	self layoutInset: 4.
	borderColor _ Color blue.
	borderWidth _ 4.
	self rebuild.
! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:48'!
mouseDownEvent: event for: aMorph

	| menu selection depictedObject |

	depictedObject _ aMorph firstSubmorph valueOfProperty: #depictedObject.
	menu _ CustomMenu new.
	menu 
		add: 'Grab' 
		action: [
			event hand attachMorph: depictedObject veryDeepCopy
		];
		add: 'Delete' 
		action: [
			self class removeFromGlobalIncomingQueue: depictedObject.
			self rebuild.
		].
	selection _ menu build startUpCenteredWithCaption: 'Morph from ',
					(aMorph submorphs at: 2) firstSubmorph contents.
	selection ifNil: [^self].
	selection value.
! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:49'!
rebuild

	| earMorph |
	updateCounter _ UpdateCounter.
	self removeAllMorphs.
	self addGateKeeperMorphs.
	GlobalListener ifNil: [
		earMorph _ (self class makeListeningToggle: false) asMorph.
		earMorph setBalloonText: 'Click to START listening for messages'.
		earMorph on: #mouseUp send: #startListening to: self.
	] ifNotNil: [
		earMorph _ (self class makeListeningToggle: true) asMorph.
		earMorph setBalloonText: 'Click to STOP listening for messages'.
		earMorph on: #mouseUp send: #stopListening to: self.
	].
	self addARow: {self inAColumn: {earMorph}}.
	self
		addARow: {
			self inAColumn: {(StringMorph contents: 'Incoming communications') lock}.
			self indicatorFieldNamed: #working color: Color blue help: 'working'.
			self indicatorFieldNamed: #communicating color: Color green help: 'receiving'.
		}.
	"{thumbForm. newObject. senderName. ipAddressString}"
	self class globalIncomingQueueCopy do: [ :each |
		self
			addNewObject: each second 
			thumbForm: each first 
			sentBy: each third 
			ipAddress: each fourth.
	].! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:23'!
startListening

	self class startListening! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:49'!
step

	| needRebuild |
	super step.
	needRebuild _ false.
	(self valueOfProperty: #gateKeeperCounterValue) = 
			EToyGateKeeperMorph updateCounter ifFalse: [needRebuild _ true].
	updateCounter = UpdateCounter ifFalse: [
		needRebuild _ true.
	].
	needRebuild ifTrue: [self rebuild].
! !

!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:23'!
stopListening

	self class stopListening! !

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

EToyListenerMorph class
	instanceVariableNames: ''!

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:24'!
addToGlobalIncomingQueue: aMorphTuple

	self critical: [
		self globalIncomingQueue add: aMorphTuple.
		self bumpUpdateCounter.
	].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:23'!
bumpUpdateCounter

	UpdateCounter _ (UpdateCounter ifNil: [0]) + 1.
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/6/2000 11:48'!
commResult: anArrayOfAssociations

	WorldState addDeferredUIMessage: [self commResultDeferred: anArrayOfAssociations].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/6/2000 11:49'!
commResultDeferred: anArrayOfAssociations

	| m ipAddress aDictionary |

	"to be run as part of the UI process in case user interaction is required"

	aDictionary _ Dictionary new.
	anArrayOfAssociations do: [ :each | aDictionary add: each].
	
	aDictionary at: #commFlash ifPresent: [ :ignore | ^self].
	m _ aDictionary at: #message ifAbsent: [^self].
	m = 'OK' ifFalse: [^self].
	ipAddress _ NetNameResolver stringFromAddress: (aDictionary at: #ipAddress).

	EToyIncomingMessage new 
		incomingMessgage: (ReadStream on: (aDictionary at: #data)) 
		fromIPAddress: ipAddress

	! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 18:05'!
confirmListening

	self isListening ifFalse: [
		(self confirm: 'You currently are not listening and will not hear a reply.
Shall I start listening for you?') ifTrue: [
			self startListening
		].
	].
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:11'!
critical: aBlock

	QueueSemaphore ifNil: [QueueSemaphore _ Semaphore forMutualExclusion].
	^QueueSemaphore critical: aBlock
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:04'!
ensureListenerInCurrentWorld

	| w |
	w _ self currentWorld.
	EToyListenerMorph allInstances 
		detect: [ :each | each world == w]
		ifNone: [EToyListenerMorph new open]! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 12:46'!
flashIndicator: ignoredForNow! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:12'!
globalIncomingQueue

	^GlobalIncomingQueue ifNil: [GlobalIncomingQueue _ OrderedCollection new].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 14:13'!
globalIncomingQueueCopy

	^self critical: [self globalIncomingQueue copy].
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 16:28'!
initialize
"
EToyListenerMorph initialize
"
	
	Smalltalk addToStartUpList: self.
	Smalltalk addToShutDownList: self.
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/9/2000 17:56'!
isListening

	^GlobalListener notNil
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/19/2000 18:59'!
makeListeningToggle: withEars

	| background c capExtent bgExtent earExtent earDeltaX earDeltaY botCent factor parts |

	factor _ 2.
	bgExtent _ (50@25) * factor.
	capExtent _ (30@30) * factor.
	earExtent _ (15@15) * factor.
	earDeltaX _ capExtent x // 2.
	earDeltaY _ capExtent y // 2.
	background _ Form extent: bgExtent depth: 8.
	botCent _ background boundingBox bottomCenter.
	c _ background getCanvas.
	"c fillColor: Color white."
	parts _ {
		(botCent - (capExtent // 2)) extent: capExtent.
	}.
	withEars ifTrue: [
		parts _ parts , {
			(botCent - (earDeltaX @ earDeltaY) - (earExtent // 2)) extent: earExtent.
			(botCent - (earDeltaX negated @ earDeltaY) - (earExtent // 2)) extent: earExtent.
		} 
	].
	parts do: [ :each |
		c
			fillOval: each
			color: Color black 
			borderWidth: 0 
			borderColor: Color black.
	].
	^background

"=====
	f2 _ Form extent: 30@15 depth: 8.
	background displayInterpolatedOn: f2.
	f2 replaceColor: Color white withColor: Color transparent.
	^f2
====="


	! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:24'!
removeFromGlobalIncomingQueue: theActualObject

	self critical: [
		GlobalIncomingQueue _ self globalIncomingQueue reject: [ :each | 
			each second == theActualObject
		].
		self bumpUpdateCounter.
	].! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 12:47'!
resetIndicator: ignoredForNow! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 16:26'!
shutDown: quitting

	WasListeningAtShutdown _ GlobalListener notNil.
	self stopListening.
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:24'!
startListening

	self stopListening.
	GlobalListener _ EToyPeerToPeer new awaitDataFor: self.
	self bumpUpdateCounter.

! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 16:27'!
startUp: resuming

	WasListeningAtShutdown == true ifTrue: [
		self startListening.
	].
! !

!EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 18:24'!
stopListening

	GlobalListener ifNotNil: [
		GlobalListener stopListening.
		GlobalListener _ nil.
		self bumpUpdateCounter.
	].
! !
EToyCommunicatorMorph subclass: #EToyMorphsWelcomeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyMorphsWelcomeMorph commentStamp: '<historical>' prior: 0!
EToyMorphsWelcomeMorph new openInWorld!


!EToyMorphsWelcomeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:40'!
initialize

	| earMorph |
	super initialize.
	color _ Color yellow.
	earMorph _ (EToyListenerMorph makeListeningToggle: true) asMorph.
	earMorph setBalloonText: 'My presence in this world means received morphs may appear automatically'.
	self addARow: {earMorph}.

! !

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

EToyMorphsWelcomeMorph class
	instanceVariableNames: ''!

!EToyMorphsWelcomeMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 13:44'!
morphsWelcomeInWorld: aWorld

	^self allInstances anySatisfy: [ :each | each world == aWorld]! !
EToyChatMorph subclass: #EToyMultiChatMorph
	instanceVariableNames: 'targetIPAddresses '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 19:24'!
acceptDroppingMorph: morphToDrop event: evt

	(morphToDrop isKindOf: EToySenderMorph) ifFalse: [
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"
	self updateIPAddressField: targetIPAddresses,{morphToDrop ipAddress}.

! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/5/2000 14:15'!
acceptTo: someText forMorph: aMorph

	| streamedMessage betterText |

	betterText _ self improveText: someText forMorph: aMorph.
	streamedMessage _ {targetIPAddresses. betterText} eToyStreamedRepresentationNotifying: self.
	targetIPAddresses do: [ :each |
		self 
			transmitStreamedObject: streamedMessage
			to: each.
	].
	aMorph setText: '' asText.
	self appendMessage: 
		self startOfMessageFromMe,
		' - ',
		betterText,
		String cr.

	^true! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:01'!
chatFrom: ipAddress name: senderName text: textPackage

	super chatFrom: ipAddress name: senderName text: textPackage second.
	self updateIPAddressField: (
		targetIPAddresses,textPackage first,{ipAddress} 
			copyWithout: NetNameResolver localAddressString
	).
! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:01'!
editEvent: anEvent for: aMorph

	| answer initialText aFillInTheBlankMorph |

	(aMorph bounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	initialText _ String streamContents: [ :strm |
		targetIPAddresses do: [ :each | strm nextPutAll: each; cr].
	].
	aFillInTheBlankMorph _ FillInTheBlankMorph new
		setQuery: 'Who are you chatting with?'
		initialAnswer: initialText
		answerHeight: 250
		acceptOnCR: false.
	aFillInTheBlankMorph responseUponCancel: nil.
	self world addMorph: aFillInTheBlankMorph centeredNear: anEvent cursorPoint.
	answer _ aFillInTheBlankMorph getUserResponse.
	answer ifNil: [^self].
	self updateIPAddressField: (answer findTokens: ' ',String cr).

! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:57'!
initialize

	targetIPAddresses _ OrderedCollection new.
	super initialize.
	bounds _ 0@0 extent: 350@350.! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:20'!
rebuild
	| r1 r2 |

	r1 _ self addARow: {
		self simpleToggleButtonFor: self attribute: #acceptOnCR help: 'Send with Return?'.
		self inAColumn: {StringMorph new contents: 'Multi chat with:'; lock}.
		self textEntryFieldNamed: #ipAddress with: ''
					help: 'Click to edit participant list'.
	}.
	sendingPane _ PluggableTextMorph
				on: self
				text: nil
				accept: #acceptTo:forMorph:.
	sendingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: sendingPane.
	r2 _ self addARow: {self inAColumn: {StringMorph new contents: 'Replies'; lock}}.
	receivingPane _ PluggableTextMorph
				on: self
				text: nil
				accept: nil.
	receivingPane hResizing: #spaceFill; vResizing: #spaceFill.
	self
		addMorphBack: receivingPane.
	receivingPane spaceFillWeight: 3.
	{r1. r2} do: [ :each |
		each
			vResizing: #shrinkWrap; minHeight: 18;
			color: Color veryLightGray.
	].
	self updateIPAddressField: targetIPAddresses.
	sendingPane acceptOnCR: (acceptOnCR ifNil: [acceptOnCR _ true]).! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:53'!
standardBorderColor

	^Color veryLightGray! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 07:44'!
transmittedObjectCategory

	^EToyIncomingMessage typeMultiChat! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:01'!
updateIPAddressField: newAddresses
	
	targetIPAddresses _ (
		newAddresses copyWithout: NetNameResolver localAddressString
	) 
		asSet 
		asSortedCollection 
		asArray.

	(fields at: #ipAddress) contents: targetIPAddresses size printString,' people'.! !

!EToyMultiChatMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 09:04'!
wantsDroppedMorph: aMorph event: evt

	(aMorph isKindOf: EToySenderMorph) ifFalse: [^false].
	(bounds containsPoint: evt cursorPoint) ifFalse: [^false].
	^true.! !

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

EToyMultiChatMorph class
	instanceVariableNames: ''!

!EToyMultiChatMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 08:53'!
chatWindowForIP: ipAddress name: senderName picture: aForm inWorld: aWorld

	^self allInstances 
		detect: [ :x | x world == aWorld] 
		ifNone: [
			EToyCommunicatorMorph playArrivalSound.
			self new open
		].

! !
Object subclass: #EToyPeerToPeer
	instanceVariableNames: 'socket communicatorMorph process ipAddress connectionQueue dataQueue remoteSocketAddress leftOverData '
	classVariableNames: 'DEBUG PREVTICK '
	poolDictionaries: ''
	category: 'Network-EToy Communications'!


!EToyPeerToPeer methodsFor: 'sending' stamp: 'RAA 8/6/2000 09:29'!
doConnectForSend

	| addr |

	addr _ NetNameResolver addressForName: ipAddress.
	addr ifNil: [
		communicatorMorph commResult: {#message -> ('could not find ',ipAddress)}.
		^false
	].
	socket connectTo: addr port: self class eToyCommunicationsPort.
	(socket waitForConnectionUntil: (Socket deadlineSecs: 15)) ifFalse: [
		communicatorMorph commResult: {#message -> ('no connection to ',ipAddress,' (',
				(NetNameResolver stringFromAddress: addr),')')}.
		^false
	].
	^true

! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'RAA 8/12/2000 14:28'!
doSendData

	| totalLength myData allTheData |

	myData _ dataQueue next ifNil: [socket sendData: '0 '. ^false].
	totalLength _ (myData collect: [ :x | x size]) sum.
	socket sendData: totalLength printString,' '.
	allTheData _ WriteStream on: (String new: totalLength).
	myData do: [ :chunk | allTheData nextPutAll: chunk asString].
	NebraskaDebug at: #peerBytesSent add: {totalLength}.
	self sendDataCautiously: allTheData contents.
	^true

! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'RAA 8/9/2000 16:30'!
sendDataCautiously: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"

	| bytesSent bytesToSend count |

	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		count _ socket 
			sendSomeData: aStringOrByteArray 
			startIndex: bytesSent + 1  
			count: (bytesToSend - bytesSent min: 4000).
		bytesSent _ bytesSent + count.
		communicatorMorph commResult: {#commFlash -> true}.
		(Delay forMilliseconds: 10) wait.
	].
	^ bytesSent
! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'RAA 8/6/2000 09:34'!
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph

	dataQueue _ self 
		sendSomeData: arrayOfByteObjects 
		to: anIPAddress 
		for: aCommunicatorMorph 
		multiple: false.
	dataQueue nextPut: nil.		"only this message to send"
! !

!EToyPeerToPeer methodsFor: 'sending' stamp: 'RAA 8/6/2000 09:34'!
sendSomeData: arrayOfByteObjects to: anIPAddress for: aCommunicatorMorph multiple: aBoolean

	Socket initializeNetwork.
	socket _ Socket newTCP.
	dataQueue _ SharedQueue new.
	dataQueue nextPut: arrayOfByteObjects.
	communicatorMorph _ aCommunicatorMorph.
	ipAddress _ anIPAddress.
	process _ [
		self doConnectForSend ifTrue: [
			[self doSendData] whileTrue.
			communicatorMorph commResult: {#message -> 'OK'}.
			socket closeAndDestroy.
		].
	] newProcess.
	process priority: Processor highIOPriority.
	process resume.
	^dataQueue
! !


!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 7/14/2000 23:17'!
awaitDataFor: aCommunicatorMorph

	Socket initializeNetwork.
	connectionQueue _ ConnectionQueue 
		portNumber: self class eToyCommunicationsPort 
		queueLength: 6.
	communicatorMorph _ aCommunicatorMorph.
	process _ [self doAwaitData] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 7/9/2000 14:05'!
doAwaitData

	[true] whileTrue: [
		socket _ connectionQueue getConnectionOrNilLenient.
		socket ifNil: [
			(Delay forMilliseconds: 50) wait
		] ifNotNil: [
			self class new receiveDataOn: socket for: communicatorMorph
		]
	].
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 8/6/2000 10:45'!
doReceiveData

	| answer |

	[answer _ self doReceiveOneMessage] 
		on: Error
		do: [ :ex | 
			communicatorMorph commResult: {#message -> (ex description,' ',socket printString)}.
			^false
		].
	communicatorMorph commResult: {
		#message -> 'OK'. 
		#data -> answer .
		#ipAddress -> remoteSocketAddress.
	}.
	^answer size > 0

! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 8/6/2000 14:29'!
doReceiveOneMessage

	| awaitingLength i length answer |

	awaitingLength _ true.
	answer _ WriteStream on: String new.
	[awaitingLength] whileTrue: [
		leftOverData _ leftOverData,socket getData.
		(i _ leftOverData indexOf: $ ) > 0 ifTrue: [
			awaitingLength _ false.
			length _ (leftOverData first: i - 1) asNumber.
			answer nextPutAll: (leftOverData allButFirst: i).
		].
	].
	leftOverData _ ''.
	[answer size < length] whileTrue: [
		answer nextPutAll: socket getData.
		communicatorMorph commResult: {#commFlash -> true}.
	].
	answer _ answer contents.
	answer size > length ifTrue: [
		leftOverData _ answer allButFirst: length.
		answer _ answer first: length
	].
	^answer

! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 8/6/2000 14:26'!
receiveDataOn: aSocket for: aCommunicatorMorph

	socket _ aSocket.
	remoteSocketAddress _ socket remoteAddress.
	communicatorMorph _ aCommunicatorMorph.
	process _ [
		leftOverData _ ''.
		[self doReceiveData] whileTrue.
		socket closeAndDestroy.
	] newProcess.
	process priority: Processor highIOPriority.
	process resume.
! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'RAA 7/9/2000 08:22'!
stopListening

	process ifNotNil: [process terminate. process _ nil].
	connectionQueue ifNotNil: [connectionQueue destroy. connectionQueue _ nil].

! !

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

EToyPeerToPeer class
	instanceVariableNames: ''!

!EToyPeerToPeer class methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 06:21'!
eToyCommunicationsPort

	^34151		"picked at random"! !

!EToyPeerToPeer class methodsFor: 'as yet unclassified' stamp: 'mir 10/10/2000 12:51'!
transmitStreamedObject: outData as: objectCategory to: anIPAddress for: aCommunicator

	| null |
	null _ String with: 0 asCharacter.
	self new 
		sendSomeData: {
			objectCategory,null. 
			Preferences defaultAuthorName,null.
			outData
		}
		to: anIPAddress
		for: aCommunicator

! !
EToyProjectRenamerMorph subclass: #EToyProjectDetailsMorph
	instanceVariableNames: 'projectDetails '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
copyOutDetails

	| newDetails |

	newDetails _ Dictionary new.
	self fieldToDetailsMappings do: [ :each |
		namedFields at: each first ifPresent: [ :field |
			newDetails at: each second put: field contents string
		].
	].
	namedFields at: 'projectname' ifPresent: [ :field |
		newDetails at: 'projectname' put: field contents string
	].
	^newDetails! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:45'!
doExpand

	self expandedFormat: true.
	self copyOutDetails.
	self rebuild.
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:43'!
doOK

	self validateTheProjectName ifFalse: [^false].
	actionBlock value: self copyOutDetails.
	self delete.! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:43'!
expandButton

	^self
		buttonNamed: 'More' 
		action: #doExpand 
		color: self buttonColor 
		help: 'Show more info on this project.'! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:40'!
expandedFormat

	^self valueOfProperty: #expandedFormat ifAbsent: [false]! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:40'!
expandedFormat: aBoolean

	self setProperty: #expandedFormat toValue: aBoolean! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:33'!
fieldToDetailsMappings

	^#(
		(#description 'projectdescription' 'Description:' 100) 
		(#author 'projectauthor' 'Author:' 20) 
		(#category 'projectcategory' 'Category:' 20)
		(#subCategory 'projectsubcategory' 'Sub-category:' 20)
		(#keywords 'projectkeywords' 'Key words:' 20)
	)
! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
fillInDetails

	theProject ifNotNil: [
		namedFields at: 'projectname' ifPresent: [ :field |
			field contentsWrapped: theProject name
		].
	].
	projectDetails ifNotNil: [
		self fieldToDetailsMappings do: [ :each |
			namedFields at: each first ifPresent: [ :field |
				projectDetails at: each second ifPresent: [ :data |
					field contentsWrapped: data
				].
			].
		].
	].! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:45'!
project: aProject actionBlock: aBlock

	theProject _ aProject.
	actionBlock _ aBlock.
	projectDetails _ theProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 11:08'!
projectDetails: aDictionary

	projectDetails _ aDictionary.! !

!EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 09:42'!
rebuild

	| bottomButtons |
	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Please describe this project'.
	}.
	self addARow: {
		self lockedString: 'Name:'.
		self inAColumnForText: {self fieldForProjectName}
	}.
	self expandedFormat ifTrue: [
		self fieldToDetailsMappings do: [ :each |
			self addARow: {
				self lockedString: each third.
				self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
			}.
		].
	].
	bottomButtons _ self expandedFormat ifTrue: [
		{
			self okButton.
			self cancelButton.
		}
	] ifFalse: [
		{
			self okButton.
			self expandButton.
			self cancelButton.
		}
	].
	self addARow: bottomButtons.
	self fillInDetails.! !

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

EToyProjectDetailsMorph class
	instanceVariableNames: ''!

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 12/24/2000 09:34'!
getFullInfoFor: aProject ifValid: aBlock

	^self 
		getFullInfoFor: aProject 
		ifValid: aBlock 
		expandedFormat: false! !

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 12/24/2000 09:33'!
getFullInfoFor: aProject ifValid: aBlock expandedFormat: expandedFormat

	| me |

	(me _ self basicNew)
		expandedFormat: expandedFormat;
		project: aProject
		actionBlock: [ :x | 
			aProject world setProperty: #ProjectDetails toValue: x.
			x at: 'projectname' ifPresent: [ :newName | 
				newName = aProject name ifFalse: [aProject changeSet name: newName].
			].
			me delete.
			aBlock value.
		];

		initialize;
		openCenteredInWorld! !

!EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:34'!
test1: aProject
"EToyProjectDetailsMorph test1: Project current"

	(self basicNew)
		project: aProject
		actionBlock: [ :x | 
			aProject world setProperty: #ProjectDetails toValue: x.
			x at: 'projectname' ifPresent: [ :newName | 
				newName = aProject name ifFalse: [aProject changeSet name: newName].
			]
		];

		initialize;
		openCenteredInWorld! !
EToyCommunicatorMorph subclass: #EToyProjectHistoryMorph
	instanceVariableNames: 'changeCounter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToyProjectHistoryMorph commentStamp: '<historical>' prior: 0!
EToyProjectHistoryMorph new openInWorld

EToyProjectHistoryMorph provides a quick reference of the most recent projects. Click on one to go there.!
]style[(40 106)f3cblue;,f1!


!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'ar 9/28/2000 13:53'!
closeMyFlapIfAny

	| myFlap allTabs myTab myWorld |

	myWorld _ self world.
	myFlap _ self nearestOwnerThat: [ :each | each isFlap].
	myFlap ifNil: [^self].
	allTabs _ myWorld submorphs select: [ :each | each isFlapTab].
	myTab _ allTabs detect: [ :each | each referent == myFlap] ifNone: [^self].
	myTab hideFlap.
	myWorld displayWorldSafely.
	
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/12/2000 13:24'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	color _ Color lightBrown.
	self layoutInset: 4.
	borderColor _ #raised "Color brown".
	borderWidth _ 4.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self useRoundedCorners.

	self rebuild.
	! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:02'!
jumpToProject

	| selection |
	selection _ (Project buildJumpToMenu: CustomMenu new) startUp.
	self closeMyFlapIfAny.
	Project jumpToSelection: selection
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 07:25'!
mouseDown: evt in: aMorph

	aMorph setProperty: #mouseDownPoint toValue: evt cursorPoint.
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 07:28'!
mouseLeave: evt in: aMorph

	aMorph removeProperty: #mouseDownPoint.! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 22:47'!
mouseMove: evt in: aMorph

	| start tuple project url pvm |
	start _ aMorph valueOfProperty: #mouseDownPoint ifAbsent: [^self].
	(start dist: evt cursorPoint) abs < 5 ifTrue: [^self].
	aMorph removeProperty: #mouseDownPoint.
	evt hand hasSubmorphs ifTrue: [^self].
	tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^self].
	project _ tuple fourth first.
	(project notNil and: [project world notNil]) ifTrue: [
		^evt hand attachMorph: (ProjectViewMorph on: project).
	].
	url _ tuple third.
	url isEmptyOrNil ifTrue: [^self].
	pvm _ ProjectViewMorph new.
	pvm
		project: (DiskProxy global: #Project selector: #namedUrl: args: {url});
		lastProjectThumbnail: tuple second.
	evt hand attachMorph: pvm.
! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:04'!
mouseUp: evt in: aMorph

	| tuple project url |

	(aMorph boundsInWorld containsPoint: evt cursorPoint) ifFalse: [^self].
	tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^1 beep].
	project _ tuple fourth first.
	(project notNil and: [project world notNil]) ifTrue: [self closeMyFlapIfAny. ^project enter].
	url _ tuple third.
	url isEmptyOrNil ifTrue: [^1 beep].
	self closeMyFlapIfAny.
	ProjectLoading thumbnailFromUrl: url.

"---
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
---"! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/13/2000 07:46'!
rebuild

	| history r1 |
	changeCounter _ ProjectHistory changeCounter.
	history _ ProjectHistory currentHistory mostRecentCopy.
	self removeAllMorphs.
	self rubberBandCells: false. "enable growing"
	r1 _ self addARow: {
		self inAColumn: {
			StringMorph new contents: 'Jump...'; lock.
		}.
	}.
	r1 on: #mouseUp send: #jumpToProject to: self.

	history do: [ :each |
		(
			self addARow: {
				(self inAColumn: {
					StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock
				}) vResizing: #spaceFill.
				self inAColumn: {
					StringMorph new contents: each first; lock.
					"StringMorph new contents: each third; lock."
				}.
			}
		)
			color: Color paleYellow;
			borderWidth: 1;
			borderColor: #raised;
			vResizing: #spaceFill;
			on: #mouseUp send: #mouseUp:in: to: self;
			on: #mouseDown send: #mouseDown:in: to: self;
			on: #mouseMove send: #mouseMove:in: to: self;
			on: #mouseLeave send: #mouseLeave:in: to: self;
			setProperty: #projectParametersTuple toValue: each;
			setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third])
	].
"---
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
---"! !

!EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 23:07'!
step

	changeCounter = ProjectHistory changeCounter ifTrue: [^self].
	self rebuild.
	! !
EToyProjectDetailsMorph subclass: #EToyProjectQueryMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:16'!
doOK

	actionBlock value: self copyOutDetails.
	self delete.! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:17'!
fillInDetails

	"leave them blank for now"! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:18'!
project: ignored actionBlock: aBlock

	actionBlock _ aBlock.
	projectDetails _ Dictionary new.! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:19'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Enter things to search for'.
	}.
	self addARow: {
		self lockedString: 'Name:'.
		self inAColumnForText: {self fieldForProjectName}
	}.
	self fieldToDetailsMappings do: [ :each |
		self addARow: {
			self lockedString: each third.
			self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth}
		}.
	].

	self addARow: {
		self okButton.
		self cancelButton.
	}.
	self fillInDetails.! !

!EToyProjectQueryMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:39'!
setColorsAndBorder

	color _ Color r: 0.545 g: 0.47 b: 0.621.
	borderWidth _ 8.
	borderColor _ color darker.
	self layoutInset: 4.
	self useRoundedCorners.
 ! !

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

EToyProjectQueryMorph class
	instanceVariableNames: ''!

!EToyProjectQueryMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:34'!
test1: aProject
"EToyProjectQueryMorph test1: nil"

	| criteria clean |

	(self basicNew)
		project: aProject
		actionBlock: [ :x | 
			criteria _ OrderedCollection new.
			x keysAndValuesDo: [ :k :v |
				(clean _ v withBlanksTrimmed) isEmpty ifFalse: [
					criteria add: k,': *',clean,'*'
				].
			].
			SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow: criteria
		];

		initialize;
		openCenteredInWorld! !
EToyGenericDialogMorph subclass: #EToyProjectRenamerMorph
	instanceVariableNames: 'actionBlock theProject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:01'!
buttonColor

	^color darker! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:06'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString font: self myFont;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:05'!
cancelButton

	^self
		buttonNamed: 'Cancel' 
		action: #doCancel 
		color: self buttonColor 
		help: 'Cancel this Publish operation.'! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:06'!
doCancel

	self delete.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
doOK

	self validateTheProjectName ifFalse: [^self].
	self delete.
	actionBlock value: (namedFields at: 'projectname') contents string.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 12:02'!
fieldForProjectName

	| tm |

	tm _ self genericTextFieldNamed: 'projectname'.
	tm setBalloonText: 'Pick a name 24 characters or less and avoid the following characters:

 : < > | / \ ? * " .'.
	^tm
	
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/30/2000 15:29'!
initialize

	super initialize.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	self setColorsAndBorder.
	self rebuild.
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:04'!
myFont

	^(TextStyle named: #ComicBold) fontOfSize: 16! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 15:21'!
okButton

	^self
		buttonNamed: 'OK' 
		action: #doOK 
		color: self buttonColor 
		help: 'Change my name and continue publishing.'! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
project: aProject actionBlock: aBlock

	theProject _ aProject.
	actionBlock _ aBlock.
	(namedFields at: 'projectname') contentsWrapped: theProject name.! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 12:36'!
rebuild

	self removeAllMorphs.
	self addARow: {
		self lockedString: 'Please name this project'.
	}.
	self addARow: {
		self inAColumnForText: {self fieldForProjectName}
	}.
	self addARow: {
		self okButton.
		self cancelButton.
	}.
! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:39'!
setColorsAndBorder

	color _ Color paleYellow.
	borderWidth _ 8.
	borderColor _ color darker.
	self layoutInset: 4.
	self useRoundedCorners.

! !

!EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 13:55'!
validateTheProjectName

	| proposed |

	proposed _ (namedFields at: 'projectname') contents string.
	proposed size = 0 ifTrue: [
		self inform: 'I do need a name for the project'.
		^false
	].
	proposed size > 24 ifTrue: [
		self inform: 'Please make the name 24 characters or less'.
		^false
	].
	(Project isBadNameForStoring: proposed) ifTrue: [
		self inform: 'Please remove any funny characters from the name'.
		^false
	].
	proposed = theProject name ifTrue: [^true].
	(ChangeSorter changeSetNamed: proposed) ifNotNil: [
		Utilities inform: 'Sorry that name is already used'.
		^false
	].
	^true! !

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

EToyProjectRenamerMorph class
	instanceVariableNames: ''!

!EToyProjectRenamerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 10/18/2000 12:35'!
validate: aProject andDo: aBlock

	(self new)
		project: aProject actionBlock: aBlock;
		openCenteredInWorld! !
EToyChatOrBadgeMorph subclass: #EToySenderMorph
	instanceVariableNames: 'userPicture '
	classVariableNames: 'DEBUG '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToySenderMorph commentStamp: '<historical>' prior: 0!
EToySenderMorph
	new
	userName: 'Bob Arning' 
	userPicture: nil 
	userEmail: 'arning@charm.net' 
	userIPAddress: '1.2.3.4';
	position: 200@200;
	open
"
EToySenderMorph represents another person to whom you wish to send things. Drop a morph on an EToySenderMorph and a copy of that morph is sent to the person represented. Currently only peer-to-peer communications are supported, but other options are planned.
"!
]style[(149 1 262)cblue;f2,f2,f1!


!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 19:58'!
aboutToBeGrabbedBy: aHand

	| aFridge |
	super aboutToBeGrabbedBy: aHand.
	aFridge _ self ownerThatIsA: EToyFridgeMorph.
	aFridge ifNil: [^self].
	aFridge noteRemovalOf: self.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'mir 10/12/2000 14:54'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy outData |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [			"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"
	myCopy _ morphToDrop veryDeepCopy.	"gradient fills require doing this second"
	myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.
	self stopFlashing.

	outData _ myCopy eToyStreamedRepresentationNotifying: self.
	self resetIndicator: #working.
	self transmitStreamedObject: outData to: self ipAddress.

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 14:15'!
checkOnAFriend

	| gateKeeperEntry caption choices resp |

	gateKeeperEntry _ EToyGateKeeperMorph entryForIPAddress: self ipAddress.
	caption _ 
'Last name: ',gateKeeperEntry latestUserName,
'\Last message in: ',gateKeeperEntry lastIncomingMessageTimeString,
'\Last status check at: ',gateKeeperEntry lastTimeCheckedString,
'\Last status in: ',gateKeeperEntry statusReplyReceivedString.
	choices _ 'Get his status now\Send my status now' .
	resp _ (PopUpMenu labels: choices withCRs) startUpWithCaption: caption withCRs.
	resp = 1 ifTrue: [
		gateKeeperEntry lastTimeChecked: Time totalSeconds.
		self sendStatusCheck.
	].
	resp = 2 ifTrue: [
		self sendStatusReply.
	].
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/10/2000 12:25'!
currentBadgeVersion

	"enables on-the-fly updating of older morphs"
	^10! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 12:30'!
establishDropZone: aMorph

	self setProperty: #specialDropZone toValue: aMorph.
	aMorph 
		on: #mouseEnterDragging send: #mouseEnteredDZ to: self;
		on: #mouseLeaveDragging send: #mouseLeftDZ to: self;
		on: #mouseLeave send: #mouseLeftDZ to: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 13:08'!
fixOldVersion

	| uName uForm uEmail uIP |
	uName _ self userName.
	uForm _ userPicture ifNil: [
		(self 
		findDeepSubmorphThat: [ :x | (x isKindOf: ImageMorph) or: [x isKindOf: SketchMorph]] 
		ifAbsent: [self halt]) form.
	].
	uEmail _ (fields at: #emailAddress) contents.
	uIP _ self ipAddress.
	self
		userName: uName 
		userPicture: (uForm scaledToSize: 61@53)
		userEmail: uEmail 
		userIPAddress: uIP
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:54'!
initialize

	Socket initializeNetwork.				"we may want our IP address"
	Preferences defaultAuthorName.		"seems like a good place to insure we have a name"
	super initialize.
	self listDirection: #topToBottom.
	color _ Color lightMagenta.
	self layoutInset: 4.
	borderColor _ Color magenta.
	borderWidth _ 4.
	self setProperty: #normalBorderColor toValue: borderColor.
	self setProperty: #flashingColors toValue: {Color red. Color yellow}.

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/31/2000 18:31'!
installModelIn: myWorld

	"if we get this far and nothing exists, make it up"

	userPicture ifNotNil: [^self].
	self
		userName: Preferences defaultAuthorName 
		userPicture: nil 
		userEmail: 'who@where.net' 
		userIPAddress: NetNameResolver localAddressString
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 15:58'!
ipAddress

	^(fields at: #ipAddress) contents! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 16:20'!
ipAddress: aString

	^(fields at: #ipAddress) contents: aString! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 14:23'!
killExistingChat

	| oldOne |
	self rubberBandCells: true. "disable growing"
	(oldOne _ self valueOfProperty: #embeddedChatHolder) ifNotNil: [
		oldOne delete.
		self removeProperty: #embeddedChatHolder
	].

	(oldOne _ self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [
		oldOne delete.
		self removeProperty: #embeddedAudioChatHolder
	].

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 18:05'!
mouseEnteredDZ

	| dz |
	dz _ self valueOfProperty: #specialDropZone ifAbsent: [^self].
	dz color: Color blue.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 18:05'!
mouseLeftDZ

	| dz |
	dz _ self valueOfProperty: #specialDropZone ifAbsent: [^self].
	dz color: Color transparent.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:52'!
sendStatusCheck

	| null |
	null _ String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeStatusRequest,null. 
			Preferences defaultAuthorName,null.
		}
		to: self ipAddress
		for: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 11:53'!
sendStatusReply

	| null |
	null _ String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeStatusReply,null. 
			Preferences defaultAuthorName,null.
			((EToyGateKeeperMorph acceptableTypesFor: self ipAddress) 
				eToyStreamedRepresentationNotifying: self).
		}
		to: self ipAddress
		for: self.
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 14:22'!
startAudioChat

	self startAudioChat: true
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/11/2000 12:32'!
startAudioChat: toggleMode

	| chat r |

	(self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [
		toggleMode ifFalse: [^self].
		^self killExistingChat
	].
	(self ownerThatIsA: EToyFridgeMorph) isNil ifTrue: [
		chat _ AudioChatGUI new ipAddress: self ipAddress.
		chat
			removeConnectButton;		"we already know the connectee"
			vResizing: #shrinkWrap;
			hResizing: #shrinkWrap;
			borderWidth: 2.
		r _ (self addARow: {chat}) vResizing: #shrinkWrap.
		self world startSteppingSubmorphsOf: chat.
		self setProperty: #embeddedAudioChatHolder toValue: r.
		self hResizing: #spaceFill; vResizing: #spaceFill.
	] ifFalse: [
		chat _ AudioChatGUI new ipAddress: self ipAddress.
		chat openInWorld: self world.
	]
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 17:14'!
startChat

	self startChat: true
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:10'!
startChat: toggleMode

	| chat r |

	(self valueOfProperty: #embeddedChatHolder) ifNotNil: [
		toggleMode ifFalse: [^self].
		^self killExistingChat
	].
	(EToyChatMorph doChatsInternalToBadge and: 
				[(self ownerThatIsA: EToyFridgeMorph) isNil]) ifTrue: [
		chat _ EToyChatMorph basicNew
			recipientForm: userPicture; 
			initialize;
			setIPAddress: self ipAddress.
		chat
			vResizing: #spaceFill;
			hResizing: #spaceFill;
			borderWidth: 2;
			insetTheScrollbars.
		r _ (self addARow: {chat}) vResizing: #spaceFill.
		self rubberBandCells: false. "enable growing"
		self height: 350. "an estimated guess for allowing shrinking as well as growing"
		self world startSteppingSubmorphsOf: chat.
		self setProperty: #embeddedChatHolder toValue: r.
	] ifFalse: [
		chat _ EToyChatMorph 
			chatWindowForIP: self ipAddress
			name: self userName 
			picture: userPicture 
			inWorld: self world.
		chat owner addMorphFront: chat.
	]
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/15/2000 12:11'!
startNebraskaClient

	| newMorph |
	[
		[
			newMorph _ NetworkTerminalMorph connectTo: self ipAddress.
			WorldState addDeferredUIMessage: [newMorph openInStyle: #scaled] fixTemps.
		]
			on: Error
			do: [ :ex |
				WorldState addDeferredUIMessage: [
					self inform: 'No connection to: '. self ipAddress,' (',ex printString,')'
				] fixTemps
			].
	] fork
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/24/2000 14:04'!
startTelemorphic

	self world 
		connectRemoteUserWithName: self userName 
		picture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20]) 
		andIPAddress: self ipAddress
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/10/2000 12:24'!
step

	(self valueOfProperty: #currentBadgeVersion) = self currentBadgeVersion ifFalse: [
		self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
		self fixOldVersion.
		Preferences defaultAuthorName.		"seems like a good place to insure we have a name"
	].
	super step.! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 11:12'!
tellAFriend

	self world project tellAFriend: (fields at: #emailAddress) contents
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:15'!
transmitStreamedObject: outData

	self transmitStreamedObject: outData to: self ipAddress

! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 12:00'!
transmittedObjectCategory

	^EToyIncomingMessage typeMorph! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 13:07'!
userName

	^ (self 
		findDeepSubmorphThat: [ :x | x isKindOf: StringMorph] 
		ifAbsent: [self halt]) contents
! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 15:04'!
userName: aString userPicture: aFormOrNil userEmail: emailString userIPAddress: ipString

	| dropZoneRow |

	self setProperty: #currentBadgeVersion toValue: self currentBadgeVersion.
	userPicture _ aFormOrNil ifNil: [
		(TextStyle default fontOfSize: 26) emphasized: 1; characterFormAt: $?
	].
	userPicture _ userPicture scaledToSize: 61@53.
	self killExistingChat.
	self removeAllMorphs.
	self useRoundedCorners.
	self 
		addARow: {
			self inAColumn: {(StringMorph contents: aString) lock}
		}.
	dropZoneRow _ self
		addARow: {
			self inAColumn: {userPicture asMorph lock}
		}.
	self establishDropZone: dropZoneRow.
	self
		addARow: {
			self textEntryFieldNamed: #emailAddress with: emailString
					help: 'Email address for this person'
		};
		addARow: {
			self textEntryFieldNamed: #ipAddress with: ipString
					help: 'IP address for this person'
		};
		addARow: {
			self indicatorFieldNamed: #working color: Color blue help: 'working'.
			self indicatorFieldNamed: #communicating color: Color green help: 'sending'.
			self buttonNamed: 'C' action: #startChat color: Color paleBlue 
								help: 'Open a written chat with this person'.
			self buttonNamed: 'T' action: #startTelemorphic color: Color paleYellow 
								help: 'Start telemorphic with this person'.
			self buttonNamed: '!!' action: #tellAFriend color: Color paleGreen 
								help: 'Tell this person about the current project'.
			self buttonNamed: '?' action: #checkOnAFriend color: Color lightBrown 
								help: 'See if this person is available'.
			self buttonNamed: 'A' action: #startAudioChat color: Color yellow 
								help: 'Open an audio chat with this person'.
			self buttonNamed: 'S' action: #startNebraskaClient color: Color white 
								help: 'See this person''s world (if he allows that)'.
		}.
	! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 16:06'!
userPicture

	^userPicture! !

!EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 18:02'!
wantsDroppedMorph: aMorph event: evt

	| dz |
	dz _ self valueOfProperty: #specialDropZone ifAbsent: [^false].
	(dz bounds containsPoint: (evt cursorPoint)) ifFalse: [^false].
	^true.! !


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

EToySenderMorph class
	instanceVariableNames: ''!

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:52'!
instanceForIP: ipAddress

	^self allInstances detect: [ :x | 
		x ipAddress = ipAddress
	] ifNone: [nil]
! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 12:50'!
instanceForIP: ipAddress inWorld: aWorld

	^self allInstances detect: [ :x | 
		x world == aWorld and: [x ipAddress = ipAddress]
	] ifNone: [nil]
! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 15:42'!
nameForIPAddress: ipString

	| senderMorphs |

	senderMorphs _ EToySenderMorph allInstances select: [ :x | 
		x userName notNil and: [x ipAddress = ipString]
	].
	senderMorphs isEmpty ifTrue: [^nil].
	^senderMorphs first userName

! !

!EToySenderMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 14:47'!
pictureForIPAddress: ipString

	| senderMorphs |

	senderMorphs _ EToySenderMorph allInstances select: [ :x | 
		x userPicture notNil and: [x ipAddress = ipString]
	].
	senderMorphs isEmpty ifTrue: [^nil].
	^senderMorphs first userPicture

! !
StandardScriptingSystem subclass: #EToySystem
	instanceVariableNames: ''
	classVariableNames: 'EToyVersion EToyVersionDate '
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!EToySystem commentStamp: '<historical>' prior: 0!
A global object holding onto properties and code of the overall E-toy system of the moment.  Its code is entirely held on the class side; the class is never instantiated.!


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

EToySystem class
	instanceVariableNames: ''!

!EToySystem class methodsFor: 'development support' stamp: 'tk 8/21/2000 12:59'!
cleanupsForRelease
	"Miscellaneous space cleanups to do before a release."
	"EToySystem cleanupsForRelease"

	Socket deadServer: ''.  "Don't reveal any specific server name"
	HandMorph initialize.  "free cached ColorChart"
	PaintBoxMorph initialize.	"forces Prototype to let go of extra things it might hold"
	Smalltalk removeKey: #AA ifAbsent: [].
	Smalltalk removeKey: #BB ifAbsent: [].
	Smalltalk removeKey: #CC ifAbsent: [].
	Smalltalk removeKey: #DD ifAbsent: [].
	Smalltalk removeKey: #Temp ifAbsent: [].

	ScriptingSystem reclaimSpace.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	Smalltalk forgetDoIts.
	Smalltalk removeEmptyMessageCategories.
	Symbol rehash.
! !

!EToySystem class methodsFor: 'development support' stamp: 'di 9/14/1998 10:02'!
loadJanForms
	"EToySystem loadJanForms"

	| aReferenceStream newFormDict |
	aReferenceStream _ ReferenceStream fileNamed: 'JanForms'.
	newFormDict _ aReferenceStream next.
	aReferenceStream close.
	newFormDict associationsDo:
		[:assoc | Smalltalk imageImports add: assoc]! !

!EToySystem class methodsFor: 'development support' stamp: 'sw 10/16/1998 09:31'!
stripMethodsForExternalRelease
	"EToySystem stripMethodsForExternalRelease"

	Utilities stripMethods: self methodsToStripForExternalRelease messageCode: '2.3External'! !


!EToySystem class methodsFor: 'versioning' stamp: 'di 8/16/2000 12:29'!
eToyVersion: aVersion date: dateStringOrDate
	"For calling from a fileIn"

	EToyVersion _ aVersion.
	EToyVersionDate _ dateStringOrDate asString.
	Smalltalk setVersion: EToyVersion , ' of ' , EToyVersionDate! !

!EToySystem class methodsFor: 'versioning' stamp: 'di 8/16/2000 12:28'!
setVersion
	"EToySystem setVersion"

	| newName |
	newName _ FillInTheBlank
		request: ('Please name this EToy system version.\The old version is:\',
					EToyVersion, '\set on ', EToyVersionDate) withCRs
 		initialAnswer: EToyVersion.
	newName size > 0 ifTrue:
		[self eToyVersion: newName date: Date today printString]! !

!EToySystem class methodsFor: 'versioning' stamp: 'sw 9/21/97 01:05'!
version
	"EToySystem version"

	^ EToyVersion! !

!EToySystem class methodsFor: 'versioning' stamp: 'sw 9/21/97 01:17'!
versionDate
	"EToySystem versionDate"

	^ EToyVersionDate! !


!EToySystem class methodsFor: 'loading' stamp: 'tk 10/31/97 12:57'!
newEToysOn: serverList
	"Return a list of fully formed URLs of update files we do not yet
have.  Go to the listed servers and look at the file 'updates.list' for the
names of the last N update files.  We look backwards for the first one we
have, and make the list from there."

	| doc list out |
	out _ OrderedCollection new.
	serverList do: [:server |
		doc _ HTTPSocket httpGet: server,'etoys.list2' 
					"Just add to contents of file 'etoys.list2', don't change its name"
				accept: 'application/octet-stream'.
		"test here for server being up"
		doc class == RWBinaryOrTextStream ifTrue:
			[list _ doc reset; contents.	"one file name per line"
			list _ Utilities extractThisVersion: list.
			^ list collect: [:nn | server, nn]].
		"Server was down, try next one"].
	PopUpMenu notify: 'All EToy servers seem to be unavailable'.
	^ out! !


!EToySystem class methodsFor: 'misc' stamp: 'sw 1/21/98 15:07'!
fixComicCharacters
	"EToySystem fixComicCharacters"
	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $_ put:
		(Form
	extent: 9@16
	depth: 1
	fromArray: #( 0 0 0 134217728 402653184 805306368 2139095040 4278190080 2139095040 805306368 402653184 134217728 0 0 0 0)
	offset: 0@0).

	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $1 put:
		(Form
	extent: 5@16
	depth: 1
	fromArray: #( 0 0 0 0 1610612736 3758096384 3758096384 1610612736 1610612736 1610612736 1610612736 4026531840 4026531840 0 0 0)
	offset: 0@0).


	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $2 put:
		(Form
	extent: 6@16
	depth: 1
	fromArray: #( 0 0 0 0 1879048192 4160749568 2550136832 939524096 1879048192 3758096384 3221225472 4160749568 4160749568 0 0 0)
	offset: 0@0).


	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $4 put:
		(Form
	extent: 7@16
	depth: 1
	fromArray: #( 0 0 0 0 134217728 402653184 402653184 939524096 1476395008 4227858432 4227858432 402653184 402653184 0 0 0)
	offset: 0@0).

	((TextConstants at:  #ComicBold) fontAt: 3) characterFormAt: $j put:
		(Form
	extent: 4@16
	depth: 1
	fromArray: #( 0 0 0 0 1610612736 1610612736 0 1610612736 1610612736 1610612736 1610612736 1610612736 1610612736 1610612736 3758096384 3221225472)
	offset: 0@0).

! !


!EToySystem class methodsFor: 'external release' stamp: 'sw 10/16/1998 09:30'!
methodsToStripForExternalRelease
	"Answer a list of triplets #(className, class/instance, methodName) of methods to be stripped in an external release."
	^ #(

		(EToySystem			class		serverUrls)
		(EToySystem			class		prepareRelease)	
		(EToySystem			class		previewEToysOn:)
		)! !


!EToySystem class methodsFor: 'stripped' stamp: 'di 1/15/1999 11:29'!
prepareRelease
	self codeStrippedOut: '2.3External'! !

!EToySystem class methodsFor: 'stripped' stamp: 'di 1/15/1999 11:29'!
previewEToysOn: arg1
	self codeStrippedOut: '2.3External'! !
TextMorph subclass: #EToyTextNode
	instanceVariableNames: 'children firstDisplay '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 01:12'!
addChild: aTextNode

	children add: aTextNode.
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 10:05'!
addNewChildAfter: anotherOrNilOrZero

	| where newNode |

	anotherOrNilOrZero == 0 ifTrue: [
		newNode _ EToyTextNode newNode.
		children _ {newNode} asOrderedCollection,children.
		^newNode
	].
	where _ children indexOf: anotherOrNilOrZero ifAbsent: [children size].
	children add: (newNode _ EToyTextNode newNode) afterIndex: where.
	^newNode
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 01:13'!
children

	^children
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 13:09'!
clipToOwner: aBoolean

	aBoolean ifFalse: [^self setContainer: nil].
	self setContainer: (SimplerTextContainer new for: self minWidth: textStyle lineGrid*2)! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:52'!
firstDisplay

	^firstDisplay ifNil: [false]! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 10:33'!
firstDisplayedOnLevel: level

	firstDisplay _ false.
	text addAttribute: (TextFontChange fontNumber: ((5 - level) max: 1)).
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 17:09'!
initialize

	| newStyle |
	super initialize.
	firstDisplay _ true.
	children _ OrderedCollection new.
	(newStyle _ TextStyle named: #Palatino) ifNotNil: [
		textStyle _ newStyle copy defaultFontIndex: 2
	].

! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 15:08'!
keyStroke: evt

	(owner notNil and: [owner keyStroke: evt]) ifTrue: [^self].
	^super keyStroke: evt.! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:07'!
keyboardFocusChange: aBoolean

	super keyboardFocusChange: aBoolean.
	aBoolean ifTrue: [owner takeFocus].

! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:43'!
removeChild: aTextNode

	children remove: aTextNode ifAbsent: [].
! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:53'!
showInOpenedState

	| answer |
	answer _ self valueOfProperty: #showInOpenedState ifAbsent: [false].
	self removeProperty: #showInOpenedState.
	^answer! !

!EToyTextNode methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:55'!
withAllChildrenDo: aBlock

	aBlock value: self.
	children do: [ :each | each withAllChildrenDo: aBlock].! !


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

EToyTextNode class
	instanceVariableNames: ''!

!EToyTextNode class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:36'!
includeInNewMorphMenu

	^ false! !

!EToyTextNode class methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:11'!
newNode

	^self new contents: (
		Text
			string: 'new item'
			attribute: (TextFontChange fontNumber: 2)
	)! !
ListItemWrapper subclass: #EToyTextNodeWrapper
	instanceVariableNames: 'parentWrapper '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 17:25'!
addNewChildAfter: anotherOrNil

	item addNewChildAfter: anotherOrNil.
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:50'!
addSibling

	parentWrapper ifNil: [^1 beep].
	parentWrapper addNewChildAfter: item.! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 00:56'!
asString

	^item contents! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 17:08'!
contents

	^item children collect: [ :each | 
		EToyTextNodeWrapper with: each model: model parent: self
	].
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:42'!
delete

	parentWrapper ifNil: [^1 beep].
	parentWrapper withoutListWrapper removeChild: item withoutListWrapper.
! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 00:43'!
hasContents

	^true! !

!EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:51'!
parentWrapper: anotherWrapper

	parentWrapper _ anotherWrapper
! !


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

EToyTextNodeWrapper class
	instanceVariableNames: ''!

!EToyTextNodeWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 11:52'!
with: anObject model: aModel parent: anotherWrapper

	^self new
		setItem: anObject model: aModel;
		parentWrapper: anotherWrapper! !
Vocabulary subclass: #EToyVocabulary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!
!EToyVocabulary commentStamp: '<historical>' prior: 0!
EToyVocabulary - a vocabulary mirroring the capabilities available to end users in Squeak's old 1997-2000 etoy prototype.!


!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 1/12/2001 01:17'!
addGetterAndSetterInterfacesFromOldSlotSpec: aCommandSpec
	"Create, given an old etoy-style command spec, appropriate MethodInterfaces, and store those interfaces in my method-interface dictionary"

	| aMethodInterface aSelector |

	aMethodInterface _ MethodInterface new initializeFromEToySlotSpec: aCommandSpec.
	methodInterfaces at:  aCommandSpec seventh put: aMethodInterface.

	(aCommandSpec size >= 9 and: [(#(unused missing) includes: aCommandSpec ninth) not])
		ifTrue:
			[aMethodInterface _ MethodInterface new initializeFor: (aSelector _ aCommandSpec ninth).
			methodInterfaces at: aSelector put: aMethodInterface]

"	1	#slot  -- indicates that is a slot specification rather than a method specification
	2	slot name
	3	help message
	4	type
	5	#readOnly or #readWrite (if #readWrite, items 8 and 9 should be present & meaningful)
	6	<future use -- target for getter -- currently always set to #player>
	7	getter selector
	8	<future use -- target for setter -- currently always set to #player>
	9	setter selector"
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether an object, by its very nature, is one that the receiver embraces"

	^ aClass isKindOf: Player class! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 12/18/2000 14:33'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower"

	| classToUse aClass theKeys |
	(aTargetClass isUniClass and:
		[(aTargetClass namedTileScriptSelectors includes: aSelector) or:
			[(((theKeys _ aTargetClass slotInfo keys collect:
				[:anInstVarName | Utilities getterSelectorFor: anInstVarName])) includes: aSelector)
					or:
						[(theKeys collect: [:anInstVarName | Utilities setterSelectorFor: anInstVarName]) includes: aSelector]]]) ifTrue: [^ true].

	(methodInterfaces includesKey: aSelector) ifFalse: [^ false].
	classToUse _ self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass _ classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[aClass includesBehavior: mostGenericClass]
! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 1/26/2001 23:03'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	|   classes aMethodCategory selectors categorySymbols |
	super initialize.
	self vocabularyName: #eToy.
	self documentation: '"EToy" is a vocabulary that provides the equivalent of the 1997-2000 etoy prototype'.
	categorySymbols _ Set new.
	classes _ Smalltalk allImplementorsOf: #additionsToViewerCategories.
	classes do:
		[:anItem |
		MessageSet parse: anItem toClassAndSelector:
			[:aClass :aSelector | aClass].
		categorySymbols addAll: aClass soleInstance basicNew categoriesForViewer].

	categorySymbols asOrderedCollection do:
		[:aCategorySymbol |
			aMethodCategory _ ElementCategory new categoryName: aCategorySymbol.
				classes _ (Smalltalk allImplementorsOf: #additionsToViewerCategories) collect:
					[:anItem | MessageSet parse: anItem toClassAndSelector: [:aMetaClass :aSelector | aMetaClass soleInstance]].

			selectors _ Set new.
			classes do:
				[:aClass |
					 (aClass additionsToViewerCategory: aCategorySymbol) do:
						[:anElement |
							anElement first == #command
								ifTrue:
									[selectors add: (aSelector _ anElement second).
									(methodInterfaces includesKey: aSelector) ifFalse:
										[methodInterfaces at: aSelector put: (MethodInterface new initializeFromEToyCommandSpec:  anElement category: aCategorySymbol)]]
								ifFalse:  "#slot format"
									[selectors add: (aSelector _ anElement seventh).  "the getter"
									selectors add: (anElement at: 9) "the setter".
									(methodInterfaces includesKey: aSelector) ifFalse:
										[self addGetterAndSetterInterfacesFromOldSlotSpec: anElement]]]].
			(selectors copyWithout: #unused) asSortedArray do:
				[:aSelector |
					aMethodCategory elementAt: aSelector put: (methodInterfaces at: aSelector)].
				 
			self addCategory: aMethodCategory].

	#(scripts 'instance variables') do: [:sym | self addCategoryNamed: sym].
	self setCategoryDocumentationStrings! !

!EToyVocabulary methodsFor: 'initialization' stamp: 'sw 12/18/2000 09:57'!
setCategoryDocumentationStrings
	"Initialize the documentation strings associated with the old etoy categories"

	#(
		(basic				'vitu muhimu')
		('color & border'	'rangi na kadhalika')
		(geometry 			'sijui neno hilo')
		(motion 			'kusogea')
		('pen use' 			'utumizi wa kalamu ya wino')
		(tests				'majaribio')
		(miscellaneous 		'mbali mbali')
		(slider				'oh yeah')
		(scripts				'methods added by this uniclass')
		('instance variables'	'instance variables added by this uniclass')) do:

		[:aPair |
			(self categoryAt: aPair first asSymbol) documentation: aPair second].! !


!EToyVocabulary methodsFor: 'category list' stamp: 'sw 12/18/2000 15:34'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in aClass and lower"

	^ (anObject isKindOf: Player)
		ifTrue:
			[(mostGenericClass == aClass)
				ifFalse:
					[anObject categories]
				ifTrue:
					[#(scripts #'instance variables')]]
		ifFalse:
			[super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass]! !


!EToyVocabulary methodsFor: 'method list' stamp: 'sw 1/30/2001 16:31'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass"

	| aCategory unfiltered suitableSelectors isAll |
	categoryName ifNil: [^ OrderedCollection new].
	aClass isUniClass ifTrue:
		[categoryName == #scripts ifTrue:
			[^ aClass namedTileScriptSelectors].
		categoryName == #'instance variables' ifTrue:
			[^ aClass slotInfo keys asSortedArray collect:
				[:anInstVarName | Utilities getterSelectorFor: anInstVarName]]].
	unfiltered _ (isAll _ categoryName = self allCategoryName)
		ifTrue:
			[methodInterfaces collect: [:anInterface | anInterface selector]]
		ifFalse:
			[aCategory _ categories detect: [:cat | cat categoryName == categoryName asSymbol] 
							ifNone: [^ OrderedCollection new].
			aCategory elementsInOrder collect: [:anElement | anElement selector]].

	(anObject isKindOf: Player) ifTrue:
		[suitableSelectors _ anObject costume selectorsForViewer.
		unfiltered _ unfiltered  select:
			[:aSelector | suitableSelectors includes: aSelector]].
	(isAll and: [aClass isUniClass]) ifTrue:
		[unfiltered addAll: aClass namedTileScriptSelectors.
		unfiltered addAll: (aClass slotInfo keys asSortedArray collect:
			[:anInstVarName | Utilities getterSelectorFor: anInstVarName])].

	^ (unfiltered copyWithoutAll: #(dummy unused)) asSortedArray! !
ObjectWithDocumentation subclass: #ElementCategory
	instanceVariableNames: 'categoryName keysInOrder elementDictionary '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!
!ElementCategory commentStamp: '<historical>' prior: 0!
ElementCategory
	
Contains a list of elements that affords keyed access but also has an inherent order.

Add items to the category by sending it elementAt:put:.
Obtain the elements in order by sending #elementsInOrder
Obtain the value of an element at a given key by sending #elementAt:!


!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:46'!
elementAt: aKey
	"Answer the element at the given key"

	^ elementDictionary at: aKey ifAbsent: [nil]! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 22:54'!
elementAt: sym put: element
	"Add symbol at the end of my sorted list (unless it is already present), and put the element in the dictionary"

	(keysInOrder includes: sym) ifFalse: [keysInOrder add: sym].
	^ elementDictionary at: sym put: element! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 12/1/2000 22:47'!
elementsInOrder
	"Answer the elements in order"

	^ keysInOrder collect: [:aKey | elementDictionary at: aKey]! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 23:00'!
placeKey: key1 afterKey: key2
	"Place the first key after the second one in my keysInOrder ordering"

	keysInOrder remove: key1.
	keysInOrder add: key1 after: key2! !

!ElementCategory methodsFor: 'elements' stamp: 'sw 1/26/2001 23:00'!
placeKey: key1 beforeKey: key2
	"Place the first key before the second one in my keysInOrder ordering"

	keysInOrder remove: key1.
	keysInOrder add: key1 before: key2! !


!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:45'!
copy
	"Answer a copy of the receiver"

	^ super copy copyFrom: self! !

!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:46'!
copyFrom: donor
	"Copy the receiver's contents from the donor"

	keysInOrder _ donor keysInOrder.
	elementDictionary _ donor copyOfElementDictionary! !

!ElementCategory methodsFor: 'copying' stamp: 'sw 12/1/2000 22:46'!
copyOfElementDictionary
	"Answer a copy of the element dictionary"

	^ elementDictionary copy! !


!ElementCategory methodsFor: 'keys' stamp: 'sw 12/11/2000 15:36'!
includesKey: aKey
	"Answer whether the receiver's dictionary holds the given key"

	^ elementDictionary includesKey: aKey! !

!ElementCategory methodsFor: 'keys' stamp: 'sw 12/1/2000 22:47'!
keysInOrder
	"Answer the keys in their sorted order"

	^ keysInOrder copy! !


!ElementCategory methodsFor: 'category name' stamp: 'sw 1/26/2001 22:45'!
categoryName
	"Answer the formal name of the category"

	^ categoryName! !

!ElementCategory methodsFor: 'category name' stamp: 'sw 1/26/2001 22:46'!
categoryName: aName
	"Set the category name"

	categoryName _ aName! !


!ElementCategory methodsFor: 'initialization' stamp: 'sw 12/1/2000 22:01'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	keysInOrder _ OrderedCollection new.
	elementDictionary _ IdentityDictionary new! !


!ElementCategory methodsFor: 'printing' stamp: 'sw 1/26/2001 22:47'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that identifies the receiver."

	super printOn: aStream.
	categoryName ifNotNil: [aStream nextPutAll: ' named ', categoryName asString]! !
Object subclass: #EllipseMidpointTracer
	instanceVariableNames: 'rect x y a b aSquared bSquared d1 d2 inFirstRegion '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!EllipseMidpointTracer methodsFor: 'initialize' stamp: 'ar 6/28/1999 15:33'!
on: aRectangle
	rect _ aRectangle.
	a _ rect width // 2.
	b _ rect height // 2.
	x _ 0.
	y _ b.
	aSquared _ a * a.
	bSquared _ b * b.
	d1 _ bSquared - (aSquared * b) + (0.25 * aSquared).
	d2 _ nil.
	inFirstRegion _ true.! !


!EllipseMidpointTracer methodsFor: 'computing' stamp: 'ar 6/28/1999 15:35'!
stepInY
	"Step to the next y value"
	inFirstRegion ifTrue:[
		"In the upper region we must step until we reach the next y value"
		[(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[
			d1 < 0.0
				ifTrue:[d1 _ d1 + (bSquared * (2*x+3)).
						x _ x + 1]
				ifFalse:[d1 _ d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)).
						y _ y - 1.
						^x _ x + 1]].
		"Stepping into second region"
		d2 _ (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared).
		inFirstRegion _ false.
	].
	"In the lower region each step is a y-step"
	d2 < 0.0
		ifTrue:[d2 _ d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)).
				x _ x + 1]
		ifFalse:[d2 _ d2 + (aSquared * (-2*y+3))].
	y _ y - 1.
	^x! !
BorderedMorph subclass: #EllipseMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!EllipseMorph methodsFor: 'as yet unclassified' stamp: 'di 6/24/1998 14:27'!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!EllipseMorph methodsFor: 'as yet unclassified' stamp: 'di 11/14/97 13:50'!
containsPoint: aPoint

	| radius other delta xOverY |
	(bounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"
	(bounds width = 1 or: [bounds height = 1])
		ifTrue: [^ true].  "Degenerate case -- code below fails by a bit"

	radius _ bounds height asFloat / 2.
	other _ bounds width asFloat / 2.
	delta _ aPoint - bounds topLeft - (other@radius).
	xOverY _ bounds width asFloat / bounds height asFloat.
	^ (delta x asFloat / xOverY) squared + delta y squared <= radius squared! !

!EllipseMorph methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 11:29'!
doesBevels
	^ false! !

!EllipseMorph methodsFor: 'as yet unclassified' stamp: 'ar 6/18/1999 08:52'!
drawOn: aCanvas 

	aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor! !

!EllipseMorph methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:14'!
initialize

	super initialize.
	borderColor _ Color black.
	borderWidth _ 1.
! !


!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^true! !

!EllipseMorph methodsFor: 'visual properties' stamp: 'sw 11/24/1999 14:59'!
couldHaveRoundedCorners
	^ false! !

!EllipseMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:14'!
defaultColor
	"Return the default fill style for the receiver"
	^Color yellow! !
ServerAction subclass: #EmbeddedServerAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!EmbeddedServerAction commentStamp: '<historical>' prior: 0!
EmbeddedServerAction works like a normal ServerAction, except that it interprets any embedded Smalltalk code (within <? ?> tags, stolen from Microsoft's notation for a similar capability) and replaces the embedded code with the value returned from the execution of the code.
!


!EmbeddedServerAction methodsFor: 'URL processing' stamp: 'mjg 10/5/1998
16:44'!
replyTo: pieces from: request
	| theLast |
	(StandardFileStream isAFileNamed: pieces)
		ifTrue:
			[theLast _ request message last asLowercase.
			theLast = 'gif' ifTrue: [^ self process: request MIMEtype: 'image/gif'].
			theLast = 'jpeg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
			theLast = 'jpg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
			theLast = 'jpe' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
			request reply: PWS success;
			 reply: PWS contentHTML , PWS crlf.
			request reply: (HTMLformatter evalEmbedded: 
				(FileStream fileNamed: pieces) contentsOfEntireFile with: request)]
		ifFalse: [request error: PWS notFound]! !
AlignmentMorph subclass: #EmbeddedWorldBorderMorph
	instanceVariableNames: 'heights minWidth minHeight '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:16'!
addCustomMenuItems: menu hand: aHandMorph

	super addCustomMenuItems: menu hand: aHandMorph.

	self worldIEnclose
		addScalingMenuItems: menu 
		hand: aHandMorph
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:08'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self boxesAndColorsAndSelectors do: [ :each |
		aCanvas fillRectangle: each first fillStyle: each second
	].

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/26/2000 19:10'!
extent: aPoint

	bounds extent = aPoint ifFalse: [
		self changed.
		bounds _ bounds topLeft extent: aPoint.
		self myWorldChanged.
	].
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:16'!
goAppView

	self worldIEnclose showApplicationView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:17'!
goFactoryView

	self worldIEnclose showFactoryView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:18'!
goFullView

	self worldIEnclose showFullView

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:18'!
goNormalProjectEntry

	| w |
	w _ self worldIEnclose.
	self delete.
	w project enter.

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:10'!
handlesMouseDown: evt

	self boxesAndColorsAndSelectors do: [ :each |
		(each first containsPoint: evt cursorPoint) ifTrue: [^true]
	].
	^false

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:26'!
initialize

	super initialize.
	self setBalloonText: 'This is the frame of an embedded project. Click on the colored boxes:
blue - expand or reduce
yellow - app view
red - factory view
cyan - full view
white - enter the project completely'! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/26/2000 18:45'!
minHeight: anInteger

	minHeight _ anInteger! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/26/2000 18:46'!
minWidth: anInteger

	minWidth _ anInteger! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 19:23'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^20		"Embedded worlds come in front of other worlds' Project navigation morphs"! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:13'!
mouseDown: evt

	self boxesAndColorsAndSelectors do: [ :each |
		(each first containsPoint: evt cursorPoint) ifTrue: [
			^self perform: each third
		].
	].


! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 13:31'!
myTransformation

	^submorphs detect: [ :x | x isKindOf: TransformationMorph] ifNone: [nil]
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/14/2000 10:48'!
myWorldChanged
	| trans |
	trans _ self myTransformation.
	self changed.
	self layoutChanged.
	trans ifNotNil:[
		trans extentFromParent: self innerBounds extent.
		bounds _ bounds topLeft extent: trans extent + (borderWidth * 2).
	].
	self changed.
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 10:12'!
toggleZoom

	self bounds: (
		bounds area > (Display boundingBox area * 0.9) ifTrue: [
			Display extent // 4 extent: Display extent // 2.
		] ifFalse: [
			Display boundingBox
		]
	)

! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 13:31'!
worldIEnclose

	^self myTransformation firstSubmorph	
					"quick hack since this is the only usage pattern at the moment"
! !

!EmbeddedWorldBorderMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/8/2000 22:42'!
xxxfixLayout
	| trans |
	trans _ self myTransformation.
	trans ifNil:[^super fixLayout].
	trans bounds: self innerBounds.

! !


!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
appViewBoxArea

	^self genericBoxArea: 1
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:12'!
boxesAndColorsAndSelectors

	^{
		{self zoomBoxArea. Color blue. #toggleZoom}.
		{self appViewBoxArea. Color yellow. #goAppView}.
		{self factoryViewBoxArea. Color red. #goFactoryView}.
		{self fullViewBoxArea. Color cyan. #goFullView}.
		{self normalEntryBoxArea. Color white. #goNormalProjectEntry}.
	}! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
factoryViewBoxArea

	^self genericBoxArea: 2
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
fullViewBoxArea

	^self genericBoxArea: 3
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:03'!
genericBoxArea: countDownFromTop

	^self innerBounds right @ (self top + (countDownFromTop * 2 * borderWidth)) 
		extent: borderWidth @ borderWidth
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:04'!
normalEntryBoxArea

	^self genericBoxArea: 4
! !

!EmbeddedWorldBorderMorph methodsFor: 'boxes' stamp: 'RAA 7/13/2000 10:03'!
zoomBoxArea

	^self genericBoxArea: 0
! !
SelectionMenu subclass: #EmphasizedMenu
	instanceVariableNames: 'emphases '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!EmphasizedMenu commentStamp: '<historical>' prior: 0!
A selection menu in which individual selections are allowed to have different emphases.  Emphases allowed are: bold, italic, struckThrough, and plain.  Provide an emphasis array, with one element per selection, to use.  Refer to the class method #example.!


!EmphasizedMenu methodsFor: 'display'!
startUpWithCaption: captionOrNil
	self setEmphasis.
	^ super startUpWithCaption: captionOrNil! !


!EmphasizedMenu methodsFor: 'emphasis'!
emphases: emphasisArray
	emphases _ emphasisArray! !

!EmphasizedMenu methodsFor: 'emphasis' stamp: 'di 4/13/1999 16:27'!
onlyBoldItem: itemNumber
	"Set up emphasis such that all items are plain except for the given item number.  "

	emphases _ (Array new: selections size) atAllPut: #plain.
	emphases at: itemNumber put: #bold! !


!EmphasizedMenu methodsFor: 'private' stamp: 'sw 4/5/1999 13:59'!
setEmphasis
	"Set up the receiver to reflect the emphases in the emphases array.  "

	| selStart selEnd currEmphasis |
	labelString _ labelString asText.
	emphases isEmptyOrNil ifTrue: [^ self].
	selStart _ 1.
	1 to: selections size do:
		[:line |
			selEnd _ selStart + (selections at: line) size - 1.
			((currEmphasis _ emphases at: line) size > 0 and: [currEmphasis ~~ #plain]) ifTrue:
				[labelString addAttribute: (TextEmphasis perform: currEmphasis)
					from: selStart to: selEnd].
			selStart _ selEnd + 2]! !

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

EmphasizedMenu class
	instanceVariableNames: ''!

!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sw 12/23/96'!
selectionAndEmphasisPairs: interleavedList
	"An alternative form of call.  "
	| selList  emphList |
	selList _ OrderedCollection new.
	emphList _ OrderedCollection new.
	interleavedList pairsDo:
		[:aSel :anEmph |
			selList add: aSel.
			emphList add: anEmph].
	^ self selections:selList emphases: emphList! !

!EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:14'!
selections: selList emphases: emphList
	"Answer an instance of the receiver with the given selections and 
	emphases."

	^ (self selections: selList) emphases: emphList

"Example:
	(EmphasizedMenu
		selections: #('how' 'well' 'does' 'this' 'work?') 
		emphases: #(bold plain italic struckOut plain)) startUp"! !


!EmphasizedMenu class methodsFor: 'examples' stamp: 'sma 5/28/2000 16:16'!
example1
	"EmphasizedMenu example1"

	^ (self
		selections: #('how' 'well' 'does' 'this' 'work?' ) 
		emphases: #(#bold #plain #italic #struckOut #plain ))
			startUpWithCaption: 'A Menu with Emphases'! !

!EmphasizedMenu class methodsFor: 'examples' stamp: 'sw 9/11/97 16:14'!
example2
	"EmphasizedMenu example2"

	| aMenu |
	aMenu _ EmphasizedMenu selections: #('One' 'Two' 'Three' 'Four').
	aMenu onlyBoldItem: 3.
	^ aMenu startUpWithCaption: 'Only the Bold'! !

!EmphasizedMenu class methodsFor: 'examples' stamp: 'sma 5/28/2000 16:17'!
example3
	"EmphasizedMenu example3"

	^ (self
		selectionAndEmphasisPairs: #('how' #bold 'well' #plain 'does' #italic 'this' #struckOut 'work' #plain))
		startUpWithCaption: 'A Menu with Emphases'! !
ParseNode subclass: #Encoder
	instanceVariableNames: 'scopeTable nTemps supered requestor class literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!Encoder commentStamp: '<historical>' prior: 0!
I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.!


!Encoder methodsFor: 'initialize-release'!
fillDict: dict with: nodeClass mapping: keys to: codeArray
	| codeStream |
	codeStream _ ReadStream on: codeArray.
	keys do: 
		[:key | dict 
				at: key
				put:  (nodeClass new name: key key: key code: codeStream next)]! !

!Encoder methodsFor: 'initialize-release' stamp: 'di 12/4/1999 22:22'!
init: aClass context: aContext notifying: req
	| node n homeNode indexNode |
	requestor _ req.
	class _ aClass.
	nTemps _ 0.
	supered _ false.
	self initScopeAndLiteralTables.
	n _ -1.
	class allInstVarNames do: 
		[:variable | 
		node _ VariableNode new
					name: variable
					index: (n _ n + 1)
					type: LdInstType.
		scopeTable at: variable put: node].
	aContext == nil
		ifFalse: 
			[homeNode _ self bindTemp: 'homeContext'.
			"first temp = aContext passed as arg"
			n _ 0.
			aContext tempNames do: 
				[:variable | 
				indexNode _ self encodeLiteral: (n _ n + 1).
				node _ MessageAsTempNode new
							receiver: homeNode
							selector: #tempAt:
							arguments: (Array with: indexNode)
							precedence: 3
							from: self.
				scopeTable at: variable put: node]].
	sourceRanges _ Dictionary new: 32.
	globalSourceRanges _ OrderedCollection new: 32.
! !

!Encoder methodsFor: 'initialize-release'!
initScopeAndLiteralTables

	scopeTable _ StdVariables copy.
	litSet _ StdLiterals copy.
	selectorSet _ StdSelectors copy.
	litIndSet _ Dictionary new: 16.
	literalStream _ WriteStream on: (Array new: 32)! !

!Encoder methodsFor: 'initialize-release'!
nTemps: n literals: lits class: cl 
	"Decompile."

	class _ cl.
	nTemps _ n.
	literalStream _ ReadStream on: lits.
	literalStream position: lits size! !

!Encoder methodsFor: 'initialize-release'!
noteSuper

	supered _ true! !

!Encoder methodsFor: 'initialize-release'!
release

	requestor _ nil! !


!Encoder methodsFor: 'encoding'!
cantStoreInto: varName

	^StdVariables includesKey: varName! !

!Encoder methodsFor: 'encoding'!
encodeLiteral: object

	^self
		name: object
		key: (class literalScannedAs: object notifying: self)
		class: LiteralNode
		type: LdLitType
		set: litSet! !

!Encoder methodsFor: 'encoding'!
encodeSelector: selector

	^self
		name: selector
		key: selector
		class: SelectorNode
		type: SendType
		set: selectorSet! !

!Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 20:09'!
encodeVariable: name
	^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]! !

!Encoder methodsFor: 'encoding' stamp: 'ls 1/19/2001 12:59'!
encodeVariable: name ifUnknown: action
	^self encodeVariable: name sourceRange: nil ifUnknown: action! !

!Encoder methodsFor: 'encoding' stamp: 'ls 1/19/2001 12:58'!
encodeVariable: name sourceRange: range ifUnknown: action
	| varNode |
	varNode _ scopeTable at: name
			ifAbsent: 
				[(self lookupInPools: name 
					ifFound: [:assoc | varNode _ self global: assoc name: name])
					ifTrue: [varNode]
					ifFalse: [action value]].
	range ifNotNil: [
		name first isUppercase ifTrue:
			[globalSourceRanges addLast: { name. range. false }]. ].

	(varNode isTemp and: [varNode scope < 0]) ifTrue: [^self notify: 'out of scope'].

	^ varNode! !

!Encoder methodsFor: 'encoding'!
litIndex: literal
	| p |
	p _ literalStream position.
	p = 256 ifTrue:
		[self notify: 'More than 256 literals referenced. 
You must split or otherwise simplify this method.
The 257th literal is: ', literal printString. ^nil].
		"Would like to show where it is in the source code, 
		 but that info is hard to get."
	literalStream nextPut: literal.
	^ p! !

!Encoder methodsFor: 'encoding' stamp: 'di 1/7/2000 15:24'!
sharableLitIndex: literal
	"Special access prevents multiple entries for post-allocated super send special selectors"
	| p |
	p _ literalStream originalContents indexOf: literal.
	p = 0 ifFalse: [^ p-1].
	^ self litIndex: literal
! !

!Encoder methodsFor: 'encoding' stamp: 'tk 4/20/1999 15:41'!
undeclared: name

	| sym |
	requestor interactive ifTrue: [
		requestor requestor == #error: ifTrue: [requestor error: 'Undeclared'].
		^ self notify: 'Undeclared'].
	Transcript show: ' (' , name , ' is Undeclared) '.
	sym _ name asSymbol.
	Undeclared at: sym put: nil.
	^self global: (Undeclared associationAt: sym) name: sym! !


!Encoder methodsFor: 'temps'!
autoBind: name 
	"Declare a block argument as a temp if not already declared."
	| node |
	node _ scopeTable 
			at: name
			ifAbsent: 
				[(self lookupInPools: name ifFound: [:assoc | assoc])
					ifTrue: [self notify: 'Name already used in a Pool or Global'].
				^ (self reallyBind: name) nowHasDef nowHasRef scope: 1].
	node isTemp
		ifTrue: [node scope >= 0 ifTrue:
					[^ self notify: 'Name already used in this method'].
				node nowHasDef nowHasRef scope: 1]
		ifFalse: [^ self notify: 'Name already used in this class'].
	^node! !

!Encoder methodsFor: 'temps' stamp: 'di 10/12/1999 16:53'!
bindAndJuggle: name

	| node nodes first thisCode |
	node _ self reallyBind: name.

	"Declared temps must precede block temps for decompiler and debugger to work right"
	nodes _ self tempNodes.
	(first _ nodes findFirst: [:n | n scope > 0]) > 0 ifTrue:
		[node == nodes last ifFalse: [self error: 'logic error'].
		thisCode _ (nodes at: first) code.
		first to: nodes size - 1 do:
			[:i | (nodes at: i) key: (nodes at: i) key
							code: (nodes at: i+1) code].
		nodes last key: nodes last key code: thisCode].
	
	^ node! !

!Encoder methodsFor: 'temps' stamp: 'jm 9/18/97 21:06'!
bindArg: name 
	"Declare an argument."
	| node |
	nTemps >= 15
		ifTrue: [^self notify: 'Too many arguments'].
	node _ self bindTemp: name.
	^ node nowHasDef nowHasRef! !

!Encoder methodsFor: 'temps' stamp: 'crl 2/26/1999 12:18'!
bindBlockTemp: name 
	"Declare a temporary block variable; complain if it's not a field or class variable."

	| node |

	node _ scopeTable at: name ifAbsent: [^self reallyBind: name].
	node isTemp
		ifTrue: [
			node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method'].
			node scope: 0]
		ifFalse: [^self notify: 'Name already used in this class'].
	^node
! !

!Encoder methodsFor: 'temps' stamp: 'ar 7/12/1999 00:24'!
bindTemp: name 
	"Declare a temporary; error not if a field or class variable."
	scopeTable at: name ifPresent:[:node|
		"When non-interactive raise the error only if its a duplicate"
		(node isTemp or:[requestor interactive])
			ifTrue:[^self notify:'Name is already defined']
			ifFalse:[Transcript show: '(', name, ' is shadowed)']].
	^self reallyBind: name! !

!Encoder methodsFor: 'temps'!
maxTemp

	^nTemps! !

!Encoder methodsFor: 'temps'!
newTemp: name

	nTemps _ nTemps + 1.
	^ TempVariableNode new
		name: name
		index: nTemps - 1
		type: LdTempType
		scope: 0! !


!Encoder methodsFor: 'results'!
allLiterals
	supered ifTrue: [self litIndex: (self associationFor: class)].
	^ literalStream contents! !

!Encoder methodsFor: 'results' stamp: 'ar 2/13/1999 21:18'!
associationFor: aClass

	| name |
	name _ Smalltalk keyAtIdentityValue: aClass ifAbsent: [^Association new value: aClass].
	^Smalltalk associationAt: name! !

!Encoder methodsFor: 'results'!
literals
	"Should only be used for decompiling primitives"
	^ literalStream contents! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 16:12'!
tempNames 

	^ self tempNodes collect:
		[:node | (node isMemberOf: MessageAsTempNode)
					ifTrue: [scopeTable keyAtValue: node]
					ifFalse: [node key]]! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 15:31'!
tempNodes 
	| tempNodes |
	tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code].
	scopeTable associationsDo:
		[:assn | assn value isTemp ifTrue: [tempNodes add: assn value]].
	^ tempNodes! !

!Encoder methodsFor: 'results'!
tempsAndBlockArgs
	| tempNodes var |
	tempNodes _ OrderedCollection new.
	scopeTable associationsDo:
		[:assn | var _ assn value.
		((var isTemp and: [var isArg not])
					and: [var scope = 0 or: [var scope = -1]])
			ifTrue: [tempNodes add: var]].
	^ tempNodes! !

!Encoder methodsFor: 'results' stamp: 'di 10/12/1999 17:15'!
unusedTempNames 
	| unused name |
	unused _ OrderedCollection new.
	scopeTable associationsDo:
		[:assn | (assn value isUnusedTemp)
			ifTrue: [name _ assn value key.
					name ~= 'homeContext' ifTrue: [unused add: name]]].
	^ unused! !


!Encoder methodsFor: 'error handling'!
notify: string
	"Put a separate notifier on top of the requestor's window"
	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string].
	^false! !

!Encoder methodsFor: 'error handling'!
notify: string at: location

	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string at: location].
	^false! !

!Encoder methodsFor: 'error handling'!
requestor: req
	"Often the requestor is a BrowserCodeController"
	requestor _ req! !


!Encoder methodsFor: 'source mapping' stamp: 'di 12/4/1999 22:27'!
globalSourceRanges

	^ globalSourceRanges! !

!Encoder methodsFor: 'source mapping'!
noteSourceRange: range forNode: node

	sourceRanges at: node put: range! !

!Encoder methodsFor: 'source mapping' stamp: 'RAA 8/21/1999 06:52'!
rawSourceRanges

	^ sourceRanges ! !

!Encoder methodsFor: 'source mapping'!
sourceMap
	"Answer with a sorted set of associations (pc range)."

	^ (sourceRanges keys collect: 
		[:key |  Association key: key pc value: (sourceRanges at: key)])
			asSortedCollection! !


!Encoder methodsFor: 'private'!
classEncoding
	"This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view."
	^ class! !

!Encoder methodsFor: 'private'!
global: ref name: name

	^self
		name: name
		key: ref
		class: VariableNode
		type: LdLitIndType
		set: litIndSet! !

!Encoder methodsFor: 'private' stamp: 'di 12/4/1999 16:51'!
lookupInPools: varName ifFound: assocBlock

	Symbol hasInterned: varName ifTrue:
		[:sym | (class scopeHas: sym ifTrue: assocBlock) ifTrue: [^ true].
		(Preferences valueOfFlag: #lenientScopeForGlobals)  "**Temporary**"
			ifTrue: [^ Smalltalk lenientScopeHas: sym ifTrue: assocBlock]
			ifFalse: [^ false]].
	^ class scopeHas: varName ifTrue: assocBlock.  "Maybe a string in a pool  **Eliminate this**"! !

!Encoder methodsFor: 'private'!
name: name key: key class: leafNodeClass type: type set: dict

	| node |
	^dict 
		at: key
		ifAbsent: 
			[node _ leafNodeClass new
						name: name
						key: key
						index: nil
						type: type.
			dict at: key put: node.
			^node]! !

!Encoder methodsFor: 'private'!
possibleVariablesFor: proposedVariable

	| results |
	results _ proposedVariable correctAgainstDictionary: scopeTable
								continuedFrom: nil.
	proposedVariable first isUppercase ifTrue:
		[ results _ class possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results.
! !

!Encoder methodsFor: 'private'!
reallyBind: name

	| node |
	node _ self newTemp: name.
	scopeTable at: name put: node.
	^node! !
Error subclass: #EndOfStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Extensions'!
!EndOfStream commentStamp: '<historical>' prior: 0!
Signalled when ReadStream>>next encounters a premature end.!


!EndOfStream methodsFor: 'description' stamp: 'hh 5/17/2000 00:30'!
isResumable
	"EndOfStream is resumable, so ReadStream>>next can answer"

	^ true! !


!EndOfStream methodsFor: 'exceptionDescription' stamp: 'RAA 5/17/2000 03:10'!
defaultAction
	"Answer ReadStream>>next default reply."

	^ nil! !
Object subclass: #Envelope
	instanceVariableNames: 'points loopStartIndex loopEndIndex loopStartMSecs loopMSecs target updateSelector loopEndMSecs endMSecs scale decayScale lastValue currValue valueIncr nextRecomputeTime noChangesDuringLoop '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!Envelope commentStamp: '<historical>' prior: 0!
An envelope models a three-stage progression for a musical note: attack, sustain, decay. Envelopes can either return the envelope value at a given time or can update some target object using a client-specified message selector.

The points instance variable holds an array of (time, value) points, where the times are in milliseconds. The points array must contain at least two points. The time coordinate of the first point must be zero and the time coordinates of subsequent points must be in ascending order, although the spacing between them is arbitrary. Envelope values between points are computed by linear interpolation.

The scale slot is initially set so that the peak of envelope matches some note attribute, such as its loudness. When entering the decay phase, the scale is adjusted so that the decay begins from the envelope's current value. This avoids a potential sharp transient when entering the decay phase.

The loopStartIndex and loopEndIndex slots contain the indices of points in the points array; if they are equal, then the envelope holds a constant value for the sustain phase of the note. Otherwise, envelope values are computed by repeatedly looping between these two points.

The loopEndMSecs slot can be set in advance (as when playing a score) or dynamically (as when responding to interactive inputs from a MIDI keyboard). In the latter case, the value of scale is adjusted to start the decay phase with the current envelope value. Thus, if a note ends before its attack is complete, the decay phase is started immediately (i.e., the attack phase is never completed).

For best results, amplitude envelopes should start and end with zero values. Otherwise, the sharp transient at the beginning or end of the note may cause audible clicks or static. For envelopes on other parameters, this may not be necessary.
!


!Envelope methodsFor: 'accessing' stamp: 'jm 8/17/1998 15:20'!
attackTime
	"Return the time taken by the attack phase."

	^ (points at: loopStartIndex) x
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:10'!
centerPitch: aNumber
	"Set the center pitch of a pitch-controlling envelope. This default implementation does nothing."
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 10:21'!
decayEndIndex

	^ points size
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 08:53'!
decayTime
	"Return the time taken by the decay phase."

	^ points last x - (points at: loopEndIndex) x
! !

!Envelope methodsFor: 'accessing' stamp: 'di 1/20/98 21:35'!
duration
	"Return the time of the final point."

	loopEndMSecs == nil
		ifTrue: [^ points last x]
		ifFalse: [^ loopEndMSecs + self decayTime].
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/19/1998 09:07'!
duration: seconds
	"Set the note duration to the given number of seconds."
	"Details: The duration is reduced by 19 mSec to ensure proper cutoffs even when the sound starts playing between doControl epochs."
	"Note: This is a hack. With a little additional work on the envelope logic, it should be possible to reduce or eliminate this fudge factor. In particular, an envelope should use the time remaining, rather than time-since-start to determine when to enter its decay phase. In addition, an envelope must be able to cut off in minimum time (~5-10 msec) if there isn't enough time to do their normal decay. All of this is to allow instruments with leisurely decays to play very short notes if necessary (say, when fast-forwarding through a score)." 

	| attack decay endTime |
	endMSecs _ (seconds * 1000.0) asInteger - 19.
	attack _ self attackTime.
	decay _ self decayTime.
	endMSecs > (attack + decay)
		ifTrue: [endTime _ endMSecs - decay]
		ifFalse: [
			endMSecs >= attack
				ifTrue: [endTime _ attack]
				ifFalse: [endTime _ endMSecs]].

	self sustainEnd: (endTime max: 0).
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
loopEndIndex

	^ loopEndIndex
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
loopStartIndex

	^ loopStartIndex
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:03'!
name

	^ self updateSelector allButLast
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 2/4/98 17:24'!
points

	^ points
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:36'!
scale

	^ scale
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:36'!
scale: aNumber

	scale _ aNumber asFloat.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 09:25'!
target

	^ target
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 09:25'!
target: anObject

	target _ anObject.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/24/97 14:34'!
updateSelector

	^ updateSelector
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 11/26/97 08:52'!
updateSelector: aSymbol

	updateSelector _ aSymbol.
! !

!Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:13'!
volume: aNumber
	"Set the maximum volume of a volume-controlling envelope. This default implementation does nothing."
! !


!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 21:07'!
computeValueAtMSecs: mSecs
	"Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."
	"Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals."

	| t i |
	mSecs < 0 ifTrue: [^ 0.0].

	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [^ 0.0].  "past end"
		^ (self interpolate: t between: (points at: i - 1) and: (points at: i)) * decayScale].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i _ self indexOfPointAfterMSecs: mSecs startingAt: 1.
		i = 1 ifTrue: [^ (points at: 1) y * scale].
		^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)].

	"sustain phase"
	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale].  "looping on a single point"
	t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.

	^ self interpolate: t between: (points at: i - 1) and: (points at: i)
! !

!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 21:15'!
reset
	"Reset the state for this envelope."

	lastValue _ -100000.0.  "impossible value"
	nextRecomputeTime _ 0.
	self updateTargetAt: 0.
! !

!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 17:39'!
showOnDisplay
	"Envelope example showOnDisplay"

	| xOrigin yOrigin minVal maxVal yScale step x v y |
	xOrigin _ 30.
	yOrigin _ 130.
	minVal _ 1e100.
	maxVal _ -1e100.
	points do: [:p |
		p y < minVal ifTrue: [minVal _ p y].
		p y > maxVal ifTrue: [maxVal _ p y]].

	yScale _ 100.0 / ((maxVal - minVal) * scale).
	step _ (self duration // 150) max: 1.

	Display fillBlack: ((xOrigin + ((points at: loopStartIndex) x // step))@(yOrigin - 100) extent: 1@100).
	Display fillBlack: ((xOrigin + ((points at: loopEndIndex) x // step))@(yOrigin - 100) extent: 1@100).
	Display fillBlack: (xOrigin@(yOrigin - 100) extent: 1@100).
	x _ xOrigin.
	step negated to: self duration + step by: step do: [:mSecs |
		v _ self computeValueAtMSecs: mSecs.
		y _ yOrigin - ((v - minVal) * yScale) asInteger.
		Display fillBlack: ((x - 1)@(y - 1) extent: 2@2).
		Display fillBlack: (x@yOrigin extent: 1@1).
		x _ x + 1].
! !

!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 18:27'!
sustainEnd: mSecs
	"Set the ending time of the sustain phase of this envelope; the decay phase will start this point. Typically derived from a note's duration."
	"Details: to avoid a sharp transient, the decay phase is scaled so that the beginning of the decay matches the envelope's instantaneous value when the decay phase starts."

	| vIfSustaining firstVOfDecay |
	loopEndMSecs _ nil. "pretend to be sustaining"
	decayScale _ 1.0.
	nextRecomputeTime _ 0.
	vIfSustaining _ self computeValueAtMSecs: mSecs.  "get value at end of sustain phase"
	loopEndMSecs _ mSecs.
	firstVOfDecay _ (points at: loopEndIndex) y * scale.
	firstVOfDecay = 0.0
		ifTrue: [decayScale _ 1.0]
		ifFalse: [decayScale _ vIfSustaining / firstVOfDecay].
! !

!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 19:46'!
updateTargetAt: mSecs
	"Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."

	| newValue |
	newValue _ self valueAtMSecs: mSecs.
	newValue = lastValue ifTrue: [^ false].
	target
		perform: updateSelector
		with: newValue.
	lastValue _ newValue.
	^ true
! !

!Envelope methodsFor: 'applying' stamp: 'jm 2/4/98 20:24'!
valueAtMSecs: mSecs
	"Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."

	mSecs < 0 ifTrue: [^ 0.0].
	mSecs < nextRecomputeTime
		ifTrue: [currValue _ currValue + valueIncr]
		ifFalse: [currValue _ self incrementalComputeValueAtMSecs: mSecs].
	^ currValue
! !


!Envelope methodsFor: 'storing' stamp: 'di 2/1/98 15:45'!
storeOn: strm
	strm nextPutAll: '((' , self class name;
		nextPutAll: ' points: '; store: (points collect: [:p | p x @ (p y roundTo: 0.00001)]);
		nextPutAll: ' loopStart: '; print: loopStartIndex;
		nextPutAll: ' loopEnd: '; print: loopEndIndex; nextPutAll: ')';
		nextPutAll: ' updateSelector: '; store: self updateSelector; nextPutAll: ';';
		nextPutAll: ' scale: '; print: scale; nextPutAll: ')'.
! !


!Envelope methodsFor: 'private' stamp: 'jm 11/26/97 09:03'!
checkParameters
	"Verify that the point array, loopStartIndex, and loopStopIndex obey the rules."

	| lastT t |
	points size > 1
		ifFalse: [^ self error: 'the point list must contain at least two points'].
	points first x = 0
		ifFalse: [^ self error: 'the time of the first point must be zero'].
	lastT _ points first x.
	2 to: points size do: [:i |
		t _ (points at: i) x.
		t >= lastT
			ifFalse: [^ self error: 'the points must be in ascending time order']].

	(loopStartIndex isInteger and:
	 [(loopStartIndex > 0) and: [loopStartIndex <= points size]])
		ifFalse: [^ self error: 'loopStartIndex is not a valid point index'].
	(loopEndIndex isInteger and:
	 [(loopEndIndex > 0) and: [loopEndIndex <= points size]])
		ifFalse: [^ self error: 'loopEndIndex is not a valid point index'].
	 loopStartIndex <= loopEndIndex
		ifFalse: [^ self error: 'loopEndIndex must not precede loopStartIndex'].
! !

!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 20:20'!
computeIncrementAt: mSecs between: p1 and: p2 scale: combinedScale
	"Compute the current and increment values for the given time between the given inflection points."
	"Assume: p1 x <= mSecs <= p2 x"

	| valueRange timeRange |
	valueRange _ (p2 y - p1 y) asFloat.
	timeRange _ (p2 x - p1 x) asFloat.
	currValue _ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * combinedScale.
	valueIncr _ (((p2 y * combinedScale) - currValue) / (p2 x - mSecs)) * 10.0.
	^ currValue
! !

!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 20:22'!
incrementalComputeValueAtMSecs: mSecs
	"Compute the current value, per-step increment, and the time of the next inflection point."
	"Note: This method is part of faster, but less general, way of computing envelope values. It depends on a known, fixed control updating rate."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [  "past end"
			currValue _ points last y * scale * decayScale.
			valueIncr _ 0.0.
			nextRecomputeTime _ mSecs + 1000000.
			^ currValue].
		nextRecomputeTime _ mSecs + ((points at: i) x - t).
		^ self computeIncrementAt: t
			between: (points at: i - 1)
			and: (points at: i)
			scale: scale * decayScale].

	mSecs < loopStartMSecs
		ifTrue: [  "attack phase"
			t _ mSecs.
			i _ self indexOfPointAfterMSecs: t startingAt: 1.
			nextRecomputeTime _ mSecs + ((points at: i) x - t)]
		ifFalse: [  "sustain (looping) phase"
			noChangesDuringLoop ifTrue: [
				currValue _ (points at: loopEndIndex) y * scale.
				valueIncr _ 0.0.
				loopEndMSecs == nil
					ifTrue: [nextRecomputeTime _ mSecs + 10]  "unknown end time"
					ifFalse: [nextRecomputeTime _ loopEndMSecs].
				^ currValue].
			t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
			i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
			nextRecomputeTime _ (mSecs + ((points at: i) x - t)) min: loopEndMSecs].

	^ self computeIncrementAt: t
		between: (points at: i - 1)
		and: (points at: i)
		scale: scale.
! !

!Envelope methodsFor: 'private' stamp: 'jm 12/16/97 16:51'!
indexOfPointAfterMSecs: mSecs startingAt: startIndex
	"Return the index of the first point whose time is greater that mSecs, starting with the given index. Return nil if mSecs is after the last point's time."

	startIndex to: points size do:
		[:i | (points at: i) x > mSecs ifTrue: [^ i]].
	^ nil
! !

!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 21:05'!
interpolate: mSecs between: p1 and: p2
	"Return the scaled, interpolated value for the given time between the given time points."
	"Assume: p1 x <= mSecs <= p2 x"

	| valueRange timeRange |
	valueRange _ (p2 y - p1 y) asFloat.
	valueRange = 0.0 ifTrue: [^ p1 y * scale].
	timeRange _ (p2 x - p1 x) asFloat.
	^ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * scale.
! !

!Envelope methodsFor: 'private' stamp: 'jm 2/4/98 17:52'!
setPoints: pointList loopStart: startIndex loopEnd: endIndex

	| lastVal |
	points _ pointList asArray collect: [:p | p x asInteger @ p y asFloat].
	loopStartIndex _ startIndex.
	loopEndIndex _ endIndex.
	self checkParameters.
	loopStartMSecs _ (points at: loopStartIndex) x.
	loopMSecs _ (points at: loopEndIndex) x - (points at: loopStartIndex) x.
	loopEndMSecs _ nil.  "unknown end time; sustain until end time is known"
	scale ifNil: [scale _ 1.0].
	decayScale ifNil: [decayScale _ 1.0].

	"note if there are no changes during the loop phase"
	noChangesDuringLoop _ true.
	lastVal _ (points at: loopStartIndex) y.
	loopStartIndex to: loopEndIndex do: [:i | 
		(points at: i) y ~= lastVal ifTrue: [
			noChangesDuringLoop _ false.
			^ self]].
! !

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

Envelope class
	instanceVariableNames: ''!

!Envelope class methodsFor: 'instance creation' stamp: 'jm 11/26/97 09:14'!
example
	"Envelope example showOnDisplay"

	| p |
	p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0.
	^ (self points: p loopStart: 2 loopEnd: 4) sustainEnd: 1200.
! !

!Envelope class methodsFor: 'instance creation' stamp: 'jm 2/4/98 06:52'!
exponentialDecay: multiplier
	"(Envelope exponentialDecay: 0.95) showOnDisplay"

	| mSecsPerStep pList t v last |
	mSecsPerStep _ 10.
	((multiplier > 0.0) and: [multiplier < 1.0])
		ifFalse: [self error: 'multiplier must be greater than 0.0 and less than 1.0'].
	pList _ OrderedCollection new.
	pList add: 0@0.0.
	last _ 0.0.
	v _ 1.0.
	t _ 10.
	[v > 0.01] whileTrue: [
		(v - last) abs > 0.02 ifTrue: [
			"only record substatial changes"
			pList add: t@v.
			last _ v].
		t _ t + mSecsPerStep.
		v _ v * multiplier].
	pList add: (t + mSecsPerStep)@0.0.

	^ self points: pList asArray
		loopStart: pList size 
		loopEnd: pList size
! !

!Envelope class methodsFor: 'instance creation' stamp: 'jm 11/26/97 08:49'!
points: pList loopStart: loopStart loopEnd: loopEnd

	^ self new setPoints: pList asArray
		loopStart: loopStart
		loopEnd: loopEnd
! !
RectangleMorph subclass: #EnvelopeEditorMorph
	instanceVariableNames: 'sound soundName envelope hScale vScale graphArea pixPerTick limits limitXs limitHandles line prevMouseDown sampleDuration showAllEnvelopes denominator keyboard '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 1/31/98 10:41'!
editEnvelope: env
	envelope _ env.
	limits _ Array with: envelope loopStartIndex
				with: envelope loopEndIndex
				with: envelope points size.
	limitXs _ limits collect: [:i | (envelope points at: i) x].
	self buildView! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'JMV 1/9/2001 13:43'!
editSound: aSound

	| p |
	(aSound respondsTo: #envelopes)
		ifFalse: [
			PopUpMenu inform: 'You selected a ', aSound class name, '.', String cr,
				'I can''t handle these kinds of sounds.'.
			^self ].
	sound _ aSound.
	sound envelopes isEmpty ifTrue: [
		"provide a default volume envelope"
		p _ OrderedCollection new.
		p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
		sound addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3)].

	self editEnvelope: sound envelopes first.
	keyboard soundPrototype: sound.
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 9/5/1998 10:40'!
initOnSound: aSound title: title
	sound _ aSound.
	soundName _ title.
	self initialize.
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 7/14/2000 12:48'!
initialize
	super initialize.
	prevMouseDown _ false.
	showAllEnvelopes _ true.
	soundName ifNil: [soundName _ 'test'].
	self editSound: (sound ifNil: [FMSound brass1 copy]).
	sound duration: 0.25.
	denominator _ 7.
	self extent: 10@10.  "ie the minimum"
! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 11/7/2000 12:45'!
soundBeingEdited

	^ sound! !

!EnvelopeEditorMorph methodsFor: 'initialization' stamp: 'di 7/14/2000 11:13'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 7/14/2000 13:08'!
addControls
	| chooser |
	chooser _ PopUpChoiceMorph new extent: 110@14;
		contentsClipped: 'Editing: ' , envelope name;
		target: self;
		actionSelector: #chooseFrom:envelopeItem:;
		getItemsSelector: #curveChoices.
	chooser arguments: (Array with: chooser).
	self addMorph: chooser.
	chooser align: chooser bounds topLeft with: graphArea bounds bottomLeft + (0@5).

	chooser _ PopUpChoiceMorph new extent: 130@14;
		contentsClipped: 'Timbre: ' , soundName;
		target: self;
		actionSelector: #chooseFrom:soundItem:;
		getItemsSelector: #soundChoices.
	chooser arguments: (Array with: chooser).
	self addMorph: chooser.
	chooser align: chooser bounds topRight with: graphArea bounds bottomRight + (-50@5).
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 2/1/98 11:54'!
addCurves
	"Add the polyLine corresponding to the currently selected envelope,
	and possibly all the others, too."
	| verts aLine |
	sound envelopes do:
		[:env | 
		(showAllEnvelopes or: [env == envelope]) ifTrue:
			[verts _ env points collect:
				[:p | (self xFromMs: p x) @ (self yFromValue: p y)].
			aLine _ EnvelopeLineMorph basicNew
						vertices: verts borderWidth: 1
						borderColor: (self colorForEnvelope: env).
			env == envelope
				ifTrue: [aLine borderWidth: 2.  line _ aLine]
				ifFalse: [aLine on: #mouseUp send: #clickOnLine:evt:envelope:
							to: self withValue: env.
						self addMorph: aLine]]].
	self addMorph: line  "add the active one last (in front)"! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 10/25/2000 17:47'!
addHandlesIn: frame
	| handle |
	handle := PolygonMorph
		vertices: (Array with: 0@0 with: 8@0 with: 4@8)
		color: Color orange borderWidth: 1 borderColor: Color black.
	handle addMorph: ((RectangleMorph
			newBounds: ((self handleOffset: handle)-(2@0) extent: 1@(graphArea height-2))
			color: Color orange) borderWidth: 0).

	limitHandles _ Array with: handle with: handle fullCopy with: handle fullCopy.
	1 to: limitHandles size do:
		[:i | handle _ limitHandles at: i.
		handle on: #mouseDown
				send: #limitHandleMoveEvent:from:index:
				to: self withValue: i.
		handle on: #mouseMove
				send: #limitHandleMoveEvent:from:index:
				to: self withValue: i.
		self addMorph: handle.
		handle position: ((self xFromMs: (envelope points at: (limits at: i)) x) @ (graphArea top)) - (self handleOffset: handle)]! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 15:49'!
addKeyboard
	keyboard _ PianoKeyboardMorph new soundPrototype: sound.
	keyboard align: keyboard bounds bottomCenter with: bounds bottomCenter - (0@4).
	self addMorph: keyboard! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 15:56'!
buildGraphAreaIn: frame
	| r y |
	graphArea _ RectangleMorph
		newBounds: ((frame left + 40) @ (frame top + 40)
		corner: (frame right+1) @ (frame bottom - 60))
		color: Color lightGreen lighter lighter.
	graphArea borderWidth: 1.
	self addMorph: graphArea.
	(envelope updateSelector = #pitch: and: [envelope scale <= 2.0]) ifTrue:
		["Show half-steps"
		r _ graphArea innerBounds.
		0.0 to: 1.0 by: 1.0/12.0/envelope scale do:
			[:val |
			y _ self yFromValue: val.
			graphArea addMorph: ((RectangleMorph
					newBounds: (r left@y extent: r width@1)
					color: Color veryLightGray)
						borderWidth: 0)]].
	(envelope updateSelector = #ratio: and: [denominator ~= 9999]) ifTrue:
		["Show denominator gridding"
		r _ graphArea innerBounds.
		(0.0 to: 1.0 by: 1.0/denominator/envelope scale) do:
			[:v |
			y _ self yFromValue: v.
			graphArea addMorph: ((RectangleMorph
					newBounds: (r left@y extent: r width@1)
					color: Color veryLightGray)
						borderWidth: 0)]].
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 9/4/1998 13:16'!
buildView
	| frame |
	self color: Color lightGreen.
	self removeAllMorphs.
	frame _ self innerBounds.
	self buildGraphAreaIn: frame.
	self buildScalesIn: frame.
	self addHandlesIn: frame.
	self addCurves.
	line addHandles.
	self addControls.
	self addKeyboard! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 2/3/98 16:50'!
colorForEnvelope: env
	| name index |
	name _ env name.
	index _ #('volume' 'modulation' 'pitch' 'ratio') indexOf: name
				ifAbsent: [5].
	^ Color perform: (#(red green blue magenta black) at: index)! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'JMV 1/29/2001 10:58'!
curveChoices
	| extant others |
	extant _ sound envelopes collect: [:env | env name].
	others _ #('volume' 'modulation' 'pitch' 'random pitch:' 'ratio')
		reject: [:x | (extant includes: x) | ((x = 'pitch') & (extant includes: 'random pitch:')) | ((x = 'random pitch:') & (extant includes: 'pitch')) ].
	^ (extant collect: [:name | 'edit ' , name])
	, (others collect: [:name | 'add ' , name])
	, (sound envelopes size > 1
		ifTrue: [Array with: 'remove ' , envelope name]
		ifFalse: [Array new])! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 1/26/98 15:37'!
handleOffset: handle
	"This is the offset from position to the bottom vertex"
	^ (handle width//2+1) @ handle height
! !

!EnvelopeEditorMorph methodsFor: 'construction' stamp: 'di 7/14/2000 12:56'!
soundChoices
	^ #('new...') , AbstractSound soundNames! !


!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 9/4/1998 16:03'!
extent: newExtent
	super extent: (newExtent max: (self maxTime//10*3+50 max: 355) @ 284).
	self buildView! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/27/98 14:40'!
maxTime
	^ (envelope points at: limits last) x + 100! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/26/98 14:10'!
msFromX: x
	^ (x - graphArea left)//pixPerTick*10! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/31/98 01:10'!
valueFromY: y
	"The convention is that envelope values are between 0.0 and 1.0"
	| value |
	value _ (graphArea bottom - y) asFloat / (graphArea height).
	envelope updateSelector = #ratio: ifTrue:
		["Ratio gets gridded by denominator"
		^ (value * envelope scale * denominator) rounded asFloat / denominator / envelope scale].
	^ value! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/26/98 14:09'!
xFromMs: ms
	^ graphArea left + (ms//10*pixPerTick)! !

!EnvelopeEditorMorph methodsFor: 'scaling' stamp: 'di 1/27/98 00:23'!
yFromValue: val
	"The convention is that envelope values are between 0.0 and 1.0"
	^ graphArea bottom - (val* (graphArea height))! !


!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:40'!
acceptGraphPoint: p at: index
	| ms val points whichLim linePoint other boundedP |
	boundedP _ p adhereTo: graphArea bounds.
	ms _ self msFromX: boundedP x.
	points _ envelope points.
	ms _ self constrain: ms adjacentTo: index in: points.
	(index = 1 or: [(whichLim _ limits indexOf: index) > 0]) ifTrue:
		["Limit points must not move laterally"
		ms _ (points at: index) x].
	val _ self valueFromY: boundedP y.
	points at: index put: ms@val.
	linePoint _ (self xFromMs: ms) @ (self yFromValue: val).
	(whichLim notNil and: [whichLim between: 1 and: 2]) ifTrue:
		["Loop start and loop end must be tied together"
		other _ limits at: (3 - whichLim).  " 1 <--> 2 "
		points at: other put: (points at: other) x @ val.
		line verticesAt: other put: (line vertices at: other) x @ linePoint y].
	"Make sure envelope feels the change in points array..."
	envelope setPoints: points loopStart: (limits at: 1) loopEnd: (limits at: 2).
	^ linePoint! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'JMV 1/29/2001 10:57'!
addEnvelopeNamed: envName
	| points env |
	points _ OrderedCollection new.
	points add: 0@0.0;
		add: (envelope points at: envelope loopStartIndex) x@1.0;
		add: (envelope points at: envelope loopEndIndex) x@1.0;
		add: (envelope points last) x@0.0.
	envName = 'volume' ifTrue:
		[env _ VolumeEnvelope points: points loopStart: 2 loopEnd: 3.
		env target: sound; scale: 0.7].
	envName = 'modulation' ifTrue:
		[env _ Envelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #modulation:;
			scale: sound modulation*2.0].
	envName = 'pitch' ifTrue:
		[env _ PitchEnvelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #pitch:; scale: 0.5].
	envName = 'random pitch:' ifTrue:
		[env _ RandomEnvelope for: #pitch:.
		points _ OrderedCollection new.
		points add: 0@(env delta * 5 + 0.5);
			add: (envelope points at: envelope loopStartIndex) x@(env highLimit - 1 * 5 + 0.5);
			add: (envelope points at: envelope loopEndIndex) x@(env highLimit - 1 * 5 + 0.5);
			add: (envelope points last) x@(env lowLimit - 1 * 5 + 0.5).
		env setPoints: points loopStart: 2 loopEnd: 3.
		env target: sound. ].
	envName = 'ratio' ifTrue:
		[denominator _ 9999.  "No gridding"
		env _ Envelope points: (points collect: [:p | p x @ 0.5])
						loopStart: 2 loopEnd: 3.
		env target: sound; updateSelector: #ratio:;
			scale: sound ratio*2.0].
	env ifNotNil:
		[sound addEnvelope: env.
		self editEnvelope: env]! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'JMV 1/26/2001 11:28'!
buildScalesIn: frame
	| env hmajortick hminortick |
	env _ envelope.
	pixPerTick _ graphArea width // (self maxTime//10) max: 1.
	hminortick _ ( 1 + ( self maxTime // 800 ) ) * 10.
	hmajortick _ ( 1 + ( self maxTime // 800 ) ) * 100.
	hScale _ (ScaleMorph newBounds: ((graphArea left)@(frame top) corner: (self xFromMs: self maxTime)@(graphArea top - 1)))
		start: 0 stop: self maxTime
		minorTick: hminortick minorTickLength: 3
		majorTick: hmajortick majorTickLength: 10
		caption: 'milliseconds' tickPrintBlock: [:v | v printString].
	self addMorph: hScale.
	vScale _ ScaleMorph newBounds: (0@0 extent: (graphArea height)@(graphArea left - frame left)).
	env name = 'pitch'
		ifTrue:
		[env scale >= 2.0
			ifTrue:
			[vScale start: 0 stop: env scale
				minorTick: env scale / 24 minorTickLength: 3
				majorTick: env scale / 2.0 majorTickLength: 10
				caption: 'pitch (octaves)'
				tickPrintBlock: [:v | (v-(env scale/2)) asInteger printString]]
			ifFalse:
			[vScale start: 0 stop: env scale
				minorTick: 1.0/48.0 minorTickLength: 3
				majorTick: 1.0/12.0 majorTickLength: 10
				caption: 'pitch (half-steps)'
				tickPrintBlock: [:v | (v-(env scale/2)*12) rounded printString]]]
		ifFalse: [
			env name = 'random pitch:'
				ifTrue: [
					vScale start: 0.9 stop: 1.1
						minorTick: 0.2 / 50.0 minorTickLength: 3
						majorTick: 0.2 / 5.0 majorTickLength: 10
						caption: env name
						tickPrintBlock: [:v | v printString]]
				ifFalse: [
					vScale start: 0 stop: env scale
						minorTick: env scale / 50.0 minorTickLength: 3
						majorTick: env scale / 5.0 majorTickLength: 10
						caption: env name
						tickPrintBlock: [:v | v printString]].
		].
	vScale _ TransformationMorph new asFlexOf: vScale.
	vScale angle: Float pi / 2.0.
	self addMorph: vScale.
	vScale position: (frame left)@(graphArea top-1) - (3@1).
! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 1/31/98 11:53'!
clickOnLine: aLine evt: anEvent envelope: env
	self editEnvelope: env! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 1/29/98 13:06'!
constrain: xVal adjacentTo: ix in: points
	"Return xVal, restricted between points adjacent to vertX"
	| newVal |
	newVal _ xVal.
	ix > 1 ifTrue: [newVal _ newVal max: (points at: ix-1) x].
	ix < points size ifTrue: [newVal _ newVal min: (points at: ix+1) x].
	^ newVal! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 1/28/98 20:19'!
deletePoint: ix
	"If the point is a limit point, return false,
	otherwise, delete the point at ix, and return true."
	(limits includes: ix) ifTrue: [^ false].
	1 to: limits size do:
		[:i |  "Decrease limit indices beyond the deletion"
		(limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) - 1]].
	envelope setPoints: (envelope points copyReplaceFrom: ix to: ix with: (Array new))
			 loopStart: (limits at: 1) loopEnd: (limits at: 2).
	^ true! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 1/28/98 20:20'!
insertPointAfter: ix
	"If there is not enough roon (in x) then return false.
	Otherwise insert a point between ix and ix+1 and return true."
	| points pt |
	points _ envelope points.
	(points at: ix+1) x - (points at: ix) x < 20 ifTrue: [^ false].
	pt _ (points at: ix+1) + (points at: ix) // 2.
	1 to: limits size do:
		[:i |  "Increase limit indices beyond the insertion"
		(limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) + 1]].
	envelope setPoints: (points copyReplaceFrom: ix+1 to: ix with: (Array with: pt))
			 loopStart: (limits at: 1) loopEnd: (limits at: 2).
	^ true! !

!EnvelopeEditorMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:41'!
limitHandleMoveEvent: evt from: handle index: index
	"index is the handle index = 1, 2 or 3"
	| ix p ms x points limIx |
	ix _ limits at: index.  "index of corresponding vertex"
	p _ evt cursorPoint adhereTo: graphArea bounds.
	ms _ self msFromX: p x + (self handleOffset: handle) x.

	"Constrain move to adjacent points on ALL envelopes"
	sound envelopes do:
		[:env | limIx _ env perform:
			(#(loopStartIndex loopEndIndex decayEndIndex) at: index).
		ms _ self constrain: ms adjacentTo: limIx in: env points].

	"Update the handle, the vertex and the line being edited"
	x _ self xFromMs: ms.
	handle position: (x @ graphArea top) - (self handleOffset: handle).
	line verticesAt: ix put: x @ (line vertices at: ix) y.

	sound envelopes do:
		[:env | limIx _ env perform:
			(#(loopStartIndex loopEndIndex decayEndIndex) at: index).
		points _ env points.
		points at: limIx put: ms @ (points at: limIx) y.
		env setPoints: points loopStart: env loopStartIndex loopEnd: env loopEndIndex].! !


!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 9/5/1998 10:45'!
addCustomMenuItems: menu hand: aHandMorph
	super addCustomMenuItems: menu hand: aHandMorph.
	menu addLine.
	envelope updateSelector = #ratio: ifTrue:
		[menu add: 'choose denominator...' action: #chooseDenominator:].
	menu add: 'adjust scale...' action: #adjustScale:.
	SoundPlayer isReverbOn
		ifTrue: [menu add: 'turn reverb off' target: SoundPlayer selector: #stopReverb]
		ifFalse: [menu add: 'turn reverb on' target: SoundPlayer selector: #startReverb].
	menu addLine.
	menu add: 'get sound from lib' action: #chooseSound:.
	menu add: 'put sound in lib' action: #saveSound:.
	menu add: 'read sound from disk...' action: #readFromDisk:.
	menu add: 'save sound on disk...' action: #saveToDisk:.
	menu add: 'save library on disk...' action: #saveLibToDisk:.
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/17/98 12:02'!
adjustScale: evt
	| scaleString oldScale baseValue |
	oldScale _ envelope scale.
	scaleString _ FillInTheBlank request: 'Enter the new full-scale value...'
						initialAnswer: oldScale printString.
	scaleString isEmpty ifTrue: [^ self].
	envelope scale: (Number readFrom: scaleString) asFloat.
	baseValue _ envelope updateSelector = #pitch: ifTrue: [0.5] ifFalse: [0.0].
	envelope setPoints: (envelope points collect:
				[:p |
				p x @ (p y - baseValue * oldScale / envelope scale + baseValue
					min: 1.0 max: 0.0)])
			 loopStart: (limits at: 1) loopEnd: (limits at: 2).
	self buildView! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
chooseDenominator: evt
	| menu |
	menu _ MenuMorph new.
	(Integer primesUpTo: 30) do:
		[:i |
		menu add: i printString
			target: self selector: #setDenominator:
			argument: i].
	menu addLine.
	menu add: 'none' target: self selector: #setDenominator: argument: 9999.
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 16:50'!
chooseEnvelope: choice
	| name |
	(choice beginsWith: 'edit ') ifTrue:
		[name _ choice copyFrom: 'edit ' size+1 to: choice size.
		^ self editEnvelope: (sound envelopes detect:
				[:env | env name = name])].
	(choice beginsWith: 'add ') ifTrue:
		[name _ choice copyFrom: 'add ' size+1 to: choice size.
		^ self addEnvelopeNamed: name].
	(choice beginsWith: 'remove ') ifTrue:
		[^ self removeEnvelope  "the current one"].
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 19:14'!
chooseFrom: chooserMorph envelopeItem: item
	| name |
	(item beginsWith: 'edit ') ifTrue:
		[name _ item copyFrom: 'edit ' size+1 to: item size.
		self editEnvelope: (sound envelopes detect:
				[:env | env name = name])].
	(item beginsWith: 'add ') ifTrue:
		[name _ item copyFrom: 'add ' size+1 to: item size.
		self addEnvelopeNamed: name].
	(item beginsWith: 'remove ') ifTrue:
		[self removeEnvelope  "the current one"].
	chooserMorph contentsClipped: envelope name! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 13:03'!
chooseFrom: chooserMorph soundItem: item
	self editSoundNamed: item.
! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 12:42'!
chooseSound: evt
	| menu |
	menu _ MenuMorph new.
	menu add: 'new...' target: self selector: #editNewSound.
	menu addLine.
	AbstractSound soundNames do:
		[:name |
		menu add: name
			target: self selector: #editSoundNamed:
			argument: name].
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/30/98 22:58'!
editNewSound
	| known i |
	known _ AbstractSound soundNames.
	i _ 0.
	[soundName _ 'unnamed' , i printString.
	known includes: soundName]
		whileTrue: [i _ 1+1].
	soundName _ soundName.
	self editSound: FMSound default copy! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 7/14/2000 12:44'!
editSoundNamed: name

	name = 'new...' ifTrue: [^ self editNewSound].
	soundName _ name.
	self editSound: (AbstractSound soundNamed: soundName) copy! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 16:49'!
readFileNamed: fileName
	| snd |
	snd _ Compiler evaluate:
		(FileStream readOnlyFileNamed: fileName) contentsOfEntireFile.
	soundName _ fileName copyFrom: 1 to: fileName size-4. "---.fmp"
	self editSound: snd! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
readFromDisk: evt
	| menu |
	menu _ MenuMorph new.
	(FileDirectory default fileNamesMatching: '*.fmp') do:
		[:fileName |
		menu add: fileName
			target: self selector: #readFileNamed:
			argument: fileName].
	menu popUpEvent: evt in: self world! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/3/98 16:50'!
removeEnvelope
	(PopUpMenu confirm: 'Really remove ' , envelope name , '?')
		ifFalse: [^ self].
	sound removeEnvelope: envelope.
	self editEnvelope: sound envelopes first.! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 16:40'!
saveLibToDisk: evt
	| newName f snd |
	newName _ FillInTheBlank request: 'Please confirm name for library...'
						initialAnswer: 'MySounds'.
	newName isEmpty ifTrue: [^ self].
	f _ FileStream newFileNamed: newName , '.fml'.
	AbstractSound soundNames do:
		[:name | snd _ AbstractSound soundNamed: name.
		"snd isStorable" true ifTrue: [f nextChunkPut: 'AbstractSound soundNamed: ' , name , ' put: ' , snd storeString; cr; cr]
			ifFalse: [PopUpMenu notify: name , ' is not currently storable']].
	f close! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 2/17/98 11:05'!
saveSound: evt
	| newName |
	newName _ FillInTheBlank request: 'Please confirm name for save...'
						initialAnswer: soundName.
	newName isEmpty ifTrue: [^ self].
	AbstractSound soundNamed: newName put: sound.
	soundName _ newName.! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 16:41'!
saveToDisk: evt
	| newName f |
	newName _ FillInTheBlank request: 'Please confirm name for save...'
						initialAnswer: soundName.
	newName isEmpty ifTrue: [^ self].
	f _ FileStream newFileNamed: newName , '.fmp'.
	sound storeOn: f.
	f close! !

!EnvelopeEditorMorph methodsFor: 'menu' stamp: 'di 1/31/98 01:36'!
setDenominator: denom
	denominator _ denom.
	self buildView! !


!EnvelopeEditorMorph methodsFor: 'playing' stamp: 'di 2/3/98 17:07'!
playNothing
! !


!EnvelopeEditorMorph methodsFor: 'stepping' stamp: 'di 6/7/1999 15:37'!
step
	| mouseDown hand |
	hand _ self world firstHand.
	(bounds containsPoint: hand position) ifFalse: [^ self].

	mouseDown _ hand lastEvent redButtonPressed.
	mouseDown not & prevMouseDown ifTrue:
		["Mouse just went up"
		limitXs = (limits collect: [:i | (envelope points at: i) x]) ifFalse:
			["Redisplay after changing limits"
			self editEnvelope: envelope]].
	prevMouseDown _ mouseDown! !

!EnvelopeEditorMorph methodsFor: 'stepping' stamp: 'di 1/30/98 13:29'!
stepTime
	^ 100! !

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

EnvelopeEditorMorph class
	instanceVariableNames: ''!

!EnvelopeEditorMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/15/1998 09:49'!
openOn: aSound title: aString
	"EnvelopeEditorMorph openOn: (AbstractSound soundNamed: 'brass1') copy title: 'brass1'"
	(self basicNew initOnSound: aSound title: aString) openInWorld! !
PolygonMorph subclass: #EnvelopeLineMorph
	instanceVariableNames: 'editor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'di 9/8/2000 10:41'!
dragVertex: evt fromHandle: handle vertIndex: ix
	| p |
	super dragVertex: evt fromHandle: handle vertIndex: ix.
	p _ owner acceptGraphPoint: evt cursorPoint at: ix.
	self verticesAt: ix put: p.
! !

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'di 1/28/98 19:38'!
dropVertex: evt fromHandle: handle vertIndex: ix
	| oldVerts |
	oldVerts _ vertices.
	super dropVertex: evt fromHandle: handle vertIndex: ix.
	vertices = oldVerts ifFalse: [owner deletePoint: ix "deleted a vertex"]! !

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'di 9/8/2000 10:42'!
newVertex: evt fromHandle: handle afterVert: ix
	"Install a new vertex if there is room."
	(owner insertPointAfter: ix) ifFalse: [^ self "not enough room"].
	super newVertex: evt fromHandle: handle afterVert: ix.
	self verticesAt: ix+1 put: (owner acceptGraphPoint: evt cursorPoint at: ix+1).
! !

!EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'di 9/7/2000 13:19'!
vertices: verts borderWidth: bw borderColor: bc
	super initialize.
	vertices _ verts.
	color _ Color transparent.
	borderWidth _ bw.
	borderColor _ bc.
	closed _ false.
	arrows _ #none.
	self computeBounds.
! !
SystemDictionary subclass: #Environment
	instanceVariableNames: 'envtName outerEnvt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!Environment commentStamp: '<historical>' prior: 0!
Environments are used to provide separate name spaces in Squeak.  Each one operates pretty much the same way that the Smalltalk systemDictionary is used in a non-partitioned Squeak.

Each class has a direct-access environment in which it is compiled.  Its environment slot points to an instance of this class, and it is there where the bindings of global variables are sought.  The compiler looks up these bindings using normal dictionary protocol (at:, etc).  If a binding is not found, then the name is looked up in the environment from which that one inherits, if any.  In this way a class may be compiled in a context that consists of several nested name spaces, and direct reference may be made to any of the objects resident in those spaces.

Various methods may need to refer to objects that reside in environnments that are not a part of their direct-access environment.  For these references, a simple global reference,
	Thing
may not be used, and instead the construct,
	Envt Thing
must be used.  In this case Envt is a gloabl reference to another environment, and the global name, Thing, is sent as a message to that environment.

Obviously, such a foreign reference cannot be resolved unless the environment in question implements a method of that name.  This is how environmental variables are exported.

Each environment has its own unique class.  With this structure, each environment can have its own instance-specific messeages to provide access to its exported symbols.  Note that this mechanism provides much faster runtime access than the Dictionary at: protocol.  Also note that inheritance provides a trivial implementation of nested name scope by the same token.

In the early stages of installing partitioned environments in Squeak, interpreted access will be provided in several ways.  To begin with, environments will intercept the doesNotUnderstand: message and, if the message begins with a capital letter, it will look up the corresponding name using #at:, and return the value if found.  A refinement to this feature will be to compile an export method on the spot, so that subsequent accesses to that variable run much faster.

Note that there is no Environmental access pattern analogous to 'Envt Thing'.  If an implementor wishes to store into environmental variables, he must do so by defining, eg, a SetThingTo: method and using a call to that method in his code.  We may choose to only allow one certain pattern of access to be compiled in any subclass of Environment to enforce some understandable style of coding.
!


!Environment methodsFor: 'instance creation' stamp: 'di 12/18/1999 15:12'!
makeSubEnvironmentNamed: name
	"Make a new environment (with its own class) of the given name.
	Install it under that name in this environment, and point its outerEnvt link here as well."
	| envtClass envt |
	envtClass _ self class subclass: (name , 'Environment') asSymbol
				instanceVariableNames: '' classVariableNames: ''
				poolDictionaries: '' category: 'System-Environments'.
	envt _ envtClass new setName: name inOuterEnvt: self.
	envtClass addSharedPool: envt.  "add it to its own compilation context for exports"
	^ envt! !

!Environment methodsFor: 'instance creation' stamp: 'di 12/18/1999 15:26'!
setName: name inOuterEnvt: outer
	outerEnvt _ outer.
	envtName _ name asSymbol.
	outerEnvt ifNotNil:
		[outerEnvt at: envtName put: self].  "install me in parent by name"
! !

!Environment methodsFor: 'instance creation' stamp: 'di 3/16/2000 12:54'!
setName: name outerEnvt: outer
	outerEnvt _ outer.
	envtName _ name.

! !


!Environment methodsFor: 'dictionary access' stamp: 'di 2/16/2000 13:29'!
= another
	"Environments should only be compared on the basis of identity"

	^ self == another! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/2/1999 15:54'!
allClassesAnywhereDo: classBlock

	| cl |
	self deepAssociationsDo:
		[:assn | cl _ assn value.
		(cl isKindOf: Class) ifTrue: [classBlock value: cl]]! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/2/1999 19:57'!
associationAtOrAbove: key ifAbsent: absentBlock
	"Look up an association with this key here or in an outer environment."

	^ super associationAt: key ifAbsent:
		[outerEnvt ifNil: [^ absentBlock value].
		^ outerEnvt associationAtOrAbove: key ifAbsent: absentBlock]! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/2/1999 20:55'!
at: key
	"Compatibility hack for starting up Environments"
	^ self atOrBelow: key ifAbsent: [self errorKeyNotFound]! !

!Environment methodsFor: 'dictionary access' stamp: 'acg 12/11/1999 02:15'!
at: key ifAbsent: aBlock
	"Compatibility hack for starting up Environments"
	^ self atOrBelow: key ifAbsent: aBlock! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/1/1999 20:37'!
atOrAbove: key ifAbsent: absentBlock
	"Look up the value iof this key here or in an outer environment."

	^ super at: key ifAbsent:
		[outerEnvt ifNil: [^ absentBlock value].
		^ outerEnvt atOrAbove: key ifAbsent: absentBlock]! !

!Environment methodsFor: 'dictionary access' stamp: 'di 2/16/2000 09:50'!
atOrBelow: key ifAbsent: absentBlock
	| envt value maybe onDisk envName |
	"Compatibility hack -- find things in sub environments for now.
	Adjusted to not fault on every environment."

	^ super at: key ifAbsent:
		[onDisk _ OrderedCollection new.
		self associationsDo: [:assn | 
			((assn key endsWith: 'Environment')
				and: [assn key size > 'Environment' size]) ifTrue: [
				envName _ (assn key copyFrom: 1 to: assn key size - 11 "Environment") asSymbol.
				(envt _ super at: envName ifAbsent: [nil]) ifNotNil: [
					envt isInMemory 
						ifTrue: [((envt isKindOf: Environment) and: [envt ~~ self])
							ifTrue: [maybe _ true.
								value _ envt atOrBelow: key ifAbsent: [maybe _ false].
								maybe ifTrue: [^ value]]]
						ifFalse: [onDisk add: envName]]]].
		onDisk do: [:outName |
			(envt _ super at: outName ifAbsent: [nil]) ifNotNil: [
				((envt isKindOf: Environment) and: [envt ~~ self])
					ifTrue: [maybe _ true.
						value _ envt atOrBelow: key ifAbsent: [maybe _ false].
						maybe ifTrue: [^ value]]]].
		^ absentBlock value]! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/2/1999 19:07'!
deepAssociationsDo: assnBlock
	"Compatibility hack -- find things in sub environments for now"

	| envt |
	self associationsDo:
		[:assn |
		(((envt _ assn value) isKindOf: Environment) and: [envt ~~ self])
			ifTrue: [envt deepAssociationsDo: assnBlock]
			ifFalse: [assnBlock value: assn]]! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/21/1999 13:03'!
environmentForCategory: catString
	"Smalltalk environmentForCategory:'Morphic'"
	"Accepts a category name which may be a symbol or a string,
	and which may have trailing parts of the form '-zort'.
	Returns the environment object of that name."

	| catName envt |
	catName _ (catString copyUpTo: $-) asSymbol.
	(Smalltalk kernelCategories includes: catName)
		ifTrue: [^ Smalltalk].
	envt _ Smalltalk at: catName ifAbsent:
		[(self confirm: 'Use of the category name
' , catName , '
implies the need to create a new system category.
Is this what you wish to do?')
			ifFalse: [self error: 'dismiss me'].
		Smalltalk makeSubEnvironmentNamed: catName].
	(envt isKindOf: Environment) ifFalse:
		[self error: catName , ' cannot be used as an environment name.'].
	^ envt! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/5/1999 11:58'!
exportMethodFor: varName
	^ varName , '
	"Automatically generated during environmental reorganization"
	^ ' , varName ! !

!Environment methodsFor: 'dictionary access' stamp: 'di 12/4/1999 15:41'!
lenientScopeHas: varName ifTrue: assocBlock
	"Compatibility hack -- find things in sub environments for now"
	| assoc envt |
	(assoc _ self associationAt: varName ifAbsent: []) == nil
		ifFalse: [assocBlock value: assoc.
				^ true].

	self associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt ~~ self])
			ifTrue: [(envt lenientScopeHas: varName ifTrue: assocBlock)
						ifTrue: [^ true]]].
	^ false! !

!Environment methodsFor: 'dictionary access' stamp: 'ls 10/23/2000 14:12'!
scopeFor: varName from: prior envtAndPathIfFound: envtAndPathBlock
	"Look up varName here or in any sub-environments, and also in any sub-environments of the outer environment.  If found, evaluate pathBlock with a string giving the path for the access, and return the environment in which the variable was found.  Return nil if the variable is not found.

	Call from outside with prior == nil.
	prior ~= nil prevents revisiting prior parts of the tree."

	| envt |
	"Might be right here -- null path."
	(self includesKey: varName) ifTrue:
		[^ envtAndPathBlock value: self value: String new].

	"Might be in a sub-environment -- append envt name to downward path."
	self associationsDo:
		[:assn |
		(((envt _ assn value) isKindOf: Environment)
			and: [envt ~~ self and: [envt ~~ prior]]) ifTrue:
				[envt scopeFor: varName from: self envtAndPathIfFound:
						[:subEnvt :subPath |
						^ envtAndPathBlock value: subEnvt value: assn key , ' ' , subPath]]].

	"If not found, traverse outer environment."
	outerEnvt ifNil: [^ nil].
	outerEnvt == prior ifTrue: [^ nil].
	outerEnvt scopeFor: varName from: self envtAndPathIfFound:
						[:subEnvt :subPath |
						^ envtAndPathBlock value: subEnvt value: subPath].
! !


!Environment methodsFor: 'system conversion' stamp: 'di 12/4/1999 14:26'!
browseIndirectRefs  "Smalltalk browseIndirectRefs"

	| cm lits browseList foundOne allClasses n |
	browseList _ OrderedCollection new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Locating methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit class == Association ifTrue:
							[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue: [browseList add: cl name , ' ' , sel]]]]].

	Smalltalk browseMessageList: browseList asSortedCollection
		name: 'Indirect Global References' autoSelect: nil! !

!Environment methodsFor: 'system conversion' stamp: 'di 12/23/1999 12:29'!
rewriteIndirectRefs   "Smalltalk rewriteIndirectRefs"
	"For all classes, identify all methods with references to globals outside their direct access path.
	For each of these, call another method to rewrite the source with proper references."

	| cm lits envtForVar envt foundOne allClasses n |
	envtForVar _ Dictionary new.  "Dict of varName -> envt name"
	Smalltalk associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500])
			ifTrue: [envt associationsDo:
						[:a | envtForVar at: a key put: assn key]]].

	"Allow compiler to compile refs to globals out of the direct reference path"
	Preferences enable: #lenientScopeForGlobals.

	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Updating indirect global references in source code...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			{ cls. cls class } do:
				[:cl | cl selectors do:
					[:sel | cm _ cl compiledMethodAt: sel.
					lits _ cm literals.
					foundOne _ false.
					lits do:
						[:lit | lit class == Association ifTrue:
							[(lit value == cl or: [cl scopeHas: lit key ifTrue: [:ignored]])
								ifFalse: [foundOne _ true]]].
					foundOne ifTrue:
						[self rewriteSourceForSelector: sel inClass: cl using: envtForVar]]].
			]].

	Preferences disable: #lenientScopeForGlobals.

! !

!Environment methodsFor: 'system conversion' stamp: 'di 2/7/2000 14:41'!
rewriteSourceForSelector: selector inClass: aClass using: envtForVar
	"Rewrite the source code for the method in question so that all global references out of the direct access path are converted to indirect global references.  This is done by parsing the source with a lenient parser able to find variables in any environment.  Then the parse tree is consulted for the source code ranges of each reference that needs to be rewritten and the pattern to which it should be rewritten.  Note that assignments, which will take the form
	envt setValueOf: #GlobalName to: ...
may generate spurious message due to agglutination of keywords with the value expression."

	| code methodNode edits varName eName envt |
	code _ aClass sourceCodeAt: selector.
	methodNode _ Compiler new parse: code in: aClass notifying: nil.
	edits _ OrderedCollection new.
	methodNode encoder globalSourceRanges do:
		[:tuple |   "{ varName. srcRange. store }"
		(aClass scopeHas: (varName _ tuple first asSymbol) ifTrue: [:ignored]) ifFalse:
			["This is a remote global.  Add it as reference to be edited."
			edits addLast: { varName. tuple at: 2. tuple at: 3 }]].
	"Sort the edits by source position."
	edits _ edits asSortedCollection: [:a :b | a second first < b second first].
	edits reverseDo:
		[:edit | varName _ edit first.
		(eName _ envtForVar at: varName ifAbsent: [nil]) ifNotNil:
			["If varName is not already exported, define an export method"
			envt _ self at: eName.
			(envt class includesSelector: varName) ifFalse:
				[envt class compile: (self exportMethodFor: varName)
						 classified: 'exports'].
			"Replace each access out of scope with a proper remote reference"
			code _ code copyReplaceFrom: edit second first
						to: edit second last
						with: eName , ' ' , varName]].

	aClass compile: code classified: (aClass organization categoryOfElement: selector)! !

!Environment methodsFor: 'system conversion' stamp: 'ls 1/19/2001 13:15'!
tallyIndirectRefs   "Smalltalk tallyIndirectRefs"
	"For all classes, tally the number of references to globals outside their inherited environment.  Then determine the 'closest' environment that resolves most of them.  If the closest environment is different from the one in whick the class currently resides, then enter the class name with the tallies of its references to all other environments.
	Return a triplet:
	A dictionary of all classes for which this is so, with those tallies,
	A dictionary giving the classes that would be happier in each of the other categories,
	A list of the variable names sorted by number of occurrences."

	| tallies refs cm lits envtForVar envt envtRefs allRefs newCategories cat allClasses n |
	envtForVar _ Dictionary new.  "Dict of varName -> envt name"
	allRefs _ Bag new.
	Smalltalk associationsDo:
		[:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500])
			ifTrue: [envt associationsDo:
						[:a | envtForVar at: a key put: assn key]]].

	tallies _ Dictionary new.
	allClasses _ OrderedCollection new.
	Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls].
	'Scanning methods with indirect global references...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: allClasses size
		during:
		[:bar | n _ 0.
		allClasses do:
			[:cls | bar value: (n_ n+1).
			refs _ Set new.
			{ cls. cls class } do:
			[:cl | cl selectors do:
				[:sel | cm _ cl compiledMethodAt: sel.
				lits _ cm literals.
				lits do:
					[:lit | lit class == Association ifTrue:
						[(lit value == cl or: [cls canFindWithoutEnvironment: lit key])
							ifFalse: [refs add: lit key]]]]].
		envtRefs _ Bag new.
		refs asSet do:
			[:varName |
			envtRefs add: (envtForVar at: varName)
					withOccurrences: (refs occurrencesOf: varName).
			(envtRefs sortedCounts isEmpty or: [envtRefs sortedCounts first value == (Smalltalk keyAtValue: cls environment)])
				ifFalse: [allRefs add: varName withOccurrences: (refs occurrencesOf: varName).
						tallies at: cls name put: envtRefs sortedCounts.
						Transcript cr; print: envtRefs sortedCounts; endEntry]]]].

	newCategories _ Dictionary new.
	tallies associationsDo:
		[:assn | cat _ assn value first value.
		(newCategories includesKey: cat) ifFalse:
			[newCategories at: cat put: Array new].
		newCategories at: cat put: ((newCategories at: cat) copyWith: assn key)].
	^ { tallies. newCategories. allRefs sortedCounts }! !

!Environment methodsFor: 'system conversion' stamp: 'di 12/23/1999 11:46'!
transferBindingsNamedIn: nameList from: otherEnvt
	| cls |
	nameList do:
		[:name |
		cls _ otherEnvt at: name.
		self add: (otherEnvt associationAt: name).
		cls environment: self.
		otherEnvt removeKey: name].
! !


!Environment methodsFor: 'printing' stamp: 'di 12/18/1999 15:19'!
name

	^ envtName ifNil: ['Environment ' , self hash printString]! !

!Environment methodsFor: 'printing' stamp: 'sma 6/1/2000 09:54'!
printOn: aStream
	envtName
		ifNil: [aStream nextPutAll: self name]
		ifNotNil: [aStream nextPutAll: 'An Environment named '; nextPutAll: envtName]! !


!Environment methodsFor: 'fileIn/out' stamp: 'di 4/1/2000 10:57'!
isInMemory
	self associationsDo:
		[:a | ^ a value isInMemory].
	^ true! !

!Environment methodsFor: 'fileIn/out' stamp: 'di 2/16/2000 23:36'!
stillOut		"Smalltalk stillOut"
	"Write transcript the names of the Environments in the list who are still out on disk."

	Transcript clear.
	Smalltalk associationsDo:
		[:assn |
		(assn value isKindOf: Environment) ifTrue:
			[Transcript cr; nextPutAll: assn key , 
					(assn value isInMemory
							ifTrue: [':  in']
							ifFalse: [':  out'])]].
	Transcript endEntry! !

!Environment methodsFor: 'fileIn/out' stamp: 'di 3/24/2000 21:50'!
storeAll
	"Write all Environments except me and the top one out as image segments."

	| firstToGo others |
	firstToGo _ #(VMConstruction Morphic Sound Network Balloon)
					collect: [:x | Smalltalk at: x].
	others _ Smalltalk values select:
		[:value |  (value isKindOf: Environment)
					and: [(firstToGo includes: value) not & (value ~~ Smalltalk)]].
	firstToGo , others do: [:anEnv | anEnv storeSegment].! !

!Environment methodsFor: 'fileIn/out' stamp: 'di 2/16/2000 22:28'!
storeSegment
	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <my name>.seg."

	| is roots |
	is _ ImageSegment new.
	is segmentName: self name.
	roots _ OrderedCollection new: self size * 2.
	"roots addFirst: self."
	self valuesDo:
		[:value | value == self ifFalse: [roots addLast: value].
		value class class == Metaclass ifTrue: [roots addLast: value class]].
	is copyFromRootsLocalFileFor: roots sizeHint: 0.

	"NOTE: self is now an ISRootStub..."
	is state = #tooBig ifTrue: [^ false].
	is extract.
	is state = #active ifFalse: [^ false].
	is writeToFile: is segmentName.
	^ true
! !

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

Environment class
	instanceVariableNames: ''!

!Environment class methodsFor: 'system conversion' stamp: 'di 2/16/2000 11:49'!
computePrerequisites
	| bigCats bigCat preReqs supCat dict kernelCategories |
	"We say one environment is a prerequisite of another if classes defined
	in the other inherit from classes in the first.
	Compute a dictionary with an entry for every non-kernel environment.
	That entry is another dictionary giving the names of any prerequisite
	environments and the list of classes that require it."
	"Environment computePrerequisites."  " <-- inspect this "

	bigCats _ IdentityDictionary new.
	kernelCategories _ Environment new kernelCategories.
	Smalltalk allClasses do:
		[:cl |  bigCat _ (cl category asString copyUpTo: '-' first) asSymbol.
		(kernelCategories includes: bigCat) ifTrue: [bigCat _ #Kernel].
		bigCats at: cl name put: bigCat].

	preReqs _ IdentityDictionary new.
	Smalltalk allClasses do:
		[:cl |  
		cl superclass ifNotNil:
			[bigCat _ bigCats at: cl name.
			supCat _ bigCats at: cl superclass name.
			bigCat ~~ supCat ifTrue:
				[dict _ preReqs at: bigCat
					ifAbsent: [preReqs at: bigCat put: IdentityDictionary new].
				dict at: supCat
					put: ((dict at: supCat ifAbsent: [Array new]) copyWith: cl name)]]].
	^ preReqs
! !

!Environment class methodsFor: 'system conversion' stamp: 'di 2/16/2000 12:43'!
reorganizeEverything
	"Environment reorganizeEverything."

	| bigCat envt pool s |
	"First check for clashes between environment names and existing globals..."
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			[(Smalltalk includesKey: bigCat) ifTrue:
				[^ self error: bigCat , ' cannot be used to name
both a package and a class or other global variable.
No reorganization will be attempted.']]].

	(PopUpMenu confirm:
'Your image is about to be partitioned into environments.
Many things may not work after this, so you should be
working in a throw-away copy of your working image.
Are you really ready to procede?
(choose ''no'' to stop here safely)')
		ifFalse: [^ PopUpMenu notify: 'No changes were made'].

	Smalltalk newChanges: (ChangeSet new initialize name: 'Reorganization').

	"Recreate the Smalltalk dictionary as the top-level Environment."
	Smalltalk _ SmalltalkEnvironment newFrom: Smalltalk.
	Smalltalk setName: #Smalltalk inOuterEnvt: nil.

	"Don't hang onto old copy of Smalltalk ."
	Smalltalk recreateSpecialObjectsArray.

	Smalltalk allClassesDo:
		[:c | c environment: nil. "Flush any old values"].

	"Run through all categories making up new sub-environments"
	SystemOrganization categories do:
		[:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol.
		(Smalltalk kernelCategories includes: bigCat) ifFalse:
			["Not a kernel category ..."
			envt _ Smalltalk at: bigCat
						ifAbsent: ["... make up a new environment if necessary ..."
									Smalltalk makeSubEnvironmentNamed: bigCat].
			"... and install the member classes in that category"
			envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat)
									from: Smalltalk].
		].

	"Move all shared pools that are only referred to in sub environments"
	Smalltalk associationsDo:
		[:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue:
			[s _ IdentitySet new.
			Smalltalk allClassesAnywhereDo:
				[:c | c sharedPools do:
					[:p | p == pool ifTrue:
						[s add: c environment]]].
			(s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue:
				[envt declare: assn key from: Smalltalk]]].

	Smalltalk rewriteIndirectRefs.
	Smalltalk newChanges: (ChangeSet new initialize name: 'PostReorganization').
	ChangeSorter gatherChangeSets.
	Preferences enable: #browserShowsPackagePane.

! !
Exception subclass: #Error
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!Error commentStamp: '<historical>' prior: 0!
>From the ANSI standard:
This protocol describes the behavior of instances of class Error. These are used to represent error conditions that prevent the normal continuation of processing. Actual error exceptions used by an application may be subclasses of this class.
As Error is explicitly specified  to be subclassable, conforming implementations must implement its behavior in a non-fragile manner.

Additional notes:
Error>defaultAction uses an explicit test for the presence of the Debugger class to decide whether or not it is in development mode.  In the future, TFEI hopes to enhance the semantics of #defaultAction to improve support for pluggable default handlers.!


!Error methodsFor: 'private' stamp: 'di 9/22/1999 19:20'!
devDefaultAction

	Debugger
		openContext: initialContext
		label: self description
		contents: initialContext shortStack! !

!Error methodsFor: 'private' stamp: 'tfei 6/5/1999 00:09'!
isDevelopmentEnvironmentPresent

	^Smalltalk includesKey: #Debugger! !

!Error methodsFor: 'private' stamp: 'tfei 6/5/1999 00:26'!
runtimeDefaultAction
	"Dump the stack trace to a log file, then exit the program (image)."

	| file |
	file := FileStream newFileNamed: ('error', Utilities dateTimeSuffix, FileDirectory dot, 'log') asFileName.
	Smalltalk timeStamp: file.
	(thisContext sender stackOfSize: 20) do: [:ctx | file cr. ctx printOn: file].
	file close.
	Smalltalk snapshot: false andQuit: true! !


!Error methodsFor: 'exceptionDescription' stamp: 'tfei 6/5/1999 00:10'!
defaultAction
	"The current computation is terminated. The cause of the error should be logged or reported to the user. If the program is operating in an interactive debugging environment the computation should be suspended and the debugger activated."

	self isDevelopmentEnvironmentPresent
		ifTrue: [self devDefaultAction]
		ifFalse: [self runtimeDefaultAction]! !
UpdatingThreePhaseButtonMorph subclass: #EtoyUpdatingThreePhaseButtonMorph
	instanceVariableNames: ''
	classVariableNames: 'CheckedForm MouseDownForm UncheckedForm '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!EtoyUpdatingThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
A slight variation wherein the actionSelector and getSelector both take argument(s).!


!EtoyUpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 12:18'!
step
	| newBoolean |

	state == #pressed ifTrue: [^ self].
	newBoolean _ target perform: getSelector withArguments: arguments.
	newBoolean == self isOn
		ifFalse:
			[self state: (newBoolean ifTrue: [#on] ifFalse: [#off])]
! !

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

EtoyUpdatingThreePhaseButtonMorph class
	instanceVariableNames: ''!

!EtoyUpdatingThreePhaseButtonMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 13:34'!
checkBox
	"Answer a button pre-initialized with checkbox images."

	"(Form extent: 12@12 depth: 32) morphEdit"
	CheckedForm ifNil: [
		self setForms
	].
	^self new
		onImage: CheckedForm;
		pressedImage: MouseDownForm;
		offImage: UncheckedForm;
		extent: CheckedForm extent;
		yourself
! !

!EtoyUpdatingThreePhaseButtonMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 13:34'!
setForms

CheckedForm _ (Form
	extent: 12@12
	depth: 32
	fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 4278190081 2003331177 4278190081 4278190081 0 0 0 0 0 0 0 4278190081 2003331177 0 4278190081 4278190081 0 0 0 0 0 0 4278190081 2003331177 0 0 4278190081 4278190081 0 4278190081 0 0 0 4278190081 2003331177 0 0 0 4278190081 4278190081 0 2003331177 4278190081 0 4278190081 2003331177 0 0 0 0 4278190081 4278190081 0 0 2003331177 4278190081 2003331177 0 0 0 0 0 4278190081 4278190081 0 0 0 2003331177 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
	offset: 0@0).
MouseDownForm _ UncheckedForm _ (Form
	extent: 12@12
	depth: 32
	fromArray: #( 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 0 0 0 0 0 0 0 0 0 0 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081 4278190081)
	offset: 0@0)! !
Object subclass: #EventHandler
	instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient clickSelector clickRecipient '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!EventHandler commentStamp: '<historical>' prior: 0!
Events in Morphic originate in a Hand, pass to a target morph, and are then dispatched by an EventHandler.  EventHandlers support redirection of mouse and keyboard activity by specifying and independent recipient object and message selector for each of the possible events.  In addition each eventHandler can supply an optional value parameter for distinguishing between, eg, events from a number of otherwise identical source morphs.

The basic protocol of an event handler is to receive a message of the form
	mouseDown: event in: targetMorph
and redirect this as one of
	mouseDownRecipient perform: mouseDownSelector0
	mouseDownRecipient perform: mouseDownSelector1 with: event
	mouseDownRecipient perform: mouseDownSelector2 with: event with: targetMorph
	mouseDownRecipient perform: mouseDownSelector3 with: event with: targetMorph with: valueParameter
depending on the arity of the mouseDownSelector.
!


!EventHandler methodsFor: 'initialization' stamp: 'ar 10/7/2000 22:50'!
adaptToWorld: aWorld
	"If any of my recipients refer to a world or a hand, make them now refer
	to the corresponding items in the new world.  (instVarNamed: is slow, later
	use perform of two selectors.)"

	| value newValue |
	#(mouseDownRecipient mouseStillDownRecipient mouseUpRecipient
	mouseEnterRecipient mouseLeaveRecipient mouseEnterDraggingRecipient
	mouseLeaveDraggingRecipient clickRecipient doubleClickRecipient startDragRecipient keyStrokeRecipient valueParameter) do:
		[:aName |
		(value _ self instVarNamed: aName asString) ifNotNil:
			[newValue _ nil.
			value isMorph
				ifTrue:
					[value isWorldMorph ifTrue: [newValue _ aWorld].
					value isHandMorph ifTrue: [newValue _ aWorld primaryHand]]
				ifFalse: [(value isKindOf: Presenter) ifTrue: [newValue _ aWorld presenter]].
			(newValue notNil and: [newValue ~~ value])
				ifTrue:
					[self instVarNamed: aName asString put: newValue]]]! !

!EventHandler methodsFor: 'initialization' stamp: 'ar 10/25/2000 17:32'!
forgetDispatchesTo: aSelector
	"aSelector is no longer implemented by my corresponding Player, so don't call it any more"
	mouseDownSelector == aSelector
		ifTrue: [mouseDownRecipient _ mouseDownSelector _ nil].
	mouseMoveSelector == aSelector
		ifTrue: [mouseMoveRecipient _ mouseMoveSelector _ nil].
	mouseStillDownSelector == aSelector
		ifTrue: [mouseStillDownRecipient _ mouseStillDownSelector _ nil].
	mouseUpSelector == aSelector
		ifTrue: [mouseUpRecipient _ mouseUpSelector _ nil].
	mouseEnterSelector == aSelector
		ifTrue: [mouseEnterRecipient _ mouseEnterSelector _ nil].
	mouseLeaveSelector == aSelector
		ifTrue: [mouseLeaveRecipient _ mouseLeaveSelector _ nil].
	mouseEnterDraggingSelector == aSelector
		ifTrue: [mouseEnterDraggingRecipient _ mouseEnterDraggingSelector _ nil].
	mouseLeaveDraggingSelector == aSelector
		ifTrue: [mouseLeaveDraggingRecipient _ mouseLeaveDraggingSelector _ nil].
	clickSelector == aSelector
		ifTrue: [clickRecipient _ clickSelector _ nil].
	doubleClickSelector == aSelector
		ifTrue: [doubleClickRecipient _ doubleClickSelector _ nil].
	keyStrokeSelector == aSelector
		ifTrue: [keyStrokeRecipient _ keyStrokeSelector _ nil].! !

!EventHandler methodsFor: 'initialization' stamp: 'ar 10/25/2000 17:30'!
on: eventName send: selector to: recipient
	eventName = #mouseDown ifTrue:
		[mouseDownRecipient _ recipient.  mouseDownSelector _ selector. ^ self].
	eventName = #mouseMove ifTrue:
		[mouseMoveRecipient _ recipient.  mouseMoveSelector _ selector. ^ self].
	eventName = #mouseStillDown ifTrue:
		[mouseStillDownRecipient _ recipient.  mouseStillDownSelector _ selector. ^ self].
	eventName = #mouseUp ifTrue:
		[mouseUpRecipient _ recipient.  mouseUpSelector _ selector. ^ self].
	eventName = #mouseEnter ifTrue:
		[mouseEnterRecipient _ recipient.  mouseEnterSelector _ selector. ^ self].
	eventName = #mouseLeave ifTrue:
		[mouseLeaveRecipient _ recipient.  mouseLeaveSelector _ selector. ^ self].
	eventName = #mouseEnterDragging ifTrue:
		[mouseEnterDraggingRecipient _ recipient.  mouseEnterDraggingSelector _ selector. ^ self].
	eventName = #mouseLeaveDragging ifTrue:
		[mouseLeaveDraggingRecipient _ recipient.  mouseLeaveDraggingSelector _ selector. ^ self].
	eventName = #click ifTrue:
		[clickRecipient _ recipient. clickSelector _ selector. ^ self].
	eventName = #doubleClick ifTrue:
		[doubleClickRecipient _ recipient. doubleClickSelector _ selector. ^ self].
	eventName = #startDrag ifTrue:
		[startDragRecipient _ recipient. startDragSelector _ selector. ^ self].
	eventName = #keyStroke ifTrue:
		[keyStrokeRecipient _ recipient.  keyStrokeSelector _ selector. ^ self].
	self error: 'Event name, ' , eventName , ' is not recognizable.'
! !

!EventHandler methodsFor: 'initialization'!
on: eventName send: selector to: recipient withValue: value
	selector numArgs = 3 ifFalse:
		[self halt: 'Warning: value parameters are passed as last of 3 arguments'].
	self on: eventName send: selector to: recipient.
	valueParameter _ value
! !


!EventHandler methodsFor: 'testing' stamp: 'ar 10/7/2000 22:56'!
handlesClickOrDrag: evt
	clickRecipient ifNotNil:[^true].
	doubleClickRecipient ifNotNil:[^true].
	startDragRecipient ifNotNil:[^true].
	^false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/28/2000 22:17'!
handlesKeyboard: evt
	keyStrokeRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/7/2000 22:56'!
handlesMouseDown: evt
	mouseDownRecipient ifNotNil: [^ true].
	mouseStillDownRecipient ifNotNil: [^ true].
	mouseUpRecipient ifNotNil: [^ true].
	(self handlesClickOrDrag: evt) ifTrue:[^true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/25/2000 17:33'!
handlesMouseMove: evt
	^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! !

!EventHandler methodsFor: 'testing'!
handlesMouseOver: evt
	mouseEnterRecipient ifNotNil: [^ true].
	mouseLeaveRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'di 9/15/1998 16:35'!
handlesMouseOverDragging: evt
	mouseEnterDraggingRecipient ifNotNil: [^ true].
	mouseLeaveDraggingRecipient ifNotNil: [^ true].
	^ false! !

!EventHandler methodsFor: 'testing' stamp: 'ar 10/22/2000 17:05'!
handlesMouseStillDown: evt
	^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]! !


!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:55'!
click: event fromMorph: sourceMorph 
	"This message is sent only when double clicks are handled."
	^ self
		send: clickSelector
		to: clickRecipient
		withEvent: event
		fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'LC 2/14/2000 08:38'!
doubleClick: event fromMorph: sourceMorph 
	^ self
		send: doubleClickSelector
		to: doubleClickRecipient
		withEvent: event
		fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
keyStroke: event fromMorph: sourceMorph
	^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'ar 10/7/2000 22:54'!
mouseDown: event fromMorph: sourceMorph 
	"Take double-clicks into account."
	((self handlesClickOrDrag: event) and:[event redButtonPressed]) ifTrue:[
		event hand waitForClicksOrDrag: sourceMorph event: event.
	].
	^self
		send: mouseDownSelector
		to: mouseDownRecipient
		withEvent: event
		fromMorph: sourceMorph.
! !

!EventHandler methodsFor: 'events'!
mouseEnter: event fromMorph: sourceMorph
	^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'!
mouseEnterDragging: event fromMorph: sourceMorph
	^ self send: mouseEnterDraggingSelector to: mouseEnterDraggingRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseLeave: event fromMorph: sourceMorph
	^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'di 9/15/1998 16:35'!
mouseLeaveDragging: event fromMorph: sourceMorph
	^ self send: mouseLeaveDraggingSelector to: mouseLeaveDraggingRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events' stamp: 'ar 10/25/2000 17:32'!
mouseMove: event fromMorph: sourceMorph
	^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseStillDown: event fromMorph: sourceMorph
	^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
mouseUp: event fromMorph: sourceMorph
	^ self send: mouseUpSelector to: mouseUpRecipient withEvent: event fromMorph: sourceMorph! !

!EventHandler methodsFor: 'events'!
send: selector to: recipient withEvent: event fromMorph: sourceMorph
	| arity |
	recipient ifNil: [^ self].
	arity _ selector numArgs.
	arity = 0 ifTrue:
		[^ recipient perform: selector].
	arity = 1 ifTrue:
		[^ recipient perform: selector with: event].
	arity = 2 ifTrue:
		[^ recipient perform: selector with: event with: sourceMorph].
	arity = 3 ifTrue:
		[^ recipient perform: selector with: event with: sourceMorph with: valueParameter].
	self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! !

!EventHandler methodsFor: 'events' stamp: 'mir 5/23/2000 17:43'!
startDrag: event fromMorph: sourceMorph 
	^ self
		send: startDragSelector
		to: startDragRecipient
		withEvent: event
		fromMorph: sourceMorph! !


!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:33'!
allRecipients
	"Answer a list, without duplication, of all the objects serving as recipients to any of the events I handle.  Intended for debugging/documentation use only"
	| aList |
	aList _ OrderedCollection with: mouseDownRecipient with: mouseStillDownRecipient with: mouseUpRecipient with: mouseEnterRecipient with: mouseLeaveRecipient.
	aList addAll: (OrderedCollection with:  mouseEnterDraggingRecipient with: mouseLeaveDraggingRecipient with: doubleClickRecipient with: keyStrokeRecipient).
	aList add: mouseMoveRecipient.
	^ (aList copyWithout: nil) asSet asArray! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:34'!
firstMouseSelector
	"Answer the selector corresponding to the first mouse-handling selector fielded.  Created in support of providing balloon-help for halo handles, triggered by the selector handled"

	mouseDownSelector ifNotNil: [^ mouseDownSelector].
	mouseMoveSelector ifNotNil:[^mouseMoveSelector].
	mouseStillDownSelector ifNotNil: [^ mouseStillDownSelector].
	mouseUpSelector ifNotNil: [^ mouseUpSelector].
	mouseEnterSelector ifNotNil: [^ mouseEnterSelector].
	mouseLeaveSelector ifNotNil: [^ mouseLeaveSelector].
	mouseEnterDraggingSelector ifNotNil: [^ mouseEnterDraggingSelector].
	mouseLeaveDraggingSelector ifNotNil: [^ mouseLeaveDraggingSelector].
	doubleClickSelector ifNotNil: [^ doubleClickSelector].
	^ nil! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 17:31'!
messageList
	"Return a list of 'Class selector' for each message I can send.  tk
9/13/97"

	| list |
	list _ SortedCollection new.
	mouseDownRecipient ifNotNil:
		[list add: (mouseDownRecipient class classThatUnderstands:
					mouseDownSelector) name , ' ', mouseDownSelector].
	mouseMoveRecipient ifNotNil:
		[list add: (mouseMoveRecipient class classThatUnderstands:
					mouseMoveSelector) name , ' ', mouseMoveSelector].
	mouseStillDownRecipient ifNotNil:
		[list add: (mouseStillDownRecipient class classThatUnderstands:
					mouseStillDownSelector) name , ' ', mouseStillDownSelector].
	mouseUpRecipient ifNotNil:
		[list add: (mouseUpRecipient class classThatUnderstands:
					mouseUpSelector) name , ' ', mouseUpSelector].
	mouseEnterRecipient ifNotNil:
		[list add: (mouseEnterRecipient class classThatUnderstands:
					mouseEnterSelector) name , ' ', mouseEnterSelector].
	mouseLeaveRecipient ifNotNil:
		[list add: (mouseLeaveRecipient class classThatUnderstands:
					mouseLeaveSelector) name , ' ', mouseLeaveSelector].
	mouseEnterDraggingRecipient ifNotNil:
		[list add: (mouseEnterDraggingRecipient class classThatUnderstands:
					mouseEnterDraggingSelector) name , ' ', mouseEnterDraggingSelector].
	mouseLeaveDraggingRecipient ifNotNil:
		[list add: (mouseLeaveDraggingRecipient class classThatUnderstands:
					mouseLeaveDraggingSelector) name , ' ', mouseLeaveDraggingSelector].
	doubleClickRecipient ifNotNil:
		[list add: (doubleClickRecipient class classThatUnderstands:
					doubleClickSelector) name , ' ', doubleClickSelector].
	keyStrokeRecipient ifNotNil:
		[list add: (keyStrokeRecipient class classThatUnderstands:
					keyStrokeSelector) name , ' ', keyStrokeSelector].
	^ list! !

!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'!
mouseDownSelector
	^ mouseDownSelector! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'!
mouseStillDownRecipient
	^mouseStillDownRecipient! !

!EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'!
mouseStillDownSelector
	^mouseStillDownSelector! !

!EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'!
mouseUpSelector
	^ mouseUpSelector! !

!EventHandler methodsFor: 'access' stamp: 'LC 2/14/2000 09:01'!
printOn: aStream
	| aVal recipients |
	super printOn: aStream.
	#('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') do:
		[:aName | (aVal _ self instVarNamed: aName) ~~ nil ifTrue:
			[aStream nextPutAll: '; ', aName, '=', aVal]].
	(recipients _ self allRecipients) size > 0 ifTrue:
		[aStream nextPutAll: ' recipients: '.
		recipients printOn: aStream]! !


!EventHandler methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:45'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"20 dec 2000 - only a few (old) conversion exists"

	varDict at: 'mouseEnterLadenRecipient' ifPresent: [ :x | mouseEnterDraggingRecipient _ x].
	varDict at: 'mouseEnterLadenSelector' ifPresent: [ :x | mouseEnterDraggingSelector _ x].
	varDict at: 'mouseLeaveLadenRecipient' ifPresent: [ :x | mouseLeaveDraggingRecipient _ x].
	varDict at: 'mouseLeaveLadenSelector' ifPresent: [ :x | mouseLeaveDraggingSelector _ x].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!EventHandler methodsFor: 'fixups' stamp: 'RAA 7/12/2000 14:54'!
fixAlansOldEventHandlers

	(#(programmedMouseUp:for: programmedMouseUp:for:with:) 
			includes: mouseUpSelector) ifFalse: [^self].
	mouseDownSelector ifNotNil: [^self].
	mouseUpRecipient addMouseUpActionWith: (
		mouseUpRecipient valueOfProperty: #mouseUpCodeToRun ifAbsent: [valueParameter]
	)
! !


!EventHandler methodsFor: 'copying' stamp: 'tk 1/22/2001 17:43'!
veryDeepFixupWith: deepCopier
	| old |
	"ALL inst vars were weakly copied.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
1 to: self class instSize do:
	[:ii | old _ self instVarAt: ii.
	self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])].

! !

!EventHandler methodsFor: 'copying' stamp: 'tk 1/22/2001 17:39'!
veryDeepInner: deepCopier
	"ALL fields are weakly copied!!  Can't duplicate an object by duplicating a button that activates it.  See DeepCopier."

	super veryDeepInner: deepCopier.
	"just keep old pointers to all fields"
	clickRecipient _ clickRecipient.!
]style[(25 108 10 111)f1b,f1,f1LDeepCopier Comment;,f1! !

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

EventHandler class
	instanceVariableNames: ''!

!EventHandler class methodsFor: 'fixups' stamp: 'RAA 7/12/2000 15:03'!
fixAlansOldEventHandlers
"
EventHandler fixAlansOldEventHandlers
"
	| allHandlers |

	allHandlers _ EventHandler allInstances select: [ :each |
		(#(programmedMouseUp:for: programmedMouseUp:for:with:) includes: 
				each mouseUpSelector) and: [each mouseDownSelector isNil]
	].
	allHandlers do: [ :each |
		each fixAlansOldEventHandlers
	].! !
Object subclass: #EventModel
	instanceVariableNames: 'myEvents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!EventModel commentStamp: '<historical>' prior: 0!
This is an abstract superclass for models which want to use the #when:send:to: event system in an efficient way. Instances of this class keep their own list of event symbols and registered events instead of using the global class variable EventsFields in class Object.

Structure:
 myEvents		Dictionary -- set of event symbols and registered listeners!


!EventModel methodsFor: 'events' stamp: 'sma 3/11/2000 10:37'!
myEvents
	^ myEvents! !

!EventModel methodsFor: 'events' stamp: 'sma 3/11/2000 10:37'!
myEvents: aDictionaryOrNil
	myEvents _ aDictionaryOrNil! !
AlignmentMorph subclass: #EventRecorderMorph
	instanceVariableNames: 'tape state time deltaTime recHand playHand lastEvent lastDelta tapeStream saved statusLight voiceRecorder startSoundEvent recordMeter caption journalFile '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!EventRecorderMorph commentStamp: '<historical>' prior: 0!
During recording, the EventRecorder subscribes to all events of the normal morphic hand, and saves them as they occur.

For replay, a second playback hand is created that reads events from the recorder and plays them back in the world.

The EventRecorder began with the work of Ted Kaehler and John Malone.  This was then signifcantly expanded by Leandro Caniglia and Valeria Murgia as a tutorial aid for the Morphic Wrapper project.

Since that time, I have...
Changed to a simple inboard array for the tape (event storage).
Provided the ability to condense linear mouse movement with interpolation at replay.
Made simple provisions for wrap-around of the millisecond clock.
Eliminated step methods in favor of using the processEvents cycle in the playback hand.
Provided a pause/resume mechanism that is capable of surviving project changes.
Added the ability to spawn a simple 'play me' button that can be saved as a morph.
Caused the playback hand to display its cursor double size for visibility.
Integrated a voice recorder with on-the-fly compression.
	This currently does NOT survive project changes, not is its data stored on the tape.
	Right now it can only be saved by saving the entire recorder as a morph.
	This will be fixed by adding a startSound event at each project change.
	We will also convert read/write file to use saveOnFile.
Added a journal file facility for recording sequences that end in a crash.
The above two features can be engaged via the ER's morph menu.
	- Dan Ingalls 3/6/99!


!EventRecorderMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:14'!
addButtons
	| r b w |

	caption ifNotNil:
		["Special setup for play-only interface"
		r _ AlignmentMorph newRow vResizing: #shrinkWrap;
			 wrapCentering: #center; cellPositioning: #leftCenter;
			 minCellSize: 4;
			 color: Color blue.
		r addMorphBack: (SimpleButtonMorph new target: self;
	 							label: caption; actionSelector: #play).
		r addMorphBack: (Morph new extent: 4@4; color: Color transparent).
		r addMorphBack: (statusLight _ EllipseMorph new extent: 11 @ 11;
								color: Color green; borderWidth: 0).
		r addMorphBack: (Morph new extent: 4@4; color: Color transparent).
		^ self addMorphBack: r].

	"record - stop - play"
	r _ AlignmentMorph newRow vResizing: #shrinkWrap;
			 minCellSize: 4;
			 color: Color blue.
	r addMorphBack: (b _ self buttonFor: #record).
	w _ b width.
	r addMorphBack: (AlignmentMorph newSpacer: Color transparent).
	r addMorphBack: ((self buttonFor: #stop) width: w).
	r addMorphBack: (AlignmentMorph newSpacer: Color transparent).
	r addMorphBack: ((self buttonFor: #play) width: w).
	self addMorphBack: r.

	"read file - write file"
	r _ AlignmentMorph newRow vResizing: #shrinkWrap;
			 minCellSize: 4;
			 color: Color blue.
	r addMorphBack: (b _ self buttonFor: #writeTape).
	w _ b width.
	r addMorphBack: (AlignmentMorph newSpacer: Color transparent).
	r addMorphBack: ((self buttonFor: #readTape)
			width: w).
	self addMorphBack: r.

	"rewind - light - reset"
	r _ AlignmentMorph newRow vResizing: #shrinkWrap;
			 wrapCentering: #center; cellPositioning: #leftCenter;
			 minCellSize: 4;
			 color: Color blue.
	r addMorphBack: (b _ self buttonFor: #shrink).
	w _ b width.
	r addMorphBack: (AlignmentMorph newSpacer: Color transparent).
	r addMorphBack: (statusLight _ EllipseMorph new extent: 11 @ 11;
			color: Color green;
		 	borderWidth: 0).
	r addMorphBack: (AlignmentMorph newSpacer: Color transparent).
	r addMorphBack: ((self buttonFor: #button)
			width: w).
	self addMorph: r! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'di 3/6/1999 15:47'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'add voice controls' action: #addVoiceControls.
	aCustomMenu add: 'add journal file' action: #addJournalFile.
! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'ar 10/25/2000 21:42'!
addJournalFile
	"In case there is a chance of not regaining control to stop recording and save a file, the EventRecorder can write directly to file as it is recording.  This is useful for capturing a sequence that results in a nasty crash."

	journalFile ifNotNil: [journalFile close].
	journalFile _ FileStream newFileNamed: 'EventRecorder.tape'.
	journalFile nextPutAll:'Event Tape v1 ASCII'; cr.! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 1/2/2001 10:35'!
addVoiceControls 

	| levelSlider r meterBox |
	voiceRecorder _ SoundRecorder new
		desiredSampleRate: 11025.0;		"<==try real hard to get the low rate"
		codec: (GSMCodec new).		"<--this should compress better than ADPCM.. is it too slow?"
		"codec: (ADPCMCodec new initializeForBitsPerSample: 4 samplesPerFrame: 0)."

	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: voiceRecorder;
		actionSelector: #recordLevel:;
		adjustToValue: voiceRecorder recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.

	meterBox _ Morph new extent: 102@18; color: Color gray.
	recordMeter _ Morph new extent: 1@16; color: Color yellow.
	recordMeter position: meterBox topLeft + (1@1).
	meterBox addMorph: recordMeter.

	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: meterBox.
	self addMorphBack: r.
! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'LC 12/20/1998 11:25'!
buttonFor: aSymbol 
	^ SimpleButtonMorph new target: self;
	 label: aSymbol asString;
	 actionSelector: aSymbol! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'di 2/17/1999 17:44'!
caption: butnCaption voiceRecorder: butnRecorder tape: butnTape
	caption _ butnCaption.
	voiceRecorder _ butnRecorder.
	tape _ butnTape! !

!EventRecorderMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:14'!
initialize
	super initialize.
	saved _ true.
	borderWidth _ 2.
	borderColor _ #raised.
	color _ Color red.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self layoutInset: 2.
	self minCellSize: 4.
	self addButtons.
! !


!EventRecorderMorph methodsFor: 'accessing' stamp: 'LC 12/23/1998 12:48'!
button: label 
	^ self allMorphs
		detect: [:one | (one isKindOf: SimpleButtonMorph)
				and: [one label = label]]
		ifNone: []! !

!EventRecorderMorph methodsFor: 'accessing' stamp: 'RAA 12/13/2000 12:51'!
recTime

	self flag: #bob.		"not sent and no longer working"

	"| ms |
	ms _ 0.
	tape do:
		[:cell | ms _ ms + cell key].
	^ String streamContents:
		[:stream | (Time fromSeconds: ms // 1000) print24: true on: stream]"! !


!EventRecorderMorph methodsFor: 'commands' stamp: 'di 2/17/1999 17:45'!
button
	"Make a simple button interface for replay only"
	| butnCaption erm |
	butnCaption _ FillInTheBlank request: 'Caption for this butn?' initialAnswer: 'play'.
	butnCaption isEmpty ifTrue: [^ self].
	erm _ (EventRecorderMorph basicNew
				caption: butnCaption
				voiceRecorder: voiceRecorder copy
				tape: tape) initialize.
	self world primaryHand attachMorph: erm! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'ar 10/25/2000 22:38'!
condense
	"Shorten the tape by deleting mouseMove events that can just as well be
	interpolated later at playback time."
	| e1 e2 t1 t2 e3 t3 |
	"e1, e2, and e3 are three consecutive events on the tape.
	t1, t2, and t3 are the associated time steps for each of them."
	tape _ Array streamContents:
	[:tStream |
	e1 _ e2 _ e3 _ nil.  t1 _ t2 _ t3 _ nil.
	1 to: tape size do:[:i|
		e1 _ e2.  t1 _ t2.
		e2 _ e3.  t2 _ t3.
		e3 _ tape at: i. t3 _ e3 timeStamp.
		((e1 ~~ nil and: [(e2 type == #mouseMove) &
				(e1 type == #mouseMove or: [e3 type == #mouseMove])]) and: 
			["Middle point within 3 pixels of mean of outer two"
			e2 position onLineFrom: e1 position to: e3 position within: 2.5])
			ifTrue: ["Delete middle mouse move event.  Absorb its time into e3"
					e2 _ e1.  t2 _ t1]
			ifFalse: [e1 ifNotNil: [tStream nextPut: (e1 copy setTimeStamp: t1)]]].
	e2 ifNotNil: [tStream nextPut: (e2 copy setTimeStamp: t2)].
	e3 ifNotNil: [tStream nextPut: (e3 copy setTimeStamp: t3)]].
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'ar 10/25/2000 23:00'!
play

	self isInWorld ifFalse: [^ self].
	self stop.
	tape ifNil: [^ self].
	tapeStream _ ReadStream on: tape.
	self resumePlayIn: self world.
	statusLight color: Color yellow.
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'ar 10/25/2000 20:24'!
record

	self isInWorld ifFalse: [^ self].
	self stop.
	self writeCheck.
	self addJournalFile.
	tapeStream _ WriteStream on: (Array new: 10000).
	self resumeRecordIn: self world.
	statusLight color: Color red.
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'ar 10/25/2000 23:00'!
shrink
	"Shorten the tape by deleting mouseMove events that can just as well be
	interpolated later at playback time."

	| oldSize priorSize |
	self writeCheck.
	oldSize _ priorSize _ tape size.
	[self condense.  tape size < priorSize] whileTrue: [priorSize _ tape size].
	PopUpMenu notify: oldSize printString , ' events reduced to ' , tape size printString.
	voiceRecorder ifNotNil: [voiceRecorder suppressSilence].
	saved _ false.
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 1/2/2001 15:45'!
step

	(state == #record and: [voiceRecorder notNil]) ifTrue: [
		recordMeter width: (voiceRecorder meterLevel + 1).
	].
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 1/2/2001 10:28'!
stepTime

	^500
! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 1/2/2001 15:45'!
stop

	state = #record ifTrue:
		[tape _ tapeStream contents.
		saved _ false].
	journalFile ifNotNil:
		[journalFile close].
	self pauseIn: self world.
	tapeStream _ nil.
	state _ nil.
	statusLight color: Color green.
	recordMeter ifNotNil: [recordMeter width: 1].

	self checkTape.! !

!EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 1/2/2001 10:25'!
wantsSteps

	^true
! !


!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'ar 10/25/2000 20:04'!
pauseIn: aWorld
	"Suspend playing or recording, either as part of a stop command,
	or as part of a project switch, after which it will be resumed."

	state = #play ifTrue:
		[state _ #suspendedPlay.
		playHand delete.
		aWorld removeHand: playHand.
		playHand _ nil].
	state = #record ifTrue:
		[state _ #suspendedRecord.
		recHand removeEventListener: self.
		recHand _ nil].

	voiceRecorder ifNotNil:
		[voiceRecorder pause.
		startSoundEvent ifNotNil:
			[startSoundEvent argument: voiceRecorder recordedSound.
			voiceRecorder clearRecordedSound.
			startSoundEvent _ nil]].
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'di 4/20/1999 16:29'!
resumeIn: aWorld
	"Resume playing or recording after a project switch."

	state = #suspendedPlay ifTrue:
		[self resumePlayIn: aWorld].
	state = #suspendedRecord ifTrue:
		[self resumeRecordIn: aWorld].
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'ar 10/25/2000 20:58'!
resumePlayIn: aWorld

	playHand _ HandMorphForReplay new recorder: self.
	playHand position: tapeStream peek position.
	aWorld addHand: playHand.
	playHand newKeyboardFocus: aWorld.
	playHand userInitials: 'play' andPicture: nil.

	lastEvent _ nil.
	lastDelta _ 0@0.
	state _ #play.

	self synchronize.
! !

!EventRecorderMorph methodsFor: 'pause/resume' stamp: 'ar 10/26/2000 00:50'!
resumeRecordIn: aWorld

	recHand _ aWorld activeHand ifNil: [aWorld primaryHand].
	recHand newKeyboardFocus: aWorld.
	recHand addEventListener: self.

	lastEvent _ nil.
	state _ #record.

	voiceRecorder ifNotNil:
		[voiceRecorder clearRecordedSound.
		voiceRecorder resumeRecording.
		startSoundEvent _ MorphicUnknownEvent new setType: #startSound argument: nil hand: nil stamp: Time millisecondClockValue.
		tapeStream nextPut: startSoundEvent].

	self synchronize.
! !


!EventRecorderMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 21:26'!
handleListenEvent: anEvent
	"Record the given event"
	(state == #record and:[anEvent hand == recHand]) 
		ifFalse:[^self].
	anEvent = lastEvent ifTrue: [^ self].
	(anEvent isKeyboard and:[anEvent keyValue = 27 "esc"])
		ifTrue: [^ self stop].
	time _ anEvent timeStamp.
	tapeStream nextPut: (anEvent copy setHand: nil).
	journalFile ifNotNil:
		[journalFile store: anEvent; cr; flush].
	lastEvent _ anEvent.! !

!EventRecorderMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 00:50'!
nextEventToPlay
	"Return the next event when it is time to be replayed.
	If it is not yet time, then return an interpolated mouseMove.
	Return nil if nothing has happened.
	Return an EOF event if there are no more events to be played."
	| nextEvent now nextTime lastP delta |
	(tapeStream == nil or:[tapeStream atEnd]) 
		ifTrue:[^MorphicUnknownEvent new setType: #EOF argument: nil].
	now _ Time millisecondClockValue.
	nextEvent _ tapeStream next.
	deltaTime ifNil:[deltaTime _ now - nextEvent timeStamp].
	nextTime _ nextEvent timeStamp + deltaTime.
	now < time ifTrue:["clock rollover"
		time _ now.
		deltaTime _ nil.
		^nil "continue it on next cycle"].
	time _ now.
	(now >= nextTime) ifTrue:[
		nextEvent _ nextEvent copy setTimeStamp: nextTime.
		nextEvent isMouse ifTrue:[lastEvent _ nextEvent] ifFalse:[lastEvent _ nil].
		^nextEvent].
	tapeStream skip: -1.
	"Not time for the next event yet, but interpolate the mouse.
	This allows tapes to be compressed when velocity is fairly constant."
	lastEvent ifNil: [^ nil].
	lastP _ lastEvent position.
	delta _ (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp).
	delta = lastDelta ifTrue: [^ nil]. "No movement"
	lastDelta _ delta.
	^MouseMoveEvent new
		setType: #mouseMove 
		startPoint: lastEvent position endPoint: lastP + delta
		trail: #() buttons: lastEvent buttons hand: nil stamp: now.! !

!EventRecorderMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 20:44'!
synchronize

	time _ Time millisecondClockValue.
	deltaTime _ nil.! !


!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 23:02'!
checkTape
	"See if this tape was already converted to the new format"
	tape ifNil:[^self].
	tape size = 0 ifTrue:[^self].
	(tape first isKindOf: Association) ifTrue:[tape _ self convertV0Tape: tape].! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:04'!
convertV0Tape: anArray
	"Convert the tape into the new format"
	| lastKey evt |
	lastKey _ 0.
	^anArray collect:[:assn| 
		evt _ assn value.
		evt setTimeStamp: (lastKey _ lastKey + assn key).
		evt]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:00'!
readFrom: aStream
	"Private"
	| cr header |
	cr _ Character cr.
	header _ aStream upTo: cr.
	(header = 'Event Tape v1 BINARY') ifTrue:[^aStream fileInObjectAndCode].
	(header = 'Event Tape v1 ASCII') ifTrue:[^self readFromV1: aStream].
	"V0 had no header so guess"
	aStream reset.
	header first isDigit ifFalse:[^self convertV0Tape: (aStream fileInObjectAndCode)].
	^self convertV0Tape: (self readFromV0: aStream).
! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:55'!
readFromV0: aStream
	| cr line lineStream t evt |
	cr _ Character cr.
	^Array streamContents:[:tStream |
		[aStream atEnd] whileFalse:
			[line _ aStream upTo: cr.
			line isEmpty "Some MW tapes have an empty record at the end"
				ifFalse: [lineStream _ ReadStream on: line.
						t _ Integer readFrom: lineStream.
						[lineStream peek isLetter] whileFalse: [lineStream next].
						evt _ MorphicEvent readFromObsolete: lineStream.
						tStream nextPut: t -> evt]]].! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/26/2000 01:55'!
readFromV1: aStream
	| cr |
	cr _ Character cr.
	^Array streamContents:[:tStream |
		[aStream atEnd] whileFalse:[
			tStream nextPut: (MorphicEvent readFromString: (aStream upTo: cr))]]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'sma 6/18/2000 10:33'!
readTape
	(Smalltalk
		at: #RequestBoxMorph
		ifAbsent:
			[^ self readTape:
				(FillInTheBlank
					request: 'Tape to read'
					initialAnswer: 'tapeName.tape')])
		request: 'Tape to read'
		respondTo: self
		selector: #readTape:! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:00'!
readTape: fileName 
	| file |
	self writeCheck.
	(FileStream isAFileNamed: fileName) ifFalse: [^ nil].
	file _ FileStream oldFileNamed: fileName.
	tape _ self readFrom: file.
	file close.
	saved _ true  "Still exists on file"! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'di 2/15/1999 16:05'!
writeCheck
	(saved not and: [self confirm: 'The current tape has not been saved.
Would you like to do so now?']) ifTrue:
		[self writeTape].
! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:11'!
writeFileNamed: fileName
	| file noVoice delta |
	file _ FileStream newFileNamed: fileName.
	noVoice _ true.
	tape do:[:evt | evt type = #startSound ifTrue: [noVoice _ false]].
	noVoice
		ifTrue: ["Simple format (reads fast) for no voice"
				file nextPutAll:'Event Tape v1 ASCII'; cr.
				delta _ tape first timeStamp.
				tape do: [:evt | file store: (evt copy setTimeStamp: evt timeStamp-delta); cr].
				file close]
		ifFalse: ["Inclusion of voice events requires general object storage"
				file nextPutAll:'Event Tape v1 BINARY'; cr.
				file fileOutClass: nil andObject: tape].
	saved _ true.
	^ file name! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'sma 6/18/2000 10:34'!
writeTape
	| args b |
	args _ (b _ self button: 'writeTape') isNil
				ifTrue: [#()]
				ifFalse: [b arguments].
	(args size > 0 and: [args first size > 0])
		ifTrue: [args first.
				self writeTape: args first]
		ifFalse: [(Smalltalk
					at: #RequestBoxMorph
					ifAbsent:
						[^ self writeTape:
							(FillInTheBlank
								request: 'Tape to write'
								initialAnswer: 'tapeName.tape')])
						request: 'Tape to write'
						respondTo: self
						selector: #writeTape:]! !

!EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'ar 10/25/2000 22:11'!
writeTape: fileName 
	| b name |
	name _ self writeFileNamed: fileName.
	(b _ self button: 'writeTape') ifNotNil: [
		b actionSelector: #writeTape:.
		b arguments: (Array with: name)].
! !



!EventRecorderMorph methodsFor: 'piano rolls' stamp: 'RAA 12/13/2000 13:07'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX myDurationInTicks endX |

	startX _ pianoRoll xForTime: t.
	myDurationInTicks _ pianoRoll scorePlayer ticksForMSecs: self myDurationInMS.
	t > rightTime ifTrue: [^ self].  
	(t + myDurationInTicks) < leftTime ifTrue: [^ self].
	endX _ pianoRoll xForTime: t + myDurationInTicks.

	morphList add: 
		(self hResizing: #spaceFill; left: startX; width: endX - startX).

! !

!EventRecorderMorph methodsFor: 'piano rolls' stamp: 'RAA 12/13/2000 12:40'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	self play.! !

!EventRecorderMorph methodsFor: 'piano rolls' stamp: 'RAA 12/13/2000 13:07'!
justDroppedIntoPianoRoll: newOwner event: evt
	
	| startX lengthInTicks endX startTimeInScore endTimeInScore |

	super justDroppedIntoPianoRoll: newOwner event: evt.

	startTimeInScore _ newOwner timeForX: self left.
	lengthInTicks _ newOwner scorePlayer ticksForMSecs: self myDurationInMS.
	endTimeInScore _ startTimeInScore + lengthInTicks.

	endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
		[newOwner scorePlayer updateDuration].

	startX _ newOwner xForTime: startTimeInScore.
	endX _ newOwner xForTime: endTimeInScore.
	self width: endX - startX.
! !

!EventRecorderMorph methodsFor: 'piano rolls' stamp: 'RAA 12/13/2000 13:07'!
myDurationInMS

	^tape isEmptyOrNil ifTrue: [
		10
	] ifFalse: [
		tape last timeStamp - tape first timeStamp
	]
! !

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

EventRecorderMorph class
	instanceVariableNames: ''!

!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'mdr 8/31/2000 18:48'!
fromFileNamed: aFileName
	| file answer |
	file _ FileStream readOnlyFileNamed: aFileName.
	answer _ self readFrom: file.
	file close.
	^ answer! !

!EventRecorderMorph class methodsFor: 'instance creation' stamp: 'LC 12/23/1998 11:14'!
readFrom: aStream
	^ self new readFrom: aStream! !
InputSensor subclass: #EventSensor
	instanceVariableNames: 'mouseButtons mousePosition keyboardBuffer interruptKey interruptSemaphore eventQueue inputProcess inputSemaphore '
	classVariableNames: 'EventPollFrequency '
	poolDictionaries: 'EventSensorConstants '
	category: 'Kernel-Processes'!
!EventSensor commentStamp: '<historical>' prior: 0!
EventSensor is a replacement for InputSensor based on a set of (optional) event primitives. An EventSensor updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before, by moving the current VM mechanisms into EventSensor itself. An optional input semaphore is part of the new design. For platforms that support true asynchronous event notification the semaphore can be signaled to indicate pending events. However, since most platforms do not support asynchronous notifications about events EventSensor still has to poll every now and then.

Instance variables:
	mouseButtons <Integer>	- mouse button state as replacement for primMouseButtons
	mousePosition <Point>	- mouse position as replacement for primMousePt
	keyboardBuffer <SharedQueue>	- keyboard input buffer
	interruptKey <Integer>			- currently defined interrupt key
	interruptSemaphore <Semaphore>	- the semaphore signaled when the interruptKey is detected
	eventQueue <SharedQueue>	- an optional event queue for event driven applications
	inputProcess <Process>		- the process receiving low-level events
	inputSemaphore <Semaphore>- the semaphore signaled by the VM if asynchronous event notification is supported

Class variables:
	EventPollFrequency <Integer>	- the number of milliseconds to wait between polling for more events

Event format:
The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported.

Currently, the following events are defined:

Null event
=============
The Null event is returned when the ST side asks for more events but no more events are available.
Structure:
[1]		- event type 0
[2-8]	- unused

Mouse event structure
==========================
Mouse events are generated when mouse input is detected.
Structure:
[1]	- event type 1
[2]	- time stamp
[3]	- mouse x position
[4]	- mouse y position
[5]	- button state; bitfield with the following entries:
		1	-	yellow (e.g., right) button
		2	-	blue (e.g., middle) button
		4	-	red (e.g., left) button
		[all other bits are currently undefined]
[6]	- modifier keys; bitfield with the following entries:
		1	-	shift key
		2	-	ctrl key
		4	-	(Mac specific) option key
		8	-	Cmd/Alt key
		[all other bits are currently undefined]
[7]	- reserved.
[8]	- reserved.

Keyboard events
====================
Keyboard events are generated when keyboard input is detected.
[1]	- event type 2
[2]	- time stamp
[3]	- character code
		For now the character code is in Mac Roman encoding.
[4]	- press state; integer with the following meaning
		0	-	character
		1	-	key press (down)
		2	- 	key release (up)
[5]	- modifier keys (same as in mouse events)
[6]	- reserved.
[7]	- reserved.
[8]	- reserved.
!


!EventSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 14:39'!
initialize
	"Initialize the receiver"
	mouseButtons _ 0.
	mousePosition _ 0@0.
	keyboardBuffer _ SharedQueue new.
	interruptKey _ interruptKey ifNil:[2094].  "cmd-."
	interruptSemaphore _ (Smalltalk specialObjectsArray at: 31) ifNil:[Semaphore new].
	eventQueue _ nil.
	inputProcess _ nil.
	inputSemaphore _ Semaphore new.
! !

!EventSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 14:51'!
shutDown
	inputProcess ifNotNil:[inputProcess terminate].
	inputProcess _ nil.
	inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore].! !

!EventSensor methodsFor: 'initialize' stamp: 'ar 10/10/2000 23:09'!
startUp
	"Run the I/O process"
	self shutDown.
	self initialize.
	self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore).
	inputProcess _ [self ioProcess] forkAt: Processor lowIOPriority.
	super startUp.
	Smalltalk isMorphic ifTrue:[self eventQueue: SharedQueue new].! !


!EventSensor methodsFor: 'accessing' stamp: 'ar 7/23/2000 14:37'!
eventQueue
	"Return the current event queue"
	^eventQueue! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 7/23/2000 14:38'!
eventQueue: aSharedQueue
	"Install a new queue for events.
	If an eventQueue is present all events will be queued up there.
	It is assumed that a client installing an event queue will actually
	read data from it, otherwise the system will overflow."
	eventQueue _ aSharedQueue.! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 9/26/2000 21:33'!
flushEvents
	eventQueue ifNotNil:[eventQueue _ SharedQueue new].! !

!EventSensor methodsFor: 'accessing' stamp: 'RAA 12/1/2000 10:18'!
inputProcess
	^ inputProcess! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 7/30/2000 15:50'!
nextEvent
	"Return the next event from the receiver."
	eventQueue == nil 
		ifTrue:[^self nextEventSynthesized]
		ifFalse:[^self nextEventFromQueue]
! !

!EventSensor methodsFor: 'accessing' stamp: 'RAA 11/24/2000 11:03'!
nextEventFromQueue
	"Return the next event from the receiver."

	EventPollFrequency _ 20.	"since Squeak is taking the event, reset to normal delay"
	eventQueue isEmpty
		ifTrue:[^nil]
		ifFalse:[^eventQueue next]! !

!EventSensor methodsFor: 'accessing' stamp: 'ar 8/16/2000 22:06'!
nextEventSynthesized
	"Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this."
	| kbd array buttons pos modifiers mapped |
	"First check for keyboard"
	array _ Array new: 8.
	kbd _ self primKbdNext.
	kbd = nil ifFalse:[
		"simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^array].

	"Then check for mouse"
	buttons _ self primMouseButtons.
	pos _ self primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
	^array! !

!EventSensor methodsFor: 'accessing' stamp: 'di 9/13/2000 13:00'!
peekEvent
	"Look ahead at the next event."
	eventQueue == nil 
		ifTrue:[^ nil]
		ifFalse:[^ eventQueue peek]
! !


!EventSensor methodsFor: 'private-I/O' stamp: 'RAA 11/26/2000 11:57'!
ioProcess
	"Run the i/o process"
	| eventBuffer type |
	eventBuffer _ Array new: 8.
	[true] whileTrue:[
		[self primGetNextEvent: eventBuffer.
		type _ eventBuffer at: 1.
		type = EventTypeNone] whileFalse:[self processEvent: eventBuffer].
		inputSemaphore waitTimeoutMSecs: EventPollFrequency.
		Preferences higherPerformance ifTrue: [
			EventPollFrequency _ (EventPollFrequency * 1.5) rounded min: 500.
		].
	].
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:12'!
mapButtons: buttons modifiers: modifiers
	"Map the buttons to yellow or blue based on the given modifiers.
	If only the red button is pressed, then map
		Ctrl-RedButton -> BlueButton.
		Cmd-RedButton -> YellowButton.
	"
	(buttons = RedButtonBit)
		ifFalse:[^buttons].
	(modifiers allMask: CtrlKeyBit) 
		ifTrue:[^BlueButtonBit].
	(modifiers allMask: CommandKeyBit) 
		ifTrue:[^YellowButtonBit].
	^buttons! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/16/2000 22:06'!
primGetNextEvent: array
	"Store the next OS event available into the provided array.
	Essential. If the VM is not event driven the ST code will fall
	back to the old-style mechanism and use the state based
	primitives instead."
	| kbd buttons modifiers pos mapped |
	<primitive: 94>
	"Simulate the events"
	array at: 1 put: EventTypeNone. "assume no more events"

	"First check for keyboard"
	kbd _ super primKbdNext.
	kbd = nil ifFalse:[
		"simulate keyboard event"
		array at: 1 put: EventTypeKeyboard. "evt type"
		array at: 2 put: Time millisecondClockValue. "time stamp"
		array at: 3 put: (kbd bitAnd: 255). "char code"
		array at: 4 put: EventKeyChar. "key press/release"
		array at: 5 put: (kbd bitShift: -8). "modifier keys"
		^self].

	"Then check for mouse"
	buttons _ super primMouseButtons.
	pos _ super primMousePt.
	modifiers _ buttons bitShift: -3.
	buttons _ buttons bitAnd: 7.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	(pos = mousePosition and:[(mapped bitOr: (modifiers bitShift: 3)) = mouseButtons])
		ifTrue:[^self].
	array 
		at: 1 put: EventTypeMouse;
		at: 2 put: Time millisecondClockValue;
		at: 3 put: pos x;
		at: 4 put: pos y;
		at: 5 put: mapped;
		at: 6 put: modifiers.
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/30/2000 18:16'!
primSetInputSemaphore: semaIndex
	"Set the input semaphore the VM should use for asynchronously signaling the availability of events. Primitive. Optional."
	<primitive: 93>
	^nil! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 9/1/2000 14:53'!
processEvent: evt
	"Process a single event. This method is run at high priority."
	| type |
	type _ evt at: 1.

	"Check if the event is a user interrupt"
	(type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[
		((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]])
			 ifTrue:["interrupt key is meta - not reported as event"
					^interruptSemaphore signal].

	"Store the event in the queue if there's any"
	self queueEvent: evt.

	"Update state for InputSensor."
	EventTypeMouse = type ifTrue:[self processMouseEvent: evt].
	EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt].
! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/1/2000 11:55'!
processKeyboardEvent: evt
	"process a keyboard event, updating InputSensor state"
	| charCode pressCode |
	"Never update keyboardBuffer if we have an eventQueue active"
	eventQueue ifNotNil:[^self]. 
	charCode _ evt at: 3.
	charCode = nil ifTrue:[^self]. "extra characters not handled in MVC"
	pressCode _ evt at: 4.
	pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC"
	"mix in modifiers"
	charCode _ charCode bitOr: ((evt at: 5) bitShift: 8).
	mouseButtons _ (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3).
	keyboardBuffer nextPut: charCode.! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 8/16/2000 22:07'!
processMouseEvent: evt
	"process a mouse event, updating InputSensor state"
	| modifiers buttons mapped |
	mousePosition _ (evt at: 3) @ (evt at: 4).
	buttons _ evt at: 5.
	modifiers _ evt at: 6.
	mapped _ self mapButtons: buttons modifiers: modifiers.
	mouseButtons _ mapped bitOr: (modifiers bitShift: 3).! !

!EventSensor methodsFor: 'private-I/O' stamp: 'ar 7/23/2000 14:55'!
queueEvent: evt
	"Queue the given event in the event queue (if any).
	Note that the event buffer must be copied since it
	will be reused later on."
	eventQueue ifNil:[^self].
	eventQueue nextPut: evt clone.! !


!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 00:34'!
primInterruptSemaphore: aSemaphore 
	"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."
	interruptSemaphore _ aSemaphore.
	"backward compatibility: use the old primitive which is obsolete now"
	super primInterruptSemaphore: aSemaphore! !

!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 14:59'!
primKbdNext
	keyboardBuffer isEmpty
		ifTrue:[^nil]
		ifFalse:[^keyboardBuffer next]! !

!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 14:59'!
primKbdPeek
	^keyboardBuffer peek! !

!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 14:59'!
primMouseButtons
	^mouseButtons! !

!EventSensor methodsFor: 'private' stamp: 'ar 7/23/2000 14:59'!
primMousePt
	^mousePosition! !

!EventSensor methodsFor: 'private' stamp: 'ls 10/23/2000 14:14'!
primSetInterruptKey: anInteger
	"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."
	interruptKey _ anInteger.
	"backward compatibility: use the old primitive which is obsolete now"
	super primSetInterruptKey: anInteger! !


!EventSensor methodsFor: 'NOTES' stamp: 'RAA 11/26/2000 12:09'!
higherPerformanceNotes

"
This is mostly a Mac issue, but may have some effect on other platforms. These changes do not take effect until you set the preference #higherPerformance to true. The impact of setting this pref to true may be higher performance for this Squeak image, but lower performance for other applications/processes that may be running concurrently. Experiment with your particular configuration/desires and decide for yourself.

1. In order to reduce the amount of time lost (perhaps 20 to 30% in some cases) to background applications on the Mac, change the strategy used to poll for UI events. Every time we poll the OS for UI events, increase the delay until the next check. Every time Squeak actually requests an event from EventSensor, reset the delay to its normal value (20 ms). This means that a long-running evaluation started in the UI process will receive less competition from background apps (and less overhead even if it is the only app), but normal UI-intensive operations will happen as they do now. What is lost by this change is some sensitivity to mouse events that occur while Squeak is busy over long periods. My thought is that if Squeak is so occupied for a period of seconds, these events are much less useful and perhaps even harmful.

2. Reduce the minimum morphic cycle time (MinCycleLapse) so that the frame rate (and, hence, running of #step methods) can proceed at greater than 50 frames per second. This can be quite beneficial to things like simulations that are run via #step.
"! !

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

EventSensor class
	instanceVariableNames: ''!

!EventSensor class methodsFor: 'class initialization' stamp: 'ar 7/23/2000 15:33'!
initialize
	"EventSensor initialize"
	self initializeEventSensorConstants.

	EventPollFrequency _ 20.
	"Note: The above is important. Most systems will not
	notify the VM about the occurance of events asynchronously.
	Therefore, we have to go check for ourselves every now and then."! !

!EventSensor class methodsFor: 'class initialization' stamp: 'ar 1/30/2001 19:41'!
initializeEventSensorConstants
	"EventSensor initialize"
	Smalltalk declare: #EventSensorConstants from: Undeclared.
	EventSensorConstants == nil ifTrue:[EventSensorConstants _ Dictionary new].
	#(
		(RedButtonBit 4)
		(BlueButtonBit 2)
		(YellowButtonBit 1)

		(ShiftKeyBit 1)
		(CtrlKeyBit 2)
		(OptionKeyBit 4)
		(CommandKeyBit 8)

		"Types of events"
		(EventTypeNone 0)
		(EventTypeMouse 1)
		(EventTypeKeyboard 2)
		(EventTypeDragDropFiles 3)

		"Press codes for keyboard events"
		(EventKeyChar 0)
		(EventKeyDown 1)
		(EventKeyUp 2)

	) do:[:spec|
		EventSensorConstants declare: spec first from: Undeclared.
		EventSensorConstants at: spec first put: spec last.
	].! !

!EventSensor class methodsFor: 'class initialization' stamp: 'ar 7/23/2000 15:06'!
install	"EventSensor install"
	"Install an EventSensor in place of the current Sensor."
	| newSensor |
	Sensor shutDown.
	newSensor _ self new.
	newSensor startUp.
	"Note: We must use #become: here to replace all references to the old sensor with the new one, since Sensor is referenced from all the existing controllers."
	Sensor becomeForward: newSensor. "done"! !


!EventSensor class methodsFor: 'instance creation' stamp: 'ar 7/22/2000 23:22'!
new
	^super new initialize! !
Object subclass: #Exception
	instanceVariableNames: 'messageText initialContext resignalException handlerContext tag activeHandler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!Exception commentStamp: '<historical>' prior: 0!
This is the main class used to implement the exception handling system (EHS).  It plays two distinct roles:  that of the exception, and that of the exception handler.  More specifically, it implements the bulk of the protocols laid out in the ANSI specification - those protocol names are reflected in the message categories.

Exception is an abstract class.  Instances should neither be created nor trapped.  In most cases, subclasses should inherit from Error or Notification rather than directly from Exception.

In implementing this EHS, The Fourth Estate Inc. incorporated some ideas and code from Craig Latta's EHS.  His insights were crucial in allowing us to implement BlockContext>>valueUninterruptably (and by extension, #ensure: and #ifCurtailed:), and we imported the following methods with little or no modification:

ContextPart>>terminateTo:
ContextPart>>terminate
MethodContext>>receiver:
MethodContext>>answer:

Thanks, Craig!!!


!Exception methodsFor: 'private' stamp: 'ikp 9/18/2000 21:36'!
findHandlerFrom: startCtx

       | ctx handler |
       ctx := startCtx.
       [ctx == nil]
               whileFalse:
                       [ctx isHandlerContext
                               ifTrue:
                                       [handler := ctx tempAt: 1. "the first argument"
                                       ((handler handles: self) and: [(ctx tempAt: 3)])
                                               ifTrue: [^ctx]].
                       ctx := ctx sender].
       ^nil! !

!Exception methodsFor: 'private' stamp: 'ikp 9/18/2000 21:47'!
handlerAction

	| na handler returnValue |
	handler := handlerContext tempAt: 2.		"the second argument"
	na := handler numArgs.
	handlerContext tempAt: 3 put: false.
	returnValue := na == 0
		ifTrue: [handler value]
		ifFalse: [handler value: self].
	resignalException == nil ifFalse: [^returnValue].
	"Execution will only continue beyond this point if the handler did not specify a handler action."
	self return: returnValue! !

!Exception methodsFor: 'private' stamp: 'tfei 3/22/1999 10:43'!
initialContext: aContext

	initialContext := aContext! !

!Exception methodsFor: 'private' stamp: 'bf 9/27/1999 16:09'!
receiver
	^initialContext ifNotNil: [initialContext receiver]! !

!Exception methodsFor: 'private' stamp: 'tfei 1/10/2000 18:22'!
setHandlerFrom: startCtx

	handlerContext := self findHandlerFrom: startCtx.
	^handlerContext! !


!Exception methodsFor: 'signaledException' stamp: 'tfei 1/10/2000 18:19'!
isNested
	"Determine whether the current exception handler is within the scope of another handler for the same exception."

	^(self findHandlerFrom: handlerContext sender) ~~ nil! !

!Exception methodsFor: 'signaledException' stamp: 'ar 9/28/2000 20:29'!
outer
	"Evaluate the enclosing exception action for the receiver and return."

	^self isResumable
		ifTrue:
			[self setHandlerFrom: handlerContext sender.
			handlerContext == nil
				ifTrue: [self defaultAction]
				ifFalse: [self handlerAction]]
		ifFalse: [self pass]! !

!Exception methodsFor: 'signaledException' stamp: 'ar 9/28/2000 20:28'!
pass
	"Yield control to the enclosing exception action for the receiver."
	| result |
	self setHandlerFrom: handlerContext sender.
	handlerContext == nil
		ifTrue:
			[result _ self defaultAction.
			self isResumable
				ifTrue: [self resume: result]
				ifFalse: [IllegalResumeAttempt signal]]
		ifFalse: [self handlerAction]! !

!Exception methodsFor: 'signaledException' stamp: 'tfei 6/13/1999 02:05'!
resignalAs: replacementException
	"Signal an alternative exception in place of the receiver."

	thisContext unwindTo: initialContext.
	replacementException initialContext: initialContext.
	resignalException := replacementException! !

!Exception methodsFor: 'signaledException' stamp: 'RAA 12/8/2000 16:26'!
resume
	"Return from the message that signaled the receiver."

	^self resume: nil! !

!Exception methodsFor: 'signaledException' stamp: 'RAA 12/8/2000 16:26'!
resume: resumptionValue
	"Return the argument as the value of the message that signaled the receiver."

	| tc |

	handlerContext ifNotNil: [handlerContext tempAt: 3 put: true].
	self isResumable ifFalse: [IllegalResumeAttempt signal].
	tc := thisContext.
	tc unwindTo: initialContext.
	tc terminateTo: initialContext.
	^resumptionValue! !

!Exception methodsFor: 'signaledException' stamp: 'tfei 6/4/1999 17:55'!
retry
	
"Abort an exception handler and re-evaluate its protected block."

	thisContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	handlerContext restart! !

!Exception methodsFor: 'signaledException' stamp: 'tfei 6/5/1999 00:34'!
retryUsing: alternativeBlock
	
"Abort an exception handler and evaluate a new block in place of the handler's protected block."

	handlerContext receiver: alternativeBlock.
	self retry! !

!Exception methodsFor: 'signaledException' stamp: 'tfei 6/4/1999 17:57'!
return
	"Return nil as the value of the block protected by the active exception handler."

	self return: nil! !

!Exception methodsFor: 'signaledException' stamp: 'tfei 6/9/1999 16:35'!
return: returnValue
	"Return the argument as the value of the block protected by the active exception handler."

	| handlerHomeContext |
	handlerHomeContext := ExceptionAboutToReturn signal.
	initialContext unwindTo: handlerContext.
	thisContext terminateTo: handlerContext.
	handlerHomeContext == nil
		ifFalse: [handlerContext sender swapSender: handlerHomeContext].
	^returnValue! !


!Exception methodsFor: 'exceptionBuilder' stamp: 'tfei 6/4/1999 17:47'!
messageText: signalerText
	
"Set an exception's message text."

	messageText := signalerText! !

!Exception methodsFor: 'exceptionBuilder' stamp: 'tfei 6/6/1999 23:06'!
tag: t
	"TFEI - This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and states that the signaler may store the tag value."

	tag := t! !


!Exception methodsFor: 'exceptionDescription' stamp: 'tfei 6/6/1999 23:06'!
defaultAction
	"The default action taken if the exception is signaled."


	self subclassResponsibility! !

!Exception methodsFor: 'exceptionDescription' stamp: 'tfei 6/6/1999 23:09'!
description
	
"Return a textual description of the exception."

	| desc mt |
	desc := self class name asString.
	^(mt := self messageText) == nil
		ifTrue: [desc]
		ifFalse: [desc, ': ', mt]! !

!Exception methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 17:36'!
isResumable
	
"Determine whether an exception is resumable."

	^false! !

!Exception methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 17:40'!
messageText
	
"Return an exception's message text."

	^messageText! !

!Exception methodsFor: 'exceptionDescription' stamp: 'tfei 11/19/1999 08:42'!
tag
       "Return an exception's tag value."

       ^tag == nil
               ifTrue: [self messageText]
               ifFalse: [tag]! !


!Exception methodsFor: 'exceptionSignaler' stamp: 'tfei 1/10/2000 18:23'!
signal
	"Signal the occurrence of an exceptional condition."

	| result |
	initialContext == nil ifTrue: [initialContext := thisContext sender].
	resignalException := nil.
	(self setHandlerFrom: initialContext) == nil
		ifTrue: [^self defaultAction].
	result := self handlerAction.
	^resignalException == nil
		ifTrue: [result]
		ifFalse: [resignalException signal]! !

!Exception methodsFor: 'exceptionSignaler' stamp: 'tfei 6/4/1999 17:46'!
signal: signalerText
	"Signal the occurrence of an exceptional condition with a specified textual description."

	self messageText: signalerText.
	initialContext == nil ifTrue: [initialContext := thisContext sender].
	^self signal! !

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

Exception class
	instanceVariableNames: ''!

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'tfei 6/4/1999 18:12'!
signal
	"Signal the occurrence of an exceptional condition."

	| ex |
	ex := self new.
	ex initialContext: thisContext sender.
	^ex signal! !

!Exception class methodsFor: 'exceptionInstantiator' stamp: 'tfei 6/4/1999 18:15'!
signal: signalerText
	"TFEI - Signal the occurrence of an exceptional condition with a specified textual description."

	| ex |
	ex := self new.
	ex initialContext: thisContext sender.
	^ex signal: signalerText! !


!Exception class methodsFor: 'exceptionSelector' stamp: 'tfei 6/4/1999 18:08'!
, anotherException
	"Create an exception set."

	^ExceptionSet new
		add: self;
		add: anotherException;
		yourself! !

!Exception class methodsFor: 'exceptionSelector' stamp: 'sma 2/12/2000 14:15'!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	(exception isKindOf: Halt) ifTrue: [^ false].
	^ exception isKindOf: self! !
Notification subclass: #ExceptionAboutToReturn
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ExceptionAboutToReturn commentStamp: '<historical>' prior: 0!
This class is private to the EHS implementation.  Its use allows for ensured execution to survive code such as:

[self doThis.
^nil]
	ensure: [self doThat]

Signaling or handling this exception is not recommended.  Not even slightly.!

Object subclass: #ExceptionSet
	instanceVariableNames: 'exceptions '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ExceptionSet commentStamp: '<historical>' prior: 0!
An ExceptionSet is a grouping of exception handlers which acts as a single handler.  Within the group, the most recently added handler will be the last handler found during a handler search (in the case where more than one handler in the group is capable of handling a given exception). !


!ExceptionSet methodsFor: 'private' stamp: 'tfei 7/16/1999 1:07'!
add: anException

	exceptions add: anException! !

!ExceptionSet methodsFor: 'private' stamp: 'tfei 3/23/1999 14:07'!
initialize

	exceptions := OrderedCollection new! !


!ExceptionSet methodsFor: 'exceptionSelector' stamp: 'tfei 6/4/1999 18:37'!
, anException
	"Return an exception set that contains the receiver and the argument exception. This is commonly used to specify a set of exception selectors for an exception handler."

	self add: anException.
	^self! !

!ExceptionSet methodsFor: 'exceptionSelector' stamp: 'tfei 6/4/1999 18:37'!
handles: anException
	"Determine whether an exception handler will accept a signaled exception."


	exceptions do:
		[:ex |
		(ex handles: anException)
			ifTrue: [^true]].
	^false! !

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

ExceptionSet class
	instanceVariableNames: ''!

!ExceptionSet class methodsFor: 'exceptionInstantiator' stamp: 'tfei 3/23/1999 14:06'!
new

	^super new initialize! !
Object subclass: #ExceptionTester
	instanceVariableNames: 'log suiteLog '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Tests'!

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'!
doSomething

	self log: self doSomethingString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'!
doSomethingElse

	self log: self doSomethingElseString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'!
doSomethingExceptional

	self log: self doSomethingExceptionalString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'!
doYetAnotherThing

	self log: self doYetAnotherThingString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'!
methodWithError

	MyTestError signal: self testString! !

!ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'!
methodWithNotification

	MyTestNotification signal: self testString! !


!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:17'!
clearLog

	log := nil! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:16'!
contents

	^( self log
		inject: (WriteStream on: (String new: 80))
		into: 
			[:result :item |
			result 
				cr; 
				nextPutAll: item;
				yourself] ) contents! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:03'!
log: aString

	self log add: aString! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'!
logTest: aSelector

	self suiteLog add: aSelector! !

!ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:38'!
logTestResult: aString

	| index |
	index := self suiteLog size.
	self suiteLog 
		at: index
		put: ((self suiteLog at: index), ' ', aString)! !


!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'!
runAllTests
	"ExceptionTester new runAllTests"

	self
		runBasicTests;
		runBasicANSISignaledExceptionTests! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'!
runBasicANSISignaledExceptionTests

	self basicANSISignaledExceptionTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !

!ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'!
runBasicTests

	self basicTestSelectors
		do:
			[:eachTestSelector |
			self runTest: eachTestSelector]! !


!ExceptionTester methodsFor: 'testing' stamp: 'tfei 8/19/1999 03:10'!
runTest: aSelector

	| expectedResult |
	[expectedResult := self perform: (aSelector, #Results) asSymbol.
	self logTest: aSelector.
	self clearLog.
	self perform: aSelector.
	] on: MyTestError
	  do: 
		[ :ex |
		self log: 'Unhandled Exception'.
		ex return: nil].
	self log = expectedResult
		ifTrue: [self logTestResult: 'succeeded']
		ifFalse: [self logTestResult: 'failed']! !


!ExceptionTester methodsFor: 'tests' stamp: 'tfei 11/14/1999 17:26'!
doubleResumeTest

       [self doSomething.
       MyResumableTestError signal.
       self doSomethingElse.
       MyResumableTestError signal.
       self doYetAnotherThing]
               on: MyResumableTestError
               do: [:ex | ex resume].! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'!
nonResumableFallOffTheEndHandler
	
	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'!
resumableFallOffTheEndHandler

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | self doSomethingExceptional].
	self doYetAnotherThing! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'!
signalFromHandlerActionTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[self doYetAnotherThing.
			MyTestError signal]! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'!
simpleEnsureTest

	[self doSomething.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'!
simpleEnsureTestWithError

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'!
simpleEnsureTestWithNotification

	[self doSomething.
	self methodWithNotification.
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'!
simpleEnsureTestWithUparrow

	[self doSomething.
	true ifTrue: [^nil].
	self doSomethingElse]
		ensure:
			[self doYetAnotherThing].
	! !

!ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'!
warningTest

	self log: 'About to signal warning.'.
	Warning signal: 'Ouch'.
	self log: 'Warning signal handled and resumed.'! !


!ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'!
doubleResumeTestResults

       ^OrderedCollection new
               add: self doSomethingString;
               add: self doSomethingElseString;
               add: self doYetAnotherThingString;
               yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'!
nonResumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'!
resumableFallOffTheEndHandlerResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingExceptionalString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'!
signalFromHandlerActionTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'!
simpleEnsureTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'!
simpleEnsureTestWithErrorResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'!
simpleEnsureTestWithNotificationResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doSomethingElseString;
		add: self doYetAnotherThingString;
		yourself! !

!ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'!
simpleEnsureTestWithUparrowResults

	^OrderedCollection new
		add: self doSomethingString;
"		add: self doSomethingElseString;"
		add: self doYetAnotherThingString;
		yourself! !


!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/12/1999 23:59'!
basicANSISignaledExceptionTestSelectors

	^#( simpleIsNestedTest simpleOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 11/14/1999 17:33'!
basicTestSelectors

       ^#( simpleEnsureTest simpleEnsureTestWithNotification simpleEnsureTestWithUparrow simpleEnsureTestWithError signalFromHandlerActionTest
               resumableFallOffTheEndHandler nonResumableFallOffTheEndHandler doubleResumeTest)! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingElseString

	^'Do something else.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'!
doSomethingExceptionalString

	^'Do something exceptional.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'!
doSomethingString

	^'Do something.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
doYetAnotherThingString

	^'Do yet another thing.'! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'!
log

	log == nil
		ifTrue: [log := OrderedCollection new].
	^log! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'!
suiteLog

	suiteLog == nil
		ifTrue: [suiteLog := OrderedCollection new].
	^suiteLog! !

!ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'!
testString

	^'This is only a test.'! !


!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:27'!
simpleIsNestedTest
	"uses resignalAs:"

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			ex isNested "expecting to detect handler in #runTest:"
				ifTrue:
					[self doYetAnotherThing.
					ex resignalAs: MyTestNotification new]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:36'!
simpleOuterTest
	"uses #resume"

	[[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do: [:ex | ex outer]]
				on: MyTestNotification
				do: [:ex | self doYetAnotherThing. ex resume]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:37'!
simplePassTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex pass "expecting handler in #runTest:"]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 02:12'!
simpleResignalAsTest
	"ExceptionTester new simpleResignalAsTest"

	[self doSomething.
	MyTestNotification signal.
	self doSomethingElse]
		on: MyTestNotification
		do:
			[:ex | ex resignalAs: MyTestError new]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'RAA 12/8/2000 12:58'!
simpleResumeTest

	"see if we can resume twice"

	| it |
	[self doSomething.
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	it := MyResumableTestError signal.
	it = 3 ifTrue: [self doSomethingElse].
	]
		on: MyResumableTestError
		do:
			[:ex |
			self doYetAnotherThing.
			ex resume: 3]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:02'!
simpleRetryTest

	| theMeaningOfLife |
	theMeaningOfLife := nil.
	[self doSomething.
	theMeaningOfLife == nil
		ifTrue: [MyTestError signal]
		ifFalse: [self doSomethingElse]]
			on: MyTestError
			do:
				[:ex |
				theMeaningOfLife := 42.
				self doYetAnotherThing.
				ex retry]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:03'!
simpleRetryUsingTest

	[self doSomething.
	MyTestError signal.
	self doSomethingElse]
		on: MyTestError
		do:
			[:ex | ex retryUsing: [self doYetAnotherThing]]! !

!ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:59'!
simpleReturnTest

	| it |
	it :=
		[self doSomething.
		MyTestError signal.
		self doSomethingElse]
			on: MyTestError
			do: [:ex | ex return: 3].
	it = 3 ifTrue: [self doYetAnotherThing]! !


!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:09'!
simpleIsNestedTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simpleOuterTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: self doSomethingElseString;
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'!
simplePassTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:11'!
simpleResignalAsTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: 'Unhandled Exception';
		yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'RAA 12/8/2000 12:59'!
simpleResumeTestResults

	"see if we can resume twice"

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			add: self doYetAnotherThingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			add: self doSomethingString;
			add: self doSomethingElseString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'!
simpleRetryUsingTestResults

	^OrderedCollection new
			add: self doSomethingString;
			add: self doYetAnotherThingString;
			yourself! !

!ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 02:22'!
simpleReturnTestResults

	^OrderedCollection new
		add: self doSomethingString;
		add: self doYetAnotherThingString;
		yourself! !
ByteArray variableByteSubclass: #ExternalAddress
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Kernel'!
!ExternalAddress commentStamp: '<historical>' prior: 0!
An ExternalAddress is an opaque handle to objects outside Smalltalk memory (e.g., a pointer).!


!ExternalAddress methodsFor: 'initialize-release' stamp: 'ar 11/22/1999 04:25'!
beNull
	"Make the receiver a NULL pointer"
	self atAllPut: 0.! !

!ExternalAddress methodsFor: 'initialize-release' stamp: 'ar 11/28/1999 23:40'!
free
	"Primitive. Free the object pointed to on the external heap.
	Dangerous - may break your system if the receiver hasn't been
	allocated by ExternalAddress class>>allocate:. No checks are done."
	<primitive:'primitiveFFIFree' module:'SqueakFFIPrims'>
	^self primitiveFailed! !


!ExternalAddress methodsFor: 'accessing' stamp: 'ar 11/21/1999 15:43'!
byteAt: byteOffset
	"Go through a different primitive since the receiver describes data in the outside world"
	^self unsignedByteAt: byteOffset! !

!ExternalAddress methodsFor: 'accessing' stamp: 'ar 11/21/1999 15:43'!
byteAt: byteOffset put: value
	"Go through a different primitive since the receiver describes data in the outside world"
	^self unsignedByteAt: byteOffset put: value! !

!ExternalAddress methodsFor: 'accessing' stamp: 'ar 11/28/1999 23:09'!
isExternalAddress
	"Return true if the receiver describes an object in the outside world"
	^true! !


!ExternalAddress methodsFor: 'private' stamp: 'ar 1/28/2000 17:45'!
asByteArrayPointer
	"Return a ByteArray describing a pointer to the contents of the receiver."
	^(ByteArray new: 4)
		byteAt: 1 put: (self basicAt: 1);
		byteAt: 2 put: (self basicAt: 2);
		byteAt: 3 put: (self basicAt: 3);
		byteAt: 4 put: (self basicAt: 4);
	yourself! !


!ExternalAddress methodsFor: 'converting' stamp: 'hg 3/1/2000 22:27'!
asInteger
	"convert address to integer"
	^self inject: 0 into: [:total :byte | total * 256 + byte]! !

!ExternalAddress methodsFor: 'converting' stamp: 'hg 3/1/2000 23:00'!
fromInteger: address
	"set my handle to point at address"

	(4 to: 1 by: -1) inject: address into: [:remainder :index | 
		self at: index put: (remainder bitAnd: 255).
		remainder // 256]! !


!ExternalAddress methodsFor: 'printing' stamp: 'sma 6/1/2000 09:45'!
printOn: aStream
	"print this as a hex address ('@ 16rFFFFFFFF') to distinguish it from ByteArrays"

	aStream nextPutAll: '@ '; nextPutAll: self asInteger hex8! !

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

ExternalAddress class
	instanceVariableNames: ''!

!ExternalAddress class methodsFor: 'class initialization' stamp: 'ar 11/28/1999 23:32'!
startUp: resuming
	resuming ifTrue:[self allInstancesDo:[:addr| addr beNull]].! !


!ExternalAddress class methodsFor: 'instance creation' stamp: 'ar 11/28/1999 23:20'!
allocate: byteSize
	"Primitive. Allocate an object on the external heap."
	<primitive:'primitiveFFIAllocate' module:'SqueakFFIPrims'>
	^self primitiveFailed! !

!ExternalAddress class methodsFor: 'instance creation' stamp: 'ar 11/21/1999 15:44'!
new
	"External addresses are always 4 bytes long"
	^super new: 4! !

!ExternalAddress class methodsFor: 'instance creation' stamp: 'ar 11/21/1999 15:44'!
new: n
	"You better don't try this..."
	^self shouldNotImplement! !
ExternalStructure subclass: #ExternalData
	instanceVariableNames: 'type '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Kernel'!
!ExternalData commentStamp: '<historical>' prior: 0!
Instances of ExternalData explicitly describe objects with associated type. They can be used for describing atomic C types like arrays of atomic types (e.g., 'int[]') or pointer to atomic types (e.g., 'int *').

Instance variables:
	type	<Integer | Behavior>	The basic type of the receiver.

The encoding of type is equivalent to that of the basic type in class ExternalType. The interpretation of whether the receiver describes an array of data or a pointer to data depends on the contents of the instance variable 'handle'. If handle contains an ExternalAddress the receiver is treated as pointer to type. If the handle contains a ByteArray the receiver is interpreted as describing an array of type. Note that both interpretations are treated equivalent in external calls, e.g., if one describes an argument to an external call as taking 'int*' then, depending on the type of handle either the actual contents (if ExternalAddress) or a pointer to the contents (if ByteArray) is passed.

!


!ExternalData methodsFor: 'private' stamp: 'ar 11/21/1999 14:23'!
setHandle: aHandle type: aType
	handle _ aHandle.
	type _ aType.! !


!ExternalData methodsFor: 'conversion' stamp: 'hg 2/25/2000 14:51'!
fromCString
	"Assume that the receiver represents a C string and convert it to a Smalltalk string. hg 2/25/2000 14:18"

	| stream index char |
	type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].
	stream _ WriteStream on: String new.
	index _ 1.
	[(char _ handle unsignedCharAt: index) = 0 asCharacter] whileFalse: [
		stream nextPut: char.
		index _ index + 1].
	^stream contents! !

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

ExternalData class
	instanceVariableNames: ''!

!ExternalData class methodsFor: 'field definition' stamp: 'ar 1/27/2000 01:23'!
fields
	"ExternalData defineFields"
	"Note: The definition is for completeness only.
	ExternalData is treated specially by the VM."
	^#(nil 'void*')! !


!ExternalData class methodsFor: 'instance creation' stamp: 'ar 12/2/1999 14:57'!
fromHandle: aHandle type: aType
	"Create a pointer to the given type"
	"ExternalData fromHandle: ExternalAddress new type: ExternalType float"
	^self basicNew setHandle: aHandle type: aType! !

!ExternalData class methodsFor: 'instance creation' stamp: 'ar 11/22/1999 04:28'!
new
	"You better not..."
	^self shouldNotImplement! !
Form subclass: #ExternalForm
	instanceVariableNames: 'display argbMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-External'!
!ExternalForm commentStamp: '<historical>' prior: 0!
An ExternalForm is just like any other form. It's only difference is that it is allocated on a specific display and can be used for accelerated blts on the particular display.

Upon shutdown of the system ExternalForms will be deallocated from the display and be kept in their internalized form.!


!ExternalForm methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 17:39'!
destroy
	"Destroy the receiver"
	display ifNotNil:[display destroyForm: self]! !

!ExternalForm methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 17:48'!
shutDown
	"System is going down. Internalize my bits and be finished."
	| copy |
	copy _ Form extent: self extent depth: self depth.
	self displayOn: copy.
	copy hibernate. "compact bits of copy"
	self destroy. "Release my external handle"
	bits _ copy bits. "Now compressed"
	display _ nil. "No longer allocated"
	argbMap _ nil. "No longer external"! !


!ExternalForm methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:13'!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB pixel values into the receiver"
	^argbMap ifNil:[argbMap _ ColorMap mappingFromARGB: self rgbaBitMasks].! !

!ExternalForm methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:56'!
displayScreen
	"Return the display screen the receiver is allocated on."
	^display! !

!ExternalForm methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:42'!
rgbaBitMasks
	"Return the masks for specifying the R,G,B, and A components in the receiver"
	display 
		ifNil:[^super rgbaBitMasks]
		ifNotNil:[^display rgbaBitMasksOfForm: self]! !


!ExternalForm methodsFor: 'testing' stamp: 'ar 5/28/2000 17:48'!
isExternalForm
	"I am an external form but only as long as I'm allocated on a display"
	^display notNil! !


!ExternalForm methodsFor: 'private' stamp: 'ar 5/27/2000 16:36'!
getExternalHandle
	"Private. Return the virtual handle used to represent the receiver"
	^bits! !

!ExternalForm methodsFor: 'private' stamp: 'ar 5/27/2000 16:52'!
setExternalHandle: aHandle on: aDisplay
	"Initialize the receiver from the given external handle"
	display _ aDisplay.
	bits _ aHandle.! !
WeakKeyDictionary subclass: #ExternalFormRegistry
	instanceVariableNames: 'lockFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-External'!
!ExternalFormRegistry commentStamp: '<historical>' prior: 0!
The ExternalFormRegistry needs to be synchronized with rendering to prevent forms from being destroyed during rendering. Only at certain points (that is after a rendering cycle is completed) the texture registry may be cleaned up.!


!ExternalFormRegistry methodsFor: 'accessing' stamp: 'ar 5/26/2000 00:40'!
lock
	lockFlag _ true! !

!ExternalFormRegistry methodsFor: 'accessing' stamp: 'ar 5/26/2000 00:40'!
unlock
	lockFlag _ false.! !


!ExternalFormRegistry methodsFor: 'finalization' stamp: 'ar 5/27/2000 00:56'!
finalizeValues
	"This message is sent when an element has gone away."
	lockFlag == true ifTrue:[^self].
	self forceFinalization.! !

!ExternalFormRegistry methodsFor: 'finalization' stamp: 'ar 5/27/2000 00:55'!
forceFinalization
	self associationsDo:[:assoc|
		assoc key isNil ifTrue:[assoc value destroy].
	].
	super finalizeValues.! !
ExternalObject subclass: #ExternalFunction
	instanceVariableNames: 'flags argTypes '
	classVariableNames: 'FFIErrorMessages '
	poolDictionaries: 'FFIConstants '
	category: 'FFI-Kernel'!
!ExternalFunction commentStamp: '<historical>' prior: 0!
This class represents an external function called from Smalltalk. Instances of ExternalFunction can be created if the address/parameters of the function are known by some other means than loading from a shared library or compiling the appropriate primitive specification.

Instance variables:
	flags	<Integer>	a set of flags encoding the calling convention
	args	<Array of: ExternalType>		the parameters of the function

Implementation notes:

The arguments consist of an array with the first element defining the return type, the remaining arguments defining the parameters of the call.
!


!ExternalFunction methodsFor: 'initialize-release' stamp: 'ar 11/29/1999 00:35'!
initialize
	"Initialize the receiver"
	handle _ ExternalAddress new.! !


!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/19/1999 19:13'!
argTypes
	^argTypes! !

!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/19/1999 19:13'!
flags
	^flags! !

!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:55'!
module
	^nil! !

!ExternalFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 17:06'!
name
	^nil! !


!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:54'!
invoke
	^self invokeWithArguments: #()! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'!
invokeWith: arg1
	^self invokeWithArguments: (Array with: arg1)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'!
invokeWith: arg1 with: arg2
	^self invokeWithArguments: (Array with: arg1 with: arg2)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'!
invokeWith: arg1 with: arg2 with: arg3
	^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 19:08'!
invokeWith: arg1 with: arg2 with: arg3 with: arg4
	^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:53'!
invokeWith: arg1 with: arg2 with: arg3 with: arg4 with: arg5
	^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4 with: arg5)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/19/1999 21:54'!
invokeWith: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6
	^self invokeWithArguments: (Array with: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6)! !

!ExternalFunction methodsFor: 'invoking' stamp: 'ar 11/28/1999 20:12'!
invokeWithArguments: argArray
	"Manually invoke the receiver, representing an external function."
	<primitive: 'primitiveCalloutWithArgs' module:'SqueakFFIPrims'>
	^self externalCallFailed! !


!ExternalFunction methodsFor: 'printing' stamp: 'ar 11/19/1999 16:35'!
callingConventionString
	(flags allMask: FFICallTypeApi) 
		ifTrue:[^'apicall']
		ifFalse:[^'cdecl']! !

!ExternalFunction methodsFor: 'printing' stamp: 'ar 11/19/1999 19:12'!
printOn: aStream
	aStream
		nextPut:$<;
		nextPutAll: self callingConventionString; nextPutAll:': ';
		print: argTypes first; space.
	self name == nil
		ifTrue:[aStream nextPutAll:'(*) ']
		ifFalse:[aStream print: self name asString; space].
	aStream nextPut:$(.
	2 to: argTypes size do:[:i|
		aStream print: (argTypes at: i).
		i < argTypes size ifTrue:[aStream space]].
	aStream nextPut:$).
	self module == nil ifFalse:[
		aStream space; nextPutAll:'module: '; print: self module asString.
	].
	aStream nextPut:$>! !

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

ExternalFunction class
	instanceVariableNames: ''!

!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 11/19/1999 19:10'!
initialize
	"ExternalFunction initialize"
	self initializeCallingConventions.
	self initializeErrorConstants.! !

!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 11/19/1999 16:35'!
initializeCallingConventions
	"ExternalFunction initializeCallingConventions"
	#(
		(FFICallTypeCDecl 0)
		(FFICallTypeApi 1)
	) do:[:spec|
		FFIConstants declare: spec first from: Undeclared.
		FFIConstants at: spec first put: spec last.
	].
! !

!ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 11/28/1999 18:52'!
initializeErrorConstants
	"ExternalFunction initializeErrorConstants"
	FFIErrorMessages _ Dictionary new.
	#(
		"No callout mechanism available"
		(FFINoCalloutAvailable -1 'Callout mechanism not available')
		"generic error"
		(FFIErrorGenericError 0 'A call to an external function failed')
		"primitive invoked without ExternalFunction"
		(FFIErrorNotFunction 1 'Only ExternalFunctions can be called')
		"bad arguments to primitive call"
		(FFIErrorBadArgs 2 'Bad arguments in primitive invokation')

		"generic bad argument"
		(FFIErrorBadArg 3 'Bad argument for external function')
		"int passed as pointer"
		(FFIErrorIntAsPointer 4 'Cannot use integer as pointer')
		"bad atomic type (e.g., unknown)"
		(FFIErrorBadAtomicType 5 'Unknown atomic type in external call')
		"argument coercion failed"
		(FFIErrorCoercionFailed 6 'Could not coerce arguments')
		"Type check for non-atomic types failed"
		(FFIErrorWrongType 7 'Wrong type in external call')
		"struct size wrong or too large"
		(FFIErrorStructSize 8 'Bad structure size in external call')
		"unsupported calling convention"
		(FFIErrorCallType 9 'Unsupported calling convention')
		"cannot return the given type"
		(FFIErrorBadReturn 10 'Cannot return the given type')
		"bad function address"
		(FFIErrorBadAddress 11 'Bad function address')
		"no module given but required for finding address"
		(FFIErrorNoModule 12 'No module to load address from')
		"function address not found"
		(FFIErrorAddressNotFound 13 'Unable to find function address')
		"attempt to pass 'void' parameter"
		(FFIErrorAttemptToPassVoid 14 'Cannot pass ''void'' parameter')
		"module not found"
		(FFIErrorModuleNotFound 15 'External module not found')
		"external library invalid"
		(FFIErrorBadExternalLibrary 16 'External library is invalid')
		"external function invalid"
		(FFIErrorBadExternalFunction 17 'External function is invalid')
		"ExternalAddress points to ST memory (don't you dare to do this!!)"
		(FFIErrorInvalidPointer 18 'Attempt to pass invalid pointer')
	) do:[:spec|
		FFIConstants declare: spec first from: Undeclared.
		FFIConstants at: spec first put: spec second.
		FFIErrorMessages at: spec second put: spec third.
	].! !


!ExternalFunction class methodsFor: 'constants' stamp: 'ar 11/19/1999 16:36'!
callTypeAPI
	^FFICallTypeApi! !

!ExternalFunction class methodsFor: 'constants' stamp: 'ar 11/19/1999 16:36'!
callTypeCDecl
	^FFICallTypeCDecl! !


!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:20'!
atomicTypeNamed: aString
	^ExternalType atomicTypeNamed: aString! !

!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 11/17/1999 19:58'!
callingConventionFor: aString
	"Return the constant describing the calling convention for the given string specification or nil if unknown."
	aString = 'cdecl:' ifTrue:[^self callTypeCDecl].
	aString = 'apicall:' ifTrue:[^self callTypeAPI].
	^nil! !

!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:49'!
forceTypeNamed: aString
	^ExternalType forceTypeNamed: aString! !

!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:30'!
isValidType: anObject
	^anObject isBehavior and:[anObject includesBehavior: ExternalStructure]! !

!ExternalFunction class methodsFor: 'compiler support' stamp: 'ar 12/2/1999 16:21'!
structTypeNamed: aString
	^ExternalType structTypeNamed: aString! !


!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/19/1999 14:17'!
errorMessageFor: code
	"Return the error message for the given error code from the foreign function interface"
	^FFIErrorMessages at: code ifAbsent:['Call to external function failed'].! !

!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/19/1999 19:09'!
externalCallFailed
	"Raise an error after a failed call to an external function"
	| errCode |
	errCode _ self getLastError. "this allows us to look at the actual error code"
	^self error: (self errorMessageFor: errCode).! !

!ExternalFunction class methodsFor: 'error handling' stamp: 'ar 11/28/1999 18:37'!
getLastError
	"Return the last error from an external call.
	Only valid immediately after the external call failed."
	<primitive: 'primitiveFFIGetLastError' module:'SqueakFFIPrims'>
	^-1! !
ExternalObject subclass: #ExternalLibrary
	instanceVariableNames: 'name '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Kernel'!
!ExternalLibrary commentStamp: '<historical>' prior: 0!
An external library bundles calls to functions from the same library. It is provided mainly as convenience since every external function can be fully specified by the name and the module it resides in.

Every external function that is defined in an external library by default will use the library it is defined in. This can always be modified by providing the appropriate module in the specification. !


!ExternalLibrary methodsFor: 'initialize-release' stamp: 'ar 12/8/1999 21:49'!
forceLoading
	"Primitive. Force loading the given library.
	The primitive will fail if the library is not available
	or if anything is wrong with the receiver."
	<primitive: 'primitiveForceLoad' module:'SqueakFFIPrims'>
	^self externalCallFailed "The primitive will set the error code"! !

!ExternalLibrary methodsFor: 'initialize-release' stamp: 'ar 11/29/1999 00:35'!
initialize
	"Initialize the receiver"
	name _ self class moduleName.
	handle _ ExternalAddress new.! !


!ExternalLibrary methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:35'!
handle
	^handle! !

!ExternalLibrary methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:35'!
name
	^name! !

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

ExternalLibrary class
	instanceVariableNames: ''!

!ExternalLibrary class methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:33'!
moduleName
	"Return the name of the module for this library"
	^nil! !
ExternalFunction subclass: #ExternalLibraryFunction
	instanceVariableNames: 'name module '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Kernel'!
!ExternalLibraryFunction commentStamp: '<historical>' prior: 0!
An ExternalLibraryFunction specifies a fully qualified function from an external library.

Instance variables:
	name	<Integer | String>	name or ordinal of function
	module	<String | nil>			name of module (nil if bound in the VM).!


!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 19:55'!
module
	^module! !

!ExternalLibraryFunction methodsFor: 'accessing' stamp: 'ar 11/17/1999 17:06'!
name
	^name! !


!ExternalLibraryFunction methodsFor: 'private' stamp: 'ar 11/19/1999 19:12'!
name: aName module: aModule flags: anInteger argTypes: argTypeArray

	name _ aName.
	module _ aModule.
	flags _ anInteger.
	argTypes _ argTypeArray.! !

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

ExternalLibraryFunction class
	instanceVariableNames: ''!

!ExternalLibraryFunction class methodsFor: 'instance creation' stamp: 'ar 11/17/1999 14:52'!
name: aName module: aModule callType: callType returnType: retType argumentTypes: argTypes
	^self new
		name: aName
		module: aModule
		flags: callType
		argTypes: (Array with: retType), argTypes! !
Object subclass: #ExternalObject
	instanceVariableNames: 'handle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Kernel'!
!ExternalObject commentStamp: '<historical>' prior: 0!
External objects represent entities that are not part of the Smalltalk universe. They are accessed using a unique handle which is interpreted depending on the actual entity that is represented. 

Instance variables:
	handle	<ByteArray | ExternalAddress>!


!ExternalObject methodsFor: 'initialize-release' stamp: 'ar 11/29/1999 00:35'!
initialize
	"Initialize the receiver"! !


!ExternalObject methodsFor: 'private' stamp: 'ar 11/16/1999 20:25'!
getHandle
	"Private. Return the handle used to represent the external entitiy."
	^handle! !

!ExternalObject methodsFor: 'private' stamp: 'ar 11/16/1999 20:26'!
setHandle: anObject
	"Private. Set the handle used to represent the external entity."
	handle _ anObject! !


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

ExternalObject class
	instanceVariableNames: ''!

!ExternalObject class methodsFor: 'class initialization' stamp: 'ar 11/19/1999 22:37'!
initialize
	"ExternalObject initialize"
	Smalltalk addToStartUpList: self after: ShortRunArray.! !


!ExternalObject class methodsFor: 'instance creation' stamp: 'ar 11/17/1999 17:02'!
new
	^super new initialize! !


!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:37'!
install
	"Notify all instances of the receiver that we're coming up on a new platform.
	Note: The default implementation does nothing since the general external
	objects are cleaned up by ExternalAddress>>startUp: but subclasses may
	implement this method so that the appropriate action for existing instances can
	be taken."! !

!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:36'!
installSubclasses
	"Notify all the subclasses of ExternalObject that we are starting up on a new platform."
	self withAllSubclassesDo:[:cls| cls install].! !

!ExternalObject class methodsFor: 'system startup' stamp: 'ar 11/28/1999 23:36'!
startUp: resuming
	"The system is coming up. If it is on a new platform, clear out the existing handles."
	ExternalAddress startUp: resuming. "Make sure handles are invalid"
	resuming ifTrue:[self installSubclasses].
! !
DisplayScreen subclass: #ExternalScreen
	instanceVariableNames: 'argbMap allocatedForms '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-External'!
!ExternalScreen commentStamp: '<historical>' prior: 0!
I represent a DisplayScreen that is not part of the Squeak universe. Subclasses must implement the appropriate primitives for creating, destroying and allocating the appropriate external objects.

Note: It is assumed that all external display surfaces are accessible by FXBlt, meaning that any support code must register the surfaces with the surface plugin. This requires that the support code will have a way of accessing the bits of the surface. Although this can be terribly expensive (such as on X where a roundtrip to the server might be required or for an OpenGL display where glReadPixels usually is slow as hell) the appropriate methods should be implemented. This allows for a gradual transition to less expensive model (such as implementing an X11Canvas supporting the drawing primitives of X) and is therefore the preferred solution.

In the eventual case that it's known that BitBlt/FXBlt will *never* be used in conjunction with a particular drawing surface, the support code should return a handle that is a) not a SmallInteger (these are used by the surface plugin) and b) not of the 'bitsSize' of a Form. One possible representation for such a handle would be a ByteArray of a non-integral word size (e.g., a ByteArray of size 5,6, or 7). In this case, all attempts to use FXBlt with the drawing surface will simply fail.
!


!ExternalScreen methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 18:44'!
destroy
	"Destroy the receiver"
	allocatedForms ifNotNil:[
		allocatedForms lock. "Make sure we don't get interrupted"
		allocatedForms forceFinalization. "Clean up all lost references"
		allocatedForms keys do:[:stillValid| stillValid shutDown].
		"All remaining references are simply destroyed"
		allocatedForms associationsDo:[:assoc| assoc key: nil].
		allocatedForms forceFinalization. "destroy all others"
		allocatedForms _ nil.
	].
	bits ifNotNil:[self primDestroyDisplaySurface: bits].
	bits _ nil.! !

!ExternalScreen methodsFor: 'initialize-release' stamp: 'ar 5/27/2000 01:30'!
finish
	"Flush the receiver"
	self primFinish: bits.
	"Now is the time to do some cleanup"
	allocatedForms unlock.
	allocatedForms finalizeValues.! !

!ExternalScreen methodsFor: 'initialize-release' stamp: 'ar 5/27/2000 01:30'!
flush
	"Flush the receiver"
	self primFlush: bits.! !

!ExternalScreen methodsFor: 'initialize-release' stamp: 'ar 5/27/2000 20:16'!
release
	"I am no longer Display. Release any resources if necessary"
	self destroy! !

!ExternalScreen methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 19:00'!
shutDown 
	"Minimize Display memory saved in image"
	self destroy.
	width _ 240.
	height _ 120.
	bits _ Bitmap new: self bitsSize.! !


!ExternalScreen methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:18'!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB pixel values into the receiver"
	^argbMap ifNil:[argbMap _ ColorMap mappingFromARGB: self rgbaBitMasks].! !

!ExternalScreen methodsFor: 'accessing' stamp: 'ar 5/26/2000 19:44'!
defaultBitBltClass
	^FXBlt! !

!ExternalScreen methodsFor: 'accessing' stamp: 'ar 5/26/2000 19:45'!
defaultWarpBltClass
	^FXBlt! !

!ExternalScreen methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:18'!
rgbaBitMasks
	"Return the masks for specifying the R,G,B, and A components in the receiver"
	| rgbaBitMasks |
	rgbaBitMasks _ Array new: 4.
	self primDisplay: bits colorMasksInto: rgbaBitMasks.
	^rgbaBitMasks! !


!ExternalScreen methodsFor: 'testing' stamp: 'ar 5/27/2000 20:17'!
isExternalForm
	"Sorta. Kinda."
	^true! !


!ExternalScreen methodsFor: 'form support' stamp: 'ar 5/28/2000 16:55'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
	| formHandle displayForm |
	formHandle _ self primAllocateForm: self depth width: extentPoint x height: extentPoint y.
	formHandle = nil ifTrue:[^super allocateForm: extentPoint].
	displayForm _ (ExternalForm extent: extentPoint depth: self depth bits: nil) 
		setExternalHandle: formHandle on: self.
	allocatedForms at: displayForm put: displayForm executor.
	^displayForm! !

!ExternalScreen methodsFor: 'form support' stamp: 'ar 5/28/2000 15:56'!
destroyForm: anExternalForm
	"Destroy the given external form"
	self primDestroyForm: anExternalForm getExternalHandle.
	anExternalForm setExternalHandle: nil on: nil.
	allocatedForms removeKey: anExternalForm ifAbsent:[].! !

!ExternalScreen methodsFor: 'form support' stamp: 'ar 5/27/2000 18:03'!
rgbaBitMasksOfForm: anExternalForm
	| rgbaBitMasks |
	rgbaBitMasks _ Array new: 4.
	self primForm: anExternalForm getExternalHandle colorMasksInto: rgbaBitMasks.
	^rgbaBitMasks! !


!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/28/2000 01:12'!
allocateOrRecycleTexture: aB3DTexture
	"If a texture for the given one has already been allocated return it. If not, allocate a new texture."
	| texture |
	allocatedForms lock. "Rendering may begin any time"
	^allocatedForms at: aB3DTexture ifAbsent:[
		texture _ self allocateTexture: aB3DTexture.
		texture ifNotNil:[
			allocatedForms at: aB3DTexture put: texture.
			aB3DTexture hasBeenModified: true].
		texture]! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/28/2000 00:26'!
allocateTexture: aB3DTexture
	"Allocate a new texture for the given (Squeak internal) form.
	NOTE: The size/depth of the texture allocated can differ. Right now
	there's an implicit strategy in the primitive code for choosing the
	right tradeoff between speed and space. In the optimal case this
	will result in a texture which is 'good enough' for what we have
	but if that can't be achieved anything might come back.
		Also, textures might be subject to certain restrictions. Some 
	graphics cards have minimum/maximum sizes of textures (some 
	older even require squared textures) and this needs to be taken
	into account by the primitive.
		One thing that's currently not handled is if insufficient
	memory is encountered. This can happen if there's just not enough
	VRAM or AGP memory. A good idea would be to free up some of
	the already allocated textures but it's not quite sure if that'll do
	the trick and it would require flushing the renderer. Tricky."
	| textureHandle |
	textureHandle _ self primAllocateTexture: aB3DTexture depth width: aB3DTexture width height: aB3DTexture height.
	textureHandle = nil ifTrue:[^nil].
	"And return the allocated texture.
	Note: #setExternalHandle: will automatically check for w/h/d"
	^(ExternalTexture initializeFrom: aB3DTexture) setExternalHandle: textureHandle on: self! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/27/2000 17:04'!
depthOfTexture: anExternalTexture
	"Return the actual height of the given external texture"
	^self primGetTextureDepth: anExternalTexture getExternalHandle! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/27/2000 17:44'!
destroyTexture: anExternalTexture
	"Destroy the given external form"
	self primDestroyTexture: anExternalTexture getExternalHandle.
	anExternalTexture setExternalHandle: nil on: nil.! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/27/2000 17:04'!
heightOfTexture: anExternalTexture
	"Return the actual height of the given external texture"
	^self primGetTextureHeight: anExternalTexture getExternalHandle! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/27/2000 18:04'!
rgbaBitMasksOfTexture: anExternalTexture
	| rgbaBitMasks |
	rgbaBitMasks _ Array new: 4.
	self primTexture: anExternalTexture getExternalHandle colorMasksInto: rgbaBitMasks.
	^rgbaBitMasks! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 6/9/2000 19:27'!
textureHandleOf: aTexture
	| textureForm |
	aTexture ifNil:[^-1].
	textureForm _ self allocateOrRecycleTexture: aTexture.
	textureForm ifNil:[^-1].
	"Update textureForm if aTexture is dirty"
	aTexture hasBeenModified ifTrue:[
		"Use the best method we have"
		aTexture displayInterpolatedOn: textureForm.
		aTexture hasBeenModified: false].
	^textureForm getExternalHandle! !

!ExternalScreen methodsFor: 'texture support' stamp: 'ar 5/27/2000 17:03'!
widthOfTexture: anExternalTexture
	"Return the actual width of the given external texture"
	^self primGetTextureWidth: anExternalTexture getExternalHandle! !


!ExternalScreen methodsFor: 'blitting support' stamp: 'ar 5/28/2000 16:16'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map
	"Attempt to accelerate blts to the receiver"
	| r |
	((self isBltAccelerated: rule for: sourceForm) and:[map == nil and:[hf == nil]]) ifTrue:[
		"Try an accelerated blt"
		r _ (destOrigin extent: sourceRect extent) intersect: (clipRect intersect: clippingBox).
		r area <= 0 ifTrue:[^self].
		(self primBltFast: bits from: sourceForm getExternalHandle
			at: r origin from: sourceRect origin
			extent: r extent) ifNotNil:[^self].
	].
	^super copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map! !

!ExternalScreen methodsFor: 'blitting support' stamp: 'ar 5/28/2000 16:16'!
displayOn: destForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf
	"Attempt to accelerate blts to aDisplayMedium"
	| sourceRect |
	((self isBltAccelerated: rule for: destForm) and:[hf = nil]) ifTrue:[
		"Try an accelerated blt"
		sourceRect _ (clipRect translateBy: destOrigin negated) intersect: clippingBox.
		(self primBltFast: bits to: destForm getExternalHandle
			at: 0@0 from: sourceRect origin
			extent: sourceRect extent) ifNotNil:[^self]].
	destForm copyBits: self boundingBox
		from: self
		at: destOrigin + self offset
		clippingBox: clipRect
		rule: rule
		fillColor: hf
		map: (self colormapIfNeededFor: destForm).
! !

!ExternalScreen methodsFor: 'blitting support' stamp: 'ar 5/27/2000 21:09'!
fill: aRectangle rule: anInteger fillColor: aColor 
	"Replace a rectangular area of the receiver with the pattern described by aForm 
	according to the rule anInteger."
	| rect |
	(self isFillAccelerated: anInteger for: aColor) ifTrue:[
		rect _ aRectangle intersect: clippingBox.
		(self primFill: bits
			color: (self pixelWordFor: aColor)
			x: rect left
			y: rect top
			w: rect width
			h: rect height) ifNotNil:[^self]].
	^super fill: aRectangle rule: anInteger fillColor: aColor! !

!ExternalScreen methodsFor: 'blitting support' stamp: 'ar 5/28/2000 15:52'!
isBltAccelerated: ruleInteger for: aForm
	"Return true if the receiver can perform accelerated blt operations by itself.
	It is assumed that blts of forms allocated on the receiverusing Form>>over 
	may be accelerated.
	Although some hardware may allow source-key blts (that is, Form>>paint or similar)
	this is usually questionable and the additional effort for allocating and
	maintaining the OS form doesn't quite seem worth the effort."
	^aForm displayScreen == self and:[ruleInteger = Form over]! !

!ExternalScreen methodsFor: 'blitting support' stamp: 'ar 5/27/2000 16:09'!
isFillAccelerated: ruleInteger for: aColor
	"Return true if the receiver can perform accelerated fill operations by itself.
	It is assumed that the hardware can accelerate plain color fill operations."
	^ruleInteger = Form over and:[aColor isColor]! !


!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:18'!
primBltFast: displayHandle from: sourceHandle at: destOrigin from: sourceOrigin extent: extent
	"Primitive. Perform a fast blt operation. Return the receiver if successful."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/28/2000 01:46'!
primBltFast: displayHandle to: dstHandle at: destOrigin from: sourceOrigin extent: extent
	"Primitive. Perform a fast blt operation. Return the receiver if successful."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:18'!
primCreateDisplaySurface: d width: w height: h
	"Primitive. Create a new external display surface. Return the handle used to identify the receiver. Fail if the surface cannot be created."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:18'!
primDestroyDisplaySurface: aHandle
	"Primitive. Destroy the display surface associated with the given handle."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:19'!
primDisplay: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:19'!
primFill: handle color: pixelWord x: x y: y w: w h: h
	"Primitive. Perform an accelerated fill operation on the receiver."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:20'!
primFinish: aHandle
	"Primitive. Finish all rendering operations on the receiver.
	Do not return before all rendering operations have taken effect."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:21'!
primFlush: aHandle
	"Primitive. If any rendering operations are pending, force them to be executed.
	Do not wait until they have taken effect."
	^nil! !

!ExternalScreen methodsFor: 'primitives-display' stamp: 'ar 5/27/2000 17:21'!
supportsDisplayDepth: pixelDepth
	"Return true if this pixel depth is supported on the current host platform."
	^false! !


!ExternalScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:22'!
primAllocateForm: d width: w height: h
	"Primitive. Allocate a form with the given parameters"
	^nil! !

!ExternalScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:22'!
primDestroyForm: aHandle
	"Primitive. Destroy the form associated with the given handle."
	^nil! !

!ExternalScreen methodsFor: 'primitives-forms' stamp: 'ar 5/27/2000 17:22'!
primForm: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	^nil! !


!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:23'!
primAllocateTexture: d width: w height: h
	"Primitive. Allocate a texture with the given dimensions.
	Note: The texture allocated may *not* match the specified
	values here."
	^nil! !

!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:23'!
primDestroyTexture: aHandle
	"Primitive. Destroy the texture associated with the given handle."
	^nil! !

!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:23'!
primGetTextureDepth: aHandle
	"Primitive. Return the actual depth of the texture with the given handle"
	^self primitiveFailed! !

!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primGetTextureHeight: aHandle
	"Primitive. Return the actual height of the texture with the given handle"
	^self primitiveFailed! !

!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primGetTextureWidth: aHandle
	"Primitive. Return the actual width of the texture with the given handle"
	^self primitiveFailed! !

!ExternalScreen methodsFor: 'primitives-textures' stamp: 'ar 5/27/2000 17:24'!
primTexture: aHandle colorMasksInto: anArray
	"Primitive. Store the bit masks for each color into the given array."
	^nil! !


!ExternalScreen methodsFor: 'private' stamp: 'ar 5/28/2000 19:00'!
setExtent: aPoint depth: bitsPerPixel
	"Create a 3D accelerated display screen"
	| screen |
	(bits isInteger and:[depth == bitsPerPixel and: [aPoint = self extent and: 
					[self supportsDisplayDepth: bitsPerPixel]]]) ifFalse: [
		bits ifNotNil:[self primDestroyDisplaySurface: bits].
		bits _ nil.  "Free up old bitmap in case space is low"
		DisplayChangeSignature _ (DisplayChangeSignature ifNil: [0]) + 1.
		(self supportsDisplayDepth: bitsPerPixel)
			ifTrue:[depth _ bitsPerPixel]
			ifFalse:["Search for a suitable depth"
					depth _ self findAnyDisplayDepthIfNone:[nil]].
		depth == nil ifFalse:[
			bits _ self primCreateDisplaySurface: depth 
					width: aPoint x height: aPoint y].
		"Bail out if surface could not be created"
		(bits == nil) ifTrue:[
			screen _ DisplayScreen extent: aPoint depth: bitsPerPixel.
			self == Display ifTrue:[
				Display _ screen.
				Display beDisplay].
			^screen].
		width _ aPoint x.
		height _ aPoint y.
	].
	clippingBox _ super boundingBox.
	allocatedForms ifNil:[
		allocatedForms _ ExternalFormRegistry new.
		WeakArray addWeakDependent: allocatedForms].
! !
Object subclass: #ExternalSemaphoreTable
	instanceVariableNames: ''
	classVariableNames: 'ProtectTable '
	poolDictionaries: ''
	category: 'System-Support'!
!ExternalSemaphoreTable commentStamp: '<historical>' prior: 0!
By John M McIntosh johnmci@smalltalkconsulting.com
This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using a mutex semaphore. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary 

Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.!


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

ExternalSemaphoreTable class
	instanceVariableNames: ''!

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:36'!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."

	ProtectTable critical: [Smalltalk specialObjectsArray at: 39 put: Array new].
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 21:01'!
externalObjects
	^ProtectTable critical: [Smalltalk specialObjectsArray at: 39].! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:44'!
registerExternalObject: anObject
	^ ProtectTable critical: [self safelyRegisterExternalObject: anObject]
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:57'!
safelyRegisterExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index."

	| objects firstEmptyIndex obj sz newObjects |
	objects _ Smalltalk specialObjectsArray at: 39.

	"find the first empty slot"
	firstEmptyIndex _ 0.
	1 to: objects size do: [:i |
		obj _ objects at: i.
		obj == anObject ifTrue: [^ i].  "object already there, just return its index"
		(obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex _ i]].

	"if no empty slots, expand the array"
	firstEmptyIndex = 0 ifTrue: [
		sz _ objects size.
		newObjects _ objects species new: sz + 20.  "grow linearly"
		newObjects replaceFrom: 1 to: sz with: objects startingAt: 1.
		firstEmptyIndex _ sz + 1.
		Smalltalk specialObjectsArray at: 39 put: newObjects.
		objects _ newObjects].

	objects at: firstEmptyIndex put: anObject.
	^ firstEmptyIndex
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:59'!
safelyUnregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered.
	JMM change to return if we clear the element, since it should only appear once in the array"

	| objects |
	anObject ifNil: [^ self].
	objects _ Smalltalk specialObjectsArray at: 39.
	1 to: objects size do: [:i |
		(objects at: i) == anObject ifTrue: 
		[objects at: i put: nil.
		^self]].
! !

!ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:45'!
unregisterExternalObject: anObject
	ProtectTable critical: [self safelyUnregisterExternalObject: anObject]
! !


!ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'JMM 6/6/2000 20:32'!
initialize
	ProtectTable _ Semaphore forMutualExclusion! !
ExternalObject subclass: #ExternalStructure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'FFIConstants '
	category: 'FFI-Kernel'!
!ExternalStructure commentStamp: '<historical>' prior: 0!
This class provides an abstract base for all structures that can be used by external functions. ExternalStructures have two possible handle types:
	- ExternalAddress
		If the handle is an external address then the object described does not reside in the Smalltalk object memory.
	- ByteArray
		If the handle is a byte array then the object described resides in Smalltalk memory.
Useful methods should be implemented by subclasses of ExternalStructure using the common ByteArray/ExternalAddress platform dependent access protocol which will transparently access the correct memory location.!


!ExternalStructure methodsFor: 'initialize-release' stamp: 'ar 11/28/1999 23:21'!
free
	"Free the handle pointed to by the receiver"
	(handle ~~ nil and:[handle isExternalAddress]) ifTrue:[handle free].
	handle _ nil.! !


!ExternalStructure methodsFor: 'inspecting' stamp: 'hg 2/28/2000 15:00'!
inspect
	"Open an ExternalStructureInspector on the receiver.  Use basicInspect to get a normal (less useful) type of inspector."

	self class fields size > 0 
		ifTrue: [ExternalStructureInspector openOn: self withEvalPane: true]
		ifFalse: [super inspect]! !


!ExternalStructure methodsFor: 'printing' stamp: 'bf 5/18/2000 16:26'!
longPrintOn: aStream 
	"Append to the argument, aStream, the names and values of all the record's variables."
	| fields |
	fields _ self class fields.
	(fields isEmpty or: [fields first isNil]) ifTrue: [fields _ #()]
		ifFalse: [(fields first isKindOf: Array) ifFalse: [fields _ Array with: fields]].
	fields do: [ :field |
		field first ~~ #nil ifTrue: [
			aStream nextPutAll: field first; nextPut: $:; space; tab.
			(self perform: field first) printOn: aStream.
			aStream cr]].! !

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

ExternalStructure class
	instanceVariableNames: 'compiledSpec '!

!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 12/1/1999 15:58'!
externalNew
	"Create an instance of the receiver on the external heap"
	^self fromHandle: (ExternalAddress allocate: self byteSize)! !

!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 11/29/1999 00:36'!
fromHandle: aHandle
	^self basicNew setHandle: aHandle! !

!ExternalStructure class methodsFor: 'instance creation' stamp: 'ar 12/1/1999 15:58'!
new
	^self fromHandle: (ByteArray new: self byteSize)! !


!ExternalStructure class methodsFor: 'converting' stamp: 'ar 12/2/1999 16:55'!
externalType
	"Return an external type describing the receiver as a structure"
	^ExternalType structTypeNamed: self name! !


!ExternalStructure class methodsFor: 'class management' stamp: 'ar 11/22/1999 10:10'!
doneCompiling
	"I have been recompiled. Update any types that reference me."
	ExternalType noticeModificationOf: self.! !

!ExternalStructure class methodsFor: 'class management' stamp: 'ar 1/26/2000 14:20'!
fileOutInitializerOn: aFileStream
	super fileOutInitializerOn: aFileStream.
	aFileStream cr.
	aFileStream cr.
	aFileStream nextChunkPut: self name , ' compileFields'.
	aFileStream cr.! !

!ExternalStructure class methodsFor: 'class management' stamp: 'ar 1/26/2000 14:19'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	super fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex
		initializing: aBool.
	(aBool and:[moveSource not]) ifTrue: 
		[aFileStream cr.
		aFileStream cr.
		aFileStream nextChunkPut: self name , ' compileFields'.
		aFileStream cr]! !

!ExternalStructure class methodsFor: 'class management' stamp: 'sma 6/16/2000 22:12'!
obsolete
	"The receiver is becoming obsolete. 
	NOTE: You if you remove the whole class category at once, you cannot
	assume that the ExternalType class is still present."

	Smalltalk at: #ExternalType ifPresent: [:class | class noticeRemovalOf: self].
	^ super obsolete! !

!ExternalStructure class methodsFor: 'class management' stamp: 'ar 11/22/1999 04:12'!
rename: aString
	| oldName |
	oldName _ name.
	super rename: aString.
	oldName = name ifFalse:[ExternalType noticeRenamingOf: self from: oldName to: name].! !


!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:31'!
byteSize
	"Return the size in bytes of this structure."
	^self compiledSpec first bitAnd: FFIStructSizeMask! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 1/27/2000 00:32'!
compileAlias: spec withAccessors: aBool
	"Define all the fields in the receiver.
	Return the newly compiled spec."
	| fieldName fieldType isPointerField externalType |
	fieldName _ spec first.
	fieldType _ spec second.
	isPointerField _ fieldType last = $*.
	fieldType _ fieldType copyWithout: $*.
	externalType _ ExternalType atomicTypeNamed: fieldType.
	externalType == nil ifTrue:["non-atomic"
		Symbol hasInterned: fieldType ifTrue:[:sym|
			externalType _ ExternalType structTypeNamed: sym]].
	externalType == nil ifTrue:[
		Transcript show:'(', fieldType,' is void)'.
		externalType _ ExternalType void].
	isPointerField ifTrue:[externalType _ externalType asPointerType].
	(fieldName ~~ #nil and:[aBool]) ifTrue:[
		self defineAliasAccessorsFor: fieldName
			type: externalType].
	isPointerField 
		ifTrue:[compiledSpec _ WordArray with: 
					(ExternalType structureSpec bitOr: ExternalType pointerSpec)]
		ifFalse:[compiledSpec _ externalType compiledSpec].
	ExternalType noticeModificationOf: self.
	^compiledSpec! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 15:35'!
compileAllFields
	"ExternalStructure compileAllFields"
	self withAllSubclassesDo:[:cls|
		cls compileFields.
	].! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'!
compileFields
	"Compile the field definition of the receiver.
	Return the newly compiled spec."
	^self compileFields: self fields! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'!
compileFields: fieldSpec
	"Compile the field definition of the receiver.
	Return the newly compiled spec."
	^self compileFields: fieldSpec withAccessors: false.! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'hg 2/29/2000 10:54'!
compileFields: specArray withAccessors: aBool
	"Define all the fields in the receiver.
	Return the newly compiled spec."
	| fieldName fieldType isPointerField externalType byteOffset typeSize typeSpec |
	(specArray size > 0 and:[specArray first class ~~ Array])
		ifTrue:[^self compileAlias: specArray withAccessors: aBool].
	byteOffset _ 1.
	typeSpec _ WriteStream on: (WordArray new: 10).
	typeSpec nextPut: (FFIFlagStructure). "dummy for size"
	specArray do:[:spec|
		fieldName _ spec first.
		fieldType _ spec second.
		isPointerField _ fieldType last = $*.
		fieldType _ (fieldType findTokens: ' *') first.
		externalType _ ExternalType atomicTypeNamed: fieldType.
		externalType == nil ifTrue:["non-atomic"
			Symbol hasInterned: fieldType ifTrue:[:sym|
				externalType _ ExternalType structTypeNamed: sym]].
		externalType == nil ifTrue:[
			Transcript show:'(', fieldType,' is void)'.
			externalType _ ExternalType void].
		isPointerField ifTrue:[externalType _ externalType asPointerType].
		typeSize _ externalType byteSize.
		spec size > 2 ifTrue:["extra size"
			spec third < typeSize ifTrue:[^self error:'Explicit type size is less than expected'].
			typeSize _ spec third].
		(fieldName ~~ #nil and:[aBool]) ifTrue:[
			self defineFieldAccessorsFor: fieldName 
				startingAt: byteOffset 
				type: externalType].
		typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
		byteOffset _ byteOffset + typeSize.
	].
	compiledSpec _ typeSpec contents.
	compiledSpec at: 1 put: (byteOffset - 1 bitOr: FFIFlagStructure).
	ExternalType noticeModificationOf: self.
	^compiledSpec! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:28'!
compiledSpec
	"Return the compiled spec of the receiver"
	^compiledSpec ifNil:[self compileFields].! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 1/27/2000 00:54'!
defineAliasAccessorsFor: fieldName type: type
	"Define read/write accessors for the given field"
	| code refClass argName |
	(type isVoid and:[type isPointerType not]) ifTrue:[^self].
	refClass _ type referentClass.
	code _ String streamContents:[:s|
		s 
			nextPutAll: fieldName; crtab;
			nextPutAll:'"This method was automatically generated"'; crtab.
		refClass == nil 
			ifTrue:[(type isAtomic and:[type isPointerType not]) 
				ifTrue:[s nextPutAll:'^handle']
				ifFalse:[s nextPutAll:'^ExternalData fromHandle: handle'.
						type isPointerType ifTrue:[s nextPutAll:' asExternalPointer'].
						s nextPutAll:' type: ';
						nextPutAll: type externalTypeName]]
			ifFalse:[s nextPutAll:'^', refClass name,' fromHandle: handle'.
					type isPointerType ifTrue:[s nextPutAll:' asExternalPointer']]].
	self compile: code classified: 'accessing'.

	code _ String streamContents:[:s|
		argName _ refClass == nil 
			ifTrue:[(type isAtomic and:[type isPointerType not])
				ifTrue:['anObject']
				ifFalse:['anExternalData']]
			ifFalse:['a',refClass name].
		s
			nextPutAll: fieldName,': '; nextPutAll: argName; crtab;
			nextPutAll:'"This method was automatically generated"'; crtab.
		(refClass == nil and:[type isAtomic and:[type isPointerType not]])
			ifTrue:[s nextPutAll:'handle _ ', argName]
			ifFalse:[s nextPutAll:'handle _ ', argName,' getHandle'.
					type isPointerType ifTrue:[s nextPutAll:' asByteArrayPointer']]].
	self compile: code classified: 'accessing'.! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 11/29/1999 00:42'!
defineFieldAccessorsFor: fieldName startingAt: byteOffset type: type
	"Define read/write accessors for the given field"
	| code |
	(type isVoid and:[type isPointerType not]) ifTrue:[^self].
	code _ fieldName,'
	"This method was automatically generated"
	', (type readFieldAt: byteOffset).
	self compile: code classified: 'accessing'.
	code _ fieldName,': anObject
	"This method was automatically generated"
	', (type writeFieldAt: byteOffset with:'anObject').
	self compile: code classified: 'accessing'.! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:37'!
defineFields
	"Define all the fields in the receiver"
	self defineFields: self fields.! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 12/2/1999 14:38'!
defineFields: fields
	"Define all the fields in the receiver"
	self compileFields: fields withAccessors: true.! !

!ExternalStructure class methodsFor: 'field definition' stamp: 'ar 11/29/1999 00:28'!
fields
	"Return the fields defining the receiver"
	^#()! !
Inspector subclass: #ExternalStructureInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!ExternalStructureInspector methodsFor: 'selecting' stamp: 'hg 2/28/2000 14:12'!
replaceSelectionValue: anObject 
	"Add colon to fieldname to get setter selector, and send it to object with the argument.
	 Refer to the comment in Inspector|replaceSelectionValue:."

	selectionIndex = 1
		ifTrue: [^object]
		ifFalse: [^object perform: ((self fieldList at: selectionIndex), ':') asSymbol with: anObject]! !

!ExternalStructureInspector methodsFor: 'selecting' stamp: 'hg 2/28/2000 14:22'!
selection 
	"Refer to the comment in Inspector|selection."
	selectionIndex = 0 ifTrue:[^object printString].
	selectionIndex = 1 ifTrue: [^object].
	selectionIndex = 2 ifTrue:[^object longPrintString].
	selectionIndex > 2
		ifTrue: [^object perform: (self fieldList at: selectionIndex)]! !


!ExternalStructureInspector methodsFor: 'accessing' stamp: 'hg 2/28/2000 14:20'!
fieldList
	^  (Array with: 'self: ', object defaultLabelForInspector with: 'all inst vars'), self recordFieldList! !

!ExternalStructureInspector methodsFor: 'accessing' stamp: 'bf 5/18/2000 16:33'!
recordFieldList
	| fields |
	fields _ object class fields.
	(fields first isKindOf: Array) ifFalse: [fields _ Array with: fields].
	^fields collect: [ :field | field first ] thenSelect: [:name | name ~~ #nil]! !
B3DTexture subclass: #ExternalTexture
	instanceVariableNames: 'display argbMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-External'!
!ExternalTexture commentStamp: '<historical>' prior: 0!
An ExternalTexture is a B3DTexture which is allocated on a specific (hopefully hardware accelerated) display. External textures are resources that are exclusively managed on the Display - no external textures should be manually allocated. This is because the texture format provided by the display may severely differ from our internal format. Therefore we always keep an 'original' B3DTexture and the external textures are allocated on demand.

Because of the above, external textures will never be kept inbetween sessions.!


!ExternalTexture methodsFor: 'initialize-release' stamp: 'ar 5/27/2000 16:58'!
destroy
	"Destroy the receiver"
	^display destroyTexture: self! !


!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 17:10'!
actualDepth
	"Return the actual depth of the receiver"
	^self displayScreen depthOfTexture: self! !

!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 17:09'!
actualHeight
	"Return the actual height of the receiver"
	^self displayScreen heightOfTexture: self! !

!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 17:09'!
actualWidth
	"Return the actual width of the receiver"
	^self displayScreen widthOfTexture: self! !

!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:19'!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB pixel values into the receiver"
	^argbMap ifNil:[argbMap _ ColorMap mappingFromARGB: self rgbaBitMasks].! !

!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:58'!
displayScreen
	"Return the display screen the receiver is allocated on."
	^display! !

!ExternalTexture methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:20'!
rgbaBitMasks
	"Return the masks for specifying the R,G,B, and A components in the receiver"
	^self displayScreen rgbaBitMasksOfTexture: self! !


!ExternalTexture methodsFor: 'testing' stamp: 'ar 5/27/2000 16:58'!
isExternalForm
	"Sorta. Kinda. But not really..."
	^true! !

!ExternalTexture methodsFor: 'testing' stamp: 'ar 5/27/2000 17:11'!
isExternalTexture
	^true! !


!ExternalTexture methodsFor: 'private' stamp: 'ar 5/27/2000 16:59'!
getExternalHandle
	"Private. Return the virtual handle used to represent the receiver"
	^bits! !

!ExternalTexture methodsFor: 'private' stamp: 'ar 5/27/2000 17:01'!
initializeFrom: aTexture
	"Private. Initialize the receiver from aTexture.
	Note: width/height/depth are not set here since textures
	are subject to restricted allocation and need to be handled
	specially."
	wrap _ aTexture wrap.
	envMode _ aTexture envMode.
	interpolate _ aTexture interpolate.! !

!ExternalTexture methodsFor: 'private' stamp: 'ar 5/27/2000 17:43'!
setExternalHandle: aHandle on: aDisplay
	"Initialize the receiver from the given external handle"
	display _ aDisplay.
	bits _ aHandle.
	(display notNil and:[bits notNil]) ifTrue:[
		"Now we can find out what the format of the receiver is"
		width _ self actualWidth.
		height _ self actualHeight.
		depth _ self actualDepth.
	].! !

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

ExternalTexture class
	instanceVariableNames: ''!

!ExternalTexture class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:49'!
initializeFrom: anotherForm
	^self basicNew initializeFrom: anotherForm! !
Object subclass: #ExternalType
	instanceVariableNames: 'compiledSpec referentClass referencedType '
	classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes StructTypes '
	poolDictionaries: 'FFIConstants '
	category: 'FFI-Kernel'!
!ExternalType commentStamp: '<historical>' prior: 0!
An external type represents the type of external objects.

Instance variables:
	compiledSpec	<WordArray>		Compiled specification of the external type
	referentClass	<Behavior | nil>	Class type of argument required
	referencedType	<ExternalType>	Associated (non)pointer type with the receiver

Compiled Spec:
The compiled spec defines the type in terms which are understood by the VM. Each word is defined as:
	bits 0...15 	- byte size of the entity
	bit 16		- structure flag (FFIFlagStructure)
				  This flag is set if the following words define a structure
	bit 17		- pointer flag (FFIFlagPointer)
				  This flag is set if the entity represents a pointer to another object
	bit 18		- atomic flag (FFIFlagAtomic)
				  This flag is set if the entity represents an atomic type.
				  If the flag is set the atomic type bits are valid.
	bits 19...23	- unused
	bits 24...27	- atomic type (FFITypeVoid ... FFITypeDoubleFloat)
	bits 28...31	- unused

Note that all combinations of the flags FFIFlagPointer, FFIFlagAtomic, and FFIFlagStructure are invalid, EXCEPT from the following:

	FFIFlagPointer + FFIFlagAtomic:
		This defines a pointer to an atomic type (e.g., 'char*', 'int*').
		The actual atomic type is represented in the atomic type bits.

	FFIFlagPointer + FFIFlagStructure:
		This defines a structure which is a typedef of a pointer type as in
			typedef void* VoidPointer;
			typedef Pixmap* PixmapPtr;
		It requires a byte size of four (e.g. a 32bit pointer) to work correctly.

[Note: Other combinations may be allowed in the future]
!


!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:15'!
atomicType
	^(self headerWord bitAnd: FFIAtomicTypeMask) >> FFIAtomicTypeShift! !

!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:11'!
byteSize
	"Return the size in bytes of this type"
	^self headerWord bitAnd: FFIStructSizeMask! !

!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:29'!
compiledSpec
	"Return the compiled spec of the receiver"
	^compiledSpec! !

!ExternalType methodsFor: 'accessing' stamp: 'ar 12/2/1999 14:11'!
referentClass
	"Return the class specifying the receiver"
	^referentClass! !


!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 20:27'!
isAtomic
	"Return true if the receiver describes a built-in type"
	^self headerWord anyMask: FFIFlagAtomic! !

!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:14'!
isIntegerType
	"Return true if the receiver is a built-in integer type"
	| type |
	type _ self atomicType.
	^type > FFITypeBool and:[type <= FFITypeUnsignedLongLong]! !

!ExternalType methodsFor: 'testing' stamp: 'ar 1/27/2000 00:29'!
isPointerType
	"Return true if the receiver represents a pointer type"
	^self isStructureType not and:[self headerWord anyMask: FFIFlagPointer]! !

!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:15'!
isSigned
	"Return true if the receiver is a signed type.
	Note: Only useful for integer types."
	^self atomicType anyMask: 1! !

!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:15'!
isStructureType
	"Return true if the receiver represents a structure type"
	^self headerWord anyMask: FFIFlagStructure! !

!ExternalType methodsFor: 'testing' stamp: 'ar 11/18/1999 18:28'!
isUnsigned
	"Return true if the receiver is an unsigned type.
	Note: Only useful for integer types."
	^self isSigned not! !

!ExternalType methodsFor: 'testing' stamp: 'ar 12/2/1999 14:16'!
isVoid
	"Return true if the receiver describes a plain 'void' type"
	^self isAtomic and:[self atomicType = 0]! !


!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 15:19'!
compiledSpec: aWordArray
	compiledSpec _ aWordArray.! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 20:34'!
embeddedSpecWithSize: typeSize
	"Return a compiled spec for embedding in a new compiled spec."
	| spec header |
	spec _ self compiledSpec copy.
	header _ spec at: 1.
	header _ (header bitAnd: FFIStructSizeMask bitInvert32) bitOr: typeSize.
	spec at: 1 put: header.
	(self isStructureType and:[self isPointerType not])
		ifTrue:[spec _ spec copyWith: self class structureSpec].
	^spec! !

!ExternalType methodsFor: 'private' stamp: 'ar 1/27/2000 00:22'!
externalTypeName
	^'ExternalType ', (AtomicTypeNames at: self atomicType), ' asPointerType'! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 14:11'!
headerWord
	"Return the compiled header word"
	^compiledSpec at: 1! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 20:30'!
newReferentClass: aClass
	"The class I'm referencing has changed. Update my spec."
	referentClass _ aClass.
	self isPointerType ifTrue:[^self]. "for pointers only the referentClass changed"
	referentClass == nil ifTrue:[
		"my class has been removed - make me 'struct { void }'"
		compiledSpec _ WordArray with: (FFIFlagStructure).
	] ifFalse:[
		"my class has been changed - update my compiledSpec"
		compiledSpec _ referentClass compiledSpec.
	].! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 18:13'!
readFieldAt: byteOffset
	"Return a string defining the accessor to an entity of the receiver type starting at the given byte offset. 
	Private. Used for field definition only."
	self isPointerType ifTrue:[
		referentClass == nil ifTrue:[
			^String streamContents:[:s|
				s nextPutAll:'^ExternalData fromHandle: (handle pointerAt: ';
					print: byteOffset;
					nextPutAll:') type: ExternalType ';
					nextPutAll: (AtomicTypeNames at: self atomicType);
					nextPutAll: ' asPointerType']].
		^String streamContents:[:s|
			s nextPutAll:'^';
				print: referentClass;
				nextPutAll:' fromHandle: (handle pointerAt: ';
				print: byteOffset;
				nextPutAll:')']].

	(self isAtomic) ifFalse:["structure type"
		^String streamContents:[:s|
			s nextPutAll:'^';
				print: referentClass;
				nextPutAll:' fromHandle: (handle structAt: ';
				print: byteOffset;
				nextPutAll:' length: ';
				print: self byteSize;
				nextPutAll:')']].

	"Atomic non-pointer types"
	^String streamContents:[:s|
		s nextPutAll:'^handle ';
			nextPutAll: (AtomicSelectors at: self atomicType);
			space; print: byteOffset].! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 16:41'!
setReferencedType: aType
	referencedType _ aType! !

!ExternalType methodsFor: 'private' stamp: 'ar 12/2/1999 14:53'!
writeFieldAt: byteOffset with: valueName
	"Return a string defining the accessor to an entity 
	of the receiver type starting at the given byte offset. 
	Private. Used for field definition only."

	self isPointerType ifTrue:[
		^String streamContents:[:s|
			s nextPutAll:'handle pointerAt: ';
				print: byteOffset;
				nextPutAll:' put: ';
				nextPutAll: valueName;
				nextPutAll:' getHandle.']].

	self isAtomic ifFalse:[
		^String streamContents:[:s|
			s nextPutAll:'handle structAt: ';
				print: byteOffset;
				nextPutAll:' put: ';
				nextPutAll: valueName;
				nextPutAll:' getHandle';
				nextPutAll:' length: ';
				print: self byteSize;
				nextPutAll:'.']].

	^String streamContents:[:s|
		s nextPutAll:'handle ';
			nextPutAll: (AtomicSelectors at: self atomicType);
			space; print: byteOffset;
			nextPutAll:' put: ';
			nextPutAll: valueName].! !


!ExternalType methodsFor: 'printing' stamp: 'ar 12/2/1999 17:02'!
printOn: aStream
	referentClass == nil
		ifTrue:[aStream nextPutAll: (AtomicTypeNames at: self atomicType)]
		ifFalse:[aStream nextPutAll: referentClass name].
	self isPointerType ifTrue:[aStream nextPut: $*].! !


!ExternalType methodsFor: 'converting' stamp: 'ar 12/2/1999 16:41'!
asNonPointerType
	"convert the receiver into a non pointer type"
	self isPointerType
		ifTrue:[^referencedType]
		ifFalse:[^self]! !

!ExternalType methodsFor: 'converting' stamp: 'ar 12/2/1999 16:40'!
asPointerType
	"convert the receiver into a pointer type"
	self isPointerType
		ifTrue:[^self]
		ifFalse:[^referencedType]! !

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

ExternalType class
	instanceVariableNames: ''!

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 16:15'!
initialize
	"ExternalType initialize"
	self initializeFFIConstants.
	self initializeDefaultTypes.! !

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 1/26/2000 14:57'!
initializeAtomicTypes
	"ExternalType initialize"
	| atomicType byteSize type typeName |
	#(
		"name		atomic id		byte size"
		('void' 		0 				0)
		('bool' 		1 				1)
		('byte' 		2 				1)
		('sbyte' 	3 				1)
		('ushort' 	4 				2)
		('short' 		5 				2)
		('ulong' 	6 				4)
		('long' 		7 				4)
		('ulonglong' 8 				8)
		('longlong' 	9 				8)
		('char' 		10 				1)
		('schar' 	11 				1)
		('float' 		12 				4)
		('double' 	13 				8)
	) do:[:spec|
		typeName _ spec first.
		atomicType _ spec second.
		byteSize _ spec third.
		spec _ WordArray with: ((byteSize bitOr: FFIFlagAtomic) bitOr:
				(atomicType bitShift: FFIAtomicTypeShift)).
		type _ (AtomicTypes at: typeName).
		type compiledSpec: spec.
		spec _ WordArray with: ((self pointerSpec bitOr: FFIFlagAtomic) bitOr:
				(atomicType bitShift: FFIAtomicTypeShift)).
		type asPointerType compiledSpec: spec.
	].! !

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 17:01'!
initializeDefaultTypes
	"ExternalType initialize"
	| type pointerType |
	AtomicTypes = nil ifTrue:[
		"Create new atomic types and setup the dictionaries"
		AtomicTypes _ Dictionary new.
		StructTypes _ WeakValueDictionary new.
		AtomicTypeNames valuesDo:[:k|
			type _ self basicNew.
			pointerType _ self basicNew.
			AtomicTypes at: k put: type.
			type setReferencedType: pointerType.
			pointerType setReferencedType: type.
		].
	].
	self initializeAtomicTypes.
	self initializeStructureTypes.
	"AtomicTypes _ nil"! !

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 20:25'!
initializeFFIConstants
	"ExternalType initialize"
	| dict |
	AtomicTypeNames _ IdentityDictionary new.
	AtomicSelectors _ IdentityDictionary new.
	dict _ Smalltalk at: #FFIConstants ifAbsentPut:[Dictionary new].
	#(
		"type void"
		(FFITypeVoid 0 'void'	voidAt:)
		"type bool"
		(FFITypeBool 1 'bool'		booleanAt:)

		"basic integer types.
		note: (integerType anyMask: 1) = integerType isSigned"

		(FFITypeUnsignedByte 2	'byte' 		unsignedByteAt:)
		(FFITypeSignedByte 3 	'sbyte' 		signedByteAt:)
		(FFITypeUnsignedShort 4	'ushort'		unsignedShortAt:)
		(FFITypeSignedShort 5 	'short'		signedShortAt:)
		(FFITypeUnsignedInt 6	'ulong'		unsignedLongAt:)
		(FFITypeSignedInt 7		'long'		signedLongAt:)

		"64bit types"
		(FFITypeUnsignedLongLong 8 'ulonglong'			unsignedLongLongAt:)
		(FFITypeSignedLongLong 9 'longlong'				signedLongLongAt:)

		"special integer types"
		(FFITypeUnsignedChar 10		'char'		unsignedCharAt:)
		(FFITypeSignedChar 11 		'schar'		signedCharAt:)

		"float types"
		(FFITypeSingleFloat 12 	'float'		floatAt:)
		(FFITypeDoubleFloat 13 	'double'		doubleAt:)

		"type flags"
		(FFIFlagAtomic 16r40000) "type is atomic"
		(FFIFlagPointer 16r20000) "type is pointer to base type"
		(FFIFlagStructure  16r10000) "baseType is structure of 64k length"
		(FFIStructSizeMask 16rFFFF) "mask for max size of structure"
		(FFIAtomicTypeMask 16r0F000000) "mask for atomic type spec"
		(FFIAtomicTypeShift 24) "shift for atomic type"
	) do:[:spec|
		dict declare: spec first from: Undeclared.
		dict at: spec first put: spec second.
		spec size > 2 ifTrue:[
			AtomicTypeNames at: spec second put: spec third.
			AtomicSelectors at: spec second put: spec fourth].
	].! !

!ExternalType class methodsFor: 'class initialization' stamp: 'ar 12/2/1999 20:34'!
initializeStructureTypes
	"ExternalType initialize"
	| referentClass pointerType |
	self cleanupUnusedTypes.
	StructTypes keysAndValuesDo:[:referentName :type|
		referentClass _ (Smalltalk at: referentName ifAbsent:[nil]).
		(referentClass isBehavior and:[
			referentClass includesBehavior: ExternalStructure])
				ifFalse:[referentClass _ nil].
		type compiledSpec: 
			(WordArray with: self structureSpec).
		type newReferentClass: referentClass.
		pointerType _ type asPointerType.
		pointerType compiledSpec: 
			(WordArray with: (self pointerSpec bitOr: self structureSpec)).
		pointerType newReferentClass: referentClass.
	].! !

!ExternalType class methodsFor: 'class initialization' stamp: 'sma 6/18/2000 11:26'!
obsolete
	Smalltalk removeKey: #FFIConstants ifAbsent: [].
	super obsolete! !


!ExternalType class methodsFor: 'instance creation' stamp: 'ar 1/26/2000 14:58'!
new
	"Use either the type constants or #externalType for creating external types"
	^self shouldNotImplement! !


!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:56'!
bool
	^AtomicTypes at: 'bool'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:29'!
byte
	"byte defaults to unsigned byte"
	^self unsignedByte! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:29'!
char
	"char defaults to unsigned char"
	^self unsignedChar! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:56'!
double
	^AtomicTypes at: 'double'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
float
	^AtomicTypes at: 'float'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/22/1999 13:10'!
long
	^self signedLong! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:43'!
sbyte
	^self signedByte! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:43'!
schar
	^self signedChar! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/20/1999 17:26'!
short
	^self signedShort! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
signedByte
	^AtomicTypes at: 'sbyte'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
signedChar
	^AtomicTypes at: 'schar'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
signedLong
	^AtomicTypes at: 'long'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
signedLongLong
	^AtomicTypes at: 'longlong'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
signedShort
	^AtomicTypes at: 'short'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
string
	^(AtomicTypes at: 'char') asPointerType! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:44'!
ulong
	^self unsignedLong! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:57'!
unsignedByte
	^AtomicTypes at: 'byte'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'!
unsignedChar
	^AtomicTypes at: 'char'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'!
unsignedLong
	^AtomicTypes at: 'ulong'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'!
unsignedLongLong
	^AtomicTypes at: 'ulonglong'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'!
unsignedShort
	^AtomicTypes at: 'ushort'! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 11/28/1999 23:44'!
ushort
	^self unsignedShort! !

!ExternalType class methodsFor: 'type constants' stamp: 'ar 12/2/1999 16:58'!
void
	^AtomicTypes at: 'void'! !


!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 18:00'!
cleanupUnusedTypes
	"ExternalType cleanupUnusedTypes"
	| value |
	StructTypes keys do:[:key|
		value _ StructTypes at: key.
		value == nil ifTrue:[StructTypes removeKey: key ifAbsent:[]]].! !

!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 17:58'!
noticeModificationOf: aClass
	"A subclass of ExternalStructure has been redefined.
	Clean out any obsolete references to its type."
	| type |
	aClass isBehavior ifFalse:[^nil]. "how could this happen?"
	aClass withAllSubclassesDo:[:cls|
		type _ StructTypes at: cls name ifAbsent:[nil].
		type == nil ifFalse:[
			type newReferentClass: cls.
			type asPointerType newReferentClass: cls].
	].! !

!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 17:59'!
noticeRemovalOf: aClass
	"A subclass of ExternalStructure is being removed.
	Clean out any obsolete references to its type."
	| type |
	type _ StructTypes at: aClass name ifAbsent:[nil].
	type == nil ifFalse:[
		type newReferentClass: nil.
		type asPointerType newReferentClass: nil].
! !

!ExternalType class methodsFor: 'housekeeping' stamp: 'ar 12/2/1999 16:14'!
noticeRenamingOf: aClass from: oldName to: newName
	"An ExternalStructure has been renamed from oldName to newName.
	Keep our type names in sync."
	| type |
	type _ StructTypes at: oldName ifAbsent:[nil].
	type == nil ifFalse:[StructTypes at: newName put: type].
	StructTypes removeKey: oldName ifAbsent:[].! !


!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 16:59'!
atomicTypeNamed: aString
	^AtomicTypes at: aString ifAbsent:[nil]! !

!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 16:50'!
forceTypeNamed: aString
	^self newTypeNamed: aString force: true! !

!ExternalType class methodsFor: 'private' stamp: 'ar 1/26/2000 21:41'!
newTypeNamed: aString force: aBool
	| sym type referentClass pointerType |
	sym _ aString asSymbol.
	type _ StructTypes at: aString ifAbsent:[nil].
	type == nil ifFalse:[^type].
	referentClass _ Smalltalk at: sym ifAbsent:[nil].
	(referentClass isBehavior and:[referentClass includesBehavior: ExternalStructure])
		ifFalse:[referentClass _ nil].
	"If we don't have a referent class and are not forced to create a type get out"
	(referentClass == nil and:[aBool not]) ifTrue:[^nil].
	type _ self basicNew compiledSpec: 
		(WordArray with: self structureSpec).
	pointerType _ self basicNew compiledSpec: 
		(WordArray with: self pointerSpec).
	type setReferencedType: pointerType.
	pointerType setReferencedType: type.
	type newReferentClass: referentClass.
	pointerType newReferentClass: referentClass.
	StructTypes at: sym put: type.
	^type! !

!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 20:33'!
pointerSpec
	^(4 bitOr: FFIFlagPointer)! !

!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 16:48'!
structTypeNamed: aSymbol
	aSymbol == nil ifTrue:[^nil].
	^self newTypeNamed: aSymbol force: false! !

!ExternalType class methodsFor: 'private' stamp: 'ar 12/2/1999 20:34'!
structureSpec
	^FFIFlagStructure! !
EllipseMorph subclass: #EyeMorph
	instanceVariableNames: 'iris '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!EyeMorph methodsFor: 'initialization' stamp: 'len 9/6/1999 23:36'!
initialize
	super initialize.
	self color: (Color r: 1.0 g: 0.968 b: 0.935).
	self borderColor: Color black; borderWidth: 1.
	self extent: 30 @ 37.
	self addMorphFront: (iris _ EllipseMorph new extent: 6 @ 6; borderWidth: 0; color: Color black).
	self lookAtFront! !


!EyeMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 15:40'!
iris
	^ iris! !


!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:25'!
closeEyelid
	self iris delete.
	self position: self position + (0 @ (self extent y // 2)).
	self extent: self extent x @ 2! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 15:57'!
dilate: amount
	| irisCenter |
	irisCenter _ self iris center.
	self iris extent: self iris extent * amount.
	self iris position: irisCenter - self iris center + self iris position! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/24/1999 00:48'!
lookAt: aPoint
	| theta scale |
	(self containsPoint: aPoint) ifTrue: [self iris align: iris center with: aPoint. ^ self].
	theta _ (aPoint - self center) theta.
	scale _ (aPoint - self center) r / 100.0 min: 1.0.
	self iris align: self iris center with: self center + (theta cos @ theta sin * self extent / 3.0 * scale) rounded! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:03'!
lookAtFront
	self iris position: self center - self iris center + self iris position! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:23'!
lookAtMorph: aMorph
	self lookAt: aMorph center! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/23/1999 22:49'!
openEyelid
	self extent: self extent x @ (self extent x * 37.0 / 30.0) rounded.
	self position: self position - (0 @ (self extent y // 2)).
	self addMorphFront: self iris! !

!EyeMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:18'!
openness: aNumber
	| previousCenter |
	previousCenter _ self center.
	self extent: self extent x @ (self extent x * 37.0 / 30.0 * aNumber) rounded.
	self align: self center with: previousCenter.
	(self containsPoint: self iris center) ifFalse: [self lookAtFront]! !
UtteranceVisitor subclass: #F0RenderingVisitor
	instanceVariableNames: 'pitch range contour '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'len 12/13/1999 03:47'!
highPitch
	^ pitch + (pitch * range)! !

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'len 12/13/1999 03:47'!
lowPitch
	^ pitch - (pitch * range)! !

!F0RenderingVisitor methodsFor: 'accessing' stamp: 'len 12/13/1999 01:21'!
timeForEvent: aVoiceEvent
	| time |
	time _ 0.
	clause eventsDo: [ :each | aVoiceEvent == each ifTrue: [^ time] ifFalse: [time _ time + each duration]]! !


!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/24/1999 03:20'!
clause: aClause
	contour _ CosineInterpolator new at: 0 put: pitch; yourself.

	super clause: aClause.
	self renderPhraseAccentOrBoundaryTone: clause accent.

	self assignF0ToEvents! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:31'!
phrase: aPhrase
	super phrase: aPhrase.

	self renderPhraseAccentOrBoundaryTone: phrase accent! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:41'!
renderPhraseAccentOrBoundaryTone: aStringOrNil
	aStringOrNil isNil ifTrue: [^ self].
	(aStringOrNil findTokens: ' ') do: [ :each |
		each = 'H-' ifTrue: [self renderHighPhraseAccent].
		each = 'L-' ifTrue: [self renderLowPhraseAccent].
		each = 'H%' ifTrue: [self renderHighBoundary].
		each = 'L%' ifTrue: [self renderLowBoundary].
		each = '%H' ifTrue: [self renderHighInitial].
		each = '%r' ifTrue: [self notYetImplemented]]! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/13/1999 02:42'!
speaker: aSpeaker
	pitch _ aSpeaker pitch.
	range _ aSpeaker range! !

!F0RenderingVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:41'!
syllable: aSyllable
	super syllable: aSyllable.

	aSyllable isAccented ifFalse: [^ self].
	aSyllable accent = 'H*' ifTrue: [^ self renderPeakAccent].
	aSyllable accent = 'L*' ifTrue: [^ self renderLowAccent].
	aSyllable accent = 'L*+H' ifTrue: [^ self renderScoopedAccent].
	aSyllable accent = 'L+H*' ifTrue: [^ self renderRisingPeakAccent]! !


!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 05:47'!
renderLowAccent
	"Render a L* accent."
	| start stop peakPosition |
	start _ self syllableStartTime.
	stop _ self syllableStopTime.
	peakPosition _ (syllable events detect: [ :one | one phoneme isSyllabic] ifNone: [syllable events first]) duration / 2.0.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: peakPosition
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 05:47'!
renderPeakAccent
	"Render a H* accent."
	| start stop peakPosition |
	start _ self syllableStartTime.
	stop _ self syllableStopTime.
	peakPosition _ (syllable events detect: [ :one | one phoneme isSyllabic] ifNone: [syllable events first]) duration / 2.0.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: peakPosition
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:44'!
renderRisingPeakAccent
	"Render a L+H* accent."

	self notYetImplemented! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:45'!
renderScoopedAccent
	"Render a L*+H accent."

	self notYetImplemented! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:43'!
syllableStartTime
	^ self timeForEvent: syllable events first! !

!F0RenderingVisitor methodsFor: 'rendering-pitch accents' stamp: 'len 12/14/1999 01:43'!
syllableStopTime
	^ self syllableStartTime + syllable events duration! !


!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'len 12/14/1999 03:45'!
phraseAccentStartTime
	| syl |
	syl _ nil.
	(phrase ifNil: [clause phrases last]) syllablesDo: [ :each | (syl isNil or: [syl isAccented]) ifTrue: [syl _ each]].
	^ self timeForEvent: syl events last! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'len 12/14/1999 01:17'!
phraseAccentStopTime
	| lastEvent |
	lastEvent _ (phrase ifNil: [clause phrases last]) lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'len 12/14/1999 01:23'!
renderHighPhraseAccent
	"Render a H- accent."
	| start stop |
	start _ self phraseAccentStartTime.
	stop _ self phraseAccentStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: stop - start
		tilt: 1.0! !

!F0RenderingVisitor methodsFor: 'rendering-phrase accents' stamp: 'len 12/14/1999 03:48'!
renderLowPhraseAccent
	"Render a L- accent."
	| start stop |
	start _ self phraseAccentStartTime.
	stop _ self phraseAccentStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: stop - start
		tilt: -0.5! !


!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 02:27'!
boundaryStartTime
	^ self timeForEvent: (phrase ifNil: [clause phrases last]) words last events first! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 02:27'!
boundaryStopTime
	| lastEvent |
	lastEvent _ (phrase ifNil: [clause phrases last]) lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 01:38'!
initialStopTime
	| lastEvent |
	lastEvent _ 	clause phrases first words first lastSyllable events last.
	^ (self timeForEvent: lastEvent) + lastEvent duration! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 01:34'!
renderHighBoundary
	"Render a H% boundary tone."
	| start stop |
	start _ self boundaryStartTime.
	stop _ self boundaryStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start)
		duration: stop - start
		peakPosition: stop - start
		tilt: 1.0! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 03:07'!
renderHighInitial
	"Render a %H tone."
	| start stop |
	start _ 0.
	stop _ self initialStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: self highPitch - (contour at: start) * 2
		duration: stop - start
		peakPosition: start
		tilt: 0.0! !

!F0RenderingVisitor methodsFor: 'rendering-boundary tones' stamp: 'len 12/14/1999 03:44'!
renderLowBoundary
	"Render a L% boundary tone."
	| start stop |
	start _ self boundaryStartTime.
	stop _ self boundaryStopTime.
	self time: start
		startingF0: (contour at: start)
		amplitude: (contour at: start) - self lowPitch
		duration: stop - start
		peakPosition: stop - start
		tilt: -1.0! !


!F0RenderingVisitor methodsFor: 'private' stamp: 'len 12/14/1999 00:48'!
assignF0ToEvents
	| time |
	time _ 0.
	clause events do: [ :each |
		each pitchPoints: (self pitchesBetween: time and: time + each duration).
		time _ time + each duration]! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'len 12/13/1999 02:55'!
pitchesBetween: t1 and: t2
	| step |
	step _ (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (contour at: each)]! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'len 12/14/1999 03:47'!
time: time startingF0: startingF0 amplitude: amplitude duration: duration peakPosition: peakPosition tilt: tilt
	| vowelStart riseAmplitude fallAmplitude |
	vowelStart _ self timeOfFirstVowelAfter: time.
	riseAmplitude _ tilt + 1.0 * amplitude / 2.0.
	fallAmplitude _ amplitude - riseAmplitude.
	contour
		x: time y: startingF0;
		x: vowelStart + peakPosition y: ((startingF0 + riseAmplitude max: self lowPitch) min: self highPitch);
		x: time + duration y: ((startingF0 + riseAmplitude - fallAmplitude max: self lowPitch) min: self highPitch);
		commit! !

!F0RenderingVisitor methodsFor: 'private' stamp: 'len 12/14/1999 01:47'!
timeOfFirstVowelAfter: time
	| currentTime |
	currentTime _ 0.
	clause events do: [ :each |
		(currentTime >= time and: [each phoneme isSyllabic]) ifTrue: [^ currentTime].
		currentTime _ currentTime + each duration].
	^ time "if not found, answer the time itself"! !

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

F0RenderingVisitor class
	instanceVariableNames: ''!

!F0RenderingVisitor class methodsFor: 'examples' stamp: 'len 12/13/1999 02:25'!
default
	^ self new! !
InterpreterPlugin subclass: #FFIPlugin
	instanceVariableNames: 'ffiLastError ffiArgClass ffiArgSpec ffiArgSpecSize ffiArgHeader ffiRetOop ffiRetClass ffiRetSpec ffiRetSpecSize ffiRetHeader '
	classVariableNames: ''
	poolDictionaries: 'FFIConstants '
	category: 'VMConstruction-Plugins'!

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:25'!
primitiveCallout

	"IMPORTANT: IF YOU CHANGE THE NAME OF THIS METHOD YOU MUST CHANGE
		Interpreter>>primitiveCalloutToFFI
	TO REFLECT THE CHANGE."

	"Perform a function call to a foreign function.
	Only invoked from method containing explicit external call spec."
	| lit address flags argTypes litClass nArgs meth |
	self export: true.
	self inline: false.
	self ffiSetLastError: FFIErrorGenericError. "educated guess if we fail silently"
	lit _ nil.
	"Look if the method is itself a callout function"
	meth _ interpreterProxy primitiveMethod.
	(interpreterProxy literalCountOf: meth) > 0 ifFalse:[^interpreterProxy primitiveFail].
	lit _ interpreterProxy literal: 0 ofMethod: meth.
	litClass _ interpreterProxy fetchClassOf: lit.
	(interpreterProxy includesBehavior: litClass 
						ThatOf: interpreterProxy classExternalFunction) 
		ifFalse:[^self ffiFail: FFIErrorNotFunction].
	address _ self ffiLoadCalloutAddress: lit.
	interpreterProxy failed ifTrue:[^0].
	"Load and check the other values before we call out"
	flags _ interpreterProxy fetchInteger: 1 ofObject: lit.
	interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorBadArgs].
	argTypes _ interpreterProxy fetchPointer: 2 ofObject: lit.
	"must be array of arg types"
	(interpreterProxy fetchClassOf: argTypes) == interpreterProxy classArray 
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	nArgs _ interpreterProxy slotSizeOf: argTypes.
	"must be argumentCount+1 arg types"
	nArgs = (interpreterProxy methodArgumentCount+1) 
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	self ffiInitialize. "announce the execution of an external call"
	self ffiCall: address 
		WithFlags: flags 
		AndTypes: argTypes.
	self ffiCleanup. "cleanup temp allocations"
	^0! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:26'!
primitiveCalloutWithArgs
	"Perform a function call to a foreign function.
	Only invoked from ExternalFunction>>invokeWithArguments:"
	| lit address flags argTypes litClass nArgs argArray |
	self export: true.
	self inline: false.
	self ffiSetLastError: FFIErrorGenericError. "educated guess if we fail silently"
	lit _ nil.
	"Look if the method is itself a callout function"
	lit _ interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	litClass _ interpreterProxy fetchClassOf: lit.
	(interpreterProxy includesBehavior: litClass 
						ThatOf: interpreterProxy classExternalFunction) 
		ifFalse:[^self ffiFail: FFIErrorNotFunction].
	address _ self ffiLoadCalloutAddress: lit.
	interpreterProxy failed ifTrue:[^nil].
	"Load and check the other values before we call out"
	flags _ interpreterProxy fetchInteger: 1 ofObject: lit.
	interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorBadArgs].
	argTypes _ interpreterProxy fetchPointer: 2 ofObject: lit.
	"must be array of arg types"
	(interpreterProxy fetchClassOf: argTypes) == interpreterProxy classArray 
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	nArgs _ interpreterProxy slotSizeOf: argTypes.
	(interpreterProxy methodArgumentCount = 1) 
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	argArray _ interpreterProxy stackValue: 0.
	(interpreterProxy fetchClassOf: argArray) = (interpreterProxy classArray)
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	nArgs = ((interpreterProxy slotSizeOf: argArray) + 1)
		ifFalse:[^self ffiFail: FFIErrorBadArgs].
	self ffiInitialize. "announce the execution of an external call"
	self ffiCall: address 
		WithFlags: flags 
		Args: argArray
		AndTypes: argTypes
		OfSize: nArgs-1.
	self ffiCleanup. "cleanup temp allocations"
	^0! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 12/1/1999 16:08'!
primitiveFFIAllocate
	"Primitive. Allocate an object on the external heap."
	| byteSize addr oop ptr |
	self export: true.
	self inline: false.
	self var: #ptr declareC:'int *ptr'.
	byteSize _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	addr _ self ffiAlloc: byteSize.
	addr = 0 ifTrue:[^interpreterProxy primitiveFail].
	oop _ interpreterProxy 
			instantiateClass: interpreterProxy classExternalAddress 
			indexableSize: 4.
	ptr _ interpreterProxy firstIndexableField: oop.
	ptr at: 0 put: addr.
	interpreterProxy pop: 2.
	^interpreterProxy push: oop.
! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/29/1999 00:07'!
primitiveFFIDoubleAt
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| byteOffset rcvr addr floatValue |
	self export: true.
	self inline: false.
	self var: #floatValue declareC:'double floatValue'.
	byteOffset _ interpreterProxy stackIntegerValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^0].
	addr _ self addressOf: rcvr startingAt: byteOffset size: 8.
	interpreterProxy failed ifTrue:[^0].
	self cCode:'((int*)(&floatValue))[0] = ((int*)addr)[0]'.
	self cCode:'((int*)(&floatValue))[1] = ((int*)addr)[1]'.
	interpreterProxy pop: 2.
	^interpreterProxy pushFloat: floatValue
! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/29/1999 10:10'!
primitiveFFIDoubleAtPut
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| byteOffset rcvr addr floatValue floatOop |
	self export: true.
	self inline: false.
	self var: #floatValue declareC:'double floatValue'.
	floatOop _ interpreterProxy stackValue: 0.
	(interpreterProxy isIntegerObject: floatOop)
		ifTrue:[floatValue _ self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'double']
		ifFalse:[floatValue _ self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'double'].
	byteOffset _ interpreterProxy stackIntegerValue: 1.
	rcvr _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^0].
	addr _ self addressOf: rcvr startingAt: byteOffset size: 8.
	interpreterProxy failed ifTrue:[^0].
	self cCode:'((int*)addr)[0] = ((int*)(&floatValue))[0]'.
	self cCode:'((int*)addr)[1] = ((int*)(&floatValue))[1]'.
	interpreterProxy pop: 3.
	^interpreterProxy push: floatOop! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/29/1999 00:07'!
primitiveFFIFloatAt
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| byteOffset rcvr addr floatValue |
	self export: true.
	self inline: false.
	self var: #floatValue declareC:'float floatValue'.
	byteOffset _ interpreterProxy stackIntegerValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^0].
	addr _ self addressOf: rcvr startingAt: byteOffset size: 4.
	interpreterProxy failed ifTrue:[^0].
	self cCode:'((int*)(&floatValue))[0] = ((int*)addr)[0]'.
	interpreterProxy pop: 2.
	^interpreterProxy pushFloat: floatValue! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/29/1999 10:10'!
primitiveFFIFloatAtPut
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| byteOffset rcvr addr floatValue floatOop |
	self export: true.
	self inline: false.
	self var: #floatValue declareC:'float floatValue'.
	floatOop _ interpreterProxy stackValue: 0.
	(interpreterProxy isIntegerObject: floatOop)
		ifTrue:[floatValue _ self cCoerce: (interpreterProxy integerValueOf: floatOop) to:'float']
		ifFalse:[floatValue _ self cCoerce: (interpreterProxy floatValueOf: floatOop) to:'float'].
	byteOffset _ interpreterProxy stackIntegerValue: 1.
	rcvr _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^0].
	addr _ self addressOf: rcvr startingAt: byteOffset size: 4.
	interpreterProxy failed ifTrue:[^0].
	self cCode:'((int*)addr)[0] = ((int*)(&floatValue))[0]'.
	interpreterProxy pop: 3.
	^interpreterProxy push: floatOop! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 12/1/1999 16:08'!
primitiveFFIFree
	"Primitive. Free the object pointed to on the external heap."
	| addr oop ptr |
	self export: true.
	self inline: false.
	self var: #ptr declareC:'int *ptr'.
	oop _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy fetchClassOf: oop) = (interpreterProxy classExternalAddress)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy byteSizeOf: oop) = 4
		ifFalse:[^interpreterProxy primitiveFail].
	ptr _ interpreterProxy firstIndexableField: oop.
	addr _ ptr at: 0.
	"Don't you dare to free Squeak's memory!!"
	(addr = 0 or:[interpreterProxy isInMemory: addr])
		ifTrue:[^interpreterProxy primitiveFail].
	self ffiFree: addr.
	^ptr at: 0 put: 0. "cleanup"
! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:26'!
primitiveFFIGetLastError
	"Primitive. Return the error code from a failed call to the foreign function interface."
	self export: true.
	self inline: false.
	interpreterProxy pop: 1.
	^interpreterProxy pushInteger: self ffiGetLastError.! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 12/1/1999 18:55'!
primitiveFFIIntegerAt
	"Return a (signed or unsigned) n byte integer from the given byte offset."
	| isSigned byteSize byteOffset rcvr addr value mask |
	self export: true.
	self inline: false.
	isSigned _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	byteSize _ interpreterProxy stackIntegerValue: 1.
	byteOffset _ interpreterProxy stackIntegerValue: 2.
	rcvr _ interpreterProxy stackObjectValue: 3.
	interpreterProxy failed ifTrue:[^0].
	(byteOffset > 0 and:[byteSize = 1 or:[byteSize = 2 or:[byteSize = 4]]])
		ifFalse:[^interpreterProxy primitiveFail].
	addr _ self addressOf: rcvr startingAt: byteOffset size: byteSize.
	interpreterProxy failed ifTrue:[^0].
	byteSize < 4 ifTrue:[
		"short/byte"
		byteSize = 1 
			ifTrue:[value _ interpreterProxy byteAt: addr]
			ifFalse:[	value _ self cCode: '*((short int *) addr)' 
								inSmalltalk: [interpreterProxy halfWordAt: addr]].
		isSigned ifTrue:["sign extend value"
			mask _ 1 << (byteSize * 8 - 1).
			value _ (value bitAnd: mask-1) - (value bitAnd: mask)].
		"note: byte/short never exceed SmallInteger range"
		value _ interpreterProxy integerObjectOf: value.
	] ifFalse:[
		"general 32 bit integer"
		value _ interpreterProxy longAt: addr.
		isSigned
			ifTrue:[value _ interpreterProxy signed32BitIntegerFor: value]
			ifFalse:[value _ interpreterProxy positive32BitIntegerFor: value].
	].
	interpreterProxy pop: 4.
	^interpreterProxy push: value
! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 12/1/1999 18:55'!
primitiveFFIIntegerAtPut
	"Store a (signed or unsigned) n byte integer at the given byte offset."
	| isSigned byteSize byteOffset rcvr addr value max valueOop |
	self export: true.
	self inline: false.
	isSigned _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	byteSize _ interpreterProxy stackIntegerValue: 1.
	valueOop _ interpreterProxy stackValue: 2.
	byteOffset _ interpreterProxy stackIntegerValue: 3.
	rcvr _ interpreterProxy stackObjectValue: 4.
	interpreterProxy failed ifTrue:[^0].
	(byteOffset > 0 and:[byteSize = 1 or:[byteSize = 2 or:[byteSize = 4]]])
		ifFalse:[^interpreterProxy primitiveFail].
	addr _ self addressOf: rcvr startingAt: byteOffset size: byteSize.
	interpreterProxy failed ifTrue:[^0].
	isSigned 
		ifTrue:[value _ interpreterProxy signed32BitValueOf: valueOop]
		ifFalse:[value _ interpreterProxy positive32BitValueOf: valueOop].
	interpreterProxy failed ifTrue:[^0].
	byteSize < 4 ifTrue:[
		isSigned ifTrue:[
			max _ 1 << (8 * byteSize - 1).
			value >= max ifTrue:[^interpreterProxy primitiveFail].
			value < (0 - max) ifTrue:[^interpreterProxy primitiveFail].
		] ifFalse:[
			value >= (1 << (8*byteSize)) ifTrue:[^interpreterProxy primitiveFail].
		].
		"short/byte"
		byteSize = 1 
			ifTrue:[interpreterProxy byteAt: addr put: value]
			ifFalse:[	self cCode: '*((short int *) addr) = value' 
						inSmalltalk: [interpreterProxy halfWordAt: addr put: value]].
	] ifFalse:[interpreterProxy longAt: addr put: value].
	interpreterProxy pop: 5.
	^interpreterProxy push: valueOop.! !

!FFIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:21'!
primitiveForceLoad
	"Primitive. Force loading the receiver (an instance of ExternalLibrary)."
	| rcvr theClass moduleHandlePtr moduleHandle ffiModuleName moduleLength ptr |
	self export: true.
	self inline: false.
	self var: #ptr declareC:'int *ptr'.
	self ffiSetLastError: FFIErrorGenericError. "educated guess if we fail silently"
	interpreterProxy methodArgumentCount = 0
		ifFalse:[^interpreterProxy primitiveFail].
	rcvr _ interpreterProxy stackValue: 0.
	theClass _ interpreterProxy fetchClassOf: rcvr.
	(interpreterProxy includesBehavior: theClass 
			ThatOf: interpreterProxy classExternalLibrary) 
				ifFalse:[^self ffiFail: FFIErrorBadExternalLibrary].
	moduleHandlePtr _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
	moduleHandle _ self ffiContentsOfHandle: moduleHandlePtr errCode: FFIErrorBadExternalLibrary.
	interpreterProxy failed ifTrue:[^0].
	ffiModuleName _ interpreterProxy fetchPointer: 1 ofObject: rcvr.
	(interpreterProxy isBytes: ffiModuleName) 
		ifFalse:[^self ffiFail: FFIErrorBadExternalLibrary].
	moduleLength _ interpreterProxy byteSizeOf: ffiModuleName.
	moduleHandle _ interpreterProxy ioLoadModule: (self cCoerce: (interpreterProxy firstIndexableField: ffiModuleName) to:'int') OfLength: moduleLength.
	interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorModuleNotFound]. "failed"
	"and store back"
	ptr _ interpreterProxy firstIndexableField: moduleHandlePtr.
	ptr at: 0 put: moduleHandle.
	^0 "done"! !


!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 19:24'!
ffiArgByValue: oop
	"Support for generic callout. Prepare an argument by value for a callout."
	| atomicType intValue floatValue |
	self inline: true.
	atomicType _ self atomicTypeOf: ffiArgHeader.
	"check if the range is valid"
	(atomicType < 0 or:[atomicType > FFITypeDoubleFloat])
		ifTrue:[^self ffiFail: FFIErrorBadAtomicType].
	atomicType < FFITypeSingleFloat ifTrue:["integer types"
		(atomicType >> 1) = (FFITypeSignedLongLong >> 1)
			ifTrue:[intValue _ oop] "ffi support code must coerce longlong"
			ifFalse:[intValue _ self ffiIntegerValueOf: oop]. "does all the coercions"
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		self dispatchOn: atomicType
			in: #(
				ffiPushVoid:
				ffiPushUnsignedInt:
				ffiPushUnsignedByte:
				ffiPushSignedByte:
				ffiPushUnsignedShort:
				ffiPushSignedShort:
				ffiPushUnsignedInt:
				ffiPushSignedInt:
				ffiPushUnsignedLongLongOop:
				ffiPushSignedLongLongOop:
				ffiPushUnsignedChar:
				ffiPushSignedChar:)
		with: intValue.
	] ifFalse:[
		"either float or double"
		floatValue _ self ffiFloatValueOf: oop.
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		atomicType = FFITypeSingleFloat
			ifTrue:[self ffiPushSingleFloat: floatValue]
			ifFalse:[self ffiPushDoubleFloat: floatValue].
	].
	^0! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/27/2000 00:06'!
ffiArgument: oop Spec: argSpec Class: argClass
	"Callout support. Prepare the given oop as argument.
	argSpec defines the compiled spec for the argument.
	argClass (if non-nil) defines the required (super)class for the argument."
	| valueOop oopClass isStruct nilOop |
	self inline: false.
	oopClass _ interpreterProxy fetchClassOf: oop. "Prefetch class (we'll need it)"
	nilOop _  interpreterProxy nilObject.
	"Do the necessary type checks"
	argClass == nilOop ifFalse:[
		"Type check 1: 
		Is the required class of the argument a subclass of ExternalStructure?"
		(interpreterProxy includesBehavior: argClass 
						ThatOf: interpreterProxy classExternalStructure)
			ifFalse:[^self ffiFail: FFIErrorWrongType]. "Nope. Fail."
		"Type check 2:
		Is the class of the argument a subclass of required class?"
		((nilOop == oop) or:[interpreterProxy includesBehavior: oopClass ThatOf: argClass])
				ifFalse:[^self ffiFail: FFIErrorCoercionFailed]. "Nope. Fail."
		"Okay, we've passed the type check (so far)"
	].

	"Check if oopClass is a subclass of ExternalStructure.
	If this is the case we'll work on it's handle and not the actual oop."
	isStruct _ false.
	((interpreterProxy isIntegerObject: oop) or:[oop == nilOop]) ifFalse:[
		"#isPointers: will fail if oop is SmallInteger so don't even attempt to use it"
		(interpreterProxy isPointers: oop) 
			ifTrue:[isStruct _ interpreterProxy includesBehavior: oopClass 
								ThatOf: interpreterProxy classExternalStructure.
					(argClass == nilOop or:[isStruct]) 
						ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
		"note: the test for #isPointers: above should speed up execution since no pointer type ST objects are allowed in external calls and thus if #isPointers: is true then the arg must be ExternalStructure to work. If it isn't then the code fails anyways so speed isn't an issue"
	].

	"Determine valueOop (e.g., the actual oop to pass as argument)"
	isStruct
		ifTrue:[valueOop _ interpreterProxy fetchPointer: 0 ofObject: oop]
		ifFalse:[valueOop _ oop].

	ffiArgClass _ argClass.

	"Fetch and check the contents of the compiled spec"
	(interpreterProxy isIntegerObject: argSpec)
		ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	(interpreterProxy isWords: argSpec)
		ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiArgSpecSize _ interpreterProxy slotSizeOf: argSpec.
	ffiArgSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiArgSpec _ self cCoerce: (interpreterProxy firstIndexableField: argSpec) to: 'int'.
	ffiArgHeader _ interpreterProxy longAt: ffiArgSpec.

	"Do the actual preparation of the argument"
	"Note: Order is important since FFIFlagStructure + FFIFlagPointer is used to represent 'typedef void* VoidPointer' and VoidPointer really is *struct* not pointer."

	(ffiArgHeader anyMask: FFIFlagStructure) ifTrue:[
		"argument must be ExternalStructure"
		isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		(ffiArgHeader anyMask: FFIFlagAtomic) 
			ifTrue:[^self ffiFail: FFIErrorWrongType]. "bad combination"
		^self ffiPushStructureContentsOf: valueOop].

	(ffiArgHeader anyMask: FFIFlagPointer) ifTrue:[
		"no integers for pointers please"
		(interpreterProxy isIntegerObject: oop) 
			ifTrue:[^self ffiFail: FFIErrorIntAsPointer].

		"but allow passing nil pointer for any pointer type"
		oop == interpreterProxy nilObject ifTrue:[^self ffiPushPointer: nil].

		"argument is reference to either atomic or structure type"
		(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
			isStruct "e.g., ExternalData"
				ifTrue:[^self ffiAtomicStructByReference: oop Class: oopClass]
				ifFalse:[^self ffiAtomicArgByReference: oop Class: oopClass].
			"********* NOTE: The above uses 'oop' not 'valueOop' (for ExternalData) ******"
		].

		"Needs to be external structure here"
		isStruct ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		^self ffiPushPointerContentsOf: valueOop].

	(ffiArgHeader anyMask: FFIFlagAtomic) ifTrue:[
		"argument is atomic value"
		self ffiArgByValue: valueOop.
		^0].
	"None of the above - bad spec"
	^self ffiFail: FFIErrorWrongType! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 22:38'!
ffiAtomicArgByReference: oop Class: oopClass
	"Support for generic callout. Prepare a pointer reference to an atomic type for callout. Note: for type 'void*' we allow either one of ByteArray/String/Symbol or wordVariableSubclass."
	| atomicType isString |
	self inline: true.
	atomicType _ self atomicTypeOf: ffiArgHeader.
	(atomicType = FFITypeBool) "No bools on input"
		ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
	((atomicType >> 1) = (FFITypeSignedChar >> 1)) ifTrue:["string value (char*)"
		"note: the only types allowed for passing into char* types are
		ByteArray, String, Symbol and *no* other byte indexed objects
		(e.g., CompiledMethod, LargeInteger). We only check for strings
		here and fall through to the byte* check otherwise."
		isString _ interpreterProxy 
					includesBehavior: oopClass 
					ThatOf: interpreterProxy classString.
		isString ifTrue:["String/Symbol"
			"Strings must be allocated by the ffi support code"
			^self ffiPushString: (self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'int') OfLength: (interpreterProxy byteSizeOf: oop)].
		"Fall through to byte* test"
		atomicType _ FFITypeUnsignedByte].

	(atomicType = FFITypeVoid or:[(atomicType >> 1) = (FFITypeSignedByte >> 1)]) ifTrue:[
		"byte* -- see comment on string above"
		oopClass = interpreterProxy classByteArray ifTrue:["ByteArray"
			^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')].
		isString _ interpreterProxy includesBehavior: oopClass 
					ThatOf: interpreterProxy classString.
		isString ifTrue:["String/Symbol"
			^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')].
		atomicType = FFITypeVoid ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		"note: type void falls through"
	].

	(atomicType <= FFITypeSignedInt "void/short/int"
		or:[atomicType = FFITypeSingleFloat]) ifTrue:[
			"require a word subclass to work"
			(interpreterProxy isWords: oop) ifTrue:[
				^self ffiPushPointer: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int')]].

	^self ffiFail: FFIErrorCoercionFailed.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 23:43'!
ffiAtomicStructByReference: oop Class: oopClass
	"Support for generic callout. Prepare an external pointer reference to an atomic type for callout."
	| atomicType valueOop |
	self inline: true.
	"must be external data to pass pointers to atomic type"
	oopClass == interpreterProxy classExternalData 
		ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
	atomicType _ self atomicTypeOf: ffiArgHeader.
	"no type checks for void pointers"
	atomicType ~= FFITypeVoid ifTrue:[
		self ffiValidateExternalData: oop AtomicType: atomicType.
		interpreterProxy failed ifTrue:[^nil].
	].
	"and push pointer contents"
	valueOop _ interpreterProxy fetchPointer: 0 ofObject: oop.
	^self ffiPushPointerContentsOf: valueOop! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 22:19'!
ffiCall: address WithFlags: callType AndTypes: argTypeArray
	"Generic callout. Does the actual work."
	| stackIndex argType argTypes oop nArgs argClass argSpec |
	self inline: true.
	"check if the calling convention is supported"
	(self ffiSupportsCallingConvention: callType)
		ifFalse:[^self ffiFail: FFIErrorCallType].
	argTypes _ argTypeArray.
	"Fetch return type and args"
	argType _ interpreterProxy fetchPointer: 0 ofObject: argTypes.
	argSpec _ interpreterProxy fetchPointer: 0 ofObject: argType.
	argClass _ interpreterProxy fetchPointer: 1 ofObject: argType.
	self ffiCheckReturn: argSpec With: argClass.
	interpreterProxy failed ifTrue:[^0]. "cannot return"
	ffiRetOop _ argType.
	nArgs _ interpreterProxy methodArgumentCount.
	stackIndex _ nArgs - 1. "stack index goes downwards"
	1 to: nArgs do:[:i|
		argType _ interpreterProxy fetchPointer: i ofObject: argTypes.
		argSpec _ interpreterProxy fetchPointer: 0 ofObject: argType.
		argClass _ interpreterProxy fetchPointer: 1 ofObject: argType.
		oop _ interpreterProxy stackValue: stackIndex.
		self ffiArgument: oop Spec: argSpec Class: argClass.
		interpreterProxy failed ifTrue:[^0]. "coercion failed"
		stackIndex _ stackIndex - 1.
	].
	"Go out and call this guy"
	^self ffiCalloutTo: address WithFlags: callType! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 22:19'!
ffiCall: address WithFlags: callType Args: argArray AndTypes: argTypeArray OfSize: nArgs
	"Generic callout. Does the actual work."
	| argType argTypes oop argSpec argClass |
	self inline: true.
	"check if the calling convention is supported"
	(self ffiSupportsCallingConvention: callType)
		ifFalse:[^self ffiFail: FFIErrorCallType].
	argTypes _ argTypeArray.
	"Fetch return type and args"
	argType _ interpreterProxy fetchPointer: 0 ofObject: argTypes.
	argSpec _ interpreterProxy fetchPointer: 0 ofObject: argType.
	argClass _ interpreterProxy fetchPointer: 1 ofObject: argType.
	self ffiCheckReturn: argSpec With: argClass.
	interpreterProxy failed ifTrue:[^0]. "cannot return"
	ffiRetOop _ argType.
	1 to: nArgs do:[:i|
		argType _ interpreterProxy fetchPointer: i ofObject: argTypes.
		argSpec _ interpreterProxy fetchPointer: 0 ofObject: argType.
		argClass _ interpreterProxy fetchPointer: 1 ofObject: argType.
		oop _ interpreterProxy fetchPointer: i-1 ofObject: argArray.
		self ffiArgument: oop Spec: argSpec Class: argClass.
		interpreterProxy failed ifTrue:[^0]. "coercion failed"
	].
	"Go out and call this guy"
	^self ffiCalloutTo: address WithFlags: callType! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 23:11'!
ffiCalloutTo: address WithFlags: callType
	"Go out, call this guy and create the return value"
	| retVal |
	self inline: false.
	"Note: Order is important here since FFIFlagPointer + FFIFlagStructure is used to represent 'typedef void* VoidPointer' and VoidPointer must be returned as pointer *not* as struct"
	(ffiRetHeader anyMask: FFIFlagPointer) ifTrue:[
		retVal _ self ffiCallAddressOf: address WithPointerReturn: callType.
		^self ffiCreateReturnPointer: retVal.
	].
	(ffiRetHeader anyMask: FFIFlagStructure) ifTrue:[
		self 
			ffiCallAddressOf: address 
			With: callType 
			Struct: (self cCoerce: ffiRetSpec to:'int*')
			Return: ffiRetSpecSize.
		^self ffiCreateReturnStruct.
	].
	retVal _ self ffiCallAddressOf: address With: callType ReturnType: ffiRetHeader.
	^self ffiCreateReturn: retVal.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 21:29'!
ffiCheckReturn: retSpec With: retClass
	"Make sure we can return an object of the given type"
	self inline: true.
	retClass == interpreterProxy nilObject ifFalse:[
		(interpreterProxy includesBehavior: retClass 
						ThatOf: interpreterProxy classExternalStructure)
			ifFalse:[^self ffiFail: FFIErrorBadReturn]].
	ffiRetClass _ retClass.

	(interpreterProxy isIntegerObject: retSpec)
		ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	(interpreterProxy isWords: retSpec)
		ifFalse:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiRetSpecSize _ interpreterProxy slotSizeOf: retSpec.
	ffiRetSpecSize = 0 ifTrue:[self ffiFail: FFIErrorWrongType. ^nil].
	ffiRetSpec _ self cCoerce: (interpreterProxy firstIndexableField: retSpec) to: 'int'.
	ffiRetHeader _ interpreterProxy longAt: ffiRetSpec.
	(self isAtomicType: ffiRetHeader) ifFalse:[
		(ffiRetClass == interpreterProxy nilObject)
			ifTrue:[^self ffiFail: FFIErrorBadReturn]].
	(self ffiCan: (self cCoerce: ffiRetSpec to:'int*') Return: ffiRetSpecSize)
		ifFalse:[self ffiFail: FFIErrorBadReturn]. "cannot return this type"
	^0! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 21:35'!
ffiContentsOfHandle: oop errCode: errCode
	"Make sure that the given oop is a valid external handle"
	self inline: true.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^self ffiFail: errCode].
	(interpreterProxy isBytes: oop)
		ifFalse:[^self ffiFail: errCode].
	((interpreterProxy byteSizeOf: oop) == 4)
		ifFalse:[^self ffiFail: errCode].
	^interpreterProxy fetchWord: 0 ofObject: oop! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 19:43'!
ffiCreateLongLongReturn: isSigned
	"Create a longlong return value from a previous call out"
	| lowWord highWord largeClass nBytes largeInt ptr |
	self var: #ptr declareC:'unsigned char *ptr'.
	lowWord _ self ffiLongLongResultLow.
	highWord _ self ffiLongLongResultHigh.
	isSigned ifTrue:["check for 32 bit signed"
		(highWord = 0 and:[lowWord >= 0])
			ifTrue:[^interpreterProxy signed32BitIntegerFor: lowWord].
		(highWord = -1 and:[lowWord < 0])
			ifTrue:[^interpreterProxy signed32BitIntegerFor: lowWord].
		"negate value for negative longlong"
		highWord < 0 
			ifTrue:[	largeClass _ interpreterProxy classLargeNegativeInteger.
					lowWord _ lowWord bitInvert32.
					highWord _ highWord bitInvert32.
					lowWord = -1 "e.g., overflow when adding one"
						ifTrue:[highWord _ highWord + 1].
					lowWord _ lowWord + 1]
			ifFalse:[largeClass _ interpreterProxy classLargePositiveInteger].
			"fall through"
	] ifFalse:["check for 32 bit unsigned"
		highWord = 0 ifTrue:[
			^interpreterProxy positive32BitIntegerFor: lowWord].
		largeClass _ interpreterProxy classLargePositiveInteger.
		"fall through"
	].
	"Create LargeInteger result"
	nBytes _ 8.
	(highWord anyMask: 255 << 24) ifFalse:[
		nBytes _ 7.
		highWord < (1 << 16) ifTrue:[nBytes _ 6].
		highWord < (1 << 8) ifTrue:[nBytes _ 5].
		highWord = 0 ifTrue:[nBytes _ 4]].
	"now we know how many bytes to create"
	largeInt _ interpreterProxy instantiateClass: largeClass indexableSize: nBytes.
	(interpreterProxy isBytes: largeInt) 
		ifFalse:[^self ffiFail: FFIErrorBadReturn]. "Hossa!!"
	ptr _ interpreterProxy firstIndexableField: largeInt.
	4 to: nBytes-1 do:[:i|
		ptr at: i put: (highWord >> (i-4*8) bitAnd: 255)].
	ptr at: 3 put: (lowWord >> 24 bitAnd: 255).
	ptr at: 2 put: (lowWord >> 16 bitAnd: 255).
	ptr at: 1 put: (lowWord >> 8 bitAnd: 255).
	ptr at: 0 put: (lowWord bitAnd: 255).
	^largeInt! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 19:47'!
ffiCreateReturn: retVal
	"Generic callout support. Create an atomic return value from an external function call"
	| atomicType retOop oop |
	self inline: true.
	interpreterProxy failed ifTrue:[^nil].
	atomicType _ self atomicTypeOf: ffiRetHeader.
	"void returns self"
	atomicType <= FFITypeVoid ifTrue:[
		^interpreterProxy pop: interpreterProxy methodArgumentCount].
	"everything else returns value"
	interpreterProxy pop: 
		interpreterProxy methodArgumentCount+1.
	interpreterProxy pushRemappableOop: ffiRetClass.
	retOop _ self ffiCreateReturnOop: retVal.
	ffiRetClass _ interpreterProxy popRemappableOop.
	ffiRetClass == interpreterProxy nilObject ifTrue:[
		"Just return oop"
		^interpreterProxy push: retOop].
	"Otherwise create an instance of external structure and store the return oop"
	interpreterProxy pushRemappableOop: retOop.
	retOop _ interpreterProxy instantiateClass: ffiRetClass indexableSize: 0.
	oop _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: retOop withValue: oop.
	^interpreterProxy push: retOop.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 5/16/2000 13:39'!
ffiCreateReturnOop: retVal
	"Callout support. Return the appropriate oop for the given atomic value"
	| atomicType shift value mask byteSize |
	atomicType _ self atomicTypeOf: ffiRetHeader.
	atomicType = FFITypeBool ifTrue:[
			"Make sure bool honors the byte size requested"
			byteSize _ ffiRetHeader bitAnd: FFIStructSizeMask.
			byteSize = 4
				ifTrue:[value _ retVal]
				ifFalse:[value _ retVal bitAnd: 1 << (byteSize * 8) - 1].
			value = 0
				ifTrue:[^interpreterProxy falseObject]
				ifFalse:[^interpreterProxy trueObject]].
	atomicType <= FFITypeSignedInt ifTrue:[
		"these are all generall integer returns"
		atomicType <= FFITypeSignedShort ifTrue:[
			"byte/short. first extract partial word, then sign extend"
			shift _ (atomicType >> 1) * 8. "# of significant bits"
			value _ retVal bitAnd: (1 << shift - 1). 
			(atomicType anyMask: 1) ifTrue:[
				"make the guy signed"
				mask _ 1 << (shift-1).
				value _ (value bitAnd: mask-1) - (value bitAnd: mask)].
			^interpreterProxy integerObjectOf: value].
		"32bit integer return"
		(atomicType anyMask: 1)
			ifTrue:[^(interpreterProxy signed32BitIntegerFor: retVal)] "signed return"
			ifFalse:[^(interpreterProxy positive32BitIntegerFor: retVal)]]. "unsigned return"

	atomicType < FFITypeSingleFloat ifTrue:[
		"longlong, char"
		(atomicType >> 1) = (FFITypeSignedLongLong >> 1) 
			ifTrue:[^self ffiCreateLongLongReturn: (atomicType anyMask: 1)]
			ifFalse:[^(interpreterProxy 
						fetchPointer: (retVal bitAnd: 255)
						ofObject: interpreterProxy characterTable)]].
	"float return"
	^interpreterProxy floatObjectOf: (self ffiReturnFloatValue).! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 23:15'!
ffiCreateReturnPointer: retVal
	"Generic callout support. Create a pointer return value from an external function call"
	| atomicType retOop oop ptr classOop |
	self var: #ptr declareC:'int *ptr'.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: interpreterProxy methodArgumentCount+1.
	(ffiRetClass == interpreterProxy nilObject) ifTrue:[
		"Create ExternalData upon return"
		atomicType _ self atomicTypeOf: ffiRetHeader.
		(atomicType >> 1) = (FFITypeSignedChar >> 1) ifTrue:["String return"
			^self ffiReturnCStringFrom: retVal].
		"generate external data"
		interpreterProxy pushRemappableOop: ffiRetOop.
		oop _ interpreterProxy 
				instantiateClass: interpreterProxy classExternalAddress 
				indexableSize: 4.
		ptr _ interpreterProxy firstIndexableField: oop.
		ptr at: 0 put: retVal.
		interpreterProxy pushRemappableOop: oop. "preserve for gc"
		retOop _ interpreterProxy 
				instantiateClass: interpreterProxy classExternalData 
				indexableSize: 0.
		oop _ interpreterProxy popRemappableOop. "external address"
		interpreterProxy storePointer: 0 ofObject: retOop withValue: oop.
		oop _ interpreterProxy popRemappableOop. "return type"
		interpreterProxy storePointer: 1 ofObject: retOop withValue: oop.
		^interpreterProxy push: retOop.
	].
	"non-atomic pointer return"
	interpreterProxy pushRemappableOop: ffiRetClass. "preserve for gc"
	(ffiRetHeader anyMask: FFIFlagStructure)
		ifTrue:[classOop _ interpreterProxy classByteArray]
		ifFalse:[classOop _ interpreterProxy classExternalAddress].
	oop _ interpreterProxy 
			instantiateClass: classOop
			indexableSize: 4.
	ptr _ interpreterProxy firstIndexableField: oop.
	ptr at: 0 put: retVal.
	ffiRetClass _ interpreterProxy popRemappableOop. "return class"
	interpreterProxy pushRemappableOop: oop. "preserve for gc"
	retOop _ interpreterProxy instantiateClass: ffiRetClass indexableSize: 0.
	oop _ interpreterProxy popRemappableOop. "external address"
	interpreterProxy storePointer: 0 ofObject: retOop withValue: oop.
	^interpreterProxy push: retOop.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 21:33'!
ffiCreateReturnStruct
	"Generic callout support. Create a structure return value from an external function call"
	| retOop structSize oop |
	self inline: true.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: interpreterProxy methodArgumentCount+1.
	structSize _ ffiRetHeader bitAnd: FFIStructSizeMask.
	interpreterProxy pushRemappableOop: ffiRetClass.
	oop _ interpreterProxy 
			instantiateClass: interpreterProxy classByteArray 
			indexableSize: structSize.
	self ffiStore: (self cCoerce: (interpreterProxy firstIndexableField: oop) to:'int') 
		Structure: structSize.
	ffiRetClass _ interpreterProxy popRemappableOop.
	interpreterProxy pushRemappableOop: oop. "secure byte array"
	retOop _ interpreterProxy instantiateClass: ffiRetClass indexableSize: 0.
	oop _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: retOop withValue: oop.
	^interpreterProxy push: retOop.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/29/1999 10:42'!
ffiFail: reason
	self inline: true.
	self ffiSetLastError: reason.
	^interpreterProxy primitiveFail! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 21:36'!
ffiFloatValueOf: oop
	"Support for generic callout. Return a float value that is coerced as C would do."
	| oopClass |
	self returnTypeC:'double'.
	oopClass _ interpreterProxy fetchClassOf: oop.
	oopClass == interpreterProxy classFloat
		ifTrue:[^interpreterProxy floatValueOf: oop].
	"otherwise try the integer coercions and return its float value"
	^(self ffiIntegerValueOf: oop) asFloat! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 18:06'!
ffiGetLastError
	^ffiLastError! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/1/1999 18:55'!
ffiIntegerValueOf: oop
	"Support for generic callout. Return an integer value that is coerced as C would do."
	| oopClass |
	self inline: true.
	(interpreterProxy isIntegerObject: oop) ifTrue:[^interpreterProxy integerValueOf: oop].
	oop == interpreterProxy nilObject ifTrue:[^0]. "@@: should we really allow this????"
	oop == interpreterProxy falseObject ifTrue:[^0].
	oop == interpreterProxy trueObject ifTrue:[^1].
	oopClass _ interpreterProxy fetchClassOf: oop.
	oopClass == interpreterProxy classFloat
		ifTrue:[^(interpreterProxy floatValueOf: oop) asInteger].
	oopClass == interpreterProxy classCharacter
		ifTrue:[^interpreterProxy fetchInteger: 0 ofObject: oop].
	^interpreterProxy signed32BitValueOf: oop "<- will fail if not integer"! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/26/2000 23:08'!
ffiPushPointerContentsOf: oop
	"Push the contents of the given external structure"
	| ptrValue ptrClass ptrAddress |
	self inline: false.
	ptrValue _ oop.
	ptrClass _ interpreterProxy fetchClassOf: ptrValue.
	ptrClass == interpreterProxy classExternalAddress ifTrue:[
		ptrAddress _ interpreterProxy fetchWord: 0 ofObject: ptrValue.
		"Don't you dare to pass pointers into object memory"
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPushPointer: ptrAddress].
	ptrClass == interpreterProxy classByteArray ifTrue:[
		ptrAddress _ self cCoerce: (interpreterProxy firstIndexableField: ptrValue) to: 'int'.
		^self ffiPushPointer: ptrAddress].
	^self ffiFail: FFIErrorBadArg! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 18:21'!
ffiPushSignedLongLongOop: oop
	"Push a longlong type (e.g., a 64bit integer).
	Note: Coercions from float are *not* supported."
	| lowWord highWord length oopClass negative ptr |
	self var: #ptr declareC:'unsigned char *ptr'.
	oop == interpreterProxy nilObject 
		ifTrue:[^self ffiPushSignedLong: 0 Long: 0.]. "@@: check this"
	oop == interpreterProxy falseObject
		ifTrue:[^self ffiPushSignedLong: 0 Long: 0].
	oop == interpreterProxy trueObject
		ifTrue:[^self ffiPushSignedLong: 0 Long: 1].
	(interpreterProxy isIntegerObject: oop) ifTrue:[
		lowWord _ interpreterProxy integerValueOf: oop.
		lowWord < 0 
			ifTrue:[highWord _ -1]
			ifFalse:[highWord _ 0].
	] ifFalse:[
		oopClass _ interpreterProxy fetchClassOf: oop.
		oopClass == interpreterProxy classLargePositiveInteger 
			ifTrue:[negative _ false]
			ifFalse:[oopClass == interpreterProxy classLargeNegativeInteger 
				ifTrue:[negative _ true]
				ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
		(interpreterProxy isBytes: oop) ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		length _ interpreterProxy byteSizeOf: oop.
		length > 8 ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		lowWord _ highWord _ 0.
		ptr _ interpreterProxy firstIndexableField: oop.
		0 to: (length min: 4)-1 do:[:i|
			lowWord _ lowWord + ((ptr at: i) << (i*8))].
		0 to: (length-5) do:[:i|
			highWord _ highWord + ((ptr at: i+4) << (i*8))].
		negative ifTrue:[
			lowWord _ lowWord bitInvert32.
			highWord _ highWord bitInvert32.
			lowWord = -1 "e.g., will overflow when adding one"
				ifTrue:[highWord _ highWord + 1].
			lowWord _ lowWord + 1].
	].
	^self ffiPushSignedLong: lowWord Long: highWord.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 1/27/2000 00:02'!
ffiPushStructureContentsOf: oop
	"Push the contents of the given external structure"
	| ptrValue ptrClass ptrAddress |
	self inline: true.
	ptrValue _ oop.
	ptrClass _ interpreterProxy fetchClassOf: ptrValue.
	ptrClass == interpreterProxy classExternalAddress ifTrue:[
		ptrAddress _ interpreterProxy fetchWord: 0 ofObject: ptrValue.
		"There is no way we can make sure the structure is valid.
		But we can at least check for attempts to pass pointers to ST memory."
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPush: ptrAddress 
				Structure: (self cCoerce: ffiArgSpec to:'int*')
				OfLength: ffiArgSpecSize].
	ptrClass == interpreterProxy classByteArray ifTrue:[
		"The following is a somewhat pessimistic test but I like being sure..."
		(interpreterProxy byteSizeOf: ptrValue) = (ffiArgHeader bitAnd: FFIStructSizeMask)
			ifFalse:[^self ffiFail: FFIErrorStructSize].
		ptrAddress _ self cCoerce: (interpreterProxy firstIndexableField: ptrValue) to: 'int'.
		(ffiArgHeader anyMask: FFIFlagPointer) ifFalse:[
			^self ffiPush: ptrAddress 
					Structure: (self cCoerce: ffiArgSpec to: 'int*')
					OfLength: ffiArgSpecSize].
		"If FFIFlagPointer + FFIFlagStructure is set use ffiPushPointer on the contents"
		(ffiArgHeader bitAnd: FFIStructSizeMask) = 4
			ifFalse:[^self ffiFail: FFIErrorStructSize].
		ptrAddress _ interpreterProxy fetchWord: 0 ofObject: ptrValue.
		(interpreterProxy isInMemory: ptrAddress)
			ifTrue:[^self ffiFail: FFIErrorInvalidPointer].
		^self ffiPushPointer: ptrAddress].
	^self ffiFail: FFIErrorBadArg! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 19:05'!
ffiPushUnsignedLongLongOop: oop
	"Push a longlong type (e.g., a 64bit integer).
	Note: Coercions from float are *not* supported."
	| lowWord highWord length ptr |
	self var: #ptr declareC:'unsigned char *ptr'.
	oop == interpreterProxy nilObject 
		ifTrue:[^self ffiPushUnsignedLong: 0 Long: 0.]. "@@: check this"
	oop == interpreterProxy falseObject 
		ifTrue:[^self ffiPushUnsignedLong: 0 Long: 0].
	oop == interpreterProxy trueObject 
		ifTrue:[^self ffiPushUnsignedLong: 0 Long: 1].
	(interpreterProxy isIntegerObject: oop) ifTrue:[
		lowWord _ interpreterProxy integerValueOf: oop.
		lowWord < 0 ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		highWord _ 0.
	] ifFalse:[
		(interpreterProxy fetchClassOf: oop) = interpreterProxy classLargePositiveInteger
			ifFalse:[^interpreterProxy primitiveFail].
		(interpreterProxy isBytes: oop) ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		length _ interpreterProxy byteSizeOf: oop.
		length > 8 ifTrue:[^self ffiFail: FFIErrorCoercionFailed].
		lowWord _ highWord _ 0.
		ptr _ interpreterProxy firstIndexableField: oop.
		0 to: (length min: 4)-1 do:[:i|
			lowWord _ lowWord + ((ptr at: i) << (i*8))].
		0 to: (length-5) do:[:i|
			highWord _ highWord + ((ptr at: i+4) << (i*8))].
	].
	^self ffiPushUnsignedLong: lowWord Long: highWord.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 19:25'!
ffiPushVoid: ignored
	"This is a fallback in case somebody tries to pass a 'void' value.
	We could simply ignore the argument but I think it's better to let
	the caller know what he did"
	^self ffiFail: FFIErrorAttemptToPassVoid.! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 18:25'!
ffiReturnCStringFrom: cPointer
	"Create a Smalltalk string from a zero terminated C string"
	| strLen strOop cString strPtr |
	self var: #cString declareC:'char *cString'.
	self var: #strPtr declareC:'char *strPtr'.
	cPointer = nil ifTrue:[
		^interpreterProxy push: interpreterProxy nilObject]. "nil always returs as nil"
	cString _ self cCoerce: cPointer to:'char *'.
	strLen _ 0.
	[(cString at: strLen) = 0] whileFalse:[strLen _ strLen+1].
	strOop _ interpreterProxy 
				instantiateClass: interpreterProxy classString 
				indexableSize: strLen.
	strPtr _ interpreterProxy firstIndexableField: strOop.
	0 to: strLen-1 do:[:i| strPtr at: i put: (cString at: i)].
	^interpreterProxy push: strOop! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 11/28/1999 18:25'!
ffiSetLastError: errCode
	^ffiLastError _ errCode! !

!FFIPlugin methodsFor: 'callout support' stamp: 'ar 12/2/1999 21:37'!
ffiValidateExternalData: oop AtomicType: atomicType
	"Validate if the given oop (an instance of ExternalData) can be passed as a pointer to the given atomic type."
	| ptrType specOop spec specType |
	self inline: true.
	ptrType _ interpreterProxy fetchPointer: 1 ofObject: oop.
	(interpreterProxy isIntegerObject: ptrType)
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy isPointers: ptrType)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy slotSizeOf: ptrType) < 2
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	specOop _ interpreterProxy fetchPointer: 0 ofObject: ptrType.
	(interpreterProxy isIntegerObject: specOop)
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy isWords: specOop)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	(interpreterProxy slotSizeOf: specOop) = 0
		ifTrue:[^self ffiFail: FFIErrorWrongType].
	spec _ interpreterProxy fetchWord: 0 ofObject: specOop.
	(self isAtomicType: spec)
		ifFalse:[^self ffiFail: FFIErrorWrongType].
	specType _ self atomicTypeOf: spec.
	specType ~= atomicType ifTrue:[
		"allow for signed/unsigned conversion but nothing else"
		(atomicType > FFITypeBool and:[atomicType < FFITypeSingleFloat])
			ifFalse:[^self ffiFail: FFIErrorCoercionFailed].
		((atomicType >> 1) = (specType >> 1))
			ifFalse:[^self ffiFail: FFIErrorCoercionFailed]].
	^0! !


!FFIPlugin methodsFor: 'symbol loading' stamp: 'ar 11/28/1999 19:10'!
ffiLoadCalloutAddress: lit
	"Load the address of the foreign function from the given object"
	| addressPtr address ptr |
	self var: #ptr declareC:'int *ptr'.
	"Lookup the address"
	addressPtr _ interpreterProxy fetchPointer: 0 ofObject: lit.
	"Make sure it's an external handle"
	address _ self ffiContentsOfHandle: addressPtr errCode: FFIErrorBadAddress.
	interpreterProxy failed ifTrue:[^0].
	address = 0 ifTrue:["Go look it up in the module"
		(interpreterProxy slotSizeOf: lit) < 5 ifTrue:[^self ffiFail: FFIErrorNoModule].
		address _ self ffiLoadCalloutAddressFrom: lit.
		interpreterProxy failed ifTrue:[^0].
		"Store back the address"
		ptr _ interpreterProxy firstIndexableField: addressPtr.
		ptr at: 0 put: address].
	^address! !

!FFIPlugin methodsFor: 'symbol loading' stamp: 'ar 11/28/1999 20:09'!
ffiLoadCalloutAddressFrom: oop
	"Load the function address for a call out to an external function"
	| module moduleHandle functionName functionLength address |
	self inline: false.
	"First find and load the module"
	module _ interpreterProxy fetchPointer: 4 ofObject: oop.
	moduleHandle _ self ffiLoadCalloutModule: module.
	interpreterProxy failed ifTrue:[^0]. "failed"
	"fetch the function name"
	functionName _ interpreterProxy fetchPointer: 3 ofObject: oop.
	(interpreterProxy isBytes: functionName) ifFalse:[^self ffiFail: FFIErrorBadExternalFunction].
	functionLength _ interpreterProxy byteSizeOf: functionName.
	address _ interpreterProxy ioLoadSymbol: 
					(self cCoerce: (interpreterProxy firstIndexableField: functionName) to:'int')
					OfLength: functionLength 
					FromModule: moduleHandle.
	(interpreterProxy failed or:[address = 0])
		ifTrue:[^self ffiFail: FFIErrorAddressNotFound].
	^address! !

!FFIPlugin methodsFor: 'symbol loading' stamp: 'ar 5/12/2000 17:22'!
ffiLoadCalloutModule: module
	"Load the given module and return its handle"
	| moduleHandlePtr moduleHandle ffiModuleName moduleLength rcvr theClass ptr |
	self var: #ptr declareC:'int *ptr'.
	(interpreterProxy isBytes: module) ifTrue:[
		"plain module name"
		ffiModuleName _ module.
		moduleLength _ interpreterProxy byteSizeOf: ffiModuleName.
		moduleHandle _ interpreterProxy ioLoadModule: (self cCoerce: (interpreterProxy firstIndexableField: ffiModuleName) to:'int') OfLength: moduleLength.
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorModuleNotFound]. "failed"
		^moduleHandle].
	"Check if the external method is defined in an external library"
	rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	theClass _ interpreterProxy fetchClassOf: rcvr.
	(interpreterProxy includesBehavior: theClass 
			ThatOf: interpreterProxy classExternalLibrary) ifFalse:[^0].
	"external library"
	moduleHandlePtr _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
	moduleHandle _ self ffiContentsOfHandle: moduleHandlePtr errCode: FFIErrorBadExternalLibrary.
	interpreterProxy failed ifTrue:[^0].
	moduleHandle = 0 ifTrue:["need to reload module"
		ffiModuleName _ interpreterProxy fetchPointer: 1 ofObject: rcvr.
		(interpreterProxy isBytes: ffiModuleName) ifFalse:[^self ffiFail: FFIErrorBadExternalLibrary].
		moduleLength _ interpreterProxy byteSizeOf: ffiModuleName.
		moduleHandle _ interpreterProxy ioLoadModule: (self cCoerce: (interpreterProxy firstIndexableField: ffiModuleName) to:'int') OfLength: moduleLength.
		interpreterProxy failed ifTrue:[^self ffiFail: FFIErrorModuleNotFound]. "failed"
		"and store back"
		ptr _ interpreterProxy firstIndexableField: moduleHandlePtr.
		ptr at: 0 put: moduleHandle].
	^moduleHandle! !


!FFIPlugin methodsFor: 'primitive support' stamp: 'ar 11/28/1999 23:59'!
addressOf: rcvr startingAt: byteOffset size: byteSize
	| rcvrClass rcvrSize addr |
	(interpreterProxy isBytes: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	(byteOffset > 0) ifFalse:[^interpreterProxy primitiveFail].
	rcvrClass _ interpreterProxy fetchClassOf: rcvr.
	rcvrSize _ interpreterProxy byteSizeOf: rcvr.
	rcvrClass == interpreterProxy classExternalAddress ifTrue:[
		(rcvrSize = 4) ifFalse:[^interpreterProxy primitiveFail].
		addr _ interpreterProxy fetchWord: 0 ofObject: rcvr.
		"don't you dare to read from object memory!!"
		(addr == 0 or:[interpreterProxy isInMemory: addr])
			ifTrue:[^interpreterProxy primitiveFail].
	] ifFalse:[
		(byteOffset+byteSize-1 <= rcvrSize)
			ifFalse:[^interpreterProxy primitiveFail].
		addr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'int'.
	].
	addr _ addr + byteOffset - 1.
	^addr! !

!FFIPlugin methodsFor: 'primitive support' stamp: 'ar 12/2/1999 21:02'!
atomicTypeOf: value
	^(value bitAnd: FFIAtomicTypeMask) >> FFIAtomicTypeShift! !

!FFIPlugin methodsFor: 'primitive support' stamp: 'ar 12/2/1999 21:04'!
isAtomicType: typeSpec
	^typeSpec anyMask: FFIFlagAtomic! !

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

FFIPlugin class
	instanceVariableNames: ''!

!FFIPlugin class methodsFor: 'accessing' stamp: 'ar 11/28/1999 18:55'!
declareCVarsIn: aCCodeGen
	aCCodeGen addHeaderFile: '"sqFFI.h"'! !

!FFIPlugin class methodsFor: 'accessing' stamp: 'ar 12/2/1999 22:19'!
moduleName "FFIPlugin translate"
	"IMPORTANT: IF YOU CHANGE THE NAME OF THIS PLUGIN YOU MUST CHANGE
		Interpreter>>primitiveCalloutToFFI
	TO REFLECT THE CHANGE."
	^'SqueakFFIPrims'! !


!FFIPlugin class methodsFor: 'C support code' stamp: 'ar 1/26/2000 14:27'!
sqFFIHeaderFile
^'/****************************************************************************
*   PROJECT: Squeak foreign function interface
*   FILE:    sqFFI.h
*   CONTENT: Declarations for the foreign function interface
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*****************************************************************************/
#ifndef SQ_FFI_H
#define SQ_FFI_H

/* Calling conventions */
#define FFICallTypeCDecl 0
#define FFICallTypeApi 1

/* Atomic types */
#define FFITypeVoid 0
#define FFITypeBool 1
#define FFITypeUnsignedByte 2
#define FFITypeSignedByte 3
#define FFITypeUnsignedShort 4
#define FFITypeSignedShort 5
#define FFITypeUnsignedInt 6
#define FFITypeSignedInt 7
#define FFITypeUnsignedLongLong 8
#define FFITypeSignedLongLong 9
#define FFITypeUnsignedChar 10
#define FFITypeSignedChar 11
#define FFITypeSingleFloat 12
#define FFITypeDoubleFloat 13

/* Shift and mask for atomic types */
#define FFIAtomicTypeShift 24
#define FFIAtomicTypeMask 251658240

/* Type flags */
#define FFIFlagPointer 131072
#define FFIFlagStructure 65536
#define FFIFlagAtomic 262144

/* Size mask */
#define FFIStructSizeMask 65535

/* error constants */
#define FFINoCalloutAvailable -1
#define FFIErrorGenericError 0
#define FFIErrorNotFunction 1
#define FFIErrorBadArgs 2
#define FFIErrorBadArg 3
#define FFIErrorIntAsPointer 4
#define FFIErrorBadAtomicType 5
#define FFIErrorCoercionFailed 6
#define FFIErrorWrongType 7
#define FFIErrorStructSize 8
#define FFIErrorCallType 9
#define FFIErrorBadReturn 10
#define FFIErrorBadAddress 11
#define FFIErrorNoModule 12
#define FFIErrorAddressNotFound 13
#define FFIErrorAttemptToPassVoid 14
#define FFIErrorModuleNotFound 15
#define FFIErrorBadExternalLibrary 16
#define FFIErrorBadExternalFunction 17
#define FFIErrorInvalidPointer 18

/* Announce a coming FFI call */
int ffiInitialize(void);

/* cleanup */
int ffiCleanup(void);

/* Allocate/free external memory */
int ffiAlloc(int byteSize);
int ffiFree(int ptr);

/* general <=32bit integer loads */
int ffiPushSignedByte(int value);
int ffiPushUnsignedByte(int value);
int ffiPushSignedShort(int value);
int ffiPushUnsignedShort(int value);
int ffiPushSignedInt(int value);
int ffiPushUnsignedInt(int value);

/* 64bit integer loads */
int ffiPushSignedLongLong(int lowWord, int highWord);
int ffiPushUnsignedLongLong(int lowWord, int highWord);
/* 64bit integer returns */
int ffiLongLongResultLow(void);
int ffiLongLongResultHigh(void);

/* special <=32bit loads */
int ffiPushSignedChar(int value);
int ffiPushUnsignedChar(int value);

/* float loads */
int ffiPushSingleFloat(double value);
int ffiPushDoubleFloat(double value);

/* structure loads */
int ffiPushStructureOfLength(int pointer, int* structSpec, int specSize);

/* pointer loads */
int ffiPushPointer(int pointer);

/* string loads */
int ffiPushStringOfLength(int srcIndex, int length);

/* return true if calling convention is supported */
int ffiSupportsCallingConvention(int callType);

/* return true if these types can be returned */
int ffiCanReturn(int* structSpec, int specSize);

/* call the appropriate function w/ the given return type */
int ffiCallAddressOfWithPointerReturn(int fn, int callType);
int ffiCallAddressOfWithStructReturn(int fn, int callType, 
				     int* structSpec, int specSize);
int ffiCallAddressOfWithReturnType(int fn, int callType, int typeSpec);

/* store the structure result of a previous call */
int ffiStoreStructure(int address, int structSize);

/* return the float value from a previous call */
double ffiReturnFloatValue(void);


#endif /* SQ_FFI_H */
'! !

!FFIPlugin class methodsFor: 'C support code' stamp: 'JMM 8/16/2000 13:53'!
sqMacFFIPPCFile
^'/****************************************************************************
*   PROJECT: Squeak foreign function interface
*   FILE:    sqMacFFIPPC.c
*   CONTENT: Mac/PPC specific support for the foreign function interface
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   Andreas.Raab@disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*****************************************************************************/
#include "sq.h"
#include "sqFFI.h"

/* note: LONGLONG is usually declared by universal headers */
#ifndef LONGLONG
#define LONGLONG long long
#endif

extern struct VirtualMachine *interpreterProxy;
#define primitiveFail() interpreterProxy->primitiveFail();


#define GP_MAX_REGS 8
#define FP_MAX_REGS 13

/* Values passed in GPR3-GPR10 */
static int GPRegs[8];
/* Nr of GPRegs used so far */
static int gpRegCount = 0;
/* Values passed in FPR1-FPR13 */
static double FPRegs[13];
/* Nr of FPRegs used so far */
static int fpRegCount = 0;

/* Max stack size */
#define FFI_MAX_STACK 512
/* The stack used to assemble the arguments for a call */
static int   ffiStack[FFI_MAX_STACK];
/* The stack pointer while filling the stack */
static int   ffiStackIndex = 0;
/* The area for temporarily allocated strings */
static char *ffiTempStrings[FFI_MAX_STACK];
/* The number of temporarily allocated strings */
static int   ffiTempStringCount = 0;

/* The return values for calls */
static int      intReturnValue;
static LONGLONG longReturnValue;
static double   floatReturnValue;
static int *structReturnValue = NULL;

/**************************************************************/
#define ARG_CHECK() if(gpRegCount >= GP_MAX_REGS && ffiStackIndex >= FFI_MAX_STACK) return primitiveFail();
#define ARG_PUSH(value) { \
	ARG_CHECK(); \
	if(gpRegCount < GP_MAX_REGS) GPRegs[gpRegCount++] = value; \
	ffiStack[ffiStackIndex++] = value; \
}

/*****************************************************************************/
/*****************************************************************************/

/*  ffiInitialize:
	Announce that the VM is about to do an external function call. */
int ffiInitialize(void)
{
	ffiStackIndex = 0;
	gpRegCount = 0;
	fpRegCount = 0;
	floatReturnValue = 0.0;
	return 1;
}

/*  ffiSupportsCallingConvention:
	Return true if the support code supports the given calling convention. */
int ffiSupportsCallingConvention(int callType)
{
	if(callType == FFICallTypeCDecl) return 1;
	if(callType == FFICallTypeApi) return 1;
	return 0;
}

int ffiAlloc(int byteSize)
{
	return (int) malloc(byteSize);
}

int ffiFree(int ptr)
{
	if(ptr) free((void*)ptr);
	return 1;
}

/*****************************************************************************/
/*****************************************************************************/

int ffiPushSignedChar(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedChar(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedByte(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedByte(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedShort(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedShort(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedInt(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedInt(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedLongLong(int low, int high)
{
	ARG_PUSH(high);
	ARG_PUSH(low);
	return 1;
}

int ffiPushUnsignedLongLong(int low, int high) 
{ 
	ARG_PUSH(high); 
	ARG_PUSH(low); 
	return 1; 
}

int ffiPushSingleFloat(double value)
{
	float floatValue = (float) value;
	if(fpRegCount < FP_MAX_REGS) {
		/* Still space in FPRegs - so we use the more accurate double value */
		FPRegs[fpRegCount++] = value;
	}
	/* Note: Even for args that are passed in FPRegs 
	   we pass the actual 32bit value in either GPRegs
	   or stack frame for varargs calls. */
	ARG_PUSH(*(int*)(&floatValue));
	return 1;
}

int ffiPushDoubleFloat(double value)
{
	if(fpRegCount < FP_MAX_REGS) {
		/* Still space in FPRegs */
		FPRegs[fpRegCount++] = value;
	}
	/* Note: Even for args that are passed in FPRegs 
	   we pass the actual 64bit value in either GPRegs
	   or stack frame for varargs calls. */
	ARG_PUSH(((int*)(&value))[1]);
	ARG_PUSH(((int*)(&value))[0]);
	return 1;
}

int ffiPushStructureOfLength(int pointer, int *structSpec, int specSize)
{
	int i, typeSpec;
	int *data = (int*) pointer;

	for(i = 0; i<specSize; i++) {
		typeSpec = structSpec[i];
		if(typeSpec & FFIFlagPointer) {
			ARG_PUSH(*data);
			data++;
		} else if(typeSpec & FFIFlagStructure) {
			/* embedded structure */
		} else {
			/* atomic type */
			int atomicType = (typeSpec & FFIAtomicTypeMask) >> FFIAtomicTypeShift;
			switch(atomicType) {
				case FFITypeUnsignedChar:
				case FFITypeUnsignedByte:
					ffiPushUnsignedByte(*(unsigned char*)data);
					break;
				case FFITypeSignedChar:
				case FFITypeSignedByte:
					ffiPushSignedByte(*(signed char*)data);
					break;
				case FFITypeUnsignedShort:
					ffiPushUnsignedShort(*(unsigned short*)data);
					break;
				case FFITypeSignedShort:
					ffiPushSignedShort(*(signed short*)data);
					break;
				case FFITypeUnsignedInt:
					ffiPushUnsignedInt(*(unsigned int*)data);
					break;
				case FFITypeSignedInt:
					ffiPushSignedInt(*(signed int*)data);
					break;
				case FFITypeUnsignedLongLong:
					ffiPushUnsignedLongLong( ((unsigned int*)data)[1], ((unsigned int*)data)[0]);
					break;
				case FFITypeSignedLongLong:
					ffiPushSignedLongLong( ((signed int*)data)[1], ((signed int*)data)[0]);
					break;
				case FFITypeSingleFloat:
					ffiPushSingleFloat( *(float*)data);
					break;
				case FFITypeDoubleFloat:
					{ double fArg;
					  ((int*)&fArg)[0] = ((int*)data)[0];
					  ((int*)&fArg)[1] = ((int*)data)[1];
					  ffiPushDoubleFloat(fArg);
					}
					break;
				default:
					return primitiveFail();
			}
			data = (int*) ((int)data + (typeSpec & FFIStructSizeMask));
		}
	}
	return 1;
}

int ffiPushPointer(int pointer)
{
	ARG_PUSH(pointer);
	return 1;
}

int ffiPushStringOfLength(int srcIndex, int length)
{
	char *ptr;
	ARG_CHECK(); /* fail before allocating */
	ptr = (char*) malloc(length+1);
	if(!!ptr) return primitiveFail();
	memcpy(ptr, (void*)srcIndex, length);
	ptr[length] = 0;
	ffiTempStrings[ffiTempStringCount++] = ptr;
	ARG_PUSH((int)ptr);
	return 1;
}

/*****************************************************************************/
/*****************************************************************************/

/*  ffiCanReturn:
	Return true if the support code can return the given type. */
int ffiCanReturn(int *structSpec, int specSize)
{
	int header = *structSpec;
	if(header & FFIFlagPointer) return 1;
	if(header & FFIFlagStructure) {
		/* structs are always returned as pointers to hidden structures */
		int structSize = header & FFIStructSizeMask;
		structReturnValue = malloc(structSize);
		if(!!structReturnValue) return 0;
		ARG_PUSH((int)structReturnValue);
	}
	return 1;
}

/*  ffiReturnFloatValue:
	Return the value from a previous ffi call with float return type. */
double ffiReturnFloatValue(void)
{
	return floatReturnValue;
}

/*  ffiLongLongResultLow:
	Return the low 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultLow(void)
{
	return ((int*) &longReturnValue)[1];
}

/*  ffiLongLongResultHigh:
	Return the high 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultHigh(void)
{
	return ((int*) &longReturnValue)[0];
}

/*  ffiStoreStructure:
	Store the structure result of a previous ffi call into the given address. */
int ffiStoreStructure(int address, int structSize)
{
	if(structReturnValue) {
		memcpy((void*)address, (void*)structReturnValue, structSize);
	} else {
		memcpy((void*)address, (void*)&intReturnValue, structSize);
  	}
  	return 1;
}

/*  ffiCleanup:
	Cleanup after a foreign function call has completed.
	The generic support code only frees the temporarily
	allocated strings. */
int ffiCleanup(void)
{
	int i;
	for(i=0; i<ffiTempStringCount; i++)
		free(ffiTempStrings[i]);
	ffiTempStringCount = 0;
	if(structReturnValue) {
		free(structReturnValue);
		structReturnValue = NULL;
	}
	return 1;
}


/*****************************************************************************/
/*****************************************************************************/
asm int ffiCallAddressOf(int);

#if TARGET_CPU_PPC || GENERATINGPOWERPC
asm int ffiCallAddressOf(int addr) {
	/* Save link register */
	mflr r0
	stw r0, 8(SP)

	/* get stack index and preserve it for copying stuff later */
	lwz r4, ffiStackIndex(RTOC)

	/* compute frame size */
	rlwinm r5, r4, 2, 0, 29  /* ffiStackIndex words to bytes (e.g., "slwi r5, r4, 2") */
	addi r5, r5, 24 /* linkage area */
	neg  r5, r5     /* stack goes down */

	/* adjust stack frame */
	stwux SP, SP, r5

	/* load the stack frame area */
	/* note: r4 == ffiStackIndex */
	addi r5, SP, 24         /* dst = SP + linkage area */
	lwz r6, ffiStack(RTOC)  /* src = ffiStack */
	li r7, 0                /* i = 0 */
	b nextItem
copyItem:
	rlwinm r8, r7, 2, 0, 29 /* r8 = i << 2 (e.g., "slwi r8, r7, 2") */
	lwzx r0, r6, r8         /* r0 = ffiStack[r8] */
	addi r7, r7, 1          /* i = i + 1 */
	stwx r0, r5, r8         /* dst[r8] = r0 */
nextItem:
	cmpw r7, r4             /* i < ffiStackIndex ? */
	blt copyItem

	/* Keep addr in GPR0 so we can load all regs beforehand */
	mr r0, r3

	/* load all the floating point registers */
	lwz r3, fpRegCount
	lwz r12, FPRegs(RTOC)
	cmpwi r3, 0     /* skip all fpregs if no FP values used */
	blt _0_fpregs
	cmpwi r3, 8
	blt _7_fpregs   /* skip last N fpregs if unused */
_all_fpregs:
	lfd  fp8, 56(r12)
	lfd  fp9, 64(r12)
	lfd fp10, 72(r12)
	lfd fp11, 80(r12)
	lfd fp12, 88(r12)
	lfd fp13, 96(r12)
_7_fpregs:
	lfd  fp1,  0(r12)
	lfd  fp2,  8(r12)
	lfd  fp3, 16(r12)
	lfd  fp4, 24(r12)
	lfd  fp5, 32(r12)
	lfd  fp6, 40(r12)
	lfd  fp7, 48(r12)
_0_fpregs:

	/* load all the general purpose registers */
	lwz  r3, gpRegCount
	lwz  r12, GPRegs(RTOC)
	cmpwi r3, 4
	blt _4_gpregs    /* skip last four gpregs if unused */
_all_gpregs:
	lwz  r7, 16(r12)
	lwz  r8, 20(r12)
	lwz  r9, 24(r12)
	lwz r10, 28(r12)
_4_gpregs:
	lwz  r3,  0(r12)
	lwz  r4,  4(r12)
	lwz  r5,  8(r12)
	lwz  r6, 12(r12)
_0_gpregs:

	/* go calling out */
	mr r12, r0      /* tvector into GPR12 */
	/* Note: The code below is nearly identical to to what''s described in
		"MacOS Runtime Architectures"
		Chapter 2, Listing 2-2, pp. 2-11
	*/
	lwz r0, 0(r12)  /* get entry point */
	stw r2, 20(SP)  /* save GPR2 */
	mtctr r0        /* move entry point into count register */
	lwz r2, 4(r12)  /* new base pointer */
	bctrl           /* jump through count register and link */
	lwz r2, 20(SP)  /* restore GPR2 */
	lwz SP, 0(SP)   /* restore frame */

	/* store the result of the call */
	stw r3, intReturnValue(RTOC)
	lwz r12, longReturnValue(RTOC)
	stw r3, 0(r12)
	stw r4, 4(r12)
	stfd fp1, floatReturnValue(RTOC)

	/* and get out of here */
	lwz r0, 8(SP)
	mtlr r0
	blr
}
#else
asm int ffiCallAddressOf(int addr) {
}
#endif

int ffiCallAddressOfWithPointerReturn(int fn, int callType)
{
	return ffiCallAddressOf(fn);
}
int ffiCallAddressOfWithStructReturn(int fn, int callType, int* structSpec, int specSize)
{
	return ffiCallAddressOf(fn);
}

int ffiCallAddressOfWithReturnType(int fn, int callType, int typeSpec)
{
	return ffiCallAddressOf(fn);
}

/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
/************ Test functions for the foreign function interface **************/
/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
#ifndef NO_FFI_TEST
typedef struct ffiTestPoint2 {
	int x;
	int y;
} ffiTestPoint2;

typedef struct ffiTestPoint4 {
	int x;
	int y;
	int z;
	int w;
} ffiTestPoint4;

#pragma export on
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4);
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4);
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4);
EXPORT(float) ffiTestFloats(float f1, float f2);
EXPORT(double) ffiTestDoubles(double d1, double d2);
EXPORT(char *) ffiPrintString(char *string);
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2);
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2);
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2);
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2);
#pragma export off


/* test passing characters */
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4) {
	printf("4 characters came in as\nc1 = %c (%x)\nc2 = %c (%x)\nc3 = %c (%x)\nc4 = %c (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return ''C'';
}

/* test passing shorts */
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4) {
	printf("4 shorts came in as\ns1 = %d (%x)\ns2 = %d (%x)\ns3 = %d (%x)\ns4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return -42;
}

/* test passing ints */
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4) {
	printf("4 ints came in as\ni1 = %d (%x)\ni2 = %d (%x)\ni3 = %d (%x)\ni4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return 42;
}

/* test passing and returning floats */
EXPORT(float) ffiTestFloats(float f1, float f2) {
	printf("The two floats are %f and %f\n", f1, f2);
	return (float) (f1 + f2);
}

/* test passing and returning doubles */
EXPORT(double) ffiTestDoubles(double d1, double d2) {
	printf("The two floats are %f and %f\n", (float)d1, (float)d2);
	return d1+d2;
}

/* test passing and returning strings */
EXPORT(char*) ffiPrintString(char *string) {
	printf("%s\n", string);
	return string;
}

/* test passing and returning 64bit structures */
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2) {
	ffiTestPoint2 result;
	printf("pt1.x = %d\npt1.y = %d\npt2.x = %d\npt2.y = %d\n",
			pt1.x, pt1.y, pt2.x, pt2.y);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	return result;
}

/* test passing and returning large structures */
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2) {
	ffiTestPoint4 result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1.x, pt1.y, pt1.z, pt1.w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2.x, pt2.y, pt2.z, pt2.w);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	result.z = pt1.z + pt2.z;
	result.w = pt1.w + pt2.w;
	return result;
}

/* test passing and returning pointers */
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2) {
	ffiTestPoint4 *result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1->x, pt1->y, pt1->z, pt1->w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2->x, pt2->y, pt2->z, pt2->w);
	result = (ffiTestPoint4*) malloc(sizeof(ffiTestPoint4));
	result->x = pt1->x + pt2->x;
	result->y = pt1->y + pt2->y;
	result->z = pt1->z + pt2->z;
	result->w = pt1->w + pt2->w;
	return result;
}

/* test passing and returning longlongs */
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2) {
	return i1 + i2;
}

#endif /* NO_FFI_TEST */
'! !

!FFIPlugin class methodsFor: 'C support code' stamp: 'ar 1/26/2000 14:29'!
sqUnixFFIFile
^'/****************************************************************************
*   PROJECT: Squeak foreign function interface
*   FILE:    sqUnixFFI.c
*   CONTENT: Unix support for the foreign function interface
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:  The Unix version of the FFI support code relies on libffi from
*	    http://sourceware.cygnus.com/libffi/
*
*****************************************************************************/
#include "sq.h"
#include "sqFFI.h"

#ifndef NO_FFI_SUPPORT

#include <ffi.h>

extern struct VirtualMachine *interpreterProxy;
#define primitiveFail() interpreterProxy->primitiveFail()

#if 1
#define HAVE_LONGLONG
#endif

/* Check if HAVE_LONGLONG is defined (should be figured out by configure */
#ifdef HAVE_LONGLONG
#define HAS_LONGLONG 1
#define LONGLONG long long
#endif

/* Error if LONGLONG is not defined */
#if HAS_LONGLONG
#ifndef LONGLONG
#error "You must define LONGLONG if HAS_LONGLONG is defined"
#endif
#endif

/* Max number of arguments in call */
#define FFI_MAX_ARGS 32

static ffi_type*  ffiTypes[FFI_MAX_ARGS];
static void*      ffiArgs[FFI_MAX_ARGS];

static char   ffiBytes[FFI_MAX_ARGS];
static short  ffiShorts[FFI_MAX_ARGS];
static int    ffiInts[FFI_MAX_ARGS];
static float  ffiFloats[FFI_MAX_ARGS];
static double ffiDoubles[FFI_MAX_ARGS];
static int    ffiArgIndex = 0;

static ffi_type*  ffiStructTypes[FFI_MAX_ARGS];
static int ffiStructIndex = 0;

/* helpers */
#define CHECK_ARGS() if(ffiArgIndex >= FFI_MAX_ARGS) return primitiveFail();
#define PUSH_TYPE(type) { CHECK_ARGS(); ffiTypes[ffiArgIndex] = &type; }
#define PUSH(where, what, type) { \
	PUSH_TYPE(type); where[ffiArgIndex] = what; \
	ffiArgs[ffiArgIndex] = (void*) (where + ffiArgIndex); \
	ffiArgIndex++;\
}


#define BARG_PUSH(value, type) PUSH(ffiBytes, value, type)
#define SARG_PUSH(value, type) PUSH(ffiShorts, value, type)
#define IARG_PUSH(value, type) PUSH(ffiInts, value, type)
#define FARG_PUSH(value) PUSH(ffiFloats, value, ffi_type_float)
#define DARG_PUSH(value) PUSH(ffiDoubles, value, ffi_type_double)

#if HAS_LONGLONG
static LONGLONG ffiLongLongs[FFI_MAX_ARGS];
#define LARG_PUSH(value, type) PUSH(ffiLongLongs, value, type)
#endif

/* The 64bit return value storage area - aligned by the C compiler */
static double   returnValue;
/* Storage area for large structure returns */
static ffi_type* structReturnType = NULL;
static void *structReturnValue = NULL;

/* The area for temporarily allocated strings */
static char *ffiTempStrings[FFI_MAX_ARGS];
/* The number of temporarily allocated strings */
static int   ffiTempStringCount = 0;

/*****************************************************************************/
/*****************************************************************************/

/*  ffiInitialize:
    Announce that the VM is about to do an external function call. */
int ffiInitialize(void)
{
  ffiArgIndex = 0;
  ffiTempStringCount = 0;
  ffiStructIndex = 0;
  structReturnType = NULL;
  structReturnValue = NULL;
  return 1;
}

/*  ffiSupportsCallingConvention:
    Return true if the support code supports the given calling convention */
int ffiSupportsCallingConvention(int callType)
{
  if(callType == FFICallTypeCDecl) return 1;
  return 0;
}

/*  ffiAlloc:
    Allocate space from the external heap */
int ffiAlloc(int byteSize)
{
  return (int)malloc(byteSize);
}
/*  ffiFree:
    Free space from the external heap */
int ffiFree(int pointer)
{
  if(pointer) free((void*)pointer);
  return 1;
}

/*****************************************************************************/
/*****************************************************************************/

int ffiPushSignedByte(int value)
{
  BARG_PUSH((char)value, ffi_type_sint8);
  return 1;
}

int ffiPushUnsignedByte(int value)
{
  BARG_PUSH((char)value, ffi_type_uint8);
  return 1;
}

int ffiPushSignedShort(int value)
{
  SARG_PUSH((short)value, ffi_type_sint16);
  return 1;
}

int ffiPushUnsignedShort(int value)
{
  SARG_PUSH((short)value, ffi_type_uint16);
  return 1;
}

int ffiPushSignedInt(int value)
{
  IARG_PUSH(value, ffi_type_sint32);
  return 1;
}

int ffiPushUnsignedInt(int value)
{
  IARG_PUSH(value, ffi_type_uint32);
  return 1;
}

int ffiPushSignedLongLong(int low, int high)
{
#if HAS_LONGLONG
  LONGLONG value = (((LONGLONG) high) << 32)  | ((LONGLONG) (unsigned) low);
  LARG_PUSH(value, ffi_type_sint64);
  return 1;
#else
  return primitiveFail();
#endif
}

int ffiPushUnsignedLongLong(int low, int high)
{
#if HAS_LONGLONG
  LONGLONG value = (((LONGLONG) high) << 32)  | ((LONGLONG) (unsigned) low);
  LARG_PUSH(value, ffi_type_uint64);
  return 1;
#else
  return primitiveFail();
#endif
}

int ffiPushSignedChar(int value)
{
  BARG_PUSH(value, ffi_type_sint8);
  return 1;
}

int ffiPushUnsignedChar(int value)
{
  BARG_PUSH(value, ffi_type_uint8);
  return 1;
}

int ffiPushBool(int value)
{
  IARG_PUSH(value, ffi_type_uint8);
  return 1;
}

int ffiPushSingleFloat(double value)
{
  FARG_PUSH((float)value);
  return 1;
}

int ffiPushDoubleFloat(double value)
{
  DARG_PUSH(value);
  return 1;
}


ffi_type* ffiCreateType(int *structSpec, int structSize)
{
  ffi_type *structType, **newTypes;
  int nTypes, i, typeSpec;

  /* count the number of atomic types we need to create */
  nTypes = 0;
  for(i=0; i<structSize; i++) {
    typeSpec = structSpec[i];
    if(typeSpec & FFIFlagPointer) nTypes++;
    else if(typeSpec & FFIFlagAtomic) nTypes++;
  }
  /* note: nTypes == 0 means an invalid structure */
  if(nTypes == 0) {
    printf("Warning: nTypes == 0 in ffiCreateTypes\n");
    return NULL;
  }
  /* allocate the structure type */
  structType = calloc(1, sizeof(ffi_type));
  /* allocate the atomic type refs */
  newTypes = calloc(nTypes+1, sizeof(ffi_type*));
  /* number of elements in type */
  structType->size = (*structSpec) & FFIStructSizeMask;
  structType->alignment = 4;
  structType->type = FFI_TYPE_STRUCT;
  structType->elements = newTypes;

  /* now go over the structure and fill in the fields */
  nTypes = 0;
  for(i=0; i<structSize; i++) {
    typeSpec = structSpec[i];
    if(typeSpec & FFIFlagPointer) {
      newTypes[nTypes++] = &ffi_type_pointer;
      continue;
    }
    if((typeSpec & FFIFlagAtomic) == 0) continue;
    switch((typeSpec & FFIAtomicTypeMask) >> FFIAtomicTypeShift) {
    case FFITypeBool:
      newTypes[nTypes++] = &ffi_type_uint8; break;
    case FFITypeUnsignedByte:
      newTypes[nTypes++] = &ffi_type_uint8; break;
    case FFITypeSignedByte:
      newTypes[nTypes++] = &ffi_type_sint8; break;
    case FFITypeUnsignedShort:
      newTypes[nTypes++] = &ffi_type_uint16; break;
    case FFITypeSignedShort:
      newTypes[nTypes++] = &ffi_type_sint16; break;
    case FFITypeUnsignedInt:
      newTypes[nTypes++] = &ffi_type_uint32; break;
    case FFITypeSignedInt:
      newTypes[nTypes++] = &ffi_type_sint32; break;
    case FFITypeUnsignedLongLong:
      newTypes[nTypes++] = &ffi_type_uint64; break;
    case FFITypeSignedLongLong:
      newTypes[nTypes++] = &ffi_type_sint64; break;
    case FFITypeUnsignedChar:
      newTypes[nTypes++] = &ffi_type_uint8; break;
    case FFITypeSignedChar:
      newTypes[nTypes++] = &ffi_type_sint8; break;
    case FFITypeSingleFloat:
      newTypes[nTypes++] = &ffi_type_float; break;
    case FFITypeDoubleFloat:
      newTypes[nTypes++] = &ffi_type_double; break;
    default:
      printf("Warning: unknown atomic type (%x) in ffiCreateTypes\n", 
	     typeSpec);
      free(newTypes);
      free(structType);
      return NULL;
    };
  }
  newTypes[nTypes++] = NULL;
  return structType;
}

int ffiPushStructureOfLength(int pointer, int* structSpec, int structSize)
{
  ffi_type *structType;

  if(pointer == 0) return primitiveFail();
  CHECK_ARGS(); /* fail early on */
  structType = ffiCreateType(structSpec, structSize);
  if(structType == NULL) return primitiveFail();
  ffiStructTypes[ffiStructIndex++] = structType;
  ffiTypes[ffiArgIndex] = structType;
  ffiArgs[ffiArgIndex] = (void*) pointer;
  ffiArgIndex++;
  return 1;
}

int ffiPushPointer(int pointer)
{
  IARG_PUSH(pointer, ffi_type_pointer);
  return 1;
}

int ffiPushStringOfLength(int srcIndex, int length)
{
  char *ptr;
  ptr = (char*) malloc(length+1);
  if(!!ptr) return primitiveFail();
  memcpy(ptr, (void*)srcIndex, length);
  ptr[length] = 0;
  ffiTempStrings[ffiTempStringCount++] = ptr;
  IARG_PUSH((int)ptr, ffi_type_pointer);
  return 1;
}

/*****************************************************************************/
/*****************************************************************************/

/*  ffiCanReturn:
	Return true if the support code can return the given type. */
int ffiCanReturn(int *structSpec, int specSize)
{
  int header = *structSpec;
  if(header & FFIFlagPointer) return 1;
  if(header & FFIFlagStructure) {
    int structSize = header & FFIStructSizeMask;
    structReturnType = ffiCreateType(structSpec, specSize);
    if(!!structReturnType) return 0;
    if(structSize > 8) {
      structReturnValue = calloc(1,structSize);
      if(!!structReturnValue) return 0;
      return 1;
    }
  }
  return 1;
}

/*  ffiReturnFloatValue:
    Return the value from a previous ffi call with float return type. */
double ffiReturnFloatValue(void)
{
  return returnValue;
}

/*  ffiLongLongResultLow:
    Return the low 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultLow(void)
{
#if HAS_LONGLONG
  return (int) ( (*(LONGLONG*)&returnValue) & (LONGLONG)0xFFFFFFFFU);
#else
  return 0;
#endif
}

/*  ffiLongLongResultHigh:
    Return the high 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultHigh(void)
{
#if HAS_LONGLONG
  return (int) ( (*(LONGLONG*)&returnValue) >> 32);
#else
  return 0;
#endif
}

/*  ffiStoreStructure:
    Store the structure result of a previous ffi call into the given address*/
int ffiStoreStructure(int address, int structSize)
{
  if(structReturnValue) {
    memcpy((void*)address, (void*)structReturnValue, structSize);
  } else {
    memcpy((void*)address, (void*)&returnValue, structSize);
  }
  return 1;
}

/*  ffiCleanup:
    Cleanup after a foreign function call has completed.
    The generic support code only frees the temporarily
    allocated strings. */
int ffiCleanup(void)
{
  int i;
  for(i=0; i<ffiTempStringCount; i++)
    free(ffiTempStrings[i]);
  for(i=0; i<ffiStructIndex; i++) {
    free(ffiStructTypes[i]->elements);
    free(ffiStructTypes[i]);
    ffiStructTypes[i]=NULL;
  }
  if(structReturnType) {
    free(structReturnType->elements);
    free(structReturnType);
    structReturnType = NULL;
  }
  if(structReturnValue) {
    free(structReturnValue);
    structReturnValue = NULL;
  }
  ffiTempStringCount = 0;
  ffiStructIndex = 0;
  return 1;
}

/*****************************************************************************/
/*****************************************************************************/
int ffiCallAddress(int fn, ffi_type *returnType, int atomicArgType)
{
  ffi_cif cif;
  ffi_status result;
  int retVal;

  result = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, ffiArgIndex, 
			returnType, ffiTypes);
  if(result !!= FFI_OK) return primitiveFail();
  if(structReturnValue) {
    ffi_call(&cif, (void *)fn, (void *)structReturnValue, (void **)ffiArgs);
    return (int) structReturnValue;
  }
  ffi_call(&cif, (void *)fn, (void *)&returnValue, (void **)ffiArgs);
  retVal = *(int*)&returnValue;
#ifdef FFI_MIPS_N32
  /* Note: MIPS N32 ABI returns 64bit for integer/pointer whatever.
     This seems to be a bug in the fficall implementation. */
  retVal = ((int*)(&returnValue))[1];
#endif
  /* Promote certain return types to integral size */
  switch(atomicArgType) {
  case FFITypeUnsignedChar:
  case FFITypeUnsignedByte: retVal = *(unsigned char*) &retVal; break;
  case FFITypeSignedChar:
  case FFITypeSignedByte: retVal = *(signed char*) &retVal; break;
  case FFITypeUnsignedShort: retVal = *(unsigned short*) &retVal; break;
  case FFITypeSignedShort: retVal = *(signed short*) &retVal; break;
  case FFITypeSingleFloat: returnValue = *(float*)&returnValue; break;
  }
  return retVal;
}

int ffiCallAddressOfWithPointerReturn(int fn, int callType)
{
  return ffiCallAddress(fn, &ffi_type_pointer,-1);
}

int ffiCallAddressOfWithStructReturn(int fn, int callType, 
				     int *structSpec, int specSize)
{
  if(!!structReturnType) return primitiveFail();
  return ffiCallAddress(fn, structReturnType,-1);
}

int ffiCallAddressOfWithReturnType(int fn, int callType, int typeSpec)
{
  ffi_type *returnType;
  int atomicType;
  atomicType = (typeSpec & FFIAtomicTypeMask) >> FFIAtomicTypeShift;
  switch(atomicType) {
  case FFITypeVoid:		returnType = &ffi_type_void; break;
  case FFITypeBool:		returnType = &ffi_type_uint8; break;
  case FFITypeUnsignedByte:	returnType = &ffi_type_uint8; break;
  case FFITypeSignedByte:	returnType = &ffi_type_sint8; break;
  case FFITypeUnsignedShort:	returnType = &ffi_type_uint16; break;
  case FFITypeSignedShort:	returnType = &ffi_type_sint16; break;
  case FFITypeUnsignedInt:	returnType = &ffi_type_uint32; break;
  case FFITypeSignedInt:       	returnType = &ffi_type_sint32; break;
  case FFITypeUnsignedLongLong: returnType = &ffi_type_uint64; break;
  case FFITypeSignedLongLong:	returnType = &ffi_type_sint64; break;
  case FFITypeUnsignedChar:	returnType = &ffi_type_uint8; break;
  case FFITypeSignedChar:      	returnType = &ffi_type_sint8; break;
  case FFITypeSingleFloat:	returnType = &ffi_type_float; break;
  case FFITypeDoubleFloat:	returnType = &ffi_type_double; break;
  default:
    return primitiveFail();
  }
  return ffiCallAddress(fn, returnType, atomicType);
}

#endif /* NO_FFI_SUPPORT */

/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
/************ Test functions for the foreign function interface **************/
/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
#ifndef NO_FFI_TEST
typedef struct ffiTestPoint2 {
	int x;
	int y;
} ffiTestPoint2;

typedef struct ffiTestPoint4 {
	int x;
	int y;
	int z;
	int w;
} ffiTestPoint4;

typedef struct ffiTestPointMix {
  int x;
  double y;
  int z;
  double w;
} ffiTestPointMix;

#pragma export on
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4);
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4);
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4);
EXPORT(float) ffiTestFloats(float f1, float f2);
EXPORT(double) ffiTestDoubles(double d1, double d2);
EXPORT(char *) ffiPrintString(char *string);
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2);
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2);
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2);
EXPORT(ffiTestPointMix) ffiTestStructMix(ffiTestPointMix pt1, 
					 ffiTestPointMix pt2);
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2);
#pragma export off


/* test passing characters */
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4) {
	printf("4 characters came in as\nc1 = %c (%x)\nc2 = %c (%x)\nc3 = %c (%x)\nc4 = %c (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return ''C'';
}

/* test passing shorts */
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4) {
	printf("4 shorts came in as\ns1 = %d (%x)\ns2 = %d (%x)\ns3 = %d (%x)\ns4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return -42;
}

/* test passing ints */
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4) {
	printf("4 ints came in as\ni1 = %d (%x)\ni2 = %d (%x)\ni3 = %d (%x)\ni4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return 42;
}

/* test passing and returning floats */
EXPORT(float) ffiTestFloats(float f1, float f2) {
	printf("The two floats are %f and %f\n", f1, f2);
	return (float) (f1 + f2);
}

/* test passing and returning doubles */
EXPORT(double) ffiTestDoubles(double d1, double d2) {
	printf("The two floats are %f and %f\n", (float)d1, (float)d2);
	return d1+d2;
}

/* test passing and returning strings */
EXPORT(char*) ffiPrintString(char *string) {
	printf("%s\n", string);
	return string;
}

/* test passing and returning 64bit structures */
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2) {
	ffiTestPoint2 result;
	printf("pt1.x = %d\npt1.y = %d\npt2.x = %d\npt2.y = %d\n",
			pt1.x, pt1.y, pt2.x, pt2.y);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	return result;
}

/* test passing and returning large structures */
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2) {
	ffiTestPoint4 result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1.x, pt1.y, pt1.z, pt1.w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2.x, pt2.y, pt2.z, pt2.w);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	result.z = pt1.z + pt2.z;
	result.w = pt1.w + pt2.w;
	return result;
}

/* test passing and returning pointers */
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2) {
	ffiTestPoint4 *result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1->x, pt1->y, pt1->z, pt1->w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2->x, pt2->y, pt2->z, pt2->w);
	result = (ffiTestPoint4*) malloc(sizeof(ffiTestPoint4));
	result->x = pt1->x + pt2->x;
	result->y = pt1->y + pt2->y;
	result->z = pt1->z + pt2->z;
	result->w = pt1->w + pt2->w;
	return result;
}

/* test passing and returning longlongs */
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2) {
	return i1 + i2;
}

#endif /* NO_FFI_TEST */
'! !

!FFIPlugin class methodsFor: 'C support code' stamp: 'ar 5/14/2000 20:25'!
sqWin32FFIFile
^'/****************************************************************************
*   PROJECT: Squeak foreign function interface
*   FILE:    sqWin32FFI.c
*   CONTENT: Win32 support for the foreign function interface
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   andreasr@wdi.disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*****************************************************************************/
#include "sq.h"
#include "sqFFI.h"

extern struct VirtualMachine *interpreterProxy;
#define primitiveFail() interpreterProxy->primitiveFail();

#ifdef _MSC_VER
#define LONGLONG __int64
#endif
#ifdef __GNUC__
#define LONGLONG long long int
#endif

/* Max stack size */
#define FFI_MAX_ARGS 128
/* The stack used to assemble the arguments for a call */
static int   ffiArgs[FFI_MAX_ARGS];
/* The stack pointer while filling the stack */
static int   ffiArgIndex = 0;
/* The area for temporarily allocated strings */
static char *ffiTempStrings[FFI_MAX_ARGS];
/* The number of temporarily allocated strings */
static int   ffiTempStringCount = 0;

/* The return values for calls */
volatile static int      intReturnValue;
volatile static int      intReturnValue2;
volatile static double   floatReturnValue;
static void*    structReturnValue;

#define ARG_CHECK() if(ffiArgIndex >= FFI_MAX_ARGS) return primitiveFail();
#define ARG_PUSH(value) { ARG_CHECK(); ffiArgs[ffiArgIndex++] = value; }

/*****************************************************************************/
/*****************************************************************************/

/*  ffiInitialize:
	Announce that the VM is about to do an external function call. */
int ffiInitialize(void)
{
	ffiArgIndex = 0;
	ffiTempStringCount = 0;
	return 1;
}

/*  ffiSupportsCallingConvention:
	Return true if the support code supports the given calling convention. */
int ffiSupportsCallingConvention(int callType)
{
	if(callType == FFICallTypeCDecl) return 1;
	if(callType == FFICallTypeApi) return 1;
	return 0;
}

int ffiAlloc(int byteSize)
{
	return (int) malloc(byteSize);
}

int ffiFree(int ptr)
{
	if(ptr) free((void*)ptr);
	return 1;
}

/*****************************************************************************/
/*****************************************************************************/

int ffiPushSignedChar(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedChar(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedByte(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedByte(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedShort(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedShort(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedInt(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushUnsignedInt(int value) 
{ 
	ARG_PUSH(value); 
	return 1; 
}

int ffiPushSignedLongLong(int lowWord, int highWord) 
{ 
	ARG_PUSH(lowWord); 
	ARG_PUSH(highWord); 
	return 1; 
}

int ffiPushUnsignedLongLong(int lowWord, int highWord) 
{ 
	ARG_PUSH(lowWord); 
	ARG_PUSH(highWord); 
	return 1; 
}

int ffiPushSingleFloat(double value)
{
	float floatValue;
	floatValue = (float) value;
	ARG_PUSH(*(int*)(&floatValue));
	return 1;
}

int ffiPushDoubleFloat(double value)
{
	ARG_PUSH(((int*)(&value))[0]);
	ARG_PUSH(((int*)(&value))[1]);
	return 1;
}

int ffiPushStructureOfLength(int pointer, int* structSpec, int structSize)
{
	int nItems, i;
	nItems = ((*structSpec & FFIStructSizeMask) + 3) / 4;
	if(pointer == 0) 
		return primitiveFail();
	for(i=0; i < nItems;i++)
		ARG_PUSH(((int*)pointer)[i]);
	return 1;
}

int ffiPushPointer(int pointer)
{
	ARG_PUSH(pointer);
	return 1;
}

int ffiPushStringOfLength(int srcIndex, int length)
{
	char *ptr;
	ARG_CHECK(); /* fail before allocating */
	ptr = (char*) malloc(length+1);
	if(!!ptr) return primitiveFail();
	memcpy(ptr, (void*)srcIndex, length);
	ptr[length] = 0;
	ffiTempStrings[ffiTempStringCount++] = ptr;
	ARG_PUSH((int)ptr);
	return 1;
}

/*****************************************************************************/
/*****************************************************************************/

/*  ffiCanReturn:
	Return true if the support code can return the given type. */
int ffiCanReturn(int *structSpec, int specSize)
{
	int header = *structSpec;
	if(header & FFIFlagPointer) return 1;
	if(header & FFIFlagStructure) {
		int structSize = header & FFIStructSizeMask;
		if(structSize > 8) {
			structReturnValue = malloc(structSize);
			if(!!structReturnValue) return 0;
			ARG_PUSH((int)structReturnValue);
		}
	}
	return 1;
}

/*  ffiReturnFloatValue:
	Return the value from a previous ffi call with float return type. */
double ffiReturnFloatValue(void)
{
	return floatReturnValue;
}

/*  ffiLongLongResultLow:
	Return the low 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultLow(void)
{
	return intReturnValue;
}

/*  ffiLongLongResultHigh:
	Return the high 32bit from the 64bit result of a call to an external function */
int ffiLongLongResultHigh(void)
{
	return intReturnValue2;
}

/*  ffiStoreStructure:
	Store the structure result of a previous ffi call into the given address.
	Note: Since the ST allocator always allocates multiples of 32bit we can
	use the atomic types for storing <= 64bit result structures. */
int ffiStoreStructure(int address, int structSize)
{
	if(structSize <= 4) {
		*(int*)address = intReturnValue;
		return 1;
	}
	if(structSize <= 8) {
		*(int*)address = intReturnValue;
		*(int*)(address+4) = intReturnValue2;
		return 1;
	}
	/* assume pointer to hidden structure */
	memcpy((void*)address, (void*) structReturnValue, structSize);
	return 1;
}

/*  ffiCleanup:
	Cleanup after a foreign function call has completed. */
int ffiCleanup(void)
{
	int i;
	for(i=0; i<ffiTempStringCount; i++)
		free(ffiTempStrings[i]);
	ffiTempStringCount = 0;
	if(structReturnValue) {
		free(structReturnValue);
		structReturnValue = NULL;
	}
	return 1;
}

/*****************************************************************************/
/*****************************************************************************/

/*  ffiCallAddress:
	Perform the actual function call. */
int ffiCallAddress(int fn)
{
#ifdef _MSC_VER
	__asm {
		push ebx
		mov ebx, fn
		push ecx
		push edx
		push edi
		push esi
		push ebp
		/* mark the frame */
		mov ebp, esp
		/* alloca() ffiStackIndex size bytes */
		mov ecx, ffiArgIndex
		shl ecx, 2
		sub esp, ecx
		/* copy stack */
		mov edi, esp
		lea esi, ffiArgs
		shr ecx, 2
		cld
		rep movsd
		/* go calling */
		call ebx
		/* restore frame */
		mov esp, ebp
		/* store the return values */
		mov intReturnValue, eax
		mov intReturnValue2, edx
		fstp floatReturnValue
		/* restore register values */
		pop ebp
		pop esi
		pop edi
		pop edx
		pop ecx
		pop ebx
		/* done */
	}
#endif
#ifdef __GNUC__
	asm("
		pushl %%ebx;
		pushl %%ecx;
		pushl %%edx;
		pushl %%edi;
		pushl %%esi;
		pushl %%ebp;
		/* mark the frame */
		movl %%esp, %%ebp
		/* alloca() ffiStackIndex size bytes */
		movl _ffiArgIndex, %%ecx;
		shll $2, %%ecx;
		subl %%ecx, %%esp
		/* copy stack */
		movl %%esp, %%edi;
		leal _ffiArgs, %%esi;
		shrl $2, %%ecx;
		cld;
		rep movsl;
		/* go calling */
		call *%%ebx
		/* restore frame */
		movl %%ebp, %%esp
		/* store the return values */
		movl %%eax, _intReturnValue
		movl %%edx, _intReturnValue2
		fstpl _floatReturnValue
		/* restore register values */
		popl %%ebp
		popl %%esi
		popl %%edi
		popl %%edx
		popl %%ecx
		popl %%ebx
		": /* no outputs */ : "ebx" (fn) : "eax" /* clobbered registers */);
		/* done */
#endif
	return intReturnValue;
}

int ffiCallAddressOfWithPointerReturn(int fn, int callType)
{
	return ffiCallAddress(fn);
}
int ffiCallAddressOfWithStructReturn(int fn, int callType, int* structSpec, int specSize)
{
	return ffiCallAddress(fn);
}

int ffiCallAddressOfWithReturnType(int fn, int callType, int typeSpec)
{
	return ffiCallAddress(fn);
}

/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
/************ Test functions for the foreign function interface **************/
/*****************************************************************************/
/*****************************************************************************/
/*****************************************************************************/
#ifndef NO_FFI_TEST
typedef struct ffiTestPoint2 {
	int x;
	int y;
} ffiTestPoint2;

typedef struct ffiTestPoint4 {
	int x;
	int y;
	int z;
	int w;
} ffiTestPoint4;

#pragma export on
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4);
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4);
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4);
EXPORT(float) ffiTestFloats(float f1, float f2);
EXPORT(double) ffiTestDoubles(double d1, double d2);
EXPORT(char *) ffiPrintString(char *string);
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2);
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2);
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2);
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2);
#pragma export off


/* test passing characters */
EXPORT(char) ffiTestChars(char c1, char c2, char c3, char c4) {
	printf("4 characters came in as\nc1 = %c (%x)\nc2 = %c (%x)\nc3 = %c (%x)\nc4 = %c (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return c1+c2;
}

/* test passing shorts */
EXPORT(short) ffiTestShorts(short c1, short c2, short c3, short c4) {
	printf("4 shorts came in as\ns1 = %d (%x)\ns2 = %d (%x)\ns3 = %d (%x)\ns4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return c1+c2;
}

/* test passing ints */
EXPORT(int) ffiTestInts(int c1, int c2, int c3, int c4) {
	printf("4 ints came in as\ni1 = %d (%x)\ni2 = %d (%x)\ni3 = %d (%x)\ni4 = %d (%x)\n", c1, c1, c2, c2, c3, c3, c4, c4);
	return c1+c2;
}

/* test passing and returning floats */
EXPORT(float) ffiTestFloats(float f1, float f2) {
	printf("The two floats are %f and %f\n", f1, f2);
	return (float) (f1 + f2);
}

/* test passing and returning doubles */
EXPORT(double) ffiTestDoubles(double d1, double d2) {
	printf("The two floats are %f and %f\n", (float)d1, (float)d2);
	return d1+d2;
}

/* test passing and returning strings */
EXPORT(char*) ffiPrintString(char *string) {
	printf("%s\n", string);
	return string;
}

/* test passing and returning 64bit structures */
EXPORT(ffiTestPoint2) ffiTestStruct64(ffiTestPoint2 pt1, ffiTestPoint2 pt2) {
	ffiTestPoint2 result;
	printf("pt1.x = %d\npt1.y = %d\npt2.x = %d\npt2.y = %d\n",
			pt1.x, pt1.y, pt2.x, pt2.y);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	return result;
}

/* test passing and returning large structures */
EXPORT(ffiTestPoint4) ffiTestStructBig(ffiTestPoint4 pt1, ffiTestPoint4 pt2) {
	ffiTestPoint4 result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1.x, pt1.y, pt1.z, pt1.w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2.x, pt2.y, pt2.z, pt2.w);
	result.x = pt1.x + pt2.x;
	result.y = pt1.y + pt2.y;
	result.z = pt1.z + pt2.z;
	result.w = pt1.w + pt2.w;
	return result;
}

/* test passing and returning pointers */
EXPORT(ffiTestPoint4*) ffiTestPointers(ffiTestPoint4 *pt1, ffiTestPoint4 *pt2) {
	ffiTestPoint4 *result;
	printf("pt1.x = %d\npt1.y = %d\npt1.z = %d\npt1.w = %d\n",
			pt1->x, pt1->y, pt1->z, pt1->w);
	printf("pt2.x = %d\npt2.y = %d\npt2.z = %d\npt2.w = %d\n",
			pt2->x, pt2->y, pt2->z, pt2->w);
	result = (ffiTestPoint4*) malloc(sizeof(ffiTestPoint4));
	result->x = pt1->x + pt2->x;
	result->y = pt1->y + pt2->y;
	result->z = pt1->z + pt2->z;
	result->w = pt1->w + pt2->w;
	return result;
}

/* test passing and returning longlongs */
EXPORT(LONGLONG) ffiTestLongLong(LONGLONG i1, LONGLONG i2) {
	return i1 + i2;
}

#endif /* NO_FFI_TEST */
'! !

!FFIPlugin class methodsFor: 'C support code' stamp: 'ar 1/26/2000 15:12'!
writeSupportFiles
	"FFIPlugin writeSupportFiles"
	InterpreterSupportCode
		storeString: self sqFFIHeaderFile onFileNamed:'sqFFI.h';
		storeString: self sqMacFFIPPCFile onFileNamed:'sqMacFFIPPC.c';
		storeString: self sqUnixFFIFile onFileNamed:'sqUnixFFI.c';
		storeString: self sqWin32FFIFile onFileNamed:'sqWin32FFI.c'.! !
ExternalStructure subclass: #FFITestPoint2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Plugin'!

!FFITestPoint2 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:42'!
x
	"This method was automatically generated"
	^handle signedLongAt: 1! !

!FFITestPoint2 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:42'!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: 1 put: anObject! !

!FFITestPoint2 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:42'!
y
	"This method was automatically generated"
	^handle signedLongAt: 5! !

!FFITestPoint2 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:42'!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: 5 put: anObject! !

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

FFITestPoint2 class
	instanceVariableNames: ''!

!FFITestPoint2 class methodsFor: 'field definition' stamp: 'ar 12/1/1999 16:42'!
fields
	"FFITestPoint2 defineFields"
	^#(
		(x	'long')
		(y	'long')
	)! !
ExternalStructure subclass: #FFITestPoint4
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Plugin'!

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
w
	"This method was automatically generated"
	^handle signedLongAt: 13! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
w: anObject
	"This method was automatically generated"
	handle signedLongAt: 13 put: anObject! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
x
	"This method was automatically generated"
	^handle signedLongAt: 1! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: 1 put: anObject! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
y
	"This method was automatically generated"
	^handle signedLongAt: 5! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: 5 put: anObject! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
z
	"This method was automatically generated"
	^handle signedLongAt: 9! !

!FFITestPoint4 methodsFor: 'accessing' stamp: 'ar 12/1/1999 16:41'!
z: anObject
	"This method was automatically generated"
	handle signedLongAt: 9 put: anObject! !

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

FFITestPoint4 class
	instanceVariableNames: ''!

!FFITestPoint4 class methodsFor: 'field definition' stamp: 'ar 12/1/1999 16:41'!
fields
	"FFITestPoint4 defineFields"
	^#(
		(x	'long')
		(y	'long')
		(z	'long')
		(w	'long')
	)! !
ExternalLibrary subclass: #FFITester
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Plugin'!

!FFITester methodsFor: 'primitives' stamp: 'ar 11/19/1999 20:37'!
ffiPrintString: aString
	"FFITester ffiPrintString: 'Hello'"
	<cdecl: char* 'ffiPrintString' (char *)>
	^self externalCallFailed! !

!FFITester methodsFor: 'primitives' stamp: 'ar 11/20/1999 23:41'!
ffiTestChar: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestChar: $A with: 65 with: 65.0 with: true"
	<cdecl: char 'ffiTestChars' (char char char char)>
	^self externalCallFailed! !

!FFITester methodsFor: 'primitives' stamp: 'ar 11/19/1999 21:30'!
ffiTestDoubles: f1 with: f2
	"FFITester ffiTestDoubles: $A with: 65.0"
	<cdecl: double 'ffiTestDoubles' (double double)>
	^self externalCallFailed! !

!FFITester methodsFor: 'primitives' stamp: 'ar 11/19/1999 20:31'!
ffiTestFloats: f1 with: f2
	"FFITester ffiTestFloats: $A with: 65.0"
	<cdecl: float 'ffiTestFloats' (float float)>
	^self externalCallFailed! !

!FFITester methodsFor: 'primitives' stamp: 'ar 11/19/1999 20:31'!
ffiTestInt: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestInt: $A with: 65 with: 65.0 with: $A"
	<cdecl: long 'ffiTestInts' (long long long long)>
	^self externalCallFailed! !

!FFITester methodsFor: 'primitives' stamp: 'ar 11/19/1999 20:31'!
ffiTestShort: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestShort: $A with: 65 with: 65.0 with: $A"
	<cdecl: short 'ffiTestShorts' (short short short short)>
	^self externalCallFailed! !

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

FFITester class
	instanceVariableNames: ''!

!FFITester class methodsFor: 'public' stamp: 'ar 11/28/1999 20:13'!
testAll	"FFITester testAll"
	"Run all the tests"
	"Pass 1: Run all the methods in the class and see if it works"
	"Pass 2: Run all the methods in an instance (ExternalLibrary) and see if it works"
	"Pass 3: Run all the methods directly invoked from an ExternalMethod"
	| rcvr value meth module |
	1 to: 2 do:[:i|
		i = 1 ifTrue:[rcvr _ self] ifFalse:[rcvr _ self new].
		"Test argument coercion and passing of arguments of different sizes"
		rcvr ffiTestChar: $A with: 65 with: 65.0 with: true.
		rcvr ffiTestShort: $A with: 65 with: 65.0 with: true.
		rcvr ffiTestInt: $A with: 65 with: 65.0 with: true.
		value _ rcvr ffiTestFloats: $A with: 65.0.
		value rounded = 130 ifFalse:[self error:'single floats don''t work'].
		value _ rcvr ffiTestDoubles: 41 with: true.
		value = 42.0 ifFalse:[self error:'problem with doubles'].
		value _ rcvr ffiPrintString:'Hello World!!'.
		value = 'Hello World!!' ifFalse:[self error:'Problem with strings'].
	].
	module _ self moduleName.
	meth _ ExternalLibraryFunction
		name:'ffiTestChars' module: module callType: 0 returnType: ExternalType char
		argumentTypes: ((1 to: 4) collect:[:i| ExternalType char]).
	meth invokeWith: $A with: 65 with: 65.0 with: true.
	meth _ ExternalLibraryFunction
		name:'ffiTestShorts' module: module callType: 0 returnType: ExternalType short
		argumentTypes: ((1 to: 4) collect:[:i| ExternalType short]).
	meth invokeWithArguments: (Array with: $A with: 65 with: 65.0 with: true).
	meth _ ExternalLibraryFunction
		name:'ffiTestInts' module: module callType: 0 returnType: ExternalType long
		argumentTypes: ((1 to: 4) collect:[:i| ExternalType long]).
	meth invokeWith: $A with: 65 with: 65.0 with: true.

	meth _ ExternalLibraryFunction
		name:'ffiTestFloats' module: module callType: 0 returnType: ExternalType float
		argumentTypes: ((1 to: 2) collect:[:i| ExternalType float]).
	value _ meth invokeWith: $A with: 65.0.
	value rounded = 130 ifFalse:[self error:'single floats don''t work'].

	meth _ ExternalLibraryFunction
		name:'ffiTestDoubles' module: module callType: 0 returnType: ExternalType double
		argumentTypes: ((1 to: 2) collect:[:i| ExternalType double]).
	value _ meth invokeWithArguments: (Array with: 41 with: true).
	value = 42.0 ifFalse:[self error:'problem with doubles'].

	meth _ ExternalLibraryFunction
		name:'ffiPrintString' module: module callType: 0 returnType: ExternalType string
		argumentTypes: ((1 to: 1) collect:[:i| ExternalType string]).
	value _ meth invokeWith:'Hello World!!'.
	value = 'Hello World!!' ifFalse:[self error:'Problem with strings'].
! !

!FFITester class methodsFor: 'public' stamp: 'ar 11/22/1999 05:02'!
testLongLongs	"FFITester testLongLongs"
	"Test passing and returning longlongs"
	| long1 long2 long3 |
	long1 _ 16r123456789012.
	long2 _ (-1 << 31).
	long3 _ self ffiTestLongLong: long1 with: long2.
	long3 = (long1 + long2) ifFalse:[self error:'Problem passing/returning longlongs'].
	^long3! !

!FFITester class methodsFor: 'public' stamp: 'ar 11/22/1999 05:03'!
testPoint2 "FFITester testPoint2"
	"Test passing and returning up of structures >32bit and <= 64 bit"
	| pt1 pt2 pt3 |
	pt1 _ FFITestPoint2 new.
	pt1 x: 1. pt1 y: 2.
	pt2 _ FFITestPoint2 new.
	pt2 x: 3. pt2 y: 4.
	pt3 _ self ffiTestPoint2: pt1 with: pt2.
	(pt3 x = 4 and:[ pt3 y = 6]) 
		ifFalse:[self error:'Problem passing 64bit structures'].
	^pt3! !

!FFITester class methodsFor: 'public' stamp: 'ar 11/22/1999 05:03'!
testPoint4 "FFITester testPoint4"
	"Test passing and returning up of structures > 64 bit"
	| pt1 pt2 pt3 |
	pt1 _ FFITestPoint4 new.
	pt1 x: 1. pt1 y: 2. pt1 z: 3. pt1 w: 4.
	pt2 _ FFITestPoint4 new.
	pt2 x: 5. pt2 y: 6. pt2 z: 7. pt2 w: 8.
	pt3 _ self ffiTestPoint4: pt1 with: pt2.
	(pt3 x = 6 and:[ pt3 y = 8 and:[pt3 z = 10 and:[pt3 w = 12]]]) 
		ifFalse:[self error:'Problem passing large structures'].
	^pt3! !

!FFITester class methodsFor: 'public' stamp: 'ar 12/1/1999 16:39'!
testPointers "FFITester testPointers"
	"Test passing and returning of pointers to structs"
	| pt1 pt2 pt3 |
	pt1 _ FFITestPoint4 new.
	pt1 x: 1. pt1 y: 2. pt1 z: 3. pt1 w: 4.
	pt2 _ FFITestPoint4 new.
	pt2 x: 5. pt2 y: 6. pt2 z: 7. pt2 w: 8.
	pt3 _ self ffiTestPointers: pt1 with: pt2.
	(pt3 x = 6 and:[ pt3 y = 8 and:[pt3 z = 10 and:[pt3 w = 12]]]) 
		ifFalse:[self error:'Problem passing large structures'].
	^pt3! !


!FFITester class methodsFor: 'primitives' stamp: 'ar 1/27/2000 01:21'!
ffiPrintString: aString
	"FFITester ffiPrintString: 'Hello'"
	<cdecl: char* 'ffiPrintString' (char *) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestChar: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestChar: $A with: 65 with: 65.0 with: true"
	<cdecl: char 'ffiTestChars' (char char char char) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestDoubles: f1 with: f2
	"FFITester ffiTestDoubles: $A with: 65.0"
	<cdecl: double 'ffiTestDoubles' (double double) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestFloats: f1 with: f2
	"FFITester ffiTestFloats: $A with: 65.0"
	<cdecl: float 'ffiTestFloats' (float float) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/29/1999 14:49'!
ffiTestInt: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestInt: $A with: 65 with: 65.0 with: true"
	<cdecl: long 'ffiTestInts' (long long long long) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestLongLong: long1 with: long2
	<cdecl: longlong 'ffiTestLongLong' (longlong longlong) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestPoint2: pt1 with: pt2
	<cdecl: FFITestPoint2 'ffiTestStruct64' (FFITestPoint2 FFITestPoint2) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/28/1999 19:51'!
ffiTestPoint4: pt1 with: pt2
	<cdecl: FFITestPoint4 'ffiTestStructBig' (FFITestPoint4 FFITestPoint4) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 12/1/1999 16:39'!
ffiTestPointers: pt1 with: pt2
	<cdecl: FFITestPoint4* 'ffiTestPointers' (FFITestPoint4* FFITestPoint4*) module:'SqueakFFIPrims'>
	^self externalCallFailed! !

!FFITester class methodsFor: 'primitives' stamp: 'ar 11/29/1999 14:16'!
ffiTestShort: c1 with: c2 with: c3 with: c4
	"FFITester ffiTestShort: $A with: 65 with: 65.0 with:1"
	<cdecl: short 'ffiTestShorts' (short short short short) module:'SqueakFFIPrims'>
	^self externalCallFailed! !


!FFITester class methodsFor: 'accessing' stamp: 'ar 11/28/1999 19:51'!
moduleName
	"Use the fully qualified VM name so we ensure testing loading a library"
	^'SqueakFFIPrims'! !
Object subclass: #FFT
	instanceVariableNames: 'nu n sinTable permTable realData imagData window '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!FFT commentStamp: '<historical>' prior: 0!
This class implements the Fast Fourier Transform roughly as described on page 367
of "Theory and Application of Digital Signal Processing" by Rabiner and Gold.
Each instance caches tables used for transforming a given size (n = 2^nu samples) of data.

It would have been cleaner using complex numbers, but often the data is all real.!


!FFT methodsFor: 'initialization' stamp: 'jm 8/25/1999 21:59'!
n

	^ n
! !

!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!
nu: order
	"Initialize variables and tables for transforming 2^nu points"
	|  j perms k |
	nu _ order.
	n _ 2 bitShift: nu-1.

	"Initialize permutation table (bit-reversed indices)"
	j_0.
	perms _ WriteStream on: (Array new: n).
	0 to: n-2 do:
		[:i |
		i < j ifTrue: [perms nextPut: i+1; nextPut: j+1].
		k _ n // 2.
		[k <= j] whileTrue: [j _ j-k.  k _ k//2].
		j _ j + k].
	permTable _ perms contents.

	"Initialize sin table 0..pi/2 in n/4 steps."
	sinTable _ (0 to: n/4) collect: [:i | (i asFloat / (n//4) * Float pi / 2.0) sin]! !

!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!
realData: real
	realData _ real.
	imagData _ real collect: [:i | 0.0]  "imaginary component all zero"! !

!FFT methodsFor: 'initialization' stamp: 'di 6/17/97 07:47'!
realData: real imagData: imag
	realData _ real.
	imagData _ imag! !


!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!
permuteData
	| i end a b |
	i _ 1.
	end _ permTable size.
	[i <= end] whileTrue:
		[a _ permTable at: i.
		b _ permTable at: i+1.
		realData swap: a with: b.
		imagData swap: a with: b.
		i _ i + 2]! !

!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!
scaleData
	"Scale all elements by 1/n when doing inverse"
	| realN |
	realN _ n asFloat.
	1 to: n do:
		[:i |
		realData at: i put: (realData at: i) / realN.
		imagData at: i put: (imagData at: i) / realN]! !

!FFT methodsFor: 'transforming' stamp: 'di 6/17/97 07:47'!
transformForward: forward
	| lev lev1 ip theta realU imagU realT imagT i |
	self permuteData.
	1 to: nu do:
		[:level |
		lev _ 1 bitShift: level.
		lev1 _ lev // 2.
		1 to: lev1 do:
			[:j |
			theta _ j-1 * (n // lev).   "pi * (j-1) / lev1 mapped onto 0..n/2"
			theta < (n//4)  "Compute U, the complex multiplier for each level"
				ifTrue:
					[realU _ sinTable at: sinTable size - theta.
					imagU _ sinTable at: theta + 1]
				ifFalse:
					[realU _ (sinTable at: theta - (n//4) + 1) negated.
					imagU _ sinTable at: (n//2) - theta + 1].
			forward ifFalse: [imagU _ imagU negated].
"
			Here is the inner loop...
			j to: n by: lev do:
				[:i |   hand-transformed to whileTrue...
"
			i _ j.
			[i <= n] whileTrue:
				[ip _ i + lev1.
				realT _ ((realData at: ip) * realU) - ((imagData at: ip) * imagU).
				imagT _ ((realData at: ip) * imagU) + ((imagData at: ip) * realU).
				realData at: ip put: (realData at: i) - realT.
				imagData at: ip put: (imagData at: i) - imagT.
				realData at: i put: (realData at: i) + realT.
				imagData at: i put: (imagData at: i) + imagT.
				i _ i + lev]]].
	forward ifFalse: [self scaleData]  "Reverse transform must scale to be an inverse"! !


!FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'!
imagData

	^ imagData
! !

!FFT methodsFor: 'testing' stamp: 'di 6/17/97 07:47'!
plot: samples in: rect
	"Throw-away code just to check out a couple of examples"
	| min max x dx pen y |
	Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
	min _ 1.0e30.  max _ -1.0e30.
	samples do:
		[:v |
		min _ min min: v.
		max _ max max: v].
	pen _ Pen new.  pen up.
	x _ rect left.
	dx _ rect width asFloat / samples size.
	samples do:
		[:v |
		y _ (max-v) / (max-min) * rect height asFloat.
		pen goto: x asInteger @ (rect top + y asInteger).
		pen down.
		x _ x + dx].
	max printString displayOn: Display at: (x+2) @ (rect top-9).
	min printString displayOn: Display at: (x+2) @ (rect bottom - 9)! !

!FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'!
realData

	^ realData
! !

!FFT methodsFor: 'testing' stamp: 'jm 8/16/1998 17:36'!
samplesPerCycleForIndex: i
	"Answer the number of samples per cycle corresponding to a power peak at the given index. Answer zero if i = 1, since an index of 1 corresponds to the D.C. component."

	| windowSize |
	windowSize _ 2 raisedTo: nu.
	(i < 1 or: [i > (windowSize // 2)]) ifTrue: [^ self error: 'index is out of range'].
	i = 1 ifTrue: [^ 0].  "the D.C. component"
	^ windowSize asFloat / (i - 1)
! !

!FFT methodsFor: 'testing' stamp: 'di 6/17/97 07:47'!
test  "Display restoreAfter: [(FFT new nu: 8) test].  --  Test on an array of 256 samples"
	"Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
	self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
	self plot: realData in: (100@20 extent: 256@60).
	self transformForward: true.
	self plot: realData in: (100@100 extent: 256@60).
	self plot: imagData in: (100@180 extent: 256@60).
	self transformForward: false.
	self plot: realData in: (100@260 extent: 256@60)! !


!FFT methodsFor: 'plugin-testing' stamp: 'ar 10/10/1998 21:53'!
pluginPrepareData
	"The FFT plugin requires data to be represented in WordArrays or FloatArrays"
	sinTable _ sinTable asFloatArray.
	permTable _ permTable asWordArray.
	realData _ realData asFloatArray.
	imagData _ imagData asFloatArray.! !

!FFT methodsFor: 'plugin-testing' stamp: 'ar 10/10/1998 21:53'!
pluginTest  "Display restoreAfter: [(FFT new nu: 12) pluginTest]."
	"Test on an array of 256 samples"
	"Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
	self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
	self plot: realData in: (100@20 extent: 256@60).
	self pluginPrepareData.
	Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: true]); endEntry.
	self plot: realData in: (100@100 extent: 256@60).
	self plot: imagData in: (100@180 extent: 256@60).
	Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: false]); endEntry.
	self plot: realData in: (100@260 extent: 256@60)! !

!FFT methodsFor: 'plugin-testing' stamp: 'ar 2/2/2001 15:47'!
pluginTransformData: forward
	"Plugin testing -- if the primitive is not implemented 
	or cannot be found run the simulation. See also: FFTPlugin"
	<primitive: 'primitiveFFTTransformData' module: 'FFTPlugin'>
	^FFTPlugin doPrimitive: 'primitiveFFTTransformData'.! !


!FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:10'!
initializeHammingWindow: alpha
	"Initialize the windowing function to the generalized Hamming window. See F. Richard Moore, Elements of Computer Music, p. 100. An alpha of 0.54 gives the Hamming window, 0.5 gives the hanning window."

	| v midPoint |
	window _ FloatArray new: n.
	midPoint _ (n + 1) / 2.0.
	1 to: n do: [:i |
		v _ alpha + ((1.0 - alpha) * (2.0 * Float pi * ((i - midPoint) / n)) cos).
		window at: i put: v].

! !

!FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 16:42'!
initializeTriangularWindow
	"Initialize the windowing function to the triangular, or Parzen, window. See F. Richard Moore, Elements of Computer Music, p. 100."

	| v |
	window _ FloatArray new: n.
	0 to: (n // 2) - 1 do: [:i |
		v _ i / ((n // 2) - 1).
		window at: (i + 1) put: v.
		window at: (n - i) put: v].
! !

!FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:40'!
setSize: anIntegerPowerOfTwo
	"Initialize variables and tables for performing an FFT on the given number of samples. The number of samples must be an integral power of two (e.g. 1024). Prepare data for use with the fast primitive."

	self nu: (anIntegerPowerOfTwo log: 2) asInteger.
	n = anIntegerPowerOfTwo ifFalse: [self error: 'size must be a power of two'].
	sinTable _ sinTable asFloatArray.
	permTable _ permTable asWordArray.
	realData _ FloatArray new: n.
	imagData _ FloatArray new: n.
	self initializeHammingWindow: 0.54.  "0.54 for Hamming, 0.5 for hanning"
! !

!FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:55'!
transformDataFrom: anIndexableCollection startingAt: index
	"Forward transform a block of real data taken from from the given indexable collection starting at the given index. Answer a block of values representing the normalized magnitudes of the frequency components."

	| j real imag out |
	j _ 0.
	index to: index + n - 1 do: [:i |
		realData at: (j _ j + 1) put: (anIndexableCollection at: i)].
	realData *= window.
	imagData _ FloatArray new: n.
	self pluginTransformData: true.

	"compute the magnitudes of the complex results"
	"note: the results are in bottom half; the upper half is just its mirror image"
	real _ realData copyFrom: 1 to: (n / 2).
	imag _ imagData copyFrom: 1 to: (n / 2).
	out _ (real * real) + (imag * imag).
	1 to: out size do: [:i | out at: i put: (out at: i) sqrt].
	^ out
! !

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

FFT class
	instanceVariableNames: ''!

!FFT class methodsFor: 'instance creation' stamp: 'jm 8/25/1999 12:49'!
new: anIntegerPowerOfTwo
	"Answer a new FFT instance for transforming data packets of the given size."

	^ self new setSize: anIntegerPowerOfTwo
! !
InterpreterPlugin subclass: #FFTPlugin
	instanceVariableNames: 'nu fftSize sinTable sinTableSize permTable permTableSize realData realDataSize imagData imagDataSize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!FFTPlugin commentStamp: '<historical>' prior: 0!
FFTPlugin is an example  of how plugins are written. It shows the use of FloatArray for heavy numerical stuff as well as the simulation of plugins from Squeak.

See also:
		FFT pluginTransformData:
!
]style[(173 24 1)f1,f1LFFT pluginTransformData:;,f1!


!FFTPlugin methodsFor: 'primitives' stamp: 'ar 10/11/1998 01:59'!
primitiveFFTPermuteData
	| rcvr |
	self export: true.
	rcvr _ interpreterProxy stackObjectValue: 0.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self permuteData.
	interpreterProxy failed ifTrue:[
		"permuteData went wrong. Do the permutation again -- this will restore the original order"
		self permuteData].! !

!FFTPlugin methodsFor: 'primitives' stamp: 'ar 10/11/1998 01:59'!
primitiveFFTScaleData
	| rcvr |
	self export: true.
	rcvr _ interpreterProxy stackObjectValue: 0.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self scaleData.! !

!FFTPlugin methodsFor: 'primitives' stamp: 'ar 10/11/1998 01:59'!
primitiveFFTTransformData
	| rcvr forward |
	self export: true.
	forward _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	rcvr _ interpreterProxy stackObjectValue: 1.
	(self loadFFTFrom: rcvr) ifFalse:[^nil].
	self transformData: forward.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 1. "Leave rcvr on stack"
	].! !


!FFTPlugin methodsFor: 'transforming' stamp: 'ar 9/16/1998 00:25'!
permuteData
	| i end a b tmp |
	self var: #tmp declareC: 'float tmp'.
	i _ 0.
	end _ permTableSize.
	[i < end] whileTrue:
		[a _ (permTable at: i) - 1.
		b _ (permTable at: i+1) - 1.

		(a < realDataSize and:[b < realDataSize]) ifFalse:[^interpreterProxy success: false].

		tmp _ realData at: a.
		realData at: a put: (realData at: b).
		realData at: b put: tmp.

		tmp _ imagData at: a.
		imagData at: a put: (imagData at: b).
		imagData at: b put: tmp.

		i _ i + 2]! !

!FFTPlugin methodsFor: 'transforming' stamp: 'ar 10/3/1998 18:10'!
scaleData
	"Scale all elements by 1/n when doing inverse"
	| realN |
	self var: #realN declareC: 'float realN'.
	fftSize <= 1 ifTrue:[^nil].
	realN _ self cCoerce: (1.0 / (self cCoerce: fftSize to: 'double')) to: 'float'.
	0 to: fftSize-1 do:
		[:i |
		realData at: i put: (realData at: i) * realN.
		imagData at: i put: (imagData at: i) * realN]! !

!FFTPlugin methodsFor: 'transforming' stamp: 'ar 9/16/1998 20:21'!
transformData: forward
	self permuteData.
	interpreterProxy failed ifTrue:[
		"permuteData went wrong. Do the permutation again -- this will restore the original order"
		self permuteData.
		^nil].
	self transformForward: forward.
	forward ifFalse: [self scaleData]  "Reverse transform must scale to be an inverse"! !

!FFTPlugin methodsFor: 'transforming' stamp: 'ar 9/16/1998 21:28'!
transformForward: forward
	| lev lev1 ip theta realU imagU realT imagT i fftSize2 fftSize4 fftScale ii |
	self var: #realU declareC:'float realU'.
	self var: #realT declareC:'float realT'.
	self var: #imagU declareC:'float imagU'.
	self var: #imagT declareC:'float imagT'.
	fftSize2 _ fftSize // 2.
	fftSize4 _ fftSize // 4.
	1 to: nu do:
		[:level |
		lev _ 1 bitShift: level.
		lev1 _ lev // 2.
		fftScale _ fftSize // lev.
		1 to: lev1 do:
			[:j |
			theta _ j-1 * fftScale.   "pi * (j-1) / lev1 mapped onto 0..n/2"
			theta < fftSize4  "Compute U, the complex multiplier for each level"
				ifTrue:
					[realU _ sinTable at: sinTableSize - theta - 1.
					imagU _ sinTable at: theta]
				ifFalse:
					[realU _ 0.0 - (sinTable at: theta - fftSize4).
					imagU _ sinTable at: fftSize2 - theta].
			forward ifFalse: [imagU _ 0.0 - imagU].
"
			Here is the inner loop...
			j to: n by: lev do:
				[:i |   hand-transformed to whileTrue...
"
			i _ j.
			[i <= fftSize] whileTrue:
				[ip _ i + lev1 - 1.
				ii _ i-1.
				realT _ ((realData at: ip) * realU) - ((imagData at: ip) * imagU).
				imagT _ ((realData at: ip) * imagU) + ((imagData at: ip) * realU).
				realData at: ip put: (realData at: ii) - realT.
				imagData at: ip put: (imagData at: ii) - imagT.
				realData at: ii put: (realData at: ii) + realT.
				imagData at: ii put: (imagData at: ii) + imagT.
				i _ i + lev]]].! !


!FFTPlugin methodsFor: 'private' stamp: 'ar 9/16/1998 21:40'!
checkedFloatPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	self returnTypeC:'float *'.
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'float *'! !

!FFTPlugin methodsFor: 'private' stamp: 'ar 9/16/1998 21:40'!
checkedWordPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	self returnTypeC:'unsigned int *'.
	interpreterProxy success: (interpreterProxy isWords: oop).
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to: 'unsigned int *'! !

!FFTPlugin methodsFor: 'private' stamp: 'ar 10/10/1998 21:43'!
loadFFTFrom: fftOop
	| oop |
	interpreterProxy success: (interpreterProxy slotSizeOf: fftOop) >= 6.
	interpreterProxy failed ifTrue:[^false].
	nu _ interpreterProxy fetchInteger: 0 ofObject: fftOop.
	fftSize _ interpreterProxy fetchInteger: 1 ofObject: fftOop.

	oop _ interpreterProxy fetchPointer: 2 ofObject: fftOop.
	sinTableSize _ interpreterProxy stSizeOf: oop.
	sinTable _ self checkedFloatPtrOf: oop.

	oop _ interpreterProxy fetchPointer: 3 ofObject: fftOop.
	permTableSize _ interpreterProxy stSizeOf: oop.
	permTable _ self checkedWordPtrOf: oop.

	oop _ interpreterProxy fetchPointer: 4 ofObject: fftOop.
	realDataSize _ interpreterProxy stSizeOf: oop.
	realData _ self checkedFloatPtrOf: oop.

	oop _ interpreterProxy fetchPointer: 5 ofObject: fftOop.
	imagDataSize _ interpreterProxy stSizeOf: oop.
	imagData _ self checkedFloatPtrOf: oop.

	"Check assumptions about sizes"
	interpreterProxy success:
		(1 << nu = fftSize) & 
		(fftSize // 4 + 1 = sinTableSize) & 
		(fftSize = realDataSize) & 
		(fftSize = imagDataSize) &
		(realDataSize = imagDataSize).

	^interpreterProxy failed == false! !

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

FFTPlugin class
	instanceVariableNames: ''!


!FFTPlugin class methodsFor: 'translation to C' stamp: 'sma 3/3/2000 12:43'!
declareCVarsIn: cg
	cg var: #sinTable type: #'float*'.
	cg var: #realData type:  #'float*'.
	cg var: #imagData type: #'float*'.
	cg var: #permTable type: #'unsigned int*'! !
FMSound subclass: #FMBassoonSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMBassoonSound methodsFor: 'as yet unclassified' stamp: 'jm 5/30/1999 21:17'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Select a modulation ratio and modulation envelope scale based on my pitch."

	| p modScale |
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	modScale _ 9.4.
	p > 100.0 ifTrue: [modScale _ 8.3].
	p > 150.0 ifTrue: [modScale _ 6.4].
	p > 200.0 ifTrue: [modScale _ 5.2].
	p > 300.0 ifTrue: [modScale _ 3.9].
	p > 400.0 ifTrue: [modScale _ 2.8].
	p > 600.0 ifTrue: [modScale _ 1.7].

	envelopes size > 0 ifTrue: [
		envelopes do: [:e |
			(e updateSelector = #modulation:)
				ifTrue: [e scale: modScale]]].

	super setPitch: p dur: d loudness: l.
! !
FMSound subclass: #FMClarinetSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMClarinetSound methodsFor: 'initialization' stamp: 'jm 5/30/1999 10:10'!
setPitch: pitchNameOrNumber dur: d loudness: l
	"Select a modulation ratio and modulation envelope scale based on my pitch."

	| p modScale |
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	p < 262.0
		ifTrue: [modScale _ 25.0. self ratio: 4]
		ifFalse: [modScale _ 20.0. self ratio: 2].
	p > 524.0 ifTrue: [modScale _ 8.0].

	envelopes size > 0 ifTrue: [
		envelopes do: [:e |
			(e updateSelector = #modulation:)
				ifTrue: [e scale: modScale]]].

	super setPitch: p dur: d loudness: l.
! !
AbstractSound subclass: #FMSound
	instanceVariableNames: 'initialCount count waveTable scaledWaveTableSize scaledIndex scaledIndexIncr modulation multiplier normalizedModulation scaledOffsetIndex scaledOffsetIndexIncr '
	classVariableNames: 'SineTable '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!FMSound methodsFor: 'initialization' stamp: 'jm 7/5/1998 11:44'!
initialize

	super initialize.
	waveTable _ SineTable.
	scaledWaveTableSize _ waveTable size * ScaleFactor.
	self setPitch: 440.0 dur: 1.0 loudness: 0.2.
! !

!FMSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:08'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"(FMSound pitch: 'a4' dur: 2.5 loudness: 0.4) play"

	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	modulation ifNil: [modulation _ 0.0].
	multiplier ifNil: [multiplier _ 0.0].
	self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
	self reset.
! !

!FMSound methodsFor: 'initialization' stamp: 'jm 9/20/1998 10:10'!
setWavetable: anArray
	"(AbstractSound lowMajorScaleOn: (FMSound new setWavetable: AA)) play"

	| samples p dur vol |
	"copy the array into a SoundBuffer if necessary"
	anArray class isPointers
		ifTrue: [samples _ SoundBuffer fromArray: anArray]
		ifFalse: [samples _ anArray].

	p _ self pitch.
	dur _ self duration.
	vol _ self loudness.
	waveTable _ samples.
	scaledWaveTableSize _ waveTable size * ScaleFactor.
	self setPitch: p dur: dur loudness: vol.
! !


!FMSound methodsFor: 'accessing' stamp: 'jm 3/26/98 10:45'!
duration

	^ initialCount asFloat / self samplingRate asFloat
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 9/9/1998 07:49'!
duration: seconds

	super duration: seconds.
	count _ initialCount _ (seconds * self samplingRate) rounded.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:44'!
internalizeModulationAndRatio
	"Recompute the internal state for the modulation index and frequency ratio relative to the current pitch."

	modulation < 0.0 ifTrue: [modulation _ modulation negated].
	multiplier < 0.0 ifTrue: [multiplier _ multiplier negated].
	normalizedModulation _
		((modulation * scaledIndexIncr)  / ScaleFactor) asInteger.
	scaledOffsetIndexIncr _ (multiplier * scaledIndexIncr) asInteger.

	"clip to maximum values if necessary"
	normalizedModulation > MaxScaledValue ifTrue: [
		normalizedModulation _ MaxScaledValue.
		modulation _ (normalizedModulation * ScaleFactor) asFloat / scaledIndexIncr].
	scaledOffsetIndexIncr > (scaledWaveTableSize // 2) ifTrue: [
		scaledOffsetIndexIncr _ scaledWaveTableSize // 2.
		multiplier _ scaledOffsetIndexIncr asFloat / scaledIndexIncr].
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:15'!
modulation
	"Return the FM modulation index."

	^ modulation
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:22'!
modulation: mod
	"Set the FM modulation index. Typical values range from 0 (no modulation) to 5, although values up to about 10 are sometimes useful."
	"Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."

	modulation _ mod asFloat.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:39'!
modulation: mod multiplier: freqRatio
	"For backward compatibility. Needed to read old .fmp files."

	self modulation: mod ratio: freqRatio.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:41'!
modulation: mod ratio: freqRatio
	"Set the modulation index and carrier to modulation frequency ratio for this sound, and compute the internal state that depends on these parameters."

	modulation _ mod asFloat.
	multiplier _ freqRatio asFloat.
	self internalizeModulationAndRatio.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 12/17/97 18:05'!
multiplier

	^ multiplier
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 8/7/1998 15:45'!
pitch

	^ (self samplingRate asFloat * scaledIndexIncr / ScaleFactor) asFloat / waveTable size
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:38'!
pitch: p
	"Warning: Since the modulation and ratio are relative to the current pitch, some internal state must be recomputed when the pitch is changed. However, for efficiency during envelope processing, this compuation will not be done until internalizeModulationAndRatio is called."

	scaledIndexIncr _
		((p asFloat * waveTable size asFloat * ScaleFactor asFloat) / self samplingRate asFloat) asInteger
			min: (waveTable size // 2) * ScaleFactor.
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:08'!
ratio
	"Return the FM modulation to carrier frequency ratio."

	^ multiplier
! !

!FMSound methodsFor: 'accessing' stamp: 'jm 2/4/98 07:22'!
ratio: freqRatio
	"Set the FM modulation to carrier frequency ratio."
	"Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."

	multiplier _ freqRatio asFloat.
! !


!FMSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:22'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy."
	"(FMSound pitch: 440.0 dur: 1.0 loudness: 0.5) play"

	| doingFM lastIndex sample offset i s |
	<primitive:'primitiveMixFMSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #waveTable declareC: 'short int *waveTable'.

	doingFM _ (normalizedModulation ~= 0) and: [scaledOffsetIndexIncr ~= 0].
	lastIndex _ (startIndex + n) - 1.
	startIndex to: lastIndex do: [:sliceIndex |
		sample _ (scaledVol * (waveTable at: (scaledIndex // ScaleFactor) + 1)) // ScaleFactor.
		doingFM
			ifTrue: [
				offset _ normalizedModulation * (waveTable at: (scaledOffsetIndex // ScaleFactor) + 1).
				scaledOffsetIndex _ (scaledOffsetIndex + scaledOffsetIndexIncr) \\ scaledWaveTableSize.
				scaledOffsetIndex < 0
					ifTrue: [scaledOffsetIndex _ scaledOffsetIndex + scaledWaveTableSize].
				scaledIndex _ (scaledIndex + scaledIndexIncr + offset) \\ scaledWaveTableSize.
				scaledIndex < 0
					ifTrue: [scaledIndex _ scaledIndex + scaledWaveTableSize]]
			ifFalse: [
				scaledIndex _ (scaledIndex + scaledIndexIncr) \\ scaledWaveTableSize].

		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].

		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]]].

	count _ count - n.
! !

!FMSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 20:12'!
reset

	self internalizeModulationAndRatio.
	super reset.
	count _ initialCount.
	scaledIndex _ 0.
	scaledOffsetIndex _ 0.
! !

!FMSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 19:34'!
samplesRemaining

	^ count
! !

!FMSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:55'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count _ (mSecs * self samplingRate) // 1000.
! !


!FMSound methodsFor: 'storing' stamp: 'jm 2/4/98 07:02'!
storeOn: strm
	| env |
	strm nextPutAll: '(((FMSound';
		nextPutAll: ' pitch: '; print: self pitch;
		nextPutAll: ' dur: '; print: self duration;
		nextPutAll: ' loudness: '; print: self loudness; nextPutAll: ')';
		nextPutAll: ' modulation: '; print: self modulation;
		nextPutAll: ' ratio: '; print: self ratio; nextPutAll: ')'.
	1 to: envelopes size do:
		[:i | env _ envelopes at: i.
		strm cr; nextPutAll: '    addEnvelope: '. env storeOn: strm.
		i < envelopes size ifTrue: [strm nextPutAll: ';']].
	strm  nextPutAll: ')'.
! !

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

FMSound class
	instanceVariableNames: ''!

!FMSound class methodsFor: 'class initialization' stamp: 'jm 7/6/1998 10:26'!
initialize
	"Build a sine wave table."
	"FMSound initialize"

	| tableSize radiansPerStep peak |
	tableSize _ 4000.
	SineTable _ SoundBuffer newMonoSampleCount: tableSize.
	radiansPerStep _ (2.0 * Float pi) / tableSize asFloat.
	peak _ ((1 bitShift: 15) - 1) asFloat.  "range is +/- (2^15 - 1)"
	1 to: tableSize do: [:i |
		SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded].
! !

!FMSound class methodsFor: 'class initialization' stamp: 'jm 7/5/1998 14:22'!
sineTable
	"Answer a SoundBuffer containing one complete cycle of a sine wave."

	^ SineTable
! !


!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
bass1
	"FMSound bass1 play"
	"(FMSound lowMajorScaleOn: FMSound bass1) play"

	| snd |
	snd _ FMSound new modulation: 0 ratio: 0.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.95).
	^ snd setPitch: 220 dur: 1.0 loudness: 0.3
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 20:37'!
bassoon1
	"FMSound bassoon1 play"
	"(FMSound lowMajorScaleOn: FMSound bassoon1) play"

	| snd p env |
	snd _ FMBassoonSound new ratio: 1.

	p _ OrderedCollection new.
	p add: 0@0.0; add: 40@0.45; add: 90@1.0; add: 180@0.9; add: 270@1.0; add: 320@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p _ OrderedCollection new.
	p add: 0@0.2; add: 40@0.9; add: 90@0.6; add: 270@0.6; add: 320@0.5.
	env _ Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #modulation:; scale: 5.05.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
brass1
	"FMSound brass1 play"
	"(FMSound lowMajorScaleOn: FMSound brass1) play"

	| snd p env |
	snd _ FMSound new modulation: 0 ratio: 1.
	p _ OrderedCollection new.
	p add: 0@0.0; add: 30@0.8; add: 90@1.0; add: 120@0.9; add: 220@0.7; add: 320@0.9; add: 360@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).

	p _ OrderedCollection new.
	p add: 0@0.5; add: 60@1.0; add: 120@0.8; add: 220@0.65; add: 320@0.8; add: 360@0.0.
	env _ Envelope points: p loopStart: 3 loopEnd: 5.
	env target: snd; updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
brass2
	"FMSound brass2 play"
	"(FMSound lowMajorScaleOn: FMSound brass2) play"

	| snd p env |
	snd _ FMSound new modulation: 1 ratio: 1.

	p _ OrderedCollection new.
	p add: 0@0.0; add: 20@1.0; add: 40@0.9; add: 100@0.7; add: 160@0.9; add: 200@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p _ OrderedCollection new.
	p add: 0@0.5; add: 30@1.0; add: 40@0.8; add: 100@0.7; add: 160@0.8; add: 200@0.0.
	env _ Envelope points: p loopStart: 3 loopEnd: 5.
	env updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:10'!
clarinet
	"FMSound clarinet play"
	"(FMSound lowMajorScaleOn: FMSound clarinet) play"

	| snd p env |
	snd _ FMSound new modulation: 0 ratio: 2.

	p _ OrderedCollection new.
	p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).

	p _ OrderedCollection new.
	p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0.
	env _ Envelope points: p loopStart: 2 loopEnd: 3.
	env updateSelector: #modulation:; scale: 10.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 10:20'!
clarinet2
	"FMSound clarinet2 play"
	"(FMSound lowMajorScaleOn: FMSound clarinet2) play"

	| snd p env |
	snd _ FMClarinetSound new modulation: 0 ratio: 2.

	p _ OrderedCollection new.
	p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).

	p _ OrderedCollection new.
	p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0.
	env _ Envelope points: p loopStart: 2 loopEnd: 3.
	env updateSelector: #modulation:; scale: 10.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5

! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/5/98 17:35'!
default

	^ self oboe1
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:02'!
flute1
	"FMSound flute1 play"
	"(FMSound majorScaleOn: FMSound flute1) play"

	| snd p |
	snd _ FMSound new.
	p _ OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:02'!
flute2
	"FMSound flute2 play"
	"(FMSound majorScaleOn: FMSound flute2) play"

	| snd p |
	snd _ FMSound new.
	p _ OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	snd addEnvelope: (RandomEnvelope for: #pitch:).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 9/2/1999 13:32'!
marimba
	"FMSound marimba play"
	"(FMSound majorScaleOn: FMSound marimba) play"

	| snd p env |
	snd _ FMSound new modulation: 1 ratio: 0.98.

	p _ OrderedCollection new.
	p add: 0@1.0; add: 10@0.3; add: 40@0.1; add: 80@0.02; add: 120@0.1; add: 160@0.02; add: 220@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).

	p _ OrderedCollection new.
	p add: 0@1.2; add: 80@0.85; add: 120@1.0; add: 160@0.85; add: 220@0.0.
	env _ Envelope points: p loopStart: 2 loopEnd: 4.
	env updateSelector: #modulation:.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
mellowBrass
	"FMSound mellowBrass play"
	"(FMSound lowMajorScaleOn: FMSound mellowBrass) play"

	| snd p env |
	snd _ FMSound new modulation: 0 ratio: 1.

	p _ OrderedCollection new.
	p add: 0@0.0; add: 70@0.325; add: 120@0.194; add: 200@0.194; add: 320@0.194; add: 380@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).

	p _ OrderedCollection new.
	p add: 0@0.1; add: 70@0.68; add: 120@0.528; add: 200@0.519; add: 320@0.528; add: 380@0.0.
	env _ Envelope points: p loopStart: 3 loopEnd: 5.
	env updateSelector: #modulation:; scale: 5.0.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
oboe1
	"FMSound oboe1 play"
	"(FMSound majorScaleOn: FMSound oboe1) play"

	| snd p |
	snd _ FMSound new modulation: 1 ratio: 1.
	p _ OrderedCollection new.
	p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'!
oboe2
	"FMSound oboe2 play"
	"(FMSound majorScaleOn: FMSound oboe2) play"

	| snd p |
	snd _ FMSound new modulation: 1 ratio: 1.
	p _ OrderedCollection new.
	p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	snd addEnvelope: (RandomEnvelope for: #pitch:).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:56'!
organ1
	"FMSound organ1 play"
	"(FMSound majorScaleOn: FMSound organ1) play"

	| snd p |
	snd _ FMSound new.
	p _ OrderedCollection new.
	p add: 0@0; add: 60@1.0; add: 110@0.8; add: 200@1.0; add: 250@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 4).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 9/1/1999 17:33'!
pluckedElecBass
	"FMSound pluckedElecBass play"
	"(FMSound lowMajorScaleOn: FMSound pluckedElecBass) play"

	| snd p env |
	snd _ FMSound new modulation: 1 ratio: 3.0.

	p _ OrderedCollection new.
	p add: 0@0.4; add: 20@1.0; add: 30@0.6; add: 100@0.6; add: 130@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 4).

	p _ OrderedCollection new.
	p add: 0@1.0; add: 20@2.0; add: 30@4.5; add: 100@4.5; add: 130@0.0.
	env _ Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #modulation:.
	snd addEnvelope: env.

	p _ OrderedCollection new.
	p add: 0@6.0; add: 20@4.0; add: 30@3.0; add: 100@3.0; add: 130@3.0.
	env _ Envelope points: p loopStart: 3 loopEnd: 4.
	env updateSelector: #ratio:.
	snd addEnvelope: env.

	^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:00'!
randomWeird1
	"FMSound randomWeird1 play"

	| snd p |
	snd _ FMSound new.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
	p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0.
	snd addEnvelope: (PitchEnvelope points: p loopStart: 2 loopEnd: 4).
	^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
! !

!FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 12:57'!
randomWeird2
	"FMSound randomWeird2 play"

	| snd |
	snd _ FMSound new.
	snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
	snd addEnvelope: (PitchEnvelope exponentialDecay: 0.98).
	^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
! !
HTTPSocket subclass: #FTPSocket
	instanceVariableNames: 'portNum dataSocket readAhead '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!FTPSocket commentStamp: '<historical>' prior: 0!
A minimal FTP client program.  Could store all state in inst vars, and use an instance to represent the full state of a connection in progress.  But simpler to do all that in one method and have it be a complete transaction.

Always operates in passive mode (PASV).  All connections are initiated from client in order to get through firewalls.

See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use.

See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.!
]style[(259 1 89 23 2 29 2 30 27 6 74)f1,f1-,f1,f1LServerDirectory openFTP;,f1,f1LServerDirectory getFileNamed:;,f1,f1LServerDirectory putFile:named:;,f1,f1b,f1!


!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:13'!
dataSocket
	^ dataSocket! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:13'!
dataSocket: dd
	dataSocket _ dd! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 21:56'!
getAllData
	"Reel in all data until the server closes the connection.  Return a RWBinaryOrTextStream.  Don't know how much is coming."

	| buf response bytesRead |
	buf _ String new: 4000.
	response _ RWBinaryOrTextStream on: (String new: 4000).
	[(self dataAvailable | self isConnected)] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: 1 count: buf size.
		1 to: bytesRead do: [:ii | response nextPut: (buf at: ii)].
			"Any way to do this so we do not have to recopy?"
		].
	response reset.	"position: 0."
	^ response! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 15:03'!
getAllDataWhileWatching: otherSocket
	"Reel in all data until the server closes the connection.  At the same time, watch for errors on otherSocket.  Return a RWBinaryOrTextStream.  Don't know how much is coming."

	| buf response bytesRead |
	buf _ String new: 4000.
	response _ RWBinaryOrTextStream on: (String new: 4000).
	[self isConnected | self dataAvailable] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			otherSocket responseError ifTrue: [self destroy. ^ #error:].
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: 1 count: buf size.
		1 to: bytesRead do: [:ii | response nextPut: (buf at: ii)].
			"Any way to do this so we do not have to recopy?"
		].
	response reset.	"position: 0."
	^ response! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 15:05'!
getDataTo: dataStream whileWatching: otherSocket
	"Reel in all data until the server closes the connection.  At the same time, watch for errors on otherSocket.  Don't know how much is coming.  Put the data on the stream."

	| buf bytesRead |
	buf _ String new: 4000.
	[self isConnected | self dataAvailable] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			otherSocket responseError ifTrue: [self destroy. ^ #error:].
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: 1 count: buf size.
		1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)].
			"Any way to do this so we do not have to recopy?"
		].
	dataStream reset.	"position: 0."
	^ dataStream! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 3/23/2000 22:10'!
getOnlyBuffer: ubuffer whileWatching: otherSocket
	"Reel in all data until the buffer is full.  At the same time, watch for errors on otherSocket.  Caller will break the connection after we have the data."

	| bytesRead ind |
	ind _ 1.
	[self isConnected | self dataAvailable] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			otherSocket responseError ifTrue: [self destroy. ^ #error:].
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: ubuffer 
			startingAt: ind count: ubuffer size - ind + 1.
		(ind _ ind + bytesRead) > ubuffer size ifTrue: [^ ubuffer].
		].
	^ ubuffer	"file was shorter"! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'di 3/29/1999 17:18'!
lookFor: beginning
        "Get the response from the server.  If 1xx, in progress.  If 2xx, success.  If 3xx, intermediate point successful.  4xx, transient error.  5xx, true error.  If 4 or 5, put up dialog, kill the socket, and return the response string.  Return true the string in beginning is at the front of what came back.  Ignore any 2xx response that is not what we want, but print it."
	| resp what all |
	(readAhead ~~ nil and: [readAhead size > 0])
		ifTrue: [resp _ readAhead removeFirst]  "response already came in"
		ifFalse: [
			all _ self getResponseUpTo: CrLf.
			resp _ all at: 1.       "150 Opening binary mode data conn"
			readAhead _ (all at: 3) findBetweenSubStrs: (Array with: CrLf)].
	resp size > 0 
		ifTrue: [
			resp first isDigit ifFalse: [ ^self lookFor: beginning ].
				"we're in the middle of a line, not the end." #XXX. "this should be fixed..."
			(resp at: 4) == $- ifTrue: [^ self lookFor: beginning]. "is a comment"
			(resp beginsWith: beginning) ifTrue: [^ true].  "exactly what we wanted"
			]
		ifFalse: [resp _ '[timeout]'].
	what _ (PopUpMenu labels: 'OK\ debug ' withCRs) 
		startUpWithCaption: 'Server reported this error:\' withCRs, resp.
	what = 2 ifTrue: [self halt].
	self destroy.
	^ resp

! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 7/8/1999 14:29'!
lookSoftlyFor: beginning
        "Get the response from the server.  Return true the string in beginning is at the front of what came back.  Don't kill the socket if we fail.  Users wants to try another password."
	| resp what all |
	(readAhead ~~ nil and: [readAhead size > 0])
		ifTrue: [resp _ readAhead removeFirst]  "response already came in"
		ifFalse: [
			all _ self getResponseUpTo: CrLf.
			resp _ all at: 1.       "150 Opening binary mode data conn"
			readAhead _ (all at: 3) findBetweenSubStrs: (Array with: CrLf)].
	resp size > 0 
		ifTrue: [
			resp first isDigit ifFalse: [ ^self lookFor: beginning ].
				"we're in the middle of a line, not the end." #XXX. "this should be fixed..."
			(resp at: 4) == $- ifTrue: [^ self lookFor: beginning]. "is a comment"
			(resp beginsWith: beginning) ifTrue: [^ true].  "exactly what we wanted"
			]
		ifFalse: [resp _ '[timeout]'].
	what _ (PopUpMenu labels: 'OK\ debug ' withCRs) 
		startUpWithCaption: 'Server reported this error:\' withCRs, resp.
	what = 2 ifTrue: [self halt].
	^ resp

! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:12'!
portNum
	^ portNum! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:12'!
portNum: anInteger
	portNum _ anInteger! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 11:59'!
responseCheck
	"If data is waiting, do a responseOK to catch any error reports."

	self dataAvailable ifTrue: [^ self responseOK].
	^ true	"all OK so far"! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 12:28'!
responseError
	"If data is waiting, Check it to catch any error reports.  Keep all responses in a queue for caller to examine later."

	| all what |
	self dataAvailable ifTrue: [
		all _ self getResponseUpTo: CrLf.
		readAhead ifNil: [readAhead _ OrderedCollection new].
		readAhead addLast: (all at: 1).	"150 Opening binary mode data conn"
		readAhead addAll: ((all at: 3) findBetweenSubStrs: (Array with: CrLf)).
		readAhead do: [:resp |
			((resp at: 1) == $5) | ((resp at: 1) == $4) ifTrue: [
				what _ (PopUpMenu labels: 'OK\ debug ' withCRs) 
					startUpWithCaption: 'Server reported this error:\' withCRs, resp.
				what = 2 ifTrue: [self halt].
				self sendCommand: 'QUIT'.
				readAhead _ nil.	"clear queue"
				self responseOK.		"221"
				self destroy.
				^ true]]].

	^ false	"all OK so far"! !

!FTPSocket methodsFor: 'as yet unclassified' stamp: 'mjg 5/7/1999 13:54'!
responseOK
	"Get the response from the server.  If 1xx, in progress.  If 2xx,
success.  If 3xx, intermediate point successful.  4xx, transient error.
5xx, true error.  If 4 or 5, put up dialog and kill the socket.  Return
true if OK, the error string if not."

	| resp what all |
	readAhead isNil ifTrue: [readAhead _ ''].
	readAhead size > 0
		ifTrue: [resp _ readAhead removeFirst]	"response already
came in"
		ifFalse: [
			all _ self getResponseUpTo: CrLf.
			resp _ all at: 1.	"150 Opening binary mode
data conn"
			readAhead _ (all at: 3) findBetweenSubStrs: (Array
with: CrLf)].
	"Transcript show: resp; cr."
	resp size > 0
		ifTrue: [((resp at: 1) == $5) | ((resp at: 1) == $4)
ifFalse: [^ true]]  "All is well"
		ifFalse: [resp _ '[timeout]'].
	what _ (PopUpMenu labels: 'OK\ debug ' withCRs)
		startUpWithCaption: 'Server reported this error:\' withCRs,
resp.
	what = 2 ifTrue: [self halt].
	self destroy.
	^ resp! !


!FTPSocket methodsFor: 'finalization' stamp: 'ar 3/21/98 18:19'!
actAsExecutor
	super actAsExecutor.
	dataSocket := nil.! !
Object subclass: #FWT
	instanceVariableNames: 'alpha beta coeffs h g hTilde gTilde samples nSamples nLevels transform '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!FWT commentStamp: '<historical>' prior: 0!
This class implements the Fast Wavelet Transform.  It follows Mac Cody's article in Dr. Dobb's Journal, April 1992.  See also... 
	http://www.dfw.net/~mcody/fwt/fwt.html

Notable features of his implementation include...
1.  The ability to generate a large family of wavelets (including the Haar (alpha=beta) and Daubechies) from two parameters, alpha and beta, which range between -pi and pi.
2.  All data arrays have 5 elements added on to allow for convolution overrun with filters up to 6 in length (the max for this implementation).
3.  After a forward transform, the detail coefficients of the deomposition are found in transform at: 2*i, for i = 1, 2, ... nLevels;  and the approximation coefficients are in transform at: (2*nLevels-1).  these together comprise the complete wavelet transform.

The following changes from cody's listings should also be noted...
1.  The three DotProduct routines have been merged into one.
2.  The four routines WaveletDecomposition, DecomposeBranches, WaveletReconstruction, ReconstructBranches have all been merged into transformForward:.
3.  All indexing follows the Smalltalk 1-to-N convention, naturally.!


!FWT methodsFor: 'initialization' stamp: 'di 10/31/1998 12:23'!
nSamples: n nLevels: nLevs
	"Initialize a wavelet transform."
	"Note the sample array size must be N + 5, where N is a multiple of 2^nLevels"
	| dyadSize |
	(n // (1 bitShift: nLevs)) > 0 ifFalse: [self error: 'Data size error'].
	(n \\ (1 bitShift: nLevs)) = 0 ifFalse: [self error: 'Data size error'].
	nSamples _ n.
	samples _ Array new: n + 5.
	nLevels _ nLevs.
	transform _ Array new: nLevels*2.  "Transformed data is stored as a tree of coeffs"
	dyadSize _ nSamples.
	1 to: nLevels do:
		[:i |  dyadSize _ dyadSize // 2.
		transform at: 2*i-1 put: (Array new: dyadSize + 5).
		transform at: 2*i put: (Array new: dyadSize + 5)]! !

!FWT methodsFor: 'initialization' stamp: 'di 10/30/1998 10:59'!
setAlpha: alph beta: bet
	"Set alpha and beta, compute wavelet coeefs, and derive hFilter and lFilter"
	| tcosa tcosb tsina tsinb |
	alpha _ alph.
	beta _ bet.

	"WaveletCoeffs..."
	"precalculate cosine of alpha and sine of beta"
	tcosa _ alpha cos.
	tcosb _ beta cos.
	tsina _ alpha sin.
	tsinb _ beta sin.
	coeffs _ Array new: 6.
	
	"calculate first two wavelet coefficients a _ a(-2) and b _ a(-1)"
	coeffs at: 1 put: ((1.0 + tcosa + tsina) * (1.0 - tcosb - tsinb)
					+ (2.0 * tsinb * tcosa)) / 4.0.
	coeffs at: 2 put: ((1.0 - tcosa + tsina) * (1.0 + tcosb - tsinb)
					- (2.0 * tsinb * tcosa)) / 4.0.

	"precalculate cosine and sine of alpha minus beta"
	tcosa _ (alpha - beta) cos.
	tsina _ (alpha - beta) sin.

	"calculate last four wavelet coefficients c _ a(0), d _ a(1), e _ a(2), and f _ a(3)"
	coeffs at: 3 put: (1.0 + tcosa + tsina) / 2.0.
	coeffs at: 4 put: (1.0 + tcosa - tsina) / 2.0.
	coeffs at: 5 put: 1.0 - (coeffs at: 1) - (coeffs at: 3).
	coeffs at: 6 put: 1.0 - (coeffs at: 2) - (coeffs at: 4).

	"MakeFiltersFromCoeffs..."
	"Select the non-zero wavelet coefficients"
	coeffs _ coeffs copyFrom: (coeffs findFirst: [:c | c abs > 1.0e-14])
						to: (coeffs findLast: [:c | c abs > 1.0e-14]).

	"Form the low pass and high pass filters for decomposition"
	hTilde _ coeffs reversed collect: [:c | c / 2.0].
	gTilde _ coeffs collect: [:c | c / 2.0].
	1 to: gTilde size by: 2 do:
		[:i | gTilde at: i put: (gTilde at: i) negated].

	"Form the low pass and high pass filters for reconstruction"
	h _ coeffs copy.
	g _ coeffs reversed.
	2 to: g size by: 2 do:
		[:i | g at: i put: (g at: i) negated]
! !


!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:19'!
coeffs
	"Return all coefficients neede to reconstruct the original samples"
	| header csize strm |
	header _ Array with: nSamples with: nLevels with: alpha with: beta.
	csize _ header size.
	1 to: nLevels do: [:i | csize _ csize + (transform at: i*2) size].
	csize _ csize + (transform at: nLevels*2-1) size.
	coeffs _ Array new: csize.
	strm _ WriteStream on: coeffs.
	strm nextPutAll: header.
	1 to: nLevels do: [:i | strm nextPutAll: (transform at: i*2)].
	strm nextPutAll: (transform at: nLevels*2-1).
	^ coeffs! !

!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:23'!
coeffs: coeffArray
	"Initialize this instance from the given coeff array (including header)."
	| header strm |
	strm _ ReadStream on: coeffArray.
	header _ strm next: 4.
	self nSamples: header first nLevels: header second.
	self setAlpha: header third beta: header fourth.
	1 to: nLevels do: [:i | transform at: i*2 put: (strm next: (transform at: i*2) size)].
	transform at: nLevels*2-1 put: (strm next: (transform at: nLevels*2-1) size).
	strm atEnd ifFalse: [self error: 'Data size error'].
! !

!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:26'!
samples
	^ samples copyFrom: 1 to: nSamples! !

!FWT methodsFor: 'access' stamp: 'di 10/31/1998 12:25'!
samples: anArray
	1 to: anArray size do:
		[:i | samples at: i put: (anArray at: i)].
	nSamples+1 to: nSamples+5 do:
		[:i | samples at: i put: 0.0]! !


!FWT methodsFor: 'computation' stamp: 'di 10/31/1998 09:20'!
convolveAndDec: inData dataLen: inLen filter: filter out: outData
	"convolve the input sequence with the filter and decimate by two"
	| filtLen offset outi dotp |
	filtLen _ filter size.
	outi _ 1.
	1 to: inLen+9 by: 2 do:
		[:i | 
		i < filtLen
		ifTrue:
			[dotp _ self dotpData: inData endIndex: i filter: filter
						start: 1 stop: i inc: 1]
		ifFalse:
			[i > (inLen+5)
			ifTrue:
				[offset _ i - (inLen+5).
				dotp _ self dotpData: inData endIndex: inLen+5 filter: filter
						start: 1+offset stop: filtLen inc: 1]
			ifFalse:
				[dotp _ self dotpData: inData endIndex: i filter: filter
						start: 1 stop: filtLen inc: 1]].
		outData at: outi put: dotp.
		outi _ outi + 1]! !

!FWT methodsFor: 'computation' stamp: 'ls 10/10/1999 13:13'!
convolveAndInt: inData dataLen: inLen filter: filter sumOutput:
sumOutput into: outData
	"insert zeros between each element of the input sequence and
	   convolve with the filter to interpolate the data"
	| outi filtLen oddTerm evenTerm j |
	outi _ 1.
	filtLen _ filter size.

	"every other dot product interpolates the data"
	filtLen // 2 to: inLen + filtLen - 2 do:
		[:i |
		oddTerm _ self dotpData: inData endIndex: i filter: filter
									start: 2 stop: filter size inc: 2.
		evenTerm _ self dotpData: inData endIndex: i+1 filter: filter
									start: 1 stop: filter size inc: 2.
		sumOutput
			ifTrue:
				["summation with previous convolution if true"
				outData at: outi put: (outData at: outi) + oddTerm.
				outData at: outi+1 put: (outData at: outi+1) + evenTerm]
			ifFalse:
				["first convolution of pair if false"
				outData at: outi put: oddTerm.
				outData at: outi+1 put: evenTerm].
		outi _ outi + 2].

	"Ought to be able to fit this last term into the above loop."
	j _ inLen + filtLen - 1.
	oddTerm _ self dotpData: inData endIndex: j filter: filter
									start: 2 stop: filter size inc: 2.
	sumOutput
		ifTrue: [outData at: outi put: (outData at: outi) + oddTerm]
		ifFalse: [outData at: outi put: oddTerm].
! !

!FWT methodsFor: 'computation' stamp: 'di 10/31/1998 12:55'!
dotpData: data endIndex: endIndex filter: filter start: start stop: stop inc: inc
	| sum i j |
	sum _ 0.0.
	j _ endIndex.
	i _ start.
	[i <= stop] whileTrue:
		[sum _ sum + ((data at: j) * (filter at: i)).
		i _ i + inc.
		j _ j - 1].
	^ sum! !

!FWT methodsFor: 'computation' stamp: 'di 10/30/1998 15:53'!
transformForward: forward
	| inData inLen outData |
	forward
	ifTrue:
		["first InData is input signal, following are intermediate approx coefficients"
		inData _ samples.  inLen _ nSamples.
		1 to: nLevels do:
			[:i |
			self convolveAndDec: inData dataLen: inLen
					filter: hTilde out: (transform at: 2*i-1).
			self convolveAndDec: inData dataLen: inLen
					filter: gTilde out: (transform at: 2*i).
			inData _ transform at: 2*i-1.  inLen _ inLen // 2]]
	ifFalse:
		[inLen _ nSamples >> nLevels.
		"all but last outData are next higher intermediate approximations,
		last is final reconstruction of samples"
		nLevels to: 1 by: -1 do:
			[:i |
			outData _ i = 1 ifTrue: [samples]
						ifFalse: [transform at: 2*(i-1)-1].
			self convolveAndInt: (transform at: 2*i-1) dataLen: inLen
					filter: h sumOutput: false into: outData.
			self convolveAndInt: (transform at: 2*i) dataLen: inLen
					filter: g sumOutput: true into: outData.
			inLen _ inLen * 2]]
! !


!FWT methodsFor: 'testing' stamp: 'di 10/31/1998 12:25'!
doWaveDemo  "FWT new doWaveDemo"
	"Printing the above should yield a small number -- I get 1.1e-32"
	| originalData |
	self nSamples: 312 nLevels: 3.
	self setAlpha: 0.0 beta: 0.0.

	"Install a sine wave as sample data"
	self samples: ((1 to: nSamples) collect: [:i | ((i-1) * 0.02 * Float pi) sin]).
	originalData _ samples copy.
	FFT new plot: (samples copyFrom: 1 to: nSamples) in: (0@0 extent: nSamples@100).

	"Transform forward and plot the decomposition"
	self transformForward: true.
	transform withIndexDo:
		[:w :i |
		FFT new plot: (w copyFrom: 1 to: w size-5)
			in: (i-1\\2*320@(i+1//2*130) extent: (w size-5)@100)].

	"Test copy out and read in the transform coefficients"
	self coeffs: self coeffs.

	"Ttransform back, plot the reconstruction, and return the error figure"
	self transformForward: false.
	FFT new plot: (samples copyFrom: 1 to: nSamples) in: (320@0 extent: nSamples@100).
	^ self meanSquareError: originalData! !

!FWT methodsFor: 'testing' stamp: 'di 10/30/1998 15:58'!
meanSquareError: otherData
	"Return the mean-square error between the current sample array and
	some other data, presumably to evaluate a compression scheme."
	| topSum bottomSum pointDiff |
	topSum _ bottomSum _ 0.0.
	1 to: nSamples do:
		[:i |  pointDiff _ (samples at: i) - (otherData at: i).
		topSum _ topSum + (pointDiff * pointDiff).
		bottomSum _ bottomSum + ((otherData at: i) * (otherData at: i))].
	^ topSum / bottomSum! !

!FWT methodsFor: 'testing' stamp: 'di 10/31/1998 22:17'!
viewPhiAndPsi  "(FWT new nSamples: 256 nLevels: 6) viewPhiAndPsi"
	"View the scaling function and mother wavelets for this transform"
	| p |
	Display fillWhite: (0@0 extent: 300@300).
	Display border: (0@0 extent: 300@300) width: 2.
	[Sensor anyButtonPressed] whileFalse:
		["Move mouse around in the outer rectangle to explore"
		p _ Sensor cursorPoint min: 300@300.
		self setAlpha: (p x - 150) / 150.0 * Float pi
				beta: (p y - 150) / 150.0 * Float pi.
		'alpha=', (alpha roundTo: 0.01) printString, '   ',
			'beta=', (beta roundTo: 0.01) printString, '    ' displayAt: 50@5.
		transform do: [:w | w atAllPut: 0.0].
		(transform at: transform size - 1) at: (nSamples>>nLevels) put: 1.0.
		self transformForward: false.
		FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@30 extent: nSamples@100).

		transform do: [:w | w atAllPut: 0.0].
		(transform at: transform size) at: (nSamples>>nLevels) put: 1.0.
		self transformForward: false.
		FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@170 extent: nSamples@100)].
	Sensor waitNoButton! !
Object subclass: #FXBlt
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap sourceMap destMap warpQuad warpQuality sourceKey destKey sourceAlpha tallyMap raiseErrors '
	classVariableNames: 'CachedFontColorMaps RecursionLock '
	poolDictionaries: ''
	category: 'Graphics-FXBlt'!
!FXBlt commentStamp: '<historical>' prior: 0!
"Copy all methods from BitBlt"
| from to |
from _ BitBlt class.
to _ FXBlt class.
from selectorsDo:[:sel|
	to compile: (from sourceCodeAt: sel) classified: (from organization categoryOfElement: sel)].


Instance variables:
	destForm	<Form>	Target form
	sourceForm	<Form>	Source form
	pattern		<Bitmap>	Fill or mask pattern
	combinationRule	<Integer>	Describes the operation to perform
	destRect		<Rectangle>	Destination rectangle of operation
	clipRect		<Rectangle>	Destination clip rectangle of operation
	sourceOrigin	<Point>	Offset in source form
	sourceMap	<ColorMap>	Mapping from source pixels into 'operational depth'
	destMap		<ColorMap>	Mapping from dest pixels into 'operational depth'
	colorMap	<ColorMap>	Mapping from 'operational depth' into destination depth
	warpQuad	<Array of: Integer>	Warp rectangle
	warpQuality	<Integer>	Sampling rate for warps
	sourceKey	<Integer>	Source color key
	destKey		<Integer>	Destination color key
	sourceAlpha	<Integer>	Constant source alpha
	tallyMap	<Bitmap>		Map for tallying pixels.
!


!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipHeight
	^clipHeight! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipHeight: anInteger 
	"Set the receiver's clipping area height to be the argument, anInteger."

	clipHeight _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipRect
	"Answer the receiver's clipping area rectangle."

	^clipX @ clipY extent: clipWidth @ clipHeight! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 10/4/2000 16:37'!
clipRect: aRectangle 
	"Set the receiver's clipping area rectangle to be the argument, aRectangle."

	clipX _ aRectangle left truncated.
	clipY _ aRectangle top truncated.
	clipWidth _ aRectangle right truncated - clipX.
	clipHeight _ aRectangle bottom truncated - clipY.! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipWidth
	^clipWidth! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipWidth: anInteger 
	"Set the receiver's clipping area width to be the argument, anInteger."

	clipWidth _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipX
	^clipX! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipX: anInteger 
	"Set the receiver's clipping area top left x coordinate to be the argument, 
	anInteger."

	clipX _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipY
	^clipY! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
clipY: anInteger 
	"Set the receiver's clipping area top left y coordinate to be the argument, 
	anInteger."

	clipY _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
colorMap
	^ colorMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/17/2000 21:54'!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	colorMap _ map.
	"As long as we need to fix problems with colorMaps"
	map ifNotNil:[
		(map isKindOf: ColorMap) ifFalse:[
			map size < 256 ifTrue:[
				colorMap _ ColorMap shifts: nil masks: nil colors: map.
			] ifFalse:[ sourceForm 
					ifNil:["Can't fix -- ignore". colorMap _ nil]
					ifNotNil:[colorMap _ sourceForm colormapIfNeededFor: destForm]]]].
! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
combinationRule
	^combinationRule! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
combinationRule: anInteger 
	"Set the receiver's combination rule to be the argument, anInteger, a 
	number in the range 0-15."

	combinationRule _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destForm
	^ destForm! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destForm: aForm
	destForm _ aForm! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 23:37'!
destMap
	^destMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 23:37'!
destMap: aColorMap
	destMap _ aColorMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destOrigin: aPoint 
	"Set the receiver's destination top left coordinates to be those of the 
	argument, aPoint."

	destX _ aPoint x.
	destY _ aPoint y! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destRect
	"The rectangle we are about to blit to or just blitted to.  "

	^ destX @ destY extent: width @ height! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destRect: aRectangle 
	"Set the receiver's destination form top left coordinates to be the origin of 
	the argument, aRectangle, and set the width and height of the receiver's 
	destination form to be the width and height of aRectangle."

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

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destX: anInteger 
	"Set the top left x coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destX _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destX: x destY: y width: w height: h
	"Combined init message saves 3 sends from DisplayScanner"
	destX _ x.
	destY _ y.
	width _ w.
	height _ h.! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
destY: anInteger 
	"Set the top left y coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destY _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
fillColor
	^ halftoneForm! !

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

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

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
height: anInteger 
	"Set the receiver's destination form height to be the argument, anInteger."

	height _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/21/2000 22:06'!
isFXBlt
	^true! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/13/2000 16:31'!
raiseErrors: aBoolean
	raiseErrors _ aBoolean! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceForm

	^ sourceForm! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceForm: aForm 
	"Set the receiver's source form to be the argument, aForm."

	sourceForm _ aForm! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/17/2000 22:06'!
sourceKey
	^sourceKey! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/17/2000 22:06'!
sourceKey: aKey
	sourceKey _ aKey! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 23:37'!
sourceMap
	^sourceMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 23:37'!
sourceMap: aColorMap
	sourceMap _ aColorMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceOrigin: aPoint 
	"Set the receiver's source form coordinates to be those of the argument, 
	aPoint."

	sourceX _ aPoint x.
	sourceY _ aPoint y! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceRect: aRectangle 
	"Set the receiver's source form top left x and y, width and height to be 
	the top left coordinate and extent of the argument, aRectangle."

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

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceX: anInteger 
	"Set the receiver's source form top left x to be the argument, anInteger."

	sourceX _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceX: sx sourceY: sy destX: x destY: y width: w height: h
	"Combined init message saves sends from DisplayScanner"
	sourceX _ sx.
	sourceY _ sy.
	destX _ x.
	destY _ y.
	width _ w.
	height _ h.! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
sourceY: anInteger 
	"Set the receiver's source form top left y to be the argument, anInteger."

	sourceY _ anInteger! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'!
tallyMap
	"Return the map used for tallying pixels"
	^tallyMap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'!
tallyMap: aBitmap
	"Install the map used for tallying pixels"
	tallyMap _ aBitmap! !

!FXBlt methodsFor: 'accessing' stamp: 'ar 2/9/2000 19:21'!
width: anInteger 
	"Set the receiver's destination form width to be the argument, anInteger."

	width _ anInteger! !


!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copy: destRectangle from: sourcePt in: srcForm
	| destOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 21:12'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	srcForm == nil ifFalse:
		[colorMap _ srcForm colormapIfNeededFor: destForm].
	^ self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule 
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.		"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/19/2000 20:18'!
copyBits
	"Primitive. Perform the movement of bits from the source form to the 
	destination form. Fail if any variables are not of the right type (Integer, 
	Float, or Form) or if the combination rule is not implemented. 
	In addition to the original 16 combination rules, this BitBlt supports
	16	fail (to simulate paint)
	17	fail (to simulate mask)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	rgbDiff: sourceWord with: destinationWord
	23	tallyIntoMap: destinationWord
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
"
	| result |
	result _ self primCopyBits.
	result == nil ifFalse:[^result].
raiseErrors == true ifTrue:[^self primitiveFailed].
	self recover ifTrue:[^self copyBits].

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

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

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copyBitsSimulated
	^FXBltSimulation copyBitsFrom: self.! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 21:11'!
copyBitsTranslucent: factor
	"This entry point to BitBlt supplies an extra argument to specify translucency
	for operations 30 and 31.  The argument must be an integer between 0 and 255."
	sourceAlpha _ factor.
	sourceForm ifNotNil:[sourceMap _ sourceForm colormapToARGB].
	destMap _ destForm colormapToARGB.
	colorMap _ destForm colormapFromARGB.
	^self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 20:41'!
copyForm: srcForm to: destPt rule: rule
	^ self copyForm: srcForm to: destPt rule: rule
		colorMap: (srcForm colormapIfNeededFor: destForm)! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copyForm: srcForm to: destPt rule: rule color: color
	sourceForm _ srcForm.
	halftoneForm _ color.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copyForm: srcForm to: destPt rule: rule colorMap: map
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	colorMap _ map.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 19:21'!
copyForm: srcForm to: destPt rule: rule fillColor: color
	sourceForm _ srcForm.
	self fillColor: color.	"sets halftoneForm"
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 2/9/2000 20:41'!
copyFrom: sourceRectangle in: srcForm to: destPt
	| sourceOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destX _ destPt x.
	destY _ destPt y.
	sourceOrigin _ sourceRectangle origin.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ sourceRectangle width.
	height _ sourceRectangle height.
	colorMap _ srcForm colormapIfNeededFor: destForm.
	self copyBits! !

!FXBlt methodsFor: 'copying' stamp: 'ar 5/25/2000 17:40'!
displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta
	destY _ aPoint y.
	destX _ aPoint x.
	^self primDisplayString: aString from: startIndex to: stopIndex
			map: font characterToGlyphMap xTable: font xTable
			kern: kernDelta.! !

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

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

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


!FXBlt methodsFor: 'private' stamp: 'hg 6/27/2000 13:13'!
cachedFontColormapFrom: sourceDepth to: destDepth

	| srcIndex map |
	CachedFontColorMaps class == Array 
		ifFalse: [CachedFontColorMaps _ (1 to: 9) collect: [:i | Array new: 32]].
	srcIndex _ sourceDepth.
	sourceDepth > 8 ifTrue: [srcIndex _ 9].
	(map _ (CachedFontColorMaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [^ map].

	map _ (Color cachedColormapFrom: sourceDepth to: destDepth) copy.
	(CachedFontColorMaps at: srcIndex) at: destDepth put: map.
	^ map
! !

!FXBlt methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
copyBitsAgain
	"Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 'primitiveCopyBits' module: 'BitBltPlugin'>
	self primitiveFailed! !

!FXBlt methodsFor: 'private' stamp: 'ar 2/9/2000 19:21'!
copyBitsFrom: x0 to: x1 at: y
	destX _ x0.
	destY _ y.
	sourceX _ x0.
	width _ (x1 - x0).
	self copyBits.! !

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

!FXBlt methodsFor: 'private' stamp: 'ar 5/26/2000 16:39'!
getPluginName
	"Private. Return the name of the plugin representing FXBlt.
	Used for dynamically switching between different BB representations only."
	^'FXBltPlugin'! !

!FXBlt methodsFor: 'private' stamp: 'hg 6/27/2000 13:14'!
installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor
	| lastSourceDepth |
	sourceForm ifNotNil:[lastSourceDepth _ sourceForm depth].
	sourceForm _ aStrikeFont glyphs.
	(colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse:
		["Set up color map for a different source depth (color font)"
		"Uses caching for reasonable efficiency"
		colorMap _ self cachedFontColormapFrom: sourceForm depth to: destForm depth.
		colorMap at: 1 put: (backgroundColor pixelValueForDepth: destForm depth).
		self colorMap: colorMap].
	sourceForm depth = 1 ifTrue:
		[colorMap colors at: 2 put: (foregroundColor pixelValueForDepth: destForm depth).
		"Ignore any halftone pattern since we use a color map approach here"
		halftoneForm _ nil].
	sourceY _ 0.
	height _ aStrikeFont height.
! !

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

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

!FXBlt methodsFor: 'private' stamp: 'ar 5/25/2000 17:14'!
primCopyBits
	<primitive: 'primitiveCopyBits' module: 'FXBltPlugin'>
	^nil "indicates error"! !

!FXBlt methodsFor: 'private' stamp: 'ar 5/25/2000 17:21'!
primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta
	| ascii glyph |
	<primitive:'primitiveDisplayString' module:'FXBltPlugin'>
	startIndex to: stopIndex do:[:charIndex|
		ascii _ (aString at: charIndex) asciiValue.
		glyph _ glyphMap at: ascii + 1.
		sourceX _ xTable at: glyph + 1.
		width _ (xTable at: glyph + 2) - sourceX.
		self copyBits.
		destX _ destX + width + kernDelta.
	].! !

!FXBlt methodsFor: 'private' stamp: 'ar 5/25/2000 17:13'!
recover
	"Recover after a BitBlt operation has failed. Return true if the
	copyBits operation should be tried again."

	"As long as we need to fix problems with colorMaps"
	colorMap ifNotNil:[
		(colorMap isKindOf: ColorMap) ifFalse:[
			colorMap size < 256 ifTrue:[
				colorMap _ ColorMap shifts: nil masks: nil colors: colorMap.
			] ifFalse:[ sourceForm 
					ifNil:["Can't fix -- ignore". colorMap _ nil]
					ifNotNil:[colorMap _ sourceForm colormapIfNeededFor: destForm]].
		^true "try again"]].

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

	^false "unable to recover"! !

!FXBlt methodsFor: 'private' stamp: 'ar 2/9/2000 19:21'!
setDestForm: df
	| bb |
	bb _ df boundingBox.
	destForm _ df.
	clipX _ bb left.
	clipY _ bb top.
	clipWidth _ bb width.
	clipHeight _ bb height! !

!FXBlt methodsFor: 'private' stamp: 'ar 2/9/2000 20:40'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

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

!FXBlt methodsFor: 'private' stamp: 'ar 2/12/2000 19:51'!
traceProblem: aString from: aContext
	RecursionLock == true ifTrue:[^self].
	RecursionLock _ true.
	Transcript cr; show: aString; cr; show: aContext shortStack.
	RecursionLock _ false.! !


!FXBlt methodsFor: 'line drawing' stamp: 'ar 2/9/2000 19:21'!
drawFrom: startPoint to: stopPoint 
	
	 ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! !

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

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

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


!FXBlt methodsFor: 'warping' stamp: 'ar 2/22/2000 17:13'!
cellSize
	^warpQuality! !

!FXBlt methodsFor: 'warping' stamp: 'ar 2/10/2000 00:16'!
cellSize: aNumber
	warpQuality _ aNumber.! !

!FXBlt methodsFor: 'warping' stamp: 'ar 2/22/2000 17:14'!
copyQuad: pts toRect: destRect
	self sourceQuad: pts destRect: destRect.
	self warpBits! !

!FXBlt methodsFor: 'warping' stamp: 'ar 5/25/2000 22:05'!
sourceForm: srcForm destRect: dstRectangle
	"Set up a WarpBlt from the entire source Form to the given destination rectangle."
	| w h |
	sourceForm _ srcForm.
	sourceX _ sourceY _ 0.
	destX _ dstRectangle left.
	destY _ dstRectangle top.
	width _ dstRectangle width.
	height _ dstRectangle height.
	w _ srcForm width.
	h _ srcForm height.
	(w = width and:[h = height]) ifTrue:[
		"Don't need no stinking warp"
		warpQuad _ nil
	] ifFalse:[
		"Oh well ... "
		w _ 16384 * (w - 1).
		h _ 16384 * (h - 1).
		warpQuad _ Array
			with: 0@0 with: 0@h
			with: w@h with: w@0.
	].! !

!FXBlt methodsFor: 'warping' stamp: 'ar 2/22/2000 17:21'!
sourceQuad: pts destRect: aRectangle
	| fixedPt1 |
	sourceX _ sourceY _ 0.
	self destRect: aRectangle.
	fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0].
	warpQuad _ pts collect:[:pt| pt * fixedPt1].! !

!FXBlt methodsFor: 'warping' stamp: 'ar 2/22/2000 19:35'!
warpBits
	warpQuality ifNil:[warpQuality _ 1].
	warpQuality > 1 ifTrue:[
		"Must install source map"
		sourceMap _ sourceForm colormapToARGB.
		colorMap _ destForm colormapFromARGB.
	].
	self copyBits! !

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

FXBlt class
	instanceVariableNames: ''!

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/9/2000 19:48'!
alphaBlendDemo
	"To run this demo, use...
		Display restoreAfter: [FXBlt alphaBlendDemo]	
	Displays 10 alphas, then lets you paint.  Option-Click to stop painting."

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

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

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

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

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

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

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

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

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

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 18:16'!
antiAliasDemo 
	"To run this demo, use...
		Display restoreAfter: [FXBlt antiAliasDemo]
	Goes immediately into on-screen paint mode.  Option-Click to stop painting."

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

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

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

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

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

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

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

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

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

	"FXBlt exampleOne"! !

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

	"FXBlt exampleTwo"! !

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 17:22'!
warpTest1   "Display restoreAfter: [FXBlt warpTest1]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p ext |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext)]! !

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 17:23'!
warpTest12   "Display restoreAfter: [FXBlt warpTest12]"
	"Just like test1, but comparing smooth to non-smooth warps"
	| warp pts r1 p0 p ext warp2 |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 2;  "installs a colormap"
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	warp2 _ (self toForm: Display)
		clipRect: ((0@0 extent: r1 extent*5) translateBy: 200@0);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext).
		warp2 copyQuad: pts toRect: ((r1 extent*5-ext//2 extent: ext) translateBy: 200@0).
		]! !

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 17:31'!
warpTest3   "Display restoreAfter: [FXBlt warpTest3]"

	"The Squeak Release Mandala - 9/23/96 di"

	"Move the mouse near the center of the square.
	Up and down affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	warp _ (self toForm: Display)
		clipRect: box;
		sourceForm: Display;
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 17:32'!
warpTest4   "Display restoreAfter: [FXBlt warpTest4]"

	"The Squeak Release Mandala - 9/23/96 di
	This version does smoothing"

	"Move the mouse near the center ofhe square.
	Up and dn affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	warp _ (self toForm: Display)
		clipRect: box;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!FXBlt class methodsFor: 'examples' stamp: 'ar 2/22/2000 17:33'!
warpTest5   "Display restoreAfter: [FXBlt warpTest5]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle fromUser.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 1;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		warp copyQuad: pts toRect: (r1 translateBy: r1 width@0)]! !


!FXBlt class methodsFor: 'form rotation' stamp: 'ar 2/22/2000 17:35'!
rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize
	"Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original."

	| srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc |
	srcRect _ srcForm boundingBox.
	center _ srcRect center.
	radians _ angleInDegrees degreesToRadians.
	dstOrigin _ dstCorner _ center.
	srcRect corners do: [:corner |
		"find the limits of a rectangle that just encloses the rotated
		 original; in general, this rectangle will be larger than the
		 original (e.g., consider a square rotated by 45 degrees)"
		p _ ((corner - center) scaleBy: scalePoint) + center.
		p _ (p rotateBy: radians about: center) rounded.
		dstOrigin _ dstOrigin min: p.
		dstCorner _ dstCorner max: p].

	"rotate the enclosing rectangle back to get the source quadrilateral"
	dstRect _ dstOrigin corner: dstCorner.
	inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y).
	quad _ dstRect innerCorners collect: [:corner |
		p _ corner rotateBy: radians negated about: center.
		((p - center) scaleBy: inverseScale) + center].

	"make a Form to hold the result and do the rotation"
	warpSrc _ srcForm.
	(srcForm isKindOf: ColorForm)
		ifTrue: [
			cellSize > 1
				ifTrue: [
					warpSrc _ Form extent: srcForm extent depth: 16.
					srcForm displayOn: warpSrc.
					dstForm _ Form extent: dstRect extent depth: 16]  "use 16-bit depth to allow smoothing"
				ifFalse: [
					dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]]
		ifFalse: [
			dstForm _ srcForm class extent: dstRect extent depth: srcForm depth].

	(self toForm: dstForm)
		sourceForm: warpSrc;
		colorMap: (dstForm colormapIfNeededFor: warpSrc);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint;
		copyQuad: quad toRect: dstForm boundingBox.

	(dstForm isKindOf: ColorForm) ifTrue: [dstForm colors: srcForm colors copy].
	newCenter _ (center rotateBy: radians about: aPoint) truncated.
	^ Array with: dstForm with: dstRect origin + (newCenter - center)
! !


!FXBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:04'!
asGrafPort
	"Return the GrafPort associated with the receiver"
	^FXGrafPort! !

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

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

!FXBlt class methodsFor: 'instance creation' stamp: 'ar 2/9/2000 19:48'!
destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

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

!FXBlt class methodsFor: 'instance creation' stamp: 'ar 2/9/2000 19:48'!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

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

!FXBlt class methodsFor: 'instance creation' stamp: 'ar 2/9/2000 19:48'!
toForm: aForm
	^ self new setDestForm: aForm! !


!FXBlt class methodsFor: 'benchmarks' stamp: 'ar 2/9/2000 19:48'!
benchDiffsFrom: before to: afterwards
	"Given two outputs of BitBlt>>benchmark show the relative improvements."
	| old new log oldLine newLine oldVal newVal improvement |
	log _ WriteStream on: String new.
	old _ ReadStream on: before.
	new _ ReadStream on: afterwards.
	[old atEnd or:[new atEnd]] whileFalse:[
		oldLine _ old upTo: Character cr.
		newLine _ new upTo: Character cr.
		(oldLine includes: Character tab) ifTrue:[
			oldLine _ ReadStream on: oldLine.
			newLine _ ReadStream on: newLine.
			Transcript cr; show: (oldLine upTo: Character tab); tab.
			log cr; nextPutAll: (newLine upTo: Character tab); tab.

			[oldLine skipSeparators. newLine skipSeparators.
			oldLine atEnd] whileFalse:[
				oldVal _ Integer readFrom: oldLine.
				newVal _ Integer readFrom: newLine.
				improvement _ oldVal asFloat / newVal asFloat roundTo: 0.1.
				Transcript show: improvement printString; tab.
				log print: improvement; tab].
		] ifFalse:[
			Transcript cr; show: oldLine.
			log cr; nextPutAll: oldLine.
		].
	].
	^log contents! !

!FXBlt class methodsFor: 'benchmarks' stamp: 'ar 5/25/2000 17:58'!
benchmark		"FXBlt benchmark"
	"Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else.
	Attention: *this*may*take*a*while*"
	| bb source dest destRect log t |
	log _ WriteStream on: String new.
	destRect _ 0@0 extent: 600@600.
	"Form paint/Form over - the most common rules"
	#( 25 3 ) do:[:rule|
		Transcript cr; show:'---- Combination rule: ', rule printString,' ----'.
		log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'.
		#(1 2 4 8 16 32) do:[:destDepth|
			dest _ nil.
			dest _ Form extent: destRect extent depth: destDepth.
			Transcript cr.
			log cr.
			#(1 2 4 8 16 32) do:[:sourceDepth|
				Transcript cr; show: sourceDepth printString, ' => ', destDepth printString.
				log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString.
				source _ nil. bb _ nil.
				source _ Form extent: destRect extent depth: sourceDepth.
				(source getCanvas) fillOval: destRect color: Color yellow borderWidth: 30 borderColor: Color black.
				bb _ FXBlt toForm: dest.
				bb raiseErrors: true.
				bb sourceForm: source.
				bb sourceRect: source boundingBox.
				bb destRect: destRect.
				bb colorMap: (source colormapIfNeededFor: dest).
				bb combinationRule: rule.

				"Measure speed of copyBits"
				t _ Time millisecondsToRun:[bb copyBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				bb sourceForm: source destRect: source boundingBox.

				"Measure speed of 1x1 warpBits"
				bb cellSize: 1.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 2x2 warpBits"
				bb cellSize: 2.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.

				"Measure speed of 3x3 warpBits"
				bb cellSize: 3.
				t _ Time millisecondsToRun:[bb warpBits].
				Transcript tab; show: t printString.
				log tab; nextPutAll: t printString.
			].
		].
	].
	^log contents! !


!FXBlt class methodsFor: 'private' stamp: 'ar 2/9/2000 19:50'!
exampleAt: originPoint rule: rule fillColor: mask 
	"This builds a source and destination form and copies the source to the
	destination using the specifed rule and mask. It is called from the method
	named exampleOne."

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

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

	d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
	aBitBlt _ self
		destForm: Display
		sourceForm: s
		fillColor: mask
		combinationRule: rule
		destOrigin: originPoint + (s extent // (2 @ 1))
		sourceOrigin: 0 @ 0
		extent: s extent
		clipRect: Display computeBoundingBox.
	aBitBlt copyBits.
	border 
		displayOn: Display at: originPoint + (s extent // (2 @ 1))
		rule: Form under.
   
	"BitBlt exampleAt: 100@100 rule: Form over fillColor: Color gray"! !

!FXBlt class methodsFor: 'private' stamp: 'ar 2/10/2000 00:34'!
swapBytesIn: aBitmap
	"Byte-swap the contents of aBitmap"
	"Notes: 
		* We could setup BitBlt so that it uses aBitmap as source 
		  but it's faster without a source
		* We could move the conversion into the destMap but
		  I'm planning to add a color cache for conversions
		  and this cache will definitely be used for colorMap."
	| bb form |
	form _ Form extent: aBitmap size @ 1 depth: 32 bits: aBitmap.
	bb _ self toForm: form.
	bb fillColor: (Bitmap with: 16rFFFFFFFF).
	"No conversion when reading the pixels"
	bb destMap:(ColorMap
			shifts: #(0 0 0 0)
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)). "<- so mask is identity!!"
	"But do swap when writing"
	bb colorMap:(ColorMap
			shifts: #(-24 -8 8 24)
			masks: #(16rFF000000 16rFF0000 16rFF00 16rFF)).
	"Set the combination rule to #destinationWord:with: so
	that the result is just the word we have in destForm.
	Only byte swapped."
	bb combinationRule: 5.
	"And swap those bytes"
	bb copyBits.! !
InterpreterPlugin subclass: #FXBltSimulation
	instanceVariableNames: 'bitBltOop destForm sourceForm halftoneForm combinationRule destX destY sourceX sourceY width height clipX clipY clipWidth clipHeight destBits destWidth destHeight destDepth destPitch destPPW destMSB destIndex destDelta sourceBits sourceWidth sourceHeight sourceDepth sourcePitch sourcePPW sourceMSB sourceIndex sourceDelta noColorMap colorMap cmMask cmShiftTable cmMaskTable noDestMap destMap dmMask dmShiftTable dmMaskTable noSourceMap sourceMap smMask smShiftTable smMaskTable tallyMap tallyMapSize sourceAlpha sourceAlphaKey destAlphaKey srcKeyMode dstKeyMode bitCount skew mask1 mask2 preload nWords destMask hDir vDir sx sy dx dy bbW bbH halftoneHeight noSource noHalftone halftoneBase srcBitShift dstBitShift pixelDepth cmCache affectedL affectedR affectedT affectedB opTable maskTable ditherMatrix4x4 ditherThresholds16 ditherValues16 hasSurfaceLock noWarp warpQuad warpQuality warpSrcShift warpSrcMask warpAlignShift warpAlignMask warpBitShiftTable unlockSurfaceFn querySurfaceFn lockSurfaceFn '
	classVariableNames: 'AllOnes AlphaIndex BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWidthIndex BinaryPoint BlueIndex ColorCacheMask ColorCacheSize FXDestKeyIndex FXDestMapIndex FXSourceAlphaIndex FXSourceKeyIndex FXSourceMapIndex FXTallyMapIndex FXWarpQuadIndex FXWarpQualityIndex FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex GreenIndex InvalidColorCacheEntry OpTable OpTableSize RedIndex '
	poolDictionaries: ''
	category: 'Graphics-FXBlt'!
!FXBltSimulation commentStamp: '<historical>' prior: 0!
This class implements BitBlt, much as specified in the Blue Book spec.

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

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

In addition to the original 16 combination rules, this BitBlt supports
	16	fail (for old paint mode)
	17	fail (for old mask mode)
	18	sourceWord + destinationWord
	19	sourceWord - destinationWord
	20	rgbAdd: sourceWord with: destinationWord
	21	rgbSub: sourceWord with: destinationWord
	22	OLDrgbDiff: sourceWord with: destinationWord
	23	OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary
	24	alphaBlend: sourceWord with: destinationWord
	25	pixPaint: sourceWord with: destinationWord
	26	pixMask: sourceWord with: destinationWord
	27	rgbMax: sourceWord with: destinationWord
	28	rgbMin: sourceWord with: destinationWord
	29	rgbMin: sourceWord bitInvert32 with: destinationWord
	30	alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg
	31	alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg
	32	rgbDiff: sourceWord with: destinationWord
	33	tallyIntoMap: destinationWord
	34	alphaBlendScaled: sourceWord with: destinationWord
	35	srcPaint: sourceWord with: destinationWord
	36	dstPaint: sourceWord with: destinationWord

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

To add a new rule to BitBlt...
	1.  add the new rule method or methods in the category 'combination rules' of BBSim
	2.  describe it in the class comment  of BBSim and in the class comment for BitBlt
	3.  add refs to initializeRuleTable in proper positions
	4.  add refs to initBBOpTable, following the pattern
!


!FXBltSimulation methodsFor: 'initialize' stamp: 'ar 5/25/2000 15:20'!
initBBOpTable
	self cCode: 'opTable[0+1] = (int)clearWordwith'.
	self cCode: 'opTable[1+1] = (int)bitAndwith'.
	self cCode: 'opTable[2+1] = (int)bitAndInvertwith'.
	self cCode: 'opTable[3+1] = (int)sourceWordwith'.
	self cCode: 'opTable[4+1] = (int)bitInvertAndwith'.
	self cCode: 'opTable[5+1] = (int)destinationWordwith'.
	self cCode: 'opTable[6+1] = (int)bitXorwith'.
	self cCode: 'opTable[7+1] = (int)bitOrwith'.
	self cCode: 'opTable[8+1] = (int)bitInvertAndInvertwith'.
	self cCode: 'opTable[9+1] = (int)bitInvertXorwith'.
	self cCode: 'opTable[10+1] = (int)bitInvertDestinationwith'.
	self cCode: 'opTable[11+1] = (int)bitOrInvertwith'.
	self cCode: 'opTable[12+1] = (int)bitInvertSourcewith'.
	self cCode: 'opTable[13+1] = (int)bitInvertOrwith'.
	self cCode: 'opTable[14+1] = (int)bitInvertOrInvertwith'.
	self cCode: 'opTable[15+1] = (int)destinationWordwith'.
	self cCode: 'opTable[16+1] = (int)destinationWordwith'.
	self cCode: 'opTable[17+1] = (int)destinationWordwith'.
	self cCode: 'opTable[18+1] = (int)addWordwith'.
	self cCode: 'opTable[19+1] = (int)subWordwith'.
	self cCode: 'opTable[20+1] = (int)rgbAddwith'.
	self cCode: 'opTable[21+1] = (int)rgbSubwith'.
	self cCode: 'opTable[22+1] = (int)OLDrgbDiffwith'.
	self cCode: 'opTable[23+1] = (int)OLDtallyIntoMapwith'.
	self cCode: 'opTable[24+1] = (int)alphaBlendwith'.
	self cCode: 'opTable[25+1] = (int)pixPaintwith'.
	self cCode: 'opTable[26+1] = (int)pixMaskwith'.
	self cCode: 'opTable[27+1] = (int)rgbMaxwith'.
	self cCode: 'opTable[28+1] = (int)rgbMinwith'.
	self cCode: 'opTable[29+1] = (int)rgbMinInvertwith'.
	self cCode: 'opTable[30+1] = (int)alphaBlendConstwith'.
	self cCode: 'opTable[31+1] = (int)alphaPaintConstwith'.
	self cCode: 'opTable[32+1] = (int)rgbDiffwith'.
	self cCode: 'opTable[33+1] = (int)tallyIntoMapwith'.
	self cCode: 'opTable[34+1] = (int)alphaBlendScaledwith'.
	self cCode: 'opTable[35+1] = (int)srcPaintwith'.
	self cCode: 'opTable[36+1] = (int)dstPaintwith'.
! !

!FXBltSimulation methodsFor: 'initialize' stamp: 'ar 5/25/2000 15:20'!
initialiseModule
	self export: true.
	self initBBOpTable.
	^true! !

!FXBltSimulation methodsFor: 'initialize' stamp: 'ar 5/25/2000 16:11'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	self export: true.
	self var: #aModuleName type: 'char *'.
	(aModuleName strcmp: 'SurfacePlugin') = 0 ifTrue:[
		"The surface plugin just shut down. How nasty."
		querySurfaceFn _ lockSurfaceFn _ unlockSurfaceFn _ 0.
	].! !


!FXBltSimulation methodsFor: 'primitives' stamp: 'ar 2/21/2000 20:24'!
primitiveCopyBits
	| rcvr |
	self export: true.
	self inline: false.
	rcvr _ interpreterProxy stackValue: interpreterProxy methodArgumentCount.
	(self loadBitBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	self copyBits.
	self showDisplayBits.! !

!FXBltSimulation methodsFor: 'primitives' stamp: 'ar 2/21/2000 20:24'!
primitiveDrawLoop
	"Invoke the line drawing primitive."
	| rcvr xDelta yDelta |
	self export: true.
	self inline: false.
	rcvr _ interpreterProxy stackValue: 2.
	xDelta _ interpreterProxy stackIntegerValue: 1.
	yDelta _ interpreterProxy stackIntegerValue: 0.
	(self loadBitBltFrom: rcvr) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifFalse:[
		self drawLoopX: xDelta Y: yDelta.
		self showDisplayBits].
	interpreterProxy failed ifFalse:[interpreterProxy pop: 2].! !

!FXBltSimulation methodsFor: 'primitives' stamp: 'ar 2/23/2000 21:39'!
primitiveVersion
	"Return the version of FXBlt"
	interpreterProxy pop: interpreterProxy methodArgumentCount+1.
	interpreterProxy pushInteger: self version.
! !


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

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

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

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/19/2000 20:50'!
fetchIntOrFloat: index ofObject: oop
	| fieldOop floatValue |
	self var: #floatValue declareC:'double floatValue'.
	fieldOop _ interpreterProxy fetchPointer: index ofObject: oop.
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	floatValue _ interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail. ^0].
	^floatValue asInteger! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 1/16/2000 21:26'!
fetchIntOrFloat: index ofObject: oop ifNil: defaultValue
	| fieldOop floatValue |
	self var: #floatValue declareC:'double floatValue'.
	fieldOop _ interpreterProxy fetchPointer: index ofObject: oop.
	(fieldOop = interpreterProxy nilObject) ifTrue:[^defaultValue].
	(interpreterProxy isIntegerObject: fieldOop)
		ifTrue:[^interpreterProxy integerValueOf: fieldOop].
	floatValue _ interpreterProxy floatValueOf: fieldOop.
	(-2147483648.0 <= floatValue and:[floatValue <= 2147483647.0])
		ifFalse:[interpreterProxy primitiveFail].
	^floatValue asInteger! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 1/16/2000 16:32'!
loadBitBltClipRect
	"Load the clipping rectangle from a BitBlt oop."
	self inline: true.
	clipX _ self fetchIntOrFloat: BBClipXIndex ofObject: bitBltOop ifNil: 0.
	clipY _ self fetchIntOrFloat: BBClipYIndex ofObject: bitBltOop ifNil: 0.
	clipWidth _ self fetchIntOrFloat: BBClipWidthIndex ofObject: bitBltOop ifNil: destWidth.
	clipHeight _ self fetchIntOrFloat: BBClipHeightIndex ofObject: bitBltOop ifNil: destHeight.
	interpreterProxy failed ifTrue: [^ false  "non-integer value"].
	clipX < 0 ifTrue: [clipWidth _ clipWidth + clipX.  clipX _ 0].
	clipY < 0 ifTrue: [clipHeight _ clipHeight + clipY.  clipY _ 0].
	clipX+clipWidth > destWidth ifTrue: [clipWidth _ destWidth - clipX].
	clipY+clipHeight > destHeight ifTrue: [clipHeight _ destHeight - clipY].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 1/16/2000 16:32'!
loadBitBltCombinationRule
	"Load the combination rule from a BitBlt oop"
	self inline: true.
	combinationRule _ interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.
	(interpreterProxy failed
		or: [combinationRule < 0 or: [combinationRule > (OpTableSize - 2)]])
		 ifTrue: [^ false  "operation out of range"].
	(combinationRule >= 16 and: [combinationRule <= 17])
		 ifTrue: [^ false  "fail for old simulated paint, erase modes"].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/13/2000 15:38'!
loadBitBltDestForm
	"Load the dest form for BitBlt. Return false if anything is wrong, true otherwise."
	| destBitsSize |
	self inline: true.
	destForm _ interpreterProxy fetchPointer: BBDestFormIndex ofObject: bitBltOop.
	((interpreterProxy isPointers: destForm) and: [
		(interpreterProxy slotSizeOf: destForm) >= 4])
			ifFalse: [^ false].
	destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
	destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
	destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
	(destWidth >= 0 and: [destHeight >= 0]) ifFalse: [^ false].
	destDepth _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
	(destDepth bitAnd: destDepth-1) = 0 ifFalse:[^false].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: destBits) ifTrue:[
		"Query for actual surface dimensions"
		(self queryDestSurface: (interpreterProxy integerValueOf: destBits))
			ifFalse:[^false].
		destPPW _ 32 // destDepth.
		destBits _ destPitch _ 0.
	] ifFalse:[
		destPPW _ 32 // destDepth.
		destPitch _ destWidth + (destPPW-1) // destPPW * 4.
		destBitsSize _ interpreterProxy byteSizeOf: destBits.
		((interpreterProxy isWordsOrBytes: destBits)
			and: [destBitsSize = (destPitch * destHeight)])
			ifFalse: [^ false].
		((interpreterProxy isWords: destBits) and:[
			(interpreterProxy fetchClassOf: destBits) = interpreterProxy classBitmap])
			ifTrue:[destMSB _ true]
			ifFalse:[destMSB _ false].
		"Skip header since external bits don't have one"
		destBits _ self cCoerce: (interpreterProxy firstIndexableField: destBits) to:'int'.
	].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 1/16/2000 16:32'!
loadBitBltDestRect
	"Load the destination rectangle from a BitBlt oop"
	self inline: true.
	destX _ self fetchIntOrFloat: BBDestXIndex ofObject: bitBltOop ifNil: 0.
	destY _ self fetchIntOrFloat: BBDestYIndex ofObject: bitBltOop ifNil: 0.
	width _ self fetchIntOrFloat: BBWidthIndex ofObject: bitBltOop ifNil: destWidth.
	height _ self fetchIntOrFloat: BBHeightIndex ofObject: bitBltOop ifNil: destHeight.
	^interpreterProxy failed not! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/22/2000 17:45'!
loadBitBltFrom: bbObj
	"Load context from BitBlt instance.  Return false if anything is amiss"
	| ok |
	self export: true.
	bitBltOop _ bbObj.
	ok _ self loadBitBltCombinationRule.
	ok ifFalse:[^false].
	ok _ self loadBitBltDestForm.
	ok ifFalse:[^false].
	ok _ self loadBitBltDestRect.
	ok ifFalse:[^false].
	ok _ self loadBitBltSourceForm.
	ok ifFalse:[^false].
	ok _ self loadHalftoneForm.
	ok ifFalse:[^false].
	ok _ self loadBitBltClipRect.
	ok ifFalse:[^false].
	ok _ self loadFXColorMap.
	ok ifFalse:[^false].
	ok _ self loadFXSourceMap.
	ok ifFalse:[^false].
	ok _ self loadFXWarpQuad.
	ok ifFalse:[^false].
	ok _ self loadFXWarpQuality.
	ok ifFalse:[^false].
	ok _ self loadFXSourceMap.
	ok ifFalse:[^false].
	ok _ self loadFXDestMap.
	ok ifFalse:[^false].
	ok _ self loadFXAlphaValues.
	ok ifFalse:[^false].
	ok _ self loadFXTallyMap.
	ok ifFalse:[^false].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/13/2000 15:39'!
loadBitBltSourceForm
	"Load the source form for BitBlt. Return false if anything is wrong, true otherwise."
	| sourceBitsSize |
	self inline: true.
	sourceForm _ interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.
	noSource _ self ignoreSourceOrHalftone: sourceForm.
	noSource ifTrue:[
		sourceX _ sourceY _ 0.
		^true].
	((interpreterProxy isPointers: sourceForm) and:[
		(interpreterProxy slotSizeOf: sourceForm) >= 4])
			ifFalse: [^ false].
	sourceX _ self fetchIntOrFloat: BBSourceXIndex ofObject: bitBltOop ifNil: 0.
	sourceY _ self fetchIntOrFloat: BBSourceYIndex ofObject: bitBltOop ifNil: 0.
	sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
	sourceWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: sourceForm.
	sourceHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: sourceForm.
	interpreterProxy failed ifTrue:[^false].
	(sourceWidth >= 0 and: [sourceHeight >= 0]) ifFalse: [^ false].
	sourceDepth _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
	(sourceDepth bitAnd: sourceDepth-1) = 0 ifFalse:[^false].
	"Ignore an integer bits handle for Display in which case 
	the appropriate values will be obtained by calling ioLockSurfaceBits()."
	(interpreterProxy isIntegerObject: sourceBits) ifTrue:[
		"Query for actual surface dimensions"
		(self querySourceSurface: (interpreterProxy integerValueOf: sourceBits))
			ifFalse:[^false].
		sourcePPW _ 32 // sourceDepth.
		sourceBits _ sourcePitch _ 0.
	] ifFalse:[
		sourcePPW _ 32 // sourceDepth.
		sourcePitch _ sourceWidth + (sourcePPW-1) // sourcePPW * 4.
		sourceBitsSize _ interpreterProxy byteSizeOf: sourceBits.
		((interpreterProxy isWordsOrBytes: sourceBits)
			and: [sourceBitsSize = (sourcePitch * sourceHeight)])
			ifFalse: [^ false].
		((interpreterProxy isWords: sourceBits) and:[
			(interpreterProxy fetchClassOf: sourceBits) = interpreterProxy classBitmap])
			ifTrue:[sourceMSB _ true]
			ifFalse:[sourceMSB _ false].
		"Skip header since external bits don't have one"
		sourceBits _ self cCoerce: (interpreterProxy firstIndexableField: sourceBits) to:'int'.
	].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/22/2000 15:16'!
loadFXAlphaValues
	"Load the source/destination transparency keys"
	| oop |
	self inline: true.
	oop _ interpreterProxy fetchPointer: FXSourceKeyIndex ofObject: bitBltOop.
	srcKeyMode _ (oop ~= interpreterProxy nilObject).
	srcKeyMode 
		ifTrue:[sourceAlphaKey _ self fetchIntOrFloat: FXSourceKeyIndex ofObject: bitBltOop]
		ifFalse:[sourceAlphaKey _ 0].
	oop _ interpreterProxy fetchPointer: FXDestKeyIndex ofObject: bitBltOop.
	dstKeyMode _ (oop ~= interpreterProxy nilObject).
	dstKeyMode 
		ifTrue:[destAlphaKey _ self fetchIntOrFloat: FXDestKeyIndex ofObject: bitBltOop]
		ifFalse:[destAlphaKey _ 0].
	sourceAlpha _ self fetchIntOrFloat: FXSourceAlphaIndex ofObject: bitBltOop ifNil: 255.
	^interpreterProxy failed not! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 22:56'!
loadFXColorMap
	"Load a color map from FXBlt"
	| oop cmSize |
	self inline: true.
	oop _ interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.
	oop = interpreterProxy nilObject ifTrue:[^noColorMap _ true].
	"We have a colorMap even though it might be that it's just an identity mapping"
	noColorMap _ false.
	((interpreterProxy isPointers: oop) 
		and:[(interpreterProxy slotSizeOf: oop) >= 3]) ifFalse:[^false].
	cmShiftTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 0 ofObject: oop).
	cmMaskTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 1 ofObject: oop).
	oop _ interpreterProxy fetchPointer: 2 ofObject: oop.
	oop = interpreterProxy nilObject 
		ifTrue:[cmSize _ cmMask _ 0]
		ifFalse:[(interpreterProxy isWords: oop) ifFalse:[^false].
				cmSize _ (interpreterProxy slotSizeOf: oop)].
	(cmSize bitAnd: cmSize - 1) = 0 ifFalse:[^false].
	cmSize = 0 
		ifTrue:[colorMap _ nil]
		ifFalse:[colorMap _ interpreterProxy firstIndexableField: oop.
				cmMask _ cmSize - 1].
	"Check if colorMap is just identity mapping for RGBA parts"
	(self isIdentityMap: cmShiftTable with: cmMaskTable)
		ifTrue:[ cmMaskTable _ cmShiftTable _ nil ].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 22:57'!
loadFXDestMap
	"Load a destination map from destForm to canonical 32bit RGBA values"
	| oop dmSize |
	self inline: true.
	oop _ interpreterProxy fetchPointer: FXDestMapIndex ofObject: bitBltOop.
	oop = interpreterProxy nilObject ifTrue:[^noDestMap _ true].
	"We have a destMap even though it might be that it's just an identity mapping"
	noDestMap _ false.
	((interpreterProxy isPointers: oop) 
		and:[(interpreterProxy slotSizeOf: oop) >= 3]) ifFalse:[^false].
	dmShiftTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 0 ofObject: oop).
	dmMaskTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 1 ofObject: oop).
	oop _ interpreterProxy fetchPointer: 2 ofObject: oop.
	oop = interpreterProxy nilObject 
		ifTrue:[dmSize _ dmMask _ 0]
		ifFalse:[(interpreterProxy isWords: oop) ifFalse:[^false].
				dmSize _ (interpreterProxy slotSizeOf: oop)].
	(dmSize bitAnd: dmSize - 1) = 0 ifFalse:[^false].
	dmSize = 0 
		ifTrue:[destMap _ nil]
		ifFalse:[destMap _ interpreterProxy firstIndexableField: oop.
				dmMask _ dmSize - 1].
	"Check if destMap is just identity mapping for RGBA parts"
	(self isIdentityMap: dmShiftTable with: dmMaskTable)
		ifTrue:[ dmMaskTable _ dmShiftTable _ nil ].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 19:35'!
loadFXShiftOrMaskFrom: mapOop
	self returnTypeC:'int *'.
	mapOop = interpreterProxy nilObject ifTrue:[^nil].
	((interpreterProxy isWords: mapOop) 
		and:[(interpreterProxy slotSizeOf: mapOop) = 4])
			ifFalse:[interpreterProxy primitiveFail. ^nil].
	^interpreterProxy firstIndexableField: mapOop! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 22:57'!
loadFXSourceMap
	"Load a source map from sourceForm to canonical 32bit RGBA values"
	| oop smSize |
	self inline: true.
	noSource ifTrue:[^true].
	oop _ interpreterProxy fetchPointer: FXSourceMapIndex ofObject: bitBltOop.
	oop = interpreterProxy nilObject ifTrue:[^noSourceMap _ true].
	"We have a sourceMap even though it might be that it's just an identity mapping"
	noSourceMap _ false.
	((interpreterProxy isPointers: oop) 
		and:[(interpreterProxy slotSizeOf: oop) >= 3]) ifFalse:[^false].
	smShiftTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 0 ofObject: oop).
	smMaskTable _ self loadFXShiftOrMaskFrom:
		(interpreterProxy fetchPointer: 1 ofObject: oop).
	oop _ interpreterProxy fetchPointer: 2 ofObject: oop.
	oop = interpreterProxy nilObject 
		ifTrue:[smSize _ smMask _ 0]
		ifFalse:[(interpreterProxy isWords: oop) ifFalse:[^false].
				smSize _ (interpreterProxy slotSizeOf: oop)].
	(smSize bitAnd: smSize - 1) = 0 ifFalse:[^false].
	smSize = 0 
		ifTrue:[sourceMap _ nil]
		ifFalse:[sourceMap _ interpreterProxy firstIndexableField: oop.
				smMask _ smSize - 1].
	"Check if sourceMap is just identity mapping for RGBA parts"
	(self isIdentityMap: smShiftTable with: smMaskTable)
		ifTrue:[ smMaskTable _ smShiftTable _ nil ].
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 19:41'!
loadFXTallyMap
	"Load the tally map"
	| map |
	self inline: true.
	map _ interpreterProxy fetchPointer: FXTallyMapIndex ofObject: bitBltOop.
	map = interpreterProxy nilObject ifTrue:[
		tallyMap _ nil.
		tallyMapSize _ 0.
		^true].
	(interpreterProxy isWords: map) ifFalse:[^false].
	tallyMapSize _ interpreterProxy slotSizeOf: map.
	tallyMap _ interpreterProxy firstIndexableField: map.
	^interpreterProxy failed not! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/22/2000 17:50'!
loadFXWarpQuad
	"Load the new warp quad (used, e.g., for warping)"
	| points oop |
	self inline: true.
	points _ interpreterProxy fetchPointer: FXWarpQuadIndex ofObject: bitBltOop.
	points = interpreterProxy nilObject ifTrue:[^noWarp _ true].
	noWarp _ false.
	(interpreterProxy fetchClassOf: points) = interpreterProxy classArray
		ifFalse:[^false].
	(interpreterProxy slotSizeOf: points) = 4 ifFalse:[^false].
	0 to: 3 do:[:i|
		oop _ interpreterProxy fetchPointer: i ofObject: points.
		(interpreterProxy fetchClassOf: oop) = interpreterProxy classPoint
			ifFalse:[^false].
		warpQuad at: i*2 put: (self fetchIntOrFloat: 0 ofObject: oop).
		warpQuad at: i*2+1 put: (self fetchIntOrFloat: 1 ofObject: oop).
	].
	^interpreterProxy failed not! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 1/16/2000 16:36'!
loadFXWarpQuality
	"Load the warp quality (used, e.g., for warping)"
	self inline: true.
	warpQuality _ self fetchIntOrFloat: FXWarpQualityIndex ofObject: bitBltOop ifNil: 1.
	^interpreterProxy failed not! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/9/2000 19:29'!
loadHalftoneForm
	"Load the halftone form"
	| halftoneBits |
	self inline: true.
	halftoneForm _ interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.
	noHalftone _ self ignoreSourceOrHalftone: halftoneForm.
	noHalftone ifTrue:[
		halftoneBase _ nil.
		^true].
	((interpreterProxy isPointers: halftoneForm) not
		and: [interpreterProxy isWords: halftoneForm])
			ifFalse: [^ false].
	halftoneBits _ halftoneForm.
	halftoneHeight _ interpreterProxy slotSizeOf: halftoneBits.
	halftoneBase _ self cCoerce: (interpreterProxy firstIndexableField: halftoneBits) to:'int'.
	^true! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/23/2000 21:03'!
showDisplayBits
	interpreterProxy 
		showDisplayBits: destForm
		Left: affectedL
		Top: affectedT
		Right: affectedR
		Bottom: affectedB
! !

!FXBltSimulation methodsFor: 'interpreter interface' stamp: 'ar 2/23/2000 21:40'!
version
	"Return the version of FXBlt"
	^1! !


!FXBltSimulation methodsFor: 'accessing'!
affectedBottom

	^affectedB! !

!FXBltSimulation methodsFor: 'accessing'!
affectedLeft

	^affectedL! !

!FXBltSimulation methodsFor: 'accessing'!
affectedRight

	^affectedR! !

!FXBltSimulation methodsFor: 'accessing'!
affectedTop

	^affectedT! !

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

	^destForm! !


!FXBltSimulation methodsFor: 'setup' stamp: 'ar 1/9/2000 16:25'!
checkSourceOverlap
	"check for possible overlap of source and destination"
	"ar 10/19/1999: This method requires surfaces to be locked."
	| t |
	self inline: true.
	(sourceForm = destForm and: [dy >= sy]) ifTrue:
		[dy > sy ifTrue:
			["have to start at bottom"
			vDir _ -1.
			sy _ sy + bbH - 1.
			dy _ dy + bbH - 1]
		ifFalse:
			[(dy = sy) & (dx > sx) ifTrue:
				["y's are equal, but x's are backward"
				hDir _ -1.
				sx _ sx + bbW - 1.
				"start at right"
				dx _ dx + bbW - 1.
				"and fix up masks"
				nWords > 1 ifTrue: 
					[t _ mask1.
					mask1 _ mask2.
					mask2 _ t]]].
		"Dest inits may be affected by this change"
		destIndex _ destBits + (dy * destPitch) + ((dx // destPPW) *4).
		destDelta _ (destPitch * vDir) - (4 * (nWords * hDir))]! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 1/10/2000 23:29'!
clipDest
	"clip and adjust source origin and extent appropriately"
	"first in x"
	destX >= clipX
		ifTrue: [sx _ sourceX.
				dx _ destX.
				bbW _ width]
		ifFalse: [sx _ sourceX + (clipX - destX).
				bbW _ width - (clipX - destX).
				dx _ clipX].
	(dx + bbW) > (clipX + clipWidth)
		ifTrue: [bbW _ bbW - ((dx + bbW) - (clipX + clipWidth))].
	"then in y"
	destY >= clipY
		ifTrue: [sy _ sourceY.
				dy _ destY.
				bbH _ height]
		ifFalse: [sy _ sourceY + clipY - destY.
				bbH _ height - (clipY - destY).
				dy _ clipY].
	(dy + bbH) > (clipY + clipHeight)
		ifTrue: [bbH _ bbH - ((dy + bbH) - (clipY + clipHeight))].
! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 1/10/2000 23:30'!
clipSource
	"clip and adjust source origin and extent appropriately"
	sx < 0
		ifTrue: [dx _ dx - sx.
				bbW _ bbW + sx.
				sx _ 0].
	sx + bbW > sourceWidth
		ifTrue: [bbW _ bbW - (sx + bbW - sourceWidth)].
	sy < 0
		ifTrue: [dy _ dy - sy.
				bbH _ bbH + sy.
				sy _ 0].
	sy + bbH > sourceHeight
		ifTrue: [bbH _ bbH - (sy + bbH - sourceHeight)]! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 2/24/2000 22:54'!
copyBits
	self export: true.
	self inline: false.
	self initBBOpTable.
	self clipDest.
	"Clip against source if not warping"
	noSource ifFalse:[
		noWarp ifTrue:[self clipSource]].
	(bbW <= 0 or: [bbH <= 0]) ifTrue:
		["zero width or height; noop"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		^ nil].
	"Lock the surfaces if necessary"
	hasSurfaceLock _ false.
	(destBits = 0 or:[noSource not and:[sourceBits = 0]])
		ifTrue:[self lockSurfaces ifFalse:[^interpreterProxy primitiveFail]].
	self copyBitsLockedAndClipped.
	"And unlock the surfaces if necessary"
	hasSurfaceLock ifTrue:[self unlockSurfaces].! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 2/21/2000 22:53'!
copyBitsFrom: startX to: stopX at: yValue
	"Support for the balloon engine."
	self export: true.
	destX _ startX.
	destY _ yValue.
	sourceX _ startX.
	width _ (stopX - startX).
	self copyBits.
	self showDisplayBits.! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 2/29/2000 15:39'!
copyBitsLockedAndClipped
	"Perform the actual copyBits operation.
	Assume: Surfaces have been locked and clipping was performed."
	| done |
	self inline: true.
	pixelDepth _ destDepth. "default assumption"
	bitCount _ 0.
	"Try a shortcut for stuff that should be run as quickly as possible"
 	done _ self copyBitsQuickly.
	done ifTrue:[^nil].
	self destMaskAndPointerInit.
	noWarp ifTrue:[
		"Choose and perform the actual copy loop."
		noSource ifTrue: ["Simple fill loop"
			noDestMap
				ifTrue:[self copyLoopNoSource]
				ifFalse:[self copyLoopNoSourcePixels].
		] ifFalse: ["Loop using source and dest"
			self checkSourceOverlap.
			(sourceDepth = destDepth and:[
				sourceMSB = destMSB and:[noColorMap and:[srcKeyMode not]]]) ifTrue: [
				"Faster version when equal depths and no color conversion"
				self sourceSkewAndPointerInit.
				self copyLoop.
			] ifFalse: [
				"If we must convert between pixel depths or use
				color lookups use the general version"
				(noSourceMap and:[noDestMap])
					ifTrue:[self doCopyLoopPixMap]
					ifFalse:[self copyLoopPixels].
			]
		].
	] ifFalse:[self doWarpLoop].
	(combinationRule = 22) | (combinationRule = 32) ifTrue:
		["zero width and height; return the count"
		affectedL _ affectedR _ affectedT _ affectedB _ 0.
		interpreterProxy pop: interpreterProxy methodArgumentCount + 1.
		^ interpreterProxy pushInteger: bitCount].
	hDir > 0
		ifTrue: [affectedL _ dx.
				affectedR _ dx + bbW]
		ifFalse: [affectedL _ dx - bbW + 1.
				affectedR _ dx + 1].
	vDir > 0
		ifTrue: [affectedT _ dy.
				affectedB _ dy + bbH]
		ifFalse: [affectedT _ dy - bbH + 1.
				affectedB _ dy + 1]! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 2/21/2000 23:26'!
copyBitsQuickly
	"Shortcut for stuff that's being run from the balloon engine.
	Since we do this at each scan line we should avoid the expensive 
	setup for source and destination."
	self inline: true.
	"We need rule 34, source depth 32, and no warping please."
	(combinationRule = 34 and:[sourceDepth = 32 and:[noWarp]]) ifFalse:[^false].
	"We need a source different from destination with at least 16bit depth."
	(noSource or:[sourceForm = destForm or:[destDepth <= 8]]) ifTrue:[^false].
	"If 8bit, then we want a dest map"
	(destDepth = 8 and:[noDestMap]) ifTrue:[^false].
	"And *no* source map please"
	noSourceMap ifFalse:[^false].
	destDepth = 32 
		ifTrue:[self alphaSourceBlendBits32].
	destDepth = 16
		ifTrue:[self alphaSourceBlendBits16].
	destDepth = 8
		ifTrue:[self alphaSourceBlendBits8].
	affectedL _ dx.
	affectedR _ dx + bbW.
	affectedT _ dy.
	affectedB _ dy + bbH.
	^true! !

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

	"calculate byte addr and delta, based on first word of data"
	"Note pitch is bytes and nWords is longs, not bytes"
	destIndex _ destBits + (dy * destPitch) + ((dx // destPPW) *4).
	destDelta _ destPitch * vDir - (4 * (nWords * hDir)).  "byte addr delta"
! !

!FXBltSimulation methodsFor: 'setup'!
ignoreSourceOrHalftone: formPointer

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

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

	"calculate right-shift skew from source to dest"
	sourceMSB "equal to destMSB so it doesn't matter"
		ifTrue:[skew _ (sxLowBits - dxLowBits) * destDepth] 
		ifFalse:[skew _ (dxLowBits - sxLowBits) * destDepth].  " -32..32 "
	preload ifTrue: 
		[skew < 0
			ifTrue: [skew _ skew+32]
			ifFalse: [skew _ skew-32]].

	"Calc byte addr and delta from longWord info"
	sourceIndex _ sourceBits + (sy * sourcePitch) + ((sx // sourcePPW) *4).
	"calculate increments from end of 1 line to start of next"
	sourceDelta _ (sourcePitch * vDir) - (4 * (nWords * hDir)).

	preload ifTrue:
		["Compensate for extra source word fetched"
		sourceDelta _ sourceDelta - (4*hDir)].! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 1/10/2000 23:31'!
warpBits
	"obsolete"
	self copyBits.! !

!FXBltSimulation methodsFor: 'setup' stamp: 'ar 2/13/2000 15:48'!
warpSetup
	"Setup values for faster pixel fetching in WarpBlt."
	| depth |
	self inline: true.
	"warpSrcShift = log2(sourceDepth)"
	warpSrcShift _ 0.
	depth _ sourceDepth.
	[depth = 1] whileFalse:[
		warpSrcShift _ warpSrcShift + 1.
		depth _ depth >> 1].

	"warpSrcMask = mask for extracting one pixel from source word"
	warpSrcMask _ maskTable at: sourceDepth.

	"warpAlignShift: Shift for aligning x position to word boundary"
	warpAlignShift _ 5 - warpSrcShift.

	"warpAlignMask: Mask for extracting the pixel position from an x position"
	warpAlignMask _ 1 << warpAlignShift - 1.

	"Setup the lookup table for source bit shifts"
	"warpBitShiftTable: given an sub-word x value what's the bit shift?"
	0 to: warpAlignMask do:[:i|
		sourceMSB
			ifTrue:[warpBitShiftTable at: i put: 32 - ( i + 1 << warpSrcShift )]
			ifFalse:[warpBitShiftTable at: i put: (i << warpSrcShift)]].! !


!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 2/13/2000 15:50'!
alphaSourceBlendBits16
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 16
		sourceForm ~= destForm.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift ditherBase ditherIndex ditherThreshold |
	self inline: false. "This particular method should be optimized in itself"
	pixelDepth _ 32.
	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.
	srcShift _ (dx bitAnd: 1) * 16.
	destMSB ifTrue:[srcShift _ 16 - srcShift].
	mask1 _ 16rFFFF << (16 - srcShift).
	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx // 2 * 4).
		ditherBase _ (dstY bitAnd: 3) * 4.
		ditherIndex _ (sx bitAnd: 3) - 1. "For pre-increment"
		deltaX _ bbW + 1. "So we can pre-decrement"
		dstMask _ mask1.
		dstMask = 16rFFFF ifTrue:[srcShift _ 16] ifFalse:[srcShift _ 0].

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			ditherThreshold _ ditherMatrix4x4 at: ditherBase + (ditherIndex _ ditherIndex + 1 bitAnd: 3).
			sourceWord _ self srcLongAt: srcIndex.
			srcAlpha _ sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				"Dither from 32 to 16 bit"
				sourceWord _ self dither32To16: sourceWord threshold: ditherThreshold.
				sourceWord = 0 ifTrue:[sourceWord _ 1].
				sourceWord _ sourceWord << srcShift.
				"Store masked value"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord _ self dstLongAt: dstIndex.
					destWord _ destWord bitAnd: dstMask bitInvert32.
					destWord _ destWord >> srcShift.
					"Expand from 16 to 32 bit by adding zero bits"
					destWord _ (((destWord bitAnd: 16r7C00) bitShift: 9) bitOr:
									((destWord bitAnd: 16r3E0) bitShift: 6)) bitOr:
								(((destWord bitAnd: 16r1F) bitShift: 3) bitOr:
									16rFF000000).
					"Mix colors"
					sourceWord _ self alphaBlendScaled: sourceWord with: destWord.
					"And dither"
					sourceWord _ self dither32To16: sourceWord threshold: ditherThreshold.
					sourceWord = 0 ifTrue:[sourceWord _ 1].
					sourceWord _ sourceWord << srcShift.
					"Store back"
					self dstLongAt: dstIndex put: sourceWord mask: dstMask.
				].
			].
			srcIndex _ srcIndex + 4.
			destMSB
				ifTrue:[srcShift = 0 ifTrue:[dstIndex _ dstIndex + 4]]
				ifFalse:[srcShift = 0 ifFalse:[dstIndex _ dstIndex + 4]].
			srcShift _ srcShift bitXor: 16. "Toggle between 0 and 16"
			dstMask _ dstMask bitInvert32. "Mask other half word"
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 1/16/2000 17:09'!
alphaSourceBlendBits32
	"This version assumes 
		combinationRule = 34
		sourcePixSize = destPixSize = 32
		sourceForm ~= destForm.
	Note: The inner loop has been optimized for dealing
		with the special cases of srcAlpha = 0.0 and srcAlpha = 1.0 
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY |
	self inline: false. "This particular method should be optimized in itself"

	"Give the compile a couple of hints"
	self var: #sourceWord declareC:'register int sourceWord'.
	self var: #deltaX declareC:'register int deltaX'.

	"The following should be declared as pointers so the compiler will
	notice that they're used for accessing memory locations 
	(good to know on an Intel architecture) but then the increments
	would be different between ST code and C code so must hope the
	compiler notices what happens (MS Visual C does)"
	self var: #srcIndex declareC:'register int srcIndex'.
	self var: #dstIndex declareC:'register int dstIndex'.

	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.

	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx * 4).
		deltaX _ bbW + 1. "So we can pre-decrement"

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			sourceWord _ self srcLongAt: srcIndex.
			srcAlpha _ sourceWord >> 24.
			srcAlpha = 255 ifTrue:[
				self dstLongAt: dstIndex put: sourceWord.
				srcIndex _ srcIndex + 4.
				dstIndex _ dstIndex + 4.
				"Now copy as many words as possible with alpha = 255"
				[(deltaX _ deltaX - 1) ~= 0 and:[
					(sourceWord _ self srcLongAt: srcIndex) >> 24 = 255]]
						whileTrue:[
							self dstLongAt: dstIndex put: sourceWord.
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
				"Adjust deltaX"
				deltaX _ deltaX + 1.
			] ifFalse:[ "srcAlpha ~= 255"
				srcAlpha = 0 ifTrue:[
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
					"Now skip as many words as possible,"
					[(deltaX _ deltaX - 1) ~= 0 and:[
						(sourceWord _ self srcLongAt: srcIndex) >> 24 = 0]]
						whileTrue:[
							srcIndex _ srcIndex + 4.
							dstIndex _ dstIndex + 4.
						].
					"Adjust deltaX"
					deltaX _ deltaX + 1.
				] ifFalse:[ "0 < srcAlpha < 255"
					"If we have to mix colors then just copy a single word"
					destWord _ self dstLongAt: dstIndex.
					destWord _ self alphaBlendScaled: sourceWord with: destWord.
					self dstLongAt: dstIndex put: destWord.
					srcIndex _ srcIndex + 4.
					dstIndex _ dstIndex + 4.
				].
			].
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 2/13/2000 15:50'!
alphaSourceBlendBits8
	"This version assumes 
		combinationRule = 34
		sourcePixSize = 32
		destPixSize = 8
		sourceForm ~= destForm.
	Note: This is not real blending since we don't have the source colors available.
	"
	| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY 
	srcY dstY dstMask srcShift adjust |
	self inline: false. "This particular method should be optimized in itself"
	deltaY _ bbH + 1. "So we can pre-decrement"
	srcY _ sy.
	dstY _ dy.
	mask1 _ (dx bitAnd: 3) * 8.
	destMSB ifTrue:[mask1 _ 24 - mask1].
	mask2 _ AllOnes bitXor:(16rFF << mask1).
	(dx bitAnd: 1) = 0 
		ifTrue:[adjust _ 0]
		ifFalse:[adjust _ 16r1F1F1F1F].
	(dy bitAnd: 1) = 0
		ifTrue:[adjust _ adjust bitXor: 16r1F1F1F1F].
	"This is the outer loop"
	[(deltaY _ deltaY - 1) ~= 0] whileTrue:[
		adjust _ adjust bitXor: 16r1F1F1F1F.
		srcIndex _ sourceBits + (srcY * sourcePitch) + (sx * 4).
		dstIndex _ destBits + (dstY * destPitch) + (dx // 4 * 4).
		deltaX _ bbW + 1. "So we can pre-decrement"
		srcShift _ mask1.
		dstMask _ mask2.

		"This is the inner loop"
		[(deltaX _ deltaX - 1) ~= 0] whileTrue:[
			sourceWord _ ((self srcLongAt: srcIndex) bitAnd: (adjust bitInvert32)) + adjust.
			srcAlpha _ sourceWord >> 24.
			srcAlpha > 31 ifTrue:["Everything below 31 is transparent"
				srcAlpha < 224 ifTrue:["Everything above 224 is opaque"
					destWord _ self dstLongAt: dstIndex.
					destWord _ destWord bitAnd: dstMask bitInvert32.
					destWord _ destWord >> srcShift.
					destWord _ self mapDestPixel: destWord.
					sourceWord _ self alphaBlendScaled: sourceWord with: destWord.
				].
				sourceWord _ self mapPixel: sourceWord.
				sourceWord _ sourceWord << srcShift.
				"Store back"
				self dstLongAt: dstIndex put: sourceWord mask: dstMask.
			].
			srcIndex _ srcIndex + 4.
			destMSB ifTrue:[
				srcShift = 0 
					ifTrue:[dstIndex _ dstIndex + 4.
							srcShift _ 24.
							dstMask _ 16r00FFFFFF]
					ifFalse:[srcShift _ srcShift - 8.
							dstMask _ (dstMask >> 8) bitOr: 16rFF000000].
			] ifFalse:[
				srcShift = 32
					ifTrue:[dstIndex _ dstIndex + 4.
							srcShift _ 0.
							dstMask _ 16rFFFFFF00]
					ifFalse:[srcShift _ srcShift + 8.
							dstMask _ dstMask << 8 bitOr: 255].
			].
			adjust _ adjust bitXor: 16r1F1F1F1F.
		].
		srcY _ srcY + 1.
		dstY _ dstY + 1.
	].! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
copyLoop
	"This version of the inner loop assumes sourceDepth = destDepth,
	noSource = false, noColorMap = noSourceMap = noDestMap = true"
	| prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask destWord mergeFn |
	self inline: false.
	mergeFn _ opTable at: combinationRule+1.
	hInc _ hDir*4.  "Byte delta"
	"degenerate skew fixed for Sparc. 10/20/96 ikp"
	skew == -32
		ifTrue: [skew _ unskew _ skewMask _ 0]
		ifFalse: [skew < 0
			ifTrue:
				[unskew _ skew+32.
				skewMask _ AllOnes << (0-skew)]
			ifFalse:
				[skew == 0
					ifTrue:
						[unskew _ 0.
						skewMask _ AllOnes]
					ifFalse:
						[unskew _ skew-32.
						skewMask _ AllOnes >> skew]]].
	notSkewMask _ skewMask bitInvert32.
	noHalftone
		ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]
		ifFalse: [halftoneWord _ self halftoneAt: 0].

	y _ dy.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
			[halftoneWord _ self halftoneAt: y.
			y _ y + vDir].
		preload ifTrue:
			["load the 64-bit shifter"
			prevWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc]
			ifFalse:
			[prevWord _ 0].

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

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

		"This central horizontal loop requires no store masking"
		destMask _ AllOnes.
combinationRule = 3
ifTrue: [noHalftone & (notSkewMask = 0)
		ifTrue:  
		["Very special inner loop for STORE mode with no skew -- just move words"
		2 to: nWords-1 do: 
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc.
			self dstLongAt: destIndex put: thisWord.
			destIndex _ destIndex + hInc]]
		ifFalse:
		["Special inner loop for STORE mode -- no need to call merge"
		2 to: nWords-1 do: 
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			self dstLongAt: destIndex put: (skewWord bitAnd: halftoneWord).
			destIndex _ destIndex + hInc]]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
			[ :word |
			thisWord _ self srcLongAt: sourceIndex.  "pick up next word"
			sourceIndex _ sourceIndex + hInc.
			skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
							bitOr:  "32-bit rotate"
						((thisWord bitAnd: skewMask) bitShift: skew).
			prevWord _ thisWord.
			mergeWord _ self merge: (skewWord bitAnd: halftoneWord)
							with: (self dstLongAt: destIndex)
							function: mergeFn.
			self dstLongAt: destIndex put: mergeWord.
			destIndex _ destIndex + hInc]
].

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

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

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
copyLoopNoSource
	"Faster copyLoop when source not used.  hDir and vDir are both
	positive, and perload and skew are unused.
	Note: This is the common fill loop without any fancy stuff."
	| halftoneWord mergeWord destWord mergeFn |
	self inline: false.
	mergeFn _ opTable at: combinationRule+1.
	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].

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

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

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

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

	destIndex _ destIndex + destDelta]! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
copyLoopNoSourcePixels
	"This version of the inner loop maps dest pixels one at a time.
	Note: This loop is typically used for filling with alpha values.
	Note2: There is probably some significant speedup in here
	but for now I just need a version that does the job..."

	| nPix dstShift destWord dstIndex nLines dstMask lastDstPix destPix dstMapped resultMapped resultPix halftoneWord dstPaint mergeFn |
	self inline: false.
	mergeFn _ opTable at: combinationRule+1.
	dstPaint _ combinationRule = 36.

	"Additional inits"
	dstMask _ maskTable at: destDepth.
	dstIndex _ destIndex.

	"Precomputed shifts for pickSourcePixels"
	dstShift _ ((dx bitAnd: destPPW - 1) * destDepth).
	destMSB ifTrue:[dstShift _ 32 - destDepth - dstShift].
	dstBitShift _ dstShift.

	destMask _ -1.
	pixelDepth _ 32.
	nLines _ bbH.
	["this is the vertical loop"
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: bbH - nLines].
		destWord _ self dstLongAt: dstIndex.
		"Prefetch first dest pixel"
		lastDstPix _ destPix _ destWord >> dstShift bitAnd: dstMask.
		dstMapped _ self mapDestPixel: destPix.
		nPix _ bbW.
		["this is the horizontal loop"
			(dstPaint and:[destPix = destAlphaKey])
				ifTrue:[resultMapped _ dstMapped]
				ifFalse:[resultMapped _ self merge: halftoneWord with: dstMapped function: mergeFn].
			(noColorMap and:[resultMapped = dstMapped]) ifFalse:[
				resultPix _ self mapPixel: resultMapped.
				destWord _ destWord bitAnd: (dstMask << dstShift) bitInvert32.
				destWord _ destWord bitOr: (resultPix bitAnd: dstMask) << dstShift.
			].
			destMSB ifTrue:[
				"Adjust dest if at pixel boundary"
				(dstShift _ dstShift - destDepth) < 0 ifTrue:
					[dstShift _ dstShift + 32.
					self dstLongAt: dstIndex put: destWord.
					destWord _ self dstLongAt: (dstIndex _ dstIndex + 4)].
			] ifFalse:[
				"Adjust dest if at pixel boundary"
				(dstShift _ dstShift + destDepth) > 31 ifTrue:
					[dstShift _ dstShift - 32.
					self dstLongAt: dstIndex put: destWord.
					destWord _ self dstLongAt: (dstIndex _ dstIndex + 4)].
			].
		(nPix _ nPix - 1) = 0] whileFalse:[
			"Fetch next dest pixel"
			destPix _ destWord >> dstShift bitAnd: dstMask.
			lastDstPix = destPix ifFalse:[
				dstMapped _ self mapDestPixel: destPix.
				lastDstPix _ destPix]
		].
	(nLines _ nLines - 1) = 0] whileFalse:[
		"Store last modified word"
		self dstLongAt: dstIndex put: destWord.
		"Advance destIndex"
		dstIndex _ destIndex _ destIndex + destPitch.
		dstShift _ dstBitShift.
	].
	"Store final destWord"
	self dstLongAt: dstIndex put: destWord.! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
copyLoopPixMap
	"This version of the inner loop maps source pixels
	to a destination form with different depth.
	Note: Special care is taken to handle source paint mode correctly."
	| skewWord halftoneWord mergeWord scrStartBits nSourceIncs startBits endBits 
	sourcePixMask destPixMask nPix srcShift dstShift destWord 
	words srcPaint mergeFn |
	"Note: This method is inlined for specialization of LSB-MSB conversion"
	self inline: true.
	mergeFn _ opTable at: combinationRule+1.
	srcPaint _ srcKeyMode.

	"Additional inits peculiar to unequal source and dest pix size..."
	sourcePixMask _ maskTable at: sourceDepth.
	destPixMask _ maskTable at: destDepth.
	sourceIndex _ sourceBits + (sy * sourcePitch) + ((sx // sourcePPW) *4).
	scrStartBits _ sourcePPW - (sx bitAnd: sourcePPW-1).
	bbW < scrStartBits
		ifTrue: [nSourceIncs _ 0]
		ifFalse: [nSourceIncs _ (bbW - scrStartBits)//sourcePPW + 1].
	sourceDelta _ sourcePitch - (nSourceIncs * 4).

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

	bbW < startBits ifTrue:[startBits _ bbW].

	"Precomputed shifts for pickSourcePixels"
	srcShift _ ((sx bitAnd: sourcePPW - 1) * sourceDepth).
	dstShift _ ((dx bitAnd: destPPW - 1) * destDepth).
	sourceMSB ifTrue:[srcShift _ 32 - sourceDepth - srcShift].
	destMSB ifTrue:[dstShift _ 32 - destDepth - dstShift].

	1 to: bbH do: "here is the vertical loop"
		[ :i |
		noHalftone
			ifTrue:[halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		"setup first load"
		srcBitShift _ srcShift.
		dstBitShift _ dstShift.
		destMask _ mask1.
		nPix _ startBits.
		"Here is the horizontal loop..."
		words _ nWords.
			["pick up the word"
			destWord _ self dstLongAt: destIndex.
			skewWord _ self pickSourcePixels: nPix
							srcMask: sourcePixMask 
							destMask: destPixMask
							paintMode: srcPaint
							destWord: destWord.
			mergeWord _ self merge: (skewWord bitAnd: halftoneWord)
							with: (destWord bitAnd: destMask)
							function: mergeFn.
			destWord _ (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ destPPW].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		sourceIndex _ sourceIndex + sourceDelta.
		destIndex _ destIndex + destDelta]

! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
copyLoopPixels
	"This version of the inner loop maps source pixels and dest pixels one at a time. This is the most general (and slowest) version which must also keep track of source and dest paint mode by itself."
	| nPix srcShift dstShift destWord srcIndex dstIndex nLines sourceWord lastSrcPix sourcePix srcMask dstMask srcMapped lastDstPix destPix dstMapped resultMapped resultPix srcPaint dstPaint paintMode mergeFn |
	self inline: false.
	mergeFn _ opTable at: combinationRule+1.
	srcPaint _ srcKeyMode.
	dstPaint _ dstKeyMode.
	paintMode _ srcPaint | dstPaint.

	"Additional inits"
	srcMask _ maskTable at: sourceDepth.
	dstMask _ maskTable at: destDepth.
	sourceIndex _ srcIndex _ sourceBits + (sy * sourcePitch) + ((sx // sourcePPW) *4).
	dstIndex _ destIndex.

	"Precomputed shifts for pickSourcePixels"
	srcShift _ ((sx bitAnd: sourcePPW - 1) * sourceDepth).
	dstShift _ ((dx bitAnd: destPPW - 1) * destDepth).
	sourceMSB ifTrue:[srcShift _ 32 - sourceDepth - srcShift].
	destMSB ifTrue:[dstShift _ 32 - destDepth - dstShift].

	srcBitShift _ srcShift.
	dstBitShift _ dstShift.

	noSourceMap 
		ifTrue:[pixelDepth _ sourceDepth]
		ifFalse:[pixelDepth _ 32].
	destMask _ -1.
	nLines _ bbH.
	["this is the vertical loop"
		sourceWord _ self srcLongAt: srcIndex.
		destWord _ self dstLongAt: dstIndex.
		"Prefetch first source pixel"
		lastSrcPix _ sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
		srcMapped _ self mapSourcePixel: sourcePix.
		"Prefetch first dest pixel"
		lastDstPix _ destPix _ destWord >> dstShift bitAnd: dstMask.
		dstMapped _ self mapDestPixel: destPix.
		nPix _ bbW.
		["this is the horizontal loop"
			(paintMode) ifTrue:[
				((srcPaint and:[sourcePix = sourceAlphaKey])
					or:[dstPaint and:[destPix ~= destAlphaKey]])
						ifTrue:[resultMapped _ dstMapped]
						ifFalse:[	resultMapped _ self merge: srcMapped with: dstMapped function: mergeFn].
			] ifFalse:[
				resultMapped _ self merge: srcMapped with: dstMapped function: mergeFn.
			].
			(noColorMap and:[resultMapped = dstMapped]) ifFalse:[
				resultPix _ self mapPixel: resultMapped.
				destWord _ destWord bitAnd: (dstMask << dstShift) bitInvert32.
				destWord _ destWord bitOr: (resultPix bitAnd: dstMask) << dstShift.
			].
			sourceMSB ifTrue:[
				"Adjust source if at pixel boundary"
				(srcShift _ srcShift - sourceDepth) < 0 ifTrue:
					[srcShift _ srcShift + 32.
					sourceWord _ self srcLongAt: (srcIndex _ srcIndex + 4)].
			] ifFalse:[
				"Adjust source if at pixel boundary"
				(srcShift _ srcShift + sourceDepth) > 31 ifTrue:
					[srcShift _ srcShift - 32.
					sourceWord _ self srcLongAt: (srcIndex _ srcIndex + 4)].
			].
			destMSB ifTrue:[
				"Adjust dest if at pixel boundary"
				(dstShift _ dstShift - destDepth) < 0 ifTrue:
					[dstShift _ dstShift + 32.
					self dstLongAt: dstIndex put: destWord.
					destWord _ self dstLongAt: (dstIndex _ dstIndex + 4)].
			] ifFalse:[
				"Adjust dest if at pixel boundary"
				(dstShift _ dstShift + destDepth) > 31 ifTrue:
					[dstShift _ dstShift - 32.
					self dstLongAt: dstIndex put: destWord.
					destWord _ self dstLongAt: (dstIndex _ dstIndex + 4)].
			].
		(nPix _ nPix - 1) = 0] whileFalse:[
			"Fetch next source/dest pixel"
			sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
			lastSrcPix = sourcePix ifFalse:[
				srcMapped _ self mapSourcePixel: sourcePix.
				lastSrcPix _ sourcePix].
			destPix _ destWord >> dstShift bitAnd: dstMask.
			lastDstPix = destPix ifFalse:[
				dstMapped _ self mapDestPixel: destPix.
				lastDstPix _ destPix]
		].
	(nLines _ nLines - 1) = 0] whileFalse:[
		"Store last destWord"
		self dstLongAt: dstIndex put: destWord.
		"Advance sourceIndex, destIndex"
		srcIndex _ sourceIndex _ sourceIndex + sourcePitch.
		dstIndex _ destIndex _ destIndex + destPitch.
		srcShift _ srcBitShift.
		dstShift _ dstBitShift.
	].
	"Store final destWord"
	self dstLongAt: dstIndex put: destWord.! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 2/16/2000 18:43'!
merge: sourceWord with: destinationWord function: mergeFn
	^self perform: (self cCoerce: mergeFn to: 'int (*) (int, int)')
		with: sourceWord
		with: destinationWord! !

!FXBltSimulation methodsFor: 'inner loop' stamp: 'ar 5/25/2000 15:41'!
warpLoop
	"This version of the inner loop traverses an arbirary quadrilateral
	source, thus producing a general affine transformation."
	| skewWord halftoneWord mergeWord startBits
	deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy pBx pBy
	xDelta yDelta nSteps nPix words destWord endBits 
	srcPaint mergeFn |
	"We want to inline this into the specialized versions"
	self inline: true.
	false ifTrue:[
	"Check if we have a simple scaling and can short cut this into scaleLoop"
	((warpQuad at: 0) "p1x" = (warpQuad at: 2) "p2x"
		and:[(warpQuad at: 4) "p3x" = (warpQuad at: 6) "p4x"
		and:[(warpQuad at: 1) "p1y" = (warpQuad at: 7) "p4y"
		and:[(warpQuad at: 3) "p2y" = (warpQuad at: 5) "p3y"]]])
			ifTrue:["^self scaleLoop"]].
	mergeFn _ opTable at: combinationRule+1.
	srcPaint _ srcKeyMode.

 	nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

	pAx _ warpQuad at: 0.	words _ warpQuad at: 2.
	deltaP12x _ self deltaFrom: pAx to: words nSteps: nSteps.
	deltaP12x < 0 ifTrue: [pAx _ words - (nSteps*deltaP12x)].

	pAy _ warpQuad at: 1.	words _ warpQuad at: 3.
	deltaP12y _ self deltaFrom: pAy to: words nSteps: nSteps.
	deltaP12y < 0 ifTrue: [pAy _ words - (nSteps*deltaP12y)].

	pBx _ warpQuad at: 6.	words _ warpQuad at: 4.
	deltaP43x _ self deltaFrom: pBx to: words nSteps: nSteps.
	deltaP43x < 0 ifTrue: [pBx _ words - (nSteps*deltaP43x)].

	pBy _ warpQuad at: 7.	words _ warpQuad at: 5.
	deltaP43y _ self deltaFrom: pBy to: words nSteps: nSteps.
	deltaP43y < 0 ifTrue: [pBy _ words - (nSteps*deltaP43y)].

	nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].
	startBits _ destPPW - (dx bitAnd: destPPW-1).
	endBits _ ((dx + bbW - 1) bitAnd: destPPW-1) + 1.
 	bbW < startBits ifTrue:[startBits _ bbW].

	destY < clipY ifTrue:[
		"Advance increments if there was clipping in y"
		pAx _ pAx + (clipY - destY * deltaP12x).
		pAy _ pAy + (clipY - destY * deltaP12y).
		pBx _ pBx + (clipY - destY * deltaP43x).
		pBy _ pBy + (clipY - destY * deltaP43y)].

	"Setup values for faster pixel fetching."
	self warpSetup.

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

		destMSB
			ifTrue:[dstBitShift _ 32 - ((dx bitAnd: destPPW - 1) + 1 * destDepth)]
			ifFalse:[dstBitShift _ (dx bitAnd: destPPW - 1) * destDepth].
		(destX < clipX) ifTrue:[
			"Advance increments if there was clipping in x"
			sx _ sx + (clipX - destX * xDelta).
			sy _ sy + (clipX - destX * yDelta).
		].
		noHalftone
			ifTrue: [halftoneWord _ AllOnes]
			ifFalse: [halftoneWord _ self halftoneAt: dy+i-1].
		destMask _ mask1.
		nPix _ startBits.
		"Here is the inner loop..."
		words _ nWords.
			["pick up word"
			destWord _ self dstLongAt: destIndex.
			warpQuality = 1 ifTrue:["Faster if not smoothing"
				skewWord _ self warpPickSourcePixels: nPix
								xDeltah: xDelta yDeltah: yDelta
								xDeltav: deltaP12x yDeltav: deltaP12y
								paintMode: srcPaint destWord: destWord
			] ifFalse:["more difficult with smoothing"
				skewWord _ self warpPickSmoothPixels: nPix
						xDeltah: xDelta yDeltah: yDelta
						xDeltav: deltaP12x yDeltav: deltaP12y
						paintMode: srcPaint destWord: destWord.
			].
			mergeWord _ self merge: (skewWord bitAnd: halftoneWord)
							with: (destWord bitAnd: destMask)
							function: mergeFn.
			destWord _ (destMask bitAnd: mergeWord) bitOr:
							(destWord bitAnd: destMask bitInvert32).
			self dstLongAt: destIndex put: destWord.
			destIndex _ destIndex + 4.
			words = 2 "e.g., is the next word the last word?"
				ifTrue:["set mask for last word in this row"
						destMask _ mask2.
						nPix _ endBits]
				ifFalse:["use fullword mask for inner loop"
						destMask _ AllOnes.
						nPix _ destPPW].
			(words _ words - 1) = 0] whileFalse.
		"--- end of inner loop ---"
		pAx _ pAx + deltaP12x.
		pAy _ pAy + deltaP12y.
		pBx _ pBx + deltaP43x.
		pBy _ pBy + deltaP43y.
		destIndex _ destIndex + destDelta]! !


!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/17/2000 19:55'!
OLDrgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination
	and return the number of differing pixels.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| diff pixMask |
	self inline: false.
	diff _ sourceWord bitXor: destinationWord.
	pixMask _ maskTable at: pixelDepth.
	[diff = 0] whileFalse:
		[(diff bitAnd: pixMask) ~= 0 ifTrue: [bitCount _ bitCount + 1].
		diff _ diff >> pixelDepth].
	^ destinationWord "for no effect".! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 21:32'!
OLDtallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the tally map.  Note that the source should be 
	specified = destination, in order for the proper color map checks 
	to be performed at setup.
	Note that the region is not clipped to bit boundaries, but only to the
	nearest (enclosing) word.  This is because copyLoop does not do
	pre-merge masking.  For accurate results, you must subtract the
	values obtained from the left and right fringes."
	| mapIndex pixMask shiftWord |
	tallyMapSize = 0 ifTrue: [^ destinationWord "no op"].
	"loop through all packed pixels."
	pixMask _ maskTable at: pixelDepth.
	shiftWord _ destinationWord.
	1 to: destPPW do:[:i |
		mapIndex _ shiftWord bitAnd: pixMask.
		mapIndex _ self mapPixel: mapIndex.
		(mapIndex >= 0 and:[mapIndex < tallyMapSize]) ifTrue:[
			tallyMap at: mapIndex put: (tallyMap at: mapIndex) + 1.
		].
		shiftWord _ shiftWord >> pixelDepth].
	^ destinationWord! !

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

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/22/2000 15:55'!
alphaBlendConst: sourceWord with: destinationWord
	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: false! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 2/9/2000 22:59'!
alphaBlendConst: sourceWord with: destinationWord paintMode: paintMode
	"Blend sourceWord with destinationWord using a constant alpha.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	The blend produced is alpha*source + (1.0-alpha)*dest, with the
	computation being performed independently on each color component.
	This function could eventually blend into any depth destination,
	using the same color averaging and mapping as warpBlt.
	paintMode = true means do nothing if the source pixel value is zero."

	"This first implementation works with dest depths of 16 and 32 bits only.
	Normal color mapping will allow sources of lower depths in this case,
	and results can be mapped directly by truncation, so no extra color maps are needed.
	To allow storing into any depth will require subsequent addition of two other
	colormaps, as is the case with WarpBlt."

	| pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor ppw |
	self inline: false.
	pixelDepth < 16 ifTrue: [^ destinationWord "no-op"].
	unAlpha _ 255 - sourceAlpha.
	pixMask _ maskTable at: pixelDepth.
	pixelDepth = 16 
		ifTrue: [bitsPerColor _ 5. ppw _ 2]
		ifFalse:[bitsPerColor _ 8. ppw _ 1].
	rgbMask _ (1<<bitsPerColor) - 1.
	maskShifted _ destMask.
	destShifted _ destinationWord.
	sourceShifted _ sourceWord.
	result _ destinationWord.
	1 to: ppw do:
		[:j |
		sourcePixVal _ sourceShifted bitAnd: pixMask.
		((maskShifted bitAnd: pixMask) = 0  "no effect if outside of dest rectangle"
			or: [paintMode & (sourcePixVal = 0)  "or painting a transparent pixel"])
		ifFalse:
			[destPixVal _ destShifted bitAnd: pixMask.
			pixBlend _ 0.
			1 to: 3 do:
				[:i | shift _ (i-1)*bitsPerColor.
				blend _ (((sourcePixVal>>shift bitAnd: rgbMask) * sourceAlpha)
							+ ((destPixVal>>shift bitAnd: rgbMask) * unAlpha))
					 	+ 254 // 255 bitAnd: rgbMask.
				pixBlend _ pixBlend bitOr: blend<<shift].
			pixelDepth = 16
				ifTrue: [result _ (result bitAnd: (pixMask << (j-1*16)) bitInvert32)
									bitOr: pixBlend << (j-1*16)]
				ifFalse: [result _ pixBlend]].
		maskShifted _ maskShifted >> pixelDepth.
		sourceShifted _ sourceShifted >> pixelDepth.
		destShifted _ destShifted >> pixelDepth].
	^ result
! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 11/27/1998 23:56'!
alphaBlendScaled: sourceWord with: destinationWord
	"Blend sourceWord with destinationWord using the alpha value from sourceWord.
	Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0.
	In contrast to alphaBlend:with: the color produced is

		srcColor + (1-srcAlpha) * dstColor

	e.g., it is assumed that the source color is already scaled."
	| unAlpha dstMask srcMask b g r a |
	self inline: false.	"Do NOT inline this into optimized loops"
	unAlpha _ 255 - (sourceWord >> 24).  "High 8 bits of source pixel"
	dstMask _ destinationWord.
	srcMask _ sourceWord.
	b _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	b > 255 ifTrue:[b _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	g _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	g > 255 ifTrue:[g _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	r _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	r > 255 ifTrue:[r _ 255].
	dstMask _ dstMask >> 8.
	srcMask _ srcMask >> 8.
	a _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255).
	a > 255 ifTrue:[a _ 255].
	^(((((a << 8) + r) << 8) + g) << 8) + b! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:56'!
alphaPaintConst: sourceWord with: destinationWord

	sourceWord = 0 ifTrue: [^ destinationWord  "opt for all-transparent source"].
	^ self alphaBlendConst: sourceWord with: destinationWord paintMode: true! !

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

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

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

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

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

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

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

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

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

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

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

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

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

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:24'!
dstPaint: sourceWord with: destinationWord
	"Replace those pixels in destinationWord where the
	pixel value is equal to destAlphaKey."
	| mask key result val |
	self inline: false.
	mask _ maskTable at: pixelDepth.
	key _ destAlphaKey.
	result _ 0.
	0 to: destPPW-1 do:[:i|
		(val _ destinationWord bitAnd: mask) = key
			ifTrue:[result _ result bitOr: (sourceWord bitAnd: mask)]
			ifFalse:[result _ result bitOr: val].
		mask _ mask << pixelDepth.
		key _ key << pixelDepth].
	^result! !

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

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:35'!
partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts
	"Max word1 to word2 as nParts partitions of nBits each"
	| mask result |
	mask _ maskTable at: nBits.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		result _ result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)).
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:35'!
partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts
	"Min word1 to word2 as nParts partitions of nBits each"
	| mask result |
	mask _ maskTable at: nBits.  "partition mask starts at the right"
	result _ 0.
	1 to: nParts do:
		[:i |
		result _ result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)).
		mask _ mask << nBits  "slide left to next partition"].
	^ result
! !

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/22/2000 16:08'!
pixMask: sourceWord with: destinationWord
	self inline: false.
	^ self partitionedAND: sourceWord bitInvert32 to: destinationWord
					nBits: destDepth nPartitions: destPPW! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/22/2000 16:09'!
pixPaint: sourceWord with: destinationWord
	self inline: false.
	sourceWord = 0 ifTrue: [^ destinationWord].
	^ sourceWord bitOr:
		(self partitionedAND: sourceWord bitInvert32 to: destinationWord
						nBits: destDepth nPartitions: destPPW)! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:11'!
rgbAdd: sourceWord with: destinationWord
	self inline: false.
	pixelDepth < 16 ifTrue:
		["Add each pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: pixelDepth nPartitions: destPPW].
	pixelDepth = 16 ifTrue:
		["Add RGB components of each pixel separately"
		^ (self partitionedAdd: sourceWord to: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Add RGB components of the pixel separately"
		^ self partitionedAdd: sourceWord to: destinationWord
						nBits: 8 nPartitions: 3]! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/17/2000 19:57'!
rgbDiff: sourceWord with: destinationWord
	"Subract the pixels in the source and destination
	and return the number of differing pixels."
	| pixMask destShifted sourceShifted destPixVal sourcePixVal maskShifted |
	self inline: false.
	pixMask _ maskTable at: pixelDepth.
	maskShifted _ destMask.
	destShifted _ destinationWord.
	sourceShifted _ sourceWord.
	1 to: destPPW do:
		[:i |
		(maskShifted bitAnd: pixMask) > 0 ifTrue:
			["Only tally pixels within the destination rectangle"
			destPixVal _ destShifted bitAnd: pixMask.
			sourcePixVal _ sourceShifted bitAnd: pixMask.
			sourcePixVal = destPixVal ifFalse: [bitCount _ bitCount + 1]].
		maskShifted _ maskShifted >> pixelDepth.
		sourceShifted _ sourceShifted >> pixelDepth.
		destShifted _ destShifted >> pixelDepth].
	^ destinationWord  "For no effect on dest"
! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:11'!
rgbMax: sourceWord with: destinationWord
	self inline: false.
	pixelDepth < 16 ifTrue:
		["Max each pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: pixelDepth nPartitions: destPPW].
	pixelDepth = 16 ifTrue:
		["Max RGB components of each pixel separately"
		^ (self partitionedMax: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMax: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Max RGB components of the pixel separately"
		^ self partitionedMax: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:13'!
rgbMin: sourceWord with: destinationWord
	self inline: false.
	pixelDepth < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: pixelDepth nPartitions: destPPW].
	pixelDepth = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGB components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:14'!
rgbMinInvert: wordToInvert with: destinationWord
	| sourceWord |
	self inline: false.
	sourceWord _ wordToInvert bitInvert32.
	pixelDepth < 16 ifTrue:
		["Min each pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: pixelDepth nPartitions: destPPW].
	pixelDepth = 16 ifTrue:
		["Min RGB components of each pixel separately"
		^ (self partitionedMin: sourceWord with: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Min RGB components of the pixel separately"
		^ self partitionedMin: sourceWord with: destinationWord
						nBits: 8 nPartitions: 3]! !

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/16/2000 17:14'!
rgbSub: sourceWord with: destinationWord
	self inline: false.
	pixelDepth < 16 ifTrue:
		["Sub each pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: pixelDepth nPartitions: destPPW].
	pixelDepth = 16 ifTrue:
		["Sub RGB components of each pixel separately"
		^ (self partitionedSub: sourceWord from: destinationWord
						nBits: 5 nPartitions: 3)
		+ ((self partitionedSub: sourceWord>>16 from: destinationWord>>16
						nBits: 5 nPartitions: 3) << 16)]
	ifFalse:
		["Sub RGB components of the pixel separately"
		^ self partitionedSub: sourceWord from: destinationWord
						nBits: 8 nPartitions: 3]! !

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 2/10/2000 17:01'!
srcPaint: sourceWord with: destinationWord
	"Replace those pixels in destinationWord where the
	associated pixel in sourceWord is different from sourceAlphaKey.
	Note: This will only work for sourceDepth = destDepth."
	| mask key result val |
	self inline: false.
	"Note: If sourceDepth ~= destDepth or warpMode the pixels are pre-merged"
	(sourceDepth = destDepth and:[noWarp])
		ifFalse:[^sourceWord].
	mask _ maskTable at: pixelDepth.
	key _ sourceAlphaKey.
	result _ 0.
	0 to: destPPW-1 do:[:i|
		(val _ sourceWord bitAnd: mask) = key
			ifTrue:[result _ result bitOr: (destinationWord bitAnd: mask)]
			ifFalse:[result _ result bitOr: val].
		mask _ mask << pixelDepth.
		key _ key << pixelDepth].
	^result! !

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

!FXBltSimulation methodsFor: 'combination rules' stamp: 'ar 1/17/2000 19:58'!
tallyIntoMap: sourceWord with: destinationWord
	"Tally pixels into the color map.  Those tallied are exactly those
	in the destination rectangle.  Note that the source should be 
	specified == destination, in order for the proper color map checks 
	to be performed at setup."
	| mapIndex pixMask mask shiftWord |
	self inline: false.
	tallyMapSize = 0 ifTrue: [^ destinationWord "no op"].
	pixMask _ maskTable at: pixelDepth.
	shiftWord _ destinationWord.
	mask _ destMask.
	1 to: destPPW do:[:i |
		(mask bitAnd: pixMask) = 0 ifFalse:[
			mapIndex _ shiftWord bitAnd: pixMask.
			mapIndex _ self mapPixel: mapIndex.
			(mapIndex >= 0 and:[mapIndex < tallyMapSize]) ifTrue:[
				tallyMap at: mapIndex put: (tallyMap at: mapIndex) + 1]].
		mask _ mask >> pixelDepth.
		shiftWord _ shiftWord >> pixelDepth].
	^ destinationWord  "For no effect on dest"! !


!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 11/16/1998 00:23'!
default8To32Table
	"Return the default translation table from 1..8 bit indexed colors to 32bit"
	"The table has been generated by the following statements"
	"| pvs hex |
	String streamContents:[:s|
		s nextPutAll:'static unsigned int theTable[256] = { '.
		pvs _ (Color colorMapIfNeededFrom: 8 to: 32) asArray.
		1 to: pvs size do:[:i|
			i > 1 ifTrue:[s nextPutAll:', '].
			(i-1 \\ 8) = 0 ifTrue:[s cr].
			s nextPutAll:'0x'.
			hex _ (pvs at: i) printStringBase: 16.
			s nextPutAll: (hex copyFrom: 4 to: hex size).
		].
		s nextPutAll:'};'.
	]."
	| theTable |
	self returnTypeC:'unsigned int *'.
	self var: #theTable declareC:'static unsigned int theTable[256] = { 
0x0, 0xFF000001, 0xFFFFFFFF, 0xFF808080, 0xFFFF0000, 0xFF00FF00, 0xFF0000FF, 0xFF00FFFF, 
0xFFFFFF00, 0xFFFF00FF, 0xFF202020, 0xFF404040, 0xFF606060, 0xFF9F9F9F, 0xFFBFBFBF, 0xFFDFDFDF, 
0xFF080808, 0xFF101010, 0xFF181818, 0xFF282828, 0xFF303030, 0xFF383838, 0xFF484848, 0xFF505050, 
0xFF585858, 0xFF686868, 0xFF707070, 0xFF787878, 0xFF878787, 0xFF8F8F8F, 0xFF979797, 0xFFA7A7A7, 
0xFFAFAFAF, 0xFFB7B7B7, 0xFFC7C7C7, 0xFFCFCFCF, 0xFFD7D7D7, 0xFFE7E7E7, 0xFFEFEFEF, 0xFFF7F7F7, 
0xFF000001, 0xFF003300, 0xFF006600, 0xFF009900, 0xFF00CC00, 0xFF00FF00, 0xFF000033, 0xFF003333, 
0xFF006633, 0xFF009933, 0xFF00CC33, 0xFF00FF33, 0xFF000066, 0xFF003366, 0xFF006666, 0xFF009966, 
0xFF00CC66, 0xFF00FF66, 0xFF000099, 0xFF003399, 0xFF006699, 0xFF009999, 0xFF00CC99, 0xFF00FF99, 
0xFF0000CC, 0xFF0033CC, 0xFF0066CC, 0xFF0099CC, 0xFF00CCCC, 0xFF00FFCC, 0xFF0000FF, 0xFF0033FF, 
0xFF0066FF, 0xFF0099FF, 0xFF00CCFF, 0xFF00FFFF, 0xFF330000, 0xFF333300, 0xFF336600, 0xFF339900, 
0xFF33CC00, 0xFF33FF00, 0xFF330033, 0xFF333333, 0xFF336633, 0xFF339933, 0xFF33CC33, 0xFF33FF33, 
0xFF330066, 0xFF333366, 0xFF336666, 0xFF339966, 0xFF33CC66, 0xFF33FF66, 0xFF330099, 0xFF333399, 
0xFF336699, 0xFF339999, 0xFF33CC99, 0xFF33FF99, 0xFF3300CC, 0xFF3333CC, 0xFF3366CC, 0xFF3399CC, 
0xFF33CCCC, 0xFF33FFCC, 0xFF3300FF, 0xFF3333FF, 0xFF3366FF, 0xFF3399FF, 0xFF33CCFF, 0xFF33FFFF, 
0xFF660000, 0xFF663300, 0xFF666600, 0xFF669900, 0xFF66CC00, 0xFF66FF00, 0xFF660033, 0xFF663333, 
0xFF666633, 0xFF669933, 0xFF66CC33, 0xFF66FF33, 0xFF660066, 0xFF663366, 0xFF666666, 0xFF669966, 
0xFF66CC66, 0xFF66FF66, 0xFF660099, 0xFF663399, 0xFF666699, 0xFF669999, 0xFF66CC99, 0xFF66FF99, 
0xFF6600CC, 0xFF6633CC, 0xFF6666CC, 0xFF6699CC, 0xFF66CCCC, 0xFF66FFCC, 0xFF6600FF, 0xFF6633FF, 
0xFF6666FF, 0xFF6699FF, 0xFF66CCFF, 0xFF66FFFF, 0xFF990000, 0xFF993300, 0xFF996600, 0xFF999900, 
0xFF99CC00, 0xFF99FF00, 0xFF990033, 0xFF993333, 0xFF996633, 0xFF999933, 0xFF99CC33, 0xFF99FF33, 
0xFF990066, 0xFF993366, 0xFF996666, 0xFF999966, 0xFF99CC66, 0xFF99FF66, 0xFF990099, 0xFF993399, 
0xFF996699, 0xFF999999, 0xFF99CC99, 0xFF99FF99, 0xFF9900CC, 0xFF9933CC, 0xFF9966CC, 0xFF9999CC, 
0xFF99CCCC, 0xFF99FFCC, 0xFF9900FF, 0xFF9933FF, 0xFF9966FF, 0xFF9999FF, 0xFF99CCFF, 0xFF99FFFF, 
0xFFCC0000, 0xFFCC3300, 0xFFCC6600, 0xFFCC9900, 0xFFCCCC00, 0xFFCCFF00, 0xFFCC0033, 0xFFCC3333, 
0xFFCC6633, 0xFFCC9933, 0xFFCCCC33, 0xFFCCFF33, 0xFFCC0066, 0xFFCC3366, 0xFFCC6666, 0xFFCC9966, 
0xFFCCCC66, 0xFFCCFF66, 0xFFCC0099, 0xFFCC3399, 0xFFCC6699, 0xFFCC9999, 0xFFCCCC99, 0xFFCCFF99, 
0xFFCC00CC, 0xFFCC33CC, 0xFFCC66CC, 0xFFCC99CC, 0xFFCCCCCC, 0xFFCCFFCC, 0xFFCC00FF, 0xFFCC33FF, 
0xFFCC66FF, 0xFFCC99FF, 0xFFCCCCFF, 0xFFCCFFFF, 0xFFFF0000, 0xFFFF3300, 0xFFFF6600, 0xFFFF9900, 
0xFFFFCC00, 0xFFFFFF00, 0xFFFF0033, 0xFFFF3333, 0xFFFF6633, 0xFFFF9933, 0xFFFFCC33, 0xFFFFFF33, 
0xFFFF0066, 0xFFFF3366, 0xFFFF6666, 0xFFFF9966, 0xFFFFCC66, 0xFFFFFF66, 0xFFFF0099, 0xFFFF3399, 
0xFFFF6699, 0xFFFF9999, 0xFFFFCC99, 0xFFFFFF99, 0xFFFF00CC, 0xFFFF33CC, 0xFFFF66CC, 0xFFFF99CC, 
0xFFFFCCCC, 0xFFFFFFCC, 0xFFFF00FF, 0xFFFF33FF, 0xFFFF66FF, 0xFFFF99FF, 0xFFFFCCFF, 0xFFFFFFFF};'.
	^theTable! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 10/27/1999 17:54'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments."
	self inline: true.
	x2 > x1
		ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 7/24/1999 19:16'!
dither32To16: srcWord threshold: ditherValue
	"Dither the given 32bit word to 16 bit. Ignore alpha."
	| pv threshold value out |
	self inline: true. "You bet"
	pv _ srcWord bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ value + 1]
		ifFalse:[out _ value].
	pv _ (srcWord bitShift: -8) bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ out bitOr: (value+1 bitShift:5)]
		ifFalse:[out _ out bitOr: (value bitShift: 5)].
	pv _ (srcWord bitShift: -16) bitAnd: 255.
	threshold _ ditherThresholds16 at: (pv bitAnd: 7).
	value _ ditherValues16 at: (pv bitShift: -3).
	ditherValue < threshold
		ifTrue:[out _ out bitOr: (value+1 bitShift:10)]
		ifFalse:[out _ out bitOr: (value bitShift: 10)].
	^out! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 2/9/2000 20:48'!
isIdentityMap: shifts with: masks
	"Return true if shiftTable/maskTable define an identity mapping."
	self var: #shifts declareC:'int *shifts'.
	self var: #masks declareC:'int *masks'.
	(shifts == nil or:[masks == nil]) ifTrue:[^true].
	((shifts at: RedIndex) = 0 
		and:[(shifts at: GreenIndex) = 0
		and:[(shifts at: BlueIndex) = 0 
		and:[(shifts at: AlphaIndex) = 0
			and:[((masks at: RedIndex) = 16rFF0000)
			and:[((masks at: GreenIndex) = 16r00FF00)
			and:[((masks at: BlueIndex) = 16r0000FF)
			and:[((masks at: AlphaIndex) = 16rFF000000)]]]]]]])
		ifTrue:[^true].
	^false! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 1/10/2000 18:32'!
mapDestPixel: destPixel
	"Expand the given destination pixel value into canonical RGBA space."
	| val |
	self inline: true.
	noDestMap ifTrue:[^destPixel].
	destMap == nil
		ifTrue:[val _ destPixel]
		ifFalse:[val _ destMap at: (destPixel bitAnd: dmMask)].
	(dmShiftTable == nil or:[dmMaskTable == nil])
		ifTrue:[^val]
		ifFalse:[^self rgbMapPixel: val shifts: dmShiftTable masks: dmMaskTable].! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 1/13/2000 22:11'!
mapPixel: sourcePixel
	"Color map the given source pixel."
	| pv |
	self inline: true.
	noColorMap ifTrue:[^sourcePixel].
	(cmMaskTable == nil or:[cmShiftTable == nil])
		ifTrue:[pv _ sourcePixel]
		ifFalse:[pv _ self rgbMapPixel: sourcePixel shifts: cmShiftTable masks: cmMaskTable].
	colorMap == nil
		ifTrue:[^pv]
		ifFalse:[^colorMap at: (pv bitAnd: cmMask)]! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 1/10/2000 18:33'!
mapSourcePixel: sourcePixel
	"Expand the given source pixel value into canonical RGBA space."
	| val |
	self inline: true.
	noSourceMap ifTrue:[^sourcePixel].
	sourceMap == nil
		ifTrue:[val _ sourcePixel]
		ifFalse:[val _ sourceMap at: (sourcePixel bitAnd: smMask)].
	(smShiftTable == nil or:[smMaskTable == nil])
		ifTrue:[^val]
		ifFalse:[^self rgbMapPixel: val shifts: smShiftTable masks: smMaskTable].! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 2/16/2000 17:12'!
pickSourcePixels: nPixels srcMask: srcMask destMask: dstMask paintMode: paintMode destWord: destinationWord
	"Pick nPix pixels starting at srcBitIndex from the source, map by the
	color map, and justify them according to dstBitIndex in the resulting destWord."
	| sourceWord destWord sourcePix destPix srcShift dstShift nPix lastPix |
	"Note: The method must be inlined for LSB-MSB conversion"
	self inline: true.
	sourceWord _ self srcLongAt: sourceIndex.
	destWord _ 0.
	srcShift _ srcBitShift. "Hint: Keep in register"
	dstShift _ dstBitShift. "Hint: Keep in register"
	nPix _ nPixels. "always > 0 so we can use do { } while(--nPix);"
	"Pick and map first pixel so we can avoid the color conversion"
	lastPix _ sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
	destPix _ self mapPixel: sourcePix.
	["Mix in pixel"
	(paintMode and:[sourcePix = sourceAlphaKey]) ifTrue:[
		destWord _ destWord bitOr: (destinationWord bitAnd: (dstMask << dstShift)).
	] ifFalse:[destWord _ destWord bitOr: (destPix bitAnd: dstMask) << dstShift].
	destMSB
		ifTrue:[dstShift _ dstShift - destDepth]
		ifFalse:[dstShift _ dstShift + destDepth].
	"Adjust source if at pixel boundary"
	sourceMSB ifTrue:[
		(srcShift _ srcShift - sourceDepth) < 0 ifTrue:
			[srcShift _ srcShift + 32.
			sourceWord _ self srcLongAt: (sourceIndex _ sourceIndex + 4)].
	] ifFalse:[
		(srcShift _ srcShift + sourceDepth) > 31 ifTrue:
			[srcShift _ srcShift - 32.
			sourceWord _ self srcLongAt: (sourceIndex _ sourceIndex + 4)].
	].
	(nPix _ nPix - 1) = 0] whileFalse:["Pick and map next pixel"
		sourcePix _ sourceWord >> srcShift bitAnd: srcMask.
		lastPix = sourcePix ifFalse:[
			"map the pixel(either into colorMap or destFormat)"
			destPix _ self mapPixel: sourcePix.
			lastPix _ sourcePix]].
	srcBitShift _ srcShift. "Store back"
	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	destMSB
		ifTrue:[dstBitShift _ 32 - destDepth] "Shift towards leftmost pixel"
		ifFalse:[dstBitShift _ 0].
	^destWord! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 1/11/2000 01:45'!
pickWarpPixelAtX: x y: y
	"Pick a single pixel from the source for WarpBlt.
	Note: This method is crucial for WarpBlt speed w/o smoothing
	and still relatively important when smoothing is used."
	| srcIndex sourceWord sourcePix |
	self inline: true.
	"Fetch source word.
	Note: We should really update srcIndex with sx and sy so that
	we don't have to do the computation below. We might even be
	able to simplify the out of bounds test from above."
	srcIndex _ sourceBits + (y * sourcePitch) + (x >> warpAlignShift * 4).
	sourceWord _ self srcLongAt: srcIndex.

	"Extract pixel from word"
	srcBitShift _ warpBitShiftTable at: (x bitAnd: warpAlignMask).
	sourcePix _ sourceWord >> srcBitShift bitAnd: warpSrcMask.
	^sourcePix! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 1/10/2000 16:16'!
rgbMapPixel: sourcePixel shifts: shifts masks: masks
	"Perform the RGBA conversion for the given source pixel"
	| val mask shift |
	self inline: true.
	val _ 0.
	mask _ (self cCoerce: masks to:'int*') at: RedIndex.
	shift _ (self cCoerce: shifts to:'int*') at: RedIndex.
	val _ val bitOr: ((sourcePixel bitAnd: mask) bitShift: shift).
	mask _ (self cCoerce: masks to:'int*') at: GreenIndex.
	shift _ (self cCoerce: shifts to:'int*') at: GreenIndex.
	val _ val bitOr: ((sourcePixel bitAnd: mask) bitShift: shift).
	mask _ (self cCoerce: masks to:'int*') at: BlueIndex.
	shift _ (self cCoerce: shifts to:'int*') at: BlueIndex.
	val _ val bitOr: ((sourcePixel bitAnd: mask) bitShift: shift).
	mask _ (self cCoerce: masks to:'int*') at: AlphaIndex.
	mask = 0 "common case"
		ifFalse:[shift _ (self cCoerce: shifts to:'int*') at: AlphaIndex.
				val _ val bitOr: ((sourcePixel bitAnd: mask) bitShift: shift)].
	"Avoid transparency by color reduction.
	Ugh ... check this!!!!!!"
	(val = 0 and:[sourcePixel ~= 0]) ifTrue:[val _ 1].
	^val! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 2/13/2000 15:47'!
warpPickSmoothPixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	paintMode: paintMode destWord: destinationWord
	"Pick n (sub-) pixels from the source form, mapped by sourceMap,
	average the RGB values, map by colorMap and return the new word.
	This version is only called from WarpBlt with smoothingCount > 1"
	| rgb x y a r g b xx yy xdh ydh xdv ydv 
	dstMask destWord i j k nPix pv n ptX ptY |
	self inline: false. "nope - too much stuff in here"
	n _ warpQuality.
	n = 2 "Try avoiding divides for most common n (divide by 2 is generated as shift)"
		ifTrue:[xdh _ xDeltah // 2. ydh _ yDeltah // 2. 
				xdv _ xDeltav // 2. ydv _ yDeltav // 2]
		ifFalse:[xdh _ xDeltah // n. ydh _ yDeltah // n. 
				xdv _ xDeltav // n. ydv _ yDeltav // n].
	dstMask _ maskTable at: destDepth.
	destWord _ 0.
	i _ nPixels.
	[
		x _ sx. y _ sy.
		a _ r _ g _ b _ 0.
		"Pick and average n*n subpixels"
		nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
		j _ n.
		[
			xx _ x. yy _ y.
			k _ n.
			[
				"get a single subpixel if not clipped"
				(xx < 0 or:[yy < 0 or:[
					(ptX _ xx >> BinaryPoint) >= sourceWidth or:[
						(ptY _ yy >> BinaryPoint) >= sourceHeight]]]) ifFalse:[
				pv _ self pickWarpPixelAtX: ptX y: ptY.
				(paintMode and: [pv = sourceAlphaKey]) ifFalse:[
					"If not clipped and not transparent, then tally rgb values"
					nPix _ nPix + 1.
					rgb _ self mapSourcePixel: pv.
					b _ b + (rgb bitAnd: 255).
					g _ g + (rgb >> 8 bitAnd: 255).
					r _ r + (rgb >> 16 bitAnd: 255).
					a _ a + (rgb >> 24)]].
				xx _ xx + xdh.
				yy _ yy + ydh.
			(k _ k - 1) = 0] whileFalse.
			x _ x + xdv.
			y _ y + ydv.
		(j _ j - 1) = 0] whileFalse.

		(nPix = 0 or: [paintMode and: [nPix < (n * n // 2)]]) ifTrue:[
			nPix _ pv _ 0  "All pixels were 0, or most were transparent"
		] ifFalse:[
			"normalize rgba sums"
			nPix = 4 "Try to avoid divides for most common n"
				ifTrue:[r _ r >> 2.	g _ g >> 2.	b _ b >> 2.	a _ a >> 2]
				ifFalse:[	r _ r // nPix.	g _ g // nPix.	b _ b // nPix.	a _ a // nPix].
			rgb _ (a << 24) + (r << 16) + (g << 8) + b.

			"map the pixel"
			rgb = 0 ifTrue: [
				"only generate zero if pixel is really transparent"
				(r + g + b + a) > 0 ifTrue: [rgb _ 1]].
			pv _ self mapPixel: rgb.
		].
		"Mix it in"
		nPix = 0 
			ifTrue:[destWord _ destWord bitOr: (destinationWord bitAnd: (dstMask << dstBitShift))]
			ifFalse:[destWord _ destWord bitOr: (pv bitAnd: dstMask) << dstBitShift].
		destMSB
			ifTrue:[dstBitShift _ dstBitShift - destDepth]
			ifFalse:[dstBitShift _ dstBitShift + destDepth].
		sx _ sx + xDeltah.
		sy _ sy + yDeltah.
	(i _ i - 1) = 0] whileFalse.

	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	destMSB "Shift towards leftmost pixel"
		ifTrue:[dstBitShift _ 32 - destDepth]
		ifFalse:[dstBitShift _ 0].
	^destWord! !

!FXBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 2/13/2000 15:48'!
warpPickSourcePixels: nPixels
	xDeltah: xDeltah yDeltah: yDeltah
	xDeltav: xDeltav yDeltav: yDeltav
	paintMode: paintMode destWord: destinationWord
	"Pick n pixels from the source form,
	map by colorMap and return aligned by dstBitShift.
	This version is only called from WarpBlt with smoothingCount = 1"
	| dstMask resultWord nPix sourcePix mappedPix lastPix x y hasPix |
	self inline: true. "This should go into warpLoop"
	dstMask _ maskTable at: destDepth.
	resultWord _ 0.
	nPix _ nPixels.
	"Pick and map first pixel to avoid color conversion"
	lastPix _ 0.
	hasPix _ false.
	(sx < 0 or:[sy < 0 or:[
		(x _ sx >> BinaryPoint) >= sourceWidth or:[
			(y _ sy >> BinaryPoint) >= sourceHeight]]]) ifFalse:[
				lastPix _ sourcePix _ self pickWarpPixelAtX: x y: y.
				(paintMode and:[sourcePix = sourceAlphaKey])
					ifFalse:[hasPix _ true]].
	"Note: lastPix might be zero here but who cares..."
	mappedPix _ self mapPixel: lastPix.
	["Mix it in"
	hasPix
		ifTrue:[resultWord _ resultWord bitOr: 
					(mappedPix bitAnd: dstMask) << dstBitShift]
		ifFalse:[resultWord _ resultWord bitOr: 
					(destinationWord bitAnd: (dstMask << dstBitShift))].
	destMSB
		ifTrue:[dstBitShift _ dstBitShift - destDepth]
		ifFalse:[dstBitShift _ dstBitShift + destDepth].
	sx _ sx + xDeltah.
	sy _ sy + yDeltah.
	(nPix _ nPix - 1) = 0] whileFalse:["Pick and map next pixel"
		hasPix _ false.
		(sx < 0 or:[sy < 0 or:[
			(x _ sx >> BinaryPoint) >= sourceWidth or:[
				(y _ sy >> BinaryPoint) >= sourceHeight]]]) ifFalse:[
			sourcePix _ self pickWarpPixelAtX: x y: y.
			(paintMode and:[sourcePix = sourceAlphaKey]) ifFalse:[
				hasPix _ true.
				lastPix = sourcePix ifFalse:[
					"map the pixel(either into colorMap or destFormat)"
					mappedPix _ self mapPixel: sourcePix.
					lastPix _ sourcePix]]].
	].
	"*** side effect ***"
	"*** only the first pixel fetch can be unaligned ***"
	"*** prepare the next one for aligned access ***"
	destMSB "Shift towards leftmost pixel"
		ifTrue:[dstBitShift _ 32 - destDepth]
		ifFalse:[dstBitShift _ 0].
	^resultWord! !


!FXBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:23'!
dstLongAt: idx
	^interpreterProxy longAt: idx! !

!FXBltSimulation methodsFor: 'memory access' stamp: 'ar 10/26/1999 18:08'!
dstLongAt: idx put: value
	^interpreterProxy longAt: idx put: value! !

!FXBltSimulation methodsFor: 'memory access' stamp: 'ar 12/7/1999 21:09'!
dstLongAt: idx put: srcValue mask: dstMask
	"Store the given value back into destination form, using dstMask
	to mask out the bits to be modified. This is an essiantial
	read-modify-write operation on the destination form."
	| dstValue |
	self inline: true.
	dstValue _ self dstLongAt: idx.
	dstValue _ dstValue bitAnd: dstMask.
	dstValue _ dstValue bitOr: srcValue.
	self dstLongAt: idx put: dstValue.! !

!FXBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:22'!
halftoneAt: idx
	"Return a value from the halftone pattern."
	^interpreterProxy longAt: halftoneBase + (idx \\ halftoneHeight * 4)! !

!FXBltSimulation methodsFor: 'memory access' stamp: 'ar 10/25/1999 19:23'!
srcLongAt: idx
	^interpreterProxy longAt: idx! !


!FXBltSimulation methodsFor: 'surface support' stamp: 'ar 5/25/2000 16:10'!
loadSurfacePlugin
	"Load the surface support plugin"
	querySurfaceFn _ interpreterProxy ioLoadFunction:'ioGetSurfaceFormat' From:'SurfacePlugin'.
	lockSurfaceFn _ interpreterProxy ioLoadFunction:'ioLockSurface' From:'SurfacePlugin'.
	unlockSurfaceFn _ interpreterProxy ioLoadFunction:'ioUnlockSurface' From:'SurfacePlugin'.
	^querySurfaceFn ~= 0 and:[lockSurfaceFn ~= 0 and:[unlockSurfaceFn ~= 0]]! !

!FXBltSimulation methodsFor: 'surface support' stamp: 'ar 5/25/2000 16:39'!
lockSurfaces
	"Get a pointer to the bits of any OS surfaces."
	"Notes: 
	* For equal source/dest handles only one locking operation is performed.
	This is to prevent locking of overlapping areas which does not work with
	certain APIs (e.g., DirectDraw prevents locking of overlapping areas). 
	A special case for non-overlapping but equal source/dest handle would 
	be possible but we would have to transfer this information over to 
	unlockSurfaces somehow (currently, only one unlock operation is 
	performed for equal source and dest handles). Also, this would require
	a change in the notion of ioLockSurface() which is right now interpreted
	as a hint and not as a requirement to lock only the specific portion of
	the surface.

	* The arguments in ioLockSurface() provide the implementation with
	an explicit hint what area is affected. It can be very useful to
	know the max. affected area beforehand if getting the bits requires expensive
	copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
	However, the returned pointer *MUST* point to the virtual origin of the surface
	and not to the beginning of the rectangle. The promise made by BitBlt
	is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
	so it is okay to return a pointer to the virtual origin that is actually outside
	the valid memory area.

	* The area provided in ioLockSurface() is already clipped (e.g., it will always
	be inside the source and dest boundingBox) but it is not aligned to word boundaries
	yet. It is up to the support code to compute accurate alignment if necessary.

	* Warping always requires the entire source surface to be locked because
	there is no beforehand knowledge about what area will actually be traversed.

	"
	| sourceHandle destHandle l r t b fn |
	self inline: true. "If the CCodeGen learns how to inline #cCode: methods"
	self var: #fn declareC:'int (*fn)(int, int*, int, int, int, int)'.
	hasSurfaceLock _ false.
	destBits = 0 ifTrue:["Blitting *to* OS surface"
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: lockSurfaceFn to: 'int (*)(int, int*, int, int, int, int)'.
		destHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: destForm.
		(sourceBits = 0 and:[noSource not]) ifTrue:[
			sourceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
			"Handle the special case of equal source and dest handles"
			(sourceHandle = destHandle) ifTrue:[
				"If we have overlapping source/dest we lock the entire area
				so that there is only one area transmitted"
				noWarp ifTrue:[
					l _ sx min: dx. r _ (sx max: dx) + bbW.
					t _ sy min: dy. b _ (sy max: sy) + bbH.
					sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, l, t, r-l, b-t)'.
				] ifFalse:[
					"When warping we always need the entire surface for the source"
					sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, 0,0, sourceWidth, sourceHeight)'.
				].
				destBits _ sourceBits.
				destPitch _ sourcePitch.
				hasSurfaceLock _ true.
				^destBits ~~ 0
			].
			"Fall through - if not equal it'll be handled below"
		].
		destBits _ self cCode:'fn(destHandle, &destPitch, dx, dy, bbW, bbH)'.
		hasSurfaceLock _ true.
	].
	(sourceBits == 0 and:[noSource not]) ifTrue:["Blitting *from* OS surface"
		sourceHandle _ interpreterProxy fetchInteger: FormBitsIndex ofObject: sourceForm.
		lockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: lockSurfaceFn to: 'int (*)(int, int*, int, int, int, int)'.
		"Warping requiring the entire surface"
		noWarp ifTrue:[
			sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, sx, sy, bbW, bbH)'.
		] ifFalse:[
			sourceBits _ self cCode:'fn(sourceHandle, &sourcePitch, 0, 0, sourceWidth, sourceHeight)'.
		].
		hasSurfaceLock _ true.
	].
	^destBits ~~ 0 and:[sourceBits ~~ 0 or:[noSource]].! !

!FXBltSimulation methodsFor: 'surface support' stamp: 'ar 5/25/2000 16:01'!
queryDestSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((int (*) (int, int*, int*, int*, int*))querySurfaceFn)
		(handle, &destWidth, &destHeight, &destDepth, &destMSB)'
			 inSmalltalk:[false])! !

!FXBltSimulation methodsFor: 'surface support' stamp: 'ar 5/25/2000 16:00'!
querySourceSurface: handle
	"Query the dimension of an OS surface.
	This method is provided so that in case the inst vars of the
	source form are broken, *actual* values of the OS surface
	can be obtained. This might, for instance, happen if the user
	resizes the main window.
	Note: Moved to a separate function for better inlining of the caller."
	querySurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^false]].
	^(self cCode:' ((int (*) (int, int*, int*, int*, int*))querySurfaceFn)
		(handle, &sourceWidth, &sourceHeight, &sourceDepth, &sourceMSB)'
			inSmalltalk:[false])! !

!FXBltSimulation methodsFor: 'surface support' stamp: 'ar 5/25/2000 16:07'!
unlockSurfaces
	"Unlock the bits of any OS surfaces."
	"See the comment in lockSurfaces. Similar rules apply. That is, the area provided in ioUnlockSurface can be used to determine the dirty region after drawing. If a source is unlocked, then the area will be (0,0,0,0) to indicate that no portion is dirty."
	| sourceHandle destHandle destLocked fn |
	self var: #fn declareC:'int (*fn)(int, int, int, int, int)'.
	hasSurfaceLock ifTrue:[
		unlockSurfaceFn = 0 ifTrue:[self loadSurfacePlugin ifFalse:[^nil]].
		fn _ self cCoerce: unlockSurfaceFn to: 'int (*)(int, int, int, int, int)'.
		destLocked _ false.
		destHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
		(interpreterProxy isIntegerObject: destHandle) ifTrue:[
			destHandle _ interpreterProxy integerValueOf: destHandle.
			"The destBits are always assumed to be dirty"
			self cCode:'fn(destHandle, affectedL, affectedT, affectedR-affectedL, affectedB-affectedT)'.
			destBits _ destPitch _ 0.
			destLocked _ true.
		].
		noSource ifFalse:[
			sourceHandle _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
			(interpreterProxy isIntegerObject: sourceHandle) ifTrue:[
				sourceHandle _ interpreterProxy integerValueOf: sourceHandle.
				"Only unlock sourceHandle if different from destHandle"
				(destLocked and:[sourceHandle = destHandle]) 
					ifFalse:[self cCode: 'fn(sourceHandle, 0, 0, 0, 0)'].
				sourceBits _ sourcePitch _ 0.
			].
		].
		hasSurfaceLock _ false.
	].! !


!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
copyLoopPixMapLsbLsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self copyLoopPixMap.
! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
copyLoopPixMapLsbMsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self copyLoopPixMap.
! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
copyLoopPixMapMsbLsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self copyLoopPixMap.
! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
copyLoopPixMapMsbMsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self copyLoopPixMap.
! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/16/2000 17:41'!
doCopyLoopPixMap
	self inline: true.
	sourceMSB ifTrue:[
		destMSB 
			ifTrue:[self copyLoopPixMapMsbMsb]
			ifFalse:[self copyLoopPixMapMsbLsb]
	] ifFalse:[
		destMSB
			ifTrue:[self copyLoopPixMapLsbMsb]
			ifFalse:[self copyLoopPixMapLsbLsb]
	].! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/16/2000 17:41'!
doWarpLoop
	self inline: true.
	sourceMSB ifTrue:[
		destMSB 
			ifTrue:[self warpLoopMsbMsb]
			ifFalse:[self warpLoopMsbLsb]
	] ifFalse:[
		destMSB
			ifTrue:[self warpLoopLsbMsb]
			ifFalse:[self warpLoopLsbLsb]
	].! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
warpLoopLsbLsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self warpLoop.! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:19'!
warpLoopLsbMsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self warpLoop.! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:20'!
warpLoopMsbLsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self warpLoop.! !

!FXBltSimulation methodsFor: 'special inner loops' stamp: 'ar 2/19/2000 20:20'!
warpLoopMsbMsb
	"Note: This loop is specialized by the CCodeGenerator."
	self inline: false.
	self warpLoop.! !

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

FXBltSimulation class
	instanceVariableNames: ''!

!FXBltSimulation class methodsFor: 'initialization' stamp: 'ar 2/16/2000 19:17'!
initialize
	"BitBltSimulation initialize"
  
	self initializeRuleTable.

	"Mask constants"
	AllOnes _ 16rFFFFFFFF.
	BinaryPoint _ 14.
	FixedPt1 _ 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"
 
	"Form fields"
	FormBitsIndex _ 0.
	FormWidthIndex _ 1.
	FormHeightIndex _ 2.
	FormDepthIndex _ 3.
 
	"BitBlt fields"
	BBDestFormIndex _ 0.
	BBSourceFormIndex _ 1.
	BBHalftoneFormIndex _ 2.
	BBRuleIndex _ 3.
	BBDestXIndex _ 4.
	BBDestYIndex _ 5.
	BBWidthIndex _ 6.
	BBHeightIndex _ 7.
	BBSourceXIndex _ 8.
	BBSourceYIndex _ 9.
	BBClipXIndex _ 10.
	BBClipYIndex _ 11.
	BBClipWidthIndex _ 12.
	BBClipHeightIndex _ 13.
	BBColorMapIndex _ 14.

	FXSourceMapIndex _ 15.
	FXDestMapIndex _ 16.
	FXWarpQuadIndex _ 17.
	FXWarpQualityIndex _ 18.
	FXSourceKeyIndex _ 19.
	FXDestKeyIndex _ 20.
	FXSourceAlphaIndex _ 21.
	FXTallyMapIndex _ 22.

	"RGBA indexes"
	RedIndex _ 0.
	GreenIndex _ 1.
	BlueIndex _ 2.
	AlphaIndex _ 3.

	"Color cache"
	ColorCacheSize _ 512. "Should be at least 256 and must be power of two"
	ColorCacheMask _ ColorCacheSize - 1.
	InvalidColorCacheEntry _ 16r01EC1B55.
! !

!FXBltSimulation class methodsFor: 'initialization' stamp: 'ar 1/22/2000 15:46'!
initializeRuleTable
	"BitBltSimulation initializeRuleTable"
	"**WARNING** You MUST change initBBOpTable if you change this"
	OpTable _ #(
		"0" clearWord:with:
		"1" bitAnd:with:
		"2" bitAndInvert:with:
		"3" sourceWord:with:
		"4" bitInvertAnd:with:
		"5" destinationWord:with:
		"6" bitXor:with:
		"7" bitOr:with:
		"8" bitInvertAndInvert:with:
		"9" bitInvertXor:with:
		"10" bitInvertDestination:with:
		"11" bitOrInvert:with:
		"12" bitInvertSource:with:
		"13" bitInvertOr:with:
		"14" bitInvertOrInvert:with:
		"15" destinationWord:with:
		"16" destinationWord:with: "unused - was old paint"
		"17" destinationWord:with: "unused - was old mask"
		"18" addWord:with:
		"19" subWord:with:
		"20" rgbAdd:with:
		"21" rgbSub:with:
		"22" OLDrgbDiff:with:
		"23" OLDtallyIntoMap:with:
		"24" alphaBlend:with:
		"25" pixPaint:with:
		"26" pixMask:with:
		"27" rgbMax:with:
		"28" rgbMin:with:
		"29" rgbMinInvert:with:
		"30" alphaBlendConst:with:
		"31" alphaPaintConst:with:
		"32" rgbDiff:with:
		"33" tallyIntoMap:with:
		"34" alphaBlendScaled:with:
		"35"	srcPaint:with:
		"36" dstPaint:with:
	).
	OpTableSize _ OpTable size + 1.  "0-origin indexing"
! !

!FXBltSimulation class methodsFor: 'initialization'!
test2  "BitBltSimulation test2"
	| f |
	Display fillWhite: (0@0 extent: 300@140).
	1 to: 12 do:
		[:i | f _ (Form extent: i@5) fillBlack.
		0 to: 20 do:
			[:x | f displayOn: Display
					at: (x*13) @ (i*10)]]! !

!FXBltSimulation class methodsFor: 'initialization'!
timingTest: extent  "BitBltSimulation timingTest: 640@480"
	| f f2 map |
	f _ Form extent: extent depth: 8.
	f2 _ Form extent: extent depth: 8.
	map _ Bitmap new: 1 << f2 depth.
	^ Array with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f fillWithColor: Color white]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copy: f boundingBox from: 0@0 in: f2 rule: Form over]])
	with:
	(Time millisecondsToRun: [100 timesRepeat:
		[f copyBits: f boundingBox from: f2 at: 0@0 colorMap: map]])! !


!FXBltSimulation class methodsFor: 'translation' stamp: 'ar 5/25/2000 16:29'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator
		var: 'colorMap' declareC:'int *colorMap';
		var: 'cmShiftTable' declareC:'int *cmShiftTable';
		var: 'cmMaskTable' declareC:'int *cmMaskTable';
		var: 'sourceMap' declareC:'int *sourceMap';
		var: 'smShiftTable' declareC:'int *smShiftTable';
		var: 'smMaskTable' declareC:'int *smMaskTable';
		var: 'destMap' declareC:'int *destMap';
		var: 'dmShiftTable' declareC:'int *dmShiftTable';
		var: 'dmMaskTable' declareC:'int *dmMaskTable';
		var: 'warpQuad' declareC:'int warpQuad[8]';
		var: 'tallyMap' declareC:'int *tallyMap'.
	aCCodeGenerator var: 'opTable'
		declareC: 'int opTable[' , OpTableSize printString , ']'.
	aCCodeGenerator var: 'maskTable'
		declareC:'int maskTable[33] = {
0, 1, 3, 0, 15, 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 65535,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1
}'.
	aCCodeGenerator var: 'ditherMatrix4x4'
		declareC:'const int ditherMatrix4x4[16] = {
0,	8,	2,	10,
12,	4,	14,	6,
3,	11,	1,	9,
15,	7,	13,	5
}'.
	aCCodeGenerator var: 'ditherThresholds16'
		declareC:'const int ditherThresholds16[8] = { 0, 2, 4, 6, 8, 12, 14, 16 }'.
	aCCodeGenerator var: 'ditherValues16'
		declareC:'const int ditherValues16[32] = {
0, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30
}'.

	aCCodeGenerator var: 'warpBitShiftTable'
		declareC:'int warpBitShiftTable[32]'.! !

!FXBltSimulation class methodsFor: 'translation' stamp: 'ar 2/21/2000 20:29'!
moduleName
	"FXBltScanner translateLocally"
	^'FXBltPlugin'! !

!FXBltSimulation class methodsFor: 'translation' stamp: 'jm 5/12/1999 12:02'!
opTable

	^ OpTable
! !

!FXBltSimulation class methodsFor: 'translation' stamp: 'ar 2/16/2000 19:32'!
specializeLoopsIn: cg
	"FXBltScanner translate"
	"Specialize those loops that benefit from a distinction of LSB vs. MSB variants"
	| i s |
	'Specializing inner loops' 
		displayProgressAt: Sensor cursorPoint
		from: 1 to: 8 during:[:bar|
	i _ 0.
	{true. false} do:[:srcMsb|
		{true. false} do:[:dstMsb|
			#(copyLoopPixMap warpLoop) do:[:sel|
				bar value: (i_i+1).
				s _ sel, (srcMsb ifTrue:['Msb'] ifFalse:['Lsb']),
							(dstMsb ifTrue:['Msb'] ifFalse:['Lsb']).
				s _ s asSymbol.
				cg specializeMethod: s variable: 'sourceMSB' value: srcMsb.
				cg specializeMethod: s variable: 'destMSB' value: dstMsb]]].
	].! !


!FXBltSimulation class methodsFor: 'system simulation' stamp: 'ar 10/27/1999 23:34'!
copyBitsFrom: aBitBlt
	"Simulate the copyBits primitive"
	| proxy bb |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	bb _ self simulatorClass new.
	bb setInterpreter: proxy.
	proxy success: (bb loadBitBltFrom: aBitBlt).
	bb copyBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm 
				Left: bb affectedLeft Top: bb affectedTop 
				Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !

!FXBltSimulation class methodsFor: 'system simulation' stamp: 'ar 2/21/2000 20:24'!
fxCopyBitsFrom: aBitBlt
	"Simulate the copyBits primitive"
	| proxy bb |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	bb _ self simulatorClass new.
	bb setInterpreter: proxy.
	proxy success: (bb loadBitBltFrom: aBitBlt).
	bb copyBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm 
				Left: bb affectedLeft Top: bb affectedTop 
				Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !

!FXBltSimulation class methodsFor: 'system simulation' stamp: 'ar 1/22/2000 15:45'!
simulatorClass
	^FXBltSimulator! !

!FXBltSimulation class methodsFor: 'system simulation' stamp: 'ar 1/10/2000 17:46'!
warpBitsFrom: aBitBlt
	"Simulate the warpBits primitive"
	| proxy bb |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	bb _ self simulatorClass new.
	bb setInterpreter: proxy.
	proxy success: (bb loadWarpBltFrom: aBitBlt).
	bb copyBits.
	proxy failed ifFalse:[
		proxy showDisplayBits: aBitBlt destForm 
				Left: bb affectedLeft Top: bb affectedTop 
				Right: bb affectedRight Bottom: bb affectedBottom].
	^proxy stackValue: 0! !
FXBltSimulation subclass: #FXBltSimulator
	instanceVariableNames: ''
	classVariableNames: 'ColorCacheHits ColorCacheMisses '
	poolDictionaries: ''
	category: 'Graphics-FXBlt'!

!FXBltSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/25/2000 15:42'!
initBBOpTable
	opTable _ OpTable.
	maskTable _ Array new: 32.
	#(1 2 4 8 16 32) do:[:i| maskTable at: i put: (1 << i)-1].
	self initializeDitherTables.
	warpBitShiftTable _ CArrayAccessor on: (Array new: 32).
	cmCache _ CArrayAccessor on: (Array new: ColorCacheSize*2).
	warpQuad _ CArrayAccessor on: (Array new: 8).! !

!FXBltSimulator methodsFor: 'as yet unclassified' stamp: 'ar 7/24/1999 23:20'!
initializeDitherTables
	ditherMatrix4x4 _ CArrayAccessor on:
		#(	0	8	2	10
			12	4	14	6
			3	11	1	9
			15	7	13	5).
	ditherThresholds16 _ CArrayAccessor on:#(0 2 4 6 8 10 12 14 16).
	ditherValues16 _ CArrayAccessor on: 
		#(0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14
		15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30).! !

!FXBltSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/25/2000 16:37'!
mergeFn: arg1 with: arg2
	^ self perform: (self cCoerce:(opTable at: combinationRule+1) to:'(int (*) (int,int))')
		with: arg1 with: arg2! !


!FXBltSimulator methodsFor: 'debug support' stamp: 'ar 10/27/1999 14:22'!
dstLongAt: dstIndex
	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex longAt: 0].
	((dstIndex anyMask: 3) or:[dstIndex + 4 < destBits or:[
		dstIndex > (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: dstIndex! !

!FXBltSimulator methodsFor: 'debug support' stamp: 'ar 10/27/1999 14:23'!
dstLongAt: dstIndex put: value
	interpreterProxy isInterpreterProxy
		ifTrue:[^dstIndex longAt: 0 put: value].
	((dstIndex anyMask: 3) or:[dstIndex < destBits or:[
		dstIndex >= (destBits + (destPitch * destHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: dstIndex put: value! !

!FXBltSimulator methodsFor: 'debug support' stamp: 'ar 1/9/2000 16:26'!
srcLongAt: srcIndex
	interpreterProxy isInterpreterProxy
		ifTrue:[^srcIndex longAt: 0].
	((srcIndex anyMask: 3) or:[srcIndex + 4 < sourceBits or:[
		srcIndex > (sourceBits + (sourcePitch * sourceHeight))]])
			ifTrue:[self error:'Out of bounds'].
	^interpreterProxy longAt: srcIndex! !

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

FXBltSimulator class
	instanceVariableNames: ''!

!FXBltSimulator class methodsFor: 'translation' stamp: 'ar 1/22/2000 15:44'!
translate: fileName doInlining: inlineFlag
	"Time millisecondsToRun: [
		Interpreter translate: 'interp.c' doInlining: true.
		Smalltalk beep] 164760 167543 171826 174510"
	| cg |
	FXBltSimulation initialize.
	Interpreter initialize.
	ObjectMemory initialize.
	cg _ CCodeGenerator new initialize.
	cg addClass: FXBltSimulation.
	cg addClass: Interpreter.
	cg addClass: ObjectMemory.
	FXBltSimulation declareCVarsIn: cg.
	Interpreter declareCVarsIn: cg.
	ObjectMemory declareCVarsIn: cg.
	cg storeCodeOnFile: fileName doInlining: inlineFlag.! !


!FXBltSimulator class methodsFor: 'instance creation' stamp: 'ar 10/27/1999 14:16'!
new
	^super new initBBOpTable.! !


!FXBltSimulator class methodsFor: 'initialization' stamp: 'ar 1/10/2000 14:04'!
resetCacheStats
	"BitBltSimulator resetCacheStats"
	ColorCacheHits _ ColorCacheMisses _ 0.! !
FXBlt subclass: #FXGrafPort
	instanceVariableNames: 'fillPattern '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-FXBlt'!

!FXGrafPort methodsFor: 'copying' stamp: 'ar 2/17/2000 21:44'!
clippedBy: aRectangle
	^ self copy clipRect: (self clipRect intersect: aRectangle)! !


!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 21:44'!
fillOval: rect
	| centerX centerY nextY yBias xBias outer nextOuterX |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	nextY _ rect height // 2.
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ rect width.
	destX _ rect left.
	self copyBits.
! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 5/27/2000 22:00'!
fillRect: rect offset: aPoint
	"The offset is really just for stupid InfiniteForms."
	| fc |
	fillPattern class == InfiniteForm ifTrue:[
		fc _ halftoneForm.
		self fillColor: nil.
		fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint.
		halftoneForm _ fc.
		^self].
	"Let's try it the fast way first"
	(fillPattern isColor and:[destForm isFillAccelerated: combinationRule for: fillPattern])
		ifTrue:[^destForm fill: (rect truncated intersect: self clipRect) 
						rule: combinationRule fillColor: fillPattern].
	destX _ rect left.
	destY _ rect top.
	sourceX _ 0.
	sourceY _ 0.
	width _ rect width.
	height _ rect height.
	self copyBits.! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 21:44'!
frameOval: rect borderWidth: borderWidth
	| centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	wp _ borderWidth asPoint.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	inner _ EllipseMidpointTracer new on: (rect insetBy: wp).
	nextY _ rect height // 2.
	1 to: (wp y min: nextY) do:[:i|
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		nextInnerX _ inner stepInY.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		width _ nextOuterX - nextInnerX.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		destX _ centerX - nextOuterX.
		destY _ centerY + nextY + yBias.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ wp x.
	destX _ rect left.
	self copyBits.
	destX _ rect right - wp x.
	self copyBits.
! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/22/2000 19:54'!
frameRect: rect borderWidth: borderWidth
	sourceX _ 0.
	sourceY _ 0.
	(rect areasOutside: (rect insetBy: borderWidth)) do:
		[:edgeStrip | self destRect: edgeStrip; copyBits].
! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 21:44'!
frameRectBottom: rect height: h

	destX _ rect left + 1.
	destY _ rect bottom - 1.
	width _ rect width - 2.
	height _ 1.
	1 to: h do: [:i |
		self copyBits.
		destX _ destX + 1.
		destY _ destY - 1.
		width _ width - 2].
! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 21:44'!
frameRectRight: rect width: w

	width _ 1.
	height _ rect height - 1.
	destX _ rect right - 1.
	destY _ rect top + 1.
	1 to: w do: [:i |
		self copyBits.
		destX _ destX - 1.
		destY _ destY + 1.
		height _ height - 2].
! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 5/28/2000 15:58'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
	(sourceMap isNil and:[destMap isNil and:[colorMap isNil and:[fillPattern isNil]]]) ifTrue:[
		"Let's try it the fast way if possible"
		(destForm isBltAccelerated: rule for: aForm) ifTrue:[
			^destForm 
				copyBits: sourceRect truncated
				from: aForm 
				at: aPoint asIntegerPoint
				clippingBox: self clipRect truncated
				rule: rule 
				fillColor: fillPattern 
				map: colorMap]].
	sourceForm _ aForm.
	combinationRule _ rule.
	self sourceRect: sourceRect.
	self destOrigin: aPoint.
	self copyBits! !

!FXGrafPort methodsFor: 'drawing support' stamp: 'ar 2/22/2000 16:47'!
stencil: stencilForm at: aPoint sourceRect: aRect
	"Paint using aColor wherever stencilForm has non-zero pixels"
	self sourceForm: stencilForm;
		destOrigin: aPoint;
		sourceRect: aRect.
	self copyBits! !


!FXGrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 21:45'!
alphaBits: a
	sourceAlpha _ a! !

!FXGrafPort methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:51'!
contentsOfArea: aRectangle into: aForm
	destForm 
		displayOn: aForm 
		at:  aRectangle origin
		clippingBox: (0@0 extent: aRectangle extent).
	^aForm! !

!FXGrafPort methodsFor: 'accessing' stamp: 'ar 5/25/2000 17:20'!
displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	^ (DisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self clone! !

!FXGrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 21:44'!
fillPattern: anObject
	fillPattern _ anObject.
	self fillColor: anObject.! !
Morph subclass: #FaceMorph
	instanceVariableNames: 'leftEye leftEyebrow rightEye rightEyebrow lips '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!FaceMorph methodsFor: 'initialization' stamp: 'len 8/22/1999 23:27'!
initialize
	super initialize.
	color _ Color transparent.
	self addMorph: (leftEye _ EyeMorph new).
	self addMorph: (rightEye _ EyeMorph new).
	self addMorph: (lips _ LipsMorph new).
	leftEye position: self position.
	rightEye position: leftEye extent x @ 0 + leftEye position.
	lips position: (0 @ 20 + (leftEye bottomRight + rightEye bottomLeft - lips extent // 2)).
	self bounds: self fullBounds! !


!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 22:21'!
leftEye
	^ leftEye! !

!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 19:47'!
lips
	^ lips! !

!FaceMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 22:21'!
rightEye
	^ rightEye! !


!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:23'!
closeEyelids
	leftEye closeEyelid.
	rightEye closeEyelid! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:18'!
grin
	self leftEye openness: (0.2 to: 1.0 by: 0.1) atRandom.
	self rightEye openness: (0.2 to: 1.0 by: 0.1) atRandom.
	self lips grin! !

!FaceMorph methodsFor: 'actions' stamp: 'len 9/7/1999 02:29'!
happy
	self lips smile! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:00'!
hideTonge
	self lips hideTonge! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:21'!
lookAt: aPoint
	self leftEye lookAt: aPoint.
	self rightEye lookAt: aPoint! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/23/1999 22:51'!
lookAtFront
	self leftEye lookAtFront.
	self rightEye lookAtFront! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:05'!
lookAtHand
	| hand |
	self isInWorld ifFalse: [^ self].
	hand _ (self world activeHand) ifNil: [self world primaryHand].
	self lookAtMorph: hand! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:05'!
lookAtMorph: aMorph
	self leftEye lookAtMorph: aMorph.
	self rightEye lookAtMorph: aMorph! !

!FaceMorph methodsFor: 'actions' stamp: 'len 9/7/1999 02:25'!
neutral
	self lips neutral! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:23'!
openEyelids
	leftEye openEyelid.
	rightEye openEyelid! !

!FaceMorph methodsFor: 'actions' stamp: 'len 8/22/1999 23:18'!
say: aString
	self lips showBalloon: aString! !


!FaceMorph methodsFor: 'geometry' stamp: 'len 8/24/1999 01:27'!
mustachePosition
	^ self nosePosition + self lips center // 2! !

!FaceMorph methodsFor: 'geometry' stamp: 'len 8/24/1999 01:26'!
nosePosition
	^ self center * 2 + self lips center // 3! !


!FaceMorph methodsFor: 'drawing' stamp: 'len 8/22/1999 21:56'!
drawNoseOn: aCanvas
	| nosePosition |
	nosePosition _ self center * 2 + self lips center // 3.
	aCanvas fillOval: (nosePosition- (3@0) extent: 2 @ 2) color: Color black.
	aCanvas fillOval: (nosePosition + (3@0) extent: 2 @ 2) color: Color black! !

!FaceMorph methodsFor: 'drawing' stamp: 'len 8/22/1999 19:02'!
drawOn: aCanvas
	super drawOn: aCanvas.
	self drawNoseOn: aCanvas! !


!FaceMorph methodsFor: 'stepping and presenter' stamp: 'len 8/24/1999 01:22'!
step
	| amount |
	super step.
	10 atRandom = 1
		ifTrue: [[self lips perform: #(smile horror surprise sad grin) atRandom.
				 (Delay forMilliseconds: 2000 atRandom) wait.
				 self lips perform: #(neutral neutral smile sad) atRandom] fork].
	5 atRandom = 1
		ifTrue: [[self closeEyelids.
				 (Delay forMilliseconds: 180) wait.
				 self openEyelids.
				 2 atRandom = 1 ifTrue: [self lookAtFront]] fork.
				^ self].
	"20 atRandom = 1 ifTrue: [(self perform: #(leftEye rightEye) atRandom) closeEyelid]."
	20 atRandom = 1 ifTrue: [amount _ (0.2 to: 1.0 by: 0.01) atRandom.
							 self leftEye openness: amount. self rightEye openness: amount].
	3 atRandom = 1 ifTrue: [self lookAtHand. ^ self].
	3 atRandom = 1 ifTrue: [self lookAtFront. ^ self].
	3 atRandom = 1 ifTrue: [self lookAtMorph: self world submorphs atRandom]! !

!FaceMorph methodsFor: 'stepping and presenter' stamp: 'len 9/13/1999 00:18'!
stepTime
	^ 1000! !
Object subclass: #FakeClassPool
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!FakeClassPool commentStamp: '<historical>' prior: 0!
The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing.  It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool.  It does this just around a doIt in the code pane.  An instance of FakeClasspool is then used as the receiver of the doIt.!


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

FakeClassPool class
	instanceVariableNames: ''!

!FakeClassPool class methodsFor: 'as yet unclassified' stamp: 'di 5/10/1998 21:32'!
adopt: classOrNil
	"Temporarily use the classPool and sharedPools of another class"
	classOrNil == nil
		ifTrue: [classPool _ nil.
				sharedPools _ nil]
		ifFalse: [classPool _ classOrNil classPool.
				sharedPools _ classOrNil sharedPools]
! !
Boolean subclass: #False
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!False commentStamp: '<historical>' prior: 0!
False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing.

Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!


!False methodsFor: 'logical operations'!
& alternativeObject 
	"Evaluating conjunction -- answer false since receiver is false."

	^self! !

!False methodsFor: 'logical operations'!
not
	"Negation -- answer true since the receiver is false."

	^true! !

!False methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR) -- answer with the argument, aBoolean."

	^aBoolean! !


!False methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer with false since the receiver is false."

	^self! !

!False methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!False methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value! !

!False methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"Since the condition is false, answer the value of the false alternative, 
	which is nil. Execution does not actually reach here because the
	expression is compiled in-line."

	^nil! !

!False methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value! !

!False methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer value of alternativeBlock."

	^alternativeBlock value! !


!False methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: 'false'! !

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

False class
	instanceVariableNames: ''!

!False class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'!
initializedInstance
	^ false! !
CelesteComposition subclass: #FancyCelesteComposition
	instanceVariableNames: 'theLinkToInclude to subject textFields '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:51'!
borderAndButtonColor

	^Color r: 0.729 g: 0.365 b: 0.729! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:14'!
buttonWithAction: aSymbol label: labelString help: helpString

	^self newColumn
		wrapCentering: #center; cellPositioning: #topCenter;
		addMorph: (
			SimpleButtonMorph new 
				color: self borderAndButtonColor;
				target: self; 
				actionSelector: aSymbol;
				label: labelString;
				setBalloonText: helpString
		)
			! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:55'!
celeste: aCeleste to: argTo subject: argSubject initialText: aText theLinkToInclude: linkText

	celeste _ aCeleste.
	to _ argTo.
	subject _ argSubject.
	messageText _ aText.
	theLinkToInclude _ linkText.
	textFields _ #().
! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:03'!
completeTheMessage

	| newText strm |
	textFields do: [ :each | each hasUnacceptedEdits ifTrue: [ each accept ] ].

	newText _ String new: 200.
	strm _ WriteStream on: newText.
	strm 
		nextPutAll: 'Content-Type: text/html'; cr;
		nextPutAll: 'From: ', Celeste userName; cr;
		nextPutAll: 'To: ',to; cr;
		nextPutAll: 'Subject: ',subject; cr;

		cr;
		nextPutAll: '<HTML><BODY><BR>';
		nextPutAll: messageText asString asHtml;
		nextPutAll: '<BR><BR>',theLinkToInclude,'<BR></BODY></HTML>'.
	^strm contents




! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:35'!
forgetIt

	morphicWindow ifNotNil: [ morphicWindow delete ].
	mvcWindow ifNotNil: [ mvcWindow controller close ].
! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:42'!
newColumn

	^AlignmentMorph newColumn color: self staticBackgroundColor! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:41'!
newRow

	^AlignmentMorph newRow color: self staticBackgroundColor! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 15:46'!
openInMorphic
	"open an interface for sending a mail message with the given initial 
	text "
	| buttonsList container toField subjectField |
	buttonsList _ self newRow.
	buttonsList wrapCentering: #center; cellPositioning: #leftCenter.
	buttonsList
		addMorphBack: (
			(self 
				buttonWithAction: #submit
				label: 'send later'
				help: 'add this to the queue of messages to be sent')
		);
		addMorphBack: (
			(self 
				buttonWithAction: #sendNow
				label: 'send now'
				help: 'send this message immediately')
		);
		addMorphBack: (
			(self 
				buttonWithAction: #forgetIt
				label: 'forget it'
				help: 'forget about sending this message')
		).
	morphicWindow _ container _ AlignmentMorphBob1 new
		borderWidth: 8;
		borderColor: self borderAndButtonColor;
		color: Color white.

	container 
		addMorphBack: (buttonsList vResizing: #shrinkWrap; minHeight: 25; yourself);
		addMorphBack: ((self simpleString: 'To:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((toField _ PluggableTextMorph
			on: self
			text: #to
			accept: #to:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself
		);
		addMorphBack: ((self simpleString: 'Subject:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((subjectField _ PluggableTextMorph
			on: self
			text: #subject
			accept: #subject:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself
		);
		addMorphBack: ((self simpleString: 'Message:') vResizing: #shrinkWrap; minHeight: 18; yourself);
		addMorphBack: ((textEditor _ PluggableTextMorph
			on: self
			text: #messageText
			accept: #messageText:) hResizing: #spaceFill; vResizing: #spaceFill; yourself
		).
	textFields _ {toField. subjectField. textEditor}.
	container 
		extent: 300@400;
		openInWorld.! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 12:53'!
sendNow

	self submit: true
! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:39'!
simpleString: aString

	^self newRow
		layoutInset: 2;
		addMorphBack: (StringMorph contents: aString) lock! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 17:38'!
staticBackgroundColor

	^Color veryLightGray! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:48'!
subject

	^subject

	! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:02'!
subject: x

	subject _ x.
	self changed: #subject.
	^true! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 12:53'!
submit

	self submit: false! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 9/8/2000 18:18'!
submit: sendNow

	| newMessageNumber personalCeleste windows |

	personalCeleste _ false.
	celeste ifNil: [
		personalCeleste _ true.
		celeste _ Celeste open.
	].

	newMessageNumber _ celeste PROTOqueueMessageWithText: (
		self breakLines: self completeTheMessage atWidth: 999
	).
	sendNow ifTrue: [celeste sendMail: {newMessageNumber}].
	personalCeleste ifTrue: [
		windows _ SystemWindow 
			windowsIn: self currentWorld 
			satisfying: [ :each | each model == celeste].
		celeste close.
		windows do: [ :each | each delete].
	].
	self forgetIt.
! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 18:47'!
to

	^to! !

!FancyCelesteComposition methodsFor: 'as yet unclassified' stamp: 'RAA 5/19/2000 19:02'!
to: x

	to _ x.	
	self changed: #to.
	^true
	! !
InflateStream subclass: #FastInflateStream
	instanceVariableNames: ''
	classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap '
	poolDictionaries: ''
	category: 'System-Compression'!
!FastInflateStream commentStamp: '<historical>' prior: 0!
This class adds the following optimizations to the basic Inflate decompression:

a) Bit reversed access
If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%.

b) Inplace storage of code meanings and extra bits
Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation).

c) Precomputed huffman tables for fixed blocks
So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).!


!FastInflateStream methodsFor: 'inflating' stamp: 'ar 2/2/2001 15:47'!
decompressBlock: llTable with: dTable
	"Process the compressed data in the block.
	llTable is the huffman table for literal/length codes
	and dTable is the huffman table for distance codes."
	| value extra length distance oldPos oldBits oldBitPos |
	<primitive: 'primitiveInflateDecompressBlock' module: 'ZipPlugin'>
	[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits _ bitBuf.
		oldBitPos _ bitPos.
		oldPos _ sourcePos.
		value _ self decodeValueFrom: llTable.
		value < 256 ifTrue:[ "A literal"
			collection byteAt: (readLimit _ readLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				state _ state bitAnd: StateNoMoreData.
				^self].
			"Compute the actual length value (including possible extra bits)"
			extra _ (value bitShift: -16) - 1.
			length _ value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[length _ length + (self nextBits: extra)].
			"Compute the distance value"
			value _ self decodeValueFrom: dTable.
			extra _ (value bitShift: -16).
			distance _ value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[distance _ distance + (self nextBits: extra)].
			(readLimit + length >= collection size) ifTrue:[
				bitBuf _ oldBits.
				bitPos _ oldBitPos.
				sourcePos _ oldPos.
				^self].
			collection 
					replaceFrom: readLimit+1 
					to: readLimit + length + 1 
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit _ readLimit + length.
		].
	].! !

!FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'!
processFixedBlock
	litTable _ FixedLitTable.
	distTable _ FixedDistTable.
	state _ state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !


!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'!
distanceMap
	^DistanceMap! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'!
increment: value bits: nBits
	"Increment value in reverse bit order, e.g. 
	for a 3 bit value count as follows:
		000 / 100 / 010 / 110
		001 / 101 / 011 / 111
	See the class comment why we need this."
	| result bit |
	result _ value.
	"Test the lowest bit first"
	bit _ 1 << (nBits - 1).
	"If the currently tested bit is set then we need to
	turn this bit off and test the next bit right to it"
	[(result bitAnd: bit) = 0] whileFalse:[ 
		"Turn off current bit"
		result _ result bitXor: bit.
		"And continue testing the next bit"
		bit _ bit bitShift: -1].
	"Turn on the right-most bit that we haven't touched in the loop above"
	^result bitXor: bit! !

!FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'!
literalLengthMap
	^LiteralLengthMap! !


!FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'!
nextSingleBits: n
	"Fetch the bits all at once"
	^self nextBits: n.! !

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

FastInflateStream class
	instanceVariableNames: ''!

!FastInflateStream class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:00'!
initialize
	"FastInflateStream initialize"
	| low high |

	"Init literal/length map"
	low _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ).
	high _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0).
	LiteralLengthMap _ WordArray new: 256 + 32.
	1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1].
	1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)].

	"Init distance map"
	high _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
	low _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
			1025 1537 2049 3073 4097 6145 8193 12289 16385 24577).
	DistanceMap _ WordArray new: 32.
	1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)].

	"Init fixed block huffman tables"
	FixedLitTable _ self basicNew
				huffmanTableFrom: FixedLitCodes
				mappedBy: LiteralLengthMap.
	FixedDistTable _ self basicNew
				huffmanTableFrom: FixedDistCodes
				mappedBy: DistanceMap.! !
SketchMorph subclass: #FatBitsPaint
	instanceVariableNames: 'formToEdit magnification brush brushSize brushColor lastMouse currentTools currentSelectionMorph selectionAnchor backgroundColor '
	classVariableNames: 'FormClipboard '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!FatBitsPaint commentStamp: '<historical>' prior: 0!
Extensions to FatBitsPaint

With the goal of making FatBitsPaint a fairly nifty Form fixer-upper in the Squeak/morphic environment, I have started this set of extensions. It will probably be updated as the mood strikes, so keep an eye out for new versions.

First, some basic operating instructions:

Get a Form and send it the message #morphEdit. To get started, you can try:

        (Form fromUser) morphEdit

And there is the form in all its glory. Control click on the form to get theFatBitsPaint menu and choose the "keep this menu up" item. This will be your main tool/command palette. With it you can:
´ Change the magnification
´ Change the brush size (in original scale pixels)
´ Change the brush color (via a ColorPickerMorph)

Now to some of the enhancements:

(25 September 1999 2:38:25 pm )

´ ColorPickerMorphs now have a label below that indicates their use (you might have more than one open)
´ A quirk that could get the brush size out of alignment with the pixel size is fixed.
´ A background has been added so that you can see the full extent of the Form and so that you can observe the effect of translucent pixels in the form.
´ A menu item has been added to change the background color so that you can simulate the real environment the form will be displayed in.
´ The magnification and brush size menus now highlight their current value.
´ An inspect option has been added to the menu so that you can do arbitrary things to the form.
´ A file out option has been added to write the form to a file.

(25 September 1999 10:02:13 pm ) 

´ New menu item: Tools allows you to choose between (for now) Paint Brush (all there was before) and Selections. Selections allows you to select rectangular regions of the form where the next menu takes over.
´ New menu item: Selections gives you choices:
        ´ edit separately - opens a new editor on the selected rectangle. Useful for cropping.
        ´ copy - copies the selection rectangle to a clipboard. Can be pasted to this or another FatBitsPaint.
        ´ cut - does a copy and clears the selection to transparent.
        ´ paste - paints the contents of the clipboard over the current selection. Only the starting point of the selection matters - the extent is controlled by the clipboard.

!


!FatBitsPaint methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:40'!
drawOn: aCanvas
	| f |
	f _ self rotatedForm.
	backgroundColor ifNotNil: [aCanvas fillRectangle: bounds fillStyle: backgroundColor].
	aCanvas translucentImage: f at: bounds origin.! !


!FatBitsPaint methodsFor: 'events' stamp: 'jm 12/1/97 12:00'!
griddedPoint: evt

	| relativePt |
	relativePt _ evt cursorPoint - self position.
	^ (relativePt x truncateTo: magnification)@(relativePt y truncateTo: magnification)
! !

!FatBitsPaint methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 9/25/1999 15:24'!
mouseDown: evt

        ^ self
                perform: (currentTools at: #mouseDown: ifAbsent: [^nil])
                with: evt! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 12/28/1999 11:35'!
mouseDownDefault: evt
	lastMouse _ nil.
	formToEdit depth = 1 ifTrue:
		[self brushColor: (originalForm colorAt: (self griddedPoint: evt)) negated]! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 9/25/1999 15:39'!
mouseDownSelection: evt

        lastMouse _ nil.
        currentSelectionMorph ifNotNil: [currentSelectionMorph delete. currentSelectionMorph _ nil].
        selectionAnchor _ self griddedPoint: evt! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 9/25/1999 15:24'!
mouseMove: evt

        ^ self
                perform: (currentTools at: #mouseMove: ifAbsent: [^nil])
                with: evt! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 9/25/1999 15:20'!
mouseMovePaintBrushMode: evt

        | p p2 |
        p _ self griddedPoint: evt.
        lastMouse = p ifTrue: [^ self].
        lastMouse ifNil: [lastMouse _ p].  "first point in a stroke"
        "draw etch-a-sketch style-first horizontal, then vertical"
        p2 _ p x@lastMouse y.
        brush drawFrom: lastMouse to: p2.
        brush drawFrom: p2 to: p.
                        
        self revealPenStrokes.
        lastMouse _ p! !

!FatBitsPaint methodsFor: 'events' stamp: 'RAA 6/12/2000 08:58'!
toolMenu: evt
	| menu |
	menu _ MenuMorph new.
	menu
		addTitle: 'Tools';
		addStayUpItem.
	{
		{'paint brush'. self toolsForPaintBrush}.
		{'selections'. self toolsForSelection}
	} do: [:each |
		menu add: each first
			target: self
			selector: #setCurrentToolTo:
			argumentList: {each second}].
	menu toggleStayUp: nil.
	menu popUpEvent: evt in: self world! !


!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:54'!
editForm: aForm

        formToEdit _ aForm.
        brushSize _ magnification _ 64 // (aForm height min: aForm width) max: 4.
        self revert! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 22:27'!
initialize

        super initialize.
        self setCurrentToolTo: self toolsForPaintBrush.
        formToEdit _ Form extent: 50@40 depth: 8.
        formToEdit fill: formToEdit boundingBox fillColor: Color veryVeryLightGray.
        brushSize _ magnification _ 4.
        color _ Color veryVeryLightGray.
        brushColor _ Color red.
        backgroundColor _ Color white.
        self revert! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 22:26'!
openWith: aForm

        self editForm: aForm; openInWorld! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 21:44'!
setCurrentToolTo: aDictionary

        currentTools _ aDictionary.
        currentSelectionMorph ifNotNil: [currentSelectionMorph delete. currentSelectionMorph _ nil]! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:25'!
toolsForPaintBrush

        ^Dictionary new
                at: #mouseMove: put: #mouseMovePaintBrushMode:;
                at: #mouseDown: put: #mouseDownDefault:;
                yourself! !

!FatBitsPaint methodsFor: 'initialization' stamp: 'RAA 9/25/1999 15:27'!
toolsForSelection

        ^ Dictionary new
                at: #mouseMove: put: #mouseMoveSelectionMode:;
                at: #mouseDown: put: #mouseDownSelection:;
                yourself! !


!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 5/14/2000 12:42'!
accept
	| f |
	f _ self unmagnifiedForm.
	f boundingBox = formToEdit boundingBox
		ifFalse: [^ self error: 'implementation error; form dimensions should match'].
	f displayOn: formToEdit.  "modify formToEdit in place"! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:17'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

        super addCustomMenuItems: aCustomMenu hand: aHandMorph.
        aCustomMenu 
                add: 'background color' action: #setBackgroundColor:;
                add: 'pen color' action: #setPenColor:;
                add: 'pen size' action: #setPenSize:;
                add: 'fill' action: #fill;
                add: 'magnification' action: #setMagnification:;
                add: 'accept' action: #accept;
                add: 'revert' action: #revert;
                add: 'inspect' action: #inspectForm;
                add: 'file out' action: #fileOut;
                add: 'selection...' action: #selectionMenu:;
                add: 'tools...' action: #toolMenu:;
                yourself! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 22:27'!
backgroundColor: aColor

        backgroundColor _ aColor.
        self changed! !

!FatBitsPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor

	brushColor _ aColor.
	brush color: aColor.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:50'!
copySelection

        | relativeBounds scaledBounds |
        currentSelectionMorph ifNil: [^ nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        scaledBounds _ relativeBounds scaleBy: 1 / magnification.
        FormClipboard _ (self unmagnifiedForm copy: scaledBounds).
        ^ relativeBounds! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:15'!
cutSelection

        | relativeBounds |
        relativeBounds _ self copySelection ifNil: [^ nil].
        originalForm fill: relativeBounds rule: Form over fillColor: Color transparent.
        self revealPenStrokes! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:19'!
editSelection

        (self selectionAsForm ifNil: [^ nil]) morphEdit! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:48'!
fileOut

        | fileName result |

        result _ StandardFileMenu newFile ifNil: [^ 1 beep].
        fileName _ result directory fullNameFor: result name.
        Cursor normal showWhile:
                [self unmagnifiedForm writeOnFileNamed: fileName]! !

!FatBitsPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 18:48'!
fill

	| fillPt |
	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: brushColor interiorPoint: fillPt.
	self changed.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:49'!
inspectForm

        self unmagnifiedForm inspect! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:49'!
magnification: aNumber

        | oldPenSize oldForm |
        oldPenSize _ brushSize / magnification.
        oldForm _ self unmagnifiedForm.
        magnification _ aNumber asInteger max: 1.
        self form: (oldForm magnify: oldForm boundingBox by: magnification).
        brush _ Pen newOnForm: originalForm.
        self penSize: oldPenSize.
        brush color: brushColor! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:39'!
mouseMoveSelectionMode: evt

        | p |
        p _ self griddedPoint: evt.
        lastMouse = p ifTrue: [^ self].

        currentSelectionMorph ifNil:
                [currentSelectionMorph _ MarqueeMorph new 
                        color: Color transparent;
                        borderWidth: 2;
                        lock.
                self addMorphFront: currentSelectionMorph.
                currentSelectionMorph startStepping].
        currentSelectionMorph 
                bounds: ((Rectangle encompassing: {p. selectionAnchor}) translateBy: self position).

        lastMouse _ p! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 21:50'!
pasteSelection

        | relativeBounds tempForm |
        currentSelectionMorph ifNil: [^ nil].
        FormClipboard ifNil: [^nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        tempForm _ (FormClipboard magnify: FormClipboard boundingBox by: magnification).
        self form
                copy: (relativeBounds origin extent: tempForm boundingBox extent)
                from: 0@0
                in: tempForm
                rule: Form over. 
        self revealPenStrokes! !

!FatBitsPaint methodsFor: 'menu' stamp: 'jm 12/1/97 12:09'!
penSize: aNumber

	brushSize _ (aNumber * magnification) asInteger.
	brush squareNib: brushSize.
! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/28/1999 13:03'!
revert
"since WarpBits may mangle an 8-bit ColorForm, make it 32 first"
        self form: ((formToEdit asFormOfDepth: 32) 
                magnify: formToEdit boundingBox 
                by: magnification 
                smoothing: 1).
        brush _ Pen newOnForm: originalForm.
        brush squareNib: brushSize.
        brush color: brushColor! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 16:18'!
selectionAsForm

        | relativeBounds scaledBounds |
        currentSelectionMorph ifNil: [^nil].
        relativeBounds _ currentSelectionMorph bounds translateBy: self position negated.
        scaledBounds _ relativeBounds scaleBy: 1 / magnification.
        ^ self unmagnifiedForm copy: scaledBounds! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
selectionMenu: evt

        | menu |
 
        (menu _ MenuMorph new)
                addTitle: 'Edit';
                addStayUpItem.

        {
                {'edit separately'. #editSelection}.
                {'copy'. #copySelection}.
                {'cut'. #cutSelection}.
                {'paste'. #pasteSelection}
        } do: [:each |
                menu add: each first
                        target: self
                        selector: each second
                        argumentList: #()].
        menu toggleStayUp: nil.
        menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
setBackgroundColor: evt

	self
		changeColorTarget: self 
		selector: #backgroundColor: 
		originalColor: backgroundColor
		hand: evt hand! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
setMagnification: evt
	| menu |
	menu _ MenuMorph new.
	((1 to: 8), #(16 24 32)) do: [:w |
		menu add: w printString
			target: self
			selector: #magnification:
			argumentList: (Array with: w).
		magnification = w ifTrue: [menu lastSubmorph color: Color red]].
	menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
setPenColor: evt

	self changeColorTarget: self selector: #brushColor: originalColor: brushColor hand: evt hand.! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 08:58'!
setPenSize: evt
	| menu sizes |
 
	menu _ MenuMorph new.
	sizes _ (1 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w |
		menu add: w printString
			target: self
			selector: #penSize:
			argumentList: (Array with: w).
		(brushSize // magnification) = w ifTrue: [menu lastSubmorph color: Color red]].
	menu popUpEvent: evt in: self world! !

!FatBitsPaint methodsFor: 'menu' stamp: 'RAA 9/25/1999 15:48'!
unmagnifiedForm

        ^ self form shrink: self form boundingBox by: magnification! !


!FatBitsPaint methodsFor: 'testing' stamp: 'RAA 9/25/1999 21:14'!
containsPoint: aPoint

        ^ self bounds containsPoint: aPoint     "even if we are transparent"
! !
Browser subclass: #FileContentsBrowser
	instanceVariableNames: 'packages infoString '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!FileContentsBrowser methodsFor: 'accessing'!
contents
	self updateInfoView.
	(editSelection == #newClass and:[self selectedPackage notNil])
		ifTrue: [^self selectedPackage packageInfo].
	editSelection == #editClass
		ifTrue:[^self modifiedClassDefinition].
	^super contents! !

!FileContentsBrowser methodsFor: 'accessing'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. The information can be a variety of things, depending on the 
	list selections (such as templates for class or message definition, methods) 
	or the user menu commands (such as definition, comment, hierarchy). 
	Answer the result of updating the source."

	| aString aText theClass |
	aString _ input asString.
	aText _ input asText.

	editSelection == #editComment 
		ifTrue: [theClass _ self selectedClass.
				theClass ifNil: [PopUpMenu notify: 'You must select a class
before giving it a comment.'.
				^ false].
				theClass comment: aText. ^ true].
	editSelection == #editMessageCategories 
		ifTrue: [^ self changeMessageCategories: aString].

	self inform:'You cannot change the current selection'.
	^false
! !

!FileContentsBrowser methodsFor: 'accessing'!
packages
	^packages! !

!FileContentsBrowser methodsFor: 'accessing'!
packages: aDictionary
	packages := aDictionary.! !

!FileContentsBrowser methodsFor: 'accessing'!
selectedPackage
	| cat |
	cat := self selectedSystemCategoryName.
	cat isNil ifTrue:[^nil].
	^self packages at: cat asString ifAbsent:[nil]! !


!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'!
removeClass
	| class |
	classListIndex = 0 ifTrue: [^ self].
	class _ self selectedClass.
	(self confirm:'Are you certain that you
want to delete the class ', class name, '?') ifFalse:[^self].
	self selectedPackage removeClass: class.
	self classListIndex: 0.
	self changed: #classList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:46'!
removeMessage
	| messageName |
	messageListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageName _ self selectedMessageName.
	(self selectedClassOrMetaClass confirmRemovalOf: messageName) ifFalse:[^false].
	self selectedClassOrMetaClass removeMethod: self selectedMessageName.
	self messageListIndex: 0.
	self setClassOrganizer.  "In case organization not cached"
	self changed: #messageList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:51'!
removeMessageCategory
	"If a message category is selected, create a Confirmer so the user can 
	verify that the currently selected message category should be removed
 	from the system. If so, remove it."

	| messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName _ self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?']) ifFalse: [^ self].
	self selectedClassOrMetaClass removeCategory: messageCategoryName.
	self messageCategoryListIndex: 0.
	self changed: #messageCategoryList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:52'!
removePackage
	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self confirm: 'Are you sure you want to
remove this package 
and all its classes?') ifFalse:[^self].
	(systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el|
		systemOrganizer removeElement: el].
	self packages removeKey: self selectedPackage packageName.
	systemOrganizer removeCategory: self selectedSystemCategoryName.
	self systemCategoryListIndex: 0.
	self changed: #systemCategoryList! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'!
removeUnmodifiedCategories
	| theClass |
	self okToChange ifFalse: [^self].
	theClass _ self selectedClass.
	theClass isNil ifTrue: [^self].
	Cursor wait showWhile:
		[theClass removeUnmodifiedMethods: theClass selectors.
		theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors].
	self messageCategoryListIndex: 0.
	self changed: #messageCategoryList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'!
removeUnmodifiedClasses
	| packageList |
	self okToChange ifFalse:[^self].
	packageList := self selectedPackage isNil
						ifTrue:[self packages] 
						ifFalse:[Array with: self selectedPackage].
	packageList do:[:package|
		package classes copy do:[:theClass|
			Cursor wait showWhile:[
				theClass removeAllUnmodified.
			].
			theClass hasChanges ifFalse:[
				package removeClass: theClass.
			].
		]].
	self classListIndex: 0.
	self changed: #classList.! !

!FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'!
removeUnmodifiedMethods
	| theClass cat |
	self okToChange ifFalse:[^self].
	theClass := self selectedClassOrMetaClass.
	theClass isNil ifTrue:[^self].
	cat := self selectedMessageCategoryName.
	cat isNil ifTrue:[^self].
	Cursor wait showWhile:[
		theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat).
	].
	self messageListIndex: 0.
	self changed: #messageList.! !


!FileContentsBrowser methodsFor: 'class list' stamp: 'sma 5/6/2000 18:48'!
browseMethodFull
	| myClass |
	(myClass _ self selectedClassOrMetaClass) ifNotNil:
		[Browser fullOnClass: myClass realClass selector: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'class list'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	(systemCategoryListIndex = 0 or:[self selectedPackage isNil])
		ifTrue: [^Array new]
		ifFalse: [^self selectedPackage classes keys asSortedCollection].! !

!FileContentsBrowser methodsFor: 'class list'!
findClass
	| pattern foundClass classNames index foundPackage |
	self okToChange ifFalse: [^ self classNotFound].
	pattern _ (FillInTheBlank request: 'Class Name?') asLowercase.
	pattern isEmpty ifTrue: [^ self].
	classNames := Set new.
	self packages do:[:p| classNames addAll: p classes keys].
	classNames := classNames asArray select: 
		[:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
	classNames isEmpty ifTrue: [^ self].
	index _ classNames size == 1
				ifTrue:	[1]
				ifFalse:	[(PopUpMenu labelArray: classNames lines: #()) startUp].
	index = 0 ifTrue: [^ self].
	foundPackage := nil.
	foundClass := nil.
	self packages do:[:p| 
		(p classes includesKey: (classNames at: index)) ifTrue:[
			foundClass := p classes at: (classNames at: index).
			foundPackage := p]].
	foundClass isNil ifTrue:[^self].
 	self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol).
	self classListIndex: (self classList indexOf: foundClass name). ! !

!FileContentsBrowser methodsFor: 'class list' stamp: 'wod 5/24/1998 20:37'!
renameClass
	| oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ (self request: 'Please type new class name'
						initialAnswer: oldName) asSymbol.
	(newName isEmpty or:[newName = oldName]) ifTrue: [^ self].
	(self selectedPackage classes includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists in the package'].
	systemOrganizer classify: newName under: self selectedSystemCategoryName.
	systemOrganizer removeElement: oldName.
	self selectedPackage renameClass: self selectedClass to: newName.
	self changed: #classList.
	self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
! !

!FileContentsBrowser methodsFor: 'class list'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	self selectedClassName == nil ifTrue: [^nil].
	^self selectedPackage classAt: self selectedClassName! !


!FileContentsBrowser methodsFor: 'edit pane' stamp: 'sw 11/9/1999 19:26'!
selectedMessage
	"Answer a copy of the source code for the selected message selector."
	| class selector |
	class _ self selectedClassOrMetaClass.
	selector _ self selectedMessageName.
	contents _ class sourceCodeAt: selector.
	Preferences browseWithPrettyPrint ifTrue: [contents _ Compiler new
					format: contents
					in: class
					notifying: nil
					decorated: Preferences colorWhenPrettyPrinting].
	self showDiffs ifTrue:
		[contents _ self
			methodDiffFor: contents
			class: self selectedClass
			selector: self selectedMessageName
			meta: self metaClassIndicated].
	^ contents asText makeSelectorBoldIn: class! !


!FileContentsBrowser methodsFor: 'diffs' stamp: 'nk 10/29/2000 12:43'!
methodDiffFor: aString class: aPseudoClass selector: selector meta: meta 
	| theClass source |
	theClass _ Smalltalk
				at: aPseudoClass name
				ifAbsent: [^ aString copy].
	meta
		ifTrue: [theClass _ theClass class].
	(theClass includesSelector: selector)
		ifFalse: [^ aString copy].
	source _ theClass sourceCodeAt: selector.
	^ Cursor wait
		showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass]! !

!FileContentsBrowser methodsFor: 'diffs'!
modifiedClassDefinition
	| pClass rClass old new diff |
	pClass := self selectedClassOrMetaClass.
	pClass hasDefinition ifFalse:[^pClass definition].
	rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil].
	rClass isNil ifTrue:[^pClass definition].
	self metaClassIndicated ifTrue:[ rClass := rClass class].
	old := rClass definition.
	new := pClass definition.
	Cursor wait showWhile:[
		diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new
	].
	^diff! !


!FileContentsBrowser methodsFor: 'fileIn/fileOut'!
fileInClass
	Cursor read showWhile:[
		self selectedClass fileIn.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'!
fileInMessage
	
	self selectedMessageName ifNil: [^self].
	Cursor read showWhile: [
		self selectedClassOrMetaClass fileInMethod: self selectedMessageName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'!
fileInMessageCategories
	Cursor read showWhile:[
		self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 12:50'!
fileInPackage
	Cursor read showWhile:[
		self selectedPackage fileIn.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'sma 4/22/2000 20:51'!
fileIntoNewChangeSet
	| p ff |
	(p _ self selectedPackage) ifNil: [^ self beep].
	ff _ StandardFileStream readOnlyFileNamed: p fullPackageName.
	ChangeSorter newChangesFromStream: ff named: p packageName! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut'!
fileOutClass
	Cursor write showWhile:[
		self selectedClass fileOut.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'!
fileOutMessage

	self selectedMessageName ifNil: [^self].
	Cursor write showWhile: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'!
fileOutMessageCategories
	Cursor write showWhile:[
		self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName.
	].! !

!FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 14:19'!
fileOutPackage
	Cursor write showWhile:[
		self selectedPackage fileOut.
	].! !


!FileContentsBrowser methodsFor: 'infoView' stamp: 'sma 5/6/2000 19:19'!
extraInfo
	^ (self
		methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName)
		class: self selectedClass
		selector: self selectedMessageName
		meta: self metaClassIndicated) unembellished
			ifTrue: [' - identical']
			ifFalse: [' - modified']! !

!FileContentsBrowser methodsFor: 'infoView'!
infoString
	^infoString isNil
		ifTrue:[infoString := StringHolder new]
		ifFalse:[infoString]! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'sma 5/6/2000 18:26'!
infoViewContents
	| theClass |
	editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
	self selectedClass isNil ifTrue: [^ ''].
	theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: [].
	editSelection == #editClass ifTrue: [^ theClass notNil
			ifTrue: ['Class exists already in the system']
			ifFalse: ['New class']].
	editSelection == #editMessage ifFalse: [^ ''].
	(theClass notNil and: [self metaClassIndicated])
		ifTrue: [theClass _ theClass class].
	^ (theClass notNil and: [theClass includesSelector: self selectedMessageName])
		ifTrue: ['Method already exists' , self extraInfo]
		ifFalse: ['New method']! !

!FileContentsBrowser methodsFor: 'infoView'!
packageInfo: p
	| nClasses newClasses oldClasses |
	p isNil ifTrue:[^''].
	nClasses := newClasses := oldClasses := 0.
	p classes do:[:cls|
		nClasses := nClasses + 1.
		(Smalltalk includesKey: (cls name asSymbol))
			ifTrue:[oldClasses := oldClasses + 1]
			ifFalse:[newClasses := newClasses + 1]].
	^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! !

!FileContentsBrowser methodsFor: 'infoView' stamp: 'wod 5/19/1998 17:34'!
updateInfoView

	Smalltalk isMorphic 
		ifTrue: [self changed: #infoViewContents]
		ifFalse: [
			self infoString contents: self infoViewContents.
			self infoString changed].! !


!FileContentsBrowser methodsFor: 'metaclass'!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

	self metaClassIndicated
		ifTrue: [^ self selectedClass metaClass]
		ifFalse: [^ self selectedClass]! !

!FileContentsBrowser methodsFor: 'metaclass'!
setClassOrganizer
	"Install whatever organization is appropriate"
	| theClass |
	classOrganizer _ nil.
	metaClassOrganizer _ nil.
	classListIndex = 0 ifTrue: [^ self].
	classOrganizer _ (theClass _ self selectedClass) organization.
	metaClassOrganizer _ theClass metaClass organization.
! !


!FileContentsBrowser methodsFor: 'other' stamp: 'wod 5/25/1998 00:46'!
browseSenders
	"Create and schedule a message set browser on all senders of the 
	currently selected message selector. Do nothing if no message is selected."

	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllCallsOn: self selectedMessageName]! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/12/1999 17:42'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	| class selector |
	(selector _ self selectedMessageName) ifNotNil:
		[class _ self selectedClassOrMetaClass.
		(class exists and: [class realClass includesSelector: selector]) ifTrue:
			[VersionsBrowser
				browseVersionsOf: (class realClass compiledMethodAt: selector)
				class: class realClass
				meta: class realClass isMeta
				category: self selectedMessageCategoryName
				selector: selector]]! !

!FileContentsBrowser methodsFor: 'other'!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self classOrMetaClassOrganizer changeFromString: aString.
	self unlock.
	self editClass.
	self classListIndex: classListIndex.
	^ true! !

!FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'!
methodHierarchy
	(self selectedClassOrMetaClass isNil or:
		[self selectedClassOrMetaClass hasDefinition])
			ifFalse: [super methodHierarchy]! !


!FileContentsBrowser methodsFor: 'creation' stamp: 'JW 2/3/2001 10:24'!
addLowerPanesTo: window at: nominalFractions with: editString

	| verticalOffset row innerFractions codePane infoPane infoHeight |

	row _ AlignmentMorph newColumn
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 1;
		borderColor: Color black;
		layoutPolicy: ProportionalLayout new.

	codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	infoPane _ PluggableTextMorph on: self text: #infoViewContents accept: nil
			readSelection: nil menu: nil.
	verticalOffset _ 0.
	innerFractions _ 0@0 corner: 1@0.
">>not with this browser--- at least not yet ---
	verticalOffset _ self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset.
	verticalOffset _ self addOptionalButtonsTo: row  at: innerFractions plus: verticalOffset.
<<<<"

	infoHeight _ 20.
	row 
		addMorph: (codePane borderWidth: 0)
		fullFrame: (
			LayoutFrame 
				fractions: (0@0 corner: 1@1) 
				offsets: (0@verticalOffset corner: 0@infoHeight negated)
		).
	row 
		addMorph: (SubpaneDividerMorph forTopEdge)
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@infoHeight negated corner: 0@(1-infoHeight))
		).
	row 
		addMorph: (infoPane borderWidth: 0; hideScrollBarIndefinitely)
		fullFrame: (
			LayoutFrame 
				fractions: (0@1 corner: 1@1) 
				offsets: (0@(1-infoHeight) corner: 0@0)
		).
	window 
		addMorph: row
		frame: nominalFractions.

	row on: #mouseEnter send: #paneTransition: to: window.
	row on: #mouseLeave send: #paneTransition: to: window.

! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'sma 2/6/2000 12:03'!
createViews
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| hasSingleFile width topView packageListView classListView switchView messageCategoryListView messageListView browserCodeView infoView |

	showDiffs _ true.
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	(hasSingleFile _ self packages size = 1)
		ifTrue: [width _ 150]
		ifFalse: [width _ 200].

	(topView _ StandardSystemView new) 
		model: self;
		borderWidth: 1.
		"label and minSize taken care of by caller"
	
	hasSingleFile 
		ifTrue: [
			self systemCategoryListIndex: 1.
			packageListView _ PluggableListView on: self
				list: #systemCategorySingleton
				selected: #indexIsOne 
				changeSelected: #indexIsOne:
				menu: #packageListMenu:
				keystroke: #packageListKey:from:.
			packageListView window: (0 @ 0 extent: width @ 12)]
		ifFalse: [
			packageListView _ PluggableListView on: self
				list: #systemCategoryList
				selected: #systemCategoryListIndex
				changeSelected: #systemCategoryListIndex:
				menu: #packageListMenu:
				keystroke: #packageListKey:from:.
			packageListView window: (0 @ 0 extent: 50 @ 70)].
	topView addSubView: packageListView.

	classListView _ PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:
		keystroke: #classListKey:from:.
	classListView window: (0 @ 0 extent: 50 @ 62).
	hasSingleFile 
		ifTrue: [topView addSubView: classListView below: packageListView]
		ifFalse: [topView addSubView: classListView toRightOf: packageListView].

	switchView _ self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageCategoryListView _ PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	messageListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	browserCodeView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: width@110).
	topView 
		addSubView: browserCodeView 
		below: (hasSingleFile 
			ifTrue: [switchView]
			ifFalse: [packageListView]).

	infoView _ StringHolderView new
		model: self infoString;
		window: (0@0 extent: width@12);
		borderWidth: 1.
	topView addSubView: infoView below: browserCodeView.

	^ topView
! !

!FileContentsBrowser methodsFor: 'creation' stamp: 'RAA 1/11/2001 08:06'!
openAsMorph
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	| window aListExtent next |
	window _ (SystemWindow labelled: 'later') model: self.
	self packages size = 1
		ifTrue: [
			aListExtent _ 0.333333 @ 0.34.
			self systemCategoryListIndex: 1.
			window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton
					selected: #indexIsOne changeSelected: #indexIsOne:
					menu: #packageListMenu:
					keystroke: #packageListKey:from:)
				frame: (0@0 extent: 1.0@0.06).
			next := 0@0.06]
		ifFalse: [
			aListExtent _ 0.25 @ 0.4.
			window addMorph: (PluggableListMorph on: self list: #systemCategoryList
					selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
					menu: #packageListMenu:
					keystroke: #packageListKey:from:)
				frame: (0@0 extent: aListExtent).
			next := aListExtent x @ 0].

	self addClassAndSwitchesTo: window at: (next extent: aListExtent) plus: 0.

	next := next + (aListExtent x @ 0).
	window addMorph: (PluggableListMorph on: self list: #messageCategoryList
			selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
			menu: #messageCategoryMenu:)
		frame: (next extent: aListExtent).
	next := next + (aListExtent x @ 0).
	window addMorph: (PluggableListMorph on: self list: #messageList
			selected: #messageListIndex changeSelected: #messageListIndex:
			menu: #messageListMenu:
			keystroke: #messageListKey:from:)
		frame: (next extent: aListExtent).

	self addLowerPanesTo: window at: (0@0.4 corner: 1@1) with: nil.
	^ window
! !


!FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/9/1999 18:26'!
addModelItemsToWindowMenu: aMenu
	aMenu addLine.
	aMenu add: 
		(self showDiffs ifTrue: ['stop showing diffs'] ifFalse: ['start showing diffs'])
			  target: self action: #toggleDiffing ! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 5/6/2000 18:36'!
classListMenu: aMenu

	^ aMenu 
		labels:
'definition
comment
browse full (b)
class refs (N)
fileIn
fileOut
rename...
remove
remove existing'
		lines: #(2 4 6 8)
		selections: #(editClass editComment browseMethodFull browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories) 

! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'wod 5/13/1998 17:39'!
messageCategoryMenu: aMenu

	^ aMenu 
		labels:
'fileIn
fileOut
reorganize
add item...
rename...
remove
remove existing'
		lines: #(2 3 6)
		selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 2/6/2000 12:28'!
messageListMenu: aMenu

	^ aMenu 
		labels:
'fileIn
fileOut
senders (n)
implementors (m)
method inheritance (h)
versions (v)
remove'
		lines: #(2 6)
		selections: #(fileInMessage fileOutMessage
browseSenders browseImplementors methodHierarchy browseVersions
removeMessage).! !

!FileContentsBrowser methodsFor: 'menus' stamp: 'sma 4/22/2000 20:52'!
packageListMenu: aMenu
	^ aMenu 
		labels:
'find class... (f)
fileIn
file into new changeset
fileOut
remove
remove existing'
		lines: #(1 4 5)
		selections: #(findClass fileInPackage fileIntoNewChangeSet fileOutPackage removePackage removeUnmodifiedClasses)! !


!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:48'!
classListKey: aChar from: view
	aChar == $b ifTrue: [^ self browseMethodFull].
	aChar == $N ifTrue: [^ self browseClassRefs].
	self packageListKey: aChar from: view! !

!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:50'!
messageListKey: aChar from: view
	aChar == $b ifTrue: [^ self browseMethodFull].
	super messageListKey: aChar from: view! !

!FileContentsBrowser methodsFor: 'keys' stamp: 'sma 2/6/2000 12:05'!
packageListKey: aChar from: view
	aChar == $f ifTrue: [^ self findClass].
	self arrowKey: aChar from: view! !

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

FileContentsBrowser class
	instanceVariableNames: ''!

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'wod 5/13/1998 18:17'!
browseFile: aFilename

	self browseFiles: (Array with: aFilename).! !

!FileContentsBrowser class methodsFor: 'instance creation' stamp: 'dew 8/2/2000 20:02'!
browseFiles: fileList

	| package organizer packageDict browser |
	Cursor wait showWhile: [
		packageDict _ Dictionary new.
		organizer _ SystemOrganizer defaultList: Array new.
		fileList do: [:fileName |
			package _ FilePackage fromFileNamed: fileName.
			packageDict 
				at: package packageName 
				put: package.
			organizer 
				classifyAll: package classes keys 
				under: package packageName].
		(browser := self new)
			systemOrganizer: organizer;
			packages: packageDict].
	self
		openBrowserView: browser createViews
		label: 'File Contents Browser'.
! !
Object subclass: #FileDirectory
	instanceVariableNames: 'pathName '
	classVariableNames: 'DefaultDirectory DirectoryClass StandardMIMEMappings '
	poolDictionaries: ''
	category: 'System-Files'!
!FileDirectory commentStamp: '<historical>' prior: 0!
A FileDirectory represents a folder or directory in the underlying platform's file system. It carries a fully-qualified path name for the directory it represents, and can enumerate the files and directories within that directory.

A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries". Each entry is an array of five items:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

The times are given in seconds, and can be converted to a time and date via Time>dateAndTimeFromSeconds:. See the comment in lookupEntry:... which provides primitive access to this information.
!


!FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 01:01'!
fullPathFor: path
	^path isEmpty ifTrue:[pathName] ifFalse:[path]! !

!FileDirectory methodsFor: 'path access' stamp: 'tk 5/18/1998 22:29'!
on: fullPath
	"Return another instance"

	^ self class on: fullPath! !

!FileDirectory methodsFor: 'path access' stamp: 'jm 12/5/97 12:18'!
pathName
	"Return the path from the root of the file system to this directory."

	^ pathName
! !

!FileDirectory methodsFor: 'path access' stamp: 'jm 12/5/97 12:19'!
pathNameDelimiter
	"Return the delimiter character for this kind of directory. This depends on the current platform."

	^ self class pathNameDelimiter
! !

!FileDirectory methodsFor: 'path access' stamp: 'jm 12/5/97 12:17'!
pathParts
	"Return the path from the root of the file system to this directory as an array of directory names."

	^ pathName findTokens: self pathNameDelimiter asString
! !

!FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 00:36'!
slash
	^self class slash! !


!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
fileNamed: localFileName
	"Open the file with the given name in this directory for writing."

	^ FileStream concreteStream fileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'dew 10/26/2000 02:08'!
forceNewFileNamed: localFileName
	"Open the file with the given name in this directory for writing.  If it already exists, delete it first without asking."

	^ FileStream concreteStream forceNewFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
newFileNamed: localFileName
	"Create a new file with the given name in this directory."

	^ FileStream concreteStream newFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
oldFileNamed: localFileName
	"Open the existing file with the given name in this directory."

	^ FileStream concreteStream oldFileNamed: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/18/1998 16:19'!
oldFileOrNoneNamed: fileName
	"If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil."

	| fullName |
	fullName _ FileStream fullName: fileName.
	(FileStream concreteStream isAFileNamed: fullName)
		ifTrue: [^ FileStream concreteStream readOnlyFileNamed: fullName]
		ifFalse: [^ nil].
! !

!FileDirectory methodsFor: 'file stream creation' stamp: 'tk 5/19/1998 09:03'!
readOnlyFileNamed: localFileName
	"Open the existing file with the given name in this directory for read-only access."

	^ FileStream concreteStream readOnlyFileNamed: (self fullNameFor: localFileName)
! !


!FileDirectory methodsFor: 'enumeration' stamp: 'jm 1/5/98 20:49'!
containingDirectory
	"Return the directory containing this directory."

	^ FileDirectory on: (FileDirectory dirPathFor: pathName)
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:46'!
directoryNamed: localFileName
	"Return the subdirectory of this directory with the given name."

	^ FileDirectory on: (self fullNameFor: localFileName)
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'!
directoryNames
	"Return a collection of names for the subdirectories of this directory."
	"FileDirectory default directoryNames"

	^ (self entries select: [:entry | entry at: 4])
		collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 12:23'!
entries
	"Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name><creationTime><modificationTime><dirFlag><fileSize>). See primLookupEntryIn:index: for further details."
	"FileDirectory default entries"

	^ self directoryContentsFor: pathName
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'!
fileAndDirectoryNames
	"FileDirectory default fileAndDirectoryNames"

	^ self entries collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:44'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	"FileDirectory default fileNames"

	^ (self entries select: [:entry | (entry at: 4) not])
		collect: [:entry | entry first]
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 9/27/1998 21:34'!
fullNamesOfAllFilesInSubtree
	"Answer a collection containing the full names of all the files in the subtree of the file system whose root is this directory."

	| result todo dir |
	result _ OrderedCollection new: 100.
	todo _ OrderedCollection with: self.
	[todo size > 0] whileTrue: [
		dir _ todo removeFirst.
		dir fileNames do: [:n | result add: (dir fullNameFor: n)].
		dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]].
	^ result asArray
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 15:39'!
keysDo: nameBlock
	"Evaluate the given block for each file or directory name in this directory."

	^ self fileAndDirectoryNames do: nameBlock
! !

!FileDirectory methodsFor: 'enumeration' stamp: 'wod 6/16/1998 15:07'!
statsForDirectoryTree: rootedPathName
	"Return the size statistics for the entire directory tree starting at the given root. The result is a three element array of the form: (<number of folders><number of files><total bytes in all files>). This method also serves as an example of how recursively enumerate a directory tree."
	"wod 6/16/1998: add Cursor wait, and use 'self pathNameDelimiter asString' rather than hardwired ':' "
	"FileDirectory default statsForDirectoryTree: '\smalltalk'"

	| dirs files bytes todo p entries |
	Cursor wait showWhile: [
		dirs _ files _ bytes _ 0.
		todo _ OrderedCollection with: rootedPathName.
		[todo isEmpty] whileFalse: [
			p _ todo removeFirst.
			entries _ self directoryContentsFor: p.
			entries do: [:entry |
				(entry at: 4)
					ifTrue: [
						todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)).
						dirs _ dirs + 1]
					ifFalse: [
						files _ files + 1.
						bytes _ bytes + (entry at: 5)]]]].

	^ Array with: dirs with: files with: bytes
! !


!FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:16'!
directoryExists: filenameOrPath
	"Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory."
	"FileDirectory default directoryExists: FileDirectory default pathName"

	| fName dir |
	FileDirectory splitName: filenameOrPath to:
		[:filePath :name |
			fName _ name.
			filePath isEmpty
				ifTrue: [dir _ self]
				ifFalse: [dir _ FileDirectory on: filePath]].

	self isCaseSensitive 
		ifTrue:[^dir directoryNames includes: fName]
		ifFalse:[^dir directoryNames anySatisfy: [:name| name sameAs: fName]].
! !

!FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'!
fileExists: filenameOrPath
	"Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory."
	"FileDirectory default fileExists: Smalltalk sourcesName"

	| fName dir |
	FileDirectory splitName: filenameOrPath to:
		[:filePath :name |
			fName _ name.
			filePath isEmpty
				ifTrue: [dir _ self]
				ifFalse: [dir _ FileDirectory on: filePath]].
	self isCaseSensitive 
		ifTrue:[^dir fileNames includes: fName]
		ifFalse:[^dir fileNames anySatisfy: [:name| name sameAs: fName]].	! !

!FileDirectory methodsFor: 'testing' stamp: 'jm 4/9/1999 17:48'!
fileOrDirectoryExists: filenameOrPath
	"Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory."
	"FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName"

	| fName dir |
	FileDirectory splitName: filenameOrPath to:
		[:filePath :name |
			fName _ name.
			filePath isEmpty
				ifTrue: [dir _ self]
				ifFalse: [dir _ FileDirectory on: filePath]].

	^ dir includesKey: fName
! !

!FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'!
includesKey: localName
	"Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names."
	"(FileDirectory on: Smalltalk vmPath) includesKey: 'SqueakV2.sources'"
	self isCaseSensitive
		ifTrue:[^ self fileAndDirectoryNames includes: localName]
		ifFalse:[^ self fileAndDirectoryNames anySatisfy: [:str| str sameAs: localName]].! !

!FileDirectory methodsFor: 'testing' stamp: 'ar 5/1/1999 01:51'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^self class isCaseSensitive! !


!FileDirectory methodsFor: 'file operations' stamp: 'MPH 10/15/2000 12:43'!
copyFile: fileStream1 toFile: fileStream2
	| buffer |
	buffer _ String new: 50000.
	[fileStream1 atEnd] whileFalse:
		[fileStream2 nextPutAll: (fileStream1 nextInto: buffer)].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'MPH 10/23/2000 13:31'!
copyFileNamed: fileName1 toFileNamed: fileName2
	"Copy the contents of the existing file with the first name into a new file with the second name. Both files are assumed to be in this directory."
	"FileDirectory default copyFileNamed: 'todo.txt' toFileNamed: 'todocopy.txt'"

	| file1 file2 |
	file1 _ (self readOnlyFileNamed: fileName1) binary.
	file2 _ (self newFileNamed: fileName2) binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.
! !

!FileDirectory methodsFor: 'file operations' stamp: 'dew 10/26/2000 02:23'!
copyFileWithoutOverwriteConfirmationNamed: fileName1 toFileNamed: fileName2
	"Copy the contents of the existing file with the first name into a file with the second name (which may or may not exist). If the second file exists, force an overwrite without confirming.  Both files are assumed to be in this directory."
	"FileDirectory default copyFileWithoutOverwriteConfirmationNamed: 'todo.txt' toFileNamed: 'todocopy.txt'"

	| file1 file2 |
	fileName1 = fileName2 ifTrue: [^ self].
	file1 _ (self readOnlyFileNamed: fileName1) binary.
	file2 _ (self forceNewFileNamed: fileName2) binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.! !

!FileDirectory methodsFor: 'file operations' stamp: 'jm 12/4/97 22:55'!
createDirectory: localFileName
	"Create a directory with the given name in this directory. Fail if the name is bad or if a file or directory with that name already exists."

 	self primCreateDirectory: (self fullNameFor: localFileName).
! !

!FileDirectory methodsFor: 'file operations' stamp: 'jm 4/9/1999 18:02'!
deleteDirectory: localDirName
	"Delete the directory with the given name in this directory. Fail if the path is bad or if a directory by that name does not exist."

 	self primDeleteDirectory: (self fullNameFor: localDirName).
! !

!FileDirectory methodsFor: 'file operations' stamp: 'jm 12/5/97 16:33'!
deleteFileNamed: localFileName
	"Delete the file with the given name in this directory."

	self deleteFileNamed: localFileName ifAbsent: [].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'ar 3/21/98 18:08'!
deleteFileNamed: localFileName ifAbsent: failBlock
	"Delete the file of the given name if it exists, else evaluate failBlock.
	If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53"
	(self 
		retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName)]
		until:[:result| result notNil]) == nil
			ifTrue: [^failBlock value].
! !

!FileDirectory methodsFor: 'file operations' stamp: 'JMM 1/29/2001 23:02'!
getMacFileTypeAndCreator: fileName 
	| results typeString creatorString |
	"get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)."
	"FileDirectory default getMacFileNamed: 'foo'"

	typeString _ ByteArray new: 4 withAll: ($? asInteger).
	creatorString _ ByteArray new: 4 withAll: ($? asInteger).
	[self primGetMacFileNamed: (self fullNameFor: fileName)
		type: typeString
		creator: creatorString.] ensure: 
		[typeString _ typeString asString. 
		creatorString _ creatorString asString].
	results _ Array with: typeString with: creatorString.
	^results
! !

!FileDirectory methodsFor: 'file operations' stamp: 'ar 2/2/2001 13:11'!
mimeTypesFor: fileName
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"

	| idx ext dot |
	ext _ ''.
	dot _ self class extensionDelimiter.
	idx _ (self fullNameFor: fileName) findLast: [:ch| ch = dot].
	idx = 0 ifFalse:[ext _ fileName copyFrom: idx+1 to: fileName size].
	^StandardMIMEMappings at: ext ifAbsent:[nil]! !

!FileDirectory methodsFor: 'file operations' stamp: 'MPH 10/23/2000 13:31'!
putFile: file1 named: destinationFileName
	"Copy the contents of the existing fileStream into the file destinationFileName in this directory.  fileStream can be anywhere in the fileSystem."

	| file2 |
	file1 binary.
	(file2 _ self newFileNamed: destinationFileName) ifNil: [^ false].
	file2 binary.
	self copyFile: file1 toFile: file2.
	file1 close.
	file2 close.
	^ true
! !

!FileDirectory methodsFor: 'file operations' stamp: 'tk 2/26/2000 12:54'!
putFile: file1 named: destinationFileName retry: aBool
	"Copy the contents of the existing fileStream into the file destinationFileName in this directory.  fileStream can be anywhere in the fileSystem.  No retrying for local file systems."

	^ self putFile: file1 named: destinationFileName
! !

!FileDirectory methodsFor: 'file operations' stamp: 'tk 3/31/2000 21:09'!
rename: oldFileName toBe: newFileName
	| selection |
	"Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name."
	"Modified for retry after GC ar 3/21/98 18:09"

	(self retryWithGC:[self primRename: (self fullNameFor: oldFileName)
						to: (self fullNameFor: newFileName)]
		until:[:result| result notNil]) ~~ nil ifTrue:[^self].
	(self fileExists: oldFileName) ifFalse:[
		^self error:'Attempt to rename a non-existent file'.
	].
	(self fileExists: newFileName) ifTrue:[
		selection _ (PopUpMenu labels:
'delete old version
cancel')
				startUpWithCaption: 'Trying to rename a file to be
', newFileName , '
and it already exists.'.
		selection = 1 ifTrue:
			[self deleteFileNamed: newFileName.
			^ self rename: oldFileName toBe: newFileName]].
	^self error:'Failed to rename file'.! !

!FileDirectory methodsFor: 'file operations' stamp: 'jm 3/27/98 06:40'!
setMacFileNamed: fileName type: typeString creator: creatorString
	"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)."
	"FileDirectory default setMacFileNamed: 'foo' type: 'TEXT' creator: 'ttxt'"

 	self primSetMacFileNamed: (self fullNameFor: fileName)
		type: typeString
		creator: creatorString.
! !


!FileDirectory methodsFor: 'file name utilities' stamp: 'jm 5/8/1998 20:48'!
checkName: aFileName fixErrors: fixing
	"Check a string aFileName for validity as a file name. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is just to truncate the name to the maximum length for this platform. Subclasses can do any kind of checking and correction appropriate for their platform."

	| maxLength |
	aFileName size = 0 ifTrue: [self error: 'zero length file name'].
	maxLength _ self class maxFileNameLength.
	aFileName size > maxLength ifTrue: [
		fixing
			ifTrue: [^ aFileName contractTo: maxLength]
			ifFalse: [self error: 'file name is too long']].

	^ aFileName
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'jm 12/4/97 21:01'!
fileNamesMatching: pat
	"FileDirectory default fileNamesMatching: '*'"

	^ self fileNames select: [:name | pat match: name]
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'acg 1/7/2000 08:00'!
fullNameFor: fileName
	"Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name."
	"Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm."
	| correctedLocalName prefix |
	self class splitName: fileName to:
		[:filePath :localName |
			correctedLocalName _ localName isEmpty 
				ifFalse: [self checkName: localName fixErrors: true]
				ifTrue: [localName].
			prefix _ self fullPathFor: filePath].
	prefix isEmpty
		ifTrue: [^correctedLocalName].
	prefix last = self pathNameDelimiter
		ifTrue:[^ prefix, correctedLocalName]
		ifFalse:[^ prefix, self slash, correctedLocalName]! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'jm 12/4/97 21:19'!
isLegalFileName: aString 
	"Answer true if the given string is a legal file name."

	^ (self checkName: aString fixErrors: true) = aString
! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'djp 10/27/1999 09:01'!
nextNameFor: baseFileName extension: extension
	"Assumes a file name includes a version number encoded as '.' followed by digits 
	preceding the file extension.  Increment the version number and answer the new file name.
	If a version number is not found, set the version to 1 and answer a new file name"

	| files splits version |

	files _ self fileNamesMatching: (baseFileName,'*', self class dot, extension).
	splits _ files 
			collect: [:file | self splitNameVersionExtensionFor: file]
			thenSelect: [:split | (split at: 1) = baseFileName].
	splits _ splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)].
	splits isEmpty 
			ifTrue: [version _ 1]
			ifFalse: [version _ (splits last at: 2) + 1].
	^ (baseFileName, '.', version asString, self class dot, extension) asFileName! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'tk 2/25/2000 13:40'!
realUrl
	^ self url! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'djp 10/27/1999 08:58'!
splitNameVersionExtensionFor: fileName
	" answer an array with the root name, version # and extension.
	See comment in nextSequentialNameFor: for more details"

	| baseName version extension i j |

	baseName _ self class baseNameFor: fileName.
	extension _ self class extensionFor: fileName.
	i _ j _ baseName findLast: [:c | c isDigit not].
	i = 0
		ifTrue: [version _ 0]
		ifFalse:
			[(baseName at: i) = $.
				ifTrue:
					[version _ (baseName copyFrom: i+1 to: baseName size) asNumber.
					j _ j - 1]
				ifFalse: [version _ 0].
			baseName _ baseName copyFrom: 1 to: j].
	^ Array with: baseName with: version with: extension! !

!FileDirectory methodsFor: 'file name utilities' stamp: 'tk 2/25/2000 13:40'!
url
	"Convert my path into a file:// type url.  Use slash instead of the local delimiter (:), and convert odd characters to %20 notation."

	"If slash (/) is not the file system delimiter, encode slashes before converting."
	| list |
	list _ self pathParts.
	^ String streamContents: [:strm |
		strm nextPutAll: 'file:/'.
		list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP].
		strm nextPut: $/]! !


!FileDirectory methodsFor: 'printing' stamp: 'jm 12/4/97 19:41'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: self class name.
	aStream nextPutAll: ' on '.
	pathName printOn: aStream.
! !


!FileDirectory methodsFor: 'private' stamp: 'jm 8/14/1998 16:44'!
directoryContentsFor: fullPath
	"Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details."
	"FileDirectory default directoryContentsFor: ''"

	| entries index done entryArray |
	entries _ OrderedCollection new: 200.
	index _ 1.
	done _ false.
	[done] whileFalse: [
		entryArray _ self primLookupEntryIn: fullPath index: index.
		#badDirectoryPath = entryArray ifTrue: [^ OrderedCollection new].
		entryArray == nil
			ifTrue: [done _ true]
			ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)].
		index _ index + 1].

	^ entries asArray
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primCreateDirectory: fullPath
	"Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists."

 	<primitive: 'primitiveDirectoryCreate' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primDeleteDirectory: fullPath
	"Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist."

 	<primitive: 'primitiveDirectoryDelete' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primDeleteFileNamed: aFileName
	"Delete the file of the given name. Return self if the primitive succeeds, nil otherwise."

	<primitive: 'primitiveFileDelete' module: 'FilePlugin'>
	^ nil
! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primGetMacFileNamed: fileName type: typeString creator: creatorString
	"Get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms."

 	<primitive: 'primitiveDirectoryGetMacTypeAndCreator' module: 'FilePlugin'>

! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primLookupEntryIn: fullPath index: index
	"Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

	The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.)

	The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad."

 	<primitive: 'primitiveDirectoryLookup' module: 'FilePlugin'>
	^ #badDirectoryPath

! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primRename: oldFileFullName to: newFileFullName 
	"Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name.
	Changed to return nil instead of failing ar 3/21/98 18:04"

	<primitive: 'primitiveFileRename' module: 'FilePlugin'>
	^nil! !

!FileDirectory methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSetMacFileNamed: fileName type: typeString creator: creatorString
	"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. This primitive is Mac specific; it is a noop on other platforms."

 	<primitive: 'primitiveDirectorySetMacTypeAndCreator' module: 'FilePlugin'>
	self primitiveFailed
! !

!FileDirectory methodsFor: 'private' stamp: 'jm 12/4/97 22:44'!
setPathName: pathString

	pathName _ pathString.
! !


!FileDirectory methodsFor: 'file status' stamp: 'mdr 1/14/2000 21:16'!
entryAt: fileName  
	"find the entry with local name fileName"

	^self entryAt: fileName ifAbsent: [ self error: 'file not in directory: ', fileName ].! !

!FileDirectory methodsFor: 'file status' stamp: 'sma 6/3/2000 22:11'!
entryAt: fileName ifAbsent: aBlock
	"Find the entry with local name fileName and answer it.
	If not found, answer the result of evaluating aBlock."

	| comparisonBlock |
	self isCaseSensitive
		ifTrue: [comparisonBlock _ [:entry | (entry at: 1) = fileName]]
		ifFalse: [comparisonBlock _ [:entry | (entry at: 1) sameAs: fileName]].
	^ self entries detect: comparisonBlock ifNone: [aBlock value]! !


!FileDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:47'!
localNameFor: fullName
	"Return the local part the given name."

	^self class localNameFor: fullName! !

!FileDirectory methodsFor: 'file directory' stamp: 'tk 12/13/1999 18:55'!
sleep
	"Leave the FileList window.  Do nothing.  Disk directories do not have to be shut down."
! !

!FileDirectory methodsFor: 'file directory' stamp: 'di 2/11/2000 22:37'!
wakeUp
	"Entering a FileList window.  Do nothing.  Disk directories do not have to be awakened."
! !


!FileDirectory methodsFor: 'searching' stamp: 'sw 6/2/2000 21:55'!
filesContaining: searchString caseSensitive: aBoolean
	| aList |
	"Search the contents of all files in the receiver and its subdirectories for the search string.  Return a list of paths found.  Make the search case sensitive if aBoolean is true."

	aList _ OrderedCollection new.
	self withAllFilesDo: [:stream |
			(stream contentsOfEntireFile includesSubstring: searchString caseSensitive: aBoolean)
				ifTrue:	[aList add: stream name]]
		andDirectoriesDo: [:d | d pathName].
	^ aList

"FileDirectory default filesContaining: 'includesSubstring:'  caseSensitive: true"! !

!FileDirectory methodsFor: 'searching' stamp: 'SIM 5/22/2000 13:33'!
withAllFilesDo: fileStreamBlock andDirectoriesDo: directoryBlock

	"For the receiver and all it's subdirectories evaluate directoryBlock.
	For a read only file stream on each file within the receiver 
	and it's subdirectories evaluate fileStreamBlock."

	| todo dir |

	todo _ OrderedCollection with: self.
	[todo size > 0] whileTrue: [
		dir _ todo removeFirst.
		directoryBlock value: dir.
		dir fileNames do: [: n | 
			fileStreamBlock value: 
				(FileStream readOnlyFileNamed: (dir fullNameFor: n))].
		dir directoryNames do: [: n | 
			todo add: (dir directoryNamed: n)]]

! !


!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/17/2000 14:57'!
directoryObject

	^self! !

!FileDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:18'!
updateProjectInfoFor: aProject

	"only swiki servers for now"! !

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

FileDirectory class
	instanceVariableNames: ''!

!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 19:24'!
default
	"Answer the default directory."

	^ DefaultDirectory
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'ls 9/10/1998 00:59'!
forFileName: aString

	| path |
	path _ self dirPathFor: aString.
	path isEmpty ifTrue: [^ self default].
	^ self on: path
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'tk 5/6/1998 14:31'!
on: pathString
	"Return a new file directory for the given path, of the appropriate FileDirectory subclass for the current OS platform."

	| pathName |
	DirectoryClass ifNil: [DirectoryClass _ self activeDirectoryClass].
	"If path ends with a delimiter (: or /) then remove it"
	((pathName _ pathString) endsWith: self pathNameDelimiter asString) ifTrue: [
		pathName _ pathName copyFrom: 1 to: pathName size - 1].
	^ DirectoryClass new setPathName: pathName
! !

!FileDirectory class methodsFor: 'instance creation' stamp: 'jm 12/4/97 23:29'!
root
	"Answer the root directory."

	^ self on: ''
! !


!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 3/28/98 06:16'!
baseNameFor: fileName
	"Return the given file name without its extension, if any."

	| delim i |
	delim _ DirectoryClass extensionDelimiter.
	i _ fileName findLast: [:c | c = delim].
	i = 0
		ifTrue: [^ fileName]
		ifFalse: [^ fileName copyFrom: 1 to: i - 1].
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:32'!
changeSuffix
"if 'changes' is not suitable, override this message to return something that is ok"
	^'changes'! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/4/97 23:38'!
checkName: fullName fixErrors: flag
	"Check a string aFileName for validity as a file name. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is to truncate the name to 31 chars. Subclasses can do any kind of checking and correction appropriate to the underlying platform."

	^ DefaultDirectory
		checkName: (self localNameFor: fullName)
		fixErrors: flag
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/5/97 13:30'!
dirPathFor: fullName
	"Return the directory part the given name."

	self
		splitName: fullName
		to: [:dirPath :localName | ^ dirPath]
! !

!FileDirectory class methodsFor: 'name utilities'!
extensionFor: fileName
	"Return the extension of given file name, if any."

	| delim i |
	delim _ DirectoryClass extensionDelimiter.
	i _ fileName findLast: [:c | c = delim].
	i = 0
		ifTrue: [^ '']
		ifFalse: [^ fileName copyFrom: i + 1 to: fileName size].
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'mir 10/11/2000 17:38'!
fileName: fileName extension: fileExtension
	| extension |
	extension _ FileDirectory dot , fileExtension.
	^(fileName endsWith: extension)
		ifTrue: [fileName]
		ifFalse: [fileName , extension].! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'TPR 5/10/1998 21:31'!
imageSuffix
"if 'image' is not suitable, override this message to return something that is ok"
	^'image'! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/4/97 23:40'!
isLegalFileName: fullName
	"Return true if the given string is a legal file name."

	^ DefaultDirectory isLegalFileName: (self localNameFor: fullName)
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'jm 12/5/97 13:30'!
localNameFor: fullName
	"Return the local part the given name."

	self
		splitName: fullName
		to: [:dirPath :localName | ^ localName]
! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'sma 6/17/2000 00:11'!
searchAllFilesForAString

	"Prompt the user for a search string, and a starting directory. Search the contents of all files in the starting directory and its subdirectories for the search string (case-insensitive search.)
	List the paths of files in which it is found on the Transcript.
	By Stewart MacLean 5/00; subsequently moved to FileDirectory class-side, and refactored to call FileDirectory.filesContaining:caseSensitive:"

	| searchString dir |

	searchString _ FillInTheBlank request: 'Enter search string'.
	searchString isEmpty ifTrue: [^nil].
	Transcript cr; show: 'Searching for ', searchString printString, ' ...'.
	(dir _ PluggableFileList getFolderDialog open) ifNotNil:
		[(dir filesContaining: searchString caseSensitive: false) do:
				[:pathname | Transcript cr; show: pathname]].
	Transcript cr; show: 'Finished searching for ', searchString printString

	"FileDirectory searchAllFilesForAString"! !

!FileDirectory class methodsFor: 'name utilities' stamp: 'bf 3/22/2000 18:04'!
splitName: fullName to: pathAndNameBlock
	"Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters."

	| delimiter i dirName localName |
	delimiter _ self pathNameDelimiter.
	(i _ fullName findLast: [:c | c = delimiter]) = 0
		ifTrue:
			[dirName _ String new.
			localName _ fullName]
		ifFalse:
			[dirName _ fullName copyFrom: 1 to: (i - 1 max: 1).
			localName _ fullName copyFrom: i + 1 to: fullName size].

	^ pathAndNameBlock value: dirName value: localName! !


!FileDirectory class methodsFor: 'create/delete file' stamp: 'tk 1/13/98 17:21'!
deleteFilePath: fullPathToAFile
	"Delete the file after finding its directory"

	| dir |
	dir _ self on: (self dirPathFor: fullPathToAFile).
	dir deleteFileNamed: (self localNameFor: fullPathToAFile).
! !


!FileDirectory class methodsFor: 'system start up' stamp: 'sma 6/25/2000 10:39'!
openSources: sourcesName andChanges: changesName forImage: imageName 
	"Initialize the default directory to the image directory and open the  
	sources and changes files, if possible. Look for the changes file in  
	image directory. Look for the system sources (or an alias to it) first in  
	the VM directory, then in the image directory. Open the changes and  
	sources files and install them in SourceFiles."
	"Note: SourcesName and imageName are full paths; changesName is a  
	local name."
	| sources changes sourceAlias msg wmsg localSourcesName |
	msg _ 'Squeak cannot locate &fileRef.

Please check that the file is named properly and is in the
same directory as this image.  
Further explanation can found
in the startup window, ''How Squeak Finds Source Code''.'.
	wmsg _ 'Squeak cannot write to &fileRef.

Please check that you have write permission for this file.

You won''t be able to save this image correctly until you fix this.'.
	self setDefaultDirectoryFrom: imageName.
	sources _ changes _ nil.
	"look for the sources file or an alias to it in the VM's directory"
	(DefaultDirectory fileExists: sourcesName)
		ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourcesName]
		ifFalse: 
			["look for an un-renamed Macintosh alias to the sources file"
			sourceAlias _ sourcesName , ' alias'.
			(DefaultDirectory fileExists: sourceAlias)
				ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourceAlias]].
	sources
		ifNil: 
			["look for the sources file or an alias to it in the image directory"
			localSourcesName _ FileDirectory localNameFor: sourcesName.
			(DefaultDirectory fileExists: localSourcesName)
				ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: localSourcesName]
				ifFalse: 
					["look for an un-renamed Macintosh alias to the sources  
					file"
					sourceAlias _ localSourcesName , ' alias'.
					(DefaultDirectory fileExists: sourceAlias)
						ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourceAlias]]].
	(DefaultDirectory fileExists: changesName)
		ifTrue: 
			[changes _ DefaultDirectory oldFileNamed: changesName.
			changes isNil
				ifTrue: 
					[PopUpMenu notify: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName).
					changes _ DefaultDirectory readOnlyFileNamed: changesName]].
	((sources == nil or: [sources atEnd])
		and: [Preferences valueOfFlag: #warnIfNoSourcesFile])
		ifTrue: 
			[PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName).
			Smalltalk platformName = 'Mac OS'
				ifTrue: [PopUpMenu notify: 'Make sure the sources file is not an Alias.']].
	(changes == nil and: [Preferences valueOfFlag: #warnIfNoChangesFile])
		ifTrue: [PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)].
	(Preferences valueOfFlag: #warnIfNoChangesFile) ifTrue: [
		((changes next: 200) includesSubString: String crlf) ifTrue: [
			PopUpMenu notify: 'The changes file named ' , changesName, '
has been injured by an unpacking utility.  Crs were changed to CrLfs.
Please set the preferences in your decompressing program to 
"do not convert text files" and unpack the system again.']].
	SourceFiles _ Array with: sources with: changes! !

!FileDirectory class methodsFor: 'system start up' stamp: 'jm 3/27/98 06:53'!
setDefaultDirectoryFrom: imageName
	"Initialize the default directory to the directory containing the Squeak image file. This method is called when the image starts up."

	DirectoryClass _ self activeDirectoryClass.
	DefaultDirectory _ self on: (self dirPathFor: imageName).
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'di 2/4/1999 15:27'!
shutDown

	Smalltalk closeSourceFiles.
! !

!FileDirectory class methodsFor: 'system start up' stamp: 'di 2/4/1999 08:50'!
startUp
	"Establish the platform-specific FileDirectory subclass. Do any platform-specific startup."

	self setDefaultDirectoryFrom: Smalltalk imageName.
	Smalltalk openSourceFiles.
! !


!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 08:17'!
dot
	"Return a one-character string containing the filename extension delimiter for this platform (i.e., the local equivalent of 'dot')"

	^ self extensionDelimiter asString
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:57'!
extensionDelimiter
	"Return the character used to delimit filename extensions on this platform. Most platforms use the period (.) character."

	^ $.
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'!
isCaseSensitive
	"Return true if file names are treated case sensitive"
	^true! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'jm 5/8/1998 20:45'!
maxFileNameLength

	^ 31
! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/12/1998 22:49'!
pathNameDelimiter
"return the active directory class's directory seperator character"
	^ DirectoryClass pathNameDelimiter! !

!FileDirectory class methodsFor: 'platform specific' stamp: 'ar 4/18/1999 18:18'!
slash
	^ self pathNameDelimiter asString! !


!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:47'!
activeDirectoryClass
	"Return the concrete FileDirectory subclass for the platform on which we are currently running."

	FileDirectory allSubclasses do: [:class |
		class isActiveDirectoryClass ifTrue: [^ class]].

	"no responding subclass; use FileDirectory"
	^ FileDirectory
! !

!FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:40'!
isActiveDirectoryClass
	"Does this class claim to be that properly active subclass of FileDirectory for this platform?
	Default test is whether the primPathNameDelimiter matches the one for this class. Other tests are possible"

	^self pathNameDelimiter = self primPathNameDelimiter
! !

!FileDirectory class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primPathNameDelimiter
	"Return the path delimiter for the underlying platform's file system."

 	<primitive: 'primitiveDirectoryDelimitor' module: 'FilePlugin'>
	self primitiveFailed
! !


!FileDirectory class methodsFor: 'class initialization' stamp: 'ar 2/2/2001 13:10'!
initializeStandardMIMETypes
	"FileDirectory initializeStandardMIMETypes"
	StandardMIMEMappings _ Dictionary new.
	#(
		(gif		('image/gif'))
		(pdf	('application/pdf'))
		(aiff	('audio/aiff'))
		(bmp	('image/bmp'))
		(swf	('application/x-shockwave-flash'))
		(htm	('text/html' 'text/plain'))
		(html	('text/html' 'text/plain'))
		(jpg		('image/jpeg'))
		(jpeg	('image/jpeg'))
		(mid	('audio/midi'))
		(midi	('audio/midi'))
		(mp3	('audio/mpeg'))
		(mpeg	('video/mpeg'))
		(mpg	('video/mpg'))
		(txt		('text/plain'))
		(text	('text/plain'))
		(mov	('video/quicktime'))
		(qt		('video/quicktime'))
		(tif		('image/tiff'))
		(tiff	('image/tiff'))
		(ttf		('application/x-truetypefont'))
		(wrl	('model/vrml'))
		(vrml	('model/vrml'))
		(wav	('audio/wav'))
	) do:[:spec|
		StandardMIMEMappings at: spec first asString put: spec last.
	].! !
ListItemWrapper subclass: #FileDirectoryWrapper
	instanceVariableNames: 'itemName balloonText '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:07'!
asString 

	^itemName! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:00'!
balloonText

	^balloonText! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:01'!
balloonText: aStringOrNil

	balloonText _ aStringOrNil! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 16:02'!
contents

	^((model directoryNamesFor: itemName) sortBy: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n | 
		FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self
	]
! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 16:03'!
directoryNamesFor: fullString
	^model directoryNamesFor: itemName, FileDirectory slash, fullString! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:03'!
hasContents

	^true
	
! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:01'!
setItem: anObject name: aString model: aModel

	item _ anObject.
	model _ aModel.
	itemName _ aString.! !

!FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'!
settingSelector

	^#setSelectedDirectoryTo:! !

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

FileDirectoryWrapper class
	instanceVariableNames: ''!

!FileDirectoryWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 18:01'!
with: anObject name: aString model: aModel

	^self new 
		setItem: anObject name: aString model: aModel! !
FileStreamException subclass: #FileDoesNotExistException
	instanceVariableNames: 'readOnly '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!

!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:41'!
readOnly
	^readOnly == true! !

!FileDoesNotExistException methodsFor: 'accessing' stamp: 'mir 7/25/2000 16:40'!
readOnly: aBoolean
	readOnly _ aBoolean! !


!FileDoesNotExistException methodsFor: 'exceptionDescription' stamp: 'mir 7/25/2000 18:22'!
defaultAction
	"The default action taken if the exception is signaled."


	^self readOnly
		ifTrue: [StandardFileStream readOnlyFileDoesNotExistUserHandling: self fileName]
		ifFalse: [StandardFileStream fileDoesNotExistUserHandling: self fileName]
! !

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

FileDoesNotExistException class
	instanceVariableNames: ''!

!FileDoesNotExistException class methodsFor: 'examples' stamp: 'mir 2/29/2000 11:44'!
example
	"FileDoesNotExistException example"

	| result |
	result _ [(StandardFileStream readOnlyFileNamed: 'error42.log') contentsOfEntireFile]
		on: FileDoesNotExistException
		do: [:ex | 'No error log'].
	Transcript show: result; cr! !
FileStreamException subclass: #FileExistsException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!

!FileExistsException methodsFor: 'exceptionDescription' stamp: 'mir 7/25/2000 18:22'!
defaultAction
	"The default action taken if the exception is signaled."

	^StandardFileStream fileExistsUserHandling: self fileName
! !
TextInput subclass: #FileInput
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!FileInput commentStamp: '<historical>' prior: 0!
An input field for <INPUT TYPE="file">
Support for uploading files using HTTP/multipart forms
Appearance/behavior as in NS/MS browsers
(i.e., separate filename entry box and browse files button)!


!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 19:37'!
browse
	| file |
	file _ (StandardFileMenu oldFileFrom: self directory) ifNil: [^nil].
	file directory isNil ifTrue: [^ nil].

	textMorph setText: (file directory pathName, FileDirectory slash, file name);
		hasUnacceptedEdits: true;
		accept! !

!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 18:56'!
directory
	^FileDirectory forFileName: self filename! !

!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 18:43'!
filename
	textMorph hasUnacceptedEdits ifTrue: [ textMorph accept ].
	^textMorph getText asString withInternetLineEndings! !

!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 18:58'!
localFilename
	^FileDirectory localNameFor: self filename! !

!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 19:23'!
url
	^FileUrl new path: (self directory pathParts), {self localFilename}
		isAbsolute: true! !

!FileInput methodsFor: 'accessing' stamp: 'bolot 11/27/1999 18:55'!
value
	^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self filename)
		content: nil
		url: self url! !

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

FileInput class
	instanceVariableNames: ''!

!FileInput class methodsFor: 'instance creation' stamp: 'bolot 11/27/1999 18:36'!
name: aString textMorph: aTextMorph
	^self name: aString defaultValue: '' textMorph: aTextMorph! !
StringHolder subclass: #FileList
	instanceVariableNames: 'fileName directory volList volListIndex list listIndex pattern sortMode brevityState '
	classVariableNames: 'RecentDirs '
	poolDictionaries: ''
	category: 'Tools-FileList'!
!FileList commentStamp: '<historical>' prior: 0!
I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file.

FileLists can now see FTP servers anywhere on the net.  In the volume list menu: 
fill in server info...		Gives you a form to register a new ftp server you want to use.
open server...		Choose a server to connect to.
local disk			Go back to looking at your local volume.

Still undone (you can contribute code):
[ ] Using a Proxy server to get out through a firewall.  What is the convention for proxy servers with FTP?
[ ] Fill in the date and size info in the list of remote files.  Allow sorting by it.  New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:).
[ ] Currently the FileList has no way to delete a directory.  Since you can't select a directory without going into it, it would have to be deleting the current directory.  Which would usually be empty.

!


!FileList methodsFor: 'initialization' stamp: 'di 5/16/2000 09:42'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode == nil ifTrue: [sortMode _ #date].
	volList _ ((Array with: '[]'), directory pathParts)  "Nesting suggestion from RvL"
			withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern! !

!FileList methodsFor: 'initialization' stamp: 'tk 5/18/1998 17:22'!
labelString
	^ directory pathName contractTo: 50! !

!FileList methodsFor: 'initialization' stamp: 'tk 12/17/1999 18:00'!
modelSleep
	"User has exited or collapsed the window -- close any remote connection."

	directory ifNotNil: [directory sleep]! !

!FileList methodsFor: 'initialization' stamp: 'di 2/16/2000 10:50'!
modelWakeUp
	"User has entered or expanded the window -- reopen any remote connection."

	(directory isKindOf: ServerDirectory) ifTrue:
		[directory wakeUp]! !

!FileList methodsFor: 'initialization' stamp: 'sbw 12/30/1999 15:53'!
optionalButtonHeight

	^ 15! !

!FileList methodsFor: 'initialization' stamp: 'RAA 1/17/2001 14:26'!
optionalButtonRow
	| aRow aButton |
	aRow _ AlignmentMorph newRow beSticky.
	aRow clipSubmorphs: true.
	aRow addTransparentSpacerOfSize: (5@0).
	self optionalButtonSpecs do:
			[:spec |
				aButton _ PluggableButtonMorph
					on: self
					getState: nil
					action: spec second.
				aButton
					hResizing: #spaceFill;
					vResizing: #spaceFill;
					useRoundedCorners;
					label: spec first asString;
					askBeforeChanging: true;
					onColor: Color transparent offColor: Color transparent.
				aRow addMorphBack: aButton.
				aRow addTransparentSpacerOfSize: (3 @ 0).
				aButton setBalloonText: spec fourth.
				aRow addTransparentSpacerOfSize: (3 @ 0).

				(spec second == #sortBySize)
					ifTrue:
						[aRow addTransparentSpacerOfSize: (4@0)]].
	^ aRow! !

!FileList methodsFor: 'initialization' stamp: 'sw 1/7/2000 15:55'!
optionalButtonSpecs
	^ #(	
		('Name' 		sortByName				sortingByName	'sort entries by name')
		('Date'			sortByDate				sortingByDate	'sort entries by date')
		('Size'			sortBySize				sortingBySize	'sort entries by size')
		('Changes'		browseChanges			none			'open a changelist browser on selected file')
		('File-in'		fileInSelection			none			'fileIn the selected file')
		('File-in to New'	fileIntoNewChangeSet	none			'fileIn the selected file into a new change set')
		('Delete'			deleteFile				none			'delete the seleted item'))
! !

!FileList methodsFor: 'initialization' stamp: 'sw 1/7/2000 15:56'!
optionalButtonView

	| aView bHeight windowWidth offset previousView aButtonView wid specs |
	aView _ View new model: self.
	bHeight _ self optionalButtonHeight.
	windowWidth _ 120.
	aView window: (0@0 extent: windowWidth@bHeight).
	offset _ 0.
	specs _ self optionalButtonSpecs copyFrom: 1 to: 6.  "Too cramped for the seventh!!"
	previousView _ nil.
	specs do: [:quad |
		aButtonView _ PluggableButtonView on: self getState: (quad third == #none ifTrue: [nil] ifFalse: [quad third]) action: quad second.
		quad second = specs last second
			ifTrue:
				[wid _ windowWidth - offset]
			ifFalse:
				[aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
				wid _ (windowWidth // (specs size)) - 2].
		aButtonView
			label: quad first asParagraph;
			window: (offset@0 extent: wid@bHeight).
		offset _ offset + wid.
		quad second = specs first second
			ifTrue: [aView addSubView: aButtonView]
			ifFalse: [aView addSubView: aButtonView toRightOf: previousView].
		previousView _ aButtonView].
	^aView
! !

!FileList methodsFor: 'initialization' stamp: 'di 5/11/1999 22:25'!
release

	self modelSleep! !

!FileList methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:28'!
setFileStream: aStream
	"Used to initialize a spawned file editor.  Sets directory too."

	self directory: aStream directory.
	fileName _ aStream localName.
	pattern _ '*'.
	listIndex _ 1.  "pretend a file is selected"
	aStream close.
	brevityState _ #needToGetBrief.
	self changed: #contents.
! !


!FileList methodsFor: 'volume list and pattern' stamp: 'di 5/26/1998 21:05'!
askServerInfo
	"Get the user to create a ServerDirectory for a new server.  Fill in and say Accept."
	| template |
	template _ '"Please fill in the following info, then select all text and choose DoIt."

| aa | aa _ ServerDirectory new.
aa server: ''st.cs.uiuc.edu''.    "host"
aa user: ''anonymous''.
aa password: ''yourEmail@school.edu''.
aa directory: ''/Smalltalk/Squeak/Goodies''.
aa url: ''''.    "<- this is optional.  Only used when *writing* update files."
ServerDirectory addServer: aa named: ''UIUCArchive''.  "<- known by this name in Squeak"'.

	(StringHolder new contents: template) openLabel: 'FTP Server Form'
	! !

!FileList methodsFor: 'volume list and pattern' stamp: 'ar 6/16/1999 06:58'!
deleteDirectory
	"Remove the currently selected directory"
	| localDir |
	directory entries size = 0 ifFalse:[^self inform:'Directory must be empty'].
	localDir _ directory pathParts last.
	(self confirm: 'Really delete ' , localDir printString , '?') ifFalse: [^ self].
	self volumeListIndex: self volumeListIndex-1.
	directory deleteDirectory: localDir.
	self updateFileList.! !

!FileList methodsFor: 'volume list and pattern' stamp: 'ls 7/25/1998 01:15'!
fileNameFormattedFrom: entry sizePad: sizePad
	"entry is a 5-element array of the form:
		(name creationTime modificationTime dirFlag fileSize)"
	| sizeStr nameStr dateStr |
	nameStr _ (entry at: 4)
		ifTrue: [entry first , self folderString]
		ifFalse: [entry first].
	dateStr _ ((Date fromSeconds: (entry at: 3) )
					printFormat: #(3 2 1 $. 1 1 2)) , ' ' ,
				(String streamContents: [:s |
					(Time fromSeconds: (entry at: 3) \\ 86400)
						print24: true on: s]).
	sizeStr _ (entry at: 5) asStringWithCommas.
	sortMode = #name ifTrue:
		[^ nameStr , '    (' , dateStr , ' ' , sizeStr , ')'].
	sortMode = #date ifTrue:
		[^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr].
	sortMode = #size ifTrue:
		[^ '(' , ((sizeStr size to: sizePad) collect: [:i | $ ]) , sizeStr , ' ' , dateStr , ') ' , nameStr].
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'sma 11/11/2000 18:06'!
listForPattern: pat
	"Make the list be those file names which match the pattern."

	| sizePad newList |
	newList _ (self entriesMatching: pat) asSortedCollection: self sortBlock.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].

	volList size = 1 ifTrue:
		["Include known servers along with other desktop volumes" 
		^ newList asArray ,
		(ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
	^ newList asArray! !

!FileList methodsFor: 'volume list and pattern' stamp: 'tk 4/7/98 15:26'!
pattern

	^ pattern ifNil: ['*']
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 19:01'!
pattern: textOrStringOrNil

	textOrStringOrNil
		ifNil: [pattern _ '*']
		ifNotNil: [pattern _ textOrStringOrNil asString].
	self updateFileList.
	^ true
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'di 5/26/1998 21:08'!
removeServer
	| choice names |
	names _ ServerDirectory serverNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	ServerDirectory removeServerNamed: choice! !

!FileList methodsFor: 'volume list and pattern' stamp: 'sw 3/6/1999 11:39'!
veryDeepFixupWith: deepCopier
	super veryDeepFixupWith: deepCopier.
	volListIndex _ 1.
	self directory: FileDirectory default.
	self updateFileList! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 18:20'!
volumeList
	"Answer the current list of volumes."

	^ volList
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/3/1998 18:21'!
volumeListIndex
	"Answer the index of the currently selected volume."

	^ volListIndex
! !

!FileList methodsFor: 'volume list and pattern' stamp: 'stp 12/11/1999 19:37'!
volumeListIndex: index
	"Select the volume name having the given index."

	| delim path |
	volListIndex := index.
	index = 1 
		ifTrue: [self directory: (FileDirectory on: '')]
		ifFalse: [delim := directory pathNameDelimiter.
				path := String streamContents: [:strm |
					2 to: index do: [:i |
						strm nextPutAll: (volList at: i) withBlanksTrimmed.
						i < index ifTrue: [strm nextPut: delim]]].
				self directory: (directory on: path)].
	brevityState := #FileList.
	self addPath: path.
	self changed: #fileList.
	self changed: #contents! !

!FileList methodsFor: 'volume list and pattern' stamp: 'stp 12/11/1999 19:34'!
volumeMenu: aMenu
	^ aMenu labels:
'recent...
add server...
remove server...
delete directory...'
		lines: # (1 3)
		selections: #(recentDirs askServerInfo removeServer deleteDirectory)
! !


!FileList methodsFor: 'file list'!
fileList
	"Answer the list of files in the current volume."

	^ list! !

!FileList methodsFor: 'file list'!
fileListIndex
	"Answer the index of the currently selected file."

	^ listIndex! !

!FileList methodsFor: 'file list' stamp: 'tk 1/2/2000 13:07'!
fileListIndex: anInteger
	"Select the file name having the given index, and display its contents."

	| item name |
	self okToChange ifFalse: [^ self].
	listIndex := anInteger.
	listIndex = 0 
		ifTrue: [fileName := nil]
		ifFalse:
			[item := self fileNameFromFormattedItem: (list at: anInteger).
			(item endsWith: self folderString)
				ifTrue:
					["remove [...] folder string and open the folder"
					name := item copyFrom: 1 to: item size - self folderString size.
					listIndex := 0.
					brevityState := #FileList.
					self addPath: name.
					name first = $^
						ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)]
						ifFalse: [volListIndex = 1 ifTrue: [name _ name, directory slash].
							self directory: (directory directoryNamed: name)]]
				ifFalse: [fileName := item]].  "open the file selected"

	brevityState := #needToGetBrief.
	self changed: #fileListIndex.
	self changed: #contents! !


!FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:03'!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index ending |
	self okToChange ifFalse: [^ self].
	(response _ FillInTheBlank request: 'New ',aString,' Name?'
 					initialAnswer: aString,'Name')
		isEmpty ifTrue: [^ self].
	newName _ response asFileName.
	Cursor wait showWhile: [
		aBlock value: newName].
	self updateFileList.
	index _ list indexOf: newName.
	index = 0 ifTrue: [ending _ ') ',newName.
		index _ list findFirst: [:line | line endsWith: ending]].
	self fileListIndex: index.
! !

!FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:04'!
addNewDirectory
	self 
		addNew: 'Directory'
		byEvaluating: [:newName | directory createDirectory: newName]
! !

!FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:04'!
addNewFile
	self 
		addNew: 'File'
		byEvaluating: [:newName | (directory newFileNamed: newName) close]
! !

!FileList methodsFor: 'file list menu' stamp: 'mdr 8/31/2000 18:50'!
browseChanges
	"Browse the selected file in fileIn format."

	fileName
		ifNotNil:
			[ChangeList browseStream: (directory readOnlyFileNamed: fileName)]
		ifNil:
			[self beep].
! !

!FileList methodsFor: 'file list menu' stamp: 'tk 3/15/2000 10:32'!
compressFile
	"Compress the currently selected file"

	(directory readOnlyFileNamed: self fullName) compressFile.
	self updateFileList! !

!FileList methodsFor: 'file list menu' stamp: 'ar 1/15/2001 18:38'!
copyName

	listIndex = 0 ifTrue: [^ self].
	Clipboard clipboardText: self fullName asText.
! !

!FileList methodsFor: 'file list menu' stamp: 'di 8/16/1998 12:22'!
deleteFile
	"Delete the currently selected file"
	listIndex = 0 ifTrue: [^ self].
	(self confirm: 'Really delete ' , fileName , '?') ifFalse: [^ self].
	directory deleteFileNamed: fileName.
	self updateFileList.
	brevityState _ #FileList.
	self get! !

!FileList methodsFor: 'file list menu'!
editFile
	"Open a simple Edit window"
	listIndex = 0 ifTrue: [^ self].
	(directory oldFileNamed: fileName) edit! !

!FileList methodsFor: 'file list menu' stamp: 'sma 5/20/2000 18:30'!
fileAllIn
	"File in all of the currently selected file, if any."
	"wod 5/24/1998: open the file read only."

	| fn ff |
	listIndex = 0 ifTrue: [^ self].
	ff _ directory readOnlyFileNamed: (fn _ self uncompressedFileName).
	((self getSuffix: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	ff fileIn! !

!FileList methodsFor: 'file list menu' stamp: 'di 4/26/2000 20:33'!
fileContentsMenu: aMenu shifted: shifted

| shiftMenu |
^ shifted 
	ifFalse: [aMenu 
		labels: 
'get entire file
view as hex
browse changes
find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
paste...
do it (d)
print it (p)
inspect it (i)
fileIn selection
accept (s)
cancel (l)
more...' 
		lines: #(3 6 8 12 16 18)
		selections: #(get getHex browseChanges
find findAgain setSearchString
again undo
copySelection cut paste pasteRecent
doIt printIt inspectIt fileItIn
accept cancel
shiftedYellowButtonActivity)]

	ifTrue: [shiftMenu _ ParagraphEditor shiftedYellowButtonMenu.
		aMenu 
			labels: shiftMenu labelString 
			lines: shiftMenu lineArray
			selections: shiftMenu selections]

! !

!FileList methodsFor: 'file list menu' stamp: 'tk 4/13/1998 23:10'!
fileInSelection
	"FileIn all of the selected file."
	self canDiscardEdits ifFalse: [^ self changed: #flash].
	self fileAllIn.
! !

!FileList methodsFor: 'file list menu' stamp: 'RAA 7/28/2000 13:49'!
fileIntoNewChangeSet
	"File in all of the contents of the currently selected file,
	if any, into a new change set." 

	| fn ff |
	listIndex = 0 ifTrue: [^ self].
	ff _ directory readOnlyFileNamed: (fn _ self uncompressedFileName).
	((self getSuffix: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml].
	ChangeSorter newChangesFromStream: ff named: (directory localNameFor: fn)! !

!FileList methodsFor: 'file list menu' stamp: 'tk 4/7/98 15:18'!
fileListMenu: aMenu

	fileName
		ifNil: [^ self noFileSelectedMenu: aMenu]
		ifNotNil: [^ self fileSelectedMenu: aMenu].
! !

!FileList methodsFor: 'file list menu' stamp: 'sma 5/20/2000 18:29'!
fileNameSuffix
	^ self getSuffix: self fullName! !

!FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 16:06'!
fileSelectedMenu: aMenu
	| firstItems secondItems thirdItems n1 n2 n3 |
	firstItems _ self itemsForFileEnding: self fileNameSuffix asLowercase.
	secondItems _ self itemsForAnyFile.
	thirdItems _ self itemsForNoFile.
	n1 _ firstItems first size.
	n2 _ n1 + secondItems first size.
	n3 _ n2 + thirdItems first size.
	^ aMenu
		labels: firstItems first , secondItems first , thirdItems first , #('more...')
		lines: firstItems second
				, (Array with: n1 with: n2)
				, (thirdItems second collect: [:n | n + n2])
				, (Array with: n3)
		selections: firstItems third , secondItems third , thirdItems third , #(offerAllFileOptions)! !

!FileList methodsFor: 'file list menu' stamp: 'jm 5/3/1998 18:03'!
get
	"Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel."

	Cursor read showWhile: [
		self okToChange ifFalse: [^ nil].
		brevityState == #briefHex
			ifTrue: [brevityState _ #needToGetFullHex]
			ifFalse: [brevityState _ #needToGetFull].
		self changed: #contents].
! !

!FileList methodsFor: 'file list menu' stamp: 'jm 5/3/1998 18:04'!
getHex
	"Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel."

	Cursor read showWhile: [
		brevityState _ #needToGetBriefHex.
		self changed: #contents].
! !

!FileList methodsFor: 'file list menu' stamp: 'di 9/15/1998 10:02'!
importImage
	"Import the given image file and store the resulting Form in the global dictionary
	ImageImports, at a key consisting of the short filename up to the first period.  "
	| key image |
	key _ fileName sansPeriodSuffix.
	image _ Form fromFileNamed: self fullName.
	Smalltalk imageImports at: key put: image.
! !

!FileList methodsFor: 'file list menu' stamp: 'ar 1/2/2000 15:30'!
itemsForAnyFile
	^ #(('copy name to clipboard' 'rename' 'delete' 'compress')
		()
		(copyName renameFile deleteFile compressFile)
		)! !

!FileList methodsFor: 'file list menu' stamp: 'di 5/13/2000 15:56'!
itemsForFileEnding: suffix
	| labels lines selectors |
	labels _ OrderedCollection new.
	lines _ OrderedCollection new.
	selectors _ OrderedCollection new.
	(suffix = 'bmp') | (suffix = 'gif') | (suffix = 'jpg') | (suffix =
'form') | (suffix = '*') | (suffix = 'png') ifTrue:
		[labels addAll: #('open image in a window' 'read image into ImageImports' 'open image as background').
		selectors addAll: #(openImageInWindow importImage openAsBackground)].
	(suffix = 'morph') | (suffix = 'morphs') | (suffix = 'sp') |
(suffix = '*') ifTrue:
		[labels add: 'load as morph'.
		selectors add: #openMorphFromFile.
		labels add: 'load as project'.
		selectors add: #openProjectFromFile].
	(suffix = 'extseg') | (suffix = 'project') | (suffix = 'pr') ifTrue:
		[labels add: 'load as project'.
		selectors add: #openProjectFromFile].
	(suffix = 'bo') | (suffix = '*') ifTrue:[
		labels add: 'load as book'.
		selectors add: #openBookFromFile].
	(suffix = 'mid') | (suffix = '*') ifTrue:
		[labels add: 'play midi file'.
		selectors add: #playMidiFile].
	(suffix = 'movie') | (suffix = '*') ifTrue:
		[labels add: 'open as movie'.
		selectors add: #openAsMovie].
	(suffix = 'st') | (suffix = 'cs') | (suffix = '*') ifTrue:
		[suffix = '*' ifTrue: [lines add: labels size].
		labels addAll: #('fileIn' 'file into new change set'
'browse changes' 'browse code' 'remove line feeds' 'broadcast as update').
		lines add: labels size - 1.
		selectors addAll: #(fileInSelection fileIntoNewChangeSet
browseChanges browseFile removeLinefeeds putUpdate)].
	(suffix = 'swf') | (suffix = '*') ifTrue:[
		labels add:'open as Flash'.
		selectors add: #openAsFlash].
	(suffix = 'ttf') | (suffix = '*') ifTrue:[
		labels add: 'open true type font'.
		selectors add: #openAsTTF].
	(suffix = 'gz') | (suffix = '*') ifTrue:[
		labels addAll: #('view decompressed' 'decompress to file').
		selectors addAll: #(viewGZipContents saveGZipContents)].
	(suffix = '3ds') | (suffix = '*') ifTrue:[
		labels add: 'Open 3DS file'.
		selectors add: #open3DSFile].
	(suffix = 'tape') | (suffix = '*') ifTrue:
		[labels add: 'open for playback'.
		selectors add: #openTapeFromFile].
	(suffix = 'wrl') | (suffix = '*') ifTrue:
		[labels add: 'open in Wonderland'.
		selectors add: #openVRMLFile].
	(suffix = 'htm') | (suffix = 'html') ifTrue:
		[labels add: 'open in browser'.
		selectors add: #openInBrowser].
	(suffix = '*') ifTrue:
		[labels addAll: #('generate HTML').
		lines add: labels size - 1.
		selectors addAll: #(renderFile)].
	^ Array with: labels with: lines with: selectors! !

!FileList methodsFor: 'file list menu' stamp: 'di 11/19/1998 14:25'!
itemsForNoFile
	^ #(
		('sort by name' 'sort by size' 'sort by date'
		'browse code files'
		'add new file' 'add new directory')
		(3 4)
		(sortByName sortBySize sortByDate
		browseFiles
		addNewFile addNewDirectory)
		)! !

!FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 09:34'!
noFileSelectedMenu: aMenu
	| items |
	items _ self itemsForNoFile.
	^ aMenu
		labels: items first
		lines: items second
		selections: items third
! !

!FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 16:05'!
offerAllFileOptions
	| items action |
	items _ self itemsForFileEnding: '*'.
	action _ (SelectionMenu labels: items first lines: items second selections: items third)
			startUp.
	action ifNotNil: [self perform: action]! !

!FileList methodsFor: 'file list menu' stamp: 'DSM 10/14/1999 15:17'!
open3DSFile
	"Open a MoviePlayerMorph on the given file (must be in .3ds format)."
	| scene |
	scene _ B3DScene from3DS: (ThreeDSParser parseFileNamed: self
fullName).
	Smalltalk isMorphic ifTrue:[
		(B3DPrimitiveEngine isAvailable) ifFalse:[
			(self confirm:'WARNING: YOU HAVE NO REAL SUPPORT
FOR 3D!!
Opening this guy in Morphic will EXTREMELY time consuming.
Are you sure you want to do this?!!
(NO is probably the right answer :-)') ifFalse:[^scene inspect]].
		scene defaultCamera moveToFit: scene.
		(B3DSceneMorph new scene: scene) openInWorld.
	] ifFalse:[scene inspect].! !

!FileList methodsFor: 'file list menu' stamp: 'jcg 5/1/2000 23:09'!
openAsBackground
	"Set an image as a background image.  Support Squeak's common file format 
	(GIF, JPG, PNG, 'Form stoteOn: (run coded)' and BMP)"

	(Form fromFileNamed: self fullName) setAsBackground! !

!FileList methodsFor: 'file list menu' stamp: 'ar 2/13/1999 21:25'!
openAsFlash
	"Open a MoviePlayerMorph on the given file (must be in .movie format)."
	| f player |
	Smalltalk at: #Morph ifAbsent: [^ self beep].
	f _ (directory readOnlyFileNamed: self fullName) binary.
	player _ (FlashMorphReader on: f) processFile.
	player startPlaying.
	player open.! !

!FileList methodsFor: 'file list menu' stamp: 'di 8/17/1998 17:31'!
openAsMovie
	"Open a MoviePlayerMorph on the given file (must be in .movie format)."
 
	Smalltalk at: #Morph ifAbsent: [^ self beep].
	(MoviePlayerMorph new openFileNamed: self fullName) openInWorld! !

!FileList methodsFor: 'file list menu' stamp: 'ar 11/14/1998 23:46'!
openAsTTF
	(TTFontReader parseFileNamed: self fullName) asMorph open! !

!FileList methodsFor: 'file list menu' stamp: 'mdr 8/31/2000 18:58'!
openBookFromFile
	"Reconstitute a Morph from the selected file, presumed to be represent
	a Morph saved via the SmartRefStream mechanism, and open it in an
	appropriate Morphic world"

	| book aFileStream |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].

	aFileStream _ directory readOnlyFileNamed: self fullName.
	book _ BookMorph new.
	book setProperty: #url toValue: aFileStream url.
	book fromRemoteStream: aFileStream.
	aFileStream close.

	Smalltalk isMorphic 
		ifTrue: [Display getCurrentMorphicWorld addMorphsAndModel: book]
		ifFalse:
			[book isMorph ifFalse: [^ self errorMustBeMorph].
			book openInWorld].
	book goToPage: 1! !

!FileList methodsFor: 'file list menu' stamp: 'RAA 6/2/2000 17:58'!
openImageInWindow
	"Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP.
	Fail if file format is not recognized."

	| image myStream |

	myStream _ (directory readOnlyFileNamed: fileName) binary.
	image _ Form fromBinaryStream: myStream.
	myStream close.

	Smalltalk isMorphic
		ifTrue: [(SketchMorph withForm: image) openInWorld]
		ifFalse: [FormView open: image named: fileName]! !

!FileList methodsFor: 'file list menu' stamp: 'sma 4/30/2000 11:32'!
openInBrowser
	Scamper openOnUrl: (directory url , fileName encodeForHTTP)! !

!FileList methodsFor: 'file list menu' stamp: 'mdr 8/31/2000 18:59'!
openMorphFromFile
	"Reconstitute a Morph from the selected file, presumed to be represent a Morph saved
	via the SmartRefStream mechanism, and open it in an appropriate Morphic world"

 	| aFileStream morphOrList |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].

	aFileStream _ directory readOnlyFileNamed: self fullName.
	morphOrList _ aFileStream fileInObjectAndCode.
	(morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList _ morphOrList contentsMorph].
	Smalltalk isMorphic
		ifTrue: [Display getCurrentMorphicWorld addMorphsAndModel: morphOrList]
		ifFalse:
			[morphOrList isMorph ifFalse: [^ self errorMustBeMorph].
			morphOrList openInWorld]! !

!FileList methodsFor: 'file list menu' stamp: 'RAA 10/15/2000 18:02'!
openProjectFromFile
	"Reconstitute a Morph from the selected file, presumed to be represent
	a Morph saved via the SmartRefStream mechanism, and open it in an
	appropriate Morphic world."

	fileName ifNil: [^self].
	Project canWeLoadAProjectNow ifFalse: [^ self].
	ProjectLoading 
		openFromDirectory: directory 
		andFileName: fileName
! !

!FileList methodsFor: 'file list menu' stamp: 'di 1/31/1999 11:05'!
openTapeFromFile
	"Open an eventRecorder tape for playback."
 
	(EventRecorderMorph new readTape: self fullName) rewind openInWorld! !

!FileList methodsFor: 'file list menu' stamp: 'ar 9/16/1999 14:48'!
openVRMLFile
	| scene |
	scene _ Wonderland new.
	scene makeActorFromVRML: self fullName.
! !

!FileList methodsFor: 'file list menu' stamp: 'di 5/20/1998 23:25'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	(#(get getHex browseChanges
sortByDate sortBySize sortByName
fileInSelection fileIntoNewChangeSet browseChanges copyName
openImageInWindow importImage playMidiFile
renameFile deleteFile addNewFile putUpdate) includes: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ super perform: selector orSendTo: otherTarget]! !

!FileList methodsFor: 'file list menu' stamp: 'mdr 8/31/2000 18:52'!
playMidiFile
	"Play a MIDI file."
 
	| f score |
	Smalltalk at: #MIDIFileReader ifPresent: [:midiReader |
		Smalltalk at: #ScorePlayerMorph ifPresent: [:scorePlayer |
			f _ (directory readOnlyFileNamed: self fullName) binary.
			score _ (midiReader new readMIDIFrom: f) asScore.
			f close.
			scorePlayer openOn: score title: fileName]].
! !

!FileList methodsFor: 'file list menu' stamp: 'tk 3/12/1999 18:07'!
putUpdate
	"Put this file out as an Update on the servers."
	| names choice |
	self canDiscardEdits ifFalse: [^ self changed: #flash].

	names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	(ServerDirectory groupNamed: choice) putUpdate: 
				(directory oldFileNamed: self fullName).
	self volumeListIndex: volListIndex.
! !

!FileList methodsFor: 'file list menu' stamp: 'ar 9/3/1999 13:05'!
removeLinefeeds
	"Remove any line feeds by converting to CRs instead"
	| fileContents |
	fileContents _ (CrLfFileStream readOnlyFileNamed: self fullName) contentsOfEntireFile.
	(StandardFileStream newFileNamed: self fullName) 
		nextPutAll: fileContents;
		close.! !

!FileList methodsFor: 'file list menu' stamp: 'sge 2/13/2000 04:36'!
renameFile
	"Rename the currently selected file"
	| newName response |
	listIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(response _ FillInTheBlank request: 'NewFileName?'
 					initialAnswer: fileName)
		isEmpty ifTrue: [^ self].
	newName _ response asFileName.
	newName = fileName ifTrue: [^ self].
	directory rename: fileName toBe: newName.
	self updateFileList.
	listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName].
	listIndex > 0 ifTrue: [fileName _ newName].
	self changed: #fileListIndex.
! !

!FileList methodsFor: 'file list menu' stamp: 'mjg 9/3/1998 17:24'!
renderFile
	"Render the currently selected file"
	| map action file renderedFile formatPage |
	listIndex = 0 ifTrue: [^ self].
	map _ URLmap new.
	action _ RenderedSwikiAction new.
	action name: '.'.  "For image references, refer to this directory"
	map action: action.
	map directory: directory.
	(directory fileExists: 'glossary')
	ifFalse: [Cursor wait showWhile: [
		(directory newFileNamed: 'glossary') close].].
	map readGlossary: (directory oldFileNamed: 'glossary').
	formatPage _ SwikiPage new.
	formatPage map: map.
	formatPage coreID: (fileName allButFirst).
	formatPage formatted: (HTMLformatter
		evalEmbedded: (directory oldFileNamed: fileName)
contentsOfEntireFile
		with: formatPage
		unlessContains: (Set new)).
	formatPage name isNil
		ifTrue: [self notify: 'You forgot to name the page!!
<?request name: ''myname''?>'.
				formatPage name: 'defaultName'.].
	map pages at: (formatPage name asLowercase) put: formatPage.
	formatPage formatted: (LessHTMLformatter swikify: (formatPage
formatted)
			linkhandler: [:link | map
					linkFor: link
					from: 'Nowhere'
					storingTo: OrderedCollection new]).
	"Make a template if one does not exist"
	(directory fileExists: 'template.html')
	ifFalse: [Cursor wait showWhile: [
		(directory newFileNamed: 'template.html') nextPutAll: (self
templateFile); close].].
	renderedFile _ (directory pathName),(ServerAction
pathSeparator),(formatPage coreID).
	(directory fileExists: renderedFile)
		ifTrue: [directory deleteFileNamed: renderedFile].
	file _ FileStream fileNamed: renderedFile.
	file nextPutAll: (HTMLformatter evalEmbedded:
		(directory oldFileNamed: 'template.html') contentsOfEntireFile
			with: formatPage).
	file close.
	FileDirectory default setMacFileNamed: renderedFile
		type: 'TEXT'
		creator: 'MOSS'.
	map writeGlossary. "Directory is already in the map, so write to
the glossary there"
	self updateFileList.
! !

!FileList methodsFor: 'file list menu' stamp: 'sma 5/20/2000 18:19'!
saveGZipContents
	"Save the contents of a gzipped file"
	| zipped buffer unzipped newName |
	newName _ fileName copyUpToLast: FileDirectory extensionDelimiter.
	unzipped _ directory newFileNamed: newName.
	zipped _ GZipReadStream on: (directory readOnlyFileNamed: self fullName).
	buffer _ String new: 50000.
	'Extracting ' , self fullName
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: zipped sourceStream size
		during: 
			[:bar | 
			[zipped atEnd]
				whileFalse: 
					[bar value: zipped sourceStream position.
					unzipped nextPutAll: (zipped nextInto: buffer)].
			zipped close.
			unzipped close].
	self updateFileList.
	^ newName! !

!FileList methodsFor: 'file list menu' stamp: 'di 4/15/98 12:36'!
sortByDate
	self resort: #date! !

!FileList methodsFor: 'file list menu' stamp: 'di 4/15/98 12:37'!
sortByName
	self resort: #name! !

!FileList methodsFor: 'file list menu' stamp: 'di 4/15/98 12:36'!
sortBySize
	self resort: #size! !

!FileList methodsFor: 'file list menu' stamp: 'tk 5/21/1998 12:39'!
spawn: code
	"Open a simple Edit window"
	listIndex = 0 ifTrue: [^ self].
	FileList openEditorOn: (directory readOnlyFileNamed: fileName)
				"read only just for initial look"
			editString: code! !

!FileList methodsFor: 'file list menu' stamp: 'mjg 9/1/1998 14:10'!
templateFile
	^'<head>
<title><?request name?></title>
</head>
<body>
<?request formatted?>
</body>
'
! !

!FileList methodsFor: 'file list menu' stamp: 'ar 1/2/2000 15:31'!
viewGZipContents
	"View the contents of a gzipped file"
	| f |
	f _ (directory readOnlyFileNamed: self fullName).
	contents _ f contentsOfEntireFile.
	Cursor wait showWhile:[contents _ (GZipReadStream on: contents) upToEnd].
	contents replaceAll: Character lf with: Character cr.
	(StringHolder new)
		contents: contents;
		openLabel:'Contents of ', fileName printString! !


!FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:05'!
addPath: aString
	"Add the given string to the list of recently visited directories."

	| full |
	aString ifNil: [^self].
	full := String streamContents: 
		[ :strm | 2 to: volList size do: 
			[ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed.
			strm nextPut: FileDirectory pathNameDelimiter]].
	full := full, aString.
"Remove and super-directories of aString from the collection."
	RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)].

"If a sub-directory is in the list, do nothing."
	(RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifNone: [nil])
		ifNotNil: [^self].

	[RecentDirs size >= 10]
		whileTrue: [RecentDirs removeFirst].
	RecentDirs addLast: full! !

!FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:26'!
contents
	"Answer the contents of the file, reading it first if needed."
	"Possible brevityState values:
		FileList,
		fullFile, briefFile, needToGetFull, needToGetBrief,
		fullHex, briefHex, needToGetFullHex, needToGetBriefHex"

	(listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents].  "no file selected"
	brevityState == #fullFile ifTrue: [^ contents].
	brevityState == #fullHex ifTrue: [^ contents].
	brevityState == #briefFile ifTrue: [^ contents].
	brevityState == #briefHex ifTrue: [^ contents].

	brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false].
	brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true].

	brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false].
	brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true].  "default"

	self halt: 'unknown state ' , brevityState printString! !

!FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:25'!
defaultContents
	contents _ list == nil
		ifTrue: [String new]
		ifFalse: [String streamContents:
					[:s | s nextPutAll: 'NO FILE SELECTED'; cr.
					s nextPutAll: '  -- Folder Summary --'; cr.
					list do: [:item | s nextPutAll: item; cr]]].
	brevityState _ #FileList.
	^ contents! !

!FileList methodsFor: 'private' stamp: 'sma 11/11/2000 17:00'!
entriesMatching: patternString
	"Answer a list of directory entries which match the patternString.
	The patternString may consist of multiple patterns separated by ';'.
	Each pattern can include a '*' or '#' as wildcards - see String>>match:"

	| entries patterns |
	entries _ directory entries.
	patterns _ patternString findTokens: ';'.
	(patterns anySatisfy: [:each | each = '*'])
		ifTrue: [^ entries].
	^ entries select: [:entry | 
		entry isDirectory or: [patterns anySatisfy: [:each | each match: entry first]]]! !

!FileList methodsFor: 'private' stamp: 'sma 4/30/2000 09:41'!
errorMustBeMorph
	self inform: 'Can only load a single morph
into an mvc project via this mechanism.'! !

!FileList methodsFor: 'private'!
fileNameFromFormattedItem: item
	"Extract fileName and folderString from a formatted fileList item string"
	| i |
	(i _ item indexOf: $( ifAbsent: [0]) = 0 ifTrue: [^ item withBlanksTrimmed].
	^ (item copyReplaceFrom: i to: (item findFirst: [:c | c = $)]) with: '') withBlanksTrimmed! !

!FileList methodsFor: 'private'!
folderString
	^ ' [...]'! !

!FileList methodsFor: 'private' stamp: 'jm 5/3/1998 18:29'!
fullName
	"Answer the full name for the currently selected file."

	^ directory fullNameFor: fileName
! !

!FileList methodsFor: 'private' stamp: 'sma 5/20/2000 18:29'!
getSuffix: aString
	| i |
	i _ aString findLast: [:each | $. = each].
	^ i = 0
		ifTrue: ['']
		ifFalse: [aString copyFrom: i + 1 to: aString size]! !

!FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:46'!
put: aText
	| ff type |
	brevityState == #fullFile ifTrue:
		[ff _ directory newFileNamed: self fullName.
		Cursor write showWhile: [ff nextPutAll: aText asString; close].
		fileName = ff localName 
			ifTrue: [contents _ aText asString]
			ifFalse: [self updateFileList].		"user renamed the file"
		^ true  "accepted"].

	listIndex = 0 ifTrue:
		[PopUpMenu notify: 'No fileName is selected'.
		^ false  "failed"].
	type _ 'These'.
	brevityState = #briefFile ifTrue: [type _ 'Abbreviated'].
	brevityState = #briefHex ifTrue: [type _ 'Abbreviated'].
	brevityState = #fullHex ifTrue: [type _ 'Hexadecimal'].
	brevityState = #FileList ifTrue: [type _ 'Directory'].
	PopUpMenu notify: type , ' contents cannot
meaningfully be saved at present.'.
	^ false  "failed"
! !

!FileList methodsFor: 'private' stamp: 'tk 3/23/2000 16:21'!
readContentsBrief: brevityFlag
	"Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist."
	| f fileSize first5000 |

	brevityFlag ifTrue: [
		(directory isKindOf: ServerDirectory) ifTrue: [^ self readServerBrief]].
	f _ directory oldFileOrNoneNamed: self fullName.
	f ifNil: [^ 'For some reason, this file cannot be read'].
	(brevityFlag not or: [(fileSize _ f size) <= 100000]) ifTrue:
		[contents _ f contentsOfEntireFile.
		brevityState _ #fullFile.   "don't change till actually read"
		^ contents].

	"if brevityFlag is true, don't display long files when first selected"
	first5000 _ f next: 5000.
	f close.
	contents _ 'File ''', fileName, ''' is ', fileSize printString, ' bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
', first5000 , '
------------------------------------------
... end of the first 5000 characters.'.
	brevityState _ #briefFile.   "don't change till actually read"
	^ contents.
! !

!FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:20'!
readContentsHex: brevity
	"retrieve the contents from the external file unless it is too long.
	  Don't create a file here.  Check if exists."
	| f size data hexData s |

	f _ directory oldFileOrNoneNamed: self fullName. 
	f == nil ifTrue: [^ 'For some reason, this file cannot be read'].
	((size _ f size)) > 5000 & brevity
		ifTrue: [data _ f next: 10000. f close. brevityState _ #briefHex]
		ifFalse: [data _ f contentsOfEntireFile. brevityState _ #fullHex].

	s _ WriteStream on: (String new: data size*4).
	0 to: data size-1 by: 16 do:
		[:loc | s nextPutAll: loc hex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space].
		s cr].
	hexData _ s contents.

	^ contents _ ((size > 5000) & brevity
		ifTrue: ['File ''', fileName, ''' is ', size printString, ' bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 5000 characters...
------------------------------------------
', hexData , '
------------------------------------------
... end of the first 5000 characters.']
		ifFalse: [hexData]).
! !

!FileList methodsFor: 'private' stamp: 'tk 3/24/2000 10:52'!
readServerBrief
	| lString sizeStr fsize ff first5000 parts |
	"If file on server is known to be long, just read the beginning.  Cheat badly by reading the fileList string."

	listIndex = 0 ifTrue: [^ self].
	"Get size from file list entry"
	lString _ list at: listIndex.
	parts _ lString findTokens: '()'.
	sortMode = #name ifTrue: [sizeStr _ (parts second findTokens: ' ') third].
	sortMode = #date ifTrue: [sizeStr _ (parts first findTokens: ' ') third].
	sortMode = #size ifTrue: [sizeStr _ (parts first findTokens: ' ') first].
	fsize _ (sizeStr copyWithout: $,) asNumber.

	fsize <= 50000 ifTrue:
		[ff _ directory oldFileOrNoneNamed: self fullName.
		ff ifNil: [^ 'For some reason, this file cannot be read'].
		contents _ ff contentsOfEntireFile.
		brevityState _ #fullFile.   "don't change till actually read"
		^ contents].

	"if brevityFlag is true, don't display long files when first selected"
	first5000 _ directory getOnly: 3500 from: fileName.
	contents _ 'File ''', fileName, ''' is ', sizeStr, ' bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 3500 characters...
------------------------------------------
', first5000 , '
------------------------------------------
... end of the first 3500 characters.'.
	brevityState _ #briefFile.   "don't change till actually read"
	^ contents.

! !

!FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:03'!
recentDirs
	"Put up a menu and let the user select from the list of recently visited directories."

	| dirName |
	RecentDirs isEmpty ifTrue: [^self].
	dirName := (SelectionMenu selections: RecentDirs) startUp.
	dirName == nil ifTrue: [^self].
	self directory: (FileDirectory on: dirName)! !

!FileList methodsFor: 'private' stamp: 'ls 9/11/1998 04:15'!
resort: newMode
	"Re-sort the list of files."
	| name |
	listIndex > 0
		ifTrue: [name _ self fileNameFromFormattedItem: (list at: listIndex)].
	sortMode _ newMode.
	self pattern: pattern.
	name ifNotNil: [
		fileName _ name.
		listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = name. ].
		self changed: #fileListIndex].
	listIndex = 0 ifTrue: [self changed: #contents]
! !

!FileList methodsFor: 'private' stamp: 'sma 11/11/2000 17:04'!
sortBlock
	"Answer block to decide what order to display the directory entries."

	^ [ :x :y |
			(x isDirectory = y isDirectory) 
				ifTrue: [  
					"sort by user-specified criterion"
					sortMode = #name 
						ifTrue: [(x name compare: y name) <= 2]
						ifFalse: [ sortMode = #date
							ifTrue: [ x modificationTime = y modificationTime
									ifTrue: [ (x name compare: y name) <= 2 ]
									ifFalse: [ x modificationTime > y modificationTime ] ]
							ifFalse: [ "size"
								x fileSize = y fileSize 
									ifTrue: [ (x name compare: y name) <= 2 ]
									ifFalse: [ x fileSize > y fileSize ] ] ] ]
				ifFalse: [
					"directories always precede files"
					x isDirectory ] ]! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'!
sortingByDate
	^ sortMode == #date! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:57'!
sortingByName
	^ sortMode == #name! !

!FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'!
sortingBySize
	^ sortMode == #size! !

!FileList methodsFor: 'private' stamp: 'sma 5/20/2000 18:31'!
uncompressedFileName
	| f |
	f _ self fullName.
	((f endsWith: '.gz') and: [self confirm: f , '
appears to be a compressed file.
Do you want to uncompress it?'])
		ifFalse: [^ f].
	^ self saveGZipContents! !

!FileList methodsFor: 'private' stamp: 'wod 5/27/1998 17:47'!
updateFileList
	"Update my files list with file names in the current directory that match the pattern."
	"wod 5/27/1998: nil out the fileName."
	Cursor execute showWhile:
		[list _ (pattern includes: $*) | (pattern includes: $#)
			ifTrue: [self listForPattern: pattern]
			ifFalse: [
				pattern isEmpty
					ifTrue: [self listForPattern: '*']
					ifFalse: [self listForPattern: '*', pattern, '*']].
		listIndex _ 0.
		volListIndex _ volList size.
		fileName _ nil.
		contents _ ''.
		self changed: #volumeListIndex.
		self changed: #fileList].
! !


!FileList methodsFor: 'menu messages' stamp: 'wod 5/13/1998 04:10'!
browseFile

	FileContentsBrowser browseFile: self fullName.! !

!FileList methodsFor: 'menu messages' stamp: 'wod 5/13/1998 04:10'!
browseFiles
	| selectionPattern fileList |
	selectionPattern := FillInTheBlank request:'What files?' initialAnswer: self pattern.
	fileList _ (directory fileNamesMatching: selectionPattern) 
		collect: [:each | directory fullNameFor: each].
	FileContentsBrowser browseFiles: fileList.
! !

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

FileList class
	instanceVariableNames: ''!

!FileList class methodsFor: 'instance creation' stamp: 'sw 1/25/2001 08:45'!
open
	"Open a view of an instance of me on the default directory."
	"FileList open"
	| dir aFileList topView volListView templateView fileListView fileContentsView underPane pHeight |
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	topView _ StandardSystemView new.
	topView
		model: aFileList;
		label: dir pathName;
		minimumSize: 200@200.
	topView borderWidth: 1.

	volListView _ PluggableListView on: aFileList
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListView autoDeselect: false.
	volListView window: (0@0 extent: 80@45).
	topView addSubView: volListView.

	templateView _ PluggableTextView on: aFileList
		text: #pattern
		accept: #pattern:.
	templateView askBeforeDiscardingEdits: false.
	templateView window: (0@0 extent: 80@15).
	topView addSubView: templateView below: volListView.

	aFileList wantsOptionalButtons
		ifTrue:
			[underPane _ aFileList optionalButtonView.
			underPane isNil
				ifTrue: [pHeight _ 60]
				ifFalse: [
					topView addSubView: underPane toRightOf: volListView.
					pHeight _ 60 - aFileList optionalButtonHeight]]
		ifFalse:
			[underPane _ nil.
			pHeight _ 60].

	fileListView _ PluggableListView on: aFileList
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.
	fileListView window: (0@0 extent: 120@pHeight).
	underPane isNil
		ifTrue: [topView addSubView: fileListView toRightOf: volListView]
		ifFalse: [topView addSubView: fileListView below: underPane].
	fileListView controller terminateDuringSelect: true.  "Pane to left may change under scrollbar"

	fileContentsView _ PluggableTextView on: aFileList
		text: #contents accept: #put:
		readSelection: #contentsSelection menu: #fileContentsMenu:shifted:.
	fileContentsView window: (0@0 extent: 200@140).
	topView addSubView: fileContentsView below: templateView.

	topView controller open! !

!FileList class methodsFor: 'instance creation' stamp: 'sw 1/24/2001 21:09'!
openAsMorph
	"Open a morphic view of a FileList on the default directory."
	| dir aFileList window fileListTop |
	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	window addMorph: ((PluggableListMorph on: aFileList list: #volumeList selected: #volumeListIndex
				changeSelected: #volumeListIndex: menu: #volumeMenu:) autoDeselect: false)
		frame: (0@0 corner: 0.3@0.2).
	window addMorph: (PluggableTextMorph on: aFileList text: #pattern accept: #pattern:)
		frame: (0@0.2 corner: 0.3@0.3).
	aFileList wantsOptionalButtons
		ifTrue:
			[window addMorph: aFileList optionalButtonRow frame: (0.3 @ 0 corner: 1 @ 0.08).
			fileListTop _ 0.08]
		ifFalse:
			[fileListTop _ 0].

	window addMorph: (PluggableListMorph on: aFileList list: #fileList selected: #fileListIndex
				changeSelected: #fileListIndex: menu: #fileListMenu:)
		frame: (0.3 @ fileListTop corner: 1@0.3).
	window addMorph: (PluggableTextMorph on: aFileList text: #contents accept: #put:
			readSelection: #contentsSelection menu: #fileContentsMenu:shifted:)
		frame: (0@0.3 corner: 1@1).
	^ window! !

!FileList class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:31'!
openEditorOn: aFileStream editString: editString
	"Open an editor on the given FileStream."
	| fileModel topView fileContentsView |
	Smalltalk isMorphic ifTrue: [^ (self openMorphOn: aFileStream editString: editString) openInWorld].

	fileModel _ FileList new setFileStream: aFileStream.	"closes the stream"
	topView _ StandardSystemView new.
	topView
		model: fileModel;
		label: aFileStream fullName;
		minimumSize: 180@120.
	topView borderWidth: 1.

	fileContentsView _ PluggableTextView on: fileModel 
		text: #contents accept: #put:
		readSelection: #contentsSelection menu: #fileContentsMenu:shifted:.
	fileContentsView window: (0@0 extent: 180@120).
	topView addSubView: fileContentsView.
	editString ifNotNil: [fileContentsView editString: editString.
			fileContentsView hasUnacceptedEdits: true].

	topView controller open.
! !

!FileList class methodsFor: 'instance creation' stamp: 'RAA 5/24/2000 19:26'!
openFileDirectly
	| aResult |

	(aResult _ StandardFileMenu oldFile) ifNotNil:
		[self openEditorOn: (aResult directory readOnlyFileNamed: aResult name) editString: nil]! !

!FileList class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:34'!
openMorphOn: aFileStream editString: editString 
	"Open a morphic view of a FileList on the given file."
	| fileModel window fileContentsView |

	fileModel _ FileList new setFileStream: aFileStream.	"closes the stream"
	window _ (SystemWindow labelled: aFileStream fullName) model: fileModel.

	window addMorph: (fileContentsView _ PluggableTextMorph on: fileModel 
			text: #contents accept: #put:
			readSelection: #contentsSelection 
			menu: #fileContentsMenu:shifted:)
		frame: (0@0 corner: 1@1).
	editString ifNotNil: [fileContentsView editString: editString.
			fileContentsView hasUnacceptedEdits: true].

	^ window! !


!FileList class methodsFor: 'class initialization' stamp: 'stp 12/11/1999 19:47'!
initialize
	"FileList initialize"

	RecentDirs := OrderedCollection new! !
FileList subclass: #FileList2
	instanceVariableNames: 'showDirsInFileList currentDirectorySelected fileSelectionBlock dirSelectionBlock optionalButtonSpecs modalView directoryChangeBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!FileList2 commentStamp: '<historical>' prior: 0!
Some variations on FileList that
- use a hierarchical pane to show folder structure
- use different pane combinations, button layouts and prefiltering for specific uses

FileList2 morphicView openInWorld				"an alternative to the standard FileList"
FileList2 morphicViewNoFile openInWorld			"useful for selecting, but not viewing"
FileList2 morphicViewProjectLoader openInWorld	"useful for finding and loading projects"
FileList2 morphicViewImageViewer openInWorld	"useful for finding and using images"
FileList2 modalFolderSelector						"allows the user to select a folder"



!
]style[(169 38 41 43 39 48 41 46 37 36 36 4)f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1!


!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/2000 12:10'!
cancelHit

	modalView delete.
	currentDirectorySelected _ nil.! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 23:01'!
defaultBackgroundColor

	^Color white! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 16:00'!
dirSelectionBlock: aBlock
	dirSelectionBlock _ aBlock! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 13:59'!
directory

	^directory! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 13:26'!
directory: dir
	"Set the path of the volume to be displayed."

	self okToChange ifFalse: [^ self].

	self modelSleep.
	directory _ dir.
	self modelWakeUp.

	sortMode == nil ifTrue: [sortMode _ #date].
	volList _ Array with: '[]'.
	directory ifNotNil: [
		volList _ volList, directory pathParts.  "Nesting suggestion from RvL"
	].
	volList _ volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
	self changed: #relabel.
	self changed: #volumeList.
	self pattern: pattern.
	directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 8/17/2000 13:22'!
directoryChangeBlock: aBlockOrNil

	directoryChangeBlock _ aBlockOrNil.! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 16:03'!
directoryNamesFor: fullString
	| entries |
	entries _ (FileDirectory on: fullString) directoryNames.
	dirSelectionBlock ifNotNil:[entries _ entries select: dirSelectionBlock].
	^entries! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 13:08'!
fileSelectionBlock: aBlock

	fileSelectionBlock _ aBlock! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:29'!
getSelectedDirectory

	^ currentDirectorySelected
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 7/13/2000 14:07'!
getSelectedFile

	directory ifNil: [^nil].
	fileName ifNil: [^nil].
	^ directory oldFileNamed: fileName
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 2/2/2001 08:30'!
initialDirectoryList

	| dir nameToShow |
	^ 
	((FileDirectory on: '') directoryNames collect: [ :each |
		FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self
	]),
	(
		ServerDirectory serverNames collect: [ :n | 
			dir _ ServerDirectory serverNamed: n.
			nameToShow _ n.
			(dir directoryWrapperClass with: dir name: nameToShow model: self)
				balloonText: dir realUrl
		]
	)
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 15:57'!
initialize

	showDirsInFileList _ false.
	fileSelectionBlock _ [ :entry :myPattern |
		entry isDirectory ifTrue: [
			showDirsInFileList
		] ifFalse: [
			myPattern = '*' or: [myPattern match: entry name]
		]
	] fixTemps.
	dirSelectionBlock _ [ :dirName | true].! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 10:40'!
labelString
	^ (directory ifNil: [^'[]']) pathName contractTo: 50! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'sma 11/11/2000 18:10'!
listForPattern: pat
	"Make the list be those file names which match the pattern."

	| sizePad newList |
	directory ifNil: [^#()].
	newList _ directory entries select: [:entry | fileSelectionBlock value: entry value: pat].
	newList _ newList asSortedCollection: self sortBlock.
	sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.
	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
	^ newList asArray! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/2000 12:06'!
modalView: aSystemWindowOrSuch

	modalView _ aSystemWindowOrSuch! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:31'!
morphicDirectoryTreePane

	^(SimpleHierarchicalListMorph 
		on: self
		list: #initialDirectoryList
		selected: #getSelectedDirectory
		changeSelected: #setSelectedDirectoryTo:
		menu: nil
		keystroke: nil) autoDeselect: false
		
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 10:53'!
morphicFileContentsPane

	^PluggableTextMorph 
		on: self 
		text: #contents 
		accept: #put:
		readSelection: #contentsSelection 
		menu: #fileContentsMenu:shifted:
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 10:54'!
morphicFileListPane

	^PluggableListMorph 
		on: self 
		list: #fileList 
		selected: #fileListIndex
		changeSelected: #fileListIndex: 
		menu: #fileListMenu:

! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 10:57'!
morphicPatternPane

	^PluggableTextMorph 
		on: self 
		text: #pattern 
		accept: #pattern:
		
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/2000 12:06'!
okHit

	modalView delete.! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 7/14/2000 14:32'!
okHitForProjectLoader

	| areaOfProgress |
	areaOfProgress _ modalView firstSubmorph.
	[
		areaOfProgress setProperty: #deleteOnProgressCompletion toValue: modalView.
		self openProjectFromFile.
		modalView delete.	"probably won't get here"
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: areaOfProgress].


! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 13:00'!
optionalButtonSpecs

	^optionalButtonSpecs ifNil: [super optionalButtonSpecs]! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 13:01'!
optionalButtonSpecs: anArray

	optionalButtonSpecs _ anArray! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 10:48'!
postOpen

	directory ifNotNil: [
		self changed: #(openPath) , directory pathParts. 
	].
! !

!FileList2 methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'!
setSelectedDirectoryTo: aFileDirectoryWrapper

	currentDirectorySelected _ aFileDirectoryWrapper.
	self directory: aFileDirectoryWrapper withoutListWrapper.
	brevityState := #FileList.
	"self addPath: path."
	self changed: #fileList.
	self changed: #contents.
	self changed: #getSelectedDirectory.! !

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

FileList2 class
	instanceVariableNames: ''!

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'ar 10/10/2000 15:59'!
hideSqueakletDirectoryBlock
	^[:dirName| (dirName sameAs: 'Squeaklets') not]! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 13:10'!
new

	^super new initialize! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:40'!
projectOnlySelectionBlock

	^[ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]
		]
	] fixTemps! !

!FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/2000 19:13'!
selectionBlockForSuffixes: anArray

	^[ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			anArray anySatisfy: [ :each | each match: entry name]
		]
	] fixTemps! !


!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 11/14/2000 11:05'!
blueButtonText: aString textColor: textColor inWindow: window

	^(window fancyText: aString ofSize: 15 color: textColor)
		setProperty: #buttonText toValue: aString;
		hResizing: #rigid;
		extent: 100@20;
		layoutInset: 4;
		borderWidth: 0;
		useRoundedCorners
! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/23/2000 16:36'!
blueRamp1

	^{
		0.0->(Color r: 0.516 g: 0.645 b: 1.0).
		1.0->(Color r: 0.742 g: 0.871 b: 1.0)
	}! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/23/2000 16:38'!
blueRamp2

	^{
		0.0->(Color r: 0.516 g: 0.645 b: 1.0).
		1.0->(TranslucentColor r: 0.645 g: 0.968 b: 1.0 alpha: 0.56078431372549)
	}! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/23/2000 16:37'!
blueRamp3

	^{
		0.0->(Color r: 0.742 g: 0.871 b: 1.0).
		1.0->(Color r: 0.516 g: 0.645 b: 1.0).
	}! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 8/17/2000 13:53'!
enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory

	| foundSuffixes fileSuffixes firstEnabled enableIt |

	firstEnabled _ nil.
	foundSuffixes _ aDirectory fileNames collect: [ :each | (each findTokens: '.') last asLowercase].
	foundSuffixes _ foundSuffixes asSet.
	fileTypeInfo with: typeButtons do: [ :info :button |
		fileSuffixes _ info second.
		enableIt _ fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt].
		button 
			setProperty: #enabled 
			toValue: enableIt.
		enableIt ifTrue: [firstEnabled ifNil: [firstEnabled _ button]].
	].
	firstEnabled ifNotNil: [^firstEnabled mouseUp: nil].
	typeButtons do: [ :each | each color: Color gray].

! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/24/2000 19:08'!
endingSpecs

	^#(
		('Art' ('bmp' 'gif' 'jpg' 'form' 'png')
			(('open image in a window' openImageInWindow 'View')
			('read image into ImageImports' importImage 'Import')
			('open image as background' openAsBackground 'World'))
		)

		('Morphs' ('morph' 'morphs' 'sp')
			(('load as morph' openMorphFromFile 'Morph')
			('load as project' openProjectFromFile 'Project'))
		)

		('Projects' ('extseg' 'project' 'pr') (('load as project' openProjectFromFile 'Load')))

		('Books' ('bo') (('load as book' openBookFromFile 'Open')))

		('Music' ('mid') (('play midi file' playMidiFile 'Play')))

		('Movies' ('movie') (('open as movie' openAsMovie 'Open')))

		"('Code' ('st' 'cs')
			(('fileIn' fileInSelection)
			('file into new change set' fileIntoNewChangeSet)
			('browse changes' browseChanges)
			('browse code' browseFile)
			('remove line feeds' removeLinefeeds)
			('broadcast as update' putUpdate))
		)"

		('Flash' ('swf') (('open as Flash' openAsFlash 'Open')))

		('TrueType' ('ttf') (('open true type font' openAsTTF 'Open')))

		('3ds' ('3ds') (('Open 3DS file' open3DSFile' Open')))

		('Tape' ('tape') (('open for playback' openTapeFromFile 'Open')))

		('Wonderland' ('wrl') (('open in Wonderland' openVRMLFile 'Open')))

		('HTML' ('htm' 'html') (('open in browser' openInBrowser 'Open')))

	)! !

!FileList2 class methodsFor: 'blue ui' stamp: 'ar 11/9/2000 22:46'!
morphicViewGeneralLoaderInWorld: aWorld
"
FileList2 morphicViewGeneralLoaderInWorld: self currentWorld
"
	| window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow |

	fileTypeInfo _ self endingSpecs.
	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList 
		fileSelectionBlock: self projectOnlySelectionBlock;
		modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.

	fileTypeButtons _ fileTypeInfo collect: [ :each |
		(self blueButtonText: each first textColor: Color gray inWindow: window)
			setProperty: #enabled toValue: true;
			hResizing: #shrinkWrap
	].
	buttons _ #('OK' 'Cancel') collect: [ :each |
		self blueButtonText: each textColor: textColor1 inWindow: window
	].
	treePane _ aFileList morphicDirectoryTreePane 
		extent: 250@300; 
		retractable: false;
		borderWidth: 0.
	fileListPane _ aFileList morphicFileListPane 
		extent: 350@300; 
		retractable: false;
		borderWidth: 0.
	window addARow: {window fancyText: 'Find...' ofSize: 21 color: textColor1}.
	fileTypeRow _ window addARowCentered: fileTypeButtons.
	actionRow _ window addARowCentered: {
		buttons first. 
		(Morph new extent: 30@5) color: Color transparent. 
		buttons second
	}.
	window
		addARow: {
			(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
			(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	fileTypeButtons do: [ :each | 
		each 
			on: #mouseUp 
			send: #value:value: 
			to: [ :evt :morph | 
				self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph.
			] fixTemps
	].
	buttons first on: #mouseUp send: #okHit to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	aFileList directoryChangeBlock: [ :newDir |
		self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir
	] fixTemps.
	aFileList directory: aFileList directory.
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'RAA 7/15/2000 19:21'!
morphicViewProjectLoader2InWorld: aWorld

	^self morphicViewProjectLoader2InWorld: aWorld reallyLoad: true! !

!FileList2 class methodsFor: 'blue ui' stamp: 'ar 11/9/2000 22:46'!
morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean

	| window aFileList buttons treePane textColor1 fileListPane pane2a pane2b |

	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList 
		optionalButtonSpecs: self specsForProjectLoader;
		fileSelectionBlock: self projectOnlySelectionBlock;
		"dirSelectionBlock: self hideSqueakletDirectoryBlock;"
		modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttons _ #('OK' 'Cancel') collect: [ :each |
		self blueButtonText: each textColor: textColor1 inWindow: window
	].
	treePane _ aFileList morphicDirectoryTreePane 
		extent: 250@300; 
		retractable: false;
		borderWidth: 0.
	fileListPane _ aFileList morphicFileListPane 
		extent: 350@300; 
		retractable: false;
		borderWidth: 0.
	window
		addARow: {
			window fancyText: 'Load A Project' ofSize: 21 color: textColor1
		};
		addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second
		};
		addARow: {
			window fancyText: 'Please select a project' ofSize: 21 color: Color blue
		};
		addARow: {
			(window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
			(window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) 
				useRoundedCorners; layoutInset: 6}) layoutInset: 10.
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	buttons first 
		on: #mouseUp 
		send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit])
		to: aFileList.
	buttons second on: #mouseUp send: #cancelHit to: aFileList.
	aFileList postOpen.
	window position: aWorld topLeft + (aWorld extent - window extent // 2).
	^ window openInWorld: aWorld.! !

!FileList2 class methodsFor: 'blue ui' stamp: 'ar 11/9/2000 22:46'!
morphicViewProjectSaverFor: aProject
"
(FileList2 morphicViewProjectSaverFor: Project current) openInWorld
"
	| window aFileList buttons treePane pane2 textColor1 |

	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	aFileList _ self new directory: FileDirectory default.
	aFileList dirSelectionBlock: self hideSqueakletDirectoryBlock.
	window _ AlignmentMorphBob1 newColumn.
	window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	aFileList modalView: window.
	window
		setProperty: #FileList toValue: aFileList;
		wrapCentering: #center; cellPositioning: #topCenter;
		borderWidth: 4;
		borderColor: (Color r: 0.355 g: 0.516 b: 1.0);
		useRoundedCorners.
	buttons _ #( ('OK' okHit) ('Cancel' cancelHit) ) collect: [ :each |
		(self blueButtonText: each first textColor: textColor1 inWindow: window)
			on: #mouseUp send: each second to: aFileList
	].
	treePane _ aFileList morphicDirectoryTreePane 
		extent: 350@300; 
		retractable: false;
		borderWidth: 0.
	window
		addARowCentered: {
			window fancyText: 'Publish This Project' ofSize: 21 color: textColor1
		};
		addARowCentered: {
			buttons first. 
			(Morph new extent: 30@5) color: Color transparent. 
			buttons second
		};
		addARowCentered: { (window inAColumn: {(ProjectViewMorph on: aProject) lock}) layoutInset: 4};
		addARowCentered: {
			window fancyText: 'Please select a folder' ofSize: 21 color: Color blue
		};
		addARow: {
			(
				window inAColumn: {
					(pane2 _ window inARow: {window inAColumn: {treePane}}) 
						useRoundedCorners; layoutInset: 6
				}
			) layoutInset: 10
		}.
	window fullBounds.
	window fillWithRamp: self blueRamp1 oriented: 0.65.
	pane2 fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35).
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	window setProperty: #morphicLayerNumber toValue: 11.
	aFileList postOpen.
	^ window ! !


!FileList2 class methodsFor: 'button specs' stamp: 'RAA 6/21/2000 12:03'!
specsForFolderSelector
	^ #(	
('OK' 			okHit				sortingByName	'use the currently selected directory')
('Cancel'		cancelHit			sortingByDate	'cancel this request')
	)
! !

!FileList2 class methodsFor: 'button specs' stamp: 'RAA 6/17/2000 18:47'!
specsForImageViewer
	^ #(	
('Name' 		sortByName				sortingByName	'sort entries by name')
('Date'			sortByDate				sortingByDate	'sort entries by date')
('Size'			sortBySize				sortingBySize	'sort entries by size')
('View'			openImageInWindow		none			'open image in a window')
('Import'		importImage				none			'read image into ImageImports')
('Bgnd'			openAsBackground		none			'open image as background')
	)

! !

!FileList2 class methodsFor: 'button specs' stamp: 'RAA 6/16/2000 13:03'!
specsForProjectLoader
	^ #(	
('Name' 		sortByName				sortingByName	'sort entries by name')
('Date'			sortByDate				sortingByDate	'sort entries by date')
('Size'			sortBySize				sortingBySize	'sort entries by size')
('Load'			openProjectFromFile		none			'load the selected project')
	)
! !


!FileList2 class methodsFor: 'modal dialogs' stamp: 'RAA 6/23/2000 16:30'!
modalFolderSelector

	| window fileModel |
	window _ self morphicViewFolderSelector.
	fileModel _ window model.
	window openInWorld: self currentWorld extent: 300@400.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'RAA 6/30/2000 11:01'!
modalFolderSelectorForProject: aProject
"
FileList2 modalFolderSelectorForProject: Project current
"
	| window fileModel w |

	window _ FileList2 morphicViewProjectSaverFor: aProject.
	fileModel _ window valueOfProperty: #FileList.
	w _ self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	window openInWorld: w.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !

!FileList2 class methodsFor: 'modal dialogs' stamp: 'RAA 7/15/2000 19:22'!
modalFolderSelectorForProjectLoad

	| window fileModel w |

	window _ self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false.
	fileModel _ window valueOfProperty: #FileList.
	w _ self currentWorld.
	window position: w topLeft + (w extent - window extent // 2).
	window openInWorld: w.
	[window world notNil] whileTrue: [
		window outermostWorldMorph doOneCycleNow.
	].
	^fileModel getSelectedDirectory withoutListWrapper! !


!FileList2 class methodsFor: 'utility' stamp: 'RAA 1/8/2001 21:23'!
addFullPanesTo: window from: aCollection

	| frame |

	aCollection do: [ :each |
		frame _ LayoutFrame 
			fractions: each second 
			offsets: each third.
		window addMorph: each first fullFrame: frame.
	]! !

!FileList2 class methodsFor: 'utility' stamp: 'RAA 6/17/2000 18:35'!
addPanesTo: window from: aCollection

	aCollection do: [ :each |
		window addMorph: each first frame: each second.
	]! !

!FileList2 class methodsFor: 'utility' stamp: 'ar 11/9/2000 21:26'!
textRow: aString 

	^AlignmentMorph newRow 
		wrapCentering: #center; cellPositioning: #leftCenter;
		layoutInset: 0;
		addMorph: (
			AlignmentMorph newColumn
			wrapCentering: #center; cellPositioning: #topCenter;
			color: Color transparent;
			vResizing: #shrinkWrap;
			layoutInset: 0;
			addMorph: (
				AlignmentMorph newRow
				wrapCentering: #center; cellPositioning: #leftCenter;
				color: Color transparent;
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap;
				layoutInset: 0;
				addMorph: ((StringMorph contents: aString) color: Color blue; lock)
			)
		)! !


!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:29'!
morphicView

	| dir aFileList window fileListBottom midLine fileListTopOffset |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fileListTopOffset _ 25.
	fileListBottom _ 0.4.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fileListTopOffset}.
		{aFileList optionalButtonRow. 0.3 @ 0 corner: 1 @ 0. 0@0 corner: 0@fileListTopOffset}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@fileListBottom. 
					0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@fileListBottom. 
					0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileContentsPane. 0@fileListBottom corner: 1@1. nil}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:34'!
morphicViewFolderSelector

	| dir aFileList window fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: self specsForFolderSelector.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.
	aFileList modalView: window.

	fixedSize _ 25.
	self addFullPanesTo: window from: {
		{self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0. 
				0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 
				0@fixedSize corner: 0@(fixedSize * 2)}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: 1@1.
				0@(fixedSize * 2) corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:36'!
morphicViewImageViewer

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: self specsForImageViewer.
	aFileList fileSelectionBlock: [ :entry :myPattern |
		entry isDirectory ifTrue: [
			false
		] ifFalse: [
			#('bmp' 'gif' 'jpg' 'form' suffix = 'png') includes: 
					(aFileList getSuffix: entry name asLowercase)
		]
	] fixTemps.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0.
				0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1.
				0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1.
				0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:39'!
morphicViewNoFile

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0.3 @ 0 corner: 1@0. 0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 1/8/2001 21:39'!
morphicViewProjectLoader

	| dir aFileList window midLine fixedSize |

	dir _ FileDirectory default.
	aFileList _ self new directory: dir.
	aFileList optionalButtonSpecs: self specsForProjectLoader.
	aFileList fileSelectionBlock: self projectOnlySelectionBlock.
	window _ (SystemWindow labelled: dir pathName) model: aFileList.

	fixedSize _ 25.
	midLine _ 0.4.
	self addFullPanesTo: window from: {
		{aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
	}.
	aFileList postOpen.
	^ window ! !

!FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 11/14/2000 11:05'!
update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph

	| fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString |

	(morph valueOfProperty: #enabled) ifFalse: [^self].
	fileTypeRow submorphsDo: [ :sub |
		sub color: (
			sub == morph 
				ifTrue: [Color white] 
				ifFalse: [(sub valueOfProperty: #enabled) 
							ifTrue: [Color transparent] ifFalse: [Color gray]]
		).
	].
	fileTypeString _ morph valueOfProperty: #buttonText.

	aFileList _ window valueOfProperty: #FileList.
	textColor1 _ Color r: 0.742 g: 0.839 b: 1.0.
	actionRow removeAllMorphs.
	fileTypeInfo _ self endingSpecs.
	info2 _ fileTypeInfo detect: [ :each | each first = fileTypeString] ifNone: [self halt].
	fileSuffixes _ info2 second.
	fileActions _ info2 third.
	buttons _ fileActions, #(('Cancel this search' cancelHit 'Cancel')) collect: [ :each |
		(self blueButtonText: each third textColor: textColor1 inWindow: window)
			setBalloonText: each first;
			on: #mouseUp send: each second to: aFileList.
	].
	buttons do: [ :each | actionRow addMorphBack: each].
	window fullBounds.
	buttons do: [ :each |
		each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0).
	].
	aFileList fileSelectionBlock: (
		self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each])
	).
	aFileList updateFileList.

! !
Object subclass: #FilePackage
	instanceVariableNames: 'fullName sourceSystem classes doIts classOrder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!FilePackage methodsFor: 'accessing'!
classAt: className
	^self classes at: className! !

!FilePackage methodsFor: 'accessing'!
classes
	^classes! !

!FilePackage methodsFor: 'accessing' stamp: 'pnm
8/23/2000 17:10'!
fullName: aString
	fullName := aString! !

!FilePackage methodsFor: 'accessing'!
fullPackageName
	^fullName! !

!FilePackage methodsFor: 'accessing'!
packageInfo
	^String streamContents:[:s|
		s nextPutAll:'Package: '.
		s nextPutAll: self fullPackageName; cr; cr.
		sourceSystem isEmpty ifFalse:[
			s nextPutAll: sourceSystem; cr; cr].
		doIts isEmpty ifFalse:[
			s nextPutAll:'Unresolvable doIts:'; cr; cr.
			doIts do:[:chgRec|
				s nextPut:$!!; nextPutAll: chgRec string; nextPut: $!!; cr]]].! !

!FilePackage methodsFor: 'accessing' stamp: 'pnm
8/23/2000 17:12'!
packageName
	^FileDirectory localNameFor: self fullPackageName! !

!FilePackage methodsFor: 'accessing'!
removeClass: aPseudoClass
	(self classes removeKey: aPseudoClass name).
	classOrder copy do:[:cls|
		cls name = aPseudoClass name ifTrue:[ classOrder remove: cls].
	].! !

!FilePackage methodsFor: 'accessing'!
renameClass: aPseudoClass to: newName
	| oldName |
	oldName := aPseudoClass name.
	self classes removeKey: oldName.
	self classes at: newName put: aPseudoClass.
	aPseudoClass renameTo: newName.! !


!FilePackage methodsFor: 'initialize' stamp: 'pnm
8/23/2000 17:13'!
fromFileNamed: aName
	| stream |
	fullName := aName.
	stream := FileStream readOnlyFileNamed: aName.
	self fileInFrom: stream.! !

!FilePackage methodsFor: 'initialize' stamp: 'pnm
8/23/2000 14:48'!
initialize
	classes := Dictionary new.
	classOrder := OrderedCollection new.
	sourceSystem := ''.
	doIts := OrderedCollection new.! !


!FilePackage methodsFor: 'private'!
classDefinition: string with: chgRec
	| tokens theClass |
	tokens := Scanner new scanTokens: string.
	tokens size = 11 ifFalse:[^doIts add: chgRec].
	theClass := self getClass: (tokens at: 3).
	theClass definition: string.
	classOrder add: theClass.! !

!FilePackage methodsFor: 'private'!
getClass: className
	| pseudoClass |
	(classes includesKey: className) ifTrue:[
		^classes at: className.
	].
	pseudoClass := PseudoClass new.
	pseudoClass name: className.
	classes at: className put: pseudoClass.
	^pseudoClass.! !

!FilePackage methodsFor: 'private'!
metaClassDefinition: string with: chgRec
	| tokens theClass |
	tokens := Scanner new scanTokens: string.
	theClass := self getClass: (tokens at: 1).
	theClass metaClass definition: string.
	classOrder add: theClass metaClass.! !

!FilePackage methodsFor: 'private'!
msgClassComment: string with: chgRec
	| tokens theClass |
	tokens := Scanner new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 3) class == String]) ifTrue:[
		theClass := self getClass: tokens first.
		^theClass commentString: tokens last].
	(tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) class == String]]) ifTrue:[
		theClass := self getClass: tokens first.
		theClass metaClass commentString: tokens last].
! !

!FilePackage methodsFor: 'private'!
possibleSystemSource: chgRec
	| tokens |
	sourceSystem isEmpty ifTrue:[
		tokens := Scanner new scanTokens: chgRec string.
		(tokens size = 1 and:[tokens first class == String]) ifTrue:[
			sourceSystem := tokens first.
			^self]].
	doIts add: chgRec.! !

!FilePackage methodsFor: 'private'!
removedMethod: string with: chgRec
	| class tokens |
	tokens := Scanner new scanTokens: string.
	(tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class removeSelector: (tokens at: 3).
	].
	(tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[
		class := self getClass: (tokens at: 1).
		^class metaClass removeSelector: (tokens at: 4).
	].
	doIts add: chgRec! !

!FilePackage methodsFor: 'private'!
sampleMethod
"	In an existing method there are always a number of changes.
	Other stuff
		will be deleted
	Or even better,
		some things may be just modified.
"! !


!FilePackage methodsFor: 'change record types'!
classComment: chgRec

	(self getClass: chgRec methodClassName) classComment: chgRec! !

!FilePackage methodsFor: 'change record types'!
doIt: chgRec
	| string |
	string := chgRec string.
	('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*'
		match: string) ifTrue:[^self classDefinition: string with: chgRec].
	('* class*instanceVariableNames:*'
		match: string) ifTrue:[^self metaClassDefinition: string with: chgRec].
	('* removeSelector: *'
		match: string) ifTrue:[^self removedMethod: string with: chgRec].
	('* comment:*'
		match: string) ifTrue:[^self msgClassComment: string with: chgRec].
	('* initialize'
		match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize"
	('''From *'
		match: string) ifTrue:[^self possibleSystemSource: chgRec].
	doIts add: chgRec.! !

!FilePackage methodsFor: 'change record types'!
method: chgRec
	(self getClass: chgRec methodClassName) methodChange: chgRec! !

!FilePackage methodsFor: 'change record types'!
preamble: chgRec
	self doIt: chgRec! !


!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:57'!
askForDoits
	| menu choice choices |
	choices := #('do not process' 'at the beginning' 'at the end' 'cancel').
	menu _ SelectionMenu selections: choices.
	choice := nil.
	[choices includes: choice] whileFalse: [
		choice _ menu startUpWithCaption: 
'The package contains unprocessed doIts.
When would like to process those?'].
	^choices indexOf: choice! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 16:00'!
fileIn
	| doitsMark |
	doitsMark := 1.
	doIts isEmpty ifFalse:[doitsMark := self askForDoits].
	doitsMark = 4 ifTrue: [^nil].
	doitsMark = 2 ifTrue:[self fileInDoits].
	classOrder do:[:cls|
		cls fileInDefinition.
	].
	classes do:[:cls|
		Transcript cr; show:'Filing in ', cls name.
		cls fileInMethods.
		cls hasMetaclass ifTrue:[cls metaClass fileInMethods].
	].
	doitsMark = 3 ifTrue:[self fileInDoits].! !

!FilePackage methodsFor: 'fileIn/fileOut'!
fileInDoits
	doIts do:[:chgRec| chgRec fileIn].! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'tk 1/8/1999 08:00'!
fileOut
	| fileName stream |
	fileName := FillInTheBlank request: 'Enter the file name' initialAnswer:''.
	stream := FileStream newFileNamed: fileName.
	sourceSystem isEmpty ifFalse:[
		stream nextChunkPut: sourceSystem printString;cr ].
	self fileOutOn: stream.
	stream cr; cr.
	self classes do:[:cls|
		cls needsInitialize ifTrue:[
			stream cr; nextChunkPut: cls name,' initialize']].
	stream cr.
	stream close.

	DeepCopier new checkVariables.
! !

!FilePackage methodsFor: 'fileIn/fileOut'!
fileOutDoits: aStream
	doIts do:[:chgRec| chgRec fileOutOn: aStream].! !

!FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:59'!
fileOutOn: aStream
	| doitsMark |
	doitsMark := 1.
	doIts isEmpty ifFalse:[doitsMark := self askForDoits].
	doitsMark = 4 ifTrue: [^nil].
	doitsMark = 2 ifTrue:[self fileOutDoits: aStream].
	classOrder do:[:cls|
		cls fileOutDefinitionOn: aStream.
	].
	classes do:[:cls|
		cls fileOutMethodsOn: aStream.
		cls hasMetaclass ifTrue:[cls metaClass fileOutMethodsOn: aStream].
	].
	doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! !


!FilePackage methodsFor: 'reading' stamp: 'pnm
8/23/2000 17:24'!
fileInFrom: aStream
	| chgRec changes |
	changes := (ChangeList new scanFile: aStream from: 0
to: aStream size) changeList.
	aStream close.
	('Processing ', self packageName) 
		displayProgressAt: Sensor cursorPoint
		from: 1
		to: changes size
		during:[:bar|
			1 to: changes size do:[:i|
				bar value: i.
				chgRec := changes at: i.
				self perform: (chgRec type copyWith: $:) asSymbol
with: chgRec.
			].
		].! !

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

FilePackage class
	instanceVariableNames: ''!

!FilePackage class methodsFor: 'instance creation'!
fromFileNamed: aName
	^self new fromFileNamed: aName! !

!FilePackage class methodsFor: 'instance creation' stamp: 'pnm 8/23/2000 17:16'!
new
	^super new initialize! !
InterpreterPlugin subclass: #FilePlugin
	instanceVariableNames: ''
	classVariableNames: 'DirBadPath DirEntryFound DirNoMoreEntries '
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!FilePlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:53'!
initialiseModule
	self export: true.
	^self cCode: 'sqFileInit()' inSmalltalk:[true]! !

!FilePlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:54'!
shutdownModule
	self export: true.
	^self cCode: 'sqFileShutdown()' inSmalltalk:[true]! !


!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/12/2000 01:24'!
fileRecordSize
	"Return the size of a Smalltalk file record in bytes."
	self static: false.
	^ self cCode: 'sizeof(SQFile)'.! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/12/2000 01:24'!
fileValueOf: objectPointer
	"Return a pointer to the first byte of of the file record within the given Smalltalk object, or nil if objectPointer is not a file record."
	self returnTypeC: 'SQFile *'.
	self static: false.
	(((interpreterProxy isBytes: objectPointer) and:
		 [(interpreterProxy byteSizeOf: objectPointer) = self fileRecordSize]))
			ifFalse:[interpreterProxy primitiveFail. ^nil].
	^interpreterProxy firstIndexableField: objectPointer! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:17'!
primitiveFileAtEnd

	| file atEnd |
	self export: true.
	self var: 'file' declareC: 'SQFile *file'.
	file _ self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse:[atEnd _ self sqFileAtEnd: file ].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2.  "rcvr, file"
		interpreterProxy pushBool: atEnd.
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:17'!
primitiveFileClose

	| file |
	self export: true.
	self var: 'file' declareC: 'SQFile *file'.
	file _ self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse: [ self sqFileClose: file ].
	interpreterProxy failed ifFalse: [ interpreterProxy pop: 1  "pop file; leave rcvr on stack" ].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:32'!
primitiveFileDelete

	| namePointer nameIndex nameSize |
	self var: 'nameIndex' type: 'char *'.
	self export: true.
	namePointer _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: namePointer) 
		ifFalse:[^interpreterProxy primitiveFail].
	nameIndex _ interpreterProxy firstIndexableField: namePointer.
	nameSize _ interpreterProxy byteSizeOf: namePointer.
	self sqFileDeleteName: (self cCoerce: nameIndex to: 'int') Size: nameSize.
	interpreterProxy failed 
		ifFalse:[interpreterProxy pop: 1. "pop name, leave rcvr on stack" ].
! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:17'!
primitiveFileGetPosition
	| file position |
	self var: 'file' declareC: 'SQFile *file'.
	self export: true.
	file _ self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse: [position _ self sqFileGetPosition: file].
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 2.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: position)].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:33'!
primitiveFileOpen

	| writeFlag namePointer filePointer file nameIndex nameSize |
	self var: 'file' declareC: 'SQFile *file'.
	self var: 'nameIndex' type:'char *'.
	self export: true.
	writeFlag _ interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
	namePointer _ interpreterProxy stackValue: 1.
	(interpreterProxy isBytes: namePointer) 
		ifFalse:[^interpreterProxy primitiveFail].
	filePointer _ interpreterProxy 
					instantiateClass: (interpreterProxy classByteArray)
					indexableSize: self fileRecordSize.
	file _ self fileValueOf: filePointer.
	nameIndex _ interpreterProxy firstIndexableField: namePointer.
	nameSize _ interpreterProxy byteSizeOf: namePointer.
	interpreterProxy failed ifFalse:[
		self cCode: 'sqFileOpen(file, (int)nameIndex, nameSize, writeFlag)'.
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3.  "rcvr, name, writeFlag"
		interpreterProxy push: filePointer.
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:33'!
primitiveFileRead

	| count startIndex array file byteSize arrayIndex bytesRead |
	self var: 'file' declareC: 'SQFile *file'.
	self var: 'arrayIndex' type:'char *'.
	self export: true.
	count		_ interpreterProxy stackIntegerValue: 0.
	startIndex	_ interpreterProxy stackIntegerValue: 1.
	array		_ interpreterProxy stackValue: 2.
	file			_ self fileValueOf: (interpreterProxy stackValue: 3).

	"buffer can be any indexable words or bytes object except CompiledMethod"
	(interpreterProxy isWordsOrBytes: array) 
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: array)
		ifTrue: [ byteSize _ 4 ]
		ifFalse: [ byteSize _ 1 ].
	((startIndex >= 1) and:
		[(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)])
			ifFalse:[^interpreterProxy primitiveFail].

	arrayIndex _ interpreterProxy firstIndexableField: array.
	"Note: adjust startIndex for zero-origin indexing"
	bytesRead _ self sqFile: file Read: (count * byteSize)
					 Into: (self cCoerce: arrayIndex to: 'int')
					   At: ((startIndex - 1) * byteSize).
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 5.  "pop rcvr, file, array, startIndex, count"
		interpreterProxy pushInteger: bytesRead // byteSize.  "push # of elements read"
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:34'!
primitiveFileRename

	| oldNamePointer newNamePointer oldNameIndex oldNameSize newNameIndex newNameSize |
	self var: 'oldNameIndex' type: 'char *'.
	self var: 'newNameIndex' type: 'char *'.
	self export: true.
	newNamePointer _ interpreterProxy stackValue: 0.
	oldNamePointer _ interpreterProxy stackValue: 1.
	((interpreterProxy isBytes: newNamePointer) and:[
		(interpreterProxy isBytes: oldNamePointer)])
			ifFalse:[^interpreterProxy primitiveFail].

	newNameIndex _ interpreterProxy firstIndexableField: newNamePointer.
	newNameSize _ interpreterProxy byteSizeOf: newNamePointer.
	oldNameIndex _ interpreterProxy firstIndexableField: oldNamePointer.
	oldNameSize _ interpreterProxy byteSizeOf: oldNamePointer.
	self sqFileRenameOld: (self cCoerce: oldNameIndex to: 'int') Size: oldNameSize New: (self cCoerce: newNameIndex to: 'int') Size: newNameSize.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2.  "pop new and old names, leave rcvr on stack"
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:17'!
primitiveFileSetPosition
	| newPosition file |
	self var: 'file' declareC: 'SQFile *file'.
	self export: true.
	newPosition _ interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
	file _ self fileValueOf: (interpreterProxy stackValue: 1).
	interpreterProxy failed ifFalse:[
		self sqFile: file SetPosition: newPosition ].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 2 "pop position, file; leave rcvr on stack" ].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:17'!
primitiveFileSize
	| file size |
	self var: 'file' declareC: 'SQFile *file'.
	self export: true.
	file _ self fileValueOf: (interpreterProxy stackValue: 0).
	interpreterProxy failed ifFalse:[size _ self sqFileSize: file].
	interpreterProxy failed ifFalse: [
		interpreterProxy pop: 2.
		interpreterProxy push: (interpreterProxy positive32BitIntegerFor: size)].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/11/2000 22:34'!
primitiveFileWrite

	| count startIndex array file byteSize arrayIndex bytesWritten |
	self var: 'file' declareC: 'SQFile *file'.
	self var: 'arrayIndex' type: 'char *'.
	self export: true.
	count		_ interpreterProxy stackIntegerValue: 0.
	startIndex	_ interpreterProxy stackIntegerValue: 1.
	array		_ interpreterProxy stackValue: 2.
	file			_ self fileValueOf: (interpreterProxy stackValue: 3).

	"buffer can be any indexable words or bytes object except CompiledMethod"
	(interpreterProxy isWordsOrBytes: array) 
		ifFalse:[^interpreterProxy primitiveFail].

	(interpreterProxy isWords: array)
		ifTrue: [ byteSize _ 4 ]
		ifFalse: [ byteSize _ 1 ].
	((startIndex >= 1) and:
		[(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)])
			ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy failed ifFalse:[
		arrayIndex _ interpreterProxy firstIndexableField: array.
		"Note: adjust startIndex for zero-origin indexing"
		bytesWritten _
			self sqFile: file
				Write: (count * byteSize)
				From: (self cCoerce: arrayIndex to: 'int')
				At: ((startIndex - 1) * byteSize).
	].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 5.  "pop rcvr, file, array, startIndex, count"
		interpreterProxy pushInteger: bytesWritten // byteSize.  "push # of elements written"
	].! !

!FilePlugin methodsFor: 'file primitives' stamp: 'ar 5/13/2000 14:51'!
setMacFile: fileName Type: typeString AndCreator: creatorString
	"Exported entry point for the VM. Needed for image saving only and no-op on anything but Macs."
	self export: true. "Must be exported for image file write"
	self var: #fileName type: 'char *'.
	self var: #typeString type: 'char *'.
	self var: #creatorString type: 'char *'.
	^self cCode: 'dir_SetMacFileTypeAndCreator(fileName, strlen(fileName), typeString, creatorString)'.! !


!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 21:31'!
asciiDirectoryDelimiter
	^ self cCode: 'dir_Delimitor()' inSmalltalk: [FileDirectory pathNameDelimiter asciiValue]! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 22:11'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	| modDateOop createDateOop nameString results stringPtr |
	self var: 'entryName' declareC: 'char *entryName'.
	self var: 'stringPtr' declareC:'char *stringPtr'.

	"allocate storage for results, remapping newly allocated
	 oops in case GC happens during allocation"
	interpreterProxy pushRemappableOop:
		(interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 5).
	interpreterProxy pushRemappableOop:
		(interpreterProxy instantiateClass: (interpreterProxy classString) indexableSize: entryNameSize)..
	interpreterProxy pushRemappableOop: 
		(interpreterProxy positive32BitIntegerFor: createDate).
	interpreterProxy pushRemappableOop: 
		(interpreterProxy positive32BitIntegerFor: modifiedDate).

	modDateOop   _ interpreterProxy popRemappableOop.
	createDateOop _ interpreterProxy popRemappableOop.
	nameString    _ interpreterProxy popRemappableOop.
	results         _ interpreterProxy popRemappableOop.

	"copy name into Smalltalk string"
	stringPtr _ interpreterProxy firstIndexableField: nameString.
	0 to: entryNameSize - 1 do: [ :i |
		stringPtr at: i put: (entryName at: i).
	].

	interpreterProxy storePointer: 0 ofObject: results withValue: nameString.
	interpreterProxy storePointer: 1 ofObject: results withValue: createDateOop.
	interpreterProxy storePointer: 2 ofObject: results withValue: modDateOop.
	dirFlag
		ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
		ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
	interpreterProxy storePointer: 4 ofObject: results
		withValue: (interpreterProxy integerObjectOf: fileSize).
	^ results! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/13/2000 14:42'!
primitiveDirectoryCreate

	| dirName dirNameIndex dirNameSize |
	self var: #dirNameIndex type: 'char *'.
	self export: true.
	dirName _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName) ifFalse:[^interpreterProxy primitiveFail].
	dirNameIndex _ interpreterProxy firstIndexableField: dirName.
	dirNameSize _ interpreterProxy byteSizeOf: dirName.
	(self cCode: 'dir_Create((char *) dirNameIndex, dirNameSize)'
		inSmalltalk:[false])
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.  "pop dirName; leave rcvr on stack"! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/13/2000 14:42'!
primitiveDirectoryDelete

	| dirName dirNameIndex dirNameSize |
	self var: #dirNameIndex type: 'char *'.
	self export: true.
	dirName _ interpreterProxy stackValue: 0.
	(interpreterProxy isBytes: dirName) ifFalse:[^interpreterProxy primitiveFail].
	dirNameIndex _ interpreterProxy firstIndexableField: dirName.
	dirNameSize _ interpreterProxy byteSizeOf: dirName.
	(self cCode: 'dir_Delete((char *) dirNameIndex, dirNameSize)'
		inSmalltalk:[false])
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.  "pop dirName; leave rcvr on stack"! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 22:18'!
primitiveDirectoryDelimitor

	| ascii |
	self export: true.
	ascii _ self asciiDirectoryDelimiter.
	((ascii >= 0) and: [ascii <= 255])
		ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 1.  "pop rcvr"
	interpreterProxy push: (interpreterProxy fetchPointer: ascii ofObject: (interpreterProxy characterTable)).! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'JMM 1/28/2001 20:12'!
primitiveDirectoryGetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize |
	self var: 'creatorStringIndex' type: 'char *'.
	self var: 'typeStringIndex' type: 'char *'.
	self var: 'fileNameIndex' type: 'char *'.
	self export: true.
	creatorString _ interpreterProxy stackValue: 0.
	typeString _ interpreterProxy stackValue: 1.
	fileName _ interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString) and: [(interpreterProxy byteSizeOf: creatorString) = 4]) ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString) and: [(interpreterProxy byteSizeOf: typeString) = 4]) ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName) ifFalse:[^interpreterProxy primitiveFail].
	creatorStringIndex _ interpreterProxy firstIndexableField: creatorString.
	typeStringIndex _ interpreterProxy firstIndexableField: typeString.
	fileNameIndex _ interpreterProxy firstIndexableField: fileName.
	fileNameSize _ interpreterProxy byteSizeOf: fileName.
	(self cCode: 'dir_GetMacFileTypeAndCreator(
			(char *) fileNameIndex, fileNameSize,
			(char *) typeStringIndex, (char *) creatorStringIndex)'
		inSmalltalk:[true]) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 3.  "pop filename, type, creator; leave rcvr on stack"
! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 22:18'!
primitiveDirectoryLookup

	| index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag fileSize |
	self var: 'entryName' declareC: 'char entryName[256]'.
	self var: 'pathNameIndex' type: 'char *'.
	self export: true.
	index _ interpreterProxy stackIntegerValue: 0.
	pathName _ interpreterProxy stackValue: 1.
	(interpreterProxy isBytes: pathName) ifFalse:[^interpreterProxy primitiveFail].
	pathNameIndex _ interpreterProxy firstIndexableField: pathName.
	pathNameSize _ interpreterProxy byteSizeOf: pathName.

	status _ self cCode:
			'dir_Lookup(
				(char *) pathNameIndex, pathNameSize, index,
				entryName, &entryNameSize, &createDate, &modifiedDate,
				&dirFlag, &fileSize)'.

	interpreterProxy failed ifTrue:[^nil].

	status = DirNoMoreEntries ifTrue: [
		"no more entries; return nil"
		interpreterProxy pop: 3.  "pop pathName, index, rcvr"
		interpreterProxy push: interpreterProxy nilObject.
		^ nil
	].
	status = DirBadPath ifTrue: [ ^ interpreterProxy primitiveFail ].  "bad path"

	interpreterProxy pop: 3.  "pop pathName, index, rcvr"
	interpreterProxy push:
			(self makeDirEntryName: entryName size: entryNameSize
				createDate: createDate modDate: modifiedDate
				isDir: dirFlag fileSize: fileSize).! !

!FilePlugin methodsFor: 'directory primitives' stamp: 'ar 5/11/2000 22:18'!
primitiveDirectorySetMacTypeAndCreator

	| creatorString typeString fileName creatorStringIndex typeStringIndex fileNameIndex fileNameSize |
	self var: 'creatorStringIndex' type: 'char *'.
	self var: 'typeStringIndex' type: 'char *'.
	self var: 'fileNameIndex' type: 'char *'.
	self export: true.
	creatorString _ interpreterProxy stackValue: 0.
	typeString _ interpreterProxy stackValue: 1.
	fileName _ interpreterProxy stackValue: 2.
	((interpreterProxy isBytes: creatorString) and: [(interpreterProxy byteSizeOf: creatorString) = 4]) ifFalse:[^interpreterProxy primitiveFail].
	((interpreterProxy isBytes: typeString) and: [(interpreterProxy byteSizeOf: typeString) = 4]) ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: fileName) ifFalse:[^interpreterProxy primitiveFail].
	creatorStringIndex _ interpreterProxy firstIndexableField: creatorString.
	typeStringIndex _ interpreterProxy firstIndexableField: typeString.
	fileNameIndex _ interpreterProxy firstIndexableField: fileName.
	fileNameSize _ interpreterProxy byteSizeOf: fileName.
	(self cCode: 'dir_SetMacFileTypeAndCreator(
			(char *) fileNameIndex, fileNameSize,
			(char *) typeStringIndex, (char *) creatorStringIndex)'
		inSmalltalk:[true]) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: 3.  "pop filename, type, creator; leave rcvr on stack"
! !

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

FilePlugin class
	instanceVariableNames: ''!

!FilePlugin class methodsFor: 'class initialization' stamp: 'ar 5/12/2000 16:04'!
initialize
	"FilePlugin initialize"
	DirEntryFound _ 0.
	DirNoMoreEntries _ 1.
	DirBadPath _ 2.! !


!FilePlugin class methodsFor: 'instance creation' stamp: 'ar 5/11/2000 22:13'!
simulatorClass
	^FilePluginSimulator! !


!FilePlugin class methodsFor: 'translation' stamp: 'JMM 1/28/2001 20:13'!
headerFile
^'/* File support definitions */
/* squeak file record; see sqFilePrims.c for details */
typedef struct {
	FILE	*file;
	int		sessionID;
	int		writable;
	int		fileSize;
	int		lastOp;  /* 0 = uncommitted, 1 = read, 2 = write */
} SQFile;

/* file i/o */
int sqFileAtEnd(SQFile *f);
int sqFileClose(SQFile *f);
int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize);
int sqFileGetPosition(SQFile *f);
int sqFileInit(void);
int sqFileShutdown(void);
int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag);
int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex);
int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize);
int sqFileSetPosition(SQFile *f, int position);
int sqFileSize(SQFile *f);
int sqFileValid(SQFile *f);
int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex);

/* directories */
int dir_Create(char *pathString, int pathStringLength);
int dir_Delete(char *pathString, int pathStringLength);
int dir_Delimitor(void);
int dir_Lookup(char *pathString, int pathStringLength, int index,
	/* outputs: */
	char *name, int *nameLength, int *creationDate, int *modificationDate,
	int *isDirectory, int *sizeIfFile);
int dir_PathToWorkingDir(char *pathName, int pathNameMax);
int dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator);
int dir_GetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator);
'.! !
FilePlugin subclass: #FilePluginSimulator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:10'!
fileValueOf: objectPointer
	^interpreterProxy fileValueOf: objectPointer! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:11'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	^interpreterProxy
		makeDirEntryName: entryName size: entryNameSize
		createDate: createDate modDate: modifiedDate
		isDir: dirFlag fileSize: fileSize
! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:11'!
primitiveDirectoryLookup
	^interpreterProxy primitiveDirectoryLookup! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:12'!
primitiveFileDelete 
	^interpreterProxy primitiveFileDelete ! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:12'!
primitiveFileOpen
	^interpreterProxy primitiveFileOpen! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:12'!
primitiveFileRename
	^interpreterProxy primitiveFileRename! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:09'!
sqFile: file Read: count Into: byteArrayIndex At: startIndex
	^interpreterProxy sqFile: file Read: count Into: byteArrayIndex At: startIndex! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:09'!
sqFile: file SetPosition: newPosition
	^interpreterProxy sqFile: file SetPosition: newPosition! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:09'!
sqFile: file Write: count From: byteArrayIndex At: startIndex
	^interpreterProxy sqFile: file Write: count From: byteArrayIndex At: startIndex! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:09'!
sqFileAtEnd: file
	^interpreterProxy sqFileAtEnd: file! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:09'!
sqFileClose: file
	^interpreterProxy sqFileClose: file! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:10'!
sqFileGetPosition: file
	^interpreterProxy sqFileGetPosition: file! !

!FilePluginSimulator methodsFor: 'as yet unclassified' stamp: 'ar 5/11/2000 22:10'!
sqFileSize: file
	^interpreterProxy sqFileSize: file! !
ReadWriteStream subclass: #FileStream
	instanceVariableNames: 'rwmode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!FileStream commentStamp: '<historical>' prior: 0!
I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated.
	
To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance.

*** On Mac and DOS, files cannot be shortened!!  ***  To overwrite a file with a shorter one, first delete the old file (FileDirectory deleteFilePath: 'Hard Disk:aFolder:dataFolder:foo') or (aFileDirectory deleteFileNamed: 'foo').  Then write your new shorter version.!


!FileStream methodsFor: 'accessing'!
contentsOfEntireFile
	"Read all of the contents of the receiver."

	| s binary |
	self readOnly.
	binary _ self isBinary.
	self reset.	"erases knowledge of whether it is binary"
	binary ifTrue: [self binary].
	s _ self next: self size.
	self close.
	^s! !

!FileStream methodsFor: 'accessing' stamp: 'ar 1/25/2001 19:33'!
mimeTypes
	^FileDirectory default mimeTypesFor: self name.! !

!FileStream methodsFor: 'accessing'!
next

	(position >= readLimit and: [self atEnd])
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]! !

!FileStream methodsFor: 'accessing'!
next: anInteger

	| newCollection howManyRead increment |
	newCollection _ collection species new: anInteger.
	howManyRead _ 0.
	[howManyRead < anInteger] whileTrue:
		[self atEnd ifTrue:
			[(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)].
			^newCollection].
		increment _ (readLimit - position) min: (anInteger - howManyRead).
		newCollection replaceFrom: (howManyRead + 1)
			to: (howManyRead _ howManyRead + increment)
			with: collection
			startingAt: (position + 1).
		position _ position + increment].
	^newCollection! !

!FileStream methodsFor: 'accessing'!
nextPut: aByte
	"1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'accessing'!
nextPutAll: aCollection
	"1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'accessing'!
size
	"Answer the size of the file in characters.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !


!FileStream methodsFor: 'testing'!
atEnd
	"Answer true if the current position is >= the end of file position.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !


!FileStream methodsFor: 'positioning'!
position
	"Answer the current character position in the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
position: pos
	"Set the current character position in the file to pos.
	 1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
reset
	"Set the current character position to the beginning of the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
setToEnd
	"Set the current character position to the end of the File. The same as
	self position: self size.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file
	1/31/96 sw: made subclassResponsibility."
 
	self subclassResponsibility! !


!FileStream methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' on '.
	self file printOn: aStream! !


!FileStream methodsFor: 'editing' stamp: 'di 5/20/1998 23:20'!
edit
	"Create and schedule an editor on this file."

	FileList openEditorOn: self editString: nil.
! !


!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'!
close
	"Close this file."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'!
closed
	"Answer true if this file is closed."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:03'!
flush
	"When writing, flush the current buffer out to disk."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:04'!
reopen
	"Ensure that the receiver is open, re-open it if necessary."
	"Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened."

	self subclassResponsibility
! !


!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'!
ascii
	"Set this file to ascii (text) mode."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'!
binary
	"Set this file to binary mode."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'!
readOnly
	"Set this file's mode to read-only."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'!
readWrite
	"Set this file's mode to read-write."

	self subclassResponsibility
! !

!FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'!
text
	"Set this file to text (ascii) mode."

	self ascii.
! !


!FileStream methodsFor: 'file accessing'!
file
	"Answer the file for the page the receiver is streaming over.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'file accessing' stamp: 'jm 12/5/97 12:53'!
localName

	^ FileDirectory localNameFor: self name
! !

!FileStream methodsFor: 'file accessing'!
name
	"Answer the name of the file for the page the receiver is streaming over.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'file accessing' stamp: 'tk 1/15/1999 11:38'!
url
	"Convert my path into a file:// type url.  Use slash instead of the local delimiter (:), and convert odd characters to %32 notation."

	"If / is not the file system delimiter, encode / before converting."
	| list |
	list _ self directory pathParts.
	^ String streamContents: [:strm |
		strm nextPutAll: 'file:/'.
		list do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP].
		strm nextPut: $/; nextPutAll: self localName encodeForHTTP]! !


!FileStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:42'!
fileIn
	"Guarantee that the receiver is readOnly before fileIn for efficiency and
	to eliminate remote sharing conflicts."

	self readOnly.
	self fileInAnnouncing: 'Loading ', self localName! !

!FileStream methodsFor: 'fileIn/Out' stamp: 'tk 1/21/2000 16:38'!
fileInObjectAndCode
	"Read the file directly, do not use an RWBinaryOrTextStream."

	self text.
	^ super fileInObjectAndCode
! !


!FileStream methodsFor: 'converting' stamp: 'tk 2/4/2000 09:16'!
asBinaryOrTextStream
	"I can switch between binary and text data"

	^ self! !


!FileStream methodsFor: 'remote file compatibility' stamp: 'RAA 9/24/2000 18:00'!
dataIsValid

	self flag: #bob.		"we needed this if a remote stream, but could be local as well"! !

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

FileStream class
	instanceVariableNames: ''!

!FileStream class methodsFor: 'instance creation'!
fileNamed: fileName 
	^ self concreteStream fileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation'!
fullName: fileName
	^ FileDirectory default fullNameFor: fileName! !

!FileStream class methodsFor: 'instance creation' stamp: 'TPR 8/26/1999 10:49'!
isAFileNamed: fName
	"return whether a file exists with the given name"
	^self concreteStream isAFileNamed: (self fullName: fName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'di 2/15/98 14:03'!
new
	^ self basicNew! !

!FileStream class methodsFor: 'instance creation'!
newFileNamed: fileName 
	^ self concreteStream newFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation'!
oldFileNamed: fileName 
	^ self concreteStream oldFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'instance creation' stamp: 'jm 5/8/1998 21:53'!
oldFileOrNoneNamed: fileName
	"If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil."

	| fullName |
	fullName _ self fullName: fileName.
	(self concreteStream isAFileNamed: fullName)
		ifTrue: [^ self concreteStream readOnlyFileNamed: fullName]
		ifFalse: [^ nil].
! !

!FileStream class methodsFor: 'instance creation'!
readOnlyFileNamed: fileName 
	^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! !


!FileStream class methodsFor: 'concrete classes' stamp: 'ls 7/11/1998 02:58'!
concreteStream
	"Who should we really direct class queries to?  "
	^ StandardFileStream  "may change this to CrLfFileStream"! !


!FileStream class methodsFor: 'browser requests' stamp: 'ar 3/2/2000 17:48'!
post: data url: url ifError: errorBlock
	^self concreteStream new post: data url: url ifError: errorBlock! !

!FileStream class methodsFor: 'browser requests'!
requestURLStream: url
	"FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'"
	^self concreteStream new requestURLStream: url! !

!FileStream class methodsFor: 'browser requests'!
requestURLStream: url ifError: errorBlock
	"FileStream requestURLStream:'http://isgwww.cs.uni-magdeburg.de/~raab'"
	^self concreteStream new requestURLStream: url ifError: errorBlock! !


!FileStream class methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 19:41'!
requestDropStream: dropIndex
	"Request a read-only stream for some file that was dropped onto Squeak"
	^self concreteStream new requestDropStream: dropIndex.! !
Error subclass: #FileStreamException
	instanceVariableNames: 'fileName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!

!FileStreamException methodsFor: 'exceptionBuilder' stamp: 'mir 2/23/2000 20:13'!
fileName: aFileName
	fileName _ aFileName! !


!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/25/2000 17:29'!
fileName
	^fileName! !

!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/23/2000 20:13'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!FileStreamException methodsFor: 'exceptionDescription' stamp: 'mir 2/23/2000 20:14'!
messageText
	
	"Return an exception's message text."

	^messageText == nil
		ifTrue: [fileName printString]
		ifFalse: [messageText]! !

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

FileStreamException class
	instanceVariableNames: ''!

!FileStreamException class methodsFor: 'exceptionInstantiator' stamp: 'mir 2/23/2000 20:12'!
fileName: aFileName
	^self new fileName: aFileName! !
Url subclass: #FileUrl
	instanceVariableNames: 'path isAbsolute '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!FileUrl commentStamp: '<historical>' prior: 0!
A reference to a local file.  The url itself uses the UNIX notation of %20 for space.  

path has the tokens translated to ascii, except if we have a UNIX file system. 

path is OC of path parts.  If last is empty string, then referring to a directory.
!


!FileUrl methodsFor: 'parsing' stamp: 'tk 9/6/1998 13:05'!
privateInitializeFromText: text

	| bare schemeName pathString |
	bare _ text withBlanksTrimmed.
	schemeName _ Url schemeNameForString: bare.
	schemeName
		ifNil: [ pathString _ bare ]
		ifNotNil: [ pathString _ bare copyFrom: (schemeName size + 2) to: bare size ].

	path _ pathString findTokens: '/'.
	path _ path collect: [:token | token unescapePercents].
	(pathString endsWith: '/') ifTrue: [ path addLast: '' ].

	isAbsolute _ pathString beginsWith: '/'.! !

!FileUrl methodsFor: 'parsing' stamp: 'tk 9/6/1998 16:40'!
privateInitializeFromText: aString relativeTo: aUrl
	| bare |

	bare _ aString.

	(bare beginsWith: (self schemeName, ':')) ifTrue: [
		bare _ bare copyFrom: (self schemeName size + 2) to: bare size ].

	(bare beginsWith: '/') ifTrue: [ ^self privateInitializeFromText: aString ].

	isAbsolute _ aUrl isAbsolute.

	path _ aUrl path copy.
	path removeLast.	"empty string that says its a directory"
	(bare findTokens: '/') do: [ :token |
		((token ~= '..') and: [token ~= '.']) ifTrue: [ 
			path addLast: token unescapePercents ].
		token = '..' ifTrue: [ 
			path isEmpty ifFalse: [ 
				path last = '..' ifFalse: [ path removeLast ] ] ].
		"token = '.' do nothing" ].

	(bare endsWith: '/') ifTrue: [ path add: '' ].! !


!FileUrl methodsFor: 'printing' stamp: 'tk 1/14/1999 21:22'!
toText
	| s |
	s _ WriteStream on: String new.
	s nextPutAll: self schemeName.
	s nextPut: $:.
	isAbsolute ifTrue:[ s nextPut: $/ ].	"the extra one"
	s nextPutAll: self pathString.
	fragment ifNotNil: [ s nextPut: $#.  s nextPutAll: fragment encodeForHTTP ].
	^s contents! !


!FileUrl methodsFor: 'access' stamp: 'ls 8/2/1998 05:39'!
isAbsolute
	^isAbsolute! !

!FileUrl methodsFor: 'access' stamp: 'ls 7/23/1998 07:29'!
path
	"return an ordered collection of the path elements"
	^path! !

!FileUrl methodsFor: 'access' stamp: 'tk 9/19/1998 18:57'!
path: anArray

	path _ anArray! !

!FileUrl methodsFor: 'access' stamp: 'tk 11/24/1998 14:59'!
pathDirString
	"Path to directory as url, using slash as delimiter"

	^ String streamContents: [ :s |
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: $/
			 ] ]! !

!FileUrl methodsFor: 'access' stamp: 'tk 11/23/1998 17:17'!
pathForDirectory
	"Path using local file system's delimiter.  $\ or $:"

	^ String streamContents: [ :s |
		1 to: self path size - 1 do: [ :ii |
			s nextPutAll: (path at: ii); nextPut: FileDirectory default pathNameDelimiter
			 ] ]! !

!FileUrl methodsFor: 'access' stamp: 'tk 9/6/1998 00:35'!
pathForFile
	"Path using local file system's delimiter.  $\ or $:"
	| first |
	^String streamContents: [ :s |
		first _ true.
		self path do: [ :p |
			first ifFalse: [ s nextPut: FileDirectory default pathNameDelimiter ].
			first _ false.
			s nextPutAll: p ] ]! !

!FileUrl methodsFor: 'access' stamp: 'tk 9/6/1998 13:03'!
pathString
	"Path as it appears in a URL with $/ as delimiter"
	| first |
	^String streamContents: [ :s |
		isAbsolute ifTrue:[ s nextPut: $/ ].

		first _ true.
		self path do: [ :p |
			first ifFalse: [ s nextPut: $/ ].
			first _ false.
			s nextPutAll: p encodeForHTTP ] ]! !


!FileUrl methodsFor: 'downloading' stamp: 'tk 9/6/1998 00:36'!
default
	"Use the default local Squeak file directory"
	| local |
	local _ FileUrl new path: (FileDirectory default pathParts), #('')
		isAbsolute: true.
	self privateInitializeFromText: self pathString relativeTo: local.
		"sets absolute also"! !

!FileUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'!
hasContents
	^true! !

!FileUrl methodsFor: 'downloading' stamp: 'tk 9/5/1998 20:42'!
retrieveContents
	| file pathString s dir |
	
	pathString _ self pathForFile.
	path last size > 0 ifTrue: [
		file _ FileStream oldFileOrNoneNamed: pathString.
		file ifNotNil: [ 
			^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: file contentsOfEntireFile ] ].

	"assume it's a directory..."
	s _ WriteStream on: String new.
	dir _ FileDirectory on: pathString.

	(pathString endsWith: '/') ifFalse: [ pathString _ pathString, '/' ].

	s nextPutAll: '<title>Directory Listing for ', pathString, '</title>'.
	s nextPutAll: '<h1>Directory Listing for ', pathString, '</h1>'.
	s nextPutAll: '<ul>'.
	s cr.
	dir entries do: [ :entry |
		s nextPutAll: '<li><a href="'.
		s nextPutAll: entry name.
		s nextPutAll: '">'.
		s nextPutAll: entry name.
		s nextPutAll: '</a>'.
		s cr. ].
	s nextPutAll: '</ul>'.

	^MIMEDocument  contentType: 'text/html'  content: s contents  url: ('file:', pathString)! !


!FileUrl methodsFor: 'private-initialization' stamp: 'ls 7/26/1998 20:43'!
path: aCollection isAbsolute: aBoolean

	path _ aCollection.
	isAbsolute _ aBoolean! !


!FileUrl methodsFor: 'classification' stamp: 'ls 7/26/1998 21:11'!
schemeName
	^'file'! !


!FileUrl methodsFor: 'copying' stamp: 'tk 2/1/2001 22:30'!
copy
	"Be sure not to share the path with the copy"

	^ (self clone) path: path copy! !

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

FileUrl class
	instanceVariableNames: ''!

!FileUrl class methodsFor: 'parsing' stamp: 'sma 4/30/2000 11:28'!
absoluteFromText: text
	"(how does this method fit with FileUrl|privateInitializeFromText:?)"

	| schemeName pathString bare thePath |
	bare _ text withBlanksTrimmed.
	schemeName _ Url schemeNameForString: bare.
	pathString _ schemeName
		ifNil: [bare]
		ifNotNil: [bare copyFrom: (schemeName size + 2) to: bare size].
	thePath _ (pathString findTokens: '/') collect: [:token | token unescapePercents].
	(pathString endsWith: '/') ifTrue: [thePath add: ''].

	"Hey, this only works on Unix!!"
	^ self new path: thePath isAbsolute: (pathString beginsWith: '/')! !
StringHolder subclass: #FillInTheBlank
	instanceVariableNames: 'acceptOnCR done responseUponCancel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!FillInTheBlank commentStamp: '<historical>' prior: 0!
I represent a prompt for string input from the user. The user is asked to type in and edit a string. The resulting string is supplied as the argument to a client-supplied action block.
!


!FillInTheBlank methodsFor: 'initialize-release' stamp: 'sw 1/31/2000 14:42'!
initialize

	super initialize.
	acceptOnCR _ false.
	done _ false.
	responseUponCancel _ ''
! !


!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'!
acceptOnCR
	"Answer whether a carriage return should cause input to be accepted."

	^ acceptOnCR
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 4/28/1998 06:18'!
acceptOnCR: aBoolean

	acceptOnCR _ aBoolean.
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'!
done
	"Answer whether the user has ended the interaction."

	^ done
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'jm 5/6/1998 15:13'!
done: aBoolean

	done _ aBoolean.
! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:45'!
responseUponCancel: resp
	responseUponCancel _ resp! !

!FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:47'!
setResponseForCancel
	self contents: responseUponCancel! !


!FillInTheBlank methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:59'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	varDict at: 'responseUponCancel' ifAbsent: [responseUponCancel _ ''].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!FillInTheBlank methodsFor: 'private' stamp: 'sma 6/18/2000 10:54'!
show: fillInView
	| savedArea |
	savedArea _ Form fromDisplay: fillInView displayBox.
	fillInView display.
	contents isEmpty
		ifFalse: [fillInView lastSubView controller selectFrom: 1 to: contents size].
	(fillInView lastSubView containsPoint: Sensor cursorPoint)
		ifFalse: [fillInView lastSubView controller centerCursorInView].
	fillInView controller startUp.
	fillInView release.
	savedArea displayOn: Display at: fillInView viewport topLeft.
	^ contents! !

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

FillInTheBlank class
	instanceVariableNames: ''!

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 6/18/2000 10:56'!
multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight
	"Create a multi-line instance of me whose question is queryString with
	the given initial answer. Invoke it centered at the given point, and
	answer the string the user accepts.  Answer nil if the user cancels.  An
	empty string returned means that the ussr cleared the editing area and
	then hit 'accept'.  Because multiple lines are invited, we ask that the user
	use the ENTER key, or (in morphic anyway) hit the 'accept' button, to 
	submit; that way, the return key can be typed to move to the next line.
	NOTE: The ENTER key does not work on Windows platforms."

	"FillInTheBlank
		multiLineRequest:
'Enter several lines; end input by accepting
or canceling via menu or press Alt+s/Alt+l'
		centerAt: Display center
		initialAnswer: 'Once upon a time...'
		answerHeight: 200"

	| model fillInView |
	Smalltalk isMorphic
		ifTrue:
			[^ self fillInTheBlankMorphClass
				request: queryString
				initialAnswer: defaultAnswer
				centerAt: aPoint
				inWorld: self currentWorld
				onCancelReturn: nil
				acceptOnCR: false].

	model _ self new initialize.
	model contents: defaultAnswer.
	model responseUponCancel: nil.
	model acceptOnCR: false.
	fillInView _
		self fillInTheBlankViewClass
			multiLineOn: model
			message: queryString
			centerAt: aPoint
			answerHeight: answerHeight.
	^ model show: fillInView! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 6/18/2000 10:27'!
request: queryString 
	"Create an instance of me whose question is queryString. Invoke it 
	centered at the cursor, and answer the string the user accepts. Answer 
	the empty string if the user cancels."

	"FillInTheBlank request: 'Your name?'"

	^ self
		request: queryString
		initialAnswer: ''
		centerAt: Sensor cursorPoint! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 6/18/2000 10:28'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given 
	initial answer. Invoke it centered at the given point, and answer the 
	string the user accepts. Answer the empty string if the user cancels."

	"FillInTheBlank 
		request: 'What is your favorite color?' 
		initialAnswer: 'red, no blue. Ahhh!!'"

	^ self
		request: queryString
		initialAnswer: defaultAnswer
		centerAt: Sensor cursorPoint! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 6/18/2000 10:53'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint
	"Create an instance of me whose question is queryString with the given
	initial answer. Invoke it centered at the given point, and answer the
	string the user accepts. Answer the empty string if the user cancels."

	"FillInTheBlank
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| model fillInView |
	Smalltalk isMorphic
		ifTrue:
			[^ self fillInTheBlankMorphClass
				request: queryString
				initialAnswer: defaultAnswer
				centerAt: aPoint].

	model _ self new initialize.
	model contents: defaultAnswer.
	fillInView _
		self fillInTheBlankViewClass
			on: model
			message: queryString
			centerAt: aPoint.
	^ model show: fillInView! !

!FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 6/18/2000 10:57'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered
	at the cursor, and answer the string the user accepts. Answer the empty 
	string if the user cancels."

	"FillInTheBlank requestPassword: 'POP password'"

	| model fillInView |
	Smalltalk isMorphic
		ifTrue: [^ self fillInTheBlankMorphClass requestPassword: queryString].

	model _ self new initialize.
	model contents: ''.
	fillInView _
		self fillInTheBlankViewClass
			requestPassword: model
			message: queryString
			centerAt: Sensor cursorPoint
			answerHeight: 40.
	^ model show: fillInView! !


!FillInTheBlank class methodsFor: 'private' stamp: 'sma 6/18/2000 10:39'!
fillInTheBlankMorphClass
	"By factoring out this class references, it becomes possible to discard 
	morphic by simply removing this class.  All calls to this method needs
	to be protected by 'Smalltalk isMorphic' tests."

	^ FillInTheBlankMorph! !

!FillInTheBlank class methodsFor: 'private' stamp: 'sma 6/18/2000 10:47'!
fillInTheBlankViewClass
	"By factoring out this class references, it becomes possible to discard 
	MVC by simply removing this class.  All calls to this method needs
	to be protected by 'Smalltalk isMorphic' tests."

	^ FillInTheBlankView! !
StringHolderController subclass: #FillInTheBlankController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!FillInTheBlankController commentStamp: '<historical>' prior: 0!
I am the controller for a FillInTheBlankView. Based on a flag in the view, I can either accept the input string when a carriage return is typed, or I can allow multiple lines of input that is accepted by either typing enter or by invoking the 'accept' command.
!


!FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'jm 4/28/1998 07:57'!
controlInitialize

	model acceptOnCR ifFalse: [^ super controlInitialize].
	startBlock _ paragraph characterBlockForIndex: startBlock stringIndex.
	stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex.
	self initializeSelection.
	beginTypeInBlock _ nil.
! !

!FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'jm 5/6/1998 15:11'!
controlTerminate

	| topController |
	super controlTerminate.
	topController _ view topView controller.
	topController ifNotNil: [topController close].
! !


!FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'!
isControlActive
	^ self isControlWanted! !

!FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'!
isControlWanted
	^ model done not! !


!FillInTheBlankController methodsFor: 'other' stamp: 'jm 5/6/1998 15:13'!
accept

	super accept.
	model done: true.
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'sw 1/31/2000 14:47'!
cancel

	model setResponseForCancel.
	super cancel.
	model done: true.
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'jm 4/28/1998 06:25'!
dispatchOnCharacter: char with: typeAheadStream
	"Accept the current input if the user hits the carriage return or the enter key."

	(model acceptOnCR and:
	 [(char = Character cr) | (char = Character enter)])
		ifTrue: [
			sensor keyboard.  "absorb the character"
			self accept.
			^ true]
		ifFalse: [
			^ super dispatchOnCharacter: char with: typeAheadStream].
! !

!FillInTheBlankController methodsFor: 'other' stamp: 'jm 4/28/1998 08:01'!
processYellowButton
	"Suppress yellow-button menu if acceptOnCR is true."

	model acceptOnCR ifFalse: [^ super processYellowButton].
! !
RectangleMorph subclass: #FillInTheBlankMorph
	instanceVariableNames: 'response done textPane responseUponCancel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 22:35'!
delete

	self breakDependents.
	super delete.! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ssa 2/14/2000 13:14'!
initialize
	super initialize.
	Preferences roundedWindowCorners ifTrue: [self useRoundedCorners].
	color _ Color white.
	borderWidth _ 2.
	self extent: 200@70.
	responseUponCancel _ ''.  "Caller can reset this to return something else, e.g. nil, upon cancel"
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 1/31/2000 11:01'!
responseUponCancel: anObject
	responseUponCancel _ anObject
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ar 11/4/2000 23:21'!
setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
	| pane |
	self setQuery: queryString 
		initialAnswer: initialAnswer 
		answerHeight: answerHeight 
		acceptOnCR: acceptBoolean.
	pane _ self submorphNamed: 'textPane'.
	pane font: (StrikeFont passwordFontSize: 12).! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 2/2/2000 22:41'!
setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight

	self setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: true
! !

!FillInTheBlankMorph methodsFor: 'initialization' stamp: 'JW 2/1/2001 13:28'!
setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
	| query frame topOffset accept cancel buttonAreaHeight |
	response _ initialAnswer.
	done _ false.
	self removeAllMorphs.

	self layoutPolicy: ProportionalLayout new.

	query _ TextMorph new contents: queryString.
	query setNameTo: 'query'.
	query lock.
		frame _ LayoutFrame new.
		frame topFraction: 0.0; topOffset: 2.
		frame leftFraction: 0.5; leftOffset: (query width // 2) negated.
	query layoutFrame: frame.
	self addMorph: query.
	topOffset _ query height + 4.

	accept _ SimpleButtonMorph new target: self; color: Color veryLightGray.
	accept label: 'Accept(s)'; actionSelector: #accept.
	accept setNameTo: 'accept'.
		frame _ LayoutFrame new.
		frame rightFraction: 0.5; rightOffset: -10; bottomFraction: 1.0; bottomOffset: -2.
	accept layoutFrame: frame.
	self addMorph: accept.

	cancel _ SimpleButtonMorph new target: self; color: Color veryLightGray.
	cancel label: 'Cancel(l)'; actionSelector: #cancel.
	cancel setNameTo: 'cancel'.
		frame _ LayoutFrame new.
		frame leftFraction: 0.5; leftOffset: 10; bottomFraction: 1.0; bottomOffset: -2.
	cancel layoutFrame: frame.
	self addMorph: cancel.
	buttonAreaHeight _ (accept height max: cancel height) + 4.

	textPane _ PluggableTextMorph on: self
		text: #response
		accept: #response:
		readSelection: #selectionInterval
		menu: #codePaneMenu:shifted:.
	textPane hResizing: #spaceFill; vResizing: #spaceFill.
	textPane borderWidth: 2.
	textPane hasUnacceptedEdits: true.
	textPane acceptOnCR: acceptBoolean.
	textPane setNameTo: 'textPane'.
		frame _ LayoutFrame new.
		frame leftFraction: 0.0; rightFraction: 1.0; topFraction: 0.0; topOffset: topOffset; bottomFraction: 1.0; bottomOffset: buttonAreaHeight negated.
	textPane layoutFrame: frame.
	self addMorph: textPane.

	self extent: (200 max: query width) + 4 @ (topOffset + answerHeight + 4 + buttonAreaHeight).
! !


!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:03'!
response

	^ response
! !

!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 14:22'!
response: aText
	"Sent when text pane accepts."

	response _ aText asString.
	done _ true.
	^ true
! !

!FillInTheBlankMorph methodsFor: 'accessing' stamp: 'di 5/22/1998 00:58'!
selectionInterval
	^ 1 to: response size
! !


!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 14:21'!
accept
	"Sent by the accept button."

	textPane accept.
! !

!FillInTheBlankMorph methodsFor: 'menu' stamp: 'sw 1/31/2000 11:11'!
cancel
	"Sent by the cancel button."

	response _ responseUponCancel.
	done _ true.
! !

!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 15:15'!
codePaneMenu: aMenu shifted: shifted

	^ StringHolder new codePaneMenu: aMenu shifted: shifted.
! !

!FillInTheBlankMorph methodsFor: 'menu' stamp: 'jm 5/4/1998 15:17'!
perform: selector orSendTo: otherTarget

	^ otherTarget perform: selector
! !


!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'ar 10/10/2000 22:37'!
getUserResponse
	"Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop."

	| w |
	w _ self world.
	w ifNil: [^ response].
	done _ false.
	[done] whileFalse: [Display doOneCycleMorphic].
	self delete.
	Display doOneCycleMorphic.
	^ response
! !

!FillInTheBlankMorph methodsFor: 'invoking' stamp: 'RAA 7/19/2000 20:40'!
morphicLayerNumber

	^10.6! !



!FillInTheBlankMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:59'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	varDict at: 'responseUponCancel' ifAbsent: [responseUponCancel _ ''].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'ar 10/7/2000 15:47'!
handlesMouseDown: evt
	^true! !

!FillInTheBlankMorph methodsFor: 'event handling' stamp: 'ar 10/7/2000 16:00'!
mouseDown: evt
	(self containsPoint: evt position) ifFalse:[^Smalltalk beep]. "sent in response to outside modal click"
	evt hand grabMorph: self. "allow repositioning"! !


!FillInTheBlankMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/7/2000 15:50'!
undoGrabCommand
	^nil! !

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

FillInTheBlankMorph class
	instanceVariableNames: ''!

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'jm 5/6/1998 15:26'!
request: queryString
	"Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
	"FillInTheBlankMorph request: 'What is your favorite color?'"

	^ self
		request: queryString
		initialAnswer: ''
		centerAt: Sensor cursorPoint.
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'jm 5/6/1998 15:26'!
request: queryString initialAnswer: defaultAnswer 
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels."
	"FillInTheBlankMorph
		request: 'What is your favorite color?'
		initialAnswer: 'red, no blue. Ahhh!!'"

	^ self
		request: queryString
		initialAnswer: defaultAnswer
		centerAt: Sensor cursorPoint.
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'RAA 6/2/2000 11:03'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels.
	This variant is only for calling from within a Morphic project."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	 ^ self 
		request: queryString 
		initialAnswer: defaultAnswer 
		centerAt: aPoint 
		inWorld: Display getCurrentMorphicWorld
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 1/31/2000 11:03'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.  Answer the empty string if the user cancels."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: ''! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:43'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel.  If user hits cr, treat it as a normal accept."

	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: true! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:34'!
request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| aFillInTheBlankMorph |
	aFillInTheBlankMorph _ self new
		setQuery: queryString
		initialAnswer: defaultAnswer
		answerHeight: 50
		acceptOnCR: acceptBoolean.
	aFillInTheBlankMorph responseUponCancel: returnOnCancel.
	aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
	^ aFillInTheBlankMorph getUserResponse
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:57'!
requestPassword: queryString
	"Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
	"use password font"
	"FillInTheBlankMorph requestPassword: 'Password?'"

	^ self
		requestPassword: queryString
		initialAnswer: ''
		centerAt: Sensor cursorPoint
		inWorld: World
		onCancelReturn: ''
		acceptOnCR: true
! !

!FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:53'!
requestPassword: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean
	"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts.   If the user cancels, answer returnOnCancel."
	"FillInTheBlankMorph
		request: 'Type something, then type CR.'
		initialAnswer: 'yo ho ho!!'
		centerAt: Display center"

	| aFillInTheBlankMorph |
	aFillInTheBlankMorph _ self new
		setPasswordQuery: queryString
		initialAnswer: defaultAnswer
		answerHeight: 50
		acceptOnCR: acceptBoolean.
	aFillInTheBlankMorph responseUponCancel: returnOnCancel.
	aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint.
	^ aFillInTheBlankMorph getUserResponse
! !
StringHolderView subclass: #FillInTheBlankView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!FillInTheBlankView commentStamp: '<historical>' prior: 0!
I am a view of a FillInTheBlank. I display a query and an editable view of the user's reply string.
!


!FillInTheBlankView methodsFor: 'controller access' stamp: 'jm 4/28/1998 06:37'!
defaultControllerClass

	^ FillInTheBlankController
! !

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

FillInTheBlankView class
	instanceVariableNames: ''!

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jm 4/28/1998 08:35'!
multiLineOn: aFillInTheBlank message: queryString centerAt: aPoint answerHeight: answerHeight
	"Answer an instance of me on aFillInTheBlank asking the question queryString. Allow the reply to be multiple lines, and make the user input view the given height."

	| messageView answerView topView |
	messageView _ DisplayTextView new
		model: queryString asDisplayText;
		borderWidthLeft: 2 right: 2 top: 2 bottom: 0;
		controller: NoController new.
	messageView
		window: (0@0 extent: (messageView window extent max: 200@30));
		centered.
	answerView _ self new
		model: aFillInTheBlank;
		window: (0@0 extent: (messageView window width@answerHeight));
		borderWidth: 2.
	topView _ View new model: aFillInTheBlank.
	topView controller: ModalController new.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView.
	topView align: topView viewport center with: aPoint.
	topView window:
		(0 @ 0 extent:
			(messageView window width) @
			  (messageView window height + answerView window height)).
	topView translateBy:
		(topView displayBox amountToTranslateWithin: Display boundingBox).
	^ topView
! !

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jm 4/28/1998 08:22'!
on: aFillInTheBlank message: queryString centerAt: aPoint
	"Answer an instance of me on aFillInTheBlank for a single line of input in response to the question queryString."

	aFillInTheBlank acceptOnCR: true.
	^ self
		multiLineOn: aFillInTheBlank
		message: queryString
		centerAt: aPoint
		answerHeight: 40
! !

!FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jdr 6/4/2000 15:03'!
requestPassword: aFillInTheBlank message: queryString centerAt: aPoint answerHeight: answerHeight
	"Answer an instance of me on aFillInTheBlank asking the question queryString. Allow the reply to be multiple lines, and make the user input view the given height."

	| messageView answerView topView myPar pwdFont myArray myStyle |
	aFillInTheBlank acceptOnCR: true.
	messageView _ DisplayTextView new
		model: queryString asDisplayText;
		borderWidthLeft: 2 right: 2 top: 2 bottom: 0;
		controller: NoController new.
	messageView
		window: (0@0 extent: (messageView window extent max: 200@30));
		centered.
	answerView _ self new
		model: aFillInTheBlank;
		window: (0@0 extent: (messageView window width@answerHeight));
		borderWidth: 2.
	" now answerView to use the password font"
	myPar _ answerView displayContents.
	pwdFont _ (StrikeFont passwordFontSize: 12).
	myArray _ Array new: 1.
	myArray at: 1 put: pwdFont.
	myStyle _ TextStyle fontArray: myArray.
	myPar setWithText: (myPar text) style: myStyle.

	topView _ View new model: aFillInTheBlank.
	topView controller: ModalController new.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView.
	topView align: topView viewport center with: aPoint.
	topView window:
		(0 @ 0 extent:
			(messageView window width) @
			  (messageView window height + answerView window height)).
	topView translateBy:
		(topView displayBox amountToTranslateWithin: Display boundingBox).
	^ topView
! !
Object subclass: #FillStyle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!

!FillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:23'!
scaledPixelValue32
	"Return a pixel value of depth 32 for the primary color in the fill style"
	^self asColor scaledPixelValue32! !


!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isBitmapFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isGradientFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 11/9/1998 13:54'!
isSolidFill
	^false! !

!FillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:28'!
isTranslucent
	^true "Since we don't know better"! !

!FillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:24'!
isTransparent
	^false! !


!FillStyle methodsFor: 'converting' stamp: 'ar 2/1/1999 22:12'!
asB3DColor
	^self asColor asB3DColor! !

!FillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:53'!
asColor
	^self subclassResponsibility! !

MagnifierMorph subclass: #FishEyeMorph
	instanceVariableNames: 'gridNum d clipRects toRects quads savedExtent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!FishEyeMorph methodsFor: 'private' stamp: 'yo 12/17/1999 11:15'!
gridSizeFor: aPoint
	"returns appropriate size for specified argument"
	| g |
	g _ aPoint x min: aPoint y.
	g <= 256 ifTrue: [^8].
	^16.! !

!FishEyeMorph methodsFor: 'private' stamp: 'ar 5/28/2000 12:12'!
magnifiedForm
	| warp warpForm fromForm |

	savedExtent ~= srcExtent ifTrue: [
		savedExtent _ srcExtent.
		self calculateTransform].

	warpForm _ Form extent: srcExtent depth: Display depth.
	fromForm _ super magnifiedForm.

	warp _  (WarpBlt current toForm: warpForm)
		sourceForm: fromForm;
		colorMap: nil;
		cellSize: 2;
		combinationRule: Form over.

	1 to: gridNum y do: [:j |
		1 to: gridNum x do: [:i |
			warp
				clipRect: ((clipRects at: j) at: i);
				copyQuad: ((quads at: j) at: i)
					toRect: ((toRects at: j) at: i).
		].
	].
	^warpForm
! !


!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 12:00'!
calculateTransform
	| stepX stepY rect tx ty arrayX arrayY |
	(gridNum x = 0 or: [gridNum y = 0]) ifTrue: [^self].
	stepX _ srcExtent x // gridNum x.
	stepY _ srcExtent y // gridNum y.

	arrayX _ (1 to: gridNum y + 1) collect: [:j | FloatArray new: gridNum x + 1].
	arrayY _ (1 to: gridNum y + 1) collect: [:j |  FloatArray new: gridNum x + 1].

	0 to: gridNum y do: [:j |
		0 to: gridNum x do: [:i |
			(arrayX at: (j + 1)) at: (i + 1) put: i*stepX.
			(arrayY at: (j + 1)) at: (i + 1) put: j*stepY.
		].
	].

	0 to: gridNum y do: [:j |
		self transformX: (arrayX at: (j+1)).
		self transformY: (arrayY at: (j+1)).
	].

	0 to: gridNum y do: [:j |
		arrayX at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayX at: (j+1)) at: i) asInteger]).
		arrayY at: (j+1) put: ((1 to: gridNum x +1) collect: [:i | ((arrayY at: (j+1)) at: i) asInteger]).
	].


	clipRects _ (1 to: gridNum y) collect: [:j | Array new: gridNum x].
	toRects _ (1 to: gridNum y) collect: [:j |  Array new: gridNum x].
	quads _ (1 to: gridNum y) collect: [:j |  Array new: gridNum x].
	0 to: gridNum y - 1 do: [:j |
		0 to: gridNum x- 1 do: [:i |
			rect _ (((arrayX at: (j+1)) at: (i+1))@((arrayY at: (j+1)) at: (i+1)))
						corner: ((arrayX at: (j+2)) at: (i+2))@((arrayY at: (j+2)) at: (i+2)).
			(clipRects at: j+1) at: i+1 put: rect.

			rect width >= stepX ifTrue: [rect _ rect expandBy: (1@0)].
			rect height >= stepY ifTrue: [rect _ rect expandBy: (0@1)].
			(toRects at: j+1) at: i+1 put: rect.

			tx _ (i)*stepX.
			ty _ (j)*stepY.
			(quads at: j+1) at: i+1
						put: {(tx)@(ty). (tx)@(ty+stepY). (tx+stepX)@(ty+stepY). (tx+stepX)@(ty)}.
		].
	].

! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 10:15'!
g: aFloatArray max: max focus: focus
	| dNormX array |

	dNormX _ aFloatArray - focus.
	
	array _ dNormX / max.
	array *= d.
	array += 1.0.
	array _ 1.0 / array.
	dNormX *= (d+1.0).
	array *= dNormX.
	^array += focus.
! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 12:41'!
initialize
	super initialize.
	"magnification should be always 1"
	magnification _ 1.
	d _ 1.3.
	self extent: 130@130.
! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 12:32'!
transformX: aFloatArray
	| focus gridNum2 subArray dMaxX |

	focus _ srcExtent x asFloat / 2.

	gridNum2 _ (aFloatArray findFirst: [:x | x > focus]) - 1.

	dMaxX _ 0.0 - focus.
	subArray _ self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus.

	aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1.


	dMaxX _ focus.    " = (size - focus)".
	subArray _ self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1)
		max: dMaxX focus: focus.

	aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1.
! !

!FishEyeMorph methodsFor: 'initialization' stamp: 'yo 12/17/1999 11:42'!
transformY: aFloatArray
	| focus subArray dMaxY |

	focus _ srcExtent y asFloat / 2.

	(aFloatArray at: 1) <= focus ifTrue: [
		dMaxY _ 0.0 - focus.
	] ifFalse: [
		dMaxY _ focus.    " = (size - focus)".
	].
		
	subArray _ self g: (aFloatArray copyFrom: 1 to: gridNum x + 1) max: dMaxY focus: focus.

	aFloatArray replaceFrom: 1 to: gridNum x + 1 with: subArray startingAt: 1.

! !


!FishEyeMorph methodsFor: 'menus' stamp: 'yo 12/17/1999 12:32'!
chooseMagnification
	self inform: 'Magnification is fixed, sorry.'! !


!FishEyeMorph methodsFor: 'events' stamp: 'yo 12/17/1999 12:03'!
chooseMagnification: evt
! !


!FishEyeMorph methodsFor: 'geometry' stamp: 'yo 12/17/1999 12:27'!
extent: aPoint
	"Round to a number divisible by grid.  Note that the superclass has its own implementation."
	| g gridSize |
	gridSize _ self gridSizeFor: aPoint.
	"self halt."
	g _ (aPoint - (2 * borderWidth)) // gridSize.
	srcExtent _ g * gridSize.
	gridNum _ g.
	^super extent: self defaultExtent! !
ReferenceMorph subclass: #FlapTab
	instanceVariableNames: 'flapShowing edgeToAdhereTo slidesOtherObjects popOutOnDragOver popOutOnMouseOver inboard dragged lastReferentThickness '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!FlapTab commentStamp: '<historical>' prior: 0!
The tab associated with a flap.

nb: slidesOtherObjects and inboard are instance variables relating to disused features.  The feature implementations still exist in the system, but the UI to them has been sealed off.!


!FlapTab methodsFor: 'initialization' stamp: 'tk 12/11/2000 16:29'!
adaptToWorld
	| wasShowing new |
	(wasShowing _ self flapShowing) ifTrue:
					[self hideFlap].
	(self respondsTo: #unhibernate) ifTrue: [
		(new _ self unhibernate) == self ifFalse: [
			^ new adaptToWorld]].
	self spanWorld.
	self positionObject: self.
	wasShowing ifTrue:
		[self showFlap]! !

!FlapTab methodsFor: 'initialization' stamp: 'sw 2/16/1999 23:44'!
initialize
	super initialize.

	edgeToAdhereTo _ #left.
	flapShowing _ false.
	slidesOtherObjects _ false.
	popOutOnDragOver _ false.
	popOutOnMouseOver _ false.
	inboard _ false.
	dragged _ false! !

!FlapTab methodsFor: 'initialization' stamp: 'sw 6/20/1999 19:17'!
preserveDetails
	"The receiver is being switched to use a different format.  Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right"

	| thickness |
	color = Color transparent ifFalse: [self setProperty: #priorColor toValue: color].
	self isCurrentlyTextual
		ifTrue:
			[self setProperty: #priorWording toValue: self existingWording]
		ifFalse:
			[self isCurrentlyGraphical
				ifTrue:
					[self setProperty: #priorGraphic toValue: submorphs first form]
				ifFalse:
					[thickness _ (self orientation == #vertical)
						ifTrue:	[self width]
						ifFalse:	[self height].
					self setProperty: #priorThickness toValue: thickness]]! !


!FlapTab methodsFor: 'access' stamp: 'sw 2/9/1999 14:44'!
flapShowing
	^ flapShowing == true! !

!FlapTab methodsFor: 'access' stamp: 'sw 1/25/2000 11:07'!
isCandidateForAutomaticViewing
	^ false! !

!FlapTab methodsFor: 'access' stamp: 'sw 12/13/1999 11:51'!
isGlobal
	^ Utilities globalFlapTabsIfAny includes: self! !

!FlapTab methodsFor: 'access' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber
	^self flapShowing ifTrue: [26] ifFalse: [25] 	"As navigators"! !

!FlapTab methodsFor: 'access' stamp: 'sw 2/26/1999 20:37'!
orientation
	^ (#(left right) includes: edgeToAdhereTo)
		ifTrue:		[#vertical]
		ifFalse:		[#horizontal]! !

!FlapTab methodsFor: 'access' stamp: 'sw 6/16/1999 11:29'!
permitsThumbnailing
	^ false! !

!FlapTab methodsFor: 'access' stamp: 'sw 6/18/1999 13:38'!
referentThickness
	^ (self orientation == #horizontal)
		ifTrue:
			[referent height]
		ifFalse:
			[referent width]! !

!FlapTab methodsFor: 'access' stamp: 'sw 2/27/1999 13:14'!
tabThickness
	^ (self orientation == #vertical)
		ifTrue:
			[self width]
		ifFalse:
			[self height]! !


!FlapTab methodsFor: 'parts bin' stamp: 'sw 9/21/2000 22:49'!
partsBinString
	"Answer the string to be shown in a menu to represent the parts-bin status"

	^ referent isPartsBin
		ifTrue:	['<yes>parts-bin']
		ifFalse:	['<no>parts-bin']! !

!FlapTab methodsFor: 'parts bin' stamp: 'sw 2/25/1999 13:17'!
togglePartsBinMode
	referent setPartsBinStatusTo: referent isPartsBin not! !


!FlapTab methodsFor: 'edge' stamp: 'sw 6/21/1999 11:13'!
edgeString
	^ 'cling to edge... (current: ', edgeToAdhereTo, ')'! !

!FlapTab methodsFor: 'edge' stamp: 'sw 2/11/1999 00:41'!
edgeToAdhereTo
	^ edgeToAdhereTo! !

!FlapTab methodsFor: 'edge' stamp: 'sw 2/11/1999 00:32'!
edgeToAdhereTo: e
	edgeToAdhereTo _ e! !

!FlapTab methodsFor: 'edge' stamp: 'sw 12/8/1999 15:01'!
setEdge: anEdge
	| changedOrientation |
	changedOrientation _ nil.
	self orientation == #vertical
			ifTrue:
				[(#(top bottom) includes: anEdge) ifTrue:
					[changedOrientation _ #horizontal]]
			ifFalse:
				[(#(top bottom) includes: anEdge) ifFalse:
					[changedOrientation _ #vertical]].
	changedOrientation ifNotNil:
		[^ self inform:
'SORRY -- this sort of switch from horizontal to vertical
or vice-versa is not yet permitted.  For now, to achieve
the desired effect, create a new flap and copy over
the elements you want.'].

	self isCurrentlyTextual ifTrue:
		[changedOrientation ifNotNil:
			[self assumeString: (submorphs first contents copyWithout: Character cr) font:  Preferences standardFlapFont orientation: changedOrientation color: self color]].

	self edgeToAdhereTo: anEdge.
	changedOrientation ifNotNil:
		[self transposeParts].
	referent isInWorld ifTrue: [self positionReferent].
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'edge' stamp: 'RAA 6/12/2000 08:58'!
setEdgeToAdhereTo
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	#(left top right bottom) do:
		[:sym | aMenu add: sym asString target: self selector:  #setEdge: argument: sym].
	aMenu popUpEvent: self currentEvent in: self world! !


!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 22:30'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	aMenu add: 'tab color...' target: self action: #changeColor.
	aMenu add: 'flap color...' target: self action: #changeFlapColor


! !

!FlapTab methodsFor: 'menu' stamp: 'sw 11/6/2000 14:52'!
addCustomMenuItems: aMenu hand: aHandMorph
	"Add further items to the menu as appropriate"

	aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo.
	aMenu addLine.
	aMenu addUpdating: #textualTabString action: #textualTab.
	aMenu addUpdating: #graphicalTabString action: #graphicalTab.
	aMenu addUpdating: #solidTabString enablement: #notSolid action: #solidTab.
	aMenu addLine.

	(referent isKindOf: PasteUpMorph) ifTrue: 
		[aMenu addUpdating: #partsBinString action: #togglePartsBinMode].
	aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior.
	aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior.
	aMenu addLine.
	aMenu addUpdating: #isGlobalFlapString action: #toggleIsGlobalFlap.
	aMenu balloonTextForLastItem: 'If checked, this flap will be available in all morphic projects; if not, it will be private to this project.,'.

	aMenu addLine.
	aMenu add: 'destroy this flap' action: #destroyFlap.

	"aMenu addUpdating: #slideString action: #toggleSlideBehavior.
	aMenu addUpdating: #inboardString action: #toggleInboardness.
	aMenu addUpdating: #thicknessString ('thickness... (current: ', self thickness printString, ')') action: #setThickness."

! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/19/1999 23:16'!
addTitleForHaloMenu: aMenu
	aMenu addTitle: self externalName updatingSelector: #flapMenuTitle updateTarget: self! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 23:41'!
applyThickness: newThickness
	| toUse |
	toUse _ newThickness asNumber max: 0.
	(self orientation == #vertical)
			ifTrue:
				[referent width: toUse]
			ifFalse:
				[referent height: toUse].
	self positionReferent. 
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 22:29'!
changeColor
	self isCurrentlyGraphical
		ifTrue:
			[^ self inform: 'Color only pertains to a flap tab when the 
tab is textual or "solid".  This tab is
currently graphical, so color-choice
does not apply.' ].
	super changeColor
	
! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/20/1999 23:14'!
changeFlapColor
	(self flapShowing)
		ifTrue:
			[referent changeColor]
		ifFalse:
			[self inform: 'The flap itself needs to be open
before you can change its
color.']! !

!FlapTab methodsFor: 'menu' stamp: 'sw 3/25/1999 10:52'!
destroyFlap
	| reply request |
	request _ self isGlobal
		ifTrue:
			['Caution -- this would permanently
remove this flap, so it would no longer be
available in this or any other project.
Do you really want to this? ']
		ifFalse:
			['Caution -- this is permanent!!  Do
you really want to do this? '].
	reply _ self confirm: request orCancel: [^ self].
	reply ifTrue:
		[self isGlobal
			ifTrue:
				[Utilities removeFlapTab: self keepInList: false]
			ifFalse:
				[referent isInWorld ifTrue: [referent delete].
				self delete]]! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/17/1999 14:20'!
dismissViaHalo
	referent delete.
	self delete.! !

!FlapTab methodsFor: 'menu' stamp: 'sw 7/8/1999 15:44'!
flapMenuTitle
	^ 'flap: ', self wording! !

!FlapTab methodsFor: 'menu' stamp: 'sw 6/14/1999 16:38'!
thicknessString
	^ 'thickness... (currently ', self thickness printString, ')'! !

!FlapTab methodsFor: 'menu' stamp: 'ar 12/18/2000 16:38'!
wording
	^ self isCurrentlyTextual
		ifTrue:
			[self existingWording]
		ifFalse:
			[self valueOfProperty: #priorWording ifAbsent: ['---']]! !


!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 4/7/2000 07:52'!
arrangeToPopOutOnDragOver: aBoolean
	aBoolean
		ifTrue:
			[self on: #mouseEnterDragging send: #showFlapIfHandLaden: to: self.
			referent on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self.
			self on: #mouseLeaveDragging send: #maybeHideFlapOnMouseLeaveDragging to: self]
		ifFalse:
			[self on: #mouseEnterDragging send: nil to: nil.
			referent on: #mouseLeaveDragging send: nil to: nil.
			self on: #mouseLeaveDragging send: nil to: nil]! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/16/1999 23:31'!
arrangeToPopOutOnMouseOver: aBoolean
	aBoolean
		ifTrue:
			[self on: #mouseEnter send: #showFlap to: self.
			referent on: #mouseLeave send: #hideFlapUnlessBearingHalo to: self.
			self on: #mouseLeave send: #maybeHideFlapOnMouseLeave to: self]
		ifFalse:
			[self on: #mouseEnter send: nil to: nil.
			self on: #mouseLeave send: #nil to: nil.
			referent on: #mouseLeave send: nil to: nil]! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 9/21/2000 22:49'!
dragoverString
	"Answer the string to be shown in a menu to represent the dragover status"

	^ popOutOnDragOver
		ifTrue:
			['<yes>pop out on dragover']
		ifFalse:
			['<no>pop out on dragover']! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 9/21/2000 22:49'!
mouseoverString
	"Answer the string to be shown in a menu to represent the mouseover status"

	^ popOutOnMouseOver
		ifTrue:
			['<yes>pop out on mouseover']
		ifFalse:
			['<no>pop out on mouseover']! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:53'!
setToPopOutOnDragOver: aBoolean
	self arrangeToPopOutOnDragOver:  (popOutOnDragOver _ aBoolean)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/25/1999 14:52'!
setToPopOutOnMouseOver: aBoolean
	self arrangeToPopOutOnMouseOver:  (popOutOnMouseOver _ aBoolean)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:10'!
toggleDragOverBehavior
	self arrangeToPopOutOnDragOver:  (popOutOnDragOver _ popOutOnDragOver not)! !

!FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 2/15/1999 14:07'!
toggleMouseOverBehavior
	self arrangeToPopOutOnMouseOver:  (popOutOnMouseOver _ popOutOnMouseOver not)! !


!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 18:13'!
adjustPositionVisAVisFlap
	| sideToAlignTo opposite |
	opposite _ Utilities oppositeSideTo: edgeToAdhereTo.
	sideToAlignTo _ inboard
		ifTrue:	[opposite]
		ifFalse:	[edgeToAdhereTo].
	self perform: (Utilities simpleSetterFor: sideToAlignTo) with: (referent perform: opposite)! !

!FlapTab methodsFor: 'positioning' stamp: 'ar 10/26/2000 17:52'!
fitOnScreen
	"19 sept 2000 - allow flaps in any paste up"
	| constrainer |
	constrainer _ owner ifNil: [self].
	self flapShowing "otherwise no point in doing this"
		ifTrue:[self spanWorld].
	self orientation == #vertical ifTrue: [
		self top: ((self top min: (constrainer bottom- self height)) max: constrainer top).
	] ifFalse: [
		self left: ((self left min: (constrainer right - self width)) max: constrainer left).
	].
	self flapShowing ifFalse: [self positionObject: self atEdgeOf: constrainer].
! !

!FlapTab methodsFor: 'positioning' stamp: 'ar 10/26/2000 17:36'!
layoutChanged
	self fitOnScreen.
	^super layoutChanged! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 7/6/1999 10:08'!
mouseMove: evt
	| aPosition newReferentThickness adjustedPosition thick |

	dragged ifFalse: [(thick _ self referentThickness) > 0
			ifTrue: [lastReferentThickness _ thick]].
	((self containsPoint: (aPosition _ evt cursorPoint)) and: [dragged not])
		ifFalse:
			[flapShowing ifFalse: [self showFlap].
			adjustedPosition _ aPosition - evt hand targetOffset.
			(edgeToAdhereTo == #bottom)
				ifTrue:
					[newReferentThickness _ inboard
						ifTrue:
							[self world height - adjustedPosition y]
						ifFalse:
							[self world height - adjustedPosition y - self height]].

			(edgeToAdhereTo == #left)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[adjustedPosition x + self width]
								ifFalse:
									[adjustedPosition x]].

			(edgeToAdhereTo == #right)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[self world width - adjustedPosition x]
								ifFalse:
									[self world width - adjustedPosition x - self width]].

			(edgeToAdhereTo == #top)
					ifTrue:
						[newReferentThickness _
							inboard
								ifTrue:
									[adjustedPosition y + self height]
								ifFalse:
									[adjustedPosition y]].
		
			self isCurrentlySolid ifFalse:
				[(#(left right) includes: edgeToAdhereTo)
					ifFalse:
						[self left: adjustedPosition x]
					ifTrue:
						[self top: adjustedPosition y]].

			self applyThickness: newReferentThickness.

			dragged _ true.

		self fitOnScreen]! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 7/6/1999 08:54'!
mouseUp: evt
	super mouseUp: evt.
	self referentThickness <= 0 ifTrue: [flapShowing _ false].
	dragged _ false.
	self fitOnScreen.! !

!FlapTab methodsFor: 'positioning' stamp: 'ar 10/26/2000 17:36'!
ownerChanged
	self fitOnScreen.
	^super ownerChanged.! !

!FlapTab methodsFor: 'positioning' stamp: 'RAA 9/19/2000 12:16'!
positionObject: anObject
        "anObject could be myself or my referent"

"Could consider container _ referent pasteUpMorph, to allow flaps on things other than the world, but for the moment, let's skip it!!"

	"19 sept 2000 - going for all paste ups"

	^self 
		positionObject: anObject 
		atEdgeOf: (self pasteUpMorph ifNil: [^ self])! !

!FlapTab methodsFor: 'positioning' stamp: 'RAA 6/14/2000 19:35'!
positionObject: anObject atEdgeOf: container
        "anObject could be myself or my referent"

        edgeToAdhereTo == #left ifTrue: [^ anObject left: container left].
        edgeToAdhereTo == #right ifTrue: [^ anObject right: container right].
        edgeToAdhereTo == #top ifTrue: [^ anObject top: container top].
        edgeToAdhereTo == #bottom ifTrue: [^ anObject bottom: container bottom]! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 2/16/1999 17:58'!
positionReferent
	self positionObject: referent! !

!FlapTab methodsFor: 'positioning' stamp: 'ar 12/17/2000 22:28'!
spanWorld
	| container |

	container _ self pasteUpMorph ifNil: [self currentWorld].
	(self orientation == #vertical) ifTrue: [
		referent vResizing == #rigid 
			ifTrue:[referent height: container height].
		referent hResizing == #rigid 
			ifTrue:[referent width: (referent width min: container width - self width)].
		referent top: container top.
	] ifFalse: [
		referent hResizing == #rigid
			ifTrue:[referent width: container width].
		referent vResizing == #rigid
			ifTrue:[referent height: (referent height min: container height - self height)].
		referent left: container left.
	] ! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 2/11/1999 14:46'!
stickOntoReferent
	"Place the receiver directly onto the referent -- for use when the referent is being shown as a flap"
	| newPosition |
	referent addMorph: self.
	edgeToAdhereTo == #left
		ifTrue:
			[newPosition _ (referent width - self width) @ self top].
	edgeToAdhereTo == #right
		ifTrue:
			[newPosition _ (referent left @ self top)].
	edgeToAdhereTo == #top
		ifTrue:
			[newPosition _ self left @ (referent height - self height)].
	edgeToAdhereTo == #bottom
		ifTrue:
			[newPosition _ self left @ referent top].
	self position: newPosition! !

!FlapTab methodsFor: 'positioning' stamp: 'sw 3/2/1999 12:27'!
transposeParts
	"The receiver's orientation has just been changed from vertical to horizontal or vice-versa.  One could imagine trying to be smart about transposition, though the variety of possibilities is daunting."
	self flag: #deferred.
	"edgeToAdhereTo == #vertical ifTrue: ..."! !


!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/16/1999 17:58'!
adjustPositionAfterHidingFlap
	self positionObject: self! !

!FlapTab methodsFor: 'show & hide' stamp: 'tk 1/31/2001 12:27'!
hideFlap
	| aWorld |
	aWorld _ self world ifNil: [self currentWorld].
	referent privateDelete.
	aWorld removeAccommodationForFlap: self.
	flapShowing _ false.
	self isInWorld ifFalse: [aWorld addMorphFront: self].
	self adjustPositionAfterHidingFlap.
	aWorld haloMorphs do:
		[:m | m target isInWorld ifFalse: [m delete]]! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 12/29/1999 12:41'!
hideFlapUnlessBearingHalo
	self hasHalo ifFalse: [self hideFlapUnlessOverReferent]! !

!FlapTab methodsFor: 'show & hide' stamp: 'RAA 6/16/2000 18:46'!
hideFlapUnlessOverReferent
	| aWorld where |

	
	(referent isInWorld and: 
		[
			where _ self outermostWorldMorph activeHand lastEvent cursorPoint.
			referent bounds containsPoint: (referent globalPointToLocal: where)
		]
	) ifTrue: [^self].
	aWorld _ self world.
	self referent delete.
	aWorld removeAccommodationForFlap: self.
	flapShowing _ false.
	self isInWorld ifFalse:
		[self inboard ifTrue: [aWorld addMorphFront: self]].
	self adjustPositionAfterHidingFlap! !

!FlapTab methodsFor: 'show & hide' stamp: 'RAA 6/2/2000 14:07'!
maybeHideFlapOnMouseLeave
	self hasHalo ifTrue: [^ self].
	referent isInWorld ifFalse: [^ self].
	self hideFlapUnlessOverReferent.
! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 3/5/1999 17:42'!
maybeHideFlapOnMouseLeaveDragging
	| aWorld |
	self hasHalo ifTrue: [^ self].
	referent isInWorld ifFalse: [^ self].
	(dragged or: [referent bounds containsPoint: self cursorPoint])
		ifTrue:	[^ self].
	aWorld _ self world.
	referent privateDelete.  "could make me worldless if I'm inboard"
	aWorld ifNotNil: [aWorld removeAccommodationForFlap: self].
	flapShowing _ false.
	self isInWorld ifFalse: [aWorld addMorphFront: self].
	self adjustPositionAfterHidingFlap! !

!FlapTab methodsFor: 'show & hide' stamp: 'RAA 9/19/2000 12:17'!
showFlap
	| thicknessToUse flapOwner |

	"19 sept 2000 - going for all paste ups"

	flapOwner _ self pasteUpMorph.
	self referentThickness <= 0
		ifTrue:
			[thicknessToUse _ lastReferentThickness ifNil: [100].
			self orientation == #horizontal
				ifTrue:
					[referent height: thicknessToUse]
				ifFalse:
					[referent width: thicknessToUse]].
	inboard ifTrue:
		[self stickOntoReferent].  "makes referent my owner, and positions me accordingly"
	referent pasteUpMorph == flapOwner
		ifFalse:
			[flapOwner accommodateFlap: self.  "Make room if needed"
			flapOwner addMorphFront: referent.
			flapOwner startSteppingSubmorphsOf: referent.
			self positionReferent.
			referent adaptToWorld: flapOwner].
	inboard  ifFalse:
		[self adjustPositionVisAVisFlap].
	flapShowing _ true.
	
	flapOwner bringFlapTabsToFront! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 4/7/2000 07:51'!
showFlapIfHandLaden: evt
	"The hand has drifted over the receiver with the button down.  If the hand is carrying anything, show the flap.  If the hand is empty, the likely cause is that it's manipulating a scrollbar or some such, so in that case don't pop the flap out."

	evt hand hasSubmorphs ifTrue: [self showFlap]! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 12/29/1999 15:30'!
succeededInRevealing: aPlayer
	(super succeededInRevealing: aPlayer) ifTrue: [^ true].
	self flapShowing ifTrue: [^ false].
	(referent succeededInRevealing: aPlayer)
		ifTrue:
			[self showFlap.
			aPlayer costume addHalo.
			^ true].
	^ false! !

!FlapTab methodsFor: 'show & hide' stamp: 'sw 2/11/1999 15:52'!
tabSelected
	dragged == true ifTrue:
		[^ dragged _ false].
	self flapShowing
		ifTrue:
			[self hideFlap]
		ifFalse:
			[self showFlap]! !


!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/21/1999 11:09'!
assumeString: aString font: aFont orientation: anOrientation color: aColor
	| aTextMorph workString pad |
	pad _ (anOrientation == #vertical) 
		ifTrue:	[Character cr]
		ifFalse:	[$ ].
	workString _ pad asString.
	aString do:
		[:ch |
			workString _ workString copyWith: ch.
			workString _ workString copyWith: pad].
	(anOrientation == #vertical)
		ifTrue:
			[workString _ workString copyFrom: 2 to: workString size - 1].

	aTextMorph _ (TextMorph new beAllFont: aFont) width: 10; contents: workString; yourself.
	self removeAllMorphs.
	self addMorph: aTextMorph centered.
	aTextMorph lock.
	anOrientation == #horizontal
		ifTrue:
			[self borderWidth: 0]
		ifFalse:
			[self borderWidth: 3; borderColor: #raised].
	self fitContents.
	aColor ifNotNil: [self color: aColor].
	aTextMorph position: self position.
	self layoutChanged! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sma 6/18/2000 10:35'!
changeTabText
	| reply |
	reply _ FillInTheBlank
		request: 'new wording for this tab:'
		initialAnswer: self existingWording.
	reply isEmptyOrNil ifTrue: [^ self].
	self useStringTab: reply.
	submorphs first delete.
	self
		assumeString: reply
		font: Preferences standardFlapFont
		orientation: (Utilities orientationForEdge: edgeToAdhereTo)
		color: nil! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/17/1999 13:33'!
existingWording
	| longForm |
	longForm _ submorphs first contents.
	^ self orientation == #vertical
		ifTrue:
			[longForm asString copyWithout: Character cr]
		ifFalse:
			[(longForm asString collectWithIndex:
				[:ch :i | i even ifFalse: [$»] ifTrue: [ch]]) copyWithout: $»]! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/20/1999 19:19'!
isCurrentlyTextual
	| first |
	^ submorphs size > 0 and: [((first _ submorphs first) isKindOf: StringMorph) or: [first isKindOf: TextMorph]]! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 12/8/1999 18:16'!
reformatTextualTab
	"The font choice possibly having changed, reformulate the receiver"

	self isCurrentlyTextual ifFalse: [^ self].
	self assumeString: self existingWording font: Preferences standardFlapFont orientation: self orientation color: self color! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/17/1999 13:21'!
textualTab
	self isCurrentlyTextual
		ifTrue:
			[self changeTabText]
		ifFalse:
			[self useTextualTab]! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 6/20/1999 19:09'!
textualTabString
	^ self isCurrentlyTextual
		ifTrue:
			['change tab wording...']
		ifFalse:
			['use textual tab']! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 2/11/1999 00:29'!
useStringTab: aString
	| aLabel |
	aLabel _ StringMorph  new contents: aString asString.
	self addMorph: aLabel.
	aLabel position: self position.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged! !

!FlapTab methodsFor: 'textual tabs' stamp: 'sw 12/8/1999 15:01'!
useTextualTab
	| stringToUse colorToUse |
	self preserveDetails.
	colorToUse _ self valueOfProperty: #priorColor ifAbsent: [Color green muchLighter].
	submorphs size > 0 ifTrue: [self removeAllMorphs].
	stringToUse _ self valueOfProperty: #priorWording ifAbsent: ['Unnamed Flap'].
	self assumeString: stringToUse font:  Preferences standardFlapFont orientation: self orientation color: colorToUse! !


!FlapTab methodsFor: 'graphical tabs' stamp: 'sw 6/17/1999 16:07'!
graphicalTab
	self isCurrentlyGraphical
		ifTrue:
			[self changeTabGraphic]
		ifFalse:
			[self useGraphicalTab]! !

!FlapTab methodsFor: 'graphical tabs' stamp: 'sw 6/20/1999 19:10'!
graphicalTabString
	^ self isCurrentlyGraphical
		ifTrue:
			['choose new graphic...']
		ifFalse:
			['use graphical tab']! !

!FlapTab methodsFor: 'graphical tabs' stamp: 'sw 6/20/1999 19:20'!
isCurrentlyGraphical
	| first |
	^ submorphs size > 0 and:
		[((first _ submorphs first) isKindOf: ImageMorph) or: [first isKindOf: SketchMorph]]! !


!FlapTab methodsFor: 'solid tabs' stamp: 'sw 2/27/1999 13:16'!
applyTabThickness: newThickness
	(self orientation == #vertical)
			ifTrue:
				[submorphs first width: newThickness asNumber]
			ifFalse:
				[submorphs first height: newThickness asNumber].
	self fitContents.
	self positionReferent. 
	self adjustPositionVisAVisFlap! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:40'!
changeTabSolidity
	"Presently no actual options associated with this menu item if the flap is currently alreadly solid, so entertain the user with an anuran sound.  However, in latest scheme, the corresponding menu item is disabled in this circumstance, so this method is effectively unreachable."

	self playSoundNamed: 'croak'! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 2/27/1999 13:14'!
changeTabThickness
	| newThickness |
	newThickness _ FillInTheBlank request: 'New thickness:' initialAnswer: self tabThickness printString.
	newThickness size > 0 ifTrue:
		[self applyTabThickness: newThickness]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:39'!
isCurrentlySolid
	"Don't never use double negatives"

	^ self notSolid not! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/21/1999 11:36'!
notSolid
	"Answer whether the receiver is currenty not solid.  Used for determining whether the #solidTab menu item should be enabled"

	^ self isCurrentlyTextual or: [self isCurrentlyGraphical]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 21:34'!
solidTab
	self isCurrentlySolid
		ifFalse:
			[self useSolidTab]
		ifTrue:
			[self changeTabSolidity]! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 19:09'!
solidTabString
	^ self isCurrentlySolid
		ifTrue:
			['currently using solid tab']
		ifFalse:
			['use solid tab']! !

!FlapTab methodsFor: 'solid tabs' stamp: 'sw 6/20/1999 20:55'!
useSolidTab
	| thickness colorToUse |
	self preserveDetails.

	thickness _ self valueOfProperty: #priorThickness ifAbsent: [20].
	colorToUse _ self valueOfProperty: #priorColor ifAbsent: [Color red muchLighter].
	self color: colorToUse.
	self removeAllMorphs.
	
	(self orientation == #vertical)
		ifTrue:
			[self width: thickness.
			self height: self currentWorld height.
			self position: (self position x @ 0)]
		ifFalse:
			[self height: thickness.
			self width: self currentWorld width.
			self position: (0 @ self position y)].

	self borderWidth: 0.
	self layoutChanged.! !


!FlapTab methodsFor: 'disused options' stamp: 'sw 6/21/1999 13:03'!
inboard
	^ inboard == true! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/15/1999 12:57'!
inboard: aBoolean
	inboard _ aBoolean! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 6/14/1999 16:37'!
inboardString
	^ inboard
		ifTrue:
			['switch to being outboard']
		ifFalse:
			['switch to being inboard']! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 6/14/1999 16:35'!
slideString

	^ slidesOtherObjects
		ifTrue:
			['cease slide behavior']
		ifFalse:
			['start slide behavior']! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/11/1999 10:55'!
slidesOtherObjects
	^ slidesOtherObjects! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/11/1999 14:18'!
toggleInboardness
	self hideFlap.
	inboard _ inboard not.
	self showFlap! !

!FlapTab methodsFor: 'disused options' stamp: 'sw 2/11/1999 12:21'!
toggleSlideBehavior
	slidesOtherObjects _ slidesOtherObjects not! !


!FlapTab methodsFor: 'rounding' stamp: 'ar 9/1/2000 13:49'!
roundedCorners
	^self orientation == #vertical
		ifTrue:
			[edgeToAdhereTo == #right
				ifTrue:
					[#(1 2)]
				ifFalse:
					[#(3 4)]]
		ifFalse:
			[edgeToAdhereTo == #top
				ifTrue:
					[#(2 3)]
				ifFalse:
					[#(1 4)]].! !

!FlapTab methodsFor: 'rounding' stamp: 'ar 9/1/2000 13:53'!
wantsRoundedCorners
	^self isCurrentlyTextual! !


!FlapTab methodsFor: 'globalness' stamp: 'sw 11/6/2000 14:15'!
isGlobalFlap
	"Answer whether the receiver is currently a Global flap"

	^ Utilities globalFlapTabsIfAny includes: self! !

!FlapTab methodsFor: 'globalness' stamp: 'sw 11/6/2000 15:38'!
isGlobalFlapString
	"Answer a string to construct a menu item representing control over whether the receiver is or is not a global flap"

	^ (self isGlobalFlap
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'global (sharable by all projects)'! !

!FlapTab methodsFor: 'globalness' stamp: 'sw 11/6/2000 14:56'!
toggleIsGlobalFlap
	"Toggle whether the receiver is currently a global flap or not"

	| oldWorld |
	self hideFlap.  "In case showing"
	oldWorld _ self currentWorld.
	self isGlobalFlap
		ifTrue:
			[Utilities removeFromGlobalFlapTabList: self.
			oldWorld addMorphFront: self]
		ifFalse:
			[self delete.
			Utilities addGlobalFlap: self.
			self currentWorld addGlobalFlaps]
		! !


!FlapTab methodsFor: 'miscellaneous' stamp: 'ar 9/28/2000 13:53'!
isFlapTab
	^true! !

!FlapTab methodsFor: 'miscellaneous' stamp: 'sw 11/6/2000 14:07'!
mightEntertainDirectionHandles
	"Answer whether the receiver, by its very nature, might possibly be happy to have direction handles shown for it in its halo"

	^ false! !

!FlapTab methodsFor: 'miscellaneous' stamp: 'sw 11/6/2000 15:41'!
printOn: aStream
	"Append a textual representation of the receiver to aStream"

	super printOn: aStream.
	aStream nextPutAll: ' "', self wording, '"'! !


!FlapTab methodsFor: 'fileIn/out' stamp: 'tk 9/28/2000 15:42'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  If I am a global flap, write a proxy instead."

	(Utilities globalFlapTabsIfAny includes: self) ifTrue: [
		dp _ DiskProxy global: #Utilities selector: #globalFlapTabOrDummy: 
					args: {self flapMenuTitle}.
		refStrm replace: self with: dp.
		^ dp].

	^ super objectForDataStream: refStrm! !

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

FlapTab class
	instanceVariableNames: ''!

!FlapTab class methodsFor: 'as yet unclassified' stamp: 'sw 2/11/1999 14:39'!
defaultNameStemForInstances
	^ 'flap tab'! !

!FlapTab class methodsFor: 'as yet unclassified' stamp: 'kfr 5/3/2000 12:51'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
CompressedBoundaryShape subclass: #FlashBoundaryShape
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashBoundaryShape methodsFor: 'private' stamp: 'ar 11/3/1998 21:54'!
remapFills
	"Replace the fill style dictionary with an array"
	| indexMap newFillStyles index |
	(fillStyles isKindOf: Dictionary) ifFalse:[^false].
	indexMap _ Dictionary new.
	indexMap at: 0 put: 0. "Map zero to zero"
	newFillStyles _ Array new: fillStyles size.
	index _ 1.
	fillStyles associationsDo:[:assoc|
		indexMap at: assoc key put: index.
		newFillStyles at: index put: assoc value.
		index _ index + 1.
	].
	leftFills _ leftFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	rightFills _ rightFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	lineFills _ lineFills valuesCollect:[:value| indexMap at: value ifAbsent:[0]].
	fillStyles _ newFillStyles! !


!FlashBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/9/1998 02:30'!
complexity
	^points size // 3! !


!FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:44'!
compress
	(points isKindOf: String) ifFalse:[
		points _ FlashCodec compress: self.
		leftFills _ rightFills _ lineWidths _ lineFills _ fillStyles _ nil].! !

!FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:46'!
decompress
	| newShape |
	(points isKindOf: String) ifTrue:[
		newShape _ FlashCodec decompress: (ReadStream on: points).
		points _ newShape points.
		leftFills _ newShape leftFills.
		rightFills _ newShape rightFills.
		lineWidths _ newShape lineWidths.
		lineFills _ newShape lineFills.
		fillStyles _ newShape fillStyles].! !
FlashCharacterMorph subclass: #FlashButtonMorph
	instanceVariableNames: 'events sounds target '
	classVariableNames: 'ActionHelpText '
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:04'!
defaultLook: aMorph
	"Assign the default look"
	aMorph setProperty: #defaultLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:26'!
loadInitialFrame
	"Resort our children"
	super loadInitialFrame.
	submorphs _ submorphs sortBy:[:m1 :m2| m1 depth > m2 depth].
	self lookEnable: #(defaultLook) disable:#(sensitive overLook pressLook)! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:25'!
overLook: aMorph
	"Assign the look if the mouse if over"
	aMorph setProperty: #overLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:25'!
pressLook: aMorph
	"Assign the look if the mouse is pressed"
	aMorph setProperty: #pressLook toValue: true.
	self addMorph: aMorph.! !

!FlashButtonMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 21:04'!
sensitiveLook: aMorph
	"Assign the look for the sensitive area."
	aMorph setProperty: #sensitive toValue: true.
	self addMorph: aMorph! !


!FlashButtonMorph methodsFor: 'accessing' stamp: 'ar 10/15/1998 21:16'!
addSound: aSound forState: state
	sounds ifNil:[sounds _ Dictionary new].
	sounds at: state put: aSound.! !

!FlashButtonMorph methodsFor: 'accessing' stamp: 'di 11/12/2000 15:59'!
ownerSprite
	"Return the sprite owning the receiver.
	The owning sprite is responsible for executing
	the actions associated with the button."
	^ self orOwnerSuchThat: [:sprite | sprite isFlashMorph and: [sprite isFlashSprite]]! !

!FlashButtonMorph methodsFor: 'accessing' stamp: 'ar 11/20/1998 02:03'!
trackAsMenu: aBoolean
	"Currently unused"
	aBoolean 
		ifTrue:[self setProperty: #trackAsMenu toValue: true]
		ifFalse:[self removeProperty: #trackAsMenu].! !


!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/12/1999 15:47'!
executeActions: type
	| rcvr |
	(events isNil or:[events isEmpty]) ifTrue:[^self].
	rcvr _ target.
	rcvr ifNil:[rcvr _ self ownerSprite].
	rcvr isNil ifTrue:[^self].
	(events at: type ifAbsent:[^self]) do:[:action|
		action sentTo: rcvr.
	].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:16'!
executeSounds: type
	| sound |
	(sounds isNil or:[sounds isEmpty]) ifTrue:[^self].
	sound _ sounds at: type ifAbsent:[^self].
	sound isPlaying & false ifFalse:[sound play].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/16/1998 23:25'!
handlesMouseDown: evt
	^self visible! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/19/1998 20:32'!
handlesMouseOver: evt
	"Handle mouse events only if I am visible,"
	^self visible! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/16/1998 23:24'!
handlesMouseOverDragging: evt
	^false! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:32'!
mouseDown: evt
	self lookEnable: #(pressLook) disable:#(overLook).
	self executeSounds: #mouseDown.
	self executeActions: #mouseDown.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/21/1998 02:30'!
mouseEnter: evt
	self lookEnable: #(overLook) disable:#(pressLook defaultLook).
	evt hand needsToBeDrawn ifFalse:[Cursor webLink show].
	self executeSounds: #mouseEnter.
	evt anyButtonPressed
		ifTrue:[self executeActions: #mouseEnterDown]
		ifFalse:[self executeActions: #mouseEnter].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/21/1998 02:30'!
mouseLeave: evt
	self lookEnable: #(defaultLook) disable:#(pressLook overLook).
	evt hand needsToBeDrawn ifFalse:[Cursor normal show].
	self executeSounds: #mouseLeave.
	evt anyButtonPressed
		ifTrue:[self executeActions: #mouseLeaveDown]
		ifFalse:[self executeActions: #mouseLeave].! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 10/15/1998 21:08'!
mouseMove: evt! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/10/1999 04:33'!
mouseUp: evt
	self lookEnable:#(overLook) disable:#(pressLook).
	self executeSounds: #mouseUp.
	self executeActions: #mouseUp.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/12/1999 15:48'!
on: eventName send: action
	"Note: We handle more than the standard Morphic events here"
	^self on: eventName sendAll:(Array with: action).! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 11/20/1998 02:09'!
on: eventName sendAll: actions
	"Note: We handle more than the standard Morphic events here"
	| actionList |
	events ifNil:[events _ Dictionary new].
	self analyzeActionsForBalloonHelp: actions.
	actionList _ events at: eventName ifAbsent:[#()].
	actionList _ actionList, actions.
	events at: eventName put: actionList.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:52'!
simulateMouseDown
	"Invoked from a client --  simulate mouse down"
	self lookEnable: #(pressLook) disable:#(overLook).
	self executeSounds: #mouseDown.
	self executeActions: #mouseDown.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:52'!
simulateMouseEnter
	"Invoked from a client -- simulate mouseEnter"
	self lookEnable: #(overLook) disable:#(pressLook defaultLook).
	self executeSounds: #mouseEnter.
	self executeActions: #mouseEnter.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:53'!
simulateMouseLeave
	"Invoked from a client -- simulate mouse leave"
	self lookEnable: #(defaultLook) disable:#(pressLook overLook).
	self executeSounds: #mouseLeave.
	self executeActions: #mouseLeave.! !

!FlashButtonMorph methodsFor: 'event handling' stamp: 'ar 2/11/1999 03:53'!
simulateMouseUp
	"Invoked from a client -- simulate mouse up"
	self lookEnable:#(overLook) disable:#(pressLook).
	self executeSounds: #mouseUp.
	self executeActions: #mouseUp.! !


!FlashButtonMorph methodsFor: 'geometry' stamp: 'ar 11/16/1998 21:46'!
containsPoint: aPoint
	| localPt |
	(self bounds containsPoint: aPoint) ifFalse:[^false].
	localPt _ self transform globalPointToLocal: aPoint.
	submorphs do:[:m| 
		((m valueOfProperty: #sensitive) ifNil:[false]) ifTrue:[
			(m bounds containsPoint: localPt) ifTrue:[^true].
		].
	].
	^false! !

!FlashButtonMorph methodsFor: 'geometry' stamp: 'ar 11/16/1998 21:09'!
lookEnable: list1 disable: list2
	self changed.
	submorphs do:[:m|
		list2 do:[:sym|
			((m valueOfProperty: sym) ifNil:[false]) ifTrue:[m visible: false].
		].
		list1 do:[:sym|
			((m valueOfProperty: sym) ifNil:[false]) ifTrue:[m visible: true].
		].
	].
	self computeBounds.
	self changed.! !


!FlashButtonMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 23:47'!
isFlashButton
	^true! !

!FlashButtonMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true if the receiver is mouse sensitive and must stay unlocked"
	^true! !


!FlashButtonMorph methodsFor: 'balloon help' stamp: 'ar 11/20/1998 15:15'!
analyzeActionsForBalloonHelp: actionList
	| helpText |
	actionList do:[:msg|
		helpText _ ActionHelpText at: msg selector ifAbsent:[nil].
		helpText ifNotNil:[self setBalloonText: helpText].
	].
! !


!FlashButtonMorph methodsFor: 'printing' stamp: 'ar 11/21/1998 01:36'!
printOn: aStream
	super printOn: aStream.
	events ifNil:[^self].
	aStream nextPut:$[.
	events keys do:[:k| aStream print: k; space].
	aStream nextPut: $].! !


!FlashButtonMorph methodsFor: 'menu' stamp: 'ar 2/23/1999 00:37'!
addCustomAction
	| string code |
	string _ FillInTheBlank request:'Enter the Smalltalk code to execute:' initialAnswer:'Smalltalk beep.'.
	string isEmpty ifTrue:[^self].
	string _ '[', string,']'.
	code _ Compiler evaluate: string for: self notifying: nil logged: false.
	self removeActions.
	target _ code.
	self on: #mouseDown send:(Message selector: #value).! !

!FlashButtonMorph methodsFor: 'menu' stamp: 'ar 2/23/1999 00:27'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'set custom action' action: #addCustomAction.
	aCustomMenu add: 'remove all actions' action: #removeActions.
! !

!FlashButtonMorph methodsFor: 'menu' stamp: 'ar 2/23/1999 00:37'!
removeActions
	events _ nil.
	target _ nil.! !


!FlashButtonMorph methodsFor: 'event processing' stamp: 'ar 9/12/2000 23:05'!
handlerForMouseDown: anEvent
	"Don't give anybody over me a chance"
	^self! !

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

FlashButtonMorph class
	instanceVariableNames: ''!

!FlashButtonMorph class methodsFor: 'class initialization' stamp: 'ar 11/20/1998 22:58'!
initialize
	"FlashButtonMorph initialize"
	ActionHelpText _ Dictionary new.
	#(	(getURL:window: 'Jump to URL')
		(gotoFrame: 'Continue playing')
		(gotoLabel: 'Continue playing')
		(gotoNextFrame 'Continue playing')
		(gotoPrevFrame 'Continue playing')
		(actionPlay 'Continue playing')
		(actionStop 'Stop playing')
		(stopSounds 'Stop all sounds')
		(toggleQuality 'Toggle display quality')
	) do:[:spec| ActionHelpText at: spec first put: spec last].! !
FlashMorph subclass: #FlashCharacterMorph
	instanceVariableNames: 'id stepTime frame renderTime vData mData dData cmData rData '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashCharacterMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 18:03'!
initialize
	super initialize.
	frame _ 1.
	self reset.! !

!FlashCharacterMorph methodsFor: 'initialize' stamp: 'ar 9/1/1999 15:25'!
loadInitialFrame
	"Force the transformations taking place in the first frame."
	super loadInitialFrame.
	self stepToFrame: 1.
	(self isSpriteHolder and:[self visible]) ifTrue:[self activateSprites: true].! !

!FlashCharacterMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 18:02'!
reset
	self removeAllKeyFrameData.
	self matrix: MatrixTransform2x3 identity atFrame: 0.
	self visible: false atFrame: 0.
	self depth: 0 atFrame: 0.
	self ratio: 0.0 atFrame: 0.
	self visible: true.
! !


!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/13/1998 13:40'!
activationKeys
	"Return the keyframes on which the receiver morph becomes visible"
	^self visibleData keys select:[:key| self visibleAtFrame: key]! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 10/3/1998 21:39'!
depth
	^self depthAtFrame: frame! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 8/14/1998 18:19'!
id
	^id! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 8/14/1998 18:19'!
id: aNumber
	id _ aNumber! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:32'!
isSpriteHolder
	^self hasProperty: #spriteHolder! !

!FlashCharacterMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:32'!
isSpriteHolder: aBoolean
	aBoolean
		ifTrue:[self setProperty: #spriteHolder toValue: true]
		ifFalse:[self removeProperty: #spriteHolder]! !


!FlashCharacterMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:52'!
isFlashCharacter
	^true! !


!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:50'!
colorTransform: aColorTransform atFrame: frameNumber
	self colorTransformData at: frameNumber put: aColorTransform! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:51'!
colorTransformAtFrame: frameNumber
	^self colorTransformData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/24/1998 14:51'!
colorTransformData
	^cmData
	"^self keyframeData: #colorMatrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:20'!
depth: aNumber atFrame: frameNumber
	self depthData at: frameNumber put: aNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:20'!
depthAtFrame: frameNumber
	^self depthData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:15'!
depthData
	^dData
	"^self keyframeData: #depthData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:11'!
matrix: aMatrixTransform atFrame: frameNumber
	"self position: aMatrixTransform offset atFrame: frameNumber."
	self matrixData at: frameNumber put: aMatrixTransform.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:12'!
matrixAtFrame: frameNumber
	^(self matrixData at: frameNumber) "copy offset: (self positionAtFrame: frameNumber)"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:15'!
matrixData
	^mData
	"^self keyframeData: #matrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
ratio: aNumber atFrame: frameNumber
	^self ratioData at: frameNumber put: aNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
ratioAtFrame: frameNumber
	^self ratioData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:24'!
ratioData
	^rData! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:20'!
removeAllKeyFrameData
	"Remove all of the keyframe data associated with this morph"
	self removeColorMatrixData.
	self removeDepthData.
	self removeMatrixData.
	self removeVisibleData.
	self removeRatioData.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeColorMatrixData
	cmData _ FlashKeyframes new.
	"^self removeKeyframeData: #colorMatrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeDepthData
	dData _ FlashKeyframes new.
	"^self removeKeyframeData: #depthData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeMatrixData
	mData _ FlashKeyframes new.
	"^self removeKeyframeData: #matrixData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 9/3/1999 15:30'!
removeRatioData
	rData _ FlashKeyframes new.! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
removeVisibleData
	vData _ FlashKeyframes new.
	"^self removeKeyframeData: #visibilityData"! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 17:13'!
visible: aBool atFrame: frameNumber
	^self visibleData at: frameNumber put: aBool! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 8/14/1998 19:23'!
visibleAtFrame: frameNumber
	^self visibleData at: frameNumber! !

!FlashCharacterMorph methodsFor: 'keyframe data' stamp: 'ar 11/13/1998 15:16'!
visibleData
	^vData
	"^self keyframeData: #visibilityData"! !


!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 18:17'!
stepTime
	^stepTime ifNil:[super stepTime]! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 18:18'!
stepTime: aNumber
	stepTime _ aNumber! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 11/24/1998 14:52'!
stepToFrame: frameNumber
	| m wasVisible isVisible noTransform cm |
	wasVisible _ self visible.
	self visible: (self visibleAtFrame: frameNumber).
	isVisible _ self visible.
	frame _ frameNumber.
	isVisible ifTrue:[
		m _ self matrixAtFrame: frame.
		cm _ self colorTransformAtFrame: frame.
		noTransform _ (m = transform) and:[colorTransform = cm].
		(noTransform and:[isVisible = wasVisible]) ifTrue:[^self]. "No change"
		((noTransform not) and:[wasVisible]) ifTrue:[
			"Invalidate with old transform"
			self changed.
		].
		self transform: m.
		self colorTransform: cm.
		((noTransform not) and:[isVisible]) ifTrue:[
			"Invalidate with new transform"
			self changed.
		].
		((noTransform) and:[isVisible ~~ wasVisible]) ifTrue:[
			"Invalidate with new transform"
			self changed.
		].
	] ifFalse:[
		wasVisible ifTrue:[self changed].
	].
	(isVisible ~~ wasVisible and:[self isSpriteHolder])
		ifTrue:[self activateSprites: isVisible].! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 21:03'!
stepToNextFrame
	self stepToFrame: frame + 1.! !

!FlashCharacterMorph methodsFor: 'stepping' stamp: 'ar 11/13/1998 14:02'!
wantsSteps
	^false
	"^stepTime notNil"! !


!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 11/24/1998 14:34'!
activateSprites: aBool
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashSprite]) ifTrue:[
			aBool 
				ifTrue:[m startPlaying]
				ifFalse:[m stopPlaying].
		].
	].! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 5/19/1999 18:58'!
isVisibleBetween: firstFrame and: lastFrame
	firstFrame to: lastFrame do:[:frameNr| 
		(self visibleAtFrame: frameNr) ifTrue:[^true]].
	^false! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 8/14/1998 20:03'!
keyframeData: aSymbol
	| data |
	data _ self valueOfProperty: aSymbol.
	data isNil ifFalse:[^data].
	data _ FlashKeyframes new.
	self setProperty: aSymbol toValue: data.
	^data! !

!FlashCharacterMorph methodsFor: 'private' stamp: 'ar 9/20/1998 23:41'!
removeKeyframeData: aSymbol
	self removeProperty: aSymbol.! !


!FlashCharacterMorph methodsFor: 'printing' stamp: 'ar 9/1/1999 15:19'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPutAll:'(renderTime = '; print: renderTime;
		nextPutAll:'; depth = '; print: self depth;
		"nextPutAll:' complexity = '; print: self complexity * bounds area // 1000 / 1000.0;"
		"nextPutAll:' size = '; print: bounds area;"
	 nextPutAll:')'.! !


!FlashCharacterMorph methodsFor: 'drawing' stamp: 'ar 11/17/1998 17:52'!
fullDrawOn: canvas
	renderTime _ Time millisecondsToRun:[super fullDrawOn: canvas].! !


!FlashCharacterMorph methodsFor: 'copying' stamp: 'ar 5/19/1999 19:07'!
copyMovieFrom: firstFrame to: lastFrame
	| copy newFrame |
	copy _ super copyMovieFrom: firstFrame to: lastFrame.
	copy reset.
	copy visible: false atFrame: 0.
	firstFrame to: lastFrame do:[:i|
		newFrame _ i - firstFrame + 1.
		copy visible: (self visibleAtFrame: i) atFrame: newFrame.
		copy matrix: (self matrixAtFrame: i) atFrame: newFrame.
		copy depth: (self depthAtFrame: i) atFrame: newFrame.
		copy colorTransform: (self colorTransformAtFrame: i) atFrame: newFrame.
	].
	^copy! !


!FlashCharacterMorph methodsFor: 'menu' stamp: 'ar 6/2/1999 04:17'!
addCustomMenuItems: aMenu hand: aHand
	super addCustomMenuItems: aMenu hand: aHand.
	aMenu add:'add project target' action: #addProjectTarget.
	aMenu add:'remove project target' action: #removeProjectTarget.! !

!FlashCharacterMorph methodsFor: 'menu' stamp: 'ar 6/2/1999 04:18'!
addProjectTarget
	| player fill |
	player _ self flashPlayer.
	player ifNil:[^self inform:'I must be in a flash player for this'].
	(submorphs size = 1 and:[submorphs first isFlashShape])
		ifFalse:[^self inform:'Cannot use me as a project target'].
	fill _ submorphs first fillForProjectTarget.
	fill ifNil:[^self inform:'No suitable fill style found'].
	player addFillForProjectTarget: fill.! !

!FlashCharacterMorph methodsFor: 'menu' stamp: 'ar 6/2/1999 04:18'!
removeProjectTarget
	| player fill |
	player _ self flashPlayer.
	player ifNil:[^self inform:'I must be in a flash player for this'].
	(submorphs size = 1 and:[submorphs first isFlashShape])
		ifFalse:[^self inform:'Cannot use me as a project target'].
	fill _ submorphs first fillForProjectTarget.
	fill ifNil:[^self inform:'No suitable fill style found'].
	player removeFillForProjectTarget: fill.! !
Object subclass: #FlashCodec
	instanceVariableNames: 'stream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashCodec methodsFor: 'accessing'!
compress: aShape

	self compressPoints: aShape points.
	self compressRunArray: aShape leftFills.
	self compressRunArray: aShape rightFills.
	self compressRunArray: aShape lineWidths.
	self compressRunArray: aShape lineFills.
	self compressFills: aShape fillStyles.
	^stream contents! !

!FlashCodec methodsFor: 'accessing'!
contents
	^stream contents! !

!FlashCodec methodsFor: 'accessing'!
decompress
	| points leftFills rightFills lineWidths lineFills fillStyles |
	points _ self decompressPoints.
	leftFills _ self decompressRunArray.
	rightFills _ self decompressRunArray.
	lineWidths _ self decompressRunArray.
	lineFills _ self decompressRunArray.
	fillStyles _ self decompressFills.
	^FlashBoundaryShape points: points leftFills: leftFills rightFills: rightFills fillStyles: fillStyles lineWidths: lineWidths lineFills: lineFills! !


!FlashCodec methodsFor: 'initialize'!
initialize
	stream _ WriteStream on: (String new: 1000).! !

!FlashCodec methodsFor: 'initialize'!
on: aStream
	stream _ aStream! !


!FlashCodec methodsFor: 'compressing points'!
compressPoints: points
	"Compress the points using delta values and RLE compression."
	| lastPt runLength runValue nextPt deltaPt |
	points class == ShortPointArray 
		ifTrue:[stream print: points size]
		ifFalse:[points class == PointArray 
					ifTrue:[stream print: points size negated]
					ifFalse:[self error:'The point array has the wrong type!!']].
	points size = 0 ifTrue:[^self].
	lastPt _ points at: 1.
	"First point has no delta"
	self printCompressedPoint: lastPt on: stream runLength: 1.
	runLength _ 0.
	runValue _ nil.
	2 to: points size do:[:i|
		nextPt _ points at: i.
		deltaPt _ nextPt - lastPt.
		runValue = deltaPt ifTrue:[
			runLength _ runLength + 1.
		]ifFalse:[
			self printCompressedPoint: runValue on: stream runLength: runLength.
			runValue _ deltaPt.
			runLength _ 1.
		].
		lastPt _ nextPt].
	runLength > 0 ifTrue:[self printCompressedPoint: runValue on: stream runLength: runLength].
	stream nextPut:$X."Terminating character"
	^stream! !

!FlashCodec methodsFor: 'compressing points'!
decompressPoints
	"Decompress the points using delta values and RLE compression."
	| pts n index runValue spl runLength c x y |
	n _ Integer readFrom: stream.
	n = 0 ifTrue:[^ShortPointArray new].
	n < 0
		ifTrue:[	n _ 0 - n.
				pts _ PointArray new: n]
		ifFalse:[pts _ ShortPointArray new: n].
	index _ 0.
	runValue _ 0@0.
	"Prefetch special character"
	spl _ stream next.
	[index < n] whileTrue:[
		"Read runLength/value"
		spl = $* ifTrue:[
			"Run length follows"
			runLength _ 0.
			[(c _ stream next) isDigit] 
				whileTrue:[runLength _ (runLength * 10) + c digitValue].
			spl _ c.
		] ifFalse:[runLength _ 1].
		"Check for special zero point"
		(spl = $Z or:[spl = $A]) ifTrue:[
			"Since deltaPt is 0@0 there is no need to update runValue.
			Just prefetch the next special character"
			spl = $A ifTrue:[runLength _ 2].
			spl _ stream next.
		] ifFalse:["Regular point"
			"Fetch absolute delta x value"
			x _ 0.
			[(c _ stream next) isDigit] 
				whileTrue:[x _ (x * 10) + c digitValue].
			"Sign correct x"
			spl = $- 
				ifTrue:[x _ 0 - x]
				ifFalse:[spl = $+ ifFalse:[self error:'Bad special character']].
			spl _ c.
			"Fetch absolute delta y value"
			y _ 0.
			[(c _ stream next) isDigit] 
				whileTrue:[y _ (y * 10) + c digitValue].
			"Sign correct y"
			spl = $-
				ifTrue:[y _ 0 - y]
				ifFalse:[spl = $+ ifFalse:[self error:'Bad special character']].
			spl _ c.
			"Compute absolute run value"
			runValue _ runValue + (x@y).
		].
		"And store points"
		1 to: runLength
			do:[:i| pts at: (index _ index + 1) put: runValue].
	].
	"Last char must be X"
	spl = $X ifFalse:[self error:'Bad special character'].
	^pts! !

!FlashCodec methodsFor: 'compressing points'!
printCompressedPoint: aPoint on: aStream runLength: n
	"Print the given point on the stream using the given run length"
	n = 0 ifTrue:[^self]. "Can only happen for the first run"
	"Check if we're storing a zero point"
	(aPoint x = 0 and:[aPoint y = 0]) 
		ifTrue:[
			"Two zero points are specially encoded since they
			occur if a line segment ends and the next segment
			starts from its end point, e.g., (p1,p2,p2) (p2,p3,p4) - this is very likely."
			n = 2 ifTrue:[^aStream nextPut:$A].
			n = 1 ifTrue:[^aStream nextPut: $Z].
			^aStream nextPut:$*; print: n; nextPut:$Z].

	n > 1 ifTrue:[
		"Run length encoding: '*N' repeat the following point n times"
		aStream nextPut: $*; print: n].
	"Point encoding: Two numbers.
	Number encoding: '+XYZ' or '-XYZ'"
	self printPoint: aPoint on: aStream! !

!FlashCodec methodsFor: 'compressing points'!
printPoint: aPoint on: aStream
	aPoint x < 0
		ifTrue:[aStream print: aPoint x]
		ifFalse:[aStream nextPut: $+; print: aPoint x].
	aPoint y < 0
		ifTrue:[aStream print: aPoint y]
		ifFalse:[aStream nextPut: $+; print: aPoint y].! !

!FlashCodec methodsFor: 'compressing points'!
readPointFrom: aStream
	| sign x y |
	sign _ aStream next.
	x _ Integer readFrom: aStream.
	sign = $- ifTrue:[x _ 0-x].
	sign _ aStream next.
	y _ Integer readFrom: aStream.
	sign = $- ifTrue:[y _ 0-y].
	^x@y! !


!FlashCodec methodsFor: 'compressing fills'!
compressFillStyle: aFillStyle
	aFillStyle isSolidFill ifTrue:[^self compressSolidFill: aFillStyle].
	aFillStyle isGradientFill ifTrue:[^self compressGradientFill: aFillStyle].
	aFillStyle isBitmapFill ifTrue:[^self compressBitmapFill: aFillStyle].
	self error:'Unknown fill style'! !

!FlashCodec methodsFor: 'compressing fills'!
compressFills: anArray
	stream print: anArray size.
	anArray do:[:fillStyle| self compressFillStyle: fillStyle].
	stream nextPut:$X. "Terminator"! !

!FlashCodec methodsFor: 'compressing fills'!
compressGradientFill: aFillStyle
	"Note: No terminators for simple colors"
	| ramp key |
	aFillStyle radial
		ifTrue:[stream nextPut: $R] " 'R'adial gradient"
		ifFalse:[stream nextPut: $L]. " 'L' inear gradient"
	self printPoint: aFillStyle origin on: stream.
	self printPoint: aFillStyle direction on: stream.
	self printPoint: aFillStyle normal on: stream.
	ramp _ aFillStyle colorRamp.
	stream nextPut: $+; print: ramp size.
	ramp do:[:assoc|
		key _ (assoc key * 255) truncated.
		stream nextPut: (Character value: key).
		self storeColor: assoc value on: stream].
	stream nextPut:$X. "Terminator"! !

!FlashCodec methodsFor: 'compressing fills'!
compressSolidFill: aFillStyle
	"Note: No terminators for simple colors"
	stream nextPut: $S. " 'S'olid fill"
	self storeColor: aFillStyle asColor on: stream.! !

!FlashCodec methodsFor: 'compressing fills'!
decompressFillStyle
	| type |
	type _ stream next.
	type = $S ifTrue:[^self decompressSolidFill].
	type = $R ifTrue:[^self decompressGradientFill: true].
	type = $L ifTrue:[^self decompressGradientFill: false].
	type = $B ifTrue:[^self decompressBitmapFill].
	^self error:'Unknown fill type'! !

!FlashCodec methodsFor: 'compressing fills'!
decompressFills
	| fills n |
	n _ Integer readFrom: stream.
	fills _ Array new: n.
	1 to: n do:[:i|
		fills at: i put: self decompressFillStyle.
	].
	stream next = $X ifFalse:[^self error:'Compression problem'].
	^fills! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'mir 3/2/2000 13:21'!
decompressGradientFill: radial
	"Note: No terminators for simple colors"
	| ramp fs rampSize rampIndex rampColor |
	fs _ GradientFillStyle new.
	fs radial: radial.
	fs origin: (self readPointFrom: stream).
	fs direction: (self readPointFrom: stream).
	fs normal: (self readPointFrom: stream).
	stream next = $+ ifFalse:[self error:'Negative Array size'].
	rampSize _ Integer readFrom: stream.
	ramp _ Array new: rampSize.
	1 to: rampSize do:[:i|
		rampIndex _ stream next asciiValue / 255.0.
		rampColor _ self readColorFrom: stream.
		ramp at: i put: (rampIndex -> rampColor)].
	fs colorRamp: ramp.
	fs pixelRamp. "Force computation"
	stream next = $X ifFalse:[^self error:'Compressio problem'].
	^fs! !

!FlashCodec methodsFor: 'compressing fills'!
decompressSolidFill
	| color |
	color _ self readColorFrom: stream.
	^SolidFillStyle color: color! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'ar 7/20/1999 16:05'!
readColorFrom: aStream
	| pv |
	pv _ stream next asciiValue +
			(stream next asciiValue bitShift: 8) +
				(stream next asciiValue bitShift: 16) +
					(stream next asciiValue bitShift: 24).
	^Color colorFromPixelValue: pv depth: 32! !

!FlashCodec methodsFor: 'compressing fills' stamp: 'mir 1/17/2000 15:12'!
storeColor: color on: aStream
	| pv |
	pv _ color pixelWordForDepth: 32.
	aStream 
		nextPut: (pv digitAt: 1) asCharacter;
		nextPut: (pv digitAt: 2) asCharacter;
		nextPut: (pv digitAt: 3) asCharacter;
		nextPut: (pv digitAt: 4) asCharacter.

! !


!FlashCodec methodsFor: 'compressing run arrays'!
compressRunArray: aShortRunArray
	stream nextPut:$+; print: aShortRunArray runSize.
	aShortRunArray lengthsAndValuesDo:[:runLength :runValue|
		runLength < 0 ifTrue:[self error:'Bad run length'].
		stream nextPut:$+; print: runLength.
		runValue < 0
			ifTrue:[stream print: runValue]
			ifFalse:[stream nextPut:$+; print: runValue].
	].
	stream nextPut:$X. "Terminator"
	^stream! !

!FlashCodec methodsFor: 'compressing run arrays'!
decompressRunArray
	| n array runIndex runLength runValue spl c |
	stream next = $+ ifFalse:[self error:'Negative array size'].
	n _ Integer readFrom: stream.
	array _ ShortRunArray basicNew: n.
	runIndex _ 0.
	spl _ stream next.
	[runIndex < n] whileTrue:[
		"Read runLength"
		runLength _ 0.
		[(c _ stream next) isDigit] 
			whileTrue:[runLength _ (runLength * 10) + c digitValue].
		spl = $+ ifFalse:[self error:'Negative run length'].
		"Read run value"
		spl _ c.
		runValue _ 0.
		[(c _ stream next) isDigit]
			whileTrue:[runValue _ (runValue * 10) + c digitValue].
		spl = $-
			ifTrue:[runValue _ 0 - runValue]
			ifFalse:[spl = $+ ifFalse:[self error:'Compression problem']].
		array setRunAt: (runIndex _ runIndex+1) toLength: runLength value: runValue.
		spl _ c.
	].
	spl = $X ifFalse:[^self error:'Unexpected special character'].
	^array	! !

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

FlashCodec class
	instanceVariableNames: ''!

!FlashCodec class methodsFor: 'decompressing'!
decompress: aStream
	^(self new on: aStream) decompress! !

!FlashCodec class methodsFor: 'decompressing'!
decompressPoints: aStream
	^(self new on: aStream) decompressPoints! !


!FlashCodec class methodsFor: 'compressing'!
compress: aFlashBoundaryShape
	^self new compress: aFlashBoundaryShape! !

!FlashCodec class methodsFor: 'compressing'!
compressPoints: points
	^(self new initialize compressPoints: points) contents! !


!FlashCodec class methodsFor: 'instance creation'!
new
	^super new initialize! !
Object subclass: #FlashColorTransform
	instanceVariableNames: 'rMul rAdd gMul gAdd bMul bAdd aMul aAdd '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashColorTransform methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:01'!
initialize
	rMul _ bMul _ gMul _ aMul _ 1.0.
	rAdd _ bAdd _ gAdd _ aAdd _ 0.0.! !


!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aAdd
	^aAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aAdd: aFixed
	aAdd _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
aMul
	^aMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
aMul: aFixed
	aMul _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bAdd
	^bAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bAdd: aFixed
	bAdd _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
bMul
	^bMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
bMul: aFixed
	bMul _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gAdd
	^gAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gAdd: aFixed
	gAdd _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
gMul
	^gMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
gMul: aFixed
	gMul _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rAdd
	^rAdd! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rAdd: aFixed
	rAdd _ aFixed! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:43'!
rMul
	^rMul! !

!FlashColorTransform methodsFor: 'accessing' stamp: 'ar 7/2/1998 23:44'!
rMul: aFixed
	rMul _ aFixed! !


!FlashColorTransform methodsFor: 'comparing' stamp: 'ar 8/14/1998 19:39'!
= aCT
	self class == aCT class ifFalse:[^false].
	^rAdd = aCT rAdd and:[rMul = aCT rMul and:[
		gAdd = aCT gAdd and:[gMul = aCT gMul and:[
			bAdd = aCT bAdd and:[bMul = aCT bMul and:[
				aAdd = aCT aAdd and:[aMul = aCT aMul]]]]]]]! !

!FlashColorTransform methodsFor: 'comparing' stamp: 'ar 8/14/1998 19:40'!
hash
	^rAdd hash + gMul hash + bAdd hash + aMul hash! !


!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/24/1998 14:54'!
composedWithGlobal: aColorTransform
	^aColorTransform composedWithLocal: self.! !

!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/25/1998 21:34'!
composedWithLocal: aColorTransform
	| cm |
	cm _ self clone.
	cm rAdd: self rAdd + (aColorTransform rAdd * self rMul).
	cm rMul: self rMul * aColorTransform rMul.
	cm gAdd: self gAdd + (aColorTransform gAdd * self gMul).
	cm gMul: self gMul * aColorTransform gMul.
	cm bAdd: self bAdd + (aColorTransform bAdd * self bMul).
	cm bMul: self bMul * aColorTransform bMul.
	cm aAdd: self aAdd + (aColorTransform aAdd * self aMul).
	cm aMul: self aMul * aColorTransform aMul.
	^cm! !

!FlashColorTransform methodsFor: 'composing' stamp: 'ar 11/24/1998 15:06'!
localColorToGlobal: aColor
	^Color
		r: (aColor red * self rMul + self rAdd)
		g: (aColor green * self gMul + self gAdd)
		b: (aColor blue * self bMul + self bAdd)
		alpha: (aColor alpha * self aMul + self aAdd)! !


!FlashColorTransform methodsFor: 'printing' stamp: 'ar 11/24/1998 14:40'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPut:$(;
		cr; nextPutAll:' r * '; print: rMul; nextPutAll:' + '; print: rAdd;
		cr; nextPutAll:' g * '; print: gMul; nextPutAll:' + '; print: gAdd;
		cr; nextPutAll:' b * '; print: bMul; nextPutAll:' + '; print: bAdd;
		cr; nextPutAll:' a * '; print: aMul; nextPutAll:' + '; print: aAdd;
		nextPut:$).! !


!FlashColorTransform methodsFor: 'testing' stamp: 'ar 9/2/1999 15:01'!
isAlphaTransform
	(aAdd = 0.0 and:[aMul = 1.0]) ifTrue:[^false].
	^true! !

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

FlashColorTransform class
	instanceVariableNames: ''!

!FlashColorTransform class methodsFor: 'instance creation' stamp: 'ar 7/2/1998 23:42'!
new
	^super new initialize! !
DamageRecorder subclass: #FlashDamageRecorder
	instanceVariableNames: 'fullDamageRect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 18:41'!
fullDamageRect
	invalidRects isEmpty ifTrue:[^0@0 corner: 0@0].
	^fullDamageRect! !

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/13/1998 15:54'!
fullDamageRect: maxBounds
	invalidRects isEmpty ifTrue:[^0@0 corner: 0@0].
	^fullDamageRect intersect: maxBounds! !

!FlashDamageRecorder methodsFor: 'as yet unclassified' stamp: 'ar 11/13/1998 15:43'!
recordInvalidRect: rect
	totalRepaint ifTrue:[^self].
	self updateIsNeeded ifTrue:[
		fullDamageRect _ fullDamageRect merge: rect.
	] ifFalse:[
		fullDamageRect _ rect copy.
	].
	^super recordInvalidRect: rect! !
Object subclass: #FlashFileReader
	instanceVariableNames: 'stream log dataSize nFillBits nLineBits nGlyphBits nAdvanceBits jpegDecoder version '
	classVariableNames: 'ActionTable IndexTables StepTable TagTable '
	poolDictionaries: ''
	category: 'Balloon-MMFlash Import'!

!FlashFileReader methodsFor: 'initialize' stamp: 'ar 7/4/1998 20:14'!
on: aStream
	aStream binary.
	stream _ FlashFileStream on: aStream.
	log _ Transcript.
	log _ nil.! !


!FlashFileReader methodsFor: 'property access' stamp: 'ar 11/18/1998 21:25'!
isStreaming
	"Subclasses may override this"
	^false! !


!FlashFileReader methodsFor: 'reading' stamp: 'ar 11/18/1998 23:41'!
processFile
	"Read and process the entire file"
	self processHeader ifFalse:[^nil].
	self processFileContents.! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 11/19/1998 00:29'!
processFileContents
	"Process the contents of the flash file.
	Assume that the header has been read before."
	| time |
	time _ Time millisecondsToRun:[
	self isStreaming ifTrue:[
		"Don't show progress for a streaming connection.
		Note: Yielding is done someplace else."
		[self processTagFrom: stream] whileTrue.
	] ifFalse:[
		'Reading file' displayProgressAt: Sensor cursorPoint
			from: 1 to: 100
			during:[:theBar|

		[self processTagFrom: stream] whileTrue:[
			theBar value: (stream position * 100 // stream size).
			stream atEnd ifTrue:[
				log ifNotNil:[
					log cr; nextPutAll:'Unexpected end of data (no end tag)'.
					self flushLog].
				^self]].
		].
	].
	(stream respondsTo: #close) ifTrue:[stream close].
	].
	Transcript cr; print: time / 1000.0; show:' secs to read file'! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 6/28/1999 16:33'!
processHeader
	"Read header information from the source stream.
	Return true if successful, false otherwise."
	| twipsFrameSize frameRate frameCount |
	self processSignature ifFalse:[^false].
	version _ stream nextByte.
	"Check for the version supported"
	version > self maximumSupportedVersion ifTrue:[^false].
	dataSize _ stream nextLong.
	"Check for the minimal file size"
	dataSize < 21 ifTrue:[^false].
	twipsFrameSize _ stream nextRect.
	self recordGlobalBounds: twipsFrameSize.
	frameRate _ stream nextWord / 256.0.
	self recordFrameRate: frameRate.
	frameCount _ stream nextWord.
	self recordFrameCount: frameCount.
	log ifNotNil:[
		log cr; nextPutAll:'------------- Header information --------------'.
		log cr; nextPutAll:'File version		'; print: version.
		log cr; nextPutAll:'File size			'; print: dataSize.
		log cr; nextPutAll:'Movie width		'; print: twipsFrameSize extent x // 20.
		log cr; nextPutAll:'Movie height	'; print: twipsFrameSize extent y // 20.
		log cr; nextPutAll:'Frame rate		'; print: frameRate.
		log cr; nextPutAll:'Frame count	'; print: frameCount.
		log cr; cr.
		self flushLog].
	^true! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 7/4/1998 20:08'!
processSignature
	"Check the signature of the SWF file"
	stream nextByte asCharacter = $F ifFalse:[^false].
	stream nextByte asCharacter = $W ifFalse:[^false].
	stream nextByte asCharacter = $S ifFalse:[^false].
	^true! !

!FlashFileReader methodsFor: 'reading' stamp: 'ar 10/12/1998 23:57'!
processTagFrom: aStream
	"Read and process the next tag from the input stream."
	| tag data result |
	tag _ aStream nextTag.
	log ifNotNil:[
		log cr; nextPutAll:'Tag #'; print: tag key.
		log nextPutAll:' ('; nextPutAll: (TagTable at: tag key + 1); space; print: tag value size;
			nextPutAll:' bytes)'.
		self flushLog].
	data _ FlashFileStream on: (ReadStream on: tag value).
	result _ self dispatch: data on: tag key+1 in: TagTable ifNone:[self processUnknown: data].
	(log isNil or:[data atEnd]) ifFalse:[
		log 
			nextPutAll:'*** ';
			print: (data size - data position);
			nextPutAll:' bytes skipped ***'.
		self flushLog].
	^result! !


!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/13/1998 17:53'!
processCurveRecordFrom: data
	| nBits cx cy ax ay |
	log ifNotNil:[log crtab; nextPutAll:'C: '].
	nBits _ (data nextBits: 4) + 2. "Offset by 2"
	"Read control point change"
	cx _ data nextSignedBits: nBits.
	cy _ data nextSignedBits: nBits.
	log ifNotNil:[log print: cx@cy].
	"Read anchor point change"
	ax _ data nextSignedBits: nBits.
	ay _ data nextSignedBits: nBits.
	log ifNotNil:[log nextPutAll:' -- '; print: ax@ay.
				self flushLog].
	self recordCurveSegmentTo: ax@ay with: cx@cy! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 11/13/1998 20:31'!
processFillStylesFrom: data
	| nFills matrix nColors rampIndex rampColor id color fillStyleType ramp |
	nFills _ data nextByte.
	nFills = 255 ifTrue:[nFills _ data nextWord].
	log ifNotNil:[log crtab; print: nFills; nextPutAll:' New fill styles'].
	1 to: nFills do:[:i|
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab].
		fillStyleType _ data nextByte.
		(fillStyleType = 0) ifTrue:["Solid fill"
			color _ data nextColor.
			self recordSolidFill: i color: color.
			log ifNotNil:[log nextPutAll:'solid color '; print: color].
		].
		(fillStyleType anyMask: 16) ifTrue:["Gradient fill"
			"Read gradient matrix"
			matrix _ data nextMatrix.
			"Read color ramp data"
			nColors _ data nextByte.
			ramp _ Array new: nColors.
			log ifNotNil:[log nextPutAll:'Gradient fill with '; print: nColors; nextPutAll:' colors'].
			1 to: nColors do:[:j|
				rampIndex _ data nextByte.
				rampColor _ data nextColor.
				ramp at: j put: (rampIndex -> rampColor)].
			self recordGradientFill: i matrix: matrix ramp: ramp linear: (fillStyleType = 16)].
		(fillStyleType anyMask: 16r40) ifTrue:["Bit fill"
			"Read bitmap id"
			id _ data nextWord.
			"Read bitmap matrix"
			matrix _ data nextMatrix.
			log ifNotNil:[log nextPutAll:'Bitmap fill id='; print: id].
			self recordBitmapFill: i matrix: matrix id: id clipped: (fillStyleType anyMask: 1)].
		self flushLog.
	].! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/12/1998 23:35'!
processFontShapeFrom: data
	data initBits.
	nFillBits _ data nextBits: 4.
	nLineBits _ data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/9/1998 20:43'!
processLineRecordFrom: data
	| nBits x y |
	nBits _ (data nextBits: 4) + 2. "Offset by 2"
	data nextBitFlag ifTrue:[
		"General line"
		x _ data nextSignedBits: nBits.
		y _ data nextSignedBits: nBits.
		self recordLineSegmentBy: x@y.
	] ifFalse:[
		data nextBitFlag 
			ifTrue:[	"vertical line"
					y _ data nextSignedBits: nBits. 
					self recordLineSegmentVerticalBy: y]
			ifFalse:[	"horizontal line"
					x _ data nextSignedBits: nBits.
					self recordLineSegmentHorizontalBy: x].
	].
	log ifNotNil:[log crtab; nextPutAll:'E: ';print: x; nextPut:$@; print: y.
				self flushLog].! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/4/1998 20:04'!
processLineStylesFrom: data
	| nStyles styles lineWidth lineColor |
	nStyles _ data nextByte.
	nStyles = 255 ifTrue:[nStyles _ data nextWord].
	log ifNotNil:[log crtab; print: nStyles; nextPutAll:' New line styles'].
	styles _ Array new: nStyles.
	1 to: nStyles do:[:i|
		lineWidth _ data nextWord.
		lineColor _ data nextColor.
		self recordLineStyle: i width: lineWidth color: lineColor.
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab; 
						print: lineWidth; tab; print: lineColor]].
	self flushLog.
	^styles! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 11/17/1998 00:35'!
processShapeRecordFrom: data
	| flags pt lineInfo fillInfo0 fillInfo1 |
	data nextBitFlag ifTrue:["Boundary edge record"
		data nextBitFlag
			ifTrue:[self processLineRecordFrom: data]
			ifFalse:[self processCurveRecordFrom: data].
		^true].
	flags _ data nextBits: 5.
	flags = 0 ifTrue:[^false]. "At end of shape"
	(flags anyMask: 1) ifTrue:["move to"
		pt _ data nextPoint.
		self recordMoveTo: pt.
		log ifNotNil:[log crtab; nextPutAll:'MoveTo '; print: pt]].
	(flags anyMask: 2) ifTrue:["fill info 0"
		fillInfo0 _ data nextBits: nFillBits.
		self recordFillStyle0: fillInfo0.
		log ifNotNil:[log crtab; nextPutAll:'FillInfo0 '; print: fillInfo0]].
	(flags anyMask: 4) ifTrue:["fill info 1"
		fillInfo1 _ data nextBits: nFillBits.
		self recordFillStyle1: fillInfo1.
		log ifNotNil:[log crtab; nextPutAll:'FillInfo1 '; print: fillInfo1]].
	(flags anyMask: 8) ifTrue:["line info"
		lineInfo _ data nextBits: nLineBits.
		self recordLineStyle: lineInfo.
		log ifNotNil:[log crtab; nextPutAll:'LineInfo '; print: lineInfo]].
	(flags anyMask: 16) ifTrue:["new styles"
		self recordEndSubshape.
		log ifNotNil:[log crtab; nextPutAll:'New Set of styles '].
		self processShapeStylesFrom: data.
		"And reset info"
		data initBits.
		nFillBits _ data nextBits: 4.
		nLineBits _ data nextBits: 4].
	^true! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 7/4/1998 20:05'!
processShapeStylesFrom: data
	self processFillStylesFrom: data.
	self processLineStylesFrom: data.! !

!FlashFileReader methodsFor: 'processing shapes' stamp: 'ar 9/3/1999 14:54'!
processShapesFrom: data
	"Process a new shape"
	| id bounds |
	"Read shape id and bounding box"
	id _ data nextWord.
	bounds _ data nextRect.
	"Start new shape definition"
	self recordShapeStart: id bounds: bounds.
	"Read styles for this shape"
	self processShapeStylesFrom: data.
	"Get number of bits for fill and line styles"
	data initBits.
	nFillBits _ data nextBits: 4.
	nLineBits _ data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.
	"And mark the end of this shape"
	self recordShapeEnd: id.
	self recordShapeProperty: id length: data size.! !


!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 7/14/1998 23:17'!
processGlyphEntries: nGlyphs from: data
	| index advance |
	data initBits.
	1 to: nGlyphs do:[:i|
		index _ data nextBits: nGlyphBits.
		advance _ data nextSignedBits: nAdvanceBits.
		self recordNextChar: index+1 advanceWidth: advance.
		log ifNotNil:[
			log nextPut:$(;print: index; space; print: advance; nextPut:$).
			self flushLog].
	].! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 11/20/1998 02:47'!
processGlyphRecordFrom: data
	| flags |
	flags _ data nextByte.
	flags = 0 ifTrue:[^false].
	self flag: #wrongSpec.
	"From news://forums.macromedia.com/macromedia.open-swf
It is an error in the spec. There can be up to 255 characters in run. The
high bit does not mean anything. The text record type 0 and type 1 is poorly
described. The real format is that all of the info in a 'text record type 1'
is always followed by the info in a 'text record type 2'. Note the high bit
of 'text record type 1' is reserved and should always be zero.
"
	self processGlyphStateChange: flags from: data.
	flags _ data nextByte.
	flags = 0 ifTrue:[^false].
	self processGlyphEntries: flags from: data.
	"Old stuff - which is according to the f**cking spec"
	"(flags anyMask: 128) ifTrue:[
		self processGlyphStateChange: flags from: data.
	] ifFalse:[
		self processGlyphEntries: flags from: data.
	]."
	^true! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 7/15/1998 19:45'!
processGlyphStateChange: flags from: data
	| hasFont hasColor hasXOffset hasYOffset fontId color xOffset yOffset height |
	hasFont _ flags anyMask: 8.
	hasColor _ flags anyMask: 4.
	hasYOffset _ flags anyMask: 2.
	hasXOffset _ flags anyMask: 1.
	hasFont ifTrue:[fontId _ data nextWord].
	hasColor ifTrue:[color _ data nextColor].
	hasXOffset ifTrue:[xOffset _ data nextWord].
	hasYOffset ifTrue:[yOffset _ data nextWord].
	hasFont ifTrue:[height _ data nextWord].
	log ifNotNil:[
		log nextPutAll:'['.
		hasFont ifTrue:[log nextPutAll:' font='; print: fontId].
		hasColor ifTrue:[log nextPutAll:' color='; print: color].
		hasXOffset ifTrue:[log nextPutAll:' xOfs=';print: xOffset].
		hasYOffset ifTrue:[log nextPutAll:' yOfs=';print: yOffset].
		hasFont ifTrue:[log nextPutAll:' height='; print: height].
		log nextPutAll:' ]'.
		self flushLog.
	].
	self recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height.! !

!FlashFileReader methodsFor: 'processing glyphs' stamp: 'ar 10/15/1998 03:23'!
processGlyphsFrom: data
	| id bounds matrix |
	id _ data nextWord.
	bounds _ data nextRect.
	matrix _ data nextMatrix.
	self recordTextStart: id bounds: bounds matrix: matrix.
	nGlyphBits _ data nextByte.
	nAdvanceBits _ data nextByte.
	log ifNotNil:[
		log	nextPutAll:'(nGlyphBits = '; 
			print: nGlyphBits; 
			nextPutAll:' nAdvanceBits = '; 
			print: nAdvanceBits;
			nextPutAll:') '.
		self flushLog].
	[self processGlyphRecordFrom: data] whileTrue.
	self recordTextEnd: id.! !


!FlashFileReader methodsFor: 'processing buttons' stamp: 'ar 6/28/1999 16:32'!
processButtonRecords: id from: data cxForm: haveCxForm
	| flags state characterId layer matrix cxForm |
	[flags _ data nextByte.
	flags = 0] whileFalse:[
		state _ flags bitAnd: 15.
		characterId _ data nextWord.
		layer _ data nextWord.
		matrix _ data nextMatrix.
		haveCxForm ifTrue:[cxForm _ data nextColorMatrix: version >= 3].
		self recordButton: id 
			character: characterId 
			state: state 
			layer: layer 
			matrix: matrix
			colorTransform: cxForm].! !


!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/24/1998 15:32'!
processActionGetURL: data
	| length position urlString winString |
	length _ data nextWord.
	position _ data position.
	urlString _ data nextString.
	winString _ data nextString.
	data position = (position + length) ifFalse:[
		self halt.
		data position: position.
		^self processUnknownAction: data].
	log ifNotNil:[
		log 
			nextPutAll:' url='; print: urlString;
			nextPutAll:', win='; print: winString].
	^Message selector: #getURL:window: arguments: (Array with: urlString with: winString)! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionGotoFrame: data
	| length frame |
	length _ data nextWord.
	length = 2 ifFalse:["There is something wrong here"
		self halt.
		data skip: -2.
		^self processUnknownAction: data].
	frame _ data nextWord.
	log ifNotNil:[log nextPutAll:' frame = '; print: frame.].
	^Message selector: #gotoFrame: argument: frame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/24/1998 15:31'!
processActionGotoLabel: data
	| length label |
	length _ data nextWord.
	label _ data nextString.
	log ifNotNil:[log nextPutAll:' label = '; print: label].
	^Message selector: #gotoLabel: argument: label! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionNextFrame: data
	^Message selector: #gotoNextFrame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/19/1998 20:39'!
processActionPlay: data
	^Message selector: #actionPlay! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionPrevFrame: data
	^Message selector: #gotoPrevFrame! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 7/15/1998 19:39'!
processActionRecordsFrom: data
	| code actionList action |
	actionList _ OrderedCollection new.
	[code _ data nextByte.
	code = 0] whileFalse:[
		code _ code bitAnd: 127. "Mask out the length-follow flag"
		log ifNotNil:[
			log cr; nextPutAll:'	Action #'; print: code.
			log nextPutAll:' ('; nextPutAll: (ActionTable at: code); nextPutAll:')'].
		action _ self dispatch: data on: code in: ActionTable 
					ifNone:[self processUnknownAction: data].
		action ifNotNil:[actionList add: action].
		log ifNotNil:[self flushLog].
	].
	^actionList! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/17/1998 13:37'!
processActionSetTarget: data
	| length target |
	length _ data nextWord.
	target _ data nextString.
	log ifNotNil:[log nextPutAll:' target = '; print: target].
	^Message selector: #actionTarget: argument: target.! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 11/19/1998 20:39'!
processActionStop: data
	^Message selector: #actionStop! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionStopSounds: data
	^Message selector: #stopSounds! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionToggleQuality: data
	^Message selector: #toggleQuality! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 8/17/1998 10:10'!
processActionWaitForFrame: data
	| length frame skip |
	length _ data nextWord.
	length = 3 ifFalse:["Something is wrong"
		self halt.
		data skip: -2.
		^self processUnknownAction: data].
	frame _ data nextWord.
	skip _ data nextByte.
	log ifNotNil:[
		log nextPutAll:'frame = '; print: frame;
			nextPutAll:', skip = '; print: skip].
	^Message selector: #isFrameLoaded:elseSkip: arguments: (Array with: frame with: skip).! !

!FlashFileReader methodsFor: 'processing actions' stamp: 'ar 7/15/1998 19:37'!
processUnknownAction: data
	| code length |
	data skip: -1. "For determining the length of the action"
	code _ data nextByte.
	(code anyMask: 128) ifTrue:["Two byte length following"
		length _ data nextWord.
		data skip: length].
	log ifNotNil:[log nextPutAll:'*** skipped ***'].
	^nil! !


!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/21/1998 00:46'!
createSoundBuffersOfSize: numSamples stereo: stereo
	| channels buffers |
	channels _ stereo ifTrue:[2] ifFalse:[1].
	buffers _ Array new: channels.
	1 to: channels do:[:i| 
		buffers at: i put: 
			(WriteStream on: ((SoundBuffer newMonoSampleCount: numSamples)))].
	^buffers! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'jm 3/30/1999 09:08'!
createSoundFrom: soundBuffers stereo: stereo samplingRate: samplingRate

	| snds |
	snds _ soundBuffers collect: [:buf |
		(SampledSound samples: buf samplingRate: samplingRate) loudness: 1.0].
	stereo
		ifTrue:[
			^ MixedSound new
				add: (snds at: 1) pan: 0.0;
				add: (snds at: 2) pan: 1.0;
				yourself]
		ifFalse: [
			^ snds at: 1].! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'jm 3/30/1999 08:55'!
decompressSound: aByteArray stereo: stereo samples: numSamples rate: samplingRate

	| buffers |
	buffers _ ADPCMCodec new
		decodeFlash: aByteArray sampleCount: numSamples stereo: stereo.
	^ self createSoundFrom: buffers stereo: stereo samplingRate: samplingRate
! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/29/1998 14:53'!
decompressSound: aByteArray stereo: stereo samples: numSamples rate: samplingRate into: buffers
	| data nBits signMask indexTable channels valPred index vp idx delta step vpdiff allButSignMask k k0 |
	data _ FlashFileStream on: (ReadStream on: aByteArray).
	data initBits.
	nBits _ (data nextBits: 2) + 2.
	signMask _ 1 bitShift: nBits - 1.
	allButSignMask _ signMask bitInvert32.
	k0 _ 1 bitShift: (nBits - 2).
	indexTable _ IndexTables at: nBits - 1.
	channels _ stereo ifTrue:[2] ifFalse:[1].
	valPred _ IntegerArray new: channels.
	index _ IntegerArray new: channels.
	1 to: numSamples do:[:nOut|
		(nOut bitAnd: 16rFFF) = 1 ifTrue:["New block header starts every 4KB"
			1 to: channels do:[:i|
				vp _ data nextSignedBits: 16.
				valPred at: i put: vp.
				(buffers at: i) nextPut: vp.
				"First sample has no delta"
				index at: i put: (data nextBits: 6).
			].
		] ifFalse:[ "Decode next sample"
			1 to: channels do:[:i|
				vp _ valPred at: i.
				idx _ index at: i.
				"Get next delta value"
				delta _ data nextBits: nBits.
				"Compute difference and new predicted value"
				"Computes 'vpdiff = (delta+0.5)*step/4"
				step _ StepTable at: idx + 1.
				k _ k0.
				vpdiff _ 0.
				[	(delta bitAnd: k) = 0 ifFalse:[vpdiff _ vpdiff + step].
					step _ step bitShift: -1.
					k _ k bitShift: -1.
					k = 0] whileFalse.
				vpdiff _ vpdiff + step.
				(delta anyMask: signMask) 
					ifTrue:[vp _ vp - vpdiff]
					ifFalse:[vp _ vp + vpdiff].
				"Compute new index value"
				idx _ idx + (indexTable at: (delta bitAnd: allButSignMask) + 1).
				"Clamp index"
				idx < 0 ifTrue:[idx _ 0].
				idx > 88 ifTrue:[idx _ 88].
				"Clamp output value"
				vp < -32768 ifTrue:[vp _ -32768].
				vp > 32767 ifTrue:[vp _ 32767].
				"Store values back"
				index at: i put: idx.
				valPred at: i put: vp.
				(buffers at: i) nextPut: vp.
			]
		].
	].! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 8/10/1998 15:37'!
processEnvelopeFrom: data
	| env |
	env _ FlashSoundEnvelope new.
	env mark44: data nextULong.
	env level0: data nextWord.
	env level1: data nextWord.
	^env! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 8/10/1998 16:11'!
processSoundInfoFrom: data
	| flags info nPoints |
	flags _ data nextByte.
	info _ FlashSoundInformation new.
	info syncFlags: (flags bitShift: -4).
	(flags anyMask: 1) ifTrue:[info inPoint: data nextULong].
	(flags anyMask: 2) ifTrue:[info outPoint: data nextULong].
	(flags anyMask: 4) ifTrue:[info loopCount: data nextWord].
	(flags anyMask: 8) ifTrue:[
		nPoints _ data nextByte.
		info envelopes: ((1 to: nPoints) collect:[:i| self processEnvelopeFrom: data]).
	].
	^info! !

!FlashFileReader methodsFor: 'processing sounds' stamp: 'ar 11/20/1998 22:37'!
processSoundStreamHeadFrom: data
	| mixFmt flags stereo bitsPerSample compressed sampleCount |
	mixFmt _ data nextByte.
	flags _ data nextByte.
	stereo _ flags anyMask: 1.
	self flag: #wrongSpec.
	bitsPerSample _ (flags anyMask: 2) ifTrue:[16] ifFalse:[8].
	compressed _ (flags bitShift: -4) = 1.
	sampleCount _ data nextWord.
	self recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed.
	^true! !


!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 2/23/1999 00:10'!
processDefineBits: data
	| id image |
	id _ data nextWord.
	image _ jpegDecoder decodeNextImageFrom: data.
	Preferences compressFlashImages ifTrue:[image _ image asFormOfDepth: 8].
	"image display."
	self recordBitmap: id data: image.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 2/23/1999 00:10'!
processDefineBitsJPEG2: data
	| id image decoder |
	id _ data nextWord.
	decoder _ FlashJPEGDecoder new.
	decoder isStreaming: self isStreaming.
	decoder decodeJPEGTables: data.
	image _ decoder decodeNextImageFrom: data.
	Preferences compressFlashImages ifTrue:[image _ image asFormOfDepth: 8].
	self recordBitmap: id data: image.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 2/23/1999 00:10'!
processDefineBitsJPEG3: data
	"TODO: Read zlib compressed alpha."
	| id image decoder alphaOffset dataOffset |
	id _ data nextWord.
	self flag: #wrongSpec.
	alphaOffset _ data nextWord.
	dataOffset _ data nextWord.
	decoder _ FlashJPEGDecoder new.
	decoder isStreaming: self isStreaming.
	decoder decodeJPEGTables: data.
	image _ decoder decodeNextImageFrom: data.
	Preferences compressFlashImages ifTrue:[image _ image asFormOfDepth: 8].
	"Note: We must read the zlib compressed alpha values here."
	self recordBitmap: id data: image.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:12'!
processDefineBitsLossless2: data
	"TODO: Read zlib compressed data."
	| id format width height |
	id _ data nextWord.
	format _ data nextByte.
	width _ data nextWord.
	height _ data nextWord.
	self recordBitmap: id data: nil.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:12'!
processDefineBitsLossless: data
	"TODO: Read zlib compressed data."
	| id format width height |
	id _ data nextWord.
	format _ data nextByte.
	width _ data nextWord.
	height _ data nextWord.
	self recordBitmap: id data: nil.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:41'!
processDefineButton2: data
	| id flags actions condition actionOffset |
	data hasAlpha: true.
	id _ data nextWord.
	self recordDefineButton: id.
	flags _ data nextByte.
	self recordButton: id trackAsMenu: flags = 0.
	self flag: #wrongSpec.
	actionOffset _ data nextWord.
	self processButtonRecords: id from: data cxForm: true.
	[actionOffset = 0] whileFalse:[
		actionOffset _ data nextWord.
		condition _ data nextWord.
		actions _ self processActionRecordsFrom: data.
		self recordButton: id actions: actions condition: condition].
	data hasAlpha: false.
	self recordEndButton: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/16/1998 20:47'!
processDefineButton: data
	| id actions |
	id _ data nextWord.
	self recordDefineButton: id.
	self processButtonRecords: id from: data cxForm: false.
	actions _ self processActionRecordsFrom: data.
	self recordButton: id actions: actions.
	self recordEndButton: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:32'!
processDefineButtonCxform: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/21/1998 13:56'!
processDefineButtonSound: data
	| id soundID soundInfo |
	id _ data nextWord.
	#(0 mouseEnter mouseDown 3) do:[:state|
		soundID _ data nextWord.
		soundID = 0 ifFalse:[
			soundInfo _ self processSoundInfoFrom: data.
			self recordButton: id sound: soundID info: soundInfo state: state]].
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:31'!
processDefineFont2: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 03:18'!
processDefineFont: data
	| fontId firstOffset offsets nShapes |
	fontId _ data nextWord.
	firstOffset _ data nextWord.
	nShapes _ firstOffset // 2.
	offsets _ Array new: nShapes.
	offsets at: 1 put: firstOffset.
	2 to: nShapes do:[:i| offsets at: i put: data nextWord].
	self recordFontBegin: fontId with: nShapes.
	1 to: nShapes do:[:i|
		log ifNotNil:[log cr; nextPutAll:'Glyph '; print: i].
		self recordFontShapeStart: fontId with: i.
		self processFontShapeFrom: data.
		self recordFontShapeEnd: fontId with: i].
	data atEnd ifFalse:[self halt].
	self recordFontEnd: fontId.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:34'!
processDefineFontInfo: data
	| id nameLength fontName flags charMap |
	id _ data nextWord.
	nameLength _ data nextByte.
	fontName _ (data nextBytes: nameLength) asString.
	flags _ data nextByte.
	charMap _ data upToEnd.
	self recordFont: id name: fontName charMap: charMap wide: (flags anyMask: 1).
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 14:45'!
processDefineMorphShape: data
	self processMorphShapeFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/13/1998 23:52'!
processDefineShape2: data
	self processShapesFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/15/1998 19:48'!
processDefineShape3: data
	data hasAlpha: true.
	self processShapesFrom: data.
	data hasAlpha: false.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/13/1998 23:22'!
processDefineShape: data
	self processShapesFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 21:29'!
processDefineSound: data
	| flags sampleCount sampleData id stereo bitsPerSample rate compressed sound |
	id _ data nextWord.
	flags _ data nextByte.
	stereo _ (flags anyMask: 1).
	bitsPerSample _ (flags anyMask: 2) ifTrue:[16] ifFalse:[8].
	rate _ #( 5512 11025 22050 44100 ) at: (flags >> 2 bitAnd: 3)+1.
	compressed _ flags anyMask: 16.
	sampleCount _ data nextULong.
	sampleData _ data upToEnd.
	compressed ifTrue:[
		self isStreaming ifFalse:[Cursor wait show].
		sound _ self decompressSound: sampleData 
						stereo: stereo 
						samples: sampleCount 
						rate: rate.
		self isStreaming ifFalse:[Cursor normal show].
	] ifFalse:[
		self halt.
		sound _ nil.
	].
	self recordSound: id data: sound.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:42'!
processDefineSprite: data
	| id frameCount |
	id _ data nextWord.
	self flag: #wrongSpec.
	frameCount _ data nextWord.
	self recordBeginSprite: id frames: frameCount.
	[self processTagFrom: data] whileTrue.
	self recordEndSprite: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/15/1998 19:47'!
processDefineText2: data
	data hasAlpha: true.
	self processGlyphsFrom: data.
	data hasAlpha: false.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 23:23'!
processDefineText: data
	self processGlyphsFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 22:57'!
processDoAction: data
	| actions |
	actions _ self processActionRecordsFrom: data.
	self recordFrameActions: actions.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:30'!
processEnd: data
	"At end of data"
	^false! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/17/1998 13:35'!
processFrameLabel: data
	| label |
	label _ data nextString.
	self recordFrameLabel: label.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:31'!
processFreeCharacter: data
	| id |
	id _ data nextWord.
	data atEnd ifFalse:[self halt].
	self recordFreeCharacter: id.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/18/1998 21:32'!
processJPEGTables: data
	jpegDecoder _ FlashJPEGDecoder new.
	jpegDecoder isStreaming: self isStreaming.
	jpegDecoder decodeJPEGTables: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/24/1998 15:32'!
processNameCharacter: data
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 15:23'!
processPlaceObject2: data
	| id flags depth matrix cxForm ratio name move |
	flags _ data nextByte.
	depth _ data nextWord.

	move _ (flags anyMask: 1).
	(flags anyMask: 2) ifTrue:[id _ data nextWord].
	(flags anyMask: 4) ifTrue:[matrix _ data nextMatrix].
	(flags anyMask: 8) ifTrue:[cxForm _ data nextColorMatrix: version >= 3].
	self flag: #checkThis.
	(flags anyMask: 16) ifTrue:["self halt." ratio _ data nextWord / 65536.0].
	(flags anyMask: 32) ifTrue:["self halt." name _ data nextString].
	(flags anyMask: 64) ifTrue:["self halt:'Clip shape encountered'." ^true].
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' name = ', name printString,' depth = ', depth printString, ' move: ', move printString, ')'.
		self flushLog].
	move 
		ifTrue:[self recordMoveObject: id name: name depth: depth matrix: matrix colorMatrix: cxForm ratio: ratio]
		ifFalse:[self recordPlaceObject: id name: name depth: depth matrix: matrix colorMatrix: cxForm ratio: ratio].
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 9/3/1999 15:12'!
processPlaceObject: data
	| id depth matrix colorMatrix |
	id _ data nextWord.
	depth _ data nextWord.
	matrix _ data nextMatrix.
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' depth = ', depth printString, ')'.
		self flushLog].
	data atEnd ifFalse:[colorMatrix _ data nextColorMatrix].
	self recordPlaceObject: id name: nil depth: depth matrix: matrix colorMatrix: colorMatrix ratio: nil.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:32'!
processProtect: data
	self recordProtection.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 02:43'!
processRemoveObject2: data
	| depth |
	depth _ data nextWord.
	log ifNotNil:[
		log nextPutAll:' (depth = ', depth printString, ')'.
		self flushLog].
	self recordRemoveObject: nil depth: depth.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/13/1998 00:19'!
processRemoveObject: data
	| id depth |
	id _ data nextWord.
	depth _ data nextWord.
	log ifNotNil:[
		log nextPutAll:' (id = ', id printString,' depth = ', depth printString, ')'.
		self flushLog].
	self recordRemoveObject: id depth: depth.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:33'!
processSetBackgroundColor: data
	| color |
	color _ data nextColor.
	self recordBackgroundColor: color.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:34'!
processShowFrame: data
	"Show the current frame"
	self recordShowFrame.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:37'!
processSoundStreamBlock: data
	self recordSoundStreamBlock: data upToEnd.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:21'!
processSoundStreamHead2: data
	self processSoundStreamHeadFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 11/20/1998 22:22'!
processSoundStreamHead: data
	self processSoundStreamHeadFrom: data.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 10/15/1998 02:47'!
processStartSound: data
	| id info |
	id _ data nextWord.
	info _ self processSoundInfoFrom: data.
	self recordStartSound: id info: info.
	^true! !

!FlashFileReader methodsFor: 'processing tags' stamp: 'ar 7/4/1998 20:34'!
processUnknown: data
	"An unknown tag has been encountered"
	^true! !


!FlashFileReader methodsFor: 'private' stamp: 'ar 11/20/1998 22:11'!
dispatch: argument on: aKey in: aTable ifNone: exceptionBlock
	| selector |
	(aKey < 1 or:[aKey > aTable size]) ifTrue:[^exceptionBlock value].
	selector _ aTable at: aKey.
	^self perform: selector with: argument! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 11/5/1998 23:42'!
flushLog
	(log == Transcript) ifTrue:[
		log endEntry.
		Sensor leftShiftDown ifTrue:[self halt].
	].! !

!FlashFileReader methodsFor: 'private' stamp: 'mir 11/3/1999 15:25'!
maximumSupportedVersion
	^4! !

!FlashFileReader methodsFor: 'private' stamp: 'ar 7/12/1998 23:41'!
warn: aString
	Transcript cr; show: aString.! !


!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:46'!
recordCurveSegmentTo: anchorPoint with: controlPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 11/17/1998 00:36'!
recordEndSubshape
	"A new subshape begins with a full set of line and fill styles"! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 10/14/1998 00:39'!
recordFillStyle0: fillIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 10/14/1998 00:39'!
recordFillStyle1: fillIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 20:56'!
recordLineSegmentBy: deltaPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/8/1998 15:56'!
recordLineSegmentHorizontalBy: deltaX
	^self recordLineSegmentBy: (deltaX@0)! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/8/1998 15:56'!
recordLineSegmentVerticalBy: deltaY
	^self recordLineSegmentBy: (0@deltaY)! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:48'!
recordLineStyle: styleIndex! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:47'!
recordMoveTo: aPoint! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:59'!
recordShapeEnd: shapeId! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 1/4/1999 08:44'!
recordShapeProperty: id length: length! !

!FlashFileReader methodsFor: 'composing shapes' stamp: 'ar 7/4/1998 19:59'!
recordShapeStart: shapeId bounds: shapeBounds! !


!FlashFileReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 22:35'!
recordFont: id name: fontName charMap: charMap wide: isWide
	"Record the name and character mapping of the font for the given id.
	If isWide is set then the font is a 16bit Unicode font."! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 18:50'!
recordFontBegin: fontId with: nGlyphs! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 18:50'!
recordFontEnd: fontId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordFontShapeEnd: fontId with: charId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordFontShapeStart: fontId with: charId! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:09'!
recordNextChar: glyphIndex advanceWidth: advance! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:08'!
recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:16'!
recordTextEnd: id! !

!FlashFileReader methodsFor: 'defining text' stamp: 'ar 7/13/1998 01:16'!
recordTextStart: id bounds: bounds matrix: matrix! !


!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 11/13/1998 20:31'!
recordBitmapFill: fillIndex matrix: bmMatrix id: bitmapID clipped: aBoolean! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:52'!
recordGradientFill: fillIndex matrix: gradientMatrix ramp: colorRampArray linear: aBoolean! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:55'!
recordLineStyle: styleIndex width: lineWidth color: lineColor! !

!FlashFileReader methodsFor: 'defining styles' stamp: 'ar 7/4/1998 19:48'!
recordSolidFill: index color: fillColor! !


!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:22'!
recordButton: buttonId actions: actionList
	"Associate an action list with the given button"
	^self recordButton: buttonId actions: actionList condition: 8. "OverDownToOverUp"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:34'!
recordButton: buttonId actions: actionList condition: condition
	"Associate an action list with the given button:
		buttonId:	global ID of the button
		actions:		Collection of MessageSends (e.g., actions)
		condition:	bit mask describing when the actions should be applied
					General conditions:
						1 - IdleToOverUp (Mouse enter up)
						2 - OverUpToIdle (Mouse exit up)
						4 - OverUpToOverDown (Mouse down)
						8 - OverDownToOverUp (Mouse up in)
					Push button conditions:
						16 - OverDownToOutDown (Mouse exit down)
						32 - OutDownToOverDown (Mouse enter down)
						64 - OutDownToIdle (Mouse up out)
					Menu button conditions:
						128 - IdleToOverDown (Mouse enter down)
						256 - OverDownToIdle (Mouse exit down)"
! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/24/1998 14:23'!
recordButton: buttonId character: characterId state: state layer: layer matrix: matrix colorTransform: cxForm
	"Define the character to use for a button.
		buttonId:	global ID used for the button
		characterId:	ID of the character defining the shape for the button
		state:		bit mask for when to use the character
						1 - default (e.g. no other state applies)
						2 - display when the mouse is over the button but not pressed
						4 - display when the button is pressed
						8 - the area in which the mouse is supposed to be 'over' the button
		layer:		UNKNOWN.
		matrix:		Transformation to apply to the character. (Guess!!)"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 8/10/1998 15:51'!
recordButton: id sound: soundId info: soundInfo state: state! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 7/15/1998 20:06'!
recordButton: id trackAsMenu: aBoolean
	"Track the button with the given ID as a menu (in contrast to a push) button. Push buttons capture the mouse until the button is released. Menu buttons don't.
	Note: If defined for a button, this method will be called prior to any other #recordButton: methods."! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:36'!
recordDefineButton: id
	"Record the definition of a new button with the given id"! !

!FlashFileReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:47'!
recordEndButton: id
	"Record the end of a button definition with the given id"
! !


!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 10/15/1998 02:36'!
recordSound: id data: aSampledSound! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:41'!
recordSoundStreamBlock: compressedData! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:45'!
recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed! !

!FlashFileReader methodsFor: 'defining sounds' stamp: 'ar 8/10/1998 15:41'!
recordStartSound: id info: info! !


!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:33'!
recordBackgroundColor: aColor! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/16/1998 16:54'!
recordBeginSprite: id frames: frameCount! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 22:27'!
recordBitmap: bitmapId data: aForm! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/16/1998 16:55'!
recordEndSprite: id! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/15/1998 19:41'!
recordFrameActions: actionList
	"Record the list of actions executed at the next showFrame"! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/18/1998 22:00'!
recordFrameCount: maxFrames! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 11/17/1998 13:36'!
recordFrameLabel: label
	"Name the current frame with the given label"! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 8/10/1998 18:23'!
recordFrameRate: fps! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/15/1998 20:30'!
recordFreeCharacter: id
	"Free the character with the given id.
	Not documented."! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/10/1998 15:51'!
recordGlobalBounds: bounds! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:10'!
recordMorph: id depth: depth ratio: ratio! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/1/1999 14:40'!
recordMoveObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 9/1/1999 14:42'!
recordPlaceObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:32'!
recordProtection! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 22:34'!
recordRemoveObject: id depth: depth! !

!FlashFileReader methodsFor: 'misc' stamp: 'ar 7/4/1998 20:34'!
recordShowFrame! !


!FlashFileReader methodsFor: 'processing morphs' stamp: 'mir 11/2/1999 17:05'!
processMorphFillStylesFrom: data
	| nFills nColors rampIndex rampColor id fillStyleType color1 color2 matrix1 matrix2 ramp1 ramp2 |
	nFills _ data nextByte.
	nFills = 255 ifTrue:[nFills _ data nextWord].
	log ifNotNil:[log crtab; print: nFills; nextPutAll:' New fill styles'].
	1 to: nFills do:[:i|
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab].
		fillStyleType _ data nextByte.
		(fillStyleType = 0) ifTrue:["Solid fill"
			color1 _ data nextColor: true.
			color2 _ data nextColor: true.
			self recordMorphFill: i color1: color1 color2: color2.
			log ifNotNil:[log nextPutAll:'solid color '; print: color1; nextPutAll:' -- '; print: color2].
		].
		(fillStyleType anyMask: 16) ifTrue:["Gradient fill"
			"Read gradient matrix"
			matrix1 _ data nextMatrix.
			matrix2 _ data nextMatrix.
			"Read color ramp data"
			nColors _ data nextByte.
			ramp1 _ Array new: nColors.
			ramp2 _ Array new: nColors.
			log ifNotNil:[log nextPutAll:'Gradient fill with '; print: nColors; nextPutAll:' colors'].
			1 to: nColors do:[:j|
				rampIndex _ data nextByte.
				rampColor _ data nextColor: true.
				ramp1 at: j put: (rampIndex -> rampColor).
				rampIndex _ data nextByte.
				rampColor _ data nextColor: true.
				ramp2 at: j put: (rampIndex -> rampColor)].
			self recordMorphFill: i matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: (fillStyleType = 16).
			fillStyleType _ 0].
		(fillStyleType anyMask: 16r40) ifTrue:["Bit fill"
			"Read bitmap id"
			id _ data nextWord.
			"Read bitmap matrix"
			matrix1 _ data nextMatrix.
			matrix2 _ data nextMatrix.
			log ifNotNil:[log nextPutAll:'Bitmap fill id='; print: id].
			self recordMorphFill: i matrix1: matrix1 matrix2: matrix2 id: id clipped: (fillStyleType anyMask: 1).
			fillStyleType _ 0].
		fillStyleType = 0 ifFalse:[self error:'Unknown fill style: ',fillStyleType printString].
		self flushLog.
	].! !

!FlashFileReader methodsFor: 'processing morphs' stamp: 'ar 9/3/1999 14:40'!
processMorphLineStylesFrom: data
	| nStyles styles lineWidth1 lineWidth2 lineColor1 lineColor2 |
	nStyles _ data nextByte.
	nStyles = 255 ifTrue:[nStyles _ data nextWord].
	log ifNotNil:[log crtab; print: nStyles; nextPutAll:' New line styles'].
	styles _ Array new: nStyles.
	1 to: nStyles do:[:i|
		lineWidth1 _ data nextWord.
		lineWidth2 _ data nextWord.
		lineColor1 _ data nextColor: true.
		lineColor2 _ data nextColor: true.
		self recordMorphLineStyle: i width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2.
		log ifNotNil:[log crtab: 2; print: i; nextPut:$:; tab; 
						print: lineWidth1; tab; print: lineColor1; tab;
						print: lineWidth2; tab; print: lineColor2; tab]].
	self flushLog.
	^styles! !

!FlashFileReader methodsFor: 'processing morphs' stamp: 'ar 9/3/1999 19:08'!
processMorphShapeFrom: data
	"Process a new morph shape"
	| id bounds1 bounds2 edgeOffset |
	"Read shape id and bounding box"
	id _ data nextWord.
	bounds1 _ data nextRect.
	bounds2 _ data nextRect.
	edgeOffset _ data nextULong. "edge offset"
	edgeOffset _ edgeOffset + data position.
	"Start new shape definition"
	self recordMorphShapeStart: id srcBounds: bounds1 dstBounds: bounds2.
	"Read fill styles for this shape"
	self processMorphFillStylesFrom: data.
	"Read line styles for this shape"
	self processMorphLineStylesFrom: data.
	"Get number of bits for fill and line styles"
	data initBits.
	nFillBits _ data nextBits: 4.
	nLineBits _ data nextBits: 4.
	"Process all records in this shape definition"
	[self processShapeRecordFrom: data] whileTrue.
	self recordMorphBoundary: id.
	data position: edgeOffset.
	data initBits.
	nFillBits _ data nextBits: 4.
	nLineBits _ data nextBits: 4.
	[self processShapeRecordFrom: data] whileTrue.
	"And mark the end of this shape"
	self recordMorphShapeEnd: id.
	self recordShapeProperty: id length: data size.! !


!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:43'!
recordMorphBoundary: id! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:06'!
recordMorphFill: i color1: color1 color2: color2! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:07'!
recordMorphFill: id matrix1: matrix1 matrix2: matrix2 id: bmId clipped: aBool! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:07'!
recordMorphFill: id matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: isLinear! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:13'!
recordMorphLineStyle: i width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:18'!
recordMorphShapeEnd: id! !

!FlashFileReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 14:06'!
recordMorphShapeStart: id srcBounds: bounds1 dstBounds: bounds2! !

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

FlashFileReader class
	instanceVariableNames: ''!

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 10/15/1998 01:18'!
initialize
	"FlashFileReader initialize"
	self initializeTagTable.
	self initializeActionTable.
	self initializeStepTable.
	self initializeIndexTables.! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 7/15/1998 18:53'!
initializeActionTable
	"Create and return a new SWF action table"
	"FlashFileReader initializeActionTable"
	ActionTable _ Array new: 12.
	ActionTable atAllPut: #processUnknownAction:.
	#(
		(processActionGotoFrame:	1)
		(processActionGetURL:		3)
		(processActionNextFrame:	4)
		(processActionPrevFrame:	5)
		(processActionPlay:			6)
		(processActionStop:			7)
		(processActionToggleQuality:	8)
		(processActionStopSounds:	9)
		(processActionWaitForFrame:	10)
		(processActionSetTarget:		11)
		(processActionGotoLabel:		12)
	) do:[:spec|
			ActionTable at: spec last put: spec first.
	].
! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 10/15/1998 01:18'!
initializeIndexTables
	IndexTables _ Array new: 4.
	IndexTables at: 1 put:
		#(-1 2).
	IndexTables at: 2 put:
		#(-1 -1 2 4).
	IndexTables at: 3 put:
		#(-1 -1 -1 -1 2 4 6 8).
	IndexTables at: 4 put:
		#(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16).! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 10/15/1998 01:15'!
initializeStepTable
	StepTable _ #(7 8 9 10 11 12 13 14 16 17
					19 21 23 25 28 31 34 37 41 45
					50 55 60 66 73 80 88 97 107 118
					130 143 157 173 190 209 230 253 279 307
					337 371 408 449 494 544 598 658 724 796
					876 963 1060 1166 1282 1411 1552 1707 1878 2066
					2272 2499 2749 3024 3327 3660 4026 4428 4871 5358
					5894 6484 7132 7845 8630 9493 10442 11487 12635 13899
					15289 16818 18500 20350 22385 24623 27086 29794 32767).! !

!FlashFileReader class methodsFor: 'class initialization' stamp: 'ar 11/20/1998 22:10'!
initializeTagTable
	"Create and return a new SWF tag table"
	"FlashFileReader initializeTagTable"
	TagTable _ Array new: 50.
	TagTable atAllPut: #processUnknown:.
	#(
	(processEnd:					0)
	(processShowFrame:			1)
	(processDefineShape:		2)
	(processFreeCharacter:		3)
	(processPlaceObject:			4)
	(processRemoveObject:		5)
	(processDefineBits:			6)
	(processDefineButton:		7)
	(processJPEGTables:			8)
	(processSetBackgroundColor:	9)
	(processDefineFont:			10)
	(processDefineText:			11)
	(processDoAction:			12)
	(processDefineFontInfo:		13)
	"Event sound tags."
	(processDefineSound:		14)
	(processStartSound:			15)
	(processDefineButtonSound:	17)
	(processSoundStreamHead:	18)
	(processSoundStreamBlock:	19)
	(processDefineBitsLossless:	20)	"A bitmap using lossless zlib compression."
	(processDefineBitsJPEG2:		21)	"A bitmap using an internal JPEG compression table"
	(processDefineShape2:		22)
	(processDefineButtonCxform:	23)
	(processProtect:				24)	"This file should not be importable for editing."

	"These are the new tags for Flash 3."
	(processPlaceObject2:			26)	"The new style place w/ alpha color transform and name."
	(processRemoveObject2:		28)	"A more compact remove object that omits the character tag (just depth)."
	(processDefineShape3:		32)	"A shape V3 includes alpha values."
	(processDefineText2:			33) "A text V2 includes alpha values."
	(processDefineButton2:		34)	"A button V2 includes color transform) alpha and multiple actions"
	(processDefineBitsJPEG3:		35)	"A JPEG bitmap with alpha info."
	(processDefineBitsLossless2:	36)	"A lossless bitmap with alpha info."
	(processDefineSprite:		39) "Define a sequence of tags that describe the behavior of a sprite."
	(processNameCharacter:		40) "Name a character definition, character id and a string, (used for buttons) bitmaps, sprites and sounds)."
	(processFrameLabel:			43) "A string label for the current frame."
	(processSoundStreamHead2:	45) "For lossless streaming sound, should not have needed this..."
	(processDefineMorphShape:	46) "A morph shape definition"
	(processDefineFont2:			48)
	) do:[:spec|
			TagTable at: spec last+1 put: spec first.
	].! !


!FlashFileReader class methodsFor: 'instance creation' stamp: 'ar 7/3/1998 19:04'!
fileNamed: aString
	"FlashFileReader fileNamed:'/home/isg/raab/WDI/flash/samples/top.swf'"
	^self on: (FileStream readOnlyFileNamed: aString).! !

!FlashFileReader class methodsFor: 'instance creation' stamp: 'ar 7/2/1998 19:53'!
on: aStream
	^self new on: aStream! !


!FlashFileReader class methodsFor: 'testing' stamp: 'ar 7/2/1998 20:30'!
canRead: aStream
	"Return true if instances of the receiver know how to handle the data from aStream."
	| ok pos |
	pos _ aStream position.
	ok _ aStream next asCharacter = $F and:[
			aStream next asCharacter  = $W and:[
				aStream next asCharacter = $S]].
	aStream position: pos.
	^ok! !


!FlashFileReader class methodsFor: 'accessing' stamp: 'ar 10/16/1998 00:29'!
tagTable
	^TagTable! !
Stream subclass: #FlashFileStream
	instanceVariableNames: 'stream bitBuffer bitPosition hasAlpha '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Import'!

!FlashFileStream methodsFor: 'initialize' stamp: 'ar 7/15/1998 20:10'!
on: aSourceStream
	stream _ aSourceStream.
	bitBuffer _ bitPosition _ 0.
	hasAlpha _ false. "Turn on if needed"! !


!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:48'!
atEnd
	^stream atEnd! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:44'!
close
	self flushBits.
	stream close! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:46'!
hasAlpha
	^hasAlpha! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:46'!
hasAlpha: aBoolean
	hasAlpha _ aBoolean! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:23'!
next
	"Make sure the bit buffer is reset"
	self initBits.
	^stream next! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/13/1998 00:40'!
nextByte
	"Make sure the bit buffer is reset"
	self initBits.
	^stream next! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/15/1998 02:24'!
nextByteForBits
	^stream next ifNil:[0]! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:19'!
nextByteForBitsPut: aByte
	^stream nextPut: aByte! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/16/1998 01:27'!
nextBytePut: aByte
	"Make sure the bit buffer is reset"
	self flushBits.
	stream nextPut: aByte! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:50'!
nextBytes: n
	"Return a ByteArray containing the next n bytes"
	^stream next: n! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:43'!
peekFor: anObject
	^stream peekFor: anObject! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 18:00'!
position
	^stream position! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 10/1/1998 14:56'!
position: aNumber
	stream position: aNumber.! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 18:00'!
size
	^stream size! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/15/1998 19:01'!
skip: nBytes
	self initBits.
	stream skip: nBytes! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 7/3/1998 17:48'!
stream
	^stream! !

!FlashFileStream methodsFor: 'accessing' stamp: 'ar 8/10/1998 14:18'!
upToEnd
	^self stream upToEnd.! !


!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:38'!
initBits
	"Initialize the bit buffer for future bit reading operations.
	Note: We do not fetch the first byte here so we can do multiple #initBits
	without harming the position of the input stream."
	bitPosition _ bitBuffer _ 0.! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 21:39'!
nextBitFlag
	^(self nextBits: 1) = 1! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/4/1998 18:27'!
nextBits: n
	"Return the next n bits"
	| shift value remaining |
	n = 0 ifTrue:[^0].
	(n between: 1 and: 32) ifFalse:[^self error:'Bad number of bits'].
	value _ 0.
	remaining _ n.
	[true] whileTrue:[
		shift _ remaining - bitPosition.
		value _ value bitOr: (bitBuffer bitShift: shift).
		shift > 0 ifTrue:["Consumes entire buffer"
			remaining _ remaining - bitPosition.
			"And get next byte"
			bitBuffer _ self nextByteForBits.
			bitPosition _ 8.
		] ifFalse:["Consumes a portion of the buffer"
			bitPosition _ bitPosition - remaining.
			"Mask off the consumed bits"
			bitBuffer _ bitBuffer bitAnd: (255 bitShift: (bitPosition - 8)).
			^value]].! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/15/1998 19:44'!
nextColor
	| r g b baseColor |
	r _ self nextByte / 255.0.
	g _ self nextByte / 255.0.
	b _ self nextByte / 255.0.
	baseColor _ Color r: r g: g b: b.
	^hasAlpha 
		ifTrue:[baseColor alpha: self nextByte / 255.0]
		ifFalse:[baseColor]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 9/3/1999 14:40'!
nextColor: usingAlpha
	| r g b baseColor |
	r _ self nextByte / 255.0.
	g _ self nextByte / 255.0.
	b _ self nextByte / 255.0.
	baseColor _ Color r: r g: g b: b.
	^usingAlpha 
		ifTrue:[baseColor alpha: self nextByte / 255.0]
		ifFalse:[baseColor]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 11/24/1998 15:01'!
nextColorMatrix
	"Read a (possibly compressed) color transformation"
	| transform nBits flags |
	transform _ FlashColorTransform new.
	self initBits.
	flags _ self nextBits: 2.
	nBits _ self nextBits: 4.
	(flags anyMask: 1) ifTrue:["Read multiplication factors"
		transform rMul: (self nextSignedBits: nBits) / 256.0.
		transform gMul: (self nextSignedBits: nBits) / 256.0.
		transform bMul: (self nextSignedBits: nBits) / 256.0.
		hasAlpha ifTrue:[transform aMul: (self nextSignedBits: nBits) / 256.0]].
	(flags anyMask: 2) ifTrue:["Read multiplication factors"
		transform rAdd: (self nextSignedBits: nBits) / 256.0.
		transform gAdd: (self nextSignedBits: nBits) / 256.0.
		transform bAdd: (self nextSignedBits: nBits) / 256.0.
		hasAlpha ifTrue:[transform aAdd: (self nextSignedBits: nBits) / 256.0]].
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 6/28/1999 16:33'!
nextColorMatrix: usingAlpha
	| hadAlpha transform |
	hadAlpha _ hasAlpha.
	hasAlpha _ usingAlpha.
	transform _ self nextColorMatrix.
	hasAlpha _ hadAlpha.
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 10/16/1998 00:47'!
nextLong
	| ulong |
	ulong _ self nextULong.
	^ulong > 16r80000000
		ifTrue:[ulong - 16r100000000]
		ifFalse:[ulong]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 11/20/1998 00:29'!
nextMatrix
	"Read a (possibly compressed) transformation matrix"
	| transform nBits |
	transform _ MatrixTransform2x3 identity.
	self initBits.
	(self nextBits: 1) = 1 ifTrue:["Read a,d"
		nBits _ self nextBits: 5.
		transform a11: (self nextSignedBits: nBits) / 65536.0.
		transform a22: (self nextSignedBits: nBits) / 65536.0].
	(self nextBits: 1) = 1 ifTrue:["Read b,c"
		nBits _ self nextBits: 5.
		transform a21: (self nextSignedBits: nBits) / 65536.0.
		transform a12: (self nextSignedBits: nBits) / 65536.0].
	"Read tx, ty"
	nBits _ self nextBits: 5.
	"Transcript cr; show:'nBits = ', nBits printString, ' from ', thisContext sender printString."
	transform a13: (self nextSignedBits: nBits) asFloat.
	transform a23: (self nextSignedBits: nBits) asFloat.
	^transform! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/4/1998 18:42'!
nextPoint
	"Read a (possibly compressed) point"
	| nBits point |
	nBits _ self nextBits: 5.
	point _ (self nextSignedBits: nBits) @ (self nextSignedBits: nBits).
	^point! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:41'!
nextRect
	"Read a (possibly compressed) rectangle"
	| nBits xMin xMax yMin yMax |
	self initBits.
	nBits _ self nextBits: 5.
	xMin _ self nextSignedBits: nBits.
	xMax _ self nextSignedBits: nBits.
	yMin _ self nextSignedBits: nBits.
	yMax _ self nextSignedBits: nBits.
	^(xMin@yMin) corner: (xMax@yMax).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 19:11'!
nextSignedBits: n
	"Return the next n bits as signed integer value"
	| value bits signBit |
	n = 0 ifTrue:[^0].
	value _ self nextBits: n.
	"Use a lookup for determining whether or not the value should be sign extended"
	bits _ #( 1 2 4 8 16 32 64 128 "1 ... 8"
			256 512 1024 2048 4096 8192 16384 32768 "9 ... 16"
			65536 131072 262144 524288 1048576 2097152 4194304 8388608 "17 ... 24"
			16777216 33554432 67108864 134217728 268435456 536870912 1073741824 2147483648 "25 ... 32"
			 4294967296 "33 bit -- for negation only" ).
	signBit _ bits at: n.
	^(value bitAnd: signBit) = 0
		ifTrue:[value]
		ifFalse:[value - (bits at: n+1)]! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextString
	| out byte |
	out _ WriteStream on: (String new: 50).
	[byte _ self nextByte.
	byte = 0] whileFalse:
		[out nextPut: (self convertChar2Squeak: byte asCharacter)].
	^out contents! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:44'!
nextTag
	"Read the next tag. Return an association with the key being the tag id and its value the contents of the chunk following."
	| word tag length |
	word _ self nextWord.
	"Extract tag and length from the word"
	length _ word bitAnd: 16r3F.
	tag _ word bitShift: -6.
	"Check if an extra word follows"
	length = 16r3F ifTrue:[length _ self nextULong].
	^Association key: tag value: (self nextBytes: length).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextULong
	^self nextByte + 
		(self nextByte bitShift: 8) + 
		(self nextByte bitShift: 16) + 
		(self nextByte bitShift: 24).! !

!FlashFileStream methodsFor: 'reading data' stamp: 'ar 7/3/1998 17:40'!
nextWord
	^self nextByte + (self nextByte bitShift: 8)! !


!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:27'!
flushBits
	"Flush the bit buffer for future bit writing operations."
	bitPosition = 0 ifFalse:[self nextByteForBitsPut: bitBuffer].
	bitPosition _ 0.
	bitBuffer _ 0.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:36'!
nextBitFlag: aBoolean
	^self nextBits: 1 put: (aBoolean ifTrue:[1] ifFalse:[0])! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:41'!
nextBits: n put: aNumber
	"Write the next n bits"
	| value remaining shift |
	value _ aNumber. "Do not round - this is a sanity check"
	value isInteger ifFalse:[^self error:'Not an integer number'].
	value < 0 ifTrue:[^self error:'Not a positive number'].
	n = 0 ifTrue:[^0].
	(n between: 1 and: 32) ifFalse:[^self error:'Bad number of bits'].
	value < (1 bitShift: n) ifFalse:[^self error:'Unable to represent number'].
	remaining _ n.
	[true] whileTrue:[
		shift _ 8 - bitPosition - remaining.
		bitBuffer _ bitBuffer + (value bitShift: shift).
		"Mask out consumed bits"
		value _ value bitAnd: (1 bitShift: 0-shift) - 1.
		shift < 0 ifTrue:["Buffer overflow"
			remaining _ remaining - (8 - bitPosition).
			"Store next byte"
			self nextByteForBitsPut: bitBuffer.
			bitBuffer _ 0.
			bitPosition _ 0.
		] ifFalse:["Store only portion of the buffer"
			bitPosition _ bitPosition + remaining.
			^self
		].
	].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'bf 3/16/2000 19:01'!
nextColorMatrixPut: cm
	"Write a (possibly compressed) color transformation"
	self flushBits.
	self nextBits: 2 put: 3. "Always write full transform"
	self nextBits: 4 put: 15. "Always use full accuracy"
	self nextSignedBits: 15 put: cm rMul.
	self nextSignedBits: 15 put: cm gMul.
	self nextSignedBits: 15 put: cm bMul.
	hasAlpha ifTrue:[self nextSignedBits: 15 put: cm aMul].
	self nextSignedBits: 15 put: cm rAdd.
	self nextSignedBits: 15 put: cm gAdd.
	self nextSignedBits: 15 put: cm bAdd.
	hasAlpha ifTrue:[self nextSignedBits: 15 put: cm aAdd].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:38'!
nextColorPut: aColor
	self nextBytePut: (aColor red * 255) rounded.
	self nextBytePut: (aColor green * 255) rounded.
	self nextBytePut: (aColor blue * 255) rounded.
	hasAlpha ifTrue:[self nextBytePut: (aColor alpha * 255) rounded].
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:46'!
nextLongPut: value

	value < 0 
		ifTrue:[self nextULongPut: 16r100000000 - value]
		ifFalse:[self nextULongPut: value]! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 11/2/1998 23:00'!
nextMatrixPut: matrix
	"write a (possibly compressed) transformation matrix"
	self flushBits.
	(matrix a11 = 0.0 and:[matrix  a22 = 0.0]) ifFalse:[
		"Write a/d"
		self nextBits: 1 put: 1.
		self nextBits: 5 put: 31. "Always use full accuracy"
		self nextSignedBits: 31 put: matrix a11 * 65536.
		self nextSignedBits: 31 put: matrix a22 * 65536.
	] ifTrue:[self nextBits: 1 put: 0].
	((matrix a12) = 0.0 and:[(matrix  a21) = 0.0]) ifFalse:[
		"Write b/c"
		self nextBits: 1 put: 1.
		self nextBits: 5 put: 31. "Always use full accuracy"
		self nextSignedBits: 31 put: matrix a12 * 65536.
		self nextSignedBits: 31 put: matrix a21 * 65536.
	] ifTrue:[self nextBits: 1 put: 0].
	"Write tx/ty"
	self nextBits: 5 put: 31. "Always use full accuracy"
	self nextSignedBits: 31 put: matrix a13.
	self nextSignedBits: 31 put: matrix a23.
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:55'!
nextPointPut: aPoint
	"Write a (possibly compressed) point"
	self nextBits: 5 put: 31. "Always write full accuracy"
	self nextSignedBits: 31 put: aPoint x.
	self nextSignedBits: 31 put: aPoint y.
! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:29'!
nextRectPut: aRect
	"Write a (possibly compressed) rectangle"
	self nextBits: 5 put: 31. "Always use full accuracy"
	self nextSignedBits: 31 put: aRect origin x.
	self nextSignedBits: 31 put: aRect corner x.
	self nextSignedBits: 31 put: aRect origin y.
	self nextSignedBits: 31 put: aRect corner y.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 00:59'!
nextSignedBits: n put: someValue
	"Write the next n bits as signed integer value"
	| value |
	value _ someValue rounded. "Do rounding here if not done before"
	value < 0
		ifTrue:[self nextBits: n put: 16r100000000 - value]
		ifFalse:[self nextBits: n put: value]! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:01'!
nextStringPut: aString

	aString do:[:char| self nextBytePut: (self convertCharFromSqueak: char) asInteger].
	self nextBytePut: 0.! !

!FlashFileStream methodsFor: 'writing data' stamp: 'di 2/9/1999 15:16'!
nextTagPut: tag length: length
	"Write the next tag."
	length >= 16r3F ifTrue:[
		self nextWordPut: (tag bitShift: 6) + 16r3F.
		self nextULongPut: length.
	] ifFalse:[
		self nextWordPut: (tag bitShift: 6) + length.
	].! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:04'!
nextULongPut: long
	self nextBytePut: (long bitAnd: 255).
	self nextBytePut: ((long bitShift: -8) bitAnd: 255).
	self nextBytePut: ((long bitShift: -16) bitAnd: 255).
	self nextBytePut: ((long bitShift: -24) bitAnd: 255).! !

!FlashFileStream methodsFor: 'writing data' stamp: 'ar 10/16/1998 01:06'!
nextWordPut: value
	self nextBytePut: (value bitAnd: 255).
	self nextBytePut: ((value bitShift: -8) bitAnd: 255).! !


!FlashFileStream methodsFor: 'private' stamp: 'ar 7/3/1998 18:17'!
convertChar2Squeak: aCharacter
	"Convert aCharacter from SWF char set (whatever this may be) to Squeaks char set"
	^aCharacter! !

!FlashFileStream methodsFor: 'private' stamp: 'ar 10/16/1998 01:01'!
convertCharFromSqueak: aCharacter
	"Convert aCharacter to SWF char set (whatever this may be) "
	^aCharacter! !

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

FlashFileStream class
	instanceVariableNames: ''!

!FlashFileStream class methodsFor: 'instance creation' stamp: 'ar 7/3/1998 17:33'!
on: aSourceStream
	^self basicNew on: aSourceStream! !
Object subclass: #FlashFileWriter
	instanceVariableNames: 'stream log dataSize nFillBits nLineBits nGlyphBits nAdvanceBits jpegEncoder '
	classVariableNames: 'TagTable '
	poolDictionaries: ''
	category: 'Balloon-MMFlash Import'!

!FlashFileWriter methodsFor: 'initialize' stamp: 'ar 10/16/1998 01:23'!
close
	stream close! !

!FlashFileWriter methodsFor: 'initialize' stamp: 'ar 10/16/1998 01:22'!
on: aStream
	aStream binary.
	stream _ FlashFileStream on: aStream.! !


!FlashFileWriter methodsFor: 'writing' stamp: 'ar 10/16/1998 01:26'!
writeHeader: bounds rate: frameRate
	"Read header information from the source stream.
	Return true if successful, false otherwise."
	self halt.
	self writeSignature.
	stream nextBytePut: 3. "Always write flash3"
	dataSize _ stream nextLongPut: 0.	"Place holder for data size"
	stream nextRectPut: bounds.
	stream nextWordPut: (frameRate * 256) truncated.! !

!FlashFileWriter methodsFor: 'writing' stamp: 'ar 10/16/1998 01:20'!
writeSignature
	stream nextBytePut: $F asInteger.
	stream nextBytePut: $W asInteger.
	stream nextBytePut: $S asInteger.! !

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

FlashFileWriter class
	instanceVariableNames: ''!

!FlashFileWriter class methodsFor: 'class initialization' stamp: 'ar 10/16/1998 00:31'!
initialize
	"FlashFileWriter initialize"
	TagTable _ Dictionary new.
	FlashFileReader tagTable doWithIndex:[:tag :index|
		TagTable at: (tag copyWithout: $:) asSymbol put: index
	].! !


!FlashFileWriter class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 01:23'!
newFileNamed: aString
	"FlashFileWriter newFileNamed:'f:\wdi\GraphicsEngine\flash\test.swf'"
	^self on: (FileStream newFileNamed: aString).! !

!FlashFileWriter class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 01:24'!
on: aStream
	^self new on: aStream! !
FlashMorph subclass: #FlashGlyphMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashGlyphMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 17:17'!
color: aColor
	super color: aColor.
	submorphs do:[:m| m color: aColor].! !

!FlashGlyphMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:51'!
defaultAALevel
	^4! !
JPEGReadWriter subclass: #FlashJPEGDecoder
	instanceVariableNames: 'eoiSeen streaming '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Import'!

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 10/1/1998 14:34'!
decodeJPEGTables: aStream
	self setStream: aStream.
	eoiSeen _ false.
	self parseFirstMarker.
	[eoiSeen] whileFalse:[self parseNextMarker].! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 11/18/1998 21:33'!
decodeNextImageFrom: aStream
	| image |
	self setStream: aStream.
	self isStreaming ifFalse:[Cursor wait show].
	image _ self nextImage.
	self isStreaming ifFalse:[Cursor normal show].
	^image! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 11/18/1998 23:25'!
nextImageDitheredToDepth: depth
	"Overwritten to yield every now and then."
	| form xStep yStep x y |
	ditherMask _ DitherMasks
		at: depth
		ifAbsent: [self error: 'can only dither to display depths'].
	redResidual _ greenResidual _ blueResidual _ 0.
	sosSeen _ false.
	self parseFirstMarker.
	[sosSeen] whileFalse: [self parseNextMarker].
	form _ Form extent: (width @ height) depth: 32.
	xStep _ mcuWidth * DCTSize.
	yStep _ mcuHeight * DCTSize.
	y _ 0.
	1 to: mcuRowsInScan do:
		[:row |
		"self isStreaming ifTrue:[Processor yield]."
		x _ 0.
		1 to: mcusPerRow do:
			[:col |
			self decodeMCU.
			self idctMCU.
			self colorConvertMCU.
			mcuImageBuffer displayOn: form at: (x @ y).
			x _ x + xStep].
		y _ y + yStep].
	^ form! !

!FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 10/1/1998 14:34'!
parseEndOfInput
	eoiSeen _ true.! !


!FlashJPEGDecoder methodsFor: 'stream access' stamp: 'ar 10/1/1998 14:42'!
next
	^stream nextByte! !

!FlashJPEGDecoder methodsFor: 'stream access' stamp: 'ar 10/1/1998 14:43'!
next: n
	^stream nextBytes: n! !


!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:32'!
isStreaming
	^streaming! !

!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:31'!
isStreaming: aBool
	streaming _ aBool! !

!FlashJPEGDecoder methodsFor: 'accessing' stamp: 'ar 1/15/1999 03:35'!
understandsImageFormat
	"Return false so we don't get confused with ImageReadWriter's mechanism for finding the right class to read a given stream."
	^false! !
Object subclass: #FlashKeyframe
	instanceVariableNames: 'start stop data '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashKeyframe methodsFor: 'initialize' stamp: 'ar 11/12/1998 22:55'!
from: startValue to: stopValue data: newData
	start _ startValue.
	stop _ stopValue.
	data _ newData.! !


!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:48'!
data
	^data! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:48'!
data: anObject
	data _ anObject! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
start
	^start! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
start: startValue
	start _ startValue! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
stop
	^stop! !

!FlashKeyframe methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:55'!
stop: stopValue
	stop _ stopValue! !


!FlashKeyframe methodsFor: 'testing' stamp: 'di 11/21/1999 20:26'!
includesFrame: aNumber
	^aNumber >= start and:[aNumber <= stop]! !


!FlashKeyframe methodsFor: 'printing' stamp: 'ar 11/13/1998 14:33'!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPut:$(;
		print: start;
		nextPut:$-;
		print: stop;
		nextPutAll:' -> ';
		print: data;
		nextPut:$)! !

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

FlashKeyframe class
	instanceVariableNames: ''!

!FlashKeyframe class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 22:47'!
from: startValue to: stopValue
	^self new from: startValue to: stopValue! !

!FlashKeyframe class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 22:54'!
from: startValue to: stopValue data: newData
	^self new from: startValue to: stopValue data: newData! !
Object subclass: #FlashKeyframes
	instanceVariableNames: 'kfList lastIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashKeyframes methodsFor: 'initialize' stamp: 'ar 8/14/1998 19:32'!
initialize
	kfList _ OrderedCollection new.! !


!FlashKeyframes methodsFor: 'accessing' stamp: 'di 11/21/1999 20:26'!
at: frameNumber
	"Return data from the keyframe list at the given frame number"
	| lastEntry |
	kfList isEmpty ifTrue:[^nil].
	lastIndex ifNil:[lastIndex _ self searchFor: frameNumber].
	lastEntry _ kfList at: lastIndex.
	(lastEntry includesFrame: frameNumber) ifTrue:[^lastEntry data].
	"Do a quick check if the frame is out of range"
	kfList first stop >= frameNumber 
		ifTrue:[	lastIndex _ 1.
				^kfList first data].
	kfList last start <= frameNumber 
		ifTrue:[	lastIndex _ kfList size. 
				^kfList last data].

	"Search linearly from lastEntry - most times we'll just be one step away"
	[lastEntry stop >= frameNumber] whileFalse:[
		lastIndex _ lastIndex+1.
		lastEntry _ kfList at: lastIndex].
	[lastEntry start <= frameNumber] whileFalse:[
		lastIndex _ lastIndex-1.
		lastEntry _ kfList at: lastIndex].
	^lastEntry data! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:51'!
at: frameNumber put: newData
	"Add newData to the keyframe list at the given frameNumber"
	| kf |
	kfList ifNil:[kfList _ OrderedCollection new].
	kfList isEmpty ifFalse:["Check if we can extend the last interval"
		kf _ kfList last.
		kf stop < frameNumber 
			ifFalse:[^self replaceData: newData at: frameNumber].
		kf data = newData "Extend interval to include frameNumber"
			ifTrue:[	kf stop: frameNumber.
					^newData].
		"Extend last interval to just before frameNumer"
		kf stop: frameNumber - 1].
	kfList add: (FlashKeyframe from: frameNumber to: frameNumber data: newData).
	^newData! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 11/12/1998 22:51'!
keys
	^kfList collect:[:kf| kf start].! !

!FlashKeyframes methodsFor: 'accessing' stamp: 'ar 10/14/1998 20:27'!
size
	^kfList size! !


!FlashKeyframes methodsFor: 'printing' stamp: 'ar 8/14/1998 19:32'!
printOn: aStream
	aStream
		nextPutAll: self class name;
		nextPut: $(;
		cr.
	kfList do:[:item| aStream print: item; cr].

	aStream nextPut:$).! !


!FlashKeyframes methodsFor: 'private' stamp: 'ar 11/12/1998 22:51'!
replaceData: newData at: frameNumber
	(kfList last stop = frameNumber) 
		ifTrue:[^self replaceLastData: newData at: frameNumber].
	self halt:'Not implemented yet'! !

!FlashKeyframes methodsFor: 'private' stamp: 'ar 11/18/1998 23:29'!
replaceLastData: newData at: frameNumber
	| kf |
	lastIndex _ nil.
	kf _ kfList last.
	(kf stop = kf start)
		ifTrue:[kfList removeLast]
		ifFalse:[kf stop: kf stop-1].
	^self at: frameNumber put: newData! !

!FlashKeyframes methodsFor: 'private' stamp: 'di 11/21/1999 20:26'!
searchFor: frameNumber
	"Return data from the keyframe list at the given frame number"
	| low high mid kf |
	low _ kfList at: 1.
	high _ kfList at: kfList size.
	"Check if in or before first keyframe interval"
	frameNumber <= low stop ifTrue:[^1].
	"Check if in or after last keyframe interval"
	frameNumber >= high start ifTrue:[^kfList size].
	"Somewhere inbetween 2nd to (n-1)th interval"
	low _ 2. high _ kfList size - 1.
	[mid _ high + low // 2.
	low > high] whileFalse:[
		kf _ kfList at: mid.
		(kf includesFrame: frameNumber) ifTrue:[^mid].
		(kf start < frameNumber)
			ifTrue:[low _ mid + 1]
			ifFalse:[high _ mid - 1]].
	kf _ kfList at: low.
	(kf includesFrame: frameNumber) ifFalse:[self error:'No keyframe found'].
	^low! !

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

FlashKeyframes class
	instanceVariableNames: ''!

!FlashKeyframes class methodsFor: 'instance creation' stamp: 'ar 8/14/1998 19:32'!
new
	^super new initialize! !
Object subclass: #FlashLineStyle
	instanceVariableNames: 'width color '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color
	^color! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color: aColor
	color _ aColor! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
color: aColor width: aNumber
	self color: aColor.
	self width: aNumber.! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
width
	^width! !

!FlashLineStyle methodsFor: 'accessing' stamp: 'ar 7/14/1998 21:20'!
width: aNumber
	width _ aNumber! !


!FlashLineStyle methodsFor: 'comparing' stamp: 'ar 8/15/1998 00:59'!
= aLineStyle
	self class = aLineStyle class ifFalse:[^false].
	^self color = aLineStyle color and:[self width = aLineStyle width].! !

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

FlashLineStyle class
	instanceVariableNames: ''!

!FlashLineStyle class methodsFor: 'instance creation' stamp: 'ar 7/14/1998 21:19'!
color: aColor width: aNumber
	^self new color: aColor width: aNumber! !
MatrixTransformMorph subclass: #FlashMorph
	instanceVariableNames: 'colorTransform '
	classVariableNames: 'FlashSoundVolume '
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/16/1998 17:28'!
loadInitialFrame
	self computeBounds.! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 22:23'!
lockChildren
	submorphs do:[:m| 
		m isMouseSensitive ifFalse:[m lock]].! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 11/13/1998 16:10'!
reset
	submorphs do:[:m| m isFlashMorph ifTrue:[m reset]].! !

!FlashMorph methodsFor: 'initialize' stamp: 'ar 8/15/1998 17:21'!
unlockChildren
	submorphs do:[:m| m unlock].! !


!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:41'!
activationKeys
	^#()! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:27'!
colorTransform
	^colorTransform! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:27'!
colorTransform: aColorTransform
	colorTransform _ aColorTransform! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:48'!
defaultAALevel
	^self valueOfProperty: #aaLevel! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 02:51'!
defaultAALevel: aNumber
	aNumber isNil 
		ifTrue:[self removeProperty: #aaLevel]
		ifFalse:[self setProperty: #aaLevel toValue: aNumber]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:13'!
delete
	| player |
	player _ self flashPlayer.
	player ifNotNil:[player noticeRemovalOf: self].
	^super delete! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:00'!
depth
	^(self valueOfProperty: #depth) ifNil:[0]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 21:00'!
depth: d
	d = 0
		ifTrue:[self removeProperty: #depth]
		ifFalse:[self setProperty: #depth toValue: d]! !

!FlashMorph methodsFor: 'accessing' stamp: 'di 11/12/2000 15:53'!
flashPlayer
	^ self firstOwnerSuchThat: [:parent | parent isFlashMorph and: [parent isFlashPlayer]]! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 11:40'!
id
	^-1! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 11/24/1998 14:19'!
keepsTransform
	"Return true if the receiver will keep it's transform while being grabbed by a hand."
	^true! !

!FlashMorph methodsFor: 'accessing' stamp: 'ar 1/4/1999 08:48'!
originalFileSize
	^(self valueOfProperty: #originalFileSize) ifNil:[0]! !


!FlashMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 23:47'!
isFlashButton
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:52'!
isFlashCharacter
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 8/14/1998 21:12'!
isFlashMorph
	^true! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/15/1998 19:04'!
isFlashPlayer
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 6/2/1999 03:15'!
isFlashShape
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 17:03'!
isFlashSprite
	^false! !

!FlashMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true if the receiver is mouse sensitive and must stay unlocked"
	^false! !


!FlashMorph methodsFor: 'drawing' stamp: 'ar 11/16/1998 19:04'!
debugDraw
	| vis canvas m |
	vis _ self visible.
	self visible: true.
	canvas _ BalloonCanvas on:Display.
	m _ MatrixTransform2x3 withScale: 0.05.
	m offset: (self fullBounds origin // 20) negated.
	canvas transformBy: m.
	self fullDrawOn: canvas.
	self visible: vis.! !

!FlashMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:08'!
drawSubmorphsOn: aCanvas
	| aaLevel |
	aCanvas asBalloonCanvas preserveStateDuring:[:myCanvas|
		colorTransform ifNotNil:[myCanvas colorTransformBy: colorTransform].
		(aaLevel _ self defaultAALevel) ifNotNil:[myCanvas aaLevel: aaLevel].
		super drawSubmorphsOn: myCanvas].! !


!FlashMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:13'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.
	aCustomMenu add:'show compressed size' action: #showCompressedSize.! !

!FlashMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:16'!
getSmoothingLevel
	"Menu support"
	| aaLevel |
	aaLevel _ self defaultAALevel ifNil:[1].
	aaLevel = 1 ifTrue:[^'turn on smoothing'].
	aaLevel = 2 ifTrue:[^'more smoothing'].
	aaLevel = 4 ifTrue:[^'turn off smoothing'].
! !

!FlashMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:17'!
nextSmoothingLevel
	| aaLevel |
	aaLevel _ self defaultAALevel ifNil:[1].
	aaLevel = 1 ifTrue:[self defaultAALevel: 2].
	aaLevel = 2 ifTrue:[self defaultAALevel: 4].
	aaLevel = 4 ifTrue:[self defaultAALevel: nil].
	self changed.! !

!FlashMorph methodsFor: 'menu' stamp: 'ar 1/5/1999 16:18'!
showCompressedSize
	| size string |
	size _ self originalFileSize.
	size = 0 
		ifTrue:[string _ 'Compressed size: not available']
		ifFalse:[string _ 'Compressed size: ', size asStringWithCommas, ' bytes'].
	self world primaryHand attachMorph:
		(TextMorph new contents: string; beAllFont: ScriptingSystem fontForTiles).! !


!FlashMorph methodsFor: 'events' stamp: 'ar 10/5/2000 19:58'!
aboutToBeGrabbedBy: aHand
	"Usually, FlashMorphs exist in a player. 
	If they're grabbed and moved outside the player
	they should keep their position."
	| player |
	super aboutToBeGrabbedBy: aHand.
	player _ self flashPlayer.
	player ifNotNil:[player noticeRemovalOf: self].
	self transform: (self transformFrom: self world).
	"If extracted from player and no default AA level is set use prefs"
	(player notNil and:[self defaultAALevel == nil]) ifTrue:[
		Preferences extractFlashInHighQuality ifTrue:[self defaultAALevel: 2].
		Preferences extractFlashInHighestQuality ifTrue:[self defaultAALevel: 4].
	].
	^self "Grab me"! !

!FlashMorph methodsFor: 'events' stamp: 'ar 11/18/1998 14:04'!
justDroppedInto: newOwner event: evt
	| ownerTransform |
	ownerTransform _ (newOwner transformFrom: newOwner world).
	ownerTransform isIdentity ifFalse:[
		ownerTransform _ ownerTransform asMatrixTransform2x3 inverseTransformation.
		self transform: (self transform composedWithGlobal: ownerTransform).
	].
	super justDroppedInto: newOwner event: evt.! !


!FlashMorph methodsFor: 'printing' stamp: 'ar 11/16/1998 11:40'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut:$[;
		print: self depth;
		space.
	self visible 
		ifTrue:[aStream nextPutAll:'visible']
		ifFalse:[aStream nextPutAll:'invisible'].
	aStream
		nextPutAll:' id = ';
		print: self id;
		nextPut:$];
		cr.! !


!FlashMorph methodsFor: 'copying' stamp: 'ar 5/20/1999 15:34'!
copyExtension
	"Copy my extensions dictionary"
	| ext |
	extension ifNil:[^self].
	ext _ extension copy.
	ext removeOtherProperties.
	extension otherProperties ifNotNil:[
		extension otherProperties associationsDo:[:assoc|
			ext setProperty: assoc key toValue: assoc value copy.
		].
	].
	extension _ ext.! !

!FlashMorph methodsFor: 'copying' stamp: 'ar 5/20/1999 15:30'!
copyMovieFrom: firstFrame to: lastFrame
	| copy |
	copy _ self copy.
	copy copyExtension.
	copy addAllMorphs: 
		(self submorphs collect:[:m| m copyMovieFrom: firstFrame to: lastFrame]).
	^copy! !


!FlashMorph methodsFor: 'sound' stamp: 'jm 6/7/1999 08:25'!
playFlashSound: aSound
	"Play the given sound at the volume level for Flash sounds."

	FlashSoundVolume ifNil: [FlashSoundVolume _ 0.3].
	(MixedSound new add: aSound pan: 0.5 volume: FlashSoundVolume) play.
! !


!FlashMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:23'!
compress
	"Compress the receiver for efficient storage on disk"
	fullBounds _ nil. "Will be computed on the fly"
	submorphs do:[:m| m compress].! !

!FlashMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:23'!
decompress
	"Decompress the receiver"
	submorphs do:[:m| m decompress].
	self fullBounds. "Force computation"! !

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

FlashMorph class
	instanceVariableNames: ''!

!FlashMorph class methodsFor: 'instance creation' stamp: 'ar 11/15/1998 16:44'!
withAll: aCollection
	^(self new) 
		addAllMorphs: aCollection;
		computeBounds;
		yourself! !
FlashFileReader subclass: #FlashMorphReader
	instanceVariableNames: 'location fillStyles lineStyles shapes fonts forms sounds buttons lineSequence currentShape player spriteOwners stepTime frameRate frame activeMorphs passiveMorphs activeFont textOffset textHeight textMorph canCompressPoints pointList compressionBounds fillIndex0 fillIndex1 lineStyleIndex leftFillList rightFillList lineStyleList streamingSound morphedFillStyles morphedLineStyles '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Import'!

!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 10/15/1998 23:45'!
doLog
	^false! !

!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 10/14/1998 19:22'!
logShapes
	^false! !

!FlashMorphReader methodsFor: 'initialize' stamp: 'ar 11/21/1998 00:30'!
on: aStream
	super on: aStream.
	self doLog ifTrue:[log _ Transcript].
	fillStyles _ Dictionary new.
	lineStyles _ Dictionary new.
	shapes _ Dictionary new.
	player _ FlashPlayerMorph new.
	fonts _ Dictionary new.
	forms _ Dictionary new.
	sounds _ Dictionary new.
	buttons _ Dictionary new.
	spriteOwners _ IdentityDictionary new.
	stepTime _ 1000.
	frame _ 1.
	activeMorphs _ Dictionary new: 100.
	passiveMorphs _ Dictionary new: 100.
	self recordSolidFill: 1 color: Color black.
	compressionBounds _ (-16r7FFF asPoint) corner: (16r8000) asPoint.
	currentShape _ WriteStream on: (Array new: 5).
	pointList _ WriteStream on: (Array new: 100).
	leftFillList _ WriteStream on: (WordArray new: 100).
	rightFillList _ WriteStream on: (WordArray new: 100).
	lineStyleList _ WriteStream on: (WordArray new: 100).
	fillIndex0 _ fillIndex1 _ lineStyleIndex _ 0.
	streamingSound _ FlashStreamingSound new.! !


!FlashMorphReader methodsFor: 'reading' stamp: 'ar 2/13/1999 21:25'!
processFile
	"Read and process the entire file"
	super processFile.
	player loadInitialFrame.
	^player! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/19/1998 21:54'!
processFileAsync
	"Read and process the entire file"
	self processHeader ifFalse:[^nil].
	player sourceUrl:'dummy'.
	[self processFileContents] fork.
	^player! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/18/1998 23:44'!
processFileAsync: aPlayer
	"Read and process the entire file"
	player _ aPlayer.
	super processFile.! !

!FlashMorphReader methodsFor: 'reading' stamp: 'ar 11/21/1998 00:50'!
processFileContents
	super processFileContents.
	self flushStreamingSound.! !


!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/16/1998 01:23'!
recordFontShapeEnd: fontId with: charId
	| font shape |
	self endShape.
	shape _ FlashGlyphMorph withAll: currentShape contents reversed.
	shape lockChildren.
	currentShape resetToStart.
	font _ fonts at: fontId ifAbsentPut:[Dictionary new].
	font at: charId put: shape.
	self doLog ifTrue:[log _ Transcript].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/12/1998 21:39'!
recordFontShapeStart: fontId with: charId
	location _ 0@0.
	self logShapes ifFalse:[log _ nil].
	self beginShape.
	self recordSolidFill: 1 color: Color black.! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 01:41'!
recordNextChar: glyphIndex advanceWidth: advance
	| shape transform |
	(activeFont includesKey: glyphIndex) ifTrue:[
		shape _ (activeFont at: glyphIndex) fullCopy reset.
		"Must include the textMorph's transform here - it might be animated"
		transform _  ((MatrixTransform2x3 withOffset: textOffset) 
							setScale: (textHeight@textHeight) / 1024.0).
		transform _ transform composedWithGlobal: textMorph transform.
		shape transform: transform.
		shape color: textMorph color.
		textMorph addMorphBack: shape.].
	textOffset _ textOffset + (advance@0).! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 01:46'!
recordTextChange: fontId color: color xOffset: xOffset yOffset: yOffset height: height

	fontId ifNotNil:[activeFont _ fonts at: fontId].
	height ifNotNil:[textHeight _ height].
	xOffset ifNotNil:[textOffset _ xOffset @ textOffset x].
	yOffset ifNotNil:[textOffset _ textOffset x @ yOffset].
	color ifNotNil:[textMorph color: color].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 00:50'!
recordTextEnd: id
	textMorph submorphs isEmpty ifFalse:[
		textMorph allMorphsDo:[:m| m color: textMorph color].
		textMorph transform: nil.
		textMorph id: id.
		textMorph stepTime: stepTime.
		textMorph lockChildren.
		shapes at: id put: textMorph].
	self doLog ifTrue:[log _ Transcript].! !

!FlashMorphReader methodsFor: 'defining text' stamp: 'ar 11/20/1998 01:41'!
recordTextStart: id bounds: bounds matrix: matrix

	textOffset _ 0@0.
	textMorph _ FlashTextMorph new.
	textMorph privateBounds: bounds.
	textMorph color: Color black.
	matrix ifNotNil:[textMorph transform: matrix].! !


!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 8/14/1998 16:19'!
recordCurveSegmentTo: anchorPoint with: controlPoint
	| target midPoint |
	midPoint _ location + controlPoint.
	target _ midPoint + anchorPoint.
	self addLineFrom: location to: target via: midPoint.
	location _ target.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/17/1998 00:36'!
recordEndSubshape
	"A new subshape begins with a full set of line and fill styles"
	self endShape.
	self beginShape.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:45'!
recordFillStyle0: fillIndex
	fillIndex0 _ fillIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:45'!
recordFillStyle1: fillIndex
	fillIndex1 _ fillIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/3/1998 16:09'!
recordLineSegmentBy: deltaPoint
	| target |
	target _ location + deltaPoint.
	self addLineFrom: location to: target via: location.
	location _ target.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:40'!
recordLineStyle: styleIndex
	lineStyleIndex _ styleIndex.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/12/1998 20:44'!
recordMoveTo: aPoint
	location _ aPoint.! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 11/16/1998 01:23'!
recordShapeEnd: shapeId
	| shape |
	self endShape.
	shape _ FlashCharacterMorph withAll: (currentShape contents reversed).
	shape lockChildren.
	currentShape resetToStart.
	shape id: shapeId.
	shape stepTime: stepTime.
	shapes at: shapeId put: shape.
	self doLog ifTrue:[log _ Transcript].! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 1/4/1999 08:47'!
recordShapeProperty: id length: length
	(shapes at: id ifAbsent:[^self]) setProperty: #originalFileSize toValue: length! !

!FlashMorphReader methodsFor: 'composing shapes' stamp: 'ar 8/14/1998 23:23'!
recordShapeStart: shapeId bounds: bounds
	location _ 0@0.
	self logShapes ifFalse:[log _ nil].
	self beginShape.! !


!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/3/1998 18:09'!
addLineFrom: start to: end via: via

	canCompressPoints ifTrue:[
		"Check if we can compress the incoming points"
		(compressionBounds containsPoint: start) ifFalse:[canCompressPoints _ false].
		(compressionBounds containsPoint: via) ifFalse:[canCompressPoints _ false].
		(compressionBounds containsPoint: end) ifFalse:[canCompressPoints _ false].
	].
	pointList nextPut: start.
	pointList nextPut: via.
	pointList nextPut: end.
	leftFillList nextPut: fillIndex0.
	rightFillList nextPut: fillIndex1.
	lineStyleList nextPut: lineStyleIndex.
! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/12/1998 21:43'!
beginShape

	canCompressPoints _ true.
	fillStyles _ Dictionary new.
	lineStyles _ Dictionary new.
	pointList resetToStart.
	leftFillList resetToStart.
	rightFillList resetToStart.
	lineStyleList resetToStart.
	fillIndex0 _ fillIndex1 _ lineStyleIndex _ 0.! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/12/1998 21:24'!
computeFillLists
	"Compute the fill index lists"
	| leftFills rightFills |
	leftFills_ leftFillList contents as: ShortRunArray.
	rightFills _ rightFillList contents as: ShortRunArray.
	^Array with: leftFills with: rightFills! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/16/1998 13:02'!
computeLineStyleLists
	"Compute the line style index lists.
	Each line style will be splitted into two parts, the width and the fill.
	Then, the fills will be added to the fillStyles and the indexes will be adjusted.
	Finally, we compute two arrays containing the width of each line and the
	fill style of each line"
	| widthList fillList indexMap oldIndex newIndex allFillStyles style |
	allFillStyles _ Dictionary new.
	fillStyles associationsDo:[:assoc| 
		allFillStyles at: assoc key put: assoc value].
	indexMap _ Dictionary new.
	lineStyles associationsDo:[:assoc|
		oldIndex _ assoc key.
		style _ assoc value.
		allFillStyles at: allFillStyles size+1 put: (SolidFillStyle color: style color).
		newIndex _ allFillStyles size.
		indexMap at: oldIndex put: newIndex.
	].
	widthList _ OrderedCollection new: lineStyles size.
	fillList _ OrderedCollection new: lineStyles size.
	lineStyleList contents do:[:index|
		index = 0 ifTrue:[
			widthList add: 0.
			fillList add: 0.
		] ifFalse:[
			style _ lineStyles at: index ifAbsent:[FlashLineStyle color: Color black width: 20].
			widthList add: style width.
			fillList add: (indexMap at: index ifAbsent:[1]).
		].
	].
	widthList _ widthList as: ShortRunArray.
	fillList _ fillList as: ShortRunArray.
	^Array with: allFillStyles with: fillList with: widthList! !

!FlashMorphReader methodsFor: 'computing shapes' stamp: 'ar 11/15/1998 15:32'!
endShape
	| points shape fillLists lineLists index |
	canCompressPoints ifTrue:[
		points _ ShortPointArray new: pointList size.
	] ifFalse:[
		points _ PointArray new: pointList size.
	].
	index _ 1.
	pointList contents do:[:p|
		points at: index put: p.
		index _ index + 1].

	fillLists _ self computeFillLists.
	lineLists _ self computeLineStyleLists.
	shape _ FlashBoundaryShape 
				points: points 
				leftFills: fillLists first
				rightFills: fillLists last
				fillStyles: lineLists first
				lineWidths: lineLists last
				lineFills: (lineLists at: 2).
	shape remapFills.
	currentShape nextPut:(FlashShapeMorph shape: shape).! !


!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 12/5/1998 22:22'!
recordBitmapFill: index matrix: bmMatrix id: bitmapID clipped: aBoolean
	| fillStyle form |
	form _ forms at: bitmapID ifAbsent:[^nil].
	fillStyle _ BitmapFillStyle form: form.
	fillStyle origin: (bmMatrix localPointToGlobal: 0@0).
	fillStyle direction: (bmMatrix localPointToGlobal: form extent x @ 0) - fillStyle origin.
	fillStyle normal: (bmMatrix localPointToGlobal: 0 @ form extent y) - fillStyle origin.
	fillStyle tileFlag: aBoolean not.
	fillStyles at: index put: fillStyle.! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 11/18/1998 21:36'!
recordGradientFill: fillIndex matrix: gradientMatrix ramp: colorRampArray linear: aBoolean
	| fillStyle ramp origin direction normal |
	ramp _ colorRampArray collect:[:assoc| (assoc key / 255.0) -> assoc value].
	origin _ gradientMatrix localPointToGlobal: (aBoolean ifFalse:[0@0] ifTrue:[-16384@0]).
	direction _ (gradientMatrix localPointToGlobal: (16384@0)) - origin.
	normal _ (gradientMatrix localPointToGlobal: (0@16384)) - origin.
	fillStyle _ GradientFillStyle ramp: ramp.
	fillStyle origin: origin.
	fillStyle direction: direction.
	fillStyle normal: normal.
	fillStyle radial: aBoolean not.
	fillStyle pixelRamp. "Force creation beforehand"
	fillStyles at: fillIndex put: fillStyle.! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 8/15/1998 00:58'!
recordLineStyle: styleIndex width: lineWidth color: lineColor
	lineStyles at: styleIndex put: (FlashLineStyle color: lineColor width: lineWidth).! !

!FlashMorphReader methodsFor: 'defining styles' stamp: 'ar 11/11/1998 22:39'!
recordSolidFill: index color: fillColor
	fillStyles at: index put: (SolidFillStyle color: fillColor)! !


!FlashMorphReader methodsFor: 'misc' stamp: 'ar 10/15/1998 20:44'!
recordBackgroundColor: aColor
	player color: aColor! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/19/1998 20:30'!
recordBeginSprite: id frames: frameCount
	| sprite |
	sprite _ FlashSpriteMorph new.
	sprite maxFrames: frameCount.
	sprite stepTime: stepTime.
	spriteOwners at: sprite put: (
		Array with: player 
			with: frame
			with: activeMorphs
			with: passiveMorphs).
	player _ sprite.
	frame _ 1.
	activeMorphs _ Dictionary new: 100.
	passiveMorphs _ Dictionary new: 100.
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/12/1998 21:50'!
recordBitmap: id data: aForm
	aForm ifNil:[^self].
	"Record the current form"
	forms at: id put: aForm.
	"Define a new character"
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/24/1998 14:35'!
recordEndSprite: id
	| shape sprite |
	sprite _ player.
	player _ (spriteOwners at: sprite) at: 1.
	frame _ (spriteOwners at: sprite) at: 2.
	activeMorphs _ (spriteOwners at: sprite) at: 3.
	passiveMorphs _ (spriteOwners at: sprite) at: 4.
	spriteOwners removeKey: sprite.
	sprite loadInitialFrame.
	shape _ FlashCharacterMorph withAll: (Array with: sprite).
	shape id: id.
	shape isSpriteHolder: true.
	shape stepTime: stepTime.
	shapes at: id put: shape.
	shape lockChildren.
! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/16/1998 22:53'!
recordFrameActions: actionList
	player addActions: actionList atFrame: frame.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/18/1998 22:00'!
recordFrameCount: maxFrames
	player maxFrames: maxFrames! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/17/1998 13:36'!
recordFrameLabel: label
	"Name the current frame with the given label"
	player addLabel: label atFrame: frame.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/21/1998 00:32'!
recordFrameRate: fps
	frameRate _ fps.
	fps > 0.0 ifTrue:[stepTime _ (1000.0 / fps) rounded].
	player stepTime: stepTime.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/18/1998 20:42'!
recordGlobalBounds: bounds
	player localBounds: bounds.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:10'!
recordMorph: id depth: depth ratio: ratio! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:50'!
recordMoveObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorMatrix ratio: ratio
	| index oldObj mat |
	index _ nil.
	activeMorphs do:[:list|
		list do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth])
					ifTrue:[index _ morph id]]].
	oldObj _ self recordRemoveObject: index depth: depth.
	oldObj isNil ifTrue:[^self].
	objectIndex isNil ifFalse:[index _ objectIndex].
	matrix isNil 
		ifTrue:[mat _ oldObj matrixAtFrame: frame]
		ifFalse:[mat _ matrix].
	self recordPlaceObject: index name: aString depth: depth matrix: mat colorMatrix: colorMatrix ratio: ratio.! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 9/3/1999 15:50'!
recordPlaceObject: objectIndex name: aString depth: depth matrix: matrix colorMatrix: colorTransform ratio: ratio
	| cached active doLoad |
	cached _ passiveMorphs at: objectIndex ifAbsent:[#()].
	cached size >= 1 
		ifTrue:["Got an old morph. Re-use it"
				doLoad _ false.
				active _ cached first.
				passiveMorphs at: objectIndex put: (cached copyWithout: active)]
		ifFalse:["Need a new morph"
				doLoad _ true.
				active _ self newMorphFromShape: objectIndex.
				active isNil ifTrue:[^self].
				active reset.
				active visible: false atFrame: frame - 1].
	active isNil ifTrue:[^self].
	active visible: true atFrame: frame.
	active depth: depth atFrame: frame.
	active matrix:  matrix atFrame: frame.
	active colorTransform: colorTransform atFrame: frame.
	doLoad ifTrue:[
		active loadInitialFrame.
		player addMorph: active].
	cached _ (activeMorphs at: objectIndex ifAbsent:[#()]) copyWith: active.
	activeMorphs at: objectIndex put: cached.
	aString ifNotNil:[active setNameTo: aString].
	ratio ifNotNil:[active ratio: ratio atFrame: frame].! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/21/1998 01:57'!
recordRemoveObject: id depth: depth
	id ifNotNil:["Faster if id is given"
		(activeMorphs at: id ifAbsent:[#()]) do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth]) 
					ifTrue:[^self removeActiveMorph: morph]]].
	activeMorphs do:[:list|
		list do:[:morph|
			((morph visibleAtFrame: frame-1) and:[
				(morph depthAtFrame: frame-1) = depth]) 
					ifTrue:[^self removeActiveMorph: morph]]].
	Transcript cr; nextPutAll:'Shape (id = '; print: id; nextPutAll:' depth = '; print: depth; nextPutAll:') not removed in frame '; print: frame; endEntry.
	^nil! !

!FlashMorphReader methodsFor: 'misc' stamp: 'ar 11/19/1998 20:30'!
recordShowFrame
	player loadedFrames: frame.
	frame _ frame + 1.! !


!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/20/1998 01:04'!
createSound: id info: info
	| theSound loops |
	theSound _ sounds at: id ifAbsent:[^nil].
	loops _ info loopCount.
	loops <= 1 ifTrue:[^theSound].
	^RepeatingSound repeat: theSound count: loops! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 19:39'!
myActiveMorphs
	| out |
	out _ WriteStream on: (Array new: 10).
	activeMorphs do:[:array| out nextPutAll: array].
	^out contents! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 19:26'!
myFlush
		Transcript endEntry.
		Sensor leftShiftDown ifTrue:[self halt].! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 9/3/1999 18:39'!
newMorphFromShape: objectIndex
	"Return a new character morph from the given object index.
	If the character morph at objectIndex is already used, then create and return a full copy of it"
	| prototype |
	prototype _ self oldMorphFromShape: objectIndex.
	prototype isNil ifTrue:[^nil].
	^(prototype owner notNil) 
		ifTrue:[prototype fullCopy]
		ifFalse:[prototype].! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 20:24'!
oldMorphFromShape: objectIndex
	"Return an existing character morph from the given object index."
	| prototype |
	prototype _ shapes at: objectIndex ifAbsent:[nil].
	"prototype ifNil:[prototype _ buttons at: objectIndex ifAbsent:[nil]]."
	prototype ifNil:[Transcript cr; nextPutAll:'No shape for '; print: objectIndex; nextPutAll:' in frame '; print: frame; endEntry].
	^prototype! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 8/15/1998 15:27'!
placeGlyph: aMorph at: position
	aMorph privateFullMoveBy: position.! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 11/16/1998 21:55'!
removeActiveMorph: aMorph
	| newActive newPassive |
	aMorph visible: false atFrame: frame.
	newActive _ (activeMorphs at: aMorph id) copyWithout: aMorph.
	newPassive _ (passiveMorphs at: aMorph id ifAbsent:[#()]) copyWith: aMorph.
	activeMorphs at: aMorph id put: newActive.
	passiveMorphs at: aMorph id put: newPassive.
	^aMorph! !

!FlashMorphReader methodsFor: 'private' stamp: 'ar 8/15/1998 15:28'!
resizeGlyph: aMorph to: extent
	aMorph extent: 1440@1440.
	aMorph extent: extent.! !


!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/20/1998 01:59'!
recordButton: buttonId actions: actionList condition: condition
	| button |
	button _ buttons at: buttonId ifAbsent:[^self halt].
	(condition anyMask: 1) ifTrue:[
		button on: #mouseEnter sendAll: actionList.
	].
	(condition anyMask: 2) ifTrue:[
		button on: #mouseLeave sendAll: actionList.
	].
	(condition anyMask: 4) ifTrue:[
		button on: #mouseDown sendAll: actionList.
	].
	(condition anyMask: 8) ifTrue:[
		button on: #mouseUp sendAll: actionList.
	].
	(condition anyMask: 16) ifTrue:[
		button on: #mouseLeaveDown sendAll: actionList.
	].
	(condition anyMask: 32) ifTrue:[
		button on: #mouseEnterDown sendAll: actionList.
	].
	(condition anyMask: 64) ifTrue:[
		button on: #mouseUpOut sendAll: actionList.
	].
	(condition anyMask: 128) ifTrue:[
		button on: #mouseEnterDown sendAll: actionList.
	].
	(condition anyMask: 256) ifTrue:[
		button on: #mouseLeaveDown sendAll: actionList.
	].
! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/24/1998 14:24'!
recordButton: buttonId character: characterId state: state layer: layer matrix: matrix colorTransform: cxForm
	| button children shape |
	button _ buttons at: buttonId ifAbsent:[^self halt].
	button id: buttonId.
	shape _ self oldMorphFromShape: characterId.
	shape isNil ifTrue:[^nil].
	children _ shape submorphs collect:[:m| m fullCopy].
	shape _ FlashMorph withAll: children.
	shape lockChildren.
	shape depth: layer.
	shape transform: matrix.
	shape colorTransform: cxForm.
	(state anyMask: 1) ifTrue:[
		button defaultLook: shape.
	].
	(state anyMask: 2) ifTrue:[
		button overLook: shape.
	].
	(state anyMask: 4) ifTrue:[
		button pressLook: shape.
	].
	(state anyMask: 8) ifTrue:[
		button sensitiveLook: shape.
	].
	button lockChildren.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/21/1998 02:20'!
recordButton: id sound: soundId info: soundInfo state: state
	"Give the button a sound"
	| button theSound |
	button _ buttons at: id ifAbsent:[^self halt].
	theSound _ self createSound: soundId info: soundInfo.
	theSound ifNil:[^self].
	button addSound: theSound forState: state.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:51'!
recordButton: id trackAsMenu: aBoolean
	| button |
	button _ buttons at: id ifAbsent:[^self halt].
	button trackAsMenu: aBoolean.
! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 20:36'!
recordDefineButton: id
	"Record the definition of a new button with the given id"
	| button |
	button _ buttons at: id put: FlashButtonMorph new.
	button id: id.
	shapes at: id put: button.! !

!FlashMorphReader methodsFor: 'defining buttons' stamp: 'ar 11/16/1998 21:11'!
recordEndButton: id
	"Record the end of a button definition with the given id"
! !


!FlashMorphReader methodsFor: 'testing' stamp: 'ar 11/18/1998 21:37'!
isStreaming
	^player isStreaming! !


!FlashMorphReader methodsFor: 'defining sounds' stamp: 'jm 3/30/1999 09:43'!
flushStreamingSound

	| bufs sound |
	streamingSound buffers ifNil: [^ self].
	streamingSound buffers first position = 0 ifFalse: [
		bufs _ streamingSound buffers collect: [:b | b contents].
		sound _ self createSoundFrom: bufs
					stereo: streamingSound stereo
					samplingRate: streamingSound samplingRate.
		player addSound: sound at: streamingSound firstFrame].
	streamingSound firstFrame: frame.
	streamingSound frameNumber: frame.
	streamingSound buffers do: [:s | s reset].
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/20/1998 22:38'!
recordSound: id data: aSampledSound
	aSampledSound ifNotNil:[sounds at: id put: aSampledSound]! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'jm 3/30/1999 09:14'!
recordSoundStreamBlock: data

	| newBufs |
	streamingSound frameNumber + 1 = frame 
		ifFalse: [self flushStreamingSound].
	newBufs _ ADPCMCodec new
		decodeFlash: data
		sampleCount: streamingSound sampleCount
		stereo: streamingSound stereo.
	streamingSound buffers with: newBufs do:
		[:streamBuf :newBuf | streamBuf nextPutAll: newBuf].
	streamingSound frameNumber: frame.
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/21/1998 00:53'!
recordSoundStreamHead: mixFmt stereo: stereo bitsPerSample: bitsPerSample sampleCount: sampleCount compressed: compressed
	streamingSound buffers isNil ifFalse:[self flushStreamingSound].
	streamingSound mixFmt: mixFmt.
	streamingSound stereo: stereo.
	streamingSound bitsPerSample: bitsPerSample.
	streamingSound sampleCount: sampleCount.
	streamingSound compressed: compressed.
	streamingSound samplingRate: (frameRate * sampleCount) truncated.
	streamingSound buffers: (self createSoundBuffersOfSize: sampleCount stereo: stereo).
	streamingSound firstFrame: frame.
	streamingSound frameNumber: frame.
! !

!FlashMorphReader methodsFor: 'defining sounds' stamp: 'ar 11/20/1998 22:38'!
recordStartSound: id info: info
	| theSound |
	theSound _ self createSound: id info: info.
	theSound ifNotNil:[player addSound: theSound at: frame].! !


!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:48'!
recordMorphBoundary: id
	self recordShapeEnd: id.
	morphedLineStyles keysAndValuesDo:[:idx :val| lineStyles at: idx put: val].
	morphedFillStyles keysAndValuesDo:[:idx :val| fillStyles at: idx put: val].
	location _ 0@0.
	self beginShape.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:43'!
recordMorphFill: id color1: color1 color2: color2
	self recordSolidFill: id color: color2.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordSolidFill: id color: color1.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:43'!
recordMorphFill: id matrix1: matrix1 matrix2: matrix2 id: bmId clipped: aBool
	self recordBitmapFill: id matrix: matrix2 id: bmId clipped: aBool.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordBitmapFill: id matrix: matrix1 id: bmId clipped: aBool.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:44'!
recordMorphFill: id matrix1: matrix1 ramp1: ramp1 matrix2: matrix2 ramp2: ramp2 linear: isLinear
	self recordGradientFill: id matrix: matrix2 ramp: ramp2 linear: isLinear.
	morphedFillStyles at: id put: (fillStyles at: id).
	self recordGradientFill: id matrix: matrix1 ramp: ramp1 linear: isLinear.	! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:45'!
recordMorphLineStyle: id width1: lineWidth1 width2: lineWidth2 color1: lineColor1 color2: lineColor2
	self recordLineStyle: id width: lineWidth2 color: lineColor2.
	morphedLineStyles at: id put: (lineStyles at: id).
	self recordLineStyle: id width: lineWidth1 color: lineColor1.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:46'!
recordMorphShapeEnd: id
	| startShape endShape morphShape |
	startShape _ shapes at: id.
	self recordShapeEnd: id.
	endShape _ shapes at: id.
	morphShape _ FlashMorphingMorph from: startShape to: endShape.
	morphShape id: id.
	morphShape stepTime: stepTime.
	shapes at: id put: morphShape.
	morphedLineStyles _ morphedFillStyles _ nil.! !

!FlashMorphReader methodsFor: 'composing morphs' stamp: 'ar 9/3/1999 18:42'!
recordMorphShapeStart: shapeId srcBounds: bounds1 dstBounds: bounds2
	morphedFillStyles _ Dictionary new.
	morphedLineStyles _ Dictionary new.
	location _ 0@0.
	self logShapes ifFalse:[log _ nil].
	self beginShape.! !
FlashCharacterMorph subclass: #FlashMorphingMorph
	instanceVariableNames: 'srcShapes dstShapes morphShapes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashMorphingMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 16:58'!
extractShapesFrom: aMorph
	| shapes |
	shapes _ WriteStream on: Array new.
	aMorph allMorphsDo:[:m|
		(m isFlashMorph and:[m isFlashShape])
			ifTrue:[shapes nextPut: m shape].
	].
	^shapes contents.
! !

!FlashMorphingMorph methodsFor: 'initialize' stamp: 'ar 9/3/1999 18:35'!
from: srcMorph to: dstMorph
	| shape |
	"Note: Add srcMorph and dstMorph to the receiver so the damned bounds will be correct."
	self addMorphBack: srcMorph.
	self addMorphBack: dstMorph.
	self computeBounds.
	srcShapes _ self extractShapesFrom: srcMorph.
	dstShapes _ self extractShapesFrom: dstMorph.
	srcShapes size = dstShapes size ifFalse:[^self error:'Shape size mismatch'].
	1 to: srcShapes size do:[:i|
		(srcShapes at: i) numSegments = (dstShapes at: i) numSegments
			ifFalse:[^self error:'Edge size mismatch']].
	morphShapes _ WriteStream on: Array new.
	srcShapes do:[:s|
		shape _ FlashBoundaryShape
					points: s points copy
					leftFills: s leftFills
					rightFills: s rightFills
					fillStyles: s fillStyles
					lineWidths: s lineWidths
					lineFills: s lineFills.
		morphShapes nextPut: shape.
		self addMorphFront: (FlashShapeMorph shape: shape)].
	morphShapes _ morphShapes contents.
	srcMorph visible: false.
	dstMorph visible: false.! !


!FlashMorphingMorph methodsFor: 'stepping' stamp: 'ar 9/3/1999 18:50'!
morphTo: ratio
	| srcShape dstShape morphShape |
	1 to: morphShapes size do:[:i|
		srcShape _ srcShapes at: i.
		dstShape _ dstShapes at: i.
		morphShape _ morphShapes at: i.
		morphShape morphFrom: srcShape to: dstShape at: ratio].		! !

!FlashMorphingMorph methodsFor: 'stepping' stamp: 'ar 9/3/1999 18:38'!
stepToFrame: frameNumber
	| ratio |
	super stepToFrame: frameNumber.
	self visible ifTrue:[
		ratio _ self ratioAtFrame: frame.
		self morphTo: ratio.
		self changed].! !


!FlashMorphingMorph methodsFor: 'copying' stamp: 'ar 9/3/1999 18:39'!
updateReferencesUsing: aDictionary
	| srcMorph dstMorph |
	super updateReferencesUsing: aDictionary.
	srcMorph _ (submorphs at: submorphs size-1).
	dstMorph _ (submorphs at: submorphs size).
	self removeAllMorphs.
	self from: srcMorph to: dstMorph.
! !

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

FlashMorphingMorph class
	instanceVariableNames: ''!

!FlashMorphingMorph class methodsFor: 'instance creation' stamp: 'ar 9/3/1999 16:53'!
from: srcMorph to: dstMorph
	^self new from: srcMorph to: dstMorph! !
Model subclass: #FlashPlayerModel
	instanceVariableNames: 'player '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 14:47'!
initialExtent
	^player bounds extent! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:02'!
isStreaming
	^player isStreaming! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:33'!
loadedFrames
	^player loadedFrames! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:02'!
maxFrames
	^player maxFrames! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 14:45'!
player: flashPlayer
	player _ flashPlayer! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:42'!
progressValue
	^player progressValue! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:45'!
startPlaying
	player startPlaying! !

!FlashPlayerModel methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:43'!
stopPlaying
	player stopPlaying! !

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

FlashPlayerModel class
	instanceVariableNames: ''!

!FlashPlayerModel class methodsFor: 'instance creation' stamp: 'ar 11/17/1998 14:45'!
player: flashPlayer
	^self new player: flashPlayer! !
FlashSpriteMorph subclass: #FlashPlayerMorph
	instanceVariableNames: 'activationKeys activeMorphs localBounds sourceUrl progressValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 22:53'!
downloadState
	| doc |
	doc _ sourceUrl retrieveContents.
	(FlashMorphReader on: doc contentStream binary) processFileAsync: self.
	self startPlaying.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 23:09'!
downloadStateIn: aScamper
	| doc |
	doc _ sourceUrl retrieveContents.
	(FlashMorphReader on: doc contentStream binary) processFileAsync: self.
	"Wait until the first frame is there"
	[loadedFrames = 0] whileTrue:[(Delay forMilliseconds: 100) wait].
	aScamper invalidateLayout.
	self startPlaying.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 9/1/1999 14:39'!
initialize
	super initialize.
	color _ Color white.
	self loopFrames: true.
	localBounds _ bounds.
	activationKeys _ #().
	activeMorphs _ SortedCollection new: 50.
	activeMorphs sortBlock:[:m1 :m2| m1 depth > m2 depth].
	progressValue _ ValueHolder new.
	progressValue contents: 0.0.
	self defaultAALevel: 2.
	self deferred: true.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/19/1998 20:31'!
loadInitialFrame
	"Note: Must only be sent to a player if not in streaming mode"
	self isStreaming ifTrue:[^self].
	super loadInitialFrame.
	activationKeys _ self collectActivationKeys: maxFrames.
	activeMorphs _ SortedCollection new: 50.
	activeMorphs sortBlock:[:m1 :m2| m1 depth > m2 depth].
	activeMorphs addAll: activationKeys first.! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 12/30/1998 14:47'!
makeControls

	| b r loopSwitch |
	b _ SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2.
	r _ AlignmentMorph newRow.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (b fullCopy label: 'Rewind';		actionSelector: #rewind).
	r addMorphBack: (b fullCopy label: 'Play';			actionSelector: #startPlaying).
	r addMorphBack: (b fullCopy label: 'Pause';			actionSelector: #stopPlaying).
	r addMorphBack: (b fullCopy label: 'Next';			actionSelector: #stepForward).
	r addMorphBack: (b fullCopy label: 'Prev';			actionSelector: #stepBackward).
	loopSwitch _ SimpleSwitchMorph new
		borderWidth: 2;
		label: 'Loop';
		actionSelector: #loopFrames:;
		target: self;
		setSwitchState: self loopFrames.
	r addMorphBack: loopSwitch.
	loopSwitch _ SimpleSwitchMorph new
		borderWidth: 2;
		label: 'Defer';
		actionSelector: #toggleDeferred;
		target: self;
		setSwitchState: self deferred.
	r addMorphBack: loopSwitch.
	r addMorphBack: (b fullCopy label: 'Fastest'; 	actionSelector: #drawFastest).
	r addMorphBack: (b fullCopy label: 'Medium';	actionSelector: #drawMedium).
	r addMorphBack: (b fullCopy label: 'Nicest';		actionSelector: #drawNicest).
	r addMorphBack: (b fullCopy label: '+10';		actionSelector: #jump10).
	b target: self.
	^ self world activeHand attachMorph: r! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/18/1998 21:40'!
open
	Smalltalk isMorphic 
		ifTrue:[self openInWorld]
		ifFalse:[self openInMVC]! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/17/1998 15:39'!
openInMVC
	| window extent |
	self localBounds: localBounds.
	extent _ bounds extent.
	window _ FlashPlayerWindow labelled:'Flash Player'.
	window model: (FlashPlayerModel player: self).
	window addMorph: self frame:(0@0 corner: 1@1).
	window openInMVCExtent: extent! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/17/1998 15:24'!
openInWorld
	| window extent |
	self localBounds: localBounds.
	extent _ bounds extent.
	window _ FlashPlayerWindow labelled:'Flash Player'.
	window model: (FlashPlayerModel player: self).
	window addMorph: self frame:(0@0 corner: 1@1).
	window openInWorldExtent: extent! !

!FlashPlayerMorph methodsFor: 'initialize' stamp: 'ar 11/18/1998 19:21'!
sourceUrl: urlString
	sourceUrl _ urlString! !


!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 2/10/1999 03:37'!
activeMorphs
	^activeMorphs! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/20/1998 02:27'!
addMorph: aMorph
	aMorph isFlashMorph ifFalse:[^super addMorph: aMorph].
	aMorph isMouseSensitive
		ifTrue:[self addMorphFront: aMorph]
		ifFalse:[self addMorphBack: aMorph].! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 20:52'!
borderWidth
	"Ignored here - only for keeping the window happy"
	^0! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 20:52'!
borderWidth: bw
	"Ignored here - only for keeping the window happy"
! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:13'!
deferred
	^self hasProperty:#deferred! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:14'!
deferred: aBoolean
	aBoolean 
		ifTrue:[self setProperty: #deferred toValue: true]
		ifFalse:[self removeProperty: #deferred]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 21:46'!
isStreaming
	"Return true if we're in streaming mode"
	^sourceUrl notNil! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'RAA 6/2/2000 10:53'!
loadedFrames: aNumber 
	self isStreaming
		ifTrue: 
			[activationKeys _ self collectActivationKeys: aNumber.
			aNumber = 1
				ifTrue: 
					[activeMorphs addAll: activationKeys first.
					self changed].
			progressValue contents: aNumber asFloat / maxFrames.
			"Give others a chance"
			Smalltalk isMorphic
				ifTrue: [Display doOneCycleMorphic]
				ifFalse: [Processor yield]].
	loadedFrames _ aNumber! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 00:56'!
localBounds
	^localBounds ifNil:[localBounds _ self transform globalBoundsToLocal: self bounds]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 20:43'!
localBounds: newBounds

	localBounds _ newBounds.
	bounds _ (self position extent: newBounds extent // 20).
	transform _ MatrixTransform2x3 
					transformFromLocal: newBounds 
					toGlobal: bounds! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:17'!
loopFrames
	^(self valueOfProperty: #loopFrames) ifNil:[false]! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 10/15/1998 02:51'!
loopFrames: aBoolean
	self setProperty: #loopFrames toValue: aBoolean! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:33'!
progressValue
	^progressValue! !

!FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:33'!
progressValue: aValueHolder
	progressValue _ aValueHolder! !


!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 17:58'!
debugDraw
	self fullDrawOn: (Display getCanvas)! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:34'!
drawOn: aCanvas 
	"Draw the background of the player"
	| box bgImage |
	box _ self bounds.
	bgImage _ self valueOfProperty: #transitionBackground ifAbsent:[nil].
	bgImage 
		ifNil:[aCanvas fillRectangle: box color: color]
		ifNotNil:[aCanvas drawImage: bgImage at: box origin].! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:49'!
drawSubmorphsOn: aCanvas
	| myCanvas |
	aCanvas clipBy: self bounds during:[:tempCanvas|
		myCanvas _ tempCanvas asBalloonCanvas.
		myCanvas aaLevel: (self defaultAALevel ifNil:[1]).
		myCanvas deferred: self deferred.
		myCanvas transformBy: self transform during:[:childCanvas| 
			activeMorphs reverseDo:[:m| childCanvas fullDrawMorph: m]].
		myCanvas flush].
! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 5/19/1999 17:57'!
imageFormOfSize: extentPoint forFrame: frameNr
	"Create an image of the given size for the given frame number"
	| thumbTransform form canvas morphsToDraw |
	thumbTransform _ MatrixTransform2x3 
						transformFromLocal: localBounds 
						toGlobal: (0@0 extent: extentPoint).
	form _ Form extent: extentPoint depth: 8.
	form fillColor: self color.
	canvas _ BalloonCanvas on: form.
	canvas transformBy: thumbTransform.
	canvas aaLevel: (self defaultAALevel ifNil:[1]).
	canvas deferred: true.
	morphsToDraw _ (submorphs select:[:m|
		m stepToFrame: frameNr.
		m visible]) sortBy:[:m1 :m2| m1 depth > m2 depth].
	morphsToDraw reverseDo:[:m|
		m fullDrawOn: canvas].
	submorphs do:[:m| m stepToFrame: frameNumber].
	canvas flush.
	^form! !

!FlashPlayerMorph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:43'!
invalidRect: rect from: aMorph
	damageRecorder isNil ifTrue:[
		super invalidRect: rect from: aMorph
	] ifFalse:[
		damageRecorder recordInvalidRect: rect.
	].! !


!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 2/3/2000 17:23'!
boundsChangedFrom: oldBounds to: newBounds
	| newWidth newLeft |
	newWidth _ localBounds width * newBounds height // localBounds height.
	newLeft _ newBounds left + (newBounds width - newWidth // 2).
	transform _ MatrixTransform2x3
		transformFromLocal: localBounds
		toGlobal: (newLeft @ newBounds top extent: newWidth @ newBounds height).! !

!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 11/16/1998 01:06'!
computeBounds
	"Do nothing."! !

!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 6/2/1999 02:41'!
containsPoint: aPoint
	^self bounds containsPoint: aPoint! !

!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 16:07'!
fullBounds
	"The player clips its children"
	^bounds! !

!FlashPlayerMorph methodsFor: 'geometry' stamp: 'ar 11/19/1998 20:48'!
fullContainsPoint: pt
	"The player clips its children"
	(bounds containsPoint: pt) ifFalse:[^false].
	^super fullContainsPoint: pt! !


!FlashPlayerMorph methodsFor: 'classification' stamp: 'ar 11/15/1998 19:05'!
isFlashPlayer
	^true! !


!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 11/6/1998 23:56'!
jump10
	1 to: 10 do:[:i| self stepForward].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 8/14/1998 21:54'!
rewind
	self frameNumber: 1.! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 2/3/2000 17:20'!
stepToFrame: frame
	| fullRect postDamage |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage _ damageRecorder isNil.
	postDamage ifTrue:[damageRecorder _ FlashDamageRecorder new].
	frame = (frameNumber+1) ifTrue:[
		self stepToFrameForward: frame.
	] ifFalse:[
		activeMorphs _ activeMorphs select:[:any| false].
		submorphs do:[:m|
			(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
				m stepToFrame: frame.
				m visible ifTrue:[activeMorphs add: m].
			]].
	].
	frameNumber _ frame.
	playing ifTrue:[
		self playSoundsAt: frame.
		self executeActionsAt: frame.
	].
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			fullRect _ damageRecorder fullDamageRect: self localBounds.
			fullRect _ (self transform localBoundsToGlobal: fullRect).
			owner invalidRect: (fullRect insetBy: -1).
		].
	].
	postDamage ifTrue:[damageRecorder _ nil].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 11/17/1998 18:33'!
stepToFrameForward: frame
	| activeRemoved resortNeeded morph |
	frameNumber+1 to: frame do:[:f|
		activeRemoved _ false.
		resortNeeded _ false.
		1 to: activeMorphs size do:[:i|
			morph _ activeMorphs at: i.
			morph stepToFrame: f.
			morph visible ifFalse:[activeRemoved _ true].
			(i > 1 and:[(activeMorphs at: i-1) depth < morph depth])
				ifTrue:[resortNeeded _ true].
		].
		activeRemoved ifTrue:[
			activeMorphs _ activeMorphs select:[:m| m visible].
			resortNeeded _ false.
		].
		resortNeeded ifTrue:[activeMorphs reSort].
		(activationKeys at: f) do:[:m|
			m stepToFrame: f.
			m visible ifTrue:[activeMorphs add: m].
		].
	].! !

!FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 5/19/1999 17:23'!
stepToFrameSilently: frame
	"Like stepToFrame but without executing any actions or starting sounds.
	Note: This method is not intended for fast replay."
	| fullRect postDamage |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage _ damageRecorder isNil.
	postDamage ifTrue:[damageRecorder _ FlashDamageRecorder new].
	activeMorphs _ activeMorphs select:[:any| false].
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m stepToFrame: frame.
			m visible ifTrue:[activeMorphs add: m].
		].
	].
	frameNumber _ frame.
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			fullRect _ damageRecorder fullDamageRect: self localBounds.
			fullRect _ (self transform localBoundsToGlobal: fullRect).
			owner invalidRect: (fullRect insetBy: -1).
		].
	].
	postDamage ifTrue:[damageRecorder _ nil].! !


!FlashPlayerMorph methodsFor: 'private' stamp: 'ar 11/18/1998 23:21'!
collectActivationKeys: frame
	"Note: Must only be called after a frame has been completed"
	| vis lastKey |
	vis _ Array new: frame.
	vis atAllPut: #().
	lastKey _ activationKeys size.
	vis replaceFrom: 1 to: lastKey with: activationKeys startingAt: 1.
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m activationKeys do:[:key|
				key > lastKey ifTrue:[
					vis at: key put: ((vis at: key) copyWith: m)
				].
			].
		].
	].
	^vis! !

!FlashPlayerMorph methodsFor: 'private' stamp: 'ar 11/16/1998 02:58'!
noticeRemovalOf: aFlashMorph
	"The flash morph is removed from the player.
	Remove it's activation keys so that we don't have any problems."
	| morphs |
	aFlashMorph activationKeys do:[:key|
		morphs _ activationKeys at: key.
		activationKeys at: key put: (morphs copyWithout: aFlashMorph).
	].
	"And remove it from the activeMorphs"
	activeMorphs remove: aFlashMorph ifAbsent:[]! !


!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:25'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'open sorter' action: #openSorter.
	aCustomMenu add: 'make controls' action: #makeControls.
	aCustomMenu addLine.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawFastest
	self defaultAALevel: 1.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawMedium
	self defaultAALevel: 2.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 14:44'!
drawNicest
	self defaultAALevel: 4.
	self changed.! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 5/19/1999 16:28'!
openSorter
	(FlashSorterMorph new on: self) openInWindow! !

!FlashPlayerMorph methodsFor: 'menu' stamp: 'ar 12/30/1998 11:33'!
toggleDeferred
	self deferred: self deferred not.
	self changed.! !


!FlashPlayerMorph methodsFor: 'copying' stamp: 'ar 5/20/1999 12:16'!
copyMovieFrom: firstFrame to: lastFrame
	"Create a copy of the receiver containing the given frames"
	| player delta actionList newMorphs |
	delta _ firstFrame - 1.
	player _ FlashPlayerMorph new.
	player bounds: self bounds.
	player localBounds: self localBounds.
	player maxFrames: lastFrame - firstFrame + 1.
	player loadedFrames: player maxFrames.
	player stepTime: stepTime.
	player color: self color.
	"Copy the sounds, actions and labels"
	sounds associationsDo:[:sndAssoc|
		(sndAssoc key between: firstFrame and: lastFrame) ifTrue:[
			sndAssoc value do:[:snd|
				player addSound: snd at: sndAssoc key - delta]]].
	actions associationsDo:[:action|
		actionList _ action value collect:[:a|
			a selector == #gotoFrame: 
				ifTrue:[Message selector: a selector argument: (a argument - delta)]
				ifFalse:[a]].
		(action key between: firstFrame and: lastFrame)
			ifTrue:[player addActions: actionList atFrame: action key - delta]].
	labels associationsDo:[:label|
		(label value between: firstFrame and: lastFrame)
			ifTrue:[player addLabel: label key atFrame: label value - delta]].
	"Finally, copy the morphs"
	newMorphs _ submorphs 
					select:[:m| m isVisibleBetween: firstFrame and: lastFrame]
					thenCollect:[:m| m copyMovieFrom: firstFrame to: lastFrame].
	player addAllMorphs: newMorphs.
	player loadInitialFrame.
	player stepToFrame: 1.
	^player! !


!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:43'!
addFillForProjectTarget: aFillStyle
	| fillStyles |
	fillStyles _ self valueOfProperty: #projectTargetFills ifAbsent:[IdentityDictionary new].
	(fillStyles includesKey: aFillStyle) ifTrue:[^self].
	fillStyles at: aFillStyle put: aFillStyle form.
	self setProperty: #projectTargetFills toValue: fillStyles.
	CurrentProjectRefactoring updateProjectFillsIn: self.
	self changed.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 6/2/1999 05:59'!
beFullScreenTransition: aBoolean
	"Make the receiver a full-screen transition if requested"
	self setProperty: #fullScreenTransition toValue: true.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:07'!
beTransitionFrom: srcProjectName

	^self beTransitionFrom: srcProjectName to: CurrentProjectRefactoring currentProjectName! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:39'!
beTransitionFrom: srcProjectName to: dstProjectName
	"Make the receiver the animation between the two projects"
	| srcProject dstProject |
	srcProject _ CurrentProjectRefactoring projectWithNameOrCurrent: srcProjectName.
	dstProject _ CurrentProjectRefactoring projectWithNameOrCurrent: dstProjectName.
	(dstProject projectParameters at: #flashTransition ifAbsentPut:[IdentityDictionary new])
		at: srcProject put: self.
! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:07'!
beTransitionTo: dstProjectName

	^self beTransitionFrom: CurrentProjectRefactoring currentProjectName to: dstProjectName! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/6/2000 17:00'!
playProjectTransitionFrom: oldProject to: newProject entering: aBoolean
	"Play the transition from the old to the new project."

	Smalltalk isMorphic ifFalse: [^ self]. "Not in MVC"
	self stopPlaying.
	owner ifNotNil:[
		self stopStepping.
		owner privateRemoveMorph: self.
		owner _ nil].
	aBoolean ifTrue:[
		self updateProjectFillsFrom: newProject.
	] ifFalse:[
		self updateProjectFillsFrom: oldProject.
		self setProperty: #transitionBackground toValue: newProject imageForm.
	].
	self frameNumber: 1.
	self loopFrames: false.
	(self valueOfProperty: #fullScreenTransition ifAbsent:[false])
		ifTrue:[self bounds: self world bounds].
	self comeToFront.
	self startStepping.
	self startPlaying.
	[playing] whileTrue: [Display doOneCycleNowMorphic].
	self stopPlaying.
	self stopStepping.
	owner privateRemoveMorph: self.
	owner _ nil.
	self removeProperty: #transitionBackground.
	Display deferUpdates: true.
	Display bestGuessOfCurrentWorld fullDrawOn: (Display getCanvas).
	Display deferUpdates: false.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:43'!
removeFillForProjectTarget: aFillStyle
	| fillStyles |
	fillStyles _ self valueOfProperty: #projectTargetFills ifAbsent:[^self].
	aFillStyle form: (fillStyles at: aFillStyle ifAbsent:[^self]).
	fillStyles removeKey: aFillStyle.
	CurrentProjectRefactoring updateProjectFillsIn: self.
	self changed.! !

!FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 6/2/1999 05:00'!
updateProjectFillsFrom: aProject
	"Update all the project target fills from the given project"
	| fillStyles projImage |
	fillStyles _ self valueOfProperty: #projectTargetFills ifAbsent:[^self].
	fillStyles isEmpty ifTrue:[^self].
	projImage _ aProject imageFormOfSize: Display extent depth: 8.
	fillStyles keysDo:[:fs| fs form: projImage].
	"Note: We must issue a full GC here for cleaning up the old bitmaps"
	Smalltalk garbageCollect.! !



!FlashPlayerMorph methodsFor: 'disk i/o'!
compress
	super compress.
	activeMorphs _ activeMorphs asOrderedCollection! !

!FlashPlayerMorph methodsFor: 'disk i/o'!
decompress
	super decompress.
	activeMorphs _ activeMorphs asSortedCollection: [:a :b | a depth > b depth]! !

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

FlashPlayerMorph class
	instanceVariableNames: ''!

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:07'!
transitionFrom: srcProjectName

	^self transitionFrom: srcProjectName to: CurrentProjectRefactoring currentProjectName! !

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:39'!
transitionFrom: srcProjectName to: dstProjectName
	"Return the transition between the two projects"
	| srcProject dstProject |

	srcProject _ CurrentProjectRefactoring projectWithNameOrCurrent: srcProjectName.
	dstProject _ CurrentProjectRefactoring projectWithNameOrCurrent: dstProjectName.
	^dstProject projectParameters at: #flashTransition ifPresent:[:dict|
		dict at: srcProject ifAbsent:[nil]].
! !

!FlashPlayerMorph class methodsFor: 'project transition' stamp: 'RAA 6/3/2000 09:07'!
transitionTo: dstProjectName

	^self transitionFrom: CurrentProjectRefactoring currentProjectName to: dstProjectName! !
SystemWindow subclass: #FlashPlayerWindow
	instanceVariableNames: 'startButton stopButton progress '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 01:31'!
addMorph: aMorph frame: relFrame
	"Do not change the color"
	| cc |
	cc _ aMorph color.
	super addMorph: aMorph frame: relFrame.
	aMorph color: cc.! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:34'!
addProgressIndicator
	progress _ FlashProgressMorph new.
	progress borderWidth: 1.
	progress color: Color transparent.
	progress progressColor: Color gray.
	progress extent: (100 @ (startButton extent y - 6)).
	self addMorph: progress.

! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:42'!
addProgressIndicator: aValueHolder
	progress _ FlashProgressMorph new.
	progress borderWidth: 1.
	progress color: Color transparent.
	progress progressColor: Color gray.
	progress value: aValueHolder.
	progress extent: (100 @ (startButton extent y - 6)).
	self addMorph: progress.

! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 10:14'!
adjustBookControls
	| inner |
	startButton ifNil: [^ self].
	startButton align: startButton topLeft with: (inner _ self innerBounds) topLeft + (35@-4).
	progress ifNotNil:
		[progress align: progress topLeft with: (startButton right @ inner top) + (10@0)].
	stopButton align: stopButton topRight with: inner topRight - (16@4)! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1998 22:40'!
collapseOrExpand
	super collapseOrExpand.
	isCollapsed ifTrue:[
		startButton delete.
		stopButton delete.
		progress ifNotNil:[progress delete].
	] ifFalse:[
		self addMorph: startButton.
		self addMorph: stopButton.
		progress ifNotNil:[self addMorph: progress].
		self adjustBookControls.
	].! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 15:09'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 18:05'!
initialize
	| aFont |
	super initialize.
	aFont _  Preferences standardButtonFont.
	self addMorph: (startButton _ SimpleButtonMorph new borderWidth: 0;
			label: 'play' font: aFont; color: Color transparent;
			actionSelector: #startPlaying; target: self).
	startButton setBalloonText: 'continue playing'.

	self addMorph: (stopButton _ SimpleButtonMorph new borderWidth: 0;
			label: 'stop' font: aFont; color: Color transparent;
			actionSelector: #stopPlaying; target: self).
	stopButton setBalloonText: 'stop playing'.

	startButton submorphs first color: Color blue.
	stopButton submorphs first color: Color red.

	self adjustBookControls! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 21:10'!
model: aFlashPlayerModel
	aFlashPlayerModel isStreaming
		ifTrue:[self addProgressIndicator: aFlashPlayerModel progressValue].
	^super model: aFlashPlayerModel! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 15:39'!
openInMVCExtent: extent
	Smalltalk isMorphic ifTrue:[^self openInWorldExtent: extent].
	super openInMVCExtent: (extent + borderWidth + (0@self labelHeight))! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/17/1998 15:39'!
openInWorldExtent: extent
	Smalltalk isMorphic ifFalse:[^self openInMVCExtent: extent].
	super openInWorldExtent: (extent + borderWidth + (0@self labelHeight))! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:46'!
startPlaying
	model startPlaying! !

!FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/19/1998 20:43'!
stopPlaying
	model stopPlaying! !
BorderedMorph subclass: #FlashProgressMorph
	instanceVariableNames: 'value progressColor lastValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashProgressMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:14'!
progressColor
	^progressColor! !

!FlashProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:52'!
progressColor: aColor
	progressColor = aColor
		ifFalse:
			[progressColor _ aColor.
			self changed]! !

!FlashProgressMorph methodsFor: 'accessing' stamp: 'ar 11/18/1998 22:09'!
value
	^value! !

!FlashProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 18:53'!
value: aModel
	value ifNotNil: [value removeDependent: self].
	value _ aModel.
	value ifNotNil: [value addDependent: self]! !


!FlashProgressMorph methodsFor: 'drawing' stamp: 'sma 3/3/2000 18:54'!
drawOn: aCanvas
	| width inner |
	super drawOn: aCanvas.
	inner _ self innerBounds.
	width _ (inner width * lastValue) truncated min: inner width.
	aCanvas fillRectangle: (inner origin extent: width @ inner height) color: progressColor.! !


!FlashProgressMorph methodsFor: 'initialize' stamp: 'sma 3/3/2000 18:55'!
initialize
	super initialize.
	progressColor _ Color green.
	self value: (ValueHolder new contents: 0.0).
	lastValue _ 0.0! !


!FlashProgressMorph methodsFor: 'updating' stamp: 'sma 3/3/2000 18:51'!
update: aSymbol 
	aSymbol == #contents
		ifTrue: 
			[lastValue _ value contents.
			self changed]! !


!FlashProgressMorph methodsFor: 'menu' stamp: 'sma 3/3/2000 19:20'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addList: #(
		('progress color...' changeProgressColor:)
		('progress value...' changeProgressValue:))! !

!FlashProgressMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:51'!
changeProgressColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	self changeColorTarget: self selector: #progressColor: originalColor: self progressColor hand: aHand.! !

!FlashProgressMorph methodsFor: 'menu' stamp: 'sma 3/3/2000 19:27'!
changeProgressValue: evt
	| answer |
	answer _ FillInTheBlank
		request: 'Enter new value (0 - 1.0)'
		initialAnswer: self value contents asString.
	answer isEmptyOrNil ifTrue: [^ self].
	self value contents: answer asNumber! !
FlashMorph subclass: #FlashShapeMorph
	instanceVariableNames: 'shape '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 17:19'!
color: aColor
	| fillStyle |
	color _ aColor.
	fillStyle _ SolidFillStyle color: aColor.
	shape _ shape copyAndCollectFills:[:fill| fillStyle]! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 6/2/1999 04:38'!
fillForProjectTarget
	"Find a fill style that is suitable for a project target."
	shape fillStyles do:[:fs| fs isBitmapFill ifTrue:[^fs]].
	^nil! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 11:39'!
id
	^-1! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 15:31'!
shape
	^shape! !

!FlashShapeMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 16:43'!
shape: newShape
	shape _ newShape.
	self computeBounds.! !


!FlashShapeMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:47'!
drawOn: aCanvas 
	"Display the receiver."
	| aaLevel |
	shape ifNil:[^aCanvas frameRectangle: self bounds color: Color black.].
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		aaLevel _ self defaultAALevel.
		aaLevel ifNotNil:[balloonCanvas aaLevel: aaLevel].
		balloonCanvas drawCompressedShape: shape.
	].! !


!FlashShapeMorph methodsFor: 'geometry' stamp: 'ar 11/18/1998 13:59'!
computeBounds
	bounds _ self transform localBoundsToGlobal: (shape bounds).
	fullBounds _ nil.! !


!FlashShapeMorph methodsFor: 'classification' stamp: 'ar 6/2/1999 03:15'!
isFlashShape
	^true! !


!FlashShapeMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:37'!
compress
	super compress.
	shape compress.! !

!FlashShapeMorph methodsFor: 'disk i/o' stamp: 'ar 6/30/1999 12:38'!
decompress
	shape decompress.
	super decompress.! !

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

FlashShapeMorph class
	instanceVariableNames: ''!

!FlashShapeMorph class methodsFor: 'instance creation' stamp: 'ar 11/15/1998 15:32'!
shape: aCompressedFlashGeometry
	^self new shape: aCompressedFlashGeometry! !
TransformMorph subclass: #FlashSorterMorph
	instanceVariableNames: 'player '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:27'!
addThumbnails: extentPoint
	| m morphList handler |
	handler _ nil.
	'Preparing thumbnails' displayProgressAt: Sensor cursorPoint
		from: 1 to: player maxFrames during:[:bar|
			morphList _ Array new: player maxFrames.
			1 to: player maxFrames do:[:i|
				bar value: i.
				m _ FlashThumbnailMorph new.
				m extent: extentPoint.
				m player: player.
				m frameNumber: i.
				handler isNil ifTrue:[
					m on: #mouseDown send: #mouseDown:onItem: to: self.
					m on: #mouseStillDown send: #mouseStillDown:onItem: to: self.
					m on: #mouseUp send: #mouseUp:onItem: to: self.
					handler _ m eventHandler.
				] ifFalse:[m eventHandler: handler].
				morphList at: i put: m].
		self addAllMorphs: morphList.
		self doLayout.
	].! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:06'!
initialize
	super initialize.
	self color: Color transparent.! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:40'!
makeControls

	| b r |
	b _ SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2.
	r _ AlignmentMorph newRow.
	r hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2.
	r addMorphBack: (b fullCopy label: 'Make movie';		actionSelector: #makeMovie).
	^r! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:10'!
on: aFlashPlayerMorph
	| w h |
	player _ aFlashPlayerMorph.
	w _ player bounds width.
	h _ player bounds height.
	w > h ifTrue:[
		h _ h * 50 // w.
		w _ 50.
	] ifFalse:[
		w _ w * 50 // h.
		h _ 50.
	].
	self addThumbnails: w@h.! !

!FlashSorterMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:54'!
openInWindow
	| window wrapper |
	window _ SystemWindow new.
	wrapper _ self makeControls.
	window addMorph: wrapper frame: (0@0 extent: 1@0.1).
	wrapper _ ScrollPane new.
	wrapper scroller: self.
	window addMorph: wrapper frame: (0 @ 0.1 extent: 1 @ 1).
	self bounds: owner bounds.
	self doLayout.
	window openInWorld.! !


!FlashSorterMorph methodsFor: 'layout' stamp: 'ar 5/19/1999 16:47'!
doLayout
	"Do the layout of the child morphs"
	| x y maxHeight w |
	w _ self bounds width.
	x _ 0.
	y _ 0.
	maxHeight _ 0.
	submorphs do:[:m|
		x + m bounds width > w ifTrue:[
			"Wrap the guy on the next line"
			x _ 0.
			y _ y + maxHeight.
			maxHeight _ 0].
		m position: x@y.
		x _ x + m bounds width.
		maxHeight _ maxHeight max: m bounds height].
! !

!FlashSorterMorph methodsFor: 'layout' stamp: 'ar 5/19/1999 16:25'!
extent: extentPoint
	super extent: extentPoint.
	self doLayout.! !


!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 5/19/1999 17:35'!
mouseDown: event onItem: aMorph
	submorphs do:[:m|
		m == aMorph ifFalse:[m isSelected: false]].
	aMorph isSelected: true.! !

!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 10/5/2000 18:42'!
mouseStillDown: evt onItem: aMorph
	| pt index m yOffset |
	submorphs do:[:mm|
		mm == aMorph ifFalse:[mm isSelected: false]].
	pt _ evt cursorPoint.
	yOffset _ self offset y.
	index _ aMorph frameNumber. "What a fake hack@!!"
	pt y - yOffset < 0 ifTrue:[
		owner scrollBy: 0@owner scrollDeltaHeight].
	pt y - yOffset > self extent y ifTrue:[
		owner scrollBy: 0@owner scrollDeltaHeight negated].
	(aMorph bounds containsPoint: pt) ifTrue:[^self].
	(pt y > aMorph bottom or:[pt x > aMorph right]) ifTrue:[
		"Select all morphs forward."
		index+1 to: submorphs size do:[:i|
			m _ submorphs at: i.
			m isSelected: aMorph isSelected.
			(m bounds containsPoint: pt) ifTrue:[^self]. "Done"
		].
		^self].
	"Select morphs backwards"
	index-1 to: 1 by: -1 do:[:i|
		m _ submorphs at: i.
		m isSelected: aMorph isSelected.
		(m bounds containsPoint: pt) ifTrue:[^self].
	].! !

!FlashSorterMorph methodsFor: 'interaction' stamp: 'ar 5/19/1999 17:30'!
mouseUp: evt onItem: aMorph
	| pt |
	pt _ evt cursorPoint.
	(aMorph bounds containsPoint: pt) ifTrue:[
		player stepToFrameSilently: aMorph frameNumber.
		^self].! !


!FlashSorterMorph methodsFor: 'editing' stamp: 'ar 5/19/1999 19:38'!
makeMovie
	"Take all the currently selected frames and make a new movie out of it"
	| firstSelection lastSelection |
	firstSelection _  submorphs size + 1.
	lastSelection _ 0.
	submorphs doWithIndex:[:m :index|
		m isSelected ifTrue:[
			firstSelection _ firstSelection min: index.
			lastSelection _ lastSelection max: index.
		].
	].
	firstSelection > lastSelection
		ifTrue:[^self inform:'You have to select the frames first'].
	(player copyMovieFrom: firstSelection to: lastSelection) open! !
Object subclass: #FlashSoundEnvelope
	instanceVariableNames: 'mark44 level0 level1 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashSoundEnvelope methodsFor: 'initialize' stamp: 'ar 8/10/1998 15:35'!
initialize
	mark44 _ level0 _ level1 _ 0.! !


!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level0
	^level0! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level0: anInteger
	level0 _ anInteger! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level1
	^level1! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
level1: anInteger
	level1 _ anInteger! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
mark44
	^mark44! !

!FlashSoundEnvelope methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:36'!
mark44: anInteger
	mark44 _ anInteger! !

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

FlashSoundEnvelope class
	instanceVariableNames: ''!

!FlashSoundEnvelope class methodsFor: 'instance creation' stamp: 'ar 8/10/1998 15:35'!
new
	^super new initialize! !
Object subclass: #FlashSoundInformation
	instanceVariableNames: 'syncFlags inPoint outPoint loopCount envelopes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashSoundInformation methodsFor: 'initialize' stamp: 'ar 8/10/1998 15:30'!
initialize
	syncFlags _ 0.
	inPoint _ -1.
	outPoint _ -1.
	loopCount _ 0.
	envelopes _ #().! !


!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
envelopes
	^envelopes! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
envelopes: aCollection
	envelopes _ aCollection! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
inPoint
	^inPoint! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
inPoint: anInteger
	inPoint _ anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
loopCount
	^loopCount! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:32'!
loopCount: anInteger
	loopCount _ anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
outPoint
	^outPoint! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
outPoint: anInteger
	outPoint _ anInteger! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:30'!
syncFlags
	^syncFlags! !

!FlashSoundInformation methodsFor: 'accessing' stamp: 'ar 8/10/1998 15:31'!
syncFlags: anInteger
	syncFlags _ anInteger! !


!FlashSoundInformation methodsFor: 'testing' stamp: 'ar 8/10/1998 15:33'!
syncNoMultiple
	"Don't start the sound if already playing."
	^syncFlags anyMask: 1! !

!FlashSoundInformation methodsFor: 'testing' stamp: 'ar 8/10/1998 15:34'!
syncStopSound
	"Stop the sound."
	^syncFlags anyMask: 2! !

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

FlashSoundInformation class
	instanceVariableNames: ''!

!FlashSoundInformation class methodsFor: 'instance creation' stamp: 'ar 8/10/1998 15:29'!
new
	^super new initialize! !
FlashMorph subclass: #FlashSpriteMorph
	instanceVariableNames: 'playing maxFrames loadedFrames frameNumber stepTime damageRecorder sounds actions labels lastStepTime useTimeSync '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashSpriteMorph methodsFor: 'initialize' stamp: 'ar 7/11/2000 11:10'!
initialize
	super initialize.
	playing _ false.
	loadedFrames _ 0.
	maxFrames _ 1.
	frameNumber _ 1.
	sounds _ Dictionary new.
	actions _ Dictionary new.
	labels _ Dictionary new.
	stepTime _ 1.
	useTimeSync _ true.! !


!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:48'!
addActions: actionList atFrame: frame
	actions ifNil:[actions _ Dictionary new].
	actions at: frame put: actionList.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:48'!
addLabel: labelString atFrame: frame
	labels ifNil:[labels _ Dictionary new].
	labels at: labelString put: frame.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/16/1998 16:49'!
addSound: aSound at: frameNr
	| oldSound newSound |
	oldSound _ sounds at: frameNr ifAbsent:[nil].
	oldSound isNil 
		ifTrue:[newSound _ Array with: aSound]
		ifFalse:[newSound _ oldSound copyWith: newSound].
	sounds at: frameNr put: newSound.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:09'!
frameNumber
	^frameNumber! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:09'!
frameNumber: frame
	^self stepToFrame: frame! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
loadedFrames
	^loadedFrames! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
loadedFrames: n
	loadedFrames _ n.! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 9/1/1999 15:27'!
loopFrames
	^true! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:16'!
loopFrames: aBool! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
maxFrames
	^maxFrames! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 11/19/1998 22:02'!
maxFrames: n
	maxFrames _ n! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 7/11/2000 11:08'!
useTimeSync
	^useTimeSync ifNil:[true]! !

!FlashSpriteMorph methodsFor: 'accessing' stamp: 'ar 7/11/2000 11:08'!
useTimeSync: aBool
	useTimeSync _ aBool! !


!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 2/3/2000 17:46'!
startPlaying
	"Start playing from the current frame"
	playing ifTrue:[^self].
	loadedFrames = 0 ifTrue:[^nil].
	frameNumber >= maxFrames ifTrue:[self frameNumber: 1].
	playing _ true.
	self playSoundsAt: frameNumber.
	self executeActionsAt: frameNumber.
	lastStepTime _ Time millisecondClockValue.! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 7/11/2000 11:08'!
step
	| nowStepTime maxSteps |
	playing ifFalse:[^self].
	self useTimeSync ifTrue:[
		maxSteps _ 5.
		nowStepTime _ Time millisecondClockValue.
		[(lastStepTime + stepTime <= nowStepTime) and:[playing and:[maxSteps >= 0]]]
			whileTrue:[
				self stepForward.
				lastStepTime _ lastStepTime + stepTime.
				maxSteps _ maxSteps - 1.
			].
	] ifFalse:[self stepForward].
	damageRecorder _ nil. "Insurance"! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/19/1998 22:09'!
stepBackward
	frameNumber > 1
		ifTrue:[self frameNumber: frameNumber - 1]
		ifFalse:[self frameNumber: loadedFrames].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 9/1/1999 16:15'!
stepForward
	frameNumber < maxFrames
		ifTrue:[^self frameNumber: frameNumber + 1].
	self loopFrames
		ifTrue:[self frameNumber: 1]
		ifFalse:[self stopPlaying].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 7/11/2000 11:08'!
stepTime
	"If we're syncing with time step at double speed."
	^self useTimeSync
		ifTrue:[stepTime // 2]
		ifFalse:[stepTime]! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/16/1998 17:07'!
stepTime: time
	stepTime _ time.! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 2/3/2000 17:21'!
stepToFrame: frame
	"Step to the given frame"
	| fullRect postDamage lastVisible resortNeeded |
	frame = frameNumber ifTrue:[^self].
	frame > loadedFrames ifTrue:[^self].
	postDamage _ damageRecorder isNil.
	postDamage ifTrue:[damageRecorder _ FlashDamageRecorder new].
	lastVisible _ nil.
	resortNeeded _ false.
	submorphs do:[:m|
		(m isFlashMorph and:[m isFlashCharacter]) ifTrue:[
			m stepToFrame: frame.
			m visible ifTrue:[
				(lastVisible notNil and:[lastVisible depth < m depth])
					ifTrue:[resortNeeded _ true].
				lastVisible _ m.
				(bounds containsRect: m bounds) ifFalse:[bounds _ bounds merge: m bounds].
			].
		].
	].
	resortNeeded ifTrue:[submorphs _ submorphs sortBy:[:m1 :m2| m1 depth > m2 depth]].
	frameNumber _ frame.
	playing ifTrue:[
		self playSoundsAt: frame.
		self executeActionsAt: frame.
	].
	(postDamage and:[owner notNil]) ifTrue:[
		damageRecorder updateIsNeeded ifTrue:[
			"fullRect _ damageRecorder fullDamageRect.
			fullRect _ (self transform localBoundsToGlobal: fullRect)."
			fullRect _ bounds.
			owner invalidRect: (fullRect insetBy: -1).
		].
	].
	postDamage ifTrue:[
		damageRecorder _ nil].! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/19/1998 22:10'!
stopPlaying
	"Stop playing at the current frame."
	playing _ false.! !

!FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 11/16/1998 16:27'!
wantsSteps
	^true! !


!FlashSpriteMorph methodsFor: 'classification' stamp: 'ar 11/16/1998 17:03'!
isFlashSprite
	^true! !

!FlashSpriteMorph methodsFor: 'classification' stamp: 'ar 11/19/1998 22:22'!
isMouseSensitive
	"Return true - my children may be sensitive"
	^true! !


!FlashSpriteMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:43'!
invalidRect: rect from: aMorph
	damageRecorder isNil ifTrue:[
		super invalidRect: rect from: aMorph
	] ifFalse:[
		damageRecorder recordInvalidRect: rect.
	].! !


!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:10'!
actionPlay
	self startPlaying.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:10'!
actionStop
	"Stop playing at the current frame."
	self stopPlaying.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 9/1/1999 15:50'!
actionTarget: target
	"Set the context (e.g., the receiver) of the following actions."
	| rcvr lastSlash nextSlash loc |
	target = '' ifTrue:[^self].
	target first = $/
		ifTrue:[rcvr _ self flashPlayer ifNil:[self]. lastSlash _ 1.] "absoute path"
		ifFalse:[rcvr _ self. lastSlash _ 0]. "relative path"
	[lastSlash > target size] whileFalse:[
		nextSlash _ target findString:'/' startingAt: lastSlash+1.
		nextSlash = 0 ifTrue:[nextSlash _ target size + 1].
		loc _ target copyFrom: lastSlash+1 to: nextSlash-1.
		(loc size = 2 and:[loc = '..']) ifTrue:[
			[rcvr _ rcvr owner.
			rcvr isFlashSprite] whileFalse.
		] ifFalse:[
			rcvr _ rcvr submorphs detect:[:m| m knownName = loc] ifNone:[rcvr owner].
			rcvr _ rcvr submorphs detect:[:m| m isFlashSprite].
		].
		lastSlash _ nextSlash].
	^rcvr! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 9/1/1999 16:15'!
executeActionsAt: frame
	| rcvr actionList index msg result |
	actionList _ actions at: frame ifAbsent:[^self].
	index _ 1.
	rcvr _ self.
	[index <= actionList size] whileTrue:[
		msg _ actionList at: index.
"Transcript cr; print: msg selector; space; print: msg arguments; endEntry."
		msg selector == #actionTarget:
			ifTrue:[	rcvr _ msg sentTo: self]
			ifFalse:[	result _ msg sentTo: rcvr.
					result ifNotNil:[index _ index + result]].
		index _ index + 1].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/20/1998 02:36'!
getURL: urlString window: windowString
	"Load the given url in display it in the window specified by windowString.
	Ignored for now."
	| browser |
	browser _ self getWebBrowser.
	browser ifNotNil:[
		browser jumpToUrl: urlString.
		^nil].
	"(self confirm: ('open a browser to view\',urlString,' ?') withCRs) ifTrue: [
		browser _ Scamper new.
		browser jumpToUrl: urlString.
		browser openAsMorph
	]."
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 2/3/2000 17:21'!
gotoFrame: frame
	"Jump to the given frame"
	self stopPlaying.
	self frameNumber: frame+1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoLabel: labelString
	"Go to the frame with the associated label string."
	labels ifNil:[^nil].
	self frameNumber: (labels at: labelString ifAbsent:[^nil]).
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoNextFrame
	"Go to the next frame"
	self frameNumber: self frameNumber+1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
gotoPrevFrame
	"Go to the previous frame"
	self frameNumber: self frameNumber-1.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
isFrameLoaded: frame elseSkip: nActions
	"Skip nActions if the given frame is not loaded yet."
	^loadedFrames >= frameNumber 
		ifTrue:[nil]
		ifFalse:[nActions].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 2/3/2000 17:20'!
playSoundsAt: frame
	(sounds at: frame ifAbsent:[#()]) 
		do: [:sound | sound ifNotNil:[self playFlashSound: sound]].! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
stopSounds
	"Stop all sounds"
	SoundPlayer shutDown.
	^nil! !

!FlashSpriteMorph methodsFor: 'actions' stamp: 'ar 11/19/1998 22:11'!
toggleQuality
	"Toggle the display quality.
	Ignored for now - we're aiming at adaptive quality settings."
	^nil! !


!FlashSpriteMorph methodsFor: 'private' stamp: 'di 11/13/2000 00:51'!
getWebBrowser
	"Return a web browser if we're running in one"

	self withAllOwnersDo:
		[:morph | morph isWebBrowser ifTrue: [^ morph].
		(morph hasProperty: #webBrowserView) ifTrue: [^ morph model]].
	^ nil! !


!FlashSpriteMorph methodsFor: 'copying' stamp: 'ar 5/19/1999 19:11'!
copyMovieFrom: firstFrame to: lastFrame
	"Note: This is different if sent to a sprite since a sprite contains a *full* animation
	and is therefore always completely."
	^super copyMovieFrom: 1 to: maxFrames.! !


!FlashSpriteMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:45'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	lastStepTime ifNil: [lastStepTime _ 0].
	useTimeSync ifNil: [useTimeSync _ true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !
Object subclass: #FlashStreamingSound
	instanceVariableNames: 'mixFmt stereo samplingRate bitsPerSample sampleCount compressed firstFrame frameNumber buffers '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Support'!

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
bitsPerSample
	^bitsPerSample! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
bitsPerSample: aNumber
	bitsPerSample _ aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:45'!
buffers
	^buffers! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:45'!
buffers: anArray
	buffers _ anArray! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
compressed
	^compressed! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
compressed: aBool
	compressed _ aBool! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:34'!
firstFrame
	^firstFrame! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:34'!
firstFrame: frame
	firstFrame _ frame.! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:45'!
frameNumber
	^frameNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:45'!
frameNumber: aNumber
	frameNumber _ aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
mixFmt
	^mixFmt! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
mixFmt: aNumber
	mixFmt _ aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
sampleCount
	^sampleCount! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:41'!
sampleCount: aNumber
	sampleCount _ aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:33'!
samplingRate
	^samplingRate! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/21/1998 00:33'!
samplingRate: aNumber
	samplingRate _ aNumber! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
stereo
	^stereo! !

!FlashStreamingSound methodsFor: 'accessing' stamp: 'ar 11/20/1998 22:40'!
stereo: aBool
	stereo _ aBool! !
FlashCharacterMorph subclass: #FlashTextMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!
BorderedMorph subclass: #FlashThumbnailMorph
	instanceVariableNames: 'player frameNumber image selected '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-MMFlash Morphs'!

!FlashThumbnailMorph methodsFor: 'initialization' stamp: 'ar 5/19/1999 17:29'!
initialize
	super initialize.
	selected _ false.! !


!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
frameNumber
	^frameNumber! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:02'!
frameNumber: aNumber
	frameNumber = aNumber ifFalse:[
		frameNumber _ aNumber.
		image _ nil.
	].! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
image
	^image! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
image: aForm
	image _ aForm.
	self changed.! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 17:14'!
isSelected
	^selected == true! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 17:29'!
isSelected: aBoolean
	selected == aBoolean ifTrue:[^self].
	selected _ aBoolean.
	self borderColor: (self isSelected ifTrue:[Color red] ifFalse:[Color black]).! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:00'!
player
	^player! !

!FlashThumbnailMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 16:01'!
player: aFlashPlayerMorph
	player _ aFlashPlayerMorph.! !


!FlashThumbnailMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:05'!
drawOn: aCanvas
	(player == nil or:[frameNumber == nil]) ifTrue:[^super drawOn: aCanvas].
false ifTrue:[super drawOn: aCanvas.
			^aCanvas text: frameNumber printString bounds: self innerBounds font: nil color: Color red].
	image ifNil:[
		Cursor wait showWhile:[
			image _ player imageFormOfSize: (self extent - (self borderWidth * 2))
					 forFrame: frameNumber.
			frameNumber printString displayOn: image]].
	aCanvas frameRectangle: self bounds width: self borderWidth color: self borderColor.
	aCanvas paintImage: image at: self topLeft + self borderWidth.
! !
EllipseMorph subclass: #FlasherMorph
	instanceVariableNames: 'onColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!FlasherMorph methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:16'!
canHaveFillStyles
	^false! !

!FlasherMorph methodsFor: 'as yet unclassified'!
color: aColor

	super color: aColor.
	onColor _ aColor.! !

!FlasherMorph methodsFor: 'as yet unclassified'!
fullPrintOn: aStream

	color _ onColor.
	super fullPrintOn: aStream.! !

!FlasherMorph methodsFor: 'as yet unclassified'!
initialize

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

!FlasherMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/4/2000 12:08'!
step
	super step.
	color = onColor
		ifTrue: [super color: (onColor alphaMixed: 0.5 with: Color black)]
		ifFalse: [super color: onColor].
! !

!FlasherMorph methodsFor: 'as yet unclassified'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 500! !
NullEncoder subclass: #FlattenEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!
!FlattenEncoder commentStamp: '<historical>' prior: 0!
The simplest possible encoding:  leave the objects as is.
!


!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:51'!
cr
	^self print:String cr.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 21:50'!
writeArrayedCollection:anArrayedCollection
	^self writeCollectionContents:anArrayedCollection.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:03'!
writeCollection:aCollection
	^self writeCollectionContents:aCollection.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'!
writeCollectionContents:aCollection
    ^self writeCollectionContents:aCollection separator:self elementSeparator iterationMessage:#do:.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:26'!
writeCollectionContents:aCollection separator:separator
	^self writeCollectionContents:aCollection separator:separator iterationMessage:#do:.! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:25'!
writeCollectionContents:aCollection separator:separator iterationMessage:op
	| first |
	first _ true.
	aCollection perform:op with: [ :each |  first ifFalse:[ self writeObject:separator ]. self write:each. first_false.].
! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:30'!
writeDictionary:aCollection
	^self writeDictionaryContents:aCollection separator:nil.

! !

!FlattenEncoder methodsFor: 'writing' stamp: 'MPW 1/4/1901 08:29'!
writeDictionaryContents:aCollection separator:separator
	^self writeCollectionContents:aCollection separator:separator iterationMessage:#associationsDo:.! !


!FlattenEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 01:32'!
elementSeparator
	^target elementSeparator.! !

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

FlattenEncoder class
	instanceVariableNames: ''!

!FlattenEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:08'!
filterSelector
	^#flattenOnStream:
! !
SketchMorph subclass: #FlexMorph
	instanceVariableNames: 'originalMorph borderWidth borderColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:40'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	"super addCustomMenuItems: aCustomMenu hand: aHandMorph."
	aCustomMenu addLine.
	aCustomMenu add: 'update from original' action: #updateFromOriginal.
	aCustomMenu addList: #(('border color...' changeBorderColor:)
						('border width...' changeBorderWidth:)).
	aCustomMenu addLine.
! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:43'!
borderColor: aColor
	borderColor _ aColor.
	self updateFromOriginal! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:43'!
borderWidth: width
	borderWidth _ width asPoint.
	self updateFromOriginal! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 18:52'!
changeBorderColor: evt
	| aHand |
	aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
	self changeColorTarget: self selector: #borderColor: originalColor: self borderColor hand: aHand.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 8/30/2000 21:39'!
changeBorderWidth: evt
	| handle origin aHand |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(LineMorph from: origin to: newPoint color: Color black width: 1).
		self borderWidth: (newPoint - origin) r asInteger // 5].
	aHand attachMorph: handle.
	handle startStepping! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:54'!
drawOn: aCanvas

	originalForm _ nil.  "Aggressively uncache the originalForm"
	^ super drawOn: aCanvas! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:35'!
extent: newExtent

	self loadOriginalForm.  "make sure it's not nil"
	^ super extent: newExtent! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:35'!
form

	self loadOriginalForm.  "make sure it's not nil"
	^ super form! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:35'!
generateRotatedForm

	self loadOriginalForm.  "make sure it's not nil"
	^ super generateRotatedForm! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:37'!
initialize
	super initialize.
	borderWidth _ 2@2.
	borderColor _ Color black.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:35'!
layoutChanged

	self loadOriginalForm.  "make sure it's not nil"
	^ super layoutChanged! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:34'!
loadOriginalForm

	originalForm ifNil: [self updateFromOriginal].
! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/25/1999 10:36'!
originalMorph

	^ originalMorph! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 20:19'!
originalMorph: aMorph

	originalMorph _ aMorph.
	scalePoint _ 0.25@0.25.
	self updateFromOriginal.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 19:44'!
releaseCachedState
	"Clear cache of rotated, scaled Form."

	originalForm _ Form extent: 10@10.  "So super hibernate won't have to work hard
												but won't crash either."
	super releaseCachedState.
	rotatedForm _ nil.
	originalForm _ nil.! !

!FlexMorph methodsFor: 'as yet unclassified' stamp: 'di 1/11/1999 21:46'!
updateFromOriginal

	| intermediateForm |
	intermediateForm _ originalMorph imageForm offset: 0@0.
	intermediateForm border: intermediateForm boundingBox
		widthRectangle: (borderWidth corner: borderWidth+1)
		rule: Form over fillColor: borderColor.
	self form: intermediateForm.
	originalMorph fullReleaseCachedState! !
PasteUpMorph subclass: #Flipper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
Array variableSubclass: #FlippyArray2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!FlippyArray2 commentStamp: '<historical>' prior: 0!
Demonstrator class using FlippyArrayPlugin2!


!FlippyArray2 methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 08:22'!
reverse

	<primitive: 'primReverse' module: 'FlippyArrayPlugin2'>
	^FlippyArrayPlugin2
		doPrimitive: 'primReverse'
		withArguments: {}! !

!FlippyArray2 methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 08:24'!
reverseFrom: x to: y

	<primitive: 'primReverseFromto' module: 'FlippyArrayPlugin2'>
	^FlippyArrayPlugin2 
		doPrimitive: 'primReverseFrom:to:'
		withArguments: {x. y}! !
TestInterpreterPlugin variableSubclass: #FlippyArrayPlugin2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!FlippyArrayPlugin2 commentStamp: '<historical>' prior: 0!
"TestInterpreterPlugin Example: primitives for reversing an array"

FlippyArrayPlugin2 translate
Smalltalk garbageCollect!


!FlippyArrayPlugin2 methodsFor: 'as yet unclassified' stamp: 'bf 9/24/1999 14:39'!
primReverse

	| rcvr t a b |
	rcvr _ self 
		primitive:	'primReverse'
		parameters:	#()
		receiver:	#Array.

	a _ 0. b _ rcvr size - 1.
	[a < b] whileTrue:
		[t _ rcvr at: a.
		 rcvr at: a put: (rcvr at: b).
		 rcvr at: b put: t.
		 a _ a + 1. b _ b - 1].
	^rcvr asOop: Array! !

!FlippyArrayPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 09:52'!
primReverseFrom: fromInteger to: toInteger

	| rcvr t a b |
	rcvr _ self
		primitive:	'primReverseFromto'
		parameters:	#(SmallInteger SmallInteger)
		receiver:	#Array.

	a _ fromInteger - 1. b _ toInteger - 1.
	[a < b] whileTrue:
		[t _ rcvr at: a.
		 rcvr at: a put: (rcvr at: b).
		 rcvr at: b put: t.
		 a _ a + 1. b _ b - 1].
	^rcvr asOop: Array! !
Number variableWordSubclass: #Float
	instanceVariableNames: ''
	classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi '
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Float commentStamp: '<historical>' prior: 0!
My instances represent IEEE-754 floating-point double-precision numbers.  They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are:
	
	8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12

Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point.  It is actually possible to specify a radix for Squeak Float constants.  This is great for teaching about numbers, but may be confusing to the average reader:

	3r20.2 --> 6.66666666666667
	8r20.2 --> 16.25

If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex.  It may help you to know that the basic format is...
	sign		1 bit
	exponent	11 bits with bias of 1023 (16r3FF) to produce an exponent
						in the range -1023 .. +1024
				- 16r000:
					significand = 0: Float zero
					significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit)
				- 16r7FF:
					significand = 0: Infinity
					significand ~= 0: Not A Number (NaN) representation
	mantissa	53 bits, but only 52 are stored (20 in the first word, 32 in the second).  This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead.  People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND.

The single-precision format is...
	sign		1 bit
	exponent	8 bits, with bias of 127, to represent -126 to +127
                    - 0x0 and 0xFF reserved for Float zero (mantissa is ignored)
                    - 16r7F reserved for Float underflow/overflow (mantissa is ignored)
	mantissa	24 bits, but only 23 are stored
This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:.

Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.!
]style[(680 9 1189 21 6 26 149)f1,f1LFloat hex;,f1,f1LFloat asIEEE32BitWord;,f1,f1LFloat class fromIEEE32Bit:;,f1!


!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'!
* aNumber 
	"Primitive. Answer the result of multiplying the receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 49>
	^ aNumber adaptToFloat: self andSend: #*! !

!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'!
+ aNumber 
	"Primitive. Answer the sum of the receiver and aNumber. Essential.
	Fail if the argument is not a Float. See Object documentation
	whatIsAPrimitive."

	<primitive: 41>
	^ aNumber adaptToFloat: self andSend: #+! !

!Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'!
- aNumber 
	"Primitive. Answer the difference between the receiver and aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 42>
	^ aNumber adaptToFloat: self andSend: #-! !

!Float methodsFor: 'arithmetic' stamp: 'tfei 4/12/1999 12:45'!
/ aNumber 
	"Primitive. Answer the result of dividing receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 50>
	aNumber = 0 ifTrue: [^(ZeroDivide dividend: self) signal].
	^ aNumber adaptToFloat: self andSend: #/! !

!Float methodsFor: 'arithmetic'!
abs
	"This is faster than using Number abs."
	self < 0.0
		ifTrue: [^ 0.0 - self]
		ifFalse: [^ self]! !

!Float methodsFor: 'arithmetic'!
negated
	"Answer a Number that is the negation of the receiver."

	^0.0 - self! !

!Float methodsFor: 'arithmetic'!
reciprocal
	^ 1.0 / self! !


!Float methodsFor: 'mathematical functions'!
arcCos
	"Answer the angle in radians."

	^ Halfpi - self arcSin! !

!Float methodsFor: 'mathematical functions' stamp: 'jsp 2/25/1999 11:15'!
arcSin
	"Answer the angle in radians."

	((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range'].
	((self = -1.0) or: [self = 1.0])
		ifTrue: [^ Halfpi * self]
		ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! !

!Float methodsFor: 'mathematical functions'!
arcTan
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| theta eps step sinTheta cosTheta |
	<primitive: 57>

	"Newton-Raphson"
	self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ].

	"first guess"
	theta _ (self * Halfpi) / (self + 1.0).

	"iterate"
	eps _ Halfpi * Epsilon.
	step _ theta.
	[(step * step) > eps] whileTrue: [
		sinTheta _ theta sin.
		cosTheta _ theta cos.
		step _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta).
		theta _ theta - step].
	^ theta! !

!Float methodsFor: 'mathematical functions' stamp: 'jsp 3/30/1999 12:38'!
arcTan: denominator
	"Answer the angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| result |

	(self = 0.0) ifTrue: [ (denominator > 0.0) ifTrue: [ result _ 0 ]
										    ifFalse: [ result _ Pi ]
						]
			    ifFalse: [(denominator = 0.0)
					ifTrue: [ (self > 0.0) ifTrue: [ result _ Halfpi ]
												ifFalse: [ result _ Halfpi negated ]
							]
					ifFalse: [ (denominator > 0) ifTrue: [ result _ (self / denominator) arcTan ]
								 ifFalse: [ result _ ((self / denominator) arcTan) + Pi ]
							].
						].
	
	^ result.! !

!Float methodsFor: 'mathematical functions'!
cos
	"Answer the cosine of the receiver taken as an angle in radians."

	^ (self + Halfpi) sin! !

!Float methodsFor: 'mathematical functions'!
degreeCos
	"Answer the cosine of the receiver taken as an angle in degrees."

	^ self degreesToRadians cos! !

!Float methodsFor: 'mathematical functions'!
degreeSin
	"Answer the sine of the receiver taken as an angle in degrees."

	^ self degreesToRadians sin! !

!Float methodsFor: 'mathematical functions'!
exp
	"Answer E raised to the receiver power.
	 Optional. See Object documentation whatIsAPrimitive." 

	| base fract correction delta div |
	<primitive: 59>

	"Taylor series"
	"check the special cases"
	self < 0.0 ifTrue: [^ (self negated exp) reciprocal].
	self = 0.0 ifTrue: [^ 1].
	self abs > MaxValLn ifTrue: [self error: 'exp overflow'].

	"get first approximation by raising e to integer power"
	base _ E raisedToInteger: (self truncated).

	"now compute the correction with a short Taylor series"
	"fract will be 0..1, so correction will be 1..E"
	"in the worst case, convergance time is logarithmic with 1/Epsilon"
	fract _ self fractionPart.
	fract = 0.0 ifTrue: [ ^ base ].  "no correction required"

	correction _ 1.0 + fract.
	delta _ fract * fract / 2.0.
	div _ 2.0.
	[delta > Epsilon] whileTrue: [
		correction _ correction + delta.
		div _ div + 1.0.
		delta _ delta * fract / div].
	correction _ correction + delta.
	^ base * correction! !

!Float methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:28'!
floorLog: radix
	"Answer the floor of the log base radix of the receiver."

	^ (self log: radix) floor
! !

!Float methodsFor: 'mathematical functions'!
ln
	"Answer the natural logarithm of the receiver.
	 Optional. See Object documentation whatIsAPrimitive."

	| expt n mant x div pow delta sum eps |
	<primitive: 58>

	"Taylor series"
	self <= 0.0 ifTrue: [self error: 'ln is only defined for x > 0.0'].

	"get a rough estimate from binary exponent"
	expt _ self exponent.
	n _ Ln2 * expt.
	mant _ self timesTwoPower: 0 - expt.

	"compute fine correction from mantinssa in Taylor series"
	"mant is in the range [0..2]"
	"we unroll the loop to avoid use of abs"
	x _ mant - 1.0.
	div _ 1.0.
	pow _ delta _ sum _ x.
	x _ x negated.  "x <= 0"
	eps _ Epsilon * (n abs + 1.0).
	[delta > eps] whileTrue: [
		"pass one: delta is positive"
		div _ div + 1.0.
		pow _ pow * x.
		delta _ pow / div.
		sum _ sum + delta.
		"pass two: delta is negative"
		div _ div + 1.0.
		pow _ pow * x.
		delta _ pow / div.
		sum _ sum + delta].

	^ n + sum

	"2.718284 ln 1.0"! !

!Float methodsFor: 'mathematical functions'!
log
	"Answer the base 10 logarithm of the receiver."

	^ self ln / Ln10! !

!Float methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:35'!
raisedTo: aNumber
	"Answer the receiver raised to aNumber."

	aNumber isInteger ifTrue:
		["Do the special case of integer power"
		^ self raisedToInteger: aNumber].
	self < 0.0 ifTrue:
		[ self error: self printString, ' raised to a non-integer power' ].
	0.0 = aNumber ifTrue: [^ 1.0].				"special case for exponent = 0.0"
	(self= 0.0) | (aNumber = 1.0) ifTrue: [^ self].	"special case for self = 1.0"
	^ (self ln * aNumber asFloat) exp			"otherwise use logarithms"
! !

!Float methodsFor: 'mathematical functions' stamp: 'tao 4/19/98 23:22'!
reciprocalFloorLog: radix 
	"Quick computation of (self log: radix) floor, when self < 1.0.
	Avoids infinite recursion problems with denormalized numbers"

	| adjust scale n |
	adjust _ 0.
	scale _ 1.0.
	[(n _ radix / (self * scale)) isInfinite]
		whileTrue:
			[scale _ scale * radix.
			adjust _ adjust + 1].
	^ ((n floorLog: radix) + adjust) negated! !

!Float methodsFor: 'mathematical functions' stamp: 'tao 10/15/97 14:23'!
reciprocalLogBase2
	"optimized for self = 10, for use in conversion for printing"

	^ self = 10.0
		ifTrue: [Ln2 / Ln10]
		ifFalse: [Ln2 / self ln]! !

!Float methodsFor: 'mathematical functions' stamp: 'laza 12/21/1999 12:15'!
safeArcCos
	"Answer the angle in radians."
	(self between: -1.0 and: 1.0)
		ifTrue: [^ self arcCos]
		ifFalse: [^ self sign arcCos]! !

!Float methodsFor: 'mathematical functions'!
sin
	"Answer the sine of the receiver taken as an angle in radians.
	 Optional. See Object documentation whatIsAPrimitive."

	| sum delta self2 i |
	<primitive: 56>

	"Taylor series"
	"normalize to the range [0..Pi/2]"
	self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))].
	self > Twopi ifTrue: [^ (self \\ Twopi) sin].
	self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)].
	self > Halfpi ifTrue: [^ (Pi - self) sin].

	"unroll loop to avoid use of abs"
	sum _ delta _ self.
	self2 _ 0.0 - (self * self).
	i _ 2.0.
	[delta > Epsilon] whileTrue: [
		"once"
		delta _ (delta * self2) / (i * (i + 1.0)).
		i _ i + 2.0.
		sum _ sum + delta.
		"twice"
		delta _ (delta * self2) / (i * (i + 1.0)).
		i _ i + 2.0.
		sum _ sum + delta].
	^ sum! !

!Float methodsFor: 'mathematical functions'!
sqrt
	"Answer the square root of the receiver.
	 Optional. See Object documentation whatIsAPrimitive."

	| exp guess eps delta |
	<primitive: 55>

	"Newton-Raphson"
	self <= 0.0 ifTrue: [
		self = 0.0
			ifTrue: [^ 0.0]
			ifFalse: [^ self error: 'sqrt is invalid for x < 0']].

	"first guess is half the exponent"
	exp _ self exponent // 2.
	guess _ self timesTwoPower: (0 - exp).

	"get eps value"
	eps _ guess * Epsilon.
	eps _ eps * eps.
	delta _ (self - (guess * guess)) / (guess * 2.0).
	[(delta * delta) > eps] whileTrue: [
		guess _ guess + delta.
		delta _ (self - (guess * guess)) / (guess * 2.0)].
	^ guess! !

!Float methodsFor: 'mathematical functions'!
tan
	"Answer the tangent of the receiver taken as an angle in radians."

	^ self sin / self cos! !

!Float methodsFor: 'mathematical functions'!
timesTwoPower: anInteger 
	"Primitive. Answer with the receiver multiplied by 2.0 raised
	to the power of the argument.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 54>

	anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)].
	anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat].
	anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat].
	^ self * (2.0 raisedToInteger: anInteger)! !


!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'!
< aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 43>
	^ aNumber adaptToFloat: self andSend: #<! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'!
<= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 45>
	^ aNumber adaptToFloat: self andSend: #<=! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:56'!
= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 47>
	aNumber isNumber ifFalse: [^ false].
	^ aNumber adaptToFloat: self andSend: #=! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'!
> aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is greater than the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 44>
	^ aNumber adaptToFloat: self andSend: #>! !

!Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'!
>= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is greater than or equal to the argument. Otherwise return
	false. Fail if the argument is not a Float. Optional. See Object documentation 
	whatIsAPrimitive. "

	<primitive: 46>
	^ aNumber adaptToFloat: self andSend: #>! !

!Float methodsFor: 'comparing' stamp: 'tk 11/27/1999 21:47'!
closeTo: num
	"are these two numbers close?"
	| fuzz ans |
	num isNumber ifFalse: [
		[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
		^ ans].
	self = 0.0 ifTrue: [^ num abs < 0.0001].
	num = 0.0 ifTrue: [^ self abs < 0.0001].
	self isNaN == num isNaN ifFalse: [^ false].
	self isInfinite == num isInfinite ifFalse: [^ false].
	fuzz := (self abs max: num abs) * 0.0001.
	^ (self - num) abs <= fuzz! !

!Float methodsFor: 'comparing' stamp: 'jm 4/28/1998 01:04'!
hash
	"Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)"

	^ (((self basicAt: 1) bitAnd: 16r00FFFF00) +
	   ((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8
! !

!Float methodsFor: 'comparing'!
~= aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is not equal to the argument. Otherwise return false.
	Fail if the argument is not a Float. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 48>
	^super ~= aNumber! !


!Float methodsFor: 'testing' stamp: 'bf 8/20/1999 12:56'!
hasContentsInExplorer

	^false! !

!Float methodsFor: 'testing'!
isFloat
	^ true! !

!Float methodsFor: 'testing' stamp: 'jm 4/30/1998 13:50'!
isInfinite
	"Return true if the receiver is positive or negative infinity."

	^ self = Infinity or: [self = NegativeInfinity]
! !

!Float methodsFor: 'testing'!
isLiteral

	^true! !

!Float methodsFor: 'testing' stamp: 'tao 10/10/97 16:39'!
isNaN
	"simple, byte-order independent test for Not-a-Number"

	^ self ~= self! !

!Float methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'!
isPowerOfTwo
	"Return true if the receiver is an integral power of two.
	Floats never return true here."
	^false! !

!Float methodsFor: 'testing'!
isZero
	^self = 0.0! !

!Float methodsFor: 'testing' stamp: 'jm 4/28/1998 01:10'!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0.
	Handle IEEE-754 negative-zero by reporting a sign of -1"

	self > 0 ifTrue: [^ 1].
	(self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1].
	^ 0! !


!Float methodsFor: 'truncation and round off'!
exponent
	"Primitive. Consider the receiver to be represented as a power of two
	multiplied by a mantissa (between one and two). Answer with the
	SmallInteger to whose power two is raised. Optional. See Object
	documentation whatIsAPrimitive."

	| positive |
	<primitive: 53>
	self >= 1.0 ifTrue: [^self floorLog: 2].
	self > 0.0
		ifTrue: 
			[positive _ (1.0 / self) exponent.
			self = (1.0 / (1.0 timesTwoPower: positive))
				ifTrue: [^positive negated]
				ifFalse: [^positive negated - 1]].
	self = 0.0 ifTrue: [^-1].
	^self negated exponent! !

!Float methodsFor: 'truncation and round off'!
fractionPart
	"Primitive. Answer a Float whose value is the difference between the 
	receiver and the receiver's asInteger value. Optional. See Object 
	documentation whatIsAPrimitive."

	<primitive: 52>
	^self - self truncated asFloat! !

!Float methodsFor: 'truncation and round off'!
integerPart
	"Answer a Float whose value is the receiver's truncated value."

	^self - self fractionPart! !

!Float methodsFor: 'truncation and round off' stamp: 'tk 12/30/2000 20:04'!
reduce
    "If self is close to an integer, return that integer"

    (self closeTo: self rounded) ifTrue: [^ self rounded]! !

!Float methodsFor: 'truncation and round off'!
rounded
	"Answer the integer nearest the receiver."

	self >= 0.0
		ifTrue: [^(self + 0.5) truncated]
		ifFalse: [^(self - 0.5) truncated]! !

!Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 13:14'!
significand

	^ self timesTwoPower: (self exponent negated)! !

!Float methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 14:27'!
significandAsInteger

	| exp sig |
	exp _ self exponent.
	sig _ (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2).
	exp > -1023
		ifTrue: [sig _ sig bitOr: (1 bitShift: 52)].
	^ sig.! !

!Float methodsFor: 'truncation and round off' stamp: 'di 7/1/1998 23:01'!
truncated
	"Answer with a SmallInteger equal to the value of the receiver without 
	its fractional part. The primitive fails if the truncated value cannot be 
	represented as a SmallInteger. In that case, the code below will compute 
	a LargeInteger truncated value.
	Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 51>
	(self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number'].

	self abs < 2.0e16
		ifTrue: ["Fastest way when it may not be an integer"
				^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated]
		ifFalse: [^ self asTrueFraction.  "Extract all bits of the mantissa and shift if necess"]! !


!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:38'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert it to a Float."
	^ rcvr asFloat perform: selector with: self! !

!Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:07'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Float."
	^ rcvr asFloat perform: selector with: self! !

!Float methodsFor: 'converting'!
asApproximateFraction
	"Answer a Fraction approximating the receiver. This conversion uses the 
	continued fraction method to approximate a floating point number."

	| num1 denom1 num2 denom2 int frac newD temp |
	num1 _ self asInteger.	"The first of two alternating numerators"
	denom1 _ 1.		"The first of two alternating denominators"
	num2 _ 1.		"The second numerator"
	denom2 _ 0.		"The second denominator--will update"
	int _ num1.		"The integer part of self"
	frac _ self fractionPart.		"The fractional part of self"
	[frac = 0]
		whileFalse: 
			["repeat while the fractional part is not zero"
			newD _ 1.0 / frac.			"Take reciprocal of the fractional part"
			int _ newD asInteger.		"get the integer part of this"
			frac _ newD fractionPart.	"and save the fractional part for next time"
			temp _ num2.				"Get old numerator and save it"
			num2 _ num1.				"Set second numerator to first"
			num1 _ num1 * int + temp.	"Update first numerator"
			temp _ denom2.				"Get old denominator and save it"
			denom2 _ denom1.			"Set second denominator to first"
			denom1 _ int * denom1 + temp.		"Update first denominator"
			10000000000.0 < denom1
				ifTrue: 
					["Is ratio past float precision?  If so, pick which 
					of the two ratios to use"
					num2 = 0.0 
						ifTrue: ["Is second denominator 0?"
								^ Fraction numerator: num1 denominator: denom1].
					^ Fraction numerator: num2 denominator: denom2]].
	"If fractional part is zero, return the first ratio"
	denom1 = 1
		ifTrue: ["Am I really an Integer?"
				^ num1 "Yes, return Integer result"]
		ifFalse: ["Otherwise return Fraction result"
				^ Fraction numerator: num1 denominator: denom1]! !

!Float methodsFor: 'converting'!
asFloat
	"Answer the receiver itself."

	^self! !

!Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'!
asFraction
	^ self asTrueFraction ! !

!Float methodsFor: 'converting' stamp: 'di 2/8/1999 12:51'!
asIEEE32BitWord
	"Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. Used for conversion in FloatArrays only."
	| word1 word2 sign mantissa exponent destWord |
	self = 0.0 ifTrue:[^0].
	word1 _ self basicAt: 1.
	word2 _ self basicAt: 2.
	mantissa _ (word2 bitShift: -29) + ((word1 bitAnd:  16rFFFFF) bitShift: 3).
	exponent _ ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127.
	exponent < 0 ifTrue:[^0]. "Underflow"
	exponent > 254 ifTrue:["Overflow"
		exponent _ 255.
		mantissa _ 0].
	sign _ word1 bitAnd: 16r80000000.
	destWord _ (sign bitOr: (exponent bitShift: 23)) bitOr: mantissa.
	^ destWord! !

!Float methodsFor: 'converting' stamp: 'di 7/1/1998 22:20'!
asTrueFraction
	" Answer a fraction that EXACTLY represents self,
	  a double precision IEEE floating point number.
	  Floats are stored in the same form on all platforms.
	  (Does not handle gradual underflow or NANs.)
	  By David N. Smith with significant performance
	  improvements by Luciano Esteban Notarfrancesco.
	  (Version of 11April97)"
	| shifty sign expPart exp fraction fractionPart result zeroBitsCount |
	self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction'].
	self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction'].

	" Extract the bits of an IEEE double float "
	shifty := ((self basicAt: 1) bitShift: 32) + (self basicAt: 2).

	" Extract the sign and the biased exponent "
	sign := (shifty bitShift: -63) = 0 ifTrue: [1] ifFalse: [-1].
	expPart := (shifty bitShift: -52) bitAnd: 16r7FF.

	" Extract fractional part; answer 0 if this is a true 0.0 value "
	fractionPart := shifty bitAnd:  16r000FFFFFFFFFFFFF.
	( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0  ].

	" Replace omitted leading 1 in fraction "
	fraction := fractionPart bitOr: 16r0010000000000000.

	"Unbias exponent: 16r3FF is bias; 52 is fraction width"
	exp := 16r3FF + 52 - expPart.

	" Form the result. When exp>52, the exponent is adjusted by
	  the number of trailing zero bits in the fraction to minimize
	  the (huge) time otherwise spent in #gcd:. "
	exp negative
		ifTrue: [
			result := sign * fraction bitShift: exp negated ]
		ifFalse:	[
			zeroBitsCount _ fraction lowBit - 1.
			exp := exp - zeroBitsCount.
			exp <= 0
				ifTrue: [
					zeroBitsCount := zeroBitsCount + exp.
					"exp := 0."   " Not needed; exp not
refernced again "
					result := sign * fraction bitShift:
zeroBitsCount negated ]
				ifFalse: [
					result := Fraction
						numerator: (sign * fraction
bitShift: zeroBitsCount negated)
						denominator: (1 bitShift:
exp) ] ].

	"Low cost validation omitted after extensive testing"
	"(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']."
	^ result ! !

!Float methodsFor: 'converting'!
degreesToRadians
	"Answer the receiver in radians. Assumes the receiver is in degrees."

	^self * RadiansPerDegree! !

!Float methodsFor: 'converting' stamp: 'tao 10/10/97 16:38'!
isInf
	"simple, byte-order independent test for +/- Infinity"

	^ self = (self * 1.5 + 1.0)! !

!Float methodsFor: 'converting'!
radiansToDegrees
	"Answer the receiver in degrees. Assumes the receiver is in radians."

	^self / RadiansPerDegree! !


!Float methodsFor: 'copying'!
deepCopy

	^self copy! !

!Float methodsFor: 'copying'!
shallowCopy

	^self + 0.0! !

!Float methodsFor: 'copying' stamp: 'tk 8/19/1998 16:08'!
veryDeepCopyWith: deepCopier
	"Return self.  Do not record me."

	^ self clone! !


!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:59'!
absByteEncode: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version performs all calculations with Floats instead of LargeIntegers, and loses
	about 3 lsbs of accuracy compared to an exact conversion."

	| significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream print: 'Infinity'. ^ self].
	significantBits _ 50.  "approximately 3 lsb's of accuracy loss during conversion"
	fBase _ base asFloat.
	exp _ self exponent.
	baseExpEstimate _ (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[r _ self.
			s _ 1.0.
			mPlus _ 1.0 timesTwoPower: exp - significantBits.
			mMinus _ self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]]
		ifFalse:
			[r _ self timesTwoPower: significantBits.
			s _ 1.0 timesTwoPower:  significantBits.
			mMinus _ 1.0 timesTwoPower: (exp max: -1024).
			mPlus _
				(exp = MinValLogBase2) | (self significand ~= 1.0)
					ifTrue: [mMinus]
					ifFalse: [mMinus * 2.0]].
	baseExpEstimate >= 0
		ifTrue:
			[s _ s * (fBase raisedToInteger: baseExpEstimate).
			exp = 1023
				ifTrue:   "scale down to prevent overflow to Infinity during conversion"
					[r _ r / fBase.
					s _ s / fBase.
					mPlus _ mPlus / fBase.
					mMinus _ mMinus / fBase]]
		ifFalse:
			[exp < -1023
				ifTrue:   "scale up to prevent denorm reciprocals overflowing to Infinity"
					[d _ (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
					scale _ fBase raisedToInteger: d.
					r _ r * scale.
					mPlus _ mPlus * scale.
					mMinus _ mMinus * scale.
					scale _ fBase raisedToInteger: (baseExpEstimate + d) negated]
				ifFalse:
				[scale _ fBase raisedToInteger: baseExpEstimate negated].
			s _ s / scale].
	(r + mPlus >= s)
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[s _ s / fBase].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream print: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1].
	[d _ (r / s) truncated.
	r _ r - (d * s).
	(tc1 _ r <= mMinus) | (tc2 _ r + mPlus >= s)] whileFalse:
		[aStream print: (Character digitValue: d).
		r _ r * fBase.
		mPlus _ mPlus * fBase.
		mMinus _ mMinus * fBase.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream print: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d _ d + 1]].
	aStream print: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream print: $0].
		aStream print: '.0'].
	fixedFormat ifFalse:
		[aStream print: $e.
		aStream print: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:21'!
absPrintExactlyOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version guarantees that the printed representation exactly represents my value
	by using exact integer arithmetic."

	| fBase significand exp baseExpEstimate be be1 r s mPlus mMinus scale roundingIncludesLimits d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self].
	fBase _ base asFloat.
	significand _ self significandAsInteger.
	roundingIncludesLimits _ significand even.
	exp _ (self exponent - 52) max: MinValLogBase2.
	baseExpEstimate _ (self exponent * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[be _ 1 << exp.
			significand ~= 16r10000000000000
				ifTrue:
					[r _ significand * be * 2.
					s _ 2.
					mPlus _ be.
					mMinus _ be]
				ifFalse:
					[be1 _ be * 2.
					r _ significand * be1 * 2.
					s _ 4.
					mPlus _ be1.
					mMinus _ be]]
		ifFalse:
			[(exp = MinValLogBase2) | (significand ~= 16r10000000000000)
				ifTrue:
					[r _ significand * 2.
					s _ (1 << (exp negated)) * 2.
					mPlus _ 1.
					mMinus _ 1]
				ifFalse:
					[r _ significand * 4.
					s _ (1 << (exp negated + 1)) * 2.
					mPlus _ 2.
					mMinus _ 1]].
	baseExpEstimate >= 0
		ifTrue: [s _ s * (base raisedToInteger: baseExpEstimate)]
		ifFalse:
			[scale _ base raisedToInteger: baseExpEstimate negated.
			r _ r * scale.
			mPlus _ mPlus * scale.
			mMinus _ mMinus * scale].
	(r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s))
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[r _ r * base.
			mPlus _ mPlus * base.
			mMinus _ mMinus * base].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1]. 
	[d _ r // s.
	r _ r \\ s.
	(tc1 _ (r < mMinus) | (roundingIncludesLimits & (r = mMinus))) |
	(tc2 _ (r + mPlus > s) | (roundingIncludesLimits & (r + mPlus = s)))] whileFalse:
		[aStream nextPut: (Character digitValue: d).
		r _ r * base.
		mPlus _ mPlus * base.
		mMinus _ mMinus * base.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream nextPut: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2 >= s)) ifTrue: [d _ d + 1]].
	aStream nextPut: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0].
		aStream nextPutAll: '.0'].
	fixedFormat ifFalse:
		[aStream nextPut: $e.
		aStream nextPutAll: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'tao 4/22/98 11:58'!
absPrintOn: aStream base: base
	"Print my value on a stream in the given base.  Assumes that my value is strictly
	positive; negative numbers, zero, and NaNs have already been handled elsewhere.
	Based upon the algorithm outlined in:
	Robert G. Burger and R. Kent Dybvig
	Printing Floating Point Numbers Quickly and Accurately
	ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation
	June 1996.
	This version performs all calculations with Floats instead of LargeIntegers, and loses
	about 3 lsbs of accuracy compared to an exact conversion."

	| significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount |
	self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self].
	significantBits _ 50.  "approximately 3 lsb's of accuracy loss during conversion"
	fBase _ base asFloat.
	exp _ self exponent.
	baseExpEstimate _ (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
	exp >= 0
		ifTrue:
			[r _ self.
			s _ 1.0.
			mPlus _ 1.0 timesTwoPower: exp - significantBits.
			mMinus _ self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]]
		ifFalse:
			[r _ self timesTwoPower: significantBits.
			s _ 1.0 timesTwoPower:  significantBits.
			mMinus _ 1.0 timesTwoPower: (exp max: -1024).
			mPlus _
				(exp = MinValLogBase2) | (self significand ~= 1.0)
					ifTrue: [mMinus]
					ifFalse: [mMinus * 2.0]].
	baseExpEstimate >= 0
		ifTrue:
			[s _ s * (fBase raisedToInteger: baseExpEstimate).
			exp = 1023
				ifTrue:   "scale down to prevent overflow to Infinity during conversion"
					[r _ r / fBase.
					s _ s / fBase.
					mPlus _ mPlus / fBase.
					mMinus _ mMinus / fBase]]
		ifFalse:
			[exp < -1023
				ifTrue:   "scale up to prevent denorm reciprocals overflowing to Infinity"
					[d _ (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling.
					scale _ fBase raisedToInteger: d.
					r _ r * scale.
					mPlus _ mPlus * scale.
					mMinus _ mMinus * scale.
					scale _ fBase raisedToInteger: (baseExpEstimate + d) negated]
				ifFalse:
				[scale _ fBase raisedToInteger: baseExpEstimate negated].
			s _ s / scale].
	(r + mPlus >= s)
		ifTrue: [baseExpEstimate _ baseExpEstimate + 1]
		ifFalse:
			[s _ s / fBase].
	(fixedFormat _ baseExpEstimate between: -3 and: 6)
		ifTrue:
			[decPointCount _ baseExpEstimate.
			baseExpEstimate <= 0
				ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]]
		ifFalse:
			[decPointCount _ 1].
	[d _ (r / s) truncated.
	r _ r - (d * s).
	(tc1 _ r <= mMinus) | (tc2 _ r + mPlus >= s)] whileFalse:
		[aStream nextPut: (Character digitValue: d).
		r _ r * fBase.
		mPlus _ mPlus * fBase.
		mMinus _ mMinus * fBase.
		decPointCount _ decPointCount - 1.
		decPointCount = 0 ifTrue: [aStream nextPut: $.]].
	tc2 ifTrue:
		[tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d _ d + 1]].
	aStream nextPut: (Character digitValue: d).
	decPointCount > 0
		ifTrue:
		[decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0].
		aStream nextPutAll: '.0'].
	fixedFormat ifFalse:
		[aStream nextPut: $e.
		aStream nextPutAll: (baseExpEstimate - 1) printString]! !

!Float methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:02'!
byteEncode: aStream base: base
	"Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 

	self isNaN ifTrue: [aStream print: 'NaN'. ^ self]. "check for NaN before sign"
	self > 0.0
		ifTrue: [self absByteEncode: aStream base: base]
		ifFalse:
			[self sign = -1
				ifTrue: [aStream print: '-'].
			self = 0.0
				ifTrue: [aStream print: '0.0'. ^ self]
				ifFalse: [aStream writeNumber:self negated base: base]]! !

!Float methodsFor: 'printing'!
hex  "If ya really want to know..."
	| word nibble |
	^ String streamContents:
		[:strm |
		1 to: 2 do:
			[:i | word _ self at: i.
			1 to: 8 do: 
				[:s | nibble _ (word bitShift: -8+s*4) bitAnd: 16rF.
				strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]]
"
(-2.0 to: 2.0) collect: [:f | f hex]
"! !

!Float methodsFor: 'printing' stamp: 'tao 4/19/98 23:31'!
printOn: aStream base: base
	"Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" 

	self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign"
	self > 0.0
		ifTrue: [self absPrintOn: aStream base: base]
		ifFalse:
			[self sign = -1
				ifTrue: [aStream nextPutAll: '-'].
			self = 0.0
				ifTrue: [aStream nextPutAll: '0.0'. ^ self]
				ifFalse: [self negated absPrintOn: aStream base: base]]! !


!Float methodsFor: 'private' stamp: 'ls 10/10/1999 11:55'!
absPrintOn: aStream base: base digitCount: digitCount 
	"Print me in the given base, using digitCount significant figures."

	| fuzz x exp q fBase scale logScale xi |
	self isInf ifTrue: [^ aStream nextPutAll: 'Inf'].
	fBase _ base asFloat.
	"x is myself normalized to [1.0, fBase), exp is my exponent"
	exp _ 
		self < 1.0
			ifTrue: [self reciprocalFloorLog: fBase]
			ifFalse: [self floorLog: fBase].
	scale _ 1.0.
	logScale _ 0.
	[(x _ fBase raisedTo: (exp + logScale)) = 0]
		whileTrue:
			[scale _ scale * fBase.
			logScale _ logScale + 1].
	x _ self * scale / x.
	fuzz _ fBase raisedTo: 1 - digitCount.
	"round the last digit to be printed"
	x _ 0.5 * fuzz + x.
	x >= fBase
		ifTrue: 
			["check if rounding has unnormalized x"
			x _ x / fBase.
			exp _ exp + 1].
	(exp < 6 and: [exp > -4])
		ifTrue: 
			["decimal notation"
			q _ 0.
			exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000'
at: i)]]]
		ifFalse: 
			["scientific notation"
			q _ exp.
			exp _ 0].
	[x >= fuzz]
		whileTrue: 
			["use fuzz to track significance"
			xi _ x asInteger.
			aStream nextPut: (Character digitValue: xi).
			x _ x - xi asFloat * fBase.
			fuzz _ fuzz * fBase.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	[exp >= -1]
		whileTrue: 
			[aStream nextPut: $0.
			exp _ exp - 1.
			exp = -1 ifTrue: [aStream nextPut: $.]].
	q ~= 0
		ifTrue: 
			[aStream nextPut: $e.
			q printOn: aStream]! !

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

Float class
	instanceVariableNames: ''!

!Float class methodsFor: 'class initialization' stamp: 'jm 4/30/1998 13:48'!
initialize
	"Float initialize"
	"Constants from Computer Approximations, pp. 182-183:
		Pi = 3.14159265358979323846264338327950288
		Pi/2 = 1.57079632679489661923132169163975144
		Pi*2 = 6.28318530717958647692528676655900576
		Pi/180 = 0.01745329251994329576923690768488612
		2.0 ln = 0.69314718055994530941723212145817657
		2.0 sqrt = 1.41421356237309504880168872420969808"

	Pi _ 3.14159265358979323846264338327950288.
	Halfpi _ Pi / 2.0.
	Twopi _ Pi * 2.0.
	RadiansPerDegree _ Pi / 180.0.

	Ln2 _ 0.69314718055994530941723212145817657.
	Ln10 _ 10.0 ln.
	Sqrt2 _ 1.41421356237309504880168872420969808.
	E _ 2.718281828459045235360287471353.

	Epsilon _ 0.000000000001.  "Defines precision of mathematical functions"

	MaxVal _ 1.7976931348623159e308.
	MaxValLn _ 709.782712893384.
	MinValLogBase2 _ -1074.

	Infinity _ MaxVal * MaxVal.
	NegativeInfinity _ 0.0 - Infinity.
	NaN _ Infinity - Infinity.
	NegativeZero _ 1.0 / Infinity negated.
! !


!Float class methodsFor: 'instance creation' stamp: 'di 2/8/1999 12:58'!
fromIEEE32Bit: word
	"Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects."
	| sign mantissa exponent newFloat |
	word negative ifTrue: [^ self error:'Cannot deal with negative numbers'].
	word = 0 ifTrue:[^ 0.0].
	mantissa _ word bitAnd:  16r7FFFFF.
	exponent _ ((word bitShift: -23) bitAnd: 16rFF) - 127.
	sign _ word bitAnd: 16r80000000.

	exponent = 128 ifTrue:["Either NAN or INF"
		mantissa = 0 ifFalse:[^ Float nan].
		sign = 0 
			ifTrue:[^ Float infinity]
			ifFalse:[^ Float infinity negated]].

	"Create new float"
	newFloat _ self new: 2.
	newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)).
	newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29).
	^newFloat! !

!Float class methodsFor: 'instance creation'!
readFrom: aStream 
	"Answer a new Float as described on the stream, aStream."

	^(super readFrom: aStream) asFloat! !


!Float class methodsFor: 'constants'!
e
	"Answer the constant, E."

	^E! !

!Float class methodsFor: 'constants' stamp: 'sw 10/8/1999 22:59'!
halfPi
	^ Halfpi! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:37'!
infinity
	"Answer the value used to represent an infinite magnitude"

	^ Infinity! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 11:38'!
nan
	"Answer the canonical value used to represent Not-A-Number"

	^ NaN! !

!Float class methodsFor: 'constants' stamp: 'tao 4/23/98 12:05'!
negativeZero

	^ NegativeZero! !

!Float class methodsFor: 'constants'!
pi
	"Answer the constant, Pi."

	^Pi! !


!Float class methodsFor: 'plugin generation' stamp: 'bf 3/16/2000 19:06'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asFloatValueFrom: anInteger on: aStream! !

!Float class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:05'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToFloatObjectFrom: aNode on: aStream! !

!Float class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToFloatValueFrom: aNode on: aStream! !

!Float class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:08'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asFloatValueFrom: anInteger! !

!Float class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:22'!
ccgCanConvertFrom: anObject

	^anObject class == self! !

!Float class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:09'!
ccgDeclareCForVar: aSymbolOrString

	^'double ', aSymbolOrString! !
ArrayedCollection variableWordSubclass: #FloatArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!FloatArray commentStamp: '<historical>' prior: 0!
FloatArrays store 32bit IEEE floating point numbers.!


!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0.0! !

!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'!
length
	"Return the length of the receiver"
	^self squaredLength sqrt! !

!FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'!
squaredLength
	"Return the squared length of the receiver"
	^self dot: self! !


!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
* anObject
	^self clone *= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'!
*= anObject
	^anObject isNumber
		ifTrue:[self primMulScalar: anObject asFloat]
		ifFalse:[self primMulArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
+ anObject
	^self clone += anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48'!
+= anObject
	^anObject isNumber
		ifTrue:[self primAddScalar: anObject asFloat]
		ifFalse:[self primAddArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'!
- anObject
	^self clone -= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'!
-= anObject
	^anObject isNumber
		ifTrue:[self primSubScalar: anObject asFloat]
		ifFalse:[self primSubArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:34'!
/ anObject
	^self clone /= anObject! !

!FloatArray methodsFor: 'arithmetic' stamp: 'ar 10/7/1998 19:58'!
/= anObject
	^anObject isNumber
		ifTrue:[self primDivScalar: anObject asFloat]
		ifFalse:[self primDivArray: anObject]! !

!FloatArray methodsFor: 'arithmetic' stamp: 'laza 3/24/2000 13:07'!
dot: aFloatVector
	"Primitive. Return the dot product of the receiver and the argument.
	Fail if the argument is not of the same size as the receiver."
	| result |
	"<primitive:'primitiveFloatArrayDotProduct'>"
	self size = aFloatVector size ifFalse:[^self error:'Must be equal size'].
	result _ 0.0.
	1 to: self size do:[:i|
		result _ result + ((self at: i) * (aFloatVector at: i)).
	].
	^result! !


!FloatArray methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'!
= aFloatArray 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	aFloatArray class = self class ifFalse: [^ false].
	length _ self size.
	length = aFloatArray size ifFalse: [^ false].
	1 to: self size do: [:i | (self at: i)
			= (aFloatArray at: i) ifFalse: [^ false]].
	^ true! !

!FloatArray methodsFor: 'comparing' stamp: 'ar 8/31/2000 21:43'!
hash
	| result |
"WARNING: THE PRIMITIVE SEEMS TO BE BROKEN"
	"<primitive:'primitiveFloatArrayHash'>"
	result _ 0.
	1 to: self size do:[:i| result _ result + (self basicAt: i) ].
	^result bitAnd: 16r1FFFFFFF! !


!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primAddArray: floatArray

	<primitive: 'primitiveAddFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primAddScalar: scalarValue

	<primitive: 'primitiveAddScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primDivArray: floatArray

	<primitive: 'primitiveDivFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primDivScalar: scalarValue

	<primitive: 'primitiveDivScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primMulArray: floatArray

	<primitive: 'primitiveMulFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primMulScalar: scalarValue

	<primitive: 'primitiveMulScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primSubArray: floatArray

	<primitive: 'primitiveSubFloatArray' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! !

!FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 2/2/2001 15:47'!
primSubScalar: scalarValue

	<primitive: 'primitiveSubScalar' module: 'FloatArrayPlugin'>
	1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! !



!FloatArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'!
asFloatArray
	^self! !


!FloatArray methodsFor: 'private' stamp: 'ar 10/9/1998 11:27'!
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! !


!FloatArray methodsFor: 'user interface' stamp: 'ar 2/13/1999 21:33'!
inspect
	"Open a OrderedCollectionInspector on the receiver.  Use basicInspect to get a normal (less useful) type of inspector."

	OrderedCollectionInspector openOn: self withEvalPane: true! !

!FloatArray methodsFor: 'user interface' stamp: 'ar 2/13/1999 21:33'!
inspectWithLabel: aLabel
	"Open a OrderedCollectionInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector."

	OrderedCollectionInspector openOn: self withEvalPane: true withLabel: aLabel! !

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

FloatArray class
	instanceVariableNames: ''!


!FloatArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:17'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asFloatPtrFrom: anInteger on: aStream! !

!FloatArray class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:07'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asWBFloatPtrFrom: anInteger! !

!FloatArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:14'!
ccgDeclareCForVar: aSymbolOrString

	^'float *', aSymbolOrString! !
InterpreterPlugin subclass: #FloatArrayPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!FloatArrayPlugin commentStamp: '<historical>' prior: 0!
FloatArrayPlugin defines the basic access messages for FloatArray (e.g., floatAt: and floatAt:put:).!


!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'ar 5/11/2000 23:14'!
primitiveAt

	| index rcvr floatValue floatPtr |
	self export: true.
	self var: #floatValue declareC:'double floatValue'.
	self var: #floatPtr declareC:'float *floatPtr'.
	index _ interpreterProxy stackIntegerValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy success: (index > 0 and:[index <= (interpreterProxy slotSizeOf: rcvr)]).
	interpreterProxy failed ifTrue:[^nil].
	floatPtr _ interpreterProxy firstIndexableField: rcvr.
	floatValue _ (floatPtr at: index-1) asFloat.
	interpreterProxy pop: 2.
	interpreterProxy pushFloat: floatValue.! !

!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'ar 5/11/2000 23:16'!
primitiveAtPut

	| value floatValue index rcvr floatPtr |
	self export: true.
	self var: #floatValue declareC: 'double floatValue'.
	self var: #floatPtr declareC:'float *floatPtr'.
	value _ interpreterProxy stackValue: 0.
	(interpreterProxy isIntegerObject: value)
		ifTrue:[floatValue _ (interpreterProxy integerValueOf: value) asFloat]
		ifFalse:[floatValue _ interpreterProxy floatValueOf: value].
	index _ interpreterProxy stackIntegerValue: 1.
	rcvr _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy success: (index > 0 and:[index <= (interpreterProxy slotSizeOf: rcvr)]).
	interpreterProxy failed ifTrue:[^nil].
	floatPtr _ interpreterProxy firstIndexableField: rcvr.
	floatPtr at: index-1 put: (self cCoerce: floatValue to:'float').
	interpreterProxy failed ifFalse:[interpreterProxy pop: 3 thenPush: value].! !

!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'ar 5/11/2000 23:17'!
primitiveEqual

	| rcvr arg rcvrPtr argPtr length |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 2.
	length _ interpreterProxy stSizeOf: arg.
	length = (interpreterProxy stSizeOf: rcvr) ifFalse:[^interpreterProxy pushBool: false].

	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		(rcvrPtr at: i) = (argPtr at: i) ifFalse:[^interpreterProxy pushBool: false].
	].
	^interpreterProxy pushBool: true! !

!FloatArrayPlugin methodsFor: 'access primitives' stamp: 'ar 5/11/2000 23:16'!
primitiveHash

	| rcvr rcvrPtr length result |
	self export: true.
	self var: #rcvrPtr declareC:'int *rcvrPtr'.
	rcvr _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: rcvr.
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'int *'.
	result _ 0.
	0 to: length-1 do:[:i|
		result _ result + (rcvrPtr at: i).
		rcvrPtr _ rcvrPtr + 4.
	].
	interpreterProxy pop: 1.
	^interpreterProxy pushInteger: (result bitAnd: 16r1FFFFFFF)! !


!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:17'!
primitiveAddFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) + (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:15'!
primitiveAddScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	self export: true.
	self var: #value declareC:'double value'.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	value _ interpreterProxy stackFloatValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: rcvr.
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) + value.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:15'!
primitiveDivFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	"Check if any of the argument's values is zero"
	0 to: length-1 do:[:i|
		(interpreterProxy longAt: (argPtr + i)) = 0 ifTrue:[^interpreterProxy primitiveFail]].
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) / (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:16'!
primitiveDivScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value inverse length |
	self export: true.
	self var: #value declareC:'double value'.
	self var: #inverse declareC:'double inverse'.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	value _ interpreterProxy stackFloatValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	value = 0.0 ifTrue:[^interpreterProxy primitiveFail].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: rcvr.
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	inverse _ 1.0 / value.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * inverse.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:18'!
primitiveDotProduct
	"Primitive. Compute the dot product of the receiver and the argument.
	The dot product is defined as the sum of the products of the individual elements."
	| rcvr arg rcvrPtr argPtr length result |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	self var: #result declareC:'double result'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	result _ 0.0.
	0 to: length-1 do:[:i|
		result _ result + ((rcvrPtr at: i) * (argPtr at: i)).
	].
	interpreterProxy pop: 2. "Pop args + rcvr"
	interpreterProxy pushFloat: result. "Return result"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:15'!
primitiveMulFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:17'!
primitiveMulScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	self export: true.
	self var: #value declareC:'double value'.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	value _ interpreterProxy stackFloatValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: rcvr.
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) * value.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:17'!
primitiveSubFloatArray
	"Primitive. Add the receiver and the argument, both FloatArrays and store the result into the receiver."
	| rcvr arg rcvrPtr argPtr length |
	self export: true.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	self var: #argPtr declareC:'float *argPtr'.
	arg _ interpreterProxy stackObjectValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: arg).
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: arg.
	interpreterProxy success: (length = (interpreterProxy stSizeOf: rcvr)).
	interpreterProxy failed ifTrue:[^nil].
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	argPtr _ self cCoerce: (interpreterProxy firstIndexableField: arg) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) - (argPtr at: i).
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

!FloatArrayPlugin methodsFor: 'arithmetic primitives' stamp: 'ar 5/11/2000 23:17'!
primitiveSubScalar
	"Primitive. Add the argument, a scalar value to the receiver, a FloatArray"
	| rcvr rcvrPtr value length |
	self export: true.
	self var: #value declareC:'double value'.
	self var: #rcvrPtr declareC:'float *rcvrPtr'.
	value _ interpreterProxy stackFloatValue: 0.
	rcvr _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy success: (interpreterProxy isWords: rcvr).
	interpreterProxy failed ifTrue:[^nil].
	length _ interpreterProxy stSizeOf: rcvr.
	rcvrPtr _ self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: 'float *'.
	0 to: length-1 do:[:i|
		rcvrPtr at: i put: (rcvrPtr at: i) - value.
	].
	interpreterProxy pop: 1. "Leave rcvr on stack"! !

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

FloatArrayPlugin class
	instanceVariableNames: ''!


!FloatArrayPlugin class methodsFor: 'translation to C' stamp: 'ar 9/15/1998 00:30'!
declareCVarsIn: cg
	"Nothing to declare..."! !
AlignmentMorph subclass: #FloatingBookControlsMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!FloatingBookControlsMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:40'!
initialize

	super initialize.
	borderWidth _ 1.
	borderColor _ Color black.
	self layoutInset: 0.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.! !

!FloatingBookControlsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/23/2000 12:47'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^23		"page controls are behind menus and balloons, but in front of most other stuff"! !

!FloatingBookControlsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/23/2000 12:48'!
step

	owner == self world ifFalse: [^ self].
	owner addMorphInLayer: self.
! !

!FloatingBookControlsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/23/2000 12:47'!
stepTime

	^1000! !

!FloatingBookControlsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/23/2000 12:47'!
wantsSteps

	^true! !
Object subclass: #FontCache
	instanceVariableNames: 'fonts '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!FontCache commentStamp: '<historical>' prior: 0!
Used by MREncoder and MRDecoder.  It associates an integer index with a number of fonts.  Fonts can be searched by index, and the index can be found for a font that isn't present.  If a font is added to the cache, sometimes the cache will discard another font to make room.!


!FontCache methodsFor: 'initialization' stamp: 'ls 3/27/2000 17:23'!
initialize: cacheSize
	fonts := Array new: cacheSize.! !


!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:28'!
fontAt: index
	"return the font associated with the given index"
	^fonts at: index! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:25'!
includesFont: aFont
	"decide whether the given font is included in the collection"
	^fonts identityIncludes: aFont	! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:28'!
indexForNewFont: aFont
	"add aFont to the cache.  Return its index.  The receiver will sometimes choose an index that is already used; that means that aFont is replacing the other font"
	| index |
	index := fonts size atRandom.      "random is simpler to manage than anything else"
	fonts at: index put: aFont.
	^index! !

!FontCache methodsFor: 'lookups' stamp: 'ls 3/27/2000 17:25'!
indexOf: aFont
	"return the index for a given font"
	^fonts identityIndexOf: aFont! !

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

FontCache class
	instanceVariableNames: ''!

!FontCache class methodsFor: 'instance creation' stamp: 'ls 3/27/2000 17:33'!
new: size
	^super new initialize: size! !
Object subclass: #FontSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!FontSet commentStamp: '<historical>' prior: 0!
FontSet provides a mechanism for storing a set of fonts as a class that can be conveniently filedOut, filedIn, and installed as a TextStyle.

The most common use is...
	Find a font you like.
	Use BitFont to convert a bunch of sizes to data files named, eg, LovelyNN.BF
	Use FontSet convertFontsNamed: 'Lovely' to produce a FontSet named Lovely.
	FileOut that FontSet for later use.
	Use Lovely installAsTextStyle to make all sizes available in a TextStyle
		named #Lovely in the TextConstants dictionary.
	Use ctrl-k in any text pane to select the new Lovely style for that paragraph.
	Then use cmd-1 through 5 or cmd-k to set the point-size for any selection.
!


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

FontSet class
	instanceVariableNames: ''!

!FontSet class methodsFor: 'as yet unclassified' stamp: 'di 9/15/97 12:01'!
convertFontsNamed: familyName  "FontSet convertFontsNamed: 'Palatino' "
	^ self convertFontsNamed: familyName inDirectoryNamed: ''! !


!FontSet class methodsFor: 'private' stamp: 'mdr 8/31/2000 19:18'!
compileFont: strikeFont 
	| tempName literalString header |
	tempName _ 'FontTemp.sf2'.
	strikeFont writeAsStrike2named: tempName.
	literalString _ (FileStream readOnlyFileNamed: tempName) contentsOfEntireFile printString.
	header _ 'sizeNNN
	^ self fontNamed: ''NNN'' fromLiteral:
' copyReplaceAll: 'NNN' with: strikeFont name.
	self class
		compile: header , literalString
		classified: 'fonts'
		notifying: nil.
	FileDirectory default deleteFileNamed: tempName!
]style[(13 10 4 30 4 8 3 14 3 10 22 8 3 13 4 10 20 8 37 6 3 50 17 5 7 10 8 4 18 6 3 13 15 7 14 3 3 13 26 8)f1b,f1cblack;b,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;! !

!FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'!
fontCategory
	^ 'Graphics-Fonts' asSymbol! !

!FontSet class methodsFor: 'private' stamp: 'RAA 6/20/2000 13:29'!
fontName

	self flag: #bob.		"temporary hack until I figure out what's happening here"
	(self name beginsWith: superclass name) ifFalse: [^self name].
	^ (self name copyFrom: superclass name size + 1 to: self name size) asSymbol! !

!FontSet class methodsFor: 'private' stamp: 'sma 12/29/1999 12:58'!
fontSetClass: aString
	| className fontSet |
	className _ (self name , (aString select: [:c | c isAlphaNumeric]) capitalized) asSymbol.
	fontSet _ Smalltalk
		at: className
		ifAbsentPut: [self
			subclass: className
			instanceVariableNames: ''
			classVariableNames: ''
			poolDictionaries: ''
			category: self fontCategory].
	(fontSet inheritsFrom: self) ifFalse: [^ self error: 'The name ' , className , ' is already in use'].
	^ fontSet! !


!FontSet class methodsFor: 'converting' stamp: 'sma 12/29/1999 21:18'!
convertFontsNamed: familyName inDirectoryNamed: dirName
		"FontSet convertFontsNamed: 'Tekton' inDirectoryNamed: 'Tekton Fonts' "
	"This utility is for use after you have used BitFont to produce data files 
	for the fonts you wish to use.  It will read the BitFont files and build
	a fontset class from them.  If one already exists, the sizes that can be
	found will be overwritten."
	"For this utility to work as is, the BitFont data files must be named 'familyNN.BF',
	and must reside in the directory named by dirName (use '' for the current directory)."

	| allFontNames fontSet dir |
	"Check first for matching file names and usable FontSet class name."
	dir _ dirName isEmpty
		ifTrue: [FileDirectory default]
		ifFalse: [FileDirectory default directoryNamed: dirName].
	allFontNames _ dir fileNamesMatching: familyName , '##.BF'.
	allFontNames isEmpty ifTrue: [^ self error: 'No files found like ' , familyName , 'NN.BF'].
	fontSet _ self fontSetClass: familyName.
	allFontNames do:
		[:each |
		Transcript cr; show: each.
		fontSet compileFont: (StrikeFont new readFromBitFont: (dir fullNameFor: each))]! !

!FontSet class methodsFor: 'converting' stamp: 'sma 12/29/1999 12:27'!
convertTextStyleNamed: aString
	| style fontSet |
	(style _ TextStyle named: aString) ifNil: [^ self error: 'unknown text style ' , aString].
	fontSet _ self fontSetClass: aString.
	style fontArray do: [:each | fontSet compileFont: each]! !


!FontSet class methodsFor: 'filein/out' stamp: 'sma 12/29/1999 11:49'!
fileOut
	"FileOut and then change the properties of the file so that it won't be
	treated as text by, eg, email attachment facilities"

	super fileOut.
	(FileStream oldFileNamed: self name , '.st') setFileTypeToObject; close! !


!FontSet class methodsFor: 'installing' stamp: 'sma 12/30/1999 15:01'!
fontNamed: fontName fromLiteral: aString
	"This method allows a font set to be captured as sourcecode in a subclass.
	The string literals will presumably be created by printing, eg,
		(FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile,
		and then pasting into a browser after a heading like, eg,
sizeNewYork10
	^ self fontNamed: 'NewYork10' fromLiteral:
	'--unreadable binary data--'

	See the method installAsTextStyle to see how this can be used."

	^ StrikeFont new 
		name: fontName;
		readFromStrike2Stream: (ReadStream on: aString asByteArray)! !

!FontSet class methodsFor: 'installing' stamp: 'sma 12/30/1999 15:07'!
installAsDefault  "FontSetNewYork installAsDefault"
	(SelectionMenu confirm: 'Do you want to install
''' , self fontName , ''' as default font?')
		ifFalse: [^ self].
	self installAsTextStyle.
	"TextConstants at: #OldDefaultTextStyle put: TextStyle default."
	TextConstants at: #DefaultTextStyle put: (TextStyle named: self fontName).
	ListParagraph initialize.
	PopUpMenu initialize.
	StandardSystemView initialize.
	"SelectionMenu notify: 'The old text style has been saved
as ''OldDefaultTextStyle''.'"! !

!FontSet class methodsFor: 'installing' stamp: 'sma 12/30/1999 15:05'!
installAsTextStyle  "FontSetNewYork installAsTextStyle"
	| selectors |
	(TextConstants includesKey: self fontName) ifTrue:
		[(self confirm: 
self fontName , ' is already defined in TextConstants.
Do you want to replace that definition?')
			ifFalse: [^ self]].
	selectors _ (self class selectors select: [:s | s beginsWith: 'size']) asSortedCollection.
	TextConstants
		at: self fontName
		put: (TextStyle fontArray: (selectors collect: [:each | self perform: each]))! !

!FontSet class methodsFor: 'installing' stamp: 'RAA 6/17/2000 10:16'!
size: pointSize fromLiteral: aString
	"This method allows a font set to be captured as sourcecode in a subclass.
	The string literals will presumably be created by printing, eg,
		(FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile,
		and then pasting into a browser after a heading like, eg,
size24
	^ self size: 24 fromLiteral:
	'--unreadable binary data--'

	See the method installAsTextStyle to see how this can be used."
	"This method is old and for backward compatibility only.
	please use fontNamed:fromLiteral: instead."

	self flag: #bob.		"used in Alan's projects"

	^ StrikeFont new 
		name: self fontName , (pointSize < 10
			ifTrue: ['0' , pointSize printString]
			ifFalse: [pointSize printString]);
		readFromStrike2Stream: ((RWBinaryOrTextStream with: aString) reset; binary)! !


!FontSet class methodsFor: 'compiling' stamp: 'sma 12/29/1999 11:48'!
acceptsLoggingOfCompilation
	"Dont log sources for my subclasses, so as not to waste time
	and space storing printString versions of the string literals."

	^ self == FontSet! !
Object subclass: #Foo2
	instanceVariableNames: 'myInteger '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!Foo2 commentStamp: '<historical>' prior: 0!
Demonstrator class using FooPlugin2!


!Foo2 methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 20:31'!
myInteger: anInteger

	^myInteger _ anInteger! !

!Foo2 methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 20:55'!
primFooIntegerIdentity: x

	<primitive: 'primFooIntegerIdentity' module: 'FooPlugin2'>
	^"FooPlugin2 
		doPrimitive: 'primFooIntegerIdentity:'
		withArguments: {x}" 'Whoops!!'! !

!Foo2 methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 20:55'!
primFooIntegerSeventeen

	<primitive: 'primFooIntegerSeventeen' module: 'FooPlugin2'>
	^"FooPlugin2 
		doPrimitive: 'primFooIntegerSeventeen'
		withArguments: {}" 'Whoops!!'! !

!Foo2 methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 20:55'!
primFooIntegerSumAnd: x with: y

	<primitive: 'primFooIntegerSumAnd' module: 'FooPlugin2'>
	^"FooPlugin2 
		doPrimitive: 'primFooIntegerSumAnd:with:'
		withArguments: {x . y}" 'Whoops!!'! !

!Foo2 methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 20:56'!
primFooIntegerSumWith: x

	<primitive: 'primFooIntegerSumWith' module: 'FooPlugin2'>
	^"FooPlugin2 
		doPrimitive: 'primFooIntegerSumWith:'
		withArguments: {x}" 'Whoops!!'! !
TestInterpreterPlugin subclass: #FooPlugin2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!FooPlugin2 commentStamp: '<historical>' prior: 0!
"TestInterpreter Example: Squeak Swiki named primitive documentation primitives"

FooPlugin2 translate!


!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 09:59'!
primFooIntegerIdentity: x

	self 
		primitive: 	'primFooIntegerIdentity'
		parameters: #(SmallInteger)
		receiver: 	#Oop.

	^ x asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 10:00'!
primFooIntegerSeventeen

	self primitive: 'primFooIntegerSeventeen'
		parameters: #()
		receiver: #Oop.

	^ 17 asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 10:00'!
primFooIntegerSumAnd: x with: y

	self 
		primitive: 	'primFooIntegerSumAnd'
		parameters: #(SmallInteger SmallInteger)
		receiver: 	#Oop.

	^ (x + y) asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 10:00'!
primFooIntegerSumWith: x

	|rcvr myInteger|
	rcvr _ self 
		primitive: 	'primFooIntegerSumWith'
		parameters: #(SmallInteger)
		receiver: 	#Foo2.

	myInteger _ (rcvr asIf: Foo2 var: 'myInteger') asValue: SmallInteger.
	^ (x + myInteger) asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 11:28'!
primNGFooIntegerIdentity: x

	self 
		primitive: 	'primNGFooIntegerIdentity'
		parameters: #(SmallInteger)
		receiver: 	#Oop.
	self suppressFailureGuards: true.

	^ x asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 11:28'!
primNGFooIntegerSeventeen

	self primitive: 'primNGFooIntegerSeventeen'
		parameters: #()
		receiver: #Oop.
	self suppressFailureGuards: true.

	^ 17 asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 11:28'!
primNGFooIntegerSumAnd: x with: y

	self 
		primitive: 	'primNGFooIntegerSumAnd'
		parameters: #(SmallInteger SmallInteger)
		receiver: 	#Oop.
	self suppressFailureGuards: true.

	^ (x + y) asOop: SmallInteger! !

!FooPlugin2 methodsFor: 'as yet unclassified' stamp: 'acg 12/18/1999 11:28'!
primNGFooIntegerSumWith: x

	|rcvr myInteger|
	rcvr _ self 
		primitive: 	'primNGFooIntegerSumWith'
		parameters: #(SmallInteger)
		receiver: 	#Foo2.
	self suppressFailureGuards: true.

	myInteger _ (rcvr asIf: Foo2 var: 'myInteger') asValue: SmallInteger.
	^ (x + myInteger) asOop: SmallInteger! !
DisplayMedium subclass: #Form
	instanceVariableNames: 'bits width height depth offset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!Form commentStamp: '<historical>' prior: 0!
A rectangular array of pixels, used for holding images.  All pictures, including character images are Forms.  The depth of a Form is how many bits are used to specify the color at each pixel.  The actual bits are held in a Bitmap, whose internal structure is different at each depth.  Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap.
	  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.
	Forms are combined using BitBlt.  See the comment in class BitBlt.  Forms that are have both transparent and opaque areas are MaskedForms.  Forms that repeat many times to fill a large destination are InfiniteForms.

	colorAt: x@y		Returns the abstract color at this location
	displayAt: x@y		shows this form on the screen
	displayOn: aMedium at: x@y	shows this form in a Window, a Form, or other DisplayMedium
	fillColor: aColor		Set all the pixels to the color.
	edit		launch an editor to change the bits of this form.
	pixelValueAt: x@y	The encoded color.  Depends on the depth.
!


!Form methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 16:00'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
	^Form extent: extentPoint depth: self depth! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:46'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:45'!
flush
	"If there are any pending operations on the receiver start doing them. In time, they will show up on the receiver but not necessarily immediately after this method returns."! !

!Form methodsFor: 'initialize-release'!
fromDisplay: aRectangle 
	"Create a virtual bit map from a user specified rectangular area on the 
	display screen. Reallocates bitmap only if aRectangle ~= the receiver's 
	extent."

	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].
	self
		copyBits: (aRectangle origin extent: self extent)
		from: Display
		at: 0 @ 0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil! !

!Form methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 18:45'!
shutDown
	"The system is going down. Try to preserve some space"
	self hibernate! !


!Form methodsFor: 'accessing'!
bits
	"Answer the receiver's Bitmap containing its bits."

	^ bits! !

!Form methodsFor: 'accessing'!
bits: aBitmap 
	"Reset the Bitmap containing the receiver's bits."

	bits _ aBitmap! !

!Form methodsFor: 'accessing' stamp: 'tk 3/9/97'!
center
	"Note that offset is ignored here.  Are we really going to embrace offset?  "
	^ (width @ height) // 2! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'!
defaultCanvasClass
	"Return the default canvas used for drawing onto the receiver"
	^Display defaultCanvasClass! !

!Form methodsFor: 'accessing'!
depth
	^ depth! !

!Form methodsFor: 'accessing'!
depth: bitsPerPixel
	(bitsPerPixel > 32 or:
		[(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0])
		ifTrue: [self halt: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32'].
	depth _ bitsPerPixel! !

!Form methodsFor: 'accessing' stamp: 'ar 5/27/2000 16:56'!
displayScreen
	"Return the display screen the receiver is allocated on. 
	Forms in general are Squeak internal and not allocated on any particular display."
	^nil! !

!Form methodsFor: 'accessing'!
extent
	^ width @ height! !

!Form methodsFor: 'accessing'!
form
	"Answer the receiver's form.  For vanilla Forms, this degenerates to self.  Makes several methods that operate on both Forms and MaskedForms much more straightforward.   6/1/96 sw"

	^ self! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:03'!
getCanvas
	"Return a Canvas that can be used to draw onto the receiver"
	^self defaultCanvasClass on: self! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'!
hasBeenModified
	"Return true if something *might* have been drawn into the receiver"
	^(bits == nil or:[bits class == ByteArray]) not
	"Read the above as: If the receiver has forgotten its contents (bits == nil) 
	or is still hibernated it can't be modified."! !

!Form methodsFor: 'accessing' stamp: 'ar 5/28/2000 00:48'!
hasBeenModified: aBool
	"Change the receiver to reflect the modification state"
	aBool ifTrue:[^self unhibernate].
	self shouldPreserveContents
		ifTrue:[self hibernate]
		ifFalse:[bits _ nil]! !

!Form methodsFor: 'accessing'!
height
	^ height! !

!Form methodsFor: 'accessing' stamp: 'ar 2/16/2000 22:00'!
offset
	^offset ifNil:[0@0]! !

!Form methodsFor: 'accessing'!
offset: aPoint

	offset _ aPoint! !

!Form methodsFor: 'accessing'!
size
	"Should no longer be used -- use bitsSize instead.  length of variable part of instance."
	^ super size! !

!Form methodsFor: 'accessing'!
width
	^ width! !


!Form methodsFor: 'copying' stamp: 'jm 11/12/97 19:28'!
as8BitColorForm
	"Simple conversion of zero pixels to transparent.  Force it to 8 bits."

	| f map |
	f _ ColorForm extent: self extent depth: 8.
	self displayOn: f at: self offset negated.
	map _ Color indexedColors copy.
	map at: 1 put: Color transparent.
	f colors: map.
	f offset: self offset.
	^ f
! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:07'!
asFormOfDepth: d
	| newForm |
	d = depth ifTrue:[^self].
	newForm _ Form extent: self extent depth: d.
	(BitBlt current toForm: newForm)
		colorMap: (self colormapIfNeededForDepth: d);
		copy: (self boundingBox)
		from: 0@0 in: self
		fillColor: nil rule: Form over.
	^newForm! !

!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 18:59'!
contentsOfArea: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	^self contentsOfArea: aRect 
		into: (self class extent: aRect extent depth: depth).! !

!Form methodsFor: 'copying' stamp: 'ar 6/9/2000 19:00'!
contentsOfArea: aRect into: newForm
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil! !

!Form methodsFor: 'copying'!
copy: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	| newForm |
	newForm _ self class extent: aRect extent depth: depth.
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil! !

!Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'!
copy: destRectangle from: sourcePt in: sourceForm rule: rule 
	"Make up a BitBlt table and copy the bits."
	(BitBlt current toForm: self)
		copy: destRectangle
		from: sourcePt in: sourceForm
		fillColor: nil rule: rule! !

!Form methodsFor: 'copying'!
copy: sourceRectangle from: sourceForm to: destPt rule: rule
	^ self copy: (destPt extent: sourceRectangle extent)
		from: sourceRectangle topLeft in: sourceForm rule: rule! !

!Form methodsFor: 'copying' stamp: 'jm 2/27/98 09:35'!
deepCopy

	^ self shallowCopy
		bits: bits copy;
		offset: offset copy
! !

!Form methodsFor: 'copying' stamp: 'tk 8/19/1998 16:11'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."
	^ self! !


!Form methodsFor: 'displaying' stamp: 'di 7/1/97 14:06'!
colormapIfNeededForDepth: destDepth
	"Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

	depth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"
	^ Color colorMapIfNeededFrom: depth to: destDepth
! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt current 
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 30
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 _ f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	(BitBlt current 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) copyBits! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map
	"Make up a BitBlt table and copy the bits.  Use a colorMap."

	((BitBlt current 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) colorMap: map) copyBits! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map 
	"Make up a BitBlt table and copy the bits with the given colorMap."
	((BitBlt current 
		destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: Form over
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: self boundingBox) colorMap: map) copyBits! !

!Form methodsFor: 'displaying' stamp: 'RAA 11/21/2000 18:28'!
displayInterpolatedIn: aRectangle on: aForm
	"Display the receiver on aForm, using interpolation if necessary.
		Form fromUser displayInterpolatedOn: Display.
	Note: When scaling we attempt to use bilinear interpolation based
	on the 3D engine. If the engine is not there then we use WarpBlt.
	"
	| engine adjustedR |
	self extent = aRectangle extent ifTrue:[^self displayOn: aForm at: aRectangle origin].
	Smalltalk at: #B3DRenderEngine 
		ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)].
	engine ifNil:[
		"We've got no bilinear interpolation. Use WarpBlt instead"
		(WarpBlt current toForm: aForm)
			sourceForm: self destRect: aRectangle;
			combinationRule: 3;
			cellSize: 2;
			warpBits.
		^self
	].

	"Otherwise use the 3D engine for our purposes"

	"there seems to be a slight bug in B3D which the following adjusts for"
	adjustedR _ (aRectangle withRight: aRectangle right + 1) translateBy: 0@1.
	engine viewport: adjustedR.
	engine material: (B3DMaterial new emission: Color white).
	engine texture: self.
	engine render: (B3DIndexedQuadMesh new plainTextureRect).
	engine finish.! !

!Form methodsFor: 'displaying' stamp: 'ar 6/9/2000 19:13'!
displayInterpolatedOn: aForm
	"Display the receiver on aForm, using interpolation if necessary.
		Form fromUser displayInterpolatedOn: Display.
	Note: When scaling we attempt to use bilinear interpolation based
	on the 3D engine. If the engine is not there then we use WarpBlt.
	"
	| engine |
	self extent = aForm extent ifTrue:[^self displayOn: aForm].
	Smalltalk at: #B3DRenderEngine 
		ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)].
	engine ifNil:[
		"We've got no bilinear interpolation. Use WarpBlt instead"
		(WarpBlt current toForm: aForm)
			sourceForm: self destRect: aForm boundingBox;
			combinationRule: 3;
			cellSize: 2;
			warpBits.
		^self
	].
	"Otherwise use the 3D engine for our purposes"
	engine viewport: aForm boundingBox.
	engine material: (B3DMaterial new emission: Color white).
	engine texture: self.
	engine render: (B3DIndexedQuadMesh new plainTextureRect).
	engine finish.! !

!Form methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm

	aDisplayMedium copyBits: self boundingBox
		from: self
		at: aDisplayPoint + self offset
		clippingBox: clipRectangle
		rule: rule
		fillColor: aForm
		map: (self colormapIfNeededForDepth: aDisplayMedium depth).
! !

!Form methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Graphically, it means nothing to scale a Form by floating point values.  
	Because scales and other display parameters are kept in floating point to 
	minimize round off errors, we are forced in this routine to round off to the 
	nearest integer."

	| absolutePoint scale magnifiedForm |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	displayTransformation noScale
		ifTrue: [magnifiedForm _ self]
		ifFalse: 
			[scale _ displayTransformation scale.
			scale _ scale x @ scale y.
			(1@1 = scale)
					ifTrue: [scale _ nil. magnifiedForm _ self]
					ifFalse: [magnifiedForm _ self magnify: self boundingBox by: scale]].
	magnifiedForm
		displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !

!Form methodsFor: 'displaying'!
displayOnPort: port at: location
	port copyForm: self to: location rule: Form over! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." 
	
	| dotSetter |
	"set up an instance of BitBlt for display"
	dotSetter _ BitBlt current
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: anInteger
		destOrigin: beginPoint
		sourceOrigin: 0 @ 0
		extent: sourceForm extent
		clipRect: clipRect.
	dotSetter drawFrom: beginPoint to: endPoint! !

!Form methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:08'!
paintBits: sourceForm at: destOrigin translucent: factor
	"Make up a BitBlt table and copy the bits with the given colorMap."
	(BitBlt current destForm: self
		sourceForm: sourceForm
		halftoneForm: nil
		combinationRule: 31
		destOrigin: destOrigin
		sourceOrigin: 0@0
		extent: sourceForm extent
		clipRect: self boundingBox)
		copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255)
"
 | f f2 f3 | f _ Form fromUser. f replaceColor: f peripheralColor withColor: Color transparent.
f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 deepCopy.
0.0 to: 1.0 by: 1.0/32 do:
	[:t | f3 _ f2 deepCopy. f3 paintBits: f at: 0@0 translucent: t.
	f3 displayAt: 0@0. (Delay forMilliseconds: 100) wait].
"! !

!Form methodsFor: 'displaying' stamp: 'di 9/12/2000 10:04'!
setAsBackground
	"Set this form as a background image."

	| world newColor |
	Smalltalk isMorphic 
		ifTrue:
			[world _ self currentWorld.
			newColor _ InfiniteForm with: self.
			self rememberCommand:
				(Command new cmdWording: 'set background to a picture';
					undoTarget: world selector: #color: argument: world color;
					redoTarget: world selector: #color: argument: newColor).
			world color: newColor]
		ifFalse:
			[ScheduledControllers screenController model form: self.
			Display restoreAfter: []]! !


!Form methodsFor: 'display box access'!
boundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !

!Form methodsFor: 'display box access'!
computeBoundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !


!Form methodsFor: 'filling' stamp: 'di 2/19/1999 07:07'!
anyShapeFill
	"Fill the interior of the outermost outlined region in the receiver, a 1-bit deep form.  Typically the resulting form is used with fillShape:fillColor: to paint a solid color.  See also convexShapeFill:"

	| shape |
	"Draw a seed line around the edge and fill inward from the outside."
	shape _ self findShapeAroundSeedBlock: [:f | f borderWidth: 1].
	"Reverse so that this becomes solid in the middle"
	shape _ shape reverse.
	"Finally erase any bits from the original so the fill is only elsewhere"
	shape copy: shape boundingBox from: self to: 0@0 rule: Form erase.
	^ shape! !

!Form methodsFor: 'filling'!
bitPatternForDepth: suspectedDepth
	"Only called when a Form is being used as a fillColor.  Use a Pattern or InfiniteForm instead for this purpose.
	Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self! !

!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!
colorAt: aPoint
	"Return the color in the pixel at the given point.  "

	^ Color 
		colorFromPixelValue: (self pixelValueAt: aPoint)
		depth: depth
! !

!Form methodsFor: 'filling' stamp: 'tk 6/20/96'!
colorAt: aPoint put: aColor
	"Store a Color into the pixel at coordinate aPoint.  "

	self pixelValueAt: aPoint put: (aColor pixelValueForDepth: depth).

"[Sensor anyButtonPressed] whileFalse:
	[Display colorAt: Sensor cursorPoint put: Color red]"
! !

!Form methodsFor: 'filling' stamp: 'di 9/11/1998 16:25'!
convexShapeFill: aMask 
	"Fill the interior of the outtermost outlined region in the receiver.  The outlined region must not be concave by more than 90 degrees.  Typically aMask is Color black, to produce a solid fill. then the resulting form is used with fillShape: to paint a solid color.  See also anyShapeFill"
	| destForm tempForm |
	destForm _ Form extent: self extent.  destForm fillBlack.
	tempForm _ Form extent: self extent.
	(0@0) fourNeighbors do:
		[:dir |  "Smear self in all 4 directions, and AND the result"
		self displayOn: tempForm at: (0@0) - self offset.
		tempForm smear: dir distance: (dir dotProduct: tempForm extent) abs.
		tempForm displayOn: destForm at: 0@0
			clippingBox: destForm boundingBox
			rule: Form and fillColor: nil].
	destForm displayOn: self at: 0@0
		clippingBox: self boundingBox
		rule: Form over fillColor: aMask! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by aForm 
	according to the rule anInteger."
	(BitBlt current toForm: self)
		copy: aRectangle
		from: 0@0 in: nil
		fillColor: aForm rule: anInteger! !

!Form methodsFor: 'filling'!
fillFromXColorBlock: colorBlock
	"Horizontal Gradient Fill.
	Supply relative x in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| xRel |
	0 to: width-1 do:
		[:x |  xRel _ x asFloat / (width-1) asFloat.
		self fill: (x@0 extent: 1@height) 
			fillColor: (colorBlock value: xRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
fillFromXYColorBlock: colorBlock
	"General Gradient Fill.
	Supply relative x and y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| poker yRel xRel |
	poker _ BitBlt current bitPokerToForm: self.
	0 to: height-1 do:
		[:y | yRel _ y asFloat / (height-1) asFloat.
		0 to: width-1 do:
			[:x |  xRel _ x asFloat / (width-1) asFloat.
			poker pixelAt: x@y
				put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: depth)]]
"
 | d |
((Form extent: 100@20 depth: Display depth)
	fillFromXYColorBlock:
	[:x :y | d _ 1.0 - (x - 0.5) abs - (y - 0.5) abs.
	Color r: d g: 0 b: 1.0-d]) display
"! !

!Form methodsFor: 'filling'!
fillFromYColorBlock: colorBlock
	"Vertical Gradient Fill.
	Supply relative y in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| yRel |
	0 to: height-1 do:
		[:y |  yRel _ y asFloat / (height-1) asFloat.
		self fill: (0@y extent: width@1) 
			fillColor: (colorBlock value: yRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display
"! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
findShapeAroundSeedBlock: seedBlock
	"Build a shape that is black in any region marked by seedBlock. 
	SeedBlock will be supplied a form, in which to blacken various
	pixels as 'seeds'.  Then the seeds are smeared until 
	there is no change in the smear when it fills the region, ie,
	when smearing hits a black border and thus goes no further."
	| smearForm previousSmear all count smearPort |
	depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."
	all _ self boundingBox.
	smearForm _ Form extent: self extent.
	smearPort _ BitBlt current toForm: smearForm.
	seedBlock value: smearForm.		"Blacken seeds to be smeared"
	smearPort copyForm: self to: 0@0 rule: Form erase.  "Clear any in black"
	previousSmear _ smearForm deepCopy.
	count _ 1.
	[count = 10 and:   "check for no change every 10 smears"
		[count _ 1.
		previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse.
		previousSmear isAllWhite]]
		whileFalse: 
			[smearPort copyForm: smearForm to: 1@0 rule: Form under.
			smearPort copyForm: smearForm to: -1@0 rule: Form under.
			"After horiz smear, trim around the region border"
			smearPort copyForm: self to: 0@0 rule: Form erase.
			smearPort copyForm: smearForm to: 0@1 rule: Form under.
			smearPort copyForm: smearForm to: 0@-1 rule: Form under.
			"After vert smear, trim around the region border"
			smearPort copyForm: self to: 0@0 rule: Form erase.
			count _ count+1.
			count = 9 ifTrue: "Save penultimate smear for comparison"
				[previousSmear copy: all from: 0@0 in: smearForm rule: Form over]].
	"Now paint the filled region in me with aHalftone"
	^ smearForm! !

!Form methodsFor: 'filling' stamp: 'ar 12/19/2000 01:17'!
floodFill2: aColor at: interiorPoint
	"Fill the shape (4-connected) at interiorPoint.  The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990.
	NOTE: This is a less optimized variant for flood filling which is precisely along the lines of Heckbert's algorithm. For almost all cases #floodFill:at: will be faster (see the comment there) but this method is left in both as reference and as a fallback if such a strange case is encountered in reality."
	| peeker poker stack old new x y top x1 x2 dy left goRight |
	peeker _ BitBlt current bitPeekerFromForm: self.
	poker _ BitBlt current bitPokerToForm: self.
	stack _ OrderedCollection new: 50.
	"read old pixel value"
	old _ peeker pixelAt: interiorPoint.
	"compute new value"
	new _ aColor pixelValueForDepth: self depth.
	old = new ifTrue:[^self]. "no point, is there?!!"

	x _ interiorPoint x.
	y _ interiorPoint y.
	(y >= 0 and:[y < height]) ifTrue:[
		stack addLast: {y. x. x. 1}. "y, left, right, dy"
		stack addLast: {y+1. x. x. -1}].
	[stack isEmpty] whileFalse:[
		top _ stack removeLast.
		y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4.
		y _ y + dy.
		"Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled.
		Now explore adjacent pixels in scanline y."
		x _ x1.
		[x >= 0 and:[(peeker pixelAt: x@y) = old]] whileTrue:[
			poker pixelAt: x@y put: new.
			x _ x - 1].
		goRight _ x < x1.
		left _ x+1.
		(left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 
			ifTrue:[stack addLast: {y. left. x1-1. 0-dy}].
		goRight ifTrue:[x _ x1 + 1].
		[
			goRight ifTrue:[
				[x < width and:[(peeker pixelAt: x@y) = old]] whileTrue:[
					poker pixelAt: x@y put: new.
					x _ x + 1].
				(y+dy >= 0 and:[y+dy < height]) 
					ifTrue:[stack addLast: {y. left. x-1. dy}].
				(x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 
					ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]].
			[(x _ x + 1) <= x2 and:[(peeker pixelAt: x@y) ~= old]] whileTrue.
			left _ x.
			goRight _ true.
		x <= x2] whileTrue.
	].
! !

!Form methodsFor: 'filling' stamp: 'ar 12/19/2000 16:37'!
floodFill: aColor at: interiorPoint
	"Fill the shape (4-connected) at interiorPoint.  The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990.
	NOTE: This variant has been heavily optimized to prevent the overhead of repeated calls to BitBlt. Usually this is a really big winner but the runtime now depends a bit on the complexity of the shape to be filled. For extremely complex shapes (say, a Hilbert curve) with very few pixels to fill it can be slower than #floodFill2:at: since it needs to repeatedly read the source bits. However, in all practical cases I found this variant to be 15-20 times faster than anything else."
	| peeker poker stack old new x y top x1 x2 dy left goRight span spanBits w box debug |
	debug _ false. "set it to true to see the filling process"
	box _ interiorPoint extent: 1@1.
	span _ Form extent: width@1 depth: 32.
	span unhibernate.
	spanBits _ span bits.

	peeker _ BitBlt current toForm: span.
	peeker 
		sourceForm: self; 
		combinationRule: 3; 
		width: width; 
		height: 1.

	poker _ BitBlt current toForm: self.
	poker 
		fillColor: aColor;
		combinationRule: 3;
		width: width;
		height: 1.

	stack _ OrderedCollection new: 50.

	"read old pixel value"
	peeker sourceOrigin: interiorPoint; destOrigin: interiorPoint x @ 0; width: 1; copyBits.
	old _ spanBits at: interiorPoint x + 1.

	"compute new value (accuracy is important since the algorithm will fail if old = new)"
	new _ self privateFloodFillValue: aColor.
	old = new ifTrue:[^box].

	x _ interiorPoint x.
	y _ interiorPoint y.
	(y >= 0 and:[y < height]) ifTrue:[
		stack addLast: {y. x. x. 1}. "y, left, right, dy"
		stack addLast: {y+1. x. x. -1}].
	[stack isEmpty] whileFalse:[
		debug ifTrue:[self displayOn: Display].
		top _ stack removeLast.
		y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4.
		y _ y + dy.
		debug ifTrue:[
			(Line from: (x1-1)@y to: (x2+1)@y 
				withForm: (Form extent: 1@1 depth: 8) fillWhite) displayOn: Display].
		"Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled.
		Now explore adjacent pixels in scanline y."
		peeker sourceOrigin: 0@y; destOrigin: 0@0; width: width; copyBits.
			"Note: above is necessary since we don't know where we'll end up filling"
		x _ x1.
		w _ 0.
		[x >= 0 and:[(spanBits at: x+1) = old]] whileTrue:[
			w _ w + 1.
			x _ x - 1].
		w > 0 ifTrue:[
			"overwrite pixels"
			poker destOrigin: x+1@y; width: w; copyBits.
			box _ box quickMerge: ((x+1@y) extent: w@1)].
		goRight _ x < x1.
		left _ x+1.
		(left < x1 and:[y-dy >= 0 and:[y-dy < height]]) 
			ifTrue:[stack addLast: {y. left. x1-1. 0-dy}].
		goRight ifTrue:[x _ x1 + 1].
		[
			goRight ifTrue:[
				w _ 0.
				[x < width and:[(spanBits at: x+1) = old]] whileTrue:[
					w _ w + 1.
					x _ x + 1].
				w > 0 ifTrue:[
					"overwrite pixels"
					poker destOrigin: (x-w)@y; width: w; copyBits.
					box _ box quickMerge: ((x-w@y) extent: w@1)].
				(y+dy >= 0 and:[y+dy < height]) 
					ifTrue:[stack addLast: {y. left. x-1. dy}].
				(x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) 
					ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]].
			[(x _ x + 1) <= x2 and:[(spanBits at: x+1) ~= old]] whileTrue.
			left _ x.
			goRight _ true.
		x <= x2] whileTrue.
	].
	^box! !

!Form methodsFor: 'filling' stamp: 'di 3/2/98 12:42'!
isAllWhite
	"Answer whether all bits in the receiver are white (=0)."

	self unhibernate.
	1 to: bits size do: [:i | (bits at: i) = 0 ifFalse: [^ false]].
	^ true! !

!Form methodsFor: 'filling'!
isTransparentAt: aPoint 
	"Return true if the receiver is transparent at the given point."

	depth = 1 ifTrue: [^ false].  "no transparency at depth 1"
	^ (self pixelValueAt: aPoint) = (Color transparent pixelValueForDepth: depth)
! !

!Form methodsFor: 'filling'!
makeBWForm: foregroundColor
	"Map this form into a B/W form with 1's in the foreground regions."
	| bwForm map |
	bwForm _ Form extent: self extent.
	map _ self newColorMap.  "All non-foreground go to 0's"
	map at: (foregroundColor indexInMap: map) put: 1.
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
	^ bwForm! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
pixelValueAt: aPoint 
	"Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color.  "

	^ (BitBlt current bitPeekerFromForm: self) pixelAt: aPoint
! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:08'!
pixelValueAt: aPoint put: pixelValue
	"Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. "

	(BitBlt current bitPokerToForm: self) pixelAt: aPoint put: pixelValue.
! !

!Form methodsFor: 'filling' stamp: 'ar 5/28/2000 12:09'!
shapeFill: aColor interiorPoint: interiorPoint
	"Identify the shape (region of identical color) at interiorPoint,
	and then fill that shape with the new color, aColor
	: modified di's original method such that it returns the bwForm, for potential use by the caller"

	| bwForm interiorPixVal map ppd color ind |
	depth = 1 ifTrue:
		[^ self shapeFill: aColor
			seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]].

	"First map this form into a B/W form with 0's in the interior region."
	interiorPixVal _ self pixelValueAt: interiorPoint.
	bwForm _ Form extent: self extent.
	map _ Bitmap new: (1 bitShift: (depth min: 12)).  "Not calling newColorMap.  All 
			non-foreground go to 0.  Length is 2 to 4096."
	ppd _ depth.	"256 long color map in depth 8 is not one of the following cases"
	3 to: 5 do: [:bitsPerColor | 
		(2 raisedTo: bitsPerColor*3) = map size 
			ifTrue: [ppd _ bitsPerColor*3]].	"ready for longer maps than 512"

	ppd <= 8
		ifTrue: [map at: interiorPixVal+1 put: 1]
		ifFalse: [interiorPixVal = 0 
			ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth.
				ind _ color pixelValueForDepth: ppd.
				map at: ind+1 put: 1]
			ifTrue: [map at: 1 put: 1]].
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
		"bwForm _ self makeBWForm: interiorColor."	"not work for two whites"
	bwForm reverse.  "Make interior region be 0's"

	"Now fill the interior region and return that shape"
	bwForm _ bwForm findShapeAroundSeedBlock:
					[:form | form pixelValueAt: interiorPoint put: 1].

	"Finally use that shape as a mask to flood the region with color"
	((BitBlt current destForm: self sourceForm: bwForm 
		fillColor: nil
		combinationRule: Form erase1bitShape	"Cut a hole in the picture with my mask"
		destOrigin: bwForm offset 
		sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits.
	self fillShape: bwForm fillColor: aColor.
	^ bwForm! !

!Form methodsFor: 'filling'!
shapeFill: aColor seedBlock: seedBlock
	depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms'].
	(self findShapeAroundSeedBlock: seedBlock)
		displayOn: self at: 0@0 clippingBox: self boundingBox
		rule: Form under fillColor: aColor ! !


!Form methodsFor: 'bordering' stamp: 'ar 5/28/2000 12:07'!
border: rect width: borderWidth rule: rule fillColor: fillColor
        "Paint a border whose rectangular area is defined by rect. The
width of the border of each side is borderWidth. Uses fillColor for drawing
the border."
        | blt |
        blt _ (BitBlt current toForm: self) combinationRule: rule; fillColor: fillColor.
        blt sourceOrigin: 0@0.
        blt destOrigin: rect origin.
        blt width: rect width; height: borderWidth; copyBits.
        blt destY: rect corner y - borderWidth; copyBits.
        blt destY: rect origin y + borderWidth.
        blt height: rect height - borderWidth - borderWidth; width:
borderWidth; copyBits.
        blt destX: rect corner x - borderWidth; copyBits! !

!Form methodsFor: 'bordering' stamp: 'ar 5/28/2000 12:07'!
borderFormOfWidth: borderWidth sharpCorners: sharpen
	"Smear this form around and then subtract the original to produce
	an outline.  If sharpen is true, then cause right angles to be outlined
	by right angles (takes an additional diagonal smears ANDed with both
	horizontal and vertical smears)."
	| smearForm bigForm smearPort all cornerForm cornerPort nbrs |
	depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."
	bigForm _ self deepCopy.
	all _ bigForm boundingBox.
	smearForm _ Form extent: self extent.
	smearPort _ BitBlt current toForm: smearForm.
	sharpen ifTrue:
		[cornerForm _ Form extent: self extent.
		cornerPort _ BitBlt current toForm: cornerForm].
	nbrs _ (0@0) fourNeighbors.
	1 to: borderWidth do:
		[:i |  "Iterate to get several layers of 'skin'"
		nbrs do:
			[:d |  "Smear the self in 4 directions to grow each layer of skin"
			smearPort copyForm: bigForm to: d rule: Form under].
		sharpen ifTrue:
			["Special treatment to smear sharp corners"
			nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do:
				[:d1 :d2 |
				"Copy corner points diagonally"
				cornerPort copyForm: bigForm to: d1+d2 rule: Form over.
				"But only preserve if there were dots on either side"
				cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and.
				cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and.
				smearPort copyForm: cornerForm to: 0@0 rule: Form under].
			].
		bigForm copy: all from: 0@0 in: smearForm rule: Form over.
		].
	"Now erase the original shape to obtain the outline"
	bigForm copy: all from: 0@0 in: self rule: Form erase.
	^ bigForm! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger 
	"Set the width of the border for the receiver to be anInteger and paint it 
	using black as the border color."

	self border: self boundingBox width: anInteger fillColor: Color black! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger color: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger fillColor: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'bordering'!
shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint
	sharpCorners: sharpen internal: internal
	"Identify the shape (region of identical color) at interiorPoint,
	and then add an outline of width=borderWidth and color=aColor.
	If sharpen is true, then cause right angles to be outlined by
	right angles.  If internal is true, then produce a border that lies
	within the identified shape.  Thus one can put an internal border
	around the whole background, thus effecting a normal border
	around every other foreground image."
	| shapeForm borderForm interiorColor |
	"First identify the shape in question as a B/W form"
	interiorColor _ self colorAt: interiorPoint.
	shapeForm _ (self makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:form | form pixelValueAt: interiorPoint put: 1].
	"Reverse the image to grow the outline inward"
	internal ifTrue: [shapeForm reverse].
	"Now find the border fo that shape"
	borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen.
	"Finally use that shape as a mask to paint the border with color"
	self fillShape: borderForm fillColor: aColor! !


!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/28/2000 12:12'!
flipBy: direction centerAt: aPoint
	"Return a copy of the receiver flipped either #vertical or #horizontal."
	| newForm quad |
	newForm _ self class extent: self extent depth: depth.
	quad _ self boundingBox innerCorners.
	quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)])
		collect: [:i | quad at: i].
	(WarpBlt current toForm: newForm)
		sourceForm: self;
		colorMap: (self colormapIfNeededForDepth: depth);
		combinationRule: 3;
		copyQuad: quad toRect: newForm boundingBox.
	newForm offset: (self offset flipBy: direction centerAt: aPoint).
	^ newForm
"
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
			flipBy: #vertical centerAt: 0@0) display]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f flipBy: #vertical centerAt: 0@0.
	(f2 flipBy: #vertical centerAt: 0@0) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation'!
magnify: aRectangle by: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float, and may be greater or less than 1.0."
	^ self magnify: aRectangle by: scale smoothing: 1

"Dynamic test...
[Sensor anyButtonPressed] whileFalse:
	[(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display]
"
"Scaling test...
| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).
Display restoreAfter: [Sensor waitNoButton.
[Sensor anyButtonPressed] whileFalse:
	[cp _ Sensor cursorPoint.
	(f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f magnify: f boundingBox by: 5@3.
	(f2 shrink: f2 boundingBox by: 5@3) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/28/2000 12:12'!
magnify: aRectangle by: scale smoothing: cellSize
        "Answer a Form created as a scaling of the receiver.
        Scale may be a Float, and may be greater or less than 1.0."
        | newForm |
        newForm _ self blankCopyOf: aRectangle scaledBy: scale.
        (WarpBlt current toForm: newForm)
                sourceForm: self;
                colorMap: (self colormapIfNeededForDepth: depth);
                cellSize: cellSize;  "installs a new colormap if cellSize > 1"
                combinationRule: 3;
                copyQuad: aRectangle innerCorners toRect: newForm boundingBox.
        ^ newForm

"Dynamic test...
[Sensor anyButtonPressed] whileFalse:
        [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display]
"
"Scaling test...
| f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100).
Display restoreAfter: [Sensor waitNoButton.
[Sensor anyButtonPressed] whileFalse:
        [cp _ Sensor cursorPoint.
        (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]]
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'di 8/17/1998 22:17'!
magnifyBy: scale 
	"Answer a Form created as a scaling of the receiver.
	Scale may be a Float, and may be greater or less than 1.0."

	^ self magnify: self boundingBox by: scale
			smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! !

!Form methodsFor: 'scaling, rotation'!
rotateBy: deg
	"Rotate the receiver by the indicated number of degrees."
	"rot is the destination form, bit enough for any angle."

	^ self rotateBy: deg smoothing: 1
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5)) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/28/2000 12:12'!
rotateBy: direction centerAt: aPoint
	"Return a rotated copy of the receiver. 
	direction = #none, #right, #left, or #pi"
	| newForm quad rot |
	direction == #none ifTrue: [^ self].
	newForm _ self class extent: (direction = #pi ifTrue: [width@height]
											ifFalse: [height@width]) depth: depth.
	quad _ self boundingBox innerCorners.
	rot _ #(right pi left) indexOf: direction.
	(WarpBlt current toForm: newForm)
		sourceForm: self;
		colorMap: (self colormapIfNeededForDepth: depth);
		combinationRule: 3;
		copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i])
			 toRect: newForm boundingBox.
	newForm offset: (self offset rotateBy: direction centerAt: aPoint).
	^ newForm
"
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: #left centerAt: 0@0) display]
"
"Consistency test...
 | f f2 p | [Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41).
	Display fillBlack: (p extent: 31@41).
	f2 _ f rotateBy: #left centerAt: 0@0.
	(f2 rotateBy: #right centerAt: 0@0) displayAt: p]
"
! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/28/2000 12:12'!
rotateBy: deg magnify: scale smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees and magnify.  "
	"rot is the destination form, big enough for any angle."

	| side rot warp r1 pts p bigSide |
	side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.
	bigSide _ (side * scale) rounded.
	rot _ Form extent: bigSide@bigSide depth: self depth.
	warp _ (WarpBlt current toForm: rot)
		sourceForm: self;
		colorMap: (self colormapIfNeededForDepth: depth);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint.
	r1 _ (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center.

	"Rotate the corners of the source rectangle." 
	pts _ r1 innerCorners collect:
		[:pt | p _ pt - r1 center.
		(r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @
		(r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].
	warp copyQuad: pts toRect: rot boundingBox.
	^ rot
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5) magnify: 0.75 smoothing: 2) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'sw 8/9/96'!
rotateBy: deg rotationCenter: aPoint
	"Rotate the receiver by the indicated number of degrees.  This variant gets a rotation center, but in fact ignores the thing -- awaiting someone's doing the right thing.   
	Note that rotationCenter should now be easy to include in the offset of the resulting form -- see <Point> rotateBy: angle about: center.  Could be even faster by sharing the sin, cos inside rotateBy:.  This should really be reversed so that this becomes the workhorse, and rotateBy: calls this with rotationCenter: self boundingBox center.  And while we're at it, why not include scaling?   "

	^ self rotateBy: deg smoothing: 1! !

!Form methodsFor: 'scaling, rotation' stamp: 'ar 5/28/2000 12:12'!
rotateBy: deg smoothing: cellSize
	"Rotate the receiver by the indicated number of degrees."
	"rot is the destination form, bit enough for any angle."
	| side rot warp r1 pts p center |
	side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger.
	rot _ Form extent: side@side depth: self depth.
	center _ rot extent // 2.

	"Now compute the sin and cos constants for the rotation angle." 
	warp _ (WarpBlt current toForm: rot)
		sourceForm: self;
		colorMap: (self colormapIfNeededForDepth: depth);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form over.
	r1 _ rot boundingBox align: center with: self boundingBox center.

	pts _ r1 innerCorners collect:
		[:pt | p _ pt - r1 center.
		(r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @
		(r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))].
	warp copyQuad: pts toRect: rot boundingBox.
	^ rot
"
 | a f |  f _ Form fromDisplay: (0@0 extent: 200@200).  a _ 0.
[Sensor anyButtonPressed] whileFalse:
	[((Form fromDisplay: (Sensor cursorPoint extent: 130@66))
		rotateBy: (a _ a+5) smoothing: 2) display].
f display
"! !

!Form methodsFor: 'scaling, rotation' stamp: 'RAA 7/13/2000 12:09'!
scaledToSize: newExtent

	| scale |

	newExtent = self extent ifTrue: [^self].
	scale _ newExtent x / self width min: newExtent y / self height.
	^self magnify: self boundingBox by: scale smoothing: 2.
! !

!Form methodsFor: 'scaling, rotation'!
shrink: aRectangle by: scale 
	| scalePt |
	scalePt _ scale asPoint.
	^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! !


!Form methodsFor: 'editing' stamp: 'bf 10/11/1999 15:38'!
bitEdit
	"Create and schedule a view located in an area designated by the user 
	that contains a view of the receiver magnified by 8@8 that can be 
	modified using the Bit Editor. It also contains a view of the original 
	form."

	Smalltalk isMorphic
		ifFalse: [BitEditor openOnForm: self]
		ifTrue: [self currentHand attachMorph: (FatBitsPaint new
			editForm: self;
			magnification: 8;
			brushColor: Color black;
			penSize: 1;
			yourself)].

	"Note that using direct messages to BitEditor, fixed locations and scales can be created.
	That is, also try:
		BitEditor openOnForm: self at: <some point>
		BitEditor openOnForm: self at: <some point> scale: <some point>"! !

!Form methodsFor: 'editing'!
bitEditAt: magnifiedFormLocation scale: scaleFactor 
	"Create and schedule a view whose top left corner is magnifiedLocation 
	and that contains a view of the receiver magnified by scaleFactor that 
	can be modified using the Bit Editor. It also contains a view of the 
	original form."

	BitEditor openOnForm: self at: magnifiedFormLocation scale: scaleFactor ! !

!Form methodsFor: 'editing'!
edit
	"Start up an instance of the FormEditor on this form. Typically the form 
	is not visible on the screen. The editor menu is located at the bottom of 
	the form editing frame. The form is displayed centered in the frame. 
	YellowButtonMenu accept is used to modify the form to reflect the 
	changes made on the screen version; cancel restores the original form to 
	the screen. Note that the changes are clipped to the original size of the 
	form."
 
	FormEditor openOnForm: self! !

!Form methodsFor: 'editing' stamp: 'RAA 9/28/1999 09:11'!
morphEdit

        ^ FatBitsPaint new openWith: self! !


!Form methodsFor: 'image manipulation'!
cgForPixelValue: pv orNot: not
	"Return the center of gravity for all pixels of value pv.
	Note:  If orNot is true, then produce the center of gravity for all pixels
	that are DIFFERENT from the supplied (background) value"
	| pixCount weighted xAndY |
	xAndY _ (Array with: (self xTallyPixelValue: pv orNot: not)
					with: (self yTallyPixelValue: pv orNot: not)) collect:
		[:profile |	"For both x and y profiles..."
		pixCount _ 0.  weighted _ 0.
		profile doWithIndex:
			[:t :i | pixCount _ pixCount + t.
			weighted _ weighted + (t*i)].
		pixCount = 0  "Produce average of nPixels weighted by coordinate"
			ifTrue: [0.0]
			ifFalse: [weighted asFloat / pixCount asFloat - 1.0]].

	^ xAndY first @ xAndY last
"
| f cg |
[Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: (Sensor cursorPoint extent: 50@50).
	cg _ f cgForPixelValue: (Color black pixelValueForDepth: f depth) orNot: false.
	f displayAt: 0@0.
	Display fill: (cg extent: 2@2) fillColor: Color red].
	ScheduledControllers restore
"! !

!Form methodsFor: 'image manipulation' stamp: 'bf 10/12/1999 18:07'!
dominantColor
	| tally max maxi |
	depth > 16 ifTrue:
		[^(self asFormOfDepth: 16) dominantColor].
	tally _ self tallyPixelValues.
	max _ maxi _ 0.
	tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]].
	^ Color colorFromPixelValue: maxi - 1 depth: depth! !

!Form methodsFor: 'image manipulation'!
innerPixelRectFor: pv orNot: not
	"Return a rectangle describing the smallest part of me that includes 
	all pixels of value pv.
	Note:  If orNot is true, then produce a copy that includes all pixels
	that are DIFFERENT from the supplied (background) value"

	| xTally yTally |
	xTally _ self xTallyPixelValue: pv orNot: not.
	yTally _ self yTallyPixelValue: pv orNot: not.
	^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1)
		corner:
			(xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])! !

!Form methodsFor: 'image manipulation' stamp: 'ar 7/23/1999 17:04'!
orderedDither32To16
	"Do an ordered dithering for converting from 32 to 16 bit depth."
	| ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex |
	self depth = 32 ifFalse:[^self error:'Must be 32bit for this'].
	ditherMatrix _ #(	0	8	2	10
						12	4	14	6
						3	11	1	9
						15	7	13	5).
	ii _ (0 to: 31) collect:[:i| i].
	out _ Form extent: self extent depth: 16.
	inBits _ self bits.
	outBits _ out bits.
	index _ outIndex _ 0.
	pvOut _ 0.
	0 to: self height-1 do:[:y|
		0 to: self width-1 do:[:x|
			pv _ inBits at: (index _ index + 1).
			dmv _ ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1.
			r _ pv bitAnd: 255.	di _ r * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			r _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			g _ (pv bitShift: -8) bitAnd: 255.	di _ g * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			g _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			b _ (pv bitShift: -16) bitAnd: 255.	di _ b * 496 bitShift: -8.
			dmi _ di bitAnd: 15.	dmo _ di bitShift: -4.
			b _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo].
			pvOut _ (pvOut bitShift: 16) + 
						(b bitShift: 10) + (g bitShift: 5) + r.
			(x bitAnd: 1) = 1 ifTrue:[
				outBits at: (outIndex _ outIndex+1) put: pvOut.
				pvOut _ 0].
		].
		(self width bitAnd: 1) = 1 ifTrue:[
			outBits at: (outIndex _ outIndex+1) put: (pvOut bitShift: -16).
			pvOut _ 0].
	].
	^out! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:08'!
pixelCompare: aRect with: otherForm at: otherLoc
	"Compare the selected bits of this form (those within aRect) against
	those in a similar rectangle of otherFrom.  Return the sum of the
	absolute value of the differences of the color values of every pixel.
	Obviously, this is most useful for rgb (16- or 32-bit) pixels but,
	in the case of 8-bits or less, this will return the sum of the differing
	bits of the corresponding pixel values (somewhat less useful)"
	| pixPerWord temp |
	pixPerWord _ 32//depth.
	(aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue:
		["If word-aligned, use on-the-fly difference"
		^ (BitBlt current toForm: self) copy: aRect from: otherLoc in: otherForm
				fillColor: nil rule: 32].
	"Otherwise, combine in a word-sized form and then compute difference"
	temp _ self copy: aRect.
	temp copy: aRect from: otherLoc in: otherForm rule: 21.
	^ (BitBlt current toForm: temp) copy: aRect from: otherLoc in: nil
				fillColor: (Bitmap with: 0) rule: 32
"  Dumb example prints zero only when you move over the original rectangle...
 | f diff | f _ Form fromUser.
[Sensor anyButtonPressed] whileFalse:
	[diff _ f pixelCompare: f boundingBox
		with: Display at: Sensor cursorPoint.
	diff printString , '        ' displayAt: 0@0]
"! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:08'!
primCountBits
	"Count the non-zero pixels of this form."
	depth > 8 ifTrue:
		[^(self asFormOfDepth: 8) primCountBits].
	^ (BitBlt current toForm: self)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: width@height);
		combinationRule: 32;
		copyBits! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
rectangleEnclosingPixelsNotOfColor: aColor
	"Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background."

	| cm slice copyBlt countBlt top bottom newH left right |
	"map the specified color to 1 and all others to 0"
	cm _ Bitmap new: (1 bitShift: (depth min: 15)).
	cm primFill: 1.
	cm at: (aColor indexInMap: cm) put: 0.
	cm _ ColorMap colors: cm.

	"build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest"
	slice _ Form extent: width@1 depth: 1.
	copyBlt _ (BitBlt current toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: 1;
		colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: slice extent);
		combinationRule: 32.

	"scan in from top and bottom"
	top _ (0 to: height)
		detect: [:y |
			copyBlt sourceOrigin: 0@y; copyBits.
			countBlt copyBits > 0]
		ifNone: [^ 0@0 extent: 0@0].
	bottom _ (height - 1 to: top by: -1)
		detect: [:y |
			copyBlt sourceOrigin: 0@y; copyBits.
			countBlt copyBits > 0].

	"build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest"
	newH _ bottom - top + 1.
	slice _ Form extent: 1@newH depth: 1.
	copyBlt _ (BitBlt current toForm: slice)
		sourceForm: self;
		combinationRule: Form over;
		destX: 0 destY: 0 width: 1 height: newH;
		colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: slice extent);
		combinationRule: 32.

	"scan in from left and right"
	left _ (0 to: width)
		detect: [:x |
			copyBlt sourceOrigin: x@top; copyBits.
			countBlt copyBits > 0].
	right _ (width - 1 to: left by: -1)
		detect: [:x |
			copyBlt sourceOrigin: x@top; copyBits.
			countBlt copyBits > 0].

	^ left@top corner: (right + 1)@(bottom + 1)
! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
replaceColor: oldColor withColor: newColor
	"Replace one color with another everywhere is this form"

	| cm newInd target ff |
	depth = 32
		ifTrue: [cm _ (Color  cachedColormapFrom: 16 to: 32) copy]
		ifFalse: [cm _ Bitmap new: (1 bitShift: (depth min: 15)).
				1 to: cm size do: [:i | cm at: i put: i - 1]].
	newInd _ newColor pixelValueForDepth: depth.
	cm at: (oldColor pixelValueForDepth: (depth min: 16))+1 put: newInd.
	target _ newColor isTransparent 
		ifTrue: [ff _ Form extent: self extent depth: depth.
			ff fillWithColor: newColor.  ff]
		ifFalse: [self].
	(BitBlt current toForm: target)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form paint;
		destX: 0 destY: 0 width: width height: height;
		colorMap: cm;
		copyBits.
	newColor = Color transparent 
		ifTrue: [target displayOn: self].! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
smear: dir distance: dist
	"Smear any black pixels in this form in the direction dir in Log N steps"
	| skew bb |
	bb _ BitBlt current destForm: self sourceForm: self fillColor: nil
		combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox.
	skew _ 1.
	[skew < dist] whileTrue:
		[bb destOrigin: dir*skew; copyBits.
		skew _ skew+skew]! !

!Form methodsFor: 'image manipulation' stamp: 'jm 6/18/1999 18:41'!
tallyPixelValues
	"Answer a Bitmap whose elements contain the number of pixels in this Form with the pixel value corresponding to their index. Note that the pixels of multiple Forms can be tallied together using tallyPixelValuesInRect:into:."

	^ self tallyPixelValuesInRect: self boundingBox
		into: (Bitmap new: (1 bitShift: (self depth min: 15)))
"
Move a little rectangle around the screen and print its tallies...
 | r tallies nonZero |
Cursor blank showWhile: [
[Sensor anyButtonPressed] whileFalse:
	[r _ Sensor cursorPoint extent: 10@10.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil.
	tallies _ (Display copy: r) tallyPixelValues.
	nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0]
			thenCollect: [:i | (tallies at: i) -> (i-1)].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"
! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
tallyPixelValuesInRect: destRect into: valueTable
	"Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable."

	(BitBlt current toForm: self)
		sourceForm: self;  "src must be given for color map ops"
		sourceOrigin: 0@0;
		tallyMap: valueTable;
		combinationRule: 33;
		destRect: destRect;
		copyBits.
	^ valueTable

"
Move a little rectangle around the screen and print its tallies...
 | r tallies nonZero |
Cursor blank showWhile: [
[Sensor anyButtonPressed] whileFalse:
	[r _ Sensor cursorPoint extent: 10@10.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil.
	tallies _ (Display copy: r) tallyPixelValues.
	nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0]
			thenCollect: [:i | (tallies at: i) -> (i-1)].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"! !

!Form methodsFor: 'image manipulation' stamp: 'jm 6/30/1999 15:36'!
trimBordersOfColor: aColor
	"Answer a copy of this Form with each edge trimmed in to the first pixel that is not of the given color. (That is, border strips of the given color are removed)."

	| r |
	r _ self rectangleEnclosingPixelsNotOfColor: aColor.
	^ self copy: r
! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
xTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by x-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice countBlt copyBlt |
	cm _ self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice _ Form extent: 1@height.
	copyBlt _ (BitBlt current destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height
				clipRect: slice boundingBox) colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: width-1) collect:
		[:x |
		copyBlt sourceOrigin: x@0; copyBits.
		countBlt copyBits]! !

!Form methodsFor: 'image manipulation' stamp: 'ar 5/28/2000 12:09'!
yTallyPixelValue: pv orNot: not
	"Return an array of the number of pixels with value pv by y-value.
	Note that if not is true, then this will tally those different from pv."
	| cm slice copyBlt countBlt |
	cm _ self newColorMap.		"Map all colors but pv to zero"
	not ifTrue: [cm atAllPut: 1].		"... or all but pv to one"
	cm at: pv+1 put: 1 - (cm at: pv+1).
	slice _ Form extent: width@1.
	copyBlt _ (BitBlt current destForm: slice sourceForm: self
				halftoneForm: nil combinationRule: Form over
				destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1
				clipRect: slice boundingBox) colorMap: cm.
	countBlt _ (BitBlt current toForm: slice)
				fillColor: (Bitmap with: 0);
				destRect: (0@0 extent: slice extent);
				combinationRule: 32.
	^ (0 to: height-1) collect:
		[:y |
		copyBlt sourceOrigin: 0@y; copyBits.
		countBlt copyBits]! !


!Form methodsFor: 'fileIn/Out' stamp: 'RAA 8/13/2000 15:32'!
encodeForRemoteCanvas
	| header binaryForm |
	"encode into a bitstream for use with RemoteCanvas.  The format does not require invoking the Compiler"
	header := String streamContents: [ :str |
	str "nextPutAll: 'F|';"
		nextPutAll: self depth printString;
		nextPut: $,;
		nextPutAll: self width printString;
		nextPut: $,;
		nextPutAll: self height printString;
		nextPut: $|. ].

	binaryForm := ByteArray streamContents: [ :str |
		self unhibernate.
		bits writeOn: str. ].

	^header, binaryForm asString
! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 8/5/1998 11:37'!
hibernate
	"Replace my bitmap with a compactly encoded representation (a ByteArray).  It is vital that BitBlt and any other access to the bitmap (such as writing to a file) not be used when in this state.  Since BitBlt will fail if the bitmap size is wrong (not = bitsSize), we do not allow replacement by a byteArray of the same (or larger) size."

	"NOTE: This method copies code from Bitmap compressToByteArray so that it can
	nil out the old bits during the copy, thus avoiding 2x need for extra storage."
	| compactBits lastByte |
	(bits isMemberOf: Bitmap) ifFalse: [^ self  "already hibernated or weird state"].
	compactBits _ ByteArray new: (bits size*4) + 7 + (bits size//1984*3).
	lastByte _ bits compress: bits toByteArray: compactBits.
	lastByte < (bits size*4) ifTrue:
		[bits _ nil.  "Let GC reclaim the old bits before the copy if necessary"
		bits _ compactBits copyFrom: 1 to: lastByte]! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 3/15/1999 14:50'!
printOn: aStream
    aStream
        nextPutAll: self class name;
        nextPut: $(; print: width;
        nextPut: $x; print: height;
        nextPut: $x; print: depth;
        nextPut: $).
! !

!Form methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 14:25'!
readFrom: aBinaryStream
	"Reads the receiver from the given binary stream with the format:
		depth, extent, offset, bits."
	| offsetX offsetY |
	depth _ aBinaryStream next.
	(depth isPowerOfTwo and: [depth between: 1 and: 32])
		ifFalse: [self error: 'invalid depth; bad Form file?'].
	width _ aBinaryStream nextWord.
	height _ aBinaryStream nextWord.
	offsetX  _ aBinaryStream nextWord.
	offsetY _ aBinaryStream nextWord.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].
	bits _ Bitmap newFromStream: aBinaryStream.
	bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?'].
	^ self
! !

!Form methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 16:54'!
readFromOldFormat: aBinaryStream
	"Read a Form in the original ST-80 format."

	| w h offsetX offsetY newForm theBits pos |
	self error: 'this method must be updated to read into 32-bit word bitmaps'.
	w _ aBinaryStream nextWord.
	h _ aBinaryStream nextWord.
	offsetX  _ aBinaryStream nextWord.
	offsetY _ aBinaryStream nextWord.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].
	newForm _ Form extent: w @ h offset: offsetX @ offsetY.
	theBits _ newForm bits.
	pos _ 0.
	1 to: w + 15 // 16 do: [:j |
		1 to: h do: [:i |
			theBits at: (pos _ pos+1) put: aBinaryStream nextWord]].
	newForm bits: theBits.
	^ newForm
! !

!Form methodsFor: 'fileIn/Out' stamp: 'RAA 9/19/2000 18:37'!
store15To24HexBitsOn:aStream

	| buf i |

	"write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original"

	buf _ String new: 12.
	bits do: [:word | 
		i _ 0.
		"upper pixel"
		buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit.

		"lower pixel"

		buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit.

		buf at: (i _ i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit.
		buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit.
		aStream print: buf.
		"#( 31 26 21 15 10 5 )  do:[:startBit | ]"
	].! !

!Form methodsFor: 'fileIn/Out'!
store32To24HexBitsOn:aStream
	^self storeBits:20 to:0 on:aStream.! !

!Form methodsFor: 'fileIn/Out'!
storeBits:startBit to:stopBit on:aStream
	bits storeBits:startBit to:stopBit on:aStream.! !

!Form methodsFor: 'fileIn/Out'!
storeBitsOn:aStream base:anInteger
	bits do: [:word | 
		anInteger = 10
			ifTrue: [aStream space]
			ifFalse: [aStream crtab: 2].
		word printOn: aStream base: anInteger].
! !

!Form methodsFor: 'fileIn/Out'!
storeHexBitsOn:aStream
	^self storeBits:28 to:0 on:aStream.! !

!Form methodsFor: 'fileIn/Out'!
storeOn: aStream

	self storeOn: aStream base: 10! !

!Form methodsFor: 'fileIn/Out'!
storeOn: aStream base: anInteger 
	"Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original."

	self unhibernate.
	aStream nextPut: $(.
	aStream nextPutAll: self species name.
	aStream crtab: 1.
	aStream nextPutAll: 'extent: '.
	self extent printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'depth: '.
	self depth printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'fromArray: #('.
	self storeBitsOn:aStream base:anInteger.
	aStream nextPut: $).
	aStream crtab: 1.
	aStream nextPutAll: 'offset: '.
	self offset printOn: aStream.
	aStream nextPut: $).
! !

!Form methodsFor: 'fileIn/Out' stamp: 'ar 5/28/2000 00:52'!
unhibernate
	"If my bitmap has been compressed into a ByteArray,
	then expand it now, and return true."
	bits == nil ifTrue:[bits _ Bitmap new: self bitsSize. ^true].
	(bits isMemberOf: ByteArray)
		ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true].
	^ false! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 12/6/1999 10:14'!
writeBMPfileNamed: fName  "Display writeBMPfileNamed: 'display'"
	| fileName bhSize biSize biClrUsed f biSizeImage bfOffBits rowBytes rgb data colorValues |
	self unhibernate.
	(#(1 4 8 32) includes: depth) ifFalse: [self halt  "depth must be one of these"].
	((fileName _ fName) asUppercase endsWith: '.BMP')
		ifFalse: [fileName _ fName , '.BMP'].
	bhSize _ 14.  "# bytes in file header"
	biSize _ 40.  "info header size in bytes"
	biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth].  "No. color table entries"
	bfOffBits _ biSize + bhSize + (4*biClrUsed).
	rowBytes _ ((depth min: 24) * width + 31 // 32) * 4.
	biSizeImage _ height * rowBytes.

 	f _ (FileStream newFileNamed: fileName) binary.
	"Write the file header"
	f position: 0.
	f nextLittleEndianNumber: 2 put: 19778.  "bfType = BM"
	f nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage.  "Entire file size in bytes"
	f nextLittleEndianNumber: 4 put: 0.  "bfReserved"
	f nextLittleEndianNumber: 4 put: bfOffBits.  "Offset of bitmap data from start of hdr (and file)"

	"Write the bitmap info header"
	f position: bhSize.
	f nextLittleEndianNumber: 4 put: biSize.  "info header size in bytes"
	f nextLittleEndianNumber: 4 put: width.  "biWidth"
	f nextLittleEndianNumber: 4 put: height.  "biHeight"
	f nextLittleEndianNumber: 2 put: 1.  "biPlanes"
	f nextLittleEndianNumber: 2 put: (depth min: 24).  "biBitCount"
	f nextLittleEndianNumber: 4 put: 0.  "biCompression"
	f nextLittleEndianNumber: 4 put: biSizeImage.  "size of image section in bytes"
	f nextLittleEndianNumber: 4 put: 2800.  "biXPelsPerMeter"
	f nextLittleEndianNumber: 4 put: 2800.  "biYPelsPerMeter"
	f nextLittleEndianNumber: 4 put: biClrUsed.
	f nextLittleEndianNumber: 4 put: 0.  "biClrImportant"
	biClrUsed > 0 ifTrue: [
		"write color map; this works for ColorForms, too"
		colorValues _ self colormapIfNeededForDepth: 32.
		1 to: biClrUsed do: [:i |
			rgb _ colorValues at: i.
			0 to: 24 by: 8 do: [:j | f nextPut: (rgb >> j bitAnd: 16rFF)]]].

	'Writing image data' displayProgressAt: Sensor cursorPoint
		from: 1 to: height during: [:bar |
			1 to: height do:
				[:i | bar value: i.
				data _ (self copy: (0@(height-i) extent: width@1)) bits.
				depth = 32
				ifTrue: [1 to: data size do: [:j | f nextLittleEndianNumber: 3 put: (data at: j)].
						1 to: (data size*3)+3//4*4-(data size*3) do: [:j | f nextPut: 0 "pad to 32-bits"]]
				ifFalse: [1 to: data size do: [:j | f nextNumber: 4 put: (data at: j)]]]].
	f position = (bfOffBits + biSizeImage) ifFalse: [self halt].
	f close.
! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 3/2/98 12:43'!
writeOn: file
	"Write the receiver on the file in the format
		depth, extent, offset, bits."
	self unhibernate.
	file nextPut: depth.
	file nextWordPut: width.
	file nextWordPut: height.
	file nextWordPut: ((self offset x) >=0
					ifTrue: [self offset x]
					ifFalse: [self offset x + 65536]).
	file nextWordPut: ((self offset y) >=0
					ifTrue: [self offset y]
					ifFalse: [self offset y + 65536]).
	bits writeOn: file! !

!Form methodsFor: 'fileIn/Out' stamp: 'di 7/6/1998 23:00'!
writeOnMovie: file
	"Write just my bits on the file."
	self unhibernate.
	bits writeUncompressedOn: file! !

!Form methodsFor: 'fileIn/Out' stamp: 'tk 2/19/1999 07:30'!
writeUncompressedOn: file
	"Write the receiver on the file in the format depth, extent, offset, bits.  Warning:  Caller must put header info on file!!  Use writeUncompressedOnFileNamed: instead."
	self unhibernate.
	file binary.
	file nextPut: depth.
	file nextWordPut: width.
	file nextWordPut: height.
	file nextWordPut: ((self offset x) >=0
					ifTrue: [self offset x]
					ifFalse: [self offset x + 65536]).
	file nextWordPut: ((self offset y) >=0
					ifTrue: [self offset y]
					ifFalse: [self offset y + 65536]).
	bits writeUncompressedOn: file! !


!Form methodsFor: 'private' stamp: 'tk 3/13/2000 15:21'!
hackBits: bitThing
	"This method provides an initialization so that BitBlt may be used, eg, to 
	copy ByteArrays and other non-pointer objects efficiently.
	The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high."
	width _ 4.
	depth _ 8.
	bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object'].
	bitThing class isBytes
		ifTrue: [height _ bitThing basicSize // 4]
		ifFalse: [height _ bitThing basicSize].
	bits _ bitThing! !

!Form methodsFor: 'private'!
initFromArray: array
	"Fill the bitmap from array.  If the array is shorter,
	then cycle around in its contents until the bitmap is filled."
	| ax aSize array32 i j word16 |
	ax _ 0.
	aSize _ array size.
	aSize > bits size ifTrue:
		["backward compatibility with old 16-bit bitmaps and their forms"
		array32 _ Array new: height * (width + 31 // 32).
		i _ j _ 0.
		1 to: height do:
			[:y | 1 to: width+15//16 do:
				[:x16 | word16 _ array at: (i _ i + 1).
				x16 odd ifTrue: [array32 at: (j _ j+1) put: (word16 bitShift: 16)]
						ifFalse: [array32 at: j put: ((array32 at: j) bitOr: word16)]]].
		^ self initFromArray: array32].
	1 to: bits size do:
		[:index |
		(ax _ ax + 1) > aSize ifTrue: [ax _ 1].
		bits at: index put: (array at: ax)]! !

!Form methodsFor: 'private' stamp: 'ar 12/19/2000 16:23'!
privateFloodFillValue: aColor
	"Private. Compute the pixel value in the receiver's depth but take into account implicit color conversions by BitBlt."
	| f1 f2 bb |
	f1 _ Form extent: 1@1 depth: depth.
	f2 _ Form extent: 1@1 depth: 32.
	bb _ BitBlt toForm: f1.
	bb fillColor: aColor; 
		destRect: (0@0 corner: 1@1); 
		combinationRule: 3; 
		copyBits.
	bb _ BitBlt toForm: f2.
	bb sourceForm: f1; 
		sourceOrigin: 0@0;
		destRect: (0@0 corner: 1@1);
		combinationRule: 3;
		copyBits.
	^f2 pixelValueAt: 0@0.! !

!Form methodsFor: 'private' stamp: '6/9/97 16:10 di'!
setExtent: extent depth: bitsPerPixel
	"Create a virtual bit map with the given extent and bitsPerPixel."

	width _ extent x asInteger.
	width < 0 ifTrue: [width _ 0].
	height _ extent y asInteger.
	height < 0 ifTrue: [height _ 0].
	depth _ bitsPerPixel.
	bits _ Bitmap new: self bitsSize! !

!Form methodsFor: 'private' stamp: 'ar 5/28/2000 15:49'!
setExtent: extent depth: bitsPerPixel bits: bitmap
	"Create a virtual bit map with the given extent and bitsPerPixel."

	width _ extent x asInteger.
	width < 0 ifTrue: [width _ 0].
	height _ extent y asInteger.
	height < 0 ifTrue: [height _ 0].
	depth _ bitsPerPixel.
	(bits isNil or:[self bitsSize = bitmap size]) ifFalse:[^self error:'Bad dimensions'].
	bits _ bitmap! !


!Form methodsFor: 'other' stamp: 'RAA 8/14/2000 10:13'!
asCursorForm

	^ self as: StaticForm! !

!Form methodsFor: 'other' stamp: 'ar 5/28/2000 12:07'!
asGrayScale
	"Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)"
	| f32 srcForm result map bb grays |
	depth = 32 ifFalse: [
		f32 _ Form extent: width@height depth: 32.
		self displayOn: f32.
		^ f32 asGrayScale].
	self unhibernate.
	srcForm _ Form extent: (width * 4)@height depth: 8.
	srcForm bits: bits.
	result _ ColorForm extent: width@height depth: 8.
	map _ Bitmap new: 256.
	2 to: 256 do: [:i | map at: i put: i - 1].
	map at: 1 put: 1.  "map zero pixel values to near-black"
	bb _ (BitBlt current toForm: result)
		sourceForm: srcForm;
		combinationRule: Form over;
		colorMap: map.
	0 to: width - 1 do: [:dstX |
		bb  sourceRect: (((dstX * 4) + 2)@0 extent: 1@height);
			destOrigin: dstX@0;
			copyBits].

	"final BitBlt to zero-out pixels that were truely transparent in the original"
	map _ Bitmap new: 512.
	map at: 1 put: 16rFF.
	(BitBlt current toForm: result)
		sourceForm: self;
		sourceRect: self boundingBox;
		destOrigin: 0@0;
		combinationRule: Form erase;
		colorMap: map;
		copyBits.
	
	grays _ (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0].
	grays at: 1 put: Color transparent.
	result colors: grays.
	^ result
! !

!Form methodsFor: 'other'!
bitsSize
	| pixPerWord |
	depth == nil ifTrue: [depth _ 1].
	pixPerWord _ 32 // depth.
	^ width + pixPerWord - 1 // pixPerWord * height! !

!Form methodsFor: 'other' stamp: 'jm 4/5/1999 19:20'!
colorReduced
	"Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not."

	| tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c |
	tally _ self tallyPixelValues asArray.
	tallyDepth _ (tally size log: 2) asInteger.
	colorCount _ 0.
	tally do: [:n | n > 0 ifTrue: [colorCount _ colorCount + 1]].
	(tally at: 1) = 0 ifTrue: [colorCount _ colorCount + 1].  "include transparent"
	colorCount > 256 ifTrue: [^ self].  "cannot reduce"
	newForm _ self formForColorCount: colorCount.

	"build an array of just the colors used, and a color map to translate
	 old pixel values to their indices into this color array"
	cm _ Bitmap new: tally size.
	oldPixelValues _ self colormapIfNeededForDepth: 32.
	newFormColors _ Array new: colorCount.
	newFormColors at: 1 put: Color transparent.
	nextColorIndex _ 2.
	2 to: cm size do: [:i |
		(tally at: i) > 0 ifTrue: [
			oldPixelValues = nil
				ifTrue: [c _ Color colorFromPixelValue: i - 1 depth: tallyDepth]
				ifFalse: [c _ Color colorFromPixelValue: (oldPixelValues at: i) depth: 32].
			newFormColors at: nextColorIndex put: c.
			cm at: i put: nextColorIndex - 1.  "pixel values are zero-based indices"
			nextColorIndex _ nextColorIndex + 1]].

	"copy pixels into new ColorForm, mapping to new pixel values"
	newForm copyBits: self boundingBox
		from: self
		at: 0@0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil
		map: cm.
	newForm colors: newFormColors.
	newForm offset: offset.
	^ newForm
! !

!Form methodsFor: 'other' stamp: 'jm 12/5/97 19:48'!
colorsUsed
	"Return a list of the Colors this form uses."

	| tallies tallyDepth usedColors |
	tallies _ self tallyPixelValues.
	tallyDepth _ (tallies size log: 2) asInteger.
	usedColors _ OrderedCollection new.
	tallies doWithIndex: [:count :i |
		count > 0 ifTrue: [
			usedColors add: (Color colorFromPixelValue: i - 1 depth: tallyDepth)]].
	^ usedColors asArray
! !

!Form methodsFor: 'other' stamp: 'jm 9/27/97 21:02'!
formForColorCount: colorCount
	"Return a ColorForm of sufficient depth to represent the given number of colors. The maximum number of colors is 256."

	colorCount > 256 ifTrue: [^ self error: 'too many colors'].

	colorCount > 16 ifTrue: [^ ColorForm extent: self extent depth: 8].
	colorCount > 4 ifTrue: [^ ColorForm extent: self extent depth: 4].
	colorCount > 2 ifTrue: [^ ColorForm extent: self extent depth: 2].
	^ ColorForm extent: self extent depth: 1
! !

!Form methodsFor: 'other' stamp: 'ar 5/28/2000 12:08'!
mapColor: oldColor to: newColor
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	map _ (Color cachedColormapFrom: depth to: depth) copy.
	map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: depth).
	(BitBlt current toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.
! !

!Form methodsFor: 'other' stamp: 'ar 5/28/2000 12:08'!
mapColors: oldColorBitsCollection to: newColorBits
	"Make all pixels of the given color in this Form to the given new color."
	"Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution."

	| map |
	depth < 16
		ifTrue: [map _ (Color cachedColormapFrom: depth to: depth) copy]
		ifFalse: [
			"use maximum resolution color map"
			"source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component"
			map _ Color computeRGBColormapFor: depth bitsPerColor: 5].
	oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits].

	(BitBlt current toForm: self)
		sourceForm: self;
		sourceOrigin: 0@0;
		combinationRule: Form over;
		destX: 0 destY: 0 width: width height: height;
		colorMap: map;
		copyBits.
! !

!Form methodsFor: 'other' stamp: 'jm 12/1/97 19:58'!
newColorMap 
	"Return an uninitialized color map array appropriate to this Form's depth."

	^ Bitmap new: (1 bitShift: (depth min: 15))
! !

!Form methodsFor: 'other' stamp: 'jm 1/6/98 10:37'!
primPrintHScale: hScale vScale: vScale landscape: aBoolean
	"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
	"(Form extent: 10@10) primPrintHScale: 1.0 vScale: 1.0 landscape: true"

	<primitive: 232>
	self primitiveFailed
! !


!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'!
fadeImage: otherImage at: topLeft
	indexAndMaskDo: indexAndMaskBlock
	"This fade uses halftones as a blending hack.
	Zeros in the halftone produce the original image (self), and 
	ones in the halftone produce the 'otherImage'.
	IndexAndMaskBlock gets evaluated prior to each cycle,
	and the resulting boolean determines whether to continue cycling."
	| index imageRect maskForm resultForm |
	imageRect _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: imageRect extent).
	maskForm _ Form extent: 32@32.
	index _ 0.
	[indexAndMaskBlock value: (index _ index+1) value: maskForm]
	whileTrue:
		[maskForm reverse.
		resultForm copyBits: imageRect from: resultForm at: 0@0
			clippingBox: imageRect rule: Form over fillColor: maskForm.
		maskForm reverse.
		resultForm copyBits: imageRect from: otherImage at: 0@0
			clippingBox: imageRect rule: Form under fillColor: maskForm.
		self copyBits: imageRect from: resultForm at: topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil.
		Display forceDisplayUpdate]! !

!Form methodsFor: 'transitions'!
fadeImageCoarse: otherImage at: topLeft
	"Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j |
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: depth) - 1.
					1 to: 8//depth-1 do: [:q | pix _ pix bitOr: (pix bitShift: depth*4)]].
		i <= 16 ifTrue:
		[j _ i-1//4+1.
		(0 to: 28 by: 4) do: [:k |
			mask bits at: j+k
				put: ((mask bits at: j+k) bitOr: (pix bitShift: i-1\\4*depth))].
		"mask display." true]
		ifFalse: [false]]! !

!Form methodsFor: 'transitions'!
fadeImageFine: otherImage at: topLeft
	"Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j ii |
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: depth) - 1.
					1 to: 8//depth-1 do:
						[:q | pix _ pix bitOr: (pix bitShift: depth*4)]].
		i <= 16 ifTrue:
		[ii _ #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i.
		j _ ii//4+1.
		(0 to: 28 by: 4) do:
			[:k | mask bits at: j+k put:
				((mask bits at: j+k) bitOr: (pix bitShift: ii\\4*depth))].
		true]
		ifFalse: [false]]! !

!Form methodsFor: 'transitions'!
fadeImageHor: otherImage at: topLeft
	"Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'transitions'!
fadeImageHorFine: otherImage at: topLeft
	"Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black.
		mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black.
		(i*2) <= mask width]! !

!Form methodsFor: 'transitions'!
fadeImageSquares: otherImage at: topLeft 
	"Display fadeImageSquares: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((16-i) asPoint extent: (i*2) asPoint) fillColor: Color black.
		i <= 16]! !

!Form methodsFor: 'transitions'!
fadeImageVert: otherImage at: topLeft
	"Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((mask width//2//depth-i*depth)@0 extent: i*2*depth@mask height) fillColor: Color black.
		i <= (mask width//depth)]! !

!Form methodsFor: 'transitions' stamp: 'jm 6/1/1998 10:55'!
pageImage: otherImage at: topLeft corner: corner
	"Produce a page-turning illusion that gradually reveals otherImage
	located at topLeft in this form.  Corner specifies which corner, as
		1=topLeft, 2=topRight, 3=bottomRight, 4=bottomLeft."
	| bb maskForm resultForm delta maskLoc maskRect stepSize cornerSel smallRect |
	stepSize _ 10.
	bb _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: bb extent).
	maskForm _ Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint.

	"maskLoc _ starting loc rel to topLeft"
	otherImage width > otherImage height
		ifTrue: ["wide image; motion is horizontal."
				(corner between: 2 and: 3) not ifTrue:
					["motion is to the right"
					delta _ 1@0.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [maskForm width@0]
						ifFalse: [maskForm width@stepSize])]
					ifFalse:
					["motion is to the left"
					delta _ -1@0.
					maskLoc _ bb topRight - (corner = 2
						ifTrue: [0@0]
						ifFalse: [0@stepSize])]]
		ifFalse: ["tall image; motion is vertical."
				corner <= 2 ifTrue:
					["motion is downward"
					delta _ 0@1.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [0@maskForm height]
						ifFalse: [stepSize@maskForm height])]
					ifFalse:
					["motion is upward"
					delta _ 0@-1.
					maskLoc _ bb bottomLeft - (corner = 3
						ifTrue: [stepSize@0]
						ifFalse: [0@0])]].

	"Build a solid triangle in the mask form"
	(Pen newOnForm: maskForm) in: [:p |
		corner even  "Draw 45-degree line"
			ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2]
			ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]].
	maskForm smear: delta negated distance: maskForm width.
	"Copy the mask to full resolution for speed.  Make it be the reversed
	so that it can be used for ORing in the page-corner color"
	maskForm _ (Form extent: maskForm extent depth: otherImage depth)
		copyBits: maskForm boundingBox from: maskForm at: 0@0
		colorMap: (Bitmap with: 16rFFFFFFFF with: 0).

	"Now move the triangle maskForm across the resultForm selecting the
	triangular part of otherImage to display, and across the resultForm,
	selecting the part of the original image to erase."
	cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: corner.
	1 to: (otherImage width + otherImage height // stepSize)+1 do:
		[:i |		"Determine the affected square"
		maskRect _ (maskLoc extent: maskForm extent) intersect: bb.
		((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue:
			[smallRect _ 0@0 extent: (maskRect width min: maskRect height) asPoint.
			maskRect _ smallRect align: (smallRect perform: cornerSel)
								with: (maskRect perform: cornerSel)].

		"AND otherForm with triangle mask, and OR into result"
		resultForm copyBits: bb from: otherImage at: 0@0
				clippingBox: maskRect rule: Form over fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form erase fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form under fillColor: Color lightBrown.

		"Now update Display in a single BLT."
		self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil.
		Display forceDisplayUpdate.
		maskLoc _ maskLoc + (delta*stepSize)]
"
1 to: 4 do: [:corner | Display pageImage:
				(Form fromDisplay: (10@10 extent: 200@300)) reverse
			at: 10@10 corner: corner]
"
! !

!Form methodsFor: 'transitions' stamp: 'ar 5/28/2000 12:12'!
pageWarp: otherImage at: topLeft forward: forward
	"Produce a page-turning illusion that gradually reveals otherImage
	located at topLeft in this form.
	forward == true means turn pages toward you, else away. [ignored for now]"
	| pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d |
	pageRect _ otherImage boundingBox.
	oldPage _ self copy: (pageRect translateBy: topLeft).
	(forward ifTrue: [oldPage] ifFalse: [otherImage])
		border: pageRect
		widthRectangle: (Rectangle
				left: 0
				right: 2
				top: 1
				bottom: 1)
		rule: Form over
		fillColor: Color black.
	oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))).
	nSteps _ 8.
	buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth.
	d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight.
	1 to: nSteps-1 do:
		[:i | forward
			ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over.
					p _ pageRect topRight + (d * i // nSteps)]
			ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over.
					p _ pageRect topRight + (d * (nSteps-i) // nSteps)].
		buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over.
		leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y).
		sourceQuad _ Array with: pageRect topLeft
			with: pageRect bottomLeft + (0@p y)
			with: pageRect bottomRight
			with: pageRect topRight - (0@p y).
		warp _ (WarpBlt current toForm: buffer)
				clipRect: leafRect;
				sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]);
				combinationRule: Form paint.
		warp copyQuad: sourceQuad toRect: leafRect.
		self copy: buffer boundingBox from: buffer to: topLeft rule: Form over.
		Display forceDisplayUpdate].

	buffer copy: pageRect from: otherImage to: 0@0 rule: Form over.
	buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over.
	self copy: buffer boundingBox from: buffer to: topLeft rule: Form over.
	Display forceDisplayUpdate.
"
1 to: 4 do: [:corner | Display pageWarp:
				(Form fromDisplay: (10@10 extent: 200@300)) reverse
			at: 10@10 forward: false]
"
! !

!Form methodsFor: 'transitions' stamp: 'jm 5/21/1998 23:46'!
slideImage: otherImage at: topLeft delta: delta
	"Display slideImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 3@-4"
	| bb nSteps clipRect |
	bb _ otherImage boundingBox.
	clipRect _ topLeft extent: otherImage extent.
	nSteps _ 1.
	delta x = 0 ifFalse: [nSteps _ nSteps max: (bb width//delta x abs) + 1].
	delta y = 0 ifFalse: [nSteps _ nSteps max: (bb height//delta y abs) + 1].
	1 to: nSteps do:
			[:i | self copyBits: bb from: otherImage
				at: delta*(i-nSteps) + topLeft
				clippingBox: clipRect rule: Form paint fillColor: nil.
			Display forceDisplayUpdate]! !

!Form methodsFor: 'transitions' stamp: 'jm 6/18/1998 12:57'!
wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: rectForIndexBlock

	| i clipRect t rectOrList waitTime |
	i _ 0.
	clipRect _ topLeft extent: otherImage extent.
	clipBox ifNotNil: [clipRect _ clipRect intersect: clipBox].
	[rectOrList _ rectForIndexBlock value: (i _ i + 1).
	 rectOrList == nil]
		whileFalse: [
			t _ Time millisecondClockValue.
			rectOrList asOrderedCollection do: [:r |
				self copyBits: r from: otherImage at: topLeft + r topLeft
					clippingBox: clipRect rule: Form over fillColor: nil].
			Display forceDisplayUpdate.
			waitTime _ 3 - (Time millisecondClockValue - t).
			waitTime > 0 ifTrue:
				["(Delay forMilliseconds: waitTime) wait"]].
! !

!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:21'!
wipeImage: otherImage at: topLeft delta: delta
	"Display wipeImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 0@-2"

	self wipeImage: otherImage at: topLeft delta: delta clippingBox: nil.
! !

!Form methodsFor: 'transitions' stamp: 'jm 10/16/97 15:17'!
wipeImage: otherImage at: topLeft delta: delta clippingBox: clipBox

	| wipeRect bb nSteps |
	bb _ otherImage boundingBox.
	wipeRect _ delta x = 0
		ifTrue:
		[delta y = 0 ifTrue: [nSteps _ 1. bb "allow 0@0"] ifFalse: [
		nSteps _ bb height//delta y abs + 1.  "Vertical movement"
		delta y > 0
			ifTrue: [bb topLeft extent: bb width@delta y]
			ifFalse: [bb bottomLeft+delta extent: bb width@delta y negated]]]
		ifFalse:
		[nSteps _ bb width//delta x abs + 1.  "Horizontal movement"
		delta x > 0
			ifTrue: [bb topLeft extent: delta x@bb height]
			ifFalse: [bb topRight+delta extent: delta x negated@bb height]].
	^ self wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex:
		[:i | i <= nSteps
			ifTrue: [wipeRect translateBy: (delta* (i-1))]
			ifFalse: [nil]]! !

!Form methodsFor: 'transitions' stamp: 'di 1/28/1999 09:20'!
zoomIn: goingIn orOutTo: otherImage at: topLeft vanishingPoint: vp 
	"Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40.
	Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40."
	| nSteps j bigR lilR minTime startTime lead |
	nSteps _ 16.
	minTime _ 500.  "milliseconds"
	startTime _ Time millisecondClockValue.
	^ self wipeImage: otherImage at: topLeft clippingBox: nil rectForIndex:
		[:i | "i runs from 1 to nsteps"
		i > nSteps
			ifTrue: [nil "indicates all done"]
			ifFalse:
			["If we are going too fast, delay for a bit"
			lead _ startTime + (i-1*minTime//nSteps) - Time millisecondClockValue.
			lead > 10 ifTrue: [(Delay forMilliseconds: lead) wait].

			"Return an array with the difference rectangles for this step."
			j _ goingIn ifTrue: [i] ifFalse: [nSteps+1-i].
			bigR _ vp - (vp*(j)//nSteps) corner:
				vp + (otherImage extent-vp*(j)//nSteps).
			lilR _ vp - (vp*(j-1)//nSteps) corner:
				vp + (otherImage extent-vp*(j-1)//nSteps).
			bigR areasOutside: lilR]]! !

!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:14'!
zoomInTo: otherImage at: topLeft
	"Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self zoomIn: true orOutTo: otherImage at: topLeft
		vanishingPoint: otherImage extent//2+topLeft! !

!Form methodsFor: 'transitions' stamp: 'di 3/2/98 09:15'!
zoomOutTo: otherImage at: topLeft
	"Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self zoomIn: false orOutTo: otherImage at: topLeft
		vanishingPoint: otherImage extent//2+topLeft! !


!Form methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 09:01'!
addDeltasFrom: previousForm

	(BitBlt 
		destForm: self 
		sourceForm: previousForm 
		fillColor: nil 
		combinationRule: Form reverse
		destOrigin: 0@0
		sourceOrigin: 0@0
		extent: self extent 
		clipRect: self boundingBox) copyBits.
	^self! !

!Form methodsFor: 'as yet unclassified' stamp: 'di 7/8/1998 12:18'!
baldMountainWorkspace
"   -- Reset player, do this, then play -- 
	|  file ff |
Time millisecondsToRun: [
	file _ FileStream oldFileNamed: 'Bald10fpsAll338.forms'.
	file binary.
	file next = 2 ifFalse: [self halt].
	ff _ Form extent: 320@240 depth: 16.
	1 to: 338 by: 2 do:
		[:i | file position: i-1*153613+1.
		ff readFrom: file.
		ff display.
		[i*124>AA msecsSinceStart] whileTrue: [World doOneCycle].
		Sensor yellowButtonPressed ifTrue: [^ file close]].
	file close]

 -- Async version --
 |  file ff byteCount nFrames bytesRead di |
	file _ AsyncFile new open: 'Bald10fpsAll338.forms' forWrite: false.
	ff _ Form extent: 320@240 depth: 16.
	byteCount _ ff bits size * 4.
	nFrames _ 338.
	file primReadStart: file fileHandle fPosition: 1+13 count: byteCount.
	1 to: nFrames by: (di_1) do:
		[:i |
		file waitForCompletion.
		bytesRead _ file primReadResult: file fileHandle
			intoBuffer: ff bits at: 1 count: byteCount//4.
		Sensor anyButtonPressed ifTrue: [^ file close].
		(i+di) <= nFrames ifTrue:
			[file primReadStart: file fileHandle fPosition: (i-1+di)*(byteCount+13)+1+13 count: byteCount].
		ff display.
		[i*124>AA msecsSinceStart] whileTrue: [World doOneCycle].
		].
	file close.
	waitTime

	| ps zps f32 f16 |
	1 to: 338 by: 1 do:
		[:i | ps _ i printString. zps _ ('00000' copyFrom: 1 to: 5 - ps size) , ps.
		f32 _ Form fromFile: (FileStream oldFileNamed:
			'Macintosh HD:Shipping.Receiving:Bald10fps bmps:Bald' , zps , '.BMP').
		f32 displayAt: 0@0.
		f16 _ Form extent: f32 extent depth: 16.
		f32 displayOn: f16 at: 0@0.
		f16 displayAt: 330@0.
		Transcript cr; show: i printString.
		f16 writeUncompressedOnFileNamed:
			'Macintosh HD:Shipping.Receiving:Bald10fps forms:Bald' , zps , '.form'.
		Sensor anyButtonPressed ifTrue: [^ nil]]

	| ps zps  file |
	file _ FileStream newFileNamed: 'Macintosh HD:Shipping.Receiving:Bald10fpsAll338.forms'.
	file binary.
	file nextPut: 2.
	1 to: 338 by: 1 do:
		[:i | ps _ i printString. zps _ ('00000' copyFrom: 1 to: 5 - ps size) , ps.
		(Form fromFileNamed: 'Macintosh HD:Shipping.Receiving:Bald10fps forms:Bald' , zps , '.form') display; writeUncompressedOn: file.
		Sensor anyButtonPressed ifTrue: [^ nil]].
	file close

	-- convert .forms file to .movie format --
	|  out ps zps ff |
	out _ FileStream newFileNamed: 'Bald2minAt10fps.movie'.
	out binary.
	ff _ Form extent: 320@240 depth: 16.
	#(22 320 240 16 338) , (6 to: 32)
		do: [:i | out nextInt32Put: i].
		
	1 to: 1203 by: 1 do:
		[:i | i printString displayAt: 400@0.
		ps _ i printString. zps _ ('00000' copyFrom: 1 to: 5 - ps size) , ps.
		(Form fromFileNamed: 'BackStreet HD:Bald Mt Disk:Bald2 10fps Proc:Bald10.' , zps)
 			displayOn: ff.
		ff display; writeOnMovie: out].
	out close.

	|  file ff |
Time millisecondsToRun: [
	file _ FileStream oldFileNamed: 'Bald10fpsAll338.forms'.
	file binary.
	file next = 2 ifFalse: [self halt].
	ff _ Form extent: 320@240 depth: 16.
	1 to: 338 by: 1 do:
		[:i | ff  readFrom: file.
		ff display.
		Sensor anyButtonPressed ifTrue: [^ file close]].
	file close]

	|  file ff byteCount nFrames filePosition bytesRead waitTime t |
Array with: (Time millisecondsToRun: [
	file _ AsyncFile new open: 'Bald10fpsAll338.forms' forWrite: false.
	ff _ Form extent: 320@240 depth: 16.
	waitTime _ 0.
	byteCount _ ff bits size * 4.
	filePosition _ 1.
	nFrames _ 338.
	file primReadStart: file fileHandle fPosition: filePosition+13 count: byteCount.
	1 to: nFrames by: 1 do:
		[:i |
		t _ Time millisecondClockValue.
		file waitForCompletion.
		waitTime _ waitTime + (Time millisecondClockValue - t).
		bytesRead _ file primReadResult: file fileHandle
			intoBuffer: ff bits at: 1 count: byteCount//4.
		filePosition _ filePosition+13 + bytesRead.
		Sensor anyButtonPressed ifTrue: [^ file close].
		i < nFrames ifTrue:
			[file primReadStart: file fileHandle fPosition: filePosition+13 count: byteCount].
		ff display].
	file close])
	with: waitTime (18400 9798 )

 | ff |
 ff _ Form fromFileNamed: 'Macintosh HD:Shipping.Receiving:Bald10fps forms:Bald00338.form'.
 Time millisecondsToRun: [1 to: 100 do: [:i | ff display]] 100000//1359 73


Try out on-the-fly pixel doubling [dummied for timing]...
 | file f1 f2 f2a pixMap bb1 bb2 |
Time millisecondsToRun: [
	file _ FileStream oldFileNamed: 'Bald10fpsAll338.forms'.
	file binary.
	file next = 2 ifFalse: [self halt].
	f1 _ Form extent: 320@240 depth: 16.
	f2 _ Form extent: 640@480 depth: 16.
	f2a _ Form extent: 320@480 depth: 32.
	f2a bits: f2 bits.
	pixMap _ Bitmap new: 32768.
	1 to: 32768 do: [:i | pixMap at: i put: (i bitOr: (i bitShift: 16))].
	bb1 _ BitBlt destForm: f2a sourceForm: f1 halftoneForm: nil combinationRule: 3 destOrigin: 0@0 sourceOrigin: 0@0 extent: 320@1 clipRect: f2a boundingBox.
	bb1 colorMap: pixMap.
	bb2 _ BitBlt destForm: f2 sourceForm: f2 halftoneForm: nil combinationRule: 3 destOrigin: 0@0 sourceOrigin: 0@0 extent: 640@1 clipRect: f2 boundingBox.
	1 to: 338 by: 1 do:
		[:i | f1  readFrom: file.
		bb1 destOrigin: 0@0; sourceOrigin: 0@0.
		bb1 destOrigin: 0@0; sourceOrigin: 0@0.
		0 to: 239 do:
			[:j |
			bb1 sourceY: j; destY: j*2; copyBits.
			bb2 sourceY: j*2; destY: j*2+1; copyBits].
		f2 display.
		Sensor anyButtonPressed ifTrue: [^ nil]].
	file close
] 104512 53247 39812 338000.0/ 53247 6.34777546152835 6 6
"! !

!Form methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 09:01'!
deltaFrom: previousForm

	| newForm |
	newForm _ previousForm deepCopy.
	(BitBlt 
		destForm: newForm 
		sourceForm: self 
		fillColor: nil 
		combinationRule: Form reverse 
		destOrigin: 0@0
		sourceOrigin: 0@0
		extent: self extent 
		clipRect: self boundingBox) copyBits.
	^newForm! !

!Form methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 06:15'!
deltaFrom: smallerForm at: offsetInMe

	| newForm |
	newForm _ smallerForm deepCopy.
	(BitBlt 
		destForm: newForm 
		sourceForm: self 
		fillColor: nil 
		combinationRule: Form reverse 
		destOrigin: 0@0
		sourceOrigin: offsetInMe
		extent: smallerForm extent 
		clipRect: newForm boundingBox) copyBits.
	^newForm! !


!Form methodsFor: 'postscript generation'!
bitsPerComponent
	^depth <= 8 ifTrue:[depth] ifFalse:[8].
! !

!Form methodsFor: 'postscript generation' stamp: 'mpw 11/14/1999 22:22'!
bytesPerRow
	^ self numComponents * self paddedWidth * self bitsPerComponent / 8.! !

!Form methodsFor: 'postscript generation'!
decodeArray
	^depth <= 8 ifTrue:['[1 0]'] ifFalse:['[0 1 0 1 0 1 ]'].
! !

!Form methodsFor: 'postscript generation' stamp: 'sma 6/14/2000 14:19'!
encodePostscriptOn: aStream 
	self unhibernate.
	^ self printPostscript: aStream operator: (self depth = 1
			ifTrue: ['imagemask']
			ifFalse: ['image'])! !

!Form methodsFor: 'postscript generation'!
numComponents
	^depth <= 8 ifTrue:[1] ifFalse:[3].
! !

!Form methodsFor: 'postscript generation'!
paddedWidth
	^ (self width + (self rowPadding-1)// self rowPadding) * self rowPadding.! !

!Form methodsFor: 'postscript generation' stamp: 'di 8/12/2000 10:43'!
printPostscript: aStream operator: operator
	aStream	preserveStateDuring:
		[:inner |
		inner rectclip: (0 @ 0 extent: (width) @ (height)).
		self setColorspaceOn: inner.
		inner print:'[ '; cr;
			print: '/ImageType 1'; cr;
			print: '/ImageMatrix [1 0 0 1 0 0]'; cr;
			print: '/MultipleDataSources false'; cr;
			print: '/DataSource level1 { { currentfile '; write: self bytesPerRow;print: ' string readhexstring pop }} bind { currentfile /ASCIIHexDecode filter } ifelse'; cr;
			print: '/Width '; write:self paddedWidth; cr;
			print: '/Height '; write:self height; cr;
			print: '/Decode '; print:self decodeArray;  cr;
			print: '/BitsPerComponent '; write: self bitsPerComponent; cr;
			print: 'makeDict '; print: operator; cr.
		self depth <= 8 ifTrue: [self storeHexBitsOn: inner].
		self depth = 16 ifTrue: [self store15To24HexBitsOn: inner].
		self depth = 32 ifTrue: [self store32To24HexBitsOn: inner].
		inner print: $>; cr.
		inner cr].
	aStream cr.! !

!Form methodsFor: 'postscript generation' stamp: 'mpw 11/15/1999 08:34'!
rowPadding
	^ 32 // self depth! !

!Form methodsFor: 'postscript generation'!
setColorspaceOn:aStream
	self numComponents = 1 ifTrue:[aStream print:'/DeviceGray setcolorspace 0 setgray'; cr.]
		ifFalse:[aStream print:'/DeviceRGB setcolorspace'; cr.].! !


!Form methodsFor: 'converting' stamp: 'ar 11/7/1999 20:29'!
asMorph
	^ImageMorph new image: self! !

!Form methodsFor: 'converting' stamp: 'ar 5/28/2000 12:07'!
asTexture
	| newForm |
	newForm _ B3DTexture extent: self extent depth: 32.
	(BitBlt current toForm: newForm)
		colorMap: (self colormapIfNeededForDepth: 32);
		copy: (self boundingBox)
		from: 0@0 in: self
		fillColor: nil rule: Form over.
	newForm interpolate: false.
	newForm wrap: false.
	newForm envMode: 0.
	^newForm! !


!Form methodsFor: 'Demo' stamp: 'RAA 9/28/1999 11:20'!
blankCopyOf: aRectangle scaledBy: scale

        ^ self class extent: (aRectangle extent * scale) truncated depth: depth! !


!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 18:17'!
balancedPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	self isExternalForm
		ifTrue:[^self bitPatternFor: aColor]
		ifFalse:[^aColor balancedPatternForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 6/8/2000 20:37'!
bitPatternFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	aColor isColor ifFalse:[^aColor bitPatternForDepth: self depth].
	self isExternalForm
		ifTrue:[^Bitmap with: (self pixelWordFor: aColor)]
		ifFalse:[^aColor bitPatternForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:12'!
colormapFromARGB
	"Return a ColorMap mapping from canonical ARGB space into the receiver.
	Note: This version is optimized for Squeak forms."
	| map nBits |
	self isExternalForm ifTrue:[^ColorMap mappingFromARGB: self rgbaBitMasks].
	self depth <= 8 ifTrue:[
		map _ Color colorMapIfNeededFrom: 32 to: self depth.
		map size = 512 ifTrue:[nBits _ 3].
		map size = 4096 ifTrue:[nBits _ 4].
		map size = 32768 ifTrue:[nBits _ 5].
		^ColorMap
			shifts: (Array 
						with: 3 * nBits - 24
						with: 2 * nBits - 16
						with: 1 * nBits - 8
						with: 0)
			masks: (Array
						with: (1 << nBits) - 1 << (24 - nBits)
						with: (1 << nBits) - 1 << (16 - nBits)
						with: (1 << nBits) - 1 << (8 - nBits)
						with: 0)
			colors: map].
	self depth = 16 ifTrue:[
		^ColorMap
			shifts: #(-9 -6 -3 0)
			masks: #(16rF80000 16rF800 16rF8 0)].
	self depth = 32 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0)
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth'! !

!Form methodsFor: 'color mapping' stamp: 'ar 6/8/2000 20:36'!
colormapIfNeededFor: destForm
	"Return a ColorMap mapping from the receiver to destForm."
	"Note: This is very magical for now - we really need to switch
	to palettes here but as long as this isn't done we need something
	that works."
	| map nBits myBits |
	(self isExternalForm or:[destForm isExternalForm]) ifTrue:[
		^self colormapFromARGB mappingTo: destForm colormapFromARGB].
	self depth = destForm depth ifTrue:[^nil]. "no conversion"
	self depth <= 8 ifTrue:["Always map indexed"
		^ColorMap
			shifts: nil
			masks: nil
			colors: (Color colorMapIfNeededFrom: self depth to: destForm depth)].
	(self depth = 16 and:[destForm depth = 32]) ifTrue:["Expand bits"
		^ColorMap 
			shifts: #( 9 6 3 0) 
			masks: #(16r7C00 16r3E0 16r1F 0)].
	(self depth = 32 and:[destForm depth = 16]) ifTrue:["Contract bits"
		^ColorMap
			shifts: #(-9 -6 -3 0)
			masks: #(16rF80000 16rF800 16rF8 0)].
	"destForm is indexed, I am non-indexed"
	map _ Color colorMapIfNeededFrom: self depth to: destForm depth.
	map size = 512 ifTrue:[nBits _ 3].
	map size = 4096 ifTrue:[nBits _ 4].
	map size = 32768 ifTrue:[nBits _ 5].
	myBits _ depth == 16 ifTrue:[5] ifFalse:[8].
	^ColorMap
		shifts: {	(3 * nBits) - (3 * myBits).
				(2 * nBits) - (2 * myBits).
				(1 * nBits) - (1 * myBits).
				0}
		masks: {	(1 bitShift: nBits) - 1 bitShift: (3 * myBits - nBits).
				(1 bitShift: nBits) - 1 bitShift: (2 * myBits - nBits).
				(1 bitShift: nBits) - 1 bitShift: (1 * myBits - nBits).
				0}
		colors: map.! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:14'!
colormapToARGB
	"Return a ColorMap mapping from the receiver into canonical ARGB space."
	self isExternalForm ifTrue:[^self colormapFromARGB inverseMap].
	self depth <= 8 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0)
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)
			colors: (Color colorMapIfNeededFrom: self depth to: 32)].
	self depth = 16 ifTrue:[
		^ColorMap 
			shifts: #( 9 6 3 0) 
			masks: #(16r7C00 16r3E0 16r1F 0)].
	self depth = 32 ifTrue:[
		^ColorMap
			shifts: #(0 0 0 0) 
			masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth'! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 18:18'!
pixelValueFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	self isExternalForm
		ifTrue:[^self colormapFromARGB mapPixel: (aColor pixelValueForDepth: 32)]
		ifFalse:[^aColor pixelValueForDepth: self depth]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 18:18'!
pixelWordFor: aColor
	"Return the pixel word for representing the given color on the receiver"
	| basicPattern |
	self isExternalForm ifFalse:[^aColor pixelWordForDepth: self depth].
	basicPattern _ self pixelValueFor: aColor.
	self depth = 32 
		ifTrue:[^basicPattern]
		ifFalse:[^aColor pixelWordFor: self depth filledWith: basicPattern]! !

!Form methodsFor: 'color mapping' stamp: 'ar 5/27/2000 20:14'!
rgbaBitMasks
	"Return the masks for specifying the R,G,B, and A components in the receiver"
	self depth <= 8
		ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self depth = 16
		ifTrue:[^#(16r7C00 16r3E0 16r1F 16r0)].
	self depth = 32
		ifTrue:[^#(16rFF0000 16rFF00 16rFF 16rFF000000)].
	self error:'Bad depth for form'! !


!Form methodsFor: 'testing' stamp: 'RAA 1/19/2001 15:04'!
appearsToBeSameCostumeAs: anotherForm

	(anotherForm isKindOf: self class) ifFalse: [^false].
	anotherForm depth = self depth ifFalse: [^false].
	^anotherForm bits = bits
! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
isBltAccelerated: ruleInteger for: sourceForm
	"Return true if the receiver can perform accelerated blts operations by itself"
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 15:04'!
isDisplayScreen
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/27/2000 16:54'!
isExternalForm
	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
isFillAccelerated: ruleInteger for: aColor
	"Return true if the receiver can perform accelerated fill operations by itself"
	^false! !

!Form methodsFor: 'testing' stamp: 'RAA 8/14/2000 10:00'!
isStatic

	^false! !

!Form methodsFor: 'testing' stamp: 'ar 5/28/2000 14:58'!
shouldPreserveContents
	"Return true if the receiver should preserve it's contents when flagged to be clean. Most forms can not be trivially restored by some drawing operation but some may."
	^true! !


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

Form class
	instanceVariableNames: ''!

!Form class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:07'!
dotOfSize: diameter
	"Create a form which contains a round black dot."
	| radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx |
	radius _ diameter//2.
	form _ self extent: diameter@diameter offset: (0@0) - (radius@radius).	
	bb _ (BitBlt current toForm: form)
		sourceX: 0; sourceY: 0;
		combinationRule: Form over;
		fillColor: Color black.
	rect _ form boundingBox.
	centerX _ rect center x.
	centerY _ rect center y.
	centerYBias _ rect height odd ifTrue: [0] ifFalse: [1].
	centerXBias _ rect width odd ifTrue: [0] ifFalse: [1].
	radiusSquared _ (rect height asFloat / 2.0) squared - 0.01.
	xOverY _ rect width asFloat / rect height asFloat.
	maxy _ rect height - 1 // 2.

	"First do the inner fill, and collect x values"
	0 to: maxy do:
		[:dy |
		dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated.
		bb	destX: centerX - centerXBias - dx
			destY: centerY - centerYBias - dy
			width: dx + dx + centerXBias + 1
			height: 1;
			copyBits.
		bb	destY: centerY + dy;
			copyBits].
	^ form
"
Time millisecondsToRun:
	[1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]]
"! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:27'!
extent: extentPoint
	"Answer an instance of me with a blank bitmap of depth 1."

	^ self extent: extentPoint depth: 1
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:36'!
extent: extentPoint depth: bitsPerPixel
	"Answer an instance of me with blank bitmap of the given dimensions and depth."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel
! !

!Form class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 23:44'!
extent: extentPoint depth: bitsPerPixel bits: aBitmap
	"Answer an instance of me with blank bitmap of the given dimensions and depth."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:35'!
extent: extentPoint depth: bitsPerPixel fromArray: anArray offset: offsetPoint 
	"Answer an instance of me with a pixmap of the given depth initialized from anArray."

	^ (self extent: extentPoint depth: bitsPerPixel)
		offset: offsetPoint;
		initFromArray: anArray
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:33'!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer an instance of me of depth 1 with bitmap initialized from anArray."

	^ (self extent: extentPoint depth: 1)
		offset: offsetPoint;
		initFromArray: anArray
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:28'!
extent: extentPoint fromStipple: fourNibbles
	"Answer an instance of me with bitmap initialized from
	a repeating 4x4 bit stipple encoded in a 16-bit constant."
	| nibble |
	^ (self extent: extentPoint depth: 1)
		initFromArray: ((1 to: 4) collect:
				[:i | nibble _ (fourNibbles bitShift: -4*(4-i)) bitAnd: 16rF.
				16r11111111 * nibble])  "fill 32 bits with each 4-bit nibble"
! !

!Form class methodsFor: 'instance creation' stamp: 'jm 3/27/98 16:26'!
extent: extentPoint offset: offsetPoint 
	"Answer an instance of me with a blank bitmap of depth 1."

	^ (self extent: extentPoint depth: 1) offset: offsetPoint
! !

!Form class methodsFor: 'instance creation' stamp: 'tk 2/19/1999 07:20'!
fromBinaryStream: aBinaryStream
	"Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format."

	| firstByte |
	aBinaryStream binary.
	firstByte _ aBinaryStream next.
	firstByte = 1 ifTrue: [
		"old Squeakform format"
		^ self new readFromOldFormat: aBinaryStream].
	firstByte = 2 ifTrue: [
		"new Squeak form format"
		^ self new readFrom: aBinaryStream].
	firstByte = $B asciiValue ifTrue: [
		"BMP format"
		aBinaryStream skip: - 1.
		^ self fromBMPFile: aBinaryStream].

	"Try for JPG, GIF, or PCX..."
	"Note: The following call closes the stream."
	^ Smalltalk imageReaderClass formFromStream: aBinaryStream
! !

!Form class methodsFor: 'instance creation'!
fromDisplay: aRectangle 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen defined by aRectangle."

	^ (self extent: aRectangle extent depth: Display depth)
		fromDisplay: aRectangle! !

!Form class methodsFor: 'instance creation'!
fromDisplay: aRectangle using: oldForm
	"Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead."

	((oldForm ~~ nil) and: [oldForm extent = aRectangle extent])
		ifTrue:
			[oldForm fromDisplay: aRectangle.
			 ^ oldForm]
		ifFalse:
			[^ self fromDisplay: aRectangle]! !

!Form class methodsFor: 'instance creation' stamp: 'jm 1/11/1999 10:42'!
fromFileNamed: fileName
	"Read a Form or ColorForm from the given file."

	| file form |
	file _ (FileStream readOnlyFileNamed: fileName) binary.
	form _ self fromBinaryStream: file.
	file close.
	^ form
! !

!Form class methodsFor: 'instance creation'!
fromUser
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	1@1."

	^self fromUser: 1 @ 1! !

!Form class methodsFor: 'instance creation'!
fromUser: aPoint 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	aPoint."

	^ self fromDisplay: (Rectangle fromUser: aPoint)! !

!Form class methodsFor: 'instance creation' stamp: 'jm 12/5/97 19:32'!
fromUserWithExtent: anExtent
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen whose origin is designated by the user and whose size is anExtent"

	^ self fromDisplay: (Rectangle originFromUser: anExtent)

"(Form fromUserWithExtent: 50@50) displayAt: 10@10"! !


!Form class methodsFor: 'mode constants'!
and
	"Answer the integer denoting the logical 'and' combination rule."

	^1! !

!Form class methodsFor: 'mode constants'!
blend
	"Answer the integer denoting BitBlt's alpha blend combination rule."
	^24! !

!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'!
blendAlpha
	"Answer the integer denoting BitBlt's blend-with-constant-alpha rule."

	^ 30! !

!Form class methodsFor: 'mode constants'!
erase
	"Answer the integer denoting mode erase."

	^4! !

!Form class methodsFor: 'mode constants'!
erase1bitShape
	"Answer the integer denoting mode erase."

	^ 26! !

!Form class methodsFor: 'mode constants'!
oldErase1bitShape
	"Answer the integer denoting mode erase."

	^ 17! !

!Form class methodsFor: 'mode constants'!
oldPaint
	"Answer the integer denoting the 'paint' combination rule."

	^16! !

!Form class methodsFor: 'mode constants'!
over
	"Answer the integer denoting mode over."

	^3! !

!Form class methodsFor: 'mode constants'!
paint
	"Answer the integer denoting the 'paint' combination rule."

	^25! !

!Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'!
paintAlpha
	"Answer the integer denoting BitBlt's paint-with-constant-alpha rule."

	^ 31! !

!Form class methodsFor: 'mode constants'!
reverse
	"Answer the integer denoting mode reverse."

	^6! !

!Form class methodsFor: 'mode constants'!
under
	"Answer the integer denoting mode under."

	^7! !


!Form class methodsFor: 'examples'!
exampleBorder    "Form exampleBorder"
	"This example demonstrates the border finding algorithm. Start
	by having the user sketch on the screen (end with option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of the region to be
	outlined, and the region begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeBorder: Color blue width: 2 interiorPoint: interiorPoint
			sharpCorners: false internal: false].
	f displayOn: Display at: r origin	! !

!Form class methodsFor: 'examples'!
exampleEdits
	"In Form category editing are messages edit and bitEdit that make it possible to 
	create editors on instances of Form. 
	 
	This is the general form editor:
	| f | 
	f _ Form fromUser. 
	f edit. 
	 
	This is the general bit editor:
	| f | 
	f _ Form fromUser. 
	f bitEdit."! !

!Form class methodsFor: 'examples'!
exampleMagnify

	| f m |
	f _ Form fromUser.
	m _ f magnify: f boundingBox by: 5 @ 5.
	m displayOn: Display at: Sensor waitButton

	"Form exampleMagnify."! !

!Form class methodsFor: 'examples'!
exampleShrink

	| f s |
	f _ Form fromUser.
	s _ f shrink: f boundingBox by: 2 @ 5.
	s displayOn: Display at: Sensor waitButton	

	"Form exampleShrink."! !

!Form class methodsFor: 'examples'!
exampleSketch
	"This is a simple drawing algorithm to get a sketch on the display screen.
	Draws whenever mouse button down.  Ends with option-click."
	| aPen color |
	aPen _ Pen new.
	color _ 0.
	[Sensor yellowButtonPressed]
		whileFalse:
		[aPen place: Sensor cursorPoint; color: (color _ color + 1).
		[Sensor redButtonPressed]
			whileTrue: [aPen goto: Sensor cursorPoint]].
	Sensor waitNoButton.

	"Form exampleSketch"! !

!Form class methodsFor: 'examples'!
exampleSpaceFill    "Form exampleSpaceFill"
	"This example demonstrates the area filling algorithm. Starts by having
	the user sketch on the screen (ended by option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of some region to be
	filled, and the filling begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeFill: Color gray interiorPoint: interiorPoint].
	f displayOn: Display at: r origin	! !

!Form class methodsFor: 'examples'!
makeStar  "See the similar example in OpaqueForm"
	| sampleForm pen |
	sampleForm _ Form extent: 50@50.  "Make a form"
	pen _ Pen newOnForm: sampleForm.
	pen place: 24@50; turn: 18.		"Draw a 5-pointed star on it."
	1 to: 5 do: [:i | pen go: 19; turn: 72; go: 19; turn: -144].
	^ sampleForm
"
Form makeStar follow: [Sensor cursorPoint]
				while: [Sensor noButtonPressed]
"! !

!Form class methodsFor: 'examples' stamp: 'tk 7/4/2000 12:08'!
toothpaste: diam		"Display restoreAfter: [Form toothpaste: 30]"
	"Draws wormlike lines by laying down images of spheres.
	See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352.
	Draw with mouse button down; terminate by option-click."
	| facade ball filter point queue port color q colors colr colr2 |
	colors _ Display depth = 1
		ifTrue: [Array with: Color black]
		ifFalse: [Color red wheel: 12].
	facade _ Form extent: diam@diam offset: (diam//-2) asPoint.
	(Form dotOfSize: diam) displayOn: facade
			at: (diam//2) asPoint clippingBox: facade boundingBox
			rule: Form under fillColor: Color white.
	#(1 2 3) do:
		[:x |  "simulate facade by circles of gray"
		(Form dotOfSize: x*diam//5) displayOn: facade
			at: (diam*2//5) asPoint clippingBox: facade boundingBox
			rule: Form under
			fillColor: (Color perform: 
					(#(black gray lightGray) at: x)).
		"facade displayAt: 50*x@50"].
	ball _ Form dotOfSize: diam.
	color _ 8.
	[ true ] whileTrue:
		[port _ BitBlt current toForm: Display.
		"Expand 1-bit forms to any pixel depth"
		port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
		queue _ OrderedCollection new: 32.
		16 timesRepeat: [queue addLast: -20@-20].
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ Sensor cursorPoint.
		colr _ colors atWrap: (color _ color + 5).  "choose increment relatively prime to colors size"
		colr2 _ colr alphaMixed: 0.3 with: Color white.
		[Sensor redButtonPressed or: [queue size > 0]] whileTrue:
			[filter _ filter * 4 + Sensor cursorPoint // 5.
			point _ Sensor redButtonPressed
				ifTrue: [filter] ifFalse: [-20@-20].
			port copyForm: ball to: point rule: Form paint fillColor: colr.
			(q _ queue removeFirst) == nil ifTrue: [^ self].	"exit"
			Display depth = 1
				ifTrue: [port copyForm: facade to: q rule: Form erase]
				ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2].
			Sensor redButtonPressed ifTrue: [queue addLast: point]]].
! !

!Form class methodsFor: 'examples'!
xorHack: size  "Display restoreAfter: [Form xorHack: 256]"
	"Draw a smiley face or stick figure, and end with option-click.
	Thereafter image gets 'processed' as long as you have button down.
	If you stop at just the right time, you'll see you figure upside down,
	and at the end of a full cycle, you'll see it perfectly restored.
	Dude -- this works in color too!!"
	| rect form i bb |
	rect _ 5@5 extent: size@size.
	Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
	Display border: (rect topRight - (0@2) extent: rect extent*2 + 4) width: 2.
	Form exampleSketch.
	form _ Form fromDisplay: rect.
	bb _ form boundingBox.
	i _ 0.
	[Sensor yellowButtonPressed] whileFalse:
		[[Sensor redButtonPressed] whileTrue:
			[i _ i + 1.
			(Array with: 0@1 with: 0@-1 with: 1@0 with: -1@0) do:
				[:d | form copyBits: bb from: form at: d
					clippingBox: bb rule: Form reverse fillColor: nil].
			form displayAt: rect topLeft.
			i+2\\size < 4 ifTrue: [(Delay forMilliseconds: 300) wait]].
		(form magnify: form boundingBox by: 2@2) displayAt: rect topRight + (2@0).
		Sensor waitButton].! !


!Form class methodsFor: 'shut down' stamp: 'ar 5/28/2000 23:35'!
shutDown  "Form shutDown"
	"Compress all instances in the system.  Will decompress on demand..."
	Form allInstancesDo: [:f | f hibernate].
	ColorForm allInstancesDo: [:f | f hibernate].! !


!Form class methodsFor: 'BMP file reading' stamp: 'jm 4/18/98 19:11'!
bmp24BitPixelDataFrom: aBinaryStream width: w height: h
	"Read 24-bit pixel data from the given a BMP stream."

	| form rowBytes line blackPixelValue pixelLine pixIndex rgb |
	form _ Form extent: w@h depth: 32.
	rowBytes _ (((24 * w) + 31) // 32) * 4.
	line _ Form extent: w@1 depth: 32.
	blackPixelValue _ Color black pixelValueForDepth: 32.
	1 to: h do: [:i |
		pixelLine _ aBinaryStream next: rowBytes.
		pixIndex _ 1.
		1 to: w do: [:j |
			rgb _ (pixelLine at: pixIndex) +
				   ((pixelLine at: pixIndex + 1) bitShift: 8) +
				   ((pixelLine at: pixIndex + 2) bitShift: 16).
			"BMP's don't support transparency, so map zero pixels to black"
			rgb = 0 ifTrue: [rgb _ blackPixelValue].
			line bits at: j put: rgb.
			pixIndex _ pixIndex + 3].
		form copy: line boundingBox from: line to: 0@(h - i) rule: Form over].
	^ form
! !

!Form class methodsFor: 'BMP file reading' stamp: 'di 2/3/1999 07:44'!
bmpColorsFrom: aBinaryStream count: colorCount depth: depth
	"Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors."

	| maxLevel colors b g r |
	colorCount = 0 ifTrue: [  "this BMP file does not have a color map"
		"default monochrome color map"
		depth = 1 ifTrue: [^ Array with: Color white with: Color black].
		"default gray-scale color map"
		maxLevel _ (2 raisedTo: depth) - 1.
		^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]].

	colors _ Array new: colorCount.
	1 to: colorCount do: [:i |
		b _ aBinaryStream next.
		g _ aBinaryStream next.
		r _ aBinaryStream next.
		aBinaryStream skip: 1.
		colors at: i put: (Color r: r g: g b: b range: 255)].
	^ colors
! !

!Form class methodsFor: 'BMP file reading' stamp: 'jm 4/18/98 20:03'!
bmpPixelDataFrom: aBinaryStream width: w height: h depth: d
	"Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, or 8."

	| form bytesPerRow pixelData pixelLine startIndex |
	form _ ColorForm extent: w@h depth: d.  "color map filled in by caller"
	bytesPerRow _ (((d* w) + 31) // 32) * 4.
	pixelData _ ByteArray new: bytesPerRow * h.
	h to: 1 by: -1 do: [:y |
		pixelLine _ aBinaryStream next: bytesPerRow.
		startIndex _ ((y - 1) * bytesPerRow) + 1.
		pixelData
			replaceFrom: startIndex
			to: startIndex + bytesPerRow - 1
			with: pixelLine
			startingAt: 1].
	form bits copyFromByteArray: pixelData.
	^ form
! !

!Form class methodsFor: 'BMP file reading' stamp: 'jm 1/12/1999 17:37'!
fromBMPFile: aBinaryStream
	"Read a BMP format image from the given binary stream."
	"Form fromBMPFile:
		(HTTPSocket
			httpGet: 'http://anHTTPServer/squeak/squeakers.bmp'
			accept: 'image/bmp')"

	| fType fSize reserved pixDataStart hdrSize w h planes d
      compressed colorCount colors colorForm |
	(aBinaryStream isMemberOf: String) ifTrue: [^ nil].  "a network error message"
	aBinaryStream binary.
	fType _ aBinaryStream nextLittleEndianNumber: 2.
	fSize _ aBinaryStream nextLittleEndianNumber: 4.
	reserved _ aBinaryStream nextLittleEndianNumber: 4.
	pixDataStart _ aBinaryStream nextLittleEndianNumber: 4.
	hdrSize _ aBinaryStream nextLittleEndianNumber: 4.
	w _ aBinaryStream nextLittleEndianNumber: 4.
	h _ aBinaryStream nextLittleEndianNumber: 4.
	planes _ aBinaryStream nextLittleEndianNumber: 2.
	d _ aBinaryStream nextLittleEndianNumber: 2.
	compressed _ aBinaryStream nextLittleEndianNumber: 4.
	aBinaryStream nextLittleEndianNumber: 4.  "biSizeImage"
	aBinaryStream nextLittleEndianNumber: 4.  "biXPelsPerMeter"
	aBinaryStream nextLittleEndianNumber: 4.  "biYPelsPerMeter"
	colorCount _ aBinaryStream nextLittleEndianNumber: 4.
	aBinaryStream nextLittleEndianNumber: 4.  "biClrImportant"

	((fType = 19778) & (reserved = 0) & (planes = 1) &
	 (hdrSize = 40) & (fSize <= aBinaryStream size))
		ifFalse: [self error: 'Bad BMP file header'].
	compressed = 0
		ifFalse: [self error: 'Can only read uncompressed BMP files'].

	d = 24 ifTrue: [
		aBinaryStream position: pixDataStart.
		^ self bmp24BitPixelDataFrom: aBinaryStream width: w height: h].

	"read the color map"
	"Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map"
	colorCount _ (pixDataStart - 54) // 4.
	colors _ self bmpColorsFrom: aBinaryStream count: colorCount depth: d.

	"read the pixel data"
	aBinaryStream position: pixDataStart.
	colorForm _ self bmpPixelDataFrom: aBinaryStream width: w height: h depth: d.
	colorForm colors: colors.
	^ colorForm
! !

!Form class methodsFor: 'BMP file reading' stamp: 'mdr 8/31/2000 19:01'!
fromBMPFileNamed: fileName
	"Form fromBMPFileNamed: 'FulS.bmp'"

	| fileStream result |
	fileStream _ (FileStream readOnlyFileNamed: fileName) binary.
	result _ self fromBMPFile: fileStream.
	fileStream close.
	^ result
! !
Object subclass: #FormButtonCache
	instanceVariableNames: 'offset form value initialState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormButtonCache commentStamp: '<historical>' prior: 0!
My instances are used to save information needed to construct the switch in a menu for a FormEditor. A collection of my instances is stored as a class variable of FormMenuView.!


!FormButtonCache methodsFor: 'accessing'!
form
	"Answer the receiver's form, the image of the button on the screen."

	^form! !

!FormButtonCache methodsFor: 'accessing'!
form: aForm
	"Set the receiver's form to be the argument."

	form _ aForm! !

!FormButtonCache methodsFor: 'accessing'!
initialState
	"Answer the receiver's initial state, on or off."

	^initialState! !

!FormButtonCache methodsFor: 'accessing'!
initialState: aBoolean
	"Set the receiver's initial state, on or off, to be the argument."

	initialState _ aBoolean! !

!FormButtonCache methodsFor: 'accessing'!
offset
	"Answer the receiver's offset, its relative position for displaying the 
	button."

	^offset! !

!FormButtonCache methodsFor: 'accessing'!
offset: anInteger
	"Set the receiver's offset."

	offset _ anInteger! !

!FormButtonCache methodsFor: 'accessing'!
value
	"Answer the receiver's value, the keyboard key that selects the button."

	^value! !

!FormButtonCache methodsFor: 'accessing'!
value: aCharacter
	"Set the receiver's key character."

	value _ aCharacter! !
Canvas subclass: #FormCanvas
	instanceVariableNames: 'origin clipRect form port shadowColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!FormCanvas commentStamp: '<historical>' prior: 0!
Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending.!


!FormCanvas methodsFor: 'initialize-release' stamp: 'ar 5/27/2000 21:51'!
finish
	"If there are any pending operations on the receiver complete them. Do not return before all modifications have taken effect."
	form finish! !

!FormCanvas methodsFor: 'initialize-release' stamp: 'ar 2/17/2000 00:21'!
reset

	origin _ 0@0.							"origin of the top-left corner of this cavas"
	clipRect _ (0@0 corner: 10000@10000).		"default clipping rectangle"
	self shadowColor: nil.! !


!FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:11'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver"
	^form allocateForm: extentPoint! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:06'!
clipRect
	"Return the currently active clipping rectangle"
	^ clipRect translateBy: origin negated! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 14:42'!
contentsOfArea: aRectangle into: aForm
	self flush.
	port contentsOfArea: ((aRectangle origin + origin) negated extent: aRectangle extent)
		into: aForm.
	^aForm! !

!FormCanvas methodsFor: 'accessing'!
depth

	^ form depth
! !

!FormCanvas methodsFor: 'accessing'!
extent

	^ form extent! !

!FormCanvas methodsFor: 'accessing'!
form

	^ form! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'!
origin
	"Return the current origin for drawing operations"
	^ origin! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'!
shadowColor
	^shadowColor! !

!FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'!
shadowColor: aColor
	shadowColor _ aColor! !


!FormCanvas methodsFor: 'testing' stamp: 'ar 2/17/2000 00:24'!
isShadowDrawing
	^ self shadowColor notNil! !

!FormCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:08'!
isVisible: aRectangle
	"Optimization"
	(aRectangle right + origin x) < clipRect left	ifTrue: [^ false].
	(aRectangle left + origin x) > clipRect right	ifTrue: [^ false].
	(aRectangle bottom + origin y) < clipRect top	ifTrue: [^ false].
	(aRectangle top + origin y) > clipRect bottom	ifTrue: [^ false].
	^ true
! !


!FormCanvas methodsFor: 'copying' stamp: 'jm 8/2/97 14:00'!
copy
	"Make a copy the receiver on the same underlying Form but with its own grafPort."

	^ self clone resetGrafPort
! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'!
copyClipRect: aRectangle
	^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)
! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOffset: aPoint
	^ self copyOrigin: origin + aPoint clipRect: clipRect! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOffset: aPoint clipRect: sourceClip
	"Make a copy of me offset by aPoint, and further clipped
	by sourceClip, a rectangle in the un-offset coordinates"
	^ self copyOrigin: aPoint + origin
		clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! !

!FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'!
copyOrigin: aPoint clipRect: aRectangle
	"Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."
	^ self copy
		setOrigin: aPoint
		clipRect: (clipRect intersect: aRectangle)! !


!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2000 15:50'!
fillColor: c
	"Note: This always fills, even if the color is transparent."
	self setClearColor: c.
	port fillRect: form boundingBox offset: origin.! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 2/17/2000 00:12'!
line: pt1 to: pt2 brushForm: brush
	| offset |
	offset _ origin.
	self setPaintColor: Color black.
	port sourceForm: brush; fillColor: nil;
		sourceRect: brush boundingBox;
		colorMap: (brush colormapIfNeededForDepth: self depth);
		drawFrom: (pt1 + offset) to: (pt2 + offset)! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 2/16/2000 22:07'!
line: pt1 to: pt2 width: w color: c
	| offset |
	offset _ origin - (w // 2) asPoint.
	self setFillColor: c.
	port width: w; height: w;
		drawFrom: (pt1 + offset) to: (pt2 + offset)! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 2/17/2000 00:23'!
paragraph: para bounds: bounds color: c

	| scanner |
	self setPaintColor: c.
	scanner _ port displayScannerFor: para
		foreground: (self shadowColor ifNil:[c]) background: Color transparent
		ignoreColorChanges: self shadowColor notNil.
	para displayOn: self using: scanner at: (bounds topLeft + origin).
! !

!FormCanvas methodsFor: 'drawing'!
point: pt color: c

	form colorAt: (pt + origin) put: c.! !

!FormCanvas methodsFor: 'drawing' stamp: 'ar 5/18/2000 18:35'!
text: s bounds: boundsRect font: fontOrNil color: c
	| scanner |
	scanner _ DisplayScanner quickPrintOn: form
				box: ((boundsRect translateBy: origin) intersect: clipRect) truncated
				font: fontOrNil
				color: (self shadowColor ifNil:[c]).
	scanner drawString: s at: boundsRect topLeft + origin! !


!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	^aBlock value: (self copyClipRect: aRectangle)! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'RAA 8/15/2000 10:53'!
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	^super 
		transform2By: aDisplayTransform 
		clippingTo: aClipRect 
		during: aBlock 
		smoothing: cellSize
! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 5/25/2000 18:04'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock	 smoothing: cellSize

	"Note: This method has been originally copied from TransformationMorph."
	| innerRect patchRect sourceQuad warp start subCanvas |
	(aDisplayTransform isPureTranslation) ifTrue:[
		^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
							clipRect: aClipRect)
	].
	"Prepare an appropriate warp from patch to innerRect"
	innerRect _ aClipRect.
	patchRect _ aDisplayTransform globalBoundsToLocal: innerRect.
	sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect)
					collect: [:p | p - patchRect topLeft].
	warp _ self warpFrom: sourceQuad toRect: innerRect.
	warp cellSize: cellSize.

	"Render the submorphs visible in the clipping rectangle, as patchForm"
	start _ (self depth = 1 and: [self isShadowDrawing not])
		"If this is true B&W, then we need a first pass for erasure."
		ifTrue: [1] ifFalse: [2].
	start to: 2 do:
		[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
		subCanvas _ self class extent: patchRect extent depth: self depth.
		i=1	ifTrue: [subCanvas shadowColor: Color black.
					warp combinationRule: Form erase]
			ifFalse: [self isShadowDrawing ifTrue:
					[subCanvas shadowColor: self shadowColor].
					warp combinationRule: Form paint].
		subCanvas translateBy: patchRect topLeft negated
			during:[:offsetCanvas| aBlock value: offsetCanvas].
		warp sourceForm: subCanvas form; warpBits.
		warp sourceForm: nil.  subCanvas _ nil "release space for next loop"]
! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:03'!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	^aBlock value: (self copyOffset: delta clipRect: aRectangle)! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	^aBlock value: (self copyOffset: delta)! !

!FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:55'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)! !


!FormCanvas methodsFor: 'other' stamp: 'ar 11/11/1998 22:57'!
asBalloonCanvas
	^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect! !

!FormCanvas methodsFor: 'other'!
flushDisplay
		Display deferUpdates: false; forceDisplayUpdate.! !

!FormCanvas methodsFor: 'other'!
forceToScreen:rect
	^Display forceToScreen:rect.
! !

!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 17:07'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll:' on: '; print: form.! !

!FormCanvas methodsFor: 'other'!
showAt: pt

	^ form displayAt: pt! !

!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:09'!
showAt: pt invalidRects: updateRects
	| blt |
	blt _ (BitBlt current toForm: Display)
		sourceForm: form;
		combinationRule: Form over.
	updateRects do:
		[:rect |
		blt sourceRect: rect;
			destOrigin: rect topLeft + pt;
			copyBits]! !

!FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:12'!
warpFrom: sourceQuad toRect: destRect
        ^ (WarpBlt current toForm: port destForm)
                combinationRule: Form paint;
                sourceQuad: sourceQuad destRect: (destRect translateBy: origin);
                clipRect: clipRect! !


!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:52'!
portClass
	"Return the class used as port"
	^Display defaultBitBltClass asGrafPort! !

!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:24'!
privateClipRect

	^clipRect! !

!FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:25'!
privatePort

	^port! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'!
resetGrafPort
	"Private!! Create a new grafPort for a new copy."

	port _ self portClass toForm: form.
	port clipRect: clipRect.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:43'!
setClearColor: aColor
	"Install a new clear color - e.g., a color is used for clearing the background"
	| clearColor |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	clearColor _ aColor ifNil:[Color transparent].
	clearColor isColor ifFalse:[
		(clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: clearColor; combinationRule: Form over].
	"Okay, so clearColor really *is* a color"
	port sourceForm: nil.
	port combinationRule: Form over.
	port fillPattern: clearColor.
	self depth = 8 ifTrue:[
		"Use a stipple pattern"
		port fillColor: (clearColor balancedPatternForDepth: 8)].
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:45'!
setFillColor: aColor
	"Install a new color used for filling."
	| screen patternWord fillColor |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	fillColor _ self shadowColor ifNil:[aColor].
	fillColor ifNil:[fillColor _ Color transparent].
	fillColor isColor ifFalse:[
		(fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: fillColor; combinationRule: Form over].
	"Okay, so fillColor really *is* a color"
	port sourceForm: nil.
	fillColor isTranslucent ifFalse:[
		port combinationRule: Form over.
		port fillPattern: fillColor.
		self depth = 8 ifTrue:[
			"In 8 bit depth it's usually a good idea to use a stipple pattern"
			port fillColor: (fillColor balancedPatternForDepth: 8)].
		^self].
	"fillColor is some translucent color"

	(port isFXBlt and:[self depth >= 8]) ifTrue:[
		"FXBlt setup for full alpha mapped transfer"
		port fillColor: (fillColor bitPatternForDepth: 32).
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		^port combinationRule: Form blend].

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha masked transfer"
		port fillPattern: fillColor.
		self depth = 16
			ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30]
			ifFalse:[port combinationRule: Form blend].
		^self].
	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: fillColor alpha depth: self depth.
	patternWord _ fillColor pixelWordForDepth: self depth.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/25/2000 17:25'!
setForm: aForm

	self reset.
	form _ aForm.
	port _ self portClass toForm: form.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'!
setOrigin: aPoint clipRect: aRectangle

	origin _ aPoint.
	clipRect _ aRectangle.
	port clipRect: aRectangle.
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:49'!
setPaintColor: aColor
	"Install a new color used for filling."
	| paintColor screen patternWord |
	port isFXBlt ifTrue:[port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil].
	paintColor _ self shadowColor ifNil:[aColor].
	paintColor ifNil:[paintColor _ Color transparent].
	paintColor isColor ifFalse:[
		(paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color'].
		^port fillPattern: paintColor; combinationRule: Form paint].
	"Okay, so paintColor really *is* a color"
	port sourceForm: nil.
	(paintColor isTranslucent) ifFalse:[
		port fillPattern: paintColor.
		port combinationRule: Form paint.
		self depth = 8 ifTrue:[
			port fillColor: (paintColor balancedPatternForDepth: 8)].
		^self].
	"paintColor is translucent color"
	(port isFXBlt and:[self depth >= 8]) ifTrue:[
		"FXBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		port fillColor: (paintColor bitPatternForDepth: 32).
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		port combinationRule: Form blend.
		^self].

	self depth > 8 ifTrue:[
		"BitBlt setup for alpha mapped transfer"
		port fillPattern: paintColor.
		self depth = 16
			ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31]
			ifFalse:[port combinationRule: Form blend].
		^self].

	"Can't represent actual transparency -- use stipple pattern"
	screen _ Color translucentMaskFor: paintColor alpha depth: self depth.
	patternWord _ paintColor pixelWordForDepth: self depth.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint
! !

!FormCanvas methodsFor: 'private' stamp: 'ar 5/28/2000 14:50'!
setStencilColor: aColor form: sourceForm
	"Install a new color used for stenciling through FXBlt.
	Stenciling in general is done mapping all colors of source form
	to the stencil color and installing the appropriate source key.
	However, due to possible transparency we may have to install the
	color map as source map so that sourceForm gets mapped to a 32bit
	ARGB pixel value before the color combination is done. If we don't
	need translucency we can just use the regular color map (faster!!)"
	| stencilColor screen patternWord |
	port isFXBlt ifFalse:[^self]. "Not appropriate for BitBlt"
	port sourceMap: nil; destMap: nil; colorMap: nil; sourceKey: nil.
	stencilColor _ self shadowColor ifNil:[aColor].
	stencilColor isColor ifFalse:[^self]. "No way"
	(stencilColor isTranslucent) ifFalse:[
		"If the paint color is not translucent we can use a simpler
		transformation going through a single color map."
		port sourceKey: 0. "The transparent source key"
		port fillPattern: stencilColor.
		port colorMap: (ColorMap colors: port fillColor).
		port fillColor: nil.
		^port combinationRule: Form over].
	(self depth >= 8) ifTrue:[
		"For transparent stenciling, things are more complicated.
		We need to install the transparent stencil color as source map
		so that all colors are mapped to the stencil color and afterwards
		blended with the destination."
		port sourceKey: 0. "The transparent source key"
		port fillPattern: stencilColor.
		port destMap: form colormapToARGB.
		port colorMap: form colormapFromARGB.
		port sourceMap: (ColorMap colors: (stencilColor bitPatternForDepth: 32)).
		port fillColor: nil.
		port combinationRule: Form blend.
		^self].
	"Translucent stenciling in < 8bit depth requires three parts,
	a color map, a fill pattern and the appropriate combination rule."
	port colorMap: (ColorMap colors: (Color maskingMap: form depth)).
	screen _ Color translucentMaskFor: stencilColor alpha depth: self depth.
	patternWord _ stencilColor pixelWordForDepth: self depth.
	port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]).
	port combinationRule: Form paint! !


!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:17'!
asShadowDrawingCanvas
	"Note: This is sort of an optimization here since since the logic is all there"
	^self copy shadowColor: (Color black alpha: 0.5)! !

!FormCanvas methodsFor: 'converting' stamp: 'ar 2/17/2000 00:16'!
asShadowDrawingCanvas: aColor
	"Note: This is sort of an optimization here since since the logic is all there"
	^self copy shadowColor: aColor! !


!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 7/28/2000 07:39'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle.! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 10/26/2000 19:26'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |
	self shadowColor ifNotNil:
		[^self fillRectangle: aRectangle color: aFillStyle asColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	(aFillStyle isSolidFill) 
		ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 5/14/2000 15:50'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	| rect |
	rect _ r translateBy: origin.
	"draw the border of the rectangle"
	borderColor isTransparent ifFalse:[
		self setFillColor: borderColor.
		(r area > 10000 or: [fillColor isTranslucent]) ifTrue: [
			port frameRect: rect borderWidth: borderWidth.
		] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle
					than to compute and fill the border rects"
					port fillRect: rect offset: origin]].

	"fill the inside"
	fillColor isTransparent ifFalse:
		[self setFillColor: fillColor.
		port fillRect: (rect insetBy: borderWidth) offset: origin].! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 2/16/2000 22:07'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor

	| w h rect |
	"First use quick code for top and left borders and fill"
	self frameAndFillRectangle: r
		fillColor: fillColor
		borderWidth: borderWidth
		borderColor: topLeftColor.

	"Now use slow code for bevelled bottom and right borders"
	bottomRightColor isTransparent ifFalse: [
		borderWidth isNumber
			ifTrue: [w _ h _ borderWidth]
			ifFalse: [w _ borderWidth x.   h _ borderWidth y].
		rect _ r translateBy: origin.
		self setFillColor: bottomRightColor.
		port 
			 frameRectRight: rect width: w;
			 frameRectBottom: rect height: h].
! !

!FormCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 9/20/2000 17:16'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	^aFillStyle
		displayOnPort: (port clippedBy: (aRectangle translateBy: origin)) 
		at: aRectangle origin + origin
! !


!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 15:21'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self asBalloonCanvas
		fillOval: aRectangle
		fillStyle: aFillStyle
		borderWidth: bw
		borderColor: bc! !

!FormCanvas methodsFor: 'drawing-ovals' stamp: 'ar 1/30/2001 23:10'!
fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor
	| rect |
	"draw the border of the oval"
	rect _ (r translateBy: origin) truncated.
	borderColor isTransparent ifFalse:[
		self setFillColor: borderColor.
		(r area > 10000 or: [fillColor isTranslucent]) 
			ifTrue: [port frameOval: rect borderWidth: borderWidth]
			ifFalse: [port fillOval: rect]]. "faster this way"
	"fill the inside"
	fillColor isTransparent ifFalse:
		[self setFillColor: fillColor.
		port fillOval: (rect insetBy: borderWidth)].
! !

!FormCanvas methodsFor: 'drawing-ovals' stamp: 'RAA 11/6/2000 16:42'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."

	self flag: #bob.		"this and its siblings could be moved up to Canvas with the
						right #balloonFillOval:..."

	self shadowColor ifNotNil:
		[^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !


!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 6/18/1999 08:57'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	"Generalize for the BalloonCanvas"
	^self drawPolygon: vertices fillStyle: aColor borderWidth: bw borderColor: bc! !

!FormCanvas methodsFor: 'drawing-polygons' stamp: 'ar 12/6/2000 14:59'!
drawPolygon: vertices fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Use a BalloonCanvas"
	self asBalloonCanvas 
		drawPolygon: vertices asArray
		fillStyle: (self shadowColor ifNil:[aFillStyle])
		borderWidth: bw 
		borderColor: bc! !



!FormCanvas methodsFor: 'drawing-images' stamp: 'ar 5/28/2000 23:47'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule 
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."
	port isFXBlt 
		ifTrue:[port sourceKey: nil; sourceMap: nil; destMap: nil;
					colorMap: (aForm colormapIfNeededFor: form); fillPattern: nil]
		ifFalse:[port colorMap: (aForm colormapIfNeededForDepth: form depth); fillColor: nil].
	port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.! !

!FormCanvas methodsFor: 'drawing-images' stamp: 'ar 5/28/2000 14:40'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	port isFXBlt "FXBlt has a very different setup"
		ifTrue:[self setStencilColor: aColor form: stencilForm]
		ifFalse:[self setPaintColor: aColor.
				port colorMap: (Color maskingMap: stencilForm depth)].
	port stencil: stencilForm
		at: aPoint + origin
		sourceRect: sourceRect.! !


!FormCanvas methodsFor: 'drawing-general' stamp: 'ar 10/26/2000 19:41'!
roundCornersOf: aMorph during: aBlock
	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: aMorph bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self
		displayBlock: aBlock
		borderWidth: aMorph borderWidth
		corners: aMorph roundedCorners! !

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

FormCanvas class
	instanceVariableNames: ''!

!FormCanvas class methodsFor: 'instance creation'!
extent: aPoint

	^ self extent: aPoint depth: Display depth
! !

!FormCanvas class methodsFor: 'instance creation'!
extent: extent depth: depth

	^ self new setForm: (Form extent: extent depth: depth)! !

!FormCanvas class methodsFor: 'instance creation' stamp: 'jm 8/2/97 13:54'!
on: aForm

	^ self new setForm: aForm
! !


!FormCanvas class methodsFor: 'testing' stamp: 'jm 6/2/1998 07:46'!
test1
	"FormCanvas test1"

	| canvas |
	canvas _ FormCanvas extent: 200@200.
	canvas fillColor: (Color black).
	canvas line: 10@10 to: 50@30 width: 1 color: (Color red).
	canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green).
	canvas point: 100@100 color: (Color black).
	canvas text: 'Hello, World!!' at: 40@40 font: nil color: (Color cyan).
	canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta).
	canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan).
	canvas frameOval: ((40@80) corner: (61@121)) color: (Color blue).
	canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: (Color red alpha: 0.2).
	canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow).
	canvas showAt: 0@0.
! !

!FormCanvas class methodsFor: 'testing' stamp: 'ar 6/17/1999 02:39'!
test2
	"FormCanvas test2"

	| baseCanvas p |
	baseCanvas _ FormCanvas extent: 200@200.
	p _ Sensor cursorPoint.
	[Sensor anyButtonPressed] whileFalse: [
		baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas|
			canvas fillColor: Color white.
			canvas line: 10@10 to: 50@30 width: 1 color: Color red.
			canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green.
			canvas point: 100@100 color: Color black.
			canvas text: 'Hello, World!!' at: 40@40 font: nil color: Color cyan.
			canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta.
			canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan.
			canvas frameOval: ((40@80) corner: (61@121)) color: Color blue.
			canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red.
			canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow.
			canvas showAt: 0@0]].
! !

!FormCanvas class methodsFor: 'testing' stamp: 'ar 2/17/2000 00:17'!
test3
	"FormCanvas test3"

	| baseCanvas |
	baseCanvas _ FormCanvas extent: 200@200.
	baseCanvas fillColor: Color white.
	baseCanvas translateBy: 10@10 during:[:canvas|
		canvas shadowColor: (Color black alpha: 0.5).
		canvas line: 10@10 to: 50@30 width: 1 color: Color red.
		canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green.
		canvas point: 100@100 color: Color black.
		canvas text: 'Hello, World!!' at: 40@40 font: nil color: Color cyan.
		canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta.
		canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan.
		canvas frameOval: ((40@80) corner: (61@121)) color: Color blue.
		canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red.
		canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow.
		canvas showAt: 0@0.
	].! !
MouseMenuController subclass: #FormEditor
	instanceVariableNames: 'form tool grid togglegrid mode previousTool color unNormalizedColor xgridOn ygridOn '
	classVariableNames: 'BitEditKey BlackKey BlockKey ChangeGridsKey CurveKey DarkGrayKey EraseKey FlashCursor GrayKey InKey LightGrayKey LineKey OutKey OverKey RepeatCopyKey ReverseKey SelectKey SingleCopyKey TogglexGridKey ToggleyGridKey UnderKey WhiteKey YellowButtonMenu YellowButtonMessages YgridKey '
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormEditor commentStamp: '<historical>' prior: 0!
I represent the basic editor for creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. I am a kind of MouseMenuController that creates a yellow button menu for accepting and canceling edits. My instances give up control if the cursor is outside the FormView or if a key on the keyboard is pressed.!


!FormEditor methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:07'!
initialize
	super initialize.
	self setVariables! !

!FormEditor methodsFor: 'initialize-release'!
release
	"Break the cycle between the Controller and its view. It is usually not 
	necessary to send release provided the Controller's view has been properly 
	released independently."

	super release.
	form _ nil! !


!FormEditor methodsFor: 'basic control sequence' stamp: 'sma 4/22/2000 12:56'!
controlInitialize

	Cursor crossHair show.
	self normalizeColor: unNormalizedColor.
	sensor waitNoButton! !

!FormEditor methodsFor: 'basic control sequence'!
controlTerminate
	"Resets the cursor to be the normal Smalltalk cursor."

	Cursor normal show.
	view updateDisplay! !


!FormEditor methodsFor: 'control defaults'!
controlActivity

	super controlActivity.
	self dragForm! !

!FormEditor methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:07'!
isControlActive
	^ super isControlActive and: [sensor keyboardPressed not]! !


!FormEditor methodsFor: 'editing tools'!
block
	"Allow the user to fill a rectangle with the gray tone and mode currently 
	selected."

	| rectangle |
	rectangle _ Rectangle fromUser: grid.
	rectangle isNil 
		ifFalse: [Display
					fill: (rectangle intersect: view insetDisplayBox)
					rule: mode
					fillColor: color]! !

!FormEditor methodsFor: 'editing tools' stamp: 'jm 3/27/98 15:01'!
changeGridding
	"Allow the user to change the values of the horizontal and/or vertical 
	grid modules. Does not change the primary tool."

	| response gridInteger gridX gridY |
	gridX _ togglegrid x.
	gridY _ togglegrid y.
	response _ FillInTheBlank
		request:
'Current horizontal gridding is: ', gridX printString, '.
Type new horizontal gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger _ Integer readFromString: response.
			gridX _ ((gridInteger max: 1) min: Display extent x)].
	response _ FillInTheBlank
		request:
'Current vertical gridding is: ', gridY printString, '.
Type new vertical gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger _ Integer readFromString: response.
			gridY _ ((gridInteger max: 1) min: Display extent y)].
	xgridOn ifTrue: [grid _ gridX @ grid y].
	ygridOn ifTrue: [grid _ grid x @ gridY].
	togglegrid _ gridX @ gridY.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
changeTool: aCharacter 
	"Change the value of the instance variable tool to be the tool 
	corresponding to aCharacter. Typically sent from a Switch in a 
	FormMenuView."

	previousTool _ tool.
	tool _ self selectTool: aCharacter.
	(#(singleCopy repeatCopy line curve block) includes: tool)
		ifFalse:
			[self perform: tool]! !

!FormEditor methodsFor: 'editing tools'!
colorBlack
	"Set the mask (color) to black. Leaves the tool set in its previous state."

	self setColor: Color black! !

!FormEditor methodsFor: 'editing tools'!
colorDarkGray
	"Set the mask (color) to dark gray. Leaves the tool set in its previous 
	state."

	self setColor: Color darkGray! !

!FormEditor methodsFor: 'editing tools'!
colorGray
	"Set the color to gray. Leaves the tool set in its previous state."

	self setColor: Color gray.
! !

!FormEditor methodsFor: 'editing tools'!
colorLightGray
	"Set the mask (color) to light gray. Leaves the tool set in its previous 
	state."

	self setColor: Color lightGray! !

!FormEditor methodsFor: 'editing tools'!
colorWhite
	"Set the color to white. Leaves the tool set in its previous state."

	self setColor: Color white! !

!FormEditor methodsFor: 'editing tools' stamp: '6/9/97 10:15 di'!
curve
	"Conic-section specified by three points designated by: first point--press 
	red button second point--release red button third point--click red button. 
	The resultant curve on the display is displayed according to the current 
	form and mode."

	| firstPoint secondPoint thirdPoint curve |
	"sensor noButtonPressed ifTrue: [^self]."
	firstPoint _ self cursorPoint.
	form
		displayOn: Display
		at: firstPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	secondPoint _ self trackFormUntil: [sensor noButtonPressed].
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	thirdPoint _ self trackFormUntil: [sensor redButtonPressed]..
	form
		displayOn: Display
		at: thirdPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	curve _ CurveFitter new.
	curve firstPoint: firstPoint.
	curve secondPoint: secondPoint.
	curve thirdPoint: thirdPoint.
	curve form: form.
	curve
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	sensor waitNoButton! !

!FormEditor methodsFor: 'editing tools'!
eraseMode
	"Set the mode for the tools that copy the form onto the display to erase. 
	Leaves the tool set in its previous state."

	mode _ 4.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'jm 3/27/98 14:59'!
fileInForm
	"Ask the user for a file name and then recalls the Form in that file as the current source Form (form). Does not change the tool."

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	form _ Form fromFileNamed: fileName.
	tool _ previousTool.
! !

!FormEditor methodsFor: 'editing tools' stamp: 'jm 3/27/98 14:54'!
fileOutForm
	"Ask the user for a file name and save the current source form under that name. Does not change the tool."

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [form writeOnFileNamed: fileName].
	tool _ previousTool.
! !

!FormEditor methodsFor: 'editing tools'!
line
	"Line is specified by two points from the mouse: first point--press red 
	button; second point--release red button. The resultant line is displayed 
	according to the current form and mode."

	| firstPoint endPoint |
	firstPoint _ self cursorPoint.
	endPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed].
	(Line from: firstPoint to: endPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color! !

!FormEditor methodsFor: 'editing tools'!
magnify
	"Allow for bit editing of an area of the Form. The user designates a 
	rectangular area that is scaled by 5 to allow individual screens dots to be 
	modified. Red button is used to set a bit to black, and yellow button is 
	used to set a bit to white. Editing continues until the user depresses any 
	key on the keyboard."

	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8@8.
	smallRect _ (Rectangle fromUser: grid) intersect: view insetDisplayBox.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.

	"Do this computation here in order to be able to save the existing display screen."
	tempRect _ BitEditor locateMagnifiedView: smallForm scale: scaleFactor.
	BitEditor
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'jm 6/30/1999 15:46'!
newSourceForm
	"Allow the user to define a new source form for the FormEditor. Copying 
	the source form onto the display is the primary graphical operation. 
	Resets the tool to be repeatCopy."
	| dForm interiorPoint interiorColor |

	dForm _ Form fromUser: grid.
	"sourceForm must be only 1 bit deep"
	interiorPoint _ dForm extent // 2.
	interiorColor _ dForm colorAt: interiorPoint.
	form _ (dForm makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:f | f pixelValueAt: interiorPoint put: 1].
	form _ form trimBordersOfColor: Color white.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
overMode
	"Set the mode for the tools that copy the form onto the display to over. 
	Leaves the tool set in its previous state."

	mode _ Form over.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools' stamp: 'ar 5/28/2000 12:09'!
repeatCopy
	"As long as the red button is pressed, copy the source form onto the 
	display screen."

	[sensor redButtonPressed]
		whileTrue: 
		[(BitBlt current destForm: Display sourceForm: form halftoneForm: color
			combinationRule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
			destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent
			clipRect: view insetDisplayBox)
			colorMap: (Bitmap with: 0 with: 16rFFFFFFFF);
			copyBits]! !

!FormEditor methodsFor: 'editing tools'!
reverseMode
	"Set the mode for the tools that copy the form onto the display to reverse. 
	Leaves the tool set in its previous state."

	mode _ Form reverse.
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
setColor: aColor
	"Set the mask (color) to aColor.
	Hacked to invoke color chooser if not B/W screen.
	Leaves the tool set in its previous state."

	self normalizeColor:  (Display depth > 1
							ifTrue: [Color fromUser]
							ifFalse: [aColor]).
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
singleCopy 
	"If the red button is clicked, copy the source form onto the display 
	screen."

	form
		displayOn: Display
		at: self cursorPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	sensor waitNoButton! !

!FormEditor methodsFor: 'editing tools'!
togglexGridding
	"Turn x (horizontal) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	xgridOn
		ifTrue: 
			[grid _ 1 @ grid y.
			xgridOn _ false]
		ifFalse: 
			[grid _ togglegrid x @ grid y.
			xgridOn _ true].
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
toggleyGridding
	"Turn y (vertical) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	ygridOn
		ifTrue: 
			[grid _ grid x @ 1.
			ygridOn _ false]
		ifFalse: 
			[grid _ grid x @ togglegrid y.
			ygridOn _ true].
	tool _ previousTool! !

!FormEditor methodsFor: 'editing tools'!
underMode
	"Set the mode for the tools that copy the form onto the display to under. 
	Leaves the tool set in its previous state."

	mode _ Form under.
	tool _ previousTool! !


!FormEditor methodsFor: 'menu messages'!
accept
	"The edited information should now be accepted by the view."

	view updateDisplay.
	view accept! !

!FormEditor methodsFor: 'menu messages'!
cancel
	"The edited information should be forgotten by the view."

	view cancel! !

!FormEditor methodsFor: 'menu messages'!
edit
	model edit! !

!FormEditor methodsFor: 'menu messages' stamp: 'jm 3/27/98 14:52'!
fileOut

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: 'Filename.form'.
	fileName isEmpty ifTrue: [^ self].
	Cursor normal
		showWhile: [model writeOnFileNamed: fileName].
! !

!FormEditor methodsFor: 'menu messages'!
redButtonActivity 
	"Refer to the comment in MouseMenuController|redButtonActivity."

	self perform: tool! !


!FormEditor methodsFor: 'cursor'!
cursorPoint
	"Answer the mouse coordinate data gridded according to the receiver's 
	grid."

	^sensor cursorPoint grid: grid! !


!FormEditor methodsFor: 'private'!
dragForm

	tool = #block
		ifTrue:
			[Cursor origin show.
			[sensor anyButtonPressed
				or: [sensor keyboardPressed
				or: [self viewHasCursor not]]]
				whileFalse: [].
			^self cursorPoint]
		ifFalse:
			[^self trackFormUntil:
				[sensor anyButtonPressed
					or: [sensor keyboardPressed
					or: [self viewHasCursor not]]]]! !

!FormEditor methodsFor: 'private' stamp: 'jm 12/4/97 10:22'!
normalizeColor: aColor

	color _ aColor.
! !

!FormEditor methodsFor: 'private'!
rubberBandFrom: startPoint until: aBlock

	| endPoint previousEndPoint |
	previousEndPoint _ startPoint.
	[aBlock value] whileFalse:
		[(endPoint _ self cursorPoint) = previousEndPoint 
			ifFalse:
			[(Line from: startPoint to: previousEndPoint withForm: form)
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Color black.
			(Line from: startPoint to: endPoint withForm: form)
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Color black.
			previousEndPoint  _ endPoint]].
	(Line from: startPoint to: previousEndPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: Color black.
	^endPoint! !

!FormEditor methodsFor: 'private'!
selectTool: aCharacter
	"A new tool has been selected. It is denoted by aCharacter. Set the tool.
	This code is written out in long hand (i.e., rather than dispatching on a
	table of options) so that it is obvious what is happening."
	
	aCharacter =  SingleCopyKey	ifTrue: [^#singleCopy].
	aCharacter =  RepeatCopyKey	ifTrue: [^#repeatCopy].
	aCharacter =  LineKey			ifTrue: [^#line].					
	aCharacter =  CurveKey			ifTrue: [^#curve].				
	aCharacter =  BlockKey			ifTrue: [^#block].		
	aCharacter =  SelectKey			ifTrue: [^#newSourceForm].		
	aCharacter =  OverKey			ifTrue: [^#overMode].
	aCharacter =  UnderKey			ifTrue: [^#underMode].
	aCharacter =  ReverseKey		ifTrue: [^#reverseMode].
	aCharacter =  EraseKey			ifTrue: [^#eraseMode].
	aCharacter =  ChangeGridsKey	ifTrue: [^#changeGridding].
	aCharacter =  TogglexGridKey	ifTrue: [^#togglexGridding].
	aCharacter =  ToggleyGridKey	ifTrue: [^#toggleyGridding].
	aCharacter =  BitEditKey			ifTrue: [^#magnify].			
	aCharacter =  WhiteKey			ifTrue: [^#colorWhite].			
	aCharacter =  LightGrayKey		ifTrue: [^#colorLightGray].			
	aCharacter =  GrayKey			ifTrue: [^#colorGray].				
	aCharacter =  DarkGrayKey		ifTrue: [^#colorDarkGray].			
	aCharacter =  BlackKey			ifTrue: [^#colorBlack].				
	aCharacter =  OutKey			ifTrue: [^#fileOutForm].			
	aCharacter =  InKey				ifTrue: [^#fileInForm]! !

!FormEditor methodsFor: 'private'!
setVariables
	tool _ #repeatCopy.
	previousTool _ tool.
	grid _ 1 @ 1.
	togglegrid _ 8 @ 8.
	xgridOn _ false.
	ygridOn _ false.
	mode _ Form over.
	form _ Form extent: 8 @ 8.
	form fillBlack.
	unNormalizedColor _ color _ Color black.
! !

!FormEditor methodsFor: 'private'!
trackFormUntil: aBlock

	| previousPoint cursorPoint |
	previousPoint _ self cursorPoint.
	form displayOn: Display at: previousPoint rule: Form reverse.
	[aBlock value] whileFalse:
		[cursorPoint _ self cursorPoint.
		(FlashCursor or: [cursorPoint ~= previousPoint])
			ifTrue:
			[form displayOn: Display at: previousPoint rule: Form reverse.
			form displayOn: Display at: cursorPoint rule: Form reverse.
			previousPoint _ cursorPoint]].
	form displayOn: Display at: previousPoint rule: Form reverse.
	^previousPoint! !


!FormEditor methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:08'!
getPluggableYellowButtonMenu: shiftKeyState
	^ YellowButtonMenu! !

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

FormEditor class
	instanceVariableNames: ''!

!FormEditor class methodsFor: 'class initialization'!
flashCursor: aBoolean

	FlashCursor _ aBoolean

	"FormEditor flashCursor: true"! !

!FormEditor class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 15:06'!
initialize

	FlashCursor _ false.
	self setKeyboardMap.
	YellowButtonMenu _ SelectionMenu 
		labels:
'accept
cancel
edit
file out'
		lines: #(2)
		selections: #(accept cancel edit fileOut).

	"FormEditor initialize"! !


!FormEditor class methodsFor: 'instance creation'!
openFullScreenForm
	"Create and schedule an instance of me on the form whose extent is the 
	extent of the display screen."

	| topView |
	topView _ self createFullScreenForm.
	topView controller 
		openDisplayAt: (topView viewport extent//2)

	"FormEditor openFullScreenForm."! !

!FormEditor class methodsFor: 'instance creation'!
openOnForm: aForm
	"Create and schedule an instance of me on the form aForm."

	| topView |
	topView _ self createOnForm: aForm.
	topView controller open

! !


!FormEditor class methodsFor: 'examples'!
formFromDisplay
	"Create an instance of me on a new form designated by the user at a
	location designated by the user."

	Form fromUser edit

	"FormEditor formFromDisplay"! !

!FormEditor class methodsFor: 'examples'!
fullScreen
	"Create an instance of me on a new form that fills the full size of the
	display screen."

	FormEditor openFullScreenForm

	"FormEditor fullScreen"! !

!FormEditor class methodsFor: 'examples'!
newForm
	"Create an instance of me on a new form at a location designated by the user. "

	(Form extent: 400 @ 200 depth: Display depth) edit

	"FormEditor newForm"! !


!FormEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'!
createFullScreenForm
	"Create a StandardSystemView for a FormEditor on the form whole screen."
	| formView formEditor menuView topView extent aForm |
	aForm _ Form extent: (Display extent x @ (Display extent y - 112)) depth: Display depth.
	formView _ FormHolderView new model: aForm.
	formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: menuView controller.
	topView _ StandardSystemView new.
	topView backgroundColor: #veryLightGray.
	topView model: aForm.
	topView addSubView: formView.
	topView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	topView window: 
		(formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))).
	topView label: 'Form Editor'.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView

! !

!FormEditor class methodsFor: 'private' stamp: 'di 9/12/1998 12:28'!
createOnForm: aForm
	"Create a StandardSystemView for a FormEditor on the form aForm."
	| formView formEditor menuView aView topView extent topViewBorder |
	topViewBorder _ 2.
	formView _ FormHolderView new model: aForm.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: aForm.
	aView _ View new.
	aView model: aForm.
	aView addSubView: formView.
	aView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	aView window: 
		((formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))) 
		  expandBy: (0@topViewBorder corner: 0@0)).
	topView _ StandardSystemView new.
	topView backgroundColor: #veryLightGray.
	topView addSubView: aView.
	topView label: 'Form Editor'.
	topView borderWidth: topViewBorder.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView! !

!FormEditor class methodsFor: 'private'!
setKeyboardMap
	"Keyboard Mapping."

	SelectKey_$a.
	SingleCopyKey_$s.			"tools"
	RepeatCopyKey_$d.
	LineKey_$f.
	CurveKey_$g.
	BlockKey_$h.
	OverKey_$j.				"modes"
	UnderKey_$k.
	ReverseKey_$l.
	EraseKey_$;.
	InKey_$'.					"file In"
	BitEditKey_$z.
	WhiteKey_$x.				"colors"
	LightGrayKey_$c.
	GrayKey_$v.
	DarkGrayKey_$b.
	BlackKey_$n.
	TogglexGridKey_$m.		"gridding"
	ToggleyGridKey_$,.
	ChangeGridsKey_$..
	OutKey_$/					"file Out"! !
StandardSystemView subclass: #FormEditorView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!

!FormEditorView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !
FormView subclass: #FormHolderView
	instanceVariableNames: 'displayedForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!FormHolderView commentStamp: '<historical>' prior: 0!
I represent a view of a Form. Editing takes place by modifying a working version of the Form. The message accept is used to copy the working version into the Form; the message cancel copies the Form into the working version.!


!FormHolderView methodsFor: 'initialize-release'!
release

	super release.
	displayedForm release.
	displayedForm _ nil! !


!FormHolderView methodsFor: 'model access'!
changeValueAt: location put: anInteger 
	"Refer to the comment in FormView|changeValueAt:put:."

	displayedForm pixelValueAt: location put: anInteger.
	displayedForm changed: self! !

!FormHolderView methodsFor: 'model access'!
model: aForm

	super model: aForm.
	displayedForm _ aForm deepCopy! !

!FormHolderView methodsFor: 'model access'!
workingForm
	"Answer the form that is currently being displayed--the working version 
	in which edits are carried out."

	^displayedForm! !


!FormHolderView methodsFor: 'displaying'!
displayView 
	"Display the Form associated with this View according to the rule and
	fillColor specifed by this class."

	| oldOffset |
	oldOffset _ displayedForm offset.
	displayedForm offset: 0@0.
	displayedForm
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	displayedForm offset: oldOffset! !

!FormHolderView methodsFor: 'displaying'!
updateDisplay
	"The working version is redefined by copying the bits displayed in the 
	receiver's display area."

	displayedForm fromDisplay: self displayBox.
	displayedForm changed: self! !


!FormHolderView methodsFor: 'menu messages'!
accept 
	"Refer to the comment in FormView|accept."
	model
		copyBits: displayedForm boundingBox
		from: displayedForm
		at: 0 @ 0
		clippingBox: model boundingBox
		rule: Form over
		fillColor: nil.
	model changed: self! !

!FormHolderView methodsFor: 'menu messages'!
cancel 
	"Refer to the comment in FormView|cancel."

	displayedForm become: model deepCopy.
	displayedForm changed: self.
	self display! !
Object subclass: #FormInput
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!FormInput commentStamp: '<historical>' prior: 0!
an input instance for a form.  A form takes its input from a collection of FormInputs; each FormInput has a name and can retrieve a textual value.  WHen a form is submitted, these name-value associations are gathered together and passed to an HTTP server.!


!FormInput methodsFor: 'testing' stamp: 'ls 8/11/1998 20:43'!
isRadioButtonSetInput
	^false! !


!FormInput methodsFor: 'input handling' stamp: 'bolot 11/3/1999 20:39'!
active
	"whether this input is currently providing an input"
	^self name isNil not! !

!FormInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:20'!
name
	"name associated with this input"
	^self subclassResponsibility! !

!FormInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:20'!
reset
	"reset to a default value"
	! !

!FormInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:20'!
value
	"value associated with this input"
	^self subclassResponsibility! !
Model subclass: #FormInputSet
	instanceVariableNames: 'inputs browser form '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!FormInputSet commentStamp: '<historical>' prior: 0!
Holds the inputs for an instance of an HTML Form.  It has a link to the browser it will be displayed in, and it has a link to each of the input PluggableTextMorph's that it input will read from.

inputs - maps HtmlInput's into the text morphs which will input their value.!


!FormInputSet methodsFor: 'private-initialization' stamp: 'ls 8/5/1998 03:57'!
form: f  browser: b
	inputs _ OrderedCollection new.
	form _ f.
	browser _ b.! !


!FormInputSet methodsFor: 'adding inputs' stamp: 'ls 8/5/1998 03:57'!
addInput: anInput
	inputs add: anInput! !

!FormInputSet methodsFor: 'adding inputs' stamp: 'ls 8/11/1998 03:30'!
inputs
	"return a list of the list of inputs"
	^inputs! !


!FormInputSet methodsFor: 'action' stamp: 'ls 8/5/1998 03:58'!
reset
	"reset all inputs to their default value"
	inputs do: [ :input | input reset ]! !

!FormInputSet methodsFor: 'action' stamp: 'bolot 11/3/1999 03:09'!
submit
	"collect inputs and instruct the browser to do a submission"
	| inputValues |
	inputValues _ Dictionary new.

	inputs do: [ :input |
		input active ifTrue: [
			(inputValues includesKey: input name) ifFalse: [
				inputValues at: input name  put: (OrderedCollection new: 1) ].
			(inputValues at: input name)  add: input value ] ].
	browser submitFormWithInputs: inputValues url: form url
		method: form method encoding: form encoding.
	^true! !

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

FormInputSet class
	instanceVariableNames: ''!

!FormInputSet class methodsFor: 'instance creation' stamp: 'ls 7/16/1998 22:01'!
forForm: form  andBrowser: browser
	"create a FormData for the given form and browser"
	^super new form: form  browser: browser! !
FormView subclass: #FormInspectView
	instanceVariableNames: 'offset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!

!FormInspectView methodsFor: 'as yet unclassified'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  NoController! !

!FormInspectView methodsFor: 'as yet unclassified' stamp: 'di 9/23/1998 10:55'!
displayView 
	"Display the form as a value in an inspector.  8/11/96 sw"
	"Defeated form scaling for HS FormInspector.  8/20/96 di"
	| scale |
	Display fill: self insetDisplayBox fillColor: Color white.
	model selectionIndex == 0 ifTrue: [^ self].
	scale _ self insetDisplayBox extent / model selection extent.
	scale _ (scale x min: scale y) min: 1.
	model selection
		displayOn: Display
		transformation: (WindowingTransformation
			scale: scale asPoint
			translation: self insetDisplayBox topLeft - model selection offset)
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor! !
Controller subclass: #FormMenuController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormMenuController commentStamp: '<historical>' prior: 0!
I represent a Controller that takes control if a key on the keyboard is depressed or if the cursor is within my rectangular area.!


!FormMenuController methodsFor: 'control defaults'!
controlActivity
	"Pass control to a subView corresponding to a pressed keyboard key or to
	a mouse button pressed, if any."

	sensor keyboardPressed
		ifTrue: [self processMenuKey]
		ifFalse: [self controlToNextLevel]! !

!FormMenuController methodsFor: 'control defaults'!
isControlActive
	"Answer false if the blue mouse button is pressed and the cursor is
	outside of the inset display box of the Controller's view; answer true,
	otherwise."

	^sensor keyboardPressed |
		(view containsPoint: sensor cursorPoint) & sensor blueButtonPressed not! !

!FormMenuController methodsFor: 'control defaults'!
isControlWanted
	"Answer true if the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view, and answer false, 
	otherwise. It is sent by Controller|controlNextLevel in order to determine 
	whether or not control should be passed to this receiver from the
	Controller of the superView of this receiver's view."

	^sensor keyboardPressed | self viewHasCursor! !

!FormMenuController methodsFor: 'control defaults' stamp: 'jm 4/7/98 20:59'!
processMenuKey
	"The user typed a key on the keyboard. Perform the action of the button whose shortcut is that key, if any."

	| aView |
	aView _ view subViewContainingCharacter: sensor keyboard.
	aView ~~ nil ifTrue: [aView performAction].
! !
View subclass: #FormMenuView
	instanceVariableNames: ''
	classVariableNames: 'BorderForm FormButtons SpecialBorderForm '
	poolDictionaries: ''
	category: 'ST80-Editors'!
!FormMenuView commentStamp: '<historical>' prior: 0!
I represent a View whose subViews are Switches (and Buttons and OneOnSwitches) whose actions set the mode, color, and tool for editing a Form on the screen. The default controller of my instances is FormMenuController.!


!FormMenuView methodsFor: 'initialize-release'!
makeFormEditorMenu

	| button buttonCache form aSwitchView aSwitchController|
	"Now get those forms into the subviews"
	self makeButton: 1.					"form source"
	self makeConnections: (2 to: 6).		"tools"
	self makeConnections: (7 to: 10).		"modes"
	self makeButton: 11.					"filing in"
	self makeButton: 12.					"bit editing"
	self makeColorConnections: (13 to: 17).		"colors"
	self makeGridSwitch: 18.					"toggle x"
	self makeGridSwitch: 19.					"toggle y"
	self makeButton: 20.					"setting grid"
	self makeButton: 21					"filing out"! !


!FormMenuView methodsFor: 'subView access' stamp: 'jm 4/2/98 17:29'!
subViewContainingCharacter: aCharacter
	"Answer the receiver's subView that corresponds to the key, aCharacter. 
	Answer nil if no subView is selected by aCharacter."

	self subViews reverseDo: 
		[:aSubView |
		(aSubView shortcutCharacter = aCharacter) ifTrue: [^aSubView]].
	^nil	
! !


!FormMenuView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^FormMenuController! !


!FormMenuView methodsFor: 'private' stamp: 'jm 4/7/98 20:17'!
makeButton: index

	| buttonCache button |
	buttonCache _ FormButtons at: index.
	button _ Button newOff.
	button onAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'jrm 6/1/1998 21:57'!
makeColorConnections: indexInterval

	| connector buttonCache button aSwitchView |
	connector _ Object new.  "a dummy model for connecting dependents"
	indexInterval do: [:index |
		buttonCache _ FormButtons at: index.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView
			borderWidthLeft: 1 right: 0 top: 1 bottom: 1;
			action: #turnOn].
	aSwitchView borderWidth: 1.
! !

!FormMenuView methodsFor: 'private' stamp: 'jrm 6/1/1998 21:56'!
makeConnections: indexInterval

	| connector buttonCache button aSwitchView |
	connector _ Object new.  "a dummy model for connecting dependents."
	indexInterval do: [:index |
		buttonCache _ FormButtons at: index.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView
			borderWidthLeft: 1 right: 0 top: 1 bottom: 1;
			action: #turnOn].
	aSwitchView borderWidth: 1.
! !

!FormMenuView methodsFor: 'private' stamp: 'jm 4/7/98 20:30'!
makeGridSwitch: index

	| buttonCache button |
	buttonCache _ FormButtons at: index.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	button offAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'jm 4/7/98 20:30'!
makeSwitch: index

	| buttonCache button |
	buttonCache _ FormButtons at: index.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button.
! !

!FormMenuView methodsFor: 'private' stamp: 'jm 4/7/98 20:24'!
makeViews: cache for: aSwitch

	| form aSwitchView |
	form _ cache form.
	aSwitchView _ PluggableButtonView
		on: aSwitch
		getState: #isOn
		action: #switch.
	aSwitchView
		label: form;
		shortcutCharacter: cache value;
		window: (0@0 extent: form extent);
		translateBy: cache offset;
		borderWidth: 1.
	self addSubView: aSwitchView.
	^ aSwitchView
! !

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

FormMenuView class
	instanceVariableNames: ''!

!FormMenuView class methodsFor: 'class initialization' stamp: 'jm 3/27/98 14:54'!
fileOut
	"Save the FormEditor button icons."
	"FormMenuView fileOut"

	| names |
	names _ 
		#('select.form' 'singlecopy.form' 'repeatcopy.form' 'line.form' 'curve.form'
		'block.form' 'over.form' 'under.form' 'reverse.form' 'erase.form' 'in.form'
		'magnify.form' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form' 'ygrid.form' 'togglegrids.form' 'out.form').
	1 to: FormButtons size do: [:i |
		(FormButtons at: i) form writeOnFileNamed: (names at: i)].
	SpecialBorderForm writeOnFileNamed: 'specialborderform.form'.
	BorderForm writeOnFileNamed: 'borderform.form'.
! !

!FormMenuView class methodsFor: 'class initialization' stamp: 'jm 3/27/98 13:07'!
initialize
	"The icons for the menu are typically stored on files. In order to avoid reading them every time, they are stored in a collection in a class variable, along with their offset, tool value, and initial visual state (on or off)."
	"FormMenuView initialize"

	| offsets keys states names button |
	offsets _ OrderedCollection new: 21.
	#(0 64 96 128 160 192 256 288 320 352 420) do: [:i | offsets addLast: i@0].  "First row"
	#(0 64 96 128 160 192 256 304 352 420) do: [:i | offsets addLast: i@48].  "Second row"
	offsets _ offsets asArray.
	keys _ #($a $s $d $f $g $h $j $k $l $; $' $z $x $c $v $b $n $m $, $. $/ ).  "Keyboard"
	states _ #(
		false false true false false false true false false false false
		false false false false false true false false false false).  "Initial button states"
	names _ 
		#('select.form' 'singlecopy.form' 'repeatcopy.form' 'line.form' 'curve.form'
		'block.form' 'over.form' 'under.form' 'reverse.form' 'erase.form' 'in.form'
		'magnify.form' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form' 'ygrid.form' 'togglegrids.form' 'out.form').  "Files of button images"
	FormButtons _ OrderedCollection new.
	1 to: 21 do: [:index |
		button _ FormButtonCache new.
		button form: (Form fromFileNamed: (names at: index)).
		button offset: (offsets at: index).
		button value: (keys at: index).
		button initialState: (states at: index).
		FormButtons addLast: button].
	SpecialBorderForm  _ Form fromFileNamed: 'specialborderform.form'.
	BorderForm _ Form fromFileNamed: 'borderform.form'.
! !
StrikeFont subclass: #FormSetFont
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Text'!
!FormSetFont commentStamp: '<historical>' prior: 0!
FormSetFonts are designed to capture individual images as character forms for imbedding in normal text.  While most often used to insert an isolated glyph in some text, the code is actually desinged to support an entire user-defined font.  The TextAttribute subclass TextFontReference is specifically designed for such in-line insertion of exceptional fonts in normal text.!


!FormSetFont methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2000 12:49'!
fromFormArray: formArray asciiStart: asciiStart ascent: ascentVal
	| height width x badChar |
	type _ 2.
	name _ 'aFormFont'.
	minAscii _ asciiStart.
	maxAscii _ minAscii + formArray size - 1.
	ascent _ ascentVal.
	subscript _ superscript _ emphasis _ 0.
	height _ width _ 0.
	maxWidth _ 0.
	formArray do:
		[:f | width _ width + f width.
		maxWidth _ maxWidth max: f width.
		height _ height max: f height + f offset y].
	badChar _ (Form extent: 7@height) borderWidth: 1.
	width _ width + badChar width.
	descent _ height - ascent.
	pointSize _ height.
	glyphs _ Form extent: width @ height depth: formArray first depth.
	xTable _ Array new: maxAscii + 3 withAll: 0.
	x _ 0.
	formArray doWithIndex:
		[:f :i | f displayOn: glyphs at: x@0.
		xTable at: minAscii + i+1 put: (x _ x + f width)].
	badChar displayOn: glyphs at: x@0.
	xTable at: maxAscii + 3 put: x + badChar width.
	characterToGlyphMap _ nil.! !

!FormSetFont methodsFor: 'as yet unclassified'!
reset  "Ignored by FormSetFonts"! !

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

FormSetFont class
	instanceVariableNames: ''!

!FormSetFont class methodsFor: 'examples' stamp: 'ar 1/15/2001 18:38'!
copy: charForm toClipBoardAs: char ascent: ascent
	Clipboard clipboardText:
		(Text string: char asString
			attribute: (TextFontReference toFont: 
				(FormSetFont new
					fromFormArray: (Array with: charForm)
					asciiStart: char asciiValue
					ascent: ascent)))
"
	The S in the Squeak welcome window was installed by doing the following
	in a workspace (where the value of, eg, charForm will persist through BitEdit...
	f _ TextStyle default fontAt: 4.
	oldS _ f characterFormAt: $S.
	charForm _ Form extent: oldS extent depth: 8.
	oldS displayOn: charForm.
	charForm bitEdit.
	...Play around with the BitEditor, then accept and close...
	FormSetFont copy: charForm toClipBoardAs: $S ascent: f ascent.
	...Then do a paste into the Welcome window
"! !

!FormSetFont class methodsFor: 'examples'!
example    "FormSetFont example"
	"Lets the user select a (small) area of the screen to represent the
	character A, then copies 'A' to the clipboard with that as the letter form.
	Thereafter, a paste operation will imbed that character in any text."
	| charForm |
	charForm _ Form fromUser.
	self copy: charForm toClipBoardAs: $A ascent: charForm height! !
View subclass: #FormView
	instanceVariableNames: 'rule mask '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Views'!
!FormView commentStamp: '<historical>' prior: 0!
I represent a view of a Form.!


!FormView methodsFor: 'accessing'!
fillColor
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask! !

!FormView methodsFor: 'accessing'!
fillColor: aForm 
	"Set the display mask for displaying the receiver's model to be the 
	argument, aForm."

	mask _ aForm! !

!FormView methodsFor: 'accessing'!
mask
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask! !

!FormView methodsFor: 'accessing'!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules (logical function of two boolean values) is to be used when 
	copying the receiver's model (a Form) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]! !

!FormView methodsFor: 'accessing'!
rule: anInteger 
	"Set the display rule for the receiver to be the argument, anInteger."

	rule _ anInteger! !


!FormView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  FormEditor! !


!FormView methodsFor: 'model access'!
changeValueAt: location put: anInteger
	"The receiver's model is a form which has an array of bits. Change the 
	bit at index, location, to be anInteger (either 1 or 0). Inform all objects 
	that depend on the model that it has changed."

	model pixelValueAt: location put: anInteger.
	model changed: self! !


!FormView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^(Rectangle origin: 0 @ 0 extent: model extent)
		expandBy: borderWidth! !

!FormView methodsFor: 'window access'!
windowBox
	"For comaptibility with Control manager (see senders)"
	^ self insetDisplayBox! !


!FormView methodsFor: 'displaying'!
displayOn: aPort
	model displayOnPort: aPort at: self displayBox origin! !

!FormView methodsFor: 'displaying' stamp: 'hmm 7/21/97 20:45'!
displayView 
	"Refer to the comment in View|displayView."

	| oldOffset |
	super displayView.
	insideColor == nil ifFalse: [Display fill: self insetDisplayBox fillColor: insideColor].
	oldOffset _ model offset.
	model offset: "borderWidth origin" 0@0.
	model
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	model offset: oldOffset! !

!FormView methodsFor: 'displaying'!
uncacheBits
	"Placed vacuously here so that when ControlManager>>restore calls uncacheBits for a project with no windows, we don't hang.  1/24/96 sw"! !

!FormView methodsFor: 'displaying'!
updateDisplay
	"overridden by subclass"! !


!FormView methodsFor: 'updating'!
update: aFormView 
	"Refer to the comment in View|update:."

	self == aFormView ifFalse: [self display]! !


!FormView methodsFor: 'menu messages'!
accept
	"The receiver's model is set to the working version, the one in which 
	edits are carried out."

	^self! !

!FormView methodsFor: 'menu messages'!
cancel
	"Set the working form to be a copy of the model."

	^self! !


!FormView methodsFor: 'private'!
defaultRule 
	"The default display rule is 3=over or storing."

	^Form over! !

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

FormView class
	instanceVariableNames: ''!

!FormView class methodsFor: 'examples'!
exampleOne
	"Frame a Form (specified by the user) with a border of 2 bits in width and display it offset 60 x 40 from the cornor of the display screen. "
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleOne"! !

!FormView class methodsFor: 'examples'!
exampleTwo
	"Frame a Form (specified by the user) that is scaled by 2. The border is 2 bits in width. Displays at location 60, 40."
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view scaleBy: 2.0.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleTwo"! !

!FormView class methodsFor: 'examples' stamp: 'di 9/12/1998 10:17'!
open: aForm named: aString
	"FormView open: ((Form extent: 100@100) borderWidth: 1) named: 'Squeak' "
	"Open a window whose model is aForm and whose label is aString."
	| topView aView |
	topView _ StandardSystemView new.
	topView model: aForm.
	topView label: aString.
	topView minimumSize: 80@80.
	aView _ FormView new.
	aView model: aForm.
	aView window: (aForm boundingBox expandBy: 2).
	aView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	topView addSubView: aView.
	topView controller open! !
Number subclass: #Fraction
	instanceVariableNames: 'numerator denominator '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Fraction commentStamp: '<historical>' prior: 0!
I represent some rational number as a fraction. All public arithmetic operations answer reduced fractions.!


!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
* aNumber 
	"Answer the result of multiplying the receiver by aNumber."
	| d1 d2 |
	aNumber isFraction ifTrue: 
		[d1 _ numerator gcd: aNumber denominator.
		d2 _ denominator gcd: aNumber numerator.
		(d2 = denominator and: [d1 = aNumber denominator])
			ifTrue: [^ numerator // d1 * (aNumber numerator // d2)].
		^ Fraction numerator: numerator // d1 * (aNumber numerator // d2)
				denominator: denominator // d2 * (aNumber denominator // d1)].
	^ aNumber adaptToFraction: self andSend: #*! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
+ aNumber 
	"Answer the sum of the receiver and aNumber."
	| n d d1 d2 |
	aNumber isFraction ifTrue: 
		[d _ denominator gcd: aNumber denominator.
		n _ numerator * (d1 _ aNumber denominator // d) + (aNumber numerator * (d2 _ denominator // d)).
		d1 _ d1 * d2.
		n _ n // (d2 _ n gcd: d).
		(d _ d1 * (d // d2)) = 1 ifTrue: [^ n].
		^ Fraction numerator: n denominator: d].
	^ aNumber adaptToFraction: self andSend: #+! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
- aNumber
	"Answer the difference between the receiver and aNumber."
	aNumber isFraction ifTrue:
		[^ self + aNumber negated].
	^ aNumber adaptToFraction: self andSend: #-! !

!Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'!
/ aNumber
	"Answer the result of dividing the receiver by aNumber."
	aNumber isFraction
		ifTrue: [^self * aNumber reciprocal].
	^ aNumber adaptToFraction: self andSend: #/! !

!Fraction methodsFor: 'arithmetic'!
negated 
	"Refer to the comment in Number|negated."

	^ Fraction
		numerator: numerator negated
		denominator: denominator! !

!Fraction methodsFor: 'arithmetic'!
reciprocal 
	"Refer to the comment in Number|reciprocal."

	numerator = 0 ifTrue: [self error: '0 has no reciprocal'].
	numerator = 1 ifTrue: [^denominator].
	numerator = -1 ifTrue: [^denominator negated].
	^Fraction numerator: denominator denominator: numerator! !


!Fraction methodsFor: 'comparing' stamp: 'di 11/6/1998 13:58'!
< aNumber
	aNumber isFraction ifTrue:
		[^ numerator * aNumber denominator < (aNumber numerator * denominator)].
	^ aNumber adaptToFraction: self andSend: #<! !

!Fraction methodsFor: 'comparing' stamp: 'di 8/31/1999 10:33'!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isFraction
		ifTrue: [numerator = 0 ifTrue: [^ aNumber numerator = 0].
				^ (numerator * aNumber denominator) =
					(aNumber numerator * denominator)
				"Note: used to just compare num and denom,
					but this fails for improper fractions"].
	^ aNumber adaptToFraction: self andSend: #=! !

!Fraction methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:33'!
hash
	"Hash is reimplemented because = is implemented."

	^numerator hash bitXor: denominator hash! !


!Fraction methodsFor: 'truncation and round off'!
truncated 
	"Refer to the comment in Number|truncated."

	^numerator quo: denominator! !


!Fraction methodsFor: 'converting' stamp: 'di 11/6/1998 13:10'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Fraction."
	^ rcvr asFraction perform: selector with: self! !

!Fraction methodsFor: 'converting' stamp: 'mrm 10/10/2000 22:58'!
asFloat
	"Answer a Float that closely approximates the value of the receiver.
	Ideally, answer the Float that most closely approximates the receiver."

	| nScaleBits dScaleBits nScaled dScaled |

	"Scale the numerator by throwing away all but the
	top 8 digits (57 to 64 significant bits) then making that a Float.
	This keeps all of the precision of a Float (53 significand bits) but
	guarantees that we do not exceed the range representable as a Float
	(about 2 to the 1024th)"

	nScaleBits _ 8 * ((numerator digitLength - 8) max: 0).
	nScaled _ (numerator bitShift: nScaleBits negated) asFloat.

	"Scale the denominator the same way."
	dScaleBits _ 8 * ((denominator digitLength - 8) max: 0).
	dScaled _ (denominator bitShift: dScaleBits negated) asFloat.

	"Divide the scaled numerator and denominator to make the 
right mantissa, then scale to correct the exponent."
	^ (nScaled / dScaled) timesTwoPower: (nScaleBits - dScaleBits).! !

!Fraction methodsFor: 'converting'!
asFraction	
	"Answer the receiver itself."

	^self! !

!Fraction methodsFor: 'converting'!
isFraction
	^ true! !


!Fraction methodsFor: 'printing'!
printOn: aStream

	aStream nextPut: $(.
	numerator printOn: aStream.
	aStream nextPut: $/.
	denominator printOn: aStream.
	aStream nextPut: $).
! !


!Fraction methodsFor: 'private'!
denominator

	^denominator! !

!Fraction methodsFor: 'private'!
numerator

	^numerator! !

!Fraction methodsFor: 'private'!
reduced

	| gcd numer denom |
	numerator = 0 ifTrue: [^0].
	gcd _ numerator gcd: denominator.
	numer _ numerator // gcd.
	denom _ denominator // gcd.
	denom = 1 ifTrue: [^numer].
	^Fraction numerator: numer denominator: denom! !

!Fraction methodsFor: 'private' stamp: 'tfei 4/12/1999 12:45'!
setNumerator: n denominator: d

	d = 0
		ifTrue: [^(ZeroDivide dividend: n) signal]
		ifFalse: 
			[numerator _ n asInteger.
			denominator _ d asInteger abs. "keep sign in numerator"
			d < 0 ifTrue: [numerator _ numerator negated]]! !


!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:03'!
raisedToInteger: anInteger 
	"See Number | raisedToInteger:"
	anInteger = 0 ifTrue: [^ 1].
	anInteger < 0 ifTrue: [^ self reciprocal raisedToInteger: anInteger negated].
	^ Fraction numerator: (numerator raisedToInteger: anInteger)
		denominator: (denominator raisedToInteger: anInteger)! !

!Fraction methodsFor: 'mathematical functions' stamp: 'LC 4/22/1998 14:05'!
squared
	"See Fraction (Number) | squared"
	^ Fraction numerator: numerator squared denominator: denominator squared! !

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

Fraction class
	instanceVariableNames: ''!

!Fraction class methodsFor: 'instance creation' stamp: 'di 8/31/1999 10:16'!
numerator: numInteger denominator: denInteger 
	"Answer an instance of me (numInteger/denInteger).
	NOTE: This primitive initialization method will not reduce improper fractions,
	so normal usage should be coded as, eg,
		(Fraction numerator: a denominator: b) reduced
	or, more simply, as
		a / b."

	^self new setNumerator: numInteger denominator: denInteger! !
StringMorph subclass: #FrameRateMorph
	instanceVariableNames: 'lastDisplayTime framesSinceLastDisplay '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!FrameRateMorph methodsFor: 'as yet unclassified'!
initialize

	super initialize.
	lastDisplayTime _ 0.
	framesSinceLastDisplay _ 0.! !

!FrameRateMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/5/2000 06:52'!
step
	"Compute and display (every half second or so) the current framerate"

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

!FrameRateMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/23/98 18:41'!
stepTime
	"Answer the desired time between steps in milliseconds."

	^ 0
! !
AlignmentMorph subclass: #FreeCell
	instanceVariableNames: 'board cardsRemainingDisplay elapsedTimeDisplay gameNumberDisplay lastGameLost state autoMoveRecursionCount myFillStyle '
	classVariableNames: 'Statistics '
	poolDictionaries: ''
	category: 'Morphic-Games'!

!FreeCell methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:17'!
initialize

	super initialize.
	Statistics newSession.
	autoMoveRecursionCount _ 0.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	self
		color: self colorNearTop;
		borderWidth: 2;
		addMorph: self makeControls;
		addMorph: self board;
		newGame.

! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/16/1999 17:17'!
makeCardsRemainingDisplay

	cardsRemainingDisplay _ LedMorph new
		digits: 2;
		extent: (2*10@15).
	^self wrapPanel: cardsRemainingDisplay label: 'Cards Left: '! !

!FreeCell methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:17'!
makeControlBar

	^AlignmentMorph newRow
		color: self colorNearBottom;
		borderColor: #inset;
		borderWidth: 2;
		layoutInset: 0;
		hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter;
		yourself.! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/24/1999 14:38'!
makeControls

	^self makeControlBar
		addMorph: AlignmentMorph newVariableTransparentSpacer;
		addMorph: self makeHelpButton;
		addMorph: self makeQuitButton;
		addMorph: self makeStatisticsButton;
		addMorph: self makeGameNumberDisplay;
		addMorph: self makePickGameButton;
		addMorph: self makeSameGameButton;
		addMorph: self makeNewGameButton;
		addMorph: self makeElapsedTimeDisplay;
		addMorph: self makeCardsRemainingDisplay;
		yourself.! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/23/1999 21:27'!
makeElapsedTimeDisplay

	elapsedTimeDisplay _ LedTimerMorph new
		digits: 3;
		extent: (3*10@15).
	^self wrapPanel: elapsedTimeDisplay label: 'Elapsed Time: '! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/23/1999 22:45'!
makeGameNumberDisplay

	gameNumberDisplay _ LedMorph new
		digits: 5;
		extent: (5*10@15).
	^self wrapPanel: gameNumberDisplay label: 'Game #: '! !

!FreeCell methodsFor: 'initialization' stamp: 'di 10/19/1999 01:12'!
makeHelpButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Help'
		selector: #help! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/16/1999 15:05'!
makeNewGameButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'New game'
		selector: #newGame! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/23/1999 22:46'!
makePickGameButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Pick game'
		selector: #pickGame! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/23/1999 21:18'!
makeQuitButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Quit'
		selector: #quit
! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/17/1999 17:44'!
makeSameGameButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Same game'
		selector: #sameGame! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/24/1999 14:38'!
makeStatisticsButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Statistics'
		selector: #statistics! !

!FreeCell methodsFor: 'initialization' stamp: 'djp 10/31/1999 18:48'!
openInWindowLabeled: aString inWorld: aWorld

	^(super openInWindowLabeled: aString inWorld: aWorld)
		model: self;
		yourself! !


!FreeCell methodsFor: 'accessing' stamp: 'djp 10/31/1999 19:28'!
board

	board ifNil: 
		[board _ FreeCellBoard new
			target: self;
			actionSelector: #boardAction:].
	^board! !

!FreeCell methodsFor: 'accessing' stamp: 'djp 10/24/1999 21:36'!
currentGame

	^self board cardDeck seed! !

!FreeCell methodsFor: 'accessing' stamp: 'djp 10/25/1999 21:56'!
helpText

	^'The objective of FreeCell is to move all of the cards to the four "home cells" in the upper right corner.  Each home cell will hold one suit and must be filled sequentially starting with the Ace.

There are four "free cells" in the upper left corner that can each hold one card.  Cards can be moved from the bottom of a stack to a free cell or to another stack.  

When moving a card to another stack, it must have a value that is one less than the exposed card and of a different color.'! !


!FreeCell methodsFor: 'actions' stamp: 'djp 10/31/1999 21:17'!
autoMovingHome

	elapsedTimeDisplay pause.
	autoMoveRecursionCount _ autoMoveRecursionCount + 1.! !

!FreeCell methodsFor: 'actions' stamp: 'djp 10/31/1999 21:35'!
boardAction: actionSymbol

	actionSymbol = #cardMovedHome 	ifTrue: [^self cardMovedHome].
	actionSymbol = #autoMovingHome	ifTrue: [^self autoMovingHome].! !

!FreeCell methodsFor: 'actions' stamp: 'di 3/5/2000 15:30'!
cardMovedHome

	cardsRemainingDisplay value: (cardsRemainingDisplay value - 1).
	autoMoveRecursionCount _ autoMoveRecursionCount - 1 max: 0.
	cardsRemainingDisplay value = 0 
		ifTrue: [self gameWon]
		ifFalse: [autoMoveRecursionCount = 0 ifTrue: [elapsedTimeDisplay continue]].! !

!FreeCell methodsFor: 'actions' stamp: 'di 3/5/2000 16:20'!
gameLost

	state _ #lost.
	elapsedTimeDisplay stop.
	cardsRemainingDisplay highlighted: true; flash: true.
	Statistics gameLost: self currentGame! !

!FreeCell methodsFor: 'actions' stamp: 'di 3/5/2000 16:20'!
gameWon

	state _ #won.
	elapsedTimeDisplay stop; highlighted: true; flash: true.
	Statistics gameWon: self currentGame! !

!FreeCell methodsFor: 'actions' stamp: 'di 10/19/1999 01:12'!
help
	| window helpMorph |

	window _ SystemWindow labelled: 'FreeCell Help'.
	window model: self.
	helpMorph _ (PluggableTextMorph new editString: self helpText)
				 lock.
	window addMorph: helpMorph frame: (0@0 extent: 1@1).
	window openInWorld.
! !

!FreeCell methodsFor: 'actions' stamp: 'di 12/12/2000 13:08'!
inAutoMove
	"Return true if an automove sequence is in progress"

	^ autoMoveRecursionCount > 0! !

!FreeCell methodsFor: 'actions' stamp: 'th 12/15/1999 15:20'!
modelSleep
	"When fixing #contains: calls beware of reinventing #includes:"
	(#(newGame sameGame pickGame won lost ) includes: state)
		ifTrue: [elapsedTimeDisplay pause]! !

!FreeCell methodsFor: 'actions' stamp: 'th 12/15/1999 15:22'!
modelWakeUp
	"Maybe less performant but more readable"
	(#(won lost) includes: state)
		ifFalse: [elapsedTimeDisplay resume]! !

!FreeCell methodsFor: 'actions' stamp: 'di 1/16/2000 10:35'!
newGame
	Collection initialize.
	self newGameNumber: nil.
	state _ #newGame! !

!FreeCell methodsFor: 'actions' stamp: 'di 3/5/2000 16:21'!
newGameNumber: aSeedOrNil 
	cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].
	cardsRemainingDisplay flash: false; highlighted: false; value: 52.
	elapsedTimeDisplay flash: false; highlighted: false.
	"board handles nil case"
	self board pickGame: aSeedOrNil.
	elapsedTimeDisplay reset; start.
	gameNumberDisplay value: self currentGame! !

!FreeCell methodsFor: 'actions' stamp: 'th 12/15/1999 15:05'!
pickGame
	| seed |
	seed _ self promptForSeed.
	seed isNil ifTrue: [^ self].
	self newGameNumber: seed.
	state _ #pickGame! !

!FreeCell methodsFor: 'actions' stamp: 'th 12/15/1999 14:56'!
promptForSeed
	| s i |
	
	[s _ FillInTheBlank request: 'Pick a game number between 1 and 32000'.
	"Let the user cancel."
	s isEmpty ifTrue:[^nil].
	[i _ s asNumber asInteger]
		on: Error do: [i _ 0].
	i between: 1 and: 32000] whileFalse.
	^ i! !

!FreeCell methodsFor: 'actions' stamp: 'di 3/5/2000 15:35'!
quit
	cardsRemainingDisplay value ~~ 0 ifTrue: [self gameLost].

	self owner == self world
		ifTrue: [self delete]
		ifFalse: [self owner delete].
	Statistics close! !

!FreeCell methodsFor: 'actions' stamp: 'th 12/15/1999 15:03'!
sameGame
	self newGameNumber: self currentGame.
	state _ #sameGame.

! !

!FreeCell methodsFor: 'actions' stamp: 'djp 10/24/1999 15:07'!
statistics

	Statistics display! !


!FreeCell methodsFor: 'private' stamp: 'ar 11/9/2000 21:16'!
buildButton: aButton target: aTarget label: aLabel selector: aSelector
	"wrap a button or switch in an alignmentMorph to provide some space around the button"

	| a |
	aButton 
		target: aTarget;
		label: aLabel;
		actionSelector: aSelector;
		borderColor: #raised;
		borderWidth: 2;
		color: Color gray.
	a _ AlignmentMorph newColumn
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: Color transparent;
		layoutInset: 1.
	a addMorph: aButton.
	^ a

! !

!FreeCell methodsFor: 'private' stamp: 'ar 11/9/2000 21:17'!
wrapPanel: anLedPanel label: aLabel
	"wrap an LED panel in an alignmentMorph with a label to its left"

	| a |
	a _ AlignmentMorph newRow
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 0;
		layoutInset: 5;
		color: Color transparent.
	a addMorph: anLedPanel.
	a addMorph: (StringMorph contents: aLabel). 
	^ a
! !


!FreeCell methodsFor: 'visual properties' stamp: 'RAA 3/3/2000 23:28'!
colorNearBottom

	^Color r: 0.0 g: 0.455 b: 0.18! !

!FreeCell methodsFor: 'visual properties' stamp: 'RAA 3/4/2000 10:26'!
colorNearTop

	^ (Color r: 0.304 g: 0.833 b: 0.075)! !

!FreeCell methodsFor: 'visual properties' stamp: 'RAA 3/3/2000 23:29'!
defaultBackgroundColor

	^Color r: 0.365 g: 1.0 b: 0.09! !


!FreeCell methodsFor: 'as yet unclassified' stamp: 'RAA 3/4/2000 17:01'!
fillStyle

	myFillStyle ifNil: [
		myFillStyle _ GradientFillStyle ramp: {
			0.0 -> self colorNearTop. 
			1.0 -> self colorNearBottom
		}.
	].
	^myFillStyle
		origin: self position;
		direction: (self width // 2)@self height
! !

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

FreeCell class
	instanceVariableNames: ''!

!FreeCell class methodsFor: 'class initialization' stamp: 'djp 10/24/1999 14:50'!
initialize

	Statistics _ FreeCellStatistics new.! !
AlignmentMorph subclass: #FreeCellBoard
	instanceVariableNames: 'cardDeck lastCardDeck freeCells homeCells stacks target actionSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!FreeCellBoard methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:54'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	self vResizing: #rigid.
	self height: 500.
	borderWidth _ 0.
	color _ Color green.
	self layout.
! !

!FreeCellBoard methodsFor: 'initialization' stamp: 'di 11/29/2000 18:50'!
pickGame: aSeedOrNil
	| sorted msg |
	cardDeck _ PlayingCardDeck newDeck.
	aSeedOrNil == 1
	ifTrue:
		["Special case of game 1 does a time profile playing the entire (trivial) game."
		sorted _ cardDeck submorphs asSortedCollection: [ :a :b | a cardNumber >= b cardNumber].
		cardDeck
			removeAllMorphs;
			addAllMorphs: sorted.
		self resetBoard.
		self world doOneCycle.
		Utilities informUser: 'Game #1 is a special case
for performance analysis' during:
			[msg _ self world firstSubmorph.
			msg align: msg topRight with: owner bottomRight.
			MessageTally spyOn: [sorted last owner doubleClickOnCard: sorted last]]]
	ifFalse:
		[aSeedOrNil ifNotNil:[cardDeck seed: aSeedOrNil].
		cardDeck shuffle.
		self resetBoard].
	! !

!FreeCellBoard methodsFor: 'initialization' stamp: 'di 12/12/2000 15:02'!
resetBoard

	self purgeAllCommands.
	self resetFreeCells;
		resetHomeCells;
		resetStacks;
		changed.! !

!FreeCellBoard methodsFor: 'initialization' stamp: 'djp 10/16/1999 20:06'!
resetFreeCells

	freeCells do: [:deck | deck removeAllCards]! !

!FreeCellBoard methodsFor: 'initialization' stamp: 'djp 10/16/1999 20:06'!
resetHomeCells

	homeCells do: [:deck | deck removeAllCards]! !

!FreeCellBoard methodsFor: 'initialization' stamp: 'djp 10/16/1999 20:06'!
resetStacks
	| card stackStream stack |

	stacks do: [:deck | deck removeAllCards].
	stackStream _ ReadStream on: stacks.
	[card _ cardDeck deal.
	card notNil] whileTrue: [
		stack _ stackStream next ifNil: [stackStream reset; next].
		stack addCard: card].
! !


!FreeCellBoard methodsFor: 'layout' stamp: 'ar 11/20/2000 19:08'!
cardCell

	^PlayingCardDeck new
		layout: #pile; 
		listDirection: #topToBottom;
		enableDragNDrop;
		color: Color transparent;
		borderColor: (Color gray alpha: 0.5);
		borderWidth: 2;
		layoutBounds: (0@0 extent: PlayingCardMorph width @ PlayingCardMorph height);
		yourself! !

!FreeCellBoard methodsFor: 'layout' stamp: 'RAA 3/3/2000 23:33'!
cellsRow
	| row |

	row := (AlignmentMorph newRow)
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		color: Color transparent;
		addAllMorphs: self freeCells;
		addMorphBack: self cellsRowSpacer;
		addAllMorphs: self homeCells;
		yourself.
	^row! !

!FreeCellBoard methodsFor: 'layout' stamp: 'djp 10/17/1999 18:25'!
cellsRowSpacer
	| column |

	column := (AlignmentMorph newColumn)
		vResizing: #rigid;
		hResizing: #rigid;
		color: Color transparent;
		extent: PlayingCardMorph cardSize;
		yourself.
	^column! !

!FreeCellBoard methodsFor: 'layout' stamp: 'th 12/15/1999 16:14'!
freeCell
	| freeCell |
	freeCell _ self cardCell.
	freeCell stackingPolicy: #single;
	 emptyDropPolicy: #any;
	 target: self;
	 cardDroppedSelector: #cardMoved;
	 acceptCardSelector: #acceptSingleCard:on:.
	^ freeCell! !

!FreeCellBoard methodsFor: 'layout' stamp: 'djp 10/11/1999 16:41'!
freeCells

	^freeCells ifNil: [freeCells := (1 to: 4) collect: [:i | self freeCell]]! !

!FreeCellBoard methodsFor: 'layout' stamp: 'th 12/15/1999 16:12'!
homeCell
	| homeCell |
	homeCell _ self cardCell.
	homeCell stackingPolicy: #straight;
	 stackingOrder: #ascending;
	 emptyDropPolicy: #inOrder;
	 target: self;
	 cardDroppedSelector: #cardMovedHome;
	 cardDraggedSelector: #dragCard:fromHome:;
	 acceptCardSelector: #acceptSingleCard:on:.
	^ homeCell! !

!FreeCellBoard methodsFor: 'layout' stamp: 'djp 10/11/1999 16:41'!
homeCells

	^homeCells ifNil: [homeCells := (1 to: 4) collect: [:i | self homeCell]]! !

!FreeCellBoard methodsFor: 'layout' stamp: 'djp 10/11/1999 18:27'!
layout

	self 
		addMorphBack: self cellsRow;
		addMorphBack: self stacksRow.
! !

!FreeCellBoard methodsFor: 'layout' stamp: 'ar 11/9/2000 20:55'!
stack
	^ PlayingCardDeck new color: Color transparent;
	 layout: #stagger;
	 listDirection: #topToBottom;
	 enableDragNDrop;
	 stackingPolicy: #altStraight;
	 stackingOrder: #descending;
	 emptyDropPolicy: #any;
	 target: self;
	 cardDroppedSelector: #cardMoved;
	 cardDraggedSelector: #dragCard:fromStack:;
	 acceptCardSelector: #acceptCard:onStack:;
	 cardDoubleClickSelector: #doubleClickInStack:OnCard:! !

!FreeCellBoard methodsFor: 'layout' stamp: 'djp 10/11/1999 16:41'!
stacks

	^stacks ifNil: [stacks:= (1 to: 8) collect: [:i | self stack]]! !

!FreeCellBoard methodsFor: 'layout' stamp: 'ar 11/20/2000 18:58'!
stacksRow
	| row |

	row := (AlignmentMorph newRow)
		vResizing: #spaceFill;
		hResizing: #spaceFill;
		wrapCentering: #topLeft;
		cellPositioning: #topLeft;
		color: Color transparent;
		yourself.
	self stacks do: [:stack |
		row 
			addMorphBack: AlignmentMorph newVariableTransparentSpacer;
			addMorphBack: stack].
	row addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	^row! !


!FreeCellBoard methodsFor: 'private' stamp: 'RAA 3/4/2000 10:48'!
autoMoveCardsHome
	| first |

	first _ false.
	(self stacks, self freeCells) do: [:deck |
		self homeCells do: [ :homeCell |
			deck hasCards ifTrue: [
				(homeCell repelCard: deck topCard) ifFalse: [
					(self isPlayableCardInHomeCells: deck topCard) ifTrue: [
						first ifFalse: [ " trigger autoMoving event on first move."
							first _ true.
							self performActionSelector: #autoMovingHome
						].
						self visiblyMove: deck topCard to: homeCell.
					]
				]
			]
		]
	].

! !

!FreeCellBoard methodsFor: 'private' stamp: 'RAA 3/4/2000 17:11'!
isPlayableCardInHomeCells: aPlayingCard
	| unplayedOther topsThisColor topsOtherColor unplayedSame | 
	" are all cards that could be played on this card if it stayed on the stack present in the
	home cells?"

	aPlayingCard cardNumber <= 2 ifTrue: [^true].	"special case for Aces and 2's"
	topsThisColor _ OrderedCollection new.
	topsOtherColor _ OrderedCollection new.
	self homeCells do: [ :deck |
		deck hasCards ifTrue: [
			(aPlayingCard suitColor == deck topCard suitColor 
					ifTrue: [topsThisColor] ifFalse: [topsOtherColor]) add: deck topCard cardNumber.
		]
	].
	unplayedOther _ topsOtherColor size < 2 ifTrue: [1] ifFalse: [topsOtherColor min + 1].
	unplayedSame _ topsThisColor size < 2 ifTrue: [1] ifFalse: [topsThisColor min + 1].
	unplayedOther > (aPlayingCard cardNumber - 1) ifTrue: [^true].
	unplayedOther < (aPlayingCard cardNumber - 1) ifTrue: [^false].
	^unplayedSame >= (unplayedOther - 1)
! !

!FreeCellBoard methodsFor: 'private' stamp: 'djp 10/24/1999 00:50'!
maxDraggableStackSize: dropIntoEmptyStack
	"Note: dropIntoEmptyStack, means one less empty stack to work with.
		This needs to be reevaluated at time of drop."
	"Not super smart - doesn't use stacks that are buildable though not empty"

	| nFree nEmptyStacks |
	nFree _ (freeCells select: [:d | d hasCards not]) size.
	nEmptyStacks _ (stacks select: [:d | d hasCards not]) size.
	dropIntoEmptyStack ifTrue: [nEmptyStacks _ nEmptyStacks - 1].
	^ (1 + nFree) * (2 raisedTo: nEmptyStacks)! !

!FreeCellBoard methodsFor: 'private' stamp: 'djp 10/31/1999 20:15'!
performActionSelector: actionSymbol

	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		target perform: actionSelector with: actionSymbol].! !

!FreeCellBoard methodsFor: 'private' stamp: 'di 12/12/2000 13:09'!
visiblyMove: aCard to: aCell
	| p1 p2 nSteps |
	self inAutoMove ifFalse: [self captureStateBeforeGrab].
	owner owner addMorphFront: aCard.
	p1 _ aCard position.
	p2 _ aCell position.
	nSteps _ 10.
	1 to: nSteps-1 do: "Note final step happens with actual drop"
		[:i | aCard position: ((p2*i) + (p1*(nSteps-i))) // nSteps.
		self world displayWorld].
	aCell acceptDroppingMorph: aCard event: nil! !


!FreeCellBoard methodsFor: 'actions' stamp: 'th 12/9/1999 19:10'!
acceptCard: aCard onStack: aDeck
	" assumes that number of cards was check at drag time, need to reduce count if dropping
	into an empty stack"
	aCard hasSubmorphs 
		ifTrue: [
			aDeck ifEmpty: [
				(aCard submorphCount+1) > (self maxDraggableStackSize: true)
					ifTrue: [^false]]]
		ifFalse: [^ nil].
	^nil.

! !

!FreeCellBoard methodsFor: 'actions' stamp: 'th 12/15/1999 16:17'!
acceptSingleCard: aCard on: aDeck 
	"Home cells and free cells don't accept multiple cards on a home cell, 
	defer to deck for other cases"
	aCard hasSubmorphs
		ifTrue: [^ false]
		ifFalse: [^ nil]! !

!FreeCellBoard methodsFor: 'actions' stamp: 'th 12/15/1999 16:15'!
cardMoved
	"Free cells and stacks do nothing special here - yet - th 12/15/1999 
	16:15 "
	self autoMoveCardsHome! !

!FreeCellBoard methodsFor: 'actions' stamp: 'djp 10/31/1999 22:02'!
cardMovedHome

	self autoMoveCardsHome.
	self performActionSelector: #cardMovedHome.! !

!FreeCellBoard methodsFor: 'actions' stamp: 'RAA 3/4/2000 17:07'!
doubleClickInStack: aDeck OnCard: aCard

	"if there is an empty free cell, move the card there. otherwise try for an empty stack"

	aCard == aDeck topCard ifFalse: [^self].
	freeCells do: [:freeCell |
		freeCell ifEmpty: [
			self visiblyMove: aCard to: freeCell.
			^ aCard
		]
	].
	stacks do: [ :each |
		each ifEmpty: [
			self visiblyMove: aCard to: each.
			^ aCard
		]
	].
! !

!FreeCellBoard methodsFor: 'actions' stamp: 'djp 10/24/1999 03:08'!
dragCard: aCard fromHome: aCardDeck

	^nil		"don't allow any cards to be dragged from a home cell"! !

!FreeCellBoard methodsFor: 'actions' stamp: 'djp 10/24/1999 00:46'!
dragCard: aCard fromStack: aCardDeck
	| i cards |

	cards _ aCardDeck cards.
	i _ cards indexOf: aCard ifAbsent: [^ nil].
	i > (self maxDraggableStackSize: false) ifTrue: [^ nil].
	[i > 1] whileTrue:
		[(aCardDeck inStackingOrder: (cards at: i-1) 
					onTopOf: (cards at: i)) ifFalse: [^ nil].
		i _ i-1].
	^ aCard! !

!FreeCellBoard methodsFor: 'actions' stamp: 'di 12/12/2000 13:08'!
inAutoMove
	"Return true if an automove sequence is in progress"

	^ owner inAutoMove! !


!FreeCellBoard methodsFor: 'accessing' stamp: 'djp 10/16/1999 16:21'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!FreeCellBoard methodsFor: 'accessing' stamp: 'djp 10/11/1999 15:51'!
cardDeck
	^cardDeck! !

!FreeCellBoard methodsFor: 'accessing' stamp: 'djp 10/16/1999 15:33'!
target: anObject

	target _ anObject! !


!FreeCellBoard methodsFor: 'as yet unclassified' stamp: 'RAA 3/4/2000 17:02'!
drawOn: aCanvas

	"we don't have anything to draw, but we need a color so the inset border of one of our submorphs will work"
! !


!FreeCellBoard methodsFor: 'undo' stamp: 'di 12/12/2000 11:54'!
captureStateBeforeGrab

	self removeProperty: #stateBeforeGrab.
	self setProperty: #stateBeforeGrab toValue: self capturedState
! !

!FreeCellBoard methodsFor: 'undo' stamp: 'di 12/12/2000 11:50'!
capturedState

	self valueOfProperty: #stateBeforeGrab ifPresentDo: [:st | ^ st].
	^ {	freeCells collect: [:deck | deck submorphs].
		homeCells collect: [:deck | deck submorphs].
		stacks collect: [:deck | deck submorphs] }
! !

!FreeCellBoard methodsFor: 'undo' stamp: 'di 12/12/2000 12:14'!
rememberUndoableAction: aBlock named: caption

	self inAutoMove ifTrue: [^ aBlock value].
	^ super rememberUndoableAction: aBlock named: caption! !

!FreeCellBoard methodsFor: 'undo' stamp: 'di 12/12/2000 08:12'!
undoFromCapturedState: st
	freeCells with: st first do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
	homeCells with: st second do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs].
	stacks with: st third do: [:deck :morphs | deck removeAllMorphs; addAllMorphs: morphs]! !

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

FreeCellBoard class
	instanceVariableNames: ''!

!FreeCellBoard class methodsFor: 'as yet unclassified' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
Object subclass: #FreeCellStatistics
	instanceVariableNames: 'sessionWins sessionLosses totalWins totalLosses streakWins streakLosses winsWithReplay lossesWithReplay lastGameWon lastGameLost currentCount currentType window statsMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!FreeCellStatistics methodsFor: 'initialization' stamp: 'djp 10/24/1999 17:26'!
initialize

	self reset.! !


!FreeCellStatistics methodsFor: 'printing' stamp: 'th 12/20/1999 20:37'!
print: aNumber type: type on: aStream 
	"I moved the code from #printWins:on: and #printLosses:on: here because it is basically
	the same. I hope this increases the maintainability. - th 12/20/1999 20:37"
	aStream print: aNumber.
	type = #wins
		ifTrue: [aNumber = 1
				ifTrue: [aStream nextPutAll: ' win']
				ifFalse: [aStream nextPutAll: ' wins']].
	type = #losses
		ifTrue: [aNumber = 1
				ifTrue: [aStream nextPutAll: ' loss']
				ifFalse: [aStream nextPutAll: ' losses']]! !

!FreeCellStatistics methodsFor: 'printing' stamp: 'di 3/5/2000 15:22'!
printOn: aStream

	self printSessionOn: aStream.
	aStream cr.
	self printTotalOn: aStream.
	aStream cr.
	self printReplaysOn: aStream.
	aStream cr.
	self printStreaksOn: aStream.! !

!FreeCellStatistics methodsFor: 'printing' stamp: 'di 3/5/2000 15:38'!
printReplaysOn: aStream 
	| total |
	aStream nextPutAll: 'With replays: ';
	 tab.
	self print: winsWithReplay type: #wins on: aStream.
	aStream nextPutAll: ', '.
	self print: lossesWithReplay type: #losses on: aStream.
	total _ winsWithReplay + lossesWithReplay.
	total ~~ 0 ifTrue: [aStream nextPutAll: ', ';
		 print: (winsWithReplay / total * 100) asInteger;
		 nextPut: $%]! !

!FreeCellStatistics methodsFor: 'printing' stamp: 'th 12/20/1999 19:50'!
printSessionOn: aStream 
	| total |
	aStream nextPutAll: 'This session: ' , String tab.
	self print: sessionWins type: #wins on: aStream.
	aStream nextPutAll: ', '.
	self print: sessionLosses type: #losses on: aStream.
	total _ sessionWins + sessionLosses.
	total ~~ 0 ifTrue: [aStream nextPutAll: ', ';
		 print: (sessionWins / total * 100) asInteger;
		 nextPut: $%]! !

!FreeCellStatistics methodsFor: 'printing' stamp: 'th 12/20/1999 19:53'!
printStreaksOn: aStream 
	aStream nextPutAll: 'Streaks: ';
	 tab;
	 tab.
	self
		print: streakWins
		type: #wins
		on: aStream.
	aStream nextPutAll: ', '.
	self
		print: streakLosses
		type: #losses
		on: aStream.
	aStream cr; tab; tab; tab; tab; nextPutAll: 'Current: '.
	self
		print: currentCount
		type: currentType
		on: aStream! !

!FreeCellStatistics methodsFor: 'printing' stamp: 'th 12/20/1999 19:48'!
printTotalOn: aStream 
	| total |
	aStream nextPutAll: 'Total: ';
	 tab;
	 tab;
	 tab.
	self print: totalWins type: #wins on: aStream.
	aStream nextPutAll: ', '.
	self print: totalLosses type: #losses on: aStream.
	total _ totalWins + totalLosses.
	total ~~ 0 ifTrue: [aStream nextPutAll: ', ';
		 print: (totalWins / total * 100) asInteger;
		 nextPut: $%]! !


!FreeCellStatistics methodsFor: 'actions' stamp: 'djp 10/24/1999 19:04'!
changed

	window ifNotNil: [
		statsMorph ifNotNil: [statsMorph contents: self statsText]]! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'di 3/5/2000 14:30'!
gameLost: gameNumber

	"Don't count multiple losses of the same game"
	gameNumber = lastGameLost ifTrue: [^ self].
	lastGameLost _ gameNumber.

	sessionLosses _ sessionLosses + 1.
	totalLosses _ totalLosses + 1.
	lossesWithReplay _ lossesWithReplay + 1.
	currentType = #losses
		ifTrue: [currentCount _ currentCount + 1]
		ifFalse: 
			[currentCount _ 1.
			currentType _ #losses].
	self updateStreak.
	self changed! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'di 3/5/2000 16:48'!
gameWon: gameNumber
	sessionWins _ sessionWins + 1.
	totalWins _ totalWins + 1.
	gameNumber = lastGameWon ifFalse:
		[gameNumber = lastGameLost ifTrue:
			["Finally won a game by replaying"
			lossesWithReplay _ lossesWithReplay - 1].
		winsWithReplay _ winsWithReplay + 1].
	lastGameWon _ gameNumber.
	currentType = #wins
		ifTrue: [currentCount _ currentCount + 1]
		ifFalse: [currentCount _ 1.
				currentType _ #wins].
	self updateStreak.
	self changed! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'djp 10/24/1999 19:21'!
newSession

	sessionWins _ 0.
	sessionLosses _ 0.
	currentCount _ 0.
	currentType _ nil.
	self changed.! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'djp 10/24/1999 17:15'!
ok

	window delete.
	window _ nil.! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'di 3/5/2000 14:30'!
reset

	sessionWins 		_ 0.
	sessionLosses 	_ 0.
	totalWins 		_ 0.
	totalLosses 		_ 0.
	streakWins		_ 0.
	streakLosses 	_ 0.
 	winsWithReplay _ 0.
	lossesWithReplay _ 0.
	lastGameWon	_ 0.
	lastGameLost 	_ 0.
	currentCount 	_ 0.
	currentType		_ nil.
	self changed.
	

	! !

!FreeCellStatistics methodsFor: 'actions' stamp: 'th 12/20/1999 20:42'!
updateStreak
	"I moved the code from #printWins:on: and #printLosses:on: here because 
	 it is basically the same. I hope this increases the maintainability. 
	th 12/20/1999 20:41"
	currentType = #losses ifTrue: [streakLosses _ streakLosses max: currentCount].
	currentType = #wins ifTrue: [streakWins _ streakWins max: currentCount]! !


!FreeCellStatistics methodsFor: 'user interface' stamp: 'ar 11/9/2000 21:17'!
buildButton: aButton target: aTarget label: aLabel selector: aSelector
	"wrap a button or switch in an alignmentMorph to provide some space around the button"

	| a |
	aButton 
		target: aTarget;
		label: aLabel;
		actionSelector: aSelector;
		borderColor: #raised;
		borderWidth: 2;
		color: Color gray.
	a _ AlignmentMorph newColumn
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		color: Color transparent;
		layoutInset: 1.
	a addMorph: aButton.
	^ a

! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 19:20'!
close

	window ifNotNil: [
		window delete.
		window _ nil].! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 16:42'!
color

	^Color green darker! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'ar 11/9/2000 21:18'!
display
	| panel |

	(window notNil and: [window owner notNil]) ifTrue: [window activate. ^nil].
	panel _ AlignmentMorph newColumn.
	panel
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #rigid;
		vResizing: #rigid;
		extent: 250@150;
		color: self color;
		addMorphBack: self makeStatistics;
		addMorphBack: self makeControls.
	window _ panel openInWindowLabeled: 'FreeCell Statistics'.! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'ar 11/9/2000 21:18'!
makeControls
	| row |

	row _ AlignmentMorph newRow.
	row
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		color: self color;
		borderWidth: 2;
		borderColor: #inset;
		addMorphBack: self makeOkButton;
		addMorphBack: self makeResetButton.
	^row.! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 16:34'!
makeOkButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'OK'
		selector: #ok! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 17:07'!
makeResetButton

	^self
		buildButton: SimpleButtonMorph new
		target: self
		label: 'Reset'
		selector: #reset! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'ar 11/9/2000 21:26'!
makeStatistics
	| row |

	row _ AlignmentMorph newRow.
	row
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		color: self color;
		borderWidth: 2;
		borderColor: #inset;
		addMorphBack: (AlignmentMorph newColumn
			wrapCentering: #center; cellPositioning: #topCenter;
			color: self color;
			addMorph: (statsMorph _ TextMorph new contents: self statsText)).
	^row.! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 19:04'!
statsText

	^ String cr,self printString,String cr! !

!FreeCellStatistics methodsFor: 'user interface' stamp: 'djp 10/24/1999 15:56'!
stringMorphFromPrintOn: aSelector
	
	^StringMorph new 
		contents: (String streamContents: [:s | self perform: aSelector with: s]);
		yourself.! !

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

FreeCellStatistics class
	instanceVariableNames: ''!

!FreeCellStatistics class methodsFor: 'instance creation' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !

!FreeCellStatistics class methodsFor: 'instance creation' stamp: 'djp 10/24/1999 17:03'!
new

	^super new initialize! !
Object subclass: #FreeTranslation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-TelNet WordNet'!
!FreeTranslation commentStamp: '<historical>' prior: 0!
Squeak interface to the translation server at www.freetranslation.com.  Invoke it in any Squeak text pane by choosing 'translate it' from the shift-menu.  Languages are set by the 'choose language; menu item of the shift menu.  Or by changing (Preferences valueOfFlag: #languageTranslateFrom) and (Preferences valueOfFlag: #languageTranslateTo).   
	See class method openScamperOn:.

	FreeTranslation openScamperOn: 'Why don''t you ever write anymore?'

!


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

FreeTranslation class
	instanceVariableNames: ''!

!FreeTranslation class methodsFor: 'as yet unclassified' stamp: 'tk 7/19/2000 08:19'!
extract: aMimeDoc
	| pageSource str |
	"Extract the translated text from the web page"

	(aMimeDoc content beginsWith: 'error') ifTrue: [^ aMimeDoc content].
	pageSource _ aMimeDoc content isoToSqueak.
	"brute force way to pull out the result"
	str _ ReadStream on: pageSource.
	str match: 'Translation Results by Transparent Language'.
	str match: '<p>'.
	^ str upToAll: '</p>'! !

!FreeTranslation class methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 13:54'!
openScamperOn: currentSelection
	"Submit the string to the translation server at www.freetranslation.com.  Ask it to translate from (Preferences valueOfFlag: #languageTranslateFrom) to (Preferences valueOfFlag: #languageTranslateTo).  Display the results in a Scamper window, reusing the previous one if possible."

	| inputs scamperWindow from to | 
	currentSelection size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
	(Preferences valueOfFlag: #languageTranslateFrom) == false ifTrue: [
			Preferences setPreference: #languageTranslateFrom toValue: 'English'].
	(Preferences valueOfFlag: #languageTranslateTo) == false ifTrue: [
			Preferences setPreference: #languageTranslateTo toValue: 'German'].
	(from _ Preferences valueOfFlag: #languageTranslateFrom) = 
		(to _ Preferences valueOfFlag: #languageTranslateTo) ifTrue: [
			^ self inform: 'You asked to translate from ', from, ' to ', to, '.\' withCRs,
				'Use "choose language" to set these.'].  
	inputs _ Dictionary new.
	inputs at: 'SrcText' put: (Array with: currentSelection).
	inputs at: 'Sequence' put: #('core').
	inputs at: 'Mode' put: #('html').
	inputs at: 'template' put: #('TextResult2.htm').
	inputs at: 'Language' put: (Array with: from, '/', to).
	scamperWindow _ Scamper newOrExistingOn: 'http://ets.freetranslation.com'.
	scamperWindow model submitFormWithInputs: inputs 
		url: 'http://ets.freetranslation.com:5081' asUrl
		method: 'post'.
	scamperWindow activate.
! !

!FreeTranslation class methodsFor: 'as yet unclassified' stamp: 'tk 7/15/2000 07:33'!
translate: aString from: fromLang to: toLang
	| inputs |
	"Submit the string to the translation server at www.freetranslation.com.  Return the entire web page that freetranslation sends back."

	aString size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.'].
	inputs _ Dictionary new.
	inputs at: 'SrcText' put: (Array with: aString).
	inputs at: 'Sequence' put: #('core').
	inputs at: 'Mode' put: #('html').
	inputs at: 'template' put: #('TextResult2.htm').
	inputs at: 'Language' put: (Array with: fromLang, '/', toLang).
	^ 'http://ets.freetranslation.com:5081' asUrl postFormArgs: inputs.
	
! !

!FreeTranslation class methodsFor: 'as yet unclassified' stamp: 'tk 1/3/2001 08:58'!
translatePanel: buttonPlayer fromTo: normalDirection
	| ow fromTM toTM fromLang toLang tt doc answer width |
	"Gather up all the info I need from the morphs in the button's owner and do the translation.  Insert the results in a TextMorph.  Use www.freeTranslation.com Refresh the banner ad.
	TextMorph with 'from' in the title is starting text.
	PopUpChoiceMorph  with 'from' in the title is the starting language.
	TextMorph with 'from' in the title is place to put the answer.
	PopUpChoiceMorph  with 'from' in the title is the target language.
		If normalDirection is false, translate the other direction."

	ow _ buttonPlayer costume ownerThatIsA: PasteUpMorph.
	ow allMorphs do: [:mm |
		(mm isKindOf: TextMorph) ifTrue: [ 
			(mm knownName asString includesSubString: 'from') ifTrue: [
				 fromTM _ mm].
			(mm knownName asString includesSubString: 'to') ifTrue: [
				 toTM _ mm]].
		(mm isKindOf: PopUpChoiceMorph) ifTrue: [ 
			(mm knownName asString includesSubString: 'from') ifTrue: [
				 fromLang _ mm contents asString].
			(mm owner knownName asString includesSubString: 'from') ifTrue: [
				 fromLang _ mm contents asString].
			(mm knownName asString includesSubString: 'to') ifTrue: [
				 toLang _ mm contents asString].
			(mm owner knownName asString includesSubString: 'to') ifTrue: [
				 toLang _ mm contents asString]]].
	normalDirection ifFalse: ["switch"
		tt _ fromTM.  fromTM _ toTM.  toTM _ tt.
		tt _ fromLang.  fromLang _ toLang.  toLang _ tt].
	Cursor wait showWhile: [
		doc _ self translate: fromTM contents asString from: fromLang to: toLang.
		answer _ self extract: doc].	"pull out the translated text"
	
	width _ toTM width.
	toTM contents: answer wrappedTo: width.
	toTM changed.! !
HierarchicalUrl subclass: #FtpUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!FtpUrl commentStamp: '<historical>' prior: 0!
a reference to a file which may be downloaded by anonymous ftp!


!FtpUrl methodsFor: 'downloading' stamp: 'ls 8/12/1998 01:24'!
retrieveContents
	| server contents pathString listing |

	"currently assumes directories end in /, and things that don't end in / are files.  Also, doesn't handle errors real well...."

	server _ ServerDirectory new.
	server server: self authority.
	server directory: '/'.
	server user: 'anonymous'.
	server password: 'SqueakUser'.

	pathString _ self pathString.
	pathString _ pathString copyFrom: 2 to: pathString size. "remove the leading /"

	self path last size = 0 ifFalse: [
		"a file"
		contents _ (server getFileNamed: pathString).
		(contents respondsTo: #contents) ifTrue: [ 
			"the file exists--return it"
			^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents contents ]
		ifFalse: [
			"some error"
			^nil ]. ].

	"a directory?"
	server directory: self pathString.
	listing _ String streamContents: [ :stream |
		stream nextPutAll: '<title>', self pathString, '</title>'; cr.
		stream nextPutAll: '<h1>Listing for ', self pathString, '</h1>'; cr.
		stream nextPutAll: '<ul>'; cr.
		server entries do: [ :entry |
			stream nextPutAll: '<li>';
				nextPutAll: '<a href="', entry name encodeForHTTP.
			entry isDirectory ifTrue: [ stream nextPut: $/ ].
			stream nextPutAll: '">';
				nextPutAll: entry name;
				nextPutAll: '</a>';
				cr ] ].
	^MIMEDocument contentType: 'text/html' content: listing! !


!FtpUrl methodsFor: 'access' stamp: 'ls 7/24/1998 00:18'!
pathString
	self path isEmpty ifTrue: [ ^'/' copy ].

	^String streamContents: [ :s |
		self path do: [ :p |
		 	s nextPut: $/.
			s nextPutAll: p ] ]! !
Vocabulary subclass: #FullVocabulary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!
!FullVocabulary commentStamp: '<historical>' prior: 0!
The vocabulary that it all-encompassing.  Its categories consist of the union of all categories of a class and all its superclasses.  The methods in each category consist of those with selectors that are associated with that category.!


!FullVocabulary methodsFor: 'initialization' stamp: 'sw 12/5/2000 11:02'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')
Vocabulary initialize
"

	super initialize.
	vocabularyName _ #Full.
	self documentation: '"Full" is all-encompassing vocabulary that embraces all methods understood by an object'.
	self rigAFewCategories! !

!FullVocabulary methodsFor: 'initialization' stamp: 'sw 1/26/2001 23:03'!
rigAFewCategories
	"Rig a few catgories, mate.   'Vocabulary fullVocabulary rigAFewCategories'"

	| aMethodCategory |
	#(	(accessing	'Generally holds methods to read and write instance variables')
		(initialization	'messages typically sent when an object is created, to set up its initial state'))

		do:
			[:pair |
				aMethodCategory _ ElementCategory new categoryName: pair first.
				aMethodCategory documentation: pair second.
				self addCategory: aMethodCategory]! !


!FullVocabulary methodsFor: 'category list' stamp: 'sw 12/13/2000 17:34'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object, considering only code implemented in mostGeneric and lower (or higher, depending on which way you're facing"

	| classToUse |
	classToUse _ anObject ifNil: [aClass] ifNotNil: [anObject class].
	^ mostGenericClass == classToUse
		ifTrue:
			[mostGenericClass organization categories]
		ifFalse:
			[classToUse allMethodCategoriesIntegratedThrough: mostGenericClass]! !


!FullVocabulary methodsFor: 'method list' stamp: 'sw 12/12/2000 12:22'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods which are in the given category, on behalf of anObject"

	| classToUse |
	classToUse _ aClass ifNil: [anObject class].
	^ classToUse allMethodsInCategory: categoryName! !


!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/13/2000 17:44'!
categoriesContaining: aSelector forClass: aTargetClass
	"Answer a list of category names (all symbols) of categories that contain the given selector for the target object.  Initially, this just returns one."

	| classDefiningSelector catName |
	classDefiningSelector _ aTargetClass classThatUnderstands: aSelector.
	classDefiningSelector ifNil: [^ OrderedCollection new].
	catName _ classDefiningSelector whichCategoryIncludesSelector: aSelector.
	^ OrderedCollection with: catName
! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 12:47'!
categoryDefiningSelector: aSelector forClass: targetClass
	"Answer which category defines the selector for the given class.  Note reimplementor"

	| aClass |
	^ (aClass _ targetClass classThatUnderstands: aSelector) 
		ifNotNil:
			[aClass whichCategoryIncludesSelector: aSelector]! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether an object, by its very nature, is one that the receiver embraces"

	^ true! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 21:57'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ true! !

!FullVocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 06:00'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class, only considering method implementations in mostGenericClass and lower"

	| classToUse aClass |
	classToUse _ self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass _ classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[aClass includesBehavior: mostGenericClass]! !
TextComponent subclass: #FunctionComponent
	instanceVariableNames: 'inputSelectors functionSelector outputSelector outputValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/4/1998 08:57'!
accept
	"Inform the model of text to be accepted, and return true if OK."
	| textToAccept oldSelector |
	oldSelector _ functionSelector.
	textToAccept _ textMorph asText.
	textToAccept = self getText ifTrue: [^ self].  "No body to compile yet"
	functionSelector _ model class
		compile: self headerString , textToAccept asString
		classified: 'functions' notifying: nil.
	self setText: textToAccept.
	self hasUnacceptedEdits: false.
	oldSelector ifNotNil:
		[functionSelector = oldSelector ifFalse: [model class removeSelector: oldSelector]].
	self fire! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/4/1998 08:12'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

	super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
	aMenu add: 'add pin' target: self selector: #addPin.
! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/4/1998 08:56'!
addPin 
	| i prev sideLength wasNew |
	wasNew _ self getText = textMorph asText.
	i _ pinSpecs size.
	prev _ pinSpecs last.
	sideLength _ prev pinLoc asInteger odd ifTrue: [self height] ifFalse: [self width].
	pinSpecs _ pinSpecs copyWith:
		(PinSpec new pinName: ('abcdefghi' copyFrom: i to: i) direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: prev pinLoc + (8/sideLength) asFloat \\ 4).
	self initFromPinSpecs.
	self addPinFromSpec: pinSpecs last.
	wasNew ifTrue: [self setText: self getText].
	self accept
	! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 11:27'!
fire
	| arguments newValue |
	outputSelector ifNil: [^ outputValue _ nil].
	functionSelector ifNil: [^ outputValue _ nil].
	arguments _ inputSelectors collect:
		[:s | s ifNil: [nil] ifNotNil: [model perform: s]].
	newValue _ (arguments findFirst: [:a | a==nil]) = 0
		ifTrue: [model perform: functionSelector withArguments: arguments]
		ifFalse: [nil].
	newValue = outputValue ifFalse:
		[model perform: outputSelector with: newValue.
		outputValue _ newValue]! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 22:12'!
getText
	| ps |
	^ ('"type a function of' ,
		(String streamContents:
			[:s | 2 to: pinSpecs size do:
				[:i | ps _ pinSpecs at: i.
				(i>2 and: [i = pinSpecs size]) ifTrue: [s nextPutAll: ' and'].
				s nextPutAll: ' ', ps pinName]]) ,
		'"') asText! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 22:04'!
headerString
	| ps |
	^ String streamContents:
		[:s | s nextPutAll: self knownName.
		2 to: pinSpecs size do:
			[:i | ps _ pinSpecs at: i.
			s nextPutAll: ps pinName , ': ';
				nextPutAll: ps pinName , ' '].
		s cr; tab; nextPutAll: '^ ']! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 23:34'!
initFromPinSpecs
	outputSelector _ pinSpecs first modelWriteSelector.
	inputSelectors _ (pinSpecs copyFrom: 2 to: pinSpecs size)
						collect: [:ps | ps modelReadSelector]! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 16:14'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'output' direction: #output
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: 3.5)
		with: (PinSpec new pinName: 'a' direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: nil
				defaultValue: nil pinLoc: 1.5)
! !

!FunctionComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 23:25'!
update: aSymbol
	inputSelectors do:
		[:s | aSymbol = s ifTrue: [^ self fire]].! !
ImageReadWriter subclass: #GIFReadWriter
	instanceVariableNames: 'width height bitsPerPixel depth colorPalette rowByteSize xpos ypos pass interlace codeSize clearCode eoiCode freeCode maxCode prefixTable suffixTable remainBitCount bufByte bufStream transparentIndex mapOf32 '
	classVariableNames: 'Extension ImageSeparator Terminator '
	poolDictionaries: ''
	category: 'Graphics-Files'!
!GIFReadWriter commentStamp: '<historical>' prior: 0!
Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.

Used with permission.  Modified for use in Squeak.!


!GIFReadWriter methodsFor: 'accessing' stamp: 'jm 11/12/97 18:00'!
nextImage
	"Read in the next GIF image from the stream. Read it all into
memory first for speed."

	| f |
	stream class == ReadWriteStream ifFalse: [
		(stream respondsTo: #binary) ifTrue: [stream binary].
		self on: (ReadWriteStream with: (stream contentsOfEntireFile))].

	self readHeader.
	f _ self readBody.
	self close.
	f == nil ifTrue: [^ self error: 'corrupt GIF file'].

	transparentIndex ifNotNil: [
		transparentIndex + 1 > colorPalette size ifTrue: [
			colorPalette _ colorPalette forceTo: transparentIndex + 1 paddingWith: Color white].
		colorPalette at: transparentIndex + 1 put: Color transparent].
	f colors: colorPalette.
	^ f
! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'ar 9/28/2000 15:17'!
nextPutImage: aForm

	| f newF |
	aForm unhibernate.
	f _ aForm colorReduced.  "minimize depth"
	f depth > 8 ifTrue: [
		"Not enough color space; do it the hard way."
		f _ f asFormOfDepth: 8].
	f depth < 8 ifTrue: [
		"writeBitData: expects depth of 8"
		newF _ f class extent: f extent depth: 8.
		(f isKindOf: ColorForm)
			ifTrue: [
				newF
					copyBits: f boundingBox
					from: f at: 0@0
					clippingBox: f boundingBox
					rule: Form over
					fillColor: nil
					map: nil.
				newF colors: f colors]
			ifFalse: [f displayOn: newF].
		f _ newF].
	(f isKindOf: ColorForm)
		ifTrue: [
			(f colorsUsed includes: Color transparent) ifTrue: [
				transparentIndex _ (f colors indexOf: Color transparent) - 1]]
		ifFalse: [transparentIndex _ nil].
	width _ f width.
	height _ f height.
	bitsPerPixel _ f depth.
	colorPalette _ f colormapIfNeededForDepth: 32.
	interlace _ false.
	self writeHeader.
	self writeBitData: f bits.
	self close.
! !

!GIFReadWriter methodsFor: 'accessing' stamp: '6/18/97 13:18 '!
setStream: aStream
	"Feed it in from an existing source"
	stream _ aStream! !

!GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'!
understandsImageFormat
	^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! !


!GIFReadWriter methodsFor: 'private-encoding'!
flushCode
	self flushBits! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'tk 9/14/97 16:25'!
readPixelFrom: bits
	"Since bits is a Bitmap with 32 bit values, watch out for the
padding at the end of each row.  But, GIF format already wants padding to
32 bit boundary!!  OK as is.  tk 9/14/97"

	| pixel |
	ypos >= height ifTrue: [^nil].
	pixel _ bits byteAt: (ypos * rowByteSize + xpos + 1).
	self updatePixelPosition.
	^pixel! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeBitData: bits
	"using modified Lempel-Ziv Welch algorithm."

	| maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch |
	pass _ 0.
	xpos _ 0.
	ypos _ 0.
	rowByteSize _ width * 8 + 31 // 32 * 4.
	remainBitCount _ 0.
	bufByte _ 0.
	bufStream _ WriteStream on: (ByteArray new: 256).

	maxBits _ 12.
	maxMaxCode _ 1 bitShift: maxBits.
	tSize _ 5003.
	prefixTable _ Array new: tSize.
	suffixTable _ Array new: tSize.

	initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel].
	self nextPut: initCodeSize.
	self setParameters: initCodeSize.

	tShift _ 0.
	fCode _ tSize.
	[fCode < 65536] whileTrue:
		[tShift _ tShift + 1.
		fCode _ fCode * 2].
	tShift _ 8 - tShift.
	1 to: tSize do: [:i | suffixTable at: i put: -1].

	self writeCodeAndCheckCodeSize: clearCode.
	ent _ self readPixelFrom: bits.
	[(pixel _ self readPixelFrom: bits) == nil] whileFalse:
		[
		fCode _ (pixel bitShift: maxBits) + ent.
		index _ ((pixel bitShift: tShift) bitXor: ent) + 1.
		(suffixTable at: index) = fCode
			ifTrue: [ent _ prefixTable at: index]
			ifFalse:
				[nomatch _ true.
				(suffixTable at: index) >= 0
					ifTrue:
						[disp _ tSize - index + 1.
						index = 1 ifTrue: [disp _ 1].
						"probe"
						[(index _ index - disp) < 1 ifTrue: [index _ index + tSize].
						(suffixTable at: index) = fCode
							ifTrue:
								[ent _ prefixTable at: index.
								nomatch _ false.
								"continue whileFalse:"].
						nomatch and: [(suffixTable at: index) > 0]]
							whileTrue: ["probe"]].
				"nomatch"
				nomatch ifTrue:
					[self writeCodeAndCheckCodeSize: ent.
					ent _ pixel.
					freeCode < maxMaxCode
						ifTrue:
							[prefixTable at: index put: freeCode.
							suffixTable at: index put: fCode.
							freeCode _ freeCode + 1]
						ifFalse:
							[self writeCodeAndCheckCodeSize: clearCode.
							1 to: tSize do: [:i | suffixTable at: i put: -1].
							self setParameters: initCodeSize]]]].
	prefixTable _ suffixTable _ nil.
	self writeCodeAndCheckCodeSize: ent.
	self writeCodeAndCheckCodeSize: eoiCode.
	self flushCode.

	self nextPut: 0.	"zero-length packet"
	self nextPut: Terminator.
! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeCode: aCode
	self nextBitsPut: aCode! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeCodeAndCheckCodeSize: aCode
	self writeCode: aCode.
	self checkCodeSize! !

!GIFReadWriter methodsFor: 'private-encoding' stamp: 'jm 4/19/98 00:50'!
writeHeader

	| byte |
	self nextPutAll: 'GIF87a' asByteArray.
	self writeWord: width.	"Screen Width"
	self writeWord: height.	"Screen Height"
	byte _ 16r80.  "has color map"
	byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5).  "color resolution"
	byte _ byte bitOr: bitsPerPixel - 1.  "bits per pixel"
	self nextPut: byte.
	self nextPut: 0.		"background color."
	self nextPut: 0.		"reserved"
	colorPalette do: [:pixelValue |
		self	nextPut: ((pixelValue bitShift: -16) bitAnd: 255);
			nextPut: ((pixelValue bitShift: -8) bitAnd: 255);
			nextPut: (pixelValue bitAnd: 255)].

	transparentIndex ifNotNil: [
		"write graphics control block to record transparent color index"
		self
			nextPut: Extension;
			nextPutAll: (#(16rF9 4 1 0 0) as: ByteArray);
			nextPut: transparentIndex;
			nextPut: 0].

	self nextPut: ImageSeparator.
	self writeWord: 0.		"Image Left"
	self writeWord: 0.		"Image Top"
	self writeWord: width.	"Image Width"
	self writeWord: height.	"Image Height"
	byte _ interlace ifTrue: [16r40] ifFalse: [0].
	self nextPut: byte.
! !

!GIFReadWriter methodsFor: 'private-encoding'!
writeWord: aWord
	self nextPut: (aWord bitAnd: 255).
	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	^aWord! !


!GIFReadWriter methodsFor: 'private-decoding' stamp: 'bf 6/3/2000 00:14'!
readBitData
	"using modified Lempel-Ziv Welch algorithm."

	| outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c |
	self readWord.	"skip Image Left"
	self readWord.	"skip Image Top"
	width _ self readWord.
	height _ self readWord.
	interlace _ (self next bitAnd: 16r40) ~= 0.
	"I ignore the possible existence of a local color map."
	pass _ 0.
	xpos _ 0.
	ypos _ 0.
	rowByteSize _ ((width + 3) // 4) * 4.
	remainBitCount _ 0.
	bufByte _ 0.
	bufStream _ ReadStream on: ByteArray new.

	outCodes _ ByteArray new: 1025.
	outCount _ 0.
	bitMask _ (1 bitShift: bitsPerPixel) - 1.
	prefixTable _ Array new: 4096.
	suffixTable _ Array new: 4096.

	initCodeSize _ self next.
	self setParameters: initCodeSize.
	bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep'].
	bytes _ ByteArray new: rowByteSize * height.
	[(code _ self readCode) = eoiCode] whileFalse:
		[code = clearCode
			ifTrue:
				[self setParameters: initCodeSize.
				curCode _ oldCode _ code _ self readCode.
				finChar _ curCode bitAnd: bitMask.
				"Horrible hack to avoid running off the end of the bitmap.  Seems to cure problem reading some gifs!!? tk 6/24/97 20:16"
				xpos = 0 ifTrue: [
						ypos < height ifTrue: [
							bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]]
					ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar].
				self updatePixelPosition]
			ifFalse:
				[curCode _ inCode _ code.
				curCode >= freeCode ifTrue:
					[curCode _ oldCode.
					outCodes at: (outCount _ outCount + 1) put: finChar].
				[curCode > bitMask] whileTrue:
					[outCount > 1024
						ifTrue: [^self error: 'corrupt GIF file (OutCount)'].
					outCodes at: (outCount _ outCount + 1)
						put: (suffixTable at: curCode + 1).
					curCode _ prefixTable at: curCode + 1].
				finChar _ curCode bitAnd: bitMask.
				outCodes at: (outCount _ outCount + 1) put: finChar.
				i _ outCount.
				[i > 0] whileTrue:
					["self writePixel: (outCodes at: i) to: bits"
					bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i).
					self updatePixelPosition.
					i _ i - 1].
				outCount _ 0.
				prefixTable at: freeCode + 1 put: oldCode.
				suffixTable at: freeCode + 1 put: finChar.
				oldCode _ inCode.
				freeCode _ freeCode + 1.
				self checkCodeSize]].
	prefixTable _ suffixTable _ nil.

	f _ ColorForm extent: width@height depth: 8.
	f bits copyFromByteArray: bytes.
	"Squeak can handle depths 1, 2, 4, and 8"
	bitsPerPixel > 4 ifTrue: [^ f].
	"reduce depth to save space"
	c _ ColorForm extent: width@height
		depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]).
	f displayOn: c.
	^ c
! !

!GIFReadWriter methodsFor: 'private-decoding' stamp: 'tk 8/7/96'!
readBody
	"Read the GIF blocks. Modified to return a form.  "

	| form extype block blocksize |
	form _ nil.
	[stream atEnd] whileFalse: [
		block _ self next.
		block = Terminator ifTrue: [^ form].
		block = ImageSeparator ifTrue: [
			form isNil
				ifTrue: [form _ self readBitData]
				ifFalse: [self skipBitData].
		] ifFalse: [
			block = Extension
				ifFalse: [^ form "^ self error: 'Unknown block type'"].
			"Extension block"
			extype _ self next.	"extension type"
			extype = 16rF9 ifTrue: [  "graphics control"
				self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].
				self next; next; next.
				transparentIndex _ self next.
				self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"].
			] ifFalse: [  "Skip blocks"
				[(blocksize _ self next) > 0]
					whileTrue: [self next: blocksize]]]].
! !

!GIFReadWriter methodsFor: 'private-decoding'!
readCode
	^self nextBits! !

!GIFReadWriter methodsFor: 'private-decoding'!
readHeader
	| is89 byte hasColorMap array r g b |
	(self hasMagicNumber: 'GIF87a' asByteArray)
		ifTrue: [is89 _ false]
		ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray)
			ifTrue: [is89 _ true]
			ifFalse: [^ self error: 'This does not appear to be a GIF file']].
	self readWord.	"skip Screen Width"
	self readWord.	"skip Screen Height"
	byte _ self next.
	hasColorMap _ (byte bitAnd: 16r80) ~= 0.
	bitsPerPixel _ (byte bitAnd: 7) + 1.
	byte _ self next.	"skip background color."
	self next ~= 0
		ifTrue: [is89
			ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']].
	hasColorMap
		ifTrue:
			[array _ Array new: (1 bitShift: bitsPerPixel).
			1 to: array size do: [:i |
				r _ self next.  g _ self next.  b _ self next.
				array at: i put: (Color r: r g: g b: b range: 255)
				  "depth 32"].
			colorPalette _ array]
		ifFalse:
			["Transcript cr; show: 'GIF file does not have a color map.'."
			colorPalette _ nil "Palette monochromeDefault"].! !

!GIFReadWriter methodsFor: 'private-decoding'!
readWord
	^self next + (self next bitShift: 8)! !

!GIFReadWriter methodsFor: 'private-decoding'!
skipBitData
	| misc blocksize |
	self readWord.  "skip Image Left"
	self readWord.  "skip Image Top"
	self readWord.  "width"
	self readWord.  "height"
	misc _ self next.
	(misc bitAnd: 16r80) = 0 ifFalse: [ "skip colormap"
		1 to: (1 bitShift: (misc bitAnd: 7) + 1) do: [:i |
			self next; next; next]].
	self next.  "minimum code size"
	[(blocksize _ self next) > 0]
		whileTrue: [self next: blocksize]! !


!GIFReadWriter methodsFor: 'private-bits access'!
flushBits
	remainBitCount = 0 ifFalse:
		[self nextBytePut: bufByte.
		remainBitCount _ 0].
	self flushBuffer! !

!GIFReadWriter methodsFor: 'private-bits access'!
nextBits
	| integer readBitCount shiftCount byte |
	integer _ 0.
	remainBitCount = 0
		ifTrue:
			[readBitCount _ 8.
			shiftCount _ 0]
		ifFalse:
			[readBitCount _ remainBitCount.
			shiftCount _ remainBitCount - 8].
	[readBitCount < codeSize]
		whileTrue:
			[byte _ self nextByte.
			byte == nil ifTrue: [^eoiCode].
			integer _ integer + (byte bitShift: shiftCount).
			shiftCount _ shiftCount + 8.
			readBitCount _ readBitCount + 8].
	(remainBitCount _ readBitCount - codeSize) = 0
		ifTrue:	[byte _ self nextByte]
		ifFalse:	[byte _ self peekByte].
	byte == nil ifTrue: [^eoiCode].
	^(integer + (byte bitShift: shiftCount)) bitAnd: maxCode! !

!GIFReadWriter methodsFor: 'private-bits access'!
nextBitsPut: anInteger
	| integer writeBitCount shiftCount |
	shiftCount _ 0.
	remainBitCount = 0
		ifTrue:
			[writeBitCount _ 8.
			integer _ anInteger]
		ifFalse:
			[writeBitCount _ remainBitCount.
			integer _ bufByte + (anInteger bitShift: 8 - remainBitCount)].
	[writeBitCount < codeSize]
		whileTrue:
			[self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255).
			shiftCount _ shiftCount - 8.
			writeBitCount _ writeBitCount + 8].
	(remainBitCount _ writeBitCount - codeSize) = 0
		ifTrue: [self nextBytePut: (integer bitShift: shiftCount)]
		ifFalse: [bufByte _ integer bitShift: shiftCount].
	^anInteger! !


!GIFReadWriter methodsFor: 'private-packing'!
fillBuffer
	| packSize |
	packSize _ self next.
	bufStream _ ReadStream on: (self next: packSize)! !

!GIFReadWriter methodsFor: 'private-packing'!
flushBuffer
	bufStream isEmpty ifTrue: [^self].
	self nextPut: bufStream size.
	self nextPutAll: bufStream contents.
	bufStream _ WriteStream on: (ByteArray new: 256)! !

!GIFReadWriter methodsFor: 'private-packing'!
nextByte
	bufStream atEnd
		ifTrue:
			[self atEnd ifTrue: [^nil].
			self fillBuffer].
	^bufStream next! !

!GIFReadWriter methodsFor: 'private-packing'!
nextBytePut: aByte
	bufStream nextPut: aByte.
	bufStream size >= 254 ifTrue: [self flushBuffer]! !

!GIFReadWriter methodsFor: 'private-packing'!
peekByte
	bufStream atEnd
		ifTrue:
			[self atEnd ifTrue: [^nil].
			self fillBuffer].
	^bufStream peek! !


!GIFReadWriter methodsFor: 'private'!
checkCodeSize
	(freeCode > maxCode and: [codeSize < 12])
		ifTrue:
			[codeSize _ codeSize + 1.
			maxCode _ (1 bitShift: codeSize) - 1]! !

!GIFReadWriter methodsFor: 'private'!
setParameters: initCodeSize
	clearCode _ 1 bitShift: initCodeSize.
	eoiCode _ clearCode + 1.
	freeCode _ clearCode + 2.
	codeSize _ initCodeSize + 1.
	maxCode _ (1 bitShift: codeSize) - 1! !

!GIFReadWriter methodsFor: 'private'!
updatePixelPosition
	(xpos _ xpos + 1) >= width ifFalse: [^self].
	xpos _ 0.
	interlace
		ifFalse: [ypos _ ypos + 1. ^self].
	pass = 0 ifTrue:
		[(ypos _ ypos + 8) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 4].
		^self].
	pass = 1 ifTrue:
		[(ypos _ ypos + 8) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 2].
		^self].
	pass = 2 ifTrue:
		[(ypos _ ypos + 4) >= height
			ifTrue:
				[pass _ pass + 1.
				ypos _ 1].
		^self].
	pass = 3 ifTrue:
		[ypos _ ypos + 2.
		^self].

	^self error: 'can''t happen'! !

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

GIFReadWriter class
	instanceVariableNames: ''!

!GIFReadWriter class methodsFor: 'class initialization'!
initialize
	"GIFReadWriter initialize"

	ImageSeparator _ $, asInteger.
	Extension _ $!! asInteger.
	Terminator _ $; asInteger.
! !
SoundCodec subclass: #GSMCodec
	instanceVariableNames: 'encodeState decodeState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'!
bytesPerEncodedFrame

	^ 33
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex

	| p |
	p _ self	primDecode: decodeState frames: frameCount
			from: srcByteArray at: srcIndex
			into: dstSoundBuffer at: dstIndex.
	^ Array with: p x with: p y
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	| p |
	p _ self	primEncode: encodeState frames: frameCount
			from: srcSoundBuffer at: srcIndex
			into: dstByteArray at: dstIndex.
	^ Array with: p x with: p y
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:32'!
reset
	"Reset my encoding/decoding state to prepare to encode or decode a new sound stream."

	encodeState _ self primNewState.
	decodeState _ self primNewState.
! !

!GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'!
samplesPerFrame

	^ 160
! !


!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'!
primDecode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	<primitive: 'primitiveGSMDecode' module: 'SoundCodecPrims'>
	self primitiveFailed.
! !

!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'!
primEncode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex

	<primitive: 'primitiveGSMEncode' module: 'SoundCodecPrims'>
	self primitiveFailed.
! !

!GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:35'!
primNewState

	<primitive: 'primitiveGSMNewState' module: 'SoundCodecPrims'>
	self error: 'The SoundCodecPrims plugin is not available'.
! !
FastInflateStream subclass: #GZipReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'GZipConstants '
	category: 'System-Compression'!

!GZipReadStream methodsFor: 'initialize' stamp: 'ar 12/27/1999 15:37'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the GZIP stream."
	| method magic flags length |
	super on: aCollection from: firstIndex to: lastIndex.
	magic _ self nextBits: 16.
	(magic = GZipMagic) 
		ifFalse:[^self error:'Not a GZipped stream'].
	method _ self nextBits: 8.
	(method = GZipDeflated)
		ifFalse:[^self error:'Bad compression method'].
	flags _ self nextBits: 8.
	(flags anyMask: GZipEncryptFlag) 
		ifTrue:[^self error:'Cannot decompress encrypted stream'].
	(flags anyMask: GZipReservedFlags)
		ifTrue:[^self error:'Cannot decompress stream with unknown flags'].
	"Ignore stamp, extra flags, OS type"
	self nextBits: 16; nextBits: 16. "stamp"
	self nextBits: 8. "extra flags"
	self nextBits: 8. "OS type"
	(flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored"
		ifTrue:[self nextBits: 16]. 
	(flags anyMask: GZipExtraField) "Extra fields - ignored"
		ifTrue:[	length _ self nextBits: 16.
				1 to: length do:[:i| self nextBits: 8]].
	(flags anyMask: GZipNameFlag) "Original file name - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse].
	(flags anyMask: GZipCommentFlag) "Comment - ignored"
		ifTrue:[[(self nextBits: 8) = 0] whileFalse].
! !

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

GZipReadStream class
	instanceVariableNames: ''!

!GZipReadStream class methodsFor: 'class initialization' stamp: 'ar 12/27/1999 15:37'!
initialize
	"GZipReadStream initialize"
	#(
		(GZipMagic 16r8B1F)		"GZIP magic number"
		(GZipDeflated 8)			"Compression method"

		(GZipAsciiFlag 16r01)		"Contents is ASCII"
		(GZipContinueFlag 16r02)	"Part of a multi-part archive"
		(GZipExtraField 16r04)	"Archive has extra fields"
		(GZipNameFlag 16r08)	"Archive has original file name"
		(GZipCommentFlag 16r10)	"Archive has comment"
		(GZipEncryptFlag 16r20)	"Archive is encrypted"
		(GZipReservedFlags 16rC0)"Reserved" 
	) do:[:spec|
		GZipConstants declare: spec first from: Undeclared.
		GZipConstants at: spec first put: spec last.
	].! !
Object subclass: #GZipSurrogateStream
	instanceVariableNames: 'gZipStream zippedFileStream bufferStream positionThusFar '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compression'!
!GZipSurrogateStream commentStamp: '<historical>' prior: 0!
A pseudo stream that allows SmartRefStream to write directly to a gzipped file. There are some peculiarities of the project exporting process that require:

1. We ignore #close since the file is closed and may be reopened to continue writing. We implement #reallyClose for when we know that all writing is over.

2. We use a BitBlt to write WordArrayForSegment objects. Bit of a hack, but there it is.

| fileStream wa |

wa _ WordArrayForSegment new: 30000.
1 to: wa size do: [ :i | wa at: i put: i].
fileStream _ GZipSurrogateStream newFileNamed: 'xxx3.gz' inDirectory: FileDirectory default.
fileStream nextPutAll: 'this is a test'.
fileStream nextPutAll: wa.
fileStream reallyClose.
!


!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
ascii

	self bufferStream ascii! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
binary

	self bufferStream binary! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:43'!
bufferStream

	^bufferStream ifNil: [bufferStream _ RWBinaryOrTextStream on: (ByteArray new: 5000)].
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:26'!
close
	
	"we don't want to until user is really done"
	

! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'!
closed

	^false! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:59'!
command: aString
	"Overridden by HtmlFileStream to append commands directly without translation.  4/5/96 tk"
	"We ignore any HTML commands.  Do nothing"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
cr

	self bufferStream cr! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:18'!
fileOutClass: extraClass andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	| class srefStream |

	self timeStamp.

	extraClass ifNotNil: [
		class _ extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue: [
			class shouldFileOutPools ifTrue: [class fileOutSharedPoolsOn: self]
		].
		class fileOutOn: self moveSource: false toFile: 0
	].

	"Append the object's raw data"
	srefStream _ SmartRefStream on: self.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me - well it thinks it does, anyway"
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:16'!
flushBuffer

	| data |
	bufferStream ifNil: [^self].
	data _ bufferStream contents asByteArray.
	gZipStream nextPutAll: data.
	positionThusFar _ positionThusFar + data size.
	bufferStream _ nil.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'!
header

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'!
newFileNamed: fName inDirectory: aDirectory

	positionThusFar _ 0.
	zippedFileStream _ aDirectory newFileNamed: fName.
	zippedFileStream binary; setFileTypeToObject.
		"Type and Creator not to be text, so can be enclosed in an email"
	gZipStream _ GZipWriteStream on: zippedFileStream.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:23'!
next

	^self bufferStream next! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
nextChunkPut: aString

	self bufferStream nextChunkPut: aString! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:42'!
nextInt32Put: int32

	^self bufferStream nextInt32Put: int32
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextNumber: n put: v 

	^self bufferStream nextNumber: n put: v 
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextPut: aByte

	^self bufferStream nextPut: aByte
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:24'!
nextPutAll: aString

	^aString writeOnGZIPByteStream: self
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
nextPutAllBytes: aString

	^self bufferStream nextPutAll: aString
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:36'!
nextPutAllWordArray: aWordArray

	| ba hackwa hackba blt rowsAtATime sourceOrigin rowsRemaining |

	self flag: #bob.		"do we need to be concerned by bytesPerElement??"
	ba _ nil.
	rowsAtATime _ 2000.		"or 8000 bytes"
	hackwa _ Form new hackBits: aWordArray.
	sourceOrigin _ 0@0.
	[(rowsRemaining _ hackwa height - sourceOrigin y) > 0] whileTrue: [
		rowsAtATime _ rowsAtATime min: rowsRemaining.
		(ba isNil or: [ba size ~= (rowsAtATime * 4)]) ifTrue: [
			ba _ ByteArray new: rowsAtATime * 4.
			hackba _ Form new hackBits: ba.
			blt _ (BitBlt toForm: hackba) sourceForm: hackwa.
		].
		blt 
			combinationRule: Form over;
			sourceOrigin: sourceOrigin;
			destX: 0 destY: 0 width: 4 height: rowsAtATime;
			copyBits.
		self bufferStream nextPutAll: ba.
		self flushBuffer.
		sourceOrigin _ sourceOrigin x @ (sourceOrigin y + rowsAtATime).
	].
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:42'!
nextStringPut: s 
	"Append the string, s, to the receiver.  Only used by DataStream.  Max size of 64*256*256*256."

	| length |
	(length _ s size) < 192
		ifTrue: [self nextPut: length]
		ifFalse: 
			[self nextPut: (length digitAt: 4)+192.
			self nextPut: (length digitAt: 3).
			self nextPut: (length digitAt: 2).
			self nextPut: (length digitAt: 1)].
	self nextPutAll: s.
	^s! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:22'!
originalContents

	^''		"used only to determine if we are byte-structured"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:26'!
padToEndWith: aChar
	"We don't have pages, so we are at the end, and don't need to pad."! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:12'!
position

	^self bufferStream position + positionThusFar! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 19:13'!
reallyClose

	self flushBuffer.
	gZipStream close.
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'!
reopen

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:36'!
setFileTypeToObject

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:30'!
setToEnd

	"ignore"! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:21'!
skip: aNumber

	^self bufferStream skip: aNumber
! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 08:41'!
timeStamp
	"Append the current time to the receiver as a String."
	self bufferStream nextChunkPut:	"double string quotes and !!s"
		(String streamContents: [:s | Smalltalk timeStamp: s]) printString.
	self bufferStream cr! !

!GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 18:37'!
trailer

	"ignore"! !

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

GZipSurrogateStream class
	instanceVariableNames: ''!

!GZipSurrogateStream class methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 11:50'!
newFileNamed: fName inDirectory: aDirectory

	^self new newFileNamed: fName inDirectory: aDirectory! !
ZipWriteStream subclass: #GZipWriteStream
	instanceVariableNames: 'crc crcPosition bytesWritten '
	classVariableNames: 'CrcTable '
	poolDictionaries: 'GZipConstants '
	category: 'System-Compression'!

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 20:07'!
on: aCollection
	crc _ 16rFFFFFFFF.
	crcPosition _ 1.
	bytesWritten _ 0.
	super on: aCollection.
	self writeHeader.
! !

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 16:36'!
release
	"Write crc and the number of bytes encoded"
	super release.
	self updateCrc.
	crc _ crc bitXor: 16rFFFFFFFF.
	encoder flushBits.
	0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)].
	0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! !

!GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 11:41'!
writeHeader
	"Write the GZip header"
	encoder nextBits: 16 put: GZipMagic.
	encoder nextBits: 8 put: GZipDeflated.
	encoder nextBits: 8 put: 0. "No flags"
	encoder nextBits: 32 put: 0. "no time stamp"
	encoder nextBits: 8 put: 0. "No extra flags"
	encoder nextBits: 8 put: 0. "No OS type"
! !


!GZipWriteStream methodsFor: 'private' stamp: 'ar 12/27/1999 17:12'!
moveContentsToFront
	"Need to update crc here"
	self updateCrc.
	super moveContentsToFront.
	crcPosition _ position + 1.! !

!GZipWriteStream methodsFor: 'private' stamp: 'ar 12/29/1999 20:09'!
updateCrc
	crcPosition <= position ifTrue:[
		bytesWritten _ bytesWritten + position - crcPosition + 1.
		crc _ self updateCrc: crc from: crcPosition to: position in: collection.
		crcPosition _ position + 1].! !

!GZipWriteStream methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'!
updateCrc: oldCrc from: start to: stop in: aCollection
	| newCrc |
	<primitive: 'primitiveUpdateGZipCrc32' module: 'ZipPlugin'>
	newCrc _ oldCrc.
	start to: stop do:[:i|
		newCrc _ (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i)) 
				bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8).
	].
	^newCrc! !

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

GZipWriteStream class
	instanceVariableNames: ''!

!GZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 14:35'!
crcTable
	^CrcTable! !

!GZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/27/1999 16:55'!
initialize
	"GZipWriteStream initialize"
	CrcTable _ #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419
  16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4
  16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07
  16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE
  16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856
  16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9
  16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4
  16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B
  16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3
  16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A
  16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599
  16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924
  16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190
  16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F
  16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E
  16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01
  16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED
  16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950
  16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3
  16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2
  16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A
  16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5
  16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010
  16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F
  16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17
  16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6
  16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615
  16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8
  16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344
  16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB
  16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A
  16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5
  16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1
  16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C
  16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF
  16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236
  16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE
  16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31
  16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C
  16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713
  16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B
  16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242
  16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1
  16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C
  16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278
  16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7
  16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66
  16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9
  16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605
  16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8
  16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B
  16r2D02EF8D
).! !
GesturalEvent subclass: #GazeGesturalEvent
	instanceVariableNames: 'point '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!GazeGesturalEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 03:17'!
point
	^ point! !

!GazeGesturalEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 03:17'!
point: aPoint
	point _ aPoint! !


!GazeGesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:42'!
actOn: aHeadMorph
	aHeadMorph face lookAt: self point! !


!GazeGesturalEvent methodsFor: 'printing' stamp: 'len 9/6/1999 00:42'!
printOn: aStream
	aStream nextPutAll: 'look at '; print: self point! !
BookMorph subclass: #GeeBookMorph
	instanceVariableNames: 'geeMail '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 11:48'!
geeMail: aGeeMail

	geeMail _ aGeeMail.! !

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:13'!
geePageRectangles

	| pageBounds allPageRects |

	pageBounds _ geeMail topLeft 
			extent: geeMail width @ (geeMail height min: Display height - 50).
	allPageRects _ OrderedCollection new.
	[pageBounds top <= geeMail bottom] whileTrue: [
		allPageRects add: pageBounds.
		pageBounds _ pageBounds translateBy: 0 @ pageBounds height.
	].
	^allPageRects
! !

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:15'!
initialize

	newPagePrototype _ GeeBookPageMorph new extent: Display extent // 3.
	super initialize.
	color _ (Color r: 0.909 g: 0.819 b: 0.09).! !

!GeeBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:44'!
rebuildPages

	pages _ self geePageRectangles collect: [ :each |
		GeeBookPageMorph new 
			disableDragNDrop;
			geeMail: geeMail geeMailRectangle: each.
	].
	currentPage delete.
	currentPage _ nil.
	pages isEmpty ifTrue: [^ self insertPage].
	self goToPage: 1.

! !
PasteUpMorph subclass: #GeeBookPageMorph
	instanceVariableNames: 'geeMail geeMailRectangle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!GeeBookPageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:40'!
fullDrawOn: aCanvas

	aCanvas 
		translateTo: self topLeft + aCanvas origin - geeMailRectangle origin 
		clippingTo: (bounds translateBy: aCanvas origin) 
		during: [ :c |
			geeMail disablePageBreaksWhile: [geeMail fullDrawOn: c].
		].
! !

!GeeBookPageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 11:57'!
geeMail: aGeeMail geeMailRectangle: aRectangle

	geeMail _ aGeeMail.
	geeMailRectangle _ aRectangle.
	self extent: aRectangle extent.! !

!GeeBookPageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 13:25'!
handlesMouseDown: evt
	"| localPt |

	localPt _ (self transformFrom: self world) globalPointToLocal: evt cursorPoint.
	submorphs do: [ :each | (each fullBounds containsPoint: localPt) ifTrue: [^false]]."
	^ true
! !

!GeeBookPageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 13:51'!
mouseDown: evt
	"Handle a mouse down event."

	
	"{evt. self recipientForMouseDown: evt. self} explore."
! !
AlansTextPlusMorph subclass: #GeeMailMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!
!GeeMailMorph commentStamp: '<historical>' prior: 0!
Well, what can I say? GeeMail is a scrolling playfield with a text morph (typically on the left) and room on the right for other morphs to be placed. The morphs on the right can be linked to text selections on the left so that they remain positioned beside the pertinent text as the text is reflowed. Probably the best thing is and example and Alan will be making some available soon.!


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

GeeMailMorph class
	instanceVariableNames: ''!

!GeeMailMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 9/10/2000 12:52'!
includeInNewMorphMenu

	^ true! !
Object subclass: #GeePrinter
	instanceVariableNames: 'pasteUp printSpecs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:33'!
allPages

	| pageNumber allPages maxPages |

	maxPages _ 9999.
	pageNumber _ 0.
	allPages _ self pageRectangles collect: [ :rect |
		pageNumber _ pageNumber + 1.
		(self as: GeePrinterPage) pageNumber: pageNumber bounds: rect
	].
	allPages size > maxPages ifTrue: [allPages _ allPages first: maxPages].
	allPages do: [ :each | each totalPages: allPages size].
	^allPages

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:46'!
bounds

	| w |
	w _ pasteUp width.
	^0@0 extent: w@(w * self hOverW) rounded.! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 12:51'!
doPages

	| dialog |
	(dialog _ GeePrinterDialogMorph new) 
		printSpecs: self printSpecs 
		printBlock: [ :preview :specs |
			preview ifTrue: [self doPrintPreview] ifFalse: [self doPrintToPrinter]
		];
		fullBounds;
		position: Display extent - dialog extent // 2;
		openInWorld

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
doPrintPreview

	| pageDisplay sz newPage subBounds pic align |

	sz _ (85 @ 110) * 3.
	self printSpecs landscapeFlag ifTrue: [
		sz _ sz transposed
	].
	pageDisplay _ BookMorph new
		color: Color paleYellow;
		borderWidth: 1.
	self allPages withIndexDo: [ :each :index |
		pic _ ImageMorph new image: (each pageThumbnailOfSize: sz).
		align _ AlignmentMorph newColumn
			addMorph: pic;
			borderWidth: 1;
			layoutInset: 0;
			borderColor: Color blue.
		newPage _ pageDisplay 
			insertPageLabel: 'Page ',index printString
			morphs: {align}.
		subBounds _ newPage boundingBoxOfSubmorphs.
		newPage extent: subBounds corner - newPage topLeft + ((subBounds left - newPage left)@0).
	].
	pageDisplay 
		goToPage: 1;
		deletePageBasic;
		position: Display extent - pageDisplay extent // 2;
		openInWorld.
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 09:29'!
doPrintToPrinter

	"fileName _ ('gee.',Time millisecondClockValue printString,'.eps') asFileName."

	DSCPostscriptCanvasToDisk 
		morphAsPostscript: self 
		rotated: self printSpecs landscapeFlag

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/22/2000 13:58'!
drawOn: aCanvas

	pasteUp drawOn: aCanvas

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:40'!
fullBounds

	^self bounds! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/22/2000 14:28'!
fullDrawOn: aCanvas

	pasteUp fullDrawOn: aCanvas

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:33'!
fullDrawPostscriptOn: aCanvas

	aCanvas drawPages: self allPages.

! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:46'!
hOverW

	^self printSpecs landscapeFlag ifTrue: [
		8.5 /  11.0
	] ifFalse: [
		11.0 / 8.5
	].
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:47'!
pageRectangles

	| pageBounds allPageRects |

	pageBounds _ self bounds.
	allPageRects _ OrderedCollection new.
	[pageBounds top <= pasteUp bottom] whileTrue: [
		allPageRects add: pageBounds.
		pageBounds _ pageBounds translateBy: 0 @ pageBounds height.
	].
	^allPageRects
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 17:41'!
pagesHandledAutomatically

	^true! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:35'!
pasteUp: x

	pasteUp _ x.! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:33'!
printSpecs

	^printSpecs ifNil: [printSpecs _ PrintSpecifications defaultSpecs].
! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:28'!
printSpecs: aPrintSpecification

	printSpecs _ aPrintSpecification! !

!GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:40'!
wantsRoundedCorners

	^false! !
AlignmentMorphBob1 subclass: #GeePrinterDialogMorph
	instanceVariableNames: 'printSpecs printBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:50'!
buttonColor

	^color darker! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:48'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	col _ (self inAColumn: {f}) hResizing: #shrinkWrap.
	^col! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:52'!
cancelButton

	^self
		buttonNamed: 'Cancel' 
		action: #doCancel 
		color: self buttonColor 
		help: 'Cancel this printing operation.'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:24'!
doCancel

	self delete! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:42'!
doPreview

	self delete.
	printBlock value: true value: printSpecs.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:42'!
doPrint

	self delete.
	printBlock value: false value: printSpecs.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:44'!
getChoice: aSymbol

	aSymbol == #landscapeFlag ifTrue: [^printSpecs landscapeFlag].
	aSymbol == #drawAsBitmapFlag ifTrue: [^printSpecs drawAsBitmapFlag].
! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
initialize

	super initialize.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	color _ Color paleYellow.
	borderWidth _ 8.
	borderColor _ color darker.
	self layoutInset: 4.
	self useRoundedCorners.
	printSpecs ifNil: [printSpecs _ PrintSpecifications defaultSpecs].
	self rebuild.
! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:51'!
previewButton

	^self
		buttonNamed: 'Preview' 
		action: #doPreview 
		color: self buttonColor 
		help: 'Show a preview of the pages that will be printed on the screen.'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:49'!
printButton

	^self
		buttonNamed: 'Print' 
		action: #doPrint 
		color: self buttonColor 
		help: 'Print me (a PostScript file will be created)'! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 11:26'!
printSpecs: aPrintSpecification printBlock: aTwoArgBlock

	printSpecs _ aPrintSpecification.
	printBlock _ aTwoArgBlock.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:43'!
rebuild

	self removeAllMorphs.
	self addARow: {
		(StringMorph contents: 'PostScript Printing Options') lock.
	}.
	self addARow: {
		self
			simpleToggleButtonFor: self
			attribute: #landscapeFlag
			help: 'Print in landscape mode'.
		(StringMorph contents: ' Landscape') lock.
	}.
	self addARow: {
		self
			simpleToggleButtonFor: self
			attribute: #drawAsBitmapFlag
			help: 'Print as a bitmap'.
		(StringMorph contents: ' Bitmap') lock.
	}.


	self addARow: {
		self printButton.
		self previewButton.
		self cancelButton.
	}.! !

!GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:44'!
toggleChoice: aSymbol

	aSymbol == #landscapeFlag ifTrue: [
		printSpecs landscapeFlag: printSpecs landscapeFlag not
	].
	aSymbol == #drawAsBitmapFlag ifTrue: [
		printSpecs drawAsBitmapFlag: printSpecs drawAsBitmapFlag not
	].
! !
GeePrinter subclass: #GeePrinterPage
	instanceVariableNames: 'pageNumber bounds totalPages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:41'!
fullDrawPostscriptOn: aCanvas

	| s |
	s _ TextMorph new 
		beAllFont: (TextStyle default fontOfSize: 30);
		contentsAsIs: '   Drawing page ',pageNumber printString,' of ',totalPages printString,'     '.
	s layoutChanged; fullBounds.
	s _ AlignmentMorph newRow
		addMorph: s;
		color: Color yellow.
	s position: Display center - (s width // 2 @ 0).
	World addMorphFront: s.
	World displayWorld.
	printSpecs drawAsBitmapFlag ifTrue: [
		aCanvas paintImage: self pageAsForm at: 0@0
	] ifFalse: [
		aCanvas 
			translateTo: bounds origin negated 
			clippingTo: (0@0 extent: bounds extent) 
			during: [ :c |
				pasteUp fullDrawForPrintingOn: c
			].
	].
	s delete.

! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 16:00'!
pageAsForm

	| f canvas |
	f _ Form extent: bounds extent depth: 16.
	canvas _ f getCanvas.
	canvas fillColor: pasteUp color.
	canvas translateTo: bounds origin negated clippingTo: f boundingBox during: [ :c |
		pasteUp fullDrawForPrintingOn: c
	].
	^f

! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/16/2000 17:53'!
pageNumber: anInteger bounds: aRect

	pageNumber _ anInteger.
	bounds _ aRect.! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 16:00'!
pageThumbnailOfSize: aPoint

	^self pageAsForm scaledToSize: aPoint

! !

!GeePrinterPage methodsFor: 'as yet unclassified' stamp: 'RAA 9/17/2000 16:51'!
totalPages: x

	totalPages _ x! !
Url subclass: #GenericUrl
	instanceVariableNames: 'schemeName locator '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!GenericUrl commentStamp: '<historical>' prior: 0!
a URL type that can't be broken down in any systematic way.  For example, mailto: and telnet: URLs.  The part after the scheme name is stored available via the #locator message.!


!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'!
privateInitializeFromText: aString
	schemeName _ Url schemeNameForString: aString.
	schemeName ifNil: [ self error: 'opaque URL with no scheme--shouldn''t happen!!'. ].
	locator _ aString copyFrom: (schemeName size+2) to: aString size.! !

!GenericUrl methodsFor: 'parsing' stamp: 'ls 8/4/1998 01:28'!
privateInitializeFromText: aString relativeTo: aUrl
	schemeName _ aUrl schemeName.
	locator _ aString.! !


!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'!
locator
	^locator! !

!GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'!
schemeName
	^schemeName! !


!GenericUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:46'!
schemeName: schemeName0  locator: locator0
	schemeName _ schemeName0.
	locator _ locator0.! !


!GenericUrl methodsFor: 'printing' stamp: 'ls 8/4/1998 02:41'!
toText
	| s |
	s _ WriteStream on: String new.
	s nextPutAll: self schemeName.
	s nextPut: $:.
	s nextPutAll: self locator.

	self fragment ifNotNil: [ s nextPut: $#.  s nextPutAll: self fragment ].

	^s contents! !

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

GenericUrl class
	instanceVariableNames: ''!

!GenericUrl class methodsFor: 'parsing' stamp: 'ls 7/26/1998 21:24'!
absoluteFromText: aString
	| schemeName locator |
	schemeName _ Url schemeNameForString: aString.
	schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ].
	locator _ aString copyFrom: (schemeName size + 2) to: aString size.
	^self schemeName: schemeName locator: locator! !


!GenericUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:46'!
schemeName: schemeName  locator: locator
	^self new schemeName: schemeName  locator: locator! !
VoiceEvent subclass: #GesturalEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!GesturalEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:18'!
voice
	"Answer the default voice for the reciever."
	^ Voice voices detect: [ :one | one class == GesturalVoice] ifNone: [super voice]! !


!GesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:40'!
actOn: aHeadMorph
	self subclassResponsibility! !

!GesturalEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:53'!
playOn: aVoice at: time
	aVoice playGesturalEvent: self at: time! !


!GesturalEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:18'!
isGestural
	^ true! !
Voice subclass: #GesturalVoice
	instanceVariableNames: 'head '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!
!GesturalVoice commentStamp: '<historical>' prior: 0!
My instances are speaking voices with a head that acts in response to gestural events.!


!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:07'!
face
	^ self head face! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:06'!
head
	^ head! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 9/28/1999 02:16'!
head: aHeadMorph
	head notNil ifTrue: [aHeadMorph position: head position. head delete].
	head _ aHeadMorph! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 8/28/1999 23:06'!
lips
	^ self face lips! !

!GesturalVoice methodsFor: 'accessing' stamp: 'len 9/28/1999 02:16'!
newHead
	| m |
	m _ HeadMorph new.
	self head: m.
	m openInWorld.
	^ m! !


!GesturalVoice methodsFor: 'playing' stamp: 'len 9/7/1999 01:41'!
playGesturalEvent: event at: time
	self head playEvent: event at: time! !

!GesturalVoice methodsFor: 'playing' stamp: 'len 9/6/1999 00:46'!
playPhoneticEvent: event at: time
	(TalkGesturalEvent new phoneme: event phoneme) playOn: self at: time! !
RectangleMorph subclass: #GradientFillMorph
	instanceVariableNames: 'fillColor2 gradientDirection colorArray colorDepth '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!GradientFillMorph commentStamp: '<historical>' prior: 0!
Class GradientFillMorph is obsolete. For getting gradient fills use a BorderedMorph with an appropriate fill style, e.g.,

	| morph fs |
	morph _ BorderedMorph new.
	fs _ GradientFillStyle ramp: {0.0 -> Color red. 1.0 -> Color green}.
	fs origin: morph bounds center.
	fs direction: (morph bounds width // 2) @ 0.
	fs radial: true.
	morph fillStyle: fs.
	World primaryHand attachMorph: morph.

Here's the old (obsolete) comment:
GradientFills cache an array of bitpatterns for the colors across their rectangle.  It costs a bit of space, but makes display fast enough to eschew the use of a bitmap.  The array must be recomputed whenever the colors, dimensions or display depth change.!


!GradientFillMorph methodsFor: 'initialize' stamp: 'di 11/13/97 15:20'!
changed
	super changed.
	self releaseCachedState! !

!GradientFillMorph methodsFor: 'initialize' stamp: 'di 1/9/98 22:17'!
initialize
	super initialize.
	borderWidth _ 0.
	fillColor2 _ Color black.
	gradientDirection _ #vertical! !


!GradientFillMorph methodsFor: 'drawing' stamp: 'ar 5/16/2000 20:49'!
drawOn: aCanvas
	"Note that this could run about 4 times faster if we got hold of
	the canvas's port and just sent it copyBits with new coords and color"
 	| style |
	super drawOn: aCanvas.
	(color isKindOf: Color) ifFalse: [^ self].  "An InfiniteForm, for example"
	(color = Color transparent) ifTrue: [^ self].  "Skip the gradient attempts, which will drop into debugger"
	color = fillColor2 ifTrue: [^ self].  "same color; no gradient"
	"Check if we can use the cached gradient fill"
	((self valueOfProperty: #cachedGradientColor1) = color 
		and:[(self valueOfProperty: #cachedGradientColor2) = fillColor2])
			ifTrue:[style _ self valueOfProperty: #cachedGradientFill].
	style ifNil:[
		style _ GradientFillStyle ramp: {0.0 -> color. 1.0 -> fillColor2}.
		self setProperty: #cachedGradientColor1 toValue: color.
		self setProperty: #cachedGradientColor2 toValue: fillColor2.
		self setProperty: #cachedGradientFill toValue: style.
	].
	style origin: self position.
	style direction: (gradientDirection == #vertical 
		ifTrue:[0@self height] 
		ifFalse:[self width@0]).
	aCanvas fillRectangle: self innerBounds fillStyle: style.! !


!GradientFillMorph methodsFor: 'menu' stamp: 'jm 11/5/97 12:41'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'gradient color' action: #setGradientColor:.
	gradientDirection == #vertical
		ifTrue: [aCustomMenu add: 'horizontal pan' action: #beHorizontal]
		ifFalse: [aCustomMenu add: 'vertical pan' action: #beVertical].
! !

!GradientFillMorph methodsFor: 'menu' stamp: 'di 11/2/97 14:35'!
beHorizontal
	gradientDirection _ #horizontal.
	self changed! !

!GradientFillMorph methodsFor: 'menu' stamp: 'di 11/2/97 14:35'!
beVertical
	gradientDirection _ #vertical.
	self changed! !

!GradientFillMorph methodsFor: 'menu' stamp: 'sw 4/2/98 00:12'!
gradientDirection
	^ gradientDirection! !



!GradientFillMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/5/97 12:40'!
gradientFillColor: aColor

	fillColor2 _ aColor.
	self changed.
! !

!GradientFillMorph methodsFor: 'as yet unclassified' stamp: 'di 1/3/1999 12:24'!
hasTranslucentColor
	"Answer true if this any of this morph is translucent but not transparent."

	(color isColor and: [color isTranslucentColor]) ifTrue: [^ true].
	(fillColor2 isColor and: [fillColor2 isTranslucentColor]) ifTrue: [^ true].
	^ false
! !

!GradientFillMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 18:52'!
setGradientColor: evt

	self changeColorTarget: self selector: #gradientFillColor: originalColor: fillColor2 hand: evt hand! !
OrientedFillStyle subclass: #GradientFillStyle
	instanceVariableNames: 'colorRamp pixelRamp radial isTranslucent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:10'!
colorRamp
	^colorRamp! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 14:30'!
colorRamp: anArray
	colorRamp _ anArray.
	pixelRamp _ nil.
	isTranslucent _ nil.! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 15:06'!
pixelRamp
	^pixelRamp ifNil:[pixelRamp _ self computePixelRampOfSize: 512].! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'!
pixelRamp: aBitmap
	pixelRamp _ aBitmap! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'!
radial
	^radial! !

!GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:11'!
radial: aBoolean
	radial _ aBoolean! !


!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'!
isGradientFill
	^true! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:13'!
isRadialFill
	^radial == true! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:12'!
isSolidFill
	^false! !

!GradientFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:29'!
isTranslucent
	^isTranslucent ifNil:[isTranslucent _ self checkTranslucency]! !


!GradientFillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 14:07'!
asColor
	^colorRamp first value! !


!GradientFillStyle methodsFor: 'private' stamp: 'di 11/21/1999 20:18'!
checkTranslucency
	^colorRamp anySatisfy: [:any| any value isTranslucent]! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/16/2000 18:32'!
computePixelRampOfSize: length
	"Compute the pixel ramp in the receiver"
	| bits lastColor lastIndex nextIndex nextColor distance theta lastValue ramp lastWord nextWord step |
	ramp _ colorRamp asSortedCollection:[:a1 :a2| a1 key < a2 key].
	bits _ Bitmap new: length.
	lastColor _ ramp first value.
	lastWord _ lastColor pixelWordForDepth: 32.
	lastIndex _ 0.
	ramp do:[:assoc|
		nextIndex _ (assoc key * length) rounded.
		nextColor _ assoc value.
		nextWord _ nextColor pixelWordForDepth: 32.
		distance _ (nextIndex - lastIndex).
		distance = 0 ifTrue:[distance _ 1].
		step _ 1.0 / distance asFloat.
		theta _ 0.0.
		lastIndex+1 to: nextIndex do:[:i|
			theta _ theta + step.
			"The following is an open-coded version of:
				color _ nextColor alphaMixed: theta with: lastColor.
				bits at: i put: (color scaledPixelValue32).
			"
			bits at: i put: (self scaledAlphaMix: theta of: lastWord with: nextWord).
		].
		lastIndex _ nextIndex.
		lastColor _ nextColor.
		lastWord _ nextWord.
	].
	lastValue _ lastColor scaledPixelValue32.
	lastIndex+1 to: length do:[:i| bits at: i put: lastValue].
	^bits! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 11/9/1998 16:56'!
display
	| f ramp |
	ramp _ self pixelRamp.
	f _ Form extent: ramp size @ 1 depth: 32 bits: ramp.
	1 to: 100 do:[:i| f displayAt: 1@i].
	[Sensor anyButtonPressed] whileFalse.
	[Sensor anyButtonPressed] whileTrue.! !

!GradientFillStyle methodsFor: 'private' stamp: 'ar 7/11/2000 16:47'!
scaledAlphaMix: theta of: lastWord with: nextWord
	"Open-coded version of alpha mixing two 32bit pixel words and returning the scaled pixel value."
	| word0 word1 a0 a1 alpha v0 v1 vv value |
	word0 _ lastWord.
	word1 _ nextWord.
	"note: extract alpha first so we'll be in SmallInteger range afterwards"
	a0 _ word0 bitShift: -24. a1 _ word1 bitShift: -24.
	alpha _ a0 + (a1 - a0 * theta) truncated.
	"Now make word0 and word1 SmallIntegers"
	word0 _ word0 bitAnd: 16rFFFFFF. word1 _ word1 bitAnd: 16rFFFFFF.
	"Compute first component value"
	v0 _ (word0 bitAnd: 255). v1 _ (word1 bitAnd: 255).
	vv _ (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value _ vv.
	"Compute second component value"
	v0 _ ((word0 bitShift: -8) bitAnd: 255). v1 _ ((word1 bitShift: -8) bitAnd: 255).
	vv _ (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value _ value bitOr: (vv bitShift: 8).
	"Compute third component value"
	v0 _ ((word0 bitShift: -16) bitAnd: 255). v1 _ ((word1 bitShift: -16) bitAnd: 255).
	vv _ (v0 + (v1 - v0 * theta) truncated) * alpha // 255.
	value _ value bitOr: (vv bitShift: 16).
	"Return result"
	^value bitOr: (alpha bitShift: 24)! !


!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 11:42'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	self isRadialFill ifTrue:[
		aMenu add: 'linear gradient' target: self selector: #beLinearGradientIn: argument: aMorph.
	] ifFalse:[
		aMenu add: 'radial gradient' target: self selector: #beRadialGradientIn: argument: aMorph.
	].
	aMenu addLine.
	aMenu add: 'change first color' target: self selector: #changeFirstColorIn:event: argument: aMorph.
	aMenu add: 'change second color' target: self selector: #changeSecondColorIn:event: argument: aMorph.
	aMenu addLine.
	super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 09:49'!
addNewColorIn: aMorph event: evt
	^self inform:'not yet implemented'! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 07:25'!
beLinearGradientIn: aMorph
	self radial: false.
	aMorph changed.! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 07:25'!
beRadialGradientIn: aMorph
	self radial: true.
	aMorph changed.! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'sw 9/8/2000 18:13'!
changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor
	"Change either the firstColor or the lastColor (depending on aSymbol).  Put up a color picker to hande it.  We always use a modal picker so that the user can adjust both colors concurrently."

	ColorPickerMorph new
		initializeModal: false;
		sourceHand: aHand;
		target: self;
		selector: aSymbol;
		argument: aMorph;
		originalColor: originalColor;
		putUpFor: aMorph near: aMorph fullBoundsInWorld! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'di 9/3/1999 11:34'!
changeFirstColorIn: aMorph event: evt
	^self changeColorSelector: #firstColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp first value! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'di 9/3/1999 11:34'!
changeSecondColorIn: aMorph event: evt
	^self changeColorSelector: #lastColor:forMorph:hand: hand: evt hand morph: aMorph originalColor: colorRamp last value! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 11:39'!
firstColor: aColor forMorph: aMorph hand: aHand
	colorRamp first value: aColor.
	pixelRamp _ nil.
	aMorph changed.! !

!GradientFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/25/1999 11:40'!
lastColor: aColor forMorph: aMorph hand: aHand
	colorRamp last value: aColor.
	pixelRamp _ nil.
	aMorph changed.! !


!GradientFillStyle methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 08:37'!
encodeForRemoteCanvas

	^(DataStream streamedRepresentationOf: self) asString
! !

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

GradientFillStyle class
	instanceVariableNames: ''!

!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/9/1998 14:05'!
ramp: colorRamp
	^self new colorRamp: colorRamp! !

!GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/10/1998 19:13'!
sample
	"GradientFill sample"
	^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue})
		origin: 300 @ 300;
		direction: 400@0;
		normal: 0@400;
		radial: true;
	yourself! !
BitBlt subclass: #GrafPort
	instanceVariableNames: 'alpha fillPattern '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:07'!
alphaBits: a
	alpha _ a! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 5/28/2000 14:41'!
contentsOfArea: aRectangle into: aForm
	destForm 
		displayOn: aForm 
		at:  aRectangle origin
		clippingBox: (0@0 extent: aRectangle extent).
	^aForm! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'!
displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode

	^ (DisplayScanner new text: para text textStyle: para textStyle
			foreground: foreColor background: backColor fillBlt: self
			ignoreColorChanges: shadowMode)
		setPort: self clone
! !

!GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'!
fillPattern: anObject
	fillPattern _ anObject.
	self fillColor: anObject.! !


!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:32'!
fillOval: rect
	| centerX centerY nextY yBias xBias outer nextOuterX |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	nextY _ rect height // 2.
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ rect width.
	destX _ rect left.
	self copyBits.
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 5/17/2000 21:20'!
fillRect: rect offset: aPoint
	"The offset is really just for stupid InfiniteForms."
	| fc |
	fillPattern class == InfiniteForm ifTrue:[
		fc _ halftoneForm.
		self fillColor: nil.
		fillPattern displayOnPort: ((self clippedBy: rect) colorMap: nil) at: aPoint.
		halftoneForm _ fc.
		^self].

	destX _ rect left.
	destY _ rect top.
	sourceX _ 0.
	sourceY _ 0.
	width _ rect width.
	height _ rect height.
	self copyBits.! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:26'!
frameOval: rect borderWidth: borderWidth
	| centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha |
	rect area <= 0 ifTrue: [^ self].
	height _ 1.
	wp _ borderWidth asPoint.
	yBias _ rect height odd ifTrue: [0] ifFalse: [-1].
	xBias _ rect width odd ifTrue: [1] ifFalse: [0].
	centerX _ rect center x.
	centerY _ rect center y.
	outer _ EllipseMidpointTracer new on: rect.
	inner _ EllipseMidpointTracer new on: (rect insetBy: wp).
	nextY _ rect height // 2.
	1 to: (wp y min: nextY) do:[:i|
		nextOuterX _ outer stepInY.
		width _ (nextOuterX bitShift: 1) + xBias.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		self copyBits.
		destY _ centerY + nextY + yBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	[nextY > 0] whileTrue:[
		nextOuterX _ outer stepInY.
		nextInnerX _ inner stepInY.
		destX _ centerX - nextOuterX.
		destY _ centerY - nextY.
		width _ nextOuterX - nextInnerX.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		destX _ centerX - nextOuterX.
		destY _ centerY + nextY + yBias.
		self copyBits.
		destX _ centerX + nextInnerX + xBias.
		self copyBits.
		nextY _ nextY - 1.
	].
	destY _ centerY.
	height _ 1 + yBias.
	width _ wp x.
	destX _ rect left.
	self copyBits.
	destX _ rect right - wp x.
	self copyBits.
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'!
frameRect: rect borderWidth: borderWidth
	sourceX _ 0.
	sourceY _ 0.
	(rect areasOutside: (rect insetBy: borderWidth)) do:
		[:edgeStrip | self destRect: edgeStrip; copyBits].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
frameRectBottom: rect height: h

	destX _ rect left + 1.
	destY _ rect bottom - 1.
	width _ rect width - 2.
	height _ 1.
	1 to: h do: [:i |
		self copyBits.
		destX _ destX + 1.
		destY _ destY - 1.
		width _ width - 2].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
frameRectRight: rect width: w

	width _ 1.
	height _ rect height - 1.
	destX _ rect right - 1.
	destY _ rect top + 1.
	1 to: w do: [:i |
		self copyBits.
		destX _ destX - 1.
		destY _ destY + 1.
		height _ height - 2].
! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule."

	sourceForm _ aForm.
	combinationRule _ rule.
	self sourceRect: sourceRect.
	self destOrigin: aPoint.
	self copyBits! !

!GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 00:31'!
stencil: stencilForm at: aPoint sourceRect: aRect
	"Paint using aColor wherever stencilForm has non-zero pixels"
	self sourceForm: stencilForm;
		destOrigin: aPoint;
		sourceRect: aRect.
	self copyBits! !


!GrafPort methodsFor: 'copying' stamp: 'ar 2/17/2000 01:07'!
clippedBy: aRectangle
	^ self copy clipRect: (self clipRect intersect: aRectangle)! !

!GrafPort methodsFor: 'copying' stamp: 'ar 2/17/2000 01:07'!
copyBits
	"Override copybits to do translucency if desired"

	(combinationRule >= 30 and: [combinationRule <= 31])
		ifTrue: [alpha == nil
					ifTrue: [self copyBitsTranslucent: 255]
					ifFalse: [self copyBitsTranslucent: alpha]]
		ifFalse: [super copyBits]! !

RectangleMorph subclass: #GraphMorph
	instanceVariableNames: 'data dataColor cursor cursorColor cursorColorAtZeroCrossings startIndex minVal maxVal cachedForm hasChanged '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!GraphMorph commentStamp: '<historical>' prior: 0!
I display a graph of numbers, normalized so the full range of values just fits my height. I support a movable cursor that can be dragged with the mouse.

Implementation notes: Some operations on me may be done at sound sampling rates (e.g. 11-44 thousand times/second). To allow such high bandwidth application, certain operations that change my appearance do not immediately report a damage rectangle. Instead, a flag is set indicating that my display needs to refreshed and a step method reports the damage rectangle if that flag is set. Also, I cache a bitmap of my graph to allow the cursor to be moved without redrawing the graph.
!


!GraphMorph methodsFor: 'initialization' stamp: 'jm 6/17/1999 20:09'!
initialize

	super initialize.
	self color: (Color r: 0.8 g: 0.8 b: 0.6).
	self extent: 365@80.
	self borderWidth: 2.
	dataColor _ Color darkGray.
	cursor _ 1.0.  "may be fractional"
	cursorColor _ Color red.
	cursorColorAtZeroCrossings _ Color red.
	startIndex _ 1.
	hasChanged _ false.
	self data:
		((0 to: 360 - 1) collect:
			[:x | (100.0 * (x degreesToRadians sin)) asInteger]).
! !


!GraphMorph methodsFor: 'accessing'!
color: aColor

	super color: aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing'!
cursor

	^ cursor
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 6/17/1999 21:41'!
cursor: aNumber

	| truncP |
	cursor ~= aNumber ifTrue:  [
		cursor _ aNumber.
		truncP _ aNumber truncated.
		truncP > data size ifTrue: [cursor _ data size].
		truncP < 0 ifTrue: [cursor _ 1].
		self keepIndexInView: truncP.
		hasChanged _ true].
! !

!GraphMorph methodsFor: 'accessing'!
cursorAtEnd

	^ cursor truncated >= data size
! !

!GraphMorph methodsFor: 'accessing'!
cursorColor

	^ cursorColor
! !

!GraphMorph methodsFor: 'accessing'!
cursorColor: aColor

	cursorColor _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'!
cursorColorAtZeroCrossing

	^ cursorColorAtZeroCrossings
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'!
cursorColorAtZeroCrossings: aColor

	cursorColorAtZeroCrossings _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 6/17/1999 21:43'!
cursorWrapped: aNumber

	| sz |
	cursor ~= aNumber ifTrue: [
		cursor _ aNumber.
		sz _ data size.
		sz = 0
			ifTrue: [cursor _ 1]
			ifFalse: [
				((cursor >= (sz + 1)) or: [cursor < 0]) ifTrue: [
					cursor _ cursor - ((cursor // sz) * sz)].
				cursor < 1 ifTrue: [cursor _ sz + cursor]].
		"assert: 1 <= cursor < data size + 1"
		hasChanged _ true].
! !

!GraphMorph methodsFor: 'accessing'!
data

	^ data
! !

!GraphMorph methodsFor: 'accessing'!
data: aCollection

	data _ aCollection.
	maxVal _ minVal _ 0.
	data do: [:x |
		x < minVal ifTrue: [minVal _ x].
		x > maxVal ifTrue: [maxVal _ x]].

	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing'!
dataColor

	^ dataColor
! !

!GraphMorph methodsFor: 'accessing'!
dataColor: aColor

	dataColor _ aColor.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 6/16/1999 13:49'!
interpolatedValueAtCursor

	| sz prev frac next |
	data isEmpty ifTrue: [^ 0].
	sz _ data size.
	cursor < 0 ifTrue: [^ data at: 1].  "just to be safe, though cursor shouldn't be negative"
	prev _ cursor truncated.
	frac _ cursor - prev.
	prev < 1 ifTrue: [prev _ sz].
	prev > sz ifTrue: [prev _ 1].
	"assert: 1 <= prev <= sz"
	frac = 0 ifTrue: [^ data at: prev].  "no interpolation needed"

	"interpolate"
	next _ prev = sz ifTrue: [1] ifFalse: [prev + 1].
	^ ((1.0 - frac) * (data at: prev)) + (frac * (data at: next))
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 4/21/1999 11:24'!
lastValue

	data size = 0 ifTrue: [^ 0].
	^ data last
! !

!GraphMorph methodsFor: 'accessing' stamp: 'jm 4/21/1999 11:25'!
lastValue: aNumber

	self appendValue: aNumber.
! !

!GraphMorph methodsFor: 'accessing'!
startIndex

	^ startIndex
! !

!GraphMorph methodsFor: 'accessing'!
startIndex: aNumber

	startIndex ~= aNumber ifTrue:  [
		startIndex _ aNumber asInteger.
		self flushCachedForm].
! !

!GraphMorph methodsFor: 'accessing'!
valueAtCursor

	data isEmpty ifTrue: [^ 0].
	^ data at: ((cursor truncated max: 1) min: data size)
! !

!GraphMorph methodsFor: 'accessing'!
valueAtCursor: aPointOrNumber

	data isEmpty ifTrue: [^ 0].
	data
		at: ((cursor truncated max: 1) min: data size)
		put: (self asNumber: aPointOrNumber).
	self flushCachedForm.
! !


!GraphMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 18:04'!
drawOn: aCanvas

	| c |
	cachedForm = nil ifTrue:  [
		c _ Display defaultCanvasClass extent: bounds extent.
		c translateBy: bounds origin negated
			during:[:tempCanvas| self drawDataOn: tempCanvas].
		cachedForm _ c form].
	aCanvas cache: bounds
			using: cachedForm
			during:[:cachingCanvas| self drawDataOn: cachingCanvas].
	self drawCursorOn: aCanvas.
! !


!GraphMorph methodsFor: 'change reporting'!
layoutChanged

	super layoutChanged.
	cachedForm _ nil.
! !


!GraphMorph methodsFor: 'events' stamp: 'jm 10/18/97 11:32'!
handlesMouseDown: evt

	evt shiftPressed
		ifTrue: [^ super handlesMouseDown: evt]
		ifFalse: [^ true].
! !

!GraphMorph methodsFor: 'events' stamp: 'jm 10/18/97 11:52'!
mouseMove: evt

	| x w |
	x _ evt cursorPoint x - (bounds left + borderWidth).
	w _ self width - (2 * borderWidth).

	self changed.
	x < 0 ifTrue: [
		cursor _ startIndex + (3 * x).
		cursor _ (cursor max: 1) min: data size.
		^ self startIndex: cursor].
	x > w ifTrue: [
		cursor _ startIndex + w + (3 * (x - w)).
		cursor _ (cursor max: 1) min: data size.
		^ self startIndex: cursor - w].

	cursor _ ((startIndex + x) max: 1) min: data size.
! !


!GraphMorph methodsFor: 'stepping' stamp: 'jm 6/17/1999 21:32'!
step
	"Make a deferred damage rectangle if I've changed. This allows applications to call methods that invalidate my display at high-bandwidth without paying the cost of doing the damage reporting on ever call; they can merely set hasChanged to true."

	super step.
	hasChanged == nil ifTrue: [hasChanged _ false].
	hasChanged ifTrue: [
		self changed.
		hasChanged _ false].
! !


!GraphMorph methodsFor: 'menu' stamp: 'jm 6/16/1999 13:08'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'open wave editor' action: #openWaveEditor.
	aCustomMenu add: 'read file' action: #readDataFromFile.
! !

!GraphMorph methodsFor: 'menu' stamp: 'di 10/11/1999 08:38'!
openWaveEditor

	| scaleFactor scaledData editor |
	self data: data.  "make sure maxVal and minVal are current"
	scaleFactor _ 32767 // ((minVal abs max: maxVal abs) max: 1).
	scaledData _ SoundBuffer newMonoSampleCount: data size.
	1 to: data size do: [:i | scaledData at: i put: (scaleFactor * (data at: i)) truncated].
	editor _ WaveEditor new
		data: scaledData;
		samplingRate: 11025;
		perceivedFrequency: 220.0.
	editor openInWorld.
! !

!GraphMorph methodsFor: 'menu' stamp: 'jm 6/16/1999 11:24'!
readDataFromFile

	| fileName |
	fileName _ FillInTheBlank
		request: 'File name?'
		initialAnswer: ''.
	fileName isEmpty ifTrue: [^ self].
	(StandardFileStream isAFileNamed: fileName) ifFalse: [
		^ self inform: 'Sorry, I cannot find that file'].
	self data: (SampledSound fromAIFFfileNamed: fileName) samples.

! !


!GraphMorph methodsFor: 'commands'!
appendValue: aPointOrNumber

	| newVal |
	(data isKindOf: OrderedCollection) ifFalse: [data _ data asOrderedCollection].
	newVal _ self asNumber: aPointOrNumber.
	data addLast: newVal.
	newVal < minVal ifTrue: [minVal _ newVal].
	newVal > maxVal ifTrue: [maxVal _ newVal].
	self cursor: data size.
	self flushCachedForm.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 7/30/1998 12:17'!
centerCursor
	"Scroll so that the cursor is as close as possible to the center of my window."

	| w |
	w _ self width - (2 * borderWidth).
	self startIndex: ((cursor - (w // 2)) max: 1).
! !

!GraphMorph methodsFor: 'commands'!
clear

	self startIndex: 1.
	self cursor: 1.
	self data: OrderedCollection new.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:49'!
loadSineWave

	self loadSoundData: FMSound sineTable.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:17'!
loadSound: aSound

	self loadSoundData: aSound samples.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:23'!
loadSoundData: aCollection

	| scale absV newData |
	scale _ 0.
	aCollection do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]].
	scale _ 100.0 / scale.
	newData _ OrderedCollection new: aCollection size.
	1 to: aCollection size do: [:i | newData addLast: (scale * (aCollection at: i))].

	self data: newData.
	self startIndex: 1.
	self cursor: 1.
! !

!GraphMorph methodsFor: 'commands' stamp: 'jm 6/16/1999 11:29'!
playOnce

	| scale absV scaledData |
	data isEmpty ifTrue: [^ self].  "nothing to play"
	scale _ 1.
	data do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]].
	scale _ 32767.0 / scale.
	scaledData _ SoundBuffer newMonoSampleCount: data size.
	1 to: data size do: [:i | scaledData at: i put: (scale * (data at: i)) truncated].
	(SampledSound samples: scaledData samplingRate: 11025) play.
! !

!GraphMorph methodsFor: 'commands'!
reverse

	data _ data reversed.
	self flushCachedForm.
! !



!GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 21:36'!
drawCursorOn: aCanvas

	| ptr x r c |
	ptr _ (cursor asInteger max: 1) min: data size.
	c _ cursorColor.
	((ptr > 1) and: [ptr < data size]) ifTrue: [
		(data at: ptr) sign ~= (data at: ptr + 1) sign
			ifTrue: [c _ cursorColorAtZeroCrossings]].
	r _ self innerBounds.
	x _ r left + ptr - startIndex.
	((x >= r left) and: [x <= r right]) ifTrue: [
		aCanvas fillRectangle: (x@r top corner: x + 1@r bottom) color: c].
! !

!GraphMorph methodsFor: 'private'!
drawDataOn: aCanvas

	| yScale baseLine x start end value left top bottom right |
	super drawOn: aCanvas.

	data isEmpty ifTrue: [^ self].
	maxVal = minVal ifTrue: [
		yScale _ 1.
	] ifFalse: [
		yScale _ (bounds height - (2 * borderWidth)) asFloat / (maxVal - minVal)].
	baseLine _ bounds bottom - borderWidth + (minVal * yScale) truncated.
	left _ top _ 0. right _ 10. bottom _ 0.
	x _ bounds left + borderWidth.
	start _ (startIndex asInteger max: 1) min: data size.
	end _ (start + bounds width) min: data size.
	start to: end do: [:i |
		left _ x truncated. right _ x + 1.
		right > (bounds right - borderWidth) ifTrue: [^ self].
		value _ (data at: i) asFloat.
		value >= 0.0 ifTrue: [
			top _ baseLine - (yScale * value) truncated.
			bottom _ baseLine.
		] ifFalse: [
			top _ baseLine.
			bottom _ baseLine - (yScale * value) truncated].
		aCanvas fillRectangle: (left@top corner: right@bottom) color: dataColor.
		x _ x + 1].
! !

!GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 20:10'!
flushCachedForm

	cachedForm _ nil.
	hasChanged _ true.
! !

!GraphMorph methodsFor: 'private' stamp: 'jm 4/21/1999 11:30'!
keepIndexInView: index

	| w newStart |
	w _ bounds width - (2 * borderWidth).
	index < startIndex ifTrue: [
		newStart _ index - w + 1.
		^ self startIndex: (newStart max: 1)].
	index > (startIndex + w) ifTrue: [
		^ self startIndex: (index min: data size)].
! !


!GraphMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:46'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	hasChanged ifNil: [hasChanged _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !

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

GraphMorph class
	instanceVariableNames: ''!

!GraphMorph class methodsFor: 'scripting' stamp: 'sw 9/17/2000 12:34'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(

	(basic (
(slot cursor 	'The current cursor location, wrapped back to the beginning if appropriate' number	 readWrite player getCursor player setCursorWrapped:)

(slot sampleAtCursor	'The sample value at the current cursor location' number readWrite player getSampleAtCursor player setSampleAtCursor:)))

	(sampling (
(slot cursor 	'The current cursor location, wrapped back to the beginning if appropriate' number	 readWrite player getCursor player setCursorWrapped:)
(slot sampleAtCursor	'The sample value at the current cursor location' number readWrite player getSampleAtCursor player setSampleAtCursor:)
(slot lastValue 'The last value obtained' number readWrite	player getLastValue player setLastValue:)
(command clear 'Clear the graph of current contents')
(command loadSineWave 'Load a sine wave as the current graph')
(command loadSound: 'Load the specified sound into the current graph' sound)
(command reverse 'Reverse the graph')
(command play 'Play the current graph as a sound'))))! !
OrderedCollection variableSubclass: #GraphicSymbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Symbols'!
!GraphicSymbol commentStamp: '<historical>' prior: 0!
I represent a structured picture built from primitive display objects and other instances of me.!


!GraphicSymbol methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the receiver on the Display where aTransformation is provided 
	as an argument, rule is anInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRect."

	self do: 
		[:element | 
		element
			displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!GraphicSymbol methodsFor: 'displaying'!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the receiver where aTransformation is provided as an argument, 
	rule is anInteger and mask is aForm. No translation. Information to be 
	displayed must be confined to the area that intersects with clipRect."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !


!GraphicSymbol methodsFor: 'accessing' stamp: 'jrm 2/6/2000 11:01'!
computeBoundingBox
	"Compute a boundingBox that encloses all of the Paths in this symbol"

	^Rectangle merging: (self collect: [:each | each computeBoundingBox])
! !
Object subclass: #GraphicSymbolInstance
	instanceVariableNames: 'transformation graphicSymbol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Symbols'!
!GraphicSymbolInstance commentStamp: '<historical>' prior: 0!
I represent a display transformation of a GraphicSymbol. Multiple copies of a GraphicSymbol can be displayed at different positions and scales on the screen by making appropriate, multiple, instances of me.!


!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol
	"Answer the graphic symbol that the receiver displays."

	^graphicSymbol! !

!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol: aGraphicSymbol 
	"Set the argument, aGraphicSymbol, to be the graphic symbol that the 
	receiver displays."

	graphicSymbol _ aGraphicSymbol! !


!GraphicSymbolInstance methodsFor: 'transforming'!
transformation
	"Answer the receiver's display transformation."

	^transformation! !

!GraphicSymbolInstance methodsFor: 'transforming'!
transformation: aWindowingTransformation 
	"Set the argument, aWindowingTransformation, to be the receiver's 
	display transformation."

	transformation _ aWindowingTransformation! !


!GraphicSymbolInstance methodsFor: 'displaying' stamp: 'jrm 2/13/2000 10:02'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox:
clipRect rule: anInteger fillColor: aForm 
	"Display the graphic symbol on the Display according to the arguments 
	of this message."

	graphicSymbol
		displayOn: aDisplayMedium
		transformation: aTransformation 
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

!GraphicSymbolInstance methodsFor: 'displaying'!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the graphic symbol according to the arguments of this message."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !

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

GraphicSymbolInstance class
	instanceVariableNames: ''!

!GraphicSymbolInstance class methodsFor: 'examples'!
example
	"Simply evaluate the method and two GraphicSymbolInstances, each
	displaying a transformation of the same graphic symbol, will be
	presented on the screen. Clears the screen to white."

	| gate instance1 instance2 trans1 trans2 line arc f|
	Display fillWhite.			"clear the Screen."
	f _ Form extent: 2@2.
	f fillBlack.
	gate_ GraphicSymbol new.		"make a logic gate out of lines and arcs."
	line_Line new.  line beginPoint: -20@-20.  line endPoint: 0@-20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: -20@20.  line endPoint: 0@20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: 0@-40.  line endPoint: 0@40. line form: f.
	gate add: line.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 1.
	arc form: f.
	gate add: arc.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 4.
	arc form: f.
	gate add: arc.

			"one instance at 1/2 scale."
	trans1_WindowingTransformation identity.	
	trans1_ trans1 scaleBy: 0.5@0.5.
	trans1_ trans1 translateBy: 100@100.

			"the other instance at 2 times scale"
	trans2_WindowingTransformation identity.	
	trans2_ trans2 scaleBy: 2.0@2.0.
	trans2_ trans2 translateBy: 200@200.

	instance1 _ GraphicSymbolInstance new.
	instance1 transformation: trans1.
	instance1 graphicSymbol: gate.

	instance2 _ GraphicSymbolInstance new.
	instance2 transformation: trans2.
	instance2 graphicSymbol: gate.

			"display both instances of the logic gate"
	instance1 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil.
	instance2 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil

	"GraphicSymbolInstance example"! !
GraphicalMenu subclass: #GraphicalDictionaryMenu
	instanceVariableNames: 'baseDictionary entryNames '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!GraphicalDictionaryMenu commentStamp: '<historical>' prior: 0!
A morph that allows you to view, rename, and remove elements from a dictionary whose keys are strings and whose values are forms.!


!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/24/1998 11:59'!
baseDictionary: aDictionary
	baseDictionary _ aDictionary.
	entryNames _ aDictionary keys asSortedArray.
	formChoices _ entryNames collect: [:n | aDictionary at: n].
	currentIndex _ 1! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 21:42'!
findEntry
	| toFind searchIndex |
	toFind _ FillInTheBlank request: 'Type name or fragment: ' initialAnswer: 'Controls'.
	toFind isEmptyOrNil ifTrue: [^ self].
	searchIndex _ currentIndex + 1.
	toFind _ '*', toFind asLowercase, '*'.
	[toFind match: (entryNames at: searchIndex) asString]
		whileFalse:
			[searchIndex _ (searchIndex \\ entryNames size) + 1.
			searchIndex == currentIndex ifTrue: [^ self inform: 'not found']].

	currentIndex _ searchIndex.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 5/26/2000 07:01'!
handMeOne
	self currentHand attachMorph: (SketchMorph new form: (formChoices at: currentIndex))! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:18'!
initializeFor: aTarget fromDictionary: aDictionary
	|  imageWrapper anIndex aButton controlsWrapper asm |
	self listDirection: #topToBottom.
	self addMorphBack: (controlsWrapper _ AlignmentMorph newRow).
	self baseDictionary: aDictionary.
	target _ aTarget.
	coexistWithOriginal _ true.
	color _ Color white.
	borderColor _ Color blue darker.
	borderWidth _ 1.

	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	controlsWrapper borderWidth: 0; layoutInset: 0; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	controlsWrapper wrapCentering: #topLeft; color: Color white; vResizing: #spaceFill.
	controlsWrapper addTransparentSpacerOfSize: (18@0).
	controlsWrapper addMorphBack: (IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: 'Menu'); color: Color transparent; 
			actWhen: #buttonDown;
			actionSelector: #showMenu; target: self;
			setBalloonText: 'menu').

	controlsWrapper  addTransparentSpacerOfSize: (14@0).

	aButton _ SimpleButtonMorph new target: self; borderColor: Color black.

	controlsWrapper addMorphBack: (aButton fullCopy
		label: 'Prev';
		actionSelector: #downArrowHit;
		actWhen: #whilePressed;
		setBalloonText: 'show previous picture';
		yourself).
	controlsWrapper addTransparentSpacerOfSize: (15@0).
	controlsWrapper addMorphBack: (aButton fullCopy label: 'Next';	actionSelector: #upArrowHit; actWhen: #whilePressed; setBalloonText: 'show next pictutre').

	self addMorphBack: controlsWrapper.
	self addTransparentSpacerOfSize: (0 @ 12).

	self addMorphBack:  (asm _ UpdatingStringMorph new contents: ' '; target: self; putSelector: #renameGraphicTo:; getSelector: #truncatedNameOfGraphic; useStringFormat).
	asm setBalloonText: 'The name of the current graphic'. 
	self addTransparentSpacerOfSize: (0 @ 12).
	self addMorphBack: (AlignmentMorph newRow height: 4; borderWidth: 0; color: Color black).
	imageWrapper _ Morph new color: Color transparent; extent: 190 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target ifNotNil: [(anIndex _ formChoices indexOf: target form ifAbsent: [nil]) ifNotNil:
		[currentIndex _ anIndex]].
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/24/1998 11:25'!
nameOfGraphic
	^ entryNames at: currentIndex! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/24/1998 12:15'!
removeEntry
	baseDictionary removeKey: (entryNames at: currentIndex).
	self baseDictionary: baseDictionary.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sma 6/18/2000 10:36'!
renameEntry
	| reply curr |
	reply _ FillInTheBlank
		request: 'New key? '
		initialAnswer: (curr _ entryNames at: currentIndex)
		centerAt: self center.
	(reply isEmptyOrNil or: [reply = curr]) ifTrue: [^ self beep].
	(baseDictionary includesKey: reply) ifTrue:
		[^ self inform: 'sorry that conflicts with
the name of another
entry in this dictionary'].
	baseDictionary at: reply put: (baseDictionary at: curr).
	baseDictionary removeKey: curr.
	self baseDictionary: baseDictionary.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 4/5/1999 12:34'!
renameGraphicTo: newName
	| curr |
	curr _ entryNames at: currentIndex.
	(newName isEmptyOrNil or: [newName = curr]) ifTrue: [^ self beep].
	(baseDictionary includesKey: newName) ifTrue:
		[^ self inform: 'sorry that conflicts with
the name of another
entry in this dictionary'].
	baseDictionary at: newName put: (baseDictionary at: curr).
	baseDictionary removeKey: curr.
	self baseDictionary: baseDictionary.
	currentIndex _ entryNames indexOf: newName.
	self updateThumbnail! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:29'!
repaintEntry
	"Let the user enter into painting mode to repaint the item and save it back."

	| aWorld bnds sketchEditor aPaintBox formToEdit |
	
	(aWorld _ self world) assureNotPaintingElse: [^ self].

	aWorld stopRunningAll; abandonAllHalos.
	aWorld displayWorld.
	formToEdit _ formChoices at: currentIndex.
	bnds _ (submorphs second boundsInWorld origin extent: formToEdit extent) intersect: aWorld bounds.
	bnds _ (aWorld paintingBoundsAround: bnds center) merge: bnds.
	sketchEditor _ SketchEditorMorph new.
	aWorld addMorphFront: sketchEditor.
	sketchEditor initializeFor: ((SketchMorph withForm: formToEdit) position: submorphs second positionInWorld)  inBounds: bnds pasteUpMorph: aWorld paintBoxPosition: bnds topRight.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			formChoices at: currentIndex put: aForm.
			baseDictionary at: (entryNames at: currentIndex) put: aForm.
			self updateThumbnail.
			(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]] 
		ifNoBits:
			[(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]].
	
! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 19:31'!
showMenu
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addList: #(
		('remove'			removeEntry)
		('rename'			renameEntry)
		('repaint'			repaintEntry)
		-
		('find...'			findEntry)
		-
		('hand me one'		handMeOne)).
	aMenu popUpInWorld: self currentWorld.
! !

!GraphicalDictionaryMenu methodsFor: 'as yet unclassified' stamp: 'sw 5/28/2000 23:19'!
truncatedNameOfGraphic
	^ self nameOfGraphic truncateTo: 30! !

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

GraphicalDictionaryMenu class
	instanceVariableNames: ''!

!GraphicalDictionaryMenu class methodsFor: 'example' stamp: 'sw 12/24/1998 12:11'!
example
	"GraphicalDictionaryMenu example"
	| aDict |
	aDict _ Dictionary new.
	#('ColorTilesOff' 'ColorTilesOn' 'Controls') do:
		[:aString | aDict at: aString put: (ScriptingSystem formAtKey: aString)].
	aDict inspectFormsWithLabel: 'Testing One Two Three'! !
AlignmentMorph subclass: #GraphicalMenu
	instanceVariableNames: 'target selector argument currentIndex formChoices formDisplayMorph coexistWithOriginal '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
argument
	^argument! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
argument: anObject
	argument _ anObject! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/4/1998 23:49'!
cancel
	coexistWithOriginal
		ifTrue:
			[self delete]
		ifFalse:
			[owner replaceSubmorph: self topRendererOrSelf by: target]! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 17:56'!
downArrowHit
	currentIndex _ currentIndex - 1.
	(currentIndex < 1) ifTrue:  [currentIndex _ formChoices size].
	self updateThumbnail
	
! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:53'!
initialize
	super initialize.
	selector _ #newForm:.! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:18'!
initializeFor: aTarget withForms: formList coexist: aBoolean
	" World primaryHand attachMorph: (GraphicalMenu new initializeFor: nil 
		withForms: Form allInstances coexist: true) "
	| buttons b anIndex buttonCage imageWrapper |
	target _ aTarget.
	coexistWithOriginal _ aBoolean.
	color _ Color white.
	borderColor _ Color blue darker.
	borderWidth _ 1.
	formChoices _ formList.
	currentIndex _ 1.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	b _ SimpleButtonMorph new target: self; borderColor: Color black.

	buttons _ AlignmentMorph newRow.
	buttons borderWidth: 0; layoutInset: 0.
	buttons hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	buttons wrapCentering: #topLeft.
	buttonCage _ AlignmentMorph newColumn.
	buttonCage hResizing: #shrinkWrap; vResizing: #spaceFill.
	buttonCage addTransparentSpacerOfSize: (0 @ 10).

	buttons addMorphBack: (b fullCopy label: 'Prev';	actionSelector: #downArrowHit; actWhen: #whilePressed).
	buttons addTransparentSpacerOfSize: (9@0).
	buttons addMorphBack: (b fullCopy label: 'Next';	actionSelector: #upArrowHit; actWhen: #whilePressed).
	buttons addTransparentSpacerOfSize: (5@0).

	buttons submorphs last color: Color white.
	buttonCage addMorphBack: buttons.
	buttonCage addTransparentSpacerOfSize: (0 @ 12).
	buttons _ AlignmentMorph newRow.
	buttons addMorphBack: (b fullCopy label: 'OK';	actionSelector: #okay).
	buttons addTransparentSpacerOfSize: (5@0).
	buttons addMorphBack: (b fullCopy label: 'Cancel';	actionSelector: #cancel).
	buttonCage addMorphBack: buttons.
	buttonCage addTransparentSpacerOfSize: (0 @ 10).
	self addMorphFront: buttonCage.

	imageWrapper _ Morph new color: Color transparent; extent: 102 @ 82.
	imageWrapper addMorphBack: (formDisplayMorph _ ImageMorph new extent: 100 @ 100).
	self addMorphBack: imageWrapper.
	target ifNotNil: [(anIndex _ formList indexOf: target form ifAbsent: [nil]) ifNotNil:
		[currentIndex _ anIndex]].
	self updateThumbnail! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
okay
	| nArgs |
	target ifNotNil:[
		nArgs _ selector numArgs.
		nArgs = 1 ifTrue:[target perform: selector with: (formChoices at: currentIndex)].
		nArgs = 2 ifTrue:[target perform: selector with: (formChoices at: currentIndex) with: argument]].
	coexistWithOriginal
		ifTrue:
			[self delete]
		ifFalse:
			[owner replaceSubmorph: self topRendererOrSelf by: target]! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
selector
	^selector! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:54'!
selector: aSymbol
	selector _ aSymbol! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 17:54'!
upArrowHit
	currentIndex _ currentIndex + 1.
	(currentIndex > formChoices size) ifTrue: [currentIndex _ 1].
	self updateThumbnail
	
! !

!GraphicalMenu methodsFor: 'as yet unclassified' stamp: 'sw 12/2/1998 22:05'!
updateThumbnail
	| f scaleY scaleX maxWidth stdHeight |
	maxWidth _ 100.
	stdHeight _ 80.
	f _ formChoices at: currentIndex.
	scaleY _ stdHeight / f height.  "keep height invariant"
	scaleY _ scaleY min: 1.
	scaleX _ ((f width * scaleY) <= maxWidth)
		ifTrue:
			[scaleY]
		ifFalse:
			[maxWidth / f width].
	formDisplayMorph image: (f magnify: f boundingBox by: (scaleX @ scaleY) smoothing: 2).
	formDisplayMorph layoutChanged! !
Object subclass: #HTMLformatter
	instanceVariableNames: 'formattingBlock specialCharacter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!HTMLformatter commentStamp: '<historical>' prior: 0!
HTMLformatter class (instances don't know anything) knows alot about HTML formatting: Creating forms, pages, different widgets, etc.  It also knows how to process Smalltalk embedded within an HTML document.
!


!HTMLformatter methodsFor: 'formatting' stamp: 'ls 4/18/98 16:46'!
format: requestObject
	"format text with requestObject as the argument for
the code blocks"
	^String streamContents: [ :stream |

	formattingBlock value: requestObject value: stream ]! !


!HTMLformatter methodsFor: 'private-initialization' stamp: 'ls 4/18/98 13:23'!
formattingBlock: aBlock
	formattingBlock _ aBlock! !

!HTMLformatter methodsFor: 'private-initialization' stamp: 'mjg 8/28/1998
20:56'!
initialize
	specialCharacter = $*.! !


!HTMLformatter methodsFor: 'translating' stamp: 'mjg 8/28/1998 21:03'!
rangesOfAngleBrackets: sourceStrm
	"Return an OrderedCollection of intervals of position within angle
brackets < and >.  Caller wants to avoid putting <br> in there."

	| list char intervals start |
	list _ OrderedCollection new: 10.
	[sourceStrm atEnd] whileFalse: [
		(char _ sourceStrm next) == $< ifTrue: [list add:
sourceStrm position].	"a start"
		char == $> ifTrue: [list add: sourceStrm position
negated]].	"an end"
	sourceStrm reset.
	intervals _ OrderedCollection new: 10.
	start _ nil.
	list do: [:each |
		(each > 0) & (start == nil) ifTrue: [start _ each].
		(each < 0) & (start ~~ nil) ifTrue: [
			intervals add: (start to: each negated). start _ nil]].
	^ intervals

"	HTMLformatter rangesOfAngleBrackets: (ReadStream on: '1234 <good>
<456 <good> 567> <ok>')
	"! !

!HTMLformatter methodsFor: 'translating' stamp: 'tk 9/24/1998 08:08'!
swikify: aStringOrStream linkhandler: aBlock
	| sourceStream aLine targetStream start end forbidden ignore |
	(aStringOrStream isKindOf: Stream)
		ifTrue: [sourceStream := aStringOrStream]
		ifFalse: [sourceStream := ReadStream on: aStringOrStream].
	forbidden _ self rangesOfAngleBrackets: sourceStream.
	targetStream := WriteStream on: String new.
	[sourceStream atEnd] whileFalse:
		[aLine := sourceStream upTo: (Character cr).
		" Now, look for links "
		start _ 1.
		[(start _ aLine indexOfSubCollection: (specialCharacter asString) 
				startingAt: start ifAbsent: [0]) ~= 0
			and: [start < aLine size]]
		whileTrue:
			[(aLine at: start+1) = specialCharacter
			ifTrue: [aLine _ aLine copyReplaceFrom: start to: start+1 
						with: specialCharacter asString.
					start_start + 1. ]
			ifFalse: [
				(end _ aLine indexOfSubCollection: (specialCharacter asString) 
					startingAt: (start+1) ifAbsent: [0]) ~= 0
				ifTrue: [aLine _ aLine copyReplaceFrom: start to: end
						with: (aBlock value: (aLine copyFrom: start+1 to: end-1))]
				ifFalse: [start _ start + 1]]].

		"If it's at least 4 dashes, make it a horizontal rule"
		(aLine indexOfSubCollection: '----' startingAt: 1) = 1
			ifTrue: [targetStream nextPutAll: '<hr>']
			ifFalse: [targetStream nextPutAll: aLine].
		"Should there be a <br> after this line?"
		(ignore _ sourceStream peek = $<) ifTrue: [
			"If just before a tag, ignore the newline"
			targetStream nextPut: $ ].	"but do put in a separator"
		forbidden do: [:interval |
			(interval includes: sourceStream position) ifTrue: [ignore _ true]].
		ignore ifFalse: [
			(sourceStream peek) = (Character cr)
				ifTrue: [sourceStream next. targetStream nextPutAll: '<p>'; cr.]
				ifFalse: [targetStream nextPutAll: '<br>'; cr.]]].
	^targetStream contents.
! !


!HTMLformatter methodsFor: 'accessing' stamp: 'mjg 8/28/1998 21:00'!
specialCharacter
	^specialCharacter! !

!HTMLformatter methodsFor: 'accessing' stamp: 'mjg 8/28/1998 21:01'!
specialCharacter: someCharacter
	specialCharacter _ someCharacter! !

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

HTMLformatter class
	instanceVariableNames: ''!

!HTMLformatter class methodsFor: 'pages and forms' stamp: 'mjg 10/31/97 16:00'!
endForm
	^ '</FORM>'
! !

!HTMLformatter class methodsFor: 'pages and forms' stamp: 'mjg 10/31/97 15:58'!
endPage
	| stream |
	stream _ WriteStream on: ''.
	stream nextPutAll: '</BODY>';cr;
	 nextPutAll: '</HTML>';cr.
	^stream contents! !

!HTMLformatter class methodsFor: 'pages and forms' stamp: 'mjg 10/31/97 15:59'!
startForm: action
	| stream |
	stream _ WriteStream on: ''.
	stream nextPutAll: '<FORM METHOD="POST" ACTION="', action, '">';
	 cr.
	^ stream contents! !

!HTMLformatter class methodsFor: 'pages and forms' stamp: 'mjg 10/31/97 15:57'!
startPage: title
	| stream |
	stream _ WriteStream on: ''.
	stream nextPutAll: '<!!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">'; cr;
	 nextPutAll: '<HTML>';cr;
	 nextPutAll: '<HEAD>';cr;
	 nextPutAll: '<TITLE>'; nextPutAll: title; nextPutAll: '</TITLE>';cr;
	 nextPutAll: '<BODY>'; cr. 
	^ stream contents! !


!HTMLformatter class methodsFor: 'translating' stamp: 'ls 4/18/98 16:23'!
evalEmbedded: stringOrStream with: request
	| formatter |
	formatter _
self forEvaluatingEmbedded: stringOrStream.
	^formatter format: request! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 1/29/98 21:40'!
evalEmbedded: string with: request unlessContains: dangerSet
	dangerSet do: [:each | (string includesSubstring: each caseSensitive: false)
		ifTrue: [^'Unsafe code!!']].
	^self evalEmbedded: string with: request
! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 11/25/97 11:50'!
fixEndings: aStringOrStream
	| sourceStream targetStream aLine |
	(aStringOrStream isKindOf: Stream)
		ifTrue: [sourceStream := aStringOrStream]
		ifFalse: [sourceStream := ReadStream on: aStringOrStream].
	targetStream := ReadWriteStream on: String new. 
	[sourceStream atEnd] whileFalse:
	[aLine := sourceStream upTo: (Character linefeed).
	targetStream nextPutAll: aLine.
	targetStream nextPut: Character cr.].
	^targetStream
! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 6/3/98 10:29'!
fixForIE: text
	| ch targetStream sourceStream |
	targetStream := WriteStream on: String new.
	sourceStream := ReadStream on: text.
	[sourceStream atEnd] whileFalse:
	[ch := sourceStream next.
	ch = $> ifTrue: [targetStream nextPutAll: '&gt;']
	ifFalse: [ch = $< ifTrue: [targetStream nextPutAll: '&lt;']
		ifFalse: [targetStream nextPut: ch]].].
	^targetStream contents
! !

!HTMLformatter class methodsFor: 'translating' stamp: 'tk 7/15/1998 12:02'!
forEvaluatingEmbedded: stringOrStream
	"stringOrStream is text with <?expr?> expressions intermingled.
This creates a HTLMLformatter instance which will substitute the <?expr?>
expressions with the value of the argument (named request), and which
leaves all other text in stringOrStream alone"

	| blockStream sourceStream doingEval ch |

	blockStream _ WriteStream on: String new.
 	blockStream nextPutAll: '[ :request :output | output nextPutAll: '''.

	(stringOrStream isKindOf: Stream)
		ifTrue: [sourceStream := stringOrStream]
		ifFalse: [sourceStream := ReadStream on: stringOrStream].

	doingEval _ false.

	[sourceStream atEnd] whileFalse:  [
		ch := sourceStream next.
		(doingEval not and: [ ch = $<  and: [ sourceStream peek =
$? ]]) ifTrue: [
			"beginning of an <?...?> expression"
			blockStream nextPutAll: '''.  output nextPutAll: ['.
			sourceStream next.  "Skip the ?"
			doingEval _ true]
		ifFalse: [
		(doingEval and: [ ch = $? and: [ sourceStream peek = $> ]])
ifTrue: [
			"end of a <?...?> expression"
			blockStream nextPutAll: '] value asString.  output
nextPutAll: '''.
			sourceStream next.  "Skip the >"
			doingEval _ false.]
		ifFalse: [
			"normal char"
			blockStream nextPut: ch.
			(doingEval not and: [ ch = $' ]) ifTrue: [
				 "double $' marks"  blockStream nextPut: $'
] ] ] ].

	"end the block"
	doingEval
		ifTrue: [ blockStream nextPutAll: '] value asString' ]
		ifFalse: [ blockStream nextPutAll: '''' ].
	blockStream nextPutAll: ']'.

	^HTMLformatter new formattingBlock: (Compiler evaluate: blockStream
contents)! !

!HTMLformatter class methodsFor: 'translating' stamp: 'ls 4/18/98 16:38'!
oldEvalEmbedded: stringOrStream with: request
	| sourceStream targetStream
evalStream currentStream evalValue peekValue ch |
	(stringOrStream
isKindOf: Stream)
		ifTrue: [sourceStream := stringOrStream]

		ifFalse: [sourceStream := ReadStream on: stringOrStream].

	targetStream := WriteStream on: String new.
	currentStream :=
targetStream. 
	[sourceStream atEnd] whileFalse: 
		[ch :=
sourceStream next.
		ch = $< ifTrue:
			[
peekValue := sourceStream peek. (peekValue = $?) ifTrue:

		[evalStream := WriteStream on: String new.

		currentStream := evalStream.

	sourceStream next. "Eat the ?"
				ch :=
sourceStream next.]].
		((currentStream = evalStream) and: [ch =
$?]) ifTrue:
			[ peekValue := sourceStream peek.
(peekValue = $>) ifTrue:
				[sourceStream next.
"Eat the >"
				currentStream := targetStream.

			evalValue := (Compiler new evaluate: (evalStream
contents) 
					in: thisContext to: self
notifying: nil ifFail: [^nil]).
				(evalValue
isKindOf: String)
				ifFalse: [evalValue :=
evalValue printString].
				currentStream
nextPutAll: evalValue.]]
			ifFalse: [currentStream
nextPut: ch].].
	^targetStream contents

! !

!HTMLformatter class methodsFor: 'translating' stamp: 'tk 1/14/98 10:30'!
rangesOfAngleBrackets: sourceStrm
	"Return an OrderedCollection of intervals of position within angle brackets < and >.  Caller wants to avoid putting <br> in there."

	| list char intervals start |
	list _ OrderedCollection new: 10.
	[sourceStrm atEnd] whileFalse: [
		(char _ sourceStrm next) == $< ifTrue: [list add: sourceStrm position].	"a start"
		char == $> ifTrue: [list add: sourceStrm position negated]].	"an end"
	sourceStrm reset.
	intervals _ OrderedCollection new: 10.
	start _ nil.
	list do: [:each |
		(each > 0) & (start == nil) ifTrue: [start _ each].
		(each < 0) & (start ~~ nil) ifTrue: [
			intervals add: (start to: each negated). start _ nil]].
	^ intervals	

"	HTMLformatter rangesOfAngleBrackets: (ReadStream on: '1234 <good> <456 <good> 567> <ok>')
	"! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 11/10/97 12:38'!
simpleProcess: aStringOrStream
	| sourceStream targetStream ch |
	(aStringOrStream isKindOf: Stream)
		ifTrue: [sourceStream := aStringOrStream]
		ifFalse: [sourceStream := ReadStream on: aStringOrStream].
	targetStream := WriteStream on: String new. 
	[sourceStream atEnd] whileFalse:
	[ch := sourceStream next.
	(ch = Character linefeed) ifTrue:
		[(sourceStream peek) = (Character linefeed)
		ifTrue: [sourceStream next. targetStream nextPutAll: '<p>']
		ifFalse: [targetStream nextPutAll: '<br>']].
	targetStream nextPut: ch].
	^targetStream contents.
! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 9/3/1998 16:58'!
swikify: aStringOrStream linkhandler: aBlock
	| formatter |
	formatter _ self new.
	formatter specialCharacter: $*.
	^formatter swikify: aStringOrStream linkhandler: aBlock! !

!HTMLformatter class methodsFor: 'translating' stamp: 'mjg 12/8/97 11:37'!
textToGIF: oneLineString
	| form filename |
	form _ (Form extent: 400@20 depth: Display depth) fillWhite.
	oneLineString displayOn: form at: 2@0. "form display."
	filename _ 'f',(SmallInteger maxVal atRandom) printString,'.gif'.
	GIFReadWriter putForm: form onFileNamed: filename.
	^(FileStream fileNamed: filename) contentsOfEntireFile

	! !


!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:48'!
checkbox: buttonname value: b 
	^ '<INPUT TYPE="checkbox" NAME="' , buttonname , '"' , (b
			ifTrue: [' CHECKED ']
			ifFalse: ['']) , '>'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/24/97 16:56'!
formFooter
	"Write the standard footer for a form."

	self reply: '<hr><input type=reset value="Reset"> <input type=submit value="OK"></form>'
! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/24/97 16:58'!
formHeader: title For: aReference
	"Write the standard header for a page and form for editing anObject."

	self
		title: title;
		reply: '<form action="',aReference,'" method=post><table>'
! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:54'!
graphic: f
	^self graphic: f standIn: 'Picture' alignment: 'right'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:53'!
graphic: f standIn: s alignment: a 
	^ '<IMG SRC="' , f , '" ALT="' , s , '" ALIGN=' , a printString , '>'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:55'!
hiddenName: n value: v 
	^ '<INPUT TYPE="hidden" NAME="' , n , '" VALUE="' , v asString , '">'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 16:02'!
linkTo: url label: label
	^'<A HREF="',url,'">',label,'</A>'.! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:50'!
select: n values: values selection: selection size: size 
	^ self
		select: n
		values: values
		selections: (Array with: selection)
		size: size
		multiple: false! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:49'!
select: buttonname values: values selections: selections size: size multiple: multiple 
	| stream |
	stream _ WriteStream on: ''.
	stream nextPutAll: '<SELECT NAME="' , buttonname , '"' , (multiple
				ifTrue: [' MULTIPLE']
				ifFalse: ['']) , ' SIZE=' , size printString , '>';
	 cr.
	values do: 
		[:value | 
		stream nextPutAll: '<OPTION'.
		(selections includes: value)
			ifTrue: [stream nextPutAll: ' SELECTED'].
		stream nextPutAll: '>'.
		stream nextPutAll: value;
		 cr].
	stream nextPutAll: '</SELECT>'.
	^ stream contents! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:53'!
submit: label
	^ self submit: 'submit' label: label! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:52'!
submit: buttonName label: v 
	^ '<INPUT TYPE="submit" NAME="' , buttonName , '" VALUE="' , v , '">'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:51'!
text: fieldName
	^ self text: fieldName value: '' length: 80.
! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 10/31/97 15:51'!
text: fieldName value: v length: l 
	^ '<INPUT TYPE="text" NAME="' , fieldName , '" VALUE="' , v , '" MAXLENGTH=' , l printString , '>'! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:30'!
textArea: fieldName
	^ (self textAreaStart: fieldName rows: 15 cols: 70), self textAreaEnd! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:30'!
textArea: fieldName value: value
	^ (self textAreaStart: fieldName rows: 15 cols: 70), value, self textAreaEnd! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'mjg 11/4/97 14:28'!
textAreaEnd
	^ '</TEXTAREA>'
! !

!HTMLformatter class methodsFor: 'formatting' stamp: 'pm 6/6/1998 21:39'!
textAreaStart: fieldName rows: rows cols: cols
       ^ '<TEXTAREA NAME="', fieldName, '" ROWS=',rows,' COLS=',cols,'>' ! !


!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/18/97 09:38'!
show: aCollection
	"Return an HTML list to reference an ordered collection of text. Used in Chat application"
	| ret |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>' ; cr.
	1 to: aCollection size do: [:each |
		ret nextPutAll: '<li>'.
		ret nextPutAll: (aCollection at: each).].
	ret nextPutAll: '</ul>'.
	^ret contents
! !

!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/19/97 10:48'!
showList: aCollection
	"Return an HTML list to reference an ordered collection of notes. 
	prefix.index will be the reference URL for the note. Used in Comment 
	application. "
	| ret aNote |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>';
	 cr.
	1 to: aCollection size do: 
		[:each | 
		ret nextPutAll: '<li>'.
		aNote _ aCollection at: each.
		ret nextPutAll: (self linkTo: (aNote url) label: aNote title).
		ret nextPutAll: ' ' , aNote author , ' ' , aNote timestamp;
		 cr.
		aNote children size > 0 ifTrue: [ret nextPutAll: (self showList: aNote children)]].
	ret nextPutAll: '</ul>'.
	^ ret contents! !

!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/18/97 09:38'!
showList: aCollection parentPrefix: prefix
	"Return an HTML list to reference an ordered collection of notes. prefix.parent.index will be the reference URL for the note."
	| ret aNote |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>' ; cr.
	1 to: aCollection size do: [:each |
		ret nextPutAll: '<li>'.
		aNote := aCollection at: each.
		ret nextPutAll: (self linkTo: (prefix , aNote parent, '.', each printString) label: (aNote title)), '-'.
		ret nextPutAll: (self linkTo: (aNote author homepage) label: aNote author name)
			,'-',aNote timestamp ; cr.
		aNote children size > 0 ifTrue: 
			[ret nextPutAll: (self showList: aNote children prefix: (prefix , each printString))].].
	ret nextPutAll: '</ul>'.
	^ret contents
! !

!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/18/97 09:38'!
showList: aCollection prefix: prefix
	"Return an HTML list to reference an ordered collection of notes. prefix.index will be the reference URL for the note. Used in Comment application."
	| ret aNote |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>' ; cr.
	1 to: aCollection size do: [:each |
		ret nextPutAll: '<li>'.
		aNote := aCollection at: each.
		ret nextPutAll: (self linkTo: (prefix , each printString) label: (aNote title)).
		ret nextPutAll: ' ',aNote author,' ',aNote timestamp ; cr.
		aNote children size > 0 ifTrue: 
			[ret nextPutAll: (self showList: aNote children prefix: (prefix , each printString))].].
	ret nextPutAll: '</ul>'.
	^ret contents
! !

!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/19/97 10:48'!
showListWithAuthors: aCollection
	"Return an HTML list to reference an ordered collection of notes. 
	prefix.index will be the reference URL for the note. Special version for 
	linking to author's homepage, if any."
	| ret aNote |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>';
	 cr.
	1 to: aCollection size do: 
		[:each | 
		ret nextPutAll: '<li>'.
		aNote _ aCollection at: each.
		ret nextPutAll: (self linkTo: (aNote url) label: aNote title)
				, '-'.
		ret nextPutAll: (self linkTo: aNote author homepage label: aNote author name)
				, '-' , aNote timestamp;
		 cr.
		aNote children size > 0 ifTrue: [ret nextPutAll: (self showListWithAuthors: aNote children)]].
	ret nextPutAll: '</ul>'.
	^ ret contents! !

!HTMLformatter class methodsFor: 'note support' stamp: 'mjg 11/18/97 09:38'!
showListWithAuthors: aCollection prefix: prefix
	"Return an HTML list to reference an ordered collection of notes. prefix.index will be the reference URL for the note. Special version for linking to author's homepage, if any."
	| ret aNote |
	ret _ WriteStream on: String new.
	ret nextPutAll: '<ul>' ; cr.
	1 to: aCollection size do: [:each |
		ret nextPutAll: '<li>'.
		aNote := aCollection at: each.
		ret nextPutAll: (self linkTo: (prefix , each printString) label: (aNote title)),'-'.
		ret nextPutAll: (self linkTo: (aNote author homepage) label: aNote author name)
			,'-',aNote timestamp ; cr.
		aNote children size > 0 ifTrue: 
			[ret nextPutAll: (self showList: aNote children prefix: (prefix , each printString))].].
	ret nextPutAll: '</ul>'.
	^ret contents
! !
Object subclass: #HTTPLoader
	instanceVariableNames: 'requests downloads '
	classVariableNames: 'DefaultLoader MaxNrOfConnections '
	poolDictionaries: ''
	category: 'Framework-Download'!

!HTTPLoader methodsFor: 'private' stamp: 'mir 1/16/2000 16:11'!
addRequest: aHTTPRequest
	requests nextPut: aHTTPRequest.
	self startDownload! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/4/1999 18:31'!
maxNrOfConnections
	^MaxNrOfConnections! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 18:16'!
nextRequest
	^requests next! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 18:37'!
removeProcess: downloadProcess.
	downloads remove: downloadProcess ifAbsent: []! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 10/7/1999 17:02'!
removeRequest: request
	requests remove: request! !

!HTTPLoader methodsFor: 'private' stamp: 'mir 1/11/2000 15:23'!
startDownload
	| newDownloadProcess |
	(downloads size < self maxNrOfConnections 
		and: [requests size > 0]) ifTrue: [
			newDownloadProcess _ [
				self flag: #httpLoader log: 'Starting download'.
				self nextRequest startRetrieval.
				self flag: #httpLoader log: 'Download done'.
				downloads remove: Processor activeProcess.
				self startDownload] newProcess.
			downloads add: newDownloadProcess.
			newDownloadProcess resume]! !


!HTTPLoader methodsFor: 'requests' stamp: 'mir 1/15/2000 22:59'!
abort
	| oldRequests |
	"Abort all requests"
	oldRequests _ requests.
	requests _ SharedQueue new.
	[oldRequests isEmpty] whileFalse: [
		oldRequests next signalAbort].
	downloads do: [:each | each ifNotNil: [each terminate]].
	downloads _ OrderedCollection new
! !

!HTTPLoader methodsFor: 'requests' stamp: 'mir 12/22/1999 13:53'!
retrieveContentsFor: url
	| request |
	request _ PluginHTTPRequest for: url in: self.
	self addRequest: request.
	^request contents! !

!HTTPLoader methodsFor: 'requests' stamp: 'mir 1/16/2000 16:35'!
retrieveObjectsFor: aURL
	"Load a remote image segment and extract the root objects.
	Check if the remote file is a zip archive."
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 
		asUrl loadRemoteObjects" 
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 
		asUrl loadRemoteObjects" 

	| stream info data |
 	data _ self retrieveContentsFor: aURL.
	(data isKindOf: String)
		ifTrue: [^self error: data]
		ifFalse: [data _ data content].
	(data beginsWith: 'error')
		ifTrue: [^self error: data].
	data _ data unzipped.
	stream _ RWBinaryOrTextStream on: data.
	stream reset.
	info _ stream fileInObjectAndCode.
	stream close.
	^info originalRoots! !


!HTTPLoader methodsFor: 'initialize/release' stamp: 'mir 10/7/1999 18:14'!
initialize
	requests _ SharedQueue new.
	downloads _ OrderedCollection new! !

!HTTPLoader methodsFor: 'initialize/release' stamp: 'mir 10/7/1999 16:59'!
release
	self abort.
	downloads _ nil.
	requests _ nil! !

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

HTTPLoader class
	instanceVariableNames: ''!

!HTTPLoader class methodsFor: 'class initialization' stamp: 'mir 10/7/1999 20:08'!
initialize
	"HTTPLoader initialize"

	MaxNrOfConnections _ 2.
	DefaultLoader ifNotNil: [
		DefaultLoader release.
		DefaultLoader _ nil]! !


!HTTPLoader class methodsFor: 'instance creation' stamp: 'mir 10/4/1999 18:20'!
new
	^super new initialize! !


!HTTPLoader class methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:41'!
default
	DefaultLoader ifNil: [
		DefaultLoader _ HTTPLoader new].
	^DefaultLoader! !
Object subclass: #HTTPRequest
	instanceVariableNames: 'semaphore url content loader process '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:26'!
content: retrievedContent
	content _ retrievedContent.
	semaphore signal! !

!HTTPRequest methodsFor: 'accessing' stamp: 'ar 12/21/1999 14:23'!
contentStream
	"Return a stream on the content of a previously completed HTTP request"
	semaphore wait.
	^content contentStream! !

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 10/4/1999 18:25'!
contents
	semaphore wait.
	^content! !

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 10/7/1999 16:57'!
process: aProcess
	process _ aProcess! !

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 1/15/2000 22:55'!
signalAbort
	loader removeProcess: process.
	self content: 'Retrieval aborted'.
	process ifNotNil: [process terminate]! !

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 1/10/2000 18:33'!
startRetrieval
	self content: url asUrl retrieveContents! !

!HTTPRequest methodsFor: 'accessing' stamp: 'mir 1/20/2000 13:33'!
url
	^url! !


!HTTPRequest methodsFor: 'initialize' stamp: 'mir 10/7/1999 17:00'!
for: aUrl in: aLoader
	url _ aUrl.
	loader _ aLoader.
	semaphore _ Semaphore new.! !

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

HTTPRequest class
	instanceVariableNames: ''!

!HTTPRequest class methodsFor: 'instance creation' stamp: 'mir 10/7/1999 16:59'!
for: aUrl in: aLoader
	^self new for: aUrl in: aLoader! !
SimpleClientSocket subclass: #HTTPSocket
	instanceVariableNames: 'headerTokens headers responseCode '
	classVariableNames: 'HTTPBlabEmail HTTPPort HTTPProxyExceptions HTTPProxyPort HTTPProxyServer ParamDelimiters '
	poolDictionaries: ''
	category: 'Network-Protocols'!
!HTTPSocket commentStamp: '<historical>' prior: 0!
HTTPSockets support HTTP requests, either directly or via an HTTP proxy server. An HTTPSocket saves the parse of the last ASCII header it saw, to avoid having to parse it repeatedly.

The real action is in httpGet:accept:.  See the examples in the class, especially httpFileInNewChangeSet: and httpShowGif:.!
]style[(206 15 45 23 5 13)f1,f1LHTTPSocket class httpGet:accept:;,f1,f1LHTTPSocket class httpFileInNewChangeSet:;,f1,f1LHTTPSocket class httpShowGif:;!


!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/14/1998 10:17'!
contentType
	| type i |
	type _ self getHeader: 'content-type' default: nil.
	type ifNil: [ ^nil ].
	type _ type withBlanksTrimmed.
	i _ type indexOf: $;.
	i = 0 ifTrue: [ ^type ].
	^(type copyFrom: 1 to: i-1) withBlanksTrimmed	! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:23'!
contentType: header
	"extract the content type from the header.  Content-type: text/plain<cr><lf>,  User may look in headerTokens afterwards."

	| this |
	headerTokens ifNil: [ headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR) ].
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $c and: [#('content-type:' 'content type') includes: this asLowercase]) ifTrue: [
			^ (headerTokens at: ii+1)]].
	^ nil	"not found"! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/15/97 11:35'!
contentsLength: header
	"extract the data length from the header.  Content-length: 1234<cr><lf>,  User may look in headerTokens afterwards."

	| this |
	headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR).
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [
			^ (headerTokens at: ii+1) asNumber]].
	^ nil	"not found"! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:37'!
getHeader: name 
	^self getHeader: name  default: nil! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:36'!
getHeader: name  default: defaultValue
	^headers at: name  ifAbsent: [ defaultValue ]! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 11:39'!
getResponseUpTo: markerString
	"Keep reading until the marker is seen.  Return three parts: header, marker, beginningOfData.  Fails if no marker in first 2000 chars." 

	| buf response bytesRead tester mm |
	buf _ String new: 2000.
	response _ WriteStream on: buf.
	tester _ 1. mm _ 1.
	[tester _ tester - markerString size + 1 max: 1.  "rewind a little, in case the marker crosses a read boundary"
	tester to: response position do: [:tt |
		(buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1].
			"Not totally correct for markers like xx0xx"
		mm > markerString size ifTrue: ["got it"
			^ Array with: (buf copyFrom: 1 to: tt+1-mm)
				with: markerString
				with: (buf copyFrom: tt+1 to: response position)]].
	 tester _ 1 max: response position.	"OK if mm in the middle"
	 (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: response position + 1 count: buf size - response position.
		"response position+1 to: response position+bytesRead do: [:ii | 
			response nextPut: (buf at: ii)].	totally redundant, but needed to advance position!!"
		response instVarAt: 2 "position" put: 
			(response position + bytesRead)].	"horrible, but fast"

	^ Array with: response contents
		with: ''
		with: ''		"Marker not found and connection closed"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tao 6/22/1999 07:56'!
getResponseUpTo: markerString ignoring: ignoreString
	"Keep reading, until the marker is seen, skipping characters in ignoreString when
      comparing to the marker.  Return three parts: header, marker, beginningOfData.
     Fails if no marker in first 2000 chars." 

	| buf response bytesRead tester mm skipped |
	buf _ String new: 2000.
	response _ WriteStream on: buf.
	tester _ 1. mm _ 1.
	skipped _ 0.
	[tester _ tester - markerString size + 1 max: 1.  "rewind a little, in case the marker crosses a read boundary"
	tester to: response position do: [:tt |
		(buf at: tt) = (markerString at: mm) ifFalse:
			[[ignoreString includes: (markerString at: mm)] whileTrue:
				[mm _ mm + 1. skipped _ skipped + 1]].
		(buf at: tt) = (markerString at: mm)
			ifTrue: [mm _ mm + 1]
			ifFalse: [mm _ 1. skipped _ 0].
			"Not totally correct for markers like xx0xx"
		mm > markerString size ifTrue: ["got it"
			^ Array with: (buf copyFrom: 1 to: tt+1-mm+skipped)
				with: markerString
				with: (buf copyFrom: tt+1 to: response position)]].
	 tester _ 1 max: response position.	"OK if mm in the middle"
	 (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
			Transcript show: 'data was late'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
			startingAt: response position + 1 count: buf size - response position.
		"response position+1 to: response position+bytesRead do: [:ii | 
			response nextPut: (buf at: ii)].	totally redundant, but needed to advance position!!"
		response instVarAt: 2 "position" put: 
			(response position + bytesRead)].	"horrible, but fast"

	^ Array with: response contents
		with: ''
		with: ''		"Marker not found and connection closed"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 12:24'!
getRestOfBuffer: beginning
	"We don't know the length.  Keep going until connection is closed.  Part of it has already been received.  Response is of type text, not binary."

	| buf response bytesRead |
	response _ RWBinaryOrTextStream on: (String new: 2000).
	response nextPutAll: beginning.
	buf _ String new: 2000.

	[self isConnected | self dataAvailable] 
	whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifTrue: [
	 		Transcript show: 'data was slow'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf 
				startingAt: 1 count: buf size. 
		bytesRead > 0 ifTrue: [  
			response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ].
	Transcript cr; show: 'data byte count: ', response position printString.
	response reset.	"position: 0."
	^ response
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'sma 4/22/2000 17:34'!
getRestOfBuffer: beginning totalLength: length
	"Reel in a string of a fixed length.  Part of it has already been received.  Close the connection after all chars are received.  We do not strip out linefeed chars.  tk 6/16/97 22:32" 
	"if length is nil, read until connection close.  Response is of type text, not binary."

	| buf response bytesRead |
	length ifNil: [^ self getRestOfBuffer: beginning].
	buf _ String new: length.
	response _ RWBinaryOrTextStream on: buf.
	response nextPutAll: beginning.
	buf _ String new: length.

	[(response position < length) & (self isConnected | self dataAvailable)] 
	whileTrue: [
		(self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [
	 		Transcript show: 'data was slow'; cr].
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 
				count: (length - response position). 
		bytesRead > 0 ifTrue: [  
			response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ].
	"Transcript cr; show: 'data byte count: ', response position printString."
	"Transcript cr; show: ((self isConnected) ifTrue: ['Over length by: ', bytesRead printString] 
		ifFalse: ['Socket closed'])."
	response position < length ifTrue: [^ 'server aborted early'].
	response reset.	"position: 0."
	^ response! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/13/1998 00:33'!
header: headerText
	"set the headers.  Then getHeader: can be used"

	"divide into basic lines"
	| lines foldedLines i statusLine |
	lines _ headerText findTokens: (String with: Character cr  with: Character linefeed).
	statusLine _ lines first.
	lines _ lines copyFrom: 2 to: lines size.

	"parse the status (pretty trivial right now)"
	responseCode _ (statusLine findTokens: ' ') second.

	"fold lines that start with spaces into the previous line"
	foldedLines _ OrderedCollection new.
	lines do: [ :line |
		line first isSeparator ifTrue: [
			foldedLines at: foldedLines size  put: (foldedLines last, line) ]
		ifFalse: [ foldedLines add: line ] ].

	"make a dictionary mapping headers to header contents"
	headers _ Dictionary new.
	foldedLines do: [ :line |
		i _ line indexOf: $:.
		i > 0 ifTrue: [
			headers 
			at: (line copyFrom: 1 to: i-1) asLowercase 
			put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ]..
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/26/97 18:28'!
redirect
	"See if the header has a 'Location: url CrLf' in it.  If so, return the new URL of this page.  tk 6/24/97 18:03"

	| this |
	1 to: headerTokens size do: [:ii | 
		this _ headerTokens at: ii.
		(this first asLowercase = $l and: [this asLowercase = 'location:']) ifTrue: [
			^ (headerTokens at: ii+1)]].
	^ nil	"not found"
! !

!HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:41'!
responseCode
	^responseCode! !

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

HTTPSocket class
	instanceVariableNames: ''!

!HTTPSocket class methodsFor: 'class initialization' stamp: 'tk 9/21/1998 10:45'!
blabEmail: aRequest
	"Of the form 'From: me@isp.com <crlf>'"
	HTTPBlabEmail _ aRequest! !

!HTTPSocket class methodsFor: 'class initialization' stamp: 'msk 
9/28/1998 15:51'!
initialize
	"HTTPSocket initialize"

	ParamDelimiters _ ' ', CrLf.
	HTTPPort _ 80.
	HTTPProxyServer _ nil.
	HTTPBlabEmail _ ''.  "	'From: tedk@disney.com', CrLf	"
! !


!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 10/4/97 16:11'!
httpFileIn: url
	"Do a regular file-in of a file that is served from a web site.  If the file contains an EToy, then open it.  Might just be code instead.  tk 7/23/97 17:10"
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones.  The server does not have to know about the .sqo extension in order to send your file.  (We do not need a new MIME type and .sqo does not have to be registered with the server.)"
	"	HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy'	 "
	"	HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo'	 "
	"	HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy'	 "

	| doc eToyHolder |
	doc _ self httpGet: url accept: 'application/octet-stream'.
	doc class == String ifTrue: [
			PopUpMenu notify: 'Cannot seem to contact the web site'].
	doc reset.
	eToyHolder _ doc fileInObjectAndCode.

	eToyHolder ifNotNil: [eToyHolder open].
	"Later may want to return it, instead of open it"
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'di 5/6/1998 16:40'!
httpFileInNewChangeSet: url
	"Do a regular file-in of a file that is served from a web site.  Put it into a new changeSet."
	"Notes: To store a file on an HTTP server, use the program 'Fetch'.  After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc.  Use any file extension as long as it is not one of the common ones."
	"	HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs'	 "

	| doc |
	doc _ self httpGet: url accept: 'application/octet-stream'.
	doc class == String ifTrue: [
			PopUpMenu notify: 'Cannot seem to contact the web site'].
	doc reset.
	ChangeSorter newChangesFromStream: doc
				named: (url findTokens: '/') last.! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'jm 11/4/97 08:25'!
httpGet: url
	"Return the exact contents of a web page or other web object. The parsed header is saved.  Use a proxy server if one has been registered.  tk 7/23/97 17:21"
	"	HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html'	 "
	"	HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.apple.com/default.html'	 "
	"	HTTPSocket httpShowPage: 'www.altavista.digital.com/'	 "
	"	HTTPSocket httpShowPage: 'jumbo/tedk/ab.html'	 "

	^ self httpGet: url accept: 'application/octet-stream'
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'ls 9/15/1998 23:57'!
httpGet: url accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'."

	^self httpGet: url  args: nil accept: mimeType! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'jm 9/16/1998 10:31'!
httpGet: url args: args accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'."

	| document |
	document _ self httpGetDocument: url  args: args  accept: mimeType.
	(document isKindOf: String) ifTrue: [
		"strings indicate errors"
		^ document ].

	^ (RWBinaryOrTextStream with: document content) reset
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:25'!
httpGetDocument: url
	"Return the exact contents of a web page or other web object. The parsed header is saved.  Use a proxy server if one has been registered.  tk 7/23/97 17:21"
	"	HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html'	 "
	"	HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html'	 "
	"	HTTPSocket httpShowPage: 'www.apple.com/default.html'	 "
	"	HTTPSocket httpShowPage: 'www.altavista.digital.com/'	 "
	"	HTTPSocket httpShowPage: 'jumbo/tedk/ab.html'	 "

	^ self httpGetDocument: url args: nil accept: 'application/octet-stream' request: ''
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'!
httpGetDocument: url accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	^self httpGetDocument: url args: nil accept: mimeType request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'!
httpGetDocument: url args: args
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'."
	^self httpGetDocument: url args: args accept: 'application/octet-stream' request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 17:48'!
httpGetDocument: url args: args accept: mimeType
	"Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered.  Note: To fetch raw data, you can use the MIME type 'application/octet-stream'."

	^ self httpGetDocument: url args: args accept: mimeType request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'bolot 1/29/2001 19:20'!
httpGetDocument: url args: args accept: mimeType request: requestString
	"Return the exact contents of a web object. Asks for the given MIME 
type. If mimeType is nil, use 'text/html'. An extra requestString may be 
submitted and must end with crlf.  The parsed header is saved. Use a 
proxy server if one has been registered.  tk 7/23/97 17:12"
	"Note: To fetch raw data, you can use the MIME type 
'application/octet-stream'."

	| serverName serverAddr port sock header length bare page list firstData 
aStream index connectToHost connectToPort type newUrl |
	Socket initializeNetwork.
	bare _ (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	bare _ bare copyUpTo: $#.  "remove fragment, if specified"
	serverName _ bare copyUpTo: $/.
	page _ bare copyFrom: serverName size + 1 to: bare size.
	(serverName includes: $:) 
		ifTrue: [ index _ serverName indexOf: $:.
			port _ (serverName copyFrom: index+1 to: serverName size) asNumber.
			serverName _ serverName copyFrom: 1 to: index-1. ]
		ifFalse: [ port _ self defaultPort ].
	page size = 0 ifTrue: [page _ '/'].
	"add arguments"
	args ifNotNil: [page _ page, (self argString: args) ].


	HTTPProxyServer isNil
		ifTrue: [ 
			connectToHost _ serverName.
			connectToPort _ port ]
		ifFalse:  [
			page _ 'http://', serverName, ':', port printString, page.		"put back 
together"
			connectToHost _ HTTPProxyServer.
			connectToPort _ HTTPProxyPort].
	
	self flag: #XXX.  "this doesn't make sense if a user isn't available for 
questioning...  -ls"
	self retry: [serverAddr _ NetNameResolver addressForName: connectToHost 
timeout: 20.
				serverAddr ~~ nil] 
		asking: 'Trouble resolving server name.  Keep trying?'
		ifGiveUp: [Socket deadServer: connectToHost.
				^ 'Could not resolve the server named: ', connectToHost].

3 timesRepeat: [
	sock _ HTTPSocket new.
	sock connectTo: serverAddr port: connectToPort.
	(sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [
		Socket deadServer: connectToHost.  sock destroy.
		^ 'Server ',connectToHost,' is not responding'].
	Transcript cr; cr; show: url; cr.
	sock sendCommand: 'GET ', page, ' HTTP/1.0', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		'User-Agent: Squeak 1.31', CrLf,
		'Host: ', serverName, ':', port printString, CrLf.	"blank line 
automatically added"

	list _ sock getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, 
beginningOfData"
	header _ list at: 1.
	"Transcript show: page; cr; show: header; cr."
	firstData _ list at: 3.
	header isEmpty 
		ifTrue: [aStream _ 'server aborted early']
		ifFalse: [
			"dig out some headers"
			sock header: header.
			length _ sock getHeader: 'content-length'.
			length ifNotNil: [ length _ length asNumber ].
			type _ sock getHeader: 'content-type'.
			sock responseCode first = $3 ifTrue: [
				newUrl _ sock getHeader: 'location'.
				newUrl ifNotNil: [ 
					Transcript show: 'redirecting to ', newUrl; cr.
					sock destroy.
					^self httpGetDocument: newUrl  args: args  accept: mimeType ] ].
			aStream _ sock getRestOfBuffer: firstData totalLength: length.
			sock responseCode = '401' ifTrue: [^ header, aStream contents].
			].
	sock destroy.	"Always OK to destroy!!"
	aStream class ~~ String ifTrue: [
 		^ MIMEDocument contentType: type content: aStream contents url: url].
	aStream = 'server aborted early' ifFalse: [
		]
	].

{'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect.

	^'some other bad thing happened!!'! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'di 4/4/1999 09:57'!
httpGetNoError: url args: args accept: mimeType
	"Return the exact contents of a web file.  Do better error checking.  Asks for the given MIME type.  To fetch raw data, you can use the MIMI type 'application/octet-stream'.  If mimeType is nil, use 'text/html'.  The parsed header is saved. Use a proxy server if one has been registered."

"Edited to remove a lineFeed from the source 4/4/99 - di"

	| document data |
	document _ self httpGetDocument: url  args: args  accept: mimeType.
	(document isKindOf: String) ifTrue: [
		"strings indicate errors"
		^ document ].
	data _ document content.
	(data beginsWith: '<HTML><HEAD>' , (String with: Character linefeed) , '<TITLE>4')
		ifTrue: ["an error message  404 File not found"
				^ data copyFrom: 21 to: data size-16].	

	^ (RWBinaryOrTextStream with: data) reset
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 10/15/97 12:07'!
httpGif: url
	"Fetch the given URL, parse it using the GIF reader, and return the resulting Form."
	"	HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif'	 "
	"	HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif'	 "

	| doc ggg |
	doc _ self httpGet: url accept: 'image/gif'.
	doc class == String ifTrue: [
		self inform: 'The server with that GIF is not responding'.
		^ ColorForm extent: 20@20 depth: 8].
	doc binary; reset.
	(ggg _ Smalltalk gifReaderClass new) setStream: doc.
	^ ggg nextImage.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tao 10/26/97 23:21'!
httpJpeg: url
	"Fetch the given URL, parse it using the JPEG reader, and return the resulting Form."

	| doc ggg |
	doc _ self httpGet: url.
	doc binary; reset.
	(ggg _ Smalltalk jpegReaderClass new) setStream: doc.
	^ ggg nextImage.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'!
httpPost: url  args: argsDict accept: mimeType 
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"
	| document |
	document _ self httpPostDocument: url  args: argsDict  accept: mimeType  request: ''.
	(document isKindOf: String) ifTrue: [ 
		"strings indicate errors"
		^document ].

	
	^RWBinaryOrTextStream with: document content! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'!
httpPostDocument: url  args: argsDict
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	^self httpPostDocument: url args: argsDict accept: 'application/octet-stream' request: ''! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 20:16'!
httpPostDocument: url  args: argsDict accept: mimeType 
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	^ self httpPostDocument: url args: argsDict accept: mimeType request: ''
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'mir 7/26/2000 13:10'!
httpPostDocument: url  args: argsDict accept: mimeType request: requestString
	"like httpGET, except it does a POST instead of a GET.  POST allows data to be uploaded"

	| s header length page list firstData aStream argsStream first type newUrl httpUrl |
	Socket initializeNetwork.

	httpUrl _ Url absoluteFromText: url.
	page _ httpUrl toText.
	"add arguments"
	argsDict ifNotNil: [page _ page, (self argString: argsDict) ].

	"encode the arguments dictionary"
	argsStream _ WriteStream on: String new.
	first _ true.
	argsDict associationsDo: [ :assoc |
		assoc value do: [ :value |
			first ifTrue: [ first _ false ] ifFalse: [ argsStream nextPut: $& ].
			argsStream nextPutAll: assoc key encodeForHTTP.
			argsStream nextPut: $=.
			argsStream nextPutAll: value encodeForHTTP.
	] ].

	s _ HTTPSocket new. 
	s _ self initHTTPSocket: httpUrl wait: (self deadlineSecs: 30) ifError: [:errorString | ^errorString].
	Transcript cr; show: url; cr.
	s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		'User-Agent: Squeak 1.31', CrLf,
		'Content-type: application/x-www-form-urlencoded', CrLf,
		'Content-length: ', argsStream contents size printString, CrLf,
		'Host: ', httpUrl authority, CrLf.  "blank line automatically added"

	s sendCommand: argsStream contents.

	"get the header of the reply"
	list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR).	"list = header, CrLf, CrLf, beginningOfData"
	header _ list at: 1.
	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
	firstData _ list at: 3.

	"dig out some headers"
	s header: header.
	length _ s getHeader: 'content-length'.
	length ifNotNil: [ length _ length asNumber ].
	type _ s getHeader: 'content-type'.
	s responseCode first = $3 ifTrue: [
		newUrl _ s getHeader: 'location'.
		newUrl ifNotNil: [
			Transcript show: 'Response: ' , s responseCode.
			Transcript show: ' redirecting to: ', newUrl; cr.
			s destroy.
			"^self httpPostDocument: newUrl  args: argsDict  accept: mimeType"
			^self httpGetDocument: newUrl accept: mimeType ] ].

	aStream _ s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'bolot 1/29/2001 19:35'!
httpPostMultipart: url args: argsDict accept: mimeType request: requestString
	" do multipart/form-data encoding rather than x-www-urlencoded "
	" by Bolot Kerimbaev, 1998 "
	" this version is a memory hog: puts the whole file in memory "
	"bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867"

	| serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue |
	Socket initializeNetwork.

	"parse url"
	bare _ (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	serverName _ bare copyUpTo: $/.
	specifiedServer _ serverName.
	(serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [
		port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber.
		serverName _ serverName copyUpTo: $:.
	].

	page _ bare copyFrom: (bare indexOf: $/) to: bare size.
	page size = 0 ifTrue: [page _ '/'].
	HTTPProxyServer ifNotNil: [ 
		page _ 'http://', serverName, ':', port printString, page.		"put back together"
		serverName _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'.
	"encode the arguments dictionary"
	argsStream _ WriteStream on: String new.
	argsDict associationsDo: [:assoc |
		assoc value do: [ :value |
		"print the boundary"
		argsStream nextPutAll: '--', mimeBorder, CrLf.
		" check if it's a non-text field "
		argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'.
		(value isKindOf: MIMEDocument)
			ifFalse: [fieldValue _ value]
			ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', CrLf, 'Content-Type: ', value contentType.
				fieldValue _ (value content
					ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile]
					ifNotNil: [value content]) asString].
" Transcript show: 'field=', key, '; value=', fieldValue; cr. "
		argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf.
	]].
	argsStream nextPutAll: '--', mimeBorder, '--'.

  	"make the request"	
	self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20.
				serverAddr ~~ nil] 
		asking: 'Trouble resolving server name.  Keep trying?'
		ifGiveUp: [^ 'Could not resolve the server named: ', serverName].


	s _ HTTPSocket new.
	s connectTo: serverAddr port: port.
	s waitForConnectionUntil: self standardDeadline.
	Transcript cr; show: serverName, ':', port asString; cr.
	s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		'User-Agent: Squeak 1.31', CrLf,
		'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf,
		'Content-length: ', argsStream contents size printString, CrLf,
		'Host: ', specifiedServer, CrLf.  "blank line automatically added"

	s sendCommand: argsStream contents.

	"get the header of the reply"
	list _ s getResponseUpTo: CrLf, CrLf.	"list = header, CrLf, CrLf, beginningOfData"
	header _ list at: 1.
	"Transcript show: page; cr; show: argsStream contents; cr; show: header; cr."
	firstData _ list at: 3.

	"dig out some headers"
	s header: header.
	length _ s getHeader: 'content-length'.
	length ifNotNil: [ length _ length asNumber ].
	type _ s getHeader: 'content-type'.
	s responseCode first = $3 ifTrue: [
		"redirected - don't re-post automatically"
		"for now, just do a GET, without discriminating between 301/302 codes"
		newUrl _ s getHeader: 'location'.
		newUrl ifNotNil: [
			(newUrl beginsWith: 'http://')
				ifFalse: [
					(newUrl beginsWith: '/')
						ifTrue: [newUrl _ (bare copyUpTo: $/), newUrl]
						ifFalse: [newUrl _ url, newUrl. self flag: #todo
							"should do a relative URL"]
				].
			Transcript show: 'redirecting to: ', newUrl; cr.
			s destroy.
			^self httpGetDocument: newUrl
			"for some codes, may do:
			^self httpPostMultipart: newUrl args: argsDict  accept: mimeType request: requestString"] ].

	aStream _ s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'RAA 10/16/2000 09:59'!
httpPostMultipartBOB: url args: argsDict accept: mimeType request: requestString

	| serverName serverAddr s header length bare page list firstData aStream port specifiedServer type mimeBorder contentsData |

	Socket initializeNetwork.

	"parse url"
	bare _ (url asLowercase beginsWith: 'http://') 
		ifTrue: [url copyFrom: 8 to: url size]
		ifFalse: [url].
	serverName _ bare copyUpTo: $/.
	specifiedServer _ serverName.
	(serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [
		port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber.
		serverName _ serverName copyUpTo: $:.
	].

	page _ bare copyFrom: (bare indexOf: $/) to: bare size.
	page size = 0 ifTrue: [page _ '/'].
	HTTPProxyServer ifNotNil: [ 
		page _ 'http://', serverName, ':', port printString, page.		"put back together"
		serverName _ HTTPProxyServer.
		port _ HTTPProxyPort].

	mimeBorder _ '---------SuperSwiki',Time millisecondClockValue printString,'-----'.
	contentsData _ String streamContents: [ :strm |
		strm nextPutAll: mimeBorder, CrLf.
		argsDict associationsDo: [:assoc |
			assoc value do: [ :value |
				strm
					nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"';
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: value;
					nextPutAll: CrLf;
					nextPutAll: CrLf;
					nextPutAll: mimeBorder;
					nextPutAll: CrLf.
			]
		].
	].

  	"make the request"	
	self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20.
				serverAddr ~~ nil] 
		asking: 'Trouble resolving server name.  Keep trying?'
		ifGiveUp: [^ 'Could not resolve the server named: ', serverName].

	s _ HTTPSocket new.
	s connectTo: serverAddr port: port.
	s waitForConnectionUntil: self standardDeadline.
	s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, 
		(mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']),
		'ACCEPT: text/html', CrLf,	"Always accept plain text"
		HTTPBlabEmail,	"may be empty"
		requestString,	"extra user request. Authorization"
		'User-Agent: Squeak 2.9', CrLf,
		'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf,
		'Content-length: ', contentsData size printString, CrLf,
		'Host: ', specifiedServer, CrLf.  "blank line automatically added"

	s sendCommand: contentsData.

	list _ s getResponseUpTo: CrLf, CrLf.	"list = header, CrLf, CrLf, beginningOfData"
	header _ list at: 1.
	firstData _ list at: 3.

	s header: header.
	length _ s getHeader: 'content-length'.
	length ifNotNil: [ length _ length asNumber ].
	type _ s getHeader: 'content-type'.
	aStream _ s getRestOfBuffer: firstData totalLength: length.
	s responseCode = '401' ifTrue: [^ header, aStream contents].
	s destroy.	"Always OK to destroy!!"

	^ MIMEDocument contentType: type  content: aStream contents url: url! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:00'!
httpShowChunk: url
	"From a Swiki server, get a text chunk in the changes file.  Show its text in a window with style.  Vertical bar separates class and selector.  BE SURE TO USE ; instead of : in selectors!!"
	"	HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Socket|Comment'	 "
	"	HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Point|class|x;y;'	"

	| doc text |
	doc _ (self httpGet: url accept: 'application/octet-stream').
"	doc size = 0 ifTrue: [doc _ 'The server does not seem to be responding']."
	doc class == String ifTrue: [text _ doc] ifFalse: [text _ doc nextChunkText].
	(StringHolder new contents: text) openLabel: url.
! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:50'!
httpShowGif: url
	"Display the picture retrieved from the given URL, which is assumed to be a GIF file.
	See examples in httpGif:."

	self showImage: (self httpGif: url) named: (url findTokens: '/') last! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:51'!
httpShowJpeg: url
	"Display the picture retrieved from the given URL, which is assumed to be a JPEG file.
	See examples in httpGif:."

	self showImage: (self httpJpeg: url) named: (url findTokens: '/') last! !

!HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:01'!
httpShowPage: url
	"Display the exact contents of the given URL as text. See examples in httpGet:"

	| doc |
	doc _ (self httpGet: url accept: 'application/octet-stream') contents.
	doc size = 0 ifTrue: [^ self error: 'Document could not be fetched'].
	(StringHolder new contents: doc) openLabel: url.
! !


!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 16:08'!
addProxyException: domainName
	"Add a (partial, wildcard) domain name to the list of proxy exceptions"
	"HTTPSocket addProxyException: '*.online.disney.com'"

	self httpProxyExceptions add: domainName! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'!
httpProxyExceptions
	HTTPProxyExceptions ifNil: [HTTPProxyExceptions _ OrderedCollection new].
	^HTTPProxyExceptions! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'jm 9/15/97 12:06'!
proxyTestingComment
	"Test Kevin's SmartCache on this machine"
	"	HTTPSocket useProxyServerNamed: '127.0.0.1' port: 8080.
		HTTPSocket httpShowPage: 'http://www.disneyblast.com/default.html'.
		HTTPSocket stopUsingProxyServer.	"

	"Test getting to outside world from DOL"
	"	HTTPSocket useProxyServerNamed: 'web-proxy.online.disney.com' port: 8080.
		HTTPSocket httpShowPage: 'http://www.apple.com/default.html'.
		HTTPSocket stopUsingProxyServer.	"

	"Test Windows Machine in our cubicle at DOL"
	"	HTTPSocket useProxyServerNamed: '206.18.67.150' port: 8080.
		HTTPSocket httpShowPage: 'http://kids.online.disney.com/~kevin/squeak/k_t.morph'.
		HTTPSocket stopUsingProxyServer.	"

	"	HTTPSocket httpShowPage: 'kids.online.disney.com/'	"
	"	HTTPSocket httpShowGif: 'kids.online.disney.com/~kevin/images/dlogo.gif'	"
! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 7/30/1999 15:03'!
removeProxyException: domainName
	"Remove a (partial, wildcard) domain name from the list of proxy exceptions"

	self httpProxyExceptions remove: domainName ifAbsent: []! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'ls 9/17/1998 07:18'!
stopUsingProxyServer
	"Stop directing HTTP request through a proxy server."

	HTTPProxyServer _ nil.
	HTTPProxyPort _ 80.
! !

!HTTPSocket class methodsFor: 'proxy settings' stamp: 'msk 9/28/1998 15:52'!
useProxyServerNamed: proxyServerName port: portNum
	"Direct all HTTP requests to the HTTP proxy server with the given name and port number."

	proxyServerName ifNil: [  "clear proxy settings"
		HTTPProxyServer _ nil.
		HTTPProxyPort _ 80.
		^ self].

	proxyServerName class == String
		ifFalse: [self error: 'Server name must be a String or nil'].
	HTTPProxyServer _ proxyServerName.

	HTTPProxyPort _ portNum.
	HTTPProxyPort class == String ifTrue: [HTTPPort _ portNum asNumber].
	HTTPProxyPort ifNil: [HTTPProxyPort _ self defaultPort].! !


!HTTPSocket class methodsFor: 'utilities' stamp: 'tk 7/16/1999 16:46'!
argString: args
	"Return the args in a long string, as encoded in a url"

	| argsString first |
	args class == String ifTrue: ["sent in as a string, not a dictionary"
		^ (args first = $? ifTrue: [''] ifFalse: ['?']), args].
	argsString _ WriteStream on: String new.
	argsString nextPut: $?.
	first _ true.
	args associationsDo: [ :assoc |
		assoc value do: [ :value |
			first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ].
			argsString nextPutAll: assoc key encodeForHTTP.
			argsString nextPut: $=.
			argsString nextPutAll: value encodeForHTTP. ] ].
	^ argsString contents
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'mir 7/28/1999 15:52'!
argStringUnencoded: args
	"Return the args in a long string, as encoded in a url"

	| argsString first |
	args class == String ifTrue: ["sent in as a string, not a dictionary"
		^ (args first = $? ifTrue: [''] ifFalse: ['?']), args].
	argsString _ WriteStream on: String new.
	argsString nextPut: $?.
	first _ true.
	args associationsDo: [ :assoc |
		assoc value do: [ :value |
			first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ].
			argsString nextPutAll: assoc key.
			argsString nextPut: $=.
			argsString nextPutAll: value. ] ].
	^ argsString contents
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'mir 7/30/1999 15:46'!
initHTTPSocket: httpUrl ifError: aBlock
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	^self initHTTPSocket: httpUrl wait: self standardDeadline ifError: aBlock! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'mir 7/30/1999 15:43'!
initHTTPSocket: httpUrl wait: timeout ifError: aBlock
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	| serverName port serverAddr s |
	Socket initializeNetwork.

	serverName _ httpUrl authority.
	port _ httpUrl port ifNil: [self defaultPort].

	(self shouldUseProxy: serverName) ifTrue: [ 
		serverName _ HTTPProxyServer.
		port _ HTTPProxyPort].

  	"make the request"	
	self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20.
				serverAddr ~~ nil] 
		asking: 'Trouble resolving server name.  Keep trying?'
		ifGiveUp: [aBlock value: 'Error: Could not resolve the server named: ', serverName].

	s _ HTTPSocket new.
	s connectTo: serverAddr port: port.
	(s waitForConnectionUntil: timeout) ifFalse: [
		Socket deadServer: httpUrl authority.
		s destroy.
		^aBlock value: 'Error: Server ',httpUrl authority,' is not responding'].
	^s
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'jm 9/15/97 11:10'!
retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock
	"Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false."

	| response |
	[tryBlock value] whileFalse: [
		response _ (PopUpMenu labels: 'Retry\Give Up' withCRs)
			startUpWithCaption: troubleString.
		response = 2 ifTrue: [abortActionBlock value. ^ false]].
	^ true
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'mir 7/30/1999 13:33'!
shouldUseProxy: serverName
	"Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request."

	HTTPProxyServer ifNotNil: [
		self httpProxyExceptions
			detect: [:domainName | domainName match: serverName]
			ifNone: [^true]].
	^false
! !

!HTTPSocket class methodsFor: 'utilities' stamp: 'sma 4/30/2000 10:39'!
showImage: image named: imageName
	Smalltalk isMorphic
		ifTrue: [HandMorph attach: (SketchMorph withForm: image)]
		ifFalse: [FormView open: image named: imageName]! !


!HTTPSocket class methodsFor: 'magic numbers' stamp: 'ls 9/17/1998 07:17'!
defaultPort
	"default port to connect on"
	^80! !
Morph subclass: #HaloMorph
	instanceVariableNames: 'target innerTarget positionOffset angleOffset minExtent growingOrRotating directionArrowAnchor haloBox simpleMode '
	classVariableNames: 'HandleSize '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!HaloMorph commentStamp: '<historical>' prior: 0!
This morph provides a halo of handles for its target morph. Dragging, duplicating, rotating, and resizing to be done by mousing down on the appropriate handle. There are also handles for help and for a menu of infrequently used operations.!


!HaloMorph methodsFor: 'initialization' stamp: 'ar 9/28/2000 17:55'!
delete
	| label |
	target ifNotNil:[target hasHalo: false].
	(label _ self findA: NameStringInHalo) ifNotNil:
		[label hasFocus ifTrue:
			[label lostFocusWithoutAccepting]].
	super delete! !

!HaloMorph methodsFor: 'initialization' stamp: 'sw 1/28/2000 09:57'!
initialize

	super initialize.
	self color: (Color r: 0.6 g: 0.8 b: 1.0).
	growingOrRotating _ false.
	simpleMode _ Preferences  simpleHalosInForce
! !


!HaloMorph methodsFor: 'accessing' stamp: 'sw 1/26/2000 15:36'!
haloBox: aBox
	haloBox _ aBox! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/22/1998 16:28'!
innerTarget

	^ innerTarget
! !

!HaloMorph methodsFor: 'accessing' stamp: 'di 9/26/2000 16:37'!
setTarget: aMorph
	"Private!! Set the target without adding handles."

	target _ aMorph topRendererOrSelf.
	innerTarget _ target renderedMorph.
	innerTarget wantsDirectionHandles
		ifTrue: [self showDirectionHandles: true addHandles: false].

! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 7/16/97 06:51'!
target

	^ target
! !

!HaloMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 15:42'!
target: aMorph

	self setTarget: aMorph.
	target ifNotNil: [self addHandles].
! !


!HaloMorph methodsFor: 'drawing' stamp: 'di 12/11/2000 13:54'!
drawOn: aCanvas
	"Draw this morph only if it has no target."

	target == nil ifTrue: [^ super drawOn: aCanvas].
	Preferences showBoundsInHalo ifTrue:
		[aCanvas frameAndFillRectangle: target boundsInWorld
				fillColor: Color transparent
				borderWidth: 1
				borderColor: Color blue]! !


!HaloMorph methodsFor: 'geometry' stamp: 'di 9/28/2000 08:15'!
changed
	"Quicker to invalidate handles individually if target is large (especially the world)"

	self extent > (200@200)
		ifTrue: [self submorphsDo: [:m | m changed]]
		ifFalse: [super changed].
! !

!HaloMorph methodsFor: 'geometry' stamp: 'jm 7/16/97 22:42'!
containsPoint: aPoint
	"This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner."

	target == nil
		ifTrue: [^ super containsPoint: aPoint]
		ifFalse: [^ false].
! !

!HaloMorph methodsFor: 'geometry' stamp: 'di 9/26/2000 21:03'!
position: pos
	"Halos display imprefectly if their coordinates are non-integral
		-- especially the direction handles."

	^ super position: pos asIntegerPoint! !


!HaloMorph methodsFor: 'events' stamp: 'ar 10/25/2000 15:10'!
blueButtonDown: event
	"Transfer the halo to the next likely recipient"
	target ifNil:[^self delete].
	event hand obtainHalo: self.
	positionOffset _ event position - (target point: target position in: owner).
	"wait for drags or transfer"
	event hand 
		waitForClicksOrDrag: self 
		event: event
		selectors: { #transferHalo:. nil. #dragTarget:. }
		threshold: 5.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 9/15/2000 16:54'!
containsPoint: aPoint event: anEvent
	"Blue buttons are handled by the halo"
	(anEvent isMouse and:[anEvent isMouseDown and:[anEvent blueButtonPressed]])
		ifFalse:[^super containsPoint: aPoint event: anEvent].
	^bounds containsPoint: anEvent position! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/25/2000 15:13'!
dragTarget: event
	"Begin dragging the target"
	| thePoint |
	thePoint _ target point: event position - positionOffset from: owner.
	target setConstrainedPositionFrom: thePoint.
	event hand newMouseFocus: self.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/12/2000 17:12'!
handleListenEvent: anEvent
	"We're listen for possible drop events here to add back those handles after a dup/grab operation"
	(anEvent isMouse and:[anEvent isMove not]) ifFalse:[^self]. "not interested"
	anEvent hand removeMouseListener: self. "done listening"
	self addHandles. "and get those handles back"! !

!HaloMorph methodsFor: 'events' stamp: 'ar 9/15/2000 16:42'!
handlerForBlueButtonDown: anEvent
	"Blue button was clicked within the receiver"
	^self! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/25/2000 15:12'!
mouseMove: evt
	"Drag our target around"
	| thePoint |
	thePoint _ target point: (evt position - positionOffset) from: owner.
	target setConstrainedPositionFrom: thePoint.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/25/2000 15:11'!
popUpFor: aMorph event: evt
	"This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame."
	| hand anEvent |
	self flag: #workAround. "We should really have some event/hand here..."
	evt isNil
		ifTrue:[	hand _ aMorph world activeHand.
				hand ifNil:[hand _ aMorph world primaryHand].
				anEvent _ hand lastEvent transformedBy: (aMorph transformedFrom: nil)]
		 ifFalse:[hand _ evt hand.
				anEvent _ evt].
	self target: aMorph.
	hand halo: self.
	hand world addMorphFront: self.
	positionOffset _ anEvent position - (aMorph point: aMorph position in: owner).
	self startStepping.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/25/2000 15:11'!
popUpFor: aMorph hand: aHand
	"Programatically pop up a halo for a given hand."
	self target: aMorph.
	aHand halo: self.
	aHand world addMorphFront: self.
	positionOffset _ aHand position - (aMorph point: aMorph position in: owner).
	self startStepping.! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/10/2000 22:00'!
rejectsEvent: anEvent
	"Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
	(super rejectsEvent: anEvent) ifTrue:[^true].
	anEvent isDropEvent ifTrue:[^true]. "never attempt to drop on halos"
	^false! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/4/2000 19:26'!
staysUpWhenMouseIsDownIn: aMorph
	^ ((aMorph == target) or: [aMorph hasOwner: self])! !

!HaloMorph methodsFor: 'events' stamp: 'ar 10/10/2000 19:09'!
transferHalo: event
	"Transfer the halo to the next likely recipient"
	target ifNil:[^self delete].
	target transferHalo: (event transformedBy: (target transformedFrom: self)) from: target.! !

!HaloMorph methodsFor: 'events' stamp: 'sw 5/21/1998 15:41'!
wantsKeyboardFocusFor: aSubmorph
	"to allow the name to be edited in the halo in the old tty way; when we morphic-text-ize the name editing, presumably this method should be removed"
	^ true! !


!HaloMorph methodsFor: 'stepping' stamp: 'RAA 6/19/2000 12:58'!
localHaloBoundsFor: aMorph

	"aMorph may be in the hand and perhaps not in our world"

	| r |

	r _ aMorph worldBoundsForHalo truncated.
	aMorph world = self world ifTrue: [^r].
	^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated! !

!HaloMorph methodsFor: 'stepping' stamp: 'ar 10/10/2000 15:17'!
step

	| newBounds |
	target ifNil: [^ self].
	target isWorldMorph
		ifTrue: [newBounds _ target bounds]
		ifFalse: [newBounds _ self localHaloBoundsFor: target renderedMorph].
	newBounds = self bounds ifTrue: [^ self].
	newBounds extent = self bounds extent ifTrue:[^self position: newBounds origin].
	growingOrRotating ifFalse: [  "adjust halo bounds if appropriate"
		submorphs size > 1
			ifTrue: [self addHandles].  "recreates full set with new bounds"
		self bounds: newBounds].
! !

!HaloMorph methodsFor: 'stepping' stamp: 'jm 7/16/97 06:54'!
stepTime

	^ 0  "every cycle"
! !


!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:39'!
addCircleHandles
	| box |
	simpleMode _ false.
	target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].

	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	box _ self basicBox.

	target addHandlesTo: self box: box.

	self addName.
	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/25/2000 17:48'!
addDirectionHandles

	| centerHandle d w directionShaft patch patchColor crossHairColor |
	self showingDirectionHandles ifFalse: [^ self].

	directionArrowAnchor _ target referencePositionInWorld rounded.
	patch _ target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3@3).
	patchColor _ patch colorAt: 1@1.

	(directionShaft _ LineMorph newSticky makeForwardArrow)
		borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor).
	self positionDirectionShaft: directionShaft.
	self addMorphFront: directionShaft.
	directionShaft setCenteredBalloonText: 'Set forward direction';
		on: #mouseDown send: #doDirection:with: to: self;
		on: #mouseMove send: #trackDirectionArrow:with: to: self;
		on: #mouseUp send: #setDirection:with: to: self.

	d _ 15.  "diameter"  w _ 3.  "borderWidth"
	crossHairColor _ Color red orColorUnlike: patchColor.
	(centerHandle _ EllipseMorph newBounds: (0@0 extent: d@d) color: Color transparent)
			borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor);
			addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1);
			addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1);
			align: centerHandle bounds center with: directionArrowAnchor.
	self addMorph: centerHandle.
	centerHandle setCenteredBalloonText: 'Set rotation center';
			on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self;
			on: #mouseMove send: #trackCenterOfRotation:with: to: self;
			on: #mouseUp send: #setCenterOfRotation:with: to: self
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/29/1999 15:31'!
addFullHandles
	"Later, obey a preference to choose between circle-iconic and solid-circles"
	self addCircleHandles! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/6/1999 20:12'!
addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient
	"Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle |
	handle _ self addGraphicalHandleFrom: formKey at: aPoint.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle).
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/6/1999 20:29'!
addGraphicalHandleFrom: formKey at: aPoint
	"Add the supplied form as a graphical handle centered at the given point.  Return the handle."
	| handle aForm |
	aForm _ (ScriptingSystem formAtKey: formKey) ifNil: [ScriptingSystem formAtKey: #SolidMenu].
	handle _ ImageMorph new image: aForm; bounds: (Rectangle center: aPoint extent: aForm extent).
	self addMorph: handle.
	handle on: #mouseUp send: #endInteraction to: self.
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 16:30'!
addHandle: handleSpec on: eventName send: selector to: recipient
	"Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle aPoint iconName colorToUse |
	aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement.
	handle _ EllipseMorph
		newBounds: (Rectangle center: aPoint extent: HandleSize asPoint)
		color: (colorToUse _ Color colorFrom: handleSpec color).
	self addMorph: handle.
	(iconName _ handleSpec iconSymbol) ifNotNil:
		[ | form |
		form _ ScriptingSystem formAtKey: iconName.
		form ifNotNil:
			[handle addMorphCentered: (ImageMorph new
				image: form; 
				color: colorToUse makeForegroundColor;
				lock)]].
	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle).
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 16:29'!
addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient
	"Add a handle centered at the given point with the given color, and set it up to respond to the given event by sending the given selector to the given recipient.  Return the handle."
	| handle |
	handle _ EllipseMorph
		newBounds: (Rectangle center: aPoint extent: self handleSize asPoint)
		color: aColor.
	self addMorph: handle.
	iconName ifNotNil:
		[ | form |
		form _ ScriptingSystem formAtKey: iconName.
		form ifNotNil:
			[handle addMorphCentered: (ImageMorph new
				image: form; 
				color: aColor makeForegroundColor;
				lock)]].
	handle on: #mouseUp send: #endInteraction to: self.
	handle on: eventName send: selector to: recipient.
	handle setBalloonText: (target balloonHelpTextForHandle: handle).
	^ handle
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/29/2000 18:36'!
addHandleAt: aPoint color: aColor on: eventName send: selector to: recipient
	^ self addHandleAt: aPoint color: aColor icon: nil on: eventName send: selector to: recipient
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/28/2000 09:57'!
addHandles
	simpleMode == true
		ifTrue:
			[self addSimpleHandles]
		ifFalse:
			[self addCircleHandles]
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/4/2000 16:27'!
addHandlesForWorldHalos
	"Add handles for world halos, like the man said"

	| box w |
	w _ self world ifNil:[target world].
	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target bounds.
	box _ w bounds insetBy: 9.
	target addWorldHandlesTo: self box: box.

	Preferences uniqueNamesInHalos ifTrue:
		[innerTarget assureExternalName].
	self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName.
	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 8/16/2000 17:41'!
addName
	"Add a name readout at the bottom of the halo."

	Preferences uniqueNamesInHalos ifTrue:
		[target assureExternalName].

	self addNameBeneath: self basicBox string: target externalName
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/26/2000 11:40'!
addNameBeneath: outerRectangle string: aString
	"Add a name display centered beneath the bottom of the outer rectangle. Return the handle."

	| nameMorph namePosition w |
	w _ self world ifNil:[target world].
	nameMorph _ NameStringInHalo contents: aString.
	nameMorph color: Color magenta.
	nameMorph useStringFormat; target: innerTarget; putSelector: #tryToRenameTo:.
	namePosition _ outerRectangle bottomCenter -
		((nameMorph width // 2) @ (self handleSize negated // 2 - 1)).
	nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2).
	nameMorph balloonTextSelector: #objectNameInHalo.
	self addMorph: nameMorph.
	^ nameMorph! !

!HaloMorph methodsFor: 'private' stamp: 'sw 4/27/2000 13:40'!
addSimpleHandles
	target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
	self removeAllMorphs.  "remove old handles, if any"
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	self innerTarget addSimpleHandlesTo: self box: self basicBoxForSimpleHalos

! !

!HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 15:39'!
addSimpleHandlesForWorldHalos
	"Nothing special at present here -- just use the regular handles.  Cannot rotate or resize world"

	self addHandlesForWorldHalos
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/25/2000 17:49'!
addSimpleHandlesTo: aHaloMorph box: aBox
	| aHandle |
	simpleMode _ true.

	target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos].

	self removeAllMorphs.  "remove old handles, if any"
	
	self bounds: target renderedMorph worldBoundsForHalo.  "update my size"
	
	self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles'
		on: #mouseDown send: #addFullHandles to: self.

	aHandle _ self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self.
	aHandle on: #mouseMove send: #doRot:with: to: self.

	target isFlexMorph
		ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight  on: #mouseDown send: #startScale:with: to: self)
				on: #mouseMove send: #doScale:with: to: self]
		ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self)
				on: #mouseMove send: #doGrow:with: to: self].

	(innerTarget isMemberOf: SketchMorph) ifTrue:  "isMemberOf: used advisedly here"
		[self addSimpleSketchMorphHandlesInBox: aBox].

	growingOrRotating _ false.
	self layoutChanged.
	self changed.
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 17:37'!
addSimpleSketchMorphHandlesInBox: box

	self addGraphicalHandle: #PaintTab at: box bottomCenter on: #mouseDown send: #editDrawing to: self innerTarget.

	self addDirectionHandles! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'!
basicBox
	| aBox minSide anExtent w |
	minSide _ 4 * self handleSize.
	anExtent _ ((self width + self handleSize + 8) max: minSide) @
				((self height + self handleSize + 8) max: minSide).
	aBox _ Rectangle center: self center extent: anExtent.
	w _ self world ifNil:[target outermostWorldMorph].
	^ w
		ifNil:
			[aBox]
		ifNotNil:
			[aBox intersect: (w viewBox insetBy: 8@8)]
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/7/2000 23:36'!
basicBoxForSimpleHalos
	| w |
	w _ self world ifNil:[target outermostWorldMorph].
	^ (target topRendererOrSelf worldBoundsForHalo expandBy: self handleAllowanceForIconicHalos)
			intersect: (w bounds insetBy: 8@8)
! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:16'!
directionArrowLength
	^ 25! !

!HaloMorph methodsFor: 'private' stamp: 'sw 6/17/1999 16:58'!
dismiss
	"Remove my target from the world."

	| w |
	self isThisEverCalled. "Seemingly no longer enfranchised"
	w _ self world.
	w ifNotNil: [w stopStepping: target].
	self delete.
	target dismissViaHalo! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doDebug: evt with: menuHandle
	"Ask hand to invoke the a debugging menu for my inner target.  If shift key is down, immediately put up an inspector on the inner target"

	| menu |
	evt hand obtainHalo: self.
	self removeAllHandlesBut: nil.  "remove all handles"
	self world displayWorld.
	evt shiftPressed ifTrue: 
		[self delete.
		^ innerTarget inspectInMorphic: evt].

	menu _ innerTarget buildDebugMenu: evt hand.
	menu addTitle: innerTarget externalName.
	menu popUpEvent: evt in: self world.
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doDirection: anEvent with: directionHandle
	anEvent hand obtainHalo: self.
	self removeAllHandlesBut: directionHandle! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/25/2000 15:14'!
doDrag: evt with: dragHandle
	| thePoint |
	evt hand obtainHalo: self.
	thePoint _ target point: evt position - positionOffset from: owner.
	target setConstrainedPositionFrom:(target griddedPoint: thePoint).
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 11/4/2000 17:53'!
doDup: evt with: dupHandle
	"Ask hand to duplicate my target."
	evt hand obtainHalo: self.
	(target isKindOf: SelectionMorph) ifTrue:
		[^ target doDup: evt fromHalo: self handle: dupHandle].
	self setTarget: (target duplicateMorph: evt).
	self removeAllHandlesBut: dupHandle.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'private' stamp: 'ar 11/4/2000 17:53'!
doGrab: evt with: grabHandle
	"Ask hand to grab my target."
	evt hand obtainHalo: self.
	self removeAllHandlesBut: grabHandle.  "remove all other handles"
	evt hand grabMorph: target.
	self step. "update position if necessary"
	evt hand addMouseListener: self. "Listen for the drop"! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/31/2000 19:14'!
doGrow: evt with: growHandle
	"Called while the mouse is down in the grow handle"

	| newExtent extentToUse |
	evt hand obtainHalo: self.
	newExtent _ (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
								- target topLeft.
	evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint].
	target renderedMorph extent: (extentToUse _ newExtent).
	growHandle position: evt cursorPoint - (growHandle extent // 2).
	self layoutChanged.
	(self valueOfProperty: #commandInProgress) doIfNotNil:  
		[:cmd | "Update the final extent"
		cmd redoTarget: target selector: #extent: argument: extentToUse]
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 11/6/2000 14:08'!
doMenu: evt with: menuHandle
	"Ask hand to invoke the halo menu for my inner target."

	| menu |
	evt hand obtainHalo: self.
	self removeAllHandlesBut: nil.  "remove all handles"
	self world displayWorld.
	menu _ innerTarget buildHandleMenu: evt hand.
	innerTarget mightEntertainDirectionHandles ifTrue:
		[self showingDirectionHandles
			ifTrue: [menu add: 'hide direction handles' target: self selector: #showDirectionHandles: argument: false]
			ifFalse: [menu add: 'show direction handles' target: self selector: #showDirectionHandles: argument: true]].
	innerTarget addTitleForHaloMenu: menu.
	menu popUpEvent: evt in: self world.
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doRecolor: evt with: aHandle
	"Change the color of the target, if appropriate"
	evt hand obtainHalo: self.
	(aHandle containsPoint: evt cursorPoint)
		ifFalse:  "only do it if mouse still in handle on mouse up"
			[self delete.
			target addHalo: evt]
		ifTrue:
			[innerTarget changeColor.
			self showingDirectionHandles ifTrue: [self addHandles]]
	
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doRot: evt with: rotHandle
	"Update the rotation of my target if it is rotatable.  Keep the relevant command object up to date."

	| degrees |
	evt hand obtainHalo: self.
	degrees _ (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees.
	degrees _ degrees - angleOffset degrees.
	degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false.
	degrees = 0.0
		ifTrue: [rotHandle color: Color lightBlue]
		ifFalse: [rotHandle color: Color blue].
	rotHandle submorphsDo:
		[:m | m color: rotHandle color makeForegroundColor].
	self removeAllHandlesBut: rotHandle.
	self showingDirectionHandles ifFalse:
		[self showDirectionHandles: true addHandles: false].
	self addDirectionHandles.

	target rotationDegrees: degrees.

	rotHandle position: evt cursorPoint - (rotHandle extent // 2).
	(self valueOfProperty: #commandInProgress) doIfNotNil:
		[:cmd | "Update the final rotation"
		cmd redoTarget: target selector: #rotationDegrees: argument: degrees].
	self layoutChanged! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
doScale: evt with: scaleHandle
	"Update the scale of my target if it is scalable."
	| newHandlePos |
	evt hand obtainHalo: self.
	newHandlePos _ evt cursorPoint - (scaleHandle extent // 2).
	target scaleToMatch: newHandlePos.
	target scale = 1.0
		ifTrue: [scaleHandle color: Color yellow]
		ifFalse: [scaleHandle color: Color orange].
	scaleHandle position: newHandlePos.
	self layoutChanged.
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 8/31/2000 23:00'!
endInteraction
	"Clean up after a user interaction with the a halo control"

	| m |
	(target isInWorld not or: [owner == nil]) ifTrue: [^ self].
	[target isFlexMorph and: [target hasNoScaleOrRotation]]
		whileTrue:
			[m _ target firstSubmorph.
			target removeFlexShell.
			target _ m].
	self isInWorld ifTrue:
		["make sure handles show in front, even if flex shell added"
		self comeToFront.
		self addHandles].
	(self valueOfProperty: #commandInProgress) doIfNotNil:
		[:cmd | self rememberCommand: cmd.
		self removeProperty: #commandInProgress] 
! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:42'!
handleAllowanceForIconicHalos
	^ 12! !

!HaloMorph methodsFor: 'private' stamp: 'sw 12/21/1999 15:19'!
handleSize
	^ HandleSize! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
maybeCollapse: evt with: collapseHandle
	"Ask hand to collapse my target if mouse comes up in it."
	evt hand obtainHalo: self.
	(collapseHandle containsPoint: evt cursorPoint)
		ifFalse:
			[self delete.
			target addHalo: evt]
		ifTrue:
			[self delete.
			target collapse]! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:41'!
maybeDismiss: evt with: dismissHandle
	"Ask hand to dismiss my target if mouse comes up in it."
	evt hand obtainHalo: self.
	(dismissHandle containsPoint: evt cursorPoint)
		ifFalse:
			[self delete.
			target addHalo: evt]
		ifTrue:
			[self delete.
			target dismissViaHalo]! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
maybeDoDup: evt with: dupHandle
	evt hand obtainHalo: self.
	^ target okayToDuplicate ifTrue:
		[self doDup: evt with: dupHandle]! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
mouseDownInCollapseHandle: evt with: collapseHandle
	evt hand obtainHalo: self.
	self removeAllHandlesBut: collapseHandle.
	collapseHandle color: Color tan darker! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
mouseDownInDimissHandle: evt with: dismissHandle
	evt hand obtainHalo: self.
	Preferences soundsEnabled ifTrue: [TrashCanMorph playMouseEnterSound].
	self removeAllHandlesBut: dismissHandle.
	dismissHandle color: Color darkGray.! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:12'!
positionDirectionShaft: shaft
	"Position the shaft."
	| alphaRadians unitVector |
	"Pretty crude and slow approach at present, but a stake in the ground"
	alphaRadians _ target heading degreesToRadians.
	unitVector _ alphaRadians sin  @ alphaRadians cos negated.
	shaft setVertices: {unitVector * 6 + directionArrowAnchor.  "6 = radius of deadeye circle"
					unitVector * self directionArrowLength + directionArrowAnchor}
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
prepareToTrackCenterOfRotation: evt with: rotationHandle
	evt hand obtainHalo: self.
	self removeAllHandlesBut: rotationHandle.
	evt hand showTemporaryCursor: Cursor blank! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/18/97 08:20'!
removeAllHandlesBut: h
	"Remove all handles except h."
	submorphs copy do:
		[:m | m == h ifFalse: [m delete]].
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
setCenterOfRotation: evt with: rotationHandle
	| localPt |
	evt hand obtainHalo: self.
	evt hand showTemporaryCursor: nil.
	localPt _ innerTarget transformFromWorld globalPointToLocal: rotationHandle center.
	innerTarget setRotationCenterFrom: localPt.
	self endInteraction
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
setDirection: anEvent with: directionHandle
	"The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly"
	| delta degrees |
	anEvent hand obtainHalo: self.
	delta _ (innerTarget transformFromWorld globalPointToLocal: directionHandle center) - innerTarget referencePosition.
	degrees _ delta degrees + 90.0.
	target forwardDirection: (degrees \\ 360) rounded.
	self endInteraction! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:42'!
setDismissColor: evt with: dismissHandle
	"Called on mouseStillDown in the dismiss handle; set the color appropriately."

	| colorToUse |
	evt hand obtainHalo: self.
	colorToUse _  (dismissHandle containsPoint: evt cursorPoint)
		ifFalse:
			[Color red muchLighter]
		ifTrue:
			[Color lightGray].
	dismissHandle color: colorToUse! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:25'!
showDirectionHandles: wantToShow

	self showDirectionHandles: wantToShow addHandles: true  "called from menu"
! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:34'!
showDirectionHandles: wantToShow addHandles: needHandles

	wantToShow
		ifTrue: [directionArrowAnchor _ target referencePositionInWorld]  "not nil means show"
		ifFalse: [directionArrowAnchor _ nil].
	needHandles ifTrue: [self addHandles]
! !

!HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:37'!
showingDirectionHandles

	^ directionArrowAnchor ~~ nil! !

!HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:43'!
simpleFudgeOffset
	"account for the difference in basicBoxes between regular and simple handles"

	^ 0@0
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/25/2000 15:10'!
startDrag: evt with: dragHandle
	| itsOwner |
	"Drag my target without removing it from its owner."
	evt hand obtainHalo: self.
	self removeAllHandlesBut: dragHandle.
	positionOffset _ dragHandle center - (target point: target position in: owner).

	 ((itsOwner _ target topRendererOrSelf owner) notNil and:
			[itsOwner automaticViewing]) ifTrue:
				[target openViewerForArgument]

"
Smalltalk at: #Q put: OrderedCollection new
"
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/25/2000 15:10'!
startGrow: evt with: growHandle
	| botRt |
	"Initialize resizing of my target.  Launch a command representing it, to support Undo"
	evt hand obtainHalo: self.
	growingOrRotating _ true.
	self removeAllHandlesBut: growHandle.  "remove all other handles"
	botRt _ target point: target bottomRight in: owner.
	(self world viewBox containsPoint: botRt)
		ifTrue: [positionOffset _ evt cursorPoint - botRt]
		ifFalse: [positionOffset _ 0@0].
	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: 'resizing';
			undoTarget: target selector: #extent: argument: target extent)
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'!
startRot: evt with: rotHandle
	"Initialize rotation of my target if it is rotatable.  Launch a command object to represent the action"
	evt hand obtainHalo: self.
	target isFlexMorph ifFalse: 
		[target isInWorld ifFalse: [self setTarget: target player costume].
		target addFlexShell].
	growingOrRotating _ true.

	self removeAllHandlesBut: rotHandle.  "remove all other handles"
	angleOffset _ evt cursorPoint - (target pointInWorld: target referencePosition).
	angleOffset _ Point
			r: angleOffset r
			degrees: angleOffset degrees - target rotationDegrees.
	self setProperty: #commandInProgress toValue:
		(Command new
			cmdWording: 'rotating';
			undoTarget: target selector: #rotationDegrees: argument: target rotationDegrees)

! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'!
startScale: evt with: scaleHandle
	"Initialize scaling of my target."
	evt hand obtainHalo: self.
	target isFlexMorph ifFalse: [target addFlexShell].
	growingOrRotating _ true.
	self removeAllHandlesBut: scaleHandle.  "remove all other handles"
	positionOffset _ 0@0.
! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/28/2000 22:25'!
strokeGrow: evt with: growHandle
	| dir |
	evt keyValue = 28 ifTrue:[dir _ -1@0].
	evt keyValue = 29 ifTrue:[dir _ 1@0].
	evt keyValue = 30 ifTrue:[dir _ 0@-1].
	evt keyValue = 31 ifTrue:[dir _ 0@1].
	dir ifNil:[^self].
	evt hand obtainHalo: self.
	evt hand newKeyboardFocus: growHandle.
	target extent: target extent + dir.
	self layoutChanged.! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'!
trackCenterOfRotation: anEvent with: rotationCenterHandle
	anEvent hand obtainHalo: self.
	rotationCenterHandle center: anEvent cursorPoint! !

!HaloMorph methodsFor: 'private' stamp: 'ar 10/24/2000 18:43'!
trackDirectionArrow: anEvent with: shaft
	anEvent hand obtainHalo: self.
	shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}.
	self layoutChanged! !


!HaloMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:37'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
innerTarget _ deepCopier references at: innerTarget ifAbsent: [innerTarget].
! !

!HaloMorph methodsFor: 'copying' stamp: 'di 9/10/2000 08:53'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	"target _ target.		Weakly copied"
	"innerTarget _ innerTarget.		Weakly copied"
	positionOffset _ positionOffset veryDeepCopyWith: deepCopier.
	angleOffset _ angleOffset veryDeepCopyWith: deepCopier.
	growingOrRotating _ growingOrRotating veryDeepCopyWith: deepCopier.
	directionArrowAnchor _ directionArrowAnchor.
	simpleMode _ simpleMode.
	haloBox _ haloBox! !


!HaloMorph methodsFor: 'handles' stamp: 'sw 11/6/2000 09:59'!
addChooseGraphicHandle: haloSpec
	"If the target is a sketch morph, and if the governing preference is set, add a halo handle allowing the user to select a new graphic"

	(Preferences showChooseGraphicHaloHandle and: [innerTarget isKindOf: SketchMorph]) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #chooseNewGraphicFromHalo to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'!
addCollapseHandle: handleSpec
	"we're hacking here - using mostly dismiss' infrastructure"
	| dismissHandle |
	dismissHandle _ self addHandle: handleSpec
		on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self.
	dismissHandle on: #mouseUp send: #maybeCollapse:with: to: self.
	dismissHandle on: #mouseDown send: #setDismissColor:with: to: self.
	dismissHandle on: #mouseMove send: #setDismissColor:with: to: self.
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 15:51'!
addDebugHandle: handleSpec
	Preferences debugHaloHandle ifTrue:
		[self addHandle: handleSpec
			on: #mouseDown send: #doDebug:with: to: self]
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'!
addDismissHandle: handleSpec
	| dismissHandle |
	dismissHandle _ self addHandle: handleSpec
		on: #mouseDown send: #mouseDownInDimissHandle:with: to: self.
	dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self.
	dismissHandle on: #mouseDown send: #setDismissColor:with: to: self.
	dismissHandle on: #mouseMove send: #setDismissColor:with: to: self.
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:48'!
addDragHandle: haloSpec
	(self addHandle: haloSpec on: #mouseDown send: #startDrag:with: to: self)
		on: #mouseMove send: #doDrag:with: to: self


! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:15'!
addDupHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #doDup:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/28/2000 09:59'!
addFewerHandlesHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #addSimpleHandles to: self
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:56'!
addFontEmphHandle: haloSpec
	(innerTarget isKindOf: TextMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #chooseEmphasisOrAlignment to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:53'!
addFontSizeHandle: haloSpec
	(innerTarget isKindOf: TextMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #chooseFont to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:55'!
addFontStyleHandle: haloSpec
	(innerTarget isKindOf: TextMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #chooseStyle to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/27/2000 17:22'!
addGrabHandle: haloSpec
	"If appropriate, add the black halo handle for picking up the target"

	innerTarget okayToAddGrabHandle ifTrue:
		[self addHandle: haloSpec on: #mouseDown send: #doGrab:with: to: self]

! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/28/2000 22:15'!
addGrowHandle: haloSpec
	target isFlexMorph ifFalse: 
		[(self addHandle: haloSpec
				on: #mouseDown send: #startGrow:with: to: self)
				on: #mouseMove send: #doGrow:with: to: self;
				on: #keyStroke send: #strokeGrow:with: to: self]
	"This or addScaleHandle:, but not both, will prevail at any one time"
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:16'!
addHelpHandle: haloSpec
	target balloonText ifNotNil:
		[(self addHandle: haloSpec on: #mouseDown send: #mouseDownOnHelpHandle: to: innerTarget)
			on: #mouseUp send: #deleteBalloon to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:05'!
addMenuHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:23'!
addPaintBgdHandle: haloSpec
	(innerTarget isKindOf: PasteUpMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #paintBackground to: innerTarget].
! !

!HaloMorph methodsFor: 'handles' stamp: 'laza 3/24/2000 13:52'!
addPoohHandle: handleSpec
	(innerTarget isKindOf: WonderlandCameraMorph) ifTrue:
		[self addHandle: handleSpec on: #mouseDown send: #strokeMode to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 8/29/2000 15:28'!
addRecolorHandle: haloSpec
	"Add a recolor handle to the receiver, if appropriate"

	| recolorHandle |
	 innerTarget canSetColor ifTrue:
		[recolorHandle _ self addHandle: haloSpec on: #mouseUp send: #doRecolor:with:  to: self.
		recolorHandle on: #mouseUp send: #doRecolor:with: to: self]


! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/27/2000 16:49'!
addRepaintHandle: haloSpec
	(innerTarget isKindOf: SketchMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #editDrawing to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'!
addRotateHandle: haloSpec
	(self addHandle: haloSpec on: #mouseDown send: #startRot:with: to: self)
		on: #mouseMove send: #doRot:with: to: self

! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:49'!
addScaleHandle: haloSpec
	target isFlexMorph ifTrue: 
		[(self addHandle: haloSpec
				on: #mouseDown send: #startScale:with: to: self)
				on: #mouseMove send: #doScale:with: to: self].
	"This or addGrowHandle:, but not both, will prevail at any one time"
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/9/2000 16:57'!
addScriptHandle: haloSpec
	"If the halo's innerTarget claims it wants a Script handle, add one to the receiver, forming it as per haloSpec"

	innerTarget wantsScriptorHaloHandle ifTrue:
		[self addHandle: haloSpec
				on: #mouseUp send: #editButtonsScript to: innerTarget]
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:07'!
addTileHandle: haloSpec
	self addHandle: haloSpec on: #mouseDown send: #tearOffTile to: innerTarget
! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 1/26/2000 16:09'!
addViewHandle: haloSpec
	self addHandle: haloSpec
		on: #mouseDown send: #openViewerForArgument to: innerTarget


! !

!HaloMorph methodsFor: 'handles' stamp: 'sw 10/23/2000 18:19'!
addViewingHandle: haloSpec
	"If appropriate, add a special Viewing halo handle to the receiver"

	(innerTarget isKindOf: PasteUpMorph) ifTrue:
		[self addHandle: haloSpec
				on: #mouseDown send: #presentViewMenu to: innerTarget].
! !

!HaloMorph methodsFor: 'handles' stamp: 'ar 1/30/2001 23:32'!
positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert
	| xCoord yCoord |

	horiz == #left
		ifTrue:	[xCoord _ aBox left].
	horiz == #leftCenter
		ifTrue:	[xCoord _ aBox left + (aBox width // 4)].
	horiz == #center
		ifTrue:	[xCoord _ (aBox left + aBox right) // 2].
	horiz == #rightCenter
		ifTrue:	[xCoord _ aBox left + ((3 * aBox width) // 4)].
	horiz == #right
		ifTrue:	[xCoord _ aBox right].

	vert == #top
		ifTrue:	[yCoord _ aBox top].
	vert == #topCenter
		ifTrue:	[yCoord _ aBox top + (aBox height // 4)].
	vert == #center
		ifTrue:	[yCoord _ (aBox top + aBox bottom) // 2].
	vert == #bottomCenter
		ifTrue:	[yCoord _ aBox top + ((3 * aBox height) // 4)].
	vert == #bottom
		ifTrue:	[yCoord _ aBox bottom].

	^ xCoord asInteger @ yCoord asInteger! !


!HaloMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:46'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	simpleMode ifNil: [simpleMode _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!HaloMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 19:12'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^7		"Halos are very front-like things"! !

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

HaloMorph class
	instanceVariableNames: ''!

!HaloMorph class methodsFor: 'as yet unclassified' stamp: 'sw 12/21/1999 15:19'!
initialize
	"HaloMorph initialize"
	HandleSize _ 16! !
Object subclass: #HaloSpec
	instanceVariableNames: 'addHandleSelector horizontalPlacement verticalPlacement color iconSymbol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'!
addHandleSelector
	^ addHandleSelector! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
color
	^ color! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
horizontalPlacement
	^ horizontalPlacement! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 19:54'!
horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel
	horizontalPlacement _ hp.
	verticalPlacement _ vp.
	color_ col.
	iconSymbol _ is asSymbol.
	addHandleSelector _ sel! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
iconSymbol
	^ iconSymbol! !

!HaloSpec methodsFor: 'as yet unclassified' stamp: 'sw 1/25/2000 18:41'!
verticalPlacement
	^ verticalPlacement! !
Error subclass: #Halt
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Extensions'!
!Halt commentStamp: '<historical>' prior: 0!
Halt is provided to support Object>>halt.!


!Halt methodsFor: 'description' stamp: 'tfei 5/10/1999 14:24'!
isResumable

	^true! !

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

Halt class
	instanceVariableNames: ''!

!Halt class methodsFor: 'exceptionSelector' stamp: 'sma 2/26/2000 18:11'!
handles: exception
	"Determine whether an exception handler will accept a signaled exception."

	^ exception isKindOf: self! !
Morph subclass: #HandMorph
	instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hasChanged savedPatch userInitials lastEventBuffer '
	classVariableNames: 'DoubleClickTime EventStats NewEventRules NormalCursor PasteBuffer ShowEvents '
	poolDictionaries: 'EventSensorConstants '
	category: 'Morphic-Kernel'!
!HandMorph commentStamp: '<historical>' prior: 0!
The cursor may be thought of as the HandMorph.  The hand's submorphs hold anything being carried by dragging.  

There is some minimal support for multiple hands in the same world.!


!HandMorph methodsFor: 'initialization' stamp: 'ar 10/9/2000 15:49'!
initForEvents
	lastMouseEvent _ MouseEvent new setType: #mouseMove position: 0@0 buttons: 0 hand: self.
	lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}.
	self resetClickState.
! !

!HandMorph methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:58'!
initialize
	super initialize.
	self initForEvents.
	keyboardFocus _ nil.
	mouseFocus _ nil.
	bounds _ 0@0 extent: Cursor normal extent.
	userInitials _ ''.
	damageRecorder _ DamageRecorder new.
	cachedCanvasHasHoles _ false.
	temporaryCursor _ temporaryCursorOffset _ nil.
	self initForEvents.! !


!HandMorph methodsFor: 'accessing' stamp: 'ar 10/5/2000 23:17'!
lastEvent
	^ lastMouseEvent! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:24'!
mouseOverHandler
	^mouseOverHandler ifNil:[mouseOverHandler _ MouseOverHandler new].! !

!HandMorph methodsFor: 'accessing'!
targetOffset
	"Return the offset of the last mouseDown location relative to the origin of the recipient morph. During menu interactions, this is the absolute location of the mouse down event that invoked the menu."

	^ targetOffset
! !

!HandMorph methodsFor: 'accessing'!
userInitials

	^ userInitials! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:18'!
userPicture
	^self valueOfProperty: #remoteUserPicture

! !

!HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:34'!
userPicture: aFormOrNil
	^self setProperty: #remoteUserPicture toValue: aFormOrNil
! !


!HandMorph methodsFor: 'classification'!
isHandMorph

	^ true! !


!HandMorph methodsFor: 'cursor' stamp: 'jwh 6/5/2000 07:38'!
cursorBounds

	^temporaryCursor 
		ifNil: [self position extent: NormalCursor extent]
		ifNotNil: [self position + temporaryCursorOffset extent: temporaryCursor extent]! !

!HandMorph methodsFor: 'cursor' stamp: 'di 3/6/1999 23:52'!
showTemporaryCursor: cursorOrNil
	"Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor."

	self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0
! !

!HandMorph methodsFor: 'cursor' stamp: 'ar 10/26/2000 15:28'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset
	"Set the temporary cursor to the given Form.
	If the argument is nil, revert to the normal hardware cursor."

	self changed.
	cursorOrNil == nil
		ifTrue: [temporaryCursor _ temporaryCursorOffset _ nil]
		ifFalse: [temporaryCursor _ cursorOrNil asCursorForm.
				temporaryCursorOffset _ temporaryCursor offset - hotSpotOffset].
	bounds _ self cursorBounds.
	self 
		userInitials: userInitials andPicture: (self userPicture);
		layoutChanged;
		changed
! !


!HandMorph methodsFor: 'geometry' stamp: 'jm 2/20/98 19:54'!
changed

	hasChanged _ true.
! !

!HandMorph methodsFor: 'geometry' stamp: 'jm 2/20/98 18:55'!
fullBounds
	"Extend my bounds by the shadow offset when carrying morphs."

	| bnds |
	bnds _ super fullBounds.
	submorphs isEmpty
		ifTrue: [^ bnds ]
		ifFalse: [^ bnds topLeft corner: bnds bottomRight + self shadowOffset].
! !

!HandMorph methodsFor: 'geometry' stamp: 'ar 11/25/2000 17:03'!
invalidRect: damageRect from: aMorph
	"Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache."
	hasChanged _ true.
	aMorph == self ifTrue:[^self].
	fullBounds == nil
		ifTrue: [damageRecorder recordInvalidRect: damageRect]
		ifFalse: [damageRecorder recordInvalidRect: (damageRect translateBy: fullBounds origin negated)].
! !

!HandMorph methodsFor: 'geometry' stamp: 'jwh 6/5/2000 08:11'!
position

	^temporaryCursor
		ifNil: [bounds topLeft]
		ifNotNil: [bounds topLeft - temporaryCursorOffset]! !

!HandMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 19:13'!
position: aPoint
	"Overridden to align submorph origins to the grid if gridding is on."
	| adjustedPosition |
	adjustedPosition := aPoint.
	temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset].
	^ super position: adjustedPosition
! !

!HandMorph methodsFor: 'geometry' stamp: 'ar 10/26/2000 15:34'!
userInitials: aString andPicture: aForm

	| qp cb pictRect initRect |

	userInitials _ aString.
	pictRect _ initRect _ cb _ self cursorBounds.
	userInitials isEmpty ifFalse: [
		qp _ DisplayScanner quickPrintOn: Display.
		initRect _ cb topRight + (0@4) extent: (qp stringWidth: userInitials)@(qp lineHeight).
	].
	self userPicture: aForm.
	aForm ifNotNil: [
		pictRect _ (self cursorBounds topRight + (0@24)) extent: aForm extent.
	].
	self bounds: ((cb merge: initRect) merge: pictRect).


! !


!HandMorph methodsFor: 'drawing' stamp: 'sw 2/11/98 18:00'!
colorForInsets
	"Morphs being dragged by the hand use the world's color"
	^ owner colorForInsets! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 10/26/2000 15:33'!
drawOn: aCanvas
	| userPic |
	"Draw the hand itself (i.e., the cursor)."

	temporaryCursor == nil
		ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft]
		ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft].
	self hasUserInformation ifTrue: [
		aCanvas 
			text: userInitials
			at: (self cursorBounds topRight + (0@4))
			font: nil
			color: color.
		(userPic _ self userPicture) ifNotNil: [
			aCanvas paintImage: userPic at: (self cursorBounds topRight + (0@24))
		].
	].
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 10/5/2000 16:19'!
fullDrawOn: aCanvas
	"A HandMorph has unusual drawing requirements:
		1. the hand itself (i.e., the cursor) appears in front of its submorphs
		2. morphs being held by the hand cast a shadow on the world/morphs below
	The illusion is that the hand plucks up morphs and carries them above the world."
	"Note: This version caches an image of the morphs being held by the hand for
	 better performance. This cache is invalidated if one of those morphs changes."

	| disableCaching subBnds |
	self visible ifFalse:[^self].

	disableCaching _ false.
	disableCaching ifTrue: [self nonCachingFullDrawOn: aCanvas. ^ self].

	submorphs isEmpty ifTrue:
		[cacheCanvas _ nil.
		^ self drawOn: aCanvas].  "just draw the hand itself"

	subBnds _ Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	self updateCacheCanvas: aCanvas.
	(cacheCanvas == nil or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]])
		ifTrue:
		["could not use caching due to translucency; do full draw"
		self nonCachingFullDrawOn: aCanvas. ^ self].

	"draw the shadow"
	aCanvas asShadowDrawingCanvas
		translateBy: self shadowOffset during:[:shadowCanvas|
		cachedCanvasHasHoles
			ifTrue: ["Have to draw the real shadow of the form"
					shadowCanvas paintImage: cacheCanvas form at: subBnds origin]
			ifFalse: ["Much faster if only have to shade the edge of a solid rectangle"
					(subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) do:
						[:r | shadowCanvas fillRectangle: r color: Color black]]].

	"draw morphs in front of the shadow using the cached Form"
	cachedCanvasHasHoles
		ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin]
		ifFalse: [aCanvas drawImage: cacheCanvas form at: subBnds origin
					sourceRect: cacheCanvas form boundingBox].
	self drawOn: aCanvas.  "draw the hand itself in front of morphs"
! !

!HandMorph methodsFor: 'drawing' stamp: 'ls 4/3/2000 20:30'!
hasChanged
	"Return true if this hand has changed, either because it has moved or because some morph it is holding has changed."

	^ hasChanged ifNil: [ true ]
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 10/26/2000 15:33'!
hasUserInformation

	^self userInitials size > 0 or: [self userPicture notNil]! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 10/26/2000 15:15'!
needsToBeDrawn
	"Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty. If using the software cursor, ensure that the hardware cursor is hidden."
	"Details:  Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display."
	(savedPatch notNil or:[(submorphs size > 0) or:[temporaryCursor ~~ nil or:[self hasUserInformation]]])
		ifTrue: [
			"using the software cursor; hide the hardware one"
			Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show].
			^ true].

	^ false
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 2/18/2000 15:19'!
nonCachingFullDrawOn: aCanvas
	| shadowForm |
	"A HandMorph has unusual drawing requirements:
		1. the hand itself (i.e., the cursor) appears in front of its submorphs
		2. morphs being held by the hand cast a shadow on the world/morphs below
	The illusion is that the hand plucks up morphs and carries them above the world."
	"Note: This version does not cache an image of the morphs being held by the hand.
	 Thus, it is slower for complex morphs, but consumes less space."

	submorphs isEmpty ifTrue: [^ self drawOn: aCanvas].  "just draw the hand itself"
	aCanvas asShadowDrawingCanvas
		translateBy: self shadowOffset during:[:shadowCanvas|
		"Note: We use a shadow form here to prevent drawing
		overlapping morphs multiple times using the transparent
		shadow color."
		shadowForm _ self shadowForm.
"
shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0@0 extent: shadowForm extent).
"
		shadowCanvas paintImage: shadowForm at: shadowForm offset.  "draw shadows"
	].
	"draw morphs in front of shadows"
	self drawSubmorphsOn: aCanvas.
	self drawOn: aCanvas.  "draw the hand itself in front of morphs"
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:46'!
restoreSavedPatchOn: aCanvas
	"Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor."

	hasChanged _ false.
	savedPatch ifNotNil: [
		aCanvas drawImage: savedPatch at: savedPatch offset.
		self hasUserInformation ifTrue: [^self].	"cannot use hw cursor if so"
		submorphs size > 0 ifTrue: [^self].
		temporaryCursor ifNotNil: [^self].

		"Make the transition to using hardware cursor. Clear savedPatch and
		 report one final damage rectangle to erase the image of the software cursor."
		super invalidRect: (savedPatch offset extent: savedPatch extent + self shadowOffset) from: self.
		Sensor currentCursor == Cursor normal ifFalse: [Cursor normal show].  "show hardware cursor"
		savedPatch _ nil.
	].
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 16:01'!
savePatchFrom: aCanvas
	"Save the part of the given canvas under this hand as a Form and return its bounding rectangle."
	"Details: The previously used patch Form is recycled when possible to reduce the burden on storage management."

	| damageRect myBnds |
	damageRect _ myBnds _ self fullBounds.
	savedPatch ifNotNil: [
		damageRect _ myBnds merge: (savedPatch offset extent: savedPatch extent)].
	(savedPatch == nil or: [savedPatch extent ~= myBnds extent])
		ifTrue: [  "allocate new patch form if needed"
			savedPatch _ aCanvas form allocateForm: myBnds extent].
	aCanvas
		contentsOfArea: (myBnds translateBy: aCanvas origin)
		into: savedPatch.
	savedPatch offset: myBnds topLeft.
	^ damageRect
! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 18:04'!
shadowForm
	"Return a 1-bit shadow of my submorphs.  Assumes submorphs is not empty"
	| bnds canvas |
	bnds _ Rectangle merging: (submorphs collect: [:m | m bounds]).
	canvas _ (Display defaultCanvasClass extent: bnds extent depth: 1) 
		asShadowDrawingCanvas: Color black.
	canvas translateBy: bnds topLeft negated
		during:[:tempCanvas| self drawSubmorphsOn: tempCanvas].
	^ canvas form offset: bnds topLeft! !

!HandMorph methodsFor: 'drawing'!
shadowOffset

	^ 6@8! !

!HandMorph methodsFor: 'drawing' stamp: 'di 9/10/1998 16:20'!
trailMorph
	"You can't draw trails when picked up by the hand."
	^ nil! !

!HandMorph methodsFor: 'drawing' stamp: 'ar 11/25/2000 17:06'!
updateCacheCanvas: aCanvas
	"Update the cached image of the morphs being held by this hand."
	| subBnds rectList |
	"Note: The following is an attempt to quickly get out if there's no change"
	subBnds _ Rectangle merging: (submorphs collect: [:m | m fullBounds]).
	rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: subBnds extent).
	(rectList isEmpty and:[cacheCanvas notNil and:[cacheCanvas extent = subBnds extent]])
		ifTrue:[^self].

	"Always check for real translucency -- can't be cached in a form"
	self allMorphsDo: [:m |
		m hasTranslucentColor ifTrue: [
			cacheCanvas _ nil.
			cachedCanvasHasHoles _ true.
			^ self]].

	(cacheCanvas == nil or: [cacheCanvas extent ~= subBnds extent]) ifTrue: [
		cacheCanvas _ (aCanvas allocateForm: subBnds extent) getCanvas.
		cacheCanvas translateBy: subBnds origin negated
			during:[:tempCanvas| self drawSubmorphsOn: tempCanvas].
		self submorphsDo:
			[:m | (m areasRemainingToFill: subBnds) isEmpty
				ifTrue: [^ cachedCanvasHasHoles _ false]].
		cachedCanvasHasHoles _ (cacheCanvas form tallyPixelValues at: 1) > 0.
		^ self].

	"incrementally update the cache canvas"
	rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: subBnds extent).
	damageRecorder reset.
	rectList do: [:r |
		cacheCanvas translateTo: subBnds origin negated clippingTo: r during:[:c|
			c fillColor: Color transparent.  "clear to transparent"
			self drawSubmorphsOn: c]].! !


!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 23:16'!
checkForMoreKeyboard
	"Quick check for more keyboard activity -- Allows, eg, many characters
	to be accumulated into a single replacement during type-in."
	self flag: #arNote. "Will not work if we don't examine event queue in Sensor"
	^nil! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 23:17'!
flushEvents
	"Flush any events that may be pending"
	self flag: #arNote. "Remove it and fix senders"
	Sensor flushEvents.! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:42'!
handleEvent: anEvent
	| evt ofs |
	owner ifNil:[^self].
	evt _ anEvent.

	EventStats ifNil:[EventStats _ IdentityDictionary new].
	EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1.
	EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1.

	evt isMouseOver ifTrue:[^self sendEvent: evt focus: self mouseFocus].

ShowEvents == true ifTrue:[
	ofs _ (owner hands indexOf: self) - 1 * 60.
	evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue:[0@30] ifFalse:[0@0]).
	self keyboardFocus printString displayAt: (0@ofs)+(0@45).
].
	"Notify listeners"
	self sendListenEvent: evt to: self eventListeners.

	evt isKeyboard ifTrue:[
		self sendListenEvent: evt to: self keyboardListeners.
		self sendEvent: evt focus: self keyboardFocus.
		^self mouseOverHandler processMouseOver: lastMouseEvent].

	evt isDropEvent ifTrue:[
		self sendEvent: evt focus: nil.
		^self mouseOverHandler processMouseOver: lastMouseEvent].

	evt isMouse ifTrue:[
		self sendListenEvent: evt to: self mouseListeners.
		lastMouseEvent _ evt].

	"Check for pending drag or double click operations."
	mouseClickState ifNotNil:[
		(mouseClickState handleEvent: evt from: self) ifFalse:[
			"Possibly dispatched #click: or something and will not re-establish otherwise"
			^self mouseOverHandler processMouseOver: lastMouseEvent]].

	evt isMove ifTrue:[
		self position: evt position.
		self sendEvent: evt focus: self mouseFocus.
	] ifFalse:[
		"Issue a synthetic move event if we're not at the position of the event"
		(evt position = self position) ifFalse:[self moveToEvent: evt].
		"Drop submorphs on button events"
		(self hasSubmorphs) 
			ifTrue:[self dropMorphs: evt]
			ifFalse:[self sendEvent: evt focus: self mouseFocus].
	].
	ShowEvents == true ifTrue:[self mouseFocus printString displayAt: (0@ofs) + (0@15)].
	self mouseOverHandler processMouseOver: lastMouseEvent.
! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 9/25/2000 14:27'!
noticeMouseOver: aMorph event: anEvent
	mouseOverHandler ifNil:[^self].
	mouseOverHandler noticeMouseOver: aMorph event: anEvent.! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 20:08'!
pauseEventRecorderIn: aWorld
	"Suspend any recorder prior to a project change, and return it.
	It will be resumed after starting the new project."
	eventListeners ifNil:[^nil].
	eventListeners do:
		[:er | (er isKindOf: EventRecorderMorph) ifTrue: [^ er pauseIn: aWorld]].
	^ nil! !

!HandMorph methodsFor: 'event handling' stamp: 'ar 1/30/2001 19:55'!
processEvents
	"Process user input events from the local input devices.
	An interesting problem. Morphic is always supposed to run in an event driven environment but for now it is possible that a Morphic window is run from MVC so that we have to synthesize events in the sensor. That's quite a bit of a problem because it means that we'll get endless mouse events. To compensate for this, EventSensor will always return keyboard events first if synthesized so if we're running into a mouse event AND Sensor doesn't have an event queue we can safely break out of the event processing loop. See also EventSensor>>nextEventSynthesized."
	| evt evtBuf type hadMouse hadAny |
	hadMouse _ hadAny _ false.
	[(evtBuf _ Sensor nextEvent) == nil] whileFalse:[
		evt _ nil. "for unknown event types"
		type _ evtBuf at: 1.
		(type = EventTypeMouse)
			ifTrue:[evt _ self generateMouseEvent: evtBuf. hadMouse _ true].
		(type = EventTypeKeyboard) 
			ifTrue:[evt _ self generateKeyboardEvent: evtBuf].
		(type = EventTypeDragDropFiles)
			ifTrue:[evt _ self generateDropFilesEvent: evtBuf].
		"All other events are ignored"

		evt == nil ifFalse:[
			"Finally, handle it"
			self handleEvent: evt.
			hadAny _ true.

			"See the note on running a World in MVC in the method comment"
			(evt isMouse and:[Sensor eventQueue == nil]) ifTrue:[^self].
		].
	].
	(mouseClickState notNil and:[hadMouse not]) ifTrue:[
		"No mouse events during this cycle. Make sure click states time out accordingly"
		mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
	hadAny ifFalse:[
		"No pending events. Make sure z-order is up to date"
		self mouseOverHandler processMouseOver: lastMouseEvent.
	].! !


!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
keyboardFocus 
	^ keyboardFocus! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'!
keyboardFocus: aMorphOrNil
	keyboardFocus _ aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
mouseFocus
	^mouseFocus! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'!
mouseFocus: aMorphOrNil
	mouseFocus _ aMorphOrNil! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/24/2000 20:07'!
newKeyboardFocus: aMorphOrNil
	"Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled."
	| oldFocus |
	oldFocus _ self keyboardFocus.
	self keyboardFocus: aMorphOrNil.
	oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]].
	aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true].
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:32'!
newMouseFocus: aMorphOrNil
	"Make the given morph the new mouse focus, canceling the previous mouse focus if any. If the argument is nil, the current mouse focus is cancelled."
	self mouseFocus: aMorphOrNil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
newMouseFocus: aMorph event: event
	aMorph == nil ifFalse:[
		targetOffset _ event cursorPoint - aMorph position.
	].
	^self newMouseFocus: aMorph.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
releaseAllFoci
	mouseFocus _ nil.
	keyboardFocus _ nil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'!
releaseKeyboardFocus
	"Release the current keyboard focus unconditionally"
	self newKeyboardFocus: nil.
! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:31'!
releaseKeyboardFocus: aMorph
	"If the given morph had the keyboard focus before, release it"
	self keyboardFocus == aMorph ifTrue:[self releaseKeyboardFocus].! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
releaseMouseFocus
	"Release the current mouse focus unconditionally."
	self newMouseFocus: nil.! !

!HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'!
releaseMouseFocus: aMorph
	"If the given morph had the mouse focus before, release it"
	self mouseFocus == aMorph ifTrue:[self releaseMouseFocus].! !


!HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:16'!
resetClickState
	"Reset the double-click detection state to normal (i.e., not waiting for a double-click)."
	mouseClickState _ nil.! !

!HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:10'!
waitForClicksOrDrag: aMorph event: evt
	"Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." 
	^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #startDrag:) threshold: 10! !

!HandMorph methodsFor: 'double click support' stamp: 'ar 9/18/2000 17:18'!
waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold
	"Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'drag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or drag: methods." 
	mouseClickState _ 
		MouseClickState new
			client: aMorph 
			click: clickAndDragSelectors first 
			dblClick: clickAndDragSelectors second 
			dblClickTime: DoubleClickTime 
			drag: clickAndDragSelectors third 
			threshold: threshold 
			event: evt.! !


!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/8/2000 23:42'!
attachMorph: m
	"Position the center of the given morph under this hand, then grab it.
	This method is used to grab far away or newly created morphs."
	| delta |
	self releaseMouseFocus. "Break focus"
	delta _ m bounds extent // 2.
	m position: (self position - delta).
	m formerPosition: m position.
	targetOffset _ m position - self position.
	self addMorphBack: m.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 2/3/2001 14:24'!
dropMorph: aMorph event: anEvent
	"Drop the given morph which was carried by the hand"
	| event dropped |
	self privateRemoveMorph: aMorph.
	dropped _ aMorph.
	(dropped hasProperty: #addedFlexAtGrab) 
		ifTrue:[dropped _ aMorph removeFlexShell].
	event _ DropEvent new setPosition: self position contents: dropped hand: self.
	owner processEvent: event.
	event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event].
	aMorph owner == self ifTrue:[aMorph delete].
	self mouseOverHandler processMouseOver: anEvent.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 10/5/2000 16:23'!
dropMorphs
	"Drop the morphs at the hands position"
	self dropMorphs: lastMouseEvent.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 9/14/2000 11:22'!
dropMorphs: anEvent
	"Drop the morphs at the hands position"
	self submorphsReverseDo:[:m|
		"Drop back to front to maintain z-order"
		self dropMorph: m event: anEvent.
	].! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 11/21/2000 17:42'!
grabMorph: aMorph
	"Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."
	| grabbed |
	self releaseMouseFocus. "Break focus"
	grabbed _ aMorph aboutToBeGrabbedBy: self.
	grabbed ifNil:[^self].
	grabbed _ grabbed topRendererOrSelf.
	^self grabMorph: grabbed from: grabbed owner! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 11/21/2000 18:25'!
grabMorph: aMorph from: formerOwner
	"Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand."
	| grabbed offset targetPoint grabTransform fullTransform |
	self releaseMouseFocus. "Break focus"
	grabbed _ aMorph.
	"Compute the transform to apply to the grabbed morph"
	grabTransform _ formerOwner 
			ifNil:[IdentityTransform new] 
			ifNotNil:[formerOwner grabTransform].
	"Compute the full transform for the grabbed morph"
	fullTransform _ formerOwner 
			ifNil:[IdentityTransform new] 
			ifNotNil:[formerOwner transformFrom: owner].
	"targetPoint is point in aMorphs reference frame"
	targetPoint _ fullTransform globalPointToLocal: self position.
	"but current position will be determined by grabTransform, so compute offset"
	offset _ targetPoint - (grabTransform globalPointToLocal: self position).
	"apply the transform that should be used after grabbing"
	grabbed _ grabbed transformedBy: grabTransform.
	grabbed == aMorph 
		ifFalse:[grabbed setProperty: #addedFlexAtGrab toValue: true].
	"offset target to compensate for differences in transforms"
	grabbed position: grabbed position - offset asIntegerPoint.
	"And compute distance from hand's position"
	targetOffset _ grabbed position - self position.
	self addMorphBack: grabbed.! !

!HandMorph methodsFor: 'grabbing/dropping' stamp: 'di 10/16/2000 10:46'!
targetOffset: offsetPoint
	"Set the offset at which we clicked down in the target morph"

	targetOffset _ offsetPoint! !


!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:43'!
addEventListener: anObject
	"Make anObject a listener for all events. All events will be reported to the object."
	self eventListeners: (self addListener: anObject to: self eventListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'!
addKeyboardListener: anObject
	"Make anObject a listener for keyboard events. All keyboard events will be reported to the object."
	self keyboardListeners: (self addListener: anObject to: self keyboardListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:40'!
addListener: anObject to: aListenerGroup
	"Add anObject to the given listener group. Return the new group."
	| listeners |
	listeners _ aListenerGroup.
	(listeners notNil and:[listeners includes: anObject]) ifFalse:[
		listeners
			ifNil:[listeners _ WeakArray with: anObject]
			ifNotNil:[listeners _ listeners copyWith: anObject]].
	listeners _ listeners copyWithout: nil. "obsolete entries"
	^listeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:42'!
addMouseListener: anObject
	"Make anObject a listener for mouse events. All mouse events will be reported to the object."
	self mouseListeners: (self addListener: anObject to: self mouseListeners)! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
eventListeners
	^eventListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
eventListeners: anArrayOrNil
	eventListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'!
keyboardListeners
	^keyboardListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
keyboardListeners: anArrayOrNil
	keyboardListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'!
mouseListeners
	^mouseListeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'!
mouseListeners: anArrayOrNil
	mouseListeners _ anArrayOrNil! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeEventListener: anObject
	"Remove anObject from the current event listeners."
	self eventListeners: (self removeListener: anObject from: self eventListeners).! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeKeyboardListener: anObject
	"Remove anObject from the current keyboard listeners."
	self keyboardListeners: (self removeListener: anObject from: self keyboardListeners).! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeListener: anObject from: aListenerGroup
	"Remove anObject from the given listener group. Return the new group."
	| listeners |
	aListenerGroup ifNil:[^nil].
	listeners _ aListenerGroup.
	listeners _ listeners copyWithout: anObject.
	listeners _ listeners copyWithout: nil. "obsolete entries"
	listeners size = 0 ifTrue:[listeners _ nil].
	^listeners! !

!HandMorph methodsFor: 'listeners' stamp: 'ar 10/24/2000 20:41'!
removeMouseListener: anObject
	"Remove anObject from the current mouse listeners."
	self mouseListeners: (self removeListener: anObject from: self mouseListeners).! !


!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:49'!
balloonHelp
	"Return the balloon morph associated with this hand"
	^self valueOfProperty: #balloonHelpMorph! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 16:51'!
balloonHelp: aBalloonMorph
	"Return the balloon morph associated with this hand"
	| oldHelp |
	oldHelp _ self balloonHelp.
	oldHelp ifNotNil:[oldHelp delete].
	aBalloonMorph
		ifNil:[self removeProperty: #balloonHelpMorph]
		ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:19'!
deleteBalloonTarget: aMorph
	"Delete the balloon help targeting the given morph"
	| h |
	h _ self balloonHelp ifNil:[^self].
	h balloonOwner == aMorph ifTrue:[self balloonHelp: nil].! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/6/2000 00:14'!
removePendingBalloonFor: aMorph
	"Get rid of pending balloon help."
	self removeAlarm: #spawnBalloonFor:.
	self deleteBalloonTarget: aMorph.! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:15'!
spawnBalloonFor: aMorph
	aMorph showBalloon: aMorph balloonText hand: self.! !

!HandMorph methodsFor: 'balloon help' stamp: 'ar 10/3/2000 17:14'!
triggerBalloonFor: aMorph after: timeOut
	"Trigger balloon help after the given time out for some morph"
	self addAlarm: #spawnBalloonFor: with: aMorph after: timeOut.! !


!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 13:40'!
halo
	"Return the halo associated with this hand, if any"
	^self valueOfProperty: #halo! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 13:40'!
halo: newHalo
	"Set halo associated with this hand"
	| oldHalo |
	oldHalo _ self halo.
	(oldHalo isNil or:[oldHalo == newHalo]) ifFalse:[oldHalo delete].
	newHalo
		ifNil:[self removeProperty: #halo]
		ifNotNil:[self setProperty: #halo toValue: newHalo]! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'!
obtainHalo: aHalo
	"Used for transfering halos between hands"
	| formerOwner |
	self halo == aHalo ifTrue:[^self].
	"Find former owner"
	formerOwner _ self world hands detect:[:h| h halo == aHalo] ifNone:[nil].
	formerOwner ifNotNil:[formerOwner releaseHalo: aHalo].
	self halo: aHalo! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'!
releaseHalo: aHalo
	"Used for transfering halos between hands"
	self removeProperty: #halo! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 19:25'!
removeHaloFromClick: anEvent on: aMorph
	| halo |
	halo _ self halo ifNil:[^self].
	(halo target hasOwner: self) ifTrue:[^self].
	(halo staysUpWhenMouseIsDownIn: aMorph) ifFalse:[halo delete].! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/6/2000 00:14'!
removePendingHaloFor: aMorph
	"Get rid of pending balloon help or halo actions."
	self removeAlarm: #spawnHaloFor:.! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 11:49'!
spawnHaloFor: aMorph
	aMorph addHaloFor: self.! !

!HandMorph methodsFor: 'halo handling' stamp: 'ar 10/4/2000 11:50'!
triggerHaloFor: aMorph after: timeOut
	"Trigger automatic halo after the given time out for some morph"
	self addAlarm: #spawnHaloFor: with: aMorph after: timeOut.! !


!HandMorph methodsFor: 'paste buffer' stamp: 'ar 11/6/2000 13:07'!
copyToPasteBuffer: aMorph
	"Save this morph in the paste buffer. This is mostly useful for copying morphs between projects."
	aMorph ifNil:[^PasteBuffer _ nil].
	Cursor wait showWhile:[
		PasteBuffer _ aMorph topRendererOrSelf veryDeepCopy.
		PasteBuffer privateOwner: nil].

! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'!
objectToPaste
	"It may need to be sent #startRunning by the client"
	^ Cursor wait showWhile: [PasteBuffer veryDeepCopy]

	"PasteBuffer usableDuplicateIn: self world"
! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'!
pasteBuffer
	"Return the paste buffer associated with this hand"
	^ PasteBuffer! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'!
pasteBuffer: aMorphOrNil
	"Set the contents of the paste buffer."
	PasteBuffer _ aMorphOrNil.

! !

!HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'!
pasteMorph

	| aPastee |
	PasteBuffer ifNil: [^ self inform: 'Nothing to paste.'].
	self attachMorph: (aPastee _ self objectToPaste).
	aPastee align: aPastee center with: self position.
	aPastee player ifNotNil: [aPastee player startRunning]
! !


!HandMorph methodsFor: 'private events' stamp: 'ar 2/2/2001 17:23'!
generateDropFilesEvent: evtBuf
	"Generate the appropriate mouse event for the given raw event buffer"
	"Note: This is still in an experimental phase and will need more work"
	| position buttons modifiers stamp numFiles dragType |
	stamp _ (evtBuf at: 2).
	stamp = 0 ifTrue:[stamp _ Time millisecondClockValue].
	dragType _ evtBuf at: 3.
	position _ (evtBuf at: 4) @ (evtBuf at: 5).
	buttons _ 0.
	modifiers _ (evtBuf at: 6).
	buttons _ buttons bitOr: (modifiers bitShift: 3).
	numFiles _ (evtBuf at: 7).
	dragType = 4 ifTrue:[
		"e.g., drop"
		owner borderWidth: 0.
		^DropFilesEvent new 
			setPosition: position 
			contents: numFiles 
			hand: self.
	].
	"the others are currently not handled by morphs themselves"
	dragType = 1 ifTrue:[
		"experimental drag enter"
		owner borderWidth: 4; borderColor: owner color negated.
	].
	dragType = 2 ifTrue:[
		"experimental drag move"
	].
	dragType = 3 ifTrue:[
		"experimental drag leave"
		owner borderWidth: 0.
	].
	^nil! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:07'!
generateKeyboardEvent: evtBuf
	"Generate the appropriate mouse event for the given raw event buffer"
	| buttons modifiers type keyValue pressType stamp |
	stamp _ (evtBuf at: 2).
	stamp = 0 ifTrue:[stamp _ Time millisecondClockValue].
	keyValue _ evtBuf at: 3.
	pressType _ evtBuf at: 4.
	pressType = EventKeyDown ifTrue:[type _ #keyDown].
	pressType = EventKeyUp ifTrue:[type _ #keyUp].
	pressType = EventKeyChar ifTrue:[type _ #keystroke].
	modifiers _ evtBuf at: 5.
	buttons _ modifiers bitShift: 3.
	^KeyboardEvent new
		setType: type
		buttons: buttons
		position: self position
		keyValue: keyValue
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/9/2000 17:54'!
generateMouseEvent: evtBuf
	"Generate the appropriate mouse event for the given raw event buffer"
	| position buttons modifiers type trail stamp oldButtons |
	stamp _ (evtBuf at: 2).
	stamp = 0 ifTrue:[stamp _ Time millisecondClockValue].
	position _ (evtBuf at: 3) @ (evtBuf at: 4).
	buttons _ (evtBuf at: 5).
	modifiers _ (evtBuf at: 6).
	buttons = 0 
		ifTrue:[	(lastEventBuffer at: 5) = 0
					ifTrue:[type _ #mouseMove]
					ifFalse:[type _ #mouseUp]]
		ifFalse:[	(lastEventBuffer at: 5) = 0
					ifTrue:[type _ #mouseDown]
					ifFalse:[type _ #mouseMove]].
	buttons _ buttons bitOr: (modifiers bitShift: 3).
	oldButtons _ (lastEventBuffer at: 5) bitOr: ((lastEventBuffer at: 6) bitShift: 3).
	lastEventBuffer _ evtBuf.
	type == #mouseMove ifTrue:[
		trail _ self mouseTrailFrom: evtBuf.
		^MouseMoveEvent new 
			setType: type 
			startPoint: trail first
			endPoint: trail last 
			trail: trail
			buttons: buttons
			hand: self
			stamp: stamp.
	].
	^MouseButtonEvent new 
		setType: type 
		position: position
		which: (oldButtons bitXor: buttons)
		buttons: buttons 
		hand: self
		stamp: stamp! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:08'!
mouseTrailFrom: currentBuf
	"Current event, a mouse event buffer, is about to be processed.  If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween."
	| nextEvent trail |
	trail _ WriteStream on: (Array new: 1).
	trail nextPut: ((currentBuf at: 3) @ (currentBuf at: 4)).
	[(nextEvent _ Sensor peekEvent) == nil] whileFalse:[
		(nextEvent at: 1) = (currentBuf at: 1) ifFalse:
			[^ trail contents  "different event type"].
		(nextEvent at: 5) = (currentBuf at: 5) ifFalse:
			[^ trail contents  "buttons changed"].
		(nextEvent at: 6) = (currentBuf at: 6) ifFalse:
			[^ trail contents  "modifiers changed"].
		"nextEvent is similar.  Remove it from the queue, and check the next."
		nextEvent _ Sensor nextEvent.
		trail nextPut: ((nextEvent at: 3) @ (nextEvent at: 4))
	].
	^trail contents! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:08'!
moveToEvent: anEvent
	"Issue a mouse move event to make the receiver appear at the given position"
	self handleEvent: (MouseMoveEvent new
		setType: #mouseMove 
		startPoint: self position 
		endPoint: anEvent position 
		trail: (Array with: self position with: anEvent position)
		buttons: anEvent buttons
		hand: self
		stamp: anEvent timeStamp)! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:08'!
sendEvent: anEvent focus: focusHolder
	"Send the event to the morph currently holding the focus, or if none to the owner of the hand."
	focusHolder ifNil:[^owner processEvent: anEvent].
	^self sendFocusEvent: anEvent to: focusHolder.! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/6/2000 00:08'!
sendFocusEvent: anEvent to: focusHolder
	"Send the event to the morph currently holding the focus"
	^focusHolder handleFocusEvent: 
		(anEvent transformedBy: (focusHolder transformedFrom: self)).! !

!HandMorph methodsFor: 'private events' stamp: 'ar 10/26/2000 01:43'!
sendListenEvent: anEvent to: listenerGroup
	"Send the event to the given group of listeners"
	listenerGroup ifNil:[^self].
	listenerGroup do:[:listener| 
		listener ifNotNil:[listener handleListenEvent: anEvent copy]].! !



!HandMorph methodsFor: 'private' stamp: 'ar 10/5/2000 19:48'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	(refStrm project world hands includes: self) ifTrue: [
		^ self].	"owned by the project"
	dp _ DiskProxy global: #World selector: #primaryHand args: #().
	refStrm replace: self with: dp.
	^ dp
	"Note, when this file is loaded in an MVC project, this will return nil.  The MenuItemMorph that has this in a field will have that item not work.  Maybe warn the user at load time?"! !

!HandMorph methodsFor: 'private' stamp: 'ar 10/26/2000 15:28'!
releaseCachedState
	| oo ui |
	ui _ userInitials.
	super releaseCachedState.
	cacheCanvas _ nil.
	oo _ owner.
	self removeAllMorphs.
	self initialize.	"nuke everything"
	self privateOwner: oo.
	self releaseAllFoci.
	self userInitials: ui andPicture: (self userPicture).! !

!HandMorph methodsFor: 'private' stamp: 'ar 10/6/2000 00:11'!
veryDeepCopyWith: deepCopier
	"Return self.  Do not copy hands this way."
	^ self! !

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

HandMorph class
	instanceVariableNames: ''!

!HandMorph class methodsFor: 'initialization' stamp: 'jm 5/13/1998 15:32'!
initialize
	"HandMorph initialize"

	PasteBuffer _ nil.
	DoubleClickTime _ 280.
	NormalCursor _ ColorForm mappingWhiteToTransparentFrom: Cursor normal.
! !


!HandMorph class methodsFor: 'accessing'!
doubleClickTime

	^ DoubleClickTime
! !

!HandMorph class methodsFor: 'accessing'!
doubleClickTime: milliseconds

	DoubleClickTime _ milliseconds.
! !


!HandMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !


!HandMorph class methodsFor: 'utilities' stamp: 'sma 4/30/2000 10:34'!
attach: aMorph
	"Attach aMorph the current world's primary hand."

	self currentWorld primaryHand attachMorph: aMorph! !

!HandMorph class methodsFor: 'utilities' stamp: 'ar 9/17/2000 17:02'!
newEventRules: aBool
	NewEventRules _ aBool.! !

!HandMorph class methodsFor: 'utilities' stamp: 'ar 10/4/2000 18:29'!
showEvents: aBool
	"HandMorph showEvents: true"
	"HandMorph showEvents: false"
	ShowEvents _ aBool.! !
HandMorph subclass: #HandMorphForReplay
	instanceVariableNames: 'recorder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!HandMorphForReplay commentStamp: '<historical>' prior: 0!
I am a hand for replaying events stored in an EventRecorderMorph.  When there are no more events, I delete myself.!


!HandMorphForReplay methodsFor: 'event dispatching' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !

!HandMorphForReplay methodsFor: 'event dispatching' stamp: 'di 3/4/1999 14:57'!
pauseEventRecorderIn: aWorld
	"Suspend my recorder prior to a project change, and return it.
	It will be resumed after starting the new project."

	^ recorder pauseIn: aWorld! !

!HandMorphForReplay methodsFor: 'event dispatching' stamp: 'ar 10/25/2000 22:14'!
processEvents
	"Play back the next event"
	| evt hadMouse hadAny |
	hadMouse _ hadAny _ false.
	[(evt _ recorder nextEventToPlay) == nil] whileFalse:[
		evt type == #EOF ifTrue: [recorder pauseIn: self world. ^self].
		evt type == #startSound ifTrue: [evt argument play.  recorder synchronize.  ^ self].
		evt isMouse ifTrue:[hadMouse _ true].
		(evt isMouse or:[evt isKeyboard]) ifTrue:[
			self handleEvent: (evt setHand: self) resetHandlerFields.
			hadAny _ true].
	].
	(mouseClickState notNil and:[hadMouse not]) ifTrue:[
		"No mouse events during this cycle. Make sure click states time out accordingly"
		mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
	hadAny ifFalse:[
		"No pending events. Make sure z-order is up to date"
		self mouseOverHandler processMouseOver: lastMouseEvent.
	].
! !


!HandMorphForReplay methodsFor: 'copying' stamp: 'LC 12/23/1998 13:26'!
veryDeepCopyWith: deepCopier
	^ self copy! !


!HandMorphForReplay methodsFor: 'halos' stamp: 'di 3/7/1999 00:00'!
showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset
	"When I show my cursor, it appears double size,
	unless it is a form such as a paint brush."

	cursorOrNil
	ifNil: ["Setting cursor to nil cannot revert to hardware cursor -- just show normal."
			^ self showTemporaryCursor: Cursor normal hotSpotOffset: Cursor normal offset]
	ifNotNil:
		[(cursorOrNil isKindOf: Cursor)
			ifTrue: ["Show cursors magnified for visibility"
					^ super showTemporaryCursor:
									(CursorWithMask derivedFrom: (cursorOrNil magnifyBy: 2))
				 				hotSpotOffset: (cursorOrNil offset negated*2) + hotSpotOffset]
			ifFalse: [^ super showTemporaryCursor: cursorOrNil
				 				hotSpotOffset: hotSpotOffset]]! !


!HandMorphForReplay methodsFor: 'initialization' stamp: 'ar 10/25/2000 20:58'!
initialize
	super initialize.
	self showTemporaryCursor: Cursor normal.
! !

!HandMorphForReplay methodsFor: 'initialization' stamp: 'di 3/3/1999 14:54'!
recorder: anEventRecorder
	recorder _ anEventRecorder! !

EllipseMorph subclass: #HandleMorph
	instanceVariableNames: 'pointBlock lastPointBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!HandleMorph commentStamp: '<historical>' prior: 0!
A HandleMorph provides mouse-up control behavior.!


!HandleMorph methodsFor: 'initialize' stamp: 'di 11/3/97 16:34'!
forEachPointDo: aBlock
	pointBlock _ aBlock! !

!HandleMorph methodsFor: 'initialize' stamp: 'di 8/30/2000 21:48'!
forEachPointDo: aBlock lastPointDo: otherBlock
	pointBlock _ aBlock.
	lastPointBlock _ otherBlock! !

!HandleMorph methodsFor: 'initialize' stamp: 'di 11/3/97 16:48'!
initialize
	super initialize.
	self extent: 8@8.
	self color: Color yellow.
! !


!HandleMorph methodsFor: 'stepping' stamp: 'ar 9/15/2000 23:24'!
startStepping
	"Make the receiver the keyboard focus for editing"
	super startStepping.
	"owner isHandMorph ifTrue:[owner newKeyboardFocus: self]."
self flag: #arNote. "make me #handleKeyboard:"! !

!HandleMorph methodsFor: 'stepping' stamp: 'di 11/3/97 16:34'!
step
	pointBlock value: self center! !

!HandleMorph methodsFor: 'stepping' stamp: 'di 11/3/97 16:54'!
stepTime
	"Update continuously."
	^ 0
! !


!HandleMorph methodsFor: 'termination' stamp: 'ar 9/15/2000 23:30'!
justDroppedInto: aMorph event: anEvent
	"So that when the hand drops me (into the world) I go away"
	lastPointBlock ifNotNil: [lastPointBlock value: self center].
	self flag: #arNote. "Probably unnecessary"
	anEvent hand releaseKeyboardFocus: self.
	self changed.
	self delete.
! !


!HandleMorph methodsFor: 'events' stamp: 'sw 6/30/1999 20:40'!
isCandidateForAutomaticViewing
	^ false! !

!HandleMorph methodsFor: 'events' stamp: 'ar 9/15/2000 23:30'!
keyStroke: evt
	"Check for cursor keys"
	| keyValue |
	owner isHandMorph ifFalse:[^self].
	keyValue _ evt keyValue.
	keyValue = 28 ifTrue:[^self position: self position - (1@0)].
	keyValue = 29 ifTrue:[^self position: self position + (1@0)].
	keyValue = 30 ifTrue:[^self position: self position - (0@1)].
	keyValue = 31 ifTrue:[^self position: self position + (0@1)].
	"Special case for return"
	keyValue = 13 ifTrue:[
		"Drop the receiver and be done"
	self flag: #arNote. "Probably unnecessary"
		owner releaseKeyboardFocus: self.
		self delete].
! !
EllipseMorph subclass: #HeadMorph
	instanceVariableNames: 'face queue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!HeadMorph methodsFor: 'initialization' stamp: 'len 9/26/1999 17:20'!
initialize
	super initialize.
	self color: self randomSkinColor.
	self face: FaceMorph new.
	self extent: self face extent * (1.5 @ 1.7).
	self face align: self face center with: self center + (0 @ self height // 10).
	self addRandomFurnitures.
	queue _ SharedQueue new! !


!HeadMorph methodsFor: 'accessing-private' stamp: 'len 9/6/1999 00:43'!
queue
	^ queue! !


!HeadMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 23:25'!
face
	^ face! !

!HeadMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 23:25'!
face: aFaceMorph
	face notNil ifTrue: [face delete].
	self addMorphFront: (face _ aFaceMorph)! !

!HeadMorph methodsFor: 'accessing' stamp: 'len 9/7/1999 01:38'!
playEvent: event at: time
	self queue nextPut: time -> event! !


!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 00:19'!
addAfroHair
	| hair |
	hair _ CurveMorph
		vertices: {115@4. 144@20. 166@79. 132@131. 116@93. 88@85. 54@94. 40@134. 2@79. 31@16. 79@1}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.9)) rounded.
	hair align: hair center with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 9/13/1999 00:51'!
addBeret
	| beret pompon |
	beret _ CurveMorph
		vertices: {66@1. 90@14. 106@22. 114@35. 98@43. 55@35. 20@46. 2@38. 8@23. 23@13. 39@7}
		color: Color random
		borderWidth: 1
		borderColor: Color black.
	beret extent: (beret extent * (self width / beret width * 4 / 3)) rounded.
	beret align: beret center x @ beret bottom with: self center x @ self face top.
	pompon _ EllipseMorph new color: beret color; borderWidth: 1; borderColor: Color black; extent: beret height // 2.
	pompon align: pompon center with: beret center x @ beret top.
	beret addMorphFront: pompon.
	self addMorphFront: beret! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 02:26'!
addEars
	| leftEar rightEar |
	leftEar _ EllipseMorph new color: self color; extent: self height // 10 @ (self height // 7).
	rightEar _ leftEar copy.
	leftEar align: leftEar center with: self left @ self center y.
	rightEar align: rightEar center with: self right @ self center y.
	self addMorphBack: leftEar; addMorphBack: rightEar! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/23/1999 12:57'!
addGlasses
	| glass glass2 diameter |
	diameter _ self face leftEye height * 2 // 3.
	glass _ EllipseMorph new extent: diameter @ diameter; color: (Color yellow alpha: 0.5).
	glass2 _ glass copy.
	glass align: glass center with: self face leftEye center.
	glass2 align: glass2 center with: self face rightEye center.
	self addMorph: glass; addMorph: glass2! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/23/1999 23:33'!
addHighHat
	| hat |
	hat _ CurveMorph
		vertices: {70@3. 98@11. 94@46. 112@50. 96@58. 53@50. 18@61. 2@58. 24@48. 30@6. 47@6}
		color: Color random
		borderWidth: 1
		borderColor: Color black.
	hat extent: (hat extent * (self width / hat width * 4 / 3)) rounded.
	hat align: hat center x @ hat bottom with: self center x @ self face top.
	self addMorphFront: hat! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 01:40'!
addLargeMustache
	| mustache |
	mustache _ CurveMorph
		vertices: {48@4. 75@3. 93@15. 48@9. 3@19. 17@5}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	mustache extent: (mustache extent * (self width / mustache width)) rounded.
	mustache align: mustache center with: self face mustachePosition.
	self addMorphFront: mustache! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 9/13/1999 00:52'!
addRandomFurnitures
	self color: self randomSkinColor.
	self perform: #(yourself addBeret addHighHat addAfroHair addShortHair addSpikyHair) atRandom.
	self perform: #(yourself yourself addShortMustache) atRandom! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 00:19'!
addShortHair
	| hair |
	hair _ CurveMorph
		vertices: {81@3. 101@22. 105@48. 93@65. 76@32. 54@32. 28@35. 11@64. 2@52. 10@15. 45@2}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.15)) rounded.
	hair align: hair center x @ (hair top * 4 + hair bottom // 5) with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 01:39'!
addShortMustache
	| mustache |
	mustache _ CurveMorph
		vertices: {29@1. 54@14. 30@11. 1@15}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	mustache extent: (mustache extent * (self width / mustache width * 0.5)) rounded.
	mustache align: mustache center with: self face mustachePosition.
	self addMorphFront: mustache! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 02:14'!
addSpikyHair
	| hair |
	hair _ PolygonMorph
		vertices: {83@3. 81@30. 91@27. 111@23. 97@32. 112@37. 99@45. 114@52. 95@53. 55@43. 10@50. 1@40. 14@40. 8@26. 24@37. 15@11. 29@29. 30@16. 36@30. 41@6. 49@31. 54@8. 61@32. 64@1. 70@27}
		color: self randomHairColor
		borderWidth: 1
		borderColor: Color black.
	hair extent: (hair extent * (self width / hair width * 1.15)) rounded.
	hair align: hair center with: self center x @ self top.
	self addMorphFront: hair! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/29/1999 02:53'!
addWhiteHat
	| stage1 stage2 |
	stage1 _ CurveMorph
		vertices: {18@1. 93@18. 91@45. 8@40}
		color: (Color r: 1.0 g: 0.968 b: 0.935)
		borderWidth: 1
		borderColor: Color black.
	stage1 extent: (stage1 extent * (self width / stage1 width * 1.20)) rounded.

	stage2 _ CurveMorph
		vertices: {27@7. 81@5. 111@34. 11@28}
		color: stage1 color
		borderWidth: 1
		borderColor: Color black.
	stage2 extent: (stage2 extent * (self width / stage2 width * 1.20)) rounded.

	stage1 align: stage1 center with: self center x @ self top.
	stage2 align: stage2 center with: stage1 center x @ stage1 top.

	stage1 addMorphFront: stage2.
	self addMorphFront: stage1! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/24/1999 01:51'!
randomHairColor
	| hairColors |
	hairColors _ {Color r: 0.613 g: 0.161 b: 0.0. "red"
		Color r: 0.323 g: 0.226 b: 0.0. "dark brown"
		Color r: 0.774 g: 0.548 b: 0.0. "light brown"
		Color r: 0.968 g: 0.871 b: 0.0. "yellow"
		Color r: 0.581 g: 0.581 b: 0.581. "gray"
		Color black}.
	self submorphs do: [ :each | (hairColors includes: each color) ifTrue: [^ each color]].
	^ hairColors atRandom! !

!HeadMorph methodsFor: 'furnitures' stamp: 'len 8/29/1999 22:27'!
randomSkinColor
	^ {Color r: 0.258 g: 0.161 b: 0.0.
		Color r: 0.452 g: 0.258 b: 0.0.
		Color r: 0.516 g: 0.323 b: 0.0.
		Color r: 1.0 g: 0.935 b: 0.645.
		Color r: 1.0 g: 0.806 b: 0.548} atRandom! !


!HeadMorph methodsFor: 'stepping and presenter' stamp: 'len 9/26/1999 17:25'!
step
	| now |
	super step.
	now _ Time millisecondClockValue.
	[queue isEmpty not and: [now >= queue peek key]]
		whileTrue: [queue next value actOn: self].
	self face lips updateShape! !

!HeadMorph methodsFor: 'stepping and presenter' stamp: 'len 9/6/1999 23:30'!
stepTime
	^ 0! !
RectangleMorph subclass: #HeadingMorph
	instanceVariableNames: 'degrees magnitude '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!HeadingMorph methodsFor: 'initialization'!
initialize

	super initialize.
	self color: (Color r:0.6 g: 1.0 b: 1.0).
	degrees _ 90.0.
	magnitude _ 1.0.
	self borderWidth: 1.
	self extent: 160@160.! !


!HeadingMorph methodsFor: 'accessing'!
degrees

	^ (degrees + 90.0) \\ 360.0! !

!HeadingMorph methodsFor: 'accessing'!
degrees: aNumber

	degrees _ (aNumber asFloat + 270.0) \\ 360.0.! !

!HeadingMorph methodsFor: 'accessing'!
extent: aPoint
	"Contrain extent to be square."

	| d |
	d _ aPoint x min: aPoint y.
	super extent: d@d.
! !

!HeadingMorph methodsFor: 'accessing'!
magnitude

	^ magnitude! !

!HeadingMorph methodsFor: 'accessing'!
magnitude: aNumber

	magnitude _ (aNumber asFloat max: 0.0) min: 1.0.! !


!HeadingMorph methodsFor: 'drawing'!
drawArrowFrom: p1 to: p2 width: w color: aColor on: aCanvas

	| d p |
	d _ (p1 - p2) theta radiansToDegrees.
	aCanvas line: p1 to: p2 width: w color: aColor.
	p _ p2 + (Point r: 5 degrees: d - 50).
	aCanvas line: p to: p2 width: w color: aColor.
	p _ p2 + (Point r: 5 degrees: d + 50).
	aCanvas line: p to: p2 width: w color: aColor.
! !

!HeadingMorph methodsFor: 'drawing'!
drawOn: aCanvas

	| x y r center box |
	super drawOn: aCanvas.
	box _ self innerBounds.
	1 to: 9 do: [:i |
		x _ box left + ((box width * i) // 10).
		aCanvas line: (x@box top) to: (x@(box bottom - 1)) color: 
Color black.
		y _ box top + ((box height * i) // 10).
		aCanvas line: (box left@y) to: ((box right - 1)@y) color: 
Color black].

	r _ ((box width asFloat * magnitude asFloat) / 2.0) - 1.0.
	center _ box center.
	self drawArrowFrom: center - (1@1)
		to: center + ((r * degrees degreesToRadians cos)@0) - (1@1)
		width: 3
		color: (Color red)
		on: aCanvas.
	self drawArrowFrom: center - (1@1)
		to: center + (0@(r * degrees degreesToRadians sin)) - (1@1)
		width: 3
		color: (Color red)
		on: aCanvas.
	self drawArrowFrom: center - (1@1)
		to: center + (Point r: r degrees: degrees) - (1@1)
		width: 3
		color: Color black
		on: aCanvas.
! !


!HeadingMorph methodsFor: 'events'!
handlesMouseDown: evt

	^ true
! !

!HeadingMorph methodsFor: 'events'!
mouseMove: evt

	| v |
	self changed.
	v _ evt cursorPoint - bounds center.
	degrees _ v theta radiansToDegrees.
	magnitude _ (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0.
! !
SequenceableCollection subclass: #Heap
	instanceVariableNames: 'array tally sortBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!Heap commentStamp: '<historical>' prior: 0!
Class Heap implements a special data structure commonly referred to as 'heap'. Heaps are more efficient than SortedCollections if:
a) Elements are only removed at the beginning
b) Elements are added with arbitrary sort order.
The sort time for a heap is O(n log n) in all cases.

Instance variables:
	array		<Array>		the data repository
	tally		<Integer>	the number of elements in the heap
	sortBlock	<Block|nil>	a two-argument block defining the sort order,
							or nil in which case the default sort order is
								[:element1 :element2| element1 <= element2]!


!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'!
at: index
	"Return the element at the given position within the receiver"
	(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
	^array at: index! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:14'!
at: index put: newObject
	"Heaps are accessed with #add: not #at:put:"
	^self shouldNotImplement! !

!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'!
first
	"Return the first element in the receiver"
	self emptyCheck.
	^array at: 1! !

!Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 14:08'!
reSort
	"Resort the entire heap"
	self isEmpty ifTrue:[^self].
	tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! !

!Heap methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:37'!
size
	"Answer how many elements the receiver contains."

	^ tally! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'!
sortBlock
	^sortBlock! !

!Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'!
sortBlock: aBlock
	sortBlock _ aBlock.
	sortBlock fixTemps.
	self reSort.! !


!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'!
isEmpty
	"Answer whether the receiver contains any elements."
	^tally = 0! !

!Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'!
sorts: element1 before: element2
	"Return true if element1 should be sorted before element2.
	This method defines the sort order in the receiver"
	^sortBlock == nil
		ifTrue:[element1 <= element2]
		ifFalse:[sortBlock value: element1 value: element2].! !


!Heap methodsFor: 'adding' stamp: 'ar 9/10/1999 13:04'!
add: anObject
	"Include newObject as one of the receiver's elements. Answer newObject."
	tally = array size ifTrue:[self grow].
	array at: (tally _ tally + 1) put: anObject.
	self upHeap: tally.
	^anObject! !


!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:04'!
remove: oldObject ifAbsent: aBlock
	"Remove oldObject as one of the receiver's elements. If several of the 
	elements are equal to oldObject, only one is removed. If no element is 
	equal to oldObject, answer the result of evaluating anExceptionBlock. 
	Otherwise, answer the argument, oldObject."
	1 to: tally do:[:i| 
		(array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]].
	^aBlock value! !

!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'!
removeAt: index
	"Remove the element at given position"
	(index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index].
	^self privateRemoveAt: index! !

!Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'!
removeFirst
	"Remove the first element from the receiver"
	^self removeAt: 1! !


!Heap methodsFor: 'comparing' stamp: 'ar 9/10/1999 13:05'!
= aHeap
	"Answer true if my and aHeap's species are the same,
	and if our blocks are the same, and if our elements are the same."

	self species = aHeap species ifFalse: [^ false].
	sortBlock = aHeap sortBlock
		ifTrue: [^ super = aHeap]
		ifFalse: [^ false]! !


!Heap methodsFor: 'enumerating' stamp: 'ar 9/10/1999 13:05'!
do: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument."
	1 to: tally do:[:i| aBlock value: (array at: i)]! !


!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:17'!
grow
	"Become larger."
	self growTo: self size + self growSize.! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
growSize
	"Return the size by which the receiver should grow if there are no empty slots left."
	^array size max: 5! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
growTo: newSize
	"Grow to the requested size."
	| newArray |
	newArray _ Array new: (newSize max: tally).
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray! !

!Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'!
trim
	"Remove any empty slots in the receiver."
	self growTo: self size.! !


!Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'!
downHeap: anIndex
	"Check the heap downwards for correctness starting at anIndex.
	 Everything above (i.e. left of) anIndex is ok."
	| value k n j |
	anIndex = 0 ifTrue:[^self].
	n _ tally bitShift: -1.
	k _ anIndex.
	value _ array at: anIndex.
	[k <= n] whileTrue:[
		j _ k + k.
		"use max(j,j+1)"
		(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
				ifTrue:[ j _ j + 1].
		"check if position k is ok"
		(self sorts: value before: (array at: j)) 
			ifTrue:[	"yes -> break loop"
					n _ k - 1]
			ifFalse:[	"no -> make room at j by moving j-th element to k-th position"
					array at: k put: (array at: j).
					"and try again with j"
					k _ j]].
	array at: k put: value.! !

!Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'!
downHeapSingle: anIndex
	"This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster."
	| value k n j |
	anIndex = 0 ifTrue:[^self].
	n _ tally bitShift: -1.
	k _ anIndex.
	value _ array at: anIndex.
	[k <= n] whileTrue:[
		j _ k + k.
		"use max(j,j+1)"
		(j < tally and:[self sorts: (array at: j+1) before: (array at: j)])
				ifTrue:[	j _ j + 1].
		array at: k put: (array at: j).
		"and try again with j"
		k _ j].
	array at: k put: value.
	self upHeap: k! !

!Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'!
upHeap: anIndex
	"Check the heap upwards for correctness starting at anIndex.
	 Everything below anIndex is ok."
	| value k kDiv2 tmp |
	anIndex = 0 ifTrue:[^self].
	k _ anIndex.
	value _ array at: anIndex.
	[ (k > 1) and:[self sorts: value before: (tmp _ array at: (kDiv2 _ k bitShift: -1))] ] 
		whileTrue:[
			array at: k put: tmp.
			k _ kDiv2].
	array at: k put: value.! !


!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:19'!
array
	^array! !

!Heap methodsFor: 'private' stamp: 'ar 9/15/2000 17:12'!
privateRemoveAt: index
	"Remove the element at the given index and make sure the sorting order is okay"
	| removed |
	removed _ array at: index.
	array at: index put: (array at: tally).
	array at: tally put: nil.
	tally _ tally - 1.
	index > tally ifFalse:[
		"Use #downHeapSingle: since only one element has been removed"
		self downHeapSingle: index].
	^removed! !

!Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:35'!
setCollection: aCollection
	array _ aCollection.
	tally _ 0.! !

!Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'!
setCollection: aCollection tally: newTally
	array _ aCollection.
	tally _ newTally.! !

!Heap methodsFor: 'private' stamp: 'sma 4/22/2000 19:30'!
species
	^ Array! !

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

Heap class
	instanceVariableNames: ''!

!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'!
new
	^self new: 10! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'!
new: n
	^super new setCollection: (Array new: n)! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 14:13'!
sortBlock: aBlock
	"Create a new heap sorted by the given block"
	^self new sortBlock: aBlock! !

!Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 13:23'!
withAll: aCollection
	"Create a new heap with all the elements from aCollection"
	^(self basicNew)
		setCollection: aCollection asArray copy tally: aCollection size;
		reSort;
		yourself! !


!Heap class methodsFor: 'examples' stamp: 'ar 9/10/1999 14:07'!
heapExample	"Heap heapExample"
	"Create a sorted collection of numbers, remove the elements
	sequentially and add new objects randomly.
	Note: This is the kind of benchmark a heap is designed for."
	| n rnd array time sorted |
	n _ 5000. "# of elements to sort"
	rnd _ Random new.
	array _ (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	time _ Time millisecondsToRun:[
		sorted _ Heap withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for Heap: ', time printString,' msecs'.
	"The quicksort version"
	time _ Time millisecondsToRun:[
		sorted _ SortedCollection withAll: array.
		1 to: n do:[:i| 
			sorted removeFirst.
			sorted add: rnd next].
	].
	Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'.
! !

!Heap class methodsFor: 'examples' stamp: 'ar 9/10/1999 13:32'!
heapSortExample	"Heap heapSortExample"
	"Sort a random collection of Floats and compare the results with
	SortedCollection (using the quick-sort algorithm) and 
	ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)."
	| n rnd array out time sorted |
	n _ 10000. "# of elements to sort"
	rnd _ Random new.
	array _ (1 to: n) collect:[:i| rnd next].
	"First, the heap version"
	out _ Array new: n. "This is where we sort into"
	time _ Time millisecondsToRun:[
		sorted _ Heap withAll: array.
		1 to: n do:[:i| sorted removeFirst].
	].
	Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'.
	"The quicksort version"
	time _ Time millisecondsToRun:[
		sorted _ SortedCollection withAll: array.
	].
	Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'.
	"The merge-sort version"
	time _ Time millisecondsToRun:[
		array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2].
	].
	Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'.
! !
FormInput subclass: #HiddenInput
	instanceVariableNames: 'name value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!HiddenInput commentStamp: '<historical>' prior: 0!
a "hidden" input.  It never actually appear on a formatted page, and the user can't change the input value.!


!HiddenInput methodsFor: 'private-initialization' stamp: 'ls 8/5/1998 06:37'!
name: name0  value: value0
	name _ name0.	
	value _ value0.! !


!HiddenInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:37'!
name
	^name! !

!HiddenInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:37'!
value
	^value! !

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

HiddenInput class
	instanceVariableNames: ''!

!HiddenInput class methodsFor: 'instance creation' stamp: 'ls 8/5/1998 06:38'!
name: name0  value: value
	^self new name: name0  value: value! !
Object subclass: #Hierarchical
	instanceVariableNames: 'myParent myChildren '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Objects'!
!Hierarchical commentStamp: '<historical>' prior: 0!
The Hierarchical class provides the basic functionality for parent-child relationships (and changing these relationships) for both the WonderlandScene and any WonderlandActors in the Wonderland.
!


!Hierarchical methodsFor: 'initialization' stamp: 'jsp 2/22/1999 12:08'!
initialize
	"Initialize this instance"

	myChildren _ OrderedCollection new.
! !


!Hierarchical methodsFor: 'private' stamp: 'jsp 2/23/1999 16:31'!
addChild: aChild
	"Add an object to this instance's list of children"

	((myChildren identityIndexOf: aChild) = 0) ifTrue: [ myChildren addLast: aChild ].
! !

!Hierarchical methodsFor: 'private' stamp: 'jsp 6/29/1999 02:36'!
appearsInChildLists
	"Returns true if this object should appear in the actor browser"

	^ true.! !

!Hierarchical methodsFor: 'private' stamp: 'jsp 6/29/1999 02:37'!
appendChildrenNamesTo: prefix
	"Return the object's children's names, each appended to the prefix."

	| nameList |

	nameList _ OrderedCollection new.
	myChildren do: [:child |
						(child appearsInChildLists) ifTrue: [
							nameList addLast: (prefix , (child getName)).
							nameList _ nameList , (child appendChildrenNamesTo: (prefix , '    '))].
					].
	^ nameList.
! !

!Hierarchical methodsFor: 'private' stamp: 'jsp 2/22/1999 12:10'!
removeChild: aChild
	"Remove an object from this instance's list of children"

	myChildren remove: aChild ifAbsent: [].
! !


!Hierarchical methodsFor: 'parent-child' stamp: 'ar 9/17/1999 12:28'!
allChildrenDo: aBlock
	"Execute aBlock for all children of the receiver"
	myChildren do:[:child|
		aBlock value: child.
		child allChildrenDo: aBlock].! !

!Hierarchical methodsFor: 'parent-child' stamp: 'jsp 6/29/1999 02:43'!
getAllChildren
	"Return all of this instance's children"

	| children |

	children _ OrderedCollection new.

	myChildren do: [:child | 
		(child appearsInChildLists)
			ifTrue: [
						children addLast: child.
						children _ children , (child getAllChildren).
					].
	].

	^ children.! !

!Hierarchical methodsFor: 'parent-child' stamp: 'jsp 2/22/1999 13:54'!
getChildren
	"Return the object's children."

	^ (myChildren copy).
! !

!Hierarchical methodsFor: 'parent-child' stamp: 'jsp 4/1/1999 17:13'!
getChildrenNames
	"Return the object's children."

	^ myChildren collect: [: child | child asString ].
! !

!Hierarchical methodsFor: 'parent-child' stamp: 'jsp 2/22/1999 12:08'!
getParent
	"Return the object's parent."

	^ myParent.
! !

!Hierarchical methodsFor: 'parent-child' stamp: 'jsp 2/22/1999 12:10'!
setParent: anObject
	"Set this instance's parent"

	myParent _ anObject.
! !

!Hierarchical methodsFor: 'parent-child' stamp: 'ar 9/17/1999 12:28'!
withAllChildrenDo: aBlock
	"Execute aBlock for all children of and the receiver itself"
	aBlock value: self.
	myChildren do:[:child|
		child withAllChildrenDo: aBlock.
	].! !

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

Hierarchical class
	instanceVariableNames: ''!

!Hierarchical class methodsFor: 'instance creation' stamp: 'jsp 2/22/1999 12:06'!
new
	"Create and initialize a new instance."

	^ super new initialize.
! !
Url subclass: #HierarchicalUrl
	instanceVariableNames: 'schemeName authority path query port '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!HierarchicalUrl commentStamp: '<historical>' prior: 0!
A URL which has a hierarchical encoding.  For instance, http and ftp URLs are hierarchical.!


!HierarchicalUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:44'!
hasContents
	"most of these do...."
	^true! !


!HierarchicalUrl methodsFor: 'parsing' stamp: 'mir 7/30/1999 13:05'!
privateInitializeFromText: aString

	| remainder ind nextTok s specifiedSchemeName |
	remainder _ aString.

	schemeName ifNil: [ 
		specifiedSchemeName _ Url schemeNameForString: remainder.
		specifiedSchemeName ifNotNil: [ 
			schemeName _ specifiedSchemeName.
			remainder _ remainder copyFrom: (schemeName size+2) to: remainder size ].
		schemeName ifNil: [ "assume HTTP"  schemeName _ 'http' ] ].

	"remove leading // if it's there"
	(remainder beginsWith: '//') ifTrue: [
		remainder _ remainder copyFrom: 3 to: remainder size ].


	"get the query"
	ind _ remainder indexOf: $?.
	ind > 0 ifTrue: [
		query _ (remainder copyFrom: ind+1 to: remainder size).
		remainder _ remainder copyFrom: 1 to: ind-1 ].

	"get the authority"
	ind _ remainder indexOf: $/.
	ind > 0 ifTrue: [
		ind = 1 ifTrue: [ authority _ '' ] ifFalse: [
			authority _ remainder copyFrom: 1 to: ind-1.
			remainder _ remainder copyFrom: ind+1 to: remainder size. ] ]
	ifFalse: [
		authority _ remainder.
		remainder _ ''. ].

	"Extract the port"
	(authority includes: $:)
		ifTrue: [
			port _ (authority copyFrom: (authority indexOf: $:) + 1 to: authority size) asNumber.
			authority _ authority copyUpTo: $:].

	"get the path"
	path _ OrderedCollection new.
	s _ ReadStream on: remainder.
	[ 
		s peek = $/ ifTrue: [ s next ].
		nextTok _ WriteStream on: String new.
		[ s atEnd or: [ s peek = $/ ] ] whileFalse: [ nextTok nextPut: s next ].
		nextTok _ nextTok contents unescapePercents.
		nextTok = '..' 
			ifTrue: [ path size > 0 ifTrue: [ path removeLast ] ]
			ifFalse: [ nextTok ~= '.' ifTrue: [ path add: nextTok ] ].
		s atEnd 
	] whileFalse.
	path isEmpty ifTrue: [ path add: '' ].! !

!HierarchicalUrl methodsFor: 'parsing' stamp: 'nk 10/9/2000 16:07'!
privateInitializeFromText: aString relativeTo: aUrl 
	| remainder ind nextTok s |
	remainder _ aString.
	"set the scheme"
	schemeName _ aUrl schemeName.
	"a leading // means the authority is specified, meaning it is absolute"
	(remainder beginsWith: '//')
		ifTrue: [^ self privateInitializeFromText: aString].
	"otherwise, use the same authority"
	authority _ aUrl authority.
	port _ aUrl port.
	"get the query"
	ind _ remainder indexOf: $?.
	ind > 0
		ifTrue: [query _ remainder copyFrom: ind + 1 to: remainder size.
			remainder _ remainder copyFrom: 1 to: ind - 1].
	"get the path"
	remainder isEmpty
		ifTrue: [path _ aUrl path]
		ifFalse: [(remainder beginsWith: '/')
				ifTrue: [path _ OrderedCollection new]
				ifFalse: [path _ aUrl path shallowCopy.
					path size > 0
						ifTrue: [path removeLast]].
			s _ ReadStream on: remainder.
			[s peek = $/
				ifTrue: [s next].
			nextTok _ WriteStream on: String new.
			[s atEnd
				or: [s peek = $/]]
				whileFalse: [nextTok nextPut: s next].
			nextTok _ nextTok contents unescapePercents.
			nextTok = '..'
				ifTrue: [path size > 0
						ifTrue: [path removeLast]]
				ifFalse: [nextTok ~= '.'
						ifTrue: [path add: nextTok]].
			s atEnd] whileFalse.
			path isEmpty
				ifTrue: [path add: '']]! !


!HierarchicalUrl methodsFor: 'private' stamp: 'ls 6/20/1998 19:41'!
schemeName: schemeName0  authority: authority0  path: path0  query: query0
	"initialize a new instance"
	schemeName _ schemeName0.
	authority _ authority0.
	path _ path0.
	query _ query0.
! !


!HierarchicalUrl methodsFor: 'printing' stamp: 'mir 9/29/2000 14:16'!
fullPath
	| ans |
	ans _ WriteStream on: String new.
	path do: [ :pathElem |
		ans nextPut: $/.
		ans nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		ans nextPut: $?.
		ans nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		ans nextPut: $#.
		ans nextPutAll: self fragment encodeForHTTP. ].
	
	^ans contents! !

!HierarchicalUrl methodsFor: 'printing' stamp: 'hmm 11/10/2000 16:32'!
toText
	| ans |
	ans _ WriteStream on: String new.
	ans nextPutAll: self schemeName.
	ans nextPutAll: '://'.
	ans nextPutAll: self authority.
	port ifNotNil: [ans nextPut: $:; print: port].
	path do: [ :pathElem |
		ans nextPut: $/.
		ans nextPutAll: pathElem encodeForHTTP. ].
	self query isNil ifFalse: [ 
		ans nextPut: $?.
		ans nextPutAll: self query. ].
	self fragment isNil ifFalse: [
		ans nextPut: $#.
		ans nextPutAll: self fragment encodeForHTTP. ].
	
	^ans contents! !


!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'!
authority
	^authority! !

!HierarchicalUrl methodsFor: 'access' stamp: 'tk 9/6/1998 12:45'!
isAbsolute
	
	path size > 0 ifFalse: [^ false].
	(path at: 1) size > 0 ifFalse: [^ false].
	^ ((path at: 1) at: 1) ~~ $.! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'!
path
	"return an ordered collection of the decoded path elements, as strings"
	^path! !

!HierarchicalUrl methodsFor: 'access' stamp: 'tk 9/19/1998 18:56'!
path: anArray

	path _ anArray! !

!HierarchicalUrl methodsFor: 'access' stamp: 'mir 7/30/1999 13:05'!
port
	^port! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:59'!
query
	"return the query, the part after any ?.  Any %XY's have already been decoded.  If there wasno query part, nil is returned (it is possible to also have an empty query"
	^query ! !

!HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:58'!
schemeName
	^schemeName! !

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

HierarchicalUrl class
	instanceVariableNames: ''!

!HierarchicalUrl class methodsFor: 'instance creation' stamp: 'ls 6/20/1998 19:41'!
schemeName: schemeName  authority: authority  path: path  query: query
	^self new schemeName: schemeName  authority: authority  path: path  query: query! !
Browser subclass: #HierarchyBrowser
	instanceVariableNames: 'classList centralClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:28'!
changed: sym
	sym == #classList ifTrue: [self updateAfterClassChange].
	super changed: sym! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'tk 4/3/98 11:09'!
classListIndex: newIndex
	"Cause system organization to reflect appropriate category"
	| newClassName ind |
	newIndex ~= 0 ifTrue:
		[newClassName _ (classList at: newIndex) copyWithout: $ .
		systemCategoryListIndex _
			systemOrganizer numberOfCategoryOfElement: newClassName].
	ind _ super classListIndex: newIndex.
	self changed: #systemCategorySingleton.
	^ ind! !

!HierarchyBrowser methodsFor: 'initialization'!
initAlphabeticListing
	| tab stab index |
	self systemOrganizer: SystemOrganization.
	metaClassIndicated _ false.
	classList _ Smalltalk classNames.! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:02'!
initHierarchyForClass: aClassOrMetaClass
	| tab stab index nonMetaClass |
	centralClass _ aClassOrMetaClass.
	nonMetaClass _ aClassOrMetaClass theNonMetaClass.
	self systemOrganizer: SystemOrganization.
	metaClassIndicated _ aClassOrMetaClass isMeta.
	classList _ OrderedCollection new.
	tab _ ''.
	nonMetaClass allSuperclasses reverseDo: 
		[:aClass | 
		classList add: tab , aClass name.
		tab _ tab , '  '].
	index _ classList size + 1.
	nonMetaClass allSubclassesWithLevelDo:
		[:aClass :level |
		stab _ ''.  1 to: level do: [:i | stab _ stab , '  '].
		classList add: tab , stab , aClass name]
	 	startingLevel: 0.
	self classListIndex: index! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'tk 4/5/98 10:29'!
openEditString: aString
	"Create a pluggable version of all the views for a HierarchyBrowser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."

	^ self openSystemCatEditString: aString! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 11/8/1999 09:38'!
potentialClassNames
	"Answer the names of all the classes that could be viewed in this browser"
	^ self classList collect:
		[:aName | aName copyWithout: $ ]! !

!HierarchyBrowser methodsFor: 'initialization'!
selectClass: classNotMeta
	| name |
	name _ classNotMeta name.
	self classListIndex: (self classList findFirst:
			[:each | (each endsWith: name)
					and: [each size = name size
							or: [(each at: each size - name size) isSeparator]]])! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 12/4/96'!
selectedClassName
	"Answer the name of the class currently selected.   di
	  bug fix for the case where name cannot be found -- return nil rather than halt"

	| aName |
	aName _ super selectedClassName.
	^ aName == nil
		ifTrue:
			[aName]
		ifFalse:
			[(aName copyWithout: $ ) asSymbol]! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'di 4/26/2000 20:20'!
systemCategorySingleton

	| cls |
	cls _ self selectedClass.
	^ cls ifNil: [Array new]
		ifNotNil: [Array with: cls category]! !

!HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:04'!
updateAfterClassChange
	"It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser."
	centralClass ifNotNil:
		[self initHierarchyForClass: centralClass]! !


!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/7/98 13:53'!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, if one 
	exists, with initial textual contents set to aString."

	self spawnHierarchy! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/3/98 11:22'!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	self inform: 'Use a normal Browser, in which you can see 
the entire category you are trying to remove.'! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 13:35'!
systemCatSingletonKey: aChar from: aView
	^ self systemCatListKey: aChar from: aView! !

!HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 14:08'!
systemCatSingletonMenu: aMenu

	^ aMenu labels:
'find class... (f)
browse
printOut
fileOut
update
rename...
remove' 
	lines: #(1 4)
	selections:
		#(findClass buildSystemCategoryBrowser
		printOutSystemCategory fileOutSystemCategory updateSystemCategories
		 renameSystemCategory removeSystemCategory )
! !


!HierarchyBrowser methodsFor: 'class list' stamp: 'mir 3/22/2000 13:02'!
classList
	classList _ classList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol].
	^ classList! !

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

HierarchyBrowser class
	instanceVariableNames: ''!

!HierarchyBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 02:10'!
newFor: aClass
	"Open a new HierarchyBrowser on the given class"
	|  newBrowser |
	newBrowser _ HierarchyBrowser new initHierarchyForClass: aClass.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: aClass theNonMetaClass name, ' hierarchy'

"HierarchyBrowser newFor: Boolean"! !

!HierarchyBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 18:20'!
newFor: aClass labeled: aLabel
	"Open a new HierarchyBrowser on the given class, using aLabel as the window title."

	|  newBrowser |
	newBrowser _ HierarchyBrowser new initHierarchyForClass: aClass.
	Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
		label: aLabel

"HierarchyBrowser newFor: Boolean labeled: 'Testing'"! !
HtmlSpecialEntity subclass: #HtmlAnchor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlAnchor methodsFor: 'testing' stamp: 'ls 10/26/1998 19:34'!
mayContain: anEntity 
	(self attributes includesKey: 'href') ifFalse: [
		"if we have no href, then we can contain nothing"
		^false ].

	^ anEntity isTextualEntity! !

!HtmlAnchor methodsFor: 'testing' stamp: 'ls 6/25/1998 03:04'!
tagName
	^'a'! !


!HtmlAnchor methodsFor: 'formatting' stamp: 'ls 9/10/1998 03:22'!
addToFormatter: formatter
	| href name |

	name _ self getAttribute: 'name'.
	name ifNotNil: [
		formatter noteAnchorStart: name ].

	href _ self getAttribute: 'href'.

	href isNil
		ifTrue: [ super addToFormatter: formatter ]
		ifFalse: [ 	
			formatter startLink: href.
			super addToFormatter: formatter.
			formatter endLink: href. ].
! !
HtmlEntity subclass: #HtmlArea
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlArea methodsFor: 'accessing' stamp: 'bolot 11/3/1999 17:48'!
coords
	^self getAttribute: 'coords'! !

!HtmlArea methodsFor: 'accessing' stamp: 'bolot 11/3/1999 17:48'!
href
	^self getAttribute: 'href'! !

!HtmlArea methodsFor: 'accessing' stamp: 'bolot 11/3/1999 17:48'!
shape
	^self getAttribute: 'shape'! !


!HtmlArea methodsFor: 'testing' stamp: 'bolot 11/4/1999 04:43'!
isArea
	^true! !

!HtmlArea methodsFor: 'testing' stamp: 'bolot 11/3/1999 18:06'!
mayContain: anEntity
	^false! !

!HtmlArea methodsFor: 'testing' stamp: 'bolot 11/3/1999 17:47'!
tagName
	^'area'! !


!HtmlArea methodsFor: 'formatting' stamp: 'bolot 2/27/2000 22:18'!
buildMorph
	"construct a hot-spot morph"
	| coords vertices radiusX radiusY |
	coords _ (self coords findTokens: ', ') collect: [:elem | elem asNumber asInteger].
	self shape isEmptyOrNil
		ifTrue: [^nil].

	(self shape asLowercase beginsWith: 'poly')
		ifTrue: [coords size even ifFalse: [^nil].
			vertices _ OrderedCollection new.
			coords pairsDo: [:x :y |
				vertices add: x @ y].
			^(PolygonMorph vertices: vertices color: Color transparent
				borderWidth: 1 borderColor: Color transparent) quickFill: false; makeClosed].

	(coords size > 4 or: [coords size < 3])
		ifTrue: [^nil].

	self shape asLowercase = 'circle'
		ifTrue: [radiusX _ coords third.
			radiusY _ coords last.
			^(EllipseMorph newBounds:
				(((coords first - radiusX) @ (coords second - radiusY))
				extent:
				((2 * radiusX) @ (2 * radiusY)))
			color: Color transparent) borderColor: Color transparent].

	coords size = 4
		ifFalse: [^nil].

	(self shape asLowercase beginsWith: 'rect')
		ifTrue: [^(RectangleMorph newBounds:
				(Rectangle origin: (coords first @ coords second)
				corner: (coords third @ coords last))
			color: Color transparent) borderColor: Color transparent].

	^nil! !

!HtmlArea methodsFor: 'formatting' stamp: 'bolot 2/28/2000 00:30'!
linkMorphForMap: map andBrowser: browser
	| m |
	(m _ self buildMorph) ifNil: [^nil].
	m color: (Color random alpha: 0.1). "hack to ensure the morph is clickable"
	m
		on: #mouseUp
		send: #mouseUpEvent:linkMorph:browserAndUrl:
		to: map
		withValue: {browser. self href}.
	^m! !
Dictionary subclass: #HtmlAttributes
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser'!

!HtmlAttributes methodsFor: 'printing' stamp: 'ls 7/23/1998 19:05'!
printHtmlOn: aStream
	self associationsDo: 
		[:element | 
		aStream 
			space;
			nextPutAll: element key asUppercase.
		element value ifNotNil: [  
				aStream nextPut: $=.
				aStream print: element value withoutQuoting]. ]! !
HtmlFontChangeEntity subclass: #HtmlBiggerFontEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlBiggerFontEntity commentStamp: '<historical>' prior: 0!
an entity which supposedly increases the font size of its constituents!

HtmlEntity subclass: #HtmlBlockEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlBlockEntity commentStamp: '<historical>' prior: 0!
a moderately high level entitiy.  This includes P, FORM, and UL, among others!


!HtmlBlockEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 03:02'!
isBlockEntity
	^true! !
HtmlBlockEntity subclass: #HtmlBlockQuote
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlBlockQuote methodsFor: 'testing' stamp: 'ls 7/17/1998 20:27'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlBlockQuote methodsFor: 'testing' stamp: 'ls 7/17/1998 20:26'!
tagName
	^'blockquote'! !


!HtmlBlockQuote methodsFor: 'formatting' stamp: 'ls 7/17/1998 20:26'!
addToFormatter: formatter
	formatter ensureNewlines: 1.
	formatter increaseIndent.
	super addToFormatter: formatter.
	formatter decreaseIndent.
	formatter ensureNewlines: 1.! !
HtmlEntity subclass: #HtmlBody
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlBody methodsFor: 'lint' stamp: 'ls 7/29/1998 00:24'!
shouldContain: anEntity
	"I don't *think* there are any elements that can be in both the header and the body..."
	^anEntity isHeadElement not! !


!HtmlBody methodsFor: 'testing' stamp: 'ls 7/4/1998 19:24'!
mayContain: anEntity
	"Body's can contain anything, so that even if we screw up the parsing, all the text will end up actually being included"
	^true! !

!HtmlBody methodsFor: 'testing' stamp: 'ls 6/25/1998 02:04'!
tagName
	^'body'! !


!HtmlBody methodsFor: 'attributes' stamp: 'bolot 12/8/1999 01:40'!
background
	^self getAttribute: 'background' default: nil! !

!HtmlBody methodsFor: 'attributes' stamp: 'bolot 12/8/1999 01:41'!
bgcolor
	^self getAttribute: 'bgcolor' default: 'white'! !
HtmlFontChangeEntity subclass: #HtmlBoldEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlBoldEntity commentStamp: '<historical>' prior: 0!
an entity which displays its contents in boldface!


!HtmlBoldEntity methodsFor: 'formatting' stamp: 'ls 6/27/1998 12:53'!
addToFormatter: formatter
	formatter increaseBold.
	super addToFormatter: formatter.
	formatter decreaseBold.! !
HtmlSpecialEntity subclass: #HtmlBreak
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlBreak methodsFor: 'testing' stamp: 'ls 7/4/1998 16:14'!
mayContain: anEntity
	^false! !

!HtmlBreak methodsFor: 'testing' stamp: 'ls 7/4/1998 16:14'!
tagName
	^'br'! !


!HtmlBreak methodsFor: 'formatting' stamp: 'ls 7/17/1998 19:21'!
addToFormatter: formatter
	formatter addChar: Character cr.! !
HtmlFormEntity subclass: #HtmlButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlButton methodsFor: 'testing' stamp: 'ls 7/21/1998 07:04'!
mayContain: anEntity
	^false! !

!HtmlButton methodsFor: 'testing' stamp: 'ls 7/21/1998 07:04'!
tagName
	^'button'! !
HtmlToken subclass: #HtmlComment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Tokenizer'!
!HtmlComment commentStamp: '<historical>' prior: 0!
A comment, eg <!!-- this is a comment -->
Normally this is ignored, but it's included so that every byte in the
input gets put into one tag or another.!


!HtmlComment methodsFor: 'parser support' stamp: 'ls 6/25/1998 02:37'!
entityFor
	^self shouldNotImplement! !


!HtmlComment methodsFor: 'properties' stamp: 'ls 1/25/98 04:57'!
isComment
	^true! !


!HtmlComment methodsFor: 'access' stamp: 'ls 1/25/98 04:56'!
text
	"return the text of the comment, the part inside the <!!-- and -->"
	^self notYetImplemented! !
HtmlTextualEntity subclass: #HtmlCommentEntity
	instanceVariableNames: 'commentText '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlCommentEntity commentStamp: '<historical>' prior: 0!
a comment from the page!


!HtmlCommentEntity methodsFor: 'private-iniitialization' stamp: 'ls 7/28/1998 20:28'!
initializeWithText: aString
	super initialize.
	commentText _ aString.! !


!HtmlCommentEntity methodsFor: 'printing' stamp: 'ls 10/26/1998 17:08'!
printHtmlOn: aStream indent: indent 
	indent timesRepeat: [aStream space].
	aStream nextPutAll: '<!!-- '.
	aStream nextPutAll: self commentText.
	aStream nextPutAll: ' -->'.
	aStream cr! !

!HtmlCommentEntity methodsFor: 'printing' stamp: 'ls 10/26/1998 17:08'!
printOn: aStream indent: indent 
	self printHtmlOn: aStream indent: indent! !


!HtmlCommentEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 16:30'!
isComment
	^true! !

!HtmlCommentEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:27'!
mayContain: anEntity
	^false! !

!HtmlCommentEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:30'!
tagName	
	"return a bogus tag name"
	^'x-comment'! !


!HtmlCommentEntity methodsFor: 'formatting' stamp: 'ls 7/4/1998 12:27'!
addToFormatter: formatter
	"do nothing"! !


!HtmlCommentEntity methodsFor: 'access' stamp: 'ls 7/4/1998 12:27'!
commentText
	^commentText! !
HtmlDefinitionListElement subclass: #HtmlDefinitionDefinition
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlDefinitionDefinition methodsFor: 'formatting' stamp: 'ls 7/4/1998 01:12'!
addToFormatter: formatter
	formatter ensureNewlines: 1.
	formatter increaseIndent.
	super addToFormatter: formatter.
	formatter decreaseIndent.! !


!HtmlDefinitionDefinition methodsFor: 'testing' stamp: 'ls 7/4/1998 00:20'!
mayContain: anEntity
	^anEntity isBlockEntity or: [ anEntity isTextualEntity ] ! !

!HtmlDefinitionDefinition methodsFor: 'testing' stamp: 'ls 7/4/1998 00:18'!
tagName
	^'dd'! !
HtmlBlockEntity subclass: #HtmlDefinitionList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlDefinitionList methodsFor: 'testing' stamp: 'ls 7/4/1998 00:17'!
mayContain: anEntity
	^anEntity isDefinitionListElement! !

!HtmlDefinitionList methodsFor: 'testing' stamp: 'ls 7/4/1998 00:17'!
tagName
	^'dl'! !


!HtmlDefinitionList methodsFor: 'formatting' stamp: 'ls 7/4/1998 01:14'!
addToFormatter: formatter
	super addToFormatter: formatter.
	formatter ensureNewlines: 1.! !
HtmlEntity subclass: #HtmlDefinitionListElement
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlDefinitionListElement methodsFor: 'testing' stamp: 'ls 6/25/1998 02:19'!
isDefinitionListElement
	^true! !
HtmlDefinitionListElement subclass: #HtmlDefinitionTerm
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlDefinitionTerm methodsFor: 'formatting' stamp: 'ls 7/4/1998 01:14'!
addToFormatter: formatter
	formatter ensureNewlines: 1.
	super addToFormatter: formatter.! !


!HtmlDefinitionTerm methodsFor: 'testing' stamp: 'ls 7/4/1998 00:19'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlDefinitionTerm methodsFor: 'testing' stamp: 'ls 7/4/1998 00:17'!
tagName
	^'dt'! !
HtmlEntity subclass: #HtmlDocument
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlDocument commentStamp: '<historical>' prior: 0!
an entire HTML document.  It should have exactly two sub-entities when completed: a HEAD and a BODY!


!HtmlDocument methodsFor: 'testing' stamp: 'ls 6/25/1998 02:57'!
mayContain: anElement
	^true 	"not strictly true, but it makes the parser simpler"! !

!HtmlDocument methodsFor: 'testing' stamp: 'ls 6/25/1998 02:06'!
tagName
	^'html'! !


!HtmlDocument methodsFor: 'access' stamp: 'djp 7/21/1998 18:38'!
addToBody: anObject
	"add an object to the Body entity of the receiver"
	self body add: anObject! !

!HtmlDocument methodsFor: 'access' stamp: 'djp 7/21/1998 18:37'!
addToHead: anObject
	"add an object to the head entity of the receiver"
	self head add: anObject! !

!HtmlDocument methodsFor: 'access' stamp: 'djp 7/21/1998 18:28'!
body
	^self contents at: 2! !

!HtmlDocument methodsFor: 'access' stamp: 'djp 7/21/1998 18:28'!
head
	^self contents at: 1! !


!HtmlDocument methodsFor: 'formatting' stamp: 'bolot 5/18/2000 11:37'!
formattedText
	"return a version of this document as a formatted Text"
	| formatter |
	formatter _ HtmlFormatter preferredFormatterClass new.
	self addToFormatter: formatter.
	^formatter text ! !

!HtmlDocument methodsFor: 'formatting' stamp: 'bolot 5/18/2000 11:37'!
formattedTextForBrowser: browser  defaultBaseUrl: defaultBaseUrl
	"return a version of this document as a formatted Text (which includes links and such)"
	| formatter text |

	"set up the formatter"
	formatter _ HtmlFormatter preferredFormatterClass new.
	formatter browser: browser.
	formatter baseUrl: defaultBaseUrl.  "should check if the document specifies something else"

	"do the formatting"
	self addToFormatter: formatter.

	"get and return the result"
	text _ formatter text.
	^text! !

!HtmlDocument methodsFor: 'formatting' stamp: 'bolot 5/18/2000 11:37'!
formattedTextMorph
	"return a version of this document as a formatted TextMorph (which includes links and such)"
	| formatter text textMorph |
	formatter _ HtmlFormatter preferredFormatterClass new.
	self addToFormatter: formatter.
	text _ formatter text .

	textMorph _ TextMorph new initialize.
	textMorph contentsWrapped: text.

	^textMorph! !

!HtmlDocument methodsFor: 'formatting' stamp: 'bolot 5/18/2000 11:37'!
formattedTextMorphForBrowser: browser  defaultBaseUrl: defaultBaseUrl
	"return a version of this document as a formatted TextMorph (which includes links and such)"
	| formatter textMorph |

	"set up the formatter"
	formatter _ HtmlFormatter preferredFormatterClass new.
	formatter browser: browser.
	formatter baseUrl: defaultBaseUrl.  "should check if the document specifies something else"

	"do the formatting"
	self addToFormatter: formatter.

	"get and return the result"
	textMorph _ formatter textMorph .
	^textMorph! !

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

HtmlDocument class
	instanceVariableNames: ''!

!HtmlDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 04:26'!
emptyDocument
	"return an empty document"
	^super new add: HtmlHead new; add: HtmlBody new! !
HtmlSpecialEntity subclass: #HtmlEmbedded
	instanceVariableNames: ''
	classVariableNames: 'ExtensionList '
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlEmbedded methodsFor: 'attributes' stamp: 'ar 11/18/1998 19:07'!
extent
	"the image extent, according to the WIDTH and HEIGHT attributes.  returns nil if either WIDTH or HEIGHT is not specified"
	| widthText heightText |
	widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
	heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
	^ widthText asNumber @ heightText asNumber! !

!HtmlEmbedded methodsFor: 'attributes' stamp: 'ar 11/18/1998 19:07'!
src
	^self getAttribute: 'src' default: nil! !


!HtmlEmbedded methodsFor: 'testing' stamp: 'ar 11/18/1998 19:07'!
mayContain: anEntity
	^false! !

!HtmlEmbedded methodsFor: 'testing' stamp: 'ar 11/18/1998 19:07'!
tagName
	^'embed'! !


!HtmlEmbedded methodsFor: 'formatting' stamp: 'ar 11/18/1998 20:56'!
addToFormatter: formatter
	| url embeddedMorph |
	self src isNil ifTrue:[^self].
	url _ self src.
	embeddedMorph _ self embeddedMorphFor: url.
	embeddedMorph isNil ifTrue:[^self].
	formatter baseUrl ifNotNil:[url _ url asUrlRelativeTo: formatter baseUrl].
	embeddedMorph extent: self extent.
	embeddedMorph sourceUrl: url.
	embeddedMorph setProperty: #embedded toValue: true.
	formatter addIncompleteMorph: embeddedMorph.! !

!HtmlEmbedded methodsFor: 'formatting' stamp: 'ar 11/19/1998 22:47'!
embeddedMorphClassFor: url
	| lastIndex extension className |
	lastIndex _ url findLast:[:c| c = $.].
	lastIndex = 0 ifTrue:[^nil].
	extension _ url copyFrom: lastIndex+1 to: url size.
	className _ ExtensionList at: extension asLowercase ifAbsent:[^nil].
	^Smalltalk at: className ifAbsent:[nil]
	! !

!HtmlEmbedded methodsFor: 'formatting' stamp: 'ar 11/18/1998 19:16'!
embeddedMorphFor: url
	| morphClass |
	morphClass _ self embeddedMorphClassFor: url.
	^morphClass ifNotNil:[morphClass new]! !

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

HtmlEmbedded class
	instanceVariableNames: ''!

!HtmlEmbedded class methodsFor: 'initialize' stamp: 'ar 11/19/1998 22:46'!
initialize
	"HtmlEmbedded initialize"
	ExtensionList _ Dictionary new.
	#(
		('swf'	FlashPlayerMorph)
	) do:[:spec| ExtensionList at: spec first put: spec last].! !
Object subclass: #HtmlEntity
	instanceVariableNames: 'contents attribs '
	classVariableNames: 'ReverseCharacterEntities '
	poolDictionaries: ''
	category: 'HTML-Parser-Entities'!
!HtmlEntity commentStamp: '<historical>' prior: 0!
<html>When HtmlParser runs, it generates a tree whose nodes are in HtmlEntity's subclasses.  There is a separate class for most of the available elements in HTML, though some are grouped together under generic classes like HtmlBoldEntity.

Methods of particular interest when modifying or adding subclasses are:
<ul>
<li>initialize:
<li>mayContain:
<li>addToFormatter:
</ul>
!


!HtmlEntity methodsFor: 'downloading' stamp: 'ls 7/29/1998 00:52'!
downloadState: baseUrl
	"download any state needed for full rendering.  eg, images need this"
	! !


!HtmlEntity methodsFor: 'categorization' stamp: 'ls 7/29/1998 00:26'!
isFrame
	^false! !

!HtmlEntity methodsFor: 'categorization' stamp: 'ls 7/29/1998 00:26'!
isFrameSet
	^false! !


!HtmlEntity methodsFor: 'user interface' stamp: 'djp 7/21/1998 18:35'!
inspect
	"Open an HtmlEntityInspector on the receiver.
	Use basicInspect to get a normal type of inspector."

	HtmlEntityInspector openOn: self withEvalPane: true! !

!HtmlEntity methodsFor: 'user interface' stamp: 'djp 7/21/1998 18:35'!
inspectWithLabel: aLabel
	"Open a HtmlEntityInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector."

	HtmlEntityInspector openOn: self withEvalPane: true withLabel: aLabel! !


!HtmlEntity methodsFor: 'converting' stamp: 'djp 7/21/1998 11:58'!
asHtml
	| aStream |
	aStream := WriteStream on: ''.
	self printHtmlOn: aStream.
	^aStream contents.! !


!HtmlEntity methodsFor: 'accessing' stamp: 'djp 7/21/1998 16:21'!
add: anObject
	"add an object to the receiver"
	(anObject isKindOf: String)
		ifTrue: [contents add: (HtmlTextEntity new text: anObject)]
		ifFalse: [contents add: anObject]! !

!HtmlEntity methodsFor: 'accessing' stamp: 'djp 7/21/1998 13:51'!
at: key put: anObject
	self attributes ifNil: [self attributes: (HtmlAttributes new)].
	(self attributes) at: key put: anObject! !

!HtmlEntity methodsFor: 'accessing' stamp: 'djp 7/21/1998 16:28'!
attributes
	^attribs ifNil: [attribs := HtmlAttributes new]! !


!HtmlEntity methodsFor: 'formatting' stamp: 'ls 6/25/1998 15:01'!
addToFormatter: aFormatter
	"by default, just format our childer"
	contents do: [ :e | e addToFormatter: aFormatter ]! !

!HtmlEntity methodsFor: 'formatting' stamp: 'ls 7/15/1998 18:31'!
parsingFinished
	"some entities need to make a final pass *after* parsing has finished and all the contents of each entity have been established; here is a place to do that"
	contents do: [ :e | e parsingFinished ].! !


!HtmlEntity methodsFor: 'contents' stamp: 'ls 6/25/1998 02:03'!
addEntity: anEntity
	"add an entity to the receiver"
	contents add: anEntity! !

!HtmlEntity methodsFor: 'contents' stamp: 'ls 6/25/1998 02:02'!
contents
	"return an ordered collection of this entity's contents"
	^contents! !

!HtmlEntity methodsFor: 'contents' stamp: 'ls 10/26/1998 17:24'!
removeEntity: anEntity 
	"remove the specified entity"
	contents remove: anEntity! !

!HtmlEntity methodsFor: 'contents' stamp: 'ls 10/26/1998 17:25'!
subEntities
	"return an ordered collection of this entity's contents"
	^ contents! !

!HtmlEntity methodsFor: 'contents' stamp: 'ls 7/5/1998 00:37'!
textualContents
	"return a string with the concatenated contents of all textual sub-entities"
	^String streamContents: [ :s |
		contents do: [ :e | s nextPutAll: e textualContents ] ]! !


!HtmlEntity methodsFor: 'private-initialization' stamp: 'ls 7/31/1998 02:57'!
initialize
	contents _ OrderedCollection new.
	attribs _ HtmlAttributes new.! !

!HtmlEntity methodsFor: 'private-initialization' stamp: 'djp 7/20/1998 20:52'!
initialize: aTag
	self initialize.
	attribs _ HtmlAttributes newFrom: aTag attribs.! !


!HtmlEntity methodsFor: 'testing' stamp: 'bolot 11/4/1999 04:42'!
isArea
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 03:02'!
isBlockEntity
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 16:30'!
isComment
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:20'!
isDefinitionListElement
	"whether receiver can appear in a DefinitionList"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/16/1998 23:18'!
isFormEntity
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:54'!
isHeadElement
	"whether this can appear in a header"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:55'!
isHeader
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:18'!
isListElement
	"is this an HtmlListElement, ie can it appear in a (non-definition) list?"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 03:12'!
isListItem
	"is this an HtmlListItem, ie can it appear in a (non-definition) list?"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/21/1998 07:33'!
isOption
	"whether this is an <option> entity"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 03:03'!
isParagraph
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:54'!
isTableDataItem
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:53'!
isTableItem
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 12:53'!
isTableRow
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:20'!
isTextualEntity
	"is receiver either text, or some low-level text-like entity such as <b> or <em>"
	^false! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/28/1998 20:09'!
lint
	^String streamContents: [ :s | self lint: s ]! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/28/1998 20:37'!
lint: aStream
	"do a lint check, reporting to aStream"
	self lintAttributes: aStream.

	contents do: [ :c |
		(c isComment not   and:  [ (self shouldContain: c) not ]) ifTrue: [ 
			aStream nextPutAll: '<', self tagName, '> should not contain <', c tagName, '>'.
			aStream cr. ] ].

	contents do: [ :c  | c lint: aStream ]! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/28/1998 20:07'!
lintAttributes: aStream
	"check that our attributes are okay.  Print any anomalies to aStream"
	! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:03'!
mayContain: anEntity
	"whether we can contain the given entity"
	^self subclassResponsibility! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:01'!
mayContainEntity: anEntity
	"whether we can contain the given entity"
	^self subclassResponsibility! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 7/28/1998 20:35'!
shouldContain: anEntity
	"whether, according to the HTML DTD, this element should actually contain anEntity.  Used for checking the quality of a pages HTML"
	^self mayContain: anEntity! !

!HtmlEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:02'!
tagName
	"tag name for ourself"
	^self subclassResponsibility! !


!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/26/1998 19:59'!
attributes: newAttributes
	"set all of the attributes at once.  newAttributes should not be modified after passing it in"
	^attribs _ newAttributes! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/31/1998 02:55'!
doesNotUnderstand: aMessage
	"treat the message as an attribute name"
	| selector |
	selector _ aMessage selector.

	selector asLowercase = selector ifFalse: [
		"attribute accesses must be in all lowercase.  This should cut down on some false doesNotUnderstand: traps"
		^super doesNotUnderstand: aMessage ].

	selector numArgs == 0 ifTrue: [
		"return the named attribute"
		^self getAttribute: selector asString default: nil ].


	selector numArgs == 1 ifTrue: [
		"set the named attribute"
		self setAttribute: (selector asString copyFrom: 1 to: (selector size-1)) to: aMessage argument.
		^self ].

	^super doesNotUnderstand: aMessage! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 8/5/1998 07:20'!
getAttribute: name
	^self getAttribute: name  default: nil! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/15/1998 18:52'!
getAttribute: name  default: anObject
	^self getAttribute: name  ifAbsent: [anObject]! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/15/1998 18:51'!
getAttribute: name  ifAbsent: aBlock
	^attribs at: name ifAbsent: aBlock! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/17/1998 19:04'!
name
	^self getAttribute: 'name' default: nil! !

!HtmlEntity methodsFor: 'attributes' stamp: 'ls 7/31/1998 03:00'!
setAttribute: name  to: value
	"set the given attribute to the given value"
	attribs at: name asLowercase  put: value! !


!HtmlEntity methodsFor: 'printing' stamp: 'djp 7/20/1998 21:12'!
printHtmlOn: aStream
	^self printHtmlOn: aStream  indent: 0! !

!HtmlEntity methodsFor: 'printing' stamp: 'ls 10/30/1998 10:08'!
printHtmlOn: aStream indent: indent 
	aStream next: indent put: $ ;
	 nextPutAll: '<';
	 nextPutAll: self tagName.
	self attributes associationsDo: [:assoc | aStream space; nextPutAll: assoc key; nextPutAll: '="'; nextPutAll: assoc value; nextPutAll: '"'].
	aStream nextPut: $>;
	 cr.
	contents do: [:entity | entity printHtmlOn: aStream indent: indent + 1].
	aStream nextPutAll: '</'; nextPutAll: self tagName; nextPutAll: '>'.! !

!HtmlEntity methodsFor: 'printing' stamp: 'ls 6/25/1998 03:13'!
printOn: aStream
	^self printOn: aStream  indent: 0! !

!HtmlEntity methodsFor: 'printing' stamp: 'ls 8/11/1998 03:16'!
printOn: aStream  indent: indent
	aStream
		next: indent put: $ ;
		nextPut: $<;
		print: self tagName.

	self attributes associationsDo: [ :assoc |
		aStream
			space;
			nextPutAll: assoc key;
			nextPutAll: '=';
			nextPutAll: assoc value ].

	aStream
		nextPut: $>;
		cr.
	contents do: [ :entity | entity printOn: aStream indent: indent+1 ].! !


!HtmlEntity methodsFor: 'enumeration' stamp: 'ls 7/16/1998 23:17'!
allSubentitiesDo: aBlock
	"perform the block recursively on all sub-entities"
	contents do: [ :e | 
		aBlock value: e .
		e allSubentitiesDo: aBlock.
	].
	! !

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

HtmlEntity class
	instanceVariableNames: ''!

!HtmlEntity class methodsFor: 'instance creation' stamp: 'ls 7/29/1998 01:27'!
forTag: aTag
	"create a new entity based on the given tag"
	^self new initialize: aTag! !

!HtmlEntity class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 13:17'!
new
	^super new initialize! !


!HtmlEntity class methodsFor: 'class initialization' stamp: 'bf 11/4/1999 23:10'!
initialize
	"HtmlEntity initialize"

	ReverseCharacterEntities _ Dictionary new: 128.
	#('quot' $" 'lt' $< 'amp' $& 'gt' $> ) pairsDo:
		[:s :c | ReverseCharacterEntities at: s put: c asciiValue].
	#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo:
		[:s :i | ReverseCharacterEntities at: s put: i - 1 + 160].! !


!HtmlEntity class methodsFor: 'character entities' stamp: 'bf 11/4/1999 23:13'!
valueOfHtmlEntity: specialEntity
	^Character value: (ReverseCharacterEntities at: specialEntity ifAbsent:
		[(specialEntity beginsWith: '#') ifTrue:
			[(specialEntity copyFrom: 2 to: specialEntity size) asNumber]
			ifFalse: [^nil]])
! !
Inspector subclass: #HtmlEntityInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser'!

!HtmlEntityInspector methodsFor: 'accessing' stamp: 'djp 7/21/1998 17:21'!
fieldList
	^ super fieldList, (Array with: 'asHtml')! !

!HtmlEntityInspector methodsFor: 'accessing' stamp: 'ls 7/24/1998 01:40'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  "

	^ 300 @ 300! !


!HtmlEntityInspector methodsFor: 'selecting' stamp: 'ls 7/23/1998 07:37'!
selection
	selectionIndex = self fieldList size 
		ifTrue: [^object asHtml]
		ifFalse: [^super selection]! !
CrLfFileStream subclass: #HtmlFileStream
	instanceVariableNames: 'prevPreamble '
	classVariableNames: 'TabThing '
	poolDictionaries: ''
	category: 'System-Files'!
!HtmlFileStream commentStamp: '<historical>' prior: 0!
The Class apes StandardFileStream, but converts the text to HTML before putting it out (primarily intended for printOut).  It can be invoked with

	((FileStream fileNamed: 'changes.html') asHtml) fileOutChanges

Use usual FileStream methods to put out text converted to
	HTML fairly approximating that text  (for best looks, use 
	method:, methodHeader:, methodBody:, for code);

verbatim: puts text out without conversion;

command: put out HTML items, such as <br>, supplying the brackets.

header: and trailer: put out an HTML wrapper (preamble and closing text)

nextPut does the actual conversion, nextPutAll: defers characters to nextPut.

The code is fairly dumb at present, doing a wooden straightforward conversion of the text without attempting to capture the style or fonts in which the original text was rendered.  Tabs are handled awkwardly, using &nbsp, so that probably only leading strings are working right.  Style sheets now permit us to do a much neater looking job if there is interest in improving the looks of things.!
]style[(1039)f1cred;!


!HtmlFileStream methodsFor: 'HTML'!
command: aString
	"Append HTML commands directly without translation.  Caller should not include < or >.  Note that font change info comes through here!!  4/5/96 tk"

	(aString includes: $<) ifTrue: [self error: 'Do not put < or > in arg'].
		"We do the wrapping with <> here!!  Don't put it in aString."
	^ self verbatim: '<', aString, '>'! !


!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 08:35'!
copyMethodChunkFrom: aStream
	"Overridden to bolden the first line (presumably a method header)"
	| terminator code firstLine |
	terminator _ $!!.
	aStream skipSeparators.
	code _ aStream upTo: terminator.
	firstLine _ code copyUpTo: Character cr.
	firstLine size = code size
		ifTrue: [self nextPutAll: code]
		ifFalse: [self command: 'b'; nextPutAll: firstLine; command: '/b'.
				self nextPutAll: (code copyFrom: firstLine size + 1 to: code size)].
	self nextPut: terminator.
	[aStream peekFor: terminator] whileTrue:   "case of imbedded (doubled) terminators"
			[self nextPut: terminator;
				nextPutAll: (aStream upTo: terminator);
				nextPut: terminator]! !

!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:21'!
copyPreamble: preamble from: aStream
	"Make method category preambles bold at category changes."

	prevPreamble = preamble
		ifTrue: [super copyPreamble: preamble from: aStream]
		ifFalse: [self command: 'H3'.
				super copyPreamble: preamble from: aStream.
				self command: '/H3'.
				prevPreamble _ preamble]! !

!HtmlFileStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 21:43'!
nextChunk
	"Answer the contents of the receiver, up to the next terminator character (!!).  Imbedded terminators are doubled.  Undo and strip out all Html stuff in the stream and convert the characters back.  4/12/96 tk"
	| out char did rest |
	self skipSeparators.	"Absorb <...><...> also"
	out _ WriteStream on: (String new: 500).
	[self atEnd] whileFalse: [
		self peek = $< ifTrue: [self unCommand].	"Absorb <...><...>"
		(char _ self next) = $&
			ifTrue: [
				rest _ self upTo: $;.
				did _ out position.
				rest = 'lt' ifTrue: [out nextPut: $<].
				rest = 'gt' ifTrue: [out nextPut: $>].
				rest = 'amp' ifTrue: [out nextPut: $&].
				did = out position ifTrue: [
					self error: 'new HTML char encoding'.
					"Please add it to this code"]]
			ifFalse: [char = $!!	"terminator"
				ifTrue: [
					self peek = $!! ifFalse: [^ out contents].
					out nextPut: self next]	"pass on one $!!"
				ifFalse: [char asciiValue = 9
							ifTrue: [self next; next; next; next "TabThing"].
						out nextPut: char]]
		].
	^ out contents! !

!HtmlFileStream methodsFor: 'fileIn/Out'!
skipSeparators
	"Bsides the normal spacers, also skip any <...>, html commands.
	4/12/96 tk"
	| did |
	[did _ self position.
		super skipSeparators.
		self unCommand.	"Absorb <...><...>"
		did = self position] whileFalse.	"until no change"
! !


!HtmlFileStream methodsFor: 'read, write, position' stamp: 'di 6/28/97 21:49'!
header
	"append the HTML header.  Be sure to call trailer after you put out the data.
	4/4/96 tk"
	| cr |
	cr _ String with: Character cr.
	self command: 'HTML'; verbatim: cr.
	self command: 'HEAD'; verbatim: cr.
	self command: 'TITLE'.
	self nextPutAll: '"', self name, '"'.
	self command: '/TITLE'; verbatim: cr.
	self command: '/HEAD'; verbatim: cr.
	self command: 'BODY'; verbatim: cr.
! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/01/1999 13:59'!
nextPut: char
	"Put a character on the file, but translate it first. 4/6/96 tk 1/1/98 acg"
	char = $< ifTrue: [^ super nextPutAll: '&lt;'].
	char = $> ifTrue: [^ super nextPutAll: '&gt;'].
	char = $& ifTrue: [^ super nextPutAll: '&amp;'].
	char asciiValue = 13 "return" 
		ifTrue: [self command: 'br'].
	char = $	"tab" 
		ifTrue: [self verbatim: TabThing. ^super nextPut: char].
	^ super nextPut: char! !

!HtmlFileStream methodsFor: 'read, write, position'!
nextPutAll: aString
	"Write the whole string, translating as we go. 4/6/96 tk"
	"Slow, but faster than using aString asHtml?"

	aString do: [:each | self nextPut: each].! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/07/1999 09:24'!
trailer
	"append the HTML trailer.  Call this just before file close.
	4/4/96 tk"
	| cr |
	cr _ String with: Character cr.
	self command: '/BODY'; verbatim: cr.
	self command: '/HTML'; verbatim: cr.
!
]style[(7 192)f1bcblue;,f1! !

!HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/02/1999 00:38'!
verbatim: aString
	"Put out the string without HTML conversion. 1/1/99 acg"

	super nextPutAll: aString

	"'super verbatim:' in the 2.3beta draft didn't perform as expected -- the code was printed with conversion.  In a sense, that wouldn't make sense either -- we don't want strictly verbatim printing, just printing without the HTML conversion (that is, skipping around just the nextPut: and nextPutAll: for just this Class).  If there were intermediate conversions (say, CRLF!!), we would want those to happen as advertised -- perhaps we should use a differently named selector, perhaps something like nextPutWithoutHTMLConversion:, so that verbatim isn't overridden?"! !

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

HtmlFileStream class
	instanceVariableNames: ''!

!HtmlFileStream class methodsFor: 'instance creation' stamp: 'acg 01/07/1999 09:24'!
newFrom: aFileStream
	"Answer an HtmlFileStream that is 'like' aFileStream.  As a side-effect, the surviving fileStream answered by this method replaces aFileStream on the finalization registry. 1/6/99 acg"

	|inst|
	inst _ super newFrom: aFileStream.
	StandardFileStream unregister: aFileStream.
	HtmlFileStream register: inst.
	inst detectLineEndConvention.
	^inst
! !


!HtmlFileStream class methodsFor: 'class initialization' stamp: 'acg 01/01/1999 13:57'!
initialize   "HtmlFileStream initialize"
	TabThing _ '&nbsp;&nbsp;&nbsp;'

"I took Ted's suggestion to use &nbsp, which works far better for the HTML.  Style sheets provide an alternative, possibly better, solution since they permit finer-grain control of the HTML formatting, and thus would permit capturing the style in which text was originally rendered.  Internal tabbings would still get lost. 1/1/99 acg."! !
HtmlFontChangeEntity subclass: #HtmlFixedWidthEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlFixedWidthEntity commentStamp: '<historical>' prior: 0!
An entity that (supposedly) displays its contents in a fixed-width font.  I don't know how to do this, though.  -ls!

HtmlTextualEntity subclass: #HtmlFontChangeEntity
	instanceVariableNames: 'tagName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlFontChangeEntity commentStamp: '<historical>' prior: 0!
an entity whose effect is to change the font its constituents are displayed in in some way.  Multiple tags might generate almost any of the subclasses, so the tag name is stored explicitly.!


!HtmlFontChangeEntity methodsFor: 'testing' stamp: 'ls 7/5/1998 01:58'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlFontChangeEntity methodsFor: 'testing' stamp: 'ls 6/27/1998 12:51'!
tagName
	"must be stored in an i-var, because these classes work for different tags"
	^tagName! !


!HtmlFontChangeEntity methodsFor: 'private-initialization' stamp: 'ls 6/27/1998 15:34'!
initialize: aTag
	super initialize: aTag.
	tagName _ aTag name! !
HtmlFontChangeEntity subclass: #HtmlFontEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlFontEntity commentStamp: '<historical>' prior: 0!
the <font> tag.  it's here for future expansion....!


!HtmlFontEntity methodsFor: 'formatting' stamp: 'bolot 5/18/2000 11:42'!
addToFormatter: formatter
	| size color textAttribList |
	(formatter respondsTo: #startFont:)
		ifFalse: [^super addToFormatter: formatter].
	size _ self getAttribute: 'size'.
	color _ self getAttribute: 'color'.
	textAttribList _ OrderedCollection new.
	color ifNotNil: [textAttribList add: (TextColor color: (Color fromString: color))].
	(size isEmptyOrNil not and: [size isAllDigits]) 
		ifTrue: [size _ (size asNumber - 3) max: 1.
			textAttribList add: (TextFontChange fontNumber: (size min: 4))].
	formatter startFont: textAttribList.
	super addToFormatter: formatter.
	formatter endFont: textAttribList! !
HtmlEntity subclass: #HtmlForm
	instanceVariableNames: 'formEntities '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlForm methodsFor: 'testing' stamp: 'ls 7/4/1998 19:51'!
isBlockElement
	^true! !

!HtmlForm methodsFor: 'testing' stamp: 'ls 7/15/1998 00:24'!
mayContain: anEntity
	"allow anything.  People probably always put </form> anyway at the end of their forms.  And furthermore, it has no effect on the display, even if this is gotten wrong"
	^true! !

!HtmlForm methodsFor: 'testing' stamp: 'ls 7/3/1998 23:30'!
tagName
	^'form'! !


!HtmlForm methodsFor: 'formatting' stamp: 'ls 7/17/1998 00:26'!
addToFormatter: formatter
	formatter startForm: self.
	super addToFormatter: formatter.
	formatter currentFormData reset.
	formatter endForm.! !


!HtmlForm methodsFor: 'parsing' stamp: 'ls 7/16/1998 23:16'!
parsingFinished
	"figure out who our constituents are"

	self allSubentitiesDo: [ :e |
		e isFormEntity ifTrue: [ e form: self ] ].
	super parsingFinished.
	formEntities _ OrderedCollection new.
	self allSubentitiesDo: [ :e |
		(e isFormEntity and: [ e form == self ])
			ifTrue: [ formEntities add: e ] ].! !


!HtmlForm methodsFor: 'attributes' stamp: 'bolot 11/27/1999 19:21'!
encoding
	"encoding for posting"
	^self getAttribute: 'enctype' default: nil.  ! !

!HtmlForm methodsFor: 'attributes' stamp: 'ls 7/17/1998 00:40'!
method
	"method to submit with"
	^self getAttribute: 'method' default: 'get'! !

!HtmlForm methodsFor: 'attributes' stamp: 'ls 7/17/1998 00:40'!
url
	"url to submit to"
	^self getAttribute: 'action' default: nil.  ! !


!HtmlForm methodsFor: 'access' stamp: 'ls 7/16/1998 23:29'!
formEntities
	^formEntities! !
HtmlEntity subclass: #HtmlFormEntity
	instanceVariableNames: 'form '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlFormEntity commentStamp: '<historical>' prior: 0!
Abstract superclass for elements that only appear in forms!


!HtmlFormEntity methodsFor: 'access' stamp: 'ls 7/15/1998 00:22'!
form
	"return which form we are in"
	^form! !

!HtmlFormEntity methodsFor: 'access' stamp: 'ls 7/15/1998 00:22'!
form: aForm
	"set which form we are part of"
	form _ aForm! !


!HtmlFormEntity methodsFor: 'testing' stamp: 'ls 7/15/1998 00:22'!
isFormEntity
	^true! !

!HtmlFormEntity methodsFor: 'testing' stamp: 'ls 7/29/1998 00:15'!
lint: aStream
	form ifNil: [ aStream nextPutAll: '<', self tagName, '> not within a form'.
		aStream cr. ].
	super lint: aStream.! !
Object subclass: #HtmlFormatter
	instanceVariableNames: 'browser baseUrl formDatas outputStream preformattedLevel indentLevel boldLevel italicsLevel underlineLevel strikeLevel centerLevel urlLink listLengths listTypes precedingSpaces precedingNewlines morphsToEmbed incompleteMorphs anchorLocations imageMaps '
	classVariableNames: 'CSNonSeparators CSSeparators '
	poolDictionaries: ''
	category: 'Network-HTML Formatter'!
!HtmlFormatter commentStamp: '<historical>' prior: 0!
a filter which formats HTML into a Text with attributes!


!HtmlFormatter methodsFor: 'forms' stamp: 'ls 7/16/1998 22:07'!
currentFormData
	"return the current form data, or nil if we aren't inside a form"
	formDatas size > 0 
		ifTrue: [ ^formDatas last ]
		ifFalse: [ ^nil ].! !

!HtmlFormatter methodsFor: 'forms' stamp: 'bolot 8/29/1999 18:40'!
endForm
	formDatas size > 0 ifTrue: [ 
		formDatas removeLast. ]
	ifFalse: [ self halt: 'HtmlFormatter: ended more forms that started!!?' ].
	self ensureNewlines: 1.! !

!HtmlFormatter methodsFor: 'forms' stamp: 'bolot 8/29/1999 18:40'!
startForm: form
	"a form is beginning"
	self ensureNewlines: 1.
	formDatas addLast: (FormInputSet forForm: form  andBrowser: browser).! !


!HtmlFormatter methodsFor: 'access' stamp: 'ls 9/10/1998 03:20'!
anchorLocations
	"return a dictionary mapping lowercase-ed anchor names into the integer positions they are located at in the text"
	^anchorLocations! !

!HtmlFormatter methodsFor: 'access' stamp: 'ls 7/16/1998 22:08'!
baseUrl
	"return the base URL for the document we are formatting, if known"
	^baseUrl! !

!HtmlFormatter methodsFor: 'access' stamp: 'ls 7/16/1998 22:09'!
baseUrl: url
	"set the base url.  All relative URLs will be determined relative to it"
	baseUrl _ url.! !

!HtmlFormatter methodsFor: 'access' stamp: 'ls 7/16/1998 22:07'!
browser
	"return the browser we are formatting for, or nil if none"
	^browser! !

!HtmlFormatter methodsFor: 'access' stamp: 'ls 7/16/1998 22:08'!
browser: b
	"set what browser we are formatting for"
	browser _ b.! !

!HtmlFormatter methodsFor: 'access' stamp: 'ls 9/5/1998 18:08'!
incompleteMorphs
	"list of morphs needing to download some more state"
	^incompleteMorphs! !


!HtmlFormatter methodsFor: 'private-initialization' stamp: 'bolot 11/4/1999 00:36'!
initialize
	outputStream _ AttributedTextStream new.
	preformattedLevel _ 0.
	indentLevel _ boldLevel _ italicsLevel _ underlineLevel _ strikeLevel _ centerLevel _ 0.
	listLengths _ OrderedCollection new.
	listTypes _ OrderedCollection new.
	formDatas _ OrderedCollection new.
	precedingSpaces _ 0.
	precedingNewlines _ 1000.   "more than will ever be asked for"
	morphsToEmbed _ OrderedCollection new.
	incompleteMorphs _ OrderedCollection new.
	anchorLocations _ Dictionary new.
	imageMaps _ OrderedCollection new.

	outputStream nextPut: Character cr.! !


!HtmlFormatter methodsFor: 'private-formatting' stamp: 'ls 8/5/1998 01:41'!
setAttributes
	"set attributes on the output stream"
	| attribs |
	attribs _ OrderedCollection new.
	indentLevel > 0 ifTrue: [ attribs add: (TextIndent tabs: indentLevel) ].
	boldLevel > 0 ifTrue: [ attribs add: TextEmphasis bold ].
	italicsLevel >  0 ifTrue: [ attribs add: TextEmphasis italic ].
	underlineLevel > 0 ifTrue: [ attribs add: TextEmphasis underlined ].
	strikeLevel > 0 ifTrue: [ attribs add: TextEmphasis struckOut ].
	urlLink isNil ifFalse: [ attribs add: (TextURL new url: urlLink) ].
	outputStream currentAttributes: attribs! !


!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 9/12/1998 00:14'!
addChar: c
	"add a single character, updating all the tallies"

	"add the character to the output"
	outputStream nextPut: c.

	"update counters for preceeding spaces and preceding newlines"
	(c = Character space or: [ c = Character tab ]) 
	ifTrue: [ precedingSpaces _ precedingSpaces+1.  precedingNewlines _ 0 ]
	ifFalse: [
		(c = Character cr) ifTrue: [
			precedingSpaces _ 0.
			precedingNewlines _ precedingNewlines + 1 ]
		ifFalse: [
			precedingSpaces _ precedingNewlines _ 0 ] ].! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 9/5/1998 18:09'!
addIncompleteMorph: aMorph
	"add a morph, and note that it needs to download some more state before reaching its ultimate state"
	self addMorph: aMorph.
	incompleteMorphs add: aMorph.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/30/1998 02:51'!
addLink: text  url: url
	"add a link with the given url and text"
	| savedAttributes linkAttribute  |

	"set up the link attribute"
	linkAttribute _ TextURL new.
	linkAttribute url: url.

	"add the link to the stream"
	savedAttributes _ outputStream currentAttributes.
	outputStream currentAttributes: (savedAttributes, linkAttribute).
	outputStream nextPutAll: text.
	outputStream currentAttributes: savedAttributes.

	"reset counters"
	precedingSpaces _ precedingNewlines _ 0.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/29/1998 07:39'!
addMorph: aMorph
	"add a morph to the output"
	| savedAttributes |
	self addChar: Character space.

	savedAttributes _ outputStream currentAttributes.
	outputStream currentAttributes: (savedAttributes copyWith: (TextAnchor new anchoredMorph: aMorph)).
	self addChar: $*.
	outputStream currentAttributes: savedAttributes.

	self addChar: Character space.

	morphsToEmbed add: aMorph.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 8/25/1998 06:10'!
addString: aString
	"adds the text in the given string.  It collapses spaces unless we are in a preformatted region"

	| space compacted lastC i |

	aString isEmpty ifTrue: [ ^self ].

	space _ Character space.


	preformattedLevel > 0 ifTrue: [
		"add all the characters as literals"
		outputStream nextPutAll: aString.

		"update the counters"
		lastC _ aString last.
		(lastC = space or: [ lastC = Character cr ]) ifTrue: [
			"how many of these are there?"
			i _ aString size - 1.
			[ i >= 1 and: [ (aString at: i) = lastC ] ] whileTrue: [ i _ i - 1 ].
			i = 0 ifTrue: [
				"the whole string is the same character!!"
				lastC = space ifTrue: [
					precedingSpaces _ precedingSpaces + aString size.
					precedingNewlines _ 0.
					^self ]
				ifFalse: [
					precedingSpaces _ 0.
					precedingNewlines _ precedingNewlines + aString size.
					^self ]. ].
			lastC = space ifTrue: [
				precedingSpaces _ aString size - i.
				precedingNewlines _ 0 ]
			ifFalse: [
				precedingSpaces _ 0.
				precedingNewlines _ aString size - i ] ] ]
	ifFalse: [
		compacted _ aString withSeparatorsCompacted.

		compacted = ' ' ifTrue: [
			"no letters in the string--just white space!!"
			(precedingNewlines = 0 and: [precedingSpaces = 0]) ifTrue: [
				precedingSpaces _ 1.
				outputStream nextPut: space. ].
			^self ].

		(compacted first = Character space and: [
			(precedingSpaces > 0) or: [ precedingNewlines > 0] ])
		ifTrue: [ compacted _ compacted copyFrom: 2 to: compacted size ].

		outputStream nextPutAll: compacted.

		"update counters"
		precedingNewlines _ 0.
		compacted last = space 
			ifTrue: [ precedingSpaces _ 1 ]
			ifFalse: [ precedingSpaces _ 0 ]. ]! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:12'!
decreaseBold
	boldLevel _ boldLevel - 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:12'!
decreaseIndent
	indentLevel _ indentLevel - 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:12'!
decreaseItalics
	italicsLevel _ italicsLevel - 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/16/1998 22:58'!
decreasePreformatted
	preformattedLevel _ preformattedLevel - 1! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 02:03'!
decreaseStrike
	strikeLevel _ strikeLevel - 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 01:39'!
decreaseUnderline
	underlineLevel _ underlineLevel - 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 12:02'!
endHeader: level
	self decreaseBold.
	self ensureNewlines: 2! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/30/1998 03:17'!
endLink: url
	urlLink _ nil.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 8/20/1998 11:34'!
endListItem
	"end a list item"
	self ensureNewlines: 1.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 13:17'!
endOrderedList
	"end an ordered list"
	listLengths removeLast.
	listTypes removeLast.
	indentLevel _ indentLevel - 1.
	self setAttributes. 

	self ensureNewlines: 1.
	! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 13:18'!
endUnorderedList
	"end an unordered list"
	listLengths removeLast.
	listTypes removeLast.
	indentLevel _ indentLevel - 1.
	self setAttributes. 
	
	self ensureNewlines: 1.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/25/1998 17:21'!
ensureNewlines: number
	"make sure there are at least number preceding newlines"
	number > precedingNewlines ifTrue: [
		(number - precedingNewlines) timesRepeat: [ self addChar: Character cr ] ].! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 8/16/1998 11:34'!
ensureSpaces: number
	"make sure there are at least number preceding spaces, unless we're at the beginning of a new line"

	precedingNewlines > 0 ifTrue: [ ^ self ].

	number > precedingSpaces ifTrue: [
		(number - precedingSpaces) timesRepeat: [ self addChar: Character space ] ].! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 9/12/1998 00:15'!
hr
	"add an (attempt at a) horizontal rule"
	self ensureNewlines: 1.
	25 timesRepeat: [ self addChar: $- ].
	self ensureNewlines: 1.
	precedingSpaces _ 0.
	precedingNewlines _ 1000.    "pretend it's the top of a new page"! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:12'!
increaseBold
	boldLevel _ boldLevel + 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:12'!
increaseIndent
	indentLevel _ indentLevel + 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/27/1998 15:13'!
increaseItalics
	italicsLevel _ italicsLevel + 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/16/1998 22:58'!
increasePreformatted
	preformattedLevel _ preformattedLevel + 1! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 02:03'!
increaseStrike
	strikeLevel _ strikeLevel + 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/5/1998 01:40'!
increaseUnderline
	underlineLevel _ underlineLevel + 1.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 9/10/1998 03:26'!
noteAnchorStart: anchorName
	"note that an anchor starts at this point in the output"
	anchorLocations at: anchorName asLowercase put: outputStream size! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'bolot 5/18/2000 12:02'!
startHeader: level
	self ensureNewlines: 3.
	self increaseBold! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 6/30/1998 03:17'!
startLink: url
	urlLink _ url.
	self setAttributes.! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'bf 11/4/1999 22:23'!
startListItem
	"begin a new list item"
	listTypes size = 0 ifTrue: [ ^self ].
	self ensureNewlines: 1.
	listTypes last = #unordered
		ifTrue: [ self addString: '¥ ' ]
		ifFalse: [ self addString: (listLengths last + 1) printString.
			self addString: '. ' ].
	listLengths at: (listLengths size) put: (listLengths last + 1).! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/4/1998 19:44'!
startOrderedList
	"begin an ordered list"
	listLengths add: 0.
	listTypes add: #ordered.
	indentLevel _ indentLevel + 1.
	self setAttributes.
	! !

!HtmlFormatter methodsFor: 'formatting commands' stamp: 'ls 7/4/1998 19:44'!
startUnorderedList
	"begin an unordered list"
	listLengths add: 0.
	listTypes add: #unordered.
	indentLevel _ indentLevel + 1.
	self setAttributes.
	! !


!HtmlFormatter methodsFor: 'formatting' stamp: 'ls 6/30/1998 01:13'!
text
	| text |
	text _ outputStream contents.
	^text! !

!HtmlFormatter methodsFor: 'formatting' stamp: 'ls 7/16/1998 21:55'!
textMorph
	| text textMorph |
	text _ outputStream contents.
	textMorph _ TextMorph new contents: text.
	morphsToEmbed do:[ :m | textMorph addMorph: m ].
	^textMorph! !


!HtmlFormatter methodsFor: 'image maps' stamp: 'bolot 11/4/1999 00:36'!
addImageMap: anImageMap
	imageMaps addLast: anImageMap! !

!HtmlFormatter methodsFor: 'image maps' stamp: 'bolot 11/4/1999 00:37'!
imageMapNamed: imageMapName
	^imageMaps detect: [:im | im name asLowercase = imageMapName asLowercase] ifNone: []! !

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

HtmlFormatter class
	instanceVariableNames: ''!

!HtmlFormatter class methodsFor: 'instance creation' stamp: 'ls 6/25/1998 17:25'!
new
	^super new initialize! !

!HtmlFormatter class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 11:36'!
preferredFormatterClass
	^DHtmlFormatter! !


!HtmlFormatter class methodsFor: 'example' stamp: 'sma 2/12/2000 18:53'!
example1
	"(HtmlFormatter example1 asParagraph compositionRectangle: (0@0 extent: 300@500) ) displayAt: 0@0"
	| input |
	input _ ReadStream on: 
'<html>
<head>
<title>The Gate of Chaos</title>
</head>

<body>

<h1>Chaos</h1>



<h2>Into the Maelstrom</h2>
Direction is useless in the ever-changing Maelstrom.  However,
if you wander with purpose, you might be able to find....
<ul>
<li><a href="/cgi-bin/w">see who''s logged in</a>
<li><a href="/Telnet/connect.html">log in, if you (oooh) have an account</a>
<li><a href="http://chaos.resnet.gatech.edu:9000/sw">The Chaos Swiki</a>--scribble on chaos
<li>the original <a href="/cgi-bin/guestlog-print">Visitor Sands</a>
<li>my old <a href="rant.html">Rant Page</a>
<li>neverending <a href="/cgi-bin/bread">poll</a>: do you have an opinion on bread?
<li>a <a href="http://www.cc.gatech.edu/~lex/linux.html">Linux page</a>-- free UNIX for PC''s!!
<li><a href="english.au">Hear Linus Himself speak!!!!</a>
<li><a href="/doc/">some docs on all kinds of computer stuff</a>
</ul>

<hr>


<h2>Paths of Retreat</h2>
Several commonly travelled ways have left paths leading 
<em>away</em> from the maelstrom, too:
<p>
<ul>
<li><a href="friends.html">Friends of Chaos</a>
<li><a href="http://www.apache.org/">The <em>Apache</em> home page</a> -- 
        <em>Chaos</em>''s WWW server!!
<li><a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
Notscape</a>

the <a href="http://www.eskimo.com/%7Eirving/anti-ns/">Anti-Netscape
Page</a> -- fight the tyranny!!
</ul>

<hr>
<a href="/analog/usage.html">usage stats</a> for this server

<hr>
<a href="http://www.eff.org/blueribbon.html"><img src="blueribbon.gif" alt="[blue ribbon campaign]"></a>
<a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
<img src="notscape.gif" alt="[NOTscape]">
</a>
<a href="http://www.anybrowser.org/campaign/">
<img src="anybrowser3.gif" alt="[Best Viewed With Any Browser"]></a>
</body>
</html>'.
	^(HtmlParser parse: input) formattedText! !


!HtmlFormatter class methodsFor: 'initialization' stamp: 'ls 8/20/1998 06:05'!
initialize
	"HtmlFormatter initialize"

	CSSeparators _ CharacterSet separators.
	CSNonSeparators _ CSSeparators complement.! !
HtmlEntity subclass: #HtmlFrame
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlFrame methodsFor: 'categorization' stamp: 'ls 7/29/1998 00:25'!
isFrame
	^true! !


!HtmlFrame methodsFor: 'formatting' stamp: 'ls 7/26/1998 21:53'!
addToFormatter: formatter
	| src |
	src _ self getAttribute: 'src' default: nil.
	formatter ensureNewlines: 1.
	src ifNotNil: [ formatter startLink: src ].
	formatter addString: 'frame '.
	formatter addString: (self name ifNil: ['(unnamed)']).
	src ifNotNil:  [ formatter endLink: src ].
	formatter ensureNewlines: 1.! !


!HtmlFrame methodsFor: 'testing' stamp: 'ls 7/26/1998 21:46'!
mayContain: anEntity
	^false! !

!HtmlFrame methodsFor: 'testing' stamp: 'ls 7/26/1998 21:46'!
tagName
	^'frame'! !
HtmlEntity subclass: #HtmlFrameSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlFrameSet methodsFor: 'lint' stamp: 'ls 7/29/1998 00:25'!
shouldContain: anEntity
	^anEntity isFrame or: [ anEntity isFrameSet ]! !


!HtmlFrameSet methodsFor: 'categorization' stamp: 'ls 7/29/1998 00:26'!
isFrameSet
	^true! !


!HtmlFrameSet methodsFor: 'testing' stamp: 'ls 7/29/1998 00:26'!
mayContain: anEntity
	^true! !

!HtmlFrameSet methodsFor: 'testing' stamp: 'ls 7/26/1998 21:45'!
tagName
	^'frameset'! !
HtmlEntity subclass: #HtmlHead
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlHead methodsFor: 'metainformation' stamp: 'ls 7/5/1998 01:03'!
title
	"return the title, or nil if there isn't one"
	| te |
	te _ self titleEntity.
	te ifNil: [ ^nil ].
	^te textualContents! !

!HtmlHead methodsFor: 'metainformation' stamp: 'ls 7/5/1998 01:02'!
titleEntity
	"return the title entity, or nil if there isn't one"
	contents do: [ :e | e tagName = 'title' ifTrue: [ ^e ] ].
	^nil! !


!HtmlHead methodsFor: 'testing' stamp: 'ls 7/28/1998 20:25'!
mayContain: anEntity
	^anEntity isHeadElement or: [ anEntity isComment ]! !

!HtmlHead methodsFor: 'testing' stamp: 'ls 6/25/1998 02:07'!
tagName
	^'head'! !
HtmlEntity subclass: #HtmlHeadEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlHeadEntity commentStamp: '<historical>' prior: 0!
abstract superclass for entities that may appear in the HEAD section!


!HtmlHeadEntity methodsFor: 'testing' stamp: 'ls 6/27/1998 15:37'!
isHeadElement
	^true! !


!HtmlHeadEntity methodsFor: 'formatting' stamp: 'ls 6/27/1998 15:38'!
addToFormatter: formatter
	"head elements are normally just meta-information, and thus don't add anything to the formatter"! !
HtmlEntity subclass: #HtmlHeader
	instanceVariableNames: 'level '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlHeader methodsFor: 'testing' stamp: 'ls 7/4/1998 12:55'!
isHeader
	^true! !

!HtmlHeader methodsFor: 'testing' stamp: 'ls 6/27/1998 15:58'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlHeader methodsFor: 'testing' stamp: 'ls 7/23/1998 05:42'!
tagName
	^'h', level printString! !


!HtmlHeader methodsFor: 'formatting' stamp: 'bolot 5/18/2000 12:03'!
addToFormatter: formatter
	formatter startHeader: level.
	super addToFormatter: formatter.
	formatter endHeader: level! !


!HtmlHeader methodsFor: 'private-initialization' stamp: 'ls 7/23/1998 05:42'!
initialize: aTag
	super initialize: aTag.
	level _ aTag name last digitValue.! !
HtmlEntity subclass: #HtmlHorizontalRule
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlHorizontalRule methodsFor: 'testing' stamp: 'ls 6/27/1998 15:52'!
mayContain: anEntity
	^false! !

!HtmlHorizontalRule methodsFor: 'testing' stamp: 'ls 6/25/1998 02:22'!
tagName
	^'hr'! !


!HtmlHorizontalRule methodsFor: 'formatting' stamp: 'ls 6/27/1998 15:57'!
addToFormatter: formatter
	formatter hr! !
HtmlSpecialEntity subclass: #HtmlImage
	instanceVariableNames: 'image '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlImage methodsFor: 'downloading' stamp: 'ls 8/8/1998 03:47'!
downloadState: baseUrl 
	|  sourceUrl imageSource |

	image ifNil: [ 
		sourceUrl _ self src.
		sourceUrl ifNotNil: [ 
			imageSource _ HTTPSocket httpGetDocument: (sourceUrl asUrlRelativeTo: baseUrl asUrl) toText.
			imageSource contentType = 'image/gif'  ifTrue: [
				[image _ (GIFReadWriter on: (RWBinaryOrTextStream with: imageSource content) reset binary) nextImage ]
				ifError: [ :a :b |  "could not decode--ignore it"  image _ nil ] ].
			 ] ].
! !


!HtmlImage methodsFor: 'attributes' stamp: 'ls 8/4/1998 21:58'!
alt
	^(self getAttribute: 'alt') ifNil: ['[image]']! !

!HtmlImage methodsFor: 'attributes' stamp: 'ls 9/9/1998 07:01'!
imageExtent
	"the image extent, according to the WIDTH and HEIGHT attributes.  returns nil if either WIDTH or HEIGHT is not specified"
	| widthText heightText |
	widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
	heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
	^ widthText asNumber @ heightText asNumber! !

!HtmlImage methodsFor: 'attributes' stamp: 'bolot 11/30/1999 00:42'!
imageMapName
	| imageMapName |
	(imageMapName _ self getAttribute: 'usemap')
		ifNil: [^nil].
	imageMapName first = $#
		ifTrue: [imageMapName _ imageMapName copyFrom: 2 to: imageMapName size].
	^imageMapName! !

!HtmlImage methodsFor: 'attributes' stamp: 'ls 7/29/1998 00:56'!
src
	^self getAttribute: 'src' default: nil! !


!HtmlImage methodsFor: 'formatting' stamp: 'bolot 2/27/2000 23:45'!
addToFormatter: formatter
	| morph url |
	self src isNil ifTrue: [ ^self ].
	url _ self src.
	formatter baseUrl ifNotNil: [ 
		url _ url asUrlRelativeTo: formatter baseUrl ].


	morph _ DownloadingImageMorph new.
	morph defaultExtent: self imageExtent.
	morph altText: self alt.
	morph url: url.
	self imageMapName
		ifNotNil:
			[morph imageMapName: self imageMapName.
			morph formatter: formatter].

	formatter addIncompleteMorph: morph.! !


!HtmlImage methodsFor: 'initializing' stamp: 'ls 7/27/1998 02:17'!
initialize: aTag	
	super initialize: aTag.
! !


!HtmlImage methodsFor: 'testing' stamp: 'ls 7/1/1998 02:30'!
mayContain: anEntity
	^false! !

!HtmlImage methodsFor: 'testing' stamp: 'ls 6/25/1998 02:22'!
tagName
	^'img'! !
HtmlFormEntity subclass: #HtmlInput
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlInput commentStamp: '<historical>' prior: 0!
result of an <input> tag!


!HtmlInput methodsFor: 'attributes' stamp: 'ls 9/18/1998 08:22'!
defaultValue
	^(self getAttribute: 'value' default: '') replaceHtmlCharRefs! !

!HtmlInput methodsFor: 'attributes' stamp: 'bolot 11/2/1999 14:14'!
imageExtent
	"the image extent, according to the WIDTH and HEIGHT attributes.  returns nil if either WIDTH or HEIGHT is not specified"
	| widthText heightText |
	widthText _ self getAttribute: 'width' ifAbsent: [ ^nil ].
	heightText _ self getAttribute: 'height' ifAbsent: [ ^nil ].
	^ widthText asNumber @ heightText asNumber! !

!HtmlInput methodsFor: 'attributes' stamp: 'ls 7/23/1998 19:09'!
type
	^(self getAttribute: 'type' default: 'text') asLowercase! !


!HtmlInput methodsFor: 'testing' stamp: 'ls 7/5/1998 02:15'!
isTextualEntity
	^true! !

!HtmlInput methodsFor: 'testing' stamp: 'ls 7/5/1998 02:14'!
mayContain: anEntity
	^false! !

!HtmlInput methodsFor: 'testing' stamp: 'ls 7/21/1998 06:51'!
suppliesInput
	"whether we actually have input to supply"
	self type = 'text' ifTrue: [ ^true ].
	^false! !

!HtmlInput methodsFor: 'testing' stamp: 'ls 7/5/1998 02:14'!
tagName
	^'input'! !


!HtmlInput methodsFor: 'formatting' stamp: 'bf 11/4/1999 21:29'!
addCheckBoxButtonToFormatter: formatter
	| name formData checked button buttonInput |

	"dig up relevant attributes"
	name _ self getAttribute: 'name'.
	name ifNil: [ ^self ].
	value _ self getAttribute: 'value'.
	value ifNil: [ ^value ].
	
	formData _ formatter currentFormData.
	formData ifNil:  [ ^self ].

	checked _ (self getAttribute: 'checked') isNil not.

	"set up the form input"
	buttonInput _ ToggleButtonInput name: name value: value checkedByDefault: checked.
	formData addInput: buttonInput.

	"create the actual button"
	button _ UpdatingThreePhaseButtonMorph checkBox.
	button target: buttonInput;
		getSelector: #pressed;
		actionSelector: #toggle.
	buttonInput button: button.
	formatter addMorph: button.


! !

!HtmlInput methodsFor: 'formatting' stamp: 'bolot 11/27/1999 18:47'!
addFileInputToFormatter: formatter
	"is it a submit button?"
	| inputMorph size fileInput |
	inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
	size _ (self getAttribute: 'size' default: '12') asNumber.
	inputMorph extent: (size*10@20).
	fileInput _ FileInput name: self name textMorph: inputMorph.
	formatter addMorph: inputMorph;
		addMorph: ((PluggableButtonMorph on: fileInput getState: nil action: #browse)
				label: 'Browse').
	formatter currentFormData addInput: fileInput! !

!HtmlInput methodsFor: 'formatting' stamp: 'bolot 2/28/2000 00:00'!
addImageButtonToFormatter: formatter
	"is it a submit button?"
	| formData imageUrl morph |
	(imageUrl _ self getAttribute: 'src') ifNil: [^self].
	formatter baseUrl
		ifNotNil: [imageUrl _ imageUrl asUrlRelativeTo: formatter baseUrl].

	morph _ DownloadingImageMorph new.
	morph defaultExtent: self imageExtent.
	morph altText: self alt.
	morph url: imageUrl.

	value _ self getAttribute: 'name' default: 'Submit'.
	formData _ formatter currentFormData.
	morph
		on: #mouseUp
		send: #mouseUpEvent:linkMorph:formData:
		to: self
		withValue: formData.
	formatter addIncompleteMorph: morph
! !

!HtmlInput methodsFor: 'formatting' stamp: 'bf 11/4/1999 21:47'!
addRadioButtonToFormatter: formatter
	| name formData checked buttonSet button buttonInput |

	"dig up relevant attributes"
	name _ self getAttribute: 'name'.
	name ifNil: [ ^self ].
	value _ self getAttribute: 'value'.
	value ifNil: [ ^value ].
	
	formData _ formatter currentFormData.
	formData ifNil:  [ ^self ].

	checked _ self getAttribute: 'checked'.


	"find or create the set of buttons with our same name"
	buttonSet _ formData inputs detect: [ :i | i isRadioButtonSetInput and: [ i name = name ] ] ifNone: [ nil ].
	buttonSet ifNil: [ 
		"create a new button set"
		buttonSet _ RadioButtonSetInput name: name.
		formData addInput: buttonSet. ].

	"set up the form input"
	buttonInput _ RadioButtonInput  inputSet: buttonSet value: value.
	buttonSet addInput: buttonInput.
	checked ifNotNil: [
		buttonSet  defaultButton: buttonInput ].

	"create the actual button"
	button _ UpdatingThreePhaseButtonMorph radioButton.
	button target: buttonInput;
		getSelector: #pressed;
		actionSelector: #toggle.
	buttonInput button: button.
	formatter addMorph: button.


! !

!HtmlInput methodsFor: 'formatting' stamp: 'bolot 11/2/1999 14:20'!
addTextInputToFormatter: formatter
	"is it a submit button?"
	| inputMorph size |
	inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
	self type = 'password'
		ifTrue: [inputMorph font: (StrikeFont passwordFontSize: 12)].
	size _ (self getAttribute: 'size' default: '12') asNumber.
	inputMorph extent: (size*10@20).
	formatter addMorph: inputMorph.
	formatter currentFormData addInput:
		(TextInput name: self name defaultValue: self defaultValue  textMorph: inputMorph).! !

!HtmlInput methodsFor: 'formatting' stamp: 'bolot 11/27/1999 18:48'!
addToFormatter: formatter
	"is it a submit button?"
	self type = 'submit' ifTrue: [
		formatter addMorph: ((PluggableButtonMorph on: formatter currentFormData getState: nil action: #submit) label: (self getAttribute: 'value' default: 'Submit')).
		^self ].

	self type = 'image'
		ifTrue: [^self addImageButtonToFormatter: formatter].

	(self type = 'text' or: [self type = 'password'])
		ifTrue: [^self addTextInputToFormatter: formatter].

	self type = 'hidden' ifTrue: [
		formatter currentFormData addInput: (HiddenInput name: self name  value: self defaultValue).
		^self ].

	self type = 'radio' ifTrue: [ 
		^self addRadioButtonToFormatter: formatter ].

	self type = 'checkbox' ifTrue: [ 
		^self addCheckBoxButtonToFormatter: formatter ].

	self type = 'file' ifTrue: [ 
		^self addFileInputToFormatter: formatter ].

	formatter addString: '[form input of type: ', self type, ']'.! !


!HtmlInput methodsFor: 'morphic' stamp: 'bolot 2/27/2000 23:18'!
mouseUpEvent: event linkMorph: linkMorph formData: formData
	| aPoint |
	aPoint _ event cursorPoint - linkMorph topLeft.
	formData addInput: (HiddenInput name: (value, '.x') value: aPoint x asInteger asString).
	formData addInput: (HiddenInput name: (value, '.y') value: aPoint y asInteger asString).
	formData submit! !
HtmlFontChangeEntity subclass: #HtmlItalicsEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlItalicsEntity commentStamp: '<historical>' prior: 0!
an entity which displays its contents in italics!


!HtmlItalicsEntity methodsFor: 'formatting' stamp: 'ls 6/27/1998 13:16'!
addToFormatter: formatter
	formatter increaseItalics.
	super addToFormatter: formatter.	
	formatter decreaseItalics.! !
HtmlBlockEntity subclass: #HtmlList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlList methodsFor: 'testing' stamp: 'ls 7/17/1998 19:20'!
mayContain: anElement
	"lists may only contain LI elements"
	"^anElement isListItem"

	"except that people write some sucky HTML out there!!!!  well, let's assume they always put the end tag.  Much safer assumption than that they only put list-items in their lists"
	^true! !

!HtmlList methodsFor: 'testing' stamp: 'ls 7/28/1998 20:40'!
shouldContain: anEntity
	^anEntity isListItem! !
HtmlEntity subclass: #HtmlListItem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlListItem methodsFor: 'testing' stamp: 'ls 6/25/1998 02:10'!
isListItem
	^true! !

!HtmlListItem methodsFor: 'testing' stamp: 'ls 6/25/1998 03:03'!
mayContain: anEntity
	^anEntity isBlockEntity or: [ anEntity isTextualEntity ]! !

!HtmlListItem methodsFor: 'testing' stamp: 'ls 6/25/1998 02:09'!
tagName
	^'li'! !


!HtmlListItem methodsFor: 'formatting' stamp: 'ls 7/4/1998 19:49'!
addToFormatter: formatter
	formatter startListItem.
	super addToFormatter: formatter.
	formatter endListItem.! !
HtmlEntity subclass: #HtmlMap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlMap methodsFor: 'formatting' stamp: 'bolot 11/4/1999 00:37'!
addToFormatter: formatter
	super addToFormatter: formatter.
	formatter addImageMap: self! !


!HtmlMap methodsFor: 'accessing' stamp: 'bolot 11/3/1999 17:55'!
name
	^self getAttribute: 'name'! !


!HtmlMap methodsFor: 'testing' stamp: 'bolot 11/4/1999 04:42'!
mayContain: anEntity
	^anEntity isArea! !

!HtmlMap methodsFor: 'testing' stamp: 'bolot 11/3/1999 17:47'!
tagName
	^'map'! !


!HtmlMap methodsFor: 'morphic' stamp: 'bolot 2/27/2000 23:42'!
buildImageMapForImage: imageMorph andBrowser: browser
	| areaMorph |
	contents do: [:area |
		(area isArea
		and: [(areaMorph _ area linkMorphForMap: self andBrowser: browser) isNil not])
			ifTrue: [imageMorph addMorph: areaMorph]].
	^imageMorph! !

!HtmlMap methodsFor: 'morphic' stamp: 'bolot 2/27/2000 23:07'!
mouseUpEvent: event linkMorph: linkMorph browserAndUrl: browserAndUrl
	"this is an image map area, just follow the link"
	| browser url |
	browser _ browserAndUrl first.
	url _ browserAndUrl second.
	browser jumpToUrl: url! !
HtmlHeadEntity subclass: #HtmlMeta
	instanceVariableNames: 'theTag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlMeta commentStamp: '<historical>' prior: 0!
some result of a meta tag; unimplemented so far!


!HtmlMeta methodsFor: 'testing' stamp: 'ls 7/5/1998 02:22'!
mayContain: anEntity
	^false! !

!HtmlMeta methodsFor: 'testing' stamp: 'ls 7/5/1998 02:22'!
tagName
	^'meta'! !


!HtmlMeta methodsFor: 'formatting' stamp: 'ls 8/12/1998 05:44'!
addToFormatter: formatter
	| httpEquiv |
	httpEquiv _ self getAttribute: 'http-equiv'.
	httpEquiv ifNil: [ ^self ].
	httpEquiv asLowercase = 'refresh' ifTrue: [
		formatter addString: '{refresh: ', (self getAttribute:  'content' default: ''), '}' ].! !


!HtmlMeta methodsFor: 'initialization' stamp: 'ls 7/5/1998 02:23'!
initialize: aTag
	super initialize: aTag.
	theTag _ aTag.! !


!HtmlMeta methodsFor: 'printing' stamp: 'ls 7/5/1998 02:24'!
printOn: aStream indent: indent
	indent timesRepeat: [ aStream space ].
	aStream nextPutAll: 'meta: '.
	theTag printOn: aStream.
	aStream cr.! !
HtmlSpecialEntity subclass: #HtmlNoEmbed
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlNoEmbed methodsFor: 'formatting' stamp: 'ar 11/18/1998 21:11'!
addToFormatter: aFormatter
	"Check if the last incomplete morph has the property #embedded set.
	If so, assume that the last <EMBED> tag has been handled."
	| morphs |
	morphs _ aFormatter incompleteMorphs.
	(morphs isEmpty not and:[(morphs last valueOfProperty: #embedded) == true])
		ifTrue:[^self].
	"If not handled do the usual stuff"
	^super addToFormatter: aFormatter! !


!HtmlNoEmbed methodsFor: 'testing' stamp: 'ar 11/18/1998 21:11'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlNoEmbed methodsFor: 'testing' stamp: 'ar 11/18/1998 21:02'!
tagName
	^'noembed'! !
HtmlFormEntity subclass: #HtmlOption
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlOption methodsFor: 'attributes' stamp: 'ls 8/5/1998 07:19'!
label
	"label to be displayed for this morph"
	^self getAttribute: 'label' ifAbsent: [self textualContents]! !

!HtmlOption methodsFor: 'attributes' stamp: 'ls 8/5/1998 08:42'!
value
	"value to pass if this option is selected"
	^self getAttribute: 'value' default: '(unspecified)'! !


!HtmlOption methodsFor: 'testing' stamp: 'ls 7/21/1998 07:33'!
isOption
	^true! !

!HtmlOption methodsFor: 'testing' stamp: 'ls 7/21/1998 07:32'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlOption methodsFor: 'testing' stamp: 'ls 7/21/1998 07:04'!
tagName
	^'option'! !
HtmlFormEntity subclass: #HtmlOptionGroup
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlOptionGroup methodsFor: 'testing' stamp: 'ls 7/21/1998 07:33'!
mayContain: anEntity
	^anEntity isOption! !

!HtmlOptionGroup methodsFor: 'testing' stamp: 'ls 7/21/1998 07:05'!
tagName
	^'optgroup'! !
HtmlList subclass: #HtmlOrderedList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlOrderedList methodsFor: 'formatting' stamp: 'ls 7/4/1998 19:50'!
addToFormatter: formatter
	formatter startOrderedList.
	super addToFormatter: formatter.
	formatter endOrderedList.! !


!HtmlOrderedList methodsFor: 'testing' stamp: 'ls 6/25/1998 02:07'!
tagName
	^'ol'! !
HtmlEntity subclass: #HtmlParagraph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlParagraph methodsFor: 'formatting' stamp: 'ls 7/4/1998 01:16'!
addToFormatter: formatter
	formatter ensureNewlines: 2.
	super addToFormatter: formatter.! !


!HtmlParagraph methodsFor: 'testing' stamp: 'ls 6/25/1998 03:02'!
isBlockEntity
	^true! !

!HtmlParagraph methodsFor: 'testing' stamp: 'ls 6/25/1998 03:03'!
isParagraph
	^true! !

!HtmlParagraph methodsFor: 'testing' stamp: 'ls 6/25/1998 02:12'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlParagraph methodsFor: 'testing' stamp: 'ls 6/25/1998 02:12'!
tagName
	^'p'! !
Object subclass: #HtmlParser
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser'!
!HtmlParser commentStamp: '<historical>' prior: 0!
parses a stream of HtmlToken's into an HtmlDocument.  All token become an entity of some sort in the resulting document; some things are left only as comments, though.!


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

HtmlParser class
	instanceVariableNames: ''!

!HtmlParser class methodsFor: 'parsing' stamp: 'ls 7/28/1998 02:02'!
parse: aStream
	^self parseTokens: (HtmlTokenizer on: aStream)
! !

!HtmlParser class methodsFor: 'parsing' stamp: 'bolot 12/1/1999 02:46'!
parseTokens: tokenStream
	|  entityStack document head token matchesAnything entity body |

	entityStack _ OrderedCollection new.

	"set up initial stack"
	document _ HtmlDocument new.
	entityStack add: document.
	
	head _ HtmlHead new.
	document addEntity: head.
	entityStack add: head.


	"go through the tokens, one by one"
	[ token _ tokenStream next.  token = nil ] whileFalse: [
		(token isTag and: [ token isNegated ]) ifTrue: [
			"a negated token"
			(token name ~= 'html' and: [ token name ~= 'body' ]) ifTrue: [
				"see if it matches anything in the stack"
				matchesAnything _ (entityStack detect: [ :e | e tagName = token name ] ifNone: [ nil ]) isNil not.
				matchesAnything ifTrue: [
					"pop the stack until we find the right one"
					[ entityStack last tagName ~= token name ] whileTrue: [ entityStack removeLast ].
					entityStack removeLast.
				]. ] ]
		ifFalse: [
			"not a negated token.  it makes its own entity"
			token isComment ifTrue: [
				entity _ HtmlCommentEntity new initializeWithText: token source.
			].
			token isText ifTrue: [
				entity _ HtmlTextEntity new text: token text.
				(((entityStack last shouldContain: entity) not) and: 
					[ token source isAllSeparators ]) ifTrue: [
					"blank text may never cause the stack to back up"
					entity _ HtmlCommentEntity new initializeWithText: token source ].
			].
			token isTag ifTrue: [
				entity _ token entityFor.
				entity = nil ifTrue: [ entity _ HtmlCommentEntity new initializeWithText: token source ] ].
			(token name = 'body')
				ifTrue: [body ifNotNil: [document removeEntity: body].
					body _ HtmlBody new initialize: token.
					document addEntity: body.
					entityStack add: body].

			entity = nil ifTrue: [ self error: 'could not deal with this token' ].

			entity isComment ifTrue: [
				"just stick it anywhere"
				entityStack last addEntity: entity ]
			ifFalse: [
				"only put it in something that is valid"
				[ entityStack last mayContain: entity ] 
					whileFalse: [ entityStack removeLast ].

				"if we have left the head, create a body"					
				(entityStack size < 2 and: [body isNil]) ifTrue: [
					body _ HtmlBody new.
					document addEntity: body.
					entityStack add: body  ].

				"add the entity"
				entityStack last addEntity: entity.
				entityStack addLast: entity.
			].
		]].

	body == nil ifTrue: [
		"add an empty body"
		body _ HtmlBody new.
		document addEntity: body ].

	document parsingFinished.

	^document! !


!HtmlParser class methodsFor: 'example' stamp: 'ls 6/27/1998 15:32'!
example1
	"HtmlParser example1"
	| input |
	input _ ReadStream on: 
'<html>
<head>
<title>The Gate of Chaos</title>
</head>

<body>

<h1>Chaos</h1>



<h2>Into the Maelstrom</h2>
Direction is useless in the ever-changing Maelstrom.  However,
if you wander with purpose, you might be able to find....
<ul>
<li><a href="/cgi-bin/w">see who''s logged in</a>
<li><a href="/Telnet/connect.html">log in, if you (oooh) have an account</a>
<li><a href="http://chaos.resnet.gatech.edu:9000/sw">The Chaos Swiki</a>--scribble on chaos
<li>the original <a href="/cgi-bin/guestlog-print">Visitor Sands</a>
<li>my old <a href="rant.html">Rant Page</a>
<li>neverending <a href="/cgi-bin/bread">poll</a>: do you have an opinion on bread?
<li>a <a href="http://www.cc.gatech.edu/~lex/linux.html">Linux page</a>-- free UNIX for PC''s!!
<li><a href="english.au">Hear Linus Himself speak!!!!</a>
<li><a href="/doc/">some docs on all kinds of computer stuff</a>
</ul>

<hr>


<h2>Paths of Retreat</h2>
Several commonly travelled ways have left paths leading 
<em>away</em> from the maelstrom, too:
<p>
<ul>
<li><a href="friends.html">Friends of Chaos</a>
<li><a href="http://www.apache.org/">The <em>Apache</em> home page</a> -- 
        <em>Chaos</em>''s WWW server!!
<li><a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
Notscape</a>

the <a href="http://www.eskimo.com/%7Eirving/anti-ns/">Anti-Netscape
Page</a> -- fight the tyranny!!
</ul>

<hr>
<a href="/analog/usage.html">usage stats</a> for this server

<hr>
<a href="http://www.eff.org/blueribbon.html"><img src="blueribbon.gif" alt="[blue ribbon campaign]"></a>
<a href="http://www.ee.umanitoba.ca/~djc/personal/notscape.html">
<img src="notscape.gif" alt="[NOTscape]">
</a>
<a href="http://www.anybrowser.org/campaign/">
<img src="anybrowser3.gif" alt="[Best Viewed With Any Browser]"></a>
</body>
</html>'.

	^HtmlParser parse: input! !
HtmlEntity subclass: #HtmlPreformattedRegion
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlPreformattedRegion methodsFor: 'lint' stamp: 'ls 7/29/1998 00:27'!
shouldContain: anEntity
	^anEntity isTextualEntity! !


!HtmlPreformattedRegion methodsFor: 'testing' stamp: 'ls 7/4/1998 12:06'!
mayContain: anEntity
	^true! !

!HtmlPreformattedRegion methodsFor: 'testing' stamp: 'ls 7/4/1998 12:06'!
tagName
	^'pre'! !


!HtmlPreformattedRegion methodsFor: 'formatting' stamp: 'ls 7/13/1998 23:15'!
addToFormatter: formatter
	formatter ensureNewlines: 1.
	formatter increasePreformatted.
	super addToFormatter: formatter.
	formatter decreasePreformatted.
	formatter ensureNewlines: 1.! !
HtmlFormEntity subclass: #HtmlSelect
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlSelect methodsFor: 'testing' stamp: 'ls 7/21/1998 07:32'!
isTextualEntity
	^true! !

!HtmlSelect methodsFor: 'testing' stamp: 'ls 7/21/1998 07:32'!
mayContain: anEntity
	^true  "end tag required"! !

!HtmlSelect methodsFor: 'testing' stamp: 'ls 7/21/1998 07:05'!
tagName
	^'select'! !


!HtmlSelect methodsFor: 'formatting' stamp: 'bolot 11/3/1999 17:35'!
addToFormatter: formatter
	| options defaultOption listMorph names size valueHolder |
	names _ OrderedCollection new.
	options _ OrderedCollection new.
	defaultOption _ nil.

	(self getAttribute: 'multiple') ifNotNil: [
		self flag: #incomplete.
		formatter addString: '[M option list]'.
		^self ].

	contents do: [ :c |  c isOption ifTrue: [
		names add: c value.
		options add: c label withBlanksCondensed.
		(c getAttribute: 'selected') ifNotNil: [ defaultOption _ c label ] ] ].

	contents isEmpty ifTrue: [ ^self ].

	defaultOption ifNil: [ defaultOption _ options first ].

	size _ (self getAttribute: 'size' default: '1') asNumber.
	size = 1
		ifTrue: [listMorph _ DropDownChoiceMorph new initialize; contents: defaultOption.
			listMorph items: options; target: nil; getItemsSelector: nil;
				maxExtent: options; border: #useBorder]
		ifFalse: [valueHolder _ ValueHolder new contents: (contents indexOf: defaultOption).
			listMorph _ PluggableListMorph on: valueHolder list: nil
				selected: #contents  changeSelected: #contents:.
			listMorph list: options.
			listMorph extent: ((listMorph extent x) @ (listMorph scrollDeltaHeight * size))].

	formatter addMorph: listMorph.

	formatter currentFormData addInput:
		(SelectionInput  name: self name  defaultValue: defaultOption
			list: listMorph  values: names asArray)! !
HtmlFontChangeEntity subclass: #HtmlSmallerFontEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlSmallerFontEntity commentStamp: '<historical>' prior: 0!
supposedly decreases the font size its constituents are displayed in!

HtmlTextualEntity subclass: #HtmlSpecialEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
HtmlFontChangeEntity subclass: #HtmlStrikeEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlStrikeEntity commentStamp: '<historical>' prior: 0!
the contents should be displayed struck-through!


!HtmlStrikeEntity methodsFor: 'formatting' stamp: 'ls 7/5/1998 02:05'!
addToFormatter: formatter
	formatter increaseStrike.
	super addToFormatter: formatter.
	formatter decreaseStrike.! !
HtmlHeadEntity subclass: #HtmlStyle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlStyle methodsFor: 'testing' stamp: 'ls 7/5/1998 00:15'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlStyle methodsFor: 'testing' stamp: 'ls 7/5/1998 00:15'!
tagName
	^'style'! !
HtmlFontChangeEntity subclass: #HtmlSubscript
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlSubscript commentStamp: '<historical>' prior: 0!
an entity to be displayed as a subscript!

HtmlFontChangeEntity subclass: #HtmlSuperscript
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlSuperscript commentStamp: '<historical>' prior: 0!
an entity whose contents are to be displayed as a superscript!

HtmlEntity subclass: #HtmlTable
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTable methodsFor: 'testing' stamp: 'ls 7/4/1998 12:53'!
mayContain: anEntity
	^anEntity isTableRow! !

!HtmlTable methodsFor: 'testing' stamp: 'ls 7/4/1998 19:07'!
tagName
	^'table'! !


!HtmlTable methodsFor: 'formatting' stamp: 'ls 9/12/1998 00:52'!
addToFormatter: formatter
	formatter ensureNewlines: 1.
	super addToFormatter: formatter.
	formatter ensureNewlines: 1.! !
HtmlEntity subclass: #HtmlTableDataItem
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTableDataItem methodsFor: 'formatting' stamp: 'ls 9/5/1998 03:37'!
addToFormatter: formatter
	super addToFormatter: formatter.
	formatter ensureSpaces: 1.! !


!HtmlTableDataItem methodsFor: 'testing' stamp: 'ls 7/4/1998 12:54'!
isTableDataItem
	^true! !

!HtmlTableDataItem methodsFor: 'testing' stamp: 'ls 7/4/1998 12:56'!
mayContain: anEntity
	^anEntity isTextualEntity or: [ anEntity isBlockEntity or: [ anEntity isHeader ] ]! !

!HtmlTableDataItem methodsFor: 'testing' stamp: 'ls 7/4/1998 19:01'!
tagName
	^'td'! !
HtmlTableDataItem subclass: #HtmlTableHeader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlTableHeader commentStamp: '<historical>' prior: 0!
a TH tag.  Currently treated the same as a TD!


!HtmlTableHeader methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:51'!
tagName
	^'th'! !
HtmlEntity subclass: #HtmlTableRow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTableRow methodsFor: 'formatting' stamp: 'ls 9/12/1998 00:52'!
addToFormatter: formatter
	super addToFormatter: formatter.
	formatter ensureNewlines: 1.! !


!HtmlTableRow methodsFor: 'testing' stamp: 'ls 7/4/1998 12:53'!
isTableRow
	^true! !

!HtmlTableRow methodsFor: 'testing' stamp: 'ls 7/4/1998 12:54'!
mayContain: anEntity
	^anEntity isTableDataItem! !

!HtmlTableRow methodsFor: 'testing' stamp: 'ls 7/4/1998 19:00'!
tagName
	^'tr'! !
HtmlToken subclass: #HtmlTag
	instanceVariableNames: 'isNegated name attribs '
	classVariableNames: 'EntityClasses '
	poolDictionaries: ''
	category: 'Network-HTML Tokenizer'!
!HtmlTag commentStamp: '<historical>' prior: 0!
An HTML tag, eg <a href="foo.html">!


!HtmlTag methodsFor: 'parser support' stamp: 'ls 6/27/1998 13:18'!
entityFor
	"return an empty entity corresponding to this tag"
	| eClass |
	eClass _ self class entityClasses at: name ifAbsent: [ ^nil ].
	^eClass forTag: self ! !


!HtmlTag methodsFor: 'properties' stamp: 'ls 1/25/98 04:57'!
isTag
	^true! !


!HtmlTag methodsFor: 'access' stamp: 'ls 1/25/98 04:50'!
attribs
	"return a dictionary mapping attribute names (in lowercase) to their values"
	^attribs
! !

!HtmlTag methodsFor: 'access' stamp: 'ls 6/24/1998 18:53'!
isNegated
	^isNegated! !

!HtmlTag methodsFor: 'access' stamp: 'ls 1/25/98 04:49'!
name
	"return the basic kind of tag, in lowercase"
	^name
! !


!HtmlTag methodsFor: 'private-initialization' stamp: 'sma 2/5/2000 18:08'!
name: name0  negated: isNegated0 attribs: attribs0
	"initialize from the given attributes"
	name _ name0.
	isNegated _ isNegated0.
	attribs _ attribs0 ifNil: [Dictionary new]! !

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

HtmlTag class
	instanceVariableNames: ''!

!HtmlTag class methodsFor: 'parser support' stamp: 'bolot 11/3/1999 17:52'!
entityClasses
	"a Dictionary mapping tag names into the correct entity class"
	"EntityClasses _ nil"

	EntityClasses isNil ifFalse: [ ^EntityClasses ].

	EntityClasses _ Dictionary new.

	#( 
		frameset	HtmlFrame
		frame	HtmlFrame

		title		HtmlTitle
		style	HtmlStyle
		meta	HtmlMeta

		p		HtmlParagraph
		form	HtmlForm
		blockquote	HtmlBlockQuote

		input	HtmlInput
		textarea	HtmlTextArea
		select	HtmlSelect
		optgroup	HtmlOptionGroup
		option		HtmlOption

		img		HtmlImage
		embed	HtmlEmbedded
		noembed	HtmlNoEmbed
		a		HtmlAnchor
		br		HtmlBreak

		map	HtmlMap
		area	HtmlArea

		li		HtmlListItem
		dd		HtmlDefinitionDefinition
		dt		HtmlDefinitionTerm

		ol		HtmlOrderedList
		ul		HtmlUnorderedList
		dl		HtmlDefinitionList

		h1		HtmlHeader
		h2		HtmlHeader
		h3		HtmlHeader
		h4		HtmlHeader
		h5		HtmlHeader
		h6		HtmlHeader

		hr		HtmlHorizontalRule

		strong	HtmlBoldEntity
		b		HtmlBoldEntity

		em		HtmlItalicsEntity
		i		HtmlItalicsEntity
		dfn 	HtmlItalicsEntity

		u		HtmlUnderlineEntity 

		tt		HtmlFixedWidthEntity
		kbd		HtmlFixedWidthEntity		

		strike	HtmlStrikeEntity

		big		HtmlBiggerFontEntity
		small	HtmlSmallerFontEntity

		sub		HtmlSubscript
		sup		HtmlSuperscript

		font	HtmlFontEntity

		pre		HtmlPreformattedRegion
 
		table	HtmlTable
		tr		HtmlTableRow
		td		HtmlTableDataItem 
		th		HtmlTableHeader
		) pairsDo: [ 
			:tagName :className |
			EntityClasses at: tagName asString put: (Smalltalk at: className) ].

	^EntityClasses ! !

!HtmlTag class methodsFor: 'parser support' stamp: 'ar 11/18/1998 19:27'!
initialize
	"HtmlTag initialize"
	EntityClasses _ nil.! !


!HtmlTag class methodsFor: 'instance creation' stamp: 'ls 6/24/1998 18:54'!
source: source0  name: name0  negated: negated0 attribs: attribs0
	^(super forSource: source0) name: name0 negated: negated0 attribs: attribs0! !
HtmlToken subclass: #HtmlText
	instanceVariableNames: 'text '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Tokenizer'!
!HtmlText commentStamp: '<historical>' prior: 0!
A sequence of text without any tags in it.  &sp; style characters have been replaced by their actual values. !


!HtmlText methodsFor: 'formatter' stamp: 'ls 6/24/1998 17:29'!
addToFormatter: aFormatter
	"add ourself to a formatter"
	aFormatter addText: source! !


!HtmlText methodsFor: 'access' stamp: 'ls 1/25/98 04:57'!
text
	^text
! !


!HtmlText methodsFor: 'private-initialization' stamp: 'bf 11/4/1999 23:22'!
initialize: source0
	super initialize: source0.
	self text: source0 replaceHtmlCharRefs isoToSqueak.! !

!HtmlText methodsFor: 'private-initialization' stamp: 'ls 7/21/1998 01:02'!
text: text0
	text _ text0.! !


!HtmlText methodsFor: 'properties' stamp: 'ls 1/25/98 04:57'!
isText
	^true! !
HtmlFormEntity subclass: #HtmlTextArea
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTextArea methodsFor: 'testing' stamp: 'ls 7/5/1998 02:28'!
isBlockEntity
	"not sure...."
	^true! !

!HtmlTextArea methodsFor: 'testing' stamp: 'ls 7/29/1998 00:28'!
mayContain: anEntity
	^true   "really we shouldn't be interpretting tags in here at all, though...."! !

!HtmlTextArea methodsFor: 'testing' stamp: 'ls 7/17/1998 19:05'!
suppliesInput
	^self name ~= nil! !

!HtmlTextArea methodsFor: 'testing' stamp: 'ls 7/5/1998 02:40'!
tagName
	^'textarea'! !


!HtmlTextArea methodsFor: 'attributes' stamp: 'bolot 11/2/1999 13:51'!
columns
	| a |
	a _ self getAttribute: 'cols' default: '20'.
	^(Integer readFrom: (ReadStream on: a)) max: 5.! !

!HtmlTextArea methodsFor: 'attributes' stamp: 'ls 7/17/1998 03:12'!
defaultValue
	^self textualContents  "it would be nice to through the tags in there, too....  Easiest way would probably be to modiy the tokenizer"! !

!HtmlTextArea methodsFor: 'attributes' stamp: 'bolot 11/2/1999 13:51'!
rows
	| a |
	a _ self getAttribute: 'rows' default: '2'.
	^(Integer readFrom: (ReadStream on: a)) max: 1.! !


!HtmlTextArea methodsFor: 'formatting' stamp: 'bolot 11/2/1999 13:48'!
addToFormatter: formatter
	| inputMorph |
	formatter ensureNewlines: 1.
	inputMorph _ PluggableTextMorph on: StringHolder new text: #contents accept: #acceptContents:.
	inputMorph extent: (self columns * 5) @ (self rows * inputMorph scrollDeltaHeight).
	inputMorph retractable: false.
	formatter addMorph: inputMorph.
	formatter currentFormData addInput: (TextInput name: self name  defaultValue:  self textualContents  textMorph: inputMorph).
	formatter ensureNewlines: 1.! !
HtmlTextualEntity subclass: #HtmlTextEntity
	instanceVariableNames: 'text '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTextEntity methodsFor: 'contents' stamp: 'ls 7/5/1998 00:38'!
textualContents
	^text! !


!HtmlTextEntity methodsFor: 'testing' stamp: 'ls 7/28/1998 20:26'!
mayContain: anEntity
	^false! !

!HtmlTextEntity methodsFor: 'testing' stamp: 'ls 7/4/1998 16:30'!
tagName
	"bogus"
	^'x-text'  ! !


!HtmlTextEntity methodsFor: 'formatting' stamp: 'ls 6/25/1998 17:24'!
addToFormatter: aFormatter
	aFormatter addString: text! !


!HtmlTextEntity methodsFor: 'printing' stamp: 'ls 10/26/1998 17:09'!
printHtmlOn: aStream indent: indent 
	indent timesRepeat: [aStream space].
	aStream nextPutAll: text.
! !

!HtmlTextEntity methodsFor: 'printing' stamp: 'ls 7/14/1998 22:28'!
printOn: aStream indent: indent
	indent timesRepeat: [ aStream space ].
	aStream nextPutAll: '['.
	aStream nextPutAll: text.
	aStream nextPutAll: ']'.
	aStream cr.! !


!HtmlTextEntity methodsFor: 'access' stamp: 'ls 6/25/1998 02:58'!
text
	^text! !

!HtmlTextEntity methodsFor: 'access' stamp: 'ls 7/14/1998 23:58'!
text: text0
	text _ text0! !
HtmlEntity subclass: #HtmlTextualEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!
!HtmlTextualEntity commentStamp: '<historical>' prior: 0!
includes raw text, font-changing entities like <b> and <em>, and special entities like <a> and <img>.  All of these are relatively low level regarding formatting; they are superceded by higher level things like <li> and <p>.  When formatted, they flow around like characters.!


!HtmlTextualEntity methodsFor: 'testing' stamp: 'ls 6/25/1998 02:12'!
isTextualEntity
	^true! !
HtmlHeadEntity subclass: #HtmlTitle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlTitle methodsFor: 'testing' stamp: 'ls 6/27/1998 15:35'!
isHeadElement
	^true! !

!HtmlTitle methodsFor: 'testing' stamp: 'ls 6/27/1998 15:35'!
mayContain: anEntity
	^anEntity isTextualEntity! !

!HtmlTitle methodsFor: 'testing' stamp: 'ls 6/27/1998 15:36'!
tagName
	^'title'! !
Object subclass: #HtmlToken
	instanceVariableNames: 'source '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Tokenizer'!

!HtmlToken methodsFor: 'parser support' stamp: 'ls 6/25/1998 02:37'!
entityFor
	^self subclassResponsibility! !


!HtmlToken methodsFor: 'formatting' stamp: 'ls 6/24/1998 17:29'!
addToFormatter: aFormatter
	"add ourself to a formatter"! !


!HtmlToken methodsFor: 'printing' stamp: 'ls 1/25/98 05:45'!
printOn: aStream
	aStream nextPutAll: '{';
		nextPutAll: self class name;
		nextPut: $:;
		nextPutAll: self source;
		nextPut: $}.! !


!HtmlToken methodsFor: 'private-initialization' stamp: 'ls 1/25/98 05:34'!
initialize: s
	"default initialization doesn't do much.  subclasses are free to override"
	source _ s
! !


!HtmlToken methodsFor: 'properties' stamp: 'ls 1/25/98 04:47'!
isComment
	"whether this token is an HTML comment"
	^false
! !

!HtmlToken methodsFor: 'properties' stamp: 'ls 1/25/98 04:38'!
isTag
	"is this an HTML tag"
	^false! !

!HtmlToken methodsFor: 'properties' stamp: 'ls 1/25/98 04:39'!
isText
	"return whether it is a string of text"
	^false
! !


!HtmlToken methodsFor: 'access' stamp: 'ls 1/25/98 04:48'!
source
	"the raw source text that composes this token"
	^source! !

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

HtmlToken class
	instanceVariableNames: ''!

!HtmlToken class methodsFor: 'instance creation' stamp: 'ls 1/25/98 06:01'!
forSource: source  
	^super new initialize: source
! !
Stream subclass: #HtmlTokenizer
	instanceVariableNames: 'inputStream text pos inTextArea textAreaLevel '
	classVariableNames: 'CSAttributeEnders CSNameEnders CSNonSeparators '
	poolDictionaries: ''
	category: 'Network-HTML Tokenizer'!
!HtmlTokenizer commentStamp: '<historical>' prior: 0!
This class takes a text stream and produces a sequence of HTML tokens.

It requires its source stream to support #peek.!


!HtmlTokenizer methodsFor: 'private-initialization' stamp: 'ls 9/18/1998 08:06'!
initialize: s
	text _ s withSqueakLineEndings.
	pos _ 1.
	textAreaLevel _ 0.! !


!HtmlTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/18/1998 08:08'!
next 
	"return the next HtmlToken, or nil if there are no more"
	|token|

	"branch, depending on what the first character is"
	self atEnd ifTrue: [ ^nil ].
	self peekChar = $< 
		ifTrue: [ token _ self nextTagOrComment ]
		ifFalse: [ token _ self nextText ].


	"return the token, modulo modifications inside of textarea's"
	textAreaLevel > 0 ifTrue: [
		(token isTag and: [ token name = 'textarea' ]) ifTrue: [
			"textarea tag--change textAreaLevel accordingly"

			token isNegated
				ifTrue: [ textAreaLevel _ textAreaLevel - 1 ]
				ifFalse: [ textAreaLevel _ textAreaLevel -2 ].

			textAreaLevel > 0
				ifTrue: [ 
					"still inside a <textarea>, so convert this tag to text"
					^HtmlText forSource: token source ]
				ifFalse: [ "end of the textarea; return the tag"  ^token ] ].
			"end of the textarea"

		"inside the text area--return the token as text"
		^HtmlText forSource: token source ].

	(token isTag and: [ token isNegated not and: [ token name = 'textarea' ]]) ifTrue: [
		"beginning of a textarea"
		inTextArea _ true.
		^token ].
		

	^token! !


!HtmlTokenizer methodsFor: 'stream protocol' stamp: 'ls 8/20/1998 05:15'!
atEnd
	"are there any more tokens?  This is equivalent to whether there is any more input"
	^(pos > text size)! !


!HtmlTokenizer methodsFor: 'private' stamp: 'ls 8/20/1998 05:14'!
nextChar
	| c |
	self atEnd ifTrue: [ ^nil ].
	c _ text at: pos.
	pos _ pos + 1.
	^c! !

!HtmlTokenizer methodsFor: 'private' stamp: 'ls 8/20/1998 05:14'!
peekChar
	self atEnd ifTrue: [ ^nil ].
	^text at: pos! !


!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:33'!
nextAttributeValue
	"return the next sequence of alphanumeric characters; used to read in the value part of a tag's attribute, ie <tagname  attribname=attribvalue>"
	"because of the plethora of sloppy web pages, this is EXTREMELY tolerant"
	| c start end |

	"make sure there are at least two characters left"
	pos >= text size ifTrue: [ ^self nextChar asString ].

	"okay, peek at the first character"
	start _ pos.
	c _ text at: start.

	"check whether it's either kind of quote mark"
	(c = $" or: [ c = $' ]) ifTrue: [
		"yes--so find the matching quote mark"
		end _ text indexOf: c startingAt: start+1 ifAbsent: [ text size + 1 ].
		pos _ end+1.
		^text copyFrom: start to: end ].


	"no--go until a space or a $> is seen"
	end _ text indexOfAnyOf: CSAttributeEnders startingAt: start ifAbsent: [ text size + 1 ].
	end _ end - 1.
	pos _ end + 1.
	^text copyFrom: start to: end.! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:31'!
nextComment
	"we've seen < and the next is a !!.  read until the whole comment is done"
	"this isn't perfectly correct--for instance <!!--> is considered a proper comment--but it should do for now.  It also picks up <!!DOCTYPE...> tags"
	| source c hyphens |
	
	self nextChar.   "swallow the $!!"
	source _ WriteStream on: String new.
	source nextPutAll: '<!!'.
	
	self peekChar = $- ifFalse: [ 
		"this case is wierd.  go until we find a > at all and pray it's the correct end-of-'comment'"
		[	self atEnd or: [ self peekChar = $> ] 
		] whileFalse: [
			c _ self nextChar.
			source nextPut: c 
		].
		self atEnd ifFalse: [ source nextPut: self nextChar ].
		^HtmlComment forSource: source contents ].
	
	hyphens _ 0.

	[ 	c _ self nextChar.
		c = nil or: [
			source nextPut: c.
			(hyphens >=2 and: [ c = $> ])]
	] whileFalse: [
		c = $- ifTrue: [ hyphens _ hyphens + 1 ] ifFalse: [ hyphens _ 0 ]
	].
		
	^HtmlComment forSource: source contents.
! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:24'!
nextName
	"return the next sequence of alphanumeric characters"
	"because of the plethora of sloppy web pages, this also accepts most non-space characters"
	| start end |

	start _ pos.
	end _ text indexOfAnyOf: CSNameEnders startingAt: start ifAbsent: [ text size + 1].
	end _ end - 1.


	pos _ end+1.
	^text copyFrom: start to: end! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:23'!
nextSpaces
	"read in as many consecutive space characters as possible"
	| start end |

	"short cut for a common case"
	self peekChar isSeparator not ifTrue: [ ^'' ].

	"find the start and end of the sequence of spaces"
	start _ pos.
	end _ text indexOfAnyOf: CSNonSeparators startingAt: start ifAbsent: [ text size + 1 ].
	end _ end - 1.

	"update pos and return the sequence"
	pos _ end + 1.
	^text copyFrom: start to: end! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/25/1998 05:43'!
nextTag
	"we've seen a < and peek-ed something other than a !!.  Parse and return a tag"
	| source negated name attribs attribName attribValue sourceStart sourceEnd c |
	
	sourceStart _ pos-1.
	attribs _ Dictionary new.

	"determine if its negated"
	self peekChar = $/ 
		ifTrue: [ negated _ true.  self nextChar. ]
		ifFalse: [ negated _ false ].

	"read in the name"
	self skipSpaces.
	name _ self nextName.
	name _ name asLowercase.

	"read in any attributes"
	[ 	self skipSpaces.
		c _ self peekChar.
		c = nil or: [c isLetter not ]
	] whileFalse: [
		attribName _ self nextName.
		attribName _ attribName asLowercase.
		self skipSpaces.
		self peekChar = $= 
			ifTrue: [ 
				self nextChar.
				self skipSpaces.
				attribValue _ self nextAttributeValue withoutQuoting  ]
			ifFalse: [ attribValue _ '' ].
		attribs at: attribName  put: attribValue ].

	self peekChar = $> ifTrue: [ self nextChar ].

	sourceEnd _ pos-1.
	source _ text copyFrom: sourceStart to: sourceEnd.

	^HtmlTag source: source name: name asLowercase negated: negated attribs: attribs! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:31'!
nextTagOrComment
	"next character is a $<.  So read either a tag or a token"
	self nextChar.  "skip the $<"

	^self peekChar = $!! 
		ifTrue: [ self nextComment ]
		ifFalse: [ self nextTag ]

! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/20/1998 05:34'!
nextText
	"returns the next textual segment"
	|start end|

	start _ pos.
	end _ (text indexOf: $< startingAt: start ifAbsent: [ text size + 1 ]) - 1.

	pos _ end+1.
	^HtmlText forSource: (text copyFrom: start to: end)! !

!HtmlTokenizer methodsFor: 'private-tokenizing' stamp: 'ls 8/25/1998 05:26'!
skipSpaces
	"skip as many consecutive space characters as possible"
	pos _ text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].! !

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

HtmlTokenizer class
	instanceVariableNames: ''!

!HtmlTokenizer class methodsFor: 'instance creation' stamp: 'ls 8/20/1998 05:13'!
on: aStream
	^super basicNew initialize: aStream contents! !


!HtmlTokenizer class methodsFor: 'initialization' stamp: 'ls 8/19/1998 09:09'!
initialize
	"HtmlTokenizer initialize"

	CSAttributeEnders _ CharacterSet empty.
	CSAttributeEnders addAll: Character separators.
	CSAttributeEnders add: $>.
	
	CSNameEnders _ CharacterSet empty.
	CSNameEnders addAll: '=>'.
	CSNameEnders addAll: Character separators.

	CSNonSeparators _ CharacterSet separators complement.! !
HtmlFontChangeEntity subclass: #HtmlUnderlineEntity
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlUnderlineEntity methodsFor: 'formatting' stamp: 'ls 7/5/1998 01:41'!
addToFormatter: formatter
	formatter increaseUnderline.
	super addToFormatter: formatter.	
	formatter decreaseUnderline.! !
HtmlList subclass: #HtmlUnorderedList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Parser Entities'!

!HtmlUnorderedList methodsFor: 'formatting' stamp: 'ls 7/4/1998 19:50'!
addToFormatter: formatter
	formatter startUnorderedList.
	super addToFormatter: formatter.
	formatter endUnorderedList.! !


!HtmlUnorderedList methodsFor: 'testing' stamp: 'ls 6/25/1998 02:07'!
tagName
	^'ul'! !
HierarchicalUrl subclass: #HttpUrl
	instanceVariableNames: 'realm '
	classVariableNames: 'Passwords '
	poolDictionaries: ''
	category: 'Network-Url'!
!HttpUrl commentStamp: '<historical>' prior: 0!
A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL

realm = the name of the security realm that has been discovered for this URL.   Look it up in Passwords.

Passwords = a Dictionary of (realm -> encoded user&password)!


!HttpUrl methodsFor: 'downloading' stamp: 'bolot 5/18/2000 13:55'!
askNamePassword
	"Authorization is required by the host site.  Ask the user for a userName and password.  Encode them and store under this realm.  Return false if the user wants to give up."

	| user password |
	(self confirm: 'Host ', self toText, '
wants a different user and password.  Type them now?' orCancel: [false])
		ifFalse: [^ false].
	"Note: When Scamper is converted to run under MVC, we'll have to pass in topView in order to decide which FillInTheBlank to call."
	user _ FillInTheBlank request: 'User account name?' initialAnswer: '' 
				centerAt: Sensor cursorPoint - (50@0).
	password _ FillInTheBlank requestPassword: 'Password?'.
	Passwords at: realm put: (Authorizer new encode: user password: password).
	^ true! !

!HttpUrl methodsFor: 'downloading' stamp: 'bolot 5/18/2000 13:11'!
checkAuthorization: webDocument retry: retryBlock
	"authorization failed if webDocument is a String"
	| oldRealm i end encoded |
	((webDocument isKindOf: String)
		and: [(webDocument beginsWith: 'HTTP/1.0 401')
			or: [webDocument beginsWith: 'HTTP/1.1 401']])
	ifFalse: [^self].

	oldRealm _ realm.
	i _ webDocument findString: 'realm="'.
	i = 0 ifTrue: [^self].
	end _ webDocument indexOf: $" startingAt: i.
	realm _ webDocument copyFrom: i+7 to: end.
	"realm _ (webDocument findTokens: '""') at: 2."
	Passwords ifNil: [Passwords _ Dictionary new].
	encoded _ Passwords at: realm ifAbsent: [nil].
	(oldRealm ~= realm) & (encoded ~~ nil) 
		ifTrue: [^ retryBlock value]
		ifFalse: ["ask the user"
			self askNamePassword ifTrue: [^ retryBlock value]]! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 10/13/1999 19:41'!
loadRemoteObjects
	"Load a remote image segment and extract the root objects.
	Check if the remote file is a zip archive."
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' 
		asUrl loadRemoteObjects" 
	"'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' 
		asUrl loadRemoteObjects" 

	| stream info data extension |
 	data _ self retrieveContents content.
	extension _ (FileDirectory extensionFor: self path last) asLowercase.
	(#('zip' 'gzip') includes: extension)
		ifTrue: [data _ (GZipReadStream on: data) upToEnd].
"	stream _ StreamWrapper streamOver: (ReadStream on: data)."
	stream _ RWBinaryOrTextStream on: data.
	stream reset.
	info _ stream fileInObjectAndCode.
	stream close.
	^info arrayOfRoots! !

!HttpUrl methodsFor: 'downloading' stamp: 'bolot 12/14/2000 18:26'!
normalizeContents: webDocument
	(webDocument isKindOf: String) ifTrue: [
		^MIMEDocument
			contentType: 'text/plain'
			content: 'error occured retrieving ', self toText, ': ', webDocument
			url: (Url absoluteFromText: '')].
	webDocument contentType = MIMEDocument defaultContentType ifTrue: [
		^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) 
			content: webDocument content url: webDocument url ].

	^webDocument! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 7/25/2000 17:10'!
postFormArgs: args
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']]
		ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ', request, String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"
	contents _ (HTTPSocket httpPostDocument: self toText args: args
				accept: 'application/octet-stream' request: request).

	self checkAuthorization: contents retry: [^ self postFormArgs: args].

	^self normalizeContents: contents! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 7/25/2000 17:10'!
postMultipartFormArgs: args
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']]
		ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ', request, String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"
	contents _ (HTTPSocket httpPostMultipart: self toText args: args
				accept: 'application/octet-stream' request: request).

	self checkAuthorization: contents retry: [^ self postMultipartFormArgs: args].

	^self normalizeContents: contents! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:49'!
privateInitializeFromText: aString relativeTo: aUrl

	super privateInitializeFromText: aString relativeTo: aUrl.
	realm _ aUrl realm.! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 19:47'!
realm
	^ realm! !

!HttpUrl methodsFor: 'downloading' stamp: 'tk 9/22/1998 20:21'!
retrieveContents
	^ self retrieveContentsArgs: nil! !

!HttpUrl methodsFor: 'downloading'!
retrieveContentsAccept: mimeType
	^ self retrieveContentsArgs: nil accept: mimeType! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 7/26/2000 12:56'!
retrieveContentsArgs: args
	^self retrieveContentsArgs: args accept: 'application/octet-stream'! !

!HttpUrl methodsFor: 'downloading' stamp: 'mir 7/26/2000 12:55'!
retrieveContentsArgs: args accept: mimeType
	| contents request |
	request _ realm ifNotNil: [Passwords at: realm ifAbsent: ['']] ifNil: [''].
	request = '' ifFalse: [request _ 'Authorization: Basic ' , request , String crlf].
		"Why doesn't Netscape send the name of the realm instead of Basic?"

	contents _ (HTTPSocket
		httpGetDocument: self withoutFragment toText
		args: args
		accept: mimeType
		request: request).

	self checkAuthorization: contents retry: [^ self retrieveContentsArgs: args].

	^ self normalizeContents: contents! !

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

HttpUrl class
	instanceVariableNames: ''!

!HttpUrl class methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 23:13'!
shutDown
	"Forget all cached passwords, so they won't stay in the image"

	Passwords _ nil.! !
Model subclass: #IRCChannelInfo
	instanceVariableNames: 'connection name topic members subscribers '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCChannelInfo commentStamp: '<historical>' prior: 0!
holds various info on a channel that the user is a member of.!


!IRCChannelInfo methodsFor: 'messages' stamp: 'ls 9/5/1998 00:40'!
sendMessage: aString
	"send a message on the channel"
	connection privmsgFrom: nil  to: name  text: aString! !


!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 09:17'!
addMember: memberName
	"note that memberName is on the channel.  memberName should be given in the user's preferred capitalization"
	members add: memberName.
	self changed: #memberNames.! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 09:18'!
addMembers: list
	members addAll: list.
	self changed: #memberNames.! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 10:07'!
changeTopic: aText
	"attempt to change the topic"
	connection sendMessage: (IRCProtocolMessage
		command: 'TOPIC'
		arguments: (Array with: self name with: aText asString)).
	^true! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 09:44'!
connection
	"return the IRC connection I am watching"
	^connection! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 09:18'!
memberNames
	"names of the clients subscribing to this channel"
	^members! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/3/1998 21:28'!
name
	"name of the channel, in its preferred capitalization"
	^name! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 09:39'!
removeMember: memberName
	"note that memberName has left (PART-ed or QUIT-ed) the channel"
	members remove: memberName ifAbsent: [ ^self ].
	self changed: #memberNames.! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/5/1998 00:41'!
subscribe: anObject
	"add anObject as a subscriber.  anObject must respond to ircMessageRecieved"

	subscribers isEmpty ifTrue: [ connection join: name ].
	subscribers add: anObject! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/3/1998 21:28'!
subscribers
	"collection of objects watching for messages on the channel"
	^subscribers! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 08:52'!
topic
	^topic ifNil: ['']! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/17/1998 08:53'!
topic: aString
	topic _ aString.
	self changed: #topic! !

!IRCChannelInfo methodsFor: 'access' stamp: 'ls 9/5/1998 00:39'!
unsubscribe: anObject
	"unsubscribe anObject"
	subscribers remove: anObject.
	subscribers isEmpty ifTrue: [ connection leave: name ].! !


!IRCChannelInfo methodsFor: 'private-initialization' stamp: 'ls 9/6/1998 20:23'!
initializeName: aString  connection: aConnection
	name _ aString.
	members _ Set new.
	subscribers _ IdentitySet new.
	connection _ aConnection! !


!IRCChannelInfo methodsFor: 'interface' stamp: 'ls 9/17/1998 09:21'!
openUserList
	"open a listing with all the users on this channel"
	^IRCChannelUsersBrowser openOnChannel: self! !

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

IRCChannelInfo class
	instanceVariableNames: ''!

!IRCChannelInfo class methodsFor: 'instance creation' stamp: 'ls 9/6/1998 20:22'!
forChannelNamed: aString  onConnection: connection
	"create an instance for the channel with the given name"
	^super new initializeName: aString connection: connection! !
Model subclass: #IRCChannelListBrowser
	instanceVariableNames: 'connection channelList channelIndex sortCriterion '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCChannelListBrowser commentStamp: '<historical>' prior: 0!
a browser of the list of channels a given connection offers.  Allows users to easily join and create channels.!


!IRCChannelListBrowser methodsFor: 'private-initialization' stamp: 'ls 9/17/1998 11:23'!
initialize: anIRCConnection
	connection _ anIRCConnection.
	channelList _ #().
	channelIndex _ 0.
	sortCriterion _ #name.
	anIRCConnection addDependent: self.
	self refreshChannelList.! !


!IRCChannelListBrowser methodsFor: 'private' stamp: 'ls 11/24/1998 08:38'!
refreshChannelList
	"update the list of channels"
	| sortBlock |

	channelList _ connection channelList.
	channelList ifNil: [ channelList _ #() ].

	"sort the channels"
	sortCriterion = #name ifTrue: [
		sortBlock _ [ :a :b | a name asIRCLowercase < b name asIRCLowercase ] ]
	ifFalse: [
		sortBlock _ [ :a :b |
		a numUsers = b numUsers
			ifTrue: [ a name asIRCLowercase < b name asIRCLowercase ]
			ifFalse: [ a numUsers > b numUsers ] ] ].

	channelList _ channelList asSortedCollection: sortBlock.
	channelList _ channelList asArray.
	
	channelIndex _ 0.

	self changed: #channelDescriptions.
	self changed: #channelIndex.! !

!IRCChannelListBrowser methodsFor: 'private' stamp: 'ls 9/17/1998 07:00'!
update: aSymbol
	aSymbol == #channelList ifTrue: [
		self refreshChannelList ].! !


!IRCChannelListBrowser methodsFor: 'interface' stamp: 'ls 9/17/1998 08:57'!
createChannel
	|  channelName |
	channelName _ FillInTheBlank request: 'channel name'.
	channelName isEmpty ifTrue: [ ^self ].

	IRCChannelObserver openForChannelNamed: channelName  onConnection: connection! !

!IRCChannelListBrowser methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:28'!
openMorphicView
	| win descListView updateButton actionColumn openChannelButton createChannelButton |
	win _ SystemWindow new.
	win setLabel: 'Channel Listing'.
	win model: self.

	descListView _ PluggableListMorph on: self  list: #channelDescriptions selected: #channelIndex changeSelected: #channelIndex:.
	win addMorph: descListView  frame: (0@0 extent: 0.8@0.9).

	updateButton _ PluggableButtonMorph on: connection getState: nil action: #requestChannelList.
	updateButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'update'.
	win addMorph: updateButton  frame: (0@0.9 extent: 1@0.1).


	actionColumn _ AlignmentMorph newColumn.

	openChannelButton _ PluggableButtonMorph on: self getState: nil action: #openSelectedChannel.
	openChannelButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'join channel'.
	actionColumn addMorphBack: openChannelButton.

	createChannelButton _ PluggableButtonMorph on: self getState: nil action: #createChannel.
	createChannelButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'create channel'.
	actionColumn addMorphBack: createChannelButton.

	win addMorph: actionColumn  frame: (0.8@0 extent: 0.2@0.9).

	win openInWorld! !

!IRCChannelListBrowser methodsFor: 'interface' stamp: 'ls 9/17/1998 08:57'!
openSelectedChannel
	| channelInfo channelName |
	channelInfo _ channelList at: channelIndex ifAbsent: [ ^self ].
	channelName _ channelInfo name.

	IRCChannelObserver openForChannelNamed: channelName  onConnection: connection! !

!IRCChannelListBrowser methodsFor: 'interface' stamp: 'ls 9/4/1998 21:28'!
openView
	^self openMorphicView! !


!IRCChannelListBrowser methodsFor: 'access' stamp: 'ls 9/17/1998 06:59'!
channelDescriptions
	^channelList collect: [ :channel |
		channel name, '(', channel numUsers printString, ')    ', channel topic].! !

!IRCChannelListBrowser methodsFor: 'access' stamp: 'ls 9/4/1998 21:34'!
channelIndex
	^channelIndex! !

!IRCChannelListBrowser methodsFor: 'access' stamp: 'ls 9/4/1998 21:53'!
channelIndex: anInteger
	channelIndex _ anInteger.
	self changed: #channelIndex! !

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

IRCChannelListBrowser class
	instanceVariableNames: ''!

!IRCChannelListBrowser class methodsFor: 'instance creation' stamp: 'ls 9/4/1998 21:35'!
forConnection: connection
	^super new initialize: connection! !

!IRCChannelListBrowser class methodsFor: 'instance creation' stamp: 'ls 9/4/1998 21:36'!
openForConnection: connection
	(self forConnection: connection) openView! !
Model subclass: #IRCChannelObserver
	instanceVariableNames: 'connection channel channelName chatText '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCChannelObserver commentStamp: '<historical>' prior: 0!
converts IRC messages forwarded to it, into a textual format that may be displayed.  Messages may additionally sent *from* it, to a specified target.!


!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/4/1998 17:51'!
chatAreaSelection
	"where to put the cursor in the chat area.  We'll leave it at the very end so that the most recent mesages are always visible"
	^chatText size to: chatText size-1! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/3/1998 19:59'!
chatText
	^chatText! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/5/1998 00:12'!
chatTextSelection
	"where to put the cursor in the chat area.  We'll leave it at the very end so that the most recent mesages are always visible"
	^chatText size to: chatText size-1! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 08:58'!
connection: anIRCConnection channelName: aString
	connection _ anIRCConnection.
	channel _ connection channelInfo: aString.
	channel subscribe: self.
	chatText _ Text new.! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 12/10/1998 20:45'!
ircMessageRecieved: aMessage
	| sender newLine |

	sender _ aMessage sender ifNil: [ 'me' ].
	(sender includes: $!!) ifTrue: [ sender _ sender copyFrom: 1 to: (sender indexOf: $!!)-1 ].

	newLine _ 
		(Text string: sender emphasis: (Array with: TextEmphasis bold)), 
		': ', aMessage text, String cr.

	chatText _ chatText, newLine.
	chatText size > 2000 ifTrue: [
		chatText _ chatText copyFrom: (chatText size - 1000) to: chatText size ].

	self changed: #chatText.! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'RAA 1/17/2001 14:28'!
openMorphicView
	"open a view for interacting with this collector"
	| win textArea inputArea topicArea usersButton |

	win _ SystemWindow new.
	win setLabel: channel name.
	win model: self.

	topicArea _ PluggableTextMorph on: channel  text: #topic  accept: #changeTopic:.
	topicArea acceptOnCR: true.
	win addMorph: topicArea frame: (0@0 extent: 0.9@0.1).

	usersButton _ PluggableButtonMorph on: channel  getState: nil  action: #openUserList.
	usersButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'users'.
	win addMorph: usersButton frame: (0.9@0 extent: 0.1@0.1).

	textArea _ PluggableTextMorph on: self text: #chatText accept: nil readSelection: #chatTextSelection menu: nil.
	win addMorph: textArea frame: (0@0.1 extent: 1@0.8).

	inputArea _ PluggableTextMorph on: self text: nil accept: #sendMessage:.
	inputArea acceptOnCR: true.
	win addMorph: inputArea frame: (0@0.9 extent: 1@0.1) .

	win openInWorld.! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/3/1998 20:59'!
openView
	"open a view for interacting with this collector"
	^self openMorphicView! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 08:57'!
release
	super release.
	channel unsubscribe: self! !

!IRCChannelObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 08:57'!
sendMessage: aText
	channel sendMessage: aText asString.
	^true! !

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

IRCChannelObserver class
	instanceVariableNames: ''!

!IRCChannelObserver class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 08:56'!
openForChannelNamed: channelName  onConnection: connection 
	^(super new connection: connection  channelName: channelName) openView! !
Object subclass: #IRCChannelSummary
	instanceVariableNames: 'name numUsers topic '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCChannelSummary commentStamp: '<historical>' prior: 0!
very basic info on an IRC channel; specifically, that returned by a LIST command!


!IRCChannelSummary methodsFor: 'access' stamp: 'ls 9/2/1998 22:39'!
name
	"the name of the channel"
	^name! !

!IRCChannelSummary methodsFor: 'access' stamp: 'ls 9/2/1998 22:40'!
numUsers
	"number of users currently on the channel"
	^numUsers! !

!IRCChannelSummary methodsFor: 'access' stamp: 'ls 9/2/1998 22:40'!
topic
	"the current topic of discussion"
	^topic! !


!IRCChannelSummary methodsFor: 'printing' stamp: 'ls 9/2/1998 23:35'!
printOn: aStream
	aStream nextPutAll: 'IRCChannel '.
	aStream nextPutAll: self name.
	aStream nextPutAll: ' ('.
	aStream nextPutAll: numUsers printString.
	aStream nextPutAll: ')'.! !


!IRCChannelSummary methodsFor: 'private-initialization' stamp: 'ls 9/2/1998 22:38'!
initializeName: aString  numUsers: anInteger  topic: anotherString
	name _ aString.
	numUsers _ anInteger.
	topic _ anotherString.! !

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

IRCChannelSummary class
	instanceVariableNames: ''!

!IRCChannelSummary class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 22:39'!
name: cname  numUsers: numUsers  topic: topic
	^super new initializeName: cname  numUsers: numUsers  topic: topic! !
Model subclass: #IRCChannelUsersBrowser
	instanceVariableNames: 'channel userList userIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCChannelUsersBrowser commentStamp: '<historical>' prior: 0!
Used for browsing the list of users on a particular channel.!


!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:17'!
onChannel: aChannel
	channel _ aChannel.
	userList _ #().
	userIndex _ 0.

	channel addDependent: self.
	self refreshUserList.! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'RAA 1/17/2001 14:28'!
openAsMorph
	| win listView talkToButton |
	win _ SystemWindow labelled: 'users in ', channel name.
	win model: self.

	listView _ PluggableListMorph on: self list: #userList selected: #userIndex  changeSelected: #userIndex:.
	win addMorph: listView  frame: (0@0 extent: 1@0.9).

	talkToButton _ PluggableButtonMorph on: self getState: nil action: #talkTo.
	talkToButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'talk to selected user'.
	win addMorph: talkToButton  frame: (0@0.9 extent: 1@0.1).

	win openInWorld! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:18'!
openView
	^self openAsMorph! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:22'!
refreshUserList
	"update the user list from the channel"
	|oldName |

	(userIndex > 0) ifTrue: [
		oldName _ userList at: userIndex ].

	userList _ channel memberNames asSortedCollection asArray.
	userIndex _ 0.

	oldName ifNotNil: [
		"try to select the same user again"
		userIndex _ userList indexOf: oldName ].

	self changed: #userList.
	self changed: #userIndex.
! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:42'!
selectedUser
	"return the name of the selected user, or nil if none"
	^userList at: userIndex ifAbsent: [nil ].! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:43'!
talkTo
	"open a window for talking to the selected user"
	| user |
	user _ self selectedUser.
	user ifNil: [ ^self ].

	^IRCDirectMessagesObserver openForConnection: channel connection   talkingTo: user! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:17'!
update: aSymbol
	aSymbol == #memberNames ifTrue: [ self refreshUserList ].! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:16'!
userIndex
	"return the index in userList of the user currently selected"
	^userIndex! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:25'!
userIndex: anInteger
	"change which user is selected"
	userIndex _ anInteger.
	self changed: #userIndex.! !

!IRCChannelUsersBrowser methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:16'!
userList
	"return the current list of user names"
	^userList! !

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

IRCChannelUsersBrowser class
	instanceVariableNames: ''!

!IRCChannelUsersBrowser class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 09:20'!
onChannel: channel
	^self new onChannel: channel! !

!IRCChannelUsersBrowser class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 09:20'!
openOnChannel: channel
	^(self onChannel: channel) openView! !
Model subclass: #IRCConnection
	instanceVariableNames: 'socket protocolMessagesToSend sendBuffer recieveBuffer nick userName fullName server port channelList channelListBeingBuilt motd motdBeingBuilt subscribedChannels directMessageSubscribers protocolMessageSubscribers consoleText messagesProcessed '
	classVariableNames: 'DefaultFullName DefaultNick DefaultPort DefaultServer DefaultUserName MessageHandlers '
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCConnection commentStamp: '<historical>' prior: 0!
A connection to an IRC server.  This handles spooling messages in and out, and converts between network commands and more convenient data structures.

Start up an instance along with an interface with:

		IRCConnection new openView

!


!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:04'!
fullName
	^fullName! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:26'!
fullName: aString
	fullName _ aString asString.
	DefaultFullName _ fullName.
	^true! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/2/1998 18:23'!
nick
	^nick ifNil: [ '(not set)' ]! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
nick: aString
	nick _ aString asString.
	DefaultNick _ nick.
	^true! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/2/1998 18:24'!
portAsString
	^port printString! !

!IRCConnection methodsFor: 'access' stamp: 'jm 10/3/1998 08:37'!
portAsString: aString

	port _ aString asString asNumber.
	DefaultPort _ port.
	^ true
! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/2/1998 18:23'!
server
	^server ifNil: [ '(not set)' ]! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
server: aString
	server _ aString asString.
	DefaultServer _ server.
	^true! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:04'!
userName
	^userName! !

!IRCConnection methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
userName: aText
	userName _ aText asString.
	DefaultUserName _ userName.
	^true! !


!IRCConnection methodsFor: 'server info' stamp: 'ls 9/6/1998 20:23'!
channelInfo: channelName
	"return cached info on a channel"
	| lChannelName |
	lChannelName _ channelName asIRCLowercase.
	^subscribedChannels at: lChannelName ifAbsent: [ 
		"no info available--create and return a skeleton"
		subscribedChannels at: lChannelName put:
			(IRCChannelInfo forChannelNamed: channelName  onConnection: self) ]! !

!IRCConnection methodsFor: 'server info' stamp: 'ls 9/2/1998 23:35'!
channelList
	"returns the list of channels, or nil if it hasn't been retrieved yet"
	^channelList! !

!IRCConnection methodsFor: 'server info' stamp: 'ls 9/2/1998 23:53'!
channelListReport
	"list the channels in a textual format"
	| list |
	list _ self channelList.
	list ifNil: [ ^'(info not available)' ].
	^String streamContents: [ :stream |
		stream nextPutAll: 'Channel List'; cr.
		stream nextPutAll: '--------------'; cr.
		list do: [ :channel |
			stream nextPutAll: channel name.
			stream nextPutAll: '('.
			stream nextPutAll: channel numUsers printString.
			stream nextPutAll: ')		['.
			stream nextPutAll: channel topic.
			stream nextPutAll: ']'.
			stream cr ] ]! !

!IRCConnection methodsFor: 'server info' stamp: 'ls 9/2/1998 23:18'!
motd
	"return the most recently seen Message of the Day, or nil if none has been seen yet"
	^motd! !


!IRCConnection methodsFor: 'private' stamp: 'ls 9/17/1998 06:51'!
initialize
	self reset.

	server _ DefaultServer.
	port _ DefaultPort.
	nick _ DefaultNick.
	userName _ DefaultUserName.
	fullName _ DefaultFullName.

	directMessageSubscribers _ IdentitySet new.
	protocolMessageSubscribers _ IdentitySet new.

	consoleText _ Text new.! !

!IRCConnection methodsFor: 'private' stamp: 'ls 9/17/1998 08:44'!
reset
	"prepare for a new connection"
	recieveBuffer _ String new.
	protocolMessagesToSend _ OrderedCollection new.
	sendBuffer _ nil.
	socket _ nil.
	channelList _ nil.
	channelListBeingBuilt _ nil.
	motd _ nil.
	motdBeingBuilt _ nil.
	messagesProcessed _ 0.
	subscribedChannels _ Dictionary new.
! !

!IRCConnection methodsFor: 'private' stamp: 'ls 9/4/1998 23:22'!
step
	self processIO! !

!IRCConnection methodsFor: 'private' stamp: 'di 1/14/1999 09:12'!
wantsSteps
	^ true! !


!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:38'!
processChannelList: aMessage
	"an item has arrived in the list of channels"
	| chanName chanNumUsers chanTopic |

	aMessage arguments size < 4 ifTrue: [ ^self ].

	chanName _ aMessage arguments at: 2.
	chanNumUsers _ (aMessage arguments at: 3) asNumber.
	chanTopic _ (aMessage arguments at: 4).

	chanName = '*' ifTrue: [ ^self ].

	channelListBeingBuilt ifNil: [ channelListBeingBuilt _ OrderedCollection new ].
	channelListBeingBuilt add: (IRCChannelSummary name: chanName numUsers: chanNumUsers topic: chanTopic). ! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:39'!
processChannelListEnd: aMessage
	"a complete channel listing has arrived"

	"end of a channel listing"
	channelList _ channelListBeingBuilt asArray.
	channelListBeingBuilt _ nil.
	self changed: #channelList. 
	self changed: #channelListReport.! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:37'!
processChannelListStart: aMessage
	"start of a channel listing"
	channelListBeingBuilt _ OrderedCollection new.! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/17/1998 09:33'!
processJoin: aMessage
	"a user is joining a channel"
	| channelName user |
	channelName _ aMessage arguments first.
	user _ aMessage prefix.
	(user includes: $!!) ifTrue: [ user _ user copyFrom: 1 to: (user indexOf: $!!)-1 ].

	(self channelInfo: channelName) addMember: user! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/17/1998 08:48'!
processMessage: aMessage
	| handler |
	protocolMessageSubscribers do: [ :subscriber |
		subscriber ircProtocolMessage: aMessage ].

	handler _ MessageHandlers at: aMessage command ifAbsent: [ nil ].
	handler ifNil: [	^self ].
	^self perform: handler  with: aMessage! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:36'!
processMotd: aMessage
	"a new line has arrived for the MOTD"
	motdBeingBuilt nextPutAll: aMessage arguments second.
	motdBeingBuilt cr.! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:36'!
processMotdEnd: aMessage
	"the whole MOTD has arrived"
	motd _ motdBeingBuilt contents.
	motdBeingBuilt _ nil.
	self changed: #motd.! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/4/1998 22:35'!
processMotdStart: aMessage
	"MOTD is being transmitted"
	motdBeingBuilt _ WriteStream on: String new.! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/17/1998 10:19'!
processNamReply: aMessage
	"list of names for a channel, probably a channel being joined"
	| names lChannelName channelInfo |

	names _ aMessage arguments last findTokens: ' '.
	names _ names collect: [ :origName |
		('+@' includes: origName first) 
			ifTrue: [ origName copyFrom: 2 to: origName size ]
			ifFalse: [ origName ] ].

	lChannelName _ (aMessage arguments at: 3) asIRCLowercase.
	channelInfo _ subscribedChannels at: lChannelName ifAbsent: [nil].
	channelInfo ifNotNil: [ channelInfo addMembers: names ].! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/17/1998 10:07'!
processNoTopic: aMessage
	"remove a channel's topic"
	(self channelInfo: (aMessage arguments at: 2)) topic: ''! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 12/10/1998 23:16'!
processPart: aMessage
	"a user is leaving a channel"
	| channelName user |
	channelName _ aMessage arguments first.
	user _ aMessage prefix.
	(user includes: $!!) ifTrue: [ user _ user copyFrom: 1 to: (user indexOf: $!!)-1 ].

	(self channelInfo: channelName) removeMember: user! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/15/1998 06:35'!
processPing: aMessage
	"ping request"
	self sendMessage: (IRCProtocolMessage command: 'pong' arguments: aMessage arguments).! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/15/1998 06:35'!
processPrivmsg: aMessage
	"handle a PRIVMSG or NOTICE message"
	| sender recipient text privMessage info |

	"put together the message"
	sender _ aMessage prefix.
	recipient _ aMessage arguments at: 1.
	text _ aMessage arguments at: 2.
	privMessage _ IRCMessage sender: sender  recipient: recipient  text: text.

	"broadcast the message to all subscribers"
	info _ subscribedChannels at: recipient asIRCLowercase ifAbsent: [ nil ].
	info ifNotNil: [ info subscribers do: [ :sub |
		sub ircMessageRecieved: privMessage ] ].
	recipient asIRCLowercase = nick asIRCLowercase ifTrue: [
		directMessageSubscribers do: [ :sub |
			sub ircMessageRecieved: privMessage ] ].
! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 12/11/1998 00:15'!
processQuit: aMessage
	"a user has left IRC.  Remove them from all chanels"
	|  user |
	user _ aMessage prefix.
	(user includes: $!!) ifTrue: [ user _ user copyFrom: 1 to: (user indexOf: $!!)-1 ].

	subscribedChannels do: [ :channel |
		(channel memberNames includes: user) 
			ifTrue: [ channel removeMember: user ] ].! !

!IRCConnection methodsFor: 'private-message handling' stamp: 'ls 9/17/1998 10:14'!
processTopic: aMessage
	"change a channel topic"
	| args |
	args _ aMessage arguments.
	args size < 2 ifTrue: [ "malformed message" ^self ].
	(self channelInfo: (args at: (args size-1))) topic: (args at: args size).! !


!IRCConnection methodsFor: 'menu' stamp: 'ls 9/17/1998 11:18'!
consoleMenu: menu
	^menu
		labels: 'connect\disconnect\message of the day\channel list\talk to individual\inspect me' withCRs
		lines: #(2 4 5)
		selections: #(openConnectionDialogue disconnect openMotd openChannelList talkTo inspect)! !

!IRCConnection methodsFor: 'menu' stamp: 'ls 9/17/1998 11:17'!
talkTo
	"talk to some user using 1-to-1 chat messages"
	| user |
	user _ FillInTheBlank request: 'user to talk to'.
	user _ user withBlanksTrimmed.
	user isEmpty ifTrue: [ ^self ].

	IRCDirectMessagesObserver openForConnection: self  talkingTo: user! !


!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:42'!
addToConsole: aText
	"add aString to the text being displayed on console."
	consoleText _ consoleText, aText.
	consoleText size > 2000 ifTrue: [
		consoleText _ consoleText copyFrom: (consoleText size - 1000) to: consoleText size ].
	self changed: #consoleText.! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:41'!
consoleText
	^consoleText! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:43'!
consoleTextSelection
	| size |
	size _ self consoleText size.
	^size+1 to: size! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:55'!
openAsMorph
	| win consolePane inputPane |

	"build views"
	win _ SystemWindow labelled: 'IRC'.
	win model: self.

	consolePane _ PluggableTextMorph on: self text: #consoleText accept: nil readSelection: #consoleTextSelection menu: #consoleMenu:.
	win addMorph: consolePane frame: (0@0 extent: 1@0.9).

	inputPane _ PluggableTextMorph on: self text: nil accept: #sendRawCommand:.
	inputPane acceptOnCR: true.
	win addMorph: inputPane  frame: (0@0.9 extent: 1@0.1).


	"subscribe to protocol messages and direct messages, so we can display them on console"
	self subscribeToDirectMessages: self.
	self subscribeToProtocolMessages: self.

	win openInWorld! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/4/1998 23:32'!
openChannelList
	"open a view on the list of channels"
	IRCChannelListBrowser openForConnection: self! !

!IRCConnection methodsFor: 'UI' stamp: 'RAA 1/17/2001 14:29'!
openConnectionDialogue
	"open a dialogue for making new connections"
	| dialogue textEntry connectButton y yDelta descMorph textEntryList |
	dialogue _ SystemWindow new.

	y _ 0.
	yDelta _ 0.8 / 5.
	textEntryList _ OrderedCollection new.
	#(
		'server'		server
		'port'		portAsString
		'nick'		nick
		'username'	userName
		'full name'	fullName
	) pairsDo: [ :desc :meth |
		descMorph _ PluggableButtonMorph on: self getState: nil action: nil.
		descMorph
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			label: desc.
		dialogue addMorph: descMorph  frame: (0@y extent: 0.3@yDelta).

		textEntry _ PluggableTextMorph on: self text: meth accept: (meth, ':') asSymbol.
		textEntry 
			extent: 200@20;
			color: (Color r: 1.0 g: 1.0 b: 0.599);
			acceptOnCR: true.
		dialogue addMorph: textEntry frame: (0.3@y extent: 0.7@yDelta).
		textEntryList add: textEntry.

		y _ y + yDelta.
	].

	connectButton _ PluggableButtonMorph on: [
			textEntryList do: [ :m | m hasUnacceptedEdits ifTrue:[ m accept ] ].
			self connect 
		] fixTemps getState: nil action: #value.
	connectButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'connect'.
	dialogue addMorph: connectButton frame: (0@0.8 extent: 1@0.2).

	dialogue setLabel: 'connect to an IRC server'.

	dialogue openInWorld.! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/5/1998 01:12'!
openDirectMessagesObserver
	IRCDirectMessagesObserver openForConnection: self! !

!IRCConnection methodsFor: 'UI' stamp: 'RAA 1/17/2001 14:29'!
openMotd
	"open a view on the MOTD"
	| win textView updateButton |

	win _ SystemWindow labelled: 'MOTD'.

	textView _ PluggableTextMorph on: self text: #motd accept: nil.
	win addMorph: textView  frame: (0@0 extent: 1@0.9).

	updateButton _ PluggableButtonMorph on: self getState: nil action: #requestMotd.
	updateButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'update'.
	win addMorph: updateButton  frame: (0@0.9 extent: 1@0.1).

	win openInWorld.! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:37'!
openView
	^self openAsMorph! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/17/1998 06:45'!
perform: aSelector  orSendTo: editor
	(self respondsTo: aSelector) ifTrue: [
		^self perform: aSelector ].

	^editor perform: aSelector! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/4/1998 23:36'!
release
	super release.
	self disconnect.! !

!IRCConnection methodsFor: 'UI' stamp: 'jm 10/3/1998 08:43'!
sendRawCommand: aString
	"Send a command directly."

	| message |
	message _ [IRCProtocolMessage fromString: aString asString] ifError: [:a :b | nil].
	message ifNil: [^ false].
	self sendMessage: message.
	^ true
! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/6/1998 20:21'!
subscribe: anObject toChannel: channelName
	"send all messages for channelName to anObject.  anObject must implemented #ircMessageReceieved:"

	|  info |

	info _ self channelInfo: channelName.

	info subscribe: anObject.! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/4/1998 18:06'!
subscribeToDirectMessages: anObject
	"send all messages directly to the user's nick to anObject.  anObject must implemented #ircMessageReceieved:"
	directMessageSubscribers add: anObject.! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/15/1998 06:30'!
subscribeToProtocolMessages: anObject
	"anObject should respond to #ircProtocolMessage:.  It will be sent all incoming messages"
	protocolMessageSubscribers add: anObject! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/5/1998 00:38'!
unsubscribe: anObject fromChannel: channelName
	"see subscribe:toChannel:"

	|  lChannelName info |

	lChannelName _ channelName asIRCLowercase.

	info _ subscribedChannels at: lChannelName ifAbsent: [ ^self ].
	info unsubscribe: anObject.
! !

!IRCConnection methodsFor: 'UI' stamp: 'ls 9/5/1998 00:10'!
unsubscribeFromDirectMessages: anObject 
	"see #subscribeFromDirectMessages:"
	directMessageSubscribers remove: anObject ifAbsent: []! !


!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 21:59'!
join: channelName
	"join a channel"

	self sendMessage: (IRCProtocolMessage
		command: 'join'
		arguments: (Array with: channelName))! !

!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 21:59'!
leave: channelName
	"leave a channel"

	self sendMessage: (IRCProtocolMessage
		command: 'part'
		arguments: (Array with: channelName))! !

!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/12/1998 04:54'!
privmsgFrom: from  to: to  text: text
	"send a private message.  'to' can be a channel name...."
	| msg |
	msg _ (IRCProtocolMessage
		prefix: from
		command: 'privmsg'
		arguments: (Array with: to  with: text)).

	self processMessage: msg.	"because these aren't sent back by default"
	self sendMessage: msg.! !

!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 21:59'!
quit
	"tell the server we are leaving"
	self sendMessage: (IRCProtocolMessage command: 'quit')! !

!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 23:36'!
requestChannelList
	"request a list of all channels"
	self sendMessage: (IRCProtocolMessage command: 'list')! !

!IRCConnection methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 23:18'!
requestMotd
	self sendMessage: (IRCProtocolMessage command: 'motd')! !


!IRCConnection methodsFor: 'network IO' stamp: 'ls 9/4/1998 23:30'!
connect
	"connect to a server"
	| addr |

	Socket initializeNetwork.
	socket ifNotNil: [ socket destroy ].
	self reset.

	Utilities informUser: 'looking up server address...' during: [
		addr _ NetNameResolver addressForName: server ].
	addr ifNil: [ ^PopUpMenu notify: 'could not find address for ', server ].

	socket _ Socket new.
	socket connectTo: addr  port: port.

	self sendMessage: (IRCProtocolMessage fromString: 'NICK ', nick).
	self sendMessage: (IRCProtocolMessage fromString: 'USER ', userName, ' * * :', fullName).! !

!IRCConnection methodsFor: 'network IO' stamp: 'ls 9/4/1998 21:27'!
disconnect	
	"disconnect from the server"
	socket ifNotNil: [ socket isValid ifTrue: [ 
		Transcript show: 'disconnecting from IRC', String cr.
		socket close ] ].	
	socket _ nil.! !

!IRCConnection methodsFor: 'network IO' stamp: 'ls 9/2/1998 17:45'!
isConnected
	"whether we are currently connected"
	^socket ~~ nil  and: [ socket isConnected ]! !

!IRCConnection methodsFor: 'network IO' stamp: 'ls 9/3/1998 00:19'!
processIO
	"do as much network IO as is immediately possible"
	
	| amount idx messageText message |

	"do nothing if the socket isn't ready for work"
	(socket isNil or: [socket isValid not or: [ socket isConnected not ]]) ifTrue: [ 
		"Transcript show: 'socket not ready; no IO done'; cr."
		^self ].


	"first do sending"
	[ socket sendDone and: [ sendBuffer isNil not or: [ protocolMessagesToSend size > 0 ] ] ]
	whileTrue: [
		sendBuffer ifNil: [
			protocolMessagesToSend isEmpty ifFalse: [
				sendBuffer _ protocolMessagesToSend removeFirst asString ] ].

		sendBuffer ifNotNil: [
			amount _ socket sendSomeData: sendBuffer.
			sendBuffer _ sendBuffer copyFrom: amount+1 to: sendBuffer size.
			sendBuffer isEmpty ifTrue: [ sendBuffer _ nil ] ].
	].


	"now do receiving"
	[ socket dataAvailable ] whileTrue: [ 
		recieveBuffer _ recieveBuffer, socket getData ].

	"parse as many messages as possible"
	[ idx _ recieveBuffer indexOf: Character lf.  
	  idx > 0 ] whileTrue: [
		messageText _ recieveBuffer copyFrom: 1 to: idx.
		message _ IRCProtocolMessage fromString: messageText.
		
		self processMessage: message.

		recieveBuffer _ recieveBuffer copyFrom: idx+1 to: recieveBuffer size ].
! !

!IRCConnection methodsFor: 'network IO' stamp: 'ls 9/2/1998 21:53'!
sendMessage: aMessage
	"queue a message for sending"
	protocolMessagesToSend addLast: aMessage.! !


!IRCConnection methodsFor: 'naval mode' stamp: 'ls 9/17/1998 06:49'!
ircMessageRecieved: aMessage
	| sender newLine |

	Smalltalk beep.

	sender _ aMessage sender ifNil: [ 'me' ].
	(sender includes: $!!) ifTrue: [ sender _ sender copyFrom: 1 to: (sender indexOf: $!!)-1 ].

	newLine _ 
		(Text string: sender emphasis: (Array with: TextEmphasis bold)), 
		': ', aMessage text, String cr.

	self addToConsole: newLine.! !

!IRCConnection methodsFor: 'naval mode' stamp: 'ls 9/17/1998 06:47'!
ircProtocolMessage: msg
	"a new message.  log it on the console, unless it's a channel listing"
	(msg command ~= IRCConnection RPLList printString
	and: [ msg command ~= IRCConnection RPLMotd ]) ifTrue: [
		self addToConsole: msg asString ].! !

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

IRCConnection class
	instanceVariableNames: ''!

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 22:59'!
RPLAway
	"someone has marked themselves as away"
	^301! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:09'!
RPLBanList
	""
	^367! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:04'!
RPLChannelModeIs
	""
	^324! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:09'!
RPLEndOfBanList
	""
	^368! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:08'!
RPLEndOfLinks
	""
	^365! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:10'!
RPLEndOfMotd
	"the MOTD has been completely transmitted"
	^376! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:08'!
RPLEndOfNames
	""
	^366! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:07'!
RPLEndOfWho
	"end of responses to a WHO"
	^315! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:02'!
RPLEndOfWhoIs
	""
	^318! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:03'!
RPLEndOfWhoWas
	""
	^369! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:05'!
RPLInviting
	"inform that you are inviting someone to a channel"
	^341! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:08'!
RPLLinks
	""
	^364! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:04'!
RPLList
	"one item in a list command"
	^322! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:04'!
RPLListEnd
	"marks end of listing from a LIST command"
	^323! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:04'!
RPLListStart
	"start of response to a LIST command"
	^321! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:45'!
RPLMotd
	"a line from the MOTD"
	^372! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/3/1998 18:17'!
RPLMotd2
	"secondd version of a line from the MOTD"
	^377! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:09'!
RPLMotdStart
	"a MOTD listing is beginning"
	^375! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:08'!
RPLNamReply
	""
	^353! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:05'!
RPLNoTopic
	"no topic is set for the given channel"
	^331! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 22:59'!
RPLNowaway
	"something to do with AWAY"
	^306! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:06'!
RPLSummoning
	"inform that you are summoning a user"
	^342! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:05'!
RPLTopic
	"topic for the given channel"
	^332! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 22:59'!
RPLUnaway
	"someone has marked themselves as unaway"
	^305! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:06'!
RPLVersion
	"version info for the server"
	^351! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:02'!
RPLWhoIsIdle
	""
	^317! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:00'!
RPLWhoIsOperator
	""
	^313! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:00'!
RPLWhoIsServer
	""
	^312! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:00'!
RPLWhoIsUser
	""
	^311! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:07'!
RPLWhoReply
	"response to a WHO"
	^352! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:03'!
RPLWhoWasUser
	""
	^314! !

!IRCConnection class methodsFor: 'reply codes' stamp: 'ls 9/2/1998 23:02'!
RPLWhoisChannels
	""
	^319! !


!IRCConnection class methodsFor: 'class initialization' stamp: 'ls 9/17/1998 10:10'!
initialize
	"IRCConnection initialize"


	self initializeMessageHandlers.

	DefaultServer _ 'us.chatnet.org'.
	DefaultPort _ 6667.
	DefaultNick _ 'nick'.
	DefaultUserName _ 'username'.
	DefaultFullName _ 'J. Doe <jdoe@somewhere>'.! !

!IRCConnection class methodsFor: 'class initialization' stamp: 'ls 12/11/1998 00:16'!
initializeMessageHandlers
	"initilize the table mapping IRC commands to processing methods"
	"IRCConnection initializeMessageHandlers"

	MessageHandlers _ Dictionary new.
	#(
		372		processMotd:
		377		processMotd:
		375		processMotdStart:
		376		processMotdEnd:

		ping	processPing:

		join		processJoin:
		part	processPart:
		quit		processQuit:

		privmsg		processPrivmsg:
		notice		processPrivmsg:

		321		processChannelListStart:
		322		processChannelList:
		323		processChannelListEnd:

		331		processNoTopic:
		332		processTopic:
		topic	processTopic:

		353		processNamReply:
	) pairsDo: [ :command  :method |
		MessageHandlers at: command asString put: method ].
! !


!IRCConnection class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 21:31'!
new
	^super new initialize! !
Model subclass: #IRCDirectMessagesObserver
	instanceVariableNames: 'connection chatText talkingTo '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 11:11'!
addToChatText: aString
	chatText _ chatText, aString.
	chatText size > 1000 ifTrue: [
		chatText _ chatText copyFrom: (chatText size - 500) to: chatText size ].

	self changed: #chatText.! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/5/1998 00:12'!
chatAreaSelection 
	^self chatTextSelection! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/4/1998 23:52'!
chatText
	^chatText! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 11:11'!
chatTextSelection
	^chatText size+1 to: chatText size! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/5/1998 00:01'!
initialize: aConnection
	connection _ aConnection.
	chatText _ Text new.
	connection subscribeToDirectMessages: self.! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 11:11'!
ircMessageRecieved: aMessage
	| sender newLine |
	sender _ aMessage sender ifNil: [ 'me' ].
	(sender includes: $!!) ifTrue: [ sender _ sender copyFrom: 1 to: (sender indexOf: $!!)-1 ].

	talkingTo ifNotNil: [
		"only display messages to or from talkingTo"
		sender asIRCLowercase = talkingTo asIRCLowercase ifFalse: [^self ] ].

	newLine _ 
		(Text string: sender emphasis: (Array with: TextEmphasis bold)), 
		': ', aMessage text, String cr.

	self addToChatText: newLine.
! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 11:15'!
openMorphicView
	"open a view for messages sent here"
	| win textArea inputArea |

	win _ SystemWindow new.
	win setLabel: (talkingTo ifNotNil: [ talkingTo ] ifNil: [ 'private messages' ]).
	win model: self.

	textArea _ PluggableTextMorph on: self text: #chatText accept: nil readSelection: #chatTextSelection menu: nil.

	talkingTo
		ifNil: [ win addMorph: textArea frame: (0@0 extent: 1@1) ]
		ifNotNil: [
			win addMorph: textArea  frame: (0@0 extent: 1@0.9).

			inputArea _ PluggableTextMorph on: self text: nil accept: #sendMessage:.
			inputArea acceptOnCR: true.
			win addMorph: inputArea  frame: (0@0.9 extent: 1@0.1) ].

	win openInWorld.! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/4/1998 23:53'!
openView
	^self openMorphicView! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/8/1998 04:55'!
release
	connection unsubscribeFromDirectMessages: self.
	super release.! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 11:09'!
sendMessage: aString
	"send a message to the user we are talking to"
	| newLine |
	talkingTo ifNil: [ Smalltalk beep.  ^self ].

	connection privmsgFrom: nil  to: talkingTo  text: aString.

	newLine _ (Text string: 'me' attribute: TextEmphasis bold),
		': ', aString, String cr.
	self addToChatText: newLine.

	^true! !

!IRCDirectMessagesObserver methodsFor: 'as yet unclassified' stamp: 'ls 9/17/1998 09:38'!
talkingTo: aName
	"set who this window is for talking to"
	talkingTo _ aName! !

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

IRCDirectMessagesObserver class
	instanceVariableNames: ''!

!IRCDirectMessagesObserver class methodsFor: 'instance creation' stamp: 'ls 9/5/1998 00:00'!
forConnection: aConnection
	^super new initialize: aConnection! !

!IRCDirectMessagesObserver class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 09:38'!
forConnection: aConnection  talkingTo: aName
	^(super new initialize: aConnection) talkingTo: aName! !

!IRCDirectMessagesObserver class methodsFor: 'instance creation' stamp: 'ls 9/5/1998 00:00'!
openForConnection: aConnection
	^(self forConnection: aConnection) openView! !

!IRCDirectMessagesObserver class methodsFor: 'instance creation' stamp: 'ls 9/17/1998 09:38'!
openForConnection: aConnection  talkingTo: aName
	^(self forConnection: aConnection talkingTo: aName) openView! !
Object subclass: #IRCMessage
	instanceVariableNames: 'sender recipient text '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCMessage commentStamp: '<historical>' prior: 0!
A message on IRC.  It has a sender (usually a username), a recipient (usually a user or channel name), and some text.!


!IRCMessage methodsFor: 'private-initialization' stamp: 'ls 9/2/1998 17:14'!
initializeSender: sender0  recipient: recipient0  text: text0
	sender _ sender0.
	recipient _ recipient0.
	text _ text0.! !


!IRCMessage methodsFor: 'access' stamp: 'ls 9/2/1998 17:15'!
recipient
	"name the message is destined to"
	^recipient! !

!IRCMessage methodsFor: 'access' stamp: 'ls 9/2/1998 17:15'!
sender
	"name of the message's sender"
	^sender! !

!IRCMessage methodsFor: 'access' stamp: 'ls 9/2/1998 17:15'!
text
	"message text"
	^text! !

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

IRCMessage class
	instanceVariableNames: ''!

!IRCMessage class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 17:15'!
sender: sender  recipient: recipient  text: text
	"create a new message with the given sender, recipient, and text"
	^super new initializeSender: sender  recipient: recipient text: text! !
Object subclass: #IRCMessagePattern
	instanceVariableNames: 'sender recipient '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCMessagePattern commentStamp: '<historical>' prior: 0!
A pattern for matching IRC messages.  Currently one can only match on the sender or the reciever.!


!IRCMessagePattern methodsFor: 'private-initialization' stamp: 'ls 9/2/1998 17:41'!
sender: sender0  recipient: recipient0
	sender _ sender0.
	recipient _ recipient0.! !


!IRCMessagePattern methodsFor: 'filtering' stamp: 'ls 9/2/1998 17:42'!
matches: aMessage
	"decide whether the message matches this pattern"
	sender ifNotNil: [ sender = aMessage sender ifFalse: [ ^false ] ].
	recipient ifNotNil: [ recipient = aMessage recipient ifFalse: [ ^false ] ].
	^true! !

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

IRCMessagePattern class
	instanceVariableNames: ''!

!IRCMessagePattern class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 18:11'!
recipient: recipient
	"create a pattern matching messages to the given recipient"
	^self sender: nil  recipient: recipient! !

!IRCMessagePattern class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 18:10'!
sender: sender
	"create a pattern for messages from the given sender"
	^self sender: sender  recipient: nil! !

!IRCMessagePattern class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 18:11'!
sender: sender  recipient: recipient
	"create a pattern matching messages from the given sender and to the given recipient"
	^super new sender: sender  recipient: recipient! !
Object subclass: #IRCMessageSet
	instanceVariableNames: 'messages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCMessageSet commentStamp: '<historical>' prior: 0!
holds some subset of the messages coming in from an IRC connection.  subclasses define specific criteria for filtering the messages.!


!IRCMessageSet methodsFor: 'as yet unclassified' stamp: 'ls 8/21/1998 10:39'!
acceptMessage: ircMessage
	"whether the given message should be accepted by this set"
	^self subclassResponsibility! !
SystemWindow subclass: #IRCMorph
	instanceVariableNames: 'nick userName fullName server port connection messageCollections consoleText '
	classVariableNames: 'DefaultFullName DefaultNick DefaultPort DefaultServer DefaultUserName '
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCMorph commentStamp: '<historical>' prior: 0!
A Morph for interfacing with IRC.!


!IRCMorph methodsFor: 'console' stamp: 'ls 9/4/1998 21:15'!
addToConsole: aText
	consoleText _ consoleText, aText.
	consoleText size > 1000 ifTrue: [
		consoleText _ consoleText copyFrom: (consoleText size - 500) to: consoleText size ].
	self changed: #consoleText.! !

!IRCMorph methodsFor: 'console' stamp: 'ls 9/4/1998 21:15'!
consoleSelection
	^consoleText size to: consoleText size - 1! !

!IRCMorph methodsFor: 'console' stamp: 'ls 9/4/1998 21:17'!
consoleTextSelection
	^consoleText size to: consoleText size - 1! !


!IRCMorph methodsFor: 'stepping' stamp: 'ls 9/3/1998 00:19'!
step
	connection processIO.! !

!IRCMorph methodsFor: 'stepping' stamp: 'ls 9/3/1998 00:17'!
stepTime
	^0! !

!IRCMorph methodsFor: 'stepping' stamp: 'ls 9/3/1998 00:19'!
wantsSteps
	^true! !


!IRCMorph methodsFor: 'initialization' stamp: 'RAA 1/17/2001 14:30'!
initialize 
	|  connectButton column channelListButton motdButton consoleView inputPane |
	super initialize.

	connection _ IRCConnection new.

	server _ DefaultServer.
	port _ DefaultPort.
	nick _ DefaultNick.
	userName _ DefaultUserName.
	fullName _ DefaultFullName.

	self setLabel: 'IRC'.
	self extent: 200@100.

	column _ AlignmentMorph newColumn.

	connectButton _ PluggableButtonMorph
		on: self
		getState: nil
		action: #openConnection.
	connectButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'connect to server'.
	column addMorphBack: connectButton.

	motdButton _ PluggableButtonMorph
		on: self
		getState: nil
		action: #openMotd.
	motdButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'view MOTD'.
	column addMorphBack: motdButton.

	channelListButton _ PluggableButtonMorph
		on: self
		getState: nil
		action: #openChannelList.
	channelListButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'channel list'.
	column addMorphBack: channelListButton.

	self addMorph: column frame: (0@0 extent: 0.4@0.8).

	consoleText _ Text new.

	consoleView _ PluggableTextMorph on: self  text: #consoleText accept: nil readSelection: #consoleTextSelection menu: nil.
	self addMorph: consoleView frame: (0.4@0 extent: 0.6@0.8).
	consoleView color: (Color r: 0.937 g: 0.937 b: 0.937).

	inputPane _ PluggableTextMorph on: self text: nil accept: #sendCommand:.
	self addMorph: inputPane frame: (0@0.8 corner: 1@1).! !


!IRCMorph methodsFor: 'interface' stamp: 'ls 9/3/1998 17:29'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu  hand: aHandMorph.

	aCustomMenu addLine.
	aCustomMenu add: 'connect to server' action: #makeConnection.

	aCustomMenu addLine.
	aCustomMenu add: 'view MOTD' action: #openMotd.
	aCustomMenu add: 'view channel list' action: #openChannelList.! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 21:12'!
connect
	connection ifNotNil: [ connection disconnect ].
	connection ifNil: [ connection _ IRCConnection new ].
	connection connectToServer: server  port: port nick: nick  user: userName  fullName: fullName.
	connection subscribeToDirectMessages: self.! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 18:10'!
delete
	super delete.
	connection quit.
	connection processIO.  "give the QUIT a brief chance to happen"
	connection disconnect.! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 22:11'!
ircMessageRecieved: aMessage
	| sender |
	sender _ aMessage sender ifNil: [ nick ].
	self addToConsole: (
		sender asText,
		': ',
		aMessage text,
		String cr).! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 21:57'!
makeConnection
	connection ifNotNil: [ connection disconnect ].
	connection ifNil: [ connection _ IRCConnection new ].
	connection connectToServer: server  port: port nick: nick  user: userName  fullName: fullName.
	connection requestChannelList.    "this is usually necessary, so go ahead and ask for it"! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 23:11'!
openChannel: name
	"open a window for interacting with the given channel"

	IRCChannelObserver openForChannel: name  onConnection: connection ! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/4/1998 21:35'!
openChannelList
	"open a view on the list of channels"
	IRCChannelListBrowser openForConnection: connection! !

!IRCMorph methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:30'!
openConnection
	"open a dialogue for making new connections"
	| dialogue textEntry connectButton y yDelta descMorph |
	dialogue _ SystemWindow new.

	y _ 0.
	yDelta _ 0.8 / 5.

	#(
		'server'		server
		'port'		portAsString
		'nick'		nick
		'username'	userName
		'full name'	fullName
	) pairsDo: [ :desc :meth |
		descMorph _ PluggableButtonMorph on: self getState: nil action: nil.
		descMorph
			hResizing: #spaceFill;
			vResizing: #spaceFill;
			label: desc.
		dialogue addMorph: descMorph  frame: (0@y extent: 0.3@yDelta).

		textEntry _ PluggableTextMorph on: self text: meth accept: (meth, ':') asSymbol.
		textEntry extent: 200@20.
		dialogue addMorph: textEntry frame: (0.3@y extent: 0.7@yDelta).

		y _ y + yDelta.
	].

	connectButton _ PluggableButtonMorph on: self getState: nil action: #connect.
	connectButton
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'connect'.
	dialogue addMorph: connectButton frame: (0@0.8 extent: 1@0.2).

	dialogue setLabel: 'connect to an IRC server'.

	dialogue openInWorld.! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/3/1998 17:44'!
openMotd
	connection openMotd! !

!IRCMorph methodsFor: 'interface' stamp: 'ls 9/8/1998 04:55'!
release
	connection quit.
	connection processIO.  "give the QUIT a brief chance to happen"
	connection disconnect.
	super release.! !

!IRCMorph methodsFor: 'interface' stamp: 'jm 10/3/1998 08:44'!
sendCommand: aString

	| message |
	[message _ IRCProtocolMessage fromString: aString asString] ifError: [nil].
	message ifNil: [^ false].
	connection sendMessage: message.
	^ true
! !


!IRCMorph methodsFor: 'access' stamp: 'ls 9/4/1998 18:49'!
consoleText
	^consoleText! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:04'!
fullName
	^fullName! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:26'!
fullName: aString
	fullName _ aString asString.
	DefaultFullName _ fullName.
	^true! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/2/1998 18:23'!
nick
	^nick ifNil: [ '(not set)' ]! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
nick: aString
	nick _ aString asString.
	DefaultNick _ nick.
	^true! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/2/1998 18:24'!
portAsString
	^port printString! !

!IRCMorph methodsFor: 'access' stamp: 'jm 10/3/1998 08:37'!
portAsString: aString

	port _ aString asString asNumber.
	DefaultPort _ port.
	^ true
! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/2/1998 18:23'!
server
	^server ifNil: [ '(not set)' ]! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
server: aString
	server _ aString asString.
	DefaultServer _ server.
	^true! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:04'!
userName
	^userName! !

!IRCMorph methodsFor: 'access' stamp: 'ls 9/3/1998 18:27'!
userName: aText
	userName _ aText asString.
	DefaultUserName _ userName.
	^true! !

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

IRCMorph class
	instanceVariableNames: ''!

!IRCMorph class methodsFor: 'misc' stamp: 'ls 9/4/1998 18:53'!
hasPrototype
	"it's not needed here...."
	^false! !


!IRCMorph class methodsFor: 'initialization' stamp: 'ls 9/3/1998 20:42'!
initialize 
	"set all the defaults to something reasonable"
	DefaultServer _ 'us.chatnet.org'.
	DefaultPort _ 6667.
	DefaultNick _ 'nick'.
	DefaultUserName _ 'username'.
	DefaultFullName _ 'J. Doe <jdoe@somewhere>'.! !
Object subclass: #IRCProtocolMessage
	instanceVariableNames: 'prefix command arguments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCProtocolMessage commentStamp: '<historical>' prior: 0!
A low-level IRC message; this is an internal format for what actually goes over the wire.!


!IRCProtocolMessage methodsFor: 'IRC commands' stamp: 'ls 9/2/1998 21:57'!
quit
	self sendMessage: (IRCProtocolMessage command: 'quit')! !


!IRCProtocolMessage methodsFor: 'access' stamp: 'ls 9/2/1998 21:49'!
arguments
	"return the arguments to the command"
	^arguments! !

!IRCProtocolMessage methodsFor: 'access' stamp: 'ls 9/2/1998 21:48'!
command
	"return the main command, in lowercase"
	^command! !

!IRCProtocolMessage methodsFor: 'access' stamp: 'ls 9/2/1998 21:49'!
prefix
	"return the prefix of the message, or nil if none"
	^prefix! !


!IRCProtocolMessage methodsFor: 'private-initialization' stamp: 'ls 9/2/1998 21:49'!
prefix: aString  command: anotherString  arguments: aCollection

	prefix _ aString.
	command _ anotherString asLowercase.
	arguments _ aCollection.! !


!IRCProtocolMessage methodsFor: 'encoding' stamp: 'ls 9/2/1998 21:49'!
asString
	"encode in the format used for transferral over the network"
	^String streamContents: [ :stream |
		prefix ifNotNil: [
			stream nextPut: $:.
			stream nextPutAll: prefix.
			stream space ].

		stream nextPutAll: command asUppercase.
		stream space.

		arguments isEmpty ifFalse: [
			"print out all but the last argument"
			(arguments copyFrom: 1 to: (arguments size - 1)) do: [ :arg |
				stream nextPutAll: arg.
				stream space ].
			
			"print the last as a trailer, just to be safe"
			stream nextPut: $:.
			stream nextPutAll: arguments last. ].

		stream nextPut: Character cr.
		stream nextPut: Character lf. ]! !

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

IRCProtocolMessage class
	instanceVariableNames: ''!

!IRCProtocolMessage class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 21:52'!
command: anotherString
	^self command: anotherString  arguments: Array new! !

!IRCProtocolMessage class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 21:52'!
command: anotherString  arguments: aCollection
	^self prefix: nil  command: anotherString  arguments: aCollection! !

!IRCProtocolMessage class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 19:47'!
fromString: aString
	"parse an IRC message from its network format"
	| remainder trailerStart trailer tokens command  arguments prefix idx |

	remainder _ aString.

	"strip the CRLF"
	idx _ remainder indexOf: Character cr.
	idx > 0 ifTrue: [ remainder _ remainder copyFrom: 1 to: idx-1 ].
	idx _ remainder indexOf: Character lf.
	idx > 0 ifTrue: [ remainder _ remainder copyFrom: 1 to: idx-1 ].


	"check if there is a trailer"
	trailerStart _ remainder indexOf: $: startingAt: 2 ifAbsent: [0].
	trailerStart > 0 ifTrue: [
		trailer _ remainder copyFrom: trailerStart+1 to: remainder size.
		remainder _ remainder copyFrom: 1 to: trailerStart-1 ].

	"divide the rest of the string up between spaces"
	tokens _ remainder findTokens: ' '.

	"the command is the first token..."
	command _ tokens removeFirst.
	command first = $: ifTrue: [
		"...unless it starts with a $:, in which case there is a prefix and the command is the second token"
		prefix _ command copyFrom: 2 to: command size.  "copy without the leading :"
		command _ tokens removeFirst ].

	"the arguments are the remaining tokens, plus the trailer if any"
	arguments _ tokens.
	trailer ifNotNil: [ arguments _ arguments copyWith: trailer ].

	^self prefix: prefix  command: command  arguments: arguments.! !

!IRCProtocolMessage class methodsFor: 'instance creation' stamp: 'ls 9/2/1998 19:34'!
prefix: aString  command: anotherString  arguments: aCollection
	^super new prefix: aString  command: anotherString  arguments: aCollection! !
IRCMessageSet subclass: #IRCRecipientFilter
	instanceVariableNames: 'recipient '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-IRC Chat'!
!IRCRecipientFilter commentStamp: '<historical>' prior: 0!
a filter for messages  sent to a particular user!

SimpleButtonMorph subclass: #IconicButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!IconicButton commentStamp: '<historical>' prior: 0!
A "Simple Button" in which the appearance is provided by a Form.!


!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 20:42'!
addLabelItemsTo: aCustomMenu hand: aHandMorph
	"don't do the inherited behavior, since there is no textual label in this case"! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 20:52'!
initialize
	super initialize.
	self useSquareCorners! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 14:11'!
labelFromString: aString
	"Make an iconic label from aString"

	self labelGraphic: (StringMorph contents: aString) imageForm
! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:30'!
labelGraphic: aForm
	| oldLabel graphicalMorph |
	(oldLabel _ self findA: SketchMorph)
		ifNotNil: [oldLabel delete].
	graphicalMorph _ SketchMorph withForm: aForm.
	self extent: graphicalMorph extent + (borderWidth + 6).
	graphicalMorph position: self center - (graphicalMorph extent // 2).
	self addMorph: graphicalMorph.
	graphicalMorph lock
! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 18:38'!
setDefaultLabel
	self labelGraphic: (ScriptingSystem formAtKey: 'squeakyMouse')! !

!IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 20:56'!
shedSelvedge
	self extent: (self extent - (6@6))! !
Dictionary subclass: #IdentityDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!IdentityDictionary methodsFor: 'private' stamp: 'RAA 1/10/2001 14:57'!
fasterKeys
	"This was taking some time in publishing and we didn't really need a Set"
	| answer index |
	answer _ Array new: self size.
	index _ 0.
	self keysDo: [:key | answer at: (index _ index + 1) put: key].
	^ answer! !

!IdentityDictionary methodsFor: 'private' stamp: 'di 12/1/1999 20:54'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key that is the external name for the argument, value. If 
	there is none, answer the result of evaluating exceptionBlock."
 
	self associationsDo: 
		[:association | value == association value ifTrue: [^ association key]].
	^ exceptionBlock value! !

!IdentityDictionary methodsFor: 'private' stamp: 'di 10/1/97 20:51'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet _ IdentitySet new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !

!IdentityDictionary methodsFor: 'private' stamp: 'jm 2/18/98 13:18'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| finish hash start element |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ array size) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
Set subclass: #IdentitySet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!IdentitySet methodsFor: 'private' stamp: 'jm 2/18/98 13:19'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| finish hash start element |
	finish _ array size.
	finish > 4096
		ifTrue: [hash _ anObject identityHash * (finish // 4096)]
		ifFalse: [hash _ anObject identityHash].
	start _ (hash \\ array size) + 1.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !


!IdentitySet methodsFor: 'converting' stamp: 'ar 9/22/2000 10:13'!
asIdentitySet
	^self! !
DisplayTransform subclass: #IdentityTransform
	instanceVariableNames: ''
	classVariableNames: 'Default '
	poolDictionaries: ''
	category: 'Graphics-Transformations'!

!IdentityTransform methodsFor: 'initialize' stamp: 'ar 9/11/2000 21:18'!
setIdentity
	"I *am* the identity transform"
	^self! !


!IdentityTransform methodsFor: 'accessing' stamp: 'di 9/29/2000 09:04'!
angle
	^ 0.0! !

!IdentityTransform methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:18'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^self! !


!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:18'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	^true! !

!IdentityTransform methodsFor: 'testing' stamp: 'ar 9/11/2000 21:19'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	^true! !


!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:27'!
composedWith: aTransform
	^aTransform! !

!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'!
composedWithGlobal: aTransformation
	^aTransformation! !

!IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'!
composedWithLocal: aTransformation
	^aTransformation! !


!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:19'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
globalPointsToLocal: inArray
	"Transform all the points of inArray from global into local coordinates"
	^inArray! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	^aPoint! !

!IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:20'!
localPointsToGlobal: inArray
	"Transform all the points of inArray from local into global coordinates"
	^inArray! !


!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^aRectangle! !

!IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:21'!
sourceQuadFor: aRectangle
	^ aRectangle innerCorners! !


!IdentityTransform methodsFor: 'converting' stamp: 'ar 9/11/2000 21:21'!
asMatrixTransform2x3
	"Represent the receiver as a 2x3 matrix transformation"
	^MatrixTransform2x3 identity! !

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

IdentityTransform class
	instanceVariableNames: ''!

!IdentityTransform class methodsFor: 'class initialization' stamp: 'ar 9/11/2000 21:24'!
initialize
	"IdentityTransform initialize"
	Default _ self basicNew.! !


!IdentityTransform class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 21:24'!
new
	"There can be only one"
	^Default! !
Exception subclass: #IllegalResumeAttempt
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!IllegalResumeAttempt commentStamp: '<historical>' prior: 0!
This class is private to the EHS implementation.  An instance of it is signaled whenever an attempt is made to resume from an exception which answers false to #isResumable.!


!IllegalResumeAttempt methodsFor: 'comment' stamp: 'tfei 6/2/1999 14:59'!
readMe

	"Never handle this exception!!"! !
Morph subclass: #ImageMorph
	instanceVariableNames: 'image '
	classVariableNames: 'DefaultForm '
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!ImageMorph methodsFor: 'initialization'!
initialize

	super initialize.
	self image: DefaultForm.
! !


!ImageMorph methodsFor: 'menu commands'!
grabFromScreen

	self image: Form fromUser.
! !

!ImageMorph methodsFor: 'menu commands' stamp: 'di 9/15/1998 09:58'!
readFromFile
	| fileName |
	fileName _ FillInTheBlank
		request: 'Please enter the image file name'
		initialAnswer: 'fileName'.
	fileName isEmpty ifTrue: [^ self].
	self image: (Form fromFileNamed: fileName).
! !


!ImageMorph methodsFor: 'accessing' stamp: 'bf 10/13/1999 14:09'!
color: aColor
        super color: aColor.
        (image depth == 1 and: [aColor isColor]) ifTrue: [
                image colors: {Color transparent. aColor}.
                self changed]! !

!ImageMorph methodsFor: 'accessing'!
form
	"For compatability with SketchMorph."

	^ image
! !

!ImageMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 20:16'!
image

	^ image
! !

!ImageMorph methodsFor: 'accessing'!
image: anImage

	self changed.
	anImage depth = 1
		ifTrue: [image _ ColorForm mappingWhiteToTransparentFrom: anImage]
		ifFalse: [image _ anImage].
	super extent: image extent.
! !

!ImageMorph methodsFor: 'accessing' stamp: 'ar 11/7/2000 14:57'!
isOpaque
	"Return true if the receiver is marked as being completely opaque"
	extension == nil ifTrue:[^false].
	^self valueOfProperty: #isOpaque ifAbsent:[false]! !

!ImageMorph methodsFor: 'accessing' stamp: 'ar 11/7/2000 14:57'!
isOpaque: aBool
	"Mark the receiver as being completely opaque or not"
	aBool == false
		ifTrue:[self removeProperty: #isOpaque]
		ifFalse:[self setProperty: #isOpaque toValue: aBool].
	self changed! !

!ImageMorph methodsFor: 'accessing' stamp: 'sw 10/24/2000 05:53'!
setNewImageFrom: formOrNil
	"Change the receiver's image to be one derived from the supplied form.  If nil is supplied, clobber any existing image in the receiver, and in its place put a default graphic, either the one known to the receiver as its default value, else a squeaky mouse"

	|  defaultImage |
	formOrNil ifNotNil: [^ self image: formOrNil].
	defaultImage _ self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
	self image: defaultImage
! !


!ImageMorph methodsFor: 'other' stamp: 'sw 10/23/2000 18:22'!
couldHoldSeparateDataForEachInstance
	"Answer whether the receiver can potentially hold separate data for each instance"

	^ true! !

!ImageMorph methodsFor: 'other' stamp: 'sw 10/23/2000 18:22'!
currentDataValue
	"Answer the current data value of the receiver, to be stored in each card instance if appropriate"

	^ image! !

!ImageMorph methodsFor: 'other'!
extent: aPoint
	"Do nothing; my extent is determined by my image Form."
! !

!ImageMorph methodsFor: 'other' stamp: 'sw 12/17/1998 12:11'!
newForm: aForm
	self image: aForm! !

!ImageMorph methodsFor: 'other'!
releaseCachedState

	super releaseCachedState.
	image hibernate.
! !

!ImageMorph methodsFor: 'other' stamp: 'sw 10/25/2000 06:58'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #form definingMorph: self morphGetSelector: #image morphPutSelector: #setNewImageFrom:)! !

!ImageMorph methodsFor: 'other'!
wearCostume: anotherMorph

	self image: anotherMorph form.
! !


!ImageMorph methodsFor: 'drawing' stamp: 'ar 11/7/2000 14:57'!
drawOn: aCanvas
	self isOpaque
		ifTrue:[aCanvas drawImage: image at: bounds origin]
		ifFalse:[aCanvas paintImage: image at: bounds origin]! !

!ImageMorph methodsFor: 'drawing' stamp: 'di 8/12/2000 15:03'!
wantsRoundedCorners

	^ self hasProperty: #roundedCorners! !


!ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:55'!
addCustomMenuItems: aMenu hand: aHand
	super addCustomMenuItems: aMenu hand: aHand.
	aMenu addUpdating: #opacityString action: #changeOpacity! !

!ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:57'!
changeOpacity
	self isOpaque: self isOpaque not! !

!ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:58'!
opacityString
	^self isOpaque ifTrue:['<on>opaque'] ifFalse:['<off>opaque']! !

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

ImageMorph class
	instanceVariableNames: ''!

!ImageMorph class methodsFor: 'class initialization' stamp: 'sw 5/19/1998 18:30'!
authoringPrototype
	| aMorph aForm |
	aMorph _ super authoringPrototype.
	aForm _ ScriptingSystem formAtKey: 'Image'.
	aForm ifNil: [aForm _ aMorph image rotateBy: 90].
	aMorph image: aForm.
	^ aMorph! !

!ImageMorph class methodsFor: 'class initialization' stamp: 'jm 4/10/98 01:09'!
initialize
	"ImageMorph initialize"

	| h p d |
	DefaultForm _ (Form extent: 80@40 depth: 16).
	h _ DefaultForm height // 2.
	0 to: h - 1 do: [:i |
		p _ (i * 2)@i.
		d _ i asFloat / h asFloat.
		DefaultForm fill:
			(p corner: DefaultForm extent - p)
			fillColor: (Color r: d g: 0.5 b: 1.0 - d)].
! !


!ImageMorph class methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:59'!
defaultForm
	^DefaultForm! !


!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'!
fromString: aString 
	"Create a new ImageMorph which displays the input string in the standard button font"

	^ self fromString: aString font: Preferences standardButtonFont! !

!ImageMorph class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:21'!
fromString: aString font: aFont
	"Create a new ImageMorph showing the given string in the given font"

	^ self new image: (StringMorph contents: aString font: aFont) imageForm! !
ImageMorph subclass: #ImageMorphWithSpotlight
	instanceVariableNames: 'spotImage spotShape spotBuffer spotOn '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!ImageMorphWithSpotlight commentStamp: '<historical>' prior: 0!
This class implements an image that appears one way or another depending upon whether it lies within a spotlight shape that moves with the cursor.  As delivered, the shape is a simple circle, the spotlighted appearance is that of a ColorForm, and the non-highlighted apperarance is a derived gray-scale form.

The implementation will space-efficient if supplied with a ColorForm, because the gray-scale derived form will share the same bitmap.

In general, any two images can be used -- one could be blurred, the other sharp -- and the masking form can be any shape.

At some point this class should be merged somehow with ScreeningMorph.!


!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/26/1999 07:51'!
backgroundImage: bkgndImage spotImage: anImage spotShape: formOfDepth1

	"See class comment."
	spotImage _ anImage.
	spotShape _ formOfDepth1.
	spotBuffer _ Form extent: spotShape extent depth: spotImage depth.
	super image: bkgndImage.
	spotOn _ false.! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'ar 2/12/2000 18:06'!
drawOn: aCanvas

	super drawOn: aCanvas.
	spotOn ifTrue:
		[aCanvas paintImage: spotBuffer at: spotBuffer offset].
! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/26/1999 08:05'!
image: anImage

	"The spotlight will reveal the original  form supplied
	while the background form will be derived grayscale."
	"See class comment."
	self backgroundImage: anImage asGrayScale
		spotImage: anImage
		spotShape: (Form dotOfSize: 100)
! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/24/1999 22:37'!
spotChanged

	self invalidRect:
		((spotBuffer offset extent: spotBuffer extent) "intersect: self bounds")! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'ar 5/28/2000 12:09'!
step
	| cp |
	((self bounds expandBy: spotBuffer extent // 2) containsPoint: (cp _ self cursorPoint))
		ifTrue:
		[(cp - (spotBuffer extent // 2)) = spotBuffer offset ifTrue: [^ self].  "No change"
		"Cursor has moved where its spotShape is visible"
		spotOn _ true.
		self spotChanged.
		spotBuffer offset: cp - (spotBuffer extent // 2).
		self spotChanged.
		(BitBlt current toForm: spotBuffer)
			"clear the buffer"
			fill: spotBuffer boundingBox fillColor: (Bitmap with: 0) rule: Form over;
			"Clip anything outside the base form"
			clipRect: (spotBuffer boundingBox
				intersect: (self bounds translateBy: spotBuffer offset negated));
			"Fill the spotBuffer with the spot image"
			copyForm: spotImage to: self position - spotBuffer offset rule: Form over;
			"Mask everything outside the spot shape to 0 (transparent)."
			copyForm: spotShape to: spotShape offset negated rule: Form and
				colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)]
		ifFalse:
		[spotOn ifTrue: [self spotChanged. spotOn _ false]]! !

!ImageMorphWithSpotlight methodsFor: 'all' stamp: 'di 5/24/1999 21:43'!
stepTime

	^ 20! !
Object subclass: #ImageReadWriter
	instanceVariableNames: 'stream '
	classVariableNames: 'ImageNotStoredSignal MagicNumberErrorSignal '
	poolDictionaries: ''
	category: 'Graphics-Files'!
!ImageReadWriter commentStamp: '<historical>' prior: 0!
Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved.

I am an abstract class to provide for encoding and/or decoding an image on a stream.

Instance Variables:
	stream		<ReadStream | WriteStream>	stream for image storages

Class Variables:
	ImageNotStoredSignal		<Signal>	image not stored error signal
	MagicNumberErrorSignal		<Signal>	magic number error signal

Subclasses must implement the following messages:
	accessing
		nextImage
		nextPutImage:
	testing
		canUnderstand         (added tao 10/26/97)!


!ImageReadWriter methodsFor: 'accessing'!
nextImage
	"Dencoding an image on stream and answer the image."

	^self subclassResponsibility! !

!ImageReadWriter methodsFor: 'accessing'!
nextPutImage: anImage
	"Encoding anImage on stream."

	^self subclassResponsibility! !


!ImageReadWriter methodsFor: 'stream access'!
atEnd

	^stream atEnd! !

!ImageReadWriter methodsFor: 'stream access'!
close
	"close if you can"
	(stream respondsTo: #close) ifTrue: [
			stream closed ifFalse: [stream close]]! !

!ImageReadWriter methodsFor: 'stream access'!
contents

	^stream contents! !

!ImageReadWriter methodsFor: 'stream access'!
cr

	^stream nextPut: Character cr asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
lf
	"PPM and PBM are used LF as CR."

	^stream nextPut: Character lf asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
next

	^stream next! !

!ImageReadWriter methodsFor: 'stream access'!
next: size

	^stream next: size! !

!ImageReadWriter methodsFor: 'stream access'!
nextLong
	"Read a 32-bit quantity from the input stream."

	^(stream next bitShift: 24) + (stream next bitShift: 16) +
		(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access'!
nextLongPut: a32BitW
	"Write out a 32-bit integer as 32 bits."

	stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF).
	stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a32BitW bitAnd: 16rFF).
	^a32BitW! !

!ImageReadWriter methodsFor: 'stream access'!
nextPut: aByte

	^stream nextPut: aByte! !

!ImageReadWriter methodsFor: 'stream access'!
nextPutAll: aByteArray

	^stream nextPutAll: aByteArray! !

!ImageReadWriter methodsFor: 'stream access'!
nextWord
	"Read a 16-bit quantity from the input stream."

	^(stream next bitShift: 8) + stream next! !

!ImageReadWriter methodsFor: 'stream access'!
nextWordPut: a16BitW
	"Write out a 16-bit integer as 16 bits."

	stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF).
	stream nextPut: (a16BitW bitAnd: 16rFF).
	^a16BitW! !

!ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'!
peekFor: aValue

	^stream peekFor: aValue! !

!ImageReadWriter methodsFor: 'stream access'!
position

	^stream position! !

!ImageReadWriter methodsFor: 'stream access'!
position: anInteger

	^stream position: anInteger! !

!ImageReadWriter methodsFor: 'stream access'!
size

	^stream size! !

!ImageReadWriter methodsFor: 'stream access'!
skip: anInteger

	^stream skip: anInteger! !

!ImageReadWriter methodsFor: 'stream access'!
space

	^stream nextPut: Character space asInteger! !

!ImageReadWriter methodsFor: 'stream access'!
tab

	^stream nextPut: Character tab asInteger! !


!ImageReadWriter methodsFor: 'private'!
changePadOfBits: bits width: width height: height depth: depth from: oldPad
to: newPad
	"Change padding size of bits."

	| srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset |
	(#(8 16 32) includes: oldPad)
		ifFalse: [^self error: 'Invalid pad: ', oldPad printString].
	(#(8 16 32) includes: newPad)
		ifFalse: [^self error: 'Invalid pad: ', newPad printString].
	srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8).
	srcRowByteSize * height = bits size
		ifFalse: [^self error: 'Incorrect bitmap array size.'].
	dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8).
	newBits _ ByteArray new: dstRowByteSize * height.
	srcRowBase _ 1.
	rowEndOffset _ dstRowByteSize - 1.
	1 to: newBits size by: dstRowByteSize do:
		[:dstRowBase |
		newBits replaceFrom: dstRowBase
			to: dstRowBase + rowEndOffset
			with: bits
			startingAt: srcRowBase.
		srcRowBase _ srcRowBase + srcRowByteSize].
	^newBits! !

!ImageReadWriter methodsFor: 'private'!
hasMagicNumber: aByteArray
	| position |
	position _ stream position.
	((stream size - position) >= aByteArray size and:
	[(stream next: aByteArray size)  = aByteArray])
		ifTrue: [^true].
	stream position: position.
	^false! !

!ImageReadWriter methodsFor: 'private' stamp: 'di 9/15/1998 11:42'!
on: aStream
	(stream _ aStream) reset.
	(stream respondsTo: #binary) ifTrue: [stream binary].
	"Note that 'reset' makes a file be text.  Must do this after."! !

!ImageReadWriter methodsFor: 'private'!
unpackBits: bits depthTo8From: depth with: width height: height pad: pad
	"Unpack bits of depth 1, 2, or 4 image to it of depth 8 image."

	| bitMask pixelInByte bitsWidth upBitsWidth stopWidth
	 trailingSize upBits bitIndex upBitIndex val |
	(#(1 2 4) includes: depth)
		ifFalse: [^self error: 'depth must be 1, 2, or 4'].
	(#(8 16 32) includes: pad)
		ifFalse: [^self error: 'pad must be 8, 16, or 32'].
	bitMask _ (1 bitShift: depth) - 1.
	pixelInByte _ 8 / depth.
	bitsWidth _ width * depth + pad - 1 // pad * (pad / 8).
	upBitsWidth _ width * 8 + pad - 1 // pad * (pad / 8).
	stopWidth _ width * depth + 7 // 8.
	trailingSize _ width - (stopWidth - 1 * pixelInByte).
	upBits _ ByteArray new: upBitsWidth * height.
	1 to: height do: [:i |
		bitIndex _ i - 1 * bitsWidth.
		upBitIndex _ i - 1 * upBitsWidth.
		1 to: stopWidth - 1 do: [:j |
			val _ bits at: (bitIndex _ bitIndex + 1).
			upBitIndex _ upBitIndex + pixelInByte.
			1 to: pixelInByte do: [:k |
				upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).
				val _ val bitShift: depth negated]].
		val _ (bits at: (bitIndex _ bitIndex + 1))
				bitShift: depth negated * (pixelInByte - trailingSize).
		upBitIndex _ upBitIndex + trailingSize.
		1 to: trailingSize do: [:k |
			upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask).
			val _ val bitShift: depth negated]].
	^ upBits
! !


!ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'!
understandsImageFormat
	"Test to see if the image stream format is understood by this decoder.
	This should be implemented in each subclass of ImageReadWriter so that
	a proper decoder can be selected without ImageReadWriter having to know
	about all possible image file types."

	^ false! !

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

ImageReadWriter class
	instanceVariableNames: ''!

!ImageReadWriter class methodsFor: 'instance creation'!
on: aStream
	"Answer an instance of the receiver for encoding and/or decoding images on the given."

	^ self new on: aStream
! !


!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ls 9/15/1998 19:08'!
formFromFileNamed: fileName
	"Answer a ColorForm stored on the file with the given name."
	| stream |
	stream _ FileStream readOnlyFileNamed: fileName.
	^self formFromStream: stream! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk 5/7/1998 17:35'!
formFromServerFile: fileName
	"Answer a ColorForm stored on the file with the given name.  Meant to be called from during the getting of updates from the server.  That assures that (Utilities serverUrls) returns the right group of servers."

	| form urls doc |
	urls _ Utilities serverUrls collect:
		[:url | url, fileName].  " fileName starts with: 'updates/'  "
	urls do: [:aURL |
		(fileName findTokens: '.') last asLowercase = 'gif' ifTrue: [
			form _ HTTPSocket httpGif: aURL.
			form = (ColorForm extent: 20@20 depth: 8) 
				ifTrue: [self inform: 'The file ',aURL,' is ill formed.'].
			^ form].
		(fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: [
			doc _ HTTPSocket httpGet: aURL accept: 'image/bmp'.
			form _ Form fromBMPFile: doc.
			doc close.
			form ifNil: [self inform: 'The file ',aURL,' is ill formed.'. ^ Form new]
				ifNotNil: [^ form]].
		self inform: 'File ', fileName, 'does not end with .gif or .bmp'].
	self inform: 'That file not found on any server we know'.! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ls 9/15/1998 19:10'!
formFromStream: aBinaryStream
	"Answer a ColorForm stored on the given stream.  closes the stream"
	| reader readerClass form  |

	readerClass _ self withAllSubclasses
		detect: [:subclass | aBinaryStream reset. (subclass new on: aBinaryStream) understandsImageFormat]
		ifNone: [
			(aBinaryStream respondsTo: #close) ifTrue: [ aBinaryStream close ].
			^self error: 'image format not recognized'].
	reader _ readerClass new on: aBinaryStream reset.
	Cursor read showWhile: [
		form _ reader nextImage.
		reader close].
	^ form
! !

!ImageReadWriter class methodsFor: 'image reading/writing'!
putForm: aForm onFileNamed: fileName
	"Store the given form on a file of the given name."

	| writer |
	writer _ self on: (FileStream newFileNamed: fileName) binary.
	Cursor write showWhile: [writer nextPutImage: aForm].
	writer close.
! !

!ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk
9/13/97 16:13'!
putForm: aForm onStream: aWriteStream
	"Store the given form on a file of the given name."

	| writer |
	writer _ self on: aWriteStream.
	Cursor write showWhile: [writer nextPutImage: aForm].
	writer close.
! !
Object subclass: #ImageSegment
	instanceVariableNames: 'arrayOfRoots segment outPointers state segmentName fileName endMarker userRootCnt renamedClasses '
	classVariableNames: 'BiggestFileNumber RecentlyRenamedClasses '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ImageSegment commentStamp: '<historical>' prior: 0!
I represent a segment of Squeak address space.  I am created from an array of root objects.  After storing, my segment contains a binary encoding of every object accessible from my roots but not otherwise accessible from anywhere else in the system.  My segment contains outward pointers that are indices into my table of outPointers.
	When a segment is written out onto a file, it goes in a folder called <image name>_segs.  If your image is called "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the image whenever your move, copy, or rename it.
	Whenever a Class is in arrayOfRoots, its class (aClass class) must also be in the arrayOfRoots.
	There are two kinds of image segments.  Normal image segments are a piece of a specific Squeak image, and can only be read back into that image.  The image holds the array of outPointers that are necessary to turn the bits in the file into objects.
	To put out a normal segment that holds a Project (not the current project), execute (Project named: 'xxx') storeSegment.

	The second kind of image segment is an Export Segment.  It can be read into a different Squeak image.  To create one:
(ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class))
		writeForExport: 'myFile.extSeg'.
To create one for a project:
	(Project named: 'Play With Me - 3') exportSegment.
To read it into another image:  Select 'myFile.extSeg' in a FileList, Menu 'load as project'.  It will install its classes automatically.  If you need to see the roots array, it is temporarily stored in (SmartRefStream scannedObject).

arrayOfRoots	The objects that head the tree we will trace.
segment			The WordArray of raw bits of all objects in the tree.
outPointers		Oops of all objects outside the segment pointed to from inside.
state			(see below)
segmentName	Its basic name.  Often the name of a Project.
fileName		The local name of the file.  'Foo-23.seg'
endMarker		An object located in memory somewhere after a segment that has 
		just been brought in.  To enumerate the objects in the segment, start at 
		the segment and go to this object.
userRootCnt		number of roots submitted by caller.  Extras are added in preparation for saving.

state that an ImageSegment may exist in...

#activeCopy			(has been copies, with the intent to become active)
arrayOfRoots, segment, and outPointers have been created by copyFromRoots:.  The tree of objects has been encoded in the segment, but those objects are still present in the Squeak system.

#active				(segment is actively holding objects)
The segment is now the only holder of tree of objects.  Each of the original roots has been transmuted into an ImageSegmentRootStub that refers back to this image segment.  The original objects in the segment will all be garbageCollected.

#onFile
The segment has been written out to a file and replaced by a file pointer.  Only ImageSegmentRootStubs and the array of outPointers remains in the image.  To get this far:
(ImageSegment new copyFromRoots: (Array with: Baz with: Baz class))
		writeToFile: 'myFile.seg'.

#inactive
The segment has been brought back into memory and turned back into objects.  rootsArray is set, but the segment is invalid.

#onFileWithSymbols
The segment has been written out to a file, along with the text of all the symbols in the outPointers array, and replaced by a file pointer.  This reduces the size of the outPointers array, and also allows the system to reclaim any symbols that are not referred to from elsewhere in the image.  The specific format used is that of a literal array as follows:
	#(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5).
In this case, the original outPointers array was 8 long, but the compacted table of outPointers retains only two entries.  These get inserted in place of the #'s in the array of symbols after it is read back in.  Symbols with embedded spaces or other strange characters are written as strings, and converted back to symbols when read back in.  The symbol # is never written out.
	NOTE: All IdentitySets or dictionaries must be rehashed when being read back from this format.  The symbols are effectively internal.  (No, not if read back into same image.  If a different image, then use #imported.  -tk)

#imported
The segment is on an external file or just read in from one.  The segment and outPointers are meant to be read into a foreign image.   In this form, the image segment can be read from a URL, and installed.  A copy of the original array of root objects is constructed, with former outPointers bound to existing objects in the host system.  
	(Any Class inside the segment MUST be in the arrayOfRoots.  This is so its association can be inserted into Smalltalk.  The class's metaclass must be in roots also.  Methods that are in outPointers because blocks point at them, were found and added to the roots.
	All IdentitySets and dictionaries are rehashed when being read back from exported segments.) 


To discover why only some of the objects in a project are being written out, try this (***Destructive Test***).  This breaks lots of backpointers in the target project, and puts up an array of suspicious objects, a list of the classes of the outPointers, and a debugger.
"Close any transcripts in the target project"
World currentHand objectToPaste ifNotNil: [
	self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs,
		World currentHand objectToPaste printString].
PV _ Project named: 'xxxx'.
(IS _ ImageSegment new) findRogueRootsImSeg: 
	(Array with: PV world presenter with: PV world).
IS findOwnersOutPtrs.	"Optionally: write a file with owner chains"
"Quit and DO NOT save"

!


!ImageSegment methodsFor: 'access' stamp: 'tk 10/4/1999 17:52'!
allObjectsDo: aBlock
	"Enumerate all objects that came from this segment.  NOTE this assumes that the segment was created (and extracted).  After the segment has been installed (install), this method allows you to enumerate its objects."
	| obj |

	endMarker == nil ifTrue: [
		^ self error: 'Just extract and install, don''t writeToFile:'].
	segment size ~= 1 ifTrue: [
		^ self error: 'Vestigial segment size must be 1 (version word)'].

	obj _ segment nextObject.  "Start with the next object after the vestigial header"
	[obj == endMarker] whileFalse:  "Stop at the next object after the full segment"
		[aBlock value: obj.
		obj _ obj nextObject].  "Step through the objects installed from the segment."! !

!ImageSegment methodsFor: 'access' stamp: 'tk 4/6/1999 13:15'!
arrayOfRoots
	^ arrayOfRoots! !

!ImageSegment methodsFor: 'access' stamp: 'tk 12/8/1999 21:12'!
arrayOfRoots: array
	arrayOfRoots _ array! !

!ImageSegment methodsFor: 'access' stamp: 'tk 1/20/2000 20:16'!
originalRoots
	"Return only the roots that the user submitted, not the ones we had to add."

	userRootCnt ifNil: [^ arrayOfRoots].
	^ arrayOfRoots copyFrom: 1 to: userRootCnt! !

!ImageSegment methodsFor: 'access' stamp: 'tk 3/31/1999 21:47'!
outPointers
	^ outPointers! !

!ImageSegment methodsFor: 'access' stamp: 'tk 8/18/1999 22:19'!
segment
	^ segment! !

!ImageSegment methodsFor: 'access' stamp: 'tk 9/26/1999 22:54'!
state
	^ state! !


!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/5/2000 11:09'!
copyFromRoots: aRootArray sizeHint: segSizeHint
	"Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)
	Caller must hold onto Symbols.
	To go faster, make sure objects are not repeated in aRootArray and other method directly, with true."

	self copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: false
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 1/10/2001 14:03'!
copyFromRoots: aRootArray sizeHint: segSizeHint areUnique: areUnique
	"Copy a tree of objects into a WordArray segment.  The copied objects in the segment are not in the normal Squeak space.  
	[1] For exporting a project.  Objects were enumerated by ReferenceStream and aRootArray has them all.
	[2] For exporting some classes.  See copyFromRootsForExport:. (Caller must hold Symbols, or they will not get registered in the target system.)
	[3] For 'local segments'.  outPointers are kept in the image.
	If this method yields a very small segment, it is because objects just below the roots are pointed at from the outside.  (See findRogueRootsImSeg: for a *destructive* diagnostic of who is pointing in.)"
	| segmentWordArray outPointerArray segSize rootSet uniqueRoots |
	aRootArray ifNil: [self errorWrongState].
	uniqueRoots _ areUnique 
		ifTrue: [aRootArray]
		ifFalse: [rootSet _ IdentitySet new: aRootArray size * 3.
			uniqueRoots _ OrderedCollection new.
			1 to: aRootArray size do: [:ii |	"Don't include any roots twice"
				(rootSet includes: (aRootArray at: ii)) 
					ifFalse: [
						uniqueRoots addLast: (aRootArray at: ii).
						rootSet add: (aRootArray at: ii)]
					ifTrue: [userRootCnt ifNotNil: ["adjust the count"
								ii <= userRootCnt ifTrue: [userRootCnt _ userRootCnt - 1]]]].
			uniqueRoots].
	arrayOfRoots _ uniqueRoots asArray.
	rootSet _ uniqueRoots _ nil.	"be clean"
	userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
	arrayOfRoots do: [:aRoot | 
		aRoot indexIfCompact > 0 ifTrue: [
			self error: 'Compact class ', aRoot name, ' cannot be a root'].
		aRoot _ nil].	"clean up"
	outPointers _ nil.	"may have used this instance before"
	segSize _ segSizeHint > 0 ifTrue: [segSizeHint *3 //2] ifFalse: [50000].

	["Guess a reasonable segment size"
	segmentWordArray _ WordArrayForSegment new: segSize.
	[outPointerArray _ Array new: segSize // 20] ifError: [
		state _ #tooBig.  ^ self].
	"Smalltalk garbageCollect."
	(self storeSegmentFor: arrayOfRoots
					into: segmentWordArray
					outPointers: outPointerArray) == nil]
		whileTrue:
			["Double the segment size and try again"
			segmentWordArray _ outPointerArray _ nil.
			segSize _ segSize * 2].
	segment _ segmentWordArray.
	outPointers _ outPointerArray.
	state _ #activeCopy.
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/5/2000 09:40'!
copyFromRootsForExport: rootArray 
	"When possible, use copySmartRootsExport:.  This way may not copy a complete tree of objects.  Add to roots: all of the methods pointed to from the outside by blocks."
	| newRoots list segSize symbolHolder |
	arrayOfRoots _ rootArray.
	Smalltalk forgetDoIts.  
	symbolHolder _ Symbol allInstances.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"
	(newRoots _ self rootsIncludingPlayers) ifNotNil: [
		arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
	"Creation of the segment happens here"
	self copyFromRoots: arrayOfRoots sizeHint: 0.
	segSize _ segment size.
	[(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods pointed at from outside"
	[(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize].
		"with methods, blocks from outPointers"
	"classes of receivers of blocks"
	list _ self compactClassesArray.
	outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	"Zap sender of a homeContext. Can't send live stacks out."
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 2/8/2000 13:34'!
copyFromRootsLocalFileFor: rootArray sizeHint: segSize
	"If the roots include a World, add its Player classes to the roots."
	| newRoots |

	arrayOfRoots _ rootArray.
	[(newRoots _ self rootsIncludingPlayers) == nil] whileFalse: [
		arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
	Smalltalk forgetDoIts.  
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 1/18/2001 16:02'!
copySmartRootsExport: rootArray 
	"Use SmartRefStream to find the object.  Make them all roots.  Create the segment in memory.  Project should be in first five objects in rootArray."
	| newRoots list segSize symbolHolder dummy replacements world naughtyBlocks goodToGo allClasses |
	Smalltalk forgetDoIts.  
	1 to: 5 do: [:ii | ((rootArray at: ii) respondsTo: #isCurrentProject) ifTrue: [
					world _ rootArray at: ii]].
	world ifNotNil: [world presenter flushPlayerListCache].	"old and outside guys"
	symbolHolder _ Symbol allInstances.	"Hold onto Symbols with strong pointers, 
		so they will be in outPointers"

	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy insideASegment: true.	"So Uniclasses will be traced"
	dummy rootObject: rootArray.	"inform him about the root"
	dummy nextPut: rootArray.
	allClasses _ SmartRefStream new uniClassInstVarsRefs: dummy.
		"catalog the extra objects in UniClass inst vars.  Put into dummy"
	allClasses do: [:cls | 
		dummy references at: cls class put: false.	"put Player5 class in roots"
		dummy blockers removeKey: cls class ifAbsent: []].
	"refs _ dummy references."
	arrayOfRoots _ self smartFillRoots: dummy.	"guaranteed none repeat"
	self savePlayerReferences: dummy references.	"for shared References table"
	replacements _ dummy blockers.
	dummy project ifNil: [self error: 'lost the project!!'].
	dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project'].
	dummy _ nil.	"force GC?"
	naughtyBlocks _ arrayOfRoots select: [ :each |
		(each isKindOf: ContextPart) and: [each hasInstVarRef]
	].
	naughtyBlocks isEmpty ifFalse: [
		goodToGo _ PopUpMenu
			confirm: 
'Some block(s) which reference instance variables 
are included in this segment. These may fail when
the segment is loaded if the class has been reshaped.
What would you like to do?' 
			trueChoice: 'keep going' 
			falseChoice: 'stop and take a look'.
		goodToGo ifFalse: [
			naughtyBlocks inspect.
			self error: 'Here are the bad blocks'].
	].

	"Creation of the segment happens here"

	"try using one-quarter of memory to publish (will get bumped later)"
	self copyFromRoots: arrayOfRoots sizeHint: (Smalltalk garbageCollect // 4 // 4) areUnique: true.
	segSize _ segment size.
	[(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
		"with methods pointed at from outside"
	[(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [
		arrayOfRoots _ newRoots.
		self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true].
		"with methods, blocks from outPointers"
	list _ self compactClassesArray.
	outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)).
	1 to: outPointers size do: [:ii | 
		(outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil].
		(outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil].
		"substitute new object in outPointers"
		(replacements includesKey: (outPointers at: ii)) ifTrue: [
			outPointers at: ii put: (replacements at: (outPointers at: ii))]].
	symbolHolder.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 11/30/1999 22:30'!
extract
	"This operation replaces (using become:) all the original roots of a segment with segmentRootStubs.  Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed."

	Cursor write showWhile: [
		state = #inactive ifTrue: [self copyFromRoots: arrayOfRoots sizeHint: 0].
		state = #activeCopy ifFalse: [self errorWrongState].
		arrayOfRoots elementsForwardIdentityTo:
			(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
		state _ #active].
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:47'!
extractThenInstall
	"For testing only"

	| newRoots |
	state = #activeCopy ifFalse: [self errorWrongState].
	arrayOfRoots elementsForwardIdentityTo:
		(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
	state _ #active.
	newRoots _ self loadSegmentFrom: segment outPointers: outPointers.
	state _ #inactive.
	arrayOfRoots elementsForwardIdentityTo: newRoots.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'di 2/11/2000 13:06'!
install
	"This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment."

	| newRoots |
	state = #onFile ifTrue: [self readFromFile].
	state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols.
		endMarker _ segment nextObject. 	"for enumeration of objects"
		endMarker == 0 ifTrue: [endMarker _ 'End' clone]].
	(state = #active) | (state = #imported) ifFalse: [self errorWrongState].
	newRoots _ self loadSegmentFrom: segment outPointers: outPointers.
	state = #imported 
		ifTrue: ["just came in from exported file"
			arrayOfRoots _ newRoots]
		ifFalse: [
			arrayOfRoots elementsForwardIdentityTo: newRoots].
	state _ #inactive.
	self beep.	"Don't use Squeak sound here."
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:03'!
localName
	| segs ind sep |
	"Return the current file name for this segment, a local name in the segments directory."

	fileName ifNil: [^ nil].
	"^ fileName"	

	"The following is for backward compatibility.  Remove this part after June 2000.
	Check if the fileName is a full path, and make it local.  Regardless of current or previous file system delimiter."

	segs _ self class folder copyLast: 4.  "_segs"
	ind _ 1.
	[ind _ fileName findString: segs startingAt: ind+1 caseSensitive: false.
		ind = 0 ifTrue: [^ fileName].
		sep _ fileName at: ind + (segs size).
		sep isAlphaNumeric ] whileTrue.		"sep is letter or digit, not a separator"

	^ fileName _ fileName copyFrom: ind+(segs size)+1 "delimiter" to: fileName size! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'mdr 8/31/2000 19:01'!
readFromFile
	"Read in a simple segment.  Use folder of this image, even if remembered as previous location of this image"

	| ff realName |
	realName _ self class folder, FileDirectory slash, self localName.
	ff _ FileStream readOnlyFileNamed: realName.
	segment _ ff nextWordsInto: (WordArrayForSegment new: ff size//4).
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	ff close.
	state _ #active! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/26/1999 13:07'!
revert
	"Pretend this segment was never brought in.  Check that it has a fileName.  Replace (using become:) all the original roots of a segment with segmentRootStubs.  Thus the original objects will be reclaimed, and the root stubs will remain to bring the segment back in if it is needed.
	How to use revert:  In the project, choose 'save for reverting'.

	ReEnter the project.  Make changes.
	Either exit normally, and change will be kept, or
		Choose 'Revert to saved version'."

	fileName ifNil: [^ self].
	(state = #inactive) | (state = #onFile) ifFalse: [^ self].
	Cursor write showWhile: [
		arrayOfRoots elementsForwardIdentityTo:
			(arrayOfRoots collect: [:r | r rootStubInImageSegment: self]).
		state _ #onFile.
		segment _ nil.
		endMarker _ nil].

"Old version:
	How to use revert:  In the project, execute 
(Project current projectParameters at: #frozen put: true)
	Leave the project.  Check that the project went out to disk (it is gray in the Jump to Project list).
	ReEnter the project.  Hear a plink as it comes in from disk.  Make a change.
	Exit the project.  Choose 'Revert to previous version' in the dialog box.
	Check that the project went out to disk (it is gray in the Jump to Project list).
	ReEnter the project and see that it is in the original state."

! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 3/6/2000 11:05'!
rootsIncludingBlockMethods
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Any CompiledMethods that create blocks will be in outPointers if the block is held outside of this segment.  Put such methods into the roots list.  Then ask for the segment again."

| extras myClasses gotIt |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
myClasses _ OrderedCollection new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [
					myClasses add: aRoot]].
myClasses isEmpty ifTrue: [^ nil].	"no change"
outPointers do: [:anOut | 
	anOut class == CompiledMethod ifTrue: [
		"specialized version of who"
		gotIt _ false.
		myClasses detect: [:class |
			class selectorsDo: [:sel |
				(class compiledMethodAt: sel) == anOut 
					ifTrue: [extras add: anOut.  gotIt _ true]].
			gotIt] 
			ifNone: []
		].
	anOut _ nil].
extras _ extras select: [:ea | (arrayOfRoots includes: ea) not].
extras isEmpty ifTrue: [^ nil].	"no change"
^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 3/6/2000 11:04'!
rootsIncludingBlocks
	"For export segments only.  Return a new roots array with more objects.  (Caller should store into rootArray.)  Collect Blocks and external methods pointed to by them.  Put them into the roots list.  Then ask for the segment again."

	| extras have |
	userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
	extras _ OrderedCollection new.
	outPointers do: [:anOut | 
		anOut class == CompiledMethod ifTrue: [extras add: anOut].
		(anOut class == BlockContext) ifTrue: [extras add: anOut].
		(anOut class == MethodContext) ifTrue: [extras add: anOut].
		anOut _ nil].	"don't hang onto it"

	[have _ extras size.
	 extras copy do: [:anOut |
		(anOut class == BlockContext) ifTrue: [
			anOut home ifNotNil: [
				(extras includes: anOut home) ifFalse: [extras add: anOut home]]].
		(anOut class == MethodContext) ifTrue: [
			anOut method ifNotNil: [
				(extras includes: anOut method) ifFalse: [extras add: anOut method]]]].
	 have = extras size] whileFalse.
	extras _ extras select: [:ea | (arrayOfRoots includes: ea) not].
	extras isEmpty ifTrue: [^ nil].	"no change"

	^ arrayOfRoots, extras! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 1/11/2001 10:41'!
rootsIncludingPlayers
	"Return a new roots array with more objects.  (Caller should store into rootArray.) Player (non-systemDefined) gets its class and metaclass put into the Roots array.  Then ask for the segment again."

| extras havePresenter players morphs env existing |
userRootCnt ifNil: [userRootCnt _ arrayOfRoots size].
extras _ OrderedCollection new.
arrayOfRoots do: [:root | 
	(root isKindOf: Presenter) ifTrue: [havePresenter _ root].
	(root isKindOf: PasteUpMorph) ifTrue: [
			root isWorldMorph ifTrue: [havePresenter _ root presenter]].
	(root isKindOf: Project) ifTrue: [havePresenter _ root world presenter]].
havePresenter ifNotNil: [
	havePresenter flushPlayerListCache.		"old and outside guys"
	morphs _ IdentitySet new: 400.
	havePresenter associatedMorph allMorphsAndBookPagesInto: morphs.
	players _ (morphs select: [:m | m player ~~ nil] 
				thenCollect: [:m | m player]) asArray.
	players _ players select: [:ap | (arrayOfRoots includes: ap class) not
		& (ap class isSystemDefined not)].
	extras addAll: (players collect: [:each | each class]).
	(env _ havePresenter world project environment) ifNil: [
		extras addAll: (players collect: [:each | each class class])].
	extras addAll: morphs.	"Make then ALL roots!!"
	].
existing _ arrayOfRoots asIdentitySet.
extras _ extras reject: [ :each | existing includes: each].
extras isEmpty ifTrue: [^ nil].	"no change"
env 
	ifNil: ["old pre-environment"
		havePresenter _ players _ morphs _ nil.
		^ arrayOfRoots, extras]	"will contain multiples of some, but reduced later"
	ifNotNil: [
		(env includesKey: #Object) ifTrue: [self error: 'only look in local env, not up chain'].
			"If get error, use a message other than includesKey:"
		extras do: [:cls | 
			(env includesKey: cls name) ifFalse: [
				env declare: cls name from: Smalltalk]].
		havePresenter _ players _ morphs _ env _ nil.
		^ arrayOfRoots, extras	"still need in roots in case outside pointers"
		]! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/8/2000 10:00'!
savePlayerReferences: dictOfAllObjects
	| save world |
	"Save our associations we own in the shared References table.  They will be installed when the segment is imported."

	save _ OrderedCollection new.
	References associationsDo: [:assoc |
		(dictOfAllObjects includesKey: assoc) ifTrue: [save add: assoc]].
	1 to: 5 do: [:ii | ((arrayOfRoots at: ii) respondsTo: #isCurrentProject) ifTrue: [
					world _ (arrayOfRoots at: ii) world]].
	world setProperty: #References toValue: save.
		"assume it is not refed from outside and will be traced"! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'di 3/28/1999 13:48'!
segmentCopy
	"This operation will install a copy of the segment in memory, and return a copy of the array of roots.  The effect is to perform a deep copy of the original structure.  Note that installation destroys the segment, so it must be copied before doing the operation."

	state = #activeCopy ifFalse: [self errorWrongState].
	^ self loadSegmentFrom: segment copy outPointers: outPointers! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:39'!
segmentName
	"Return the local file name for this segment."

	^ segmentName! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/13/1999 09:19'!
segmentName: aString
	"Local file name for this segment."

	segmentName _ aString! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 1/10/2001 14:05'!
smartFillRoots: dummy
	| refs known ours ww blockers |
	"Put all traced objects into my arrayOfRoots.  Remove some that want to be in outPointers.  Return blockers, an IdentityDictionary of objects to replace in outPointers."

	blockers _ dummy blockers.
	known _ (refs _ dummy references) size.
	refs fasterKeys do: [:obj | "copy keys to be OK with removing items"
		(obj class == Symbol) ifTrue: [refs removeKey: obj.  known _ known-1].
		(obj class == PasteUpMorph) ifTrue: [
			obj isWorldMorph & (obj owner == nil) ifTrue: [
				obj == dummy project world ifFalse: [
					refs removeKey: obj.  known _ known-1.
					blockers at: obj put: 
						(StringMorph contents: 'The worldMorph of a different world')]]].
					"Make a ProjectViewMorph here"
		"obj class == Project ifTrue: [Transcript show: obj; cr]."
		(blockers includesKey: obj) ifTrue: [
			refs removeKey: obj ifAbsent: [known _ known+1].  known _ known-1].
		].
	ours _ dummy project world.
	refs keysDo: [:obj |
			obj isMorph ifTrue: [
				ww _ obj world. 
				(ww == ours) | (ww == nil) ifFalse: [
					refs removeKey: obj.  known _ known-1.
					blockers at: obj put: (StringMorph contents: 
								obj printString, ' from another world')]]].
	"keep original roots on the front of the list"
	(dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []].
	^ dummy rootObject, refs fasterKeys asArray.

! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'mir 10/11/2000 19:08'!
writeForExport: shortName
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk."

	| fileStream temp |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	temp _ endMarker.
	endMarker _ nil.
	fileStream _ FileStream newFileNamed: (FileDirectory fileName: shortName extension: self class fileExtension).
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 9/30/2000 20:53'!
writeForExportWithSources: fName inDirectory: aDirectory
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"this is the old version which I restored until I solve the gzip problem"

	| fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
	zipper _ [
		ProgressNotification signal: '3:uncompressedSaveComplete'.
		(aDirectory oldFileNamed: tempFileName) compressFile.	"makes xxx.gz"
		aDirectory 
			rename: (tempFileName, FileDirectory dot, 'gz')
			toBe: fName.
		aDirectory
			deleteFileNamed: tempFileName
			ifAbsent: []
	].
	fileStream _ aDirectory newFileNamed: tempFileName.
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self].

	fileStream reopen; setToEnd.
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls | 
		cls isMeta ifFalse: [fileStream nextPutAll: 
						(cls name, ' category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do: 
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream close.
	zipper value.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 12/22/2000 11:16'!
writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"



	| fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'.
	zipper _ [
		ProgressNotification signal: '3:uncompressedSaveComplete'.
		(aDirectory oldFileNamed: tempFileName) compressFile.	"makes xxx.gz"
		aDirectory 
			rename: (tempFileName, FileDirectory dot, 'gz')
			toBe: fName.
		aDirectory
			deleteFileNamed: tempFileName
			ifAbsent: []
	].
	fileStream _ aDirectory newFileNamed: tempFileName.
	fileStream fileOutChangeSet: aChangeSetOrNil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self].

	fileStream reopen; setToEnd.
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls | 
		cls isMeta ifFalse: [fileStream nextPutAll: 
						(cls name, ' category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do: 
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream close.
	zipper value.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'RAA 7/11/2000 18:33'!
writeForExportWithSourcesGZ: fName inDirectory: aDirectory
	"Write the segment on the disk with all info needed to reconstruct it in a new image.  For export.  Out pointers are encoded as normal objects on the disk.  Append the source code of any classes in roots.  Target system will quickly transfer the sources to its changes file."

	"this is the gzipped version which I have temporarily suspended until I can get resolve the problem with forward references tring to reposition the stream - RAA 11 june 2000"




	| fileStream temp allClassesInRoots classesToWriteEntirely methodsWithSource |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
	(fName includes: $.) ifFalse: [
		^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.].
	temp _ endMarker.
	endMarker _ nil.
	fileStream _ GZipSurrogateStream newFileNamed: fName inDirectory: aDirectory.
	fileStream fileOutClass: nil andObject: self.
		"remember extra structures.  Note class names."
	endMarker _ temp.

	"append sources"
	allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior].
	classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined].
	methodsWithSource _ OrderedCollection new.
	allClassesInRoots do: [ :cls |
		(classesToWriteEntirely includes: cls) ifFalse: [
			cls selectorsAndMethodsDo: [ :sel :meth |
				meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}].
			].
		].
	].
	(classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [
		fileStream reallyClose.	"since #close is ignored"
		^ self
	].
	"fileStream reopen; setToEnd."	"<--not required with gzipped surrogate stream"
	fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs.
	methodsWithSource do: [ :each |
		fileStream nextPut: $!!.	"try to pacify ImageSegment>>scanFrom:"
		fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ',
				each first name printString,' methodsFor: ',
				(each first organization categoryOfElement: each second) asString printString,
				' stamp: ',(Utilities timeStampForMethod: each third) printString; cr.
		fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString.
		fileStream nextChunkPut: ' '; cr.
	].
	classesToWriteEntirely do: [:cls | 
		cls isMeta ifFalse: [fileStream nextPutAll: 
						(cls name, ' category: ''', cls category, '''.!!'); cr; cr].
		cls organization
			putCommentOnFile: fileStream
			numbered: 0
			moveSource: false
			forClass: cls.	"does nothing if metaclass"
		cls organization categories do: 
			[:heading |
			cls fileOutCategory: heading
				on: fileStream
				moveSource: false
				toFile: 0]].
	"no class initialization -- it came in as a real object"
	fileStream reallyClose.	"since #close is ignored"
! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:13'!
writeToFile

	state = #active ifFalse: [self error: 'wrong state'. ^ self].
	Cursor write showWhile: [
		segmentName ifNil: [
			segmentName _ (FileDirectory localNameFor: fileName) sansPeriodSuffix].
			"OK that still has number on end.  This is an unusual case"
		fileName _ self class uniqueFileNameFor: segmentName.	"local name"
		(self class segmentDirectory newFileNamed: fileName) nextPutAll: segment; close.
		segment _ nil.
		endMarker _ nil.
		state _ #onFile].! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'!
writeToFile: shortName
	"The short name can't have any fileDelimiter characters in it.  It is remembered in case the segment must be brought in and then sent out again (see ClassDescription updateInstancesFrom:)."

	segmentName _ (shortName endsWith: '.seg')
		ifTrue: [shortName copyFrom: 1 to: shortName size - 4]
		ifFalse: [shortName].
	segmentName last isDigit ifTrue: [segmentName _ segmentName, '-'].
	self writeToFile.! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/17/1999 00:14'!
writeToFileWithSymbols
	| symbols nonSymbols pound |

	state = #extracted ifFalse: [self error: 'wrong state'].
	segmentName ifNil: [
		segmentName _ (FileDirectory localNameFor: fileName) sansPeriodSuffix].
		"OK that still has number on end.  This is an unusual case"
	fileName _ self class uniqueFileNameFor: segmentName.
	symbols _ OrderedCollection new.
	nonSymbols _ OrderedCollection new.
	pound _ '#' asSymbol.
	outPointers do:
		[:s | 
		((s isMemberOf: Symbol) and: [s isLiteral and: [s ~~ pound]])
			ifTrue: [symbols addLast: s]
			ifFalse: [symbols addLast: pound.  nonSymbols addLast: s]].
	(self class segmentDirectory newFileNamed: fileName)
		store: symbols asArray; cr;
		nextPutAll: segment; close.
	outPointers _ nonSymbols asArray.
	state _ #onFileWithSymbols! !

!ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/8/1999 12:23'!
writeToFileWithSymbols: shortName

	segmentName _ (shortName endsWith: '.seg')
		ifTrue: [shortName copyFrom: 1 to: shortName size - 4]
		ifFalse: [shortName].
	segmentName last isDigit ifTrue: [segmentName _ segmentName, '-'].
	self writeToFileWithSymbols.! !


!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:47'!
loadSegmentFrom: segmentWordArray outPointers: outPointerArray
	"This primitive will install a binary image segment and return as its value the array of roots of the tree of objects represented.  Upon successful completion, the wordArray will have been transmuted into an object of zero length.  If this primitive should fail, it will have destroyed the contents of the segment wordArray."

	<primitive: 99>	"successful completion returns the array of roots"
	^ nil			"failure returns nil"! !

!ImageSegment methodsFor: 'primitives' stamp: 'di 3/28/1999 13:49'!
storeSegmentFor: rootsArray into: segmentWordArray outPointers: outPointerArray
	"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  Note: all elements of the reciever are treated as roots indetermining the extent of the tree.  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outpointer array (the first would be 4). but with the high bit set."

	"The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  If either array is too small, the primitive will fail, but in no other case."

	<primitive: 98>	"successful completion returns self"
	^ nil			"failure returns nil"! !


!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:29'!
deepCopyTest: aRootArray
	"ImageSegment new deepCopyTest: Morph withAllSubclasses asArray"
	"Project allInstances do:
		[:p | p == Project current ifFalse:
			[Transcript cr; cr; nextPutAll: p name.
			ImageSegment new deepCopyTest: (Array with: p)]]."
	| t1 t2 copy |
	t1 _ Time millisecondsToRun: [self copyFromRoots: aRootArray sizeHint: 0].
	t2 _ Time millisecondsToRun: [copy _ self segmentCopy].
	Transcript cr; print: segment size * 4; nextPutAll: ' bytes stored with ';
		print: outPointers size; show: ' outpointers in '; print: t1; show: 'ms.'.
	Transcript cr; nextPutAll: 'Reconstructed in '; print: t2; show: 'ms.'.
	^ copy
"
Smalltalk allClasses do:
	[:m | ImageSegment new deepCopyTest: (Array with: m with: m class)]
"! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/26/1999 22:51'!
errorWrongState

	^ self error: 'wrong state'! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/3/1999 14:11'!
findInOut: anArray
	"Take an array of references to a morph, and try to classify them:  in the segment, in outPointers, or other."

String streamContents: [:strm |
	anArray withIndexDo: [:obj :ind |
		strm cr; nextPutAll: obj printString; space.

		]].! !

!ImageSegment methodsFor: 'testing' stamp: 'ar 9/14/2000 16:47'!
findOwnerMap: morphs
	| st |
	"Construct a string that has a printout of the owner chain for every morph in the list.  Need it as a string so not hold onto them."

st _ ''.
morphs do: [:mm |
	(st includesSubString: mm printString) ifFalse: [
		st _ st, '
', mm allOwners printString]].
Smalltalk at: #Owners put: st.
! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/7/1999 09:48'!
findOwnersOutPtrs

| ow ff |
ow _ Smalltalk at: #Owners ifAbsent: [^ self].
ow ifNil: [^ self].
outPointers do: [:oo | 
	oo isMorph ifTrue: [
		ow _ ow copyReplaceAll: oo printString with: oo printString, '[<<<- Pointed at]']].
ff _ FileStream fileNamed: 'Owners log'.
ff nextPutAll: ow; close.
Smalltalk at: #Owners put: ow.
ff edit.! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/8/1999 16:35'!
findRogueRootsAllMorphs: rootArray
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) assemble all objects should be in seg:  morph tree, presenter, scripts, player classes, metaclasses.  Put in a Set.
2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."

| inSeg testRoots scriptEditors pointIn wld xRoots |
Smalltalk garbageCollect.
inSeg _ IdentitySet new: 200.
arrayOfRoots _ rootArray.
(testRoots _ self rootsIncludingPlayers) ifNil: [testRoots _ rootArray].
testRoots do: [:obj |
	(obj isKindOf: Project) ifTrue: [inSeg add: obj.
			wld _ obj world.
			inSeg add: wld presenter].
	(obj isKindOf: Presenter) ifTrue: [inSeg add: obj].
	].
xRoots _ wld ifNil: [testRoots] ifNotNil: [testRoots, (Array with: wld)].
xRoots do: [:obj |
	"root is a project"
	obj isMorph ifTrue: [
		obj allMorphs do: [:mm | inSeg add: mm.
			mm player ifNotNil: [inSeg add: mm player]].
		obj isWorldMorph ifTrue: [inSeg add: obj presenter]]].
inSeg do: [:obj |
	(obj isKindOf: Player) ifTrue: [
		scriptEditors _ obj class tileScriptNames collect: [:nn | 
			obj scriptEditorFor: nn].
		scriptEditors do: [:se | inSeg addAll: se allMorphs]].
	].
testRoots do: [:each | inSeg remove: each ifAbsent: []].
	"want them to be pointed at from outside"
pointIn _ IdentitySet new: 400.
inSeg do: [:ob |
	pointIn addAll: (Smalltalk pointersTo: ob except: inSeg)].
testRoots do: [:each | pointIn remove: each ifAbsent: []].
pointIn remove: inSeg array ifAbsent: [].
pointIn remove: pointIn array ifAbsent: [].
inSeg do: [:obj |
	(obj isKindOf: Morph) ifTrue: [
		pointIn remove: (obj "submorphs" instVarAt: 3) ifAbsent: [].
		"associations in extension"
		pointIn remove: obj extension ifAbsent: [].
		obj extension ifNotNil: [obj extension otherProperties ifNotNil: [
			obj extension otherProperties associationsDo: [:ass | 
				pointIn remove: ass ifAbsent: []]]
			"*** and extension actorState"
			"*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]].
	(obj isKindOf: Player) ifTrue: [obj class scripts values do: [:us | 
			pointIn remove: us ifAbsent: []]]].
"*** presenter playerlist"
self halt: 'Examine local variables pointIn and inSeg'.
^ pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 11/30/1999 22:30'!
findRogueRootsImSeg: rootArray
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) Break all owner pointers in submorphs and all scripts.
2) Create the segment and look at outPointers.
3) Remove those we expect.
4) Remember to quit without saving -- the owner pointers are smashed."

| newRoots suspects bag1 bag2 |
arrayOfRoots _ rootArray.
[(newRoots _ self rootsIncludingPlayers) == nil] whileFalse: [
	arrayOfRoots _ newRoots].		"world, presenter, and all Player classes"
self findRogueRootsPrep.	"and free that context!!"
Smalltalk forgetDoIts.
Smalltalk garbageCollect.
self copyFromRoots: arrayOfRoots sizeHint: 0.

suspects _ outPointers select: [:oo | oo isMorph].
suspects size > 0 ifTrue: [suspects inspect].
bag1 _ Bag new.  bag2 _ Bag new.
outPointers do: [:key | 
	(key isKindOf: Class) 
		ifTrue: [bag2 add: key class name]
		ifFalse: [(#(Symbol Point Rectangle True False String Float Color Form ColorForm StrikeFont Metaclass UndefinedObject TranslucentColor) includes: key class name)
			ifTrue: [bag2 add: key class name]
			ifFalse: [bag1 add: key class name]]].
"(bag sortedCounts) is the SortedCollection"
(StringHolder new contents: bag1 sortedCounts printString, '

', bag2 sortedCounts printString) 
	openLabel: 'Objects pointed at by the outside'.
self halt: 'Examine local variables pointIn and inSeg'.

"Use this in inspectors:
	outPointers select: [:oo | oo class == <a Class>].		"

! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/28/1999 20:54'!
findRogueRootsPrep
	"Part of the tool to track down unwanted pointers into the segment.  Break all owner pointers in submorphs, scripts, and viewers in flaps."

| wld players morphs scriptEditors |
wld _ arrayOfRoots detect: [:obj | 
	obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil].
wld ifNil: [wld _ arrayOfRoots detect: [:obj | obj isMorph] 
				ifNone: [^ self error: 'can''t find a root morph']].
morphs _ IdentitySet new: 400.
wld allMorphsAndBookPagesInto: morphs.
players _ wld presenter allExtantPlayers.	"just the cached list"
players do: [:pp |
	scriptEditors _ pp class tileScriptNames collect: [:nn | 
			pp scriptEditorFor: nn].
	scriptEditors do: [:se | morphs addAll: se allMorphs]].
wld submorphs do: [:mm | 	"non showing flaps"
	(mm isKindOf: FlapTab) ifTrue: [
		mm referent allMorphsAndBookPagesInto: morphs]].
morphs do: [:mm | 	"break the back pointers"
	mm isInMemory ifTrue: [
	(mm respondsTo: #target) ifTrue: [
		mm nearestOwnerThat: [:ow | ow == mm target 
			ifTrue: [mm target: nil. true]
			ifFalse: [false]]].
	(mm respondsTo: #arguments) ifTrue: [
		mm arguments do: [:arg | arg ifNotNil: [
			mm nearestOwnerThat: [:ow | ow == arg
				ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true]
				ifFalse: [false]]]]].
	mm eventHandler ifNotNil: ["recipients point back up"
		(morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [
			mm eventHandler: nil]].
	"temporary, until using Model for PartsBin"
	(mm isKindOf: MorphicModel) ifTrue: [
		(mm model isKindOf: MorphicModel) ifTrue: [
			mm model breakDependents]].
	(mm isKindOf: TextMorph) ifTrue: [mm setContainer: nil]]].
(Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil].
	"in case findOwnerMap: is commented out"
"self findOwnerMap: morphs."
morphs do: [:mm | 	"break the back pointers"
	mm isInMemory ifTrue: [mm privateOwner: nil]].
"more in extensions?"

! !

!ImageSegment methodsFor: 'testing' stamp: 'tk 9/8/1999 16:34'!
findRogueRootsRefStrm: rootArray
	"This is a tool to track down unwanted pointers into the segment.  If we don't deal with these pointers, the segment turns out much smaller than it should.  These pointers keep a subtree of objects out of the segment.
1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream.  Put in a Set.
2) Remove the roots from this list.  Ask for senders of each.  Of the senders, forget the ones that are in the segment already.  Keep others.  The list is now all the 'incorrect' pointers into the segment."

| dummy goodInSeg inSeg ok pointIn |
dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
rootArray do: [:root |
	dummy rootObject: root.	"inform him about the root"
	dummy nextPut: root.
	].
inSeg _ dummy references keys.
dummy _ nil.   Smalltalk garbageCollect.  "dump refs dictionary"
rootArray do: [:each | inSeg remove: each ifAbsent: []].
	"want them to be pointed at from outside"
pointIn _ IdentitySet new: 500.
goodInSeg _ IdentitySet new: 2000.
inSeg do: [:obj |
	ok _ obj class isPointers.
	obj class == Color ifTrue: [ok _ false].
	obj class == TranslucentColor ifTrue: [ok _ false].
	obj class == Array ifTrue: [obj size = 0 ifTrue: [ok _ false]].
		"shared #() in submorphs of all Morphs"
	ok ifTrue: [goodInSeg add: obj]].
goodInSeg do: [:ob |
		pointIn addAll: (Smalltalk pointersTo: ob except: #())].
inSeg do: [:each | pointIn remove: each ifAbsent: []].
rootArray do: [:each | pointIn remove: each ifAbsent: []].
pointIn remove: inSeg array ifAbsent: [].
pointIn remove: goodInSeg array ifAbsent: [].
pointIn remove: pointIn array ifAbsent: [].
self halt: 'Examine local variables pointIn and inSeg'.
^ pointIn! !

!ImageSegment methodsFor: 'testing' stamp: 'di 9/29/1999 16:50'!
isOnFile
	^ state == #onFile! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 22:04'!
verify: ob1 matches: ob2 knowing: matchDict

	| priorMatch first |
	ob1 == ob2 ifTrue:
		["If two pointers are same, they must be ints or in outPointers"
		((ob1 isMemberOf: SmallInteger) and: [ob1 = ob2]) ifTrue: [^ self].
		((ob1 isKindOf: Behavior) and: [ob1 indexIfCompact = ob2 indexIfCompact]) ifTrue: [^ self].
		(outPointers includes: ob1) ifTrue: [^ self].
		self halt].
	priorMatch _ matchDict at: ob1 ifAbsent: [nil].
	priorMatch == nil
		ifTrue: [matchDict at: ob1 put: ob2]
		ifFalse: [priorMatch == ob2
					ifTrue: [^ self]
					ifFalse: [self halt]].
	self verify: ob1 class matches: ob2 class knowing: matchDict.
	ob1 class isVariable ifTrue: 
		[ob1 basicSize = ob2 basicSize ifFalse: [self halt].
		first _ 1.
		(ob1 isMemberOf: CompiledMethod) ifTrue: [first _ ob1 initialPC].
		first to: ob1 basicSize do:
			[:i | self verify: (ob1 basicAt: i) matches: (ob2 basicAt: i) knowing: matchDict]].
	ob1 class instSize = ob2 class instSize ifFalse: [self halt].
	1 to: ob1 class instSize do:
		[:i | self verify: (ob1 instVarAt: i) matches: (ob2 instVarAt: i) knowing: matchDict].
	(ob1 isMemberOf: CompiledMethod) ifTrue:
		[ob1 header = ob2 header ifFalse: [self halt].
		ob1 numLiterals = ob2 numLiterals ifFalse: [self halt].
		1 to: ob1 numLiterals do:
			[:i | self verify: (ob1 literalAt: i) matches: (ob2 literalAt: i) knowing: matchDict]]! !

!ImageSegment methodsFor: 'testing' stamp: 'di 3/27/1999 21:36'!
verifyCopy

	| copyOfRoots matchDict |
	copyOfRoots _ self segmentCopy.
	matchDict _ IdentityDictionary new.
	arrayOfRoots with: copyOfRoots do:
		[:r :c | self verify: r matches: c knowing: matchDict]! !


!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/17/2001 12:15'!
acceptSingleMethodSource: aDictionary

	| oldClassInfo oldClassName ismeta newName actualClass selector |
	oldClassInfo _ (aDictionary at: #oldClassName) findTokens: ' '.	"'Class' or 'Class class'"
	oldClassName _ oldClassInfo first asSymbol.
	ismeta _ oldClassInfo size > 1.

	"must use class var since we may not be the same guy who did the initial work"

	newName _ RecentlyRenamedClasses ifNil: [
		oldClassName
	] ifNotNil: [
		RecentlyRenamedClasses at: oldClassName ifAbsent: [oldClassName]
	].
	actualClass _ Smalltalk at: newName.
	ismeta ifTrue: [actualClass _ actualClass class].
	selector _ actualClass parserClass new parseSelector: (aDictionary at: #methodText).
	(actualClass compiledMethodAt: selector ifAbsent: [^self "hosed input"]) 
		putSource: (aDictionary at: #methodText)
		fromParseNode: nil
		class: actualClass
		category: (aDictionary at: #category)
		withStamp: (aDictionary at: #changeStamp)
		inFile: 2
		priorMethod: nil.

! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 1/31/2001 12:46'!
comeFullyUpOnReload: smartRefStream
	"fix up the objects in the segment that changed size.  An object in the segment is the wrong size for the modern version of the class.  Construct a fake class that is the old size.  Replace the modern class with the old one in outPointers.  Load the segment.  Traverse the instances, making new instances by copying fields, and running conversion messages.  Keep the new instances.  Bulk forward become the old to the new.  Let go of the fake objects and classes.
	After the install (below), arrayOfRoots is filled in.  Globalize new classes.  Caller may want to do some special install on certain objects in arrayOfRoots. 
	May want to write the segment out to disk in its new form."

	| mapFakeClassesToReal ccFixups receiverClasses |

	self flag: #bobconv.	

	RecentlyRenamedClasses _ nil.		"in case old data hanging around"
	mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers.
		"Dictionary of just the ones that change shape.  Substitute them in outPointers."
	ccFixups _ self remapCompactClasses: mapFakeClassesToReal 
				refStrm: smartRefStream.
	ccFixups ifFalse: [^ self error: 'A class in the file is not compatible'].
	endMarker _ segment nextObject. 	"for enumeration of objects"
	endMarker == 0 ifTrue: [endMarker _ 'End' clone].
	arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers.
		"Can't use install.  Not ready for rehashSets"
	mapFakeClassesToReal isEmpty ifFalse: [
		self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream
	].
	receiverClasses _ self restoreEndianness.		"rehash sets"
	smartRefStream checkFatalReshape: receiverClasses.

	"Classes in this segment."
	arrayOfRoots do: [:importedObject | 
		importedObject class class == Metaclass ifTrue: [self declare: importedObject]].
	arrayOfRoots do: [:importedObject | 
		(importedObject isKindOf: Project) ifTrue: [
			importedObject ensureChangeSetNameUnique.
			Project addingProject: importedObject.
			importedObject restoreReferences.
			ScriptEditorMorph writingUniversalTiles: 
				(importedObject world valueOfProperty: #universalTiles)]].
	
	arrayOfRoots do: [:importedObject | 
		(importedObject respondsTo: #unhibernate) ifTrue: [
			importedObject unhibernate].	"ScriptEditors and ViewerFlapTabs"
		].

	mapFakeClassesToReal isEmpty ifFalse: [
		mapFakeClassesToReal keys do: [:aFake | 
			aFake indexIfCompact > 0 ifTrue: [aFake becomeUncompact].
			aFake removeFromSystemUnlogged].
		SystemOrganization removeEmptyCategories].
	"^ self"! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/17/2001 12:06'!
declare: classThatIsARoot

	| nameOnArrival |
	"The class just arrived in this segment.  How fit it into the Smalltalk dictionary?  If it had an association, that was installed with associationDeclareAt:."

	nameOnArrival _ classThatIsARoot name.
	self declareAndPossiblyRename: classThatIsARoot.
	nameOnArrival == classThatIsARoot name ifTrue: [^self].
	renamedClasses ifNil: [RecentlyRenamedClasses _ renamedClasses _ Dictionary new].
	renamedClasses at: nameOnArrival put: classThatIsARoot name.

! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/12/2001 07:11'!
declareAndPossiblyRename: classThatIsARoot
	| existing catInstaller |
	"The class just arrived in this segment.  How fit it into the Smalltalk dictionary?  If it had an association, that was installed with associationDeclareAt:."

	catInstaller _ [
		classThatIsARoot superclass name == #Player 
			ifTrue: [classThatIsARoot category: Object categoryForUniclasses]
			ifFalse: [classThatIsARoot category: 'Morphic-Imported'].
	].
	classThatIsARoot superclass addSubclass: classThatIsARoot.
	(Smalltalk includesKey: classThatIsARoot name) ifFalse: [
		"Class entry in Smalltalk not referred to in Segment, install anyway."
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	existing _ Smalltalk at: classThatIsARoot name.
	existing xxxClass == ImageSegmentRootStub ifTrue: [
		"We are that segment!!  Must ask it carefully!!"
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	existing == false | (existing == nil) ifTrue: [
		"association is in outPointers, just installed"
		catInstaller value.
		^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
	"Conflict with existing global or copy of the class"
	(existing isKindOf: Class) ifTrue: [
		classThatIsARoot isSystemDefined not ifTrue: [
			"UniClass.  give it a new name"
			classThatIsARoot setName: Player chooseUniqueClassName.
			catInstaller value.	"must be after new name"
			^ Smalltalk at: classThatIsARoot name put: classThatIsARoot].
		"Take the incoming one"
		self inform: 'Using newly arrived version of ', classThatIsARoot name.
		classThatIsARoot superclass removeSubclass: classThatIsARoot.	"just in case"
		(Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot.
		catInstaller value.
		^ classThatIsARoot superclass addSubclass: classThatIsARoot].
	self error: 'Name already in use by a non-class: ', classThatIsARoot name.
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 9/26/2000 15:58'!
prepareToBeSaved
	"Prepare objects in outPointers to be written on the disk.  They must be able to match up with existing objects in their new system.  outPointers is already a copy.
	Classes are already converted to a DiskProxy.  
	Associations in outPointers:
1) in Smalltalk.
2) in a classPool.
3) in a shared pool.
4) A pool dict pointed at directly"

| left pool myClasses outIndexes key |
myClasses _ Set new.
arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]].
outIndexes _ IdentityDictionary new.
outPointers withIndexDo: [:anOut :ind | 
	anOut class == Association ifTrue: [
		(myClasses includes: anOut value)
			ifFalse: [outIndexes at: anOut put: ind]
			ifTrue: [(Smalltalk associationAt: anOut key ifAbsent: [3]) == anOut 
				ifTrue: [outPointers at: ind put: 
					(DiskProxy global: #Smalltalk selector: #associationDeclareAt: 
						args: (Array with: anOut key))]
				ifFalse: [outIndexes at: anOut put: ind]
				]].
	(anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly"
		(key _ Smalltalk keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [
			outPointers at: ind put: 
				(DiskProxy global: key selector: #yourself args: #())]].
	anOut isMorph ifTrue: [outPointers at: ind put: 
		(StringMorph contents: anOut printString, ' that was not counted')]
	].
left _ outIndexes keys asSet.
left size > 0 ifTrue: ["Globals"
	(left copy) do: [:assoc |	"stay stable while delete items"
		(Smalltalk associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
			outPointers at: (outIndexes at: assoc) put: 
				(DiskProxy global: #Smalltalk selector: #associationAt: 
					args: (Array with: assoc key)).
			left remove: assoc]]].
left size > 0 ifTrue: ["Class variables"
	Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [
		(left copy) do: [:assoc |	"stay stable while delete items"
			(cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
				outPointers at: (outIndexes at: assoc) put: 
					(DiskProxy new global: cls name
						preSelector: #classPool
						selector: #associationAt: 
						args: (Array with: assoc key)).
				left remove: assoc]]]]].
left size > 0 ifTrue: ["Pool variables"
	Smalltalk associationsDo: [:poolAssoc |
		poolAssoc value class == Dictionary ifTrue: ["a pool"
			pool _ poolAssoc value.
			(left copy) do: [:assoc |	"stay stable while delete items"
				(pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [
					outPointers at: (outIndexes at: assoc) put: 
						(DiskProxy global: poolAssoc key selector: #associationAt: 
							args: (Array with: assoc key)).
					left remove: assoc]]]]].
left size > 0 ifTrue: [
	"If points to class in arrayOfRoots, must deal with it separately"
	"OK to have obsolete associations that just get moved to the new system"
	self inform: 'extra associations'.
	left inspect].
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 1/25/2000 22:23'!
rehashSets
	"I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg |
	object _ segment.
	sets _ OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses _ IdentitySet new.
	inSeg _ true.
	[object _ object nextObject.  
		object == endMarker ifTrue: [inSeg _ false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			object class == BlockContext ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			object class == MethodContext ifTrue: [inSeg ifTrue: [
					receiverClasses add: object receiver class]].	
			]. 
		object == 0] whileFalse.
	sets do: [:each | each rehash].	"our purpose"
	^ receiverClasses	"our secondary job"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 12/20/2000 11:07'!
reshapeClasses: mapFakeClassesToReal refStream: smartRefStream 

	| bads allVarMaps perfect insts partials in out |

	self flag: #bobconv.	

	partials _ OrderedCollection new.
	bads _ OrderedCollection new.
	allVarMaps _ IdentityDictionary new.
	mapFakeClassesToReal keysAndValuesDo: [ :aFakeClass :theRealClass | 
		(theRealClass indexIfCompact > 0) "and there is a fake class"
			ifFalse: [insts _ aFakeClass allInstances]
			ifTrue: ["instances have the wrong class.  Fix them before anyone notices."
				insts _ OrderedCollection new.
				self allObjectsDo: [:obj | obj class == theRealClass ifTrue: [insts add: obj]].
			].
		insts do: [ :misShapen | 
			perfect _ smartRefStream convert1: misShapen to: theRealClass allVarMaps: allVarMaps.
			bads 
				detect: [ :x | x == misShapen] 
				ifNone: [
					bads add: misShapen.
					partials add: perfect
				].
		].
	].
	bads isEmpty ifFalse: [
		bads asArray elementsForwardIdentityTo: partials asArray
	].

	in _ OrderedCollection new.
	out _ OrderedCollection new.
	partials do: [ :each |
		perfect _ smartRefStream convert2: each allVarMaps: allVarMaps.
		in 
			detect: [ :x | x == each]
			ifNone: [
				in add: each.
				out add: perfect
			]
	].
	in isEmpty ifFalse: [
		in asArray elementsForwardIdentityTo: out asArray
	].
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 1/5/2001 09:53'!
restoreEndianness
	"Fix endianness (byte order) of any objects not already fixed.
	I have just been brought in and converted to live objects.  Find all Sets and Dictionaries in the newly created objects and rehash them.  Segment is near then end of memory, since is was newly brought in (and a new object created for it).
	Also, collect all classes of receivers of blocks which refer to instance variables.  Return them.  Caller will check if they have been reshaped."

	| object sets receiverClasses inSeg reorder |

	object _ segment.
	sets _ OrderedCollection new.
		"have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one."
	receiverClasses _ IdentitySet new.
	reorder _ (Smalltalk endianness) ~~ 
		((segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]).
	inSeg _ true.
	[object _ object nextObject.  "all the way to the end of memory to catch remade objects"
		object == endMarker ifTrue: [inSeg _ false].	"off end"
		object isInMemory ifTrue: [
			(object isKindOf: Set) ifTrue: [sets add: object].
			(object isKindOf: ContextPart) ifTrue: [
				(inSeg and: [object hasInstVarRef]) ifTrue: [
					receiverClasses add: object receiver class
				]
			].	
			(reorder and: [(object class == SoundBuffer) & inSeg]) ifTrue: [object swapHalves]]. 
		object == 0] whileFalse.
	sets do: [:each | each rehash].	"our purpose"
	^ receiverClasses	"our secondary job"
! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'RAA 6/22/2000 17:49'!
scanFrom: aStream
	"Move source code from a fileIn to the changes file for classes in an ImageSegment.  Do not compile the methods.  They already came in via the image segment.  After the ImageSegment in the file, !!ImageSegment new!! captures control, and scanFrom: is called."
	| val chunk |

	[aStream atEnd] whileFalse: 
		[aStream skipSeparators.
		val _ (aStream peekFor: $!!)
			ifTrue: ["Move (aStream nextChunk), find the method or class 
						comment, and install the file location bytes"
					(Compiler evaluate: aStream nextChunk logged: false)
						scanFromNoCompile: aStream forSegment: self]
			ifFalse: [chunk _ aStream nextChunk.
					aStream checkForPreamble: chunk.
					Compiler evaluate: chunk logged: true].
		aStream skipStyleChunk].
	"regular fileIn will close the file"
	^ val! !

!ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 3/6/2000 17:22'!
storeDataOn: aDataStream
	"Don't wrote the array of Roots.  Also remember the structures of the classes of objects inside the segment."

	| tempRoots tempOutP list |
	state = #activeCopy ifFalse: [self error: 'wrong state'].
		"real state is activeCopy, but we changed it will be right when coming in"
	tempRoots _ arrayOfRoots.
	tempOutP _ outPointers.
	outPointers _ outPointers clone.
	self prepareToBeSaved.
	arrayOfRoots _ nil.
	state _ #imported.
	super storeDataOn: aDataStream.		"record my inst vars"
	arrayOfRoots _ tempRoots.
	outPointers _ tempOutP.
	state _ #activeCopy.
	aDataStream references at: #AnImageSegment put: false.
		"flag that there is one in this write"

	"Find the receivers of blocks in the segment.  Need to get the structure of their classes into structures.  Put the receivers into references."
	(aDataStream byteStream isKindOf: DummyStream) ifTrue: [
		list _ Set new.
		arrayOfRoots do: [:ea | 
			(ea class == BlockContext) | (ea class == MethodContext) ifTrue: [ 
				list add: ea receiver class ]].
		aDataStream references at: #BlockReceiverClasses put: list].
! !


!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'!
allInstancesOf: aClass do: aBlock
	| withSymbols oldInstances segSize |
	"Bring me in, locate instances of aClass and submit them to the block.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	(outPointers includes: aClass) ifFalse: [^ self].
		"If has instances, they point out at the class"
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	oldInstances _ OrderedCollection new.
	self allObjectsDo: [:obj | obj class == aClass ifTrue: [
		oldInstances add: obj]].
	oldInstances do: [:inst | aBlock value: inst].	"do the work"
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].

! !

!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:54'!
ifOutPointer: anObject thenAllObjectsDo: aBlock
	| withSymbols segSize |
	"If I point out to anObject, bring me in, Submit all my objects to the block.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	(outPointers includes: anObject) ifFalse: [^ self].
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	self allObjectsDo: [:obj | aBlock value: obj].	"do the work"
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].

! !

!ImageSegment methodsFor: 'instance change shape' stamp: 'tk 1/25/2000 21:51'!
segUpdateInstancesOf: oldClass toBe: newClass isMeta: isMeta
	| withSymbols oldInstances segSize |
	"Bring me in, locate instances of oldClass and get them converted.  Write me out again."

	(state = #onFile or: [state = #onFileWithSymbols]) ifFalse: [^ self].
	withSymbols _ state = #onFileWithSymbols.
	"If has instances, they point out at the class"
	(outPointers includes: oldClass) ifFalse: [
		oldClass == SmallInteger ifTrue: [^ self].	"instance not changable"
		oldClass == Symbol ifTrue: [^ self].	"instance is never in a segment"
		(Smalltalk compactClassesArray includes: oldClass) ifFalse: [^ self]].
		"For a compact class, must search the segment.  Instance does not 
		 point outward to class"
	state = #onFile ifTrue: [Cursor read showWhile: [self readFromFile]].
	segSize _ segment size.
	self install.
	oldInstances _ OrderedCollection new.
	self allObjectsDo: [:obj | obj class == oldClass ifTrue: [
		oldInstances add: obj]].
	newClass updateInstances: oldInstances asArray from: oldClass isMeta: isMeta.
	self copyFromRoots: arrayOfRoots sizeHint: segSize.
	self extract.
	withSymbols 
		ifTrue: [self writeToFileWithSymbols]
		ifFalse: [self writeToFile].
! !


!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/8/2000 17:39'!
aComment
	"Compact classes are a potential problem because a pointer to the class would not ordinarily show up in the outPointers.  We add the classes of all compact classes to outPointers, both for local and export segments.
	Compact classes are never allowed as roots.  No compact class may be in an Environment that is written out to disk.  (In local segments, the compact classes array should never have an ImageSegmentRootStub in it.  For export, fileIn the class first, then load a segment with instances of it.  The fileIn code can be pasted onto the front of the .extSeg file) 
	For local segments, a class may become compact while its instances are out on the disk.  Or it may become un-compact.  A compact class may change shape while some of its instances are on disk.  All three cases go through (ClassDescription updateInstancesFrom:).  If it can't rule out an instance being in the segment, it reads it in to fix the instances.  
	See Behavior.becomeCompact for the rules on Compact classes.  Indexes may not be reused.  This is so that an incoming export segment has its index available.  (Changes may be needed in the way indexes are assigned.)
	For export segments, a compact class may have a different shape.  The normal class reshape mechanism will catch this.  During the installation of the segment, objects will have the wrong version of their class momentarily.  We will change them back before we get caught.
	For export segments, the last two items in outPointers are the number 1717 and an array of the compact classes used in this segment.  (The classes in the array are converted from DiskProxies by SmartRefStream.)  If that class is not compact in the new image, the instances are recopied.
	"!
]style[(8 275 5 1435)f1b,f1,f3,f1! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/10/2000 14:51'!
cc: ind new: inTheSeg current: inTheImage fake: fakeCls refStrm: smartRefStream
	"Sort out all the cases and decide what to do.  Every Fake class is uncompacted before having insts converted.  As the segment is installed, instances of reshaped compact classes will have the wrong class.  Trouble cases:
	1) Existing class is compact in the segment and not compact here.  Make that compact, (error if that slot is used), load the segment.  If an class was just filed in, it is an existing class as far as we are concerned.
	2) A compact class has a different shape.  We created a Fake class.  Load the segment, with instances in the seg having the Wrong Class!!!!  Find the bad instancees, and copy them over to being the real class.
	3) An existing class is not compact in the segment, but is in the image.  Just let the new instance be uncompact.  That is OK, and never reaches this code.
	A class that is a root in this segment cannot be compact.  That is not allowed."

	(inTheImage == nil) & (fakeCls == nil) ifTrue: ["case 1 and empty slot" 
		inTheSeg becomeCompactSimplyAt: ind.  ^ true].
	
	(inTheImage == inTheSeg) & (fakeCls == nil) ifTrue: ["everything matches" 
		^ true].

	inTheImage ifNil: ["reshaped and is an empty slot"
		fakeCls becomeCompactSimplyAt: ind.  ^ true].
		"comeFullyUpOnReload: will clean up"

	"Is the image class really the class we are expecting?  inTheSeg came in as a DiskProxy, and was mapped if it was renamed!!"
	inTheImage == inTheSeg ifFalse: [
		self inform: 'The incoming class ', inTheSeg name, ' wants compact class \location ', ind printString, ', but that is occupied by ', inTheImage name, '.  \This file cannot be read into this system.  The author of the file \should make the class uncompact and create the file again.' withCRs.
		^ false].

	"Instances of fakeCls think they are compact, and thus will say they are instances of the class inTheImage, which is a different shape.  Just allow this to happen.  Collect them and remap them as soon as the segment is installed."
	^ true! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/26/2000 20:57'!
compactClassesArray
	| ccIndexes ind ccArray hdrBits |
	"A copy of the real compactClassesArray, but with only the classes actually used in the segment.  Slow, but OK for export."

	ccIndexes _ Set new.
	ind _ 2. 	"skip version word, first object"
	"go past extra header words"
	(hdrBits _ (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind _ ind+1].
	hdrBits = 0 ifTrue: [ind _ ind+3].

	[ccIndexes add: (self compactIndexAt: ind).	"0 if has class field"
	 ind _ self objectAfter: ind.
	 ind > segment size] whileFalse.
	ccArray _ Smalltalk compactClassesArray clone.
	1 to: ccArray size do: [:ii | "only the ones we use"
		(ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]].
	^ ccArray! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 12/21/1999 21:53'!
compactIndexAt: ind
	| word |
	"Look in this header word in the segment and find it's compact class index. *** Warning: When class ObjectMemory change, be sure to change it here. *** "

	((word _ segment at: ind) bitAnd: 3) = 2 ifTrue: [^ 0].  "free block"
	^ (word >> 12) bitAnd: 16r1F 	"Compact Class field of header word"

! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 3/15/2000 09:51'!
objectAfter: ind
	"Return the object or free chunk immediately following the given object or free chunk in the segment.  *** Warning: When class ObjectMemory change, be sure to change it here. ***"

	| sz word newInd hdrBits |
	sz _ ((word _ segment at: ind "header") bitAnd: 3) = 2   "free block?"
		ifTrue: [word bitAnd: 16rFFFFFFFC]
		ifFalse: [(word bitAnd: 3) = 0 "HeaderTypeSizeAndClass"
			ifTrue: [(segment at: ind-2) bitAnd: 16rFFFFFFFC]
			ifFalse: [word bitAnd: "SizeMask" 252]].

	newInd _ ind + (sz>>2).
	"adjust past extra header words"
	(hdrBits _ (segment atPin: newInd) bitAnd: 3) = 3 ifTrue: [^ newInd].
		"If at end, header word will be garbage.  This is OK"
	hdrBits = 1 ifTrue: [^ newInd+1].
	hdrBits = 0 ifTrue: [^ newInd+2].
	^ newInd	"free"! !

!ImageSegment methodsFor: 'compact classes' stamp: 'tk 1/11/2000 15:27'!
remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream
	| ccArray current fake info |
	"See if our compact classes are compatible with this system.  Convert to what the system already has.  If we are adding a new class, it has already been filed in.  A compact class may not be a root."

	(outPointers at: (outPointers size - 1)) = 1717 ifFalse: [^ true].
	ccArray _ outPointers last.
	current _ Smalltalk compactClassesArray.
	1 to: ccArray size do: [:ind | 
		(ccArray at: ind) ifNotNil: ["is compact in the segment"
			fake _ mapFakeClassesToReal keyAtValue: (current at: ind) ifAbsent: [nil].
			info _ self cc: ind new: (ccArray at: ind) current: (current at: ind) 
					fake: fake refStrm: smartRefStream.
			info ifFalse: [^ false]]].
	^ true! !


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

ImageSegment class
	instanceVariableNames: ''!

!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 21:58'!
activeClasses   "ImageSegment activeClasses"
	"Restore all remaining MD faults and return the active classes"

	| unused active |
	unused _ OrderedCollection new.
	active _ OrderedCollection new.
	Smalltalk allClasses do:
		[:c | (c instVarNamed: 'methodDict') 
			ifNil: [unused addLast: c]
			ifNotNil: [active addLast: c]].
	unused do: [:c | c recoverFromMDFault].
	^ active
! !

!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 22:08'!
activeClassesByCategory   "ImageSegment activeClassesByCategory"
	"Return a dictionary of active classes by system category.
	Useful for finding kernel categories to minimize swapping."

	| active dict cat list |
	active _ self activeClasses.
	dict _ Dictionary new.
	active do:
		[:c | cat _ c category.
		list _ dict at: cat ifAbsent: [Array new].
		dict at: cat put: (list copyWith: c)].
	^ dict
"
	ImageSegment discoverActiveClasses  <-- do it
		-- do something typical --
	ImageSegment activeClassesByCategory  <-- inspect it
"! !

!ImageSegment class methodsFor: 'testing' stamp: 'di 2/17/2000 22:00'!
discoverActiveClasses   "ImageSegment discoverActiveClasses" 
	"Run this method, do a few things, save and resume the image.
	This will leave unused classes with MDFaults.
	You MUST follow this soon by activeClasses, or by swapOutInactiveClasses."

	| ok |
	Smalltalk allClasses do:
		[:c | ok _ true.
		#(Array Object Class Message MethodDictionary) do:
			[:n | ((Smalltalk at: n) == c or:
				[(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok _ false]].
		ok ifTrue: [c induceMDFault]].
"
	ImageSegment discoverActiveClasses.
		-- do something typical --
	PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' ,
			Smalltalk allClasses size printString.
"! !

!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'!
swapOutInactiveClasses  "ImageSegment swapOutInactiveClasses"  
	"Make up segments by grouping unused classes by system category.
	Read about, and execute discoverActiveClasses, and THEN execute this one."

	| unused groups i roots |
	ImageSegment recoverFromMDFault.
	ImageSegmentRootStub recoverFromMDFault.
	unused _ Smalltalk allClasses select: [:c | (c instVarNamed: 'methodDict') == nil].
	unused do: [:c | c recoverFromMDFault].
	groups _ Dictionary new.
	SystemOrganization categories do:
		[:cat |
		i _ (cat findLast: [:c | c = $-]) - 1.
		i <= 0 ifTrue: [i _ cat size].
		groups at: (cat copyFrom: 1 to: i)
			put: (groups at: (cat copyFrom: 1 to: i) ifAbsent: [Array new]) ,
			((SystemOrganization superclassOrder: cat) select: [:c | 
				unused includes: c]) asArray].
	groups keys do:
		[:cat | roots _ groups at: cat.
		Transcript cr; cr; show: cat; cr; print: roots; endEntry.
		roots _ roots , (roots collect: [:c | c class]).
		(cat beginsWith: 'Sys' "something here breaks") ifFalse:
			[(ImageSegment new copyFromRoots: roots sizeHint: 0) extract; 
				writeToFile: cat].
		Transcript cr; print: Smalltalk garbageCollect; endEntry]! !

!ImageSegment class methodsFor: 'testing' stamp: 'RAA 9/27/2000 18:50'!
swapOutProjects  "ImageSegment swapOutProjects"  
	"Swap out segments for all projects other than the current one."

	| spaceLeft newSpaceLeft |
	spaceLeft _ Smalltalk garbageCollect.
	Project allProjects doWithIndex:
		[:p :i | p couldBeSwappedOut ifTrue:
			[Transcript cr; cr; nextPutAll: p name.
			(ImageSegment new copyFromRoots: (Array with: p) sizeHint: 0)
				extract; writeToFile: 'project' , i printString.
			newSpaceLeft _ Smalltalk garbageCollect.
			Transcript cr; print: newSpaceLeft - spaceLeft; endEntry.
			spaceLeft _ newSpaceLeft]].! !

!ImageSegment class methodsFor: 'testing' stamp: 'tk 11/30/1999 22:27'!
testClassFaultOn: someClass  "ImageSegment testClassFaultOn: FileList"  
	"Swap out a class with an existing instance.  Then send a message to the inst.
	This will cause the VM to choke down deep and resend #cannotInterpret:.
	This in turn will send a message to the stubbed class which will choke
	and resend: #doesNotUnderstand:.  Then, if we're lucky, things will start working."

	(ImageSegment new copyFromRoots: (Array with: someClass with: someClass class) 
		sizeHint: 0) extract; writeToFile: 'test'.
! !


!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 9/24/1999 11:41'!
folder
	| im |
	"Full path name of segments folder.  Be sure to duplicate and rename the folder when you duplicate and rename an image.  Is $_ legal in all file systems?"

	im _ Smalltalk imageName.
	^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 12/16/1999 23:44'!
reclaimObsoleteSegmentFiles  "ImageSegment reclaimObsoleteSegmentFiles"
	"Delete segment files that can't be used after this image is saved.
	Note that this is never necessary -- it just saves file space."

	| aFileName segDir segFiles folderName byName exists |
	folderName _ FileDirectory default class localNameFor: self folder.
	(FileDirectory default includesKey: folderName) ifFalse: [
		^ self "don't create if absent"].
	segDir _ self segmentDirectory.
	segFiles _ (segDir fileNames select: [:fn | fn endsWith: '.seg']) asSet.
	exists _ segFiles copy.
	segFiles isEmpty ifTrue: [^ self].
	byName _ Set new.
	"Remove (save) every file owned by a segment in memory"
	ImageSegment allInstancesDo: [:is | 
		(aFileName _ is localName) ifNotNil: [
			segFiles remove: aFileName ifAbsent: [].
			(exists includes: aFileName) ifFalse: [
				Transcript cr; show: 'Segment file not found: ', aFileName].
			byName add: is segmentName]].
	"Of the segments we have seen, delete unclaimed the files."
	segFiles do: [:fName | 
		"Delete other file versions with same project name as one known to us"
		(byName includes: (fName sansPeriodSuffix stemAndNumericSuffix first))
			ifTrue: [segDir deleteFileNamed: fName]].! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'di 9/29/1999 15:45'!
segmentDirectory
	"Return a directory object for the folder of segments.
	Create such a folder if none exists."
	| dir folderName |
	dir _ FileDirectory default.
	folderName _ dir class localNameFor: self folder. "imageName_segs"
	(dir includesKey: folderName) ifFalse:
		[dir createDirectory: folderName].	"create the folder if necess"
	^ dir directoryNamed: folderName! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 9/23/1999 17:50'!
shutDown
	"Delete segment files that can't be used after this image is saved."

	"This is Optional.  
(1) How tell if saving image now?  Only do if is.
(2) ImageSegmentRootStub allInstancesDo: 
	If more than one file, delete all but one we are using now.
	Leave files with not stubs (could be out in a segment)
	Must forbid two projects from having the same name!!
(3) all Projects do:
	If project is in, delete all files with its name.
"
	! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 9/24/1999 14:48'!
startUp
	| choice |
	"Minimal thing to assure that a .segs folder is present"

(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
	(FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) 
		ifFalse: [
			choice _ (PopUpMenu labels: 'Create folder\Quit without saving' withCRs)
				startUpWithCaption: 
					'The folder with segments for this image is missing.\' withCRs,
					self folder, '\If you have moved or renamed the image file,\' withCRs,
					'please Quit and rename the segments folder in the same way'.
			choice = 1 ifTrue: [FileDirectory default createDirectory: self folder].
			choice = 2 ifTrue: [Smalltalk snapshot: false andQuit: true]]]

	! !

!ImageSegment class methodsFor: 'fileIn/Out' stamp: 'tk 12/16/1999 22:33'!
uniqueFileNameFor: segName
	"Choose a unique file name for the segment with this name."
	| segDir fileName listOfFiles |
	segDir _ self segmentDirectory.
	listOfFiles _ segDir fileNames.
	BiggestFileNumber ifNil: [BiggestFileNumber _ 1].
	BiggestFileNumber > 99 ifTrue: [BiggestFileNumber _ 1].	"wrap"
	[fileName _ segName, BiggestFileNumber printString, '.seg'.
	 (listOfFiles includes: fileName)] whileTrue: [
		BiggestFileNumber _ BiggestFileNumber + 1].	"force a unique file name"
	^ fileName! !


!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:33'!
compressedFileExtension
	^'sqz'! !

!ImageSegment class methodsFor: 'accessing' stamp: 'mir 10/11/2000 17:32'!
fileExtension
	^'extSeg'! !
ProtoObject subclass: #ImageSegmentRootStub
	instanceVariableNames: 'shadowSuper shadowMethodDict shadowFormat imageSegment '
	classVariableNames: 'FaultLogs LoggingFaults '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ImageSegmentRootStub commentStamp: '<historical>' prior: 0!
An ImageSegmentRootStub is a stub that replaces one of the root of an ImageSegment that has been extracted from the Squeak ObjectMemory.  It has two very simple roles:

1.  If any message is sent to one of these objects, it will be caught by doesNotUnderstand:, and bring about a reinstallation of the missing segment.  This exception is caused by the fact that no other messages are defined in this class, and neither does it inherit any from above, since its superclass is nil.  When the reinstallation has been accomplished, the message will be resent as though nothing was amiss.

2.  If one of these objects is a class, and a message is sent to one of its instances, it will cause a similar fault which will be caught by cannotInterpret:.  This exception is caused by a somewhat more subtle condition:  the primitive operations of the virtual machine do not have time to check whether classes are resident or not -- they assume that all classes are resident.  However every non-cached message lookup does test for a nil in the methodDictionary slot.  If a rootStub replaces a class (or any behavior), it masquerades as the class, but it will have a nil in the slot where the method Dictionary is expected.  This will cause the VM to send cannotInterpret:, eventually leading to the same process for reinstalling the missing segment and resending the message as above.

Just to be on the safe side, a rootStub that replaces a Behavior also carries a copy of both the superclass and format fields from the original class.  This insures that, even if some operations of the VM require these values, things will continue to operate properly when the segment is absent.!


!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 2/28/2000 10:50'!
doesNotUnderstand: aMessage 
	 "Any normal message sent to this object is really intended for another object that is in a non-resident imageSegment.  Reinstall the segment and resend the message."

	imageSegment install.
	LoggingFaults ifTrue:		"Save the stack printout to show who caused the fault"
		[FaultLogs at: Time millisecondClockValue printString
			put: (String streamContents:
				[:strm | 
				strm print: self class; space; print: aMessage selector; cr.
				(thisContext sender stackOfSize: 30)
					do: [:item | strm print: item; cr]])].

	"NOTE:  The following should really be (aMessage sentTo: self)
		in order to recover properly from a fault in a super-send,
		however, the lookupClass might be bogus in this case, and it's
		almost unthinkable that the first fault would be a super send."
	^ self perform: aMessage selector withArguments: aMessage arguments! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/27/1999 12:19'!
xxSuperclass: superclass format: format segment: segment

	"Set up fields like a class but with null methodDict"
	shadowSuper _ superclass.
	shadowMethodDict _ nil.
	shadowFormat _ format.
	imageSegment _ segment.
! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 4/9/1999 10:32'!
xxxClass
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'tk 10/24/1999 10:57'!
xxxSegment
	^ imageSegment! !


!ImageSegmentRootStub methodsFor: 'basics' stamp: 'tk 8/13/1999 15:59'!
isInMemory
	"We are a place holder for an object that is out."
	^ false! !

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

ImageSegmentRootStub class
	instanceVariableNames: ''!

!ImageSegmentRootStub class methodsFor: 'as yet unclassified' stamp: 'di 2/7/2000 23:43'!
doLogFaults  "ImageSegmentRootStub doLogFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ true.! !

!ImageSegmentRootStub class methodsFor: 'as yet unclassified' stamp: 'di 2/7/2000 23:17'!
dontLogFaults  "ImageSegmentRootStub dontLogFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ false.! !

!ImageSegmentRootStub class methodsFor: 'as yet unclassified' stamp: 'di 2/11/2000 12:33'!
faultLogs  "ImageSegmentRootStub faultLogs"  "<-- inspect it"

	^ FaultLogs! !

!ImageSegmentRootStub class methodsFor: 'as yet unclassified' stamp: 'di 2/11/2000 12:31'!
startLoggingFaults  "ImageSegmentRootStub startLoggingFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ true.! !

!ImageSegmentRootStub class methodsFor: 'as yet unclassified' stamp: 'di 2/11/2000 12:33'!
stopLoggingFaults  "ImageSegmentRootStub stopLoggingFaults"

	FaultLogs _ Dictionary new.
	LoggingFaults _ false.! !
StringMorph subclass: #IndentingListItemMorph
	instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!IndentingListItemMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
Don't blame him if it's not perfect.  We wanted to get it out for people to play with.!


!IndentingListItemMorph methodsFor: 'mouse events' stamp: 'mir 5/5/2000 11:53'!
acceptDroppingMorph: toDrop event: evt. 
	complexContents acceptDroppingObject: toDrop complexContents.
	toDrop delete.
	self clearDropHighlighting.! !

!IndentingListItemMorph methodsFor: 'mouse events' stamp: 'RAA 8/5/1999 19:28'!
handlesMouseDown: evt

	"if user wants a menu, let the pane handle it"

	^evt yellowButtonPressed not! !

!IndentingListItemMorph methodsFor: 'mouse events' stamp: 'RAA 7/13/1998 17:15'!
inToggleArea: event

	^self toggleRectangle containsPoint: event cursorPoint

	! !


!IndentingListItemMorph methodsFor: 'drawing' stamp: 'mir 5/5/2000 11:43'!
drawOn: aCanvas

	| tRect sRect columnRect columnScanner columnData columnLeft colorToUse |

	tRect := self toggleRectangle.
	sRect := bounds withLeft: tRect right + 3.
	self drawToggleOn: aCanvas in: tRect.
	colorToUse _ complexContents preferredColor ifNil: [color].
	(container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [
		aCanvas text: contents asString bounds: sRect font: font color: colorToUse.
	] ifFalse: [
		columnLeft _ sRect left.
		columnScanner _ ReadStream on: contents asString.
		container columns do: [ :width |
			columnRect _ columnLeft @ sRect top extent: width @ sRect height.
			columnData _ columnScanner upTo: Character tab.
			columnData isEmpty ifFalse: [
				aCanvas text: columnData bounds: columnRect font: font color: colorToUse.
			].
			columnLeft _ columnRect right + 5.
		].
	]! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'dew 1/21/2001 16:47'!
drawToggleOn: aCanvas in: aRectangle

	| aForm centeringOffset |
	complexContents hasContents ifFalse: [^self].
	aForm _ isExpanded 
		ifTrue: [container expandedForm]
		ifFalse: [container notExpandedForm].
	centeringOffset _ ((aRectangle height - aForm extent y) / 2) asInteger.
	^aCanvas 
		paintImage: aForm 
		at: (aRectangle topLeft translateBy: 0 @ centeringOffset).
! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:47'!
highlight

	complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor].
	self changed.
	
! !

!IndentingListItemMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:46'!
unhighlight

	complexContents highlightingColor ifNotNil: [self color: Color black].
	self changed.
	
	
! !


!IndentingListItemMorph methodsFor: 'initialization' stamp: 'RAA 7/30/2000 19:13'!
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel

	container _ hostList.
	complexContents _ anObject.
	self initWithContents: anObject asString font: nil emphasis: nil.
	indentLevel _ 0.
	isExpanded _ false.
 	nextSibling _ firstChild _ nil.
	priorMorph ifNotNil: [
		priorMorph nextSibling: self.
	].
	indentLevel _ newLevel.
! !

!IndentingListItemMorph methodsFor: 'initialization' stamp: 'RAA 7/15/1998 00:14'!
initialize

	super initialize.
	indentLevel := 0.
	isExpanded := false.! !


!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:49'!
addChildrenForList: hostList addingTo: morphList withExpandedItems: expandedItems

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode delete].
	].
	firstChild _ nil.
	complexContents hasContents ifFalse: [^self].
	firstChild _ hostList 
		addMorphsTo: morphList
		from: complexContents contents 
		allowSorting: true
		withExpandedItems: expandedItems
		atLevel: indentLevel + 1.
	! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:00'!
balloonText

	^complexContents balloonText ifNil: [super balloonText]! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 11:13'!
boundsForBalloon

	"some morphs have bounds that are way too big"
	container ifNil: [^super boundsForBalloon].
	^self boundsInWorld intersect: container boundsInWorld! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 17:44'!
canExpand

	^complexContents hasContents! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'panda 4/28/2000 15:30'!
children
	| children |
	children _ OrderedCollection new.
	self childrenDo: [:each | children add: each].
	^children! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'panda 4/28/2000 15:29'!
childrenDo: aBlock

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aBlock value: aNode].
	]! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/1998 14:34'!
complexContents

	^complexContents! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/1999 16:48'!
firstChild

	^firstChild! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:15'!
indentLevel

	^indentLevel! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/1998 00:30'!
isExpanded

	^isExpanded! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/1998 00:48'!
isExpanded: aBoolean

	isExpanded _ aBoolean! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/1998 12:15'!
nextSibling

	^nextSibling! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/1998 01:05'!
nextSibling: anotherMorph

	nextSibling _ anotherMorph! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/16/2000 11:30'!
openPath: anArray

	anArray isEmpty ifTrue: [^container setSelectedMorph: nil].
	self withSiblingsDo: [:each | 
		(each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [
			each isExpanded ifFalse: [
				each toggleExpandedState.
				container installEventHandlerOn: each children.
				container adjustSubmorphPositions.
			].
			each changed.
			anArray size = 1 ifTrue: [
				^container setSelectedMorph: each
			].
			each firstChild ifNil: [^container setSelectedMorph: nil].
			^each firstChild openPath: anArray allButFirst.
		].
	].
	^container setSelectedMorph: nil

! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 18:53'!
recomputeAllForList: hostList addingTo: aCollection withExpandedItems: expandedItems

	self halt.	"not used"

	"self withSiblingsDo: [ :aNode |
		aNode 
			recomputeForList: hostList 
			addingTo: aCollection 
			withExpandedItems: expandedItems.
	].
"! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:05'!
recomputeForList: hostList addingTo: aCollection withExpandedItems: expandedItems

	self halt.	"no longer used"

	
	"self contents: complexContents asString.
	aCollection add: self."
	"isExpanded ifTrue: [
		self 
			addChildrenForList: hostList 
			addingTo: aCollection 
			withExpandedItems: expandedItems]."
! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 14:54'!
recursiveAddTo: aCollection

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection].
	].
	aCollection add: self
	! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/2/1999 18:02'!
recursiveDelete

	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete].
	].
	self delete
	! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:17'!
toggleExpandedState

 	| newChildren toDelete c |

	isExpanded _ isExpanded not.
	toDelete _ OrderedCollection new.
	firstChild ifNotNil: [
		firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: toDelete].
	].
	container noteRemovalOfAll: toDelete.
	(isExpanded and: [complexContents hasContents]) ifFalse: [
		^self changed
	].
	(c _ complexContents contents) isEmpty ifTrue: [^self changed].
	newChildren _ container 
		addSubmorphsAfter: self 
		fromCollection: c 
		allowSorting: true.
	firstChild _ newChildren first.
! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 22:06'!
toggleRectangle

	| h |
	h _ bounds height.
	^(bounds left + (12 * indentLevel)) @ bounds top extent: 12@h! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/1998 14:25'!
withSiblingsDo: aBlock

	| node |
	node _ self.
	[node isNil] whileFalse: [
		aBlock value: node.
		node _ node nextSibling
	].! !

!IndentingListItemMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^complexContents withoutListWrapper! !
IndentingListItemMorph subclass: #IndentingListParagraphMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:10'!
desiredHeight

	submorphs isEmpty ifTrue: [^self height].
	"isExpanded ifFalse: [^self height]."
	^complexContents withoutListWrapper height "max: self height"
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 12:53'!
drawOn: aCanvas

	self drawToggleOn: aCanvas in: self toggleRectangle.
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/26/2001 10:26'!
drawToggleOn: aCanvas in: aRectangle

	| aForm |

	aCanvas 
		fillRectangle: (bounds withRight: aRectangle right)
		color: container color.
	complexContents hasContents ifFalse: [^self].
	aForm _ isExpanded 
		ifTrue: [container expandedForm]
		ifFalse: [container notExpandedForm].
	^aCanvas 
		paintImage: aForm 
		at: aRectangle topLeft
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 09:52'!
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel

	super initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel.
	self width: hostList width.
	complexContents withoutListWrapper firstDisplay ifTrue: [
		complexContents withoutListWrapper firstDisplayedOnLevel: indentLevel.
		isExpanded _ true.
	].
	complexContents withoutListWrapper showInOpenedState ifTrue: [
		isExpanded _ true.
	].
	self addMorph: self repositionText.

! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:47'!
isExpanded: aBoolean

	| tm |
	super isExpanded: aBoolean.
	tm _ self repositionText.
	isExpanded ifFalse: [
		self height: tm height.
	].
	self addMorph: tm.
	"tm clipToOwner: isExpanded not."		"not really working right yet"

! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 10:04'!
keyStroke: evt

	| char |
	char _ evt keyCharacter.
	evt controlKeyPressed ifTrue: [
		char = Character cr ifTrue: [
			container model addSibling.
			^true	"we did handle it"
		].
		char = Character tab ifTrue: [
			container model addNewChildAfter: 0.
			^true	"we did handle it"
		].
	].
	^false	"we did not handle it"
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 12:54'!
layoutChanged

	super layoutChanged.
	submorphs isEmpty ifTrue: [^self].
	self desiredHeight = self height ifTrue: [^self].
	self height: self desiredHeight.
	container adjustSubmorphPositions.
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 16:06'!
position: p andWidth: w

	| widthChanged |

	widthChanged _ self width ~= w.
	self position: p.
	self width: w.
	submorphs isEmpty ifTrue: [^self height].
	widthChanged ifTrue: [
		self repositionText.
	].
	self height: self desiredHeight.
	^self desiredHeight
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 12:14'!
privateBounds: boundsRect
	"Private!! Use position: and/or extent: instead."
	
	^super privateBounds: boundsRect! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:19'!
repositionText

	| sRect tm |
	sRect _ self textMorphBounds.
	(tm _ complexContents withoutListWrapper)
		"clipToOwner: isExpanded not;"
		position: sRect origin;
		width: sRect width.
	isExpanded ifTrue: [
		tm extent: sRect width@10.
		tm contents: tm contents wrappedTo: sRect width.
		tm extent: sRect width@10.
	] ifFalse: [
		tm contentsAsIs: tm contents.
		tm extent: tm extent.		"force bounds recompute"
	].
	tm lock: isExpanded not.
"{tm. tm bounds. sRect} explore."
	^tm
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 10:21'!
takeFocus

	container setSelectedMorph: self! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 15:36'!
textMorphBounds

	^(bounds withRight: self right - 4)
		 withLeft: self textMorphLeft.
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:45'!
textMorphLeft
	
	^self toggleRectangle right + 3
! !

!IndentingListParagraphMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 12:29'!
toggleExpandedState

	super toggleExpandedState.
	self isExpanded: isExpanded.
! !

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

IndentingListParagraphMorph class
	instanceVariableNames: ''!

!IndentingListParagraphMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/8/2000 14:36'!
includeInNewMorphMenu

	^ false! !
MailDBFile subclass: #IndexFile
	instanceVariableNames: 'msgDictionary timeSortedEntries logfile '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!IndexFile commentStamp: '<historical>' prior: 0!
I represent an index for the messages in a mail database. I acts like a dictionary that maps unique message ID's to IndexFileEntry objects.

The index file is read into memory in its entirety and kept there for the duration of a mail reading session. It should be stored back to disk at the end of the session, or after a major change, such as fetching new mail. If necessary, it can be completely recreated by scanning the messages file.
!


!IndexFile methodsFor: 'file operations' stamp: 'dvf 5/1/2000 21:26'!
openOn: aFileName messageFile: messageFile 
	"Initialize myself from the file with the given name."
	| fileStream |
	filename _ aFileName.
	fileStream _ FileStream fileNamed: aFileName.
	self readFrom: (ReadStream on: fileStream contentsOfEntireFile)
		messageFile: messageFile.
	self readLogMessageFile: messageFile .
	"close and release the file stream"
	fileStream _ nil! !

!IndexFile methodsFor: 'file operations' stamp: 'dvf 4/30/2000 00:38'!
readLogMessageFile: messageFile 
	| file msgID entry |
	file _ self logStream position: 0.
	[file atEnd]
		whileFalse: [(file peekFor: $r)
				ifTrue: 
					[MailDB readStringLineFrom: file.
					self privateRemove: (MailDB readIntegerLineFrom: file)]
				ifFalse: 
					[msgID _ MailDB readIntegerLineFrom: file.
					entry _ IndexFileEntry
								readFrom: file
								messageFile: messageFile
								msgID: msgID. self privateAt: msgID put: entry]]! !


!IndexFile methodsFor: 'dictionary access'!
at: msgID
	"Answer the IndexFileEntry for the message with the given ID."

	^msgDictionary at: msgID ifAbsent: [self reportInconsistency]! !

!IndexFile methodsFor: 'dictionary access'!
at: msgID ifAbsent: aBlock
	"Answer the IndexFileEntry for the message with the given ID. Evaluate the given block if there is no entry for the given ID."

	^msgDictionary at: msgID ifAbsent: aBlock! !

!IndexFile methodsFor: 'dictionary access' stamp: 'dvf 4/30/2000 00:17'!
at: msgID put: anIndexFileEntry 
	"Associate the given IndexFileEntry with the given message ID."
	timeSortedEntries removeAllSuchThat: [:assoc | assoc key = msgID].
	"don't duplicate the entry!!"
	self privateAt: msgID put: anIndexFileEntry.
	self logStream print: msgID;
	 cr.
	"message ID"
	anIndexFileEntry writeOn: self logStream.
	self logStream close! !

!IndexFile methodsFor: 'dictionary access'!
includesKey: msgID
	"Answer true if my message dictionary contains an entry for the message with the given ID."

	^msgDictionary includesKey: msgID! !

!IndexFile methodsFor: 'dictionary access'!
keys
	"Answer a collection of message IDs for the messages in this IndexFile, sorted in ascending timestamp order. Because sorting is expensive, the sorted key list is cached."

	| keys |
	keys _ OrderedCollection new: timeSortedEntries size * 2.
	timeSortedEntries do: [: assoc | keys addLast: assoc key].
	^keys! !

!IndexFile methodsFor: 'dictionary access' stamp: 'dvf 6/3/2000 16:56'!
keysCount
	^msgDictionary size! !

!IndexFile methodsFor: 'dictionary access' stamp: 'RAA 9/14/2000 16:00'!
logStream

	logfile ifNil: [
		^logfile _ (StandardFileStream fileNamed: filename,'.log') setToEnd
	].
	logfile closed ifTrue: [logfile open; setToEnd].
	^ logfile! !

!IndexFile methodsFor: 'dictionary access' stamp: 'dvf 4/30/2000 00:10'!
privateAt: msgID put: anIndexFileEntry 
	"Associate the given IndexFileEntry with the given message ID."
	timeSortedEntries removeAllSuchThat: [:assoc | assoc key = msgID].
	"don't duplicate the entry!!"
	msgDictionary at: msgID put: anIndexFileEntry.
	timeSortedEntries add: (Association key: msgID value: anIndexFileEntry).
	! !

!IndexFile methodsFor: 'dictionary access' stamp: 'dvf 4/30/2000 00:09'!
privateRemove: msgID 
	"Remove the entry with the given ID from my Dictionary."
	timeSortedEntries removeAllSuchThat: [:assoc | assoc key = msgID].
	msgDictionary removeKey: msgID ifAbsent: [].
	! !

!IndexFile methodsFor: 'dictionary access' stamp: 'dvf 4/30/2000 00:59'!
remove: msgID 
	"Remove the entry with the given ID from my Dictionary."
	self privateRemove: msgID.
	self logStream nextPutAll: 'remove';
	 cr;
	 print: msgID;
	 cr;
	 close! !


!IndexFile methodsFor: 'read-write' stamp: 'dvf 6/11/2000 01:02'!
readFrom: aStream messageFile: messageFile 
	"Initialize myself from the given text stream. It is assumed that the 
	.index file was written in order of ascending message timestamps, 
	although this method is only less efficient, not incorrect, if this is not 
	the case."
	| sorted lastTime msgID entry |
	msgDictionary _ PluggableDictionary integerDictionary.
	timeSortedEntries _ (SortedCollection new: 1000)
				sortBlock: [:m1 :m2 | m1 value time <= m2 value time].
	sorted _ true.
	lastTime _ nil.
	[aStream atEnd]
		whileFalse: 
			[msgID _ MailDB readIntegerLineFrom: aStream.
			entry _ IndexFileEntry
						readFrom: aStream
						messageFile: messageFile
						msgID: msgID.
			msgDictionary at: msgID put: entry.
			timeSortedEntries addLast: (Association key: msgID value: entry).
			(sorted & lastTime notNil and: [lastTime > entry time])
				ifTrue: [sorted _ false].
			lastTime _ entry time].
	sorted ifFalse: [timeSortedEntries reSort]! !

!IndexFile methodsFor: 'read-write' stamp: 'BEO 6/25/2000 15:36'!
save
	| dir shortName |
	super save. 
	self logStream close.
	shortName _ FileDirectory localNameFor: filename.
	dir _ FileDirectory forFileName: filename.
	dir deleteFileNamed: shortName , '.log' ifAbsent: []! !

!IndexFile methodsFor: 'read-write'!
writeOn: aStream
	"Write my index entries to the given text stream in human-readable form."
	"Note: For efficiency, this is done in order of increasing message timestamps, to save the cost of sorting when we read it back in. It is assumed that timeSortedEntries should contains exactly the same message ID's as msgDictionary."

	timeSortedEntries do:
		[: assoc |
		 (assoc key) printOn: aStream.		"message ID"
		 aStream cr.
		 (assoc value) writeOn: aStream].	"index entry"! !

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

IndexFile class
	instanceVariableNames: ''!

!IndexFile class methodsFor: 'instance creation'!
openOn: fileName messageFile: messageFile
	"Answer a new instance of me for the given message file, backed by the file with the given name."

	^(super new) openOn: fileName messageFile: messageFile! !
Object subclass: #IndexFileEntry
	instanceVariableNames: 'messageFile msgID location textLength time from to cc subject tocLineCache '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!IndexFileEntry commentStamp: '<historical>' prior: 0!
An IndexFileEntry contains enough information to present a table-of-contents entry for the message and to support simple filtering based on a subset of the mail header information. The IndexFile maps unique message ID's to IndexFileEntries.

!


!IndexFileEntry methodsFor: 'access'!
cc

	^cc! !

!IndexFileEntry methodsFor: 'access'!
cc: aString

	cc _ aString.! !

!IndexFileEntry methodsFor: 'access'!
date
	"Answer a date string for this index entry."

	^Date fromDays: (time + (Date newDay: 1 year: 1980) asSeconds) // 86400! !

!IndexFileEntry methodsFor: 'access'!
from

	^from! !

!IndexFileEntry methodsFor: 'access'!
from: aString

	from _ aString.! !

!IndexFileEntry methodsFor: 'access' stamp: 'dvf 5/13/2000 00:51'!
likelyEqual: otherIndexFileEntry
	"return true if the two toc entries seem to represent the same message"
	^(self textLength = otherIndexFileEntry textLength and: [self subject = otherIndexFileEntry subject]) and: [self from = otherIndexFileEntry from]! !

!IndexFileEntry methodsFor: 'access'!
location

	^location! !

!IndexFileEntry methodsFor: 'access'!
location: anInteger

	location _ anInteger.! !

!IndexFileEntry methodsFor: 'access'!
messageFile

	^messageFile! !

!IndexFileEntry methodsFor: 'access'!
messageFile: aMessageFile

	messageFile _ aMessageFile.! !

!IndexFileEntry methodsFor: 'access'!
msgID

	^msgID! !

!IndexFileEntry methodsFor: 'access'!
msgID: anID

	msgID _ anID.! !

!IndexFileEntry methodsFor: 'access'!
subject

	^subject! !

!IndexFileEntry methodsFor: 'access'!
subject: aString

	subject _ aString.! !

!IndexFileEntry methodsFor: 'access'!
textLength

	^textLength! !

!IndexFileEntry methodsFor: 'access'!
textLength: anInteger

	textLength _ anInteger.! !

!IndexFileEntry methodsFor: 'access'!
time

	^time! !

!IndexFileEntry methodsFor: 'access'!
time: anInteger

	time _ anInteger.! !

!IndexFileEntry methodsFor: 'access'!
to

	^to! !

!IndexFileEntry methodsFor: 'access'!
to: aString

	to _ aString.! !


!IndexFileEntry methodsFor: 'printing' stamp: 'bf 3/9/2000 16:09'!
computeTOCString
	"Answer a string for the table of contents."
	"IndexFileEntry allInstancesDo: [: e | e flushTOCCache]"

	| fromFieldSize s |
	fromFieldSize _ 18.
	s _ WriteStream on: (String new: 200).
	s nextPutAll: self dateString.
	[s position < 9] whileTrue: [s space].
	s nextPutAll: (self fromStringLimit: fromFieldSize).
	[s position <= (9 + fromFieldSize + 2)] whileTrue: [s space].
	s nextPutAll: subject decodeMimeHeader.
	^ s contents
! !

!IndexFileEntry methodsFor: 'printing' stamp: 'sbw 1/11/2001 21:11'!
computeTOCStringAsColumns
	"Answer a string for the table of contents."
	"IndexFileEntry allInstancesDo: [: e | e flushTOCCache]"
	| fromFieldSize array attachFlag |
	fromFieldSize _ 18.
	attachFlag _ self getMessage body isMultipart.
	array _ Array new: 5.
	array at: 1 put: self dateString.
	array
		at: 2
		put: (self fromStringLimit: fromFieldSize).
	array at: 3 put: subject decodeMimeHeader.
	array at: 4 put: self textLength asStringWithCommas.
	array at: 5 put: attachFlag.
	^ array! !

!IndexFileEntry methodsFor: 'printing'!
dateString
	"Answer a date string for this index entry."

	^self date printFormat: #(2 1 3 47 1 2)! !

!IndexFileEntry methodsFor: 'printing'!
flushTOCCache
	"Flush my cached table-of-contents entry string."
	"IndexFileEntry allInstancesDo: [: e | e flushTOCCache]"

	tocLineCache _ nil.! !

!IndexFileEntry methodsFor: 'printing' stamp: 'bf 3/9/2000 16:05'!
fromStringLimit: limit
	"Answer a cleaned up 'from' field for the table of contents."

	| editedFrom s ch i |
	editedFrom _ WriteStream on: (String new: limit + 1).
	s _ ReadStream on: from decodeMimeHeader.
	s skipSeparators.
	('"<' includes: s peek) ifTrue: [s next].
	((i _ from indexOf: $() > 0) ifTrue: [s position: i].
	[s atEnd] whileFalse: [
		ch _ s next.
		(('@<>)$"' includes: ch) or: [editedFrom position >= limit])
			ifTrue: [^editedFrom contents]
			ifFalse: [editedFrom nextPut: ch]].
	^editedFrom contents
! !

!IndexFileEntry methodsFor: 'printing'!
printOn: aStream

	aStream nextPutAll: self dateString; cr.
	aStream nextPutAll: from; cr.
	aStream nextPutAll: to; cr.
	aStream nextPutAll: cc; cr.
	aStream nextPutAll: subject; cr.
	aStream nextPut: $(; nextPutAll: location printString; space.
	aStream nextPutAll: textLength printString; nextPut: $).
	aStream cr.! !

!IndexFileEntry methodsFor: 'printing'!
tocString
	"Answer a string for the table of contents."

	(tocLineCache isNil) ifTrue:
		[tocLineCache _ self computeTOCString].
	^tocLineCache! !

!IndexFileEntry methodsFor: 'printing' stamp: 'sbw 12/25/2000 20:47'!
tocStringAsColumns
	"Answer a string for the table of contents."
	^self computeTOCStringAsColumns! !


!IndexFileEntry methodsFor: 'read-write'!
readFrom: aStream
	"Initialize myself from the given text stream."

	location _ MailDB readIntegerLineFrom: aStream.
	textLength _ MailDB readIntegerLineFrom: aStream.
	time _ MailDB readIntegerLineFrom: aStream.
	from _ MailDB readStringLineFrom: aStream.
	to _ MailDB readStringLineFrom: aStream.
	cc _ MailDB readStringLineFrom: aStream.
	subject _ MailDB readStringLineFrom: aStream.! !

!IndexFileEntry methodsFor: 'read-write' stamp: 'ls 10/6/1998 13:22'!
writeOn: aStream
	"Write a human-readable representation of myself on the given text stream."

	aStream
		nextPutAll: location printString; cr;
		nextPutAll: textLength printString; cr;
		nextPutAll: time printString; cr;
		nextPutAll: from; cr;
		nextPutAll: to; cr;
		nextPutAll: cc; cr;
		nextPutAll: subject; cr.
! !


!IndexFileEntry methodsFor: 'filtering support'!
ccHas: stringOrList

	^ self field: cc has: stringOrList! !

!IndexFileEntry methodsFor: 'filtering support' stamp: 'jm 8/14/1998 13:39'!
field: field has: stringOrList
	"Return true if either the given field contains the argument string or, if the argument is a collection, return true if the given field contains any of the strings in that collection."

	| s |
	(stringOrList isKindOf: String) ifTrue: [
		^ field includesSubstring: stringOrList caseSensitive: false
	] ifFalse: [
		1 to: stringOrList size do: [ :i |
			s _ stringOrList at: i.
			s isNumber ifTrue: [s _ s printString].
			(field includesSubstring: s caseSensitive: false) ifTrue: [^ true].
		].
		^ false
	].! !

!IndexFileEntry methodsFor: 'filtering support'!
fromHas: stringOrList

	^ self field: from has: stringOrList! !

!IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:25'!
getMessage
	"Answer the MailMessage for this index file entry."
	^ MailMessage from: (self rawText)! !

!IndexFileEntry methodsFor: 'filtering support'!
participantHas: stringOrList

	^ (self field: from has: stringOrList) or:
	   [(self field: self to has: stringOrList) or:
	   [self field: self cc has: stringOrList]]! !

!IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:25'!
rawText
	"Answer the unparsed text for this entry."
	^ messageFile
			getMessage: msgID
			at: location
			textLength: textLength! !

!IndexFileEntry methodsFor: 'filtering support'!
subjectHas: stringOrList

	^ self field: subject has: stringOrList! !

!IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:11'!
text
	^self getMessage text! !

!IndexFileEntry methodsFor: 'filtering support' stamp: 'dvf 5/13/2000 02:11'!
textHas: stringOrList 
	^ self field: self text has: stringOrList! !

!IndexFileEntry methodsFor: 'filtering support'!
toHas: stringOrList

	^ self field: to has: stringOrList! !

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

IndexFileEntry class
	instanceVariableNames: ''!

!IndexFileEntry class methodsFor: 'instance creation'!
message: aMailMessage location: location messageFile: aMessageFile msgID: msgID
	"Answer a new instance of me for the given message and message file location."

	^self new
		messageFile: aMessageFile;
		msgID: msgID;
		location: location;
		textLength: aMailMessage text size;
		time: aMailMessage time;
		from: aMailMessage from;
		to: aMailMessage to;
		cc: aMailMessage cc;
		subject: aMailMessage subject! !

!IndexFileEntry class methodsFor: 'instance creation'!
readFrom: aStream messageFile: aMessageFile msgID: msgID
	"Answer a new instance of me initialized from the given text stream."

	^(self new readFrom: aStream)
		messageFile: aMessageFile;
		msgID: msgID! !
PasteUpMorph subclass: #IndexTabs
	instanceVariableNames: 'highlightColor regularColor basicHeight basicWidth verticalPadding fixedWidth '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!IndexTabs commentStamp: '<historical>' prior: 0!
Used in conjunction wi[th a TabbedPalette -- each TabbedPalette has one.  Each submorph of an IndexTabs is a TabMorph.  When you click on one of the tabs, a corresponding action is taken -- sometimes, the existing palette gets replaced by the new one, other times, the tab results in some selector being invoked; in any case, tab highlighting takes place accordingly.!


!IndexTabs methodsFor: 'initialization' stamp: 'sw 8/16/2000 17:40'!
initialize
	"Initialize the receiver.  Make sure it is not open to drag and drop"

	super initialize.
	padding _ 10.
	verticalPadding _ 4.
	basicHeight _ 14.
	basicWidth _ 200.
	color _ Color r: 0.0 g: 0.6 b: 0.6.
	borderWidth _ 0.
	self enableDragNDrop: false! !


!IndexTabs methodsFor: 'tabs' stamp: 'sw 7/3/1998 11:44'!
addTab: aTab
	self addMorphBack: aTab.
	self laySubpartsOutInOneRow! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 1/11/2000 11:15'!
addTabFor: aReferent font: aFont
	|  aTab |
	aTab _ ReferenceMorph forMorph: aReferent font: aFont.
	self addMorphBack: aTab.
	aTab highlightColor: self highlightColor; regularColor: self regularColor.
	aTab unHighlight.
	self laySubpartsOutInOneRow; layoutChanged.
	^ aTab! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 12/2/1998 17:53'!
addTabForBook: aBook
	|  aTab |
	aTab _ ReferenceMorph forMorph: aBook.
	self addMorphBack: aTab.
	aTab highlightColor: self highlightColor; regularColor: self regularColor.
	aTab unHighlight.
	self laySubpartsOutInOneRow; layoutChanged.
	^ aTab! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 1/13/2000 15:19'!
ownerChanged
	fixedWidth ifNil: [self laySubpartsOutInOneRow]! !

!IndexTabs methodsFor: 'tabs' stamp: 'sw 1/11/2000 10:17'!
tabMorphs
	"Presently all the submorphs are ReferenceMorphs, but this still supports an earlier design where spacers are interleaved, and where the old TabMorph class was used"

	^ submorphs select: [:m | (m isKindOf: TabMorph) or: [m isKindOf: ReferenceMorph]]! !


!IndexTabs methodsFor: 'layout' stamp: 'sw 7/3/1998 18:37'!
basicHeight
	^ basicHeight! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 11/30/1998 15:38'!
basicWidth
	basicWidth ifNil: [basicWidth _ owner ifNotNil: [owner width] ifNil: [100]].
	^ basicWidth! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 10/15/1998 17:12'!
basicWidth: w
	basicWidth _ w! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/13/2000 15:18'!
fixedWidth: aWidth
	fixedWidth _ aWidth! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/19/2000 13:57'!
laySubpartsOutInOneRow
	| aPosition neededHeight widthToUse mid |
	fixedWidth ifNotNil: [self error: 'incompatibility in IndexTabs'].
	verticalPadding ifNil: [verticalPadding _ 4].  "for benefit of old structures"
	aPosition _ self topLeft.
	neededHeight _ self basicHeight.
	submorphs do:
		[:aMorph |
			aMorph position: (aPosition + (padding @ 0)).
			aPosition _ aMorph topRight.
			neededHeight _ neededHeight max: aMorph height].
	neededHeight _ neededHeight + (verticalPadding * 2).
	mid _ self top + (neededHeight // 2).
	submorphs do:
		[:aMorph |
			aMorph top: (mid - (aMorph height // 2))].
	widthToUse _ self widthImposedByOwner max: self requiredWidth.
	self extent: (((aPosition x + padding - self left) max: widthToUse) @ neededHeight)! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 4/27/2000 13:30'!
repelsMorph: aMorph event: evt
	^ false! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 12/7/1998 17:29'!
requiredWidth
	submorphs size = 0
		ifTrue:
			[^ self basicWidth].
	^ (submorphs detectSum: [:m | m width]) + (submorphs size * padding)! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 1/13/2000 15:50'!
rowsNoWiderThan: maxWidth
	| aPosition neededHeight |
	self fixedWidth: maxWidth.
	verticalPadding ifNil: [verticalPadding _ 4].  "for benefit of old structures"
	aPosition _ self topLeft.
	neededHeight _ self basicHeight.
	submorphs do:
		[:aMorph |
			aMorph position: (aPosition + (padding @ 0)).
			(aMorph right > (self left + maxWidth)) ifTrue:
				[aPosition _ self left @ (aPosition y + neededHeight).
				aMorph position: aPosition + (padding @ 0).
				neededHeight _ self basicHeight].
			aPosition _ aMorph topRight.
			neededHeight _ neededHeight max: aMorph height].
	self extent: (maxWidth @ ((aPosition y + neededHeight) - self top))! !

!IndexTabs methodsFor: 'layout' stamp: 'sw 12/7/1998 19:50'!
widthImposedByOwner
	((owner == nil or: [owner isWorldOrHandMorph]) or: [owner submorphs size < 2])
		ifTrue:
			[^ self basicWidth].
	^ owner submorphs second width! !


!IndexTabs methodsFor: 'selection' stamp: 'sw 7/3/1998 18:43'!
selectTab: aTab
	| aWorld |
	(aWorld _ self world) ifNotNil: [aWorld abandonAllHalos].  "nil can happen at init time"
	self highlightTab: aTab.
! !


!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 14:56'!
highlightColor
	^ highlightColor ifNil: [Color yellow]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 13:29'!
highlightColor: aColor
	highlightColor _ aColor! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 13:43'!
highlightColor: color1 regularColor: color2
	"Apply these colors to all of the receiver's tabs"
	highlightColor _ color1.
	regularColor _ color2.
	self tabMorphs do:
		[:m | m highlightColor: color1.  m regularColor: color2]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 11/30/1998 12:43'!
highlightTab: aTab
	self tabMorphs do:
		[:m | m == aTab
			ifTrue: [m highlight]
			ifFalse: [m unHighlight]]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 11/30/1998 12:44'!
highlightTabFor: aBook
	| theOne |
	self tabMorphs do: [:m |
		(m morphToInstall == aBook)
				ifTrue: [m highlight.  theOne _ m]
				ifFalse: [m unHighlight]].
	^ theOne
! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 12/2/1998 12:30'!
highlightedTab
	^ self tabMorphs detect: [:m | m isHighlighted] ifNone: [nil]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 14:47'!
regularColor
	^ regularColor ifNil: [Color r: 0.4 g: 0.2 b: 0.6]! !

!IndexTabs methodsFor: 'highlighting' stamp: 'sw 7/2/1998 13:29'!
regularColor: aColor
	regularColor _ aColor! !


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

IndexTabs class
	instanceVariableNames: ''!

!IndexTabs class methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 15:16'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'tabs'! !
DisplayObject subclass: #InfiniteForm
	instanceVariableNames: 'patternForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!InfiniteForm commentStamp: '<historical>' prior: 0!
I represent a Form obtained by replicating a pattern form indefinitely in all directions.!


!InfiniteForm methodsFor: 'accessing'!
asForm
	^ patternForm! !

!InfiniteForm methodsFor: 'accessing' stamp: 'di 9/2/97 20:21'!
dominantColor
	^ patternForm dominantColor! !

!InfiniteForm methodsFor: 'accessing'!
offset 
	"Refer to the comment in DisplayObject|offset."

	^0 @ 0! !


!InfiniteForm methodsFor: 'displaying' stamp: 'sw 2/16/98 03:42'!
colorForInsets
	^ Color transparent! !

!InfiniteForm methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:09'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the real display message, but it doesn't get used until the new
	display protocol is installed."
	| targetBox patternBox bb |
	(patternForm isKindOf: Form) ifFalse:
		[^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm].

	"Do it iteratively"
	targetBox _ aDisplayMedium boundingBox intersect: clipRectangle.
	patternBox _ patternForm boundingBox.
	bb _ BitBlt current destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm
		combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0
		extent: patternBox extent clipRect: clipRectangle.
	bb colorMap:
		(patternForm colormapIfNeededForDepth: aDisplayMedium depth).
	(targetBox left truncateTo: patternBox width)
		to: targetBox right - 1 by: patternBox width do:
		[:x |
		(targetBox top truncateTo: patternBox height)
			to: targetBox bottom - 1 by: patternBox height do:
			[:y |
			bb destOrigin: x@y; copyBits]]! !

!InfiniteForm methodsFor: 'displaying' stamp: 'di 8/25/2000 00:26'!
displayOnPort: aPort at: offset

	| targetBox patternBox savedMap top left |
	(patternForm isKindOf: Form) ifFalse: [
		"patternForm is a Pattern or Color; just use it as a mask for BitBlt"
		^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over].

	"do it iteratively"
	targetBox _ aPort clipRect.
	patternBox _ patternForm boundingBox.
	savedMap _ aPort colorMap.
	aPort sourceForm: patternForm;
		fillColor: nil;
		combinationRule: Form paint;
		sourceRect: (0@0 extent: patternBox extent);
		colorMap: (patternForm colormapIfNeededForDepth: aPort destForm depth).
	top _ (targetBox top truncateTo: patternBox height) "- (offset y \\ patternBox height)".
	left _  (targetBox left truncateTo: patternBox width) "- (offset x \\ patternBox width)".
	left to: (targetBox right - 1) by: patternBox width do:
		[:x | top to: (targetBox bottom - 1) by: patternBox height do:
			[:y | aPort destOrigin: x@y; copyBits]].
	aPort colorMap: savedMap.
! !


!InfiniteForm methodsFor: 'display box access'!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! !


!InfiniteForm methodsFor: 'private'!
form: aForm

	patternForm _ aForm! !


!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'!
bitPatternForDepth: suspectedDepth
	^ patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
direction
	^patternForm width @ 0! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
form
	"Bitmap fills respond to #form"
	^patternForm! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isBitmapFill
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isGradientFill
	^false! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:59'!
isOrientedFill
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'!
isSolidFill
	^false! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:55'!
isTiled
	"Return true if the receiver should be drawn as a tiled pattern"
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 9/2/1999 14:32'!
isTranslucent
	"Return true since the bitmap may be translucent and we don't really want to check"
	^true! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:57'!
normal
	^0 @ patternForm height! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
origin
	^0@0! !

!InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'!
origin: aPoint
	"Ignored"
! !


!InfiniteForm methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 10:50'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"

	"prevents a walkback when control menu is built for morph with me as color"! !

!InfiniteForm methodsFor: 'as yet unclassified' stamp: 'RAA 8/28/2000 10:27'!
encodeForRemoteCanvas

	^patternForm encodeForRemoteCanvas
! !

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

InfiniteForm class
	instanceVariableNames: ''!

!InfiniteForm class methodsFor: 'instance creation'!
with: aForm 
	"Answer an instance of me whose pattern form is the argument, aForm."

	^self new form: aForm! !
InterpreterPlugin subclass: #InflatePlugin
	instanceVariableNames: 'zipCollection zipReadLimit zipPosition zipState zipBitBuf zipBitPos zipSource zipSourcePos zipSourceLimit zipLitTable zipDistTable zipCollectionSize zipLitTableSize zipDistTableSize '
	classVariableNames: 'MaxBits StateNoMoreData '
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!InflatePlugin commentStamp: '<historical>' prior: 0!
This plugin implements the one crucial function for efficiently decompressing streams.!


!InflatePlugin methodsFor: 'primitives' stamp: 'ar 12/22/1999 00:04'!
primitiveInflateDecompressBlock
	"Primitive. Inflate a single block."
	| oop rcvr |
	self export: true.
	interpreterProxy methodArgumentCount = 2 ifFalse:[^interpreterProxy primitiveFail].
	"distance table"
	oop _ interpreterProxy stackObjectValue: 0.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipDistTable _ interpreterProxy firstIndexableField: oop.
	zipDistTableSize _ interpreterProxy slotSizeOf: oop.

	"literal table"
	oop _ interpreterProxy stackObjectValue: 1.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isWords: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipLitTable _ interpreterProxy firstIndexableField: oop.
	zipLitTableSize _ interpreterProxy slotSizeOf: oop.


	"Receiver (InflateStream)"
	rcvr _ interpreterProxy stackObjectValue: 2.
	interpreterProxy failed ifTrue:[^nil].
	(interpreterProxy isPointers: rcvr)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: rcvr) < 9
		ifTrue:[^interpreterProxy primitiveFail].

	"All the integer instvars"
	zipReadLimit _ interpreterProxy fetchInteger: 2 ofObject: rcvr.
	zipState _ interpreterProxy fetchInteger: 3 ofObject: rcvr.
	zipBitBuf _ interpreterProxy fetchInteger: 4 ofObject: rcvr.
	zipBitPos _ interpreterProxy fetchInteger: 5 ofObject: rcvr.
	zipSourcePos _ interpreterProxy fetchInteger: 7 ofObject: rcvr.
	zipSourceLimit _ interpreterProxy fetchInteger: 8 ofObject: rcvr.
	interpreterProxy failed ifTrue:[^nil].
	zipReadLimit _ zipReadLimit - 1.
	zipSourcePos _ zipSourcePos - 1.
	zipSourceLimit _ zipSourceLimit - 1.

	"collection"
	oop _ interpreterProxy fetchPointer: 0 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipCollection _ interpreterProxy firstIndexableField: oop.
	zipCollectionSize _ interpreterProxy byteSizeOf: oop.

	"source"
	oop _ interpreterProxy fetchPointer: 6 ofObject: rcvr.
	(interpreterProxy isIntegerObject: oop)
		ifTrue:[^interpreterProxy primitiveFail].
	(interpreterProxy isBytes: oop)
		ifFalse:[^interpreterProxy primitiveFail].
	zipSource _ interpreterProxy firstIndexableField: oop.

	"do the primitive"
	self zipDecompressBlock.
	interpreterProxy failed ifFalse:[
		"store modified values back"
		interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
		interpreterProxy storeInteger: 3 ofObject: rcvr withValue: zipState.
		interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
		interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
		interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipSourcePos + 1.
		interpreterProxy pop: 2.
	].! !


!InflatePlugin methodsFor: 'inflating' stamp: 'ar 12/22/1999 15:14'!
zipDecodeValueFrom: table size: tableSize
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value index |
	self var: #table declareC:'unsigned int *table'.
	bitsNeeded _ (table at: 0) bitShift: -24.	"Initial bits needed"
	bitsNeeded > MaxBits ifTrue:[interpreterProxy primitiveFail. ^0].
	tableIndex _ 2.							"First real table"
	[true] whileTrue:[
		bits _ self zipNextBits: bitsNeeded.		"Get bits"
		index _ tableIndex + bits - 1.
		index >= tableSize ifTrue:[interpreterProxy primitiveFail. ^0].
		value _ table at: index.					"Lookup entry in table"
		(value bitAnd: 16r3F000000) = 0 ifTrue:[^value]. "Check if it is a leaf node"
		"Fetch sub table"
		tableIndex _ value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
		bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
		bitsNeeded > MaxBits ifTrue:[interpreterProxy primitiveFail. ^0]].
	^0! !

!InflatePlugin methodsFor: 'inflating' stamp: 'ar 12/22/1999 00:04'!
zipDecompressBlock
	| value extra length distance oldPos oldBits oldBitPos dstPos srcPos max |
	self inline: false.
	max _ zipCollectionSize - 1.
	[zipReadLimit < max and:[zipSourcePos <= zipSourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits _ zipBitBuf.
		oldBitPos _ zipBitPos.
		oldPos _ zipSourcePos.
		value _ self zipDecodeValueFrom: zipLitTable size: zipLitTableSize.
		value < 256 ifTrue:[ "A literal"
			zipCollection at: (zipReadLimit _ zipReadLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				zipState _ zipState bitAnd: StateNoMoreData.
				^0].
			"Compute the actual length value (including possible extra bits)"
			extra _ (value bitShift: -16) - 1.
			length _ value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[length _ length + (self zipNextBits: extra)].
			"Compute the distance value"
			value _ self zipDecodeValueFrom: zipDistTable size: zipDistTableSize.
			extra _ (value bitShift: -16).
			distance _ value bitAnd: 16rFFFF.
			extra > 0 ifTrue:[distance _ distance + (self zipNextBits: extra)].
			(zipReadLimit + length >= max) ifTrue:[
				zipBitBuf _ oldBits.
				zipBitPos _ oldBitPos.
				zipSourcePos _ oldPos.
				^0].
			dstPos _ zipReadLimit.
			srcPos _ zipReadLimit - distance.
			1 to: length do:[:i|
				zipCollection at: dstPos+i put: (zipCollection at: srcPos+i)].
			zipReadLimit _ zipReadLimit + length.
		].
	].! !

!InflatePlugin methodsFor: 'inflating' stamp: 'ar 12/21/1999 23:06'!
zipNextBits: n
	| bits byte |
	self inline: true.
	[zipBitPos < n] whileTrue:[
		byte _ zipSource at: (zipSourcePos _ zipSourcePos + 1).
		zipBitBuf _ zipBitBuf + (byte << zipBitPos).
		zipBitPos _ zipBitPos + 8].
	bits _ zipBitBuf bitAnd: (1 << n)-1.
	zipBitBuf _ zipBitBuf >> n.
	zipBitPos _ zipBitPos - n.
	^bits! !

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

InflatePlugin class
	instanceVariableNames: ''!

!InflatePlugin class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:02'!
initialize
	"InflatePlugin initialize"
	MaxBits _ 16.
	StateNoMoreData _ 1.! !


!InflatePlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:31'!
declareCVarsIn: cg
	cg var: #zipCollection type: #'unsigned char*'.
	cg var: #zipSource type: #'unsigned char*'.
	cg var: #zipLitTable type: #'unsigned int*'.
	cg var: #zipDistTable type: #'unsigned int*'! !

!InflatePlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 23:58'!
moduleName
	^'ZipPlugin'! !
ReadStream subclass: #InflateStream
	instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream '
	classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData '
	poolDictionaries: ''
	category: 'System-Compression'!
!InflateStream commentStamp: '<historical>' prior: 0!
This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in

[LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343.

[RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3"

For more information see the above mentioned RFC 1951 which can for instance be found at

	http://www.leo.org/pub/comp/doc/standards/rfc/index.html

Huffman Tree Implementation Notes:
===========================================
The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:):

	table _ initialTable.
	bitsNeeded _ high 8 bits of (table at: 1).		"Determine initial bits"
	table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table"
	[bits _ fetch next bitsNeeded bits.			"Grab the bits"
	value _ table at: bits.						"Lookup the value"
	value has high 8 bit set] whileTrue:[		"Check if it's leaf"
		table _ initialTable + (low 16 bits of value).	"No - compute new sub table start"
		bitsNeeded _ high 8 bit of value].		"Compute additional number of bits needed"
	^value
!


!InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:45'!
on: aCollectionOrStream
	aCollectionOrStream isStream 
		ifTrue:[	sourceStream _ aCollectionOrStream.
				self getFirstBuffer]
		ifFalse:[source _ aCollectionOrStream].
	^self on: source from: 1 to: source size.! !

!InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:35'!
on: aCollection from: firstIndex to: lastIndex
	bitBuf _ bitPos _ 0.
	"The decompression buffer has a size of at 64k,
	since we may have distances up to 32k back and
	repetitions of at most 32k length forward"
	collection _ aCollection species new: 1 << 16.
	readLimit _ 0. "Not yet initialized"
	position _ 0.
	source _ aCollection.
	sourceLimit _ lastIndex.
	sourcePos _ firstIndex-1.
	state _ StateNewBlock.! !

!InflateStream methodsFor: 'initialize' stamp: 'ar 12/3/1998 16:32'!
reset
	"Position zero - nothing decoded yet"
	position _ readLimit _ 0.
	sourcePos _ 0.
	bitBuf _ bitPos _ 0.
	state _ 0.! !


!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'!
close
	sourceStream ifNotNil:[sourceStream close].! !

!InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'!
contents

	^ self upToEnd! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'!
next
	"Answer the next decompressed object in the Stream represented by the
	receiver."

	<primitive: 65>
	position >= readLimit
		ifTrue: [^self pastEndRead]
		ifFalse: [^collection at: (position _ position + 1)]! !

!InflateStream methodsFor: 'accessing' stamp: 'RAA 11/5/2000 11:12'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for simplicity"
	| newArray |

	"try to do it the fast way"
	position + anInteger < readLimit ifTrue: [
		newArray _ collection copyFrom: position + 1 to: position + anInteger.
		position _ position + anInteger.
		^newArray
	].

	"oh, well..."
	newArray _ collection species new: anInteger.
	1 to: anInteger do: [:index | newArray at: index put: self next].
	^newArray! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 16:06'!
next: n into: buffer startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| c numRead count |
	numRead _ 0.
	["Force decompression if necessary"
	(c _ self next) == nil 
		ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1].
	"Store the first value which provoked decompression"
	buffer at: startIndex + numRead put: c.
	numRead _ numRead + 1.
	"After collection has been filled copy as many objects as possible"
	count _ (readLimit - position) min: (n - numRead).
	buffer 
		replaceFrom: startIndex + numRead 
		to: startIndex + numRead + count - 1 
		with: collection 
		startingAt: position+1.
	position _ position + count.
	numRead _ numRead + count.
	numRead = n] whileFalse.
	^buffer! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'!
size
	"This is a compressed stream - we don't know the size beforehand"
	^self shouldNotImplement! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'!
sourceLimit
	^sourceLimit! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'!
sourcePosition
	^sourcePos! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'!
sourceStream
	^sourceStream! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'!
upTo: anObject 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of anObject in the receiver. If 
	anObject is not in the collection, answer the entire rest of the receiver."
	| newStream element |
	newStream _ WriteStream on: (collection species new: 100).
	[self atEnd or: [(element _ self next) = anObject]]
		whileFalse: [newStream nextPut: element].
	^newStream contents! !

!InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 02:04'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream buffer |
	buffer _ collection species new: 1000.
	newStream _ WriteStream on: (collection species new: 100).
	[self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)].
	^ newStream contents! !


!InflateStream methodsFor: 'testing' stamp: 'ar 12/27/1999 13:43'!
atEnd
	"Note: It is possible that we have a few bits left,
	representing just the EOB marker. To check for
	this we must force decompression of the next
	block if at end of data."
	super atEnd ifFalse:[^false]. "Primitive test"
	(position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true].
	"Force decompression, by calling #next. Since #moveContentsToFront
	will never move data to the beginning of the buffer it is safe to
	skip back the read position afterwards"
	self next == nil ifTrue:[^true].
	position _ position - 1.
	^false! !


!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'!
decodeValueFrom: table
	"Decode the next value in the receiver using the given huffman table."
	| bits bitsNeeded tableIndex value |
	bitsNeeded _ (table at: 1) bitShift: -24.	"Initial bits needed"
	tableIndex _ 2.							"First real table"
	[bits _ self nextSingleBits: bitsNeeded.	"Get bits"
	value _ table at: (tableIndex + bits).		"Lookup entry in table"
	(value bitAnd: 16r3F000000) = 0] 			"Check if it is a non-leaf node"
		whileFalse:["Fetch sub table"
			tableIndex _ value bitAnd: 16rFFFF.	"Table offset in low 16 bit"
			bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit"
			bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']].
	^value! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 3/15/1999 15:38'!
decompressBlock: llTable with: dTable
	"Process the compressed data in the block.
	llTable is the huffman table for literal/length codes
	and dTable is the huffman table for distance codes."
	| value extra length distance oldPos oldBits oldBitPos |
	[readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[
		"Back up stuff if we're running out of space"
		oldBits _ bitBuf.
		oldBitPos _ bitPos.
		oldPos _ sourcePos.
		value _ self decodeValueFrom: llTable.
		value < 256 ifTrue:[ "A literal"
			collection byteAt: (readLimit _ readLimit + 1) put: value.
		] ifFalse:["length/distance or end of block"
			value = 256 ifTrue:["End of block"
				state _ state bitAnd: StateNoMoreData.
				^self].
			"Compute the actual length value (including possible extra bits)"
			extra _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256.
			length _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256.
			extra > 0 ifTrue:[length _ length + (self nextBits: extra)].
			"Compute the distance value"
			value _ self decodeValueFrom: dTable.
			extra _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1.
			distance _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
						1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1.
			extra > 0 ifTrue:[distance _ distance + (self nextBits: extra)].
			(readLimit + length >= collection size) ifTrue:[
				bitBuf _ oldBits.
				bitPos _ oldBitPos.
				sourcePos _ oldPos.
				^self].
			collection 
					replaceFrom: readLimit+1 
					to: readLimit + length + 1 
					with: collection 
					startingAt: readLimit - distance + 1.
			readLimit _ readLimit + length.
		].
	].! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'!
proceedDynamicBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'!
proceedFixedBlock
	self decompressBlock: litTable with: distTable! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'!
proceedStoredBlock
	"Proceed decompressing a stored (e.g., uncompressed) block"
	| length decoded |
	"Literal table must be nil for a stored block"
	litTable == nil ifFalse:[^self error:'Bad state'].
	length _ distTable.
	[length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] 
		whileTrue:[
			collection at: (readLimit _ readLimit + 1) put: 
				(source at: (sourcePos _ sourcePos + 1)).
			length _ length - 1].
	length = 0 ifTrue:[state _ state bitAnd: StateNoMoreData].
	decoded _ length - distTable.
	distTable _ length.
	^decoded! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'!
processDynamicBlock
	| nLit nDist nLen codeLength lengthTable bits |
	nLit _ (self nextBits: 5) + 257.
	nDist _ (self nextBits: 5) + 1.
	nLen _ (self nextBits: 4) + 4.
	codeLength _ Array new: 19.
	codeLength atAllPut: 0.
	1 to: nLen do:[:i|
		bits _ #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i.
		codeLength at: bits+1 put: (self nextBits: 3).
	].
	lengthTable _ self huffmanTableFrom: codeLength mappedBy: nil.
	"RFC 1951: In other words, all code lengths form a single sequence..."
	codeLength _ self decodeDynamicTable: nLit+nDist from: lengthTable.
	litTable _ self 
				huffmanTableFrom: (codeLength copyFrom: 1 to: nLit)
				mappedBy: self literalLengthMap.
	distTable _ self 
				huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size)
				mappedBy: self distanceMap.
	state _ state bitOr: BlockProceedBit.
	self proceedDynamicBlock.! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'!
processFixedBlock
	litTable _ self 
				huffmanTableFrom: FixedLitCodes
				mappedBy: self literalLengthMap.
	distTable _ self 
				huffmanTableFrom: FixedDistCodes
				mappedBy: self distanceMap.
	state _ state bitOr: BlockProceedBit.
	self proceedFixedBlock.! !

!InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'!
processStoredBlock
	| chkSum length |
	"Skip to byte boundary"
	self nextBits: (bitPos bitAnd: 7).
	length _ self nextBits: 16.
	chkSum _ self nextBits: 16.
	(chkSum bitXor: 16rFFFF) = length
		ifFalse:[^self error:'Bad block length'].
	litTable _ nil.
	distTable _ length.
	state _ state bitOr: BlockProceedBit.
	^self proceedStoredBlock! !


!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'!
decompressAll
	"Profile the decompression speed"
	[self atEnd] whileFalse:[
		position _ readLimit.
		self next "Provokes decompression"
	].! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:15'!
getFirstBuffer
	"Get the first source buffer after initialization has been done"
	sourceStream == nil ifTrue:[^self].
	source _ sourceStream next: 1 << 16. "This is more than enough..."
	sourceLimit _ source size.! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'!
getNextBlock
	^self nextBits: 3! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'!
moveContentsToFront
	"Move the decoded contents of the receiver to the front so that we have enough space for decoding more data."
	| delta |
	readLimit > 32768 ifTrue:[
		delta _ readLimit - 32767.
		collection 
			replaceFrom: 1 
			to: collection size - delta + 1 
			with: collection 
			startingAt: delta.
		position _ position - delta + 1.
		readLimit _ readLimit - delta + 1].! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'!
moveSourceToFront
	"Move the encoded contents of the receiver to the front so that we have enough space for decoding more data."
	(sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self].
	sourcePos > 10000 ifTrue:[
		source 
			replaceFrom: 1 
			to: source size - sourcePos
			with: source 
			startingAt: sourcePos + 1.
		source _ sourceStream 
			next: sourcePos 
			into: source 
			startingAt: source size - sourcePos + 1.
		sourcePos _ 0.
		sourceLimit _ source size].! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/27/1999 15:25'!
pastEndRead
	"A client has attempted to read beyond the read limit.
	Check in what state we currently are and perform
	the appropriate action"
	| blockType |
	state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible"
	"Check if we can move decoded data to front"
	self moveContentsToFront.
	"Check if we can fetch more source data"
	self moveSourceToFront.
	state = StateNewBlock ifTrue:[state _ self getNextBlock].
	blockType _ state bitShift: -1.
	self perform: (BlockTypes at: blockType+1).
	^self next! !

!InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'!
profile
	"Profile the decompression speed"
	MessageTally spyOn:[self decompressAll].! !


!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'!
computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits
	"Assign numerical values to all codes.
	Note: The values are stored according to the bit length"
	| offsets values baseOffset codeLength |
	offsets _ Array new: maxBits.
	offsets atAllPut: 0.
	baseOffset _ 1.
	minBits to: maxBits do:[:bits|
		offsets at: bits put: baseOffset.
		baseOffset _ baseOffset + (counts at: bits+1)].
	values _ WordArray new: aCollection size.
	1 to: aCollection size do:[:i|
		codeLength _ aCollection at: i.
		codeLength > 0 ifTrue:[
			baseOffset _ offsets at: codeLength.
			values at: baseOffset put: i-1.
			offsets at: codeLength put: baseOffset + 1]].
	^values! !

!InflateStream methodsFor: 'huffman trees' stamp: 'sma 5/12/2000 10:49'!
createHuffmanTables: values counts: counts from: minBits to: maxBits
	"Create the actual tables"
	| table tableStart tableSize tableEnd 
	valueIndex tableStack numValues deltaBits maxEntries
	lastTable lastTableStart tableIndex lastTableIndex |

	table _ WordArray new: ((4 bitShift: minBits) max: 16).

	"Create the first entry - this is a dummy.
	It gives us information about how many bits to fetch initially."
	table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2"

	"Create the first table from scratch."
	tableStart _ 2. "See above"
	tableSize _ 1 bitShift: minBits.
	tableEnd _ tableStart + tableSize.
	"Store the terminal symbols"
	valueIndex _ (counts at: minBits+1).
	tableIndex _ 0.
	1 to: valueIndex do:[:i|
		table at: tableStart + tableIndex put: (values at: i).
		tableIndex _ self increment: tableIndex bits: minBits].
	"Fill up remaining entries with invalid entries"
	tableStack _ OrderedCollection new: 10. "Should be more than enough"
	tableStack addLast: 
		(Array 
			with: minBits	"Number of bits (e.g., depth) for this table"
			with: tableStart	"Start of table"
			with: tableIndex "Next index in table"
			with: minBits	"Number of delta bits encoded in table"
			with: tableSize - valueIndex "Entries remaining in table").
	"Go to next value index"
	valueIndex _ valueIndex + 1.
	"Walk over remaining bit lengths and create new subtables"
	minBits+1 to: maxBits do:[:bits|
		numValues _ counts at: bits+1.
		[numValues > 0] whileTrue:["Create a new subtable"
			lastTable _ tableStack last.
			lastTableStart _ lastTable at: 2.
			lastTableIndex _ lastTable at: 3.
			deltaBits _ bits - (lastTable at: 1).
			"Make up a table of deltaBits size"
			tableSize _ 1 bitShift: deltaBits.
			tableStart _ tableEnd.
			tableEnd _ tableEnd + tableSize.
			[tableEnd > table size ]
				whileTrue:[table _ self growHuffmanTable: table].
			"Connect to last table"
			self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused"
			table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart.
			lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)).
			lastTable at: 5 put: (lastTable at: 5) - 1.
			self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize"
			"Store terminal values"
			maxEntries _ numValues min: tableSize.
			tableIndex _ 0.
			1 to: maxEntries do:[:i|
				table at: tableStart + tableIndex put: (values at: valueIndex).
				valueIndex _ valueIndex + 1.
				numValues _ numValues - 1.
				tableIndex _ self increment: tableIndex bits: deltaBits].
			"Check if we have filled up the current table completely"
			maxEntries = tableSize ifTrue:[
				"Table has been filled. Back up to the last table with space left."
				[tableStack isEmpty not and:[(tableStack last at: 5) = 0]]
						whileTrue:[tableStack removeLast].
			] ifFalse:[
				"Table not yet filled. Put it back on the stack."
				tableStack addLast:
					(Array
						with: bits		"Nr. of bits in this table"
						with: tableStart	"Start of table"
						with: tableIndex "Index in table"
						with: deltaBits	"delta bits of table"
						with: tableSize - maxEntries "Unused entries in table").
			].
		].
	].
	 ^table copyFrom: 1 to: tableEnd-1! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'!
decodeDynamicTable: nItems from: aHuffmanTable
	"Decode the code length of the literal/length and distance table
	in a block compressed with dynamic huffman trees"
	| values index value repCount theValue |
	values _ Array new: nItems.
	index _ 1.
	theValue _ 0.
	[index <= nItems] whileTrue:[
		value _ self decodeValueFrom: aHuffmanTable.
		value < 16 ifTrue:[
			"Immediate values"
			theValue _ value.
			values at: index put: value.
			index _ index+1.
		] ifFalse:[
			"Repeated values"
			value = 16 ifTrue:[
				"Repeat last value"
				repCount _ (self nextBits: 2) + 3.
			] ifFalse:[
				"Repeat zero value"
				theValue _ 0.
				value = 17 
					ifTrue:[repCount _ (self nextBits: 3) + 3]
					ifFalse:[value = 18 
								ifTrue:[repCount _ (self nextBits: 7) + 11]
								ifFalse:[^self error:'Invalid bits tree value']]].
			0 to: repCount-1 do:[:i| values at: index+i put: theValue].
			index _ index + repCount].
	].
	^values! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'!
distanceMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'!
growHuffmanTable: table
	| newTable |
	newTable _ table species new: table size * 2.
	newTable replaceFrom: 1 to: table size with: table startingAt: 1.
	^newTable! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'!
huffmanTableFrom: aCollection mappedBy: valueMap
	"Create a new huffman table from the given code lengths.
	Map the actual values by valueMap if it is given.
	See the class comment for a documentation of the huffman
	tables used in this decompressor."
	| counts  values table minBits maxBits |
	minBits _ MaxBits + 1.
	maxBits _ 0.
	"Count the occurences of each code length and compute minBits and maxBits"
	counts _ Array new: MaxBits+1.
	counts atAllPut: 0.
	aCollection do:[:length| 
		length > 0 ifTrue:[
			length < minBits ifTrue:[minBits _ length].
			length > maxBits ifTrue:[maxBits _ length].
			counts at: length+1 put: (counts at: length+1)+1]].
	maxBits = 0 ifTrue:[^nil]. "Empty huffman table"

	"Assign numerical values to all codes."
	values _ self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits.

	"Map the values if requested"
	self mapValues: values by: valueMap.

	"Create the actual tables"
	table _ self createHuffmanTables: values counts: counts from: minBits to: maxBits.

	^table! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'!
increment: value bits: nBits
	"Increment a value of nBits length.
	The fast decompressor will do this differently"
	^value+1! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'!
literalLengthMap
	"This is used by the fast decompressor"
	^nil! !

!InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:28'!
mapValues: values by: valueMap
	| oldValue |
	valueMap ifNil:[^values].
	1 to: values size do:[:i|
		oldValue _ values at: i.
		"Note: there may be nil values if not all values are used"
		oldValue isNil
			ifTrue:[^values]
			ifFalse:[values at: i put: (valueMap at: oldValue+1)]].
! !


!InflateStream methodsFor: 'bit access' stamp: 'ar 12/27/1999 13:47'!
bitPosition
	"Return the current bit position of the source"
	sourceStream == nil
		ifTrue:[^sourcePos * 8 + bitPos]
		ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'!
nextBits: n
	| bits |
	[bitPos < n] whileTrue:[
		bitBuf _ bitBuf + (self nextByte bitShift: bitPos).
		bitPos _ bitPos + 8].
	bits _ bitBuf bitAnd: (1 bitShift: n)-1.
	bitBuf _ bitBuf bitShift: 0 - n.
	bitPos _ bitPos - n.
	^bits! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'!
nextByte
	^source byteAt: (sourcePos _ sourcePos + 1)! !

!InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'!
nextSingleBits: n
	| out |
	out _ 0.
	1 to: n do:[:i| out _ (out bitShift: 1) + (self nextBits: 1)].
	^out! !

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

InflateStream class
	instanceVariableNames: ''!

!InflateStream class methodsFor: 'class initialization' stamp: 'ar 12/4/1998 19:12'!
initialize
	"InflateStream initialize"
	MaxBits _ 16.
	StateNewBlock _ 0.
	StateNoMoreData _ 1.
	BlockProceedBit _ 8.
	BlockTypes _ #(	processStoredBlock	"New block in stored format"
					processFixedBlock	"New block with fixed huffman tables"
					processDynamicBlock	"New block with dynamic huffman tables"
					errorBadBlock		"Bad block format"
					proceedStoredBlock	"Continue block in stored format"
					proceedFixedBlock	"Continue block in fixed format"
					proceedDynamicBlock	"Continue block in dynamic format"
					errorBadBlock		"Bad block format").
	"Initialize fixed block values"
	FixedLitCodes _ 	((1 to: 144) collect:[:i| 8]),
					((145 to: 256) collect:[:i| 9]),
					((257 to: 280) collect:[:i| 7]),
					((281 to: 288) collect:[:i| 8]).
	FixedDistCodes _ ((1 to: 32) collect:[:i| 5]).! !
StringMorph subclass: #InfoStringMorph
	instanceVariableNames: 'stepTime block '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!InfoStringMorph commentStamp: '<historical>' prior: 0!
A generalization of the clock morph

Try
	InfoStringMorph new openInWorld
or
	(InfoStringMorph on: [Smalltalk vmParameterAt: 9])
		stepTime: 50;
		openInWorld!


!InfoStringMorph methodsFor: 'initialization' stamp: 'sma 6/1/2000 14:03'!
initialize
	super initialize.
	stepTime _ 1000.
	block _ [Time now]! !


!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:06'!
block
	^ block! !

!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:05'!
block: aBlock
	block _ aBlock! !

!InfoStringMorph methodsFor: 'accessing' stamp: 'sma 6/1/2000 14:06'!
stepTime: anInteger
	stepTime _ anInteger! !


!InfoStringMorph methodsFor: 'stepping' stamp: 'sma 6/1/2000 14:03'!
step
	self contents: block value asString! !

!InfoStringMorph methodsFor: 'stepping' stamp: 'sma 6/1/2000 14:03'!
stepTime
	^ stepTime! !

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

InfoStringMorph class
	instanceVariableNames: ''!

!InfoStringMorph class methodsFor: 'instance creation' stamp: 'sma 6/1/2000 14:07'!
on: aBlock
	^ self new block: aBlock! !
Object subclass: #InputSensor
	instanceVariableNames: ''
	classVariableNames: 'InterruptSemaphore InterruptWatcherProcess '
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!InputSensor commentStamp: '<historical>' prior: 0!
I represent an interface to the user input devices. There is at least one instance of me named Sensor in the system.!


!InputSensor methodsFor: 'keyboard'!
flushKeyboard
	"Remove all characters from the keyboard buffer."

	[self keyboardPressed]
		whileTrue: [self keyboard]! !

!InputSensor methodsFor: 'keyboard' stamp: 'di 10/29/97 20:20'!
kbdTest    "Sensor kbdTest"
	"This test routine will print the unmodified character, its keycode,
	and the OR of all its modifier bits, until the character x is typed"
	| char |
	char _ nil.
	[char = $x] whileFalse: 
		[[self keyboardPressed] whileFalse: [].
		char _ self characterForKeycode: self keyboard.
		(String streamContents: 
			[:s | s nextPut: char; space; print: char asciiValue;
					space; print: self primMouseButtons; nextPutAll: '     '])
			displayAt: 10@10]! !

!InputSensor methodsFor: 'keyboard'!
keyboard
	"Answer the next character from the keyboard."

	^ self characterForKeycode: self primKbdNext! !

!InputSensor methodsFor: 'keyboard'!
keyboardPeek
	"Answer the next character in the keyboard buffer without removing it, or nil if it is empty."

	^ self characterForKeycode: self primKbdPeek! !

!InputSensor methodsFor: 'keyboard'!
keyboardPressed
	"Answer true if keystrokes are available."

	^self primKbdPeek notNil! !


!InputSensor methodsFor: 'modifier keys' stamp: 'di 9/28/1999 08:29'!
anyModifierKeyPressed
	"ignore, however, the shift keys 'cause that's not REALLY a command key"

	^ self primMouseButtons anyMask: 16r70	"cmd | opt | ctrl"! !

!InputSensor methodsFor: 'modifier keys'!
commandKeyPressed
	"Answer whether the command key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 64! !

!InputSensor methodsFor: 'modifier keys'!
controlKeyPressed
	"Answer whether the control key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 16! !

!InputSensor methodsFor: 'modifier keys'!
leftShiftDown
	"Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys."

	^ self primMouseButtons anyMask: 8! !

!InputSensor methodsFor: 'modifier keys' stamp: 'bf 9/22/1999 15:47'!
macOptionKeyPressed
	"Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific."

	Preferences macOptionKeyAllowed ifFalse: [self notify: 'Portability note:
InputSensor>>macOptionKeyPressed is not portable.
Please use InputSensor>>yellowButtonPressed instead!!'].
	^ self primMouseButtons anyMask: 32! !

!InputSensor methodsFor: 'modifier keys' stamp: 'sw 9/21/2000 12:41'!
rawMacOptionKeyPressed
	"Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific.  Clients are discouraged from calling this directly, since it circumvents bert's attempt to eradicate option-key checks"

	^ self primMouseButtons anyMask: 32! !

!InputSensor methodsFor: 'modifier keys' stamp: 'jm 5/21/1998 16:13'!
shiftPressed
	"Answer whether the shift key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 8
! !


!InputSensor methodsFor: 'mouse'!
anyButtonPressed
	"Answer whether a mouse button is being pressed."

	^self buttons > 0! !

!InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:59'!
blueButtonPressed
	"Answer whether only the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac."

	^self buttons = 1! !

!InputSensor methodsFor: 'mouse'!
mousePoint
	"Answer a Point indicating the coordinates of the current mouse location."

	^self primMousePt! !

!InputSensor methodsFor: 'mouse'!
noButtonPressed
	"Answer whether any mouse button is not being pressed."

	^self anyButtonPressed == false! !

!InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:43'!
redButtonPressed
	"Answer true if the red mouse button is being pressed. This is the first mouse button."

	^self buttons = 4! !

!InputSensor methodsFor: 'mouse' stamp: 'bf 11/1/1999 20:12'!
waitButton
	"Wait for the user to press any mouse button and then answer with the 
	current location of the cursor."

	[self anyButtonPressed] whileFalse:
		[(Delay forMilliseconds: 50) wait].
	^self cursorPoint! !

!InputSensor methodsFor: 'mouse' stamp: 'sma 5/28/2000 12:04'!
waitButtonOrKeyboard
	"Wait for the user to press either any mouse button or any key.
	Answer the current cursor location or nil if a keypress occured."

	[self anyButtonPressed] whileFalse:
		[(Delay forMilliseconds: 50) wait.
		self keyboardPressed ifTrue: [^ nil]].
	^ self cursorPoint! !

!InputSensor methodsFor: 'mouse'!
waitClickButton
	"Wait for the user to click (press and then release) any mouse button and 
	then answer with the current location of the cursor."

	self waitButton.
	^self waitNoButton! !

!InputSensor methodsFor: 'mouse' stamp: 'bf 11/1/1999 20:22'!
waitNoButton
	"Wait for the user to release any mouse button and then answer with the 
	current location of the cursor."

	[self anyButtonPressed] whileTrue:
		[(Delay forMilliseconds: 50) wait].
	^self cursorPoint! !

!InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:43'!
yellowButtonPressed
	"Answer whether only the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac."

	^self buttons = 2! !


!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:15'!
currentCursor
	"The current cursor is maintained in class Cursor."

	^ Cursor currentCursor! !

!InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:16'!
currentCursor: newCursor 
	"The current cursor is maintained in class Cursor."

	Cursor currentCursor: newCursor.! !

!InputSensor methodsFor: 'cursor'!
cursorPoint
	"Answer a Point indicating the cursor location."

	^self mousePoint! !

!InputSensor methodsFor: 'cursor'!
cursorPoint: aPoint 
	"Set aPoint to be the current cursor location."

	^self primCursorLocPut: aPoint! !


!InputSensor methodsFor: 'joystick'!
joystickButtons: index

	^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F
	! !

!InputSensor methodsFor: 'joystick'!
joystickOn: index

	^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0
	! !

!InputSensor methodsFor: 'joystick'!
joystickXY: index

	| inputWord x y |
	inputWord _ self primReadJoystick: index.
	x _ (inputWord bitAnd: 16r7FF) - 16r400.
	y _ ((inputWord bitShift: -11) bitAnd: 16r7FF) - 16r400.
	^ x@y
	! !

!InputSensor methodsFor: 'joystick' stamp: 'di 4/13/1999 14:32'!
testJoystick: index
	"Sensor testJoystick: 3"

	| f pt buttons status |
	f _ Form extent: 110@50.
	[Sensor anyButtonPressed] whileFalse: [
		pt _ Sensor joystickXY: index.
		buttons _ Sensor joystickButtons: index.
		status _
'xy: ', pt printString, '
buttons: ', buttons hex.
		f fillWhite.
		status displayOn: f at: 10@10.
		f displayOn: Display at: 10@10.
	].
! !


!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/29/2000 11:23'!
inputProcess
	"For non-event image compatibility"
	^ nil! !

!InputSensor methodsFor: 'user interrupts'!
installInterruptWatcher
	"Initialize the interrupt watcher process. Terminate the old process if any."
	"Sensor installInterruptWatcher"

	InterruptWatcherProcess == nil ifFalse: [InterruptWatcherProcess terminate].
	InterruptSemaphore _ Semaphore new.
	InterruptWatcherProcess _ [self userInterruptWatcher] newProcess.
	InterruptWatcherProcess priority: Processor lowIOPriority.
	InterruptWatcherProcess resume.
	self primInterruptSemaphore: InterruptSemaphore.! !

!InputSensor methodsFor: 'user interrupts' stamp: 'nk 10/28/2000 20:33'!
interruptWatcherProcess
	"Answer my interrupt watcher process, if any"
	^InterruptWatcherProcess! !

!InputSensor methodsFor: 'user interrupts'!
setInterruptKey: anInteger
	"Register the given keycode as the user interrupt key."

	self primSetInterruptKey: anInteger.
! !

!InputSensor methodsFor: 'user interrupts' stamp: 'di 2/4/1999 15:24'!
userInterruptWatcher
	"Wait for user interrupts and open a notifier on the active process when one occurs."

	[true] whileTrue: [
		InterruptSemaphore wait.
		Display deferUpdates: false.
		Smalltalk at: #SoundPlayer ifPresent: [:theClass | theClass shutDown].
		Smalltalk handleUserInterrupt]
! !


!InputSensor methodsFor: 'private'!
buttons

	^ self primMouseButtons bitAnd: 7! !

!InputSensor methodsFor: 'private'!
characterForKeycode: keycode
	"Map the given keycode to a Smalltalk character object. Encoding:
		A keycode is 12 bits:   <4 modifer bits><8 bit ISO character>
		Modifier bits are:       <command><option><control><shift>"

	"NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."

	keycode = nil ifTrue: [ ^nil ].
	keycode class = Character ifTrue: [ ^keycode ].  "to smooth the transition!!"
	^ Character value: (keycode bitAnd: 16rFF)! !

!InputSensor methodsFor: 'private'!
primCursorLocPut: aPoint
	"If the primitive fails, try again with a rounded point."

	<primitive: 91>
	^ self primCursorLocPutAgain: aPoint rounded! !

!InputSensor methodsFor: 'private'!
primCursorLocPutAgain: aPoint
	"Do nothing if primitive is not implemented."

	<primitive: 91>
	^ self! !

!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'!
primInterruptSemaphore: aSemaphore 
	"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."

	<primitive: 134>
	^self primitiveFailed
"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! !

!InputSensor methodsFor: 'private'!
primKbdNext
	<primitive: 108>
	^ nil! !

!InputSensor methodsFor: 'private'!
primKbdPeek
	<primitive: 109>
	^ nil! !

!InputSensor methodsFor: 'private'!
primMouseButtons
	<primitive: 107>
	^ 0! !

!InputSensor methodsFor: 'private'!
primMousePt
	"Primitive. Poll the mouse to find out its position. Return a Point. Fail if
	event-driven tracking is used instead of polling. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 90>
	^ 0@0! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primReadJoystick: index
	"Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick."

	<primitive: 'primitiveReadJoystick' module: 'JoystickTabletPlugin'>
	^ 0

	! !

!InputSensor methodsFor: 'private' stamp: 'ar 7/23/2000 15:38'!
primSetInterruptKey: anInteger
	"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."

	<primitive: 133>
	^self primitiveFailed
"Note: This primitive is obsolete with the new event driven architecture in which EventSensor can handle the interrupts itself. However, for supporting older images running on newer VMs the primitive must still be implemented."! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primTabletGetParameters: cursorIndex
	"Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are:
	1. tablet width, in tablet units
	2. tablet height, in tablet units
	3. number of tablet units per inch
	4. number of cursors (pens, pucks, etc; some tablets have more than one)
	5. this cursor index
	6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen)
	8. and 9. y scale and y offset for scaling tablet coordintes  (e.g., to fit the screen)
	10. number of pressure levels
	11. presure threshold needed close pen tip switch 
	12. number of pen tilt angles"

	<primitive: 'primitiveGetTabletParameters' module: 'JoystickTabletPlugin'>
	^ nil
! !

!InputSensor methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primTabletRead: cursorIndex
	"Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is:
	1. index of the cursor to which this data applies
	2. timestamp of the last state chance for this cursor
	3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0)
	6. and 7. xTilt and yTilt of the cursor; (signed)
	8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser)
	9. cursor buttons
	10. cursor pressure, downward
	11. cursor pressure, tangential
	12. flags"

	<primitive: 'primitiveReadTablet' module: 'JoystickTabletPlugin'>
	self primitiveFailed
! !


!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'!
hasTablet
	"Answer true if there is a pen tablet available on this computer."

	^ (self primTabletGetParameters: 1) notNil
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'!
tabletExtent
	"Answer the full tablet extent in tablet coordinates."

	| params |
	params _ self primTabletGetParameters: 1.
	params ifNil: [^ self error: 'no tablet available'].
	^ (params at: 1)@(params at: 2)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'!
tabletPoint
	"Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates."

	| data |
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ (data at: 3) @ (data at: 4)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'!
tabletPressure
	"Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)"

	| params data |
	params _ self primTabletGetParameters: 1.
	params ifNil: [^ self].
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ (data at: 10) asFloat / ((params at: 10) - 1)
! !

!InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'!
tabletTimestamp
	"Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either."

	| data |
	data _ self primTabletRead: 1.  "state of first/primary pen"
	^ data at: 2
! !


!InputSensor methodsFor: 'initialize' stamp: 'ar 9/26/2000 21:35'!
flushEvents
	"Do nothing"! !

!InputSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 15:06'!
shutDown
	InterruptWatcherProcess == nil ifFalse: [
		InterruptWatcherProcess terminate.
		InterruptWatcherProcess terminate].! !

!InputSensor methodsFor: 'initialize' stamp: 'ar 7/23/2000 00:00'!
startUp
	self installInterruptWatcher.! !


!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:34'!
eventQueue
	^nil! !

!InputSensor methodsFor: 'accessing' stamp: 'ar 10/11/2000 17:35'!
eventQueue: aSharedQueue
! !

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

InputSensor class
	instanceVariableNames: ''!

!InputSensor class methodsFor: 'public'!
default
	"Answer the default system InputSensor, Sensor."

	^ Sensor! !

!InputSensor class methodsFor: 'public' stamp: 'ar 7/23/2000 00:00'!
startUp
	
	self default startUp.! !
StringHolder subclass: #Inspector
	instanceVariableNames: 'object selectionIndex timeOfLastListUpdate selectionUpdateTime '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!
!Inspector commentStamp: '<historical>' prior: 0!
I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.!


!Inspector methodsFor: 'accessing'!
baseFieldList
	"Answer an Array consisting of 'self'
	and the instance variable names of the inspected object."

	^ (Array with: 'self' with: 'all inst vars')
			, object class allInstVarNames! !

!Inspector methodsFor: 'accessing'!
fieldList
	"Answer the base field list plus an abbreviated list of indices."

	object class isVariable ifFalse: [^ self baseFieldList].
	^ self baseFieldList ,
		(object basicSize <= (self i1 + self i2)
			ifTrue: [(1 to: object basicSize)
						collect: [:i | i printString]]
			ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize)
						collect: [:i | i printString]])! !

!Inspector methodsFor: 'accessing'!
i1
	"This is the max index shown before skipping to the 
	last i2 elements of very long arrays"
	^ 100! !

!Inspector methodsFor: 'accessing'!
i2
	"This is the number of elements to show at the end
	of very long arrays"
	^ 10! !

!Inspector methodsFor: 'accessing' stamp: 'sw 5/22/96'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  "

	^ 250 @ 200! !

!Inspector methodsFor: 'accessing'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''! !

!Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:57'!
modelWakeUpIn: aWindow
	| newText |
	self updateListsAndCodeIn: aWindow.
	newText _ self contentsIsString
		ifTrue: [newText _ self selection]
		ifFalse: ["keep it short to reduce time to compute it"
			self selectionPrintString ].
	newText = contents ifFalse:
		[contents _ newText.
		self changed: #contents]! !

!Inspector methodsFor: 'accessing' stamp: 'sw 10/30/1999 23:59'!
noteSelectionIndex: anInteger for: aSymbol
	aSymbol == #fieldList
		ifTrue:
			[selectionIndex _ anInteger]! !

!Inspector methodsFor: 'accessing'!
object
	"Answer the object being inspected by the receiver."

	^object! !

!Inspector methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:52'!
object: anObject 
	"Set anObject to be the object being inspected by the receiver."

	anObject == object
		ifTrue: [self update]
		ifFalse:
			[self inspect: anObject.
			self changed: #inspectObject.
			self changed: #fieldList.
			self changed: #contents]! !

!Inspector methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:37'!
selectedClass
	"Answer the class of the receiver's current selection"

	self selectionUnmodifiable ifTrue: [^ object class].
	^ self selection class! !

!Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:57'!
stepAt: millisecondClockValue in: aWindow
	| newText |

	(Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds"
		ifTrue:
			[self updateListsAndCodeIn: aWindow.
			timeOfLastListUpdate _ millisecondClockValue].

	newText _ self contentsIsString
		ifTrue: [newText _ self selection]
		ifFalse: ["keep it short to reduce time to compute it"
			self selectionPrintString ].
	newText = contents ifFalse:
		[contents _ newText.
		self changed: #contents]! !

!Inspector methodsFor: 'accessing' stamp: 'sma 6/15/2000 16:48'!
stepTimeIn: aSystemWindow
	^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000! !

!Inspector methodsFor: 'accessing' stamp: 'sw 10/20/1999 15:54'!
timeOfLastListUpdate
	^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate _ 0]! !

!Inspector methodsFor: 'accessing' stamp: 'tk 4/10/1998 11:28'!
trash
	"What goes in the bottom pane"
	^ ''! !

!Inspector methodsFor: 'accessing' stamp: 'tk 6/11/1998 22:23'!
trash: newText
	"Don't save it"
	^ true! !

!Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:56'!
update
	"Reshow contents, assuming selected value may have changed."

	selectionIndex = 0
		ifFalse:
			[contents _ self selectionPrintString.
			self changed: #selection.
			self changed: #selectionIndex]! !

!Inspector methodsFor: 'accessing' stamp: 'di 1/13/1999 14:36'!
wantsSteps
	^ true! !


!Inspector methodsFor: 'selecting' stamp: 'tk 4/13/1998 09:19'!
accept: aString

	| result |
	result _ self doItReceiver class evaluatorClass new
				evaluate: (ReadStream on: aString)
				in: self doItContext
				to: self doItReceiver
				notifying: nil	"fix this"
				ifFail:  [^ false].
	result == #failedDoit ifFalse: 
			[contents _ result printString.
			self replaceSelectionValue: result.	"may put contents back"
			self changed: #contents.
			^ true].
	^ false! !

!Inspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:24'!
contentsIsString
	"Hacked so contents empty when deselected and = long printString when item 2"

	^ (selectionIndex = 2) | (selectionIndex = 0)! !

!Inspector methodsFor: 'selecting' stamp: 'tk 4/13/1998 09:23'!
replaceSelectionValue: anObject 
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. The value of the selected variable is set to the value, 
	anObject."
	| basicIndex si |
	selectionIndex <= 2 ifTrue: [
		self toggleIndex: (si _ selectionIndex).  
		self toggleIndex: si.
		^ object].
	object class isVariable
		ifFalse: [^ object instVarAt: selectionIndex - 2 put: anObject].
	basicIndex _ selectionIndex - 2 - object class instSize.
	(object basicSize <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [^object basicAt: basicIndex put: anObject]
		ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex
					put: anObject]! !

!Inspector methodsFor: 'selecting' stamp: 'hg 10/8/2000 14:46'!
selectedSlotName

	^ self fieldList at: self selectionIndex! !

!Inspector methodsFor: 'selecting' stamp: 'tk 4/10/1998 17:57'!
selection
	"The receiver has a list of variables of its inspected object.
	One of these is selected. Answer the value of the selected variable."
	| basicIndex |
	selectionIndex = 0 ifTrue: [^ ''].
	selectionIndex = 1 ifTrue: [^ object].
	selectionIndex = 2 ifTrue: [^ object longPrintString].
	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ object instVarAt: selectionIndex - 2].
	basicIndex _ selectionIndex - 2 - object class instSize.
	(object basicSize <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [^ object basicAt: basicIndex]
		ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! !

!Inspector methodsFor: 'selecting'!
selectionIndex
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. Answer the index into the list of the selected variable."

	^selectionIndex! !

!Inspector methodsFor: 'selecting' stamp: 'sma 6/15/2000 16:45'!
selectionPrintString
	| text nm |
	selectionUpdateTime _ [text _ [self selection printStringLimitedTo: 5000]
		on: Error do: 
		[nm _ self selectionIndex < 3
					ifTrue: ['self']
					ifFalse: [self selectedSlotName].
		text _ ('<error in printString: evaluate "' , nm , ' printString" to debug>') asText.
		text
			addAttribute: TextColor red
			from: 1
			to: text size.
		text]] timeToRun.
	^ text! !

!Inspector methodsFor: 'selecting'!
selectionUnmodifiable
	"Answer if the current selected variable is modifiable via acceptance in the code pane.  For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable"

	^ selectionIndex <= 2! !

!Inspector methodsFor: 'selecting' stamp: 'sma 6/15/2000 16:50'!
toggleIndex: anInteger
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. If anInteger is the index of this variable, then deselect it. 
	Otherwise, make the variable whose index is anInteger be the selected 
	item."

	selectionUpdateTime _ 0.
	selectionIndex = anInteger
		ifTrue: 
			["same index, turn off selection"
			selectionIndex _ 0.
			contents _ '']
		ifFalse:
			["different index, new selection"
			selectionIndex _ anInteger.
			self contentsIsString
				ifTrue: [contents _ self selection]
				ifFalse: [contents _ self selectionPrintString]].
	self changed: #selection.
	self changed: #contents.
	self changed: #selectionIndex.! !


!Inspector methodsFor: 'code'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^object! !


!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:53'!
classOfSelection
	"Answer the class of the receiver's current selection"

	self selectionUnmodifiable ifTrue: [^ object class].
	^ self selection class! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:43'!
classVarRefs
	"Request a browser of methods that store into a chosen instance variable"

	| aClass |
	(aClass _ self classOfSelection) ifNotNil:
		[aClass browseClassVarRefs].
! !

!Inspector methodsFor: 'menu commands' stamp: 'ar 1/15/2001 18:38'!
copyName
	"Copy the name of the current variable, so the user can paste it into the window below and work with is.  If collection, do (xxx at: 1). "

	| sel aClass |
	self selectionUnmodifiable ifTrue: [^ self changed: #flash].
	(aClass _ self object class) isVariable ifTrue: [^ self changed: #flash].

	sel _ aClass allInstVarNames at: selectionIndex - 2.
	(self selection isKindOf: Collection) ifTrue: [sel _ '(',sel,' at: 1)'].
	Clipboard clipboardText: sel asText.	"no undo allowed"! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 10/10/1999 14:34'!
defsOfSelection
	"Open a browser on all defining references to the selected instance variable, if that's what currently selected. "
	| aClass sel |

	self selectionUnmodifiable ifTrue: [^ self changed: #flash].
	(aClass _ self object class) isVariable ifTrue: [^ self changed: #flash].

	sel _ aClass allInstVarNames at: self selectionIndex - 2.
	aClass browseAllStoresInto: sel! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:16'!
exploreSelection

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	^ self selection explore! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 10/24/2000 07:01'!
fieldListMenu: aMenu
	"Arm the supplied menu with items for the field-list of the receiver"

	| sel |
	((((sel _ self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and: [sel size >= 1])
		ifTrue:
			[^ self fieldListMenuForCollection: aMenu].

	aMenu addList: #(

		('inspect (i)'						inspectSelection)
		('explore (I)'						exploreSelection)
		-
		('method refs to this inst var'		referencesToSelection)
		('methods storing into this inst var'	defsOfSelection)
		('objects pointing to this value'		objectReferencesToSelection)
		-
		('browse full (b)'					browseMethodFull)
		('browse class'						browseClass)
		('browse hierarchy'					classHierarchy)
		-
		('inst var refs...'					browseInstVarRefs)
		('inst var defs...'					browseInstVarDefs)
		('class var refs...'					classVarRefs)
		('class variables'					browseClassVariables)
		('class refs (N)'						browseClassRefs)
		-
		('copy name'						copyName)		
		('basic inspect'						inspectBasic)).

	Smalltalk isMorphic ifTrue:
		[aMenu addList: #(
			-
			('tile for this value	(t)'			tearOffTile)
"			('alias for this value'			aliasForValue)"
"			('watcher for this slot'			watcherForSlot)"
			('viewer for this value (v)'		viewerForValue))].

	^ aMenu

! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 11:45'!
fieldListMenuForCollection: aMenu

	^ aMenu labels: 'inspect (i)
inspect element...
explore (I)
method refs to this inst var
methods storing into this inst var
objects pointing to this value
copy name
browse full (b)
browse class
browse hierarchy
inst var refs...
inst var defs...
class var refs...
class variables
class refs
basic inspect'
	lines: #(3 6 7 10 12 15)
	selections: #(inspectSelection inspectElement exploreSelection referencesToSelection defsOfSelection objectReferencesToSelection copyName  browseMethodFull browseClass classHierarchy browseInstVarRefs browseInstVarDefs classVarRefs browseClassVariables browseClassRefs inspectBasic).
! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/12/1998 08:49'!
inspectBasic
	"Bring up a non-special inspector"

	selectionIndex = 0 ifTrue: [^ object basicInspect].
	self selection basicInspect! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 12:19'!
inspectElement
	| sel selSize countString count |
	"Create and schedule an Inspector on an element of the receiver's model's currently selected collection."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	((sel _ self selection) isKindOf: SequenceableCollection) ifFalse:
		[^ sel inspect].
	(selSize _ sel size) == 1 ifTrue: [^ sel first inspect].
	selSize <= 10 ifTrue:
		[count _ (SelectionMenu selections: (1 to: selSize) asArray) startUpWithCaption: 'which element?'.
		count ifNil: [^ self] ifNotNil: [^ (sel at: count) inspect]].

	countString _ FillInTheBlank request: 'Which element? (1 - ', selSize printString, ')' initialAnswer: '1'.
	countString isEmptyOrNil ifTrue: [^ self].
	count _ Integer readFrom: (ReadStream on: countString).
	(count > 0 and: [count <= selSize])
		ifTrue:
			[(sel  at: count) inspect]
		ifFalse:
			[self beep]! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 13:39'!
inspectSelection
	"Create and schedule an Inspector on the receiver's model's currently selected object."

	self selectionIndex = 0 ifTrue: [^ self changed: #flash].
	^ self selection inspect! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:13'!
inspectorKey: aChar from: view
	"respond to a Command key.  Got here from a list of fields being inspected"

	aChar == $i ifTrue: [self selection inspect].
	aChar == $I ifTrue: [self selection explore].
	aChar == $b ifTrue:	[self browseMethodFull].
	aChar == $c ifTrue: [self copyName].
	^ self arrowKey: aChar from: view! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:45'!
objectReferencesToSelection
	"Open a list inspector on all the objects that point to the value of the selected instance variable, if any.  "

	self selectionIndex == 0 ifTrue: [^ self changed: #flash].
	Smalltalk
		browseAllObjectReferencesTo: self selection
		except: (Array with: self object)
		ifNone: [:obj | self changed: #flash].
! !

!Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:46'!
referencesToSelection
	"Open a browser on all references to the selected instance variable, if that's what currently selected.  1/25/96 sw"
	| aClass sel |

	self selectionUnmodifiable ifTrue: [^ self changed: #flash].
	(aClass _ self object class) isVariable ifTrue: [^ self changed: #flash].

	sel _ aClass allInstVarNames at: self selectionIndex - 2.
	aClass browseAllAccessesTo: sel! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 10/23/2000 18:25'!
tearOffTile
	"Tear off a tile that refers to the receiver's selection, and place it in the mophic hand"

	| objectToRepresent |
	objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	self currentHand attachMorph: (TileMorph new referTo: objectToRepresent)
	! !

!Inspector methodsFor: 'menu commands' stamp: 'sw 10/23/2000 18:27'!
viewerForValue
	"Open up a viewer on the value of the receiver's current selection"

	| objectToRepresent |
	objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection].
	objectToRepresent beViewed
	! !


!Inspector methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:47'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	timeOfLastListUpdate ifNil: [timeOfLastListUpdate _ 0].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !

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

Inspector class
	instanceVariableNames: ''!

!Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'!
horizontalDividerProportion
	^ 0.3! !

!Inspector class methodsFor: 'instance creation'!
inspect: anObject 
	"Answer an instance of me to provide an inspector for anObject."

	^self new inspect: anObject! !

!Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:16'!
openAsMorphOn: anObject
	^ self openAsMorphOn: anObject withLabel: anObject defaultLabelForInspector! !

!Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:30'!
openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass
	"Note: for now, this always adds an eval pane, and ignores the valueViewClass"

	(self openAsMorphOn: anObject withLabel: label) openInWorld! !

!Inspector class methodsFor: 'instance creation' stamp: 'RAA 12/19/2000 09:41'!
openAsMorphOn: anObject withLabel: aLabel
	"(Inspector openAsMorphOn: SystemOrganization) openInMVC"
	| window inspector |
	inspector _ self inspect: anObject.
	window _ (SystemWindow labelled: aLabel) model: inspector.
	window addMorph: (
		PluggableListMorph new
			doubleClickSelector: #inspectSelection;

			on: inspector list: #fieldList
			selected: #selectionIndex
			changeSelected: #toggleIndex:
			menu: ((inspector isMemberOf: DictionaryInspector)
					ifTrue: [#dictionaryMenu:]
					ifFalse: [#fieldListMenu:])
			keystroke: #inspectorKey:from:)
		frame: (0@0 corner: self horizontalDividerProportion @ self verticalDividerProportion).
	window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
		frame: (self horizontalDividerProportion @0 corner: 1@self verticalDividerProportion).
	window addMorph: ((PluggableTextMorph on: inspector text: #trash accept: #trash:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
					askBeforeDiscardingEdits: false)
		frame: (0@self verticalDividerProportion corner: 1@1).
	window setUpdatablePanesFrom: #(fieldList).
	window position: 16@0.  "Room for scroll bar."
	^ window! !

!Inspector class methodsFor: 'instance creation'!
openOn: anObject withEvalPane: withEval 
	"Create and schedule an instance of me on the model, anInspector. "

	^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector! !

!Inspector class methodsFor: 'instance creation' stamp: 'RAA 6/14/2000 18:20'!
openOn: anObject withEvalPane: withEval withLabel: label
        
        self couldOpenInMorphic ifTrue:
                [^ self openAsMorphOn: anObject withEvalPane: withEval
                        withLabel: label valueViewClass: nil].
        ^ self openOn: anObject 
                withEvalPane: withEval 
                withLabel: label 
                valueViewClass: PluggableTextView
! !

!Inspector class methodsFor: 'instance creation' stamp: 'di 2/16/2000 10:52'!
openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass
	| topView inspector listView valueView evalView |
	inspector _ self inspect: anObject.
	topView _ StandardSystemView new model: inspector.
	topView borderWidth: 1.

	listView _ PluggableListView on: inspector
		list: #fieldList
		selected: #selectionIndex
		changeSelected: #toggleIndex:
		menu: #fieldListMenu:
		keystroke: #inspectorKey:from:.
	(inspector isMemberOf: DictionaryInspector)
		ifTrue: [listView menu: #dictionaryMenu:].
	listView window: (0 @ 0 extent: 40 @ 40).
	topView addSubView: listView.

	valueView _ valueViewClass new.
		"PluggableTextView or PluggableFormView"
	(valueView respondsTo: #getText) ifTrue: [
		valueView on: inspector 
			text: #contents accept: #accept:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:].
	(valueViewClass inheritsFrom: FormView) ifTrue: [
		valueView model: inspector].
	valueView window: (0 @ 0 extent: 75 @ 40).
	topView addSubView: valueView toRightOf: listView.
	
	withEval ifTrue:
		[evalView _ PluggableTextView new on: inspector 
			text: #trash accept: #trash:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
		evalView window: (0 @ 0 extent: 115 @ 20).
		evalView askBeforeDiscardingEdits: false.
		topView addSubView: evalView below: listView].
	topView label: label.
	topView minimumSize: 180 @ 120.
	topView setUpdatablePanesFrom: #(fieldList).
	topView controller open! !

!Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'!
verticalDividerProportion
	^ 0.7! !
Inspector subclass: #InspectorBrowser
	instanceVariableNames: 'fieldList msgList msgListIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 15:51'!
fieldList
	fieldList ifNotNil: [^ fieldList].
	^ (fieldList _ super fieldList)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 15:52'!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject."
	fieldList _ nil.
	super inspect: anObject.
	msgListIndex _ 0.
	self changed: #msgText! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/13/1998 15:27'!
msgAccept: newText from: editor
	| category |
	category _ msgListIndex = 0
		ifTrue: [ClassOrganizer default]
		ifFalse: [object class organization categoryOfElement: (msgList at: msgListIndex)].
	^ (object class compile: newText classified: category notifying: editor) ~~ nil! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/17/1998 10:19'!
msgList
	msgList ifNotNil: [^ msgList].
	^ (msgList _ object class selectors asSortedCollection asArray)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:18'!
msgListIndex 
	^msgListIndex! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:32'!
msgListIndex: anInteger
	"A selection has been made in the message pane"

	msgListIndex _ anInteger.
	self changed: #msgText.! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/20/1998 07:44'!
msgPaneMenu: aMenu shifted: shifted
	^ aMenu labels: 
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)' 
		lines: #(0 3 5 8 11)
		selections: #(find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/16/1998 14:38'!
msgText
	msgListIndex = 0 ifTrue: [^ nil].
	^ object class sourceCodeAt: (msgList at: msgListIndex)! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 4/18/1998 09:48'!
step
	| list fieldString msg |
	(list _ super fieldList) = fieldList ifFalse:
		[fieldString _ selectionIndex > 0 ifTrue: [fieldList at: selectionIndex] ifFalse: [nil].
		fieldList _ list.
		selectionIndex _ fieldList indexOf: fieldString ifAbsent: [0].
		self changed: #fieldList.
		self changed: #selectionIndex].
	list _ msgList.  msgList _ nil.  "force recomputation"
		list = self msgList ifFalse:
		[msg _ msgListIndex > 0 ifTrue: [list at: msgListIndex] ifFalse: [nil].
		msgListIndex _ msgList indexOf: msg ifAbsent: [0].
		self changed: #msgList.
		self changed: #msgListIndex].
	super step! !

!InspectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 1/14/1999 09:01'!
wantsSteps
	^ true! !

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

InspectorBrowser class
	instanceVariableNames: ''!

!InspectorBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 10:11'!
openAsMorphOn: anObject
	"(InspectorBrowser openAsMorphOn: SystemOrganization) openInMVC"
	| window inspector |
	inspector _ self inspect: anObject.
	window _ (SystemWindow labelled: anObject defaultLabelForInspector)
				model: inspector.

	window addMorph: (PluggableListMorph on: inspector list: #fieldList
				selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu:)
		frame: (0@0 corner: 0.3@0.5).
	window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept:
				readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0.3@0 corner: 1.0@0.5).
	window addMorph: (PluggableListMorph on: inspector list: #msgList
				selected: #msgListIndex changeSelected: #msgListIndex: menu: #msgListMenu:)
		frame: (0@0.5 corner: 0.3@1.0).
	window addMorph: (PluggableTextMorph on: inspector text: #msgText accept: #msgAccept:from:
				readSelection: nil menu: #msgPaneMenu:shifted:)
		frame: (0.3@0.5 corner: 1.0@1.0).
	
	window setUpdatablePanesFrom: #(fieldList msgList).
	window position: 16@0.  "Room for scroll bar."
	^ window! !
AbstractInstructionPrinter subclass: #InstVarRefLocator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

!InstVarRefLocator methodsFor: 'as yet unclassified' stamp: 'RAA 1/5/2001 08:46'!
popIntoReceiverVariable: offset 

	bingo _ true! !

!InstVarRefLocator methodsFor: 'as yet unclassified' stamp: 'RAA 1/5/2001 08:46'!
pushReceiverVariable: offset

	bingo _ true! !

!InstVarRefLocator methodsFor: 'as yet unclassified' stamp: 'RAA 1/5/2001 08:46'!
storeIntoReceiverVariable: offset 

	bingo _ true! !
InstructionStream subclass: #InstructionPrinter
	instanceVariableNames: 'stream oldPC '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstructionPrinter commentStamp: '<historical>' prior: 0!
My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The inherited variable, sender, is used in an ugly way to hold the method being printed.!


!InstructionPrinter methodsFor: 'initialize-release'!
printInstructionsOn: aStream 
	"Append to the stream, aStream, a description of each bytecode in the 
	instruction stream."
	
	| end |
	stream _ aStream.
	end _ self method endPC.
	oldPC _ pc.
	[pc <= end]
		whileTrue: [super interpretNextInstructionFor: self]! !


!InstructionPrinter methodsFor: 'instruction decoding'!
blockReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'blockReturn'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
doDup
	"Print the Duplicate Top Of Stack bytecode."

	self print: 'dup'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
doPop
	"Print the Remove Top Of Stack bytecode."

	self print: 'pop'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
jump: offset
	"Print the Unconditional Jump bytecode."

	self print: 'jumpTo: ' , (pc + offset) printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

	self print: 
		(condition
			ifTrue: ['jumpTrue: ']
			ifFalse: ['jumpFalse: '])
			, (pc + offset) printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnConstant: value 
	"Print the Return Constant bytecode."

	self print: 'return: ' , value printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnReceiver
	"Print the Return Self bytecode."

	self print: 'returnSelf'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
methodReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'returnTop'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoLiteralVariable: anAssociation 
	"Print the Remove Top Of Stack And Store Into Literal Variable bytecode."

	self print: 'popIntoLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset 
	"Print the Remove Top Of Stack And Store Into Instance Variable 
	bytecode."

	self print: 'popIntoRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset 
	"Print the Remove Top Of Stack And Store Into Temporary Variable 
	bytecode."

	self print: 'popIntoTemp: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushActiveContext
	"Print the Push Active Context On Top Of Its Own Stack bytecode."

	self print: 'pushThisContext: '! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushConstant: value
	"Print the Push Constant, value, on Top Of Stack bytecode."

	self print: 'pushConstant: ' , value printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushLiteralVariable: anAssociation
	"Print the Push Contents Of anAssociation On Top Of Stack bytecode."

	self print: 'pushLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushReceiver
	"Print the Push Active Context's Receiver on Top Of Stack bytecode."

	self print: 'self'! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushReceiverVariable: offset
	"Print the Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."

	self print: 'pushRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset
	"Print the Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."

	self print: 'pushTemp: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
send: selector super: supered numArgs: numberArguments
	"Print the Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."

	self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: anAssociation 
	"Print the Store Top Of Stack Into Literal Variable Of Method bytecode."

	self print: 'storeIntoLit: ' , anAssociation key! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset 
	"Print the Store Top Of Stack Into Instance Variable Of Method bytecode."

	self print: 'storeIntoRcvr: ' , offset printString! !

!InstructionPrinter methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset 
	"Print the Store Top Of Stack Into Temporary Variable Of Method 
	bytecode."

	self print: 'storeIntoTemp: ' , offset printString! !


!InstructionPrinter methodsFor: 'printing'!
print: instruction 
	"Append to the receiver a description of the bytecode, instruction." 

	| code |
	stream print: oldPC; space.
	stream nextPut: $<.
	oldPC to: pc - 1 do: 
		[:i | 
		code _ (self method at: i) radix: 16.
		stream nextPut: 
			(code size < 5
				ifTrue: [$0]
				ifFalse: [code at: 4]).
		stream nextPut: code last; space].
	stream skip: -1.
	stream nextPut: $>.
	stream space.
	stream nextPutAll: instruction.
	stream cr.
	oldPC _ pc
	"(InstructionPrinter compiledMethodAt: #print:) symbolic."
! !

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

InstructionPrinter class
	instanceVariableNames: ''!

!InstructionPrinter class methodsFor: 'printing'!
printClass: class 
	"Create a file whose name is the argument followed by '.bytes'. Store on 
	the file the symbolic form of the compiled methods of the class."
	| file |
	file _ FileStream newFileNamed: class name , '.bytes'.
	class selectors do: 
		[:sel | 
		file cr; nextPutAll: sel; cr.
		(self on: (class compiledMethodAt: sel)) printInstructionsOn: file].
	file close
	"InstructionPrinter printClass: Parser."
! !
Object subclass: #InstructionStream
	instanceVariableNames: 'sender pc '
	classVariableNames: 'SpecialConstants '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!InstructionStream commentStamp: '<historical>' prior: 0!
My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.!


!InstructionStream methodsFor: 'testing'!
willJumpIfFalse
	"Answer whether the next bytecode is a jump-if-false."

	| byte |
	byte _ self method at: pc.
	^(byte between: 152 and: 159) or: [byte between: 172 and: 175]! !

!InstructionStream methodsFor: 'testing' stamp: 'di 1/29/2000 14:42'!
willJumpIfTrue 
	"Answer whether the next bytecode is a jump-if-true."
 
	| byte |
	byte _ self method at: pc.
	^ byte between: 168 and: 171! !

!InstructionStream methodsFor: 'testing' stamp: 'sn 8/22/97 21:55'!
willReallySend
	"Answer whether the next bytecode is a real message-send,
	not blockCopy:."

	| byte |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^false].
	byte == 200 ifTrue: [^false].
	byte >= 176 ifTrue: [^true].	"special send or short send"
	^byte between: 131 and: 134	"long sends"! !

!InstructionStream methodsFor: 'testing'!
willReturn
	"Answer whether the next bytecode is a return."

	^(self method at: pc) between: 120 and: 125! !

!InstructionStream methodsFor: 'testing'!
willSend
	"Answer whether the next bytecode is a message-send."

	| byte |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^false].
	byte >= 176 ifTrue: [^true].	"special send or short send"
	^byte between: 131 and: 134	"long sends"! !

!InstructionStream methodsFor: 'testing'!
willStorePop
	"Answer whether the next bytecode is a store-pop."

	| byte |
	byte _ self method at: pc.
	^byte = 130 or: [byte between: 96 and: 111]! !


!InstructionStream methodsFor: 'decoding'!
interpretJump

	| byte |
	byte _ self method at: pc.
	(byte between: 144 and: 151) ifTrue:
		[pc _ pc + 1. ^byte - 143].
	(byte between: 160 and: 167) ifTrue:
		[pc _ pc + 2. ^(byte - 164) * 256 + (self method at: pc - 1)].
	^nil! !

!InstructionStream methodsFor: 'decoding'!
interpretNextInstructionFor: client 
	"Send to the argument, client, a message that specifies the type of the 
	next instruction."

	| byte type offset method |
	method _ self method.  
	byte _ method at: pc.
	type _ byte // 16.  
	offset _ byte \\ 16.  
	pc _ pc+1.
	type=0 ifTrue: [^client pushReceiverVariable: offset].
	type=1 ifTrue: [^client pushTemporaryVariable: offset].
	type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)].
	type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)].
	type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)].
	type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)].
	type=6 
		ifTrue: [offset<8
					ifTrue: [^client popIntoReceiverVariable: offset]
					ifFalse: [^client popIntoTemporaryVariable: offset-8]].
	type=7
		ifTrue: [offset=0 ifTrue: [^client pushReceiver].
				offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)].
				offset=8 ifTrue: [^client methodReturnReceiver].
				offset<12 ifTrue: [^client methodReturnConstant: 
												(SpecialConstants at: offset-8)].
				offset=12 ifTrue: [^client methodReturnTop].
				offset=13 ifTrue: [^client blockReturnTop].
				offset>13 ifTrue: [^self error: 'unusedBytecode']].
	type=8 ifTrue: [^self interpretExtension: offset in: method for: client].
	type=9
		ifTrue:  "short jumps"
			[offset<8 ifTrue: [^client jump: offset+1].
			^client jump: offset-8+1 if: false].
	type=10 
		ifTrue:  "long jumps"
			[byte_ method at: pc.  pc_ pc+1.
			offset<8 ifTrue: [^client jump: offset-4*256 + byte].
			^client jump: (offset bitAnd: 3)*256 + byte if: offset<12].
	type=11 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+1) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+1)].
	type=12 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+17) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+17)].
	type>12
		ifTrue: 
			[^client send: (method literalAt: offset+1) 
					super: false
					numArgs: type-13]! !


!InstructionStream methodsFor: 'scanning'!
addSelectorTo: set 
	"If this instruction is a send, add its selector to set."

	| byte literalNumber byte2 |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^self].
	byte >= 176
		ifTrue: 
			["special byte or short send"
			byte >= 208
				ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)]
				ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]]
		ifFalse: 
			[(byte between: 131 and: 134)
				ifTrue: 
					[byte2 _ self method at: pc + 1.
					byte = 131 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
					byte = 132 ifTrue: [byte2 < 64 ifTrue: [set add: (self method literalAt: (self method at: pc + 2) + 1)]].
					byte = 133 ifTrue: [set add: (self method literalAt: byte2 \\ 32 + 1)].
					byte = 134 ifTrue: [set add: (self method literalAt: byte2 \\ 64 + 1)]]]! !

!InstructionStream methodsFor: 'scanning'!
followingByte
	"Answer the next bytecode."

	^self method at: pc + 1! !

!InstructionStream methodsFor: 'scanning'!
method
	"Answer the compiled method that supplies the receiver's bytecodes."

	^sender		"method access when used alone (not as part of a context)"! !

!InstructionStream methodsFor: 'scanning'!
nextByte
	"Answer the next bytecode."

	^self method at: pc! !

!InstructionStream methodsFor: 'scanning'!
pc
	"Answer the index of the next bytecode."

	^pc! !

!InstructionStream methodsFor: 'scanning'!
scanFor: scanBlock 
	"Answer the index of the first bytecode for which scanBlock answer true 
	when supplied with that bytecode."

	| method end byte type |
	method _ self method.
	end _ method endPC.
	[pc <= end]
		whileTrue: 
			[(scanBlock value: (byte _ method at: pc)) ifTrue: [^true].
			type _ byte // 16.
			pc _ 
				type = 8
					ifTrue: ["extensions"
							pc + (#(2 2 2 2 3 2 2 1 1 1 ) at: byte \\ 16 + 1)]
					ifFalse: [type = 10
								ifTrue: [pc + 2"long jumps"]
								ifFalse: [pc + 1]]].
	^false! !

!InstructionStream methodsFor: 'scanning'!
thirdByte
	"Answer the next bytecode."

	^self method at: pc + 2! !


!InstructionStream methodsFor: 'private'!
interpretExtension: offset in: method for: client
	| type offset2 byte2 byte3 |
	offset <=6 ifTrue: 
		["Extended op codes 128-134"
		byte2 _ method at: pc.
		pc _ pc + 1.
		offset <= 2 ifTrue:
			["128-130:  extended pushes and pops"
			type _ byte2 // 64.
			offset2 _ byte2 \\ 64.
			offset = 0 ifTrue: 
				[type = 0 ifTrue: [^ client pushReceiverVariable: offset2].
				type = 1 ifTrue: [^ client pushTemporaryVariable: offset2].
				type = 2  ifTrue: [^ client pushConstant: (method literalAt: offset2 + 1)].
				type = 3 ifTrue: [^ client pushLiteralVariable: (method literalAt: offset2 + 1)]].
			offset = 1 ifTrue: 
				[type = 0 ifTrue: [^ client storeIntoReceiverVariable: offset2].
				type = 1 ifTrue: [^ client storeIntoTemporaryVariable: offset2].
				type = 2 ifTrue: [self error: 'illegalStore'].
				type = 3 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
			offset = 2 ifTrue: 
				[type = 0 ifTrue: [^ client popIntoReceiverVariable: offset2].
				type = 1 ifTrue: [^ client popIntoTemporaryVariable: offset2].
				type = 2 ifTrue: [self error: 'illegalStore'].
				type = 3  ifTrue: [^ client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
		"131-134: extended sends"
		offset = 3 ifTrue:  "Single extended send"
			[^ client send: (method literalAt: byte2 \\ 32 + 1)
					super: false numArgs: byte2 // 32].
		offset = 4 ifTrue:    "Double extended do-anything"
			[byte3 _ method at: pc.  pc _ pc + 1.
			type _ byte2 // 32.
			type = 0 ifTrue: [^ client send: (method literalAt: byte3 + 1)
									super: false numArgs: byte2 \\ 32].
			type = 1 ifTrue: [^ client send: (method literalAt: byte3 + 1)
									super: true numArgs: byte2 \\ 32].
			type = 2 ifTrue: [^ client pushReceiverVariable: byte3].
			type = 3 ifTrue: [^ client pushConstant: (method literalAt: byte3 + 1)].
			type = 4 ifTrue: [^ client pushLiteralVariable: (method literalAt: byte3 + 1)].
			type = 5 ifTrue: [^ client storeIntoReceiverVariable: byte3].
			type = 6 ifTrue: [^ client popIntoReceiverVariable: byte3].
			type = 7 ifTrue: [^ client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
		offset = 5 ifTrue:  "Single extended send to super"
			[^ client send: (method literalAt: byte2 \\ 32 + 1)
					super: true numArgs: byte2 // 32].
		offset = 6 ifTrue:   "Second extended send"
			[^ client send: (method literalAt: byte2 \\ 64 + 1)
					super: false numArgs: byte2 // 64]].
	offset = 7 ifTrue: [^ client doPop].
	offset = 8 ifTrue: [^ client doDup].
	offset = 9 ifTrue: [^ client pushActiveContext].
	self error: 'unusedBytecode'! !

!InstructionStream methodsFor: 'private'!
method: method pc: startpc

	sender _ method. 
	"allows this class to stand alone as a method scanner"
	pc _ startpc! !

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

InstructionStream class
	instanceVariableNames: ''!

!InstructionStream class methodsFor: 'class initialization'!
initialize
	"Initialize an array of special constants returned by single-bytecode returns."

	SpecialConstants _ 
		(Array with: true with: false with: nil)
			, (Array with: -1 with: 0 with: 1 with: 2)	
	"InstructionStream initialize."
! !


!InstructionStream class methodsFor: 'instance creation'!
on: method 
	"Answer an instance of me on the argument, method."

	^self new method: method pc: method initialPC! !
Number subclass: #Integer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Integer commentStamp: '<historical>' prior: 0!
I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger.
	
Integer division consists of:
	/	exact division, answers a fraction if result is not a whole integer
	//	answers an Integer, rounded towards negative infinity
	\\	is modulo rounded towards negative infinity
	quo: truncated division, rounded towards zero!


!Integer methodsFor: 'testing'!
even 
	"Refer to the comment in Number|even."

	^((self digitAt: 1) bitAnd: 1) = 0! !

!Integer methodsFor: 'testing'!
isInteger
	"True for all subclasses of Integer."

	^ true! !

!Integer methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'!
isPowerOfTwo
	"Return true if the receiver is an integral power of two."
	^ (self bitAnd: self-1) = 0! !


!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
* aNumber
	"Refer to the comment in Number * " 
	aNumber isInteger ifTrue:
		[^ self digitMultiply: aNumber 
					neg: self negative ~~ aNumber negative].
	^ aNumber adaptToInteger: self andSend: #*! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
+ aNumber
	"Refer to the comment in Number + "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ (self digitAdd: aNumber) normalize]
			ifFalse: [^ self digitSubtract: aNumber]].
	^ aNumber adaptToInteger: self andSend: #+! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'!
- aNumber
	"Refer to the comment in Number - "
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [^ self digitSubtract: aNumber]
			ifFalse: [^ (self digitAdd: aNumber) normalize]].
	^ aNumber adaptToInteger: self andSend: #-! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'!
/ aNumber
	"Refer to the comment in Number / "
	| quoRem |
	aNumber isInteger ifTrue:
		[quoRem _ self digitDiv: aNumber abs	"*****I've added abs here*****"
						neg: self negative ~~ aNumber negative.
		(quoRem at: 2) = 0
			ifTrue: [^ (quoRem at: 1) normalize]
			ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]].
	^ aNumber adaptToInteger: self andSend: #/! !

!Integer methodsFor: 'arithmetic'!
// aNumber

	| q |
	aNumber = 0 ifTrue: [^self error: 'division by 0'].
	self = 0 ifTrue: [^0].
	q _ self quo: aNumber 
	"Refer to the comment in Number|//.".
	(q negative
		ifTrue: [q * aNumber ~= self]
		ifFalse: [q = 0 and: [self negative ~= aNumber negative]])
		ifTrue: [^q - 1"Truncate towards minus infinity"]
		ifFalse: [^q]! !

!Integer methodsFor: 'arithmetic' stamp: 'hh 8/4/2000 00:39'!
\\\ anInteger 
	"a modulo method for use in DSA. Be careful if you try to use this elsewhere"

	^self \\ anInteger! !

!Integer methodsFor: 'arithmetic'!
alignedTo: anInteger
	"Answer the smallest number not less than receiver that is a multiple of anInteger."

	^(self+anInteger-1//anInteger)*anInteger

"5 alignedTo: 2"
"12 alignedTo: 3"! !

!Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'!
quo: aNumber 
	"Refer to the comment in Number quo: "
	| ng quo |
	aNumber isInteger ifTrue: 
		[ng _ self negative == aNumber negative == false.
		quo _ (self digitDiv:
			(aNumber class == SmallInteger
				ifTrue: [aNumber abs]
				ifFalse: [aNumber])
			neg: ng) at: 1.
		^ quo normalize].
	^ aNumber adaptToInteger: self andSend: #quo:! !


!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
< aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^ (self digitCompare: aNumber) > 0]
						ifFalse: [^ (self digitCompare: aNumber) < 0]]
			ifFalse: [^ self negative]].
	^ aNumber adaptToInteger: self andSend: #<! !

!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
= aNumber
	aNumber isNumber ifFalse: [^ false].
	aNumber isInteger ifTrue:
		[aNumber negative == self negative
			ifTrue: [^ (self digitCompare: aNumber) = 0]
			ifFalse: [^ false]].
	^ aNumber adaptToInteger: self andSend: #=! !

!Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'!
> aNumber
	aNumber isInteger ifTrue:
		[self negative == aNumber negative
			ifTrue: [self negative
						ifTrue: [^(self digitCompare: aNumber) < 0]
						ifFalse: [^(self digitCompare: aNumber) > 0]]
			ifFalse: [^ aNumber negative]].
	^ aNumber adaptToInteger: self andSend: #>! !

!Integer methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^(self lastDigit bitShift: 8) + (self digitAt: 1)! !


!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'!
asLargerPowerOfTwo
	"Convert the receiver into a power of two which is not less than the receiver"
	self isPowerOfTwo
		ifTrue:[^self]
		ifFalse:[^1 bitShift: (self highBit)]! !

!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 18:56'!
asPowerOfTwo
	"Convert the receiver into a power of two"
	^self asSmallerPowerOfTwo! !

!Integer methodsFor: 'truncation and round off' stamp: 'ar 6/9/2000 19:16'!
asSmallerPowerOfTwo
	"Convert the receiver into a power of two which is not larger than the receiver"
	self isPowerOfTwo
		ifTrue:[^self]
		ifFalse:[^1 bitShift: (self highBit - 1)]! !

!Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'!
atRandom
	"Answer a random integer from 1 to self.  This implementation uses a
	shared generator. Heavy users should their own implementation or use
	Interval>atRandom: directly."

	^ self atRandom: Collection randomForPicking! !

!Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'!
atRandom: aGenerator
	"Answer a random integer from 1 to self picked from aGenerator."

	^ aGenerator nextInt: self! !

!Integer methodsFor: 'truncation and round off'!
ceiling 
	"Refer to the comment in Number|ceiling."! !

!Integer methodsFor: 'truncation and round off'!
floor 
	"Refer to the comment in Number|floor."! !

!Integer methodsFor: 'truncation and round off'!
normalize 
	"SmallInts OK; LgInts override"
	^ self! !

!Integer methodsFor: 'truncation and round off'!
rounded 
	"Refer to the comment in Number|rounded."! !

!Integer methodsFor: 'truncation and round off'!
truncated 
	"Refer to the comment in Number|truncated."! !


!Integer methodsFor: 'enumerating'!
timesRepeat: aBlock 
	"Evaluate the argument, aBlock, the number of times represented by the 
	receiver."

	| count |
	count _ 1.
	[count <= self]
		whileTrue: 
			[aBlock value.
			count _ count + 1]! !


!Integer methodsFor: 'mathematical functions'!
degreeCos
	"Answer the cosine of the receiver taken as an angle in degrees."

	^ (90 + self) degreeSin! !

!Integer methodsFor: 'mathematical functions'!
degreeSin
	"Answer the sine of the receiver taken as an angle in degrees."

	^ self asFloat degreesToRadians sin! !

!Integer methodsFor: 'mathematical functions' stamp: 'di 4/22/1998 14:45'!
factorial
	"Answer the factorial of the receiver."

	self = 0 ifTrue: [^ 1].
	self > 0 ifTrue: [^ self * (self - 1) factorial].
	self error: 'Not valid for negative integers'! !

!Integer methodsFor: 'mathematical functions' stamp: 'LC 6/17/1998 19:22'!
gcd: anInteger
	"See Knuth, Vol 2, 4.5.2, Algorithm L"
	"Initialize"
	| higher u v k uHat vHat a b c d vPrime vPrimePrime q t |
	higher _ SmallInteger maxVal highBit.
	u _ self abs max: (v _ anInteger abs).
	v _ self abs min: v.
	[v class == SmallInteger]
		whileFalse: 
			[(uHat _ u bitShift: (k _ higher - u highBit)) class == SmallInteger
				ifFalse: 
					[k _ k - 1.
					uHat _ uHat bitShift: -1].
			vHat _ v bitShift: k.
			a _ 1.
			b _ 0.
			c _ 0.
			d _ 1.
			"Test quotient"
			[(vPrime _ vHat + d) ~= 0
				and: [(vPrimePrime _ vHat + c) ~= 0 and: [(q _ uHat + a // vPrimePrime) = (uHat + b // vPrime)]]]
				whileTrue: 
					["Emulate Euclid"
					c _ a - (q * (a _ c)).
					d _ b - (q * (b _ d)).
					vHat _ uHat - (q * (uHat _ vHat))].
			"Multiprecision step"
			b = 0
				ifTrue: 
					[v _ u rem: (u _ v)]
				ifFalse: 
					[t _ u * a + (v * b).
					v _ u * c + (v * d).
					u _ t]].
	^ v gcd: u! !

!Integer methodsFor: 'mathematical functions'!
lcm: n 
	"Answer the least common multiple of the receiver and n."

	^self // (self gcd: n) * n! !

!Integer methodsFor: 'mathematical functions' stamp: 'hh 8/4/2000 01:09'!
raisedTo: y modulo: n
	"Answer the modular exponential. Code by Jesse Welton."
	| s t u |
	s _ 1.
	t _ self.
	u _ y.
	[u = 0] whileFalse: [
		u odd ifTrue: [
			s _ s * t.
			s >= n ifTrue: [s _ s \\\ n]].
		t _ t * t.
		t >= n ifTrue: [t _ t \\\ n].
		u _ u bitShift: -1].
	^ s
! !

!Integer methodsFor: 'mathematical functions' stamp: 'tk 7/30/97 13:08'!
take: kk
	"Return the number of combinations of (self) elements taken kk at a time.  For 6 take 3, this is 6*5*4 / (1*2*3).  Zero outside of Pascal's triangle.  Use a trick to go faster."
	" 6 take: 3  "

	| num denom |
	kk < 0 ifTrue: [^ 0].
	kk > self ifTrue: [^ 0].
	num _ 1.
	self to: (kk max: self-kk) + 1 by: -1 do: [:factor | num _ num * factor].
	denom _ 1.
	1 to: (kk min: self-kk) do: [:factor | denom _ denom * factor].
	^ num // denom! !


!Integer methodsFor: 'bit manipulation'!
<< shiftAmount  "left shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: shiftAmount! !

!Integer methodsFor: 'bit manipulation' stamp: 'dwh 8/18/1999 21:57'!
>> shiftAmount  "right shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: 0 - shiftAmount! !

!Integer methodsFor: 'bit manipulation'!
allMask: mask 
	"Treat the argument as a bit mask. Answer whether all of the bits that 
	are 1 in the argument are 1 in the receiver."

	^mask = (self bitAnd: mask)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 11/29/2000 14:32'!
anyBitOfMagnitudeFrom: start to: stopArg 
	"Tests for any magnitude bits in the interval from start to stopArg."
	"Primitive fixed in LargeIntegers v1.2. If you have an earlier version 
	comment out the primitive call (using this ST method then)."
	| magnitude firstDigitIx lastDigitIx rightShift leftShift stop |
	<primitive: 'primAnyBitFromTo' module:'LargeIntegers'>
	start < 1 | (stopArg < 1)
		ifTrue: [^ self error: 'out of range'].
	magnitude _ self abs.
	stop _ stopArg min: magnitude highBit.
	start > stop
		ifTrue: [^ false].
	firstDigitIx _ start - 1 // 8 + 1.
	lastDigitIx _ stop - 1 // 8 + 1.
	rightShift _ (start - 1 \\ 8) negated.
	leftShift _ 7 - (stop - 1 \\ 8).
	firstDigitIx = lastDigitIx
		ifTrue: [| digit mask | 
			mask _ (255 bitShift: rightShift negated)
						bitAnd: (255 bitShift: leftShift negated).
			digit _ magnitude digitAt: firstDigitIx.
			^ (digit bitAnd: mask)
				~= 0].
	((magnitude digitAt: firstDigitIx)
			bitShift: rightShift)
			~= 0
		ifTrue: [^ true].
	firstDigitIx + 1
		to: lastDigitIx - 1
		do: [:ix | (magnitude digitAt: ix)
					~= 0
				ifTrue: [^ true]].
	(((magnitude digitAt: lastDigitIx)
			bitShift: leftShift)
			bitAnd: 255)
			~= 0
		ifTrue: [^ true].
	^ false! !

!Integer methodsFor: 'bit manipulation'!
anyMask: mask 
	"Treat the argument as a bit mask. Answer whether any of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 ~= (self bitAnd: mask)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitAnd: n 
	"Answer an Integer whose bits are the logical AND of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitAnd' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitAnd:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:32'!
bitClear: aMask 
	"Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask."

	^ (self bitOr: aMask) - aMask! !

!Integer methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitInvert
	"Answer an Integer whose bits are the logical negation of the receiver's bits.
	Numbers are interpreted as having 2's-complement representation."

	^ -1 - self! !

!Integer methodsFor: 'bit manipulation'!
bitInvert32
	"Answer the 32-bit complement of the receiver."

	^ self bitXor: 16rFFFFFFFF! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitOr: n 
	"Answer an Integer whose bits are the logical OR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitOr' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitOr:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:09'!
bitShift: shiftCount 
	"Answer an Integer whose value (in twos-complement representation) is  
	the receiver's value (in twos-complement representation) shifted left by 
	the number of bits indicated by the argument. Negative arguments  
	shift right. Zeros are shifted in from the right in left shifts."
	| magnitudeShift |
	magnitudeShift _ self bitShiftMagnitude: shiftCount.
	^ ((self negative and: [shiftCount negative])
		and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated])
		ifTrue: [magnitudeShift - 1]
		ifFalse: [magnitudeShift]! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 14:02'!
bitShiftMagnitude: shiftCount 
	"Answer an Integer whose value (in magnitude representation) is  
	the receiver's value (in magnitude representation) shifted left by  
	the number of bits indicated by the argument. Negative arguments
	shift right. Zeros are shifted in from the right in left shifts."
	| rShift |
	<primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'>
	shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount].
	rShift _ 0 - shiftCount.
	^ (self
		digitRshift: (rShift bitAnd: 7)
		bytes: (rShift bitShift: -3)
		lookfirst: self digitLength) normalize! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'!
bitXor: n 
	"Answer an Integer whose bits are the logical XOR of the receiver's bits  
	and those of the argument, n."
	| norm |
	<primitive: 'primDigitBitXor' module:'LargeIntegers'>
	norm _ n normalize.
	^ self
		digitLogic: norm
		op: #bitXor:
		length: (self digitLength max: norm digitLength)! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:13'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."

	^ self subclassResponsibility! !

!Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 01:55'!
highBitOfMagnitude
	"Answer the index of the high order bit of the magnitude of the  
	receiver, or zero if the receiver is zero."
	^ self subclassResponsibility! !

!Integer methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'!
lowBit
	"Answer the index of the low order bit of this number."
	| index |
	self = 0 ifTrue: [ ^ 0 ].
	index := 1.
	[ (self digitAt: index) = 0 ]
		whileTrue:
			[ index := index + 1 ].
	^ (self digitAt: index) lowBit + (8 * (index - 1))! !

!Integer methodsFor: 'bit manipulation'!
noMask: mask 
	"Treat the argument as a bit mask. Answer whether none of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 = (self bitAnd: mask)! !


!Integer methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert me to a Fraction."
	^ rcvr perform: selector with: self asFraction! !

!Integer methodsFor: 'converting'!
asCharacter
	"Answer the Character whose value is the receiver."

	^Character value: self! !

!Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04'!
asColorOfDepth: d
	"Return a color value representing the receiver as color of the given depth"
	^Color colorFromPixelValue: self depth: d! !

!Integer methodsFor: 'converting' stamp: 'di 1/13/1999 12:45'!
asFloat
	"Answer a Float that represents the value of the receiver.
	Optimized to process only the significant digits of a LargeInteger.
	SqR: 11/30/1998 21:11"

	| sum firstByte shift |
	shift _ 0.
	sum _ 0.0.
	firstByte _ self size - 7 max: 1.
	firstByte to: self size do:
		[:byteIndex | 
		sum _ ((self digitAt: byteIndex) asFloat timesTwoPower: shift) + sum.
		shift _ shift + 8].
	^sum * self sign asFloat timesTwoPower: firstByte - 1 * 8! !

!Integer methodsFor: 'converting'!
asFraction
	"Answer a Fraction that represents value of the the receiver."

	^Fraction numerator: self denominator: 1! !

!Integer methodsFor: 'converting' stamp: 'ls 5/26/1998 20:53'!
asHexDigit
	^'0123456789ABCDEF' at: self+1! !

!Integer methodsFor: 'converting'!
asInteger
	"Answer with the receiver itself."

	^self

! !


!Integer methodsFor: 'printing' stamp: 'sw 11/24/1998 14:53'!
asStringWithCommas
	"123456789 asStringWithCommas"
	"-123456789 asStringWithCommas"
	| digits |
	digits _ self abs printString.
	^ String streamContents:
		[:strm | 
		self sign = -1 ifTrue: [strm nextPut: $-].
		1 to: digits size do: 
			[:i | strm nextPut: (digits at: i).
			(i < digits size and: [(i - digits size) \\ 3 = 0])
				ifTrue: [strm nextPut: $,]]]! !

!Integer methodsFor: 'printing' stamp: 'sw 11/13/1999 23:00'!
asTwoCharacterString
	"Answer a two-character string representing the receiver, with leading zero if required.  Intended for use with integers in the range 0 to 99, but plausible replies given for other values too"

	^ (self >= 0 and: [self < 10])
		ifTrue:	['0', self printString]
		ifFalse:	[self printString copyFrom: 1 to: 2]


"
2 asTwoCharacterString
11 asTwoCharacterString
1943 asTwoCharacterString
0 asTwoCharacterString
-2 asTwoCharacterString
-234 asTwoCharacterString
"! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:04'!
byteEncode: aStream base: b 
	"Print a representation of the receiver on the stream, aStream, in base, b, 
	where 2<=b<=16."
	| digits source dest i j pos t rem |

	self negative ifTrue:[aStream print:$-].
	i _ self digitLength.
	"Estimate size of result, conservatively"
	digits _ self digitBuffer:i.
	pos _ 0.
	dest _ self destinationBuffer:i.
	source _ self.
	[i >= 1]
		whileTrue: 
			[rem _ 0.
			j _ i.
			[j > 0]
				whileTrue: 
					[t _ (rem bitShift: 8) + (source digitAt: j).
					dest digitAt: j put: t // b.
					rem _ t \\ b.
					j _ j - 1].
			pos _ pos + 1.
			digits at: pos put: rem.
			source _ dest.
			(source digitAt: i) = 0 ifTrue: [i _ i - 1]].
	"(dest digitAt: 1) printOn: aStream base: b."
	[pos > 0]
		whileTrue:
			[aStream print:(Character digitValue: (digits at: pos)).
			pos _ pos - 1]! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:14'!
destinationBuffer:digitLength
  digitLength <= 1
		ifTrue: [self]
		ifFalse: [LargePositiveInteger new: digitLength].! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'!
digitBuffer:digitLength
  ^Array new:digitLength*8.! !

!Integer methodsFor: 'printing'!
hex
	^ self printStringBase: 16! !

!Integer methodsFor: 'printing'!
hex8  "16r3333 hex8"
	| hex |
	hex _ self hex.  "16rNNN"
	hex size < 11
		ifTrue: [^ hex copyReplaceFrom: 4 to: 3
						 with: ('00000000' copyFrom: 1 to: 11-hex size)]
		ifFalse: [^ hex]! !

!Integer methodsFor: 'printing'!
isLiteral

	^true! !

!Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:04'!
printOn: aStream base: b 
	"Print a representation of the receiver on the stream, aStream, in base, b, 
	where 2<=b<=16."
	| digits source dest i j pos t rem |
	self negative ifTrue:[aStream nextPut:$-].
	b = 10 ifFalse: [aStream print: b; nextPut: $r].
	i _ self digitLength.
	"Estimate size of result, conservatively"
	digits _ Array new: i * 8.
	pos _ 0.
	dest _ i <= 1
		ifTrue: [self]
		ifFalse: [LargePositiveInteger new: i].
	source _ self.
	[i >= 1]
		whileTrue: 
			[rem _ 0.
			j _ i.
			[j > 0]
				whileTrue: 
					[t _ (rem bitShift: 8) + (source digitAt: j).
					dest digitAt: j put: t // b.
					rem _ t \\ b.
					j _ j - 1].
			pos _ pos + 1.
			digits at: pos put: rem.
			source _ dest.
			(source digitAt: i) = 0 ifTrue: [i _ i - 1]].
	"(dest digitAt: 1) printOn: aStream base: b."
	[pos > 0]
		whileTrue:
			[aStream nextPut: (Character digitValue: (digits at: pos)).
			pos _ pos - 1]! !

!Integer methodsFor: 'printing'!
radix: radix 
	"Answer a String representing the receiver as a base radix integer."

	^ self printStringBase: radix! !

!Integer methodsFor: 'printing' stamp: 'sma 5/20/2000 17:03'!
romanString	"1999 romanString"
	[self > 0] assert.
	^ String streamContents:
		[:s |
		self // 1000 timesRepeat: [s nextPut: $M].
		self romanDigits: 'MDC' for: 100 on: s.
		self romanDigits: 'CLX' for: 10 on: s.
		self romanDigits: 'XVI' for: 1 on: s]! !


!Integer methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:26'!
lastDigit
	"Answer the last digit of the integer base 256.  LargePositiveInteger uses bytes of base two number, and each is a 'digit'."

	^self digitAt: self digitLength! !

!Integer methodsFor: 'system primitives'!
replaceFrom: start to: stop with: replacement startingAt: repStart
	| j |  "Catches failure if LgInt replace primitive fails"
	j _ repStart.
	start to: stop do:
		[:i |
		self digitAt: i put: (replacement digitAt: j).
		j _ j+1]! !


!Integer methodsFor: 'private'!
copyto: x
	| stop |
	stop _ self digitLength min: x digitLength.
	^ x replaceFrom: 1 to: stop with: self startingAt: 1! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:41'!
digitAdd: arg 
	| len arglen accum sum |
	<primitive: 'primDigitAdd' module:'LargeIntegers'>
	accum _ 0.
	(len _ self digitLength) < (arglen _ arg digitLength) ifTrue: [len _ arglen].
	"Open code max: for speed"
	sum _ Integer new: len neg: self negative.
	1 to: len do: 
		[:i | 
		accum _ (accum bitShift: -8)
					+ (self digitAt: i) + (arg digitAt: i).
		sum digitAt: i put: (accum bitAnd: 255)].
	accum > 255
		ifTrue: 
			[sum _ sum growby: 1.
			sum at: sum digitLength put: (accum bitShift: -8)].
	^ sum! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:43'!
digitCompare: arg 
	"Compare the magnitude of self with that of arg.   
	Return a code of 1, 0, -1 for self >, = , < arg"
	| len arglen argDigit selfDigit |
	<primitive: 'primDigitCompare' module:'LargeIntegers'>
	len _ self digitLength.
	(arglen _ arg digitLength) ~= len
		ifTrue: [arglen > len
				ifTrue: [^ -1]
				ifFalse: [^ 1]].
	[len > 0]
		whileTrue: 
			[(argDigit _ arg digitAt: len) ~= (selfDigit _ self digitAt: len)
				ifTrue: [argDigit < selfDigit
						ifTrue: [^ 1]
						ifFalse: [^ -1]].
			len _ len - 1].
	^ 0! !

!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:28'!
digitDiv: arg neg: ng 
	"Answer with an array of (quotient, remainder)."
	| quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t |
	<primitive: 'primDigitDivNegative' module:'LargeIntegers'>
	arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	"TFEI added this line"
	l _ self digitLength - arg digitLength + 1.
	l <= 0 ifTrue: [^ Array with: 0 with: self].
	"shortcut against #highBit"
	d _ 8 - arg lastDigit highBitOfPositiveReceiver.
	div _ arg digitLshift: d.
	div _ div growto: div digitLength + 1.
	"shifts so high order word is >=128"
	rem _ self digitLshift: d.
	rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1].
	"makes a copy and shifts"
	quo _ Integer new: l neg: ng.
	dl _ div digitLength - 1.
	"Last actual byte of data"
	ql _ l.
	dh _ div digitAt: dl.
	dnh _ dl = 1
				ifTrue: [0]
				ifFalse: [div digitAt: dl - 1].
	1 to: ql do: 
		[:k | 
		"maintain quo*arg+rem=self"
		"Estimate rem/div by dividing the leading to bytes of rem by dh."
		"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
		j _ rem digitLength + 1 - k.
		"r1 _ rem digitAt: j."
		(rem digitAt: j)
			= dh
			ifTrue: [qhi _ qlo _ 15
				"i.e. q=255"]
			ifFalse: 
				["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.  
				Note that r1,r2 are bytes, not nibbles.  
				Be careful not to generate intermediate results exceeding 13  
				bits."
				"r2 _ (rem digitAt: j - 1)."
				t _ ((rem digitAt: j)
							bitShift: 4)
							+ ((rem digitAt: j - 1)
									bitShift: -4).
				qhi _ t // dh.
				t _ (t \\ dh bitShift: 4)
							+ ((rem digitAt: j - 1)
									bitAnd: 15).
				qlo _ t // dh.
				t _ t \\ dh.
				"Next compute (hi,lo) _ q*dnh"
				hi _ qhi * dnh.
				lo _ qlo * dnh + ((hi bitAnd: 15)
								bitShift: 4).
				hi _ (hi bitShift: -4)
							+ (lo bitShift: -8).
				lo _ lo bitAnd: 255.
				"Correct overestimate of q.  
				Max of 2 iterations through loop -- see Knuth vol. 2"
				r3 _ j < 3
							ifTrue: [0]
							ifFalse: [rem digitAt: j - 2].
				[(t < hi
					or: [t = hi and: [r3 < lo]])
					and: 
						["i.e. (t,r3) < (hi,lo)"
						qlo _ qlo - 1.
						lo _ lo - dnh.
						lo < 0
							ifTrue: 
								[hi _ hi - 1.
								lo _ lo + 256].
						hi >= dh]]
					whileTrue: [hi _ hi - dh].
				qlo < 0
					ifTrue: 
						[qhi _ qhi - 1.
						qlo _ qlo + 16]].
		"Subtract q*div from rem"
		l _ j - dl.
		a _ 0.
		1 to: div digitLength do: 
			[:i | 
			hi _ (div digitAt: i)
						* qhi.
			lo _ a + (rem digitAt: l) - ((hi bitAnd: 15)
							bitShift: 4) - ((div digitAt: i)
							* qlo).
			rem digitAt: l put: lo - (lo // 256 * 256).
			"sign-tolerant form of (lo bitAnd: 255)"
			a _ lo // 256 - (hi bitShift: -4).
			l _ l + 1].
		a < 0
			ifTrue: 
				["Add div back into rem, decrease q by 1"
				qlo _ qlo - 1.
				l _ j - dl.
				a _ 0.
				1 to: div digitLength do: 
					[:i | 
					a _ (a bitShift: -8)
								+ (rem digitAt: l) + (div digitAt: i).
					rem digitAt: l put: (a bitAnd: 255).
					l _ l + 1]].
		quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4)
				+ qlo].
	rem _ rem
				digitRshift: d
				bytes: 0
				lookfirst: dl.
	^ Array with: quo with: rem! !

!Integer methodsFor: 'private'!
digitLogic: arg op: op length: len
	| result neg1 neg2 rneg z1 z2 rz b1 b2 b |
	neg1 _ self negative.
	neg2 _ arg negative.
	rneg _ 
		((neg1 ifTrue: [-1] ifFalse: [0])
			perform: op 
			with: (neg2
					ifTrue: [-1]
					ifFalse: [0])) < 0.
	result _ Integer new: len neg: rneg.
	rz _ z1 _ z2 _ true.
	1 to: result digitLength do: 
		[:i | 
		b1 _ self digitAt: i.
		neg1 
			ifTrue: [b1 _ z1
						ifTrue: [b1 = 0
									ifTrue: [0]
									ifFalse: 
										[z1 _ false.
										256 - b1]]
						ifFalse: [255 - b1]].
		b2 _ arg digitAt: i.
		neg2 
			ifTrue: [b2 _ z2
						ifTrue: [b2 = 0
									ifTrue: [0]
									ifFalse: 
										[z2 _ false.
										256 - b2]]
						ifFalse: [255 - b2]].
		b _ b1 perform: op with: b2.
		b = 0
			ifTrue: 
				[result digitAt: i put: 0]
			ifFalse: 
				[result 
					digitAt: i 
					put: (rneg
							ifTrue: [rz ifTrue: 
											[rz _ false.
											256 - b]
										ifFalse: [255 - b]]
						ifFalse: [b])]].
	^ result normalize! !

!Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:30'!
digitLshift: shiftCount 
	| carry rShift mask len result digit byteShift bitShift highBit |
	(highBit _ self highBitOfMagnitude) = 0 ifTrue: [^ 0].
	len _ highBit + shiftCount + 7 // 8.
	result _ Integer new: len neg: self negative.
	byteShift _ shiftCount // 8.
	bitShift _ shiftCount \\ 8.
	bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts"
		^ result
			replaceFrom: byteShift + 1
			to: len
			with: self
			startingAt: 1].
	carry _ 0.
	rShift _ bitShift - 8.
	mask _ 255 bitShift: 0 - bitShift.
	1 to: byteShift do: [:i | result digitAt: i put: 0].
	1 to: len - byteShift do: 
		[:i | 
		digit _ self digitAt: i.
		result digitAt: i + byteShift put: (((digit bitAnd: mask)
				bitShift: bitShift)
				bitOr: carry).
		carry _ digit bitShift: rShift].
	^ result! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'!
digitMultiply: arg neg: ng 
	| prod prodLen carry digit k ab |
	<primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'>
	(arg digitLength = 1 and: [(arg digitAt: 1)
			= 0])
		ifTrue: [^ 0].
	(self digitLength = 1 and: [(self digitAt: 1)
			= 0])
		ifTrue: [^ 0].
	prodLen _ self digitLength + arg digitLength.
	prod _ Integer new: prodLen neg: ng.
	"prod starts out all zero"
	1 to: self digitLength do: [:i | (digit _ self digitAt: i) ~= 0
			ifTrue: 
				[k _ i.
				carry _ 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1"
				1 to: arg digitLength do: 
					[:j | 
					ab _ (arg digitAt: j)
								* digit + carry + (prod digitAt: k).
					carry _ ab bitShift: -8.
					prod digitAt: k put: (ab bitAnd: 255).
					k _ k + 1].
				prod digitAt: k put: carry]].
	^ prod normalize! !

!Integer methodsFor: 'private'!
digitRshift: anInteger bytes: b lookfirst: a 
	 "Shift right 8*b+anInteger bits, 0<=n<8.
	Discard all digits beyond a, and all zeroes at or below a."
	| n x r f m digit count i |
	n _ 0 - anInteger.
	x _ 0.
	f _ n + 8.
	i _ a.
	m _ 255 bitShift: 0 - f.
	digit _ self digitAt: i.
	[((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue:
		[x _ digit bitShift: f "Can't exceed 8 bits".
		i _ i - 1.
		digit _ self digitAt: i].
	i <= b ifTrue: [^Integer new: 0 neg: self negative].  "All bits lost"
	r _ Integer new: i - b neg: self negative.
	count _ i.
	x _ (self digitAt: b + 1) bitShift: n.
	b + 1 to: count do:
		[:j | digit _ self digitAt: j + 1.
		r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) 
			"Avoid values > 8 bits".
		x _ digit bitShift: n].
	^r! !

!Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'!
digitSubtract: arg 
	| smaller larger z sum sl al ng |
	<primitive: 'primDigitSubtract' module:'LargeIntegers'>
	sl _ self digitLength.
	al _ arg digitLength.
	(sl = al
		ifTrue: 
			[[(self digitAt: sl)
				= (arg digitAt: sl) and: [sl > 1]]
				whileTrue: [sl _ sl - 1].
			al _ sl.
			(self digitAt: sl)
				< (arg digitAt: sl)]
		ifFalse: [sl < al])
		ifTrue: 
			[larger _ arg.
			smaller _ self.
			ng _ self negative == false.
			sl _ al]
		ifFalse: 
			[larger _ self.
			smaller _ arg.
			ng _ self negative].
	sum _ Integer new: sl neg: ng.
	z _ 0.
	"Loop invariant is -1<=z<=1"
	1 to: sl do: 
		[:i | 
		z _ z + (larger digitAt: i) - (smaller digitAt: i).
		sum digitAt: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z _ z // 256].
	^ sum normalize! !

!Integer methodsFor: 'private'!
growby: n

	^self growto: self digitLength + n! !

!Integer methodsFor: 'private'!
growto: n

	^self copyto: (self species new: n)! !

!Integer methodsFor: 'private' stamp: 'sma 5/20/2000 17:00'!
romanDigits: digits for: base on: aStream
	| n |
	n _ self \\ (base * 10) // base.
	n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first].
	n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second].
	n > 4 ifTrue: [aStream nextPut: digits second].
	n \\ 5 timesRepeat: [aStream nextPut: digits last]! !


!Integer methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'!
benchFib  "Handy send-heavy benchmark"
	"(result // seconds to run) = approx calls per second"
	" | r t |
	  t _ Time millisecondsToRun: [r _ 26 benchFib].
	  (r * 1000) // t"
	"138000 on a Mac 8100/100"
	^ self < 2
		ifTrue: [1] 
		ifFalse: [(self-1) benchFib + (self-2) benchFib + 1]
! !

!Integer methodsFor: 'benchmarks' stamp: 'di 4/11/1999 11:20'!
benchmark  "Handy bytecode-heavy benchmark"
	"(500000 // time to run) = approx bytecodes per second"
	"5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000"
	"3059000 on a Mac 8100/100"
    | size flags prime k count |
    size _ 8190.
    1 to: self do:
        [:iter |
        count _ 0.
        flags _ (Array new: size) atAllPut: true.
        1 to: size do:
            [:i | (flags at: i) ifTrue:
                [prime _ i+1.
                k _ i + prime.
                [k <= size] whileTrue:
                    [flags at: k put: false.
                    k _ k + prime].
                count _ count + 1]]].
    ^ count! !

!Integer methodsFor: 'benchmarks' stamp: 'dwh 11/21/1999 16:40'!
tinyBenchmarks
	"Report the results of running the two tiny Squeak benchmarks.
	ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results"
	"0 tinyBenchmarks"
	"On a 292 MHz G3 Mac: 22727272 bytecodes/sec; 984169 sends/sec"
	"On a 400 MHz PII/Win98:  18028169 bytecodes/sec; 1081272 sends/sec"
	| t1 t2 r n1 n2 |
	n1 _ 1.
	[t1 _ Time millisecondsToRun: [n1 benchmark].
	t1 < 1000] whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)"

	n2 _ 28.
	[t2 _ Time millisecondsToRun: [r _ n2 benchFib].
	t2 < 1000] whileTrue:[n2 _ n2 + 1]. 
	"Note: #benchFib's runtime is about O(k^n),
		where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...."

	^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ',
	  ((r * 1000) // t2) printString, ' sends/sec'! !


!Integer methodsFor: 'tiles' stamp: 'RAA 8/24/1999 15:32'!
asPrecedenceName

	^#('unary' 'binary' 'keyword') at: self
! !

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

Integer class
	instanceVariableNames: ''!

!Integer class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'!
basicNew

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super basicNew! !

!Integer class methodsFor: 'instance creation'!
byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 
	"Depending on high-order byte copy directly into a LargeInteger,
	or build up a SmallInteger by shifting"
	| value |
	byte4 < 16r20 ifTrue:
		[^ (byte4 bitShift: 24)
		 + (byte3 bitShift: 16)
		 + (byte2 bitShift: 8)
		 + byte1].
	value _ LargePositiveInteger new: 4.
	value digitAt: 4 put: byte4.
	value digitAt: 3 put: byte3.
	value digitAt: 2 put: byte2.
	value digitAt: 1 put: byte1.
	^ value! !

!Integer class methodsFor: 'instance creation' stamp: 'sw 5/8/2000 11:05'!
initializedInstance
	^ 2468! !

!Integer class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 22:01'!
new

	self == Integer ifTrue: [
		^ self error: 'Integer is an abstract class.  Make a concrete subclass.'].
	^ super new! !

!Integer class methodsFor: 'instance creation'!
new: length neg: neg
	"Answer an instance of a large integer whose size is length. neg is a flag 
	determining whether the integer is negative or not."

	neg 
		ifTrue: [^LargeNegativeInteger new: length]
		ifFalse: [^LargePositiveInteger new: length]! !

!Integer class methodsFor: 'instance creation' stamp: 'jm 1/21/98 23:22'!
primesUpTo: max
	"Return a list of prime integers up to the given integer."
	"Integer primesUpTo: 100"

	| out limit flags prime k |
	out _ OrderedCollection new.
	limit _ max asInteger - 1.
	flags _ (Array new: limit) atAllPut: true.
	1 to: limit do: [:i |
		(flags at: i) ifTrue: [
			prime _ i + 1.
			k _ i + prime.
			[k <= limit] whileTrue: [
				flags at: k put: false.
				k _ k + prime].
			out add: prime]].
	^ out asArray
! !

!Integer class methodsFor: 'instance creation'!
readFrom: aStream 
	"Answer a new Integer as described on the stream, aStream.
	Embedded radix specifiers not allowed - use Number readFrom: for that."
	^self readFrom: aStream base: 10! !

!Integer class methodsFor: 'instance creation' stamp: 'ls 6/23/1999 20:37'!
readFrom: aStream base: base 
	"Answer an instance of one of my concrete subclasses. Initial minus sign 
	accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not 
	allowed--use Number readFrom: for that. Answer zero (not an error) if 
	there are no digits."

	| digit value neg startPos |
	neg _ aStream peekFor: $-.
	neg ifFalse: [aStream peekFor: $+].
	value _ 0.
	startPos _ aStream position.
	[aStream atEnd]
		whileFalse: 
			[digit _ aStream next digitValue.
			(digit < 0 or: [digit >= base])
				ifTrue: 
					[aStream skip: -1.
					aStream position = startPos ifTrue: [self error: 'At least one digit expected here'].
					neg ifTrue: [^ value negated].
					^ value]
				ifFalse: [value _ value * base + digit]].
	neg ifTrue: [^ value negated].
	^ value! !

!Integer class methodsFor: 'instance creation' stamp: 'di 4/30/1998 10:42'!
testBitLogic  "Integer testBitLogic"
	"This little suite of tests is designed to verify correct operation of most
	of Squeak's bit manipulation code, including two's complement
	representation of negative values.  It was written in a hurry and
	is probably lacking several important checks."

	"Shift 1 bit left then right and test for 1"
	| n |
	1 to: 100 do: [:i | ((1 bitShift: i) bitShift: i negated) = 1 ifFalse: [self error: 'Bit Logic Failure']].

	"Shift -1 left then right and test for 1"
	1 to: 100 do: [:i | ((-1 bitShift: i) bitShift: i negated) = -1 ifFalse: [self error: 'Bit Logic Failure']].

	"And a single bit with -1 and test for same value"
	1 to: 100 do: [:i | ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i) ifFalse: [self error: 'Bit Logic Failure']].

	"Verify that (n bitAnd: n negated) = n for single bits"
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				(n bitAnd: n negated) = n ifFalse: [self error: 'Bit Logic Failure']].

	"Verify that n negated = (n complemented + 1) for single bits"
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				n negated = ((n bitXor: -1) + 1) ifFalse: [self error: 'Bit Logic Failure']].

	"Verify that (n + n complemented) = -1 for single bits"
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				(n + (n bitXor: -1)) = -1 ifFalse: [self error: 'Bit Logic Failure']].

	"Verify that n negated = (n complemented +1) for single bits"
	1 to: 100 do: [:i | n _ 1 bitShift: i.
				n negated = ((n bitXor: -1) + 1) ifFalse: [self error: 'Bit Logic Failure']].
! !


!Integer class methodsFor: 'testing' stamp: 'sr 11/29/2000 14:41'!
testTwoComplementRightShift
	"self testTwoComplementRightShift"
	| large small |
	small _ 2 << 16.
	large _ 2 << 32.
	"2-complement test"
	(small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1)
		== ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))
		ifFalse: [^ self inform: 'ERROR: Two-complement shifts of negative Integers are NOT consistent!!'].
	(small bitShift: -1) ~= (small + 1 bitShift: -1)
		== ((large bitShift: -1) ~= (large + 1 bitShift: -1))
		ifFalse: [^ self inform: 'ERROR: Two-complement shifts of positive Integers are NOT consistent!!'].
	^ self inform: 'OK: Two-complement shifts of small and large Integers are consistent!!'.! !
ArrayedCollection variableWordSubclass: #IntegerArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!IntegerArray commentStamp: '<historical>' prior: 0!
IntegerArrays store 32bit signed Integer values.
Negative values are stored as 2's complement.!


!IntegerArray methodsFor: 'accessing'!
at: index
	| word |
	word _ self basicAt: index.
	word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations"
	^word >= 16r80000000	"Negative?!!"
		ifTrue:["word - 16r100000000"
				(word bitInvert32 + 1) negated]
		ifFalse:[word]! !

!IntegerArray methodsFor: 'accessing' stamp: 'jm 3/19/1999 09:35'!
at: index put: anInteger
	| word |
	anInteger < 0
		ifTrue:["word _ 16r100000000 + anInteger"
				word _ (anInteger + 1) negated bitInvert32]
		ifFalse:[word _ anInteger].
	self  basicAt: index put: word.
	^anInteger! !

!IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !


!IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'!
asIntegerArray
	^self! !

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

IntegerArray class
	instanceVariableNames: ''!

!IntegerArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:17'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !

!IntegerArray class methodsFor: 'plugin generation' stamp: 'acg 9/25/1999 15:00'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asIntPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isWords')! !

!IntegerArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:18'!
ccgDeclareCForVar: aSymbolOrString

	^'int *', aSymbolOrString! !
InterpreterPlugin subclass: #IntegerPokerPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-ObjectSocket'!
!IntegerPokerPlugin commentStamp: '<historical>' prior: 0!
a plugin that sticks the 4 bytes of a small integer into a string.  and read them back....


IntegerPokerPlugin translate.!


!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/26/2000 23:51'!
asCharacter: anInteger
	^anInteger 
! !

!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/26/2000 23:51'!
asInteger: aChar
	^aChar ! !

!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 00:12'!
cutOffForPositives
	"return the largest positive integer that we can encode"
	^1 << 30! !

!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 00:51'!
getInteger

	| stringOop stringData integer locationOop location |
	self export: true.
	self var: #stringData declareC: 'unsigned char *stringData'.
	self var: #location declareC: 'int location'.


	"decode the string to read it from"
	stringOop := (interpreterProxy stackValue: 1).
	(interpreterProxy isBytes: stringOop ) ifFalse: [
		interpreterProxy success: false.  ^nil ].
	stringData := (interpreterProxy arrayValueOf: stringOop).


	"decode the location"
	locationOop := (interpreterProxy stackValue: 0).
	(interpreterProxy isIntegerValue: locationOop) ifFalse: [
		interpreterProxy success: false.  ^nil ].
	location := interpreterProxy integerValueOf: locationOop.
	location := location - 1.
	location < 0 ifTrue: [
		interpreterProxy success: false. ^nil ].

	"check that the string has room"
	location + 4 > (interpreterProxy stSizeOf: stringOop) ifTrue: [
		interpreterProxy success: false.  ^nil ].

	"do the retrieval"
	integer := (stringData at: location) asInteger << 24.
	integer := (stringData at: location+1) asInteger << 16 + integer.
	integer := (stringData at: location+2) asInteger << 8 + integer.
	integer := (stringData at: location+3) asInteger + integer.

	"convert it to a negative number, if it's too large"
	integer > (self cutOffForPositives) ifTrue: [
		integer := (self cutOffForPositives) - integer ].

	"push the result"
	interpreterProxy pop: 2.
	interpreterProxy pushInteger: integer.! !

!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 00:05'!
negated: anInteger
	^-1 * anInteger! !

!IntegerPokerPlugin methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 00:51'!
putInteger

	| stringOop stringData integerOop integer locationOop location |
	self export: true.
	self var: #stringData declareC: 'unsigned char *stringData'.
	self var: #location declareC: 'int location'.


	"decode the string to store it into"
	stringOop := (interpreterProxy stackValue: 2).
	(interpreterProxy isBytes: stringOop ) ifFalse: [
		interpreterProxy success: false.  ^nil ].
	stringData := (interpreterProxy arrayValueOf: stringOop).

	"decode the integer to be stored"
	integerOop := (interpreterProxy stackValue: 1).
	(interpreterProxy isIntegerValue: integerOop) ifFalse: [
		interpreterProxy success: false.  ^nil ].
	integer := interpreterProxy integerValueOf: integerOop.


	"decode the location"
	locationOop := (interpreterProxy stackValue: 0).
	(interpreterProxy isIntegerValue: locationOop) ifFalse: [
		interpreterProxy success: false.  ^nil ].
	location := interpreterProxy integerValueOf: locationOop.
	location := location - 1.
	location < 0 ifTrue: [
		interpreterProxy success: false. ^nil ].

	"check that the string has room"
	location + 4 > (interpreterProxy stSizeOf: stringOop) ifTrue: [
		interpreterProxy success: false.  ^nil ].

	"check that the integer is reasonably sized"
	integer > (self cutOffForPositives) ifTrue: [
		interpreterProxy success: false. ^nil ].
	integer < (self cutOffForPositives) negated ifTrue: [
		interpreterProxy success: false. ^ nil ].

	"if the integer is negative, convert it to a large positive number"
	integer < 0 ifTrue: [
		integer := (self cutOffForPositives) - integer. ].

	"do the copy"
	stringData at: location+3 put: (integer \\ 256) asCharacter.
	stringData at: location+2 put: (integer >> 8 \\ 256) asCharacter.
	stringData at: location+1 put: (integer >> 16 \\ 256) asCharacter.
	stringData at: location+0 put: (integer >> 24 \\ 256) asCharacter.

	"all done"
	interpreterProxy pop: 2! !
RectangleMorph subclass: #InterimSoundMorph
	instanceVariableNames: 'graphic sound '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:30'!
addGraphic

	graphic _ SketchMorph withForm: self speakerGraphic.
	graphic position: bounds center - (graphic extent // 2).
	self addMorph: graphic.
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:26'!
handlesMouseDown: evt

	(graphic containsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 12/17/97 22:43'!
initialize

	super initialize.
	borderWidth _ 1.
	color _ Color r: 0 g: 0.8 b: 0.6.
	self extent: 30@30.
	self addGraphic.
	sound _ PluckedSound pitch: 880.0 dur: 2.0 loudness: 0.5.
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 18:56'!
mouseDown: evt

	(graphic containsPoint: evt cursorPoint)
		ifTrue: [sound copy play]
		ifFalse: [super mouseDown: evt].
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:02'!
sound

	^ sound
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:01'!
sound: aSound

	sound _ aSound.
! !

!InterimSoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/18/97 15:20'!
speakerGraphic

	^ Form
		extent: 19@18
		depth: 8
		fromArray: #(0 0 1493172224 2816 0 0 0 1493172224 11 0 0 138 1493172224 184549376 184549376 0 35509 2315255808 720896 720896 0 9090522 2315255808 2816 720896 0 2327173887 2315255819 2816 720896 138 3051028442 2315255819 2816 2816 1505080590 4294957786 2315255808 184549387 2816 3053453311 4292532917 1493172224 184549387 2816 1505080714 3048584629 1493172224 184549387 2816 9079434 3048584629 1493172224 184549387 2816 138 2327164341 1493172235 2816 2816 0 2324346293 1493172235 2816 720896 0 9079477 1493172224 2816 720896 0 35466 1493172224 720896 720896 0 138 0 184549376 184549376 0 0 0 11 0 0 0 0 2816 0)
		offset: 0@0
! !
ThreadNavigationMorph subclass: #InternalThreadNavigationMorph
	instanceVariableNames: 'threadName '
	classVariableNames: 'KnownThreads '
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/13/2000 08:44'!
acceptSortedContentsFrom: aHolder
	"Update my page list from the given page sorter."

	| nameOfThisProject |

	threadName isEmpty ifTrue: [threadName _ 'I need a name'].
	threadName _ FillInTheBlank 
		request: 'Name this thread.' 
		initialAnswer: threadName.
	threadName isEmptyOrNil ifTrue: [^self].
	listOfPages _ OrderedCollection new.
	aHolder submorphs doWithIndex: [:m :i |
		(nameOfThisProject _ m valueOfProperty: #nameOfThisProject) ifNotNil: [
			listOfPages add: {nameOfThisProject}.
		].
	].
	self class know: listOfPages as: threadName.
	self removeAllMorphs; addButtons.
	self world ifNil: [
		self openInWorld; positionAppropriately.
	].
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 20:16'!
addButtons

	| marginPt i sz data images pageNumber proj f m b1 b2 dot arrowWidth arrowCenter vertices arrowHeight allMorphicProjects nameMorph |

	allMorphicProjects _ Project allMorphicProjects.
	self changeNoLayout.
	self hResizing: #rigid. "... this is very unlikely..."
	self vResizing: #rigid.
	marginPt _ 4@4.
	i _ self currentIndex.
	sz _ 50@40.
	arrowWidth _ 14.
	arrowHeight _ 17.
	data _ {
		{i - 1. 'Previous:'. #previousPage. #rightCenter. arrowWidth negated}.
		{i + 1. 'Next:'. #nextPage. #leftCenter. arrowWidth}
	}.
	images _ data collect: [ :tuple |
		pageNumber _ tuple first.
		(pageNumber between: 1 and: listOfPages size) ifTrue: [
			proj _ Project named: (listOfPages at: pageNumber) first in: allMorphicProjects.
			f _ (self makeThumbnailFor: proj) scaledToSize: sz.
			arrowCenter _ f boundingBox perform: tuple fourth.
			vertices _ {
				arrowCenter - (0@arrowHeight).
				arrowCenter + (0@arrowHeight).
				arrowCenter + (tuple fifth @ 0).
			}.
			f getCanvas
				drawPolygon: vertices 
				color: Color orange 
				borderWidth: 0 
				borderColor: Color transparent.
			m _ ImageMorph new image: f.
			m setBalloonText: tuple second,' ',(listOfPages at: pageNumber) first.
			m addMouseUpActionWith: (
				MessageSend receiver: self selector: tuple third
			).
		] ifFalse: [
			f _ (Form extent: sz depth: 16) fillColor: Color lightGray.
			m _ ImageMorph new image: f.
		].
		m
	].
	b1 _ images first.
	b2 _ images second.
	dot _ EllipseMorph new extent: 16@16; color: Color orange lighter; borderWidth: 0.
	self addMorph: (b1 position: self position + marginPt).
	self addMorph: (b2 position: b1 topRight + (marginPt x @ 0)).
	self extent: b2 bottomRight - self position + marginPt.
	self addMorph: dot.
	dot align: dot center with: b1 bounds rightCenter + ((marginPt x @ 0) // 2).
	dot setBalloonText: threadName,'
more commands'.
	dot on: #mouseDown send: #moreCommands to: self.
	self fullBounds.
	self addMorph: (nameMorph _ SquishedNameMorph new).
	nameMorph
		target: self getSelector: #threadName setSelector: nil;
		color: Color transparent;
		width: self width;
		height: 15;
		align: nameMorph bottomLeft with: self bottomLeft.

! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 11:41'!
buttonForMenu

	^self makeButton: '?' balloonText: 'More commands' for: #moreCommands.
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 15:18'!
clickFromSorterEvent: evt morph: aMorph

	(aMorph bounds containsPoint: evt cursorPoint) ifFalse: [^self].
	evt isMouseUp ifFalse: [
		evt shiftPressed ifFalse: [^evt hand grabMorph: aMorph].
		^self
	].

	evt shiftPressed ifTrue: [
		(Project named: (aMorph valueOfProperty: #nameOfThisProject)) enter.
	].
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 19:09'!
currentIndex

	| currentName |

	currentName _ CurrentProjectRefactoring currentProjectName.
	listOfPages withIndexDo: [ :each :index |
		each first = currentName ifTrue: [^currentIndex _ index]
	].
	^currentIndex ifNil: [1]
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 15:31'!
deleteCurrentPage

	"no-op here"! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/2000 12:32'!
editThisThread

	| sz morphsForPageSorter sorter pixelsAvailable pixelsNeeded scale |

	"a bit of fudging to try to outguess the layout mechanism and get best possible scale"
	pixelsAvailable _ Display extent - 130.
	pixelsAvailable _ pixelsAvailable x * pixelsAvailable y.
	pixelsNeeded _ 100@75.
	pixelsNeeded _ pixelsNeeded x * pixelsNeeded y  * listOfPages size.
	scale _ (pixelsAvailable / pixelsNeeded min: 1) sqrt.
	sz _ (100@75 * scale) rounded.

	morphsForPageSorter _ self morphsForMyContentsSizedTo: sz.
	morphsForPageSorter _ morphsForPageSorter reject: [ :each | each isNil].
	sorter _ BookPageSorterMorph new.
	sorter changeExtent: Display extent.

	sorter
		book: self 
		morphsToSort: morphsForPageSorter.
	sorter pageHolder cursor: self currentIndex.
	self currentWorld addMorphFront: sorter.
	sorter align: sorter center with: self currentWorld center.

! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/2000 19:25'!
ensureSuitableDefaults

	listOfPages ifNil: [
		listOfPages _ Project allMorphicProjects collect: [ :each | {each name}].
		threadName _ 'all (default)'.
		self class know: listOfPages as: threadName.
	].
	currentIndex ifNil: [currentIndex _ 0].
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 11:51'!
getRecentThread

	self switchToThread: (
		ProjectHistory currentHistory mostRecentThread ifNil: [^self]
	)

! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 14:45'!
initialColor

	^(Color r: 0.27 g: 0.634 b: 0.365) alpha: 0.25! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:27'!
initialize

	super initialize.
	! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 11:08'!
insertNewProject

	| newProj me |

	[newProj _ Project newMorphicOn: nil.]
		on: ProjectViewOpenNotification
		do: [ :ex | ex resume: false].	

	me _ CurrentProjectRefactoring currentProjectName.

	listOfPages withIndexDo: [ :each :index |
		each first = me ifTrue: [
			listOfPages add: {newProj name} afterIndex: index.
			^self switchToThread: threadName
		].
	].
	listOfPages add: {newProj name} afterIndex: listOfPages size.
	^self switchToThread: threadName

! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 12:10'!
jumpToIndex: anInteger

	currentIndex _ anInteger.
	self loadPageWithProgress.! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 12:12'!
jumpWithinThread

	| aMenu me weHaveOthers |

	me _ CurrentProjectRefactoring currentProjectName.
	aMenu _ MenuMorph new defaultTarget: self.
	weHaveOthers _ false.
	listOfPages withIndexDo: [ :each :index |
		each first = me ifFalse: [
			weHaveOthers _ true.
			aMenu add: 'jump to <',each first,'>' selector: #jumpToIndex: argument: index.
		].
	].
	weHaveOthers ifFalse: [^self inform: 'This is the only project in this thread'].
	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 19:11'!
listOfPages: aCollection

	listOfPages _ aCollection.
	currentIndex _ nil.
	self currentIndex
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 19:29'!
loadPageWithProgress

	| projectInfo projectName |

	projectInfo _ listOfPages at: currentIndex.
	projectName _ projectInfo at: 1.
	loadedProject _ Project named: projectName.
	self class know: listOfPages as: threadName.
	WorldState addDeferredUIMessage: [
		InternalThreadNavigationMorph openThreadNamed: threadName
	].

	loadedProject ifNil: [
		ComplexProgressIndicator new 
			targetMorph: self;
			historyCategory: 'project loading';
			withProgressDo: [
				[
					loadedProject _ CurrentProjectRefactoring 
							currentFromMyServerLoad: projectName
				] 
					on: ProjectViewOpenNotification
					do: [ :ex | ex resume: false]		
						"we probably don't want a project view morph in this case"
			].
	].
	loadedProject ifNil: [
		^self inform: 'I cannot find that project'
	].
	self delete.

	loadedProject enter.
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 20:16'!
makeThumbnailFor: proj

	(proj isNil or: [proj thumbnail isNil]) ifTrue: [
		^(StringMorph contents: '???') imageForm
	].
	^proj thumbnail
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/31/2001 13:31'!
moreCommands

	| allThreads aMenu others |

	allThreads _ self class knownThreads.
	aMenu _ MenuMorph new defaultTarget: self.
	others _ (allThreads keys reject: [ :each | each = threadName]) asSortedCollection.
	others do: [ :each |
		aMenu add: 'switch to <',each,'>' selector: #switchToThread: argument: each.
	].
	aMenu 
		add: 'switch to recent projects' action: #getRecentThread;
		addLine;
		add: 'thread of all projects' action: #threadOfAllProjects;
		add: 'thread of no projects' action: #threadOfNoProjects;
		add: 'edit this thread' action: #editThisThread;
		addLine;
		add: 'First project in thread' action: #firstPage;
		add: 'Last project in thread' action: #lastPage;
		add: 'jump within this thread' action: #jumpWithinThread;
		add: 'insert new project' action: #insertNewProject;
		addLine;
		add: 'simply close this navigator' action: #delete.

	aMenu popUpEvent: self world primaryHand lastEvent in: self world! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 15:16'!
morphsForMyContentsSizedTo: sz

	| allMorphicProjects morphsForPageSorter proj pvm |

	allMorphicProjects _ Project allMorphicProjects.
	'Assembling thumbnail images...'
		displayProgressAt: self cursorPoint
		from: 0 to: listOfPages size
		during: [:bar |
			morphsForPageSorter _ listOfPages withIndexCollect: [ :each :index | 
				bar value: index.
				(proj _ Project named: each first in: allMorphicProjects) ifNil: [
					nil
				] ifNotNil: [
					pvm _ ProjectViewMorph on: proj.
					pvm _ pvm imageForm scaledToSize: sz.
					pvm _ pvm asMorph.
					pvm setProperty: #nameOfThisProject toValue: each first.
					pvm setBalloonText: each first.
					pvm on: #mouseDown send: #clickFromSorterEvent:morph: to: self.
					pvm on: #mouseUp send: #clickFromSorterEvent:morph: to: self.
					pvm
				]
			].
		].
	^morphsForPageSorter
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/12/2000 16:07'!
positionAppropriately

	| others otherRects overlaps |
	others _ self world submorphs select: [ :each | each ~~ self and: [each isKindOf: self class]].
	otherRects _ others collect: [ :each | each bounds].
	self align: self fullBounds bottomRight with: self world bottomRight.

	[
		overlaps _ false.
		otherRects do: [ :r |
			(r intersects: bounds) ifTrue: [overlaps _ true. self bottom: r top].
		].
		self top < self world top ifTrue: [
			self bottom: self world bottom.
			self right: self left - 1.
		].
		overlaps
	] whileTrue.! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 17:49'!
showMenuFor: actionSelector event: evt

	self perform: actionSelector
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/2000 15:15'!
step

	super step.
	self class knownThreads
		at: threadName
		ifPresent: [ :known |
			known == listOfPages ifFalse: [
				listOfPages _ known.
				self removeAllMorphs.
				self addButtons.
			].
		].
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 17:46'!
switchToThread: newName

	threadName _ newName.
	listOfPages _ self class knownThreads at: threadName.
	self removeAllMorphs.
	self addButtons.
	self currentIndex.
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 17:10'!
threadName

	^threadName! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:34'!
threadName: aString

	threadName _ aString! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/2000 19:24'!
threadOfAllProjects

	| nameList nav |

	nameList _ Project allMorphicProjects collect: [ :each | {each name}].
	nav _ self class basicNew.
	nav
		listOfPages: nameList;
		threadName: '';
		initialize.
	nav editThisThread.
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/12/2000 13:21'!
threadOfNoProjects

	| nameList nav |

	nameList _ { {CurrentProjectRefactoring currentProjectName} }.
	nav _ self class basicNew.
	nav
		listOfPages: nameList;
		threadName: '';
		initialize.
	nav editThisThread.
! !

!InternalThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 13:17'!
triggerActionFromPianoRoll

	| proj |

	WorldState addDeferredUIMessage: [
		self currentIndex >= listOfPages size ifTrue: [^1 beep].
		currentIndex _ self currentIndex + 1.
		proj _ Project named: ((listOfPages at: currentIndex) at: 1).
		proj world setProperty: #letTheMusicPlay toValue: true.
		proj enter.
	]! !

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

InternalThreadNavigationMorph class
	instanceVariableNames: ''!

!InternalThreadNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 17:12'!
know: listOfPages as: nameOfThread

	self knownThreads at: nameOfThread put: listOfPages.
! !

!InternalThreadNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 15:53'!
knownThreads

	^KnownThreads ifNil: [KnownThreads _ Dictionary new].
! !

!InternalThreadNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/12/2000 15:56'!
openThreadNamed: nameOfThread

	| coll nav |

	coll _ self knownThreads at: nameOfThread ifAbsent: [^self].
	nav _ World 
		submorphThat: [ :each | (each isKindOf: self) and: [each threadName = nameOfThread]]
		ifNone: [
			nav _ self basicNew.
			nav
				listOfPages: coll;
				threadName: nameOfThread;
				initialize;
				openInWorld;
				positionAppropriately.
			^self
		].
	nav
		listOfPages: coll;
		threadName: nameOfThread;
		removeAllMorphs;
		addButtons.

! !
Object subclass: #Interpolateable
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Misc'!
!Interpolateable commentStamp: '<historical>' prior: 0!
The Interpolateable class is a wrapper for instances that don't have interpolation methods provided for them (like Numbers).
!


!Interpolateable methodsFor: 'accessing' stamp: 'jsp 2/9/1999 16:21'!
setValue: aValue
	"Set the base interpolateable value."

	value _ aValue.! !


!Interpolateable methodsFor: 'interpolating' stamp: 'jsp 2/9/1999 16:18'!
interpolateTo: end at: amountDone
	"Interpolate between the instance and end after the specified amount has been done (0 - 1)."

	^ value + ((end - value) * amountDone).! !

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

Interpolateable class
	instanceVariableNames: 'value '!

!Interpolateable class methodsFor: 'instance creation' stamp: 'jsp 2/9/1999 16:20'!
value: aValue
	"Create and initialize a new interpolateable value."

	| newInterp |
	newInterp _ Interpolateable new.
	newInterp setValue: aValue.
	^ newInterp.
! !
ImageMorph subclass: #InterpolatingImageMorph
	instanceVariableNames: 'cachedImage '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!InterpolatingImageMorph commentStamp: '<historical>' prior: 0!
InterpolatingImageMorphs use bi-linear interpolation as provided by the Balloon 3D engine.!


!InterpolatingImageMorph methodsFor: 'accessing' stamp: 'ar 9/10/1999 15:01'!
image: newImage
	cachedImage _ nil.
	super image: newImage! !


!InterpolatingImageMorph methodsFor: 'drawing' stamp: 'ar 5/25/2000 17:59'!
cachedImageForDepth: aDepth
	(cachedImage ~~ nil and:[cachedImage depth = aDepth])
		ifTrue:[^cachedImage].
	cachedImage _ nil. "In case we need some space"
	cachedImage _ Form extent: self bounds extent depth: aDepth.
	self drawImage: image on: (cachedImage getCanvas).
	^cachedImage! !

!InterpolatingImageMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 12:23'!
drawImage: aForm on: aCanvas
	"Draw the given form onto the canvas using the Balloon 3D engine"
	| engine |
	engine _ (B3DRenderEngine defaultForPlatformOn: aCanvas form).
	engine == nil ifTrue:[^self].
	"Setup the engine"
	engine viewport: aCanvas form boundingBox.
	"Install the material to be used (using a plain white emission color)"
	engine material: (B3DMaterial new emission: Color white).
	"Install the texture"
	engine texture: aForm.
	"Draw the mesh"
	engine render: (B3DIndexedQuadMesh new plainTextureRect).
	"and finish"
	engine finish.! !

!InterpolatingImageMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:06'!
drawOn: aCanvas
	aCanvas paintImage: (self cachedImageForDepth: aCanvas depth) at: self topLeft! !


!InterpolatingImageMorph methodsFor: 'geometry' stamp: 'ar 9/10/1999 14:38'!
extent: extentPoint
	bounds extent = extentPoint ifFalse: [
		cachedImage _ nil.
		self changed.
		bounds _ bounds topLeft extent: extentPoint.
		self layoutChanged.
		self changed].
! !
ObjectMemory subclass: #Interpreter
	instanceVariableNames: 'activeContext theHomeContext method receiver instructionPointer stackPointer localIP localSP localHomeContext messageSelector argumentCount newMethod currentBytecode successFlag primitiveIndex methodCache atCache lkupClass reclaimableContextCount nextPollTick nextWakeupTick lastTick interruptKeycode interruptPending semaphoresToSignalA semaphoresUseBufferA semaphoresToSignalCountA semaphoresToSignalB semaphoresToSignalCountB savedWindowSize fullScreenFlag deferDisplayUpdates pendingFinalizationSignals compilerInitialized compilerHooks extraVMMemory newNativeMethod methodClass receiverClass interpreterVersion obsoleteIndexedPrimitiveTable obsoleteNamedPrimitiveTable interpreterProxy showSurfaceFn interruptCheckCounterFeedBackReset interruptChecksEveryNms externalPrimitiveTable '
	classVariableNames: 'ActiveProcessIndex AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BlockArgumentCountIndex BytecodeTable CacheProbeMax CallerIndex CharacterValueIndex CompilerHooksSize CrossedX DirBadPath DirEntryFound DirNoMoreEntries EndOfRun ExcessSignalsIndex FirstLinkIndex GenerateBrowserPlugin HeaderIndex HomeIndex InitialIPIndex InstanceSpecificationIndex InstructionPointerIndex JitterTable LastLinkIndex LiteralStart MaxExternalPrimitiveTableSize MaxPrimitiveIndex MessageArgumentsIndex MessageDictionaryIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodCacheClass MethodCacheEntries MethodCacheEntrySize MethodCacheMask MethodCacheMethod MethodCacheNative MethodCachePrim MethodCacheSelector MethodCacheSize MethodIndex MillisecondClockMask MyListIndex NextLinkIndex PrimitiveExternalCallIndex PrimitiveTable PriorityIndex ProcessListsIndex ReceiverIndex SelectorStart SemaphoresToSignalSize SenderIndex StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TempFrameStart ValueIndex XIndex YIndex '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!Interpreter commentStamp: '<historical>' prior: 0!
This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification.

It has been modernized with 32-bit pointers, better management of Contexts, and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers.

In addition to SmallInteger arithmetic and Floats, it supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case.

NOTE:  Here follows a list of things to be borne in mind when working on this code, or when making changes for the future.

1.  There are a number of things that should be done the next time we plan to release a copletely incompatible image format.  These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:.  Also, contexts should be given a special format code (see next item).

2.  There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change.  This is necessary because the oops may change during a compaction when the oops are being adjusted.  It's important to be aware of this when writing a new image using the systemTracer.  A better solution would be to reserve one of the format codes for Contexts only.

3.  We have made normal files tolerant to size and positions up to 32 bits.  This has not been done for async files, since they are still experimental.  The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes.

4.  Note that 0 is used in a couple of places as an impossible oop.  This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment).  The places include the method cache and the at cache. !


!Interpreter methodsFor: 'initialization' stamp: 'ikp 10/16/2000 15:16'!
initializeInterpreter: bytesToShift
	"Initialize Interpreter state before starting execution of a new image."

	interpreterProxy _ self sqGetInterpreterProxy.
	self initializeObjectMemory: bytesToShift.
	self initCompilerHooks.
	self flushExternalPrimitives.

	activeContext	_ nilObj.
	theHomeContext	_ nilObj.
	method			_ nilObj.
	receiver		_ nilObj.
	messageSelector	_ nilObj.
	newMethod		_ nilObj.
	methodClass		_ nilObj.
	lkupClass		_ nilObj.
	receiverClass	_ nilObj.

	self flushMethodCache.
	self loadInitialContext.
	interruptCheckCounter _ 0.
	interruptCheckCounterFeedBackReset _ 1000.
	interruptChecksEveryNms _ 5.
	nextPollTick _ 0.
	nextWakeupTick _ 0.
	lastTick _ 0.
	interruptKeycode _ 2094.  "cmd-."
	interruptPending _ false.
	semaphoresUseBufferA _ true.
	semaphoresToSignalCountA _ 0.
	semaphoresToSignalCountB _ 0.
	deferDisplayUpdates _ false.
	pendingFinalizationSignals _ 0.
! !

!Interpreter methodsFor: 'initialization'!
loadInitialContext

	| sched proc |
	sched _ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation).
	proc _ self fetchPointer: ActiveProcessIndex ofObject: sched.
	activeContext _ self fetchPointer: SuspendedContextIndex ofObject: proc.
	(activeContext < youngStart) ifTrue: [ self beRootIfOld: activeContext ].
	self fetchContextRegisters: activeContext.
	reclaimableContextCount _ 0.! !

!Interpreter methodsFor: 'initialization' stamp: 'ar 5/26/2000 21:47'!
moduleUnloaded: aModuleName
	"The module with the given name was just unloaded.
	Make sure we have no dangling references."
	self export: true.
	self var: #aModuleName type: 'char *'.
	(aModuleName strcmp: 'SurfacePlugin') = 0 ifTrue:[
		"Surface plugin went away. Should never happen. But then, who knows"
		showSurfaceFn _ 0.
	].! !


!Interpreter methodsFor: 'utilities'!
areIntegers: oop1 and: oop2

	^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 2/15/98 17:11'!
arrayValueOf: arrayOop
	"Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	self returnTypeC: 'void *'.
	((self isIntegerObject: arrayOop) not and:
	 [self isWordsOrBytes: arrayOop])
		ifTrue: [^ self cCode: '(void *) (arrayOop + 4)'].
	self primitiveFail.
! !

!Interpreter methodsFor: 'utilities'!
assertClassOf: oop is: classOop
	"Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."

	| ccIndex cl |
	self inline: true.
	(self isIntegerObject: oop)
		ifTrue: [ successFlag _ false. ^ nil ].

	ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
	ccIndex = 0
		ifTrue: [ cl _ ((self classHeader: oop) bitAnd: AllButTypeMask) ]
		ifFalse: [
			"look up compact class"
			cl _ (self fetchPointer: (ccIndex - 1)
					ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))].

	self success: cl = classOop.
! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 12/10/1998 19:18'!
booleanCheat: cond

	| bytecode offset |
	self inline: true.

	bytecode _ self fetchByte.  "assume next bytecode is jumpIfFalse (99%)"
	self internalPop: 2.
	(bytecode < 160 and: [bytecode > 151]) ifTrue: [  "short jumpIfFalse"
		cond
			ifTrue: [^ self fetchNextBytecode]
			ifFalse: [^ self jump: bytecode - 151]].

	bytecode = 172 ifTrue: [  "long jumpIfFalse"
		offset _ self fetchByte.
		cond
			ifTrue: [^ self fetchNextBytecode]
			ifFalse: [^ self jump: offset]].

	"not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
	localIP _ localIP - 1.
	self fetchNextBytecode.
	cond
		ifTrue: [self internalPush: trueObj]
		ifFalse: [self internalPush: falseObj].
! !

!Interpreter methodsFor: 'utilities'!
booleanValueOf: obj

	obj = trueObj ifTrue: [ ^ true ].
	obj = falseObj ifTrue: [ ^ false ].
	successFlag _ false.
	^ nil! !

!Interpreter methodsFor: 'utilities'!
checkedIntegerValueOf: intOop
	"Note: May be called by translated primitive code."

	(self isIntegerObject: intOop)
		ifTrue: [ ^ self integerValueOf: intOop ]
		ifFalse: [ self primitiveFail. ^ 0 ]! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 12/7/1998 07:35'!
externalizeIPandSP
	"Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop."

	instructionPointer _ self cCoerce: localIP to: 'int'.
	stackPointer _ self cCoerce: localSP to: 'int'.
	theHomeContext _ localHomeContext.
! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 2/15/98 17:11'!
fetchArray: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	| arrayOop |
	self returnTypeC: 'void *'.
	arrayOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self arrayValueOf: arrayOop
! !

!Interpreter methodsFor: 'utilities'!
fetchFloat: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| floatOop |
	self returnTypeC: 'double'.
	floatOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self floatValueOf: floatOop! !

!Interpreter methodsFor: 'utilities'!
fetchInteger: fieldIndex ofObject: objectPointer
	"Note: May be called by translated primitive code."

	| intOop |
	self inline: false.
	intOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOop)
		ifTrue: [ ^ self integerValueOf: intOop ]
		ifFalse: [ self primitiveFail. ^ 0 ]! !

!Interpreter methodsFor: 'utilities' stamp: 'di 4/3/1999 21:29'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
	"Note: May be called by translated primitive code."

	| intOrFloat floatVal frac trunc |
	self inline: false.
	self var: #floatVal declareC: 'double floatVal'.
	self var: #frac declareC: 'double frac'.
	self var: #trunc declareC: 'double trunc'.

	intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
	self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
	successFlag ifTrue: [
		self cCode: '' inSmalltalk: [floatVal _ Float new: 2].
		self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.
		self cCode: 'frac = modf(floatVal, &trunc)'.
		"the following range check is for C ints, with range -2^31..2^31-1"
		self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'].
	successFlag
		ifTrue: [^ self cCode: '((int) trunc)' inSmalltalk: [floatVal truncated]]
		ifFalse: [^ 0].
! !

!Interpreter methodsFor: 'utilities' stamp: 'di 4/3/1999 17:05'!
floatValueOf: oop
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| result |
	self returnTypeC: 'double'.
	self var: #result declareC: 'double result'.
	self assertClassOf: oop is: (self splObj: ClassFloat).
	successFlag
		ifTrue: [self cCode: '' inSmalltalk: [result _ Float new: 2].
				self fetchFloatAt: oop + BaseHeaderSize into: result]
		ifFalse: [result _ 0.0].
	^ result! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 12/7/1998 07:35'!
internalizeIPandSP
	"Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop."

	localIP _ self cCoerce: instructionPointer to: 'char *'.
	localSP _ self cCoerce: stackPointer to: 'char *'.
	localHomeContext _ theHomeContext.
! !

!Interpreter methodsFor: 'utilities' stamp: 'di 4/4/1999 00:00'!
loadFloatOrIntFrom: floatOrInt
	"If floatOrInt is an integer, then convert it to a C double float and return it.
	If it is a Float, then load its value and return it.
	Otherwise fail -- ie return with successFlag set to false."

	self inline: true.
	self returnTypeC: 'double'.

	(self isIntegerObject: floatOrInt) ifTrue:
		[^ self cCode: '((double) (floatOrInt >> 1))'
				inSmalltalk: [(self integerValueOf: floatOrInt) asFloat]].
	(self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat)
		ifTrue: [^ self floatValueOf: floatOrInt].
	successFlag _ false! !

!Interpreter methodsFor: 'utilities'!
makePointwithxValue: xValue yValue: yValue

	| pointResult |
	pointResult _ self instantiateSmallClass: (self splObj: ClassPoint)
							   sizeInBytes: 12
									   fill: nilObj.
	self storePointer: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
	self storePointer: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
	^ pointResult! !

!Interpreter methodsFor: 'utilities'!
quickFetchInteger: fieldIndex ofObject: objectPointer
	"Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed."

	^ self integerValueOf:
		(self fetchPointer: fieldIndex ofObject: objectPointer).! !

!Interpreter methodsFor: 'utilities'!
signExtend16: int16
	"Convert a signed 16-bit integer into a signed 32-bit integer value. The integer bit is not added here."

	(int16 bitAnd: 16r8000) = 0
		ifTrue: [ ^ int16 ]
		ifFalse: [ ^ int16 - 16r10000 ].! !

!Interpreter methodsFor: 'utilities' stamp: 'jm 2/16/98 11:13'!
sizeOfSTArrayFromCPrimitive: cPtr
	"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header start 4 bytes before that."
	"Note: Only called by translated primitive code."

	| oop |
	self var: #cPtr declareC: 'void *cPtr'.
	oop _ self cCode: '((int) cPtr) - 4'.
	(self isWordsOrBytes: oop) ifFalse: [
		self primitiveFail.
		^ 0].
	^ self lengthOf: oop
! !

!Interpreter methodsFor: 'utilities'!
storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
	"Note: May be called by translated primitive code."

	(self isIntegerValue: integerValue) ifTrue: [
		self storeWord: fieldIndex
			ofObject: objectPointer
			withValue: (self integerObjectOf: integerValue).
	] ifFalse: [
		self primitiveFail
	].! !

!Interpreter methodsFor: 'utilities' stamp: 'ikp 12/12/1998 14:35'!
transfer: count from: src to: dst

	| in out lastIn |
	self inline: true.
	in _ src - 4.
	lastIn _ in + (count * 4).
	out _ dst - 4.
	[in < lastIn] whileTrue: [
		self longAt: (out _ out + 4) put: (self longAt: (in _ in + 4)).
	].! !

!Interpreter methodsFor: 'utilities'!
transfer: count
	fromIndex: firstFrom ofObject: fromOop
	toIndex: firstTo ofObject: toOop
	"Assume: beRootIfOld: will be called on toOop."

	| fromIndex toIndex lastFrom |
	self inline: true.
	fromIndex _ fromOop + (firstFrom * 4).
	toIndex _ toOop + (firstTo * 4).
	lastFrom _ fromIndex + (count * 4).
	[fromIndex < lastFrom] whileTrue: [
		fromIndex _ fromIndex + 4.
		toIndex _ toIndex + 4.
		self longAt: toIndex put: (self longAt: fromIndex).
	].! !


!Interpreter methodsFor: 'object memory support' stamp: 'ikp 10/26/2000 17:46'!
mapInterpreterOops
	"Map all oops in the interpreter's state to their new values during garbage collection or a become: operation."
	"Assume: All traced variables contain valid oops."

	| oop |
	nilObj				_ self remap: nilObj.
	falseObj				_ self remap: falseObj.
	trueObj				_ self remap: trueObj.
	specialObjectsOop	_ self remap: specialObjectsOop.
	compilerInitialized ifFalse: [
		stackPointer 		_ stackPointer - activeContext.	"*rel to active"
		activeContext		_ self remap: activeContext.
		stackPointer 		_ stackPointer + activeContext.	"*rel to active"
		theHomeContext		_ self remap: theHomeContext.
	].
	instructionPointer 	_ instructionPointer - method.	"*rel to method"
	method				_ self remap: method.
	instructionPointer 	_ instructionPointer + method.	"*rel to method"
	receiver			_ self remap: receiver.
	messageSelector		_ self remap: messageSelector.
	newMethod			_ self remap: newMethod.
	methodClass			_ self remap: methodClass.
	lkupClass			_ self remap: lkupClass.
	receiverClass		_ self remap: receiverClass.

	1 to: remapBufferCount do: [ :i |
		oop _ remapBuffer at: i.
		(self isIntegerObject: oop) ifFalse: [
			remapBuffer at: i put: (self remap: oop).
		].
	].

	"The method cache uses oops as hashes -- toss the whole thing."
	self flushMethodCache.! !

!Interpreter methodsFor: 'object memory support' stamp: 'ikp 11/22/1999 12:13'!
markAndTraceInterpreterOops
	"Mark and trace all oops in the interpreter's state."
	"Assume: All traced variables contain valid oops."
	| oop |
	self compilerMarkHook.

	self markAndTrace: specialObjectsOop.
		"also covers nilObj, trueObj, falseObj, and compact classes"

	compilerInitialized
		ifTrue:
			[self markAndTrace: receiver.
			 self markAndTrace: method]
		ifFalse:
			[self markAndTrace: activeContext.  "traces entire stack"
				"also covers theHomeContext, receiver, method"].

	self markAndTrace: messageSelector.
	self markAndTrace: newMethod.
	self markAndTrace: methodClass.
	self markAndTrace: lkupClass.
	self markAndTrace: receiverClass.

	1 to: remapBufferCount do: [ :i |
		oop _ remapBuffer at: i.
		(self isIntegerObject: oop) ifFalse: [
			self markAndTrace: oop.
		].
	].! !

!Interpreter methodsFor: 'object memory support' stamp: 'ikp 11/22/1999 12:09'!
postGCAction
	"Mark the active and home contexts as roots if old. This allows the interpreter to use storePointerUnchecked to store into them."
	compilerInitialized
		ifTrue:
			[self compilerPostGC]
		ifFalse:
			[(activeContext    < youngStart) ifTrue: [ self beRootIfOld: activeContext ].
			 (theHomeContext < youngStart) ifTrue: [ self beRootIfOld: theHomeContext ]]
! !

!Interpreter methodsFor: 'object memory support' stamp: 'ikp 11/22/1999 12:10'!
preGCAction: fullGCFlag

	compilerInitialized
		ifTrue:
			[self compilerPreGC: fullGCFlag]
		ifFalse:
			[self storeContextRegisters: activeContext].! !


!Interpreter methodsFor: 'compiled methods' stamp: 'ar 10/13/1998 13:50'!
argumentCountOf: methodPointer
	^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r0F! !

!Interpreter methodsFor: 'compiled methods'!
headerOf: methodPointer
	^self fetchPointer: HeaderIndex
		ofObject: methodPointer! !

!Interpreter methodsFor: 'compiled methods'!
literal: offset
	^self literal: offset
		ofMethod: method! !

!Interpreter methodsFor: 'compiled methods'!
literal: offset ofMethod: methodPointer

	^ self fetchPointer: offset + LiteralStart ofObject: methodPointer
! !

!Interpreter methodsFor: 'compiled methods'!
literalCountOf: methodPointer
	^self literalCountOfHeader: (self headerOf: methodPointer)! !

!Interpreter methodsFor: 'compiled methods'!
literalCountOfHeader: headerPointer
	^ (headerPointer >> 10) bitAnd: 16rFF! !

!Interpreter methodsFor: 'compiled methods'!
methodClassOf: methodPointer

	^ self fetchPointer: ValueIndex ofObject:
		(self literal: (self literalCountOf: methodPointer) - 1
			ofMethod: methodPointer)! !

!Interpreter methodsFor: 'compiled methods' stamp: 'jm 9/18/97 21:06'!
primitiveIndexOf: methodPointer
	"Note: We now have 11 bits of primitive index, but they are in two places
	for temporary backward compatibility.  The time to unpack is negligible,
	since the reconstituted full index is stored in the method cache."
	| primBits |
	primBits _ ((self headerOf: methodPointer) >> 1) bitAnd: 16r300001FF.
	primBits > 16r1FF
		ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits >> 19)]
		ifFalse: [^ primBits]! !

!Interpreter methodsFor: 'compiled methods'!
primitiveNewMethod
	| header bytecodeCount class size theMethod literalCount |
	header _ self popStack.
	bytecodeCount _ self popInteger.
	self success: (self isIntegerObject: header).
	successFlag ifFalse: [self unPop: 2].
	class _ self popStack.
	size _ (self literalCountOfHeader: header) + 1 * 4 + bytecodeCount.
	theMethod _ self instantiateClass: class indexableSize: size.
	self storePointer: HeaderIndex ofObject: theMethod withValue: header.
	literalCount _ self literalCountOfHeader: header.
	1 to: literalCount do:
		[:i | self storePointer: i ofObject: theMethod withValue: nilObj].
	self push: theMethod! !


!Interpreter methodsFor: 'contexts' stamp: 'SqR 8/2/2000 16:47'!
argumentCountOfBlock: blockPointer

	| localArgCount |
	localArgCount _ self fetchPointer: BlockArgumentCountIndex
							ofObject: blockPointer.
	(self isIntegerObject: localArgCount)
		ifTrue: [ ^ self integerValueOf: localArgCount ]
		ifFalse: [ self primitiveFail. ^0 ].! !

!Interpreter methodsFor: 'contexts'!
caller
	^self fetchPointer: CallerIndex
		ofObject: activeContext! !

!Interpreter methodsFor: 'contexts'!
fetchContextRegisters: activeCntx
	"Note: internalFetchContextRegisters: should track changes to this method."

	| tmp |
	self inline: true.
	tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp) ifTrue: [
		"if the MethodIndex field is an integer, activeCntx is a block context"
		tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.
		(tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].
	] ifFalse: [
		"otherwise, it is a method context and is its own home context"
		tmp _ activeCntx.
	].
	theHomeContext _ tmp.
	receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.
	method _ self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to
		method oop + ip + BaseHeaderSize
		  -1 for 0-based addressing of fetchByte
		  -1 because it gets incremented BEFORE fetching currentByte"
	tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	instructionPointer _ method + tmp + BaseHeaderSize - 2.

	"the stack pointer is a pointer variable also..."
	tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	stackPointer _ activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4).! !

!Interpreter methodsFor: 'contexts' stamp: 'di 11/29/1998 16:24'!
fetchStackPointerOf: aContext
	"Return the stackPointer of a Context or BlockContext."
	| sp |
	self inline: true.
	sp _ self fetchPointer: StackPointerIndex ofObject: aContext.
	(self isIntegerObject: sp) ifFalse: [^ 0].
	^ self integerValueOf: sp! !

!Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 08:37'!
internalFetchContextRegisters: activeCntx
	"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."

	| tmp |
	self inline: true.
	tmp _ self fetchPointer: MethodIndex ofObject: activeCntx.
	(self isIntegerObject: tmp) ifTrue: [
		"if the MethodIndex field is an integer, activeCntx is a block context"
		tmp _ self fetchPointer: HomeIndex ofObject: activeCntx.
		(tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].
	] ifFalse: [
		"otherwise, it is a method context and is its own home context"
		tmp _ activeCntx.
	].
	localHomeContext _ tmp.
	receiver _ self fetchPointer: ReceiverIndex ofObject: tmp.
	method _ self fetchPointer: MethodIndex ofObject: tmp.

	"the instruction pointer is a pointer variable equal to
		method oop + ip + BaseHeaderSize
		  -1 for 0-based addressing of fetchByte
		  -1 because it gets incremented BEFORE fetching currentByte"
	tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
	localIP _ self cCoerce: method + tmp + BaseHeaderSize - 2 to: 'char *'.

	"the stack pointer is a pointer variable also..."
	tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
	localSP _ self cCoerce: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4) to: 'char *'.! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 15:55'!
internalNewActiveContext: aContext
	"The only difference between this method and newActiveContext: is that this method uses internal context registers."
	self inline: true.

	self internalStoreContextRegisters: activeContext.
	(aContext < youngStart) ifTrue: [ self beRootIfOld: aContext ].
	activeContext _ aContext.
	self internalFetchContextRegisters: aContext.! !

!Interpreter methodsFor: 'contexts'!
internalPop: nItems

	localSP _ localSP - (nItems * 4).! !

!Interpreter methodsFor: 'contexts'!
internalPop: nItems thenPush: oop

	self longAt: (localSP _ localSP - ((nItems - 1) * 4)) put: oop.
! !

!Interpreter methodsFor: 'contexts'!
internalPush: object

	self longAt: (localSP _ localSP + 4) put: object.! !

!Interpreter methodsFor: 'contexts'!
internalStackTop

	^ self longAt: localSP! !

!Interpreter methodsFor: 'contexts'!
internalStackValue: offset

	^ self longAt: localSP - (offset * 4)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 22:57'!
internalStoreContextRegisters: activeCntx
	"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + BaseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	self inline: true.
	self storeWord: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: 
			(localIP asInteger + 2 - (method + BaseHeaderSize))).
	self storeWord: StackPointerIndex		  ofObject: activeCntx
		withValue: (self integerObjectOf:
			(((localSP asInteger - (activeCntx + BaseHeaderSize)) >> 2) - TempFrameStart + 1)).
! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/18/1998 21:38'!
isContext: oop header: hdr
	"NOTE: anOop is assumed not to be an integer"
	| ccIndex theClass |
	self inline: true.
	ccIndex _ (hdr >> 12) bitAnd: 16r1F.
	ccIndex = 0
		ifTrue: [theClass _ (self classHeader: oop) bitAnd: AllButTypeMask]
		ifFalse: ["look up compact class"
				theClass _ self fetchPointer: ccIndex - 1
							ofObject: (self splObj: CompactClasses)].
	^ theClass = (self splObj: ClassMethodContext)
		or: [theClass = (self splObj: ClassBlockContext)]
! !

!Interpreter methodsFor: 'contexts' stamp: 'ikp 11/14/1999 23:44'!
isContextHeader: aHeader
	| ccIndex |
	self inline: true.
	ccIndex _ (aHeader >> 12) bitAnd: 16r1F.
	^ ccIndex = 13			"MethodContext"
		or: [ccIndex = 14		"BlockContext"
		or: [ccIndex = 4]]	"PseudoContext"! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/27/1998 23:32'!
isMethodContextHeader: aHeader
	self inline: true.
	^ ((aHeader >> 12) bitAnd: 16r1F) = 14! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 15:51'!
newActiveContext: aContext
	"Note: internalNewActiveContext: should track changes to this method."

	self storeContextRegisters: activeContext.
	(aContext < youngStart) ifTrue: [ self beRootIfOld: aContext ].
	activeContext _ aContext.
	self fetchContextRegisters: aContext.! !

!Interpreter methodsFor: 'contexts' stamp: 'di 11/30/1998 12:31'!
pop2AndPushIntegerIfOK: integerResult

	successFlag ifTrue:
		[(self isIntegerValue: integerResult)
			ifTrue: [self pop: 2 thenPush: (self integerObjectOf: integerResult)]
			ifFalse: [successFlag _ false]]! !

!Interpreter methodsFor: 'contexts'!
pop: nItems
	"Note: May be called by translated primitive code."

	stackPointer _ stackPointer - (nItems*4).! !

!Interpreter methodsFor: 'contexts'!
pop: nItems thenPush: oop

	| sp |
	self longAt: (sp _ stackPointer - ((nItems - 1) * 4)) put: oop.
	stackPointer _ sp.
! !

!Interpreter methodsFor: 'contexts'!
popInteger
	| integerPointer |
	integerPointer _ self popStack.
	(self isIntegerObject: integerPointer)
		ifTrue: [^ self integerValueOf: integerPointer]
		ifFalse: [successFlag _ false.
				^ 1  "in case need SOME integer prior to fail"]! !

!Interpreter methodsFor: 'contexts'!
popPos32BitInteger
	"May set successFlag, and return false if not valid"

	| top |
	top _ self popStack.
	^ self positive32BitValueOf: top! !

!Interpreter methodsFor: 'contexts'!
popStack

	| top |
	top _ self longAt: stackPointer.
	stackPointer _ stackPointer - 4.
	^ top! !

!Interpreter methodsFor: 'contexts'!
push: object

	| sp |
	self longAt: (sp _ stackPointer + 4) put: object.
	stackPointer _ sp.! !

!Interpreter methodsFor: 'contexts'!
pushBool: trueOrFalse

	trueOrFalse
		ifTrue: [ self push: trueObj ]
		ifFalse: [ self push: falseObj ].! !

!Interpreter methodsFor: 'contexts'!
pushInteger: integerValue
	self push: (self integerObjectOf: integerValue).! !

!Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 07:41'!
sender

	^ self fetchPointer: SenderIndex ofObject: localHomeContext! !

!Interpreter methodsFor: 'contexts' stamp: 'di 4/3/1999 21:26'!
stackFloatValue: offset
	"Note: May be called by translated primitive code."
	| result floatPointer |
	self returnTypeC: 'double'.
	self var: #result declareC: 'double result'.
	floatPointer _ self longAt: stackPointer - (offset*4).
	(self fetchClassOf: floatPointer) = (self splObj: ClassFloat) 
		ifFalse:[self primitiveFail. ^0.0].
	self cCode: '' inSmalltalk: [result _ Float new: 2].
	self fetchFloatAt: floatPointer + BaseHeaderSize into: result.
	^ result! !

!Interpreter methodsFor: 'contexts'!
stackIntegerValue: offset
	| integerPointer |
	integerPointer _ self longAt: stackPointer - (offset*4).
	(self isIntegerObject: integerPointer)
		ifTrue: [ ^self integerValueOf: integerPointer ]
		ifFalse: [ self primitiveFail. ^0 ]! !

!Interpreter methodsFor: 'contexts' stamp: 'jm 6/24/1998 17:59'!
stackObjectValue: offset
	"Ensures that the given object is a real object, not a SmallInteger."

	| oop |
	oop _ self longAt: stackPointer - (offset * 4).
	(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
	^ oop
! !

!Interpreter methodsFor: 'contexts'!
stackPointerIndex
	"Return the 0-based index rel to the current context.
	(This is what stackPointer used to be before conversion to pointer"
	^ (stackPointer - activeContext - BaseHeaderSize) >> 2! !

!Interpreter methodsFor: 'contexts'!
stackTop
	^self longAt: stackPointer! !

!Interpreter methodsFor: 'contexts'!
stackValue: offset
	^ self longAt: stackPointer - (offset*4)! !

!Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 13:39'!
storeContextRegisters: activeCntx
	"Note: internalStoreContextRegisters: should track changes to this method."

	"InstructionPointer is a pointer variable equal to
	method oop + ip + BaseHeaderSize
		-1 for 0-based addressing of fetchByte
		-1 because it gets incremented BEFORE fetching currentByte"

	self inline: true.
	self storeWord: InstructionPointerIndex ofObject: activeCntx
		withValue: (self integerObjectOf: 
			(instructionPointer - method - (BaseHeaderSize - 2))).
	self storeWord: StackPointerIndex		  ofObject: activeCntx
		withValue: (self integerObjectOf:
			(self stackPointerIndex - TempFrameStart + 1)).
! !

!Interpreter methodsFor: 'contexts'!
storeInstructionPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storeWord: InstructionPointerIndex
		ofObject: contextPointer
		withValue: (self integerObjectOf: value).! !

!Interpreter methodsFor: 'contexts'!
storeStackPointerValue: value inContext: contextPointer
	"Assume: value is an integerValue"

	self storeWord: StackPointerIndex
		ofObject: contextPointer
		withValue: (self integerObjectOf: value).! !

!Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 07:42'!
temporary: offset

	^ self fetchPointer: offset + TempFrameStart ofObject: localHomeContext! !

!Interpreter methodsFor: 'contexts'!
unPop: nItems
	stackPointer _ stackPointer + (nItems*4)! !


!Interpreter methodsFor: 'object format' stamp: 'ar 3/21/98 02:37'!
fixedFieldsOf: oop format: fmt length: wordLength
"
	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
	When we revise the image format, it should become...
	^ (classFormat >> 2 bitAnd: 16rFF) - 1
"
	| class classFormat |
	self inline: true.
	((fmt > 4) or: [fmt = 2]) ifTrue: [^ 0].  "indexable fields only"
	fmt < 2 ifTrue: [^ wordLength].  "fixed fields only (zero or more)"
	
	"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
	class _ self fetchClassOf: oop.
	classFormat _ self formatOfClass: class.
	^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
! !

!Interpreter methodsFor: 'object format'!
formatOfClass: classPointer
	"**should be in-lined**"
	"Note that, in Smalltalk, the instSpec will be equal to the inst spec
	part of the base header of an instance (without hdr type) shifted left 1.
	In this way, apart from the smallInt bit, the bits
	are just where you want them for the first header word."
	"Callers expect low 2 bits (header type) to be zero!!"

	^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1! !

!Interpreter methodsFor: 'object format' stamp: 'ar 3/23/98 22:52'!
nonWeakFieldsOf: oop
	"Return the number of non-weak fields in oop (i.e. the number of fixed fields).
	Note: The following is copied from fixedFieldsOf:format:length: since we do know
	the format of the oop (e.g. format = 4) and thus don't need the length."
	| class classFormat |
	self inline: false. "No need to inline - we won't call this often"

	(self isWeak: oop) ifFalse:[self error:'Called fixedFieldsOfWeak: with a non-weak oop'].

	"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
	class _ self fetchClassOf: oop.
	classFormat _ self formatOfClass: class.
	^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1
! !


!Interpreter methodsFor: 'message sending' stamp: 'ikp 10/26/2000 15:57'!
activateNewMethod
	| newContext methodHeader initialIP tempCount nilOop |
	methodHeader _ self headerOf: newMethod.
	newContext _ self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).

	initialIP _ ((LiteralStart + (self literalCountOfHeader: methodHeader)) * 4) + 1.
	tempCount _ (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."

	self storePointerUnchecked: SenderIndex	ofObject: newContext
		withValue: activeContext.
	self storeWord: InstructionPointerIndex	ofObject: newContext
		withValue: (self integerObjectOf: initialIP).
	self storeWord: StackPointerIndex			ofObject: newContext
		withValue: (self integerObjectOf: tempCount).
	self storePointerUnchecked: MethodIndex ofObject: newContext
		withValue: newMethod.

	"Copy the reciever and arguments..."
	0 to: argumentCount do:
		[:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext
			withValue: (self stackValue: argumentCount-i)].

	"clear remaining temps to nil in case it has been recycled"
	nilOop _ nilObj.
	argumentCount+1 to: tempCount do:
		[:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext
			withValue: nilOop].

	self pop: argumentCount + 1.
	reclaimableContextCount _ reclaimableContextCount + 1.
	self newActiveContext: newContext.! !

!Interpreter methodsFor: 'message sending'!
argCount
	^ argumentCount! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 11/20/1999 05:05'!
createActualMessageTo: aClass
	"Bundle up the selector, arguments and lookupClass into a Message object.
	In the process it pops the arguments off the stack, and pushes the message object.
	This can then be presented as the argument of e.g. #doesNotUnderstand:.
	ikp 11/20/1999 03:59 -- added hook for external runtime compilers."

	| argumentArray message lookupClass |
	"remap lookupClass in case GC happens during allocation"
	self pushRemappableOop: aClass.
	argumentArray _ self instantiateClass: (self splObj: ClassArray)
							indexableSize: argumentCount.
	"remap argumentArray in case GC happens during allocation"
	self pushRemappableOop: argumentArray.
	message _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	argumentArray _ self popRemappableOop.
	lookupClass _ self popRemappableOop.

	self beRootIfOld: argumentArray.

	compilerInitialized
		ifTrue:
			[self compilerCreateActualMessage: message storingArgs: argumentArray]
		ifFalse:
			[self transfer: argumentCount
				from: stackPointer - ((argumentCount - 1) * 4)
				to: argumentArray + BaseHeaderSize.
			 self pop: argumentCount thenPush: message].
	argumentCount _ 1.

	self storePointer: MessageSelectorIndex ofObject: message
		withValue: messageSelector.
	self storePointer: MessageArgumentsIndex ofObject: message
		withValue: argumentArray.
	(self lastPointerOf: message) >= (MessageLookupClassIndex*4 +BaseHeaderSize) ifTrue:
	["Only store lookupClass if message has 3 fields (old images don't)"
	self storePointer: MessageLookupClassIndex ofObject: message
		withValue: lookupClass].! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 1/3/1999 17:29'!
executeNewMethod

	primitiveIndex > 0 ifTrue: [
		self primitiveResponse.
		successFlag ifTrue: [^ nil]].

	"if not primitive, or primitive failed, activate the method"
	self activateNewMethod.

	"check for possible interrupts at each real send"
	self quickCheckForInterrupts.
! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 10/27/2000 14:11'!
findNewMethodInClass: class
	"Find the compiled method to be run when the current messageSelector is sent to the given class, setting the values of 'newMethod' and 'primitiveIndex'."
	| ok |
	self inline: false.
	ok _ self lookupInMethodCacheSel: messageSelector class: class.
	ok ifFalse: [
		"entry was not found in the cache; look it up the hard way"
		self lookupMethodInClass: class.
		lkupClass _ class.
		self addNewMethodToCache.
	].
! !

!Interpreter methodsFor: 'message sending' stamp: 'JMM 11/21/2000 16:22'!
internalActivateNewMethod
	| methodHeader newContext tempCount argCount2 needsLarge |
	self inline: true.

	methodHeader _ self headerOf: newMethod.
	needsLarge _ methodHeader bitAnd: LargeContextBit.
	(needsLarge = 0 and: [freeContexts ~= NilContext])
		ifTrue: [newContext _ freeContexts.
				freeContexts _ self fetchPointer: 0 ofObject: newContext]
		ifFalse: ["Slower call for large contexts or empty free list"
				self externalizeIPandSP.
				newContext _ self allocateOrRecycleContext: needsLarge.
				self internalizeIPandSP].
	tempCount _ (methodHeader >> 19) bitAnd: 16r3F.

	"Assume: newContext will be recorded as a root if necessary by the
	 call to newActiveContext: below, so we can use unchecked stores."

	self storePointerUnchecked: SenderIndex	ofObject: newContext
		withValue: activeContext.
	self storeWord: InstructionPointerIndex	ofObject: newContext
		withValue: (self integerObjectOf:
			(((LiteralStart + (self literalCountOfHeader: methodHeader)) * 4) + 1)).
	self storeWord: StackPointerIndex			ofObject: newContext
		withValue: (self integerObjectOf: tempCount).
	self storePointerUnchecked: MethodIndex ofObject: newContext
		withValue: newMethod.

	"Copy the reciever and arguments..."
	argCount2 _ argumentCount.
	0 to: argCount2 do:
		[:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext
			withValue: (self internalStackValue: argCount2-i)].

	"clear remaining temps to nil in case it has been recycled"
	methodHeader _ nilObj.  "methodHeader here used just as faster (register?) temp"
	argCount2+1 to: tempCount do:
		[:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext
			withValue: methodHeader].

	self internalPop: argCount2 + 1.
	reclaimableContextCount _ reclaimableContextCount + 1.
	self internalNewActiveContext: newContext.
! !

!Interpreter methodsFor: 'message sending' stamp: 'SqR 8/2/2000 16:52'!
internalExecuteNewMethod
	| localPrimIndex |
	self inline: true.

	localPrimIndex _ primitiveIndex.
	localPrimIndex > 0
		ifTrue: [(localPrimIndex > 255 and: [localPrimIndex < 520])
				ifTrue: ["Internal return instvars"
						localPrimIndex >= 264
						ifTrue:
						[^ self internalPop: 1 thenPush:
								(self fetchPointer: localPrimIndex-264
										ofObject: self internalStackTop)]
						ifFalse:
						["Internal return constants"
						localPrimIndex = 256 ifTrue: [^ nil "^ self"].
						localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: trueObj].
						localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: falseObj].
						localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: nilObj].
						^ self internalPop: 1 thenPush: (self integerObjectOf: localPrimIndex-261)]]
				ifFalse: 	[self externalizeIPandSP.
						self primitiveResponse.
						self internalizeIPandSP.
						successFlag ifTrue: [^ nil]]].

	"if not primitive, or primitive failed, activate the method"
	self internalActivateNewMethod.

	"check for possible interrupts at each real send"
	self internalQuickCheckForInterrupts.
! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 10/27/2000 14:11'!
internalFindNewMethod
	"Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'."
	| ok | 
	self inline: true.
	self sharedCodeNamed: 'commonLookup' inCase: 131.

	ok _ self lookupInMethodCacheSel: messageSelector class: lkupClass.
	ok ifFalse: [
		"entry was not found in the cache; look it up the hard way"
		self externalizeIPandSP.
		self lookupMethodInClass: lkupClass.
		self internalizeIPandSP.
		self addNewMethodToCache].
! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 10/24/1999 03:58'!
lookupMethodInClass: class
	| currentClass dictionary found rclass |
	self inline: false.

	currentClass _ class.
	[currentClass ~= nilObj]
		whileTrue:
		[dictionary _ self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
		dictionary = nilObj ifTrue:
			["MethodDict pointer is nil (hopefully due a swapped out stub)
				-- raise exception #cannotInterpret:."
			self pushRemappableOop: currentClass.  "may cause GC!!"
			self createActualMessageTo: class.
			currentClass _ self popRemappableOop.
			messageSelector _ self splObj: SelectorCannotInterpret.
			^ self lookupMethodInClass: (self superclassOf: currentClass)].
		found _ self lookupMethodInDictionary: dictionary.
		found ifTrue: [^ methodClass _ currentClass].
		currentClass _ self superclassOf: currentClass].

	"Could not find #doesNotUnderstand: -- unrecoverable error."
	messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue:
		[self error: 'Recursive not understood error encountered'].

	"Cound not find a normal message -- raise exception #doesNotUnderstand:"
	self pushRemappableOop: class.  "may cause GC!!"
	self createActualMessageTo: class.
	rclass _ self popRemappableOop.
	messageSelector _ self splObj: SelectorDoesNotUnderstand.
	^ self lookupMethodInClass: rclass! !

!Interpreter methodsFor: 'message sending' stamp: 'di 12/4/1998 15:02'!
lookupMethodInDictionary: dictionary
	"This method lookup tolerates integers as Dictionary keys to support
	execution of images in which Symbols have been compacted out"
 	| length index mask wrapAround nextSelector methodArray |
	self inline: true.
	length _ self fetchWordLengthOf: dictionary.
	mask _ length - SelectorStart - 1.
	(self isIntegerObject: messageSelector)
		ifTrue:
		[index _ (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]
		ifFalse:
		[index _ (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
	"It is assumed that there are some nils in this dictionary, and search will
	stop when one is encountered.  However, if there are no nils, then wrapAround
	will be detected the second time the loop gets to the end of the table."
	wrapAround _ false.
	[true] whileTrue:
		[nextSelector _ self fetchPointer: index
					ofObject: dictionary.
		nextSelector=nilObj ifTrue: [^false].
		nextSelector=messageSelector
			ifTrue: [methodArray _ self fetchPointer: MethodArrayIndex
							ofObject: dictionary.
				newMethod _ self fetchPointer:  index - SelectorStart
							ofObject: methodArray.
				primitiveIndex _ self primitiveIndexOf: newMethod.
				primitiveIndex > MaxPrimitiveIndex ifTrue:
					["If primitiveIndex is out of range, set to zero before putting in cache.
						This is equiv to primFail, and avoids the need to check on every send."
					primitiveIndex _ 0].
				^ true].
		index _ index + 1.
		index = length
			ifTrue: [wrapAround ifTrue: [^false].
				wrapAround _ true.
				index _ SelectorStart]]! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 11/14/1999 23:52'!
normalSend
	"Send a message, starting lookup with the receiver's class."
	"Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
	"Note: This method is inlined into the interpreter dispatch loop."

	| rcvr |
	self inline: true.
	self sharedCodeNamed: 'commonSend' inCase: 131.

	rcvr _ self internalStackValue: argumentCount.
	receiverClass _ lkupClass _ self fetchClassOf: rcvr.
	self internalFindNewMethod.
	self internalExecuteNewMethod.
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'message sending'!
specialSelector: index

	^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)! !

!Interpreter methodsFor: 'message sending'!
superclassOf: classPointer

	^ self fetchPointer: SuperclassIndex ofObject: classPointer! !

!Interpreter methodsFor: 'message sending' stamp: 'ikp 11/14/1999 23:55'!
superclassSend
	"Send a message to self, starting lookup with the superclass of the class containing the currently executing method."
	"Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack,"
	"Note: This method is inlined into the interpreter dispatch loop."
	| rcvr |
	self inline: true.
	self sharedCodeNamed: 'commonSupersend' inCase: 133.

	lkupClass _ self superclassOf: (self methodClassOf: method).
	rcvr _ self internalStackValue: argumentCount.
	receiverClass _ self fetchClassOf: rcvr.
	self internalFindNewMethod.
	self internalExecuteNewMethod.
	self fetchNextBytecode.
! !


!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 10/24/1999 04:17'!
addNewMethodToCache
	"Add the given entry to the method cache.
	The policy is as follows:
		Look for an empty entry anywhere in the reprobe chain.
		If found, install the new entry there.
		If not found, then install the new entry at the first probe position
			and delete the entries in the rest of the reprobe chain.
		This has two useful purposes:
			If there is active contention over the first slot, the second
				or third will likely be free for reentry after ejection.
			Also, flushing is good when reprobe chains are getting full."
	| probe hash |
	self inline: false.
	self compilerTranslateMethodHook.	"newMethod x lkupClass -> newNativeMethod (may cause GC !!)"
	hash _ messageSelector bitXor: lkupClass.  "drop low-order zeros from addresses"

	0 to: CacheProbeMax-1 do:
		[:p | probe _ (hash >> p) bitAnd: MethodCacheMask.
		(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
				["Found an empty entry -- use it"
				methodCache at: probe + MethodCacheSelector put: messageSelector.
				methodCache at: probe + MethodCacheClass put: lkupClass.
				methodCache at: probe + MethodCacheMethod put: newMethod.
				methodCache at: probe + MethodCachePrim put: primitiveIndex.
				methodCache at: probe + MethodCacheNative put: newNativeMethod.
				^ nil]].

	"OK, we failed to find an entry -- install at the first slot..."
	probe _ hash bitAnd: MethodCacheMask.  "first probe"
	methodCache at: probe + MethodCacheSelector put: messageSelector.
	methodCache at: probe + MethodCacheClass put: lkupClass.
	methodCache at: probe + MethodCacheMethod put: newMethod.
	methodCache at: probe + MethodCachePrim put: primitiveIndex.
	methodCache at: probe + MethodCacheNative put: newNativeMethod.

	"...and zap the following entries"
	1 to: CacheProbeMax-1 do:
		[:p | probe _ (hash >> p) bitAnd: MethodCacheMask.
		methodCache at: probe + MethodCacheSelector put: 0].
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'di 12/12/1998 23:37'!
flushMethodCache
	"Flush the method cache. The method cache is flushed on every programming change and garbage collect."

	1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ].
	1 to: AtCacheTotalSize do: [ :i | atCache at: i put: 0 ].
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'ikp 10/24/1999 03:20'!
lookupInMethodCacheSel: selector class: class
	"This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false."
	"About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
	"WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."

	| hash probe |
	self inline: true.
	hash _ selector bitXor: class.  "shift drops two low-order zeros from addresses"

	probe _ hash bitAnd: MethodCacheMask.  "first probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			^ true	"found entry in cache; done"].

	probe _ (hash >> 1) bitAnd: MethodCacheMask.  "second probe"
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			^ true	"found entry in cache; done"].

	probe _ (hash >> 2) bitAnd: MethodCacheMask.
	(((methodCache at: probe + MethodCacheSelector) = selector) and:
		 [(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
			[newMethod _ methodCache at: probe + MethodCacheMethod.
			primitiveIndex _ methodCache at: probe + MethodCachePrim.
			newNativeMethod _ methodCache at: probe + MethodCacheNative.
			^ true	"found entry in cache; done"].

	^ false
! !

!Interpreter methodsFor: 'method lookup cache' stamp: 'len 8/2/2000 16:39'!
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex 
	"Rewrite an existing entry in the method cache with a new primitive   
	index."
	| probe hash |
	self inline: false.
	hash _ selector bitXor: class.
	0 to: CacheProbeMax - 1 do: 
		[:p | 
		probe _ hash >> p bitAnd: MethodCacheMask.
		((methodCache at: probe + MethodCacheSelector)
			= selector and: [(methodCache at: probe + MethodCacheClass)
				= class])
			ifTrue: 
				[methodCache at: probe + MethodCachePrim put: localPrimIndex.
				^ nil]]! !


!Interpreter methodsFor: 'interpreter shell'!
fetchByte
	"This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator."

	^ self byteAt: localIP preIncrement! !

!Interpreter methodsFor: 'interpreter shell' stamp: 'jm 12/10/1998 16:44'!
fetchNextBytecode
	"This method fetches the next instruction (bytecode). Each bytecode method is responsible for fetching the next bytecode, preferably as early as possible to allow the memory system time to process the request before the next dispatch."

	currentBytecode _ self fetchByte.
! !

!Interpreter methodsFor: 'interpreter shell'!
getCurrentBytecode
	"currentBytecode will be private to the main dispatch loop in the generated code. This method allows the currentBytecode to be retrieved from global variables."

	^ self byteAt: instructionPointer! !

!Interpreter methodsFor: 'interpreter shell' stamp: 'jm 5/30/2000 08:28'!
interpret
	"This is the main interpreter loop. It normally loops forever, fetching and executing bytecodes. When running in the context of a browser plugin VM, however, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap. Since this is the case at the moment that a check for interrupts is performed, that is when we return to the browser if it is time to do so. Interrupt checks happen quite frequently."

	"record entry time when running as a browser plug-in"
	GenerateBrowserPlugin ifTrue: [self plugInSetStartTime].

	self internalizeIPandSP.
	self fetchNextBytecode.
	[true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable].
	localIP _ localIP - 1.  "undo the pre-increment of IP before returning"
	self externalizeIPandSP.
! !

!Interpreter methodsFor: 'interpreter shell'!
unknownBytecode
	"This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."

	self error: 'Unknown bytecode'.! !


!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:42'!
duplicateTopBytecode

	self fetchNextBytecode.
	self internalPush: self internalStackTop.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:46'!
experimentalBytecode
	"Note: This bytecode is not currently generated by the compiler."
	"This range of six bytecodes can replace the pushTemporaryVariable[0..5] bytecode at the beginning of a sequence of either the form:
		pushTemp
		pushTemp | pushConstantOne | pushLiteralConstant
		<=
		longJumpIfFalse
or the form:
		pushTemp
		pushTemp | pushConstantOne | pushLiteralConstant
		+
		popIntoTemp (optional)

If two values pushed are not small integers, this bytecode acts like the pushTemp bytecode it replaces. However, if they are small integers, then the given arithmetic or comparison operation is performed. The result of that operation is either pushed onto the stack or, if one of the expected bytecodes follows it, then that bytecode is performed immediately. In such cases, the entire four instruction sequence is performed without doing any stack operations."

	| arg1 byte2 byte3 byte4 arg1Val arg2Val result offset |
	arg1 _ self temporary: currentBytecode - 138.
	byte2 _ self byteAt: localIP + 1.  "fetch ahead"
	byte3 _ self byteAt: localIP + 2.  "fetch ahead"
	byte4 _ self byteAt: localIP + 3.  "fetch ahead"

	"check first arg"
	(self isIntegerObject: arg1) ifTrue: [
		arg1Val _ self integerValueOf: arg1.
	] ifFalse: [
		self fetchNextBytecode.
		^ self internalPush: arg1.  "abort; first arg is not an integer"
	].

	"get and check second arg"
	byte2 < 32 ifTrue: [
		arg2Val _ self temporary: (byte2 bitAnd: 16rF).
		(self isIntegerObject: arg2Val) ifTrue: [
			arg2Val _ self integerValueOf: arg2Val.
		] ifFalse: [
			self fetchNextBytecode.
			^ self internalPush: arg1.  "abort; second arg is not an integer"
		].
	] ifFalse: [
		byte2 > 64 ifTrue: [
			arg2Val _ 1.
		] ifFalse: [
			arg2Val _ self literal: (byte2 bitAnd: 16r1F).
			(self isIntegerObject: arg2Val) ifTrue: [
				arg2Val _ self integerValueOf: arg2Val.
			] ifFalse: [
				self fetchNextBytecode.
				^ self internalPush: arg1.  "abort; second arg is not an integer"
			].
		].
	].

	byte3 < 178 ifTrue: [
		"do addition, possibly followed by a storeAndPopTemp"
		result _ arg1Val + arg2Val.
		(self isIntegerValue: result) ifTrue: [
			((byte4 > 103) and: [byte4 < 112]) ifTrue: [
				"next instruction is a storeAndPopTemp"
				localIP _ localIP + 3.
				self storePointerUnchecked: (byte4 bitAnd: 7) + TempFrameStart
					ofObject: localHomeContext
					withValue: (self integerObjectOf: result).
			] ifFalse: [
				localIP _ localIP + 2.
				self internalPush: (self integerObjectOf: result).
			].
		] ifFalse: [
			self fetchNextBytecode.
			^ self internalPush: arg1.  "abort; result is not an integer"
		].
	] ifFalse: [
		"do comparison operation, followed by a longJumpIfFalse"
		offset _ self byteAt: localIP + 4.
		arg1Val <= arg2Val
			ifTrue: [localIP _ localIP + 3 + 1]  "jump not taken; skip extra instruction byte"
			ifFalse: [localIP _ localIP + 3 + 1 + offset].
			self fetchNextBytecode.
	].
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:46'!
extendedPushBytecode

	| descriptor variableType variableIndex |
	descriptor _ self fetchByte.
	self fetchNextBytecode.
	variableType _ (descriptor >> 6) bitAnd: 16r3.
	variableIndex _ descriptor bitAnd: 16r3F.
	variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex].
	variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex].
	variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex].
	variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex].
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'!
extendedStoreAndPopBytecode

	self extendedStoreBytecode.
	self internalPop: 1.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'!
extendedStoreBytecode

	| descriptor variableType variableIndex association |
	self inline: true.
	descriptor _ self fetchByte.
	self fetchNextBytecode.
	variableType _ (descriptor >> 6) bitAnd: 16r3.
	variableIndex _ descriptor bitAnd: 16r3F.
	variableType = 0 ifTrue:
		[^self storePointer: variableIndex
			ofObject: receiver
			withValue: self internalStackTop].
	variableType = 1 ifTrue:
		[^self storePointerUnchecked: variableIndex + TempFrameStart
			ofObject: localHomeContext
			withValue: self internalStackTop].
	variableType = 2 ifTrue:
		[self error: 'illegal store'].
	variableType = 3 ifTrue:
		[association _ self literal: variableIndex.
		^self storePointer: ValueIndex
			ofObject: association
			withValue: self internalStackTop].! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'!
popStackBytecode

	self fetchNextBytecode.
	self internalPop: 1.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushActiveContextBytecode
	"Puts reclaimability of this context in question."

	self fetchNextBytecode.
	reclaimableContextCount _ 0.
	self internalPush: activeContext.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantFalseBytecode

	self fetchNextBytecode.
	self internalPush: falseObj.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantMinusOneBytecode

	self fetchNextBytecode.
	self internalPush: ConstMinusOne.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantNilBytecode

	self fetchNextBytecode.
	self internalPush: nilObj.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantOneBytecode

	self fetchNextBytecode.
	self internalPush: ConstOne.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantTrueBytecode

	self fetchNextBytecode.
	self internalPush: trueObj.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantTwoBytecode

	self fetchNextBytecode.
	self internalPush: ConstTwo.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushConstantZeroBytecode

	self fetchNextBytecode.
	self internalPush: ConstZero.
! !

!Interpreter methodsFor: 'stack bytecodes'!
pushLiteralConstant: literalIndex

	self internalPush: (self literal: literalIndex).! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:56'!
pushLiteralConstantBytecode

	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
! !

!Interpreter methodsFor: 'stack bytecodes'!
pushLiteralVariable: literalIndex

	self internalPush:
		(self fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:56'!
pushLiteralVariableBytecode

	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'!
pushReceiverBytecode

	self fetchNextBytecode.
	self internalPush: receiver.
! !

!Interpreter methodsFor: 'stack bytecodes'!
pushReceiverVariable: fieldIndex

	self internalPush:
		(self fetchPointer: fieldIndex ofObject: receiver).! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:57'!
pushReceiverVariableBytecode

	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
! !

!Interpreter methodsFor: 'stack bytecodes'!
pushTemporaryVariable: temporaryIndex

	self internalPush: (self temporary: temporaryIndex).! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:57'!
pushTemporaryVariableBytecode

	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:58'!
storeAndPopReceiverVariableBytecode
	"Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."

	| rcvr top |
	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	rcvr _ receiver.
	top _ self internalStackTop.
	(rcvr < youngStart) ifTrue: [
		self possibleRootStoreInto: rcvr value: top.
	].
	self storePointerUnchecked: (currentBytecode bitAnd: 7)
		ofObject: rcvr
		withValue: top.
	self internalPop: 1.
! !

!Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:59'!
storeAndPopTemporaryVariableBytecode

	self fetchNextBytecode.
	"this bytecode will be expanded so that refs to currentBytecode below will be constant"
	self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
		ofObject: localHomeContext
		withValue: self internalStackTop.
	self internalPop: 1.
! !


!Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/10/1998 17:11'!
jump: offset

	localIP _ localIP + offset + 1.
	currentBytecode _ self byteAt: localIP.
! !

!Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/11/1998 07:24'!
jumplfFalseBy: offset

	| boolean |
	boolean _ self internalStackTop.
	boolean = falseObj ifTrue: [
		self jump: offset.
	] ifFalse: [
		boolean = trueObj ifFalse: [
			messageSelector _ self splObj: SelectorMustBeBoolean.
			argumentCount _ 0.
			^ self normalSend
		].
		self fetchNextBytecode.
	].
	self internalPop: 1.
! !

!Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/11/1998 07:24'!
jumplfTrueBy: offset

	| boolean |
	boolean _ self internalStackTop.
	boolean = trueObj ifTrue: [
		self jump: offset.
	] ifFalse: [
		boolean = falseObj ifFalse: [
			messageSelector _ self splObj: SelectorMustBeBoolean.
			argumentCount _ 0.
			^ self normalSend
		].
		self fetchNextBytecode.
	].
	self internalPop: 1.
! !

!Interpreter methodsFor: 'jump bytecodes'!
longJumpIfFalse

	self jumplfFalseBy:
		((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !

!Interpreter methodsFor: 'jump bytecodes'!
longJumpIfTrue

	self jumplfTrueBy:
		((currentBytecode bitAnd: 3) * 256) + self fetchByte.! !

!Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/13/1998 11:20'!
longUnconditionalJump

	| offset |
	offset _ (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte.
	localIP _ localIP + offset.
	offset < 0 ifTrue: [
		"backward jump means we're in a loop; check for possible interrupts"
		self internalQuickCheckForInterrupts.
	].
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'jump bytecodes'!
shortConditionalJump

	self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! !

!Interpreter methodsFor: 'jump bytecodes'!
shortUnconditionalJump

	self jump: (currentBytecode bitAnd: 7) + 1.! !


!Interpreter methodsFor: 'send bytecodes' stamp: 'jm 12/10/1998 17:20'!
doubleExtendedDoAnythingBytecode
	"Replaces the Blue Book double-extended send [132], in which
	the first byte was wasted on 8 bits of argument count.
	Here we use 3 bits for the operation sub-type (opType),
	and the remaining 5 bits for argument count where needed.
	The last byte give access to 256 instVars or literals.
	See also secondExtendedSendBytecode"

	| byte2 byte3 opType top |
	byte2 _ self fetchByte.
	byte3 _ self fetchByte.
	opType _ byte2 >> 5.
	opType = 0 ifTrue: [
		messageSelector _ self literal: byte3.
		argumentCount _ byte2 bitAnd: 16r1F.
		^ self normalSend
	].
	opType = 1 ifTrue: [
		messageSelector _ self literal: byte3.
		argumentCount _ byte2 bitAnd: 16r1F.
		^ self superclassSend
	].
	self fetchNextBytecode.
	opType = 2 ifTrue: [^ self pushReceiverVariable: byte3].
	opType = 3 ifTrue: [^ self pushLiteralConstant: byte3].
	opType = 4 ifTrue: [^ self pushLiteralVariable: byte3].
	opType = 5 ifTrue: [
		top _ self internalStackTop.
		^ self storePointer: byte3 ofObject: receiver withValue: top
	].
	opType = 6 ifTrue: [
		top _ self internalStackTop.
		self internalPop: 1.
		^ self storePointer: byte3 ofObject: receiver withValue: top
	].
	opType = 7 ifTrue: [
		top _ self internalStackTop.
		^ self storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top
	].! !

!Interpreter methodsFor: 'send bytecodes'!
secondExtendedSendBytecode
	"This replaces the Blue Book double-extended super-send [134],
	which is subsumed by the new double-extended do-anything [132].
	It offers a 2-byte send of 0-3 args for up to 63 literals, for which 
	the Blue Book opcode set requires a 3-byte instruction."

	| descriptor |
	descriptor _ self fetchByte.
	messageSelector _ self literal: (descriptor bitAnd: 16r3F).
	argumentCount _ descriptor >> 6.
	self normalSend.
! !

!Interpreter methodsFor: 'send bytecodes' stamp: 'di 12/3/1998 12:52'!
sendLiteralSelectorBytecode
	"Can use any of the first 16 literals for the selector and pass up to 2 arguments."

	messageSelector _ self literal: (currentBytecode bitAnd: 16rF).
	argumentCount _ ((currentBytecode >> 4) bitAnd: 3) - 1.
	self normalSend.
"
Note - if you ever want to try inlining these, the following will produce the code to paste into interp.c -- I found it actually slowed things down (cache size effect?).
String streamContents:
	[:s | 208 to: 255 do:
		[:i | s tab; tab; nextPutAll: 'case ', i printString, ':'; cr.
		s tab; tab; tab; nextPutAll: 'messageSelector = longAt(((char *) method) + 4 + ';
			print: ((i bitAnd: 15) + 1) << 2; nextPutAll: ');'; cr.
		s tab; tab; tab; nextPutAll: 'argumentCount = ';
			print: (i >> 4 bitAnd: 3) - 1; nextPutAll: ';'; cr.
		s tab; tab; tab; nextPutAll: 'goto commonSend;'; cr.
		s tab; tab; tab; nextPutAll: 'break;'; cr; cr]]
"! !

!Interpreter methodsFor: 'send bytecodes'!
singleExtendedSendBytecode
	"Can use any of the first 32 literals for the selector and pass up to 7 arguments."

	| descriptor |
	descriptor _ self fetchByte.
	messageSelector _ self literal: (descriptor bitAnd: 16r1F).
	argumentCount _ descriptor >> 5.
	self normalSend.! !

!Interpreter methodsFor: 'send bytecodes'!
singleExtendedSuperBytecode
	"Can use any of the first 32 literals for the selector and pass up to 7 arguments."

	| descriptor |
	descriptor _ self fetchByte.
	messageSelector _ self literal: (descriptor bitAnd: 16r1F).
	argumentCount _ descriptor >> 5.
	self superclassSend.
! !


!Interpreter methodsFor: 'return bytecodes'!
returnFalse

	| cntx val |
	cntx _ self sender.
	val _ falseObj.
	self returnValue: val to: cntx.
! !

!Interpreter methodsFor: 'return bytecodes'!
returnNil

	| cntx val |
	cntx _ self sender.
	val _ nilObj.
	self returnValue: val to: cntx.
! !

!Interpreter methodsFor: 'return bytecodes'!
returnReceiver

	| cntx val |
	cntx _ self sender.
	val _ receiver.
	self returnValue: val to: cntx.! !

!Interpreter methodsFor: 'return bytecodes'!
returnTopFromBlock
	"Return to the caller of the method containing the block."

	| cntx val |
	cntx _ self caller.  "Note: caller, not sender!!"
	val _ self internalStackTop.
	self returnValue: val to: cntx.! !

!Interpreter methodsFor: 'return bytecodes'!
returnTopFromMethod

	| cntx val |
	cntx _ self sender.
	val _ self internalStackTop.
	self returnValue: val to: cntx.! !

!Interpreter methodsFor: 'return bytecodes'!
returnTrue

	| cntx val |
	cntx _ self sender.
	val _ trueObj.
	self returnValue: val to: cntx.
! !

!Interpreter methodsFor: 'return bytecodes' stamp: 'di 3/21/2000 10:35'!
returnValue: resultObj to: returnContext
	"Note: Assumed to be inlined into the dispatch loop."

	| nilOop thisCntx contextOfCaller ctx |
	self inline: true.
	self sharedCodeNamed: 'commonReturn' inCase: 120.

	nilOop _ nilObj. "keep in a register"
	thisCntx _ activeContext.
	ctx _ thisCntx.
	"First scan to ensure non-nil senders. This feature, suggested by Craig Latta, catches attempts to return out of the scope of an ensure-block, before actually unwinding the stack."
	[ctx ~= returnContext and: [ctx ~= nilOop]]
		whileTrue: [ctx _ self fetchPointer: SenderIndex ofObject: ctx].

	"make sure we can return to the given context"
	((ctx = nilOop) or:[ (returnContext = nilOop) or:
	 [(self fetchPointer: InstructionPointerIndex ofObject: returnContext) = nilOop]])
		ifTrue:
		["error: sender's instruction pointer or context is nil; cannot return"
		self internalPush: activeContext.
		self internalPush: resultObj.
		messageSelector _ self splObj: SelectorCannotReturn.
		argumentCount _ 1.
		^ self normalSend].

	[thisCntx = returnContext]
		whileFalse:
		["climb up stack to returnContext"
		contextOfCaller _ self fetchPointer: SenderIndex ofObject: thisCntx.

		"zap exited contexts so any future attempted use will be caught"
		self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
		self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
		reclaimableContextCount > 0 ifTrue:
			["try to recycle this context"
			reclaimableContextCount _ reclaimableContextCount - 1.
			self recycleContextIfPossible: thisCntx].
		thisCntx _ contextOfCaller].

	activeContext _ thisCntx.
	(thisCntx < youngStart) ifTrue: [ self beRootIfOld: thisCntx ].

	self internalFetchContextRegisters: thisCntx.  "updates local IP and SP"
	self fetchNextBytecode.
	self internalPush: resultObj.
! !


!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:28'!
bytecodePrimAdd
	| rcvr arg result |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [result _ (self integerValueOf: rcvr) + (self integerValueOf: arg).
				(self isIntegerValue: result) ifTrue:
					[self internalPop: 2
						thenPush: (self integerObjectOf: result).
					^ self fetchNextBytecode "success"]]
		ifFalse: [successFlag _ true.
				self externalizeIPandSP.
				self primitiveFloatAdd: rcvr toArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector _ self specialSelector: 0.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 12/14/1998 15:10'!
bytecodePrimAt
	"BytecodePrimAt will only succeed if the receiver is in the atCache.
	Otherwise it will fail so that the more general primitiveAt will put it in the
	cache after validating that message lookup results in a primitive response."
	| index rcvr result atIx |
	index _ self internalStackTop.
	rcvr _ self internalStackValue: 1.
	successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index].
	successFlag ifTrue:
		[atIx _ rcvr bitAnd: AtCacheMask.  "Index into atCache = 4N, for N = 0 ... 7"
		(atCache at: atIx+AtCacheOop) = rcvr
		ifTrue:
			[result _ self commonVariableInternal: rcvr at: (self integerValueOf: index)
							cacheIndex: atIx.
			successFlag ifTrue:
				[self fetchNextBytecode.
				^ self internalPop: 2 thenPush: result]]].

	messageSelector _ self specialSelector: 16.
	argumentCount _ 1.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!
bytecodePrimAtEnd
	messageSelector _ self specialSelector: 21.
	argumentCount _ 0.
	self normalSend.! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 12/14/1998 15:10'!
bytecodePrimAtPut
	"BytecodePrimAtPut will only succeed if the receiver is in the atCache.
	Otherwise it will fail so that the more general primitiveAtPut will put it in the
	cache after validating that message lookup results in a primitive response."
	| index rcvr atIx value |
	value _ self internalStackTop.
	index _ self internalStackValue: 1.
	rcvr _ self internalStackValue: 2.
	successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index].
	successFlag ifTrue:
		[atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase.  "Index into atPutCache"
		(atCache at: atIx+AtCacheOop) = rcvr
		ifTrue:
			[self commonVariable: rcvr at: (self integerValueOf: index)
							put: value cacheIndex: atIx.
			successFlag ifTrue:
				[self fetchNextBytecode.
				^ self internalPop: 3 thenPush: value]]].

	messageSelector _ self specialSelector: 17.
	argumentCount _ 2.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitAnd

	successFlag _ true.
	self externalizeIPandSP.
	self primitiveBitAnd.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 14.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitOr

	successFlag _ true.
	self externalizeIPandSP.
	self primitiveBitOr.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 15.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'!
bytecodePrimBitShift

	successFlag _ true.
	self externalizeIPandSP.
	self primitiveBitShift.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 12.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 1/10/1999 23:29'!
bytecodePrimBlockCopy

	| rcvr hdr |
	rcvr _ self internalStackValue: 1.
	successFlag _ true.
	hdr _ self baseHeader: rcvr.
	self success: (self isContextHeader: hdr).
	successFlag ifTrue:
		[self externalizeIPandSP.
		self primitiveBlockCopy.
		self internalizeIPandSP].
	successFlag ifFalse:
		[messageSelector _ self specialSelector: 24.
		argumentCount _ 1.
		^ self normalSend].
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 1/11/1999 00:09'!
bytecodePrimClass
	| rcvr |
	rcvr _ self internalStackTop.
	self internalPop: 1 thenPush: (self fetchClassOf: rcvr).
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:35'!
bytecodePrimDiv
	| quotient |
	successFlag _ true.
	quotient _ self doPrimitiveDiv: (self internalStackValue: 1)
							by: (self internalStackValue: 0).
	successFlag ifTrue:
		[self internalPop: 2 thenPush: (self integerObjectOf: quotient).
		^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 13.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:30'!
bytecodePrimDivide
	| rcvr arg result |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [rcvr _ self integerValueOf: rcvr.
				arg _ self integerValueOf: arg.
				((arg ~= 0) and: [(rcvr \\ arg) = 0]) ifTrue:
					[result _ rcvr // arg.  "generates C / operation"
					(self isIntegerValue: result) ifTrue:
						[self internalPop: 2
						thenPush: (self integerObjectOf: result).
					^ self fetchNextBytecode "success"]]]
		ifFalse: [successFlag _ true.
				self externalizeIPandSP.
				self primitiveFloatDivide: rcvr byArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector _ self specialSelector: 9.
	argumentCount _ 1.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends'!
bytecodePrimDo

	messageSelector _ self specialSelector: 27.
	argumentCount _ 1.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:39'!
bytecodePrimEqual
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[^ self booleanCheat: rcvr = arg].

	successFlag _ true.
	bool _ self primitiveFloatEqual: rcvr toArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool].

	messageSelector _ self specialSelector: 6.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends'!
bytecodePrimEquivalent

	| rcvr arg |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	self booleanCheat: rcvr = arg.! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 4/3/1999 21:37'!
bytecodePrimGreaterOrEqual
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk:
			[^ self booleanCheat:
					(self integerValueOf: rcvr) >= (self integerValueOf: arg)].
		^ self booleanCheat: rcvr >= arg].

	successFlag _ true.
	bool _ self primitiveFloatLess: rcvr thanArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool not].

	messageSelector _ self specialSelector: 5.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 4/3/1999 21:40'!
bytecodePrimGreaterThan
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk:
			[^ self booleanCheat:
				(self integerValueOf: rcvr) > (self integerValueOf: arg)].
		^ self booleanCheat: rcvr > arg].

	successFlag _ true.
	bool _ self primitiveFloatGreater: rcvr thanArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool].

	messageSelector _ self specialSelector: 3.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 4/3/1999 21:41'!
bytecodePrimLessOrEqual
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk:
			[^ self booleanCheat:
				(self integerValueOf: rcvr) <= (self integerValueOf: arg)].
		^ self booleanCheat: rcvr <= arg].

	successFlag _ true.
	bool _ self primitiveFloatGreater: rcvr thanArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool not].

	messageSelector _ self specialSelector: 4.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 4/3/1999 21:42'!
bytecodePrimLessThan
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[self cCode: '' inSmalltalk: 
			[^ self booleanCheat:
				(self integerValueOf: rcvr) < (self integerValueOf: arg)].
		^ self booleanCheat: rcvr < arg].

	successFlag _ true.
	bool _ self primitiveFloatLess: rcvr thanArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool].

	messageSelector _ self specialSelector: 2.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'!
bytecodePrimMakePoint

	successFlag _ true.
	self externalizeIPandSP.
	self primitiveMakePoint.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 11.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'!
bytecodePrimMod
	| mod |
	successFlag _ true.
	mod _ self doPrimitiveMod: (self internalStackValue: 1)
							by: (self internalStackValue: 0).
	successFlag ifTrue:
		[self internalPop: 2 thenPush: (self integerObjectOf: mod).
		^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 10.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'!
bytecodePrimMultiply
	| rcvr arg result |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [rcvr _ self integerValueOf: rcvr.
				arg _ self integerValueOf: arg.
				result _ rcvr * arg.
				((arg = 0 or: [(result // arg) = rcvr])
					and: [self isIntegerValue: result])
					ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result).
							^ self fetchNextBytecode "success"]]
		ifFalse: [successFlag _ true.
				self externalizeIPandSP.
				self primitiveFloatMultiply: rcvr byArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector _ self specialSelector: 8.
	argumentCount _ 1.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends'!
bytecodePrimNew

	messageSelector _ self specialSelector: 28.
	argumentCount _ 0.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends'!
bytecodePrimNewWithArg

	messageSelector _ self specialSelector: 29.
	argumentCount _ 1.
	self normalSend.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'!
bytecodePrimNext
	messageSelector _ self specialSelector: 19.
	argumentCount _ 0.
	self normalSend.! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 10:12'!
bytecodePrimNextPut
	messageSelector _ self specialSelector: 20.
	argumentCount _ 1.
	self normalSend.! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:41'!
bytecodePrimNotEqual
	| rcvr arg bool |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg) ifTrue:
		[^ self booleanCheat: rcvr ~= arg].

	successFlag _ true.
	bool _ self primitiveFloatEqual: rcvr toArg: arg.
	successFlag ifTrue:
		[^ self booleanCheat: bool not].

	messageSelector _ self specialSelector: 7.
	argumentCount _ 1.
	self normalSend
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:34'!
bytecodePrimPointX

	successFlag _ true.
	self externalizeIPandSP.
	self primitivePointX.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 30.
	argumentCount _ 0.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:34'!
bytecodePrimPointY

	successFlag _ true.
	self externalizeIPandSP.
	self primitivePointY.
	self internalizeIPandSP.
	successFlag ifTrue: [^ self fetchNextBytecode "success"].

	messageSelector _ self specialSelector: 31.
	argumentCount _ 0.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'di 12/11/1998 10:22'!
bytecodePrimSize
	messageSelector _ self specialSelector: 18.
	argumentCount _ 0.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 18:44'!
bytecodePrimSubtract
	| rcvr arg result |
	rcvr _ self internalStackValue: 1.
	arg _ self internalStackValue: 0.
	(self areIntegers: rcvr and: arg)
		ifTrue: [result _ (self integerValueOf: rcvr) - (self integerValueOf: arg).
				(self isIntegerValue: result) ifTrue:
					[self internalPop: 2
						thenPush: (self integerObjectOf: result).
					^ self fetchNextBytecode "success"]]
		ifFalse: [successFlag _ true.
				self externalizeIPandSP.
				self primitiveFloatSubtract: rcvr fromArg: arg.
				self internalizeIPandSP.
				successFlag ifTrue: [^ self fetchNextBytecode "success"]].

	messageSelector _ self specialSelector: 1.
	argumentCount _ 1.
	self normalSend! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:33'!
bytecodePrimValue

	| block |
	block _ self internalStackTop.
	successFlag _ true.
	argumentCount _ 0.
	self assertClassOf: block is: (self splObj: ClassBlockContext).
	successFlag ifTrue: [
		self externalizeIPandSP.
		self primitiveValue.
		self internalizeIPandSP.
	].
	successFlag ifFalse: [
		messageSelector _ self specialSelector: 25.
		argumentCount _ 0.
		^ self normalSend
	].
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:33'!
bytecodePrimValueWithArg

	| block |
	block _ self internalStackValue: 1.
	successFlag _ true.
	argumentCount _ 1.
	self assertClassOf: block is: (self splObj: ClassBlockContext).
	successFlag ifTrue: [
		self externalizeIPandSP.
		self primitiveValue.
		self internalizeIPandSP.
	].
	successFlag ifFalse: [
		messageSelector _ self specialSelector: 26.
		argumentCount _ 1.
		^ self normalSend
	].
	self fetchNextBytecode.
! !

!Interpreter methodsFor: 'common selector sends' stamp: 'ar 2/2/2001 14:35'!
primitiveDisablePowerManager
	"Pass in a non-negative value to disable the architectures powermanager if any, zero to enable"

	| integer |
	self export: true.
	integer _ self stackIntegerValue: 0.
	successFlag ifTrue: [
		self ioDisablePowerManager: integer.
		self pop: 1].  "integer; leave rcvr on stack"
! !


!Interpreter methodsFor: 'primitive support'!
failed

	^successFlag not! !

!Interpreter methodsFor: 'primitive support'!
positive32BitIntegerFor: integerValue

	| newLargeInteger |
	"Note - integerValue is interpreted as POSITIVE, eg, as the result of
		Bitmap>at:, or integer>bitAnd:."
	(integerValue >= 0 and: [self isIntegerValue: integerValue])
		ifTrue: [^ self integerObjectOf: integerValue].
	newLargeInteger _
		self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
				sizeInBytes: 8
						 fill: 0.
	self storeByte: 3 ofObject: newLargeInteger
		withValue: ((integerValue >> 24) bitAnd: 16rFF).
	self storeByte: 2 ofObject: newLargeInteger
		withValue: ((integerValue >> 16) bitAnd: 16rFF).
	self storeByte: 1 ofObject: newLargeInteger
		withValue: ((integerValue >> 8) bitAnd: 16rFF).
	self storeByte: 0 ofObject: newLargeInteger
		withValue: (integerValue bitAnd: 16rFF).
	^ newLargeInteger! !

!Interpreter methodsFor: 'primitive support'!
positive32BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a four-byte LargePositiveInteger."

	| sz value |
	(self isIntegerObject: oop) ifTrue: [
		value _ self integerValueOf: oop.
		value < 0 ifTrue: [^ self primitiveFail].
		^ value].

	self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger).
	successFlag ifTrue: [
		sz _ self lengthOf: oop.
		sz = 4 ifFalse: [^ self primitiveFail]].
	successFlag ifTrue: [
		^ (self fetchByte: 0 ofObject: oop) +
		  ((self fetchByte: 1 ofObject: oop) <<  8) +
		  ((self fetchByte: 2 ofObject: oop) << 16) +
		  ((self fetchByte: 3 ofObject: oop) << 24) ].! !

!Interpreter methodsFor: 'primitive support'!
primIndex
	^ primitiveIndex! !

!Interpreter methodsFor: 'primitive support'!
primitiveFail

	successFlag _ false.! !

!Interpreter methodsFor: 'primitive support' stamp: 'ar 7/30/2000 17:39'!
primitiveResponse
	"Details: Since primitives can run for a long time, we must check to see if it is time to process a timer interrupt. However, on the Mac, the high-resolution millisecond clock is expensive to poll. Thus, we use a fast, low-resolution (1/60th second) clock to determine if the primitive took enough time to justify polling the high-resolution clock. Seems Byzantine, but Bob Arning showed that the performance of primitive-intensive code decreased substantially if there was another process waiting on a Delay.
	One other detail: If the primitive fails, we want to postpone the timer interrupt until just after the primitive failure code has been entered. This is accomplished by setting the interrupt check counter to zero, thus triggering a check for interrupts when activating the method containing the primitive."

	| timerPending startTime |
	timerPending _ nextWakeupTick ~= 0.
	timerPending ifTrue: [startTime _ self ioLowResMSecs].
	successFlag _ true.
	self dispatchOn: primitiveIndex in: PrimitiveTable.
	timerPending ifTrue: [
		(self ioLowResMSecs ~= startTime) ifTrue: [
			"primitive ran for more than a tick; check for possible timer interrupts"
			((self ioMSecs bitAnd: MillisecondClockMask) >= nextWakeupTick) ifTrue: [
				successFlag
					ifTrue: ["process the interrupt now"
							self checkForInterrupts]
					ifFalse: ["process the interrupt in primtive failure code"
							interruptCheckCounter _ 0]]]].
	^ successFlag
! !

!Interpreter methodsFor: 'primitive support' stamp: 'ar 11/29/1999 22:01'!
signed32BitIntegerFor: integerValue
	"Return a full 32 bit integer object for the given integer value"
	| newLargeInteger value largeClass |
	self inline: false.
	(self isIntegerValue: integerValue)
		ifTrue: [^ self integerObjectOf: integerValue].
	integerValue < 0
		ifTrue:[	largeClass _ self classLargeNegativeInteger.
				value _ 0 - integerValue]
		ifFalse:[	largeClass _ self classLargePositiveInteger.
				value _ integerValue].
	newLargeInteger _
		self instantiateClass: largeClass indexableSize: 4.
	self storeByte: 3 ofObject: newLargeInteger
		withValue: ((value >> 24) bitAnd: 16rFF).
	self storeByte: 2 ofObject: newLargeInteger
		withValue: ((value >> 16) bitAnd: 16rFF).
	self storeByte: 1 ofObject: newLargeInteger
		withValue: ((value >> 8) bitAnd: 16rFF).
	self storeByte: 0 ofObject: newLargeInteger
		withValue: (value bitAnd: 16rFF).
	^ newLargeInteger! !

!Interpreter methodsFor: 'primitive support' stamp: 'ar 11/29/1999 22:00'!
signed32BitValueOf: oop
	"Convert the given object into an integer value.
	The object may be either a positive ST integer or a four-byte LargeInteger."
	| sz value largeClass negative |
	self inline: false.
	(self isIntegerObject: oop) ifTrue: [^self integerValueOf: oop].
	largeClass _ self fetchClassOf: oop.
	largeClass = self classLargePositiveInteger
		ifTrue:[negative _ false]
		ifFalse:[largeClass = self classLargeNegativeInteger
					ifTrue:[negative _ true]
					ifFalse:[^self primitiveFail]].
	sz _ self lengthOf: oop.
	sz = 4 ifFalse: [^ self primitiveFail].
	value _ (self fetchByte: 0 ofObject: oop) +
		  ((self fetchByte: 1 ofObject: oop) <<  8) +
		  ((self fetchByte: 2 ofObject: oop) << 16) +
		  ((self fetchByte: 3 ofObject: oop) << 24).
	negative
		ifTrue:[^0 - value]
		ifFalse:[^value]! !

!Interpreter methodsFor: 'primitive support'!
success: successValue

	successFlag _ successValue & successFlag.! !


!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:38'!
checkBooleanResult: result
	successFlag
		ifTrue: [self pushBool: result]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:26'!
checkIntegerResult: integerResult
	(successFlag and: [self isIntegerValue: integerResult])
		ifTrue: [self pushInteger: integerResult]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives'!
compare31or32Bits: obj1 equal: obj2
	"May set success to false"

	"First compare two ST integers..."
	((self isIntegerObject: obj1)
		and: [self isIntegerObject: obj2])
		ifTrue: [^ obj1 = obj2].

	"Now compare, assuming positive integers, but setting fail if not"
	^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 11:22'!
doPrimitiveDiv: rcvr by: arg
	"Rounds negative results towards negative infinity, rather than zero."
	| result posArg posRcvr integerRcvr integerArg |
	(self areIntegers: rcvr and: arg)
		ifTrue: [integerRcvr _ self integerValueOf: rcvr.
				integerArg _ self integerValueOf: arg.
				self success: integerArg ~= 0]
		ifFalse: [self primitiveFail].
	successFlag ifFalse: [^ 1 "fail"].

	integerRcvr > 0
		ifTrue: [integerArg > 0
					ifTrue: [result _ integerRcvr // integerArg]
					ifFalse: ["round negative result toward negative infinity"
							posArg _ 0 - integerArg.
							result _ 0 - ((integerRcvr + (posArg - 1)) // posArg)]]
		ifFalse: [posRcvr _ 0 - integerRcvr.
				integerArg > 0
					ifTrue: ["round negative result toward negative infinity"
							result _ 0 - ((posRcvr + (integerArg - 1)) // integerArg)]
					ifFalse: [posArg _ 0 - integerArg.
							result _ posRcvr // posArg]].
	self success: (self isIntegerValue: result).
	^ result! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 10:02'!
doPrimitiveMod: rcvr by: arg
	| integerResult integerRcvr integerArg |
	(self areIntegers: rcvr and: arg)
		ifTrue: [integerRcvr _ self integerValueOf: rcvr.
				integerArg _ self integerValueOf: arg.
				self success: integerArg ~= 0]
		ifFalse: [self primitiveFail].
	successFlag ifFalse: [^ 1 "fail"].

	integerResult _ integerRcvr \\ integerArg.

	"ensure that the result has the same sign as the integerArg"
	integerArg < 0
		ifTrue: [integerResult > 0
			ifTrue: [integerResult _ integerResult + integerArg]]
		ifFalse: [integerResult < 0
			ifTrue: [integerResult _ integerResult + integerArg]].
	self success: (self isIntegerValue: integerResult).
	^ integerResult
! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:13'!
primitiveAdd

	self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) + (self stackIntegerValue: 0)! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:02'!
primitiveBitAnd
	| integerReceiver integerArgument |
	integerArgument _ self popPos32BitInteger.
	integerReceiver _ self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitAnd: integerArgument))]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:02'!
primitiveBitOr
	| integerReceiver integerArgument |
	integerArgument _ self popPos32BitInteger.
	integerReceiver _ self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitOr: integerArgument))]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:04'!
primitiveBitShift 
	| integerReceiver integerArgument shifted |
	integerArgument _ self popInteger.
	integerReceiver _ self popPos32BitInteger.
	successFlag ifTrue: [
		integerArgument >= 0 ifTrue: [
			"Left shift -- must fail if we lose bits beyond 32"
			self success: integerArgument <= 31.
			shifted _ integerReceiver << integerArgument.
			self success: (shifted >> integerArgument) = integerReceiver.
		] ifFalse: [
			"Right shift -- OK to lose bits"
			self success: integerArgument >= -31.
			shifted _ integerReceiver bitShift: integerArgument.
		].
	].
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor: shifted)]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 13:18'!
primitiveBitXor
	| integerReceiver integerArgument |
	integerArgument _ self popPos32BitInteger.
	integerReceiver _ self popPos32BitInteger.
	successFlag
		ifTrue: [self push: (self positive32BitIntegerFor:
					(integerReceiver bitXor: integerArgument))]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 12/27/1998 22:52'!
primitiveDiv
	| quotient |
	quotient _ self doPrimitiveDiv: (self stackValue: 1) by: (self stackValue: 0).
	self pop2AndPushIntegerIfOK: quotient! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:25'!
primitiveDivide
	| integerReceiver integerArgument |
	integerReceiver _ self stackIntegerValue: 1.
	integerArgument _ self stackIntegerValue: 0.
	(integerArgument ~= 0 and: [integerReceiver \\ integerArgument = 0])
		ifTrue: [self pop2AndPushIntegerIfOK: integerReceiver // integerArgument]
		ifFalse: [self primitiveFail]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveEqual
	| integerReceiver integerArgument result |
	integerArgument _ self popStack.
	integerReceiver _ self popStack.
	result _ self compare31or32Bits: integerReceiver equal: integerArgument.
	self checkBooleanResult: result! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveGreaterOrEqual
	| integerReceiver integerArgument |
	integerArgument _ self popInteger.
	integerReceiver _ self popInteger.
	self checkBooleanResult: integerReceiver >= integerArgument! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveGreaterThan
	| integerReceiver integerArgument |
	integerArgument _ self popInteger.
	integerReceiver _ self popInteger.
	self checkBooleanResult: integerReceiver > integerArgument! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveLessOrEqual
	| integerReceiver integerArgument |
	integerArgument _ self popInteger.
	integerReceiver _ self popInteger.
	self checkBooleanResult: integerReceiver <= integerArgument! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveLessThan
	| integerReceiver integerArgument |
	integerArgument _ self popInteger.
	integerReceiver _ self popInteger.
	self checkBooleanResult: integerReceiver < integerArgument! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'ar 7/30/1999 16:57'!
primitiveMakePoint
	| rcvr argument pt |
	argument _ self stackValue: 0.
	rcvr _ self stackValue: 1.
	(self isIntegerObject: rcvr) ifTrue:[
		(self isIntegerObject: argument)
			ifTrue:[pt _ self makePointwithxValue: (self integerValueOf: rcvr)
							yValue: (self integerValueOf: argument)]
			ifFalse:[pt _ self makePointwithxValue: (self integerValueOf: rcvr)
							yValue: 0.
					"Above may cause GC!!"
					self storePointer: 1 ofObject: pt withValue: (self stackValue: 0)].
	] ifFalse:[
		(self isFloatObject: rcvr) ifFalse:[^self success: false].
		pt _ self makePointwithxValue: 0 yValue: 0.
		"Above may cause GC!!"
		self storePointer: 0 ofObject: pt withValue: (self stackValue: 1).
		self storePointer: 1 ofObject: pt withValue: (self stackValue: 0).
	].
	self pop: 2.
	self push: pt.
! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:36'!
primitiveMod
	| mod |
	mod _ self doPrimitiveMod: (self stackValue: 1) by: (self stackValue: 0).
	self pop2AndPushIntegerIfOK: mod! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:27'!
primitiveMultiply
	| integerRcvr integerArg integerResult |
	integerRcvr _ self stackIntegerValue: 1.
	integerArg _ self stackIntegerValue: 0.
	successFlag ifTrue:
		[integerResult _ integerRcvr * integerArg.
		"check for C overflow by seeing if computation is reversible"
		((integerArg = 0) or: [(integerResult // integerArg) = integerRcvr])
			ifTrue: [self pop2AndPushIntegerIfOK: integerResult]
			ifFalse: [self primitiveFail]]! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'!
primitiveNotEqual
	| integerReceiver integerArgument result |
	integerArgument _ self popStack.
	integerReceiver _ self popStack.
	result _ (self compare31or32Bits: integerReceiver equal: integerArgument) not.
	self checkBooleanResult: result! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:19'!
primitiveQuo
	"Rounds negative results towards zero."
	| integerRcvr integerArg integerResult |
	integerRcvr _ self stackIntegerValue: 1.
	integerArg _ self stackIntegerValue: 0.
	self success: integerArg ~= 0.
	successFlag ifTrue: [
		integerRcvr > 0 ifTrue: [
			integerArg > 0 ifTrue: [
				integerResult _ integerRcvr // integerArg.
			] ifFalse: [
				integerResult _ 0 - (integerRcvr // (0 - integerArg)).
			].
		] ifFalse: [
			integerArg > 0 ifTrue: [
				integerResult _ 0 - ((0 - integerRcvr) // integerArg).
			] ifFalse: [
				integerResult _ (0 - integerRcvr) // (0 - integerArg).
			].
		]].
	self pop2AndPushIntegerIfOK: integerResult! !

!Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:13'!
primitiveSubtract

	self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) - (self stackIntegerValue: 0)! !


!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 21:24'!
popFloat
	"Note: May be called by translated primitive code."

	| top result |
	self returnTypeC: 'double'.
	self var: #result declareC: 'double result'.
	top _ self popStack.
	self assertClassOf: top is: (self splObj: ClassFloat).
	successFlag ifTrue:
		[self cCode: '' inSmalltalk: [result _ Float new: 2].
		self fetchFloatAt: top + BaseHeaderSize into: result].
	^ result! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:36'!
primitiveArctan

	| rcvr |
	self var: #rcvr declareC: 'double rcvr'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'atan(rcvr)'
									inSmalltalk: [rcvr arcTan])]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:35'!
primitiveAsFloat
	| arg |
	arg _ self popInteger.
	successFlag
		ifTrue: [ self pushFloat: (self cCode: '((double) arg)'
									inSmalltalk: [arg asFloat]) ]
		ifFalse: [ self unPop: 1 ].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:37'!
primitiveExp
	"Computes E raised to the receiver power."

	| rcvr |
	self var: #rcvr declareC: 'double rcvr'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'exp(rcvr)'
									inSmalltalk: [rcvr exp])]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:38'!
primitiveExponent
	"Exponent part of this float."

	| rcvr frac pwr |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #frac declareC: 'double frac'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [  "rcvr = frac * 2^pwr, where frac is in [0.5..1.0)"
			self cCode: 'frac = frexp(rcvr, &pwr)'
					inSmalltalk: [rcvr exponent].
			self pushInteger: pwr - 1]
		ifFalse: [self unPop: 1].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:45'!
primitiveFloatAdd
	^ self primitiveFloatAdd: (self stackValue: 1) toArg: self stackTop! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:53'!
primitiveFloatAdd: rcvrOop toArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr + arg].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:45'!
primitiveFloatDivide
	^ self primitiveFloatDivide: (self stackValue: 1) byArg: self stackTop! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:55'!
primitiveFloatDivide: rcvrOop byArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self success: arg ~= 0.0.
		successFlag ifTrue: [
			self pop: 2.
			self pushFloat: (self cCode: 'rcvr / arg'
							inSmalltalk: [rcvr / arg])]].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:48'!
primitiveFloatEqual
	| bool |
	bool _ self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:18'!
primitiveFloatEqual: rcvrOop toArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr = arg]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:42'!
primitiveFloatGreater: rcvrOop thanArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr > arg].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:40'!
primitiveFloatGreaterOrEqual
	| bool |
	bool _ self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool not].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:52'!
primitiveFloatGreaterThan
	| bool |
	bool _ self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:21'!
primitiveFloatLess: rcvrOop thanArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [^ rcvr < arg].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:49'!
primitiveFloatLessOrEqual
	| bool |
	bool _ self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool not].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:51'!
primitiveFloatLessThan
	| bool |
	bool _ self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:46'!
primitiveFloatMultiply
	^ self primitiveFloatMultiply: (self stackValue: 1) byArg: self stackTop! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:56'!
primitiveFloatMultiply: rcvrOop byArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr * arg].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:49'!
primitiveFloatNotEqual
	| bool |
	bool _ self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop.
	successFlag ifTrue: [self pop: 2. self pushBool: bool not].
! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:46'!
primitiveFloatSubtract
	^ self primitiveFloatSubtract: (self stackValue: 1) fromArg: self stackTop! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:56'!
primitiveFloatSubtract: rcvrOop fromArg: argOop
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #arg declareC: 'double arg'.

	rcvr _ self loadFloatOrIntFrom: rcvrOop.
	arg _ self loadFloatOrIntFrom: argOop.
	successFlag ifTrue: [
		self pop: 2.
		self pushFloat: rcvr - arg].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:27'!
primitiveFractionalPart
	| rcvr frac trunc |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #frac declareC: 'double frac'.
	self var: #trunc declareC: 'double trunc'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [self cCode: 'frac = modf(rcvr, &trunc)'
					inSmalltalk: [frac _ rcvr fractionPart].
				self pushFloat: frac]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:44'!
primitiveLogN
	"Natural log."

	| rcvr |
	self var: #rcvr declareC: 'double rcvr'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'log(rcvr)'
									inSmalltalk: [rcvr ln])]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:45'!
primitiveSine

	| rcvr |
	self var: #rcvr declareC: 'double rcvr'.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'sin(rcvr)'
									inSmalltalk: [rcvr sin])]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:45'!
primitiveSquareRoot
	| rcvr |
	self var: #rcvr declareC: 'double rcvr'.
	rcvr _ self popFloat.
	self success: rcvr >= 0.0.
	successFlag
		ifTrue: [self pushFloat: (self cCode: 'sqrt(rcvr)'
									inSmalltalk: [rcvr sqrt])]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:47'!
primitiveTimesTwoPower
	| rcvr arg |
	self var: #rcvr declareC: 'double rcvr'.
	arg _ self popInteger.
	rcvr _ self popFloat.
	successFlag
		ifTrue: [ self pushFloat: (self cCode: 'ldexp(rcvr, arg)'
									inSmalltalk: [rcvr timesTwoPower: arg]) ]
		ifFalse: [ self unPop: 2 ].! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:49'!
primitiveTruncated 
	| rcvr frac trunc |
	self var: #rcvr declareC: 'double rcvr'.
	self var: #frac declareC: 'double frac'.
	self var: #trunc declareC: 'double trunc'.
	rcvr _ self popFloat.
	successFlag ifTrue: [
		self cCode: 'frac = modf(rcvr, &trunc)'.
		self cCode: 'success((-1073741824.0 <= trunc) && (trunc <= 1073741823.0))'.
	].
	successFlag
		ifTrue: [self cCode: 'pushInteger((int) trunc)'
					inSmalltalk: [self pushInteger: rcvr truncated]]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'float primitives' stamp: 'di 4/3/1999 16:52'!
pushFloat: f

	self var: #f declareC: 'double f'.
	self push: (self floatObjectOf: f).! !


!Interpreter methodsFor: 'array and stream primitives'!
asciiOfCharacter: characterObj  "Returns an integer object"

	self inline: false.
	self assertClassOf: characterObj is: (self splObj: ClassCharacter).
	successFlag
		ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj]
		ifFalse: [^ ConstZero]  "in case some code needs an int"! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'go 11/17/1998 15:55'!
byteLengthOf: oop
	"Return the number of indexable bytes in the given object. This is basically a special copy of lengthOf: for BitBlt."
	| header sz fmt |
	header _ self baseHeader: oop.
	(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: [ sz _ header bitAnd: SizeMask ].
	fmt _ (header >> 8) bitAnd: 16rF.
	fmt < 8
		ifTrue: [ ^ (sz - BaseHeaderSize)]  "words"
		ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3)]  "bytes"! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/10/1998 14:53'!
characterForAscii: ascii  "Arg must lie in range 0-255!!"
	self inline: true.
	^ self fetchPointer: ascii ofObject: (self splObj: CharacterTable)! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 17:04'!
commonAt: stringy
	"This code is called if the receiver responds primitively to at:.
	If this is so, it will be installed in the atCache so that subsequent calls of at:
	or next may be handled immediately in bytecode primitive routines."
	| index rcvr atIx result |
	index _ self positive32BitValueOf: (self stackValue: 0).  "Sets successFlag"
	rcvr _ self stackValue: 1.
	successFlag & (self isIntegerObject: rcvr) not
		ifFalse: [^ self primitiveFail].

	"NOTE:  The at-cache, since it is specific to the non-super response to #at:.
	Therefore we must determine that the message is #at: (not, eg, #basicAt:),
	and that the send is not a super-send, before using the at-cache."
	(messageSelector = (self specialSelector: 16)
		and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
		ifTrue:
		["OK -- look in the at-cache"
		atIx _ rcvr bitAnd: AtCacheMask.  "Index into atCache = 4N, for N = 0 ... 7"
		(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
			["Rcvr not in cache.  Install it..."
			self install: rcvr inAtCache: atCache at: atIx string: stringy].
		successFlag ifTrue:
			[result _ self commonVariable: rcvr at: index cacheIndex: atIx].
		successFlag ifTrue:
			[^ self pop: 2 thenPush: result]].

	"The slow but sure way..."
	successFlag _ true.
	result _ self stObject: rcvr at: index.
	successFlag ifTrue:
		[stringy ifTrue: [result _ self characterForAscii: (self integerValueOf: result)].
		^ self pop: 2 thenPush: result]! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 17:06'!
commonAtPut: stringy
	"This code is called if the receiver responds primitively to at:Put:.
	If this is so, it will be installed in the atPutCache so that subsequent calls of at:
	or  next may be handled immediately in bytecode primitive routines."
	| value index rcvr atIx |
	value _ self stackValue: 0.
	index _ self positive32BitValueOf: (self stackValue: 1).  "Sets successFlag"
	rcvr _ self stackValue: 2.
	successFlag & (self isIntegerObject: rcvr) not
		ifFalse: [^ self primitiveFail].

	"NOTE:  The atPut-cache, since it is specific to the non-super response to #at:Put:.
	Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
	and that the send is not a super-send, before using the at-cache."
	(messageSelector = (self specialSelector: 17)
		and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
		ifTrue:
		["OK -- look in the at-cache"
		atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase.  "Index into atPutCache"
		(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
			["Rcvr not in cache.  Install it..."
			self install: rcvr inAtCache: atCache at: atIx string: stringy].
		successFlag ifTrue:
			[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
		successFlag ifTrue:
			[^ self pop: 3 thenPush: value]].

	"The slow but sure way..."
	successFlag _ true.
	stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
			ifFalse: [self stObject: rcvr at: index put: value].
	successFlag ifTrue: [^ self pop: 3 thenPush: value].
! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'!
commonVariable: rcvr at: index cacheIndex: atIx 
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'unsigned ') >= 1
		and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result _ self fetchWord: index - 1 ofObject: rcvr.
			result _ self positive32BitIntegerFor: result.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'!
commonVariable: rcvr at: index put: value cacheIndex: atIx
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields valToPut |
	self inline: true.

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'unsigned ') >= 1
		and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value].
		fmt < 8 ifTrue:  "Bitmap"
			[valToPut _ self positive32BitValueOf: value.
			successFlag ifTrue: [self storeWord: index - 1 ofObject: rcvr withValue: valToPut].
			^ nil].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: [valToPut _ self asciiOfCharacter: value.
					successFlag ifFalse: [^ nil]]
			ifFalse: [valToPut _ value].
		(self isIntegerObject: valToPut) ifTrue:
			[^ self storeByte: index - 1 ofObject: rcvr
						withValue: (self integerValueOf: valToPut)]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'!
commonVariableInternal: rcvr at: index cacheIndex: atIx 
	"This code assumes the reciever has been identified at location atIx in the atCache."
	| stSize fmt fixedFields result |
	self inline: true.

	stSize _ atCache at: atIx+AtCacheSize.
	((self cCoerce: index to: 'unsigned ') >= 1
		and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')])
	ifTrue:
		[fmt _ atCache at: atIx+AtCacheFmt.
		fmt <= 4 ifTrue:
			[fixedFields _ atCache at: atIx+AtCacheFixedFields.
			^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr].
		fmt < 8 ifTrue:  "Bitmap"
			[result _ self fetchWord: index - 1 ofObject: rcvr.
			self externalizeIPandSP.
			result _ self positive32BitIntegerFor: result.
			self internalizeIPandSP.
			^ result].
		fmt >= 16  "Note fmt >= 16 is an artificial flag for strings"
			ifTrue: "String"
			[^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)]
			ifFalse: "ByteArray"
			[^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]].

	self primitiveFail! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 23:17'!
install: rcvr inAtCache: cache at: atIx string: stringy
	"Install the oop of this object in the given cache (at or atPut), along with
	its size, format and fixedSize"
	| hdr fmt totalLength fixedFields |
	self var: #cache declareC: 'int *cache'.

	hdr _ self baseHeader: rcvr.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	(fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
		["Contexts must not be put in the atCache, since their size is not constant"
		^ self primitiveFail].
	totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.

	cache at: atIx+AtCacheOop put: rcvr.
	stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16]  "special flag for strings"
			ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
	cache at: atIx+AtCacheFixedFields put: fixedFields.
	cache at: atIx+AtCacheSize put: totalLength - fixedFields.
! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 11/29/1998 21:24'!
lengthOf: oop
	"Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."

	| header |
	self inline: true.
	header _ self baseHeader: oop.
	^ self lengthOf: oop baseHeader: header format: ((header >> 8) bitAnd: 16rF)! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'go 11/17/1998 15:55'!
lengthOf: oop baseHeader: hdr format: fmt
	"Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."

	| sz |
	self inline: true.
	(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: [ sz _ hdr bitAnd: SizeMask ].

	fmt < 8
		ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 ]  "words"
		ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) ]  "bytes"! !

!Interpreter methodsFor: 'array and stream primitives'!
okArrayClass: cl

	^(cl = (self splObj: ClassArray) or:
	  [cl = (self splObj: ClassBitmap) or:
	  [cl = (self splObj: ClassByteArray)]])! !

!Interpreter methodsFor: 'array and stream primitives'!
okStreamArrayClass: cl

	^(cl = (self splObj: ClassString) or:
	  [cl = (self splObj: ClassArray) or:
	  [cl = (self splObj: ClassByteArray) or:
	  [cl = (self splObj: ClassBitmap)]]])! !

!Interpreter methodsFor: 'array and stream primitives'!
primitiveAt

	self commonAt: false.! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/11/1998 10:15'!
primitiveAtEnd
	| stream index limit |
	stream _ self popStack.
	successFlag _ ((self isPointers: stream)
			and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)]).
 	successFlag ifTrue: [
		index _ self fetchInteger: StreamIndexIndex ofObject: stream.
		limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream].
 	successFlag
		ifTrue: [self pushBool: (index >= limit)]
		ifFalse: [self unPop: 1].! !

!Interpreter methodsFor: 'array and stream primitives'!
primitiveAtPut

	self commonAtPut: false.! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/14/1998 14:58'!
primitiveNext
	"PrimitiveNext will succeed only if the stream's array is in the atCache.
	Otherwise failure will lead to proper message lookup of at: and
	subsequent installation in the cache if appropriate."
	| stream array index limit result atIx |
	stream _ self stackTop.
	((self isPointers: stream)
		and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
		ifFalse: [^ self primitiveFail].

	array _ self fetchPointer: StreamArrayIndex ofObject: stream.
	index _ self fetchInteger: StreamIndexIndex ofObject: stream.
	limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream.
	atIx _ array bitAnd: AtCacheMask.
	(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
		ifFalse: [^ self primitiveFail].

	"OK -- its not at end, and the array is in the cache"
	index _ index + 1.
	result _ self commonVariable: array at: index cacheIndex: atIx.
	"Above may cause GC, so can't use stream, array etc. below it"
	successFlag ifTrue:
		[stream _ self stackTop.
		self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
		^ self pop: 1 thenPush: result].
! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/14/1998 14:58'!
primitiveNextPut
	"PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
	Otherwise failure will lead to proper message lookup of at:put: and
	subsequent installation in the cache if appropriate."
	| value stream index limit array atIx |
	value _ self stackTop.
	stream _ self stackValue: 1.
	((self isPointers: stream)
		and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
		ifFalse: [^ self primitiveFail].

	array _ self fetchPointer: StreamArrayIndex ofObject: stream.
	index _ self fetchInteger: StreamIndexIndex ofObject: stream.
	limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream.
	atIx _ (array bitAnd: AtCacheMask) + AtPutBase.
	(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
		ifFalse: [^ self primitiveFail].

	"OK -- its not at end, and the array is in the cache"
	index _ index + 1.
	self commonVariable: array at: index put: value cacheIndex: atIx.
	successFlag ifTrue:
		[self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
		^ self pop: 2 thenPush: value].
! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 3/29/1999 11:28'!
primitiveSize
	| rcvr sz |
	rcvr _ self stackTop.
	(self isIntegerObject: rcvr) ifTrue: [^ self primitiveFail].  "Integers are not indexable"
	(self formatOf: rcvr) < 2 ifTrue: [^ self primitiveFail].  "This is not an indexable object"
	sz _ self stSizeOf: rcvr.
	successFlag ifTrue:
		[self pop: 1 thenPush: (self positive32BitIntegerFor: sz)]
! !

!Interpreter methodsFor: 'array and stream primitives'!
primitiveStringAt

	self commonAt: true.! !

!Interpreter methodsFor: 'array and stream primitives'!
primitiveStringAtPut

	self commonAtPut: true.! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'ls 8/18/1998 06:24'!
primitiveStringReplace
"
<array> primReplaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
"
	| array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |
	array _ self stackValue: 4.
	start _ self stackIntegerValue: 3.
	stop _ self stackIntegerValue: 2.
	repl _ self stackValue: 1.
	replStart _ self stackIntegerValue: 0.

	successFlag ifFalse: [^ self primitiveFail].
	(self isIntegerObject: repl)  "can happen in LgInt copy"
		ifTrue: [^ self primitiveFail].

	hdr _ self baseHeader: array.
	arrayFmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt.
	arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength.
	((start >= 1) and: [(start <= stop) and: [stop + arrayInstSize <= totalLength]])
		ifFalse: [^ self primitiveFail].

	hdr _ self baseHeader: repl.
	replFmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt.
	replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength.
	((replStart >= 1) and: [stop - start + replStart + replInstSize <= totalLength])
		ifFalse: [^ self primitiveFail].

	"Array formats (without byteSize bits, if bytes array) must be same"
	arrayFmt < 8
		ifTrue: [arrayFmt = replFmt ifFalse: [^ self primitiveFail]]
		ifFalse: [(arrayFmt bitAnd: 16rC) = (replFmt bitAnd: 16rC) ifFalse: [^ self primitiveFail]].

	srcIndex _ replStart + replInstSize - 1.   " - 1 for 0-based access"

	arrayFmt < 4 ifTrue: [ "pointer type objects"
		start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | 
			self storePointer: i ofObject: array withValue:
				(self fetchPointer: srcIndex ofObject: repl).
			srcIndex _ srcIndex + 1. ] ]
	ifFalse: [
		arrayFmt < 8  ifTrue: [ "long-word type objects"
			start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | 
				self storeWord: i ofObject: array withValue:
					(self fetchWord: srcIndex ofObject: repl).
				srcIndex _ srcIndex + 1 ] ]
		ifFalse: [  "byte-type objects"
			start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | 
				self storeByte: i ofObject: array withValue:
					(self fetchByte: srcIndex ofObject: repl).
				srcIndex _ srcIndex + 1. ] ].	].


	self pop: 4.  "leave rcvr on stack"! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:38'!
stObject: array at: index
	"Return what ST would return for <obj> at: index."

	| hdr fmt totalLength fixedFields stSize |
	self inline: false.
	hdr _ self baseHeader: array.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize _ self fetchStackPointerOf: array]
		ifFalse: [stSize _ totalLength - fixedFields].
	((self cCoerce: index to: 'unsigned ') >= 1
		and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')])
		ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
		ifFalse: [successFlag _ false.  ^ 0].! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:39'!
stObject: array at: index put: value
	"Do what ST would return for <obj> at: index put: value."
	| hdr fmt totalLength fixedFields stSize |
	self inline: false.
	hdr _ self baseHeader: array.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: array baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: array format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [stSize _ self fetchStackPointerOf: array]
		ifFalse: [stSize _ totalLength - fixedFields].
	((self cCoerce: index to: 'unsigned ') >= 1
		and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')])
		ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
		ifFalse: [successFlag _ false]! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:39'!
stSizeOf: oop
	"Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
	"Note: Assume oop is not a SmallInteger!!"

	| hdr fmt totalLength fixedFields |
	self inline: true.
	hdr _ self baseHeader: oop.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength.
	(fmt = 3 and: [self isContextHeader: hdr])
		ifTrue: [^ self fetchStackPointerOf: oop]
		ifFalse: [^ totalLength - fixedFields]! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'ar 3/21/98 02:37'!
subscript: array with: index format: fmt
	"Note: This method assumes that the index is within bounds!!"

	self inline: true.
	fmt <= 4 ifTrue: [  "pointer type objects"
		^ self fetchPointer: index - 1 ofObject: array].
	fmt < 8 ifTrue: [  "long-word type objects"
		^ self positive32BitIntegerFor:
			(self fetchWord: index - 1 ofObject: array)
	] ifFalse: [  "byte-type objects"
		^ self integerObjectOf:
			(self fetchByte: index - 1 ofObject: array)
	].! !

!Interpreter methodsFor: 'array and stream primitives' stamp: 'ar 3/21/98 02:38'!
subscript: array with: index storing: oopToStore format: fmt
	"Note: This method assumes that the index is within bounds!!"

	| valueToStore |
	self inline: true.
	fmt <= 4 ifTrue: [  "pointer type objects"
		self storePointer: index - 1 ofObject: array withValue: oopToStore.
	] ifFalse: [
		fmt < 8 ifTrue: [  "long-word type objects"
			valueToStore _ self positive32BitValueOf: oopToStore.
			successFlag ifTrue:
				[self storeWord: index - 1 ofObject: array withValue: valueToStore].
		] ifFalse: [  "byte-type objects"
			(self isIntegerObject: oopToStore) ifFalse: [successFlag _ false].
			valueToStore _ self integerValueOf: oopToStore.
			((valueToStore >= 0) and: [valueToStore <= 255]) ifFalse: [successFlag _ false].
			successFlag ifTrue:
				[self storeByte: index - 1 ofObject: array withValue: valueToStore].
		].
	].! !


!Interpreter methodsFor: 'object access primitives' stamp: 'di 1/9/1999 15:30'!
primitiveArrayBecome
	"We must flush the method cache here, to eliminate stale references
	to mutated classes and/or selectors."

	| arg rcvr |
	arg _ self stackTop.
	rcvr _ self stackValue: 1.
	self success: (self become: rcvr with: arg twoWay: true).
	self flushMethodCache.
	successFlag ifTrue: [ self pop: 1 ].! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 1/9/1999 15:30'!
primitiveArrayBecomeOneWay
	"We must flush the method cache here, to eliminate stale references
	to mutated classes and/or selectors."

	| arg rcvr |
	arg _ self stackTop.
	rcvr _ self stackValue: 1.
	self success: (self become: rcvr with: arg twoWay: false).
	self flushMethodCache.
	successFlag ifTrue: [ self pop: 1 ].! !

!Interpreter methodsFor: 'object access primitives'!
primitiveAsOop
	| thisReceiver |
	thisReceiver _ self popStack.
	self success: (self isIntegerObject: thisReceiver) not.
	successFlag
		ifTrue: [self pushInteger: (self hashBitsOf: thisReceiver)]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveClass
	| instance |
	instance _ self popStack.
	self push: (self fetchClassOf: instance)! !

!Interpreter methodsFor: 'object access primitives'!
primitiveClone
	"Return a shallow copy of the receiver."

	| newCopy |
	newCopy _ self clone: (self stackTop).
	self pop: 1 thenPush: newCopy.! !

!Interpreter methodsFor: 'object access primitives'!
primitiveEquivalent
	| thisObject otherObject |
	otherObject _ self popStack.
	thisObject _ self popStack.
	self pushBool: thisObject = otherObject! !

!Interpreter methodsFor: 'object access primitives'!
primitiveInstVarAt

	| index rcvr hdr fmt totalLength fixedFields value |
	index _ self popInteger.
	rcvr _ self popStack.
	successFlag ifTrue: [
		hdr _ self baseHeader: rcvr.
		fmt _ (hdr >> 8) bitAnd: 16rF.
		totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.
		fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.
		((index >= 1) and: [index <= fixedFields])
			ifFalse: [successFlag _ false]].
	successFlag
		ifTrue: [value _ self subscript: rcvr with: index format: fmt].
	successFlag
		ifTrue: [self push: value]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveInstVarAtPut

	| newValue index rcvr hdr fmt totalLength fixedFields |
	newValue _ self popStack.
	index _ self popInteger.
	rcvr _ self popStack.
	successFlag ifTrue: [
		hdr _ self baseHeader: rcvr.
		fmt _ (hdr >> 8) bitAnd: 16rF.
		totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt.
		fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength.
		((index >= 1) and: [index <= fixedFields])
			ifFalse: [successFlag _ false]].
	successFlag
		ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt].
	successFlag
		ifTrue: [self push: newValue]
		ifFalse: [self unPop: 3]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'ar 4/6/1999 13:08'!
primitiveNew
	"Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."

	| class spaceOkay |
	class _ self stackValue: 0.
	"The following may cause GC!!"
	spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: 0.
	self success: spaceOkay.
	successFlag
		ifTrue: [ self push: (self instantiateClass: self popStack indexableSize: 0) ]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'ar 4/6/1999 13:08'!
primitiveNewWithArg
	"Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free."

	| size class spaceOkay |
	size _ self positive32BitValueOf: (self stackValue: 0).
	class _ self stackValue: 1.
	self success: size >= 0.
	successFlag ifTrue: [
		"The following may cause GC!!"
		spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: size.
		self success: spaceOkay.
		class _ self stackValue: 1. "Reload class in case of GC"
	].
	successFlag
		ifTrue: [ self pop: 2 thenPush: (self instantiateClass: class indexableSize: size) ]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveNextInstance
	| object instance |
	object _ self popStack.
	instance _ self instanceAfter: object.
	instance = nilObj
		ifTrue: [self unPop: 1. self primitiveFail]
		ifFalse: [self push: instance]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveNextObject
	"Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects."

	| object instance |
	object _ self popStack.
	instance _ self accessibleObjectAfter: object.
	instance = nil
		ifTrue: [ self pushInteger: 0 ]
		ifFalse: [ self push: instance ].! !

!Interpreter methodsFor: 'object access primitives'!
primitiveObjectAt  "Defined for CompiledMethods only"
	| thisReceiver index |
	index  _ self popInteger.
	thisReceiver _ self popStack.
	self success: index > 0.
	self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
	successFlag
		ifTrue: [self push: (self fetchPointer: index - 1
					ofObject: thisReceiver)]
		ifFalse: [self unPop: 2]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveObjectAtPut  "Defined for CompiledMethods only"
	| thisReceiver index newValue |
	newValue _ self popStack.
	index _ self popInteger.
	thisReceiver _ self popStack.
	self success: index > 0.
	self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart).
	successFlag
		ifTrue: [self storePointer: index - 1
				ofObject: thisReceiver
				withValue: newValue.
			self push: newValue]
		ifFalse: [self unPop: 3]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveObjectPointsTo
	| rcvr thang lastField |
	thang _ self popStack.
	rcvr _ self popStack.
	(self isIntegerObject: rcvr) ifTrue: [^ self pushBool: false].
	lastField _ self lastPointerOf: rcvr.
	BaseHeaderSize to: lastField by: 4 do:
		[:i | (self longAt: rcvr + i) = thang
			ifTrue: [^ self pushBool: true]].
	self pushBool: false.! !

!Interpreter methodsFor: 'object access primitives' stamp: 'jm 12/10/1998 18:49'!
primitivePointX
	| rcvr | 
	self inline: false.
	rcvr _ self popStack.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'jm 12/10/1998 18:50'!
primitivePointY
	| rcvr | 
	self inline: false.
	rcvr _ self popStack.
	self assertClassOf: rcvr is: (self splObj: ClassPoint).
	successFlag
		ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)]
		ifFalse: [self unPop: 1]! !

!Interpreter methodsFor: 'object access primitives' stamp: 'jm 1/6/98 18:44'!
primitiveSomeInstance
	| class instance |
	class _ self popStack.
	instance _ self initialInstanceOf: class.
	instance = nilObj
		ifTrue: [self unPop: 1. self primitiveFail]
		ifFalse: [self push: instance]! !

!Interpreter methodsFor: 'object access primitives'!
primitiveSomeObject
	"Return the first object in the heap."

	self pop: 1.
	self push: self firstAccessibleObject.! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 1/11/1999 13:20'!
primitiveStoreStackp
	"Atomic store into context stackPointer.
	Also ensures that any newly accessible cells are initialized to nil"
	| ctxt newStackp stackp |
	ctxt _ self stackValue: 1.
	newStackp _ self stackIntegerValue: 0.
	self success: (newStackp >= 0).
	self success: (newStackp <= (LargeContextSize-BaseHeaderSize // 4 - CtxtTempFrameStart)).
	successFlag ifFalse: [^ self primitiveFail].

	stackp _ self fetchStackPointerOf: ctxt.
	newStackp > stackp ifTrue:
		["Nil any newly accessible cells"
		stackp + 1 to: newStackp do:
			[:i | self storePointer: i+CtxtTempFrameStart-1	ofObject: ctxt withValue: nilObj]].
	self storeStackPointerValue: newStackp inContext: ctxt.
	self pop: 1
! !

!Interpreter methodsFor: 'object access primitives' stamp: 'di 12/27/1998 16:28'!
sufficientSpaceToInstantiate: classOop indexableSize: size
	"Return the number of bytes required to allocate an instance of the given class with the given number of indexable fields."
	"Details: For speed, over-estimate space needed for fixed fields or literals; the low space threshold is a blurry line."

	| format okay |
	self inline: true.
	format _ ((self formatOfClass: classOop) >> 8) bitAnd: 16rF.

	"fail if attempting to call new: on non-indexable class"
	((self cCoerce: size to: 'unsigned ') > 0 and: [format < 2]) ifTrue: [ ^ false ].

	format < 8 ifTrue: [
		"indexable fields are words or pointers"
		okay _ self sufficientSpaceToAllocate: (2500 + (size * 4)).
	] ifFalse: [
		"indexable fields are bytes"
		okay _ self sufficientSpaceToAllocate: (2500 + size).
	].

	^ okay! !


!Interpreter methodsFor: 'control primitives' stamp: 'di 12/5/1998 21:28'!
internalPrimitiveValue
	| newContext blockArgumentCount initialIP |
	self inline: true.
	self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.

	successFlag _ true.
	newContext _ self internalStackValue: argumentCount.
	self assertClassOf: newContext is: (self splObj: ClassBlockContext).
	blockArgumentCount _ self argumentCountOfBlock: newContext.
	self success: (argumentCount = blockArgumentCount
			and: [(self fetchPointer: CallerIndex ofObject: newContext) = nilObj]).
	successFlag ifTrue:
		["This code assumes argCount can only = 0 or 1"
		argumentCount = 1 ifTrue:
			[self storePointer: TempFrameStart ofObject: newContext
				withValue: self internalStackTop].
		self internalPop: argumentCount + 1.

		initialIP _ self fetchPointer: InitialIPIndex	ofObject: newContext.
		self storePointerUnchecked: InstructionPointerIndex ofObject: newContext
			withValue: initialIP.
		self storeStackPointerValue: argumentCount	inContext: newContext.
		self storePointerUnchecked: CallerIndex		ofObject: newContext
			withValue: activeContext.
		self internalNewActiveContext: newContext]
 	ifFalse:
		[messageSelector _ self specialSelector: 25+argumentCount.
		self normalSend].
! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 1/10/1999 23:29'!
primitiveBlockCopy

	| context methodContext contextSize newContext initialIP |
	context _ self stackValue: 1.
	(self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
		ifTrue: ["context is a block; get the context of its enclosing method"
				methodContext _ self fetchPointer: HomeIndex ofObject: context]
		ifFalse: [methodContext _ context].
	contextSize _ self sizeBitsOf: methodContext.  "in bytes, including header"
	context _ nil.  "context is no longer needed and is not preserved across allocation"

	"remap methodContext in case GC happens during allocation"
	self pushRemappableOop: methodContext.
	newContext _ self instantiateContext: (self splObj: ClassBlockContext)
							   sizeInBytes: contextSize.
	methodContext _ self popRemappableOop.

	initialIP _ self integerObjectOf: instructionPointer - method.
	"Was instructionPointer + 3, but now it's greater by 
		methodOop + 4 (headerSize) and less by 1 due to preIncrement"

	"Assume: have just allocated a new context; it must be young.
	 Thus, can use uncheck stores. See the comment in fetchContextRegisters."

	self storeWord: InitialIPIndex					ofObject: newContext
		withValue: initialIP.
	self storeWord: InstructionPointerIndex		ofObject: newContext
		withValue: initialIP.
	self storeStackPointerValue: 0				inContext: newContext.
	self storePointerUnchecked: BlockArgumentCountIndex	ofObject: newContext
		withValue: (self stackValue: 0).
	self storePointerUnchecked: HomeIndex		ofObject: newContext
		withValue: methodContext.
	self storePointerUnchecked: SenderIndex		ofObject: newContext
		withValue: nilObj.

	self pop: 2 thenPush: newContext.! !

!Interpreter methodsFor: 'control primitives' stamp: 'jm 12/14/1998 09:53'!
primitiveDoPrimitiveWithArgs
	| argumentArray arraySize index cntxSize primIdx |
	argumentArray _ self stackTop.
	arraySize _ self fetchWordLengthOf: argumentArray.
	cntxSize _ self fetchWordLengthOf: activeContext.
	self success: (self stackPointerIndex + arraySize) < cntxSize.
	self assertClassOf: argumentArray is: (self splObj: ClassArray).
	primIdx _ self stackIntegerValue: 1.
	successFlag ifFalse: [^ self primitiveFail].  "invalid args"

	"Pop primIndex and argArray, then push args in place..."
	self pop: 2.
	primitiveIndex _ primIdx.
	argumentCount _ arraySize.
	index _ 1.
	[index <= argumentCount]
		whileTrue:
		[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
		index _ index + 1].

	"Run the primitive (sets successFlag)"
	self pushRemappableOop: argumentArray.	"prim might alloc/gc"
	lkupClass _ nilObj.
	self primitiveResponse.
	argumentArray _ self popRemappableOop.

	successFlag ifFalse:
		["If primitive failed, then restore state for failure code"
		self pop: arraySize.
		self pushInteger: primIdx.
		self push: argumentArray.
		argumentCount _ 2.
		"... caller (execNewMeth) will run failure code"]! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 11:38'!
primitivePerform
	| performSelector newReceiver selectorIndex lookupClass performMethod |
	performSelector _ messageSelector.
	performMethod _ newMethod.
	messageSelector _ self stackValue: argumentCount - 1.
	newReceiver _ self stackValue: argumentCount.
	"NOTE: the following lookup may fail and be converted to #doesNotUnderstand:,
		so we must adjust argumentCount and slide args now, so that would work."

	"Slide arguments down over selector"
	argumentCount _ argumentCount - 1.
	selectorIndex _ self stackPointerIndex - argumentCount.
	self transfer: argumentCount
		fromIndex: selectorIndex + 1
		ofObject: activeContext
		toIndex: selectorIndex
		ofObject: activeContext.
	self pop: 1.

	lookupClass _ self fetchClassOf: newReceiver.
	self findNewMethodInClass: lookupClass.
	self success: ((self argumentCountOf: newMethod) = argumentCount).
	successFlag
		ifTrue: [self executeNewMethod.  "Recursive xeq affects successFlag"
				successFlag _ true]
		ifFalse: ["Slide the args back up (sigh) and re-insert the selector."
				1 to: argumentCount do:
					[:i |
					self storePointer: argumentCount-i+1+selectorIndex ofObject: activeContext
						withValue:
						(self fetchPointer: argumentCount-i+selectorIndex ofObject: activeContext)].
				self unPop: 1.
				self storePointer: selectorIndex ofObject: activeContext withValue: messageSelector.
				argumentCount _ argumentCount + 1.
				newMethod _ performMethod.
				messageSelector _ performSelector]! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 10:50'!
primitivePerformAt: lookupClass
	"Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"

	"NOTE:  The case of doesNotUnderstand: is not a failure to perform.
	The only failures are arg types and consistency of argumentCount."

	| performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
	argumentArray _ self popStack.
	self assertClassOf: argumentArray is: (self splObj: ClassArray).
	successFlag ifTrue:
		["Check for enough space to push all args"
		arraySize _ self fetchWordLengthOf: argumentArray.
		cntxSize _ self fetchWordLengthOf: activeContext.
		self success: (self stackPointerIndex + arraySize) < cntxSize].
	successFlag ifFalse: [^ self unPop: 1].

	performSelector _ messageSelector.
	performMethod _ newMethod.
	performArgCount _ argumentCount.
	messageSelector _ self popStack.

	"Copy the arguments to the stack, and execute"
	index _ 1.
	[index <= arraySize]
		whileTrue:
		[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
		index _ index + 1].
	argumentCount _ arraySize.
	self findNewMethodInClass: lookupClass.
	self success: (self argumentCountOf: newMethod) = argumentCount.
	successFlag
		ifTrue: [self executeNewMethod.  "Recursive xeq affects successFlag"
				successFlag _ true]
		ifFalse: ["Restore the state and fail"
				self pop: argumentCount.
				self push: messageSelector.
				self push: argumentArray.
				messageSelector _ performSelector.
				newMethod _ performMethod.
				argumentCount _ performArgCount]
! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 10:57'!
primitivePerformInSuperclass
	| lookupClass rcvr currentClass |
	lookupClass _ self stackTop.
	rcvr _ self stackValue: argumentCount.
	currentClass _ self fetchClassOf: rcvr.
	[currentClass ~= lookupClass]
		whileTrue:
		[currentClass _ self superclassOf: currentClass.
		currentClass = nilObj ifTrue: [^ self primitiveFail]].

	self popStack.
	self primitivePerformAt: lookupClass.
	successFlag ifFalse:
		[self push: lookupClass]! !

!Interpreter methodsFor: 'control primitives' stamp: 'di 4/12/1999 10:55'!
primitivePerformWithArgs

	| lookupClass rcvr |
	rcvr _ self stackValue: argumentCount.
	lookupClass _ self fetchClassOf: rcvr.
	self primitivePerformAt: lookupClass.
! !

!Interpreter methodsFor: 'control primitives'!
primitiveValue
	| blockContext blockArgumentCount initialIP |
	blockContext _ self stackValue: argumentCount.
	blockArgumentCount _ self argumentCountOfBlock: blockContext.
	self success: (argumentCount = blockArgumentCount
			and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]).
	successFlag
		ifTrue: [self transfer: argumentCount
				fromIndex: self stackPointerIndex - argumentCount + 1
				ofObject: activeContext
				toIndex: TempFrameStart
				ofObject: blockContext.

			"Assume: The call to transfer:... makes blockContext a root if necessary,
			 allowing use to use unchecked stored in the following code."
			self pop: argumentCount + 1.
			initialIP _ self fetchPointer: InitialIPIndex	ofObject: blockContext.
			self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext
				withValue: initialIP.
			self storeStackPointerValue: argumentCount	inContext: blockContext.
			self storePointerUnchecked: CallerIndex		ofObject: blockContext
				withValue: activeContext.
			self newActiveContext: blockContext]! !

!Interpreter methodsFor: 'control primitives'!
primitiveValueWithArgs

	| argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
	argumentArray _ self popStack.
	blockContext _ self popStack.
	blockArgumentCount _ self argumentCountOfBlock: blockContext.
	self assertClassOf: argumentArray is: (self splObj: ClassArray).
	successFlag ifTrue: [
		arrayArgumentCount _ self fetchWordLengthOf: argumentArray.
		self success: (arrayArgumentCount = blockArgumentCount
			and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].
	successFlag ifTrue: [
		self transfer: arrayArgumentCount
			fromIndex: 0
			ofObject: argumentArray
			toIndex: TempFrameStart
			ofObject: blockContext.

		"Assume: The call to transfer:... makes blockContext a root if necessary,
		 allowing use to use unchecked stored in the following code."
		initialIP _ self fetchPointer: InitialIPIndex			ofObject: blockContext.
		self storePointerUnchecked: InstructionPointerIndex	ofObject: blockContext
			withValue: initialIP.
		self storeStackPointerValue: arrayArgumentCount	inContext: blockContext.
		self storePointerUnchecked: CallerIndex				ofObject: blockContext
			withValue: activeContext.
		self newActiveContext: blockContext.
	] ifFalse: [self unPop: 2].! !


!Interpreter methodsFor: 'processes'!
addLastLink: proc toList: aList
	"Add the given process to the given linked list and set the backpointer
	of process to its new list."

	| lastLink |
	(self isEmptyList: aList) ifTrue: [
		self storePointer: FirstLinkIndex ofObject: aList withValue: proc.
	] ifFalse: [
		lastLink _ self fetchPointer: LastLinkIndex ofObject: aList.
		self storePointer: NextLinkIndex ofObject: lastLink withValue: proc.
	].
	self storePointer: LastLinkIndex ofObject: aList withValue: proc.
	self storePointer: MyListIndex   ofObject:  proc withValue: aList.! !

!Interpreter methodsFor: 'processes' stamp: 'ar 7/30/2000 17:37'!
checkForInterrupts
	"Check for possible interrupts and handle one if necessary."

	| sema now |
	self inline: false.

	"Mask so same wrap as primitiveMillisecondClock"
	now _ self ioMSecs bitAnd: MillisecondClockMask. 

	now < lastTick ifTrue: [
		"millisecond clock wrapped"
		nextPollTick _ now + (nextPollTick - lastTick).
		nextWakeupTick ~= 0
			ifTrue: [nextWakeupTick _ now + (nextWakeupTick - lastTick)]].

	(now - lastTick) < interruptChecksEveryNms ifTrue: "wrapping is not a concern"
	    [interruptCheckCounterFeedBackReset _ interruptCheckCounterFeedBackReset + 10]
	ifFalse: 
		[interruptCheckCounterFeedBackReset <= 1000 
			ifTrue: [interruptCheckCounterFeedBackReset _ 1000]
			ifFalse: [interruptCheckCounterFeedBackReset _ interruptCheckCounterFeedBackReset - 12]].

	interruptCheckCounter _ interruptCheckCounterFeedBackReset.  "reset the interrupt check counter"

	lastTick _ now.  "used to detect millisecond clock wrapping"

	signalLowSpace ifTrue: [
		signalLowSpace _ false.  "reset flag"
		sema _ (self splObj: TheLowSpaceSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	now >= nextPollTick ifTrue: [
		self ioProcessEvents.  "sets interruptPending if interrupt key pressed"
		nextPollTick _ now + 500].  "msecs to wait before next call to ioProcessEvents"

	interruptPending ifTrue: [
		interruptPending _ false.  "reset interrupt flag"
		sema _ (self splObj: TheInterruptSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	((nextWakeupTick ~= 0) and: [now >= nextWakeupTick]) ifTrue: [
		nextWakeupTick _ 0.  "reset timer interrupt"
		sema _ (self splObj: TheTimerSemaphore).
		sema = nilObj ifFalse: [self synchronousSignal: sema]].

	"signal any pending finalizations"
	pendingFinalizationSignals > 0 ifTrue:[
		sema _ self splObj: TheFinalizationSemaphore.
		(self fetchClassOf: sema) = (self splObj: ClassSemaphore) 
			ifTrue:[self synchronousSignal: sema].
		pendingFinalizationSignals _ 0.
	].

	"signal all semaphores in semaphoresToSignal" 
	(semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
		ifTrue: [self signalExternalSemaphores].
! !

!Interpreter methodsFor: 'processes' stamp: 'jm 5/30/2000 09:35'!
internalQuickCheckForInterrupts
	"Internal version of quickCheckForInterrupts for use within jumps."

	self inline: true.
	((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [
		self externalizeIPandSP.
		self checkForInterrupts.

		"When Squeak runs as a browser plugin, it must return control to the browser periodically. This should done only when the state of the currently running Squeak thread is safely stored in the object heap, as is the case at this point. Since this method is inlined, the message 'ReturnFromInterpret' is actually a C macro that returns control from the interpret() method to the browser that called it."
		GenerateBrowserPlugin ifTrue: [
			self plugInTimeToReturn ifTrue: [self ReturnFromInterpret]].

		self internalizeIPandSP].
! !

!Interpreter methodsFor: 'processes'!
isEmptyList: aLinkedList

	^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj! !

!Interpreter methodsFor: 'processes'!
primitiveResume

	| proc |
	proc _ self stackTop.  "rcvr"
	"self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))."
	successFlag ifTrue: [ self resume: proc ].! !

!Interpreter methodsFor: 'processes'!
primitiveSignal

	| sema |
	sema _ self stackTop.  "rcvr"
	self assertClassOf: sema is: (self splObj: ClassSemaphore).
	successFlag ifTrue: [ self synchronousSignal: sema ].! !

!Interpreter methodsFor: 'processes'!
primitiveSuspend

	| activeProc |
	activeProc _ self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	self success: self stackTop = activeProc.
	successFlag ifTrue: [
		self pop: 1.
		self push: nilObj.
		self transferTo: self wakeHighestPriority.
	].! !

!Interpreter methodsFor: 'processes'!
primitiveWait

	| sema excessSignals activeProc |
	sema _ self stackTop.  "rcvr"
	self assertClassOf: sema is: (self splObj: ClassSemaphore).
	successFlag ifTrue: [
		excessSignals _
			self fetchInteger: ExcessSignalsIndex ofObject: sema.
		excessSignals > 0 ifTrue: [
			self storeInteger: ExcessSignalsIndex
				ofObject: sema withValue: excessSignals - 1.
		] ifFalse: [
			activeProc _ self fetchPointer: ActiveProcessIndex
								 ofObject: self schedulerPointer.
			self addLastLink: activeProc toList: sema.
			self transferTo: self wakeHighestPriority.
		].
	].! !

!Interpreter methodsFor: 'processes'!
putToSleep: aProcess
	"Save the given process on the scheduler process list for its priority."

	| priority processLists processList |
	priority _ self quickFetchInteger: PriorityIndex ofObject: aProcess.
	processLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
	processList _ self fetchPointer: priority - 1 ofObject: processLists.
	self addLastLink: aProcess toList: processList.! !

!Interpreter methodsFor: 'processes' stamp: 'jm 8/22/1998 09:37'!
quickCheckForInterrupts
	"Quick check for possible user or timer interrupts. Decrement a counter and only do a real check when counter reaches zero or when a low space or user interrupt is pending."
	"Note: Clients that trigger interrupts should set interruptCheckCounter to zero to get immediate results."
	"Note: Requires that instructionPointer and stackPointer be external."

	((interruptCheckCounter _ interruptCheckCounter - 1) <= 0)
		ifTrue: [self checkForInterrupts].
! !

!Interpreter methodsFor: 'processes'!
removeFirstLinkOfList: aList
	"Remove the first process from the given linked list."

	| first last next |
	first _ self fetchPointer: FirstLinkIndex ofObject: aList.
	last  _ self fetchPointer: LastLinkIndex ofObject: aList.
	first = last ifTrue: [
		self storePointer: FirstLinkIndex ofObject: aList withValue: nilObj.
		self storePointer:  LastLinkIndex ofObject: aList withValue: nilObj.
	] ifFalse: [
		next _ self fetchPointer: NextLinkIndex ofObject: first.
		self storePointer: FirstLinkIndex ofObject: aList withValue: next.
	].
	self storePointer: NextLinkIndex ofObject: first withValue: nilObj.
	^ first! !

!Interpreter methodsFor: 'processes'!
resume: aProcess

	| activeProc activePriority newPriority |
	self inline: false.
	activeProc _ self fetchPointer: ActiveProcessIndex
						 ofObject: self schedulerPointer.
	activePriority _ self quickFetchInteger: PriorityIndex ofObject: activeProc.
	newPriority   _ self quickFetchInteger: PriorityIndex ofObject: aProcess.
	newPriority > activePriority ifTrue: [
		self putToSleep: activeProc.
		self transferTo: aProcess.
	] ifFalse: [
		self putToSleep: aProcess.
	].! !

!Interpreter methodsFor: 'processes'!
schedulerPointer

	^ self fetchPointer: ValueIndex
		ofObject: (self splObj: SchedulerAssociation)! !

!Interpreter methodsFor: 'processes' stamp: 'JMM 6/6/2000 00:17'!
signalExternalSemaphores
	"Signal all requested semaphores"
	| xArray xSize index sema |
	semaphoresUseBufferA _ semaphoresUseBufferA not.
	xArray _ self splObj: ExternalObjectsArray.
	xSize _ self stSizeOf: xArray.
	semaphoresUseBufferA ifTrue: ["use opposite buffer during read"
		1 to: semaphoresToSignalCountB do: [:i |
			index _ semaphoresToSignalB at: i.
			(index <= xSize) ifTrue:[
				sema _ self fetchPointer: index - 1 ofObject: xArray.
					"Note: semaphore indices are 1-based"
				(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
					ifTrue: [self synchronousSignal: sema]]].
		semaphoresToSignalCountB _ 0]
	ifFalse: [
		1 to: semaphoresToSignalCountA do: [:i |
			index _ semaphoresToSignalA at: i.
			(index <= xSize) ifTrue:[
				sema _ self fetchPointer: index - 1 ofObject: xArray.
					"Note: semaphore indices are 1-based"
				(self fetchClassOf: sema) = (self splObj: ClassSemaphore)
					ifTrue: [self synchronousSignal: sema]]].
		semaphoresToSignalCountA _ 0]! !

!Interpreter methodsFor: 'processes' stamp: 'ar 3/21/98 18:39'!
signalFinalization: weakReferenceOop
	"If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Set the interruptCheckCounter to zero to force a real interrupt check as soon as possible."

	interruptCheckCounter _ 0.
	pendingFinalizationSignals _ pendingFinalizationSignals + 1.! !

!Interpreter methodsFor: 'processes' stamp: 'JMM 6/6/2000 00:41'!
signalSemaphoreWithIndex: index
	"Record the given semaphore index in the double buffer semaphores array to be signaled at the next convenient moment. Set the interruptCheckCounter to zero to force a real interrupt check as soon as possible."

	index <= 0 ifTrue: [^ nil].  "bad index; ignore it"

	semaphoresUseBufferA ifTrue: 
		[semaphoresToSignalCountA < SemaphoresToSignalSize ifTrue: [
			semaphoresToSignalCountA _ semaphoresToSignalCountA + 1.
			semaphoresToSignalA at: semaphoresToSignalCountA put: index]]
	ifFalse:
		[semaphoresToSignalCountB < SemaphoresToSignalSize ifTrue: [
			semaphoresToSignalCountB _ semaphoresToSignalCountB + 1.
			semaphoresToSignalB at: semaphoresToSignalCountB put: index]].
	interruptCheckCounter _ 0.
! !

!Interpreter methodsFor: 'processes'!
synchronousSignal: aSemaphore
	"Signal the given semaphore from within the interpreter."

	| excessSignals |
	self inline: false.
	(self isEmptyList: aSemaphore) ifTrue: [
		"no process is waiting on this semaphore"
		excessSignals _
			self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore.
		self storeInteger: ExcessSignalsIndex
			ofObject: aSemaphore withValue: excessSignals + 1.
	] ifFalse: [
		self resume: (self removeFirstLinkOfList: aSemaphore).
	].! !

!Interpreter methodsFor: 'processes' stamp: 'ikp 9/14/2000 01:26'!
transferTo: aProc
	"Record a process to be awoken on the next interpreter cycle.
	ikp 11/24/1999 06:07 -- added hook for external runtime compiler"

	| sched oldProc newProc |
	newProc _ aProc.
	sched _ self schedulerPointer.
	oldProc _ self fetchPointer: ActiveProcessIndex ofObject: sched.
	self storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
	compilerInitialized ifTrue: [
		self compilerProcessChange: oldProc to: newProc.
	] ifFalse: [
		self storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
		self newActiveContext: (self fetchPointer: SuspendedContextIndex ofObject: newProc)
	].
	reclaimableContextCount _ 0.! !

!Interpreter methodsFor: 'processes'!
wakeHighestPriority
	"Return the highest priority process that is ready to run."
	"Note: It is a fatal VM error if there is no runnable process."

	| schedLists p processList |
	schedLists _ self fetchPointer: ProcessListsIndex
				ofObject: self schedulerPointer.
	p _ self fetchWordLengthOf: schedLists.
	p _ p - 1.  "index of last indexable field"
	processList _ self fetchPointer: p ofObject: schedLists.
	[self isEmptyList: processList] whileTrue: [
		p _ p - 1.
		p < 0 ifTrue: [ self error: 'scheduler could not find a runnable process' ].
		processList _ self fetchPointer: p ofObject: schedLists.
	].
	^ self removeFirstLinkOfList: processList! !


!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/26/2000 21:49'!
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."

	| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
	displayObj _ self splObj: TheDisplay.
	aForm = displayObj ifFalse: [^ nil].
	self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
	successFlag ifTrue: [
		dispBits _ self fetchPointer: 0 ofObject: displayObj.
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		d _ self fetchInteger: 3 ofObject: displayObj.
	].
	l < 0 ifTrue:[left _ 0] ifFalse:[left _ l].
	r > w ifTrue:[right _ w] ifFalse:[right _ r].
	t < 0 ifTrue:[top _ 0] ifFalse:[top _ t].
	b > h ifTrue:[bottom _ h] ifFalse:[bottom _ b].
	((left <= right) and: [top <= bottom]) ifFalse:[^nil].
	successFlag ifTrue: [
		(self isIntegerObject: dispBits) ifTrue:[
			surfaceHandle _ self integerValueOf: dispBits.
			showSurfaceFn = 0 ifTrue:[
				showSurfaceFn _ self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
				showSurfaceFn = 0 ifTrue:[^self success: false]].
			self cCode:'((int (*) (int, int, int, int, int))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
		] ifFalse:[
			dispBitsIndex _ dispBits + BaseHeaderSize.  "index in memory byte array"
			self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
				inSmalltalk:[self showDisplayBits: dispBitsIndex 
								w: w h: h d: d
								left: left right: right top: top bottom: bottom]
		].
	].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/26/2000 21:40'!
fullDisplayUpdate
	"Repaint the entire smalltalk screen, ignoring the affected rectangle. Used when the Smalltalk window is brought to the front or uncovered."

	| displayObj w h |
	displayObj _ self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
		w _ self fetchInteger: 1 ofObject: displayObj.
		h _ self fetchInteger: 2 ofObject: displayObj.
		self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h.
		self ioForceDisplayUpdate].
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'di 4/3/1999 22:05'!
primitiveBeCursor
	"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."

	| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
	argumentCount = 0 ifTrue: [
		cursorObj _ self stackTop.
		maskBitsIndex _ nil].
	argumentCount = 1 ifTrue: [
		cursorObj _ self stackValue: 1.
		maskObj _ self stackTop].
	self success: (argumentCount < 2).

	self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
	successFlag ifTrue: [
		bitsObj _ self fetchPointer: 0 ofObject: cursorObj.
		extentX _ self fetchInteger: 1 ofObject: cursorObj.
		extentY _ self fetchInteger: 2 ofObject: cursorObj.
		depth _ self fetchInteger: 3 ofObject: cursorObj.
		offsetObj _ self fetchPointer: 4 ofObject: cursorObj].
		self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).

	successFlag ifTrue: [
		offsetX _ self fetchInteger: 0 ofObject: offsetObj.
		offsetY _ self fetchInteger: 1 ofObject: offsetObj.
		self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
		self success: ((offsetX >= -16) and: [offsetX <= 0]).
		self success: ((offsetY >= -16) and: [offsetY <= 0]).
		self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
		cursorBitsIndex _ bitsObj + BaseHeaderSize.
		self cCode: '' inSmalltalk:
			[ourCursor _ Cursor
				extent: extentX @ extentY
				fromArray: ((1 to: 16) collect: [:i |
					((self fetchWord: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
				offset: offsetX  @ offsetY]].

	argumentCount = 1 ifTrue: [
		self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
		successFlag ifTrue: [
			bitsObj _ self fetchPointer: 0 ofObject: maskObj.
			extentX _ self fetchInteger: 1 ofObject: maskObj.
			extentY _ self fetchInteger: 2 ofObject: maskObj.
			depth _ self fetchInteger: 3 ofObject: maskObj].

		successFlag ifTrue: [
			self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
			self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
			maskBitsIndex _ bitsObj + BaseHeaderSize]].

	successFlag ifTrue: [
		argumentCount = 0
			ifTrue: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
						inSmalltalk: [ourCursor show]]
			ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
						inSmalltalk: [ourCursor show]].
		self pop: argumentCount].
! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveBeDisplay
	"Record the system Display object."

	| rcvr |
	rcvr _ self stackTop.
	self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
	successFlag ifTrue: [
		"record the display object both in a variable and in the specialObjectsOop"
		self storePointer: TheDisplay ofObject: specialObjectsOop withValue: rcvr.
	].! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveBeep

	self ioBeep.! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 20:08'!
primitiveDeferDisplayUpdates
	"Set or clear the flag that controls whether modifications of the Display object are propagated to the underlying platform's screen."

	| flag |
	flag _ self stackTop.
	flag = trueObj
		ifTrue: [deferDisplayUpdates _ true]
		ifFalse: [
			flag = falseObj
				ifTrue: [deferDisplayUpdates _ false]
				ifFalse: [self primitiveFail]].
	successFlag ifTrue: [self pop: 1].  "pop flag; leave rcvr on stack"
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 07:06'!
primitiveForceDisplayUpdate
	"On some platforms, this primitive forces enqueued display updates to be processed immediately. On others, it does nothing."

	self ioForceDisplayUpdate.
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 7/31/2000 23:34'!
primitiveGetNextEvent
	"Primitive. Return the next input event from the OS event queue."
	| evtBuf arg value |
	self var: #evtBuf declareC:'int evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'.
	self cCode:'' inSmalltalk:[evtBuf _ CArrayAccessor on: (IntegerArray new: 8)].
	arg _ self stackValue: 0.
	((self fetchClassOf: arg) = self classArray 
		and:[(self slotSizeOf: arg) = 8]) 
			ifFalse:[^self primitiveFail].
	self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*').
	successFlag ifFalse:[^nil].
	"Event type"
	self 
		storeInteger: 0 
		ofObject: arg 
		withValue: (evtBuf at: 0).
	successFlag ifFalse:[^nil].
	"Event time stamp"
	self 
		storeInteger: 1 
		ofObject: arg 
		withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask).
	successFlag ifFalse:[^nil].
	"Event arguments"
	2 to: 7 do:[:i|
		value _ evtBuf at: i.
		(self isIntegerValue: value)
			ifTrue:[self storeInteger: i ofObject: arg withValue: value]
			ifFalse:["Need to remap because allocation may cause GC"
				self pushRemappableOop: arg.
				value _ self positive32BitIntegerFor: value.
				arg _ self popRemappableOop.
				self storePointer: i ofObject: arg withValue: value.
			].
	].
	successFlag ifFalse:[^nil].
	self pop: 1.! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 7/30/2000 17:31'!
primitiveInputSemaphore
	"Register the input semaphore. If the argument is not a Semaphore, unregister the current input semaphore."

	| arg |
	arg _ self stackValue: 0.
	(self isIntegerObject: arg) ifTrue:[
		"If arg is integer, then use it as an index
		 into the external objects array and install it
		 as the new event semaphore"
		self ioSetInputSemaphore: (self integerValueOf: arg).
		successFlag ifTrue:[self pop: 1].
		^nil
	].
	"old code for compatibility"
	arg _ self popStack.
	((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [
		self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: arg.
	] ifFalse: [
		self storePointer: TheInputSemaphore ofObject: specialObjectsOop withValue: nilObj.
	].! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveInputWord
	"Return an integer indicating the reason for the most recent input interrupt."

	self pop: 1.
	self pushInteger: 0.	"noop for now"! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveInterruptSemaphore
	"Register the user interrupt semaphore. If the argument is not a Semaphore, unregister the current interrupt semaphore."

	| arg |
	arg _ self popStack.
	((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [
		self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg.
	] ifFalse: [
		self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj.
	].! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveKbdNext
	"Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| keystrokeWord |
	self pop: 1.
	keystrokeWord _ self ioGetKeystroke.
	keystrokeWord >= 0
		ifTrue: [self pushInteger: keystrokeWord]
		ifFalse: [self push: nilObj].! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveKbdPeek
	"Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| keystrokeWord |
	self pop: 1.
	keystrokeWord _ self ioPeekKeystroke.
	keystrokeWord >= 0
		ifTrue: [self pushInteger: keystrokeWord]
		ifFalse: [self push: nilObj].! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveMouseButtons
	"Return the mouse button state. The low three bits encode the state of the <red><yellow><blue> mouse buttons. The next four bits encode the Smalltalk modifier bits <cmd><option><ctrl><shift>."

	| buttonWord |
	self pop: 1.
	buttonWord _ self ioGetButtonState.
	self pushInteger: buttonWord.! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveMousePoint
	"Return a Point indicating current position of the mouse. Note that mouse coordinates may be negative if the mouse moves above or to the left of the top-left corner of the Smalltalk window."

	| pointWord x y |
	self pop: 1.
	pointWord _ self ioMousePoint.
	x _ self signExtend16: ((pointWord >> 16) bitAnd: 16rFFFF).
	y _ self signExtend16: (pointWord bitAnd: 16rFFFF).
	self push: (self makePointwithxValue: x  yValue: y).! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveScreenSize
	"Return a point indicating the current size of the Smalltalk window."

	| pointWord |
	self pop: 1.
	pointWord _ self ioScreenSize.
	self push:
		(self makePointwithxValue: ((pointWord >>16) bitAnd: 16rFFFF)
						   yValue: (pointWord bitAnd: 16rFFFF)).! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/5/1999 23:45'!
primitiveSetDisplayMode
	"Set to OS to the requested display mode.
	See also DisplayScreen setDisplayDepth:extent:fullscreen:"
	| fsFlag h w d okay |
	fsFlag _ self booleanValueOf: (self stackValue: 0).
	h _ self stackIntegerValue: 1.
	w _ self stackIntegerValue: 2.
	d _ self stackIntegerValue: 3.
	successFlag ifTrue: [okay _ self cCode:'ioSetDisplayMode(w, h, d, fsFlag)'].
	successFlag ifTrue: [
		self pop: 5. "Pop args+rcvr"
		self pushBool: okay].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 07:08'!
primitiveSetFullScreen
	"On platforms that support it, set full-screen mode to the value of the boolean argument."

	| argOop |
	argOop _ self stackTop.
	argOop = trueObj
		ifTrue: [self ioSetFullScreen: true]
		ifFalse: [
			argOop = falseObj
				ifTrue: [self ioSetFullScreen: false]
				ifFalse: [self primitiveFail]].
	successFlag ifTrue: [self pop: 1].
! !

!Interpreter methodsFor: 'I/O primitives'!
primitiveSetInterruptKey
	"Set the user interrupt keycode. The keycode is an integer whose encoding is described in the comment for primitiveKbdNext."

	| keycode |
	keycode _ self popInteger.
	successFlag
		ifTrue: [ interruptKeycode _ keycode ]
		ifFalse: [ self unPop: 1 ].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 2/20/2000 22:06'!
primitiveShowDisplayRect
	"Force the given rectangular section of the Display to be copied to the screen."
	| bottom top right left |
	bottom	_ self stackIntegerValue: 0.
	top		_ self stackIntegerValue: 1.
	right	_ self stackIntegerValue: 2.
	left		_ self stackIntegerValue: 3.
	self displayBitsOf: (self splObj: TheDisplay) Left: left Top: top Right: right Bottom: bottom.
	successFlag ifTrue: [
		self ioForceDisplayUpdate.
		self pop: 4].  "pop left, right, top, bottom; leave rcvr on stack"
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/1/1999 09:41'!
primitiveTestDisplayDepth
	"Return true if the host OS does support the given display depth."
	| bitsPerPixel okay|
	bitsPerPixel _ self stackIntegerValue: 0.
	successFlag ifTrue: [okay _ self ioHasDisplayDepth: bitsPerPixel].
	successFlag ifTrue: [
		self pop: 2. "Pop arg+rcvr"
		self pushBool: okay].! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 5/26/2000 21:44'!
reverseDisplayFrom: startIndex to: endIndex
	"Reverse the given range of Display words (at different bit depths, this will reverse different numbers of pixels). Used to give feedback during VM activities such as garbage collection when debugging. It is assumed that the given word range falls entirely within the first line of the Display."

	| displayObj dispBitsPtr w reversed |
	displayObj _ self splObj: TheDisplay.
	((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4])
		ifFalse: [^ nil].
	w _ self fetchInteger: 1 ofObject: displayObj.
	dispBitsPtr _ (self fetchPointer: 0 ofObject: displayObj).
	(self isIntegerObject: dispBitsPtr) ifTrue:[^nil].
	dispBitsPtr _ BaseHeaderSize + BaseHeaderSize.
	dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4 do: [:ptr |
		reversed _ (self longAt: ptr) bitXor: 16rFFFFFFFF.
		self longAt: ptr put: reversed].
	self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
	self ioForceDisplayUpdate.
! !

!Interpreter methodsFor: 'I/O primitives' stamp: 'ar 2/20/2000 22:06'!
showDisplayBits: aForm Left: l Top: t Right: r Bottom: b
	"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
	deferDisplayUpdates ifTrue: [^ nil].
	self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b! !



!Interpreter methodsFor: 'memory space primitives'!
primitiveBytesLeft
	"Reports bytes available at this moment. For more meaningful results, calls to this primitive should be preceeded by a full or incremental garbage collection."

	self pop: 1.
	self pushInteger: (self sizeOfFree: freeBlock).! !

!Interpreter methodsFor: 'memory space primitives'!
primitiveFullGC
	"Do a quick, incremental garbage collection and return the number of bytes available."

	self pop: 1.
	self incrementalGC.  "maximimize space for forwarding table"
	self fullGC.
	self pushInteger: (self sizeOfFree: freeBlock).! !

!Interpreter methodsFor: 'memory space primitives'!
primitiveIncrementalGC
	"Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection."

	self pop: 1.
	self incrementalGC.
	self pushInteger: (self sizeOfFree: freeBlock).! !

!Interpreter methodsFor: 'memory space primitives'!
primitiveLowSpaceSemaphore
	"Register the low-space semaphore. If the argument is not a Semaphore, unregister the current low-space Semaphore."

	| arg |
	arg _ self popStack.
	((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [
		self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg.
	] ifFalse: [
		self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj.
	].! !

!Interpreter methodsFor: 'memory space primitives'!
primitiveSignalAtBytesLeft
	"Set the low-water mark for free space. When the free space falls below this level, the new and new: primitives fail and system attempts to allocate space (e.g., to create a method context) cause the low-space semaphore (if one is registered) to be signalled."

	| bytes |
	bytes _ self popInteger.
	successFlag
		ifTrue: [ lowSpaceThreshold _ bytes ]
		ifFalse: [
			lowSpaceThreshold _ 0.
			self unPop: 1.
		].! !




!Interpreter methodsFor: 'sound primitives' stamp: '6/7/97 09:59 di'!
primitiveConstantFill
	"Fill the receiver, which must be an indexable bytes or words objects, with the given integer value."

	| fillValue rcvr rcvrIsBytes end i |
	fillValue _ self positive32BitValueOf: self stackTop. 
	rcvr _ self stackValue: 1.
	self success: (self isWordsOrBytes: rcvr).
	rcvrIsBytes _ self isBytes: rcvr.
	rcvrIsBytes ifTrue: [
		self success: ((fillValue >= 0) and: [fillValue <= 255]).
	].
	successFlag ifTrue: [
		end _ rcvr + (self sizeBitsOf: rcvr).
		i _ rcvr + BaseHeaderSize.
		rcvrIsBytes ifTrue: [
			[i < end] whileTrue: [
				self byteAt: i put: fillValue.
				i _ i + 1.
			].
		] ifFalse: [
			[i < end] whileTrue: [
				self longAt: i put: fillValue.
				i _ i + 4.
			].
		].
		self pop: 1.  "pop fillValue; leave rcvr on stack"
	].
! !

!Interpreter methodsFor: 'sound primitives' stamp: 'di 4/3/1999 21:33'!
primitiveShortAt
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	index _ self stackIntegerValue: 0.
	rcvr _ self stackValue: 1.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	successFlag ifTrue: [
		addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).
		value _ self cCode: '*((short int *) addr)' inSmalltalk: [self halfWordAt: addr].
		self pop: 2.  "pop rcvr, index"
		self pushInteger: value.  "push element value"
	].! !

!Interpreter methodsFor: 'sound primitives'!
primitiveShortAtPut
	"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."

	| index rcvr sz addr value |
	value _ self stackIntegerValue: 0.
	index _ self stackIntegerValue: 1.
	rcvr _ self stackValue: 2.
	self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
	successFlag ifFalse: [ ^ nil ].
	sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2.  "number of 16-bit fields"
	self success: ((index >= 1) and: [index <= sz]).
	self success: ((value >= -32768) and: [value <= 32767]).
	successFlag ifTrue: [
		addr _ rcvr + BaseHeaderSize + (2 * (index - 1)).
		self cCode: '*((short int *) addr) = value'.
		self pop: 2.  "pop index and value; leave rcvr on stack"
	].! !


!Interpreter methodsFor: 'other primitives' stamp: 'ar 11/28/1999 19:50'!
primitiveCalloutToFFI
	"Perform a function call to a foreign function.
	Only invoked from method containing explicit external call spec.
	Due to this we use the pluggable prim mechanism explicitly here
	(the first literal of any FFI spec'ed method is an ExternalFunction
	and not an array as used in the pluggable primitive mechanism)."
	| function moduleName functionName |
	self var: #function declareC:'static int function = 0'.
	self var: #moduleName declareC:'static char *moduleName = "SqueakFFIPrims"'.
	self var: #functionName declareC:'static char *functionName = "primitiveCallout"'.
	function = 0 ifTrue:[
		function _ self
			ioLoadExternalFunction: (self cCoerce: functionName to:'int')
			OfLength: 16
			FromModule: (self cCoerce: moduleName to:'int')
			OfLength: 14.
		function == 0 ifTrue:[^self primitiveFail]].
	^self cCode: '((int (*) (void)) function) ()'.
! !

!Interpreter methodsFor: 'other primitives'!
primitiveClipboardText
	"When called with a single string argument, post the string to the clipboard. When called with zero arguments, return a string containing the current clipboard contents."

	| s sz |
	argumentCount = 1 ifTrue: [
		s _ self stackTop.
		self assertClassOf: s is: (self splObj: ClassString).
		successFlag ifTrue: [
			sz _ self stSizeOf: s.
			self clipboardWrite: sz From: (s + BaseHeaderSize) At: 0.
			self pop: 1.  "pop s, leave rcvr on stack"
		].
	] ifFalse: [
		sz _ self clipboardSize.
		s _ self instantiateClass: (self splObj: ClassString)
					  indexableSize: sz.
		self clipboardRead: sz Into: (s + BaseHeaderSize) At: 0.
		self pop: 1.  "rcvr"
		self push: s.
	].
! !

!Interpreter methodsFor: 'other primitives'!
primitiveExitToDebugger

	self error: 'Exit to debugger at user request'.! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 2/2/2001 16:34'!
primitiveExternalCall
	"Call an external primitive. The external primitive methods contain as first literal an array consisting of:
		* The module name (String | Symbol)
		* The function name (String | Symbol)
		* The session ID (SmallInteger) [OBSOLETE]
		* The function index (Integer) in the externalPrimitiveTable
	For fast failures the primitive index of any method where the external prim is not found is rewritten in the method cache with zero. This allows for ultra fast responses as long as the method stays in the cache.
	The fast failure response relies on lkupClass being properly set. This is done in #addToMethodCacheSel:class:method:primIndex: to compensate for execution of methods that are looked up in a superclass (such as in primitivePerformAt).
	With the latest modifications (e.g., actually flushing the function addresses from the VM), the session ID is obsolete. But for backward compatibility it is still kept around. Also, a failed lookup is reported specially. If a method has been looked up and not been found, the function address is stored as -1 (e.g., the SmallInteger -1 to distinguish from 16rFFFFFFFF which may be returned from the lookup).
	It is absolutely okay to remove the rewrite if we run into any problems later on. It has an approximate speed difference of 30% per failed primitive call which may be noticable but if, for any reasons, we run into problems (like with J3) we can always remove the rewrite.
	"
	| lit addr moduleName functionName moduleLength functionLength index |
	"Fetch the first literal of the method"
	self success: (self literalCountOf: newMethod) > 0."@@: Could this be omitted for speed?!!"
	successFlag ifFalse:[^nil].
	lit _ self literal: 0 ofMethod: newMethod.

	"Check if it's an array of length 4"
	self success: ((self fetchClassOf: lit) = (self splObj: ClassArray) 
					and:[(self lengthOf: lit) = 4]).
	successFlag ifFalse:[^nil].

	"Look at the function index in case it has been loaded before"
	index _ self fetchPointer: 3 ofObject: lit.
	(self isIntegerObject: index) ifFalse:[^self success: false].
	index _ self integerValueOf: index.

	"Check if we have already looked up the function and failed."
	index < 0 ifTrue:[
		"Function address was not found in this session,
		Rewrite the mcache entry with a zero primitive index."
		self
			rewriteMethodCacheSel: messageSelector
			class: lkupClass
			primIndex: 0.		
		^self success: false].

	"Try to call the function directly"
	(index > 0 and:[index <= MaxExternalPrimitiveTableSize]) ifTrue:[
		addr _ externalPrimitiveTable at: index-1.
		addr ~= 0 ifTrue:[^self cCode:' ((int (*) (void)) addr) ()' 
							inSmalltalk:[self callExternalPrimitive: addr]].
		"if we come here, then an index to the external prim was kept
		on the ST side although the underlying prim table was already flushed"
		^self success: false].

	"Clean up session id and external primitive index"
	self storeInteger: 2 ofObject: lit withValue: 0.
	self storeInteger: 3 ofObject: lit withValue: 0.

	"The function has not been loaded yet. 
	Fetch module and function name."
	moduleName _ self fetchPointer: 0 ofObject: lit.
	moduleName = nilObj ifTrue:[
		moduleLength _ 0.
	] ifFalse:[
		self success: (self isBytes: moduleName).
		moduleLength _ self lengthOf: moduleName.
	].

	functionName _ self fetchPointer: 1 ofObject: lit.
	self success: (self isBytes: functionName).
	functionLength _ self lengthOf: functionName.
	successFlag ifFalse:[^nil].
	"Backward compatibility:
		Attempt to map any old-style named primitives into the new ones.
		The old ones are exclusively bound into the VM so we don't need
		to check if a module is given."
	addr _ 0. "Addr ~= 0 indicates we have a compat match later"
	moduleLength = 0 ifTrue:[
		"Search the obsolete named primitive table for a match"
		index _ self findObsoleteNamedPrimitive: (self cCoerce: (functionName+4) to: 'char *') length: functionLength.
		"The returned value is the index into the obsolete primitive table.
		If the index is found, use the 'C-style' version of the lookup."
		index < 0 ifFalse:[
			addr _ self ioLoadFunction: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 2) to: 'char*')
						From: (self cCoerce: ((obsoleteNamedPrimitiveTable at: index) at: 1) to:'char*')]].
	addr = 0 ifTrue:["Only if no compat version was found"
		addr _ self ioLoadExternalFunction: functionName + 4
					OfLength: functionLength 
					FromModule: moduleName + 4
					OfLength: moduleLength.
	].
	addr = 0 ifTrue:[
		index _ -1. "remember we failed"
	] ifFalse:[
		"add the function to the external primitive table"
		index _ self addToExternalPrimitiveTable: addr.
		"if no space, index will be zero so we will look it up again.
		although slow it makes sure we will find the prim in case
		it's needed."
	].
	self success: index >= 0.
	"Store the index (or -1 if failure) back in the literal"
	self storePointer: 3 ofObject: lit withValue: (self integerObjectOf: index).

	"If the function has been successfully loaded process it"
	(successFlag and:[addr ~= 0])
		ifTrue:[^self cCode:' ((int (*) (void)) addr) ()'
					inSmalltalk:[self callExternalPrimitive: addr]]
		ifFalse:["Otherwise rewrite the primitive index"
			self
				rewriteMethodCacheSel: messageSelector
				class: lkupClass
				primIndex: 0].! !

!Interpreter methodsFor: 'other primitives'!
primitiveFlushCache
	"Clear the method lookup cache. This must be done after every programming change."

	self flushMethodCache.! !

!Interpreter methodsFor: 'other primitives' stamp: 'ikp 1/4/1999 11:31'!
primitiveFlushCacheByMethod
	"The receiver is a compiledMethod.  Clear all entries in the method lookup cache that refer to this method, presumably because it has been redefined, overridden or removed."
	| probe oldMethod |
	oldMethod _ self stackTop.
	probe _ 0.
	1 to: MethodCacheEntries do:
		[:i | (methodCache at: probe + MethodCacheMethod) = oldMethod ifTrue:
			[methodCache at: probe + MethodCacheSelector put: 0].
		probe _ probe + MethodCacheEntrySize].
	self compilerFlushCacheHook: oldMethod.		"Flush the dynamic compiler's inline caches."! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 12/14/1998 14:32'!
primitiveFlushCacheSelective
	"The receiver is a message selector.  Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined."
	| selector probe |
	selector _ self stackTop.
	probe _ 0.
	1 to: MethodCacheEntries do:
		[:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue:
			[methodCache at: probe + MethodCacheSelector put: 0].
		probe _ probe + MethodCacheEntrySize]! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 3/26/2000 16:03'!
primitiveFlushExternalPrimitives
	"Primitive. Flush all the existing external primitives in the image thus forcing a reload on next invokation."
	^self flushExternalPrimitives! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 10/30/97 07:47'!
primitiveFormPrint
	"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."

	| landscapeFlag vScale hScale rcvr bitsArray w h
	 depth pixelsPerWord wordsPerLine bitsArraySize ok |
	self var: #vScale declareC: 'double vScale'.
	self var: #hScale declareC: 'double hScale'.
	landscapeFlag _ self booleanValueOf: self stackTop.
	vScale _ self floatValueOf: (self stackValue: 1).
	hScale _ self floatValueOf: (self stackValue: 2).
	rcvr _ self stackValue: 3.
	(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
	successFlag ifTrue: [
		((self  isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
			ifFalse: [self success: false]].
	successFlag ifTrue: [
		bitsArray _ self fetchPointer: 0 ofObject: rcvr.
		w _ self fetchInteger: 1 ofObject: rcvr.
		h _ self fetchInteger: 2 ofObject: rcvr.
		depth _ self fetchInteger: 3 ofObject: rcvr.
		(w > 0 and: [h > 0]) ifFalse: [self success: false].
		pixelsPerWord _ 32 // depth.
		wordsPerLine _ (w + (pixelsPerWord - 1)) // pixelsPerWord.
		((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
			ifTrue: [
				bitsArraySize _ self byteLengthOf: bitsArray.
				self success: (bitsArraySize = (wordsPerLine * h * 4))]
			ifFalse: [self success: false]].	
	successFlag ifTrue: [
		ok _ self cCode:
			'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'.
		self success: ok].
	successFlag ifTrue: [
		self pop: 3].  "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 5/8/1998 12:18'!
primitiveGetAttribute
	"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."

	| attr sz s |
	attr _ self stackIntegerValue: 0.
	successFlag ifTrue: [sz _ self attributeSize: attr].
	successFlag ifTrue: [
		s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.
		self getAttribute: attr Into: (s + BaseHeaderSize) Length: sz.
		self pop: 2.  "rcvr, attr"
		self push: s].
! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 4/22/1999 08:53'!
primitiveGetTabletParameters
	"Get information on the pen tablet attached to this machine. Fail if there is no tablet. If successful, the result is an array of integers; see the Smalltalk call on this primitive for its interpretation."

	| cursorIndex resultSize result |
	cursorIndex _ self stackIntegerValue: 0.
	successFlag ifTrue: [
		resultSize _ self tabletResultSize.
		result _ self instantiateClass: (self splObj: ClassBitmap) indexableSize: resultSize.
		self success: (self cCode: 'tabletGetParameters(cursorIndex, (int *) (result + 4))')].
	successFlag ifTrue: [
		self pop: 2.  "receiver, cursorIndex"
		self push: result].
! !

!Interpreter methodsFor: 'other primitives'!
primitiveImageName
	"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."

	| s sz |
	argumentCount = 1 ifTrue: [
		s _ self stackTop.
		self assertClassOf: s is: (self splObj: ClassString).
		successFlag ifTrue: [
			sz _ self stSizeOf: s.
			self imageNamePut: (s + BaseHeaderSize) Length: sz.
			self pop: 1.  "pop s, leave rcvr on stack"
		].
	] ifFalse: [
		sz _ self imageNameSize.
		s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.
		self imageNameGet: (s + BaseHeaderSize) Length: sz.
		self pop: 1.  "rcvr"
		self push: s.
	].
! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 5/16/2000 00:11'!
primitiveListBuiltinModule
	"Primitive. Return the n-th builtin module name."
	| moduleName index length nameOop |
	self var: #moduleName type: 'char *'.
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	index _ self stackIntegerValue: 0.
	index <= 0 ifTrue:[^self primitiveFail].
	moduleName _ self ioListBuiltinModule: index.
	moduleName == nil ifTrue:[
		self pop: 2. "arg+rcvr"
		^self push: self nilObject].
	length _ self strlen: moduleName.
	nameOop _ self instantiateClass: self classString indexableSize: length.
	0 to: length-1 do:[:i|
		self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
	self pop: 2. "arg+rcvr"
	self push: nameOop.! !

!Interpreter methodsFor: 'other primitives' stamp: 'TPR 5/16/2000 16:48'!
primitiveListExternalModule
	"Primitive. Return the n-th loaded external module name."
	| moduleName index length nameOop |
	self var: #moduleName type: 'char *'.
	self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
	index _ self stackIntegerValue: 0.
	index <= 0 ifTrue:[^self primitiveFail].
	moduleName _ self ioListLoadedModule: index.
	moduleName == nil ifTrue:[
		self pop: 2. "arg+rcvr"
		^self push: self nilObject].
	length _ self strlen: moduleName.
	nameOop _ self instantiateClass: self classString indexableSize: length.
	0 to: length-1 do:[:i|
		self storeByte: i ofObject: nameOop withValue: (moduleName at: i)].
	self pop: 2. "arg+rcvr"
	self push: nameOop.! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 7/30/2000 17:38'!
primitiveMillisecondClock
	"Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger."

	self pop: 1.  "pop rcvr"
	self push: (self integerObjectOf: (self ioMSecs bitAnd: MillisecondClockMask)).
! !

!Interpreter methodsFor: 'other primitives'!
primitiveNoop
	"A placeholder for primitives that haven't been implemented or are being withdrawn gradually. Just absorbs any arguments and returns the receiver."

	self pop: argumentCount.  "pop args, leave rcvr on stack"! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 5/17/2000 22:48'!
primitiveObsoleteIndexedPrimitive
	"Primitive. Invoke an obsolete indexed primitive."
	| pluginName functionName functionAddress |
	self var: #pluginName declareC:'char *pluginName'.
	self var: #functionName declareC:'char *functionName'.
	functionAddress _ 
		self cCoerce: ((obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 2) to: 'int'.
	functionAddress = nil 
		ifFalse:[^self cCode: '((int (*) (void))functionAddress)()'
					inSmalltalk:[self callExternalPrimitive: functionAddress]].
	pluginName _ (obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 0.
	functionName _ (obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 1.
	(pluginName = nil and:[functionName = nil]) 
		ifTrue:[^self primitiveFail].
	functionAddress _ self ioLoadFunction: functionName From: pluginName.
	functionAddress = nil ifFalse:["Cache for future use"
		(obsoleteIndexedPrimitiveTable at: primitiveIndex) at: 2 put: 
			(self cCoerce: functionAddress to: 'char*').
		^self cCode: '((int (*) (void))functionAddress)()'
				inSmalltalk:[self callExternalPrimitive: functionAddress]].
	^self primitiveFail! !

!Interpreter methodsFor: 'other primitives'!
primitiveQuit

	self ioExit.
! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 9/3/97 11:57'!
primitiveRelinquishProcessor
	"Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent."

	| microSecs |
	microSecs _ self stackIntegerValue: 0.
	successFlag ifTrue: [
		self ioRelinquishProcessorForMicroseconds: microSecs.
		self pop: 1].  "microSecs; leave rcvr on stack"
! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 5/23/2000 12:59'!
primitiveScanCharacters
	"Invoke the character scanner primitive."
	| kernDelta stops sourceString scanStopIndex scanStartIndex rcvr scanDestX scanLastIndex scanXTable scanMap maxGlyph ascii stopReason glyphIndex sourceX sourceX2 nextDestX scanRightX nilOop |
	self methodArgumentCount = 6 ifFalse:[^self primitiveFail].
	"Load the arguments"
	kernDelta _ self stackIntegerValue: 0.
	stops _ self stackObjectValue: 1.
	(self fetchClassOf: stops) = self classArray ifFalse:[^self primitiveFail].
	(self slotSizeOf: stops) >= 258 ifFalse:[^self primitiveFail].
	scanRightX _ self stackIntegerValue: 2.
	sourceString _ self stackObjectValue: 3.
	(self isBytes: sourceString) ifFalse:[^self primitiveFail].
	scanStopIndex _ self stackIntegerValue: 4.
	scanStartIndex _ self stackIntegerValue: 5.
	(scanStartIndex > 0 and:[scanStopIndex > 0 and:[
		scanStopIndex <= (self byteSizeOf: sourceString)]])
			ifFalse:[^self primitiveFail].
	"Load receiver and required instVars"
	rcvr _ self stackObjectValue: 6.
	((self isPointers: rcvr) and:[(self slotSizeOf: rcvr) >= 4])
		ifFalse:[^self primitiveFail].
	scanDestX _ self fetchInteger: 0 ofObject: rcvr.
	scanLastIndex _ self fetchInteger: 1 ofObject: rcvr.
	scanXTable _ self fetchPointer: 2 ofObject: rcvr.
	scanMap _ self fetchPointer: 3 ofObject: rcvr.
	((self fetchClassOf: scanXTable) = self classArray and:[
		(self fetchClassOf: scanMap) = self classArray])
			ifFalse:[^self primitiveFail].
	(self slotSizeOf: scanMap) = 256 ifFalse:[^self primitiveFail].
	self failed ifTrue:[^nil].
	maxGlyph _ (self slotSizeOf: scanXTable) - 2.

	"Okay, here we go. We have eliminated nearly all failure conditions,
	to optimize the inner fetches."
	scanLastIndex _ scanStartIndex.
	nilOop _ self nilObject.
	[scanLastIndex <= scanStopIndex] whileTrue:[
		"Known to be okay since scanStartIndex > 0 and scanStopIndex <= sourceString size"
		ascii _ self fetchByte: scanLastIndex-1 ofObject: sourceString.
		"Known to be okay since stops size >= 258"
		(stopReason _ self fetchPointer: ascii ofObject: stops) = nilOop ifFalse:[
			"Store everything back and get out of here"
			(self isIntegerValue: scanDestX) ifFalse:[^self primitiveFail].
			self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
			self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
			self pop: 7. "args+rcvr"
			^self push: stopReason].
		"Known to be okay since scanMap size = 256"
		glyphIndex _ self fetchInteger: ascii ofObject: scanMap.
		(self failed or:[glyphIndex < 0 or:[glyphIndex > maxGlyph]])
			ifTrue:[^self primitiveFail].
		sourceX _ self fetchInteger: glyphIndex ofObject: scanXTable.
		sourceX2 _ self fetchInteger: glyphIndex+1 ofObject: scanXTable.
		"Above may fail if non-integer entries in scanXTable"
		self failed ifTrue:[^nil].
		nextDestX _ scanDestX + sourceX2 - sourceX.
		nextDestX > scanRightX ifTrue:[
			"Store everything back and get out of here"
			(self isIntegerValue: scanDestX) ifFalse:[^self primitiveFail].
			self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
			self storeInteger: 1 ofObject: rcvr withValue: scanLastIndex.
			self pop: 7. "args+rcvr"
			^self push: (self fetchPointer: CrossedX-1 ofObject: stops)].
		scanDestX _ nextDestX + kernDelta.
		scanLastIndex _ scanLastIndex + 1].
	(self isIntegerValue: scanDestX) ifFalse:[^self primitiveFail].
	self storeInteger: 0 ofObject: rcvr withValue: scanDestX.
	self storeInteger: 1 ofObject: rcvr withValue: scanStopIndex.
	self pop: 7. "args+rcvr"
	^self push: (self fetchPointer: EndOfRun-1 ofObject: stops).! !

!Interpreter methodsFor: 'other primitives'!
primitiveSecondsClock
	"Return the number of seconds since January 1, 1901 as an integer."

	self pop: 1.  "pop rcvr"
	self push: (self positive32BitIntegerFor: self ioSeconds).! !

!Interpreter methodsFor: 'other primitives'!
primitiveSignalAtMilliseconds
	"Cause the time semaphore, if one has been registered, to be signalled when the millisecond clock is greater than or equal to the given tick value. A tick value of zero turns off timer interrupts."

	| tick sema |
	tick _ self popInteger.
	sema _ self popStack.
	successFlag ifTrue: [
		(self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [
			self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: sema.
			nextWakeupTick _ tick.
		] ifFalse: [
			self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: nilObj.
			nextWakeupTick _ 0.
		].
	] ifFalse: [
		self unPop: 2.  "sema, tick"
	].! !

!Interpreter methodsFor: 'other primitives' stamp: 'ikp 12/8/1999 11:04'!
primitiveSnapshot

	| activeProc dataSize rcvr |

	"update state of active context"
	compilerInitialized
		ifTrue: [self compilerPreSnapshot]
		ifFalse: [self storeContextRegisters: activeContext].

	"update state of active process"
	activeProc _ self
		fetchPointer: ActiveProcessIndex
		ofObject: self schedulerPointer.
	self	storePointer: SuspendedContextIndex
		ofObject: activeProc
		withValue: activeContext.

	"compact memory and compute the size of the memory actually in use"
	self cleanUpContexts.
	self incrementalGC.  "maximimize space for forwarding table"
	self fullGC.

	dataSize _ freeBlock - (self startOfMemory).
	"Assume: all objects are below the start of the free block"

	successFlag ifTrue: [
		rcvr _ self popStack.  "pop rcvr"
		self push: trueObj.
		self writeImageFile: dataSize.
		self pop: 1.  "pop true"
	].
	successFlag
		ifTrue: [ self push: falseObj ]
		ifFalse: [ self push: rcvr ].

	compilerInitialized
		ifTrue: [self compilerPostSnapshot].! !

!Interpreter methodsFor: 'other primitives' stamp: 'JMM 11/21/2000 20:27'!
primitiveSnapshotEmbedded

	| activeProc dataSize rcvr |
	self compilerPreSnapshotHook.
	"save the state of the current process and save it on the scheduler queue"
	self storeContextRegisters: activeContext.
	activeProc _
		self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
	self storePointer: SuspendedContextIndex
		    ofObject: activeProc
		  withValue: activeContext.

	"compact memory and compute the size of the memory actually in use"
	self cleanUpContexts.
	self incrementalGC.  "maximimize space for forwarding table"
	self fullGC.

	dataSize _ freeBlock - (self startOfMemory).
	"Assume: all objects are below the start of the free block"

	successFlag ifTrue: [
		rcvr _ self popStack.  "pop rcvr"
		self push: trueObj.
		self writeImageFileEmbedded: dataSize.
		self pop: 1.  "pop true"
	].
	successFlag
		ifTrue: [ self push: falseObj ]
		ifFalse: [ self push: rcvr ].
	self compilerPostSnapshotHook.! !

!Interpreter methodsFor: 'other primitives'!
primitiveSpecialObjectsOop
	"Return the oop of the SpecialObjectsArray."

	self pop: 1.
	self push: specialObjectsOop.! !

!Interpreter methodsFor: 'other primitives' stamp: 'ar 5/26/2000 21:52'!
primitiveUnloadModule
	"Primitive. Unload the module with the given name."
	"Reloading of the module will happen *later* automatically, when a 
	function from it is called. This is ensured by invalidating current sessionID."
	| moduleName |
	self methodArgumentCount = 1 ifFalse:[^self success: false].
	moduleName _ self stackValue: 0.
	(self isIntegerObject: moduleName) ifTrue:[^self success: false].
	(self isBytes: moduleName) ifFalse:[^self success: false].
	(self ioUnloadModule: (self cCoerce: (self firstIndexableField: moduleName) to: 'int')
		OfLength: (self byteSizeOf: moduleName)) ifFalse:[^self success: false].
	self flushExternalPrimitives.
	self pop: 1 "pop moduleName; return receiver"! !

!Interpreter methodsFor: 'other primitives' stamp: 'jm 7/10/1999 07:35'!
primitiveVMParameter
	"Behaviour depends on argument count:
		0 args:	return an Array of VM parameter values;
		1 arg:	return the indicated VM parameter;
		2 args:	set the VM indicated parameter.
	VM parameters are numbered as follows:
		1	end of old-space (0-based, read-only)
		2	end of young-space (read-only)
		3	end of memory (read-only)
		4	allocationCount (read-only)
		5	allocations between GCs (read-write)
		6	survivor count tenuring threshold (read-write)
		7	full GCs since startup (read-only)
		8	total milliseconds in full GCs since startup (read-only)
		9	incremental GCs since startup (read-only)
		10	total milliseconds in incremental GCs since startup (read-only)
		11	tenures of surving objects since startup (read-only)
		12-20 specific to the translating VM
		21	root table size (read-only)
		22	root table overflows since startup (read-only)
		23	bytes of extra memory to reserve for VM buffers, plugins, etc.
	Note: Thanks to Ian Piumarta for this primitive."

	| mem paramsArraySize result arg index |
	mem _ self cCoerce: memory to: 'int'.
	argumentCount = 0 ifTrue: [
		paramsArraySize _ 23.
		result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.
		0 to: paramsArraySize - 1 do:
			[:i | self storeWord: i ofObject: result withValue: (self integerObjectOf: 0)].
		self storeWord: 0	ofObject: result withValue: (self integerObjectOf: youngStart - mem).
		self storeWord: 1		ofObject: result withValue: (self integerObjectOf: freeBlock - mem).
		self storeWord: 2	ofObject: result withValue: (self integerObjectOf: endOfMemory - mem).
		self storeWord: 3	ofObject: result withValue: (self integerObjectOf: allocationCount).
		self storeWord: 4	ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs).
		self storeWord: 5	ofObject: result withValue: (self integerObjectOf: tenuringThreshold).
		self storeWord: 6	ofObject: result withValue: (self integerObjectOf: statFullGCs).
		self storeWord: 7	ofObject: result withValue: (self integerObjectOf: statFullGCMSecs).
		self storeWord: 8	ofObject: result withValue: (self integerObjectOf: statIncrGCs).
		self storeWord: 9	ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs).
		self storeWord: 10	ofObject: result withValue: (self integerObjectOf: statTenures).
		self storeWord: 20	ofObject: result withValue: (self integerObjectOf: rootTableCount).
		self storeWord: 21	ofObject: result withValue: (self integerObjectOf: statRootTableOverflows).
		self storeWord: 22	ofObject: result withValue: (self integerObjectOf: extraVMMemory).
		self pop: 1 thenPush: result.
		^nil].

	arg _ self stackTop.
	(self isIntegerObject: arg) ifFalse: [^self primitiveFail].
	arg _ self integerValueOf: arg.
	argumentCount = 1 ifTrue: [	 "read VM parameter"
		(arg < 1 or: [arg > 23]) ifTrue: [^self primitiveFail].
		arg = 1		ifTrue: [result _ youngStart - mem].
		arg = 2		ifTrue: [result _ freeBlock - mem].
		arg = 3		ifTrue: [result _ endOfMemory - mem].
		arg = 4		ifTrue: [result _ allocationCount].
		arg = 5		ifTrue: [result _ allocationsBetweenGCs].
		arg = 6		ifTrue: [result _ tenuringThreshold].
		arg = 7		ifTrue: [result _ statFullGCs].
		arg = 8		ifTrue: [result _ statFullGCMSecs].
		arg = 9		ifTrue: [result _ statIncrGCs].
		arg = 10		ifTrue: [result _ statIncrGCMSecs].
		arg = 11		ifTrue: [result _ statTenures].
		((arg >= 12) and: [arg <= 20]) ifTrue: [result _ 0].
		arg = 21		ifTrue: [result _ rootTableCount].
		arg = 22		ifTrue: [result _ statRootTableOverflows].
		arg = 23		ifTrue: [result _ extraVMMemory].
		self pop: 2 thenPush: (self integerObjectOf: result).
		^nil].

	"write a VM parameter"
	argumentCount = 2 ifFalse: [^self primitiveFail].
	index _ self stackValue: 1.
	(self isIntegerObject: index) ifFalse: [^self primitiveFail].
	index _ self integerValueOf: index.
	index <= 0 ifTrue: [^self primitiveFail].
	successFlag _ false.
	index = 5 ifTrue: [
		result _ allocationsBetweenGCs.
		allocationsBetweenGCs _ arg.
		successFlag _ true].
	index = 6 ifTrue: [
		result _ tenuringThreshold.
		tenuringThreshold _ arg.
		successFlag _ true].
	index = 23 ifTrue: [
		result _ extraVMMemory.
		extraVMMemory _ arg.
		successFlag _ true].
	successFlag ifTrue: [
		self pop: 3 thenPush: (self integerObjectOf: result).  "return old value"
		^ nil].

	self primitiveFail.  "attempting to write a read-only parameter"
! !

!Interpreter methodsFor: 'other primitives'!
primitiveVMPath
	"Return a string containing the path name of VM's directory."

	| s sz |
	sz _ self vmPathSize.
	s _ self instantiateClass: (self splObj: ClassString) indexableSize: sz.
	self vmPathGet: (s + BaseHeaderSize) Length: sz.
	self pop: 1.  "rcvr"
	self push: s.
! !


!Interpreter methodsFor: 'debug printing'!
cr
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self printf: '\n'.! !

!Interpreter methodsFor: 'debug printing'!
print: s
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self var: #s declareC: 'char *s'.
	self cCode: 'printf("%s", s)'.! !

!Interpreter methodsFor: 'debug printing'!
printChar: aByte
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self putchar: aByte.! !

!Interpreter methodsFor: 'debug printing'!
printNum: n
	"For testing in Smalltalk, this method should be overridden in a subclass."

	self cCode: 'printf("%ld", (long) n)'.! !


!Interpreter methodsFor: 'debug support'!
allAccessibleObjectsOkay
	"Ensure that all accessible objects in the heap are okay."

	| oop |
	oop _ self firstAccessibleObject.
	[oop = nil] whileFalse: [
		self okayFields: oop.
		oop _ self accessibleObjectAfter: oop.
	].! !

!Interpreter methodsFor: 'debug support'!
findClassOfMethod: meth forReceiver: rcvr

	| currClass classDict classDictSize methodArray i done |
	currClass _ self fetchClassOf: rcvr.
	done _ false.
	[done] whileFalse: [
		classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass.
		classDictSize _ self fetchWordLengthOf: classDict.
		methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict.
		i _ 0.
		[i < (classDictSize - SelectorStart)] whileTrue: [
			meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
			i _ i + 1.
		].
		currClass _ self fetchPointer: SuperclassIndex ofObject: currClass.
		done _ currClass = nilObj.
	].
	^self fetchClassOf: rcvr    "method not found in superclass chain"! !

!Interpreter methodsFor: 'debug support'!
findSelectorOfMethod: meth forReceiver: rcvr

	| currClass done classDict classDictSize methodArray i |
	currClass _ self fetchClassOf: rcvr.
	done _ false.
	[done] whileFalse: [
		classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass.
		classDictSize _ self fetchWordLengthOf: classDict.
		methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict.
		i _ 0.
		[i <= (classDictSize - SelectorStart)] whileTrue: [
			meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [
				^(self fetchPointer: i + SelectorStart ofObject: classDict)
			].
			i _ i + 1.
		].
		currClass _ self fetchPointer: SuperclassIndex ofObject: currClass.
		done _ currClass = nilObj.
	].
	^self splObj: SelectorDoesNotUnderstand    "method not found in superclass chain"! !

!Interpreter methodsFor: 'debug support'!
okayActiveProcessStack

	| cntxt |
	cntxt _ activeContext.	
	[cntxt = nilObj] whileFalse: [
		self okayFields: cntxt.
		cntxt _ (self fetchPointer: SenderIndex ofObject: cntxt).
	].! !

!Interpreter methodsFor: 'debug support'!
okayFields: oop
	"If this is a pointers object, check that its fields are all okay oops."

	| i fieldOop |
	(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
	(self isIntegerObject: oop) ifTrue: [ ^true ].
	self okayOop: oop.
	self oopHasOkayClass: oop.
	(self isPointers: oop) ifFalse: [ ^true ].
	i _ (self lengthOf: oop) - 1.
	[i >= 0] whileTrue: [
		fieldOop _ self fetchPointer: i ofObject: oop.
		(self isIntegerObject: fieldOop) ifFalse: [
			self okayOop: fieldOop.
			self oopHasOkayClass: fieldOop.
		].
		i _ i - 1.
	].! !

!Interpreter methodsFor: 'debug support'!
okayInterpreterObjects

	| oopOrZero oop |
	self okayFields: nilObj.
	self okayFields: falseObj.
	self okayFields: trueObj.
	self okayFields: specialObjectsOop.
	self okayFields: activeContext.
	self okayFields: method.
	self okayFields: receiver.
	self okayFields: theHomeContext.
	self okayFields: messageSelector.
	self okayFields: newMethod.
	self okayFields: lkupClass.
	0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
		oopOrZero _ methodCache at: i + MethodCacheSelector.
		oopOrZero = 0 ifFalse: [
			self okayFields: (methodCache at: i + MethodCacheSelector).
			self okayFields: (methodCache at: i + MethodCacheClass).
			self okayFields: (methodCache at: i + MethodCacheMethod).
		].
	].
	1 to: remapBufferCount do: [ :i |
		oop _ remapBuffer at: i.
		(self isIntegerObject: oop) ifFalse: [
			self okayFields: oop.
		].
	].
	self okayActiveProcessStack.! !

!Interpreter methodsFor: 'debug support' stamp: 'ar 3/21/98 02:37'!
okayOop: oop
	"Verify that the given oop is legitimate. Check address, header, and size but not class."

	| sz type fmt |
	"address and size checks"
	(self isIntegerObject: oop) ifTrue: [ ^true ].
	((0 < oop) & (oop < endOfMemory))
		ifFalse: [ self error: 'oop is not a valid address' ].
	((oop \\ 4) = 0)
		ifFalse: [ self error: 'oop is not a word-aligned address' ].
	sz _ self sizeBitsOf: oop.
	(oop + sz) < endOfMemory
		ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ].

	"header type checks"
	type _ self headerType: oop.
	type = HeaderTypeFree
		ifTrue:  [ self error: 'oop is a free chunk, not an object' ].
	type = HeaderTypeShort ifTrue: [
		(((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0
			ifTrue:  [ self error: 'cannot have zero compact class field in a short header' ].
	].
	type = HeaderTypeClass ifTrue: [
		((oop >= 4) and: [(self headerType: oop - 4) = type])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].
	type = HeaderTypeSizeAndClass ifTrue: [
		((oop >= 8) and:
		 [(self headerType: oop - 8) = type and:
		 [(self headerType: oop - 4) = type]])
			ifFalse: [ self error: 'class header word has wrong type' ].
	].

	"format check"
	fmt _ self formatOf: oop.
	((fmt = 5) | (fmt = 7))
		ifTrue:  [ self error: 'oop has an unknown format type' ].

	"mark and root bit checks"
	((self longAt: oop) bitAnd: 16r20000000) = 0
		ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ].
"xxx
	((self longAt: oop) bitAnd: MarkBit) = 0
		ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
	(((self longAt: oop) bitAnd: RootBit) = 1 and:
	 [oop >= youngStart])
		ifTrue: [ self error: 'root bit is set in a young object' ].
	^true! !

!Interpreter methodsFor: 'debug support'!
oopHasOkayClass: oop
	"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."

	| oopClass formatMask behaviorFormatBits oopFormatBits |
	self okayOop: oop.
	oopClass _ self fetchClassOf: oop.

	(self isIntegerObject: oopClass)
		ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
	self okayOop: oopClass.
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
		ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
	(self isBytes: oop)
		ifTrue: [ formatMask _ 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask _ 16rF00 ].

	behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits
		ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
	^true! !

!Interpreter methodsFor: 'debug support' stamp: 'ikp 10/24/1999 03:57'!
printCallStack

	| ctxt home methClass methodSel |
	ctxt _ activeContext.
	[ctxt = nilObj] whileFalse: [
		(self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
			ifTrue: [ home _ self fetchPointer: HomeIndex ofObject: ctxt ]
			ifFalse: [ home _ ctxt ].
		methClass _
			self findClassOfMethod: (self fetchPointer: MethodIndex ofObject: home)
					   forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
		methodSel _
			self findSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
						 forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
		self printNum: ctxt.
		self print: ' '.
		ctxt = home ifFalse: [ self print: '[] in ' ].
		self printNameOfClass: methClass count: 5.
		self print: '>'.
		self printStringOf: methodSel.
		self cr.

		ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt).
	].! !

!Interpreter methodsFor: 'debug support' stamp: 'di 10/4/1999 08:12'!
printNameOfClass: classOop count: cnt
	"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."

	cnt <= 0 ifTrue: [ ^ self print: 'bad class' ].
	(self sizeBitsOf: classOop) = 16r1C  "(Metaclass instSize+1 * 4)"
	ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) 
				count: cnt - 1.
			self print: ' class']
	ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]! !

!Interpreter methodsFor: 'debug support'!
printStringOf: oop

	| fmt cnt i |
	fmt _ self formatOf: oop.
	fmt < 8 ifTrue: [ ^nil ].

	cnt _ 100 min: (self lengthOf: oop).
	i _ 0.
	[i < cnt] whileTrue: [
		self printChar: (self fetchByte: i ofObject: oop).
		i _ i + 1.
	].! !

!Interpreter methodsFor: 'debug support' stamp: 'di 10/6/1999 16:43'!
verifyCleanHeaders
	| oop |
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop)
			ifTrue: ["There should only be one free block at end of memory."
					(self objectAfter: oop) = endOfMemory
						ifFalse: [self error: 'Invalid obj with HeaderTypeBits = Free.']]
			ifFalse: [((self longAt: oop) bitAnd: MarkBit) = 0
						ifFalse: [self error: 'Invalid obj with MarkBit set.']].
		oop _ self objectAfter: oop]! !


!Interpreter methodsFor: 'image save/restore' stamp: 'di 10/18/1999 16:58'!
byteSwapByteObjects
	"Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."

	self byteSwapByteObjectsFrom: self firstObject to: endOfMemory! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 11/30/1999 07:42'!
byteSwapByteObjectsFrom: startOop to: stopAddr
	"Byte-swap the words of all bytes objects in a range of the image, including Strings, ByteArrays, and CompiledMethods. This returns these objects to their original byte ordering after blindly byte-swapping the entire image. For compiled methods, byte-swap only their bytecodes part."

	| oop fmt wordAddr methodHeader |
	oop _ startOop.
	[oop < stopAddr] whileTrue: [
		(self isFreeObject: oop) ifFalse: [
			fmt _ self formatOf: oop.
			fmt >= 8 ifTrue: [  "oop contains bytes"
				wordAddr _ oop + BaseHeaderSize.
				fmt >= 12 ifTrue: [
					"compiled method; start after methodHeader and literals"
					methodHeader _ self longAt: oop + BaseHeaderSize.
					wordAddr _ wordAddr + 4 + (((methodHeader >> 10) bitAnd: 16rFF) * 4).
				].
				self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop).
			].
 		].
		oop _ self objectAfter: oop.
	].
! !

!Interpreter methodsFor: 'image save/restore'!
byteSwapped: w
	"Return the given integer with its bytes in the reverse order."

	^ ((w bitShift: -24) bitAnd: 16rFF) +
	  ((w bitShift: -8) bitAnd: 16rFF00) +
	  ((w bitShift: 8) bitAnd: 16rFF0000) +
	  ((w bitShift: 24) bitAnd: 16rFF000000)
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'ar 7/16/1999 22:48'!
checkImageVersionFrom: f startingAt: imageOffset
	"Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number."
	"This code is based on C code by Ian Piumarta."

	| version firstVersion |
	self var: #f declareC: 'sqImageFile f'.

	"check the version number"
	self sqImageFile: f Seek: imageOffset.
	version _ firstVersion _ self getLongFromFile: f swap: false.
	(self readableFormat: version) ifTrue: [^ false].

	"try with bytes reversed"
	self sqImageFile: f Seek: imageOffset.
	version _ self getLongFromFile: f swap: true.
	(self readableFormat: version) ifTrue: [^ true].

	"Note: The following is only meaningful if not reading an embedded image"
	imageOffset = 0 ifTrue:[
		"try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)"
		self sqImageFile: f Seek: 512.
		version _ self getLongFromFile: f swap: false.
		(self readableFormat: version) ifTrue: [^ false].

		"try skipping the first 512 bytes with bytes reversed"
		self sqImageFile: f Seek: 512.
		version _ self getLongFromFile: f swap: true.
		(self readableFormat: version) ifTrue: [^ true]].

	"hard failure; abort"
	self print: 'This interpreter (vers. '.
	self printNum: self imageFormatVersion.
	self print: ' cannot read image file (vers. '.
	self printNum: firstVersion.
	self cr.
	self print: 'Hit CR to quit'.
	self getchar.
	self ioExit.
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 12/27/1998 23:16'!
cleanUpContexts
	"Sweep memory, nilling out all fields of contexts above the stack pointer."
	| oop header fmt sz |
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue: [
		(self isFreeObject: oop) ifFalse: [
			header _ self longAt: oop.
			fmt _ (header >> 8) bitAnd: 16rF.
			(fmt = 3 and: [self isContextHeader: header]) ifTrue:
				[sz _ self sizeBitsOf: oop.
				(self lastPointerOf: oop) + 4 to: sz - BaseHeaderSize by: 4
					do: [:i | self longAt: oop+i put: nilObj]]].
		oop _ self objectAfter: oop.
	].
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'jm 2/1/98 14:07'!
getLongFromFile: f swap: swapFlag
	"Return the next 4-byte word of the given file, byte-swapped according to the given flag."

	| w |
	self var: #f declareC: 'sqImageFile f'.
	self cCode: 'sqImageFileRead(&w, sizeof(char), 4, f)'.
	swapFlag
		ifTrue: [^ self byteSwapped: w]
		ifFalse: [^ w].
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 12/18/1998 12:24'!
imageFormatVersion
	"Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."

	^ 6502! !

!Interpreter methodsFor: 'image save/restore' stamp: 'jm 2/1/98 14:08'!
putLong: n toFile: f
	"Append the given 4-byte long word to the given file in this platforms 'natural' byte order. (Bytes will be swapped, if necessary, when the image is read on a different platform.) Set successFlag to false if the write fails."

	| wordsWritten |
	self var: #f declareC: 'sqImageFile f'.

	wordsWritten _ self cCode: 'sqImageFileWrite(&n, sizeof(int), 1, f)'.
	self success: wordsWritten = 1.
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'jm 5/30/2000 08:44'!
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
	"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
	"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
	"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"

	| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
	self var: #f declareC: 'sqImageFile f'.

	swapBytes _ self checkImageVersionFrom: f startingAt: imageOffset.
	headerStart _ (self sqImageFilePosition: f) - 4.  "record header start position"

	headerSize			_ self getLongFromFile: f swap: swapBytes.
	dataSize				_ self getLongFromFile: f swap: swapBytes.
	oldBaseAddr			_ self getLongFromFile: f swap: swapBytes.
	specialObjectsOop	_ self getLongFromFile: f swap: swapBytes.
	lastHash			_ self getLongFromFile: f swap: swapBytes.
	savedWindowSize	_ self getLongFromFile: f swap: swapBytes.
	fullScreenFlag		_ self getLongFromFile: f swap: swapBytes.
	extraVMMemory		_ self getLongFromFile: f swap: swapBytes.

	lastHash = 0 ifTrue: [
		"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
		lastHash _ 999].

	"decrease Squeak object heap to leave extra memory for the VM"
	heapSize _ self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.

	"compare memory requirements with availability".
	minimumMemory _ dataSize + 100000.  "need at least 100K of breathing room"
	heapSize < minimumMemory ifTrue: [
		GenerateBrowserPlugin
			ifTrue: [
				self plugInNotifyUser: 'The amount of memory specified by the ''memory'' EMBED tag is not enough for the installed Squeak image file.'.
				^ nil]
			ifFalse: [self error: 'Insufficient memory for this image']].

	"allocate a contiguous block of memory for the Squeak heap"
	memory _ self cCode: '(unsigned char *) sqAllocateMemory(minimumMemory, heapSize)'.
	memory = nil ifTrue: [
		GenerateBrowserPlugin
			ifTrue: [
				self plugInNotifyUser: 'There is not enough memory to give Squeak the amount specified by the ''memory'' EMBED tag.'.
				^ nil]
			ifFalse: [self error: 'Failed to allocate memory for the heap']].

	memStart _ self startOfMemory.
	memoryLimit _ (memStart + heapSize) - 24.  "decrease memoryLimit a tad for safety"
	endOfMemory _ memStart + dataSize.

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"read in the image in bulk, then swap the bytes if necessary"
	bytesRead _ self cCode: 'sqImageFileRead(memory, sizeof(unsigned char), dataSize, f)'.
	bytesRead ~= dataSize ifTrue: [
		GenerateBrowserPlugin
			ifTrue: [
				self plugInNotifyUser: 'Squeak had problems reading its image file.'.
				self plugInShutdown.
				^ nil]
			ifFalse: [self error: 'Read failed or premature end of image file']].
	swapBytes ifTrue: [self reverseBytesInImage].

	"compute difference between old and new memory base addresses"
	bytesToShift _ memStart - oldBaseAddr.
	self initializeInterpreter: bytesToShift.  "adjusts all oops to new location"
	^ dataSize
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 3/28/1999 17:55'!
readableFormat: imageVersion
	"Anwer true if images of the given format are readable by this interpreter. Allows a virtual machine to accept selected older image formats."

	^ imageVersion = self imageFormatVersion
"
	Example of multiple formats:
	^ (imageVersion = self imageFormatVersion) or: [imageVersion = 6504]
"! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 3/28/1999 17:42'!
reverseBytesFrom: startAddr to: stopAddr
	"Byte-swap the given range of memory (not inclusive of stopAddr!!)."
	| addr |
	addr _ startAddr.
	[addr < stopAddr] whileTrue:
		[self longAt: addr put: (self byteSwapped: (self longAt: addr)).
		addr _ addr + 4].! !

!Interpreter methodsFor: 'image save/restore' stamp: 'di 10/2/97 00:31'!
reverseBytesInImage
	"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."

	"First, byte-swap every word in the image. This fixes objects headers."
	self reverseBytesFrom: self startOfMemory to: endOfMemory.

	"Second, return the bytes of bytes-type objects to their orginal order."
	self byteSwapByteObjects.! !

!Interpreter methodsFor: 'image save/restore' stamp: 'JMM 11/21/2000 20:25'!
writeImageFile: imageBytes
	| fn |
	self writeImageFileIO: imageBytes.

	"set Mac file type and creator; this is a noop on other platforms"
	fn _ self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
	fn = 0 ifFalse:[
		self cCode:'((int (*) (char*, char*, char*)) fn) (imageName, "STim", "FAST")'.
	].
! !

!Interpreter methodsFor: 'image save/restore' stamp: 'JMM 11/21/2000 20:26'!
writeImageFileEmbedded: imageBytes
	self writeImageFileIO: imageBytes! !

!Interpreter methodsFor: 'image save/restore' stamp: 'JMM 11/21/2000 20:24'!
writeImageFileIO: imageBytes

	| headerStart headerSize f bytesWritten |
	self var: #f declareC: 'sqImageFile f'.

	"local constants"
	headerStart _ 0.  
	headerSize _ 64.  "header size in bytes; do not change!!"

	f _ self cCode: 'sqImageFileOpen(imageName, "wb")'.
	f = nil ifTrue: [
		"could not open the image file for writing"
		self success: false.
		^ nil].

	headerStart _ self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
	self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
	"position file to start of header"
	self sqImageFile: f Seek: headerStart.

	self putLong: (self imageFormatVersion) toFile: f.
	self putLong: headerSize toFile: f.
	self putLong: imageBytes toFile: f.
	self putLong: (self startOfMemory) toFile: f.
	self putLong: specialObjectsOop toFile: f.
	self putLong: lastHash toFile: f.
	self putLong: (self ioScreenSize) toFile: f.
	self putLong: fullScreenFlag toFile: f.
	self putLong: extraVMMemory toFile: f.
	1 to: 7 do: [:i | self putLong: 0 toFile: f].  "fill remaining header words with zeros"
	successFlag ifFalse: [
		"file write or seek failure"
		self cCode: 'sqImageFileClose(f)'.
		^ nil].

	"position file after the header"
	self sqImageFile: f Seek: headerStart + headerSize.

	"write the image data"
	bytesWritten _ self cCode: 'sqImageFileWrite(memory, sizeof(unsigned char), imageBytes, f)'.
	self success: bytesWritten = imageBytes.
	self cCode: 'sqImageFileClose(f)'.

! !


!Interpreter methodsFor: 'quick primitives' stamp: 'di 12/28/1998 09:28'!
primitiveInstVarsPutFromStack
	"Note:  this primitive has been decommissioned.  It is only here for short-term compatibility with an internal 2.3beta-d image that used this.  It did not save much time and it complicated several things.  Plus Jitter will do it right anyway."
	| rcvr offsetBits |
	rcvr _ self stackValue: argumentCount.
	"Mark dirty so stores below can be unchecked"
	(rcvr < youngStart) ifTrue: [ self beRootIfOld: rcvr ].
	0 to: argumentCount-1 do:
		[:i | (i bitAnd: 3) = 0 ifTrue:
			[offsetBits _ self positive32BitValueOf: (self literal: i//4 ofMethod: newMethod)].
		self storePointerUnchecked: (offsetBits bitAnd: 16rFF) ofObject: rcvr
						withValue: (self stackValue: i).
		offsetBits _ offsetBits >> 8].
	self pop: argumentCount! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitiveLoadInstVar
	| thisReceiver |
	thisReceiver _ self popStack.
	self push: (self fetchPointer: primitiveIndex-264 ofObject: thisReceiver)! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushFalse
	self popStack.
	self push: falseObj! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushMinusOne
	self popStack.
	self push: ConstMinusOne! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushNil
	self popStack.
	self push: nilObj! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushOne
	self popStack.
	self push: ConstOne! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushSelf
"	no-op, really...
	thisReceiver _ self popStack.
	self push: thisReceiver
"! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushTrue
	self popStack.
	self push: trueObj! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushTwo
	self popStack.
	self push: ConstTwo! !

!Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'!
primitivePushZero
	self popStack.
	self push: ConstZero! !





!Interpreter methodsFor: 'plugin support' stamp: 'ar 2/2/2001 16:28'!
addToExternalPrimitiveTable: functionAddress
	"Add the given function address to the external primitive table and return the index where it's stored. This function doesn't need to be fast since it is only called when an external primitive has been looked up (which takes quite a bit of time itself). So there's nothing specifically complicated here.
	Note: Return index will be one-based (ST convention)"
	0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
		(externalPrimitiveTable at: i) = 0 ifTrue:[
			externalPrimitiveTable at: i put: functionAddress.
			^i+1]].
	"if no space left, return zero so it'll looked up again"
	^0! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:34'!
byteSizeOf: oop
	| slots |
	(self isIntegerObject: oop) ifTrue:[^0].
	slots _ self slotSizeOf: oop.
	(self isBytes: oop)
		ifTrue:[^slots]
		ifFalse:[^slots * 4]! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classNameOf: aClass Is: className
	"Check if aClass' name is className"
	| srcName name length |
	self var: #className declareC:'char *className'.
	self var: #srcName declareC:'char *srcName'.
	(self lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior" 
	name _ self fetchPointer: 6 ofObject: aClass.
	(self isBytes: name) ifFalse:[^false].
	length _ self stSizeOf: name.
	srcName _ self cCoerce: (self arrayValueOf: name) to:'char *'.
	0 to: length-1 do:[:i|
		(srcName at: i) = (className at: i) ifFalse:[^false].
	].
	"Check if className really ends at this point"
	^(className at: length) = 0! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 5/12/2000 16:35'!
findObsoleteNamedPrimitive: functionName length: functionLength
	"Search the obsolete named primitive table for the given function.
	Return the index if it's found, -1 otherwise."
	| entry index chIndex |
	self var: #functionName type:'char *'.
	self var: #entry type:'const char *'.
	index _ 0.
	[true] whileTrue:[
		entry _ (obsoleteNamedPrimitiveTable at: index) at: 0.
		entry == nil ifTrue:[^-1]. "at end of table"
		"Compare entry with functionName"
		chIndex _ 0.
		[(entry at: chIndex) = (functionName at: chIndex) 
			and:[chIndex < functionLength]] whileTrue:[chIndex _ chIndex + 1].
		(chIndex = functionLength and:[(entry at: chIndex) = 0]) 
			ifTrue:[^index]. "match"
		index _ index + 1.
	].! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:13'!
firstFixedField: oop
	self returnTypeC:'void *'.
	^self cCoerce: oop+4 to:'void *'.! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
firstIndexableField: oop

	| hdr fmt totalLength fixedFields |
	self returnTypeC:'void *'.
	hdr _ self baseHeader: oop.
	fmt _ (hdr >> 8) bitAnd: 16rF.
	totalLength _ self lengthOf: oop baseHeader: hdr format: fmt.
	fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength.
	fmt < 8 ifTrue:["32 bit field objects"
		^ self cCoerce: oop+4+ (fixedFields << 2) to:'void *'.
	] ifFalse:["Byte objects"
		^ self cCoerce: oop+4+fixedFields to:'void *'.
	]! !

!Interpreter methodsFor: 'plugin support' stamp: 'di 4/5/1999 20:27'!
floatObjectOf: aFloat
	| newFloatObj |
	self var: #aFloat declareC: 'double aFloat'.
	newFloatObj _ self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 12 fill: 0.
	self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat.
	^ newFloatObj.
! !

!Interpreter methodsFor: 'plugin support' stamp: 'ikp 10/11/2000 17:29'!
flushExternalPrimitiveOf: methodPtr
	"methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
	| lit |
	(self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
	lit _ self literal: 0 ofMethod: methodPtr.
	((self fetchClassOf: lit) = (self splObj: ClassArray) and:[(self lengthOf: lit) = 4])
		ifFalse:[^nil]. "Something's broken"
	self storeInteger: 2 ofObject: lit withValue: 0.
	self storeInteger: 3 ofObject: lit withValue: 0.
! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 2/2/2001 16:29'!
flushExternalPrimitiveTable
	"Flush the external primitive table"
	0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
		externalPrimitiveTable at: i put: 0.
	].
! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 2/2/2001 16:30'!
flushExternalPrimitives
	"Flush the references to external functions from plugin primitives.
	This will force a reload of those primitives when accessed next.
	Note: We must flush the method cache here so that any failed
	primitives are looked up again."
	| oop fmt primIdx |
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue:[
		(self isFreeObject: oop) ifFalse: [
			fmt _ self formatOf: oop.
			fmt >= 12 ifTrue:["This is a compiled method"
				primIdx _ self primitiveIndexOf: oop.
				primIdx = PrimitiveExternalCallIndex ifTrue:["It's primitiveExternalCall"
					self flushExternalPrimitiveOf: oop.
				].
			].
		].
		oop _ self objectAfter: oop.
	].
	self flushMethodCache.
	self flushObsoleteIndexedPrimitives.
	self flushExternalPrimitiveTable.! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 5/11/2000 23:31'!
flushObsoleteIndexedPrimitives
	"Flush the pointers in the obsolete indexed primitive table"
	1 to: MaxPrimitiveIndex do:[:i|
		(obsoleteIndexedPrimitiveTable at: i) at: 2 put: nil.
	].! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 11/21/1999 00:11'!
includesBehavior: aClass ThatOf: aSuperclass
	"Return the equivalent of 
		aClass includesBehavior: aSuperclass.
	Note: written for efficiency and better inlining (only 1 temp)"
	| theClass |
	self inline: true.
	(((theClass _ aClass) = aSuperclass) "aClass == aSuperclass"
		or:[aSuperclass = nilObj]) "every class inherits from nil"
			ifTrue:[^true].
	[(theClass _ self superclassOf: theClass) = aSuperclass ifTrue:[^true].
	theClass ~= nilObj] whileTrue.
	^false! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:13'!
is: oop KindOf: className
	"Support for external primitives."
	| oopClass |
	self var: #className declareC:'char *className'.
	oopClass _ self fetchClassOf: oop.
	[oopClass == nilObj] whileFalse:[
		(self classNameOf: oopClass Is: className) ifTrue:[^true].
		oopClass _ self superclassOf: oopClass].
	^false! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:13'!
is: oop MemberOf: className
	"Support for external primitives"
	| oopClass |
	self var: #className declareC:'char *className'.
	oopClass _ self fetchClassOf: oop.
	^(self classNameOf: oopClass Is: className)! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:13'!
isFloatObject: oop
	^(self fetchClassOf: oop) == self classFloat! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:13'!
isIndexable: oop
	^(self formatOf: oop) >= 2! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:38'!
methodArgumentCount
	^argumentCount! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:39'!
methodPrimitiveIndex
	^primitiveIndex! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 11/28/1999 17:42'!
primitiveMethod
	"Return the method an external primitive was defined in"
	^newMethod! !

!Interpreter methodsFor: 'plugin support' stamp: 'ar 10/10/1998 21:24'!
slotSizeOf: oop
	"Returns the number of slots in the receiver.
	If the receiver is a byte object, return the number of bytes.
	Otherwise return the number of words."
	(self isIntegerObject: oop) ifTrue:[^0].
	^self lengthOf: oop! !


!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/20/1999 05:05'!
compilerCreateActualMessage: aMessage storingArgs: argArray
	^self cCode: 'compilerHooks[14](aMessage, argArray)'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 1/3/1999 18:00'!
compilerFlushCache: aCompiledMethod
	^self cCode: 'compilerHooks[2](aCompiledMethod)'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 1/3/1999 17:59'!
compilerFlushCacheHook: aCompiledMethod
	self inline: true.
	compilerInitialized ifTrue: [self compilerFlushCache: aCompiledMethod]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:00'!
compilerMapFrom: memStart to: memEnd
	^self cCode: 'compilerHooks[4](memStart, memEnd)'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:03'!
compilerMapHookFrom: memStart to: memEnd
	self inline: true.
	compilerInitialized ifTrue: [self compilerMapFrom: memStart to: memEnd]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/19/1998 17:08'!
compilerMark
	^self cCode: 'compilerHooks[9]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/19/1998 17:08'!
compilerMarkHook
	self inline: true.
	compilerInitialized ifTrue: [self compilerMark]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:00'!
compilerPostGC
	^self cCode: 'compilerHooks[5]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:04'!
compilerPostGCHook
	self inline: true.
	compilerInitialized ifTrue: [self compilerPostGC]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 12:43'!
compilerPostSnapshot
	^self cCode: 'compilerHooks[8]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 12:43'!
compilerPostSnapshotHook
	self inline: true.
	compilerInitialized ifTrue: [self compilerPostSnapshot]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:01'!
compilerPreGC: fullGCFlag
	^self cCode: 'compilerHooks[3](fullGCFlag)'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:03'!
compilerPreGCHook: fullGCFlag
	self inline: true.
	compilerInitialized ifTrue: [self compilerPreGC: fullGCFlag]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 13:10'!
compilerPreSnapshot
	^self cCode: 'compilerHooks[7]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/15/1998 13:10'!
compilerPreSnapshotHook
	self inline: true.
	compilerInitialized ifTrue: [self compilerPreSnapshot]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:01'!
compilerProcessChange
	^self cCode: 'compilerHooks[6]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/24/1999 07:09'!
compilerProcessChange: oldProc to: newProc
	^self cCode: 'compilerHooks[6](oldProc, newProc)'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:04'!
compilerProcessChangeHook
	self inline: true.
	compilerInitialized ifTrue: [self compilerProcessChange]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 10/22/1999 17:01'!
compilerTranslateMethod
	^self cCode: 'compilerHooks[1]()'! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 10/22/1999 17:01'!
compilerTranslateMethodHook
	self inline: true.
	^compilerInitialized and: [self compilerTranslateMethod]! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 21:44'!
disableCompiler
	compilerInitialized _ false! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 21:45'!
enableCompiler
	"Calling this before loading the compiler will provoke a nullCompilerHook error"

	compilerInitialized _ true! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 11/20/1999 04:53'!
initCompilerHooks
	"Initialize hooks for the 'null compiler'"

	self cCode: 'compilerHooks[1]= nullCompilerHook'.
	self cCode: 'compilerHooks[2]= nullCompilerHook'.
	self cCode: 'compilerHooks[3]= nullCompilerHook'.
	self cCode: 'compilerHooks[4]= nullCompilerHook'.
	self cCode: 'compilerHooks[5]= nullCompilerHook'.
	self cCode: 'compilerHooks[6]= nullCompilerHook'.
	self cCode: 'compilerHooks[7]= nullCompilerHook'.
	self cCode: 'compilerHooks[8]= nullCompilerHook'.
	self cCode: 'compilerHooks[9]= nullCompilerHook'.
	self cCode: 'compilerHooks[10]= nullCompilerHook'.
	self cCode: 'compilerHooks[11]= nullCompilerHook'.
	self cCode: 'compilerHooks[12]= nullCompilerHook'.
	self cCode: 'compilerHooks[13]= nullCompilerHook'.
	self cCode: 'compilerHooks[14]= nullCompilerHook'.

	compilerInitialized _ false! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/12/1998 17:08'!
nullCompilerHook
	"This should never be called: either the compiler is uninitialised (in which case the hooks should never be reached) or the compiler initialisation should have replaced all the hook with their external implementations."

	self error: 'uninitialised compiler hook called'.
	^false! !

!Interpreter methodsFor: 'compiler support' stamp: 'ikp 12/16/1998 01:35'!
setCompilerInitialized: newFlag
	| oldFlag |
	oldFlag _ compilerInitialized.
	compilerInitialized _ newFlag.
	^oldFlag! !


!Interpreter methodsFor: 'image segment in/out' stamp: 'di 10/5/1999 19:09'!
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
	"Copy this object into the segment beginning at lastSeg.
	Install a forwarding pointer, and save oop and header.
	Fail if out of space.  Return the next segmentAddr if successful."

	"Copy the object..."
	| extraSize bodySize hdrAddr |
	successFlag ifFalse: [^ lastSeg].
	extraSize _ self extraHeaderBytes: oop.
	bodySize _ self sizeBitsOf: oop.
	(lastSeg + extraSize + bodySize) >= stopAddr
		ifTrue: [^ self primitiveFail].
	self transfer: extraSize + bodySize // 4  "wordCount"
		from: oop - extraSize
		to: lastSeg+4.

	"Clear root and mark bits of all headers copied into the segment"
	hdrAddr _ lastSeg+4 + extraSize.
	self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit).

	self forward: oop to: (lastSeg+4 + extraSize - segmentWordArray)
		savingOopAt: oopPtr andHeaderAt: hdrPtr.

	"Return new end of segment"
	^ lastSeg + extraSize + bodySize! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 3/24/1999 16:10'!
forward: oop to: newOop savingOopAt: oopPtr andHeaderAt: hdrPtr

	"Make a new entry in the table of saved oops."
	self longAt: oopPtr put: oop.					"Save the oop"
	self longAt: hdrPtr put: (self longAt: oop).	"Save the old header word"

	"Put a forwarding pointer in the old object, flagged with forbidden header type"
	self longAt: oop put: newOop + HeaderTypeFree.
! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'tk 12/4/1999 05:41'!
imageSegmentVersion
	| wholeWord |
	"a more complex version that tells both the word reversal and the endianness of the machine it came from.  Low half of word is 6502.  Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)"

	wholeWord _ self longAt: (self splObj: SelectorDoesNotUnderstand) + BaseHeaderSize.
		"first data word, 'does' "
	^ self imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 3/22/1999 23:28'!
oopHasOKclass: oop
	"Similar to oopHasOkayClass:, except that it only returns true or false."

	| oopClass formatMask behaviorFormatBits oopFormatBits |
	(self isIntegerObject: oop) ifTrue: [^ true].
	((0 < oop) & (oop < endOfMemory)) ifFalse: [^ false].
	((oop \\ 4) = 0) ifFalse: [^ false].
	(oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false].
	oopClass _ self fetchClassOf: oop.

	(self isIntegerObject: oopClass) ifTrue: [^ false].
	((0 < oopClass) & (oopClass < endOfMemory)) ifFalse: [^ false].
	((oopClass \\ 4) = 0) ifFalse: [^ false].
	(oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false].
	((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
	(self isBytes: oop)
		ifTrue: [ formatMask _ 16rC00 ]  "ignore extra bytes size bits"
		ifFalse: [ formatMask _ 16rF00 ].

	behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask.
	oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask.
	behaviorFormatBits = oopFormatBits ifFalse: [^ false].
	^ true! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'tk 10/6/1999 08:42'!
primitiveFailAfterCleanup: outPointerArray
	"If the storeSegment primitive fails, it must clean up first."

	| i lastAddr |   "Store nils throughout the outPointer array."
	lastAddr _ outPointerArray + (self lastPointerOf: outPointerArray).
	i _ outPointerArray + BaseHeaderSize.
	[i <= lastAddr] whileTrue:
		[self longAt: i put: nilObj.
		i _ i + 4].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self primitiveFail! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'tk 12/3/1999 14:41'!
primitiveLoadImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."

"This primitive will load a binary image segment created by primitiveStoreImageSegment.  It expects the outPointer array to be of the proper size, and the wordArray to be well formed.  It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero.  If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble.  But what more could you have done with it anyway?"

	| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	outPointerArray _ self stackValue: 0.
	lastOut _ outPointerArray + (self lastPointerOf: outPointerArray).
	segmentWordArray _ self stackValue: 1.
	endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.

	"Essential type checks"
	((self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].

	"Version check.  Byte order of the WordArray now"
	data _ self longAt: segmentWordArray + BaseHeaderSize.
	(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
		"Not readable -- try again with reversed bytes..."
		self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + 4.
		data _ self longAt: segmentWordArray + BaseHeaderSize.
		(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
			"Still NG -- put things back and fail"
			self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + 4.
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail]].
	"Reverse the Byte type objects if the data from opposite endian machine"
	"Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal"
	data = self imageSegmentVersion ifFalse: [
		"Reverse the byte-type objects once"
		segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4.
			 "Oop of first embedded object"
		self byteSwapByteObjectsFrom: segOop to: endSeg + 4].

	"Proceed through the segment, remapping pointers..."
	segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4.
	[segOop <= endSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
					fieldPtr _ segOop - 4.  doingClass _ true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr _ segOop + BaseHeaderSize.  doingClass _ false].
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"
		lastPtr > endSeg ifTrue: [
			DoAssertionChecks ifTrue: [self verifyCleanHeaders].
			^ self primitiveFail "out of bounds"].

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits _ self headerType: fieldPtr.
				fieldOop _ fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue:
					["Integer -- nothing to do"
					fieldPtr _ fieldPtr + 4]
				ifFalse:
					[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
					(fieldOop bitAnd: 16r80000000) = 0
						ifTrue: ["Internal pointer -- add segment offset"
								mapOop _ fieldOop + segmentWordArray]
						ifFalse: ["External pointer -- look it up in outPointers"
								outPtr _ outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
								outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
								mapOop _ self longAt: outPtr].
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr _ fieldPtr + 8.
								doingClass _ false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr _ fieldPtr + 4].
					segOop < youngStart
						ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
					]].
		segOop _ self objectAfter: segOop].

	"Again, proceed through the segment checking consistency..."
	segOop _ self oopFromChunk: segmentWordArray + BaseHeaderSize + 4.
	[segOop <= endSeg] whileTrue:
		[(self oopHasOKclass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
		fieldPtr _ segOop + BaseHeaderSize.		"first field"
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"
		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			(self oopHasOKclass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
			fieldPtr _ fieldPtr + 4].
		segOop _ self objectAfter: segOop].

	"Truncate the segment word array to size = 4 (vers stamp only)"
	extraSize _ self extraHeaderBytes: segmentWordArray.
	hdrTypeBits _ self headerType: segmentWordArray.
	extraSize = 8
		ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + 4 + hdrTypeBits]
		ifFalse: [header _ self longAt: segmentWordArray.
				self longAt: segmentWordArray
					put: header - (header bitAnd: SizeMask) + BaseHeaderSize + 4].	
	"and return the roots array which was first in the segment"
	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + BaseHeaderSize + 4).
! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'tk 2/9/2000 16:51'!
primitiveStoreImageSegment
	"This primitive is called from Squeak as...
		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray."

"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree will be copied into the array of outpointers.  In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."

"The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers).  If either array is too small, the primitive will fail, but in no other case.

During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type).  Tables are kept of both kinds of oops, as well as of the original headers for restoration.

To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray.  Each grows oops from the bottom up, and preserved headers from halfway up.

In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."

	| outPointerArray segmentWordArray savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop doingClass lastPtr extraSize hdrTypeBits arrayOfRoots hdrBaseIn hdrBaseOut header firstOut versionOffset |

	outPointerArray _ self stackValue: 0.
	segmentWordArray _ self stackValue: 1.
	arrayOfRoots _ self stackValue: 2.

	"Essential type checks"
	((self formatOf: arrayOfRoots) = 2				"Must be indexable pointers"
		and: [(self formatOf: outPointerArray) = 2				"Must be indexable pointers"
		and: [(self formatOf: segmentWordArray) = 6]])	"Must be indexable words"
		ifFalse: [^ self primitiveFail].
	((self headerType: outPointerArray) = HeaderTypeSizeAndClass	"Must be 3-word header"
		and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass])	"Must be 3-word header"
		ifFalse: [^ self primitiveFail].

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	"Use the top half of outPointers for saved headers."
	firstOut _ outPointerArray + BaseHeaderSize.
	lastOut _ firstOut - 4.
	hdrBaseOut _ outPointerArray + ((self lastPointerOf: outPointerArray) // 8 * 4). "top half"

	lastSeg _ segmentWordArray.
	endSeg _ segmentWordArray + (self sizeBitsOf: segmentWordArray) - 4.

	"Write a version number for byte order and version check"
	versionOffset _ 4.
	lastSeg _ lastSeg + versionOffset.
	lastSeg > endSeg ifTrue: [^ self primitiveFail].
	self longAt: lastSeg put: self imageSegmentVersion.

	"Allocate top 1/8 of segment for table of internal oops and saved headers"
	firstIn _ endSeg - ((self sizeBitsOf: segmentWordArray) // 32 * 4).  "Take 1/8 of seg"
	lastIn _ firstIn - 4.
	hdrBaseIn _ firstIn + ((self sizeBitsOf: segmentWordArray) // 64 * 4). "top half"

	"First mark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit).
	lastPtr _ arrayOfRoots + (self lastPointerOf: arrayOfRoots).
	fieldPtr _ arrayOfRoots + BaseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop _ self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)].
		fieldPtr _ fieldPtr + 4].

	"Then do a mark pass over all objects.  This will stop at our marked roots,
	thus leaving our segment unmarked in their shadow."
	savedYoungStart _ youngStart.
	youngStart _ self startOfMemory.  "process all of memory"
		"clear the recycled context lists"
		freeContexts _ NilContext.
		freeLargeContexts _ NilContext.
	self markAndTraceInterpreterOops.	"and special objects array"
	youngStart _ savedYoungStart.
	
	"Finally unmark the rootArray and all root objects."
	self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit).
	fieldPtr _ arrayOfRoots + BaseHeaderSize.
	[fieldPtr <= lastPtr] whileTrue:
		[fieldOop _ self longAt: fieldPtr.
		(self isIntegerObject: fieldOop) ifFalse:
			[self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)].
		fieldPtr _ fieldPtr + 4].

	"All external objects, and only they, are now marked.
	Copy the array of roots into the segment, and forward its oop."
	lastIn _ lastIn + 4.
	lastIn >= hdrBaseIn ifTrue: [successFlag _ false].
	lastSeg _ self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
	successFlag ifFalse:
		[lastIn _ lastIn - 4.
		self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
		^ self primitiveFailAfterCleanup: outPointerArray].

	"Now run through the segment fixing up all the pointers.
	Note that more objects will be added to the segment as we make our way along."
	segOop _ self oopFromChunk: segmentWordArray + versionOffset + BaseHeaderSize.
	[segOop <= lastSeg] whileTrue:
		[(self headerType: segOop) <= 1
			ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
					fieldPtr _ segOop - 4.  doingClass _ true]
			ifFalse: ["No class field -- start with first data field"
					fieldPtr _ segOop + BaseHeaderSize.  doingClass _ false].
		lastPtr _ segOop + (self lastPointerOf: segOop).	"last field"

		"Go through all oops, remapping them..."
		[fieldPtr > lastPtr] whileFalse:
			["Examine each pointer field"
			fieldOop _ self longAt: fieldPtr.
			doingClass ifTrue:
				[hdrTypeBits _ fieldOop bitAnd: TypeMask.
				fieldOop _ fieldOop - hdrTypeBits].
			(self isIntegerObject: fieldOop)
				ifTrue: ["Just an integer -- nothing to do"
						fieldPtr _ fieldPtr + 4]
				ifFalse:
				[header _ self longAt: fieldOop.
				(header bitAnd: TypeMask) = HeaderTypeFree
					ifTrue: ["Has already been forwarded -- this is the link"
							mapOop _ header bitAnd: AllButTypeMask]
					ifFalse:
					[((self longAt: fieldOop) bitAnd: MarkBit) = 0
						ifTrue:
							["Points to an unmarked obj -- an internal pointer.
							Copy the object into the segment, and forward its oop."
							lastIn _ lastIn + 4.
							lastIn >= hdrBaseIn ifTrue: [successFlag _ false].
							lastSeg _ self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn).
							successFlag ifFalse:
								["Out of space in segment"
								lastIn _ lastIn - 4.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
							mapOop _ (self longAt: fieldOop) bitAnd: AllButTypeMask]
						ifFalse:
							["Points to a marked obj -- an external pointer.
							Map it as a tagged index in outPointers, and forward its oop."
							lastOut _ lastOut + 4.
							lastOut >= hdrBaseOut ifTrue:
								["Out of space in outPointerArray"
								lastOut _ lastOut - 4.
								self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
								^ self primitiveFailAfterCleanup: outPointerArray].
.							mapOop _ lastOut - outPointerArray bitOr: 16r80000000.
							self forward: fieldOop to: mapOop
								savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
					"Replace the oop by its mapped value"
					doingClass
						ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
								fieldPtr _ fieldPtr + 8.
								doingClass _ false]
						ifFalse: [self longAt: fieldPtr put: mapOop.
								fieldPtr _ fieldPtr + 4].
]].
		segOop _ self objectAfter: segOop].

	self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.

	"Truncate the outPointerArray..."
	((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
		or: [(endSeg - lastSeg) < 12]) ifTrue:
			["Not enough room to insert simple 3-word headers"
			^ self primitiveFailAfterCleanup: outPointerArray].
	extraSize _ self extraHeaderBytes: segmentWordArray.
	hdrTypeBits _ self headerType: segmentWordArray.
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastOut+4.
	"Adjust the size of the original as well as the free chunk."
	self longAt: lastOut+4
		put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
	self longAt: outPointerArray-extraSize
		put: lastOut - firstOut + 8 + hdrTypeBits.
	"Note that pointers have been stored into roots table"
	self beRootIfOld: outPointerArray.

	"Truncate the image segment..."
	"Copy the 3-word wordArray header to establish a free chunk."
	self transfer: 3
		from: segmentWordArray - extraSize
		to: lastSeg+4.
	"Adjust the size of the original as well as the free chunk."
	self longAt: segmentWordArray-extraSize
		put: lastSeg - segmentWordArray + BaseHeaderSize + hdrTypeBits.
	self longAt: lastSeg+4
		put: endSeg - lastSeg - extraSize + hdrTypeBits.

	DoAssertionChecks ifTrue: [self verifyCleanHeaders].
	self pop: 3.  "...leaving the reciever on the stack as return value"
! !

!Interpreter methodsFor: 'image segment in/out' stamp: 'di 3/24/1999 22:24'!
restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut

	"Restore headers smashed by forwarding links"
	| tablePtr oop header |
	tablePtr _ firstIn.
	[tablePtr <= lastIn] whileTrue:
		[oop _ self longAt: tablePtr.
		header _ self longAt: hdrBaseIn + (tablePtr-firstIn).
		self longAt: oop put: header.
		tablePtr _ tablePtr + 4].
	tablePtr _ firstOut.
	[tablePtr <= lastOut] whileTrue:
		[oop _ self longAt: tablePtr.
		header _ self longAt: hdrBaseOut + (tablePtr-firstOut).
		self longAt: oop put: header.
		tablePtr _ tablePtr + 4].
	
	"Clear all mark bits"
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)].
		oop _ self objectAfter: oop].
! !


!Interpreter methodsFor: 'bitblt support' stamp: 'ar 5/12/2000 15:34'!
copyBits
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_copyBits
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"
	| fn |
	fn _ self ioLoadFunction: 'copyBits' From: 'BitBltPlugin'.
	fn = 0 ifTrue:[^self primitiveFail].
	^self cCode:' ((int (*) (void)) fn)()'! !

!Interpreter methodsFor: 'bitblt support' stamp: 'ar 5/12/2000 15:35'!
copyBitsFrom: x0 to: x1 at: y
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_copyBitsFrom:to:at:
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"
	| fn |
	fn _ self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'.
	fn = 0 ifTrue:[^self primitiveFail].
	^self cCode:' ((int (*) (int, int, int)) fn)(x0, x1, y)'! !

!Interpreter methodsFor: 'bitblt support' stamp: 'ar 5/12/2000 15:34'!
loadBitBltFrom: bb
	"This entry point needs to be implemented for the interpreter proxy.
	Since BitBlt is now a plugin we need to look up BitBltPlugin_loadBitBltFrom
	and call it. This entire mechanism should eventually go away and be
	replaced with a dynamic lookup from BitBltPlugin itself but for backward
	compatibility this stub is provided"
	| fn |
	fn _ self ioLoadFunction: 'loadBitBltFrom' From: 'BitBltPlugin'.
	fn = 0 ifTrue:[^self primitiveFail].
	^self cCode:' ((int (*) (int)) fn)(bb)'! !

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

Interpreter class
	instanceVariableNames: ''!

!Interpreter class methodsFor: 'initialization' stamp: 'ar 2/2/2001 16:35'!
initialize
	"Interpreter initialize"

	super initialize.  "initialize ObjectMemory constants"
	self initializeAssociationIndex.
	self initializeBytecodeTable.
	self initializeCaches.
	self initializeCharacterIndex.
	self initializeClassIndices.
	self initializeCompilerHooks.
	self initializeContextIndices.
	self initializeDirectoryLookupResultCodes.
	self initializeMessageIndices.
	self initializeMethodIndices.
	self initializePointIndices.
	self initializePrimitiveTable.
	self initializeSchedulerIndices.
	self initializeSmallIntegers.
	self initializeStreamIndices.

	SemaphoresToSignalSize _ 500.
	PrimitiveExternalCallIndex _ 117. "Primitive index for #primitiveExternalCall"
	GenerateBrowserPlugin _ false.
	MillisecondClockMask _ 16r1FFFFFFF.
	"Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)"
	MaxExternalPrimitiveTableSize _ 4096. "entries"
! !

!Interpreter class methodsFor: 'initialization'!
initializeAssociationIndex
	ValueIndex _ 1! !

!Interpreter class methodsFor: 'initialization'!
initializeBytecodeTable
	"Interpreter initializeBytecodeTable"
	"Note: This table will be used to generate a C switch statement."

	BytecodeTable _ Array new: 256.
	self table: BytecodeTable from:
	#(
		(  0  15 pushReceiverVariableBytecode)
		( 16  31 pushTemporaryVariableBytecode)
		( 32  63 pushLiteralConstantBytecode)
		( 64  95 pushLiteralVariableBytecode)
		( 96 103 storeAndPopReceiverVariableBytecode)
		(104 111 storeAndPopTemporaryVariableBytecode)
		(112 pushReceiverBytecode)
		(113 pushConstantTrueBytecode)
		(114 pushConstantFalseBytecode)
		(115 pushConstantNilBytecode)
		(116 pushConstantMinusOneBytecode)
		(117 pushConstantZeroBytecode)
		(118 pushConstantOneBytecode)
		(119 pushConstantTwoBytecode)
		(120 returnReceiver)
		(121 returnTrue)
		(122 returnFalse)
		(123 returnNil)
		(124 returnTopFromMethod)
		(125 returnTopFromBlock)
		(126 unknownBytecode)
		(127 unknownBytecode)
		(128 extendedPushBytecode)
		(129 extendedStoreBytecode)
		(130 extendedStoreAndPopBytecode)
		(131 singleExtendedSendBytecode)
		(132 doubleExtendedDoAnythingBytecode)
		(133 singleExtendedSuperBytecode)
		(134 secondExtendedSendBytecode)
		(135 popStackBytecode)
		(136 duplicateTopBytecode)
		(137 pushActiveContextBytecode)
		(138 143 experimentalBytecode)
		(144 151 shortUnconditionalJump)
		(152 159 shortConditionalJump)
		(160 167 longUnconditionalJump)
		(168 171 longJumpIfTrue)
		(172 175 longJumpIfFalse)

		"176-191 were sendArithmeticSelectorBytecode"
		(176 bytecodePrimAdd)
		(177 bytecodePrimSubtract)
		(178 bytecodePrimLessThan)
		(179 bytecodePrimGreaterThan)
		(180 bytecodePrimLessOrEqual)
		(181 bytecodePrimGreaterOrEqual)
		(182 bytecodePrimEqual)
		(183 bytecodePrimNotEqual)
		(184 bytecodePrimMultiply)
		(185 bytecodePrimDivide)
		(186 bytecodePrimMod)
		(187 bytecodePrimMakePoint)
		(188 bytecodePrimBitShift)
		(189 bytecodePrimDiv)
		(190 bytecodePrimBitAnd)
		(191 bytecodePrimBitOr)	

		"192-207 were sendCommonSelectorBytecode"
		(192 bytecodePrimAt)
		(193 bytecodePrimAtPut)
		(194 bytecodePrimSize)
		(195 bytecodePrimNext)
		(196 bytecodePrimNextPut)
		(197 bytecodePrimAtEnd)
		(198 bytecodePrimEquivalent)
		(199 bytecodePrimClass)
		(200 bytecodePrimBlockCopy)
		(201 bytecodePrimValue)
		(202 bytecodePrimValueWithArg)
		(203 bytecodePrimDo)
		(204 bytecodePrimNew)
		(205 bytecodePrimNewWithArg)
		(206 bytecodePrimPointX)
		(207 bytecodePrimPointY)

		(208 255 sendLiteralSelectorBytecode)
	).! !

!Interpreter class methodsFor: 'initialization' stamp: 'ikp 10/26/2000 18:02'!
initializeCaches
	| atCacheEntrySize |
	MethodCacheEntries _ 512. 
	MethodCacheSelector _ 1.
	MethodCacheClass _ 2.
	MethodCacheMethod _ 3.
	MethodCachePrim _ 4.
	MethodCacheNative _ 5.
	MethodCacheEntrySize _ 8.  "Must be power of two for masking scheme."
	MethodCacheMask _ (MethodCacheEntries - 1) * MethodCacheEntrySize.
	MethodCacheSize _ MethodCacheEntries * MethodCacheEntrySize.
	CacheProbeMax _ 3.

	AtCacheEntries _ 8.  "Must be power of two"
	AtCacheOop _ 1.
	AtCacheSize _ 2.
	AtCacheFmt _ 3.
	AtCacheFixedFields _ 4.
	atCacheEntrySize _ 4.  "Must be power of two for masking scheme."
	AtCacheMask _ (AtCacheEntries-1) * atCacheEntrySize.
	AtPutBase _ AtCacheEntries * atCacheEntrySize.
	AtCacheTotalSize _ AtCacheEntries * atCacheEntrySize * 2.
! !

!Interpreter class methodsFor: 'initialization'!
initializeCharacterIndex
	CharacterValueIndex _ 0! !

!Interpreter class methodsFor: 'initialization'!
initializeClassIndices
	"Class Class"
	SuperclassIndex _ 0.
	MessageDictionaryIndex _ 1.
	InstanceSpecificationIndex _ 2.
	"Fields of a message dictionary"
	MethodArrayIndex _ 1.
	SelectorStart _ 2! !

!Interpreter class methodsFor: 'initialization' stamp: 'ikp 10/27/2000 14:47'!
initializeCompilerHooks
	"Interpreter initializeCompilerHooks"

	"compilerHooks[] indices:
	1	void compilerTranslateMethodHook(void)
	2	void compilerFlushCacheHook(CompiledMethod *oldMethod)
	3	void compilerPreGCHook(int fullGCFlag)
	4	void compilerMapHook(int memStart, int memEnd)
	5	void compilerPostGCHook(void)
	6	void compilerProcessChangeHook(void)
	7	void compilerPreSnapshotHook(void)
	8	void compilerPostSnapshotHook(void)
	9	void compilerMarkHook(void)
	10	void compilerActivateMethodHook(void)
	11	void compilerNewActiveContextHook(int sendFlag)
	12	void compilerGetInstructionPointerHook(void)
	13	void compilerSetInstructionPointerHook(void)
	14	void compilerCreateActualMessageHook(void)"

	CompilerHooksSize _ 15.! !

!Interpreter class methodsFor: 'initialization'!
initializeContextIndices
	"Class MethodContext"
	SenderIndex _ 0.
	InstructionPointerIndex _ 1.
	StackPointerIndex _ 2.
	MethodIndex _ 3.
	ReceiverIndex _ 5.
	TempFrameStart _ 6.
	"Class BlockContext"
	CallerIndex _ 0.
	BlockArgumentCountIndex _ 3.
	InitialIPIndex _ 4.
	HomeIndex _ 5! !

!Interpreter class methodsFor: 'initialization'!
initializeDirectoryLookupResultCodes

	DirEntryFound _ 0.
	DirNoMoreEntries _ 1.
	DirBadPath _ 2.! !

!Interpreter class methodsFor: 'initialization' stamp: 'di 3/25/1999 22:09'!
initializeMessageIndices
	MessageSelectorIndex _ 0.
	MessageArgumentsIndex _ 1.
	MessageLookupClassIndex _ 2.! !

!Interpreter class methodsFor: 'initialization'!
initializeMethodIndices
	"Class CompiledMethod"
	HeaderIndex _ 0.
	LiteralStart _ 1! !

!Interpreter class methodsFor: 'initialization'!
initializePointIndices
	XIndex _ 0.
	YIndex _ 1! !

!Interpreter class methodsFor: 'initialization' stamp: 'ar 2/3/2001 16:22'!
initializePrimitiveTable 
	"This table generates a C switch statement for primitive dispatching."

	"NOTE: The real limit here is 2047, but our C compiler currently barfs over 700"
	MaxPrimitiveIndex _ 700.
	PrimitiveTable _ Array new: MaxPrimitiveIndex + 1.
	self table: PrimitiveTable from: 
	#(	"Integer Primitives (0-19)"
		(0 primitiveFail)
		(1 primitiveAdd)
		(2 primitiveSubtract)
		(3 primitiveLessThan)
		(4 primitiveGreaterThan)
		(5 primitiveLessOrEqual)
		(6 primitiveGreaterOrEqual)
		(7 primitiveEqual)
		(8 primitiveNotEqual)
		(9 primitiveMultiply)
		(10 primitiveDivide)
		(11 primitiveMod)
		(12 primitiveDiv)
		(13 primitiveQuo)
		(14 primitiveBitAnd)
		(15 primitiveBitOr)
		(16 primitiveBitXor)
		(17 primitiveBitShift)
		(18 primitiveMakePoint)
		(19 primitiveFail)					"Guard primitive for simulation -- *must* fail"

		"LargeInteger Primitives (20-39)"
		"32-bit logic is aliased to Integer prims above"
		(20 39 primitiveFail)

		"Float Primitives (40-59)"
		(40 primitiveAsFloat)
		(41 primitiveFloatAdd)
		(42 primitiveFloatSubtract)
		(43 primitiveFloatLessThan)
		(44 primitiveFloatGreaterThan)
		(45 primitiveFloatLessOrEqual)
		(46 primitiveFloatGreaterOrEqual)
		(47 primitiveFloatEqual)
		(48 primitiveFloatNotEqual)
		(49 primitiveFloatMultiply)
		(50 primitiveFloatDivide)
		(51 primitiveTruncated)
		(52 primitiveFractionalPart)
		(53 primitiveExponent)
		(54 primitiveTimesTwoPower)
		(55 primitiveSquareRoot)
		(56 primitiveSine)
		(57 primitiveArctan)
		(58 primitiveLogN)
		(59 primitiveExp)

		"Subscript and Stream Primitives (60-67)"
		(60 primitiveAt)
		(61 primitiveAtPut)
		(62 primitiveSize)
		(63 primitiveStringAt)
		(64 primitiveStringAtPut)
		(65 primitiveNext)
		(66 primitiveNextPut)
		(67 primitiveAtEnd)

		"StorageManagement Primitives (68-79)"
		(68 primitiveObjectAt)
		(69 primitiveObjectAtPut)
		(70 primitiveNew)
		(71 primitiveNewWithArg)
		(72 primitiveArrayBecomeOneWay)	"Blue Book: primitiveBecome"
		(73 primitiveInstVarAt)
		(74 primitiveInstVarAtPut)
		(75 primitiveAsOop)
		(76 primitiveStoreStackp)					"Blue Book: primitiveAsObject"
		(77 primitiveSomeInstance)
		(78 primitiveNextInstance)
		(79 primitiveNewMethod)

		"Control Primitives (80-89)"
		(80 primitiveBlockCopy)
		(81 primitiveValue)
		(82 primitiveValueWithArgs)
		(83 primitivePerform)
		(84 primitivePerformWithArgs)
		(85 primitiveSignal)
		(86 primitiveWait)
		(87 primitiveResume)
		(88 primitiveSuspend)
		(89 primitiveFlushCache)

		"Input/Output Primitives (90-109)"
		(90 primitiveMousePoint)
		(91 primitiveTestDisplayDepth)			"Blue Book: primitiveCursorLocPut"
		(92 primitiveSetDisplayMode)				"Blue Book: primitiveCursorLink"
		(93 primitiveInputSemaphore)
		(94 primitiveGetNextEvent)				"Blue Book: primitiveSampleInterval"
		(95 primitiveInputWord)
		(96 primitiveObsoleteIndexedPrimitive)	"primitiveCopyBits"
		(97 primitiveSnapshot)
		(98 primitiveStoreImageSegment)
		(99 primitiveLoadImageSegment)
		(100 primitivePerformInSuperclass)		"Blue Book: primitiveSignalAtTick"
		(101 primitiveBeCursor)
		(102 primitiveBeDisplay)
		(103 primitiveScanCharacters)
		(104 primitiveObsoleteIndexedPrimitive)	"primitiveDrawLoop"
		(105 primitiveStringReplace)
		(106 primitiveScreenSize)
		(107 primitiveMouseButtons)
		(108 primitiveKbdNext)
		(109 primitiveKbdPeek)

		"System Primitives (110-119)"
		(110 primitiveEquivalent)
		(111 primitiveClass)
		(112 primitiveBytesLeft)
		(113 primitiveQuit)
		(114 primitiveExitToDebugger)
		(115 primitiveFail)					"Blue Book: primitiveOopsLeft"
		(116 primitiveFlushCacheByMethod)
		(117 primitiveExternalCall)
		(118 primitiveDoPrimitiveWithArgs)
		(119 primitiveFlushCacheSelective)
			"Squeak 2.2 and earlier use 119.  Squeak 2.3 and later use 116.
			Both are supported for backward compatibility."

		"Miscellaneous Primitives (120-127)"
		(120 primitiveCalloutToFFI)
		(121 primitiveImageName)
		(122 primitiveNoop)					"Blue Book: primitiveImageVolume"
		(123 primitiveFail)
		(124 primitiveLowSpaceSemaphore)
		(125 primitiveSignalAtBytesLeft)

		"Squeak Primitives Start Here"

		"Squeak Miscellaneous Primitives (128-149)"
		(126 primitiveDeferDisplayUpdates)
		(127 primitiveShowDisplayRect)
		(128 primitiveArrayBecome)
		(129 primitiveSpecialObjectsOop)
		(130 primitiveFullGC)
		(131 primitiveIncrementalGC)
		(132 primitiveObjectPointsTo)
		(133 primitiveSetInterruptKey)
		(134 primitiveInterruptSemaphore)
		(135 primitiveMillisecondClock)
		(136 primitiveSignalAtMilliseconds)
		(137 primitiveSecondsClock)
		(138 primitiveSomeObject)
		(139 primitiveNextObject)
		(140 primitiveBeep)
		(141 primitiveClipboardText)
		(142 primitiveVMPath)
		(143 primitiveShortAt)
		(144 primitiveShortAtPut)
		(145 primitiveConstantFill)
		(146 primitiveObsoleteIndexedPrimitive)	"primitiveReadJoystick"
		(147 primitiveObsoleteIndexedPrimitive)	"primitiveWarpBits"
		(148 primitiveClone)
		(149 primitiveGetAttribute)

		"File Primitives (150-169) - NO LONGER INDEXED"
		(150 164 primitiveObsoleteIndexedPrimitive)
		(165 168 primitiveFail)
		(169 primitiveObsoleteIndexedPrimitive)

		"Sound Primitives (170-199) - NO LONGER INDEXED"
		(170 185 primitiveObsoleteIndexedPrimitive)
		(186 188 primitiveFail)
		(189 194 primitiveObsoleteIndexedPrimitive)
		(195 199 primitiveFail)

		"Networking Primitives (200-229) - NO LONGER INDEXED"
		(200 225 primitiveObsoleteIndexedPrimitive)
		(226 229 primitiveFail)

		"Other Primitives (230-249)"
		(230 primitiveRelinquishProcessor)
		(231 primitiveForceDisplayUpdate)
		(232 primitiveFormPrint)
		(233 primitiveSetFullScreen)
		(234 primitiveObsoleteIndexedPrimitive) "primBitmapdecompressfromByteArrayat"
		(235 primitiveObsoleteIndexedPrimitive) "primStringcomparewithcollated"
		(236 primitiveObsoleteIndexedPrimitive) "primSampledSoundconvert8bitSignedFromto16Bit"
		(237 primitiveObsoleteIndexedPrimitive) "primBitmapcompresstoByteArray"
		(238 241 primitiveObsoleteIndexedPrimitive) "serial port primitives"
		(242 primitiveFail)
		(243 primitiveObsoleteIndexedPrimitive) "primStringtranslatefromtotable"
		(244 primitiveObsoleteIndexedPrimitive) "primStringfindFirstInStringinSetstartingAt"
		(245 primitiveObsoleteIndexedPrimitive) "primStringindexOfAsciiinStringstartingAt"
		(246 primitiveObsoleteIndexedPrimitive) "primStringfindSubstringinstartingAtmatchTable"
		(247 primitiveSnapshotEmbedded)
		(248 249 primitiveFail)

		"VM Implementor Primitives (250-255)"
		(250 clearProfile)
		(251 dumpProfile)
		(252 startProfiling)
		(253 stopProfiling)
		(254 primitiveVMParameter)
		(255 primitiveInstVarsPutFromStack) "Never used except in Disney tests.  Remove after 2.3 release."

		"Quick Push Const Methods"
		(256 primitivePushSelf)
		(257 primitivePushTrue)
		(258 primitivePushFalse)
		(259 primitivePushNil)
		(260 primitivePushMinusOne)
		(261 primitivePushZero)
		(262 primitivePushOne)
		(263 primitivePushTwo)

		"Quick Push Const Methods"
		(264 519 primitiveLoadInstVar)

		"MIDI Primitives (520-539) - NO LONGER INDEXED"
		(520 529 primitiveObsoleteIndexedPrimitive)
		(530 539 primitiveFail)  "reserved for extended MIDI primitives"

		"Experimental Asynchrous File Primitives - NO LONGER INDEXED"
		(540 545 primitiveObsoleteIndexedPrimitive)
		(546 547 primitiveFail)

		"Pen Tablet Primitives - NO LONGER INDEXED"
		(548 primitiveObsoleteIndexedPrimitive)
		(549 primitiveObsoleteIndexedPrimitive)

		"Sound Codec Primitives - NO LONGER INDEXED"
		(550 553 primitiveObsoleteIndexedPrimitive)
		(554 569 primitiveFail)

		"External primitive support primitives"
		(570 primitiveFlushExternalPrimitives)
		(571 primitiveUnloadModule)
		(572 primitiveListBuiltinModule)
		(573 primitiveListExternalModule)
		(574 primitiveFail) "reserved for addl. external support prims"

		"Unassigned Primitives"
		(575 700 primitiveFail)).
! !

!Interpreter class methodsFor: 'initialization'!
initializeSchedulerIndices
	"Class ProcessorScheduler"
	ProcessListsIndex _ 0.
	ActiveProcessIndex _ 1.
	"Class LinkedList"
	FirstLinkIndex _ 0.
	LastLinkIndex _ 1.
	"Class Semaphore"
	ExcessSignalsIndex _ 2.
	"Class Link"
	NextLinkIndex _ 0.
	"Class Process"
	SuspendedContextIndex _ 1.
	PriorityIndex _ 2.
	MyListIndex _ 3! !

!Interpreter class methodsFor: 'initialization'!
initializeSmallIntegers
	"SmallIntegers"
	ConstMinusOne _ Interpreter new integerObjectOf: -1.
	ConstZero _ Interpreter new integerObjectOf: 0.
	ConstOne _ Interpreter new integerObjectOf: 1.
	ConstTwo _ Interpreter new integerObjectOf: 2! !

!Interpreter class methodsFor: 'initialization'!
initializeStreamIndices
	StreamArrayIndex _ 0.
	StreamIndexIndex _ 1.
	StreamReadLimitIndex _ 2.
	StreamWriteLimitIndex _ 3.! !

!Interpreter class methodsFor: 'initialization' stamp: 'ar 2/3/2001 16:22'!
obsoleteIndexedPrimitiveTable
	"Interpreter obsoleteIndexedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives to
	the new named primitives."
	| table |
	table _ Array new: MaxPrimitiveIndex+1.
	#(
		(96	(BitBltPlugin primitiveCopyBits))
		(104 (BitBltPlugin primitiveDrawLoop))
		(147 (BitBltPlugin primitiveWarpBits))

		(146 (JoystickTabletPlugin primitiveReadJoystick))

		"File Primitives (150-169)"
		(150 (FilePlugin primitiveFileAtEnd))
		(151 (FilePlugin primitiveFileClose))
		(152 (FilePlugin primitiveFileGetPosition))
		(153 (FilePlugin primitiveFileOpen))
		(154 (FilePlugin primitiveFileRead))
		(155 (FilePlugin primitiveFileSetPosition))
		(156 (FilePlugin primitiveFileDelete))
		(157 (FilePlugin primitiveFileSize))
		(158 (FilePlugin primitiveFileWrite))
		(159 (FilePlugin primitiveFileRename))
		(160 (FilePlugin primitiveDirectoryCreate))
		(161 (FilePlugin primitiveDirectoryDelimitor))
		(162 (FilePlugin primitiveDirectoryLookup))
		(163 (FilePlugin primitiveDirectoryDelete))
		(164 (FilePlugin primitiveDirectoryGetMacTypeAndCreator))
		(169 (FilePlugin primitiveDirectorySetMacTypeAndCreator))

		"Sound Primitives (170-199)"
		(170 (SoundPlugin primitiveSoundStart))
		(171 (SoundPlugin primitiveSoundStartWithSemaphore))
		(172 (SoundPlugin primitiveSoundStop))
		(173 (SoundPlugin primitiveSoundAvailableSpace))
		(174 (SoundPlugin primitiveSoundPlaySamples))
		(175 (SoundPlugin primitiveSoundPlaySilence))

		(176 (SoundGenerationPlugin primitiveWaveTableSoundMix))
		(177 (SoundGenerationPlugin primitiveFMSoundMix))
		(178 (SoundGenerationPlugin primitivePluckedSoundMix))
		(179 (SoundGenerationPlugin primitiveSampledSoundMix))
		(180 (SoundGenerationPlugin primitiveMixFMSound))
		(181 (SoundGenerationPlugin primitiveMixPluckedSound))
		(182 (SoundGenerationPlugin primitiveOldSampledSoundMix))
		(183 (SoundGenerationPlugin primitiveApplyReverb))
		(184 (SoundGenerationPlugin primitiveMixLoopedSampledSound))
		(185 (SoundGenerationPlugin primitiveMixSampledSound))

		(189 (SoundPlugin primitiveSoundInsertSamples))
		(190 (SoundPlugin primitiveSoundStartRecording))
		(191 (SoundPlugin primitiveSoundStopRecording))
		(192 (SoundPlugin primitiveSoundGetRecordingSampleRate))
		(193 (SoundPlugin primitiveSoundRecordSamples))
		(194 (SoundPlugin primitiveSoundSetRecordLevel))

		"Networking Primitives (200-229)"
		(200 (SocketPlugin primitiveInitializeNetwork))
		(201 (SocketPlugin primitiveResolverStartNameLookup))
		(202 (SocketPlugin primitiveResolverNameLookupResult))
		(203 (SocketPlugin primitiveResolverStartAddressLookup))
		(204 (SocketPlugin primitiveResolverAddressLookupResult))
		(205 (SocketPlugin primitiveResolverAbortLookup))
		(206 (SocketPlugin primitiveResolverLocalAddress))
		(207 (SocketPlugin primitiveResolverStatus))
		(208 (SocketPlugin primitiveResolverError))
		(209 (SocketPlugin primitiveSocketCreate))
		(210 (SocketPlugin primitiveSocketDestroy))
		(211 (SocketPlugin primitiveSocketConnectionStatus))
		(212 (SocketPlugin primitiveSocketError))
		(213 (SocketPlugin primitiveSocketLocalAddress))
		(214 (SocketPlugin primitiveSocketLocalPort))
		(215 (SocketPlugin primitiveSocketRemoteAddress))
		(216 (SocketPlugin primitiveSocketRemotePort))
		(217 (SocketPlugin primitiveSocketConnectToPort))
		(218 (SocketPlugin primitiveSocketListenWithOrWithoutBacklog))
		(219 (SocketPlugin primitiveSocketCloseConnection))
		(220 (SocketPlugin primitiveSocketAbortConnection))
		(221 (SocketPlugin primitiveSocketReceiveDataBufCount))
		(222 (SocketPlugin primitiveSocketReceiveDataAvailable))
		(223 (SocketPlugin primitiveSocketSendDataBufCount))
		(224 (SocketPlugin primitiveSocketSendDone))
		(225 (SocketPlugin primitiveSocketAccept))

		"Other Primitives (230-249)"
		(234 (MiscPrimitivePlugin primitiveDecompressFromByteArray))
		(235 (MiscPrimitivePlugin primitiveCompareString))
		(236 (MiscPrimitivePlugin primitiveConvert8BitSigned))
		(237 (MiscPrimitivePlugin primitiveCompressToByteArray))
		(238 (SerialPlugin primitiveSerialPortOpen))
		(239 (SerialPlugin primitiveSerialPortClose))
		(240 (SerialPlugin primitiveSerialPortWrite))
		(241 (SerialPlugin primitiveSerialPortRead))

		(243 (MiscPrimitivePlugin primitiveTranslateStringWithTable))
		(244 (MiscPrimitivePlugin primitiveFindFirstInString))
		(245 (MiscPrimitivePlugin primitiveIndexOfAsciiInString))
		(246 (MiscPrimitivePlugin primitiveFindSubstring))

		"MIDI Primitives (520-539)"
		(521 (MIDIPlugin primitiveMIDIClosePort))
		(522 (MIDIPlugin primitiveMIDIGetClock))
		(523 (MIDIPlugin primitiveMIDIGetPortCount))
		(524 (MIDIPlugin primitiveMIDIGetPortDirectionality))
		(525 (MIDIPlugin primitiveMIDIGetPortName))
		(526 (MIDIPlugin primitiveMIDIOpenPort))
		(527 (MIDIPlugin primitiveMIDIParameterGetOrSet))
		(528 (MIDIPlugin primitiveMIDIRead))
		(529 (MIDIPlugin primitiveMIDIWrite))

		"Experimental Asynchrous File Primitives"
		(540 (AsynchFilePlugin primitiveAsyncFileClose))
		(541 (AsynchFilePlugin primitiveAsyncFileOpen))
		(542 (AsynchFilePlugin primitiveAsyncFileReadResult))
		(543 (AsynchFilePlugin primitiveAsyncFileReadStart))
		(544 (AsynchFilePlugin primitiveAsyncFileWriteResult))
		(545 (AsynchFilePlugin primitiveAsyncFileWriteStart))

		"Pen Tablet Primitives"
		(548 (JoystickTabletPlugin primitiveGetTabletParameters))
		(549 (JoystickTabletPlugin primitiveReadTablet))

		"Sound Codec Primitives"

		(550 (ADPCMCodecPlugin primitiveDecodeMono))
		(551 (ADPCMCodecPlugin primitiveDecodeStereo))	
		(552 (ADPCMCodecPlugin primitiveEncodeMono))	
		(553 (ADPCMCodecPlugin primitiveEncodeStereo))

	) do:[:spec| table at: spec first+1 put: spec second].
	^table! !

!Interpreter class methodsFor: 'initialization' stamp: 'ar 5/11/2000 22:42'!
obsoleteIndexedPrimitiveTableString
	"Interpreter obsoleteIndexedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives to
	the new named primitives."
	| table |
	table _ self obsoleteIndexedPrimitiveTable.
	^String streamContents:[:s|
		s nextPutAll:'{'; cr.
		table doWithIndex:[:primSpec :idx|
			primSpec ifNil:[
				s nextPutAll:'{ NULL, NULL, NULL }'.
			] ifNotNil:[
				s nextPutAll:'{ "';
					nextPutAll: primSpec first;
					nextPutAll:'", "';
					nextPutAll: primSpec last;
					nextPutAll: '", NULL }'].
			idx < table size ifTrue:[s nextPut:$, ; cr]].
			s cr; nextPutAll:'}'.
	].! !

!Interpreter class methodsFor: 'initialization' stamp: 'ar 5/12/2000 16:26'!
obsoleteNamedPrimitiveTable
	"Interpreter obsoleteNamedPrimitiveTableString"
	"Initialize the links from the (now obsolete) named primitives to
	the new named primitives."
	^#(
		(gePrimitiveMergeFillFrom B2DPlugin primitiveMergeFillFrom)
		(gePrimitiveSetClipRect B2DPlugin primitiveSetClipRect)
		(gePrimitiveDoProfileStats B2DPlugin primitiveDoProfileStats)
		(gePrimitiveAddCompressedShape B2DPlugin primitiveAddCompressedShape)
		(gePrimitiveFinishedProcessing B2DPlugin primitiveFinishedProcessing)
		(gePrimitiveGetBezierStats B2DPlugin primitiveGetBezierStats)
		(gePrimitiveSetDepth B2DPlugin primitiveSetDepth)
		(gePrimitiveAbortProcessing B2DPlugin primitiveAbortProcessing)
		(gePrimitiveGetTimes B2DPlugin primitiveGetTimes)
		(gePrimitiveNextActiveEdgeEntry B2DPlugin primitiveNextActiveEdgeEntry)
		(gePrimitiveAddBezier B2DPlugin primitiveAddBezier)
		(gePrimitiveRenderScanline B2DPlugin primitiveRenderScanline)
		(gePrimitiveAddBezierShape B2DPlugin primitiveAddBezierShape)
		(gePrimitiveAddLine B2DPlugin primitiveAddLine)
		(gePrimitiveRenderImage B2DPlugin primitiveRenderImage)
		(gePrimitiveGetAALevel B2DPlugin primitiveGetAALevel)
		(gePrimitiveRegisterExternalEdge B2DPlugin primitiveRegisterExternalEdge)
		(gePrimitiveInitializeBuffer B2DPlugin primitiveInitializeBuffer)
		(gePrimitiveAddRect B2DPlugin primitiveAddRect)
		(gePrimitiveInitializeProcessing B2DPlugin primitiveInitializeProcessing)
		(gePrimitiveAddBitmapFill B2DPlugin primitiveAddBitmapFill)
		(gePrimitiveGetClipRect B2DPlugin primitiveGetClipRect)
		(gePrimitiveGetFailureReason B2DPlugin primitiveGetFailureReason)
		(gePrimitiveNextGlobalEdgeEntry B2DPlugin primitiveNextGlobalEdgeEntry)
		(gePrimitiveNextFillEntry B2DPlugin primitiveNextFillEntry)
		(gePrimitiveSetColorTransform B2DPlugin primitiveSetColorTransform)
		(gePrimitiveDisplaySpanBuffer B2DPlugin primitiveDisplaySpanBuffer)
		(gePrimitiveGetOffset B2DPlugin primitiveGetOffset)
		(gePrimitiveAddPolygon B2DPlugin primitiveAddPolygon)
		(gePrimitiveNeedsFlush B2DPlugin primitiveNeedsFlush)
		(gePrimitiveAddOval B2DPlugin primitiveAddOval)
		(gePrimitiveSetAALevel B2DPlugin primitiveSetAALevel)
		(gePrimitiveCopyBuffer B2DPlugin primitiveCopyBuffer)
		(gePrimitiveAddActiveEdgeEntry B2DPlugin primitiveAddActiveEdgeEntry)
		(gePrimitiveGetCounts B2DPlugin primitiveGetCounts)
		(gePrimitiveSetOffset B2DPlugin primitiveSetOffset)
		(gePrimitiveAddGradientFill B2DPlugin primitiveAddGradientFill)
		(gePrimitiveChangedActiveEdgeEntry B2DPlugin primitiveChangedActiveEdgeEntry)
		(gePrimitiveRegisterExternalFill B2DPlugin primitiveRegisterExternalFill)
		(gePrimitiveGetDepth B2DPlugin primitiveGetDepth)
		(gePrimitiveSetEdgeTransform B2DPlugin primitiveSetEdgeTransform)
		(gePrimitiveNeedsFlushPut B2DPlugin primitiveNeedsFlushPut)

		(primitiveFloatArrayAt FloatArrayPlugin primitiveAt)
		(primitiveFloatArrayMulFloatArray FloatArrayPlugin primitiveMulFloatArray)
		(primitiveFloatArrayAddScalar FloatArrayPlugin primitiveAddScalar)
		(primitiveFloatArrayDivFloatArray FloatArrayPlugin primitiveDivFloatArray)
		(primitiveFloatArrayDivScalar FloatArrayPlugin primitiveDivScalar)
		(primitiveFloatArrayHash FloatArrayPlugin primitiveHash)
		(primitiveFloatArrayAtPut FloatArrayPlugin primitiveAtPut)
		(primitiveFloatArrayMulScalar FloatArrayPlugin primitiveMulScalar)
		(primitiveFloatArrayAddFloatArray FloatArrayPlugin primitiveAddFloatArray)
		(primitiveFloatArraySubScalar FloatArrayPlugin primitiveSubScalar)
		(primitiveFloatArraySubFloatArray FloatArrayPlugin primitiveSubFloatArray)
		(primitiveFloatArrayEqual FloatArrayPlugin primitiveEqual)
		(primitiveFloatArrayDotProduct FloatArrayPlugin primitiveDotProduct)

		(m23PrimitiveInvertRectInto Matrix2x3Plugin primitiveInvertRectInto)
		(m23PrimitiveTransformPoint Matrix2x3Plugin primitiveTransformPoint)
		(m23PrimitiveIsPureTranslation Matrix2x3Plugin primitiveIsPureTranslation)
		(m23PrimitiveComposeMatrix Matrix2x3Plugin primitiveComposeMatrix)
		(m23PrimitiveTransformRectInto Matrix2x3Plugin primitiveTransformRectInto)
		(m23PrimitiveIsIdentity Matrix2x3Plugin primitiveIsIdentity)
		(m23PrimitiveInvertPoint Matrix2x3Plugin primitiveInvertPoint)

		(primitiveDeflateBlock ZipPlugin primitiveDeflateBlock)
		(primitiveDeflateUpdateHashTable ZipPlugin primitiveDeflateUpdateHashTable)
		(primitiveUpdateGZipCrc32 ZipPlugin primitiveUpdateGZipCrc32)
		(primitiveInflateDecompressBlock ZipPlugin primitiveInflateDecompressBlock)
		(primitiveZipSendBlock ZipPlugin primitiveZipSendBlock)

		(primitiveFFTTransformData FFTPlugin primitiveFFTTransformData)
		(primitiveFFTScaleData FFTPlugin primitiveFFTScaleData)
		(primitiveFFTPermuteData FFTPlugin primitiveFFTPermuteData)
	)! !

!Interpreter class methodsFor: 'initialization' stamp: 'ar 5/11/2000 23:30'!
obsoleteNamedPrimitiveTableString
	"Interpreter obsoleteNamedPrimitiveTableString"
	"Initialize the links from the (now obsolete) indexed primitives to
	the new named primitives."
	| table |
	table _ self obsoleteNamedPrimitiveTable.
	^String streamContents:[:s|
		s nextPutAll:'{'; cr.
		table do:[:primSpec |
			s nextPutAll:'{ "';
				nextPutAll: primSpec first;
				nextPutAll:'", "';
				nextPutAll: primSpec second;
				nextPutAll:'", "';
				nextPutAll: primSpec third;
				nextPutAll: '" },'; cr].
		s nextPutAll: '{ NULL, NULL, NULL }'.
		s cr; nextPutAll:'}'.
	].! !

!Interpreter class methodsFor: 'initialization'!
table: anArray from: specArray
	"SpecArray is an array of either (index selector) or (index1 index2 selector)."

	| contiguous |
	contiguous _ 0.
	specArray do: [ :spec |
		(spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ].
		spec size = 2 ifTrue: [
			anArray at: ((spec at: 1) + 1) put: (spec at: 2).
			contiguous _ contiguous + 1.
		] ifFalse: [
			(spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ].
			contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1.
		].
	].! !


!Interpreter class methodsFor: 'constants'!
bytecodeTable

	^ BytecodeTable! !

!Interpreter class methodsFor: 'constants'!
primitiveTable

	^ PrimitiveTable! !


!Interpreter class methodsFor: 'translation' stamp: 'ar 2/2/2001 16:37'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator 
		var: #interpreterProxy 
		type: #'struct VirtualMachine*'.
	aCCodeGenerator
		var: #methodCache
		declareC: 'int methodCache[', (MethodCacheSize + 1) printString, ']'.
	aCCodeGenerator
		var: #atCache
		declareC: 'int atCache[', (AtCacheTotalSize + 1) printString, ']'.
	aCCodeGenerator var: #localIP type: #'char*'.
	aCCodeGenerator var: #localSP type: #'char*'.
	aCCodeGenerator var: 'semaphoresToSignalA'
		declareC: 'int semaphoresToSignalA[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator var: 'semaphoresToSignalB'
		declareC: 'int semaphoresToSignalB[', (SemaphoresToSignalSize + 1) printString, ']'.
	aCCodeGenerator
		var: #compilerHooks
		declareC: 'int (*compilerHooks[', (CompilerHooksSize + 1) printString, '])()'.
	aCCodeGenerator
		var: #interpreterVersion
		declareC: 'const char *interpreterVersion = "', Smalltalk version, ' [', Smalltalk lastUpdateString,']"'.
	aCCodeGenerator
		var: #obsoleteIndexedPrimitiveTable
		declareC: 'char* obsoleteIndexedPrimitiveTable[][3] = ', self obsoleteIndexedPrimitiveTableString.
	aCCodeGenerator
		var: #obsoleteNamedPrimitiveTable
		declareC: 'const char* obsoleteNamedPrimitiveTable[][3] = ', self obsoleteNamedPrimitiveTableString.
	aCCodeGenerator
		var: #externalPrimitiveTable
		declareC: 'int externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'.
! !

!Interpreter class methodsFor: 'translation'!
patchInterp: fileName
	"Interpreter patchInterp: 'Squeak VM PPC'"
	"This will patch out the unneccesary range check (a compare
	 and branch) in the inner interpreter dispatch loop."
	"NOTE: You must edit in the Interpeter file name, and the
	 number of instructions (delta) to count back to find the compare
	 and branch that we want to get rid of."

	| delta f code len remnant i |
	delta _ 6.
	f _ FileStream fileNamed: fileName.
	f binary.
	code _ Bitmap new: (len _ f size) // 4.
	f nextInto: code.
	remnant _ f next: len - (code size * 4).
	i _ 0.
	["Look for a BCTR instruction"
	(i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: [
		"Look for a CMPLWI FF, 6 instrs back"
	       ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue: [
	       	"Copy dispatch instrs back over the compare"
			SelectionMenu notify: 'Patching at ', i hex.
			0 to: delta - 2 do: [ :j |
				code at: (i - delta) + j put: (code at: (i - delta) + j + 2).
			].
		].
	].
	f position: 0; nextPutAll: code; nextPutAll: remnant.
	f close.
! !

!Interpreter class methodsFor: 'translation' stamp: 'JMM 11/22/2000 16:41'!
patchInterpGCCPPC: fileName
	"Interpreter patchInterpGCCPPC: 'Squeak copy 1'"
	"This will patch out the unneccesary range check (a compare
	 and branch) in the inner interpreter dispatch loop. for the PPC version of the GCC compiled
	version of Squeak under MPW"
	"NOTE: You must edit in the Interpeter file name"

	| delta f code len remnant i |
	delta _ 7.
	f _ FileStream fileNamed: fileName.
	f binary.
	code _ Bitmap new: (len _ f size) // 4.
	f nextInto: code.
	remnant _ f next: len - (code size * 4).
	i _ 0.
	["Look for a BCTR instruction"
	(i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: [
		"Look for a CMPLWI cr1,rxx,FF, 7 instrs back"
	       ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r288000FF ifTrue: [
	       	"Copy dispatch instrs back over the compare"
			SelectionMenu notify: 'Patching at ', i hex.
			0 to: delta - 2 do: [ :j |
				code at: (i - delta) + j put: (code at: (i - delta) + j + 2).
			].
		].
	].
	f position: 0; nextPutAll: code; nextPutAll: remnant.
	f close! !

!Interpreter class methodsFor: 'translation' stamp: 'ar 5/26/2000 21:57'!
storeExports: exports on: aFilename
	| s |
	"Store the exports on the given file"
	s _ CrLfFileStream newFileNamed: aFilename.
	s nextPutAll:'/* This is an automatically generated table of all named primitive in the VM */'; cr;cr.

	s nextPutAll:'/* Function prototypes */'; cr.
	exports do:[:assoc|
		assoc value do:[:primName|
			s nextPutAll:'int '.
			assoc key size > 0 ifTrue:[
				s nextPutAll: assoc key; nextPutAll:'_'].
			s nextPutAll: primName; nextPutAll:'(void);'; cr.
		].
	].
	s nextPutAll:'/* extra (platform specific) prototypes */'; cr.
	s nextPutAll:'#define XFN(name) int name(void);'; cr.
	s nextPutAll:'#define XFN2(module, name) int module##_##name(void);'; cr.
	s nextPutAll:'#include "platform.exports"'; cr.
	s nextPutAll:'#undef XFN'; cr.
	s nextPutAll:'#undef XFN2'; cr.
	s cr; cr.

	s nextPutAll:'/* Function names */'; cr.
	s nextPutAll:'char *internalPrimitiveNames[][2] = {';cr.
	exports do:[:assoc|
		assoc value do:[:primName|
			s nextPutAll:'{ "'; nextPutAll: assoc key; nextPutAll:'", '.
			s nextPutAll:'"'; nextPutAll: primName; nextPutAll:'" },'; cr.
		].
	].
	s nextPutAll:'/* extra (platform specific) names */'; cr.
	s nextPutAll:'#define XFN(name) { "", #name },'; cr.
	s nextPutAll:'#define XFN2(module, name) { #module, #name },'; cr.
	s nextPutAll:'#include "platform.exports"'; cr.
	s nextPutAll:'#undef XFN'; cr.
	s nextPutAll:'#undef XFN2'; cr.
	s nextPutAll:'{ NULL, NULL }'; cr; nextPutAll:'};'.
	s cr; cr.

	s nextPutAll:'/* Function addresses */'; cr.
	s nextPutAll:'void *internalPrimitiveAddresses[] = {'; cr.
	exports do:[:assoc|
		assoc value do:[:primName|
			s nextPutAll:'(void*)'.
			assoc key size > 0 ifTrue:[
				s nextPutAll: assoc key; nextPutAll:'_'].
			s nextPutAll: primName; nextPutAll:','; cr.
		].
	].
	s nextPutAll:'/* extra (platform specific) addresses */'; cr.
	s nextPutAll:'#define XFN(name) (void*) name,'; cr.
	s nextPutAll:'#define XFN2(module, name) (void*) module##_##name,'; cr.
	s nextPutAll:'#include "platform.exports"'; cr.
	s nextPutAll:'#undef XFN'; cr.
	s nextPutAll:'#undef XFN2'; cr.
	s nextPutAll:'NULL'; cr; nextPutAll:'};'.
	s cr; cr.
	s close.! !

!Interpreter class methodsFor: 'translation' stamp: 'jm 5/30/2000 08:53'!
translate: fileName doInlining: inlineFlag
	"Time millisecondsToRun: [
		Interpreter translate: 'interp.c' doInlining: true.
		Smalltalk beep]"
	"Interpreter patchInterp: 'Squeak VM PPC'"

	self translate: fileName doInlining: inlineFlag forBrowserPlugin: false.
! !

!Interpreter class methodsFor: 'translation' stamp: 'ar 2/3/2001 18:20'!
translate: fileName doInlining: inlineFlag forBrowserPlugin: pluginFlag
	"Note: The pluginFlag is meaningless on Windows and Unix. On these platforms Squeak runs as it's own process and doesn't need any special attention from the VMs point of view. Meaning that NONE of the required additional functions will be supported. In other words, the pluginFlag is not needed and not supported."
	"Translate the Smalltalk description of the virtual machine into C. If inlineFlag is true,
small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. If pluginFlag is true, generate code for an interpreter that runs as a browser plugin (Netscape or IE)."

	| doInlining cg exports |
	doInlining _ inlineFlag.
	pluginFlag ifTrue: [doInlining _ true].  "must inline when generating browser plugin"
	Interpreter initialize.
	ObjectMemory initialize.
	GenerateBrowserPlugin _ pluginFlag.
	cg _ CCodeGenerator new initialize.
	cg addClass: Interpreter.
	cg addClass: ObjectMemory.
	Interpreter declareCVarsIn: cg.
	ObjectMemory declareCVarsIn: cg.
	"Get all the named prims from the VM.
	Note: the format of exports is:
		pluginName -> Array of: primitiveName.
	so we can generate a nice table from it."
	exports _ Array with: '' -> cg exportedPrimitiveNames asArray.
	cg storeCodeOnFile: fileName doInlining: doInlining.
	"Add our plugins"
	{
		"Graphics"
			"Note: BitBltSimulation should go first, 
			because three of it's entries might be 
			looked up quite often (due to refs from 
			InterpreterProxy). This will go away at
			some point but for now it's a good idea
			to have those entries early in the table."
		BitBltSimulation.	
		BalloonEnginePlugin. 
		SurfacePlugin. "To support OS surfaces through FXBlt"

		"I/O subsystems"
		FilePlugin.
		SocketPlugin.
		MIDIPlugin. 
		SerialPlugin. 
		JoystickTabletPlugin. 
		AsynchFilePlugin. 

		"Sound"
		SoundPlugin. 
		SoundGenerationPlugin.
		ADPCMCodecPlugin.
		KlattSynthesizerPlugin.
		SoundCodecPlugin.

	 	"Numerics"
		LargeIntegersPlugin.
		FFTPlugin. 
		FloatArrayPlugin. 
		Matrix2x3Plugin. 

		"Compression"
		DeflatePlugin.

		"Others"
		B3DEnginePlugin.
		DSAPlugin.
		DropPlugin. 
		MiscPrimitivePlugin.

		"Note: Optionally, you can translate the following as builtins.
		As of Squeak 2.7 they are not builtins by default:
			FFIPlugin.
		"
	} do:[:plugin|
		cg _ plugin translate: plugin moduleName, '.c'
					doInlining: doInlining
					locally: true.
		exports _ exports copyWith: 
			(plugin moduleName -> cg exportedPrimitiveNames asArray).
	].
	self storeExports: exports on: 'sqNamedPrims.h'.! !

!Interpreter class methodsFor: 'translation' stamp: 'ar 5/31/2000 21:20'!
translateForBrowserPlugin: fileName
	"NOTE: For other than Mac, see the comment in
		#translate:doInlining:forBrowserPlugin:
	"
	"Time millisecondsToRun: [
		Interpreter translateForBrowserPlugin: 'pluginInterp.c'.
		Smalltalk beep]"
	"Interpreter patchInterp: 'Squeak VM PPC'"

	self translate: fileName doInlining: true forBrowserPlugin: true.
! !
Object subclass: #InterpreterPlugin
	instanceVariableNames: 'interpreterProxy moduleName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!InterpreterPlugin methodsFor: 'initialize' stamp: 'ar 5/13/2000 02:00'!
getModuleName
	"Note: This is hardcoded so it can be run from Squeak.
	The module name is used for validating a module *after*
	it is loaded to check if it does really contain the module
	we're thinking it contains. This is important!!"
	self returnTypeC:'const char*'.
	self export: true.
	^moduleName! !

!InterpreterPlugin methodsFor: 'initialize' stamp: 'sma 3/3/2000 12:28'!
setInterpreter: anInterpreter 
	"Note: This is coded so that is can be run from Squeak."

	| ok |
	self export: true.
	self var: #anInterpreter type: #'struct VirtualMachine*'.
	interpreterProxy _ anInterpreter.
	ok _ self cCode: 'interpreterProxy->majorVersion() == VM_PROXY_MAJOR'.
	ok == false ifTrue: [^ false].
	ok _ self cCode: 'interpreterProxy->minorVersion() >= VM_PROXY_MINOR'.
	^ ok! !

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

InterpreterPlugin class
	instanceVariableNames: ''!

!InterpreterPlugin class methodsFor: 'accessing' stamp: 'RMF 3/27/2000 09:39'!
isCPP
	^ false! !

!InterpreterPlugin class methodsFor: 'accessing' stamp: 'sma 4/22/2000 12:32'!
moduleExtension
	^ self isCPP ifTrue: ['.cpp'] ifFalse: ['.c']! !

!InterpreterPlugin class methodsFor: 'accessing' stamp: 'sma 3/3/2000 12:24'!
moduleName
	"Answer the receiver's module name that is used for the plugin's C code."

	^ self name asString! !

!InterpreterPlugin class methodsFor: 'accessing' stamp: 'TPR 5/23/2000 15:33'!
moduleNameAndVersion
	"Answer the receiver's module name and version info that is used for the plugin's C code. The default is to append the code generation date, but any useful text is ok (keep it short)"

	^ self moduleName, Character space asString, Date today asString! !

!InterpreterPlugin class methodsFor: 'accessing' stamp: 'sma 3/3/2000 12:24'!
simulatorClass
	"For running from Smalltalk - answer a class that can be used to 
	simulate the receiver. By default every plugin can simulate itself."

	^ self! !


!InterpreterPlugin class methodsFor: 'class initialization' stamp: 'ar 9/16/1998 20:26'!
initialize
	"Nothing to do ..."! !


!InterpreterPlugin class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 12:26'!
doPrimitive: primitiveName 
	| proxy plugin |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	plugin _ self simulatorClass new.
	plugin setInterpreter: proxy.
	plugin perform: primitiveName asSymbol.
	^ proxy stackValue: 0! !


!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/12/2000 00:24'!
baseDirectoryName
	"Return the directory into which plugins should be generated by default."
	^FileDirectory default pathName! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/12/2000 00:34'!
declareCVarsIn: aCCodeGenerator
	"Note: This method must be implemented by all subclasses to declare variables."

	aCCodeGenerator 
		var: #interpreterProxy 
		type: #'struct VirtualMachine*'.
	self declareHeaderFilesIn: aCCodeGenerator.! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:25'!
declareHeaderFilesIn: aCCodeGenerator
	self headerFile ifNotNil:[
		aCCodeGenerator addHeaderFile: '"', self moduleName,'.h"'].! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:28'!
headerFile
	"If there is a single intrinsic header file to be associated with the plugin, here is where you want to put it. It will be generated and included automatically."
	^nil! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 16:56'!
storeString: s onFileNamed: fileName
	"Store the given string in a file of the given name."

	| f |
	f _ CrLfFileStream newFileNamed: fileName.
	f nextPutAll: s.
	f close.! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:23'!
translate
	"Translate the receiver as plugin with inlining using its default name."

	^ self translateDoInlining: true! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'TPR 2/29/2000 18:55'!
translate: fileName all: classes doInlining: inlineFlag
	"Time millisecondsToRun: [
		InterpreterPlugin translate:'all.c' all:{FloatArrayPlugin. FFTPlugin} doInlining: true.
		Smalltalk beep]"
	| cg theClass |
	cg _ self codeGeneratorClass new initialize.
	classes do:[:cls|
		theClass _ cls.
		theClass initialize.
		[theClass == InterpreterPlugin] whileFalse:[
			cg addClass: theClass.
			theClass declareCVarsIn: cg.
			theClass _ theClass superclass]].
	(classes includes: InterpreterPlugin) ifFalse:[
		cg addClass: InterpreterPlugin.
		InterpreterPlugin declareCVarsIn: cg].
	cg storeCodeOnFile: fileName doInlining: inlineFlag.! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:30'!
translate: fileName doInlining: inlineFlag
	"Time millisecondsToRun: [
		FloatArrayPlugin translate: 'SqFloatArray.c' doInlining: true.
		Smalltalk beep]"
	^self translate: fileName doInlining: inlineFlag locally: false.! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 15:44'!
translate: fileName doInlining: inlineFlag locally: localFlag
	"Time millisecondsToRun: [
		FloatArrayPlugin translate: 'SqFloatArray.c' doInlining: true.
		Smalltalk beep]"
	| cg fullName fd |
	fullName _ self baseDirectoryName.
	fd _ FileDirectory on: fullName.
	localFlag ifFalse:[
		(fd directoryExists: self moduleName) 
			ifFalse:[fd createDirectory: self moduleName].
		fd _ fd on: (fd fullNameFor: self moduleName)].
	fullName _ fd fullNameFor: fileName.
	self initialize.
	self headerFile ifNotNil:[
		(CrLfFileStream newFileNamed: (fd fullNameFor: self moduleName,'.h'))
			nextPutAll: self headerFile;
			close].
	cg _ self codeGeneratorClass new initialize.
	localFlag ifTrue:[cg pluginPrefix: self moduleName].
	"Add an extra declaration for module name"
	cg declareModuleName: self moduleNameAndVersion local: localFlag.
	self translateOn: cg inlining: inlineFlag to: fullName local: localFlag.
	^cg! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'sma 4/22/2000 12:32'!
translateDoInlining: inlineFlag 
	"Time millisecondsToRun: [ 
		FloatArrayPlugin translateDoInlining: true. 
		Smalltalk beep]"

	^ self translate: self moduleName , self moduleExtension doInlining: inlineFlag! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 2/20/2000 23:28'!
translateLocally
	^self translate: (self moduleName,'.c') doInlining: true locally: true! !

!InterpreterPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 15:44'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"do the actual translation"
	| theClass |
	theClass _ self.
	[theClass == Object] whileFalse:[
		cg addClass: theClass.
		theClass declareCVarsIn: cg.
		theClass _ theClass superclass].
	cg storeCodeOnFile: fullName doInlining: inlineFlag.
! !


!InterpreterPlugin class methodsFor: 'private' stamp: 'TPR 2/29/2000 18:54'!
codeGeneratorClass
	"return the appropriate class of code generator for this kind ofplugin"

	^PluggableCodeGenerator! !
Object subclass: #InterpreterProxy
	instanceVariableNames: 'successFlag remapBuffer stack method argumentCount bb '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!InterpreterProxy methodsFor: 'initialize' stamp: 'ar 9/16/1998 01:35'!
initialize
	successFlag _ true.
	remapBuffer _ OrderedCollection new.
	stack _ OrderedCollection new.! !

!InterpreterProxy methodsFor: 'initialize' stamp: 'ar 10/3/1998 18:50'!
loadStackFrom: aContext
	self push: aContext receiver.
	method _ aContext method.
	argumentCount _ method numArgs.
	1 to: argumentCount do:[:i| self push: (aContext at: i) ].! !


!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:41'!
pop: nItems
	1 to: nItems do:[:i| stack removeLast].! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:41'!
pop: nItems thenPush: oop
	self pop: nItems.
	self push: oop.! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 01:42'!
push: object
	stack addLast: object! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 10/10/1998 21:16'!
pushBool: trueOrFalse
	(trueOrFalse == true or:[trueOrFalse == false]) ifFalse:[self error:'Not a Boolean'].
	self push: trueOrFalse! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 10/10/1998 21:16'!
pushFloat: f
	self var: #f declareC: 'double f'.
	f class == Float ifFalse:[^self error:'Not a Float'].
	self push: f.! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 10/10/1998 21:20'!
pushInteger: integerValue
	self push: (self integerObjectOf: integerValue).! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/27/1998 15:22'!
stackFloatValue: offset
	| oop |
	self returnTypeC: 'double'.
	oop _ self stackValue: offset.
	(self isFloatObject: oop) ifFalse: [self primitiveFail. ^0.0].
	^oop! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 22:07'!
stackIntegerValue: offset
	| oop |
	oop _ self stackValue: offset.
	(self isIntegerObject: oop) ifFalse: [self primitiveFail. ^0].
	^oop! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 22:07'!
stackObjectValue: offset
	| oop |
	oop _ self stackValue: offset.
	(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
	^oop! !

!InterpreterProxy methodsFor: 'stack access' stamp: 'ar 9/16/1998 11:47'!
stackValue: offset
	^stack at: stack size - offset.! !


!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:40'!
argumentCountOf: methodPointer
	^methodPointer numArgs! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/11/1998 03:01'!
arrayValueOf: oop
	self returnTypeC: 'void *'.
	self success: (self isWordsOrBytes: oop).
	^CArrayAccessor on: oop.! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:23'!
byteSizeOf: oop
	"Return the size of the receiver in bytes"
	^oop class isBytes
		ifTrue:[(self slotSizeOf: oop)]
		ifFalse:[(self slotSizeOf: oop) * 4]! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 21:22'!
fetchArray: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object."
	"Note: May be called by translated primitive code."

	| arrayOop |
	self returnTypeC: 'void *'.
	arrayOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self arrayValueOf: arrayOop
! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:07'!
fetchClassOf: oop
	^oop class! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 21:21'!
fetchFloat: fieldIndex ofObject: objectPointer
	"Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float."
	"Note: May be called by translated primitive code."

	| floatOop |
	self returnTypeC: 'double'.
	floatOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	^ self floatValueOf: floatOop! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 21:19'!
fetchInteger: fieldIndex ofObject: objectPointer
	"Note: May be called by translated primitive code."

	| intOop |
	self inline: false.
	intOop _ self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOop)
		ifTrue: [ ^ self integerValueOf: intOop ]
		ifFalse: [ self primitiveFail. ^ 0 ]! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 16:04'!
fetchPointer: index ofObject: oop
	^oop instVarAt: index+1! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 16:04'!
fetchWord: fieldIndex ofObject: oop
	^oop instVarAt: fieldIndex+1! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/18/1998 20:26'!
firstFixedField: oop
	self returnTypeC:'void *'.
	^CObjectAccessor on: oop! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 16:22'!
firstIndexableField: oop
	self returnTypeC:'void *'.
	^CArrayAccessor on: oop! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:38'!
literal: offset ofMethod: methodPointer
	^methodPointer literals at: offset+1! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:40'!
literalCountOf: methodPointer
	^methodPointer numLiterals! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:43'!
methodArgumentCount
	^argumentCount! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:43'!
methodPrimitiveIndex
	^method primitive! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:39'!
primitiveIndexOf: methodPointer
	^methodPointer primitive! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 11/28/1999 17:43'!
primitiveMethod
	"Return the method an external primitive was defined in"
	^method! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 19:03'!
sizeOfSTArrayFromCPrimitive: cPtr
	"Note: Only called by translated primitive code."
	self var: #cPtr declareC: 'void *cPtr'.
	^self shouldNotImplement! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:24'!
slotSizeOf: oop
	"Returns the number of slots in the receiver.
	If the receiver is a byte object, return the number of bytes.
	Otherwise return the number of words."
	^(oop basicSize) + (oop class instSize)! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:53'!
stObject: array at: index
	^array at: index! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 9/16/1998 01:53'!
stObject: array at: index put: value
	^array at: index put: value! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/7/1998 18:26'!
stSizeOf: oop
	"Return the number of indexable fields in the receiver"
	^oop basicSize! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/25/1998 16:16'!
storeInteger: index ofObject: oop withValue: integer
	(self isIntegerValue: integer) 
		ifTrue:[^self storePointer: index ofObject: oop withValue: integer]
		ifFalse:[^self primitiveFail]! !

!InterpreterProxy methodsFor: 'object access' stamp: 'ar 10/10/1998 21:25'!
storePointer: index ofObject: oop withValue: valuePointer
	^oop instVarAt: index+1 put: valuePointer! !


!InterpreterProxy methodsFor: 'testing' stamp: 'ar 11/17/1999 22:04'!
includesBehavior: aClass ThatOf: aSuperclass
	^aClass includesBehavior: aSuperclass! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/19/1998 14:00'!
is: oop KindOf: aString
	"InterpreterProxy new is: 42 KindOf: 'Number'"
	| theClass |
	self var: #aString declareC:'char *aString'.
	theClass _ Smalltalk at: aString asSymbol ifAbsent:[nil].
	^theClass isNil
		ifTrue:[false]
		ifFalse:[^oop isKindOf: theClass]! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/19/1998 14:01'!
is: oop MemberOf: aString
	"InterpreterProxy new is: 42 MemberOf:'SmallInteger'"
	| theClass |
	self var: #aString declareC:'char *aString'.
	theClass _ Smalltalk at: aString asSymbol ifAbsent:[nil].
	^theClass isNil
		ifTrue:[false]
		ifFalse:[^oop isMemberOf: theClass]! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:04'!
isBytes: oop
	^oop class isBytes! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 21:44'!
isFloatObject: oop
	^oop class == Float! !

!InterpreterProxy methodsFor: 'testing' stamp: 'acg 9/19/1999 13:11'!
isIndexable: oop
	^oop class isVariable! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:12'!
isIntegerObject: objectPointer
	^objectPointer class == SmallInteger! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:13'!
isIntegerValue: intValue
	^intValue class == SmallInteger! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:04'!
isPointers: oop
	^oop class isPointers! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:16'!
isWeak: oop
	^oop class isWeak! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 10/9/1998 22:19'!
isWords: oop
	^oop class isPointers not and:[oop class isBytes not]! !

!InterpreterProxy methodsFor: 'testing' stamp: 'ar 9/16/1998 01:05'!
isWordsOrBytes: oop
	^(self isBytes: oop) or:[self isWords: oop]! !


!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 21:27'!
booleanValueOf: obj
	obj == true ifTrue:[^true].
	obj == false ifTrue:[^false].
	self primitiveFail.
	^nil! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/4/1998 15:47'!
checkedIntegerValueOf: intOop
	(self isIntegerObject: intOop)
		ifTrue:[^self integerValueOf: intOop]
		ifFalse:[self primitiveFail. ^0].! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:08'!
floatObjectOf: aFloat
	self var: #aFloat declareC: 'double aFloat'.
	aFloat class == Float ifFalse:[self error:'Not a float object'].
	^aFloat! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:09'!
floatValueOf: oop
	self returnTypeC:'double'.
	oop class == Float
		ifTrue:[^oop]
		ifFalse:[self primitiveFail. ^0.0].! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:13'!
integerObjectOf: value
	value class == SmallInteger ifFalse:[self error:'Not a SmallInteger object'].
	^value! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:10'!
integerValueOf: oop
	oop class == SmallInteger ifFalse:[self error:'Not a SmallInteger'].
	^oop! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:11'!
positive32BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue > 0
		ifTrue:[integerValue]
		ifFalse:[ (1 bitShift: 32) + integerValue]! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 10/10/1998 16:12'!
positive32BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	oop < 0 
		ifTrue:[self primitiveFail. ^0]
		ifFalse:[^oop]! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 11/29/1999 22:01'!
signed32BitIntegerFor: integerValue
	integerValue isInteger ifFalse:[self error:'Not an Integer object'].
	^integerValue! !

!InterpreterProxy methodsFor: 'converting' stamp: 'ar 11/29/1999 22:00'!
signed32BitValueOf: oop
	oop isInteger ifFalse:[self error:'Not an integer object'].
	^oop! !


!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 21:43'!
characterTable
	^Character characterTable! !

!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 21:42'!
displayObject
	^Display! !

!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:40'!
falseObject
	^false! !

!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:40'!
nilObject
	^nil! !

!InterpreterProxy methodsFor: 'special objects' stamp: 'ar 9/16/1998 20:41'!
trueObject
	^true! !


!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:42'!
classArray
	^Array! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classBitmap
	^Bitmap! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classByteArray
	^ByteArray! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classCharacter
	^Character! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classFloat
	^Float! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 11/19/1999 14:29'!
classLargeNegativeInteger
	^LargeNegativeInteger! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classLargePositiveInteger
	^LargePositiveInteger! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classPoint
	^Point! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classSemaphore
	^Semaphore! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 21:43'!
classSmallInteger
	^SmallInteger! !

!InterpreterProxy methodsFor: 'special classes' stamp: 'ar 9/16/1998 20:43'!
classString
	^String! !


!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/18/1998 20:11'!
clone: oop
	^oop clone! !

!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:11'!
instantiateClass: classPointer indexableSize: size
	^size = 0 
		ifTrue:[classPointer basicNew]
		ifFalse:[classPointer basicNew: size]! !

!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 10/10/1998 16:14'!
makePointwithxValue: xValue yValue: yValue
	(xValue class == SmallInteger and:[yValue class == SmallInteger]) 
		ifFalse:[self error:'Not SmallInteger objects'].
	^xValue@yValue! !

!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:14'!
popRemappableOop
	^remapBuffer removeLast! !

!InterpreterProxy methodsFor: 'instance creation' stamp: 'ar 9/16/1998 01:14'!
pushRemappableOop: oop
	remapBuffer addLast: oop! !


!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
become: array1 with: array2
	array1 elementsExchangeIdentityWith: array2! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
byteSwapped: w
	"Return the given integer with its bytes in the reverse order."

	^ ((w bitShift: -24) bitAnd: 16rFF) +
	  ((w bitShift: -8) bitAnd: 16rFF00) +
	  ((w bitShift: 8) bitAnd: 16rFF0000) +
	  ((w bitShift: 24) bitAnd: 16rFF000000)
! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
failed
	^successFlag not! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
fullDisplayUpdate
	Display display! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
fullGC
	Smalltalk garbageCollect.! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
incrementalGC
	Smalltalk garbageCollectMost.! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 5/13/2000 14:55'!
ioMicroMSecs
	^Time millisecondClockValue! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
primitiveFail
	(self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt].
	successFlag _ false.! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:52'!
showDisplayBits: aForm Left: l Top: t Right: r Bottom: b
	aForm == Display ifTrue:[
		Display forceToScreen: (Rectangle left: l right: r top: t bottom: b)].! !

!InterpreterProxy methodsFor: 'other' stamp: 'JMM 6/6/2000 21:00'!
signalSemaphoreWithIndex: semaIndex
	((Smalltalk externalObjects) at: semaIndex) signal! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/19/1998 13:30'!
success: aBoolean
	successFlag not ifTrue:[^self].
	successFlag _ successFlag and:[aBoolean].
	successFlag not ifTrue:[
		(self confirm:'A primitive is failing -- Stop simulation?') ifTrue:[self halt]].! !

!InterpreterProxy methodsFor: 'other' stamp: 'ar 9/16/1998 20:51'!
superclassOf: classPointer
	^classPointer superclass! !


!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
byteAt: accessor
	^accessor byteAt: 0! !

!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:12'!
byteAt: accessor put: value
	^accessor byteAt: 0 put: value! !

!InterpreterProxy methodsFor: 'private' stamp: 'ar 10/27/1999 14:13'!
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
	"Support for BitBlt simulation only"
	| intOrFloat |
	intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer.
	(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
	intOrFloat isFloat ifTrue:[^intOrFloat truncated].
	^self primitiveFail.! !

!InterpreterProxy methodsFor: 'private' stamp: 'ar 10/27/1999 14:21'!
isInterpreterProxy
	"Return true since I am not a real Interpreter simulation"
	^true! !

!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
longAt: accessor
	^accessor longAt: 0! !

!InterpreterProxy methodsFor: 'private' stamp: 'ar 9/18/1998 21:11'!
longAt: accessor put: value
	^accessor longAt: 0 put: value! !


!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
copyBits
	bb copyBits.! !

!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
copyBitsFrom: leftX to: rightX at: yValue
	bb copyBitsFrom: leftX to: rightX at: yValue.! !

!InterpreterProxy methodsFor: 'BitBlt support' stamp: 'ar 4/12/1999 23:29'!
loadBitBltFrom: bbOop
	bb _ bbOop.! !


!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalAddress
	^Smalltalk at: #ExternalAddress ifAbsent:[nil]! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalData
	^Smalltalk at: #ExternalData ifAbsent:[nil]! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:03'!
classExternalFunction
	^Smalltalk at: #ExternalFunction ifAbsent:[nil]! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:04'!
classExternalLibrary
	^Smalltalk at: #ExternalLibrary ifAbsent:[nil]! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/29/1999 22:04'!
classExternalStructure
	^Smalltalk at: #ExternalStructure ifAbsent:[nil]! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 5/11/2000 20:05'!
ioLoadFunction: functionName From: moduleName
	"Dummy - provided by support code"
	^0! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 18:33'!
ioLoadModule: moduleNameIndex OfLength: moduleLength
	"Dummy - provided by support code"
	^0! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 18:34'!
ioLoadSymbol: functionNameIndex OfLength: functionLength FromModule: moduleHandle
	"Dummy - provided by support code"
	^0! !

!InterpreterProxy methodsFor: 'FFI support' stamp: 'ar 11/28/1999 19:04'!
isInMemory: address
	"Return true if the given address is in ST object memory"
	^true! !

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

InterpreterProxy class
	instanceVariableNames: ''!

!InterpreterProxy class methodsFor: 'instance creation' stamp: 'ar 9/16/1998 00:23'!
new
	^super new initialize! !


!InterpreterProxy class methodsFor: 'private' stamp: 'ar 10/7/1998 18:45'!
generateVMProxyOn: fileName
	| cg proxyClass catList |
	proxyClass _ InterpreterProxy.
	cg _ PluggableCodeGenerator new initialize.
	cg addClass: proxyClass.
	catList _ proxyClass organization categories copy asOrderedCollection.
	catList remove: 'initialize' ifAbsent:[].
	catList remove: 'private' ifAbsent:[].
	catList _ catList collect:[:cat| cat -> (proxyClass organization listAtCategoryNamed: cat)].
	cg storeVirtualMachineProxyHeader: catList on: (fileName,'.h').
	cg storeVirtualMachineProxyImplementation: catList on: (fileName,'.c').

	"InterpreterProxy generateVMProxyOn:'sqVirtualMachine'"
! !

!InterpreterProxy class methodsFor: 'private' stamp: 'di 12/6/1999 12:40'!
validateProxyImplementation: anInterpreter 
	"InterpreterProxy validateProxyImplementation: Interpreter"
	"InterpreterProxy validateProxyImplementation: DynamicInterpreter"
	| proxyClass catList |
	proxyClass _ InterpreterProxy.
	catList _ proxyClass organization categories copy asOrderedCollection.
	catList remove: 'initialize' ifAbsent:[].
	catList remove: 'private' ifAbsent:[].
	catList do:[:categ|
		(proxyClass organization listAtCategoryNamed: categ) do:[:selector|
			(anInterpreter canUnderstand: selector) 
				ifFalse:[self notify: selector, ' is not implemented in ', anInterpreter name]]].! !
Interpreter subclass: #InterpreterSimulator
	instanceVariableNames: 'byteCount sendCount traceOn myBitBlt displayForm filesOpen imageName pluginList mappedPluginEntries '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!InterpreterSimulator commentStamp: '<historical>' prior: 0!
This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment.  It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.

To see the thing actually run, you could (after backing up this image and changes), execute

	(InterpreterSimulator new openOn: Smalltalk imageName) test

and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be.  We usually do this with a small and simple benchmark image.!


!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 11/23/1998 16:46'!
close  "close any files that ST may have opened"
	filesOpen do: [:f | f close]! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'ar 2/2/2001 16:31'!
initialize
	"Initialize the InterpreterSimulator when running the interpreter inside
	Smalltalk. The primary responsibility of this method is to allocate
	Smalltalk Arrays for variables that will be declared as statically-allocated
	global arrays in the translated code."

	"initialize class variables"
	ObjectMemory initialize.
	Interpreter initialize.

	methodCache _ Array new: MethodCacheSize.
	atCache _ Array new: AtCacheTotalSize.
	rootTable _ Array new: RootTableSize.
	remapBuffer _ Array new: RemapBufferSize.
	semaphoresUseBufferA _ true.
	semaphoresToSignalA _ Array new: SemaphoresToSignalSize.
	semaphoresToSignalB _ Array new: SemaphoresToSignalSize.
	externalPrimitiveTable _ CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize size).

	obsoleteNamedPrimitiveTable _ 
		CArrayAccessor on: self class obsoleteNamedPrimitiveTable.
	obsoleteIndexedPrimitiveTable _ CArrayAccessor on: 
		(self class obsoleteIndexedPrimitiveTable collect:[:spec| 
			CArrayAccessor on:
				(spec ifNil:[Array new: 3] 
					  ifNotNil:[Array with: spec first with: spec second with: nil])]).
	pluginList _ #().
	mappedPluginEntries _ #().

	"initialize InterpreterSimulator variables used for debugging"
	byteCount _ 0.
	sendCount _ 0.
	traceOn _ true.
	myBitBlt _ BitBltSimulator new setInterpreter: self.
	displayForm _ nil.  "displayForm is created in response to primitiveBeDisplay"
	filesOpen _ OrderedCollection new.
! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'th 4/15/2000 17:19'!
nextLongFrom: aStream
	"Read a 32-bit quantity from the given (binary) stream."
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 9/23/97 15:51'!
nextLongFrom: aStream swap: swapFlag
	swapFlag 
		ifTrue: [^ self byteSwapped: (self nextLongFrom: aStream)]
		ifFalse: [^ self nextLongFrom: aStream]! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'ar 5/17/2000 23:20'!
openOn: fileName
	"(InterpreterSimulator new openOn: 'clonex.image') test"

	self openOn: fileName extraMemory: 500000.! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'mdr 9/4/2000 10:43'!
openOn: fileName extraMemory: extraBytes
	"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"

	| f version headerSize count oldBaseAddr bytesToShift swapBytes |
	"open image file and read the header"
	f _ FileStream readOnlyFileNamed: fileName.
	imageName _ f fullName.
	f binary.
	version _ self nextLongFrom: f.  "current version: 16r1966 (=6502)"
	(self readableFormat: version)
		ifTrue: [swapBytes _ false]
		ifFalse: [(version _ self byteSwapped: version) = self imageFormatVersion
					ifTrue: [swapBytes _ true]
					ifFalse: [self error: 'incomaptible image format']].
	headerSize _ self nextLongFrom: f swap: swapBytes.
	endOfMemory _ self nextLongFrom: f swap: swapBytes.  "first unused location in heap"
	oldBaseAddr _ self nextLongFrom: f swap: swapBytes.  "object memory base address of image"
	specialObjectsOop _ self nextLongFrom: f swap: swapBytes.
	lastHash _ self nextLongFrom: f swap: swapBytes.  "Should be loaded from, and saved to the image header"
	savedWindowSize _ self nextLongFrom: f swap: swapBytes.
	lastHash = 0 ifTrue: [lastHash _ 999].

	"allocate interpreter memory"
	memoryLimit _ endOfMemory + extraBytes.

	"read in the image in bulk, then swap the bytes if necessary"
	f position: headerSize.
	memory _ Bitmap new: memoryLimit // 4.
	count _ f readInto: memory startingAt: 1 count: endOfMemory // 4.
	count ~= (endOfMemory // 4) ifTrue: [self halt].
	f close.
	swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'
								during: [self reverseBytesInImage]].

	self initialize.
	bytesToShift _ 0 - oldBaseAddr.  "adjust pointers for zero base address"
	endOfMemory _ endOfMemory.
	Utilities informUser: 'Relocating object pointers...'
				during: [self initializeInterpreter: bytesToShift].
! !

!InterpreterSimulator methodsFor: 'initialization' stamp: 'di 10/2/97 00:32'!
reverseBytesFrom: begin to: end
	"Byte-swap the given range of memory (not inclusive!!)."
	| wordAddr |
	wordAddr _ begin.
	memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4! !

!InterpreterSimulator methodsFor: 'initialization'!
startOfMemory
	"Return the start of object memory."

	^ 0! !


!InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:06'!
findNewMethodInClass: class
"
	| cName |
	traceOn ifTrue:
		[cName _ (self sizeBitsOf: class) = 16r20
			ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))]
			ifFalse: [(self nameOfClass: class)].
		self cr; print: cName , '>>' , (self stringOf: messageSelector)].
"

(self stringOf: messageSelector) = 'doesNotUnderstand:' ifTrue: [self halt].

	sendCount _ sendCount + 1.

"
	(sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue:
		[Transcript print: sendCount; space.
		self validate].
"
"
	(sendCount > 100150) ifTrue:
		[self qvalidate.
		messageQueue == nil ifTrue: [messageQueue _ OrderedCollection new].
		messageQueue addLast: (self stringOf: messageSelector)].
"
	super findNewMethodInClass: class.! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'ar 10/27/1999 14:21'!
isInterpreterProxy
	"Return false since I am a real Interpreter simulation"
	^false! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 10/1/97 23:36'!
objectBefore: addr
	| oop prev |
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue: [
		prev _ oop.  "look here if debugging prev obj overlapping this one"
		oop _ self objectAfter: oop.
		oop >= addr ifTrue: [^ prev]
	]! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 11/29/2000 10:26'!
profile: nBytecodes
	"(InterpreterSimulator new openOn: 'clonex.image') profile: 60000"
	Transcript clear.
	byteCount _ 0.
	MessageTally spyOn: [self runForNBytes: nBytecodes].
	self close! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 11/29/2000 10:25'!
profileSends: nBytecodes
	"(InterpreterSimulator new openOn: 'clonex.image') profileSends: 5000"
	MessageTally tallySendsTo: self
		inBlock: [self runForNBytes: nBytecodes]
		showTree: true.
	self close! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 11/29/2000 10:24'!
runForNBytes: nBytecodes
	byteCount _ 0.
	self internalizeIPandSP.
	self fetchNextBytecode.
	[byteCount < nBytecodes] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount _ byteCount + 1].
	self externalizeIPandSP.
! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/22/1998 23:24'!
stackDepth
	| ctxt n |
	ctxt _ activeContext.
	n _ 0.
	[(ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
		whileFalse: [n _ n+1].
	^ n! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 2/13/98 10:40'!
stats
	| oop fieldAddr fieldOop last stats v d |
	stats _ Bag new.
	oop _ self firstObject.

'Scanning the image...' displayProgressAt: Sensor cursorPoint
	from: oop to: endOfMemory
	during: [:bar |

	[oop < endOfMemory] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[stats add: #objects.
			fieldAddr _ oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop _ self longAt: fieldAddr.
				(self isIntegerObject: fieldOop)
					ifTrue: [v _ self integerValueOf: fieldOop.
							(v between: -16000 and: 16000)
								ifTrue: [stats add: #ints32k]
								ifFalse: [stats add: #intsOther]]
					ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
							ifFalse:
							[d _ fieldOop - oop.
							(d between: -16000 and: 16000)
								ifTrue: [stats add: #oops32k]
								ifFalse: [stats add: #oopsOther]]].
				fieldAddr _ fieldAddr - 4]].
		bar value: oop.
		last _ oop.
		last _ last.
		oop _ self objectAfter: oop]].
	^ stats sortedElements! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:17'!
test
	Transcript clear.
	byteCount _ 0.
	self internalizeIPandSP.
	self fetchNextBytecode.
	[true] whileTrue:
		[self dispatchOn: currentBytecode in: BytecodeTable.
		byteCount _ byteCount + 1].
	self externalizeIPandSP.
! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 1/9/1999 15:31'!
testBecome
	"Become some young things.  AA testBecome    "
	| array list1 list2 p1 p2 p3 p4 |
	array _ self splObj: ClassArray.
	list1 _ self instantiateClass: array indexableSize: 2.
	list2 _ self instantiateClass: array indexableSize: 2.
	p1 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
	self push: p1.
	self storePointer: 0 ofObject: list1 withValue: p1.
	p2 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0.
	self push: p2.
	self storePointer: 1 ofObject: list1 withValue: p2.
	p3 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	self push: p3.
	self storePointer: 0 ofObject: list2 withValue: p3.
	p4 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
	self push: p4.
	self storePointer: 1 ofObject: list2 withValue: p4.
	(self become: list1 with: list2 twoWay: true) ifFalse: [self error: 'failed'].
	self popStack = p2 ifFalse: [self halt].
	self popStack = p1 ifFalse: [self halt].
	self popStack = p4 ifFalse: [self halt].
	self popStack = p3 ifFalse: [self halt].
	(self fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt].
	(self fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt].
	(self fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt].
	(self fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 4/3/1999 15:45'!
validOop: oop
	" Return true if oop appears to be valid "
	(oop bitAnd: 1) = 1 ifTrue: [^ true].  "Integer"
	(oop bitAnd: 3) = 0 ifFalse: [^ false].  "Uneven address"
	oop >= endOfMemory ifTrue: [^ false].  "Out of range"
	"could test if within the first large freeblock"
	(self longAt: oop) = 4 ifTrue: [^ false].
	(self headerType: oop) = 2 ifTrue: [^ false].	"Free object"
	^ true! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'jm 9/24/97 22:52'!
validate
	| oop prev |
	Transcript show: 'Validating...'.
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue: [
		self validate: oop.
		prev _ oop.  "look here if debugging prev obj overlapping this one"
		oop _ self objectAfter: oop.
	].
	Transcript show: 'done.'; cr! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'tk 9/21/1999 12:19'!
validate: oop
	| header type cc sz fmt nextChunk | 
	header _ self longAt: oop.
	type _ header bitAnd: 3.
	type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
	sz _ (header >> 2) bitAnd: 16r3F.
	(self isFreeObject: oop)
		ifTrue: [ nextChunk _ oop + (self sizeOfFree: oop) ]
		ifFalse: [  nextChunk _ oop + (self sizeBitsOf: oop) ].
	nextChunk > endOfMemory
		ifTrue: [oop = endOfMemory ifFalse: [self halt]].
	(self headerType: nextChunk) = 0 ifTrue: [
		(self headerType: (nextChunk + 8)) = 0 ifFalse: [self halt]].
	(self headerType: nextChunk) = 1 ifTrue: [
		(self headerType: (nextChunk + 4)) = 1 ifFalse: [self halt]].
	type = 2 ifTrue:
		["free block" ^ self].
	fmt _ (header >> 8) bitAnd: 16rF.
	cc _ (header >> 12) bitAnd: 31.
	cc > 16 ifTrue: [self halt].	"up to 32 are legal, but not used"
	type = 0 ifTrue:
		["three-word header"
		((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop-8) bitAnd: 3) = type ifFalse: [self halt].
		((self longAt: oop-4) = type) ifTrue: [self halt].	"Class word is 0"
		sz = 0 ifFalse: [self halt]].
	type = 1 ifTrue:
		["two-word header"
		((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt].
		cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
		sz = 0 ifTrue: [self halt]].
	type = 3 ifTrue:
		["one-word header"
		cc = 0 ifTrue: [self halt]].
	fmt = 5 ifTrue: [self halt].
	fmt = 7 ifTrue: [self halt].
	fmt >= 12 ifTrue:
		["CompiledMethod -- check for integer header"
		(self isIntegerObject: (self longAt: oop + 4)) ifFalse: [self halt]].! !

!InterpreterSimulator methodsFor: 'testing'!
validateActiveContext
	self validateOopsIn: activeContext.	"debug -- test if messed up"! !

!InterpreterSimulator methodsFor: 'testing' stamp: 'di 4/3/1999 15:46'!
validateOopsIn: object
	| fieldPtr limit former header | 
	"for each oop in me see if it is legal"
	fieldPtr _ object + BaseHeaderSize.	"first field"
	limit _ object + (self lastPointerOf: object).	"a good field"
	[fieldPtr > limit] whileFalse: [
		former _ self longAt: fieldPtr.
		(self validOop: former) ifFalse: [self halt].
		fieldPtr _ fieldPtr + 4].
	"class"
	header _ self baseHeader: object.
	(header bitAnd: CompactClassMask) = 0 ifTrue: [	
		former _ (self classHeader: object) bitAnd: AllButTypeMask.
		(self validOop: former) ifFalse: [self halt]].! !


!InterpreterSimulator methodsFor: 'debug printing'!
cr

	traceOn ifTrue: [ Transcript cr; endEntry ].! !

!InterpreterSimulator methodsFor: 'debug printing'!
print: s

	traceOn ifTrue: [ Transcript show: s ]! !

!InterpreterSimulator methodsFor: 'debug printing'!
printChar: aByte

	traceOn ifTrue: [ Transcript nextPut: aByte asCharacter ].! !

!InterpreterSimulator methodsFor: 'debug printing'!
printNum: anInteger

	traceOn ifTrue: [ Transcript show: anInteger printString ].! !


!InterpreterSimulator methodsFor: 'debug support' stamp: 'th 4/15/2000 17:22'!
charsOfLong: long
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'debug support'!
classAndSelectorOfMethod: meth forReceiver: rcvr
	| mClass dict length methodArray |
	mClass _ self fetchClassOf: rcvr.
	[dict _ self fetchPointer: MessageDictionaryIndex ofObject: mClass.
	length _ self fetchWordLengthOf: dict.
	methodArray _ self fetchPointer: MethodArrayIndex ofObject: dict.
	0 to: length-SelectorStart-1 do: 
		[:index | 
		meth = (self fetchPointer: index ofObject: methodArray) 
			ifTrue: [^ Array
				with: mClass
				with: (self fetchPointer: index + SelectorStart ofObject: dict)]].
	mClass _ self fetchPointer: SuperclassIndex ofObject: mClass.
	mClass = nilObj]
		whileFalse: [].
	^ Array
		with: (self fetchClassOf: rcvr)
		with: (self splObj: SelectorDoesNotUnderstand)! !

!InterpreterSimulator methodsFor: 'debug support'!
compactClassAt: ccIndex
	"Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"

	| classArray |
	classArray _ self fetchPointer: CompactClasses ofObject: specialObjectsOop.
	^ self fetchPointer: (ccIndex - 1) ofObject: classArray! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 11/23/1998 22:44'!
dumpHeader: hdr
	| cc |
	^ String streamContents: [:strm |
		cc _ (hdr bitAnd: CompactClassMask) >> 12.
		strm nextPutAll: '<cc=', cc hex.
		cc > 0 ifTrue:
			[strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))].
		strm nextPutAll: '>'.
		strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'.
		strm nextPutAll: '<sz=', (hdr bitAnd: SizeMask) hex , '>'.
		strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>']
! !

!InterpreterSimulator methodsFor: 'debug support'!
dumpMethodHeader: hdr
	^ String streamContents:
		[:strm |
		strm nextPutAll: '<nArgs=', ((hdr >> 25) bitAnd: 16r1F) printString , '>'.
		strm nextPutAll: '<nTemps=', ((hdr >> 19) bitAnd: 16r3F) printString , '>'.
		strm nextPutAll: '<lgCtxt=', ((hdr >> 18) bitAnd: 16r1) printString , '>'.
		strm nextPutAll: '<nLits=', ((hdr >> 10) bitAnd: 16rFF) printString , '>'.
		strm nextPutAll: '<prim=', ((hdr >> 1) bitAnd: 16r1FF) printString , '>'.
		]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'ar 5/17/2000 23:16'!
fullGC
	Transcript cr; show:'<Running full GC ...'.
	super fullGC.
	Transcript show: ' done>'.! !

!InterpreterSimulator methodsFor: 'debug support'!
headerStart: oop

	^ (self extraHeaderBytes: oop) negated! !

!InterpreterSimulator methodsFor: 'debug support'!
hexDump100: oop
	| byteSize val |
	^ String streamContents:
		[:strm |
		byteSize _ 256.
		(self headerStart: oop) to: byteSize by: 4 do:
			[:a | val _ self longAt: oop+a.
			strm cr; nextPutAll: (oop+a) hex8; space; space; 
				nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8;
				space; space.
			strm nextPutAll: (self charsOfLong: val).
			strm space; space; nextPutAll: (oop+a) printString]]! !

!InterpreterSimulator methodsFor: 'debug support'!
hexDump: oop
	| byteSize val |
	(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
	^ String streamContents:
		[:strm |
		byteSize _ 256 min: (self sizeBitsOf: oop)-4.
		(self headerStart: oop) to: byteSize by: 4 do:
			[:a | val _ self longAt: oop+a.
			strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8;
				space; space.
			a=0
				ifTrue: [strm nextPutAll: (self dumpHeader: val)]
				ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'di 4/3/1999 15:47'!
longPrint: oop
	| lastPtr val lastLong hdrType prevVal |
	(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
	^ String streamContents:
		[:strm |
		lastPtr _ 256 min: (self lastPointerOf: oop).
		hdrType _ self headerType: oop.
		hdrType = 2 ifTrue: [lastPtr _ 0].
		prevVal _ 0.
		(self headerStart: oop) to: lastPtr by: 4 do:
			[:a | val _ self longAt: oop+a.
			(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
			ifTrue:
			[prevVal = (self longAt: oop+a-8) ifFalse: [strm cr; nextPutAll: '        ...etc...']]
			ifFalse:
			[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
				space; space; space; nextPutAll: val hex8; space; space.
			a=-8 ifTrue: [strm nextPutAll: 'size = ' , (val - hdrType) hex].
			a=-4 ifTrue: [strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
			a=0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
			a>0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
			a=4 ifTrue: [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue:
							[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
			prevVal _ val].
		lastLong _ 256 min: (self sizeBitsOf: oop) - 4.
		hdrType = 2
			ifTrue:
			["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
			space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
			ifFalse:
			[(self formatOf: oop) = 3
			ifTrue:
				[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
				lastPtr+4 to: lastPtr+12 by: 4 do:
					[:a | val _ self longAt: oop+a.
					strm cr; nextPutAll: a hex; 
						space; space; space; nextPutAll: val hex8; space; space.
					(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
			ifFalse:
			[lastPtr+4 to: lastLong by: 4 do:
				[:a | val _ self longAt: oop+a.
				strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); 
					space; space; space.
				strm nextPutAll: val hex8; space; space;
						nextPutAll: (self charsOfLong: val)]]].
	]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'tk 9/21/1999 12:52'!
nameOfClass: classOop
	(self sizeBitsOf: classOop) = (Metaclass instSize +1*4) ifTrue:
		[^ (self nameOfClass:
				(self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
	^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! !

!InterpreterSimulator methodsFor: 'debug support'!
printStack
	| ctxt classAndSel home |
	ctxt _ activeContext.
	^ String streamContents:
		[:strm |
			[home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
				ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
				ifFalse: [ctxt].
			classAndSel _ self
				classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
				forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
			strm cr; nextPutAll: ctxt hex8.
			ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
			strm space; nextPutAll: (self nameOfClass: classAndSel first).
			strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
			(ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj]
				whileFalse: [].
		]! !

!InterpreterSimulator methodsFor: 'debug support' stamp: 'tk 9/18/1999 16:33'!
shortPrint: oop
	| name classOop |
	(self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , 
		' (' , (self integerValueOf: oop) hex , ')'].
	classOop _ self fetchClassOf: oop.
	(self sizeBitsOf: classOop) = (Metaclass instSize +1*4) ifTrue: [
		^ 'class ' , (self nameOfClass: oop)].
	name _ self nameOfClass: classOop.
	name size = 0 ifTrue: [name _ '??'].
	name = 'String' ifTrue: [^ (self stringOf: oop) printString].
	name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
	name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: 
				(self fetchPointer: 0 ofObject: oop))) printString].
	name = 'UndefinedObject' ifTrue: [^ 'nil'].
	name = 'False' ifTrue: [^ 'false'].
	name = 'True' ifTrue: [^ 'true'].
	name = 'Float' ifTrue: [^ '=' , (self floatValueOf: oop) printString].
	name = 'Association' ifTrue: [^ '(' ,
				(self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
				' -> ' ,
				(self longAt: oop + BaseHeaderSize + 4) hex8 , ')'].
	('AEIOU' includes: name first)
		ifTrue: [^ 'an ' , name]
		ifFalse: [^ 'a ' , name]! !

!InterpreterSimulator methodsFor: 'debug support'!
stringOf: oop
	| size long nLongs chars |
	^ String streamContents:
		[:strm |
		size _ 100 min: (self stSizeOf: oop).
		nLongs _ size-1//4+1.
		1 to: nLongs do:
			[:i | long _ self longAt: oop + BaseHeaderSize + (i-1*4).
			chars _ self charsOfLong: long.
			strm nextPutAll: (i=nLongs
							ifTrue: [chars copyFrom: 1 to: size-1\\4+1]
							ifFalse: [chars])]]! !


!InterpreterSimulator methodsFor: 'interpreter shell'!
dispatchOn: anInteger in: selectorArray
	"Simulate a case statement via selector table lookup.
	The given integer must be between 0 and selectorArray size-1, inclusive.
	For speed, no range test is done, since it is done by the at: operation."

	"assert: (anInteger >= 0) | (anInteger < selectorArray size)"
"
Transcript cr; show: anInteger hex , '  ' , (selectorArray at: (anInteger + 1)).
Sensor waitButton.
Sensor yellowButtonPressed ifTrue: [self halt].
"
	self perform: (selectorArray at: (anInteger + 1)).! !

!InterpreterSimulator methodsFor: 'interpreter shell'!
fetchByte

	^ self byteAt: (localIP _ localIP + 1).! !

!InterpreterSimulator methodsFor: 'interpreter shell'!
isIntegerValue: valueWord 
	^ valueWord >= 16r-40000000 and: [valueWord <= 16r3FFFFFFF]! !


!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'ar 5/1/1999 09:43'!
ioHasDisplayDepth: depth
	^Display supportsDisplayDepth: depth! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 12/1/1998 00:09'!
ioLowResMSecs
	^ Time millisecondClockValue! !

!InterpreterSimulator methodsFor: 'I/O primitives'!
ioProcessEvents! !

!InterpreterSimulator methodsFor: 'I/O primitives'!
primitiveBeDisplay
	"Extended to create a scratch Form for use by showDisplayBits."

	| rcvr destWidth destHeight destDepth |
	rcvr _ self stackTop.
	self success: ((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
	successFlag ifTrue: [
		destWidth _ self fetchInteger: 1 ofObject: rcvr.
		destHeight _ self fetchInteger: 2 ofObject: rcvr.
		destDepth _ self fetchInteger: 3 ofObject: rcvr.
	].
	successFlag ifTrue: [
		"create a scratch form the same size as Smalltalk displayObj"
		displayForm _ Form extent: destWidth @ destHeight
							depth: destDepth.
	].
	super primitiveBeDisplay.! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveKbdNext

	self pop: 1.
	Sensor keyboardPressed
		ifTrue: [self pushInteger: Sensor primKbdNext]
		ifFalse: [self push: nilObj]! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveKbdPeek

	self pop: 1.
	Sensor keyboardPressed
		ifTrue: [self pushInteger: Sensor primKbdPeek]
		ifFalse: [self push: nilObj]! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'!
primitiveMouseButtons
	| buttons |
	self pop: 1.
	buttons _ Sensor primMouseButtons.
	self pushInteger: buttons! !

!InterpreterSimulator methodsFor: 'I/O primitives'!
primitiveMousePoint

	| relPt |
	self pop: 1.
	displayForm == nil
		ifTrue: [self push: (self makePointwithxValue: 99 yValue: 66)]
		ifFalse: [relPt _ Sensor cursorPoint - (Display extent - displayForm extent - (10@10)).
				self push: (self makePointwithxValue: relPt x yValue: relPt y)]! !

!InterpreterSimulator methodsFor: 'I/O primitives'!
primitiveScreenSize  "Dummied for now"

	self pop: 1.
	self push: (self makePointwithxValue: 640 yValue: 480).! !

!InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'ar 5/17/2000 23:10'!
showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
	| raster pixPerWord simDisp realDisp rect |
	pixPerWord _ 32 // d.
	raster _ displayForm width + (pixPerWord - 1) // pixPerWord.
	simDisp _ Form new hackBits: memory.
	realDisp _ Form new hackBits: displayForm bits.
	realDisp
		copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
		from: 0 @ (destBits // 4 + (top * raster))
		in: simDisp
		rule: Form over.
	rect _ 0 @ top corner: displayForm width @ bottom.
	Display
		copy: (rect translateBy: self displayLocation)
		from: rect topLeft
		in: displayForm
		rule: Form over! !


!InterpreterSimulator methodsFor: 'I/O primitives support'!
copyBits

	^ myBitBlt copyBits! !

!InterpreterSimulator methodsFor: 'I/O primitives support'!
displayLocation

	^ Display extent - displayForm extent - (10@10)! !

!InterpreterSimulator methodsFor: 'I/O primitives support'!
drawLoopX: xDelta Y: yDelta

	^ myBitBlt drawLoopX: xDelta Y: yDelta! !

!InterpreterSimulator methodsFor: 'I/O primitives support'!
ioMSecs
	"Return the value of the millisecond clock."

	^ Time millisecondClockValue! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 3/9/1999 10:00'!
ioMicroMSecs
	"Answer the value of the high-resolution millisecond clock."

	^ Time millisecondClockValue
! !

!InterpreterSimulator methodsFor: 'I/O primitives support'!
ioProcessEventsEveryMSecs: mSecs
	"Noop during simulation."! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'!
ioScreenSize
	"Return the screen extent packed into 32 bits."

	^ (displayForm width << 16) + displayForm height! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'!
ioSeconds
	"Return the value of the second clock."

	^ Time primSecondsClock! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 12/1/1998 00:05'!
primitiveRelinquishProcessor
	"No-op in simulator"

	^ self pop: 1! !

!InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'yo 6/3/1999 16:10'!
warpBits

	^ myBitBlt warpBits! !


!InterpreterSimulator methodsFor: 'file primitives'!
fileValueOf: integerPointer
	"Convert the (integer) fileID to the actual fileStream it uses"
	self success: (self isIntegerObject: integerPointer).
	successFlag
		ifTrue: [^ filesOpen at: (self integerValueOf: integerPointer)]
		ifFalse: [^ nil]! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'yo 6/3/1999 12:03'!
makeDirEntryName: entryName size: entryNameSize
	createDate: createDate modDate: modifiedDate
	isDir: dirFlag fileSize: fileSize

	| modDateOop createDateOop nameString results |
	self var: 'entryName' declareC: 'char *entryName'.

	"allocate storage for results, remapping newly allocated
	 oops in case GC happens during allocation"
	self pushRemappableOop:
		(self instantiateClass: (self splObj: ClassArray) indexableSize: 5).
	self pushRemappableOop:
		(self instantiateClass: (self splObj: ClassString) indexableSize: entryNameSize)..
	self pushRemappableOop: (self positive32BitIntegerFor: createDate).
	self pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).

	modDateOop   _ self popRemappableOop.
	createDateOop _ self popRemappableOop.
	nameString    _ self popRemappableOop.
	results         _ self popRemappableOop.

	1 to: entryNameSize do: [ :i |
		self storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
	].

	self storePointer: 0 ofObject: results withValue: nameString.
	self storePointer: 1 ofObject: results withValue: createDateOop.
	self storePointer: 2 ofObject: results withValue: modDateOop.
	dirFlag
		ifTrue: [ self storePointer: 3 ofObject: results withValue: trueObj ]
		ifFalse: [ self storePointer: 3 ofObject: results withValue: falseObj ].
	self storePointer: 4 ofObject: results
		withValue: (self integerObjectOf: fileSize).
	^ results
! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'tk 10/30/1999 15:33'!
primitiveDirectoryLookup
	| index pathName array result |
	index _ self stackIntegerValue: 0.
	pathName _ (self stringOf: (self stackValue: 1)).
	
	successFlag ifFalse: [
		^self primitiveFail.
	].

	array _ FileDirectory default primLookupEntryIn: pathName index: index.

	array == nil ifTrue: [
		self pop: 3.
		self push: nilObj.
		^array.
	].
	array == #badDirectoryPath ifTrue: [
		^self primitiveFail.
	].

	result _ self makeDirEntryName: (array at: 1) size: (array at: 1) size
				createDate: (array at: 2) modDate: (array at: 3)
				isDir: (array at: 4)  fileSize: (array at: 5).
	self pop: 3.
	self push: result.
! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 1/12/1999 15:38'!
primitiveFileDelete 

	| namePointer |
	namePointer _ self stackTop.
	self success: (self isBytes: namePointer).
	self success: (StandardFileStream isAFileNamed: (self stringOf: namePointer)).
	successFlag ifTrue: [FileDirectory deleteFilePath: (self stringOf: namePointer)].
	successFlag ifTrue: [self pop: 1].  "pop fileName; leave rcvr on stack"
! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'mdr 9/4/2000 10:45'!
primitiveFileOpen
	| namePointer writeFlag fileName f |
	writeFlag _ self booleanValueOf: self stackTop.
	namePointer _ self stackValue: 1.
	self success: (self isBytes: namePointer).
	successFlag ifTrue:
		[fileName _ self stringOf: namePointer.
		filesOpen addLast: (writeFlag
			ifTrue: [(FileStream fileNamed: fileName) binary]
			ifFalse: [(StandardFileStream isAFileNamed: fileName)
				ifTrue: [f _ (FileStream readOnlyFileNamed: fileName).
						f ifNil:[^self primitiveFail] ifNotNil:[f binary]]
				ifFalse: [^ self primitiveFail]]).
		self pop: 3.  "rcvr, name, write"
		self pushInteger: filesOpen size]! !

!InterpreterSimulator methodsFor: 'file primitives' stamp: 'jm 12/5/97 15:10'!
primitiveFileRename

	| oldNamePointer newNamePointer f |
	oldNamePointer _ self stackTop.
	newNamePointer _ self stackValue: 1.
	self success: (self isBytes: oldNamePointer).
	self success: (self isBytes: newNamePointer).
	self success: (StandardFileStream isAFileNamed: (self stringOf: oldNamePointer)).
	self success: (StandardFileStream isAFileNamed: (self stringOf: newNamePointer)) not.
	successFlag ifTrue: [
		f _ FileStream oldFileNamed: (self stringOf: oldNamePointer).
		f rename: (self stringOf: newNamePointer).
		f close.
	].
	successFlag ifTrue: [
		self pop: 2.  "oldName, newName; leave rcvr on stack"
	].! !

!InterpreterSimulator methodsFor: 'file primitives'!
primitiveImageName
	"Note: For now, this only implements getting, not setting, the image file name."
	| result imageNameSize |
	self pop: 1.
	imageNameSize _ imageName size.
	result _ self instantiateClass: (self splObj: ClassString)
				   indexableSize: imageNameSize.
	1 to: imageNameSize do:
		[:i | self storeByte: i-1 ofObject: result
			withValue: (imageName at: i) asciiValue].
	self push: result.! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file Read: count Into: byteArrayIndex At: startIndex

	startIndex to: (startIndex + count - 1) do: [ :i |
		file atEnd ifTrue: [ ^ i - startIndex ].
		self byteAt: byteArrayIndex + i put: file next.
	].
	^ count! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file SetPosition: newPosition

	file position: newPosition.! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFile: file Write: count From: byteArrayIndex At: startIndex

	startIndex to: (startIndex + count - 1) do: [ :i |
		file nextPut: (self byteAt: byteArrayIndex + i).
	].
	^ count! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFileAtEnd: file

	^ file atEnd! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFileClose: file

	file close.! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFileGetPosition: file

	^ file position! !

!InterpreterSimulator methodsFor: 'file primitives'!
sqFileSize: file

	^ file size! !

!InterpreterSimulator methodsFor: 'file primitives'!
vmPathGet: stringBase Length: stringSize
	| pathName stringOop |
	pathName _ Smalltalk vmPath.
	stringOop _ stringBase - BaseHeaderSize. "Due to C call in Interp"
	1 to: stringSize do:
		[:i | self storeByte: i-1 ofObject: stringOop
			withValue: (pathName at: i) asciiValue].
! !

!InterpreterSimulator methodsFor: 'file primitives'!
vmPathSize
	^ Smalltalk vmPath size! !


!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 4/3/1999 17:07'!
fetchFloatAt: floatBitsAddress into: aFloat

	aFloat at: 1 put: (self longAt: floatBitsAddress).
	aFloat at: 2 put: (self longAt: floatBitsAddress+4).
! !

!InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 4/3/1999 15:56'!
storeFloatAt: floatBitsAddress from: aFloat.

	self longAt: floatBitsAddress put: (aFloat at: 1).
	self longAt: floatBitsAddress+4 put: (aFloat at: 2).
! !


!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:21'!
byteAt: byteAddress
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:21'!
byteAt: byteAddress put: byte
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:22'!
halfWordAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access' stamp: 'th 4/15/2000 17:22'!
halfWordAt: byteAddress put: halfWord
	^self subclassResponsibility! !

!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1! !

!InterpreterSimulator methodsFor: 'memory access'!
longAt: byteAddress put: a32BitValue
	"Note: Adjusted for Smalltalk's 1-based array indexing."

	^memory at: (byteAddress // 4) + 1 put: a32BitValue! !


!InterpreterSimulator methodsFor: 'other primitives' stamp: 'ikp 12/15/1998 23:33'!
ioForceDisplayUpdate
	"no-op"! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'!
primBitmapcompresstoByteArray
	^ self primitiveFail! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 11/23/1998 22:41'!
primBitmapdecompressfromByteArrayat
	| indexInt index baOop bmOop baSize bmSize ba bm |
	indexInt _ self stackTop.
	(self isIntegerValue: indexInt) ifFalse: [^ self primitiveFail].
	index _ self integerValueOf: indexInt.
	baOop _ self stackValue: 1.
	bmOop _ self stackValue: 2.
	baSize _ self stSizeOf: baOop.
	bmSize _ self stSizeOf: bmOop.
	ba _ ByteArray new: baSize.
	bm _ Bitmap new: bmSize.

	"Copy the byteArray into ba"
	1 to: baSize do: [:i | ba at: i put: (self fetchByte: i-1 ofObject: baOop)].

	"Decompress ba into bm"
	bm decompress: bm fromByteArray: ba at: index.

	"Then copy bm into the Bitmap"
	1 to: bmSize do: [:i | self storeWord: i-1 ofObject: bmOop withValue: (bm at: i)].
	self pop: 3! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'!
primStringcomparewithcollated
	^ self primitiveFail! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'ikp 12/15/1998 23:30'!
primStringfindSubstringinstartingAtmatchTable
	^self primitiveFail! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 11/8/1998 13:04'!
primStringindexOfAsciiinStringstartingAt
	^ self primitiveFail! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'yo 1/29/1999 21:37'!
primStringtranslatefromtotable
	^ self primitiveFail! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'tk 9/17/1999 21:24'!
primitiveBeep

	self beep.! !

!InterpreterSimulator methodsFor: 'other primitives' stamp: 'tao 9/29/97 
16:29'!
primitiveGetAttribute
	"return nil as if attribute isn't defined"
		self pop: 2.  "rcvr, attr"
		self push: (self splObj: NilObject).! !


!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:32'!
pushLiteralConstantBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushLiteralConstant: (currentBytecode bitAnd: 16r1F).
	self fetchNextBytecode.
! !

!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'!
pushLiteralVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushLiteralVariable: (currentBytecode bitAnd: 16r1F).
	self fetchNextBytecode.
! !

!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:34'!
pushReceiverVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushReceiverVariable: (currentBytecode bitAnd: 16rF).
	self fetchNextBytecode.
! !

!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:35'!
pushTemporaryVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
	self fetchNextBytecode.
! !

!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:30'!
storeAndPopReceiverVariableBytecode
	"Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."

	"Interpreter version has fetchNextBytecode out of order"
	| rcvr top |
	rcvr _ receiver.
	top _ self internalStackTop.
	(rcvr < youngStart) ifTrue: [
		self possibleRootStoreInto: rcvr value: top.
	].
	self storePointerUnchecked: (currentBytecode bitAnd: 7)
		ofObject: rcvr
		withValue: top.
	self internalPop: 1.
	self fetchNextBytecode.
! !

!InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'!
storeAndPopTemporaryVariableBytecode

	"Interpreter version has fetchNextBytecode out of order"
	self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart
		ofObject: localHomeContext
		withValue: self internalStackTop.
	self internalPop: 1.
	self fetchNextBytecode.
! !


!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 22:01'!
callExternalPrimitive: mapIndex
	| entry |
	entry _ (mappedPluginEntries at: mapIndex).
	^(entry at: 1) perform: (entry at: 2).! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 21:59'!
flushExternalPrimitives
	mappedPluginEntries _ #().
	super flushExternalPrimitives.! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'sr 7/21/2000 20:02'!
ioLoadExternalFunction: functionName OfLength: functionLength FromModule: moduleName OfLength: moduleLength
	"Load and return the requested function from a module"
	| pluginString functionString |
	pluginString _ String new: moduleLength.
	1 to: moduleLength do:[:i| pluginString byteAt: i put: (self byteAt: moduleName+i-1)].
	functionString _ String new: functionLength.
	1 to: functionLength do:[:i| functionString byteAt: i put: (self byteAt: functionName+i-1)].
	functionString _ functionString asSymbol.
	^self ioLoadFunction: functionString From: pluginString! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/17/2000 22:55'!
ioLoadFunction: functionString From: pluginString
	"Load and return the requested function from a module"
	| plugin fnSymbol |
	fnSymbol _ functionString asSymbol.
	Transcript cr; show:'Looking for ', functionString, ' in ', pluginString.
	plugin _ pluginList 
				detect:[:any| any key = pluginString asString]
				ifNone:[self loadNewPlugin: pluginString].
	plugin ifNil:[
		Transcript cr; show:'Failed ... no plugin found'. ^0]. "No plugin found"
	plugin _ plugin value.
	mappedPluginEntries doWithIndex:[:pluginAndName :index|
		((pluginAndName at: 1) == plugin 
			and:[(pluginAndName at: 2) == fnSymbol]) ifTrue:[
				Transcript show:' ... okay'. ^index]].
	(plugin respondsTo: fnSymbol) ifFalse:[
		Transcript cr; show:'Failed ... primitive not in plugin'. ^0].
	mappedPluginEntries _ mappedPluginEntries copyWith: (Array with: plugin with: fnSymbol).
	Transcript show:' ... okay'.
	^mappedPluginEntries size! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/17/2000 22:53'!
loadNewPlugin: pluginString
	| plugin simClass |
	Transcript cr; show:'Looking for module ', pluginString.
	plugin _ simClass _ nil.
	InterpreterPlugin allSubclassesDo:[:plg|
		plg moduleName asString = pluginString asString ifTrue:[
			simClass _ plg simulatorClass.
			plugin ifNil:[plugin _ simClass]
				ifNotNil:[plugin == simClass ifFalse:[^self error:'This won''t work...']].
		].
	].
	plugin ifNil:[Transcript show: ' ... not found'. ^nil].
	plugin _ plugin new.
	plugin setInterpreter: self. "Ignore return value from setInterpreter"
	(plugin respondsTo: #initialiseModule) ifTrue:[
		plugin initialiseModule ifFalse:[Transcript show: ' ... initialiser failed'.^nil]. "module initialiser failed"
	].
	pluginList _ pluginList copyWith: (pluginString asString -> plugin).
	Transcript show:' ... loaded'.
	^pluginList last! !

!InterpreterSimulator methodsFor: 'plugin support' stamp: 'ar 5/11/2000 21:47'!
sqGetInterpreterProxy
	"I am basically my own proxy..."
	^self! !

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

InterpreterSimulator class
	instanceVariableNames: ''!

!InterpreterSimulator class methodsFor: 'instance creation' stamp: 'th 4/15/2000 17:14'!
new
	^ self == InterpreterSimulator
		ifTrue: [Smalltalk endianness == #big
				ifTrue: [InterpreterSimulatorMSB new]
				ifFalse: [InterpreterSimulatorLSB new]]
		ifFalse: [super new]! !
InterpreterSimulator subclass: #InterpreterSimulatorLSB
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!InterpreterSimulatorLSB commentStamp: '<historical>' prior: 0!
This class overrides a few methods in InterpreterSimulator required for simulation to work on little-endian architectures (such as the x86 family of processors).  To start it up simply use InterpreterSimulatorLSB instead of InterpreterSimulator (see the class comment there for more details).  For example:

	(InterpreterSimulatorLSB new openOn: Smalltalk imageName) test

Note that the image must have been saved at least once on the local architecture, since the compiled VM performs some byte swapping that the simulator cannot cope with.!


!InterpreterSimulatorLSB methodsFor: 'initialization' stamp: 'ikp 12/11/1998 01:35'!
nextLongFrom: aStream
	"Read a 32-bit quantity from the given (binary) stream."
	| bytes |
	bytes _ aStream nextInto: (ByteArray new: 4).
	^ Integer
		byte1: (bytes at: 1)
		byte2: (bytes at: 2)
		byte3: (bytes at: 3)
		byte4: (bytes at: 4)! !


!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'ikp 12/11/1998 01:35'!
byteAt: byteAddress
	| lowBits |
	lowBits _ byteAddress bitAnd: 3.
	^((self longAt: byteAddress - lowBits)
		bitShift: (0 - lowBits) * 8)
		bitAnd: 16rFF! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'ikp 12/11/1998 01:35'!
byteAt: byteAddress put: byte
	| longWord shift lowBits |
	lowBits _ byteAddress bitAnd: 3.
	longWord _ self longAt: byteAddress - lowBits.
	shift _ lowBits * 8.
	longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift).
	self longAt: byteAddress - lowBits put: longWord! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'GVG 1/27/1999
20:43'!
halfWordAt: byteAddress
	| lowBits |
	lowBits _ byteAddress bitAnd: 2.
	^((self longAt: byteAddress - lowBits)
		bitShift: (0 - lowBits) * 8)
		bitAnd: 16rFFFF! !

!InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'GVG 1/27/1999
21:30'!
halfWordAt: byteAddress put: halfWord
	| longWord shift lowBits |
	lowBits _ byteAddress bitAnd: 2.
	longWord _ self longAt: byteAddress - lowBits.
	shift _ lowBits * 8.
	longWord _ longWord - (longWord bitAnd: (16rFFFF bitShift: shift)) +
(halfWord bitShift: shift).
	self longAt: byteAddress - lowBits put: longWord
! !


!InterpreterSimulatorLSB methodsFor: 'debug support' stamp: 'ikp 12/11/1998 01:35'!
charsOfLong: long
	^ (1 to: 4) collect:
		[:i | ((long digitAt: i) between: 14 and: 126)
					ifTrue: [(long digitAt: i) asCharacter]
					ifFalse: [$?]]! !

!InterpreterSimulatorLSB methodsFor: 'debug support' stamp: 'ar 10/24/1999 21:47'!
displayForm: f
	| width height depth bits realForm simDisp realDisp |
	bits _ self fetchPointer: 0 ofObject: f.
	width _ self fetchInteger: 1 ofObject: f.
	height _ self fetchInteger: 2 ofObject: f.
	depth _ self fetchInteger: 3 ofObject: f.
	realForm _ Form extent: width@height depth: depth.
	simDisp _ Form new hackBits: memory.
	realDisp _ Form new hackBits: realForm bits.
	realDisp
		copy: (0 @ 0 extent: 4 @ realForm bits size)
		from: (0 @ (bits + 4 // 4))
		in: simDisp
		rule: Form over.
	realForm displayOn: Display at: 0@0.! !

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

InterpreterSimulatorLSB class
	instanceVariableNames: ''!

!InterpreterSimulatorLSB class methodsFor: 'instance creation' stamp: 'th 4/15/2000 17:16'!
new
	^self basicNew! !
InterpreterSimulator subclass: #InterpreterSimulatorMSB
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!

!InterpreterSimulatorMSB methodsFor: 'initialization' stamp: 'th 4/15/2000 15:43'!
nextLongFrom: aStream 
	"Read a 32-bit quantity from the given (binary) stream."
	| bytes |
	bytes _ aStream nextInto: (ByteArray new: 4).
	^ Integer
		byte1: (bytes at: 4)
		byte2: (bytes at: 3)
		byte3: (bytes at: 2)
		byte4: (bytes at: 1)! !


!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'th 4/15/2000 16:03'!
byteAt: byteAddress
	| lowBits |
	lowBits _ byteAddress bitAnd: 3.
	^((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - 3) * 8)
		bitAnd: 16rFF! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'th 4/15/2000 16:03'!
byteAt: byteAddress put: byte
	| longWord shift lowBits |
	lowBits _ byteAddress bitAnd: 3.
	longWord _ self longAt: byteAddress - lowBits.
	shift _ (3 - lowBits) * 8.
	longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift).
	self longAt: byteAddress put: longWord! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'th 4/15/2000 16:05'!
halfWordAt: byteAddress
    "Return the half-word at byteAddress which must be even."
	| lowBits |
	lowBits _ byteAddress bitAnd: 2.
	^((self longAt: byteAddress - lowBits)
		bitShift: (lowBits - 2) * 8)
		bitAnd: 16rFFFF
! !

!InterpreterSimulatorMSB methodsFor: 'memory access' stamp: 'th 4/15/2000 16:05'!
halfWordAt: byteAddress put: halfWord
	| longWord shift lowBits |
	lowBits _ byteAddress bitAnd: 2.
	longWord _ self longAt: byteAddress - lowBits.
	shift _ lowBits * 8.
	longWord _ longWord - (longWord bitAnd: (16rFFFF bitShift: shift)) +
(halfWord bitShift: shift).
	self longAt: byteAddress - lowBits put: longWord
! !


!InterpreterSimulatorMSB methodsFor: 'debug support' stamp: 'th 4/15/2000 16:05'!
charsOfLong: long
	^ (4 to: 1 by: -1) collect:
		[:i | ((long digitAt: i) between: 14 and: 126)
					ifTrue: [(long digitAt: i) asCharacter]
					ifFalse: [$?]]! !

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

InterpreterSimulatorMSB class
	instanceVariableNames: ''!

!InterpreterSimulatorMSB class methodsFor: 'instance creation' stamp: 'th 4/15/2000 17:16'!
new
	^self basicNew! !
Object subclass: #InterpreterSupportCode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!InterpreterSupportCode commentStamp: '<historical>' prior: 0!
This class is a shell that includes all the ancillary C code for supporting Squeak in the Macintosh operating environment.  Executing

	InterpreterSupportCode writeMacSourceFiles

will cause the creation of a number of files in your working directory which, together with the one large interpreter file (see CCodeGenerator) should be adequate to compile a complete running interpreter.!


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

InterpreterSupportCode class
	instanceVariableNames: ''!

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'di 11/15/1998 16:22'!
cCodeForMiscPrimitives
	"Return the contents of the miscellaneous primitives file, which is generated via automatic translation to C."

	^ CCodeGenerator new codeStringForPrimitives: #(
		(Bitmap compress:toByteArray:)
		(Bitmap decompress:fromByteArray:at:)
		(Bitmap encodeBytesOf:in:at:)
		(Bitmap encodeInt:in:at:)
		(String compare:with:collated:)
		(String translate:from:to:table:)	
		(String findFirstInString:inSet:startingAt:)
		(String indexOfAscii:inString:startingAt:)
		(String findSubstring:in:startingAt:matchTable:)
		(SampledSound convert8bitSignedFrom:to16Bit:))
! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'ar 2/3/2001 16:33'!
compareWithFilesInFolder: folderName
	"InterpreterSupportCode compareWithFilesInFolder: 'Tosh:Desktop Folder:Squeak VM Project'"

	| dir |
	dir _ FileDirectory on: folderName.

	(dir readOnlyFileNamed: 'projectArchive.sit') binary contentsOfEntireFile =
	InterpreterSupportCode macArchiveBinaryFile asByteArray
		ifFalse: [self inform: 'File projectArchive.sit differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'readme') contentsOfEntireFile =
	InterpreterSupportCode readmeFile
		ifFalse: [self inform: 'File readme differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sq.h') contentsOfEntireFile =
	InterpreterSupportCode squeakHeaderFile
		ifFalse: [self inform: 'File sq.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqConfig.h') contentsOfEntireFile =
	InterpreterSupportCode squeakConfigFile
		ifFalse: [self inform: 'File sqConfig.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'platform.exports') contentsOfEntireFile =
	InterpreterSupportCode squeakPlatformExportsFile
		ifFalse: [self inform: 'File platform.exports differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqPlatformSpecific.h') contentsOfEntireFile =
	InterpreterSupportCode squeakPlatSpecFile
		ifFalse: [self inform: 'File sqPlatformSpecific.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqFilePrims.c') contentsOfEntireFile =
	InterpreterSupportCode squeakFilePrimsFile
		ifFalse: [self inform: 'File sqFilePrims.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacAsyncFilePrims.c') contentsOfEntireFile =
	InterpreterSupportCode macAsyncFilePrimsFile
		ifFalse: [self inform: 'File sqMacAsyncFilePrims.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacNSPlugin.c') contentsOfEntireFile =
	InterpreterSupportCode macBrowserPluginFile
		ifFalse: [self inform: 'File sqMacNSPlugin.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacDirectory.c') contentsOfEntireFile =
	InterpreterSupportCode macDirectoryFile
		ifFalse: [self inform: 'File sqMacDirectory.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacDragDrop.c') contentsOfEntireFile =
	InterpreterSupportCode macDragDropFile
		ifFalse: [self inform: 'File sqMacDragDrop.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacJoystickAndTablet.c') contentsOfEntireFile =
	InterpreterSupportCode macJoystickAndTabletFile
		ifFalse: [self inform: 'File sqMacJoystickAndTablet.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacMinimal.c') contentsOfEntireFile =
	InterpreterSupportCode macMinimal
		ifFalse: [self inform: 'File sqMacMinimal.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacNetwork.c') contentsOfEntireFile =
	InterpreterSupportCode macNetworkFile
		ifFalse: [self inform: 'File sqMacNetwork.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacSerialAndMIDIPort.c') contentsOfEntireFile =
	InterpreterSupportCode macSerialAndMIDIPortFile
		ifFalse: [self inform: 'File sqMacSerialAndMIDIPort.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacSound.c') contentsOfEntireFile =
	InterpreterSupportCode macSoundFile
		ifFalse: [self inform: 'File sqMacSound.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqMacWindow.c') contentsOfEntireFile =
	InterpreterSupportCode macWindowFile
		ifFalse: [self inform: 'File sqMacWindow.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqNamedPrims.c') contentsOfEntireFile =
	InterpreterSupportCode squeakNamedPrimsFile
		ifFalse: [self inform: 'File sqNamedPrims.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqVirtualMachine.h') contentsOfEntireFile =
	InterpreterSupportCode squeakVirtualMachineHeaderFile
		ifFalse: [self inform: 'File sqVirtualMachine.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'sqVirtualMachine.c') contentsOfEntireFile =
	InterpreterSupportCode squeakVirtualMachineFile
		ifFalse: [self inform: 'File sqVirtualMachine.c differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'MacTCP.h') contentsOfEntireFile =
	InterpreterSupportCode macTCPFile
		ifFalse: [self inform: 'File MacTCP.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'AddressXlation.h') contentsOfEntireFile =
	InterpreterSupportCode macAddressXlationFile
		ifFalse: [self inform: 'File AddressXlation.h differs from the version stored in this image.'].

	(dir readOnlyFileNamed: 'dnr.c') contentsOfEntireFile =
	InterpreterSupportCode macDNRFile
		ifFalse: [self inform: 'File dnr.c differs from the version stored in this image.'].
! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'ar 4/30/1999 04:49'!
storeString: s onFileNamed: fileName
	"Store the given string in a file of the given name."

	| f |
	f _ CrLfFileStream newFileNamed: fileName.
	f nextPutAll: s.
	f close.! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 5/26/2000 09:11'!
storeStuffitArchive: archiveData onFileNamed: fileName
	"Store the given binary data as a file with the type and creator of a Stuff archive file. You will need to use a StuffIt unpacking utility such as StuffIt Expander to unpack the file."

	| f |
	f _ (FileStream newFileNamed: fileName) binary.
	archiveData do: [:byte | f nextPut: byte].
	f close.
	FileDirectory default setMacFileNamed: fileName type: 'SITD' creator: 'SIT!!'.
! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'JMM 1/31/2001 14:44'!
writeMacSourceFiles
	"Store into this image's folder the C sources files required to support the interpreter on the Macintosh. It also generates the code for the sound synthesis primitives. However, because generating code for the interpreter itself takes several minutes, that is not done automatically by this method. To generate the interpreter code, use the method 'translate:doInlining:' in Interpreter class."
	"InterpreterSupportCode writeMacSourceFiles"

	self writeSupportFiles.
	FFIPlugin writeSupportFiles.

	self storeString: self macAsyncFilePrimsFile	onFileNamed: 'sqMacAsyncFilePrims.c'.
	self storeString: self macBrowserPluginFile	onFileNamed: 'sqMacNSPlugin.c'.
	self storeString: self macDirectoryFile	onFileNamed: 'sqMacDirectory.c'.
	self storeString: self macJoystickAndTabletFile  onFileNamed: 'sqMacJoystickAndTablet.c'.
	self storeString: self macMinimal		onFileNamed: 'sqMacMinimal.c'.
	self storeString: self macNetworkFile		onFileNamed: 'sqMacNetwork.c'.
	self storeString: self macDragDropFile	onFileNamed: 'sqMacDragDrop.c'.
	self storeString: self macSerialAndMIDIPortFile	onFileNamed: 'sqMacSerialAndMIDIPort.c'.
	self storeString: self macSoundFile		onFileNamed: 'sqMacSound.c'.
	self storeString: self macWindowFile		onFileNamed: 'sqMacWindow.c'.
	self storeString: self macTCPFile			onFileNamed: 'MacTCP.h'.
	self storeString: self macAddressXlationFile		onFileNamed: 'AddressXlation.h'.
	self storeString: self macDNRFile					onFileNamed: 'dnr.c'.

	self storeStuffitArchive: self	 macArchiveBinaryFile
		onFileNamed: 'projectArchive.sit'.
! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 10/13/1999 23:06'!
writePluginSupportFiles
	"InterpreterSupportCode writePluginSupportFiles"

	self	storeString: self squeakConfigFile onFileNamed: 'sqConfig.h'.
	self	storeString: self squeakPlatSpecFile onFileNamed: 'sqPlatformSpecific.h'.
	self	storeString: self squeakVirtualMachineHeaderFile onFileNamed: 'sqVirtualMachine.h'.
! !

!InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'ar 2/3/2001 16:33'!
writeSupportFiles
	"Store into this image's folder the C sources files required to support the interpreter on all platforms. This method also generates the code for the sound synthesis and other primitives translated from Smalltalk to C. However, because generating code for the interpreter itself takes several minutes, that is not done automatically by this method. To generate that code, use the method 'translate:doInlining:' in Interpreter class."
	"InterpreterSupportCode writeSupportFiles"

	self storeString: self readmeFile			onFileNamed: 'readme'.
	self storeString: self squeakHeaderFile	onFileNamed: 'sq.h'.
	self storeString: self squeakConfigFile	onFileNamed: 'sqConfig.h'.
	self storeString: self squeakPlatformExportsFile	onFileNamed: 'platform.exports'.
	self storeString: self squeakPlatSpecFile	onFileNamed: 'sqPlatformSpecific.h'.
	self storeString: self squeakVirtualMachineHeaderFile	onFileNamed: 'sqVirtualMachine.h'.
	self storeString: self squeakVirtualMachineFile	onFileNamed: 'sqVirtualMachine.c'.
	self storeString: self squeakNamedPrimsFile onFileNamed:'sqNamedPrims.c'.

	self storeString: self squeakFilePrimsFile	onFileNamed:  'sqFilePrims.c'.! !


!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 1/6/98 11:52'!
macAddressXlationFile

	^ '/*
 	File:		AddressXlation.h
 
 	Contains:	TCP Manager interfaces for dnr.c
 
 	Version:	Use with MacTCP 2.0.6 and Universal Interfaces 2.1b1
					in ÒMPW PrereleaseÓ on ETO #17

  	Copyright:	© 1984-1995 by Apple Computer, Inc.
 				All rights reserved.
 
 	Bugs?:		If you find a problem with this file, send the file and version
 				information (from above) and the problem description to:
 
 					Internet:	apple.bugs@applelink.apple.com
 					AppleLink:	APPLE.BUGS
 
*/

#ifndef __ADDRESSXLATION__
#define __ADDRESSXLATION__


#ifndef __TYPES__
#include <Types.h>
#endif
/*	#include <ConditionalMacros.h>								*/

#ifndef __MACTCP__
#include <MacTCP.h>
#endif
/*	#include <AppleTalk.h>										*/
/*		#include <OSUtils.h>									*/
/*			#include <MixedMode.h>								*/
/*			#include <Memory.h>									*/

#ifdef __cplusplus
extern "C" {
#endif

#if STRUCTALIGNMENTSUPPORTED
#pragma options align=mac68k
#endif

#if PRAGMA_IMPORT_SUPPORTED
#pragma import on
#endif

/*
	Developer Notes:

			When the various calls are made to the dnr code, you must set up 
			a NewRoutineDescriptor for every non-nil completion routine and/or 
			notifyProc parameter.  Otherwise, the 68K dnr code, will not 
			correctly call your routine.
		1. For the call to EnumCache, use NewEnumResultProc to set up a 
			universal procptr to pass as the enumResultProc parameter.
		2. For the calls to StrToAddr and AddrToName, use NewResultProc to 
			set up a ResultUPP universal procptr to pass as the ResultProc 
			parameter.
		3. For the calls to HInfo and MXInfo, use NewResultProc2Proc to
			set up a ResultProc2UPP universal procptr to pass as the ResultProc
			parameter.
		4. The DNR selector symbol HINFO has been changed to HXINFO due to
			conflict with the same symbol in the AddressXLation.h header
*/

enum {
	NUM_ALT_ADDRS				= 4
};

struct hostInfo {
	long							rtnCode;
	char							cname[255];
	SInt8							filler;						/* Filler for proper byte alignment	 */
	unsigned long					addr[NUM_ALT_ADDRS];
};
typedef struct hostInfo hostInfo;


enum {
	A							= 1,
	NS							= 2,
	CNAME						= 5,
	HINFO						= 13,
	MX							= 15,
	lastClass					= 32767
};

typedef unsigned short AddrClasses;

/* Domain Name Resolver code selectors */

enum {
	OPENRESOLVER				= 1,
	CLOSERESOLVER				= 2,
	STRTOADDR					= 3,
	ADDRTOSTR					= 4,
	ENUMCACHE					= 5,
	ADDRTONAME					= 6,
	HXINFO						= 7,							/* changed from HINFO due to symbol conflict*/
	MXINFO						= 8
};

struct HInfoRec {
	char							cpuType[30];
	char							osType[30];
};
typedef struct HInfoRec HInfoRec;

struct MXRec {
	unsigned short					preference;
	char							exchange[255];
};
typedef struct MXRec MXRec;

struct returnRec {
	long							rtnCode;
	char							cname[255];
	SInt8							filler;						/* Filler for proper byte alignment	 */
	union {
		unsigned long					addr[NUM_ALT_ADDRS];
		struct HInfoRec					hinfo;
		struct MXRec					mx;
	}								rdata;
};
typedef struct returnRec returnRec;

struct cacheEntryRecord {
	char							*cname;
	unsigned short					ctype;
	unsigned short					cacheClass;
	unsigned long					ttl;
	union {
		char							*name;
		ip_addr							addr;
	}								rdata;
};
typedef struct cacheEntryRecord cacheEntryRecord;

typedef pascal void (*EnumResultProcPtr)(struct cacheEntryRecord *cacheEntryRecordPtr, Ptr userDataPtr);
typedef pascal void (*ResultProcPtr)(struct hostInfo *hostInfoPtr, Ptr userDataPtr);
typedef pascal void (*ResultProc2ProcPtr)(struct returnRec *returnRecPtr, Ptr userDataPtr);

#if GENERATINGCFM
typedef UniversalProcPtr EnumResultUPP;
typedef UniversalProcPtr ResultUPP;
typedef UniversalProcPtr ResultProc2UPP;
#else
typedef EnumResultProcPtr EnumResultUPP;
typedef ResultProcPtr ResultUPP;
typedef ResultProc2ProcPtr ResultProc2UPP;
#endif

enum {
	uppEnumResultProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct cacheEntryRecord*)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr))),
	uppResultProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct hostInfo*)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr))),
	uppResultProc2ProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct returnRec*)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(Ptr)))
};

#if GENERATINGCFM
#define NewEnumResultProc(userRoutine)		\
		(EnumResultUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppEnumResultProcInfo, GetCurrentArchitecture())
#define NewResultProc(userRoutine)		\
		(ResultUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppResultProcInfo, GetCurrentArchitecture())
#define NewResultProc2Proc(userRoutine)		\
		(ResultProc2UPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppResultProc2ProcInfo, GetCurrentArchitecture())
#else
#define NewEnumResultProc(userRoutine)		\
		((EnumResultUPP) (userRoutine))
#define NewResultProc(userRoutine)		\
		((ResultUPP) (userRoutine))
#define NewResultProc2Proc(userRoutine)		\
		((ResultProc2UPP) (userRoutine))
#endif

#if GENERATINGCFM
#define CallEnumResultProc(userRoutine, cacheEntryRecordPtr, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppEnumResultProcInfo, (cacheEntryRecordPtr), (userDataPtr))
#define CallResultProc(userRoutine, hostInfoPtr, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppResultProcInfo, (hostInfoPtr), (userDataPtr))
#define CallResultProc2Proc(userRoutine, returnRecPtr, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppResultProc2ProcInfo, (returnRecPtr), (userDataPtr))
#else
#define CallEnumResultProc(userRoutine, cacheEntryRecordPtr, userDataPtr)		\
		(*(userRoutine))((cacheEntryRecordPtr), (userDataPtr))
#define CallResultProc(userRoutine, hostInfoPtr, userDataPtr)		\
		(*(userRoutine))((hostInfoPtr), (userDataPtr))
#define CallResultProc2Proc(userRoutine, returnRecPtr, userDataPtr)		\
		(*(userRoutine))((returnRecPtr), (userDataPtr))
#endif

extern OSErr OpenResolver(char *fileName);
extern OSErr StrToAddr(char *hostName, struct hostInfo *hostInfoPtr, ResultUPP ResultProc, char *userDataPtr);
extern OSErr AddrToStr(unsigned long addr, char *addrStr);
extern OSErr EnumCache(EnumResultUPP enumResultProc, Ptr userDataPtr);
extern OSErr AddrToName(ip_addr addr, struct hostInfo *hostInfoPtr, ResultUPP ResultProc, Ptr userDataPtr);
extern OSErr HInfo(char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);
extern OSErr MXInfo(char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);
extern OSErr CloseResolver(void);
/*
	Universal ProcPtrs declaration for each of the dnr selector code calls.
*/
typedef OSErr (*OpenResolverProcPtr)(UInt32 selector, char *filename);
typedef OSErr (*CloseResolverProcPtr)(UInt32 selector);
typedef OSErr (*StrToAddrProcPtr)(UInt32 selector, char *hostName, struct hostInfo *rtnStruct, ResultUPP resultproc, Ptr userDataPtr);
typedef OSErr (*AddrToStrProcPtr)(UInt32 selector, unsigned long addr, char *addrStr);
typedef OSErr (*EnumCacheProcPtr)(UInt32 selector, EnumResultUPP resultproc, Ptr userDataPtr);
typedef OSErr (*AddrToNameProcPtr)(UInt32 selector, UInt32 addr, struct hostInfo *rtnStruct, ResultUPP resultproc, Ptr userDataPtr);
typedef OSErr (*HInfoProcPtr)(UInt32 selector, char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);
typedef OSErr (*MXInfoProcPtr)(UInt32 selector, char *hostName, struct returnRec *returnRecPtr, ResultProc2UPP resultProc, Ptr userDataPtr);

#if GENERATINGCFM
typedef UniversalProcPtr OpenResolverUPP;
typedef UniversalProcPtr CloseResolverUPP;
typedef UniversalProcPtr StrToAddrUPP;
typedef UniversalProcPtr AddrToStrUPP;
typedef UniversalProcPtr EnumCacheUPP;
typedef UniversalProcPtr AddrToNameUPP;
typedef UniversalProcPtr HInfoUPP;
typedef UniversalProcPtr MXInfoUPP;
#else
typedef OpenResolverProcPtr OpenResolverUPP;
typedef CloseResolverProcPtr CloseResolverUPP;
typedef StrToAddrProcPtr StrToAddrUPP;
typedef AddrToStrProcPtr AddrToStrUPP;
typedef EnumCacheProcPtr EnumCacheUPP;
typedef AddrToNameProcPtr AddrToNameUPP;
typedef HInfoProcPtr HInfoUPP;
typedef MXInfoProcPtr MXInfoUPP;
#endif

enum {
	uppOpenResolverProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*))),
	uppCloseResolverProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32))),
	uppStrToAddrProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct hostInfo*)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultUPP)))
		 | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),
	uppAddrToStrProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned long)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(char*))),
	uppEnumCacheProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(EnumResultUPP)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr))),
	uppAddrToNameProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct hostInfo*)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultUPP)))
		 | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),
	uppHInfoProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct returnRec*)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultProc2UPP)))
		 | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr))),
	uppMXInfoProcInfo = kCStackBased
		 | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(UInt32)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(char*)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(struct returnRec*)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(ResultProc2UPP)))
		 | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Ptr)))
};

#if GENERATINGCFM
#define CallOpenResolverProc(userRoutine, selector, filename)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppOpenResolverProcInfo, (selector), (filename))
#define CallCloseResolverProc(userRoutine, selector)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppCloseResolverProcInfo, (selector))
#define CallStrToAddrProc(userRoutine, selector, hostName, rtnStruct, resultproc, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppStrToAddrProcInfo, (selector), (hostName), (rtnStruct), (resultproc), (userDataPtr))
#define CallAddrToStrProc(userRoutine, selector, addr, addrStr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppAddrToStrProcInfo, (selector), (addr), (addrStr))
#define CallEnumCacheProc(userRoutine, selector, resultproc, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppEnumCacheProcInfo, (selector), (resultproc), (userDataPtr))
#define CallAddrToNameProc(userRoutine, selector, addr, rtnStruct, resultproc, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppAddrToNameProcInfo, (selector), (addr), (rtnStruct), (resultproc), (userDataPtr))
#define CallHInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppHInfoProcInfo, (selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))
#define CallMXInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppMXInfoProcInfo, (selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))
#else
#define CallOpenResolverProc(userRoutine, selector, filename)		\
		(*(userRoutine))((selector), (filename))
#define CallCloseResolverProc(userRoutine, selector)		\
		(*(userRoutine))((selector))
#define CallStrToAddrProc(userRoutine, selector, hostName, rtnStruct, resultproc, userDataPtr)		\
		(*(userRoutine))((selector), (hostName), (rtnStruct), (resultproc), (userDataPtr))
#define CallAddrToStrProc(userRoutine, selector, addr, addrStr)		\
		(*(userRoutine))((selector), (addr), (addrStr))
#define CallEnumCacheProc(userRoutine, selector, resultproc, userDataPtr)		\
		(*(userRoutine))((selector), (resultproc), (userDataPtr))
#define CallAddrToNameProc(userRoutine, selector, addr, rtnStruct, resultproc, userDataPtr)		\
		(*(userRoutine))((selector), (addr), (rtnStruct), (resultproc), (userDataPtr))
#define CallHInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)		\
		(*(userRoutine))((selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))
#define CallMXInfoProc(userRoutine, selector, hostName, returnRecPtr, resultProc, userDataPtr)		\
		(*(userRoutine))((selector), (hostName), (returnRecPtr), (resultProc), (userDataPtr))
#endif


#if PRAGMA_IMPORT_SUPPORTED
#pragma import off
#endif

#if STRUCTALIGNMENTSUPPORTED
#pragma options align=reset
#endif

#ifdef __cplusplus
}
#endif

#endif /* __ADDRESSXLATION__ */
'.
! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 12/1/2000 22:45'!
macArchiveBinaryFile
	"Answer the binary contents of a StuffIt archive file containing the CodeWarrier project files for the virtual machine. You will need to use a StuffIt unpacking utility such as StuffIt Expander to unpack the file. The result will be a folder containing the project files."
	"To create the text for this method evaulate:
		| in out |
		in _ (FileStream oldFileNamed: 'projectArchive.sit') binary.
		out _ WriteStream on: (String new: 100000).
		out nextPutAll: '#('.
		[in atEnd] whileFalse: [out nextPutAll: in next printString; space].
		out skip: -1.
		out nextPutAll: ')'.
		in close.
		ParagraphEditor clipboardTextPut: out contents asText
	  and then do paste into this method."

	^ #(83 116 117 102 102 73 116 32 40 99 41 49 57 57 55 45 49 57 57 56 32 65 108 97 100 100 105 110 32 83 121 115 116 101 109 115 44 32 73 110 99 46 44 32 104 116 116 112 58 47 47 119 119 119 46 97 108 97 100 100 105 110 115 121 115 46 99 111 109 47 83 116 117 102 102 73 116 47 13 10 26 0 5 16 0 0 114 250 0 0 0 114 0 8 0 0 0 114 148 6 0 43 0 5 1 24 2 0 0 0 0 0 0 0 165 165 165 165 1 0 0 61 0 0 172 94 103 33 181 100 42 6 0 0 0 0 0 0 13 31 0 0 0 0 0 13 218 2 0 0 7 218 0 0 2 139 0 0 0 0 15 0 77 121 80 108 117 103 105 110 46 112 114 111 106 0 1 186 192 77 77 80 82 67 87 73 69 1 0 4 47 0 245 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 43 27 0 0 9 179 0 0 0 0 15 0 66 193 212 194 19 180 140 109 220 205 78 57 63 90 66 84 57 156 71 10 240 179 194 234 180 76 49 136 61 86 193 33 87 165 51 39 174 141 114 32 57 229 43 22 87 128 72 84 38 117 129 4 182 215 234 186 97 240 130 6 7 168 37 149 122 3 125 3 195 87 185 151 254 22 251 249 238 210 167 130 219 121 155 186 134 229 95 75 152 58 93 250 123 38 106 43 222 218 75 149 20 150 219 56 44 81 228 23 54 251 165 214 237 251 0 192 205 43 113 64 228 181 201 133 51 84 209 66 37 59 176 144 234 4 186 142 81 128 228 2 55 216 158 134 41 177 194 7 95 252 212 255 73 83 237 231 200 33 245 234 99 190 79 33 76 97 115 253 35 55 46 42 13 118 116 73 161 215 249 23 162 74 26 161 34 208 52 177 148 31 2 225 128 147 212 218 175 235 77 215 179 45 41 42 83 138 73 222 20 4 247 49 227 152 237 224 96 210 249 218 162 93 24 168 187 8 67 87 106 36 240 23 14 253 32 32 233 250 182 103 110 104 23 208 218 230 121 74 225 57 124 53 128 60 111 91 170 168 211 245 68 13 214 181 216 230 12 119 31 218 154 171 103 239 30 230 22 188 226 29 238 162 224 59 253 70 31 56 103 224 36 245 159 238 139 104 201 201 132 39 227 128 0 62 234 60 136 63 255 195 11 172 202 17 37 216 84 146 63 219 54 56 151 166 38 241 106 221 197 103 27 237 182 165 6 183 114 101 218 141 240 64 148 45 222 37 21 103 254 127 46 56 173 37 215 210 155 156 143 214 184 249 118 238 209 196 193 63 132 149 152 85 92 181 13 27 221 176 225 145 152 79 7 62 97 181 120 39 91 165 74 115 184 46 199 3 192 153 218 145 229 140 225 48 115 235 24 105 61 157 168 6 39 4 200 157 182 175 112 130 106 48 11 175 17 0 192 51 97 61 92 231 192 128 4 202 158 82 84 178 6 244 58 194 143 198 197 84 245 194 178 69 38 193 153 99 228 73 197 137 51 95 234 74 220 141 111 161 135 191 121 33 201 254 51 7 28 164 179 195 57 17 73 210 193 161 123 149 11 73 41 75 25 196 86 100 212 137 148 255 191 61 249 212 167 243 124 178 252 243 230 210 105 103 137 88 244 8 170 166 127 33 239 33 76 177 46 165 94 119 60 57 69 82 53 93 97 113 18 211 180 59 221 195 107 202 4 125 117 172 218 169 252 32 46 1 54 41 228 135 201 89 109 105 202 112 20 196 166 41 173 208 173 27 148 202 143 245 25 142 72 111 18 240 135 44 9 113 199 4 252 36 142 207 253 43 184 119 116 86 138 249 177 138 141 63 33 191 93 190 139 209 129 212 216 83 151 194 200 24 252 41 196 242 80 71 41 30 226 43 28 209 35 219 218 177 65 128 188 55 183 237 64 231 242 161 168 189 135 114 61 217 9 64 19 4 196 99 134 88 34 235 184 97 44 234 25 195 176 83 127 209 207 190 234 196 243 14 19 177 134 74 190 120 202 207 65 100 1 59 62 46 48 80 135 3 9 73 242 18 57 109 183 245 222 178 216 183 84 76 56 208 27 8 158 248 66 214 155 165 188 137 94 194 111 156 211 2 200 53 127 166 203 170 79 164 98 8 33 169 242 184 152 189 171 140 226 112 193 38 34 179 149 178 39 37 88 11 56 158 240 172 153 69 71 107 203 187 140 154 176 235 8 151 194 172 241 194 59 173 162 204 166 181 114 97 224 92 71 116 144 235 121 221 159 124 218 189 170 239 83 135 28 243 178 223 131 227 17 146 169 220 93 31 64 246 60 114 194 162 48 94 192 255 37 210 128 223 90 148 255 167 134 204 96 230 126 180 73 114 139 161 17 171 76 130 56 199 160 130 180 229 165 79 185 10 128 134 241 79 80 147 118 89 165 116 61 94 67 177 61 154 226 10 230 26 219 235 251 35 12 194 40 38 35 252 251 191 11 198 3 254 127 229 204 232 61 105 255 53 135 108 128 24 78 193 229 23 109 141 167 141 113 72 6 184 7 83 149 143 141 161 13 193 130 105 121 159 72 83 255 218 246 207 168 2 188 251 220 106 202 121 24 137 85 236 151 184 191 38 29 12 123 142 42 244 196 40 124 66 26 203 78 220 166 73 142 150 63 166 17 119 99 243 166 176 210 220 215 118 253 59 143 35 122 222 50 58 29 51 211 19 174 220 236 227 198 71 227 70 156 97 25 76 78 210 252 109 98 200 134 0 148 114 221 154 66 23 196 248 37 253 225 184 18 33 116 236 252 67 236 135 114 205 157 120 160 155 132 133 60 83 40 206 205 65 122 27 3 244 137 119 158 91 42 59 189 57 230 202 3 71 214 181 17 91 237 71 219 25 87 69 187 54 79 222 40 229 9 229 71 160 174 72 187 107 25 142 156 159 128 201 103 230 130 228 230 37 21 220 76 245 164 173 70 236 120 248 32 0 235 8 226 156 150 195 159 49 115 251 27 199 242 115 185 77 140 190 205 244 7 223 191 94 162 200 1 170 101 82 196 36 62 145 104 149 184 123 177 153 15 220 14 50 253 40 5 192 198 227 129 195 234 3 23 1 199 104 182 67 51 17 31 177 252 147 96 76 24 221 202 12 236 136 115 123 75 165 115 55 2 242 194 9 252 13 250 160 95 132 217 253 162 222 168 205 117 26 224 163 41 136 164 32 42 40 60 7 24 87 230 249 31 58 236 150 135 184 249 22 205 31 97 180 112 137 182 250 89 4 221 38 113 74 247 168 206 215 112 54 174 17 124 134 22 229 141 40 117 220 60 36 142 159 28 196 12 79 250 234 136 200 220 192 151 253 59 63 143 176 44 197 118 7 251 9 88 225 69 165 197 229 146 92 13 230 142 60 188 7 204 81 241 42 116 68 128 100 171 169 163 137 188 9 17 212 4 231 195 226 170 216 196 24 94 172 65 211 52 75 97 206 167 143 24 61 168 230 229 31 239 42 70 74 67 179 96 52 199 96 80 117 42 122 92 36 146 138 21 213 65 96 75 175 232 31 107 43 33 91 231 154 123 5 24 28 139 122 138 127 91 147 185 79 21 150 196 39 242 145 196 148 195 22 235 187 30 46 175 109 249 30 33 44 231 138 19 255 207 171 119 184 201 171 190 52 6 187 143 13 176 206 38 141 52 54 14 234 19 13 72 228 115 134 239 231 78 161 68 240 39 189 238 92 137 134 220 92 228 98 165 0 223 127 16 233 228 150 150 183 157 213 170 18 108 187 193 244 40 94 214 27 214 103 133 11 23 106 140 153 150 249 216 192 173 245 226 15 71 223 152 10 15 241 34 209 142 177 116 19 237 153 115 235 149 33 51 8 136 185 42 26 124 13 143 64 6 191 151 249 2 34 136 141 198 23 227 78 45 51 175 180 143 131 177 93 122 47 116 190 243 99 42 32 159 106 87 251 223 159 179 37 63 143 200 173 119 171 27 79 79 149 2 209 224 156 255 224 213 5 208 114 14 166 128 135 141 222 107 146 148 60 212 87 95 249 62 108 29 151 193 171 48 111 202 218 27 135 180 253 254 184 223 129 63 91 60 123 221 98 165 199 70 36 4 155 209 197 95 213 90 27 172 67 75 182 52 134 225 138 50 128 100 245 153 1 73 95 228 92 254 186 19 225 208 85 38 151 24 215 131 149 191 230 74 57 107 248 227 229 111 209 108 16 211 152 104 163 251 128 215 147 85 150 15 43 134 83 159 42 239 54 28 40 73 52 207 84 129 239 98 214 179 21 102 137 178 110 247 152 202 120 33 245 91 121 128 234 177 58 4 101 109 183 205 222 157 164 79 7 109 210 19 253 233 66 110 212 180 156 55 124 37 83 157 36 52 71 108 27 185 118 84 11 222 1 186 180 176 54 75 2 134 10 200 41 247 243 115 198 166 236 142 190 189 239 126 125 106 88 219 213 89 86 112 164 28 237 40 73 163 214 41 167 51 226 144 185 109 128 31 24 46 11 81 151 124 82 134 29 127 35 25 190 38 212 98 223 126 203 32 60 74 103 251 72 156 19 78 206 72 239 13 5 249 184 234 54 28 128 245 0 249 90 69 3 123 98 160 210 186 41 73 17 3 28 112 129 216 217 199 108 97 59 3 225 73 152 69 217 146 229 62 27 45 119 23 226 20 9 145 94 46 115 121 134 233 179 133 155 94 199 108 100 28 131 175 206 140 90 173 14 18 76 19 202 83 159 22 214 223 144 183 119 149 129 120 70 181 99 68 133 35 149 192 17 182 40 216 129 186 185 222 109 72 135 219 119 115 196 249 44 150 83 58 212 26 210 154 53 109 49 36 39 146 188 84 202 107 117 165 30 161 103 160 138 30 154 85 67 10 214 221 117 225 102 176 143 120 211 187 176 196 245 60 28 179 165 154 167 22 55 97 242 45 252 235 170 218 20 43 72 243 201 54 123 101 20 33 48 168 180 233 60 232 203 7 66 56 124 146 214 112 254 140 37 96 243 38 179 116 69 25 227 129 70 166 160 195 95 119 149 251 212 214 138 62 183 247 149 85 11 116 61 189 17 187 149 100 21 248 121 103 245 72 14 36 248 191 128 103 91 132 118 39 131 121 52 247 206 93 47 82 113 11 31 148 91 121 169 110 211 31 34 248 177 165 90 108 123 99 171 35 104 32 238 176 63 65 30 99 58 169 225 58 211 237 4 229 142 123 59 108 223 136 197 220 218 91 179 0 121 93 76 67 65 204 151 161 33 65 74 212 79 82 70 71 34 30 120 110 193 0 36 170 193 44 45 143 228 131 205 150 244 160 150 106 22 65 152 121 20 125 25 104 52 133 104 165 184 88 121 83 121 93 99 250 114 15 118 56 143 178 96 88 189 162 5 211 244 73 153 40 207 205 71 138 167 60 186 201 213 118 68 181 199 75 78 195 34 132 17 127 183 98 72 65 22 255 140 196 232 205 157 2 110 42 175 37 4 30 101 25 242 48 107 25 105 159 30 213 210 157 118 121 51 157 187 180 131 3 44 5 185 15 215 79 162 2 26 65 168 188 175 126 122 46 117 97 63 225 223 18 22 211 203 44 218 82 158 29 119 110 57 91 14 143 66 109 2 240 56 94 247 35 47 101 146 49 98 29 193 204 226 150 16 203 189 11 251 203 208 29 186 250 218 53 107 74 41 140 45 140 4 31 27 113 69 36 188 128 46 81 132 34 77 101 50 169 28 156 133 164 129 253 215 241 194 174 172 194 42 220 190 205 227 223 125 42 185 109 222 61 100 144 193 147 66 193 232 72 220 164 225 179 24 189 206 106 11 94 84 43 63 244 25 229 114 152 79 232 252 147 54 43 138 6 104 248 81 78 162 136 226 36 206 113 106 248 66 115 193 28 216 164 130 112 222 54 251 213 143 169 214 127 195 37 79 48 191 31 239 222 47 54 197 188 194 74 4 90 50 70 38 100 59 49 223 218 178 37 231 49 12 152 217 227 91 99 20 154 159 152 122 106 149 86 103 187 70 156 1 251 186 172 207 166 67 51 147 24 159 0 66 193 212 209 173 202 54 121 186 247 106 241 139 248 136 144 151 199 247 80 188 144 101 75 21 223 57 158 220 219 236 232 23 100 202 212 173 34 206 147 90 245 218 205 94 143 37 178 123 245 10 207 222 177 255 205 243 59 2 92 205 14 246 210 227 42 114 60 115 43 247 225 110 54 179 180 171 8 226 94 227 206 84 12 108 245 165 220 186 62 202 190 198 31 48 221 104 253 145 8 22 239 235 157 224 89 115 154 66 225 233 26 132 65 101 103 113 198 133 195 218 235 163 15 66 48 130 138 254 104 191 21 132 73 188 3 18 49 233 212 33 173 203 85 255 167 237 129 60 173 232 204 54 14 112 18 11 20 121 253 133 205 30 128 169 42 1 114 138 184 35 247 111 197 232 255 8 125 197 39 27 123 188 217 183 113 101 115 55 200 76 41 136 182 194 36 115 226 46 180 223 15 180 184 199 127 207 175 183 18 108 253 224 68 225 189 230 145 197 113 58 99 64 169 236 231 55 89 138 194 172 139 126 15 235 114 7 190 146 185 206 38 26 160 116 201 4 85 157 75 151 138 219 4 150 5 192 67 120 123 231 151 29 125 34 237 37 125 175 14 219 63 40 148 37 198 227 142 220 5 165 190 80 20 226 226 188 106 110 189 68 213 83 144 111 161 33 212 140 77 52 244 117 247 254 247 134 221 112 95 223 125 162 95 247 113 127 148 138 20 251 103 234 125 73 19 94 81 44 249 114 11 173 196 15 63 229 13 115 251 195 11 98 206 183 202 33 193 89 219 11 110 155 116 53 252 253 48 32 153 170 120 19 185 239 38 248 134 53 99 79 234 178 251 112 68 87 151 119 91 159 228 132 234 207 90 233 251 86 23 140 87 198 204 228 239 33 97 205 23 105 57 191 169 94 234 175 182 54 157 209 165 39 1 23 153 99 4 83 250 118 150 110 225 141 205 108 23 85 157 117 151 134 213 237 178 162 80 51 220 165 2 220 8 167 35 52 225 141 195 156 254 21 76 95 231 237 249 231 199 223 249 56 16 105 49 246 179 86 86 199 222 103 162 50 165 41 77 133 132 4 246 90 221 161 237 175 20 1 224 5 208 134 151 85 245 81 241 166 113 128 176 170 18 208 148 167 107 165 84 201 247 77 110 178 243 212 76 28 185 151 25 3 254 91 135 233 7 181 194 191 189 100 178 100 20 92 126 239 85 113 127 203 20 251 252 161 1 63 35 197 97 30 51 62 136 236 104 162 216 84 86 49 130 181 92 215 169 183 20 181 106 88 75 233 118 139 43 234 2 58 27 15 194 152 140 103 217 39 100 170 4 96 201 205 75 153 189 203 211 117 177 25 176 204 93 16 68 7 53 84 183 210 189 91 68 187 188 136 34 168 145 152 249 26 42 26 225 31 239 15 249 137 120 247 29 172 107 103 137 180 207 217 121 27 149 32 90 137 141 176 165 165 165 165 1 0 0 64 0 0 172 94 103 33 181 100 23 240 0 0 0 114 0 0 25 110 0 0 0 0 0 16 49 217 0 0 7 90 0 0 2 148 0 0 0 0 15 0 77 121 80 108 117 103 105 110 54 56 75 46 112 114 111 106 0 1 220 45 77 77 80 82 67 87 73 69 1 0 4 110 0 1 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 37 135 0 0 9 73 0 0 0 0 15 0 66 193 212 169 9 210 149 55 104 18 166 123 198 254 115 231 189 56 26 63 233 107 89 215 26 41 64 39 168 254 239 247 106 245 213 179 37 162 85 150 47 25 75 142 73 147 42 103 39 18 89 87 185 158 183 144 191 121 197 58 247 237 47 168 4 250 221 80 196 140 250 2 153 82 24 7 101 152 165 56 154 236 133 124 32 161 65 134 202 240 234 38 74 220 207 29 183 187 78 143 128 78 228 25 224 83 50 226 241 200 15 193 111 178 15 246 78 206 228 147 246 197 203 10 10 242 105 41 4 66 205 9 1 225 252 22 138 140 209 6 181 240 179 154 27 24 6 94 118 33 215 71 251 65 6 46 194 156 224 245 152 248 245 163 117 106 184 81 55 44 43 63 12 15 131 173 177 63 58 108 90 116 237 57 130 18 45 207 39 168 184 124 14 234 151 77 158 24 238 174 149 45 154 30 127 131 200 231 47 199 96 208 217 78 147 104 4 219 175 174 33 142 236 210 130 219 100 211 116 254 15 231 119 8 95 0 178 98 122 210 142 229 104 67 70 12 175 141 92 58 110 110 125 213 36 115 84 117 144 245 75 148 181 55 130 172 219 99 192 169 188 102 174 245 3 98 201 249 187 198 155 60 173 205 234 41 227 58 211 109 39 124 98 234 206 156 15 73 86 25 233 109 125 254 184 178 214 178 133 136 246 117 48 173 55 248 26 8 190 78 97 200 67 23 26 223 148 9 135 229 250 93 43 221 207 238 48 11 146 126 167 202 57 129 122 208 16 68 11 171 85 193 55 197 75 206 6 101 225 159 104 37 53 24 149 113 98 108 118 35 180 159 124 25 241 188 82 51 147 186 228 19 144 214 103 241 33 199 95 1 89 148 121 49 217 177 30 75 206 83 68 131 49 235 210 72 87 124 132 117 54 28 248 36 131 82 144 238 147 41 18 75 146 21 97 35 176 24 27 156 45 171 65 232 213 217 183 86 97 199 127 122 105 229 192 146 21 171 163 104 83 164 85 85 159 97 16 133 250 117 123 35 109 109 221 183 95 120 25 237 167 23 213 43 6 178 186 44 154 201 162 86 26 136 87 11 90 163 230 224 102 104 162 19 246 228 233 218 91 12 199 141 183 74 205 224 12 153 150 177 85 0 41 202 28 63 57 160 34 129 152 15 10 240 140 213 45 91 151 230 63 252 32 81 62 58 251 113 147 52 74 212 214 30 114 32 135 185 204 7 224 181 26 172 91 169 81 65 140 201 52 185 195 170 193 233 103 214 112 109 65 219 94 83 253 182 167 152 47 211 90 104 203 34 241 216 55 162 73 128 24 254 18 243 43 51 199 224 93 181 216 4 195 100 21 1 142 111 89 99 181 120 228 69 89 150 166 67 160 133 83 74 25 120 228 202 151 213 197 238 169 7 25 75 215 132 139 13 128 148 42 185 174 244 128 76 188 161 166 164 16 51 147 115 251 235 205 105 232 86 142 76 237 244 167 29 43 177 248 156 194 246 97 15 7 255 213 141 41 156 105 175 207 13 3 192 68 119 2 85 97 230 126 53 40 79 97 45 221 168 205 66 34 36 28 180 173 22 22 180 51 194 56 193 255 243 75 101 57 141 155 154 6 150 42 8 180 204 128 177 95 60 122 220 131 125 225 225 49 227 224 60 187 72 148 80 225 109 173 250 161 103 80 190 248 119 106 225 182 172 156 189 14 39 39 172 51 134 119 87 74 119 174 13 184 80 179 206 211 203 197 4 98 108 88 244 9 167 90 0 179 111 74 175 93 37 151 71 255 226 242 57 3 70 223 10 238 143 109 72 108 218 5 38 140 97 70 133 196 185 229 124 137 190 203 76 81 53 60 4 82 244 201 125 216 66 13 237 218 214 208 120 143 242 251 23 135 220 72 32 82 237 68 189 70 62 224 254 70 62 224 229 134 119 188 130 31 152 255 212 226 149 189 221 60 223 148 73 202 157 18 249 54 56 126 101 207 255 58 91 68 133 67 118 98 230 235 242 45 38 75 183 17 235 204 212 204 222 45 249 140 101 163 86 59 125 195 111 43 228 127 205 120 199 85 241 203 115 36 38 114 138 200 134 12 65 52 23 170 58 186 89 15 23 144 208 141 125 252 131 154 213 103 133 164 20 24 181 20 212 220 255 114 55 158 205 47 147 146 107 120 61 236 170 84 104 212 61 32 201 252 208 92 120 214 182 30 6 28 5 1 22 67 109 244 114 222 27 168 58 178 108 199 187 12 57 225 72 255 253 245 130 250 31 222 250 246 10 101 46 52 182 55 251 253 245 81 49 245 105 93 45 82 221 74 249 125 1 22 82 12 24 109 64 86 153 199 117 92 85 16 118 131 199 159 35 198 115 25 194 53 204 76 60 91 61 99 94 137 235 45 223 47 205 83 53 161 9 165 132 157 86 145 51 163 200 190 148 205 153 118 167 140 3 86 133 127 81 179 26 56 173 105 221 157 174 25 29 252 191 134 231 205 247 66 63 40 168 20 174 40 253 99 88 50 93 57 46 77 42 38 230 44 152 237 96 246 158 174 127 80 223 21 171 208 218 64 83 60 6 39 178 161 246 16 149 28 35 238 182 210 44 48 166 87 16 17 60 128 20 135 242 84 199 79 197 192 216 159 45 88 172 97 28 155 254 95 247 229 19 84 119 64 208 127 23 119 239 50 27 133 55 86 37 222 63 40 63 237 92 219 43 139 185 171 144 78 174 41 45 134 33 179 81 222 241 244 47 230 107 206 53 93 206 223 25 220 198 187 145 188 22 208 189 21 158 201 29 156 207 162 236 106 151 65 58 250 220 39 200 228 244 143 101 56 32 72 194 32 92 161 170 95 226 91 247 74 68 91 243 111 13 53 30 159 155 43 194 142 72 76 100 240 231 155 202 2 170 87 103 101 137 13 158 138 204 152 21 128 163 227 158 239 113 74 203 205 138 28 253 172 176 47 237 128 246 167 129 252 181 12 189 44 9 25 249 55 100 198 20 247 11 221 58 43 244 154 235 66 177 195 182 215 227 81 34 233 12 208 171 215 60 228 237 247 68 237 254 101 72 11 189 214 132 0 237 192 83 247 146 44 29 115 128 161 61 99 89 134 224 142 199 58 193 76 75 167 233 190 242 240 211 62 140 149 132 19 231 30 187 11 119 216 16 130 123 220 109 76 105 8 8 51 177 93 127 176 168 236 224 185 239 147 241 252 89 235 117 89 232 240 134 105 5 97 209 251 211 122 163 130 146 101 27 0 163 26 227 99 143 189 100 252 184 92 204 15 249 41 66 137 162 186 236 108 107 110 37 6 27 122 43 43 183 9 177 188 52 107 174 190 52 142 8 234 72 246 140 207 86 16 62 58 111 246 174 164 206 167 225 25 226 156 194 36 44 43 216 74 52 246 175 115 93 50 77 141 193 52 62 121 123 202 32 231 159 172 154 127 94 71 139 59 99 60 95 93 5 219 230 131 152 119 71 166 108 172 186 159 236 122 151 241 89 190 225 248 70 6 59 222 41 63 1 165 51 242 86 140 13 190 182 4 62 76 202 29 142 235 136 247 213 221 89 87 129 198 64 125 243 139 125 99 248 77 77 161 154 149 206 132 228 19 219 21 20 117 100 106 17 25 129 82 47 223 238 149 91 209 180 62 152 199 225 74 120 88 182 193 105 50 55 18 249 249 177 21 79 110 42 239 129 88 200 29 133 34 98 15 45 175 191 221 140 248 216 149 245 89 166 178 80 182 78 190 69 50 222 205 239 161 190 224 7 58 209 212 252 3 217 253 195 183 64 52 49 155 161 91 219 253 14 98 134 170 152 67 190 151 34 0 244 30 29 40 140 166 74 48 227 156 179 126 37 235 250 104 255 27 136 65 183 130 244 43 240 35 123 226 134 15 235 124 3 209 133 214 35 208 2 203 15 238 71 79 163 249 77 38 232 160 127 174 99 90 151 104 248 47 21 102 40 10 75 7 38 213 12 191 187 208 175 51 104 120 67 247 117 94 241 128 200 6 166 210 115 55 169 169 217 14 21 75 98 182 140 181 241 103 66 242 210 58 92 215 100 223 168 223 224 23 185 68 213 123 36 81 24 49 168 209 69 245 79 245 26 172 28 132 233 201 18 122 188 2 206 212 185 33 163 205 123 122 253 31 107 244 225 171 154 126 238 192 76 97 3 130 6 136 89 106 53 55 117 226 25 20 196 35 147 112 210 205 162 106 50 158 32 159 46 222 213 182 51 197 240 80 51 244 161 110 150 205 10 210 29 211 191 134 8 62 165 173 11 212 161 149 21 59 192 148 10 206 136 162 153 70 254 239 231 184 38 59 63 15 77 159 36 158 37 220 110 219 185 101 189 130 102 113 59 89 8 251 111 16 111 199 206 9 183 37 71 67 15 254 146 122 128 22 246 172 83 255 83 89 0 246 254 92 199 238 49 177 50 56 60 7 47 70 50 98 209 93 12 210 64 75 186 162 82 59 16 42 28 252 150 217 13 179 131 109 44 168 155 109 124 107 172 34 39 56 93 136 156 226 51 195 139 240 86 22 205 163 244 246 122 13 115 134 172 202 203 8 83 178 251 160 6 219 89 67 181 18 209 214 63 231 59 24 227 158 23 7 240 58 71 177 7 113 158 183 64 244 85 7 107 227 60 68 82 254 89 181 121 244 154 127 239 164 100 253 201 24 40 247 95 2 117 74 39 105 8 93 65 60 200 39 164 174 113 104 28 234 29 2 248 240 139 89 240 62 145 199 95 144 239 95 112 133 161 248 7 69 77 160 179 10 214 118 130 47 36 196 113 185 107 12 184 128 166 184 156 240 64 39 22 137 148 42 166 209 186 106 148 29 222 181 182 12 140 98 107 232 202 192 126 214 67 12 90 3 7 248 95 36 76 59 188 66 63 98 47 55 72 103 196 189 55 155 89 36 43 7 171 26 228 14 129 26 180 143 57 83 243 131 55 10 86 141 23 182 84 53 42 118 71 72 221 140 17 103 43 14 243 168 38 236 161 104 222 196 131 99 100 2 95 182 238 89 158 129 168 152 135 33 197 190 201 123 56 211 17 219 71 63 164 17 28 210 229 135 70 215 21 37 111 40 118 238 71 231 185 92 225 238 138 15 196 191 125 76 175 41 229 73 155 45 56 91 234 166 249 104 4 179 127 38 179 30 101 157 148 54 199 109 249 21 239 65 56 118 173 182 77 172 225 67 185 168 180 146 85 179 50 125 131 216 129 42 197 47 124 221 171 199 98 155 4 245 181 64 165 225 148 159 88 65 126 225 27 188 72 65 126 66 80 88 14 250 23 35 36 212 224 92 173 32 66 193 212 120 244 150 156 45 75 143 253 186 160 103 148 110 138 210 209 163 125 11 126 208 172 225 255 129 97 133 7 117 173 34 14 198 74 241 119 114 179 69 78 241 172 212 89 124 91 120 8 205 235 82 98 142 194 32 245 179 201 44 162 110 214 68 254 158 4 147 19 254 191 118 156 232 12 254 184 209 40 217 121 173 182 158 0 168 203 19 227 183 248 42 166 119 134 20 184 72 174 2 197 58 133 29 213 233 74 101 1 85 71 25 150 55 32 225 207 234 168 1 132 48 188 104 84 53 145 212 222 88 12 164 128 218 29 207 78 77 249 16 88 28 232 164 142 192 159 5 8 135 38 217 75 132 1 169 131 180 254 194 85 160 186 146 180 24 82 91 133 163 169 12 134 152 70 138 133 74 186 173 245 88 137 116 233 235 3 118 28 107 126 133 54 54 53 235 170 9 149 65 194 190 72 136 43 247 87 106 245 14 28 216 174 131 61 75 2 32 48 18 90 42 185 42 139 107 94 143 236 239 204 214 131 5 194 198 84 239 253 129 60 182 156 134 15 194 224 152 87 64 148 238 6 49 222 188 124 178 199 34 127 212 174 139 147 19 174 19 177 25 35 173 239 20 162 133 142 35 21 226 49 117 215 117 82 150 137 206 32 224 106 132 88 229 130 225 121 252 199 118 93 193 14 161 171 76 13 36 30 78 89 226 51 243 117 178 220 71 194 253 155 147 117 169 112 214 170 151 80 176 47 113 137 200 71 128 223 66 205 149 141 14 174 254 215 224 212 209 129 71 42 114 80 117 179 6 107 207 86 126 92 5 186 201 125 182 1 242 50 66 210 232 200 192 245 137 242 31 142 235 147 161 97 3 161 124 80 122 86 211 86 19 222 78 188 48 94 226 5 28 139 115 71 189 71 214 76 63 3 208 118 242 103 42 218 166 31 193 172 90 1 221 207 45 41 132 69 109 253 53 20 18 46 39 129 112 108 97 15 218 100 16 0 87 235 39 246 68 156 112 218 135 240 49 235 29 171 113 255 41 197 77 237 159 181 64 19 122 215 56 164 218 187 2 68 137 251 240 202 132 181 223 81 212 100 47 233 101 78 16 141 85 48 151 108 6 121 86 47 13 210 187 225 178 157 228 22 177 139 131 77 189 136 67 214 106 21 35 156 24 206 241 20 160 172 42 105 163 82 42 95 198 28 128 214 182 183 18 226 9 84 238 73 67 7 6 79 149 143 81 6 165 26 204 217 230 127 245 25 64 156 2 31 40 230 31 152 83 16 27 19 48 88 183 13 234 44 214 230 142 115 130 245 184 253 244 91 188 169 175 129 42 172 27 94 36 204 250 103 164 187 225 237 171 117 127 191 201 200 10 17 53 9 251 134 12 155 134 192 93 150 96 13 18 25 200 160 243 9 207 137 253 198 235 76 86 159 204 94 141 69 7 244 119 142 65 54 80 199 204 199 217 168 184 53 128 33 0 165 165 165 165 1 0 0 59 0 16 181 174 127 194 181 175 1 132 0 0 13 31 0 0 27 191 0 0 0 0 0 11 26 238 0 0 2 170 0 0 1 124 0 0 0 0 15 0 83 113 117 101 97 107 65 112 112 46 114 0 1 48 155 84 69 88 84 67 87 73 69 1 0 255 255 255 255 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 1 154 0 0 0 104 0 0 0 0 15 0 66 193 212 165 47 158 104 38 183 219 249 217 33 168 151 12 136 53 189 184 158 14 233 171 185 188 252 36 85 186 68 105 32 221 147 163 179 129 148 246 162 31 24 235 185 98 218 101 160 56 155 179 209 51 153 16 169 186 131 139 49 67 115 239 159 135 201 102 194 30 232 134 74 94 72 73 53 209 51 0 164 170 218 80 239 206 105 215 91 90 51 83 245 201 43 25 56 235 71 7 130 202 80 0 66 193 212 157 170 210 35 52 27 93 136 197 106 52 54 31 166 122 205 231 32 32 112 160 40 138 126 3 77 99 4 251 242 199 125 87 169 103 99 226 123 60 70 128 113 18 28 85 6 189 121 109 31 26 249 161 83 169 157 62 74 239 8 51 45 186 94 58 49 252 46 209 169 153 202 106 248 205 178 15 4 139 59 160 209 168 125 168 73 48 103 120 110 199 109 171 159 179 239 33 94 118 136 247 133 234 179 177 46 218 151 77 116 44 159 93 94 44 99 70 93 125 137 53 84 131 32 59 239 13 28 34 65 92 91 104 119 79 119 174 134 219 228 67 30 37 182 200 207 220 0 237 187 20 146 233 200 152 182 39 167 14 242 53 180 240 195 154 154 94 91 182 52 134 249 136 119 67 194 147 228 97 60 211 48 22 65 190 202 99 103 114 208 10 131 161 3 87 31 64 250 4 254 133 169 217 77 183 225 106 142 240 240 180 146 248 39 192 170 88 102 69 95 13 89 148 174 206 78 162 131 133 161 167 150 32 158 248 178 173 101 227 217 102 143 206 171 62 75 41 237 239 9 58 126 14 226 107 122 250 208 40 209 10 252 105 101 26 155 10 18 126 136 104 210 186 8 64 134 82 245 212 110 151 241 61 69 16 181 128 165 251 123 137 63 121 161 161 183 56 176 164 4 136 161 23 48 88 225 129 48 129 37 151 67 233 215 152 90 89 82 27 227 240 224 102 238 138 80 14 201 181 17 19 136 193 127 207 108 171 212 101 238 237 175 10 248 251 8 248 107 203 87 203 119 235 140 103 161 208 168 170 55 199 88 185 214 52 170 233 214 179 94 170 196 230 181 174 40 0 165 165 165 165 1 0 0 68 0 0 172 94 103 33 181 192 88 206 0 0 25 110 0 0 52 58 0 0 0 0 0 20 153 121 0 0 95 218 0 0 14 61 0 0 0 0 15 0 83 113 117 101 97 107 73 110 66 114 111 119 115 101 114 46 112 114 111 106 0 1 103 92 77 77 80 82 67 87 73 69 1 0 255 255 255 255 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 43 99 0 0 9 200 0 0 0 0 15 0 66 193 213 34 167 232 170 96 73 254 125 109 219 133 91 226 173 79 60 72 84 69 81 149 82 193 195 62 243 118 100 84 239 248 172 131 161 136 154 59 198 96 8 244 185 108 41 50 222 100 82 26 215 37 53 108 220 21 203 219 50 66 180 190 240 141 157 173 170 51 45 136 236 170 181 44 84 47 113 175 150 67 195 75 236 38 36 167 98 30 128 9 4 41 81 183 33 61 198 230 33 33 195 250 238 170 88 161 29 121 215 132 249 179 85 186 248 47 89 143 35 147 13 241 188 47 106 188 213 166 78 146 43 51 69 235 43 123 213 57 185 38 233 121 77 22 85 192 31 62 122 83 240 101 109 114 223 183 50 167 38 210 143 43 59 159 239 99 72 61 124 93 191 17 21 83 3 152 165 163 27 121 26 80 54 26 252 240 48 4 84 254 49 236 152 0 103 136 176 199 240 231 0 194 156 73 207 15 40 147 116 179 184 5 5 136 95 237 112 137 98 147 232 94 70 169 140 6 38 233 82 238 90 178 104 247 205 99 160 29 2 244 112 1 102 227 165 33 98 62 144 81 48 112 194 159 232 104 107 9 234 39 163 254 174 8 179 133 36 15 64 6 127 201 175 184 95 26 128 250 3 254 214 205 44 226 99 194 21 234 107 90 77 26 63 72 211 192 220 142 63 104 189 115 120 208 168 6 20 59 32 49 42 156 170 101 144 121 106 2 6 248 154 32 163 150 233 170 134 166 28 209 215 205 3 25 81 239 109 122 95 124 97 23 247 91 178 236 59 254 102 182 86 238 105 102 201 185 89 42 29 235 233 127 96 56 84 85 170 216 13 61 54 236 10 174 146 165 113 230 253 188 205 13 160 113 165 217 127 153 113 145 3 81 155 44 85 123 48 191 148 49 61 113 83 28 196 245 22 152 167 135 24 210 146 195 155 64 50 69 230 199 214 97 69 98 22 167 2 7 61 68 222 242 25 237 175 203 226 122 144 173 149 129 72 126 105 119 160 153 101 226 214 106 226 164 129 176 215 112 221 78 69 152 245 75 166 51 20 51 94 133 150 157 123 112 129 194 53 100 194 125 123 241 192 205 208 243 18 63 160 206 168 132 79 71 253 76 89 221 100 213 42 225 139 183 137 94 174 83 19 147 113 99 133 59 62 216 64 182 144 131 214 164 151 238 16 75 240 56 4 3 194 72 101 70 155 58 114 37 71 113 205 90 148 234 228 253 91 181 193 210 197 186 107 39 157 180 87 72 45 153 204 109 187 145 107 217 38 219 248 164 171 146 117 141 43 3 105 255 126 119 16 102 203 167 63 148 44 32 214 73 202 7 111 121 175 193 163 185 101 66 137 200 21 225 76 192 228 15 124 219 249 221 50 204 210 144 224 107 121 231 51 174 29 32 1 24 22 233 26 90 61 246 36 93 169 151 177 160 222 171 223 198 204 121 12 254 228 102 158 174 158 60 207 115 92 255 234 192 73 250 14 63 97 204 177 209 67 137 2 92 155 69 72 73 106 32 144 187 92 150 178 223 187 214 208 180 8 134 236 156 93 168 142 15 184 65 222 195 116 76 148 64 134 244 240 116 207 171 233 133 234 180 228 244 83 195 166 244 191 127 224 183 237 240 221 61 42 239 234 246 81 217 79 17 126 234 252 215 240 252 68 247 147 209 132 101 0 102 72 133 23 214 229 252 119 27 130 211 103 142 159 198 238 246 86 229 235 108 226 71 22 224 70 236 26 110 142 61 33 6 218 50 186 146 104 251 177 98 66 156 38 82 60 80 231 227 52 31 89 147 105 121 183 88 2 254 69 76 66 227 65 236 223 60 217 12 98 12 19 104 147 45 196 11 240 191 107 162 239 211 166 44 41 249 39 37 63 131 158 97 247 131 129 244 22 112 218 137 123 26 15 243 2 182 190 153 209 112 8 135 78 189 236 94 158 54 199 68 222 176 75 80 118 44 130 210 38 124 197 161 122 197 40 223 224 186 158 200 128 140 152 136 210 37 103 180 217 56 77 18 191 65 83 243 71 174 176 56 156 55 186 91 193 189 72 99 194 241 223 83 16 18 36 127 111 244 32 116 144 212 11 152 136 20 25 71 73 141 81 48 132 238 222 101 79 109 211 6 94 240 82 117 99 67 1 158 172 228 182 48 42 250 91 145 204 104 115 51 24 2 235 209 127 112 71 109 172 75 167 216 207 47 118 227 119 254 51 22 159 247 168 93 42 138 74 227 79 143 50 129 172 150 126 149 88 29 57 40 39 155 51 217 207 188 37 166 138 104 87 180 47 247 57 71 98 69 164 178 190 179 15 236 99 230 33 120 112 14 117 178 125 170 196 51 249 210 32 70 222 9 192 150 12 116 148 255 37 212 77 222 201 196 51 191 234 89 33 236 189 101 14 124 148 160 149 221 45 103 7 22 10 193 2 228 76 34 36 20 29 5 141 248 124 47 6 159 53 130 140 66 124 100 130 251 89 227 179 247 81 101 146 156 137 197 215 142 213 63 237 98 34 232 170 15 43 117 149 33 108 109 17 54 51 16 50 44 2 34 122 22 164 103 189 10 38 71 187 83 159 162 62 46 245 228 103 212 102 180 202 7 163 106 252 104 98 47 227 140 130 195 68 252 232 227 17 111 112 180 119 186 253 143 246 189 114 125 173 4 142 73 116 112 240 253 154 94 10 22 98 155 32 98 52 250 134 13 164 13 250 243 153 77 233 17 89 170 177 62 205 50 107 249 213 254 119 54 110 201 2 66 120 6 72 18 241 126 66 4 53 68 160 231 107 171 202 144 220 176 103 66 217 82 82 198 51 124 239 193 203 28 202 168 180 143 253 110 106 202 216 204 124 170 170 134 250 206 148 180 130 105 7 212 153 173 74 14 138 49 205 172 243 7 239 116 117 52 67 227 155 135 50 207 18 183 1 78 221 99 35 155 64 166 27 145 7 134 169 166 186 139 30 195 144 225 72 240 97 115 199 74 17 15 212 44 103 26 48 41 242 15 105 219 134 238 188 233 232 20 11 91 88 254 65 86 161 147 173 111 156 248 34 122 142 162 88 82 252 62 124 49 86 32 49 241 111 189 76 248 145 251 15 194 36 35 218 174 121 252 64 170 226 77 111 29 50 236 224 177 241 185 255 219 186 172 136 213 222 154 48 237 168 101 222 205 180 92 47 220 253 189 241 32 200 243 128 30 58 250 11 252 8 203 216 76 202 167 20 34 181 123 219 129 193 40 197 197 210 75 139 151 188 42 41 127 7 90 139 69 214 4 72 107 7 112 65 182 1 239 74 239 51 173 169 166 130 95 25 4 3 183 225 64 100 47 243 225 242 24 109 201 75 96 182 28 87 112 94 111 24 18 74 202 69 46 71 222 230 176 94 154 169 221 58 60 208 251 1 199 26 238 60 250 63 35 143 164 195 118 102 26 246 178 104 121 21 132 106 90 238 183 214 166 7 129 38 26 24 161 214 93 46 167 114 235 51 84 139 165 108 221 95 254 251 204 149 172 30 42 138 143 218 222 230 61 126 132 156 186 75 0 193 131 148 163 22 243 69 109 202 235 200 67 69 241 76 65 94 144 147 126 133 55 212 204 107 220 44 235 205 19 254 9 248 98 225 208 149 165 223 6 51 120 195 149 186 131 239 72 174 207 27 204 102 201 171 45 68 92 4 76 199 184 96 176 177 5 144 28 240 12 207 211 135 147 179 50 12 234 125 29 194 157 151 86 235 143 195 236 225 73 109 168 86 167 106 97 112 133 105 4 252 186 207 134 211 73 3 162 110 134 96 204 0 243 82 152 0 39 134 196 55 172 181 168 171 234 161 89 155 63 233 141 144 114 83 212 58 241 128 45 212 8 31 238 245 143 225 247 59 2 114 227 60 153 162 91 228 131 154 117 60 208 209 129 119 131 243 132 26 91 189 99 112 51 115 140 190 79 96 231 231 42 168 189 10 40 35 101 218 21 238 249 99 69 71 43 92 41 233 98 9 183 204 140 47 155 121 197 204 27 52 38 0 184 189 1 80 212 206 164 8 4 105 184 116 254 165 76 151 50 180 144 40 14 78 109 44 46 18 156 161 162 46 248 14 57 178 96 71 87 210 247 225 51 204 42 71 144 255 10 49 68 88 60 33 218 87 35 85 166 236 3 93 156 130 121 41 50 6 47 76 4 88 154 243 127 160 118 8 39 27 69 130 201 211 215 204 171 5 42 182 80 125 87 73 253 8 248 76 114 89 25 126 228 185 105 83 174 81 25 67 128 13 193 121 182 27 140 240 93 235 42 117 238 100 15 168 212 5 11 252 113 215 196 140 32 127 69 82 203 103 117 199 108 170 121 159 120 194 230 1 202 20 79 79 146 18 171 140 88 90 23 158 150 31 69 99 196 240 245 161 35 65 171 81 80 67 174 134 79 191 177 52 247 188 169 163 188 158 170 20 230 84 197 27 148 212 122 204 156 46 202 243 128 71 81 154 3 216 49 164 36 74 64 252 145 2 71 64 173 35 220 27 114 224 97 175 86 133 68 210 184 214 59 239 149 213 28 106 2 250 14 15 2 178 236 34 212 149 18 247 151 15 113 248 88 180 45 32 238 115 186 167 173 159 254 150 72 85 21 26 142 39 52 92 160 72 25 71 236 166 154 18 95 171 223 49 118 165 14 157 250 1 174 233 101 178 138 165 195 68 236 169 115 0 27 7 118 131 24 248 96 95 130 158 153 178 178 67 17 11 81 181 123 110 241 196 62 203 69 185 46 93 247 49 87 16 231 0 210 223 112 219 34 230 28 83 98 1 112 4 251 145 237 209 187 179 152 228 78 162 166 107 166 82 102 164 153 167 122 206 87 54 156 168 231 152 204 172 142 90 169 111 121 71 62 194 28 126 194 19 5 110 49 225 70 135 91 221 194 210 237 201 33 177 123 252 64 190 50 162 245 161 163 48 56 188 69 137 31 117 107 28 51 145 58 82 87 109 172 229 116 20 134 19 204 182 61 118 243 236 190 49 238 253 251 53 61 16 212 101 8 215 165 64 123 203 83 168 95 48 64 209 235 197 213 186 206 123 7 104 152 214 78 36 192 226 235 176 135 179 55 227 220 182 208 109 194 184 126 193 218 39 152 187 203 125 249 182 124 155 110 132 54 134 238 247 130 248 192 251 81 222 71 14 212 169 243 105 94 13 213 255 78 164 23 16 75 150 25 235 84 154 34 87 251 212 195 53 236 106 25 73 128 140 57 6 148 248 205 213 12 143 228 113 19 235 5 77 72 51 126 79 218 10 0 1 121 41 34 18 29 67 89 221 67 50 90 121 69 17 163 184 29 180 230 17 143 172 200 69 31 144 224 203 81 189 177 99 86 115 36 198 59 133 191 147 154 206 213 33 211 160 80 201 180 183 34 241 132 245 7 103 81 244 205 231 207 239 192 37 249 138 46 4 27 50 106 215 153 252 38 7 208 27 53 164 77 189 113 48 205 87 135 42 23 170 37 252 217 147 234 177 5 141 10 247 162 152 128 128 21 161 121 109 166 103 96 236 9 248 125 64 91 175 238 188 244 21 163 162 203 40 188 44 76 255 24 229 68 168 155 17 46 224 154 17 150 78 213 144 0 66 193 212 210 108 229 211 185 50 163 125 227 237 145 120 79 89 27 32 142 106 58 64 12 158 0 71 68 58 113 24 81 4 16 174 92 12 198 221 223 102 6 169 131 127 129 105 197 82 81 89 229 183 209 64 139 197 242 244 108 83 157 79 54 254 251 225 61 167 216 21 215 226 105 101 225 7 161 178 76 212 124 148 181 135 120 125 154 179 190 245 216 203 187 235 99 129 241 55 117 94 47 175 195 176 55 212 221 184 84 161 142 233 245 56 147 38 138 58 77 201 191 102 6 157 232 64 228 225 105 104 219 244 66 175 84 250 238 210 215 212 237 18 185 240 27 19 92 65 103 153 5 83 116 120 255 198 73 132 46 195 161 140 200 161 156 139 69 55 142 122 174 8 99 198 217 92 9 207 80 24 176 179 188 78 192 168 237 112 183 118 200 87 45 153 111 8 223 87 10 36 21 141 245 241 158 17 52 70 16 189 190 197 187 19 167 51 4 214 137 38 214 46 73 105 207 42 146 109 217 132 252 171 239 241 211 219 202 29 115 86 61 184 177 92 239 59 53 62 207 200 24 181 70 176 38 98 212 77 77 237 27 167 187 17 85 1 239 132 45 224 186 10 242 62 209 134 108 106 248 190 17 205 167 1 199 154 8 102 146 47 110 235 249 113 53 116 4 209 187 97 115 123 119 111 231 234 232 233 92 221 133 131 113 255 185 187 221 152 111 126 54 18 83 97 246 168 179 65 89 157 3 199 108 172 31 200 6 228 177 8 192 6 122 78 249 9 79 175 199 12 161 22 85 212 99 214 21 219 154 136 244 248 163 152 218 23 5 242 129 115 67 31 10 186 120 60 58 105 88 93 196 115 101 200 103 42 150 19 195 104 56 30 230 167 133 60 21 110 186 168 12 51 203 198 14 119 109 60 183 141 59 203 181 114 53 174 148 81 178 69 175 56 89 195 110 42 145 176 191 85 248 60 178 173 103 214 104 125 214 141 223 178 32 58 152 73 198 1 71 8 132 152 113 93 30 240 145 200 143 3 233 99 212 165 130 12 138 15 23 78 120 158 172 105 218 177 246 23 180 88 25 39 231 236 77 130 13 220 144 95 97 208 216 158 81 152 40 199 212 225 51 3 80 10 67 20 214 252 183 35 153 64 27 164 20 48 120 177 95 167 68 33 149 229 7 155 241 77 229 39 138 14 219 237 228 102 122 128 122 21 179 248 223 110 159 88 219 59 8 209 58 194 150 102 90 129 77 23 198 139 56 46 163 119 251 178 122 239 214 169 119 167 77 77 65 4 105 160 110 217 239 132 155 84 120 97 13 109 75 14 32 98 205 175 37 191 174 27 87 55 172 121 201 153 245 18 8 127 148 227 29 241 63 95 201 126 250 13 32 215 159 15 69 21 159 218 204 183 173 196 54 168 77 139 46 103 4 73 227 51 127 238 153 141 118 186 62 5 24 53 202 125 158 243 68 203 38 151 0 222 24 134 182 32 155 43 247 22 123 165 247 34 212 226 121 134 197 165 189 69 223 27 170 34 207 174 64 23 135 158 197 242 154 232 5 207 99 131 169 94 202 161 155 195 56 110 221 65 228 142 168 236 189 238 108 162 27 15 24 1 118 170 123 220 25 211 234 169 102 64 58 1 102 103 45 63 170 193 201 212 138 93 6 28 189 41 21 150 225 119 61 22 26 227 44 60 65 76 200 1 123 4 155 150 88 64 34 90 236 28 229 84 179 126 194 230 28 21 10 94 133 178 158 182 195 43 135 241 4 233 36 255 131 180 177 92 49 165 17 73 29 52 30 30 80 229 78 53 99 175 237 90 12 73 26 219 45 58 118 214 173 237 4 150 45 142 83 229 221 215 121 41 189 202 218 145 185 179 237 10 160 215 216 179 32 221 135 222 65 197 164 11 68 209 128 156 166 94 235 211 165 170 140 151 210 51 198 12 191 151 125 52 227 227 28 74 87 58 15 232 202 247 183 10 132 172 214 136 123 92 206 216 55 32 120 160 65 81 180 244 25 205 138 137 167 42 110 212 104 140 22 211 146 144 122 191 56 21 213 54 226 158 102 44 71 228 189 218 29 222 32 0 239 91 45 236 142 136 188 130 4 239 229 110 192 16 17 28 94 90 195 99 217 178 206 100 87 224 85 25 42 88 246 167 111 23 12 202 13 171 98 8 199 181 162 27 32 254 18 115 79 252 146 65 41 224 46 118 112 71 1 58 173 199 173 235 206 240 244 222 70 228 187 15 180 155 172 115 4 220 47 100 218 97 238 193 81 43 48 187 181 143 199 203 55 210 111 61 252 250 100 218 57 6 197 87 137 16 6 159 237 197 44 44 193 104 31 217 158 12 252 238 151 133 95 2 47 23 67 96 71 11 154 75 127 160 213 141 41 5 115 129 42 81 229 82 143 121 155 187 46 82 46 132 7 143 81 37 98 2 168 71 202 182 162 162 157 226 163 78 129 76 27 221 106 61 105 133 147 58 2 111 141 15 219 75 196 106 238 105 74 1 136 76 39 208 172 93 30 89 7 92 72 172 253 43 123 85 116 252 129 236 157 108 13 125 214 181 254 18 248 121 57 125 151 147 165 254 126 55 184 23 227 128 50 30 45 98 242 77 19 89 120 38 153 97 118 186 206 111 231 126 244 158 48 38 223 164 151 250 247 254 152 86 245 92 20 209 214 97 44 133 80 1 85 17 66 6 222 47 165 44 190 49 242 254 255 190 103 148 29 135 125 54 184 224 174 177 231 214 44 63 165 158 102 92 250 113 120 139 2 186 225 141 8 154 193 122 96 165 59 221 220 103 162 194 102 206 97 10 207 157 226 50 70 70 81 129 24 113 160 25 145 246 184 66 56 38 29 47 4 163 253 218 16 71 29 182 238 252 252 231 160 216 103 109 144 163 19 245 202 61 19 53 255 58 175 38 18 70 180 46 72 231 238 66 255 79 68 64 63 51 16 37 247 138 54 116 45 35 182 248 224 20 94 10 46 180 241 47 178 52 70 136 236 90 102 86 79 106 100 21 4 158 100 172 95 0 97 1 61 64 117 17 231 151 169 131 215 12 221 159 145 182 153 15 18 8 75 23 92 82 9 236 148 49 88 181 193 178 29 244 83 153 128 116 74 136 158 149 92 71 204 159 172 173 20 235 95 209 11 45 57 55 70 78 109 210 93 166 164 95 207 107 214 240 231 125 249 76 245 2 230 216 245 201 224 217 243 5 29 10 36 187 193 86 183 152 69 136 60 63 84 7 158 180 224 162 237 69 120 85 92 35 227 179 49 149 91 57 199 112 192 138 22 234 195 201 85 223 210 199 36 112 72 129 143 131 132 243 235 89 68 129 129 215 93 144 29 0 28 161 109 143 9 245 179 238 181 65 132 89 183 104 59 155 37 174 223 78 73 24 226 212 234 128 110 122 41 209 224 150 242 167 197 245 73 14 253 194 105 150 76 214 234 30 176 202 46 213 65 48 194 251 243 9 111 114 45 171 175 0 193 226 163 203 192 242 101 77 20 128 73 27 41 39 223 237 6 97 61 84 91 158 231 169 79 210 251 225 188 96 167 127 69 1 161 145 191 232 148 175 164 167 41 155 204 164 159 125 128 169 151 32 197 137 63 81 185 201 67 87 132 63 216 106 254 201 244 202 247 144 246 31 150 117 69 162 191 191 70 204 98 35 135 25 63 105 24 53 55 236 135 147 84 95 52 103 74 140 76 165 102 94 62 51 23 13 70 55 230 118 115 174 12 132 110 181 21 224 123 28 5 87 109 226 102 235 72 142 172 226 189 212 153 218 1 13 246 223 95 214 119 195 232 200 203 247 17 117 12 43 40 240 67 244 80 178 83 71 136 129 56 182 208 247 83 115 253 221 133 64 14 129 242 59 184 57 141 243 192 179 224 178 127 56 7 196 116 246 32 97 183 235 248 46 174 237 66 236 16 45 71 87 3 154 123 106 127 165 146 0 66 112 31 239 110 20 89 22 15 44 162 45 231 86 252 4 168 14 83 171 180 249 83 224 103 33 89 197 187 206 134 7 246 109 99 69 1 32 127 66 247 56 38 27 48 197 103 195 132 27 166 241 210 66 227 89 237 43 183 63 87 209 135 237 156 250 60 95 195 209 93 37 166 230 132 252 182 192 9 216 49 139 160 2 53 10 51 76 154 102 183 132 97 223 210 175 135 247 252 137 40 79 202 215 230 148 128 124 90 46 210 230 144 218 181 63 32 245 139 83 207 98 217 90 22 251 182 220 90 222 189 197 179 196 17 114 208 138 12 156 49 61 50 214 22 113 94 197 115 102 85 120 136 128 19 232 237 4 88 131 210 92 163 212 183 139 70 133 176 20 20 115 176 30 217 119 201 204 188 81 61 208 14 123 60 23 93 62 28 152 167 71 181 227 10 168 235 171 57 30 151 131 185 70 81 151 87 242 130 145 148 174 133 166 33 147 103 252 50 138 248 111 215 142 1 35 189 84 95 66 104 237 166 39 88 131 33 200 142 48 244 30 148 243 53 16 56 245 140 221 24 184 114 241 44 87 113 81 8 231 80 226 79 102 186 205 122 125 207 89 137 139 47 226 122 112 46 186 51 246 141 224 233 136 44 150 189 160 133 94 7 50 206 145 46 79 245 119 37 5 90 78 156 30 234 102 187 122 177 41 144 200 65 11 220 85 11 22 81 32 231 155 192 3 11 193 167 214 187 81 94 75 53 3 2 243 189 106 204 15 140 190 240 52 60 27 170 36 243 197 190 207 139 135 117 237 45 83 216 228 19 246 197 185 63 204 126 210 206 193 164 102 34 134 194 97 28 175 229 130 22 59 146 36 137 177 70 140 143 40 20 218 153 14 216 56 31 153 122 232 18 16 234 108 196 97 208 148 151 59 165 200 79 110 10 120 138 114 197 108 171 110 229 95 226 234 45 76 120 203 38 237 23 196 30 40 150 28 110 102 110 108 89 148 79 242 115 255 249 51 96 62 210 236 144 70 45 221 139 156 214 18 5 59 187 129 190 184 89 38 197 231 170 89 244 234 186 31 229 46 146 0 109 118 220 72 112 122 103 220 121 51 218 177 184 52 68 213 158 231 224 127 86 96 170 133 44 50 55 66 193 198 20 105 121 98 8 231 4 228 209 113 231 54 69 63 101 245 220 240 222 140 62 162 195 60 239 204 84 149 32 71 162 40 145 198 64 17 240 173 4 135 192 159 190 111 221 183 91 27 160 237 25 93 91 128 230 96 12 14 72 175 23 33 123 232 175 21 207 173 5 67 200 73 152 149 83 110 47 166 72 144 164 48 78 174 51 253 83 246 5 111 16 241 187 55 86 250 214 50 226 186 67 168 153 66 121 23 189 229 119 13 223 215 168 213 67 242 86 18 214 171 201 184 178 153 187 165 220 172 65 111 4 192 207 173 93 245 121 9 181 139 50 245 20 239 226 128 132 216 116 136 162 47 218 231 101 81 173 163 191 85 77 15 80 192 47 119 164 154 85 98 199 35 243 74 239 199 66 221 16 47 195 51 88 229 160 228 108 6 69 191 167 113 207 18 71 96 75 225 86 150 111 219 101 117 66 92 162 201 19 19 164 142 90 129 83 9 108 226 144 166 93 250 90 186 43 210 131 210 188 136 224 114 164 214 107 230 103 169 214 47 106 43 3 205 97 155 241 236 200 99 226 135 59 6 157 7 53 58 193 90 116 51 20 136 232 58 99 29 237 103 232 153 224 195 79 6 129 54 246 177 106 89 21 185 45 102 212 48 224 198 79 3 67 45 102 185 42 26 27 128 0 250 52 62 137 165 100 200 72 159 168 245 235 87 16 102 213 217 117 69 200 119 220 64 72 165 219 243 132 163 97 184 249 27 191 98 153 240 138 6 223 186 220 76 13 229 188 64 234 203 116 115 9 69 115 107 226 106 179 16 169 171 73 145 188 201 110 54 44 149 242 17 151 98 44 20 247 253 203 206 241 175 19 184 75 38 119 71 245 229 64 43 10 50 132 247 219 180 153 61 93 117 108 71 29 57 157 144 75 213 31 5 138 175 172 135 178 199 47 98 100 149 188 14 64 52 221 206 156 136 138 75 56 177 30 178 158 129 41 51 142 194 123 224 144 51 83 145 141 200 146 88 117 247 233 242 117 101 181 145 154 173 67 173 143 25 156 82 45 69 112 7 220 89 73 2 34 115 97 15 126 137 83 91 2 153 96 227 85 147 223 63 187 185 107 166 88 24 139 238 9 197 152 38 48 185 204 158 148 206 185 59 224 91 251 249 90 167 59 54 237 125 96 249 130 97 70 191 90 183 34 228 6 223 43 81 226 226 76 231 58 173 172 18 190 250 183 247 149 112 227 113 149 236 38 55 109 229 41 192 160 160 32 193 0 165 251 188 180 98 106 216 200 160 108 228 52 182 141 185 82 23 186 150 87 246 234 3 221 120 175 165 114 247 51 80 185 223 143 182 88 25 41 133 38 38 171 202 74 237 146 101 99 78 208 98 83 210 44 105 225 114 117 228 236 130 78 20 222 41 174 100 51 149 5 209 122 232 69 58 115 254 85 239 26 22 137 91 237 177 157 27 67 23 19 203 144 150 30 94 92 167 104 179 123 154 70 199 13 148 63 135 100 195 14 177 185 136 253 198 114 130 66 115 146 167 140 104 111 219 234 99 60 159 173 230 151 251 80 95 105 116 195 29 221 27 13 31 99 185 225 56 133 236 241 161 159 99 48 75 131 248 162 70 212 198 190 56 145 173 9 156 252 107 13 43 143 204 179 251 85 29 106 113 124 120 42 240 45 43 248 167 128 110 180 192 91 163 110 44 126 146 157 253 98 76 42 150 85 173 117 81 229 214 162 133 88 123 156 216 78 230 134 218 250 39 179 65 238 55 212 183 232 19 189 53 187 178 247 28 235 19 79 121 249 147 130 143 71 239 234 199 23 60 210 1 36 150 68 215 235 137 243 201 126 143 38 7 235 188 153 212 209 193 50 105 97 192 58 202 65 2 130 196 76 46 54 218 127 205 146 217 45 251 254 55 76 180 180 89 32 48 36 130 96 111 25 32 67 222 131 55 73 86 168 157 146 194 172 175 117 121 112 167 28 167 244 108 115 137 182 224 181 4 62 104 195 5 109 87 177 53 212 206 29 228 232 20 187 188 254 137 41 105 239 98 145 176 192 82 149 97 209 172 29 93 122 155 157 133 139 103 86 149 215 77 0 98 141 234 13 154 202 48 81 197 182 90 124 42 229 36 44 242 106 60 158 50 163 141 87 223 230 184 200 211 97 254 24 192 231 199 152 162 234 156 109 16 88 33 222 195 19 135 66 2 82 251 82 55 175 0 132 99 199 34 165 132 61 138 162 229 88 37 116 144 118 157 16 157 59 181 16 132 98 145 95 160 77 26 115 103 250 242 28 195 81 55 155 209 35 220 244 235 38 5 241 128 174 252 224 251 225 177 185 188 84 240 22 121 11 72 98 195 245 33 49 27 197 160 54 69 120 200 35 246 220 111 49 32 222 143 156 192 184 231 113 78 6 1 73 110 149 7 215 154 48 6 249 196 81 45 163 85 138 190 101 176 195 187 28 211 165 43 234 219 34 41 138 213 54 42 105 227 10 200 157 1 5 123 90 175 97 216 129 205 103 137 168 28 72 204 251 217 209 42 167 93 151 203 240 51 96 176 39 186 6 125 77 224 23 155 193 82 95 177 38 18 219 84 242 221 16 236 221 78 149 119 186 12 68 34 176 144 238 187 93 155 226 237 165 226 193 8 49 39 161 62 110 111 53 158 12 95 43 200 151 106 71 143 174 75 27 2 175 48 190 188 49 30 95 116 85 125 14 143 141 159 226 194 245 84 191 89 70 39 173 6 41 177 39 19 209 220 240 58 48 123 124 119 7 159 34 22 189 71 67 75 19 228 79 248 124 31 112 6 9 103 12 74 94 249 95 220 106 167 126 22 39 37 80 116 245 73 166 59 251 58 221 190 129 231 77 52 170 140 31 87 156 66 13 150 107 206 210 135 19 14 250 60 229 95 192 82 254 144 171 179 247 140 178 104 123 116 56 17 36 12 76 115 179 206 34 125 53 126 234 180 152 222 14 177 138 199 0 174 79 111 42 192 31 82 157 249 173 32 217 107 238 38 69 240 19 165 166 232 151 82 142 24 165 165 165 165 1 0 0 62 0 0 172 94 90 110 181 192 83 165 0 0 27 191 0 0 74 39 0 0 0 0 0 14 34 54 0 0 87 188 0 0 12 167 0 0 0 0 15 0 83 113 117 101 97 107 54 56 75 46 112 114 111 106 0 1 161 103 77 77 80 82 67 87 73 69 1 0 0 0 1 233 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 42 61 0 0 8 214 0 0 0 0 15 0 66 193 212 177 152 127 146 222 243 33 86 175 90 50 8 89 67 135 137 27 141 183 161 206 42 22 96 87 116 152 233 42 230 166 223 93 16 6 173 110 181 222 55 15 183 81 106 64 84 85 160 125 218 100 35 39 25 39 155 84 32 38 58 140 69 8 21 146 69 1 191 80 0 201 126 125 46 66 83 22 20 130 143 170 158 63 106 140 213 92 209 255 135 216 159 84 99 38 148 146 107 157 136 129 110 237 72 101 148 131 63 192 78 85 109 81 50 24 101 40 56 111 173 14 205 235 213 3 133 142 139 114 241 203 123 254 58 185 51 2 27 48 37 153 96 209 175 238 195 126 222 65 173 21 29 98 248 206 60 216 203 5 186 73 219 168 119 207 161 113 94 190 25 51 139 204 212 164 34 245 135 95 247 177 89 209 27 77 68 0 114 87 89 133 253 149 81 148 65 243 35 66 243 110 6 52 113 77 148 239 180 7 50 82 101 26 204 48 217 149 125 164 129 157 244 29 151 52 60 126 49 90 159 229 54 202 101 245 206 193 50 84 135 81 82 100 145 234 215 136 203 133 45 176 76 224 80 244 244 173 206 12 207 6 81 163 207 31 88 57 18 55 165 124 147 130 64 197 116 90 222 158 59 48 52 215 224 53 120 25 95 221 249 251 67 77 98 168 2 27 65 2 238 87 196 69 14 90 244 83 197 232 144 5 174 26 205 221 163 142 95 46 209 104 66 143 121 34 164 244 187 84 132 47 210 55 220 108 157 46 143 116 47 30 219 141 27 211 204 204 195 213 3 133 192 155 236 120 26 238 11 206 184 123 159 126 130 26 105 198 86 34 236 106 174 241 147 247 239 180 150 134 67 115 92 233 6 198 53 12 253 113 156 46 77 193 24 135 51 238 247 75 61 237 121 249 243 164 174 124 224 119 204 52 49 253 52 19 221 243 48 23 71 25 42 22 96 98 48 239 251 226 164 105 154 90 43 96 74 136 255 45 80 186 74 71 116 36 145 25 47 245 42 233 145 174 158 52 177 211 229 98 60 208 239 203 21 37 124 152 77 192 13 153 139 87 217 119 72 165 238 218 187 209 202 147 47 81 85 214 251 234 72 178 172 121 14 140 58 81 62 50 189 26 2 249 128 63 118 163 16 194 181 99 236 173 44 56 73 73 133 224 180 170 115 214 115 248 62 229 50 42 175 243 16 152 37 0 115 108 72 212 92 124 106 204 180 224 193 90 110 210 25 27 52 91 23 74 169 8 27 247 211 45 85 133 132 228 133 147 94 42 205 187 139 94 141 64 6 37 161 68 154 60 22 99 135 94 249 61 146 137 121 49 183 13 129 208 8 146 110 93 248 117 36 160 225 156 145 121 254 150 108 214 78 71 67 162 217 210 130 110 149 214 242 190 45 176 193 197 139 141 93 201 61 68 158 243 234 78 36 204 133 90 204 173 80 29 190 2 74 107 18 163 210 245 2 26 126 230 164 222 139 35 19 90 137 87 151 168 240 194 20 239 25 232 126 32 229 34 25 83 85 86 201 195 46 117 233 177 193 171 240 199 75 138 137 40 104 162 91 24 108 42 69 110 77 119 11 111 102 154 147 231 134 65 107 234 57 255 60 63 175 128 22 235 179 251 26 30 159 51 32 205 195 146 242 53 74 214 181 70 161 89 99 71 30 183 228 45 73 217 121 159 66 154 71 75 178 149 212 222 47 224 45 141 179 173 105 184 136 249 82 179 248 13 33 13 122 193 72 225 20 113 155 200 14 116 120 106 7 92 41 203 147 234 94 109 159 144 45 110 227 65 60 38 121 79 233 250 128 89 1 232 40 40 22 202 90 192 186 58 161 211 131 190 161 75 60 208 235 1 156 52 85 235 103 144 76 53 99 25 4 178 114 57 153 89 172 18 177 102 186 60 255 108 255 128 124 113 44 108 228 216 52 244 12 239 76 124 91 58 220 107 5 56 210 70 224 153 20 75 179 45 79 216 208 190 50 16 112 122 200 98 85 173 128 166 54 121 147 80 125 45 82 32 155 244 49 61 133 153 117 115 41 9 36 82 20 226 111 143 198 244 182 222 88 60 225 63 5 226 149 116 184 144 167 105 205 158 35 132 166 199 54 142 91 6 44 10 24 201 117 32 111 116 70 225 95 248 163 80 208 198 67 214 59 218 134 249 253 151 166 19 155 188 170 179 205 215 156 68 146 113 125 16 43 192 112 157 155 119 73 48 167 103 119 77 151 14 222 168 146 185 130 234 6 1 125 151 95 22 203 138 211 170 200 28 70 129 169 82 83 38 32 21 17 193 37 80 207 189 1 232 82 248 169 50 14 13 174 52 150 49 16 152 156 188 208 119 162 221 141 177 54 116 199 234 189 177 190 170 25 238 164 236 219 92 80 210 70 106 15 91 192 136 51 233 176 179 151 227 43 202 52 16 185 107 1 93 93 1 150 183 91 137 85 71 100 111 142 242 150 215 34 253 219 90 128 24 3 52 86 121 93 88 44 206 137 148 70 181 123 153 10 29 239 143 233 34 232 246 90 214 217 73 209 89 129 195 98 162 10 255 204 166 104 50 125 104 15 126 253 135 96 174 84 142 188 0 127 232 133 189 170 162 39 31 120 102 21 197 102 185 32 214 135 69 53 86 43 209 97 149 52 182 40 9 175 26 87 172 113 118 232 228 28 62 101 98 186 76 211 108 105 152 100 16 123 107 79 115 84 52 32 14 71 172 101 148 112 2 150 230 8 57 23 165 222 82 3 128 81 28 176 108 37 97 90 128 86 119 169 196 12 165 126 137 196 183 136 86 157 149 17 223 7 37 1 53 76 12 234 96 108 92 1 163 21 66 138 131 152 91 197 108 177 71 94 54 255 212 225 129 186 105 110 141 19 227 83 123 135 139 8 240 100 22 97 119 148 73 50 165 31 9 16 240 162 92 180 209 142 117 74 192 251 28 160 210 24 11 31 208 21 52 97 46 230 165 71 243 141 117 163 72 197 163 240 104 4 192 165 208 81 41 50 3 83 151 255 197 9 166 177 28 175 165 1 214 131 14 220 121 31 69 213 215 253 191 174 220 207 31 111 174 164 208 127 75 79 82 211 205 21 69 29 120 37 214 124 3 231 148 98 174 152 138 124 248 155 243 38 211 71 230 4 31 31 11 66 121 190 134 117 72 134 111 110 130 8 24 112 177 209 44 179 86 238 139 46 23 193 206 115 156 120 161 238 252 102 122 189 88 148 93 176 88 133 91 110 179 173 154 2 32 93 178 153 64 82 62 34 48 100 130 100 223 133 211 113 183 191 241 228 108 147 79 78 5 102 206 61 37 221 74 168 6 7 230 124 189 191 225 112 169 142 30 97 121 194 149 33 142 166 250 168 22 250 125 110 253 134 166 165 120 193 224 31 79 41 206 20 187 97 90 212 109 255 69 178 30 68 228 121 243 17 20 3 75 95 209 10 74 68 245 223 21 202 180 79 224 12 253 233 250 226 91 26 5 56 89 192 137 59 44 98 153 34 236 152 210 44 126 111 110 230 14 155 64 240 171 108 142 243 120 22 239 138 169 87 199 111 142 170 187 193 14 90 209 227 111 115 55 68 72 212 186 63 55 34 211 56 203 208 9 238 180 250 194 48 239 242 15 168 59 138 115 189 179 21 140 242 118 211 7 212 179 209 251 132 32 69 174 15 218 121 235 161 92 80 210 34 173 213 220 243 7 176 61 0 47 218 186 251 123 207 252 93 42 254 130 125 210 143 1 7 184 182 124 36 88 161 25 48 136 236 99 159 96 176 7 84 112 110 181 179 5 192 236 116 19 137 96 42 222 82 252 233 129 78 86 142 215 175 126 100 81 17 170 118 12 177 240 122 19 184 106 50 41 131 233 138 208 32 118 234 89 251 255 154 189 62 177 92 223 211 39 239 124 42 152 72 27 93 118 163 243 230 238 96 174 230 244 179 120 71 153 116 155 66 213 155 189 187 177 81 120 237 73 12 202 204 99 228 207 252 228 199 10 234 30 84 14 58 241 211 86 201 103 251 213 196 248 130 3 60 67 146 172 210 122 223 35 171 229 92 185 125 83 123 251 3 198 81 147 140 227 247 16 244 73 231 176 21 44 90 23 41 76 222 54 166 33 217 237 68 225 142 77 31 40 148 183 55 126 172 225 228 202 23 152 244 253 116 147 202 152 13 65 47 55 39 76 44 130 211 107 70 201 135 161 8 85 185 17 76 61 219 98 169 93 155 3 252 180 95 141 3 102 136 49 116 61 60 221 139 194 244 101 243 71 116 251 48 215 182 80 108 214 156 178 137 201 103 217 143 131 193 160 112 27 109 109 105 12 151 31 246 64 148 32 214 202 158 113 228 251 184 134 40 99 150 28 205 96 224 41 15 238 128 62 81 179 9 152 137 146 105 243 201 19 32 75 200 3 116 156 247 105 154 214 210 209 236 170 205 203 125 30 22 51 244 45 97 173 107 145 214 27 7 107 205 84 142 87 96 197 155 132 28 255 48 4 255 139 118 220 15 166 170 90 28 137 181 166 225 93 186 191 51 100 40 26 198 141 244 53 18 152 172 252 247 84 220 213 24 141 131 235 134 27 253 181 134 153 0 182 70 195 38 101 155 245 69 163 20 35 5 71 254 160 204 89 253 232 253 233 53 87 120 191 225 237 181 192 201 86 165 85 168 29 20 153 156 213 195 246 188 61 35 232 102 44 221 31 91 96 232 37 243 11 140 141 4 238 246 149 187 195 8 49 240 125 199 97 65 120 22 200 102 181 14 197 45 139 61 123 131 168 186 208 168 126 54 207 237 118 77 125 213 54 8 255 185 229 203 202 97 114 173 37 65 196 57 46 238 31 143 143 36 23 202 37 14 102 2 117 216 55 39 83 93 63 181 220 206 119 11 209 126 255 148 144 149 58 236 198 221 190 156 15 160 214 72 3 198 122 182 38 13 63 41 226 119 84 170 104 242 106 54 114 33 225 207 58 75 237 237 252 125 62 89 118 181 207 80 111 227 148 0 223 218 159 220 93 40 134 184 129 177 151 205 176 166 90 208 2 241 128 60 0 66 193 212 216 191 219 184 241 11 253 181 9 81 160 233 115 36 244 172 68 140 78 110 150 75 207 21 69 167 173 40 179 48 7 172 215 128 45 180 54 88 237 245 31 155 42 17 134 148 46 82 231 168 100 45 110 137 233 26 169 221 15 61 7 37 170 10 253 91 47 101 1 7 246 181 106 157 109 255 248 150 43 35 32 186 230 167 250 157 1 237 16 148 206 225 131 103 45 51 219 184 144 19 208 148 37 222 210 175 170 141 65 225 196 99 95 160 120 89 220 121 152 247 54 49 105 177 175 8 123 216 11 2 9 182 10 121 7 121 185 97 23 128 30 207 9 6 32 15 17 108 80 130 196 164 53 135 253 128 118 127 84 210 1 226 50 233 243 207 59 110 231 71 107 194 186 238 210 152 37 102 210 8 5 128 152 124 231 140 133 162 151 22 188 138 132 251 90 17 234 50 118 203 193 228 3 101 19 149 70 25 24 114 217 250 206 254 173 148 247 183 206 65 242 61 123 155 69 45 174 84 232 185 33 58 28 214 132 190 234 148 77 169 27 37 55 129 115 119 70 173 201 95 130 160 195 254 244 165 255 165 98 62 115 46 241 172 2 245 85 46 88 183 241 104 162 38 153 210 61 172 7 68 219 155 64 166 107 196 230 39 92 77 72 181 143 33 253 173 118 197 111 230 225 1 53 50 66 185 228 127 216 161 161 36 64 36 166 61 232 46 52 152 14 121 66 31 249 44 137 171 107 178 34 208 227 236 169 227 14 131 227 243 188 61 167 5 201 99 234 37 227 174 27 48 209 125 197 124 14 40 155 182 226 106 129 145 105 133 5 55 88 50 33 202 30 100 71 68 122 87 30 229 131 3 111 25 101 158 3 26 61 40 87 175 63 127 111 225 17 82 184 202 213 193 200 173 82 102 208 199 107 97 41 252 139 68 121 92 82 235 25 97 208 190 61 209 230 79 62 97 158 96 18 179 30 105 46 140 158 43 55 231 141 120 48 42 177 24 192 209 88 22 26 231 76 136 9 57 28 241 246 178 7 64 251 105 113 52 42 189 22 177 3 254 122 132 178 230 194 24 72 201 52 93 77 19 14 55 254 122 168 87 148 191 183 146 94 21 52 93 135 94 163 73 193 3 24 98 179 130 232 240 159 14 208 105 41 36 2 99 93 178 230 182 160 96 188 50 100 43 141 26 40 13 78 212 43 11 83 228 126 31 166 95 170 204 77 250 114 253 65 218 123 98 49 164 122 170 220 252 111 240 250 38 191 63 130 166 195 209 135 158 161 176 238 19 55 104 29 92 205 35 215 22 169 212 198 186 183 168 233 184 251 8 130 177 159 239 20 43 164 73 202 43 187 53 76 200 56 7 224 100 60 73 42 112 10 4 239 114 25 72 131 46 236 69 41 207 246 175 19 154 152 52 70 51 151 81 159 123 94 201 251 67 45 6 221 225 4 251 161 145 13 210 121 249 237 190 145 240 32 139 38 196 218 119 208 196 69 157 129 82 42 98 25 24 61 10 31 188 59 220 12 157 225 16 247 183 208 199 215 54 195 233 67 218 35 233 123 225 45 204 142 252 27 149 121 239 144 90 212 194 199 222 47 51 124 144 33 63 182 252 209 154 141 179 27 47 61 145 99 98 73 77 171 116 201 16 12 87 214 74 250 174 5 209 82 5 229 58 35 5 1 182 17 119 250 126 76 5 245 108 121 119 29 211 112 195 128 124 202 211 84 167 180 218 201 206 227 237 233 139 177 39 21 192 190 80 254 207 200 172 45 3 179 33 148 64 245 154 8 82 20 2 23 4 35 87 4 232 92 201 77 252 180 252 243 204 139 166 147 222 167 115 184 137 67 155 163 246 76 255 152 222 204 71 36 113 61 195 8 128 11 23 80 173 27 59 56 244 125 137 193 55 36 84 81 157 96 109 179 33 192 242 197 113 223 119 196 96 54 159 143 25 152 56 43 33 184 151 187 41 77 177 180 99 71 137 49 196 6 229 36 247 217 24 99 195 132 120 123 88 61 189 154 40 186 154 90 17 31 210 114 229 123 187 7 235 74 112 59 185 61 12 118 104 215 180 87 216 28 63 243 138 185 131 105 30 83 46 60 152 91 133 29 202 189 173 106 103 136 232 249 107 69 27 25 243 26 157 118 154 40 198 87 193 211 57 137 183 19 11 38 67 105 255 107 98 8 178 154 191 153 119 112 54 98 181 201 116 167 46 41 128 248 62 91 67 201 134 17 56 156 233 232 140 202 162 138 162 183 249 47 224 120 54 60 251 166 236 122 216 87 152 176 75 243 253 247 208 135 132 75 111 20 163 104 234 7 190 19 112 36 94 43 152 60 65 9 127 183 90 170 113 75 119 81 169 198 244 182 244 10 92 103 25 206 89 12 147 209 59 67 35 41 91 70 185 54 92 158 168 234 138 21 254 43 84 243 140 29 224 198 185 152 74 14 102 5 215 200 118 50 86 101 238 19 124 130 173 249 38 76 37 77 229 118 109 47 242 108 181 237 99 251 126 191 15 41 179 141 159 15 170 82 68 253 47 197 133 25 26 18 249 131 34 35 122 203 200 11 248 77 167 52 84 172 200 105 243 48 169 55 189 20 216 135 214 30 122 237 21 73 83 5 192 48 94 152 84 185 6 50 32 132 116 61 141 94 50 110 183 126 97 107 15 239 220 46 231 158 7 122 157 45 177 56 186 18 60 132 87 168 61 20 198 121 144 31 96 138 12 160 172 61 39 1 241 86 101 95 1 17 238 16 55 35 245 12 148 65 14 80 102 152 151 134 238 186 91 231 63 25 4 89 163 120 44 216 107 229 217 210 175 94 64 169 170 255 35 174 110 199 149 167 111 95 167 78 97 187 103 183 90 222 141 89 3 164 102 222 230 137 121 202 154 69 184 200 116 6 151 69 182 24 211 122 210 108 85 207 201 63 182 12 148 53 110 150 25 204 187 114 242 198 151 167 187 103 20 170 53 12 52 192 190 185 43 199 152 170 208 64 73 11 36 192 237 157 62 50 104 232 84 84 185 24 198 45 170 219 173 173 241 209 94 237 231 114 188 197 115 181 212 195 152 16 48 155 110 61 42 188 8 66 131 247 231 70 11 16 132 108 110 105 200 243 4 95 50 143 90 90 168 30 56 178 183 211 30 240 206 22 199 56 134 68 203 61 222 19 213 235 204 77 230 135 147 59 82 42 109 167 220 65 67 90 47 198 58 188 77 191 203 4 45 14 148 4 16 92 216 106 118 168 167 120 23 228 151 41 237 94 238 211 2 80 175 106 107 237 187 193 250 181 187 246 63 134 41 35 24 103 59 71 60 80 143 215 197 133 71 132 255 191 181 188 171 122 225 177 147 53 123 118 229 246 56 137 176 190 109 153 40 127 102 228 192 215 40 155 166 173 237 180 160 98 39 204 29 173 119 34 242 211 121 78 126 12 39 229 127 13 208 245 152 227 133 29 252 188 187 63 129 158 209 176 216 28 185 140 85 177 7 112 237 204 91 75 52 124 51 222 69 57 179 45 155 65 127 247 184 154 3 151 30 71 190 49 106 82 124 234 240 252 50 145 113 85 18 37 4 228 181 103 239 7 47 60 189 24 194 58 127 20 14 102 84 177 161 150 18 20 159 116 10 141 222 57 175 198 227 244 247 162 25 217 20 230 237 8 191 212 194 36 223 85 97 213 62 17 158 141 230 228 219 239 254 146 221 68 111 196 115 90 123 55 140 222 234 35 224 255 95 3 138 235 16 150 112 222 6 180 47 60 102 4 152 66 76 25 76 100 245 14 247 227 188 53 13 232 255 181 223 60 175 16 21 73 229 96 136 50 134 153 250 97 207 157 15 169 101 200 187 168 56 62 130 222 136 231 118 95 125 81 204 2 244 102 221 115 38 148 165 153 238 87 93 124 184 226 83 195 222 232 97 99 105 231 31 204 39 84 230 91 37 235 41 197 12 3 91 217 194 30 62 150 135 69 78 65 154 90 170 177 26 92 149 59 112 5 173 199 24 25 239 137 230 84 121 55 191 130 1 196 255 230 39 72 92 90 27 14 47 229 242 48 24 28 16 101 115 104 65 210 6 249 187 102 203 130 84 14 107 53 76 77 252 151 85 20 91 163 13 71 115 166 22 163 94 108 252 226 193 236 42 202 54 236 17 106 217 113 211 205 198 121 107 166 58 94 181 144 197 179 88 253 179 53 59 143 243 161 109 39 37 230 50 55 72 104 243 224 234 85 195 178 96 176 120 249 6 48 148 110 30 52 108 114 96 33 151 10 108 133 17 135 32 100 170 97 87 181 78 198 102 72 255 108 251 148 24 52 36 47 5 40 59 63 107 90 215 245 170 6 59 234 186 232 121 98 91 211 116 22 162 227 227 190 222 147 207 168 226 5 125 184 50 87 217 226 208 66 195 124 86 89 37 91 214 80 229 71 4 151 108 152 11 218 90 16 195 35 239 42 87 41 5 171 125 161 226 37 103 169 38 161 7 186 1 210 110 184 80 8 57 126 31 123 22 133 226 151 214 177 58 93 71 122 59 133 25 204 99 253 246 6 132 238 115 247 160 201 202 198 15 255 143 159 58 38 225 73 119 189 141 22 26 95 30 246 110 245 253 45 2 129 248 93 191 57 93 160 10 149 25 82 249 218 131 4 51 94 59 51 114 223 45 21 44 93 23 36 198 25 172 5 48 169 20 67 96 139 21 8 108 227 181 106 197 147 41 220 203 234 5 5 225 98 238 86 50 36 40 210 16 147 144 106 223 102 2 104 245 122 48 115 80 13 189 221 226 38 78 63 217 168 33 192 195 174 194 60 47 77 52 177 168 163 127 188 150 238 71 13 118 153 42 243 111 189 85 48 151 2 105 42 89 236 33 215 242 171 165 53 234 196 230 219 8 54 88 173 4 249 223 88 236 163 185 76 34 39 106 72 1 187 230 70 171 171 207 82 171 10 4 224 85 75 175 209 156 159 51 87 111 129 76 173 195 119 143 176 184 104 77 213 76 156 190 240 92 210 47 98 35 150 164 130 170 47 163 238 239 224 67 114 14 108 172 42 171 97 128 143 133 10 49 126 56 212 188 250 198 166 248 77 42 189 101 173 44 160 252 208 128 34 23 129 207 192 80 91 138 130 170 13 143 145 140 247 251 38 236 86 175 75 213 81 46 45 58 143 117 88 4 92 103 66 141 56 218 102 98 149 26 147 219 40 187 202 66 214 138 18 211 42 208 97 6 13 69 113 237 72 99 215 107 190 98 153 56 17 103 89 142 234 237 87 118 226 213 63 203 209 253 31 242 80 100 178 205 243 244 254 225 181 124 53 237 171 79 172 36 68 173 40 254 139 242 76 220 196 85 65 209 83 208 241 22 81 48 9 174 21 198 69 177 28 25 206 38 18 240 223 34 77 54 248 35 252 127 77 118 239 11 222 20 170 234 130 98 93 61 119 92 139 231 130 166 216 197 66 113 183 46 0 220 105 235 211 29 235 37 136 246 14 248 189 42 11 121 88 71 9 88 206 168 133 31 196 150 29 103 31 57 111 183 254 157 78 212 206 141 98 88 211 157 102 116 155 145 192 72 107 225 255 157 14 172 224 155 173 25 171 171 203 43 239 28 82 240 44 33 14 8 254 78 9 66 59 55 207 143 247 4 244 187 32 41 13 163 100 223 39 141 4 196 61 51 108 93 92 22 104 44 16 240 126 217 121 221 103 57 30 86 38 68 136 153 244 241 175 48 181 105 45 182 36 203 101 241 180 88 156 248 109 58 62 199 200 104 3 48 93 180 4 226 84 118 72 242 91 233 51 5 181 185 233 112 186 169 254 124 231 5 175 156 36 42 250 177 140 206 141 0 108 225 94 130 228 178 38 27 129 21 93 220 21 48 192 211 107 27 128 254 35 102 65 147 64 8 110 249 143 15 129 72 123 0 159 155 85 0 60 113 162 202 233 239 144 132 2 218 83 195 52 29 14 75 27 54 141 113 203 135 107 36 110 115 19 75 190 87 152 88 39 100 243 14 233 43 170 186 66 139 236 34 231 235 174 57 153 203 102 24 16 5 151 184 156 94 242 23 131 166 210 79 72 18 138 201 235 52 112 232 134 185 72 75 157 186 144 211 190 246 181 121 1 54 84 177 64 145 95 191 129 210 231 203 8 192 121 119 129 175 107 16 234 79 253 164 192 204 40 209 61 64 49 72 94 117 83 255 73 93 87 16 30 155 229 40 192 120 151 140 142 149 172 117 221 212 246 251 153 189 150 221 236 224 34 83 7 60 252 155 78 87 104 61 193 77 219 229 252 180 5 161 87 141 172 247 143 127 65 33 254 157 240 140 171 165 18 220 106 185 182 142 39 128 123 249 186 17 214 15 21 145 47 209 90 87 62 55 174 127 246 21 69 89 169 136 159 81 123 116 28 150 69 122 31 225 168 118 18 30 69 241 148 93 123 245 141 83 201 111 47 255 19 9 240 223 70 215 132 56 114 141 97 70 140 102 149 199 45 122 183 158 236 64 137 58 111 22 253 5 238 65 41 92 236 40 158 203 161 244 60 96 179 20 205 9 254 49 210 94 235 127 205 16 75 45 76 35 29 79 39 134 252 76 136 75 169 114 151 114 194 90 112 173 26 30 210 61 5 34 72 18 74 114 52 4 145 94 253 90 165 15 236 210 229 101 220 179 159 122 54 92 159 181 135 54 32 121 144 208 62 249 50 49 225 5 117 127 198 182 239 67 18 57 189 7 88 14 67 41 142 199 125 22 11 126 138 21 184 244 48 159 190 71 188 66 164 241 212 157 83 209 140 241 201 1 131 110 195 109 150 231 192 203 183 31 209 210 55 237 74 73 41 74 96 167 28 89 104 249 45 184 219 29 57 208 201 222 11 133 203 217 48 158 187 178 30 129 93 122 131 8 9 145 74 208 61 67 122 114 154 184 212 174 187 27 122 187 198 145 60 133 71 24 131 148 20 51 97 233 69 126 115 255 10 197 134 69 11 43 215 18 86 43 14 90 179 193 159 35 203 7 199 45 30 16 44 52 53 191 15 206 55 153 30 59 81 34 6 209 252 14 56 191 191 4 6 65 92 118 123 142 150 21 214 126 64 72 134 12 106 54 160 39 246 179 2 96 230 101 106 230 156 156 110 215 137 223 166 23 121 187 145 134 27 91 59 63 199 41 181 229 130 145 22 171 217 116 112 85 25 217 147 1 156 32 136 72 13 120 200 1 147 189 59 254 218 104 65 177 71 0 165 165 165 165 1 0 0 62 0 0 174 236 103 92 181 192 83 131 0 0 52 58 0 0 99 99 0 0 0 0 0 14 67 2 0 0 88 176 0 0 13 22 0 0 0 0 15 0 83 113 117 101 97 107 80 80 67 46 112 114 111 106 0 1 43 249 77 77 80 82 67 87 73 69 1 0 0 0 1 111 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 72 39 0 0 60 122 0 0 11 182 0 0 0 0 15 0 66 193 212 151 230 44 187 242 126 170 58 34 133 163 140 183 17 157 122 10 120 46 3 129 230 154 177 115 133 125 213 209 224 242 22 126 25 154 214 216 196 174 96 243 128 109 90 179 117 245 139 187 167 47 156 119 182 214 72 195 139 171 20 66 248 252 82 0 64 157 2 33 34 208 126 128 38 5 124 153 220 3 74 5 116 126 162 108 152 131 142 94 103 164 83 214 149 156 193 237 25 14 251 53 196 247 119 62 179 57 145 84 220 160 162 72 185 133 115 102 11 210 135 91 2 226 49 250 205 130 31 155 169 189 44 214 24 71 141 229 22 65 166 252 244 182 95 118 167 148 57 203 124 189 46 57 190 101 213 12 241 37 185 67 67 25 128 143 47 7 84 243 26 234 72 46 29 24 17 114 248 113 83 22 187 21 44 85 249 227 43 20 191 51 9 99 1 66 78 252 228 7 65 214 203 195 80 200 133 152 254 16 156 143 131 61 195 84 158 92 145 215 206 167 70 203 126 167 110 199 180 127 205 226 95 181 158 123 6 132 215 203 1 33 24 233 5 55 159 245 126 241 241 149 105 55 174 7 1 28 236 157 6 164 210 12 70 151 64 216 55 25 151 64 204 145 168 43 129 208 41 106 51 41 161 109 218 46 90 82 191 110 156 51 89 250 158 93 78 200 17 188 4 65 171 244 208 30 31 132 180 19 184 64 184 173 188 148 200 151 252 248 72 43 199 99 34 242 60 218 170 242 23 101 90 111 182 215 129 253 142 164 230 79 127 62 175 9 235 48 39 183 232 92 44 242 3 55 24 131 73 89 246 236 93 247 115 158 24 159 102 149 226 84 246 166 197 250 225 25 63 207 203 147 113 84 21 240 194 45 245 11 171 143 31 187 10 162 218 71 107 150 243 42 36 25 30 214 154 163 44 245 212 134 67 244 226 178 157 147 51 221 212 46 198 166 226 170 237 15 182 225 202 191 204 203 167 176 126 210 44 70 11 60 125 10 141 221 61 81 244 134 10 215 67 176 231 110 101 153 138 172 62 46 178 146 199 81 24 236 145 188 206 171 233 43 123 76 157 172 147 32 67 14 204 21 161 133 48 174 207 70 249 66 251 115 236 190 206 85 242 54 241 248 240 187 95 196 119 54 106 216 81 191 155 249 197 192 3 205 27 63 161 8 200 146 178 192 37 155 136 82 89 83 116 214 8 8 10 105 148 90 137 118 193 25 107 28 191 91 10 149 250 221 61 24 134 106 32 68 94 70 252 171 40 117 235 52 237 144 33 106 247 219 84 213 77 229 8 164 181 208 22 162 198 103 29 216 156 223 0 12 192 39 88 40 45 73 140 179 147 168 169 154 132 82 44 23 150 14 157 12 2 235 88 100 173 72 150 165 54 225 234 104 68 122 81 111 236 17 101 218 153 178 254 241 69 6 22 118 152 146 18 56 39 33 26 114 87 239 181 72 102 239 207 2 37 95 166 152 158 15 34 90 40 208 35 225 11 85 200 247 234 185 141 172 42 24 101 58 221 55 246 131 140 219 38 164 255 199 101 64 144 160 76 205 35 184 232 213 123 16 56 86 177 31 11 146 144 119 14 28 150 154 67 167 204 48 51 78 112 49 81 90 116 63 111 157 82 57 147 88 112 120 164 112 107 125 20 134 77 233 29 198 78 25 103 48 22 134 1 93 182 119 221 12 40 91 181 212 88 135 182 34 155 27 160 128 192 76 19 28 138 77 29 88 184 157 183 168 221 79 89 28 91 139 253 138 31 188 196 250 167 253 2 44 126 83 70 208 118 158 124 77 57 78 104 153 193 251 93 56 51 12 130 124 40 116 109 214 44 61 142 194 63 129 93 43 162 67 43 51 49 180 216 131 187 36 51 243 148 79 20 126 32 3 213 176 90 110 25 166 103 202 210 111 104 169 118 165 119 64 149 241 114 11 232 216 129 67 70 195 71 85 149 132 63 39 55 104 34 179 44 94 126 195 78 166 166 131 38 183 107 109 72 186 10 32 221 104 106 114 147 34 174 127 99 22 3 15 73 247 205 217 210 28 71 20 33 73 227 145 250 202 94 127 82 254 119 41 39 240 249 29 159 90 20 173 127 238 127 2 231 245 212 21 235 116 57 230 35 198 207 137 61 176 200 201 218 105 192 5 241 5 108 28 101 80 144 30 160 254 151 165 142 213 109 119 35 66 34 204 46 220 40 109 247 54 190 226 113 160 198 185 73 244 231 43 76 31 162 248 102 158 76 144 84 77 226 6 197 235 182 139 106 146 114 92 91 238 83 12 53 232 195 40 95 21 112 146 194 82 208 91 162 163 75 32 209 25 72 45 108 129 45 54 152 90 179 175 137 153 142 160 53 190 35 254 48 66 57 57 235 191 84 74 232 99 53 143 175 217 232 65 128 127 207 102 246 229 113 92 130 232 54 157 214 106 242 176 84 7 216 56 72 18 33 168 214 219 209 119 202 155 142 148 184 18 198 112 104 102 25 238 30 24 89 231 250 244 242 153 116 15 100 162 11 59 51 40 101 113 140 73 231 40 244 151 17 177 116 153 27 61 144 105 36 46 216 46 253 183 22 151 38 199 159 11 176 120 81 189 114 52 3 231 81 192 122 170 93 84 101 105 225 231 57 47 105 228 43 156 0 2 33 206 79 54 193 157 66 134 197 182 134 228 150 223 233 66 88 168 86 235 227 125 185 247 101 50 205 97 244 169 72 49 53 24 25 139 190 206 5 74 42 111 168 89 70 143 232 11 30 162 112 51 174 93 242 203 147 45 55 80 90 48 161 51 13 245 234 93 234 218 138 184 188 67 211 115 5 252 186 204 92 94 231 193 110 178 217 195 49 2 109 4 214 199 158 86 133 128 200 127 213 131 151 0 57 223 101 64 223 37 128 213 77 176 195 177 148 31 94 204 71 93 200 77 175 43 200 244 234 212 93 183 246 66 54 127 222 8 177 180 177 45 183 110 152 55 209 18 74 189 107 13 147 174 245 9 162 243 63 94 13 237 103 179 41 53 194 73 42 218 55 122 147 139 255 142 121 112 23 7 205 254 68 14 246 186 156 21 235 222 152 4 224 53 143 57 11 149 112 36 125 47 103 141 124 142 120 12 178 86 8 188 202 98 210 249 255 125 95 83 26 122 183 39 131 41 217 9 69 98 74 209 13 236 238 88 69 249 198 54 126 97 241 73 163 68 255 84 107 110 129 104 81 17 219 113 147 204 170 235 10 244 225 64 236 18 216 190 11 140 177 106 205 79 36 168 11 203 86 91 186 225 216 209 220 193 176 17 22 48 27 197 24 42 24 196 95 208 210 43 154 242 175 94 88 39 66 165 138 226 45 112 168 244 228 115 231 107 243 192 16 242 63 125 177 91 93 132 50 95 215 98 201 23 230 56 146 168 94 55 223 119 71 178 152 95 31 42 225 137 42 80 217 220 189 254 106 23 13 142 135 106 13 164 206 252 118 27 238 5 26 151 117 54 69 39 53 7 16 17 198 174 117 154 48 70 61 16 212 101 144 128 118 44 204 207 130 117 187 221 141 32 14 164 186 208 110 10 126 70 111 78 179 132 185 31 220 20 1 230 138 49 112 37 172 230 140 185 24 219 66 154 144 217 199 64 1 247 86 105 69 78 100 250 167 232 33 88 35 162 144 91 88 155 192 218 243 126 36 180 150 50 206 29 1 123 152 39 40 192 38 122 162 179 178 91 244 177 136 40 193 94 78 43 126 44 0 176 69 71 232 13 165 33 9 252 240 15 8 69 6 68 163 95 214 196 83 148 46 43 202 157 18 225 189 55 144 120 190 113 27 108 13 170 139 6 78 28 176 228 118 91 177 164 156 6 197 237 255 156 38 209 125 89 77 153 8 229 199 32 240 181 3 138 236 156 9 33 48 246 245 8 94 111 126 250 187 235 174 222 19 126 197 3 17 50 104 58 199 23 162 174 1 207 104 183 133 108 191 133 150 45 192 220 128 63 163 147 217 188 223 12 31 157 17 128 99 59 212 195 149 128 181 137 129 0 226 66 198 112 66 246 176 6 233 244 11 19 18 12 136 235 196 210 197 44 134 205 238 145 128 169 19 132 48 79 193 120 157 123 187 118 200 15 243 3 85 227 53 15 68 229 241 47 159 28 105 5 244 128 67 2 36 54 240 129 99 122 195 140 44 105 26 141 55 165 103 131 238 193 165 95 62 119 12 148 225 204 56 41 235 210 40 16 109 166 65 31 240 13 97 136 233 13 189 108 65 51 35 150 15 31 16 11 33 0 52 57 110 225 62 226 14 194 111 201 122 28 216 127 67 212 232 244 148 131 214 143 83 2 145 163 132 61 176 94 138 28 220 17 45 164 169 125 104 50 81 223 15 128 35 155 30 253 112 53 65 30 90 144 58 221 47 251 131 103 154 144 128 157 138 97 253 136 62 89 208 3 140 188 58 211 22 37 160 20 196 42 24 175 204 220 74 89 170 77 124 203 3 217 110 44 69 83 103 77 86 251 71 207 195 6 209 195 156 226 128 21 184 158 63 51 49 76 228 20 103 214 68 193 65 132 134 224 149 25 86 210 61 41 125 246 25 49 88 250 223 179 25 14 19 179 200 125 191 92 26 118 117 50 26 23 199 232 167 135 150 137 221 247 193 201 159 249 222 184 143 138 85 194 111 84 229 138 156 123 188 9 184 40 81 241 41 176 246 69 181 47 109 194 96 161 152 96 0 109 177 99 77 69 169 100 211 181 43 33 135 231 234 153 177 36 24 253 109 229 214 63 87 101 19 254 170 34 161 203 34 228 187 181 2 151 72 146 135 60 111 109 239 178 217 75 58 81 20 163 237 95 197 251 145 147 44 109 44 169 101 97 72 251 100 242 148 94 162 183 188 115 7 101 188 209 220 25 236 80 234 181 35 139 4 27 3 183 2 151 50 241 147 36 71 166 214 32 168 167 239 92 97 231 55 152 71 150 80 227 186 139 175 123 43 195 134 118 247 169 147 115 96 190 45 160 162 172 98 215 128 45 138 67 171 36 65 127 153 125 191 243 226 251 21 176 73 143 136 126 210 4 219 30 104 13 249 10 118 106 221 143 113 168 43 95 48 70 206 56 211 169 55 135 135 71 250 35 204 55 92 27 109 22 8 110 18 199 67 49 102 244 22 203 33 14 95 10 106 41 202 54 30 255 230 136 9 69 115 10 50 248 2 75 187 55 204 15 145 198 43 159 88 185 44 245 185 120 203 81 22 99 194 107 72 70 60 238 190 101 119 247 21 244 83 14 0 92 94 163 115 172 84 149 224 97 118 147 253 133 123 250 223 210 205 185 225 188 137 162 241 248 69 189 228 204 70 91 237 0 133 225 117 11 179 144 95 202 161 15 119 235 182 221 245 11 83 225 108 209 167 210 173 177 69 71 24 67 103 246 98 210 212 63 35 56 121 35 18 231 141 13 122 245 54 3 192 88 11 148 106 216 72 253 89 193 26 204 128 81 117 54 202 166 5 40 252 92 212 116 246 85 253 185 20 185 152 135 39 192 248 12 162 234 141 210 139 180 190 22 119 220 172 8 92 48 107 80 183 85 168 140 194 172 138 38 115 190 81 139 235 203 231 16 213 159 186 244 208 77 38 88 251 58 167 155 180 123 43 3 196 135 74 191 204 112 243 255 212 247 120 52 174 5 253 169 46 134 164 46 154 2 233 110 62 210 186 85 88 106 137 47 240 57 168 113 68 63 232 19 3 253 245 55 213 201 169 246 210 44 151 143 148 139 124 158 148 241 71 249 59 93 23 184 108 236 39 20 245 227 154 143 253 176 158 41 96 212 147 158 102 131 110 115 67 134 253 236 76 222 88 232 153 13 92 165 193 69 138 30 252 95 197 165 141 9 164 136 86 156 175 254 61 37 21 116 230 117 107 249 229 28 2 85 106 150 221 89 115 74 115 215 224 36 175 160 93 221 158 53 223 83 216 21 198 235 111 136 132 195 161 196 205 71 189 247 31 241 136 218 35 55 210 230 248 105 62 121 46 92 81 172 66 59 237 75 229 251 250 26 25 7 66 38 207 227 99 109 123 165 162 17 154 175 134 150 220 125 210 99 24 71 133 94 248 194 123 77 160 79 149 33 191 133 191 50 160 67 42 8 138 2 26 179 84 15 198 171 176 55 168 71 217 69 188 175 58 76 255 42 76 25 176 71 108 231 14 184 68 132 192 221 108 113 181 52 163 90 55 43 185 75 179 93 154 252 189 16 194 104 82 159 152 221 241 230 151 172 46 201 16 141 189 91 182 160 169 41 151 2 181 104 55 23 20 20 139 133 170 159 146 197 17 70 227 86 63 8 126 42 188 77 72 254 118 61 128 203 218 249 156 233 201 115 144 72 156 99 221 98 224 148 39 118 123 22 42 147 184 48 21 164 133 168 233 90 242 124 252 200 183 193 188 167 178 216 237 23 146 139 132 126 225 188 157 188 128 97 175 42 227 94 214 221 202 121 93 228 152 159 95 179 91 29 118 67 3 203 22 152 234 126 253 128 253 105 134 132 43 230 42 104 130 148 173 109 220 134 87 21 46 19 187 144 96 250 246 57 169 122 209 246 108 128 225 250 252 217 67 237 197 111 35 143 21 116 85 75 209 144 19 179 169 105 159 229 63 83 91 55 182 139 95 84 134 198 105 126 210 150 29 207 176 251 33 171 141 244 121 52 221 128 29 83 93 54 128 0 66 193 213 16 181 48 169 180 14 221 180 40 225 44 39 13 57 227 112 140 78 231 242 215 8 190 198 120 110 65 28 120 86 141 129 25 22 126 80 56 36 217 189 29 58 190 208 142 45 216 134 104 63 99 44 107 71 209 38 205 252 120 46 39 213 57 134 40 9 109 184 211 216 98 177 234 68 53 25 27 164 55 66 222 63 158 39 202 178 130 26 101 32 159 150 12 59 145 52 234 168 185 178 117 87 130 34 20 141 50 120 192 146 240 134 124 85 160 107 21 99 147 173 18 224 23 57 195 45 253 254 55 95 110 76 132 155 192 227 106 159 48 255 57 23 131 122 195 98 219 210 28 187 43 184 147 218 78 54 233 8 96 18 170 199 37 161 61 15 138 119 36 14 241 185 245 144 255 53 58 176 18 99 131 142 101 13 161 213 251 186 29 94 242 223 167 157 176 41 16 172 60 245 238 86 153 69 214 86 139 159 121 139 252 58 214 115 19 165 123 63 18 81 222 83 99 102 129 192 40 150 67 239 46 115 245 28 9 131 203 72 211 210 213 225 73 165 35 255 130 60 53 153 197 202 16 201 228 90 243 25 143 141 116 85 53 228 42 200 48 181 207 84 13 88 67 33 66 104 70 55 118 50 154 109 95 4 76 17 219 219 120 9 116 115 48 138 34 246 5 188 198 100 106 203 105 90 18 102 145 89 118 241 242 180 29 85 228 250 110 108 8 63 126 250 113 65 33 192 134 246 170 8 122 110 65 118 119 129 133 102 244 85 107 136 43 60 118 209 197 107 18 62 46 156 123 173 170 119 45 162 179 193 167 7 185 246 42 119 179 22 30 121 81 57 2 30 141 73 90 92 237 181 73 143 96 45 198 53 192 112 161 85 215 104 63 20 164 18 167 185 60 32 179 4 26 62 114 218 61 136 215 153 244 60 144 25 24 120 159 196 76 181 23 173 11 234 226 170 3 82 139 56 127 96 32 56 202 143 24 188 134 85 39 182 8 163 218 241 217 230 196 182 238 212 86 234 13 189 87 42 54 169 169 79 255 112 0 56 166 76 155 202 233 61 131 74 58 109 218 54 116 93 40 197 204 129 212 246 121 136 223 202 116 169 248 244 168 144 161 64 111 95 87 162 222 212 127 91 67 180 22 27 60 230 136 115 253 197 49 141 210 230 125 246 220 3 213 124 156 192 116 158 247 199 202 212 242 88 90 46 200 140 83 23 190 233 76 154 244 145 60 191 54 86 90 181 1 249 223 250 58 88 250 249 218 202 206 148 62 90 89 143 139 232 122 103 132 208 200 33 123 196 78 146 160 70 158 143 233 74 128 90 86 70 75 159 159 59 104 145 24 218 202 219 117 121 54 1 240 224 41 224 157 144 101 46 95 87 16 225 123 126 192 201 205 216 5 232 127 235 215 170 233 149 5 8 112 128 141 93 235 196 51 49 32 56 213 119 64 126 212 190 100 37 239 3 68 208 94 130 24 124 123 29 223 153 92 165 251 190 247 102 221 125 232 89 21 188 167 103 19 113 216 4 93 193 216 204 173 213 156 10 229 255 158 101 60 160 240 44 231 173 74 117 61 177 160 195 118 210 232 153 46 90 143 165 198 160 235 93 113 57 80 0 165 105 174 107 91 89 128 83 6 115 141 54 169 201 88 227 110 85 107 99 242 1 74 28 99 67 122 206 94 50 180 136 137 193 185 125 1 24 125 30 29 54 129 215 188 231 89 27 57 129 168 10 80 120 71 64 242 137 151 191 193 91 239 36 163 237 57 236 35 32 101 173 75 211 138 172 109 184 244 131 248 134 150 199 200 154 12 46 10 51 209 81 248 85 113 159 178 160 205 106 184 175 44 46 32 242 220 208 209 39 8 103 92 233 215 254 182 178 226 227 153 128 74 5 31 79 112 18 247 21 90 239 198 132 21 129 185 250 104 218 29 210 101 202 245 120 249 216 212 224 116 231 10 195 200 208 250 38 30 8 108 191 26 0 72 193 113 120 146 174 9 118 160 57 144 49 8 228 121 171 230 71 137 3 59 77 141 161 83 233 55 173 113 115 28 254 56 223 121 184 212 18 222 145 35 206 72 202 97 150 175 131 220 93 120 72 63 53 225 171 149 37 184 43 80 62 72 249 9 42 148 115 74 87 177 59 87 176 230 109 102 77 41 162 220 184 52 206 201 33 142 172 203 119 162 112 221 224 185 191 89 100 237 175 213 89 152 240 142 210 116 196 93 18 34 150 158 202 19 62 218 102 44 22 140 234 76 255 16 88 84 226 7 159 187 84 200 32 110 32 183 238 69 132 138 161 11 129 100 154 144 96 119 98 85 167 252 167 195 156 134 224 2 150 160 145 225 134 70 181 37 211 8 26 165 105 90 39 176 116 135 230 137 200 201 89 152 244 233 192 27 176 219 4 227 2 42 230 134 129 207 168 70 239 196 93 18 61 55 35 188 79 26 115 221 121 201 238 99 151 108 72 148 96 45 170 113 49 238 104 193 207 208 187 78 86 207 156 51 211 227 43 100 49 207 28 177 242 36 193 238 62 183 29 78 157 121 12 193 60 174 48 21 195 92 77 211 103 67 233 220 76 233 44 145 234 144 229 20 52 87 48 196 31 235 43 1 220 142 47 41 255 234 208 239 78 115 131 56 218 154 167 145 183 3 219 218 73 110 218 84 101 42 159 127 85 236 155 184 229 39 251 5 179 31 218 216 255 49 94 248 245 160 241 38 234 161 51 111 179 196 15 19 220 188 236 206 142 77 153 79 152 3 239 72 219 219 69 55 31 120 188 213 42 201 36 82 21 190 90 161 144 241 160 141 120 162 63 133 22 162 21 237 156 171 109 132 84 40 230 202 34 182 205 249 170 189 3 97 50 27 191 173 229 42 35 172 64 204 162 51 212 143 161 37 241 130 81 103 51 28 230 184 228 178 57 217 157 91 86 4 200 82 41 73 127 143 200 189 128 160 132 161 44 85 83 105 244 177 128 141 95 226 34 234 123 68 169 47 162 216 80 140 31 150 229 129 185 106 48 190 105 40 63 168 126 57 165 21 122 236 250 247 121 99 255 228 237 85 173 198 7 146 14 173 184 45 199 149 219 28 26 34 150 31 129 8 6 238 129 51 1 177 93 200 194 34 38 102 40 69 23 207 148 95 171 101 47 1 234 227 157 206 154 52 163 201 33 167 155 185 205 105 58 197 148 248 134 230 2 95 110 188 2 242 20 200 132 7 47 53 194 214 165 80 15 134 134 219 149 9 198 192 203 117 215 232 59 252 189 101 107 204 42 50 15 123 251 91 150 197 169 239 49 254 66 198 66 248 146 134 133 54 227 18 15 87 156 187 146 92 81 176 169 146 213 1 167 238 148 242 199 179 157 112 198 163 241 207 227 84 101 189 149 74 154 59 157 100 87 173 245 87 126 159 237 49 203 48 205 224 19 168 253 230 8 238 89 124 107 89 112 198 130 92 248 195 188 203 126 166 2 178 94 253 41 226 3 254 104 127 7 108 140 162 133 21 12 177 95 50 65 134 10 120 100 146 231 252 86 254 138 126 157 234 131 195 124 120 121 210 172 149 213 22 200 126 3 194 179 99 162 185 138 77 4 38 129 91 172 31 15 173 23 50 153 113 3 184 59 172 221 99 214 240 45 108 6 52 185 80 113 83 194 28 74 233 139 177 226 246 99 175 168 146 42 155 83 224 164 134 205 132 102 178 219 170 153 123 116 151 59 14 143 189 172 4 71 227 83 241 73 189 139 62 247 103 196 170 231 198 243 250 25 232 32 139 134 217 94 219 180 147 54 104 20 73 226 170 27 129 179 195 248 182 137 110 29 112 192 59 3 158 147 131 4 191 12 184 253 122 158 11 143 49 179 94 221 140 71 33 200 242 190 190 255 10 213 202 94 221 121 238 207 136 175 137 133 39 243 15 187 20 120 195 203 218 10 68 121 17 201 80 155 64 191 109 147 78 79 8 180 155 108 30 218 155 231 185 217 131 133 216 188 5 90 232 55 47 150 4 137 70 224 113 215 225 2 186 86 182 187 154 224 228 32 123 221 241 142 10 104 43 47 57 246 47 182 248 82 149 37 125 112 72 77 26 177 59 34 172 188 48 245 155 39 161 186 40 157 5 171 111 86 199 30 150 251 57 137 191 37 179 4 96 154 20 17 135 160 218 84 192 53 47 129 166 16 126 120 192 15 226 0 203 89 183 27 123 105 24 173 77 22 177 81 129 88 67 171 36 228 95 163 137 144 32 183 44 126 45 36 178 148 6 212 3 175 2 243 4 188 43 204 209 157 145 85 229 207 206 162 18 168 100 185 69 207 132 61 8 44 19 224 204 252 47 129 39 236 163 134 71 244 39 65 61 66 86 165 65 155 255 203 77 175 21 183 60 7 117 1 63 218 173 79 253 241 42 143 27 25 235 123 14 144 167 13 101 39 96 15 102 34 235 18 40 46 63 166 72 82 40 134 240 194 164 176 2 83 92 227 255 239 139 234 252 252 115 53 119 241 97 22 113 93 198 171 183 102 173 24 39 247 110 111 229 188 232 235 201 129 159 247 156 206 108 23 49 12 177 246 60 25 25 220 26 93 104 30 140 183 100 80 146 212 86 82 194 221 58 31 43 28 141 69 190 194 219 53 37 55 183 59 238 229 144 157 245 156 59 198 244 132 195 254 146 169 90 83 236 23 4 179 96 241 237 221 66 178 2 182 124 248 107 98 51 25 2 172 167 8 218 239 216 65 225 217 174 51 65 129 13 229 83 110 108 187 202 253 0 60 1 66 250 236 184 216 103 129 216 192 188 72 254 149 144 171 57 117 19 192 163 21 110 215 161 160 20 11 182 233 8 131 206 252 206 75 173 253 80 70 236 205 140 177 21 141 183 103 37 90 196 2 154 183 134 46 130 17 148 241 105 88 42 15 224 221 18 54 173 102 52 93 13 139 77 192 189 75 136 39 161 202 117 111 204 234 114 83 36 69 134 106 176 43 170 31 8 118 16 183 142 74 139 171 112 113 234 97 42 97 237 42 8 187 103 158 41 1 17 225 79 145 133 173 33 165 145 227 188 206 90 64 107 197 87 195 240 75 131 247 75 7 62 91 138 125 68 197 215 93 104 211 251 65 136 152 14 96 31 181 185 255 90 130 165 147 91 36 130 78 155 91 240 192 91 190 190 130 239 193 85 1 10 172 233 117 225 54 0 156 66 183 165 231 51 21 55 76 220 43 180 66 114 95 233 180 236 74 75 53 115 148 14 99 228 71 168 46 60 50 95 193 97 175 200 128 124 234 171 109 195 73 234 85 62 175 167 8 36 130 112 33 235 202 30 173 236 249 40 110 84 56 168 145 64 224 85 145 68 216 85 126 59 234 166 207 104 113 201 44 180 23 70 154 226 184 212 89 255 3 183 86 142 56 144 174 62 61 138 214 7 249 78 68 34 16 143 61 172 225 186 188 126 124 213 203 50 228 34 124 21 69 187 56 230 201 144 158 37 110 116 68 27 125 85 203 127 19 36 222 212 15 198 14 84 181 42 0 254 196 247 127 70 189 100 24 51 11 69 91 147 163 230 189 50 144 134 186 46 103 249 242 17 97 153 185 77 185 240 149 215 217 118 149 129 217 217 212 144 80 233 93 172 107 190 128 235 214 244 2 130 242 36 113 49 215 165 245 165 157 80 162 167 0 190 189 155 107 58 156 231 199 140 158 237 122 227 204 142 61 243 93 237 12 178 165 142 158 182 28 127 171 131 190 36 175 20 154 152 172 163 193 197 115 67 112 251 241 159 136 129 102 123 8 106 130 51 42 17 140 224 0 134 138 176 209 106 65 163 94 244 92 192 94 87 32 146 118 246 20 82 2 222 233 5 227 148 249 127 109 71 148 127 196 154 172 110 224 143 97 36 52 172 41 80 134 39 43 115 18 202 14 164 31 246 5 114 156 9 252 179 227 187 57 215 240 57 129 70 203 15 42 95 49 23 142 169 87 102 217 125 102 164 233 245 59 192 51 60 103 18 99 234 200 215 177 95 146 114 90 101 243 156 230 74 43 45 20 180 33 221 209 170 19 78 186 227 191 45 193 115 228 252 57 101 113 7 139 16 23 140 148 31 201 115 144 45 179 249 103 208 118 7 21 241 229 152 207 181 142 98 4 47 137 144 99 147 208 74 116 194 245 134 146 123 229 228 204 161 110 25 13 160 222 148 179 203 79 140 49 111 98 75 233 61 114 63 229 55 249 157 184 124 6 43 181 56 133 123 138 170 172 222 252 9 139 215 40 205 134 230 197 63 75 210 109 54 39 203 25 95 162 147 33 208 21 57 230 32 111 87 218 144 153 203 31 10 85 15 149 95 129 87 247 247 98 191 63 230 169 142 47 143 130 93 152 50 108 117 140 41 154 101 254 193 175 118 67 204 146 229 74 80 211 250 16 207 128 106 235 62 105 9 133 35 141 216 87 28 164 71 113 183 213 248 143 67 45 213 84 250 141 60 5 107 114 248 102 28 119 167 35 190 163 144 128 254 24 241 93 39 85 26 234 188 226 179 58 211 195 29 170 57 89 152 77 30 18 249 218 194 80 170 227 175 18 213 44 26 160 76 54 71 51 118 13 113 104 13 59 164 209 3 174 94 139 28 183 57 228 110 120 213 14 104 68 219 53 105 87 128 227 165 228 24 162 220 111 221 146 67 190 153 215 91 146 208 227 164 203 6 57 208 123 118 203 122 32 12 76 249 110 221 246 244 32 83 252 153 0 89 34 69 189 89 229 241 244 251 173 172 144 166 186 181 13 19 119 184 180 61 174 0 170 252 250 245 231 7 224 133 132 3 123 223 6 158 137 63 172 160 233 145 50 9 234 114 188 174 247 220 109 254 118 193 118 209 48 248 63 149 233 234 98 83 68 242 75 39 74 60 235 204 5 235 101 220 123 151 138 84 34 2 41 21 49 209 247 249 182 213 0 158 176 84 126 247 68 64 109 141 20 33 179 249 106 127 148 23 255 223 50 39 236 42 109 38 127 37 151 221 161 125 170 173 223 234 245 240 206 123 154 246 139 26 177 26 35 2 33 181 250 14 151 172 88 42 11 136 224 73 89 227 197 89 171 51 88 206 67 234 129 94 248 59 168 32 136 31 162 243 127 161 246 94 49 243 239 10 160 184 47 126 171 13 34 59 127 37 26 86 135 191 180 193 58 160 73 46 189 138 240 35 55 165 157 239 64 183 233 225 217 249 234 84 208 8 159 51 227 109 158 179 87 220 158 175 210 131 177 204 209 48 240 231 24 222 11 187 85 11 97 101 66 21 205 94 126 85 236 39 241 196 175 219 38 238 245 159 49 77 199 196 110 218 150 223 145 49 49 127 62 140 140 27 53 37 79 19 49 135 176 144 235 28 123 245 229 175 31 167 163 2 135 209 2 223 60 132 10 79 182 23 8 132 44 197 24 123 193 91 106 116 79 97 249 8 77 185 136 105 128 110 4 9 27 235 203 1 128 127 125 0 165 165 165 165 1 0 0 68 0 0 180 207 51 128 182 14 50 169 0 0 74 39 0 0 101 98 0 0 0 0 0 20 194 229 0 0 0 0 0 0 0 0 0 0 0 0 0 0 83 113 117 101 97 107 73 110 66 114 111 119 115 101 114 46 114 115 114 99 0 1 134 53 114 115 114 99 82 83 69 68 1 0 4 0 0 129 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 1 253 0 0 1 137 0 0 0 0 15 0 66 193 212 234 64 99 97 40 139 5 15 124 31 121 65 120 146 200 173 211 210 149 182 129 158 205 118 129 207 95 40 49 56 157 177 180 70 149 83 54 3 21 101 109 192 23 68 207 158 18 100 184 200 57 166 54 189 7 10 8 35 160 31 189 69 96 6 251 36 144 52 46 122 224 140 131 142 107 203 86 133 196 231 193 118 175 248 52 27 9 237 188 57 72 178 184 251 102 202 113 145 140 10 144 242 70 217 116 15 106 131 246 74 196 1 22 89 124 130 39 36 161 170 59 206 175 126 171 28 60 247 201 113 130 115 211 207 61 71 255 51 103 85 164 106 4 45 107 151 164 234 135 37 154 140 172 36 162 124 138 123 134 131 22 222 204 0 143 209 176 180 40 40 83 131 32 200 202 141 130 221 88 227 19 175 6 121 236 249 59 11 214 118 118 203 22 70 160 90 245 161 227 255 229 122 250 193 135 203 10 226 24 65 203 79 121 182 197 210 18 129 97 215 101 195 170 225 244 234 54 162 2 70 49 242 208 45 192 209 41 192 140 163 193 203 28 229 201 202 3 215 230 23 44 15 110 165 188 64 227 33 30 189 93 89 180 203 179 31 169 10 141 180 17 200 146 27 13 238 56 10 29 23 62 248 208 13 168 201 252 10 236 197 19 236 183 94 95 27 17 242 58 179 242 109 147 121 193 155 144 46 248 52 226 149 176 250 202 4 58 89 131 34 148 100 124 228 53 56 166 208 218 140 69 213 223 84 198 170 44 98 130 94 24 65 112 50 62 107 104 26 218 230 148 65 52 215 139 174 49 8 141 106 8 247 50 218 37 118 118 249 63 141 166 56 43 243 68 242 131 7 252 7 29 103 22 146 152 169 150 22 142 32 165 165 165 165 1 0 0 62 0 0 181 174 119 219 182 77 216 118 0 0 99 99 0 0 0 0 0 0 0 0 0 14 103 216 0 0 0 0 0 0 0 0 0 0 0 0 0 0 83 113 117 101 97 107 65 112 112 46 114 115 114 99 0 1 218 217 114 115 114 99 82 83 69 68 1 0 255 255 255 255 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 0 40 104 0 0 13 40 0 0 0 0 15 0 66 193 212 197 152 42 182 125 7 209 253 179 246 11 43 249 23 162 71 36 169 250 206 186 205 66 199 226 98 55 7 177 53 236 55 58 79 128 26 51 183 167 240 97 86 128 242 71 242 67 174 16 134 228 55 218 207 53 158 128 112 186 172 232 44 219 195 5 180 24 55 31 245 94 187 102 126 16 225 179 154 193 117 248 105 117 137 150 166 228 202 174 98 128 190 102 60 144 107 20 18 75 136 179 30 85 35 195 28 12 247 213 107 204 112 228 106 25 110 4 221 123 213 59 16 187 58 94 158 27 188 245 213 128 9 187 130 72 240 30 18 151 45 85 48 180 5 174 122 71 58 54 143 167 128 15 181 234 211 148 60 98 50 11 144 242 246 177 192 149 156 85 165 182 226 173 152 245 203 119 112 220 233 96 107 53 59 249 50 154 14 247 103 36 101 32 250 43 139 76 121 77 153 238 120 50 78 196 146 143 89 11 166 238 44 175 144 152 163 178 112 169 179 103 226 51 222 50 173 237 139 145 162 210 63 68 250 39 244 117 11 92 69 182 204 20 110 203 107 28 152 74 89 68 140 252 178 251 139 206 236 1 31 160 134 231 48 71 246 252 66 249 35 122 4 209 145 48 70 240 233 126 104 2 47 204 88 178 155 109 195 129 244 240 81 167 114 214 18 144 131 73 169 35 230 68 150 251 95 220 251 117 22 186 127 175 169 13 235 137 211 56 50 114 113 53 35 23 73 238 70 94 196 46 93 245 233 196 175 248 31 199 194 45 248 43 56 209 224 247 48 231 70 62 181 117 249 241 143 47 190 228 101 185 117 82 48 249 145 171 27 146 252 3 200 220 146 109 217 227 112 120 57 54 164 101 212 114 247 40 244 177 184 166 140 54 130 49 116 50 115 29 177 14 114 213 40 244 211 3 90 221 26 25 251 45 1 226 81 146 137 162 26 131 89 169 44 97 25 167 10 141 134 209 150 115 100 170 60 142 38 78 118 161 100 10 178 72 69 44 58 161 188 43 226 48 17 124 149 125 13 90 82 60 202 14 56 90 55 83 89 66 117 231 200 238 140 51 113 69 149 224 131 185 225 75 101 192 217 120 23 0 198 25 227 166 27 177 149 232 124 148 80 123 62 189 232 223 176 7 144 111 105 250 111 133 237 167 129 109 211 225 145 239 23 226 245 181 66 69 66 133 132 83 190 152 254 108 193 2 94 18 209 199 117 204 70 221 245 139 68 110 211 141 193 251 18 9 241 78 245 7 200 116 236 156 64 176 236 204 122 179 165 233 163 43 5 26 50 222 240 131 172 0 89 159 186 176 3 21 182 112 18 227 250 222 236 26 99 160 219 162 118 217 47 123 104 42 105 148 67 20 127 185 244 232 254 213 66 139 5 52 240 142 2 127 59 32 245 12 159 87 243 126 180 225 198 21 81 117 169 59 2 173 149 90 248 17 50 77 39 124 242 224 189 137 91 145 56 130 73 192 106 124 172 72 31 228 141 133 3 148 132 243 242 101 195 171 219 161 141 22 233 139 235 186 141 186 89 25 101 33 229 92 84 50 19 191 175 209 88 207 89 174 223 19 197 28 10 219 142 73 199 74 24 43 188 224 215 60 241 161 76 83 193 182 59 14 193 133 95 238 105 29 42 94 205 150 154 164 227 29 137 40 239 113 134 188 186 116 115 151 108 43 204 147 73 59 10 169 136 223 188 62 145 228 215 123 117 145 189 216 254 33 80 103 236 221 103 169 91 117 130 101 57 124 183 196 243 179 67 75 122 248 62 225 8 141 159 167 151 46 229 82 70 34 71 65 33 97 177 11 119 51 12 253 244 11 41 26 31 56 103 9 142 180 80 149 96 199 3 179 95 26 75 109 202 192 97 146 255 123 10 183 120 117 187 41 151 167 69 14 99 130 173 149 73 72 94 84 40 154 18 192 247 172 42 125 12 149 6 196 255 82 136 130 244 149 67 66 144 83 127 74 176 46 251 132 227 231 176 130 227 51 120 83 84 13 43 102 123 38 171 245 29 13 141 59 169 232 90 172 218 123 238 251 136 255 137 97 254 107 223 252 155 49 62 95 180 123 229 81 0 146 135 130 82 8 225 29 2 223 236 130 58 163 44 114 134 2 202 80 160 220 202 159 66 81 31 85 189 221 199 92 24 84 105 74 254 192 253 28 87 145 161 163 21 186 254 52 94 42 250 246 151 29 180 44 76 139 66 0 205 253 216 187 171 178 162 133 238 37 77 177 24 181 173 161 108 32 139 24 164 154 252 201 135 112 82 176 198 66 241 23 249 137 31 165 82 148 80 5 125 158 149 121 158 215 191 173 198 239 220 112 227 155 129 19 190 73 167 3 195 125 1 192 199 125 155 89 137 241 65 210 146 36 196 30 180 171 201 250 102 54 255 103 116 81 102 76 115 43 233 15 132 185 194 38 167 199 125 167 169 142 69 163 225 186 146 109 191 42 154 250 162 48 70 120 194 109 253 160 90 20 245 237 75 193 20 2 246 1 208 117 19 242 50 218 120 226 131 254 89 59 200 32 177 138 199 170 89 20 231 9 185 179 213 233 140 91 87 239 179 120 30 130 231 59 19 8 236 225 203 156 138 95 84 213 13 53 20 73 83 48 172 156 64 169 49 176 145 245 141 146 194 178 13 122 13 224 139 18 104 23 38 86 151 229 93 169 192 143 207 133 23 152 163 240 155 78 158 59 142 86 33 107 204 195 184 123 43 175 2 183 149 211 242 18 178 162 49 101 190 114 156 131 159 104 18 255 174 66 67 29 251 127 225 78 196 146 11 75 128 10 163 64 179 23 216 176 108 7 126 94 174 12 67 23 152 92 182 216 43 57 222 112 146 12 13 108 166 175 82 46 112 75 73 26 136 187 252 185 161 15 224 48 189 26 96 147 221 32 237 67 119 48 208 64 175 149 240 238 20 20 204 108 191 106 175 2 61 98 21 90 228 214 151 14 61 199 231 23 133 234 240 25 18 134 67 238 191 212 247 218 6 112 232 138 207 66 174 183 187 79 124 93 58 181 171 156 155 94 235 68 18 50 138 96 134 233 206 48 75 165 10 55 137 234 228 143 44 4 94 133 87 18 13 183 184 161 16 105 58 118 4 132 168 2 202 110 182 177 7 211 127 17 97 211 127 168 56 25 240 11 197 47 12 220 220 220 223 246 163 123 247 89 47 203 127 186 92 145 184 152 85 142 34 23 220 192 74 23 129 98 229 117 92 12 248 77 209 248 173 72 166 34 191 57 112 2 91 5 194 142 64 38 248 156 68 216 180 109 54 145 241 67 40 105 255 226 217 12 44 175 219 29 255 163 121 156 176 101 144 218 211 7 98 203 101 21 148 125 79 40 177 70 85 4 145 207 124 158 107 192 15 182 78 131 108 198 143 75 192 80 197 74 135 208 28 248 123 177 244 83 57 154 229 0 103 90 4 4 161 254 200 18 161 54 113 234 178 111 194 227 233 137 200 51 202 170 30 57 101 5 53 92 245 201 151 139 114 83 133 235 118 230 19 84 68 86 232 37 217 13 112 46 103 211 146 116 112 221 40 73 31 178 1 86 184 146 61 239 186 65 121 90 250 185 172 110 79 26 87 220 10 127 176 253 194 48 207 174 185 215 40 166 83 157 74 129 65 253 248 171 153 219 78 73 225 220 246 100 5 31 252 118 223 28 208 61 177 129 74 99 86 50 232 54 243 233 219 89 92 202 153 170 133 17 38 169 221 62 209 122 67 170 96 177 144 31 61 39 248 107 140 133 205 169 139 25 168 20 195 116 236 41 148 68 122 169 200 20 187 14 127 185 206 245 187 167 99 46 149 94 88 208 65 132 19 58 222 108 48 204 197 71 13 63 182 59 97 213 222 58 111 220 124 145 92 129 195 151 19 242 113 213 153 58 41 89 150 148 52 175 102 243 180 163 164 103 70 127 180 218 186 85 83 79 239 242 96 50 249 146 232 238 84 3 155 56 121 174 242 1 104 196 21 3 44 39 70 101 93 136 211 187 101 132 211 159 186 225 186 191 83 15 172 214 118 168 6 92 55 224 125 63 177 80 109 227 132 29 176 179 247 7 150 202 227 144 90 245 193 81 29 186 181 60 201 174 159 129 141 106 224 89 151 48 21 22 163 162 146 199 236 25 44 243 191 30 239 66 8 235 253 61 62 26 45 97 66 73 141 225 179 88 16 198 101 129 120 158 63 232 171 42 214 128 249 123 69 97 155 94 177 164 184 230 220 48 103 18 5 172 211 65 180 63 48 174 36 50 190 179 29 10 100 27 236 55 222 41 119 87 61 250 30 117 183 144 25 219 68 234 240 168 6 32 254 82 29 201 231 49 134 227 150 99 150 64 200 13 19 149 212 96 71 201 46 123 44 46 155 236 10 241 29 210 99 154 83 202 171 210 206 76 73 191 78 143 11 175 88 251 218 47 42 224 243 230 198 175 11 31 144 155 116 156 216 13 244 194 45 183 93 193 237 206 1 245 51 109 155 22 193 65 225 93 87 41 240 133 187 138 165 83 126 119 228 142 31 143 23 182 190 16 209 55 165 18 21 94 242 88 177 86 97 22 7 235 80 76 159 40 52 26 202 239 65 176 79 64 187 221 132 84 12 144 228 187 53 250 43 11 9 105 74 240 172 182 42 75 170 116 74 27 182 206 72 18 11 209 158 251 23 4 252 23 78 40 120 184 36 244 217 133 201 133 134 243 185 113 72 155 244 44 138 39 1 35 109 206 112 111 135 175 30 220 225 109 41 162 45 217 212 98 122 10 32 249 179 36 189 187 123 29 44 197 33 9 190 224 155 89 124 183 214 167 243 39 255 202 24 13 245 112 204 160 85 9 112 72 104 19 202 137 75 106 227 223 10 195 3 156 92 151 183 165 126 37 93 188 165 168 20 215 106 123 67 169 68 189 23 75 62 213 206 107 4 254 7 24 81 133 14 78 4 91 1 255 95 176 232 254 66 68 84 99 123 62 114 169 246 184 202 222 51 57 178 111 81 122 87 144 153 176 236 72 128 11 75 46 193 66 41 92 238 139 28 194 83 215 154 201 18 94 122 90 62 143 22 77 216 10 72 134 144 117 196 200 188 155 138 84 185 143 245 221 104 31 162 243 181 6 231 243 176 169 192 20 237 232 66 7 109 101 249 215 29 216 42 92 233 93 229 118 229 199 252 160 20 20 213 149 230 166 41 111 172 94 194 206 60 221 127 66 167 117 26 128 168 128 243 28 89 8 166 81 32 30 0 238 16 224 139 7 91 218 94 153 187 134 53 145 144 20 98 10 126 252 63 134 142 198 33 227 98 249 26 147 30 14 25 75 26 209 75 209 80 45 78 35 110 242 202 30 130 202 106 225 183 8 151 189 72 150 237 191 206 46 119 12 177 5 81 86 162 152 143 29 158 103 241 40 76 65 114 245 198 231 24 29 180 212 109 56 12 55 204 92 123 240 63 124 194 160 36 38 199 236 148 244 184 98 242 75 13 203 243 190 86 35 119 234 249 174 178 21 122 136 103 136 46 112 56 44 62 220 92 24 124 159 84 245 142 21 209 56 205 183 187 168 197 146 107 148 57 93 110 42 41 182 160 83 36 199 182 93 191 248 224 166 170 147 143 201 21 51 42 235 9 81 193 226 52 45 121 120 94 239 22 253 39 27 198 183 39 67 107 43 174 65 180 229 184 128 215 81 166 191 161 207 15 107 124 74 106 200 110 48 7 33 233 57 248 102 5 241 219 65 152 60 220 56 47 193 8 53 14 174 4 81 93 254 88 59 209 31 12 165 208 185 53 178 113 12 193 61 80 70 51 122 113 34 29 236 155 119 62 187 129 110 18 244 159 47 216 76 29 168 177 138 124 80 215 220 28 47 80 219 9 39 130 105 8 245 82 185 51 109 58 104 133 200 194 74 128 153 124 140 25 212 46 199 17 35 185 134 216 247 42 189 68 2 200 68 60 181 129 216 25 44 187 135 230 235 147 102 121 37 66 47 110 123 253 21 83 65 120 102 70 2 23 90 25 61 45 249 248 174 60 182 186 153 124 179 252 210 126 225 63 180 2 159 113 44 88 173 215 239 103 224 196 193 231 170 119 227 106 120 98 234 198 44 233 17 112 9 203 178 134 215 177 95 30 215 105 70 189 15 16 8 210 42 223 189 170 43 56 146 211 189 12 81 103 174 101 26 147 68 240 45 64 22 172 40 97 40 129 25 98 48 219 244 135 13 93 163 105 64 28 193 67 8 239 241 26 30 218 148 178 92 95 172 126 113 154 37 213 120 155 5 96 143 52 203 246 60 255 23 133 251 90 80 184 215 94 14 35 226 114 209 63 105 224 231 246 6 73 136 28 34 177 78 242 57 228 135 108 104 144 48 142 238 199 230 86 199 179 222 57 208 179 209 231 82 222 98 101 254 229 8 185 213 235 117 220 132 6 116 38 237 23 227 205 0 60 69 43 81 3 64 33 183 171 158 60 100 223 63 184 147 252 84 228 166 102 130 46 149 190 130 206 254 174 228 193 78 71 62 122 252 60 56 231 128 120 139 143 36 38 68 3 109 58 4 58 82 31 109 197 211 56 176 126 70 33 112 81 201 58 231 88 18 7 178 168 179 225 94 112 231 52 93 71 28 68 99 155 211 101 195 165 121 208 115 189 190 254 164 155 118 20 228 86 219 221 220 47 193 102 12 195 159 148 12 108 236 226 110 105 223 169 115 43 174 84 183 120 219 130 103 117 123 249 249 248 229 184 135 216 186 90 124 151 185 105 67 38 223 126 180 175 103 89 83 228 36 34 144 185 71 236 79 213 67 75 96 34 81 88 68 27 193 161 27 225 48 228 91 242 83 216 196 238 38 5 136 81 104 99 174 78 41 226 89 67 102 168 52 98 209 41 213 41 219 229 50 245 250 86 170 149 218 44 178 0 204 157 61 193 38 204 227 134 99 116 45 37 53 156 133 81 0 224 166 93 57 92 235 8 143 228 164 57 24 31 236 70 229 198 43 96 24 247 81 36 210 148 107 26 182 43 60 112 78 75 26 82 238 109 60 134 32 0 148 210 106 59 221 255 221 248 124 235 235 231 201 242 163 145 180 174 12 219 5 176 54 19 189 119 40 20 232 177 182 116 239 183 108 73 185 104 103 112 44 61 53 137 190 135 160 216 66 223 140 190 56 174 227 250 106 119 94 174 197 223 214 81 148 199 105 191 143 180 74 189 105 238 91 211 71 181 150 166 201 114 127 97 125 125 4 74 146 10 227 86 179 126 10 227 40 41 146 63 4 139 163 200 245 209 102 122 24 163 190 10 27 80 206 190 222 59 31 252 104 44 167 216 242 110 166 245 113 205 219 194 92 102 88 235 10 211 187 20 225 4 63 197 19 77 131 24 67 200 124 155 46 35 48 139 87 156 191 151 93 83 115 31 186 147 241 169 119 121 65 227 83 165 145 164 222 208 13 211 176 88 30 249 165 195 114 24 200 229 79 111 54 64 41 230 138 224 119 9 10 96 167 14 68 246 111 32 164 88 65 155 0)! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:39'!
macAsyncFilePrimsFile

	^ '/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */

#include "sq.h"
#include "AsynchFilePlugin.h"
#include <devices.h>

#if !!TARGET_API_MAC_CARBON
#define DisposeIOCompletionUPP(userUPP) DisposeRoutineDescriptor(userUPP)
#endif
/* initialize/shutdown */
int asyncFileInit() { return true; }
int asyncFileShutdown() {} 

/* End of adjustments for pluginized VM */

/*
  Experimental support for asynchronous file reading and writing.

  When a read or write operation is initiated, control is returned to Squeak
  immediately. A semaphore is signaled when the operation completes, at which
  time the client can find out how many bytes were actually read or written
  and copy the results of the read operation from the file buffer into a Squeak
  buffer. Only one operation may be in progress on a given file at a given time,
  but operations on different files may be done in parallel.

  The semaphore is signalled once for each transfer operation that is successfully
  started, even if that operation later fails. Write operations always write
  their entire buffer if they succeed, but read operations may transfer less than
  their buffer size if they are started less than a buffer''s size from the end
  of the file.
  
  The state of a file is kept in the following structure, which is stored directly
  in a Squeak ByteArray object:

    typedef struct {
	  int				sessionID;
	  AsyncFileState	*state;
    } AsyncFile;

  The session ID is used to detect stale files--files that were open
  when the image was saved. The state pointer of such files is meaningless.
  Async file handles use the same session ID as ordinary file handles.

  Note: These primitives are experimental!! They need not be implemented on
  every platform, and they may be withdrawn or replaced in a future release.
*/

#include <Errors.h>
#include <Files.h>
#include <Strings.h>

/* Async file handle (defined in header file):
*/

typedef struct {
	ParamBlockRec pb;  /* must be first */
	long	refNum;
	int		writable;
	int		semaIndex;
	int		status;
	int		bytesTransferred;
	int		bufferSize;
	char 	*bufferPtr;
} AsyncFileState;

/*** Status Values ***/
#define IDLE			0
#define LAST_OP_FAILED	1
#define BUSY			2

/*** Imported Variables ***/
extern int successFlag;
extern int thisSession;

/*** Local Vaiables ***/
IOCompletionUPP asyncFileCompletionProc = nil;

/*** Exported Functions ***/
int asyncFileClose(AsyncFile *f);
int asyncFileOpen(AsyncFile *f, int fileNamePtr, int fileNameSize, int writeFlag, int semaIndex);
int asyncFileRecordSize();
int asyncFileReadResult(AsyncFile *f, int bufferPtr, int bufferSize);
int asyncFileReadStart(AsyncFile *f, int fPosition, int count);
int asyncFileWriteResult(AsyncFile *f);
int asyncFileWriteStart(AsyncFile *f, int fPosition, int bufferPtr, int bufferSize);

/*** Local Functions ***/
int asyncFileAllocateBuffer(AsyncFileState *state, int byteCount);
pascal void asyncFileCompletionRoutine(AsyncFileState *state);
int asyncFileInitPB(AsyncFileState *state, int fPosition);
int asyncFileValid(AsyncFile *f);

int asyncFileAllocateBuffer(AsyncFileState *state, int byteCount) {
  /* Allocate a new buffer of the given size if necessary. If the current buffer
	 is already allocated and of the desired size, do nothing. */

	if ((state->bufferPtr !!= nil) && (state->bufferSize == byteCount)) {
		return;  /* buffer is already allocated and of the desired size */
	}

	/* free old buffer, if any */
	if (state->bufferPtr !!= nil) {
		DisposePtr(state->bufferPtr);
		state->bufferSize = 0;
		state->bufferPtr = nil;
	}

	/* allocate new buffer */
	state->bufferPtr = NewPtr(byteCount);
	if (state->bufferPtr == nil) {
		state->bufferSize = 0;
		return success(false);  /* could not allocate a buffer of size count */
	}
	state->bufferSize = byteCount;
}

pascal void asyncFileCompletionRoutine(AsyncFileState *state) {
  /* Called when an I/O request completes. Decides what to do based on the given state.
	 Note that the first part of the state record is the I/O parameter block. */

	OSErr err;

	err = state->pb.ioParam.ioResult;
	if ((err !!= noErr) && (err !!= eofErr)) {
		/* Note: eofErr indicates that fewer than the count bytes were transfered when
		   reading because the end-of-file was encountered first; it isn''t a real error. */
		state->status = LAST_OP_FAILED;
		state->bytesTransferred = 0;
		signalSemaphoreWithIndex(state->semaIndex);
		return;
	}
	state->bytesTransferred = state->pb.ioParam.ioActCount;
	state->status = IDLE;
	signalSemaphoreWithIndex(state->semaIndex);
}

int asyncFileInitPB(AsyncFileState *state, int fPosition) {
	memset(&state->pb, 0, sizeof(ParamBlockRec));
	state->pb.ioParam.ioCompletion = asyncFileCompletionProc;
	state->pb.ioParam.ioRefNum = state->refNum;
	state->pb.ioParam.ioBuffer = state->bufferPtr;
	state->pb.ioParam.ioReqCount = state->bufferSize;
	state->pb.ioParam.ioPosMode = fsFromStart;
	state->pb.ioParam.ioPosOffset = (fPosition < 0) ? 0 : fPosition;
	state->status = BUSY;
	state->bytesTransferred = 0;
}

int asyncFileValid(AsyncFile *f) {
	return (
		(f !!= NULL) &&
		(f->sessionID == thisSession) &&
		(f->state !!= NULL) &&
		(((AsyncFileState *) f->state)->refNum !!= 0));
}

/*** Exported Functions ***/

int asyncFileClose(AsyncFile *f) {
  /* Close the given asynchronous file. */

	AsyncFileState *state;
	short int volRefNum;
	OSErr err;

	if (!!asyncFileValid(f)) return;  /* already closed */
	state = f->state;

	err = GetVRefNum(state->refNum, &volRefNum);
	success(err == noErr);

	err = FSClose(state->refNum);
	success(err == noErr);

	if (successFlag) err = FlushVol(NULL, volRefNum);
	success(err == noErr);

    if (asyncFileCompletionProc !!= nil)
        DisposeIOCompletionUPP(asyncFileCompletionProc);
  
	asyncFileCompletionProc = nil;
	if (state->bufferPtr !!= nil) DisposePtr(state->bufferPtr);
	DisposePtr((void *) f->state);
	f->state = nil;
	f->sessionID = 0;
}

int asyncFileOpen(AsyncFile *f, int fileNamePtr, int fileNameSize, int writeFlag, int semaIndex) {
  /* Opens the given file using the supplied AsyncFile structure to record
	 its state. Fails with no side effects if f is already open. Files are
	 always opened in binary mode. */

	int i;
	Str255 cFileName;
	short int fileRefNum;
	AsyncFileState *state;
	OSErr err;

	/* don''t open an already open file */
	if (asyncFileValid(f)) return success(false);

	/* build complete routine descriptor, if necessary */
	if (asyncFileCompletionProc == nil) {
#if TARGET_API_MAC_CARBON
		asyncFileCompletionProc = NewIOCompletionUPP((pascal void (*) (union ParamBlockRec *) )asyncFileCompletionRoutine);
#else
		asyncFileCompletionProc = NewIOCompletionProc((pascal void (*) (union ParamBlockRec *) )asyncFileCompletionRoutine);
#endif
	}

	/* copy the file name into a null-terminated C string */
	if (fileNameSize > 255) return success(false);
	
	sqFilenameFromString(cFileName, fileNamePtr, fileNameSize);

	if (!!plugInAllowAccessToFilePath((char *) cFileName, fileNameSize)) {
		return success(false);
	}

	CopyCStringToPascal((const char *)cFileName,cFileName);
	f->sessionID = 0;
	if (writeFlag) {
		/* first try to open an existing file read/write: */
		err = HOpenDF(0,0,cFileName, fsRdWrPerm, &fileRefNum); 
		if (err !!= noErr) {
			/* file does not exist; must create it. */
			err = HCreate(0, 0, cFileName,''R*ch'',''TEXT''); 
			if (err !!= noErr) return success(false);
			err = HOpenDF(0,0,cFileName,fsRdWrPerm, &fileRefNum);
			if (err !!= noErr) return success(false);
		}
	} else {
		/* open the file read-only  */
		err = HOpenDF(0,0,cFileName, fsRdPerm, &fileRefNum); 
		if (err !!= noErr) return success(false);
	}
	f->state = (AsyncFileState *) NewPtr(sizeof(AsyncFileState));	/* allocate state record */
	if (f->state == nil) {
		FSClose(fileRefNum);
		return success(false);
	}
	f->sessionID = thisSession;
	state = (AsyncFileState *) f->state;
	state->refNum = fileRefNum;
	state->writable = writeFlag;
	state->semaIndex = semaIndex;
	state->status = IDLE;
	state->bytesTransferred = 0;
	state->bufferSize = 0;
	state->bufferPtr = nil;
}

int asyncFileReadResult(AsyncFile *f, int bufferPtr, int bufferSize) {
  /* Copy up to bufferSize bytes from the buffer of the last read operation
	 into the given Squeak buffer, and return the number of bytes copied.
	 Negative values indicate:
		-1    -- busy; the last operation has not finished yet
		-2    -- error; the last operation failed
	Note that a read operation may read fewer bytes than requested if, for
	example, there are fewer than the requested number of bytes between the
	starting file position of the read operation and the end-of-file. */

	AsyncFileState *state;
	int bytesRead;

	if (!!asyncFileValid(f)) return success(false);
	state = f->state;
	if (state->status == BUSY) return -1;
	if (state->status == LAST_OP_FAILED) return -2;

	/* copy the file buffer into the squeak buffer */
	bytesRead = (bufferSize < state->bytesTransferred) ? bufferSize : state->bytesTransferred;
	memcpy((char *) bufferPtr, state->bufferPtr, bytesRead);
	return bytesRead;
}

int asyncFileReadStart(AsyncFile *f, int fPosition, int count) {
  /* Start an asynchronous operation to read count bytes from the given file
	 starting at the given file position. The file''s semaphore will be signalled when
	 the operation is complete. The client may then use asyncFileReadResult() to
	 find out if the operation succeeded and to get the data that was read. */

	AsyncFileState *state;
	OSErr err;

	if (!!asyncFileValid(f)) return success(false);
	state = f->state;
	if (state->status == BUSY) return success(false);  /* operation in progress */

	/* allocate a new buffer if necessary */
	asyncFileAllocateBuffer(state, count);
	if (state->bufferPtr == nil) return success(false);  /* could not allocate buffer */

	asyncFileInitPB(state, fPosition);
	err = PBReadAsync(&state->pb);
	if (err !!= noErr) {
		state->status = IDLE;
		return success(false);
	}
}

int asyncFileRecordSize() {
	return sizeof(AsyncFile);
}

int asyncFileWriteResult(AsyncFile *f) {
  /* Return the number of bytes copied by the last write operation.
	 Negative values indicate:
		-1    -- busy; the last operation has not finished yet
		-2    -- error; the last operation failed */

	AsyncFileState *state;

	if (!!asyncFileValid(f)) return success(false);
	state = f->state;
	if (state->status == BUSY) return -1;
	if (state->status == LAST_OP_FAILED) return -2;
	return state->bytesTransferred;
}

int asyncFileWriteStart(AsyncFile *f, int fPosition, int bufferPtr, int bufferSize) {
  /* Start an asynchronous operation to write bufferSize bytes to the given file
	 starting at the given file position. The file''s semaphore will be signalled when
	 the operation is complete. The client may then use asyncFileWriteResult() to
	 find out if the operation succeeded and how many bytes were actually written. */

	AsyncFileState *state;
	OSErr err;

	if (!!asyncFileValid(f)) return success(false);
	state = f->state;
	if (state->status == BUSY) return success(false);  /* operation in progress */
	if (!!state->writable) return success(false);

	/* allocate a new buffer if necessary */
	asyncFileAllocateBuffer(state, bufferSize);
	if (state->bufferPtr == nil) return success(false);  /* could not allocate buffer */

	/* copy the squeak buffer into the file buffer */
	memcpy(state->bufferPtr, (char *) bufferPtr, bufferSize);

	asyncFileInitPB(state, fPosition);
	err = PBWriteAsync(&state->pb);
	if (err !!= noErr) {
		state->status = IDLE;
		return success(false);
	}
}
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 11/10/2000 10:37'!
macBrowserPluginFile

	^ '/********** Notes on Browser Plugin VM ************
How it Works:

The browser plugin VM allows Squeak to be run as a plug-in under
version 4.0 and later of either Netscape Navigator or Internet Explorer.
To use it, you must translate a version of interp.c with the browser plugin
hooks. These hooks work by causing the VM to save the state of the current
Squeak process and return control from the interpret() after a short
period of time (e.g., 1/10th second or 1/60th). This allows the browser to process
events and perform other tasks. Eventually, the browser calls NPP_HandleEvent()
with a NULL event, thus re-entering the Squeak interpret loop. The key to
efficiency is to not return control to the browser too often, since the
browser is quite slow to send the next null event. The VM does this
by polling for events itself; if there are no events in the OS queue,
then it return control to the browser much less often.

Note for fullscreen support NPP_HandleEvent does not return control, it consumes 
events from waitnextevent. When fullscreen mode is turn off then control is 
returned to the browser.

Relationship of this file to sqMacWindow.c:

One can think of this file as specializing and extending sqMacWindow.c
for running within a browser. Certain methods in  sqMacWindow.c are
replaced by functions defined here. The originals are removed from
sqMacWindow.c by defining the PLUGIN flag in that file when compiling.
Here is a list of the functions overridden:

	ioExit()
	ioScreenSize()
	ioSetFullScreen()
	sqAllocateMemory()
    plugInAllowAccessToFilePath()

In addition, ioProcessEvents() becomes a noop and main() is completely
omitted when sqMacWindow.c is compiled for use in the browser plugin VM.

 Thing busted 2000 July 26th
 squeak quit restart has issues with change file open
 

June/July 2000 johnmci@smalltalkconsulting.com Reviewed code readded comments, added FullScreen Support
				fixed issues with Carbon, general code cleaning.

Sept 27th 2000 johnmci@smalltalkconsulting.com added logic to have more flexibility in memory size.
				Fix issue with volume ID, don''t use 0
				Fix issue were IE lies about the frame size as it figures out the frame size in real time durning rendering
				Added check for file: in URL logic to disallow
				Fixed problem in NPP_URLNotify, must call notify complete logic
				Ensure NP_memFree is called for plugin arguments
				Add logic for URLPosting
**********/

#include "sq.h"
#include "FilePlugin.h"
#include "npapi.h"

#include <Events.h>
#include <Files.h>
#include <Notification.h>
#include <Strings.h>
#include <MacWindows.h>
#include <Movies.h>
#include <Folders.h>
#include <string.h>
#include <ctype.h>

#if TARGET_API_MAC_CARBON
    #define EnableMenuItemCarbon(m1,v1)  EnableMenuItem(m1,v1);
    #define DisableMenuItemCarbon(m1,v1)  DisableMenuItem(m1,v1);
#else
    #define EnableMenuItemCarbon(m1,v1)  EnableItem(m1,v1);
    #define DisableMenuItemCarbon(m1,v1)  DisableItem(m1,v1);
        inline Rect *GetPortBounds(CGrafPtr w,Rect *r) { *r = w->portRect; return &w->portRect;}  
        inline Rect *GetRegionBounds(RgnHandle region, Rect * bounds) { *bounds = (*region)->rgnBBox; return &(*region)->rgnBBox;}
        inline RgnHandle GetPortClipRegion(CGrafPtr port,RgnHandle clipRgn) {MacCopyRgn (port->clipRgn,clipRgn); return clipRgn;}  
        inline BitMap *GetQDGlobalsScreenBits(BitMap *bm){*bm = qd.screenBits; return &qd.screenBits; }
        inline BitMap * GetPortBitMapForCopyBits (CGrafPtr w) { return &((GrafPtr)w)->portBits;}
        inline pascal long InvalWindowRect(WindowRef  window,  const Rect * bounds) {InvalRect (bounds);}
#endif


/********** Compilation Options:
*
*	ENABLE_URL_FETCH
*	  Define this to compile primitives to fetch URL''s via the browser.
*
*	  Warning: Fetching file URL''s through the URL fetch mechanism allows
*	  potentially untrusted code to read files outside of the Squeak
*	  file system "sandbox", a serious breach of privacy. 
*	  There are few uses for use for the browser URL fetch
*	  mechanism, since you can always fetch URL''s from remote servers
*	  using Squeak''s own HTTPSocket.
*
**********/

#define ENABLE_URL_FETCH  
#define IMAGE_NAME "SqueakPlugin.image"
#define VMPATH_SIZE 300

/*** Exported Primitives ***/

#ifdef ENABLE_URL_FETCH
#pragma export on
int primitivePluginBrowserReady(void);
int primitivePluginDestroyRequest(void);
int primitivePluginRequestFileHandle(void);
int primitivePluginRequestState(void);
int primitivePluginRequestURL(void);
int primitivePluginRequestURLStream(void);
int primitivePluginPostURL(void);
#pragma export off
#endif

/* Constants */

#define MAX_STRING_LENGTH 255
#define MAX_ARG_STRING_LENGTH 100
#define STATUS_BAD_HANDLE -1
#define STATUS_IDLE 0
#define STATUS_IN_PROGRESS 1
#define STATUS_FAILED 2
#define STATUS_SUCCEEDED 3
#define STARTINGsqueakHeapMBytes 20*1024*1024

/*** Imported Variables ***/

extern int interruptKeycode;
extern unsigned char *memory;
extern WindowPtr stWindow;
extern int fullScreenFlag;

extern char documentName[];  /* full path to document file */
extern char imageName[];  /* full path to image file */
extern char shortImageName[];  /* just the image file name */
extern char vmPath[];  /* full path to interpreter''s directory */

extern struct VirtualMachine *interpreterProxy;

extern int thisSession;  /* from sqFilePrims.c: */

/*** Local Variables ***/

int			exitRequested	= false;
Rect    	gSavePortPortRect;
RgnHandle   gSavePortClipRgn;
CGrafPtr	gOldPort		= nil;
int			interpStartTime	= 0;
int			needsUpdate		= false;
NPWindow* 	netscapeWindow	= nil;
Str255		notificationMsg = "";
NMRec		notifyRec;
int			pluginArgCount	= 0;
char		*pluginArgName[MAX_ARG_STRING_LENGTH];
char		*pluginArgValue[MAX_ARG_STRING_LENGTH];
Boolean     ignoreFirstEvent=false;
int			squeakHeapMBytes = STARTINGsqueakHeapMBytes;  /* default heap size, override via the "memory" EMBED tag */
char		squeakPluginImageName[] = IMAGE_NAME;
NPP			thisInstance	= nil;
WindowPtr gAFullscreenWindow = nil;
char        rememberMemoryString[128]="";


#define URL_REQUEST_COUNT 100

typedef struct {
	int id;  /* used to associate a request with its outcome */
	int status;
	int semaIndex;
	char fileName[MAX_STRING_LENGTH + 1];
	char *buffer;
} URLRequestRecord;

URLRequestRecord urlRequests[URL_REQUEST_COUNT];
int nextRequestID = 1;

/*** Functions Imported from sqMacWindow ***/

int recordKeystroke(EventRecord *theEvent);
int recordModifierButtons(EventRecord *theEvent);
int recordMouseDown(EventRecord *theEvent);
void ioSetFullScreenRestore();
int PrefixPathWith(char *pathName, int pathNameSize, int pathNameMax, char *prefix);

/*** From VM ***/
int checkImageVersionFromstartingAt(sqImageFile f, int imageOffset);
int getLongFromFileswap(sqImageFile f, int swapFlag);


/*** Local Functions ***/

int  CaseInsensitiveMatch(char *s1, char *s2);
void EndDraw(void);
void ExitCleanup(void);
int  FindIdleURLRequest(void);
int  InitFilePaths(void);
void InitURLRequestTable(void);
int  IsPrefixedBy(char *s, char *prefix);
void OpenFileReadOnly(SQFile *f, char *fileName);
void ReadSqueakImage(void);
void StartDraw(void);
int  StringToInteger(char *s);
int PathToPreferenceDir(char *pathName, long pathNameMax, long volumeID, long directoryID);
void URLRequestCompleted(int notifyData, const char* fileName);
int  URLRequestCreate(char *url, char *target, int semaIndex);
void URLRequestDestroy(int requestHandle);
void URLRequestFailed(int notifyData, int reason);
char * URLRequestFileName(int requestHandle);
int  URLRequestStatus(int requestHandle);
int parseMemorySize(int baseSize, char *src);
int AbortIfFileURL(char *url);
int URLPostCreate(char *url, char *buffer, char * window,int semaIndex);

/*** Initialize/Shutdown ***/

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_Initialize:
 * Provides global initialization for a plug-in, and returns an error value. 
 *
 * This function is called once when a plug-in is loaded, before the first instance
 * is created. Allocate any memory or resources shared by all
 * instances of your plug-in at this time. After the last instance has been deleted,
 * NPP_Shutdown will be called, where you can release any memory or
 * resources allocated by NPP_Initialize. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
NPError NPP_Initialize(void) {
	exitRequested = false;
	needsUpdate = false;
	netscapeWindow = nil;
	pluginArgCount = 0;
	thisInstance = nil;
	InitURLRequestTable();
	return NPERR_NO_ERROR;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_GetJavaClass:
 * New in Netscape Navigator 3.0. 
 *
 * NPP_GetJavaClass is called during initialization to ask your plugin
 * what its associated Java class is. If you don''t have one, just return
 * NULL. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
jref
NPP_GetJavaClass(void)
{
	return (jref) NULL;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_Shutdown:
 * Provides global deinitialization for a plug-in. 
 * 
 * This function is called once after the last instance of your plug-in is destroyed.
 * Use this function to release any memory or resources shared across all
 * instances of your plug-in. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/

void NPP_Shutdown(void) {
	ExitCleanup();
}

/*** Instance Create/Destroy ***/
/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_New:
 * Creates a new instance of a plug-in and returns an error value. 
 * 
 * NPP_New creates a new instance of your plug-in with MIME type specified
 * by pluginType. The parameter mode is NP_EMBED if the instance was created
 * by an EMBED tag, or NP_FULL if the instance was created by a separate file.
 * You can allocate any instance-specific private data in instance->pdata at this
 * time. The NPP pointer is valid until the instance is destroyed. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/

NPError NPP_New(NPMIMEType pluginType, NPP instance, uint16 mode,
  int16 argc, char* argn[], char* argv[], NPSavedData* saved) {
	int i;

	/* only one Squeak instance can be active at a time */
	if (thisInstance !!= nil) return NPERR_GENERIC_ERROR;

	for (i = 0; i < MAX_ARG_STRING_LENGTH; i++) {
		pluginArgName[i] = pluginArgValue[i] = "";
	}

	/* record plugin arguments */
	pluginArgCount = argc;
	for (i = 0; (i < argc) && (i < MAX_ARG_STRING_LENGTH); i++) {
		pluginArgName[i] = (char *) NPN_MemAlloc(strlen(argn[i]) + 1);
		strcpy(pluginArgName[i], argn[i]);
		pluginArgValue[i] = (char *) NPN_MemAlloc(strlen(argv[i]) + 1);
		strcpy(pluginArgValue[i], argv[i]);
		if (CaseInsensitiveMatch(pluginArgName[i], "memory")) {
			strcpy(rememberMemoryString,pluginArgValue[i]);
		}
	}

	memory = nil;
	ReadSqueakImage();
	if (!!memory) return NPERR_GENERIC_ERROR;

	thisInstance = instance;
	return NPERR_NO_ERROR;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_Destroy:
 * Deletes a specific instance of a plug-in and returns an error value. 

 * NPP_Destroy is called when a plug-in instance is deleted, typically because the
 * user has left the page containing the instance, closed the window, or quit the
 * application. You should delete any private instance-specific information stored
 * in instance->pdata. If the instance being deleted is the last instance created
 * by your plug-in, NPP_Shutdown will subsequently be called, where you can
 * delete any data allocated in NPP_Initialize to be shared by all your plug-in''s
 * instances. Note that you should not perform any graphics operations in
 * NPP_Destroy as the instance''s window is no longer guaranteed to be valid. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
NPError NPP_Destroy(NPP instance, NPSavedData** save) {
	long i;
	
	ExitCleanup();
	if (pluginArgCount !!= 0) {
		for(i=0;i<pluginArgCount;i++) {
			NPN_MemFree(pluginArgName[i]);
			NPN_MemFree(pluginArgValue[i]);
		}
		pluginArgCount = 0;
	}
	return NPERR_NO_ERROR;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_SetWindow:
 * Sets the window in which a plug-in draws, and returns an error value. 
 * 
 * NPP_SetWindow informs the plug-in instance specified by instance of the
 * the window denoted by window in which the instance draws. This NPWindow
 * pointer is valid for the life of the instance, or until NPP_SetWindow is called
 * again with a different value. Subsequent calls to NPP_SetWindow for a given
 * instance typically indicate that the window has been resized. If either window
 * or window->window are NULL, the plug-in must not perform any additional
 * graphics operations on the window and should free any resources associated
 * with the window. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
NPError NPP_SetWindow(NPP instance, NPWindow* window) {
	NP_Port* port;

	if (window == NULL) return NPERR_NO_ERROR;
	if (window->window == NULL) return NPERR_NO_ERROR;
	
	netscapeWindow = window;
	port = (NP_Port *) netscapeWindow->window;
	stWindow = (WindowPtr) port->port;
	needsUpdate	= true;
	return NPERR_NO_ERROR;
}

/*** Streaming ***/

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_NewStream:
 * Notifies an instance of a new data stream and returns an error value. 
 * 
 * NPP_NewStream notifies the instance denoted by instance of the creation of
 * a new stream specifed by stream. The NPStream* pointer is valid until the
 * stream is destroyed. The MIME type of the stream is provided by the
 * parameter type. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
NPError NPP_NewStream(
  NPP instance, NPMIMEType type,
  NPStream *stream, NPBool seekable, uint16 *stype) {
  /* Call to load the initial URL and to handle explicit URL fetch requests. */

	*stype = NP_ASFILEONLY;  /* ask Netscape to cache file and call NPP_StreamAsFile */
	return NPERR_NO_ERROR;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_DestroyStream:
 * Indicates the closure and deletion of a stream, and returns an error value. 
 * 
 * The NPP_DestroyStream function is called when the stream identified by
 * stream for the plug-in instance denoted by instance will be destroyed. You
 * should delete any private data allocated in stream->pdata at this time. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
NPError NPP_DestroyStream(NPP instance, NPStream *stream, NPError reason) {
	return NPERR_NO_ERROR;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_StreamAsFile:
 * Provides a local file name for the data from a stream. 
 * 
 * NPP_StreamAsFile provides the instance with a full path to a local file,
 * identified by fname, for the stream specified by stream. NPP_StreamAsFile is
 * called as a result of the plug-in requesting mode NP_ASFILEONLY or
 * NP_ASFILE in a previous call to NPP_NewStream. If an error occurs while
 * retrieving the data or writing the file, fname may be NULL. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
void NPP_StreamAsFile(NPP instance, NPStream *stream, const char* fname) {
	if (fname !!= null) 
		URLRequestCompleted((int) stream->notifyData, fname);
	 else 
		URLRequestFailed((int) stream->notifyData, 1);
}


/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_WriteReady:
 * Returns the maximum number of bytes that an instance is prepared to accept
 * from the stream. 
 * 
 * NPP_WriteReady determines the maximum number of bytes that the
 * instance will consume from the stream in a subsequent call NPP_Write. This
 * function allows Netscape to only send as much data to the instance as the
 * instance is capable of handling at a time, allowing more efficient use of
 * resources within both Netscape and the plug-in. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
int32 NPP_WriteReady(NPP instance, NPStream *stream) {
  /* not used, because we use ASFILEONLY mode */

	return 100000;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_Write:
 * Delivers data from a stream and returns the number of bytes written. 
 * 
 * NPP_Write is called after a call to NPP_NewStream in which the plug-in
 * requested a normal-mode stream, in which the data in the stream is delivered
 * progressively over a series of calls to NPP_WriteReady and NPP_Write. The
 * function delivers a buffer buf of len bytes of data from the stream identified
 * by stream to the instance. The parameter offset is the logical position of
 * buf from the beginning of the data in the stream. 
 * 
 * The function returns the number of bytes written (consumed by the instance).
 * A negative return value causes an error on the stream, which will
 * subsequently be destroyed via a call to NPP_DestroyStream. 
 * 
 * Note that a plug-in must consume at least as many bytes as it indicated in the
 * preceeding NPP_WriteReady call. All data consumed must be either processed
 * immediately or copied to memory allocated by the plug-in: the buf parameter
 * is not persistent. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
int32 NPP_Write(NPP instance, NPStream *stream, int32 offset, int32 len, void *buffer) {
  /* not used, because we use ASFILEONLY mode */

	return len;
}

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_URLNotify:
 * Notifies the instance of the completion of a URL request. 
 * 
 * NPP_URLNotify is called when Netscape completes a NPN_GetURLNotify or
 * NPN_PostURLNotify request, to inform the plug-in that the request,
 * identified by url, has completed for the reason specified by reason. The most
 * common reason code is NPRES_DONE, indicating simply that the request
 * completed normally. Other possible reason codes are NPRES_USER_BREAK,
 * indicating that the request was halted due to a user action (for example,
 * clicking the "Stop" button), and NPRES_NETWORK_ERR, indicating that the
 * request could not be completed (for example, because the URL could not be
 * found). The complete list of reason codes is found in npapi.h. 
 * 
 * The parameter notifyData is the same plug-in-private value passed as an
 * argument to the corresponding NPN_GetURLNotify or NPN_PostURLNotify
 * call, and can be used by your plug-in to uniquely identify the request. 
 +++++++++++++++++++++++++++++++++++++++++++++++++*/
void NPP_URLNotify(NPP instance, const char* url, NPReason reason, void* notifyData) {
	if (reason !!= NPRES_DONE) 
		URLRequestFailed((int) notifyData, reason);
	else
		URLRequestCompleted((int) notifyData, null);

}

/*** Printing ***/

void NPP_Print(NPP instance, NPPrint* printInfo) {
	/* printing is not supported */
}

/*** Event Handling ***/

/*+++++++++++++++++++++++++++++++++++++++++++++++++
 * NPP_HandleEvent:
 * Mac-only, but stub must be present for Windows
 * Delivers a platform-specific event to the instance. 
 * 
 * On the Macintosh, event is a pointer to a standard Macintosh EventRecord.
 * All standard event types are passed to the instance as appropriate. In general,
 * return TRUE if you handle the event and FALSE if you ignore the event. 
 * Note special logic for full screen support
 +++++++++++++++++++++++++++++++++++++++++++++++++*/

int16 NPP_HandleEvent(NPP instance, void *rawEvent) {
	EventRecord *eventPtr = (EventRecord*) rawEvent;
	EventRecord	theEvent;
	int				ok;

	do {
	
    	if (exitRequested) {
    		exitRequested = false;
    		ExitCleanup();
    		return false;
    	}

    	if ((thisInstance == nil) || (eventPtr == NULL)) {
    		/* no instance or no event; do nothing */
    		return false;
    	}

    	recordModifierButtons(eventPtr);
    	switch (eventPtr->what) {
    		case mouseDown:
    			recordMouseDown(eventPtr);
    		break;

    		case keyDown:
    		case autoKey:
    			recordKeystroke(eventPtr);
    		break;

    		case updateEvt:
    			needsUpdate = true;
    		break;
    		
    		case nullEvent:
    			/* interpret some bytecodes on every event */
    			if (memory) {  /* but only if the VM has memory!! */
    				StartDraw();
    				interpret();
    				EndDraw();
    			}
    		break;
    	}

    	if (needsUpdate && (netscapeWindow !!= nil) && (memory)) {
    		if (fullScreenFlag) {
    		    BeginUpdate((WindowPtr) eventPtr->message);
     		}
    		StartDraw();
    		fullDisplayUpdate();  /* ask VM to call ioShowDisplay */
    		EndDraw();
    		if (fullScreenFlag) {
    		    EndUpdate((WindowPtr) eventPtr->message);
   			}
    		needsUpdate = false;
    	}
    	if (ignoreFirstEvent  &&  fullScreenFlag) {
    	    ignoreFirstEvent = false;
    	    return true;
    	}
    	if (fullScreenFlag) {
     	    ok = WaitNextEvent(everyEvent, &theEvent,0,null);
            eventPtr = &theEvent;
    	}
	} while (fullScreenFlag);
	return true;
}

/*** Drawing ***/

void EndDraw(void) {
	SetOrigin(gSavePortPortRect.left, gSavePortPortRect.top);
	SetClip(gSavePortClipRgn);
	SetPort((GrafPtr) gOldPort);
}

void StartDraw(void) {
	NP_Port* port;
	Rect clipRect;
	

	port = (NP_Port *) netscapeWindow->window;

	/* save old graphics port and switch to ours */
	GetPort((GrafPtr *) &gOldPort);
	SetPort((GrafPtr) port->port);
	stWindow = (WindowPtr) port->port;

	/* save old drawing environment */
	GetPortBounds(port->port,&gSavePortPortRect);
	GetClip(gSavePortClipRgn);

	/* setup our drawing environment */
	SetOrigin(port->portx, port->porty);
	clipRect.top    = netscapeWindow->clipRect.top    + port->porty;
	clipRect.left   = netscapeWindow->clipRect.left   + port->portx;
	clipRect.bottom = netscapeWindow->clipRect.bottom + port->porty;
	clipRect.right  = netscapeWindow->clipRect.right  + port->portx;
	if (clipRect.top == 0 && clipRect.left ==0 && clipRect.bottom==0 && clipRect.right==0) {
		// Not sure what to do IE is lying... this gets the full screen, not a table cell GetPortBounds(GetWindowPort(stWindow),&clipRect);
	}
	ClipRect(&clipRect);
	BackColor(whiteColor);  /* needed to avoid funny colors */
}

/*** Image File Reading ***/

void ReadSqueakImage(void) {
	sqImageFile f;
	char msg[500];
    int swapBytes;
    int dataSize;
    int headerStart;
    int headerSize;
    int heapSize;
    
	plugInInit(squeakPluginImageName);
	InitFilePaths();

	/* read the image file and allocate memory for Squeak heap */
	f = sqImageFileOpen(imageName, "rb");
	if (f == NULL) {
		strcpy(msg, "Could not open Squeak image file \"");
		strcat(msg, imageName);
		strcat(msg, "\"");
		plugInNotifyUser(msg);
		return;
	}
	
	//Cheat and peek ahead to get the image size so we can calculate the memory required 
	
	swapBytes = checkImageVersionFromstartingAt(f, 0);
	headerStart = (sqImageFilePosition(f)) - 4;
	headerSize = getLongFromFileswap(f, swapBytes);
	dataSize = getLongFromFileswap(f, swapBytes);
	
	//Close then reopen to reset file position
	
	sqImageFileClose(f);  
	f = sqImageFileOpen(imageName, "rb");

	squeakHeapMBytes = parseMemorySize(dataSize, rememberMemoryString);
	if (squeakHeapMBytes == 0) 
	    squeakHeapMBytes = STARTINGsqueakHeapMBytes;
	    
	readImageFromFileHeapSizeStartingAt(f, squeakHeapMBytes, 0);
	sqImageFileClose(f);
	interruptKeycode = 515;  /* ctrl-C, since Netscape blocks cmd-. */
	fullScreenFlag=false; //Note image can be saved with true

}

/*** URL Requests ***/

int URLRequestCreate(char *url, char *target, int semaIndex) {
  /* Start a URL request and return its index. Return -1 if there were
     no idle request handles. */

	int handle, notifyData;
	long junk;

	handle = FindIdleURLRequest();
	if (handle < 0) return handle;
	urlRequests[handle].id = nextRequestID++;
	urlRequests[handle].status = STATUS_IN_PROGRESS;
	urlRequests[handle].semaIndex = semaIndex;
	urlRequests[handle].buffer = null;

	/* temporarily return the grafPort to Netscape so it can display feedback: */
	EndDraw();
	notifyData = (urlRequests[handle].id << 8) + handle;
	NPN_GetURLNotify(thisInstance, url, target, (void *) notifyData);

	Delay(120, (unsigned long *) &junk);  /* workaround for a bug in Mac Netscape 4.7--
						  back-to-back requests to a server sometimes fail
						  when the server was heavily loaded Question is this value too long!!*/
	StartDraw();
	return handle;
}

int URLPostCreate(char *url, char *buffer, char * window,int semaIndex) {
  /* Start a URL request and return its index. Return -1 if there were
     no idle request handles. */

	int handle, notifyData;
	long junk;
	NPError error;
	
	handle = FindIdleURLRequest();
	if (handle < 0) return handle;
	urlRequests[handle].id = nextRequestID++;
	urlRequests[handle].status = STATUS_IN_PROGRESS;
	urlRequests[handle].semaIndex = semaIndex;
	urlRequests[handle].buffer = buffer;

	/* temporarily return the grafPort to Netscape so it can display feedback: */
	EndDraw();
	notifyData = (urlRequests[handle].id << 8) + handle;
	error = NPN_PostURLNotify(thisInstance, url, window, strlen(buffer)+1, buffer, false, (void *) notifyData);
	if (error !!= NPERR_NO_ERROR) {
		StartDraw();
		return -1;
	}
	
	Delay(120, (unsigned long *) &junk);  /* workaround for a bug in Mac Netscape 4.7--
						  back-to-back requests to a server sometimes fail
						  when the server was heavily loaded Question is this value too long!!*/
	StartDraw();
	if (window[0] == 0x00) {
		//Bug? unsure, but if window is null, then no notification give so trigger semaphore
		URLRequestCompleted(notifyData,null);
	}	
	return handle;
}

void URLRequestDestroy(int requestHandle) {
  /* Clear the url request with the given handle. */

	if ((requestHandle < 0) || (requestHandle >= URL_REQUEST_COUNT)) {
		return;
	}
	urlRequests[requestHandle].id = 0;
	urlRequests[requestHandle].status = STATUS_IDLE;
	urlRequests[requestHandle].semaIndex = 0;
	urlRequests[requestHandle].fileName[0] = 0;
	urlRequests[requestHandle].buffer = null;
}

char * URLRequestFileName(int requestHandle) {
  /* Return the filename associated with the url request with the given
     handle. Return null if the request status is not STATUS_SUCCEEDED. */

	if ((requestHandle < 0) ||
		(requestHandle >= URL_REQUEST_COUNT) ||
		(urlRequests[requestHandle].status !!= STATUS_SUCCEEDED)) {
			return null;
	}

	return urlRequests[requestHandle].fileName;
}

int URLRequestStatus(int requestHandle) {
  /* Return the status of the url request with the given handle. */

	if ((requestHandle < 0) ||
		(requestHandle >= URL_REQUEST_COUNT) ||
		(urlRequests[requestHandle].status < STATUS_IN_PROGRESS)) {
			return STATUS_BAD_HANDLE;
	}
	return urlRequests[requestHandle].status;
}

int FindIdleURLRequest(void) {
  /* Return the index of an idle request or -1 if there are none. */
	int i;

	for (i = 0; i < URL_REQUEST_COUNT; i++) {
		if (urlRequests[i].status == STATUS_IDLE) {
			return i;
		}
	}
	return -1;
}

void URLRequestCompleted(int notifyData, const char* fileName) {
  /* Record that the given request has completed, caching the result in
     the given file name. */

	int handle = notifyData & 0xFF;

	if ((handle < 0) || (handle >= URL_REQUEST_COUNT)) {
		return;
	}
	if (urlRequests[handle].id == (notifyData >> 8)) {
		if (fileName !!= null) 
		    strncpy(urlRequests[handle].fileName, fileName, MAX_STRING_LENGTH);
		if (urlRequests[handle].buffer !!= null) {
			NPN_MemFree(urlRequests[handle].buffer);
			urlRequests[handle].buffer = null;
		}
		urlRequests[handle].status = STATUS_SUCCEEDED;
		signalSemaphoreWithIndex(urlRequests[handle].semaIndex);
	}
}

void URLRequestFailed(int notifyData, int reason) {
  /* Record that the given URL request failed. */

	int handle = notifyData & 0xFF;

	if ((handle < 0) || (handle >= URL_REQUEST_COUNT)) {
		return;
	}
	if (urlRequests[handle].id == (notifyData >> 8)) {
		if (urlRequests[handle].buffer !!= null) {
			NPN_MemFree(urlRequests[handle].buffer);
			urlRequests[handle].buffer = null;
		}
		/* Note: For local files, we''re informed that there was a network
		   error (but only after NPP_StreamAsFile has reported success).
		   We could allow local files to be read through the URL request
		   mechanism but NOT failing here if the status has already been
		   set to success. But we don''t want to allow the URL mechanism
		   to be used as a loophole to read files outside the sandbox, so
		   we let this fail. */
		if (urlRequests[handle].status !!= STATUS_SUCCEEDED) {
			urlRequests[handle].status = STATUS_FAILED;
			signalSemaphoreWithIndex(urlRequests[handle].semaIndex);
		}
	}
}

void InitURLRequestTable(void) {
  /* Initialize the table of URL requests. */
	int i;

	for (i = 0; i < URL_REQUEST_COUNT; i++) {
		URLRequestDestroy(i);
	}
	nextRequestID = 1;
}

/*** Squeak I/O Support and Memory Allocation ***/

int ioExit(void) {
  /* Request that we stop running plugin. */

	ioSetFullScreenRestore();
	plugInForceTimeToReturn();
	exitRequested = true;
}

int ioScreenSize(void) {
	int w = 0, h = 0;
	Rect bounds;
	
	if (netscapeWindow !!= nil) {
		w = netscapeWindow->clipRect.right - netscapeWindow->clipRect.left;
		h = netscapeWindow->clipRect.bottom - netscapeWindow->clipRect.top;
	}
	    
	if (w == 0 && h == 0) { 
	    GetPortBounds(GetWindowPort(stWindow),&bounds);
		w = bounds.right - bounds.left;
		h = bounds.bottom - bounds.top;
	}
	
	return (w << 16) | (h & 0xFFFF);  /* w is high 16 bits; h is low 16 bits */
}

/* Full Screen logic */

Ptr gRestorableStateForScreen = nil;
NP_Port	  gFullScreenNPPort;
NPWindow  *oldNetscapeWindow,gFullScreenNPWindow;
WindowPtr oldStWindow;

int ioSetFullScreen(int fullScreen) {
	short desiredWidth,desiredHeight;
	
    plugInForceTimeToReturn();
	if (fullScreen) {
	    if (fullScreenFlag) return;
		desiredWidth = 0;
		desiredHeight = 0;
		oldNetscapeWindow = netscapeWindow;
		oldStWindow = stWindow;
		BeginFullScreen	(&gRestorableStateForScreen,nil,
								 &desiredWidth,
								 &desiredHeight,
								 &gAFullscreenWindow,
								 nil,
								 fullScreenAllowEvents);
		fullScreenFlag = true;
		stWindow = gAFullscreenWindow;
		gFullScreenNPPort.port = (CGrafPort *) gAFullscreenWindow;
		gFullScreenNPPort.portx = 0;
		gFullScreenNPPort.porty = 0;
		gFullScreenNPWindow.window =  &gFullScreenNPPort;
		gFullScreenNPWindow.x = 0;
		gFullScreenNPWindow.y = 0;
		gFullScreenNPWindow.width = desiredWidth;
		gFullScreenNPWindow.height = desiredHeight;
		gFullScreenNPWindow.clipRect.top = 0;
		gFullScreenNPWindow.clipRect.left = 0;
		gFullScreenNPWindow.clipRect.bottom = desiredHeight;
		gFullScreenNPWindow.clipRect.right = desiredWidth;
    	
    	netscapeWindow = &gFullScreenNPWindow;
    	ignoreFirstEvent = true;
 	} else {
	    if (!!fullScreenFlag) return;
		fullScreenFlag = false;
        ioSetFullScreenRestore();
	}

}

void ioSetFullScreenRestore()
{
	if (gRestorableStateForScreen !!= nil) {
		EndFullScreen(gRestorableStateForScreen,nil);
	    if (gAFullscreenWindow == nil) 
		    return;
	    gRestorableStateForScreen = nil;
	    netscapeWindow = oldNetscapeWindow;
	    stWindow = oldStWindow;
	}
}

void * sqAllocateMemory(int minHeapSize, int desiredHeapSize) {
  /* Allocate the Squeak object heap memory from the system heap. */

#if TARGET_API_MAC_CARBON
	return NewPtr(desiredHeapSize);
#else
	return NewPtrSys(desiredHeapSize);
#endif
}

/*** File and Access Paths ***/

int InitFilePaths(void) {
	short vRefNum;
	char imageInPreferenceFolder[256];
	long dirID;
	OSErr err;
	FSSpec fileSpec;
	
	/* clear all path and file names */
	imageName[0] = shortImageName[0] = documentName[0] = vmPath[0] = 0;

	strcpy(shortImageName, squeakPluginImageName);

	/* get the path to the sytem folder preference area*/
	err = FindFolder(kOnSystemDisk, kPreferencesFolderType, kDontCreateFolder, &vRefNum, &dirID);
	if (err !!= noErr) {
		strcpy(imageName,"Problems finding System Preference folder");
		return err;
	}
	
	// Look for folder, if not found abort */
	strcpy(imageInPreferenceFolder,":Squeak:Internet:");
	strcat(imageInPreferenceFolder,shortImageName);
	CopyCStringToPascal(imageInPreferenceFolder,(unsigned char *) imageInPreferenceFolder);
	err = FSMakeFSSpec(vRefNum, dirID,(unsigned char *) imageInPreferenceFolder , &fileSpec);
	if (err !!= noErr) {
		strcpy(imageName,"Problems finding Internet folder in Squeak Preference folder and SqueakPlugin.image");
		return err;
	}	
	/* set the vmPath */
	PathToPreferenceDir(vmPath,VMPATH_SIZE,fileSpec.vRefNum,fileSpec.parID);
	strcpy(imageName, vmPath);
	strcat(imageName, shortImageName);
}

int PathToPreferenceDir(char *pathName, long pathNameMax, long volumeID, long directoryID) {
	/* Fill in the given string with the full path from a root volume to
	   to current preference directory.
	*/

	Str255 thisName;
	CInfoPBRec pb;
	int nextDirRefNum, pathLen;

	/* initialize string copying state */
	pathName[0] = 0;
	pathLen = 0;

	/* get refNum of working directory */
	strcpy((char *) thisName, ":");
	CopyCStringToPascal((const char *)thisName,thisName);
	pb.hFileInfo.ioNamePtr = thisName;
	pb.hFileInfo.ioVRefNum = volumeID;
	pb.hFileInfo.ioFDirIndex = 0;
	pb.hFileInfo.ioDirID = directoryID;
	if (PBGetCatInfoSync(&pb) !!= noErr) {
		nextDirRefNum = 0;
	}
	nextDirRefNum = pb.hFileInfo.ioDirID;

	while (true) {
		thisName[0] = 0;
		pb.hFileInfo.ioFDirIndex = -1; /* map ioDirID -> name */
		pb.hFileInfo.ioVRefNum = volumeID;
		pb.hFileInfo.ioDirID = nextDirRefNum;
    	if (PBGetCatInfoSync(&pb) !!= noErr) {
 			break;  /* we''ve reached the root */
		}
    	CopyPascalStringToC((unsigned char *)thisName,(char *) thisName);
		pathLen = PrefixPathWith(pathName, pathLen, pathNameMax,(char *) thisName);
		nextDirRefNum = pb.dirInfo.ioDrParID;
	}
	return pathLen;
}


int IsPrefixedBy(char *s, char *prefix) {
  /* Return true if the given string begins with or equals the given prefix. */
	int i;

	for (i = 0; prefix[i] !!= 0; i++) {
		if (s[i] !!= prefix[i]) 
			return false;
	}
	return true;
}

int plugInAllowAccessToFilePath(char *pathString, int pathStringLength) {
  /* Return true if access to the given file is allowed. */
	int i;
	char path[2000];

	/* copy path into C string */
	if (pathStringLength >= 2000) return false;  /* path too long */
	memcpy(path,pathString,pathStringLength+1);
	path[pathStringLength] = '':'';
	path[pathStringLength+1] = 0;

	/* disallow relative path names that might access a parent folder */
	for (i = 0; i < pathStringLength; i++) {
		if ((path[i] == '':'') && (path[i+1] == '':'')) {
			return false;
		}
	}
	/* check for directory, thus we need to check directory otherwise fallback to default directory */
	for (i = 0; i < pathStringLength; i++)
	    if (path[i] == '':'') return IsPrefixedBy(path, vmPath);
	
    return false;  //Sigh default is where browser is not preference folder
}

/*** Optional URL Fetch Primitives ***/

#ifdef ENABLE_URL_FETCH
int primitivePluginBrowserReady(void) {
	/* Args: none.
	   Always return true on Macintosh. */

	interpreterProxy->pop(1);
	interpreterProxy->pushBool(1);
}

int primitivePluginDestroyRequest(void) {
	/* Args: handle.
	   Destroy the given request. */

	int handle;

	handle = interpreterProxy->stackIntegerValue(0);
	if (interpreterProxy->failed()) {
		return null;
	}
	URLRequestDestroy(handle);
	interpreterProxy->pop(1);
}

int primitivePluginRequestFileHandle(void) {
	/* Args: handle.
	   Return a file handle for the completed request. Fail if
	   the request handle is not valid or hasn''t successfully completed. */

	int handle, fileObj;
	char *fileName;
	SQFile *filePtr;

	handle = interpreterProxy->stackIntegerValue(0);
	if (interpreterProxy->failed()) {
		return null;
	}

	fileName = URLRequestFileName(handle);
	if (fileName == null) {
		interpreterProxy->success(false);
		return null;
	}

	fileObj = interpreterProxy->instantiateClassindexableSize(
		interpreterProxy->classByteArray(), sizeof(SQFile));
	filePtr = (SQFile *) (fileObj + 4);

	/* Note: OpenFileReadOnly() allows any file on the disk to be read via a file URL.
	   However, we are using it for now because we are not sure where the Netscape cache
	   folder will be--it''s folder might even be user-name dependent. sqFileOpen() will
	   only allow opening files within the sandbox, which would be better. Here''s the
	   sandbox-safe alternative:
		  sqFileOpen(filePtr, (int) fileName, strlen(fileName), false);
	*/
	OpenFileReadOnly(filePtr, fileName);

	if (interpreterProxy->failed()) {
		return null;
	}
	interpreterProxy->pop(2);
	interpreterProxy->push(fileObj);
}

int primitivePluginRequestState(void) {
	/* Args: handle.
	   Return true if the request succeeded, false if it failed, and nil if
	   it is still in progress. Fail if the request handle is not valid. */

	int handle;
	int status;
	int resultObj;

	handle = interpreterProxy->stackIntegerValue(0);
	if (interpreterProxy->failed()) {
		return null;
	}

	status = URLRequestStatus(handle);
	if (status == STATUS_BAD_HANDLE) {
		interpreterProxy->success(false);
		return null;
	}

	/* default return object: (nil means "in progress") */
	resultObj = interpreterProxy->nilObject();

	if (status == STATUS_FAILED) {
		resultObj = interpreterProxy->falseObject();
	}
	if (status == STATUS_SUCCEEDED) {
		resultObj = interpreterProxy->trueObject();
	}

	interpreterProxy->pop(2);
	interpreterProxy->push(resultObj);
}

int primitivePluginRequestURL(void) {
	/* Args: url, target, semaphoreIndex.
	   Start a URL request to fetch the given URL to the given target.
	   (See the Netscape Plugin programmer''s manual for possible targets.)
	   Return a handle that can be used to identify this request. Fail if
	   there are already too many outstanding requests. */

	char *urlPtr;
	char *targetPtr;
	int semaIndex;
	int urlObj, urlSize;
	int targetObj, targetSize;
	char url[MAX_STRING_LENGTH + 1];
	char target[MAX_STRING_LENGTH + 1];
	int i;
	int handle;

	semaIndex = interpreterProxy->stackIntegerValue(0);
	targetObj = interpreterProxy->stackObjectValue(1);
	urlObj = interpreterProxy->stackObjectValue(2);
	interpreterProxy->success(interpreterProxy->isBytes(targetObj));
	interpreterProxy->success(interpreterProxy->isBytes(urlObj));
	if (interpreterProxy->failed()) {
		return null;
	}
	urlSize = interpreterProxy->stSizeOf(urlObj);
	urlPtr = interpreterProxy->firstIndexableField(urlObj);
	targetSize = interpreterProxy->stSizeOf(targetObj);
	targetPtr = interpreterProxy->firstIndexableField(targetObj);

	/* copy url into a C string */
	if (urlSize > MAX_STRING_LENGTH) urlSize = MAX_STRING_LENGTH;
	for (i = 0; i < urlSize; i++) {
		url[i] = urlPtr[i];
	}
	url[urlSize] = 0;

	interpreterProxy->success(AbortIfFileURL(url));
	if (interpreterProxy->failed()) {
		return null;
	}
	
	/* copy target into a C string */
	if (targetSize > MAX_STRING_LENGTH) targetSize = MAX_STRING_LENGTH;
	for (i = 0; i < targetSize; i++) {
		target[i] = targetPtr[i];
	}
	target[targetSize] = 0;

	handle = URLRequestCreate(url, target, semaIndex);
	interpreterProxy->success(handle >= 0);

	if (interpreterProxy->failed()) {
		return null;
	}
	interpreterProxy->pop(4);
	interpreterProxy->pushInteger(handle);
}

int primitivePluginPostURL(void) {
	/* Args: url, target, semaphoreIndex.
	   Start a URL request to post the given URL to the given target.
	   (See the Netscape Plugin programmer''s manual for possible targets.)
	   Return a handle that can be used to identify this request. Fail if
	   there are already too many outstanding requests. */

	char *urlPtr;
	char *targetPtr;
	char *bufferPtr,*buffer;
	int semaIndex;
	int urlObj, urlSize;
	int targetObj, targetSize;
	int bufferObj, bufferSize;
	char url[MAX_STRING_LENGTH + 1];
	char target[MAX_STRING_LENGTH + 1];
	int i;
	int handle;

	semaIndex = interpreterProxy->stackIntegerValue(0);
	bufferObj = interpreterProxy->stackObjectValue(1);
	targetObj = interpreterProxy->stackObjectValue(2);
	urlObj = interpreterProxy->stackObjectValue(3);
	
	interpreterProxy->success(interpreterProxy->isBytes(targetObj));
	interpreterProxy->success(interpreterProxy->isBytes(urlObj));
	interpreterProxy->success(interpreterProxy->isBytes(bufferObj));
	if (interpreterProxy->failed()) {
		return null;
	}
	urlSize = interpreterProxy->stSizeOf(urlObj);
	urlPtr = interpreterProxy->firstIndexableField(urlObj);
	targetSize = interpreterProxy->stSizeOf(targetObj);
	targetPtr = interpreterProxy->firstIndexableField(targetObj);
	bufferSize = interpreterProxy->stSizeOf(bufferObj);
	bufferPtr = interpreterProxy->firstIndexableField(bufferObj);

	/* copy url into a C string */
	if (urlSize > MAX_STRING_LENGTH) urlSize = MAX_STRING_LENGTH;
	for (i = 0; i < urlSize; i++) {
		url[i] = urlPtr[i];
	}
	url[urlSize] = 0;

	interpreterProxy->success(AbortIfFileURL(url));
	if (interpreterProxy->failed()) {
		return null;
	}
	
	/* copy target into a C string */
	if (targetSize > MAX_STRING_LENGTH) targetSize = MAX_STRING_LENGTH;
	for (i = 0; i < targetSize; i++) {
		target[i] = targetPtr[i];
	}
	target[targetSize] = 0;

	/* copy over the post buffer which might be large*/
	
	buffer = (char *) NPN_MemAlloc(bufferSize+1);
	for (i = 0; i < bufferSize; i++) {
		buffer[i] = bufferPtr[i];
	}
	buffer[bufferSize] = 0;

	handle = URLPostCreate(url, buffer,target,semaIndex) ;
	interpreterProxy->success(handle >= 0);

	if (interpreterProxy->failed()) {
		return null;
	}
	interpreterProxy->pop(5);
	interpreterProxy->pushInteger(handle);
}

int primitivePluginRequestURLStream(void) {
	/* Args: url, semaphoreIndex.
	   Start a URL request to fetch the given URL. Return a handle that
	   can be used to identify this request. Fail if there are already
	   too many outstanding requests. */

	int urlObj, urlSize, semaIndex;
	char *urlPtr;
	char url[MAX_STRING_LENGTH + 1];
	int handle, i;

	semaIndex = interpreterProxy->stackIntegerValue(0);
	urlObj = interpreterProxy->stackObjectValue(1);
	interpreterProxy->success(interpreterProxy->isBytes(urlObj));
	if (interpreterProxy->failed()) {
		return null;
	}
	urlSize = interpreterProxy->stSizeOf(urlObj);
	urlPtr = interpreterProxy->firstIndexableField(urlObj);

	/* copy url into a C string */
	if (urlSize > MAX_STRING_LENGTH) urlSize = MAX_STRING_LENGTH;
	for (i = 0; i < urlSize; i++) {
		url[i] = urlPtr[i];
	}
	url[urlSize] = 0;

	interpreterProxy->success(AbortIfFileURL(url));
	if (interpreterProxy->failed()) {
		return null;
	}

	handle = URLRequestCreate(url, null, semaIndex);
	interpreterProxy->success(handle >= 0);

	if (interpreterProxy->failed()) {
		return null;
	}
	interpreterProxy->pop(3);
	interpreterProxy->pushInteger(handle);
}


void OpenFileReadOnly(SQFile *f, char *fileName) {
	/* Opens the given file for reading using the supplied sqFile
	   structure. This is a simplified version of sqFileOpen() that
	   avoids the "sandbox" access check, since the browser''s
	   cache folder is outside the Squeak sandbox. That is why
	   we only allow reading of this file. Sets the primitive
	   failure flag if not successful. */

	f->file = fopen(fileName, "rb");
	f->writable = false;

	if (f->file == NULL) {
		f->sessionID = 0;
		f->fileSize = 0;
		interpreterProxy->success(false);
		return;
	} else {
		f->sessionID = thisSession;
		/* compute and cache file size */
		fseek(f->file, 0, SEEK_END);
		f->fileSize = ftell(f->file);
		fseek(f->file, 0, SEEK_SET);
	}
	f->lastOp = 0;
}

#endif

/*** Other ***/

int CaseInsensitiveMatch(char *s1, char *s2) {
  /* Return true if the two strings are the same, not considering case. */
	int len, i, c1, c2;

	len = strlen(s1);
	if (strlen(s2) !!= len) return false;
	for (i = 0; i < len; i++) {
		c1 = s1[i];
		c2 = s2[i];
		if ((c1 >= ''a'') && (c1 <= ''z'')) {
			c1 = c1 - (''a'' - ''A'');
		}
		if ((c2 >= ''a'') && (c2 <= ''z'')) {
			c2 = c2 - (''a'' - ''A'');
		}
		if (c1 !!= c2) return false;
	}
	return true;
}

void ExitCleanup(void) {
  /* Clean up and stop running plugin. */

	if (thisInstance == nil) return;
	thisInstance = nil;
	plugInShutdown();
	ioSetFullScreenRestore();
	NPP_Initialize();  /* reset local variables */
}

int StringToInteger(char *s) {
  /* Answer the integer resulting from converting the given
     string, assumed to be decimal integer. */
	int sign, n, i, ch;

	sign = 1;
	n = 0;
	i = 0;
	while ((ch = s[i++]) !!= 0) {
		if ((ch == ''-'') && (i == 1)) {
			sign = -1;
		} else {
			if ((ch >= ''0'') && (ch <= ''9'')) {
				n = (10 * n) + (ch - ''0'');
			} else {
				return sign * n;
			}
		}
	}
	return sign * n;
}

/*** Interpreter Hooks ***/

void plugInForceTimeToReturn(void) {
  /* Ensure that the next call to pluginTimeToReturn() will return true. */
	interpStartTime = TickCount() - 10000;
}

int plugInNotifyUser(char *msg) {
  /* Notify the user that there was a problem starting Squeak. */

	CopyCStringToPascal(msg,notificationMsg); /* copy message, since notification is asynchronous */

	notifyRec.qType = nmType;
	notifyRec.nmMark = false;			/* no mark in applications menu */
	notifyRec.nmIcon = nil;				/* no menu bar icon */
	notifyRec.nmSound = (Handle) -1;	/* -1 means system beep */
	notifyRec.nmStr = notificationMsg;
	notifyRec.nmResp = (NMUPP) -1;		/* -1 means remove notification when user confirms */

	/* add to notification queue */
	NMInstall(&notifyRec);
}

void plugInSetStartTime(void) {
  /* Set that time at which interpret() was started. */
	interpStartTime = TickCount();
}

int plugInTimeToReturn(void) {
  /* Return true if it is time to return from interpret(). */
    EventRecord evt;
    int delta = TickCount() - interpStartTime;

    if ((delta < 0) || (delta >= 20)) {
        /* let Netscape have control every so often whether or
           not there are pending events */
        return true;
    }
    if ((delta & 0x3) == 0x3) {
        /* check every 4 ticks; if pending events, return to the browser */
        if (OSEventAvail(everyEvent, &evt)) return true;
    }
    return false;
}

int parseMemorySize(int baseSize, char *src)
{
	char buf[50], *tmp;
	int imageSize = 0, requestedSize;

	while(*src) {
		switch(*src) {
			case '' '': /* white spaces; ignore */
			case ''"'':
				src++; break;
			case ''*'': /* multiple of image size */
				tmp = buf; src++;
				while(*src && isdigit(*src)) *(tmp++) = *(src++); /* integer part */
				if(*src == ''.'') { /* fraction part */
					*(tmp++) = *(src++);
					while(*src && isdigit(*src)) *(tmp++) = *(src++);
				}
				*(tmp++) = 0;
				imageSize += (int) (baseSize * atof(buf));
				break;
			case ''+'': /* additional space in bytes */
				tmp = buf; src++;
				while(*src && isdigit(*src)) *(tmp++) = *(src++);
				*(tmp++) = 0;
				if (imageSize == 0) 
					imageSize = baseSize;
				requestedSize = atoi(buf);
				imageSize += (requestedSize <= 1000) ? requestedSize*1024*1024 : requestedSize;
				break;
			default: /* absolute size */
				tmp = buf;
				*(tmp++) = *(src++);
				while(*src && isdigit(*src)) *(tmp++) = *(src++);
				*(tmp++) = 0;
				requestedSize = atoi(buf);
				imageSize = (requestedSize <= 1000) ? requestedSize*1024*1024 : requestedSize;
		}
	}
	return imageSize;
}

int AbortIfFileURL(char *url)
{   char lookFor[6];
	int i=0,placement=0;
	
	lookFor[5] = 0x00;
	while (true) {
		if (*url == 0x00) break;
		if (*url == '' '') {
			url++;
		} else {
		  lookFor[placement++] = *url++;
		  if (placement == 5) break;
		}
	}
	return !!CaseInsensitiveMatch(lookFor,"file:");
}'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 6/7/2000 16:25'!
macDNRFile

	^ '/* 	

	File:		DNR.c 
	
	Contains:	DNR library for MPW

  	Copyright:	© 1989-1995 by Apple Computer, Inc., all rights reserved

	Version:	Technology:			Networking
				Package:			Use with MacTCP 2.0.6 and the Universal
									Interfaces 2.1b1	
		
	Change History (most recent first):
		<3>	 1/23/95	rrk  	implemented use of universal procptrs
		 						Changed selector name HINFO to HXINFO
		 						due to conflict of name in MacTCP header
		 						Removed use of TrapAvailable and exchanged
		 						for the TrapExists call.
								Changed symbol codeHandle to gDNRCodeHndl
								Changed symbol dnr to gDNRCodePtr
	Further modifications by Steve Falkenburg, Apple MacDTS 8/91
	Modifications by Jim Matthews, Dartmouth College, 5/91

	
*/
#include "sq.h"

#ifndef __OSUTILS__
#include <OSUtils.h>
#endif

#ifndef __ERRORS__
#include <Errors.h>
#endif

#ifndef __FILES__
#include <Files.h>
#endif

#ifndef __RESOURCES__
#include <Resources.h>
#endif

#ifndef __MEMORY__
#include <Memory.h>
#endif

#ifndef __TRAPS__
#include <Traps.h>
#endif

#ifndef __GESTALT__
#include <Gestalt.h>
#endif

#ifndef __FOLDERS__
#include <Folders.h>
#endif

#ifndef __TOOLUTILS__
#include <ToolUtils.h>
#endif


#ifndef __MACTCP__
#include "MacTCP.h"
#endif

#ifndef __ADDRESSXLATION__
#include "AddressXlation.h"
#endif

// think C compatibility stuff

#ifndef	_GestaltDispatch
#define	_GestaltDispatch	_Gestalt
#endif


/* RRK Modification 1/95 - commenting out the following defines as they are
	defined in the DNRCalls.h header file
*/

void GetSystemFolder(short *vRefNumP, long *dirIDP);
void GetCPanelFolder(short *vRefNumP, long *dirIDP);
short SearchFolderForDNRP(long targetType, long targetCreator, short vRefNum, long dirID);
short OpenOurRF(void);
short	NumToolboxTraps(void);
TrapType	GetTrapType(short theTrap);
Boolean TrapExists(short theTrap);

static Handle 			gDNRCodeHndl = nil;
static ProcPtr			gDNRCodePtr = nil;

/*	Check the bits of a trap number to determine its type. */

/* InitGraf is always implemented (trap $A86E).  If the trap table is big
** enough, trap $AA6E will always point to either Unimplemented or some other
** trap, but will never be the same as InitGraf.  Thus, you can check the size
** of the trap table by asking if the address of trap $A86E is the same as
** $AA6E. */

#pragma segment UtilMain
short	NumToolboxTraps(void)
{
	if (NGetTrapAddress(_InitGraf, ToolTrap) == NGetTrapAddress(0xAA6E, ToolTrap))
		return(0x200);
	else
		return(0x400);
}

#pragma segment UtilMain
TrapType	GetTrapType(short theTrap)
{
	/* OS traps start with A0, Tool with A8 or AA. */
	if ((theTrap & 0x0800) == 0)					/* per D.A. */
		return(OSTrap);
	else
		return(ToolTrap);
}

Boolean TrapExists(short theTrap)
{
	TrapType	theTrapType;

	theTrapType = GetTrapType(theTrap);
	if ((theTrapType == ToolTrap) && ((theTrap &= 0x07FF) >= NumToolboxTraps()))
		theTrap = _Unimplemented;

	return(NGetTrapAddress(_Unimplemented, ToolTrap) !!= NGetTrapAddress(theTrap, theTrapType));
}

void GetSystemFolder(short *vRefNumP, long *dirIDP)
{
	SysEnvRec info;
	long wdProcID;
	
	SysEnvirons(1, &info);
	if (GetWDInfo(info.sysVRefNum, vRefNumP, dirIDP, &wdProcID) !!= noErr) 
	{
		*vRefNumP = 0;
		*dirIDP = 0;
	}
}

void GetCPanelFolder(short *vRefNumP, long *dirIDP)
{
	Boolean hasFolderMgr = false;
	long feature;
	
	if (TrapExists(_GestaltDispatch)) if (Gestalt(gestaltFindFolderAttr, &feature) == noErr) hasFolderMgr = true;
	if (!!hasFolderMgr) 
	{
		GetSystemFolder(vRefNumP, dirIDP);
		return;
	}
	else 
	{
		if (FindFolder(kOnSystemDisk, kControlPanelFolderType, kDontCreateFolder, vRefNumP, dirIDP) !!= noErr) 
		{
			*vRefNumP = 0;
			*dirIDP = 0;
		}
	}
}
	
/* SearchFolderForDNRP is called to search a folder for files that might 
	contain the ''dnrp'' resource */
short SearchFolderForDNRP(long targetType, long targetCreator, short vRefNum, long dirID)
{
	HParamBlockRec fi;
	Str255 filename;
	short refnum;
	
	fi.fileParam.ioCompletion = nil;
	fi.fileParam.ioNamePtr = filename;
	fi.fileParam.ioVRefNum = vRefNum;
	fi.fileParam.ioDirID = dirID;
	fi.fileParam.ioFDirIndex = 1;
	
	while (PBHGetFInfo(&fi, false) == noErr) 
	{
		/* scan system folder for driver resource files of specific type & creator */
		if (fi.fileParam.ioFlFndrInfo.fdType == targetType &&
			fi.fileParam.ioFlFndrInfo.fdCreator == targetCreator) 
		{
			/* found the MacTCP driver file? */
			refnum = HOpenResFile(vRefNum, dirID, filename, fsRdPerm);
			if (GetIndResource(''dnrp'', 1) == NULL)
				CloseResFile(refnum);
			else
				return refnum;
		}
		/* check next file in system folder */
		fi.fileParam.ioFDirIndex++;
		fi.fileParam.ioDirID = dirID;	/* PBHGetFInfo() clobbers ioDirID */
	}
	return(-1);
}	

/* OpenOurRF is called to open the MacTCP driver resources */

short OpenOurRF(void)
{
	short refnum;
	short vRefNum;
	long dirID;
	
	/* first search Control Panels for MacTCP 1.1 */
	GetCPanelFolder(&vRefNum, &dirID);
	refnum = SearchFolderForDNRP(''cdev'', ''ztcp'', vRefNum, dirID);
	if (refnum !!= -1) return(refnum);
		
	/* next search System Folder for MacTCP 1.0.x */
	GetSystemFolder(&vRefNum, &dirID);
	refnum = SearchFolderForDNRP(''cdev'', ''mtcp'', vRefNum, dirID);
	if (refnum !!= -1) return(refnum);
		
	/* finally, search Control Panels for MacTCP 1.0.x */
	GetCPanelFolder(&vRefNum, &dirID);
	refnum = SearchFolderForDNRP(''cdev'', ''mtcp'', vRefNum, dirID);
	if (refnum !!= -1) return(refnum);
		
	return -1;
}	


OSErr OpenResolver(char *fileName)
{
	short 			refnum;
	OSErr 			rc;
	
	if (gDNRCodePtr !!= nil)
		/* resolver already loaded in */
		return(noErr);
		
	/* open the MacTCP driver to get DNR resources. Search for it based on
	   creator & type rather than simply file name */	
	refnum = OpenOurRF();

	/* ignore failures since the resource may have been installed in the 
	   System file if running on a Mac 512Ke */
	   
	/* load in the DNR resource package */
	gDNRCodeHndl = GetIndResource(''dnrp'', 1);
	if (gDNRCodeHndl == nil)
	{
		/* can''t open DNR */
		return(ResError());
	}
	
	DetachResource(gDNRCodeHndl);
	if (refnum !!= -1) 
	{
		CloseResFile(refnum);
	}
		
	/* lock the DNR resource since it cannot be reloated while opened */
	MoveHHi(gDNRCodeHndl);
	HLock(gDNRCodeHndl);
	
	gDNRCodePtr = (ProcPtr)*gDNRCodeHndl;
	
	/* call open resolver */
	// RRK modification 1/95 use CallOpenResolverProc define to call UPP
	
	rc = CallOpenResolverProc(gDNRCodePtr, OPENRESOLVER, fileName);
	if (rc !!= noErr) 
	{
		/* problem with open resolver, flush it */
		HUnlock(gDNRCodeHndl);
		DisposeHandle(gDNRCodeHndl);
		gDNRCodePtr = nil;
	}
	return(rc);
}


OSErr CloseResolver(void)
{
	
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	/* call close resolver */
	// RRK modification 1/95 use CallCloseResolverProc define to call UPP
	// (void) (*dnr)(CLOSERESOLVER);

	CallCloseResolverProc(gDNRCodePtr, CLOSERESOLVER);
	
	/* release the DNR resource package */
	HUnlock(gDNRCodeHndl);
	DisposeHandle(gDNRCodeHndl);
	gDNRCodePtr = nil;
	return(noErr);
}

	// RRK modification 1/95 declare parameter resultProc to be of type 
	// ResultProcUPP instead of a long
	
OSErr StrToAddr(char *hostName, struct hostInfo *rtnStruct, 
			ResultUPP resultproc, Ptr userDataPtr)
{
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallStrToAddrProc define to call UPP
	// return((*dnr)(STRTOADDR, hostName, rtnStruct, resultproc, userDataPtr));
			
	return (CallStrToAddrProc(gDNRCodePtr, STRTOADDR, hostName, rtnStruct, resultproc, userDataPtr));
}
	
OSErr AddrToStr(unsigned long addr, char *addrStr)
{
	OSErr	err;
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallAddrToStrProc define to call UPP
	// (*dnr)(ADDRTOSTR, addr, addrStr);
	
	err = CallAddrToStrProc(gDNRCodePtr, ADDRTOSTR, addr, addrStr);
	return(noErr);
}
	
OSErr EnumCache(EnumResultUPP resultproc, Ptr userDataPtr)
{

	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallEnumCacheProc define to call UPP
	// return((*dnr)(ENUMCACHE, resultproc, userDataPtr));

	return (CallEnumCacheProc(gDNRCodePtr, ENUMCACHE, resultproc, userDataPtr));
}
	
	
OSErr AddrToName(unsigned long addr, struct hostInfo *rtnStruct, 
			ResultUPP resultproc, Ptr userDataPtr)
{
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallAddrToNameProc define to call UPP
	// return((*dnr)(ADDRTONAME, addr, rtnStruct, resultproc, userDataPtr));

	return(CallAddrToNameProc(gDNRCodePtr, ADDRTONAME, addr, rtnStruct, resultproc, userDataPtr));
}


extern OSErr HInfo(char *hostName, struct returnRec *returnRecPtr, 
			ResultProc2UPP resultProc, Ptr userDataPtr)
{
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallHInfoProc define to call UPP
	// return((*dnr)(HINFO, hostName, returnRecPtr, resultProc, userDataPtr));

	return(CallHInfoProc(gDNRCodePtr, HXINFO, hostName, returnRecPtr, resultProc, userDataPtr));

}
	
extern OSErr MXInfo(char *hostName, struct returnRec *returnRecPtr, 
			ResultProc2UPP resultProc, Ptr userDataPtr)
{
	if (gDNRCodePtr == nil)
		/* resolver not loaded error */
		return(notOpenErr);
		
	// RRK modification 1/95 use CallHInfoProc define to call UPP
	// return((*dnr)(MXINFO, hostName, returnRecPtr, resultProc, userDataPtr));

	return(CallMXInfoProc(gDNRCodePtr, MXINFO, hostName, returnRecPtr, resultProc, userDataPtr));

}	/* removed ; (causes syntax err in Think C 5.0 */
	'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/2/2001 00:56'!
macDirectoryFile

	^ '/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */

#include "sq.h"
#include "FilePlugin.h"

/* End of adjustments for pluginized VM */

#include <Files.h>
#include <Strings.h>

/***
	The interface to the directory primitive is path based.
	That is, the client supplies a Squeak string describing
	the path to the directory on every call. To avoid traversing
	this path on every call, a cache is maintained of the last
	path seen, along with the Mac volume and folder reference
	numbers corresponding to that path.
***/

/*** Constants ***/
#define ENTRY_FOUND     0
#define NO_MORE_ENTRIES 1
#define BAD_PATH        2

#define DELIMITOR '':''
#define MAX_PATH 2000

/*** Variables ***/
char lastPath[MAX_PATH + 1];
int  lastPathValid = false;
int  lastRefNum = 0;
int  lastVolNum = 0;

/*** Functions ***/
int convertToSqueakTime(int macTime);
int equalsLastPath(char *pathString, int pathStringLength);
int lookupPath(char *pathString, int pathStringLength, int *refNumPtr, int *volNumPtr);
int lookupVolume(char *volName, int *refNumPtr);
int recordPath(char *pathString, int pathStringLength, int refNum, int volNum);

int convertToSqueakTime(int macTime) {
	/* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than Mac one */
	return macTime + (3 * 365 * 24 * 60 * 60);
}

int dir_Create(char *pathString, int pathStringLength) {
	/* Create a new directory with the given path. By default, this
	   directory is created in the current directory. Use
	   a full path name such as "MyDisk:Working:New Folder" to
	   create folders elsewhere. */
	Str255 name;
	HParamBlockRec pb;
	int i;

	if (!!plugInAllowAccessToFilePath(pathString, pathStringLength)) {
		return false;
	}

	for (i = 0; i < pathStringLength; i++) {
		name[i] = pathString[i];
	}
	name[i] = 0; /* string terminator */

	CopyCStringToPascal((const char *) name,name);
	pb.fileParam.ioNamePtr = name;
	pb.fileParam.ioVRefNum = 0;
	pb.fileParam.ioDirID = 0;
	return PBDirCreateSync(&pb) == noErr;
}

int dir_Delete(char *pathString, int pathStringLength) {
	/* Delete the existing directory with the given path. */
	int okay, refNum, volNum, i;
	HParamBlockRec pb;
	Str255 name;

	if (!!plugInAllowAccessToFilePath(pathString, pathStringLength)) {
		return false;
	}

	for (i = 0; i < pathStringLength; i++) {
		name[i] = pathString[i];
	}
	name[i] = 0; /* string terminator */

	okay = lookupPath(pathString, pathStringLength, &refNum, &volNum);
	if (!!okay) {
		return false;
	}

	CopyCStringToPascal((const char *) name,name);
	pb.fileParam.ioNamePtr = name;
	pb.fileParam.ioVRefNum = volNum;
	pb.fileParam.ioDirID = refNum;
	return PBHDeleteSync(&pb) == noErr;
}

int dir_Delimitor(void) {
	return DELIMITOR;
}

int dir_Lookup(char *pathString, int pathStringLength, int index,
  /* outputs: */
  char *name, int *nameLength, int *creationDate, int *modificationDate,
  int *isDirectory, int *sizeIfFile) {
	/* Lookup the index-th entry of the directory with the given path, starting
	   at the root of the file system. Set the name, name length, creation date,
	   creation time, directory flag, and file size (if the entry is a file).
	   Return:	0 	if a entry is found at the given index
	   			1	if the directory has fewer than index entries
	   			2	if the given path has bad syntax or does not reach a directory
	*/

	int okay, newRefNum, newVolNum;
	HVolumeParam volumeParams;
	CInfoPBRec dirParams;

	/* default return values */
	*name             = 0;
	*nameLength       = 0;
	*creationDate     = 0;
	*modificationDate = 0;
	*isDirectory      = false;
	*sizeIfFile       = 0;

	if (!!plugInAllowAccessToFilePath(pathString, pathStringLength)) {
		return NO_MORE_ENTRIES;
	}

	if ((pathStringLength == 0)) {
		/* get volume info */
		volumeParams.ioNamePtr = (unsigned char *) name;
		volumeParams.ioVRefNum = 0;
		volumeParams.ioVolIndex = index;
		okay = PBHGetVInfoSync((HParmBlkPtr) &volumeParams) == noErr;
		if (okay) {
			CopyPascalStringToC((ConstStr255Param) name,name);
			*nameLength       = strlen(name);
			*creationDate     = convertToSqueakTime(volumeParams.ioVCrDate);
			*modificationDate = convertToSqueakTime(volumeParams.ioVLsMod);
			*isDirectory      = true;
			*sizeIfFile       = 0;
			return ENTRY_FOUND;
		} else {
			return NO_MORE_ENTRIES;
		}
	} else {
		/* get file or directory info */
		if (!!equalsLastPath(pathString, pathStringLength)) {
			/* lookup and cache the refNum for this path */
			okay = lookupPath(pathString, pathStringLength, &newRefNum, &newVolNum);
			if (okay) {
				recordPath(pathString, pathStringLength, newRefNum, newVolNum);
			} else {
				return BAD_PATH;
			}
		}
		dirParams.hFileInfo.ioNamePtr = (unsigned char *) name;
		dirParams.hFileInfo.ioFVersNum = 0;
		dirParams.hFileInfo.ioFDirIndex = index;
		if (lastRefNum < 0) {
			dirParams.hFileInfo.ioVRefNum = lastRefNum;
			dirParams.hFileInfo.ioDirID = 0;
		} else {
			dirParams.hFileInfo.ioVRefNum = lastVolNum;
			dirParams.hFileInfo.ioDirID = lastRefNum;
		}
		okay = PBGetCatInfoSync(&dirParams) == noErr;
		if (okay) {
			CopyPascalStringToC((ConstStr255Param) name,name);
			*nameLength       = strlen(name);
			*creationDate     = convertToSqueakTime(dirParams.hFileInfo.ioFlCrDat);
			*modificationDate = convertToSqueakTime(dirParams.hFileInfo.ioFlMdDat);
			if ((dirParams.hFileInfo.ioFlAttrib & 16) !!= 0) {
				*isDirectory  = true;
				*sizeIfFile   = 0;
			} else {
				*isDirectory  = false;
				*sizeIfFile   = dirParams.hFileInfo.ioFlLgLen;
			}
			return ENTRY_FOUND;
		} else {
			return NO_MORE_ENTRIES;
		}
	}
}

dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator) {
	/* Set the Macintosh type and creator of the given file. */
	/* Note: On other platforms, this is just a noop. */

	Str255 name;
	FInfo finderInfo;
	int i;

	/* copy file name into a Pascal string */
	if (filenameSize > 255) return false;
	name[0] = filenameSize;
	for (i = 1; i <= filenameSize; i++) {
		name[i] = filename[i - 1];
	}

	if (HGetFInfo(0,0,name,  &finderInfo) !!= noErr) return false;
	finderInfo.fdType = *((int *) fType);
	finderInfo.fdCreator = *((int *) fCreator);
	if (HSetFInfo(0,0,name,  &finderInfo) !!= noErr) return false;
	return true;
}

dir_GetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator) {
	/* Get the Macintosh type and creator of the given file. */
	/* Note: On other platforms, this is just a noop. */

	Str255 name;
	FInfo finderInfo;
	int i;

	/* copy file name into a Pascal string */
	if (filenameSize > 255) return false;
	name[0] = filenameSize;
	for (i = 1; i <= filenameSize; i++) {
		name[i] = filename[i - 1];
	}

	if (HGetFInfo(0,0,name,  &finderInfo) !!= noErr) return false;
	*((int *) fType) = finderInfo.fdType;
	*((int *) fCreator) = finderInfo.fdCreator;

	return true;
}


int equalsLastPath(char *pathString, int pathStringLength) {
	/* Return true if the lastPath cache is valid and the
	   given Squeak string equals it. */

	int i, ch;

	if (!!lastPathValid ||
		(pathStringLength > MAX_PATH)) {
			return false;
	}

	for (i = 0; i < pathStringLength; i++) {
		ch = lastPath[i];
		if ((ch == 0) || (ch !!= pathString[i])) return false;
	}
	return lastPath[i] == 0;
}


/*
Note:
The previous version of lookupPath checks each folder in the path
hierarchy.  Given a parent folder id of 0, the Carbon version wants
to look in the default directory rather than the root level.  So, rather
than fix it up, I chose to rewrite the function, first looking for the
volume, then the directory (they are the system calls offered anyway).

The function only needs to return false for failure otherwise the volume
and folder id numbers - not details of a full examination of the path.

Karl Goiser 14/01/01
*/

int lookupPath(char *pathString, int pathStringLength, int *refNumPtr, int *volNumPtr) {
	/* Resolve the given path and return the resulting folder or volume
	   reference number in *refNumPtr. Return false if the path is bad. */


	Str255		tempName;
	CInfoPBRec	pb;
	OSErr		err;
    FSSpec		volumeSpec;
    long        i;

	// Set up for failure...
		*refNumPtr = 0;
		*volNumPtr = 0;


// --------------
// Find the volume reference number:

	/* copy file name into a Pascal string */
	if (pathStringLength > 255) return false;
	
	tempName[0] = pathStringLength;
	for (i = 1; i <= pathStringLength; i++)
		tempName[i] = pathString[i - 1];


	err = FSMakeFSSpec (0, 0, tempName, &volumeSpec);
	if (err == -43) {
	    err = lookupVolume(pathString, refNumPtr);
	    return err;
	}
	
	if (err !!= noErr) {
	    return false;
	}


// --------------
// Find the directory id:

	pb.hFileInfo.ioFDirIndex = 0;
	pb.hFileInfo.ioNamePtr = tempName;
	pb.hFileInfo.ioVRefNum = 0;
	pb.hFileInfo.ioDirID = 0;
	pb.hFileInfo.ioACUser = 0; /* ioACUser used to be filler2 */
	pb.hFileInfo.ioCompletion = nil;
	pb.hFileInfo.ioFVersNum = 0;

	err = PBGetCatInfoSync(&pb);
	if (err !!= noErr) return false;

	*refNumPtr = pb.hFileInfo.ioDirID;
	*volNumPtr = volumeSpec.vRefNum;

	return true;
}


int lookupVolume(char *volName, int *refNumPtr) {
	/* Look up the volume with the given name and set *refNumPtr
	   to the reference number of the resulting volume.
	   Return true if this succeeds. */

	int okay;
	HVolumeParam volumeParams;
	Str255 tempVolName;

	CopyCStringToPascal((const char *)volName,tempVolName);
	volumeParams.ioNamePtr = (StringPtr) tempVolName;
	volumeParams.ioVRefNum = 0;
	volumeParams.ioVolIndex = -1;
	okay = PBHGetVInfoSync((HParmBlkPtr) &volumeParams) == noErr;

	if (okay) {
		*refNumPtr = volumeParams.ioVRefNum;
		return true;
	}
	return false;
}

int recordPath(char *pathString, int pathStringLength, int refNum, int volNum) {
	/* Copy the given Squeak string into the lastPath cache. */

	int i;

	if (pathStringLength > MAX_PATH) {
		lastPath[0] = 0; /* set to empty string */
		lastPathValid = false;
		lastRefNum = 0;
		lastVolNum = 0;
		return;
	}
	for (i = 0; i < pathStringLength; i++) {
		lastPath[i] = pathString[i];
	}
	lastPath[i] = 0; /* string terminator */
	lastPathValid = true;
	lastRefNum = refNum;
	lastVolNum = volNum;
}

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:41'!
macDragDropFile
	^ '/*  Jan 24th 2001
	Drag and drop support for Squeak 
	John M McIntosh of Corporate Smalltalk Consulting Ltd
	johnmci@smalltalkconsulting.com 
	http://www.smalltalkconsulting.com 
	In Jan of 2001 under contract to Disney
	
	Dragging is only for objects into Squeak, not from Squeak outwards.
		
    V1.0 Jan 24th 2001, JMM


Some of this code comes from
	Author:		John Montbriand
				Some techniques borrowed from Pete Gontier''s original FinderDragPro.


	Copyright: 	Copyright: © 1999 by Apple Computer, Inc.
				all rights reserved.
	
	Disclaimer:	You may incorporate this sample code into your applications without
				restriction, though the sample code has been provided "AS IS" and the
				responsibility for its operation is 100% yours.  However, what you are
				not permitted to do is to redistribute the source as "DSC Sample Code"
				after having made changes. If you''re going to re-distribute the source,
				we require that you make it clear in the source that the code was
				descended from Apple Sample Code, but that you''ve made changes.
	
	Change History (most recent first):
	9/9/99 by John Montbriand
	
*/
/*
    need get filetype/creator
    need DropPlugin_shutdownModule & dropShutdown
    
*/

#include "sq.h"

#include <drag.h>
#include <macwindows.h>
#include <gestalt.h>
#include <quickdraw.h>


#include "sqVirtualMachine.h"
#include "FilePlugin.h"

#include "DropPlugin.h"

#if TARGET_API_MAC_CARBON
#else
    inline Rect *GetPortBounds(CGrafPtr w,Rect *r) { *r = w->portRect; return &w->portRect;}  
#endif

	/* promise flavor types */
	
enum {
	kPromisedFlavor = ''fssP'',		/* default promise */
	kPromisedFlavorFindFile = ''rWm1'' /* Find File promise -- special case */
};


 Boolean gHasDragManager = false;                    /* true if the Drag Manager is installed */
 Boolean gCanTranslucentDrag = false;                /* true if translucent dragging is available */
 DragReceiveHandlerUPP gMainReceiveHandler = NULL;   /* receive handler for the main dialog */
 DragTrackingHandlerUPP gMainTrackingHandler = NULL; /* tracking handler for the main dialog */
 WindowPtr   gWindowPtr;

 UInt16 gNumDropFiles=0;
 HFSFlavor *dropFiles;

#define DOCUMENT_NAME_SIZE 300
char tempName[DOCUMENT_NAME_SIZE + 1];  

	/* these routines are used both in the receive handler and inside of the
		tracking handler.  The following variables are shared between MyDragTrackingHandler
		and MyDragReceiveHandler.  */
		
 Boolean gApprovedDrag = false;   /* set to true if the drag is approved */
 Boolean gInIconBox = false;      /* set true if the drag is inside our drop box */


extern struct VirtualMachine *interpreterProxy;
extern WindowPtr getSTWindow(void);
 pascal OSErr MyDragTrackingHandler(DragTrackingMessage message, WindowPtr theWindow, void *refCon, DragReference theDragRef);
 pascal OSErr MyDragReceiveHandler(WindowPtr theWindow, void *refcon, DragReference theDragRef);

extern int (*instantiateClassindexableSize)(int classPointer, int size);
extern int classByteArray(void);
extern int fileRecordSize(void);
extern int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag);
extern SQFile * fileValueOf(int objectPointer);
extern int recordDragDropEvent(EventRecord *theEvent, int theButtonState, int numberOfItems, int dragType);
extern int MouseModifierState(EventRecord *theEvent);
extern void StoreFullPathForLocalNameInto(char *shortName, char *fullName, int length, short VolumeNumber,long directoryID);

// Startup logic

int dropInit(void)
{
    long response;
    long fn;
    Boolean  installedReceiver=false, installedTracker=false;
    OSErr err;
    
    /* check for the drag manager & translucent feature??? */
    
	if (gMainReceiveHandler !!= NULL) return 1;
	
	if (Gestalt(gestaltDragMgrAttr, &response) !!= noErr) return 0;
	
	gHasDragManager = (((1 << gestaltDragMgrPresent)) !!= 0);
	gCanTranslucentDrag = (((1 << gestaltDragMgrHasImageSupport)) !!= 0);

    if (!!(gHasDragManager && gCanTranslucentDrag)) return 0;
	
	gWindowPtr = getSTWindow();

	gMainTrackingHandler = NewDragTrackingHandlerUPP(MyDragTrackingHandler);
	if (gMainTrackingHandler == NULL) return 0;
	gMainReceiveHandler = NewDragReceiveHandlerUPP(MyDragReceiveHandler);
	if (gMainReceiveHandler == NULL) return 0;

		/* install the drag handlers, don''t forget to dispose of them later */
		
	err = InstallTrackingHandler(gMainTrackingHandler, gWindowPtr, NULL);
	if (err !!= noErr) { 
	    err = memFullErr; 
	    goto bail; 
    }
	installedTracker = true;
	err = InstallReceiveHandler(gMainReceiveHandler, gWindowPtr, NULL);
	
	if (err !!= noErr) { 
	    err = memFullErr; 
	    goto bail; 
	}
	installedReceiver = true;
	return 1;
	
bail: 
    if (installedReceiver)
		RemoveReceiveHandler(gMainReceiveHandler, gWindowPtr);
	if (installedTracker)
		RemoveTrackingHandler(gMainTrackingHandler, gWindowPtr);
	
	gMainTrackingHandler = NULL; 
    gMainReceiveHandler = NULL;
    
	return 0;
}	

// Shutdown logic

int dropShutdown() {
    if (gMainReceiveHandler !!= NULL)
		RemoveReceiveHandler(gMainReceiveHandler, gWindowPtr);
	if (gMainTrackingHandler !!= NULL)
		RemoveTrackingHandler(gMainTrackingHandler, gWindowPtr);
	if (gNumDropFiles !!= 0 ) {
	    DisposePtr((char *) dropFiles);
	    gNumDropFiles = 0;
	}
	
	gMainTrackingHandler = NULL; 
    gMainReceiveHandler = NULL;

}

//Primitive to get file name

char *dropRequestFileName(int dropIndex) {
    char	shortName[256];
  
    if(dropIndex < 1 || dropIndex > gNumDropFiles) 
        return NULL;
    CopyPascalStringToC(dropFiles[dropIndex-1].fileSpec.name,shortName);
    StoreFullPathForLocalNameInto(shortName, 
        tempName, 
        DOCUMENT_NAME_SIZE,
        dropFiles[dropIndex-1].fileSpec.vRefNum,
        dropFiles[dropIndex-1].fileSpec.parID);
  return tempName;
}

//Primitive to get file stream handle.

int dropRequestFileHandle(int dropIndex) {
    int fileHandle;
    int   size,classPointer;
    char *dropName = dropRequestFileName(dropIndex);
    
    if(!!dropName)
        return interpreterProxy->nilObject();

    size = fileRecordSize();
    classPointer = interpreterProxy->classByteArray();
    fileHandle = interpreterProxy->instantiateClassindexableSize(classPointer, size);
    sqFileOpen(fileValueOf(fileHandle),(int)dropName, strlen(dropName), 0);
    
  return fileHandle;
}


/* RECEIVING DRAGS ------------------------------------------------ */


/* ApproveDragReference is called by the drag tracking handler to determine
	if the contents of the drag can be handled by our receive handler.

	Note that if a flavor can''t be found, it''s not really an
	error; it only means the flavor wasn''t there and we should
	not accept the drag. Therefore, we translate ''badDragFlavorErr''
	into a ''false'' value for ''*approved''. */
	
static pascal OSErr ApproveDragReference(DragReference theDragRef, Boolean *approved) {

	OSErr err;
	DragAttributes dragAttrs;
	FlavorFlags flavorFlags;
	ItemReference theItem;
		
		/* we cannot drag to our own window */
	if ((err = GetDragAttributes(theDragRef, &dragAttrs)) !!= noErr) 
	    goto bail;
	    
	if ((dragAttrs & kDragInsideSenderWindow) !!= 0) { 
	    err = userCanceledErr; 
	    goto bail; 
    }
	
		/* gather information about the drag & a reference to item one. */
	if ((err = GetDragItemReferenceNumber(theDragRef, 1, &theItem)) !!= noErr) 
	    goto bail;
		
		/* check for flavorTypeHFS */
	err = GetFlavorFlags(theDragRef, theItem, flavorTypeHFS, &flavorFlags);
	if (err == noErr) {
		*approved = true;
		return noErr;
	} else if (err !!= badDragFlavorErr)
		goto bail;
		
		/* check for flavorTypePromiseHFS */
	err = GetFlavorFlags(theDragRef, theItem, flavorTypePromiseHFS, &flavorFlags);
	if (err == noErr) {
		*approved = true;
		return noErr;
	} else if (err !!= badDragFlavorErr)
		goto bail;
		
		/* none of our flavors were found */
	*approved = false;
	return noErr;
	
bail:
		/* an error occured, clean up.  set result to false. */
	*approved = false;
	return err;
}



/* MyDragTrackingHandler is called for tracking the mouse while a drag is passing over our
	window.  if the drag is approved, then the drop box will be hilitied appropriately
	as the mouse passes over it.  */
	
static pascal OSErr MyDragTrackingHandler(DragTrackingMessage message, WindowPtr theWindow, void *refCon, DragReference theDragRef) {
		/* we''re drawing into the image well if we hilite... */
    Rect  bounds;
	EventRecord		theEvent;

	switch (message) {
	
		case kDragTrackingEnterWindow:
			{	
				Point mouse;
				
				gApprovedDrag = false;
				if (theWindow == gWindowPtr) {
					if (ApproveDragReference(theDragRef, &gApprovedDrag) !!= noErr) break;
					if ( !! gApprovedDrag ) break;
					SetPortWindowPort(theWindow);
					GetMouse(&mouse);
					GetPortBounds(GetWindowPort(gWindowPtr),&bounds);
					if (PtInRect(mouse, &bounds)) {  // if we''re in the box, hilite... 
						gInIconBox = true;					
                    	    /* queue up an event */
                        WaitNextEvent(0, &theEvent,0,null);
                    	recordDragDropEvent(&theEvent, MouseModifierState(&theEvent),gNumDropFiles,DragEnter);
					} 
				}
			}
			break;

		case kDragTrackingInWindow:
			if (gApprovedDrag) {
                WaitNextEvent(0, &theEvent,0,null);
            	recordDragDropEvent(&theEvent, MouseModifierState(&theEvent),gNumDropFiles,DragMove);
			}
			break;

		case kDragTrackingLeaveWindow:
			if (gApprovedDrag && gInIconBox) {
            	    /* queue up an event */
                WaitNextEvent(0, &theEvent,0,null);
            	recordDragDropEvent(&theEvent, MouseModifierState(&theEvent),gNumDropFiles,DragLeave);
			}
			gApprovedDrag = gInIconBox = false;
			break;
	}
	return noErr; // there''s no point in confusing Drag Manager or its caller
}


/* MyDragReceiveHandler is the receive handler for the main window.  It is called
	when a file or folder (or a promised file or folder) is dropped into the drop
	box in the main window.  Here, if the drag reference has been approved in the
	track drag call, we handle three different cases:
	
	1. standard hfs flavors,
	
	2. promised flavors provided by find file, mmmm This may be a pre sherlock issue
	
	3. promised flavors provided by other applications.
	
     */
     
static pascal OSErr MyDragReceiveHandler(WindowPtr theWindow, void *refcon, DragReference theDragRef) {

	ItemReference   theItem;
	PromiseHFSFlavor targetPromise;
	Size            theSize;
	OSErr           err;
	EventRecord		theEvent;
	long            i,countActualItems;
	FInfo 			finderInfo;
	HFSFlavor		targetHFSFlavor;
	
		/* validate the drag.  Recall the receive handler will only be called after
		the tracking handler has received a kDragTrackingInWindow event.  As a result,
		the gApprovedDrag and gInIconBox will be defined when we arrive here.  Hence,
		there is no need to spend extra time validating the drag at this point. */
		
	if ( !! (gApprovedDrag && gInIconBox) )  
	    return userCanceledErr; 

	if (gNumDropFiles !!=0 ) 
	    DisposePtr((char *) dropFiles);
	    
	if ((err = CountDragItems(theDragRef, &gNumDropFiles)) !!= noErr) 
	    return paramErr;
	
	dropFiles = (HFSFlavor *) NewPtr(sizeof(HFSFlavor)*gNumDropFiles);
	
	if (dropFiles == null) 
	    return userCanceledErr;
	
    WaitNextEvent(0, &theEvent,0,null);
    countActualItems = 0;
    		
    for(i=1;i<=gNumDropFiles;i++) {
		/* get the first item reference */
    	if ((err = GetDragItemReferenceNumber(theDragRef, i, &theItem)) !!= noErr) 
    	    continue;

    		/* try to get a  HFSFlavor*/
    	theSize = sizeof(HFSFlavor);
    	err = GetFlavorData(theDragRef, theItem, flavorTypeHFS, &targetHFSFlavor, &theSize, 0);
    	if (err == noErr) {
    		if (dropFiles[countActualItems].fileCreator == ''MACS'' && (
    				dropFiles[countActualItems].fileType == ''fold'' ||
    				dropFiles[countActualItems].fileType == ''disk'')) 
    				continue;
    		dropFiles[countActualItems] = targetHFSFlavor;
    		countActualItems++;
    		continue;
    	} else if (err !!= badDragFlavorErr) 
    	        continue; 
    	
    		/* try to get a  promised HFSFlavor*/
    	theSize = sizeof(PromiseHFSFlavor);
    	err = GetFlavorData(theDragRef, theItem, flavorTypePromiseHFS, &targetPromise, &theSize, 0);
    	if (err !!= noErr) 
    		continue;
    	
    		/* check for a drop from find file */
    	if (targetPromise.promisedFlavor == kPromisedFlavorFindFile) {
    	
    			/* from find file, no need to set the file location... */
    		theSize = sizeof(FSSpec);
    		err = GetFlavorData(theDragRef, theItem, targetPromise.promisedFlavor, &dropFiles[countActualItems].fileSpec, &theSize, 0);
    		if (err !!= noErr) 
    			continue;
    		HGetFInfo(dropFiles[countActualItems].fileSpec.vRefNum,dropFiles[countActualItems].fileSpec.parID,dropFiles[countActualItems].fileSpec.name,  &finderInfo);
	    		/* queue up an event */
	        dropFiles[countActualItems].fileType = finderInfo.fdType;
	        dropFiles[countActualItems].fileCreator = finderInfo.fdCreator;
	        dropFiles[countActualItems].fdFlags =  finderInfo.fdFlags;
    		countActualItems++;
    	} else {
    		err = badDragFlavorErr;
    		return err;
    	}
    }
    
	gNumDropFiles = countActualItems;
    if (gNumDropFiles == 0) {
    	DisposePtr((char *) dropFiles);
    	return noErr;
    }
	
	    /* queue up an event */

	recordDragDropEvent(&theEvent, MouseModifierState(&theEvent),gNumDropFiles,DragDrop);
	return noErr;
}

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 8/3/2000 15:03'!
macJoystickAndTabletFile

	^ '/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */

#include "sq.h"
#include "JoystickTabletPlugin.h"

/* initialize/shutdown */
int joystickShutdown() {}

/* End of adjustments for pluginized VM */

#include <DeskBus.h>
#include <Devices.h>
#include <Timer.h>

/* Joystick Record */

#define MOUSESTICK_SIGNATURE 0x4A656666
#define MAX_STICKS 4

typedef struct {
	short			rawX;				/* absolute stick position */
	short			rawY;
	unsigned char	buttons;
	char			private1;
	short			cursorX;			/* cursor position */
	short			cursorY;
	char			oldStickType;
	char			private2;
	char			stickOn;			/* true if stick is connected */
	char			private3;
	char			stickControlsCursor;
	char			applicationAware;	/* settings change with application changes */
	char			private4[152];
} MouseStickRec;

typedef struct {
	long			signature;
	char			private1[18];
	short			stickCount;
	char			private2[22];
	MouseStickRec	stick[MAX_STICKS];
} MouseStickSetRec, *MouseStickSetPtr;

/* Tablet Record (see  Apple Tech. Note 266, version 2) */

#define MAX_TRANSDUCERS 4

typedef struct {
    char	DOFTrans;			/* degrees of freedom and transducer type */
    char	orientFlag;			/* type of orientation information */
    short	pressLevels;		/* pressure support and number of levels */
    unsigned short xScale;		/* x scale factor for screen mapping */
    short	xTrans;				/* x translation factor for screen */
    unsigned short yScale;		/* y scale factor for screen mapping */
    short	yTrans;				/* y translation factor for screen */
    unsigned char flags;		/* proximity, update flag, and # buttons */
    unsigned char pressThresh;	/* pressure threshold - normally unused */
    short	buttonMask;			/* button mask of driver-reserved buttons */
    short	errorFlag;			/* error code generated */
    short	buttons;			/* buttons pressed */
    short	tangPress;			/* tangential pressure level */
    short	pressure;			/* normal pressure level */
    long	timeStamp;			/* ticks at latest update */
    long	xCoord;				/* x coordinate in resolution units */
    long	yCoord;				/* y coordinate in resolution units */
    long	zCoord;				/* z coordinate in resolution units */
    short	xTilt;				/* x tilt */
    short	yTilt;				/* y tilt */
    short	unused[8];			/* remainder of unused attitude matrix */
} TransducerRec, *TransducerRecPtr;

typedef struct {
    char	version;			/* version of this data format */
    char	semaphore;			/* for future use -- tells if drvr is enabled */
    char	cursors;			/* number of cursors with tablet */
    char	updateFlags;		/* flags used when updating structure */
    short	angleRes;			/* metric bit & angular resolution */
    short	spaceRes;			/* spatial resolution of the tablet */
    long	xDimension;			/* x dimension in resolution units */
    long	yDimension;			/* y dimension in resolution units */
    long	zDimension;			/* z dimension in resolution units */
    long	xDisplace;			/* x displacement - minimum x value */
    long	yDisplace;			/* y displacement - minimum y value */
    long	zDisplace;			/* z displacement - minimum z value */
    long	reserved;			/* reserved */
    long	tabletID;			/* contains ''TBLT'' identifying the device */
	TransducerRec transducer[MAX_TRANSDUCERS];
} TabletRec, *TabletRecPtr;

/*** Variables ***/

MouseStickSetPtr joySticks = nil;	/* pointer to a joystick set or nil */
TabletRecPtr tablet = nil;  		/* pointer to a tablet record or nil */

int joystickInit(void) {
	/* If a joystick is plugged in and its control panel is installed,
	   initialize the global pointer ''joySticks'' to the joystick set
	   data structure. Otherwise, set it to nil.
	*/
#if TARGET_API_MAC_CARBON
	joySticks = nil;  /* set to nil in case we don''t find any joysticks */
	return false;
#else
	ADBDataBlock adbGetInfo;
	MouseStickSetPtr sticks;
	int count, i;

	joySticks = nil;  /* set to nil in case we don''t find any joysticks */

	count = CountADBs();
	for (i = 1; i <= count; i++) {
		GetADBInfo(&adbGetInfo, GetIndADB(&adbGetInfo, i));
		sticks = (MouseStickSetPtr) adbGetInfo.dbDataAreaAddr;
		if ((sticks !!= nil) && (sticks->signature == MOUSESTICK_SIGNATURE)) {
			joySticks = sticks;
			return true;
		}
	}
	return true;
#endif
}

int joystickRead(int stickIndex) {
	/* Return input word for the joystick with the given index (in range [1..2]
	   on the Macintosh; other platforms may vary). This word is encoded as follows:

		<onFlag (1 bit)><buttonFlags (5 bits)><x-value (11 bits)><y-value (11 bits)>

	   The highest four bits of the input word are zero. If the onFlag bit is zero,
	   there is no joystick at the given index. This may be because no joystick
	   is connected or the joystick control panel is not installed. In such,
	   cases, the entire word will be zero. A maximum of two joysticks are supported
	   by Gravis''s current version of the control panel. The x and y values are
	   11-bit signed values in the range [-1024..1023] representing the raw (unencoded)
	   joystick position. The MouseStick II only uses the approximate range [-650..650].
	   The range and center values of poorly adjusted joysticks may vary; the client
	   software should provide a way to adjust the center and scaling to correct.
	*/

	MouseStickRec stickData;
	int buttons, xBits, yBits;

	if ((joySticks == nil) || (stickIndex < 1) || (stickIndex > 2) ||
		(stickIndex > joySticks->stickCount)) {
			return 0;  /* no joystick at the given index */
	}
	stickData = joySticks->stick[stickIndex - 1];  /* 1-based index */
	buttons = ~stickData.buttons & 0x1F;
	xBits = (0x400 + stickData.rawX) & 0x7FF;
	yBits = (0x400 + stickData.rawY) & 0x7FF;
	return (1 << 27) | (buttons << 22) | (yBits << 11) | xBits;
}

int tabletInit(void);
int tabletInit(void) {
	/* Open the tablet driver and initialize the global pointer to its status
	   record. Return true if a tablet exists, false otherwise. */

#if TARGET_API_MAC_CARBON
    return false;
#else
	CntrlParam	pb;
	short		driverRefNum;

	if (OpenDriver("\p.Wacom", &driverRefNum) !!= noErr) {
		return false;
	}

	pb.ioCRefNum = driverRefNum;
	pb.csCode = 20;  /* requests the address of the current tablet record */
	if (PBStatusSync((ParmBlkPtr) (&pb)) !!= noErr) {
		return false;
	}

	tablet = *((TabletRecPtr *) &pb.csParam);
	return tablet->tabletID == 0x54424c54;  /* verify that id is ''TBLT'' */
#endif 
}

int tabletGetParameters(int cursorIndex, int result[]) {
	/* Fill in the integer array ''result'' with tablet parameter information.
	   For cursor-specific parameters, such as the number of pressure levels,
	   return the information for the cursor with the given index, an integer
	   between 1 and tablet->cursors. */

	TransducerRecPtr cursorPtr;
	int cursor;

	/* open tablet if necessary; return false if no tablet */
	if (tablet == nil) {
		if (!!tabletInit()) return false;
	}

	cursor = cursorIndex - 1;
	if ((cursor < 0)  || (cursor >= tablet->cursors)) {
		return false;
	}
	cursorPtr = &tablet->transducer[cursor];

	result[0] = tablet->xDimension;
	result[1] = tablet->yDimension;
	result[2] = tablet->spaceRes;
	result[3] = tablet->cursors;  /* number of cursors */

	result[4] = cursor + 1;
	result[5] = cursorPtr->xScale;
	result[6] = cursorPtr->xTrans;
	result[7] = cursorPtr->yScale;
	result[8] = cursorPtr->yTrans;
	result[9] = cursorPtr->pressLevels;
	result[10] = cursorPtr->pressThresh;

	if (tablet->angleRes == 0) {
		result[11] = 0;  /* no pen tilt support */
	} else {
		result[11] = tablet->angleRes >> 1;  /* number of pen tilt levels */
	}

	return true;
}

int tabletRead(int cursorIndex, int result[]) {
	/* Fill in the integer array ''result'' with the current data
	   the cursor with the given index, an integer between 1 and
	   tablet->cursors. Note that the timestamp changes only
	   when some new data has arrived from the tablet. */

	TransducerRecPtr cursorPtr;
	int cursor;

	/* open tablet if necessary; return false if no tablet */
	if (tablet == nil) {
		if (!!tabletInit()) return false;
	}

	cursor = cursorIndex - 1;
	if ((cursor < 0)  || (cursor >= tablet->cursors)) {
		return false;
	}
	cursorPtr = &tablet->transducer[cursor];

	result[0] = cursor + 1;
	result[1] = cursorPtr->timeStamp;
	result[2] = cursorPtr->xCoord;
	result[3] = cursorPtr->yCoord;
	result[4] = cursorPtr->zCoord;
	result[5] = cursorPtr->xTilt;
	result[6] = cursorPtr->yTilt;
	result[7] = (cursorPtr->DOFTrans & 0x30) >> 4;  /* cursor type; 1-pen, 2-puck, 3-eraser */
	result[8] = cursorPtr->buttons;
	result[9] = cursorPtr->pressure;
	result[10] = cursorPtr->tangPress;
	result[11] = cursorPtr->flags;
	return true;
}

int tabletResultSize(void) {
	/* Return the size of the integer array required to hold the results of
	   either a tabletGetParameters() or tabletRead() call. The VM allocates
	   an array of this length and passes it as a parameter to be filled in. */

	return 12;
}
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 5/25/2000 18:33'!
macMinimal

	^ '/* sqMacMinimal.c

	This file includes the minimal support code to build a Squeak virtual machine for
	the Mac. Most primitives are "stubbed-out", meaning that if they are invoked from
	the image they will return a "primitive failed" error. Among the stubbed out
	primitives are those that support sound input and output, serial and MIDI ports,
	networking, ,file directory operations, etc. The basic file read/write operations
	are NOT stubbed out, although they could be as long as the image loading mechanism
	still works.

	The purpose of this file is to provide an implementation roadmap when bootstrapping
	Squeak on a new platform. Once all the non-stubbed-out functions in this file have
	been ported, you will have a working, usable Squeak virtual machine!!

*** Implementation Notes ***

  I/O Functions
	The following are essential for display and user interaction:
		ioScreenSize()
		ioShowDisplay()
		ioGetButtonState()
		ioGetKeystroke()
		ioMousePoint()
		ioPeekKeystroke()

	The following can be made no-ops:
		ioProcessEvents() 	-- poll for input events on some platforms
		ioSetCursor()		-- install a 16x16 black and white hardware cursor
		ioSetCursorWithMask() -- install a masked black and white hardware cursor
		ioBeep()			-- sound a short beep through the speaker
		ioExit()			-- exit the VM: quit the application, reboot, power down, or
							-- similar behavior appropriate to this platform (if this
							-- is a noop you simply won''t be able to quit from Squeak)

  File Naming

	The virtual machine keeps track of the full path name of the Squeak image
	file and the path to the directory containing the virtual machine. In this
	minimal implementation, the VM path is the empty string and the image name is
	hardwired to "squeak.image". It is assumed that the image file, the changes
	file, the Squeak application, and the system sources file are all in the
	the same directory, and that this directory is the default working directory
	for any file operations.

  Time Functions

		ioMSecs(), ioMicroMSecs()
							-- both return a millisecond clock value, but historically
							-- ioMicroMSecs() used a higher resolution timer; the
							-- ideal implementation is an inexpensive clock with 1
							-- millisecond accuracy, but both functions can use a
							-- clock with much coarser accuracy (e.g., 50-100 mSecs)
							-- if necessary
		ioSeconds()			-- returns the number of seconds since Jan 1, 1901.
	   						-- optional: may be implemented to always return 0, but then
	   						-- the current date and time will be wrong

*** Linking ***

	To build a Macintosh VM using this file, link together:

		interp.c		-- automatically generated interpreter file
		sqMiscPrims.c	-- automatically generated primitives
		sqMacMinimal.c	-- this file

	plus the appropriate C libraries (e.g. math, strings, standard I/O).
	
	The interpreter code depends on the following functions from libraries:

	    math: exp(), log(), atan(), sin(), sqrt(), ldexp(), frexp(), modf()
	    standard i/o: getchar(), putchar(), printf()
	    other: memcpy(), strlen(), clock()

	The standard i/o functions could be stubbed out; they are only used to report
	fatal VM errors.
*/

#include <Devices.h>
#include <Fonts.h>
#include <Strings.h>
#include <Timer.h>
#include <ToolUtils.h>

#include "sq.h"
#include "FilePlugin.h"

/*** Mac Toolbox Function that is Missing from Standard Header Files ***/
void ExitToShell(void);

/*** Stub Definitions ***/
#define STUBBED_OUT { success(false); }
#define DO_NOTHING { }

/*** Enumerations ***/
enum { appleID = 1, fileID };
enum { quitItem = 1 };

/*** Variables -- Imported from Virtual Machine ***/
extern int interruptCheckCounter;
extern int interruptKeycode;
extern int interruptPending;  /* set to true by RecordKeystroke if interrupt key is pressed */

/*** Variables -- image and path names ***/
#define IMAGE_NAME_SIZE 300
char imageName[IMAGE_NAME_SIZE + 1];  /* full path to image */

#define SHORTIMAGE_NAME_SIZE 100
char shortImageName[SHORTIMAGE_NAME_SIZE + 1];  /* just the image file name */

#define VMPATH_SIZE 300
char vmPath[VMPATH_SIZE + 1];  /* full path to interpreter''s directory */

/*** Variables -- Mac Related ***/
MenuHandle		appleMenu = nil;
MenuHandle		fileMenu = nil;
CTabHandle		stColorTable = nil;
PixMapHandle	stPixMap = nil;
WindowPtr		stWindow = nil;

/*** Variables -- Event Recording ***/
#define KEYBUF_SIZE 64
int keyBuf[KEYBUF_SIZE];	/* circular buffer */
int keyBufGet = 0;			/* index of next item of keyBuf to read */
int keyBufPut = 0;			/* index of next item of keyBuf to write */
int keyBufOverflows = 0;	/* number of characters dropped */

int buttonState = 0;		/* mouse button and modifier state when mouse
							   button went down or 0 if not pressed */

/* This table maps the 5 Macintosh modifier key bits to 4 Squeak modifier
   bits. (The Mac shift and caps lock keys are both mapped to the single
   Squeak shift bit).
		Mac bits: <control><option><caps lock><shift><command>
		ST bits:  <command><option><control><shift>
*/
char modifierMap[32] = {
	0,  8, 1,  9, 1,  9, 1,  9, 4, 12, 5, 13, 5, 13, 5, 13,
	2, 10, 3, 11, 3, 11, 3, 11, 6, 14, 7, 15, 7, 15, 7, 15
};

/*** Functions ***/
char * GetAttributeString(int id);
int  HandleEvents(void);
void HandleMenu(int mSelect);
void HandleMouseDown(EventRecord *theEvent);
void InitMacintosh(void);
int RecordKeystroke(EventRecord *theEvent);
int RecordModifierButtons(EventRecord *theEvent);
int RecordMouseDown(EventRecord *theEvent);
void SetColorEntry(int index, int red, int green, int blue);
void SetUpMenus(void);
void SetUpPixmap(void);
void SetUpWindow(void);

/*** Mac-specific Functions (these would be replaced on another platform) ***/

int HandleEvents(void) {
	EventRecord		theEvent;
	int				ok;

	SystemTask();
	ok = GetNextEvent(everyEvent, &theEvent);
	if (ok) {
		switch (theEvent.what) {
			case mouseDown:
				HandleMouseDown(&theEvent);
				return false;
			break;

			case mouseUp:
				RecordModifierButtons(&theEvent);
				return false;
			break;

			case keyDown:
			case autoKey:
				RecordModifierButtons(&theEvent);
				RecordKeystroke(&theEvent);
			break;

			case updateEvt:
				BeginUpdate(stWindow);
				fullDisplayUpdate();  /* this makes VM call ioShowDisplay */
				EndUpdate(stWindow);
			break;

			case activateEvt:
				InvalRect(&stWindow->portRect);
			break;
		}
	}
	return ok;
}

void HandleMenu(int mSelect) {
	if ((HiWord(mSelect) == fileID) &&
		(LoWord(mSelect) == quitItem)) {
		ioExit();
	}
}

void HandleMouseDown(EventRecord *theEvent) {
	WindowPtr	theWindow;
	Rect		growLimits = { 20, 20, 4000, 4000 };
	Rect		dragBounds;
	int			windowCode, newSize;

	windowCode = FindWindow(theEvent->where, &theWindow);
	switch (windowCode) {
		case inSysWindow:
			SystemClick(theEvent, theWindow);
		break;

		case inMenuBar:
			HandleMenu(MenuSelect(theEvent->where));
		break;

		case inDrag:
			dragBounds = qd.screenBits.bounds;
			if (theWindow == stWindow) {
				DragWindow(stWindow, theEvent->where, &dragBounds);
			}
		break;

		case inGrow:
			if (theWindow == stWindow) {
				newSize = GrowWindow(stWindow, theEvent->where, &growLimits);
				if (newSize !!= 0) {
					SizeWindow(stWindow, LoWord(newSize), HiWord(newSize), true);
				}
			}
		break;

		case inContent:
			if (theWindow == stWindow) {
				if (theWindow !!= FrontWindow()) {
					SelectWindow(stWindow);
				}
				RecordMouseDown(theEvent);
			}
		break;
	}
}

void InitMacintosh(void) {
	MaxApplZone();
	InitGraf(&qd.thePort);
	InitFonts();
	FlushEvents(everyEvent, 0);
	InitWindows();
	InitMenus();
	TEInit();
	InitDialogs(NULL);
	InitCursor();
	SetUpMenus();
	SetUpWindow();
	SetUpPixmap();
}

void SetUpMenus(void) {
	InsertMenu(appleMenu = NewMenu(appleID, "\p\024"), 0);
	InsertMenu(fileMenu  = NewMenu(fileID,  "\pFile"), 0);
	DrawMenuBar();
	AppendResMenu(appleMenu, ''DRVR'');
	AppendMenu(fileMenu, "\pQuit");
}

void SetColorEntry(int index, int red, int green, int blue) {
	(*stColorTable)->ctTable[index].value = index;
	(*stColorTable)->ctTable[index].rgb.red = red;
	(*stColorTable)->ctTable[index].rgb.green = green;
	(*stColorTable)->ctTable[index].rgb.blue = blue;
}

void SetUpPixmap(void) {
	int i, r, g, b;

	stColorTable = (CTabHandle) NewHandle(sizeof(ColorTable) + (256 * sizeof(ColorSpec)));
	(*stColorTable)->ctSeed = GetCTSeed();
	(*stColorTable)->ctFlags = 0;
	(*stColorTable)->ctSize = 255;

	/* 1-bit colors (monochrome) */
	SetColorEntry(0, 65535, 65535, 65535);	/* white or transparent */
	SetColorEntry(1,     0,     0,     0);	/* black */

	/* additional colors for 2-bit color */
	SetColorEntry(2, 65535, 65535, 65535);	/* opaque white */
	SetColorEntry(3, 32768, 32768, 32768);	/* 1/2 gray */

	/* additional colors for 4-bit color */
	SetColorEntry( 4, 65535,     0,     0);	/* red */
	SetColorEntry( 5,     0, 65535,     0);	/* green */
	SetColorEntry( 6,     0,     0, 65535);	/* blue */
	SetColorEntry( 7,     0, 65535, 65535);	/* cyan */
	SetColorEntry( 8, 65535, 65535,     0);	/* yellow */
	SetColorEntry( 9, 65535,     0, 65535);	/* magenta */
	SetColorEntry(10,  8192,  8192,  8192);	/* 1/8 gray */
	SetColorEntry(11, 16384, 16384, 16384);	/* 2/8 gray */
	SetColorEntry(12, 24576, 24576, 24576);	/* 3/8 gray */
	SetColorEntry(13, 40959, 40959, 40959);	/* 5/8 gray */
	SetColorEntry(14, 49151, 49151, 49151);	/* 6/8 gray */
	SetColorEntry(15, 57343, 57343, 57343);	/* 7/8 gray */

	/* additional colors for 8-bit color */
	/* 24 more shades of gray (does not repeat 1/8th increments) */
	SetColorEntry(16,  2048,  2048,  2048);	/*  1/32 gray */
	SetColorEntry(17,  4096,  4096,  4096);	/*  2/32 gray */
	SetColorEntry(18,  6144,  6144,  6144);	/*  3/32 gray */
	SetColorEntry(19, 10240, 10240, 10240);	/*  5/32 gray */
	SetColorEntry(20, 12288, 12288, 12288);	/*  6/32 gray */
	SetColorEntry(21, 14336, 14336, 14336);	/*  7/32 gray */
	SetColorEntry(22, 18432, 18432, 18432);	/*  9/32 gray */
	SetColorEntry(23, 20480, 20480, 20480);	/* 10/32 gray */
	SetColorEntry(24, 22528, 22528, 22528);	/* 11/32 gray */
	SetColorEntry(25, 26624, 26624, 26624);	/* 13/32 gray */
	SetColorEntry(26, 28672, 28672, 28672);	/* 14/32 gray */
	SetColorEntry(27, 30720, 30720, 30720);	/* 15/32 gray */
	SetColorEntry(28, 34815, 34815, 34815);	/* 17/32 gray */
	SetColorEntry(29, 36863, 36863, 36863);	/* 18/32 gray */
	SetColorEntry(30, 38911, 38911, 38911);	/* 19/32 gray */
	SetColorEntry(31, 43007, 43007, 43007);	/* 21/32 gray */
	SetColorEntry(32, 45055, 45055, 45055);	/* 22/32 gray */
	SetColorEntry(33, 47103, 47103, 47103);	/* 23/32 gray */
	SetColorEntry(34, 51199, 51199, 51199);	/* 25/32 gray */
	SetColorEntry(35, 53247, 53247, 53247);	/* 26/32 gray */
	SetColorEntry(36, 55295, 55295, 55295);	/* 27/32 gray */
	SetColorEntry(37, 59391, 59391, 59391);	/* 29/32 gray */
	SetColorEntry(38, 61439, 61439, 61439);	/* 30/32 gray */
	SetColorEntry(39, 63487, 63487, 63487);	/* 31/32 gray */

	/* The remainder of color table defines a color cube with six steps
	   for each primary color. Note that the corners of this cube repeat
	   previous colors, but simplifies the mapping between RGB colors and
	   color map indices. This color cube spans indices 40 through 255.
	*/
	for (r = 0; r < 6; r++) {
		for (g = 0; g < 6; g++) {
			for (b = 0; b < 6; b++) {
				i = 40 + ((36 * r) + (6 * b) + g);
				if (i > 255) error("index out of range in color table compuation");
				SetColorEntry(i, (r * 65535) / 5, (g * 65535) / 5, (b * 65535) / 5);
			}
		}
	}

	stPixMap = NewPixMap();
	(*stPixMap)->pixelType = 0; /* chunky */
	(*stPixMap)->cmpCount = 1;
	(*stPixMap)->pmTable = stColorTable;
}

void SetUpWindow(void) {
	Rect windowBounds = {44, 8, 460, 640};

	stWindow = NewCWindow(
		0L, &windowBounds, "\p Squeak!! ",
		true, documentProc, (WindowPtr) -1L, true, 0);
}

/*** Event Recording Functions ***/

int RecordKeystroke(EventRecord *theEvent) {
	/* record a keystroke in the keyboard buffer. */
	int keystate;

	/* keystate: low byte is the ascii character; next 4 bits are modifier bits */
	keystate =
		(modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 8) |
		(theEvent->message & 0xFF);
	if (keystate == interruptKeycode) {
		/* Note: interrupt key is "meta"; it not reported as a keystroke */
		interruptPending = true;
		interruptCheckCounter = 0;
	} else {
		keyBuf[keyBufPut] = keystate;
		keyBufPut = (keyBufPut + 1) % KEYBUF_SIZE;
		if (keyBufGet == keyBufPut) {
			/* buffer overflow; drop the last character */
			keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;
			keyBufOverflows++;
		}
	}
}

int RecordMouseDown(EventRecord *theEvent) {
	/* record that the mouse button has been pressed. */
	int stButtons;

	stButtons = 4;		/* red button by default */
	if ((theEvent->modifiers & optionKey) !!= 0) {
		stButtons = 2;	/* yellow button if option down */
	}
	if ((theEvent->modifiers & cmdKey) !!= 0) {
		stButtons = 1;	/* blue button if command down */
	}
	/* button state: low three bits are mouse buttons; next 4 bits are modifier bits */
	buttonState =
		(modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |
		(stButtons & 0x7);
}

int RecordModifierButtons(EventRecord *theEvent) {
	/* record the state of the mouse buttons and modifier keys. */
	int stButtons = 0;

	if (Button()) {
		stButtons = buttonState & 0x7;
	} else {
		stButtons = 0;
	}
	/* button state: low three bits are mouse buttons; next 4 bits are modifier bits */
	buttonState =
		(modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |
		(stButtons & 0x7);
}

/*** I/O Primitives ***/

int ioBeep(void) {
	/* optional; could be noop. play a beep through the speaker. */
	SysBeep(1000);
}

int ioExit(void) {
	/* optional; could be noop. exit from the Squeak application. */
	ExitToShell();
}

int ioForceDisplayUpdate(void) {
	/* does nothing on a Mac */
}

int ioGetButtonState(void) {
	/* return the state of the mouse and modifier buttons */
	ioProcessEvents();  /* process all pending events */
	return buttonState;
}

int ioGetKeystroke(void) {
	/* return the next keystroke from the buffer or -1 if the buffer is empty */
	int keystate;

	ioProcessEvents();  /* process all pending events */
	if (keyBufGet == keyBufPut) {
		return -1;  /* keystroke buffer is empty */
	} else {
		keystate = keyBuf[keyBufGet];
		keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;
		/* set modifer bits in buttonState to reflect the last keystroke fetched */
		buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);
	}
	return keystate;
}

int ioMicroMSecs(void) {
	/* millisecond clock based on microsecond timer (about 60 times slower than clock()!!!!) */
	/* Note: This function and ioMSecs() both return a time in milliseconds. The difference
	   is that ioMicroMSecs() is called only when precise millisecond resolution is essential,
	   and thus it can use a more expensive timer than ioMSecs, which is called frequently.
	   However, later VM optimizations reduced the frequency of calls to ioMSecs to the point
	   where clock performance became less critical, and we also started to want millisecond-
	   resolution timers for real time applications such as music. Thus, on the Mac, we''ve
	   opted to use the microsecond clock for both ioMSecs() and ioMicroMSecs(). */
	UnsignedWide microTicks;

	Microseconds(&microTicks);
	return (microTicks.lo / 1000) + (microTicks.hi * 4294967);
}

int ioMSecs(void) {
	/* return a time in milliseconds for use in Delays and Time millisecondClockValue */
	/* Note: This was once a macro based on clock(); it now uses the microsecond clock for
	   greater resolution. See the comment in ioMicroMSecs(). */
	UnsignedWide microTicks;

	Microseconds(&microTicks);
	return (microTicks.lo / 1000) + (microTicks.hi * 4294967);
}

int ioMousePoint(void) {
	/* return the mouse point two 16-bit positive integers packed into a 32-bit integer */
	Point p;

	ioProcessEvents();  /* process all pending events */
	GetMouse(&p);
	return (p.h << 16) | (p.v & 0xFFFF);  /* x is high 16 bits; y is low 16 bits */
}

int ioPeekKeystroke(void) {
	/* return the next keystroke from the buffer or -1 if the buffer is empty; leave
	   the keystrok in the buffer. */
	int keystate;

	ioProcessEvents();  /* process all pending events */
	if (keyBufGet == keyBufPut) {
		return -1;  /* keystroke buffer is empty */
	} else {
		keystate = keyBuf[keyBufGet];
		/* set modifer bits in buttonState to reflect the last keystroke peeked at */
		buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);
	}
	return keystate;
}

int ioProcessEvents(void) {
	/* process Macintosh events, checking for the interrupt key. Return
	   true if the interrupt key was pressed. This might simply do nothing
	   on some other platform.*/
	int maxPollsPerSec = 30;
	static clock_t nextPollTick = 0;

	if (clock() > nextPollTick) {
		/* time to process events!! */
		while (HandleEvents()) {
			/* process all pending events */
		}

		/* wait a while before trying again */
		nextPollTick = clock() + (CLOCKS_PER_SEC / maxPollsPerSec);
	}
	return interruptPending;
}

int ioScreenSize(void) {
	/* return the screen size as two positive 16-bit integers packed into a 32-bit integer */
	int w = 10, h = 10;

	if (stWindow !!= nil) {
		w = stWindow->portRect.right - stWindow->portRect.left;
		h = stWindow->portRect.bottom - stWindow->portRect.top;
	}
	return (w << 16) | (h & 0xFFFF);  /* w is high 16 bits; h is low 16 bits */
}

int ioSeconds(void) {
	/* return the time in seconds since midnight of Jan 1, 1901.  */
	/* optional: could simply return 0.  */

	struct tm timeRec;
	time_t time1904, timeNow;

	/* start of ANSI epoch is midnight of Jan 1, 1904 */
	timeRec.tm_sec   = 0;
	timeRec.tm_min   = 0;
	timeRec.tm_hour  = 0;
	timeRec.tm_mday  = 1;
	timeRec.tm_mon   = 0;
	timeRec.tm_year  = 4;
	timeRec.tm_wday  = 0;
	timeRec.tm_yday  = 0;
	timeRec.tm_isdst = 0;
	time1904 = mktime(&timeRec);

	timeNow = time(NULL);

	/* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than ANSI one */
	return (timeNow - time1904) + (3 * 365 * 24 * 60 * 60);
}

int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY) {
	/* old version; just call the new version. */
	ioSetCursorWithMask(cursorBitsIndex, nil, offsetX, offsetY);
}

int ioSetCursorWithMask(int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY) {
	/* Optional primitive; this could be defined to do nothing. */
	/* Set the 16x16 cursor bitmap. If cursorMaskIndex is nil, then make the mask the same as
	   the cursor bitmap. If not, then mask and cursor bits combined determine how cursor is
	   displayed:
			mask	cursor	effect
			 0		  0		transparent (underlying pixel shows through)
			 1		  1		opaque black
			 1		  0		opaque white
			 0		  1		invert the underlying pixel
	*/
	Cursor macCursor;
	int i;

	if (cursorMaskIndex == nil) {
		for (i = 0; i < 16; i++) {
			macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
			macCursor.mask[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
		}
	} else {
		for (i = 0; i < 16; i++) {
			macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
			macCursor.mask[i] = (checkedLongAt(cursorMaskIndex + (4 * i)) >> 16) & 0xFFFF;
		}
	}

	/* Squeak hotspot offsets are negative; Mac''s are positive */
	macCursor.hotSpot.h = -offsetX;
	macCursor.hotSpot.v = -offsetY;
	SetCursor(&macCursor);
}

int ioShowDisplay(
	/* copy the given rectangular display region to the hardware display buffer. */
	int dispBitsIndex, int width, int height, int depth,
	int affectedL, int affectedR, int affectedT, int affectedB) {

	Rect		dstRect = { 0, 0, 0, 0 };
	Rect		srcRect = { 0, 0, 0, 0 };
	RgnHandle	maskRect = nil;

	if (stWindow == nil) {
		return;
	}

	dstRect.left	= 0;
	dstRect.top		= 0;
	dstRect.right	= width;
	dstRect.bottom	= height;

	srcRect.left	= 0;
	srcRect.top		= 0;
	srcRect.right	= width;
	srcRect.bottom	= height;

	(*stPixMap)->baseAddr = (void *) dispBitsIndex;
	/* Note: top three bits of rowBytes indicate this is a PixMap, not a BitMap */
	(*stPixMap)->rowBytes = (((((width * depth) + 31) / 32) * 4) & 0x1FFF) | 0x8000;
	(*stPixMap)->bounds = srcRect;
	(*stPixMap)->pixelSize = depth;
	(*stPixMap)->cmpSize = depth;

	/* create a mask region so that only the affected rectangle is copied */
	maskRect = NewRgn();
	SetRectRgn(maskRect, affectedL, affectedT, affectedR, affectedB);

	SetPort(stWindow);
	CopyBits((BitMap *) *stPixMap, &stWindow->portBits, &srcRect, &dstRect, srcCopy, maskRect);
	DisposeRgn(maskRect);
}

/*** VM Home Directory Path ***/

int vmPathSize(void) {
	/* return the length of the path string for the directory containing the VM. */
	return strlen(vmPath);
}

int vmPathGetLength(int sqVMPathIndex, int length) {
	/* copy the path string for the directory containing the VM into the given Squeak string. */
	char *stVMPath = (char *) sqVMPathIndex;
	int count, i;

	count = strlen(vmPath);
	count = (length < count) ? length : count;

	/* copy the file name into the Squeak string */
	for (i = 0; i < count; i++) {
		stVMPath[i] = vmPath[i];
	}
	return count;
}

/*** Image File Name ***/

int imageNameSize(void) {
	/* return the length of the Squeak image name. */
	return strlen(imageName);
}

int imageNameGetLength(int sqImageNameIndex, int length) {
	/* copy the Squeak image name into the given Squeak string. */
	char *sqImageName = (char *) sqImageNameIndex;
	int count, i;

	count = strlen(imageName);
	count = (length < count) ? length : count;

	/* copy the file name into the Squeak string */
	for (i = 0; i < count; i++) {
		sqImageName[i] = imageName[i];
	}
	return count;
}

int imageNamePutLength(int sqImageNameIndex, int length) {
	/* copy from the given Squeak string into the imageName variable. */
	char *sqImageName = (char *) sqImageNameIndex;
	int count, i, ch, j;
	int lastColonIndex = -1;

	count = (IMAGE_NAME_SIZE < length) ? IMAGE_NAME_SIZE : length;

	/* copy the file name into a null-terminated C string */
	for (i = 0; i < count; i++) {
		ch = imageName[i] = sqImageName[i];
		if (ch == '':'') {
			lastColonIndex = i;
		}
	}
	imageName[count] = 0;

	/* copy short image name into a null-terminated C string */
	for (i = lastColonIndex + 1, j = 0; i < count; i++, j++) {
		shortImageName[j] = imageName[i];
	}
	shortImageName[j] = 0;

	return count;
}

/*** Clipboard Support ***/

int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex) {
	/* return number of bytes read from clipboard; stubbed out. */
	return 0;
}

int clipboardSize(void) {
	/* return the number of bytes of data the clipboard; stubbed out. */
	return 0;
}

int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex) {
	/* write count bytes to the clipboard; stubbed out. */
	return 0;
}

/*** System Attributes ***/

char * GetAttributeString(int id) {
	/* This is a hook for getting various status strings back from
	   the OS. In particular, it allows Squeak to be passed arguments
	   such as the name of a file to be processed. Command line options
	   are reported this way as well, on platforms that support them.
	*/

	// id #0 should return the full name of VM; for now it just returns its path
	if (id == 0) return vmPath;
	// id #1 should return imageName, but returns empty string in this release to
	// ease the transition (1.3x images otherwise try to read image as a document)
	if (id == 1) return "";  /* will be imageName */
	if (id == 2) return "";

	/* the following attributes describe the underlying platform: */
	if (id == 1001) return "Mac OS";
	if (id == 1002) return "System 7 or Later";
	if (id == 1003) return "PowerPC or 680xx";

	/* attribute undefined by this platform */
	success(false);
	return "";
}

int attributeSize(int id) {
	/* return the length of the given attribute string. */
	return strlen(GetAttributeString(id));
}

int getAttributeIntoLength(int id, int byteArrayIndex, int length) {
	/* copy the attribute with the given id into a Squeak string. */
	char *srcPtr, *dstPtr, *end;
	int charsToMove;

	srcPtr = GetAttributeString(id);
	charsToMove = strlen(srcPtr);
	if (charsToMove > length) {
		charsToMove = length;
	}

	dstPtr = (char *) byteArrayIndex;
	end = srcPtr + charsToMove;
	while (srcPtr < end) {
		*dstPtr++ = *srcPtr++;
	}
	return charsToMove;
}

/*** Image File Read/Write ***/

void * sqAllocateMemory(int minHeapSize, int desiredHeapSize) {
	/* allocate memory for Squeak object heap. */
	MaxBlock();
	return NewPtr(desiredHeapSize);
}

void sqImageFileClose(sqImageFile f) {
	FSClose(f);
}

sqImageFile sqImageFileOpen(char *fileName, char *mode) {
	short int err, err2, fRefNum;
	unsigned char *pascalFileName;

	pascalFileName = c2pstr(fileName);
	err = FSOpen(pascalFileName, 0, &fRefNum);
	if ((err !!= 0) && (strchr(mode, ''w'') !!= null)) {
		/* creating a new file for "save as" */
		err2 = Create(pascalFileName, 0, ''FAST'', ''STim'');
		if (err2 == 0) {
			err = FSOpen(pascalFileName, 0, &fRefNum);
		}
	}
	p2cstr(pascalFileName);
	if (err !!= 0) return null;

	if (strchr(mode, ''w'') !!= null) {
		/* truncate file if opening in write mode */
		err = SetEOF(fRefNum, 0);
		if (err !!= 0) {
			FSClose(fRefNum);
			return null;
		}
	}
	return (sqImageFile) fRefNum;
}

int sqImageFilePosition(sqImageFile f) {
	long int currentPosition = 0;

	GetFPos(f, &currentPosition);
	return currentPosition;
}

int sqImageFileRead(void *ptr, int elementSize, int count, sqImageFile f) {
	long int byteCount = elementSize * count;
	short int err;

	err = FSRead(f, &byteCount, ptr);
	if (err !!= 0) return 0;
	return byteCount / elementSize;
}

void sqImageFileSeek(sqImageFile f, int pos) {
	SetFPos(f, fsFromStart, pos);
}

int sqImageFileWrite(void *ptr, int elementSize, int count, sqImageFile f) {
	long int byteCount = elementSize * count;
	short int err;

	err = FSWrite(f, &byteCount, ptr);
	if (err !!= 0) return 0;
	return byteCount / elementSize;
}

/*** I/O Stubs ***/

int ioFormPrint(int bitsAddr, int width, int height,
	int depth, double hScale, double vScale, int landscapeFlag)				STUBBED_OUT
int ioHasDisplayDepth(int depth) 											STUBBED_OUT
int ioRelinquishProcessorForMicroseconds(int microSeconds)					DO_NOTHING
int ioSetDisplayMode(int width, int height, int depth, int fullscreenFlag)	DO_NOTHING
int ioSetFullScreen(int fullScreen) 										DO_NOTHING

/*** File I/0 Stubs ***/

int sqFileAtEnd(SQFile *f)													STUBBED_OUT
int sqFileClose(SQFile *f)													STUBBED_OUT
int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize)			STUBBED_OUT
int sqFileGetPosition(SQFile *f)											STUBBED_OUT
int sqFileInit(void)														{ return true; }
int sqFileOpen(
  SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag)		STUBBED_OUT
int sqFileReadIntoAt(
  SQFile *f, int count, int byteArrayIndex, int startIndex)					STUBBED_OUT
int sqFileRenameOldSizeNewSize(
  int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize)		STUBBED_OUT
int sqFileSetPosition(SQFile *f, int position)								STUBBED_OUT
int sqFileSize(SQFile *f) { return 0; }
int sqFileShutdown(void)													{ return 0; }
int sqFileValid(SQFile *f)													STUBBED_OUT
int sqFileWriteFromAt(
  SQFile *f, int count, int byteArrayIndex, int startIndex)					STUBBED_OUT

/*** Directory Stubs ***/

int dir_Create(char *pathString, int pathStringLength)						STUBBED_OUT
int dir_Delimitor(void)														{ return '':''; }
int dir_Lookup(char *pathString, int pathStringLength, int index,
  char *name, int *nameLength, int *creationDate, int *modificationDate,
  int *isDirectory, int *sizeIfFile)										STUBBED_OUT
dir_SetMacFileTypeAndCreator(char *filename, int filenameSize,
  char *fType, char *fCreator)												DO_NOTHING
int dir_Delete(char *pathString, int pathStringLength)						STUBBED_OUT

/*** Profiling Stubs ***/

int clearProfile(void)														STUBBED_OUT
int dumpProfile(void)														STUBBED_OUT
int startProfiling(void)													STUBBED_OUT
int stopProfiling(void)														STUBBED_OUT

/*** External Primitive Support (No-ops) ***/

int ioLoadModule(char *pluginName) { return 0; }
int ioFindExternalFunctionIn(char *lookupName, int moduleHandle) { return 0; }
int ioFreeModule(int moduleHandle) { return 0; }

/*** Main ***/

void main(void) {
	sqImageFile f;
	int availableMemory;

	/* check the interpreter''s size assumptions for basic data types */
	if (sizeof(int) !!= 4) {
		error("This C compiler''s integers are not 32 bits.");
	}
	if (sizeof(double) !!= 8) {
		error("This C compiler''s floats are not 64 bits.");
	}
	if (sizeof(time_t) !!= 4) {
		error("This C compiler''s time_t''s are not 32 bits.");
	}

	InitMacintosh();
	sqFileInit();

	imageName[0] = shortImageName[0] = vmPath[0] = 0;
	strcpy(imageName, "squeak.image");
	strcpy(shortImageName, "squeak.image");

	/* compute the desired memory allocation */
	availableMemory = MaxBlock() - 50000;
	/******
	  Note: This is platform-specific. On the Mac, the user specifies the desired
	    memory partition for each application using the Finder''s Get Info command.
	    MaxBlock() returns the amount of memory in that partition minus space for
	    the code segment and other resources. On other platforms, the desired heap
	    size would be specified in other ways (e.g, via a command line argument).
	    The maximum size of the object heap is fixed at at startup. If you run low
	    on space, you must save the image and restart with more memory.
		(We reserve 50K for Mac toolbox calls, the error console window, etc.
	******/

	/* read the image file and allocate memory for Squeak heap */
	f = sqImageFileOpen(imageName, "rb");
	if (f == NULL) {
		/* give a Mac-specific error message if image file is not found */
		printf("Could not open the Squeak image file ''%s''\n\n", imageName);
		printf("In this minimal VM, the image file must be named ''squeak.image''\n");
		printf("and must be in the same directory as the Squeak application.\n");
		printf("Press the return key to exit.\n");
		getchar();
		printf("Aborting...\n");
		ioExit();
	}
	readImageFromFileHeapSize(f, availableMemory);
	sqImageFileClose(f);

	/* run Squeak */
	interpret();
}
'
! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:43'!
macNetworkFile

	^ '#include <ConditionalMacros.h>
#if TARGET_CPU_PPC
#include <OpenTransport.h>
#include <OpenTptInternet.h>
#include <OpenTptClient.h>
#include <stropts.h>
#include <Gestalt.h>
#include <TextUtils.h>
#include <files.h>
#if !!TARGET_API_MAC_CARBON
    #ifndef NewOTNotifyUPP
    	typedef struct OTConfiguration* OTConfigurationRef;
    	#define OTNotifyUPP OTNotifyProcPtr 
    	#define NewOTNotifyUPP(userRoutine) userRoutine
    	#define DisposeOTNotifyUPP(userRoutine)
    #endif
#endif

#include "sq.h"
#include "SocketPlugin.h"
//#define OTSERVER

/*  May 1st 2000
	An Open Transport 2.0 version of source code for TCP/IP & UDP support
	Some of this the code was descended from Apple sample source written by: Eric Okholm
	However getting it to work was done by
	John M Mcintosh of Corporate Smalltalk Consulting Ltd
	johnmci@smalltalkconsulting.com 
	http://www.smalltalkconsulting.com 
	In May of 2000 under contract to Disney
	
	Some of the original source code was written by John Maloney of Disney thoughout the 1990''s
	
	The basic intent was to make the code fully interrupt driven
	No limits.... Well maybe we throttle read buffers to some parcel of memory to prevent us
	from using all the memory on the box. Sends depend on lowerlayer buffering/flow control.
	Testing from a 500Mhz PowerBook showed we could saturate a 100MB ethernet when sending data oneway.
	
	UDP and TCP/IP are all supported.
	Note for TCP we turn on two options IP_REUSEADDR, and IP_KEEPALIVE.
	We do NOT handle T_EXDATA  data
	
	V1.0 May 18th 2000, JMM (TCP/IP and UDP)
	V1.1 May 19th 2000, JMM Cleanup
	V1.2 may 20th 2000, JMM UDP free buffer cleanup, relook at resolver terminate to fix crash
	V1.3 may 23rd 2000, JMM fix T_UDERR crash
	V1.3.1 may 24th 2000, JMM UDP work
	V1.3.2 may 25th 2000, JMM socket options work
	V1.3.3 may 27th 2000, JMM rewrote resolver
	V1.3.4 Jun 7th 2000, JMM some integration
	V1.3.5 Jun 9th 2000, JMM Dan Ingalls found some interesting bugs with a T_GODATA on T_CONNECT.
	V1.3.6 Jun 10th 2000, JMM fix a fatal but in close/close pattern I made on the 9th.
	V1.3.7 Aug 1st 2000, JMM Some carbon work, reviewed open non-existent port logic fix so unavailable port causes immediate failure
	V1.3.8 Aug 29th 2000, JMM Fix problem with recusion on make me an EP.
	v1.3.9 Sept 28th 2000, JMM Problem with accept somewhere (so harden code)
	v1.3.10 Oct 4th 2000, JMM Issue with destory and free buffers, and disconnect on read with buffer restriction
	v1.3.11 Nov 11th 2000, JMM extra buffer for server version
	v1.3.12 Jan 2001, Karl Goiser Carbon changes
	
	Notes beware semaphore''s lurk for socket support. Three semaphores lives in Smalltalk, waiting for
	connect/disconnect/listen, sending data, and receiving data. When to tap the semaphore is based on
	inferences driven from the smalltalk code. We really need a call to tell us intent.
	
	waitForDisconnectUntil:
	    via closeAndDestroy: after primSocketCloseConnection:
	    
	waitForDataUntil:
	    Usually before primitiveSocketReceiveDataBufCount: after checking SocketReceiveDataAvailable
	    
	waitForSendDoneUntil:
	    via sendData: or sendSomeData:startIndex;count: before calls to primitiveSocketSendDataBufCount
	    
	waitForConnectionUntil:
	    via waitForAcceptUntil and many places afer doing primitiveSocketConnectToPort
*/				
				
/*** Socket Type Constants ***/
#define TCPSocketType 0
#define UDPSocketType 1
#define TCPListenerSocketType 2   //These are special to enable the right options for listening. Not Exposed to Smalltalk
#define UDPListenerSocketType 3   //Very special not really linked to an EP structure.  Not Exposed to Smalltalk

/*** Resolver Status Constants ***/
#define RESOLVER_UNINITIALIZED	0
#define RESOLVER_SUCCESS		1
#define RESOLVER_BUSY			2
#define RESOLVER_ERROR			3
#define RESOLVER_NAMETOADDR     4
#define RESOLVER_ADDRTONAME     5


/*** TCP Socket Status Constants ***/
#define InvalidSocket           -1
#define Unconnected				0
#define WaitingForConnection	1
#define Connected				2
#define OtherEndClosed			3
#define ThisEndClosed			4


	// Overall program states
enum
{
	kProgramRunning		= 1,
	kProgramDone		= 2
};


	// Bit numbers in EPInfo stateFlags fields
enum
{
	kOpenInProgressBit				= 0,  
	kUnConnected    				= 1,
	kWaitingForConnection           = 2,
	kConnected                      = 3,
	kSendIsBlocked                  = 4,
    kOtherEndClosed                 = 5,
    kThisEndClosed                  = 6,
	kPassconBit                     = 7

};

	// Bit numbers in EPInfo stateFlags2 fields
enum
{
	kFlushDisconnectInProgressBit	= 0,
	kMakeEPIdle                     = 1,
	kEPIsBroken                     = 2,
	kReadFlowControl                = 3,
	kPassconNeeded                  = 4,
	kTapSemaphore                   = 5,
	kTapSemaphoreReadData           = 6,
	kTapSemaphoreWriteData          = 7
};

	// Bit numbers in EPInfo stateFlags3 fields
enum
{
    kKeepAliveOptionNeeded          = 0,
    kSleepKilledMe                  = 1,
    kWaitingForBind                 = 2
}; 

enum
{
	kOTVersion111				= 0x01110000,
	kOTVersion112				= 0x01120000,
	kOTVersion113				= 0x01130000,
	kOTVersion130				= 0x01300000
};

const kTCPKeepAliveInMinutes		= 10;		// 10 minutes  keep alive
#ifdef OTSERVER
const kReadBuffersToAllocate	    = 256;		// Memory Allocation issue how big, this means 256x mtu size * 4 But for 68K we do 1/2 size
#else
const kReadBuffersToAllocate	    = 50;		// Memory Allocation issue how big, this means 50x mtu size * 4 But for 68K we do 1/2 size
#endif

	// Endpoint Info Structure

struct EPInfo
{
	EndpointRef		erf;				//	actual endpoint
	OTLink			link;				//	link into an OT LIFO (atomic)
	OTLink          globalLink;         //  link that follows all allocated EPs
    SInt32          outstandingSends;   //  number of sends outstanding
    OTList          readBuffers;        //  Read buffers
    SInt32          bytesPendingToRead; //  bytes outstanding to read
	SInt32			semaIndex;			//	semaphore index
	SInt32          readSemaIndex;      //  read semaphore
	SInt32          writeSemaIndex;     //  write semaphore
	SInt32          UDPMaximumSize;     //  max size if a UDP endpoint
	SInt32			lastError;          //  last error code
	UInt8			stateFlags;			//	various status fields
	UInt8			stateFlags2;		//	various status fields
	UInt8			stateFlags3;		//	various status fields
	UInt8           socketType;         //  type of socket, tcp, udp, or tcp/udp listener
	InetAddress     localAddress;       //  local address at bind time (ignored used call to get current)
	InetAddress     remoteAddress;      //  remote address at connect (ignored used call to get current)
	Boolean         UDPMoreFlag;        //  UDP more of datagram flag set
    };
typedef struct EPInfo EPInfo;

struct ReadBuffer                       // Structure to contain read data.
{
	OTLink			fNext;				//	link into an OT FIFO 
	UInt32          readBufferSize;
	UInt32			readBufferOriginalSize;  
	char *          readBufferData;
	char *          readBufferPtr;      //Sliding pointer used to partial read buffer.
    InetAddress     UDPAddress;         //UDP address
	Boolean         UDPMoreFlag;        //UDP more of datagram flag set
};
typedef struct ReadBuffer ReadBuffer;


struct TKeepAliveOpt                    
{
	UInt32		len;
	OTXTILevel	level;
	OTXTIName	name;
	UInt32		status;
	UInt32		tcpKeepAliveOn;
	UInt32		tcpKeepAliveTimer;
};
typedef struct TKeepAliveOpt TKeepAliveOpt;

struct TLingerOpt                    
{
	UInt32		len;
	OTXTILevel	level;
	OTXTIName	name;
	UInt32		status;
	UInt32		tcpLingerOn;
	UInt32		tcpLingerTimer;
};
typedef struct TLingerOpt TLingerOpt;

/*** Variables ***/

extern struct VirtualMachine *interpreterProxy;

EPInfo*				gDNSResolver;               //Our resolver
SInt32				gDNSResolverStatus 			= RESOLVER_UNINITIALIZED;
SInt32				gDNSResolverError			= noErr;
SInt32			    gDNSResolverSemaIndex;      //This gets changed at startup time.
InetHostInfo		gDNSHostInfo;
InetDomainName 		gDNSAddrStr;                //Length of domain names? Old code was 512, but specs say 256.
InetHost			gDNSAddr;
SInt32              gDNSLookupType;

OTConfigurationRef	gCfgMastertcp				= NULL;
OTConfigurationRef	gCfgMasterudp				= NULL;
OTConfigurationRef	gCfgMasterListener			= NULL;

OTLIFO				gFreeReadBuffersLIFO;    	//  Buffers that are free to read into
OTLIFO*				gFreeReadBuffers			= &gFreeReadBuffersLIFO;
SInt32				gFreeReadBuffersCounter		= 0;
SInt32				gSocketsAllocated			= 0;
UInt32				gmtuSize 					= 1024; //This gets changed at startup time.
SInt32				gthisNetSession 			= 0;    //This gets changed at startup time.
SInt32				gMaxConnections				= 0;    //This gets changed at startup time.
UInt32				gOTVersion;                         //Gets set to OT version, to help us with special cases.
SInt32				gProgramState				= 0;    //This gets changed at startup time.
OTClientContextPtr     gClientContext;

OTLIFO				gIdleEPLIFO[3];
OTLIFO*				gIdleEPs[3];
SInt32              gIdleEPCounter[3];
OTLIFO				gBrokenEPLIFO;
OTLIFO*				gBrokenEPs					= &gBrokenEPLIFO;
OTLIFO				gAllEPLIFO;
OTLIFO*				gAllEPs					    = &gAllEPLIFO;

OTNotifyUPP DNSNotifierUPP,NotifierSocketUPP,NotifierSocketUDPUPP,NotifierSocketListenerUPP;


/*** Private TCP Socket Functions ***/

/*** Private Resolver Functions ***/
static void 		ResolverInitialize();
static void		    ResolverTerminate(void);
static void 		ResolverStart ();

/*** Other Private Functions ***/
void               CFMTerminate (void);
static Boolean	   DestroyAllOpenSockets(void);
static Boolean	   SocketValid(SocketPtr s);
static Boolean     PortNumberValid(InetPort port) ;
static SInt32      unmapStatus(EPInfo *);
static void        Recycle();
static void        makeEPIdle(EPInfo *epi);
static void        purgeReadBuffers(EPInfo *epi);
static void        makeEPBrokenThenIdle(EPInfo* epi,OTResult error);
static void        makeEPBroken(EPInfo* epi,OTResult error);
static EPInfo*     getOrMakeMeAnEP(UInt8 aSocketType,short counter);
static Boolean     makeMeAnEP(UInt8 aSocketType);
static void        attemptToCloseAndDeleteThisEP (EPInfo *epi);
static void		   makeEPUnconnected(EPInfo* epi);
static void        SetEPLastError(EPInfo* epi,OTResult error);
static void        TapAllInterestedSemaphores(EPInfo *epi);
int 				socketInit(void);
int 				socketShutdown(void);


static pascal void  DNSNotifier(void* context, OTEventCode event, OTResult result, void* cookie);
static pascal void  NotifierSocket(void* context, OTEventCode event, OTResult result, void* cookie);
static pascal void  NotifierSocketUDP(void* context, OTEventCode event, OTResult result, void* cookie);
static pascal void  NotifierSocketListener(void* context, OTEventCode event, OTResult result, void* cookie);
static SInt32       internalSocketCreate(SocketPtr s, SInt32 netType, SInt32  socketType, SInt32 recvBufSize, SInt32 sendBufSize, SInt32 semaIndex, SInt32 readSemaIndex, SInt32 writeSemaIndex, UInt8 aExtraSocketHint);
static Boolean		EPOpen(EPInfo* epi);
static Boolean 		EPClose(EPInfo*);
static void         DoListenAccept(EPInfo* acceptor,EPInfo* theServer);
static void         DoConnect(EPInfo* epi,InetHost addr, InetPort port);
static void         DoBind(EPInfo* epi,InetHost addr, InetPort port,UInt8 aExtraSocketHint, OTQLen queueDepth );
static UInt32       ReadData(EPInfo* epi, char* specialBuffer, UInt32 specialBufferSize);
static OTResult     SendData(EPInfo* epi, char* buffer, UInt32 size);
static OSStatus     doAbortConnection(EPInfo* epi);
static void         NoCopyReceiveWalkingBufferChain(EPInfo *epi,OTBufferInfo *bufferInfo);
static UInt32       readBytes(EPInfo* epi,char *buf,UInt32 adjustedBufSize);
static UInt32       readBytesUDP(EPInfo* epi,InetAddress *fromAddress, int *moreFlag, char *buf,UInt32 adjustedBufSize);
static SInt32	    lookupOptionName(EPInfo *epi, Boolean trueIfGet, char *aString, UInt32 value, SInt32 *result);
static OTResult     SetFourByteOption(EPInfo* epi, Boolean trueIfGet, OTXTILevel level,  OTXTIName  name, UInt32 value, SInt32    *result);
static OTResult     SetOneByteOption(EPInfo* epi, Boolean trueIfGet, OTXTILevel level,  OTXTIName  name, UInt32 value, SInt32    *result);
static OTResult     SetKeepAliveOption(EPInfo* epi, Boolean trueIfGet, OTXTILevel level,  OTXTIName  name, UInt32 value, SInt32    *result);
static OTResult     SetLingerOption(EPInfo* epi, Boolean trueIfGet, OTXTILevel level,  OTXTIName  name, UInt32 value, SInt32    *result);

// Some diagnostic routines

void JMMLogMessage(Str255 input);
void JMMLogMessageAndNumber(Str255 msg,long number);
void JMMWriteLog();

/*** Network Functions ***/

int socketInit() {
	//
	//Don''t actually do any network work until we are newworked initialized
	//This prevents kicking off internet dialup connections until needed
	//
	return true;
}

int socketShutdown() {
	CFMTerminate();
	return true;
}

int sqNetworkInit(int resolverSemaIndex) {

	//
	//  Initialize the network and return 0 if successful
	//  Loads Open transport, allocates memory for read buffers and various other tasks
	//
	
	SInt32              i;
	OSStatus            err = noErr;
	InetInterfaceInfo   interfaceInformation;
	UInt8               aSocketType;
    ReadBuffer          *readBufferObject;
    long				check68KorPPC;
	    
	if (gthisNetSession !!= 0) return 0;  /* noop if network is already initialized */
	

#if TARGET_API_MAC_CARBON
	err = InitOpenTransportInContext (kInitOTForExtensionMask, &gClientContext);
#else
	err = InitOpenTransport(); 
#endif
	if (err) return -1;

		
	err = Gestalt(gestaltOpenTptVersions, (long*) &gOTVersion);
	
	if (err || (gOTVersion < kOTVersion112))
	{
		// Please install Open Transport 1.1.2 or later
		// This might change to 1.3 since tech notes talked about 
		// previous versions having problems with acksend logic.
		//
		return -111;
	}
	
	err = Gestalt(gestaltSysArchitecture, (long*) &check68KorPPC);
	gProgramState = kProgramRunning;

    // 
    //Setup the head of the idle queues
    //
    
	for (i=0;i<3;i++) {
	    gIdleEPs[i] = &gIdleEPLIFO[i];
	    gIdleEPs[i]->fHead	   = NULL;
	    gIdleEPCounter[i]      = 0;
	}
	gBrokenEPs->fHead 		= NULL;
	gFreeReadBuffers->fHead = NULL;
	gAllEPs->fHead          = NULL;
	
	
	gMaxConnections			= 24; // Build 8 of each of listeners, tcp, udp.
	
    DNSNotifierUPP = NewOTNotifyUPP(DNSNotifier);
    NotifierSocketUPP = NewOTNotifyUPP(NotifierSocket);
    NotifierSocketUDPUPP = NewOTNotifyUPP(NotifierSocketUDP);
    NotifierSocketListenerUPP = NewOTNotifyUPP(NotifierSocketListener);

	
#if TARGET_API_MAC_CARBON
	gDNSResolver = (EPInfo*) OTAllocMemInContext(sizeof(EPInfo), gClientContext);
#else
	gDNSResolver = (EPInfo*) OTAllocMem(sizeof(EPInfo));
#endif
	if (gDNSResolver == NULL) return -1;
		
	gDNSResolverSemaIndex = resolverSemaIndex;
	ResolverInitialize();
	
	/* Get MTU and default selected host address */
	
	OTInetGetInterfaceInfo (&interfaceInformation,kDefaultInetInterface);
    gmtuSize = interfaceInformation.fIfMTU;
    
	
	//
	//	Open endpoints 
	//
	gCfgMastertcp = OTCreateConfiguration(kTCPName);
	if (gCfgMastertcp == NULL) return -3;
	
	gCfgMasterudp = OTCreateConfiguration(kUDPName);
	if (gCfgMasterudp == NULL) return -4;
	
	gCfgMasterListener = OTCreateConfiguration("tilisten, tcp"); //Note use of special tilisten logic
	if (gCfgMasterListener == NULL) return -5;
	
	//
	//Build all our EPs, lots of work happens lower down asyncronously
	//
	aSocketType = TCPSocketType;
	for (i = 0; i < gMaxConnections; i++)	{
		makeMeAnEP(aSocketType);
		aSocketType = ++aSocketType > 2 ? TCPSocketType : aSocketType;
	} 
	
#ifdef OTSERVER
	for (i = 0; i < 256; i++)	{
		makeMeAnEP(TCPSocketType);
	} 
#endif

	//
	//Build storage objects for read buffers
	//How much memory to allocate still is a mystery
	//
    for (i=0;i<kReadBuffersToAllocate ;i++) { 
#if TARGET_API_MAC_CARBON
        readBufferObject = OTAllocMemInContext(sizeof(ReadBuffer), gClientContext);
#else
        readBufferObject = OTAllocMem(sizeof(ReadBuffer));
#endif
        if (readBufferObject == nil) {
       	    interpreterProxy->success(false);
            return -25;
        } 
        
        OTMemzero(readBufferObject,sizeof(ReadBuffer));
        if (gestalt68k == check68KorPPC) 
        	readBufferObject->readBufferOriginalSize = (gmtuSize > 0) ? gmtuSize*2 : 1024;
        else
        	readBufferObject->readBufferOriginalSize = (gmtuSize > 0) ? gmtuSize*4 : 1024;
        
#if TARGET_API_MAC_CARBON
       readBufferObject->readBufferData = readBufferObject->readBufferPtr = OTAllocMemInContext(readBufferObject->readBufferOriginalSize, gClientContext);
#else
       readBufferObject->readBufferData = readBufferObject->readBufferPtr = OTAllocMem(readBufferObject->readBufferOriginalSize);
#endif
        if ( readBufferObject->readBufferData == nil) {
       	    interpreterProxy->success(false);
            return -25;
        }

        OTLIFOEnqueue(gFreeReadBuffers, &readBufferObject->fNext);
		gFreeReadBuffersCounter++;
    }


	/* Success!! Create a session ID that is unlikely to be
	   repeated. Zero is never used for a valid session number.
	*/
	gthisNetSession = clock() + time(NULL);
	if (gthisNetSession == 0) gthisNetSession = 1;  /* don''t use 0 */
	
	return 0;
}


void CFMTerminate (void)    /* termination either via a CFM or Squeak call*/
{ 
    sqNetworkShutdown();
}


void sqNetworkShutdown(void) {
	/* shut down the network */
    
	if (gthisNetSession == 0) return;  /* noop if network is already shut down */
	gthisNetSession = 0;
	gProgramState = kProgramDone;
	DestroyAllOpenSockets();
#if TARGET_API_MAC_CARBON
	CloseOpenTransportInContext(gClientContext); 
#else
	CloseOpenTransport(); 
#endif
}


/*** Resolver Functions ***/


static void	ResolverInitialize() 
{
	OSStatus err;
	
	//
	//	Prepare to open internet services
	//  to invoke DNR services
	//
	
	OTMemzero(gDNSResolver, sizeof(EPInfo));	
#if TARGET_API_MAC_CARBON
    gDNSResolver->erf = OTOpenInternetServicesInContext(kDefaultInternetServicesPath, 0, &err, gClientContext);
#else
    gDNSResolver->erf = OTOpenInternetServices(kDefaultInternetServicesPath, 0, &err);
#endif
    gDNSResolver->semaIndex = gDNSResolverSemaIndex;
	
	if (err !!= kOTNoError) {
		gDNSResolverStatus = RESOLVER_ERROR;
		gDNSResolverError = err;
		return;
	}
	gDNSResolverStatus = RESOLVER_SUCCESS;
	gDNSResolverError = kOTNoError;

    err =  OTSetAsynchronous(gDNSResolver->erf);
    err =  OTSetNonBlocking(gDNSResolver->erf);
    err =  OTInstallNotifier(gDNSResolver->erf, DNSNotifierUPP, gDNSResolver);
}

static void ResolverStart () {
	OSStatus err;
	//
	// Invoke DNR service Async, this meants the DNSNotifier will handle the actual 
	// lookup and work, flags like the gDNSResolverStatus are used to indicate back
	// to Squeak when the work is done
	//
	if (gDNSResolver->erf == NULL) //Sleep fix, other endpoints are more explicit about this issue. 
	    ResolverInitialize();
	    
	gDNSResolverStatus  = RESOLVER_BUSY;
	switch (gDNSLookupType) {
		case RESOLVER_NAMETOADDR: {
		    err = OTInetStringToAddress((InetSvcRef)gDNSResolver->erf, gDNSAddrStr, &gDNSHostInfo);
			break;
		}
		case RESOLVER_ADDRTONAME: {
			err = OTInetAddressToName((InetSvcRef)gDNSResolver->erf, gDNSAddr, gDNSAddrStr);
			break;
		}
    }
	if (err !!= kOTNoError)  {
		gDNSResolverStatus = RESOLVER_ERROR;
		gDNSResolverError = err;
	}
}

void ResolverTerminate(void) {
    //JMM if the resolver is opening what happens?
 	gDNSResolverStatus = RESOLVER_UNINITIALIZED;
   
	if (gDNSResolver->erf == NULL) return;
	EPClose(gDNSResolver);
	OTMemzero(gDNSResolver, sizeof(EPInfo));
}

void sqResolverAbort(void) {
	//
	// Abort this running resolver request
	//

	if (gDNSResolverStatus == RESOLVER_BUSY) {
		ResolverTerminate();
		ResolverInitialize();
	}
}

void sqResolverAddrLookupResult(char *nameForAddress, int nameSize) {
	//
	// copy the name found by the last address lookup into the given string 
	//
	
	OTMemcpy(nameForAddress, gDNSAddrStr, (UInt32) nameSize);
	
}

int sqResolverAddrLookupResultSize(void) {
	//
	// return the length of the looked up name
	//
	return (long) strlen(gDNSAddrStr);
}

int sqResolverError(void) {
	//
	// Return OT error number
	//
	return gDNSResolverError; 
}

int sqResolverLocalAddress(void) {
    //
    // Watch out for dynamic changing of this information, so don''t cache
    //
	InetInterfaceInfo interfaceInformation;

	OTInetGetInterfaceInfo (&interfaceInformation,kDefaultInetInterface);
	gDNSResolverStatus = RESOLVER_SUCCESS;
	gDNSResolverError  = noErr;
	return (long) interfaceInformation.fAddress;
}

int sqResolverNameLookupResult(void) {
	//
	// Return address from last lookup
	//
    
	return (int) gDNSAddr;
}

void sqResolverStartAddrLookup(int address) {
	//
	// start process to lookup name from address
	//
    
	if (gDNSResolverStatus == RESOLVER_BUSY) return;

	gDNSAddr            = (InetHost) address;
    gDNSLookupType      = RESOLVER_ADDRTONAME;
	ResolverStart();
}

void sqResolverStartNameLookup(char *hostName, int nameSize) {
	//
	// start process to lookup address from name
	//
    
	UInt32 len; 

	if (gDNSResolverStatus == RESOLVER_BUSY) return;

	len = (UInt32) ((nameSize <= kMaxHostNameLen) ? nameSize : kMaxHostNameLen);  //Old limit was 500  but that appeared to be wrong
	OTMemcpy(gDNSAddrStr, hostName, len);
	gDNSAddrStr[len]    = ''\0'';
    gDNSLookupType      = RESOLVER_NAMETOADDR;
	ResolverStart();
	
}

int sqResolverStatus(void) {
	//
	// return resolver status, this is different from resolver error code
	// status is the same among implementations, error is implementation dependent
	//
    
	return gDNSResolverStatus;
}

//================================

// Socket logic 
//

void	sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID(
			SocketPtr s, int netType, int socketType,
			int recvBufSize, int sendBufSize, int semaIndex) {
			
	//
	//Old call from old image using new VM
	//Just make new call
	//
	sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
  		 s,  netType,  socketType, recvBufSize,  sendBufSize,  semaIndex,  semaIndex,  semaIndex);
}

void sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
  SocketPtr s, int netType, int socketType,
  int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex)	{
     OSErr error; 
     netType; recvBufSize; sendBufSize;
    
    
    //
    //Create a socket given the supplied information
    //We don''t bind the socket to a local port  until 
    //we do the connection. This of course could change? 
    //
    
    error = internalSocketCreate( s, netType, socketType, recvBufSize,  sendBufSize, semaIndex, readSemaIndex, writeSemaIndex, (UInt8) socketType);
    if (error !!= noErr) {
		interpreterProxy->success(false); 
        return;   
    }

}

static SInt32 internalSocketCreate(
  SocketPtr s, SInt32 netType, SInt32 socketType,
  SInt32 recvBufSize, SInt32 sendBufSize, SInt32 semaIndex, SInt32 readSemaIndex, SInt32 writeSemaIndex, UInt8 aExtraSocketHint)	{
  //
  // Internal logic to open a socket for a connection or to listen
  // Note how we ignore buffer sizes!!
  //
    EPInfo*     epi;
    socketType; netType; recvBufSize; sendBufSize;
    
    //
    //Make the socket invalid and then get an idle EP
    //Technically we only run out of EP when we run out of memory
    //
    
	s->sessionID = 0;
	if (gProgramState !!= kProgramRunning ) {		
	    interpreterProxy->success(false);
        return -1;
    }

	epi = getOrMakeMeAnEP(aExtraSocketHint,0);
	if (epi == NULL) {
		interpreterProxy->success(false);
		return -1;
	}

	epi->outstandingSends   = 0;
	epi->bytesPendingToRead = 0;
	epi->semaIndex          = semaIndex;
	epi->readSemaIndex      = readSemaIndex;
	epi->writeSemaIndex     = writeSemaIndex;
	epi->stateFlags         = 0;
	epi->stateFlags2        = 0;
	epi->stateFlags3        = 0;
	SetEPLastError(epi,noErr);
	epi->socketType        = aExtraSocketHint;
	OTInitInetAddress(&epi->remoteAddress, 0, 0);
    OTInitInetAddress(&epi->localAddress, 0, 0);
    
    if (aExtraSocketHint == UDPSocketType)
        OTAtomicSetBit(&epi->stateFlags, kConnected); //udp is always connected
     else
        OTAtomicSetBit(&epi->stateFlags, kUnConnected);
 
 	s->sessionID            = gthisNetSession;
	s->socketType           = (aExtraSocketHint == UDPSocketType) ? UDPSocketType : TCPSocketType;
	s->privateSocketPtr     = epi;
	gSocketsAllocated++;
	return 0;
}

void sqSocketListenOnPort(SocketPtr s, int port) {
    //
    //Listen on port for a connection, this is not the approved method
    //sqSocketListenOnPortBacklogSize is the best way if you are a server
    //However this works ok for UDP and kinda for onetime connections in TCP
    //
    EPInfo* epi;

	if (!!SocketValid(s) || !!PortNumberValid((InetPort) port)) return;
	epi = (EPInfo *) s->privateSocketPtr;
	if (s->socketType == TCPSocketType) {
		DoBind(epi,0,(InetPort) port,TCPListenerSocketType,1);
		if (epi->localAddress.fPort !!= port) {//We die if we don''t get the port we want
            sqSocketDestroy(s);
    	    interpreterProxy->success(false);
		}
	} else {//udp
		DoBind(epi,0,(InetPort) port,UDPListenerSocketType,1);
	}

}

void	sqSocketListenOnPortBacklogSize(SocketPtr s, int port, int backlogSize) {
    EPInfo* epi;
	SInt32 sema,readSema,writeSema;
	OSErr error;
    //
    //Listen on port for a connection, this is the best method if you are
    //a server. Works in conjunction with accept. Shouldn''t drop connections
    //OT''s special listener logic queues up the listen requestions
    //
	if (!!SocketValid(s) || !!PortNumberValid((InetPort) port)) return;
	if (s->socketType == TCPSocketType) {
		epi = (EPInfo *) s->privateSocketPtr;
		sema = epi->semaIndex; readSema = epi->readSemaIndex; writeSema = epi->writeSemaIndex;
	    makeEPIdle(epi); //Special case really need a listener EP, so put this EP back on the queue
	    				 //This may seem odd but the epi is allocated before we know what type it is.
	    				 //Would need to change Squeak to indicate type at creation!!
		error = internalSocketCreate( s, 0, TCPSocketType, 0,  0, sema, readSema, writeSema, TCPListenerSocketType);
		if (error !!= noErr) {
            interpreterProxy->success(false); 
            return;   
		}
        epi = (EPInfo *) s->privateSocketPtr;
		DoBind(epi,0,(InetPort) port,TCPListenerSocketType,(OTQLen) backlogSize);
		if (epi->localAddress.fPort !!= port) {//The port we wanted must match, otherwise we die
		    sqSocketDestroy(s);
    	    interpreterProxy->success(false);
		}
	} else {//udp not allowed
       	    interpreterProxy->success(false);
	}
}

void	sqSocketAcceptFromRecvBytesSendBytesSemaID(
			SocketPtr s, SocketPtr serverSocket,
			int recvBufSize, int sendBufSize, int semaIndex){
	//
	//Old call from old image using new VM
	//Just make new call
	//

	sqSocketAcceptFromRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
			 s,  serverSocket,  recvBufSize,  sendBufSize,  semaIndex,  semaIndex,  semaIndex);
		
}
void	sqSocketAcceptFromRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
			SocketPtr s, SocketPtr serverSocket,
			int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex) {
	//
	//Accept incoming request from a listener
	//We take information from the listener, create a new socket
	//and accept the incoming call
	//
	
    EPInfo* epiSocket;
    EPInfo* epiServerSocket;
    Boolean	doLeave;
    OSErr   error;
    long	count=0;
    
	if (!!SocketValid(serverSocket)) return;
	if (serverSocket->socketType == TCPSocketType) {
            error = internalSocketCreate( s, 0, TCPSocketType, recvBufSize,  sendBufSize, semaIndex, readSemaIndex, writeSemaIndex, TCPSocketType);
		    if (error !!= noErr) {
        		interpreterProxy->success(false); 
		        return;   
		    }
		    epiSocket = (EPInfo *) s->privateSocketPtr;
    		DoBind(epiSocket,0,0,TCPSocketType,0); // interrupt driven to  T_TBINDCOMPLETE
    		while (count++ < 100 && (OTAtomicTestBit(&epiSocket->stateFlags3, kWaitingForBind) == true)) {
#ifndef TARGET_API_MAC_CARBON
			    SystemTask();
#endif
			    OTIdle();
            }
		    OTAtomicSetBit(&epiSocket->stateFlags2, kPassconNeeded);
		    epiServerSocket = (EPInfo *) serverSocket->privateSocketPtr;
			OTAtomicSetBit(&epiServerSocket->stateFlags, kWaitingForConnection);
			OTAtomicSetBit(&epiServerSocket->stateFlags, kUnConnected);
            OTAtomicClearBit(&epiServerSocket->stateFlags, kConnected);
    	    OTAtomicSetBit(&epiServerSocket->stateFlags2, kTapSemaphore);
        	
        	doLeave = OTEnterNotifier(epiServerSocket->erf);
        	DoListenAccept(epiSocket,epiServerSocket);
        	if (doLeave)
        		OTLeaveNotifier(epiServerSocket->erf);
	} else { //udp
		interpreterProxy->success(false); 
	}
}

void sqSocketConnectToPort(SocketPtr s, int addr, int port) {
    //
    //Connect this socket to the given host addr and port
    //
    EPInfo* epi;
	OTResult	epState;

	if (!!SocketValid(s) || !!PortNumberValid((InetPort) port)) return;
	epi = (EPInfo *) s->privateSocketPtr;
	if (s->socketType == TCPSocketType) {
    	DoBind(epi,(InetHost) addr,(InetPort) port,TCPSocketType,0); // interrupt driven to  T_TBINDCOMPLETE which drives T_CONNECT/DoConnect
	} else {//udp
		epState = OTGetEndpointState(epi->erf);
		if (epState == T_UNBND) {//Bind to remote, our side gets wildcarded
    	    DoBind(epi,(InetHost) addr,(InetPort) port,UDPSocketType,0); // interrupt driven to  T_TBINDCOMPLETE which drives T_CONNECT/DoConnect
    	} else {//Already bound to a port/interface on our side
    	    OTInitInetAddress(&epi->remoteAddress, (InetPort) port, (InetHost) addr);
    	}
	}
}


int sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize) {
	//
	// Send data really fast
	// We create a copy of the data and give it to OT to play with
	// We can get flow controlled lower down, if no flow control then we
	// tap the semiphore since from squeaks viewpoint data is sent, otherwise when flow control is lifted the
	// semaphore is tapped in the notification routine
	//
	OTResult res ;
    EPInfo* epi;
    Boolean doLeave;
    char * buffer;
 	UInt32 adjustedBufSize = bufSize > 65536 ? 65536 : (UInt32) bufSize; //? Not sure if we really need to do this limiting.
   	
	if (!!SocketValid(s)) return -1;
	
	epi = (EPInfo *) s->privateSocketPtr;
	
	// If send is blocked wait for unblocking
	if (OTAtomicTestBit(&epi->stateFlags, kSendIsBlocked)) {
	    return 0;
	}

    if (epi->socketType == UDPSocketType) {
        //UDP adjust the buffer size again
        adjustedBufSize = (adjustedBufSize > epi->UDPMaximumSize) ?   epi->UDPMaximumSize : adjustedBufSize;
     }

#if TARGET_API_MAC_CARBON
	buffer = OTAllocMemInContext(adjustedBufSize, gClientContext);
#else
	buffer = OTAllocMem(adjustedBufSize);
#endif
	if (buffer == nil) {
		//Well maybe we back off and wait awhile? 
		//If we run out of memory and stress the box, well death lurks.
		adjustedBufSize = 256;
#if TARGET_API_MAC_CARBON
		buffer = OTAllocMemInContext(adjustedBufSize, gClientContext);
#else
		buffer = OTAllocMem(adjustedBufSize);
#endif
		if (buffer == nil) {
		    interpreterProxy->success(false); //Death did lurk
	        SetEPLastError(epi, -1);
	        return -1;
	    } 
	}
		
	OTMemcpy(buffer,(void*) buf,adjustedBufSize);
    
	doLeave = OTEnterNotifier(epi->erf);  //Avoid race condition for T_GODATA
    res = SendData(epi,buffer,adjustedBufSize);  	
  	if (doLeave)
		OTLeaveNotifier(epi->erf);
		
  	if (res < 0 ){
	    SetEPLastError(epi, res);
		interpreterProxy->success(false); //JMM just for testing
	    return 0;
	}
	return res;
}

//
//New primitive for sending UDP data to a particular host/port
//Avoids race conditions between binding and send in Smalltalk
//

int sqSockettoHostportSendDataBufCount(SocketPtr s, int address, int port, int buf, int bufSize) {
 sqSocketConnectToPort(s, address, port);
 return sqSocketSendDataBufCount(s, buf, bufSize);
}

//
//Abort the socket
//
void sqSocketAbortConnection(SocketPtr s) {
    EPInfo* epi;
   OSStatus err;
 
	if (!!SocketValid(s)) return;
    if (s->socketType == UDPSocketType) {
		interpreterProxy->success(false); 
        return;
    }
	epi = (EPInfo *) s->privateSocketPtr;
	err = doAbortConnection(epi);
}

//
//Acutal abort logic
//We need to flush the queues
//Then do a disconnect
//
static OSStatus doAbortConnection(EPInfo* epi) {
   SInt32		count = 0;
   OSStatus     err = kOTNoError;
 
	if ( OTAtomicSetBit(&epi->stateFlags2, kFlushDisconnectInProgressBit) == 0 ) {
		//Do flush and wait for it to happen
		//Should make sync?
		//
		if (epi->outstandingSends !!= 0) {
		    err = OTIoctl(epi->erf, I_FLUSH, (void *)FLUSHRW);
		    while (count++ < 100 && (epi->outstandingSends !!= 0 || OTAtomicTestBit(&epi->stateFlags, kUnConnected) == false)) {
			    OTIdle();
            }
	    }
        makeEPBroken(epi,0);
	    err = OTSndDisconnect(epi->erf, NULL);
	}
	    
	if (err !!= kOTNoError) 
	    return err;
	else
        return epi->lastError;
}

//
//Socket close logic
//
void sqSocketCloseConnection(SocketPtr s) {
    EPInfo* epi;
    OSStatus err; 
	OTResult	epState;
	OTResult	lookResult;
    
	if (!!SocketValid(s)) return;
	epi = (EPInfo *) s->privateSocketPtr;
    if (s->socketType == UDPSocketType) {//Handle udp and return
        OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);
        OTAtomicClearBit(&epi->stateFlags, kConnected);
        OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);
        OTAtomicSetBit(&epi->stateFlags, kUnConnected);
        OTAtomicSetBit(&epi->stateFlags2, kTapSemaphore);
		err = OTUnbind(epi->erf);
		if (err !!= kOTNoError) { //kOTLookErr with T_DATA, book says response is to zap EP.
		    makeEPBroken(epi,err);
		}
	    TapAllInterestedSemaphores(epi);
	    return;
    }

    OTAtomicSetBit(&epi->stateFlags, kThisEndClosed);
    OTAtomicSetBit(&epi->stateFlags2, kTapSemaphore);
	// old code is sync and doesn''t trigger semaphore 
	
	epState = OTGetEndpointState(epi->erf);
	if (epState == T_UNINIT || epState == T_UNBND ) {
        OTAtomicSetBit(&epi->stateFlags, kThisEndClosed);
        OTAtomicClearBit(&epi->stateFlags, kConnected);
        OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);
 	    TapAllInterestedSemaphores(epi);
	    return;
	}
	else
	    err = OTSndOrderlyDisconnect(epi->erf);
	    
	if (err == kOTNoError) {
        if (OTAtomicTestBit(&epi->stateFlags, kOtherEndClosed)) {
	        OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);
	        OTAtomicClearBit(&epi->stateFlags, kConnected);
	        OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);
	        OTAtomicSetBit(&epi->stateFlags, kUnConnected);
	        if (epi->outstandingSends !!= 0)
	            doAbortConnection(epi);

			err = OTUnbind(epi->erf);
			if (err !!= kOTNoError) { //kOTLookErr with T_DATA, book says response is to zap EP.
			    makeEPBroken(epi,err);
			}
    	    TapAllInterestedSemaphores(epi);
        }
	} else {// Could get kOTLookErr with T_DISCONNECT pending 
		lookResult = OTLook(epi->erf); 
		if (err == kOTLookErr && lookResult == T_DISCONNECT) {
        	err = OTRcvDisconnect(epi->erf, NULL);
	        OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);
	        OTAtomicClearBit(&epi->stateFlags, kConnected);
	        OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);
	        OTAtomicSetBit(&epi->stateFlags, kUnConnected);
	        if (epi->outstandingSends !!= 0)
	            doAbortConnection(epi);

			err = OTUnbind(epi->erf);
			if (err !!= kOTNoError) { //kOTLookErr with T_DATA, book says response is to zap EP.
			    makeEPBroken(epi,err);
			}
    	    TapAllInterestedSemaphores(epi);
        }
        else {
            SetEPLastError(epi,err);
    		makeEPBroken(epi,err);
            TapAllInterestedSemaphores(epi);
       }
	}
}

//
//Destroy the socket here we must ensure we cleanup and put the 
//socket back on the idle or broken EP queue
//
void sqSocketDestroy(SocketPtr s) {
    OTResult err;
    EPInfo* epi;
	OTResult	epState;

    JMMWriteLog(); //Diagnostics, turned off, must fiddle recompile to turn on.
    
  
    if (!!SocketValid(s)) {
    	return; 
    }
	epi = (EPInfo *) s->privateSocketPtr;
   OTAtomicSetBit(&epi->stateFlags2, kMakeEPIdle); 
	epState = OTGetEndpointState(epi->erf);
	if (epState == T_UNINIT || epState == T_UNBND ) {
	    makeEPIdle(epi); //Unbound already so make him idle.
	} else {
	    if (s->socketType == UDPSocketType)
			err = OTUnbind(epi->erf);
	    else 
		    err = doAbortConnection(epi);
	
		if (err !!= kOTNoError) {//kOTLookErr with T_DATA, book says response is to zap EP.
		    makeEPBrokenThenIdle(epi,err);
		}
	}
	purgeReadBuffers(epi); //JMM Oct 4th 2000 (bug?)
	s->sessionID = 0;
	s->socketType = -1;
	s->privateSocketPtr = nil;
	gSocketsAllocated--;
 }

//
//Check to see if bytes are available
//
int sqSocketReceiveDataAvailable(SocketPtr s)							
{
    EPInfo* epi;
    static lastTickCount=0;

	if (!!SocketValid(s)) return 0;
    epi = (EPInfo *) s->privateSocketPtr;
    if (epi->bytesPendingToRead > 0) 
        return 1;
   
    if (OTAtomicTestBit(&epi->stateFlags2, kReadFlowControl)) // New case if data pending but flow controlled then go get it
        return 1;
    
    OTAtomicSetBit(&epi->stateFlags2, kTapSemaphoreReadData); //Note how we imply there will be interest in semaphore
    return 0;
}


//
//Read data into the buffer supplied
//
int sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize) {
    EPInfo* epi;
 	UInt32  bytesRead = 0;
    Boolean doLeave;
    
	if (!!SocketValid(s)) return -1; 
	
	epi = (EPInfo *) s->privateSocketPtr;
        
 	doLeave = OTEnterNotifier(epi->erf);  //Avoid race condition for T_DATA
    bytesRead = readBytes(epi,(char *) buf,(UInt32) bufSize);
    if (OTAtomicTestBit(&epi->stateFlags2, kReadFlowControl)) {
        if (bytesRead > 0) 
            ReadData(epi,NULL,0); 
        else
            bytesRead = ReadData(epi,(char *) buf,(UInt32) bufSize); //special case attempt read into squeak buffer
    }
  	if (doLeave)
		OTLeaveNotifier(epi->erf);
   
	return (int) bytesRead;
}

//
//New primitive to read UDP data and get data, host/port, and more flag
//
int sqSocketReceiveUDPDataBufCountaddressportmoreFlag(SocketPtr s, int buf, int bufSize,  int *address,  int *port, int *moreFlag) {
    EPInfo* epi;
 	UInt32 bytesRead = 0;
    Boolean doLeave;
    InetAddress fromAddress;
    
    OTMemzero(&fromAddress,sizeof(InetAddress));
    *address  = 0;
    *port = 0;
    *moreFlag = 0;
    
	if (!!SocketValid(s)) return -1;
	
	epi = (EPInfo *) s->privateSocketPtr;
        
 	doLeave = OTEnterNotifier(epi->erf);  //Avoid race condition for T_DATA
    bytesRead   = readBytesUDP(epi,&fromAddress, moreFlag, (char *) buf,(UInt32) bufSize);
    *address    = fromAddress.fHost;
    *port       = fromAddress.fPort;
    if (OTAtomicTestBit(&epi->stateFlags2, kReadFlowControl)) {
         if (bytesRead > 0) 
            ReadData(epi,NULL,0); 
        else {
            bytesRead = ReadData(epi,(char *) buf,(UInt32) bufSize);//special case attempt read into squeak buffer
            *address    = epi->remoteAddress.fHost; //Also we happen to know the address just when into this area
            *port       = epi->remoteAddress.fPort; //JMM more flag?
            *moreFlag   = epi->UDPMoreFlag;
        }
    }
  	if (doLeave)
		OTLeaveNotifier(epi->erf);
   
	return (int) bytesRead;
}

int sqSocketLocalAddress(SocketPtr s) {
    EPInfo* epi;
    
	if (!!SocketValid(s)) return -1;
	epi = (EPInfo *) s->privateSocketPtr;
    return (int) (epi->localAddress.fHost == 0) ? sqResolverLocalAddress() : epi->localAddress.fHost;
}

int sqSocketLocalPort(SocketPtr s) {
    EPInfo* epi;
    
	if (!!SocketValid(s)) return -1;
	epi = (EPInfo *) s->privateSocketPtr;
	
	return epi->localAddress.fPort;
}

int sqSocketRemoteAddress(SocketPtr s) {
    EPInfo*     epi;
    TBind       remoteBind;
    InetAddress remoteAddr;
    SInt32        counter=0;
    OSStatus    err;

	if (!!SocketValid(s)) return -1;
	epi = (EPInfo *) s->privateSocketPtr;
	if (OTAtomicTestBit(&epi->stateFlags, kUnConnected) && 
	    !!OTAtomicTestBit(&epi->stateFlags, kWaitingForConnection)) return 0;
	
    if (epi->socketType == UDPSocketType) {
        return (int) epi->remoteAddress.fHost;
    }
    
    //It seems the only reliable way to get the address
    //Is to make a call
    //
    OTMemzero(&remoteBind,sizeof(TBind));
    OTMemzero(&remoteAddr,sizeof(InetAddress));
    remoteBind.addr.buf = (UInt8 *) &remoteAddr;
    remoteBind.addr.maxlen = sizeof(InetAddress);
    err = OTGetProtAddress(epi->erf,0,&remoteBind);
    while (counter++ < 10 && remoteAddr.fHost == 0) {
        OTIdle();
    }
    
    if (err !!= kOTNoError) 
        return 0;
    else
        return (int) remoteAddr.fHost;
}

int sqSocketRemotePort(SocketPtr s) {
    EPInfo* epi;
    TBind       remoteBind;
    InetAddress remoteAddr;
    SInt32        counter=0;
    OSStatus    err;

	if (!!SocketValid(s)) return -1;
	epi = (EPInfo *) s->privateSocketPtr;
	if (OTAtomicTestBit(&epi->stateFlags, kUnConnected) && 
	    !!OTAtomicTestBit(&epi->stateFlags, kWaitingForConnection)) return 0;
	
    if (epi->socketType == UDPSocketType) {
        return epi->remoteAddress.fPort;
    }
    
    //It seems the only reliable way to get the port
    //Is to make a call
    //
    OTMemzero(&remoteBind,sizeof(TBind));
    OTMemzero(&remoteAddr,sizeof(InetAddress));
    remoteBind.addr.buf = (UInt8 *) &remoteAddr;
    remoteBind.addr.maxlen = sizeof(InetAddress);
    err = OTGetProtAddress(epi->erf,0,&remoteBind);
    while (counter++ < 10 && remoteAddr.fHost == 0) {
        OTIdle();
    }
    
    if (err !!= kOTNoError) 
        return 0;
    else
        return remoteAddr.fPort;
}


int sqSocketSendDone(SocketPtr s) {
    EPInfo* epi;

	if (!!SocketValid(s)) return 1;
	epi = (EPInfo *) s->privateSocketPtr;
    if (OTAtomicTestBit(&epi->stateFlags, kSendIsBlocked)) {
	    OTAtomicSetBit(&epi->stateFlags2, kTapSemaphoreWriteData); //Note the implied intent to use the semaphore
        return 0;
    }
    else {
        return 1;
    }
}

int sqSocketError(SocketPtr s) {
    EPInfo* epi;
    
 	if (!!SocketValid(s)) return -1;
	epi = (EPInfo *) s->privateSocketPtr;
    if (OTAtomicTestBit(&epi->stateFlags, kUnConnected)  && 
        !!OTAtomicTestBit(&epi->stateFlags, kWaitingForConnection) 
        && epi->lastError == 0)
	    return kENOTCONNErr; // old code would return unconnectederror if unconnected
	else
	    return (epi->lastError);
}

int sqSocketConnectionStatus(SocketPtr s) {

	if (!!SocketValid(s)) return InvalidSocket;
	return unmapStatus((EPInfo *) s->privateSocketPtr);
}

static SInt32 unmapStatus(EPInfo *s) {
    if (OTAtomicTestBit(&s->stateFlags3, kSleepKilledMe)) 
        {return  InvalidSocket;
        }
    if (OTAtomicTestBit(&s->stateFlags, kThisEndClosed)) 
        {return  ThisEndClosed;
        }
    if (OTAtomicTestBit(&s->stateFlags, kOtherEndClosed)) 
        {return  OtherEndClosed;
        }
    if (OTAtomicTestBit(&s->stateFlags, kConnected)) 
        { return  Connected;
        }
    if (OTAtomicTestBit(&s->stateFlags, kWaitingForConnection)) 
        {return  WaitingForConnection;
        }
    if (OTAtomicTestBit(&s->stateFlags, kUnConnected)) 
        {return  Unconnected;
        }
   return 0;
}

static Boolean SocketValid(SocketPtr s) {
	if ((s !!= NULL) &&
		(s->privateSocketPtr !!= NULL) &&
		(s->sessionID == gthisNetSession) && 
		(s->socketType == TCPSocketType || s->socketType == UDPSocketType) &&
		(!!OTAtomicTestBit(&(((EPInfo *)s->privateSocketPtr)->stateFlags3), kSleepKilledMe)) )
		    return true;
	interpreterProxy->success(false);
	return false;
}


static Boolean PortNumberValid(InetPort port) {
	if (port <= 65535) {
		return true;
	}
	interpreterProxy->success(false);
	return false;
}

//Used to signal all semaphores when we''ve closed the socket
//I guess the read/write/disconnect threads really want to know
//
static void TapAllInterestedSemaphores(EPInfo *epi) {
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphore)) 
	    interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex); 
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphoreReadData)) 
	    interpreterProxy->signalSemaphoreWithIndex(epi->readSemaIndex); 
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphoreWriteData)) 
	    interpreterProxy->signalSemaphoreWithIndex(epi->writeSemaIndex); 				
}

static Boolean DestroyAllOpenSockets(void) {
	EPInfo      *epi;
	OTLink*		link;
    ReadBuffer *aBuffer;

	//
	//	Start closing connector endpoints.
	//	While we could be rude and just close the endpoints, 
	//	we try to be polite and wait for all outstanding connections
	//	to finish before closing the endpoints.   The is a bit easier
	//	on the server which won''t end up keeping around control blocks
	//	for dead connections which it doesn''t know are dead.  Alternately,
	//	we could just send a disconnect, but this seems cleaner.
	//

	(void)OTLIFOStealList(gBrokenEPs);
	(void)OTLIFOStealList(gIdleEPs[0]);
	(void)OTLIFOStealList(gIdleEPs[1]);
	(void)OTLIFOStealList(gIdleEPs[2]);
	
    link = OTLIFODequeue(gAllEPs);
    while (link !!= NULL) {
        epi = OTGetLinkObject(link, EPInfo, globalLink);
     	attemptToCloseAndDeleteThisEP(epi);
        link = OTLIFODequeue(gAllEPs);
    }

	//
	//	If the lists are empty now, then all endpoints have been successfully closed,
	//	so the client is stopped now.  (Actually we hope that is the case)
	//
	
    //
    //Free up all the other resources
    //
    link = OTLIFODequeue(gFreeReadBuffers);
    while (link !!= NULL) {
    	aBuffer = OTGetLinkObject(link, ReadBuffer, fNext);
        OTFreeMem(aBuffer->readBufferData);
        OTFreeMem(aBuffer); 
        link = OTLIFODequeue(gFreeReadBuffers);
    }
    ResolverTerminate();
	OTFreeMem((char*)gDNSResolver);
	gIdleEPs[0]->fHead		= NULL;
	gIdleEPs[1]->fHead		= NULL;
	gIdleEPs[2]->fHead		= NULL;
	gBrokenEPs->fHead 		= NULL;
	OTDestroyConfiguration(gCfgMastertcp);
	OTDestroyConfiguration(gCfgMasterudp);
	OTDestroyConfiguration(gCfgMasterListener);
	DisposeOTNotifyUPP(DNSNotifierUPP);
	DisposeOTNotifyUPP(NotifierSocketUPP);
	DisposeOTNotifyUPP(NotifierSocketUDPUPP);
	DisposeOTNotifyUPP(NotifierSocketListenerUPP);
	return true;
}


//
//	DoBind
//
//	This routine either binds to a wild card address and specfic port if 
//  we are doing a listen, otherwise we bind to a wild card address and 
//  wild card port if we are starting a connection to a remote host.
//  J M M NOTE A more complex version could use port and addr
//  Note we don''t bind to the local socket until here, we could when 
//  The socket is created, but that leads to odd issues.
//

static void DoBind(EPInfo* epi,InetHost addr, InetPort port,UInt8 aExtraSocketHint,OTQLen queueDepth )
{
	OSStatus 	err;
	TBind 		bindReq, bindResult;
	InetAddress	inAddr,bindAddr;
	
	switch (aExtraSocketHint) {
        case TCPSocketType: {
            // for a connection
        	//	Bind the endpoint to a wildcard address 
        	//	(assign us a port, we don''t care which one).
        	//  NOTE A more complex version could use port and addr
            OTInitInetAddress(&epi->remoteAddress, port, addr);
            OTInitInetAddress(&epi->localAddress, 0, kOTAnyInetAddress);
        	OTInitInetAddress(&inAddr, 0, 0);
            break;
        }
        case UDPSocketType: { 
            // for a connection
        	//	Bind the endpoint to earlier supplied information
            OTInitInetAddress(&epi->remoteAddress, port, addr);
        	OTInitInetAddress(&inAddr, 0, 0);
            break;
        }
        case TCPListenerSocketType: {
            // For a listen, bind wild card address, but supplied port.
            // Note the passed in addr should be zero
            // Note a more complex version could supply the address
            OTInitInetAddress(&epi->remoteAddress, 0, kOTAnyInetAddress);
            OTInitInetAddress(&epi->localAddress, port, addr);
        	OTInitInetAddress(&inAddr,port, addr);
            break;
        }
        case UDPListenerSocketType: {
            // For a listen, bind wild card address, but supplied port.
            // Note the passed in addr should be zero
            // Note a more complex version could supply the address
            OTInitInetAddress(&epi->remoteAddress, 0, kOTAnyInetAddress);
            OTInitInetAddress(&epi->localAddress, port, addr);
        	OTInitInetAddress(&inAddr,port, addr);
            break;
        }
	}

 	bindReq.addr.len    	= sizeof(InetAddress);
	bindReq.addr.buf    	= (unsigned char*) &inAddr;
	bindReq.qlen        	= queueDepth; //Note queue depth for listening
 	bindResult.addr.maxlen	= sizeof(InetAddress);
 	bindResult.addr.len   	= sizeof(InetAddress);
	bindResult.addr.buf    	= (unsigned char*) &bindAddr;
	epi->stateFlags     	= 0;
	epi->stateFlags2   		= 0;
	epi->stateFlags3    	= 0;
	epi->bytesPendingToRead = 0;
	SetEPLastError(epi,noErr);
	if (aExtraSocketHint == TCPSocketType|| aExtraSocketHint == TCPListenerSocketType) {
        OTAtomicSetBit(&epi->stateFlags, kUnConnected);
        OTAtomicSetBit(&epi->stateFlags, kWaitingForConnection);
        OTAtomicSetBit(&epi->stateFlags2, kTapSemaphore);
    }
	
	OTAtomicSetBit(&epi->stateFlags3, kWaitingForBind);
	err = OTBind(epi->erf, &bindReq, &bindResult); // resume at T_BINDCOMPLETE
	
	// for bindReq on listen what is queueDepth now? 
	// bindReq.qlen could have changed
	// But... No why to feed this back to the client!!
	
	if (err !!= kOTNoError) {
    	SetEPLastError(epi,err);
        makeEPUnconnected(epi);
    	return;
	}
	
	OTMemcpy(&epi->localAddress,bindResult.addr.buf,sizeof(InetAddress)); //Pickup local address
	return;
}

//
//	DoConnect
//
//	This routine attempts establish a new connection to the given
//	address and port.  
//  Called via the notifier at interrupt time.
//

static void DoConnect(EPInfo* epi,InetHost addr, InetPort port)
{
	OSStatus err;
	TCall sndCall;
	InetAddress inAddr;
	
	//	Don''t want new connections if already shutting down.
	if (gProgramState !!= kProgramRunning ) return;
		
	OTInitInetAddress(&inAddr, port, addr);
	OTMemzero(&sndCall, sizeof(TCall));
	sndCall.addr.len 	= sizeof(InetAddress);				
	sndCall.addr.buf	= (unsigned char*) &inAddr;
	
	err = OTConnect(epi->erf, &sndCall, NULL); //resume at T_CONNECT
	if (err !!= kOTNoDataErr) {
    	SetEPLastError(epi,err);
        makeEPUnconnected(epi);
		return;
	}
}


//
//	DoListenAccept
//
//	The handling of a T_LISTEN is greatly simplified by use
//	of the tilisten module, which serializes inbound connections.
//	This means that when doing an OTAccept we won''t get a kOTLookErr
//	because another inbound connection arrived and created a T_LISTEN.
//	Without the tilisten module, we have to use the "8 step 
//	listen/accept/disconnect method", which is documented elsewhere.
//

static void DoListenAccept(EPInfo* acceptor,EPInfo* theServer)
{
	TCall		call;
	InetAddress	caddr;
	OTResult	lookResult;
	OSStatus	err;
			
	OTMemzero(&call, sizeof(TCall));
	call.addr.maxlen = sizeof(InetAddress);
	call.addr.buf = (unsigned char*) &caddr;
		
	err = OTListen(theServer->erf, &call);
	if (err !!= kOTNoError) {
		//
		//	Only two errors are expected at this point.
		//	One would be a kOTNoDataErr, indicating the inbound connection
		//	was unavailable, temporarily hidden by a higher priority streams
		//	message, etc.   The more likely error is a kOTLookErr, 
		//	which indicates a T_DISCONNECT on the OTLook()
		//	happens when the call we were going to process disconnected.
		//	In that case, go away and wait for the next T_LISTEN event.
		//
		if (err == kOTNoDataErr) return;
			
		lookResult = OTLook(theServer->erf); 
		if (err == kOTLookErr && lookResult == T_DISCONNECT)
        	err = OTRcvDisconnect(theServer->erf, NULL);
		else 
		    SetEPLastError(theServer,lookResult);
		
		//JMM Sept28th,2000 ? ok accept it, if we don''t does this cause blockage?
		acceptor->remoteAddress = caddr;
		err = OTAccept(theServer->erf, acceptor->erf, &call);
		return;	
	}
	
	acceptor->remoteAddress = caddr;
	
	err = OTAccept(theServer->erf, acceptor->erf, &call);
	//
	//	Note an kOTIndOutErr can occur if we are listening on the EP and handling 
	//  off to the same EP. Sorry use the listento:backlogqueue: logic instead
    //
	if (err !!= kOTNoError) {
		//
		//	Again, we have to be able to handle the connection being disconnected
		//	while we were trying to accept it.
		//
		lookResult = OTLook(theServer->erf);
		if (err == kOTLookErr && lookResult == T_DISCONNECT) 
        	err = OTRcvDisconnect(theServer->erf, NULL);
		else 
		    SetEPLastError(theServer,lookResult);
	}
}

//
//	EPOpen:
//
//	A front end to OTAsyncOpenEndpoint.
//	A status bit is set so we know there is an open in progress.
//	It is cleared when the notifier gets a T_OPENCOMPLETE where the context
//	pointer is this EPInfo.  Until that happens, this EPInfo can''t be cleaned
//	up and released.
//
static Boolean EPOpen(EPInfo* epi)
{
	OSStatus err;
	
	OTAtomicSetBit(&epi->stateFlags, kOpenInProgressBit);
	SetEPLastError(epi,kOTNoError);
    epi->UDPMaximumSize = 0; //Remember to figure out the max UDP size.
    
	switch (epi->socketType) {
	    case TCPSocketType: {
#if TARGET_API_MAC_CARBON
		    err = OTAsyncOpenEndpointInContext(OTCloneConfiguration(gCfgMastertcp), 0, NULL, NotifierSocketUPP, epi, gClientContext); 
#else
		    err = OTAsyncOpenEndpoint(OTCloneConfiguration(gCfgMastertcp), 0, NULL, NotifierSocketUPP, epi); 
#endif
	        break;
	    }
	    case UDPSocketType: {
	        TEndpointInfo endPointInformation;
#if TARGET_API_MAC_CARBON
		    err = OTAsyncOpenEndpointInContext(OTCloneConfiguration(gCfgMasterudp), 0, &endPointInformation, NotifierSocketUDPUPP, epi, gClientContext); 
#else
		    err = OTAsyncOpenEndpoint(OTCloneConfiguration(gCfgMasterudp), 0, &endPointInformation, NotifierSocketUDPUPP, epi); 
#endif
		    epi->UDPMaximumSize = (endPointInformation.tsdu == T_INFINITE) ? 64*1024 : endPointInformation.tsdu;
	        break;
	    }
	    case TCPListenerSocketType: {
#if TARGET_API_MAC_CARBON
		    err = OTAsyncOpenEndpointInContext(OTCloneConfiguration(gCfgMasterListener), 0, NULL, NotifierSocketListenerUPP, epi, gClientContext); 
#else
		    err = OTAsyncOpenEndpoint(OTCloneConfiguration(gCfgMasterListener), 0, NULL, NotifierSocketListenerUPP, epi); 
#endif
	        break;
	    }
	}
	if (err !!= kOTNoError) {
		SetEPLastError(epi,err);
		OTAtomicClearBit(&epi->stateFlags, kOpenInProgressBit);
		return false;
	}
	return (epi->lastError == kOTNoError);
}


//
//	EPClose
//
//	This routine is a front end to OTCloseProvider.   
//	Centralizing closing of endpoints makes debugging and instrumentation easier.  
//
static Boolean EPClose(EPInfo* epi)
{
	OSStatus err;
	
	//
	//	If an endpoint is still being opened, we can''t close it yet.
	//	There is no way to cancel an OTAsyncOpenEndpoint, so we just
	//	have to wait for the T_OPENCOMPLETE event at the notifier.
	//
	if ( OTAtomicTestBit(&epi->stateFlags, kOpenInProgressBit) )
		return false;
		
    
	//
	//	If the OTAsyncOpenEndpoint failed, the endpoint ref will be NULL,
	//	and we don''t need to close it now. Also can be NULL or should be NULL if sleeping happened.
	//
	if (epi->erf == NULL || OTAtomicClearBit(&epi->stateFlags3, kSleepKilledMe)) {
	    epi->erf = NULL;
		return true;
	}
		
	if (epi->outstandingSends == 0) {
    	err = OTCloseProvider(epi->erf);
    	epi->erf = NULL;
    	return true;
    }
    	
    //
	//	If we get to this point, the endpoint did an OTSnd() with AckSends,
	//	and the T_MEMORYRELEASED event hasn''t been returned yet.  In order
	//	to make sure we get the event, we flush the stream and then do an
	//	OTDisconnect().   This should get the memory freed so we can close
	//	the endpoint safely.   Note, we set a flag so we don''t do this 
	//	more than once on an endpoint.
	//  J M M I''m not sure we''ll ever get here since a flush should have been done higher up
	//
	if ( OTAtomicSetBit(&epi->stateFlags2, kFlushDisconnectInProgressBit) == 0 )
	{
		err = OTIoctl(epi->erf, I_FLUSH, (void *)FLUSHRW);
		if (err !!= kOTNoError)
			{} 
	}
	return false;

}

//
//	Recycle:
//
//	This routine shouldn''t be necessary, but it is helpful to work around both
//	problems in OpenTransport and bugs in this program.   Basicly, whenever an
//	unexpected error occurs which shouldn''t be fatal to the program, the EPInfo
//	is queued on the BrokenEP queue.  When recycle is called,
//  it will attempt to close the associated endpoint and open
//	a new one to replace it using the same EPInfo structure.   This process of
//	closing an errant endpoint and opening a replacement is probably the most
//	reliable way to make sure that this program and OpenTransport can recover
//	from unexpected happenings in a clean manner.
//
//  Mind you it can be invoked to cleanup UDP sockets that aren''t closed 
//  properly due to pending traffice on a busy port.
//  Solution mentioned in books is to close the EP.
//
static void Recycle()
{
	OTLink* 	list = OTLIFOStealList(gBrokenEPs);
	OTLink*		link;
	EPInfo*		epi;

	while ( (link = list) !!= NULL ) {
		list = link->fNext;
		epi = OTGetLinkObject(link, EPInfo, link);
		if (!!EPClose(epi)) {
			OTLIFOEnqueue(gBrokenEPs, &epi->link);
			continue;
		}
		if (gProgramState == kProgramRunning)
		    EPOpen(epi);
		 else
		    makeEPIdle(epi);
	}
}

//
// Make the EP idle, it either goes on an idle queue or gets broken.
//
static void    makeEPIdle(EPInfo *epi) {
    purgeReadBuffers(epi);
    
    if (OTAtomicClearBit(&epi->stateFlags2, kEPIsBroken)) {
        OTLIFOEnqueue(gBrokenEPs, &epi->link); 
    } else {
	    OTLIFOEnqueue(gIdleEPs[epi->socketType], &epi->link); 
   	    OTAtomicAdd32(1, &gIdleEPCounter[epi->socketType]); 
   }
}

static void attemptToCloseAndDeleteThisEP (EPInfo *epi) {
    purgeReadBuffers(epi); 
	if (!!EPClose(epi)) {
		//	Can''t close this endpoint yet, so skip it.
	} else 
	    OTFreeMem((char*)epi);
}
static EPInfo* getOrMakeMeAnEP(UInt8 aSocketType,short counter) {
	EPInfo      *epi;
    OTLink		*link;
    SInt32      i;
    
    Recycle();  //Ensure broken EP get fixed up
    
    if (counter > 25) 
        return nil;  // End recursion John 2000/8/29

    if (gIdleEPCounter[aSocketType] < 5)   //Magic Number ensure we have at least 5 EP available.
        makeMeAnEP(aSocketType);
        
    link = OTLIFODequeue(gIdleEPs[aSocketType]);
	if (link == NULL) {
		for(i=0;i<10;i++) {OTIdle();};
		return getOrMakeMeAnEP(aSocketType,counter+1); //Watch for recursive failure
	}
	
   	OTAtomicAdd32(-1, &gIdleEPCounter[aSocketType]);
	epi = OTGetLinkObject(link, EPInfo, link);
	
	if (OTAtomicTestBit(&epi->stateFlags3, kSleepKilledMe)) {
	//
	//A broken epi on the idle stack, now the only way we can 
	//get here (I think) is to have gone to sleep which breaks
	//all the end points. To clean up we must now fix them
	//So make it idle, of course it''s broken
	//Then recursive call to get another one
	//This continues until we get a good one
	//
  	    makeEPIdle(epi);
	    return getOrMakeMeAnEP(aSocketType,counter);  //Not a recursion issue. 
	}
    return epi;
}

//
//This is where EP are actually made and opened
//EP opening is async
//

static Boolean makeMeAnEP (UInt8 aSocketType) {
	EPInfo      *epi;
	
#if TARGET_API_MAC_CARBON
	epi = (EPInfo*) OTAllocMemInContext(sizeof(EPInfo), gClientContext);
#else
	epi = (EPInfo*) OTAllocMem(sizeof(EPInfo));
#endif
	if (epi == NULL) return false;   //Death lurks
	OTMemzero(epi, sizeof(EPInfo));  //zero it out which makes all the pointers null
    epi->socketType = aSocketType;
    OTLIFOEnqueue(gAllEPs, &epi->globalLink);
	return EPOpen(epi);
}

static void makeEPUnconnected(EPInfo *epi) {
	OTAtomicClearBit(&epi->stateFlags, kWaitingForConnection);
	OTAtomicSetBit(&epi->stateFlags, kUnConnected);
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphore)) //tap to clear waitforconnection on error
        interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
}

static void makeEPConnected(EPInfo *epi) {
	OTAtomicClearBit(&epi->stateFlags, kWaitingForConnection);
	OTAtomicClearBit(&epi->stateFlags, kUnConnected);
    OTAtomicSetBit(&epi->stateFlags, kConnected);
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphore)) //tap to clear waitforconnection
        interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
}

static void makeEPBrokenThenIdle(EPInfo* epi,OTResult error) {
    makeEPBroken(epi,error);
    makeEPIdle(epi);
}

static void makeEPBroken(EPInfo* epi,OTResult error) {
    SetEPLastError(epi,error);
    OTAtomicSetBit(&epi->stateFlags2, kEPIsBroken);
}

static void SetEPLastError(EPInfo* epi,OTResult error) {
    if (error < 0) {
		JMMLogMessageAndNumber("\p NonZero Error For ",epi->semaIndex);
		JMMLogMessageAndNumber("\p NonZero Error Is  ",error);
    }
    epi->lastError = error;
}

//	ReadData:
//
//	This routine attempts to read all available data from an endpoint.
//	it is not necessary for the program to handle
//	getting back a T_DATA notification DURING an OTRcv() call, as would be
//	the case if we read from outside the notifier.   We must read until we
//	get a kOTNoDataErr in order to clear the T_DATA event so we will get
//	another notification of T_DATA in the future.
//  Note we use EnterNotifier to make this possible
//
//	Note for the curious we attempted to use no-copy receives to get data.  This obligates
//	the program to return the buffers to OT asap.  BUT we found we overran memory!!
//  So we reverted to more expensive copies into buffers we have preallocated
//
//  Perhaps a seperate routine for UDP would make sense?
//  Note May 30/00 we added a special read when we exhaust the internal buffer pool
//  But data is still pending we allow you to read into the squeak buffer directly
//

static UInt32 ReadData(EPInfo* epi,char *specialReadBuffer,UInt32 specialReadSize) {
	OTResult  	res;
	OTFlags	  	flags;
	OTResult	epState,err;
	OTLink		*link;
    ReadBuffer 	*readBufferObject,simulatedReadBuffer;
    InetAddress UDPdataFromAddress;
	
    if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphoreReadData)) //tap to clear waitfordata Data Data Data
        interpreterProxy->signalSemaphoreWithIndex(epi->readSemaIndex);
        
    if (specialReadSize > 0) { //Special case drop into squeak buffer, make a simulated buffer object
        OTMemzero(&simulatedReadBuffer,sizeof(ReadBuffer));
        simulatedReadBuffer.readBufferData = specialReadBuffer;
        simulatedReadBuffer.readBufferSize = simulatedReadBuffer.readBufferOriginalSize = specialReadSize;
        readBufferObject = &simulatedReadBuffer;
    } else {
       link = OTLIFODequeue(gFreeReadBuffers);
            
    	if (link == NULL) {
           	OTAtomicSetBit(&epi->stateFlags2, kReadFlowControl);  //NO free buffers we are flow controled
        	return; 
    	}
		gFreeReadBuffersCounter--;
    	readBufferObject = OTGetLinkObject(link, ReadBuffer, fNext);
        OTAtomicClearBit(&epi->stateFlags2, kReadFlowControl);  
    }
    
    OTMemzero(&UDPdataFromAddress,sizeof(InetAddress));
    
	while (true) {
        
		readBufferObject->readBufferPtr = readBufferObject->readBufferData;
		
   	    if (epi->socketType == UDPSocketType) {
   	        TUnitData 	UDPDataInBound;
   	        OTFlags     flagMeaningMore;
            OSStatus    error;
            
    	    UDPDataInBound.addr.maxlen = sizeof(InetAddress);
    	    UDPDataInBound.addr.len    = sizeof(InetAddress);
    	    UDPDataInBound.addr.buf    = (UInt8*) &readBufferObject->UDPAddress;
    	    UDPDataInBound.opt.maxlen  = 0;
    	    UDPDataInBound.opt.len     = 0;
    	    UDPDataInBound.opt.buf     = NULL;
    	    UDPDataInBound.udata.maxlen = readBufferObject->readBufferOriginalSize;
    	    UDPDataInBound.udata.len    = readBufferObject->readBufferOriginalSize;
    	    UDPDataInBound.udata.buf    = (UInt8*)readBufferObject->readBufferData;
	    
	        error =  OTRcvUData(epi->erf, &UDPDataInBound, &flagMeaningMore);
	        
	        if (error !!= kOTNoError) {
	            res = error;
	        } else {
	            if (UDPDataInBound.addr.len == 0) //Remember UDP address
	                readBufferObject->UDPAddress = UDPdataFromAddress;
	            else
	                UDPdataFromAddress = readBufferObject->UDPAddress;
	                
	            epi->UDPMoreFlag = readBufferObject->UDPMoreFlag = (flagMeaningMore > 0) ? true: false;
	            res = (SInt32) UDPDataInBound.udata.len; 
	            OTMemcpy(&epi->remoteAddress,&readBufferObject->UDPAddress,sizeof(InetAddress));  
	        }
   	    } else {//A less complicated tcp read
   	        res = OTRcv(epi->erf, readBufferObject->readBufferData, readBufferObject->readBufferOriginalSize, &flags);
   	    }
   	    
		//
		//	Note, check for 0 because can get a real 0 length receive
		//	in some protocols (not in TCP), which is different from
		//	getting back a kOTNoDataErr.
		//
		if (res >= 0) {
            if (specialReadSize > 0) 
                return (UInt32) res; //Note special case
                
            readBufferObject->readBufferSize = (UInt32) res;
            
            OTAddLast(&epi->readBuffers,&readBufferObject->fNext); //Put the buffer on the read queue
        	OTAtomicAdd32(res, &epi->bytesPendingToRead);
            link = OTLIFODequeue(gFreeReadBuffers);
                    
        	if (link == NULL) {
               	OTAtomicSetBit(&epi->stateFlags2, kReadFlowControl); //Our read flow control, OT will block lower down
            	return; 
        	}
			gFreeReadBuffersCounter--;
        	readBufferObject = OTGetLinkObject(link, ReadBuffer, fNext);
   			continue; //Loop around and get more bytes if available
		}
		else {
            if (specialReadSize == 0) {
                OTLIFOEnqueue(gFreeReadBuffers, &readBufferObject->fNext); //Read above didn''t work so put it back on free queue
				gFreeReadBuffersCounter++;
			}
		}
		
		if (res == kOTNoDataErr) {
			//
			//	Since ReadData is only called from inside the notifier
			//	we don''t have to worry about having missed a T_DATA 
			//	during the OTRcv.
			//  Note use of EnterNotifier logic
			//
			if (specialReadSize > 0)
			    OTAtomicClearBit(&epi->stateFlags2, kReadFlowControl);
 			return 0;
		}
		if (res == kOTLookErr) {
			res = OTLook(epi->erf);
			if (res == T_ORDREL || res == T_DISCONNECT) {
				//	If we got the T_ORDREL, we won''t get any more inbound data.
				//	We return and wait for the notifier to get the T_ORDREL notification.
				//	Upon getting it, we will notice we still need to send data and do so.
				//	The T_ORDREL has to be cleared before we can send. 
				//
				if (specialReadSize > 0 && res == T_DISCONNECT) {
					//Special case? need to get disconnect 
					err = OTRcvDisconnect(epi->erf, NULL);
					makeEPUnconnected(epi);
				}
				return 0 ;
			}
			if (res == T_GODATA) {
			    if (specialReadSize == 0) {
    			    link = OTLIFODequeue(gFreeReadBuffers);    
                	if (link == NULL) {
                       	OTAtomicSetBit(&epi->stateFlags2, kReadFlowControl);
                    	return 0 ; 
                	}
					gFreeReadBuffersCounter--;
                	readBufferObject = OTGetLinkObject(link, ReadBuffer, fNext);
            	} else {
            	    return 0;
            	}
			    continue; //OT Flow control lifted keep reading. JMM
			}
		} else {
			epState = OTGetEndpointState(epi->erf);
			if (res == kOTOutStateErr && epState == T_INREL) {
				//
				//	Occasionally this problem will happen due to what appears
				//	to be an OpenTransport notifier reentrancy problem.   
				//	What has occured is that a T_ORDREL event happened and 
				//	was processed during ReadData().   This is proven by being
				//	in the T_INREL state without having done a call to
				//	OTRcvOrderlyDisconnect() here.   It appears to be a benign 
				//	situation, so the way to handle it is to understand that no
				//	more data is going to arrive and go ahead and being our response
				//	to the client.
				//
				break;
			}
			if (res == kOTOutStateErr && (epState == T_UNBND || epState == T_IDLE ) && specialReadSize > 0) {
				  interpreterProxy->success(false); //JMM Oct 4th 2000 special case fail if read on unbound
				  return 0;
			}
		break; //Ok error so break out of loop
		}
	}
    return 0;	
}

//
// NOT USED HISTORICAL REASONS
// 
/*

static void NoCopyReceiveWalkingBufferChain(EPInfo *epi,OTBufferInfo *bufferInfo)
{
   OSStatus     err;
   OTBuffer     *thisBuffer;
   UInt32       count;
   ReadBuffer   *readBufferObject;
   
    
    thisBuffer = bufferInfo->fBuffer;
    err = noErr;
    while (err == noErr && thisBuffer !!= nil) {
        count = thisBuffer->fLen;
    	OTAtomicAdd32(count, &epi->bytesPendingToRead);
		readBufferObject = OTAllocMemInContext(sizeof(ReadBuffer), gClientContext);
        if (readBufferObject == nil) {
			SysBeep(5);
            err = -1;
            break;
        } 
        OTMemzero(readBufferObject,sizeof(ReadBuffer));
        readBufferObject->readBufferData = readBufferObject->readBufferPtr = OTAllocMemInContext(count, gClientContext);
        if ( readBufferObject->readBufferData == nil) {
			SysBeep(5);
             err = -1;
            break;
        } 
        readBufferObject->readBufferOriginalSize = readBufferObject->readBufferSize = count;
        OTMemcpy(readBufferObject->readBufferData,thisBuffer->fData,count);
        OTAddLast(&epi->readBuffers,&readBufferObject->fNext);
        thisBuffer = thisBuffer->fNext;
    }

   // Clean up.  We MUST release the OTBuffer chain to Open Transport 
   // so that it crelease the OTBuffer chain to Open Transport 
   // so that it can reuse it., OTReleaseBuffer does not tolerate
   // the parameter being nil, so we check for that case first. 

   if (bufferInfo->fBuffer !!= nil) {
      OTReleaseBuffer(bufferInfo->fBuffer);
   }

}
*/

//
// Read Bytes from the buffers
// Called by Squeak to get the data
//
static UInt32  readBytes(EPInfo* epi,char *buf,UInt32 adjustedBufSize)
{
    //
    // Read bytes from buffers
    // use recursion to fill buf to adjustedBufSize or 
    // til we have no buffers left
    // By using enterNotifier higher up we avoid race on the readBuffers list
    //
    
    UInt32 		increment,bytesRead = 0;
    ReadBuffer *aBuffer;
    
    aBuffer = (ReadBuffer *) OTRemoveFirst(&epi->readBuffers);
    if (aBuffer == nil) return 0;
    
    if (aBuffer->readBufferSize > adjustedBufSize) {
        bytesRead = adjustedBufSize;
    	OTAtomicAdd32(-bytesRead, &epi->bytesPendingToRead);
        OTMemcpy((char *) buf,aBuffer->readBufferPtr,bytesRead);
        aBuffer->readBufferPtr += bytesRead;
        aBuffer->readBufferSize -= bytesRead;
        OTAddFirst(&epi->readBuffers,&aBuffer->fNext);
        return bytesRead;
    }
    else {
        bytesRead = aBuffer->readBufferSize;
       	OTAtomicAdd32(-bytesRead, &epi->bytesPendingToRead);
        OTMemcpy(buf,aBuffer->readBufferPtr,bytesRead);
        OTLIFOEnqueue(gFreeReadBuffers, &aBuffer->fNext);
		gFreeReadBuffersCounter++;
        increment = readBytes(epi,buf+bytesRead,adjustedBufSize-bytesRead);
        bytesRead += increment;
        return bytesRead;
   }
}


static UInt32  readBytesUDP(EPInfo* epi,InetAddress *fromAddress, int * moreFlag, char *buf,UInt32 adjustedBufSize)
{
    //
    // Read bytes from buffers
    // For UDP we just drop in the read buffer and address
    // Don''t fill the entire buffer no recursion.
    // By using enterNotifier higher up we avoid race on the readBuffers list
    //
    
    UInt32      bytesRead = 0;
    ReadBuffer  *aBuffer;
    
    aBuffer = (ReadBuffer *) OTRemoveFirst(&epi->readBuffers);
    if (aBuffer == nil) return 0;
    
    if (aBuffer->readBufferSize > adjustedBufSize) {
        bytesRead = adjustedBufSize;
    	OTAtomicAdd32(-bytesRead, &epi->bytesPendingToRead);
        OTMemcpy((char *) buf,aBuffer->readBufferPtr,bytesRead);
        aBuffer->readBufferPtr += bytesRead;
        aBuffer->readBufferSize -= bytesRead;
        OTMemcpy(fromAddress,&aBuffer->UDPAddress,sizeof(InetAddress));
        *moreFlag = aBuffer->UDPMoreFlag;
        OTAddFirst(&epi->readBuffers,&aBuffer->fNext);
        return bytesRead;
    }
    else {
        bytesRead = aBuffer->readBufferSize;
       	OTAtomicAdd32(-bytesRead, &epi->bytesPendingToRead);
        OTMemcpy(buf,aBuffer->readBufferPtr,bytesRead);
        OTMemcpy(fromAddress,&aBuffer->UDPAddress,sizeof(InetAddress));
        *moreFlag = aBuffer->UDPMoreFlag;
        OTLIFOEnqueue(gFreeReadBuffers, &aBuffer->fNext);
		gFreeReadBuffersCounter++;
        return bytesRead;
   }
}

//Cleanup logic
//

static void purgeReadBuffers(EPInfo *epi) {
    ReadBuffer *aBuffer;
        
    //
    //Put buffers for this epi back on the free queue
    //
    aBuffer = (ReadBuffer *) OTRemoveFirst(&epi->readBuffers);
    
    while (aBuffer !!= NULL) {
        OTLIFOEnqueue(gFreeReadBuffers, &aBuffer->fNext);
		gFreeReadBuffersCounter++;
        aBuffer = (ReadBuffer *) OTRemoveFirst(&epi->readBuffers);
    }
    epi->bytesPendingToRead = 0;
}



//
//	Send the Bytes (Really fast, we hope)
//
static SInt32 SendData(EPInfo* epi,char* buffer, UInt32 size)
{
	OTResult res;
	struct OTData *dataPtr; 

 	//
	//	Make sure we record that we are starting a send so we don''t try to close
	//	the endpoint before a T_MEMORYRELEASED event is returned.
	//
	OTAtomicAdd32(1, &epi->outstandingSends);
	
	if (epi->socketType == UDPSocketType) {
		TUnitData UDPDataOutBound;

	    UDPDataOutBound.addr.maxlen  = sizeof(InetAddress);
	    UDPDataOutBound.addr.len     = sizeof(InetAddress);
	    UDPDataOutBound.addr.buf     = (UInt8*) &epi->remoteAddress;
	    UDPDataOutBound.opt.maxlen   = 0;
	    UDPDataOutBound.opt.len      = 0;
	    UDPDataOutBound.opt.buf      = NULL;
	    UDPDataOutBound.udata.maxlen = size;
	    UDPDataOutBound.udata.len    = size;
	    UDPDataOutBound.udata.buf    = (UInt8*)buffer;
	    
        res =  OTSndUData(epi->erf,&UDPDataOutBound); 
        if (res == kOTNoError ) return (SInt32) size;
        
        // Other Errors could be kOTFlowErr or kOTBadDataErr
	}
	else { //TCP Send
    	//
    	//	In OT 1.1.2 and previous versions, there is a bug with AckSends
    	//	which occurs when the same buffer is sent more than once.   In an attempt
    	//	to go fast and not allocate memory, TCP may write an IP and TCP header
    	//	into the data buffer which is sent.   If the buffer is sent more than once
    	//	without being refreshed, the data may be corrupted.   To work around this,
    	//	send the data via an OTData structure, using the gather-write mechanism.
    	//	The problem does not occur in this code path, and this will not hinder performance.
    	//	The problem will be fixed in the next Open Transport release following 1.1.2.
    	//
    	//  Note the MAC OS 8.1 docs alude to a bug before 1.3 where acksends
    	//  cause problems if a disconnect flows just right. Unsure if this
    	//  will be an issue
    	//
    	
    	if (gOTVersion < kOTVersion113) {
#if TARGET_API_MAC_CARBON
    		dataPtr = OTAllocMemInContext(sizeof(OTData), gClientContext);
#else
    		dataPtr = OTAllocMem(sizeof(OTData));
#endif
    		if (dataPtr == NULL) { //Death lurks I''m sure
    		    OTAtomicAdd32(-1, &epi->outstandingSends);
                OTFreeMem(buffer);
                return 0;
            }

    		dataPtr->fNext = NULL;
    		dataPtr->fData = buffer;
    		dataPtr->fLen  = size;
    		res = OTSnd(epi->erf, dataPtr, kNetbufDataIsOTData, 0);
    		
    		//Note in the notification routine we cleanup the allocated dataPtr AND buffer.
    	}
    	else
    	{
    		res = OTSnd(epi->erf, buffer, size, 0);
    		
    		//JMM how to handle kENOMEMErr no memory right now error
    		//Book says to back off and wait but must do a timer or something
    		//Right now we''ll fail the primitive higher up since the error code is bad
    	}
    }

	if (res == size) return (SInt32) size;

	if (res >= 0) {
		//
		//	Implied kOTFlowErr since not all data was accepted.
		//  But maybe we aren''t blocked yet so keep sending
		//
		return res;
	} else	{	// res < 0
	
 		OTAtomicAdd32(-1, &epi->outstandingSends);
        OTFreeMem(buffer);
        
	    if ((epi->socketType !!= UDPSocketType) && (gOTVersion < kOTVersion113) )
	       	OTFreeMem(dataPtr); 
	   
		if (res == kOTFlowErr) {
		    //
		    // Flow control back off and wait for T_GODATA
		    //
        	OTAtomicSetBit(&epi->stateFlags, kSendIsBlocked);
			return 0;
		}
		
		if (res == kOTLookErr) {
			res = OTLook(epi->erf);
			if (res == T_ORDREL || res == T_GODATA || res == T_DISCONNECT)
			{
				//	Wait to get the T_ORDREL at the notifier and handle it there.
				//	Then we will resume sending.
				//  Same applies for other events
				//
                //JMM test? 
               	OTAtomicSetBit(&epi->stateFlags, kSendIsBlocked);
				return 0;
			} else 	
		    	return res; 
		} else 
		    return res;
	
	}
}

//
//Set the options
//
int sqSocketSetOptionsoptionNameStartoptionNameSizeoptionValueStartoptionValueSizereturnedValue(SocketPtr s,int optionNameT, int optionNameSize, int optionValueT, int optionValueSize, int *result)	{
    EPInfo*     epi;
    OTResult    error;
    char        optionName[80],optionValue[80];
    SInt32      anInteger;
    
	*result = 0;
	if (!!SocketValid(s)) return -1;
    epi = (EPInfo *) s->privateSocketPtr;

	OTMemcpy(optionName,(char *) optionNameT,optionNameSize);
	optionName[optionNameSize] = 0x00;
	
    OTMemcpy(optionValue,(char *) optionValueT,optionValueSize);
    optionValue[optionValueSize] = 0x00;
    CopyCStringToPascal(optionValue,(unsigned char *) optionValue);
    StringToNum((ConstStr255Param) optionValue,&anInteger);   
    	
   error = lookupOptionName(epi, false, (char *) &optionName, anInteger,(long *) result);
   return error;
}

//
//Get the options
//
int sqSocketGetOptionsoptionNameStartoptionNameSizereturnedValue(SocketPtr s,int optionNameT, int optionNameSize, int *result)	{
    EPInfo*     epi;
    OTResult    error;
    char        optionName[80];
   
	*result = 0;
	if (!!SocketValid(s)) return -1;
    epi = (EPInfo *) s->privateSocketPtr;

	OTMemcpy(optionName,(char *) optionNameT,optionNameSize);  //NEED to fiddle with error number JMM to say readonly notvalid etc.
	optionName[optionNameSize] = 0x00;
	
     	
   error = lookupOptionName(epi, true, (char *) &optionName, NULL,(long *)  result);
   return error;
}


// A Number of routines to set/get options, first figureout the flags, then call the routine
// To set or get the options. 

static SInt32	lookupOptionName(EPInfo *epi, Boolean trueIfGet, char *aString, UInt32 value, SInt32 *result) {
	if (strcmp("TCP_MAXSEG",aString)==0) 				{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_MAXSEG,value,result);};
	if (strcmp("TCP_NODELAY",aString)==0) 				{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_NODELAY,value,result);};
	if (strcmp("TCP_ABORT_THRESHOLD",aString)==0) 		{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_ABORT_THRESHOLD,value,result);};
	if (strcmp("TCP_CONN_NOTIFY_THRESHOLD",aString)==0) {return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_CONN_NOTIFY_THRESHOLD,value,result);};
	if (strcmp("TCP_CONN_ABORT_THRESHOLD",aString)==0) 	{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_CONN_ABORT_THRESHOLD,value,result);};
	if (strcmp("TCP_NOTIFY_THRESHOLD",aString)==0) 		{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_NOTIFY_THRESHOLD,value,result);};
	if (strcmp("TCP_URGENT_PTR_TYPE",aString)==0) 		{return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_URGENT_PTR_TYPE,value,result);};

	if (strcmp("UDP_CHECKSUM",aString)==0) 				{return SetFourByteOption(epi,trueIfGet,INET_UDP,UDP_CHECKSUM,value,result);};

	if (strcmp("SO_DEBUG",aString)==0) 			    	{return SetFourByteOption(epi,trueIfGet,XTI_GENERIC,XTI_DEBUG,value,result);};
	if (strcmp("SO_REUSEADDR",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_REUSEADDR,value,result);;};
	if (strcmp("SO_REUSEPORT",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_REUSEADDR,value,result);};
	if (strcmp("SO_DONTROUTE",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_DONTROUTE,value,result);};
	if (strcmp("SO_BROADCAST",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_BROADCAST,value,result);};
	if (strcmp("SO_SNDBUF",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,XTI_GENERIC,XTI_SNDBUF,value,result);};
	if (strcmp("SO_RCVBUF",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,XTI_GENERIC,XTI_RCVBUF,value,result);};
	if (strcmp("SO_KEEPALIVE",aString)==0) 			   {return SetKeepAliveOption(epi,trueIfGet,INET_TCP,TCP_KEEPALIVE,value,result);};
	if (strcmp("SO_OOBINLINE",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_TCP,TCP_OOBINLINE,value,result);};
	if (strcmp("SO_PRIORITY",aString)==0) 			     {return SetOneByteOption(epi,trueIfGet,INET_IP,IP_TOS,value,result);};
	if (strcmp("SO_LINGER",aString)==0) 			      {return SetLingerOption(epi,trueIfGet,XTI_GENERIC,XTI_LINGER,value,result);};
	if (strcmp("SO_RCVLOWAT",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,XTI_GENERIC,XTI_RCVLOWAT,value,result);};
	if (strcmp("SO_SNDLOWAT",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,XTI_GENERIC,XTI_SNDLOWAT,value,result);};	
	
	if (strcmp("IP_OPTIONS",aString)==0) 			    { }; //JMM What to do here?	
	if (strcmp("IP_TTL",aString)==0) 			         {return SetOneByteOption(epi,trueIfGet,INET_IP,IP_TTL,value,result);};	
	if (strcmp("IP_HDRINCL",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_HDRINCL,value,result);}; //NOT SUPPORT FOR IP	
	if (strcmp("IP_RCVOPTS",aString)==0) 			    {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_RCVOPTS,value,result);};	
	if (strcmp("IP_RCVDSTADDR",aString)==0) 			{return SetFourByteOption(epi,trueIfGet,INET_IP,IP_RCVDSTADDR,value,result);};	
	if (strcmp("IP_MULTICAST_IF",aString)==0) 			{return SetFourByteOption(epi,trueIfGet,INET_IP,IP_MULTICAST_IF,value,result);};	
	if (strcmp("IP_MULTICAST_TTL",aString)==0) 			 {return SetOneByteOption(epi,trueIfGet,INET_IP,IP_MULTICAST_TTL,value,result);};	
	if (strcmp("IP_MULTICAST_LOOP",aString)==0) 	     {return SetOneByteOption(epi,trueIfGet,INET_IP,IP_MULTICAST_LOOP,value,result);};	
/*	if (strcmp("IP_ADD_MEMBERSHIP",aString)==0) 	    { return SetJMMByteOption(epi,trueIfGet,INET_IP,IP_ADD_MEMBERSHIP,value,result);};	
	if (strcmp("IP_DROP_MEMBERSHIP",aString)==0) 	    { return SetJMMByteOption(epi,trueIfGet,INET_IP,IP_DROP_MEMBERSHIP,value,result);};	
	if (strcmp("IP_BROADCAST_IF",aString)==0) 	        {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_BROADCAST_IF,value,result);};	
	if (strcmp("IP_RCVIFADDR",aString)==0) 	            {return SetFourByteOption(epi,trueIfGet,INET_IP,IP_RCVIFADDR,value,result);};	*/

    *result = 0;
    return -1;
}

static OTResult SetFourByteOption(EPInfo* epi,Boolean trueIfGet, OTXTILevel level, OTXTIName  name, UInt32   value, SInt32    *returnValue) {
   OTResult err;
   UInt8    optBuffer[kOTFourByteOptionSize];
   TOption  *option = (TOption *) &optBuffer;
   TOptMgmt request;
   TOptMgmt result;
   Boolean isAsync=false;
   
   /* Set up the option buffer to specify the option and value to set. */
   option->len  = kOTFourByteOptionSize;
   option->level= level;
   option->name = name;
   option->status = 0;
   option->value[0] = value;

   /* Set up request parameter for OTOptionManagement */
   request.opt.buf= (UInt8 *) option;
   request.opt.len= sizeof(optBuffer);
   request.opt.maxlen=sizeof(optBuffer);
   request.flags  = trueIfGet ? T_CURRENT : T_NEGOTIATE;

   /* Set up reply parameter for OTOptionManagement. */
   result.opt.buf  = (UInt8 *) option;
   result.opt.maxlen  = sizeof(optBuffer);
  
    if (OTIsSynchronous(epi->erf) == false)	{	// check whether ep sync or not
		isAsync = true;			                // set flag if async
		OTSetSynchronous(epi->erf);			        // set endpoint to sync	
	}
				
				
    err = OTOptionManagement(epi->erf, &request, &result);
	
	if (isAsync)				        // restore ep state 
		OTSetAsynchronous(epi->erf);
    
	*returnValue = option->value[0];

   if (err == noErr) {
      if (option->status !!= T_SUCCESS) 
         err = option->status;
   } 
            
   return (err);
}

static OTResult SetOneByteOption(EPInfo* epi,Boolean trueIfGet, OTXTILevel level, OTXTIName  name, UInt32   value, SInt32    *returnValue) {
   OTResult err;
   UInt8    optBuffer[kOTFourByteOptionSize];
   TOption  *option = (TOption *) &optBuffer;
   TOptMgmt request;
   TOptMgmt result;
   Boolean isAsync=false;
   
   /* Set up the option buffer to specify the option and value to set. */
   option->len  = kOTOneByteOptionSize;
   option->level= level;
   option->name = name;
   option->status = 0;
   *(unsigned char *)option->value = value;

   /* Set up request parameter for OTOptionManagement */
   request.opt.buf= (UInt8 *) option;
   request.opt.len= kOTOneByteOptionSize;
   request.opt.maxlen=sizeof(optBuffer);
   request.flags  = trueIfGet ? T_CURRENT : T_NEGOTIATE;

   /* Set up reply parameter for OTOptionManagement. */
   result.opt.buf  = (UInt8 *) option;
   result.opt.maxlen  = sizeof(optBuffer);
   
    if (OTIsSynchronous(epi->erf) == false)	{	// check whether ep sync or not
		isAsync = true;			                // set flag if async
		OTSetSynchronous(epi->erf);			        // set endpoint to sync	
	}
				
    err = OTOptionManagement(epi->erf, &request, &result);
	
	if (isAsync)				        // restore ep state 
		OTSetAsynchronous(epi->erf);
    
	*returnValue = (UInt32) (*(unsigned char *)option->value);

   if (err == noErr) {
      if (option->status !!= T_SUCCESS) 
         err = option->status;
   }
            
   return (err);
}

static OTResult SetKeepAliveOption(EPInfo* epi,Boolean trueIfGet, OTXTILevel level, OTXTIName  name, UInt32   value, SInt32    *returnValue) {
   OTResult err;
   TKeepAliveOpt  optBuffer;
   TOption  *option = (TOption *) &optBuffer;
   TOptMgmt request;
   TOptMgmt result;
   Boolean isAsync=false;
   
   
   if (value == 0)
       optBuffer.tcpKeepAliveOn = T_NO;
   else
        optBuffer.tcpKeepAliveOn = T_YES;
        
   optBuffer.tcpKeepAliveTimer = value;
				
   /* Set up the option buffer to specify the option and value to set. */
   option->len  = sizeof(TKeepAliveOpt);
   option->level= level;
   option->name = name;
   option->status = 0;

   /* Set up request parameter for OTOptionManagement */
   request.opt.buf= (UInt8 *) option;
   request.opt.len= sizeof(TKeepAliveOpt);
   request.opt.maxlen=sizeof(TKeepAliveOpt);
   request.flags  = trueIfGet ? T_CURRENT : T_NEGOTIATE;

   /* Set up reply parameter for OTOptionManagement. */
   result.opt.buf  = (UInt8 *) option;
   result.opt.maxlen  = sizeof(TKeepAliveOpt);
   
    if (OTIsSynchronous(epi->erf) == false)	{	// check whether ep sync or not
		isAsync = true;			                // set flag if async
		OTSetSynchronous(epi->erf);			        // set endpoint to sync	
	}
				
    err = OTOptionManagement(epi->erf, &request, &result);
	
	if (isAsync)				        // restore ep state 
		OTSetAsynchronous(epi->erf);
    
	*returnValue = optBuffer.tcpKeepAliveTimer;

   if (err == noErr) {
      if (option->status !!= T_SUCCESS) 
         err = option->status;
   }
            
   return (err);
}
		    

static OTResult SetLingerOption(EPInfo* epi,Boolean trueIfGet, OTXTILevel level, OTXTIName  name, UInt32   value, SInt32    *returnValue) {
   OTResult err;
   TLingerOpt  optBuffer;
   TOption  *option = (TOption *) &optBuffer;
   TOptMgmt request;
   TOptMgmt result;
   Boolean isAsync=false;
   
   
   if (value == 0)
       optBuffer.tcpLingerOn = T_NO;
   else
        optBuffer.tcpLingerOn = T_YES;
        
   optBuffer.tcpLingerTimer = value;
				
   /* Set up the option buffer to specify the option and value to set. */
   option->len  = sizeof(TKeepAliveOpt);
   option->level= level;
   option->name = name;
   option->status = 0;

   /* Set up request parameter for OTOptionManagement */
   request.opt.buf= (UInt8 *) option;
   request.opt.len= sizeof(TKeepAliveOpt);
   request.opt.maxlen=sizeof(TKeepAliveOpt);
   request.flags  = trueIfGet ? T_CURRENT : T_NEGOTIATE;

   /* Set up reply parameter for OTOptionManagement. */
   result.opt.buf  = (UInt8 *) option;
   result.opt.maxlen  = sizeof(TKeepAliveOpt);
   
    if (OTIsSynchronous(epi->erf) == false)	{	// check whether ep sync or not
		isAsync = true;			                // set flag if async
		OTSetSynchronous(epi->erf);			        // set endpoint to sync	
	}
				
    err = OTOptionManagement(epi->erf, &request, &result);
	
	if (isAsync)				        // restore ep state 
		OTSetAsynchronous(epi->erf);
    
	*returnValue = optBuffer.tcpLingerTimer;

   if (err == noErr) {
      if (option->status !!= T_SUCCESS) 
         err = option->status;
   }
            
   return (err);
}


//
//	Notifier:
//
//	Most of the interesting networking code in this program for the resolver resides inside 
//	this notifier.   In order to run asynchronously and as fast as possible,
//	things are done inside the notifier whenever possible.  Since almost
//	everything is done inside the notifier, there was little need for specical
//	synchronization code.
//
//	Note: The only events which are expected from the DNR are T_DNRSTRINGTOADDRCOMPLETE,
//	T_DNRADDRTONAMECOMPLETE, and of close sleep/reconfigure notifications.
//
//

static pascal void DNSNotifier(void* context, OTEventCode event, OTResult result, void* cookie)
{
	EPInfo* epi = (EPInfo*) context;

	JMMLogMessageAndNumber("\p DNS Event  ",event);
	JMMLogMessageAndNumber("\p DNS Result ",result);
	JMMLogMessageAndNumber("\p Id ",epi->semaIndex);
	
	//
	//	Once the program is shutting down, most events would be uninteresting.
	//
	if (gProgramState !!= kProgramRunning)
			return;
		
	//
	//	Within the notifier, all action is based on the event code.
	//	In this notifier, fatal errors all break out of the switch to the bottom.
	//	As long as everything goes as expected, the case returns rather than breaks.
	//
	switch (event)
	{
		//
		//	T_DNRSTRINGTOADDRCOMPLETE:
		//
		//	This event occurs when the DNR has finished an attempt to translate
		//	the server''s name into an IP address we can use to connect to.
		//
		case T_DNRSTRINGTOADDRCOMPLETE:
		{
			gDNSResolverError = result;
			if (result !!= kOTNoError) {
				gDNSResolverStatus = RESOLVER_ERROR;
    			interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
				return;
			}
			gDNSAddr = gDNSHostInfo.addrs[0];
			gDNSResolverStatus = RESOLVER_SUCCESS;
			interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
			return;
		}
		
		//
		//	T_DNRADDRTONAMECOMPLETE:
		//
		//	This event occurs when the DNR has finished an attempt to translate
		//	the  an IP address into a server name.
		//
		case T_DNRADDRTONAMECOMPLETE:
		{
			gDNSResolverError = result;
			if (result !!= kOTNoError) {
				gDNSResolverStatus = RESOLVER_ERROR;
    			interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
				return;
			}
			gDNSResolverStatus = RESOLVER_SUCCESS;
			interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
			return;
		}
				
			
		//
		//	kOTProviderWillClose:
		//
		//	This event occurs when the user changes TCP/IP in the control panel
		//
		case kOTProviderWillClose:
		case kOTProviderIsClosed:
		{
			gDNSResolverError = kOTProviderWillClose;
			interpreterProxy->signalSemaphoreWithIndex(epi->semaIndex);
			ResolverTerminate(); 
			gDNSResolverStatus = RESOLVER_SUCCESS; //Cheat!! Keep Squeak happy later we fix the resolver EP.
			return;
		}

		
		//
		//	default:
		//
		//	There are events which we don''t handle, but we don''t expect to see
		//	any of them.  In the production version of the program, we ignore the event and try to keep running.
		//
		default:
		{
			return;
		}
	}
}



//
//	Notifier for socket: Please note we have another notifier for sockets that do multiple listens
//  And a different notifier for UDP sockets, however the intesting thing is that we can call
/// This routine from othe other as a simple form of inheritence.
//
//	Most of the interesting networking code in this program for socket support resides inside 
//	this notifier.   In order to run asynchronously and as fast as possible,
//	things are done inside the notifier whenever possible.  Since almost
//	everything is done inside the notifier, there was little need for specical
//	synchronization code.
//
//	IMPORTANT NOTE:  Normal events defined by XTI (T_LISTEN, T_CONNECT, etc)
//	and OT completion events (T_OPENCOMPLETE, T_BINDCOMPLETE, etc.) are not
//	reentrant.  That is, whenever our notifier is invoked with such an event,
//	the notifier will not be called again by OT for another normal or completion
//	event until we have returned out of the notifier - even if we make OT calls
//	from inside the notifier.   This is a useful synchronization tool.
//	However, there are two kinds of events which will cause the notifier to 
//	be reentered.   One is T_MEMORYRELEASED, which always happens instantly.
//	The other are state change events like kOTProviderWillClose.
//

static pascal void NotifierSocket(void* context, OTEventCode event, OTResult result, void* cookie)
{
	OSStatus err;
	OTResult epState;
	EPInfo* epi = (EPInfo*) context;
	
	JMMLogMessageAndNumber("\p Event  ",event);
	JMMLogMessageAndNumber("\p Result ",result);
	JMMLogMessageAndNumber("\p Id ",epi->semaIndex);

	//
	//	Once the program is shutting down, most events would be uninteresting.
	//	However, we still need T_OPENCOMPLETE and T_MEMORYRELEASED events since
	//	we can''t call CloseOpenTransport until all OTAsyncOpenEndpoints and
	//	OTSends with AckSends have completed.   So those specific events
	//	are still accepted.
	//
	if (gProgramState !!= kProgramRunning) {
		if ((event !!= T_OPENCOMPLETE) && (event !!= T_MEMORYRELEASED)) {
			return;
		}
	}
	
	
	//
	//	Within the notifier, all action is based on the event code.
	//	In this notifier, fatal errors all break out of the switch to the bottom.
	//	As long as everything goes as expected, the case returns rather than breaks.
	//
	switch (event)
	{
		//
		//	kStreamIoctlEvent:
		//
		//	This event is returned when an I_FLUSH ioctl has completed.
		//	The flush was done in an attempt to get back all T_MEMORYRELEASED events
		//	for outstanding OTSnd() calls with Ack Sends.   For good measure, we
		//	send a disconnect now.   Errors are ignored at this point since it is
		//	possible that the connection will already be gone, etc.
		//
		case kStreamIoctlEvent:
		{
			if (OTAtomicTestBit(&epi->stateFlags, kOpenInProgressBit) !!= 0) {
			    OTAtomicClearBit(&epi->stateFlags2, kFlushDisconnectInProgressBit);
				(void) OTSndDisconnect(epi->erf, NULL);
			}
			return;
		}
		//
		//	T_ACCEPTCOMPLETE:
		//
		//	This event is received by the listener endpoint only when we open a port with a listen.   
		//	The acceptor endpoint will get a T_PASSCON event instead.
		//
		case T_ACCEPTCOMPLETE:
		{
            SetEPLastError(epi,result);
			if (result !!= kOTNoError) {
				makeEPUnconnected(epi);
        		return;
            }
            makeEPConnected(epi);
			return;
		}
		//
		//	T_BINDCOMPLETE:
		//
		//	This event is returned when an endpoint has been bound to a wildcard addr.
		//  Bind happens when we open a connection to a remote location.
		//	No errors are expected.   
		//
		case T_BINDCOMPLETE:
		{
            SetEPLastError(epi,result);
			OTAtomicClearBit(&epi->stateFlags3, kWaitingForBind);
			if (result !!= kOTNoError) {
            	makeEPUnconnected(epi);
				return;
			}
			if (epi->remoteAddress.fHost !!= 0) 
			    DoConnect(epi,epi->remoteAddress.fHost, epi->remoteAddress.fPort);
			return;
		}
		
		//
		//	T_CONNECT:
		//
		//	This event is returned when a connection is established to the server.
		//	The program must call OTRcvConnect() to get the conenction information
		//	and clear the T_CONNECT event from the stream.  Since OTRcvConnect()
		//	returns immediately (rather than via a completion event to the notifier)
		//	we can use local stack structures for parameters.
		//
		case T_CONNECT:
		{
			TCall call;
						
            SetEPLastError(epi,result);
			if (result !!= kOTNoError) {
				makeEPUnconnected(epi);
  				return;
			}
			
			// Address of endpoint that has connection
			// This could be different from original request
			// Due to hand off to different EP say you connect to 
			// port 80, but you end up on 49160
			
			call.addr.maxlen = sizeof(InetAddress);
			call.addr.buf = (unsigned char*) &epi->remoteAddress;  
			call.opt.maxlen = 0;
			call.opt.buf = NULL;
			call.udata.maxlen = 0;
			call.udata.buf = NULL;
			
			err = OTRcvConnect(epi->erf, &call);
			SetEPLastError(epi,err);

			if (err !!= kOTNoError) {
			    if (err == kOTLookErr) {
			        OSStatus	lookStatus;
			        lookStatus = OTLook(epi->erf);
			        if (lookStatus == T_DISCONNECT) {
               			err = OTRcvDisconnect(epi->erf, NULL);
        	    		if (err !!= kOTNoError) {
        		    		if (err == kOTNoDisconnectErr) {
                    			err = OTRcvConnect(epi->erf, &call);
                    			SetEPLastError(epi,err);
                       			makeEPUnconnected(epi);
       		    		        return;
       		    		    }
			            } else {
                			err = OTRcvConnect(epi->erf, &call);
                			SetEPLastError(epi,err);
                   			makeEPUnconnected(epi);
   		    		        return;
			            }
			        }
			        if (lookStatus == T_GODATA) { // HUH
            			err = OTRcvConnect(epi->erf, &call);
            			SetEPLastError(epi,err);
               			makeEPConnected(epi);
	    		        return;
			        }
			    }
                //JMM book says may return kOTNoDataErr (no connecton yet) or a kOTLookErr with T_DISCONNECT
                // BUT we had got T_GODATA WHY? 
                
				makeEPUnconnected(epi);
				return;
			}
			
			makeEPConnected(epi);
			return;				// Wait for a T_DATA...
		}
		
		//
		//	T_LISTEN:
		//
		case T_LISTEN:
		{
			DoListenAccept(epi,epi);
			return;
		}

		//
		//	T_DATA:
		//
		//	The main rule for processing T_DATA''s is to remember that once you have
		//	a T_DATA, you won''t get another one until you have read to a kOTNoDataErr.
		//	The advanced rule is to remember that you could get another T_DATA
		//	during an OTRcv() which will eventually return kOTNoDataErr, presenting
		//	the application with a synchronization issue to be most careful about.
		//	
		//	In this application, since an OTRcv() calls are made from inside the notifier,
		//	this particular synchronization issue doesn''t become a problem.
		//
		case T_DATA:
		{
			if (!!OTAtomicTestBit(&epi->stateFlags2, kPassconNeeded)) {
			    ReadData(epi,NULL,0);
			    return;
			 }
			 else {
    			//
    			//	Here we work around a small OpenTransport bug.
    			//	It turns out, since this program does almost everything from inside the notifier,
    			//	that during a T_UNBINDCOMPLETE we can put an EPInfo back into the idle list.
    			//	If that notification is interrupted by a T_LISTEN at the notifier, we could
    			//	end up starting a new connection on the endpoint before OT unwinds the stack
    			//	out of the code which delivered the T_UNBINDCOMPLETE.   OT has some specific
    			//	code to protect against a T_DATA arriving before the T_PASSCON, but in this
    			//	case it gets confused and the events arrive out of order.   If we try to
    			//	do an OTRcv() at this point we will get a kOTStateChangeErr because the endpoint
    			//	is still locked by the earlier OTAccept call until the T_PASSCON is delivered
    			//	to us.   This is fairly benign and can be worked around easily.  What we do
    			//	is note that the T_PASSCON hasn''t arrived yet and defer the call to ReadData()
    			//	until it does.
    			//
    			if ( OTAtomicSetBit(&epi->stateFlags, kPassconBit) !!= 0 )
    			{
    			    ReadData(epi,NULL,0);
    			    return;
    			}
    		}
		}					

		//
		//	T_PASSCON:
		//
		//	This event happens on the accepting endpoint, not the listening endpoint.
		//	At this point the connection is fully established and we can begin the
		//	process of downloading data.  Note that due to a problem in OT it is 
		//	possible for a T_DATA to beat a T_PASSCON to the notifier.  When this
		//	happens we note it in the T_DATA case and then start processing the 
		//	data here.  
		//
		case T_PASSCON:
		{
            SetEPLastError(epi,result);
			if (result !!= kOTNoError) {
               	OTAtomicSetBit(&epi->stateFlags, kPassconBit);
   				makeEPUnconnected(epi);
				return;
			}
			
   			makeEPConnected(epi);
                
		    if ( OTAtomicSetBit(&epi->stateFlags, kPassconBit) !!= 0 ){
				//
				//	A T_DATA previously beat the T_PASSCON to our notifier.
				//	Here we help OT out by having deferred data processing until now.
				//
			    ReadData(epi,NULL,0);
			}
			return;
		}
		//
		// T_MEMORYRELEASED
		// lower level has finished with buffer
				
		case T_MEMORYRELEASED:
		{
		    if (cookie == nil) return;
			OTAtomicAdd32(-1, &epi->outstandingSends);
			
	    	if (epi->socketType == UDPSocketType) {
		        OTFreeMem(cookie);
	    	} else {//tcp
		    	if (gOTVersion < kOTVersion113) {
		    		struct OTData *data=cookie;

		    		OTFreeMem(data->fData);
		    		OTFreeMem(data);
		    	} else {
		        	OTFreeMem(cookie);
		        }
	        }
	        	
		    return;
		}
			
		//
		//	T_DISCONNECT:
		//
		//	An inbound T_DISCONNECT event usually indicates that the other side of the
		//	connection did an abortive disconnect (as opposed to an orderly release).
		//	It also can be generated by the transport provider on the system (e.g. tcp)
		//	when it decides that a connection is no longer in existance.
		//
		//	We receive the disconnect, but this program ignores the associated reason (NULL param).
		//	It is possible to get back a kOTNoDisconnectErr from the OTRcvDisconnect call.
		//	This can happen when either (1) the disconnect on the stream is hidden by a 
		//	higher priority message, or (2) something has flushed or reset the disconnect
		//	event in the meantime.   This is not fatal, and the appropriate thing to do is
		//	to pretend the T_DISCONNECT event never happened.   Any other error is unexpected
		//	and needs to be reported so we can fix it.  Next, unbind the endpoint so we can
		//	reuse it for a new inbound connection.
		//	
		//	It is possible to get an error on the unbind due to a bug in OT 1.1.1 and earlier.
		//	The best thing to do for that is close the endpoint and open a new one to replace it.
		//	We do this back in the main thread so we don''t have to deal with synchronization problems.
		//
		case T_DISCONNECT:
		{
			epState = OTGetEndpointState(epi->erf);
			err = OTRcvDisconnect(epi->erf, NULL);
			
			if (epState == T_OUTCON) { //01Aug2000 fix for bad port, will get disconnect on outgoing connection
                makeEPUnconnected(epi);
			}
			if (err !!= kOTNoError) {
				if (err == kOTNoDisconnectErr) return;
			    makeEPBroken(epi,err);
				return;
			}
			
                ///
                //Both sides now have closed 
                //
            
            OTAtomicSetBit(&epi->stateFlags, kUnConnected);			
	        OTAtomicClearBit(&epi->stateFlags, kConnected);
            OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);			
            OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);			
			err = OTUnbind(epi->erf);
    	    TapAllInterestedSemaphores(epi);
			if (err !!= kOTNoError) {
			    makeEPBroken(epi,err);
			}
			return;
		}
		
		//
		//	T_GODATA:
		//
		//	This event is received when flow control is lifted.   We are under flow control
		//	whenever OTSnd() returns a kOTFlowErr or accepted less bytes than we attempted
		//	to send.  
		//
		//	Note, it is also possible to get a T_GODATA without having invoke flow control.
		//	Be safe and prepare for this. 
		//
		case T_GODATA:
		{
            if (OTAtomicClearBit(&epi->stateFlags, kSendIsBlocked)) {
 	           if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphoreWriteData))
  	              interpreterProxy->signalSemaphoreWithIndex(epi->writeSemaIndex);
            };
			return;
		}

		
		//
		//	T_OPENCOMPLETE:
		//
		//	This event occurs when an OTAsyncOpenEndpoint() completes.   Note that this event,
		//	just like any other async call made from outside the notifier, can occur during
		//	the call to OTAsyncOpenEndpoint().  That is, in the main thread the program did
		//	the OTAsyncOpenEndpoint(), and the notifier is invoked before control is returned
		//	to the line of code following the call to OTAsyncOpenEndpoint().   This is one
		//	event we need to keep track of even if we are shutting down the program since there
		//	is no way to cancel outstanding OTAsyncOpenEndpoint() calls.
		//
		case T_OPENCOMPLETE:
		{
			TOptMgmt 			optReq;
			TOption             opt;

			OTAtomicClearBit(&epi->stateFlags, kOpenInProgressBit);
			if (result == kOTNoError)
				epi->erf = (EndpointRef) cookie;
			else {
				makeEPBrokenThenIdle(epi,result);
				return;
			}

			if (gProgramState !!= kProgramRunning) return;
			
				
			//
			//	Set to blocking mode so we don''t have to deal with kEAGAIN errors.
			//	Async/blocking is the best mode to write an OpenTransport application in.
			//
			err = OTSetBlocking(epi->erf);
			if (err !!= kOTNoError) {
			    makeEPBrokenThenIdle(epi,err);
				return;
			}
			
			//
			//	Set to AckSends so OT doesn''t slow down to copy data sent out.
			//	However, this requires special care when closing endpoints, so don''t use
			//	AckSends unless you are prepared for this.   Never, ever, close an endpoint
			//	when a send has been done but the T_MEMORYRELEASED event hasn''t been returned yet.
			//
			err = OTAckSends(epi->erf);
			if (err !!= kOTNoError) {
			    makeEPBrokenThenIdle(epi,err);
				return;
			}
			
			//
			//	Option Management
			//
			//	Turn on ip_reuseaddr so we don''t have port conflicts in general.
			//	We use local stack structures here since the memory for the 
			//	option request structure is free upon return.   If we were to request
			//	the option return value, we would have to use static memory for it.
			//
			optReq.flags			= T_NEGOTIATE;
			optReq.opt.len			= kOTFourByteOptionSize;
			optReq.opt.buf			= (unsigned char *) &opt;
			
			opt.len					= sizeof(TOption);
			opt.level				= INET_IP;
			opt.name				= IP_REUSEADDR;
			opt.status				= 0;
			opt.value[0]			= 1;
			
            if (epi->socketType == TCPSocketType) 
                OTAtomicSetBit(&epi->stateFlags3, kKeepAliveOptionNeeded);
                
			err = OTOptionManagement(epi->erf, &optReq, NULL);
			if (err !!= kOTNoError) {
			    makeEPBrokenThenIdle(epi,err);
			}
			
			//
			//	Code path resumes at T_OPTMGMTCOMPLETE
			//
			
			return;
		}
		
		//
		//	T_OPTMGMTCOMPLETE:
		//
		//	An OTOptionManagement() call has completed.  These are used on all
		//	endpoints to set IP_REUSEADDR.   It is also used for all endpoints
		//	other than the listener to set TCP_KEEPALIVE which helps recover
		//	server resources if the other side crashes or is unreachable.
		//
		case T_OPTMGMTCOMPLETE:
		{
			TOptMgmt 			optReq;

			if (result !!= kOTNoError) {
			    makeEPBrokenThenIdle(epi,result);
				return;
			}
			
            if (OTAtomicClearBit(&epi->stateFlags3, kKeepAliveOptionNeeded)) {
                
                TKeepAliveOpt		opt;
				//
				//	Turn on TCP_KEEPALIVE so we can recover from connections which have
				//	gone away which we don''t know about.  
				//
				optReq.flags			= T_NEGOTIATE;
				optReq.opt.len			= sizeof(TKeepAliveOpt);
				optReq.opt.buf			= (unsigned char *) &opt;
				
				opt.len					= sizeof(TKeepAliveOpt);
				opt.level				= INET_TCP;
				opt.name				= TCP_KEEPALIVE;
				opt.status				= 0;
				opt.tcpKeepAliveOn		= 1;
				opt.tcpKeepAliveTimer	= kTCPKeepAliveInMinutes;	
				
				err = OTOptionManagement(epi->erf, &optReq, NULL);
				if (err !!= kOTNoError) {
    			    makeEPBrokenThenIdle(epi,result);
                }
                return;
            }
						
            makeEPIdle(epi);  //This is where more EP enter the queue of available EPs.
            
			return;			// now wait 
		}
		//
		//	T_ORDREL:
		//
		//	This event occurs when an orderly release has been received on the stream.
		//
		case T_ORDREL:
		{
			err = OTRcvOrderlyDisconnect(epi->erf);
			
			if (err !!= kOTNoError) {
				//
				//	It is possible for several reasons for the T_ORDREL to have disappeared,
				//	or be temporarily hidden, when we attempt the OTRcvOrderlyDisconnect().
				//	The best thing to do when this happens is pretend that the event never
				//	occured.   We will get another notification of T_ORDREL if the event
				//	becomes unhidden later.  Any other form of error is unexpected and 
				//	is reported back so we can correct it.
				//
				if (err == kOTNoReleaseErr)
					return;
				//Can get OTLookErr with T_DISCONNECT
    		   makeEPBroken(epi,err);
			}	

			if (OTAtomicTestBit(&epi->stateFlags, kThisEndClosed)) {
                
                ///
                //Both sides now have closed
                //
                
                OTAtomicSetBit(&epi->stateFlags, kUnConnected);			
    	        OTAtomicClearBit(&epi->stateFlags, kConnected);
                OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);			
                OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);			
				
				epState = OTGetEndpointState(epi->erf);
				if (epState !!= T_IDLE) {
            	    TapAllInterestedSemaphores(epi);
				    return;
				}

				err = OTUnbind(epi->erf);
        	    TapAllInterestedSemaphores(epi);
				if (err !!= kOTNoError) {
				    makeEPBroken(epi,err);
				}
				
    		    return;
            } else {
    			OTAtomicSetBit(&epi->stateFlags, kOtherEndClosed);
			}
			
			//
			//	Sometimes our data sends get stopped with a kOTLookErr
			//	because of a T_ORDREL from the other side (which doesn''t close
			//	the connection, it just means they are done sending data).
			//	If so, we still end up in the notifier with the T_ORDREL event,
			//	but we won''t resume sending data unless we explictly check
			//	here whether or not we need to do so.
			//
             //JMM Test this? 

            if (OTAtomicClearBit(&epi->stateFlags, kSendIsBlocked)) {
  		    	if (OTAtomicClearBit(&epi->stateFlags2, kTapSemaphoreWriteData))
                	interpreterProxy->signalSemaphoreWithIndex(epi->writeSemaIndex);
            };

			return;
		}
		
		//
		//	T_UNBINDCOMPLETE:
		//
		//	This event occurs on completion of an OTUnbind().
		//	The endpoint is ready for reuse on a new inbound connection.
		//	Note that the OTLIFO structure has atomic queue and dequeue,
		//	which can be helpful for synchronization protection.  
		//
		case T_UNBINDCOMPLETE:
		{
			if (result !!= kOTNoError) {
				//
				//	Unbind errors can occur as a result of a bug in OT 1.1.1 and earlier
				//	versions.   The best recovery is to put the endpoint in the broken
				//	list for recycling with a clean, new endpoint.
				//  Since we only support 1.1.2 we don''t expect to run this code.
				//
			    makeEPBroken(epi,result);
				return;
			}
			return;
		}
		
		
		//
		//	T_DISCONNECTCOMPLETE:
		//
		//	This event occurs on completion of an OTSndDisconnect().
		//	Called when we abort a socket
		//
		case T_DISCONNECTCOMPLETE: {
			err = OTUnbind(epi->erf);
			if (err !!= kOTNoError) {
			    makeEPBroken(epi,err);
			}

			purgeReadBuffers(epi);		
            TapAllInterestedSemaphores(epi); 
			if (OTAtomicTestBit(&epi->stateFlags2, kMakeEPIdle)) { //Make EP idle if marked as such only happens via destroy. 
			    makeEPIdle(epi);
			}
			epi->stateFlags = 0;
			epi->stateFlags2 = 0;
			epi->stateFlags3 = 0;
            SetEPLastError(epi,result);
        	OTAtomicSetBit(&epi->stateFlags, kUnConnected);
			return;
		}
		
		//
		//Sleep sleep sleep all end points get trashed.
		//
		case kOTProviderWillClose: // reconfig stack disconnect and close
		{
		    makeEPBroken(epi,-12345678);
            if(OTAtomicTestBit(&epi->stateFlags, kOpenInProgressBit)) return;
            OTSetSynchronous(epi->erf);			        // set endpoint to sync	
        	if ( OTAtomicSetBit(&epi->stateFlags2, kFlushDisconnectInProgressBit) == 0 )
        		err = OTIoctl(epi->erf, I_FLUSH, (void *)FLUSHRW);
            OTSndDisconnect(epi->erf, NULL);
            OTUnbind(epi->erf);
            OTCloseProvider(epi->erf);
            OTAtomicSetBit(&epi->stateFlags, kUnConnected);			
	        OTAtomicClearBit(&epi->stateFlags, kConnected);
            OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);			
            OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);			
            OTAtomicSetBit(&epi->stateFlags3, kSleepKilledMe);
            TapAllInterestedSemaphores(epi); 
		    return;
		}

		case kOTProviderIsClosed: //Sleep lurks
		{
		    makeEPBroken(epi,-12345678);
            OTSetSynchronous(epi->erf);			        // set endpoint to sync	
        	if ( OTAtomicSetBit(&epi->stateFlags2, kFlushDisconnectInProgressBit) == 0 )
        		err = OTIoctl(epi->erf, I_FLUSH, (void *)FLUSHRW);
            OTCloseProvider(epi->erf);
            OTAtomicSetBit(&epi->stateFlags, kUnConnected);			
	        OTAtomicClearBit(&epi->stateFlags, kConnected);
            OTAtomicClearBit(&epi->stateFlags, kThisEndClosed);			
            OTAtomicClearBit(&epi->stateFlags, kOtherEndClosed);			
            OTAtomicSetBit(&epi->stateFlags3, kSleepKilledMe);
            TapAllInterestedSemaphores(epi); 
			return;
		}

		//
		//	default:
		//
		//	There are events which we don''t handle, but we don''t expect to see
		//	any of them.   When running in debugging mode while developing a program,
		//	we exit with an informational alert.   Later, in the production version
		//	of the program, we ignore the event and try to keep running.
		//
		default:
		{
			return;
		}
	}
}


//
//	Notifier for listen socket:
//


static pascal void NotifierSocketListener(void* context, OTEventCode event, OTResult result, void* cookie)
{
	EPInfo* epi = (EPInfo*) context;

	if (gProgramState !!= kProgramRunning)
	{
		if ((event !!= T_OPENCOMPLETE) && (event !!= T_MEMORYRELEASED))
		{
			return;
		}
	}
	JMMLogMessageAndNumber("\p Listener Event  ",event);
	JMMLogMessageAndNumber("\p Listener Result ",result);
	JMMLogMessageAndNumber("\p Listener Id ",epi->semaIndex);
	
	switch (event)
	{
		//
		//	T_BINDCOMPLETE:
		//
		//	We only bind the listener endpoint, and bind failure is a fatal error.  
		//	Acceptor endpoints are bound within the OTAccept() call when they get a connection.
		//
		case T_BINDCOMPLETE:
		{
            SetEPLastError(epi,result);
			OTAtomicClearBit(&epi->stateFlags3, kWaitingForBind);
			if (result !!= kOTNoError)
   				makeEPUnconnected(epi);
      
			return;
		}
				
		//
		//	T_LISTEN:
		//
		case T_LISTEN:
		{
            SetEPLastError(epi,result);
   			makeEPConnected(epi);
			return;
		}
		//
		//	T_ACCEPTCOMPLETE:
		//
		//	This event is received by the listener endpoint only.   
		//	The acceptor endpoint will get a T_PASSCON event instead.
		//
		case T_ACCEPTCOMPLETE:
		{
            SetEPLastError(epi,result);
			return;
		}

		
		//
		//	default:
		//
		//	There are events which we don''t handle, pass them onwards
		//
		default:
		{
            NotifierSocket(context,  event,  result, cookie);
			return;
		}
	}
}


//
//	Notifier for UDP listen socket:
//


static pascal void NotifierSocketUDP(void* context, OTEventCode event, OTResult result, void* cookie)
{
	EPInfo* epi = (EPInfo*) context;
	OSStatus err;

	JMMLogMessageAndNumber("\p DNS Event  ",event);
	JMMLogMessageAndNumber("\p DNS Result ",result);
	JMMLogMessageAndNumber("\p Id ",epi->semaIndex);

	if (gProgramState !!= kProgramRunning) {
		if ((event !!= T_OPENCOMPLETE) && (event !!= T_MEMORYRELEASED)) {
			return;
		}
	}
		
	switch (event)
	{
		//Some sort of UDP send error, too late to tell anyone?
		//
		case T_UDERR: {  
    		TUDErr 		uderr;
		    InetAddress errorAddress;
            
            uderr.addr.maxlen   = sizeof(InetAddress);
            uderr.addr.len      = sizeof(InetAddress);
            uderr.addr.buf      = (UInt8 *) &errorAddress;
            uderr.opt.maxlen    = 0;
            uderr.opt.len       = 0;
            uderr.opt.buf       = NULL;
   
		    err =  OTRcvUDErr(epi->erf, &uderr);
            if (err !!= kOTNoError)   
				makeEPBroken(epi,err);
			
            SetEPLastError(epi,uderr.error);
		    return;
		}
		
		//
		//	T_DATA:
		//
		//  Got milk?
		//
		
		case T_DATA: {
			ReadData(epi,NULL,0);
		    return;
		}
		
		//
		//	T_BINDCOMPLETE:
		//
		//	This event is returned when an endpoint has been bound.
		//	No errors are expected.   
		//
		
		case T_BINDCOMPLETE:
		{
            SetEPLastError(epi,result);
			OTAtomicClearBit(&epi->stateFlags3, kWaitingForBind);
			if (result !!= kOTNoError) {
   				makeEPUnconnected(epi);
				return;
			}
   			makeEPConnected(epi);
			return;
		}

		//
		//	default:
		//
		//	There are events which we don''t handle, pass them onwards to the regular notifier
		//
		
		default:
		{
            NotifierSocket(context,  event,  result, cookie);
			return;
		}
    }
}


short	        gJMMFile=0;
OTTimeStamp 	JMMStartTimeStamp;
OTLIFO			JMMLogBufferLIFO;    	//  Buffers that are free to read into
OTLIFO*			JMMLogBufferBuffers			= &JMMLogBufferLIFO;

 
void JMMWriteLog() {
	OSErr			error;
	OTLink* 	    list = OTReverseList(OTLIFOStealList(JMMLogBufferBuffers));
	OTLink*		    link;
	ReadBuffer      *aBuffer;
	long           dummySize;
	char			CH=0x0D;

	if (true) return;
	
	error = HCreate(0,0,"\pJMMFOOBAR.txt",''TEXT'',''TEXT'');
	error = HOpenDF(0,0,"\pJMMFOOBAR.txt",fsRdWrPerm,&gJMMFile);
	error = SetFPos(gJMMFile,fsFromLEOF,0);

	while ( (link = list) !!= NULL ) {
		list = link->fNext;
    	aBuffer = OTGetLinkObject(link, ReadBuffer, fNext);
    	error = FSWrite(gJMMFile,(long *)&aBuffer->readBufferSize,aBuffer->readBufferData);
    	dummySize = 1;
    	error = FSWrite(gJMMFile,&dummySize,&CH);
	}
	error = FSClose(gJMMFile);
	
	while ( (link = list) !!= NULL ) {
		list = link->fNext;
    	aBuffer = OTGetLinkObject(link, ReadBuffer, fNext);
        OTFreeMem(aBuffer->readBufferData);
        OTFreeMem(aBuffer); 
	}
	
}

void JMMLogMessage(Str255 input) {
	Str255 			timeString;
	long 			timeStringLength,inputLength;
	UInt32			duration;
	ReadBuffer      *readBufferObject;
	
	if (true) return;
	
	if (gJMMFile == 0) {
		gJMMFile = 1;
		OTGetTimeStamp(&JMMStartTimeStamp);
		JMMLogBufferBuffers->fHead 		= NULL;

	}
	
	duration = OTElapsedMilliseconds(&JMMStartTimeStamp);
	NumToString(duration,timeString);
	timeStringLength = (unsigned char) timeString[0];
	inputLength = (unsigned char) input[0];
	
#if TARGET_API_MAC_CARBON
	readBufferObject = OTAllocMemInContext(sizeof(ReadBuffer), gClientContext);
#else
	readBufferObject = OTAllocMem(sizeof(ReadBuffer));
#endif
	if (readBufferObject == NULL) return;
	OTMemzero(readBufferObject,sizeof(ReadBuffer));
	
#if TARGET_API_MAC_CARBON
	readBufferObject->readBufferData = OTAllocMemInContext(60, gClientContext);
#else
	readBufferObject->readBufferData = OTAllocMem(60);
#endif
	if (readBufferObject->readBufferData == NULL) {
	    OTFreeMem(readBufferObject);
	    return;
	}
	
	OTMemcpy(readBufferObject->readBufferData,timeString+1,timeStringLength);
	OTMemcpy(readBufferObject->readBufferData+timeStringLength,input+1,inputLength);
	readBufferObject->readBufferSize= timeStringLength+inputLength;
    OTLIFOEnqueue(JMMLogBufferBuffers, &readBufferObject->fNext);
	
}

void JMMLogMessageAndNumber(Str255 msg,long number) {
	Str255 buffer,numberString;
	long msgLength,numberLength;
	
	if (true) return;
	
	NumToString(number,numberString);
	numberLength = (unsigned char) numberString[0];
	msgLength = (unsigned char) msg[0];
	
	OTMemcpy(buffer+1,msg+1,msgLength);
	OTMemcpy(buffer+1+msgLength,numberString+1,numberLength);
	buffer[0] = (unsigned char) msgLength+numberLength;
	JMMLogMessage(buffer);

}


/*
The Open Transport TCP/IP software modules provide a RawIP interface to the IP protocol

hostname of '''' lookup fails This is OK? Same on linux and old mac version

JMM look at tlook page, not sure if we have completely understood it

JMM is it legal to send a zero byte buffer need case for this?

/* According to the XTI spec ("Section 4.6 Events and TLOOK Error indication"), 
the SndOrderlyDisconnect and RcvOrderlyDisconnect calls can fail because of a pending T_DISCONNECT event. 
This is XTI trying to tell you that the a connection on that endpoint broke. This can happen in this asynchronous 
wacky world of networks and your program will have to call a RcvDisconnect to acknowledge that your endpoint dropped.

You might want to check out the OTI spec, which, although it is not always written in the most lucid fashion, 
does contain valuable information for those involved in OpenTransport programming.

Further Information:
Title: X/OPEN TRANSPORT INTERFACE (XTI) VER 2 [ 1.0 ed]
Author: X/OPEN 
ISBN #: 0133534596

A Prior to Open Transport 1.3, there was no supported way of calling Open Transport from CFM-68K code. 
With the introduction of Open Transport 1.3, it is now possible to call the Open Transport client 
interface from CFM-68K code. The Open Transport 1.3 SDK includes stub libraries and a document, 
"Open Tpt CFM68K Dev. Note", which explains Open Transport''s support for CFM-68K. which is supporte for 
syste 7.x but you can''t install!! No standalone installer exists. Coping the OT files kinda works
*/
#else
/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */

#include "sq.h"
#include "SocketPlugin.h"

/* initialize/shutdown */
int socketInit() { return true; }
int socketShutdown() { sqNetworkShutdown(); }

/* End of adjustments for pluginized VM */

#include <Events.h>
#include <Devices.h>
#include <Processes.h>
#include <Traps.h>

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include "MacTCP.h"
#include "AddressXLation.h"

/*** Socket Type Constants ***/
#define TCPSocketType 		0
#define UDPSocketType 		1
#define ListenerQueueType	2

/*** Resolver Status Constants ***/
#define RESOLVER_UNINITIALIZED	0
#define RESOLVER_SUCCESS		1
#define RESOLVER_BUSY			2
#define RESOLVER_ERROR			3

/* Resolver State */
typedef struct {
	int				semaIndex;
	int				status;
	int				error;
	int				localAddress;
	int				remoteAddress;
	struct hostInfo	hostInfo;
} ResolverStatusRec, *ResolverStatusPtr;

/*** TCP Socket Status Constants ***/
#define Unconnected				0
#define WaitingForConnection	1
#define Connected				2
#define OtherEndClosed			3
#define ThisEndClosed			4

/*** TCP Socket State ***/
#define SendBufferSize	(8 * 1024)
#define RecvBufferSize	(8 * 1024)
typedef struct {
	TCPiopb		tcpPB;				/* TCP parameter block for open/send (must be first) */
	TCPiopb		closePB;			/* TCP parameter block for close */
	StreamPtr	tcpStream;			/* TCP stream */
	void *		next;				/* next socket in a linked list of open sockets */
	int			semaIndex;
	int			connectStatus;
	void *		nextInListenerQueue; /* next socket in a ListenderQueue waiting socket list */
	int			dataAvailable;		/* suggests that data may be available */
	int			sendInProgress;
	int			lastError;
//xxx	char		sendBuf[SendBufferSize];
	char		rcvBuf[1];			/* must be last; length set when allocated */
} TCPSockRec, *TCPSockPtr;

typedef struct {
	TCPiopb		tcpPB;
	TCPSockPtr	mySocket;
	struct wdsEntry wds[2];
	char		data[SendBufferSize];
} TCPSendBuf, *TCPSendBufPtr;

#define SendBufCount 8
TCPSendBuf sendBufPool[SendBufCount];
int nextSendBuf = 0;

typedef struct {
	int			localAddress;
	int			localPort;
	int			closed;				/* set true by close or abort */
	int			semaIndex;			/* semaphore of the server socket */
	int			desiredQueueLength;
	TCPSockPtr	waitingSockets;
} ListenerQueueRec, *ListenerQueuePtr;

/*** UDP Socket Status Constants ***/
#define UnknowRemoteAddrAndPort	0
#define Ready					1

/*** UDP Socket State ***/
typedef struct {
	void *		next;				/* next socket in a linked list of open sockets */
	int			remoteAddress;
	int			remotePort;
	int			semaIndex;
	int			connectStatus;
	int			dataAvailable;		/* suggests that data may be available */
	int			sendInProgress;
	int			lastError;
	char		sendBuf[SendBufferSize];
	char		rcvBuf[1];			/* must be last; length set when allocated */
} UDPSockRec, *UDPSockPtr;

/*** Variables ***/
extern struct VirtualMachine *interpreterProxy;

short				macTCPRefNum = 0;
int					mtuSize = 1024;
TCPSockPtr 			openTCPSockets = nil;
UDPSockPtr			openUDPSockets = nil;
ResolverStatusRec 	resolver = {0, 0, 0, 0, 0, 0, 0};

UniversalProcPtr	myExitHandlerProc = nil;
UniversalProcPtr	oldExitHandlerProc = nil;
ResultUPP			resolverDoneProc = nil;
TCPIOCompletionUPP	tcpCloseDoneProc = nil;
TCPIOCompletionUPP	tcpConnectDoneProc = nil;
TCPNotifyUPP		tcpNotifyProc = nil;
TCPIOCompletionUPP	tcpSendDoneProc = nil;
UDPNotifyUPP		udpNotifyProc = nil;
UDPIOCompletionUPP	udpSendDoneProc = nil;

int					thisNetSession = 0;

/*** Private TCP Socket Functions ***/
void *		TCPSockCreate(void);
void		TCPSockDestroy(TCPSockPtr s);
void		TCPSockRemoveFromOpenList(TCPSockPtr s);

int			TCPSockLocalAddress(TCPSockPtr s);
int			TCPSockLocalPort(TCPSockPtr s);
int			TCPSockRemoteAddress(TCPSockPtr s);
int			TCPSockRemotePort(TCPSockPtr s);

void		TCPSockConnectTo(TCPSockPtr s, int addr, int port);
void		TCPSockListenOn(TCPSockPtr s, int port);
void		TCPSockAbortConnection(TCPSockPtr s);
void		TCPSockCloseConnection(TCPSockPtr s);

int			TCPSockDataAvailable(TCPSockPtr s);
int			TCPSockRecvData(TCPSockPtr s, char *buf, int bufSize);
int			TCPSockSendData(TCPSockPtr s, char *buf, int bufSize);

/*** Private ListenerQueue Socket Functions ***/
void		FillListenerQueue(ListenerQueuePtr listener);
TCPSockPtr	FindConnectedSocket(ListenerQueuePtr listener);
TCPSockPtr	FindZombieSocket(ListenerQueuePtr listener);
void		RemoveSocketFromListenerQueue(TCPSockPtr sockToRemove, ListenerQueuePtr listener);
ListenerQueuePtr ListenerQueueCreate(TCPSockPtr tcpSocket, int port, int backlogSize);
void		ListenerQueueDestroy(ListenerQueuePtr listener);
int			ListenerQueueStatus(ListenerQueuePtr listener);

/*** Private UDP Socket Functions ***/
void *		UDPSockCreate(void);
void		UDPSockDestroy(UDPSockPtr s);
void		UDPSockRemoveFromOpenList(UDPSockPtr s);

int			UDPSockLocalAddress(UDPSockPtr s);
int			UDPSockLocalPort(UDPSockPtr s);
int			UDPSockRemoteAddress(UDPSockPtr s);
int			UDPSockRemotePort(UDPSockPtr s);

void		UDPSockConnectTo(UDPSockPtr s, int addr, int port);
void		UDPSockListenOn(UDPSockPtr s, int port);

int			UDPSockRecvData(UDPSockPtr s, char *buf, int bufSize);
int			UDPSockSendData(UDPSockPtr s, char *buf, int bufSize);

/*** Other Private Functions ***/
void		DestroyAllOpenSockets(void);
void		InitTCPCmd(int cmd, StreamPtr tcpStream, TCPiopb *paramBlkPtr);
void		InstallExitHandler(void);
void		MyExitHandler(void);
int			PortNumberValid(int port);
pascal void	ResolverCompletionRoutine(struct hostInfo *hostInfoPtr, char *userDataPtr);
int			ResolverInitialize(int resolverSemaIndex);
void		ResolverTerminate(void);
int			SocketValid(SocketPtr s);
void		TCPCloseCompletionRoutine(struct TCPiopb *s);
void		TCPConnectCompletionRoutine(struct TCPiopb *s);
pascal void	TCPNotificationRoutine(
	StreamPtr s, unsigned short eventCode, Ptr userDataPtr,
	unsigned short terminReason, struct ICMPReport *icmpMsg);
void		TCPSendCompletionRoutine(struct TCPiopb *s);


/*** Network Functions ***/
void sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
  SocketPtr s, int netType, int socketType,
  int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex) {
  interpreterProxy->success(false);
}

int sqSockettoHostportSendDataBufCount(SocketPtr s, int address, int port, int buf, int bufSize) {
  interpreterProxy->success(false);
}

int sqSocketGetOptionsoptionNameStartoptionNameSizereturnedValue(SocketPtr s,int optionNameT, int optionNameSize, int *result)	{
  interpreterProxy->success(false);
}

void	sqSocketAcceptFromRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
			SocketPtr s, SocketPtr serverSocket,
			int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex) {
  interpreterProxy->success(false);
}

int sqSocketReceiveUDPDataBufCountaddressportmoreFlag(SocketPtr s, int buf, int bufSize,  int *address,  int *port, int *moreFlag) {
  interpreterProxy->success(false);
}

int sqSocketSetOptionsoptionNameStartoptionNameSizeoptionValueStartoptionValueSizereturnedValue(SocketPtr s,int optionNameT, int optionNameSize, int optionValueT, int optionValueSize, int *result)	{
  interpreterProxy->success(false);
}

int sqNetworkInit(int resolverSemaIndex) {
	/* initialize the network and return 0 if successful */
	int localAddr;
	UDPiopb paramBlock;
	OSErr err = noErr;

	if (thisNetSession !!= 0) return 0;  /* noop if network is already initialized */

	/* open network driver */
	macTCPRefNum = 0;
	err = OpenDriver("\p.IPP", &macTCPRefNum);
	if (err !!= noErr) {
		return -1;
	}

	/* open resolver */
	err = ResolverInitialize(resolverSemaIndex);
	if (err !!= noErr) {
		ResolverTerminate();
		return -1;
	}

	/* get local address */
	localAddr = sqResolverLocalAddress();
	if (sqResolverError() !!= noErr) {
		ResolverTerminate();
		return -1;
	}

	/* compute MTU (maximum transfer unit) size */
	memset(&paramBlock, 0, sizeof(paramBlock));
	paramBlock.csCode = UDPMaxMTUSize;
	paramBlock.csParam.mtu.remoteHost = localAddr;
	paramBlock.ioCRefNum = macTCPRefNum;
	err = PBControlSync((ParmBlkPtr) &paramBlock);
	if (err == noErr) {
		mtuSize = paramBlock.csParam.mtu.mtuSize;
	} else {
		mtuSize = 1024;  /* guess */
		ResolverTerminate();
		return -1;
	}

	resolverDoneProc	= NewResultProc(ResolverCompletionRoutine);
	tcpCloseDoneProc 	= NewTCPIOCompletionProc(TCPCloseCompletionRoutine);
	tcpConnectDoneProc	= NewTCPIOCompletionProc(TCPConnectCompletionRoutine);
	tcpNotifyProc		= NewTCPNotifyProc(TCPNotificationRoutine);
	tcpSendDoneProc		= NewTCPIOCompletionProc(TCPSendCompletionRoutine);

	InstallExitHandler();

	/* Success!! Create a session ID that is unlikely to be
	   repeated. Zero is never used for a valid session number.
	*/
	thisNetSession = clock() + time(NULL);
	if (thisNetSession == 0) thisNetSession = 1;  /* don''t use 0 */
	return 0;
}

void sqNetworkShutdown(void) {
	/* shut down the network */

	if (thisNetSession == 0) return;  /* noop if network is already shut down */
	SetToolTrapAddress(oldExitHandlerProc, _ExitToShell);
	ResolverTerminate();
	DestroyAllOpenSockets();
	thisNetSession = 0;
}

/*** Squeak Generic Socket Functions ***/

void sqSocketAbortConnection(SocketPtr s) {
	if (!!SocketValid(s)) return;
	if (s->socketType == TCPSocketType) {
		TCPSockAbortConnection((TCPSockPtr) s->privateSocketPtr);
		return;
	}
	if (s->socketType == ListenerQueueType) {
		((ListenerQueuePtr) s->privateSocketPtr)->closed = true; /* set closed flag */
		return;
	}
	success(false);
}

void sqSocketCloseConnection(SocketPtr s) {
	if (!!SocketValid(s)) return;
	if (s->socketType == TCPSocketType) {
		TCPSockCloseConnection((TCPSockPtr) s->privateSocketPtr);
		return;
	}
	if (s->socketType == ListenerQueueType) {
		((ListenerQueuePtr) s->privateSocketPtr)->closed = true; /* set closed flag */
		return;
	}
	success(false);
}

int sqSocketConnectionStatus(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return ((TCPSockPtr) s->privateSocketPtr)->connectStatus;
	}
	if (s->socketType == UDPSocketType) {
		return ((UDPSockPtr) s->privateSocketPtr)->connectStatus;
	}
	if (s->socketType == ListenerQueueType) {
		return ListenerQueueStatus((ListenerQueuePtr) s->privateSocketPtr);
	}
	success(false);
}

void sqSocketConnectToPort(SocketPtr s, int addr, int port) {
	if (!!SocketValid(s)) return;
	if (!!PortNumberValid(port)) return;
	if (s->socketType == TCPSocketType) {
		TCPSockConnectTo((TCPSockPtr) s->privateSocketPtr, addr, port);
		return;
	}
	if (s->socketType == UDPSocketType) {
		UDPSockConnectTo((UDPSockPtr) s->privateSocketPtr, addr, port);
		return;
	}
	success(false);
}

void sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID(
			SocketPtr s, int netType, int socketType,
			int recvBufSize, int sendBufSize, int semaIndex) {
	TCPSockPtr tcpSock = nil;
	UDPSockPtr udpSock = nil;

	/* reference args to suppress compiler warnings about unused variables */
	s; netType; recvBufSize; sendBufSize;

	s->sessionID = 0;
	if (socketType == TCPSocketType) {
		tcpSock = TCPSockCreate();
		if (tcpSock == nil) {
			success(false);
		} else {
			tcpSock->semaIndex = semaIndex;
			tcpSock->next = openTCPSockets;
			openTCPSockets = tcpSock;
			s->sessionID = thisNetSession;
			s->socketType = TCPSocketType;
			s->privateSocketPtr = tcpSock;
		}
		return;
	}
	if (s->socketType == UDPSocketType) {
		udpSock = UDPSockCreate();
		if (udpSock == nil) {
			success(false);
		} else {
			udpSock->semaIndex = semaIndex;
			udpSock->next = openUDPSockets;
			openUDPSockets = udpSock;
			s->sessionID = thisNetSession;
			s->socketType = UDPSocketType;
			s->privateSocketPtr = udpSock;
		}
		return;
	}
	success(false);
}

void sqSocketDestroy(SocketPtr s) {
	if (!!SocketValid(s)) return;
	if (s->socketType == TCPSocketType) {
		TCPSockDestroy((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		UDPSockDestroy((UDPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == ListenerQueueType) {
		ListenerQueueDestroy((ListenerQueuePtr) s->privateSocketPtr);
	}
	s->sessionID = 0;
	s->socketType = -1;
	s->privateSocketPtr = nil;
}

int sqSocketError(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return ((TCPSockPtr) s->privateSocketPtr)->lastError;
	}
	if (s->socketType == UDPSocketType) {
		return ((UDPSockPtr) s->privateSocketPtr)->lastError;
	}
	if (s->socketType == ListenerQueueType) {
		return 0;  /* ListenerQueue''s themselves never get an error */
	}
}

void sqSocketListenOnPort(SocketPtr s, int port) {
	if (!!SocketValid(s)) return;
	if (!!PortNumberValid(port)) return;
	if (s->socketType == TCPSocketType) {
		TCPSockListenOn((TCPSockPtr) s->privateSocketPtr, port);
		return;
	}
	if (s->socketType == UDPSocketType) {
		UDPSockListenOn((UDPSockPtr) s->privateSocketPtr, port);
		return;
	}
	success(false);
}

int sqSocketLocalAddress(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockLocalAddress((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockLocalAddress((UDPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == ListenerQueueType) {
		return ((ListenerQueuePtr) s->privateSocketPtr)->localAddress;
	}
	success(false);
}

int sqSocketLocalPort(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockLocalPort((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockLocalPort((UDPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == ListenerQueueType) {
		return ((ListenerQueuePtr) s->privateSocketPtr)->localPort;
	}
	success(false);
}

int sqSocketReceiveDataAvailable(SocketPtr s) {
	if (!!SocketValid(s)) return 0;
	if (s->socketType == TCPSocketType) {
		return TCPSockDataAvailable((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		return ((UDPSockPtr) s->privateSocketPtr)->dataAvailable;
	}
	success(false);
}

int sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize) {
	int adjustedBufSize = bufSize > 0xFFFF ? 0xFFFF : bufSize;

	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockRecvData((TCPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockRecvData((UDPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);
	}
	success(false);
}

int sqSocketRemoteAddress(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockRemoteAddress((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockRemoteAddress((UDPSockPtr) s->privateSocketPtr);
	}
	success(false);
}

int sqSocketRemotePort(SocketPtr s) {
	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockRemotePort((TCPSockPtr) s->privateSocketPtr);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockRemotePort((UDPSockPtr) s->privateSocketPtr);
	}
	success(false);
}

int sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize) {
	int adjustedBufSize = bufSize > 0xFFFF ? 0xFFFF : bufSize;

	if (!!SocketValid(s)) return -1;
	if (s->socketType == TCPSocketType) {
		return TCPSockSendData((TCPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);
	}
	if (s->socketType == UDPSocketType) {
		return UDPSockSendData((UDPSockPtr) s->privateSocketPtr, (char *) buf, adjustedBufSize);
	}
	success(false);
}

int sqSocketSendDone(SocketPtr s) {
	if (!!SocketValid(s)) return 1;
	if (s->socketType == TCPSocketType) {
		return !!((TCPSockPtr) s->privateSocketPtr)->sendInProgress;
	}
	if (s->socketType == UDPSocketType) {
		return !!((UDPSockPtr) s->privateSocketPtr)->sendInProgress;
	}
	success(false);
}

/*** Resolver Functions ***/

void sqResolverAbort(void) {
	int semaIndex;

	/* abort the current request */
	if (resolver.status == RESOLVER_BUSY) {
		semaIndex = resolver.semaIndex;
		ResolverTerminate();
		ResolverInitialize(semaIndex);
	}
}

void sqResolverAddrLookupResult(char *nameForAddress, int nameSize) {
	/* copy the name found by the last address lookup into the given string */
	memcpy(nameForAddress, resolver.hostInfo.cname, nameSize);
}

int sqResolverAddrLookupResultSize(void) {
	return strlen(resolver.hostInfo.cname);
}

int sqResolverError(void) {
	return resolver.error;
}

int sqResolverLocalAddress(void) {
	struct GetAddrParamBlock paramBlock;

	if (resolver.localAddress == 0) {
		resolver.remoteAddress = 0;
		memset(&paramBlock, 0, sizeof(struct GetAddrParamBlock));
		paramBlock.ioResult = 1;
		paramBlock.csCode = ipctlGetAddr;
		paramBlock.ioCRefNum = macTCPRefNum;
		PBControlSync((ParmBlkPtr) &paramBlock);
		if (paramBlock.ioResult == noErr) {
			resolver.status = RESOLVER_SUCCESS;
			resolver.localAddress = paramBlock.ourAddress;
			resolver.error = noErr;
		} else {
			resolver.status = RESOLVER_ERROR;
			resolver.error = paramBlock.ioResult;
		}
	} else {
		resolver.status = RESOLVER_SUCCESS;
		resolver.error = noErr;
	}
	return resolver.localAddress;
}

int sqResolverNameLookupResult(void) {
	/* return the result of the last successful lookup */
	return resolver.remoteAddress;
}

void sqResolverStartAddrLookup(int address) {
	OSErr err;

	if (resolver.status == RESOLVER_BUSY) return;

	resolver.status = RESOLVER_BUSY;
	resolver.error = noErr;
	memset(&resolver.hostInfo, 0, sizeof(hostInfo));
	err = AddrToName(address, &resolver.hostInfo, resolverDoneProc, (char *) &resolver);
	if (err == noErr) {
		/* address was in cache; lookup is already done */
		resolver.status = RESOLVER_SUCCESS;
	} else {
		if (err !!= cacheFault) {
			/* real error */
			resolver.status = RESOLVER_ERROR;
			resolver.error = err;
		}
	}
}

void sqResolverStartNameLookup(char *hostName, int nameSize) {
	char name[501];
	int len; 
	OSErr err;

	if (resolver.status == RESOLVER_BUSY) return;

	len = ((nameSize <= 500) ? nameSize : 500);
	memcpy(name, hostName, len);
	name[len] = ''\0'';

	resolver.status = RESOLVER_BUSY;
	resolver.error = noErr;
	memset(&resolver.hostInfo, 0, sizeof(hostInfo));
	err = StrToAddr(name, &resolver.hostInfo, resolverDoneProc, (char *) &resolver);
	if (err == noErr) {
		/* address was in cache; lookup is already done */
		resolver.status = RESOLVER_SUCCESS;
		resolver.remoteAddress = resolver.hostInfo.addr[0];
	} else {
		if (err !!= cacheFault) {
			/* real error */
			resolver.status = RESOLVER_ERROR;
			resolver.error = err;
		}
	}
}

int sqResolverStatus(void) {
	return resolver.status;
}

/*** Private Resolver Functions ***/

int ResolverInitialize(int resolverSemaIndex) {
	if (resolver.status !!= RESOLVER_UNINITIALIZED) {
		ResolverTerminate();
	}

	memset(&resolver, 0, sizeof(ResolverStatusRec));
	resolver.status = RESOLVER_UNINITIALIZED;

	resolver.error = OpenResolver(nil);
	if (resolver.error !!= noErr) {
		resolver.status = RESOLVER_ERROR;
		return resolver.error;
	}

	resolver.semaIndex = resolverSemaIndex;
	resolver.status = RESOLVER_SUCCESS;
	return noErr;
}

static pascal void ResolverCompletionRoutine(struct hostInfo *hostInfoPtr, char *userDataPtr) {
	ResolverStatusPtr r = (ResolverStatusPtr) userDataPtr;

	if ((r == null) || (r->status !!= RESOLVER_BUSY)) return;

	/* completion routine */
	if (r->hostInfo.rtnCode == noErr) {
		r->status = RESOLVER_SUCCESS;
		r->remoteAddress = hostInfoPtr->addr[0];
	} else {
		r->status = RESOLVER_ERROR;
		r->error = hostInfoPtr->rtnCode;
	}
	signalSemaphoreWithIndex(r->semaIndex);
}

void ResolverTerminate(void) {
	CloseResolver();
	memset(&resolver, 0, sizeof(ResolverStatusRec));
	resolver.status = RESOLVER_UNINITIALIZED;
}

/*** Squeak TCP Socket Listen/Accept Functions ***/

ListenerQueuePtr ListenerQueueCreate(TCPSockPtr tcpSocket, int port, int backlogSize) {
	ListenerQueuePtr listener;

	/* allocate a new ListenerQueue */
	listener = (ListenerQueuePtr) malloc(sizeof(ListenerQueueRec));
	if (listener == nil) return nil;

	/* initialize it */
	listener->localAddress = TCPSockLocalAddress(tcpSocket);
	listener->localPort = port;
	listener->closed = false;
	listener->semaIndex = tcpSocket->semaIndex;
	listener->desiredQueueLength = (backlogSize < 1) ? 1 : backlogSize;
	listener->waitingSockets = nil;

	/* add the given socket to the new ListenerQueue */
	tcpSocket->nextInListenerQueue = listener->waitingSockets;
	listener->waitingSockets = tcpSocket;
	TCPSockListenOn(tcpSocket, listener->localPort);

	/* create additional waiting sockets in necessary to fill the ListenerQueue */
	FillListenerQueue(listener);
	return listener;
}

void ListenerQueueDestroy(ListenerQueuePtr listener) {
	TCPSockPtr thisSock, nextSock;

	/* destroy all sockets in this ListenerQueue''s waiting socket list */
	thisSock = listener->waitingSockets;
	while (thisSock !!= nil) {
		nextSock = thisSock->nextInListenerQueue;
		TCPSockDestroy(thisSock);
		thisSock = nextSock;
	}

	/* clear a few fields, just in case of a dangling reference */
	listener->closed = true;
	listener->semaIndex = 0;
	listener->waitingSockets = nil;

	/* free the ListenerQueue */
	free(listener);
}

int ListenerQueueStatus(ListenerQueuePtr listener) {
	TCPSockPtr sock;

	if (listener == nil) {
		success(false);
		return Unconnected;
	}

	if (listener->closed) return Unconnected;

	/* check for zombie sockets; if there is one, clean up the queue */
	if (FindZombieSocket(listener) !!= nil) {
		FillListenerQueue(listener);  /* removes zombies and refills queue */
	}

	/* scan queue for a connected socket */
	sock = FindConnectedSocket(listener);
	return (sock == nil) ? WaitingForConnection : Connected;
}

void FillListenerQueue(ListenerQueuePtr listener) {
	TCPSockPtr sock, newSock;
	int count, socksToAdd;

	/* remove from the queue and destroy any zombie sockets */
	while ((sock = FindZombieSocket(listener)) !!= nil) {
		RemoveSocketFromListenerQueue(sock, listener);
		TCPSockDestroy(sock);
	}

	/* count the number of remaining sockets */
	count = 0;
	sock = listener->waitingSockets;
	while (sock !!= nil) {
		count++;
		sock = sock->nextInListenerQueue;
	}

	/* create enough new sockets up to fill ListenerQueue to desired size */
	socksToAdd = listener->desiredQueueLength - count;
	while (socksToAdd > 0) {
		newSock = TCPSockCreate();
		if (newSock!!= nil) {
			/* set semaphore of the new socket*/
			newSock->semaIndex = listener->semaIndex;

			/* record new socket in openTCPSockets */
			newSock->next = openTCPSockets;
			openTCPSockets = newSock;

			/* add new socket to the listener queue and start it listening */
			newSock->nextInListenerQueue = listener->waitingSockets;
			listener->waitingSockets = newSock;
			TCPSockListenOn(newSock, listener->localPort);
		}
		socksToAdd--;
	}
}

TCPSockPtr FindConnectedSocket(ListenerQueuePtr listener) {
  /* Return the first connected socket in the given ListenerQueue,
     or nil if there isn''t one. */

	TCPSockPtr sock;

	sock = listener->waitingSockets;
	while (sock !!= nil) {
		if (sock->connectStatus == Connected) return sock;
		sock = sock->nextInListenerQueue;
	}
	return nil;
}

TCPSockPtr FindZombieSocket(ListenerQueuePtr listener) {
  /* Return the first socket in the given ListenerQueue that is not connected or
     waiting for a connection (we call this a zombie), or nil if there isn''t one.
     Zombies are created when a connection is made but broken again before an
     accept has been done. Since a zombie are no longer waiting for a connection,
     it takes the place of listening socket. If the queue became filled with zombies
     no connections could get through. Thus, zombies must be eliminated. As the
     saying goes: "the only good zombie is a dead zombie." */

	TCPSockPtr sock;

	sock = listener->waitingSockets;
	while (sock !!= nil) {
		if ((sock->connectStatus !!= WaitingForConnection) &&
			(sock->connectStatus !!= Connected)) return sock;
		sock = sock->nextInListenerQueue;
	}
	return nil;
}

void sqSocketAcceptFromRecvBytesSendBytesSemaID(
  SocketPtr s, SocketPtr serverSocket,
  int recvBufSize, int sendBufSize, int semaIndex) {
  /* Accept a connection for the given server socket. The server socket must
     have been turned into a listener queue via sqSocketListenOnPortBacklogSize().
     If successful, s is initialized to newly connected socket using the
     given paramenters, and a new listening socket will be created and added
     to the ListenerQueue to maintain the desired queue length. Note that MacTCP
     allows multiple sockets to be listening on the same port number and, indeed,
     this is the only way to support the Unix socket notion of a socket backlog. */

	ListenerQueuePtr listener;
	TCPSockPtr connectedSock;

	/* server socket must be a valid ListenerQueue */
	if ((serverSocket == nil) ||
		(serverSocket->sessionID !!= thisNetSession) ||
		(serverSocket->socketType !!= ListenerQueueType) ||
		(serverSocket->privateSocketPtr == nil)) {
			success(false);
			return;
	}

	/* result socket must be a new, unintialized socket */
	if ((s == nil) ||
		(s->sessionID !!= 0) ||
		(s->socketType !!= 0) ||
		(s->privateSocketPtr !!= nil)) {
			success(false);
			return;
	}

	/* look for a connected socket */
	listener = (ListenerQueuePtr) serverSocket->privateSocketPtr;
	connectedSock = FindConnectedSocket(listener);
	if (connectedSock == nil) {
		success(false);
	} else {
		/* remove connected socket from the listener queue */
		RemoveSocketFromListenerQueue(connectedSock, listener);

		/* fill in the result socket handle */
		connectedSock->semaIndex = semaIndex;
		s->sessionID = thisNetSession;
		s->socketType = TCPSocketType;
		s->privateSocketPtr = connectedSock;
	}

	/* ensure that the queue has the desired number of listenening sockets */
	FillListenerQueue(listener);
}

void RemoveSocketFromListenerQueue(TCPSockPtr sockToRemove, ListenerQueuePtr listener) {
	TCPSockPtr lastSock, thisSock;

	if (sockToRemove == nil) return;

	if (listener->waitingSockets == sockToRemove) {
		listener->waitingSockets = sockToRemove->nextInListenerQueue;
		sockToRemove->nextInListenerQueue = nil;
		return;
	}

	lastSock = listener->waitingSockets;
	thisSock = lastSock->nextInListenerQueue;
	while (thisSock !!= nil) {
		if (thisSock == sockToRemove) {
			lastSock->nextInListenerQueue = sockToRemove->nextInListenerQueue;
			sockToRemove->nextInListenerQueue = nil;
			return;
		}
		lastSock = thisSock;
		thisSock = lastSock->nextInListenerQueue;
	}
}

void sqSocketListenOnPortBacklogSize(SocketPtr s, int port, int backlogSize) {
	TCPSockPtr tcpSocket;
	ListenerQueuePtr listener;

	/* s must be an TCP socket that is initialized but unconnected */
	if ((!!SocketValid(s)) || (s->socketType !!= TCPSocketType)) {
		success(false);
		return;
	}
	tcpSocket = (TCPSockPtr) s->privateSocketPtr;
	if (tcpSocket->connectStatus !!= Unconnected) {
		success(false);
		return;
	}

	/* make sure the port number is in range */
	if (!!PortNumberValid(port)) {;
		success(false);
		return;
	}

	/* create a new listener on the given with the given backlog size */
	listener = ListenerQueueCreate((TCPSockPtr) s->privateSocketPtr, port, backlogSize);
	if (listener == nil) {
		success(false);
		return;
	}

	/* mutate s into a listener socket: replace the original TCP socket in s with
	   the new listener, and change the type of s to ListenerQueueType */
	s->socketType = ListenerQueueType;
	s->privateSocketPtr = listener;
}

/*** Private TCP Socket Functions ***/

void * TCPSockCreate(void) {
	TCPiopb paramBlock;
	TCPSockPtr s = nil;
	int minRcvBufSize, rcvBufSize;
	OSErr err = noErr;

	rcvBufSize = RecvBufferSize;
	minRcvBufSize = (4 * mtuSize) + 1024;
	if (rcvBufSize < minRcvBufSize) rcvBufSize = minRcvBufSize;

	s = (TCPSockPtr) malloc(sizeof(TCPSockRec) + rcvBufSize);
	if (s == nil) return nil;  /* allocation failed */
	memset(s, 0, sizeof(TCPSockRec) + rcvBufSize);

	InitTCPCmd(TCPCreate, nil, &paramBlock);
	paramBlock.csParam.create.rcvBuff = s->rcvBuf;
	paramBlock.csParam.create.rcvBuffLen = rcvBufSize;
	paramBlock.csParam.create.notifyProc = tcpNotifyProc;
	paramBlock.csParam.create.userDataPtr = (Ptr) s;
	err = PBControlSync((ParmBlkPtr) &paramBlock);
	if (err !!= noErr) {
		free(s);
		return nil;
	}
	s->tcpStream = paramBlock.tcpStream;
	return s;
}

int TCPSockDataAvailable(TCPSockPtr s) {
	TCPiopb paramBlock;
	OSErr err = noErr;

	if ((s == nil) || (s->tcpStream == nil)) {
		return false;  /* already destroyed */
	}

	InitTCPCmd(TCPStatus, s->tcpStream, &paramBlock);
	err = PBControlSync((ParmBlkPtr) &paramBlock);
	if (err !!= noErr) {
		return 0;
	}
	return paramBlock.csParam.status.amtUnreadData > 0;
}

void TCPSockDestroy(TCPSockPtr s) {
	TCPiopb paramBlock;
	OSErr err = noErr;

	if ((s == nil) || (s->tcpStream == nil)) {
		return;  /* already destroyed */
	}

	InitTCPCmd(TCPRelease, s->tcpStream, &paramBlock);
	err = PBControlSync((ParmBlkPtr) &paramBlock);
	TCPSockRemoveFromOpenList(s);
	s->tcpStream = nil;
	free(s);
}

int TCPSockLocalAddress(TCPSockPtr s) {
	TCPiopb paramBlock;

	if ((s == nil) || (s->tcpStream == nil)) {
		return 0;  /* already destroyed */
	}

	InitTCPCmd(TCPStatus, s->tcpStream, &paramBlock);
	s->lastError = PBControlSync((ParmBlkPtr) &paramBlock);
	if (s->lastError !!= noErr) {
		return 0;
	}
	return paramBlock.csParam.status.localHost;
}

int TCPSockLocalPort(TCPSockPtr s) {
	TCPiopb paramBlock;

	if ((s == nil) || (s->tcpStream == nil)) {
		return 0;  /* already destroyed */
	}

	InitTCPCmd(TCPStatus, s->tcpStream, &paramBlock);
	s->lastError = PBControlSync((ParmBlkPtr) &paramBlock);
	if (s->lastError !!= noErr) {
		return 0;
	}
	return paramBlock.csParam.status.localPort;
}

int TCPSockRemoteAddress(TCPSockPtr s) {
	TCPiopb paramBlock;

	if ((s == nil) || (s->tcpStream == nil)) {
		return 0;  /* already destroyed */
	}

	InitTCPCmd(TCPStatus, s->tcpStream, &paramBlock);
	s->lastError = PBControlSync((ParmBlkPtr) &paramBlock);
	if (s->lastError !!= noErr) {
		return 0;
	}
	return paramBlock.csParam.status.remoteHost;
}

int TCPSockRemotePort(TCPSockPtr s) {
	TCPiopb paramBlock;

	if ((s == nil) || (s->tcpStream == nil)) {
		return 0;  /* already destroyed */
	}

	InitTCPCmd(TCPStatus, s->tcpStream, &paramBlock);
	s->lastError = PBControlSync((ParmBlkPtr) &paramBlock);
	if (s->lastError !!= noErr) {
		return 0;
	}
	return paramBlock.csParam.status.remotePort;
}

void TCPSockRemoveFromOpenList(TCPSockPtr s) {
	TCPSockPtr thisSock, nextSock, previousSock;

	previousSock = nil;
	for (thisSock = openTCPSockets; thisSock !!= nil; thisSock = nextSock) {
		nextSock = thisSock->next;
		if (thisSock == s) {
			if (previousSock == nil) {
				openTCPSockets = nextSock;
			} else {
				previousSock->next = nextSock;
			}
			break;
		}
		previousSock = thisSock;
	}
}

void TCPSockConnectTo(TCPSockPtr s, int addr, int port) {
	if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */

	InitTCPCmd(TCPActiveOpen, s->tcpStream, &s->tcpPB);
	s->tcpPB.csParam.open.remoteHost = addr;
	s->tcpPB.csParam.open.remotePort = port;
	s->connectStatus = WaitingForConnection;
	s->tcpPB.ioCompletion = tcpConnectDoneProc;
	s->lastError = PBControlAsync((ParmBlkPtr) &s->tcpPB);
	if (s->lastError !!= noErr) {
		s->connectStatus = Unconnected;
	}
}

void TCPSockListenOn(TCPSockPtr s, int port) {
	if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */

	InitTCPCmd(TCPPassiveOpen, s->tcpStream, &s->tcpPB);
	s->tcpPB.csParam.open.localPort = port;
	s->connectStatus = WaitingForConnection;
	s->tcpPB.ioCompletion = tcpConnectDoneProc;
	s->lastError = PBControlAsync((ParmBlkPtr) &s->tcpPB);
	if (s->lastError !!= noErr) {
		s->connectStatus = Unconnected;
	}
}

void TCPSockCloseConnection(TCPSockPtr s) {
	/* Note: This operation uses a dedicated parameter block so that it
	   can be invoked even in the previous send is not yet complete.
	   It will eventually use a completion routine to delete the
	   socket automatically. For now, this is the client''s responsibility.
	*/
	if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */

	InitTCPCmd(TCPClose, s->tcpStream, &s->closePB);
//	s->closePB.ioCompletion = tcpCloseDoneProc;
	s->connectStatus = ThisEndClosed; // xxx remove when making this async
	s->lastError = PBControlSync((ParmBlkPtr) &s->closePB);
}

void TCPSockAbortConnection(TCPSockPtr s) {
	TCPiopb paramBlock;

	if ((s == nil) || (s->tcpStream == nil)) return;  /* socket destroyed */

	InitTCPCmd(TCPAbort, s->tcpStream, &paramBlock);
	s->lastError = PBControlSync((ParmBlkPtr) &paramBlock);
	s->connectStatus = Unconnected;
}

int TCPSockRecvData(TCPSockPtr s, char *buf, int bufSize) {
	TCPiopb paramBlock;  /* use local parameter block since send may be using one in socket */
	OSErr err = noErr;
	int bytesRead;

	if ((s->connectStatus == Unconnected) || (s->connectStatus == WaitingForConnection)) {
		success(false);
		return 0;  /* fail if not connected */
	}
	if (!!TCPSockDataAvailable(s)) return 0;  /* no data available */

	InitTCPCmd(TCPRcv, s->tcpStream, &paramBlock);
	paramBlock.csParam.receive.commandTimeoutValue = 1; /* finish in one second, data or not */
	paramBlock.csParam.receive.rcvBuff = buf;
	paramBlock.csParam.receive.rcvBuffLen = bufSize;
	s->lastError = noErr;
	err = PBControlSync((ParmBlkPtr) &paramBlock);  /* synchronous */
	if (err == noErr) {
		bytesRead = paramBlock.csParam.receive.rcvBuffLen;
	} else {
		/* if err == commandTimeout, no data was available */
		bytesRead = 0;
		if (!!((err == commandTimeout) || (err == connectionClosing))) {
			s->lastError = err;
		}
	}
	s->dataAvailable = (bytesRead !!= 0);  /* if we got data, there may be more */
	return bytesRead;
}

int xxxGOODTCPSockSendData(TCPSockPtr s, char *buf, int bufSize);
int xxxGOODTCPSockSendData(TCPSockPtr s, char *buf, int bufSize) {
	int sendCount;
	struct wdsEntry wds[2];

	buf;  /* xxx avoid compiler complaint about unreferenced vars */

	/* copy client data into sendBuf to allow asynchronous send */
	sendCount = (bufSize <= SendBufferSize) ? bufSize : SendBufferSize;
//xxx	memcpy(s->sendBuf, buf, sendCount);

	/* set up WDS entry; zero length marks end of chunk list */
	wds[0].length = sendCount;
//xxx		wds[0].ptr = s->sendBuf;
	wds[1].length = 0;

	InitTCPCmd(TCPSend, s->tcpStream, &s->tcpPB);
	s->tcpPB.csParam.send.wdsPtr = (Ptr) &wds;
	s->tcpPB.csParam.send.pushFlag = true;
	s->sendInProgress = true;
	s->tcpPB.ioCompletion = tcpSendDoneProc;
	s->lastError = PBControlAsync((ParmBlkPtr) &s->tcpPB);
	if (s->lastError !!= noErr) {
		s->sendInProgress = false;
		return 0;
	}
	return sendCount;
}

int TCPSockSendData(TCPSockPtr s, char *buf, int bufSize) {
	TCPSendBufPtr sendBuf;
	int sendCount;

	if ((s->connectStatus == Unconnected) || (s->connectStatus == WaitingForConnection)) {
		success(false);
		return 0;  /* fail if not connected */
	}

	sendBuf = &sendBufPool[nextSendBuf++];
	if (nextSendBuf >= SendBufCount) nextSendBuf = 0;
	sendBuf->mySocket = s;

	/* copy client data into sendBuf to allow asynchronous send */
	sendCount = (bufSize <= SendBufferSize) ? bufSize : SendBufferSize;
	memcpy(sendBuf->data, buf, sendCount);

	/* set up WDS entry; zero length marks end of chunk list */
	sendBuf->wds[0].length = sendCount;
	sendBuf->wds[0].ptr = sendBuf->data;
	sendBuf->wds[1].length = 0;

	InitTCPCmd(TCPSend, s->tcpStream, &sendBuf->tcpPB);
	sendBuf->tcpPB.csParam.send.wdsPtr = (Ptr) &sendBuf->wds;
	sendBuf->tcpPB.csParam.send.pushFlag = true;
	sendBuf->tcpPB.ioCompletion = tcpSendDoneProc;
	s->sendInProgress = true;
	s->lastError = PBControlAsync((ParmBlkPtr) &sendBuf->tcpPB);
	if (s->lastError !!= noErr) {
		s->sendInProgress = false;
		return 0;
	}
	return sendCount;
}

/*** Private General Utilities ***/

void DestroyAllOpenSockets(void) {
	while (openTCPSockets !!= nil) {
		TCPSockDestroy(openTCPSockets);  /* removes socket from the list */
	}
	while (openUDPSockets !!= nil) {
		UDPSockDestroy(openUDPSockets);  /* removes socket from the list */
	}
}

void InstallExitHandler(void) {
	/* Install a handler to release all open sockets when terminating this
	   application. The handler will be called even if you type ''es'' to
	   MacsBug or use Command-Option-Escape for force the program to exit.
	   The handler is only installed the first time the network is initialized.
	*/

	if (oldExitHandlerProc == nil) {
		oldExitHandlerProc = GetToolTrapAddress(_ExitToShell);
		myExitHandlerProc = 
			NewRoutineDescriptor((ProcPtr) MyExitHandler, kPascalStackBased, GetCurrentISA());
		SetToolTrapAddress(myExitHandlerProc, _ExitToShell);
	}
}

void MyExitHandler(void) {
	SetCurrentA5();
	if (thisNetSession == 0) return;  /* noop if network is already shut down */
	SetToolTrapAddress(oldExitHandlerProc, _ExitToShell);
	ResolverTerminate();
	DestroyAllOpenSockets();
	ExitToShell();
}

int PortNumberValid(int port) {
	if (port < 0xFFFF) {
		return true;
	}
	success(false);
	return false;
}

int SocketValid(SocketPtr s) {
	if ((s !!= NULL) &&
		(s->privateSocketPtr !!= NULL) &&
		(s->sessionID == thisNetSession)) {
			if (s->socketType == TCPSocketType) {
				if (((TCPSockPtr) s->privateSocketPtr)->tcpStream !!= nil) {
					return true;
				}
			}
			return true;
	}
	success(false);
	return false;
}

/*** Private TCP Utilities ***/

void InitTCPCmd(int cmd, StreamPtr tcpStream, TCPiopb *paramBlkPtr) {
	memset(paramBlkPtr, 0, sizeof(TCPiopb));
	paramBlkPtr->csCode = cmd;
	paramBlkPtr->tcpStream = tcpStream;
	paramBlkPtr->ioCRefNum = macTCPRefNum;
	paramBlkPtr->ioResult = 1;
}

void TCPCloseCompletionRoutine(struct TCPiopb *pbPtr) {
	TCPSockPtr s = (TCPSockPtr) pbPtr;

	s->lastError = s->tcpPB.ioResult;
	if (s->lastError == noErr) {
		if (s->connectStatus == OtherEndClosed) {
			s->connectStatus = Unconnected;
		} else {
			s->connectStatus = ThisEndClosed;
		}
	}
	signalSemaphoreWithIndex(s->semaIndex);
}

void TCPConnectCompletionRoutine(struct TCPiopb *pbPtr) {
	TCPSockPtr s = (TCPSockPtr) pbPtr;

	s->lastError = s->tcpPB.ioResult;
	if (s->lastError == noErr) {
		s->connectStatus = Connected;
	} else {
		s->connectStatus = Unconnected;
	}
	signalSemaphoreWithIndex(s->semaIndex);
}

pascal void TCPNotificationRoutine(
	StreamPtr s, unsigned short eventCode, Ptr userDataPtr,
	unsigned short terminReason, struct ICMPReport *icmpMsg) {
	/* called when data arrives or stream status changes */

	/* reference args to suppress compiler warnings about unused variables */
	s; terminReason; icmpMsg;

	if (eventCode == TCPDataArrival) {
		TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;
		tcpSock->dataAvailable = true;
		signalSemaphoreWithIndex(tcpSock->semaIndex);
		return;
	}
	if (eventCode == TCPClosing) {
		TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;
		if (tcpSock->connectStatus == ThisEndClosed) {
			tcpSock->connectStatus = Unconnected;
		} else {
			tcpSock->connectStatus = OtherEndClosed;
		}
		signalSemaphoreWithIndex(tcpSock->semaIndex);
		return;
	}
	if (eventCode == TCPTerminate) {
		TCPSockPtr tcpSock = (TCPSockPtr) userDataPtr;
		tcpSock->connectStatus = Unconnected;
		signalSemaphoreWithIndex(tcpSock->semaIndex);
		return;
	}
}

void TCPSendCompletionRoutine(struct TCPiopb *pbPtr) {
//xxx	TCPSockPtr s = (TCPSockPtr) pbPtr;
TCPSockPtr s = ((TCPSendBufPtr) pbPtr)->mySocket;

	s->lastError = s->tcpPB.ioResult;
	s->sendInProgress = false;
	signalSemaphoreWithIndex(s->semaIndex);
}

/*** Private UDP Socket Functions (not yet implemented) ***/

void * UDPSockCreate(void) {
	return nil;
}

void UDPSockDestroy(UDPSockPtr s) {
	s;
}

int UDPSockLocalAddress(UDPSockPtr s) {
	s;
}

int UDPSockLocalPort(UDPSockPtr s) {
	s;
}

int UDPSockRemoteAddress(UDPSockPtr s) {
	s;
}

int UDPSockRemotePort(UDPSockPtr s) {
	s;
}

void UDPSockConnectTo(UDPSockPtr s, int addr, int port) {
	s; addr; port;
}

void UDPSockListenOn(UDPSockPtr s, int port) {
	s; port;
}

int UDPSockRecvData(UDPSockPtr s, char *buf, int bufSize) {
	s; buf; bufSize;
}

int UDPSockSendData(UDPSockPtr s, char *buf, int bufSize) {
	s; buf; bufSize;
}

#endif'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:44'!
macSerialAndMIDIPortFile

	^ '/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */

#include "sq.h"
#include "SerialPlugin.h"
#include "MidiPlugin.h"

/* initialize/shutdown */
int midiInit() { return true; }
int midiShutdown() {}
int serialPortInit() { return true; }
int serialPortShutdown() {
	serialPortClose(0);
	serialPortClose(1);
}

/* helper function for MIDI module */
int sqMIDIParameter(int whichParameter, int modify, int newValue);

int sqMIDIParameterSet(int whichParameter, int newValue) {
	sqMIDIParameter(whichParameter, true, newValue);
}

int sqMIDIParameterGet(int whichParameter) {
	sqMIDIParameter(whichParameter, false, 0);
}
/* End of adjustments for pluginized VM */

#include <CommResources.h>
#include <CRMSerialDevices.h>
#include <Devices.h>
#include <QuickTimeComponents.h>
#include <QuickTimeMusic.h>
#include <Serial.h>
#include <Strings.h>

/*** Constants ***/
#define INPUT_BUF_SIZE 1000
#define FIRST_DRUM_KIT 16385

/*** Imported Variables ***/
extern int successFlag;

/*** Serial Ports ***/
#define MAX_PORTS 4
short inRefNum[MAX_PORTS] = {0, 0, 0, 0};
short outRefNum[MAX_PORTS] = {0, 0, 0, 0};
char inputBuffer[MAX_PORTS][INPUT_BUF_SIZE];

/* Quicktime MIDI note allocator and channels */
NoteAllocator na = nil;
NoteChannel channel[16] = {
	nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil};

/* Initial instruments: drums on channel 10, piano on all other channels */
int channelInstrument[16] = {
	1, 1, 1, 1, 1, 1, 1, 1, 1, FIRST_DRUM_KIT, 1, 1, 1, 1, 1, 1};

/* Quicktime MIDI parser state */
enum {idle, want1of2, want2of2, want1of1, sysExclusive};
int state = idle;
int argByte1 = 0;
int argByte2 = 0;
int lastCmdByte = nil;

/* number of argument bytes for each MIDI command */
char argumentBytes[128] = {
	2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	3, 1, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};


/*** Private Functions ***/
int portIsOpen(int portNum);
int portNames(int portNum, char *portName, char *inName, char *outName);
int serialPortCount(void);
int setHandshakeOptions(int portNum, int inFlowCtrl, int outFlowCtrl, int xOnChar, int xOffChar);
int setMidiClockRate(int portNum, int interfaceClockRate);

/*** Quicktime MIDI Support Functions ***/
void closeQuicktimeMIDIPort(void);
void openQuicktimeMIDIPort(void);
void performMIDICmd(int cmdByte, int arg1, int arg2);
void processMIDIByte(int aByte);
void startMIDICommand(int cmdByte);

int serialPortCount(void) {
  /* Return the number of serial ports available on this machine */

#if TARGET_API_MAC_CARBON
    return false;
#else
 	CRMRec		commRec;
 	CRMRecPtr	thisRecPtr;
 	int			count = 0;
 
	InitCRM();
 	commRec.crmDeviceType = crmSerialDevice;
 	commRec.crmDeviceID = 0;
	thisRecPtr = (CRMRecPtr) CRMSearch(&commRec);
 	while (thisRecPtr !!= nil) {
 		count++;
		commRec.crmDeviceID = thisRecPtr->crmDeviceID;
		thisRecPtr = (CRMRecPtr) CRMSearch(&commRec);
    }
    if (count > MAX_PORTS) count = MAX_PORTS;
 	return count;
#endif
 }

int portIsOpen(int portNum) {
	if ((portNum < 0) || (portNum > 1)) return false;
	return outRefNum[portNum] !!= 0;
}

int portNames(int portNum, char *portName, char *inName, char *outName) {
/* Fill in the user name and input and output port names for the given
   port number. Note that ports are numbered starting with zero. */

#if TARGET_API_MAC_CARBON
    return false;
#else
 	CRMRec			commRec;
 	CRMRecPtr		thisRecPtr;
 	CRMSerialPtr	serialPtr;
 	int				count = 0;
 
 	portName[0] = inName[0] = outName[0] = 0;
	InitCRM();
 	commRec.crmDeviceType = crmSerialDevice;
 	commRec.crmDeviceID = 0;
	thisRecPtr = (CRMRecPtr) CRMSearch(&commRec);
 	while (thisRecPtr !!= nil) {
 		if (count == portNum) {
			serialPtr = (CRMSerialPtr) thisRecPtr->crmAttributes;
			CopyPascalStringToC((void *) *(serialPtr->name),portName);
			CopyPascalStringToC((void *) *(serialPtr->inputDriverName),inName);
			CopyPascalStringToC((void *) *(serialPtr->outputDriverName),outName);
 		}
 		count++;
		commRec.crmDeviceID = thisRecPtr->crmDeviceID;
		thisRecPtr = (CRMRecPtr) CRMSearch(&commRec);
    }
#endif
 }

int setHandshakeOptions(
  int portNum, int inFlowCtrl, int outFlowCtrl, int xOnChar, int xOffChar) {
/* Set the given port''s handshaking parameters. */
#if TARGET_API_MAC_CARBON
    return false;
#else

	SerShk handshakeOptions;
	int osErr;

	if (!!portIsOpen(portNum)) {
		return success(false);
	}

	handshakeOptions.fInX = false;
	handshakeOptions.fDTR = false;
	if (inFlowCtrl == 1) handshakeOptions.fInX = true;  /* XOn/XOff handshaking */
	if (inFlowCtrl == 2) handshakeOptions.fDTR = true;  /* hardware handshaking */

	handshakeOptions.fXOn = false;
	handshakeOptions.fCTS = false;
	if (outFlowCtrl == 1) handshakeOptions.fXOn = true;  /* XOn/XOff handshaking */
	if (outFlowCtrl == 2) handshakeOptions.fCTS = true;  /* hardware handshaking */

	handshakeOptions.xOn  = xOnChar;	/* XOn character */
	handshakeOptions.xOff = xOffChar;	/* XOff character */
	handshakeOptions.errs = 0;			/* clear errors mask bits */
	handshakeOptions.evts = 0;			/* clear event enable mask bits */

	osErr = Control(outRefNum[portNum], 14, &handshakeOptions);
	if (osErr !!= noErr) {
		success(false);
	}
#endif
}

int setMidiClockRate(int portNum, int interfaceClockRate) {
/* Put the given port into MIDI mode, which uses a clock supplied
   by an external MIDI interface adaptor to determine the baud rate.
   Possible external clock rates: 31.25 KHz, 0.5 MHz, 1 MHz, or 2 MHz. */
#if TARGET_API_MAC_CARBON
    return false;
#else

	char midiParam = 15;  /* dummy value */
	int osErr;

	if (!!portIsOpen(portNum)) {
		return success(false);
	}

	if (interfaceClockRate ==   31250) midiParam = 0x00;
	if (interfaceClockRate ==  500000) midiParam = 0x40;
	if (interfaceClockRate == 1000000) midiParam = 0x80;
	if (interfaceClockRate == 2000000) midiParam = 0xC0;
	if (midiParam == 15) {
		return success(false);  /* bad interfaceClockRate */
	}

	osErr = Control(outRefNum[portNum], 15, &midiParam);
	if (osErr !!= noErr) {
		return success(false);
	}
#endif
}

/*** Serial Port Functions ***/

int serialPortClose(int portNum) {
#if TARGET_API_MAC_CARBON
    return false;
#else
	int osErr;

	if ((portNum < 0) || (portNum > 1)) {
		return success(false); /* bad port number */
	}
	if (!!portIsOpen(portNum)) {
		return;  /* already closed */
	}
	osErr = KillIO(outRefNum[portNum]);
	if (osErr !!= noErr) {
		success(false);
	}
	osErr = CloseDriver(inRefNum[portNum]);
	if (osErr !!= noErr) {
		success(false);
	}
	osErr = CloseDriver(outRefNum[portNum]);
	if (osErr !!= noErr) {
		success(false);
	}

	inRefNum[portNum] = 0;
	outRefNum[portNum] = 0;
#endif
}

int serialPortOpen(
  int portNum, int baudRate, int stopBitsType, int parityType, int dataBits,
  int inFlowCtrl, int outFlowCtrl, int xOnChar, int xOffChar) {
/* Open the given serial port using the given settings. The baud rate can be
   any number between about 224 and 57600; the driver will pick a clock
   divisor that will generate the closest available baud rate. */
#if TARGET_API_MAC_CARBON
    return false;
#else

	short int options, baudRateParam;
	char userName[256], inName[256], outName[256];
	int osErr;

	if ((portNum < 0) || (portNum > 1) || portIsOpen(portNum)) {
		return success(false); /* bad port number or port already open */
	}

	options = baud9600;
	switch (stopBitsType) {
	case 0:
		options += stop15;
		break;
	case 1:
		options += stop10;
		break;
	case 2:
		options += stop20;
		break;
	default:
		return success(false);
	}

	switch (parityType) {
	case 0:
		options += noParity;
		break;
	case 1:
		options += oddParity;
		break;
	case 2:
		options += evenParity;
		break;
	default:
		return success(false);
	}

	switch (dataBits) {
	case 5:
		options += data5;
		break;
	case 6:
		options += data6;
		break;
	case 7:
		options += data7;
		break;
	case 8:
		options += data8;
		break;
	default:
		return success(false);
	}

	portNames(portNum, userName, inName, outName);
	CopyCStringToPascal((const char *)outName,(unsigned char *) outName);
	osErr = OpenDriver((unsigned char *)outName, &outRefNum[portNum]);
	if (osErr !!= noErr) {
		return success(false);
	}
	CopyCStringToPascal((const char *)inName,(unsigned char *)inName);
	osErr = OpenDriver((unsigned char *)inName, &inRefNum[portNum]);
	if (osErr !!= noErr) {
		CloseDriver(outRefNum[portNum]);
		return success(false);
	}

	/* set the handshaking options */
	setHandshakeOptions(portNum, inFlowCtrl, outFlowCtrl, xOnChar, xOffChar);

	/* install a larger input buffer */
	osErr = SerSetBuf(inRefNum[portNum], &inputBuffer[portNum][0], INPUT_BUF_SIZE);
	if (osErr !!= noErr) {
		success(false);
	}

	/* set data bits, parity type, and stop bits */
	osErr = SerReset(outRefNum[portNum], options);
	if (osErr !!= noErr) {
		success(false);
	}

	/* set the baud rate (e.g., the value 9600 gives 9600 baud) */
	baudRateParam = baudRate;
	osErr = Control(outRefNum[portNum], 13, &baudRateParam);
	if (osErr !!= noErr) {
		success(false);
	}

	if (!!successFlag) {
		CloseDriver(inRefNum[portNum]);
		CloseDriver(outRefNum[portNum]);
		inRefNum[portNum] = 0;
		outRefNum[portNum] = 0;
	}
#endif
}

int serialPortReadInto(int portNum, int count, int bufferPtr) {
/* Read up to count bytes from the given serial port into the given byte array.
   Read only up to the number of bytes in the port''s input buffer; if fewer bytes
   than count have been received, do not wait for additional data to arrive.
   Return zero if no data is available. */
#if TARGET_API_MAC_CARBON
    return false;
#else

	long int byteCount;
	int osErr;

	if (!!portIsOpen(portNum)) {
		return success(false);
	}

	osErr = SerGetBuf(inRefNum[portNum], &byteCount);  /* bytes available */
	if (osErr !!= noErr) {
		return success(false);
	}

	if (byteCount > count) byteCount = count;  /* read at most count bytes */
	osErr = FSRead(inRefNum[portNum], &byteCount, (char *) bufferPtr);
	if (osErr !!= noErr) {
		return success(false);
	}
	return byteCount;
#endif
}

int serialPortWriteFrom(int portNum, int count, int bufferPtr) {
/* Write count bytes from the given byte array to the given serial port''s
   output buffer. Return the number of bytes written. This implementation is
   synchronous: it doesn''t return until the data has been sent. However, other
   implementations may return before transmission is complete. */

	long int byteCount = count;
	int osErr;

	if (!!portIsOpen(portNum)) {
		return success(false);
	}

	osErr = FSWrite(outRefNum[portNum], &byteCount, (char *) bufferPtr);
	if (osErr !!= noErr) {
		return success(false);
	}
	return byteCount;
}

/*** MIDI Parameters (used with sqMIDIParameter function) ***/

#define sqMIDIInstalled				1
/* Read-only. Return 1 if a MIDI driver is installed, 0 if not.
   On OMS-based MIDI drivers, this returns 1 only if the OMS
   system is properly installed and configured. */

#define sqMIDIVersion				2
/* Read-only. Return the integer version number of this MIDI driver.
   The version numbering sequence is relative to a particular driver.
   That is, version 3 of the Macintosh MIDI driver is not necessarily
   related to version 3 of the Win95 MIDI driver. */

#define sqMIDIHasBuffer				3
/* Read-only. Return 1 if this MIDI driver has a time-stamped output
   buffer, 0 otherwise. Such a buffer allows the client to schedule
   MIDI output packets to be sent later. This can allow more precise
   timing, since the driver uses timer interrupts to send the data
   at the right time even if the processor is in the midst of a
   long-running Squeak primitive or is running some other application
   or system task. */

#define sqMIDIHasDurs				4
/* Read-only. Return 1 if this MIDI driver supports an extended
   primitive for note-playing that includes the note duration and
   schedules both the note-on and the note-off messages in the
   driver. Otherwise, return 0. */

#define sqMIDICanSetClock			5
/* Read-only. Return 1 if this MIDI driverÕs clock can be set
   via an extended primitive, 0 if not. */

#define sqMIDICanUseSemaphore		6
/* Read-only. Return 1 if this MIDI driver can signal a semaphore
   when MIDI input arrives. Otherwise, return 0. If this driver
   supports controller caching and it is enabled, then incoming
   controller messages will not signal the semaphore. */

#define sqMIDIEchoOn				7
/* Read-write. If this flag is set to a non-zero value, and if
   the driver supports echoing, then incoming MIDI events will
   be echoed immediately. If this driver does not support echoing,
   then queries of this parameter will always return 0 and
   attempts to change its value will do nothing. */

#define sqMIDIUseControllerCache	8
/* Read-write. If this flag is set to a non-zero value, and if
   the driver supports a controller cache, then the driver will
   maintain a cache of the latest value seen for each MIDI controller,
   and control update messages will be filtered out of the incoming
   MIDI stream. An extended MIDI primitive allows the client to
   poll the driver for the current value of each controller. If
   this driver does not support a controller cache, then queries
   of this parameter will always return 0 and attempts to change
   its value will do nothing. */

#define sqMIDIEventsAvailable		9
/* Read-only. Return the number of MIDI packets in the input queue. */

#define sqMIDIFlushDriver			10
/* Write-only. Setting this parameter to any value forces the driver
   to flush its I/0 buffer, discarding all unprocessed data. Reading
   this parameter returns 0. Setting this parameter will do nothing
   if the driver does not support buffer flushing. */

#define sqMIDIClockTicksPerSec		11
/* Read-only. Return the MIDI clock rate in ticks per second. */

#define sqMIDIHasInputClock			12
/* Read-only. Return 1 if this MIDI driver timestamps incoming
   MIDI data with the current value of the MIDI clock, 0 otherwise.
   If the driver does not support such timestamping, then the
   client must read input data frequently and provide its own
   timestamping. */

/*** MIDI Functions ***/

int sqMIDIClosePort(int portNum) {
/* Close the given MIDI port. Do nothing if the port is not open.
   Fail if there is no port of the given number.*/

	int serialPorts;
	
	serialPorts = serialPortCount();
	if (portNum == serialPorts) {
		closeQuicktimeMIDIPort();
		return;
	} else {
		return serialPortClose(portNum);
	}
}

int sqMIDIGetClock(void) {
/* Return the current value of the clock used to schedule MIDI events.
   The MIDI clock is assumed to wrap at or before half the maximum
   positive SmallInteger value. This allows events to be scheduled
   into the future without overflowing into LargePositiveIntegers. 
   This implementation does not support event scheduling, so it
   just returns the value of the Squeak millisecond clock. */

	return ioMicroMSecs();
}

int sqMIDIGetPortCount(void) {
/* Return the number of available MIDI interfaces, including both
   hardware ports and software entities that act like ports. Ports
   are numbered from 0 to N-1, where N is the number returned by this
   primitive. */

	return serialPortCount() + 1;  /* serial ports + QuickTime Synth */
}

int sqMIDIGetPortDirectionality(int portNum) {
/* Return an integer indicating the directionality of the given
   port where: 1 = input, 2 = output, 3 = bidirectional. Fail if
   there is no port of the given number. */

	
	int serialPorts;
	
	serialPorts = serialPortCount();
	if (portNum > serialPorts) return success(false);
	if (portNum == serialPorts) {
		return 2;
	} else {
		return 3;
	}
}

int sqMIDIGetPortName(int portNum, int namePtr, int length) {
/* Copy the name of the given MIDI port into the string at the given
   address. Copy at most length characters, and return the number of
   characters copied. Fail if there is no port of the given number.*/

	char userName[256], inName[256], outName[256];
	int serialPorts, count;
	
	serialPorts = serialPortCount();
	if (portNum > serialPorts) return success(false);

	if (portNum == serialPorts) {
		strcpy(userName, "QuickTime MIDI");
	} else {
		portNames(portNum, userName, inName, outName);
	}

	count = strlen(userName);
	if (count > length) count = length;
	memcpy((void *) namePtr, userName, count);
	return count;
}

int sqMIDIOpenPort(int portNum, int readSemaIndex, int interfaceClockRate) {
/* Open the given port, if possible. If non-zero, readSemaphoreIndex
   specifies the index in the external objects array of a semaphore
   to be signalled when incoming MIDI data is available. Note that
   not all implementations support read semaphores (this one does
   not); see sqMIDICanUseSemaphore. The interfaceClockRate parameter
   specifies the clock speed for an external MIDI interface
   adaptor on platforms that use such adaptors (e.g., Macintosh).
   Fail if there is no port of the given number.*/

	int serialPorts;
	
	serialPorts = serialPortCount();
	if (portNum > serialPorts) return success(false);

	if (portNum == serialPorts) {
		openQuicktimeMIDIPort();
		return;
	}

	serialPortOpen(portNum, 9600, 1, 0, 8, 0, 0, 0, 0);
	if (successFlag) {
		setMidiClockRate(portNum, interfaceClockRate);
		if (!!successFlag) {
			serialPortClose(portNum);
		}
	}
}

int sqMIDIParameter(int whichParameter, int modify, int newValue) {
/* Read or write the given MIDI driver parameter. If modify is 0,
   then newValue is ignored and the current value of the specified
   parameter is returned. If modify is non-zero, then the specified
   parameter is set to newValue. Note that many MIDI driver parameters
   are read-only; attempting to set one of these parameters fails.
   For boolean parameters, true = 1, false = 0. */

	if (modify == 0) {
		switch(whichParameter) {
		case sqMIDIInstalled:
			return 1;
			break;
		case sqMIDIVersion:
			return 100;
			break;
		case sqMIDIHasBuffer:
		case sqMIDIHasDurs:
		case sqMIDICanSetClock:
		case sqMIDICanUseSemaphore:
		case sqMIDIEchoOn:
		case sqMIDIUseControllerCache:
			return 0;
			break;
		case sqMIDIEventsAvailable:
			return 1;  /* pretend that events are always available */
			break;
		case sqMIDIFlushDriver:
			return 0;
			break;
		case sqMIDIClockTicksPerSec:
			return 1000;
			break;
		case sqMIDIHasInputClock:
			return 0;
			break;
		default:
			return success(false);
		}
	} else {
		switch(whichParameter) {
		case sqMIDIInstalled:
		case sqMIDIVersion:
		case sqMIDIHasBuffer:
		case sqMIDIHasDurs:
		case sqMIDICanSetClock:
		case sqMIDICanUseSemaphore:
			return success(false);
			break;
		case sqMIDIEchoOn:
			/* noop; echoing not supported */
			break;
		case sqMIDIUseControllerCache:
			/* noop; controller cache not supported */
			break;
		case sqMIDIEventsAvailable:
			return success(false);
			break;
		case sqMIDIFlushDriver:
			/* noop; buffer flushing not supported */
			break;
		case sqMIDIClockTicksPerSec:
			return success(false);
			break;
		default:
			return success(false);
		}
	}
}

int sqMIDIPortReadInto(int portNum, int count, int bufferPtr) {
/* bufferPtr is the address of the first byte of a Smalltalk
   ByteArray of the given length. Copy up to (length - 4) bytes
   of incoming MIDI data into that buffer, preceded by a 4-byte
   timestamp in the units of the MIDI clock, most significant byte
   first. Implementations that do not support timestamping of
   incoming data as it arrives (see sqMIDIHasInputClock) simply
   set the timestamp to the value of the MIDI clock when this
   function is called. Return the total number of bytes read,
   including the timestamp bytes. Return zero if no data is
   available. Fail if the buffer is shorter than five bytes,
   since there must be enough room for the timestamp plus at
   least one data byte. */

	int bytesRead;

	if (count < 5) return success(false);
	bytesRead = serialPortReadInto(portNum, count - 4, bufferPtr + 4);
	if (bytesRead == 0) return 0;
	*((int *) bufferPtr) = sqMIDIGetClock();  /* set timestamp */
	return bytesRead + 4;
}

int sqMIDIPortWriteFromAt(int portNum, int count, int bufferPtr, int time) {
/* bufferPtr is the address of the first byte of a Smalltalk
   ByteArray of the given length. Send its contents to the given
   port when the MIDI clock reaches the given time. If time equals
   zero, then send the data immediately. Implementations that do
   not support a timestamped output queue, such as this one, always
   send the data immediately; see sqMIDIHasBuffer. */

	int serialPorts, i;
	unsigned char *bytePtr;
	
	serialPorts = serialPortCount();
	if (portNum > serialPorts) return success(false);

	if (portNum == serialPorts) {
		if (!!na) return success(false);  /* QuickTime port not open */
		bytePtr = (unsigned char *) bufferPtr;
		for (i = 0; i < count; i++) {
			processMIDIByte(*bytePtr++);
		}
		return count;
	}
	return serialPortWriteFrom(portNum, count, bufferPtr);
}

/*** Quicktime MIDI Support Functions ***/

void closeQuicktimeMIDIPort(void) {
	int i;

	if (!!na) return;
	for (i = 0; i < 16; i++) {
		/* dispose of note channels */
		if (channel[i]) NADisposeNoteChannel(na, channel[i]);
		channel[i] = nil;
	}
	CloseComponent(na);  /* close note allocator */
}

void openQuicktimeMIDIPort(void) {
	ComponentResult err;
	NoteRequest nr;
	NoteChannel nc;
	int i;

	closeQuicktimeMIDIPort();
	na = OpenDefaultComponent(''nota'', 0);
	if (!!na) return;

	for (i = 0; i < 16; i++) {
		nr.info.polyphony = 11;					/* max simultaneous tones */
		nr.info.typicalPolyphony = 0x00010000;	/* typical simultaneous tones */
		NAStuffToneDescription(na, 1, &nr.tone);
		err = NANewNoteChannel(na, &nr, &nc);
		if (err || !!nc) {
			closeQuicktimeMIDIPort();
			return;
		}
		NAResetNoteChannel(na, nc);
		NASetInstrumentNumber(na, nc, channelInstrument[i]);
		channel[i] = nc;
	}
	state = idle;
	argByte1 = 0;
	argByte2 = 0;
	lastCmdByte = nil;
	return;
}

void performMIDICmd(int cmdByte, int arg1, int arg2) {
	/* Perform the given MIDI command with the given arguments. */

	int ch, cmd, val, instrument, bend;

	ch = cmdByte & 0x0F;
	cmd = cmdByte & 0xF0;
	if (cmd == 128) {  /* note off */
		NAPlayNote(na, channel[ch], arg1, 0);
	}
	if (cmd == 144) {  /* note on */
		NAPlayNote(na, channel[ch], arg1, arg2);
	}
	if (cmd == 176) {  /* control change */
		if ((arg1 >= 32) && (arg1 <= 63)) {
			val = arg2 << 1;  /* LSB of controllers 0-31 */
		} else {
			val = arg2 << 8;  /* scale MSB to QT controller range */
		}
		NASetController(na, channel[ch], arg1, val);
	}
	if (cmd == 192) {  /* program change */
		if (ch == 9) {
			instrument = FIRST_DRUM_KIT + arg1;  /* if channel 10, select a drum set */
		} else {
			instrument = arg1 + 1;
		}
		NASetInstrumentNumber(na, channel[ch], instrument);
		channelInstrument[ch] = instrument;
	}
	if (cmd == 224) {  /* pitch bend */
		bend = ((arg2 << 7) + arg1) - (64 << 7);
		bend = bend / 32;  /* default sensitivity = +/- 2 semitones */
		NASetController(na, channel[ch], kControllerPitchBend, bend);
	}
}

void processMIDIByte(int aByte) {
	/* Process the given incoming MIDI byte and perform any completed commands. */

	if (aByte > 247) return;  /* skip all real-time messages */

	switch (state) {
	case idle:
		if (aByte >= 128) {
			/* start a new command using the action table */
			startMIDICommand(aByte);
		} else {
			/* data byte arrived in idle state: use running status if possible */
			if (lastCmdByte == nil) {
				return;  /* last command byte is not defined; just skip this byte */
			} else {
				/* process this data as if it had the last command byte in front of it */
				startMIDICommand(lastCmdByte);
				/* the previous line put us into a new state; we now do a recursive
			   	   call to process the data byte in this new state. */
				processMIDIByte(aByte);
				return;
			}
		}
		break;
	case want1of2:
		argByte1 = aByte;
		state = want2of2;
		break;
	case want2of2:
		argByte2 = aByte;
		performMIDICmd(lastCmdByte, argByte1, argByte2);
		state = idle;
		break;
	case want1of1:
		argByte1 = aByte;
		performMIDICmd(lastCmdByte, argByte1, 0);
		state = idle;
		break;
	case sysExclusive:
		if (aByte < 128) {
			/* skip a system exclusive data byte */
		} else {
			if (aByte < 248) {
				/* a system exclusive message can be terminated by any non-real-time command byte */
				state = idle;
				if (aByte !!= 247) {
					processMIDIByte(aByte);	/* if not endSysExclusive, byte is the start the next command */
				}
			}
		}
		break;
	}
}

void startMIDICommand(int cmdByte) {
	/* Start processing a MIDI message beginning with the given command byte. */

	int argCount;

	argCount = argumentBytes[cmdByte - 128];
	switch (argCount) {
	case 0:						/* start a zero argument command (e.g., a real-time message) */
		/* Stay in the current state and don''t change active status.
		   Real-time messages may arrive between data bytes without disruption. */
		performMIDICmd(cmdByte, 0, 0);
		break;
	case 1:						/* start a one argument command */
		lastCmdByte = cmdByte;
		state = want1of1;
		break;
	case 2:						/* start a two argument command */
		lastCmdByte = cmdByte;
		state = want1of2;
		break;
	case 3:						/* start a variable length ''system exclusive'' command */
		/* a system exclusive command clears running status */
		lastCmdByte = nil;
		state = sysExclusive;
		break;
	}
}
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:45'!
macSoundFile

	^ '/*
Carbon porting notes:

	Carbon doesn''t support the SndPlayDoubleBuffer system routine.
	This is a command you put in the sound channel which repeatedly
	calls a callback routine.
	
	Technote 1198 describes the situation, a work-around and provides
	example code.  I merely added this code to the end of this file
	and plugged it into the existing Squeak code.

Karl Goiser 14/01/01
*/

//johnmci@smalltalkconsulting.com Nov 6th 2000. Added sound volume logic

/* Adjustments for pluginized VM
 *
 * Note: The Mac support files have not yet been fully converted to
 * pluginization. For the time being, it is assumed that they are linked
 * with the VM. When conversion is complete, they will no longer import
 * "sq.h" and they will access all VM functions and variables through
 * the interpreterProxy mechanism.
 */
 
#include "sq.h"
#include "SoundPlugin.h"

/* initialize/shutdown */
int soundInit() { return true; }
int soundShutdown() { snd_Stop(); }

/* End of adjustments for pluginized VM */

#include <Sound.h>
#include <SoundInput.h>

/******
  Mac Sound Output Notes:

	The Squeak sound code produces 16-bit, stereo sound buffers. The was
	arrived at after experimentation on a PPC 601 at 110 MHz on which I
	found that:
	  a. using 16-bit sound only slightly increased the background CPU burden and
	  b. 16-bit sound yielded vastly superior sound quality.

	My understanding is that SoundManager 3.0 or later supports the 16-bit
	sound interface an all Macs, even if the hardware only supports 8-bits.
	If this is not true, however, change BYTES_PER_SAMPLE to 1. Then, either
	the Squeak code will need to be changed to use 8-bit sound buffers,
	or (preferrably) snd_PlaySamplesFromAtLength will need to do the conversion
	from 16 to 8 bits. I plan to cross that bridge if and when we need to.
	The code as currently written was to support Squeak code that generated
	8-bit sound buffers.

	In earlier versions, I experimented with other sound buffer formats. Here
	are all the sound buffer formats that were used at one point or another:
		1. mono,    8-bits -- packed array of bytes (not currently used)
		2. stereo,  8-bits -- as above, with L and R channels in alternate bytes (not currently used)
		3. stereo, 16-bits -- array of 32-bit words; with L and R channels in high and low half-words

	Note:  8-bit samples are encoded with 0x80 as the center (zero) value
	Note: 16-bit samples are encoded as standard, signed integers (i.e., 2''s-complement)
	Note: When the sound drive is operating in "mono", the two stereo channels are mixed
	      together. This feature was added in January, 1998.

	-- John Maloney, July 28, 1996
	-- edited: John Maloney, January 5, 1998

  Mac Sound Input Notes:

	Squeak sound input is currently defined to provide a single (mono) stream
	of signed 16-bit samples for all platforms. Platforms that only support
	8-bit sound input should convert samples to signed 16 bit values, leaving
	the low order bits zero. Since the available sampling rates differ from
	platform to platform, the client may not get the requested sampling rate;
	however, the call snd_GetRecordingSampleRate returns the sampling rate.
	On many platforms, simultaneous record and playback is permitted only if
	the input and output sampling rates are the same.

	-- John Maloney, Aug 22, 1997

******/

#define BYTES_PER_SAMPLE 2

/*** double-buffer state record ***/

typedef struct {
	int open;
	int stereo;
	int frameCount;
	int sampleRate;
	int lastFlipTime;
	int playSemaIndex;
	int bufSizeInBytes;
	int bufState0;
	int bufState1;
	int done;
} PlayStateRec;

/*** possible buffer states ***/

#define BUF_EMPTY	0
#define BUF_FULL	1
#define BUF_PLAYING	2

/*** record buffer state record ***/

/* Note: RECORD_BUFFER_SIZE should be a multiple of 4096 bytes to avoid clicking.
   (The clicking was observed on a Mac 8100; the behavior of other Macs could differ.)
   Note: G3 Series Powerbook requires minimum of 4 * 4096 buffer size for stereo.
*/
#define RECORD_BUFFER_SIZE (4096 * 2)
typedef struct {
	SPB paramBlock;
	int stereo;
	int bytesPerSample;
	int recordSemaIndex;
	int readIndex;  /* index of the next sample to read */
	char samples[RECORD_BUFFER_SIZE];
} RecordBufferRec, *RecordBuffer;

/*** sound output variables ***/

SndChannelPtr chan;
PlayStateRec bufState = {false, false, 0, 0, 0, 0, 0, 0, 0, true};
SndDoubleBufferHeader dblBufHeader;

/*** sound input variables ***/

RecordBufferRec recordBuffer1, recordBuffer2;
int recordingInProgress;
long soundInputRefNum;

/*** local functions ***/

pascal void DoubleBack(SndChannelPtr chan, SndDoubleBufferPtr buf);
int FillBufferWithSilence(SndDoubleBufferPtr buf);
pascal void FlipRecordBuffers(SPBPtr pb);
int MixInSamples(int count, char *srcBufPtr, int srcStartIndex, char *dstBufPtr, int dstStartIndex);

OSErr CarbonSndPlayDoubleBuffer (SndChannelPtr chan, SndDoubleBufferHeaderPtr theParams);


pascal void DoubleBack(SndChannelPtr chan, SndDoubleBufferPtr buf) {
  /* Switch buffers (at interrupt time). The given buffer just finished playing. */

	PlayStateRec *state;

	chan;  /* reference argument to avoid compiler warnings */

	state = (PlayStateRec *) buf->dbUserInfo[0];
	if (buf->dbUserInfo[1] == 0) {
		state->bufState0 = BUF_EMPTY;
		state->bufState1 = BUF_PLAYING;
	} else {
		state->bufState0 = BUF_PLAYING;
		state->bufState1 = BUF_EMPTY;
	}

	buf->dbNumFrames = state->frameCount;
	buf->dbFlags = buf->dbFlags | dbBufferReady;
	if (state->done) {
		buf->dbFlags = buf->dbFlags | dbLastBuffer;
	} else {
		signalSemaphoreWithIndex(state->playSemaIndex);
	}
	state->lastFlipTime = ioMicroMSecs();
	FillBufferWithSilence(buf);  /* avoids ugly stutter if not filled in time */
}

int FillBufferWithSilence(SndDoubleBufferPtr buf) {
	unsigned int *sample, *lastSample;

	sample		= (unsigned int *) &buf->dbSoundData[0];
	lastSample	= (unsigned int *) &buf->dbSoundData[bufState.bufSizeInBytes];

	/* word-fill buffer with silence */
	if (BYTES_PER_SAMPLE == 1) {
		while (sample < lastSample) {
			*sample++ = 0x80808080;  /* Note: 0x80 is zero value for 8-bit samples */
		}
	} else {
		while (sample < lastSample) {
			*sample++ = 0;
		}
	}
}

pascal void FlipRecordBuffers(SPBPtr pb) {
	/* called at interrupt time to exchange the active and inactive record buffers */
	RecordBuffer thisBuffer = (RecordBuffer) pb;
	RecordBuffer nextBuffer = (RecordBuffer) pb->userLong;

	if (pb->error == 0) {
		/* restart recording using the other buffer */
		SPBRecord(&nextBuffer->paramBlock, true);

		/* reset the read pointer for the buffer that has just been filled */
		thisBuffer->readIndex = 0;
		signalSemaphoreWithIndex(nextBuffer->recordSemaIndex);
	}
}

/*** exported sound output functions ***/

int snd_AvailableSpace(void) {
	if (!!bufState.open) return -1;
	if ((bufState.bufState0 == BUF_EMPTY) ||
		(bufState.bufState1 == BUF_EMPTY)) {
			return bufState.bufSizeInBytes;
	}
	return 0;
}

int snd_PlaySamplesFromAtLength(int frameCount, int arrayIndex, int startIndex) {
	SndDoubleBufferPtr buf;
	int framesWritten;

	if (!!bufState.open) return -1;

	if (bufState.bufState0 == BUF_EMPTY) {
		buf = dblBufHeader.dbhBufferPtr[0];
		bufState.bufState0 = BUF_FULL;
	} else {
		if (bufState.bufState1 == BUF_EMPTY) {
			buf = dblBufHeader.dbhBufferPtr[1];
			bufState.bufState1 = BUF_FULL;
		} else {
			return 0;  /* neither buffer is available */
		}
	}

	if (bufState.frameCount < frameCount) {
		framesWritten = bufState.frameCount;
	} else {
		framesWritten = frameCount;
	}

	if (BYTES_PER_SAMPLE == 1) {  /* 8-bit samples */
		unsigned char *src, *dst, *end;
		src = (unsigned char *) (arrayIndex + startIndex);
		end = (unsigned char *) src + (framesWritten * (bufState.stereo ? 2 : 1));
		dst = (unsigned char *) &buf->dbSoundData[0];
		while (src < end) {
			*dst++ = *src++;
		}
	} else {  /* 16-bit samples */
		short int *src, *dst, *end;
		src = (short int *) (arrayIndex + (startIndex * 4));
		end = (short int *) (arrayIndex + ((startIndex + framesWritten) * 4));
		dst = (short int *) &buf->dbSoundData[0];
		if (bufState.stereo) {  /* stereo */
			while (src < end) {
				*dst++ = *src++;
			}
		} else {  /* mono */
			/* if mono, average the left and right channels of the source */
			while (src < end) {
				*dst++ = (*src++ + *src++) / 2;
			}
		}
	}
	return framesWritten;
}

int MixInSamples(int count, char *srcBufPtr, int srcStartIndex, char *dstBufPtr, int dstStartIndex) {
	int sample;

	if (BYTES_PER_SAMPLE == 1) {  /* 8-bit samples */
		unsigned char *src, *dst, *end;
		src = (unsigned char *) srcBufPtr + srcStartIndex;
		end = (unsigned char *) srcBufPtr + (count * (bufState.stereo ? 2 : 1));
		dst = (unsigned char *) dstBufPtr + dstStartIndex;
		while (src < end) {
			sample = *dst + (*src++ - 128);
			if (sample > 255) sample = 255;
			if (sample < 0) sample = 0;
			*dst++ = sample;
		}
	} else {  /* 16-bit samples */
		short int *src, *dst, *end;
		src = (short int *) (srcBufPtr + (srcStartIndex * 4));
		end = (short int *) (srcBufPtr + ((srcStartIndex + count) * 4));
		if (bufState.stereo) {  /* stereo */
			dst = (short int *) (dstBufPtr + (dstStartIndex * 4));
			while (src < end) {
				sample = *dst + *src++;
				if (sample > 32767) sample = 32767;
				if (sample < -32767) sample = -32767;
				*dst++ = sample;
			}
		} else {  /* mono */
			/* if mono, average the left and right channels of the source */
			dst = (short int *) (dstBufPtr + (dstStartIndex * 2));
			while (src < end) {
				sample = *dst + ((*src++ + *src++) / 2);
				if (sample > 32767) sample = 32767;
				if (sample < -32767) sample = -32767;
				*dst++ = sample;
			}
		}
	}
}

int snd_InsertSamplesFromLeadTime(int frameCount, int srcBufPtr, int samplesOfLeadTime) {
	SndDoubleBufferPtr bufPlaying, otherBuf;
	int samplesInserted, startSample, count;

	if (!!bufState.open) return -1;

	if (bufState.bufState0 == BUF_PLAYING) {
		bufPlaying = dblBufHeader.dbhBufferPtr[0];
		otherBuf = dblBufHeader.dbhBufferPtr[1];
	} else {
		bufPlaying = dblBufHeader.dbhBufferPtr[1];
		otherBuf = dblBufHeader.dbhBufferPtr[0];
	}

	samplesInserted = 0;

	/* mix as many samples as can fit into the remainder of the currently playing buffer */
	startSample =
		((bufState.sampleRate * (ioMicroMSecs() - bufState.lastFlipTime)) / 1000) + samplesOfLeadTime;
	if (startSample < bufState.frameCount) {
		count = bufState.frameCount - startSample;
		if (count > frameCount) count = frameCount;
		MixInSamples(count, (char *) srcBufPtr, 0, (char *) &bufPlaying->dbSoundData[0], startSample);
		samplesInserted = count;
	}

	/* mix remaining samples into the inactive buffer */
	count = bufState.frameCount;
	if (count > (frameCount - samplesInserted)) {
		count = frameCount - samplesInserted;
	}
	MixInSamples(count, (char *) srcBufPtr, samplesInserted, (char *) &otherBuf->dbSoundData[0], 0);
	return samplesInserted + count;
}

int snd_PlaySilence(void) {
	if (!!bufState.open) return -1;

	if (bufState.bufState0 == BUF_EMPTY) {
		FillBufferWithSilence(dblBufHeader.dbhBufferPtr[0]);
		bufState.bufState0 = BUF_FULL;
	} else {
		if (bufState.bufState1 == BUF_EMPTY) {
			FillBufferWithSilence(dblBufHeader.dbhBufferPtr[1]);
			bufState.bufState1 = BUF_FULL;
		} else {
			return 0;  /* neither buffer is available */
		}
	}
	return bufState.bufSizeInBytes;
}

int snd_Start(int frameCount, int samplesPerSec, int stereo, int semaIndex) {
	OSErr				err;
	SndDoubleBufferPtr	buffer;
	int					bytesPerFrame, bufferBytes, i;

	bytesPerFrame			= stereo ? 2 * BYTES_PER_SAMPLE : BYTES_PER_SAMPLE;
	bufferBytes				= ((frameCount * bytesPerFrame) / 8) * 8;
		/* Note: Must round bufferBytes down to an 8-byte boundary to avoid clicking!!!!!! */

	if (bufState.open) {
		/* still open from last time; clean up before continuing */
		snd_Stop();
	}

	bufState.open			= false;  /* set to true if successful */
	bufState.stereo			= stereo;
	bufState.frameCount		= bufferBytes / bytesPerFrame;
	bufState.sampleRate		= samplesPerSec;
	bufState.lastFlipTime	= ioMicroMSecs();
	bufState.playSemaIndex	= semaIndex;
	bufState.bufSizeInBytes	= bufferBytes;
	bufState.bufState0		= BUF_EMPTY;
	bufState.bufState1		= BUF_EMPTY;
	bufState.done			= false;

	dblBufHeader.dbhNumChannels		= stereo ? 2 : 1;
	dblBufHeader.dbhSampleSize		= BYTES_PER_SAMPLE * 8;
	dblBufHeader.dbhCompressionID	= 0;
	dblBufHeader.dbhPacketSize		= 0;
	dblBufHeader.dbhSampleRate		= samplesPerSec << 16; /* convert to fixed point */
#if TARGET_API_MAC_CARBON
	dblBufHeader.dbhDoubleBack		= nil;
#else
	dblBufHeader.dbhDoubleBack		= NewSndDoubleBackProc(DoubleBack);
#endif

	chan = NULL;
	err = SndNewChannel(&chan, sampledSynth, 0, NULL);
	if (err !!= noErr) return false; /* could not open sound channel */

	for (i = 0; i < 2; i++) {
		buffer = (SndDoubleBufferPtr) NewPtrClear(sizeof(SndDoubleBuffer) + bufState.bufSizeInBytes);
		if (buffer == NULL) {   /* could not allocate memory for a buffer; clean up and abort */
			SndDisposeChannel(chan, true);
#if !!TARGET_API_MAC_CARBON
			DisposeRoutineDescriptor(dblBufHeader.dbhDoubleBack);
#endif
			if (i == 1) {  /* free the first buffer */
				DisposePtr((char *) dblBufHeader.dbhBufferPtr[1]);
				dblBufHeader.dbhBufferPtr[1] = NULL;
			}
			return false;
		}
		buffer->dbNumFrames		= bufState.frameCount;
		buffer->dbFlags			= dbBufferReady;
		buffer->dbUserInfo[0]	= (long) &bufState;
		buffer->dbUserInfo[1]	= i;
		FillBufferWithSilence(buffer);

		dblBufHeader.dbhBufferPtr[i] = buffer;
	}

#if TARGET_API_MAC_CARBON
	err = CarbonSndPlayDoubleBuffer(chan, &dblBufHeader);
#else
	err = SndPlayDoubleBuffer(chan, &dblBufHeader);
#endif
	if (err !!= noErr) return false; /* could not play double buffer */

	bufState.open = true;
	return true;
}

int snd_Stop(void) {
	OSErr				err;
	SndDoubleBufferPtr	buffer;
	SCStatus			status;
	long				i, junk;

	if (!!bufState.open) return;
	bufState.open = false;

	bufState.done = true;
	while (true) {
		err = SndChannelStatus(chan, sizeof(status), &status);
		if (err !!= noErr) break; /* could not get channel status */
		if (!!status.scChannelBusy) break;
		Delay(1, (void *) &junk);
	}
	SndDisposeChannel(chan, true);
#if !!TARGET_API_MAC_CARBON
	DisposeRoutineDescriptor(dblBufHeader.dbhDoubleBack);
#endif

	for (i = 0; i < 2; i++) {
		buffer = dblBufHeader.dbhBufferPtr[i];
		if (buffer !!= NULL) {
			DisposePtr((char *) buffer);
		}
		dblBufHeader.dbhBufferPtr[i] = NULL;
	}
	bufState.open = false;
}

/*** exported sound input functions ***/

int snd_SetRecordLevel(int level) {
	/* set the recording level to a value between 0 (minimum gain) and 1000. */
	Fixed inputGainArg;
	int err;

	if (!!recordingInProgress || (level < 0) || (level > 1000)) {
		success(false);
		return;  /* noop if not recording */
	}

	inputGainArg = ((500 + level) << 16) / 1000;  /* gain is Fixed between 0.5 and 1.5 */
	err = SPBSetDeviceInfo(soundInputRefNum, siInputGain, &inputGainArg);
	/* don''t fail on error; hardware may not support setting the gain */
}

int snd_StartRecording(int desiredSamplesPerSec, int stereo, int semaIndex) {
	/* turn on sound recording, trying to use a sampling rate close to
	   the one specified. semaIndex is the index in the exportedObject
	   array of a semaphore to be signalled when input data is available. */
	Str255 deviceName = "";
	short automaticGainControlArg;
	Fixed inputGainArg;
	long  compressionTypeArg;
	short continuousArg;
	short sampleSizeArg;
	short channelCountArg;
	UnsignedFixed sampleRateArg;
	int err;

	err = SPBOpenDevice(deviceName, siWritePermission, &soundInputRefNum);
	if (err !!= noErr) {
		success(false);
		return;
	}

	/* try to initialize some optional parameters, but don''t fail if we can''t */
	automaticGainControlArg = false;
	SPBSetDeviceInfo(soundInputRefNum, siAGCOnOff, &automaticGainControlArg);
	inputGainArg = 1 << 16;  /* 1.0 in Fixed */
	SPBSetDeviceInfo(soundInputRefNum, siInputGain, &inputGainArg);
	compressionTypeArg = ''NONE'';
	SPBSetDeviceInfo(soundInputRefNum, siCompressionType, &compressionTypeArg);

	continuousArg = true;
	err = SPBSetDeviceInfo(soundInputRefNum, siContinuous, &continuousArg);
	if (err !!= noErr) {
		success(false);
		SPBCloseDevice(soundInputRefNum);
		return;
	}

	sampleSizeArg = 16;
	err = SPBSetDeviceInfo(soundInputRefNum, siSampleSize, &sampleSizeArg);
	if (err !!= noErr) {
		/* use 8-bit samples */
		sampleSizeArg = 8;
		err = SPBSetDeviceInfo(soundInputRefNum, siSampleSize, &sampleSizeArg);
		if (err !!= noErr) {
			success(false);
			SPBCloseDevice(soundInputRefNum);
			return;
		}
	}

	channelCountArg = stereo ? 2 : 1;
	err = SPBSetDeviceInfo(soundInputRefNum, siNumberChannels, &channelCountArg);
	if (err !!= noErr) {
		success(false);
		SPBCloseDevice(soundInputRefNum);
		return;
	}

	/* try to set the client''s desired sample rate */
	sampleRateArg = desiredSamplesPerSec << 16;
	err = SPBSetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);
	if (err !!= noErr) {
		/* if client''s rate fails, try the nearest common sampling rates in {11025, 22050, 44100} */
		if (desiredSamplesPerSec <= 16538) {
			sampleRateArg = 11025 << 16;
		} else {
			if (desiredSamplesPerSec <= 33075) {
				sampleRateArg = 22050 << 16;
			} else {
				sampleRateArg = 44100 << 16;
			}
		}
		/* even if following fails, recording can go on at the default sample rate */
		SPBSetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);
	}

	recordBuffer1.paramBlock.inRefNum = soundInputRefNum;
	recordBuffer1.paramBlock.count = RECORD_BUFFER_SIZE;
	recordBuffer1.paramBlock.milliseconds = 0;
	recordBuffer1.paramBlock.bufferLength = RECORD_BUFFER_SIZE;
	recordBuffer1.paramBlock.bufferPtr = recordBuffer1.samples;
#if TARGET_API_MAC_CARBON
	recordBuffer1.paramBlock.completionRoutine = NewSICompletionUPP(FlipRecordBuffers);
#else
	recordBuffer1.paramBlock.completionRoutine = NewSICompletionProc(FlipRecordBuffers);
#endif
	recordBuffer1.paramBlock.interruptRoutine = nil;
	recordBuffer1.paramBlock.userLong = (long) &recordBuffer2;  /* pointer to other buffer */
	recordBuffer1.paramBlock.error = noErr;
	recordBuffer1.paramBlock.unused1 = 0;
	recordBuffer1.stereo = stereo;
	recordBuffer1.bytesPerSample = sampleSizeArg == 8 ? 1 : 2;
	recordBuffer1.recordSemaIndex = semaIndex;
	recordBuffer1.readIndex = RECORD_BUFFER_SIZE;

	recordBuffer2.paramBlock.inRefNum = soundInputRefNum;
	recordBuffer2.paramBlock.count = RECORD_BUFFER_SIZE;
	recordBuffer2.paramBlock.milliseconds = 0;
	recordBuffer2.paramBlock.bufferLength = RECORD_BUFFER_SIZE;
	recordBuffer2.paramBlock.bufferPtr = recordBuffer2.samples;
#if TARGET_API_MAC_CARBON
	recordBuffer2.paramBlock.completionRoutine = NewSICompletionUPP(FlipRecordBuffers);
#else
	recordBuffer2.paramBlock.completionRoutine = NewSICompletionProc(FlipRecordBuffers);
#endif
	recordBuffer2.paramBlock.interruptRoutine = nil;
	recordBuffer2.paramBlock.userLong = (long) &recordBuffer1;  /* pointer to other buffer */
	recordBuffer2.paramBlock.error = noErr;
	recordBuffer2.paramBlock.unused1 = 0;
	recordBuffer2.stereo = stereo;
	recordBuffer2.bytesPerSample = sampleSizeArg == 8 ? 1 : 2;
	recordBuffer2.recordSemaIndex = semaIndex;
	recordBuffer2.readIndex = RECORD_BUFFER_SIZE;

	err = SPBRecord(&recordBuffer1.paramBlock, true);
	if (err !!= noErr) {
		success(false);
		SPBCloseDevice(soundInputRefNum);
		return;
	}

	recordingInProgress = true;
}

int snd_StopRecording(void) {
	/* turn off sound recording */
	int err;

	if (!!recordingInProgress) return;  /* noop if not recording */

	err = SPBStopRecording(soundInputRefNum);
	if (err !!= noErr) success(false);
	SPBCloseDevice(soundInputRefNum);

#if TARGET_API_MAC_CARBON
	DisposeSICompletionUPP(recordBuffer1.paramBlock.completionRoutine);
#else
	DisposeRoutineDescriptor(recordBuffer1.paramBlock.completionRoutine);
#endif
	recordBuffer1.paramBlock.completionRoutine = nil;
#if TARGET_API_MAC_CARBON
	DisposeSICompletionUPP(recordBuffer2.paramBlock.completionRoutine);
#else
	DisposeRoutineDescriptor(recordBuffer2.paramBlock.completionRoutine);
#endif
	recordBuffer2.paramBlock.completionRoutine = nil;

	recordBuffer1.recordSemaIndex = 0;
	recordBuffer2.recordSemaIndex = 0;
	recordingInProgress = false;
}

double snd_GetRecordingSampleRate(void) {
	/* return the actual recording rate; fail if not currently recording */
	UnsignedFixed sampleRateArg;
	int err;

	if (!!recordingInProgress) {
		success(false);
		return 0.0;
	}

	err = SPBGetDeviceInfo(soundInputRefNum, siSampleRate, &sampleRateArg);
	if (err !!= noErr) {
		success(false);
		return 0.0;
	}
	return  (double) ((sampleRateArg >> 16) & 0xFFFF) +
			((double) (sampleRateArg & 0xFFFF) / 65536.0);
}

int snd_RecordSamplesIntoAtLength(int buf, int startSliceIndex, int bufferSizeInBytes) {
	/* if data is available, copy as many sample slices as possible into the
	   given buffer starting at the given slice index. do not write past the
	   end of the buffer, which is buf + bufferSizeInBytes. return the number
	   of slices (not bytes) copied. a slice is one 16-bit sample in mono
	   or two 16-bit samples in stereo. */
	int bytesPerSlice = (recordBuffer1.stereo ? 4 : 2);
	char *nextBuf = (char *) buf + (startSliceIndex * bytesPerSlice);
	char *bufEnd = (char *) buf + bufferSizeInBytes;
	char *src, *srcEnd;
	RecordBuffer recBuf = nil;
	int bytesCopied;

	if (!!recordingInProgress) {
		success(false);
		return 0;
	}

	/* select the buffer with unread samples, if any */
	recBuf = nil;
	if (recordBuffer1.readIndex < RECORD_BUFFER_SIZE) recBuf = &recordBuffer1;
	if (recordBuffer2.readIndex < RECORD_BUFFER_SIZE) recBuf = &recordBuffer2;
	if (recBuf == nil) return 0;  /* no samples available */

	/* copy samples into the client''s buffer */
	src = &recBuf->samples[0] + recBuf->readIndex;
	srcEnd = &recBuf->samples[RECORD_BUFFER_SIZE];
	if (recBuf->bytesPerSample == 1) {
		while ((src < srcEnd) && (nextBuf < bufEnd)) {
			/* convert 8-bit sample to 16-bit sample */
			*nextBuf++ = (*src++) - 128;  /* convert from [0-255] to [-128-127] */
			*nextBuf++ = 0;  /* low-order byte is zero */
		}
	} else {
		while ((src < srcEnd) && (nextBuf < bufEnd)) {
			*nextBuf++ = *src++;
		}
	}
	recBuf->readIndex = src - &recBuf->samples[0];  /* update read index */

	/* return the number of slices copied */
	bytesCopied = (int) nextBuf - (buf + (startSliceIndex * bytesPerSlice));
	return bytesCopied / bytesPerSlice;
}


//Nov 6th 2000
void snd_Volume(double *left, double *right) {
	double temp;
	SndCommand cmd;
    long   results;
	OSErr  err;
	
	*left = 1.0;
	*right = 1.0;
	cmd.cmd = getVolumeCmd;
	cmd.param1 = 0;
	cmd.param2 = (long) &results;
	err = -1;
	if (chan !!= null)
	    err = SndDoImmediate(chan,&cmd);
	    
	if (err !!= noErr) {
	   err = GetDefaultOutputVolume(&results);
	}
	if (err !!= noErr) 
	    return;
	temp  = (results & 0xFFFF);
	*left = temp/256.0;
	
	temp = (results >> 16);
	*right = temp/256.0;
}

void snd_SetVolume(double left, double right) {
	unsigned long tempLeft,tempRight;
	SndCommand cmd;
	OSErr  err;
	
	tempLeft = left*256.0 + 0.5;
	tempLeft = tempLeft & 0xFFFF;
	tempRight = right*256.0 + 0.5;
	tempRight= tempRight & 0xFFFF;
	cmd.cmd = volumeCmd;
	cmd.param1 = 0;
	cmd.param2 = (tempRight << 16) | tempLeft;
	err = -1;
	if (chan !!= null)
	    err= SndDoImmediate(chan,&cmd);
	if (err !!= noErr) {
	   err = SetDefaultOutputVolume(cmd.param2);
	}
}



/*
	File:		CarbonSndPlayDB.c
	
	Description:Routines demonstrating how to create a function that works
				much like the original SndPlayDoubleBuffer but is Carbon compatible
				(which SndPlayDoubleBuffer isn''t).

	Author:		MC

	Copyright: 	© Copyright 1999-2000 Apple Computer, Inc. All rights reserved.
	
	Disclaimer:	IMPORTANT:  This Apple software is supplied to you by Apple Computer, Inc.
				("Apple") in consideration of your agreement to the following terms, and your
				use, installation, modification or redistribution of this Apple software
				constitutes acceptance of these terms.  If you do not agree with these terms,
				please do not use, install, modify or redistribute this Apple software.

				In consideration of your agreement to abide by the following terms, and subject
				to these terms, Apple grants you a personal, non-exclusive license, under AppleÕs
				copyrights in this original Apple software (the "Apple Software"), to use,
				reproduce, modify and redistribute the Apple Software, with or without
				modifications, in source and/or binary forms; provided that if you redistribute
				the Apple Software in its entirety and without modifications, you must retain
				this notice and the following text and disclaimers in all such redistributions of
				the Apple Software.  Neither the name, trademarks, service marks or logos of
				Apple Computer, Inc. may be used to endorse or promote products derived from the
				Apple Software without specific prior written permission from Apple.  Except as
				expressly stated in this notice, no other rights or licenses, express or implied,
				are granted by Apple herein, including but not limited to any patent rights that
				may be infringed by your derivative works or by other works in which the Apple
				Software may be incorporated.

				The Apple Software is provided by Apple on an "AS IS" basis.  APPLE MAKES NO
				WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE IMPLIED
				WARRANTIES OF NON-INFRINGEMENT, MERCHANTABILITY AND FITNESS FOR A PARTICULAR
				PURPOSE, REGARDING THE APPLE SOFTWARE OR ITS USE AND OPERATION ALONE OR IN
				COMBINATION WITH YOUR PRODUCTS.

				IN NO EVENT SHALL APPLE BE LIABLE FOR ANY SPECIAL, INDIRECT, INCIDENTAL OR
				CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
				GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
				ARISING IN ANY WAY OUT OF THE USE, REPRODUCTION, MODIFICATION AND/OR DISTRIBUTION
				OF THE APPLE SOFTWARE, HOWEVER CAUSED AND WHETHER UNDER THEORY OF CONTRACT, TORT
				(INCLUDING NEGLIGENCE), STRICT LIABILITY OR OTHERWISE, EVEN IF APPLE HAS BEEN
				ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
				
	Change History (most recent first):

*/

/* Requirements for using this shim code:

	1) The sound channel''s queue must be empty before you call CarbonSndPlayDoubleBuffer
	2) You cannot call MySndDoImmediate until CarbonSndPlayDoubleBuffer returns.  Be
	   careful about calling MySndDoImmediate at interrupt time with a quietCmd.

*/

/*
Some code is commented out becuase knowing who calls it and how allows shortcuts

Karl Goiser 14/01/01
*/

#undef UNNECESSARY_FOR_SQUEAK

#if UNNECESSARY_FOR_SQUEAK
static	pascal	void	CarbonSndPlayDoubleBufferCleanUpProc (SndChannelPtr theChannel, SndCommand * theCallBackCmd);
#endif
static  pascal  void	CarbonSndPlayDoubleBufferCallBackProc (SndChannelPtr theChannel, SndCommand * theCallBackCmd);
static			void	InsertSndDoCommand (SndChannelPtr chan, SndCommand * theCmd);
static	pascal	void	NMResponseProc (NMRecPtr nmReqPtr);

#define kBufSize					2048

// Structs
struct PerChanInfo {
	QElemPtr 						qLink;						/* next queue entry */
	short 							qType;						/* queue type = 0 */
	short							stopping;
	#if DEBUG
		OSType						magic;
	#endif
	SndCallBackUPP 					usersCallBack;
	SndDoubleBufferHeaderPtr		theParams;
	CmpSoundHeader					soundHeader;
};
typedef struct PerChanInfo			PerChanInfo;
typedef struct PerChanInfo *		PerChanInfoPtr;

// Globals
	Boolean							gNMRecBusy;
	NMRecPtr						gNMRecPtr;
	QHdrPtr							gFreeList;
	Ptr								gSilenceTwos;
	Ptr								gSilenceOnes;
static SndCallBackUPP				gCarbonSndPlayDoubleBufferCallBackUPP = nil;
static SndCallBackUPP				gCarbonSndPlayDoubleBufferCleanUpUPP = nil;

#if UNNECESSARY_FOR_SQUEAK
// Remember this routine could be called at interrupt time, so don''t allocate or deallocate memory.
OSErr	MySndDoImmediate (SndChannelPtr chan, SndCommand * cmd) {
	PerChanInfoPtr					perChanInfoPtr;

	// Is this being called on one of the sound channels we are manipulating?
	// If so, we need to pull our callback out of the way so that the user''s commands run
	if (gCarbonSndPlayDoubleBufferCallBackUPP == chan->callBack) {
		if (quietCmd == cmd->cmd || flushCmd == cmd->cmd) {
			// We know that our callBackCmd is the first item in the queue if this is our channel
			perChanInfoPtr = (PerChanInfoPtr)(chan->queue[chan->qHead].param2);
			#if DEBUG
				if (perChanInfoPtr->magic !!= ''SANE'') DebugStr("\pBAD in MySndDoImmediate");
			#endif
			perChanInfoPtr->stopping = true;
			Enqueue ((QElemPtr)perChanInfoPtr, gFreeList);
			if (!! OTAtomicSetBit (&gNMRecBusy, 0)) {
				NMInstall (gNMRecPtr);
			}
			chan->callBack = perChanInfoPtr->usersCallBack;
		}
	}

	return (SndDoImmediate (chan, cmd));
}
#endif UNNECESSARY_FOR_SQUEAK


// This must be called at task time.
OSErr	CarbonSndPlayDoubleBuffer (SndChannelPtr chan, SndDoubleBufferHeaderPtr theParams) {
	OSErr							err;
	CompressionInfo					compInfo;
	PerChanInfoPtr					perChanInfoPtr;
	SndCommand						playCmd;
	SndCommand						callBack;

	if (nil == chan)		return badChannel;
	if (nil == theParams)	return paramErr;

	if (nil == gFreeList) {
		// This can''t ever be disposed since we don''t know when we might need to use it (at interrupt time)
		gFreeList = (QHdrPtr)NewPtrClear (sizeof (QHdr));
		err = MemError ();
		if (noErr !!= err) goto exit;
	}

	if (nil == gSilenceOnes) {
		short		i;
		// This can''t ever be disposed since we don''t know when we might need to use it (at interrupt time)
		gSilenceOnes = NewPtr (kBufSize);
		err = MemError ();
		if (noErr !!= err) goto exit;
		for (i = 0; i < kBufSize; i++)
			*gSilenceOnes++ = (char)0x80;
	}

	if (nil == gSilenceTwos) {
		// This can''t ever be disposed since we don''t know when we might need to use it (at interrupt time)
		gSilenceTwos = NewPtrClear (kBufSize);
		err = MemError ();
		if (noErr !!= err) goto exit;
	}

	if (nil == gNMRecPtr) {
		// This can''t ever be disposed since we don''t know when we might need to use it (at interrupt time)
		gNMRecPtr = (NMRecPtr)NewPtr (sizeof (NMRec));
		err = MemError ();
		if (noErr !!= err) goto exit;

		// Set up our NMProc info that will dispose of most (but not all) of our memory
		gNMRecPtr->qLink = nil;
		gNMRecPtr->qType = 8;
		gNMRecPtr->nmFlags = 0;
		gNMRecPtr->nmPrivate = 0;
		gNMRecPtr->nmReserved = 0;
		gNMRecPtr->nmMark = nil;
		gNMRecPtr->nmIcon = nil;
		gNMRecPtr->nmSound = nil;
		gNMRecPtr->nmStr = nil;
		gNMRecPtr->nmResp = NewNMUPP (NMResponseProc);
		gNMRecPtr->nmRefCon = 0;
	}

	perChanInfoPtr = (PerChanInfoPtr)NewPtr (sizeof (PerChanInfo));
	err = MemError ();
	if (noErr !!= err) goto exit;

	// Init basic per channel information
	perChanInfoPtr->qLink = nil;
	perChanInfoPtr->qType = 0;				// not used
	perChanInfoPtr->stopping = 0;
	#if DEBUG
		perChanInfoPtr->magic = ''SANE'';
	#endif
	
	perChanInfoPtr->theParams = theParams;
	// Have to remember the user''s callback function from the sound because
	// we are going to overwrite it with our own callback function.
	perChanInfoPtr->usersCallBack = chan->callBack;

	// Set up the sound header for the bufferCmd that will be used to play
	// the buffers passed in by the SndPlayDoubleBuffer call.
	perChanInfoPtr->soundHeader.samplePtr = (Ptr)(theParams->dbhBufferPtr[0]->dbSoundData);
	perChanInfoPtr->soundHeader.numChannels = theParams->dbhNumChannels;
	perChanInfoPtr->soundHeader.sampleRate = theParams->dbhSampleRate;
	perChanInfoPtr->soundHeader.loopStart = 0;
	perChanInfoPtr->soundHeader.loopEnd = 0;
	perChanInfoPtr->soundHeader.encode = cmpSH;
	perChanInfoPtr->soundHeader.baseFrequency = kMiddleC;
	perChanInfoPtr->soundHeader.numFrames = (unsigned long)theParams->dbhBufferPtr[0]->dbNumFrames;
	//	perChanInfoPtr->soundHeader.AIFFSampleRate = 0;				// unused
	perChanInfoPtr->soundHeader.markerChunk = nil;
	perChanInfoPtr->soundHeader.futureUse2 = nil;
	perChanInfoPtr->soundHeader.stateVars = nil;
	perChanInfoPtr->soundHeader.leftOverSamples = nil;
	perChanInfoPtr->soundHeader.compressionID = theParams->dbhCompressionID;
	perChanInfoPtr->soundHeader.packetSize = (unsigned short)theParams->dbhPacketSize;
	perChanInfoPtr->soundHeader.snthID = 0;
	perChanInfoPtr->soundHeader.sampleSize = (unsigned short)theParams->dbhSampleSize;
	perChanInfoPtr->soundHeader.sampleArea[0] = 0;

	// Is the sound compressed?  If so, we need to treat theParams as a SndDoubleBufferHeader2Ptr.
	if (0 !!= theParams->dbhCompressionID) {
		// Sound is compressed
		err = GetCompressionInfo (theParams->dbhCompressionID,
								((SndDoubleBufferHeader2Ptr)theParams)->dbhFormat,
								theParams->dbhNumChannels,
								theParams->dbhSampleSize,
								&compInfo);
		if (noErr !!= err) goto exitDispose;

		perChanInfoPtr->soundHeader.format = compInfo.format;
	} else {
		// Sound is not compressed
		perChanInfoPtr->soundHeader.format = kSoundNotCompressed;
	}

	playCmd.cmd = bufferCmd;
	playCmd.param1 = 0;							// unused
	playCmd.param2 = (long)&perChanInfoPtr->soundHeader;

	callBack.cmd = callBackCmd;
	callBack.param1 = 0;						// which buffer to fill, 0 buffer, 1, 0, ...
	callBack.param2 = (long)perChanInfoPtr;

	// Install our callback function pointer straight into the sound channel structure
	if (nil == gCarbonSndPlayDoubleBufferCallBackUPP) {
		gCarbonSndPlayDoubleBufferCallBackUPP = NewSndCallBackUPP(CarbonSndPlayDoubleBufferCallBackProc);
	}

	chan->callBack = gCarbonSndPlayDoubleBufferCallBackUPP;

#if UNNECESSARY_FOR_SQUEAK
	if (gCarbonSndPlayDoubleBufferCleanUpUPP == nil) {
			gCarbonSndPlayDoubleBufferCleanUpUPP = NewSndCallBackProc (CarbonSndPlayDoubleBufferCleanUpProc);
	}
#endif

	err = SndDoCommand (chan, &playCmd, true);
	if (noErr !!= err) goto exitDispose;

	err = SndDoCommand (chan, &callBack, true);
	if (noErr !!= err) goto exitDispose;

exit:
	return err;

exitDispose:
	if (nil !!= perChanInfoPtr)
		DisposePtr ((Ptr)perChanInfoPtr);
	goto exit;
}

#if UNNECESSARY_FOR_SQUEAK
static pascal void	CarbonSndPlayDoubleBufferCleanUpProc(
								SndChannelPtr theChannel, SndCommand * theCallBackCmd)
{
	PerChanInfoPtr	perChanInfoPtr;

	perChanInfoPtr = (PerChanInfoPtr)(theCallBackCmd->param2);
	#if DEBUG
		if (perChanInfoPtr->magic !!= ''SANE'') DebugStr("\pBAD in CarbonSndPlayDoubleBufferCleanUpProc");
	#endif

	// Put our per channel data on the free queue so we can clean up later
	Enqueue ((QElemPtr)perChanInfoPtr, gFreeList);
	// Have to install our Notification Manager routine so that we can clean up the gFreeList
	if (!! OTAtomicSetBit (&gNMRecBusy, 0)) {
		NMInstall (gNMRecPtr);
	}
	// Have to put the user''s callback proc back so they get called when the next buffer finishes
	theChannel->callBack = perChanInfoPtr->usersCallBack;
}
#endif


static pascal void	CarbonSndPlayDoubleBufferCallBackProc (SndChannelPtr theChannel, SndCommand * theCallBackCmd) {
	SndDoubleBufferHeaderPtr		theParams;
	SndDoubleBufferPtr				emptyBuf;
	SndDoubleBufferPtr				nextBuf;
	PerChanInfoPtr					perChanInfoPtr;
	SndCommand						playCmd;

	perChanInfoPtr = (PerChanInfoPtr)(theCallBackCmd->param2);
	#if DEBUG
		if (perChanInfoPtr->magic !!= ''SANE'') DebugStr("\pBAD in CarbonSndPlayDoubleBufferCallBackProc");
	#endif
	if (true == perChanInfoPtr->stopping) goto exit;

	theParams = perChanInfoPtr->theParams;

	// The buffer that just played and needs to be filled
	emptyBuf = theParams->dbhBufferPtr[theCallBackCmd->param1];

	// Clear the ready flag
	emptyBuf->dbFlags ^= dbBufferReady;

	// This is the buffer to play now
	nextBuf = theParams->dbhBufferPtr[!!theCallBackCmd->param1];

	// Check to see if it is ready, or if we have to wait a bit
	if (nextBuf->dbFlags & dbBufferReady) {
		perChanInfoPtr->soundHeader.numFrames = (unsigned long)nextBuf->dbNumFrames;
		perChanInfoPtr->soundHeader.samplePtr = (Ptr)(nextBuf->dbSoundData);

		// Flip the bit telling us which buffer is next
		theCallBackCmd->param1 = !!theCallBackCmd->param1;

		// If this isn''t the last buffer, call the user''s fill routine
		if (!!(nextBuf->dbFlags & dbLastBuffer)) {
				// Declare a function pointer to the user''s double back proc
				void (*doubleBackProc)(SndChannel*, SndDoubleBuffer*);

				// Call user''s double back proc
				doubleBackProc = (void*)DoubleBack;
				(*doubleBackProc) (theChannel, emptyBuf);
		} else {
			// Call our clean up proc when the last buffer finishes
			theChannel->callBack = gCarbonSndPlayDoubleBufferCleanUpUPP;
		}
	} else {
		// We have to wait for the buffer to become ready.
		// The real SndPlayDoubleBuffer would play a short bit of silence waiting for
		// the user to read the audio from disk, so that''s what we do here.
		#if DEBUG
			DebugStr ("\p buffer is not ready!!");
		#endif
		// Play a short section of silence so that we can check the ready flag again
		if (theParams->dbhSampleSize == 8) {
			perChanInfoPtr->soundHeader.numFrames = (UInt32)(kBufSize / theParams->dbhNumChannels);
			perChanInfoPtr->soundHeader.samplePtr = gSilenceOnes;
		} else {
			perChanInfoPtr->soundHeader.numFrames = (UInt32)(kBufSize / (theParams->dbhNumChannels * (theParams->dbhSampleSize / 8)));
			perChanInfoPtr->soundHeader.samplePtr = gSilenceTwos;
		}
	}

	// Insert our callback command
	InsertSndDoCommand (theChannel, theCallBackCmd);

	// Play the next buffer
	playCmd.cmd = bufferCmd;
	playCmd.param1 = 0;
	playCmd.param2 = (long)&(perChanInfoPtr->soundHeader);
	InsertSndDoCommand (theChannel, &playCmd);

exit:
	return;
}

static void	InsertSndDoCommand (SndChannelPtr chan, SndCommand * newCmd) {
	if (-1 == chan->qHead) {
		chan->qHead = chan->qTail;
	}

	if (1 <= chan->qHead) {
		chan->qHead--;
	} else {
		chan->qHead = chan->qTail;
	}

	chan->queue[chan->qHead] = *newCmd;
}

static pascal void NMResponseProc (NMRecPtr nmReqPtr) {
	PerChanInfoPtr					perChanInfoPtr;
	OSErr							err;

	NMRemove (nmReqPtr);
	gNMRecBusy = false;

	do {
		perChanInfoPtr = (PerChanInfoPtr)gFreeList->qHead;
		if (nil !!= perChanInfoPtr) {
			err = Dequeue ((QElemPtr)perChanInfoPtr, gFreeList);
			if (noErr == err) {
				DisposePtr ((Ptr)perChanInfoPtr);
			}
		}
	} while (nil !!= perChanInfoPtr && noErr == err);
}

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 1/28/98 20:58'!
macTCPFile

	^ '/*
 	File:		MacTCP.h
 
 	Contains:	TCP Manager Interfaces.
 
 	Version:	Technology:	MacTCP 2.0.6
 				Package:	Universal Interfaces 2.1§1 in ÒMPW PrereleaseÓ on ETO #17
 
 	Copyright:	© 1984-1995 by Apple Computer, Inc.
 				All rights reserved.
 
 	Bugs?:		If you find a problem with this file, use the Apple Bug Reporter
 				stack.  Include the file and version information (from above)
 				in the problem description and send to:
 					Internet:	apple.bugs@applelink.apple.com
 					AppleLink:	APPLE.BUGS
 
*/

#ifndef __MACTCP__
#define __MACTCP__


#ifndef __TYPES__
#include <Types.h>
#endif
/*	#include <ConditionalMacros.h>								*/

#ifndef __APPLETALK__
#include <AppleTalk.h>
#endif
/*	#include <OSUtils.h>										*/
/*		#include <MixedMode.h>									*/
/*		#include <Memory.h>										*/

#ifdef __cplusplus
extern "C" {
#endif

#if PRAGMA_ALIGN_SUPPORTED
#pragma options align=mac68k
#endif

#if PRAGMA_IMPORT_SUPPORTED
#pragma import on
#endif

/*
Developer Notes:
		0. This MacTCP header replaces what used to be defined in the following header files
			MacTCPCommonTypes.h
			GetMyIPAddr.h
			MiscIPPB.h
			TCPPB.h
			UDPPB.h 
			
			When the various control calls are made to the ip driver, you must set up a 
			NewRoutineDescriptor for every non-nil completion routine and/or notifyProc parameter.  
			Otherwise, the 68K driver code, will not correctly call your routine.
		1. For ipctlGetAddr Control calls, use NewGetIPIOCompletionProc
			to set up a GetIPIOCompletionUPP universal procptr to pass as
			the ioCompletion parameter.
		2. For the ipctlEchoICMP and ipctlLAPStats Control calls, use 
			NewIPIOCompletion to set up a IPIOCompletionUPP universal procptr
			to pass in the ioCompletion field of the parameter block.
		3. For TCPCreatePB Control calls, use NewTCPNotifyProc to set up a
			TCPNotifyUPP universal procptr to pass in the notifyProc field
			of the parameter block
		4. For all of the TCP Control calls using the TCPiopb parameter block,
			use NewTCPIOCompletionProc to set up a TCPIOCompletionUPP
			universal procptr to pass in the ioCompletion field of the paramter
			block.
		5. For UDBCreatePB Control calls, use NewUDPNotifyProc to set up a
			UDPNotifyUPP universal procptr to pass in the notifyProc field
			of the parameter block
		6. For all of the UDP Control calls using the UDPiopb parameter block,
			use NewUDPIOCompletionProc to set up a UDPIOCompletionUPP
			universal procptr to pass in the ioCompletion field of the paramter
			block.
		7. For all calls implementing a notifyProc or ioCompletion routine
			which was set up using a NewTCPRoutineProc call, do not call
			DisposeRoutineSDescriptor on the universal procptr until
			after the completion or notify proc has completed.
*/
/* MacTCP return Codes in the range -23000 through -23049 */

enum {
	inProgress					= 1,							/* I/O in progress */
	ipBadLapErr					= -23000,						/* bad network configuration */
	ipBadCnfgErr				= -23001,						/* bad IP configuration error */
	ipNoCnfgErr					= -23002,						/* missing IP or LAP configuration error */
	ipLoadErr					= -23003,						/* error in MacTCP load */
	ipBadAddr					= -23004,						/* error in getting address */
	connectionClosing			= -23005,						/* connection is closing */
	invalidLength				= -23006,
	connectionExists			= -23007,						/* request conflicts with existing connection */
	connectionDoesntExist		= -23008,						/* connection does not exist */
	insufficientResources		= -23009,						/* insufficient resources to perform request */
	invalidStreamPtr			= -23010,
	streamAlreadyOpen			= -23011,
	connectionTerminated		= -23012,
	invalidBufPtr				= -23013,
	invalidRDS					= -23014,
	invalidWDS					= -23014,
	openFailed					= -23015,
	commandTimeout				= -23016,
	duplicateSocket				= -23017
};

/* Error codes from internal IP functions */
enum {
	ipDontFragErr				= -23032,						/* Packet too large to send w/o fragmenting */
	ipDestDeadErr				= -23033,						/* destination not responding */
	icmpEchoTimeoutErr			= -23035,						/* ICMP echo timed-out */
	ipNoFragMemErr				= -23036,						/* no memory to send fragmented pkt */
	ipRouteErr					= -23037,						/* can''t route packet off-net */
	nameSyntaxErr				= -23041,
	cacheFault					= -23042,
	noResultProc				= -23043,
	noNameServer				= -23044,
	authNameErr					= -23045,
	noAnsErr					= -23046,
	dnrErr						= -23047,
	outOfMemory					= -23048
};

enum {
	BYTES_16WORD				= 2,							/* bytes per = 16, bit ip word */
	BYTES_32WORD				= 4,							/* bytes per = 32, bit ip word */
	BYTES_64WORD				= 8								/* bytes per = 64, bit ip word */
};

/* 8-bit quantity */
typedef UInt8 b_8;

/* 16-bit quantity */
typedef UInt16 b_16;

/* 32-bit quantity */
typedef UInt32 b_32;

/* IP address is 32-bits */
typedef b_32 ip_addr;

struct ip_addrbytes {
	union {
		b_32							addr;
		UInt8							byte[4];
	}								a;
};
typedef struct ip_addrbytes ip_addrbytes;

struct wdsEntry {
	unsigned short					length;						/* length of buffer */
	Ptr								ptr;						/* pointer to buffer */
};
typedef struct wdsEntry wdsEntry;

struct rdsEntry {
	unsigned short					length;						/* length of buffer */
	Ptr								ptr;						/* pointer to buffer */
};
typedef struct rdsEntry rdsEntry;

typedef unsigned long BufferPtr;

typedef unsigned long StreamPtr;


enum {
	netUnreach					= 0,
	hostUnreach					= 1,
	protocolUnreach				= 2,
	portUnreach					= 3,
	fragReqd					= 4,
	sourceRouteFailed			= 5,
	timeExceeded				= 6,
	parmProblem					= 7,
	missingOption				= 8,
	lastICMPMsgType				= 32767
};

typedef unsigned short ICMPMsgType;

typedef b_16 ip_port;

struct ICMPReport {
	StreamPtr						streamPtr;
	ip_addr							localHost;
	ip_port							localPort;
	ip_addr							remoteHost;
	ip_port							remotePort;
	short							reportType;
	unsigned short					optionalAddlInfo;
	unsigned long					optionalAddlInfoPtr;
};
typedef struct ICMPReport ICMPReport;

/* csCode to get our IP address */

enum {
	ipctlGetAddr				= 15
};

typedef void (*GetIPIOCompletionProcPtr)(struct GetAddrParamBlock *iopb);

#if GENERATINGCFM
typedef UniversalProcPtr GetIPIOCompletionUPP;
#else
typedef GetIPIOCompletionProcPtr GetIPIOCompletionUPP;
#endif

#define GetIPParamBlockHeader 	\
	struct QElem*	qLink; 		\
	short	qType; 				\
	short	ioTrap; 				\
	Ptr	ioCmdAddr; 				\
	GetIPIOCompletionUPP	ioCompletion;  \
	OSErr	ioResult; 			\
	StringPtr	ioNamePtr; 		\
	short	ioVRefNum;				\
	short	ioCRefNum;				\
	short	csCode
struct GetAddrParamBlock {
	struct QElem					*qLink;
	short							qType;
	short							ioTrap;
	Ptr								ioCmdAddr;
	GetIPIOCompletionUPP			ioCompletion;
	OSErr							ioResult;
	StringPtr						ioNamePtr;
	short							ioVRefNum;
	short							ioCRefNum;
	short							csCode;						/* standard I/O header */
	ip_addr							ourAddress;					/* our IP address */
	long							ourNetMask;					/* our IP net mask */
};
typedef struct GetAddrParamBlock GetAddrParamBlock;

/* control codes */

enum {
	ipctlEchoICMP				= 17,							/* send icmp echo */
	ipctlLAPStats				= 19							/* get lap stats */
};

typedef void (*IPIOCompletionProcPtr)(struct ICMPParamBlock *iopb);

#if GENERATINGCFM
typedef UniversalProcPtr IPIOCompletionUPP;
#else
typedef IPIOCompletionProcPtr IPIOCompletionUPP;
#endif

#define IPParamBlockHeader 		\
	struct QElem*	qLink; 		\
	short	qType; 				\
	short	ioTrap; 				\
	Ptr	ioCmdAddr; 				\
	IPIOCompletionUPP	ioCompletion;  \
	OSErr	ioResult; 			\
	StringPtr	ioNamePtr; 		\
	short	ioVRefNum;				\
	short	ioCRefNum;				\
	short	csCode
struct ICMPParamBlock {
	struct QElem					*qLink;
	short							qType;
	short							ioTrap;
	Ptr								ioCmdAddr;
	IPIOCompletionUPP				ioCompletion;
	OSErr							ioResult;
	StringPtr						ioNamePtr;
	short							ioVRefNum;
	short							ioCRefNum;
	short							csCode;						/* standard I/O header */
	short							params[11];
	struct {
		unsigned long					echoRequestOut;			/* time in ticks of when the echo request went out */
		unsigned long					echoReplyIn;			/* time in ticks of when the reply was received */
		struct rdsEntry					echoedData;				/* data received in responce */
		Ptr								options;
		unsigned long					userDataPtr;
	}								icmpEchoInfo;
};
typedef pascal void (*ICMPEchoNotifyProcPtr)(struct ICMPParamBlock *iopb);

#if GENERATINGCFM
typedef UniversalProcPtr ICMPEchoNotifyUPP;
#else
typedef ICMPEchoNotifyProcPtr ICMPEchoNotifyUPP;
#endif

struct IPParamBlock {
	struct QElem					*qLink;
	short							qType;
	short							ioTrap;
	Ptr								ioCmdAddr;
	IPIOCompletionUPP				ioCompletion;
	OSErr							ioResult;
	StringPtr						ioNamePtr;
	short							ioVRefNum;
	short							ioCRefNum;
	short							csCode;						/* standard I/O header */
	union {
		struct {
			ip_addr							dest;				/* echo to IP address */
			wdsEntry						data;
			short							timeout;
			Ptr								options;
			unsigned short					optLength;
			ICMPEchoNotifyUPP				icmpCompletion;
			unsigned long					userDataPtr;
		}								IPEchoPB;
		struct {
			struct LAPStats					*lapStatsPtr;
		}								LAPStatsPB;
	}								csParam;
};
union LAPStatsAddrXlation {
	struct arp_entry				*arp_table;
	struct nbp_entry				*nbp_table;
};
struct LAPStats {
	short							ifType;
	char							*ifString;
	short							ifMaxMTU;
	long							ifSpeed;
	short							ifPhyAddrLength;
	char							*ifPhysicalAddress;
	union LAPStatsAddrXlation		AddrXlation;
	short							slotNumber;
};
typedef struct LAPStats LAPStats;

struct nbp_entry {
	ip_addr							ip_address;					/* IP address */
	AddrBlock						at_address;					/* matching AppleTalk address */
	Boolean							gateway;					/* TRUE if entry for a gateway */
	Boolean							valid;						/* TRUE if LAP address is valid */
	Boolean							probing;					/* TRUE if NBP lookup pending */
	SInt8							afiller;					/* Filler for proper byte alignment	 */
	long							age;						/* ticks since cache entry verified */
	long							access;						/* ticks since last access */
	SInt8							filler[116];				/* for internal use only !!!!!! */
};
struct Enet_addr {
	b_16							en_hi;
	b_32							en_lo;
};
typedef struct Enet_addr Enet_addr;

struct arp_entry {
	short							age;						/* cache aging field */
	b_16							protocol;					/* Protocol type */
	ip_addr							ip_address;					/* IP address */
	Enet_addr						en_address;					/* matching Ethernet address */
};
typedef struct arp_entry arp_entry;

/* number of ARP table entries */

enum {
	ARP_TABLE_SIZE				= 20
};

enum {
	NBP_TABLE_SIZE				= 20,							/* number of NBP table entries */
	NBP_MAX_NAME_SIZE			= 16 + 10 + 2
};

/* Command codes */
enum {
	TCPCreate					= 30,
	TCPPassiveOpen				= 31,
	TCPActiveOpen				= 32,
	TCPSend						= 34,
	TCPNoCopyRcv				= 35,
	TCPRcvBfrReturn				= 36,
	TCPRcv						= 37,
	TCPClose					= 38,
	TCPAbort					= 39,
	TCPStatus					= 40,
	TCPExtendedStat				= 41,
	TCPRelease					= 42,
	TCPGlobalInfo				= 43,
	TCPCtlMax					= 49
};

enum {
	TCPClosing					= 1,
	TCPULPTimeout				= 2,
	TCPTerminate				= 3,
	TCPDataArrival				= 4,
	TCPUrgent					= 5,
	TCPICMPReceived				= 6,
	lastEvent					= 32767
};

typedef unsigned short TCPEventCode;


enum {
	TCPRemoteAbort				= 2,
	TCPNetworkFailure			= 3,
	TCPSecPrecMismatch			= 4,
	TCPULPTimeoutTerminate		= 5,
	TCPULPAbort					= 6,
	TCPULPClose					= 7,
	TCPServiceError				= 8,
	lastReason					= 32767
};

typedef unsigned short TCPTerminationReason;

typedef pascal void (*TCPNotifyProcPtr)(StreamPtr tcpStream, unsigned short eventCode, Ptr userDataPtr, unsigned short terminReason, struct ICMPReport *icmpMsg);

#if GENERATINGCFM
typedef UniversalProcPtr TCPNotifyUPP;
#else
typedef TCPNotifyProcPtr TCPNotifyUPP;
#endif

typedef unsigned short tcp_port;

/* ValidityFlags */

enum {
	timeoutValue				= 0x80,
	timeoutAction				= 0x40,
	typeOfService				= 0x20,
	precedence					= 0x10
};

/* TOSFlags */
enum {
	lowDelay					= 0x01,
	throughPut					= 0x02,
	reliability					= 0x04
};

struct TCPCreatePB {
	Ptr								rcvBuff;
	unsigned long					rcvBuffLen;
	TCPNotifyUPP					notifyProc;
	Ptr								userDataPtr;
};
typedef struct TCPCreatePB TCPCreatePB;

struct TCPOpenPB {
	SInt8							ulpTimeoutValue;
	SInt8							ulpTimeoutAction;
	SInt8							validityFlags;
	SInt8							commandTimeoutValue;
	ip_addr							remoteHost;
	tcp_port						remotePort;
	ip_addr							localHost;
	tcp_port						localPort;
	SInt8							tosFlags;
	SInt8							precedence;
	Boolean							dontFrag;
	SInt8							timeToLive;
	SInt8							security;
	SInt8							optionCnt;
	SInt8							options[40];
	Ptr								userDataPtr;
};
typedef struct TCPOpenPB TCPOpenPB;

struct TCPSendPB {
	SInt8							ulpTimeoutValue;
	SInt8							ulpTimeoutAction;
	SInt8							validityFlags;
	Boolean							pushFlag;
	Boolean							urgentFlag;
	SInt8							filler;						/* Filler for proper byte alignment	 */
	Ptr								wdsPtr;
	unsigned long					sendFree;
	unsigned short					sendLength;
	Ptr								userDataPtr;
};
typedef struct TCPSendPB TCPSendPB;

/* for receive and return rcv buff calls */
/*   Note: the filler in the following structure is in a different location than */
/*         that specified in the Programmer''s Guide.  */
struct TCPReceivePB {
	SInt8							commandTimeoutValue;
	Boolean							markFlag;
	Boolean							urgentFlag;
	SInt8							filler;						/* Filler for proper byte alignment  */
	Ptr								rcvBuff;
	unsigned short					rcvBuffLen;
	Ptr								rdsPtr;
	unsigned short					rdsLength;
	unsigned short					secondTimeStamp;
	Ptr								userDataPtr;
};
typedef struct TCPReceivePB TCPReceivePB;

struct TCPClosePB {
	SInt8							ulpTimeoutValue;
	SInt8							ulpTimeoutAction;
	SInt8							validityFlags;
	SInt8							filler;						/* Filler for proper byte alignment	 */
	Ptr								userDataPtr;
};
typedef struct TCPClosePB TCPClosePB;

struct HistoBucket {
	unsigned short					value;
	unsigned long					counter;
};
typedef struct HistoBucket HistoBucket;


enum {
	NumOfHistoBuckets			= 7
};

struct TCPConnectionStats {
	unsigned long					dataPktsRcvd;
	unsigned long					dataPktsSent;
	unsigned long					dataPktsResent;
	unsigned long					bytesRcvd;
	unsigned long					bytesRcvdDup;
	unsigned long					bytesRcvdPastWindow;
	unsigned long					bytesSent;
	unsigned long					bytesResent;
	unsigned short					numHistoBuckets;
	struct HistoBucket				sentSizeHisto[NumOfHistoBuckets];
	unsigned short					lastRTT;
	unsigned short					tmrSRTT;
	unsigned short					rttVariance;
	unsigned short					tmrRTO;
	SInt8							sendTries;
	SInt8							sourchQuenchRcvd;
};
typedef struct TCPConnectionStats TCPConnectionStats;

struct TCPStatusPB {
	SInt8							ulpTimeoutValue;
	SInt8							ulpTimeoutAction;
	long							unused;
	ip_addr							remoteHost;
	tcp_port						remotePort;
	ip_addr							localHost;
	tcp_port						localPort;
	SInt8							tosFlags;
	SInt8							precedence;
	SInt8							connectionState;
	SInt8							filler;						/* Filler for proper byte alignment	 */
	unsigned short					sendWindow;
	unsigned short					rcvWindow;
	unsigned short					amtUnackedData;
	unsigned short					amtUnreadData;
	Ptr								securityLevelPtr;
	unsigned long					sendUnacked;
	unsigned long					sendNext;
	unsigned long					congestionWindow;
	unsigned long					rcvNext;
	unsigned long					srtt;
	unsigned long					lastRTT;
	unsigned long					sendMaxSegSize;
	struct TCPConnectionStats		*connStatPtr;
	Ptr								userDataPtr;
};
typedef struct TCPStatusPB TCPStatusPB;

struct TCPAbortPB {
	Ptr								userDataPtr;
};
typedef struct TCPAbortPB TCPAbortPB;

struct TCPParam {
	unsigned long					tcpRtoA;
	unsigned long					tcpRtoMin;
	unsigned long					tcpRtoMax;
	unsigned long					tcpMaxSegSize;
	unsigned long					tcpMaxConn;
	unsigned long					tcpMaxWindow;
};
typedef struct TCPParam TCPParam;

struct TCPStats {
	unsigned long					tcpConnAttempts;
	unsigned long					tcpConnOpened;
	unsigned long					tcpConnAccepted;
	unsigned long					tcpConnClosed;
	unsigned long					tcpConnAborted;
	unsigned long					tcpOctetsIn;
	unsigned long					tcpOctetsOut;
	unsigned long					tcpOctetsInDup;
	unsigned long					tcpOctetsRetrans;
	unsigned long					tcpInputPkts;
	unsigned long					tcpOutputPkts;
	unsigned long					tcpDupPkts;
	unsigned long					tcpRetransPkts;
};
typedef struct TCPStats TCPStats;

typedef StreamPtr *StreamPPtr;

struct TCPGlobalInfoPB {
	struct TCPParam					*tcpParamPtr;
	struct TCPStats					*tcpStatsPtr;
	StreamPPtr						tcpCDBTable[1];
	Ptr								userDataPtr;
	unsigned short					maxTCPConnections;
};
typedef struct TCPGlobalInfoPB TCPGlobalInfoPB;

typedef void (*TCPIOCompletionProcPtr)(struct TCPiopb *iopb);

#if GENERATINGCFM
typedef UniversalProcPtr TCPIOCompletionUPP;
#else
typedef TCPIOCompletionProcPtr TCPIOCompletionUPP;
#endif

struct TCPiopb {
	SInt8							fill12[12];
	TCPIOCompletionUPP				ioCompletion;
	short							ioResult;
	Ptr								ioNamePtr;
	short							ioVRefNum;
	short							ioCRefNum;
	short							csCode;
	StreamPtr						tcpStream;
	union {
		struct TCPCreatePB				create;
		struct TCPOpenPB				open;
		struct TCPSendPB				send;
		struct TCPReceivePB				receive;
		struct TCPClosePB				close;
		struct TCPAbortPB				abort;
		struct TCPStatusPB				status;
		struct TCPGlobalInfoPB			globalInfo;
	}								csParam;
};
typedef struct TCPiopb TCPiopb;


enum {
	UDPCreate					= 20,
	UDPRead						= 21,
	UDPBfrReturn				= 22,
	UDPWrite					= 23,
	UDPRelease					= 24,
	UDPMaxMTUSize				= 25,
	UDPStatus					= 26,
	UDPMultiCreate				= 27,
	UDPMultiSend				= 28,
	UDPMultiRead				= 29,
	UDPCtlMax					= 29
};

enum {
	UDPDataArrival				= 1,
	UDPICMPReceived				= 2,
	lastUDPEvent				= 32767
};

typedef unsigned short UDPEventCode;

typedef pascal void (*UDPNotifyProcPtr)(StreamPtr udpStream, unsigned short eventCode, Ptr userDataPtr, struct ICMPReport *icmpMsg);

#if GENERATINGCFM
typedef UniversalProcPtr UDPNotifyUPP;
#else
typedef UDPNotifyProcPtr UDPNotifyUPP;
#endif

typedef unsigned short udp_port;

/* for create and release calls */
struct UDPCreatePB {
	Ptr								rcvBuff;
	unsigned long					rcvBuffLen;
	UDPNotifyUPP					notifyProc;
	unsigned short					localPort;
	Ptr								userDataPtr;
	udp_port						endingPort;
};
typedef struct UDPCreatePB UDPCreatePB;

struct UDPSendPB {
	unsigned short					reserved;
	ip_addr							remoteHost;
	udp_port						remotePort;
	Ptr								wdsPtr;
	Boolean							checkSum;
	SInt8							filler;						/* Filler for proper byte alignment	 */
	unsigned short					sendLength;
	Ptr								userDataPtr;
	udp_port						localPort;
};
typedef struct UDPSendPB UDPSendPB;

/* for receive and buffer return calls */
struct UDPReceivePB {
	unsigned short					timeOut;
	ip_addr							remoteHost;
	udp_port						remotePort;
	Ptr								rcvBuff;
	unsigned short					rcvBuffLen;
	unsigned short					secondTimeStamp;
	Ptr								userDataPtr;
	ip_addr							destHost;					/* only for use with multi rcv */
	udp_port						destPort;					/* only for use with multi rcv */
};
typedef struct UDPReceivePB UDPReceivePB;

struct UDPMTUPB {
	unsigned short					mtuSize;
	ip_addr							remoteHost;
	Ptr								userDataPtr;
};
typedef struct UDPMTUPB UDPMTUPB;

typedef void (*UDPIOCompletionProcPtr)(struct UDPiopb *iopb);

#if GENERATINGCFM
typedef UniversalProcPtr UDPIOCompletionUPP;
#else
typedef UDPIOCompletionProcPtr UDPIOCompletionUPP;
#endif

struct UDPiopb {
	SInt8							fill12[12];
	UDPIOCompletionUPP				ioCompletion;
	short							ioResult;
	Ptr								ioNamePtr;
	short							ioVRefNum;
	short							ioCRefNum;
	short							csCode;
	StreamPtr						udpStream;
	union {
		struct UDPCreatePB				create;
		struct UDPSendPB				send;
		struct UDPReceivePB				receive;
		struct UDPMTUPB					mtu;
	}								csParam;
};
typedef struct UDPiopb UDPiopb;


#if GENERATINGCFM
#else
#endif

enum {
	uppGetIPIOCompletionProcInfo = kCStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct GetAddrParamBlock*))),
	uppIPIOCompletionProcInfo = kCStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct ICMPParamBlock*))),
	uppICMPEchoNotifyProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct ICMPParamBlock*))),
	uppTCPNotifyProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(StreamPtr)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned short)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(unsigned short)))
		 | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(struct ICMPReport*))),
	uppTCPIOCompletionProcInfo = kCStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct TCPiopb*))),
	uppUDPNotifyProcInfo = kPascalStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(StreamPtr)))
		 | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(unsigned short)))
		 | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(Ptr)))
		 | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(struct ICMPReport*))),
	uppUDPIOCompletionProcInfo = kCStackBased
		 | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(struct UDPiopb*)))
};

#if GENERATINGCFM
#define NewGetIPIOCompletionProc(userRoutine)		\
		(GetIPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppGetIPIOCompletionProcInfo, GetCurrentArchitecture())
#define NewIPIOCompletionProc(userRoutine)		\
		(IPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppIPIOCompletionProcInfo, GetCurrentArchitecture())
#define NewICMPEchoNotifyProc(userRoutine)		\
		(ICMPEchoNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppICMPEchoNotifyProcInfo, GetCurrentArchitecture())
#define NewTCPNotifyProc(userRoutine)		\
		(TCPNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppTCPNotifyProcInfo, GetCurrentArchitecture())
#define NewTCPIOCompletionProc(userRoutine)		\
		(TCPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppTCPIOCompletionProcInfo, GetCurrentArchitecture())
#define NewUDPNotifyProc(userRoutine)		\
		(UDPNotifyUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppUDPNotifyProcInfo, GetCurrentArchitecture())
#define NewUDPIOCompletionProc(userRoutine)		\
		(UDPIOCompletionUPP) NewRoutineDescriptor((ProcPtr)(userRoutine), uppUDPIOCompletionProcInfo, GetCurrentArchitecture())
#else
#define NewGetIPIOCompletionProc(userRoutine)		\
		((GetIPIOCompletionUPP) (userRoutine))
#define NewIPIOCompletionProc(userRoutine)		\
		((IPIOCompletionUPP) (userRoutine))
#define NewICMPEchoNotifyProc(userRoutine)		\
		((ICMPEchoNotifyUPP) (userRoutine))
#define NewTCPNotifyProc(userRoutine)		\
		((TCPNotifyUPP) (userRoutine))
#define NewTCPIOCompletionProc(userRoutine)		\
		((TCPIOCompletionUPP) (userRoutine))
#define NewUDPNotifyProc(userRoutine)		\
		((UDPNotifyUPP) (userRoutine))
#define NewUDPIOCompletionProc(userRoutine)		\
		((UDPIOCompletionUPP) (userRoutine))
#endif

#if GENERATINGCFM
#define CallGetIPIOCompletionProc(userRoutine, iopb)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppGetIPIOCompletionProcInfo, (iopb))
#define CallIPIOCompletionProc(userRoutine, iopb)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppIPIOCompletionProcInfo, (iopb))
#define CallICMPEchoNotifyProc(userRoutine, iopb)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppICMPEchoNotifyProcInfo, (iopb))
#define CallTCPNotifyProc(userRoutine, tcpStream, eventCode, userDataPtr, terminReason, icmpMsg)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppTCPNotifyProcInfo, (tcpStream), (eventCode), (userDataPtr), (terminReason), (icmpMsg))
#define CallTCPIOCompletionProc(userRoutine, iopb)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppTCPIOCompletionProcInfo, (iopb))
#define CallUDPNotifyProc(userRoutine, udpStream, eventCode, userDataPtr, icmpMsg)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppUDPNotifyProcInfo, (udpStream), (eventCode), (userDataPtr), (icmpMsg))
#define CallUDPIOCompletionProc(userRoutine, iopb)		\
		CallUniversalProc((UniversalProcPtr)(userRoutine), uppUDPIOCompletionProcInfo, (iopb))
#else
#define CallGetIPIOCompletionProc(userRoutine, iopb)		\
		(*(userRoutine))((iopb))
#define CallIPIOCompletionProc(userRoutine, iopb)		\
		(*(userRoutine))((iopb))
#define CallICMPEchoNotifyProc(userRoutine, iopb)		\
		(*(userRoutine))((iopb))
#define CallTCPNotifyProc(userRoutine, tcpStream, eventCode, userDataPtr, terminReason, icmpMsg)		\
		(*(userRoutine))((tcpStream), (eventCode), (userDataPtr), (terminReason), (icmpMsg))
#define CallTCPIOCompletionProc(userRoutine, iopb)		\
		(*(userRoutine))((iopb))
#define CallUDPNotifyProc(userRoutine, udpStream, eventCode, userDataPtr, icmpMsg)		\
		(*(userRoutine))((udpStream), (eventCode), (userDataPtr), (icmpMsg))
#define CallUDPIOCompletionProc(userRoutine, iopb)		\
		(*(userRoutine))((iopb))
#endif


#if PRAGMA_IMPORT_SUPPORTED
#pragma import off
#endif

#if PRAGMA_ALIGN_SUPPORTED
#pragma options align=reset
#endif

#ifdef __cplusplus
}
#endif

#endif /* __MACTCP__ */
'.
! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 2/1/2001 23:45'!
macWindowFile

	^ '#include "sq.h"

#include <AppleEvents.h>
#include <Dialogs.h>
#include <Devices.h>
#include <Files.h>
#include <Fonts.h>
#include <Gestalt.h>
#include <LowMem.h>
#include <Memory.h>
#include <Menus.h>
#include <OSUtils.h>
#include <Power.h>
#include <QuickDraw.h>
#include <Scrap.h>
#include <Strings.h>
#include <Timer.h>
#include <ToolUtils.h>
#include <Windows.h>
#include <profiler.h>
#include <sound.h>
#include <Math64.h>
#include <cstddef>
#include <processes.h>
#include <OpenTransport.h>

#include <stddef.h>



/*** Compilation Options:
*
*	define PLUGIN		to compile code for Netscape or IE Plug-in
*	define MAKE_PROFILE	to compile code for profiling
*
***/

//#define PLUGIN
//#define MAKE_PROFILE
//#define IHAVENOHEAD

//Aug 7th 2000,JMM Added logic for interrupt driven dispatching
//Sept 1st 2000, JMM fix problem with modifier information being passed back incorrectly.
//Sept 1st 2000, JMM use floating point for time versus 64bit math (faster!!)
//Sept 1st 2000, JMM watch mouse movement foreground only, ignore when squeak in background.
//Sept 18th 2000, JMM fix to cmpSize 
//Sept 19th 2000, JMM Sept 1st fix to keyboard modifier info broke cmd shift
//Sept 27 2000, JMM fix to documentPath
//Nov 13 2000, JMM logic to read/write image from VM. 
//Nov 22 2000, JMM Bob Arning found a bug with the duplicate mouse event logic (we were altering the event then recording the altered value)
//Nov 30 2000, JMM Use Open Transport clock versus upTime, solves some issues for jitter and it''s faster
//Dec 5th 2000, JMM poll 60 times a second... do event polling via checkForInterrupts and drive semaphore
//Dec 6th 2000, JMM added logic to interface with power manger (1997 was there but dropped..., back again for ibooks)
//Jan 14th 2001, KG Did some carbon porting.

#if TARGET_API_MAC_CARBON
    #define EnableMenuItemCarbon(m1,v1)  EnableMenuItem(m1,v1);
    #define DisableMenuItemCarbon(m1,v1)  DisableMenuItem(m1,v1);
#else
    #ifndef NewAEEventHandlerUPP
    	#define NewAEEventHandlerUPP NewAEEventHandlerProc 
    #endif
    #define EnableMenuItemCarbon(m1,v1)  EnableItem(m1,v1);
    #define DisableMenuItemCarbon(m1,v1)  DisableItem(m1,v1);
        inline Rect *GetPortBounds(CGrafPtr w,Rect *r) { *r = w->portRect; return &w->portRect;}  
        inline BitMap *GetQDGlobalsScreenBits(BitMap *bm){*bm = qd.screenBits; return &qd.screenBits; }
        inline BitMap * GetPortBitMapForCopyBits (CGrafPtr w) { return &((GrafPtr)w)->portBits;}
        inline pascal long InvalWindowRect(WindowRef  window,  const Rect * bounds) {InvalRect (bounds);}
#endif

/*** Enumerations ***/
enum { appleID = 1, fileID, editID };
enum { quitItem = 1 };

/* The following prototype is missing from the CW11 header files: */
pascal void ExitToShell(void);

/*** Variables -- Imported from Browser Plugin Module ***/
#ifdef PLUGIN
extern int pluginArgCount;
extern char *pluginArgName[100];
extern char *pluginArgValue[100];
#endif

/*** Variables -- Imported from Virtual Machine ***/
extern int fullScreenFlag;
extern int interruptCheckCounter;
extern int interruptKeycode;
extern int interruptPending;  /* set to true by recordKeystroke if interrupt key is pressed */
extern unsigned char *memory;
extern int savedWindowSize;   /* set from header when image file is loaded */

/*** Variables -- image and path names ***/
#define IMAGE_NAME_SIZE 300
char imageName[IMAGE_NAME_SIZE + 1];  /* full path to image file */

#define SHORTIMAGE_NAME_SIZE 100
char shortImageName[SHORTIMAGE_NAME_SIZE + 1];  /* just the image file name */

#define DOCUMENT_NAME_SIZE 300
char documentName[DOCUMENT_NAME_SIZE + 1];  /* full path to document file */

#define VMPATH_SIZE 300
char vmPath[VMPATH_SIZE + 1];  /* full path to interpreter''s directory */

/*** Variables -- Mac Related ***/
MenuHandle		appleMenu = nil;
MenuHandle		editMenu = nil;
int				menuBarHeight = 20;
RgnHandle		menuBarRegion = nil;  /* if non-nil, then menu bar has been hidden */
MenuHandle		fileMenu = nil;
CTabHandle		stColorTable = nil;
PixMapHandle	stPixMap = nil;
WindowPtr		stWindow = nil;
OTTimeStamp     timeStart;
Boolean         gTapPowerManager=false;
Boolean         gDisablePowerManager=false;
const long      gDisableIdleTickCount=60*10;
long            gDisableIdleTickLimit=0;

/*** Variables -- Event Recording ***/
#define MAX_EVENT_BUFFER 1024
int inputSemaphoreIndex = 0;/* if non-zero the event semaphore index */

sqInputEvent eventBuffer[MAX_EVENT_BUFFER];
int eventBufferGet = 0;
int eventBufferPut = 0;

/* declaration of the event message hook */
typedef int (*eventMessageHook)(EventRecord* event);
eventMessageHook messageHook = NULL;
eventMessageHook postMessageHook = NULL;


#define KEYBUF_SIZE 64
int keyBuf[KEYBUF_SIZE];	/* circular buffer */
int keyBufGet = 0;			/* index of next item of keyBuf to read */
int keyBufPut = 0;			/* index of next item of keyBuf to write */
int keyBufOverflows = 0;	/* number of characters dropped */

int buttonState = 0;		/* mouse button and modifier state when mouse
							   button went down or 0 if not pressed */
int cachedButtonState = 0;	/* buffered mouse button and modifier state for
							   last mouse click even if button has since gone up;
							   this cache is kept until the next time ioGetButtonState()
							   is called to avoid missing short clicks */

Point savedMousePosition;	/* mouse position when window is inactive */
int windowActive = true;	/* true if the Squeak window is the active window */

/* This table maps the 5 Macintosh modifier key bits to 4 Squeak modifier
   bits. (The Mac shift and caps lock keys are both mapped to the single
   Squeak shift bit).
		Mac bits: <control><option><caps lock><shift><command>
		ST bits:  <command><option><control><shift>
*/
char modifierMap[32] = {
	0,  8, 1,  9, 1,  9, 1,  9, 4, 12, 5, 13, 5, 13, 5, 13,
	2, 10, 3, 11, 3, 11, 3, 11, 6, 14, 7, 15, 7, 15, 7, 15
};

/*** Functions ***/
void AdjustMenus(void);
void FreeClipboard(void);
void FreePixmap(void);
char * GetAttributeString(int id);
int  HandleEvents(void);
void HandleMenu(int mSelect);
void HandleMouseDown(EventRecord *theEvent);
void InitMacintosh(void);
void InstallAppleEventHandlers(void);
int  IsImageName(char *name);
CFragConnectionID LoadLibViaPath(char *libName, char *pluginDirPath);
void MenuBarHide(void);
void MenuBarRestore(void);
int PathToWorkingDir(char *pathName, int pathNameMax, short volumeNumber,long directoryID);
int PrefixPathWith(char *pathName, int pathNameSize, int pathNameMax, char *prefix);
void SetColorEntry(int index, int red, int green, int blue);
void SetUpClipboard(void);
void SetUpMenus(void);
void SetUpPixmap(void);
void SetUpWindow(void);
void SetWindowTitle(char *title);
void StoreFullPathForLocalNameInto(char *shortName, char *fullName, int length, short VolumeNumber,long directoryID);
void SqueakTerminate();
void ExitCleanup();
int calculateStartLocationForImage();
extern int dropInit(void);
Boolean RunningOnCarbonX(void);

OSStatus GetApplicationDirectory(short *vRefNum, long *dirID);
pascal	OSErr	GetFullPath(short vRefNum,
							long dirID,
							ConstStr255Param name,
							short *fullPathLength,
							Handle *fullPath);
pascal	OSErr	FSpGetFullPath(const FSSpec *spec,
							   short *fullPathLength,
							   Handle *fullPath);
pascal OSErr FSpLocationFromFullPath(short fullPathLength,
									 const void *fullPath,
									 FSSpec *spec);
pascal	OSErr	FSMakeFSSpecCompat(short vRefNum,
								   long dirID,
								   ConstStr255Param fileName,
								   FSSpec *spec);

/* event capture */
sqInputEvent *nextEventPut(void);

int recordKeystroke(EventRecord *theEvent);
int recordModifierButtons(EventRecord *theEvent);
int recordMouseDown(EventRecord *theEvent);
int recordMouseEvent(EventRecord *theEvent, int theButtonState);
int recordDragDropEvent(EventRecord *theEvent, int theButtonState, int numberOfItems, int dragType);
int recordKeyboardEvent(EventRecord *theEvent, int keyType);
int MouseModifierState(EventRecord *theEvent);
WindowPtr getSTWindow(void);
int setMessageHook(eventMessageHook theHook);
int setPostMessageHook(eventMessageHook theHook);
void PowerMgrCheck(void);


/*** Apple Event Handlers ***/
static pascal OSErr HandleOpenAppEvent(const AEDescList *aevt,  AEDescList *reply, long refCon);
static pascal OSErr HandleOpenDocEvent(const AEDescList *aevt,  AEDescList *reply, long refCon);
static pascal OSErr HandlePrintDocEvent(const AEDescList *aevt, AEDescList *reply, long refCon);
static pascal OSErr HandleQuitAppEvent(const AEDescList *aevt,  AEDescList *reply, long refCon);

/*** Apple Event Handling ***/

void InstallAppleEventHandlers() {
	OSErr	err;
	long	result;

	shortImageName[0] = 0;
	err = Gestalt(gestaltAppleEventsAttr, &result);
	if (err == noErr) {
		AEInstallEventHandler(kCoreEventClass, kAEOpenApplication, NewAEEventHandlerUPP(HandleOpenAppEvent),  0, false);
		AEInstallEventHandler(kCoreEventClass, kAEOpenDocuments,   NewAEEventHandlerUPP(HandleOpenDocEvent),  0, false);
		AEInstallEventHandler(kCoreEventClass, kAEPrintDocuments,  NewAEEventHandlerUPP(HandlePrintDocEvent), 0, false);
		AEInstallEventHandler(kCoreEventClass, kAEQuitApplication, NewAEEventHandlerUPP(HandleQuitAppEvent),  0, false);
	}
}

pascal OSErr HandleOpenAppEvent(const AEDescList *aevt,  AEDescList *reply, long refCon) {
	/* User double-clicked application; look for "squeak.image" in same directory */
    int                 checkValueForEmbeddedImage;
    OSErr               err;
	FSSpec		        fileSpec;
	Str32                name; 
	
/* record path to VM''s home folder */
	short vRefNum;
	long dirID;

	// Get the Volume ref and Directory id of the Application''s directory.
    err = GetApplicationDirectory(&vRefNum, &dirID);
    if (err !!= noErr) return err;

	// Convert that to a full path string.
	PathToWorkingDir(vmPath, VMPATH_SIZE, vRefNum, dirID);

	checkValueForEmbeddedImage = calculateStartLocationForImage();
	if (checkValueForEmbeddedImage == 0) {
	    /* use default image name in same directory as the VM */
	    strcpy(shortImageName, "squeak.image");
	    return noErr;
	}

	if (err !!= noErr) {
		strcpy(shortImageName, "squeak.image");
	    return noErr;
	}
	
	CopyPascalStringToC(name,shortImageName);
	StoreFullPathForLocalNameInto(shortImageName, imageName, IMAGE_NAME_SIZE, vRefNum, dirID);

    return noErr;
}

pascal OSErr HandleOpenDocEvent(const AEDescList *aevt, AEDescList *reply, long refCon) {
	/* User double-clicked an image file. Record the path to the VM''s directory,
	   then set the default directory to the folder containing the image and
	   record the image name. Fail if mullitple image files were selected. */

	OSErr		err;
	AEDesc		fileList = {''NULL'', NULL};
	long		numFiles, size;
	DescType	type;
	AEKeyword	keyword;
	FSSpec		fileSpec;
	WDPBRec		pb;
	FInfo		finderInformation;
	char 		tempShortName[SHORTIMAGE_NAME_SIZE + 1];	
	short vRefNum;
	long dirID;
	
	reply; refCon;  /* reference args to avoid compiler warnings */

	/* record path to VM''s home folder */
    err = GetApplicationDirectory(&vRefNum, &dirID);
    if (err !!= noErr) return err;
    
	PathToWorkingDir(vmPath, VMPATH_SIZE, vRefNum, dirID);
	
	/* copy document list */
	err = AEGetKeyDesc(aevt, keyDirectObject, typeAEList, &fileList);
	if (err) return errAEEventNotHandled;;

	/* count list elements */
	err = AECountItems( &fileList, &numFiles);
	if (err) goto done;
	
	if (shortImageName[0] !!= 0) {
#ifdef IHAVENOHEAD
		/* get image name */
		err = AEGetNthPtr(&fileList, 1, typeFSS,
						  &keyword, &type, (Ptr) &fileSpec, sizeof(fileSpec), &size);
		if (err) goto done;
		
		err = FSpGetFInfo(&fileSpec,&finderInformation);
		if (err) goto done;
			
		CopyPascalStringToC(fileSpec.name,tempShortName);

		if (finderInformation.fdType == ''SOBJ'') {
			StoreFullPathForLocalNameInto(tempShortName, documentName, DOCUMENT_NAME_SIZE,fileSpec.vRefNum,fileSpec.parID);
		}
#endif
		goto done;
	}

	/* get image name */
	err = AEGetNthPtr(&fileList, 1, typeFSS,
					  &keyword, &type, (Ptr) &fileSpec, sizeof(fileSpec), &size);
	if (err) goto done;
	
	err = FSpGetFInfo(&fileSpec,&finderInformation);
	if (err) goto done;
		
	CopyPascalStringToC(fileSpec.name,shortImageName);

	if (!!(IsImageName(shortImageName) || finderInformation.fdType == ''STim'') || finderInformation.fdType == ''STch'') {
		/* record the document name, but run the default image in VM directory */
		if (finderInformation.fdType == ''SOBJ'')
			StoreFullPathForLocalNameInto(shortImageName, documentName, DOCUMENT_NAME_SIZE,fileSpec.vRefNum,fileSpec.parID);

		strcpy(shortImageName, "squeak.image");
		StoreFullPathForLocalNameInto(shortImageName, imageName, IMAGE_NAME_SIZE, vRefNum, dirID);
	}
	/* make the image or document directory the working directory */
	pb.ioNamePtr = NULL;
	pb.ioVRefNum = fileSpec.vRefNum;
	pb.ioWDDirID = fileSpec.parID;
	PBHSetVolSync(&pb);

done:
	AEDisposeDesc(&fileList);
	return err;
}

pascal OSErr HandlePrintDocEvent(const AEDescList *aevt,  AEDescList *reply, long refCon) {
	aevt; reply; refCon;  /* reference args to avoid compiler warnings */
	return errAEEventNotHandled;
}

pascal OSErr HandleQuitAppEvent(const AEDescList *aevt,  AEDescList *reply, long refCon) {
	aevt; reply; refCon;  /* reference args to avoid compiler warnings */
	return errAEEventNotHandled;
}

/*** VM Home Directory Path ***/

int vmPathSize(void) {
	return strlen(vmPath);
}

int vmPathGetLength(int sqVMPathIndex, int length) {
	char *stVMPath = (char *) sqVMPathIndex;
	int count, i;

	count = strlen(vmPath);
	count = (length < count) ? length : count;

	/* copy the file name into the Squeak string */
	for (i = 0; i < count; i++) {
		stVMPath[i] = vmPath[i];
	}
	return count;
}

/*** Mac-related Functions ***/

void AdjustMenus(void) {
	WindowRef		wp;
	int				isDeskAccessory;

	wp = FrontWindow();
	if (wp !!= NULL) {
		isDeskAccessory = GetWindowKind(wp) < 0;
	} else {
		isDeskAccessory = false;
	}

	if (isDeskAccessory) {
		/* Enable items in the Edit menu */
		EnableMenuItemCarbon(editMenu, 1);
		EnableMenuItemCarbon(editMenu, 3);
		EnableMenuItemCarbon(editMenu, 4);
		EnableMenuItemCarbon(editMenu, 5);
		EnableMenuItemCarbon(editMenu, 6);
	} else {
		/* Disable items in the Edit menu */
		DisableMenuItemCarbon(editMenu, 1);
		DisableMenuItemCarbon(editMenu, 3);
		DisableMenuItemCarbon(editMenu, 4);
		DisableMenuItemCarbon(editMenu, 5);
		DisableMenuItemCarbon(editMenu, 6);
	}
}

int HandleEvents(void) {
	EventRecord		theEvent;
	static EventRecord oldEvent;
	int				ok;
	Rect    bounds;

	ok = WaitNextEvent(everyEvent, &theEvent,0,null);
	if((messageHook) && (messageHook(&theEvent))) {
        return ok;
    }
	if (ok) {
		switch (theEvent.what) {
			case mouseDown:
				HandleMouseDown(&theEvent);
				if(postMessageHook) postMessageHook(&theEvent);
				return false;
			break;

			case mouseUp:
				if(inputSemaphoreIndex) {
					recordMouseEvent(&theEvent,MouseModifierState(&theEvent));
    				if(postMessageHook) postMessageHook(&theEvent);
					return false;
				}
				recordModifierButtons(&theEvent);
				if(postMessageHook) postMessageHook(&theEvent);
				return false;
			break;

			case keyDown:
			case autoKey:
				if ((theEvent.modifiers & cmdKey) !!= 0) {
					AdjustMenus();
					HandleMenu(MenuKey(theEvent.message & charCodeMask));
				}
				if(inputSemaphoreIndex) {
					recordKeyboardEvent(&theEvent,EventKeyDown);
					break;
				}
				recordModifierButtons(&theEvent);
				recordKeystroke(&theEvent);
			break;
			
			case keyUp:
				if(inputSemaphoreIndex) {
					recordKeyboardEvent(&theEvent,EventKeyUp);
				}
			break;

#ifndef IHAVENOHEAD
			case updateEvt:
				BeginUpdate(stWindow);
				fullDisplayUpdate();  /* this makes VM call ioShowDisplay */
				EndUpdate(stWindow);
			break;

			case activateEvt:
				if (theEvent.modifiers & activeFlag) {
					windowActive = true;
				} else {
					GetMouse(&savedMousePosition);
					windowActive = false;
				}
				GetPortBounds(GetWindowPort(stWindow),&bounds);
				InvalWindowRect(stWindow,&bounds);
			break;
#endif

			case kHighLevelEvent:
				AEProcessAppleEvent(&theEvent);
			break;
			
			case osEvt: 
				if (((theEvent.message>>24)& 0xFF) == suspendResumeMessage) {
				
					//JMM July 4th 2000
					//Fix for menu bar tabbing, thanks to Javier Diaz-Reinoso for pointing this out
					//
					if (fullScreenFlag) {
						if ((theEvent.message & resumeFlag) == 0) {
							MenuBarRestore();
						}
						else {
							MenuBarHide();
						}
					}
				}
				break;
		}
	}
	else {
		if(inputSemaphoreIndex && windowActive && 
		    !!((oldEvent.what == theEvent.what) && 
 		    (oldEvent.message == theEvent.message) &&
 		    ((oldEvent.where.v == theEvent.where.v) && (oldEvent.where.h == theEvent.where.h)) &&
 		    (oldEvent.modifiers == theEvent.modifiers))) {
    		oldEvent = theEvent; //JMM Nov 11th 2000 bug fix 
			recordMouseEvent(&theEvent,MouseModifierState(&theEvent));
 		}
 		else
		 oldEvent = theEvent;
	}
	if(postMessageHook) postMessageHook(&theEvent); 
	return ok;
}

void HandleMenu(int mSelect) {
	int			menuID, menuItem;
	Str255		name;
	GrafPtr		savePort;

	menuID = HiWord(mSelect);
	menuItem = LoWord(mSelect);
	switch (menuID) {
		case appleID:
			GetPort(&savePort);
			GetMenuItemText(appleMenu, menuItem, name);
#if !!TARGET_API_MAC_CARBON
			OpenDeskAcc(name);
#endif 
			SetPort(savePort);
		break;

		case fileID:
			if (menuItem == quitItem) {
				ioExit();
			}
		break;

		case editID:
#if !!TARGET_API_MAC_CARBON
			if (!!SystemEdit(menuItem - 1)) {
				SysBeep(5);
			}
#endif
		break;
	}
}

void HandleMouseDown(EventRecord *theEvent) {
    BitMap      bmap;
	WindowPtr	theWindow;
	Rect		growLimits = { 20, 20, 4000, 4000 };
	int			windowCode, newSize;

	windowCode = FindWindow(theEvent->where, &theWindow);
	switch (windowCode) {
		case inSysWindow:
#if !!TARGET_API_MAC_CARBON
			SystemClick(theEvent, theWindow);
#endif
		break;

		case inMenuBar:
			AdjustMenus();
			HandleMenu(MenuSelect(theEvent->where));
		break;

#ifndef IHAVENOHEAD
		case inDrag:

			GetQDGlobalsScreenBits(&bmap);
			if (theWindow == stWindow) {
				DragWindow(stWindow, theEvent->where, &bmap.bounds);
			}
		break;

		case inGrow:
			if (theWindow == stWindow) {
				newSize = GrowWindow(stWindow, theEvent->where, &growLimits);
				if (newSize !!= 0) {
					SizeWindow(stWindow, LoWord(newSize), HiWord(newSize), true);
				}
			}
		break;

		case inContent:
			if (theWindow == stWindow) {
				if (theWindow !!= FrontWindow()) {
					SelectWindow(stWindow);
				}
				if(inputSemaphoreIndex) {
					recordMouseEvent(theEvent,MouseModifierState(theEvent));
					break;
				}
				recordMouseDown(theEvent);
			}
		break;

		case inGoAway:
			if ((theWindow == stWindow) &&
				(TrackGoAway(stWindow, theEvent->where))) {
					/* HideWindow(stWindow); noop for now */
			}
		break;
#endif
	}
}


#if TARGET_API_MAC_CARBON
void InitMacintosh(void) {
	FlushEvents(everyEvent, 0);
	InitCursor();
}

void MenuBarHide(void) {
 	if (menuBarRegion !!= nil) return;  /* saved state, so menu bar is already hidden */
    menuBarRegion = (RgnHandle) 1;
    HideMenuBar();
}
void MenuBarRestore(void) {
	if (menuBarRegion == nil) return;  /* no saved state, so menu bar is not hidden */
    ShowMenuBar();
    menuBarRegion = nil;
}

/*** Clipboard Support (text only for now) ***/

void SetUpClipboard(void) {
}

void FreeClipboard(void) {
}

int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex) {
	long clipSize, charsToMove;
	ScrapRef scrap;
	OSStatus err;

    err = GetCurrentScrap (&scrap);
    if (err !!= noErr) return 0;       
	clipSize = clipboardSize();
 	charsToMove = (count < clipSize) ? count : clipSize;
    err = GetScrapFlavorData(scrap,kScrapFlavorTypeText,(long *) &charsToMove,(char *) byteArrayIndex + startIndex);
    if (err !!= noErr) { 
        FreeClipboard();
        return 0;       
    }
	return charsToMove;
}

int clipboardSize(void) {
	long count;
	ScrapRef scrap;
	OSStatus err;

    err = GetCurrentScrap (&scrap);
    if (err !!= noErr) return 0;       
    err = GetScrapFlavorSize (scrap, kScrapFlavorTypeText, &count); 
	if (err !!= noErr) {
		return 0;
	} else {
		return count;
	}
}

int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex) {
	ScrapRef scrap;
	OSErr err;
	err = ClearCurrentScrap();
    err = GetCurrentScrap (&scrap);
	err = PutScrapFlavor ( scrap, kScrapFlavorTypeText, kScrapFlavorMaskNone , count,  (const void *) (byteArrayIndex + startIndex));
}

#else 
void InitMacintosh(void) {
	MaxApplZone();
	InitGraf(&qd.thePort);
	InitFonts();
	FlushEvents(everyEvent, 0);
	InitWindows();
	InitMenus();
	TEInit();
	InitDialogs(NULL);
	InitCursor();
}

void MenuBarHide(void) {
  /* Remove the menu bar, saving its old state. */
  /* Many thanks to John McIntosh for this code!! */
	Rect screenRect, mBarRect;

	if (menuBarRegion !!= nil) return;  /* saved state, so menu bar is already hidden */
	screenRect = (**GetMainDevice()).gdRect;
	menuBarHeight = GetMBarHeight();
	SetRect(&mBarRect, screenRect.left, screenRect.top, screenRect.right, screenRect.top + menuBarHeight);
	menuBarRegion = NewRgn();
	if (menuBarRegion !!= nil) {
		LMSetMBarHeight(0);
		RectRgn(menuBarRegion, &mBarRect);
		UnionRgn(GetGrayRgn(), menuBarRegion, GetGrayRgn());
	}
}

void MenuBarRestore(void) {
  /* Restore the menu bar from its saved state. Do nothing if it isn''t hidden. */
  /* Many thanks to John McIntosh for this code!! */
 
 	WindowPtr win;
 	
	if (menuBarRegion == nil) return;  /* no saved state, so menu bar is not hidden */
	DiffRgn(GetGrayRgn(), menuBarRegion, GetGrayRgn());
	LMSetMBarHeight(menuBarHeight);
	
	win = FrontWindow();
	if (win) {
		CalcVis(win);
		CalcVisBehind(win,menuBarRegion);
	}
	HiliteMenu(0);
	DisposeRgn(menuBarRegion);
	
	menuBarRegion = nil;
	DrawMenuBar();
}

/*** Clipboard Support (text only for now) ***/
Handle			clipboardBuffer = nil;

void SetUpClipboard(void) {
	/* allocate clipboard in the system heap to support really big copy/paste */
	THz oldZone;

	oldZone = GetZone();
	SetZone(SystemZone());
	clipboardBuffer = NewHandle(0);
	SetZone(oldZone);
}

void FreeClipboard(void) {
	if (clipboardBuffer !!= nil) {
		DisposeHandle(clipboardBuffer);
		clipboardBuffer = nil;
	}
}

int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex) {
	long clipSize, charsToMove;
	char *srcPtr, *dstPtr, *end;

	clipSize = clipboardSize();
	charsToMove = (count < clipSize) ? count : clipSize;
    //JMM locking
    HLock(clipboardBuffer); 
	srcPtr = (char *) *clipboardBuffer;
	dstPtr = (char *) byteArrayIndex + startIndex;
	end = srcPtr + charsToMove;
	while (srcPtr < end) {
		*dstPtr++ = *srcPtr++;
	}
    HUnlock(clipboardBuffer); 
	return charsToMove;
}

int clipboardSize(void) {
	long count, offset;

	count = GetScrap(clipboardBuffer, ''TEXT'', &offset);
	if (count < 0) {
		return 0;
	} else {
		return count;
	}
}

int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex) {
	ZeroScrap();
	PutScrap(count, ''TEXT'', (char *) (byteArrayIndex + startIndex));
}

#endif

void SetUpMenus(void) {
	long decideOnQuitMenu;
	
	InsertMenu(appleMenu = NewMenu(appleID, "\p\024"), 0);
	InsertMenu(fileMenu  = NewMenu(fileID,  "\pFile"), 0);
	InsertMenu(editMenu  = NewMenu(editID,  "\pEdit"), 0);
	DrawMenuBar();
#if TARGET_API_MAC_CARBON
    Gestalt( gestaltMenuMgrAttr, &decideOnQuitMenu);
    if (!!(decideOnQuitMenu & gestaltMenuMgrAquaLayoutMask))	
        AppendMenu(fileMenu, "\pQuit");
#else
	AppendResMenu(appleMenu, ''DRVR'');
    AppendMenu(fileMenu, "\pQuit");
#endif
 	AppendMenu(editMenu, "\pUndo/Z;(-;Cut/X;Copy/C;Paste/V;Clear");
}

void SetColorEntry(int index, int red, int green, int blue) {
	(*stColorTable)->ctTable[index].value = index;
	(*stColorTable)->ctTable[index].rgb.red = red;
	(*stColorTable)->ctTable[index].rgb.green = green;
	(*stColorTable)->ctTable[index].rgb.blue = blue;
}

void FreePixmap(void) {
	if (stPixMap !!= nil) {
		DisposePixMap(stPixMap);
		stPixMap = nil;
	}

	if (stColorTable !!= nil) {
		DisposeHandle((void *) stColorTable);
		stColorTable = nil;
	}
}

void SetUpPixmap(void) {
	int i, r, g, b;

	stColorTable = (CTabHandle) NewHandle(sizeof(ColorTable) + (256 * sizeof(ColorSpec)));
	(*stColorTable)->ctSeed = GetCTSeed();
	(*stColorTable)->ctFlags = 0;
	(*stColorTable)->ctSize = 255;

	/* 1-bit colors (monochrome) */
	SetColorEntry(0, 65535, 65535, 65535);	/* white or transparent */
	SetColorEntry(1,     0,     0,     0);	/* black */

	/* additional colors for 2-bit color */
	SetColorEntry(2, 65535, 65535, 65535);	/* opaque white */
	SetColorEntry(3, 32768, 32768, 32768);	/* 1/2 gray */

	/* additional colors for 4-bit color */
	SetColorEntry( 4, 65535,     0,     0);	/* red */
	SetColorEntry( 5,     0, 65535,     0);	/* green */
	SetColorEntry( 6,     0,     0, 65535);	/* blue */
	SetColorEntry( 7,     0, 65535, 65535);	/* cyan */
	SetColorEntry( 8, 65535, 65535,     0);	/* yellow */
	SetColorEntry( 9, 65535,     0, 65535);	/* magenta */
	SetColorEntry(10,  8192,  8192,  8192);	/* 1/8 gray */
	SetColorEntry(11, 16384, 16384, 16384);	/* 2/8 gray */
	SetColorEntry(12, 24576, 24576, 24576);	/* 3/8 gray */
	SetColorEntry(13, 40959, 40959, 40959);	/* 5/8 gray */
	SetColorEntry(14, 49151, 49151, 49151);	/* 6/8 gray */
	SetColorEntry(15, 57343, 57343, 57343);	/* 7/8 gray */

	/* additional colors for 8-bit color */
	/* 24 more shades of gray (does not repeat 1/8th increments) */
	SetColorEntry(16,  2048,  2048,  2048);	/*  1/32 gray */
	SetColorEntry(17,  4096,  4096,  4096);	/*  2/32 gray */
	SetColorEntry(18,  6144,  6144,  6144);	/*  3/32 gray */
	SetColorEntry(19, 10240, 10240, 10240);	/*  5/32 gray */
	SetColorEntry(20, 12288, 12288, 12288);	/*  6/32 gray */
	SetColorEntry(21, 14336, 14336, 14336);	/*  7/32 gray */
	SetColorEntry(22, 18432, 18432, 18432);	/*  9/32 gray */
	SetColorEntry(23, 20480, 20480, 20480);	/* 10/32 gray */
	SetColorEntry(24, 22528, 22528, 22528);	/* 11/32 gray */
	SetColorEntry(25, 26624, 26624, 26624);	/* 13/32 gray */
	SetColorEntry(26, 28672, 28672, 28672);	/* 14/32 gray */
	SetColorEntry(27, 30720, 30720, 30720);	/* 15/32 gray */
	SetColorEntry(28, 34815, 34815, 34815);	/* 17/32 gray */
	SetColorEntry(29, 36863, 36863, 36863);	/* 18/32 gray */
	SetColorEntry(30, 38911, 38911, 38911);	/* 19/32 gray */
	SetColorEntry(31, 43007, 43007, 43007);	/* 21/32 gray */
	SetColorEntry(32, 45055, 45055, 45055);	/* 22/32 gray */
	SetColorEntry(33, 47103, 47103, 47103);	/* 23/32 gray */
	SetColorEntry(34, 51199, 51199, 51199);	/* 25/32 gray */
	SetColorEntry(35, 53247, 53247, 53247);	/* 26/32 gray */
	SetColorEntry(36, 55295, 55295, 55295);	/* 27/32 gray */
	SetColorEntry(37, 59391, 59391, 59391);	/* 29/32 gray */
	SetColorEntry(38, 61439, 61439, 61439);	/* 30/32 gray */
	SetColorEntry(39, 63487, 63487, 63487);	/* 31/32 gray */

	/* The remainder of color table defines a color cube with six steps
	   for each primary color. Note that the corners of this cube repeat
	   previous colors, but simplifies the mapping between RGB colors and
	   color map indices. This color cube spans indices 40 through 255.
	*/
	for (r = 0; r < 6; r++) {
		for (g = 0; g < 6; g++) {
			for (b = 0; b < 6; b++) {
				i = 40 + ((36 * r) + (6 * b) + g);
				if (i > 255) error("index out of range in color table compuation");
				SetColorEntry(i, (r * 65535) / 5, (g * 65535) / 5, (b * 65535) / 5);
			}
		}
	}

	stPixMap = NewPixMap();
	(*stPixMap)->pixelType = 0; /* chunky */
	(*stPixMap)->cmpCount = 1;
	(*stPixMap)->pmTable = stColorTable;
}

void SetUpWindow(void) {
	Rect windowBounds = {44, 8, 300, 500};

#ifndef IHAVENOHEAD
	stWindow = NewCWindow(
		0L, &windowBounds,
		"\p Welcome to Squeak!!  Reading Squeak image file... ",
		true, documentProc, (WindowPtr) -1L, false, 0);
#endif
}

void SetWindowTitle(char *title) {
    Str255 tempTitle;
	CopyCStringToPascal(title,tempTitle);
#ifndef IHAVENOHEAD
	SetWTitle(stWindow, tempTitle);
#endif
}

/*** Event Recording Functions ***/

int recordKeystroke(EventRecord *theEvent) {
	int asciiChar, modifierBits, keystate;

	/* keystate: low byte is the ascii character; next 4 bits are modifier bits */
	asciiChar = theEvent->message & charCodeMask;
	modifierBits = modifierMap[(theEvent->modifiers >> 8) & 0x1F];
	if ((modifierBits & 0x9) == 0x9) {  /* command and shift */
		if ((asciiChar >= 97) && (asciiChar <= 122)) {
			/* convert ascii code of command-shift-letter to upper case */
			asciiChar = asciiChar - 32;
		}
	}

	keystate = (modifierBits << 8) | asciiChar;
	if (keystate == interruptKeycode) {
		/* Note: interrupt key is "meta"; it not reported as a keystroke */
		interruptPending = true;
		interruptCheckCounter = 0;
	} else {
		keyBuf[keyBufPut] = keystate;
		keyBufPut = (keyBufPut + 1) % KEYBUF_SIZE;
		if (keyBufGet == keyBufPut) {
			/* buffer overflow; drop the last character */
			keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;
			keyBufOverflows++;
		}
	}
}

int recordMouseDown(EventRecord *theEvent) {

	/* button state: low three bits are mouse buttons; next 4 bits are modifier bits */
	buttonState = MouseModifierState(theEvent);
	cachedButtonState = cachedButtonState | buttonState;
}

int MouseModifierState(EventRecord *theEvent) {
	int stButtons;

	stButtons = 0;
	if ((theEvent->modifiers & btnState) == false) {  /* is false if button is down */
		stButtons = 4;		/* red button by default */
		if ((theEvent->modifiers & optionKey) !!= 0) {
			stButtons = 2;	/* yellow button if option down */
		}
		if ((theEvent->modifiers & cmdKey) !!= 0) {
			stButtons = 1;	/* blue button if command down */
		}
	} 

	/* button state: low three bits are mouse buttons; next 4 bits are modifier bits */
	return ((modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |
		(stButtons & 0x7));
}

int recordModifierButtons(EventRecord *theEvent) {
	int stButtons = 0;

	if ((theEvent->modifiers & btnState) == false) {
		stButtons = buttonState & 0x7;
	} else {
		stButtons = 0;
	}
	/* button state: low three bits are mouse buttons; next 4 bits are modifier bits */
	buttonState =
		(modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) |
		(stButtons & 0x7);
}

int recordMouseEvent(EventRecord *theEvent, int theButtonState) {
	sqMouseEvent *evt;
	
	evt = (sqMouseEvent*) nextEventPut();

	/* first the basics */
	evt->type = EventTypeMouse;
	evt->timeStamp = ioMSecs(); 
	GlobalToLocal((Point *) &theEvent->where);
	evt->x = theEvent->where.h;
	evt->y = theEvent->where.v;
	/* then the buttons */
	evt->buttons = theButtonState & 0x07;
	/* then the modifiers */
	evt->modifiers = theButtonState >> 3;
	/* clean up reserved */
	evt->reserved1 = 0;
	evt->reserved2 = 0;
//	signalSemaphoreWithIndex(inputSemaphoreIndex);
	return 1;
}

int recordDragDropEvent(EventRecord *theEvent, int theButtonState, int numberOfItems, int dragType) {
	sqDragDropFilesEvent *evt;
	
	evt = (sqDragDropFilesEvent*) nextEventPut();

	/* first the basics */
	evt->type = EventTypeDragDropFiles;
	evt->timeStamp = ioMSecs(); 
	GlobalToLocal((Point *) &theEvent->where);
	evt->x = theEvent->where.h;
	evt->y = theEvent->where.v;
	evt->numFiles = numberOfItems;
	evt->dragType = dragType;
	
	/* then the modifiers */
	evt->modifiers = theButtonState >> 3;
	/* clean up reserved */
	evt->reserved1 = 0;
//	signalSemaphoreWithIndex(inputSemaphoreIndex);
	return 1;
}

int recordKeyboardEvent(EventRecord *theEvent, int keyType) {
	int stButtons = 0;
	int asciiChar, modifierBits;
	sqKeyboardEvent *evt, *extra;

	evt = (sqKeyboardEvent*) nextEventPut();

	/* keystate: low byte is the ascii character; next 4 bits are modifier bits */
	asciiChar = theEvent->message & charCodeMask;
	modifierBits = MouseModifierState(theEvent); //Capture mouse/option states
	if (((modifierBits >> 3) & 0x9) == 0x9) {  /* command and shift */
		if ((asciiChar >= 97) && (asciiChar <= 122)) {
			/* convert ascii code of command-shift-letter to upper case */
			asciiChar = asciiChar - 32;
		}
	}

	/* first the basics */
	evt->type = EventTypeKeyboard;
	evt->timeStamp = ioMSecs();
	/* now the key code */
	/* press code must differentiate */
	evt->charCode = (theEvent->message & keyCodeMask) >> 8;
	evt->pressCode = keyType;
	evt->modifiers = modifierBits >> 3;
	/* clean up reserved */
	evt->reserved1 = 0;
	evt->reserved2 = 0;
	/* generate extra character event */
	if (keyType == EventKeyDown) {
		extra = (sqKeyboardEvent*)nextEventPut();
		*extra = *evt;
		extra->charCode = asciiChar;
		extra->pressCode = EventKeyChar;
	}
//	signalSemaphoreWithIndex(inputSemaphoreIndex);
	return 1;
}

static sqInputEvent *nextEventPut(void) {
	sqInputEvent *evt;
	evt = eventBuffer + eventBufferPut;
	eventBufferPut = (eventBufferPut + 1) % MAX_EVENT_BUFFER;
	if (eventBufferGet == eventBufferPut) {
		/* buffer overflow; drop the last event */
		eventBufferGet = (eventBufferGet + 1) % MAX_EVENT_BUFFER;
	}
	return evt;
}

int ioSetInputSemaphore(int semaIndex) {
	inputSemaphoreIndex = semaIndex;
	return 1;
}

int ioGetNextEvent(sqInputEvent *evt) {
	if (eventBufferGet == eventBufferPut) {
		ioProcessEvents();
	}
	if (eventBufferGet == eventBufferPut) 
		return false;

	*evt = eventBuffer[eventBufferGet];
	eventBufferGet = (eventBufferGet+1) % MAX_EVENT_BUFFER;
	return true;
}


/*** Mac Specific External Primitive Support ***/

/* ioLoadModule:
	Load a module from disk.
	WARNING: this always loads a *new* module. Don''t even attempt to find a loaded one.
	WARNING: never primitiveFail() within, just return 0
*/
int ioLoadModule(char *pluginName) {
	char pluginDirPath[1000];
	CFragConnectionID libHandle;
	Ptr mainAddr;
	Str255 errorMsg,tempPluginName;
	OSErr err;
    
    	/* first, look in the "<Squeak VM directory>Plugins" directory for the library */
	strcpy(pluginDirPath, vmPath);
	
#ifdef PLUGIN
	strcat(pluginDirPath, ":Plugins");
#else
	strcat(pluginDirPath, "Plugins");
#endif 	
    
    libHandle = LoadLibViaPath(pluginName, pluginDirPath);
	if (libHandle !!= nil) return (int) libHandle;

#ifndef PLUGIN
	/* second, look directly in Squeak VM directory for the library */
	libHandle = LoadLibViaPath(pluginName, vmPath);
	if (libHandle !!= nil) return (int) libHandle;
    
    /* Lastly look for it as a shared import library */
    
    CopyCStringToPascal(pluginName,tempPluginName);
    err = GetSharedLibrary(tempPluginName, kAnyCFragArch, kLoadCFrag, &libHandle, &mainAddr, errorMsg);
	if (err == noErr) 
	    err = GetSharedLibrary(tempPluginName, kAnyCFragArch, kFindCFrag, &libHandle, &mainAddr, errorMsg);
	if (libHandle !!= nil) return (int) libHandle;
#endif
    
	return nil;
}

/* ioFindExternalFunctionIn:
	Find the function with the given name in the moduleHandle.
	WARNING: never primitiveFail() within, just return 0.
*/
int ioFindExternalFunctionIn(char *lookupName, int moduleHandle) {
	CFragSymbolClass ignored;
	Ptr functionPtr = 0;
	OSErr err;
    Str255 tempLookupName;
    
	if (!!moduleHandle) return 0;

	/* get the address of the desired primitive function */
	CopyCStringToPascal(lookupName,tempLookupName);
	err = FindSymbol(
		(CFragConnectionID) moduleHandle, (unsigned char *) tempLookupName,
		&functionPtr, &ignored);
	if (err) return 0;

	return (int) functionPtr;
}

/* ioFreeModule:
	Free the module with the associated handle.
	WARNING: never primitiveFail() within, just return 0.
*/
int ioFreeModule(int moduleHandle) {
	CFragConnectionID libHandle;
	OSErr err;

	if (!!moduleHandle) return 0;
	libHandle = (CFragConnectionID) moduleHandle;
	err = CloseConnection(&libHandle);
	return 0;
}

CFragConnectionID LoadLibViaPath(char *libName, char *pluginDirPath) {
	short 				vRefNum;
	long				ignore;
	CInfoPBRec 			pb;
	FSSpec				fileSpec;
	Str255				problemLibName,fileSpecName,tempPlugindirPath;
    Ptr					junk;
	CFragConnectionID	libHandle = 0;
	OSErr				err = noErr;

	/* get the default volume */
	HGetVol( nil, &vRefNum, &ignore);

	/* get the directory ID for the given path */
	CopyCStringToPascal(pluginDirPath,tempPlugindirPath);
	pb.hFileInfo.ioNamePtr = tempPlugindirPath;
	pb.hFileInfo.ioVRefNum = 0;  /* use the default volume */
	pb.hFileInfo.ioFDirIndex = 0;
	pb.hFileInfo.ioDirID = 0;
	err = PBGetCatInfoSync(&pb);
	if (err) return nil; /* bad plugin directory path */

	/* make a file spec for the given file name in the plugin directory */
	CopyCStringToPascal(libName,fileSpecName);
	FSMakeFSSpec(vRefNum,pb.hFileInfo.ioDirID,fileSpecName,&fileSpec);

	err = GetDiskFragment(
		&fileSpec, 0, kCFragGoesToEOF, nil, kLoadCFrag, &libHandle, &junk, problemLibName);
	if (err) return nil;
	return libHandle;
}
/*** I/O Primitives ***/

int ioBeep(void) {
	SysBeep(1000);
}

#ifndef PLUGIN
int ioExit(void) {
	ioShutdownAllModules();
	MenuBarRestore();
	ExitToShell();
}
#endif

int ioForceDisplayUpdate(void) {
	/* do nothing on a Mac */
}

int ioFormPrint(int bitsAddr, int width, int height, int depth, double hScale, double vScale, int landscapeFlag) {
	/* experimental: print a form with the given bitmap, width, height, and depth at
	   the given horizontal and vertical scales in the given orientation */
	printf("ioFormPrint width %d height %d depth %d hScale %f vScale %f landscapeFlag %d\n",
		width, height, depth, hScale, vScale, landscapeFlag);
	bitsAddr;
	return true;
}

int ioGetButtonState(void) {
	ioProcessEvents();  /* process all pending events */
	if ((cachedButtonState & 0x7) !!= 0) {
		int result = cachedButtonState;
		cachedButtonState = 0;  /* clear cached button state */
		return result;
	}
	cachedButtonState = 0;  /* clear cached button state */
	return buttonState;
}

int ioGetKeystroke(void) {
	int keystate;

	ioProcessEvents();  /* process all pending events */
	if (keyBufGet == keyBufPut) {
		return -1;  /* keystroke buffer is empty */
	} else {
		keystate = keyBuf[keyBufGet];
		keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE;
		/* set modifer bits in buttonState to reflect the last keystroke fetched */
		buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);
	}
	return keystate;
}

int ioHasDisplayDepth(int depth) {
	/* Return true if this platform supports the given color display depth. */

	switch (depth) {
	case 1:
	case 2:
	case 4:
	case 8:
	case 16:
	case 32:
		return true;
	}
	return false;
}


int ioMicroMSecsExpensive(void);

int ioMicroMSecsExpensive(void) {
	UnsignedWide microTicks;
	Microseconds(&microTicks);
	return (microTicks.lo / 1000) + (microTicks.hi * 4294967);
}

#if TARGET_CPU_PPC
int ioMicroMSecs(void) {
	/* Note: This function and ioMSecs() both return a time in milliseconds. The difference
	   is that ioMicroMSecs() is called only when precise millisecond resolution is essential,
	   and thus it can use a more expensive timer than ioMSecs, which is called frequently.
	   However, later VM optimizations reduced the frequency of calls to ioMSecs to the point
	   where clock performance became less critical, and we also started to want millisecond-
	   resolution timers for real time applications such as music. */
	
	register long check;
	
	if((Ptr)OTElapsedMilliseconds!!=(Ptr)kUnresolvedCFragSymbolAddress){
    	check = OTElapsedMilliseconds(&timeStart);
    	if (check !!= -1) 
    	    return check;
    	OTGetTimeStamp(&timeStart);
	    return ioMicroMSecs();
	}else {
	    return ioMicroMSecsExpensive();
	}
}
#else
int ioMicroMSecs(void) {
    return ioMicroMSecsExpensive();
}
#endif

int ioMSecs(void) {
	/* return a time in milliseconds for use in Delays and Time millisecondClockValue */
	/* Note: This was once a macro based on clock(); it now uses the microsecond clock for
	   greater resolution. See the comment in ioMicroMSecs(). */
	return ioMicroMSecs();
}

int ioMousePoint(void) {
	Point p;

	ioProcessEvents();  /* process all pending events */
	if (windowActive) {
		GetMouse(&p);
	} else {
		/* don''t report mouse motion if window is not active */
		p = savedMousePosition;
	}
	return (p.h << 16) | (p.v & 0xFFFF);  /* x is high 16 bits; y is low 16 bits */
}

int ioPeekKeystroke(void) {
	int keystate;

	ioProcessEvents();  /* process all pending events */
	if (keyBufGet == keyBufPut) {
		return -1;  /* keystroke buffer is empty */
	} else {
		keystate = keyBuf[keyBufGet];
		/* set modifer bits in buttonState to reflect the last keystroke peeked at */
		buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7);
	}
	return keystate;
}

int ioProcessEvents(void) {
	/* This is a noop when running as a plugin; the browser handles events. */
	const int nextPollOffsetCheck = CLOCKS_PER_SEC/60, nextPowerCheckOffset=CLOCKS_PER_SEC/2; 
	static clock_t nextPollTick = 0, nextPowerCheck;
	long    clockTime;

#ifndef PLUGIN
	if (clock() >= nextPollTick) {
		/* time to process events!! */
		while (HandleEvents()) {
			/* process all pending events */
		}
		
        clockTime = clock();
        
        if (gDisablePowerManager && gTapPowerManager) {
            if (clockTime > gDisableIdleTickLimit)
                gDisableIdleTickLimit = IdleUpdate() + gDisableIdleTickCount;
                
#if TARGET_CPU_PPC
            if (clockTime > nextPowerCheck) {
                 UpdateSystemActivity(UsrActivity);
                 nextPowerCheck = clockTime + nextPowerCheckOffset;
            }
#endif
        }
        
		/* wait a while before trying again */
		nextPollTick = clockTime + nextPollOffsetCheck;
	}
#endif
	return interruptPending;
}

int ioRelinquishProcessorForMicroseconds(int microSeconds) {
	/* This operation is platform dependent. On the Mac, it simply calls
	 * ioProcessEvents(), which gives other applications a chance to run.
	 */
   
    microSeconds;
	ioProcessEvents();  /* process all pending events */
}

#ifndef PLUGIN
int ioScreenSize(void) {
	int w = 10, h = 10;
    Rect portRect;
    
#ifndef IHAVENOHEAD
	if (stWindow !!= nil) {
        GetPortBounds(GetWindowPort(stWindow),&portRect);
		w =  portRect.right -  portRect.left;
		h =  portRect.bottom - portRect.top;
	}
#endif
	return (w << 16) | (h & 0xFFFF);  /* w is high 16 bits; h is low 16 bits */
}
#endif

int ioSeconds(void) {
	struct tm timeRec;
	time_t time1904, timeNow;

	/* start of ANSI epoch is midnight of Jan 1, 1904 */
	timeRec.tm_sec   = 0;
	timeRec.tm_min   = 0;
	timeRec.tm_hour  = 0;
	timeRec.tm_mday  = 1;
	timeRec.tm_mon   = 0;
	timeRec.tm_year  = 4;
	timeRec.tm_wday  = 0;
	timeRec.tm_yday  = 0;
	timeRec.tm_isdst = 0;
	time1904 = mktime(&timeRec);

	timeNow = time(NULL);

	/* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than ANSI one */
	return (timeNow - time1904) + (3 * 365 * 24 * 60 * 60);
}

int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY) {
	/* Old version; forward to new version. */
	ioSetCursorWithMask(cursorBitsIndex, nil, offsetX, offsetY);
}

int ioSetCursorWithMask(int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY) {
	/* Set the 16x16 cursor bitmap. If cursorMaskIndex is nil, then make the mask the same as
	   the cursor bitmap. If not, then mask and cursor bits combined determine how cursor is
	   displayed:
			mask	cursor	effect
			 0		  0		transparent (underlying pixel shows through)
			 1		  1		opaque black
			 1		  0		opaque white
			 0		  1		invert the underlying pixel
	*/
	Cursor macCursor;
	int i;

	if (cursorMaskIndex == nil) {
		for (i = 0; i < 16; i++) {
			macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
			macCursor.mask[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
		}
	} else {
		for (i = 0; i < 16; i++) {
			macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF;
			macCursor.mask[i] = (checkedLongAt(cursorMaskIndex + (4 * i)) >> 16) & 0xFFFF;
		}
	}

	/* Squeak hotspot offsets are negative; Mac''s are positive */
	macCursor.hotSpot.h = -offsetX;
	macCursor.hotSpot.v = -offsetY;
	SetCursor(&macCursor);
}

int ioSetDisplayMode(int width, int height, int depth, int fullscreenFlag) {
	/* Set the window to the given width, height, and color depth. Put the window
	   into the full screen mode specified by fullscreenFlag. */
	/* Note: Changing display depth is not yet, and may never be, implemented
	   on the Macintosh, where (a) it is considered inappropriate and (b) it may
	   not even be a well-defined operation if the Squeak window spans several
	   displays (which display''s depth should be changed?). */

	depth;
#ifndef IHAVENOHEAD
	ioSetFullScreen(fullscreenFlag);
	if (!!fullscreenFlag) {
		SizeWindow(stWindow, width, height, true);
	}
#endif
}

#ifndef PLUGIN
int ioSetFullScreen(int fullScreen) {
	Rect screen,portRect;
	BitMap bmap;
	int width, height, maxWidth, maxHeight;
	int oldWidth, oldHeight;
			
	GetQDGlobalsScreenBits(&bmap);
    screen = bmap.bounds;
    
	if (fullScreen) {
		MenuBarHide();
		GetPortBounds(GetWindowPort(stWindow),&portRect);
		oldWidth =  portRect.right -  portRect.left;
		oldHeight =  portRect.bottom -  portRect.top;
		width  = screen.right - screen.left; 
		height = (screen.bottom - screen.top);
		if ((oldWidth < width) || (oldHeight < height)) {
			/* save old size if it wasn''t already full-screen */ 
			savedWindowSize = (oldWidth << 16) + (oldHeight & 0xFFFF);
		}
		MoveWindow(stWindow, 0, 0, true);
		SizeWindow(stWindow, width, height, true);
		fullScreenFlag = true;
	} else {
		MenuBarRestore();

		/* get old window size */
		width  = (unsigned) savedWindowSize >> 16;
		height = savedWindowSize & 0xFFFF;

		/* minimum size is 64 x 64 */
		width  = (width  > 64) ?  width : 64;
		height = (height > 64) ? height : 64;

		/* maximum size is screen size inset slightly */
		maxWidth  = (screen.right  - screen.left) - 16;
		maxHeight = (screen.bottom - screen.top)  - 52;
		width  = (width  <= maxWidth)  ?  width : maxWidth;
		height = (height <= maxHeight) ? height : maxHeight;
		MoveWindow(stWindow, 8, 44, true);
		SizeWindow(stWindow, width, height, true);
		fullScreenFlag = false;
	}
}
#endif


int ioShowDisplay(
	int dispBitsIndex, int width, int height, int depth,
	int affectedL, int affectedR, int affectedT, int affectedB) {

	Rect		dstRect = { 0, 0, 0, 0 };
	Rect		srcRect = { 0, 0, 0, 0 };
	RgnHandle	maskRect = nil;

	if (stWindow == nil) {
		return;
	}

	dstRect.left	= 0;
	dstRect.top		= 0;
	dstRect.right	= width;
	dstRect.bottom	= height;

	srcRect.left	= 0;
	srcRect.top		= 0;
	srcRect.right	= width;
	srcRect.bottom	= height;

	(*stPixMap)->baseAddr = (void *) dispBitsIndex;
	/* Note: top three bits of rowBytes indicate this is a PixMap, not a BitMap */
	(*stPixMap)->rowBytes = (((((width * depth) + 31) / 32) * 4) & 0x1FFF) | 0x8000;
	(*stPixMap)->bounds = srcRect;
	(*stPixMap)->pixelSize = depth;

    if (depth<=8) { /*Duane Maxwell <dmaxwell@exobox.com> fix cmpSize Sept 18,2000 */
    	(*stPixMap)->cmpSize = depth;
    	(*stPixMap)->cmpCount = 1;
    } else if (depth==16) {
    	(*stPixMap)->cmpSize = 5;
    	(*stPixMap)->cmpCount = 3;
    } else if (depth==32) {
    	(*stPixMap)->cmpSize = 8;
    	(*stPixMap)->cmpCount = 3;
    }

	/* create a mask region so that only the affected rectangle is copied */
	maskRect = NewRgn();
	SetRectRgn(maskRect, affectedL, affectedT, affectedR, affectedB);

	SetPortWindowPort(stWindow);
	CopyBits((BitMap *) *stPixMap, GetPortBitMapForCopyBits(GetWindowPort(stWindow)), &srcRect, &dstRect, srcCopy, maskRect);
#if TARGET_API_MAC_CARBON
	QDFlushPortBuffer (GetWindowPort(stWindow), maskRect);
#endif
	DisposeRgn(maskRect);
}


/*** Image File Naming ***/

void StoreFullPathForLocalNameInto(char *shortName, char *fullName, int length, short volumeNumber,long directoryID) {
	int offset, sz, i;

	offset = PathToWorkingDir(fullName, length, volumeNumber, directoryID);

	/* copy the file name into a null-terminated C string */
	sz = strlen(shortName);
	for (i = 0; i <= sz; i++) {
		/* append shortName to fullName, including terminator */
		fullName[i + offset] = shortName[i];
	}
}

int imageNameSize(void) {
	return strlen(imageName);
}

int imageNameGetLength(int sqImageNameIndex, int length) {
	char *sqImageName = (char *) sqImageNameIndex;
	int count, i;

	count = strlen(imageName);
	count = (length < count) ? length : count;

	/* copy the file name into the Squeak string */
	for (i = 0; i < count; i++) {
		sqImageName[i] = imageName[i];
	}
	return count;
}

int imageNamePutLength(int sqImageNameIndex, int length) {
	char *sqImageName = (char *) sqImageNameIndex;
	int count, i, ch, j;
	int lastColonIndex = -1;

	count = (IMAGE_NAME_SIZE < length) ? IMAGE_NAME_SIZE : length;

	/* copy the file name into a null-terminated C string */
	for (i = 0; i < count; i++) {
		ch = imageName[i] = sqImageName[i];
		if (ch == '':'') {
			lastColonIndex = i;
		}
	}
	imageName[count] = 0;

	/* copy short image name into a null-terminated C string */
	for (i = lastColonIndex + 1, j = 0; i < count; i++, j++) {
		shortImageName[j] = imageName[i];
	}
	shortImageName[j] = 0;

	SetWindowTitle(shortImageName);
	return count;
}

/*****************************************************************************************
GetApplicationDirectory

Get the volume reference number and directory id of this application.
Code taken from Apple:
	Technical Q&As: FL 14 - Finding your application''s directory (19-June-2000)

Karl Goiser 14/01/01
*****************************************************************************************/

        /* GetApplicationDirectory returns the volume reference number
        and directory ID for the current application''s directory. */

    OSStatus GetApplicationDirectory(short *vRefNum, long *dirID) {
        ProcessSerialNumber PSN;
        ProcessInfoRec pinfo;
        FSSpec pspec;
        OSStatus err;
            /* valid parameters */
        if (vRefNum == NULL || dirID == NULL) return paramErr;
            /* set up process serial number */
        PSN.highLongOfPSN = 0;
        PSN.lowLongOfPSN = kCurrentProcess;
            /* set up info block */
        pinfo.processInfoLength = sizeof(pinfo);
        pinfo.processName = NULL;
        pinfo.processAppSpec = &pspec;
            /* grab the vrefnum and directory */
        err = GetProcessInformation(&PSN, &pinfo);
        if (err == noErr) {
            *vRefNum = pspec.vRefNum;
            *dirID = pspec.parID;
        }
        return err;
    }


/*** Initializing the path to Working Dir ***/

int PathToWorkingDir(char *pathName, int pathNameMax, short volumeNumber,long directoryID) {
	/* Fill in the given string with the full path from a root volume to
	   to current working directory. (At startup time, the working directory
	   is set to the application''s directory. Fails if the given string is not
	   long enough to hold the entire path. (Use at least 1000 characters to
	   be safe.)
	*/

	short	fullPathLength;
	Handle	fullPathHandle;

	if (GetFullPath(volumeNumber, directoryID, nil, &fullPathLength, &fullPathHandle) !!= noErr) {
		//Some sort of random guff for failure:
		pathName[0] = 1;
		pathName[1] = (char)":";
		return 1;
	}

	strncpy((char *) pathName, (char *) *fullPathHandle, fullPathLength);
	DisposeHandle(fullPathHandle);
	return fullPathLength;
}

pascal	OSErr	GetFullPath(short vRefNum,
							long dirID,
							ConstStr255Param name,
							short *fullPathLength,
							Handle *fullPath)
{
	OSErr		result;
	FSSpec		spec;
	
	*fullPathLength = 0;
	*fullPath = NULL;
	
	result = FSMakeFSSpecCompat(vRefNum, dirID, name, &spec);
	if ( (result == noErr) || (result == fnfErr) )
	{
		result = FSpGetFullPath(&spec, fullPathLength, fullPath);
	}
	
	return ( result );
}

pascal	OSErr	FSpGetFullPath(const FSSpec *spec,
							   short *fullPathLength,
							   Handle *fullPath)
{
	OSErr		result;
	OSErr		realResult;
	FSSpec		tempSpec;
	CInfoPBRec	pb;
	
	*fullPathLength = 0;
	*fullPath = NULL;
	
	
	/* Default to noErr */
	realResult = result = noErr;
	
#if 0
//The following code doesn''t seem to work in OS X, the BloackMoveData crashes the
// machine, the the FSMakeFSSpecCompat works, so go figure...  KG 4/1/01

	/* work around Nav Services "bug" (it returns invalid FSSpecs with empty names) */
	if ( spec->name[0] == 0 )
	{
		result = FSMakeFSSpecCompat(spec->vRefNum, spec->parID, spec->name, &tempSpec);
	}
	else
	{
		/* Make a copy of the input FSSpec that can be modified */
		BlockMoveData(spec, &tempSpec, sizeof(FSSpec));
	}
#endif 0

	result = FSMakeFSSpecCompat(spec->vRefNum, spec->parID, spec->name, &tempSpec);


	if ( result == noErr )
	{
		if ( tempSpec.parID == fsRtParID )
		{
			/* The object is a volume */
			
			/* Add a colon to make it a full pathname */
			++tempSpec.name[0];
			tempSpec.name[tempSpec.name[0]] = '':'';
			
			/* We''re done */
			result = PtrToHand(&tempSpec.name[1], fullPath, tempSpec.name[0]);
			*fullPathLength = tempSpec.name[0];
		}
		else
		{
			/* The object isn''t a volume */
			
			/* Is the object a file or a directory? */
			pb.dirInfo.ioNamePtr = tempSpec.name;
			pb.dirInfo.ioVRefNum = tempSpec.vRefNum;
			pb.dirInfo.ioDrDirID = tempSpec.parID;
			pb.dirInfo.ioFDirIndex = 0;
			result = PBGetCatInfoSync(&pb);
			// Allow file/directory name at end of path to not exist.
			realResult = result;
			if ( (result == noErr) || (result == fnfErr) )
			{
				/* if the object is a directory, append a colon so full pathname ends with colon */
				if ( (result == noErr) && (pb.hFileInfo.ioFlAttrib & kioFlAttribDirMask) !!= 0 )
				{
					++tempSpec.name[0];
					tempSpec.name[tempSpec.name[0]] = '':'';
				}
				
				/* Put the object name in first */
				result = PtrToHand(&tempSpec.name[1], fullPath, tempSpec.name[0]);
				*fullPathLength = tempSpec.name[0];
				if ( result == noErr )
				{
					/* Get the ancestor directory names */
					pb.dirInfo.ioNamePtr = tempSpec.name;
					pb.dirInfo.ioVRefNum = tempSpec.vRefNum;
					pb.dirInfo.ioDrParID = tempSpec.parID;
					do	/* loop until we have an error or find the root directory */
					{
						pb.dirInfo.ioFDirIndex = -1;
						pb.dirInfo.ioDrDirID = pb.dirInfo.ioDrParID;
						result = PBGetCatInfoSync(&pb);
						if ( result == noErr )
						{
							/* Append colon to directory name */
							++tempSpec.name[0];
							tempSpec.name[tempSpec.name[0]] = '':'';
							
							/* Add directory name to beginning of fullPath */
							(void) Munger(*fullPath, 0, NULL, 0, &tempSpec.name[1], tempSpec.name[0]);
							*fullPathLength += tempSpec.name[0];
							result = MemError();
						}
					} while ( (result == noErr) && (pb.dirInfo.ioDrDirID !!= fsRtDirID) );
				}
			}
		}
	}
	
	if ( result == noErr )
	{
		/* Return the length */
///		*fullPathLength = GetHandleSize(*fullPath);
		result = realResult;	// return realResult in case it was fnfErr
	}
	else
	{
		/* Dispose of the handle and return NULL and zero length */
		if ( *fullPath !!= NULL )
		{
			DisposeHandle(*fullPath);
		}
		*fullPath = NULL;
		*fullPathLength = 0;
	}
	
	return ( result );
}

/*****************************************************************************/

pascal OSErr FSpLocationFromFullPath(short fullPathLength,
									 const void *fullPath,
									 FSSpec *spec)
{
	AliasHandle	alias;
	OSErr		result;
	Boolean		wasChanged;
	Str32		nullString;
	
	/* Create a minimal alias from the full pathname */
	nullString[0] = 0;	/* null string to indicate no zone or server name */
	result = NewAliasMinimalFromFullPath(fullPathLength, fullPath, nullString, nullString, &alias);
	if ( result == noErr )
	{
		/* Let the Alias Manager resolve the alias. */
		result = ResolveAlias(NULL, alias, spec, &wasChanged);
		
		/* work around Alias Mgr sloppy volume matching bug */
		if ( spec->vRefNum == 0 )
		{
			/* invalidate wrong FSSpec */
			spec->parID = 0;
			spec->name[0] =  0;
			result = nsvErr;
		}
		DisposeHandle((Handle)alias);	/* Free up memory used */
	}
	return ( result );
}
/*****************************************************************************/

/*
**	File Manager FSp calls
*/

/*****************************************************************************/

pascal	OSErr	FSMakeFSSpecCompat(short vRefNum,
								   long dirID,
								   ConstStr255Param fileName,
								   FSSpec *spec)
{
	OSErr	result;
	
	/* Let the file system create the FSSpec if it can since it does the job */
	/* much more efficiently than I can. */
	result = FSMakeFSSpec(vRefNum, dirID, fileName, spec);

	/* Fix a bug in Macintosh PC Exchange''s MakeFSSpec code where 0 is */
	/* returned in the parID field when making an FSSpec to the volume''s */
	/* root directory by passing a full pathname in MakeFSSpec''s */
	/* fileName parameter. Fixed in Mac OS 8.1 */
	if ( (result == noErr) && (spec->parID == 0) )
		spec->parID = fsRtParID;
	return ( result );
}

int PrefixPathWith(char *pathName, int pathNameSize, int pathNameMax, char *prefix) {
	/* Insert the given prefix C string plus a delimitor character at the
	   beginning of the given C string. Return the new pathName size. Fails
	   if pathName is does not have sufficient space for the result.
	   Assume: pathName is null terminated.
	*/

	int offset, i;

	offset = strlen(prefix) + 1;
	if ((pathNameSize + offset) > pathNameMax) {
		return pathNameSize;
	}

	for (i = pathNameSize; i >= 0; i--) {
		/* make room in pathName for prefix (moving string terminator, too) */
		pathName[i + offset] = pathName[i];
	}
	for (i = 0; i < offset; i++) {
		/* make room in pathName for prefix */
		pathName[i] = prefix[i];
	}
	pathName[offset - 1] = '':'';  /* insert delimitor */
	return pathNameSize + offset;
}


/*** Profiling ***/

int clearProfile(void) {
#ifdef MAKE_PROFILE
	ProfilerClear();
#endif
}

int dumpProfile(void) {
#ifdef MAKE_PROFILE
	ProfilerDump("\pProfile.out");
#endif
}

int startProfiling(void) {
#ifdef MAKE_PROFILE
	ProfilerSetStatus(true);
#endif
}

int stopProfiling(void) {
#ifdef MAKE_PROFILE
	ProfilerSetStatus(false);
#endif
}

/*** Plugin Support ***/

int plugInInit(char *fullImagePath) {

	fullImagePath;
	/* check the interpreter''s size assumptions for basic data types */
	if (sizeof(int) !!= 4) {
		error("This C compiler''s integers are not 32 bits.");
	}
	if (sizeof(double) !!= 8) {
		error("This C compiler''s floats are not 64 bits.");
	}
	if (sizeof(time_t) !!= 4) {
		error("This C compiler''s time_t''s are not 32 bits.");
	}

	/* clear all path and file names */
	imageName[0] = shortImageName[0] = documentName[0] = vmPath[0] = 0;

#if TARGET_CPU_PPC
	if((Ptr)OTGetTimeStamp!!=(Ptr)kUnresolvedCFragSymbolAddress)
 	    OTGetTimeStamp(&timeStart);
#endif

	PowerMgrCheck();
	SetUpClipboard();
	SetUpPixmap();
	dropInit();
}

int plugInShutdown(void) {
	ioShutdownAllModules();
	FreeClipboard();
	FreePixmap();
	if (memory !!= nil) {
		DisposePtr((void *) memory);
		memory = nil;
	}
}

#ifndef PLUGIN
int plugInAllowAccessToFilePath(char *pathString, int pathStringLength) {
  /* Grant permission to all files. */
	pathString; pathStringLength;
	return true;
}
#endif

/*** System Attributes ***/

int IsImageName(char *name) {
	char *suffix;

	suffix = strrchr(name, ''.'');  /* pointer to last period in name */
	if (suffix == NULL) return false;
	if (strcmp(suffix, ".ima") == 0) return true;
	if (strcmp(suffix, ".image") == 0) return true;
	if (strcmp(suffix, ".IMA") == 0) return true;
	if (strcmp(suffix, ".IMAGE") == 0) return true;
	return false;
}

char * GetAttributeString(int id) {
	/* This is a hook for getting various status strings back from
	   the OS. In particular, it allows Squeak to be passed arguments
	   such as the name of a file to be processed. Command line options
	   are reported this way as well, on platforms that support them.
	*/

	// id #0 should return the full name of VM; for now it just returns its path
	if (id == 0) return vmPath;
	/* Note: 1.3x images will try to read the image as a document because they
	   expect attribute #1 to be the document name. A 1.3x image can be patched
	   using a VM of 2.6 or earlier. */
	if (id == 1) return imageName;
	if (id == 2) return documentName;

#ifdef PLUGIN
	/* When running in browser, return the EMBED tag info */
	if ((id > 2) && (id <= (2 + (2 * pluginArgCount)))) {
		int i = id - 3;
		if ((i & 1) == 0) {  /* i is even */
			return pluginArgName[i/2];
		} else {
			return pluginArgValue[i/2];
		}
	}
#endif

	if (id == 1001) return "Mac OS";
	if (id == 1002) return "System 7 or Later";
	if (id == 1003) return "PowerPC or 68K";

	/* attribute undefined by this platform */
	success(false);
	return "";
}

int attributeSize(int id) {
	return strlen(GetAttributeString(id));
}

int getAttributeIntoLength(int id, int byteArrayIndex, int length) {
	char *srcPtr, *dstPtr, *end;
	int charsToMove;

	srcPtr = GetAttributeString(id);
	charsToMove = strlen(srcPtr);
	if (charsToMove > length) {
		charsToMove = length;
	}

	dstPtr = (char *) byteArrayIndex;
	end = srcPtr + charsToMove;
	while (srcPtr < end) {
		*dstPtr++ = *srcPtr++;
	}
	return charsToMove;
}

/*** Image File Operations ***/

void sqImageFileClose(sqImageFile f) {
	FSClose(f);
}

sqImageFile sqImageFileOpen(char *fileName, char *mode) {
	short int err, err2, fRefNum;
	Str255 tempPascalFileName; 
    FInfo fileInfo;

	CopyCStringToPascal(fileName,tempPascalFileName);
	if (strchr(mode, ''w'') !!= null) 
	    err = HOpenDF(0,0,tempPascalFileName,fsRdWrPerm, &fRefNum);
	 else
	    err = HOpenDF(0,0,tempPascalFileName,fsRdPerm, &fRefNum);
	    
	if ((err !!= 0) && (strchr(mode, ''w'') !!= null)) {
		/* creating a new file for "save as" */
		err2 = HCreate(0,0,tempPascalFileName,  ''FAST'', ''STim'');
		if (err2 == 0) {
			err = HOpenDF(0,0,tempPascalFileName,fsRdWrPerm, &fRefNum);
		}
	}

	if (err !!= 0) return null;

	if (strchr(mode, ''w'') !!= null) {
        err = HGetFInfo(0,0,tempPascalFileName,&fileInfo);
        if (err !!= noErr) return 0; //This should not happen
        
        //On the mac we start at location 0 if this isn''t an VM
        
    	if (!!(fileInfo.fdType == ''APPL'' && fileInfo.fdCreator == ''FAST'')){
    		/* truncate non-VM file if opening in write mode */
    		err = SetEOF(fRefNum, 0);
    		if (err !!= 0) {
    			FSClose(fRefNum);
    			return null;
    		}
	    }
	}
	return (sqImageFile) fRefNum;
}

int sqImageFilePosition(sqImageFile f) {
	long int currentPosition = 0;

	GetFPos(f, &currentPosition);
	return currentPosition;
}

int sqImageFileRead(void *ptr, int elementSize, int count, sqImageFile f) {
	long int byteCount = elementSize * count;
	short int err;

	err = FSRead(f, &byteCount, ptr);
	if (err !!= 0) return 0;
	return byteCount / elementSize;
}

void sqImageFileSeek(sqImageFile f, int pos) {
	SetFPos(f, fsFromStart, pos);
}

int sqImageFileWrite(void *ptr, int elementSize, int count, sqImageFile f) {
	long int byteCount = elementSize * count;
	short int err;

	err = FSWrite(f, &byteCount, ptr);
	if (err !!= 0) return 0;
	return byteCount / elementSize;
}

int calculateStartLocationForImage() { 

	Handle cfrgResource;  
	long	memberCount,i;
	CFragResourceMember *target;
	Str255 tempPascalFileName;
	OSErr   err;
    int     resFileRef;
	
	cfrgResource = GetResource(kCFragResourceType,0); 
	if (cfrgResource == nil || ResError() !!= noErr) { return 0;};  
	
	memberCount = ((CFragResource *)(*cfrgResource))->memberCount;
	if (memberCount <= 1) {
        ReleaseResource(cfrgResource);
	    return 0; //Need FAT to get counters right
	}
	
	target = &((CFragResource *)(*cfrgResource))->firstMember;
	for(i=0;i<memberCount;i++) {
		if (target->architecture == ''FAST'') {			
		    ReleaseResource(cfrgResource);
		    return target->offset;
		}
		target = NextCFragResourceMemberPtr(target); 
	}
    ReleaseResource(cfrgResource);
	return 0;
}

int sqImageFileStartLocation(int fileRef, char *filename, int imageSize){
    FInfo fileInfo;
	Str255 tempPascalFileName;
	OSErr   err; 
    int     resFileRef;
	Handle  cfrgResource,newcfrgResource;  
	UInt32	maxOffset=0,maxOffsetLength,targetOffset;
	long    memberCount,i;
	CFragResourceMember *target;
  
    
	CopyCStringToPascal(filename,tempPascalFileName);
    err = HGetFInfo(0,0,tempPascalFileName,&fileInfo);
    if (err !!= noErr) return 0; //This should not happen
    
    //On the mac we start at location 0 if this isn''t an VM
    
	if (!!(fileInfo.fdType == ''APPL'' && fileInfo.fdCreator == ''FAST'')) return 0;
    
    //Ok we have an application file, open the resource part and attempt to find the crfg
    
    resFileRef = HOpenResFile(0,0,tempPascalFileName,fsWrPerm);
    if (resFileRef == -1) return 0;
    
	cfrgResource = GetResource(kCFragResourceType,0);
	if (cfrgResource == nil || ResError() !!= noErr) {CloseResFile(resFileRef); return 0;};  
	
	memberCount = ((CFragResource *)(*cfrgResource))->memberCount;
	if (memberCount <= 1) {ReleaseResource(cfrgResource); CloseResFile(resFileRef); return 0;};  //Need FAT to get counters right
	
	target = &((CFragResource *)(*cfrgResource))->firstMember;
	for(i=0;i<memberCount;i++) {
		if (target->architecture == ''FAST'') {
		    targetOffset = target->offset;
		    target->length = imageSize;
		    ChangedResource(cfrgResource);
        	if (ResError() !!= noErr) {ReleaseResource(cfrgResource); CloseResFile(resFileRef); return 0;}; 
		    UpdateResFile(resFileRef);
        	if (ResError() !!= noErr) {ReleaseResource(cfrgResource); CloseResFile(resFileRef); return 0;}; 
            ReleaseResource(cfrgResource); 
		    CloseResFile(resFileRef);
			return targetOffset;
		}
		if (target->offset > maxOffset) {
			maxOffset = target->offset;
			maxOffsetLength = target->length;
		}
		target = NextCFragResourceMemberPtr(target);
	}
	
	//Ok at this point we need to alter the crfg to add the new tag for the image part
	
	newcfrgResource = cfrgResource;
	err = HandToHand(&newcfrgResource);
	if (err !!= noErr || MemError() !!= noErr)  {ReleaseResource(cfrgResource); CloseResFile(resFileRef); return 0;}; 
	SetHandleSize(newcfrgResource,GetHandleSize(cfrgResource)+AlignToFour(kBaseCFragResourceMemberSize + 1));
	if (MemError() !!= noErr)  {ReleaseResource(cfrgResource); CloseResFile(resFileRef); return 0;}; 
	
	target = &((CFragResource *)(*newcfrgResource))->firstMember; 
	for(i=0;i<memberCount;i++) {
		target = NextCFragResourceMemberPtr(target); 
	}

    target->architecture = ''FAST'';
    target->reservedA = 0;                  /* !! Must be zero!!*/
    target->reservedB = 0;                  /* !! Must be zero!!*/
    target->updateLevel = 0;
    target->currentVersion = 0;
    target->oldDefVersion = 0;
    target->uUsage1.appStackSize = 0;
    target->uUsage2.appSubdirID = 0;
    target->uUsage2.libFlags = 0;
    target->usage = kApplicationCFrag;
    target->where = kDataForkCFragLocator;
    target->offset = maxOffset + maxOffsetLength;
    targetOffset = target->offset;
    target->length = imageSize;
    target->uWhere1.spaceID = 0;
    target->extensionCount = 0;             /* The number of extensions beyond the name.*/
    target->memberSize = AlignToFour(kBaseCFragResourceMemberSize + 1);   /* Size in bytes, includes all extensions.*/
    target->name[0] = 0x00;

	((CFragResource *)(*newcfrgResource))->memberCount = memberCount+1;
	RemoveResource(cfrgResource);
	if (ResError() !!= noErr) {CloseResFile(resFileRef); return 0;}; 
 	AddResource(newcfrgResource,kCFragResourceType,0,nil);
	if (ResError() !!= noErr) {CloseResFile(resFileRef); return 0;}; 
    UpdateResFile(resFileRef);
	if (ResError() !!= noErr) {CloseResFile(resFileRef); return 0;}; 
    CloseResFile(resFileRef);
    
	return targetOffset;
}

#ifndef PLUGIN
void * sqAllocateMemory(int minHeapSize, int desiredHeapSize) {
	/* Application allocates Squeak object heap memory from its own heap. */	
	minHeapSize;
	return NewPtr(desiredHeapSize);;
}
#endif

void PowerMgrCheck(void) {
	long pmgrAttributes;
	
	gTapPowerManager = false;
	gDisablePowerManager = false;
	if (!! Gestalt(gestaltPowerMgrAttr, &pmgrAttributes))
		if ((pmgrAttributes & (1<<gestaltPMgrExists)) 
		    && (pmgrAttributes & (1<<gestaltPMgrDispatchExists))
		    && (PMSelectorCount() >= 0x24)) {
		    gTapPowerManager = true;
			gDisableIdleTickLimit = clock();
		}
}

int ioDisablePowerManager(int disableIfNonZero) {
    gDisablePowerManager = disableIfNonZero;
}

Boolean RunningOnCarbonX(void)
{
    UInt32 response;
    
    return (Gestalt(gestaltSystemVersion, 
                    (SInt32 *) &response) == noErr)
                && (response >= 0x01000);
}

/*** Main ***/

#ifndef PLUGIN
void main(void) {
	EventRecord theEvent;
	sqImageFile f;
	int reservedMemory, availableMemory;

	short vRefNum;
	long dirID;
	OSErr err;

	InitMacintosh();
	PowerMgrCheck();
	
	SetUpMenus();
	SetUpClipboard();
	SetUpWindow();
	SetUpPixmap();
	dropInit();
	SetEventMask(everyEvent); // also get key up events
	
#if TARGET_CPU_PPC
	if((Ptr)OTGetTimeStamp!!=(Ptr)kUnresolvedCFragSymbolAddress)
 	    OTGetTimeStamp(&timeStart);
#endif 

	/* install apple event handlers and wait for open event */
	imageName[0] = shortImageName[0] = documentName[0] = vmPath[0] = 0;
	InstallAppleEventHandlers();
	while (shortImageName[0] == 0) {
		GetNextEvent(everyEvent, &theEvent);
		if (theEvent.what == kHighLevelEvent) {
			AEProcessAppleEvent(&theEvent);
		}
	}
	if (imageName[0] == 0) {
		err = GetApplicationDirectory(&vRefNum, &dirID);
		if (err !!= noErr) error("Could not obtain default directory");
		StoreFullPathForLocalNameInto(shortImageName, imageName, IMAGE_NAME_SIZE, vRefNum, dirID);
	}

	/* check the interpreter''s size assumptions for basic data types */
	if (sizeof(int) !!= 4) {
		error("This C compiler''s integers are not 32 bits.");
	}
	if (sizeof(double) !!= 8) {
		error("This C compiler''s floats are not 64 bits.");
	}
	if (sizeof(time_t) !!= 4) {
		error("This C compiler''s time_t''s are not 32 bits.");
	}

#ifdef MAKE_PROFILE
	ProfilerInit(collectDetailed, bestTimeBase, 1000, 50);
	ProfilerSetStatus(false);
	ProfilerClear();
#endif

	/* compute the desired memory allocation */
	reservedMemory = 500000;
	if (RunningOnCarbonX())
	    availableMemory = 100*1024*1024 - reservedMemory;
	else 
    	availableMemory = MaxBlock() - reservedMemory;
	
	/******
	  Note: This is platform-specific. On the Mac, the user specifies the desired
	    memory partition for each application using the Finder''s Get Info command.
	    MaxBlock() returns the amount of memory in the partition minus space for
	    the code segment and other resources. On other platforms, the desired heap
	    size would be specified in other ways (e.g, via a command line argument).
	    The maximum size of the object heap is fixed at at startup. If you run low
	    on space, you must save the image and restart with more memory.

	  Note: Some memory must be reserved for Mac toolbox calls, sound buffers, etc.
	    A 30K reserve is too little. 40K allows Squeal to run but crashes if the
	    console is opened. 50K allows the console to be opened (with and w/o the
	    profiler). I added another 30K to provide for sound buffers and reliability.
	    (Note: Later discovered that sound output failed if SoundManager was not
	    preloaded unless there is about 100K reserved. Added 50K to that.)
	    
	    JMM Note changed to 500 for Open Transport support on 68K machines
	******/

	/* uncomment the following when using the C transcript window for debugging: */
	//printf("Move this window, then hit CR\n"); getchar();

	/* read the image file and allocate memory for Squeak heap */
	f = sqImageFileOpen(imageName, "rb");
	if (f == NULL) {
		/* give a Mac-specific error message if image file is not found */
		printf("Could not open the Squeak image file ''%s''\n\n", imageName);
		printf("There are several ways to open a Squeak image file. You can:\n");
		printf("  1. Double-click on the desired image file.\n");
		printf("  2. Drop the image file icon onto the Squeak application or an alias to it.\n");
		printf("  3. Name your image ''squeak.image'' and put it in the same folder as the\n");
		printf("     Squeak application, then double-click on the Squeak application.\n\n");
		printf("Press the return key to exit.\n");
		getchar();
		printf("Aborting...\n");
		ioExit();
	}
	readImageFromFileHeapSizeStartingAt(f, availableMemory, calculateStartLocationForImage());
	sqImageFileClose(f);

#ifndef IHAVENOHEAD
	SetWindowTitle(shortImageName);
	ioSetFullScreen(fullScreenFlag);
#endif
	/* run Squeak */
	interpret();
}
#endif

void SqueakTerminate() {
#ifdef PLUGIN
	ExitCleanup();
#else
	ioShutdownAllModules();
#endif
}

WindowPtr getSTWindow(void) {
    return stWindow;
}

int setMessageHook(eventMessageHook theHook) {
    messageHook = theHook;
}

int setPostMessageHook(eventMessageHook theHook) {
    postMessageHook = theHook;
}

#if !!TARGET_API_MAC_CARBON
//
//	CopyPascalStringToC converts the source pascal string to a destination
//	C string as it copies. 
//
void CopyPascalStringToC(ConstStr255Param src, char* dst)
{
	if ( src !!= NULL )
	{
		short   length  = *src++;
	
		while ( length > 0 ) 
		{
			*dst++ = *(char*)src++;
			--length;
		}
	}
	*dst = ''\0'';
}


//
//	CopyCStringToPascal converts the source C string to a destination
//	pascal string as it copies. The dest string will
//	be truncated to fit into an Str255 if necessary.
//  If the C String pointer is NULL, the pascal string''s length is set to zero
//
void CopyCStringToPascal(const char* src, Str255 dst)
{
	short 	length  = 0;
	
	// handle case of overlapping strings
	if ( (void*)src == (void*)dst )
	{
		unsigned char*		curdst = &dst[1];
		unsigned char		thisChar;
				
		thisChar = *(const unsigned char*)src++;
		while ( thisChar !!= ''\0'' ) 
		{
			unsigned char	nextChar;
			
			// use nextChar so we don''t overwrite what we are about to read
			nextChar = *(const unsigned char*)src++;
			*curdst++ = thisChar;
			thisChar = nextChar;
			
			if ( ++length >= 255 )
				break;
		}
	}
	else if ( src !!= NULL )
	{
		unsigned char*		curdst = &dst[1];
		short 				overflow = 255;		// count down so test it loop is faster
		register char		temp;
	
		// Can''t do the K&R C thing of Òwhile (*s++ = *t++)Ó because it will copy trailing zero
		// which might overrun pascal buffer.  Instead we use a temp variable.
		while ( (temp = *src++) !!= 0 ) 
		{
			*(char*)curdst++ = temp;
				
			if ( --overflow <= 0 )
				break;
		}
		length = 255 - overflow;
	}
	dst[0] = length;
}
#endif

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 12/1/2000 22:44'!
readmeFile

	^ 'Building the Squeak Virtual Machine

The Macintosh virtual machine is built using the following source files:

	sq.h				-- shared definitions included in all .c files
	sqConfig.h			-- platform configuration settings
	sqMachDep.h		-- machine dependent macros to support threaded code
	sqPlatformSpecific.h -- platform specific macros and definitions
	sqVirtualMachine.h	-- support for dynamic primitives
	sqADPCMPrims.c		-- ADCPM sound compression primitives
	sqFilePrims.c		-- file primitives
	sqMacAsyncFilePrims.c -- Mac asynchronous file I/O
	sqMacDirectory.c	-- Mac directory enumerations
	sqMacJoystickAndTablet.c -- Mac support for Wacom tablets and Gravis
MouseStickII joystick
	sqMacNetwork.c		-- Mac networking primitives
	sqMacSerialAndMIDIPort.c -- Mac serial and MIDI port primitives
	sqMacSound.c		-- Mac audio output primitives
	sqMacWindow.c		-- Mac window and event handling; main program
	sqMiscPrims.c		-- miscellaneous automatically generated primitives
	sqNamedPrims.c		-- support for named primitives
	sqSoundPrims.c		-- automatically generated sound synthesis primitives
	sqOldSoundPrims.c	-- old versions of sound primitives for backward
compatibility
	sqVirtualMachine.c	-- support for dynamic primitives
	interp.c				-- automatically generated code for the virtual
machine

In addition to these files, a number of .h and .c files are generated when Squeak
generates a new interpreter. The exact set of files depends on which sets of
primitives are included. In general, all the files created by this process should
be visible to the CW project and all the generated .c files should be added to
the CW project. Don''t worry--the linker will tell you if you forget something.

The platform specific files are sqMacXXX.c, totaling about 2000 lines of code
when this document was originally written. All other code is written to standard
ANSI libraries and should port easily to other C environments.

The file sqMacMinimal.c can be used a porting guide. This ~1100 line file stubs
out all non-essential support functions and, together with sqFilePrims.c, allows
one to build a functioning virtual machine that only lacks non-essential I/O
functions (including support for file directory enumeration, which is not really
essential!!). The small size of this file demonstrates how little code is really
needed to get Squeak running on a new platform.

Thanks to Ian Piumarta, the C header files are identical across all the major
Squeak platforms.

The code assumes that C ints and pointers are 4 bytes and double floats are 8
bytes; these assumptions are checked at start up time. Float objects in the image
are stored in the IEEE standard byte ordering for double-precision floats on all
platforms; macros in sq.h can be defined to swap bytes into and out of the
platform native float format if necessary. (To ensure proper word alignment, one
typically has to copy a Squeak Float object into a C "double" variable before
operating on it; byte swapping can be done while doing this copy for little or no
additional cost.)

The files interp.c, sqSoundPrims.c, and sqMiscPrims.c are generated
automatically, so changes to these files will be lost when they are next
generated. It is fine to make ephemeral changes to these file for the purpose of
debugging or statistics gathering. To generate the interpreter, see the
"translation" category in Interpreter class. To generate sqSoundPrims.c, see the
class method "cCodeForSoundPrimitives" in AbstractSound.

The current VM was compiled with Metrowerks CodeWarrior 11. Earlier, I used
Semantec Think C 6.0, but discovered a few bugs in their libraries having to do
with 8-byte versus 4-byte integers. These bugs have probably been fixed by now.

This code has also been compiled under the MPW "Mr. C" Macintosh compiler by
Hans-Martin Mosner (hmm@heeg.de) with only one minor change: you will need to
create an empty "MacHeaders.h" file. You may get some harmless compiler warnings
and, for peak performance, the method that patches the dispatch loop must also be
changed. Hans-Martin says: "The whole VM seems to be marginally slower than the
delivered VM, but it is significantly smaller."

Note that Jitter 3 (Squeak V3.x) has migrated to Gnu GCC, and MPW. As of late fall 2000
there is no 68K version, but the macintosh specific source is the same as for CW.

The virtual machine uses the following libraries:

	Libraries for 68K Project:
		dnr.c
		InterfaceLib
		MathLibCFM68K (4i/8d).Lib
		MSL C.CFM68K Far(4i/8d).Lib
		MWCFM68KRuntime.Lib
		Profiler68kCFM.lib
		QuickTimeLib
		
		//Optional only to build OT version of 68K do not include in regular
build
		OpenTpt68kATalkLib
		OpenTpt68kClientLib
		OpenTpt68kInetLib
		OpenTpt68kUtilLib

	Libraries for PowerPC Project:
		InterfaceLib
		MathLib
		MSL C.PPC.Lib
		MWCRuntime.Lib
		profilerPPC.lib
		QuickTimeLib
		OpenTptInetPPC.o
		OpenTptInternetLib
		OpenTransportExtnPPC.o
		OpenTransportLib

The 68K Mac networking code also requires three files from Apple''s MacTCP
developer''s kit:

	MacTCP.h
	AddressXlation.h
	dnr.c

For convenience, these files are included.

The shipping 68K version of Squeak uses the older MacTCP interface. You can alter
the sqMacNetwork.c file and compile your own 68K verion of Squeak that uses the
new Open Transport version, but the availability of the 68K version of Open
Transport V1.3 is limited to 68040 machines that run system 8.1. You can run this
configuration on a 68030 using system 7.5.x but Apple does not support that
configuration.

To build a fat binary, build the 68K version first, and make sure that the file
"Squeak VM 68K" is included in the PowerPC project. Then build the PowerPC
version. CodeWarrior will include the 68K interpreter in the resource fork of the
output file, resulting in an interpreter that runs on either 68K or PowerPC Macs.
(JMM) Note I had some problems building the FAT application with CW11 I had to
copy the SqueakApp.rsrc items over to the application after it was built, these
resources aren''t copied from the 68K application like the documentation says they
should.

To get an additional speedup, the object code for the bytecode dispatch loop of
the PPC version can be patched using the method "patchInterp:" in Interpreter
class.

Note: In order to support dynamically loaded primitives, we have switched to
using Code Fragement Manager model for the 68K VM. This has several
ramifications:

  1. You now need to use the CFM versions of the library files. The 68K project
file has been updated accordingly.
  2. You cannot run the 68K VM under the emulator on the PowerPC (Apple doesn''t
support CFM apps under the 68K emulator).
  3. You need to be sure that version 4.0 or later of "CFM-68K Runtime Enabler"
is in the Extensions folder of the system folder on your 68K Mac. *** Warning:
Older versions of "CFM-68K Runtime Enabler" had bugs that will probably prevent
Squeak from even starting!! ***.

Carbon

We do not include a Carbon ready project at this time. Much of the work to make a
Carbon application is done, however we are still missing versions of the sound
plugin and the serialMidi plugin which are Carbon compliant. 

Building Named Primitive Plugins

I''ve included a pair of sample projects for building Squeak primitive plugins. As
usual, you must build the 68K version first, then the FAT one. If you don''t need
a FAT version, you can remove the 68K project from the PPC one.

Pluginized VM

Squeak 2.8 introduces the "pluginized VM". In the interest of getting a Mac
version of the 2.8 out as quickly and with as little chance of introducing bugs
as possible, I''ve made the bare minimal changes to the Mac support files. For
this reason, all the Mac primitives that were previously linked into the VM must
still be built into the VM as "internal" primitives. That is because many of them
still access a few VM functions and variables directly, rather than calling
through the interpreter proxy, which they must in order to run in an external
plugin. One can still override these builtin primitives with an external plugin
and, of course, newly built plugins can be created as external or internal
plugins. When the dust settles, it will be easy to make the final few changes
required.

Building Squeak as a Browser Plugin

I''ve included an archive containing a CW project file and various supporting
files for building the Squeak VM as plugin for Netscape or Internet Explorer on
the Mac. The plugin works with versions 4.0 or later of either browser. However,
the primitives that can be used to ask the browser to fetch a URL do not work in
versions of IE earlier than 5.0. There are also two resource files the contain
the strings needed to tell the browser about the plugin--its name, version, and
the mime and file extensions it recognizes.

To build this, you will need a copy of the Netscape Plugin SDK, available for
free at their web site. The required support files are:
	jri.h
	jritypes.h
	jri_md.h
	npapi.h
	npmac.cpp
	npupp.h

The installation and use of Squeak as a browser plugin is somewhat beyond the
scope of this readme file. The basic idea is that the Squeak image started by the
browser lives in a pre-defined directory ("System
Folder:Preferences:Squeak:Internet" by default) with predefined name (e.g.,
"squeak.image"). The browser plugin can only read and write files within the
Internet directory and directories contained within it. This is called Squeak
file system "sand box". The browser captures most of the command key combination,
so you have to use the menus rather than your favorite Squeak command key
shortcuts. {Note that using the full screen option allows you to again use the
command key combinations and has better performance characteristics.} The browser
also captures cmd-., so the interrupt key when running under the browser is
control-C. The most flexible way to invoke Squeak is through the HTML "EMBED"
command. This allows arbitrary arguments to be made available to Squeak. The
"memory" EMBED tag can be used to tell Squeak how much memory is required by a
given Squeaklet.

To build a browser plugin VM, do the following:

  1. translate a browser plugin version of the interpreter (using
Interpreter>translateForBrowserPlugin:).
  2. edit the file sqMacWindow.c and uncomment the #define of "PLUGIN"
  3. edit the file platform.exports and uncomment the #define of "PLUGIN"
  4. build the plugin using the supplied browser plugin project

If you build your own project file, note that IE requires that the main entry
point be "main" rather than CW''s usual "__start". (Netscape doesn''t care, so it
took me a long time to figure out why it wasn''t working under IE!!) The supplied
project produces a PPC-only plugin.

	-- John Maloney, May 25, 2000,
	-- Changes John M McIntosh Aug 2, 2000, Dec 1,2000
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 2/2/2001 15:23'!
squeakConfigFile

	^ '/* sqConfig.h -- platform identification and configuration */

#if defined(__MWERKS__) && !!defined(macintosh)  && !!defined(__be_os) && !!defined(__BEOS__)
  /* CodeWarrior 8 neglects to define "macintosh" */
# define macintosh
#endif

#if defined(WIN32) || defined(_WIN32) || defined(Win32)
  /* Some compilers use different win32 definitions.
     Define WIN32 so we have only to check for one symbol. */
# if !!defined(WIN32)
#  define WIN32
# endif
#endif

#if defined(macintosh)
# if defined(SQ_CONFIG_DONE)
#   error configuration conflict
# endif
# define SQ_CONFIG_DONE
#endif

#if defined(ACORN)
# if defined(SQ_CONFIG_DONE)
#   error configuration conflict
# endif
# define SQ_CONFIG_DONE
#endif

#if defined(WIN32)
# if defined(SQ_CONFIG_DONE)
#   error configuration conflict
# endif
# if defined(_M_IX86) || defined(X86)
  /* x86 systems */
#  define DOUBLE_WORD_ALIGNMENT
#  define DOUBLE_WORD_ORDER
  /* Note: We include a generic sqWin32.h to override some settings */
#  include "sqWin32.h"
#  define SQ_CONFIG_DONE
# elif defined(_WIN32_WCE)
#  include "sqWin32.h"
#  define SQ_CONFIG_DONE
# else
#  error unsupported win32 processor type (alpha?!!)
# endif
#endif

#if defined(__be_os) || defined(__BEOS__)
# if defined(SQ_CONFIG_DONE)
#   error configuration conflict
# endif
# include <ByteOrder.h>
# if B_HOST_IS_LENDIAN /* Intel, etc. */
#  define JUMP_ALIGN_BYTE
#  define DOUBLE_WORD_ALIGNMENT
#  define DOUBLE_WORD_ORDER
#  define HAS_LSB_FIRST
#  define SQ_CONFIG_DONE
# else  /* PPC, etc. */
#  define HAS_MSB_FIRST
#  define SQ_CONFIG_DONE
# endif
#endif

/* This file has been superseded by autoconf for Unix variants. */

#if defined(HAVE_CONFIG_H)
# include "sqUnixConfig.h"
# define SQ_CONFIG_DONE
#endif

#if !!defined(SQ_CONFIG_DONE)
# error test for, and describe, your architecture here.
#endif
'
! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 5/31/2000 21:51'!
squeakFilePrimsFile

	^ '#include "sq.h"
#ifndef NO_STD_FILE_SUPPORT
#include "FilePlugin.h"

/***
	The state of a file is kept in the following structure,
	which is stored directly in a Squeak bytes object.
	NOTE: The Squeak side is responsible for creating an
	object with enough room to store sizeof(SQFile) bytes.

	The session ID is used to detect stale file objects--
	files that were still open when an image was written.
	The file pointer of such files is meaningless.

	Files are always opened in binary mode; Smalltalk code
	does (or someday will do) line-end conversion if needed.

	Writeable files are opened read/write. The stdio spec
	requires that a positioning operation be done when
	switching between reading and writing of a read/write
	filestream. The lastOp field records whether the last
	operation was a read or write operation, allowing this
	positioning operation to be done automatically if needed.

	typedef struct {
		File	*file;
		int		sessionID;
		int		writable;
		int		fileSize;
		int		lastOp;  // 0 = uncommitted, 1 = read, 2 = write //
	} SQFile;

***/

/*** Constants ***/
#define UNCOMMITTED	0
#define READ_OP		1
#define WRITE_OP	2

#ifndef SEEK_SET
#define SEEK_SET	0
#define SEEK_CUR	1
#define SEEK_END	2
#endif

/*** Variables ***/
int thisSession = 0;
extern struct VirtualMachine * interpreterProxy;


int sqFileAtEnd(SQFile *f) {
	/* Return true if the file''s read/write head is at the end of the file. */

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	return ftell(f->file) == f->fileSize;
}

int sqFileClose(SQFile *f) {
	/* Close the given file. */

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	fclose(f->file);
	f->file = NULL;
	f->sessionID = 0;
	f->writable = false;
	f->fileSize = 0;
	f->lastOp = UNCOMMITTED;
}

int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize) {
	char cFileName[1000];
	int i, err;

	if (sqFileNameSize >= 1000) {
		return interpreterProxy->success(false);
	}

	/* copy the file name into a null-terminated C string */
	sqFilenameFromString(cFileName, sqFileNameIndex, sqFileNameSize);

	if (!!plugInAllowAccessToFilePath(cFileName, sqFileNameSize)) {
		return interpreterProxy->success(false);
	}


	err = remove(cFileName);
	if (err) {
		return interpreterProxy->success(false);
	}
}

int sqFileGetPosition(SQFile *f) {
	/* Return the current position of the file''s read/write head. */

	int position;

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	position = ftell(f->file);
	if (position < 0) return interpreterProxy->success(false);
	return position;
}

int sqFileInit(void) {
	/* Create a session ID that is unlikely to be repeated.
	   Zero is never used for a valid session number.
	   Should be called once at startup time.
	*/

	thisSession = clock() + time(NULL);
	if (thisSession == 0) thisSession = 1;	/* don''t use 0 */
	return 1;
}

int sqFileShutdown(void) {
	return 1;
}

int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag) {
	/* Opens the given file using the supplied sqFile structure
	   to record its state. Fails with no side effects if f is
	   already open. Files are always opened in binary mode;
	   Squeak must take care of any line-end character mapping.
	*/

	char cFileName[1001];
	int i;

	/* don''t open an already open file */
	if (sqFileValid(f)) return interpreterProxy->success(false);

	/* copy the file name into a null-terminated C string */
	if (sqFileNameSize > 1000) {
		return interpreterProxy->success(false);
	}
	sqFilenameFromString(cFileName, sqFileNameIndex, sqFileNameSize);

	if (!!plugInAllowAccessToFilePath(cFileName, sqFileNameSize)) {
		return interpreterProxy->success(false);
	}

	if (writeFlag) {
		/* First try to open an existing file read/write: */
		f->file = fopen(cFileName, "r+b");
		if (f->file == NULL) {
			/* Previous call fails if file does not exist. In that case,
			   try opening it in write mode to create a new, empty file.
			*/
			f->file = fopen(cFileName, "w+b");
			if (f->file !!= NULL) {
				/* set the type and creator of newly created Mac files */
				dir_SetMacFileTypeAndCreator((char *)sqFileNameIndex, sqFileNameSize, "TEXT", "R*ch");	
			}
		}
		f->writable = true;
	} else {
		f->file = fopen(cFileName, "rb");
		f->writable = false;
	}

	if (f->file == NULL) {
		f->sessionID = 0;
		f->fileSize = 0;
		return interpreterProxy->success(false);
	} else {
		f->sessionID = thisSession;
		/* compute and cache file size */
		fseek(f->file, 0, SEEK_END);
		f->fileSize = ftell(f->file);
		fseek(f->file, 0, SEEK_SET);
	}
	f->lastOp = UNCOMMITTED;
}

int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex) {
	/* Read count bytes from the given file into byteArray starting at
	   startIndex. byteArray is the address of the first byte of a
	   Squeak bytes object (e.g. String or ByteArray). startIndex
	   is a zero-based index; that is a startIndex of 0 starts writing
	   at the first byte of byteArray.
	*/

	char *dst;
	int bytesRead;

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	if (f->writable && (f->lastOp == WRITE_OP)) fseek(f->file, 0, SEEK_CUR);  /* seek between writing and reading */
	dst = (char *) (byteArrayIndex + startIndex);
	bytesRead = fread(dst, 1, count, f->file);
	f->lastOp = READ_OP;
	return bytesRead;
}

int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize) {
	char cOldName[1000], cNewName[1000];
	int i, err;

	if ((oldNameSize >= 1000) || (newNameSize >= 1000)) {
		return interpreterProxy->success(false);
	}

	/* copy the file names into null-terminated C strings */
	sqFilenameFromString(cOldName, oldNameIndex, oldNameSize);

	sqFilenameFromString(cNewName, newNameIndex, newNameSize);

	if (!!plugInAllowAccessToFilePath(cOldName, oldNameSize) ||
		!!plugInAllowAccessToFilePath(cNewName, newNameSize)) {
		return interpreterProxy->success(false);
	}

	err = rename(cOldName, cNewName);
	if (err) {
		return interpreterProxy->success(false);
	}
}

int sqFileSetPosition(SQFile *f, int position) {
	/* Set the file''s read/write head to the given position. */

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	fseek(f->file, position, SEEK_SET);
	f->lastOp = UNCOMMITTED;
}

int sqFileSize(SQFile *f) {
	/* Return the length of the given file. */

	if (!!sqFileValid(f)) return interpreterProxy->success(false);
	return f->fileSize;
}

int sqFileValid(SQFile *f) {
	return (
		(f !!= NULL) &&
		(f->file !!= NULL) &&
		(f->sessionID == thisSession));
}

int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex) {
	/* Write count bytes to the given writable file starting at startIndex
	   in the given byteArray. (See comment in sqFileReadIntoAt for interpretation
	   of byteArray and startIndex).
	*/

	char *src;
	int bytesWritten, position;

	if (!!(sqFileValid(f) && f->writable)) return interpreterProxy->success(false);
	if (f->lastOp == READ_OP) fseek(f->file, 0, SEEK_CUR);  /* seek between reading and writing */
	src = (char *) (byteArrayIndex + startIndex);
	bytesWritten = fwrite(src, 1, count, f->file);

	position = ftell(f->file);
	if (position > f->fileSize) {
		f->fileSize = position;  /* update file size */
	}

	if (bytesWritten !!= count) {
		interpreterProxy->success(false);
	}
	f->lastOp = WRITE_OP;
	return bytesWritten;
}
#endif /* NO_STD_FILE_SUPPORT */

'
! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 2/3/2001 16:35'!
squeakHeaderFile
	^'#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

#include "sqConfig.h"
#include "sqVirtualMachine.h"

#define true 1
#define false 0
#define null 0  /* using "null" because nil is predefined in Think C */

/* pluggable primitives macros */
/* Note: All pluggable primitives are defined as
	EXPORT(int) somePrimitive(void)
   If the platform requires special declaration modifiers
   the EXPORT macro can be redefined
*/
#define EXPORT(returnType) returnType

/* image save/restore macros */
/* Note: The image file save and restore code uses these macros; they
   can be redefined in sqPlatformSpecific.h if desired. These default
   versions are defined in terms of the ANSI Standard C libraries.
*/
#define sqImageFile FILE *
#define sqImageFileClose(f)                  fclose(f)
#define sqImageFileOpen(fileName, mode)      fopen(fileName, mode)
#define sqImageFilePosition(f)               ftell(f)
#define sqImageFileRead(ptr, sz, count, f)   fread(ptr, sz, count, f)
#define sqImageFileSeek(f, pos)              fseek(f, pos, SEEK_SET)
#define sqImageFileWrite(ptr, sz, count, f)  fwrite(ptr, sz, count, f)
#define sqImageFileStartLocation(fileRef, fileName, size)  0
#define sqAllocateMemory(minHeapSize, desiredHeapSize)   malloc(desiredHeapSize)

/* platform-dependent float conversion macros */
/* Note: Second argument must be a variable name, not an expression!! */
/* Note: Floats in image are always in PowerPC word order; change
   these macros to swap words if necessary. This costs no extra and
   obviates sometimes having to word-swap floats when reading an image.
*/
#if defined(DOUBLE_WORD_ALIGNMENT) || defined(DOUBLE_WORD_ORDER)
# ifdef DOUBLE_WORD_ORDER
/* word-based copy with swapping for non-PowerPC order */
#   define storeFloatAtfrom(i, floatVarName) \
	*((int *) (i) + 0) = *((int *) &(floatVarName) + 1); \
	*((int *) (i) + 1) = *((int *) &(floatVarName) + 0);
#   define fetchFloatAtinto(i, floatVarName) \
	*((int *) &(floatVarName) + 0) = *((int *) (i) + 1); \
	*((int *) &(floatVarName) + 1) = *((int *) (i) + 0);
# else /*!!DOUBLE_WORD_ORDER*/
/* word-based copy for machines with alignment restrictions */
#   define storeFloatAtfrom(i, floatVarName) \
	*((int *) (i) + 0) = *((int *) &(floatVarName) + 0); \
	*((int *) (i) + 1) = *((int *) &(floatVarName) + 1);
#   define fetchFloatAtinto(i, floatVarName) \
	*((int *) &(floatVarName) + 0) = *((int *) (i) + 0); \
	*((int *) &(floatVarName) + 1) = *((int *) (i) + 1);
# endif /*!!DOUBLE_WORD_ORDER*/
#else /*!!(DOUBLE_WORD_ORDER||DOUBLE_WORD_ALIGNMENT)*/
/* for machines that allow doubles to be on any word boundary */
# define storeFloatAtfrom(i, floatVarName) \
	*((double *) (i)) = (floatVarName);
# define fetchFloatAtinto(i, floatVarName) \
	(floatVarName) = *((double *) (i));
#endif

/* platform-dependent memory size adjustment macro */
/* Note: This macro can be redefined to allows platforms with a
   fixed application memory partition (notably, the Macintosh)
   to reserve extra C heap memory for special applications that need
   it (e.g., for a 3D graphics library). Since most platforms can
   extend their application memory partition at run time if needed,
   this macro is defined as a noop here and redefined if necessary
   in sqPlatformSpecific.h.
*/

#define reserveExtraCHeapBytes(origHeapSize, bytesToReserve) origHeapSize

/* platform-dependent millisecond clock macros */
/* Note: The Squeak VM uses three different clocks functions for
   timing. The primary one, ioMSecs(), is used to implement Delay
   and Time millisecondClockValue. The resolution of this clock
   determines the resolution of these basic timing functions. For
   doing real-time control of music and MIDI, a clock with resolution
   down to one millisecond is preferred, but a coarser clock (say,
   1/60th second) can be used in a pinch. The VM calls a different
   clock function, ioLowResMSecs(), in order to detect long-running
   primitives. This function must be inexpensive to call because when
   a Delay is active it is polled twice per primitive call. On several
   platforms (Mac, Win32), the high-resolution system clock used in
   ioMSecs() would incur enough overhead in this case to slow down the
   the VM significantly. Thus, a cheaper clock with low resolution is
   used to implement ioLowResMSecs() on these platforms. Finally, the
   function ioMicroMSecs() is used only to collect timing statistics
   for the garbage collector and other VM facilities. (The function
   name is meant to suggest that the function is based on a clock
   with microsecond accuracy, even though the times it returns are
   in units of milliseconds.) This clock must have enough precision to
   provide accurate timings, and normally isn''t called frequently
   enough to slow down the VM. Thus, it can use a more expensive clock
   that ioMSecs(). By default, all three clock functions are defined
   here as macros based on the standard C library function clock().
   Any of these macros can be overridden in sqPlatformSpecific.h.
*/

int ioMSecs(void);
int ioLowResMSecs(void);
int ioMicroMSecs(void);

#define ioMSecs()		((1000 * clock()) / CLOCKS_PER_SEC)
#define ioLowResMSecs()	((1000 * clock()) / CLOCKS_PER_SEC)
#define ioMicroMSecs()	((1000 * clock()) / CLOCKS_PER_SEC)

/* filename copy/transform macro. An opportunity to transform the filenames for
   platforms with strange needs, anda simple encapsulation for everyone else
*/
#define sqFilenameFromString(dst, src, num) \
if (1) { \
	int i; \
	for (i = 0; i < num; i++) { \
		dst[i] = *((char *) (src + i)); \
	} \
	dst[num] = 0;\
}

/* this include file may redefine earlier definitions and macros: */
#include "sqPlatformSpecific.h"

/* interpreter entry points */
void error(char *s);
int checkedByteAt(int byteAddress);
int checkedByteAtput(int byteAddress, int byte);
int checkedLongAt(int byteAddress);
int checkedLongAtput(int byteAddress, int a32BitInteger);
int fullDisplayUpdate(void);
int initializeInterpreter(int bytesToShift);
int interpret(void);
int primitiveFail(void);
int signalSemaphoreWithIndex(int index);
int success(int);

/* display, mouse, keyboard, time i/o */
int ioBeep(void);
int ioExit(void);
int ioForceDisplayUpdate(void);
int ioFormPrint(
	int bitsAddr, int width, int height, int depth,
	double hScale, double vScale, int landscapeFlag);
int ioSetFullScreen(int fullScreen);
int ioRelinquishProcessorForMicroseconds(int microSeconds);
int ioScreenSize(void);
int ioSeconds(void);
int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY);
int ioSetCursorWithMask(int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY);
int ioShowDisplay(
	int dispBitsIndex, int width, int height, int depth,
	int affectedL, int affectedR, int affectedT, int affectedB);
int ioHasDisplayDepth(int depth);
int ioSetDisplayMode(int width, int height, int depth, int fullscreenFlag);

/* Power Management */

int ioDisablePowerManager(int disableIfNonZero);

/* User input recording I:
   In general, either set of input function can be supported,
   depending on the platform. This (first) set is state based
   and should be supported even on platforms that make use
   of the newer event driven API to support older images 
   without event support.
*/
int ioGetButtonState(void);
int ioGetKeystroke(void);
int ioMousePoint(void);
int ioPeekKeystroke(void);
/* Note: In an event driven architecture, ioProcessEvents is obsolete.
   It can be implemented as a no-op since the image will check for
   events in regular intervals. */
int ioProcessEvents(void);


/* User input recording II:
   The following functions and definition can be used on
   platform supporting events directly.
*/
/* types of events */
#define EventTypeNone 0
#define EventTypeMouse 1
#define EventTypeKeyboard 2
#define EventTypeDragDropFiles 3

/* keypress state for keyboard events */
#define EventKeyChar 0
#define EventKeyDown 1
#define EventKeyUp 2

/* button definitions */
#define RedButtonBit 4
#define BlueButtonBit 2
#define YellowButtonBit 1

/* modifier definitions */
#define ShiftKeyBit 1
#define CtrlKeyBit 2
#define OptionKeyBit 4
#define CommandKeyBit 8

/* generic input event definition */
typedef struct sqInputEvent {
	int type; /* type of event; either one of EventTypeXXX */
	unsigned int timeStamp; /* time stamp */
     /* the interpretation of the following fields depend on the type of the event */
	int unused1;
	int unused2;
	int unused3;
	int unused4;
	int unused5;
	int unused6;
} sqInputEvent;

/* mouse input event definition */
typedef struct sqMouseEvent {
	int type; /* EventTypeMouse */
	unsigned int timeStamp; /* time stamp */
	int x; /* mouse position x */
	int y; /* mouse position y */
	int buttons; /* combination of xxxButtonBit */
	int modifiers; /* combination of xxxKeyBit */
	int reserved1; /* reserved for future use */
	int reserved2; /* reserved for future use */
} sqMouseEvent;

/* keyboard input event definition */
typedef struct sqKeyboardEvent {
	int type; /* EventTypeKeyboard */
	unsigned int timeStamp; /* time stamp */
	int charCode; /* character code in Mac Roman encoding */
	int pressCode; /* press code; any of EventKeyXXX */
	int modifiers; /* combination of xxxKeyBit */
	int reserved1; /* reserved for future use */
	int reserved2; /* reserved for future use */
	int reserved3; /* reserved for future use */
} sqKeyboardEvent;

/* drop files event definition:
   DragEnter - drag operation from OS entered Squeak window
   DragMove  - drag operation from OS moved within Squeak window
   DragLeave - drag operation from OS left Squeak window
   DragDrop  - drag operation dropped contents onto Squeak.
*/
#define DragEnter 1
#define DragMove  2
#define DragLeave 3
#define DragDrop  4
typedef struct sqDragDropFilesEvent {
	int type; /* EventTypeDropFiles */
	unsigned int timeStamp; /* time stamp */
	int dragType; /* one of the DragXXX constants */
	int x; /* mouse position x */
	int y; /* mouse position y */
	int modifiers; /* combination of xxxKeyBit */
	int numFiles; /* number of files in transaction */
	int reserved1; /* reserved for future use */
} sqDragDropFilesEvent;


/* set an asynchronous input semaphore index for events */
int ioSetInputSemaphore(int semaIndex);
/* retrieve the next input event from the OS */
int ioGetNextEvent(sqInputEvent *evt);

/* image file and VM path names */
extern char imageName[];
int imageNameGetLength(int sqImageNameIndex, int length);
int imageNamePutLength(int sqImageNameIndex, int length);
int imageNameSize(void);
int vmPathSize(void);
int vmPathGetLength(int sqVMPathIndex, int length);

/* save/restore */
/* Read the image from the given file starting at the given image offset */
int readImageFromFileHeapSizeStartingAt(sqImageFile f, int desiredHeapSize, int imageOffset);
/* NOTE: The following is obsolete - it is only provided for compatibility */
#define readImageFromFileHeapSize(f, s) readImageFromFileHeapSizeStartingAt(f,s,0)

/* clipboard (cut/copy/paste) */
int clipboardSize(void);
int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex);
int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex);

/* browser plug-in support */
int plugInAllowAccessToFilePath(char *pathString, int pathStringLength);
void plugInForceTimeToReturn(void);
int plugInInit(char *imageName);
int plugInNotifyUser(char *msg);
void plugInSetStartTime(void);
int plugInShutdown(void);
int plugInTimeToReturn(void);

/* interpreter entry points needed by compiled primitives */
void * arrayValueOf(int arrayOop);
int checkedIntegerValueOf(int intOop);
void * fetchArrayofObject(int fieldIndex, int objectPointer);
double fetchFloatofObject(int fieldIndex, int objectPointer);
int fetchIntegerofObject(int fieldIndex, int objectPointer);
double floatValueOf(int floatOop);
int pop(int nItems);
int pushInteger(int integerValue);
int sizeOfSTArrayFromCPrimitive(void *cPtr);
int storeIntegerofObjectwithValue(int fieldIndex, int objectPointer, int integerValue);

/* profiling */
int clearProfile(void);
int dumpProfile(void);
int startProfiling(void);
int stopProfiling(void);

/* system attributes */
int attributeSize(int id);
int getAttributeIntoLength(int id, int byteArrayIndex, int length);

/*** pluggable primitive support ***/
/* NOTE: The following functions are those implemented by sqNamedPrims.c */
int ioLoadExternalFunctionOfLengthFromModuleOfLength(
  int functionNameIndex, int functionNameLength,
  int moduleNameIndex, int moduleNameLength);
int ioUnloadModuleOfLength(int moduleNameIndex, int moduleNameLength);
int ioLoadFunctionFrom(char *functionName, char *pluginName);
int ioShutdownAllModules(void);
int ioUnloadModule(char *);
int ioUnloadModuleOfLength(int moduleNameIndex, int moduleNameLength);
char *ioListBuiltinModule(int moduleIndex);
char *ioListLoadedModule(int moduleIndex);
/* The next two are FFI entries!! (implemented in sqNamedPrims.c as well) */
int ioLoadModuleOfLength(int moduleNameIndex, int moduleNameLength);
int ioLoadSymbolOfLengthFromModule(int functionNameIndex, int functionNameLength, int moduleHandle);

/* The next three functions must be implemented by sqXYZExternalPrims.c */
/* ioLoadModule:
	Load a module from disk.
	WARNING: this always loads a *new* module. Don''t even attempt to find a loaded one.
	WARNING: never primitiveFail() within, just return 0
*/
int ioLoadModule(char *pluginName);

/* ioFindExternalFunctionIn:
	Find the function with the given name in the moduleHandle.
	WARNING: never primitiveFail() within, just return 0.
*/
int ioFindExternalFunctionIn(char *lookupName, int moduleHandle);

/* ioFreeModule:
	Free the module with the associated handle.
	WARNING: never primitiveFail() within, just return 0.
*/
int ioFreeModule(int moduleHandle);

/* The Squeak version this interpreter was generated from */
extern const char *interpreterVersion;
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'TPR 5/23/2000 17:34'!
squeakNamedPrimsFile
^'/****************************************************************************
*   PROJECT: Squeak 
*   FILE:    sqNamedPrims.c
*   CONTENT: Generic (cross platform) named primitive support
*
*   AUTHOR:  Andreas Raab (ar)
*   ADDRESS: Walt Disney Imagineering, Glendale, CA
*   EMAIL:   Andreas.Raab@disney.com
*   RCSID:   $Id$
*
*   NOTES:
*
*****************************************************************************/
#include "sq.h"
#include "sqNamedPrims.h"

#ifdef DEBUG
#define dprintf(what) printf what
#else
#define dprintf(what)
#endif

typedef struct ModuleEntry {
	struct ModuleEntry *next;
	void *handle;
	int ffiLoaded;
	char name[1];
} ModuleEntry;


static ModuleEntry *squeakModule = NULL;
static ModuleEntry *firstModule = NULL;
struct VirtualMachine *sqGetInterpreterProxy(void);

static void *findLoadedModule(char *pluginName)
{
	ModuleEntry *module;
	if(!!pluginName || !!pluginName[0]) return squeakModule;
	module = firstModule;
	while(module) {
		if(strcmp(module->name, pluginName) == 0) return module;
		module = module->next;
	}
	return NULL;
}

static ModuleEntry *addToModuleList(char *pluginName, void* handle, int ffiFlag)
{
	ModuleEntry *module;

	module = (ModuleEntry*) calloc(1, sizeof(ModuleEntry) + strlen(pluginName));
	strcpy(module->name, pluginName);
	module->handle = handle;
	module->ffiLoaded = ffiFlag;
	module->next = firstModule;
	firstModule = module;
	return firstModule;
}

/*
	removeFromList:
	Remove the given entry from the list of loaded modules.
	Do NOT free it yet.
*/
static int removeFromList(ModuleEntry *entry)
{
	ModuleEntry *prevModule;

	/* Unlink the entry from the module chain */
	if(entry == firstModule) {
		firstModule = entry->next;
	} else {
		prevModule = firstModule;
		while(prevModule->next !!= entry)
			prevModule = prevModule->next;
		prevModule->next = entry->next;
	}
	return 1;
}

/*
	findExternalFunctionIn:
	Look up "pluginName_functionName" in the specified module through
	the OS dependent call. NEVER used to search through the internal
	primitive table.
*/
static void *findExternalFunctionIn(char *functionName, ModuleEntry *module)
{
	void *result;

	dprintf(("Looking (externally) for %s ... ", functionName));
	if(module->handle)
		result = (void*) ioFindExternalFunctionIn(functionName, (int) module->handle);
	else
		result = NULL;
	dprintf(("%s\n", result ? "found" : "not found"));
	return result;
}

/*
	findInternalFunctionIn:
	Lookup the given "pluginName_functionName" in the internal
	primitive table. If it can not be found try to look it up
	by using the OS dependent mechanism (see comment below).
*/
static void *findInternalFunctionIn(char *functionName, char *pluginName)
{
	char *function, *plugin;
	int index;

	dprintf(("Looking (internally) for %s in %s ... ", functionName, (pluginName ? pluginName : "<intrinsic>")));

	/* canonicalize functionName and pluginName to be NULL if not specified */
	if(functionName && !!functionName[0]) functionName = NULL;
	if(pluginName && !!pluginName[0]) pluginName = NULL;

	for(index=0;;index++) {
		plugin = internalPrimitiveNames[index][0];
		function = internalPrimitiveNames[index][1];

		/* canonicalize plugin and function to be NULL if not specified */
		if(plugin && !!plugin[0]) plugin = NULL;
		if(function && !!function[0]) function = NULL;

		if(!!plugin && !!function) {/* At end of table. */
			dprintf(("not found\n"));
			return NULL;
		}
		/* check for module name match */
		if((pluginName == NULL) !!= (plugin == NULL)) continue; /* one is missing */
		if(plugin && strcmp(pluginName, plugin)) continue; /* name mismatch */

		/* check for function name match */
		if((functionName == NULL) !!= (function == NULL)) continue; /* one is missing */
		if(function && strcmp(functionName, function)) continue; /* name mismatch */

		/* match */
		dprintf(("found\n"));
		return internalPrimitiveAddresses[index];
	}
}


static void *findFunctionIn(char *functionName, ModuleEntry *module)
{
	if(module->handle == squeakModule->handle)
		return findInternalFunctionIn(functionName, module->name);
	else
		return findExternalFunctionIn(functionName, module);
}

/*
	callInitializersIn:
	Call the required initializers in the given module.
	The module has been loaded before so the task is to
	call a) setInterpreter() and check it''s return, and
	b) initialiseModule (if defined) and check it''s return
	as well.
*/
static int callInitializersIn(ModuleEntry *module)
{
	void *init0;
	void *init1;
	void *init2;
	char *moduleName;
	int okay;

	init0 = findFunctionIn("getModuleName", module);
	init1 = findFunctionIn("setInterpreter", module);
	init2 = findFunctionIn("initialiseModule", module);

	if(init0) {
		/* Check the compiled name of the module */
		moduleName = ((char* (*) (void))init0)();
		if(!!moduleName) {
			dprintf(("ERROR: getModuleName() returned NULL\n"));
			return 0;
		}
		if(strncmp(moduleName, module->name, strlen(module->name)) !!= 0) {
			dprintf(("ERROR: getModuleName returned %s (expected: %s)\n", moduleName, module->name));
			return 0;
		}
	} else {
		/* Note: older plugins may not export the compiled module name */
		dprintf(("WARNING: getModuleName() not found in %s\n", module->name));
	}
	if(!!init1) { 
		dprintf(("ERROR: setInterpreter() not found\n"));
		return 0;
	}
	/* call setInterpreter */
	okay = ((int (*) (struct VirtualMachine*))init1)(sqGetInterpreterProxy());
	if(!!okay) {
		dprintf(("ERROR: setInterpreter() returned false\n"));
		return 0;
	}
	if(init2) {
		okay = ((int (*) (void)) init2)();
		if(!!okay) {
			dprintf(("ERROR: initialiseModule() returned false\n"));
			return 0;
		}
	}
	dprintf(("SUCCESS: Module %s is now initialized\n", module->name));
	return 1;
}

/*
	findAndLoadModule:
	Find the module with the given name by,
	* first looking it up in some (external) shared library
	* then, by trying to find pluginName_setInterpreter.
	If the module is found and the initialisers work, add it
	to the list of loaded modules and return the new module.
	If anything goes wrong make sure the module is unloaded
	(WITHOUT calling shutdownModule()) and return NULL.
*/
static ModuleEntry *findAndLoadModule(char *pluginName, int ffiLoad)
{
	void *handle;
	ModuleEntry *module;

	dprintf(("Looking for plugin %s\n", (pluginName ? pluginName : "<intrinsic>")));
	/* Try to load the module externally */
	handle = (void*) ioLoadModule(pluginName);
	if(ffiLoad) {
		/* When dealing with the FFI, don''t attempt to mess around internally */
		if(!!handle) return NULL;
		return addToModuleList(pluginName, handle, ffiLoad);
	}
	/* NOT ffiLoad */
	if(!!handle) {
		/* might be internal, so go looking for setInterpreter() */
		if(findInternalFunctionIn("setInterpreter", pluginName))
			handle = squeakModule->handle;
		else
			return NULL; /* PluginName_setInterpreter() not found */
	}
	module = addToModuleList(pluginName, handle, ffiLoad);
	if(!!callInitializersIn(module)) {
		/* Initializers failed */
		if(handle !!= squeakModule->handle) {
			/* physically unload module */
			ioFreeModule((int)handle);
		}
		removeFromList(module); /* remove list entry */
		free(module); /* give back space */
		module = NULL;
	}
	return module;
}

/* findOrLoadModule:
	Look if the given module is already loaded. 
	If so, return it''s handle, otherwise try to load it.
*/
static ModuleEntry *findOrLoadModule(char *pluginName, int ffiLoad)
{
	ModuleEntry *module;

	if(!!squeakModule) {
		/* Load intrinsics (if possible) */
		squeakModule = addToModuleList("", NULL, 1);
		firstModule = NULL; /* drop off module list - will never be unloaded */
	}

	/* see if the module was already loaded */
	module = findLoadedModule(pluginName);
	if(!!module) {
		/* if not try loading it */
		module = findAndLoadModule(pluginName, ffiLoad);
	}
	return module; /* module not found */
}

/* ioLoadFunctionFrom:
	Load and return the given function from the specified plugin.
	Return the function address if successful, otherwise 0.
	This entry point is called from the interpreter proxy.
*/
int ioLoadFunctionFrom(char *functionName, char *pluginName)
{
	ModuleEntry *module;

	module = findOrLoadModule(pluginName, 0);
	if(!!module) {
		/* no module */
		dprintf(("Failed to find %s (module %s was not loaded)\n", functionName, pluginName));
		return 0;
	}
	if(!!functionName) {
		/* only the module was requested but not any specific function */
		return 1;
	}
	/* and load the actual function */
	return (int) findFunctionIn(functionName, module);
}

/* ioLoadExternalFunctionOfLengthFromModuleOfLength
	Entry point for functions looked up through the VM.
*/
int ioLoadExternalFunctionOfLengthFromModuleOfLength(int functionNameIndex, int functionNameLength, 
                                                     int moduleNameIndex,   int moduleNameLength)
{
	char functionName[256];
	char moduleName[256];
	int i;

	if(functionNameLength > 255 || moduleNameLength > 255)
		return 0; /* can''t cope with those */
	for(i=0; i< functionNameLength; i++)
		functionName[i] = ((char*)functionNameIndex)[i];
	functionName[functionNameLength] = 0;
	for(i=0; i< moduleNameLength; i++)
		moduleName[i] = ((char*)moduleNameIndex)[i];
	moduleName[moduleNameLength] = 0;
	return ioLoadFunctionFrom(functionName, moduleName);
}

/* ioLoadSymbolOfLengthFromModule
	This entry point is exclusively for the FFI.
*/
int ioLoadSymbolOfLengthFromModule(int functionNameIndex, int functionNameLength, int moduleHandle)
{
	char functionName[256];
	int i;

	if(functionNameLength > 255)
		return 0; /* can''t cope with those */
	for(i=0; i< functionNameLength; i++)
		functionName[i] = ((char*)functionNameIndex)[i];
	functionName[functionNameLength] = 0;
	if(moduleHandle)
		return ioFindExternalFunctionIn(functionName, moduleHandle);
	else
		return 0;
}

/* ioLoadModuleOfLength
	This entry point is exclusively for the FFI.
	It does *NOT* call any of the initializers nor
	does it attempt to lookup stuff internally.
*/
int ioLoadModuleOfLength(int moduleNameIndex, int moduleNameLength)
{
	ModuleEntry *module;
	char moduleName[256];
	int i;

	if(moduleNameLength > 255) return 0; /* can''t cope with those */
	for(i=0; i< moduleNameLength; i++)
		moduleName[i] = ((char*)moduleNameIndex)[i];
	moduleName[moduleNameLength] = 0;

	module = findOrLoadModule(moduleName, 1);
	if(module) return (int) module->handle;
	return 0;
}


/* shutdownModule:
	Call the shutdown mechanism from the specified module.
*/
static int shutdownModule(ModuleEntry *module)
{
	void* fn;

	if(module->ffiLoaded) return 1; /* don''t even attempt for ffi loaded modules */

	/* load the actual function */
	fn = findFunctionIn("shutdownModule", module);
	if(fn) return ((int (*) (void)) fn) ();
	return 1;
}

/* ioShutdownAllModules:
	Call the shutdown mechanism for all loaded modules.
*/
int ioShutdownAllModules(void)
{
	ModuleEntry *entry;
	entry = firstModule;
	while(entry) {
		shutdownModule(entry);
		entry = entry->next;
	}
	return 1;
}

/* ioUnloadModule:
	Unload the module with the given name.
*/
int ioUnloadModule(char *moduleName)
{
	ModuleEntry *entry, *temp;

	if(!!squeakModule) return 0; /* Nothing has been loaded */
	if(!!moduleName || !!moduleName[0]) return 0; /* nope */

	entry = findLoadedModule(moduleName);
	if(!!entry) return 1; /* module was never loaded */

	/* Try to shutdown the module */
	if(!!shutdownModule(entry)) {
		/* Could not shut down the module. Bail out. */
		return 0;
	}
	/* Notify all interested parties about the fact */
	temp = firstModule;
	while(temp) {
		if(temp !!= entry) {
			/* Lookup moduleUnloaded: from the plugin */
			void *fn = findFunctionIn("moduleUnloaded", temp);
			if(fn) {
				/* call it */
				((int (*) (char *))fn)(entry->name);
			}
		}
		temp = temp->next;
	}
	/* And actually unload it if it isn''t just the VM... */
	if(entry->handle !!= squeakModule->handle)
		ioFreeModule((int) entry->handle);
	removeFromList(entry);
	free(entry); /* give back space */
	return 1;
}

/* ioUnloadModuleOfLength:
	Entry point for the interpreter.
*/
int ioUnloadModuleOfLength(int moduleNameIndex, int moduleNameLength)
{
	char moduleName[256];
	int i;

	if(moduleNameLength > 255) return 0; /* can''t cope with those */
	for(i=0; i< moduleNameLength; i++)
		moduleName[i] = ((char*)moduleNameIndex)[i];
	moduleName[moduleNameLength] = 0;
	return ioUnloadModule(moduleName);
}

/* ioListBuiltinModule:
	Return the name of the n-th builtin module.
*/

char *ioListBuiltinModule(int moduleIndex)
{
	int index;
	char *function;
	char *plugin;

	for(index=0;;index++) {
		plugin = internalPrimitiveNames[index][0];
		function = internalPrimitiveNames[index][1];
		if(!!function && !!plugin) return NULL; /* no more plugins */
		if(strcmp(function,"setInterpreter") == 0) {
			/* new module */
			if(--moduleIndex == 0) {
				char *moduleName;
				void * init0;
		
				init0 = findInternalFunctionIn("getModuleName", plugin);
				if(init0) {
					/* Check the compiled name of the module */
					moduleName = ((char* (*) (void))init0)();
					if(moduleName) { return moduleName;}
				}
				return plugin;
			}
		}
	}
}

char *ioListLoadedModule(int moduleIndex) {
	int index = 1;

	ModuleEntry *entry;
	entry = firstModule;

	if ( moduleIndex < 1) return (char*)NULL;
	while(entry && index < moduleIndex) {
		entry = entry->next;
		index = index + 1;
	}
	if ( entry ) {
		char *moduleName;
		void * init0;

		init0 = findFunctionIn("getModuleName", entry);
		if(init0) {
			/* Check the compiled name of the module */
			moduleName = ((char* (*) (void))init0)();
			if(moduleName) { return moduleName;}
		}
		return entry->name;
	}
	else return (char*)NULL;
}
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 2/2/2001 15:21'!
squeakPlatSpecFile

	^ '/* sqPlatformSpecific.h -- Platform-specific prototypes and definitions */

/* How to use this file:
   This file is for general platform-specific macros and declarations.
   Function prototypes that are unlikely to introduce name conflicts on
   other platforms can be added directly. Macro re-definitions or conflicting
   function prototypes can be wrapped in a #ifdefs. Alternatively, a customized
   version of this file can be used on that platform. The goal is to keep all
   the other header files generic across platforms. To override a definition or
   macro from sq.h, you must first #undef it, then provide the new definition.
*/

#ifdef UNIX
/* unix-specific prototypes and definitions */
void aioPollForIO(int microSeconds, int extraFd);
#define SQ_FORM_FILENAME	"squeak-form.ppm"

/* undefine clock macros that are implemented as functions */
#undef ioMSecs
#undef ioMicroMSecs
#undef ioLowResMSecs
#endif /* UNIX */

#ifdef macintosh

// CARBON

/*#ifdef TARGET_API_MAC_CARBON  
    #undef TARGET_API_MAC_CARBON
    #define TARGET_API_MAC_CARBON 1
#else
    #define TARGET_API_MAC_CARBON 1
#endif */


/* replace the image file manipulation macros with functions */
#undef sqImageFile
#undef sqImageFileClose
#undef sqImageFileOpen
#undef sqImageFilePosition
#undef sqImageFileRead
#undef sqImageFileSeek
#undef sqImageFileWrite
#undef sqImageFileStartLocation
#undef sqAllocateMemory

typedef int sqImageFile;
void        sqImageFileClose(sqImageFile f);
sqImageFile sqImageFileOpen(char *fileName, char *mode);
int         sqImageFilePosition(sqImageFile f);
int         sqImageFileRead(void *ptr, int elementSize, int count, sqImageFile f);
void        sqImageFileSeek(sqImageFile f, int pos);
int         sqImageFileWrite(void *ptr, int elementSize, int count, sqImageFile f);
int         sqImageFileStartLocation(int fileRef, char *filename, int imageSize);
void *						sqAllocateMemory(int minHeapSize, int desiredHeapSize);

/* override reserveExtraCHeapBytes() macro to reduce Squeak object heap size on Mac */
#undef reserveExtraCHeapBytes
#define reserveExtraCHeapBytes(origHeapSize, bytesToReserve) (origHeapSize - bytesToReserve)

/* undefine clock macros that are implemented as functions */
#undef ioMSecs
#undef ioMicroMSecs

/* macro to return from interpret() loop in browser plugin VM */
#define ReturnFromInterpret() return

/* prototypes missing from CW11 headers */
#include <textutils.h>
void CopyPascalStringToC(ConstStr255Param src, char* dst);
void CopyCStringToPascal(const char* src, Str255 dst);
#endif /* macintosh */


#ifdef ACORN
/* acorn memory allocation */
#undef sqAllocateMemory
#define sqAllocateMemory(minHeapSize, desiredHeapSize) platAllocateMemory(desiredHeapSize)
#undef sqFilenameFromString
#define sqFilenameFromString(dst, src, num) sqFilenameFromString(dst, src, num)

/* string copying macro to compensate for bug in Acorn library code */
#define copyNCharsFromTo(num, src, dst)\
if(1) {int sqfni;\
	char cc;\
	for (sqfni = 0; sqfni < num; sqfni++) {\
		dst[sqfni] = cc = *((char *) (src + sqfni));\
		if ( cc == 0) break;\
	}\
	dst[num] = 0;\
}

/* undefine clock macros that are implemented as functions */
#undef ioMicroMSecs
#undef ioMSecs
#define ioMSecs() (10* (int)os_read_monotonic_time())
#undef ioLowResMSecs
#define ioLowResMSecs() (ioMSecs())
#endif /* ACORN */

#ifdef WIN32
/* Override necessary definitions */
#undef putchar
#include "sqWin32Alloc.h"

#ifdef WIN32_FILE_SUPPORT

#undef sqImageFile
#undef sqImageFileClose
#undef sqImageFileOpen
#undef sqImageFilePosition
#undef sqImageFileRead
#undef sqImageFileSeek
#undef sqImageFileWrite

#define sqImageFile unsigned long
int sqImageFileClose(sqImageFile h);
sqImageFile sqImageFileOpen(char *fileName, char *mode);
int sqImageFilePosition(sqImageFile h);
int sqImageFileRead(void *ptr, int sz, int count, sqImageFile h);
int sqImageFileSeek(sqImageFile h, int pos);
int sqImageFileWrite(void *ptr, int sz, int count, sqImageFile h);

#endif /* WIN32_FILE_SUPPORT */

/* pluggable primitive support */
#if defined(_MSC_VER) || defined(__MINGW32__)
#  undef EXPORT
#  define EXPORT(returnType) __declspec( dllexport ) returnType
#endif 

/* undefine clock macros that are implemented as functions */
#undef ioMSecs
#undef ioLowResMSecs
#undef ioMicroMSecs

/* Declare GetTickCount() in case <windows.h> is not included */
#if !!defined(_WINDOWS_) && !!defined(_WIN32_WCE) && !!defined(_WINDOWS_H)
__declspec(dllimport) unsigned long __stdcall GetTickCount(void);
#endif

#define ioLowResMSecs() GetTickCount()

#endif /* WIN32 */

#if defined(__be_os) || defined(__BEOS__) // BeOS support

void AsyncSignalSemaphoreWithIndex(int semaIndex); // external SYNCHRONIZED signaling of semaphores
void SignalSqSemaphores(); // signal semaphores signalled with

/* undefine clock macros that are implemented as functions */
#undef ioMSecs
#undef ioMicroMSecs

/* pluggable primitive support */
# undef EXPORT
# define EXPORT(returnType) __declspec( dllexport ) returnType

#endif /* BeOS */    

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'JMM 11/10/2000 10:36'!
squeakPlatformExportsFile

	^ '/* This file is for extra (platform) specific declarations of exported functions.
   The general format is a list of XFN(name), referring to the extra exports that
   should be listed in the internal primitive table. As an example, two extra
   definitions required by the Unix VM would look like:

   XFN(setSocketPollFunction)
   XFN(setSoundPollFunction)
*/

#ifdef macintosh

	XFN(getSTWindow)
	XFN(setMessageHook)
	XFN(setPostMessageHook)
	
//#define PLUGIN
#ifdef PLUGIN
/* Plugin support primitives
   We should make these primitives a proper plugin
   but right now we just need the exports. */
XFN(primitivePluginBrowserReady)
XFN(primitivePluginRequestURLStream)
XFN(primitivePluginRequestURL)
XFN(primitivePluginPostURL)
XFN(primitivePluginRequestFileHandle)
XFN(primitivePluginDestroyRequest)
XFN(primitivePluginRequestState)
#endif
#endif /* macintosh */

#ifdef UNIX
   XFN(setSocketPollFunction)
   XFN(setSoundPollFunction)
#endif

#ifdef ACORN
   XFN(setSocketPollFunction)
#endif

'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 5/13/2000 14:56'!
squeakVirtualMachineFile
^'#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include "sqVirtualMachine.h"

/*** Function prototypes ***/

/* InterpreterProxy methodsFor: ''stack access'' */
int pop(int nItems);
int popthenPush(int nItems, int oop);
int push(int object);
int pushBool(int trueOrFalse);
int pushFloat(double f);
int pushInteger(int integerValue);
double stackFloatValue(int offset);
int stackIntegerValue(int offset);
int stackObjectValue(int offset);
int stackValue(int offset);

/*** variables ***/

extern int (*compilerHooks[])();
extern int setCompilerInitialized(int flagValue);

/* InterpreterProxy methodsFor: ''object access'' */
int argumentCountOf(int methodPointer);
void * arrayValueOf(int oop);
int byteSizeOf(int oop);
void * fetchArrayofObject(int fieldIndex, int objectPointer);
int fetchClassOf(int oop);
double fetchFloatofObject(int fieldIndex, int objectPointer);
int fetchIntegerofObject(int fieldIndex, int objectPointer);
int fetchPointerofObject(int index, int oop);
int fetchWordofObject(int fieldIndex, int oop);
void * firstFixedField(int oop);
void * firstIndexableField(int oop);
int literalofMethod(int offset, int methodPointer);
int literalCountOf(int methodPointer);
int methodArgumentCount(void);
int methodPrimitiveIndex(void);
int primitiveMethod(void);
int primitiveIndexOf(int methodPointer);
int sizeOfSTArrayFromCPrimitive(void *cPtr);
int slotSizeOf(int oop);
int stObjectat(int array, int index);
int stObjectatput(int array, int index, int value);
int stSizeOf(int oop);
int storeIntegerofObjectwithValue(int index, int oop, int integer);
int storePointerofObjectwithValue(int index, int oop, int valuePointer);


/* InterpreterProxy methodsFor: ''testing'' */
int isKindOf(int oop, char *aString);
int isMemberOf(int oop, char *aString);
int isBytes(int oop);
int isFloatObject(int oop);
int isIndexable(int oop);
int isIntegerObject(int objectPointer);
int isIntegerValue(int intValue);
int isPointers(int oop);
int isWeak(int oop);
int isWords(int oop);
int isWordsOrBytes(int oop);
int includesBehaviorThatOf(int aClass, int aSuperClass);

/* InterpreterProxy methodsFor: ''converting'' */
int booleanValueOf(int obj);
int checkedIntegerValueOf(int intOop);
int floatObjectOf(double aFloat);
double floatValueOf(int oop);
int integerObjectOf(int value);
int integerValueOf(int oop);
int positive32BitIntegerFor(int integerValue);
int positive32BitValueOf(int oop);
int signed32BitIntegerFor(int integerValue);
int signed32BitValueOf(int oop);

/* InterpreterProxy methodsFor: ''special objects'' */
int characterTable(void);
int displayObject(void);
int falseObject(void);
int nilObject(void);
int trueObject(void);


/* InterpreterProxy methodsFor: ''special classes'' */
int classArray(void);
int classBitmap(void);
int classByteArray(void);
int classCharacter(void);
int classFloat(void);
int classLargePositiveInteger(void);
int classLargeNegativeInteger(void);
int classPoint(void);
int classSemaphore(void);
int classSmallInteger(void);
int classString(void);


/* InterpreterProxy methodsFor: ''instance creation'' */
int clone(int oop);
int instantiateClassindexableSize(int classPointer, int size);
int makePointwithxValueyValue(int xValue, int yValue);
int popRemappableOop(void);
int pushRemappableOop(int oop);


/* InterpreterProxy methodsFor: ''other'' */
int becomewith(int array1, int array2);
int byteSwapped(int w);
int failed(void);
int fullDisplayUpdate(void);
int fullGC(void);
int incrementalGC(void);
int primitiveFail(void);
int showDisplayBitsLeftTopRightBottom(int aForm, int l, int t, int r, int b);
int signalSemaphoreWithIndex(int semaIndex);
int success(int aBoolean);
int superclassOf(int classPointer);
int ioMicroMSecs(void);

/* InterpreterProxy methodsFor: ''BitBlt support'' */
int loadBitBltFrom(int bbOop);
int copyBits(void);
int copyBitsFromtoat(int leftX, int rightX, int yValue);

/* InterpreterProxy methodsFor: ''FFI support'' */
int classExternalAddress(void);
int classExternalData(void);
int classExternalFunction(void);
int classExternalLibrary(void);
int classExternalStructure(void);
int ioLoadModuleOfLength(int moduleNameIndex, int moduleNameLength);
int ioLoadSymbolOfLengthFromModule(int functionNameIndex, int functionNameLength, int moduleHandle);
int isInMemory(int address);

int ioLoadFunctionFrom(char *fnName, char *modName);

struct VirtualMachine *VM = NULL;

static int majorVersion(void) {
	return VM_PROXY_MAJOR;
}

static int minorVersion(void) {
	return VM_PROXY_MINOR;
}

static CompilerHook *compilerHookVector(void) {
  return compilerHooks;
}


struct VirtualMachine* sqGetInterpreterProxy(void)
{
	if(VM) return VM;
	VM = (struct VirtualMachine *) calloc(1, sizeof(VirtualMachine));
	/* Initialize Function pointers */
	VM->majorVersion = majorVersion;
	VM->minorVersion = minorVersion;


	/* InterpreterProxy methodsFor: ''stack access'' */
	VM->pop = pop;
	VM->popthenPush = popthenPush;
	VM->push = push;
	VM->pushBool = pushBool;
	VM->pushFloat = pushFloat;
	VM->pushInteger = pushInteger;
	VM->stackFloatValue = stackFloatValue;
	VM->stackIntegerValue = stackIntegerValue;
	VM->stackObjectValue = stackObjectValue;
	VM->stackValue = stackValue;
	

	/* InterpreterProxy methodsFor: ''object access'' */
	VM->argumentCountOf = argumentCountOf;
	VM->arrayValueOf = arrayValueOf;
	VM->byteSizeOf = byteSizeOf;
	VM->fetchArrayofObject = fetchArrayofObject;
	VM->fetchClassOf = fetchClassOf;
	VM->fetchFloatofObject = fetchFloatofObject;
	VM->fetchIntegerofObject = fetchIntegerofObject;
	VM->fetchPointerofObject = fetchPointerofObject;
	VM->fetchWordofObject = fetchWordofObject;
	VM->firstFixedField = firstFixedField;
	VM->firstIndexableField = firstIndexableField;
	VM->literalofMethod = literalofMethod;
	VM->literalCountOf = literalCountOf;
	VM->methodArgumentCount = methodArgumentCount;
	VM->methodPrimitiveIndex = methodPrimitiveIndex;
	VM->primitiveIndexOf = primitiveIndexOf;
	VM->primitiveMethod = primitiveMethod;
	VM->sizeOfSTArrayFromCPrimitive = sizeOfSTArrayFromCPrimitive;
	VM->slotSizeOf = slotSizeOf;
	VM->stObjectat = stObjectat;
	VM->stObjectatput = stObjectatput;
	VM->stSizeOf = stSizeOf;
	VM->storeIntegerofObjectwithValue = storeIntegerofObjectwithValue;
	VM->storePointerofObjectwithValue = storePointerofObjectwithValue;
	

	/* InterpreterProxy methodsFor: ''testing'' */
	VM->isKindOf = isKindOf;
	VM->isMemberOf = isMemberOf;
	VM->isBytes = isBytes;
	VM->isFloatObject = isFloatObject;
	VM->isIndexable = isIndexable;
	VM->isIntegerObject = isIntegerObject;
	VM->isIntegerValue = isIntegerValue;
	VM->isPointers = isPointers;
	VM->isWeak = isWeak;
	VM->isWords = isWords;
	VM->isWordsOrBytes = isWordsOrBytes;

	/* InterpreterProxy methodsFor: ''converting'' */
	VM->booleanValueOf = booleanValueOf;
	VM->checkedIntegerValueOf = checkedIntegerValueOf;
	VM->floatObjectOf = floatObjectOf;
	VM->floatValueOf = floatValueOf;
	VM->integerObjectOf = integerObjectOf;
	VM->integerValueOf = integerValueOf;
	VM->positive32BitIntegerFor = positive32BitIntegerFor;
	VM->positive32BitValueOf = positive32BitValueOf;

	/* InterpreterProxy methodsFor: ''special objects'' */
	VM->characterTable = characterTable;
	VM->displayObject = displayObject;
	VM->falseObject = falseObject;
	VM->nilObject = nilObject;
	VM->trueObject = trueObject;
	

	/* InterpreterProxy methodsFor: ''special classes'' */
	VM->classArray = classArray;
	VM->classBitmap = classBitmap;
	VM->classByteArray = classByteArray;
	VM->classCharacter = classCharacter;
	VM->classFloat = classFloat;
	VM->classLargePositiveInteger = classLargePositiveInteger;
	VM->classPoint = classPoint;
	VM->classSemaphore = classSemaphore;
	VM->classSmallInteger = classSmallInteger;
	VM->classString = classString;
	

	/* InterpreterProxy methodsFor: ''instance creation'' */
	VM->clone = clone;
	VM->instantiateClassindexableSize = instantiateClassindexableSize;
	VM->makePointwithxValueyValue = makePointwithxValueyValue;
	VM->popRemappableOop = popRemappableOop;
	VM->pushRemappableOop = pushRemappableOop;
	

	/* InterpreterProxy methodsFor: ''other'' */
	VM->becomewith = becomewith;
	VM->byteSwapped = byteSwapped;
	VM->failed = failed;
	VM->fullDisplayUpdate = fullDisplayUpdate;
	VM->fullGC = fullGC;
	VM->incrementalGC = incrementalGC;
	VM->primitiveFail = primitiveFail;
	VM->showDisplayBitsLeftTopRightBottom = showDisplayBitsLeftTopRightBottom;
	VM->signalSemaphoreWithIndex = signalSemaphoreWithIndex;
	VM->success = success;
	VM->superclassOf = superclassOf;

	VM->compilerHookVector= compilerHookVector;
	VM->setCompilerInitialized= setCompilerInitialized;

#if VM_PROXY_MINOR > 1
	/* InterpreterProxy methodsFor: ''BitBlt support'' */
	VM->loadBitBltFrom = loadBitBltFrom;
	VM->copyBits = copyBits;
	VM->copyBitsFromtoat = copyBitsFromtoat;
#endif

#if VM_PROXY_MINOR > 2
	/* InterpreterProxy methodsFor: ''FFI support'' */
	VM->classExternalAddress = classExternalAddress;
	VM->classExternalData = classExternalData;
	VM->classExternalFunction = classExternalFunction;
	VM->classExternalLibrary = classExternalLibrary;
	VM->classExternalStructure = classExternalStructure;
	VM->ioLoadModuleOfLength = ioLoadModuleOfLength;
	VM->ioLoadSymbolOfLengthFromModule = ioLoadSymbolOfLengthFromModule;
	VM->isInMemory = isInMemory;
	VM->signed32BitIntegerFor = signed32BitIntegerFor;
	VM->signed32BitValueOf = signed32BitValueOf;
	VM->includesBehaviorThatOf = includesBehaviorThatOf;
	VM->classLargeNegativeInteger = classLargeNegativeInteger;
#endif

#if VM_PROXY_MINOR > 3
	VM->ioLoadFunctionFrom = ioLoadFunctionFrom;
	VM->ioMicroMSecs = ioMicroMSecs;
#endif

	return VM;
}
'! !

!InterpreterSupportCode class methodsFor: 'source files' stamp: 'ar 5/13/2000 14:57'!
squeakVirtualMachineHeaderFile
^ '#ifndef _SqueakVM_H
#define _SqueakVM_H

/* Increment the following number if you change the order of
   functions listed or if you remove functions */
#define VM_PROXY_MAJOR 1

/* Note: You can define a different VM_PROXY_MINOR if the plugin
   should work with older VMs. */
#ifndef VM_PROXY_MINOR
/* Increment the following number if you add functions at the end */
#define VM_PROXY_MINOR 4
#endif

typedef int (*CompilerHook)();

struct VirtualMachine* sqGetInterpreterProxy(void);

typedef struct VirtualMachine {
	int (*minorVersion) (void);
	int (*majorVersion) (void);


	/* InterpreterProxy methodsFor: ''stack access'' */

	int (*pop)(int nItems);
	int (*popthenPush)(int nItems, int oop);
	int (*push)(int object);
	int (*pushBool)(int trueOrFalse);
	int (*pushFloat)(double f);
	int (*pushInteger)(int integerValue);
	double (*stackFloatValue)(int offset);
	int (*stackIntegerValue)(int offset);
	int (*stackObjectValue)(int offset);
	int (*stackValue)(int offset);
	

	/* InterpreterProxy methodsFor: ''object access'' */

	int (*argumentCountOf)(int methodPointer);
	void * (*arrayValueOf)(int oop);
	int (*byteSizeOf)(int oop);
	void * (*fetchArrayofObject)(int fieldIndex, int objectPointer);
	int (*fetchClassOf)(int oop);
	double (*fetchFloatofObject)(int fieldIndex, int objectPointer);
	int (*fetchIntegerofObject)(int fieldIndex, int objectPointer);
	int (*fetchPointerofObject)(int index, int oop);
	int (*fetchWordofObject)(int fieldIndex, int oop);
	void * (*firstFixedField)(int oop);
	void * (*firstIndexableField)(int oop);
	int (*literalofMethod)(int offset, int methodPointer);
	int (*literalCountOf)(int methodPointer);
	int (*methodArgumentCount)(void);
	int (*methodPrimitiveIndex)(void);
	int (*primitiveIndexOf)(int methodPointer);
	int (*sizeOfSTArrayFromCPrimitive)(void *cPtr);
	int (*slotSizeOf)(int oop);
	int (*stObjectat)(int array, int index);
	int (*stObjectatput)(int array, int index, int value);
	int (*stSizeOf)(int oop);
	int (*storeIntegerofObjectwithValue)(int index, int oop, int integer);
	int (*storePointerofObjectwithValue)(int index, int oop, int valuePointer);
	

	/* InterpreterProxy methodsFor: ''testing'' */

	int (*isKindOf)(int oop, char *aString);
	int (*isMemberOf)(int oop, char *aString);
	int (*isBytes)(int oop);
	int (*isFloatObject)(int oop);
	int (*isIndexable)(int oop);
	int (*isIntegerObject)(int objectPointer);
	int (*isIntegerValue)(int intValue);
	int (*isPointers)(int oop);
	int (*isWeak)(int oop);
	int (*isWords)(int oop);
	int (*isWordsOrBytes)(int oop);
	

	/* InterpreterProxy methodsFor: ''converting'' */

	int (*booleanValueOf)(int obj);
	int (*checkedIntegerValueOf)(int intOop);
	int (*floatObjectOf)(double aFloat);
	double (*floatValueOf)(int oop);
	int (*integerObjectOf)(int value);
	int (*integerValueOf)(int oop);
	int (*positive32BitIntegerFor)(int integerValue);
	int (*positive32BitValueOf)(int oop);
	

	/* InterpreterProxy methodsFor: ''special objects'' */

	int (*characterTable)(void);
	int (*displayObject)(void);
	int (*falseObject)(void);
	int (*nilObject)(void);
	int (*trueObject)(void);
	

	/* InterpreterProxy methodsFor: ''special classes'' */

	int (*classArray)(void);
	int (*classBitmap)(void);
	int (*classByteArray)(void);
	int (*classCharacter)(void);
	int (*classFloat)(void);
	int (*classLargePositiveInteger)(void);
	int (*classPoint)(void);
	int (*classSemaphore)(void);
	int (*classSmallInteger)(void);
	int (*classString)(void);
	

	/* InterpreterProxy methodsFor: ''instance creation'' */

	int (*clone)(int oop);
	int (*instantiateClassindexableSize)(int classPointer, int size);
	int (*makePointwithxValueyValue)(int xValue, int yValue);
	int (*popRemappableOop)(void);
	int (*pushRemappableOop)(int oop);
	

	/* InterpreterProxy methodsFor: ''other'' */

	int (*becomewith)(int array1, int array2);
	int (*byteSwapped)(int w);
	int (*failed)(void);
	int (*fullDisplayUpdate)(void);
	int (*fullGC)(void);
	int (*incrementalGC)(void);
	int (*primitiveFail)(void);
	int (*showDisplayBitsLeftTopRightBottom)(int aForm, int l, int t, int r, int b);
	int (*signalSemaphoreWithIndex)(int semaIndex);
	int (*success)(int aBoolean);
	int (*superclassOf)(int classPointer);

	/* InterpreterProxy methodsFor: ''compiler'' */
	CompilerHook *(*compilerHookVector)(void);
	int (*setCompilerInitialized)(int initFlag);

#if VM_PROXY_MINOR > 1
	/* new for proxy 1.2 */
	/* InterpreterProxy methodsFor: ''BitBlt support'' */
	int (*loadBitBltFrom)(int bbOop);
	int (*copyBits)(void);
	int (*copyBitsFromtoat)(int leftX, int rightX, int yValue);
#endif

#if VM_PROXY_MINOR > 2
	/* New for proxy version 1.3 */
	int (*classLargeNegativeInteger)(void);
	int (*signed32BitIntegerFor)(int integerValue);
	int (*signed32BitValueOf)(int oop);
	int (*includesBehaviorThatOf)(int aClass, int aSuperClass);
	int (*primitiveMethod) (void);

	/* InterpreterProxy methodsFor: ''FFI support'' */
	int (*classExternalAddress)(void);
	int (*classExternalData)(void);
	int (*classExternalFunction)(void);
	int (*classExternalLibrary)(void);
	int (*classExternalStructure)(void);
	int (*ioLoadModuleOfLength)(int modIndex, int modLength);
	int (*ioLoadSymbolOfLengthFromModule)(int fnIndex, int fnLength, int handle);
	int (*isInMemory)(int address);
#endif

#if VM_PROXY_MINOR > 3
	/* New for proxy 1.4 */
	int (*ioLoadFunctionFrom)(char *fnName, char *modName);
	int (*ioMicroMSecs)(void);
#endif

} VirtualMachine;

#endif /* _SqueakVM_H */
'! !


!InterpreterSupportCode class methodsFor: 'compiler' stamp: 'ikp 1/4/1999 01:36'!
comparativeBenchmarks
	"InterpreterSupportCode comparativeBenchmarks"

	Smalltalk compilerDisable.
	self compilerBenchmarks.
	Transcript show: '  interpreted'.
	Smalltalk compilerEnable.
	self compilerBenchmarks.
	Transcript show: '  compiled'.! !

!InterpreterSupportCode class methodsFor: 'compiler' stamp: 'ikp 1/5/1999 03:43'!
compilerBenchmarks
	"InterpreterSupportCode compilerBenchmarks"

	| r t f b |
	f _ SortedCollection new.
	5 timesRepeat:
		[t _ Time millisecondsToRun: [r _ 30 benchFib].
		 f add: r*1000//t].
	b _ SortedCollection new.
	5 timesRepeat:
		[b add: (20000000 * 1000 // (Time millisecondsToRun: [40 benchmark]))].
	Transcript cr; print: f; cr; print: b.
	f _ (f removeFirst; removeLast; inject: 0 into: [:sum :elt | sum + elt]) // f size.
	b _ (b removeFirst; removeLast; inject: 0 into: [:sum :elt | sum + elt]) // b size.
	Transcript cr;
		show: f printString; tab;
		show: b printString! !

!InterpreterSupportCode class methodsFor: 'compiler'!
primitiveTableDeclaration
	"InterpreterSupportCode primitiveTableDeclaration"

	| primitives internal external declared |
	primitives _ Interpreter initialize; primitiveTable.
	internal _ #(
		primitiveBlockCopy primitiveDoPrimitiveWithArgs
		primitivePerform primitivePerformWithArgs
		primitiveValue primitiveValueWithArgs).
	external _ Interpreter primitiveTable reject: [:prim | internal includes: prim].
	declared _ IdentitySet new.
	^String streamContents: [:str |
	str	nextPutAll:	'// generated automatically at ';
		print:		Time now;
		nextPutAll:	' on ';
		print:		Date today;
		cr;
		nextPutAll:	'// DO NOT EDIT!!!!!!';
		cr; cr;
		nextPutAll:	'#define MaxPrimitiveIndex ';
		print:		primitives size - 1;
		cr; cr.
	internal do: [:prim |
		str	nextPutAll: 'extern void ';
			nextPutAll: prim;
			nextPutAll: '(void);'; cr].
	str	cr;
		nextPutAll:	'extern "C" {'; cr;
		nextPutAll:	'  void primitiveFail(void);'; cr.
	external do: [:prim |
	(declared includes: prim)
		ifFalse: [str	nextPutAll: '  void ';
					nextPutAll:	prim;
					nextPutAll: '(void);'; cr].
	declared add: prim].
	str	nextPutAll:	'};'; cr.
	]! !

!InterpreterSupportCode class methodsFor: 'compiler'!
primitiveTableDefinition
	"InterpreterSupportCode primitiveTableDefinition"
	| primitives |
	primitives _ Interpreter initialize; primitiveTable.
	^String streamContents: [:str |
	str	nextPutAll:	'// generated automatically at ';
		print:		Time now;
		nextPutAll:	' on ';
		print:		Date today;
		cr;
		nextPutAll:	'// DO NOT EDIT!!!!!!';
		cr; cr;
		nextPutAll:	'primitive primitiveTable[MaxPrimitiveIndex + 1]= {'; cr.
	primitives doWithIndex: [:prim :index |
		str nextPutAll: '  '; print: prim.
		index == primitives size ifFalse: [str nextPut: $,].
		str cr].
	str	nextPutAll:	'};'; cr.
	]! !


!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 9/19/2000 04:35'!
assertVars: ivars subsumeAll: primList
	| summum |
	summum _ Set new.
	primList valuesDo: [:vars | summum addAll: vars].
	summum removeAll: ivars.
	summum isEmpty ifFalse: [self error: 'unexpected variables in primitive: ' , summum printString].! !

!InterpreterSupportCode class methodsFor: 'compiler-j3'!
externalPrimitives
	"InterpreterSupportCode externalPrimitives"

	| unexported |
	Interpreter initialize.
	unexported _ self unexportedPrimitives.
	^(Interpreter primitiveTable asSet reject: [:sel | Interpreter includesSelector: sel])
		asSortedCollection
		reject: [:prim | unexported includes: prim]! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 9/19/2000 04:30'!
gcReachableFrom: selector
	"Answer whether the given selector can trigger a garbage collection."
	"InterpreterSupportCode gcReachableFrom: #primitiveClass"
	"InterpreterSupportCode gcReachableFrom: #primitiveFullGC"
	"InterpreterSupportCode gcReachableFrom: #primitiveAt"
	"InterpreterSupportCode gcReachableFrom: #primitiveArrayBecome"
	"InterpreterSupportCode gcReachableFrom: #primitiveStoreImageSegment"

	| method messages prevSize |
	method _ Interpreter compiledMethodAt: selector ifAbsent: [^false].
	messages _ (method literals select: [:sel |
					(Interpreter includesSelector: sel) or: [ObjectMemory includesSelector: sel]]) asSet.
	prevSize _ 0.
	[messages size > prevSize] whileTrue:
		[prevSize _ messages size.
		 messages copy do: [:sel |
			method _ Interpreter compiledMethodAt: sel ifAbsent: [ObjectMemory compiledMethodAt: sel].
			messages addAll: (method literals select: [:sel2 |
					(Interpreter includesSelector: sel2) or: [ObjectMemory includesSelector: sel2]])].
		 ((messages includes: #mapPointersInObjectsFrom:to:)
			or: [messages includes: #markAndTraceInterpreterOops]) ifTrue: [^true]].
	^false! !

!InterpreterSupportCode class methodsFor: 'compiler-j3'!
internalPrimitives
	"InterpreterSupportCode internalPrimitives"

	| unexported |
	Interpreter initialize.
	unexported _ self unexportedPrimitives.
	^(Interpreter primitiveTable asSet select: [:sel | Interpreter includesSelector: sel])
		asSortedCollection reject: [:prim | unexported includes: prim].! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 1/10/2000 07:49'!
nextPutExternDeclarations: tricky on: file
	file nextPutAll: 'static const unsigned ArgumentCountBit=	0x01; // prim reads argumentCount'; cr.
	file nextPutAll: 'static const unsigned StackPointerBit=	0x02; // prim reads stackPointer'; cr.
	file nextPutAll: 'static const unsigned SuccessFlagBit=	0x04; // prim writes successFlag'; cr.
	file nextPutAll: 'static const unsigned ActiveFrameBit=	0x08; // prim may cause GC'; cr.
	file nextPutAll: 'static const unsigned IntrinsicPrimBit=	0x10; // prim not exported to j3'; cr.
	file nextPutAll: 'static const unsigned PrimitiveFailBit=	0x20; // prim has no primitive response'; cr.
	file cr.
	file nextPutAll: 'typedef int (*primitive_t)(void);'; cr; cr.
	file nextPutAll: 'extern primitive_t primitiveTable[];'; cr; cr.
	file nextPutAll: 'extern unsigned char primitiveFlags[];'; cr; cr.
	file nextPutAll: '// primitives imported from the Interpreter'; cr; cr.
	file nextPutAll: 'extern "C" {'; cr.
	tricky keysDo: [:prim | file nextPutAll: '  int '; nextPutAll: prim; nextPutAll: '(void);'; cr].
	file nextPutAll: '};'; cr; cr.! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 10/11/2000 19:18'!
nextPutFlagsDefinition: tricky on: file

	| ivars primitives prim |
	ivars _ #(activeFrame argumentCount stackPointer successFlag).
	"Sanity check"
	self assertVars: ivars subsumeAll: tricky.
	primitives _ Interpreter primitiveTable.
	file nextPutAll: 'unsigned char primitiveFlags['; print: primitives size + 1; nextPutAll: ']= {'; cr.
	'scanning for GC reachability...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: primitives size - 1
		during: [:bar |
			0 to: primitives size - 1 do: [:index |
				bar value: index.
				prim _ primitives at: index + 1.
				file nextPutAll: '  0'.
				prim == #primitiveFail
					ifTrue: [file nextPutAll: ' | PrimitiveFailBit']
					ifFalse:
						[(tricky includesKey: prim)
								ifTrue: [(tricky at: prim) do:
											[:var | file nextPutAll: ' | '; nextPutAll: var capitalized; nextPutAll: 'Bit']]
								ifFalse: [file nextPutAll: ' | IntrinsicPrimBit'].
						 (self gcReachableFrom: prim) ifTrue: [file nextPutAll: ' | ActiveFrameBit']].
				file nextPutAll: ',	// '; nextPutAll: prim; cr]].
	file nextPutAll: '  0
};'; cr.! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 1/10/2000 07:49'!
nextPutPrimitiveTable: tricky on: file

	| prims |
	prims _ Interpreter primitiveTable.
	file nextPutAll: 'primitive_t primitiveTable['; print: (prims size + 1); nextPutAll: ']= {'; cr.
	prims do: [:prim |
		file nextPutAll: '  '.
		(tricky includesKey: prim) ifFalse: [file nextPutAll: '(primitive_t)j_'].
		file nextPutAll: prim; nextPut: $,; cr].
	file nextPutAll: '  0'; cr; nextPutAll: '};'; cr.! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 1/10/2000 06:58'!
primitiveHeaderString: tricky			"InterpreterSupportCode primitiveHeaderString: self trickyPrimitiveList"
	"Answer the contents of the primitives.h file."

	^String streamContents: [:file |
		file nextPutAll: '// primitives.h -- primitive characteristics'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// WARNING: this file was generated automatically -- DO NOT EDIT!!'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// Author: Squeak2.7 (on behalf of Ian.Piumarta@INRIA.Fr)'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// Last edited: NEVER (and woebetide anybody who dares to!!)'; cr; cr.
		self nextPutExternDeclarations: tricky on: file.
	]! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 1/10/2000 08:35'!
primitiveImplementationString: tricky	"InterpreterSupportCode primitiveImplementationString: self trickyPrimitiveList"
	"Answer the contents of the primitives.cc file."

	^String streamContents: [:file |
		file nextPutAll: '// primitives.cc -- primitive characteristics'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// WARNING: this file was generated automatically -- DO NOT EDIT!!'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// Author: Squeak2.7 (on behalf of Ian.Piumarta@INRIA.Fr)'; cr;
			nextPutAll: '//'; cr;
			nextPutAll: '// Last edited: NEVER (and woebetide anybody who dares to!!)'; cr; cr;
			nextPutAll: '#include "primitive.h"'; cr; cr.
		self nextPutFlagsDefinition: tricky on: file.
		file cr.
		self nextPutPrimitiveTable: tricky on: file.
	]! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 9/16/2000 19:25'!
selectorsReachableFrom: selector
	"Answer the Set of selectors reachable transitively in Interpreter starting at selector"
	"InterpreterSupportCode selectorsReachableFrom: #primitiveAdd"

	| method messages prevSize |
	method _ Interpreter compiledMethodAt: selector.
	messages _ (method literals select: [:sel | Interpreter includesSelector: sel]) asSet.
	prevSize _ 0.
	[messages size > prevSize] whileTrue:
		[prevSize _ messages size.
		 messages copy do: [:sel |
			method _ Interpreter compiledMethodAt: sel.
			messages addAll: (method literals select: [:sel2 | Interpreter includesSelector: sel2])]].
	^messages add: selector; yourself! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 10/11/2000 19:21'!
trickyPrimitiveList
	"InterpreterSupportCode trickyPrimitiveList"

	| primitives internal method index ivars |
	"Instance variables of Interpreter that we might have to setup before running a primitive"
	ivars _ #(activeContext argumentCount instructionPointer lkupClass messageSelector
			method newMethod primitiveIndex receiver stackPointer successFlag theHomeContext).
	Interpreter initialize.
	primitives _ self internalPrimitives asArray.
	primitives _ IdentityDictionary withAll: ('scanning for reachable methods...' withCRs
		displayProgressAt: Sensor cursorPoint
		from: 1 to: primitives size
		during: [:bar |
			primitives withIndexCollect: [:sel :seq |
				bar value: seq.
				sel -> (self selectorsReachableFrom: sel)]]).
	internal _ Dictionary new.
	('scanning for inst var refs...' withCRs
		displayProgressAt: Sensor cursorPoint
		from: 1 to: ivars size
		during: [:bar |
			ivars withIndexCollect: [:ivar :seq |
				bar value: seq.
				index _ Interpreter allInstVarNames indexOf: ivar.
				ivar -> (primitives select: [:sels |
							nil ~~ (sels detect: [:sel |
											method _ (Interpreter compiledMethodAt: sel).
											(method readsField: index) or: [method writesField: index]]
										ifNone: [nil])]) keys]])
		associationsDo: [:assoc |
			assoc value do: [:sel |
				(internal at: sel ifAbsent: [internal at: sel put: Set new])
					add: assoc key]].
	primitives keysDo: [:sel | (internal includesKey: sel) ifFalse: [internal at: sel put: Set new]].
	internal addAll: (self externalPrimitives collect: [:prim | prim -> #(argumentCount stackPointer successFlag)]).
	(internal at: #primitiveStoreImageSegment) removeAll:
		#(activeContext lkupClass messageSelector method newMethod receiver).
	internal at: #primitiveFlushCache put:
		#(stackPointer activeFrame).
	^(internal associationsDo: [:assoc | assoc value: assoc value asSortedCollection])! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 10/11/2000 19:20'!
unexportedPrimitives
	"Answer an Array containing the names of the primitives that are not exported to j3."
	"InterpreterSupportCode unexportedPrimitives"

	| prims missing |
	prims _ #(primitiveAt primitiveAtPut primitiveBlockCopy primitiveClone
		primitiveDoPrimitiveWithArgs primitiveExternalCall primitiveInstVarAt
		primitiveInstVarAtPut primitiveInstVarsPutFromStack primitiveLoadInstVar
		primitivePerform primitivePerformInSuperclass primitivePerformWithArgs
		primitiveResume primitiveSignal primitiveSize primitiveSnapshot
		primitiveStoreStackp primitiveStringAt primitiveStringAtPut primitiveSuspend
		primitiveValue primitiveValueWithArgs primitiveWait
		primitiveObsoleteIndexedPrimitive).
	missing _ prims reject: [:prim | Interpreter primitiveTable includes: prim].
	missing isEmpty ifFalse: [self error: 'missing primitives: ' , missing printString].
	^prims! !

!InterpreterSupportCode class methodsFor: 'compiler-j3' stamp: 'ikp 1/10/2000 06:58'!
writeCompilerSourceFiles
	"Store into this image's directory the C sources files required to support the runtime compiler."
	"InterpreterSupportCode writeCompilerSourceFiles"

	| tricky |
	tricky _ self trickyPrimitiveList.
	self storeString: (self primitiveHeaderString: tricky)			onFileNamed: 'primitives.h'.
	self storeString: (self primitiveImplementationString: tricky)	onFileNamed: 'primitives.cc'.! !
SequenceableCollection subclass: #Interval
	instanceVariableNames: 'start stop step '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!Interval commentStamp: '<historical>' prior: 0!
I represent a finite arithmetic progression.!


!Interval methodsFor: 'accessing'!
at: anInteger 
	"Answer the anInteger'th element."

	(anInteger >= 1 and: [anInteger <= self size])
		ifTrue: [^start + (step * (anInteger - 1))]
		ifFalse: [self errorSubscriptBounds: anInteger]! !

!Interval methodsFor: 'accessing'!
at: anInteger put: anObject 
	"Storing into an Interval is not allowed."

	self error: 'you can not store into an interval'! !

!Interval methodsFor: 'accessing'!
first 
	"Refer to the comment in SequenceableCollection|first."

	^start! !

!Interval methodsFor: 'accessing' stamp: 'rpj 11/30/1999 11:04'!
includes: aNumber
	"Determine if aNumber is an element of this interval."
	^ (self rangeIncludes: aNumber) and: [ self valuesInclude: aNumber ]! !

!Interval methodsFor: 'accessing'!
increment
	"Answer the receiver's interval increment."

	^step! !

!Interval methodsFor: 'accessing'!
last 
	"Refer to the comment in SequenceableCollection|last."

	^stop - (stop - start \\ step)! !

!Interval methodsFor: 'accessing' stamp: 'di 12/6/1999 11:00'!
rangeIncludes: aNumber
	"Return true if the number lies in the interval between start and stop."

	step >= 0
		ifTrue: [^ aNumber between: start and: stop]
		ifFalse: [^ aNumber between: stop and: start]
! !

!Interval methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:38'!
size
	"Answer how many elements the receiver contains."

	step < 0
		ifTrue: [start < stop
				ifTrue: [^ 0]
				ifFalse: [^ stop - start // step + 1]]
		ifFalse: [stop < start
				ifTrue: [^ 0]
				ifFalse: [^ stop - start // step + 1]]! !


!Interval methodsFor: 'comparing'!
= anInterval 
	"Answer true if my species and anInterval species are equal, and
	if our starts, steps and sizes are equal."

	self species == anInterval species
		ifTrue: [^start = anInterval first
					and: [step = anInterval increment and: [self size = anInterval size]]]
		ifFalse: [^false]! !

!Interval methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^(((start hash bitShift: 2)
		bitOr: stop hash)
		bitShift: 1)
		bitOr: self size! !

!Interval methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Interval methodsFor: 'adding'!
add: newObject 
	"Adding to an Interval is not allowed."

	self shouldNotImplement! !


!Interval methodsFor: 'removing'!
remove: newObject 
	"Removing from an Interval is not allowed."

	self error: 'elements cannot be removed from an Interval'! !


!Interval methodsFor: 'copying'!
copy
	"Return a copy of me. Override the superclass because my species is
	Array and copy, as inherited from SequenceableCollection, uses
	copyFrom:to:, which creates a new object of my species."

	^self shallowCopy! !

!Interval methodsFor: 'copying' stamp: 'sma 3/3/2000 13:18'!
shallowCopy
	"Without this method, #copy would return an array instead of a new interval.
	The whole problem is burried in the class hierarchy and every fix will worsen
	the problem, so once the whole issue is resolved one should come back to this 
	method fix it."

	^ self class from: start to: stop by: step! !


!Interval methodsFor: 'enumerating'!
collect: aBlock
	| nextValue result |
	result _ self species new: self size.
	nextValue _ start.
	1 to: result size do:
		[:i |
		result at: i put: (aBlock value: nextValue).
		nextValue _ nextValue + step].
	^ result! !

!Interval methodsFor: 'enumerating'!
do: aBlock

	| aValue |
	aValue _ start.
	step < 0
		ifTrue: [[stop <= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue + step]]
		ifFalse: [[stop >= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue + step]]! !

!Interval methodsFor: 'enumerating'!
reverseDo: aBlock 
	"Evaluate aBlock for each element of my interval, in reverse order."

	| aValue |
	aValue _ stop.
	step < 0
		ifTrue: [[start >= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]
		ifFalse: [[start <= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]! !


!Interval methodsFor: 'printing' stamp: 'sma 6/1/2000 09:50'!
printOn: aStream
	aStream nextPut: $(;
	 print: start;
	 nextPutAll: ' to: ';
	 print: stop.
	step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step].
	aStream nextPut: $)! !

!Interval methodsFor: 'printing'!
storeOn: aStream 
	"This is possible because we know numbers store and print the same."

	self printOn: aStream! !


!Interval methodsFor: 'private'!
setFrom: startInteger to: stopInteger by: stepInteger

	start _ startInteger.
	stop _ stopInteger.
	step _ stepInteger! !

!Interval methodsFor: 'private'!
species

	^Array! !

!Interval methodsFor: 'private' stamp: 'di 4/24/2000 13:56'!
valuesInclude: aNumber
	"Private - answer whether or not aNumber is one of the enumerated values in this interval."

	| val |
	val _ (aNumber - self first) asFloat / self increment.
	^ val fractionPart abs < (step * 1.0e-10)! !

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

Interval class
	instanceVariableNames: ''!

!Interval class methodsFor: 'instance creation'!
from: startInteger to: stopInteger 
	"Answer an instance of me, starting at startNumber, ending at 
	stopNumber, and with an interval increment of 1."

	^self new
		setFrom: startInteger
		to: stopInteger
		by: 1! !

!Interval class methodsFor: 'instance creation'!
from: startInteger to: stopInteger by: stepInteger 
	"Answer an instance of me, starting at startNumber, ending at 
	stopNumber, and with an interval increment of stepNumber."

	^self new
		setFrom: startInteger
		to: stopInteger
		by: stepInteger! !

!Interval class methodsFor: 'instance creation'!
new
	"Primitive. Create and answer with a new instance of the receiver
	(a class) with no indexable fields. Fail if the class is indexable. Override
	SequenceableCollection new. Essential. See Object documentation
	whatIsAPrimitive."

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

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

	| newInterval |
	newInterval _ self from: aCollection first to: aCollection last by:
		(aCollection last - aCollection first)//(aCollection size - 1).
	aCollection ~= newInterval
		ifTrue: [self error: 'The argument is not an arithmetic progression'].
	^newInterval

"	Interval newFrom: {1. 2. 3}
	{33. 5. -23} as: Interval
	{33. 5. -22} as: Interval    (an error)
	(-4 to: -12 by: -1) as: Interval
"! !
UtteranceVisitor subclass: #IntonationVisitor
	instanceVariableNames: 'functionWords '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!IntonationVisitor methodsFor: 'accessing' stamp: 'len 12/10/1999 02:45'!
functionWords
	^ functionWords! !

!IntonationVisitor methodsFor: 'accessing' stamp: 'len 12/10/1999 02:45'!
functionWords: aCollection
	functionWords _ aCollection! !


!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 02:52'!
clause: aClause
	super clause: aClause.

	self isYesNoQuestionClause ifTrue: [^ clause accent: 'L- H%'].
	self isWHQuestionClause ifTrue: [^ clause accent: '%H H- L%'].
	clause accent: 'L- L%' "it's a declarative phrase"! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/12/1999 22:44'!
isQuestionClause
	^ clause string includes: $?! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 00:07'!
isWHQuestionClause
	| firstWordString |
	self isQuestionClause ifFalse: [^ false].
	firstWordString _ clause phrases first words first string asLowercase.
	^ (firstWordString beginsWith: 'wh') or: [firstWordString = 'how']! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/12/1999 22:45'!
isYesNoQuestionClause
	^ self isQuestionClause and: [self isWHQuestionClause not]! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 03:16'!
phrase: aPhrase
	super phrase: aPhrase.

"	phrase == clause phrases last ifFalse: [phrase accent: 'L- H%']"! !

!IntonationVisitor methodsFor: 'visiting' stamp: 'len 12/14/1999 03:12'!
word: aWord
	| accent |
	super word: aWord.

	((self functionWords includes: word string asLowercase) and: [phrase words first ~~ word]) ifTrue: [^ self].
	self isYesNoQuestionClause ifTrue: [accent _ 'L*'] ifFalse: [accent _ 'H*'].
	(word syllables detect: [ :one | one stress > 0] ifNone: [word syllables first]) accent: accent! !

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

IntonationVisitor class
	instanceVariableNames: ''!

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/13/1999 02:25'!
default
	^ self english! !

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/10/1999 02:41'!
english
	^ self new functionWords: self englishFunctionWords! !

!IntonationVisitor class methodsFor: 'examples' stamp: 'len 12/10/1999 02:41'!
englishFunctionWords
	^ #('a' 'about' 'above' 'across' 'after' 'ago' 'all' 'along' 'although' 'am' 'among'
		'an' 'and' 'any' 'apart' 'are' 'aren''t' 'around' 'as' 'aside' 'at' 'away'
		'back' 'be' 'because' 'been' 'before' 'behind' 'below' 'between' 'both'
		'but' 'by' 'can' 'can''t' 'could' 'couldn''t' 'down' 'each' 'either' 'every'
		'few' 'for' 'forever' 'forward' 'fro' 'from' 'has' 'hasn''t' 'have' 'haven''t'
		'he' 'her' 'here' 'him' 'his' 'home' 'how' 'however' 'i' 'if' 'immediately'
		'in' 'inside' 'is' 'it' 'its' 'least' 'less' 'like' 'little' 'many' 'more' 'most' 'much'
		'my' 'neither' 'no' 'none' 'nor' 'not' 'now' 'of' 'off' 'on' 'once' 'only' 'or'
		'our' 'out' 'outside' 'over' 'part' 'plenty' 'right' 'round' 'several' 'she'
		'should' 'shouldn''t' 'since' 'so' 'some' 'than' 'that' 'the' 'their' 'theirs'
		'then' 'there' 'these' 'they' 'this' 'those' 'though' 'through' 'till' 'to' 'together'
		'unless' 'until' 'up' 'upon' 'was' 'wasn''t' 'we' 'were' 'weren''t' 'what'
		'whatever' 'when' 'where' 'whereas' 'whether' 'which' 'while' 'who' 'whom'
		'whose' 'why' 'will' 'with' 'without' 'would' 'wouldn''t' 'yet' 'you' 'your' 'yours'
	) asSet! !
Object subclass: #JPEGColorComponent
	instanceVariableNames: 'id hSampleFactor vSampleFactor dctSize qTableIndex dcTableIndex acTableIndex widthInBlocks heightInBlocks mcuWidth mcuHeight mcuBlocks currentX currentY priorDCValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGColorComponent commentStamp: '<historical>' prior: 0!
I represent a single component of color in JPEG YCbCr color space.  I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion.  I also store the running DC sample value for my component, used by the Huffman decoder. !


!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'!
acTableIndex

	^acTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:20'!
acTableIndex: anInteger

	acTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:21'!
dcTableIndex

	^dcTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:20'!
dcTableIndex: anInteger

	dcTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
heightInBlocks

	^heightInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:10'!
heightInBlocks: anInteger

	heightInBlocks _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'!
id

	^id! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'!
id: anObject

	id _ anObject! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:29'!
mcuWidth: mw mcuHeight: mh dctSize: ds

	mcuWidth _ mw.
	mcuHeight _ mh.
	dctSize _ ds.
	hSampleFactor _ mcuWidth // widthInBlocks.
	vSampleFactor _ mcuHeight // heightInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:15'!
priorDCValue: aNumber

	priorDCValue _ aNumber! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:43'!
qTableIndex
	^qTableIndex! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
qTableIndex: anInteger

	qTableIndex _ anInteger! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:18'!
totalMcuBlocks

	^ heightInBlocks * widthInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:16'!
updateDCValue: aNumber

	priorDCValue _ priorDCValue + aNumber.
	^priorDCValue! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:11'!
widthInBlocks

	^widthInBlocks! !

!JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:10'!
widthInBlocks: anInteger

	widthInBlocks _ anInteger! !


!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'tao 10/23/97 12:24'!
initializeSampleStreamBlocks: aCollection

	mcuBlocks _ aCollection.
	self resetSampleStream! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'tao 10/23/97 14:23'!
nextSample

	| dx dy blockIndex sampleIndex sample |
	dx _ currentX // hSampleFactor.
	dy _ currentY // vSampleFactor.
	blockIndex _ dy // dctSize * widthInBlocks + (dx // dctSize) + 1.
	sampleIndex _ dy \\ dctSize * dctSize + (dx \\ dctSize) + 1.
	sample _ (mcuBlocks at: blockIndex) at: sampleIndex.
	currentX _ currentX + 1.
	currentX < (mcuWidth * dctSize)
		ifFalse:
			[currentX _ 0.
			currentY _ currentY + 1].
	^ sample! !

!JPEGColorComponent methodsFor: 'sample streaming' stamp: 'tao 10/23/97 12:24'!
resetSampleStream

	currentX _ 0.
	currentY _ 0! !
Object subclass: #JPEGHuffmanTable
	instanceVariableNames: 'bits values mincode maxcode valptr lookaheadBits lookaheadSymbol '
	classVariableNames: 'BitBufferSize Lookahead '
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGHuffmanTable commentStamp: '<historical>' prior: 0!
I represent the table of values used to decode Huffman entropy-encoded bitstreams.  From the JFIF file header entropy values, I build a derived table of codes and values for faster decoding.!


!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/20/97 14:27'!
bits: anObject

	bits _ anObject! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:31'!
lookaheadBits
	^lookaheadBits! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:38'!
lookaheadSymbol
	^lookaheadSymbol! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/21/97 23:59'!
maxcode
	^maxcode! !

!JPEGHuffmanTable methodsFor: 'accessing' stamp: 'tao 10/20/97 14:27'!
values: anObject

	values _ anObject! !


!JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/24/97 12:28'!
makeDerivedTables

	| huffSize huffCode code si index lookbits |
	mincode _ Array new: 16.
	maxcode _ Array new: 17.
	valptr _ Array new: 17.
	huffSize _ OrderedCollection new.
	1 to: 16 do: [:l | 1 to: (bits at: l) do: [:i | huffSize add: l]].
	huffSize add: 0.
	code _ 0.
	huffCode _ Array new: huffSize size.
	si _ huffSize at: 1.
	index _ 1.
	[(huffSize at: index) ~= 0] whileTrue:
		[[(huffSize at: index) = si] whileTrue:
			[huffCode at: index put: code.
			index _ index + 1.
			code _ code + 1].
		code _ code << 1.
		si _ si + 1].

	index _ 1.
	1 to: 16 do:
		[:l |
		(bits at: l) ~= 0
			ifTrue:
				[valptr at: l put: index.
				mincode at: l put: (huffCode at: index).
				index _ index + (bits at: l).
				maxcode at: l put: (huffCode at: index-1)]
			ifFalse:
				[maxcode at: l put: -1]].
	maxcode at: 17 put: 16rFFFFF.

	lookaheadBits _ (Array new: 1 << Lookahead) atAllPut: 0.
	lookaheadSymbol _ Array new: 1 << Lookahead.
	index _ 1.
	1 to: Lookahead do:
		[:l |
		1 to: (bits at: l) do:
			[:i |
			lookbits _ (huffCode at: index) << (Lookahead - l) + 1.
			(1 << (Lookahead - l) to: 1 by: -1) do:
				[:ctr |
				lookaheadBits at: lookbits put: l.
				lookaheadSymbol at: lookbits put: (values at: index).
				lookbits _ lookbits + 1].
			index _ index + 1]]! !

!JPEGHuffmanTable methodsFor: 'computation' stamp: 'tao 10/21/97 22:44'!
valueForCode: code length: length

	^ values at: ((valptr at: length) + code - (mincode at: length))! !

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

JPEGHuffmanTable class
	instanceVariableNames: ''!

!JPEGHuffmanTable class methodsFor: 'initialization' stamp: 'tao 10/21/97 11:06'!
initialize

	Lookahead _ 8.
	BitBufferSize _ 16! !


!JPEGHuffmanTable class methodsFor: 'constants' stamp: 'tao 10/21/97 22:15'!
lookahead

	^ Lookahead! !
ImageReadWriter subclass: #JPEGReadWriter
	instanceVariableNames: 'width height components currentComponents qTable hACTable hDCTable bitBuffer bitsInBuffer lookahead restartInterval restartsToGo mcuWidth mcuHeight mcusPerRow mcuRowsInScan mcuMembership mcuSampleBuffer mcuImageBuffer majorVersion minorVersion dataPrecision densityUnit xDensity yDensity ss se ah al sosSeen redResidual greenResidual blueResidual ditherMask '
	classVariableNames: 'ConstBits DCTK1 DCTK2 DCTK3 DCTK4 DCTSize DCTSize2 DitherMasks FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 FloatSampleOffset HuffmanTableSize JFIFMarkerParser JPEGNaturalOrder MaxSample Pass1Bits QTableScaleFactor QuantizationTableSize SampleOffset '
	poolDictionaries: ''
	category: 'Graphics-Files'!
!JPEGReadWriter commentStamp: '<historical>' prior: 0!
I am a subclass of ImageReadWriter that understands JFIF file streams, and can decode JPEG images.
This code is based upon the Independent Joint Photographic Experts Group (IJPEG) software, originally written in C by Tom Lane, Philip Gladstone, Luis Ortiz, Jim Boucher, Lee Crocker, Julian Minguillon, George Phillips, Davide Rossi, Ge' Weijers, and other members of the Independent JPEG Group.

!


!JPEGReadWriter methodsFor: 'public access' stamp: 'tao 9/18/1998 08:53'!
nextImage

	^ self nextImageDitheredToDepth: Display depth
! !

!JPEGReadWriter methodsFor: 'public access' stamp: 'ar 5/28/2000 12:09'!
nextImageDitheredToDepth: depth

	| form xStep yStep x y |
	ditherMask _ DitherMasks
		at: depth
		ifAbsent: [self error: 'can only dither to display depths'].
	redResidual _ greenResidual _ blueResidual _ 0.
	sosSeen _ false.
	self parseFirstMarker.
	[sosSeen] whileFalse: [self parseNextMarker].
	form _ Form extent: (width @ height) depth: 32.
	xStep _ mcuWidth * DCTSize.
	yStep _ mcuHeight * DCTSize.
	y _ 0.
	1 to: mcuRowsInScan do:
		[:row |
		x _ 0.
		1 to: mcusPerRow do:
			[:col |
			self decodeMCU.
			self idctMCU.
			self colorConvertMCU.
			mcuImageBuffer displayOn: form at: (x @ y).
			x _ x + xStep].
		y _ y + yStep].
	"Fixup the alpha channel in the 32bit form"
	(BitBlt current toForm: form)
		destRect: form boundingBox;
		fillColor: (Bitmap with: 16rFF000000);
		combinationRule: 7; "bitOr:with:"
		copyBits.
		
	^ form! !

!JPEGReadWriter methodsFor: 'public access' stamp: 'tao 10/26/97 21:41'!
setStream: aStream
	"Feed it in from an existing source"

	stream _ aStream! !


!JPEGReadWriter methodsFor: 'preferences' stamp: 'tao 10/26/97 22:09'!
useFloatingPoint

	^ false! !


!JPEGReadWriter methodsFor: 'testing' stamp: 'jm 10/3/1998 08:33'!
understandsImageFormat
	"Answer true if the image stream format is understood by this decoder."

	self next = 16rFF ifFalse: [^ false].
	self next = 16rD8 ifFalse: [^ false].
	^ true
! !


!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/23/97 11:47'!
initialSOSSetup

	mcuWidth _ (components detectMax: [:c | c widthInBlocks]) widthInBlocks.
	mcuHeight _ (components detectMax: [:c | c heightInBlocks]) heightInBlocks.
	components do:
		[:c |
		c mcuWidth: mcuWidth mcuHeight: mcuHeight dctSize: DCTSize].
	hACTable , hDCTable do: [:t | t ifNotNil: [t makeDerivedTables]].
	bitBuffer _ 0.
	bitsInBuffer _ 0.
	lookahead _ JPEGHuffmanTable lookahead.
! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:31'!
okToIgnoreMarker: aMarker

	^ ((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers"
		or: [aMarker = 16rDC or: [aMarker = 16rFE]] "DNL or COM markers"! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/23/97 11:47'!
parseAPPn

	| length buffer thumbnailLength markerStart |
	markerStart _ self position.
	length _ self nextWord.
	buffer _ self next: 4.
	(buffer asString = 'JFIF') ifFalse: [self error: 'APP header is incorrect'].
	self next.
	majorVersion _ self next.
	minorVersion _ self next.
	densityUnit _ self next.
	xDensity _ self nextWord.
	yDensity _ self nextWord.
	thumbnailLength _ self next * self next * 3.
	length _ length - (self position - markerStart).
	length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail length is incorrect.'].
	self next: length! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/20/97 13:36'!
parseDecoderRestartInterval

	| length |
	length _ self nextWord.
	length = 4 ifFalse: [self error: 'DRI length incorrect'].
	restartInterval _ self nextWord.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/20/97 22:31'!
parseFirstMarker

	self next = 16rFF ifFalse: [self error: 'JFIF marker expected'].
	self next = 16rD8 ifFalse: [self error: 'SOI marker expected'].
	self parseStartOfInput.
! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/23/97 11:49'!
parseHuffmanTable

	| length markerStart index bits count huffVal isACTable hTable |
	markerStart _ self position.
	length _ self nextWord.
	[self position - markerStart >= length] whileFalse:
		[index _ self next.
		isACTable _ (index bitAnd: 16r10) ~= 0.
		index _ (index bitAnd: 16r0F) + 1.
		index > HuffmanTableSize
			ifTrue: [self error: 'image has more than ', HuffmanTableSize printString,
				' quantization tables'].
		bits _ self next: 16.
		count _ bits sum.
		(count > 256 or: [(count > (length - (self position - markerStart)))])
			ifTrue: [self error: 'Huffman Table count is incorrect'].
		huffVal _ self next: count.
		(hTable _ JPEGHuffmanTable new)
			bits: bits;
			values: huffVal.
		isACTable
			ifTrue:
				[self hACTable at: index put: hTable]
			ifFalse:
				[self hDCTable at: index put: hTable]].! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:32'!
parseNOP

	"don't need to do anything, here"! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:40'!
parseNextMarker

	| byte discardedBytes |
	discardedBytes _ 0.
	[(byte _ self next) = 16rFF] whileFalse: [ self debug. discardedBytes _ discardedBytes + 1].	
	[[(byte _ self next) = 16rFF] whileTrue. byte = 16r00] whileTrue:
		[discardedBytes _ discardedBytes + 2].
	discardedBytes > 0 ifTrue: [self notify: 'warning: extraneous data discarded'].
	self perform:
		(JFIFMarkerParser
			at: byte
			ifAbsent:
				[(self okToIgnoreMarker: byte)
					ifTrue: [#skipMarker]
					ifFalse: [self error: 'marker ', byte hex , ' cannot be handled']])! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/26/97 21:31'!
parseQuantizationTable

	| length markerStart n prec value table |
	markerStart _ self position.
	length _ self nextWord.
	[self position - markerStart >= length] whileFalse:
		[value _ self next.
		n _ (value bitAnd: 16r0F) + 1.
		prec _ (value >> 4) > 0.
		n > QuantizationTableSize
			 ifTrue: [self error: 'image has more than ',
				QuantizationTableSize printString,
				' quantization tables'].
		table _ Array new: DCTSize2.
		1 to: DCTSize2 do:
			[:i |
			value _ (prec
				ifTrue: [self nextWord]
				ifFalse: [self next]).
			table at: (JPEGNaturalOrder at: i) put: value].
		self useFloatingPoint ifTrue: [self scaleQuantizationTable: table].
		self qTable at: n put: table]! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/24/97 17:07'!
parseStartOfFile

	| length markerStart value n |
	markerStart _ self position.
	length _ self nextWord.
	dataPrecision _ self next.
	dataPrecision = 8
		ifFalse: [self error: 'cannot handle ', dataPrecision printString, '-bit components'].
	height _ self nextWord.
	width _ self nextWord.
	n _ self next.
	(height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty image'].
	(length - (self position - markerStart)) ~= (n * 3)
		ifTrue: [self error: 'component length is incorrect'].
	components _ Array new: n.
	1 to: components size do:
		[:i |
		components
			at: i
			put:
				(JPEGColorComponent new
					id: self next;
					"heightInBlocks: (((value _ self next) >> 4) bitAnd: 16r0F);
					widthInBlocks: (value bitAnd: 16r0F);"
					widthInBlocks: (((value _ self next) >> 4) bitAnd: 16r0F);
					heightInBlocks: (value bitAnd: 16r0F);

					qTableIndex: self next + 1)]! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/22/97 17:38'!
parseStartOfInput

	restartInterval _ 0.
	densityUnit _ 0.
	xDensity _ 1.
	yDensity _ 1
! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/26/97 21:53'!
parseStartOfScan

	| length n id value dcNum acNum comp |
	length _ self nextWord.
	n _ self next.
	(length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length is incorrect'].
	currentComponents _ Array new: n.
	1 to: n do: [:i |
		id _ self next.
		value _ self next.
		dcNum _ (value >> 4) bitAnd: 16r0F.
		acNum _ value bitAnd: 16r0F.
		comp _ components detect: [:c | c id = id].
		comp
			dcTableIndex: dcNum+1;
			acTableIndex: acNum+1.
		currentComponents at: i put: comp].
	ss _ self next.
	se _ self next.
	value _ self next.
	ah _ (value >> 4) bitAnd: 16r0F.
	al _ value bitAnd: 16r0F.
	self initialSOSSetup.
	self perScanSetup.
	sosSeen _ true! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 9/17/1998 01:02'!
perScanSetup

	mcusPerRow _ (width / (mcuWidth * DCTSize)) ceiling.
	mcuRowsInScan _ (height / (mcuHeight * DCTSize)) ceiling.
	(currentComponents size = 3 or: [currentComponents size = 1])
		ifFalse: [self error: 'JPEG color space not recognized'].
	mcuMembership _ OrderedCollection new.
	currentComponents withIndexDo:
		[:c :i |
		c priorDCValue: 0.
		mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [:b | i])].
	mcuSampleBuffer _ (1 to: mcuMembership size) collect: [:i | Array new: DCTSize2].
	currentComponents withIndexDo:
		[:c :i |
			c initializeSampleStreamBlocks:
				((1 to: mcuMembership size)
					select: [:j | i = (mcuMembership at: j)]
					thenCollect: [:j | mcuSampleBuffer at: j])].
	mcuImageBuffer _ Form
		extent: (mcuWidth @ mcuHeight) * DCTSize
		depth: 32.
	restartsToGo _ restartInterval.! !

!JPEGReadWriter methodsFor: 'marker parsing' stamp: 'tao 10/22/97 16:27'!
skipMarker

	| length markerStart |
	markerStart _ self position.
	length _ self nextWord.
	self next: length - (self position - markerStart)
! !


!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/22/97 17:10'!
decodeBlockInto: anArray component: aColorComponent dcTable: huffmanDC acTable: huffmanAC

	| byte i zeroCount |
	byte _ self decodeByteWithTable: huffmanDC.
	byte ~= 0 ifTrue: [byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte].
	byte _ aColorComponent updateDCValue: byte.
	anArray atAllPut: 0.
	anArray at: 1 put: byte.
	i _ 2.
	[i <= DCTSize2] whileTrue:
		[byte _ self decodeByteWithTable: huffmanAC.
		zeroCount _ byte >> 4.
		byte _ byte bitAnd: 16r0F.
		byte ~= 0
			ifTrue:
				[i _ i + zeroCount.
				byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte.
				anArray at:	 (JPEGNaturalOrder at: i) put: byte]
			ifFalse:
				[zeroCount = 15 ifTrue: [i _ i + zeroCount] ifFalse: [^ self]].
		i _ i + 1]
		! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/24/97 20:24'!
decodeByteWithTable: aHuffmanTable

	| look nb length code |
	look _ self peekBits: lookahead.
	(look >= 0 and: [(nb _ aHuffmanTable lookaheadBits at: look+1) ~= 0])
		ifTrue:
			[self getBits: nb.
			^ aHuffmanTable lookaheadSymbol at: look+1].
	length _ 1.
	code _ self getBits: length.
	[code > (aHuffmanTable maxcode at: length)] whileTrue:
		[code _ code << 1 + (self getBits: 1).
		length _ length + 1].
	length > 16 ifTrue: [self error: 'bad encoding value in bit stream'].
	^ aHuffmanTable valueForCode: code length: length.
				! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/23/97 13:50'!
decodeMCU

	| comp |
	(restartInterval ~= 0 and: [restartsToGo = 0]) ifTrue: [self processRestart].
	mcuMembership withIndexDo:
		[:ci :i |
		comp _ currentComponents at: ci.
		self
			decodeBlockInto: (mcuSampleBuffer at: i)
			component: comp
			dcTable: (hDCTable at: comp dcTableIndex)
			acTable: (hACTable at: comp acTableIndex)].
	restartsToGo _ restartsToGo - 1.! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/24/97 20:56'!
fillBuffer

	| byte |
	[bitsInBuffer <= 16]
		whileTrue:
			[byte _ self next.
			(byte = 16rFF and: [(stream peekFor: 16r00) not])
					ifTrue:
						[stream position: stream position - 1.
						^0].
			bitBuffer _ bitBuffer << 8 bitOr: byte.
			bitsInBuffer _ bitsInBuffer + 8].
	^ bitsInBuffer! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/24/97 20:54'!
getBits: requestedBits

	| value |
	requestedBits > bitsInBuffer
		ifTrue:
			[self fillBuffer.
			requestedBits > bitsInBuffer
				ifTrue:
					[self error: 'not enough bits available to decode']].
	value _ bitBuffer >> (bitsInBuffer - requestedBits).
	bitBuffer _ bitBuffer bitAnd: (1 << (bitsInBuffer - requestedBits) -1).
	bitsInBuffer _ bitsInBuffer - requestedBits.
	^ value
		! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/24/97 12:46'!
peekBits: requestedBits

	requestedBits > bitsInBuffer
		ifTrue:
			[self fillBuffer.
			requestedBits > bitsInBuffer ifTrue: [^ -1]].
	^ bitBuffer >> (bitsInBuffer - requestedBits)
		! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/24/97 19:40'!
processRestart

	bitBuffer _ 0.
	bitsInBuffer _ 0.
	self parseNextMarker.
	currentComponents do: [:c | c priorDCValue: 0].
	restartsToGo _ restartInterval.! !

!JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'tao 10/22/97 09:43'!
scaleAndSignExtend: aNumber inFieldWidth: w

	^ aNumber < (1 << (w - 1))
		ifTrue: [aNumber + (1 << w) negated + 1]
		ifFalse: [aNumber]! !


!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 15:16'!
dctFloatRangeLimit: value

	^ (value / 8.0) + FloatSampleOffset.! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 16:34'!
idctBlockFloat: anArray component: aColorComponent

	| t0 t1 t2 t3 t4 t5 t6 t7 t10 t11 t12 t13 z5 z10 z11 z12 z13 qt ws |
	qt _ self qTable at: (aColorComponent qTableIndex).
	ws _ Array new: DCTSize2.

	"Pass 1: process columns from input, store into work array"
	1 to: DCTSize do: [:i |
		t0 _ (anArray at: i) * (qt at: i).
		t1 _ (anArray at: (DCTSize*2 + i)) * (qt at: (DCTSize*2 + i)).
		t2 _ (anArray at: (DCTSize*4 + i)) * (qt at: (DCTSize*4 + i)).
		t3 _ (anArray at: (DCTSize*6 + i)) * (qt at: (DCTSize*6 + i)).
		t10 _ t0 + t2.
		t11 _ t0 - t2.
		t13 _ t1 + t3.
		t12 _ (t1 - t3) * DCTK1 - t13.
		t0 _ t10 + t13.
		t3 _ t10 - t13.
		t1 _ t11 + t12.
		t2 _ t11 - t12.
		t4 _ (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)).
		t5 _ (anArray at: (DCTSize*3 + i)) * (qt at: (DCTSize*3 + i)).
		t6 _ (anArray at: (DCTSize*5 + i)) * (qt at: (DCTSize*5 + i)).
		t7 _ (anArray at: (DCTSize*7 + i)) * (qt at: (DCTSize*7 + i)).
		z13 _ t6 + t5.
		z10 _ t6 - t5.
		z11 _ t4 + t7.
		z12 _ t4 - t7.
		t7 _ z11 + z13.
		t11 _ (z11 - z13) * DCTK1.
		z5 _ (z10 + z12) * DCTK2.
		t10 _ DCTK3 * z12 - z5.
		t12 _ DCTK4 * z10 + z5.
		t6 _ t12 - t7.
		t5 _ t11 - t6.
		t4 _ t10 + t5.
		ws at: i put: t0 + t7.
		ws at: (DCTSize*7 + i) put: t0 - t7.
		ws at: (DCTSize + i) put: t1 + t6.
		ws at: (DCTSize*6 + i) put: t1 - t6.
		ws at: (DCTSize*2 + i) put: t2 + t5.
		ws at: (DCTSize*5 + i) put: t2 - t5.
		ws at: (DCTSize*4 + i) put: t3 + t4.
		ws at: (DCTSize*3 + i) put: t3 - t4].

		"Pass 2: process rows from the workspace"
	(0 to: DCTSize2-DCTSize by: DCTSize) do: [:i |
		t10 _ (ws at: (i+1)) + (ws at: (i+5)).
		t11 _ (ws at: (i+1)) - (ws at: (i+5)).
		t13 _ (ws at: (i+3)) + (ws at: (i+7)).
		t12 _ ((ws at: (i+3)) - (ws at: (i+7))) * DCTK1 - t13.
		t0 _ t10 + t13.
		t3 _ t10 - t13.
		t1 _ t11 + t12.
		t2 _ t11 - t12.
		z13 _ (ws at: (i+6)) + (ws at: (i+4)).
		z10 _ (ws at: (i+6)) - (ws at: (i+4)).
		z11 _ (ws at: (i+2)) + (ws at: (i+8)).
		z12 _ (ws at: (i+2)) - (ws at: (i+8)).
		t7 _ z11 + z13.
		t11 _ (z11 - z13) * DCTK1.
		z5 _ (z10 + z12) * DCTK2.
		t10 _ DCTK3 * z12 - z5.
		t12 _ DCTK4 * z10 + z5.
		t6 _ t12 - t7.
		t5 _ t11 - t6.
		t4 _ t10 + t5.

		"final output stage: scale down by a factor of 8 and range-limit"
		anArray at: (i+1) put: (self dctFloatRangeLimit: (t0 + t7)).
		anArray at: (i+8) put: (self dctFloatRangeLimit: (t0 - t7)).
		anArray at: (i+2) put: (self dctFloatRangeLimit: (t1 + t6)).
		anArray at: (i+7) put: (self dctFloatRangeLimit: (t1 - t6)).
		anArray at: (i+3) put: (self dctFloatRangeLimit: (t2 + t5)).
		anArray at: (i+6) put: (self dctFloatRangeLimit: (t2 - t5)).
		anArray at: (i+5) put: (self dctFloatRangeLimit: (t3 + t4)).
		anArray at: (i+4) put: (self dctFloatRangeLimit: (t3 - t4))]


! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'di 9/15/1998 14:29'!
idctBlockInt: anArray component: aColorComponent

	|  qt ws anACTerm dcval z1 z2 z3 z4 z5 t0 t1 t2 t3 t10 t11 t12 t13 shift |
	qt _ self qTable at: (aColorComponent qTableIndex).
	ws _ Array new: DCTSize2.

	"Pass 1: process columns from anArray, store into work array"
	shift _ 1 bitShift: ConstBits - Pass1Bits.
	1 to: DCTSize do:
		[:i |
		anACTerm _ (1 to: DCTSize-1)
			detect: [:row | (anArray at: (row * DCTSize + i)) ~= 0]
			ifNone: [nil].
		anACTerm isNil
			ifTrue:
				[dcval _ (anArray at: i) * (qt at: 1) bitShift: Pass1Bits.
				(0 to: DCTSize-1) do: [:j | ws at: (j * DCTSize + i) put: dcval]]
			ifFalse:
				[z2 _ (anArray at: (DCTSize * 2 + i)) * (qt at: (DCTSize * 2 + i)).
				z3 _ (anArray at: (DCTSize * 6 + i)) * (qt at: (DCTSize * 6 + i)).
				z1 _ (z2 + z3) * FIXn0n541196100.
				t2 _ z1 + (z3 * FIXn1n847759065 negated).
				t3 _ z1 + (z2 * FIXn0n765366865).
				z2 _ (anArray at: i) * (qt at: i).
				z3 _ (anArray at: (DCTSize * 4 + i)) * (qt at: (DCTSize * 4 + i)).
				t0 _ (z2 + z3) bitShift: ConstBits.
				t1 _ (z2 - z3) bitShift: ConstBits.
				t10 _ t0 + t3.
				t13 _ t0 - t3.
				t11 _ t1 + t2.
				t12 _ t1 - t2.
				t0 _ (anArray at: (DCTSize * 7 + i)) * (qt at: (DCTSize * 7 + i)).
				t1 _ (anArray at: (DCTSize * 5 + i)) * (qt at: (DCTSize * 5 + i)).
				t2 _ (anArray at: (DCTSize * 3 + i)) * (qt at: (DCTSize * 3 + i)).
				t3 _ (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)).
				z1 _ t0 + t3.
				z2 _ t1 + t2.
				z3 _ t0 + t2.
				z4 _ t1 + t3.
				z5 _ (z3 + z4) * FIXn1n175875602.
				t0 _ t0 * FIXn0n298631336.
				t1 _ t1 * FIXn2n053119869.
				t2 _ t2 * FIXn3n072711026.
				t3 _ t3 * FIXn1n501321110.
				z1 _ z1 * FIXn0n899976223 negated.
				z2 _ z2 * FIXn2n562915447 negated.
				z3 _ z3 * FIXn1n961570560 negated.
				z4 _ z4 * FIXn0n390180644 negated.
				z3 _ z3 + z5.
				z4 _ z4 + z5.
				t0 _ t0 + z1 + z3.
				t1 _ t1 +z2 +z4.
				t2 _ t2 + z2 + z3.
				t3 _ t3 + z1 + z4.
				ws at: i put: (t10 + t3) >> (ConstBits - Pass1Bits).
				ws at: (DCTSize * 7 + i) put: (t10 - t3) // shift.
				ws at: (DCTSize * 1 + i) put: (t11 + t2) // shift.
				ws at: (DCTSize * 6 + i) put: (t11 - t2) // shift.
				ws at: (DCTSize * 2 + i) put: (t12 + t1) // shift.
				ws at: (DCTSize * 5 + i) put: (t12 - t1) // shift.
				ws at: (DCTSize * 3 + i) put: (t13 + t0) // shift.
				ws at: (DCTSize * 4 + i) put: (t13 - t0) // shift]].

	"Pass 2: process rows from work array, store back into anArray"
	shift _ 1 bitShift: ConstBits + Pass1Bits + 3.
	(0 to: DCTSize2-DCTSize by: DCTSize) do:
		[:i |
		z2 _ ws at: i + 3.
		z3 _ ws at: i + 7.
		z1 _ (z2 + z3) * FIXn0n541196100.
		t2 _ z1 + (z3 * FIXn1n847759065 negated).
		t3 _ z1 + (z2 * FIXn0n765366865).
		t0 _ (ws at: (i + 1)) + (ws at: (i + 5)) bitShift: ConstBits.
		t1 _ (ws at: (i + 1)) - (ws at: (i + 5)) bitShift: ConstBits.
		t10 _ t0 + t3.
		t13 _ t0 - t3.
		t11 _ t1 + t2.
		t12 _ t1 -t2.
		t0 _ ws at: (i + 8).
		t1 _ ws at: (i + 6).
		t2 _ ws at: (i + 4).
		t3 _ ws at: (i + 2).
		z1 _ t0 + t3.
		z2 _ t1 + t2.
		z3 _ t0 + t2.
		z4 _ t1 + t3.
		z5 _ (z3 + z4) * FIXn1n175875602.
		t0 _ t0 * FIXn0n298631336.
		t1 _ t1 * FIXn2n053119869.
		t2 _ t2 * FIXn3n072711026.
		t3 _ t3 * FIXn1n501321110.
		z1 _ z1 * FIXn0n899976223 negated.
		z2 _ z2 * FIXn2n562915447 negated.
		z3 _ z3 * FIXn1n961570560 negated.
		z4 _ z4 * FIXn0n390180644 negated.
		z3 _ z3 + z5.
		z4 _ z4 + z5.
		t0 _ t0 + z1 + z3.
		t1 _ t1 + z2 + z4.
		t2 _ t2 + z2 + z3.
		t3 _ t3 + z1 + z4.
		anArray at: (i + 1) put: (self sampleRangeLimit: (t10 + t3) // shift + SampleOffset).
		anArray at: (i + 8) put: (self sampleRangeLimit: (t10 - t3) // shift + SampleOffset).
		anArray at: (i + 2) put: (self sampleRangeLimit: (t11 + t2) // shift + SampleOffset).
		anArray at: (i + 7) put: (self sampleRangeLimit: (t11 - t2) // shift + SampleOffset).
		anArray at: (i + 3) put: (self sampleRangeLimit: (t12 + t1) // shift + SampleOffset).
		anArray at: (i + 6) put: (self sampleRangeLimit: (t12 - t1) // shift + SampleOffset).
		anArray at: (i + 4) put: (self sampleRangeLimit: (t13 + t0) // shift + SampleOffset).
		anArray at: (i + 5) put: (self sampleRangeLimit: (t13 - t0) // shift + SampleOffset)].


! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 21:25'!
idctMCU

	| comp |
	self useFloatingPoint
		ifTrue:
			[mcuMembership withIndexDo:
				[:ci :i |
				comp _ currentComponents at: ci.
				self idctBlockFloat: (mcuSampleBuffer at: i) component: comp]]
		ifFalse:
			[mcuMembership withIndexDo:
				[:ci :i |
				comp _ currentComponents at: ci.
				self idctBlockInt: (mcuSampleBuffer at: i) component: comp]]
! !

!JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 16:16'!
scaleQuantizationTable: table

	| index |

	index _ 1.
	1 to: DCTSize do:
		[:row |
		1 to: DCTSize do:
			[:col |
			table at: index
				put: ((table at: index) * (QTableScaleFactor at: row) *
					(QTableScaleFactor at: col)) rounded.
			index _ index + 1]].
	^ table
! !


!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 18:53'!
colorConvertFloatYCbCrMCU

	| ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits |
	ySampleStream _ currentComponents at: 1.
	cbSampleStream _ currentComponents at: 2.
	crSampleStream _ currentComponents at: 3.
	ySampleStream resetSampleStream.
	cbSampleStream resetSampleStream.
	crSampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ ySampleStream nextSample.
		cb _ cbSampleStream nextSample - FloatSampleOffset.
		cr _ crSampleStream nextSample - FloatSampleOffset.
		red _ self sampleFloatRangeLimit: (y + (1.40200 * cr)).
		green _ self sampleFloatRangeLimit: (y - (0.34414 * cb) - (0.71414 * cr)).
		blue _ self sampleFloatRangeLimit: (y + (1.77200 * cb)).
		bits at: i put: (red << 16) + (green << 8) + blue].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 9/17/1998 00:55'!
colorConvertGrayscaleMCU

	| ySampleStream y bits |
	ySampleStream _ currentComponents at: 1.
	ySampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ (ySampleStream nextSample) + greenResidual.
		y > MaxSample ifTrue: [y _ MaxSample].
		greenResidual _ y bitAnd: ditherMask.
		y _ y bitAnd: MaxSample - ditherMask.
		y < 1 ifTrue: [y _ 1].
		bits at: i put: (y<<16) + (y<<8) + y].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 9/17/1998 00:58'!
colorConvertIntYCbCrMCU

	| ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits |
	ySampleStream _ currentComponents at: 1.
	cbSampleStream _ currentComponents at: 2.
	crSampleStream _ currentComponents at: 3.
	ySampleStream resetSampleStream.
	cbSampleStream resetSampleStream.
	crSampleStream resetSampleStream.
	bits _ mcuImageBuffer bits.
	1 to: bits size do:
		[:i |
		y _ ySampleStream nextSample.
		cb _ cbSampleStream nextSample - SampleOffset.
		cr _ crSampleStream nextSample - SampleOffset.
		red _ y + ((FIXn1n40200 * cr) // 65536) + redResidual.
		red > MaxSample
			ifTrue: [red _ MaxSample]
			ifFalse: [red < 0 ifTrue: [red _ 0]].
		redResidual _ red bitAnd: ditherMask.
		red _ red bitAnd: MaxSample - ditherMask.
		red < 1 ifTrue: [red _ 1].
		green _ y - ((FIXn0n34414 * cb) // 65536) -
			((FIXn0n71414 * cr) // 65536) + greenResidual.
		green > MaxSample
			ifTrue: [green _ MaxSample]
			ifFalse: [green < 0 ifTrue: [green _ 0]].
		greenResidual _ green bitAnd: ditherMask.
		green _ green bitAnd: MaxSample - ditherMask.
		green < 1 ifTrue: [green _ 1].
		blue _ y + ((FIXn1n77200 * cb) // 65536) + blueResidual.
		blue > MaxSample
			ifTrue: [blue _ MaxSample]
			ifFalse: [blue < 0 ifTrue: [blue _ 0]].
		blueResidual _ blue bitAnd: ditherMask.
		blue _ blue bitAnd: MaxSample - ditherMask.
		blue < 1 ifTrue: [blue _ 1].
		bits at: i put: (red bitShift: 16) + (green bitShift: 8) + blue].
	! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 21:27'!
colorConvertMCU

	^ currentComponents size = 3
		ifTrue:
			[self useFloatingPoint
				ifTrue: [self colorConvertFloatYCbCrMCU]
				ifFalse: [self colorConvertIntYCbCrMCU]]
		ifFalse: [self colorConvertGrayscaleMCU]! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 15:43'!
sampleFloatRangeLimit: aNumber

	^ (aNumber rounded max: 0) min: MaxSample! !

!JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'di 9/15/1998 14:30'!
sampleRangeLimit: aNumber

	aNumber < 0 ifTrue: [^ 0].
	aNumber > MaxSample ifTrue: [^ MaxSample].
	^ aNumber! !


!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 13:46'!
hACTable

	hACTable ifNil: [hACTable _ Array new: HuffmanTableSize].
	^ hACTable! !

!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 13:46'!
hDCTable

	hDCTable ifNil: [hDCTable _ Array new: HuffmanTableSize].
	^ hDCTable! !

!JPEGReadWriter methodsFor: 'accessing' stamp: 'tao 10/19/97 08:46'!
qTable

	qTable ifNil: [qTable _ Array new: QuantizationTableSize].
	^ qTable! !


!JPEGReadWriter methodsFor: 'error handling' stamp: 'tao 10/19/97 12:25'!
notSupported: aString

	self error: aString , ' is not currently supported'! !

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

JPEGReadWriter class
	instanceVariableNames: ''!

!JPEGReadWriter class methodsFor: 'initialization' stamp: 'tao 9/18/1998 09:06'!
initialize

	"general constants"
	DCTSize _ 8.
	MaxSample _ (2 raisedToInteger: DCTSize) - 1.
	SampleOffset _ MaxSample // 2.
	FloatSampleOffset _ SampleOffset asFloat.
	DCTSize2 _ DCTSize squared.
	QuantizationTableSize _ 4.
	HuffmanTableSize _ 4.

	"floating-point Inverse Discrete Cosine Transform (IDCT) constants"
	ConstBits _ 13.
	Pass1Bits _ 2.
	DCTK1 _ 2 sqrt.
	DCTK2 _ 1.847759065.
	DCTK3 _ 1.082392200.
	DCTK4 _ -2.613125930.

	"fixed-point Inverse Discrete Cosine Transform (IDCT) constants"
	FIXn0n298631336 _ 2446.
	FIXn0n390180644 _ 3196.
	FIXn0n541196100 _ 4433.
	FIXn0n765366865 _ 6270.
	FIXn0n899976223 _ 7373.
	FIXn1n175875602 _ 9633.
	FIXn1n501321110 _ 12299.
	FIXn1n847759065 _ 15137.
	FIXn1n961570560 _ 16069.
	FIXn2n053119869 _ 16819.
	FIXn2n562915447 _ 20995.
	FIXn3n072711026 _ 25172.

	"fixed-point color conversion constants"
	FIXn0n34414 _ 22554.
	FIXn0n71414 _ 46802.
	FIXn1n40200 _ 91881.
	FIXn1n77200 _  116130.

	"reordering table from JPEG zig-zag order"
	JPEGNaturalOrder _ #(
		1 2 9 17 10 3 4 11
		18 25 33 26 19 12 5 6
		13 20 27 34 41 49 42 35
		28 21 14 7 8 15 22 29
		36 43 50 57 58 51 44 37
		30 23 16 24 31 38 45 52
		59 60 53 46 39 32 40 47
		54 61 62 55 48 56 63 64).

	"scale factors for the values in the Quantization Tables"
	QTableScaleFactor _ (0 to: DCTSize-1) collect:
		[:k | k = 0
			ifTrue: [1.0]
			ifFalse: [(k * Float pi / 16) cos * 2 sqrt]].

	"dithering masks"
	(DitherMasks _ Dictionary new)
		add: 0 -> 0;
		add: 1 -> 127;
		add: 2 -> 63;
		add: 4 -> 63;
		add: 8 -> 31;
		add: 16 -> 7;
		add: 32 -> 0.

	"dictionary of marker parsers"
	(JFIFMarkerParser _ Dictionary new)
		add: (16r01 -> #parseNOP);
		add: (16rC0 -> #parseStartOfFile);
		add: (16rC4 -> #parseHuffmanTable);
		addAll: ((16rD0 to: 16rD7) collect: [:m | Association key: m value: #parseNOP]);
		add: (16rD8 -> #parseStartOfInput);
		add: (16rD9 -> #parseEndOfInput);
		add: (16rDA -> #parseStartOfScan);
		add: (16rDB -> #parseQuantizationTable);
		add: (16rDD -> #parseDecoderRestartInterval);
		add: (16rE0 -> #parseAPPn);
		add: (16rE1 -> #parseAPPn)! !
SketchMorph subclass: #JoystickMorph
	instanceVariableNames: 'handleMorph xScale yScale radiusScale lastAngle autoCenter realJoystickIndex lastRealJoystickValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!JoystickMorph methodsFor: 'initialization' stamp: 'jm 11/18/97 14:26'!
initialize

	super initialize.
	xScale _ 0.25.
	yScale _ 0.25.
	radiusScale _ 1.0.
	lastAngle _ 0.0.
	autoCenter _ true.
	self form: ((Form extent: 55@55 depth: 8) fillColor: (Color r: 0.3 g: 0.2 b: 0.2)).
	handleMorph _ EllipseMorph new.
	handleMorph color: Color red; extent: 15@15.
	self addMorph: handleMorph.
	self moveHandleToCenter.
! !


!JoystickMorph methodsFor: 'accessing'!
amount

	^ (handleMorph center - self center) r * radiusScale! !

!JoystickMorph methodsFor: 'accessing'!
angle

	self center = handleMorph center ifTrue: [^ lastAngle].
	^ 360.0 - (handleMorph center - self center) theta radiansToDegrees! !

!JoystickMorph methodsFor: 'accessing'!
leftRight

	^ (handleMorph center x - self center x) * xScale
! !

!JoystickMorph methodsFor: 'accessing' stamp: 'jm 1/19/98 20:48'!
upDown

	^ (self center y - handleMorph center y) * yScale
! !


!JoystickMorph methodsFor: 'other' stamp: 'sw 5/11/1998 13:51'!
handlesMouseDown: evt

	self inPartsBin ifTrue: [^ false].

	true ifTrue: [^ true].  "5/7/98 jhm temporary fix to allow use when rotated"

	(handleMorph fullContainsPoint: evt cursorPoint)
		ifTrue: [^ true]
		ifFalse: [^ super handlesMouseDown: evt].
! !

!JoystickMorph methodsFor: 'other'!
mouseMove: evt
	"Make handle track the cursor within my bounds."

	| m r center |
	m _ handleMorph.
	center _ m center.
	r _ m owner innerBounds insetBy:
		((center - m fullBounds origin) corner: (m fullBounds corner - center)).
	m position: (evt cursorPoint adhereTo: r) - (m extent // 2).
! !

!JoystickMorph methodsFor: 'other' stamp: 'jm 11/18/97 14:26'!
mouseUp: evt

	lastAngle _ self angle.
	autoCenter ifTrue: [self moveHandleToCenter].
! !

!JoystickMorph methodsFor: 'other'!
moveHandleToCenter

	handleMorph position: self center - (handleMorph extent // 2).
! !


!JoystickMorph methodsFor: 'stepping' stamp: 'sw 8/13/1999 14:03'!
step
	"Track the real joystick whose index is realJoystickIndex."
	"Details:
	  a. if realJoystickIndex is nil we're not tracking a joystick
	  b. [-joyMax..joyMax] is nominal range of joystick in both X and Y
	  c. [-threshold..threshold] is considered 0 to compensate for poor joystick centering"

	| threshold joyMax joyPt m mCenter r scaledPt |
	super step.  "Run ticking user-written scripts if any"
	realJoystickIndex ifNil: [^ self].
	threshold _ 30.
	joyMax _ 350.
	joyPt _ Sensor joystickXY: realJoystickIndex.
	joyPt x abs < threshold ifTrue: [joyPt _ 0@joyPt y].
	joyPt y abs < threshold ifTrue: [joyPt _ joyPt x@0].
	lastRealJoystickValue = joyPt ifTrue: [^ self].
	lastRealJoystickValue _ joyPt.
	m _ handleMorph.
	mCenter _ m center.
	r _ m owner innerBounds insetBy:
		((mCenter - m fullBounds origin) corner: (m fullBounds corner - mCenter)).
	scaledPt _ r center + ((r extent * joyPt) / (joyMax * 2)) truncated.
	m position: (scaledPt adhereTo: r) - (m extent // 2).
! !

!JoystickMorph methodsFor: 'stepping' stamp: 'sw 8/13/1999 14:00'!
stepTime
	^ realJoystickIndex
		ifNil:
			[0]  "fast as we can to track actual joystick"
		ifNotNil:
			[super stepTime]
! !


!JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:19'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'set X range' action: #setXRange.
	aCustomMenu add: 'set Y range' action: #setYRange.
	autoCenter
		ifTrue: [aCustomMenu add: 'turn auto-center off' action: #toggleAutoCenter]
		ifFalse: [aCustomMenu add: 'turn auto-center on' action: #toggleAutoCenter].
	realJoystickIndex
		ifNil: [aCustomMenu add: 'track real joystick' action: #trackRealJoystick]
		ifNotNil: [aCustomMenu add: 'stop tracking joystick' action: #stopTrackingJoystick].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 11/18/97 14:51'!
setXRange

	| range |
	range _ FillInTheBlank
		request:
'Type the maximum value for the X axis'
		initialAnswer: ((xScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString.
	range isEmpty ifFalse: [
		xScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 11/18/97 14:52'!
setYRange

	| range |
	range _ FillInTheBlank
		request:
'Type the maximum value for the Y axis'
		initialAnswer: ((yScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString.
	range isEmpty ifFalse: [
		yScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:24'!
stopTrackingJoystick

	realJoystickIndex _ nil.
	self stopStepping.
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 11/18/97 14:33'!
toggleAutoCenter

	autoCenter _ autoCenter not.
	autoCenter ifTrue: [self moveHandleToCenter].
! !

!JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:59'!
trackRealJoystick

	| s |
	s _ FillInTheBlank
		request: 'Number of joystick to track?'
		initialAnswer: '1'.
	s isEmpty ifTrue: [^ self].
	realJoystickIndex _ Number readFromString: s.
	self startStepping.
! !

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

JoystickMorph class
	instanceVariableNames: ''!

!JoystickMorph class methodsFor: 'scripting' stamp: 'sw 9/8/2000 15:35'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((joystick (
(slot amount 'The amount of displacement' number readOnly player getAmount unused unused)
(slot angle 'The angular displacement' number readOnly player getAngle  unused  unused)
(slot leftRight  'The horizontal displacement' number  readOnly player getLeftRight  unused  unused)
(slot upDown 'The vertical displacement' number  readOnly player getUpDown unused unused))))


! !

!JoystickMorph class methodsFor: 'scripting' stamp: 'sw 11/5/97 12:04'!
authoringPrototype
	^ self new markAsPartsDonor! !


!JoystickMorph class methodsFor: 'new morph menu' stamp: 'sw 4/26/1999 16:02'!
includeInNewMorphMenu
	^ true! !
TestInterpreterPlugin subclass: #JoystickTabletPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!JoystickTabletPlugin commentStamp: '<historical>' prior: 0!
This plugin implements the interface to the joystick and tablet input devices, if you have one.!


!JoystickTabletPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:53'!
initialiseModule
	self export: true.
	^self cCode: 'joystickInit()' inSmalltalk:[true]! !

!JoystickTabletPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:55'!
shutdownModule
	self export: true.
	^self cCode: 'joystickShutdown()' inSmalltalk:[true]! !


!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 18:54'!
primitiveGetTabletParameters: cursorIndex
	"Get information on the pen tablet attached to this machine. Fail if there is no tablet. If successful, the result is an array of integers; see the Smalltalk call on this primitive for its interpretation."

	| resultSize result resultPtr |
	self var: #resultPtr declareC: 'int * resultPtr'.
	self primitive: 'primitiveGetTabletParameters'
		parameters: #(SmallInteger).
	resultSize _ self tabletResultSize.
	result _ interpreterProxy instantiateClass: interpreterProxy classBitmap indexableSize: resultSize.
	resultPtr _ result asIntPtr.
	interpreterProxy success: (self cCode: 'tabletGetParameters(cursorIndex, resultPtr)').
	^result! !

!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:33'!
primitiveReadJoystick: index
	"Read an input word from the joystick with the given index."

	self primitive: 'primitiveReadJoystick'
		parameters: #(SmallInteger).
	^(self joystickRead: index) asPositiveIntegerObj! !

!JoystickTabletPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 18:56'!
primitiveReadTablet: cursorIndex
	"Get the current state of the cursor of the pen tablet specified by my argument. Fail if there is no tablet. If successful, the result is an array of integers; see the Smalltalk call on this primitive for its interpretation."

	| resultSize result resultPtr|
	self var: #resultPtr declareC: 'int * resultPtr'.
	self primitive: 'primitiveReadTablet'
		parameters: #(SmallInteger).
	resultSize _ self tabletResultSize.
	result _ interpreterProxy instantiateClass: interpreterProxy classBitmap indexableSize: resultSize.
	resultPtr _ result asIntPtr.
	interpreterProxy success: (self cCode: 'tabletRead(cursorIndex, resultPtr)').
	^result! !

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

JoystickTabletPlugin class
	instanceVariableNames: ''!

!JoystickTabletPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:20'!
headerFile
^'/* joystick support */

/* module initialization/shutdown */
int joystickInit(void);
int joystickShutdown(void);

int joystickRead(int stickIndex);
/*** tablet support ***/
int tabletGetParameters(int cursorIndex, int result[]);
int tabletRead(int cursorIndex, int result[]);
int tabletResultSize(void);
'! !
SelectorNode subclass: #KeyWordNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!KeyWordNode commentStamp: '<historical>' prior: 0!
I am a part of a selector.   #at:put: is owned by a SelectorNode, and #put: within it is owned by a KeyWordNode.!

Object subclass: #KeyboardBuffer
	instanceVariableNames: 'event eventUsed '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:53'!
commandKeyPressed
	^ event commandKeyPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:54'!
controlKeyPressed
	^ event controlKeyPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
flushKeyboard
	eventUsed ifFalse: [^ eventUsed _ true].! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
keyboard
	eventUsed ifFalse: [eventUsed _ true.  ^ event keyCharacter].
	^ nil! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/29/97 12:34'!
keyboardPeek
	eventUsed ifFalse: [^ event keyCharacter].
	^ nil! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 4/27/1999 21:49'!
keyboardPressed

	| evt |
	eventUsed ifFalse: [^ true].
	(evt _ event hand checkForMoreKeyboard) ifNil: [^ false].
	event _ evt.
	eventUsed _ false.
	^ true! !

!KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 9/30/97 19:54'!
leftShiftDown
	^ event shiftPressed! !

!KeyboardBuffer methodsFor: 'as yet unclassified'!
startingEvent: evt
	event _ evt.
	eventUsed _ false! !
UserInputEvent subclass: #KeyboardEvent
	instanceVariableNames: 'keyValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyDown
	^self type == #keyDown! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyUp
	^self type == #keyUp! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeyboard
	^true! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'!
isKeystroke
	^self type == #keystroke! !

!KeyboardEvent methodsFor: 'testing' stamp: 'ar 10/9/2000 00:43'!
isMouseMove
	^false! !


!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 10/24/2000 17:44'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	keyValue = aMorphicEvent keyValue ifFalse: [^ false].
	^ true
! !

!KeyboardEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:50'!
hash
	^buttons hash + keyValue hash
! !


!KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'!
keyCharacter
	"Answer the character corresponding this keystroke. This is defined only for keystroke events."

	^ keyValue asCharacter! !

!KeyboardEvent methodsFor: 'keyboard' stamp: 'ar 9/13/2000 15:51'!
keyValue
	"Answer the ascii value for this keystroke. This is defined only for keystroke events."

	^ keyValue! !


!KeyboardEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:13'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #keystroke ifTrue:[^anObject handleKeystroke: self].
	type == #keyDown ifTrue:[^anObject handleKeyDown: self].
	type == #keyUp ifTrue:[^anObject handleKeyUp: self].
	^super sentTo: anObject.! !


!KeyboardEvent methodsFor: 'printing' stamp: 'ar 9/13/2000 15:51'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: type.
	self controlKeyPressed ifTrue: [
		aStream nextPutAll: ' ''^'.
		aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter.
	] ifFalse: [
		aStream nextPutAll: ' '''.
		aStream nextPut: self keyCharacter.
	].
	aStream nextPut: $'.
	aStream nextPut: $].! !

!KeyboardEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:07'!
storeOn: aStream

	aStream nextPutAll: type.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	buttons storeOn: aStream.
	aStream space.
	keyValue storeOn: aStream.
! !


!KeyboardEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:54'!
setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp
	type _ aSymbol.
	buttons _ anInteger.
	position _ pos.
	keyValue _ aValue.
	source _ aHand.
	wasHandled _ false.
	timeStamp _ stamp.! !

!KeyboardEvent methodsFor: 'private' stamp: 'ar 10/25/2000 22:08'!
type: eventType readFrom: aStream
	type _ eventType.
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	buttons _ Integer readFrom: aStream.
	aStream skip: 1.
	keyValue _ Integer readFrom: aStream.! !


!KeyboardEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:31'!
decodeFromStringArray: array
	"decode the receiver from an array of strings"
	type _ array first asSymbol.
	position _ CanvasDecoder decodePoint: (array at: 2).
	buttons _ CanvasDecoder decodeInteger: (array at: 3).
	keyValue _ CanvasDecoder decodeInteger: (array at: 4).
! !

!KeyboardEvent methodsFor: 'encoding' stamp: 'ar 10/9/2000 00:14'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodeInteger: keyValue asInteger
	}! !
PianoKeyboardMorph subclass: #KeyboardMorphForInput
	instanceVariableNames: 'pianoRoll duration durationModifier articulation buildingChord insertMode prevSelection startOfNextNote '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!KeyboardMorphForInput commentStamp: '<historical>' prior: 0!
This class adds state and controls to the basic PianoKeyboardMorph so that notes of reliable duration can be keyed into a score without the need for a real keyboard.

To try this out, execute...

	| n score | n _ 3.
	score _ (MIDIScore new tracks: ((1 to: n) collect: [:i | Array new]);
		trackInfo: ((1 to: n) collect: [:i | 'Instrument' , i printString]);
		tempoMap: nil; ticksPerQuarterNote: 96).
	ScorePlayerMorph openOn: score title: 'empty score'

Then open a pianoRoll and, from that, open a keyboard.  The rule is that the keyboard will append after the current selection.  If the current selection is muted or nil, then input will go to the end of the first non-muted track.!


!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:41'!
addRecordingControls

	| button switch playRow durRow articRow modRow |
	button _ SimpleButtonMorph new target: self;
		borderColor: #raised; borderWidth: 2; color: color.
	switch _ SimpleSwitchMorph new target: self;
		offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2;
		setSwitchState: false.

	"Add chord, rest and delete buttons"
	playRow _ AlignmentMorph newRow.
	playRow color: color; borderWidth: 0; layoutInset: 0.
	playRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	playRow addMorphBack: (switch fullCopy label: 'chord'; actionSelector: #buildChord:).
	playRow addMorphBack: (button fullCopy label: '          rest          '; actionSelector: #emitRest).
	playRow addMorphBack: (button fullCopy label: 'del'; actionSelector: #deleteNotes).
	self addMorph: playRow.
	playRow align: playRow bounds topCenter
			with: self bounds bottomCenter.

	"Add note duration buttons"
	durRow _ AlignmentMorph newRow.
	durRow color: color; borderWidth: 0; layoutInset: 0.
	durRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	durRow addMorphBack: (switch fullCopy label: 'whole';
				actionSelector: #duration:onOff:; arguments: #(1)).
	durRow addMorphBack: (switch fullCopy label: 'half';
				actionSelector: #duration:onOff:; arguments: #(2)).
	durRow addMorphBack: (switch fullCopy label: 'quarter';
				actionSelector: #duration:onOff:; arguments: #(4)).
	durRow addMorphBack: (switch fullCopy label: 'eighth';
				actionSelector: #duration:onOff:; arguments: #(8)).
	durRow addMorphBack: (switch fullCopy label: 'sixteenth';
				actionSelector: #duration:onOff:; arguments: #(16)).
	self addMorph: durRow.
	durRow align: durRow bounds topCenter
			with: playRow bounds bottomCenter.

	"Add note duration modifier buttons"
	modRow _ AlignmentMorph newRow.
	modRow color: color; borderWidth: 0; layoutInset: 0.
	modRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	modRow addMorphBack: (switch fullCopy label: 'dotted';
				actionSelector: #durMod:onOff:; arguments: #(dotted)).
	modRow addMorphBack: (switch fullCopy label: 'normal';
				actionSelector: #durMod:onOff:; arguments: #(normal)).
	modRow addMorphBack: (switch fullCopy label: 'triplets';
				actionSelector: #durMod:onOff:; arguments: #(triplets)).
	modRow addMorphBack: (switch fullCopy label: 'quints';
				actionSelector: #durMod:onOff:; arguments: #(quints)).
	self addMorph: modRow.
	modRow align: modRow bounds topCenter
			with: durRow bounds bottomCenter.

	"Add articulation buttons"
	articRow _ AlignmentMorph newRow.
	articRow color: color; borderWidth: 0; layoutInset: 0.
	articRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	articRow addMorphBack: (switch fullCopy label: 'legato';
				actionSelector: #articulation:onOff:; arguments: #(legato)).
	articRow addMorphBack: (switch fullCopy label: 'normal';
				actionSelector: #articulation:onOff:; arguments: #(normal)).
	articRow addMorphBack: (switch fullCopy label: 'staccato';
				actionSelector: #articulation:onOff:; arguments: #(staccato)).
	self addMorph: articRow.
	articRow align: articRow bounds topCenter
			with: modRow bounds bottomCenter.

	self bounds: (self fullBounds expandBy: (0@0 extent: 0@borderWidth))
! !

!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'di 6/20/1999 12:54'!
initialize
	super initialize.
	buildingChord _ false.
	self addRecordingControls.
	self duration: 4 onOff: true.
	self durMod: #normal onOff: true.
	self articulation: #normal onOff: true.
	insertMode _ false! !

!KeyboardMorphForInput methodsFor: 'initialization' stamp: 'di 6/18/1999 15:52'!
pianoRoll: prMorph

	pianoRoll _ prMorph! !


!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/19/1999 23:37'!
articulation: artic onOff: ignored    "artic = eg, #legato, #normal, #staccato."
	"Set the articulation of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #articulation:onOff:])
				ifTrue: [m setSwitchState: m arguments first == artic]].
	articulation _ artic! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:20'!
backspaceNote

	self deleteNotes! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/18/1999 15:50'!
buildChord: onOff! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:20'!
deleteNotes

	pianoRoll deleteSelection! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 12:55'!
durMod: durMod onOff: ignored    "durMod = eg, #dotted, #normal, #triplets, #quints"
	"Set the duration of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #durMod:onOff:])
				ifTrue: [m setSwitchState: m arguments first = durMod]].
	durationModifier _ durMod! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 18:31'!
duration: denom onOff: ignored    "denom = eg, 1, 2, 4, 8, 16"
	"Set the duration of notes to be emitted when a key is pressed."

	self allMorphsDo:
		[:m | ((m isMemberOf: SimpleSwitchMorph)
				and: [m actionSelector == #duration:onOff:])
				ifTrue: [m setSwitchState: m arguments first = denom]].
	duration _ denom.
	self durMod: #normal onOff: true! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:01'!
emitRest

	| sel noteEvent |

	"All this selection logic should be shared with mouseDown..."
	(sel _ pianoRoll selection) ifNil: [^ self].
	insertMode ifTrue:
		[sel _ pianoRoll selectionForInsertion.
		insertMode _ false].
	sel = prevSelection ifFalse:
		["This is a new selection -- need to determine start time"
		sel third = 0
			ifTrue: [startOfNextNote _ 0]
			ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first)
										at: sel third) endTime.
					startOfNextNote _ startOfNextNote + self fullDuration - 1
										truncateTo: self fullDuration]].
	noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration;
			key: -1 "my flag for rest" velocity: self velocity channel: 1.
	pianoRoll appendEvent: noteEvent fullDuration: self fullDuration.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	prevSelection _ pianoRoll selection.
	startOfNextNote _ startOfNextNote + self fullDuration.! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 13:03'!
fullDuration

	| num denom |
	num _ denom _ 1.
	durationModifier == #dotted ifTrue: [num _ 3.  denom _ 2].
	durationModifier == #triplets ifTrue: [num _ 2.  denom _ 3].
	durationModifier == #quints ifTrue: [num _ 2.  denom _ 5].
	^ pianoRoll score ticksPerQuarterNote * 4 * num // duration // denom! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:27'!
noteDuration

	articulation == #staccato ifTrue: [^ (self fullDuration * 0.65) asInteger].
	articulation == #normal ifTrue: [^ (self fullDuration * 0.8) asInteger].
	articulation == #legato ifTrue: [^ (self fullDuration * 0.95) asInteger].
! !

!KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/19/1999 23:13'!
velocity

	^ 80  "Later put a slider on the keyboard control"! !


!KeyboardMorphForInput methodsFor: 'events' stamp: 'di 6/19/1999 23:52'!
mouseDownEvent: event noteMorph: keyMorph pitch: midiKey

	| sel noteEvent |
	event hand hasSubmorphs ifTrue: [^ self  "no response if drag something over me"].
	keyMorph color: playingKeyColor.
	(sel _ pianoRoll selection) ifNil: [^ self].
	insertMode ifTrue:
		[sel _ pianoRoll selectionForInsertion.
		insertMode _ false].
	sel = prevSelection ifFalse:
		["This is a new selection -- need to determine start time"
		sel third = 0
			ifTrue: [startOfNextNote _ 0]
			ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first)
										at: sel third) endTime.
					startOfNextNote _ startOfNextNote + self fullDuration - 1
										truncateTo: self fullDuration]].
	noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration;
			key: midiKey + 23 velocity: self velocity channel: 1.
	pianoRoll appendEvent: noteEvent fullDuration: self fullDuration.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	(soundPlaying _ self soundForEvent: noteEvent inTrack: sel first) play.
	prevSelection _ pianoRoll selection.
	startOfNextNote _ startOfNextNote + self fullDuration.! !

!KeyboardMorphForInput methodsFor: 'events' stamp: 'di 6/20/1999 15:28'!
mouseUpEvent: event noteMorph: noteMorph pitch: pitch
	noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12)
					ifTrue: [whiteKeyColor]
					ifFalse: [blackKeyColor]).
! !

!KeyboardMorphForInput methodsFor: 'events' stamp: 'di 6/20/1999 15:53'!
soundForEvent: noteEvent inTrack: trackIndex

	| sound player |
	player _ pianoRoll scorePlayer.
	sound _ MixedSound new.
	sound add: ((player instrumentForTrack: trackIndex)
					soundForMidiKey: noteEvent midiKey
					dur: noteEvent duration / (pianoRoll scorePlayer ticksForMSecs: 1000)
					loudness: (noteEvent velocity asFloat / 127.0))
			pan: (player panForTrack: trackIndex)
			volume: player overallVolume *
						(player volumeForTrack: trackIndex).
	^ sound
! !
ProjectNavigationMorph subclass: #KidNavigationMorph
	instanceVariableNames: ''
	classVariableNames: 'PreExistingProjects '
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
addButtons

	(self addARow: {

		self inAColumn: {self buttonFind}.
		self transparentSpacerOfSize:6@6.
		self transparentSpacerOfSize:6@6.
		self inAColumn: {self buttonNewProject}.
	}) layoutInset: 6.
	self addARow: {
		self transparentSpacerOfSize:0@6.
	}.
	(self addARow: {
		self inAColumn: {self buttonPublish}.
	}) layoutInset: 6.
	self addARow: {
		self transparentSpacerOfSize:0@18.
	}.
	(self addARow: {
		self inAColumn: {self buttonQuit}.
	}) layoutInset: 6.

! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'mir 10/4/2000 14:12'!
amountToShowWhenSmall
	^49! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/28/2000 18:23'!
balloonText

	^(mouseInside ifNil: [false]) ifTrue: [
		'Click here to see FEWER buttons.'
	] ifFalse: [
		'Click here to see MORE buttons.'
	].! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 13:56'!
colorForButtons

	^Color r: 0.613 g: 0.71 b: 1.0 ! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 14:01'!
fontForButtons

	^(TextStyle named: #ComicBold) fontOfSize: 18! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 12:29'!
handlesMouseDown: evt

	^true
	! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
initialize

	| fill |
	super initialize.
	self layoutInset: 12.
	fill _ GradientFillStyle ramp: {
		0.0->(Color r: 0.032 g: 0.0 b: 0.484).
		1.0->(Color r: 0.194 g: 0.032 b: 1.0)
	}.
	fill origin: self bounds topLeft.
	fill direction: 0@200.
	fill radial: false.
	self fillStyle: fill.
	self removeAllMorphs.
	self addButtons.

! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 12:28'!
mouseEnter: evt

	"kid nav doesn't care"
	! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 12:28'!
mouseLeave: evt

	"kid nav doesn't care"
	! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 12:30'!
mouseUp: evt

	mouseInside _ (mouseInside ifNil: [false]) not.
	self positionVertically
	! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/28/2000 19:00'!
quitSqueak

	| newProjects limit now msg response |

	Preferences checkForUnsavedProjects ifFalse: [^super quitSqueak].
	PreExistingProjects ifNil: [^super quitSqueak].
	limit _ 5 * 60.
	now _ Time totalSeconds.
	newProjects _ Project allProjects reject: [ :each | PreExistingProjects includes: each].
	newProjects _ newProjects reject: [ :each | 
		((each lastSavedAtSeconds ifNil: [0]) - now) abs < limit
	].
	newProjects isEmpty ifTrue: [^super quitSqueak].
	msg _ String streamContents: [ :strm |
		strm nextPutAll: 'There are some project(s)
that have not been saved recently:
----
'.
		newProjects do: [ :each | strm nextPutAll: each name; cr].
		strm nextPutAll: '----
What would you like to do?'
	].
	response _ PopUpMenu 
		confirm: msg
		trueChoice: 'Go ahead and QUIT'
		falseChoice: 'Wait, let me save them first'.
	response ifTrue: [^super quitSqueak].

! !

!KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/28/2000 18:27'!
step

	super step.
	PreExistingProjects ifNil: [PreExistingProjects _ WeakArray withAll: Project allProjects].! !
FloatArray variableWordSubclass: #KlattFrame
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattFrame commentStamp: '<historical>' prior: 0!
My instances are frames of parameters which are inputs for KlattSynthesizers. See the class method category 'documentation' for more details.!


!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a1v
	^ self at: 47! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a1v: aNumber
	self at: 47 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2f
	^ self at: 35! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2f: aNumber
	self at: 35 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2v
	^ self at: 48! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a2v: aNumber
	self at: 48 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3f
	^ self at: 36! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3f: aNumber
	self at: 36 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3v
	^ self at: 49! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a3v: aNumber
	self at: 49 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4f
	^ self at: 37! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4f: aNumber
	self at: 37 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4v
	^ self at: 50! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a4v: aNumber
	self at: 50 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a5f
	^ self at: 38! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a5f: aNumber
	self at: 38 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a6f
	^ self at: 39! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
a6f: aNumber
	self at: 39 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
anv
	^ self at: 46! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
anv: aNumber
	self at: 46 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
aspiration
	^ self at: 10! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
aspiration: aNumber
	self at: 10 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
atv
	^ self at: 51! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
atv: aNumber
	self at: 51 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b1
	^ self at: 14! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b1: aNumber
	self at: 14 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b2
	^ self at: 18! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b2: aNumber
	self at: 18 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b2f
	^ self at: 41! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b2f: aNumber
	self at: 41 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b3
	^ self at: 20! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b3: aNumber
	self at: 20 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b3f
	^ self at: 42! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b3f: aNumber
	self at: 42 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b4
	^ self at: 22! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b4: aNumber
	self at: 22 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b4f
	^ self at: 43! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b4f: aNumber
	self at: 43 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b5
	^ self at: 24! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b5: aNumber
	self at: 24 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b5f
	^ self at: 44! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b5f: aNumber
	self at: 44 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b6
	^ self at: 26! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
b6: aNumber
	self at: 26 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b6f
	^ self at: 45! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
b6f: aNumber
	self at: 45 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnp
	^ self at: 28! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnp: aNumber
	self at: 28 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnz
	^ self at: 30! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bnz: aNumber
	self at: 30 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btp
	^ self at: 32! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btp: aNumber
	self at: 32 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btz
	^ self at: 34! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
btz: aNumber
	self at: 34 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bypass
	^ self at: 40! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
bypass: aNumber
	self at: 40 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
db1
	^ self at: 16! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
db1: aNumber
	self at: 16 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
df1
	^ self at: 15! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
df1: aNumber
	self at: 15 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
diplophonia
	^ self at: 5! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
diplophonia: aNumber
	self at: 5 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f0
	^ self at: 1! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f0: aNumber
	self at: 1 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f1
	^ self at: 13! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f1: aNumber
	self at: 13 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f2
	^ self at: 17! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f2: aNumber
	self at: 17 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f3
	^ self at: 19! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f3: aNumber
	self at: 19 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f4
	^ self at: 21! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f4: aNumber
	self at: 21 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f5
	^ self at: 23! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f5: aNumber
	self at: 23 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f6
	^ self at: 25! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
f6: aNumber
	self at: 25 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
flutter
	^ self at: 2! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
flutter: aNumber
	self at: 2 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
fnp
	^ self at: 27! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnp: aNumber
	self at: 27 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnz
	^ self at: 29! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
fnz: aNumber
	self at: 29 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
friction
	^ self at: 11! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
friction: aNumber
	self at: 11 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftp
	^ self at: 31! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftp: aNumber
	self at: 31 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftz
	^ self at: 33! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
ftz: aNumber
	self at: 33 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
gain
	^ self at: 52! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 23:00'!
gain: aNumber
	self at: 52 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
jitter
	^ self at: 3! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
jitter: aNumber
	self at: 3 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ra
	^ self at: 8! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ra: aNumber
	self at: 8 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
rk
	^ self at: 9! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
rk: aNumber
	self at: 9 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ro
	^ self at: 7! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
ro: aNumber
	self at: 7 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
shimmer
	^ self at: 4! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
shimmer: aNumber
	self at: 4 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
turbulence
	^ self at: 12! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
turbulence: aNumber
	self at: 12 put: aNumber! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
voicing
	^ self at: 6! !

!KlattFrame methodsFor: 'accessing' stamp: 'len 12/5/1999 22:59'!
voicing: aNumber
	self at: 6 put: aNumber! !


!KlattFrame methodsFor: 'editing' stamp: 'len 12/17/1999 03:35'!
edit
	^ KlattFrameMorph new
		frame: self;
		addTestButton;
		openInWorld! !


!KlattFrame methodsFor: 'playing' stamp: 'len 12/17/1999 03:33'!
play
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {self}) play! !


!KlattFrame methodsFor: 'printing' stamp: 'len 9/1/1999 23:36'!
printOn: aStream
	self class parameterNames do: [ :each |
		aStream
			nextPutAll: each;
			nextPut: $=; 
			print: (self perform: each);
			space]! !

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

KlattFrame class
	instanceVariableNames: ''!

!KlattFrame class methodsFor: 'instance creation' stamp: 'len 12/17/1999 03:34'!
default
	"
	KlattFrame default edit
	"
	^ self new
		f0: 133;
		flutter: 0; jitter: 0; shimmer: 0; diplophonia: 0;
		voicing: 62;
		ro: 0.4; ra: 0.01; rk: 0.25;
		aspiration: 0;
		friction: 0;
		turbulence: 0;
		f1: 500;		b1: 60;
		df1: 0;		db1: 0;
		f2: 1500;		b2: 90;
		f3: 2800;	b3: 150;
		f4: 3250;	b4: 200;
		f5: 3700;	b5: 200;
		f6: 4990;	b6: 500;
		fnp: 280;	bnp: 90;
		fnz: 280;	bnz: 90;
		ftp: 2150;	btp: 180;
		ftz: 2150;	btz: 180;
		a2f: 52.5;	b2f: 200;
		a3f: 39.3;	b3f: 350;
		a4f: 25.4;	b4f: 500;
		a5f: 0;		b5f: 600;
		a6f: 0;		b6f: 800;
		bypass: 0;
		anv: 0;
		a1v: 60.3;
		a2v: 52.5;
		a3v: 39.3;
		a4v: 25.4;
		atv: 0;
		gain: 62! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'len 9/3/1999 02:38'!
fromArray: anArray
	| answer |
	answer _ self new.
	anArray doWithIndex: [ :each :i | answer at: i put: each].
	^ answer! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'hmm 5/7/1999 22:00'!
fromString: aString
	^ self fromArray: (aString substrings collect: [ :each | each asNumber])! !

!KlattFrame class methodsFor: 'instance creation' stamp: 'len 11/22/1999 02:38'!
new
	^ super new: 52! !


!KlattFrame class methodsFor: 'documentation' stamp: 'len 12/20/1999 01:49'!
defaultForParameter: aSymbol
	^ self default perform: aSymbol asSymbol! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
descriptionForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 4! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
maximumForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 3! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
minimumForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 2! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 12/5/1999 22:59'!
parameterData
	"This is a table describing the Klatt parameters. The columns are: parameter name, minimum value, maximum, parameter description, unit."
 
	^ #(
	"Excitation source (voice, aspiration and friction):"
		(f0 20 1000 'Fundamental frequency (hz)' hz)
		(flutter 0 1 'Amount of flutter' value)
		(jitter 0 1 'Amount of jitter' value)
		(shimmer 0 1 'Amount of shimmer' value)
		(diplophonia 0 1 'Amount of diplophonia' value)
		(voicing 0 80 'Amplitude of voicing' hz)
		(ro 0 1 'Relative duration of open phase of voicing waveform = Te/T0 (0 - 1)' value)
		(ra 0 0.2 'Relative duration of return phase of voicing waveform = Ta/T0 (0 - 1)' value)
		(rk 0 1 'Simmetry of the glottal pulse = (Te-Tp)/Tp (0 - 1)' value)
		(aspiration 0 80 'Amplitude of aspiration' dB)
		(friction 0 80 'Amplitude of friction' dB)
		(turbulence 0 80 'Amplitude of turbulence (in open glottal phase)' dB)

	"Formants frequencies and bandwidths:"	
		(f1 200 1300 'Frequency of 1st formant' hz)
		(b1 40 1000 'Bandwidth of 1st formant' hz)
		(df1 0 100 'Change in F1 during open portion of period' hz)
		(db1 0 400 'Change in B1 during open portion of period' hz)
		(f2 550 3000 'Frequency of 2nd formant' hz)
		(b2 40 1000 'Bandwidth of 2nd formant' hz)
		(f3 1200 4999 'Frequency of 3rd formant' hz)
		(b3 40 1000 'Bandwidth of 3rd formant' hz)
		(f4 1200 4999 'Frequency of 4th formant' hz)
		(b4 40 1000 'Bandwidth of 4th formant' hz)
		(f5 1200 4999 'Frequency of 5th formant' hz)
		(b5 40 1000 'Bandwidth of 5th formant' hz)
		(f6 1200 4999 'Frequency of 6th formant' hz)
		(b6 40 1000 'Bandwidth of 6th formant' hz)
		(fnp 248 528 'Frequency of nasal pole' hz)
		(bnp 40 1000 'Bandwidth of nasal pole' hz)
		(fnz 248 528 'Frequency of nasal zero' hz)
		(bnz 40 1000 'Bandwidth of nasal zero' hz)
		(ftp 300 3000 'Frequency of tracheal pole' hz)
		(btp 40 1000 'Bandwidth of tracheal pole' hz)
		(ftz 300 3000 'Frequency of tracheal zero' hz)
		(btz 40 2000 'Bandwidth of tracheal zero' hz)

	"Parallel Friction-Excited:"
		(a2f 0 80 'Amplitude of friction-excited parallel 2nd formant' dB)
		(a3f 0 80 'Amplitude of friction-excited parallel 3rd formant' dB)
		(a4f 0 80 'Amplitude of friction-excited parallel 4th formant' dB)
		(a5f 0 80 'Amplitude of friction-excited parallel 5th formant' dB)
		(a6f 0 80 'Amplitude of friction-excited parallel 6th formant' dB)
		(bypass 0 80 'Amplitude of friction-excited parallel bypass path' dB)
		(b2f 40 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b3f 60 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b4f 100 1000 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b5f 100 1500 'Bandwidth of friction-excited parallel 2nd formant' hz)
		(b6f 100 4000 'Bandwidth of friction-excited parallel 2nd formant' hz)

	"Parallel Voice-Excited:"
		(anv 0 80 'Amplitude of voice-excited parallel nasal formant' dB)
		(a1v 0 80 'Amplitude of voice-excited parallel 1st formant' dB)
		(a2v 0 80 'Amplitude of voice-excited parallel 2nd formant' dB)
		(a3v 0 80 'Amplitude of voice-excited parallel 3rd formant' dB)
		(a4v 0 80 'Amplitude of voice-excited parallel 4th formant' dB)
		(atv 0 80 'Amplitude of voice-excited parallel tracheal formant' dB)

	"Overall gain:"
		(gain 0 80 'Overall gain' dB))! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 9/27/1999 02:21'!
parameterNames
	^ self parameterData collect: [ :each | each first]! !

!KlattFrame class methodsFor: 'documentation' stamp: 'len 11/29/1999 02:10'!
unitForParameter: aSymbol
	^ (self parameterData detect: [ :one | one first = aSymbol]) at: 5! !


!KlattFrame class methodsFor: 'examples' stamp: 'len 12/8/1999 21:22'!
example1
	"
	KlattFrame example1.
	KlattFrame example2.
	KlattFrame example3
	"
	| frame |
	frame _ self default
		voicing: 62;
		anv: 0; a1v: 0; a2v: 0; a3v: 0; a4v: 0;
		yourself.
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !

!KlattFrame class methodsFor: 'examples' stamp: 'len 11/8/1999 00:56'!
example2
	"
	KlattFrame example2
	"
	| frame |
	frame _ self default
		voicing: 62;
		anv: 0; a1v: 62; a2v: 62; a3v: 62; a4v: 62;
		yourself.
	(KlattSynthesizer new cascade: 6; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !

!KlattFrame class methodsFor: 'examples' stamp: 'len 12/8/1999 21:23'!
example3
	"
	KlattFrame example3
	"
	| frame |
	frame _ self default
		voicing: 62;
		anv: 0; a1v: 62; a2v: 62; a3v: 62; a4v: 62;
		yourself.
	(KlattSynthesizer new cascade: 0; millisecondsPerFrame: 1000; soundFromFrames: {frame}) play! !


!KlattFrame class methodsFor: 'code generation' stamp: 'len 9/27/1999 02:21'!
generateAccessors
	"
	KlattFrame generateAccessors
	"
	| crtab getter setter |
	crtab _ String with: Character cr with: Character tab.
	self parameterNames
		doWithIndex: [ :selector :i |
			getter _ selector, crtab, '^ self at: ', i printString.
			setter _ selector, ': aNumber', crtab, 'self at: ', i printString,' put: aNumber'.
			self compile: getter classified: 'accessing'.
			self compile: setter classified: 'accessing']! !
AlignmentMorph subclass: #KlattFrameMorph
	instanceVariableNames: 'frame lastSnapshot glottal '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 12/2/1999 02:57'!
addSliderForParameter: parameter target: target min: min max: max description: description
	self addMorphFront: (self newSliderForParameter: parameter target: target min: min max: max description: description)! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:00'!
addSlidersForParameters: params
	| left right container current slider |
	params size < 10
		ifTrue: [left _ right _ self]
		ifFalse: [container _ AlignmentMorph new color: self color; listDirection: #leftToRight.
				left _ container clone listDirection: #topToBottom.
				right _ left clone.
				container addMorphBack: left; addMorphBack: right.
				self addMorphBack: container].
	params do: [ :each |
		current _ current == left ifTrue: [right] ifFalse: [left].
		slider _ self newSliderNamed: each min: (KlattFrame minimumForParameter: each) max: (KlattFrame maximumForParameter: each).
		slider setBalloonText: (KlattFrame descriptionForParameter: each).
		current addMorphBack: slider]! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 10/1/1999 01:25'!
addTestButton
	self addMorphBack: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #playTest; labelString: 'play')! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 9/27/1999 02:25'!
frame: aKlattFrame
	self frame: aKlattFrame edit: KlattFrame parameterNames! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 10/1/1999 01:27'!
frame: aKlattFrame edit: params
	frame _ aKlattFrame.
	self addSlidersForParameters: params.
	(params detect: [ :one | #(ro ra rk) includes: one] ifNone: []) notNil
		ifTrue: [glottal _ GraphMorph new extent: 210 @ 100.
				glottal setBalloonText: 'Glottal pulse'.
				self addMorphBack: glottal]! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:55'!
initialize
	super initialize.
	self listDirection: #topToBottom.
	self color: (Color r: 0.452 g: 0.935 b: 0.548)! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:18'!
newSliderForParameter: parameter target: target min: min max: max description: description
	| r slider m |
	r _ AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter.

	slider _ SimpleSliderMorph new
		color: (Color r: 0.065 g: 0.548 b: 0.645);
		extent: 120@2;
		target: target;
		actionSelector: (parameter, ':') asSymbol;
		minVal: min;
		maxVal: max;
		adjustToValue: (target perform: parameter asSymbol).
	r addMorphBack: slider.

	m _ StringMorph new contents: parameter, ': '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: target; getSelector: parameter asSymbol; putSelector: (parameter, ':') asSymbol;
		width: 30; growable: false; floatPrecision: (max - min / 100.0 min: 1.0); step.
	r addMorphBack: m.
	r setBalloonText: description.
	^ r! !

!KlattFrameMorph methodsFor: 'initialization' stamp: 'len 12/2/1999 02:59'!
newSliderNamed: name min: min max: max
	^ self newSliderForParameter: name target: frame min: min max: max description: ''! !


!KlattFrameMorph methodsFor: 'menu' stamp: 'len 10/1/1999 01:31'!
playTest
	| synth |
	synth _ KlattSynthesizer new.
	synth millisecondsPerFrame: 1000; cascade: 8.
	(SampledSound samples: (synth samplesFromFrames: {frame}) samplingRate: synth samplingRate) play! !


!KlattFrameMorph methodsFor: 'stepping and presenter' stamp: 'len 9/27/1999 02:58'!
step
	| lf |
	lastSnapshot = frame ifTrue: [^ self].
	lastSnapshot _ frame clone.
	lf _ LiljencrantsFant new
		t0: 1 / frame f0 ro: frame ro rk: frame rk ra: frame ra samplingRate: 44000.
	glottal data: lf init samples! !

!KlattFrameMorph methodsFor: 'stepping and presenter' stamp: 'len 9/27/1999 02:51'!
stepTime
	^ 500! !
Object subclass: #KlattSegment
	instanceVariableNames: 'name features rank duration parameters '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattSegment methodsFor: 'initialization' stamp: 'len 10/9/1999 02:14'!
initialize
	self parameters: Dictionary new! !


!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 23:58'!
addParameter: aKlattSegmentParameter
	^ self parameters at: aKlattSegmentParameter selector put: aKlattSegmentParameter! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:51'!
duration
	^ duration! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:51'!
duration: aNumber
	duration _ aNumber! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 11/22/1999 01:07'!
features
	^ features! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 11/22/1999 01:07'!
features: aCollection
	features _ aCollection! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 02:56'!
name
	^ name! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 02:56'!
name: aString
	name _ aString! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:50'!
parameters
	^ parameters! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 02:13'!
parameters: aDictionary
	parameters _ aDictionary! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:49'!
rank
	^ rank! !

!KlattSegment methodsFor: 'accessing' stamp: 'len 10/9/1999 01:49'!
rank: aNumber
	rank _ aNumber! !


!KlattSegment methodsFor: 'processing' stamp: 'len 12/2/1999 01:55'!
cosine: a with: b time: time duration: dur
	time <= 0 ifTrue: [^ a].
	time >= dur ifTrue: [^ b].
	^ ((time / dur * Float pi) cos - 1 / -2.0) * (b - a) + a! !

!KlattSegment methodsFor: 'processing' stamp: 'len 12/6/1999 03:26'!
interpolate: slope1 with: slope2 mid: mid time: time speed: speed
	| steady p1 p2 |
	steady _ self duration * speed - (slope1 x + slope2 x).
	steady < 0 "steady state cannot be reached"
		ifTrue: [p1 _ self linear: slope1 y with: mid time: time duration: slope1 x.
				p2 _ self linear: slope2 y with: mid time: self duration * speed - time duration: slope2 x.
				^ p2 - p1 * time / (self duration * speed) + p1].
	time < slope1 x
		ifTrue: [^ self linear: slope1 y with: mid time: time duration: slope1 x].
	^ time - slope1 x <= steady "steady state reached"
		ifTrue: [mid]
		ifFalse: [self linear: mid with: slope2 y time: time - slope1 x - steady duration: slope2 x]! !

!KlattSegment methodsFor: 'processing' stamp: 'len 12/6/1999 03:31'!
left: left right: right speed: speed pattern: patternFrame
	| frames leftSlope rightSlope value |
	frames _ (1 to: self duration * speed) collect: [ :each | patternFrame clone].
	self parameters do: [ :each |
		leftSlope _ self slopeWith: left selector: each selector speed: speed.
		rightSlope _ self slopeWith: right selector: each selector speed: speed.
		0 to: self duration * speed - 1 do: [ :time |
			value _ self interpolate: leftSlope with: rightSlope mid: each steady time: time speed: speed.
			(frames at: (time + 1) asInteger) perform: each selector with: value]].
	^ frames! !

!KlattSegment methodsFor: 'processing' stamp: 'len 12/6/1999 03:51'!
linear: a with: b time: time duration: dur
	time <= 0 ifTrue: [^ a].
	time >= dur ifTrue: [^ b].
	^ b - a * time / dur + a! !

!KlattSegment methodsFor: 'processing' stamp: 'len 12/6/1999 03:16'!
slopeWith: aKlattSegment selector: selector speed: speed
	| me other |
	me _ self parameters at: selector.
	other _ aKlattSegment parameters at: selector.
	^ (self dominates: aKlattSegment)
		ifTrue: [me slopeWithDominated: other speed: speed]
		ifFalse: [me slopeWithDominant: other speed: speed]! !


!KlattSegment methodsFor: 'testing' stamp: 'len 10/12/1999 01:12'!
dominates: aKlattSegment
	"Answer true if the receiver dominates the argument,
	i.e. if the receiver has greater rank than the argument."

	^ self rank > aKlattSegment rank! !


!KlattSegment methodsFor: 'printing' stamp: 'len 12/5/1999 23:38'!
compileOn: aClass
	| stream |
	stream _ WriteStream on: ''.
	self methodPrintOn: stream.
	aClass compile: stream contents classified: 'default segments'! !

!KlattSegment methodsFor: 'printing' stamp: 'len 12/5/1999 23:38'!
methodPrintOn: aStream
	| param |
	aStream print: self name; cr;
		tab; nextPutAll: '^ self segmentFromArray: '; cr;
		tab; tab; nextPutAll: '"name	rank	duration	features"'; cr;
		tab; tab; nextPutAll: '#('; print: self name; tab; tab; print: self rank; tab; tab; print: self duration; tab; tab; tab; print: (self features ifNil: [#()]); cr;
		tab; tab; nextPutAll: '"selector		steady	fixed	prop	extern	intern"'.
	KlattFrame parameterNames do: [ :each |
		(param _ self parameters at: (each, ':') asSymbol ifAbsent: [])
			ifNotNil: [aStream cr; tab; tab.
					param methodPrintOn: aStream]].
	aStream nextPut: $)! !

!KlattSegment methodsFor: 'printing' stamp: 'len 11/25/1999 01:38'!
methodString
	| stream |
	stream _ WriteStream on: ''.
	self methodPrintOn: stream.
	^ stream contents! !

!KlattSegment methodsFor: 'printing' stamp: 'len 12/6/1999 03:59'!
printOn: aStream
	aStream nextPutAll: self name! !


!KlattSegment methodsFor: 'message dispatching' stamp: 'len 12/8/1999 21:40'!
doesNotUnderstand: aMessage
	| sel |
	(parameters includesKey: (sel _ (aMessage selector copyWith: $:) asSymbol))
		ifTrue: [^ parameters at: sel].
	^ super doesNotUnderstand: aMessage! !

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

KlattSegment class
	instanceVariableNames: ''!

!KlattSegment class methodsFor: 'instance creation' stamp: 'len 10/9/1999 03:05'!
new
	^ super new initialize! !
Object subclass: #KlattSegmentParameter
	instanceVariableNames: 'selector steady fixed proportion internal external '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
external
	^ external! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
external: aNumber
	external _ aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 12/5/1999 23:22'!
fixed
	^ fixed! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 12/5/1999 16:10'!
fixed: aNumber
	fixed _ aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
internal
	^ internal! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
internal: aNumber
	internal _ aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:08'!
proportion
	^ proportion! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:09'!
proportion: aNumber
	proportion _ aNumber! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 23:52'!
selector
	^ selector! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 23:52'!
selector: aSymbol
	selector _ aSymbol asSymbol! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:08'!
steady
	^ steady! !

!KlattSegmentParameter methodsFor: 'accessing' stamp: 'len 10/9/1999 02:08'!
steady: aNumber
	steady _ aNumber! !


!KlattSegmentParameter methodsFor: 'printing' stamp: 'len 12/5/1999 23:35'!
methodPrintOn: aStream
	aStream nextPut: $(; print: self selector; tab.
	self selector size < 4 ifTrue: [aStream tab].
	self selector size < 8 ifTrue: [aStream tab].
	aStream print: self steady; tab; tab; print: self fixed; tab; tab; print: self proportion; tab; tab; print: self external; tab; tab; print: self internal; nextPut: $)! !

!KlattSegmentParameter methodsFor: 'printing' stamp: 'len 10/10/1999 00:22'!
printOn: aStream
	aStream nextPutAll: self selector; space; print: self steady! !


!KlattSegmentParameter methodsFor: 'processing' stamp: 'len 12/6/1999 03:15'!
slopeWith: parameter dominant: dominant speed: speed
	| dominated time value |
	dominated _ self == dominant ifTrue: [parameter] ifFalse: [self].
	time _ dominant == self ifTrue: [dominant internal] ifFalse: [dominant external].
	time _ time * speed.
	value _ time ~= 0
		ifTrue: [dominant proportion * dominated steady * 0.01 + dominant fixed]
		ifFalse: [dominated steady].
	^ time @ value! !

!KlattSegmentParameter methodsFor: 'processing' stamp: 'len 12/6/1999 03:15'!
slopeWithDominant: parameter speed: speed
	^ self slopeWith: parameter dominant: parameter speed: speed! !

!KlattSegmentParameter methodsFor: 'processing' stamp: 'len 12/6/1999 03:16'!
slopeWithDominated: parameter speed: speed
	^ self slopeWith: parameter dominant: self speed: speed! !
Object subclass: #KlattSegmentSet
	instanceVariableNames: 'phonemes segments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattSegmentSet commentStamp: '<historical>' prior: 0!
My instances are sets of KlattSegments, and they map phonemes to actual KlattSegments. The default segments are adapted from rsynth 2.0, a public domain TTS.!


!KlattSegmentSet methodsFor: 'initialization' stamp: 'len 12/20/1999 04:27'!
initializeArpabet
	phonemes _ PhonemeSet arpabet.
	segments _ Dictionary new.
	#(('p'	(p py pz))
	('t'		(t ty tz))
	('k'		(k ky kz))
	('b'		(b by bz))
	('d'		(d dy dz))
	('g'		(g gy gz))
	('m'		(m))
	('n'		(n))
	('ng'	(ng))
	('f'		(f))
	('th'	(th))
	('s'		(s))
	('sh'	(sh))
	('hh'	(h))
	('v'		(v qq v))
	('dh'	(dh qq di))
	('z'		(z qq zz))
	('zh'	(zh qq zh))
	('ch'	(ch ci))
	('jh'	(j jy qq jy))
	('l'		(l))
	('r'		(r))
	('w'		(w))
	('q'		(qq)) "stop-ness - not quite glottal stop"
	('y'		(y))
	('ih'	(i))
	('eh'	(e))
	('ae'	(aa))
	('ah'	(u))
"	('oh'	(o))	????????????????????????"
	('uh'	(oo))
	('ax'	(a))
	('iy'	(ee))
	('er'	(er))
	('aa'	(ar))
	('ao'	(aw))
	('uw'	(uu))
	('ey'	(ai i))
	('ay'	(ie i))
	('oy'	(oi i))
	('aw'	(ou ov))
	('ow'	(oa ov))
	('ia'	(ia ib))
	('ea'	(air ib))
	('ua'	(oor ib))
	('sil'	(q))
	('ll'		(ll))
	('wh'	(w))
	('ix'		(a))
	('el'		(l))
	('rx'	(rx))) do: [ :each |
		segments at: (phonemes at: each first)
		put: (each last collect: [ :selector | self perform: selector])]! !


!KlattSegmentSet methodsFor: 'accessing-private' stamp: 'len 10/12/1999 00:49'!
phonemes: aPhonemeSet
	phonemes _ aPhonemeSet! !

!KlattSegmentSet methodsFor: 'accessing-private' stamp: 'len 10/12/1999 00:48'!
segments: aDictionary
	segments _ aDictionary! !


!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
at: aPhoneme
	^ self segments at: aPhoneme! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:53'!
at: aPhoneme ifAbsent: aBlock
	^ self segments at: aPhoneme ifAbsent: aBlock! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
phonemes
	^ phonemes! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 10/12/1999 00:48'!
segments
	^ segments! !

!KlattSegmentSet methodsFor: 'accessing' stamp: 'len 12/6/1999 03:58'!
silence
	self phonemes do: [ :each | each isSilence ifTrue: [^ self at: each]].
	self error: 'silence segment not found'! !


!KlattSegmentSet methodsFor: 'enumerating' stamp: 'len 11/28/1999 04:18'!
do: aBlock
	self segments do: [ :each | each do: aBlock]! !


!KlattSegmentSet methodsFor: 'segments creation' stamp: 'len 12/5/1999 23:09'!
parameterFromArray: anArray
	| answer |
	answer _ KlattSegmentParameter new.
	#(selector: steady: fixed: proportion: external: internal:)
		doWithIndex: [ :each :index | answer perform: each with: (anArray at: index)].
	^ answer! !

!KlattSegmentSet methodsFor: 'segments creation' stamp: 'len 11/29/1999 01:40'!
segmentFromArray: anArray
	| answer |
	answer _ KlattSegment new.
	#(name: rank: duration: features:)
		doWithIndex: [ :each :index | answer perform: each with: (anArray at: index)].
	5 to: anArray size do: [ :each | answer addParameter: (self parameterFromArray: (anArray at: each))].
	^ answer! !


!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
a
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(a		2		4			(cnt mdl unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1480		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		64.75		31.5		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
aa
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(aa		2		5			(fnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		4		4)
		(b1:			130		65.0		50		4		4)
		(f2:			1780		950.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		61.25		31.5		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ai
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ai		2		6			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		290.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1600		830.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		43.75		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		43.75		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
air
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(air		2		6			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		350.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			2020		1070.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		5		5)
		(a3f:		52.5		24.5		50		5		5)
		(a4f:		45.5		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		56		28.0		50		5		5)
		(a3v:		52.5		24.5		50		5		5)
		(a4v:		45.5		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ar
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ar		2		15			(bck low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		31.5		50		4		4)
		(a3f:		43.75		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		63		31.5		50		4		4)
		(a3v:		43.75		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
aw
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(aw		2		10			(bck lmd rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			820		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		4		4)
		(a3f:		36.75		17.5		50		4		4)
		(a4f:		31.5		14.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		59.5		28.0		50		4		4)
		(a3v:		36.75		17.5		50		4		4)
		(a4v:		31.5		14.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
b
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(b		26		12			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		0		2)
		(b3:			150		0.0		100		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
by
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(by		29		1			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			760		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		0.0		100		0		0)
		(a3f:		57.25		0.0		100		0		0)
		(a4f:		52.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		63		0.0		100		0		0)
		(a3v:		57.25		0.0		100		0		0)
		(a4v:		52.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
bz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(bz		26		0			(blb stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		0)
		(b1:			60		30.0		50		2		0)
		(f2:			760		350.0		50		2		0)
		(b2:			90		45.0		50		2		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ch
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ch		23		4			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ci
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ci		18		8			(frc pla vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		56		0.0		100		0		0)
		(a4f:		45.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		56		0.0		100		0		0)
		(a4v:		45.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
d
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(d		26		8			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		45.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/8/1999 22:08'!
dh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dh		20		4			(dnt frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	36		18.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1600		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:	54		27.0		50		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
di
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(di		20		4			(dnt frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1600		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
dy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dy		29		1			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1780		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2680		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		0.0		100		0		0)
		(a3f:		49		0.0		100		0		0)
		(a4f:		59.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		52.5		0.0		100		0		0)
		(a2v:		52.5		0.0		100		0		0)
		(a3v:		49		0.0		100		0		0)
		(a4v:		59.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
dz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(dz		26		1			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		0)
		(b1:			60		30.0		50		2		0)
		(f2:			1780		950.0		50		2		0)
		(b2:			90		45.0		50		2		0)
		(f3:			2680		2680.0		0		2		0)
		(b3:			150		150.0		0		2		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		49		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		0)
		(b3f:		150		150.0		0		2		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		52.5		0.0		100		0		0)
		(a2v:		42		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		49		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
e
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(e		2		4			(fnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			640		350.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2020		1070.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ee
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ee		2		7			(fnt hgh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2320		1190.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			3200		1580.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		47.25		24.5		50		4		4)
		(a3f:		50.75		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		47.25		24.5		50		4		4)
		(a3v:		50.75		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/22/1999 03:07'!
end
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(end		31		5			(0 )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		3		3)
		(a2f:		-16		-10.5		100		3		0)
		(a3f:		-16		-10.5		100		3		0)
		(a4f:		-16		-10.5		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		-10.5		100		3		0)
		(a1v:		-16		-10.5		100		3		0)
		(a2v:		-16		-10.5		100		3		0)
		(a3v:		-16		-10.5		100		3		0)
		(a4v:		-16		-10.5		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
er
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(er		2		16			(cnt lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			580		290.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1420		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		59.5		28.0		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/8/1999 22:08'!
f
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(f		18		12			(frc lbd vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	32		16.0		50		0		0)
		(friction:	54		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1420		350.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		980.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		14		0.0		100		0		0)
		(a3f:		14		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:	54		27.0		50		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		14		0.0		100		0		0)
		(a3v:		14		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
g
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(g		26		12			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
gy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(gy		29		1			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2620		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		38.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		59.5		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		38.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
gz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(gz		26		2			(stp vcd vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1480		1550.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2620		1580.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		0.0		100		0		0)
		(a3f:		43.75		0.0		100		0		0)
		(a4f:		28		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		49		0.0		100		0		0)
		(a2v:		49		0.0		100		0		0)
		(a3v:		43.75		0.0		100		0		0)
		(a4v:		28		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
h
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(h		9		10			(apr glt )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			490		0.0		100		0		7)
		(b1:			60		0.0		100		0		7)
		(f2:			1480		0.0		100		0		7)
		(b2:			90		0.0		100		0		7)
		(f3:			2500		0.0		100		0		7)
		(b3:			150		0.0		100		0		7)
		(fnz:		270		135.0		50		0		0)
		(a2f:		50.75		-14.0		100		0		7)
		(a3f:		40.25		-7.0		100		0		7)
		(a4f:		36.75		-3.5		100		0		7)
		(a5f:		-16		0.0		100		0		7)
		(a6f:		-16		0.0		100		0		7)
		(bypass:		-16		0.0		100		0		7)
		(b2f:		90		0.0		100		0		7)
		(b3f:		150		0.0		100		0		7)
		(anv:		-16		0.0		100		0		7)
		(a1v:		49		-14.0		100		0		7)
		(a2v:		50.75		-14.0		100		0		7)
		(a3v:		40.25		-7.0		100		0		7)
		(a4v:		36.75		-3.5		100		0		7))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
i
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(i		2		6			(fnt smh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			400		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2080		1070.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2560		1340.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		50.75		24.5		50		4		4)
		(a3f:		49		24.5		50		4		4)
		(a4f:		43.75		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		50.75		24.5		50		4		4)
		(a3v:		49		24.5		50		4		4)
		(a4v:		43.75		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ia
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ia		2		6			(fnt smh unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			310		170.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			2200		1070.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2920		1460.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		50.75		24.5		50		5		5)
		(a4f:		45.5		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		50.75		24.5		50		5		5)
		(a4v:		45.5		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ib
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ib		2		6			(fnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1480		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		4		4)
		(a3f:		47.25		24.5		50		4		4)
		(a4f:		40.25		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		64.75		31.5		50		4		4)
		(a3v:		47.25		24.5		50		4		4)
		(a4v:		40.25		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ie
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ie		2		6			(cnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			880		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		31.5		50		5		5)
		(a3f:		43.75		21.0		50		5		5)
		(a4f:		36.75		17.5		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		63		31.5		50		5		5)
		(a3v:		43.75		21.0		50		5		5)
		(a4v:		36.75		17.5		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
j
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(j		26		4			(alv stp vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		2		2)
		(b3:			150		150.0		0		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		45.5		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
jy
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(jy		20		3			(frc pla vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		40.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		40.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
k
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(k		23		8			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ky
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ky		29		1			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1480		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2620		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		0.0		100		0		0)
		(a3f:		64.75		0.0		100		0		0)
		(a4f:		43.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		64.75		0.0		100		0		0)
		(a3v:		64.75		0.0		100		0		0)
		(a4v:		43.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
kz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(kz		23		4			(stp vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		33.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		33.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
l
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(l		11		8			(alv lat vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			460		230.0		50		6		0)
		(b1:			60		30.0		50		6		0)
		(f2:			1480		710.0		50		6		0)
		(b2:			90		45.0		50		6		0)
		(f3:			2500		1220.0		50		6		0)
		(b3:			150		75.0		50		6		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		35		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		6		0)
		(b3f:		150		75.0		50		6		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		50.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		35		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ll
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ll		11		8			(alv lat vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			460		230.0		50		6		0)
		(b1:			60		30.0		50		6		0)
		(f2:			940		470.0		50		6		0)
		(b2:			90		45.0		50		6		0)
		(f3:			2500		1220.0		50		6		0)
		(b3:			150		75.0		50		6		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		40.25		0.0		100		0		0)
		(a4f:		35		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		6		0)
		(b3f:		150		75.0		50		6		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		50.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		40.25		0.0		100		0		0)
		(a4v:		35		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
m
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(m		15		8			(blb nas )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			40		20.0		50		3		0)
		(f2:			1000		350.0		50		3		0)
		(b2:			175		87.0		50		3		0)
		(f3:			2200		0.0		100		5		0)
		(b3:			120		0.0		100		5		0)
		(fnz:		360		360.0		0		3		0)
		(a2f:		44		-10.0		100		3		0)
		(a3f:		47		-10.0		100		3		0)
		(a4f:		-16		-10.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		175		87.0		50		3		0)
		(b3f:		120		0.0		100		5		0)
		(anv:		56		28.0		50		3		0)
		(a1v:		40		-10.0		100		3		0)
		(a2v:		44		-10.0		100		3		0)
		(a3v:		47		-10.0		100		3		0)
		(a4v:		-16		-10.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
n
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(n		15		8			(alv nas )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			40		20.0		50		3		0)
		(f2:			1780		950.0		50		3		3)
		(b2:			300		150.0		50		3		3)
		(f3:			2620		2680.0		0		3		0)
		(b3:			260		130.0		50		3		0)
		(fnz:		450		450.0		0		3		0)
		(a2f:		49		-10.0		100		3		0)
		(a3f:		49		-10.0		100		3		0)
		(a4f:		34		-10.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		300		150.0		50		3		3)
		(b3f:		260		130.0		50		3		0)
		(anv:		56		28.0		50		3		0)
		(a1v:		49		-10.0		100		3		0)
		(a2v:		49		-10.0		100		3		0)
		(a3v:		49		-10.0		100		3		0)
		(a4v:		34		-10.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ng
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ng		15		8			(nas vel )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	52		26.0		50		2		0)
		(aspiration:	0		0.0		50		2		0)
		(friction:	0		0.0		50		2		0)
		(f1:			480		480.0		0		3		0)
		(b1:			160		80.0		0		5		0)
		(f2:			820		1550.0		50		5		3)
		(b2:			150		75.0		50		5		3)
		(f3:			2800		1580.0		50		3		3)
		(b3:			100		50.0		50		3		0)
		(fnz:		360		360.0		0		3		0)
		(a2f:		44		0.0		100		3		0)
		(a3f:		49		0.0		100		3		0)
		(a4f:		14		0.0		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		150		75.0		50		5		3)
		(b3f:		100		50.0		50		3		0)
		(anv:		56		28.0		50		3		3)
		(a1v:		34		0.0		100		3		0)
		(a2v:		44		0.0		100		3		0)
		(a3v:		49		0.0		100		3		0)
		(a4v:		14		0.0		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
o
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(o		2		6			(bck low rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			610		290.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		4		4)
		(a3f:		36.75		17.5		50		4		4)
		(a4f:		29.75		14.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		61.25		31.5		50		4		4)
		(a3v:		36.75		17.5		50		4		4)
		(a4v:		29.75		14.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oa
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oa		2		6			(cnt mdl unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1480		710.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		64.75		31.5		50		5		5)
		(a3f:		47.25		24.5		50		5		5)
		(a4f:		40.25		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		64.75		31.5		50		5		5)
		(a3v:		47.25		24.5		50		5		5)
		(a4v:		40.25		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oi
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oi		2		6			(bck rnd umd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			820		350.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		36.75		17.5		50		5		5)
		(a4f:		31.5		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		36.75		17.5		50		5		5)
		(a4v:		31.5		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oo
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oo		2		4			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1000		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		42		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		42		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
oor
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(oor		2		6			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1000		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		5		5)
		(a3f:		42		21.0		50		5		5)
		(a4f:		36.75		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		56		28.0		50		5		5)
		(a3v:		42		21.0		50		5		5)
		(a4v:		36.75		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
or
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(or		2		6			(bck lmd rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		230.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			820		470.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		59.5		28.0		50		5		5)
		(a3f:		36.75		17.5		50		5		5)
		(a4f:		31.5		14.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		59.5		28.0		50		5		5)
		(a3v:		36.75		17.5		50		5		5)
		(a4v:		31.5		14.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ou
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ou		2		6			(cnt low unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			790		410.0		50		5		5)
		(b1:			60		30.0		50		5		5)
		(f2:			1300		590.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			2500		1220.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		61.25		31.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		42		21.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		64.75		31.5		50		5		5)
		(a2v:		61.25		31.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		42		21.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ov
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ov		2		6			(bck rnd smh vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			370		170.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1000		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		56		28.0		50		4		4)
		(a3f:		42		21.0		50		4		4)
		(a4f:		36.75		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		56		28.0		50		4		4)
		(a3v:		42		21.0		50		4		4)
		(a4v:		36.75		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
p
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(p		23		8			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		0		2)
		(b3:			150		0.0		100		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
py
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(py		29		1			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			760		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2500		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		63		0.0		100		0		0)
		(a3f:		57.75		0.0		100		0		0)
		(a4f:		52.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		63		0.0		100		0		0)
		(a3v:		57.75		0.0		100		0		0)
		(a4v:		52.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
pz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(pz		23		2			(blb stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			760		350.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2500		0.0		100		2		2)
		(b3:			150		0.0		100		2		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		0.0		100		0		0)
		(a3f:		47.25		0.0		100		0		0)
		(a4f:		42		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		0.0		100		2		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		38.5		0.0		100		0		0)
		(a2v:		52.5		0.0		100		0		0)
		(a3v:		47.25		0.0		100		0		0)
		(a4v:		42		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
q
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(q		29		6			(0 )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		3		3)
		(b1:			60		0.0		100		3		3)
		(f2:			1480		0.0		100		3		3)
		(b2:			90		0.0		100		3		3)
		(f3:			2500		0.0		100		3		3)
		(b3:			150		0.0		100		3		3)
		(fnz:		270		135.0		50		3		3)
		(a2f:		-16		-10.5		100		3		0)
		(a3f:		-16		-10.5		100		3		0)
		(a4f:		-16		-10.5		100		3		0)
		(a5f:		-16		0.0		100		3		0)
		(a6f:		-16		0.0		100		3		0)
		(bypass:		-16		0.0		100		3		0)
		(b2f:		90		0.0		100		3		3)
		(b3f:		150		0.0		100		3		3)
		(anv:		-16		-10.5		100		3		0)
		(a1v:		-16		-10.5		100		3		0)
		(a2v:		-16		-10.5		100		3		0)
		(a3v:		-16		-10.5		100		3		0)
		(a4v:		-16		-10.5		100		3		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
qq
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(qq		30		0			(frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1420		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2560		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		47.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		47.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
r
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(r		10		11			(alv apr )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		5)
		(b1:			60		0.0		100		0		5)
		(f2:			1180		590.0		50		5		5)
		(b2:			90		45.0		50		5		5)
		(f3:			1600		740.0		50		5		5)
		(b3:			150		75.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		-16		7.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		150		75.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		56		28.0		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		-16		7.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
rx
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(rx		10		10			(rzd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	50		25.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			490		0.0		100		0		5)
		(b1:			60		30.0		50		0		5)
		(f2:			1180		0.0		100		0		5)
		(b2:			90		45.0		50		5		5)
		(f3:			1600		1600.0		0		5		5)
		(b3:			70		35.0		50		5		5)
		(fnz:		270		135.0		50		0		0)
		(a2f:		49		24.5		50		5		5)
		(a3f:		49		24.5		50		5		5)
		(a4f:		-16		7.0		50		5		5)
		(a5f:		-16		-8.0		50		5		5)
		(a6f:		-16		-8.0		50		5		5)
		(bypass:		-16		-8.0		50		5		5)
		(b2f:		90		45.0		50		5		5)
		(b3f:		70		35.0		50		5		5)
		(anv:		-16		0.0		100		5		5)
		(a1v:		56		28.0		50		5		5)
		(a2v:		49		24.5		50		5		5)
		(a3v:		49		24.5		50		5		5)
		(a4v:		-16		7.0		50		5		5))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
s
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(s		18		12			(alv frc vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	32		16.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			200		100.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			96		48.0		50		3		2)
		(f3:			2620		0.0		100		3		2)
		(b3:			220		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		54.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		96		48.0		50		3		2)
		(b3f:		220		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		42		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		54.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
sh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(sh		18		12			(frc pla vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2200		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		45.5		0.0		100		0		0)
		(a3f:		56		0.0		100		0		0)
		(a4f:		45.5		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		45.5		0.0		100		0		0)
		(a3v:		56		0.0		100		0		0)
		(a4v:		45.5		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
t
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(t		23		6			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		2)
		(b1:			60		30.0		50		2		2)
		(f2:			1780		950.0		50		2		2)
		(b2:			90		45.0		50		2		2)
		(f3:			2680		2680.0		0		0		2)
		(b3:			150		150.0		0		0		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		-16		0.0		100		0		0)
		(a4f:		-16		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		2)
		(b3f:		150		150.0		0		0		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		-16		0.0		100		0		0)
		(a4v:		-16		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
th
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(th		18		15			(dnt frc vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			400		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1780		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2680		2680.0		0		3		2)
		(b3:			150		150.0		0		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		36.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		150.0		0		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		36.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
ty
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(ty		29		1			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		0.0		100		0		0)
		(b1:			60		0.0		100		0		0)
		(f2:			1780		0.0		100		0		0)
		(b2:			90		0.0		100		0		0)
		(f3:			2680		0.0		100		0		0)
		(b3:			150		0.0		100		0		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		52.5		0.0		100		0		0)
		(a4f:		64.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		0.0		100		0		0)
		(b3f:		150		0.0		100		0		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		52.5		0.0		100		0		0)
		(a4v:		64.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
tz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(tz		23		2			(alv stp vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		2		1)
		(b1:			60		30.0		50		2		1)
		(f2:			1780		950.0		50		2		1)
		(b2:			90		45.0		50		2		1)
		(f3:			2680		2680.0		0		2		0)
		(b3:			150		150.0		0		2		0)
		(fnz:		270		135.0		50		0		0)
		(a2f:		-16		0.0		100		0		0)
		(a3f:		42		0.0		100		0		0)
		(a4f:		54.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		2		1)
		(b3f:		150		150.0		0		2		0)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		-16		0.0		100		0		0)
		(a3v:		42		0.0		100		0		0)
		(a4v:		54.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
u
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(u		2		6			(bck lmd unr vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			700		350.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			1360		710.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2500		1220.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		57.75		28.0		50		4		4)
		(a3f:		45.5		21.0		50		4		4)
		(a4f:		38.5		17.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		57.75		28.0		50		4		4)
		(a3v:		45.5		21.0		50		4		4)
		(a4v:		38.5		17.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
uu
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(uu		2		9			(bck hgh rnd vwl )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			880		470.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2200		1100.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		52.5		24.5		50		4		4)
		(a3f:		31.5		14.0		50		4		4)
		(a4f:		24.5		10.5		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		52.5		24.5		50		4		4)
		(a3v:		31.5		14.0		50		4		4)
		(a4v:		24.5		10.5		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
v
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(v		20		4			(frc lbd vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1420		350.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		980.0		50		3		2)
		(b3:			150		75.0		50		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		47.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		75.0		50		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		47.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
w
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(w		10		8			(apr lbv vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			190		50.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			760		350.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2020		980.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		42		21.0		50		4		4)
		(a3f:		35		17.5		50		4		4)
		(a4f:		-16		7.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		57.75		28.0		50		4		4)
		(a2v:		42		21.0		50		4		4)
		(a3v:		35		17.5		50		4		4)
		(a4v:		-16		7.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
x
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(x		18		12			(frc vel vls )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	0		0.0		50		0		0)
		(aspiration:	60		30.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			190		110.0		50		3		3)
		(b1:			60		30.0		50		3		3)
		(f2:			1480		1550.0		50		3		3)
		(b2:			90		45.0		50		3		3)
		(f3:			2620		1580.0		50		3		3)
		(b3:			150		75.0		50		3		3)
		(fnz:		270		135.0		50		0		0)
		(a2f:		54.25		0.0		100		0		0)
		(a3f:		54.25		0.0		100		0		0)
		(a4f:		33.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		3)
		(b3f:		150		75.0		50		3		3)
		(anv:		-16		0.0		100		0		0)
		(a1v:		-16		0.0		100		0		0)
		(a2v:		54.25		0.0		100		0		0)
		(a3v:		54.25		0.0		100		0		0)
		(a4v:		33.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
y
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(y		10		7			(apr pal vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			250		110.0		50		4		4)
		(b1:			60		30.0		50		4		4)
		(f2:			2500		1190.0		50		4		4)
		(b2:			90		45.0		50		4		4)
		(f3:			2980		1460.0		50		4		4)
		(b3:			150		75.0		50		4		4)
		(fnz:		270		135.0		50		0		0)
		(a2f:		47.25		24.5		50		4		4)
		(a3f:		52.5		24.5		50		4		4)
		(a4f:		45.5		21.0		50		4		4)
		(a5f:		-16		-8.0		50		4		4)
		(a6f:		-16		-8.0		50		4		4)
		(bypass:		-16		-8.0		50		4		4)
		(b2f:		90		45.0		50		4		4)
		(b3f:		150		75.0		50		4		4)
		(anv:		-16		0.0		100		4		4)
		(a1v:		64.75		31.5		50		4		4)
		(a2v:		47.25		24.5		50		4		4)
		(a3v:		52.5		24.5		50		4		4)
		(a4v:		45.5		21.0		50		4		4))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
z
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(z		20		4			(alv frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	40		20.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	60		30.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		38.5		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		50.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		38.5		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		50.75		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
zh
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(zh		20		4			(frc pla vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			2020		1190.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		40.25		0.0		100		0		0)
		(a3f:		50.75		0.0		100		0		0)
		(a4f:		40.25		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		40.25		0.0		100		0		0)
		(a3v:		50.75		0.0		100		0		0)
		(a4v:		40.25		0.0		100		0		0))! !

!KlattSegmentSet methodsFor: 'default segments' stamp: 'len 12/6/1999 02:25'!
zz
	^ self segmentFromArray: 
		"name	rank	duration	features"
		#(zz		20		4			(alv frc vcd )
		"selector		steady	fixed	prop	extern	intern"
		(voicing:	62		31.0		50		0		0)
		(aspiration:	0		0.0		50		0		0)
		(friction:	0		0.0		50		0		0)
		(f1:			280		170.0		50		3		2)
		(b1:			60		30.0		50		3		2)
		(f2:			1720		950.0		50		3		2)
		(b2:			90		45.0		50		3		2)
		(f3:			2560		0.0		100		3		2)
		(b3:			150		0.0		100		3		2)
		(fnz:		270		135.0		50		0		0)
		(a2f:		38.5		0.0		100		0		0)
		(a3f:		38.5		0.0		100		0		0)
		(a4f:		50.75		0.0		100		0		0)
		(a5f:		-16		0.0		100		0		0)
		(a6f:		-16		0.0		100		0		0)
		(bypass:		-16		0.0		100		0		0)
		(b2f:		90		45.0		50		3		2)
		(b3f:		150		0.0		100		3		2)
		(anv:		-16		0.0		100		0		0)
		(a1v:		43.75		0.0		100		0		0)
		(a2v:		38.5		0.0		100		0		0)
		(a3v:		38.5		0.0		100		0		0)
		(a4v:		50.75		0.0		100		0		0))! !

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

KlattSegmentSet class
	instanceVariableNames: ''!

!KlattSegmentSet class methodsFor: 'instance creation' stamp: 'len 10/12/1999 00:47'!
arpabet
	^ self new initializeArpabet! !
Object subclass: #KlattSynthesizer
	instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate '
	classVariableNames: 'Epsilon '
	poolDictionaries: 'KlattResonatorIndices '
	category: 'Speech-Klatt'!
!KlattSynthesizer commentStamp: '<historical>' prior: 0!
My instances are Klatt-style cascade/parallel formant synthesizers, first described by Dennis Klatt in [1]. An updated version of the model was described in [2]. This version implements the LF (Liljencrants-Fant) glottal pulse model from [3], and the jitter and shimmer parameters suggested in [4]. For a description of the Klatt parameters, see KlattFrame.

References:
	[1] Klatt,D.H. "Software for a cascade/parallel formant synthesizer", in the Journal of the Acoustical Society of America, pages 971-995, volume 67, number 3, March 1980.
	[2] Klatt,D.H. and Klatt, L.C. "Analysis, synthesis and perception of voice quality variations among female and male talkers". In the Journal of the Acoustical Society of America, pages 820-857, volume 87, number 2. February 1990.
	[3] Fant, G., Liljencrants, J., & Lin, Q. "A four-parameter model of glottal flow", Speech Transmission Laboratory Qurterly Progress Report 4/85, KTH.
	[4] Alwan, A., Bangayan, P., Kreiman, J., and Long, C. "Time and Frequency Synthesis Parameters of Severely Pathological Voice Qualities."!


!KlattSynthesizer methodsFor: 'initialization' stamp: 'len 9/2/1999 01:44'!
defaultMillisecondsPerFrame
	"Default is 10 milliseconds per frame."
	^ 10! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'len 11/8/1999 01:25'!
initialize
	"Initialize the Klatt synthesizer."

	"Seed for noise generation:"
	seed _ 17.
	"Sampling rate and millseconds per frame:"
	self samplingRate: 22025.
	self millisecondsPerFrame: self defaultMillisecondsPerFrame.
	"Number of formants in the cascade branch: (0 to 8)"
	self cascade: 0! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'len 12/19/1999 05:36'!
initializeResonators
	resonators _ FloatArray new: 24 * 5		"24 resonators, 5 floats each"! !

!KlattSynthesizer methodsFor: 'initialization' stamp: 'len 12/19/1999 04:51'!
initializeState
	self initializeResonators.
	pitch _ 110.0.
	t0 _ (samplingRate / pitch) asInteger.
	nper _ 0.
	nopen _ 0.
	nmod _ 0.
	periodCount _ 0.
	samplesCount _ 0.
	vlast _ 0.0.
	glast _ 0.0.
	nlast _ 0.0.

	self ro: 0.25 ra: 0.01 rk: 0.25! !


!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:53'!
antiResonator: index frequency: freq bandwidth: bw
	"Set up an anti-resonator"
	| arg r a b c |
	arg _ 0.0 - Float pi / samplingRate * bw.
	r _ arg exp.
	c _ 0.0 - (r * r).
	arg _ Float pi * 2.0 / samplingRate * freq.
	b _ r * arg cos * 2.0.
	a _ 1.0 - b - c.
	a _ 1.0 / a.
	b _ 0.0 - b * a.
	c _ 0.0 - c * a.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:54'!
antiResonator: index value: aFloat
	| answer p1 |
	answer _ (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 _ self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: aFloat.
	^ answer! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:55'!
resonator: index frequency: freq bandwidth: bw
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	| arg r a b c |
	arg _ 0.0 - Float pi / samplingRate * bw.
	r _ arg exp.
	c _ 0.0 - (r * r).
	arg _ Float pi * 2.0 / samplingRate * freq.
	b _ r * arg cos * 2.0.
	a _ 1.0 - b - c.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 10/29/1999 01:32'!
resonator: index frequency: freq bandwidth: bw gain: gain
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	self resonator: index frequency: freq bandwidth: bw.
	self resonatorA: index put: (self resonatorA: index) * gain! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:55'!
resonator: index value: aFloat
	| answer p1 |
	answer _ (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 _ self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: answer.
	^ answer! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorA: index
	^resonators at: index * 5 - 4! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorA: index put: aFloat
	resonators at: index*5-4 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:58'!
resonatorB: index
	^resonators at: index*5-3! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorB: index put: aFloat
	resonators at: index*5-3 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorC: index
	^resonators at: index*5-2! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorC: index put: aFloat
	resonators at: index*5-2 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP1: index
	^resonators at: index*5-1! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP1: index put: aFloat
	resonators at: index*5-1 put: aFloat! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP2: index
	^resonators at: index*5! !

!KlattSynthesizer methodsFor: 'accessing-resonators' stamp: 'len 8/29/1999 23:59'!
resonatorP2: index put: aFloat
	resonators at: index*5 put: aFloat! !


!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/18/1999 00:50'!
cascade
	"Answer the number of formants in the cascade branch."
	^ cascade! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/18/1999 00:51'!
cascade: anInteger
	"Set the number of formants in the cascade branch."
	cascade _ anInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 10/8/1999 02:09'!
millisecondsPerFrame
	^ 1000.0 / self samplingRate * self samplesPerFrame! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/3/1999 02:48'!
millisecondsPerFrame: aNumber
	self samplesPerFrame: (aNumber * self samplingRate / 1000) asInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 8/24/1999 02:45'!
samplesPerFrame
	^ samplesPerFrame! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 9/2/1999 01:42'!
samplesPerFrame: anInteger
	samplesPerFrame _ anInteger! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 8/24/1999 02:45'!
samplingRate
	^ samplingRate! !

!KlattSynthesizer methodsFor: 'accessing' stamp: 'len 10/3/1999 20:23'!
samplingRate: anInteger
	samplingRate _ anInteger.
	self initializeState! !


!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'len 9/16/1999 00:28'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	expuphi _ (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !

!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'len 9/19/1999 02:38'!
ro: roNumber ra: raNumber rk: rkNumber
	| r d phi cosphi sinphi rphid u theta rho gamma gammapwr te ro ra rk |
	te _ (t0 * roNumber) asInteger.
	ro _ te asFloat / t0 asFloat.
	rk _ rkNumber.
	ra _ raNumber.

	ra <= 0.0
		ifTrue: [d _ 1.0]
		ifFalse: [r _ 1.0 - ro / ra.
				d _ 1.0 - (r / (r exp - 1.0))].

	phi _ Float pi * (rk + 1.0).
	cosphi _ phi cos.
	sinphi _ phi sin.
	rphid _ ra / ro * phi * d.

	u _ self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta _ phi / te.
	rho _ (u * theta) exp.
	a1 _ 2.0 * theta cos * rho.
	a2 _ 0.0 - (rho * rho).
	x2 _ 0.0.
	x1 _ rho * theta sin.

	gamma _ (-1.0 / (ra * t0)) exp.
	gammapwr _ gamma raisedTo: t0 - te.

	b1 _ gamma.
	c1 _ (1.0 - gamma) * gammapwr / (1.0 - gammapwr)! !

!KlattSynthesizer methodsFor: 'processing-LF' stamp: 'len 9/16/1999 00:28'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	qzero _ self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua _ 0. ub _ 1.
				qa _ qzero. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua _ ub. qa _ qb.
								ub _ ub * 2. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua _ -1. ub _ 0.
				qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb _ qzero.
				[qa < 0]
					whileTrue: [ub _ ua. qb _ qa.
								ua _ ua * 2. qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc _ ub + ua / 2. qc _ self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua _ uc. qa _ qc] ifFalse: [ub _ uc. qb _ qc]].
	^ ub + ua / 2! !


!KlattSynthesizer methodsFor: 'processing' stamp: 'len 12/1/1999 02:42'!
samplesFromFrames: aCollection
	| buffer index |
	buffer _ SoundBuffer newMonoSampleCount: aCollection size * samplesPerFrame.
	index _ 1.
	aCollection do: [ :each |
		self synthesizeFrame: each into: buffer startingAt: index.
		index _ samplesPerFrame + index].
	^ buffer! !

!KlattSynthesizer methodsFor: 'processing' stamp: 'len 9/4/1999 00:20'!
soundFromFrames: aCollection
	^ SampledSound samples: (self samplesFromFrames: aCollection) samplingRate: samplingRate! !

!KlattSynthesizer methodsFor: 'processing' stamp: 'len 12/21/1999 01:46'!
synthesizeFrame: aKlattFrame into: aSoundBuffer startingAt: index
	<primitive: 'primitiveSynthesizeFrameIntoStartingAt' module: 'Klatt'>
	KlattSynthesizerPlugin doPrimitive: 'primitiveSynthesizeFrameIntoStartingAt'! !


!KlattSynthesizer methodsFor: 'testing' stamp: 'len 9/27/1999 01:06'!
isAllParallel
	"Answer true if the receiver is not using the cascade branch."
	^ self cascade = 0! !

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

KlattSynthesizer class
	instanceVariableNames: ''!

!KlattSynthesizer class methodsFor: 'class initialization' stamp: 'len 9/25/1999 23:14'!
initialize
	"
	KlattSynthesizer initialize
	"
	Epsilon _ 1.0e-04.
	self initializePool! !

!KlattSynthesizer class methodsFor: 'class initialization' stamp: 'len 12/19/1999 05:30'!
initializePool
	| dict |
	(Smalltalk includesKey: #KlattResonatorIndices)
		ifFalse: [Smalltalk declare: #KlattResonatorIndices from: Undeclared].
	(Smalltalk at: #KlattResonatorIndices) isNil
		ifTrue: [(Smalltalk associationAt: #KlattResonatorIndices) value: Dictionary new].
	dict _ Smalltalk at: #KlattResonatorIndices.
	#(Rnpp Rtpp R1vp R2vp R3vp R4vp R2fp R3fp R4fp R5fp R6fp R1c R2c R3c R4c R5c R6c R7c R8c Rnpc Rnz Rtpc Rtz Rout)
		doWithIndex: [ :each :i | dict at: each asSymbol put: i]! !

!KlattSynthesizer class methodsFor: 'class initialization' stamp: 'sma 6/18/2000 11:22'!
obsolete
	Smalltalk removeKey: #KlattResonatorIndices ifAbsent: [].
	super obsolete! !


!KlattSynthesizer class methodsFor: 'instance creation' stamp: 'len 4/8/98 03:33'!
new
	^ super new initialize! !
InterpreterPlugin subclass: #KlattSynthesizerPlugin
	instanceVariableNames: 'resonators frame pitch t0 nper nopen nmod a1 a2 x1 x2 b1 c1 glast vlast nlast periodCount samplesCount seed cascade samplesPerFrame samplingRate '
	classVariableNames: 'A1v A2f A2v A3f A3v A4f A4v A5f A6f Anv Aspiration Atv B1 B2 B2f B3 B3f B4 B4f B5 B5f B6 B6f Bnp Bnz Btp Btz Bypass Db1 Df1 Diplophonia Epsilon F0 F1 F2 F3 F4 F5 F6 Flutter Fnp Fnz Friction Ftp Ftz Gain Jitter PI Ra Rk Ro Shimmer Turbulence Voicing '
	poolDictionaries: 'KlattResonatorIndices '
	category: 'VMConstruction-Plugins'!
!KlattSynthesizerPlugin commentStamp: '<historical>' prior: 0!
This is a pluggable primitive implementation of the KlattSynthesizer.!


!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:14'!
antiResonator: index frequency: freq bandwidth: bw
	"Set up an anti-resonator"
	| arg r a b c |
	self returnTypeC: 'void'.
	self var: 'freq' declareC: 'float freq'.
	self var: 'bw' declareC: 'float bw'.
	self var: 'arg' declareC: 'double arg'.
	self var: 'a' declareC: 'float a'.
	self var: 'b' declareC: 'float b'.
	self var: 'c' declareC: 'float c'.
	self var: 'r' declareC: 'float r'.
	arg _ 0.0 - PI / samplingRate * bw.
	r _ arg exp.
	c _ 0.0 - (r * r).
	arg _ PI * 2.0 / samplingRate * freq.
	b _ r * arg cos * 2.0.
	a _ 1.0 - b - c.
	a _ 1.0 / a.
	b _ 0.0 - b * a.
	c _ 0.0 - c * a.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:14'!
antiResonator: index value: aFloat
	| answer p1 |
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'aFloat' declareC: 'double aFloat'.
	self var: 'answer' declareC: 'double answer'.
	self var: 'p1' declareC: 'double p1'.
	answer _ (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 _ self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	self resonatorP2: index put: p1.
	self resonatorP1: index put: aFloat.
	^ answer! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:15'!
resonator: index frequency: freq bandwidth: bw
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	| arg r a b c |
	self returnTypeC: 'void'.
	self var: 'freq' declareC: 'float freq'.
	self var: 'bw' declareC: 'float bw'.
	self var: 'arg' declareC: 'double arg'.
	self var: 'a' declareC: 'float a'.
	self var: 'b' declareC: 'float b'.
	self var: 'c' declareC: 'float c'.
	self var: 'r' declareC: 'float r'.
	arg _ 0.0 - PI / samplingRate * bw.
	r _ arg exp.
	c _ 0.0 - (r * r).
	arg _ PI * 2.0 / samplingRate * freq.
	b _ r * arg cos * 2.0.
	a _ 1.0 - b - c.
	self resonatorA: index put: a.
	self resonatorB: index put: b.
	self resonatorC: index put: c! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 10/29/1999 01:32'!
resonator: index frequency: freq bandwidth: bw gain: gain
	"Convert formant frequencies and bandwidth into
	resonator difference equation coefficients."
	self returnTypeC: 'void'.
	self var: 'freq' declareC: 'float freq'.
	self var: 'bw' declareC: 'float bw'.
	self var: 'gain' declareC: 'float gain'.
	self resonator: index frequency: freq bandwidth: bw.
	self resonatorA: index put: (self resonatorA: index) * gain! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:15'!
resonator: index value: aFloat
	| answer p1 |
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'aFloat' declareC: 'float aFloat'.
	self var: 'answer' declareC: 'float answer'.
	self var: 'p1' declareC: 'float p1'.
	answer _ (self resonatorA: index) * aFloat
			+ ((self resonatorB: index) * (p1 _ self resonatorP1: index))
			+ ((self resonatorC: index) * (self resonatorP2: index)).
	"(p1 between: -100000 and: 100000) ifFalse: [self halt].
	(answer between: -100000 and: 100000) ifFalse: [self halt]."
	self resonatorP2: index put: p1.
	self resonatorP1: index put: answer.
	^ answer! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorA: index
	self inline: true.
	self returnTypeC: 'float'.
	^resonators at: index*5-5! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorA: index put: aFloat
	self inline: true.
	self returnTypeC: 'void'.
	self var: 'aFloat' declareC: 'float aFloat'.
	resonators at: index*5-5 put: aFloat! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorB: index
	self inline: true.
	self returnTypeC: 'float'.
	^resonators at: index*5-4! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorB: index put: aFloat
	self inline: true.
	self returnTypeC: 'void'.
	self var: 'aFloat' declareC: 'float aFloat'.
	resonators at: index*5-4 put: aFloat! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorC: index
	self inline: true.
	self returnTypeC: 'float'.
	^resonators at: index*5-3! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorC: index put: aFloat
	self inline: true.
	self returnTypeC: 'void'.
	self var: 'aFloat' declareC: 'float aFloat'.
	resonators at: index*5-3 put: aFloat! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorP1: index
	self inline: true.
	self returnTypeC: 'float'.
	^resonators at: index*5-2! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorP1: index put: aFloat
	self inline: true.
	self returnTypeC: 'void'.
	self var: 'aFloat' declareC: 'float aFloat'.
	resonators at: index*5-2 put: aFloat! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorP2: index
	self inline: true.
	self returnTypeC: 'float'.
	^resonators at: index*5-1! !

!KlattSynthesizerPlugin methodsFor: 'resonators' stamp: 'len 9/6/1999 00:16'!
resonatorP2: index put: aFloat
	self inline: true.
	self returnTypeC: 'void'.
	self var: 'aFloat' declareC: 'float aFloat'.
	resonators at: index*5-1 put: aFloat! !


!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'len 12/19/1999 04:55'!
glottalSource
	| x0 |
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'x0' declareC: 'float x0'.
	t0 = 0 ifTrue: [^ 0].
	nper < nopen
		ifTrue: [x0 _ a1 * x1 + (a2 * x2).
				x2 _ x1.
				x1 _ x0]
		ifFalse: [x0 _ b1 * x1 - c1.
				x1 _ x0].
	"Reset period when 'nper' reaches t0."
	nper >= t0 ifTrue: [nper _ 0. self pitchSynchronousReset].
	nper _ nper + 1.
	^ x0! !

!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'len 10/29/1999 02:24'!
normalizeGlottalPulse
	| s1 s2 s0 |
	self inline: true.
	self returnTypeC: 'void'.
	self var: 's0' declareC: 'float s0'.
	self var: 's1' declareC: 'float s1'.
	self var: 's2' declareC: 'float s2'.
	s0 _ 0.0.
	s1 _ x1.
	s2 _ x2.
	1 to: nopen do: [ :ingore |
		s0 _ a1 * s1 + (a2 * s2).
		s2 _ s1.
		s1 _ s0].
	s0 = 0.0 ifFalse: [x1 _ x1 / s0 * 10000.0]! !

!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'len 9/19/1999 02:29'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	self returnTypeC: 'float'.
	self var: 'u' declareC: 'float u'.
	self var: 'phi' declareC: 'float phi'.
	self var: 'cosphi' declareC: 'float cosphi'.
	self var: 'sinphi' declareC: 'float sinphi'.
	self var: 'rphid' declareC: 'float rphid'.
	self var: 'expuphi' declareC: 'float expuphi'.
	expuphi _ (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !

!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'len 11/8/1999 00:42'!
ro: roNumber ra: raNumber rk: rkNumber
	| r d phi cosphi sinphi rphid u theta rho gamma gammapwr te ro ra rk |

	self returnTypeC: 'void'.
	self var: 'roNumber' declareC: 'float roNumber'.
	self var: 'raNumber' declareC: 'float raNumber'.
	self var: 'rkNumber' declareC: 'float rkNumber'.
	self var: 'r' declareC: 'float r'.
	self var: 'd' declareC: 'float d'.
	self var: 'phi' declareC: 'float phi'.
	self var: 'cosphi' declareC: 'float cosphi'.
	self var: 'sinphi' declareC: 'float sinphi'.
	self var: 'rphid' declareC: 'float rphid'.
	self var: 'u' declareC: 'float u'.
	self var: 'theta' declareC: 'float theta'.
	self var: 'rho' declareC: 'float rho'.
	self var: 'gamma' declareC: 'float gamma'.
	self var: 'gammapwr' declareC: 'float gammapwr'.
	self var: 'ro' declareC: 'float ro'.
	self var: 'ra' declareC: 'float ra'.
	self var: 'rk' declareC: 'float rk'.

	te _ (t0 * roNumber) asInteger.
	ro _ te asFloat / t0 asFloat.
	rk _ rkNumber.
	ra _ raNumber.

	ra <= 0.0
		ifTrue: [d _ 1.0]
		ifFalse: [r _ 1.0 - ro / ra.
				d _ 1.0 - (r / (r exp - 1.0))].

	phi _ PI * (rk + 1.0).
	cosphi _ phi cos.
	sinphi _ phi sin.
	rphid _ ra / ro * phi * d.

	u _ self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta _ phi / te.
	rho _ (u * theta) exp.
	a1 _ 2.0 * theta cos * rho.
	a2 _ 0.0 - (rho * rho).
	x2 _ 0.0.
	x1 _ rho * theta sin.

	gamma _ (-1.0 / (ra * t0)) exp.
	gammapwr _ gamma raisedTo: t0 - te.

	b1 _ gamma.
	c1 _ (1.0 - gamma) * gammapwr / (1.0 - gammapwr).

	self normalizeGlottalPulse! !

!KlattSynthesizerPlugin methodsFor: 'processing-LF' stamp: 'len 9/20/1999 01:46'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	self returnTypeC: 'float'.
	self var: 'qzero' declareC: 'float qzero'.
	self var: 'ua' declareC: 'float ua'.
	self var: 'ub' declareC: 'float ub'.
	self var: 'qa' declareC: 'float qa'.
	self var: 'qb' declareC: 'float qb'.
	self var: 'uc' declareC: 'float uc'.
	self var: 'qc' declareC: 'float qc'.
	self var: 'phi' declareC: 'float phi'.
	self var: 'cosphi' declareC: 'float cosphi'.
	self var: 'sinphi' declareC: 'float sinphi'.
	self var: 'rphid' declareC: 'float rphid'.

	qzero _ self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua _ 0. ub _ 1.
				qa _ qzero. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua _ ub. qa _ qb.
								ub _ ub * 2. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua _ -1. ub _ 0.
				qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb _ qzero.
				[qa < 0]
					whileTrue: [ub _ ua. qb _ qa.
								ua _ ua * 2. qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc _ ub + ua / 2.0. qc _ self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua _ uc. qa _ qc] ifFalse: [ub _ uc. qb _ qc]].
	^ ub + ua / 2.0! !


!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 12/17/1999 03:16'!
addAmplitudeDiplophonia
	"Add diplophonia (bicyclic voice). Change voicing amplitude."
	self returnTypeC: 'void'.
	periodCount \\ 2 = 0
		ifFalse: [x1 _ x1 * (1.0 - (frame at: Diplophonia)).
				"x1 must be <= 0"
				x1 > 0 ifTrue: [x1 _ 0]]! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 12/17/1999 03:51'!
addFlutter
	"Add F0 flutter, as specified in:
		'Analysis, synthesis and perception of voice quality variations among
		female and male talkers' D.H. Klatt and L.C. Klatt JASA 87(2) February 1990.
	Flutter is added by applying a quasi-random element constructed from three
	slowly varying sine waves."
	| timeCount asin bsin csin deltaF0 |
	self returnTypeC: 'void'.
	self var: 'timeCount' declareC: 'float timeCount'.
	self var: 'asin' declareC: 'float asin'.
	self var: 'bsin' declareC: 'float bsin'.
	self var: 'csin' declareC: 'float csin'.
	self var: 'deltaF0' declareC: 'double deltaF0'.
	timeCount _ (self cCoerce: samplesCount to: 'float') / (self cCoerce: samplingRate to: 'float').
	asin _ (2.0 * PI * 12.7 * timeCount) sin.
	bsin _ (2.0 * PI * 7.1 * timeCount) sin.
	csin _ (2.0 * PI * 4.7 * timeCount) sin.
	deltaF0 _ (frame at: Flutter) * 2.0 * (frame at: F0) / 100.0 * (asin + bsin + csin).
	pitch _ pitch + deltaF0! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 12/17/1999 03:11'!
addFrequencyDiplophonia
	"Add diplophonia (bicyclic voice). Change F0."
	self returnTypeC: 'void'.
	periodCount \\ 2 = 0
		ifTrue: [pitch _ pitch + ((frame at: Diplophonia) * (frame at: F0) * (1.0 - (frame at: Ro)))]
		ifFalse: [pitch _ pitch - ((frame at: Diplophonia) * (frame at: F0) * (1.0 - (frame at: Ro)))]! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 11/22/1999 02:44'!
addJitter
	"Add jitter (random F0 perturbation)."
	self returnTypeC: 'void'.
	pitch _ pitch + (self nextRandom - 32767 * (frame at: Jitter) / 32768.0 * (frame at: F0))! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 11/22/1999 02:45'!
addShimmer
	"Add shimmer (random voicing amplitude perturbation)."
	self returnTypeC: 'void'.
	x1 _ x1 + (self nextRandom - 32767 * (frame at: Shimmer) / 32768.0 * x1).
	"x1 must be <= 0"
	x1 > 0 ifTrue: [x1 _ 0]! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 12/21/1999 02:24'!
pitchSynchronousReset
	self returnTypeC: 'void'.
	(frame at: F0) > 0
		ifTrue: [self voicedPitchSynchronousReset.
				periodCount _ periodCount + 1 \\ 65535]
		ifFalse: [t0 _ 1.
				nmod _ t0]! !

!KlattSynthesizerPlugin methodsFor: 'processing-voice' stamp: 'len 12/19/1999 04:52'!
voicedPitchSynchronousReset
	self returnTypeC: 'void'.

	"Set the pitch."
	pitch _ frame at: F0.

	"Add flutter and jitter (F0 perturbations)."
	self addFlutter.
	self addJitter.
	self addFrequencyDiplophonia.
	pitch < 0 ifTrue: [pitch _ 0].

	"Recompute t0 (it is the number of samples in one pitch period)."
	t0 _ (samplingRate / pitch) asInteger.

	"Duration of period before amplitude modulation."
	nmod _ t0.
	(frame at: Voicing) > 0 ifTrue: [nmod _ nmod // 2].

	"Set open phase of glottal period."
	nopen _ (t0 * (frame at: Ro)) asInteger.

	"Set the LF glottal pulse model parameters."
	self ro: (frame at: Ro) ra: (frame at: Ra) rk: (frame at: Rk).

	"Add shimmer and diplophonia amplitude pertirbations.
	(This must be done AFTER the actual computation of the LF parameters.)"
	self addShimmer.
	self addAmplitudeDiplophonia! !


!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 11/9/1999 23:37'!
cascadeBranch: source
	"Cascade vocal tract, excited by laryngeal sources.
	Nasal antiresonator, nasal resonator, tracheal antirresonator,
	tracheal resonator, then formants F8, F7, F6, F5, F4, F3, F2, F1."
	| out |
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'source' declareC: 'float source'.
	self var: 'out' declareC: 'float out'.
	cascade > 0 ifFalse: [^ 0.0].
	out _ self antiResonator: Rnz value: source.
	out _ self resonator: Rnpc value: out.
	out _ self antiResonator: Rtz value: out.
	out _ self resonator: Rtpc value: out.
	"Do not use unless sample rate >= 16000"
	cascade >= 8 ifTrue: [out _ self resonator: R8c value: out].
	"Do not use unless sample rate >= 16000"
	cascade >= 7 ifTrue: [out _ self resonator: R7c value: out].
	"Do not use unless long vocal tract or sample rate increased"
	cascade >= 6 ifTrue: [out _ self resonator: R6c value: out].
	cascade >= 5 ifTrue: [out _ self resonator: R5c value: out].
	cascade >= 4 ifTrue: [out _ self resonator: R4c value: out].
	cascade >= 3 ifTrue: [out _ self resonator: R3c value: out].
	cascade >= 2 ifTrue: [out _ self resonator: R2c value: out].
	cascade >= 1 ifTrue: [out _ self resonator: R1c value: out].
	^ out! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 10/29/1999 02:31'!
linearFromdB: aNumber
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'aNumber' declareC: 'double aNumber'.
	^ (2.0 raisedTo: (aNumber-87.0/6.0)) * 32.767! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 11/9/1999 22:40'!
nextRandom
	"Answer a random number between 0 and 65535."
	self inline: true.
	seed _ (seed * 1309) + 13849 bitAnd: 65535.
	^ seed! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 12/22/1999 02:38'!
parallelFrictionBranch: source
	"Friction-excited parallel vocal tract formants F6, F5, F4, F3, F2,
	outputs added with alternating sign. Sound source for other
	parallel resonators is friction plus first difference of
	voicing waveform."
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'source' declareC: 'float source'.
	^ (self resonator: R2fp value: source) - (self resonator: R3fp value: source) + (self resonator: R4fp value: source) - (self resonator: R5fp value: source) + (self resonator: R6fp value: source)! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 12/22/1999 02:37'!
parallelVoicedBranch: source
	"Voice-excited parallel vocal tract F1, F2, F3, F4, FNP and FTP."
	self inline: true.
	self returnTypeC: 'float'.
	self var: 'source' declareC: 'float source'.
	^ (self resonator: R1vp value: source) + (self resonator: R2vp value: source) + (self resonator: R3vp value: source) + (self resonator: R4vp value: source) + (self resonator: Rnpp value: source) + (self resonator: Rtpp value: source)! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 12/21/1999 02:25'!
setCurrentFrame: aKlattFrame
	| ampFNV ampFTV ampF1V ampF2V ampF3V ampF4V ampF2F ampF3F ampF4F ampF5F ampF6F |
	self returnTypeC: 'void'.
	self var: 'aKlattFrame' declareC: 'float *aKlattFrame'.
	self var: 'ampFNV' declareC: 'float ampFNV'.
	self var: 'ampFTV' declareC: 'float ampFTV'.
	self var: 'ampF1V' declareC: 'float ampF1V'.
	self var: 'ampF2V' declareC: 'float ampF2V'.
	self var: 'ampF3V' declareC: 'float ampF3V'.
	self var: 'ampF4V' declareC: 'float ampF4V'.
	self var: 'ampF2F' declareC: 'float ampF2F'.
	self var: 'ampF3F' declareC: 'float ampF3F'.
	self var: 'ampF4F' declareC: 'float ampF4F'.
	self var: 'ampF5F' declareC: 'float ampF5F'.
	self var: 'ampF6F' declareC: 'float ampF6F'.

	frame _ aKlattFrame.

	"Fudge factors..."
	ampFNV _ (self linearFromdB: (frame at: Anv)) * 0.6.	"-4.44 dB"
	ampFTV _ (self linearFromdB: (frame at: Atv)) * 0.6.		"-4.44 dB"
	ampF1V _ (self linearFromdB: (frame at: A1v)) * 0.4.		"-7.96 dB"
	ampF2V _ (self linearFromdB: (frame at: A2v)) * 0.15.	"-16.5 dB"
	ampF3V _ (self linearFromdB: (frame at: A3v)) * 0.06.	"-24.4 dB"
	ampF4V _ (self linearFromdB: (frame at: A4v)) * 0.04.	"-28.0 dB"
	ampF2F _ (self linearFromdB: (frame at: A2f)) * 0.15.		"-16.5 dB"
	ampF3F _ (self linearFromdB: (frame at: A3f)) * 0.06.	"-24.4 dB"
	ampF4F _ (self linearFromdB: (frame at: A4f)) * 0.04.	"-28.0 dB"
	ampF5F _ (self linearFromdB: (frame at: A5f)) * 0.022.	"-33.2 dB"
	ampF6F _ (self linearFromdB: (frame at: A6f)) * 0.03.	"-30.5 dB"

	"Set coefficients of variable cascade resonators"
	cascade >= 8
		ifTrue: [samplingRate >= 16000	"Inside Nyquist rate?"
					ifTrue: [self resonator: R8c frequency: 7500 bandwidth: 600]
					ifFalse: [cascade _ 6]].
	cascade >= 7
		ifTrue: [samplingRate >= 16000	"Inside Nyquist rate?"
					ifTrue: [self resonator: R7c frequency: 6500 bandwidth: 500]
					ifFalse: [cascade _ 6]].
	cascade >= 6 ifTrue: [self resonator: R6c frequency: (frame at: F6) bandwidth: (frame at: B6)].
	cascade >= 5 ifTrue: [self resonator: R5c frequency: (frame at: F5) bandwidth: (frame at: B5)].
	self resonator: R4c frequency: (frame at: F4) bandwidth: (frame at: B4).
	self resonator: R3c frequency: (frame at: F3) bandwidth: (frame at: B3).
	self resonator: R2c frequency: (frame at: F2) bandwidth: (frame at: B2).
	self resonator: R1c frequency: (frame at: F1) bandwidth: (frame at: B1).

	"Set coefficients of nasal and tracheal resonators and antiresonators"
	self resonator: Rnpc frequency: (frame at: Fnp) bandwidth: (frame at: Bnp).
	self resonator: Rtpc frequency: (frame at: Ftp) bandwidth: (frame at: Btp).
	self antiResonator: Rnz frequency: (frame at: Fnz) bandwidth: (frame at: Bnz).
	self antiResonator: Rtz frequency: (frame at: Ftz) bandwidth: (frame at: Btz).

	"Set coefficients of parallel resonators, and amplitude of outputs"
	self resonator: Rnpp frequency: (frame at: Fnp) bandwidth: (frame at: Bnp) gain: ampFNV.
	self resonator: Rtpp frequency: (frame at: Ftp) bandwidth: (frame at: Btp) gain: ampFTV.
	self resonator: R1vp frequency: (frame at: F1) bandwidth: (frame at: B1) gain: ampF1V.
	self resonator: R2vp frequency: (frame at: F2) bandwidth: (frame at: B2) gain: ampF2V.
	self resonator: R3vp frequency: (frame at: F3) bandwidth: (frame at: B3) gain: ampF3V.
	self resonator: R4vp frequency: (frame at: F4) bandwidth: (frame at: B4) gain: ampF4V.
	self resonator: R2fp frequency: (frame at: F2) bandwidth: (frame at: B2f) gain: ampF2F.
	self resonator: R3fp frequency: (frame at: F3) bandwidth: (frame at: B3f) gain: ampF3F.
	self resonator: R4fp frequency: (frame at: F4) bandwidth: (frame at: B4f) gain: ampF4F.
	self resonator: R5fp frequency: (frame at: F5) bandwidth: (frame at: B5f) gain: ampF5F.
	self resonator: R6fp frequency: (frame at: F6) bandwidth: (frame at: B6f) gain: ampF6F! !

!KlattSynthesizerPlugin methodsFor: 'processing' stamp: 'len 12/22/1999 02:42'!
synthesizeFrame: aKlattFrame into: buffer startingAt: startIndex
	| noise voice frictionNoise aspirationNoise glotout
	parGlotout source temp out
	index top
	voicing parVoicing turbulence friction aspiration bypass
	gain ampGain |

	self returnTypeC: 'void'.
	self var: 'aKlattFrame' declareC: 'float *aKlattFrame'.
	self var: 'buffer' declareC: 'short *buffer'.
	self var: 'noise' declareC: 'float noise'.
	self var: 'voice' declareC: 'float voice'.
	self var: 'frictionNoise' declareC: 'float frictionNoise'.
	self var: 'aspirationNoise' declareC: 'float aspirationNoise'.
	self var: 'voicing' declareC: 'float voicing'.
	self var: 'parVoicing' declareC: 'float parVoicing'.
	self var: 'turbulence' declareC: 'float turbulence'.
	self var: 'friction' declareC: 'float friction'.
	self var: 'aspiration' declareC: 'float aspiration'.
	self var: 'bypass' declareC: 'float bypass'.
	self var: 'glotout' declareC: 'float glotout'.
	self var: 'parGlotout' declareC: 'float parGlotout'.
	self var: 'source' declareC: 'float source'.
	self var: 'gain' declareC: 'float gain'.
	self var: 'ampGain' declareC: 'float ampGain'.
	self var: 'out' declareC: 'float out'.

	self setCurrentFrame: aKlattFrame.

	pitch > 0
		ifTrue: [voicing _ self linearFromdB: (frame at: Voicing) - 7.
				parVoicing _ self linearFromdB: (frame at: Voicing).
				turbulence _ (self linearFromdB: (frame at: Turbulence)) * 0.1]
		ifFalse: [voicing _ parVoicing _ turbulence _ 0.0].

	friction _ (self linearFromdB: (frame at: Friction)) * 0.25.
	aspiration _ (self linearFromdB: (frame at: Aspiration)) * 0.05.
	bypass _ (self linearFromdB: (frame at: Bypass)) * 0.05.		"-26.0 dB"

	"Flod overall gain into output resonator (low-pass filter)"
	gain _ (frame at: Gain) - 3.
	gain <= 0 ifTrue: [gain _ 57].
	ampGain _ self linearFromdB: gain.
	self resonator: Rout frequency: 0 bandwidth: samplingRate gain: ampGain.

	noise _ nlast.
	index _ startIndex.
	top _ samplesPerFrame + startIndex - 1.
	[index <= top] whileTrue: [
		"Get low-passed random number for aspiration and friction noise"
		noise _ (self nextRandom - 32768) asFloat / 4.0. "radom number between -8196.0 and 8196.0"

		"Tilt down noise spectrum by soft low-pass filter having
		 a pole near the origin in the z-plane."
		noise _ noise + (0.75 * nlast).
		nlast _ noise.

		"Amplitude modulate noise (reduce noise amplitude during second
		 half of glottal period) if voicing  simultaneously present."
		nper > nmod ifTrue: [noise _ noise * 0.5].

		"Compute frictation noise"
		frictionNoise _ friction * noise.

		"Compute voicing waveform."
		voice _ self glottalSource.
		vlast _ voice.

		"Add turbulence during glottal open phase.
		 Use random rather than noise because noise is low-passed."
		nper < nopen ifTrue: [voice _ voice + (turbulence * (self nextRandom - 32768) asFloat / 4.0)].

		"Set amplitude of voicing."
		glotout _ voicing * voice.
		parGlotout _ parVoicing * voice.

		"Compute aspiration amplitude and add to voicing source."
		aspirationNoise _ aspiration * noise.
		glotout _ glotout + aspirationNoise.
		parGlotout _ parGlotout + aspirationNoise.

		"Cascade vocal tract, excited by laryngeal sources.
		 Nasal antiresonator, nasal resonator, trachearl antirresonator,
		 tracheal resonator, then formants F8, F7, F6, F5, F4, F3, F2, F1."
		out _ self cascadeBranch: glotout.

		"Voice-excited parallel vocal tract F1, F2, F3, F4, FNP and FTP."
		source _ parGlotout.	"Source is voicing plus aspiration."
		out _ out + (self parallelVoicedBranch: source).

		"Friction-excited parallel vocal tract formants F6, F5, F4, F3, F2,
		 outputs added with alternating sign. Sound source for other
		 parallel resonators is friction plus first difference of
		 voicing waveform."
		source _ frictionNoise + parGlotout - glast.
		glast _ parGlotout.
		out _ (self parallelFrictionBranch: source) - out.

		"Apply bypas and output low-pass filter"
		out _ bypass * source - out.
		out _ self resonator: Rout value: out.
		temp _ (out * ampGain) asInteger.
		temp < -32768 ifTrue: [temp _ -32768].
		temp > 32767 ifTrue: [temp _ 32767].
		buffer at: index - 1 put: temp.
		index _ index + 1.
		samplesCount _ samplesCount + 1]! !


!KlattSynthesizerPlugin methodsFor: 'primitives' stamp: 'len 9/26/1999 02:30'!
primitiveSynthesizeFrameIntoStartingAt
	| aKlattFrame buffer startIndex rcvr bufferOop |
	self export: true.
	self var: 'aKlattFrame' declareC: 'float *aKlattFrame'.
	self var: 'buffer' declareC: 'short *buffer'.
	aKlattFrame _ self checkedFloatPtrOf: (interpreterProxy stackValue: 2).
	buffer _ self checkedShortPtrOf: (bufferOop _ interpreterProxy stackValue: 1).
	startIndex _ interpreterProxy stackIntegerValue: 0.
	interpreterProxy failed ifTrue: [^nil].
	rcvr _ interpreterProxy stackObjectValue: 3.
	(self loadFrom: rcvr) ifFalse:[^nil].
	interpreterProxy success: (interpreterProxy stSizeOf: bufferOop) * 2 >= samplesPerFrame.
	interpreterProxy failed ifTrue: [^nil].
	self synthesizeFrame: aKlattFrame into: buffer startingAt: startIndex.
	(self saveTo: rcvr) ifFalse: [^nil].
	interpreterProxy pop: 3! !


!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'hmm 5/10/1999 06:49'!
checkedFloatPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	self returnTypeC:'float *'.
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'float *'! !

!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'hmm 5/10/1999 06:50'!
checkedShortPtrOf: oop
	"Return the first indexable word of oop which is assumed to be variableWordSubclass"
	self returnTypeC:'short *'.
	interpreterProxy success: (interpreterProxy isWords: oop).
	interpreterProxy failed ifTrue:[^0].
	^self cCoerce: (interpreterProxy firstIndexableField: oop) to:'short *'! !

!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'len 12/17/1999 03:27'!
loadFrom: klattOop
	| oop |
	interpreterProxy success: (interpreterProxy slotSizeOf: klattOop) = 22.
	interpreterProxy failed ifTrue:[^ false].

	oop _ interpreterProxy fetchPointer: 0 ofObject: klattOop.
	resonators _ self checkedFloatPtrOf: oop.

	pitch _ interpreterProxy fetchFloat: 2 ofObject: klattOop.
	t0 _ interpreterProxy fetchInteger: 3 ofObject: klattOop.
	nper _ interpreterProxy fetchInteger: 4 ofObject: klattOop.
	nopen _ interpreterProxy fetchInteger: 5 ofObject: klattOop.
	nmod _ interpreterProxy fetchInteger: 6 ofObject: klattOop.
	a1 _ interpreterProxy fetchFloat: 7 ofObject: klattOop.
	a2 _ interpreterProxy fetchFloat: 8 ofObject: klattOop.
	x1 _ interpreterProxy fetchFloat: 9 ofObject: klattOop.
	x2 _ interpreterProxy fetchFloat: 10 ofObject: klattOop.
	b1 _ interpreterProxy fetchFloat: 11 ofObject: klattOop.
	c1 _ interpreterProxy fetchFloat: 12 ofObject: klattOop.
	glast _ interpreterProxy fetchFloat: 13 ofObject: klattOop.
	vlast _ interpreterProxy fetchFloat: 14 ofObject: klattOop.
	nlast _ interpreterProxy fetchFloat: 15 ofObject: klattOop.
	periodCount _ interpreterProxy fetchInteger: 16 ofObject: klattOop.
	samplesCount _ interpreterProxy fetchInteger: 17 ofObject: klattOop.
	seed _ interpreterProxy fetchInteger: 18 ofObject: klattOop.
	cascade _ interpreterProxy fetchInteger: 19 ofObject: klattOop.
	samplesPerFrame _ interpreterProxy fetchInteger: 20 ofObject: klattOop.
	samplingRate _ interpreterProxy fetchInteger: 21 ofObject: klattOop.

	^ interpreterProxy failed == false! !

!KlattSynthesizerPlugin methodsFor: 'private' stamp: 'len 12/19/1999 05:25'!
saveTo: origKlattOop
	| pitchOop a1Oop a2Oop x1Oop x2Oop b1Oop c1Oop glastOop vlastOop nlastOop klattOop |
	interpreterProxy pushRemappableOop: origKlattOop.
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: pitch).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: a1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: a2).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: x1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: x2).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: b1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: c1).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: glast).
	interpreterProxy pushRemappableOop: (interpreterProxy floatObjectOf: vlast).
	nlastOop _ interpreterProxy floatObjectOf: nlast.
	vlastOop _ interpreterProxy popRemappableOop.
	glastOop _ interpreterProxy popRemappableOop.
	c1Oop _ interpreterProxy popRemappableOop.
	b1Oop _ interpreterProxy popRemappableOop.
	x2Oop _ interpreterProxy popRemappableOop.
	x1Oop _ interpreterProxy popRemappableOop.
	a2Oop _ interpreterProxy popRemappableOop.
	a1Oop _ interpreterProxy popRemappableOop.
	pitchOop _ interpreterProxy popRemappableOop.
	klattOop _ interpreterProxy popRemappableOop.
	interpreterProxy failed ifTrue:[^ false].

	interpreterProxy storePointer: 2 ofObject: klattOop withValue: pitchOop.
	interpreterProxy storeInteger: 3 ofObject: klattOop withValue: t0.
	interpreterProxy storeInteger: 4 ofObject: klattOop withValue: nper.
	interpreterProxy storeInteger: 5 ofObject: klattOop withValue: nopen.
	interpreterProxy storeInteger: 6 ofObject: klattOop withValue: nmod.
	interpreterProxy storePointer: 7 ofObject: klattOop withValue: a1Oop.
	interpreterProxy storePointer: 8 ofObject: klattOop withValue: a2Oop.
	interpreterProxy storePointer: 9 ofObject: klattOop withValue: x1Oop.
	interpreterProxy storePointer: 10 ofObject: klattOop withValue: x2Oop.
	interpreterProxy storePointer: 11 ofObject: klattOop withValue: b1Oop.
	interpreterProxy storePointer: 12 ofObject: klattOop withValue: c1Oop.
	interpreterProxy storePointer: 13 ofObject: klattOop withValue: glastOop.
	interpreterProxy storePointer: 14 ofObject: klattOop withValue: vlastOop.
	interpreterProxy storePointer: 15 ofObject: klattOop withValue: nlastOop.
	interpreterProxy storeInteger: 16 ofObject: klattOop withValue: periodCount.
	interpreterProxy storeInteger: 17 ofObject: klattOop withValue: samplesCount.
	interpreterProxy storeInteger: 18 ofObject: klattOop withValue: seed.

	^ interpreterProxy failed == false! !

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

KlattSynthesizerPlugin class
	instanceVariableNames: ''!

!KlattSynthesizerPlugin class methodsFor: 'class initialization' stamp: 'len 9/25/1999 23:12'!
initialize
	"
	KlattSynthesizerPlugin initialize
	"
	KlattFrame parameterNames
		doWithIndex: [ :each :i | self classPool at: each capitalized asSymbol put: i-1].
	PI _ Float pi	.
	Epsilon _ 1.0e-04! !


!KlattSynthesizerPlugin class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:39'!
declareCVarsIn: cg 
	cg var: #resonators type: #'float*'.
	cg var: #frame type: #'float*'.
	cg var: #pitch type: #float.
	cg var: #a1 type: #float.
	cg var: #a2 type: #float.
	cg var: #x1 type: #float.
	cg var: #x2 type: #float.
	cg var: #b1 type: #float.
	cg var: #c1 type: #float.
	cg var: #glast type: #float.
	cg var: #vlast type: #float.
	cg var: #nlast type: #float! !

!KlattSynthesizerPlugin class methodsFor: 'translation' stamp: 'len 9/25/1999 23:14'!
moduleName
	"
	KlattSynthesizerPlugin translateDoInlining: true
	"
	^ 'Klatt'! !
Voice subclass: #KlattVoice
	instanceVariableNames: 'segments lastEvent lastEventTime left current right synthesizer patternFrame breathiness tract '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!KlattVoice commentStamp: '<historical>' prior: 0!
My instances are voices that play PhoneticEvents using a KlattSynthesizer and KlattSegments. There are many controls to change voice personalities, such as vocal tract length, breathiness, jitter, shimmer and glottal pulse shape.!


!KlattVoice methodsFor: 'initialization' stamp: 'len 12/6/1999 03:43'!
defaultPatternFrame
	^ KlattFrame default clone
		f0: 133;
		flutter: 0; jitter: 0; shimmer: 0; diplophonia: 0;
		voicing: 60;
		aspiration: 0;
		friction: 0;
		bypass: 0;
		turbulence: 0;
		ro: 0.5; rk: 0.25; ra: 0.01;
		f1: 500;		b1: 60;
		f2: 1500;		b2: 90;
		f3: 2800;	b3: 150;
		f4: 3250;	b4: 200;
		f5: 3700;	b5: 200;
		f6: 4990;	b6: 500;
		fnz: 270;	bnz: 100;
		fnp: 270;	bnp: 100;
		b2f: 200;
		b3f: 350;
		b4f: 500;
		b5f: 600;
		b6f: 800;
		anv: 0;
		gain: 61! !

!KlattVoice methodsFor: 'initialization' stamp: 'len 12/6/1999 00:00'!
initialize
	super initialize.
	synthesizer _ KlattSynthesizer new cascade: 0.
	self segments: KlattSegmentSet arpabet.
	self patternFrame: self defaultPatternFrame.
	self breathiness: 0.0.
	self tract: 17.3. "Set a male vocal tract."
	self reset! !


!KlattVoice methodsFor: 'accessing-private' stamp: 'len 9/27/1999 01:40'!
patternFrame
	^ patternFrame! !

!KlattVoice methodsFor: 'accessing-private' stamp: 'len 12/2/1999 03:08'!
patternFrame: aKlattFrame
	patternFrame isNil ifTrue: [patternFrame _ aKlattFrame. ^ self].
	patternFrame replaceFrom: 1 to: patternFrame size with: aKlattFrame! !


!KlattVoice methodsFor: 'accessing' stamp: 'len 12/6/1999 03:43'!
phonemes
	^ self segments phonemes! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 9/6/1999 01:21'!
samplingRate
	^ self synthesizer samplingRate! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 10/12/1999 00:41'!
segments
	^ segments! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 10/12/1999 00:51'!
segments: aKlattSegmentSet
	segments _ aKlattSegmentSet! !

!KlattVoice methodsFor: 'accessing' stamp: 'len 9/6/1999 01:21'!
synthesizer
	^ synthesizer! !


!KlattVoice methodsFor: 'personality' stamp: 'len 11/30/1999 03:26'!
breathiness
	^ breathiness! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/30/1999 03:26'!
breathiness: aNumber
	breathiness _ aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
diplophonia
	^ self patternFrame diplophonia! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
diplophonia: aNumber
	self patternFrame diplophonia: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
flutter
	^ self patternFrame flutter! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
flutter: aNumber
	self patternFrame flutter: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
jitter
	^ self patternFrame jitter! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
jitter: aNumber
	self patternFrame jitter: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
ra
	^ self patternFrame ra! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
ra: aNumber
	self patternFrame ra: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
rk
	^ self patternFrame rk! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:17'!
rk: aNumber
	self patternFrame rk: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
ro
	^ self patternFrame ro! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
ro: aNumber
	self patternFrame ro: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:16'!
shimmer
	^ self patternFrame shimmer! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:15'!
shimmer: aNumber
	self patternFrame shimmer: aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 12/1/1999 03:37'!
tract
	^ tract! !

!KlattVoice methodsFor: 'personality' stamp: 'len 12/1/1999 03:37'!
tract: aNumber
	tract _ aNumber! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
turbulence
	^ self patternFrame turbulence! !

!KlattVoice methodsFor: 'personality' stamp: 'len 11/29/1999 02:18'!
turbulence: aNumber
	self patternFrame turbulence: aNumber! !


!KlattVoice methodsFor: 'editing' stamp: 'len 12/2/1999 02:52'!
edit
	self editor openInWorld! !

!KlattVoice methodsFor: 'editing' stamp: 'len 12/6/1999 02:27'!
editor
	^ KlattFrameMorph new
		frame: self patternFrame edit: #(flutter jitter shimmer diplophonia ro rk ra turbulence gain);
		addSliderForParameter: #breathiness target: self min: 0.0 max: 1.0 description: 'Amount of breathiness';
		addSliderForParameter: #tract target: self min: 10.0 max: 20.0 description: 'Vocal tract length (average male=17.3, average female=14.4)'! !


!KlattVoice methodsFor: 'playing' stamp: 'len 12/22/1999 03:52'!
flush
	"Play all the events in the queue, and then reset."
	| lastEventSegments |
	lastEvent isNil
		ifFalse: [lastEventSegments _ self segments at: lastEvent phoneme ifAbsent: [self segments silence].
				self playEvent: lastEvent segments: lastEventSegments boundary: self segments end at: lastEventTime].
	super flush.
	self reset! !

!KlattVoice methodsFor: 'playing' stamp: 'len 12/22/1999 03:19'!
playPhoneticEvent: event at: time
	| lastEventSegments boundarySegment |
	"Play an event."
	lastEvent isNil
		ifFalse: [lastEventSegments _ self segments at: lastEvent phoneme ifAbsent: [self segments silence].
				boundarySegment _ (self segments at: event phoneme ifAbsent: [self segments silence]) first.
				self playEvent: lastEvent segments: lastEventSegments boundary: boundarySegment at: lastEventTime].
	lastEvent _ event.
	lastEventTime _ time! !

!KlattVoice methodsFor: 'playing' stamp: 'len 12/22/1999 03:19'!
reset
	"Reset the state of the receiver."
	super reset.
	lastEvent _ lastEventTime _ nil.
	current _ right _ left _ self segments end! !


!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/6/1999 03:21'!
currentFramesCount: n
	| answer |
	answer _ current left: left right: right speed: n / current duration asFloat pattern: self patternFrame.
	answer size > 0 ifTrue: [self patternFrame: answer last].
	^ answer! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 9/30/1999 22:34'!
dBFromLinear: aNumber
	^ aNumber log / 2 log * 6.0 + 87.0! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/8/1999 20:56'!
durationsForEvent: event segments: segs
	| scale |
	scale _ event duration / ((segs inject: 0 into: [ :result :each | result + each duration]) * 10 / 1000.0).
	^ segs collect: [ :each | (each duration * scale) rounded]! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/6/1999 03:48'!
formantScale
	self flag: #fixThis. "NOTE: this approximation is good only for vocal-tract lengths near 14.4 and 17.3 (and between them)... but it is certainly wrong for lengths such as 10 or 20."
	^ (17.3 - self tract) / (17.3 - 14.4) * 0.175 + 1.0! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 9/30/1999 22:34'!
linearFromdB: aNumber
	^ (2 raisedTo: (aNumber-87/6.0))! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/19/1999 04:26'!
playEvent: event frames: frames at: time
	| frame breathyAspiration formantScale |
	breathyAspiration _ self dBFromLinear: (self linearFromdB: 68) * self breathiness.
	formantScale _ self formantScale.
	1 to: frames size do: [ :each |
		frame _ frames at: each.
		frame gain: (self dBFromLinear: (self linearFromdB: frame gain) * event loudness).
		frame f0: (event pitchAt: each - 1 * event duration / frames size).
		frame voicing: (self dBFromLinear: (self linearFromdB: frame voicing) * (1.0 - self breathiness)).
		frame aspiration: (frame aspiration max: breathyAspiration).
		frame
			f1: frame f1 * formantScale;
			f2: frame f2 * formantScale;
			f3: frame f3 * formantScale;
			f4: frame f4 * formantScale;
			f5: frame f5 * formantScale;
			f6: frame f6 * formantScale].
	"Transcript cr; show: (event duration * 1000 / frames size) printString."
	synthesizer millisecondsPerFrame: event duration * 1000 / frames size.
	self playBuffer: (synthesizer samplesFromFrames: frames) at: time! !

!KlattVoice methodsFor: 'playing-private' stamp: 'len 12/22/1999 03:44'!
playEvent: event segments: segs boundary: boundarySegment at: time
	| frames stream dur durations |
	frames _ OrderedCollection new.
	stream _ ReadStream on: segs.
	durations _ ReadStream on: (self durationsForEvent: event segments: segs).
	[stream atEnd]
		whileFalse: [current _ stream next.
					dur _ durations next.
					dur > 0
						ifTrue: [right _ stream atEnd ifTrue: [boundarySegment] ifFalse: [stream peek].
								frames addAll: (self currentFramesCount: dur)].
					left _ current].
	frames isEmpty ifTrue: [^ self].
	self playEvent: event frames: frames at: time! !
TestInterpreterPlugin subclass: #LargeIntegersPlugin
	instanceVariableNames: 'andOpIndex orOpIndex xorOpIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!LargeIntegersPlugin commentStamp: '<historical>' prior: 0!
LargeIntegersPlugin provides functions for speeding up LargeInteger arithmetics.

Inst vars:
	andOpIndex			C constant
	orOpIndex			C constant
	xorOpIndex 			C constant
Used like an enum, in ST one would use symbols instead.

Class vars:
	none


Evaluations
-------------

Try

	LargeIntegersTest getModuleName.

If it is nil, you probably have an older LargeInteger module or none at all; it works for version number 'v1.1' or higher.


History
--------

v1.2

- fix: >>anyBitOfBytes: aBytesOop from: start to: stopArg

v1.1

- >>primGetModuleName for checking the version of the plugin;

- >>primDigitBitShiftMagnitude and >>primAnyBitFrom:to: for supporting - not installing!! - unification of shift semantics of negative Integers;

v1.0

- speeds up digitDiv:neg: at about 20%.
	In >>cCoreDigitDivDiv:len:rem:len:quo:len: the 'nibble' arithmetic is removed.

!


!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/9/2000 10:25'!
primAnyBitFrom: from to: to 
	| integer large |
	self debugCode: [self msg: 'primAnyBitFrom: from to: to'].
	integer _ self
				primitive: 'primAnyBitFromTo'
				parameters: #(#SmallInteger #SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: integer)
		ifTrue: ["convert it to a not normalized LargeInteger"
			large _ self createLargeFromSmallInteger: integer]
		ifFalse: [large _ integer].
	^ (self
		anyBitOfBytes: large
		from: from
		to: to)
		asOop: Boolean! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:06'!
primDigitAdd: secondInteger 
	""
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitAdd: secondInteger'].
	firstInteger _ self
				primitive: 'primDigitAdd'
				parameters: #(Integer )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self digitAddLarge: firstLarge with: secondLarge! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitAnd: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitAnd: secondInteger'].
	firstInteger _ self
				primitive: 'primDigitBitAnd'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: andOpIndex! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitOr: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitOr: secondInteger'].
	firstInteger _ self
				primitive: 'primDigitBitOr'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: orOpIndex! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 6/9/2000 10:49'!
primDigitBitShiftMagnitude: shiftCount 
	| rShift aLarge anInteger |
	self debugCode: [self msg: 'primDigitBitShiftMagnitude: shiftCount'].
	anInteger _ self
				primitive: 'primDigitBitShiftMagnitude'
				parameters: #(#SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge _ self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge _ anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift _ 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:08'!
primDigitBitXor: secondInteger 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstInteger |
	self debugCode: [self msg: 'primDigitBitXor: secondInteger'].
	firstInteger _ self
				primitive: 'primDigitBitXor'
				parameters: #(Integer )
				receiver: #Integer.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: xorOpIndex! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:08'!
primDigitCompare: secondInteger 
	| firstVal secondVal firstInteger |
	self debugCode: [self msg: 'primDigitCompare: secondInteger'].
	firstInteger _ self
		primitive: 'primDigitCompare'
		parameters: #(Integer  )
		receiver: #Integer.
	"shortcut: aSmallInteger has to be smaller in Magnitude as aLargeInteger"
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["first"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					(firstVal _ interpreterProxy integerValueOf: firstInteger) > (secondVal _ interpreterProxy integerValueOf: secondInteger)
						ifTrue: [^ 1 asOop: SmallInteger"first > second"]
						ifFalse: [firstVal < secondVal
								ifTrue: [^ -1 asOop: SmallInteger"first < second"]
								ifFalse: [^ 0 asOop: SmallInteger"first = second"]]]
				ifFalse: ["SECOND"
					^ -1 asOop: SmallInteger"first < SECOND"]]
		ifFalse: ["FIRST"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					^ 1 asOop: SmallInteger"FIRST > second"]
				ifFalse: ["SECOND"
					^ self digitCompareLarge: firstInteger with: secondInteger]]! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:09'!
primDigitDiv: secondInteger negative: neg 
	"Answer the result of dividing firstInteger by secondInteger.  Fail if      
	parameters are not integers or secondInteger is zero."
	| firstAsLargeInteger secondAsLargeInteger firstInteger |
	self debugCode: [self msg: 'primDigitDiv: secondInteger negative: neg'].
	firstInteger _ self
				primitive: 'primDigitDivNegative'
				parameters: #(Integer Boolean )
				receiver: #Integer.
	"Coerce SmallIntegers to corresponding (not normalized) large integers    
	  and check for zerodivide."
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert to LargeInteger"
			self remapOop: secondInteger in: [firstAsLargeInteger _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstAsLargeInteger _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: 
			["check for zerodivide and convert to LargeInteger"
			(interpreterProxy integerValueOf: secondInteger)
				= 0 ifTrue: [^ interpreterProxy primitiveFail].
			self remapOop: firstAsLargeInteger in: [secondAsLargeInteger _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondAsLargeInteger _ secondInteger].
	^ self
		digitDivLarge: firstAsLargeInteger
		with: secondAsLargeInteger
		negative: neg! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:09'!
primDigitMultiply: secondInteger negative: neg 
	""
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitMultiply: secondInteger negative: neg'].
	firstInteger _ self
		primitive: 'primDigitMultiplyNegative'
		parameters: #( Integer Boolean )
		receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self
		digitMultiplyLarge: firstLarge
		with: secondLarge
		negative: neg! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:10'!
primDigitSubtract: secondInteger 
	""
	| firstLarge secondLarge firstInteger |
	self debugCode: [self msg: 'primDigitSubtract: secondInteger'].
	firstInteger _ self
		primitive: 'primDigitSubtract'
		parameters: #( Integer )
		receiver: #Integer.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self digitSubLarge: firstLarge with: secondLarge! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:11'!
primNormalizeNegative
	""
	| rcvr |
	self debugCode: [self msg: 'primNormalizeNegative'].
	rcvr _ self
				primitive: 'primNormalizeNegative'
				parameters: #()
				receiver: #LargeNegativeInteger.
	^ self normalizeNegative: rcvr! !

!LargeIntegersPlugin methodsFor: 'Integer primitives' stamp: 'sr 4/8/2000 02:11'!
primNormalizePositive
	| rcvr |
	""
	self debugCode: [self msg: 'primNormalizePositive'].
	rcvr _ self
		primitive: 'primNormalizePositive'
		parameters: #()
		receiver: #LargePositiveInteger.
	^ self normalizePositive: rcvr! !


!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:05'!
primDigit: anInteger bitShift: shiftCount 
	| rShift aLarge |
	self debugCode: [self msg: 'primDigit: anInteger bitShift: shiftCount'].
	self
		primitive: '_primDigitBitShift'
		parameters: #(Integer SmallInteger )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge _ self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge _ anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift _ 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:06'!
primDigitAdd: firstInteger with: secondInteger 
	""
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitAdd: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitAddWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self digitAddLarge: firstLarge with: secondLarge! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:07'!
primDigitBitLogic: firstInteger with: secondInteger op: opIndex 
	"Bit logic here is only implemented for positive integers or Zero; if any arg is negative, it fails."
	self debugCode: [self msg: 'primDigitBitLogic: firstInteger with: secondInteger op: opIndex'].
	self
		primitive: 'primDigitBitLogicWithOp'
		parameters: #(Integer Integer SmallInteger )
		receiver: #Oop.
	^ self
		digitBitLogic: firstInteger
		with: secondInteger
		opIndex: opIndex! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:08'!
primDigitCompare: firstInteger with: secondInteger 
	| firstVal secondVal |
	self debugCode: [self msg: 'primDigitCompare: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitCompareWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	"shortcut: aSmallInteger has to be smaller in Magnitude as aLargeInteger"
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["first"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second"
					(firstVal _ interpreterProxy integerValueOf: firstInteger) > (secondVal _ interpreterProxy integerValueOf: secondInteger)
						ifTrue: [^ 1 asOop: SmallInteger"first > second"]
						ifFalse: [firstVal < secondVal
								ifTrue: [^ -1 asOop: SmallInteger"first < second"]
								ifFalse: [^ 0 asOop: SmallInteger"first = second"]]]
				ifFalse: ["SECOND" ^ -1 asOop: SmallInteger"first < SECOND"]]
		ifFalse: ["FIRST"
			(interpreterProxy isIntegerObject: secondInteger)
				ifTrue: ["second" ^ 1 asOop: SmallInteger"FIRST > second"]
				ifFalse: ["SECOND"
					^ self digitCompareLarge: firstInteger with: secondInteger]]! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:09'!
primDigitDiv: firstInteger with: secondInteger negative: neg 
	"Answer the result of dividing firstInteger by secondInteger.  Fail if     
	parameters are not integers or secondInteger is zero."
	| firstAsLargeInteger secondAsLargeInteger |
	self debugCode: [self msg: 'primDigitDiv: firstInteger with: secondInteger negative: neg'].
	self
		primitive: 'primDigitDivWithNegative'
		parameters: #(Integer Integer Boolean )
		receiver: #Oop.
	"Coerce SmallIntegers to corresponding (not normalized) large integers    
	 and check for zerodivide."
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert to LargeInteger"
			self remapOop: secondInteger in: [firstAsLargeInteger _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstAsLargeInteger _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: 
			["check for zerodivide and convert to LargeInteger"
			(interpreterProxy integerValueOf: secondInteger)
				= 0 ifTrue: [^ interpreterProxy primitiveFail].
			self remapOop: firstAsLargeInteger in: [secondAsLargeInteger _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondAsLargeInteger _ secondInteger].
	^ self
		digitDivLarge: firstAsLargeInteger
		with: secondAsLargeInteger
		negative: neg! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:10'!
primDigitMultiply: firstInteger with: secondInteger negative: neg
	""
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitMultiply: firstInteger with: secondInteger negative: neg'].
	self
		primitive: 'primDigitMultiplyWithNegative'
		parameters: #(Integer Integer Boolean )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self
		digitMultiplyLarge: firstLarge
		with: secondLarge
		negative: neg! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:11'!
primDigitSubtract: firstInteger with: secondInteger
	""
	| firstLarge secondLarge |
	self debugCode: [self msg: 'primDigitSubtract: firstInteger with: secondInteger'].
	self
		primitive: 'primDigitSubtractWith'
		parameters: #(Integer Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: [firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: [secondLarge _ secondInteger].
	^ self digitSubLarge: firstLarge with: secondLarge! !

!LargeIntegersPlugin methodsFor: 'development primitives' stamp: 'sr 4/8/2000 02:11'!
primNormalize: anInteger 
"Parameter specification #(Integer) doesn't convert!!"
	self debugCode: [self msg: 'primNormalize: anInteger'].
	self
		primitive: 'primNormalize'
		parameters: #(Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: [^ anInteger].
	^ self normalize: anInteger! !


!LargeIntegersPlugin methodsFor: 'control & support primitives' stamp: 'sr 4/8/2000 02:13'!
primAsLargeInteger: anInteger
	"Converts a SmallInteger into a - non normalized!! - LargeInteger;          
	 aLargeInteger will be returned unchanged."
	"Do not check for forced fail, because we need this conversion to test the 
	plugin in ST during forced fail, too."
	self debugCode: [self msg: 'primAsLargeInteger: anInteger'].
	self
		primitive: 'primAsLargeInteger'
		parameters: #(Integer )
		receiver: #Oop.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: [^ self createLargeFromSmallInteger: anInteger]
		ifFalse: [^ anInteger]! !

!LargeIntegersPlugin methodsFor: 'control & support primitives' stamp: 'sr 12/27/1999 19:00'!
primCheckIfCModuleExists
	"If calling this primitive fails, then C module does not exist. Do not check for forced fail, because we want to know if module exists during forced fail, too."
	self
		primitive: 'primCheckIfCModuleExists'
		parameters: #()
		receiver: #Oop.
	^ true asOop: Boolean! !

!LargeIntegersPlugin methodsFor: 'control & support primitives' stamp: 'sr 6/9/2000 18:05'!
primGetModuleName
	"If calling this primitive fails, then C module does not exist."
	| strLen strOop strPtr |
	self var: #cString declareC: 'char *cString'.
	self var: #strPtr declareC: 'char *strPtr'.
	self debugCode: [self msg: 'primGetModuleName'].
	self
		primitive: 'primGetModuleName'
		parameters: #()
		receiver: #Oop.
	strLen _ self strlen: self getModuleName.
	strOop _ interpreterProxy instantiateClass: interpreterProxy classString indexableSize: strLen.
	strPtr _ interpreterProxy firstIndexableField: strOop.
	0 to: strLen - 1 do: [:i | strPtr at: i put: (self getModuleName at: i)].
	^ strOop! !


!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:43'!
bytes: aBytesOop Lshift: shiftCount 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at    
	       return."
	"Does not normalize."
	| newBytes highBit newLen oldLen |
	oldLen _ self byteSizeOfBytes: aBytesOop.
	(highBit _ self cBytesHighBit: (interpreterProxy firstIndexableField: aBytesOop)
				len: oldLen) = 0 ifTrue: [^ 0 asOop: SmallInteger].
	newLen _ highBit + shiftCount + 7 // 8.
	self remapOop: aBytesOop in: [newBytes _ interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
					indexableSize: newLen].
	self
		cBytesLshift: shiftCount
		from: (interpreterProxy firstIndexableField: aBytesOop)
		len: oldLen
		to: (interpreterProxy firstIndexableField: newBytes)
		len: newLen.
	^ newBytes! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:44'!
bytes: aBytesOop Rshift: anInteger bytes: b lookfirst: a 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at    
	  return."
	"Shift right 8*b+anInteger bits, 0<=n<8.         
	Discard all digits beyond a, and all zeroes at or below a."
	"Does not normalize."
	| n x f m digit i oldLen newLen newBytes |
	n _ 0 - anInteger.
	x _ 0.
	f _ n + 8.
	i _ a.
	m _ 255 bitShift: 0 - f.
	digit _ self digitOfBytes: aBytesOop at: i.
	[((digit bitShift: n)
		bitOr: x)
		= 0 and: [i ~= 1]]
		whileTrue: 
			[x _ digit bitShift: f.
			"Can't exceed 8 bits"
			i _ i - 1.
			digit _ self digitOfBytes: aBytesOop at: i].
	i <= b ifTrue: [^ interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
			indexableSize: 0"Integer new: 0 neg: self negative"].
	"All bits lost"
	oldLen _ self byteSizeOfBytes: aBytesOop.
	newLen _ i - b.
	self remapOop: aBytesOop in: [newBytes _ interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesOop)
					indexableSize: newLen].
	"r _ Integer new: i - b neg: self negative."
	"	count _ i.       
	"
	self
		cCoreBytesRshiftCount: i
		n: n
		m: m
		f: f
		bytes: b
		from: (interpreterProxy firstIndexableField: aBytesOop)
		len: oldLen
		to: (interpreterProxy firstIndexableField: newBytes)
		len: newLen.
	^ newBytes! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:45'!
digitAddLarge: firstInteger with: secondInteger 
	"Does not need to normalize!!"
	| over firstLen secondLen shortInt shortLen longInt longLen sum newSum resClass |
	self var: #over declareC: 'unsigned char  over'.
	firstLen _ self byteSizeOfBytes: firstInteger.
	secondLen _ self byteSizeOfBytes: secondInteger.
	resClass _ interpreterProxy fetchClassOf: firstInteger.
	firstLen <= secondLen
		ifTrue: 
			[shortInt _ firstInteger.
			shortLen _ firstLen.
			longInt _ secondInteger.
			longLen _ secondLen]
		ifFalse: 
			[shortInt _ secondInteger.
			shortLen _ secondLen.
			longInt _ firstInteger.
			longLen _ firstLen].
	"	sum _ Integer new: len neg: firstInteger negative."
	self remapOop: #(shortInt longInt ) in: [sum _ interpreterProxy instantiateClass: resClass indexableSize: longLen].
	over _ self
				cDigitAdd: (interpreterProxy firstIndexableField: shortInt)
				len: shortLen
				with: (interpreterProxy firstIndexableField: longInt)
				len: longLen
				into: (interpreterProxy firstIndexableField: sum).
	over > 0
		ifTrue: 
			["sum _ sum growby: 1."
			interpreterProxy remapOop: sum in: [newSum _ interpreterProxy instantiateClass: resClass indexableSize: longLen + 1].
			self
				cBytesCopyFrom: (interpreterProxy firstIndexableField: sum)
				to: (interpreterProxy firstIndexableField: newSum)
				len: longLen.
			sum _ newSum.
			"C index!!"
			(self cCoerce: (interpreterProxy firstIndexableField: sum)
				to: 'unsigned char *')
				at: longLen put: over].
	^ sum! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/13/2000 19:24'!
digitBitLogic: firstInteger with: secondInteger opIndex: opIx 
	"Bit logic here is only implemented for positive integers or Zero; if rec 
	or arg is negative, it fails."
	| firstLarge secondLarge firstLen secondLen shortLen shortLarge longLen longLarge result |
	(interpreterProxy isIntegerObject: firstInteger)
		ifTrue: 
			[(interpreterProxy integerValueOf: firstInteger)
				< 0 ifTrue: [^ interpreterProxy primitiveFail].
			"convert it to a not normalized LargeInteger"
			self remapOop: secondInteger in: [firstLarge _ self createLargeFromSmallInteger: firstInteger]]
		ifFalse: 
			[(interpreterProxy fetchClassOf: firstInteger)
				= interpreterProxy classLargeNegativeInteger ifTrue: [^ interpreterProxy primitiveFail].
			firstLarge _ firstInteger].
	(interpreterProxy isIntegerObject: secondInteger)
		ifTrue: 
			[(interpreterProxy integerValueOf: secondInteger)
				< 0 ifTrue: [^ interpreterProxy primitiveFail].
			"convert it to a not normalized LargeInteger"
			self remapOop: firstLarge in: [secondLarge _ self createLargeFromSmallInteger: secondInteger]]
		ifFalse: 
			[(interpreterProxy fetchClassOf: secondInteger)
				= interpreterProxy classLargeNegativeInteger ifTrue: [^ interpreterProxy primitiveFail].
			secondLarge _ secondInteger].
	firstLen _ self byteSizeOfBytes: firstLarge.
	secondLen _ self byteSizeOfBytes: secondLarge.
	firstLen < secondLen
		ifTrue: 
			[shortLen _ firstLen.
			shortLarge _ firstLarge.
			longLen _ secondLen.
			longLarge _ secondLarge]
		ifFalse: 
			[shortLen _ secondLen.
			shortLarge _ secondLarge.
			longLen _ firstLen.
			longLarge _ firstLarge].
	self remapOop: #(shortLarge longLarge ) in: [result _ interpreterProxy instantiateClass: interpreterProxy classLargePositiveInteger indexableSize: longLen].
	self
		cByteOp: opIx
		short: (interpreterProxy firstIndexableField: shortLarge)
		len: shortLen
		long: (interpreterProxy firstIndexableField: longLarge)
		len: longLen
		into: (interpreterProxy firstIndexableField: result).
	interpreterProxy failed ifTrue: [^ 0].
	^ self normalizePositive: result! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:45'!
digitCompareLarge: firstInteger with: secondInteger 
	"Compare the magnitude of firstInteger with that of secondInteger.      
	Return a code of 1, 0, -1 for firstInteger >, = , < secondInteger"
	| firstLen secondLen |
	firstLen _ self byteSizeOfBytes: firstInteger.
	secondLen _ self byteSizeOfBytes: secondInteger.
	secondLen ~= firstLen
		ifTrue: [secondLen > firstLen
				ifTrue: [^ -1 asOop: SmallInteger]
				ifFalse: [^ 1 asOop: SmallInteger]].
	^ (self
		cDigitCompare: (interpreterProxy firstIndexableField: firstInteger)
		with: (interpreterProxy firstIndexableField: secondInteger)
		len: firstLen)
		asOop: SmallInteger! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:45'!
digitDivLarge: firstInteger with: secondInteger negative: neg 
	"Does not normalize."
	"Division by zero has to be checked in caller."
	| firstLen secondLen resultClass l d div rem quo result |
	firstLen _ self byteSizeOfBytes: firstInteger.
	secondLen _ self byteSizeOfBytes: secondInteger.
	neg
		ifTrue: [resultClass _ interpreterProxy classLargeNegativeInteger]
		ifFalse: [resultClass _ interpreterProxy classLargePositiveInteger].
	l _ firstLen - secondLen + 1.
	l <= 0
		ifTrue: 
			[self remapOop: firstInteger in: [result _ interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2].
			result stAt: 1 put: (0 asOop: SmallInteger).
			result stAt: 2 put: firstInteger.
			^ result].
	"set rem and div to copies of firstInteger and secondInteger, respectively. 
	  However,  
	 to facilitate use of Knuth's algorithm, multiply rem and div by 2 (that 
	 is, shift)   
	 until the high byte of div is >=128"
	d _ 8 - (self cHighBit: (self unsafeByteOf: secondInteger at: secondLen)).
	self remapOop: firstInteger
		in: 
			[div _ self bytes: secondInteger Lshift: d.
			div _ self bytesOrInt: div growTo: (self digitLength: div)
							+ 1].
	self remapOop: div
		in: 
			[rem _ self bytes: firstInteger Lshift: d.
			(self digitLength: rem)
				= firstLen ifTrue: [rem _ self bytesOrInt: rem growTo: firstLen + 1]].
	self remapOop: #(div rem ) in: [quo _ interpreterProxy instantiateClass: resultClass indexableSize: l].
	self
		cCoreDigitDivDiv: (interpreterProxy firstIndexableField: div)
		len: (self digitLength: div)
		rem: (interpreterProxy firstIndexableField: rem)
		len: (self digitLength: rem)
		quo: (interpreterProxy firstIndexableField: quo)
		len: (self digitLength: quo).
	self remapOop: #(quo ) in: [rem _ self
					bytes: rem
					Rshift: d
					bytes: 0
					lookfirst: (self digitLength: div)
							- 1].
	"^ Array with: quo with: rem"
	self remapOop: #(quo rem ) in: [result _ interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2].
	result stAt: 1 put: quo.
	result stAt: 2 put: rem.
	^ result! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:46'!
digitMultiplyLarge: firstInteger with: secondInteger negative: neg 
	"Normalizes."
	| firstLen secondLen shortInt shortLen longInt longLen prod resultClass |
	firstLen _ self byteSizeOfBytes: firstInteger.
	secondLen _ self byteSizeOfBytes: secondInteger.
	firstLen <= secondLen
		ifTrue: 
			[shortInt _ firstInteger.
			shortLen _ firstLen.
			longInt _ secondInteger.
			longLen _ secondLen]
		ifFalse: 
			[shortInt _ secondInteger.
			shortLen _ secondLen.
			longInt _ firstInteger.
			longLen _ firstLen].
	neg
		ifTrue: [resultClass _ interpreterProxy classLargeNegativeInteger]
		ifFalse: [resultClass _ interpreterProxy classLargePositiveInteger].
	self remapOop: #(shortInt longInt ) in: [prod _ interpreterProxy instantiateClass: resultClass indexableSize: longLen + shortLen].
	self
		cDigitMultiply: (interpreterProxy firstIndexableField: shortInt)
		len: shortLen
		with: (interpreterProxy firstIndexableField: longInt)
		len: longLen
		into: (interpreterProxy firstIndexableField: prod).
	^ self normalize: prod! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 3/11/2000 19:47'!
digitSubLarge: firstInteger with: secondInteger 
	"Normalizes."
	| firstLen secondLen class larger largerLen smaller smallerLen neg resLen res firstNeg |
	firstNeg _ (interpreterProxy fetchClassOf: firstInteger)
				= interpreterProxy classLargeNegativeInteger.
	firstLen _ self byteSizeOfBytes: firstInteger.
	secondLen _ self byteSizeOfBytes: secondInteger.
	firstLen = secondLen
		ifTrue: 
			[[(self digitOfBytes: firstInteger at: firstLen)
				= (self digitOfBytes: secondInteger at: firstLen) and: [firstLen > 1]]
				whileTrue: [firstLen _ firstLen - 1].
			secondLen _ firstLen].
	(firstLen < secondLen
		or: [firstLen = secondLen and: [(self digitOfBytes: firstInteger at: firstLen)
					< (self digitOfBytes: secondInteger at: firstLen)]])
		ifTrue: 
			[larger _ secondInteger.
			largerLen _ secondLen.
			smaller _ firstInteger.
			smallerLen _ firstLen.
			neg _ firstNeg == false]
		ifFalse: 
			[larger _ firstInteger.
			largerLen _ firstLen.
			smaller _ secondInteger.
			smallerLen _ secondLen.
			neg _ firstNeg].
	resLen _ largerLen.
	neg
		ifTrue: [class _ interpreterProxy classLargeNegativeInteger]
		ifFalse: [class _ interpreterProxy classLargePositiveInteger].
	self remapOop: #(smaller larger ) in: [res _ interpreterProxy instantiateClass: class indexableSize: resLen].
	self
		cDigitSub: (interpreterProxy firstIndexableField: smaller)
		len: smallerLen
		with: (interpreterProxy firstIndexableField: larger)
		len: largerLen
		into: (interpreterProxy firstIndexableField: res).
	^ self normalize: res! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 6/9/2000 04:02'!
normalize: aLargeInteger 
	"Check for leading zeroes and return shortened copy if so."
	self debugCode: [self msg: 'normalize: aLargeInteger'].
	(interpreterProxy fetchClassOf: aLargeInteger)
		= interpreterProxy classLargePositiveInteger
		ifTrue: [^ self normalizePositive: aLargeInteger]
		ifFalse: [^ self normalizeNegative: aLargeInteger]! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 1/23/2000 18:14'!
normalizeNegative: aLargeNegativeInteger 
	"Check for leading zeroes and return shortened copy if so"
	"First establish len = significant length"
	| sLen val len oldLen minVal |
	len _ oldLen _ self digitLength: aLargeNegativeInteger.
	[len ~= 0 and: [(self unsafeByteOf: aLargeNegativeInteger at: len)
			= 0]]
		whileTrue: [len _ len - 1].
	len = 0 ifTrue: [^ 0 asOop: SmallInteger].
	"Now check if in SmallInteger range"
	sLen _ 4.
	"SmallInteger minVal digitLength"
	len <= sLen
		ifTrue: 
			["SmallInteger minVal"
			minVal _ -1073741824.
			(len < sLen or: [(self digitOfBytes: aLargeNegativeInteger at: sLen)
					< (self cDigitOfCSI: minVal at: sLen)
				"minVal lastDigit"])
				ifTrue: 
					["If high digit less, then can be small"
					val _ 0.
					len
						to: 1
						by: -1
						do: [:i | val _ val * 256 - (self unsafeByteOf: aLargeNegativeInteger at: i)].
					^ val asOop: SmallInteger].
			1 to: sLen do: [:i | "If all digits same, then = minVal (sr: minVal digits 1 to 3 are 
				          0)"
				(self digitOfBytes: aLargeNegativeInteger at: i)
					= (self cDigitOfCSI: minVal at: i)
					ifFalse: ["Not so; return self shortened"
						len < oldLen
							ifTrue: ["^ self growto: len"
								^ self bytes: aLargeNegativeInteger growTo: len]
							ifFalse: [^ aLargeNegativeInteger]]].
			^ minVal asOop: SmallInteger].
	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: ["^ self growto: len"
			^ self bytes: aLargeNegativeInteger growTo: len]
		ifFalse: [^ aLargeNegativeInteger]! !

!LargeIntegersPlugin methodsFor: 'oop functions' stamp: 'sr 1/23/2000 18:14'!
normalizePositive: aLargePositiveInteger 
	"Check for leading zeroes and return shortened copy if so"
	"First establish len = significant length"
	| sLen val len oldLen |
	len _ oldLen _ self digitLength: aLargePositiveInteger.
	[len ~= 0 and: [(self unsafeByteOf: aLargePositiveInteger at: len)
			= 0]]
		whileTrue: [len _ len - 1].
	len = 0 ifTrue: [^ 0 asOop: SmallInteger].
	"Now check if in SmallInteger range"
	sLen _ 4.
	"SmallInteger maxVal digitLength."
	(len <= sLen and: [(self digitOfBytes: aLargePositiveInteger at: sLen)
			<= (self cDigitOfCSI: 1073741823 at: sLen)
		"SmallInteger maxVal"])
		ifTrue: 
			["If so, return its SmallInt value"
			val _ 0.
			len
				to: 1
				by: -1
				do: [:i | val _ val * 256 + (self unsafeByteOf: aLargePositiveInteger at: i)].
			^ val asOop: SmallInteger].
	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: ["^ self growto: len"
			^ self bytes: aLargePositiveInteger growTo: len]
		ifFalse: [^ aLargePositiveInteger]! !


!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'sr 3/11/2000 19:44'!
bytes: aBytesObject growTo: newLen 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at    
	     return."
	"Does not normalize."
	| newBytes oldLen copyLen |
	self remapOop: aBytesObject in: [newBytes _ interpreterProxy instantiateClass: (interpreterProxy fetchClassOf: aBytesObject)
					indexableSize: newLen].
	oldLen _ self byteSizeOfBytes: aBytesObject.
	oldLen < newLen
		ifTrue: [copyLen _ oldLen]
		ifFalse: [copyLen _ newLen].
	self
		cBytesCopyFrom: (interpreterProxy firstIndexableField: aBytesObject)
		to: (interpreterProxy firstIndexableField: newBytes)
		len: copyLen.
	^ newBytes! !

!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'sr 1/23/2000 04:52'!
bytesOrInt: oop growTo: len 
	"Attention: this method invalidates all oop's!! Only newBytes is valid at    
	          return."
	| newBytes val class |
	(interpreterProxy isIntegerObject: oop)
		ifTrue: 
			[val _ interpreterProxy integerValueOf: oop.
			val < 0
				ifTrue: [class _ interpreterProxy classLargeNegativeInteger]
				ifFalse: [class _ interpreterProxy classLargePositiveInteger].
			newBytes _ interpreterProxy instantiateClass: class indexableSize: len.
			self cCopyIntVal: val toBytes: newBytes]
		ifFalse: [newBytes _ self bytes: oop growTo: len].
	^ newBytes! !

!LargeIntegersPlugin methodsFor: 'oop util' stamp: 'sr 1/23/2000 04:53'!
createLargeFromSmallInteger: anOop 
	"anOop has to be a SmallInteger!!"
	| val class size res pByte |
	self var: #pByte declareC: 'unsigned char *  pByte'.
	val _ interpreterProxy integerValueOf: anOop.
	val < 0
		ifTrue: [class _ interpreterProxy classLargeNegativeInteger]
		ifFalse: [class _ interpreterProxy classLargePositiveInteger].
	size _ self cDigitLengthOfCSI: val.
	res _ interpreterProxy instantiateClass: class indexableSize: size.
	pByte _ interpreterProxy firstIndexableField: res.
	1 to: size do: [:ix | pByte at: ix - 1 put: (self cDigitOfCSI: val at: ix)].
	^ res! !


!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 11/29/2000 13:41'!
anyBitOfBytes: aBytesOop from: start to: stopArg 
	"Argument has to be aBytesOop!!"
	"Tests for any magnitude bits in the interval from start to stopArg."
	| magnitude rightShift leftShift stop firstByteIx lastByteIx |
	self
		debugCode: [self msg: 'anyBitOfBytes: aBytesOop from: start to: stopArg'].
	start < 1 | (stopArg < 1)
		ifTrue: [^ interpreterProxy primitiveFail].
	magnitude _ aBytesOop.
	stop _ stopArg
				min: (self highBitOfBytes: magnitude).
	start > stop
		ifTrue: [^ false].
	firstByteIx _ start - 1 // 8 + 1.
	lastByteIx _ stop - 1 // 8 + 1.
	rightShift _ 0 - (start - 1 \\ 8).
	leftShift _ 7 - (stop - 1 \\ 8).
	firstByteIx = lastByteIx
		ifTrue: [| digit mask | 
			mask _ (255 bitShift: 0 - rightShift)
						bitAnd: (255 bitShift: 0 - leftShift).
			digit _ self digitOfBytes: magnitude at: firstByteIx.
			^ (digit bitAnd: mask)
				~= 0].
	((self digitOfBytes: magnitude at: firstByteIx)
			bitShift: rightShift)
			~= 0
		ifTrue: [^ true].
	firstByteIx + 1
		to: lastByteIx - 1
		do: [:ix | (self digitOfBytes: magnitude at: ix)
					~= 0
				ifTrue: [^ true]].
	(((self digitOfBytes: magnitude at: lastByteIx)
			bitShift: leftShift)
			bitAnd: 255)
			~= 0
		ifTrue: [^ true].
	^ false! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 3/11/2000 19:42'!
byteSizeOfBytes: bytesOop 
	"Precondition: bytesOop is not anInteger and a bytes object."
	"Function #byteSizeOf: is used by the interpreter, be careful with name  
	     clashes..."
	^ interpreterProxy slotSizeOf: bytesOop! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 3/11/2000 19:46'!
digitLength: oop 
	(interpreterProxy isIntegerObject: oop)
		ifTrue: [^ self cDigitLengthOfCSI: (interpreterProxy integerValueOf: oop)]
		ifFalse: [^ self byteSizeOfBytes: oop]! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 1/23/2000 18:10'!
digitOf: oop at: ix 
	(interpreterProxy isIntegerObject: oop)
		ifTrue: [^ self cDigitOfCSI: (interpreterProxy integerValueOf: oop)
				at: ix]
		ifFalse: [^ self digitOfBytes: oop at: ix]! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 3/11/2000 19:46'!
digitOfBytes: aBytesOop at: ix 
	"Argument has to be aLargeInteger!!"
	ix > (self byteSizeOfBytes: aBytesOop)
		ifTrue: [^ 0]
		ifFalse: [^ self unsafeByteOf: aBytesOop at: ix]! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 6/9/2000 00:24'!
highBitOfBytes: aBytesOop 
	^ self cBytesHighBit: (interpreterProxy firstIndexableField: aBytesOop)
		len: (self byteSizeOfBytes: aBytesOop)! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 6/9/2000 00:31'!
negative: aLarge 
	^ (interpreterProxy fetchClassOf: aLarge)
		= interpreterProxy classLargeNegativeInteger! !

!LargeIntegersPlugin methodsFor: 'util' stamp: 'sr 12/27/1999 22:01'!
unsafeByteOf: bytesOop at: ix 
"Argument bytesOop must not be aSmallInteger!!"
	^ interpreterProxy integerValueOf: (interpreterProxy stObject: bytesOop at: ix)! !


!LargeIntegersPlugin methodsFor: 'debugging' stamp: 'sr 4/8/2000 02:30'!
assert: aBool 
	self
		debugCode: 
			[aBool
				ifFalse: 
					[self msg: 'Assertion failed!!'.
					self cCode: 'exit(1)'
						inSmalltalk: 
							[interpreterProxy primitiveFail.
							self halt]].
			^ true]! !

!LargeIntegersPlugin methodsFor: 'debugging' stamp: 'sr 6/9/2000 03:39'!
debugCode: aBlock
! !

!LargeIntegersPlugin methodsFor: 'debugging' stamp: 'sr 3/14/2000 23:43'!
msg: s 
	self var: #s declareC: 'char *s'.
	self cCode: 'fprintf(stderr, "\n%s: %s", moduleName, s)' inSmalltalk: [Transcript cr; show: self class moduleName , ': ' , s; endEntry]! !

!LargeIntegersPlugin methodsFor: 'debugging' stamp: 'sr 3/14/2000 23:01'!
think
	"Flag for marking methods for later thinking."
	^ self msg: '#think should not be called'! !


!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 3/13/2000 17:04'!
cByteOp: opIndex short: pByteShort len: shortLen long: pByteLong len: longLen into: pByteRes 
	"pByteRes len = longLen."
	| limit |
	self var: #pByteShort declareC: 'unsigned char * pByteShort'.
	self var: #pByteLong declareC: 'unsigned char * pByteLong'.
	self var: #pByteRes declareC: 'unsigned char * pByteRes'.
	self var: #shortLen declareC: 'int shortLen'.
	self var: #longLen declareC: 'int longLen'.
	self var: #limit declareC: 'int limit'.
	limit _ shortLen - 1.
	opIndex = andOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitAnd: (pByteLong at: i))].
			limit _ longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: 0].
			^ 0].
	opIndex = orOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitOr: (pByteLong at: i))].
			limit _ longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: (pByteLong at: i)].
			^ 0].
	opIndex = xorOpIndex
		ifTrue: 
			[0 to: limit do: [:i | pByteRes at: i put: ((pByteShort at: i)
						bitXor: (pByteLong at: i))].
			limit _ longLen - 1.
			shortLen to: limit do: [:i | pByteRes at: i put: (pByteLong at: i)].
			^ 0].
	^ interpreterProxy primitiveFail! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/24/1999 05:57'!
cBytesLshift: shiftCount from: pFrom len: lenFrom to: pTo len: lenTo 
	"C indexed!!"
	| byteShift bitShift carry rShift mask limit digit lastIx |
	self returnTypeC: 'int'.
	self var: #pTo declareC: 'unsigned char * pTo'.
	self var: #pFrom declareC: 'unsigned char * pFrom'.
	self var: #lenFrom declareC: 'int lenFrom'.
	self var: #lenTo declareC: 'int lenTo'.
	byteShift _ shiftCount // 8.
	bitShift _ shiftCount \\ 8.
	bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts"
		"C indexed!!"
		^ self
			cBytesReplace: pTo
			from: byteShift
			to: lenTo - 1
			with: pFrom
			startingAt: 0].
	carry _ 0.
	rShift _ bitShift - 8.
	mask _ 255 bitShift: 0 - bitShift.
	limit _ byteShift - 1.
	0 to: limit do: [:i | pTo at: i put: 0].
	limit _ lenTo - byteShift - 2.
	self assert: limit < lenFrom.
	0 to: limit do: 
		[:i | 
		digit _ pFrom at: i.
		pTo at: i + byteShift put: (((digit bitAnd: mask)
				bitShift: bitShift)
				bitOr: carry).
		carry _ digit bitShift: rShift].
	lastIx _ limit + 1.
	lastIx > (lenFrom - 1)
		ifTrue: [digit _ 0]
		ifFalse: [digit _ pFrom at: lastIx].
	pTo at: lastIx + byteShift put: (((digit bitAnd: mask)
			bitShift: bitShift)
			bitOr: carry).
	carry _ digit bitShift: rShift.
	self assert: carry = 0! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/23/1999 18:46'!
cCoreBytesRshiftCount: count n: n m: m f: f bytes: b from: pFrom len: fromLen to: pTo len: toLen 
	| x digit |
	self var: #pTo declareC: 'unsigned char * pTo'.
	self var: #pFrom declareC: 'unsigned char * pFrom'.
	self assert: b < fromLen.
	x _ (pFrom at: b)
				bitShift: n.
	self assert: count - 1 < fromLen.
	b + 1 to: count - 1 do: 
		[:j | 
		digit _ pFrom at: j.
		pTo at: j - b - 1 put: (((digit bitAnd: m)
				bitShift: f)
				bitOr: x).
		"Avoid values > 8 bits"
		x _ digit bitShift: n].
	count = fromLen
				ifTrue: [digit _ 0]
				ifFalse: [digit _ pFrom at: count].
	pTo at: count - b - 1 put: (((digit bitAnd: m)
			bitShift: f)
			bitOr: x)! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 6/1/2000 08:03'!
cCoreDigitDivDiv: pDiv len: divLen rem: pRem len: remLen quo: pQuo len: quoLen 
	| dl ql dh dnh j t hi lo r3 l a cond q r1r2 mul |
	self var: #pDiv declareC: 'unsigned char * pDiv'.
	self var: #pRem declareC: 'unsigned char * pRem'.
	self var: #pQuo declareC: 'unsigned char * pQuo'.
	dl _ divLen - 1.
	"Last actual byte of data (ST ix)"
	ql _ quoLen.
	dh _ pDiv at: dl - 1.
	dl = 1
		ifTrue: [dnh _ 0]
		ifFalse: [dnh _ pDiv at: dl - 2].
	1 to: ql do: 
		[:k | 
		"maintain quo*arg+rem=self"
		"Estimate rem/div by dividing the leading two bytes of rem by dh."
		"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
		"Nibbles are kicked off!! We use full 16 bits now, because we are in  
		the year 2000 ;-) [sr]"
		j _ remLen + 1 - k.
		"r1 _ rem digitAt: j."
		(pRem at: j - 1)
			= dh
			ifTrue: [q _ 255]
			ifFalse: 
				["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.                
				Note that r1,r2 are bytes, not nibbles.                
				Be careful not to generate intermediate results exceeding 13  
				            bits."
				"r2 _ (rem digitAt: j - 2)."
				r1r2 _ ((pRem at: j - 1)
							bitShift: 8)
							+ (pRem at: j - 2).
				t _ r1r2 \\ dh.
				q _ r1r2 // dh.
				"Next compute (hi,lo) _ q*dnh"
				mul _ q * dnh.
				hi _ mul bitShift: -8.
				lo _ mul bitAnd: 255.
				"Correct overestimate of q.                
				Max of 2 iterations through loop -- see Knuth vol. 2"
				j < 3
					ifTrue: [r3 _ 0]
					ifFalse: [r3 _ pRem at: j - 3].
				
				[(t < hi
					or: [t = hi and: [r3 < lo]])
					ifTrue: 
						["i.e. (t,r3) < (hi,lo)"
						q _ q - 1.
						lo _ lo - dnh.
						lo < 0
							ifTrue: 
								[hi _ hi - 1.
								lo _ lo + 256].
						cond _ hi >= dh]
					ifFalse: [cond _ false].
				cond]
					whileTrue: [hi _ hi - dh]].
		"Subtract q*div from rem"
		l _ j - dl.
		a _ 0.
		1 to: divLen do: 
			[:i | 
			hi _ (pDiv at: i - 1)
						* (q bitShift: -8).
			lo _ a + (pRem at: l - 1) - ((pDiv at: i - 1)
							* (q bitAnd: 255)).
			"pRem at: l - 1 put: lo - (lo // 256 * 256)."
			"sign-tolerant form of (lo bitAnd: 255) -> obsolete..."
			pRem at: l - 1 put: (lo bitAnd: 255).
			"... is sign-tolerant!! [sr]"
			a _ lo // 256 - hi.
			l _ l + 1].
		a < 0
			ifTrue: 
				["Add div back into rem, decrease q by 1"
				q _ q - 1.
				l _ j - dl.
				a _ 0.
				1 to: divLen do: 
					[:i | 
					a _ (a bitShift: -8)
								+ (pRem at: l - 1) + (pDiv at: i - 1).
					pRem at: l - 1 put: (a bitAnd: 255).
					l _ l + 1]].
		pQuo at: quoLen - k put: q]! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/17/1999 09:48'!
cDigitAdd: pByteShort len: shortLen with: pByteLong len: longLen into: pByteRes 
	"pByteRes len = longLen; returns over.."
	| accum limit |
	self returnTypeC: 'unsigned char'.
	self var: #pByteShort declareC: 'unsigned char * pByteShort'.
	self var: #pByteLong declareC: 'unsigned char * pByteLong'.
	self var: #pByteRes declareC: 'unsigned char * pByteRes'.
	self var: #shortLen declareC: 'int shortLen'.
	self var: #longLen declareC: 'int longLen'.
	self var: #accum declareC: 'int accum'.
	self var: #limit declareC: 'int limit'.
	accum _ 0.
	limit _ shortLen - 1.
	0 to: limit do: 
		[:i | 
		accum _ (accum bitShift: -8)
					+ (pByteShort at: i) + (pByteLong at: i).
		pByteRes at: i put: (accum bitAnd: 255)].
	limit _ longLen - 1.
	shortLen to: limit do: 
		[:i | 
		accum _ (accum bitShift: -8)
					+ (pByteLong at: i).
		pByteRes at: i put: (accum bitAnd: 255)].
	^ accum bitShift: -8! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/27/1999 21:24'!
cDigitCompare: pFirst with: pSecond len: len 
	"Precondition: pFirst len = pSecond len."
	| secondDigit ix firstDigit |
	self var: #pFirst declareC: 'unsigned char * pFirst'.
	self var: #pSecond declareC: 'unsigned char * pSecond'.
	ix _ len - 1.
	[ix >= 0]
		whileTrue: 
			[(secondDigit _ pSecond at: ix) ~= (firstDigit _ pFirst at: ix)
				ifTrue: [secondDigit < firstDigit
						ifTrue: [^ 1]
						ifFalse: [^ -1]].
			ix _ ix - 1].
	^ 0! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/21/1999 09:56'!
cDigitMultiply: pByteShort len: shortLen with: pByteLong len: longLen into: pByteRes 
	"pByteRes len = longLen * shortLen"
	| limitLong digit k carry limitShort ab |
	self returnTypeC: 'unsigned char'.
	self var: #pByteShort declareC: 'unsigned char * pByteShort'.
	self var: #pByteLong declareC: 'unsigned char * pByteLong'.
	self var: #pByteRes declareC: 'unsigned char * pByteRes'.
	self var: #shortLen declareC: 'int shortLen'.
	self var: #longLen declareC: 'int longLen'.
	self var: #carry declareC: 'int carry'.
	self var: #limitLong declareC: 'int limitLong'.
	self var: #limitShort declareC: 'int limitShort'.
	self var: #digit declareC: 'int digit'.
	self var: #ab declareC: 'int ab'.
	self var: #k declareC: 'int k'.
	(shortLen = 1 and: [(pByteShort at: 0)
			= 0])
		ifTrue: [^ 0].
	(longLen = 1 and: [(pByteLong at: 0)
			= 0])
		ifTrue: [^ 0].
	"prod starts out all zero"
	limitShort _ shortLen - 1.
	0 to: limitShort do: [:i | (digit _ pByteShort at: i) ~= 0
			ifTrue: 
				[k _ i.
				carry _ 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1 (ST)"
				"-> Loop invariant: 0<=carry<=0377, k=i+j (C) (?)"
				limitLong _ longLen - 1.
				0 to: limitLong do: 
					[:j | 
					ab _ (pByteLong at: j)
								* digit + carry + (pByteRes at: k).
					carry _ ab bitShift: -8.
					pByteRes at: k put: (ab bitAnd: 255).
					k _ k + 1].
				pByteRes at: k put: carry]].
	^ 0! !

!LargeIntegersPlugin methodsFor: 'C core' stamp: 'sr 12/22/1999 07:47'!
cDigitSub: pByteSmall
		len: smallLen
		with: pByteLarge
		len: largeLen
		into: pByteRes
	| z limit |
	self var: #pByteSmall declareC: 'unsigned char * pByteSmall'.
	self var: #pByteLarge declareC: 'unsigned char * pByteLarge'.
	self var: #pByteRes declareC: 'unsigned char * pByteRes'.
	self var: #smallLen declareC: 'int smallLen'.
	self var: #largeLen declareC: 'int largeLen'.

	z _ 0.
	"Loop invariant is -1<=z<=1"
	limit _ smallLen - 1.
	0 to: limit do: 
		[:i | 
		z _ z + (pByteLarge at: i) - (pByteSmall at: i).
		pByteRes at: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z _ z // 256].
	limit _ largeLen - 1.
	smallLen to: limit do: 
		[:i | 
		z _ z + (pByteLarge at: i) .
		pByteRes at: i put: z - (z // 256 * 256).
		"sign-tolerant form of (z bitAnd: 255)"
		z _ z // 256].
! !


!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/21/1999 01:26'!
cBytesCopyFrom: pFrom to: pTo len: len 
	""
	| limit |
	self returnTypeC: 'int'.
	self var: #pFrom declareC: 'unsigned char * pFrom'.
	self var: #pTo declareC: 'unsigned char * pTo'.
	self var: #len declareC: 'int len'.
	self var: #limit declareC: 'int limit'.
	limit _ len - 1.
	0 to: limit do: [:i | pTo at: i put: (pFrom at: i)].
	^ 0! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'acg 1/1/2000 15:25'!
cBytesHighBit: pByte len: len 
	"Answer the index (in bits) of the high order bit of the receiver, or zero if the    
	 receiver is zero. This method is allowed (and needed) for     
	LargeNegativeIntegers as well, since Squeak's LargeIntegers are     
	sign/magnitude."
	| realLength lastDigit |
	self var: #pByte declareC: 'unsigned char *  pByte'.
	realLength _ len.
	[(lastDigit _ pByte at: realLength - 1) = 0]
		whileTrue: [(realLength _ realLength - 1) = 0 ifTrue: [^ 0]].
	^  (self cHighBit: lastDigit) + (8 * (realLength - 1))! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/23/1999 14:44'!
cBytesReplace: pTo from: start to: stop with: pFrom startingAt: repStart 
	"C indexed!!"
	self returnTypeC: 'int'.
	self var: #pTo declareC: 'unsigned char * pTo'.
	self var: #pFrom declareC: 'unsigned char * pFrom'.
	self var: #start declareC: 'int start'.
	self var: #stop declareC: 'int stop'.
	self var: #repStart declareC: 'int repStart'.
	^ self
		cBytesCopyFrom: pFrom + repStart
		to: pTo + start
		len: stop - start + 1! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/27/1999 11:38'!
cCopyIntVal: val toBytes: bytes 
	| pByte |
	self var: #pByte declareC: 'unsigned char *  pByte'.
	pByte _ interpreterProxy firstIndexableField: bytes.
	1 to: (self cDigitLengthOfCSI: val)
		do: [:ix | pByte at: ix - 1 put: (self cDigitOfCSI: val at: ix)]! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/12/1999 05:53'!
cDigitLengthOfCSI: csi 
	"Answer the number of indexable fields of a CSmallInteger. This value is 
	   the same as the largest legal subscript."
	self returnTypeC: 'int'.
	self var: #csi declareC: 'int csi'.
	(csi < 256 and: [csi > -256])
		ifTrue: [^ 1].
	(csi < 65536 and: [csi > -65536])
		ifTrue: [^ 2].
	(csi < 16777216 and: [csi > -16777216])
		ifTrue: [^ 3].
	^ 4! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/23/1999 15:12'!
cDigitOfCSI: csi at: ix 
	"Answer the value of an indexable field in the receiver.              
	LargePositiveInteger uses bytes of base two number, and each is a       
	      'digit' base 256."
	"ST indexed!!"
	ix < 0 ifTrue: [interpreterProxy primitiveFail].
	ix > 4 ifTrue: [^ 0].
	csi < 0
		ifTrue: 
			[self cCode: ''
				inSmalltalk: [csi = -1073741824 ifTrue: ["SmallInteger minVal"
						"Can't negate minVal -- treat specially"
						^ #(0 0 0 64 ) at: ix]].
			^ (0 - csi bitShift: 1 - ix * 8)
				bitAnd: 255]
		ifFalse: [^ (csi bitShift: 1 - ix * 8)
				bitAnd: 255]! !

!LargeIntegersPlugin methodsFor: 'C core util' stamp: 'sr 12/22/1999 11:53'!
cHighBit: uint 
	"Answer the index of the high order bit of the argument, or zero if the  
	argument is zero."
	| shifted bitNo |
	self var: #shifted declareC: 'unsigned int  shifted'.
	shifted _ uint.
	bitNo _ 0.
	[shifted < 16]
		whileFalse: 
			[shifted _ shifted bitShift: -4.
			bitNo _ bitNo + 4].
	[shifted = 0]
		whileFalse: 
			[shifted _ shifted bitShift: -1.
			bitNo _ bitNo + 1].
	^ bitNo! !


!LargeIntegersPlugin methodsFor: 'ST initialize' stamp: 'sr 3/15/2000 00:57'!
initialize
	"Initializes ST constants; C's are set by class>>declareCVarsIn:."
	self returnTypeC: 'void'.
	self cCode: '"nothing to do here"'
		inSmalltalk: 
			[andOpIndex _ 0.
			orOpIndex _ 1.
			xorOpIndex _ 2]! !


!LargeIntegersPlugin methodsFor: 'obsolete' stamp: 'sr 4/8/2000 02:08'!
primDigitBitShift: shiftCount 
	| rShift aLarge anInteger |
	self debugCode: [self msg: 'primDigitBitShift: shiftCount'].
	anInteger _ self
				primitive: 'primDigitBitShift'
				parameters: #(SmallInteger )
				receiver: #Integer.
	(interpreterProxy isIntegerObject: anInteger)
		ifTrue: ["convert it to a not normalized LargeInteger"
			aLarge _ self createLargeFromSmallInteger: anInteger]
		ifFalse: [aLarge _ anInteger].
	shiftCount >= 0
		ifTrue: [^ self bytes: aLarge Lshift: shiftCount]
		ifFalse: 
			[rShift _ 0 - shiftCount.
			^ self normalize: (self
					bytes: aLarge
					Rshift: (rShift bitAnd: 7)
					bytes: (rShift bitShift: -3)
					lookfirst: (self byteSizeOfBytes: aLarge))]! !

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

LargeIntegersPlugin class
	instanceVariableNames: ''!

!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 4/8/2000 05:40'!
declareCVarsIn: cg 
	cg var: 'andOpIndex' declareC: 'const int  andOpIndex = 0'.
	cg var: 'orOpIndex' declareC: 'const int  orOpIndex = 1'.
	cg var: 'xorOpIndex' declareC: 'const int  xorOpIndex = 2'! !

!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'ar 5/17/2000 16:08'!
moduleName
	^'LargeIntegers'! !

!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 6/9/2000 15:47'!
moduleNameAndVersion
	"Answer the receiver's module name and version info that is used for the plugin's C code. The default is to append the code generation date, but any useful text is ok (keep it short)"

	^ self moduleName, Character space asString, self version, Character space asString, Date today asString! !

!LargeIntegersPlugin class methodsFor: 'translation' stamp: 'sr 11/29/2000 13:36'!
version
	"Answer the receiver's version info as String."

	^ 'v1.2'! !


!LargeIntegersPlugin class methodsFor: 'instance creation' stamp: 'sr 3/15/2000 01:08'!
new
	^super new initialize! !
Object subclass: #LargeIntegersTest
	instanceVariableNames: 'oc1 oc2 ocShift ocShift2 stream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!LargeIntegersTest commentStamp: '<historical>' prior: 0!
Some tests for LargeIntegersPlugin functions and their binding to Integer methods.

Evaluate...
without module:
	LargeIntegersTest doItInFile: '/tmp/withoutModule.txt' withModule: false.
with module:
	LargeIntegersTest doItInFile: '/tmp/withModule.txt' withModule: true.
.
After these computations both files have to be the same contents!!

Speed:
	[LargeIntegersTest bigFactorial: 3 depth: 3] timeToRun
or
	[1000 factorial] timeToRun
!


!LargeIntegersTest methodsFor: 'as yet unclassified' stamp: 'sr 4/8/2000 22:25'!
computeOp: anOpSymbol with: arg1 with: arg2 
	| res |
	stream cr; print: anOpSymbol; cr.
	stream nextPutAll: 'arg1: ';
	 print: arg1;
	 cr;
	 nextPutAll: 'arg2: ';
	 print: arg2.
	res _ arg1 perform: anOpSymbol with: arg2.
	stream cr; nextPutAll: 'res: '; print: res! !

!LargeIntegersTest methodsFor: 'as yet unclassified' stamp: 'sr 6/9/2000 09:00'!
createTestData
	| tmpPos1 tmpPos2 tmpNeg1 tmpNeg2 tmp tmp2 |
	tmpPos1 _ OrderedCollection new.
	tmpPos2 _ OrderedCollection new.
	tmpPos1 add: 0.
	tmpPos2 add: 0.
	tmpPos1 add: 1.
	tmpPos2 add: 1.
	tmpPos1 add: SmallInteger maxVal + 1 * 1000.
	tmpPos2 add: SmallInteger maxVal.
	tmpPos1 add: SmallInteger maxVal.
	tmpPos2 add: 77.
	tmpPos1 add: (2 raisedTo: 7).
	tmpPos2 add: (2 raisedTo: 7).
	tmpPos1 add: (2 raisedTo: 31).
	tmpPos2 add: (2 raisedTo: 31).
	tmpPos1 add: (2 raisedTo: 7).
	tmpPos2 add: (2 raisedTo: 31).
	tmpPos1 add: (2 raisedTo: 31).
	tmpPos2 add: (2 raisedTo: 7).
	tmpPos1 add: (2 raisedTo: 100).
	tmpPos2 add: (2 raisedTo: 100)
			- 1.
	tmpPos1 add: (2 raisedTo: 1000).
	tmpPos2 add: (2 raisedTo: 1000)
			- 1.
	tmpPos1 add: 65535.
	tmpPos2 add: 3.
	tmpPos1 add: 3.
	tmpPos2 add: 65535.
	tmpNeg1 _ tmpPos1 collect: [:e | e negated].
	tmpNeg2 _ tmpPos2 collect: [:e | e negated].
	oc1 _ tmpPos1 , tmpPos1 , tmpNeg1 , tmpNeg1.
	oc2 _ tmpPos2 , tmpNeg2 , tmpNeg2 , tmpPos2.

	ocShift _ (tmpPos1 collect: [:e | e])
				, (tmpPos2 collect: [:e | e]) , (tmpPos1 collect: [:e | e + (2 raisedTo: 32)]) , (tmpPos2 collect: [:e | e + (2 raisedTo: 32)]).
	ocShift2 _ OrderedCollection new.
	0 to: ocShift size - 1 do: [:ix | ocShift2 add: ix].
	ocShift _ ocShift , ocShift.
	ocShift2 addAll: (ocShift2 collect: [:e | e negated]).
	tmp _ OrderedCollection new. tmp2 _ OrderedCollection new.
	ocShift do: [:e | tmp add: e. tmp add: e+1.].
	ocShift2 do: [:e | tmp2 add: e. tmp2 add: e.].
	ocShift _ tmp.
	ocShift2 _ tmp2.
	ocShift _ (ocShift collect: [:e | e negated]), ocShift, ocShift, (ocShift collect: [:e | e negated]).
	ocShift2 _ (ocShift2 collect: [:e | e negated]), (ocShift2 collect: [:e | e negated]), ocShift2 , ocShift2.
! !

!LargeIntegersTest methodsFor: 'as yet unclassified' stamp: 'sr 4/8/2000 23:24'!
test
	| n |
	stream cr; cr; nextPutAll: 'Testing LargeIntegers computations...'.
	stream cr; tab; nextPutAll: 'operation symbols shown; ''0'' stands for (avoided) division by ''0'''; cr.
	self class name , ': performing arithmetic operations...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: oc1 size
		during: 
			[:bar | 
			n _ 0.
			oc1 with: oc2 do: 
				[:e1 :e2 | 
				bar value: (n _ n + 1).
				self
					computeOp: #+
					with: e1
					with: e2.
				self
					computeOp: #-
					with: e1
					with: e2.
				self
					computeOp: #*
					with: e1
					with: e2.
				self
					computeOp: #bitAnd:
					with: e1
					with: e2.
				self
					computeOp: #bitOr:
					with: e1
					with: e2.
				self
					computeOp: #bitXor:
					with: e1
					with: e2.
				e2 ~= 0
					ifTrue: [self
							computeOp: #/
							with: e1
							with: e2]
					ifFalse: [stream nextPutAll: ' 0 ']]].
	self class name , ': performing shift operations...'
		displayProgressAt: Sensor cursorPoint
		from: 0
		to: ocShift size
		during: 
			[:bar | 
			n _ 0.
			ocShift with: ocShift2 do: 
				[:e1 :e2 | 
				bar value: (n _ n + 1).
				self
					computeOp: #bitShift:
					with: e1
					with: e2]]! !


!LargeIntegersTest methodsFor: 'accessing' stamp: 'sr 4/8/2000 22:51'!
stream
	^stream! !

!LargeIntegersTest methodsFor: 'accessing' stamp: 'sr 4/8/2000 22:51'!
stream: anObject
	stream _ anObject! !

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

LargeIntegersTest class
	instanceVariableNames: ''!

!LargeIntegersTest class methodsFor: 'private' stamp: 'ar 5/17/2000 16:06'!
checkIfCModuleExists
	"If primitive fails, module isn't reachable."
	<primitive: 'primCheckIfCModuleExists' module:'LargeIntegers'>
	^ false! !

!LargeIntegersTest class methodsFor: 'private' stamp: 'ar 5/17/2000 16:06'!
doItOn: stream withModule: withModuleFlag 
	"Make LargeIntegers computations with logging onto stream."
	| tester |
	withModuleFlag
		ifTrue: [self checkIfCModuleExists
				ifFalse: 
					[self inform: self name , ': Test *with* module impossible!!' , Character cr asString , self moduleName , ' plugin module isn''t installed properly.'.
					^ false]]
		ifFalse: [self checkIfCModuleExists
				ifTrue: 
					[self inform: self name , ': Test *without* module impossible!!' , Character cr asString , self moduleName , ' plugin module has to be renamed or removed from reachable modules path.'.
					^ false]].
	tester _ self new.
	tester stream: (stream notNil
			ifTrue: [stream]
			ifFalse: [Transcript]).
	tester stream cr; nextPutAll: self class name , ': creating test data...'.
	tester createTestData.
	tester test.
	^ true! !

!LargeIntegersTest class methodsFor: 'private' stamp: 'ar 5/17/2000 16:06'!
moduleName
	^ 'LargeIntegers'! !


!LargeIntegersTest class methodsFor: 'user interface' stamp: 'sr 4/9/2000 00:24'!
bigFactorial: anInteger depth: depth 
	"Computationally very expensive!!"
	depth > 1
		ifTrue: [^ (self bigFactorial: anInteger depth: depth - 1) factorial]
		ifFalse: [^ anInteger factorial]! !

!LargeIntegersTest class methodsFor: 'user interface' stamp: 'sr 4/9/2000 00:23'!
doItInFile: fileName withModule: withModuleFlag 
	"Stores output in a new file named 'filename'.
	Param 'withModuleFlag' has to be true, if there is a reachable module, false otherwise."
	| stream |
	stream _ FileStream newFileNamed: fileName.
	LargeIntegersTest doItOn: stream withModule: withModuleFlag.
	stream close! !

!LargeIntegersTest class methodsFor: 'user interface' stamp: 'sr 6/9/2000 18:17'!
getModuleName
	"self getModuleName"
	<primitive: 'primGetModuleName' module: 'LargeIntegers'>
	^ nil! !
LargePositiveInteger variableByteSubclass: #LargeNegativeInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!LargeNegativeInteger commentStamp: '<historical>' prior: 0!
Just like LargePositiveInteger, but represents a negative number.!


!LargeNegativeInteger methodsFor: 'arithmetic'!
abs
	^ self negated! !

!LargeNegativeInteger methodsFor: 'arithmetic'!
negated
	^ self copyto: (LargePositiveInteger new: self digitLength)! !


!LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:10'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."

	^ self shouldNotImplement! !


!LargeNegativeInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:10'!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen minVal |
	<primitive: 'primNormalizeNegative' module:'LargeIntegers'>
	"First establish len = significant length"
	len _ oldLen _ self digitLength.
	[len = 0 ifTrue: [^0].
	(self digitAt: len) = 0]
		whileTrue: [len _ len - 1].

	"Now check if in SmallInteger range"
	sLen _ 4  "SmallInteger minVal digitLength".
	len <= sLen ifTrue:
		[minVal _ SmallInteger minVal.
		(len < sLen
			or: [(self digitAt: sLen) < minVal lastDigit])
			ifTrue: ["If high digit less, then can be small"
					val _ 0.
					len to: 1 by: -1 do:
						[:i | val _ (val *256) - (self digitAt: i)].
					^ val].
		1 to: sLen do:  "If all digits same, then = minVal"
			[:i | (self digitAt: i) = (minVal digitAt: i)
					ifFalse: ["Not so; return self shortened"
							len < oldLen
								ifTrue: [^ self growto: len]
								ifFalse: [^ self]]].
		^ minVal].

	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: [^ self growto: len]
		ifFalse: [^ self]! !


!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ true! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ false! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'!
sign
	"Optimization. Answer -1 since receiver is less than 0."

	^ -1
! !

!LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:03'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ false! !


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

LargeNegativeInteger class
	instanceVariableNames: ''!

!LargeNegativeInteger class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 12:05'!
initializedInstance
	^ -9876543210987654321 copy! !
Integer variableByteSubclass: #LargePositiveInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!LargePositiveInteger commentStamp: '<historical>' prior: 0!
I represent positive integers of more than 30 bits (ie, >= 1073741824).  These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits.  Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize).

Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits.  This is a great help to the simulator.!


!LargePositiveInteger methodsFor: 'arithmetic'!
* anInteger 
	"Primitive. Multiply the receiver by the argument and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 29>
	^super * anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
+ anInteger 
	"Primitive. Add the receiver to the argument and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 21>
	^super + anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
- anInteger 
	"Primitive. Subtract the argument from the receiver and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 22>
	^super - anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
/ anInteger 
	"Primitive. Divide the receiver by the argument and answer with the
	result if the division is exact. Fail if the result is not a whole integer.
	Fail if the argument is 0. Fail if either the argument or the result is not
	a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 30>
	^super / anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
// anInteger 
	"Primitive. Divide the receiver by the argument and return the result.
	Round the result down towards negative infinity to make it a whole
	integer. Fail if the argument is 0. Fail if either the argument or the
	result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
	Optional. See Object documentation whatIsAPrimitive. "

	<primitive: 32>
	^super // anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic'!
\\ anInteger 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided
	by the argument. Fail if the argument is 0. Fail if either the argument
	or the result is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 31>
	^super \\ anInteger! !

!LargePositiveInteger methodsFor: 'arithmetic' stamp: 'RAA 5/31/2000 13:21'!
\\\ anInteger 
	"a faster modulo method for use in DSA. Be careful if you try to use this elsewhere"

	^(self digitDiv: anInteger neg: false) second! !

!LargePositiveInteger methodsFor: 'arithmetic'!
abs! !

!LargePositiveInteger methodsFor: 'arithmetic'!
negated 
	^ (self copyto: (LargeNegativeInteger new: self digitLength))
		normalize  "Need to normalize to catch SmallInteger minVal"! !

!LargePositiveInteger methodsFor: 'arithmetic'!
quo: anInteger 
	"Primitive. Divide the receiver by the argument and return the result.
	Round the result down towards zero to make it a whole integer. Fail if
	the argument is 0. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 33>
	^super quo: anInteger! !


!LargePositiveInteger methodsFor: 'bit manipulation'!
bitAnd: anInteger 
	"Primitive. Answer an Integer whose bits are the logical AND of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 14>
	^ super bitAnd: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitOr: anInteger 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 15>
	^ super bitOr: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitShift: anInteger 
	"Primitive. Answer an Integer whose value (in twos-complement 
	representation) is the receiver's value (in twos-complement
	representation) shifted left by the number of bits indicated by the
	argument. Negative arguments shift right. Zeros are shifted in from the
	right in left shifts. The sign bit is extended in right shifts.
	Fail if the receiver or result is greater than 32 bits.
	See Object documentation whatIsAPrimitive."
	<primitive: 17>
	^super bitShift: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation'!
bitXor: anInteger 
	"Primitive. Answer an Integer whose bits are the logical XOR of the
	receiver's bits and those of the argument. Fail if the receiver or argument
	is greater than 32 bits. See Object documentation whatIsAPrimitive."
	<primitive: 16>
	^ super bitXor: anInteger! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'SqR 9/18/2000 15:17'!
hashMultiply
	"Truncate to 28 bits and try again"

	^(self bitAnd: 16rFFFFFFF) hashMultiply! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:11'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to  
	get the highest bit of the magnitude."
	^ self highBitOfMagnitude! !

!LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:15'!
highBitOfMagnitude
	"Answer the index of the high order bit of the magnitude of the  
	receiver, or zero if the receiver is zero.  
	This method is used for LargeNegativeIntegers as well,  
	since Squeak's LargeIntegers are sign/magnitude."
	| realLength lastDigit |
	realLength _ self digitLength.
	[(lastDigit _ self digitAt: realLength) = 0]
		whileTrue: [(realLength _ realLength - 1) = 0 ifTrue: [^ 0]].
	^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! !


!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ false! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:00'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ true! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'!
sign
	"Optimization. Answer 1 since receiver is greater than 0."

	^ 1
! !

!LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ true! !


!LargePositiveInteger methodsFor: 'comparing'!
< anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824).
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 23>
	^super < anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
<= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than or equal to the argument. Otherwise answer false.
	Fail if the argument is not a SmallInteger or a LargePositiveInteger less
	than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 25>
	^super <= anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	receiver or argument is negative or greater than 32 bits.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 7>
	^ super = anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
> anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger or a LargePositiveInteger less than
	2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 24>
	^super > anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
>= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger or a LargePositiveInteger
	less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive."

	<primitive: 26>
	^super >= anInteger! !

!LargePositiveInteger methodsFor: 'comparing'!
~= anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	receiver or argument is negative or greater than 32 bits.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 8>
	^ super ~= anInteger! !


!LargePositiveInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:09'!
normalize
	"Check for leading zeroes and return shortened copy if so"
	| sLen val len oldLen |
	<primitive: 'primNormalizePositive' module:'LargeIntegers'>
	"First establish len = significant length"
	len _ oldLen _ self digitLength.
	[len = 0 ifTrue: [^0].
	(self digitAt: len) = 0]
		whileTrue: [len _ len - 1].

	"Now check if in SmallInteger range"
	sLen _ SmallInteger maxVal digitLength.
	(len <= sLen
		and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)])
		ifTrue: ["If so, return its SmallInt value"
				val _ 0.
				len to: 1 by: -1 do:
					[:i | val _ (val *256) + (self digitAt: i)].
				^ val].

	"Return self, or a shortened copy"
	len < oldLen
		ifTrue: [^ self growto: len]
		ifFalse: [^ self]! !


!LargePositiveInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'!
digitAt: index 
	"Primitive. Answer the value of an indexable field in the receiver.   LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256.  Fail if the argument (the index) is not an Integer or is out of bounds. Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 60>
	self digitLength < index
		ifTrue: [^0]
		ifFalse: [^super at: index]! !

!LargePositiveInteger methodsFor: 'system primitives'!
digitAt: index put: value 
	"Primitive. Store the second argument (value) in the indexable field of 
	the receiver indicated by index. Fail if the value is negative or is larger 
	than 255. Fail if the index is not an Integer or is out of bounds. Answer 
	the value that was stored. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 61>
	^super at: index put: value! !

!LargePositiveInteger methodsFor: 'system primitives'!
digitLength
	"Primitive. Answer the number of indexable fields in the receiver. This 
	value is the same as the largest legal subscript. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 62>
	self primitiveFailed! !

!LargePositiveInteger methodsFor: 'system primitives'!
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! !

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

LargePositiveInteger class
	instanceVariableNames: ''!

!LargePositiveInteger class methodsFor: 'testing' stamp: 'sw 5/8/2000 12:05'!
initializedInstance
	^ 12345678901234567 copy! !

!LargePositiveInteger class methodsFor: 'testing'!
test: n  "Time millisecondsToRun: [LargePositiveInteger test: 100] 1916"
	| f f1 |
	"Test and time mult, div, add, subtract"
	f _ n factorial.
	f1 _ f*(n+1).
	n timesRepeat: [f1 _ f1 - f].
	f1 = f ifFalse: [self halt].
	n timesRepeat: [f1 _ f1 + f].
	f1 // f = (n+1) ifFalse: [self halt].
	f1 negated = (Number readFrom: '-' , f1 printString) ifFalse: [self halt].

	"Check normalization and conversion to/from SmallInts"
	(SmallInteger maxVal + 1 - 1) == SmallInteger maxVal ifFalse: [self halt].
	(SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3) ifFalse: [self halt].
	(SmallInteger minVal - 1 + 1) == SmallInteger minVal ifFalse: [self halt].
	(SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3) ifFalse: [self halt].

	"Check bitShift from and back to SmallInts"
	1 to: 257 do: [:i | ((i bitShift: i) bitShift: 0-i) == i ifFalse: [self halt]].
! !
Object subclass: #LayoutCell
	instanceVariableNames: 'target cellSize extraSpace flags nextCell '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutCell commentStamp: '<historical>' prior: 0!
I am used in table layouts to hold temporary values while the layout is being computed.

Instance variables:
	target 		<Morph>		The morph contained in this cell
	cellSize 		<Point>		The size of the cell
	extraSpace 	<nil | Point>	Additional space to add after this cell
	nextCell 	<nil | LayoutCell>	The next cell in the arrangement.

Implementation note:
Both, cellSize and extraSpace contains points where
	x - represents the primary table direction
	y - represents the secondary table direction
!


!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/2/2000 17:15'!
addExtraSpace: aPoint
	extraSpace 
		ifNil:[extraSpace _ aPoint]
		ifNotNil:[extraSpace _ extraSpace + aPoint]! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
cellSize
	^cellSize! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
cellSize: aPoint
	cellSize _ aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 11/10/2000 17:09'!
extraSpace
	^extraSpace ifNil:[0@0]! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 21:30'!
extraSpace: aPoint
	extraSpace _ aPoint! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/31/2000 21:24'!
hSpaceFill
	^flags anyMask: 1! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/31/2000 23:23'!
hSpaceFill: aBool
	flags ifNil:[flags _ 0].
	flags _ aBool ifTrue:[flags bitOr: 1] ifFalse:[flags bitClear: 1].
! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
nextCell
	^nextCell! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
nextCell: aCell
	nextCell _ aCell! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:11'!
target
	^target! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'!
target: newTarget
	target _ newTarget! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/31/2000 21:24'!
vSpaceFill
	^flags anyMask: 2! !

!LayoutCell methodsFor: 'accessing' stamp: 'ar 10/31/2000 23:23'!
vSpaceFill: aBool
	flags ifNil:[flags _ 0].
	flags _ aBool ifTrue:[flags bitOr: 2] ifFalse:[flags bitClear: 2].
! !


!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 18:58'!
do: aBlock
	aBlock value: self.
	nextCell ifNotNil:[nextCell do: aBlock].! !

!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 21:27'!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue! !

!LayoutCell methodsFor: 'collection' stamp: 'ar 10/28/2000 21:41'!
size
	| n cell |
	n _ 0.
	cell _ self.
	[cell == nil] whileFalse:[
		n _ n + 1.
		cell _ cell nextCell].
	^n! !
Object subclass: #LayoutFrame
	instanceVariableNames: 'leftFraction leftOffset topFraction topOffset rightFraction rightOffset bottomFraction bottomOffset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutFrame commentStamp: '<historical>' prior: 0!
I define a frame for positioning some morph in a proportional layout.

Instance variables:
	leftFraction 
	topFraction 
	rightFraction 
	bottomFraction 	<Float>		The fractional distance (between 0 and 1) to place the morph in its owner's bounds
	leftOffset 
	topOffset 
	rightOffset 
	bottomOffset 	<Integer>	Fixed pixel offset to apply after fractional positioning (e.g., "10 pixel right of the center of the owner")!


!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction
	^bottomFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction: aNumber
	bottomFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomFraction: aNumber offset: anInteger

	bottomFraction _ aNumber.
	bottomOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomOffset
	^bottomOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
bottomOffset: anInteger
	bottomOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction
	^leftFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction: aNumber
	leftFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftFraction: aNumber offset: anInteger

	leftFraction _ aNumber.
	leftOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'!
leftOffset
	^leftOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
leftOffset: anInteger
	leftOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction
	^rightFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction: aNumber
	rightFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightFraction: aNumber offset: anInteger

	rightFraction _ aNumber.
	rightOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightOffset
	^rightOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
rightOffset: anInteger
	rightOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
topFraction
	^topFraction! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'!
topFraction: aNumber
	topFraction _ aNumber! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topFraction: aNumber offset: anInteger

	topFraction _ aNumber.
	topOffset _ anInteger! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topOffset
	^topOffset! !

!LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'!
topOffset: anInteger
	topOffset _ anInteger! !


!LayoutFrame methodsFor: 'layout' stamp: 'JW 2/1/2001 13:04'!
layout: oldBounds in: newBounds
	"Return the proportional rectangle insetting the given bounds"
	| left right top bottom |
	leftFraction ifNotNil:[
		left _ newBounds left + (newBounds width * leftFraction).
		leftOffset ifNotNil:[left _ left + leftOffset]].
	rightFraction ifNotNil:[
		right _ newBounds right - (newBounds width * (1.0 - rightFraction)).
		rightOffset ifNotNil:[right _ right + rightOffset]].
	topFraction ifNotNil:[
		top _ newBounds top + (newBounds height * topFraction).
		topOffset ifNotNil:[top _ top + topOffset]].
	bottomFraction ifNotNil:[
		bottom _ newBounds bottom - (newBounds height * (1.0 - bottomFraction)).
		bottomOffset ifNotNil:[bottom _ bottom + bottomOffset]].
	left ifNil:[ right 
			ifNil:[left _ oldBounds left. right _ oldBounds right]
			ifNotNil:[left _ right - oldBounds width]].
	right ifNil:[right _ left + oldBounds width].
	top ifNil:[ bottom 
			ifNil:[top _ oldBounds top. bottom _ oldBounds bottom]
			ifNotNil:[top _ bottom - oldBounds height]].
	bottom ifNil:[bottom _ top + oldBounds height].
	^(left rounded @ top rounded) corner: (right rounded @ bottom rounded)! !


!LayoutFrame methodsFor: 'objects from disk' stamp: 'JW 2/1/2001 13:33'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	| className oldClassVersion |

	"JW 2/1/2001"
	"Since class version isn't passed in varDict, look it up through smartRefSrm."
	className := varDict at: #ClassName.
	oldClassVersion := (smartRefStrm structures at: className) first.
	(oldClassVersion = 0) ifTrue: [ self negateBottomRightOffsets ].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

!LayoutFrame methodsFor: 'objects from disk' stamp: 'JW 2/1/2001 14:37'!
negateBottomRightOffsets

	bottomOffset ifNotNil: [ bottomOffset := bottomOffset negated ].
	rightOffset ifNotNil: [ rightOffset := rightOffset negated ].

! !

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

LayoutFrame class
	instanceVariableNames: ''!

!LayoutFrame class methodsFor: 'as yet unclassified' stamp: 'JW 2/1/2001 12:48'!
classVersion
	^1 "changed treatment of bottomOffset and rightOffset"
! !

!LayoutFrame class methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2001 21:22'!
fractions: fractionsOrNil offsets: offsetsOrNil

	| fractions offsets |

	fractions _ fractionsOrNil ifNil: [0@0 extent: 0@0].
	offsets _ offsetsOrNil ifNil: [0@0 extent: 0@0].
	^self new
		topFraction: fractions top offset: offsets top;
		leftFraction: fractions left offset: offsets left;
		bottomFraction: fractions bottom offset: offsets bottom;
		rightFraction: fractions right offset: offsets right
! !
Object subclass: #LayoutPolicy
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutPolicy commentStamp: '<historical>' prior: 0!
A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.!


!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'!
isProportionalLayout
	^false! !

!LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'!
isTableLayout
	^false! !


!LayoutPolicy methodsFor: 'layout' stamp: 'ar 1/27/2001 14:39'!
flushLayoutCache
	"Flush any cached information associated with the receiver"! !

!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/28/2000 19:12'!
layout: aMorph in: newBounds
	"Compute the layout for the given morph based on the new bounds"
! !

!LayoutPolicy methodsFor: 'layout' stamp: 'ar 10/31/2000 19:59'!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	^0@0! !


!LayoutPolicy methodsFor: 'utilities' stamp: 'ar 10/29/2000 17:31'!
indexForInserting: aMorph at: aPoint in: someMorph
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
	^1 "front-most"! !
Object subclass: #LayoutProperties
	instanceVariableNames: 'hResizing vResizing disableLayout '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!LayoutProperties commentStamp: '<historical>' prior: 0!
This class provides a compact bit encoding for the most commonly used layout properties.!


!LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:53'!
initialize
	hResizing _ vResizing _ #rigid.
	disableLayout _ false.! !

!LayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:56'!
initializeFrom: defaultProvider
	"Initialize the receiver from a default provider"
	self hResizing: defaultProvider hResizing.
	self vResizing: defaultProvider vResizing.
	self disableTableLayout: defaultProvider disableTableLayout.! !


!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
disableTableLayout
	^disableLayout! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
disableTableLayout: aBool
	disableLayout _ aBool! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
hResizing
	^hResizing! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
hResizing: aSymbol
	hResizing _ aSymbol! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'!
vResizing
	^vResizing! !

!LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:52'!
vResizing: aSymbol
	vResizing _ aSymbol! !


!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:53'!
cellInset
	"Default"
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:50'!
cellPositioning
	^#center! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:55'!
cellSpacing
	"Default"
	^#none! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:38'!
layoutInset
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:58'!
listCentering
	"Default"
	^#topLeft! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'!
listDirection
	"Default"
	^#topToBottom! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'!
listSpacing
	"Default"
	^#none! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
maxCellSize
	^SmallInteger maxVal! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
minCellSize
	^0! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'!
reverseTableCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:01'!
rubberBandCells
	^false! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'!
wrapCentering
	^#topLeft! !

!LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:02'!
wrapDirection
	^#none! !


!LayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'!
includesTableProperties
	^false! !


!LayoutProperties methodsFor: 'converting' stamp: 'ar 11/14/2000 17:52'!
asTableLayoutProperties
	^(TableLayoutProperties new)
		hResizing: self hResizing;
		vResizing: self vResizing;
		disableTableLayout: self disableTableLayout;
		yourself! !

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

LayoutProperties class
	instanceVariableNames: ''!

!LayoutProperties class methodsFor: 'instance creation' stamp: 'ar 11/13/2000 18:16'!
new
	^super new initialize! !
ParseNode subclass: #LeafNode
	instanceVariableNames: 'key code '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!LeafNode commentStamp: '<historical>' prior: 0!
I represent a leaf node of the compiler parse tree. I am abstract.
	
Types (defined in class ParseNode):
	1 LdInstType (which uses class VariableNode)
	2 LdTempType (which uses class VariableNode)
	3 LdLitType (which uses class LiteralNode)
	4 LdLitIndType (which uses class VariableNode)
	5 SendType (which uses class SelectorNode).

Note that Squeak departs slightly from the Blue Book bytecode spec.

In order to allow access to more than 63 literals and instance variables,
bytecode 132 has been redefined as DoubleExtendedDoAnything:
		byte2				byte3			Operation
(hi 3 bits)  (lo 5 bits)
	0		nargs			lit index			Send Literal Message 0-255
	1		nargs			lit index			Super-Send Lit Msg 0-255
	2		ignored			rcvr index		Push Receiver Variable 0-255
	3		ignored			lit index			Push Literal Constant 0-255
	4		ignored			lit index			Push Literal Variable 0-255
	5		ignored			rcvr index		Store Receiver Variable 0-255
	6		ignored			rcvr index		Store-pop Receiver Variable 0-255
	7		ignored			lit index			Store Literal Variable 0-255

	This has allowed bytecode 134 also to be redefined as a second extended send
	that can access literals up to 64 for nargs up to 3 without needing three bytes.
	It is just like 131, except that the extension byte is aallllll instead of aaalllll,
	where aaa are bits of argument count, and lll are bits of literal index.!


!LeafNode methodsFor: 'initialize-release'!
key: object code: byte

	key _ object.
	code _ byte! !

!LeafNode methodsFor: 'initialize-release'!
key: object index: i type: type

	self key: object code: (self code: i type: type)! !

!LeafNode methodsFor: 'initialize-release'!
name: ignored key: object code: byte

	key _ object.
	code _ byte! !

!LeafNode methodsFor: 'initialize-release'!
name: literal key: object index: i type: type

	self key: object
		index: i
		type: type! !


!LeafNode methodsFor: 'accessing'!
key

	^key! !


!LeafNode methodsFor: 'code generation'!
code

	^code! !

!LeafNode methodsFor: 'code generation'!
emitForEffect: stack on: strm

	^self! !

!LeafNode methodsFor: 'code generation'!
emitLong: mode on: aStream 
	"Emit extended variable access."
	| type index |
	code < 256
		ifTrue:
			[code < 16
			ifTrue: [type _ 0.
					index _ code]
			ifFalse: [code < 32
					ifTrue: [type _ 1.
							index _ code - 16]
					ifFalse: [code < 96
							ifTrue: [type _ code // 32 + 1.
									index _ code \\ 32]
							ifFalse: [self error: 
									'Sends should be handled in SelectorNode']]]]
		ifFalse: 
			[index _ code \\ 256.
			type _ code // 256 - 1].
	index <= 63 ifTrue:
		[aStream nextPut: mode.
		^ aStream nextPut: type * 64 + index].
	"Compile for Double-exetended Do-anything instruction..."
	mode = LoadLong ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(64 0 96 128) at: type+1).  "Cant be temp (type=1)"
		^ aStream nextPut: index].
	mode = Store ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(160 0 0 224) at: type+1).  "Cant be temp or const (type=1 or 2)"
		^ aStream nextPut: index].
	mode = StorePop ifTrue:
		[aStream nextPut: DblExtDoAll.
		aStream nextPut: (#(192 0 0 0) at: type+1).  "Can only be inst"
		^ aStream nextPut: index].
! !

!LeafNode methodsFor: 'code generation'!
reserve: encoder 
	"If this is a yet unused literal of type -code, reserve it."

	code < 0 ifTrue: [code _ self code: (encoder litIndex: key) type: 0 - code]! !

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

	^0! !

!LeafNode methodsFor: 'code generation'!
sizeForValue: encoder
	self reserve: encoder.
	code < 256 ifTrue: [^ 1].
	(code \\ 256) <= 63 ifTrue: [^ 2].
	^ 3! !


!LeafNode methodsFor: 'private'!
code: index type: type

	index isNil 
		ifTrue: [^type negated].
	(CodeLimits at: type) > index 
		ifTrue: [^(CodeBases at: type) + index].
	^type * 256 + index! !


!LeafNode methodsFor: 'copying' stamp: 'tk 10/20/2000 11:45'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
key _ deepCopier references at: key ifAbsent: [key].
! !

!LeafNode methodsFor: 'copying' stamp: 'tk 10/20/2000 11:41'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"key _ key.		Weakly copied"
code _ code veryDeepCopyWith: deepCopier.
! !
Morph subclass: #LedDigitMorph
	instanceVariableNames: 'digit highlighted '
	classVariableNames: 'HSegmentOrigins HSegments VSegmentOrigins VSegments '
	poolDictionaries: ''
	category: 'Morphic-Games'!
!LedDigitMorph commentStamp: '<historical>' prior: 0!
I am a 7-segment LED that can display a decimal digit!


!LedDigitMorph methodsFor: 'initialization' stamp: 'tao 5/18/1998 17:01'!
initialize

	super initialize.
	color _ Color green.
	highlighted _ false.
	digit _ 0.! !


!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:00'!
digit

	^ digit! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:00'!
digit: anInteger

	digit _ anInteger \\ 10	"make sure it stays between 0 and 9"! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 17:00'!
highlighted

	^ highlighted! !

!LedDigitMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 18:43'!
highlighted: aBoolean

	highlighted _ aBoolean.
	self changed.! !


!LedDigitMorph methodsFor: 'drawing' stamp: 'rjf 5/25/2000 00:16'!
drawOn: aCanvas

	| foregroundColor backgroundColor thickness hThickness vThickness hOffset vOffset |
	foregroundColor _ highlighted ifTrue: [Color white] ifFalse: [color].
	backgroundColor _ color darker darker darker.
	hThickness _ self height * 0.1.
	vThickness _ self width * 0.1.
	thickness _ hThickness min: vThickness.
	vOffset _ ((hThickness - thickness) // 2) max: 0.
	hOffset _ ((vThickness - thickness) // 2) max: 0.
	aCanvas fillRectangle: self bounds color: backgroundColor.
	"added to show the minus sign"
	(digit asString = '-') ifTrue: [digit _ 10].
	HSegmentOrigins with: (HSegments at: digit+1) do:
		[:o :isLit |
		aCanvas
			fillRectangle: (Rectangle
				origin: (self position + (0@vOffset) + (o * self extent)) rounded
				extent: ((self width * 0.6) @ thickness) rounded)
			color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])].
	VSegmentOrigins with: (VSegments at: digit+1) do:
		[:o :isLit |
		aCanvas
			fillRectangle: (Rectangle
				origin: (self position + (hOffset@0) + (o * self extent)) rounded
				extent: (thickness @ (self height * 0.25)) rounded)
			color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])].
! !

!LedDigitMorph methodsFor: 'drawing' stamp: 'tao 5/18/1998 13:58'!
drawOnFills: aRectangle

	^ true! !

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

LedDigitMorph class
	instanceVariableNames: ''!

!LedDigitMorph class methodsFor: 'initialization' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !

!LedDigitMorph class methodsFor: 'initialization' stamp: 'rjf 5/25/2000 00:16'!
initialize

	HSegmentOrigins _ {0.2@0.1. 0.2@0.45. 0.2@0.8}.
	VSegmentOrigins _ {0.1@0.2. 0.1@0.55. 0.8@0.2. 0.8@0.55}.
	HSegments _ {
		{true. false. true}.
		{false. false. false}.
		{true. true. true}.
		{true. true. true}.
		{false. true. false}.
		{true. true. true}.
		{true. true. true}.
		{true. false. false}.
		{true. true. true}.
		{true. true. true}.
		{false. true. false}}.
	VSegments _ {
		{true. true. true. true}.
		{false. false. true. true}.
		{false. true. true. false}.
		{false. false. true. true}.
		{true. false. true. true}.
		{true. false. false. true}.
		{true. true. false. true}.
		{false. false. true. true}.
		{true. true. true. true}.
		{true. false. true. true}.
		{false. false. false. false}}.! !
Morph subclass: #LedMorph
	instanceVariableNames: 'digits value flashing flash '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!LedMorph commentStamp: '<historical>' prior: 0!
I am a collection of LED digits that can display a decimal value.  The display can be set to flash by sending flash: true.!


!LedMorph methodsFor: 'initialization' stamp: 'tao 5/18/1998 20:38'!
initialize

	super initialize.
	flashing _ false.
	flash _ false.
	self digits: 2.
	self value: 0.
	self color: Color green.
! !


!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:51'!
color: aColor

	color _ aColor.
	self submorphsDo: [:m | m color: aColor]! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:42'!
digits

	^ digits! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:46'!
digits: aNumber

	digits _ aNumber.
	self removeAllMorphs.
	1 to: digits do: [:i | self addMorph: (LedDigitMorph new color: color)].
	self layoutChanged.
	self changed.! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 18:26'!
flash

	^ flash! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 18:26'!
flash: aBoolean

	flash _ aBoolean.! !

!LedMorph methodsFor: 'accessing' stamp: 'djp 11/29/1999 17:27'!
highlighted: aBoolean

	self submorphsDo: [:m | m highlighted: aBoolean]! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:42'!
value

	^ value! !

!LedMorph methodsFor: 'accessing' stamp: 'tao 5/18/1998 13:47'!
value: aNumber

	| val |
	value _ aNumber.
	val _ value.
	submorphs reverseDo:
		[:m |
		m digit: val \\ 10.
		val _ val // 10].
	self changed.! !


!LedMorph methodsFor: 'drawing' stamp: 'tao 5/18/1998 14:00'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds color: color darker darker.
! !


!LedMorph methodsFor: 'change reporting' stamp: 'tao 5/18/1998 13:53'!
layoutChanged

	super layoutChanged.
	submorphs withIndexDo:
		[:m :i |
		m
			position: self position + (((i-1) * self width / digits) rounded @ 0);
			extent: (self width / digits) rounded @ self height]! !


!LedMorph methodsFor: 'stepping' stamp: 'djp 11/29/1999 17:27'!
step

	(flash or: [flashing])
		ifTrue:
			[flashing _ flashing not.
			self highlighted: flashing]! !

!LedMorph methodsFor: 'stepping' stamp: 'tao 5/18/1998 18:44'!
stepTime

	^ 500! !

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

LedMorph class
	instanceVariableNames: ''!

!LedMorph class methodsFor: 'as yet unclassified' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
LedMorph subclass: #LedTimerMorph
	instanceVariableNames: 'counting startSeconds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 19:36'!
continue

	counting _ true! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 21:58'!
pause

	counting ifTrue: [self updateTime].
	counting _ false! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/23/1999 21:46'!
reset

	startSeconds _ Time totalSeconds.
	self value: 0.! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 19:02'!
resume

	counting ifFalse: [
		counting _ true.
		startSeconds _  (Time totalSeconds) - self value]! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/23/1999 21:35'!
start

	counting _ true! !

!LedTimerMorph methodsFor: 'accessing' stamp: 'djp 10/31/1999 21:44'!
stop

	counting ifTrue: [self updateTime].
	counting _ false.! !


!LedTimerMorph methodsFor: 'initialization' stamp: 'djp 10/23/1999 21:43'!
initialize

	super initialize.
	counting _ false.
	startSeconds _ Time totalSeconds.! !


!LedTimerMorph methodsFor: 'stepping' stamp: 'djp 10/24/1999 01:12'!
step

	flash
		ifTrue: [super step]
		ifFalse: [
			counting ifTrue: [self updateTime]]! !

!LedTimerMorph methodsFor: 'stepping' stamp: 'djp 10/23/1999 21:27'!
stepTime

	^ 1000! !

!LedTimerMorph methodsFor: 'stepping' stamp: 'djp 10/24/1999 01:12'!
updateTime

	self value:  Time totalSeconds - startSeconds.
	self changed! !

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

LedTimerMorph class
	instanceVariableNames: ''!

!LedTimerMorph class methodsFor: 'as yet unclassified' stamp: 'di 1/16/2000 10:39'!
includeInNewMorphMenu

	^false! !
HTMLformatter subclass: #LessHTMLformatter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!LessHTMLformatter commentStamp: '<historical>' prior: 0!
The LessHTMLformatter provides a few more plaintext notations to swikify, to avoid typing HTML a bit more.  Used in rendering -- see FileList renderFile!
]style[(133 19)f1,f1LFileList renderFile;!


!LessHTMLformatter methodsFor: 'translating' stamp: 'mjg 9/30/1998 13:39'!
swikify: aStringOrStream linkhandler: aBlock
	| sourceStream aLine targetStream start end forbidden ignore |
	(aStringOrStream isKindOf: Stream)
		ifTrue: [sourceStream := aStringOrStream]
		ifFalse: [sourceStream := ReadStream on: aStringOrStream].
	forbidden _ self rangesOfAngleBrackets: sourceStream.
	targetStream := WriteStream on: String new.
	[sourceStream atEnd] whileFalse:
		[aLine := sourceStream upTo: (Character cr).
		" Now, look for links "
		start _ 1.
		[(start _ aLine indexOfSubCollection: (specialCharacter asString) 
				startingAt: start ifAbsent: [0]) ~= 0
			and: [start < aLine size]]
		whileTrue:
			[(aLine at: start+1) = specialCharacter
			ifTrue: [aLine _ aLine copyReplaceFrom: start 
						to: start+1 with: specialCharacter asString.
					start_start + 1.]
			ifFalse: [
				(end _ aLine indexOfSubCollection: (specialCharacter asString)  
					startingAt: (start+1) ifAbsent: [0]) ~= 0
				ifTrue: [aLine _ aLine copyReplaceFrom: start to: end
						with: (aBlock value: (aLine copyFrom: start+1 to: end-1))]
				ifFalse: [start _ start + 1]]].

		"If it's at least 4 dashes, make it a horizontal rule"
		(aLine indexOfSubCollection: '----' startingAt: 1) = 1
			ifTrue: [targetStream nextPutAll: '<hr>' ; cr.]
			ifFalse: [
				(aLine beginsWith: '-')
				ifTrue: [targetStream nextPutAll: '<li>',aLine allButFirst; cr.]
				ifFalse: [
				(aLine beginsWith: '====')
				ifTrue: [targetStream nextPutAll: '<h4>',
					(aLine copyFrom: 5 to: aLine size),'</h4>';cr.]
				ifFalse: [
				(aLine beginsWith: '===')
				ifTrue: [targetStream nextPutAll: '<h3>',
					(aLine copyFrom: 4 to: aLine size),'</h3>';cr.]
				ifFalse: [
				(aLine beginsWith: '==')
				ifTrue: [targetStream nextPutAll: '<h2>',
					(aLine copyFrom: 3 to: aLine size),'</h2>';cr.]
				ifFalse: [
				(aLine beginsWith: '=')
				ifTrue: [targetStream nextPutAll: '<h1>',
					aLine allButFirst,'</h1>';cr.]
				ifFalse: [
				(aLine beginsWith: '!!')
				ifTrue: [targetStream nextPutAll: '<b>',aLine allButFirst,'</b>';cr.]
				ifFalse: [
				((aLine beginsWith: '|') and: [(aLine count: [:c | c= $|]) > 2])
							"Then treat it as a table"
				ifTrue: [targetStream nextPutAll: '<tr><td>',
					(aLine allButFirst allButLast copyReplaceAll: '|' with:
						'</td><td>'),'</td></tr>'.]
				ifFalse: [targetStream nextPutAll: aLine].]]]]]]].
		"Should there be a <br> after this line?"
		(ignore _ sourceStream peek = $<) ifTrue: [
			"If just before a tag, ignore the newline"
			targetStream nextPut: $ ].	"but do put in a separator"
		forbidden do: [:interval |
			(interval includes: sourceStream position) ifTrue: [ignore _ true]].
		ignore ifFalse: [
			(sourceStream peek) = (Character cr)
				ifTrue: [sourceStream next. targetStream nextPutAll: '<p>'; cr.]
				ifFalse: [targetStream cr.].]
			ifTrue: [targetStream cr.].].
	^targetStream contents.
! !
Object subclass: #LiljencrantsFant
	instanceVariableNames: 'ro ra rk a1 a2 x1 x2 b1 c1 n0 ne '
	classVariableNames: 'Epsilon '
	poolDictionaries: ''
	category: 'Speech-Klatt'!
!LiljencrantsFant commentStamp: '<historical>' prior: 0!
This is the LF glottal-pulse model. Actually this is here only for pedagogical purposes. The LF model is again implemented in KlattSynthesizer (and as primitive in the KlattSynthesizerPluggin). For more details on the LF model see:
	Fant, G., Liljencrants, J., & Lin, Q. "A four-parameter model of glottal flow", Speech Transmission Laboratory Qurterly Progress Report 4/85, KTH.
!


!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 01:15'!
n0: anInteger
	n0 _ anInteger! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 01:15'!
ne: anInteger
	ne _ anInteger! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
ra
	^ ra! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
ra: aNumber
	ra _ aNumber! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
rk
	^ rk! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:02'!
rk: aNumber
	rk _ aNumber! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:36'!
ro
	^ ro! !

!LiljencrantsFant methodsFor: 'accessing' stamp: 'len 9/15/1999 00:37'!
ro: aNumber
	ro _ aNumber! !


!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:14'!
computeSamplesInto: aFloatArray
	| s0 s1 s2 |
	aFloatArray at: 1 put: x1.
	s2 _ x1.
	aFloatArray at: 2 put: x2.
	s1 _ x2.
	3 to: ne - 1 do: [ :each |
		s0 _ a1 * s1 + (a2 * s2).
		aFloatArray at: each put: s0.
		s2 _ s1.
		s1 _ s0].
	ne to: n0 do: [ :each | aFloatArray at: each put: b1 * (aFloatArray at: each - 1) - c1]! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:23'!
d
	| r |
	ra <= 0.0 ifTrue: [^ 1.0].
	r _ 1.0 - ro / ra.
	^ 1.0 - (r / (r exp - 1.0))! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/26/1999 22:12'!
example1
	"
	Utilities plot: LiljencrantsFant new example1
	"
	self t0: 1 / 133 * 4 ro: 0.25 rk: 0.25 ra: 0.01 samplingRate: 22025.
	self init.
	^ self samples! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 10/29/1999 01:55'!
init
	| d phi cosphi sinphi rphid u theta rho gamma gammapwr |
	d _ self d.
	phi _ Float pi * (rk + 1.0).
	cosphi _ phi cos.
	sinphi _ phi sin.
	rphid _ ra / ro * phi * d.

	u _ self zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
	theta _ phi / ne.
	rho _ (u * theta) exp.
	a1 _ 2.0 * theta cos * rho.
	a2 _ 0.0 - (rho * rho).
	x1 _ 0.0.
	x2 _ rho * theta sin.

	gamma _ (-1.0 / (ra * n0)) exp.
	gammapwr _ gamma raisedTo: n0 - ne.

	b1 _ gamma.
	c1 _ (1.0 - gamma) * gammapwr / (1.0 - gammapwr)! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:10'!
qu: u phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| expuphi |
	expuphi _ (u * phi) exp.
	^ expuphi * ((rphid * (u*u + 1.0) + u) * sinphi - cosphi) + 1.0! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:16'!
samples
	| answer |
	answer _ FloatArray new: n0.
	self computeSamplesInto: answer.
	^ answer! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:30'!
t0: t0 ro: roNumber rk: rkNumber ra: raNumber samplingRate: samplingRate
	| doubleN0 |
	doubleN0 _ samplingRate * t0.
	n0 _ doubleN0 asInteger.
	ne _ (doubleN0 * roNumber) asInteger.
	ro _ ne asFloat / n0 asFloat.
	rk _ rkNumber.
	ra _ raNumber! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:29'!
t0: t0 tp: tp te: te ta: ta samplingRate: samplingRate
	self t0: t0 ro: te / t0 rk: te - tp / tp ra: ta / t0 samplingRate: samplingRate! !

!LiljencrantsFant methodsFor: 'processing' stamp: 'len 9/15/1999 01:07'!
zeroQphi: phi cosphi: cosphi sinphi: sinphi rphid: rphid
	| qzero ua ub qa qb uc qc |
	qzero _ self qu: 0 phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.

	qzero > 0
		ifTrue: [ua _ 0. ub _ 1.
				qa _ qzero. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
				[qb > 0]
					whileTrue: [ua _ ub. qa _ qb.
								ub _ ub * 2. qb _ self qu: ub phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]]
		ifFalse: [ua _ -1. ub _ 0.
				qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid. qb _ qzero.
				[qa < 0]
					whileTrue: [ub _ ua. qb _ qa.
								ua _ ua * 2. qa _ self qu: ua phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid]].
	[ub - ua > Epsilon]
		whileTrue: [uc _ ub + ua / 2. qc _ self qu: uc phi: phi cosphi: cosphi sinphi: sinphi rphid: rphid.
					qc > 0 ifTrue: [ua _ uc. qa _ qc] ifFalse: [ub _ uc. qb _ qc]].
	^ ub + ua / 2! !

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

LiljencrantsFant class
	instanceVariableNames: ''!

!LiljencrantsFant class methodsFor: 'initialize-release' stamp: 'len 9/15/1999 00:58'!
initialize
	"
	LiljencrantsFant initialize
	"
	Epsilon _ 1.0e-04! !
WriteStream subclass: #LimitedWriteStream
	instanceVariableNames: 'limit limitBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!LimitedWriteStream commentStamp: '<historical>' prior: 0!
A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished.  For a simple example take a look at the universal Object printString.

The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. !
]style[(323 18 15 54 151)f1,f1LObject printString;,f1,f1LSequenceableCollection class streamContents:limitedTo:;,f1!


!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 08:55'!
pastEndPut: anObject
	collection size >= limit ifTrue: [limitBlock value].  "Exceptional return"
	collection _ collection ,
		(collection class new: ((collection size max: 20) min: limit)).
	writeLimit _ collection size.
	collection at: (position _ position + 1) put: anObject! !

!LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 6/20/97 09:07'!
setLimit: sizeLimit limitBlock: aBlock
	"Limit the numer of elements this stream will write..."
	limit _ sizeLimit.
	"Execute this (typically ^ contents) when that limit is exceded"
	limitBlock _ aBlock! !
Object subclass: #LimitingLineStreamWrapper
	instanceVariableNames: 'stream line limitingBlock position '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Collections-Streams'!
!LimitingLineStreamWrapper commentStamp: '<historical>' prior: 0!
I'm a wrapper for a stream optimized for line-by-line access using #nextLine. My instances can be nested.

I read one line ahead. Reading terminates when the stream ends, or if the limitingBlock evaluated with the line answers true. To skip the delimiting line for further reading use #skipThisLine.

Character-based reading (#next) is permitted, too. Send #updatePosition when switching from line-based reading.

See examples at the class side.

--bf 2/19/1999 12:52!


!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:25'!
delimiter: aString
	"Set limitBlock to check for a delimiting string. Be unlimiting if nil"

	self limitingBlock: (aString caseOf: {
		[nil] -> [[:aLine | false]].
		[''] -> [[:aLine | aLine size = 0]]
	} otherwise: [[:aLine | aLine beginsWith: aString]])
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:08'!
lastLineRead
	"Return line last read. At stream end, this is the boundary line or nil"

	^ line! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 19:16'!
limitingBlock: aBlock
	"The limitingBlock is evaluated with a line to check if this line terminates the stream"

	limitingBlock _ aBlock fixTemps.
	self updatePosition! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:45'!
linesUpToEnd

	| elements ln |
	elements _ OrderedCollection new.
	[(ln _ self nextLine) isNil] whileFalse: [ 
		elements add: ln].
	^elements! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'!
next
	"Provide character-based access"

	position isNil ifTrue: [^nil].
	position < line size ifTrue: [^line at: (position _ position + 1)].
	line _ stream nextLine.
	self updatePosition.
	^ Character cr! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:09'!
nextLine

	| thisLine |
	self atEnd ifTrue: [^nil].
	thisLine _ line.
	line _ stream nextLine.
	^thisLine
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:04'!
peekLine

	self atEnd ifTrue: [^nil].
	^ line! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 16:53'!
skipThisLine

	line _ stream nextLine.
	self updatePosition.
! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 2/19/1999 11:47'!
upToEnd

	| ln |
	^String streamContents: [:strm |
		[(ln _ self nextLine) isNil] whileFalse: [ 
			strm nextPutAll: ln; cr]]! !

!LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:37'!
updatePosition
	"Call this before doing character-based access"

	position _ self atEnd ifFalse: [0]! !


!LimitingLineStreamWrapper methodsFor: 'testing' stamp: 'bf 11/13/1998 16:55'!
atEnd

	^line isNil or: [limitingBlock value: line]! !


!LimitingLineStreamWrapper methodsFor: 'stream protocol' stamp: 'bf 11/13/1998 17:00'!
close
	^stream close! !


!LimitingLineStreamWrapper methodsFor: 'printing' stamp: 'bf 11/24/1998 13:39'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' on '.
	stream printOn: aStream! !


!LimitingLineStreamWrapper methodsFor: 'private' stamp: 'bf 11/24/1998 14:30'!
setStream: aStream delimiter: aString

	stream _ aStream.
	line _ stream nextLine.
	self delimiter: aString.	"sets position"
! !

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

LimitingLineStreamWrapper class
	instanceVariableNames: ''!

!LimitingLineStreamWrapper class methodsFor: 'instance creation' stamp: 'bf 11/24/1998 14:31'!
on: aStream delimiter: aString

	^self new setStream: aStream delimiter: aString
! !


!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 11:48'!
example1
	"LimitingLineStreamWrapper example1"
	"Separate chunks of text delimited by a special string"
	| inStream msgStream messages |
	inStream _ self exampleStream.
	msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
	messages _ OrderedCollection new.
	[inStream atEnd] whileFalse: [
		msgStream skipThisLine.
		messages add: msgStream upToEnd].
	^messages
			! !

!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:46'!
example2
	"LimitingLineStreamWrapper example2"
	"Demo nesting wrappers - get header lines from some messages"
	| inStream msgStream headers headerStream |
	inStream _ self exampleStream.
	msgStream _ LimitingLineStreamWrapper on: inStream delimiter: 'From '.
	headers _ OrderedCollection new.
	[inStream atEnd] whileFalse: [
		msgStream skipThisLine. "Skip From"
		headerStream _ LimitingLineStreamWrapper on: msgStream delimiter: ''.
		headers add: headerStream linesUpToEnd.
		[msgStream nextLine isNil] whileFalse. "Skip Body"
	].
	^headers
			! !

!LimitingLineStreamWrapper class methodsFor: 'examples' stamp: 'bf 2/19/1999 12:44'!
exampleStream
	^ReadStream on:
'From me@somewhere
From: me
To: you
Subject: Test

Test

From you@elsewhere
From: you
To: me
Subject: Re: test

okay
'! !
Path subclass: #Line
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Line commentStamp: '<historical>' prior: 0!
I represent the line segment specified by two points.!


!Line methodsFor: 'accessing'!
beginPoint
	"Answer the first end point of the receiver."

	^self first! !

!Line methodsFor: 'accessing'!
beginPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 1 put: aPoint.
	^aPoint! !

!Line methodsFor: 'accessing'!
endPoint
	"Answer the last end point of the receiver."

	^self last! !

!Line methodsFor: 'accessing'!
endPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 2 put: aPoint.
	^aPoint! !


!Line methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"The form associated with this Path will be displayed, according  
	to one of the sixteen functions of two logical variables (rule), at  
	each point on the Line. Also the source form will be first anded  
	with aForm as a mask. Does not effect the state of the Path."

	collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points'].
	aDisplayMedium
		drawLine: self form
		from: self beginPoint + aPoint
		to: self endPoint + aPoint
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

	| newPath newLine |
	newPath _ aTransformation applyTo: self.
	newLine _ Line new.
	newLine beginPoint: newPath firstPoint.
	newLine endPoint: newPath secondPoint.
	newLine form: self form.
	newLine
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

!Line methodsFor: 'displaying'!
displayOnPort: aPort at: aPoint 
	aPort sourceForm: self form; combinationRule: Form under; fillColor: nil.
	aPort drawFrom: collectionOfPoints first + aPoint
		to: collectionOfPoints last + aPoint! !

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

Line class
	instanceVariableNames: ''!

!Line class methodsFor: 'instance creation'!
from: beginPoint to: endPoint withForm: aForm 
	"Answer an instance of me with end points begingPoint and endPoint; 
	the source form for displaying the line is aForm."

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: beginPoint.
	newSelf add: endPoint.
	newSelf form: aForm.
	^newSelf! !

!Line class methodsFor: 'instance creation'!
new

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !


!Line class methodsFor: 'examples'!
example
	"Designate two places on the screen by clicking any mouse button. A
	straight path with a square black form will be displayed connecting the
	two selected points."

	| aLine aForm |  
	aForm _ Form extent: 20@20.		"make a form one quarter of inch square"
	aForm fillBlack.							"turn it black"
	aLine _ Line new.
	aLine form: aForm.						"use the black form for display"
	aLine beginPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aLine beginPoint.	
	aLine endPoint: Sensor waitButton.
	aLine displayOn: Display.				"display the line"

	"Line example"! !
PolygonMorph subclass: #LineMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!LineMorph commentStamp: '<historical>' prior: 0!
This is really only a shell for creating single-segment straight-line Shapes.!


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

LineMorph class
	instanceVariableNames: ''!

!LineMorph class methodsFor: 'as yet unclassified' stamp: 'di 8/20/2000 12:18'!
from: startPoint to: endPoint color: lineColor width: lineWidth

	^ PolygonMorph vertices: {startPoint. endPoint}
			color: Color black borderWidth: lineWidth borderColor: lineColor! !

!LineMorph class methodsFor: 'as yet unclassified' stamp: 'di 8/20/2000 12:16'!
new
	^ self from: 0@0 to: 50@50 color: Color black width: 2! !
Object subclass: #LineSegment
	instanceVariableNames: 'start end '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!
!LineSegment commentStamp: '<historical>' prior: 0!
This class represents a straight line segment between two points

Instance variables:
	start	<Point>	start point of the line
	end		<Point>	end point of the line
!


!LineSegment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:12'!
from: startPoint to: endPoint
	"Initialize the receiver"
	start _ startPoint.
	end _ endPoint.! !


!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
bounds
	"Return the bounds containing the receiver"
	^(start min: end) corner: (start max: end)! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
end
	"Return the end point"
	^end! !

!LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'!
start
	"Return the start point"
	^start! !


!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:12'!
hasZeroLength
	"Return true if the receiver has zero length"
	^start = end! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'!
isBezier2Segment
	"Return true if the receiver is a quadratic bezier segment"
	^false! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:07'!
isLineSegment
	"Return true if the receiver is a line segment"
	^true! !

!LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:08'!
isStraight
	"Return true if the receiver represents a straight line"
	^true! !


!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'!
length
	"Return the length of the receiver"
	^start dist: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:08'!
lineSegmentsDo: aBlock
	"Evaluate aBlock with the receiver's line segments"
	aBlock value: start value: end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAt: parameter
	"Return the tangent at the given parametric value along the receiver"
	^end - start! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAtEnd
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
tangentAtStart
	"Return the tangent for the last point"
	^(end - start)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:09'!
valueAt: parameter
	"Evaluate the receiver at the given parametric value"
	^start + (end - start * parameter)! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'!
valueAtEnd
	"Evaluate the receiver at it's end point (e.g., self valueAtEnd = (self valueAt: 1.0))"
	^end! !

!LineSegment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:10'!
valueAtStart
	"Evaluate the receiver at it's start point (e.g., self valueAtEnd = (self valueAt: 0.0))"
	^start! !


!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asBezier2Segment
	"Represent the receiver as quadratic bezier segment"
	^Bezier2Segment from: start to: end! !

!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asIntegerSegment
	"Convert the receiver into integer representation"
	^self species from: start asIntegerPoint to: end asIntegerPoint! !

!LineSegment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:11'!
asLineSegment
	"Represent the receiver as a straight line segment"
	^self! !


!LineSegment methodsFor: 'printing' stamp: 'ar 11/2/1998 12:13'!
printOn: aStream
	"Print the receiver on aStream"
	aStream 
		nextPutAll: self class name;
		nextPutAll:' from: ';
		print: start;
		nextPutAll: ' to: ';
		print: end;
		space.! !


!LineSegment methodsFor: 'private' stamp: 'ar 5/25/2000 17:59'!
debugDraw
	| canvas |
	canvas _ Display getCanvas.
	self lineSegmentsDo:[:p1 :p2|
		canvas line: p1 rounded to: p2 rounded width: 1 color: Color black.
	].! !

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

LineSegment class
	instanceVariableNames: ''!

!LineSegment class methodsFor: 'instance creation' stamp: 'ar 11/1/1998 21:10'!
from: startPoint to: endPoint
	^self new from: startPoint to: endPoint! !
Path subclass: #LinearFit
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!LinearFit commentStamp: '<historical>' prior: 0!
I represent a piece-wise linear approximation to a set of points in the plane.!


!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 22:16'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger
fillColor: aForm
 
	| line |
	line _ Line new.
	line form: self form.
	1 to: self size - 1 do: 
		[:i | 
		line beginPoint: (self at: i).
		line endPoint: (self at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!LinearFit methodsFor: 'displaying' stamp: 'jrm 9/7/1999 23:00'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox:
clipRect rule: anInteger fillColor: aForm 

	| transformedPath |
	"get the scaled and translated Path."
	transformedPath _ aTransformation applyTo: self.
	transformedPath
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !

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

LinearFit class
	instanceVariableNames: ''!

!LinearFit class methodsFor: 'examples'!
example
	"Select points on a Path using the red button. Terminate by selecting
	any other button. Creates a Path from the points and displays it as a
	piece-wise linear approximation." 

	| aLinearFit aForm flag |
	aLinearFit _ LinearFit new.
	aForm _ Form extent: 1 @ 40.
	aForm  fillBlack.
	aLinearFit form: aForm.
	flag _ true.
	[flag] whileTrue:
		[Sensor waitButton.
		 Sensor redButtonPressed
			ifTrue: [aLinearFit add: Sensor waitButton. Sensor waitNoButton.
					aForm displayOn: Display at: aLinearFit last]
			ifFalse: [flag_false]].
	aLinearFit displayOn: Display

	"LinearFit example"! !
Object subclass: #Link
	instanceVariableNames: 'nextLink '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!Link commentStamp: '<historical>' prior: 0!
An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.!


!Link methodsFor: 'accessing'!
nextLink
	"Answer the link to which the receiver points."

	^nextLink! !

!Link methodsFor: 'accessing'!
nextLink: aLink 
	"Store the argument, aLink, as the link to which the receiver refers. 
	Answer aLink."

	^nextLink _ aLink! !

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

Link class
	instanceVariableNames: ''!

!Link class methodsFor: 'instance creation' stamp: 'apb 10/3/2000 15:55'!
nextLink: aLink 
	"Answer an instance of me referring to the argument, aLink."

	^self new nextLink: aLink; yourself! !
SequenceableCollection subclass: #LinkedList
	instanceVariableNames: 'firstLink lastLink '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!LinkedList commentStamp: '<historical>' prior: 0!
I represent a collection of links, which are containers for other objects. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue.!


!LinkedList methodsFor: 'accessing'!
first
	"Answer the first link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^firstLink! !

!LinkedList methodsFor: 'accessing'!
last
	"Answer the last link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^lastLink! !


!LinkedList methodsFor: 'testing'!
isEmpty

	^firstLink == nil! !


!LinkedList methodsFor: 'adding'!
add: aLink 
	"Add aLink to the end of the receiver's list. Answer aLink."

	^self addLast: aLink! !

!LinkedList methodsFor: 'adding'!
addFirst: aLink 
	"Add aLink to the beginning of the receiver's list. Answer aLink."

	self isEmpty ifTrue: [lastLink _ aLink].
	aLink nextLink: firstLink.
	firstLink _ aLink.
	^aLink! !

!LinkedList methodsFor: 'adding'!
addLast: aLink 
	"Add aLink to the end of the receiver's list. Answer aLink."

	self isEmpty
		ifTrue: [firstLink _ aLink]
		ifFalse: [lastLink nextLink: aLink].
	lastLink _ aLink.
	^aLink! !


!LinkedList methodsFor: 'removing'!
remove: aLink ifAbsent: aBlock  
	"Remove aLink from the receiver. If it is not there, answer the result of
	evaluating aBlock."

	| tempLink |
	aLink == firstLink
		ifTrue: [firstLink _ aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ nil]]
		ifFalse: [tempLink _ firstLink.
				[tempLink == nil ifTrue: [^aBlock value].
				 tempLink nextLink == aLink]
					whileFalse: [tempLink _ tempLink nextLink].
				tempLink nextLink: aLink nextLink.
				aLink == lastLink
					ifTrue: [lastLink _ tempLink]].
	aLink nextLink: nil.
	^aLink! !

!LinkedList methodsFor: 'removing'!
removeFirst
	"Remove the first element and answer it. If the receiver is empty, create 
	an error notification."

	| oldLink |
	self emptyCheck.
	oldLink _ firstLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [firstLink _ oldLink nextLink].
	oldLink nextLink: nil.
	^oldLink! !

!LinkedList methodsFor: 'removing'!
removeLast
	"Remove the receiver's last element and answer it. If the receiver is 
	empty, create an error notification."

	| oldLink aLink |
	self emptyCheck.
	oldLink _ lastLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [aLink _ firstLink.
				[aLink nextLink == oldLink] whileFalse:
					[aLink _ aLink nextLink].
				 aLink nextLink: nil.
				 lastLink _ aLink].
	oldLink nextLink: nil.
	^oldLink! !


!LinkedList methodsFor: 'enumerating'!
do: aBlock

	| aLink |
	aLink _ firstLink.
	[aLink == nil] whileFalse:
		[aBlock value: aLink.
		 aLink _ aLink nextLink]! !
MessageSet subclass: #LinkedMessageSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!LinkedMessageSet commentStamp: '<historical>' prior: 0!
An instance of me holds a list of methods (or class comment, class defintion, class hierarchy).  When a user clicks on a HyperText link, the place referred to is displayed in me.  The non-method contents are not meant to be edited and accepted.

To create a link to a class comment:
In any piece of text, type the name of a class.
Select it.
Command-6.
Choose 'go to comment of class'
Then a user can click on that text later and she will be transported to the class's comment.

To create a link to a method, class definition, or class hierarchy: Do the same as above, but choose the appropriate menu item. !


!LinkedMessageSet methodsFor: 'as yet unclassified' stamp: 'jm 3/24/98 16:05'!
contents: aText notifying: aController
	"override to handle class dfn and comment"

	self setClassAndSelectorIn: [:class :selector | 
		selector first isUppercase ifFalse: [
			^ super contents: aText notifying: aController].
		selector = #Comment ifTrue: [
			class comment: aText.
 			self clearUserEditFlag.
			^ false].
		selector = #Definition ifTrue: [
			"self defineClass: aText notifying: aController."
			class subclassDefinerClass
				evaluate: aText
				notifying: aController
				logged: true.
			self clearUserEditFlag.
 			^ false].
		selector = #Hierarchy ifTrue: [
			self inform: 'To change the hierarchy, edit the class definitions'. ^ false].
		].! !

!LinkedMessageSet methodsFor: 'as yet unclassified' stamp: 'tk 4/9/98 14:02'!
initializeMessageList: anArray
	messageList _ anArray.
	self messageListIndex: (messageList size min: 1).	"0 or 1"
! !

!LinkedMessageSet methodsFor: 'as yet unclassified' stamp: 'tk 4/25/1998 00:07'!
linkMethod: classAndMethod
	"Make a linked message list and put this method in it.  For example, click here: LinkedMessageSet linkMethod:."

	"Do some checks here on the user's text!!!!!!"
	self okToChange ifFalse: [^ self].
	messageList add: classAndMethod.
	self changed: #messageList.
	self messageListIndex: messageList size.! !

!LinkedMessageSet methodsFor: 'as yet unclassified' stamp: 'di 6/7/2000 22:53'!
selectedMessage
	"Answer the source method for the currently selected message.  Allow class comment, definition, and hierarchy."

	| source |
	self setClassAndSelectorIn: [:class :selector | 
		selector first isUppercase ifFalse:
			[source _ class sourceMethodAt: selector.
			currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil]..
			^ source asText makeSelectorBoldIn: self selectedClassOrMetaClass].
		selector = #Comment ifTrue: [^ class comment].
		selector = #Definition ifTrue: [^ class definitionST80: Preferences printAlternateSyntax not].
		selector = #Hierarchy ifTrue: [^ class printHierarchy].
		source _ class sourceMethodAt: selector.
		currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil].
		Preferences browseWithPrettyPrint ifTrue:
			[source _ class compilerClass new
				format: source in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting].
		^ source asText makeSelectorBoldIn: self selectedClassOrMetaClass]! !
PolygonMorph subclass: #LipsMorph
	instanceVariableNames: 'newVertices newScale '
	classVariableNames: 'PhoneticArticulations '
	poolDictionaries: ''
	category: 'Speech-Gestures'!

!LipsMorph methodsFor: 'initialization' stamp: 'di 9/7/2000 17:22'!
initialize
	super initialize.
 	self beSmoothCurve.
	vertices _ {11@3. 35@1. 60@5. 67@17. 34@24. 3@17}.
	color _ Color black. "red darker."
	borderColor _ Color black.
	borderWidth _ 1.
	closed _ true.
	self neutral; updateShape! !


!LipsMorph methodsFor: 'accessing' stamp: 'len 8/22/1999 17:54'!
verticesString
	| stream first |
	stream _ WriteStream with: ''.
	stream nextPut: ${.
	first _ true.
	vertices do: [ :each |
		first ifFalse: [stream nextPutAll: '. '].
		stream print: (each - self position) rounded.
		first _ false].
	stream nextPut: $}.
	^ stream contents! !


!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 23:17'!
articulate: aPhoneme
	self newVerticesCentered: (PhoneticArticulations at: aPhoneme ifAbsent: [^ self]) scaled: 0.5! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/24/1999 01:13'!
grin
	self newVerticesCentered: {17@5. 30@7. 33@12. 16@14. 2@10. 5@2}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/24/1999 00:11'!
hideTongue
	self submorphs do: [ :each | each delete]! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:14'!
horror
	self newVerticesCentered: {21@3. 37@5. 36@19. 19@19. 3@19. 5@4}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:15'!
neutral
	self newVerticesCentered: {13@1. 22@4. 12@6. 1@4}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:34'!
newVerticesCentered: anArray
	self newVerticesCentered: anArray scaled: 0.5! !

!LipsMorph methodsFor: 'actions' stamp: 'len 9/6/1999 01:35'!
newVerticesCentered: anArray scaled: aNumber
	newVertices _ anArray.
	newScale _ aNumber! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 17:32'!
openness: amount
	self newVerticesCentered: {40@-3. 74@8. 59@ (21 * amount). 38@ (20 * amount). 22@ (21 * amount). 3@8}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:11'!
sad
	self newVerticesCentered: {26@4. 50@10. 41@4. 27@2. 14@3. 1@10}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/24/1999 00:10'!
showTongue
	| tongue |
	self hideTongue.
	tongue _ CurveMorph vertices: {10@2. 21@5. 16@23. 10@27. 5@23. 2@4} color: Color red borderWidth: 0 borderColor: Color black.
	tongue position: self center - (10 @ 0).
	self addMorphFront: tongue! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 19:12'!
smile
	self newVerticesCentered: {26@11. 43@7. 51@2. 44@12. 26@19. 8@14. 2@4. 12@9}! !

!LipsMorph methodsFor: 'actions' stamp: 'len 8/22/1999 22:34'!
surprise
	self newVerticesCentered:  {22@3. 38@7. 37@21. 20@26. 4@21. 6@6}! !

!LipsMorph methodsFor: 'actions' stamp: 'di 9/8/2000 10:44'!
updateShape
	| center median |
	newVertices isNil ifTrue: [^ self].
	median _ 0 @ 0.
	newVertices do: [ :each | median _ median + each].
	median _ median / newVertices size.
	center _ self center.
	self setVertices: (newVertices collect: [ :each | (each - median) * newScale + median]).
	self position: self position - self center + center.
	newVertices _ nil! !

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

LipsMorph class
	instanceVariableNames: ''!

!LipsMorph class methodsFor: 'class initialization' stamp: 'len 8/22/1999 18:28'!
initialize
	"
	LipsMorph initialize
	"
	| o u a e i m n p t s |
	a _ {22@2. 39@4. 45@16. 23@23. 2@15. 9@4}.
	e _ {23@2. 41@3. 45@15. 21@19. 2@14. 6@3}.
	i _ {21@2. 40@4. 45@14. 23@16. 2@13. 8@4}.
	o _ {18@1. 31@5. 31@20. 16@24. 3@19. 5@5}.
	u _ {14@1. 23@6. 22@16. 11@20. 2@14. 3@4}.
	m _ {17@2. 31@2. 27@4. 15@3. 2@4. 6@2}.
	n _ {20@3. 33@2. 39@8. 19@9. 2@8. 7@2}.
	p _ {7@1. 16@3. 12@5. 6@6. 1@4}.
	t _ {14@2. 29@3. 21@7. 12@8. 1@3}.
	s _ {19@2. 32@4. 35@10. 18@13. 2@10. 9@3}.
	PhoneticArticulations _ Dictionary new.
	"Default"
	PhonemeSet arpabet do: [ :each | PhoneticArticulations at: each put: p].
	"Vowels"
	PhonemeSet arpabet do: [ :each |
		each name first = $a ifTrue: [PhoneticArticulations at: each put: a].
		each name first = $e ifTrue: [PhoneticArticulations at: each put: e].
		each name first = $i ifTrue: [PhoneticArticulations at: each put: i].
		each name first = $o ifTrue: [PhoneticArticulations at: each put: o].
		each name first = $u ifTrue: [PhoneticArticulations at: each put: u].
		each name first = $w ifTrue: [PhoneticArticulations at: each put: u]].
	"Particulars"
	PhoneticArticulations
		at: (PhonemeSet arpabet at: 'm') put: m;
		at: (PhonemeSet arpabet at: 'n') put: n;
		at: (PhonemeSet arpabet at: 't') put: t;
		at: (PhonemeSet arpabet at: 's') put: s;
		at: (PhonemeSet arpabet at: 'sh') put: s;
		at: (PhonemeSet arpabet at: 'sh') put: s;
		at: (PhonemeSet arpabet at: 'zh') put: s;
		at: (PhonemeSet arpabet at: 'th') put: s;
		at: (PhonemeSet arpabet at: 'jh') put: s;
		at: (PhonemeSet arpabet at: 'dh') put: s;
		at: (PhonemeSet arpabet at: 'd') put: s;
		at: (PhonemeSet arpabet at: 'z') put: s! !
PluggableListMorph subclass: #ListComponent
	instanceVariableNames: 'selectedItem setSelectionSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!ListComponent methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 08:26'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."

	setIndexSelector
		ifNil: 	["If model is not hooked up to index, then we won't get
					an update, so have to do it locally."
				self selectionIndex: anInteger]
		ifNotNil: [model perform: setIndexSelector with: anInteger].
	selectedItem _ anInteger = 0 ifTrue: [nil] ifFalse: [list at: anInteger].
	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: selectedItem]! !

!ListComponent methodsFor: 'as yet unclassified' stamp: 'di 5/1/1998 23:20'!
initFromPinSpecs
	| ioPin |
	getListSelector _ pinSpecs first modelReadSelector.
	ioPin _ pinSpecs second.
	ioPin isInput ifTrue: [getIndexSelector _ ioPin modelReadSelector]
					ifFalse: [getIndexSelector _ nil].
	ioPin isOutput ifTrue: [setIndexSelector _ ioPin modelWriteSelector]
					ifFalse: [setIndexSelector _ nil].
	setSelectionSelector _ pinSpecs third modelWriteSelector.
! !

!ListComponent methodsFor: 'as yet unclassified' stamp: 'di 5/1/1998 13:38'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'list' direction: #input
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getListSelector modelWriteSelector: nil
				defaultValue: #(one two three) pinLoc: 1.5)
		with: (PinSpec new pinName: 'index' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getIndexSelector modelWriteSelector: setIndexSelector
				defaultValue: 0 pinLoc: 2.5)
		with: (PinSpec new pinName: 'selectedItem' direction: #output
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: nil modelWriteSelector: setSelectionSelector
				defaultValue: nil pinLoc: 3.5)! !

!ListComponent methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 11:09'!
list: listOfItems
	super list: listOfItems.
	self selectionIndex: 0.
	selectedItem _ nil.
	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: selectedItem]! !
ScrollController subclass: #ListController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListController commentStamp: '<historical>' prior: 0!
I am a kind of ScrollController that assumes that the view is a kind of ListView. Therefore, scrolling means moving the items in a textual list (menu) up or down. In addition, I provide the red button activity of determining when the red button is selecting an item in the list.!


!ListController methodsFor: 'control defaults' stamp: 'bf 4/14/1999 12:41'!
controlActivity
	self scrollByKeyboard ifTrue: [^self].
	self processKeyboard.
	super controlActivity.
! !


!ListController methodsFor: 'marker adjustment'!
computeMarkerRegion 
	"Refer to the comment in ScrollController|computeMarkerRegion."

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height = 0
		ifTrue: [^ 0@0 extent: Preferences scrollBarWidth@scrollBar inside height].
	^ 0@0 extent: Preferences scrollBarWidth@
			((viewList clippingRectangle height asFloat /
						viewList compositionRectangle height *
							scrollBar inside height)
					rounded min: scrollBar inside height)! !

!ListController methodsFor: 'marker adjustment'!
markerDelta

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height == 0 ifTrue: [
		^ (marker top - scrollBar inside top) - scrollBar inside height
	].
	^ (marker top - scrollBar inside top) -
		((viewList clippingRectangle top -
				viewList compositionRectangle top) asFloat /
			viewList compositionRectangle height asFloat *
			scrollBar inside height asFloat) rounded
! !


!ListController methodsFor: 'scrolling'!
scrollAmount 
	"Refer to the comment in ScrollController|scrollAmount."

	^sensor cursorPoint y - scrollBar inside top! !

!ListController methodsFor: 'scrolling'!
scrollView: anInteger 
	"Scroll the view and highlight the selection if it just came into view"
	| wasClipped |
	wasClipped _ view isSelectionBoxClipped.
	(view scrollBy: anInteger)
		ifTrue: [view isSelectionBoxClipped ifFalse:
					[wasClipped ifTrue:  "Selection came into view"
						[view displaySelectionBox]].
				^ true]
		ifFalse: [^ false]! !

!ListController methodsFor: 'scrolling'!
viewDelta 
	"Refer to the comment in ScrollController|viewDelta."

	| viewList |
	viewList _ view list.
	^(viewList clippingRectangle top -
			viewList compositionRectangle top -
			((marker top - scrollBar inside top) asFloat /
				scrollBar inside height asFloat *
				viewList compositionRectangle height asFloat))
		roundTo: viewList lineGrid! !


!ListController methodsFor: 'selecting' stamp: 'tk 4/1/98 10:33'!
redButtonActivity
	| noSelectionMovement oldSelection selection nextSelection pt scrollFlag firstTime |
	noSelectionMovement _ true.
	scrollFlag _ false.
	oldSelection _ view selection.
	firstTime _ true.
	[sensor redButtonPressed | firstTime]
		whileTrue: 
			[selection _ view findSelection: (pt _ sensor cursorPoint).
			firstTime _ false.
			selection == nil ifTrue:  "Maybe out of box - check for auto-scroll"
					[pt y < view insetDisplayBox top ifTrue:
						[self scrollView: view list lineGrid.
						scrollFlag _ true.
						selection _ view firstShown].
					pt y > view insetDisplayBox bottom ifTrue:
						[self scrollView: view list lineGrid negated.
						scrollFlag _ true.
						selection _ view lastShown]].
			selection == nil ifFalse:
					[view moveSelectionBox: (nextSelection _ selection).
					nextSelection ~= oldSelection
						ifTrue: [noSelectionMovement _ false]]].
	nextSelection ~~ nil & (nextSelection = oldSelection
			ifTrue: [noSelectionMovement]
			ifFalse: [true]) ifTrue: [self changeModelSelection: nextSelection].
	scrollFlag ifTrue: [self moveMarker]! !


!ListController methodsFor: 'private'!
changeModelSelection: anInteger
	model toggleListIndex: anInteger! !


!ListController methodsFor: 'menu messages' stamp: 'acg 9/18/1999 14:09'!
processKeyboard
	"Derived from a Martin Pammer submission, 02/98"

     | keyEvent oldSelection nextSelection max min howMany |
	sensor keyboardPressed ifFalse: [^ self].

     keyEvent := sensor keyboard asciiValue.
     oldSelection := view selection.
     nextSelection := oldSelection.
     max := view maximumSelection.
     min := view minimumSelection.
     howMany := view clippingBox height // view list lineGrid.

     keyEvent == 31 ifTrue:
		["down-arrow; move down one, wrapping to top if needed"
		nextSelection := oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].

     keyEvent == 30 ifTrue:
		["up arrow; move up one, wrapping to bottom if needed"
		nextSelection := oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].

     keyEvent == 1  ifTrue: [nextSelection := 1].  "home"
     keyEvent == 4  ifTrue: [nextSelection := max].   "end"
     keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection -
howMany)].  "page up"
     keyEvent == 12  ifTrue: [nextSelection := (oldSelection + howMany)
min: max].  "page down"
     nextSelection = oldSelection  ifFalse:
		[model okToChange
			ifTrue:
				[self changeModelSelection: nextSelection.
				self moveMarker]]
			! !
Object subclass: #ListItemWrapper
	instanceVariableNames: 'item model '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!ListItemWrapper commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:13'!
acceptDroppingObject: anotherItem

	^item acceptDroppingObject: anotherItem! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:17'!
asString

	^item asString! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 10:59'!
balloonText

	^nil! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:25'!
canBeDragged

	^true! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:32'!
contents

	^Array new! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:24'!
handlesMouseOver: evt

	^false! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/1/1999 20:09'!
hasContents

	^self contents isEmpty not! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:15'!
hasEquivalentIn: aCollection

	aCollection detect: [ :each | 
		each withoutListWrapper = item withoutListWrapper
	] ifNone: [^false].
	^true! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 8/3/1999 09:40'!
highlightingColor

	^Color red! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/2/1999 15:14'!
preferredColor

	^nil! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 4/4/1999 17:58'!
sendSettingMessageTo: aModel

	aModel 
		perform: (self settingSelector ifNil: [^self])
		with: self withoutListWrapper
! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:27'!
setItem: anObject

	item _ anObject! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'!
setItem: anObject model: aModel

	item _ anObject.
	model _ aModel.! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 21:31'!
settingSelector

	^nil! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:32'!
wantsDroppedObject: anotherItem

	^false! !

!ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^item withoutListWrapper! !

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

ListItemWrapper class
	instanceVariableNames: ''!

!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:28'!
with: anObject

	^self new setItem: anObject! !

!ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'!
with: anObject model: aModel

	^self new setItem: anObject model: aModel! !
Paragraph subclass: #ListParagraph
	instanceVariableNames: ''
	classVariableNames: 'ListStyle '
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListParagraph commentStamp: '<historical>' prior: 0!
I represent a special type of Paragraph that is used in the list panes of a browser.  I  avoid all the composition done by more general Paragraphs, because I know the structure of my Text.!


!ListParagraph methodsFor: 'composition'!
composeAll
	"No composition is necessary once the ListParagraph is created."
	
	lastLine isNil ifTrue: [lastLine _ 0].	
		"Because composeAll is called once in the process of creating the ListParagraph."
	^compositionRectangle width! !


!ListParagraph methodsFor: 'private'!
trimLinesTo: lastLineInteger
	"Since ListParagraphs are not designed to be changed, we can cut back the
		lines field to lastLineInteger."
	lastLine _ lastLineInteger.
	lines _ lines copyFrom: 1 to: lastLine! !

!ListParagraph methodsFor: 'private' stamp: 'di 7/13/97 16:56'!
withArray: anArray 
	"Modifies self to contain the list of strings in anArray"
	| startOfLine endOfLine lineIndex aString |
	lines _ Array new: 20.
	lastLine _ 0.
	startOfLine _ 1.
	endOfLine _ 1.
	lineIndex _ 0.
	anArray do: 
		[:item | 
		endOfLine _ startOfLine + item size.		"this computation allows for a cr after each line..."
												"...but later we will adjust for no cr after last line"
		lineIndex _ lineIndex + 1.
		self lineAt: lineIndex put:
			((TextLineInterval start: startOfLine stop: endOfLine
				internalSpaces: 0 paddingWidth: 0)
				lineHeight: textStyle lineGrid baseline: textStyle baseline).
		startOfLine _ endOfLine + 1].
	endOfLine _ endOfLine - 1.		"endOfLine is now the total size of the text"
	self trimLinesTo: lineIndex.
	aString _ String new: endOfLine.
	anArray with: lines do: 
		[:item :interval | 
		aString
			replaceFrom: interval first
			to: interval last - 1
			with: item asString
			startingAt: 1.
		interval last <= endOfLine ifTrue: [aString at: interval last put: Character cr]].
	lineIndex > 0 ifTrue: [(lines at: lineIndex) stop: endOfLine].	"adjust for no cr after last line"
	self text: aString asText.
	anArray with: lines do: 
		[:item :interval |  item isText ifTrue:
			[text replaceFrom: interval first to: interval last - 1 with: item]].
	self updateCompositionHeight! !

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

ListParagraph class
	instanceVariableNames: ''!

!ListParagraph class methodsFor: 'instance creation' stamp: 'jm 9/20/1998 17:10'!
withArray: anArray style: aTextStyleOrNil
	"Convert an array of strings into a ListParagraph using the given TextStyle."

	aTextStyleOrNil
		ifNil: [^ (super withText: Text new style: ListStyle) withArray: anArray]
		ifNotNil: [^ (super withText: Text new style: aTextStyleOrNil) withArray: anArray].
! !


!ListParagraph class methodsFor: 'initialization' stamp: 'sw 12/10/1999 10:37'!
initialize 
	"ListParagraph initialize"
	| aFont |
	"Allow different line spacing for lists"
	aFont _ Preferences standardListFont.
	ListStyle _ aFont textStyle copy consistOnlyOf: aFont.
	ListStyle gridForFont: 1 withLead: 1! !


!ListParagraph class methodsFor: 'style' stamp: 'sw 12/10/1999 10:43'!
standardListStyle
	^ ListStyle! !
View subclass: #ListView
	instanceVariableNames: 'list selection topDelimiter bottomDelimiter isEmpty textStyle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!ListView commentStamp: '<historical>' prior: 0!
I am an abstract View of a list of items. I provide support for storing a selection of one item, as well as formatting the list for presentation on the screen. My instances' default controller is ListController.!


!ListView methodsFor: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	topDelimiter _ '------------'.
	bottomDelimiter _ '------------'.
	isEmpty _ true.
	self list: Array new! !


!ListView methodsFor: 'font access' stamp: 'sw 12/9/1999 18:07'!
font
	^ self assuredTextStyle fontNamed: textStyle fontNames first
! !

!ListView methodsFor: 'font access' stamp: 'jm 9/20/1998 19:44'!
font: aFontOrNil

	aFontOrNil
		ifNil: [textStyle _ nil]
		ifNotNil: [
			textStyle _ TextStyle fontArray: (Array with: aFontOrNil).
			textStyle gridForFont: 1 withLead: 1].
	self changed: #list.  "update display"
! !


!ListView methodsFor: 'list access' stamp: 'sw 12/10/1999 10:43'!
assuredTextStyle
	^ textStyle ifNil:
		[textStyle _  ListParagraph standardListStyle]
! !

!ListView methodsFor: 'list access'!
list
	"Answer the list of items the receiver displays."

	^list! !

!ListView methodsFor: 'list access' stamp: 'sw 12/9/1999 18:06'!
list: anArray 
	"Set the list of items the receiver displays to be anArray."
	| arrayCopy i |
	isEmpty _ anArray isEmpty.
	arrayCopy _ Array new: (anArray size + 2).
	arrayCopy at: 1 put: topDelimiter.
	arrayCopy at: arrayCopy size put: bottomDelimiter.
	i _ 2.
	anArray do: [:el | arrayCopy at: i put: el. i _ i+1].
	arrayCopy _ arrayCopy copyWithout: nil.
	list _ ListParagraph withArray: arrayCopy style: self assuredTextStyle.
	selection _ 0.
	self positionList.
! !

!ListView methodsFor: 'list access'!
reset
	"Set the list of items displayed to be empty."

	isEmpty _ true.
	self list: Array new! !

!ListView methodsFor: 'list access'!
resetAndDisplayView
	"Set the list of items displayed to be empty and redisplay the receiver."

	isEmpty
		ifFalse: 
			[self reset.
			self displayView]! !

!ListView methodsFor: 'list access'!
selection: selIndex
	selection _ selIndex! !


!ListView methodsFor: 'delimiters'!
bottomDelimiter
	"Answer the string used to indicate the bottom of the list."

	^bottomDelimiter! !

!ListView methodsFor: 'delimiters'!
bottomDelimiter: aString 
	"Set the string used to indicate the bottom of the list."

	bottomDelimiter _ aString! !

!ListView methodsFor: 'delimiters'!
noBottomDelimiter
	"Set the string used to indicate the bottom of the list to be nothing."

	bottomDelimiter _ nil! !

!ListView methodsFor: 'delimiters'!
noTopDelimiter
	"Set the string used to indicate the top of the list to be nothing."

	topDelimiter _ nil! !

!ListView methodsFor: 'delimiters'!
topDelimiter
	"Answer the string used to indicate the top of the list."

	^topDelimiter! !

!ListView methodsFor: 'delimiters'!
topDelimiter: aString 
	"Set the string used to indicate the top of the list."

	topDelimiter _ aString! !


!ListView methodsFor: 'displaying'!
deEmphasizeSelectionBox
	self displaySelectionBox! !

!ListView methodsFor: 'displaying'!
display 
	"Refer to the comment in View.display."
	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[selection isNil ifTrue: [selection _ 0].
			self positionList].
	super display! !

!ListView methodsFor: 'displaying'!
displaySelectionBox
	"If the receiver has a selection and that selection is visible on the display 
	screen, then highlight it."
	selection ~= 0 ifTrue:
		[Display reverse: (self selectionBox intersect: self clippingBox)]! !

!ListView methodsFor: 'displaying'!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	list foregroundColor: self foregroundColor
		backgroundColor: self backgroundColor.
	list displayOn: Display! !

!ListView methodsFor: 'displaying'!
scrollBy: anInteger 
	"Scroll up by this amount adjusted by lineSpacing and list limits"
	| maximumAmount minimumAmount amount wasClipped |
	maximumAmount _ 0 max:
		list clippingRectangle top - list compositionRectangle top.
	minimumAmount _ 0 min:
		list clippingRectangle bottom - list compositionRectangle bottom.
	amount _ (anInteger min: maximumAmount) max: minimumAmount.
	amount ~= 0
		ifTrue: [list scrollBy: amount negated.  ^ true]
		ifFalse: [^ false]  "Return false if no scrolling took place"! !

!ListView methodsFor: 'displaying'!
scrollSelectionIntoView
	"Selection is assumed to be on and clipped out of view.
	Uses controller scrollView to keep selection right"
	| delta |
	(delta _ self insetDisplayBox bottom - self selectionBox bottom) < 0
		ifTrue: [^ self controller scrollView: delta - (list lineGrid-1)]. "up"
	(delta _ self insetDisplayBox top - self selectionBox top) > 0
		ifTrue: [^ self controller scrollView: delta + 1] "down"! !


!ListView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	^ self deEmphasizeSelectionBox! !

!ListView methodsFor: 'deEmphasizing'!
emphasizeView 
	"List emphasis is its own inverse."
	^ self deEmphasizeView! !


!ListView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ListController! !


!ListView methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in View|boundingBox."

	^list boundingBox! !

!ListView methodsFor: 'display box access' stamp: 'mkd 11/4/1999 14:31'!
isSelectionBoxClipped
        "Answer whether there is a selection and whether the selection is visible 
        on the screen."

        ^ selection ~= 0 and:
			[(self selectionBox intersects: 
                       (self clippingBox insetBy: (Rectangle left: 0 right: 0 top: 1 bottom: 0))) not]! !


!ListView methodsFor: 'clipping box access'!
clippingBox
	"Answer the rectangle in which the model can be displayed--this is the 
	insetDisplayBox inset by the height of a line for an item."

	^self insetDisplayBox insetBy: 
		(Rectangle
			left: 0
			right: 0
			top: 0
			bottom: self insetDisplayBox height \\ list lineGrid)! !


!ListView methodsFor: 'selecting'!
deselect
	"If the receiver has a selection, then it is highlighted. Remove the 
	highlighting."

	selection ~= 0 ifTrue: [Display reverse: (self selectionBox intersect: self clippingBox)]! !

!ListView methodsFor: 'selecting'!
findSelection: aPoint 
	"Determine which selection is displayed in an area containing the point, 
	aPoint. Answer the selection if one contains the point, answer nil 
	otherwise."

	| trialSelection |
	(self clippingBox containsPoint: aPoint) ifFalse: [^nil].
	trialSelection _ aPoint y - list compositionRectangle top // list lineGrid + 1.
	topDelimiter == nil ifFalse: [trialSelection _ trialSelection - 1].
	(trialSelection < 1) | (trialSelection > self maximumSelection)
		ifTrue: [^ nil]
		ifFalse: [^ trialSelection]! !

!ListView methodsFor: 'selecting'!
maximumSelection
	"Answer which selection is the last possible one."
	^ list numberOfLines
		- (topDelimiter == nil ifTrue: [0] ifFalse: [1])
		- (bottomDelimiter == nil ifTrue: [0] ifFalse: [1])! !

!ListView methodsFor: 'selecting'!
minimumSelection
	"Answer which selection is the first possible one."
	^ 1! !

!ListView methodsFor: 'selecting'!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."

	selection ~= anInteger
		ifTrue: 
			[self deselect.
			selection _ anInteger.
			self displaySelectionBox].
	self isSelectionBoxClipped
		ifTrue: [self scrollSelectionIntoView]! !

!ListView methodsFor: 'selecting' stamp: 'di 5/22/1998 00:25'!
numSelectionsInView
	^ self clippingBox height // self list lineGrid! !

!ListView methodsFor: 'selecting'!
selection
	"Answer the receiver's current selection."

	^selection! !

!ListView methodsFor: 'selecting'!
selectionBox
	"Answer the rectangle in which the current selection is displayed."

	^(self insetDisplayBox left @ (list compositionRectangle top + self selectionBoxOffset) 
		extent: self insetDisplayBox width @ list lineGrid)
		insetBy: (Rectangle left: 1 right: 1 top: 1 bottom: 0)! !

!ListView methodsFor: 'selecting'!
selectionBoxOffset
	"Answer an integer that determines the y position for the display box of 
	the current selection."

	^ (selection - 1 + (topDelimiter == nil ifTrue: [0] ifFalse: [1]))
		* list lineGrid! !


!ListView methodsFor: 'updating'!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == #list
		ifTrue: 
			[self list: model list.
			self displayView.
			^self].
	aSymbol == #listIndex
		ifTrue: 
			[self moveSelectionBox: model listIndex.
			^self]! !


!ListView methodsFor: 'private'!
firstShown
	"Return the index of the top item currently visible"
	| trial |
	trial _ self findSelection: self insetDisplayBox topLeft.
	^ trial == nil
		ifTrue: [1]
		ifFalse: [trial]! !

!ListView methodsFor: 'private'!
lastShown
	"Return the index of the bottom item currently visible"
	| trial bottomMargin |
	bottomMargin _ self insetDisplayBox height \\ list lineGrid.
	trial _ self findSelection: self insetDisplayBox bottomLeft - (0@bottomMargin).
	trial == nil
		ifTrue: [trial _ self findSelection: self insetDisplayBox bottomLeft
					- (0@(list lineGrid+bottomMargin))].
	^ trial == nil
		ifTrue: [list numberOfLines - 2]
		ifFalse: [trial]! !

!ListView methodsFor: 'private'!
positionList

	list wrappingBox: self wrappingBox clippingBox: self clippingBox ! !

!ListView methodsFor: 'private'!
wrappingBox

	| aRectangle |
	aRectangle _ self insetDisplayBox. 
	selection = 0
		ifTrue: [^aRectangle topLeft + (4 @ 0) extent: list compositionRectangle extent]
		ifFalse: [^aRectangle left + 4 @ 
					(aRectangle top - 
						(self selectionBoxOffset 
							min: ((list height - aRectangle height 
									+ list lineGrid truncateTo: list lineGrid)
							max: 0))) 
					extent: list compositionRectangle extent]! !


!ListView methodsFor: 'lock access'!
lock
	"Refer to the comment in view|lock.  Must do at least what display would do to lock the view."

	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[self positionList].
	super lock! !
ObjectRepresentativeMorph subclass: #ListViewLine
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ListViewLine methodsFor: 'list view line' stamp: 'sw 10/23/2000 18:27'!
listViewLineForFieldList: aFieldList
	"Answer a list view line containing data representing the items in aFieldList"

	^ objectRepresented == self
		ifFalse:
			[objectRepresented listViewLineForFieldList: aFieldList]
		ifTrue:
			[super listViewLineForFieldList: aFieldList]! !


!ListViewLine methodsFor: 'object represented' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject
	"Set the object represented by the receiver to be as requested"

	objectRepresented _ anObject.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self setNameTo: anObject name.
	self removeAllMorphs.
! !
Dictionary subclass: #LiteralDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!LiteralDictionary commentStamp: '<historical>' prior: 0!
A LiteralDictionary, like an IdentityDictionary, has a special test for equality.  In this case it is simple equality between objects of like class.  This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0!


!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'yo 1/27/2001 05:06'!
arrayEquality: x and: y

	x size = y size ifFalse: [^ false].
	x with: y do: [:e1 :e2 | 
		(self literalEquality: e1 and: e2) ifFalse: [^ false]
	].
	^true.
! !

!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'yo 1/27/2001 05:13'!
literalEquality: x and: y

	^ (x class = Array and: [y class = Array]) ifTrue: [
		self arrayEquality: x and: y.
	] ifFalse: [
		(x class == y class) and: [x = y]
	].
! !

!LiteralDictionary methodsFor: 'as yet unclassified' stamp: 'yo 1/27/2001 05:10'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil
					or: [self literalEquality: element key and: anObject])
					ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil
					or: [self literalEquality: element key and: anObject])
					ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
LeafNode subclass: #LiteralNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!LiteralNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a literal string or number.!


!LiteralNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	code < 256
		ifTrue: [strm nextPut: code]
		ifFalse: [self emitLong: LoadLong on: strm].
	stack push: 1! !


!LiteralNode methodsFor: 'testing'!
isConstantNumber
	^ key isNumber! !

!LiteralNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:13'!
isLiteral

	^ true! !

!LiteralNode methodsFor: 'testing'!
isSpecialConstant
	^ code between: LdTrue and: LdMinus1+3! !

!LiteralNode methodsFor: 'testing'!
literalValue

	^key! !


!LiteralNode methodsFor: 'printing' stamp: 'di 4/5/2000 15:10'!
printOn: aStream indent: level

	(key isMemberOf: Association)
		ifTrue:
			[key key isNil
				ifTrue:
					[aStream nextPutAll: '###';
					 	nextPutAll: key value soleInstance name]
				ifFalse:
					[aStream nextPutAll: '##';
						nextPutAll: key key]]
		ifFalse:
			[aStream withStyleFor: #literal
					do: [key storeOn: aStream]]! !


!LiteralNode methodsFor: 'C translation'!
asTranslatorNode 
	^TConstantNode new setValue: key! !


!LiteralNode methodsFor: 'evaluation' stamp: 'tk 8/4/1999 17:35'!
eval
	"When everything in me is a constant, I can produce a value.  This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"

	^ key! !


!LiteralNode methodsFor: 'tiles' stamp: 'tk 11/29/2000 13:32'!
asMorphicSyntaxIn: parent

	| row |

	row _ parent addColumn: #literal on: self.
	(key isMemberOf: Association) ifFalse: [
		row layoutInset: 1.
		^ row addMorphBack: (row addString: key storeString)].
	key key isNil ifTrue: [
		^ row addTextRow: ('###',key value soleInstance name)
	] ifFalse: [
		^ row addTextRow: ('##', key key)
	].	! !

!LiteralNode methodsFor: 'tiles' stamp: 'RAA 8/15/1999 18:45'!
explanation

	(key isMemberOf: Association) ifFalse: [
		^'Literal ', key storeString
	].
	key key isNil ifTrue: [
		^'Literal ', ('###',key value soleInstance name) 
	] ifFalse: [
		^'Literal ', ('##', key key) 
	].	! !
Magnitude subclass: #LookupKey
	instanceVariableNames: 'key '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!LookupKey commentStamp: '<historical>' prior: 0!
I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.!


!LookupKey methodsFor: 'accessing'!
key
	"Answer the lookup key of the receiver."

	^key! !

!LookupKey methodsFor: 'accessing'!
key: anObject 
	"Store the argument, anObject, as the lookup key of the receiver."

	key _ anObject! !


!LookupKey methodsFor: 'comparing'!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^key < aLookupKey key! !

!LookupKey methodsFor: 'comparing'!
= aLookupKey

	self species = aLookupKey species
		ifTrue: [^key = aLookupKey key]
		ifFalse: [^false]! !

!LookupKey methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^key hash! !

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

	^key hashMappedBy: map! !

!LookupKey methodsFor: 'comparing' stamp: 'di 9/27/97 20:45'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^ key identityHashMappedBy: map! !


!LookupKey methodsFor: 'printing'!
printOn: aStream

	key printOn: aStream! !


!LookupKey methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 02:35'!
writeOnFilterStream: aStream

	aStream write:key.! !

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

LookupKey class
	instanceVariableNames: ''!

!LookupKey class methodsFor: 'instance creation'!
key: aKey 
	"Answer an instance of me with the argument as the lookup up."

	^self new key: aKey! !
Object subclass: #LoopbackStringSocket
	instanceVariableNames: 'associate inArrays outArrays '
	classVariableNames: 'WRITESTRINGSIZES '
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!LoopbackStringSocket commentStamp: '<historical>' prior: 0!
a string socket which is connected to another string sockt on the local computer.  Used mostly for testing.!


!LoopbackStringSocket methodsFor: 'initialization' stamp: 'ls 3/18/2000 13:28'!
associate: aLoopbackStringSocket
	associate := aLoopbackStringSocket.
	inArrays := OrderedCollection new.
	outArrays := OrderedCollection new.! !


!LoopbackStringSocket methodsFor: 'I/O' stamp: 'ls 3/21/2000 23:40'!
flush! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'ls 3/18/2000 13:27'!
isConnected
	^true! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'RAA 7/22/2000 07:47'!
nextOrNil

	inArrays ifNil: [^nil].

	inArrays isEmpty 
		ifTrue: [ ^nil ]
		ifFalse: [
			^inArrays removeFirst. ]	! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'RAA 7/22/2000 08:55'!
nextPut: aStringArray

	inArrays ifNil: [^self].

	outArrays add: aStringArray.
	"WRITESTRINGSIZES ifNil: [WRITESTRINGSIZES _ Bag new].
	aStringArray do: [ :each | WRITESTRINGSIZES add: each size]."! !

!LoopbackStringSocket methodsFor: 'I/O' stamp: 'RAA 7/22/2000 07:48'!
processIO

	inArrays ifNil: [^self].

	associate arraysFromAssociate: outArrays.
	outArrays := OrderedCollection new.! !


!LoopbackStringSocket methodsFor: 'private' stamp: 'RAA 7/22/2000 07:47'!
arraysFromAssociate: arrays
	"new string-arrays have arrived from our associate"

	inArrays ifNil: [^self].
	inArrays addAll: arrays.! !


!LoopbackStringSocket methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 07:44'!
destroy

	associate _ inArrays _ outArrays _ nil.! !

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

LoopbackStringSocket class
	instanceVariableNames: ''!

!LoopbackStringSocket class methodsFor: 'instance creation' stamp: 'ls 3/18/2000 13:24'!
newPair
	"create a connected pair of sockets"
	| a b |
	a := self new.
	b := self new.
	a associate: b.
	b associate: a.
	^{a. b}! !


!LoopbackStringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 08:14'!
clearStats

	WRITESTRINGSIZES _ nil! !

!LoopbackStringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 08:15'!
stats

	^WRITESTRINGSIZES! !
AbstractSound subclass: #LoopedSampledSound
	instanceVariableNames: 'initialCount count releaseCount sampleCountForRelease leftSamples rightSamples originalSamplingRate perceivedPitch gain firstSample lastSample loopEnd scaledLoopLength scaledIndex scaledIndexIncr '
	classVariableNames: 'FloatLoopIndexScaleFactor LoopIndexFractionMask LoopIndexScaleFactor '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!LoopedSampledSound commentStamp: '<historical>' prior: 0!
I respresent a sequence of sound samples, often used to record a single note played by a real instrument. I can be pitch-shifted up or down, and can include a looped portion to allow a sound to be sustained indefinitely.
!


!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 10/14/1998 16:04'!
addReleaseEnvelope
	"Add a simple release envelope to this sound."

	| p env |
	p _ OrderedCollection new.
	p add: 0@1.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	env _ (VolumeEnvelope points: p loopStart: 2 loopEnd: 3) target: self.
	envelopes size > 0 ifTrue: [  "remove any existing volume envelopes"
		envelopes copy do: [:e |
			(e isKindOf: VolumeEnvelope) ifTrue: [self removeEnvelope: e]]].
	self addEnvelope: env.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 11:48'!
computeSampleCountForRelease
	"Calculate the number of samples before the end of the note after which looping back will be be disabled. The units of this value, sampleCountForRelease, are samples at the original sampling rate. When playing a specific note, this value is converted to releaseCount, which is number of samples to be computed at the current pitch and sampling rate."
	"Details: For short loops, set the sampleCountForRelease to the loop length plus the number of samples between loopEnd and lastSample. Otherwise, set it to 1/10th of a second worth of samples plus the number of samples between loopEnd and lastSample. In this case, the trailing samples will be played only if the last loop-back occurs within 1/10th of a second of the total note duration, and the note may be shortened by up to 1/10th second. For long loops, this is the best we can do."

	(scaledLoopLength > 0 and: [lastSample > loopEnd])
		ifTrue: [
			sampleCountForRelease _ (lastSample - loopEnd) +
				(self loopLength min: (originalSamplingRate / 10.0)) asInteger]
		ifFalse: [sampleCountForRelease _ 0].

	releaseCount _ sampleCountForRelease.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 5/5/1999 20:59'!
fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	| aiffFileReader |
	aiffFileReader _ AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: mergeFlag
		skipDataChunk: false.
	aiffFileReader isLooped
		ifTrue: [
			self samples: aiffFileReader leftSamples
				loopEnd: aiffFileReader loopEnd
				loopLength: aiffFileReader loopLength
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate]
		ifFalse: [
			self unloopedSamples: aiffFileReader leftSamples
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate].

	"the following must be done second, since the initialization above sets
	 leftSamples and rightSamples to the same sample data"
	aiffFileReader isStereo
		ifTrue: [rightSamples _ aiffFileReader rightSamples].

	initialCount _ (leftSamples size * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.

	self addReleaseEnvelope.
! !

!LoopedSampledSound methodsFor: 'initialization'!
fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	aiffFileReader isLooped
		ifTrue: [
			self samples: aiffFileReader leftSamples
				loopEnd: aiffFileReader loopEnd
				loopLength: aiffFileReader loopLength
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate]
		ifFalse: [
			self unloopedSamples: aiffFileReader leftSamples
				pitch: aiffFileReader pitch
				samplingRate: aiffFileReader samplingRate].

	"the following must be done second, since the initialization above sets
	 leftSamples and rightSamples to the same sample data"
	aiffFileReader isStereo
		ifTrue: [rightSamples _ aiffFileReader rightSamples].

	initialCount _ (leftSamples size * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.

	self addReleaseEnvelope.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 07:43'!
initialize
	"This default initialization creates a loop consisting of a single cycle of a sine wave."
	"(LoopedSampledSound pitch: 440.0 dur: 1.0 loudness: 0.4) play"

	| samples |
	super initialize.
	samples _ FMSound sineTable.
	self samples: samples
		loopEnd: samples size
		loopLength: samples size
		pitch: 1.0
		samplingRate: samples size.
	self addReleaseEnvelope.
	self setPitch: 440.0 dur: 1.0 loudness: 0.5.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'!
samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"Make this sound use the given samples array with a loop of the given length starting at the given index. The loop length may have a fractional part; this is necessary to achieve pitch accuracy for short loops."

	| loopStartIndex |
	super initialize.
	loopStartIndex _ (loopEndIndex - loopSampleCount) truncated + 1.
	((1 <= loopStartIndex) and:
	 [loopStartIndex < loopEndIndex and:
	 [loopEndIndex <= aSoundBuffer size]])
		ifFalse: [self error: 'bad loop parameters'].

	leftSamples _ rightSamples _ aSoundBuffer.
	originalSamplingRate _ samplingRateInHz asFloat.
	perceivedPitch _ perceivedPitchInHz asFloat.
	gain _ 1.0.
	firstSample _ 1.
	lastSample _ leftSamples size.
	lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
		self error: 'cannot handle more than ',
			(SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
	loopEnd _ loopEndIndex.
	scaledLoopLength _ (loopSampleCount * LoopIndexScaleFactor) asInteger.
	scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
	self computeSampleCountForRelease.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"(LoopedSampledSound pitch: 440.0 dur: 2.5 loudness: 0.4) play"

	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
	self reset.
! !

!LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'!
unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"Make this sound play the given samples unlooped. The samples have the given perceived pitch when played at the given sampling rate. By convention, unpitched sounds such as percussion sounds should specify a pitch of nil or 100 Hz."

	super initialize.
	leftSamples _ rightSamples _ aSoundBuffer.
	originalSamplingRate _ samplingRateInHz asFloat.
	perceivedPitchInHz
		ifNil: [perceivedPitch _ 100.0]
		ifNotNil: [perceivedPitch _ perceivedPitchInHz asFloat].
	gain _ 1.0.
	firstSample _ 1.
	lastSample _ leftSamples size.
	lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
		self error: 'cannot handle more than ',
			(SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
	loopEnd _ leftSamples size.
	scaledLoopLength _ 0.  "zero length means unlooped"
	scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
	self computeSampleCountForRelease.
! !


!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 5/31/1999 14:09'!
beUnlooped

	scaledLoopLength _ 0.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate asFloat
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:36'!
duration: seconds

	super duration: seconds.
	count _ initialCount _ (seconds * self samplingRate) rounded.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'!
firstSample

	^ firstSample
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'!
firstSample: aNumber

	firstSample _ (aNumber asInteger max: 1) min: lastSample.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'!
gain

	^ gain
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'!
gain: aNumber

	gain _ aNumber asFloat.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'!
isLooped

	^ scaledLoopLength ~= 0.  "zero loop length means unlooped"
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:14'!
isStereo

	^ leftSamples ~~ rightSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
leftSamples

	^ leftSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
leftSamples: aSampleBuffer

	leftSamples _ aSampleBuffer.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:35'!
loopEnd

	^ loopEnd
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:12'!
loopLength

	^ scaledLoopLength / FloatLoopIndexScaleFactor
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 10/14/1998 16:26'!
originalSamplingRate

	^ originalSamplingRate
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:54'!
perceivedPitch

	^ perceivedPitch
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:08'!
pitch

	^ (scaledIndexIncr asFloat * perceivedPitch * self samplingRate asFloat) /
	  (originalSamplingRate * FloatLoopIndexScaleFactor)
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 11:38'!
pitch: p

	scaledIndexIncr _
		((p asFloat * originalSamplingRate * FloatLoopIndexScaleFactor) /
		 (perceivedPitch * self samplingRate asFloat)) asInteger.

	sampleCountForRelease > 0
		ifTrue: [releaseCount _ (sampleCountForRelease * LoopIndexScaleFactor) // scaledIndexIncr]
		ifFalse: [releaseCount _ 0].
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
rightSamples

	^ rightSamples
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'!
rightSamples: aSampleBuffer

	rightSamples _ aSampleBuffer.
! !

!LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 3/15/1999 08:01'!
samples
	"For compatability with SampledSound. Just return my left channel (which is the only channel if I am mono)."

	^ leftSamples
! !


!LoopedSampledSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:23'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy.  If a loop length is specified, then the index is looped back when the loopEnd index is reached until count drops below releaseCount. This allows a short sampled sound to be sustained indefinitely."
	"(LoopedSampledSound pitch: 440.0 dur: 5.0 loudness: 0.5) play"

	| lastIndex sampleIndex i s compositeLeftVol compositeRightVol nextSampleIndex m isInStereo rightVal leftVal |
	<primitive:'primitiveMixLoopedSampledSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #leftSamples declareC: 'short int *leftSamples'.
	self var: #rightSamples declareC: 'short int *rightSamples'.

	isInStereo _ leftSamples ~~ rightSamples.
	compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor.
	compositeRightVol _  (rightVol * scaledVol) // ScaleFactor.

	i _ (2 * startIndex) - 1.
	lastIndex _ (startIndex + n) - 1.
	startIndex to: lastIndex do: [:sliceIndex |
		sampleIndex _ (scaledIndex _ scaledIndex + scaledIndexIncr) // LoopIndexScaleFactor.
		((sampleIndex > loopEnd) and: [count > releaseCount]) ifTrue: [
			"loop back if not within releaseCount of the note end"
			"note: unlooped sounds will have loopEnd = lastSample"
			sampleIndex _ (scaledIndex _ scaledIndex - scaledLoopLength) // LoopIndexScaleFactor].
		(nextSampleIndex _ sampleIndex + 1) > lastSample ifTrue: [
			sampleIndex > lastSample ifTrue: [count _ 0. ^ nil].  "done!!"
			scaledLoopLength = 0
				ifTrue: [nextSampleIndex _ sampleIndex]
				ifFalse: [nextSampleIndex _ ((scaledIndex - scaledLoopLength) // LoopIndexScaleFactor) + 1]].

		m _ scaledIndex bitAnd: LoopIndexFractionMask.
		rightVal _ leftVal _
			(((leftSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
			 ((leftSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor.
		isInStereo ifTrue: [
			rightVal _
				(((rightSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
				 ((rightSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor].

		leftVol > 0 ifTrue: [
			s _ (aSoundBuffer at: i) + ((compositeLeftVol * leftVal) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		i _ i + 1.
		rightVol > 0 ifTrue: [
			s _ (aSoundBuffer at: i) + ((compositeRightVol * rightVal) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].
		i _ i + 1.

		scaledVolIncr ~= 0 ifTrue: [  "update volume envelope if it is changing"
			scaledVol _ scaledVol + scaledVolIncr.
			((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
			 [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
				ifTrue: [  "reached the limit; stop incrementing"
					scaledVol _ scaledVolLimit.
					scaledVolIncr _ 0].
			compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor.
			compositeRightVol _  (rightVol * scaledVol) // ScaleFactor]].

	count _ count - n.
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 09:38'!
reset

	super reset.
	count _ initialCount.
	scaledIndex _ firstSample * LoopIndexScaleFactor.
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/18/1998 09:31'!
samplesRemaining
	"Answer the number of samples remaining until the end of this sound."

	^ count
! !

!LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:57'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count _ (mSecs * self samplingRate) // 1000.
! !


!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 08:19'!
copyDownSampledLowPassFiltering: doFiltering
	"Answer a copy of the receiver at half its sampling rate. The result consumes half the memory space, but has only half the frequency range of the original. If doFiltering is true, the original sound buffers are low-pass filtered before down-sampling. This is slower, but prevents aliasing of any high-frequency components of the original signal. (While it may be possible to avoid low-pass filtering when down-sampling from 44.1 kHz to 22.05 kHz, it is probably essential when going to lower sampling rates.)"

	^ self copy downSampleLowPassFiltering: doFiltering
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:30'!
edit
	"Open a WaveEditor on this sound."

	| loopLen ed |
	loopLen _ scaledLoopLength asFloat / LoopIndexScaleFactor.
	ed _ WaveEditor new
		data: leftSamples;
		samplingRate: originalSamplingRate;
		loopEnd: loopEnd;
		loopLength: loopLen;
		loopCycles: (loopLen / (originalSamplingRate asFloat / perceivedPitch)) rounded.
	ed openInWorld.
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 07:49'!
fftAt: startIndex
	"Answer the Fast Fourier Transform (FFT) of my samples (only the left channel, if stereo) starting at the given index."

	| availableSamples fftWinSize |
	availableSamples _ (leftSamples size - startIndex) + 1.
	fftWinSize _ 2 raisedTo: (((availableSamples - 1) log: 2) truncated + 1).
	fftWinSize _ fftWinSize min: 4096.
	fftWinSize > availableSamples ifTrue: [fftWinSize _ fftWinSize / 2].
	^ self fftWindowSize: fftWinSize startingAt: startIndex
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 5/29/1999 18:56'!
findStartPointAfter: index
	"Answer the index of the last zero crossing sample before the given index."

	| i |
	i _ index min: lastSample.

	"scan backwards to the last zero-crossing"
	(leftSamples at: i) > 0
		ifTrue: [
			[i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]]
		ifFalse: [
			[i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]].
	^ i
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:29'!
findStartPointForThreshold: threshold
	"Answer the index of the last zero crossing sample before the first sample whose absolute value (in either the right or left channel) exceeds the given threshold."

	| i |
	i _ self indexOfFirstPointOverThreshold: threshold.
	i >= lastSample ifTrue: [^ self error: 'no sample exceeds the given threshold'].

	"scan backwards to the last zero-crossing"
	(leftSamples at: i) > 0
		ifTrue: [
			[i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]]
		ifFalse: [
			[i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]].
	^ i
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:26'!
highestSignificantFrequencyAt: startIndex
	"Answer the highest significant frequency in the sample window starting at the given index. The a frequency is considered significant if it's power is at least 1/50th that of the maximum frequency component in the frequency spectrum."

	| fft powerArray threshold indices |
	fft _ self fftAt: startIndex.
	powerArray _ self normalizedResultsFromFFT: fft.
	threshold _ powerArray max / 50.0.
	indices _ (1 to: powerArray size) select: [:i | (powerArray at: i) > threshold].
	^ originalSamplingRate / (fft samplesPerCycleForIndex: indices last)
! !

!LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/17/1998 09:22'!
indexOfFirstPointOverThreshold: threshold
	"Answer the index of the first sample whose absolute value exceeds the given threshold."

	| s |
	leftSamples == rightSamples
		ifTrue: [
			1 to: lastSample do: [:i |
				s _ leftSamples at: i.
				s < 0 ifTrue: [s _ 0 - s].
				s > threshold ifTrue: [^ i]]]
		ifFalse: [
			1 to: lastSample do: [:i |
				s _ leftSamples at: i.
				s < 0 ifTrue: [s _ 0 - s].
				s > threshold ifTrue: [^ i].
				s _ rightSamples at: i.
				s < 0 ifTrue: [s _ 0 - s].
				s > threshold ifTrue: [^ i]]].
	^ lastSample + 1
! !


!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'tk 4/8/1999 12:45'!
comeFullyUpOnReload: smartRefStream
	"Convert my sample buffers from ByteArrays into SampleBuffers after raw loading from a DataStream. Answer myself."

	leftSamples == rightSamples
		ifTrue: [
			leftSamples _ SoundBuffer fromByteArray: self leftSamples.
			rightSamples _ leftSamples]
		ifFalse: [
			leftSamples _ SoundBuffer fromByteArray: self leftSamples.
			rightSamples _ SoundBuffer fromByteArray: self rightSamples].

! !

!LoopedSampledSound methodsFor: 'disk i/o' stamp: 'tk 9/25/2000 12:06'!
objectForDataStream: refStrm
    "Answer an object to store on a data stream, a copy of myself whose SampleBuffers have been converted into ByteArrays."

	refStrm replace: leftSamples with: leftSamples asByteArray.
	refStrm replace: rightSamples with: rightSamples asByteArray.
	"substitution will be made in DataStream nextPut:"
	^ self
! !


!LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/18/1998 08:11'!
downSampleLowPassFiltering: doFiltering
	"Cut my sampling rate in half. Use low-pass filtering (slower) if doFiltering is true."
	"Note: This operation loses information, and modifies the receiver in place."

	| stereo newLoopLength |
	stereo _ self isStereo.
	leftSamples _ leftSamples downSampledLowPassFiltering: doFiltering.
	stereo
		ifTrue: [rightSamples _ rightSamples downSampledLowPassFiltering: doFiltering]
		ifFalse: [rightSamples _ leftSamples].
	originalSamplingRate _ originalSamplingRate / 2.0.
	loopEnd odd
		ifTrue: [newLoopLength _ (self loopLength / 2.0) + 0.5]
		ifFalse: [newLoopLength _ self loopLength / 2.0].
	firstSample _ (firstSample + 1) // 2.
	lastSample _ (lastSample + 1) // 2.
	loopEnd _ (loopEnd + 1) // 2.
	scaledLoopLength _ (newLoopLength * LoopIndexScaleFactor) asInteger.
	scaledIndexIncr _ scaledIndexIncr // 2.
! !

!LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/18/1998 07:48'!
fftWindowSize: windowSize startingAt: startIndex
	"Answer a Fast Fourier Transform (FFT) of the given number of samples starting at the given index (the left channel only, if stereo). The window size will be rounded up to the nearest power of two greater than the requested size. There must be enough samples past the given starting index to accomodate this window size."

	| nu n fft |
	nu _ ((windowSize - 1) log: 2) truncated + 1.
	n _ 2 raisedTo: nu.
	fft _ FFT new nu: nu.
	fft realData: ((startIndex to: startIndex + n - 1) collect: [:i | leftSamples at: i]).
	^ fft transformForward: true.
! !

!LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/16/1998 17:48'!
normalizedResultsFromFFT: fft
	"Answer an array whose size is half of the FFT window size containing power in each frequency band, normalized to the average power over the entire FFT. A value of 10.0 in this array thus means that the power at the corresponding frequences is ten times the average power across the entire FFT."

	| r avg |
	r _ (1 to: fft realData size // 2) collect:
		[:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt].
	avg _ r sum / r size.
	^ r collect: [:v | v / avg].
! !

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

LoopedSampledSound class
	instanceVariableNames: ''!

!LoopedSampledSound class methodsFor: 'class initialization' stamp: 'jm 8/13/1998 12:54'!
initialize
	"LoopedSampledSound initialize"

	LoopIndexScaleFactor _ 512.
	FloatLoopIndexScaleFactor _ LoopIndexScaleFactor asFloat.
	LoopIndexFractionMask _ LoopIndexScaleFactor - 1.
! !


!LoopedSampledSound class methodsFor: 'instance creation'!
fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	| aiffFileReader |
	aiffFileReader _ AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: mergeFlag
		skipDataChunk: false.
	self new fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag! !

!LoopedSampledSound class methodsFor: 'instance creation'!
fromAIFFStream: fileStream
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	^self fromAIFFStream: fileStream mergeIfStereo: true! !

!LoopedSampledSound class methodsFor: 'instance creation'!
fromAIFFStream: fileStream mergeIfStereo: mergeFlag
	"Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."

	| aiffFileReader |
	aiffFileReader _ AIFFFileReader new.
	aiffFileReader readFrom: fileStream
		mergeIfStereo: mergeFlag
		skipDataChunk: false.
	^self new fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag! !

!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:40'!
samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"See the comment in the instance method of this name."

	^ self basicNew
		samples: aSoundBuffer
		loopEnd: loopEndIndex
		loopLength: loopSampleCount
		pitch: perceivedPitchInHz
		samplingRate: samplingRateInHz
! !

!LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:41'!
unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
	"See the comment in the instance method of this name."

	^ self basicNew
		unloopedSamples: aSoundBuffer
		pitch: perceivedPitchInHz
		samplingRate: samplingRateInHz
! !
MailInboxFile subclass: #MHMailInboxFile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MHMailInboxFile commentStamp: '<historical>' prior: 0!
I am a parser for mail files in the format output by the Unix 'mh' program.
!


!MHMailInboxFile methodsFor: 'scanning'!
mailMessagesDo: aBlock
	"Invoke the given block for each message in the mail inbox. The block argument is the text of a new message."

	| fileStream stream textStart textSize msgText |
	fileStream _ FileStream fileNamed: filename.
	Smalltalk garbageCollect.
	(fileStream size < (Smalltalk bytesLeft - 200000))
		ifTrue:
			["if possible, buffer the entire file in memory for speed"
			 stream _ ReadStream on: (fileStream contentsOfEntireFile).
			 fileStream _ nil]
		ifFalse:
			["otherwise, use the actual file stream, reading from disk"
			 stream _ fileStream].
	[self scanToNextMessageIn: stream] whileTrue:
		["skip the three-line message delimiter"
		 3 timesRepeat: [MailDB skipRestOfLine: stream].
		 textStart _ stream position.
		 self scanToNextMessageIn: stream.
		 textSize _ stream position - textStart.
		 stream position: textStart.
		 msgText _ stream next: textSize.
		 aBlock value: msgText].
	fileStream = nil ifFalse: [fileStream close].! !

!MHMailInboxFile methodsFor: 'scanning'!
scanToNextMessageIn: aStream
	"Scan to the start of the next message in the given stream. Answer true if we find a message delimiter, false if we hit the end of the stream first. The stream is left positioned at the start of the next message delimiter (if there is one) or at the end of the stream."

	| msgStart |
	[true] whileTrue:
		[(aStream skipTo: $:) ifFalse: [^false].	"end of stream"
		 msgStart _ aStream position - 1.
		 ((MailDB readStringLineFrom: aStream) = ':::::::::::::') ifTrue:
			["looking good..."
			 MailDB skipRestOfLine: aStream.	"skip message number"
			 ((MailDB readStringLineFrom: aStream) = '::::::::::::::') ifTrue:
				["found a message!!"
				 aStream position: msgStart. ^true]].
		 "false alarm, keep scanning"
		 aStream position: msgStart + 1].! !
AlignmentMorph subclass: #MIDIControllerMorph
	instanceVariableNames: 'channel controller midiPort lastValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!MIDIControllerMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:18'!
initialize

	| slider |
	super initialize.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self color: (Color r: 0.484 g: 0.613 b: 0.0).
	self borderWidth: 1.
	channel _ 0.
	controller _ 7.  "channel volume"

	slider _ SimpleSliderMorph new
		target: self;
		actionSelector: #newSliderValue:;
		minVal: 0;
		maxVal: 127;
		extent: 128@10.
	self addMorphBack: slider.
	self addMorphBack: (StringMorph contents: 'Midi Controller').
	self updateLabel.
! !


!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'!
channel

	^ channel
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'!
channel: anInteger

	channel _ anInteger.
	lastValue _ nil.
	self updateLabel.
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'!
controller

	^ controller
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'!
controller: anInteger

	controller _ anInteger.
	lastValue _ nil.
	self updateLabel.
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:54'!
midiPort

	^ midiPort
! !

!MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:55'!
midiPort: anInteger

	midiPort _ anInteger.
! !


!MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/28/1998 22:47'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'set channel' action: #setChannel:.
	aCustomMenu add: 'set controller' action: #setController:.
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:06'!
controllerList
	"Answer a list of controller name, number pairs to be used in the menu."

	^ #((1 modulation)
		(2 'breath control')
		(7 volume)
		(10 pan)
		(11 expression)
		(92 'tremolo depth')
		(93 'chorus depth')
		(94 'celeste depth')
		(95 'phaser depth'))
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:09'!
controllerName: controllerNumber
	"Answer a name for the given controller. If no name is available, use the form 'CC5' (CC is short for 'continuous controller')."

	self controllerList do: [:pair |
		pair first = controllerNumber ifTrue: [^ pair last]].
	^ 'CC', controllerNumber asString
! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:02'!
setChannel: evt
	| menu |
	menu _ MenuMorph new.
	1 to: 16 do: [:chan |
		menu add: chan printString
			target: self
			selector: #channel:
			argumentList: (Array with: chan - 1)].

	menu popUpEvent: evt in: self world! !

!MIDIControllerMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:02'!
setController: evt
	| menu |
	menu _ MenuMorph new.
	self controllerList do: [:pair |
		menu add: (pair last)
			target: self
			selector: #controller:
			argumentList: (Array with: pair first)].

	menu popUpEvent: evt in: self world! !


!MIDIControllerMorph methodsFor: 'other' stamp: 'jm 10/12/1998 16:02'!
newSliderValue: newValue
	"Send a control command out the MIDI port."

	| val |
	midiPort ifNil: [^ self].
	val _ newValue asInteger.
	lastValue = val ifTrue: [^ self].
	lastValue _ val.
	midiPort midiCmd: 16rB0 channel: channel byte: controller byte: val.
! !

!MIDIControllerMorph methodsFor: 'other' stamp: 'jm 9/29/1998 09:10'!
updateLabel

	| label |
	(label _ self findA: StringMorph) ifNil: [^ self].
	label contents: (self controllerName: controller), ', ch: ', (channel + 1) printString.
! !
Object subclass: #MIDIFileReader
	instanceVariableNames: 'stream fileType trackCount ticksPerQuarter tracks trackInfo tempoMap strings track trackStream activeEvents maxNoteTicks '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIFileReader commentStamp: '<historical>' prior: 0!
A reader for Standard 1.0 format MIDI files.
MIDI File Types:
	type 0 -- one multi-channel track
	type 1 -- one or more simultaneous tracks
	type 2 -- a number on independent single-track patterns

Instance variables:
	stream			source of MIDI data
	fileType			MIDI file type
	trackCount		number of tracks in file
	ticksPerQuarter	number of ticks per quarter note for all tracks in this file
	tracks			collects track data for non-empty tracks
	strings			collects all strings in the MIDI file
	tempoMap		nil or a MIDITrack consisting only of tempo change events
	trackStream		stream on buffer containing track chunk
	track			track being read
	activeEvents 	notes that have been turned on but not off
!


!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 1/6/98 23:20'!
asScore

	^ MIDIScore new
		tracks: tracks;
		trackInfo: trackInfo;
		tempoMap: tempoMap;
		ticksPerQuarterNote: ticksPerQuarter
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 9/27/1998 21:44'!
readHeaderChunk

	| chunkType chunkSize division |
	chunkType _ self readChunkType.
	chunkType = 'RIFF' ifTrue:[chunkType _ self riffSkipToMidiChunk].
	chunkType = 'MThd' ifFalse: [self scanForMIDIHeader].
	chunkSize _ self readChunkSize.
	fileType _ self next16BitWord.
	trackCount _ self next16BitWord.
	division _ self next16BitWord.
	(division anyMask: 16r8000)
		ifTrue: [self error: 'SMPTE time formats are not yet supported']
		ifFalse: [ticksPerQuarter _ division].
	maxNoteTicks _ 12 * 4 * ticksPerQuarter.
		"longest acceptable note; used to detect stuck notes"

	"sanity checks"
	((chunkSize < 6) or: [chunkSize > 100])
		ifTrue: [self error: 'unexpected MIDI header size ', chunkSize printString].
	(#(0 1 2) includes: fileType)
		ifFalse: [self error: 'unknown MIDI file type ', fileType printString].

	Transcript
		show: 'Reading Type ', fileType printString, ' MIDI File (';
		show: trackCount printString, ' tracks, ';
		show: ticksPerQuarter printString, ' ticks per quarter note)';
		cr.
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 9/12/1998 19:08'!
readMIDIFrom: aBinaryStream
	"Read one or more MIDI tracks from the given binary stream."

	stream _ aBinaryStream.
	tracks _ OrderedCollection new.
	trackInfo _ OrderedCollection new.
	self readHeaderChunk.
	trackCount timesRepeat: [self readTrackChunk].
	stream atEnd ifFalse: [self report: 'data beyond final track'].
	fileType = 0 ifTrue: [self splitIntoTracks].
	self guessMissingInstrumentNames.
! !

!MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 12/31/97 10:41'!
readTrackChunk

	| chunkType chunkSize |
	chunkType _ self readChunkType.
	[chunkType = 'MTrk'] whileFalse: [
		self report: 'skipping unexpected chunk type "', chunkType, '"'.
		stream skip: (self readChunkSize).  "skip it"
		chunkType _ (stream next: 4) asString].
	chunkSize _ self readChunkSize.
	chunkSize < 10000000 ifFalse: [
		self error: 'suspiciously large track chunk; this may not be MIDI file'].

	self readTrackContents: chunkSize.
! !


!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 3/28/98 05:44'!
endAllNotesAt: endTicks
	"End of score; end any notes still sounding."
	"Details: Some MIDI files have missing note-off events, resulting in very long notes. Truncate any such notes encountered."

	| dur |
	activeEvents do: [:e |
		dur _ endTicks - e time.
		dur > maxNoteTicks ifTrue: [dur _ ticksPerQuarter].  "truncate long note"
		e duration: dur].
	activeEvents _ activeEvents species new.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 12/31/97 11:36'!
endNote: midiKey chan: channel at: endTicks

	| evt |
	evt _ activeEvents
		detect: [:e | (e midiKey = midiKey) and: [e channel = channel]]
		ifNone: [^ self].
	evt duration: (endTicks - evt time).
	activeEvents remove: evt ifAbsent: [].
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 1/3/98 09:45'!
isTempoTrack: anEventList
	"Return true if the given event list is non-empty and contains only tempo change events."

	anEventList isEmpty ifTrue: [^ false].
	anEventList do: [:evt | evt isTempoEvent ifFalse: [^ false]].
	^ true
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/27/1998 22:15'!
metaEventAt: ticks
	"Read a meta event. Event types appear roughly in order of expected frequency."

	| type length tempo |
	type _ trackStream next.
	length _ self readVarLengthIntFrom: trackStream.

	type = 16r51 ifTrue: [  "tempo"
		tempo _ 0.
		length timesRepeat: [tempo _ (tempo bitShift: 8) + trackStream next].
		track add: (TempoEvent new tempo: tempo; time: ticks).
		^ self].

	type = 16r2F ifTrue: [  "end of track"
		length = 0 ifFalse: [self error: 'length of end-of-track chunk should be zero'].
		self endAllNotesAt: ticks.
		trackStream skip: length.
		^ self].

	type = 16r58 ifTrue: [  "time signature"
		length = 4 ifFalse: [self error: 'length of time signature chunk should be four'].
		trackStream skip: length.
		^ self].

	type = 16r59 ifTrue: [  "key signature"
		length = 2 ifFalse: [self error: 'length of key signature chunk should be two'].
		trackStream skip: length.
		^ self].

	((type >= 1) and: [type <= 7]) ifTrue: [  "string"
		strings add: (trackStream next: length) asString.
		^ self].

	(  type = 16r21 or:   "mystery; found in MIDI files but not in MIDI File 1.0 Spec"
	 [(type = 16r7F) or:  "sequencer specific meta event"
	 [(type = 16r00) or:  "sequence number"
	 [(type = 16r20)]]])  "MIDI channel prefix"
		ifTrue: [
			trackStream skip: length.
			^ self].

	type = 16r54 ifTrue: [
		"SMPTE offset"
		self report: 'Ignoring SMPTE offset'.
		trackStream skip: length.
		^ self].

	"skip unrecognized meta event"
	self report:
		'skipping unrecognized meta event: ', (type printStringBase: 16),
		' (', length printString, ' bytes)'.
	trackStream skip: length.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:10'!
readTrackContents: byteCount

	| info |
	strings _ OrderedCollection new.
	track _ OrderedCollection new.
	trackStream _ ReadStream on: (stream next: byteCount).
	activeEvents _ OrderedCollection new.
	self readTrackEvents.
	(tracks isEmpty and: [self isTempoTrack: track])
		ifTrue: [tempoMap _ track asArray]
		ifFalse: [
			"Note: Tracks without note events are currently not saved to
			 eliminate clutter in the score player. In control applications,
			 this can be easily changed by modifying the following test."
			(self trackContainsNotes: track) ifTrue: [
				tracks add: track asArray.
				info _ WriteStream on: (String new: 100).
				strings do: [:s | info nextPutAll: s; cr].
				trackInfo add: info contents]].
	strings _ track _ trackStream _ activeEvents _ nil.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/10/1998 09:57'!
readTrackEvents
	"Read the events of the current track."

	| cmd chan key vel ticks byte length evt |
	cmd _ #unknown.
	chan _ key _ vel _ 0.
	ticks _ 0.
	[trackStream atEnd] whileFalse: [
		ticks _ ticks + (self readVarLengthIntFrom: trackStream).
		byte _ trackStream next.
		byte >= 16rF0
			ifTrue: [  "meta or system exclusive event"
				byte = 16rFF ifTrue: [self metaEventAt: ticks].
				((byte = 16rF0) or: [byte = 16rF7]) ifTrue: [  "system exclusive data"
					length _ self readVarLengthIntFrom: trackStream.
					trackStream skip: length].
				cmd _ #unknown]
			ifFalse: [  "channel message event"
				byte >= 16r80
					ifTrue: [  "new command"
						cmd _ byte bitAnd: 16rF0.
						chan _ byte bitAnd: 16r0F.
						key _ trackStream next]
					ifFalse: [  "use running status"
						cmd == #unknown
							ifTrue: [self error: 'undefined running status; bad MIDI file?'].
						key _ byte].

				((cmd = 16rC0) or: [cmd = 16rD0]) ifFalse: [
					"all but program change and channel pressure have two data bytes"
					vel _ trackStream next].

				cmd = 16r80 ifTrue: [  "note off"
					self endNote: key chan: chan at: ticks].

				cmd = 16r90 ifTrue: [  "note on"
					vel = 0
						ifTrue: [self endNote: key chan: chan at: ticks]
						ifFalse: [self startNote: key vel: vel chan: chan at: ticks]].

				"cmd = 16A0 -- polyphonic key pressure; skip"

				cmd = 16rB0 ifTrue: [
					evt _ ControlChangeEvent new control: key value: vel channel: chan.
					evt time: ticks.
					track add: evt].

				cmd = 16rC0 ifTrue: [
					evt _ ProgramChangeEvent new program: key channel: chan.
					evt time: ticks.
					track add: evt].

				"cmd = 16D0 -- channel aftertouch pressure; skip"

				cmd = 16rE0 ifTrue: [
					evt _ PitchBendEvent new bend: key + (vel bitShift: 7) channel: chan.
					evt time: ticks.
					track add: evt]
	]].
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 3/28/98 05:46'!
startNote: midiKey vel: vel chan: chan at: startTicks
	"Record the beginning of a note."
	"Details: Some MIDI scores have missing note-off events, causing a note-on to be received for a (key, channel) that is already sounding. If the previous note is suspiciously long, truncate it."

	| newActiveEvents dur noteOnEvent |
	newActiveEvents _ nil.
	activeEvents do: [:e |
		((e midiKey = midiKey) and: [e channel = chan]) ifTrue: [
			"turn off key already sounding"
			dur _ startTicks - e time.
			dur > maxNoteTicks ifTrue: [dur _ ticksPerQuarter].  "truncate"
			e duration: dur.
			newActiveEvents ifNil: [newActiveEvents _ activeEvents copy].
			newActiveEvents remove: e ifAbsent: []]].
	newActiveEvents ifNotNil: [activeEvents _ newActiveEvents].

	noteOnEvent _ NoteEvent new key: midiKey velocity: vel channel: chan.
	noteOnEvent time: startTicks.
	track add: noteOnEvent.
	activeEvents add: noteOnEvent.
! !

!MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:15'!
trackContainsNotes: eventList
	"Answer true if the given track contains at least one note event."

	eventList do: [:e | e isNoteEvent ifTrue: [^ true]].
	^ false
! !


!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 20:00'!
guessMissingInstrumentNames
	"Attempt to guess missing instrument names from the first program change in that track."

	| progChange instrIndex instrName |
	1 to: tracks size do: [:i |
		(trackInfo at: i) isEmpty ifTrue: [
			progChange _ (tracks at: i) detect: [:e | e isProgramChange] ifNone: [nil].
			progChange ifNotNil: [
				instrIndex _ progChange program + 1.
				instrName _ self class standardMIDIInstrumentNames at: instrIndex.
				trackInfo at: i put: instrName]]].
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 10:30'!
next16BitWord
	"Read a 16-bit positive integer from the input stream, most significant byte first."
	"Assume: Stream has at least two bytes left."

	| n |
	n _ stream next.
	^ (n bitShift: 8) + stream next
! !

!MIDIFileReader methodsFor: 'private' stamp: 'ar 1/27/98 17:27'!
next32BitWord: msbFirst
	"Read a 32-bit positive integer from the input stream."
	"Assume: Stream has at least four bytes left."

	| n |
	n _ stream next: 4.
	^msbFirst
		ifTrue:[((n at: 1) bitShift: 24) + ((n at: 2) bitShift: 16) + ((n at: 3) bitShift: 8) + (n at: 4)]
		ifFalse:[((n at: 4) bitShift: 24) + ((n at: 3) bitShift: 16) + ((n at: 2) bitShift: 8) + (n at: 1)]
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 10:29'!
readChunkSize
	"Read a 32-bit positive integer from the next 4 bytes, most significant byte first."
	"Assume: Stream has at least four bytes left."

	| n |
	n _ 0.
	1 to: 4 do: [:ignore | n _ (n bitShift: 8) + stream next].
	^ n
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 17:32'!
readChunkType
	"Read a chunk ID string from the next 4 bytes."
	"Assume: Stream has at least four bytes left."

	| s |
	s _ String new: 4.
	1 to: 4 do: [:i | s at: i put: (stream next) asCharacter].
	^ s
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/31/97 11:33'!
readVarLengthIntFrom: aBinaryStream
	"Read a one to four byte positive integer from the given stream, most significant byte first. Use only the lowest seven bits of each byte. The highest bit of a byte is set for all bytes except the last."

	| n byte |
	n _ 0.
	1 to: 4 do: [:ignore |
		byte _ aBinaryStream next.
		byte < 128 ifTrue: [
			n = 0
				ifTrue: [^ byte]  "optimization for one-byte lengths"
				ifFalse: [^ (n bitShift: 7) + byte]].
		n _ (n bitShift: 7) + (byte bitAnd: 16r7F)].

	self error: 'variable length quantity must not exceed four bytes'.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 12/30/97 06:36'!
report: aString

	Transcript show: aString; cr.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 2/1/98 19:20'!
riffSkipToMidiChunk
	"This file is a RIFF file which may (or may not) contain a MIDI chunk. Thanks to Andreas Raab for this code."

	| dwLength fourcc |
	"Read length of all data"
	dwLength := self next32BitWord: false.
	"Get RIFF contents type "
	fourcc := self readChunkType.
	fourcc = 'RMID' ifFalse:[^fourcc]. "We can only read RMID files here"
	"Search for data"
	[[fourcc := self readChunkType.
	dwLength := self next32BitWord: false.
	fourcc = 'data'] whileFalse:[
		"Skip chunk - rounded to word boundary"
		stream skip: (dwLength + 1 bitAnd: 16rFFFFFFFE).
		stream atEnd ifTrue:[^'']].
	"Data chunk is raw - look into if it contains MIDI data and skip if not"
	fourcc := self readChunkType.
	fourcc = 'MThd'] whileFalse:[
		"Skip data (chunk - 4bytes) rounded to word boundary"
		stream skip: (dwLength - 3 bitAnd: 16rFFFFFFFE)].
	^fourcc! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 19:19'!
scanForMIDIHeader
	"Scan the first part of this file in search of the MIDI header string 'MThd'. Report an error if it is not found. Otherwise, leave the input stream positioned to the first byte after this string."

	| asciiM p lastSearchPosition byte restOfHeader |
	asciiM _ $M asciiValue.
	stream skip: -3.
	p _ stream position.
	lastSearchPosition _ p + 10000.  "search only the first 10000 bytes of the file"
	[p < lastSearchPosition and: [stream atEnd not]] whileTrue: [
		[(byte _ stream next) ~= asciiM and: [byte ~~ nil]] whileTrue.  "find the next 'M' or file end"
		restOfHeader _ (stream next: 3) asString.
		restOfHeader = 'Thd'
			ifTrue: [^ self]
			ifFalse: [restOfHeader size = 3 ifTrue: [stream skip: -3]].
		p _ stream position].

	self error: 'MIDI header chunk not found'.
! !

!MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 20:10'!
splitIntoTracks
	"Split a type zero MIDI file into separate tracks by channel number."

	| newTempoMap newTracks |
	tracks size = 1 ifFalse: [self error: 'expected exactly one track in type 0 file'].
	tempoMap ifNotNil: [self error: 'did not expect a tempo map in type 0 file'].
	newTempoMap _ OrderedCollection new.
	newTracks _ (1 to: 16) collect: [:i | OrderedCollection new].
	tracks first do: [:e |
		e isTempoEvent
			ifTrue: [newTempoMap addLast: e]
			ifFalse: [(newTracks at: e channel + 1) addLast: e]].
	newTempoMap size > 0 ifTrue: [tempoMap _ newTempoMap asArray].
	newTracks _ newTracks select: [:t | self trackContainsNotes: t].
	tracks _ newTracks collect: [:t | t asArray].
	trackInfo _ trackInfo, ((2 to: tracks size) collect: [:i | '']).
! !

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

MIDIFileReader class
	instanceVariableNames: ''!

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 2/1/98 19:48'!
playFileNamed: fileName

	ScorePlayerMorph
		openOn: (self scoreFromFileNamed: fileName)
		title: (FileDirectory localNameFor: fileName).
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'!
playStream: binaryStream

	ScorePlayerMorph
		openOn: (self scoreFromStream: binaryStream)
		title: 'a MIDI stream'
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 5/29/1998 17:12'!
playURLNamed: urlString

	| titleString |
	titleString _ urlString
		copyFrom: (urlString findLast: [:c | c=$/]) + 1
		to: urlString size.
	ScorePlayerMorph
		openOn: (self scoreFromURL: urlString)
		title: titleString.
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 1/3/98 09:58'!
scoreFromFileNamed: fileName

	| f score |
	f _ (FileStream readOnlyFileNamed: fileName) binary.
	score _ (self new readMIDIFrom: f) asScore.
	f close.
	^ score
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'!
scoreFromStream: binaryStream

	|  score |
	score _ (self new readMIDIFrom: binaryStream) asScore.
	^ score
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 21:48'!
scoreFromURL: urlString

	| data |
	data _ HTTPSocket httpGet: urlString accept: 'audio/midi'.
	data binary.
	^ (self new readMIDIFrom: data) asScore.
! !

!MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 9/12/1998 19:57'!
standardMIDIInstrumentNames
	"Answer an array of Standard MIDI instrument names."

	^ #(
		'Grand Piano'
		'Bright Piano'
		'Electric Grand Piano'
		'Honky-tonk Piano'
		'Electric Piano 1'
		'Electric Piano 2'
		'Harpsichord'
		'Clavichord'
		'Celesta'
		'Glockenspiel'
		'Music Box'
		'Vibraphone'
		'Marimba'
		'Xylophone'
		'Tubular Bells'
		'Duclimer'
		'Drawbar Organ'
		'Percussive Organ'
		'Rock Organ'
		'Church Organ'
		'Reed Organ'
		'Accordion'
		'Harmonica'
		'Tango Accordion'
		'Nylon Guitar'
		'Steel Guitar'
		'Electric Guitar 1'
		'Electric Guitar 2'
		'Electric Guitar 3'
		'Overdrive Guitar'
		'Distorted Guitar'
		'Guitar Harmonics'
		'Acoustic Bass'
		'Electric Bass 1'
		'Electric Bass 2'
		'Fretless Bass'
		'Slap Bass 1'
		'Slap Bass 2'
		'Synth Bass 1'
		'Synth Bass 2'
		'Violin'
		'Viola'
		'Cello'
		'Contrabass'
		'Tremolo Strings'
		'Pizzicato Strings'
		'Orchestral Harp'
		'Timpani'
		'String Ensemble 1'
		'String Ensemble 2'
		'Synth Strings 1'
		'Synth Strings 2'
		'Choir Ahhs'
		'Choir Oohs'
		'Synth Voice'
		'Orchestra Hit'
		'Trumpet'
		'Trombone'
		'Tuba'
		'Muted Trumpet'
		'French Horn'
		'Brass Section'
		'Synth Brass 1'
		'Synth Brass 2'
		'Soprano Sax'
		'Alto Sax'
		'Tenor Sax'
		'Baritone Sax'
		'Oboe'
		'English Horn'
		'Bassoon'
		'Clarinet'
		'Piccolo'
		'Flute'
		'Recorder'
		'Pan Flute'
		'Blown Bottle'
		'Shakuhachi'
		'Whistle'
		'Ocarina'
		'Lead 1 (square)'
		'Lead 2 (sawtooth)'
		'Lead 3 (calliope)'
		'Lead 4 (chiff)'
		'Lead 5 (charang)'
		'Lead 6 (voice)'
		'Lead 7 (fifths)'
		'Lead 8 (bass+lead)'
		'Pad 1 (new age)'
		'Pad 2 (warm)'
		'Pad 3 (polysynth)'
		'Pad 4 (choir)'
		'Pad 5 (bowed)'
		'Pad 6 (metallic)'
		'Pad 7 (halo)'
		'Pad 8 (sweep)'
		'FX 1 (rain)'
		'FX 2 (soundtrack)'
		'FX 3 (crystals)'
		'FX 4 (atmosphere)'
		'FX 5 (brightness)'
		'FX 6 (goblins)'
		'FX 7 (echoes)'
		'FX 8 (sci-fi)'
		'Sitar'
		'Banjo'
		'Shamisen'
		'Koto'
		'Kalimba'
		'Bagpipe'
		'Fiddle'
		'Shanai'
		'Tinkle Bell'
		'Agogo'
		'Steel Drum'
		'Woodblock'
		'Taiko Drum'
		'Melodic Tom'
		'Synth Drum'
		'Reverse Cymbal'
		'Guitar Fret Noise'
		'Breath Noise'
		'Seashore'
		'Bird Tweet'
		'Telephone Ring'
		'Helicopter'
		'Applause'
		'Gunshot')
! !
Object subclass: #MIDIInputParser
	instanceVariableNames: 'cmdActionTable midiPort received rawDataBuffer sysExBuffer ignoreSysEx startTime timeNow state lastSelector lastCmdByte argByte1 argByte2 '
	classVariableNames: 'DefaultMidiTable '
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIInputParser commentStamp: '<historical>' prior: 0!
I am a parser for a MIDI data stream. I support:

	real-time MIDI recording,
	overdubbing (recording while playing),
	monitoring incoming MIDI, and
	interactive MIDI performances.

Note: MIDI controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this filtering, including filtering by MIDI channel and/or by command type.
!


!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:39'!
ignoreChannel: channel
	"Don't record any events arriving on the given MIDI channel (in the range 1-16)."

	((channel isInteger not) | (channel < 1) | (channel > 16))
		ifTrue: [^ self error: 'bad MIDI channel number', channel printString].

	"two-arg channel messages"
	#(128 144 160 176 224) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreTwo:].

	"one-arg channel messages"
	#(192 208) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreOne:].
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:40'!
ignoreCommand: midiCmd
	"Don't record the given MIDI command on any channel."

	| cmd sel | 
	((midiCmd isInteger not) | (midiCmd < 128) | (midiCmd > 255))
		ifTrue: [^ self error: 'bad MIDI command'].

	midiCmd < 240 ifTrue: [  "channel commands; ignore on all channels"
		cmd _ midiCmd bitAnd: 2r11110000.
		sel _ (#(128 144 160 176 224) includes: cmd)
			ifTrue: [#ignoreTwo:]
			ifFalse: [#ignoreOne:].
		 1 to: 16 do: [:ch | cmdActionTable at: (cmd bitOr: ch - 1) put: sel].
		^ self].

	(#(240 241 244 245 247 249 253) includes: midiCmd) ifTrue: [
		^ self error: 'You can''t ignore the undefined MIDI command: ', midiCmd printString].

	midiCmd = 242 ifTrue: [  "two-arg command"
		cmdActionTable at: midiCmd put: #ignoreTwo:.
		 ^ self].

	midiCmd = 243 ifTrue: [  "one-arg command"
		cmdActionTable at: midiCmd put: #ignoreOne:.
		^ self].

	(#(246 248 250 251 252 254 255) includes: midiCmd) ifTrue:	[  "zero-arg command"
		cmdActionTable at: midiCmd put: #ignore.
		 ^ self].

	"we should not get here"
	self error: 'implementation error'.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:38'!
ignoreSysEx: aBoolean
	"If the argument is true, then ignore incoming system exclusive message."

	ignoreSysEx _ aBoolean.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:46'!
ignoreTuneAndRealTimeCommands
	"Ignore tuning requests and real-time commands."

	cmdActionTable at: 246 put: #ignoreZero:.	"tune request"
	cmdActionTable at: 248 put: #ignoreZero:.	"timing clock"
	cmdActionTable at: 250 put: #ignoreZero:.	"start"
	cmdActionTable at: 251 put: #ignoreZero:.		"continue"
	cmdActionTable at: 252 put: #ignoreZero:.	"stop/Clock"
	cmdActionTable at: 254 put: #ignoreZero:.	"active sensing"
	cmdActionTable at: 255 put: #ignoreZero:.	"system reset"
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:37'!
noFiltering
	"Revert to accepting all MIDI commands on all channels. This undoes any earlier request to filter the incoming MIDI stream."

	cmdActionTable _ DefaultMidiTable deepCopy.
	ignoreSysEx _ false.
! !

!MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:50'!
recordOnlyChannels: channelList
	"Record only MIDI data arriving on the given list of channel numbers (in the range 1-16)."

	channelList do: [:ch |
		((ch isInteger not) | (ch < 1) | (ch > 16))
			ifTrue: [^ self error: 'bad Midi channel specification: ', ch printString]].

	1 to: 16 do: [:ch | (channelList includes: ch) ifFalse: [self ignoreChannel: ch]].
! !


!MIDIInputParser methodsFor: 'recording' stamp: 'jm 1/6/1999 08:24'!
clearBuffers
	"Clear the MIDI record buffers. This should be called at the start of recording or real-time MIDI processing."	

	received _ received species new: 5000.
	rawDataBuffer _ ByteArray new: 1000.
	sysExBuffer _ WriteStream on: (ByteArray new: 100).
	midiPort ifNotNil: [midiPort ensureOpen; flushInput].
	startTime _ Time millisecondClockValue.
	state _ #idle.
! !

!MIDIInputParser methodsFor: 'recording' stamp: 'jm 10/8/1998 21:06'!
processMIDIData
	"Process all MIDI data that has arrived since the last time this method was executed. This method should be called frequently to process, filter, and timestamp MIDI data as it arrives."

	| bytesRead |
	[(bytesRead _ midiPort readInto: rawDataBuffer) > 0] whileTrue: [
		timeNow _ (midiPort bufferTimeStampFrom: rawDataBuffer) - startTime.
		5 to: bytesRead do: [:i | self processByte: (rawDataBuffer at: i)]].
! !

!MIDIInputParser methodsFor: 'recording' stamp: 'jm 10/8/1998 20:24'!
received
	"Answer my current collection of all MIDI commands received. Items in this list have the form (<time><cmd byte>[<arg1>[<arg2>]]). Note that the real-time processing facility, midiDo:, removes items from this list as it processes them."

	^ received
! !


!MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/9/1998 07:53'!
midiDo: aBlock
	"Poll the incoming MIDI stream in real time and call the given block for each complete command that has been received. The block takes one argument, which is an array of the form (<time><cmd byte>[<arg1>[<arg2>]]). The number of arguments depends on the command byte. For system exclusive commands, the argument is a ByteArray containing the system exclusive message."

	self processMIDIData.
	[received isEmpty] whileFalse:
		[aBlock value: received removeFirst].
! !

!MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/8/1998 21:21'!
midiDoUntilMouseDown: midiActionBlock
	"Process the incoming MIDI stream in real time by calling midiActionBlock for each MIDI event. This block takes three arguments: the MIDI command byte and two argument bytes. One or both argument bytes may be nil, depending on the MIDI command. If not nil, evaluatue idleBlock regularly whether MIDI data is available or not. Pressing any mouse button terminates the interaction."

	| time cmd arg1 arg2 |
	self clearBuffers.
	[Sensor anyButtonPressed] whileFalse: [
		self midiDo: [:item |
			time _ item at: 1.
			cmd _ item at: 2.
			arg1 _ arg2 _ nil.
			item size > 2 ifTrue: [
				arg1 _ item at: 3.
				item size > 3 ifTrue: [arg2 _ item at: 4]].
				midiActionBlock value: cmd value: arg1 value: arg2]].
! !


!MIDIInputParser methodsFor: 'midi monitor' stamp: 'jm 10/8/1998 21:22'!
monitor
	"Print MIDI messages to the transcript until any mouse button is pressed."

	self midiDoUntilMouseDown: [:cmd :arg1 :arg2 |
		self printCmd: cmd with: arg1 with: arg2].
! !

!MIDIInputParser methodsFor: 'midi monitor' stamp: 'jm 10/9/1998 10:19'!
printCmd: cmdByte with: arg1 with: arg2
	"Print the given MIDI command."

	| cmd ch bend |
	cmdByte < 240
		ifTrue: [  "channel message" 
			cmd _ cmdByte bitAnd: 2r11110000.
			ch _ (cmdByte bitAnd: 2r00001111) + 1]
		ifFalse: [cmd _ cmdByte].  "system message"

	cmd = 128 ifTrue: [
		^ Transcript show: ('key up ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 144 ifTrue: [
		^ Transcript show: ('key down: ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 160 ifTrue: [
		^ Transcript show: ('key pressure: ', arg1 printString, ' val: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 176 ifTrue: [
		^ Transcript show: ('CC', arg1 printString, ': val: ', arg2 printString, ' chan: ', ch printString); cr].
	cmd = 192 ifTrue: [
		^ Transcript show: ('prog: ', (arg1 + 1) printString, ' chan: ', ch printString); cr].
	cmd = 208 ifTrue: [
		^ Transcript show: ('channel pressure ', arg1 printString, ' chan: ', ch printString); cr].
	cmd = 224 ifTrue: [
		bend _ ((arg2 bitShift: 7) + arg1) - 8192.
		^ Transcript show: ('bend: ', bend printString, ' chan: ', ch printString); cr].

	cmd = 240 ifTrue: [
		^ Transcript show: ('system exclusive: ', (arg1 at: 1) printString, ' (', arg1 size printString, ' bytes)'); cr].

	Transcript show: 'cmd: ', cmd printString, ' arg1: ', arg1 printString, ' arg2: ', arg2 printString; cr.
! !


!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 18:34'!
endSysExclusive: cmdByte
	"Error!! Received 'end system exclusive' command when not receiving system exclusive data."

	self error: 'unexpected ''End of System Exclusive'' command'.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'!
ignoreOne: cmdByte
	"Ignore a one argument command."	

	lastCmdByte _ cmdByte.
	lastSelector _ #ignoreOne:.
	state _ #ignore1.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'!
ignoreTwo: cmdByte
	"Ignore a two argument command."	

	lastCmdByte _ cmdByte.
	lastSelector _ #ignoreTwo:.
	state _ #ignore2.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:45'!
ignoreZero: cmdByte
	"Ignore a zero argument command, such as tune request or a real-time message. Stay in the current and don't change active status. Note that real-time messages can arrive between data bytes without disruption."	

	"do nothing"
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 09:36'!
processByte: aByte
	"Process the given incoming MIDI byte and record completed commands."
	"Details: Because this must be fast, it has been hand-tuned. Be careful!!"

	aByte > 247 ifTrue: [  "real-time message; can arrive at any time"
		^ self perform: (cmdActionTable at: aByte) with: aByte].

	#idle = state ifTrue: [
		aByte >= 128
			ifTrue: [  "command byte in idle state: start new command"
				^ self perform: (cmdActionTable at: aByte) with: aByte]
			ifFalse: [  "data byte in idle state: use running status if possible"
				lastCmdByte ifNil: [^ self].  "running status unknown; skip byte"
				"process this data as if it had the last command byte in front of it"
				 self perform: lastSelector with: lastCmdByte.

				"the previous line put us into a new state; we now 'fall through'
				 to process the data byte given this new state."]].

	#ignore1 = state ifTrue: [^ state _ #idle].
	#ignore2 = state ifTrue: [^ state _ #ignore1].

	#want1of2 = state ifTrue: [
		argByte1 _ aByte.
		^ state _ #want2of2].

	#want2of2 = state ifTrue: [
		argByte2 _ aByte.
		received addLast: (Array with: timeNow with: lastCmdByte with: argByte1 with: argByte2).
		^ state _ #idle].

	#want1only = state ifTrue: [
		argByte1 _ aByte.
		received addLast: (Array with: timeNow with: lastCmdByte with: argByte1).
		^ state _ #idle].

	#sysExclusive = state ifTrue: [
		aByte < 128 ifTrue: [
			"record a system exclusive data byte"
			ignoreSysEx ifFalse: [sysExBuffer nextPut: aByte].
			^ self]
		ifFalse: [
			aByte < 248 ifTrue: [
				"a system exclusive message is terminated by any non-real-time command byte"
				ignoreSysEx ifFalse: [
					received addLast: (Array with: timeNow with: lastCmdByte with: sysExBuffer contents)].
				state _ #idle.
				aByte = 247
					ifTrue: [^ self]							"endSysExclusive command, nothing left to do"
					ifFalse: [^ self processByte: aByte]]]].  	"no endSysExclusive; just start the next command"
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'!
recordOne: cmdByte
	"Record a one argument command at the current time."	

	lastCmdByte _ cmdByte.
	lastSelector _ #recordOne:.
	state _ #want1only.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'!
recordTwo: cmdByte
	"Record a two argument command at the current time."	

	lastCmdByte _ cmdByte.
	lastSelector _ #recordTwo:.
	state _ #want1of2.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:43'!
recordZero: cmdByte
	"Record a zero-byte message, such as tune request or a real-time message. Don't change active status. Note that real-time messages can arrive between data bytes without disruption."	

	received addLast: (Array with: timeNow with: cmdByte).
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 09:38'!
startSysExclusive: cmdByte
	"The beginning of a variable length 'system exclusive' command."

	sysExBuffer resetContents.
	lastCmdByte _ nil.  "system exclusive commands clear running status"
	lastSelector _ nil.
	state _ #sysExclusive.
! !

!MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 17:12'!
undefined: cmdByte
	"We have received an unexpected MIDI byte (e.g., a data byte when we were expecting a command). This should never happen."

	self error: 'unexpected MIDI byte ', cmdByte printString.
! !


!MIDIInputParser methodsFor: 'private-other' stamp: 'jm 10/9/1998 07:56'!
setMIDIPort: aMIDIPort
	"Initialize this instance for recording from the given MIDI port. Tune and real-time commands are filtered out by default; the client can send noFiltering to receive these messages."

	midiPort _ aMIDIPort.
	received _ OrderedCollection new.
	self noFiltering.  "initializes cmdActionTable"
	self ignoreTuneAndRealTimeCommands.
! !


!MIDIInputParser methodsFor: 'accessing' stamp: 'jm 1/6/1999 08:25'!
midiPort

	^ midiPort
! !

!MIDIInputParser methodsFor: 'accessing' stamp: 'jm 1/6/1999 08:24'!
midiPort: aMIDIPort
	"Use the given MIDI port."

	midiPort _ aMIDIPort.
	self clearBuffers.
! !

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

MIDIInputParser class
	instanceVariableNames: ''!

!MIDIInputParser class methodsFor: 'class initialization' stamp: 'jm 10/9/1998 07:35'!
initialize
	"Build the default MIDI command-byte action table. This table maps MIDI command bytes to the action to be performed when that is received. Note that MIDI data bytes (bytes whose value is < 128) are never used to index into this table."
	"MIDIInputParser initialize"

	DefaultMidiTable _ Array new: 255 withAll: #undefined:.
	128 to: 143 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"key off"
	144 to: 159 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"key on"
	160 to: 175 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"polyphonic after-touch"
	176 to: 191 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"control change"
	192 to: 207 do: [:i | DefaultMidiTable at: i put: #recordOne:].		"program change"
	208 to: 223 do: [:i | DefaultMidiTable at: i put: #recordOne:].		"channel after-touch"
	224 to: 239 do: [:i | DefaultMidiTable at: i put: #recordTwo:].		"pitch bend"

	DefaultMidiTable at: 240 put: #startSysExclusive:.		"start a system exclusive block"
	DefaultMidiTable at: 241 put: #recordOne:.			"MIDI time code quarter frame"
	DefaultMidiTable at: 242 put: #recordTwo:.			"song position select"
	DefaultMidiTable at: 243 put: #recordOne:.			"song select"
	DefaultMidiTable at: 244 put: #undefined:.
	DefaultMidiTable at: 245 put: #undefined:.
	DefaultMidiTable at: 246 put: #recordZero:.			"tune request"
	DefaultMidiTable at: 247 put: #endSysExclusive:.		"end a system exclusive block"
	DefaultMidiTable at: 248 put: #recordZero:.			"timing clock"
	DefaultMidiTable at: 249 put: #undefined:.
	DefaultMidiTable at: 250 put: #recordZero:.			"start"
	DefaultMidiTable at: 251 put: #recordZero:.			"continue"
	DefaultMidiTable at: 252 put: #recordZero:.			"stop/Clock"
	DefaultMidiTable at: 253 put: #undefined:.
	DefaultMidiTable at: 254 put: #recordZero:.			"active sensing"
	DefaultMidiTable at: 255 put: #recordZero:.			"system reset"
! !


!MIDIInputParser class methodsFor: 'instance creation' stamp: 'jm 10/8/1998 20:29'!
on: aSimpleMIDIPort
	"Answer a new MIDI parser on the given port."

	^ super new setMIDIPort: aSimpleMIDIPort
! !
PianoKeyboardMorph subclass: #MIDIPianoKeyboardMorph
	instanceVariableNames: 'midiPort channel velocity '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!
!MIDIPianoKeyboardMorph commentStamp: '<historical>' prior: 0!
I implement a piano keyboard that can be played with the mouse. I can output to a MIDI port, if MIDI is supported on this platform. I can also spawn controllers for other MIDI parameters, such as pitch bend.
!


!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:13'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	midiPort
		ifNil: [aCustomMenu add: 'play via MIDI' action: #openMIDIPort]
		ifNotNil: [
			aCustomMenu add: 'play via built in synth' action: #closeMIDIPort.
			aCustomMenu add: 'new MIDI controller' action: #makeMIDIController:].
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 15:57'!
closeMIDIPort

	midiPort _ nil.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:30'!
initialize

	super initialize.
	SimpleMIDIPort midiIsSupported
		ifTrue: [midiPort _ SimpleMIDIPort openDefault].
	channel _ 1.
	velocity _ 100.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:11'!
makeMIDIController: evt

	self world activeHand attachMorph:
		(MIDIControllerMorph new midiPort: midiPort).
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 16:25'!
mouseDownEvent: event noteMorph: noteMorph pitch: midiKey

	midiPort ifNil: [^ super mouseDownEvent: event noteMorph: noteMorph pitch: midiKey - 1].
	noteMorph color: playingKeyColor.
	soundPlaying
		ifNil: [midiPort ensureOpen]
		ifNotNil: [self turnOffNote].
	self turnOnNote: midiKey + 23.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 15:43'!
mouseUpEvent: event noteMorph: noteMorph pitch: midiKey

	midiPort ifNil: [
		^ super mouseUpEvent: event noteMorph: noteMorph pitch: midiKey].

	noteMorph color:
		((#(0 1 3 5 6 8 10) includes: midiKey \\ 12)
			ifTrue: [whiteKeyColor]
			ifFalse: [blackKeyColor]).
	soundPlaying ifNotNil: [self turnOffNote].
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 18:00'!
openMIDIPort

	| portNum |
	portNum _ SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	midiPort _ SimpleMIDIPort openOnPortNumber: portNum.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 15:44'!
turnOffNote

	midiPort notNil & soundPlaying notNil ifTrue: [
		soundPlaying isInteger ifTrue: [
			midiPort midiCmd: 16r90 channel: channel byte: soundPlaying byte: 0]].
	soundPlaying _ nil.
! !

!MIDIPianoKeyboardMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 16:25'!
turnOnNote: midiKey

	midiPort midiCmd: 16r90 channel: channel byte: midiKey byte: velocity.
	soundPlaying _ midiKey.
! !
TestInterpreterPlugin subclass: #MIDIPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!MIDIPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:53'!
initialiseModule
	self export: true.
	^self cCode: 'midiInit()' inSmalltalk:[true]! !

!MIDIPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:55'!
shutdownModule
	self export: true.
	^self cCode: 'midiShutdown()' inSmalltalk:[true]! !


!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIClosePort: portNum

	self primitive: 'primitiveMIDIClosePort'
		parameters: #(SmallInteger).
	self sqMIDIClosePort: portNum! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetClock
	"Return the value of the MIDI clock as a SmallInteger. The range is limited to SmallInteger maxVal / 2 to allow scheduling MIDI events into the future without overflowing a SmallInteger. The sqMIDIGetClock function is assumed to wrap at or before 16r20000000."

	| clockValue |
	self primitive: 'primitiveMIDIGetClock'.
	clockValue _ self sqMIDIGetClock bitAnd: 16r1FFFFFFF.
	^clockValue asSmallIntegerObj! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetPortCount

	| n |
	self primitive: 'primitiveMIDIGetPortCount'.
	n _ self sqMIDIGetPortCount.
	^n asSmallIntegerObj
! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetPortDirectionality: portNum

	|  dir |
	self primitive: 'primitiveMIDIGetPortDirectionality'
		parameters: #(SmallInteger).
	dir _ self sqMIDIGetPortDirectionality: portNum.
	^dir asSmallIntegerObj! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:14'!
primitiveMIDIGetPortName: portNum

	| portName sz nameObj namePtr |
	self var: #portName declareC: 'char portName[256]'.
	self var: #namePtr declareC: 'char * namePtr'.
	self primitive: 'primitiveMIDIGetPortName'
		parameters: #(SmallInteger).

	sz _ self cCode: 'sqMIDIGetPortName(portNum, (int) &portName, 255)'.
	nameObj _ interpreterProxy instantiateClass: interpreterProxy classString indexableSize: sz.
	interpreterProxy failed ifTrue:[^nil].
	namePtr _ nameObj asValue: String .
	self cCode: 'memcpy(namePtr, portName, sz)'.
	^nameObj! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIOpenPort: portNum sema: semaIndex speed: clockRate

	self primitive: 'primitiveMIDIOpenPort'
		parameters: #(SmallInteger SmallInteger SmallInteger).
	self cCode: 'sqMIDIOpenPort(portNum, semaIndex, clockRate)'! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIParameterGet: whichParameter

	|  currentValue |
	"read parameter"
	self primitive: 'primitiveMIDIParameterGet'
		parameters: #(SmallInteger).
	currentValue _ self cCode: 'sqMIDIParameterGet(whichParameter)'.
	^currentValue asSmallIntegerObj! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIParameterGetOrSet
	"Backward compatibility"
	self export: true.
	interpreterProxy methodArgumentCount = 1
		ifTrue:[^self primitiveMIDIParameterGet]
		ifFalse:[^self primitiveMIDIParameterSet]! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIParameterSet: whichParameter value: newValue

	"write parameter"
	self primitive:'primitiveMIDIParameterSet'
		parameters:#(SmallInteger SmallInteger).
	self cCode: 'sqMIDIParameterSet(whichParameter, newValue)'! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIRead: portNum into: array

	| arrayLength bytesRead |
	self primitive: 'primitiveMIDIRead'
		parameters: #(SmallInteger ByteArray).
	arrayLength _ interpreterProxy byteSizeOf: array cPtrAsOop.
	bytesRead _ self sqMIDIPort: portNum
			Read: arrayLength
			Into: array asInteger.
	^bytesRead asSmallIntegerObj! !

!MIDIPlugin methodsFor: 'primitives' stamp: 'ar 5/12/2000 17:15'!
primitiveMIDIWrite: portNum from: array at: time

	| arrayLength bytesWritten |
	self primitive: 'primitiveMIDIWrite'
		parameters: #(SmallInteger ByteArray SmallInteger).
	arrayLength _ interpreterProxy byteSizeOf: array cPtrAsOop.
	bytesWritten _ self sqMIDIPort: portNum
			Write: arrayLength
			From: array asInteger
			At: time.
	^bytesWritten asSmallIntegerObj! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MIDIPlugin class
	instanceVariableNames: ''!

!MIDIPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:21'!
headerFile
^'/* MIDI primitives */

/* module initialization/shutdown */
int midiInit(void);
int midiShutdown(void);

int sqMIDIGetClock(void);
int sqMIDIGetPortCount(void);
int sqMIDIGetPortDirectionality(int portNum);
int sqMIDIGetPortName(int portNum, int namePtr, int length);
int sqMIDIClosePort(int portNum);
int sqMIDIOpenPort(int portNum, int readSemaIndex, int interfaceClockRate);
int sqMIDIParameterSet(int whichParameter, int newValue);
int sqMIDIParameterGet(int whichParameter);
int sqMIDIPortReadInto(int portNum, int count, int bufferPtr);
int sqMIDIPortWriteFromAt(int portNum, int count, int bufferPtr, int time);
'! !
Object subclass: #MIDIScore
	instanceVariableNames: 'tracks trackInfo ambientTrack tempoMap ticksPerQuarterNote '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDIScore commentStamp: '<historical>' prior: 0!
A MIDIScore is a container for a number of MIDI tracks as well as an ambient track for such things as sounds, book page triggers and other related events.!


!MIDIScore methodsFor: 'initialization' stamp: 'di 10/23/2000 16:19'!
initialize

	tracks _ #().
	ambientTrack _ Array new.
	tempoMap _ #().
	ticksPerQuarterNote _ 100.
! !


!MIDIScore methodsFor: 'accessing' stamp: 'ak 11/1/2000 20:18'!
durationInTicks
	
	| t |
	t _ 0.
	tracks, {self ambientTrack} do:
		[:track |
		track do:
			[:n | (n isNoteEvent)
				ifTrue: [t _ t max: n endTime]
				ifFalse: [t _ t max: n time]]].
	^ t
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 07:36'!
tempoMap

	^ tempoMap
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/29/98 18:09'!
tempoMap: tempoEventList

	tempoEventList ifNil: [
		tempoMap _ #().
		^ self].
	tempoMap _ tempoEventList asArray.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 07:37'!
ticksPerQuarterNote

	^ ticksPerQuarterNote
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 07:37'!
ticksPerQuarterNote: anInteger

	ticksPerQuarterNote _ anInteger.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'di 10/21/2000 10:02'!
trackInfo

	^ trackInfo ifNil: [tracks collect: [:i | String new]]
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/6/98 23:20'!
trackInfo: trackInfoList

	trackInfo _ trackInfoList asArray.
! !

!MIDIScore methodsFor: 'accessing' stamp: 'jm 1/3/98 08:15'!
tracks

	^ tracks
! !

!MIDIScore methodsFor: 'accessing' stamp: 'di 11/1/2000 12:40'!
tracks: trackList

	tracks _ trackList asArray collect: [:trackEvents | trackEvents asArray].
	self ambientTrack.  "Assure it's not nil"! !


!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/23/2000 16:18'!
addAmbientEvent: evt
	| i |
	i _ ambientTrack findFirst: [:e | e time >= evt time].
	i = 0 ifTrue: [^ ambientTrack _ ambientTrack , (Array with: evt)].
	ambientTrack _ ambientTrack copyReplaceFrom: i to: i-1 with: (Array with: evt)! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 8/1/1998 15:31'!
ambientEventAfter: eventIndex ticks: scoreTicks
	| evt |
	(ambientTrack == nil or: [eventIndex > ambientTrack size]) ifTrue: [^ nil].
	evt _ ambientTrack at: eventIndex.
	evt time <= scoreTicks ifTrue: [^ evt].
	^ nil! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/25/2000 23:34'!
ambientTrack
	^ ambientTrack ifNil: [ambientTrack _ Array new]! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/23/2000 08:16'!
eventMorphsDo: aBlock
	"Evaluate aBlock for all morphs related to the ambient events."

	ambientTrack == nil ifTrue: [^ self].
	ambientTrack do: [:evt | evt morph doIfNotNil: aBlock].
! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/25/2000 22:24'!
eventMorphsWithTimeDo: aBlock
	"Evaluate aBlock for all morphs and times related to the ambient events."

	ambientTrack == nil ifTrue: [^ self].
	ambientTrack do: [:evt | evt morph ifNotNil: [aBlock value: evt morph value: evt time]].
! !

!MIDIScore methodsFor: 'ambient track' stamp: 'di 10/23/2000 16:19'!
removeAmbientEventWithMorph: aMorph
	| i |
	i _ ambientTrack findFirst: [:e | e morph == aMorph].
	i = 0 ifTrue: [^ self].
	ambientTrack _ ambientTrack copyReplaceFrom: i to: i with: Array new! !


!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:40'!
pauseFrom: scorePlayer
	self eventMorphsDo: [:p | p pauseFrom: scorePlayer]! !

!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:40'!
resetFrom: scorePlayer
	self eventMorphsDo: [:p | p resetFrom: scorePlayer]! !

!MIDIScore methodsFor: 'playing' stamp: 'di 10/22/2000 12:39'!
resumeFrom: scorePlayer
	self eventMorphsDo: [:p | p resumeFrom: scorePlayer]! !


!MIDIScore methodsFor: 'editing' stamp: 'di 6/20/1999 00:08'!
appendEvent: noteEvent fullDuration: fullDuration at: selection
	"It is assumed that the noteEvent already has the proper time"

	| track noteLoc |
	track _ tracks at: selection first.
	noteLoc _ selection third + 1.
	noteEvent midiKey = -1
		ifTrue: [noteLoc _ noteLoc - 1]
		ifFalse: ["If not a rest..."
				track _ track copyReplaceFrom: noteLoc to: noteLoc - 1
								with: (Array with: noteEvent)].
	track size >= (noteLoc + 1) ifTrue:
		["Adjust times of following events"
		noteLoc + 1 to: track size do:
			[:i | (track at: i) adjustTimeBy: fullDuration]].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 15:12'!
cutSelection: selection

	| track selStartTime delta |
	track _ tracks at: selection first.
	selStartTime _ (track at: selection second) time.
	track _ track copyReplaceFrom: selection second to: selection third with: Array new.
	track size >=  selection second ifTrue:
		["Adjust times of following events"
		delta _ selStartTime - (track at: selection second) time.
		selection second to: track size do:
			[:i | (track at: i) adjustTimeBy: delta]].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'jm 9/10/1998 17:22'!
eventForTrack: trackIndex after: eventIndex ticks: scoreTick

	| track evt |
	track _ tracks at: trackIndex.
	eventIndex > track size ifTrue: [^ nil].
	evt _ track at: eventIndex.
	evt time > scoreTick ifTrue: [^ nil].
	^ evt
! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 16:06'!
gridToNextQuarterNote: tickTime

	^ self gridToQuarterNote: tickTime + ticksPerQuarterNote! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 14:55'!
gridToQuarterNote: tickTime

	^ tickTime truncateTo: ticksPerQuarterNote! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 16:14'!
gridTrack: trackIndex toQuarter: quarterDelta at: indexInTrack

	| track selStartTime delta |
	track _ tracks at: trackIndex.
	selStartTime _ (track at: indexInTrack) time.
	delta _ (self gridToQuarterNote: selStartTime + (quarterDelta*ticksPerQuarterNote))
				- selStartTime.
	indexInTrack to: track size do:
		[:i | (track at: i) adjustTimeBy: delta].
! !

!MIDIScore methodsFor: 'editing' stamp: 'di 6/21/1999 10:56'!
insertEvents: events at: selection

	| track selStartTime delta |
	track _ tracks at: selection first.
	selection second = 0
		ifTrue: [selStartTime _ 0.
				selection at: 2 put: 1]
		ifFalse: [selStartTime _ (track at: selection second) time].
	track _ track copyReplaceFrom: selection second to: selection second - 1
				with: (events collect: [:e | e copy]).
	track size >=  (selection second + events size) ifTrue:
		["Adjust times of following events"
		delta _ selStartTime - (track at: selection second) time.
		selection second to: selection second + events size - 1 do:
			[:i | (track at: i) adjustTimeBy: delta].
		delta _ (self gridToNextQuarterNote: (track at: selection second + events size - 1) endTime)
					- (track at: selection second + events size) time.
		selection second + events size to: track size do:
			[:i | (track at: i) adjustTimeBy: delta].
		].
	tracks at: selection first put: track! !

!MIDIScore methodsFor: 'editing' stamp: 'jm 8/6/1998 21:16'!
jitterStartAndEndTimesBy: mSecs

	| r range halfRange oldEnd newEnd newStart |
	r _ Random new.
	range _ 2.0 * mSecs.
	halfRange _ mSecs.
	tracks do: [:t |
		t do: [:e |
			e isNoteEvent ifTrue: [
				oldEnd _ e time + e duration.
				newEnd _ oldEnd + ((r next * range) asInteger - halfRange).
				newStart _ e time + ((r next * range) asInteger - halfRange).
				e time: newStart.
				e duration: (newEnd - newStart)]]].

				! !
Object subclass: #MIDISynth
	instanceVariableNames: 'midiParser channels process '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDISynth commentStamp: '<historical>' prior: 0!
I implement a simple real-time MIDI synthesizer on platforms that support MIDI input. I work best on platforms that allow the sound buffer to be made very short--under 50 milliseconds is good and under 20 milliseconds is preferred (see below). The buffer size is changed by modifying the class initialization method of SoundPlayer and executing the do-it there to re-start the sound player.

Each instance of me takes input from a single MIDI input port. Multiple instances of me can be used to handle multiple MIDI input ports. I distribute incoming commands among my sixteen MIDISynthChannel objects. Most of the interpretation of the MIDI commands is done by these channel objects. 

Buffer size notes: At the moment, most fast PowerPC Macintosh computers can probably work with buffer sizes down to 50 milliseconds, and the Powerbook G3 works down to about 15 milliseconds. You will need to experiment to discover the minimum buffer size that does not result in clicking during sound output. (Hint: Be sure to turn off power cycling on your Powerbook. Other applications and extensions can steal cycles from Squeak, causing intermittent clicking. Experimentation may be necessary to find a configuration that works for you.)
!


!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 22:16'!
channel: i

	^ channels at: i
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:50'!
closeMIDIPort

	midiParser midiPort ifNil: [^ self].
	midiParser midiPort close.
	midiParser midiPort: nil.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:29'!
initialize

	midiParser _ MIDIInputParser on: nil.
	channels _ (1 to: 16) collect: [:ch | MIDISynthChannel new initialize].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:13'!
instrumentForChannel: channelIndex

	^ (channels at: channelIndex) instrument
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:14'!
instrumentForChannel: channelIndex put: aSoundProto

	(channels at: channelIndex) instrument: aSoundProto.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:27'!
isOn

	^ process notNil
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 21:52'!
midiParser

	^ midiParser
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:26'!
midiPort

	^ midiParser midiPort
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:32'!
midiPort: aMIDIPortOrNil

	midiParser midiPort: aMIDIPortOrNil.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/13/1998 12:09'!
midiTrackingLoop

	midiParser clearBuffers.
	[true] whileTrue: [
		self processMIDI ifFalse: [(Delay forMilliseconds: 5) wait]].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 20:12'!
mutedForChannel: channelIndex put: aBoolean

	^ (channels at: channelIndex) muted: aBoolean
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'!
panForChannel: channelIndex

	^ (channels at: channelIndex) pan
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'!
panForChannel: channelIndex put: newPan

	(channels at: channelIndex) pan: newPan.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 14:13'!
processMIDI
	"Process some MIDI commands. Answer true if any commands were processed."

	| didSomething cmdByte byte1 byte2 cmd chan |
	didSomething _ false.
	midiParser midiDo: [:item |
		didSomething _ true.
		cmdByte _ item at: 2.
		byte1 _ byte2 _ nil.
		item size > 2 ifTrue: [
			byte1 _ item at: 3.
			item size > 3 ifTrue: [byte2 _ item at: 4]].
		cmdByte < 240
			ifTrue: [  "channel message" 
				cmd _ cmdByte bitAnd: 2r11110000.
				chan _ (cmdByte bitAnd: 2r00001111) + 1.
				(channels at: chan) doChannelCmd: cmd byte1: byte1 byte2: byte2]
			ifFalse: [  "system message"
				"process system messages here"
			]].
	^ didSomething
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 14:14'!
processMIDIUntilMouseDown
	"Used for debugging. Do MIDI processing until the mouse is pressed."

	midiParser clearBuffers.
	[Sensor anyButtonPressed] whileFalse: [self processMIDI].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:36'!
setAllChannelMasterVolumes: aNumber

	| vol |
	vol _ (aNumber asFloat min: 1.0) max: 0.0.
	channels do: [:ch | ch masterVolume: vol].
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 08:16'!
startMIDITracking

	midiParser ifNil: [^ self].
	midiParser midiPort ifNil: [^ self].
	midiParser midiPort ensureOpen.
	self stopMIDITracking.
	SoundPlayer useShortBuffer.
	process _ [self midiTrackingLoop] newProcess.
	process priority: Processor userInterruptPriority.
	process resume.
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:34'!
stopMIDITracking

	process ifNotNil: [
		process terminate.
		process _ nil].
	SoundPlayer shutDown; initialize.  "revert to normal buffer size"
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'!
volumeForChannel: channelIndex

	^  (channels at: channelIndex) masterVolume
! !

!MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'!
volumeForChannel: channelIndex put: newVolume

	(channels at: channelIndex) masterVolume: newVolume.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MIDISynth class
	instanceVariableNames: ''!

!MIDISynth class methodsFor: 'examples' stamp: 'jm 1/6/1999 16:39'!
example
	"Here's one way to run the MIDI synth. It will get a nice Morphic UI later. Click the mouse to stop running it. (Mac users note: be sure you have MIDI interface adaptor plugged in, or Squeak will hang waiting for the external clock signal.)."
	"MIDISynth example"

	| portNum synth |
	portNum _ SimpleMIDIPort inputPortNumFromUser.
	portNum ifNil: [^ self].
	SoundPlayer useShortBuffer.
	synth _ MIDISynth new
		midiPort: (SimpleMIDIPort openOnPortNumber: portNum).
	synth midiParser ignoreCommand: 224.  "filter out pitch bends"
	1 to: 16 do: [:i |
		(synth channel: i) instrument:
 			 (AbstractSound soundNamed: 'oboe1')].
	1 to: 16 do: [:ch | synth volumeForChannel: ch put: 0.2].

	synth processMIDIUntilMouseDown.
	SoundPlayer shutDown; initialize.  "revert to normal buffer size"
! !


!MIDISynth class methodsFor: 'instance creation' stamp: 'jm 1/6/1999 08:15'!
new

	^ super new initialize
! !
Object subclass: #MIDISynthChannel
	instanceVariableNames: 'channel instrument muted masterVolume channelVolume pan pitchBend activeSounds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MIDISynthChannel commentStamp: '<historical>' prior: 0!
I implement one polyphonic channel of a 16-channel MIDI synthesizer. Many MIDI commands effect all the notes played on a particular channel, so I record the state for a single channel, including a list of notes currently playing.

This initial implementation is extremely spartan, having just enough functionality to play notes. Things that are not implemented include:

  1. program changes
  2. sustain pedal
  3. aftertouch (either kind)
  4. most controllers
  5. portamento
  6. mono-mode
!


!MIDISynthChannel methodsFor: 'initialization' stamp: 'jm 1/6/1999 20:10'!
initialize

	instrument _ FMSound default.
	muted _ false.
	masterVolume _ 0.5.
	channelVolume _ 1.0.
	pan _ 0.5.
	pitchBend _ 0.0.
	activeSounds _ OrderedCollection new.
! !


!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:45'!
instrument

	^ instrument
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:45'!
instrument: aSound

	instrument _ aSound.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:47'!
masterVolume

	^ masterVolume
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 11:49'!
masterVolume: aNumber
	"Set the master volume the the given value (0.0 to 1.0)."

	masterVolume _ aNumber asFloat.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 20:10'!
muted

	^ muted
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 20:11'!
muted: aBoolean

	muted _ aBoolean.
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 19:43'!
pan

	^ pan
! !

!MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 19:43'!
pan: aNumber
	"Set the left-right pan to the given value (0.0 to 1.0)."

	pan _ aNumber asFloat.
! !


!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 15:40'!
channelPressure: newPressure
	"Handle a channel pressure (channel aftertouch) change."

	self newVolume: newPressure.
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:48'!
control: control value: newValue
	"Handle a continuous controller change."

	control = 2 ifTrue: [self newVolume: newValue].  "breath controller"
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:44'!
doChannelCmd: cmdByte byte1: byte1 byte2: byte2
	"Dispatch a channel command with the given arguments."
	"Details: Cases appear in order of expected frequency, most frequent cases first."

	cmdByte = 144 ifTrue: [
		byte2 = 0
			ifTrue: [^ self keyUp: byte1 vel: 0]
			ifFalse: [^ self keyDown: byte1 vel: byte2]].
	cmdByte = 128 ifTrue: [^ self keyUp: byte1 vel: byte2].
	cmdByte = 224 ifTrue: [^ self pitchBend: ((byte2 bitShift: 7) + byte1) - 8192].
	cmdByte = 176 ifTrue: [^ self control: byte1 value: byte2].
	cmdByte = 208 ifTrue: [^ self channelPressure: byte1].
	cmdByte = 160 ifTrue: [^ self key: byte1 pressure: byte2].
	cmdByte = 192 ifTrue: [^ self programChange: byte1].
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:49'!
key: key pressure: press
	"Handle a key pressure (polyphonic aftertouch) change. Rarely implemented."

	"Do nothing for now."
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 1/10/1999 08:42'!
keyDown: key vel: vel
	"Handle a key down event with non-zero velocity."

	| pitch snd |
	muted ifTrue: [^ self].
	pitch _ AbstractSound pitchForMIDIKey: key.
	snd _ instrument
		soundForPitch: pitch
		dur: 10000.0  "sustain a long time, or until turned off"
		loudness: masterVolume * channelVolume * (self convertVelocity: vel).
	snd _ (MixedSound new add: snd pan: pan) reset.
	SoundPlayer resumePlaying: snd quickStart: false.
	activeSounds add: (Array with: key with: snd with: pitch).
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:49'!
keyUp: key vel: vel
	"Handle a key up event."

	| snd |
	activeSounds copy do: [:entry |
		(entry at: 1) = key ifTrue: [
			snd _ entry at: 2.
			snd stopGracefully.
			activeSounds remove: entry]].
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 1/11/1999 11:32'!
pitchBend: bend
	"Handle a pitch-bend change."

	self adjustPitch: bend.
! !

!MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:50'!
programChange: newProgram
	"Handle a program (instrument) change."

	"Do nothing for now."
! !


!MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 21:45'!
adjustPitch: bend
	"Handle a pitch-bend change."

	| snd pitchAdj centerPitch |
	pitchBend _ bend.
	pitchAdj _ 2.0 raisedTo: (bend asFloat / 8192.0) / 6.0.
	activeSounds copy do: [:entry |
		snd _ entry at: 2.
		centerPitch _ entry at: 3.
		snd pitch: pitchAdj * centerPitch.
		snd internalizeModulationAndRatio].
! !

!MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 15:43'!
convertVelocity: valueByte
	"Map a value in the range 0..127 to a volume in the range 0.0..1.0."
	"Details: A quadratic function seems to give a good keyboard feel."

	| r |
	r _ (valueByte * valueByte) / 12000.0.
	r > 1.0 ifTrue: [^ 1.0].
	r < 0.08 ifTrue: [^ 0.08].
	^ r
! !

!MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 15:41'!
newVolume: valueByte
	"Set the channel volume to the level given by the given number in the range 0..127."

	| snd newVolume |
	channelVolume _ valueByte asFloat / 127.0.
	newVolume _ masterVolume * channelVolume.
	activeSounds do: [:entry |
		snd _ entry at: 2.
		snd adjustVolumeTo: newVolume overMSecs: 10].
! !
Object subclass: #MIMEDocument
	instanceVariableNames: 'mainType subType content url '
	classVariableNames: 'MIMEdatabase '
	poolDictionaries: ''
	category: 'Network-Url'!
!MIMEDocument commentStamp: '<historical>' prior: 0!
a MIME object, along with its type and the URL it was found at (if any)!


!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:49'!
content
	"Answer the receiver's raw data."

	^ content! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:46'!
contentStream
	"Answer a RWBinaryOrTextStream on the contents."

	^ (RWBinaryOrTextStream with: self content) reset! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'!
contentType
	"Answer the MIME contents type."

	^ self mainType , '/' , self subType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'!
mainType
	^ mainType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'dvf 4/26/2000 18:23'!
parts
	| parseStream currLine separator msgStream messages |
	self isMultipart ifFalse: [^ #()].
	parseStream _ ReadStream on: self content.
	currLine _ ''.
	['--*' match: currLine]
		whileFalse: [currLine _ parseStream nextLine].
	separator _ currLine copy.
	msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator.
	messages _ OrderedCollection new.
	[parseStream atEnd]
		whileFalse: 
			[messages add: msgStream upToEnd.
			msgStream skipThisLine].
	^ messages collect: [:e | MIMEPart on: e]! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'!
subType
	^ subType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'!
type
	"Deprecated. Use contentType instead."

	^ self contentType! !

!MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'!
url
	"Answer the URL the receiver was downloaded from.  It may legitimately be nil."

	^ url! !


!MIMEDocument methodsFor: 'printing' stamp: 'bolot 12/14/2000 17:56'!
printOn: aStream
	aStream nextPutAll: self class name;
		nextPutAll: ' (';
		nextPutAll: self contentType;
		nextPutAll: ', '.
	self content
		ifNotNil: [aStream
			nextPutAll: self content size printString;
			nextPutAll: ' bytes)']
		ifNil: [aStream nextPutAll: 'unknown size)'].! !


!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:11'!
privateContent: aString
	content _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'!
privateMainType: aString
	mainType _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'!
privateSubType: aString
	subType _ aString! !

!MIMEDocument methodsFor: 'private' stamp: 'ls 8/12/1998 00:25'!
privateUrl: aUrl
	url _ aUrl! !


!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:13'!
isGif
	^ self mainType = 'image'
		and: [self subType = 'gif']! !

!MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:15'!
isJpeg
	^ self mainType = 'image'
		and: [self subType = 'jpeg' | (self subType = 'jpg')]! !

!MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:07'!
isMultipart
	^self mainType = 'multipart'! !


!MIMEDocument methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 19:01'!
atomicParts
	self isMultipart ifFalse: [^ OrderedCollection with: self].
	^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! !

!MIMEDocument methodsFor: 'as yet unclassified' stamp: 'ls 4/30/2000 18:45'!
isMultipartAlternative
	"whether the document is in a multipart format where the parts are alternates"
	^ self contentType = 'multipart/alternative'
! !


!MIMEDocument methodsFor: 'converting' stamp: 'ls 6/1/2000 16:24'!
withUrl: newUrl
	"return an identical document except that the URL has been modified"
	^MIMEDocument contentType: self contentType  content: self content url: newUrl! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MIMEDocument class
	instanceVariableNames: ''!

!MIMEDocument class methodsFor: 'initialize-release' stamp: 'bolot 5/5/1999 15:44'!
defaultMIMEdatabase
	| d |
	(d _ Dictionary new)
	at: 'html' put: 'text/html';
	at: 'htm' put: 'text/html';
	at: 'xml' put: 'text/xml';
	at: 'txt' put: 'text/plain';
	at: 'c' put: 'text/plain';
	at: 'gif' put: 'image/gif';
	at: 'jpg' put: 'image/jpeg';
	at: 'jpeg' put: 'image/jpeg';
	at: 'xbm' put: 'image/x-xbitmap';
	at: 'mid' put: 'audio/midi';
	at: 'doc' put: 'application/ms-word-document'.
	^d! !

!MIMEDocument class methodsFor: 'initialize-release' stamp: 'bolot 9/9/1999 15:41'!
extendedMIMEdatabase
	| d |
	(d _ self defaultMIMEdatabase)
	at: 'hqx' put: 'application/mac-binhex40';
	at: 'cpt' put: 'application/mac-compactpro';
	at: 'pdf' put: 'application/pdf';
	at: 'ps' put: 'application/postscript';
	at: 'ai' put: 'application/postscript';
	at: 'eps' put: 'application/postscript';
	at: 'rtf' put: 'text/rtf';
	at: 'bin' put: 'application/octet-stream';
	at: 'dms' put: 'application/octet-stream';
	at: 'lha' put: 'application/octet-stream';
	at: 'lzh' put: 'application/octet-stream';
	at: 'exe' put: 'application/octet-stream';
	at: 'class' put: 'application/octet-stream';
	at: 'zip' put: 'application/zip';
	at: 'gtar' put: 'application/x-gtar';
	at: 'swf' put: 'application/x-shockwave-flash';
	at: 'sit' put: 'application/x-stuffit';
	at: 'tar' put: 'application/x-tar';
	at: 'au' put: 'audio/basic';
	at: 'snd' put: 'audio/basic';
	at: 'mid' put: 'audio/midi';
	at: 'midi' put: 'audio/midi';
	at: 'mpga' put: 'audio/mpeg';
	at: 'mp2' put: 'audio/mpeg';
	at: 'mp3' put: 'audio/mpeg';
	at: 'aiff' put: 'audio/x-aiff';
	at: 'aif' put: 'audio/x-aiff';
	at: 'aifc' put: 'audio/x-aiff';
	at: 'rm' put: 'audio/x-pn-realaudio';
	at: 'ram' put: 'audio/x-pn-realaudio';
	at: 'rpm' put: 'audio/x-pn-realaudio-plugin';
	at: 'ra' put: 'audio/x-realaudio';
	at: 'wav' put: 'audio/x-wav';
	at: 'css' put: 'text/css';
	at: 'mpeg' put: 'video/mpeg';
	at: 'mpg' put: 'video/mpeg';
	at: 'mpe' put: 'video/mpeg';
	at: 'qt' put: 'video/quicktime';
	at: 'mov' put: 'video/quicktime';
	at: 'avi' put: 'video/x-msvideo';
	at: 'movie' put: 'video/x-sgi-movie'.
	^d! !

!MIMEDocument class methodsFor: 'initialize-release' stamp: 'bolot 9/9/1999 16:48'!
readMIMEdatabaseFrom: someStream
	| d line tokens stream |
	"type/subtype    extension"
	"white spaces are separators"
	"apache conf file format: mime.types"

	"must normalize line endings"
	stream _ ReadStream on: someStream contentsOfEntireFile withSqueakLineEndings.

	d _ Dictionary new.
	[(line _ stream nextLine) isNil not]
		whileTrue: [tokens _ line findTokens: ' 	'.
			(tokens size = 2 and: [line first ~= $#])
				ifTrue: [d at: tokens second put: tokens first]].
	^d! !


!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'!
contentTypeFormData
	^'application/x-www-form-urlencoded'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypeHtml
	^'text/html'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'!
contentTypeMultipart
	^'multipart/form-data'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypePlainText
	^'text/plain'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'!
contentTypeXml
	^'text/xml'! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
guessTypeFromExtension: ext
	"guesses a content type from the extension"
	| extension |
	extension _ ext asString.
	(extension includes: $.) ifTrue: [ ^self defaultContentType].

	MIMEdatabase ifNil: [self resetMIMEdatabase].
	^ MIMEdatabase at: extension ifAbsent: [self defaultContentType].! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
guessTypeFromName: url
	"guesses a content type from the url"
	| extension |
	extension _ url asString.
	(extension includes: $.) ifFalse: [ ^self defaultContentType].

	extension _ (extension findTokens: '.') last asLowercase.

	MIMEdatabase ifNil: [self resetMIMEdatabase].
	^ MIMEdatabase at: extension ifAbsent: [self defaultContentType].
! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 9/9/1999 15:21'!
linkExtension: ext toType: mimeType
	MIMEdatabase at: ext asString put: mimeType asString! !

!MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 11/27/1999 14:26'!
resetMIMEdatabase
	MIMEdatabase _ self extendedMIMEdatabase! !


!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'!
content: aString
	^self contentType: self defaultContentType  content: aString! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 8/5/1998 08:00'!
contentType: aString  content: content
	"create a MIMEObject with the given content-type and content"
	"MIMEObject contentType: 'text/plain' content: 'This is a test'"
	
	| ans idx |
	ans _ self new.
	ans privateContent: content.

	"parse the content-type"
	(aString isNil or: [
		idx _ aString indexOf: $/.
		idx = 0]) 
	ifTrue: [ 
		ans privateMainType: 'application'.  
		ans privateSubType: 'octet-stream' ]
	ifFalse: [ 
		ans privateMainType: (aString copyFrom: 1 to: idx-1).
		ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].

	^ans
! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 8/12/1998 00:26'!
contentType: aString  content: content  url: aUrl
	"create a MIMEObject with the given content-type and content"
	"MIMEObject contentType: 'text/plain' content: 'This is a test'"
	
	| ans idx |
	ans _ self new.
	ans privateContent: content.

	"parse the content-type"
	(aString isNil or: [
		idx _ aString indexOf: $/.
		idx = 0]) 
	ifTrue: [ 
		ans privateMainType: 'application'.  
		ans privateSubType: 'octet-stream' ]
	ifFalse: [ 
		ans privateMainType: (aString copyFrom: 1 to: idx-1).
		ans privateSubType: (aString copyFrom: idx+1 to: aString size) ].

	ans privateUrl: aUrl asUrl.

	^ans
! !

!MIMEDocument class methodsFor: 'instance creation' stamp: 'ls 7/23/1998 22:59'!
defaultContentType
	^'application/octet-stream'! !
Object subclass: #MIMEHeaderValue
	instanceVariableNames: 'mainValue parameters '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!

!MIMEHeaderValue methodsFor: 'printing' stamp: 'dvf 4/28/2000 02:48'!
asHeaderValue
	| strm |
	strm _ WriteStream on: (String new: 20).
	strm nextPutAll: mainValue.
	parameters associationsDo: [:e | strm nextPut: $; ; nextPutAll: e key;
		 nextPutAll: '="';
		 nextPutAll: e value , '"'].
	^ strm contents! !


!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:55'!
mainValue
	^mainValue! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'!
mainValue: anObject
	mainValue _ anObject! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:18'!
parameters
	^parameters! !

!MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'!
parameters: anObject
	parameters _ anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MIMEHeaderValue class
	instanceVariableNames: ''!

!MIMEHeaderValue class methodsFor: 'as yet unclassified' stamp: 'dvf 5/13/2000 20:47'!
fromString: aString 
	| parts newValue parms separatorPos parmName parmValue |
	parts _ ReadStream on: (aString findTokens: ';').
	newValue _ self new mainValue: parts next asLowercase.
	parms _ Dictionary new.
	parts do: 
		[:e | 
		separatorPos _ e findAnySubStr: '=' startingAt: 1. 
		separatorPos <= e size
			ifTrue: 
				[parmName _ (e copyFrom: 1 to: separatorPos - 1) withBlanksTrimmed.
				parmValue _ (e copyFrom: separatorPos + 1 to: e size) withBlanksTrimmed withoutQuoting.
				parms at: parmName put: parmValue]].
	newValue parameters: parms.
	^ newValue! !
Object subclass: #MIMEPart
	instanceVariableNames: 'text fields separator parts content '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 19:01'!
atomicParts
	self isMultipart ifFalse: [^OrderedCollection with: self].
	^self parts inject: OrderedCollection new into: [:col :part | col, part atomicParts]! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 17:58'!
content
	content ifNil: [self parse].
	^ content! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 18:40'!
decoderClass
	| encoding |
	encoding _ self fields at: 'content-transfer-encoding' ifAbsent: [^ nil].
	encoding _ encoding mainValue.
	encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter].
	encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter].
	^ nil! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 01:04'!
excerpt
	^ self content withSeparatorsCompacted truncateWithElipsisTo: 30! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 17:57'!
fields
	fields ifNil: [self parse].
	^ fields! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/28/2000 02:50'!
fieldsAsMimeHeader
	| strm |
	strm _ WriteStream on: (String new: 100).
	self fields associationsDo: [:e | strm nextPutAll: e key;
		 nextPutAll: ': ';
		 nextPutAll: e value asHeaderValue;
		 cr]. 
	^ strm contents! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 17:52'!
fieldsFrom: aStream do: aBlock 
	"Invoke the given block with each of the header fields from the given 
	stream. The block arguments are the field name and value."
	| savedLine line s |
	savedLine _ MailDB readStringLineFrom: aStream.
	[aStream atEnd]
		whileFalse: 
			[line _ savedLine.
			line isEmpty ifTrue: [^ self].
			"quit when we hit a blank line"
			
			[savedLine _ MailDB readStringLineFrom: aStream.
			savedLine size > 0 and: [savedLine first isSeparator]]
				whileTrue: 
					["lines starting with white space are continuation lines"
					s _ ReadStream on: savedLine.
					s skipSeparators; skip: -1.
					line _ line , s upToEnd].
			self reportField: line withBlanksTrimmed to: aBlock].
	"process final header line of a body-less message"
	savedLine isEmpty ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 18:33'!
isAttachment
	| field |
	field _ self fields at: 'content-disposition' ifAbsent: [^false].
	^'*attachment*' match: field! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 23:48'!
isMultipart
	^ self mainType = 'multipart'! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 18:35'!
mainType
	| type |
	type _ self fields at: 'content-type' ifAbsent: [^'application'].
	^ (type mainValue findTokens: '/') first! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 18:18'!
name
	| type nameField disposition |
	type _ self fields at: 'content-type' ifAbsent: [].
	(type notNil and: [(nameField _ type parameters at: 'name' ifAbsent: []) notNil])
		ifTrue: [^ nameField].
	disposition _ self fields at: 'content-disposition' ifAbsent: [].
	(disposition notNil and: [(nameField _ disposition parameters at: 'filename' ifAbsent: []) notNil])
		ifTrue: [^ nameField].
	^ nil! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 18:14'!
parse
	| parseStream |
	fields _ Dictionary new.
	parseStream _ ReadStream on: self text.
	self fieldsFrom: parseStream do: [:key :value | fields at: key put: (MIMEHeaderValue fromString: value)].
	content _ parseStream upToEnd! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/28/2000 01:20'!
parseParts
	| parseStream currLine msgStream messages |
	self isMultipart ifFalse: [^ parts _ #()].
	parseStream _ ReadStream on: self content.
	currLine _ ''.
	['--*' match: currLine]
		whileFalse: [currLine _ parseStream nextLine].
	separator _ currLine copy.
	msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator.
	messages _ OrderedCollection new.
	[parseStream atEnd]
		whileFalse: 
			[messages add: msgStream upToEnd.
			msgStream skipThisLine].
	parts _ messages collect: [:e | MIMEPart on: e]! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/28/2000 01:24'!
parts

	parts ifNil: [self parseParts].
	^ parts! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/27/2000 01:05'!
printOn: aStream 
	"For text parts with no filename show: 'text/plain: first line of text...'    
	for attachments/filenamed parts show: 'attachment: filename.ext'"
	| name |
	aStream nextPutAll: ((name _ self name) ifNil: ['Text: ' , self excerpt]
			ifNotNil: ['File: ' , name])! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 17:52'!
reportField: aString to: aBlock 
	"Evaluate the given block with the field name a value in the given 
	field. Do nothing if the field has an empty value part."
	| s fieldName fieldValue |
	s _ ReadStream on: aString.
	fieldName _ (s upTo: $:) asLowercase.
	s skipSeparators.
	s atEnd
		ifFalse: 
			["field is not empty"
			fieldValue _ s upToEnd.
			aBlock value: fieldName value: fieldValue]! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 5/13/2000 23:08'!
save
	| fileName decoder file decoderClass bufferStream |
	(fileName _ self name) ifNil: [fileName _ FillInTheBlank request: 'File name for save?' initialAnswer: 'attachment' , Utilities dateTimeSuffix].
	fileName ifNil: [^ nil].
	file _ FileStream newFileNamed: fileName.
	file binary.
	(decoderClass _ self decoderClass) ifNil: ["decoder not needed or unknown"
		file nextPutAll: self content]
		ifNotNil: 
			[decoder _ decoderClass new.
			bufferStream _ WriteStream on: String new.
			decoder dataStream: bufferStream;
			 mimeStream: (ReadStream on: self content);
			 mimeDecode.
			file nextPutAll: bufferStream contents asByteArray].
	file close ! !

!MIMEPart methodsFor: 'as yet unclassified' stamp: 'dvf 4/28/2000 00:48'!
separator
	separator ifNil: [self parts].
	^ separator! !


!MIMEPart methodsFor: 'accessing' stamp: 'dvf 4/26/2000 17:53'!
text
	^text! !

!MIMEPart methodsFor: 'accessing' stamp: 'dvf 4/26/2000 17:52'!
text: anObject
	text _ anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MIMEPart class
	instanceVariableNames: ''!

!MIMEPart class methodsFor: 'as yet unclassified' stamp: 'dvf 4/26/2000 17:38'!
on: aString
	^self new text: aString! !
MenuMorph subclass: #MVCMenuMorph
	instanceVariableNames: 'done mvcSelection '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MVCMenuMorph commentStamp: '<historical>' prior: 0!
I simulate the MVC menu classes PopUpMenu, SelectionMenu, and CustomMenu when running in a Morphic world. I am also used to implement Utilities>informUser:during:.!


!MVCMenuMorph methodsFor: 'invoking' stamp: 'RAA 6/2/2000 11:05'!
displayAt: aPoint during: aBlock
	"Add this menu to the Morphic world during the execution of the given block."

	Smalltalk isMorphic ifFalse: [^ self].

	Display getCurrentMorphicWorld addMorph: self centeredNear: aPoint.
	self world displayWorld.  "show myself"
	aBlock value.
	self delete! !

!MVCMenuMorph methodsFor: 'invoking' stamp: 'RAA 6/2/2000 11:05'!
informUserAt: aPoint during: aBlock
	"Add this menu to the Morphic world during the execution of the given block."

	| title w |
	Smalltalk isMorphic ifFalse: [^ self].

	title _ submorphs first submorphs first.
	self visible: false.
	w _ Display getCurrentMorphicWorld.
	aBlock value:[:string|
		self visible ifFalse:[
			w addMorph: self centeredNear: aPoint.
			self visible: true].
		title contents: string.
		self setConstrainedPositionFrom: Sensor cursorPoint.
		self changed.
		w displayWorld		 "show myself"
	]. 
	self delete.
	w displayWorld! !

!MVCMenuMorph methodsFor: 'invoking' stamp: 'ar 10/25/2000 19:39'!
invokeAt: aPoint in: aWorld
	"Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu."
	"Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." 
	| w |
	self flag: #bob.		"is <aPoint> global or local?"
	self flag: #arNote.	"<aPoint> is local to aWorld"
	self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld.
	done _ false.
	w _ aWorld outermostWorldMorph. "containing hand"
	[self isInWorld & done not] whileTrue: [w doOneSubCycle].
	self delete.
	^ mvcSelection
! !


!MVCMenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:10'!
cancelValue: selectionOrNil
	"Set the value to be returned if the user cancels without making a selection."

	mvcSelection _ selectionOrNil.
! !

!MVCMenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:16'!
selectMVCItem: item
	"Called by the MenuItemMorph that the user selects.
	Record the selection and set the done flag to end this interaction."

	mvcSelection _ item.
	done _ true.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MVCMenuMorph class
	instanceVariableNames: ''!

!MVCMenuMorph class methodsFor: 'instance creation' stamp: 'ar 9/18/2000 12:16'!
from: aPopupMenu title: titleStringOrNil
	"Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world."

	| menu items lines selections labelString j emphasis |
	menu _ self new.
	titleStringOrNil ifNotNil: [
		titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]].
	labelString _ aPopupMenu labelString.
	items _ labelString asString findTokens: String cr.
	labelString isText ifTrue:
		["Pass along text emphasis if present"
		j _ 1.
		items _ items collect:
			[:item | j _ labelString asString findString: item startingAt: j.
			emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j).
			item asText addAttribute: emphasis]].
	lines _ aPopupMenu lineArray.
	lines ifNil: [lines _ #()].
	menu cancelValue: 0.
	menu defaultTarget: menu.
	selections _ (1 to: items size) asArray.
	1 to: items size do: [:i |
		menu add: (items at: i) selector: #selectMVCItem: argument: (selections at: i).
		(lines includes: i) ifTrue: [menu addLine]].
	^ menu
! !
WiWPasteUpMorph subclass: #MVCWiWPasteUpMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Morphic'!
!MVCWiWPasteUpMorph commentStamp: '<historical>' prior: 0!
A subclass of WiWPasteUpMorph that supports Morphic worlds embedded in MVC Views.!


!MVCWiWPasteUpMorph methodsFor: 'initialization' stamp: 'ar 9/15/2000 23:27'!
viewBox: newViewBox

	| vb |

	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	((vb _ self viewBox) == nil or: [vb ~= newViewBox])
		ifTrue: [worldState canvas: nil].

	worldState viewBox: newViewBox.

	self bounds: newViewBox.		"works better here than simply storing into bounds"
	worldState assuredCanvas.
	"Paragraph problem workaround; clear selections to avoid screen droppings:"
	self flag: #arNote. "Probably unnecessary"
	worldState handsDo: [:h | h releaseKeyboardFocus].
	self fullRepaintNeeded.

! !


!MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 5/24/2000 10:30'!
becomeTheActiveWorldWith: evt

	worldState canvas: nil.	"safer to start from scratch"
	self installFlaps.

! !

!MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 11/25/1999 10:09'!
revertToParentWorldWithEvent: evt

">>unused, but we may want some of this later
	self damageRecorder reset.
	World _ parentWorld.
	World assuredCanvas.
	World installFlaps.
	owner changed.
	hostWindow setStripeColorsFrom: Color red.
	World restartWorldCycleWithEvent: evt.
<<<"

! !


!MVCWiWPasteUpMorph methodsFor: 'drawing' stamp: 'RAA 11/27/2000 10:35'!
invalidRect: damageRect from: aMorph

	worldState ifNil: [^self].
	worldState recordDamagedRect: damageRect
! !


!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/25/1999 09:20'!
position: aPoint
	"Change the position of this morph and and all of its submorphs."

	| delta |
	delta _ aPoint - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	self changed.
	self privateFullMoveBy: delta.
	self changed.
! !

!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 5/24/2000 10:47'!
resetViewBox

	| c |
	(c _ worldState canvas) == nil ifTrue: [^self resetViewBoxForReal].
	c form == Display ifFalse: [^self resetViewBoxForReal].
	c origin = (0@0) ifFalse: [^self resetViewBoxForReal].
	c clipRect extent = self viewBox extent ifFalse: [^self resetViewBoxForReal].
			
! !

!MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/6/2000 17:15'!
resetViewBoxForReal

	self viewBox ifNil: [^self].
	worldState canvas: (
		(Display getCanvas)
			copyOffset:  0@0
			clipRect: self viewBox
	)! !


!MVCWiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/13/2000 11:53'!
worldUnderCursor

        ^self! !
WordArray variableWordSubclass: #MacExternalData
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!MacExternalData commentStamp: '<historical>' prior: 0!
I am a collection of word-aligned external data.  My instances are very helpful for interacting with plugin routines.!


!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 17:24'!
at: index put: datum

	datum >= 0 ifTrue: [^super at: index put: datum].		
	^super at: index put: (16rFFFFFFFF + datum + 1)! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 17:20'!
byteAt: anInteger

	| loc offset |
	loc _ ((anInteger-1) // 4) + 1.
	offset _ 24 - (8*((anInteger-1) \\ 4)).
	^ ((self at: loc) >> offset) bitAnd: 16rFF
! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 17:47'!
byteAt: index put: datum

	| loc offset val |
	(datum > 255 or: [datum<0]) ifTrue: [^self error: 'not a byte quantity'].
	loc _ ((index-1) // 4) + 1.
	offset _ 24 - (8*((index-1) \\ 4)).
	val _ ((16rFF << offset) bitInvert32) bitAnd: (self at: loc).
	val _ val bitOr: (datum<<offset).
	^super at: loc put: val! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 17:56'!
fourBytesAt: anInteger
	"Answer a string corresponding to the word at anInteger, in accordance with Apple's four byte code convention"

	| val |
	val _ self at: anInteger.
	^String streamContents: [:aStream |
		(3 to: 0 by: -1) do: [:i |
			aStream nextPut: (((val >> (i*8)) bitAnd: 16rFF) asCharacter)]]
	! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 17:56'!
fourBytesAt: anInteger put: aString
	"Store a word corresponding to Apple's four byte code convention at anIntger"

	| str |
	aString size > 4 ifTrue: [^self error: 'string too long'].
	str _ aString padded: #right to: 4 with: $ .
	self at: anInteger put: 
		(str inject: 0 into: [:val :each | val * 256 + each asciiValue])! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/12/1999 21:31'!
handleSizeAt: anInteger

	(anInteger < 1 or: [anInteger> self size]) ifTrue: 
		[self error: 'invalid index'].
	^self primGetHandleSize: anInteger - 1! !

!MacExternalData methodsFor: 'accessing' stamp: 'acg 9/23/1999 20:54'!
shortAt: anInteger

	| loc offset |
	loc _ ((anInteger-1) // 2) + 1.
	offset _ 32 - (16*((anInteger-1) \\ 2)).
	^ ((self at: loc) >> offset) bitAnd: 16rFFFF
! !


!MacExternalData methodsFor: 'printing' stamp: 'acg 9/12/1999 17:55'!
printAt: index on: aStream

	aStream 
		nextPutAll: (self at: index) hex8;
		nextPutAll: '(''';
		nextPutAll: (self fourBytesAt: index);
		nextPutAll: ''')'! !

!MacExternalData methodsFor: 'printing' stamp: 'acg 9/20/1999 11:56'!
printOn: aStream

	aStream 
		nextPutAll: self species asString;
		nextPutAll: '('.
	(1 to: self size)
		do: [:i | self printAt: i on: aStream]
		separatedBy: [aStream nextPutAll: '; '].
	aStream nextPut: $)! !


!MacExternalData methodsFor: 'private' stamp: 'acg 9/20/1999 13:54'!
primGetHandleSize: anIndex

	<primitive: 'primGetHandleSize' module: 'TestOSAPlugin'>
	TestOSAPlugin 
		doPrimitive: 'primGetHandleSize'
		withArguments: {anIndex}! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacExternalData class
	instanceVariableNames: ''!

!MacExternalData class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 22:08'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asNamedPtr: self asString
		from: anInteger
		andThen: (cg ccgValBlock: 'isWordsOrBytes')! !

!MacExternalData class methodsFor: 'as yet unclassified' stamp: 'acg 9/25/1999 14:55'!
ccgDeclareCForVar: aSymbolOrString

	^self asString, ' *', aSymbolOrString! !

!MacExternalData class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 14:53'!
fromValue: aNumber

	^(super new: 1) at: 1 put: aNumber; yourself! !
FileDirectory subclass: #MacFileDirectory
	instanceVariableNames: ''
	classVariableNames: 'TypeToMimeMappings '
	poolDictionaries: ''
	category: 'System-Files'!
!MacFileDirectory commentStamp: '<historical>' prior: 0!
I represent a Macintosh FileDirectory.
!


!MacFileDirectory methodsFor: 'file operations' stamp: 'ar 2/2/2001 13:08'!
mimeTypesFor: fileName
	"Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type"
	| typeCreator type | 
	typeCreator _ self getMacFileTypeAndCreator: ((self fullNameFor: fileName)).
	type _ (typeCreator at: 1) asLowercase.
	^TypeToMimeMappings at: type ifAbsent:[super mimeTypesFor: fileName]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacFileDirectory class
	instanceVariableNames: ''!

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'di 5/11/1999 08:53'!
isCaseSensitive
	"Mac OS ignores the case of file names"
	^ false! !

!MacFileDirectory class methodsFor: 'platform specific' stamp: 'jm 12/4/97 22:57'!
pathNameDelimiter

	^ $:
! !


!MacFileDirectory class methodsFor: 'class initialization' stamp: 'ar 2/2/2001 13:10'!
initializeTypeToMimeMappings
	"MacFileDirectory initializeTypeToMimeMappings"
	TypeToMimeMappings _ Dictionary new.
	#(
		"format"
		"(abcd		('image/gif'))"
	) do:[:spec|
		TypeToMimeMappings at: spec first asString put: spec last.
	].
! !
ExternalStructure subclass: #MacPixPatPtr
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-MacOS'!

!MacPixPatPtr methodsFor: 'initialize-release' stamp: 'ar 1/25/2000 11:50'!
dispose
	handle == nil ifFalse:[
		self apiDisposePixPat: self.
		handle _ nil.
	].! !


!MacPixPatPtr methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:59'!
makeRGBPattern: aColor
	^self apiMakeRGBPat: self with: (MacRGBColor fromColor: aColor)! !


!MacPixPatPtr methodsFor: 'api calls' stamp: 'ar 1/25/2000 11:50'!
apiDisposePixPat: aPixPat
	<apicall: void 'DisposePixPat' (MacPixPatPtr*) module:'InterfaceLib'>
	^self externalCallFailed! !

!MacPixPatPtr methodsFor: 'api calls' stamp: 'ar 1/25/2000 12:05'!
apiMakeRGBPat: aPixPat with: aRGBColor
	<apicall: void 'MakeRGBPat' (MacPixPatPtr* MacRGBColor*) module: 'InterfaceLib'>
	^self externalCallFailed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacPixPatPtr class
	instanceVariableNames: ''!

!MacPixPatPtr class methodsFor: 'field definition' stamp: 'ar 1/27/2000 01:08'!
fields
	"MacPixPatPtr defineFields"
	"The following really means
		typedef void* MacPixPatPtr;
	"
	^#(nil 'void*') "For now this is just an opaque handle"! !


!MacPixPatPtr class methodsFor: 'instance creation' stamp: 'ar 1/27/2000 01:04'!
newPixPat
	<apicall: MacPixPatPtr* 'NewPixPat' (void) module:'InterfaceLib'>
	^self externalCallFailed! !
ExternalStructure subclass: #MacPoint
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-MacOS'!

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:34'!
getMousePoint
	^self apiGetMousePoint: self! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:38'!
h
	"This method was automatically generated"
	^handle signedShortAt: 3! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:38'!
h: anObject
	"This method was automatically generated"
	handle signedShortAt: 3 put: anObject! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:38'!
v
	"This method was automatically generated"
	^handle signedShortAt: 1! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:38'!
v: anObject
	"This method was automatically generated"
	handle signedShortAt: 1 put: anObject! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:39'!
x
	^self h! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:39'!
x: anObject
	^self h: anObject! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:39'!
y
	^self v! !

!MacPoint methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:39'!
y: anObject
	^self v: anObject! !


!MacPoint methodsFor: 'api calls' stamp: 'ar 1/25/2000 00:34'!
apiGetMousePoint: aMacPoint
	<apicall: void 'GetMouse' (MacPoint*) module:'InterfaceLib'>
	^self externalCallFailed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacPoint class
	instanceVariableNames: ''!

!MacPoint class methodsFor: 'field definition' stamp: 'ar 1/25/2000 12:15'!
fields
	"MacPoint defineFields"
	^#(
		(v	'short')
		(h	'short')
	)! !


!MacPoint class methodsFor: 'examples' stamp: 'ar 1/25/2000 16:57'!
lineTo: aPoint
	"MacPoint moveTo: 0@0; lineTo: 100@100"
	^self apiLineTo: aPoint x with: aPoint y
! !

!MacPoint class methodsFor: 'examples' stamp: 'ar 1/28/2000 17:50'!
macDraw
	"MacPoint macDraw"
	| pt |
	pt _ self new.
	pt getMousePoint.
	self moveTo: pt.
	[Sensor anyButtonPressed] whileFalse:[
		pt getMousePoint.
		self lineTo: pt.
	].
	Display forceToScreen.! !

!MacPoint class methodsFor: 'examples' stamp: 'ar 1/25/2000 16:56'!
moveTo: aPoint
	"MacPoint moveTo: 0@0; lineTo: 100@100"
	^self apiMoveTo: aPoint x with: aPoint y
! !


!MacPoint class methodsFor: 'api calls' stamp: 'ar 1/25/2000 00:33'!
apiLineTo: x with: y
	<apicall: void 'LineTo' (short short) module:'InterfaceLib'>
	^self externalCallFailed! !

!MacPoint class methodsFor: 'api calls' stamp: 'ar 1/25/2000 00:33'!
apiMoveTo: x with: y
	<apicall: void 'MoveTo' (short short) module:'InterfaceLib'>
	^self externalCallFailed! !
ExternalStructure subclass: #MacRGBColor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-MacOS'!

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
blue
	"This method was automatically generated"
	^handle unsignedShortAt: 5! !

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
blue: anObject
	"This method was automatically generated"
	handle unsignedShortAt: 5 put: anObject! !

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
green
	"This method was automatically generated"
	^handle unsignedShortAt: 3! !

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
green: anObject
	"This method was automatically generated"
	handle unsignedShortAt: 3 put: anObject! !

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
red
	"This method was automatically generated"
	^handle unsignedShortAt: 1! !

!MacRGBColor methodsFor: 'accessing' stamp: 'ar 1/25/2000 00:59'!
red: anObject
	"This method was automatically generated"
	handle unsignedShortAt: 1 put: anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacRGBColor class
	instanceVariableNames: ''!

!MacRGBColor class methodsFor: 'field definition' stamp: 'ar 1/25/2000 00:59'!
fields
	"MacRGBColor defineFields"
	^#(
		(red 'ushort')
		(green 'ushort')
		(blue 'ushort')
	)! !


!MacRGBColor class methodsFor: 'instance creation' stamp: 'ar 1/25/2000 12:12'!
fromColor: aColor
	^(self new)
		red: (aColor red * 16rFFFF) rounded;
		green: (aColor green * 16rFFFF) rounded;
		blue: (aColor blue * 16rFFFF) rounded;
		yourself! !
ExternalStructure subclass: #MacRect
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-MacOS'!

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
bottom
	"This method was automatically generated"
	^handle signedShortAt: 5! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
bottom: anObject
	"This method was automatically generated"
	handle signedShortAt: 5 put: anObject! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
left
	"This method was automatically generated"
	^handle signedShortAt: 3! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
left: anObject
	"This method was automatically generated"
	handle signedShortAt: 3 put: anObject! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
right
	"This method was automatically generated"
	^handle signedShortAt: 7! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
right: anObject
	"This method was automatically generated"
	handle signedShortAt: 7 put: anObject! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
top
	"This method was automatically generated"
	^handle signedShortAt: 1! !

!MacRect methodsFor: 'accessing' stamp: 'ar 1/25/2000 11:57'!
top: anObject
	"This method was automatically generated"
	handle signedShortAt: 1 put: anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacRect class
	instanceVariableNames: ''!

!MacRect class methodsFor: 'field definition' stamp: 'ar 1/25/2000 11:57'!
fields
	"MacRect defineFields"
	^#(
		(top 'short')
		(left 'short')
		(bottom 'short')
		(right 'short')
	)! !


!MacRect class methodsFor: 'examples' stamp: 'ar 1/28/2000 17:50'!
coloredEllipses "MacRect coloredEllipses"
	| rnd w h colors n r pat v0 v1 |
	colors _ Color colorNames collect:[:cName| (Color perform: cName)].
	"convert to PixPats"
	colors _ colors collect:[:c| MacPixPatPtr newPixPat makeRGBPattern: c].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	n _ 0.
	r _ MacRect new.
	[Sensor anyButtonPressed] whileFalse:[
		pat _ colors atRandom.
		v0 _ (rnd next * w) asInteger.
		v1 _ (rnd next * w) asInteger.
		v0 < v1 ifTrue:[r left: v0; right: v1] ifFalse:[r left: v1; right: v0].
		v0 _ (rnd next * h) asInteger.
		v1 _ (rnd next * h) asInteger.
		v0 < v1 ifTrue:[r top: v0; bottom: v1] ifFalse:[r top: v1; bottom: v0].
		self apiFillCOval: r with: pat.
		self apiFrameOval: r.
		n _ n + 1.
		(n \\ 10) = 0 ifTrue:[n printString displayAt: 0@0].
	].
	colors do:[:c| c dispose].
	Display forceToScreen.! !

!MacRect class methodsFor: 'examples' stamp: 'ar 1/28/2000 17:50'!
coloredRectangles "MacRect coloredRectangles"
	| rnd w h colors n r pat v0 v1 nPixels time |
	colors _ Color colorNames collect:[:cName| (Color perform: cName)].
	"convert to PixPats"
	colors _ colors collect:[:c| MacPixPatPtr newPixPat makeRGBPattern: c].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	n _ 0.
	r _ MacRect new.
	nPixels _ 0.
	time _ Time millisecondClockValue.
	[Sensor anyButtonPressed] whileFalse:[
		pat _ colors atRandom.
		v0 _ (rnd next * w) asInteger.
		v1 _ (rnd next * w) asInteger.
		v0 < v1 ifTrue:[r left: v0; right: v1] ifFalse:[r left: v1; right: v0].
		v0 _ (rnd next * h) asInteger.
		v1 _ (rnd next * h) asInteger.
		v0 < v1 ifTrue:[r top: v0; bottom: v1] ifFalse:[r top: v1; bottom: v0].
		self apiFillCRect: r with: pat.
		self apiFrameRect: r.
		n _ n + 1.
		nPixels _ nPixels + ((r right - r left) * (r bottom - r top)).
		(n \\ 100) = 0 ifTrue:[
			'Pixel fillRate: ', (nPixels * 1000 // (Time millisecondClockValue - time))
				asStringWithCommas displayAt: 0@0].
	].
	colors do:[:c| c dispose].
	Display forceToScreen.! !

!MacRect class methodsFor: 'examples' stamp: 'ar 1/28/2000 19:42'!
macDraw
	"MacRect macDraw"
	^MacPoint macDraw! !


!MacRect class methodsFor: 'api calls' stamp: 'ar 1/25/2000 12:06'!
apiFillCOval: r with: pat
	<apicall: void 'FillCOval' (MacRect* MacPixPatPtr*) module:'InterfaceLib'>
	^self externalCallFailed! !

!MacRect class methodsFor: 'api calls' stamp: 'ar 1/25/2000 12:04'!
apiFillCRect: r with: pat
	<apicall: void 'FillCRect' (MacRect* MacPixPatPtr*) module:'InterfaceLib'>
	^self externalCallFailed! !

!MacRect class methodsFor: 'api calls' stamp: 'ar 1/25/2000 12:08'!
apiFrameOval: r
	<apicall: void 'FrameOval' (MacRect*) module:'InterfaceLib'>
	^self externalCallFailed! !

!MacRect class methodsFor: 'api calls' stamp: 'ar 1/25/2000 12:16'!
apiFrameRect: r
	<apicall: void 'FrameRect' (MacRect*) module:'InterfaceLib'>
	^self externalCallFailed! !
BorderedMorph subclass: #MagnifierMorph
	instanceVariableNames: 'magnification trackPointer lastPos srcExtent '
	classVariableNames: 'RecursionLock '
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!MagnifierMorph commentStamp: '<historical>' prior: 0!
Provides a magnifying glass. Magnifies the morphs below (if grabbed) or the area around the mouse pointer.!


!MagnifierMorph methodsFor: 'initialization' stamp: 'bf 9/20/1999 15:54'!
initialize
	super initialize.
	trackPointer _ true.
	magnification _ 2.
	color _ Color black.
	borderWidth _ 1.
	lastPos _ self sourcePoint.
	self extent: 128@128.

! !


!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:31'!
borderWidth: anInteger
	"Grow outwards preserving innerBounds"
	| c |  
	c _ self center.
	super borderWidth: anInteger.
	super extent: self defaultExtent.
	self center: c.! !

!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:22'!
defaultExtent
	^(srcExtent * magnification) truncated + (2 * borderWidth)! !

!MagnifierMorph methodsFor: 'geometry' stamp: 'bf 9/21/1999 09:23'!
extent: aPoint
	"Round to multiples of magnification"
	srcExtent _ (aPoint - (2 * borderWidth)) // magnification.
	^super extent: self defaultExtent! !


!MagnifierMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:06'!
drawOn: aCanvas
	super drawOn: aCanvas.		"border and fill"
	aCanvas isShadowDrawing ifFalse: [
		"Optimize because #magnifiedForm is expensive"
		aCanvas paintImage: self magnifiedForm at: self innerBounds origin]! !

!MagnifierMorph methodsFor: 'drawing' stamp: 'bf 9/21/1999 08:51'!
hasTranslucentColor
	"I may show what's behind me, so tell the hand to don't cache"
	^self sourceRect intersects: self bounds! !


!MagnifierMorph methodsFor: 'stepping' stamp: 'di 9/28/1999 07:57'!
step
	self changed! !

!MagnifierMorph methodsFor: 'stepping' stamp: 'di 9/28/1999 07:57'!
stepTime
	^ 0! !


!MagnifierMorph methodsFor: 'events' stamp: 'bf 9/18/1999 20:42'!
handlesMouseDown: evt
	^evt yellowButtonPressed
		or: [super handlesMouseDown: evt]! !

!MagnifierMorph methodsFor: 'events' stamp: 'bf 9/21/1999 10:45'!
mouseDown: evt
	evt yellowButtonPressed
		ifTrue: [self chooseMagnification: evt]
		ifFalse: [super mouseDown: evt]! !


!MagnifierMorph methodsFor: 'menu' stamp: 'di 9/28/1999 23:06'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu
		addLine;
		add: 'magnification...' action: #chooseMagnification;
		addUpdating: #trackingPointerString action: #toggleTrackingPointer;
		addUpdating: #toggleRoundString action: #toggleRoundness.! !

!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/28/1999 16:22'!
chooseMagnification
	| result |
	result _ (SelectionMenu selections: #(1.5 2 4 8))
		startUpWithCaption: 'Choose magnification
(currently ', magnification printString, ')'.
	(result == nil or: [result = magnification]) ifTrue: [^ self].
	magnification _ result.
	self extent: self extent. "round to new magnification"
	self changed. "redraw even if extent wasn't changed".! !

!MagnifierMorph methodsFor: 'menu' stamp: 'di 8/24/2000 14:02'!
chooseMagnification: evt
	| handle origin aHand currentMag |
	currentMag _ magnification.
	aHand _ evt ifNil: [self currentHand] ifNotNil: [evt hand].
	origin _ aHand position y.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | self magnification: (newPoint y - origin) / 8.0 + currentMag].
	aHand attachMorph: handle.
	handle startStepping.
	self changed. "Magnify handle"! !

!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/20/1999 15:48'!
toggleTrackingPointer
	trackPointer _ trackPointer not! !

!MagnifierMorph methodsFor: 'menu' stamp: 'bf 9/20/1999 15:49'!
trackingPointerString
	^trackPointer
		ifTrue: ['stop tracking pointer']
		ifFalse: ['start tracking pointer']! !


!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 9/21/1999 12:27'!
magnification: aNumber
	| c |  
	magnification _ aNumber min: 8 max: 0.5.
	magnification _ magnification roundTo:
		(magnification < 3 ifTrue: [0.5] ifFalse: [1]).
	srcExtent _ srcExtent min: (512@512) // magnification. "to prevent accidents"
	c _ self center.
	super extent: self defaultExtent.
	self center: c.! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 1/5/2000 18:25'!
magnifiedForm
	| srcRect form exclusion |
	lastPos _ self sourcePoint.
	srcRect _ self sourceRectFrom: lastPos.
	((srcRect intersects: self bounds) and: [ RecursionLock == nil ])
		ifTrue: [RecursionLock _ self.
				self isRound
					ifTrue: [exclusion _ owner]
					ifFalse: [exclusion _ self].
				form _ self world patchAt: srcRect without: exclusion andNothingAbove: false.
				RecursionLock _ nil]
		ifFalse: ["cheaper method if the source is not occluded"
				form _ Display copy: srcRect].
	"smooth if non-integer scale"
	^ form magnify: form boundingBox
		by: magnification
		smoothing: (magnification isInteger ifTrue: [1] ifFalse: [2])! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 11/1/2000 16:02'!
sourcePoint
	"If we are being dragged use our center, otherwise use pointer position"
	^(trackPointer not or: [owner notNil and: [owner isHandMorph]])
		ifTrue: [self center]
		ifFalse: [self currentHand position]! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'bf 9/21/1999 08:47'!
sourceRect
	^self sourceRectFrom: self sourcePoint
! !

!MagnifierMorph methodsFor: 'magnifying' stamp: 'di 12/17/1999 13:42'!
sourceRectFrom: aPoint
	^ (aPoint extent: srcExtent) translateBy: (srcExtent // -2) + 1.
! !


!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:01'!
isRound

	^ owner isMemberOf: ScreeningMorph! !

!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:17'!
toggleRoundString
	^ self isRound
		ifTrue: ['be square']
		ifFalse: ['be round']! !

!MagnifierMorph methodsFor: 'round view' stamp: 'di 9/28/1999 23:16'!
toggleRoundness
	| sm w |
	w _ self world.
	self isRound
		ifTrue: [owner delete.
				w addMorph: self]
		ifFalse: [sm _ ScreeningMorph new position: self position.
				sm addMorph: self.
				sm addMorph: (EllipseMorph newBounds: self bounds).
				w addMorph: sm]! !
Object subclass: #Magnitude
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Magnitudes'!
!Magnitude commentStamp: '<historical>' prior: 0!
I am an abstract representation of objects that measure something linear. Examples are dates, times, and numbers.!


!Magnitude methodsFor: 'comparing'!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not! !

!Magnitude methodsFor: 'comparing'!
= aMagnitude 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self! !

!Magnitude methodsFor: 'comparing'!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^(self < aMagnitude) not! !

!Magnitude methodsFor: 'comparing'!
between: min and: max 
	"Answer whether the receiver is less than or equal to the argument, max, 
	and greater than or equal to the argument, min."

	^self >= min and: [self <= max]! !

!Magnitude methodsFor: 'comparing'!
hash
	"Hash must be redefined whenever = is redefined."

	^self subclassResponsibility! !

!Magnitude methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Magnitude methodsFor: 'testing'!
max: aMagnitude 
	"Answer the receiver or the argument, whichever has the greater 
	magnitude."

	self > aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude methodsFor: 'testing'!
min: aMagnitude 
	"Answer the receiver or the argument, whichever has the lesser 
	magnitude."

	self < aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]! !

!Magnitude methodsFor: 'testing'!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !
Object subclass: #MailAddressParser
	instanceVariableNames: 'tokens addresses curAddrTokens '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressParser commentStamp: '<historical>' prior: 0!
Parse mail addresses.  The basic syntax is:

	addressList := MailAddressParser addressesIn: aString

This currently only returns the bare addresses, but it could also return a list of the address "source codes".  For example, if you give it "Joe <joe@foo>, <jane>", it will currently return a list ('joe@foo' 'jane').  It would be nice to also get a list ('Joe <joe@foo>'  '<jane>').!


!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:31'!
addToAddress
	"add the last token to the address.  removes the token from the collection"
	curAddrTokens addFirst: (tokens removeLast)! !

!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'!
finishAddress
	"we've finished one address.  Bundle it up and add it to the list of addresses"
	| address |

	address _ String streamContents: [ :str |
		curAddrTokens do: [ :tok | str nextPutAll: tok text ] ].

	addresses addFirst: address.

	curAddrTokens _ nil.! !

!MailAddressParser methodsFor: 'building address list' stamp: 'ls 9/13/1998 01:30'!
startNewAddress
	"set up data structures to begin a new address"
	(curAddrTokens ~~ nil) ifTrue: [
		self error: 'starting new address before finishing the last one!!' ].

	curAddrTokens _ OrderedCollection new.
	! !


!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'!
grabAddressWithRoute
	"grad an address of the form 'Descriptive Text <real.address@c.d.e>"
	
	self startNewAddress.

	tokens removeLast.	"remove the >"

	"grab until we see a $<"
	[ 
		tokens isEmpty ifTrue: [
			self error: '<> are not matched' ].
		tokens last type = $<
	] whileFalse: [ self addToAddress ].

	tokens removeLast.  "remove the <"


	self removePhrase.

	self finishAddress! !

!MailAddressParser methodsFor: 'parsing' stamp: 'bf 3/12/2000 20:06'!
grabAddresses
	"grab all the addresses in the string"
	| token |
	"remove comments"
	tokens removeAllSuchThat: [:t | t type == #Comment].
	"grab one address or address group each time through this loop"
	[ 
		"remove commas"
		[
			tokens isEmpty not and: [ tokens last type = $, ]
		] whileTrue: [ tokens removeLast ].

		"check whether any tokens are left"
		tokens isEmpty 
	] whileFalse: [
		token _ tokens last.

		"delegate, depending on what form the address is in"
		"the from can be determined from the last token"

		token type = $> ifTrue: [
			self grabAddressWithRoute ]
		ifFalse: [ 
			(#(Atom DomainLiteral QuotedString) includes: token type)  ifTrue: [
				self grabBasicAddress ]
		ifFalse: [
			token type = $; ifTrue: [
				self grabGroupAddress ]
		ifFalse: [
			^self error: 'un-recognized address format' ] ] ]
	].

	^addresses! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 10/23/1998 13:39'!
grabBasicAddress
	"grad an address of the form a.b@c.d.e"
	self startNewAddress.
	"grab either the domain if specified, or the domain if not"
	self addToAddress.
	[tokens isEmpty not and: [ tokens last type = $.] ] 
		whileTrue: 
			["add name-dot pairs of tokens"
			self addToAddress.
			(#(Atom QuotedString ) includes: tokens last type)
				ifFalse: [self error: 'bad token in address: ' , tokens last text].
			self addToAddress].
	(tokens isEmpty or: [tokens last type ~= $@])
		ifTrue: ["no domain specified"
			self finishAddress]
		ifFalse: 
			["that was the domain.  check that no QuotedString's slipped in"
			curAddrTokens do: [:tok | tok type = #QuotedString ifTrue: [self error: 'quote marks are not allowed within a domain name (' , tok text , ')']].
			"add the @ sign"
			self addToAddress.
			"add the local part"
			(#(Atom QuotedString ) includes: tokens last type)
				ifFalse: [self error: 'invalid local part for address: ' , tokens last text].
			self addToAddress.
			"add word-dot pairs if there are any"
			[tokens isEmpty not and: [tokens last type = $.]]
				whileTrue: 
					[self addToAddress.
					(tokens isEmpty not and: [#(Atom QuotedString ) includes: tokens last type])
						ifTrue: [self addToAddress]].
			self finishAddress]! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:07'!
grabGroupAddress
	"grab an address of the form 'phrase : address, address, ..., address;'"
	"I'm not 100% sure what this format means, so I'm just returningthe list of addresses between the : and ;   -ls  (if this sounds right to someone, feel free to remove this comment :)"

	"remove the $; "
	tokens removeLast.

	"grab one address each time through this loop"
	[ 
		"remove commas"
		[
			tokens isEmpty not and: [ tokens last type = $, ]
		] whileTrue: [ tokens removeLast ].

		tokens isEmpty ifTrue: [
			"no matching :"
			^self error: 'stray ; in address list'. ].

		tokens last type = $:
	] whileFalse: [
		"delegate to either grabAddressWithRoute, or grabBasicAddress.  nested groups are not allowed"

		tokens last type = $> ifTrue: [
			self grabAddressWithRoute ]
		ifFalse: [ 
			(#(Atom DomainLiteral QuotedString) includes: tokens last type)  ifTrue: [
				self grabBasicAddress ]
		ifFalse: [
			^self error: 'un-recognized address format' ] ]
	].

	tokens removeLast.   "remove the :"

	self removePhrase.! !

!MailAddressParser methodsFor: 'parsing' stamp: 'ls 9/13/1998 02:08'!
removePhrase
	"skip most characters to the left of this"

	[
		tokens isEmpty not and: [
			#(Atom QuotedString $. $@) includes: (tokens last type) ]
	] whileTrue: [ tokens removeLast ].
! !


!MailAddressParser methodsFor: 'private-initialization' stamp: 'ls 9/13/1998 01:25'!
initialize: tokenList
	tokens _ tokenList asOrderedCollection copy.
	addresses _ OrderedCollection new.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailAddressParser class
	instanceVariableNames: ''!

!MailAddressParser class methodsFor: 'examples' stamp: 'ls 9/13/1998 02:08'!
example
	"test out several correct formats"

	"MailAddressParser example"

	^self addressesIn: 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address <joe5@address>, joe.(annoying (nested) comment)literal@[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;,  Lex''s email account <lex>'! !


!MailAddressParser class methodsFor: 'parsing' stamp: 'ls 9/13/1998 01:34'!
addressesIn: aString
	"return a collection of the bare addresses listed in aString"
	| tokens |
	tokens _ MailAddressTokenizer tokensIn: aString.
	^(self new initialize: tokens) grabAddresses! !
Object subclass: #MailAddressToken
	instanceVariableNames: 'type text '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressToken commentStamp: '<historical>' prior: 0!
a single token from an RFC822 mail address.  Used internally in MailAddressParser!


!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'!
text
	^text! !

!MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'!
type
	^type! !


!MailAddressToken methodsFor: 'private' stamp: 'ls 9/12/1998 20:24'!
type: type0  text: text0
	type _ type0.
	text _ text0.! !


!MailAddressToken methodsFor: 'printing' stamp: 'ls 9/12/1998 20:40'!
printOn: aStream
	aStream nextPut: $[.
	aStream nextPutAll: self type asString.
	aStream nextPut: $|.
	aStream nextPutAll: self text.
	aStream nextPut: $].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailAddressToken class
	instanceVariableNames: ''!

!MailAddressToken class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:31'!
type: type  text: text
	^self new type: type text: text! !
Stream subclass: #MailAddressTokenizer
	instanceVariableNames: 'cachedToken text pos '
	classVariableNames: 'CSNonAtom CSNonSeparators CSParens CSSpecials '
	poolDictionaries: ''
	category: 'Network-RFC822'!
!MailAddressTokenizer commentStamp: '<historical>' prior: 0!
Divides an address into tokens, as specified in RFC 822.  Used by MailAddressParser.!


!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'!
atEndOfChars
	^pos > text size! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'!
nextAtom
	| start end |
	start _ pos.
	pos _ text indexOfAnyOf: CSNonAtom startingAt: start ifAbsent: [ text size + 1].
	end _ pos - 1.
	^MailAddressToken
		type: #Atom
		text: (text copyFrom: start to: end)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:52'!
nextChar
	self atEndOfChars ifTrue: [ ^nil ].
	pos _ pos + 1.
	^text at: (pos-1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'bf 3/12/2000 19:59'!
nextComment
	| start nestLevel paren |
	start _ pos.
	pos _ pos + 1.
	nestLevel _ 1.

	[ nestLevel > 0 ] whileTrue: [
		pos _ text indexOfAnyOf: CSParens startingAt: pos  ifAbsent: [ 0 ].
		pos = 0 ifTrue: [ 
			self error: 'unterminated comment.  ie, more (''s than )''s' ].

		paren _ self nextChar.
		paren = $( ifTrue: [ nestLevel _ nestLevel + 1 ] ifFalse: [ nestLevel _ nestLevel - 1 ]].
	^ MailAddressToken type: #Comment
		text: (text copyFrom: start to: pos + 1)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/13/1998 01:39'!
nextDomainLiteral
	| start end |
	start _ pos.
	end _ text indexOf: $] startingAt: start ifAbsent: [ 0 ].
	end = 0 ifTrue: [
		"not specified"
		self error: 'saw [ without a matching ]' ].

	pos _ end+1.

	^MailAddressToken
		type: #DomainLiteral
		text: (text copyFrom: start to: end)! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:51'!
nextQuotedString
	| res c |
	res _ WriteStream on: String new.
	res nextPut: self nextChar.   "record the starting quote"
	[ self atEndOfChars ] whileFalse: [
		c _ self nextChar.
		c = $\ ifTrue: [
			res nextPut: c.
			res nextPut: self nextChar ]
		ifFalse: [
			c = $" ifTrue: [
				res nextPut: c.
				^MailAddressToken type: #QuotedString  text: res contents ]
			ifFalse: [
				res nextPut: c ] ] ].

	"hmm, never saw the final quote mark"
	^MailAddressToken type: #QuotedString  text: (res contents, '"')! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:44'!
nextSpecial
	| c |
	c _ self nextChar.
	^MailAddressToken type: c  text: c asString.! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'bf 3/12/2000 19:53'!
nextToken
	| c |
	self skipSeparators.
	c _ self peekChar.
	c ifNil: [ ^nil ].
	c = $( ifTrue: [ ^self nextComment ].
	c = $" ifTrue: [ ^self nextQuotedString ].
	c = $[ ifTrue: [ ^self nextDomainLiteral ].
	(CSSpecials includes: c) ifTrue: [ ^self nextSpecial ].
	^self nextAtom! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:15'!
peekChar
	^text at: pos ifAbsent: [ nil ]! !

!MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'ls 9/12/1998 20:14'!
skipSeparators
	pos _ text indexOfAnyOf: CSNonSeparators  startingAt: pos  ifAbsent: [ text size + 1 ].! !


!MailAddressTokenizer methodsFor: 'initialization' stamp: 'ls 9/12/1998 20:13'!
initialize: aString
	text _ aString.
	pos _ 1.! !


!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'!
atEnd
	^self peek == nil! !

!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:51'!
next
	| ans |
	cachedToken ifNil: [ ^self nextToken ].
	ans _ cachedToken.
	cachedToken _ nil.
	^ans! !

!MailAddressTokenizer methodsFor: 'stream protocol' stamp: 'ls 9/12/1998 20:53'!
peek
	cachedToken ifNil: [ cachedToken _ self nextToken. ].
	
	^cachedToken	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailAddressTokenizer class
	instanceVariableNames: ''!

!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:54'!
forString: aString
	^super basicNew initialize: aString! !

!MailAddressTokenizer class methodsFor: 'instance creation' stamp: 'ls 9/13/1998 01:34'!
tokensIn: aString
	"return a collection of the tokens in aString"
	^(self forString: aString) upToEnd! !


!MailAddressTokenizer class methodsFor: 'class initialization' stamp: 'mdr 1/24/2000 10:51'!
initialize
	"Initalize class variables using   MailAddressTokenizer initialize"

	| skipCharacters |

	CSParens _ CharacterSet empty.
	CSParens addAll: '()'.

	CSSpecials _ CharacterSet empty.
	CSSpecials addAll: '()<>@,;:\".[]'.

	skipCharacters _ CharacterSet separators.
	0 to: 31 do: [ :c |
		skipCharacters add: (Character value: c) ].
	skipCharacters add: (Character value: 127).

	CSNonSeparators _ skipCharacters complement.

	CSNonAtom _ skipCharacters addAll: CSSpecials.

! !
Model subclass: #MailDB
	instanceVariableNames: 'rootFilename messageFile indexFile categoriesFile '
	classVariableNames: 'LastID '
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MailDB commentStamp: '<historical>' prior: 0!
I am the in-memory representation of a Celeste mail database. A mail database named "current" consists of three files:

	current.messages	-- an append-only file containing the full content of all messages
	current.index		-- an index of all messages in the messages file that maps unique
						   message ID's to index entries containing some header information
						   and the offset of the full message in the .messages file
	current.categories	-- maps category names to collections of message ID's

Each open mail database has a MailDB object that manages these three files. Operations such as fetching a message given its unique ID and finding out which messages are in which category are supported by the MailDB object. It also supports incorporating new messages (reading mail), message editing and deletions, and message file compaction and recovery.
!


!MailDB methodsFor: 'initialize-release' stamp: 'dvf 5/1/2000 20:14'!
close
	"Save and close the messageFile."
	self consolidateDB.
	messageFile notNil ifTrue: [messageFile close].
	rootFilename _ nil.
	messageFile _ indexFile _ categoriesFile _ nil! !

!MailDB methodsFor: 'initialize-release'!
openOn: rootNameString
	"Open a mail database with the given root file name."

	| status |
	rootFilename _ rootNameString.
	status _ self dbStatus.
	messageFile _ indexFile _ categoriesFile _ nil.
	(status = #exists) ifTrue: [^self openDB].
	(status = #partialDatabase) ifTrue: [^self recoverDB].
	(status = #doesNotExist) ifTrue: [^self createDB].! !


!MailDB methodsFor: 'open-create-save' stamp: 'dvf 5/1/2000 20:13'!
consolidateDB
	"Write all database files to disk."
	rootFilename notNil
		ifTrue: [Transcript show: 'Saving mail database ''' , rootFilename , '''...']
		ifFalse: [Transcript show: 'Saving mail database...'].
	messageFile notNil ifTrue: [messageFile save].
	indexFile notNil ifTrue: [indexFile save].
	categoriesFile notNil ifTrue: [categoriesFile save].
	Transcript show: 'Done.';
	 cr! !

!MailDB methodsFor: 'open-create-save'!
createDB
	"Create a new mail database."

	(self confirm:
'Shall I create a new mail database
named: ', rootFilename, '?')
		ifFalse:	"abort create operation"
			[rootFilename _ nil.
			 self release.
			^nil].
	self openDB.							"creates new DB files"
	self saveDB.							"save the new mail database to disk"! !

!MailDB methodsFor: 'open-create-save' stamp: 'jm 10/12/1998 13:53'!
dbStatus
	"See if my database exists. Since the database has several components, the answer is one of:
	#exists				all files exist
	#partialDatabase	only some of the files exist
	#doesNotExist		none of the files exist"

	| dir localName |
	dir _ FileDirectory forFileName: rootFilename.
	localName _ FileDirectory localNameFor: rootFilename.
	messageFile _ dir includesKey: localName, '.messages'.
	indexFile _ dir includesKey: localName, '.index'.
	categoriesFile _ dir includesKey: localName, '.categories'.
	(messageFile & indexFile & categoriesFile) ifTrue: [^ #exists].
	(messageFile | indexFile | categoriesFile) ifFalse: [^ #doesNotExist].
	^ #partialDatabase
! !

!MailDB methodsFor: 'open-create-save'!
openDB
	"Open an existing mail database."

	Transcript show: 'Opening mail database ''', rootFilename, '''...'.
	messageFile _ MessageFile openOn: rootFilename, '.messages'.
	indexFile _ IndexFile openOn: rootFilename, '.index' messageFile: messageFile.
	categoriesFile _ CategoriesFile openOn: rootFilename, '.categories'.
	Transcript show: 'Done.'; cr.! !

!MailDB methodsFor: 'open-create-save' stamp: 'mdr 1/25/2000 12:06'!
recoverDB
	"Open a mail database with the given root file name."

	(self confirm:
'The mail database named:
    ', rootFilename, '
appears to be damaged.
Shall I fix it?  (This might take some time)')
		ifFalse: [self release. ^nil].

	self openDB.
	self compact.! !

!MailDB methodsFor: 'open-create-save'!
rootFilename
	"Answer my root filename."

	^rootFilename! !

!MailDB methodsFor: 'open-create-save' stamp: 'dvf 5/1/2000 20:12'!
saveDB
	"Write all database files to disk."
	rootFilename notNil
		ifTrue: [Transcript show: 'Saving mail database ''' , rootFilename , '''...']
		ifFalse: [Transcript show: 'Saving mail database...'].
	messageFile notNil ifTrue: [messageFile save].
	"indexFile notNil ifTrue: [indexFile save]."
	categoriesFile notNil ifTrue: [categoriesFile save].
	Transcript show: 'Done.';
	 cr! !


!MailDB methodsFor: 'fetch-import-export' stamp: 'jm 10/14/1998 12:31'!
fetchMailFromPOP: server userName: userName password: password doFormatting: doFormatting deleteFromServer: deleteFromServer
	"Download mail from the given POP3 mail server and append it this mail database. Answer the number of messages fetched. If doFormatting is true, messages will be formatted as they are received. If deleteFromServer is true, then messages will be removed from the POP3 server after being successfully retrieved. (Note: If there is a failure while fetching mail, all messages will be left on the server.)"

	| popConnection msgCount |
	Socket initializeNetwork.
	popConnection _ POPSocket new
		serverName: server;	
		userName: userName;
		password: password;
		addProgressObserver: Transcript.
	Utilities
		informUser: 'connecting to ', server
		during: [popConnection connectToPOP].
	popConnection isConnected ifFalse: [^ -1].

	msgCount _ popConnection numMessages.
	msgCount > 0 ifTrue: [
		self fetchMessageCount: msgCount
			fromPOPConnection: popConnection
			doFormatting: doFormatting.

		deleteFromServer ifTrue: [
			self removeMessageCount: msgCount fromPOPConnection: popConnection]].

	popConnection disconnectFromPOP.
	^ msgCount
! !

!MailDB methodsFor: 'fetch-import-export' stamp: 'jm 10/2/1998 16:10'!
fetchMessageCount: msgCount fromPOPConnection: popConnection doFormatting: doFormatting
	"Download the given number of messages from the given open POP3 connection. If doFormatting is true, messages will be formatted as they are received."

	| nextID msgText msg location |
	nextID _ self nextUnusedID.
	messageFile beginAppend.
	('Downloading ', msgCount printString, ' messages...')
		displayProgressAt: Sensor mousePoint
		from: 0
		to: msgCount
		during: [:progressBar |
			1 to: msgCount do: [:messageNum |
				progressBar value: messageNum.
				popConnection isConnected ifFalse: [
					popConnection destroy.  "network error"
					messageFile endAppend.
					LastID _ nextID.
					self saveDB.
					^ self inform: 'Server connection unexpectedly closed.'].

				"get a message"
				msgText _ popConnection retrieveMessage: messageNum.

				"save that message"
				msg _ MailMessage from: msgText.
				doFormatting ifTrue: [msg format].
				location _ messageFile basicAppend: msg text id: nextID.
				indexFile
					at: nextID
					put: (IndexFileEntry
						message: msg
						location: location
						messageFile: messageFile
						msgID: nextID).
				categoriesFile file: nextID inCategory: 'new'.
				nextID _ nextID + 1]].

	messageFile endAppend.
	LastID _ nextID.
	self saveDB.
! !

!MailDB methodsFor: 'fetch-import-export' stamp: 'jm 8/14/1998 16:47'!
fetchNewsFrom: inboxPathName doFormatting: doFormatting deleteInbox: deleteInbox
	"Append the messages from the given news inbox file to this mail database. Answer the number of messages fetched."

	| inbox nextID count msg location |
	"is there any news?"
	((FileDirectory on: inboxPathName) includesKey: 'news') ifFalse: [^ 0].

	inbox _ RNInboxFile openOn: inboxPathName, ':news'.
	nextID _ self nextUnusedID.
	count _ 0.
	messageFile beginAppend.
	inbox newsMessagesDo:
		[: newsgroup : msgText |
		 msg _ MailMessage from: msgText.
		 doFormatting ifTrue: [msg format].
		 location _ messageFile basicAppend: msg text id: nextID.
		 indexFile
			at: nextID
			put: (IndexFileEntry
					message: msg
					location: location
					messageFile: messageFile
					msgID: nextID).
		 categoriesFile file: nextID inCategory: newsgroup.
		 categoriesFile file: nextID inCategory: 'new'.
		 nextID _ nextID + 1.
		 count _ count + 1].
	messageFile endAppend.
	LastID _ nextID.

	"snapshot the database and remove the inbox file"
	self saveDB.
	deleteInbox ifTrue: [inbox delete].
	^ count
! !

!MailDB methodsFor: 'fetch-import-export' stamp: 'jm 10/2/1998 15:39'!
importMailFrom: inboxFileName intoCategory: category
	"Append the messages from the given mail file to this mail database, and store them in the given category. Answer the number of messages imported."

	| inbox nextID count msg location |
	inbox _ MailInboxFile openOn: inboxFileName.
	nextID _ self nextUnusedID.
	count _ 0.
	messageFile beginAppend.
	inbox mailMessagesDo: [:msgText |
		 msg _ MailMessage from: msgText.
		 location _ messageFile basicAppend: msg text id: nextID.
		 indexFile
			at: nextID
			put: (IndexFileEntry
					message: msg
					location: location
					messageFile: messageFile
					msgID: nextID).
		 categoriesFile file: nextID inCategory: category.
		 nextID _ nextID + 1.
		 count _ count + 1].
	messageFile endAppend.
	LastID _ nextID.
	self saveDB.
	^ count
! !

!MailDB methodsFor: 'fetch-import-export'!
mergeMessages: msgIDList from: sourceDB
	"Merge the given collection of messages from the source database into the receiver. When a message being added has the same message ID as an existing message, check to see if the two message texts are identical. If so, do not store the duplicate message. If the texts are different, make a new ID for the message being added. This operation will also copy the category information from the sourceDB, creating new catetories if necessary."

	| msgText newMsgID saveIt msg location entry |
	messageFile beginAppend.
	msgIDList do:
		[: oldMsgID |
		 msgText _ sourceDB getText: oldMsgID.

		 "resolve ID conflicts"
		 (indexFile includesKey: oldMsgID)
			ifFalse:	"no ID conflict"
				[newMsgID _ oldMsgID.
				 saveIt _ true]
			ifTrue:	"resolve an ID conflict"
				[(msgText = (self getText: oldMsgID))
					ifTrue:	"identical text; don't save again"
						[newMsgID _ oldMsgID.
						 saveIt _ false]
					ifFalse:	"different text; save with new ID"
						[newMsgID _ self nextUnusedID.
						 saveIt _ true]].

		 "save the message in the destination DB"
		 saveIt ifTrue:
			[msg _ MailMessage from: msgText.
			 location _ messageFile basicAppend: msg text id: newMsgID.
			 entry _ IndexFileEntry
						message: msg
						location: location 
						messageFile: messageFile
						msgID: newMsgID.
			 indexFile at: newMsgID put: entry].

		 "update the categories for the message in the destination DB"
		 (sourceDB categoriesThatInclude: oldMsgID) do:
			[: categoryName |
			 self file: newMsgID inCategory: categoryName]].
	messageFile endAppend.! !

!MailDB methodsFor: 'fetch-import-export' stamp: 'jm 10/2/1998 15:51'!
removeMessageCount: msgCount fromPOPConnection: popConnection
	"Remove messages 1 through msgCount from the given POP3 server."

	('Removing ', msgCount printString, ' messages from the server...')
		displayProgressAt: Sensor mousePoint
		from: 0
		to: msgCount
		during: [:progressBar |
			1 to: msgCount do: [:messageNum |
				progressBar value: messageNum.
				popConnection isConnected ifFalse: [
					popConnection destroy.  "network error"
					^ self inform: 'Server connection unexpectedly closed.'].
				popConnection deleteMessage: messageNum]].
! !


!MailDB methodsFor: 'housekeeping'!
appendMessages: msgBuffer messageFile: msgFile indexFile: idxFile
	"Append the given collection of messages to the message file. msgBuffer is a collection of (message ID, message text) pairs."

	| id msgText location entry |
	msgBuffer do:
		[: idAndText |
		 id _ idAndText at: 1.
		 msgText _ idAndText at: 2.
		 location _ msgFile basicAppend: msgText id: id.
		 entry _ indexFile
			at: id
			ifAbsent:
				[IndexFileEntry
					message: (MailMessage from: msgText)
					location: location
					messageFile: msgFile
					msgID: id].
		 entry _ (entry copy) location: location; textLength: msgText size.
		 idxFile at: id put: entry].! !

!MailDB methodsFor: 'housekeeping'!
cleanUpCategories
	"Prune the dead wood out of all categories."

	categoriesFile categories do:
		[: category |
		 categoriesFile removeMessagesInCategory: category butNotIn: indexFile].! !

!MailDB methodsFor: 'housekeeping'!
compact
	"Compact the message file and rebuild the index file. Answer an array containing with the number of messages and the number of bytes recovered."

	| newMessageFile newIndexFile stats |
	newMessageFile _ MessageFile openOn: rootFilename, '.messages.tmp'.
	newIndexFile _ IndexFile openOn: rootFilename, '.index.tmp' messageFile: newMessageFile.
	stats _ self copyUndeletedTo: newMessageFile indexFile: newIndexFile.
	newMessageFile save.
	newIndexFile save.
	messageFile rename: rootFilename, '.messages.bak'.
	indexFile rename: rootFilename, '.index.bak'.
	newMessageFile rename: rootFilename, '.messages'.
	newIndexFile rename: rootFilename, '.index'.
	indexFile delete.
	messageFile delete.
	indexFile _ newIndexFile.
	messageFile _ newMessageFile.
	self cleanUpCategories.
	categoriesFile save.
	^stats! !

!MailDB methodsFor: 'housekeeping'!
copyUndeletedTo: newMsgFile indexFile: newIndexFile
	"Copy all the undeleted messages in my current message file into the new message file, recording their locations in the new index file. Answer an array containing with the number of messages and the number of bytes recovered."
	"Note: To minimize disk seeks, messages are buffered and written in large batches. You may wish to tune the amount of buffering if you have a particular shortage or abundance of physical memory. bufferLimit is the approximate number of bytes of messages that will be accumulated before writing the buffered messages to disk."

	| bufferLimit msgBuffer bufferSize deletedCount deletedBytes |
	Smalltalk garbageCollect.
	bufferLimit _ Smalltalk bytesLeft // 2.	"use half of the available memory"
	msgBuffer _ OrderedCollection new: 1000.
	bufferSize _ 0.
	deletedCount _ deletedBytes _ 0.
	newMsgFile beginAppend.
	messageFile messagesDo:
		[: deleted : msgID : msgText |
		 (deleted)
			ifTrue:
				[deletedCount _ deletedCount + 1.
				 deletedBytes _ deletedBytes + msgText size]
			ifFalse:
				[msgBuffer addLast: (Array with: msgID with: msgText).
				 bufferSize _ bufferSize + msgText size.
				 (bufferSize >= bufferLimit) ifTrue:
					[self
						appendMessages: msgBuffer
						messageFile: newMsgFile
						indexFile: newIndexFile.
					 msgBuffer _ OrderedCollection new: 1000.
					 bufferSize _ 0]]].
	"flush remaining buffered messages"
	self
		appendMessages: msgBuffer
		messageFile: newMsgFile
		indexFile: newIndexFile.
	newMsgFile endAppend.

	"return statistics"
	^Array with: deletedCount with: deletedBytes! !

!MailDB methodsFor: 'housekeeping'!
fileDuplicatesIn: categoryName
	"MailDB someInstance fileDuplicatesIn: '.duplicates.'"

	self fileAll: self findDuplicates inCategory: categoryName.
! !

!MailDB methodsFor: 'housekeeping' stamp: 'dvf 6/10/2000 18:33'!
findDuplicates
	"MailDB someInstance findDuplicates"
	| msgsAtTime duplicates msgsBySize similarMessages textCache first second text1 text2 |
	duplicates _ PluggableSet integerSet.
	msgsAtTime _ ((self messagesIn: '.all.')
				collect: [:e | indexFile at: e])
				groupBy: [:e | e time]
				having: [:arr | arr size > 1].
	msgsAtTime
		associationsDo: 
			[:assoc | 
			msgsBySize _ assoc value groupBy: [:e | e textLength]
						having: [:arr | arr size > 1].
			msgsBySize
				associationsDo: 
					[:assoc2 | 
					similarMessages _ assoc2 value.
					textCache _ PluggableDictionary integerDictionary.
					similarMessages combinations: 2
						atATimeDo: 
							[:each | 
							first _ each first.
							second _ each second.
							((first likelyEqual: second)
								and: 
									[text1 _ textCache at: first msgID ifAbsentPut: [(self getMessage: first msgID) bodyText].
									text2 _ textCache at: second msgID ifAbsentPut: [(self getMessage: second msgID) bodyText].
									text1 = text2])
								ifTrue: [duplicates add: second msgID]]]].
	^ duplicates asArray! !

!MailDB methodsFor: 'housekeeping' stamp: 'jm 10/4/1998 11:06'!
nextUnusedID
	"Answer the next unused message identifier. Message ID's are a monotonically increasing series roughly related to the time that they were requested. We use a block of message ID's based on the starting ID computed here. The last ID used is kept in LastID, to be sure that we don't reuse an already allocated ID."

	| id |
	"initialize LastID the first time it is used"
	(LastID isNil) ifTrue: [LastID _ 0].

 	"message ID's are roughly the number of seconds since the beginning of 1980"
	id _ Date today asSeconds + Time now asSeconds -
		(Date newDay: 1 year: 1980) asSeconds.
	id _ id max: (LastID + 1).  "never go backwards!!"
	LastID _ id.
	^ id
! !


!MailDB methodsFor: 'categories'!
addCategory: categoryName
	"Create a category with the given name if one doesn't already exist."

	categoriesFile addCategory: categoryName.! !

!MailDB methodsFor: 'categories'!
allCategories
	"Answer a list of categories sorted in alphabetical order, including the special categories."

	^categoriesFile categories asSortedCollection asOrderedCollection! !

!MailDB methodsFor: 'categories'!
categoriesThatInclude: msgID
	"Answer a collection of names for real categories that include the message with the given ID. Pseudo-categories (such as '.unclassified.') are not considered real categories."

	^categoriesFile categories select:
		[: catName |
		 (categoriesFile messagesIn: catName) includes: msgID]! !

!MailDB methodsFor: 'categories'!
file: msgID inCategory: categoryName
	"File the message with the given ID in the given category."

	categoriesFile file: msgID inCategory: categoryName.! !

!MailDB methodsFor: 'categories'!
fileAll: msgIDList inCategory: categoryName
	"File all the messages with ID's in the given list in the given category."

	msgIDList do:
		[: msgID |
		 categoriesFile file: msgID inCategory: categoryName].! !

!MailDB methodsFor: 'categories' stamp: 'dvf 6/3/2000 15:06'!
messagesIn: categoryName 
	"Answer a collection of message ID's for the messages in the given 
	category, sorted in ascending time order.  If the category does not exist, 
	answer an empty collection. The pseudo-categories '.all.' and 
	'.unclassified.' are computed dynamically, which may take a little time."
	| msgList category |
	categoryName = '.unclassified.'
		ifTrue: 
			[Cursor execute showWhile: [msgList _ categoriesFile unclassifiedFrom: indexFile keys].
			^ msgList].
	categoryName = '.all.' ifTrue: [^ indexFile keys].
	"otherwise, it is a real category"
	category _ categoriesFile messagesIn: categoryName.
	^self sortedKeysForMessages: category.
	! !

!MailDB methodsFor: 'categories'!
remove: msgID fromCategory: categoryName
	"Remove the message with the given ID from the given category."

	categoriesFile remove: msgID fromCategory: categoryName.! !

!MailDB methodsFor: 'categories'!
removeAll: msgIDList fromCategory: categoryName
	"Remove all the messages with ID's in the given list from the given category."

	msgIDList do:
		[: msgID |
		 categoriesFile remove: msgID fromCategory: categoryName].! !

!MailDB methodsFor: 'categories'!
removeCategory: categoryName
	"Remove the category with the given name. This does nothing if the category does not exist or if it is a pseudo-category."

	categoriesFile removeCategory: categoryName.! !

!MailDB methodsFor: 'categories'!
removeFromAllCategories: msgID
	"Remove the message with the given ID from all categories. The message will appear in 'unclassified'."

	categoriesFile categories do:
		[: categoryName |
		 categoriesFile remove: msgID fromCategory: categoryName].! !

!MailDB methodsFor: 'categories' stamp: 'jm 10/4/1998 11:16'!
renameCategory: oldName to: newName
	"Rename the given category. This does nothing if the category does not exist or if it is a special category ('.all.' or '.unclassified.')."

	categoriesFile renameCategory: oldName to: newName.
! !

!MailDB methodsFor: 'categories' stamp: 'dvf 6/3/2000 17:05'!
sortedKeysForMessages: aSet 
	"use a heuristic to choose method of obtaining sorted message list"
	^ aSet size * (aSet size log: 2) * 3 > indexFile keysCount
		ifTrue: [indexFile keys select: [:msgID | "indexFile keys is sorted"
				aSet includes: msgID]]
		ifFalse: [(aSet asArray
				mergeSortFrom: 1
				to: aSet size
				by: [:a :b | (self getTOCentry: a) time < (self getTOCentry: b) time]) asOrderedCollection]! !


!MailDB methodsFor: 'messages' stamp: 'jm 10/4/1998 11:13'!
addNewMessage: message
	"Add the given message to the database, and answer its message id."

	| id location |
	id _ self nextUnusedID.
	location _ messageFile append: message text id: id.
	indexFile
		at: id
		put: (IndexFileEntry
				message: message
				location: location
				messageFile: messageFile
				msgID: id).
	^ id
! !

!MailDB methodsFor: 'messages'!
deleteAll: msgIDList
	"Delete all the messages with ID's in the given list from the message file. This is permanent!!"

	msgIDList do:
		[: msgID |
		 messageFile
			deleteMessageAt: (indexFile at: msgID) location
			id: msgID.
		 indexFile remove: msgID].
	self cleanUpCategories.! !

!MailDB methodsFor: 'messages'!
getMessage: msgID
	"Answer the MailMessage with the given ID."

	^MailMessage from: (self getText: msgID)! !

!MailDB methodsFor: 'messages'!
getTOCentry: msgID
	"Answer the table-of-contents entry for the message with the given ID."

	^indexFile at: msgID! !

!MailDB methodsFor: 'messages'!
getTOCstring: msgID
	"Answer the table-of-contents string for the message with the given ID."

	^(indexFile at: msgID) tocString! !

!MailDB methodsFor: 'messages' stamp: 'sbw 12/25/2000 20:35'!
getTOCstringAsColumns: msgID 
	^ (indexFile at: msgID) tocStringAsColumns! !

!MailDB methodsFor: 'messages'!
getText: msgID
	"Answer the text for the message with the given ID."

	| entry |
	entry _ indexFile at: msgID.
	^messageFile
		getMessage: msgID
		at: entry location
		textLength: entry textLength! !

!MailDB methodsFor: 'messages'!
newText: newText for: msgID
	"Replace the text for the message with the given ID."

	| oldLocation newLocation newEntry |
	oldLocation _ (indexFile at: msgID) location.
	newLocation _ messageFile update: newText at: oldLocation id: msgID.
	newEntry _ IndexFileEntry
		message: (MailMessage from: newText)
		location: newLocation
		messageFile: messageFile
		msgID: msgID.
	indexFile at: msgID put: newEntry.! !


!MailDB methodsFor: 'printing' stamp: 'dvf 4/29/2000 15:27'!
printOn: aStream 
	aStream nextPutAll: 'a MailDB on '.
	rootFilename ifNotNil: [aStream nextPutAll: '''' , rootFilename , '''']! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailDB class
	instanceVariableNames: ''!

!MailDB class methodsFor: 'instance creation' stamp: 'tk 6/24/1999 07:22'!
openOn: rootFilename
	"Open or create a mail database with the given root filename. If an instance of me exists with the given root filename, return a reference to that instance rather than creating a new one. This allows multiple MailReaders to be open on the same database without synchronization problems."

	| alreadyOpenDB |
	alreadyOpenDB _ self allSubInstances
		detect:
			[: db |
			 (db rootFilename notNil) and:
			 [db rootFilename = rootFilename]]
		ifNone: [nil].
	(alreadyOpenDB notNil)
		ifTrue: [^alreadyOpenDB]
		ifFalse: [^(self new) openOn: rootFilename].! !


!MailDB class methodsFor: 'utilities'!
readIntegerLineFrom: aStream
	"Read a positive integer from the given stream. Answer zero if there are no digits. Consume the stream through the next carriage return."

	| digit value |
	value _ 0.
	[aStream atEnd] whileFalse: 
		[digit _ aStream next digitValue.
		 ((digit >= 0) & (digit <= 9))
			ifTrue: 
				[value _ (value * 10) + digit]
			ifFalse:
				[(digit == Character cr digitValue) ifFalse:
					[self skipRestOfLine: aStream].
				 ^value]].
	^value! !

!MailDB class methodsFor: 'utilities' stamp: 'ls 9/8/1998 05:19'!
readStringLineFrom: aStream 
	"Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string."

	| |

	^aStream upTo: Character cr! !

!MailDB class methodsFor: 'utilities'!
skipRestOfLine: aStream
	"Consume characters from the given stream through the next carriage return."

	| crValue |
	crValue _ Character cr asciiValue.
	[aStream atEnd or:
	 [aStream next asciiValue == crValue]] whileFalse:
		["consume until end of stream or a carriage return"].! !


!MailDB class methodsFor: 'shut down' stamp: 'tk 6/24/1999 11:35'!
shutDown
	"snapshot all mail databases to disk"

	self allSubInstancesDo: [:db | db saveDB]! !
Object subclass: #MailDBFile
	instanceVariableNames: 'filename '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MailDBFile commentStamp: '<historical>' prior: 0!
I am an abstract class that collects some of the operations common to all mail database files.
!


!MailDBFile methodsFor: 'file operations' stamp: 'ls 9/10/1998 01:40'!
delete
	"Delete this file."

	FileDirectory splitName: filename to: [:dirPath :name |
		(FileDirectory forFileName: filename) 
			deleteFileNamed: name ifAbsent: []].
! !

!MailDBFile methodsFor: 'file operations'!
openOn: aFileName
	"Initialize myself from the file with the given name."

	| fileStream |
	filename _ aFileName.
	fileStream _ FileStream fileNamed: aFileName.
	self readFrom: fileStream.
	fileStream setToEnd; close; release.
		"close and release the file stream"
	fileStream _ nil.! !

!MailDBFile methodsFor: 'file operations' stamp: 'ls 9/10/1998 01:35'!
rename: newFileName
	"Rename this file."

	FileDirectory splitName: filename to: [:dirPath :oldFileName |
		(FileDirectory forFileName: filename) 
			rename: oldFileName toBe: newFileName].
	filename _ newFileName.
! !

!MailDBFile methodsFor: 'file operations' stamp: 'RAA 9/14/2000 15:59'!
save
	"Atomically save a representation of this object to its file. The old file is 
	renamed to '<oldname>.bak' before the new file is written. If the write 
	operation fails, the old file may be restored by renaming it. If it 
	succeeds, the .bak file is deleted."
	"create the file if it doesn't already exist"
	| f dir shortName |

	(StandardFileStream fileNamed: filename) close.	"ensure it exists"
	shortName _ FileDirectory localNameFor: filename.
	dir _ FileDirectory forFileName: filename.
	dir rename: shortName toBe: shortName , '.bak'.
	Cursor write showWhile: [f _ FileStream fileNamed: filename.
	self writeOn: f.
	f setToEnd; close.].
	dir deleteFileNamed: shortName , '.bak' ifAbsent: []! !


!MailDBFile methodsFor: 'read-write'!
readFrom: aStream
	"Subclasses must override this method to provide a means of reading themselves into memory."

	self subclassResponsibility! !

!MailDBFile methodsFor: 'read-write'!
writeOn: aStream
	"Subclasses must override this method to provide a means of writing themseves out on their files."

	self subclassResponsibility! !


!MailDBFile methodsFor: 'error reporting'!
reportInconsistency
	"Report that the index file is not consistent with the messages file."

	self inform:
'The .index file is not consistent with the .messages file.
Choosing ''salvage & compact'' will rebuild the index from scratch.'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailDBFile class
	instanceVariableNames: ''!

!MailDBFile class methodsFor: 'instance creation'!
openOn: fileName
	"Answer a new instance of me, backed by the file with the given name."

	^(super new) openOn: fileName! !
MailDBFile subclass: #MailInboxFile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MailInboxFile commentStamp: '<historical>' prior: 0!
I am a parser for mail inboxes in a form found in the Unix '/var/spool' inboxes. This is also the format used by Eudora 3.0 on the Macintosh (and perhaps by other versions of Eudora as well).
!


!MailInboxFile methodsFor: 'read-write'!
readFrom: aStream
	"This operation is a noop for mail inboxes. Use 'messagesDo:' to enumerate the messages in the inbox."! !

!MailInboxFile methodsFor: 'read-write'!
writeOn: aStream
	"This operation is illegal for mail inboxes."

	self error: 'Mail inboxes are read only!!'! !


!MailInboxFile methodsFor: 'scanning'!
delimitersDo: aBlock
	"Invoke the given block for each message in the mail inbox. The block argument is the text of a new message."

	| fileStream stream msgStart msgSize msgText delim |
	fileStream _ FileStream fileNamed: filename.
	Smalltalk garbageCollect.
	(fileStream size < (Smalltalk bytesLeft - 200000))
		ifTrue: [
			"if possible, buffer the entire file in memory for speed"
			stream _ ReadStream on: (fileStream contentsOfEntireFile).
			fileStream _ nil]
		ifFalse: [
			"otherwise, use the actual file stream, reading from disk"
			stream _ fileStream].

	[self scanToNextMessageIn: stream] whileTrue: [
		aBlock value: (MailDB readStringLineFrom: stream)].

	fileStream = nil ifFalse: [fileStream close].! !

!MailInboxFile methodsFor: 'scanning'!
findPossibleMessageStart: aStream
	"Find the next line starting with the string 'From' followed by a space. Leave the input stream positioned at the character following the space."

	(self nextStringIs: 'From ' in: aStream) ifTrue: [^true].
	[true] whileTrue: [
		aStream skipTo: Character cr.
		[aStream peek = Character cr] whileTrue: [aStream next].
		(self nextStringIs: 'From ' in: aStream) ifTrue: [^true].
		aStream atEnd ifTrue: [^false].
	].! !

!MailInboxFile methodsFor: 'scanning' stamp: 'bf 3/9/2000 18:36'!
mailMessagesDo: aBlock
	"Invoke the given block for each message in the mail inbox. The block argument is the text of a new message."

	| fileStream stream msgStart msgSize msgText |
	fileStream _ CrLfFileStream readOnlyFileNamed: filename.
	Smalltalk garbageCollect.
	(fileStream size < (Smalltalk bytesLeft - 200000))
		ifTrue: [
			"if possible, buffer the entire file in memory for speed"
			stream _ ReadStream on: (fileStream contentsOfEntireFile).
			fileStream _ nil]
		ifFalse: [
			"otherwise, use the actual file stream, reading from disk"
			stream _ fileStream].

	self scanToNextMessageIn: stream.
	MailDB skipRestOfLine: stream.  "skip message delimiter"
	msgStart _ stream position.
	[self scanToNextMessageIn: stream] whileTrue: [
		msgSize _ stream position - msgStart.
		stream position: msgStart.
		msgText _ stream next: msgSize.
		MailDB skipRestOfLine: stream.  "skip message delimiter"
		msgStart _ stream position.
		aBlock value: msgText].

	"process final message"
	msgSize _ stream position - msgStart.
	msgSize > 0 ifTrue: [
		stream position: msgStart.
		msgText _ stream next: msgSize.
		aBlock value: msgText].

	fileStream = nil ifFalse: [fileStream close].! !

!MailInboxFile methodsFor: 'scanning'!
nextStringIs: aString in: aStream
	"If the next characters of the given stream form the given string, then advance the stream position by the size of the string and return true. Otherwise, leave the stream untouched and return false."

	| oldPosition |
	oldPosition _ aStream position.
	1 to: aString size do: [ :i |
		aStream next = (aString at: i) ifFalse: [
			aStream position: oldPosition.
			^false
		].
	].
	aStream position: oldPosition.
	^true! !

!MailInboxFile methodsFor: 'scanning' stamp: 'ls 8/21/1998 10:21'!
scanToNextMessageIn: aStream
	"Scan to the start of the next message in the given stream. Answer true if we find a message delimiter, false if we hit the end of the stream first. The stream is left positioned at the start of the next message or at the end of the stream."

	| msgStart line dayOfWeek year |
	[aStream atEnd] whileFalse: [
		(self findPossibleMessageStart: aStream) ifFalse: [^false].
		msgStart _ aStream position.
		aStream next: 5.  "skip 'From '"

		"skip address"
		[aStream peek isSeparator] whileFalse: [aStream next].
		[aStream peek = Character space] whileTrue: [aStream next].

		line _ MailDB readStringLineFrom: aStream.
		line size >= 7 ifTrue: [
			dayOfWeek _ (line copyFrom: 1 to: 3) asLowercase.
			year _ (line copyFrom: line size - 3 to: line size) asNumber.
			((#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: dayOfWeek) and:
			[(year > 1900) and: [year < 2100]]) ifTrue: [
				aStream position: msgStart.
				^true  "found a message!!"
			].
		].
	].
	^false! !
Object subclass: #MailMessage
	instanceVariableNames: 'time from to cc subject text body fields parts separator '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MailMessage commentStamp: '<historical>' prior: 0!
I represent a mail or news message. I parse the message header and keep certain header fields in instance variables for rapid access.

!


!MailMessage methodsFor: 'initialize-release' stamp: 'bf 3/10/2000 10:01'!
cacheFieldsFrom: aStream andDo: aBlock
	"Parse aStream to initialize myself. Also, report to aBlock like fieldsFrom:do: does"
	time _ 0.
	from _ to _ cc _ subject _ ''.
	self fieldsFrom: aStream do:
		[:fName :fValue |
			fName asLowercase caseOf: {
				['date'] -> [time _ self timeFrom: fValue].
				['from'] -> [from _ fValue].
				['to'] -> [to isEmpty
					ifTrue: [to _ fValue]
					ifFalse: [to _ to , ', ' , fValue]].
				['cc'] -> [cc isEmpty
					ifTrue: [cc _ fValue]
					ifFalse: [cc _ cc , ', ' , fValue]].
				['subject'] -> [subject _ fValue]}
				otherwise: [].
			aBlock value: fName value: fValue].
! !

!MailMessage methodsFor: 'initialize-release' stamp: 'bf 3/10/2000 10:03'!
cachedFields
	^ #('Date' 'From' 'To' 'Cc' 'Subject')
! !

!MailMessage methodsFor: 'initialize-release' stamp: 'BEO 12/3/2000 15:53'!
from: aString 
	"Parse aString to initialize myself."
	| parseStream isMime contentType bodyText contentTransferEncoding |
	time _ 0.
	from _ to _ cc _ subject _ '' copy.
	text _ aString withoutTrailingBlanks, String cr.
	parseStream _ ReadStream on: text.
	isMime _ false.  "mdr: This variable is later set but never seems to be used???"
	contentType _ 'text/plain'.
	contentTransferEncoding _ nil.
	fields := Dictionary new.

	self fieldsFrom: parseStream do: 
		[:fName :fValue | 
		(fName asLowercase) = 'date' ifTrue: 
			[time _ (self timeFrom: fValue) ifNil: [ 0 ]].
		(fName asLowercase) = 'from' ifTrue: [from _ fValue].
		(fName asLowercase) = 'to'
			ifTrue: [to isEmpty
					ifTrue: [to _ fValue]
					ifFalse: [to _ to , ', ' , fValue]].
		(fName asLowercase)  = 'cc'
			ifTrue: [cc isEmpty
					ifTrue: [cc _ fValue]
					ifFalse: [cc _ cc , ', ' , fValue]].
		(fName asLowercase) = 'subject' ifTrue: [subject _ fValue].
		(fName asLowercase) = 'mime-version' ifTrue: [isMime _ true].
		(fName asLowercase) = 'content-type' ifTrue: [contentType _ (fValue copyUpTo: $;) asLowercase].
		(fName asLowercase) = 'content-transfer-encoding' ifTrue: [contentTransferEncoding _ fValue asLowercase].

		fields at: fName put: (MIMEHeaderValue fromString: fValue)].
	bodyText _ parseStream upToEnd.
	contentTransferEncoding = 'base64'
		ifTrue: 
			[bodyText _ Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText).
			bodyText _ bodyText contents].
	contentTransferEncoding = 'quoted-printable' ifTrue: [bodyText _ bodyText decodeQuotedPrintable].
	body _ MIMEDocument contentType: contentType content: bodyText! !


!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:48'!
body
	"return just the body of the message"
	^body! !

!MailMessage methodsFor: 'access' stamp: 'ls 1/3/1999 15:52'!
bodyText
	"return the text of the body of the message"
	^body content! !

!MailMessage methodsFor: 'access'!
cc

	^cc! !

!MailMessage methodsFor: 'access' stamp: 'bf 3/16/2000 18:31'!
date
	"Answer a date string for this message."

	^(Date fromSeconds: time + (Date newDay: 1 year: 1980) asSeconds) 
		printFormat: #(2 1 3 47 1 2)! !

!MailMessage methodsFor: 'access' stamp: 'ls 4/30/2000 18:15'!
fields
	^ fields! !

!MailMessage methodsFor: 'access'!
from

	^from! !

!MailMessage methodsFor: 'access' stamp: 'ls 4/30/2000 18:21'!
name
	"return a default name for this part, if any was specified.  If not, return nil"
	| type nameField disposition |

	"try in the content-type: header"
	type _ self fields at: 'content-type' ifAbsent: [nil].
	(type notNil and: [(nameField _ type parameters at: 'name' ifAbsent: [nil]) notNil])
		ifTrue: [^ nameField].

	"try in content-disposition:"
	disposition _ self fields at: 'content-disposition' ifAbsent: [nil].
	(disposition notNil and: [(nameField _ disposition parameters at: 'filename' ifAbsent: [nil]) notNil])
		ifTrue: [^ nameField].

	"give up"
	^ nil! !

!MailMessage methodsFor: 'access'!
subject

	^subject! !

!MailMessage methodsFor: 'access'!
text

	^text! !

!MailMessage methodsFor: 'access'!
time

	^time! !

!MailMessage methodsFor: 'access'!
to

	^to! !


!MailMessage methodsFor: 'parsing' stamp: 'bf 3/10/2000 09:44'!
fieldsFrom: aStream do: aBlock
	"Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body."

	| savedLine line s |
	savedLine _ MailDB readStringLineFrom: aStream.
	[aStream atEnd] whileFalse: [
		line _ savedLine.
		(line isEmpty) ifTrue: [^self].  "quit when we hit a blank line"
		[savedLine _ MailDB readStringLineFrom: aStream.
		 (savedLine size > 0) and: [savedLine first isSeparator]] whileTrue: [
			"lines starting with white space are continuation lines"
			s _ ReadStream on: savedLine.
			s skipSeparators.
			line _ line, s upToEnd].
		self reportField: line withBlanksTrimmed to: aBlock].

	"process final header line of a body-less message"
	(savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock].
! !

!MailMessage methodsFor: 'parsing' stamp: 'bf 3/10/2000 08:37'!
headerFieldsNamed: fieldName do: aBlock
	"Evalue aBlock once for each header field which matches fieldName.  The block is valued with one parameter, the value of the field"

	self fieldsFrom: (ReadStream on: text) do:
		[: fName : fValue |
			(fieldName sameAs: fName) ifTrue: [aBlock value: fValue]].
! !

!MailMessage methodsFor: 'parsing'!
readDateFrom: aStream
	"Parse a date from the given stream and answer nil if the date can't be parsed. The date may be in any of the following forms:
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)
		<monthName> <day> <year>		(April 5, 1982)
		<monthNumber> <day> <year>		(4/5/82)
	In addition, the date may be preceded by the day of the week and an optional comma, such as:
		Tue, November 14, 1989"

	| day month year |
	self skipWeekdayName: aStream.
	aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	aStream peek isLetter
		ifTrue:		"month name or weekday name"
			[month _ WriteStream on: (String new: 10).
			 [aStream peek isLetter] whileTrue: [month nextPut: aStream next].
			 month _ month contents.
			 day isNil ifTrue:		"name/number..."
				[[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
				 (aStream peek isDigit) ifFalse: [^nil].
				 day _ Integer readFrom: aStream]]
		ifFalse:		"number/number..."
			[month _ Date nameOfMonth: day.
			 day _ Integer readFrom: aStream].
	[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
	(aStream peek isDigit) ifFalse: [^nil].
	year _ Integer readFrom: aStream.
	^Date newDay: day month: month year: year! !

!MailMessage methodsFor: 'parsing' stamp: 'bf 3/10/2000 11:04'!
reportField: aString to: aBlock
	"Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed."

	| s fieldName fieldValue |
	(aString includes: $:) ifFalse: [^self].
	s _ ReadStream on: aString.
	fieldName _ s upTo: $:.
	fieldValue _ s upToEnd withBlanksTrimmed.
	fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue].
! !

!MailMessage methodsFor: 'parsing'!
skipWeekdayName: aStream
	"If the given stream starts with a weekday name or its abbreviation, advance the stream to the first alphaNumeric character following the weekday name."

	| position name abbrev |
	aStream skipSeparators.
	(aStream peek isDigit) ifTrue: [^self].
	(aStream peek isLetter) ifTrue:
		[position _ aStream position.
		 name _ WriteStream on: (String new: 10).
		 [aStream peek isLetter] whileTrue: [name nextPut: aStream next].
		 abbrev _ (name contents copyFrom: 1 to: (3 min: name position)).
		 abbrev _ abbrev asLowercase.
		 (#('sun' 'mon' 'tue' 'wed' 'thu' 'fri' 'sat') includes: abbrev asLowercase)
			ifTrue:
				["found a weekday; skip to the next alphanumeric character"
				 [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]]
			ifFalse:
				["didn't find a weekday so restore stream position"
				 aStream position: position]].! !

!MailMessage methodsFor: 'parsing' stamp: 'dvf 4/29/2000 03:07'!
timeFrom: aString 
	"Parse the date and time and answer the result as the number of seconds 
	since the start of 1980."
	| s t rawDelta delta |
	s _ ReadStream on: aString.
	t _ (self readDateFrom: s) asSeconds.
	"date part"
	[s atEnd or: [s peek isAlphaNumeric]]
		whileFalse: [s next].
	s atEnd ifFalse: ["read time part (interpreted as local, regardless of sender's timezone)"
		t _ t + (Time readFrom: s) asSeconds].
	s skipSeparators.
	('+-' includes: s peek)
		ifTrue: 
			[s peekFor: $+. rawDelta _ Integer readFrom: s.
			delta _ rawDelta // 100 * 60 + (rawDelta \\ 100).
			t _ t - (delta * 60)].
	^ t - (Date newDay: 1 year: 1980) asSeconds"time started with 1980..."! !


!MailMessage methodsFor: 'printing/formatting' stamp: 'dvf 6/14/2000 00:29'!
asSendableText
	"break lines in the given string into shorter lines"
	| result start end pastHeader atAttachment width aString |
	width _ 72.
	aString _ self text.
	result _ WriteStream on: (String new: aString size * 50 // 49).
	pastHeader _ false.
	atAttachment _ false.
	aString asString
		linesDo: 
			[:line | 
			line isEmpty ifTrue: [pastHeader _ true].
			pastHeader
				ifTrue: 
					["(line beginsWith: '--==')
						ifTrue: [atAttachment _ true]."
					atAttachment
						ifTrue: 
							["at or after an attachment line; no more 
							wrapping for the rest of the message"
							result nextPutAll: line.
							result cr]
						ifFalse: [(line beginsWith: '>')
								ifTrue: 
									["it's quoted text; don't wrap it"
									result nextPutAll: line.
									result cr]
								ifFalse: 
									["regular old line.  Wrap it to multiple 
									lines "
									start _ 1.
									"output one shorter line each time 
									through this loop"
									[start + width <= line size]
										whileTrue: 
											["find the end of the line"
											end _ start + width - 1.
											[end >= start and: [(line at: end + 1) isSeparator not]]
												whileTrue: [end _ end - 1].
											end < start ifTrue: ["a word spans the entire 
												width!! "
												end _ start + width - 1].
											"copy the line to the output"
											result nextPutAll: (line copyFrom: start to: end).
											result cr.
											"get ready for next iteration"
											start _ end + 1.
											(line at: start) isSeparator ifTrue: [start _ start + 1]].
									"write out the final part of the line"
									result nextPutAll: (line copyFrom: start to: line size).
									result cr]]]
				ifFalse: 
					[result nextPutAll: line.
					result cr]].
	^ result contents! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 23:37'!
bodyTextFormatted
	"Answer a version of the text in my body suitable for display.  This will parse multipart forms, decode HTML, and other such things"

	"check for multipart"
	self body isMultipart ifTrue: [
		"check for alternative forms"
		self body isMultipartAlternative ifTrue: [
			"it's multipart/alternative.  search for a part that we can display, biasing towards nicer formats"
			#('text/html' 'text/plain') do: [ :format |
				self parts do: [ :part |
					part body contentType = format ifTrue: [ ^part bodyTextFormatted ] ] ].

			"couldn't find a desirable part to display; just display the first part"
			^self parts first bodyTextFormatted ].

		"not alternative parts.  put something for each part"
		^Text streamContents: [ :str |
			self parts do: [ :part |
				((#('text' 'multipart') includes: part body mainType) or: 
					[ part body contentType = 'message/rfc822'])
				ifTrue: [
					"try to inline the message part"
					str nextPutAll: part bodyTextFormatted. ]
				ifFalse: [ 
					|descript |
					str cr.
					descript := part name ifNil: [ 'attachment' ].
					str nextPutAll: (Text string: '[', descript, ']'  attribute: (TextMessageLink message: part)). ] ] ]. ].


	"check for HTML"
	self body contentType = 'text/html'
		ifTrue: [^(HtmlParser parse: (ReadStream on: body content)) formattedText].

	"check for an embedded message"
	self body contentType = 'message/rfc822' ifTrue: [
		^(MailMessage from: self body content) formattedText ].

	"nothing special--just return the text"
	^body content.

! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'bf 3/10/2000 09:34'!
cleanedHeader
	"Reply with a cleaned up version email header.  First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded"

	| new priorityFields omittedFields |

	new _ WriteStream on: (String new: text size).

	priorityFields _ #('Date' 'From' 'Subject' 'To' 'Cc').
	omittedFields _ MailMessage omittedHeaderFields.

	"Show the priority fields first, in the order given in priorityFields"
	priorityFields do: [ :pField |
		"We don't check whether the priority field is in the omitted list!!"
		self headerFieldsNamed: pField do:
			[: fValue | new nextPutAll: pField, ': ', fValue; cr]].

	"Show the rest of the fields, omitting the uninteresting ones and ones we have already shown"
	omittedFields _ omittedFields, priorityFields.
	self fieldsFrom: (ReadStream on: text) do:
		[: fName : fValue |
		 (omittedFields anySatisfy: [: omitted | fName sameAs: omitted]) ifFalse:
			[new nextPutAll: fName, ': ', fValue; cr]].

	^new contents! !

!MailMessage methodsFor: 'printing/formatting'!
eudoraOutboxText
	"Return this message formatted for inclusion in a Eudora outbox."

	| old new |
	old _ ReadStream on: text.
	new _ WriteStream on: (String new: text size).
	MailMessage new fieldsFrom: old do: [ :fName :fValue | "skip header fields" ].
	new nextPutAll: 'To: ';		nextPutAll: to; cr.
	new nextPutAll: 'From: ';	nextPutAll: from; cr.
	new nextPutAll: 'Subject: ';	nextPutAll: subject; cr.
	new nextPutAll: 'Cc: ';		nextPutAll: cc; cr.
	new nextPutAll: 'Bcc: '; cr.
	new nextPutAll: 'X-attachments: '; cr.
	new cr.
	new nextPutAll: old upToEnd.
	^new contents! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'dew 8/27/2000 02:07'!
fieldsAsMimeHeader
	"return the entire header in proper MIME format"
	| strm |
	strm _ WriteStream on: (String new: 100).
	self fields associationsDo: [:e | strm nextPutAll: e key;
		 nextPutAll: ': ';
		 "circumvent the forced lowercasing of the subject MimeHeader"
		 nextPutAll: (e key = 'subject' ifTrue: [subject] ifFalse: [e value asHeaderValue]);
		 cr]. 
	^ strm contents! !

!MailMessage methodsFor: 'printing/formatting'!
format
	"Replace the text of this message with a formatted version."
	"NOTE: This operation discards extra header fields."

	text _ self formattedText.! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'ls 4/30/2000 18:52'!
formattedText
	"Answer a version of my text suitable for display.  This cleans up the header, decodes HTML, and things like that"

	
	^ self cleanedHeader asText, String cr , self bodyTextFormatted! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 19:47'!
viewBody
	"open a viewer on the body of this message"
	self containsViewableImage
		ifTrue: [^ self viewImageInBody].
	(StringHolder new contents: self bodyTextFormatted;
		 yourself)
		openLabel: (self name
				ifNil: ['(a message part)'])! !

!MailMessage methodsFor: 'printing/formatting' stamp: 'sbw 1/21/2001 11:10'!
viewImageInBody
	| stream image |
	stream _ self body contentStream.
	image _ Form fromBinaryStream: stream.
	(SketchMorph withForm: image) openInWorld! !


!MailMessage methodsFor: 'multipart' stamp: 'dvf 5/13/2000 16:25'!
asMultipartText
	"Return a multipart mime-formatted text otherwise equivalent to this  
	message."
	| attachmentSeparator newText strm |
	self body isMultipart ifTrue: [^ self text].
	attachmentSeparator _ MailMessage generateSeparator.
	newText _ String new: 200.
	strm _ WriteStream on: newText.
	strm nextPutAll: 'Mime-Version: 1.0';
	 cr;
	 nextPutAll: 'Content-Type: multipart/mixed; boundary="';
	 nextPutAll: attachmentSeparator;
	 nextPut: $";
	 cr;
	 nextPutAll: self fieldsAsMimeHeader;
	 cr;
	 cr;
	 nextPutAll: '--' , attachmentSeparator;
	 cr;
	 nextPutAll: 'Content-Type: text/plain; charset="us-ascii"';
	 cr;
	 cr;
	 nextPutAll: self content;
	 cr;
	 nextPutAll: '--' , attachmentSeparator;
	 cr.
	^strm contents! !

!MailMessage methodsFor: 'multipart' stamp: 'dvf 6/11/2000 22:47'!
asTextEncodingNewPart: aStream named: aName 
	"Return a multipart mime-formatted text otherwise equivalent to this      
	message, with the contents of aStream attached (base64 encoded)."
	| strm |
	strm _ WriteStream on: (String new: 100).
	strm nextPutAll: self asMultipartText;
	" cr; this bungled changeset mailouts. don't restore unless you know what you're doing."
	 nextPutAll: 'Content-Type: application/octet-stream; name="' , aName , '"';
	 cr;
	 nextPutAll: 'Content-Disposition: attachment; filename="' , aName , '"';
	 cr;
	 nextPutAll: 'Content-Transfer-Encoding: base64';
	 cr;
	 cr.
	Base64MimeConverter new dataStream: aStream;
	 mimeStream: strm;
	 mimeEncode.
	strm cr; nextPutAll: '--' , self attachmentSeparator; cr.
	^ strm contents! !

!MailMessage methodsFor: 'multipart' stamp: 'BEO 12/3/2000 16:20'!
attachmentSeparator
	^(self fields at: 'Content-Type') parameters at: 'boundary' ! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:47'!
content
	"returns the text, still encoded"
	^self bodyText! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:13'!
decoderClass
	| encoding |
	encoding _ self fields at: 'content-transfer-encoding' ifAbsent: [^ nil].
	encoding _ encoding mainValue.
	encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter].
	encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter].
	^ nil! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:14'!
excerpt
	"give a very brief excerpt from the text"
	^ self content withSeparatorsCompacted truncateWithElipsisTo: 30! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 22:37'!
parseParts
	"private -- parse the parts of the message and put them in the parts ivar.  If this is not a multipart message, put #() into the ivar"
	| parseStream currLine msgStream messages |
	self body isMultipart ifFalse: [^ parts _ #()].
	parseStream _ ReadStream on: self content.
	currLine _ ''.
	['--*' match: currLine]
		whileFalse: [currLine _ parseStream nextLine].
	separator _ currLine copy.
	msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator.
	messages _ OrderedCollection new.
	[parseStream atEnd]
		whileFalse: 
			[messages add: msgStream upToEnd.
			msgStream skipThisLine].
	parts _ messages collect: [:e | MailMessage from: e]! !

!MailMessage methodsFor: 'multipart' stamp: 'ls 4/30/2000 18:22'!
parts
	parts ifNil: [self parseParts].
	^ parts! !

!MailMessage methodsFor: 'multipart' stamp: 'sbw 1/21/2001 11:14'!
save
	"save the part to a file"
	| fileName file |
	fileName _ self name
				ifNil: ['attachment' , Utilities dateTimeSuffix].
	self body isJpeg
		ifTrue: [fileName _ fileName , '.jpg'].
	self body isGif ifTrue: [fileName _ fileName, '.gif'].
	fileName _ FillInTheBlank request: 'File name for save?' initialAnswer: fileName.
	fileName isEmpty
		ifTrue: [^ nil].
	file _ FileStream newFileNamed: fileName.
	file nextPutAll: self content.
	file close! !


!MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 15:22'!
canonicalFields
	"Break long header fields and escape those containing high-ascii characters according to RFC2047"

	self rewriteFields:
		[ :fName :fValue | 
			(fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]])
				ifFalse: [RFC2047MimeConverter mimeEncode: fName, ': ', fValue]]
		append: [].

! !

!MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 14:07'!
replaceFields: fieldsArray
	"Replace existing fields or append to the header. fieldsArray is an array of entire header lines."

	| found fields |
	fields _ Dictionary new.
	fieldsArray do: [:f | fields at: (f copyUpTo: $:) asLowercase put: f withoutTrailingBlanks].
	found _ Set new.
	self rewriteFields:
		[ :fName :fValue | | fieldString |
			fieldString _ fields at: fName asLowercase ifAbsent: [].
			fieldString ifNotNil: [
				found add: fName asLowercase.
				(fieldString last = $:)
					ifTrue: ['']
					ifFalse: [fieldString]]]
		append: [String streamContents: [:append |
			fields keysAndValuesDo: [:fk :fv | 
				((found includes: fk) or: [fv last = $:])
					ifFalse: [append nextPutAll: fv; cr]]]].

! !

!MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 14:10'!
rewriteFields: aBlock append: appendBlock
	"Rewrite header fields. The body is not modified.
	Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header."

	| old new result appendString |
	old _ ReadStream on: text.
	new _ WriteStream on: (String new: text size).
	self fieldsFrom: old do: [ :fName :fValue |
		result _ aBlock value: fName value: fValue.
		result ifNil: [new nextPutAll: fName, ': ', fValue; cr]
			ifNotNil: [result isEmpty
				ifFalse: [new nextPutAll: result.
					result last = Character cr ifFalse: [new cr]]]].
	appendString _ appendBlock value.
	appendString isEmptyOrNil ifFalse:
		[new nextPutAll: appendString.
		appendString last = Character cr ifFalse: [new cr]].
	new cr. "End of header"
	text _ new contents, old upToEnd.
	self cacheFieldsFrom: (ReadStream on: text) andDo: [:f :n | "Just chache it"]! !


!MailMessage methodsFor: 'testing' stamp: 'sbw 1/21/2001 19:47'!
containsViewableImage
	^self body isJpeg | self body isGif! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MailMessage class
	instanceVariableNames: ''!

!MailMessage class methodsFor: 'instance creation'!
from: aString
	"Initialize a new instance from the given string."

	^(self new) from: aString! !


!MailMessage class methodsFor: 'utilities' stamp: 'mdr 2/18/1999 20:47'!
dateStampNow
	"Return the current date and time formatted as a email Date: line"
	"The result conforms to RFC822 with a long year, e.g.  'Thu, 18 Feb 1999 20:38:51'"

	^	(Date today weekday copyFrom: 1 to: 3), ', ',
		(Date today printFormat: #(1 2 3 $  2 1 1)), ' ',
		Time now print24! !

!MailMessage class methodsFor: 'utilities' stamp: 'ls 4/30/2000 22:58'!
generateSeparator
	"generate a separator usable for making MIME multipart documents.  A leading -- will *not* be included"
	^'==CelesteAttachment' , (10000 to: 99999) atRandom asString , '=='.! !


!MailMessage class methodsFor: 'preferences' stamp: 'mdr 1/24/2000 11:49'!
omittedHeaderFields
	"Reply a list of fields to omit when displaying a nice simple message"

	^ #(
			'comments'
			'priority'
			'disposition-notification-to'
			'x-envelope-info'
			'x-mime-autoconverted'
			'content-id'
			'received'
			'x-accept-language'
			'x-mailer-version'
			'x-unityuser'
			'return-path'
			'newsgroups'
			'message-id'
			'path'
			'in-reply-to'
			'sender'
			'x-sender'
			'fonts'
			'x-mailer'
			'mime-version'
			'x-uidl'
			'status'
			'content-type'
			'content-transfer-encoding'
			'errors-to'
			'keywords'
			'references'
			'x-vms-to'
			'x-delivery-notice'
			'x-reply-of'
			'x-newsreader'
			'x-icon'
			'x-mailing-list'
			'x-loop'
			'x-priority'
			'x-msmail-priority'
			'x-mimeole'
			'x-organization'
			'x-originating-ip'
			'x-sun-charset'
			'x-url'
			'x-nextstep-mailer'
			'x-authentication-warning'
			'x-lotus-fromdomain'
			'x-blackmail'
			'x-authenticated-timestamp'
			'nntp-posting-host'
			'lines'
			'return-receipt-to'
			'precedence'
			'originator'
			'distribution'
			'content-disposition'
			'importance'
			'resent-to'
			'resent-cc'
			'resent-message-id'
			'resent-date'
			'resent-sender'
			'resent-from'
		)
! !
Object subclass: #MailNotifier
	instanceVariableNames: 'socket messageCount lastConnectTime password '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!

!MailNotifier methodsFor: 'accessing' stamp: 'dvf 4/29/2000 21:50'!
messageCount
	"if no socket, try to connect in background, when done, remove socket."
	socket
		ifNil: 
			[socket _ POPSocket new.
			
			[socket serverName: Celeste popServer.
			socket userName: Celeste popUserName.
			socket password: self password.
			"socket addProgressObserver: Transcript."
			([socket connectToPOP]
				on: Error do: 
				[Transcript show: 'Couldn''t connect to POP.';
				 cr. (Delay forSeconds: 180) wait.
				false])
				ifTrue: 
					[messageCount _ socket numMessages.
					socket disconnectFromPOP.
					lastConnectTime _ Time now].
			socket _ nil]
				forkAt: Processor userBackgroundPriority].
	^ messageCount! !
GenericUrl subclass: #MailtoUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MailtoUrl commentStamp: '<historical>' prior: 0!
a URL specifying a mailing address; activating it triggers a mail-sender to start up, if one is present.!


!MailtoUrl methodsFor: 'downloading' stamp: 'sma 6/12/2000 12:15'!
activate
	(Smalltalk includesKey: #Celeste)
		ifFalse: [^ self notify: 'no mail reader present'].
	^ CelesteComposition
		openForCeleste: Celeste current
		initialText: self composeText! !

!MailtoUrl methodsFor: 'downloading' stamp: 'kfr 6/11/2000 16:47'!
composeText
	"Answer the template for a new message."

	^ String streamContents: [:str |
		str nextPutAll: 'From: '.
		str nextPutAll: Celeste userName; cr.
		str nextPutAll: 'To: '.
		str nextPutAll: locator asString; cr.

		str nextPutAll: 'Subject: '; cr.

		Celeste ccList isEmpty ifFalse: [
			str nextPutAll: 'Cc: '.
			str nextPutAll: Celeste ccList; cr].
		str cr].! !
SequenceableCollection subclass: #MappedCollection
	instanceVariableNames: 'domain map '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!MappedCollection commentStamp: '<historical>' prior: 0!
I represent an access mechanism for a sequencable collection re-ordering or filtering its elements.!


!MappedCollection methodsFor: 'accessing'!
at: anIndex

	^domain at: (map at: anIndex)! !

!MappedCollection methodsFor: 'accessing'!
at: anIndex put: anObject

	^domain at: (map at: anIndex) put: anObject! !

!MappedCollection methodsFor: 'accessing'!
contents
	"Answer the receiver's domain for mapping, a Dictionary or 
	SequenceableCollection."

	^map collect: [:mappedIndex | domain at: mappedIndex]! !

!MappedCollection methodsFor: 'accessing'!
size

	^map size! !


!MappedCollection methodsFor: 'adding'!
add: newObject

	self shouldNotImplement! !


!MappedCollection methodsFor: 'copying' stamp: 'RvL 4/28/1999 10:31'!
copy
	"This returns another MappedCollection whereas copyFrom:to: will return
	an object like my domain."

	^self class collection: domain map: map! !


!MappedCollection methodsFor: 'enumerating'!
collect: aBlock 
	"Refer to the comment in Collection|collect:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		aStream nextPut: (aBlock value: domainValue)].
	^aStream contents! !

!MappedCollection methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."

	map do:
		[:mapValue | aBlock value: (domain at: mapValue)]! !

!MappedCollection methodsFor: 'enumerating'!
select: aBlock 
	"Refer to the comment in Collection|select:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		(aBlock value: domainValue)
			ifTrue: [aStream nextPut: domainValue]].
	^aStream contents! !


!MappedCollection methodsFor: 'printing' stamp: 'sma 5/11/2000 19:53'!
storeOn: aStream
	aStream
		nextPut: $(;
		nextPutAll: self class name;
		nextPutAll: ' collection: ';
		store: domain;
		nextPutAll: ' map: ';
		store: map;
		nextPut: $)! !


!MappedCollection methodsFor: 'private'!
setCollection: aCollection map: aDictionary

	domain _ aCollection.
	map _ aDictionary! !

!MappedCollection methodsFor: 'private'!
species

	^domain species! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MappedCollection class
	instanceVariableNames: ''!

!MappedCollection class methodsFor: 'instance creation'!
collection: aCollection map: aSequenceableCollection 
	"Answer an instance of me that maps aCollection by 
	aSequenceableCollection."

	^self basicNew setCollection: aCollection map: aSequenceableCollection! !

!MappedCollection class methodsFor: 'instance creation'!
new

	self error: 'MappedCollections must be created using the collection:map: message'! !

!MappedCollection class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ self collection: aCollection map: (1 to: aCollection size)

"	MappedCollection newFrom: {1. 2. 3}
	{4. 3. 8} as: MappedCollection
"! !
BorderedMorph subclass: #MarqueeMorph
	instanceVariableNames: 'colors count '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!MarqueeMorph commentStamp: '<historical>' prior: 0!
The MarqueeMorph is a subclass of the BorderedMorph which quickly cycles its border color.

The implementation could be simplified and generalized.  The color values and cycle speed are hard-coded for example.!


!MarqueeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/25/1999 21:26'!
initialize

        super initialize.
        colors _ {Color red. Color white. Color blue}.
        count _ 0! !

!MarqueeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/25/1999 21:27'!
step

        count _ count + 1.
        count > colors size ifTrue: [count _ 1].
        self borderColor: (colors at: count)! !

!MarqueeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/25/1999 21:30'!
stepTime
        "Answer the desired time between steps in milliseconds."

        ^ 200! !

!MarqueeMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/25/1999 21:28'!
wantsSteps

        ^ true! !
InterpreterPlugin subclass: #Matrix2x3Plugin
	instanceVariableNames: 'm23ResultX m23ResultY m23ArgX m23ArgY '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:19'!
primitiveComposeMatrix
	| m1 m2 m3 result |
	self export: true.
	self inline: false.
	self var: #m1 declareC:'float *m1'.
	self var: #m2 declareC:'float *m2'.
	self var: #m3 declareC:'float *m3'.
	m3 _ self loadArgumentMatrix: (result _ interpreterProxy stackObjectValue: 0).
	m2 _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	m1 _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3ComposeMatrix: m1 with: m2 into: m3.
	interpreterProxy pop: 3.
	interpreterProxy push: result.! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:19'!
primitiveInvertPoint
	| matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self loadArgumentPoint: (interpreterProxy stackObjectValue: 0).
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3InvertPoint: matrix.
	interpreterProxy failed ifFalse:[self roundAndStoreResultPoint: 2].! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:18'!
primitiveInvertRectInto
	| matrix srcOop dstOop originX originY cornerX cornerY minX maxX minY maxY |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self var: #originX declareC:'double originX'.
	self var: #originY declareC:'double originY'.
	self var: #cornerX declareC:'double cornerX'.
	self var: #cornerY declareC:'double cornerY'.
	self var: #minX declareC:'double minX'.
	self var: #maxX declareC:'double maxX'.
	self var: #minY declareC:'double minY'.
	self var: #maxY declareC:'double maxY'.

	dstOop _ interpreterProxy stackObjectValue: 0.
	srcOop _ interpreterProxy stackObjectValue: 1.
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].

	(interpreterProxy fetchClassOf: srcOop) = (interpreterProxy fetchClassOf: dstOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: srcOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: srcOop) = 2
		ifFalse:[^interpreterProxy primitiveFail].

	"Load top-left point"
	self loadArgumentPoint: (interpreterProxy fetchPointer: 0 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	originX _ m23ArgX.
	originY _ m23ArgY.
	self matrix2x3InvertPoint: matrix.
	minX _ maxX _ m23ResultX.
	minY _ maxY _ m23ResultY.

	"Load bottom-right point"
	self loadArgumentPoint:(interpreterProxy fetchPointer: 1 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	cornerX _ m23ArgX.
	cornerY _ m23ArgY.
	self matrix2x3InvertPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	"Load top-right point"
	m23ArgX _ cornerX.
	m23ArgY _ originY.
	self matrix2x3InvertPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	"Load bottom-left point"
	m23ArgX _ originX.
	m23ArgY _ cornerY.
	self matrix2x3InvertPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	interpreterProxy failed ifFalse:[
		dstOop _ self roundAndStoreResultRect: dstOop x0: minX y0: minY x1: maxX y1: maxY].
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3.
		interpreterProxy push: dstOop.
	].! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:19'!
primitiveIsIdentity
	| matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 0).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 1.
	interpreterProxy pushBool:(
		((matrix at: 0) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 1) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 2) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 3) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 4) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 5) = (self cCoerce: 0.0 to: 'float'))).! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:19'!
primitiveIsPureTranslation
	| matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 0).
	interpreterProxy failed ifTrue:[^nil].
	interpreterProxy pop: 1.
	interpreterProxy pushBool:(
		((matrix at: 0) = (self cCoerce: 1.0 to: 'float')) &
		((matrix at: 1) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 3) = (self cCoerce: 0.0 to: 'float')) &
		((matrix at: 4) = (self cCoerce: 1.0 to: 'float'))).! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:18'!
primitiveTransformPoint
	| matrix |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self loadArgumentPoint: (interpreterProxy stackObjectValue: 0).
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 1).
	interpreterProxy failed ifTrue:[^nil].
	self matrix2x3TransformPoint: matrix.
	self roundAndStoreResultPoint: 2.! !

!Matrix2x3Plugin methodsFor: 'primitives' stamp: 'ar 5/11/2000 23:19'!
primitiveTransformRectInto
	| matrix srcOop dstOop originX originY cornerX cornerY minX maxX minY maxY |
	self export: true.
	self inline: false.
	self var: #matrix declareC:'float *matrix'.
	self var: #originX declareC:'double originX'.
	self var: #originY declareC:'double originY'.
	self var: #cornerX declareC:'double cornerX'.
	self var: #cornerY declareC:'double cornerY'.
	self var: #minX declareC:'double minX'.
	self var: #maxX declareC:'double maxX'.
	self var: #minY declareC:'double minY'.
	self var: #maxY declareC:'double maxY'.

	dstOop _ interpreterProxy stackObjectValue: 0.
	srcOop _ interpreterProxy stackObjectValue: 1.
	matrix _ self loadArgumentMatrix: (interpreterProxy stackObjectValue: 2).
	interpreterProxy failed ifTrue:[^nil].

	(interpreterProxy fetchClassOf: srcOop) = (interpreterProxy fetchClassOf: dstOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy isPointers: srcOop)
		ifFalse:[^interpreterProxy primitiveFail].
	(interpreterProxy slotSizeOf: srcOop) = 2
		ifFalse:[^interpreterProxy primitiveFail].

	"Load top-left point"
	self loadArgumentPoint: (interpreterProxy fetchPointer: 0 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	originX _ m23ArgX.
	originY _ m23ArgY.
	self matrix2x3TransformPoint: matrix.
	minX _ maxX _ m23ResultX.
	minY _ maxY _ m23ResultY.

	"Load bottom-right point"
	self loadArgumentPoint:(interpreterProxy fetchPointer: 1 ofObject: srcOop).
	interpreterProxy failed ifTrue:[^nil].
	cornerX _ m23ArgX.
	cornerY _ m23ArgY.
	self matrix2x3TransformPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	"Load top-right point"
	m23ArgX _ cornerX.
	m23ArgY _ originY.
	self matrix2x3TransformPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	"Load bottom-left point"
	m23ArgX _ originX.
	m23ArgY _ cornerY.
	self matrix2x3TransformPoint: matrix.
	minX _ minX min: m23ResultX.
	maxX _ maxX max: m23ResultX.
	minY _ minY min: m23ResultY.
	maxY _ maxY max: m23ResultY.

	dstOop _ self roundAndStoreResultRect: dstOop x0: minX y0: minY x1: maxX y1: maxY.
	interpreterProxy failed ifFalse:[
		interpreterProxy pop: 3.
		interpreterProxy push: dstOop.
	].! !


!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'ar 9/28/1998 00:55'!
matrix2x3ComposeMatrix: m1 with: m2 into: m3
	"Multiply matrix m1 with m2 and store the result into m3."
	| a11 a12 a13 a21 a22 a23 |
	self var: #m1 declareC:'const float *m1'.
	self var: #m2 declareC:'const float *m2'.
	self var: #m3 declareC:'float *m3'.

	self var: #a11 declareC:'double a11'.
	self var: #a12 declareC:'double a12'.
	self var: #a13 declareC:'double a13'.
	self var: #a21 declareC:'double a21'.
	self var: #a22 declareC:'double a22'.
	self var: #a23 declareC:'double a23'.

	a11 _ ((m1 at: 0) * (m2 at: 0)) + ((m1 at: 1) * (m2 at: 3)).
	a12 _ ((m1 at: 0) * (m2 at: 1)) + ((m1 at: 1) * (m2 at: 4)).
	a13 _ ((m1 at: 0) * (m2 at: 2)) + ((m1 at: 1) * (m2 at: 5)) + (m1 at: 2).
	a21 _ ((m1 at: 3) * (m2 at: 0)) + ((m1 at: 4) * (m2 at: 3)).
	a22 _ ((m1 at: 3) * (m2 at: 1)) + ((m1 at: 4) * (m2 at: 4)).
	a23 _ ((m1 at: 3) * (m2 at: 2)) + ((m1 at: 4) * (m2 at: 5)) + (m1 at: 5).

	m3 at: 0 put: (self cCoerce: a11 to: 'float').
	m3 at: 1 put: (self cCoerce: a12 to: 'float').
	m3 at: 2 put: (self cCoerce: a13 to: 'float').
	m3 at: 3 put: (self cCoerce: a21 to: 'float').
	m3 at: 4 put: (self cCoerce: a22 to: 'float').
	m3 at: 5 put: (self cCoerce: a23 to: 'float').
! !

!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'ar 11/2/1998 03:37'!
matrix2x3InvertPoint: m
	"Invert the pre-loaded argument point by the given matrix"
	| x y det detX detY |
	self var: #m declareC:'float *m'.
	self var: #x declareC:'double x'.
	self var: #y declareC:'double y'.
	self var: #det declareC:'double det'.
	self var: #detX declareC:'double detX'.
	self var: #detY declareC:'double detY'.

	x _ m23ArgX - (m at: 2).
	y _ m23ArgY - (m at: 5).
	det _ ((m at: 0) * (m at: 4)) - ((m at: 1) * (m at: 3)).
	det = 0.0 ifTrue:[^interpreterProxy primitiveFail]."Matrix is singular."
	det _ 1.0 / det.
	detX _ (x * (m at: 4)) - ((m at: 1) * y).
	detY _ ((m at: 0) * y) - (x * (m at: 3)).
	m23ResultX _ detX * det.
	m23ResultY _ detY * det.! !

!Matrix2x3Plugin methodsFor: 'transforming' stamp: 'ar 11/9/1998 16:23'!
matrix2x3TransformPoint: m
	"Transform the pre-loaded argument point by the given matrix"
	self var: #m declareC:'float *m'.
	m23ResultX _ (m23ArgX * (m at: 0)) + (m23ArgY * (m at: 1)) + (m at: 2).
	m23ResultY _ (m23ArgX * (m at: 3)) + (m23ArgY * (m at: 4)) + (m at: 5).! !


!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/9/1998 15:17'!
loadArgumentMatrix: matrix
	"Load the argument matrix"
	self returnTypeC:'float *'.
	interpreterProxy failed ifTrue:[^nil].
	((interpreterProxy isWords: matrix) and:[(interpreterProxy slotSizeOf: matrix) = 6]) 
		ifFalse:[interpreterProxy primitiveFail.
				^nil].
	^self cCoerce: (interpreterProxy firstIndexableField: matrix) to:'float *'.! !

!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/9/1998 16:17'!
loadArgumentPoint: point
	"Load the argument point into m23ArgX and m23ArgY"
	| oop isInt |
	interpreterProxy failed ifTrue:[^nil].
	"Check class of point"
	(interpreterProxy fetchClassOf: point) = (interpreterProxy classPoint) 
		ifFalse:[^interpreterProxy primitiveFail].
	"Load X value"
	oop _ interpreterProxy fetchPointer: 0 ofObject: point.
	isInt _ interpreterProxy isIntegerObject: oop.
	(isInt or:[interpreterProxy isFloatObject: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	isInt
		ifTrue:[m23ArgX _ interpreterProxy integerValueOf: oop]
		ifFalse:[m23ArgX _ interpreterProxy floatValueOf: oop].

	"Load Y value"
	oop _ interpreterProxy fetchPointer: 1 ofObject: point.
	isInt _ interpreterProxy isIntegerObject: oop.
	(isInt or:[interpreterProxy isFloatObject: oop])
		ifFalse:[^interpreterProxy primitiveFail].
	isInt
		ifTrue:[m23ArgY _ interpreterProxy integerValueOf: oop]
		ifFalse:[m23ArgY _ interpreterProxy floatValueOf: oop].

! !

!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/14/1998 02:37'!
okayIntValue: value
	^(value >= -1073741824 asFloat and:[m23ResultX <= 1073741823 asFloat]) 
! !

!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/14/1998 02:39'!
roundAndStoreResultPoint: nItemsToPop
	"Store the result of a previous operation.
	Fail if we cannot represent the result as SmallInteger"
	m23ResultX _ m23ResultX + 0.5.
	m23ResultY _ m23ResultY + 0.5.
	(self okayIntValue: m23ResultX) ifFalse:[^interpreterProxy primitiveFail].
	(self okayIntValue: m23ResultY) ifFalse:[^interpreterProxy primitiveFail].
	interpreterProxy pop: nItemsToPop.
	interpreterProxy push:
		(interpreterProxy makePointwithxValue: m23ResultX asInteger 
							yValue: m23ResultY asInteger).! !

!Matrix2x3Plugin methodsFor: 'private' stamp: 'ar 11/14/1998 02:38'!
roundAndStoreResultRect: dstOop x0: x0 y0: y0 x1: x1 y1: y1
	"Check, round and store the result of a rectangle operation"
	| minX maxX minY maxY originOop cornerOop rectOop |
	self var: #x0 declareC:'double x0'.
	self var: #y0 declareC:'double y0'.
	self var: #x1 declareC:'double x1'.
	self var: #y1 declareC:'double y1'.
	self var: #minX declareC:'double minX'.
	self var: #maxX declareC:'double maxX'.
	self var: #minY declareC:'double minY'.
	self var: #maxY declareC:'double maxY'.

	minX _ x0 + 0.5.
	(self okayIntValue: minX) ifFalse:[^interpreterProxy primitiveFail].
	maxX _ x1 + 0.5.
	(self okayIntValue: maxX) ifFalse:[^interpreterProxy primitiveFail].
	minY _ y0 + 0.5.
	(self okayIntValue: minY) ifFalse:[^interpreterProxy primitiveFail].
	maxY _ y1 + 0.5.
	(self okayIntValue: maxY) ifFalse:[^interpreterProxy primitiveFail].

	interpreterProxy pushRemappableOop: dstOop.
	originOop _ interpreterProxy makePointwithxValue: minX asInteger yValue: minY asInteger.
	interpreterProxy pushRemappableOop: originOop.
	cornerOop _ interpreterProxy makePointwithxValue: maxX asInteger yValue: maxY asInteger.
	originOop _ interpreterProxy popRemappableOop.
	rectOop _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: rectOop withValue: originOop.
	interpreterProxy storePointer: 1 ofObject: rectOop withValue: cornerOop.
	^rectOop! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Matrix2x3Plugin class
	instanceVariableNames: ''!

!Matrix2x3Plugin class methodsFor: 'class initialization' stamp: 'sma 3/3/2000 12:39'!
declareCVarsIn: cg 
	cg var: #m23ResultX type: #double.
	cg var: #m23ResultY type: #double.
	cg var: #m23ArgX type: #double.
	cg var: #m23ArgY type: #double! !
DisplayTransform variableWordSubclass: #MatrixTransform2x3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!MatrixTransform2x3 commentStamp: '<historical>' prior: 0!
This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive.

Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).!


!MatrixTransform2x3 methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:17'!
setIdentiy
	"Initialize the receiver to the identity transformation (e.g., not affecting points)"
	self
		a11: 1.0; a12: 0.0; a13: 0.0;
		a21: 0.0; a22: 1.0; a23: 0.0.! !


!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index
	<primitive: 'primitiveAt' module: 'FloatArrayPlugin'>
	^Float fromIEEE32Bit: (self basicAt: index)! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'!
at: index put: value
	<primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'>
	value isFloat 
		ifTrue:[self basicAt: index put: value asIEEE32BitWord]
		ifFalse:[self at: index put: value asFloat].
	^value! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/18/1998 14:03'!
inverseTransformation
	"Return the inverse transformation of the receiver.
	The inverse transformation is computed by first calculating
	the inverse offset and then computing transformations
	for the two identity vectors (1@0) and (0@1)"
	| r1 r2 r3 m |
	r3 _ self invertPoint: 0@0.
	r1 _ (self invertPoint: 1@0) - r3.
	r2 _ (self invertPoint: 0@1) - r3.
	m _ self species new.
	m
		a11: r1 x; a12: r2 x; a13: r3 x;
		a21: r1 y; a22: r2 y; a23: r3 y.
	^m! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:19'!
offset
	^self a13 @ self a23! !

!MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'!
offset: aPoint
	self a13: aPoint x asFloat.
	self a23: aPoint y asFloat.! !


!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a11
	^self at: 1! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a11: value
	 self at: 1 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a12
	^self at: 2! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a12: value
	 self at: 2 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a13
	^self at: 3! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a13: value
	 self at: 3 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a21
	 ^self at: 4! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a21: value
	 self at: 4 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a22
	 ^self at: 5! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a22: value
	 self at: 5 put: value! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'!
a23
	 ^self at: 6! !

!MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'!
a23: value
	 self at: 6 put: value! !


!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."
	<primitive: 'primitiveIsIdentity' module: 'Matrix2x3Plugin'>
	^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:15'!
isMatrixTransform2x3
	"Return true if the receiver is 2x3 matrix transformation"
	^true! !

!MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 2/2/2001 15:47'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."
	<primitive: 'primitiveIsPureTranslation' module: 'Matrix2x3Plugin'>
	^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! !


!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'!
= aMatrixTransform2x3 
	| length |
	<primitive: 'primitiveEqual' module: 'FloatArrayPlugin'>
	self class = aMatrixTransform2x3 class ifFalse: [^ false].
	length _ self size.
	length = aMatrixTransform2x3 size ifFalse: [^ false].
	1 to: self size do: [:i | (self at: i)
			= (aMatrixTransform2x3 at: i) ifFalse: [^ false]].
	^ true! !

!MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 2/2/2001 15:47'!
hash
	| result |
	<primitive: 'primitiveHash' module: 'FloatArrayPlugin'>
	result _ 0.
	1 to: self size do:[:i| result _ result + (self basicAt: i) ].
	^result bitAnd: 16r1FFFFFFF! !


!MatrixTransform2x3 methodsFor: 'composing' stamp: 'RAA 9/20/2000 13:10'!
composedWithLocal: aTransformation
	"Return the composition of the receiver and the local transformation passed in"
	aTransformation isMatrixTransform2x3 ifFalse:[^super composedWithLocal: aTransformation].
	^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! !

!MatrixTransform2x3 methodsFor: 'composing' stamp: 'ar 2/2/2001 15:47'!
composedWithLocal: aTransformation into: result
	"Return the composition of the receiver and the local transformation passed in.
	Store the composed matrix into result."
	| a11 a12 a13 a21 a22 a23 b11 b12 b13 b21 b22 b23 matrix |
	<primitive: 'primitiveComposeMatrix' module: 'Matrix2x3Plugin'>
	matrix _ aTransformation asMatrixTransform2x3.
	a11 _ self a11.		b11 _ matrix a11.
	a12 _ self a12.		b12 _ matrix a12.
	a13 _ self a13.		b13 _ matrix a13.
	a21 _ self a21.		b21 _ matrix a21.
	a22 _ self a22.		b22 _ matrix a22.
	a23 _ self a23.		b23 _ matrix a23.
	result a11: (a11 * b11) + (a12 * b21).
	result a12: (a11 * b12) + (a12 * b22).
	result a13: a13 + (a11 * b13) + (a12 * b23).
	result a21: (a21 * b11) + (a22 * b21).
	result a22: (a21 * b12) + (a22 * b22).
	result a23: a23 + (a21 * b13) + (a22 * b23).
	^result! !


!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	<primitive: 'primitiveInvertPoint' module: 'Matrix2x3Plugin'>
	^(self invertPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/16/1998 23:46'!
invertPoint: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	| x y det a11 a12 a21 a22 detX detY |
	x _ aPoint x asFloat - (self a13).
	y _ aPoint y asFloat - (self a23).
	a11 _ self a11.	a12 _ self a12.
	a21 _ self a21.	a22 _ self a22.
	det _ (a11 * a22) - (a12 * a21).
	det = 0.0 ifTrue:[^0@0]. "So we have at least a valid result"
	det _ 1.0 / det.
	detX _ (x * a22) - (a12 * y).
	detY _ (a11 * y) - (x * a21).
	^(detX * det) @ (detY * det)! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 2/2/2001 15:47'!
localPointToGlobal: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	<primitive: 'primitiveTransformPoint' module: 'Matrix2x3Plugin'>
	^(self transformPoint: aPoint) rounded! !

!MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/2/1998 23:09'!
transformPoint: aPoint
	"Transform aPoint from local coordinates into global coordinates"
	| x y |
	x _ (aPoint x * self a11) + (aPoint y * self a12) + self a13.
	y _ (aPoint x * self a21) + (aPoint y * self a22) + self a23.
	^x @ y! !


!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'!
globalBounds: srcRect toLocal: dstRect
	"Transform aRectangle from global coordinates into local coordinates"
	<primitive: 'primitiveInvertRectInto' module: 'Matrix2x3Plugin'>
	^super globalBoundsToLocal: srcRect! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'!
globalBoundsToLocal: aRectangle
	"Transform aRectangle from global coordinates into local coordinates"
	^self globalBounds: aRectangle toLocal: Rectangle new! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 2/2/2001 15:47'!
localBounds: srcRect toGlobal: dstRect
	"Transform aRectangle from local coordinates into global coordinates"
	<primitive: 'primitiveTransformRectInto' module: 'Matrix2x3Plugin'>
	^super localBoundsToGlobal: srcRect! !

!MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'!
localBoundsToGlobal: aRectangle
	"Transform aRectangle from local coordinates into global coordinates"
	^self localBounds: aRectangle toGlobal: Rectangle new! !


!MatrixTransform2x3 methodsFor: 'converting' stamp: 'ar 11/2/1998 15:34'!
asMatrixTransform2x3
	^self! !


!MatrixTransform2x3 methodsFor: 'printing'!
encodePostscriptOn: aStream
	aStream writeMatrix:self.
! !

!MatrixTransform2x3 methodsFor: 'printing' stamp: 'ar 11/2/1998 23:11'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut: $(;
		cr; print: self a11; tab; print: self a12; tab; print: self a13;
		cr; print: self a21; tab; print: self a22; tab; print: self a23;
		cr; nextPut:$).! !


!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'!
setAngle: angle
	"Set the raw rotation angle in the receiver"
	| rad s c |
	rad := angle degreesToRadians.
	s := rad sin.
	c := rad cos.
	self a11: c.
	self a12: s negated.
	self a21: s.
	self a22: c.! !

!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'!
setOffset: aPoint
	"Set the raw offset in the receiver"
	| pt |
	pt _ aPoint asPoint.
	self a13: pt x asFloat.
	self a23: pt y asFloat.! !

!MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:16'!
setScale: aPoint
	"Set the raw scale in the receiver"
	| pt |
	pt _ aPoint asPoint.
	self a11: pt x asFloat.
	self a22: pt y asFloat.! !


!MatrixTransform2x3 methodsFor: 'encoding' stamp: 'ls 10/9/1999 19:03'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^String streamContents: [ :str |
		str nextPutAll: 'Matrix,'.
		1 to: 6 do: [ :i |
			str print: (self basicAt: i).
			str nextPut: $, ].
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MatrixTransform2x3 class
	instanceVariableNames: ''!

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ls 10/9/1999 19:51'!
fromRemoteCanvasEncoding: encoded
	"DisplayTransform fromRemoteCanvasEncoding:  'Matrix,1065353216,0,1137541120,0,1065353216,1131610112,'"
	| nums transform encodedNums |
	"split the numbers up"
	encodedNums _ encoded findTokens: ','.

	"remove the initial 'Matrix' specification"
	encodedNums _ encodedNums asOrderedCollection.
	encodedNums removeFirst.

	"parse the numbers"
	nums _ encodedNums collect: [ :enum |
		Integer readFromString: enum ].

	"create an instance"
	transform _ self new.

	"plug in the numbers"
	nums doWithIndex: [ :num :i |
		transform basicAt: i put: num ].

	^transform! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 22:50'!
identity
	^self new setScale: 1.0! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 7/9/1998 20:09'!
new
	^self new: 6! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 01:25'!
transformFromLocal: localBounds toGlobal: globalBounds
	^((self withOffset: (globalBounds center)) composedWithLocal:
		(self withScale: (globalBounds extent / localBounds extent) asFloatPoint))
			composedWithLocal: (self withOffset: localBounds center negated)
"
	^(self identity)
		setScale: (globalBounds extent / localBounds extent) asFloatPoint;
		setOffset: localBounds center negated asFloatPoint;
		composedWithGlobal:(self withOffset: globalBounds center asFloatPoint)
"! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'!
withAngle: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'!
withOffset: aPoint
	^self identity setOffset: aPoint! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:17'!
withRotation: angle
	^self new setAngle: angle! !

!MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'!
withScale: aPoint
	^self new setScale: aPoint! !
Morph subclass: #MatrixTransformMorph
	instanceVariableNames: 'transform '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Geometry'!

!MatrixTransformMorph methodsFor: 'initialize' stamp: 'ar 11/15/1998 22:21'!
asFlexOf: aMorph
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."
	self addMorph: aMorph.
	self computeBounds! !


!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 10/25/2000 17:49'!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: self referencePosition color: Color lightGray icon: nil on: #mouseMove send: #changeRotationCenter:with: to: self! !

!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:50'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #changeRotationCenter:with:
		ifTrue:[^'set center of rotation'].
	^super balloonHelpTextForHandle: aHandle! !

!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:16'!
transform
	^transform ifNil:[MatrixTransform2x3 identity]! !

!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:51'!
transform: aMatrixTransform
	transform _ aMatrixTransform.
	self computeBounds.! !

!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:52'!
visible
	extension == nil ifTrue:[^true].
	^extension visible! !

!MatrixTransformMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 21:51'!
visible: aBool
	extension == nil ifTrue:[
		aBool ifTrue:[^self].
		self assureExtension].
	extension visible: aBool.! !



!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 22:17'!
boundsChangedFrom: oldBounds to: newBounds
	transform ifNil:[transform _ MatrixTransform2x3 identity].
	oldBounds extent = newBounds extent ifFalse:[
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withOffset: oldBounds origin negated).
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withScale: newBounds extent / oldBounds extent).
		transform _ transform composedWithGlobal:
			(MatrixTransform2x3 withOffset: newBounds origin).
	].
	transform offset: transform offset + (newBounds origin - oldBounds origin)! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 22:01'!
computeBounds
	| subBounds |
	(submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self].
	bounds _ nil.
	submorphs do:[:m|
		subBounds _ self transform localBoundsToGlobal: m bounds.
		bounds 
			ifNil:[bounds _ subBounds]
			ifNotNil:[bounds _ bounds quickMerge: subBounds].
	].
	bounds ifNil:[bounds _ 0@0 corner: 20@20].
	fullBounds _ bounds.! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 1/15/1999 16:34'!
containsPoint: aPoint
	self visible ifFalse:[^false].
	(bounds containsPoint: aPoint) ifFalse: [^ false].
	self hasSubmorphs
		ifTrue: [self submorphsDo: 
					[:m | (m fullContainsPoint: (self transform globalPointToLocal: aPoint))
							ifTrue: [^ true]].
				^ false]
		ifFalse: [^ true]! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
extent: extent
	self handleBoundsChange:[super extent: extent]! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
fullBounds
	| subBounds |
	fullBounds ifNil:[
		fullBounds _ self bounds.
		submorphs do:[:m|
			subBounds _ (self transform localBoundsToGlobal: m fullBounds).
			fullBounds _ fullBounds quickMerge: subBounds.
		].
	].
	^fullBounds! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
fullContainsPoint: aPoint
	| p |
	self visible ifFalse:[^false].
	(self fullBounds containsPoint: aPoint) ifFalse:[^false].
	(self containsPoint: aPoint) ifTrue:[^true].
	p _ self transform globalPointToLocal: aPoint.
	submorphs do:[:m|
		(m fullContainsPoint: p) ifTrue:[^true].
	].
	^false! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 21:52'!
handleBoundsChange: aBlock
	| oldBounds newBounds |
	oldBounds _ bounds.
	aBlock value.
	newBounds _ bounds.
	self boundsChangedFrom: oldBounds to: newBounds.! !

!MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 22:14'!
privateFullMoveBy: delta
	self handleBoundsChange:[super privateMoveBy: delta]! !


!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:51'!
changed
	^self invalidRect: (self fullBounds insetBy: -1)! !

!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 22:20'!
drawOn: aCanvas! !

!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:01'!
drawSubmorphsOn: aCanvas
	aCanvas asBalloonCanvas transformBy: self transform
		during:[:myCanvas| super drawSubmorphsOn: myCanvas].! !

!MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:44'!
invalidRect: rect from: aMorph
	aMorph == self
		ifTrue:[super invalidRect: rect from: self]
		ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].! !


!MatrixTransformMorph methodsFor: 'events' stamp: 'ar 9/12/2000 01:22'!
transformFrom: uberMorph
	(owner isNil or:[self == uberMorph]) ifTrue:[^self transform].
	^(owner transformFrom: uberMorph) asMatrixTransform2x3 composedWithLocal: self transform! !


!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'!
addFlexShell
	"No flex shell necessary"
	self lastRotationDegrees: 0.0.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:19'!
changeRotationCenter: evt with: rotHandle
	| pos |
	pos _ evt cursorPoint.
	rotHandle referencePosition: pos.
	self referencePosition: pos.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'!
hasNoScaleOrRotation
	^true! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
isFlexMorph
	^false! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
lastRotationDegrees
	^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
lastRotationDegrees: deg
	deg = 0.0 
		ifTrue:[self removeProperty: #lastRotationDegrees]
		ifFalse:[self setProperty: #lastRotationDegrees toValue: deg]! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:20'!
referencePosition
	| refPos |
	refPos _ self valueOfProperty: #referencePosition.
	refPos ifNil:[refPos _ self transform globalPointToLocal: super referencePosition].
	^self transformFromWorld localPointToGlobal: refPos! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:18'!
referencePosition: pos
	self setProperty: #referencePosition toValue: 
		(self transformFromWorld globalPointToLocal: pos)! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
removeFlexShell
	"Do nothing"! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/16/1998 01:14'!
rotateBy: delta
	| pt m |
	delta = 0.0 ifTrue:[^self].
	self changed.
	pt _ self transformFromWorld globalPointToLocal: self referencePosition.
	m _ MatrixTransform2x3 withOffset: pt.
	m _ m composedWithLocal: (MatrixTransform2x3 withAngle: delta).
	m _ m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated).
	transform _ self transform composedWithLocal: m.
	self computeBounds.
	self changed.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'!
rotationDegrees: degrees
	| last delta |
	last _ self lastRotationDegrees.
	delta _ degrees - last.
	self rotateBy: delta.
	self lastRotationDegrees: degrees.! !

!MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 10/6/2000 15:37'!
transformedBy: aTransform
	self transform: (self transform composedWithGlobal: aTransform).! !
StringMorph subclass: #MenuItemMorph
	instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments '
	classVariableNames: 'SubMenuMarker '
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MenuItemMorph commentStamp: '<historical>' prior: 0!
I represent an item in a menu.

Instance variables:
	isEnabled 	<Boolean>	True if the menu item can be executed.
	subMenu 	<MenuMorph | nil>	The submenu to activate automatically when the user mouses over the item.
	isSelected 	<Boolean>	True if the item is currently selected.
	target 		<Object>		The target of the associated action.
	selector 	<Symbol>	The associated action.
	arguments 	<Array>		The arguments for the associated action.!


!MenuItemMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 02:05'!
deleteIfPopUp: evt
	"Recurse up for nested pop ups"
	owner ifNotNil:[owner deleteIfPopUp: evt].! !

!MenuItemMorph methodsFor: 'initialization' stamp: 'ar 11/8/2000 23:08'!
initialize

	super initialize.
	bounds _ 0@0 extent: 10@10.
	color _ Color black.
	contents _ ''.
	hasFocus _ false.
	isEnabled _ true.
	subMenu _ nil.
	isSelected _ false.
	target _ nil.
	selector _ nil.
	arguments _ nil.
	font _ Preferences standardMenuFont.
	self hResizing: #spaceFill; vResizing: #shrinkWrap.! !


!MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 6/14/2000 18:45'!
adaptToWorld: aWorld

        super adaptToWorld: aWorld.
        (target isKindOf: Presenter) ifTrue: [^self target: aWorld presenter].
        (target isKindOf: TheWorldMenu) ifTrue: [^target adaptToWorld: aWorld].
        target isMorph ifTrue: [
                target isWorldMorph ifTrue: [self target: aWorld].
                target isHandMorph ifTrue: [self target: aWorld primaryHand]
        ].! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:20'!
allWordingsNotInSubMenu: verbotenSubmenuContents
	"Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in a submenu whose tag is given by verbotenSubmenuContents"
	self isStayUpItem ifTrue:[^#()].
	subMenu ifNotNil:[^subMenu allWordingsNotInSubMenu: verbotenSubmenuContents].
	self contents asString = verbotenSubmenuContents ifTrue:[^#()].
	^Array with: self contents asString! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
arguments

	^ arguments
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
arguments: aCollection

	arguments _ aCollection.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'!
contentString
	^self valueOfProperty: #contentString! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'!
contentString: aString
	aString == nil
		ifTrue:[self removeProperty: #contentString]
		ifFalse:[self setProperty: #contentString toValue: aString]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/17/2000 18:32'!
contents: aString
	^self contents: aString withMarkers: true! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:57'!
contents: aString withMarkers: aBool
	^self contents: aString withMarkers: aBool inverse: false! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 17:02'!
contents: aString withMarkers: aBool inverse: inverse
	"Set the menu item entry. If aBool is true, parse aString for embedded markers."
	| markerIndex marker indent |
	self contentString: nil. "get rid of old"
	aBool ifFalse:[^super contents: aString].
	self removeAllMorphs. "get rid of old markers if updating"
	(aString at: 1) = $< ifFalse:[^super contents: aString].
	markerIndex _ aString indexOf: $>.
	markerIndex = 0 ifTrue:[^super contents: aString].
	marker _ (aString copyFrom: 1 to: markerIndex) asLowercase.
	(#('<on>' '<off>' '<yes>' '<no>') includes: marker) ifFalse:[^super contents: aString].
	self contentString: aString. "remember actual string"
	(marker = '<on>' or:[marker = '<yes>']) ~= inverse
		ifTrue:[marker _ self onImage]
		ifFalse:[marker _ self offImage].
	"Indent the string using white spaces"
	indent _ ' '.
	font _ self fontToUse.
	[ (font widthOfString: indent) < (marker width + 4) ] 
		whileTrue:[indent _ indent copyWith: Character space].
	"Set the string"
	super contents: indent, (aString copyFrom: markerIndex+1 to: aString size).
	"And set the marker"
	marker _ ImageMorph new image: marker.
	marker position: (self left) @ (self top + 2).
	self addMorphFront: marker.! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:40'!
hasSubMenu
	"Return true if the receiver has a submenu"
	^subMenu notNil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'!
hasSubMenu: aMenuMorph
	subMenu ifNil:[^false].
	subMenu == aMenuMorph ifTrue:[^true].
	^subMenu hasSubMenu: aMenuMorph! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
isEnabled

	^ isEnabled
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
isEnabled: aBoolean

	isEnabled = aBoolean ifTrue: [^ self].
	isEnabled _ aBoolean.
	self color: (aBoolean ifTrue: [Color black] ifFalse: [Color gray]).
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:24'!
isStayUpItem

	^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'!
itemWithWording: wording
	"If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
	(self contents asString sameAs: wording) ifTrue:[^self].
	subMenu ifNotNil:[^subMenu itemWithWording: wording].
	^nil! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
selector

	^ selector
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
selector: aSymbol

	selector _ aSymbol.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
subMenu

	^ subMenu
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
subMenu: aMenuMorph

	subMenu _ aMenuMorph.
	self changed.
! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
target

	^ target! !

!MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
target: anObject

	target _ anObject.
! !


!MenuItemMorph methodsFor: 'drawing' stamp: 'sma 6/5/2000 14:50'!
drawOn: aCanvas
	| selectionColor |
	isSelected & isEnabled
		ifTrue:
			[selectionColor _ Display depth <= 2
				ifTrue: [Color gray]
				ifFalse: [owner color darker].
			aCanvas fillRectangle: self bounds color: selectionColor].
	super drawOn: aCanvas.
	subMenu ifNotNil:
		[aCanvas
			paintImage: SubMenuMarker
			at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! !


!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:38'!
activateOwnerMenu: evt
	"Activate our owner menu; e.g., pass control to it"
	owner ifNil:[^false]. "not applicable"
	(owner fullContainsPoint: evt position) ifFalse:[^false].
	owner activate: evt.
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:37'!
activateSubmenu: evt
	"Activate our submenu; e.g., pass control to it"
	subMenu ifNil:[^false]. "not applicable"
	(subMenu fullContainsPoint: evt position) ifFalse:[^false].
	subMenu activate: evt.
	self removeAlarm: #deselectTimeOut:.
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:50'!
deselectTimeOut: evt
	"Deselect timout. Now really deselect"
	owner selectedItem == self ifTrue:[owner selectItem: nil event: evt].! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 22:45'!
handleMouseUp: anEvent
	"The handling of control between menu item requires them to act on mouse up even if not the current focus. This is different from the default behavior which really only wants to handle mouse ups when they got mouse downs before"
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	anEvent blueButtonChanged
		ifTrue:[self blueButtonUp: anEvent]
		ifFalse:[self mouseUp: anEvent].! !

!MenuItemMorph methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/16/2000 14:40'!
handlesMouseOver: anEvent
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/18/2000 21:46'!
handlesMouseOverDragging: evt
	^true! !

!MenuItemMorph methodsFor: 'events' stamp: 'RAA 1/18/2001 18:21'!
invokeWithEvent: evt
	"Perform the action associated with the given menu item."

	| selArgCount w |
	self isEnabled ifFalse: [^ self].
	target class == HandMorph ifTrue: [(self notObsolete) ifFalse: [^ self]].
	owner ifNotNil:[self isStayUpItem ifFalse:[
		self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world."
		(w _ self world) ifNotNil:[
			owner deleteIfPopUp: evt.
			"Repair damage before invoking the action for better feedback"
			w displayWorldSafely]]].
	selector ifNil:[^self].
	Cursor normal showWhile: [  "show cursor in case item opens a new MVC window"
		(selArgCount _ selector numArgs) = 0
			ifTrue:
				[target perform: selector]
			ifFalse:
				[selArgCount = arguments size
					ifTrue: [target perform: selector withArguments: arguments]
					ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]].! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:26'!
mouseDown: evt
	"Handle a mouse down event. Menu items get activated when the mouse is over them."

	evt shiftPressed ifTrue: [^ super mouseDown: evt].  "enable label editing" 
	evt hand newMouseFocus: owner. "Redirect to menu for valid transitions"
	owner selectItem: self event: evt.! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 9/17/2000 20:33'!
mouseEnter: evt
	owner stayUp ifFalse:[self mouseEnterDragging: evt].! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:24'!
mouseEnterDragging: evt
	"The mouse entered the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	evt hand mouseFocus == owner ifTrue:[owner selectItem: self event: evt]! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/9/2000 16:07'!
mouseLeave: evt
	owner stayUp ifFalse:[self mouseLeaveDragging: evt].! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 00:25'!
mouseLeaveDragging: evt
	"The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	evt hand mouseFocus == owner ifFalse:[^self].
	"If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item"
	subMenu == nil
		ifTrue:[owner selectItem: nil event: evt]
		ifFalse:[self addAlarm: #deselectTimeOut: with: evt after: 500].! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 1/16/2001 17:39'!
mouseUp: evt
	"Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
	evt hand mouseFocus == owner ifFalse:[^self].
	self contentString ifNotNil:[
		self contents: self contentString withMarkers: true inverse: true.
		self refreshWorld.
		(Delay forMilliseconds: 200) wait].
	self deselect: evt.
	self invokeWithEvent: evt.		
! !

!MenuItemMorph methodsFor: 'events' stamp: 'ar 10/10/2000 02:18'!
receiveNewFocus: evt
	"Obsolete. Left in for not getting errors during the update where this entire stuff is removed."
	evt hand releaseKeyboardFocus.
	self flag: #arNote. "Remove it"! !


!MenuItemMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:46'!
minHeight

	^ self fontToUse height! !

!MenuItemMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:46'!
minWidth

	| scanner |
	scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse.
	^ (scanner stringWidth: contents) + (subMenu == nil ifTrue: [0] ifFalse: [10])
! !


!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/18/2000 10:27'!
notObsolete
	"Provide backward compatibility with messages being sent to the Hand.  Remove this when no projects made prior to 2.9 are likely to be used.  If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu."

	(HandMorph canUnderstand: (selector)) ifTrue: [^ true]. 	"a modern one"

	self inform: 'This world menu is obsolete.
Please dismiss the menu and open a new one.'.
	^ false
! !

!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/17/2000 18:36'!
offImage
	"Return the form to be used for indicating an '<off>' marker"
	| form |
	form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16.
	(form getCanvas)
		frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.9) 
			borderWidth: 1 borderColor: Color black.
	^form! !

!MenuItemMorph methodsFor: 'private' stamp: 'ar 9/19/2000 09:34'!
onImage
	"Return the form to be used for indicating an '<off>' marker"
	| form |
	form _ Form extent: (self fontToUse ascent-2) asPoint depth: 16.
	(form getCanvas)
		frameAndFillRectangle: form boundingBox fillColor: (Color gray: 0.8) 
			borderWidth: 1 borderColor: Color black;
		fillRectangle: (form boundingBox insetBy: 2) fillStyle: Color black.
	^form! !


!MenuItemMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:54'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!MenuItemMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 11:57'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
isEnabled _ isEnabled veryDeepCopyWith: deepCopier.
subMenu _ subMenu veryDeepCopyWith: deepCopier.
isSelected _ isSelected veryDeepCopyWith: deepCopier.
"target _ target.		Weakly copied"
"selector _ selector.		a Symbol"
arguments _ arguments.		"All weakly copied"! !


!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 10/10/2000 01:39'!
deselect: evt
	self isSelected: false.
	subMenu ifNotNil: [
		owner ifNotNil:[owner activeSubmenu: nil].
		self removeAlarm: #deselectTimeOut:].! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 11:09'!
isSelected: aBoolean

	isSelected _ aBoolean.
	self changed.
! !

!MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 12:17'!
select: evt
	self isSelected: true.
	owner activeSubmenu: subMenu.
	subMenu ifNotNil: [
		subMenu delete.
		subMenu
			popUpAdjacentTo: (Array with: self bounds topRight + (10@0)
									with: self bounds topLeft)
			forHand: evt hand
			from: self.
		subMenu selectItem: nil event: evt].! !


!MenuItemMorph methodsFor: 'grabbing' stamp: 'ar 10/13/2000 10:36'!
aboutToBeGrabbedBy: aHand
	"Don't allow the receiver to act outside a Menu"
	| menu box |
	(owner notNil and:[owner submorphs size = 1]) ifTrue:[
		"I am a lonely menuitem already; just grab my owner"
		owner stayUp: true.
		^owner 	aboutToBeGrabbedBy: aHand].
	box _ self bounds.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: self.
	menu bounds: box.
	menu stayUp: true.
	^menu! !

!MenuItemMorph methodsFor: 'grabbing' stamp: 'ar 1/15/2001 20:44'!
duplicateMorph: evt
	"Make and return a duplicate of the receiver's argument"
	| dup menu |
	dup _ self duplicate.
	menu _ MenuMorph new defaultTarget: nil.
	menu addMorphFront: dup.
	menu bounds: self bounds.
	menu stayUp: true.
	evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here"
	^menu! !



!MenuItemMorph methodsFor: 'meta actions' stamp: 'ar 10/10/2000 02:13'!
wantsHaloFromClick
	"Only if I'm not a lonely submenu"
	^owner notNil and:[owner submorphs size > 1]! !


!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:58'!
hResizing
	"Default to #spaceFill"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#spaceFill] ifNotNil:[props hResizing].! !

!MenuItemMorph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:59'!
vResizing
	"Default to #shrinkWrap"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#shrinkWrap] ifNotNil:[props vResizing].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MenuItemMorph class
	instanceVariableNames: ''!

!MenuItemMorph class methodsFor: 'class initialization' stamp: 'jm 11/16/97 09:17'!
initialize
	"MenuItemMorph initialize"

	| f |
	f _ Form
		extent: 5@9
		fromArray: #(2147483648 3221225472 3758096384 4026531840 4160749568 4026531840 3758096384 3221225472 2147483648)
		offset: 0@0.
	SubMenuMarker _ ColorForm mappingWhiteToTransparentFrom: f.
! !
Morph subclass: #MenuLineMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!

!MenuLineMorph methodsFor: 'drawing' stamp: 'sw 7/14/1999 10:14'!
drawOn: aCanvas
	| pref |
	aCanvas
		fillRectangle: (bounds topLeft corner: bounds rightCenter)
		color: ((pref _ Preferences menuColorFromWorld)
					ifTrue:
						[owner color darker]
					ifFalse:
						[Preferences menuLineUpperColor]).
	aCanvas
		fillRectangle: (bounds leftCenter corner: bounds bottomRight)
		color: (pref
					ifTrue:
						[owner color lighter]
					ifFalse:
						[Preferences menuLineLowerColor])! !


!MenuLineMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:46'!
minHeight

	^ 2
! !

!MenuLineMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:46'!
minWidth

	^ 10
! !


!MenuLineMorph methodsFor: 'initialize' stamp: 'ar 11/8/2000 23:09'!
initialize
	super initialize.
	self hResizing: #spaceFill; vResizing: #spaceFill.! !
AlignmentMorph subclass: #MenuMorph
	instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!MenuMorph commentStamp: '<historical>' prior: 0!
Instance variables:
	defaultTarget 	<Object>				The default target for creating menu items
	selectedItem		<MenuItemMorph> 	The currently selected item in the receiver
	stayUp 			<Boolean>			True if the receiver should stay up after clicks
	popUpOwner 	<MenuItemMorph>	The menu item that automatically invoked the receiver, if any.
	activeSubMenu 	<MenuMorph>		The currently active submenu.!


!MenuMorph methodsFor: 'accessing' stamp: 'sw 12/1/1999 13:05'!
allWordings
	| verboten |
	"Answer a collection of the wordings of all items and subitems, omitting debug menu"
	verboten _ Preferences debugMenuItemsInvokableFromScripts 
		ifTrue:	[nil]
		ifFalse:	['debug...'].
	^ self allWordingsNotInSubMenu: verboten! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:17'!
allWordingsNotInSubMenu: verbotenSubmenuContents
	"Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in a submenu whose tag is given by erbotenSubmenuContents"
	| aList |
	aList _ OrderedCollection new.
	self items do:[:anItem | aList addAll: (anItem allWordingsNotInSubMenu: verbotenSubmenuContents)].
	^aList! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 13:19'!
defaultTarget
	^defaultTarget! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:18'!
hasSubMenu: aMenuMorph
	self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]].
	^ false
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:22'!
itemWithWording: wording
	"If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
	| found |
	self items do:[:anItem |
		found _ anItem itemWithWording: wording.
		found ifNotNil:[^found]].
	^ nil! !

!MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
items

	^ submorphs select: [:m | m isKindOf: MenuItemMorph]
! !

!MenuMorph methodsFor: 'accessing' stamp: 'sw 4/19/1999 12:22'!
lastItem
	^ submorphs last! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 12:12'!
lastSelection
	"Return the label of the last selected item or nil."

	selectedItem == nil
		ifTrue: [^ selectedItem selector]
		ifFalse: [^ nil].
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:06'!
popUpOwner
	"Return the current pop-up owner that is the menu item that automatically initiated the receiver."
	^ popUpOwner
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 10:07'!
popUpOwner: aMenuItemMorph
	"Set the current pop-up owner"
	popUpOwner _ aMenuItemMorph.
! !

!MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
stayUp

	^ stayUp
! !

!MenuMorph methodsFor: 'accessing' stamp: 'ar 10/10/2000 02:00'!
stayUp: aBoolean

	stayUp _ aBoolean.! !

!MenuMorph methodsFor: 'accessing' stamp: 'RAA 6/16/2000 09:31'!
titleGuesstimate

        submorphs isEmpty ifTrue: [^nil].
        (submorphs first isKindOf: AlignmentMorph) ifFalse: [^nil].
        submorphs first submorphsDo: [ :each |
                (each isKindOf: StringMorph) ifTrue: [^each contents]
        ].
        ^nil
! !


!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString action: aSymbol
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object."
	"Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action."

	self add: aString
		target: defaultTarget
		selector: aSymbol
		argumentList: EmptyArray.
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 5/1/1998 00:48'!
add: aString selector: aSymbol argument: arg

	self add: aString
		target: defaultTarget
		selector: aSymbol
		argumentList: (Array with: arg)
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString subMenu: aMenuMorph
	"Append the given submenu with the given label."

	| item |
	item _ MenuItemMorph new.
	item contents: aString;
		subMenu: aMenuMorph.
	self addMorphBack: item.
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 4/17/1998 22:45'!
add: aString target: aTarget action: aSymbol
	self add: aString
		target: aTarget
		selector: aSymbol
		argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString target: anObject selector: aSymbol
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object."

	self add: aString
		target: anObject
		selector: aSymbol
		argumentList: EmptyArray.
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
add: aString target: target selector: aSymbol argument: arg
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument."

	self add: aString
		target: target
		selector: aSymbol
		argumentList: (Array with: arg)
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:44'!
add: aString target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  Answer the appended menu item."

	| item |
	item _ MenuItemMorph new
		contents: aString;
		target: target;
		selector: aSymbol;
		arguments: argList asArray.
	self addMorphBack: item.
	^ item
! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 5/20/1998 10:50'!
addLine
	"Append a divider line to this menu. Suppress duplicate lines."

	submorphs isEmpty ifTrue: [^ self].
	(self lastSubmorph isKindOf: MenuLineMorph)
		ifFalse: [self addMorphBack: MenuLineMorph new].
! !

!MenuMorph methodsFor: 'construction' stamp: 'md 12/15/1999 12:44'!
addList: listOfPairs
	"Add the given items to this menu, where each item is a pair (<string> <actionSelector>)..  ILf an element of the list is simply the symobl $-, add a line to the receiver."

	listOfPairs do: [:pair |
		#- = pair
			ifTrue: [self addLine]
			ifFalse: [self add: pair first action: pair last]]! !

!MenuMorph methodsFor: 'construction' stamp: 'di 9/22/1998 20:29'!
addStayUpItem
	"Append a menu item that can be used to toggle this menu's persistent."

	self add: 'keep this menu up'
		target: self
		selector: #toggleStayUp:
		argumentList: EmptyArray.
	self addLine! !

!MenuMorph methodsFor: 'construction' stamp: 'RAA 1/18/2001 18:27'!
addStayUpItemSpecial
	"Append a menu item that can be used to toggle this menu's persistent."

	"This variant is resistant to the MVC compatibility in #setInvokingView:"

	self add: 'keep this menu up'
		target: self
		selector: #toggleStayUpIgnore:evt:
		argumentList: #(1).
	self addLine! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/19/1999 23:09'!
addTitle: aString
	"Add a title line at the top of this menu."

	self addTitle: aString updatingSelector: nil updateTarget: nil! !

!MenuMorph methodsFor: 'construction' stamp: 'ar 11/9/2000 21:19'!
addTitle: aString updatingSelector: aSelector updateTarget: aTarget
	"Add a title line at the top of this menu  Make aString its initial contents.  If aSelector is not nil, then periodically obtain fresh values for its contents by sending aSelector to aTarget.."

	| title |
	title _ AlignmentMorph new.
	self setTitleParametersFor: title.
	title vResizing: #shrinkWrap.
	title listDirection: #topToBottom.
	title wrapCentering: #center; cellPositioning: #topCenter.
	aSelector
		ifNotNil:
			[title addMorphBack: (UpdatingStringMorph new lock; useStringFormat; target: aTarget; getSelector: aSelector)]
		ifNil:
			[(aString asString findTokens: String cr) do:
				[:line | title addMorphBack: (StringMorph contents: line font: Preferences standardMenuFont)]].
	
	self addMorphFront: title.
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 16:49'!
addUpdating: aWordingSelector action: aSymbol

	self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/21/1999 11:34'!
addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol

	self addUpdating: aWordingSelector enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:39'!
addUpdating: wordingSelector enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled.  Answer the item itself."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		wordingProvider: target wordingSelector: wordingSelector;
		enablementSelector: enablementSelector;
		arguments: argList asArray.
	self addMorphBack: item.
	^ item
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 17:26'!
addUpdating: aWordingSelector target: aTarget action: aSymbol

	self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/6/2000 13:43'!
addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target,  Answer the item added."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		wordingProvider: target wordingSelector: wordingSelector;
		arguments: argList asArray.
	self addMorphBack: item.
	^ item
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:02'!
addWithLabel: aLabel enablement: anEnablementSelector action: aSymbol

	self addWithLabel: aLabel enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 8/28/2000 18:01'!
addWithLabel: aLabel enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList
	"Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument.  In this variant, the wording of the menu item is constant, and the optional enablementSelector determines whether or not the item should be enabled."

	| item |
	item _ UpdatingMenuItemMorph new
		target: target;
		selector: aSymbol;
		contents: aLabel;
		wordingProvider: target wordingSelector: nil;
		enablementSelector: enablementSelector;
		arguments: argList asArray.
	self addMorphBack: item.
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 11/5/1998 21:13'!
balloonTextForLastItem: balloonText
	submorphs last setBalloonText: balloonText! !

!MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'!
defaultTarget: anObject
	"Set the default target for adding menu items."

	defaultTarget _ anObject.
! !

!MenuMorph methodsFor: 'construction' stamp: 'di 8/20/1998 09:30'!
labels: labelList lines: linesArray selections: selectionsArray
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."
	"Labels can be either a sting with embedded crs, or a collection of strings."

	| labelArray |
	(labelList isMemberOf: String)
		ifTrue: [labelArray _ labelList findTokens: String cr]
		ifFalse: [labelArray _ labelList].
	1 to: labelArray size do: [:i |
		self add: (labelArray at: i) action: (selectionsArray at: i).
		(linesArray includes: i) ifTrue: [self addLine]].
! !

!MenuMorph methodsFor: 'construction' stamp: 'sw 7/1/1999 22:21'!
title: aString
	"Add a title line at the top of this menu."

	self addTitle: aString! !


!MenuMorph methodsFor: 'control' stamp: 'ar 9/17/2000 20:38'!
activeSubmenu: aSubmenu
	activeSubMenu ifNotNil:[activeSubMenu delete].
	activeSubMenu _ aSubmenu.! !

!MenuMorph methodsFor: 'control' stamp: 'ar 10/10/2000 00:54'!
deleteIfPopUp: evt
	"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."

	stayUp ifFalse: [self topRendererOrSelf delete].
	(popUpOwner notNil) ifTrue: [
		popUpOwner isSelected: false.
		popUpOwner deleteIfPopUp: evt].
	evt ifNotNil:[evt hand releaseMouseFocus: self].! !

!MenuMorph methodsFor: 'control' stamp: 'sw 6/30/1999 20:30'!
isCandidateForAutomaticViewing
	^ false! !

!MenuMorph methodsFor: 'control' stamp: 'ar 9/18/2000 12:15'!
popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem
	"Present this menu at the given point under control of the given hand."

	| delta tryToPlace selectedOffset |

	hand world startSteppingSubmorphsOf: self.
	popUpOwner _ sourceItem.
	self fullBounds.  "ensure layout is current"
	selectedOffset := (selectedItem ifNil:[self items first]) position - self position.

	tryToPlace :=
		[ :where :mustFit |
		self position: where - selectedOffset.
		delta _ self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds.
		(delta x = 0 or: [mustFit]) ifTrue:
			[delta = (0@0) ifFalse: [self position: self position + delta].
			sourceItem owner owner addMorphFront: self.
			^ self]].
	tryToPlace 
		value: rightOrLeftPoint first value: false;
		value: rightOrLeftPoint last  - (self width @ 0) value: false;
		value: rightOrLeftPoint first value: true

	! !

!MenuMorph methodsFor: 'control' stamp: 'ar 10/10/2000 02:00'!
popUpAt: aPoint forHand: hand in: aWorld
	"Present this menu at the given point under control of the given hand."
	self items isEmpty ifTrue: [^ self].
	self positionAt: aPoint relativeTo: (selectedItem ifNil:[self items first]) inWorld: aWorld.
	aWorld addMorphFront: self; startSteppingSubmorphsOf: self.
	"Aquire focus for valid pop up behavior"
	hand newMouseFocus: self.
	self changed! !

!MenuMorph methodsFor: 'control' stamp: 'RAA 6/12/2000 08:55'!
popUpEvent: evt in: aWorld
	| h p |
	"Present this menu in response to the given event."

	h _ evt hand.
	p _ (aWorld pointFromWorld: h position) truncated.
	^self popUpAt: p forHand: h in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'RAA 6/12/2000 09:13'!
popUpForHand: hand in: aWorld
	| p |
	"Present this menu under control of the given hand."

	p _ (aWorld pointFromWorld: hand position) truncated.
	^self popUpAt: p forHand: hand in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'ar 10/5/2000 19:31'!
popUpInWorld: aWorld
	"Present this menu under control of the given hand."
	^self popUpAt: aWorld primaryHand position forHand: aWorld primaryHand in: aWorld
! !

!MenuMorph methodsFor: 'control' stamp: 'ar 9/18/2000 12:16'!
selectItem: aMenuItem event: anEvent
	selectedItem ifNotNil:[selectedItem deselect: anEvent].
	selectedItem _ aMenuItem.
	selectedItem ifNotNil:[selectedItem select: anEvent].! !

!MenuMorph methodsFor: 'control' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! !


!MenuMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 09:34'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals."

super veryDeepFixupWith: deepCopier.
defaultTarget _ deepCopier references at: defaultTarget ifAbsent: [defaultTarget].
popUpOwner _ deepCopier references at: popUpOwner ifAbsent: [popUpOwner].
activeSubMenu _ deepCopier references at: activeSubMenu ifAbsent:[activeSubMenu].! !

!MenuMorph methodsFor: 'copying' stamp: 'ar 9/18/2000 12:17'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"defaultTarget _ defaultTarget.		Weakly copied"
selectedItem _ selectedItem veryDeepCopyWith: deepCopier.
stayUp _ stayUp veryDeepCopyWith: deepCopier.
popUpOwner _ popUpOwner.		"Weakly copied"
activeSubMenu _ activeSubMenu. "Weakly copied"
! !


!MenuMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 01:57'!
delete
	activeSubMenu ifNotNil:[activeSubMenu delete].
	^super delete! !

!MenuMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:56'!
initialize
	super initialize.
	bounds _ 0@0 corner: 40@10.
	self setDefaultParameters.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	defaultTarget _ nil.
	selectedItem _ nil.
	stayUp _ false.
	popUpOwner _ nil.
	Preferences roundedMenuCorners ifTrue: [self useRoundedCorners]
! !

!MenuMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:41'!
setDefaultParameters

	| worldColor |
	((Preferences menuColorFromWorld and: [Display depth > 4]) and: [(worldColor _ self currentWorld color) isColor])
		ifTrue: [self setColor: (worldColor luminance > 0.7
						ifTrue: [worldColor mixed: 0.8 with: Color black]
						ifFalse: [worldColor mixed: 0.4 with: Color white])
						"Think about whether alpha should be included."
					borderWidth: Preferences menuBorderWidth
					borderColor: #raised]
		ifFalse: [self setColor: Preferences menuColor
					borderWidth: Preferences menuBorderWidth
					borderColor: Preferences menuBorderColor].
	self layoutInset: 3.! !

!MenuMorph methodsFor: 'initialization' stamp: 'sw 11/3/1998 11:23'!
setTitleParametersFor: aMenuTitle
	aMenuTitle setColor: Preferences menuTitleColor borderWidth: Preferences menuTitleBorderWidth borderColor: Preferences menuTitleBorderColor! !



!MenuMorph methodsFor: 'menu' stamp: 'ar 9/18/2000 13:15'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'add title...' action: #addTitle.
	aCustomMenu add: 'set target...' action: #setTarget:.
	defaultTarget ifNotNil: [
		aCustomMenu add: 'add item...' action: #addItem].
	aCustomMenu add: 'add line' action: #addLine.
	(self items count:[:any| any hasSubMenu]) > 0
		ifTrue:[aCustomMenu add: 'detach submenu' action: #detachSubMenu:].! !

!MenuMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addItem

	| string sel |
	string _ FillInTheBlank request: 'Label for new item?'.
	string isEmpty ifTrue: [^ self].
	sel _ FillInTheBlank request: 'Selector?'.
	sel isEmpty ifFalse: [sel _ sel asSymbol].
	self add: string action: sel.
! !

!MenuMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addTitle

	| string |
	string _ FillInTheBlank request: 'Title for this menu?'.
	string isEmpty ifTrue: [^ self].
	self addTitle: string.
! !

!MenuMorph methodsFor: 'menu' stamp: 'ar 9/18/2000 11:47'!
detachSubMenu: evt
	| possibleTargets item subMenu index |
	possibleTargets _ self items select:[:any| any hasSubMenu].
	possibleTargets size > 0 ifTrue:[
		index _ PopUpMenu 
				withCaption:'Which menu?' 
				chooseFrom: (possibleTargets collect:[:t| t contents asString]).
		index = 0 ifTrue:[^self]].
	item _ possibleTargets at: index.
	subMenu _ item subMenu.
	subMenu ifNotNil: [
		item subMenu: nil.
		item delete.
		subMenu stayUp: true.
		subMenu popUpOwner: nil.
		subMenu addTitle: item contents.
		evt hand attachMorph: subMenu].
! !

!MenuMorph methodsFor: 'menu' stamp: 'di 4/11/98 14:25'!
setInvokingView: invokingView
	"Re-work every menu item of the form
		<target> perform: <selector>
	to the form
		<target> perform: <selector> orSendTo: <invokingView>.
	This supports MVC's vectoring of non-model messages to the editPane."
	self items do:
		[:item |
		item arguments isEmpty ifTrue:  "only the simple messages"
			[item arguments: (Array with: item selector with: invokingView).
			item selector: #perform:orSendTo:]]! !

!MenuMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:45'!
setTarget: evt
	"Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand."

	| rootMorphs old |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1
		ifTrue: [defaultTarget _ rootMorphs at: 2]
		ifFalse: [^ self].
	"re-target all existing items"
	self items do: [:item |
		old _ item target.
		old isHandMorph
			ifTrue: [item target: evt hand]
			ifFalse: [item target: defaultTarget]].
! !

!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/18/2001 18:21'!
toggleStayUp: evt
	"Toggle my 'stayUp' flag and adjust the menu item to reflect its new state."

	self items do: [:item |
		item isStayUpItem ifTrue:
			[self stayUp: stayUp not.	
			 stayUp
				ifTrue: [item contents: 'dismiss this menu']
				ifFalse: [item contents: 'keep this menu up']]].
	evt hand releaseMouseFocus: self.
	stayUp ifFalse: [self topRendererOrSelf delete].
! !

!MenuMorph methodsFor: 'menu' stamp: 'RAA 1/19/2001 15:10'!
toggleStayUpIgnore: ignored evt: evt

	"This variant is resistant to the MVC compatibility in #setInvokingView:"

	self toggleStayUp: evt.
! !


!MenuMorph methodsFor: 'private' stamp: 'ar 10/7/2000 21:08'!
invokeMetaMenu: evt
	stayUp ifFalse:[^self]. "Don't allow this"
	^super invokeMetaMenu: evt! !

!MenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 11:49'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^10		"Menus are very front-like things"! !

!MenuMorph methodsFor: 'private' stamp: 'ar 11/12/2000 17:52'!
positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld
	"Note: items may not be laid out yet (I found them all to be at 0@0),  
	so we have to add up heights of items above the selected item."

	| i yOffset sub delta |
	self fullBounds. "force layout"
	i _ 0.
	yOffset _ 0.
	[(sub _ self submorphs at: (i _ i + 1)) == aMenuItem]
		whileFalse: [yOffset _ yOffset + sub height].

	self position: aPoint - (2 @ (yOffset + 8)).

	"If it doesn't fit, show it to the left, not to the right of the hand."
	self right > aWorld worldBounds right
		ifTrue: [self left: self left - self width + 4].

	"Make sure that the menu fits in the world."
	delta _ self bounds amountToTranslateWithin: aWorld worldBounds.
	delta = (0 @ 0) ifFalse: [self position: self position + delta]! !

!MenuMorph methodsFor: 'private' stamp: 'ar 9/18/2000 12:12'!
selectedItem
	^selectedItem! !


!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:35'!
activate: evt
	"Receiver should be activated; e.g., so that control passes correctly."
	evt hand newMouseFocus: self.! !

!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:52'!
handleFocusEvent: evt
	"Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children."
	self processEvent: evt.
	"We need to handle button clicks outside and transitions to local popUps so throw away everything else"
	(evt isMouseOver or:[evt isMouse not]) ifTrue:[^self].
	"What remains are mouse buttons and moves"
	evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means"
	"Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first."
	selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]].
	"Note: The following does not traverse upwards but it's the best I can do for now"
	popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].! !

!MenuMorph methodsFor: 'events' stamp: 'ar 9/18/2000 10:13'!
handlesMouseDown: evt
	^true! !

!MenuMorph methodsFor: 'events' stamp: 'RAA 12/16/2000 11:20'!
mouseDown: evt
	"Handle a mouse down event."
	(stayUp or:[self fullContainsPoint: evt position]) 
		ifFalse:[^self deleteIfPopUp: evt]. "click outside"
	self isSticky ifTrue: [^self].
	"Grab the menu and drag it to some other place"
	evt hand grabMorph: self.! !

!MenuMorph methodsFor: 'events' stamp: 'ar 10/10/2000 01:57'!
mouseUp: evt
	"Handle a mouse up event.
	Note: This might be sent from a modal shell."
	(self fullContainsPoint: evt position) ifFalse:[
		"Mouse up outside. Release eventual focus and delete if pop up."
		evt hand releaseMouseFocus: self.
		^self deleteIfPopUp: evt].
	stayUp ifFalse:[
		"Still in pop-up transition; keep focus"
		evt hand newMouseFocus: self].! !


!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 14:23'!
justDroppedInto: aMorph event: evt
	| halo |
	super justDroppedInto: aMorph event: evt.
	halo _ evt hand halo.
	(halo notNil and:[halo target hasOwner: self]) ifTrue:[
		"Grabbed single menu item"
		self addHalo: evt.
	].
	stayUp ifFalse:[evt hand newMouseFocus: self].! !

!MenuMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:16'!
undoGrabCommand
	^nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MenuMorph class
	instanceVariableNames: ''!

!MenuMorph class methodsFor: 'example' stamp: 'jm 11/4/97 07:46'!
example
	"MenuMorph example"

	| menu |
	menu _ MenuMorph new.
	menu addStayUpItem.
	menu add: 'apples' action: #apples.
	menu add: 'oranges' action: #oranges.
	menu addLine.
	menu addLine.  "extra lines ignored"
	menu add: 'peaches' action: #peaches.
	menu addLine.
	menu add: 'pears' action: #pears.
	menu addLine.
	^ menu
! !


!MenuMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 17:21'!
entitled: aString
	"Answer a new instance of me with the given title."

	^ self new addTitle: aString
! !
TileMorph subclass: #MenuTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!MenuTile commentStamp: '<historical>' prior: 0!
A tile representing a menu item!


!MenuTile methodsFor: 'as yet unclassified' stamp: 'sw 11/22/1999 11:54'!
arrowAction: delta
	| phrase aPlayer newItem |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ self].
	aPlayer _ phrase associatedPlayer.
	newItem _ delta > 0
		ifTrue:
			[aPlayer menuItemAfter: literal]
		ifFalse:
			[aPlayer menuItemBefore: literal].
	self literal: newItem.
	self layoutChanged! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'ar 9/12/2000 23:05'!
handlerForMouseDown: anEvent
	"Don't give anybody over me a chance"
	^self! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'sw 11/22/1999 12:15'!
handlesMouseDown: evt
	^ true! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'tk 8/14/2000 22:41'!
initialize
	super initialize.
	self addArrows; setLiteral: 'send to back'.
	self labelMorph useStringFormat! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 17:20'!
mouseDown: evt
	| aPoint aMenu reply |
	aPoint _ evt cursorPoint.
	nArrowTicks _ 0.
	upArrow ifNotNil:
		[(upArrow boundsInWorld containsPoint: aPoint) ifTrue: [^ self].
		(downArrow boundsInWorld containsPoint: aPoint) ifTrue: [^ self]].
	aMenu _ SelectionMenu selections: ((self ownerThatIsA: PhraseTileMorph) associatedPlayer costume allMenuWordings).
	reply _ aMenu startUp.
	reply ifNotNil: [self literal: reply; layoutChanged]! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'ar 10/9/2000 21:16'!
mouseDownPriority
	^100! !

!MenuTile methodsFor: 'as yet unclassified' stamp: 'sw 11/22/1999 11:27'!
resultType
	^ 'menu'! !
Object subclass: #Message
	instanceVariableNames: 'selector args lookupClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!Message commentStamp: '<historical>' prior: 0!
I represent a selector and its argument values.
	
Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.!


!Message methodsFor: 'accessing'!
argument
	"Answer the first (presumably sole) argument"

	^args at: 1! !

!Message methodsFor: 'accessing'!
argument: newValue
	"Change the first argument to newValue and answer self"

	args at: 1 put: newValue! !

!Message methodsFor: 'accessing'!
arguments
	"Answer the arguments of the receiver."

	^args! !

!Message methodsFor: 'accessing'!
selector
	"Answer the selector of the receiver."

	^selector! !

!Message methodsFor: 'accessing'!
sends: aSelector
	"answer whether this message's selector is aSelector"

	^selector == aSelector! !


!Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:00'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."
 
	super printOn: aStream.
	aStream nextPutAll: ' with selector: ';
	 print: selector;
	 nextPutAll: ' and arguments: ';
	 print: args! !

!Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:01'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	aStream nextPut: $(;
	 nextPutAll: self class name;
	 nextPutAll: ' selector: ';
	 store: selector;
	 nextPutAll: ' arguments: ';
	 store: args;
	 nextPut: $)! !


!Message methodsFor: 'private'!
setSelector: aSymbol arguments: anArray

	selector _ aSymbol.
	args _ anArray! !


!Message methodsFor: 'sending' stamp: 'di 3/25/1999 21:54'!
sentTo: receiver
	"answer the result of sending this message to receiver"

	lookupClass == nil
		ifTrue: [^ receiver perform: selector withArguments: args]
		ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Message class
	instanceVariableNames: ''!

!Message class methodsFor: 'instance creation'!
selector: aSymbol
	"Answer an instance of me with unary selector, aSymbol."

	^self new setSelector: aSymbol arguments: (Array new: 0)! !

!Message class methodsFor: 'instance creation'!
selector: aSymbol argument: anObject 
	"Answer an instance of me whose selector is aSymbol and single 
	argument is anObject."

	^self new setSelector: aSymbol arguments: (Array with: anObject)! !

!Message class methodsFor: 'instance creation'!
selector: aSymbol arguments: anArray 
	"Answer an instance of me with selector, aSymbol, and arguments, 
	anArray."

	^self new setSelector: aSymbol arguments: anArray! !
MessageNode subclass: #MessageAsTempNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!MessageAsTempNode commentStamp: '<historical>' prior: 0!
This node represents accesses to temporary variables for do-its in the debugger.  Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.!


!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:38'!
asStorableNode: encoder
	"This node is a message masquerading as a temporary variable.
	It currently has the form {homeContext tempAt: offset}.
	We need to generate code for {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack.
	This, in turn will get turned into {homeContext tempAt: offset put: expr}
	at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)"
	^ MessageAsTempNode new
		receiver: nil  "suppress code generation for reciever already on stack"
		selector: #storeAt:inTempFrame:
		arguments: (arguments copyWith: receiver)
		precedence: precedence
		from: encoder! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 10/12/1999 17:29'!
code
	"Allow synthetic temp nodes to be sorted by code"
	^ arguments first literalValue! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
emitStorePop: stack on: codeStream
	"This node has the form {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack."
	^ self emitForEffect: stack on: codeStream! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:35'!
isTemp
	"Masquerading for debugger access to temps."
	^ true! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
nowHasDef
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
nowHasRef
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
scope
	"For compatibility with temp scope protocol"
	^ -1! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
scope: ignored
	"For compatibility with temp scope protocol"
! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'!
sizeForStorePop: encoder
	"This node has the form {expr storeAt: offset inTempFrame: homeContext},
	where the expr, the block argument, is already on the stack."
	^ self sizeForEffect: encoder! !

!MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:40'!
store: expr from: encoder 
	"ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment).
	For assigning into temps of a context being debugged."

	selector key ~= #tempAt: 
		ifTrue: [^self error: 'cant transform this message'].
	^ MessageAsTempNode new
		receiver: receiver
		selector: #tempAt:put:
		arguments: (arguments copyWith: expr)
		precedence: precedence
		from: encoder! !
MailDBFile subclass: #MessageFile
	instanceVariableNames: 'file '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!MessageFile commentStamp: '<historical>' prior: 0!
I represent the messages file of a mail database. This file is treated as (mostly) append-only. All new messages or edited messages are appended to the end of this file.

Messages are stored as ASCII text with seperator strings and some additional information between each message. If necessary, this file can be inspected or edited with a text editor; after editing, the index file should be recreated using the "compact" command. (This is necessary because the offsets kept in the index file will probably be different after the edits.)

When a message is deleted, its delimiter is changed to mark it as deleted, but it is left in the mail file until the next time "compact" command is executed. Generally, the reduction in disk fragmentation resulting from keeping the messages in a single file more than offsets the temporary space lost by having a few deleted messages hanging around between compactions. Compaction is done into a new copy of the file, followed by a renaming operation. Thus, if compaction fails, the original messages file will not be lost.
!


!MessageFile methodsFor: 'file operations' stamp: 'jm 9/21/1998 16:26'!
close
	"Close the file."

	file ifNil: [^ self].
	file
		ensureOpen;
		setToEnd;
		close.
	file _ nil.
! !

!MessageFile methodsFor: 'file operations'!
delete
	"I must close my file handle before the file can be deleted."

	self close.
	super delete.! !

!MessageFile methodsFor: 'file operations' stamp: 'jm 9/21/1998 16:30'!
ensureFileIsOpen
	"Make sure that my file is open. The file is automatically closed on snapshots."

	file
		ifNil: [file _ FileStream fileNamed: filename]
		ifNotNil: [file ensureOpen].
! !

!MessageFile methodsFor: 'file operations'!
openOn: aFileName
	"Initialize myself for the message file with the given name."

	filename _ aFileName.
	file _ nil.
	self ensureFileIsOpen.! !

!MessageFile methodsFor: 'file operations'!
rename: newFileName
	"I must close my file handle before the file can be renamed."

	self close.
	super rename: newFileName.! !

!MessageFile methodsFor: 'file operations' stamp: 'di 9/29/1998 16:01'!
save
	"Make sure the message file is flushed to disk. This is NOT atomic because MessageFiles can get large and there might not be enough disk space to save them atomically. Besides, it would be very slow."

	file ifNil: [^ self].
	file ensureOpen.
	file closed  "Will still be closed if no file present"
		ifFalse: [file setToEnd; close; reopen].
! !


!MessageFile methodsFor: 'message operations'!
append: messageText id: messageID
	"Append the given message text with the given unique identifier. Answer the new location of the message."

	| location |
	self beginAppend.
	location _ self basicAppend: messageText id: messageID.
	self endAppend.
	^location! !

!MessageFile methodsFor: 'message operations'!
assertValidMessageAt: filePosition id: msgID
	"Verify that the given filePosition is, indeed, the start of a message (possibly deleted) with the given ID and raise an error if this assertion is false."

	| delimiter fileMsgID |
	"assume file is open"
	file position: filePosition.
	delimiter _ file next: 10.
	((delimiter = '&&&&&start') or: [delimiter = '&&&&&XXXXX']) ifFalse:
		[^self reportInconsistency].
	file next. "skip cr"
	fileMsgID _ MailDB readIntegerLineFrom: file.
	(msgID = fileMsgID) ifFalse:
		[^self reportInconsistency].! !

!MessageFile methodsFor: 'message operations'!
basicAppend: messageText id: messageID
	"Append the given message text with the given message ID. Answer the new location of the message."
	"WARNING: This operation assumes:
		1. the sender positioned the stream to the end of the file (using beginAppend), and
		2. the sender will do an endAppend operation after all messages are appended to flush all file buffers to disk."

	| location |
	file setToEnd.
	location _ file position.
	file nextPutAll: '&&&&&start'.	"message delimiter"
	file cr.
	messageID printOn: file.		"message ID"
	file cr.
	file nextPutAll: messageText.
	^location! !

!MessageFile methodsFor: 'message operations'!
beginAppend
	"Set the file to the end prior to performing a sequence of basicAppend operations."

	self ensureFileIsOpen.
	file setToEnd.! !

!MessageFile methodsFor: 'message operations'!
deleteMessageAt: filePosition id: msgID
	"Mark as deleted the message with the given ID located at the given file position."

	self ensureFileIsOpen.
	self assertValidMessageAt: filePosition id: msgID.
	file position: filePosition.
	file nextPutAll: '&&&&&XXXXX'.		"delimiter for deleted messages"
	file flush.! !

!MessageFile methodsFor: 'message operations'!
endAppend
	"Complete an append transaction by flushing the file to disk."

	self save.! !

!MessageFile methodsFor: 'message operations'!
getMessage: msgID at: start textLength: textSize
	"Retrieve the message with the given ID, location, and text size."

	self ensureFileIsOpen.
	self assertValidMessageAt: start id: msgID.
	^file next: textSize! !

!MessageFile methodsFor: 'message operations'!
update: messageText at: oldMessagePosition id: msgID
	"Atomically update the message having the old location and ID with the given new text (e.g. when the user has edited a message). Answer the new location of the message."

	| newLocation |
	newLocation _ self append: messageText id: msgID.
	self deleteMessageAt: oldMessagePosition id: msgID.
	^newLocation! !


!MessageFile methodsFor: 'scanning'!
messagesDo: aBlock
	"Scan the message file and invoke the given block for each message in it. The block arguments are:
	deleted			true if this message is marked deleted
	msgID			the message ID
	msgBody			the message text
This operation is very expensive."

	| more deleted msgID textStart textSize msgBody |
	self ensureFileIsOpen.
	file position: 0.
	more _ self scanToNextMessageIn: file.
	[more] whileTrue:
		[deleted _								"deleted"
			(MailDB readStringLineFrom: file) = '&&&&&XXXXX'.
		 msgID _ MailDB readIntegerLineFrom: file.	"msgID"
		 textStart _ file position.
		 more _ self scanToNextMessageIn: file.
		 textSize _ file position - textStart.
		 file position: textStart.
		 msgBody _ file next: textSize.				"msgBody"
		 aBlock valueWithArguments:
			(Array
				with: deleted
				with: msgID
				with: msgBody)].! !

!MessageFile methodsFor: 'scanning'!
scanToNextAndSigns: aStream
	"Scan the given stream for a pair of and-sign (&) characters and answer true if they are found before the end of the stream is reached. The stream is left positioned after the second and-sign or at the end of the stream."

	| ch |
	[true] whileTrue:
		[ch _ aStream next.
		 ((ch == $&) and:
		   [aStream next == $&]) ifTrue: [^true].	"found"
		 (ch == nil) ifTrue: [^false]].	"end of file"! !

!MessageFile methodsFor: 'scanning'!
scanToNextMessageIn: aStream
	"Scan to the start of the next message. Answer true if we find a message delimiter, false if we hit the end of the file first. The stream is left positioned at the start of the next message (at the message delimiter) or at the end of the stream."

	| delimiter |
	[self scanToNextAndSigns: aStream] whileTrue:
		[delimiter _ aStream next: 8.
		 ((delimiter = '&&&start') or: [delimiter = '&&&XXXXX'])
			ifTrue: [aStream skip: -10. ^true]
			ifFalse: [(delimiter includes: $&) ifTrue: [aStream skip: -8]]].
	^false	"end of file"! !
ParseNode subclass: #MessageNode
	instanceVariableNames: 'receiver selector precedence special arguments sizes pc equalNode caseErrorNode '
	classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers StdTypers ThenFlag '
	poolDictionaries: ''
	category: 'System-Compiler'!
!MessageNode commentStamp: '<historical>' prior: 0!
I represent a receiver and its message.
	
Precedence codes:
	1 unary
	2 binary
	3 keyword
	4 other
	
If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.!


!MessageNode methodsFor: 'initialize-release' stamp: 'di 6/6/2000 23:24'!
receiver: rcvr selector: selNode arguments: args precedence: p 
	"Decompile."

	self receiver: rcvr
		arguments: args
		precedence: p.
	self noteSpecialSelector: selNode key.
	selector _ selNode.
	"self pvtCheckForPvtSelector: encoder"
	"We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"! !

!MessageNode methodsFor: 'initialize-release' stamp: 'di 6/6/2000 23:27'!
receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder 
	"Compile."

	| theSelector |
	self receiver: rcvr
		arguments: args
		precedence: p.
	aSelector = #:Repeat:do:
		ifTrue: [theSelector _ #do:]
		ifFalse: [theSelector _ aSelector].
	self noteSpecialSelector: theSelector.
	(self transform: encoder)
		ifTrue: 
			[selector isNil
				ifTrue: [selector _ SelectorNode new 
							key: (MacroSelectors at: special)
							code: #macro]]
		ifFalse: 
			[selector _ encoder encodeSelector: theSelector.
			rcvr == NodeSuper ifTrue: [encoder noteSuper]].
	self pvtCheckForPvtSelector: encoder! !

!MessageNode methodsFor: 'initialize-release'!
receiver: rcvr selector: selName arguments: args precedence: p from: encoder sourceRange: range 
	"Compile."

	encoder noteSourceRange: range forNode: self.
	^self
		receiver: rcvr
		selector: selName
		arguments: args
		precedence: p
		from: encoder! !

!MessageNode methodsFor: 'initialize-release' stamp: 'tk 10/26/2000 15:37'!
selector: sel
	selector _ sel! !


!MessageNode methodsFor: 'testing'!
canCascade

	^(receiver == NodeSuper or: [special > 0]) not! !

!MessageNode methodsFor: 'testing'!
isComplex
	
	^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]! !

!MessageNode methodsFor: 'testing'!
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
	"Answer whether selector is selSymbol, and the predicates rcvrPred and argsPred
	 evaluate to true with respect to receiver and the list of arguments.  If selSymbol or
	 either predicate is nil, it means 'don't care'.  Note that argsPred takes numArgs
	 arguments.  All block arguments are ParseNodes."

	^(selSymbol isNil or: [selSymbol==selector key]) and:
		[(rcvrPred isNil or: [rcvrPred value: receiver]) and:
			[(argsPred isNil or: [argsPred valueWithArguments: arguments])]]! !

!MessageNode methodsFor: 'testing'!
isReturningIf

	^(special between: 3 and: 4)
		and: [arguments first returns and: [arguments last returns]]! !

!MessageNode methodsFor: 'testing'!
toDoIncrement: variable
	(receiver = variable and: [selector key = #+]) 
		ifFalse: [^ nil].
	arguments first isConstantNumber
		ifTrue: [^ arguments first]
		ifFalse: [^ nil]! !

!MessageNode methodsFor: 'testing'!
toDoLimit: variable
	(receiver = variable and: [selector key = #<= or: [selector key = #>=]]) 
		ifTrue: [^ arguments first]
		ifFalse: [^ nil]! !


!MessageNode methodsFor: 'cascading'!
cascadeReceiver
	"Nil out rcvr (to indicate cascade) and return what it had been."

	| rcvr |
	rcvr _ receiver.
	receiver _ nil.
	^rcvr! !


!MessageNode methodsFor: 'macro transformations' stamp: 'di 6/11/2000 16:09'!
noteSpecialSelector: selectorSymbol
	" special > 0 denotes specially treated messages. "

	"Deconvert initial keywords from SQ2K"
	special _ #(:Test:Yes: :Test:No: :Test:Yes:No: :Test:No:Yes:
				and: or:
				:Until:do: :While:do: whileFalse whileTrue
				:Repeat:to:do: :Repeat:to:by:do:
				) indexOf: selectorSymbol.
	special > 0 ifTrue: [^ self].

	special _ MacroSelectors indexOf: selectorSymbol.
! !

!MessageNode methodsFor: 'macro transformations' stamp: 'sma 3/3/2000 13:37'!
toDoFromWhileWithInit: initStmt
	"Return nil, or a to:do: expression equivalent to this whileTrue:"
	| variable increment limit toDoBlock body test |
	(selector key == #whileTrue:
		and: [(initStmt isMemberOf: AssignmentNode) and:
				[initStmt variable isTemp]])
		ifFalse: [^ nil].
	body _ arguments last statements.
	variable _ initStmt variable.
	increment _ body last toDoIncrement: variable.
	(increment == nil or: [receiver statements size ~= 1])
		ifTrue: [^ nil].
	test _ receiver statements first.
	"Note: test chould really be checked that <= or >= comparison
	jibes with the sign of the (constant) increment"
	((test isMemberOf: MessageNode)
		and: [(limit _ test toDoLimit: variable) notNil])
		ifFalse: [^ nil].
	toDoBlock _ BlockNode statements: body allButLast returns: false.
	toDoBlock arguments: (Array with: variable).
	^ MessageNode new
		receiver: initStmt value
		selector: (SelectorNode new key: #to:by:do: code: #macro)
		arguments: (Array with: limit with: increment with: toDoBlock)
		precedence: precedence! !

!MessageNode methodsFor: 'macro transformations'!
transform: encoder
	special = 0 ifTrue: [^false].
	(self perform: (MacroTransformers at: special) with: encoder)
		ifTrue: 
			[^true]
		ifFalse: 
			[special _ 0. ^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformAnd: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (BlockNode withJust: NodeFalse).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformBoolean: encoder
	^self
		checkBlock: (arguments at: 1)
		as: 'argument'
		from: encoder! !

!MessageNode methodsFor: 'macro transformations'!
transformIfFalse: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (BlockNode withJust: NodeNil)
					with: (arguments at: 1).
			^true]
		ifFalse:
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 00:48'!
transformIfFalseIfTrue: encoder
	((self checkBlock: (arguments at: 1) as: 'False arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'True arg' from: encoder])
		ifTrue: 
			[selector _ #ifTrue:ifFalse:.
			arguments swap: 1 with: 2.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'di 4/24/2000 13:32'!
transformIfNil: encoder

	(self transformBoolean: encoder) ifFalse: [^ false].
	(MacroSelectors at: special) = #ifNotNil:
	ifTrue:
		[(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder) ifFalse: [^ false].

		"Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'.
		Slightly better code and more consistent with decompilation."
		self noteSpecialSelector: #ifNil:ifNotNil:.
		selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro.
		arguments _ {BlockNode withJust: NodeNil. arguments first}.
		(self transform: encoder) ifFalse: [self error: 'compiler logic error'].
		^ true]
	ifFalse:
		[^ self checkBlock: arguments first as: 'ifNil arg' from: encoder]
! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:49'!
transformIfNilIfNotNil: encoder
	((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'NotNil arg' from: encoder])
		ifTrue: 
			[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
			receiver _ MessageNode new
				receiver: receiver
				selector: #==
				arguments: (Array with: NodeNil)
				precedence: 2
				from: encoder.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:50'!
transformIfNotNilIfNil: encoder
	((self checkBlock: (arguments at: 1) as: 'NotNil arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder])
		ifTrue: 
			[selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro.
			receiver _ MessageNode new
				receiver: receiver
				selector: #==
				arguments: (Array with: NodeNil)
				precedence: 2
				from: encoder.
			arguments swap: 1 with: 2.
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations'!
transformIfTrue: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (arguments at: 1)
					with: (BlockNode withJust: NodeNil).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/27/2000 22:29'!
transformIfTrueIfFalse: encoder
	^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder)
		and: [self checkBlock: (arguments at: 2) as: 'False arg' from: encoder]! !

!MessageNode methodsFor: 'macro transformations'!
transformOr: encoder
	(self transformBoolean: encoder)
		ifTrue: 
			[arguments _ 
				Array 
					with: (BlockNode withJust: NodeTrue)
					with: (arguments at: 1).
			^true]
		ifFalse: 
			[^false]! !

!MessageNode methodsFor: 'macro transformations' stamp: 'tao 1/30/1999 
08:56'!
transformToDo: encoder
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] 
Jmp(L1) L2: "
	| limit increment block initStmt test incStmt limitInit blockVar |
	"First check for valid arguments"
	((arguments last isMemberOf: BlockNode)
			and: [arguments last numberOfArguments = 1])
		ifFalse: [^ false].
	arguments last firstArgument isVariableReference
		ifFalse: [^ false]. "As with debugger remote vars"
	arguments size = 3
		ifTrue: [increment _ arguments at: 2.
				(increment isConstantNumber and:
					[increment literalValue ~= 0]) ifFalse: [^ false]]
		ifFalse: [increment _ encoder encodeLiteral: 1].
	arguments size < 3 ifTrue:   "transform to full form"
		[selector _ SelectorNode new key: #to:by:do: code: #macro].

	"Now generate auxiliary structures"
	block _ arguments last.
	blockVar _ block firstArgument.
	initStmt _ AssignmentNode new variable: blockVar value: receiver.
	limit _ arguments at: 1.
	limit isVariableReference | limit isConstantNumber
		ifTrue: [limitInit _ nil]
		ifFalse:  "Need to store limit in a var"
			[limit _ encoder autoBind: blockVar key , 'LimiT'.
			limit scope: -2.  "Already done parsing block"
			limitInit _ AssignmentNode new
					variable: limit
					value: (arguments at: 1)].
	test _ MessageNode new receiver: blockVar
			selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=])
			arguments: (Array with: limit)
			precedence: precedence from: encoder.
	incStmt _ AssignmentNode new
			variable: blockVar
			value: (MessageNode new
				receiver: blockVar selector: #+
				arguments: (Array with: increment)
				precedence: precedence from: encoder).
	arguments _ (Array with: limit with: increment with: block)
		, (Array with: initStmt with: test with: incStmt with: limitInit).
	^ true! !

!MessageNode methodsFor: 'macro transformations'!
transformWhile: encoder
	(self checkBlock: receiver as: 'receiver' from: encoder)
		ifFalse: [^ false].
	arguments size = 0   "transform bodyless form to body form"
		ifTrue: [selector _ SelectorNode new
					key: (special = 10 ifTrue: [#whileTrue:] ifFalse: [#whileFalse:])
					code: #macro.
				arguments _ Array with: (BlockNode withJust: NodeNil).
				^ true]
		ifFalse: [^ self transformBoolean: encoder]! !


!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:24'!
emitCase: stack on: strm value: forValue

	| braceNode sizeStream thenSize elseSize |
	forValue not
		ifTrue: [^super emitForEffect: stack on: strm].
	braceNode _ arguments first.
	sizeStream _ ReadStream on: sizes.
	receiver emitForValue: stack on: strm.
	braceNode casesForwardDo:
		[:keyNode :valueNode :last |
		thenSize _ sizeStream next.
		elseSize _ sizeStream next.
		last ifFalse: [strm nextPut: Dup. stack push: 1].
		keyNode emitForEvaluatedValue: stack on: strm.
		equalNode emit: stack args: 1 on: strm.
		self emitBranchOn: false dist: thenSize pop: stack on: strm.
		last ifFalse: [strm nextPut: Pop. stack pop: 1].
		valueNode emitForEvaluatedValue: stack on: strm.
		last ifTrue: [stack pop: 1].
		valueNode returns ifFalse: [self emitJump: elseSize on: strm]].
	arguments size = 2
		ifTrue:
			[arguments last emitForEvaluatedValue: stack on: strm] "otherwise: [...]"
		ifFalse:
			[NodeSelf emitForValue: stack on: strm.
			caseErrorNode emit: stack args: 0 on: strm]! !

!MessageNode methodsFor: 'code generation'!
emitForEffect: stack on: strm

	special > 0
		ifTrue: 
			[self perform: (MacroEmitters at: special) with: stack with: strm with: false.
			pc _ 0]
		ifFalse: 
			[super emitForEffect: stack on: strm]! !

!MessageNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	special > 0
		ifTrue: 
			[self perform: (MacroEmitters at: special) with: stack with: strm with: true.
			pc _ 0]
		ifFalse: 
			[receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm].
			arguments do: [:argument | argument emitForValue: stack on: strm].
			selector
				emit: stack
				args: arguments size
				on: strm
				super: receiver == NodeSuper.
			pc _ strm position]! !

!MessageNode methodsFor: 'code generation'!
emitIf: stack on: strm value: forValue
	| thenExpr thenSize elseExpr elseSize |
	thenSize _ sizes at: 1.
	elseSize _ sizes at: 2.
	(forValue not and: [(elseSize*thenSize) > 0])
		ifTrue:  "Two-armed IFs forEffect share a single pop"
			[^ super emitForEffect: stack on: strm].
	thenExpr _ arguments at: 1.
	elseExpr _ arguments at: 2.
	receiver emitForValue: stack on: strm.
	forValue
		ifTrue:  "Code all forValue as two-armed"
			[self emitBranchOn: false dist: thenSize pop: stack on: strm.
			thenExpr emitForEvaluatedValue: stack on: strm.
			stack pop: 1.  "then and else alternate; they don't accumulate"
			thenExpr returns not
				ifTrue:  "Elide jump over else after a return"
					[self emitJump: elseSize on: strm].
			elseExpr emitForEvaluatedValue: stack on: strm]
		ifFalse:  "One arm is empty here (two-arms code forValue)"
			[thenSize > 0
				ifTrue:
					[self emitBranchOn: false dist: thenSize pop: stack on: strm.
					thenExpr emitForEvaluatedEffect: stack on: strm]
				ifFalse:
					[self emitBranchOn: true dist: elseSize pop: stack on: strm.
					elseExpr emitForEvaluatedEffect: stack on: strm]]! !

!MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 21:59'!
emitIfNil: stack on: strm value: forValue

	| theNode theSize theSelector |
	theNode _ arguments first.
	theSize _ sizes at: 1.
	theSelector _ #ifNotNil:.
	receiver emitForValue: stack on: strm.
	forValue ifTrue: [strm nextPut: Dup. stack push: 1].
	strm nextPut: LdNil. stack push: 1.
	equalNode emit: stack args: 1 on: strm.
	self 
		emitBranchOn: (selector key == theSelector)
		dist: theSize 
		pop: stack 
		on: strm.
	forValue 
		ifTrue: 
			[strm nextPut: Pop. stack pop: 1.
			theNode emitForEvaluatedValue: stack on: strm]	
		ifFalse: [theNode emitForEvaluatedEffect: stack on: strm].! !

!MessageNode methodsFor: 'code generation'!
emitToDo: stack on: strm value: forValue 
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
	| loopSize initStmt limitInit test block incStmt blockSize |
	initStmt _ arguments at: 4.
	limitInit _ arguments at: 7.
	test _ arguments at: 5.
	block _ arguments at: 3.
	incStmt _ arguments at: 6.
	blockSize _ sizes at: 1.
	loopSize _ sizes at: 2.
	limitInit == nil
		ifFalse: [limitInit emitForEffect: stack on: strm].
	initStmt emitForEffect: stack on: strm.
	test emitForValue: stack on: strm.
	self emitBranchOn: false dist: blockSize pop: stack on: strm. 
	block emitForEvaluatedEffect: stack on: strm.
	incStmt emitForEffect: stack on: strm.
	self emitJump: 0 - loopSize on: strm.
	forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! !

!MessageNode methodsFor: 'code generation'!
emitWhile: stack on: strm value: forValue 
	" L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: "
	| cond stmt stmtSize loopSize |
	cond _ receiver.
	stmt _ arguments at: 1.
	stmtSize _ sizes at: 1.
	loopSize _ sizes at: 2.
	cond emitForEvaluatedValue: stack on: strm.
	self emitBranchOn: (selector key == #whileFalse:)  "Bfp for whileTrue"
					dist: stmtSize pop: stack on: strm.   "Btp for whileFalse"
	stmt emitForEvaluatedEffect: stack on: strm.
	self emitJump: 0 - loopSize on: strm.
	forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! !

!MessageNode methodsFor: 'code generation'!
pc
	"Used by encoder source mapping."

	pc==nil ifTrue: [^0] ifFalse: [^pc]! !

!MessageNode methodsFor: 'code generation' stamp: 'tao 8/20/97 22:25'!
sizeCase: encoder value: forValue

	| braceNode sizeIndex thenSize elseSize |
	forValue not
		ifTrue: [^super sizeForEffect: encoder].
	equalNode _ encoder encodeSelector: #=.
	braceNode _ arguments first.
	sizes _ Array new: 2 * braceNode numElements.
	sizeIndex _ sizes size.
	elseSize _ arguments size = 2
		ifTrue:
			[arguments last sizeForEvaluatedValue: encoder] "otherwise: [...]"
		ifFalse:
			[caseErrorNode _ encoder encodeSelector: #caseError.
			 1 + (caseErrorNode size: encoder args: 0 super: false)]. "self caseError"
	braceNode casesReverseDo:
		[:keyNode :valueNode :last |
		sizes at: sizeIndex put: elseSize.
		thenSize _ valueNode sizeForEvaluatedValue: encoder.
		last ifFalse: [thenSize _ thenSize + 1]. "Pop"
		valueNode returns ifFalse: [thenSize _ thenSize + (self sizeJump: elseSize)].
		sizes at: sizeIndex-1 put: thenSize.
		last ifFalse: [elseSize _ elseSize + 1]. "Dup"
		elseSize _ elseSize + (keyNode sizeForEvaluatedValue: encoder) +
			(equalNode size: encoder args: 1 super: false) +
			(self sizeBranchOn: false dist: thenSize) + thenSize.
		sizeIndex _ sizeIndex - 2].
	^(receiver sizeForValue: encoder) + elseSize
! !

!MessageNode methodsFor: 'code generation'!
sizeForEffect: encoder

	special > 0 
		ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: false].
	^super sizeForEffect: encoder! !

!MessageNode methodsFor: 'code generation'!
sizeForValue: encoder
	| total argSize |
	special > 0 
		ifTrue: [^self perform: (MacroSizers at: special) with: encoder with: true].
	receiver == NodeSuper
		ifTrue: [selector _ selector copy "only necess for splOops"].
	total _ selector size: encoder args: arguments size super: receiver == NodeSuper.
	receiver == nil 
		ifFalse: [total _ total + (receiver sizeForValue: encoder)].
	sizes _ arguments collect: 
					[:arg | 
					argSize _ arg sizeForValue: encoder.
					total _ total + argSize.
					argSize].
	^total! !

!MessageNode methodsFor: 'code generation'!
sizeIf: encoder value: forValue
	| thenExpr elseExpr branchSize thenSize elseSize |
	thenExpr _ arguments at: 1.
	elseExpr _ arguments at: 2.
	(forValue
		or: [(thenExpr isJust: NodeNil)
		or: [elseExpr isJust: NodeNil]]) not
			"(...not ifTrue: avoids using ifFalse: alone during this compile)"
		ifTrue:  "Two-armed IFs forEffect share a single pop"
			[^ super sizeForEffect: encoder].
	forValue
		ifTrue:  "Code all forValue as two-armed"
			[elseSize _ elseExpr sizeForEvaluatedValue: encoder.
			thenSize _ (thenExpr sizeForEvaluatedValue: encoder)
					+ (thenExpr returns
						ifTrue: [0]  "Elide jump over else after a return"
						ifFalse: [self sizeJump: elseSize]).
			branchSize _ self sizeBranchOn: false dist: thenSize]
		ifFalse:  "One arm is empty here (two-arms code forValue)"
			[(elseExpr isJust: NodeNil)
				ifTrue:
					[elseSize _ 0.
					thenSize _ thenExpr sizeForEvaluatedEffect: encoder.
					branchSize _ self sizeBranchOn: false dist: thenSize]
				ifFalse:
					[thenSize _ 0.
					elseSize _ elseExpr sizeForEvaluatedEffect: encoder.
					branchSize _ self sizeBranchOn: true dist: elseSize]].
	sizes _ Array with: thenSize with: elseSize.
	^ (receiver sizeForValue: encoder) + branchSize
			+ thenSize + elseSize! !

!MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 22:00'!
sizeIfNil: encoder value: forValue

	| theNode theSize theSelector |
	equalNode _ encoder encodeSelector: #==.
	sizes _ Array new: 1.
	theNode _ arguments first.
	theSelector _ #ifNotNil:.
	forValue
		ifTrue:
			[sizes at: 1 put: (theSize _ (1 "pop" + (theNode sizeForEvaluatedValue: encoder))).
			 ^(receiver sizeForValue: encoder) +
				2 "Dup. LdNil" +
				(equalNode size: encoder args: 1 super: false) +
				(self 
					sizeBranchOn: (selector key == theSelector) 
					dist: theSize) +
				theSize]
		ifFalse:
			[sizes at: 1 put: (theSize _ (theNode sizeForEvaluatedEffect: encoder)).
			 ^(receiver sizeForValue: encoder) +
				1 "LdNil" +
				(equalNode size: encoder args: 1 super: false) +
				(self 
					sizeBranchOn: (selector key == theSelector) 
					dist: theSize) +
				theSize]

! !

!MessageNode methodsFor: 'code generation'!
sizeToDo: encoder value: forValue 
	" var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: "
	| loopSize initStmt test block incStmt blockSize blockVar initSize limitInit |
	block _ arguments at: 3.
	blockVar _ block firstArgument.
	initStmt _ arguments at: 4.
	test _ arguments at: 5.
	incStmt _ arguments at: 6.
	limitInit _ arguments at: 7.
	initSize _ initStmt sizeForEffect: encoder.
	limitInit == nil
		ifFalse: [initSize _ initSize + (limitInit sizeForEffect: encoder)].
	blockSize _ (block sizeForEvaluatedEffect: encoder)
			+ (incStmt sizeForEffect: encoder) + 2.  "+2 for Jmp backward"
	loopSize _ (test sizeForValue: encoder)
			+ (self sizeBranchOn: false dist: blockSize)
			+ blockSize.
	sizes _ Array with: blockSize with: loopSize.
	^ initSize + loopSize
			+ (forValue ifTrue: [1] ifFalse: [0])    " +1 for value (push nil) "! !

!MessageNode methodsFor: 'code generation'!
sizeWhile: encoder value: forValue 
	"L1: ... Bfp(L2) ... Jmp(L1) L2: nil (nil for value only);
	justStmt, wholeLoop, justJump."
	| cond stmt stmtSize loopSize branchSize |
	cond _ receiver.
	stmt _ arguments at: 1.
	stmtSize _ (stmt sizeForEvaluatedEffect: encoder) + 2.
	branchSize _ self sizeBranchOn: (selector key == #whileFalse:)  "Btp for whileFalse"
					dist: stmtSize.
	loopSize _ (cond sizeForEvaluatedValue: encoder)
			+ branchSize + stmtSize.
	sizes _ Array with: stmtSize with: loopSize.
	^ loopSize    " +1 for value (push nil) "
		+ (forValue ifTrue: [1] ifFalse: [0])! !


!MessageNode methodsFor: 'printing' stamp: 'RAA 6/9/2000 18:06'!
asMorphicCaseOn: parent indent: ignored
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"

	| braceNode otherwise |

	braceNode _ arguments first.
	otherwise _ arguments last.
	((arguments size = 1) or: [otherwise isJustCaseError]) ifTrue: [
		self morphFromKeywords: #caseOf: arguments: {braceNode} on: parent indent: nil.
		^parent
	].
	self morphFromKeywords: #caseOf:otherwise: arguments: arguments on: parent indent: nil.
	^parent
! !

!MessageNode methodsFor: 'printing'!
precedence

	^precedence! !

!MessageNode methodsFor: 'printing' stamp: 'di 4/24/2000 10:32'!
printCaseOn: aStream indent: level 
	"receiver caseOf: {[key]->[value]. ...} otherwise: [otherwise]"
	| braceNode otherwise extra |
	braceNode _ arguments first.
	otherwise _ arguments last.
	(arguments size = 1 or: [otherwise isJustCaseError])
		ifTrue: [otherwise _ nil].
	receiver
		printOn: aStream
		indent: level
		precedence: 3.
	aStream dialect = #SQ00 ifTrue: [aStream nextPutAll: ' caseOf (']
		ifFalse: [aStream nextPutAll: ' caseOf: '].
	braceNode isVariableReference ifTrue: [braceNode printOn: aStream indent: level]
		ifFalse: 
			[aStream nextPutAll: '{';
				 crtab: level + 1.
			braceNode
				casesForwardDo: 
					[:keyNode :valueNode :last | 
					keyNode printOn: aStream indent: level + 1.
					aStream nextPutAll: ' -> '.
					valueNode isComplex
						ifTrue: 
							[aStream crtab: level + 2.
							extra _ 1]
						ifFalse: [extra _ 0].
					valueNode printOn: aStream indent: level + 1 + extra.
					last ifTrue: [aStream nextPut: $}]
						ifFalse: [aStream nextPut: $.;
								 crtab: level + 1]]].
	aStream dialect = #SQ00 ifTrue: [aStream nextPutAll: ')'].
	otherwise isNil
		ifFalse: 
			[aStream dialect = #SQ00 ifTrue: [aStream crtab: level + 1;
					 nextPutAll: ' otherwise (']
				ifFalse: [aStream crtab: level + 1;
						 nextPutAll: ' otherwise: '].
			otherwise isComplex
				ifTrue: 
					[aStream crtab: level + 2.
					extra _ 1]
				ifFalse: [extra _ 0].
			otherwise printOn: aStream indent: level + 1 + extra.
			aStream dialect = #SQ00 ifTrue: [aStream nextPutAll: ')']]! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'!
printIfNil: aStream indent: level

	self printReceiver: receiver on: aStream indent: level.

	^self printKeywords: selector key
		arguments: (Array with: arguments first)
		on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/1/2000 23:20'!
printIfNilNotNil: aStream indent: level

	self printReceiver: receiver ifNilReceiver on: aStream indent: level.

	(arguments first isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifNotNil:
				arguments: { arguments second }
				on: aStream indent: level].
	(arguments second isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifNil:
				arguments: { arguments first }
				on: aStream indent: level].
	^ self printKeywords: #ifNil:ifNotNil:
			arguments: arguments
			on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:11'!
printIfOn: aStream indent: level

	aStream dialect = #SQ00 ifTrue:
		["Convert to if-then-else"
		(arguments last isJust: NodeNil) ifTrue:
			[aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
			self printParenReceiver: receiver on: aStream indent: level + 1.
			^ self printKeywords: #Yes: arguments: (Array with: arguments first)
						on: aStream indent: level prefix: true].
		(arguments last isJust: NodeFalse) ifTrue:
			[self printReceiver: receiver on: aStream indent: level.
			^ self printKeywords: #and: arguments: (Array with: arguments first)
						on: aStream indent: level].
		(arguments first isJust: NodeNil) ifTrue:
			[aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
			self printParenReceiver: receiver on: aStream indent: level + 1.
			^ self printKeywords: #No: arguments: (Array with: arguments last)
						on: aStream indent: level prefix: true].
		(arguments first isJust: NodeTrue) ifTrue:
			[self printReceiver: receiver on: aStream indent: level.
			^ self printKeywords: #or: arguments: (Array with: arguments last)
						on: aStream indent: level].
		aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test '].
		self printParenReceiver: receiver on: aStream indent: level + 1.
		^ self printKeywords: #Yes:No: arguments: arguments
						on: aStream indent: level prefix: true].

	receiver printOn: aStream indent: level + 1 precedence: precedence.
	(arguments last isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifTrue: arguments: (Array with: arguments first)
					on: aStream indent: level].
	(arguments last isJust: NodeFalse) ifTrue:
		[^ self printKeywords: #and: arguments: (Array with: arguments first)
					on: aStream indent: level].
	(arguments first isJust: NodeNil) ifTrue:
		[^ self printKeywords: #ifFalse: arguments: (Array with: arguments last)
					on: aStream indent: level].
	(arguments first isJust: NodeTrue) ifTrue:
		[^ self printKeywords: #or: arguments: (Array with: arguments last)
					on: aStream indent: level].
	self printKeywords: #ifTrue:ifFalse: arguments: arguments
					on: aStream indent: level! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:08'!
printKeywords: key arguments: args on: aStream indent: level

	^ self printKeywords: key arguments: args on: aStream indent: level prefix: false
! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:07'!
printKeywords: key arguments: args on: aStream indent: level prefix: isPrefix
	| keywords indent noColons arg kwd hasBrackets doCrTab |
	args size = 0 ifTrue: [aStream space; nextPutAll: key. ^ self].
	keywords _ key keywords.
	noColons _ aStream dialect = #SQ00 and: [keywords first endsWith: ':'].
	doCrTab _ args size > 2 or:
		[{receiver} , args
			inject: false
			into: [:was :thisArg |
				was or: [(thisArg isKindOf: BlockNode)
					or: [(thisArg isKindOf: MessageNode) and: [thisArg precedence >= 3]]]]].
	1 to: (args size min: keywords size) do:
		[:i | arg _ args at: i.  kwd _ keywords at: i.
		doCrTab
			ifTrue: [aStream crtab: level+1. indent _ 1] "newline after big args"
			ifFalse: [aStream space. indent _ 0].
		noColons
			ifTrue: [aStream withStyleFor: (isPrefix ifTrue: [#prefixKeyword] ifFalse: [#keyword])
						do: [aStream nextPutAll: kwd allButLast; space].
					hasBrackets _ (arg isKindOf: BlockNode) or: [arg isKindOf: BlockNode].
					hasBrackets ifFalse: [aStream nextPutAll: '(']]
			ifFalse: [aStream nextPutAll: kwd; space].
		arg printOn: aStream indent: level + 1 + indent
			 	precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence]).
		noColons
			ifTrue: [hasBrackets ifFalse: [aStream nextPutAll: ')']]]! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:09'!
printOn: aStream indent: level

	| printer leadingKeyword |
	special > 0 ifTrue: [printer _ MacroPrinters at: special].
	(special > 0)
		ifTrue: [self perform: printer with: aStream with: level]
		ifFalse: [selector key first = $:
				ifTrue: [leadingKeyword _ selector key keywords first.
						aStream nextPutAll: leadingKeyword; space.
						self printReceiver: receiver on: aStream indent: level.
						self printKeywords: (selector key allButFirst: leadingKeyword size + 1) arguments: arguments
							on: aStream indent: level]
				ifFalse: [(aStream dialect = #SQ00 and: [selector key == #do:])
						ifTrue: ["Add prefix keyword"
								aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Repeat '].
								self printParenReceiver: receiver on: aStream indent: level + 1.
								self printKeywords: selector key arguments: arguments
									on: aStream indent: level prefix: true]
						ifFalse: [self printReceiver: receiver on: aStream indent: level.
								self printKeywords: selector key arguments: arguments
									on: aStream indent: level]]]! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/30/2000 23:17'!
printOn: strm indent: level precedence: outerPrecedence

	| parenthesize |
	parenthesize _ precedence > outerPrecedence
		or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]].
	parenthesize
		ifTrue: [strm nextPutAll: '('.
				self printOn: strm indent: level.
				strm nextPutAll: ')']
		ifFalse: [self printOn: strm indent: level]! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/7/2000 08:28'!
printParenReceiver: rcvr on: aStream indent: level
					
	(rcvr isKindOf: BlockNode) ifTrue:
		[^ rcvr printOn: aStream indent: level].
	aStream nextPutAll: '('.
	rcvr printOn: aStream indent: level.
	aStream nextPutAll: ')'
! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/30/2000 23:06'!
printReceiver: rcvr on: aStream indent: level
					
	rcvr ifNil: [^ self].

	"Force parens around keyword receiver of kwd message"
	(precedence = 3 and: [aStream dialect = #SQ00])
		ifTrue: [rcvr printOn: aStream indent: level precedence: precedence - 1]
		ifFalse: [rcvr printOn: aStream indent: level precedence: precedence]
! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:12'!
printToDoOn: aStream indent: level

	| limitNode |
	aStream dialect = #SQ00
		ifTrue: ["Add prefix keyword"
				aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Repeat '].
				self printParenReceiver: receiver on: aStream indent: level + 1]
		ifFalse: [self printReceiver: receiver on: aStream indent: level].

	(arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not])
		ifTrue: [limitNode _ arguments first]
		ifFalse: [limitNode _ arguments last value].
	(selector key = #to:by:do:
			and: [(arguments at: 2) isConstantNumber
				and: [(arguments at: 2) key = 1]])
		ifTrue: [self printKeywords: #to:do:
					arguments: (Array with: limitNode with: (arguments at: 3))
					on: aStream indent: level prefix: true]
		ifFalse: [self printKeywords: selector key
					arguments: (Array with: limitNode) , arguments allButFirst
					on: aStream indent: level prefix: true]! !

!MessageNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:12'!
printWhileOn: aStream indent: level

	aStream dialect = #SQ00
		ifTrue: ["Add prefix keyword"
				aStream withStyleFor: #prefixKeyword
						do: [aStream nextPutAll: (selector key == #whileTrue:
									ifTrue: ['While '] ifFalse: ['Until '])].
				self printParenReceiver: receiver on: aStream indent: level + 1.
				self printKeywords: #do: arguments: arguments
					on: aStream indent: level prefix: true]
		ifFalse: [self printReceiver: receiver on: aStream indent: level.
				(arguments first isJust: NodeNil) ifTrue:
						[selector _ SelectorNode new
								key: (selector key == #whileTrue:
									ifTrue: [#whileTrue] ifFalse: [#whileFalse])
								code: #macro.
						arguments _ Array new].
				self printKeywords: selector key arguments: arguments
					on: aStream indent: level]! !

!MessageNode methodsFor: 'printing' stamp: 'di 5/2/2000 00:16'!
test

	3 > 4 ifTrue: [4+5 between: 6 and: 7]
			ifFalse: [4 between: 6+5 and: 7-2]! !


!MessageNode methodsFor: 'private'!
checkBlock: node as: nodeName from: encoder

	node canBeSpecialArgument ifTrue: [^node isMemberOf: BlockNode].
	((node isKindOf: BlockNode) and: [node numberOfArguments > 0])
		ifTrue:	[^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' must be 0-argument block']
		ifFalse: [^encoder notify: '<- ', nodeName , ' of ' ,
					(MacroSelectors at: special) , ' must be a block or variable']! !

!MessageNode methodsFor: 'private' stamp: 'acg 1/28/2000 00:57'!
ifNilReceiver

	^receiver! !

!MessageNode methodsFor: 'private' stamp: 'tk 8/2/1999 18:40'!
pvtCheckForPvtSelector: encoder
	"If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder."

	selector isPvtSelector ifTrue:
		[receiver isSelfPseudoVariable ifFalse:
			[encoder notify: 'Private messages may only be sent to self']].! !

!MessageNode methodsFor: 'private'!
receiver: rcvr arguments: args precedence: p

	receiver _ rcvr.
	arguments _ args.
	sizes _ Array new: arguments size.
	precedence _ p! !

!MessageNode methodsFor: 'private'!
transformCase: encoder

	| caseNode |
	caseNode _ arguments first.
	(caseNode isKindOf: BraceNode)
		ifTrue:
			[^(caseNode blockAssociationCheck: encoder) and:
			 	[arguments size = 1 or:
					[self checkBlock: arguments last as: 'otherwise arg' from: encoder]]].
	(caseNode canBeSpecialArgument and: [(caseNode isMemberOf: BlockNode) not])
		ifTrue:
			[^false]. "caseOf: variable"
	^encoder notify: 'caseOf: argument must be a brace construct or a variable'! !


!MessageNode methodsFor: 'equation translation'!
arguments
	^arguments! !

!MessageNode methodsFor: 'equation translation' stamp: 'tk 10/27/2000 15:11'!
arguments: list
	arguments _ list! !

!MessageNode methodsFor: 'equation translation' stamp: 'tk 8/4/1999 17:33'!
eval
	"When everything in me is a constant, I can produce a value.  This is only used by the Scripting system (TilePadMorph tilesFrom:in:)"

	| rec args |
	(receiver isKindOf: VariableNode) ifFalse: [^ #illegal].
	rec _ receiver key value.
	args _ arguments collect: [:each | each eval].
	^ rec perform: selector key withArguments: args! !

!MessageNode methodsFor: 'equation translation'!
receiver
	^receiver! !

!MessageNode methodsFor: 'equation translation'!
receiver: val
	^receiver _ val! !

!MessageNode methodsFor: 'equation translation'!
selector
	^selector! !


!MessageNode methodsFor: 'C translation'!
asTranslatorNode
	"selector is sometimes a Symbol, sometimes a SelectorNode!!
	On top of this, numArgs is needed due to the (truly grody) use of
	arguments as a place to store the extra expressions needed to generate
	code for in-line to:by:do:, etc.  see below, where it is used."
	| sel args |
	sel _ (selector isMemberOf: Symbol) ifTrue: [selector] ifFalse: [selector key].
	args _ (1 to: sel numArgs) collect:
			[:i | (arguments at: i) asTranslatorNode].
	(sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]])
		ifTrue: ["Restore limit expr that got moved by transformToDo:"
				args at: 1 put: (arguments at: 7) value asTranslatorNode].
	(sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
		ifTrue: ["Restore argument block that got moved by transformOr:"
				args at: 1 put: (arguments at: 2) asTranslatorNode].
	(sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]])
		ifTrue: ["Restore argument block that got moved by transformIfFalse:"
				args at: 1 put: (arguments at: 2) asTranslatorNode].
	^ TSendNode new
		setSelector: sel
		receiver: ((receiver == nil)
					ifTrue: [nil]
					ifFalse: [receiver asTranslatorNode])
		arguments: args! !


!MessageNode methodsFor: 'tiles' stamp: 'tk 1/25/2001 17:19'!
asMorphicSyntaxIn: parent

	| printer substitute row sel |
	sel _ #message.
	((parent nodeClassIs: CascadeNode) and: [parent parseNode receiver ~~ self]) ifTrue: [
		sel _ #keyword2.
		receiver ifNotNil: [self inform: 'receiver should be nil']].
	row _ parent addRow: sel on: self.
	special > 0 ifTrue: [printer _ MacroPrinters at: special].
	substitute _ self as: TileMessageNode.
	(printer == #printCaseOn:indent:) ifTrue: [
		self asMorphicCaseOn: row indent: nil.
		^ parent].
	(special > 0)
		ifTrue: 
			[substitute perform: printer with: row with: nil]
		ifFalse: 
			[substitute 
				printKeywords: selector key
				arguments: arguments
				on: row
				indent: nil].
	^ row addTransparentSpacerOfSize: 3@10.
! !

!MessageNode methodsFor: 'tiles' stamp: 'tk 1/15/2001 15:43'!
morphFromKeywords: key arguments: args on: parent indent: ignored
	| keywords column row receiverMorph firstArgMorph receiverWidth
messageWidth onlyOne selfWithNilReceiver |
	receiver ifNotNil: ["i.e. not a cascade"
			receiverMorph _ receiver asMorphicSyntaxIn: parent].
	keywords _ key keywords.
	args size = 0 ifTrue:
			[row _ (parent addTextRow: key) layoutInset: 1.
			^ row parseNode: selector].
	receiverWidth _ receiver
				ifNil: [0]
				ifNotNil: [receiverMorph fullBounds width].
	onlyOne _ args size = 1.
	(receiverWidth <= 80 and: [onlyOne])
		ifTrue: [row _ (parent addTextRow: keywords first) layoutInset: 1.
			row parseNode: selector.
			firstArgMorph _ args first asMorphicSyntaxIn: parent.
			receiver ifNil: [^ self].
			(firstArgMorph fullBounds height > 100
					or: [firstArgMorph fullBounds width > 250])
				ifTrue: [parent foldMessageOneArg].
			^ self].
	selfWithNilReceiver _ self copy receiver: nil.
	column _ parent addColumn: #keyword1 on: selfWithNilReceiver.
	messageWidth _ 0.
	keywords
		with: (args copyFrom: 1 to: keywords size)
		do: [:kwd :arg |
			(row _ column addRow: #keyword2 on: selfWithNilReceiver) borderWidth: 1;
				parseNode: (selfWithNilReceiver as: 
						(onlyOne ifTrue: [MessageNode] ifFalse: [MessagePartNode]));
				 borderColor: row stdBorderColor.
			row addToken: kwd
				type: #keyword2
				on: (onlyOne ifTrue: [SelectorNode new key: kwd code: nil "fill this in?"]
								ifFalse: [KeyWordNode new]).
			arg asMorphicSyntaxIn: row.
			messageWidth _ messageWidth + row fullBounds width].
	receiverMorph ifNotNil:
		[receiverWidth + messageWidth < 350 ifTrue: [^ parent unfoldMessage].
			((receiverWidth > 200
						or: [receiverWidth > 80
								and: [column fullBounds height > 20]])
					or: [receiverMorph fullBounds width > 30
							and: [column fullBounds height > 100
									or: [column fullBounds width > 250]]])
				ifTrue: [^ parent foldMessage]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MessageNode class
	instanceVariableNames: ''!

!MessageNode class methodsFor: 'class initialization' stamp: 'acg 1/28/2000 21:58'!
initialize		"MessageNode initialize"
	MacroSelectors _ 
		#(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:
			and: or:
			whileFalse: whileTrue: whileFalse whileTrue
			to:do: to:by:do:
			caseOf: caseOf:otherwise:
			ifNil: ifNotNil:  ifNil:ifNotNil: ifNotNil:ifNil:).
	MacroTransformers _ 
		#(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue:
			transformAnd: transformOr:
			transformWhile: transformWhile: transformWhile: transformWhile:
			transformToDo: transformToDo:
			transformCase: transformCase:
			transformIfNil: transformIfNil:  transformIfNilIfNotNil: transformIfNotNilIfNil:).
	MacroEmitters _ 
		#(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value:
			emitIf:on:value: emitIf:on:value:
			emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value:
			emitToDo:on:value: emitToDo:on:value:
			emitCase:on:value: emitCase:on:value:
			emitIfNil:on:value: emitIfNil:on:value: emitIf:on:value: emitIf:on:value:).
	MacroSizers _ 
		#(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value:
			sizeIf:value: sizeIf:value:
			sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value:
			sizeToDo:value: sizeToDo:value:
			sizeCase:value: sizeCase:value:
			sizeIfNil:value: sizeIfNil:value: sizeIf:value: sizeIf:value: ).
	MacroPrinters _ 
		#(printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent:
			printIfOn:indent: printIfOn:indent:
			printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent:
			printToDoOn:indent: printToDoOn:indent:
			printCaseOn:indent: printCaseOn:indent:
			printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)! !
Error subclass: #MessageNotUnderstood
	instanceVariableNames: 'message '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!MessageNotUnderstood commentStamp: '<historical>' prior: 0!
This exception is provided to support Object>>doesNotUnderstand:.!


!MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'tfei 6/13/1999 02:31'!
message: aMessage
	"TFEI extension"

	message := aMessage! !


!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:30'!
isResumable
	"Determine whether an exception is resumable."

	^true! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:27'!
message
	"Answer the selector and arguments of the message that failed."

	^message! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/5/1999 17:24'!
messageText
	
"Return an exception's message text."

	^messageText == nil
		ifTrue:
			[message == nil
				ifTrue: [super messageText]
				ifFalse: [message selector asString]]
		ifFalse:
			[messageText]! !

!MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:31'!
receiver
	"Answer the receiver of the message that failed."

	^initialContext receiver! !
MessageNode subclass: #MessagePartNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Tile Scriptors'!
Object subclass: #MessageSend
	instanceVariableNames: 'receiver selector arguments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!MessageSend commentStamp: '<historical>' prior: 0!
Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. MessageSends are used to implement the #when:send:to: event system.

Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied.

Structure:
 receiver		Object -- object receiving the message send
 selector		Symbol -- message selector
 arguments		Array -- bound arguments!


!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
arguments
	^ arguments! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'!
arguments: anArray
	arguments _ anArray! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver
	^ receiver! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
receiver: anObject
	receiver _ anObject! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector
	^ selector! !

!MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'!
selector: aSymbol
	selector _ aSymbol! !


!MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'!
= anObject
	^ anObject species == self species 
		and: [receiver == anObject receiver
		and: [selector == anObject selector
		and: [arguments = anObject arguments]]]! !

!MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'!
hash
	^ receiver hash bitXor: selector hash! !


!MessageSend methodsFor: 'evaluating' stamp: 'mir 7/25/2000 19:11'!
value
	^arguments isNil
		ifTrue: [receiver perform: selector]
		ifFalse: [receiver perform: selector withArguments: arguments]! !

!MessageSend methodsFor: 'evaluating' stamp: 'sma 2/29/2000 20:45'!
valueWithArguments: anArray
	^ receiver perform: selector withArguments: arguments , anArray! !


!MessageSend methodsFor: 'tiles' stamp: 'tk 11/15/2000 15:19'!
asTilesIn: playerClass
	| code keywords num tree syn block phrase |
	"Construct SyntaxMorph tiles for me."

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab.
		strm nextPutAll: (self stringFor: receiver).
		keywords _ selector keywords.
		strm space; nextPutAll: keywords first.
		(num _ selector numArgs) > 0 ifTrue: [strm space. 
					strm nextPutAll: (self stringFor: arguments first)].
		2 to: num do: [:kk |
			strm space; nextPutAll: (keywords at: kk).
			strm space; nextPutAll: (self stringFor: (arguments at: kk))]].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: playerClass
		notifying: nil.
	syn _ tree asMorphicSyntaxUsing: SyntaxMorph.
	block _ syn submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == BlockNode] ifFalse: [false]].
	phrase _ block submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == MessageNode] ifFalse: [false]].
	^ phrase

! !

!MessageSend methodsFor: 'tiles' stamp: 'tk 1/2/2001 14:27'!
stringFor: anObject
	| generic aName |
	"Return a string suitable for compiling.  Literal or reference from global ref dictionary.  self is always named via the ref dictionary."

	anObject isLiteral ifTrue: [^ anObject printString].
	anObject class == Color ifTrue: [^ anObject printString].
	anObject class superclass == Boolean ifTrue: [^ anObject printString].
	anObject class == BlockContext ifTrue: [^ '[''do nothing'']'].	"default block"
		"Real blocks need to construct tiles in a different way"
	generic _ anObject knownName.	"may be nil or 'Ellipse' "
	aName _ anObject uniqueNameForReference.
	generic = aName ifFalse: [anObject renameTo: aName].
	^ aName
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MessageSend class
	instanceVariableNames: ''!

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'!
receiver: anObject selector: aSymbol
	^ self receiver: anObject selector: aSymbol arguments: #()! !

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'!
receiver: anObject selector: aSymbol argument: aParameter
	^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! !

!MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:39'!
receiver: anObject selector: aSymbol arguments: anArray
	^ self new
		receiver: anObject;
		selector: aSymbol;
		arguments: anArray! !
Browser subclass: #MessageSet
	instanceVariableNames: 'messageList autoSelectString growable '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!MessageSet commentStamp: '<historical>' prior: 0!
I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.!


!MessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:57'!
addExtraShiftedItemsTo: aMenu
	"The shifted selector-list menu is being built.  Add items specific to MessageSet"

	self growable ifTrue:
		[aMenu addList: #(
			-
			('remove from this browser'		removeMessageFromBrowser)
			('filter message list...'			filterMessageList)
			('add to message list...'			augmentMessageList))]! !

!MessageSet methodsFor: 'message list' stamp: 'sw 1/28/2001 20:56'!
growable
	"Answer whether the receiver is capable of growing/shrinking dynamically"

	^ growable ~~ false! !

!MessageSet methodsFor: 'message list' stamp: 'sw 12/6/2000 07:12'!
growable: aBoolean
	"Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list"

	growable _ aBoolean! !

!MessageSet methodsFor: 'message list'!
messageList
	"Answer the current list of messages."

	^messageList! !

!MessageSet methodsFor: 'message list' stamp: 'sw 1/5/2001 07:20'!
messageListIndex: anInteger 
	"Set the index of the selected item to be anInteger."

	messageListIndex _ anInteger.
	contents _ 
		messageListIndex ~= 0
			ifTrue: [self selectedMessage]
			ifFalse: [''].
	self changed: #messageListIndex.	 "update my selection"
	editSelection _ #editMessage.
	self contentsChanged.
	(messageListIndex ~= 0 and: [autoSelectString notNil])
		ifTrue: [self changed: #autoSelect].
	self decorateButtons
! !

!MessageSet methodsFor: 'message list' stamp: 'sbw 12/30/1999 17:19'!
optionalButtonHeight

	^ 15! !

!MessageSet methodsFor: 'message list' stamp: 'sma 3/3/2000 11:17'!
selectedMessageName
	"Answer the name of the currently selected message."
	"wod 6/16/1998: answer nil if none are selected."

	messageListIndex = 0 ifTrue: [^ nil].
	^ self setClassAndSelectorIn: [:class :selector | ^ selector]! !


!MessageSet methodsFor: 'message functions' stamp: 'sw 12/11/2000 15:51'!
deleteFromMessageList: aMessage
	"Delete the given message from the receiver's message list"

	messageList _ messageList copyWithout: aMessage! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 2/24/1999 18:31'!
methodCategoryChanged
	self changed: #annotation! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 12/1/2000 11:54'!
reformulateList
	"The receiver's messageList has been changed; rebuild it"

	super reformulateList.
	self initializeMessageList: messageList.
	self changed: #messageList.
	self changed: #messageListIndex.
	self contentsChanged
! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 12/1/2000 11:52'!
removeMessage
	"Remove the selected message from the system. 1/15/96 sw"

	| messageName confirmation |

	messageListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageName _ self selectedMessageName.
	confirmation _ self selectedClassOrMetaClass confirmRemovalOf: messageName.
	confirmation == 3 ifTrue: [^ self].

	self selectedClassOrMetaClass removeSelector: messageName.
	self deleteFromMessageList: self selection.
	self reformulateList.

	confirmation == 2 ifTrue:
		[Smalltalk browseAllCallsOn: messageName]! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 1/12/2001 00:19'!
removeMessageFromBrowser
	"Remove the selected message from the browser."

	messageListIndex = 0 ifTrue: [^ self].
	self deleteFromMessageList: self selection.
	self reformulateList.
	self adjustWindowTitleAfterFiltering
! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 1/18/2001 13:58'!
toggleDiffing
	"Differs from the inherited version in that it does not set contents to nil"

	self okToChange ifTrue:
		[self showDiffs: self showDiffs not.
		self changed: #contents]

! !

!MessageSet methodsFor: 'message functions' stamp: 'sw 12/5/2000 16:48'!
toggleShowDocumentation
	"Toggle the setting of the showDocumentation flag"

	self okToChange ifTrue:
		[self showDocumentation: self showingDocumentation not.
		self changed: #contents]

! !


!MessageSet methodsFor: 'class list'!
metaClassIndicated
	"Answer the boolean flag that indicates whether
	this is a class method."

	^ self selectedClassOrMetaClass isMeta! !

!MessageSet methodsFor: 'class list'!
selectedClass 
	"Return the base class for the current selection.  1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"

	| aClass |
	^ (aClass _ self selectedClassOrMetaClass) == nil
		ifTrue:
			[nil]
		ifFalse:
			[aClass theNonMetaClass]! !

!MessageSet methodsFor: 'class list' stamp: 'tk 4/4/98 18:50'!
selectedClassName
	"Answer the name of class of the currently selected message. Answer nil if no selection 
	exists."

	| cls |
	(cls _ self selectedClass) ifNil: [^ nil].
	^ cls name! !

!MessageSet methodsFor: 'class list'!
selectedClassOrMetaClass
	"Answer the currently selected class (or metaclass)."
	messageListIndex = 0 ifTrue: [^nil].
	self setClassAndSelectorIn: [:c :s | ^c]! !

!MessageSet methodsFor: 'class list'!
selectedMessageCategoryName 
	"Answer the name of the selected message category or nil."
	messageListIndex = 0 ifTrue: [^ nil].
	^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName! !


!MessageSet methodsFor: 'contents' stamp: 'sma 5/28/2000 11:09'!
contents
	^ contents == nil
		ifTrue: [currentCompiledMethod _ nil. '']
		ifFalse: [messageListIndex = 0 
			ifTrue: [currentCompiledMethod _ nil. contents]
			ifFalse: [editSelection == #byteCodes
				ifTrue: [(self selectedClassOrMetaClass
							compiledMethodAt: self selectedMessageName) symbolic]
				ifFalse: [self selectedMessage]]]! !

!MessageSet methodsFor: 'contents' stamp: 'sw 12/5/2000 12:17'!
selectedMessage
	"Answer the source method for the currently selected message."

	| source |

	self setClassAndSelectorIn: [:class :selector | 
		class ifNil: [^ 'Class vanished'].
		source _ class sourceMethodAt: selector ifAbsent:
			[currentCompiledMethod _ nil.
			^ 'Missing'].
		currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil].
		self showingDocumentation ifTrue:
			[^ self commentContents].

		Preferences browseWithPrettyPrint ifTrue:
			[source _ class compilerClass new
				format: source in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting].
		self showDiffs ifTrue:
			[source _ self diffFromPriorSourceFor: source].
		^ source asText makeSelectorBoldIn: class]! !

!MessageSet methodsFor: 'contents' stamp: 'sw 10/19/1999 17:30'!
updateCodePaneIfNeeded
	"If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits.
	Overridden here in order not to set contents to nil"

	self didCodeChangeElsewhere
		ifTrue:
			[self hasUnacceptedEdits
				ifFalse:
					[self contentsChanged]
				ifTrue:
					[self changed: #codeChangedElsewhere]]! !


!MessageSet methodsFor: 'private' stamp: 'sw 1/11/2001 09:16'!
adjustWindowTitleAfterFiltering
	"Set the title of the receiver's window, if any, to reflect the just-completed filtering"

	| aWindow existingLabel newLabel |

	(aWindow _ self containingWindow) ifNil: [^ self].
	(existingLabel _ aWindow label) isEmptyOrNil ifTrue: [^ self].
	(((existingLabel size < 3) or: [existingLabel last ~~ $]]) or: [(existingLabel at: (existingLabel size - 1)) isDigit not]) ifTrue: [^ self].
	existingLabel size to: 1 by: -1 do:
		[:anIndex | ((existingLabel at: anIndex) == $[) ifTrue:
			[newLabel _ (existingLabel copyFrom: 1 to: anIndex),
				'Filtered: ',
				messageList size printString,
				']'.
			^ aWindow setLabel: newLabel]]
			

! !

!MessageSet methodsFor: 'private'!
autoSelectString
	"Return the string to be highlighted when making new selections"
	^ autoSelectString! !

!MessageSet methodsFor: 'private'!
autoSelectString: aString
	"Set the string to be highlighted when making new selections"
	autoSelectString _ aString! !

!MessageSet methodsFor: 'private' stamp: 'sw 12/9/2000 23:59'!
contents: aString notifying: aController 
	"Compile the code in aString. Notify aController of any syntax errors. 
	Answer false if the compilation fails. Otherwise, if the compilation 
	created a new method, deselect the current selection. Then answer
true."
	| category selector class oldSelector |
	messageListIndex = 0 ifTrue: [^ false].
	self okayToAccept ifFalse: [^ false].
	self setClassAndSelectorIn: [:c :os | class_c.  oldSelector_os].
	category _ class organization categoryOfElement: oldSelector.
	selector _ class compile: aString
				classified: category
				notifying: aController.
	selector == nil ifTrue: [^ false].
	self noteAcceptanceOfCodeFor: selector.
	selector == oldSelector ifFalse:
		[self reformulateListNoting: selector].
	contents _ aString copy.
	self changed: #annotation.
	^ true! !

!MessageSet methodsFor: 'private' stamp: 'sw 12/9/2000 17:13'!
initializeMessageList: anArray
	"Initialize the message list from anArray, which must contain objects which, when sent #asString, answer a string in standard format such as 'Rectangle width'"

	messageList _ anArray collect: [:each |
		MessageSet parse: each asString toClassAndSelector: [:class :sel |
			class ifNotNil: [class name , ' ' , sel , ' {' , ((class organization categoryOfElement: sel) ifNil: ['']) , '}']]]
		thenSelect:
			[:each | each notNil].
	messageListIndex _ 0.
	contents _ ''! !

!MessageSet methodsFor: 'private' stamp: 'RAA 1/10/2001 11:14'!
openAsMorphNamed: labelString inWorld: aWorld

	| window listFraction |

	window _ (SystemWindow labelled: labelString) model: self.
	listFraction _ 0.2.
	window addMorph: self buildMorphicMessageList frame: (0@0 extent: 1@listFraction).
	self 
		addLowerPanesTo: window 
		at: (0@listFraction corner: 1@1) 
		with: nil.

	window setUpdatablePanesFrom: #(messageList).
	window openInWorld: aWorld! !

!MessageSet methodsFor: 'private' stamp: 'sw 12/28/2000 14:28'!
selection
	"Answer the item in the list that is currently selected, or nil if no selection is present"

	^ messageList at: messageListIndex ifAbsent: [nil]! !

!MessageSet methodsFor: 'private'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form <className> [class] <selectorName>."
	^ MessageSet parse: self selection toClassAndSelector: csBlock! !

!MessageSet methodsFor: 'private' stamp: 'sw 1/11/2001 09:18'!
setFilteredList: newList
	"Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing"

	newList size == 0
		ifTrue:
			[^ self inform: 'Nothing would be left in the list if you did that'].
	newList size == messageList size
		ifTrue:
			[^ self inform: 'That leaves the list unchanged'].
	self initializeMessageList: newList.
	self adjustWindowTitleAfterFiltering! !


!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:47'!
augmentMessageList
	"Allow the user to add to the list of messages."

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/11/2001 09:33'!
filterFrom: aBlock
	"Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments."

	| newList |
	newList _ messageList select:
		[:anElement |
			self class parse: anElement toClassAndSelector: aBlock].
	self setFilteredList: newList! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 20:00'!
filterMessageList
	"Allow the user to refine the list of messages."

	| aMenu evt |
	Smalltalk isMorphic ifFalse: [^ self inform: 'sorry, morphic only at this time.'].
	messageList size <= 1 ifTrue: [^ self inform: 'this is not a propitious filtering situation'].

	"would like to get the evt coming in but thwarted by the setInvokingView: circumlocution"
	evt _ self currentWorld activeHand lastEvent.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Filter by only showing...'.
	aMenu addStayUpItem.

	aMenu addList: #(
		('messages that send...'					filterToSendersOf)
		-
		('messages in current change set'		filterToCurrentChangeSet)
		('messages not in current change set'	filterToNotCurrentChangeSet)
		('messages in any change set'			filterToAnyChangeSet)
		-
		('messages authored by me'				filterToCurrentAuthor)
		('messages not authored by me'			filterToNotCurrentAuthor)
		-
		('messages only in .changes file'		filterToMessagesInChangesFile)
		('messages with prior versions'			filterToMessagesWithPriorVersions)
			).

	aMenu popUpEvent: evt hand lastEvent in: evt hand world.! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:00'!
filterToAnyChangeSet
	"Filter down only to messages present in ANY change set"

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:02'!
filterToCurrentAuthor
	"Filter down only to messages with my initials as most recent author"

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/11/2001 09:34'!
filterToCurrentChangeSet
	"Filter the receiver's list down to only those items in the current change set"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(Smalltalk changes atSelector: aSelector class: aClass) ~~ #none]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:03'!
filterToMessagesInChangesFile
	"Filter down only to messages whose source code risides in the Changes file.  This allows one to ignore long-standing methods that live in the .sources file."

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:03'!
filterToMessagesWithPriorVersions
	"Filter down only to messages which have at least one prior version"

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 16:01'!
filterToNotCurrentAuthor
	"Filter down only to messages not stamped with my initials"

	self notYetImplemented
! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/12/2001 00:02'!
filterToNotCurrentChangeSet
	"Filter the receiver's list down to only those items not in the current change set"

	self filterFrom:
		[:aClass :aSelector |
			(aClass notNil and: [aSelector notNil]) and:
				[(Smalltalk changes atSelector: aSelector class: aClass) == #none]]! !

!MessageSet methodsFor: 'filtering' stamp: 'sw 1/19/2001 15:58'!
filterToSendersOf
	"Filter the receiver's list down to only those items which send a given selector"

	| aFragment inputWithBlanksTrimmed aMethod |

	aFragment _ FillInTheBlank request: 'type selector:' initialAnswer: ''.
	aFragment  isEmptyOrNil ifTrue: [^ self].
	inputWithBlanksTrimmed _ aFragment withBlanksTrimmed.
	Symbol hasInterned: inputWithBlanksTrimmed ifTrue:
		[:aSymbol | 
			self filterFrom:
				[:aClass :aSelector |
					(aMethod _ aClass compiledMethodAt: aSelector) notNil and:
						[aMethod hasLiteralThorough: aSymbol]]]

! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MessageSet class
	instanceVariableNames: ''!

!MessageSet class methodsFor: 'instance creation'!
messageList: anArray 
	"Answer an instance of me with message list anArray."

	^self new initializeMessageList: anArray! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sw 1/24/2001 21:24'!
open: aMessageSet name: aString 
	"Create a standard system view for the messageSet, aMessageSet, whose label is aString."
	| topView aListView aBrowserCodeView aTextView underPane y buttonsView winWidth |

	Smalltalk isMorphic ifTrue: [^ self openAsMorph: aMessageSet name: aString].

	winWidth _ 200.
	topView _ (StandardSystemView new) model: aMessageSet.
	topView label: aString.
	topView minimumSize: winWidth @ 120.
	topView borderWidth: 1.

	aListView _ PluggableListView on: aMessageSet
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	aListView  menuTitleSelector: #messageListSelectorTitle.
	aListView window: (0 @ 0 extent: winWidth @ 100).
	topView addSubView: aListView.

	aMessageSet  wantsAnnotationPane
		ifTrue:
			[aTextView _ PluggableTextView on: aMessageSet 
			text: #annotation accept: nil
			readSelection: nil menu: nil.
			aTextView window: (0 @ 0 extent: winWidth @ 24).
			topView addSubView: aTextView below: aListView.
			underPane _ aTextView.
			y _ 300 - 24.
			aTextView askBeforeDiscardingEdits: false]
		ifFalse:
			[underPane _ aListView.
			y _ 300].

	aMessageSet wantsOptionalButtons ifTrue:
		[buttonsView _ aMessageSet buildOptionalButtonsView.
		topView addSubView: buttonsView below: underPane.
		underPane _ buttonsView.
		y _ y - aMessageSet optionalButtonHeight].

	aBrowserCodeView _ PluggableTextView on: aMessageSet 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	aBrowserCodeView window: (0 @ 0 extent: winWidth @ y).
	topView addSubView: aBrowserCodeView below: underPane.
	topView setUpdatablePanesFrom: #(messageList).
	topView controller open! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:41'!
openAsMorph: aMessageSet name: labelString 
	"Create a SystemWindow aMessageSet, with the label labelString, in a Morphic project"
	^ self openAsMorph: aMessageSet name: labelString inWorld: self currentWorld! !

!MessageSet class methodsFor: 'instance creation' stamp: 'RAA 1/10/2001 11:07'!
openAsMorph: aMessageSet name: labelString inWorld: aWorld

	^aMessageSet openAsMorphNamed: labelString inWorld: aWorld
! !

!MessageSet class methodsFor: 'instance creation'!
openMessageList: anArray name: aString 
	"Create a standard system view for the message set on the list, anArray. 
	The label of the view is aString."

	self open: (self messageList: anArray) name: aString! !

!MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:59'!
openMessageList: messageList name: labelString autoSelect: autoSelectString
	"Open a system view for a MessageSet on messageList. 
	 1/24/96 sw: the there-are-no msg now supplied by my sender"

	| messageSet |
	messageSet _ self messageList: messageList.
	messageSet autoSelectString: autoSelectString.
	Smalltalk isMorphic ifTrue: [^ self openAsMorph: messageSet name: labelString].
	ScheduledControllers scheduleActive: (self open: messageSet name: labelString)! !


!MessageSet class methodsFor: 'utilities' stamp: 'sw 1/27/2001 12:18'!
extantMethodsIn: aList
	"Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image"

	^ aList select:
		[:aToken |
			self parse: aToken toClassAndSelector:
				[:aClass :aSelector | aClass notNil and: [aClass includesSelector: aSelector]]]! !

!MessageSet class methodsFor: 'utilities' stamp: 'sw 1/28/2001 23:40'!
parse: messageString toClassAndSelector: csBlock
	"Decode strings of the form <className> [class] <selectorName>."

	| tuple cl |
	messageString ifNil: [^ csBlock value: nil value: nil].
	tuple _ messageString findTokens: ' .'.
	cl _ Smalltalk atOrBelow: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
	(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
		ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol]
		ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! !
Magnitude subclass: #MessageTally
	instanceVariableNames: 'class method tally receivers senders time '
	classVariableNames: 'ObservedProcess Timer '
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!MessageTally commentStamp: '<historical>' prior: 0!
My instances observe and report the amount of time spent in methods. Observing a method implies observing all messages it sends.

Q: How do you interpret MessageTally>>tallySends
A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format.  #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.!


!MessageTally methodsFor: 'initialize-release'!
close

	(Timer isMemberOf: Process) ifTrue: [Timer terminate].
	Timer _ ObservedProcess _ nil.
	class _ method _ tally _ receivers _ nil! !

!MessageTally methodsFor: 'initialize-release' stamp: 'stp 05/07/1999 15:31'!
spyEvery: millisecs on: aBlock 
	"Create a spy and spy on the given block at the specified rate."

	| myDelay value startTime time0 |
	(aBlock isMemberOf: BlockContext)
		ifFalse: [self error: 'spy needs a block here'].
	self class: aBlock receiver class method: aBlock method.
		"set up the probe"
	ObservedProcess _ Processor activeProcess.
	myDelay := Delay forMilliseconds: millisecs.
	time0 := Time millisecondClockValue.
	Timer :=
		[[true] whileTrue: 
			[startTime := Time millisecondClockValue.
			myDelay wait.
			self tally: ObservedProcess suspendedContext
				"tally can be > 1 if ran a long primitive"
				by: (Time millisecondClockValue - startTime) // millisecs].
		nil] newProcess.
	Timer priority: Processor userInterruptPriority.
		"activate the probe and evaluate the block"
	Timer resume.
	value := aBlock value.
		"cancel the probe and return the value"
	Timer terminate.
	time := Time millisecondClockValue - time0.
	^value! !

!MessageTally methodsFor: 'initialize-release' stamp: 'nk 10/27/2000 11:08'!
spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration 
	"Create a spy and spy on the given process at the specified rate."
	| myDelay time0 endTime sem |
	(aProcess isKindOf: Process)
		ifFalse: [self error: 'spy needs a Process here'].
	self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method.
	"set up the probe"
	ObservedProcess _ aProcess.
	myDelay _ Delay forMilliseconds: millisecs.
	time0 _ Time millisecondClockValue.
	endTime _ time0 + msecDuration.
	sem _ Semaphore new.
	Timer _ [[| startTime | 
			startTime _ Time millisecondClockValue.
			myDelay wait.
			self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs.
			startTime < endTime] whileTrue.
			sem signal]
				forkAt: (ObservedProcess priority + 1 min: Processor highestPriority).
	"activate the probe and wait for it to finish"
	sem wait.
	time _ Time millisecondClockValue - time0! !


!MessageTally methodsFor: 'comparing'!
< aMessageTally 
	"Refer to the comment in Magnitude|<."

	^tally > aMessageTally tally! !

!MessageTally methodsFor: 'comparing'!
= aMessageTally

	^aMessageTally method == method! !

!MessageTally methodsFor: 'comparing'!
> aMessageTally 
	"Refer to the comment in Magnitude|>."

	^tally < aMessageTally tally! !

!MessageTally methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^method asOop! !

!MessageTally methodsFor: 'comparing'!
isPrimitives
	"Detect pseudo node used to carry tally of local hits"
	^ receivers == nil! !

!MessageTally methodsFor: 'comparing'!
sonsOver: threshold

	| hereTally last sons |
	(receivers == nil or: [receivers size = 0]) ifTrue: [^#()].
	hereTally _ tally.
	sons _ receivers select:  "subtract subNode tallies for primitive hits here"
		[:son |
		hereTally _ hereTally - son tally.
		son tally > threshold].
	hereTally > threshold
		ifTrue: 
			[last _ MessageTally new class: class method: method.
			^sons copyWith: (last primitives: hereTally)].
	^sons! !


!MessageTally methodsFor: 'tallying'!
bumpBy: count

	tally _ tally + count! !

!MessageTally methodsFor: 'tallying'!
tally: context by: count
	"Explicitly tally the specified context and its stack."
	| root |
	context method == method ifTrue: [^self bumpBy: count].
	(root _ context home sender) == nil
		ifTrue: [^ (self bumpBy: count) tallyPath: context by: count].
	^ (self tally: root by: count) tallyPath: context by: count! !

!MessageTally methodsFor: 'tallying'!
tallyPath: context by: count
	| aMethod path |
	aMethod _ context method.
	receivers do: 
		[:aMessageTally | 
		aMessageTally method == aMethod ifTrue: [path _ aMessageTally]].
	path == nil ifTrue: 
		[path _ MessageTally new class: context receiver class method: aMethod.
		receivers _ receivers copyWith: path].
	^ path bumpBy: count! !


!MessageTally methodsFor: 'collecting leaves'!
bump: hitCount
	tally _ tally + hitCount! !

!MessageTally methodsFor: 'collecting leaves'!
bump: hitCount fromSender: senderTally
	"Add this hitCount to the total, and include a reference to the
	sender responsible for the increment"
	self bump: hitCount.
	senders == nil ifTrue: [senders _ OrderedCollection new].
	senderTally == nil
		ifFalse: [senders add: (senderTally copyWithTally: hitCount)]! !

!MessageTally methodsFor: 'collecting leaves'!
into: leafDict fromSender: senderTally
	| leafNode |
	leafNode _ leafDict at: method
		ifAbsent: [leafDict at: method
			put: (MessageTally new class: class method: method)].
	leafNode bump: tally fromSender: senderTally! !

!MessageTally methodsFor: 'collecting leaves'!
leavesInto: leafDict fromSender: senderTally
	| rcvrs |
	rcvrs _ self sonsOver: 0.
	rcvrs size = 0
		ifTrue: [self into: leafDict fromSender: senderTally]
		ifFalse: [rcvrs do:
				[:node |
				node isPrimitives
					ifTrue: [node leavesInto: leafDict fromSender: senderTally]
					ifFalse: [node leavesInto: leafDict fromSender: self]]]! !


!MessageTally methodsFor: 'reporting'!
report: strm 
	"Print a report, with cutoff percentage of each element of the tree 
	(leaves, roots, tree)=2, on the stream, strm."

	self report: strm cutoff: 2! !

!MessageTally methodsFor: 'reporting' stamp: 'stp 05/07/1999 14:38'!
report: strm cutoff: threshold 
	tally = 0
		ifTrue: [strm nextPutAll: ' - no tallies obtained']
		ifFalse: 
			[strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr.
			self fullPrintOn: strm tallyExact: false orThreshold: threshold]! !

!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 12:06'!
tally
	"Answer the receiver's number of tally."

	^tally! !

!MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 11:47'!
time
	"Answer the receiver's run time."

	^time! !


!MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:49'!
fullPrintOn: aStream tallyExact: isExact orThreshold: perCent
	| threshold |  
	isExact ifFalse: [threshold _ (perCent asFloat / 100 * tally) rounded].
	aStream nextPutAll: '**Tree**'; cr.
	self treePrintOn: aStream
		tabs: OrderedCollection new
		thisTab: ''
		total: tally
		totalTime: time
		tallyExact: isExact
		orThreshold: threshold.
	aStream nextPut: Character newPage; cr.
	aStream nextPutAll: '**Leaves**'; cr.
	self leavesPrintOn: aStream
		tallyExact: isExact
		orThreshold: threshold! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'!
leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold
	| dict |
	dict _ IdentityDictionary new: 100.
	self leavesInto: dict fromSender: nil.
	isExact ifTrue: 
		[dict asSortedCollection
			do: [:node |
				node printOn: aStream total: tally totalTime: nil tallyExact: isExact.
				node printSenderCountsOn: aStream]]
		ifFalse:
		[(dict asOrderedCollection
				select: [:node | node tally > threshold])
			asSortedCollection
			do: [:node |
				node printOn: aStream total: tally totalTime: time tallyExact: isExact]]! !

!MessageTally methodsFor: 'printing' stamp: 'ls 10/10/1999 11:56'!
printOn: aStream
	| aSelector className aClass |
	aSelector _ class selectorAtMethod: method setClass: [:c | aClass _ c].
	className _ aClass name contractTo: 30.
	aStream nextPutAll: className; nextPutAll: ' >> ';
			nextPutAll: (aSelector contractTo: 60-className size)! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:56'!
printOn: aStream total: total totalTime: totalTime tallyExact: isExact
	| aSelector className myTally aClass percentage |
	isExact
		ifTrue:
			[myTally _ tally.
			receivers == nil
				ifFalse: [receivers do: [:r | myTally _ myTally - r tally]].
			aStream print: myTally; space]
		ifFalse:
			[percentage _ tally asFloat / total * 100.0 roundTo: 0.1.
			aStream
				print: percentage;
				nextPutAll: '% {';
				print: (percentage * totalTime / 100) rounded;
				nextPutAll: 'ms} '].
	receivers == nil
		ifTrue: [aStream nextPutAll: 'primitives'; cr]
		ifFalse: 
			[aSelector _ class selectorAtMethod: method setClass: [:c | aClass _
c].
			className _ aClass name contractTo: 30.
			aStream nextPutAll: class name;
				nextPutAll: (aClass = class ifTrue: ['>>']
								ifFalse: ['(' , aClass name , ')>>']);
				nextPutAll: (aSelector contractTo: 60-className size); cr]! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'!
printSenderCountsOn: aStream
	| mergedSenders mergedNode |
	mergedSenders _ IdentityDictionary new.
	senders do:
		[:node |
		mergedNode _ mergedSenders at: node method ifAbsent: [nil].
		mergedNode == nil
			ifTrue: [mergedSenders at: node method put: node]
			ifFalse: [mergedNode bump: node tally]].
	mergedSenders asSortedCollection do:
		[:node | 
		10 to: node tally printString size by: -1 do: [:i | aStream space].
		node printOn: aStream total: tally totalTime: nil tallyExact: true]! !

!MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:51'!
treePrintOn: aStream tabs: tabs thisTab: myTab
	total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold
	| sons sonTab |
	tabs do: [:tab | aStream nextPutAll: tab].
	tabs size > 0 ifTrue: [self printOn: aStream total: total totalTime: totalTime tallyExact: isExact].
	sons _ isExact
		ifTrue: [receivers]
		ifFalse: [self sonsOver: threshold].
	sons isEmpty ifFalse:
		[tabs addLast: myTab.
		sons _ sons asSortedCollection.
		(1 to: sons size) do: 
			[:i |
			sonTab _ i < sons size ifTrue: ['  |'] ifFalse: ['  '].
			(sons at: i) treePrintOn: aStream
				tabs: (tabs size < 18
					ifTrue: [tabs]
					ifFalse: [(tabs select: [:x | x = '[']) copyWith: '['])
				thisTab: sonTab total: total totalTime: totalTime
				tallyExact: isExact orThreshold: threshold].
		tabs removeLast]! !


!MessageTally methodsFor: 'private'!
class: aClass method: aMethod

	class _ aClass.
	method _ aMethod.
	tally _ 0.
	receivers _ Array new: 0! !

!MessageTally methodsFor: 'private'!
copyWithTally: hitCount
	^ (MessageTally new class: class method: method) bump: hitCount! !

!MessageTally methodsFor: 'private'!
method

	^method! !

!MessageTally methodsFor: 'private'!
primitives: anInteger

	tally _ anInteger.
	receivers _ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MessageTally class
	instanceVariableNames: ''!

!MessageTally class methodsFor: 'spying' stamp: 'di 11/4/2000 12:11'!
spyOn: aBlock    "MessageTally spyOn: [100 timesRepeat: [3.14159 printString]]"
	| node result |
	node _ self new.
	result _ node spyEvery: 16 on: aBlock.
	(StringHolder new contents: (String streamContents: [:s | node report: s; close]))
		openLabel: 'Spy Results'.
	^ result! !

!MessageTally class methodsFor: 'spying'!
spyOn: aBlock toFileNamed: fileName 
	"Spy on the evaluation of aBlock. Write the data collected on a file
	named fileName."

	| file value node |
	node _ self new.
	value _ node spyEvery: 16 on: aBlock.
	file _ FileStream newFileNamed: fileName.
	node report: file; close.
	file close.
	^value! !

!MessageTally class methodsFor: 'spying' stamp: 'nk 10/27/2000 11:20'!
spyOnProcess: aProcess forMilliseconds: msecDuration 
	"| p |  
	p _ [100000 timesRepeat: [3.14159 printString]] fork.  
	(Delay forMilliseconds: 100) wait.  
	MessageTally spyOnProcess: p forMilliseconds: 1000"
	| node |
	node _ self new.
	node
		spyEvery: 10
		onProcess: aProcess
		forMilliseconds: msecDuration.
	(StringHolder new
		contents: (String
				streamContents: [:s | node report: s;
						 close]))
		openLabel: 'Spy Results'! !

!MessageTally class methodsFor: 'spying' stamp: 'nk 10/27/2000 11:19'!
spyOnProcess: aProcess forMilliseconds: msecDuration toFileNamed: fileName 
	"Spy on the evaluation of aProcess. Write the data collected on a file  
	named fileName. Will overwrite fileName"
	| file node |
	node _ self new.
	node
		spyEvery: 10
		onProcess: aProcess
		forMilliseconds: msecDuration.
	file _ FileStream fileNamed: fileName.
	node report: file;
		 close.
	file close! !

!MessageTally class methodsFor: 'spying'!
tallySends: aBlock   "MessageTally tallySends: [3.14159 printString]"
	^ self tallySendsTo: nil inBlock: aBlock showTree: true! !

!MessageTally class methodsFor: 'spying' stamp: 'tk 5/4/1998 17:01'!
tallySendsTo: receiver inBlock: aBlock showTree: treeOption
	"MessageTally tallySends: [3.14159 printString]"
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. If receiver is not nil, then only sends
	to that receiver are tallied.
	Results are presented as leaves, sorted by frequency,
	preceded, optionally, by the whole tree."
	| prev tallies startTime totalTime |
	startTime _ Time millisecondClockValue.
	tallies _ MessageTally new class: aBlock receiver class
							method: aBlock method.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: 
				["call or return"
				prev sender == nil ifFalse: 
					["call only"
					(receiver == nil or: [current receiver == receiver])
						ifTrue: [tallies tally: current by: 1]].
				prev _ current]].

	totalTime _ Time millisecondClockValue - startTime // 1000.0 roundTo: 0.01.
	(StringHolder new contents:
		(String streamContents:
			[:s |
			s nextPutAll: 'This simulation took ' , totalTime printString
							, ' seconds.'; cr.
			treeOption
				ifTrue: [tallies fullPrintOn: s tallyExact: true orThreshold: 0]
				ifFalse: [tallies leavesPrintOn: s tallyExact: true orThreshold: 0].
			tallies close]))
		openLabel: 'Spy Results'! !

!MessageTally class methodsFor: 'spying'!
time: aBlock

	^ Time millisecondsToRun: aBlock! !
ClassDescription subclass: #Metaclass
	instanceVariableNames: 'thisClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
!Metaclass commentStamp: '<historical>' prior: 0!
My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance.
	
[Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus,
	Integer superclass == Number, and
	Integer class superclass == Number class.
However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus,
	Object superclass == nil, and
	Object class superclass == Class.

[Subtle detail] A class is know by name to an environment.  Typically this is the SystemDictionary named Smalltalk.  If we ever make lightweight classes that are not in Smalltalk, they must be in some environment.  Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.!


!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'!
adoptInstance: oldInstance from: oldMetaClass 
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary."
	thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance'].
	oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass'].
	oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument'].
	^thisClass _ self 
		newInstanceFrom: oldInstance 
		variable: self isVariable 
		size: self instSize 
		map: (self instVarMappingFrom: oldMetaClass)! !

!Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 18:56'!
instanceVariableNames: instVarString 
	"Declare additional named variables for my instance."
	^(ClassBuilder new)
		class: self
		instanceVariableNames: instVarString! !


!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 08:14'!
allInstances
	thisClass class == self ifTrue:[^Array with: thisClass].
	^super allInstances! !

!Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'!
environment
	^thisClass environment! !

!Metaclass methodsFor: 'accessing'!
isMeta
	^ true! !

!Metaclass methodsFor: 'accessing' stamp: 'tk 6/17/1998 09:48'!
isSystemDefined
	"Answer false if I am a UniClass (an instance-specific lightweight class)"

	^ true! !

!Metaclass methodsFor: 'accessing'!
name
	"Answer a String that is the name of the receiver, either 'Metaclass' or 
	the name of the receiver's class followed by ' class'."

	thisClass == nil
		ifTrue: [^'a Metaclass']
		ifFalse: [^thisClass name , ' class']! !

!Metaclass methodsFor: 'accessing'!
soleInstance
	"The receiver has only one instance. Answer it."

	^thisClass! !

!Metaclass methodsFor: 'accessing'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^thisClass! !


!Metaclass methodsFor: 'copying'!
copy
	"Make a copy of the receiver without a list of subclasses. Share the 
	reference to the sole instance."

	| copy t |
	t _ thisClass.
	thisClass _ nil.
	copy _ super copy.
	thisClass _ t.
	^copy! !

!Metaclass methodsFor: 'copying' stamp: 'tk 8/19/1998 16:16'!
veryDeepCopyWith: deepCopier
	"Return self.  Must be created, not copied.  Do not record me."! !


!Metaclass methodsFor: 'instance creation' stamp: 'ar 7/11/1999 10:07'!
new
	"The receiver can only have one instance. Create it or complain that
	one already exists."

	thisClass class ~~ self
		ifTrue: [^thisClass _ super new]
		ifFalse: [self error: 'A Metaclass should only have one instance!!']! !


!Metaclass methodsFor: 'instance variables'!
addInstVarName: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	| fullString |
	fullString _ aString.
	self instVarNames do: [:aString2 | fullString _ aString2 , ' ' , fullString].
	self instanceVariableNames: fullString! !

!Metaclass methodsFor: 'instance variables'!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newArray newString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newArray _ self instVarNames copyWithout: aString.
	newString _ ''.
	newArray do: [:aString2 | newString _ aString2 , ' ' , newString].
	self instanceVariableNames: newString! !


!Metaclass methodsFor: 'pool variables'!
classPool
	"Answer the dictionary of class variables."

	^thisClass classPool! !


!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!
addSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'!
removeSubclass: aClass
	"Do nothing."! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'!
subclasses
	"Answer the receiver's subclasses."
	thisClass == nil ifTrue:[^#()].
	^thisClass subclasses 
		select:[:aSubclass| aSubclass isMeta not] 
		thenCollect:[:aSubclass| aSubclass class]

	"Metaclass allInstancesDo:
		[:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/9/1999 14:11'!
subclassesDo: aBlock
	"Evaluate aBlock for each of the receiver's immediate subclasses."
	thisClass subclassesDo:[:aSubclass|
		"The following test is for Class class which has to exclude
		the Metaclasses being subclasses of Class."
		aSubclass isMeta ifFalse:[aBlock value: aSubclass class]].! !

!Metaclass methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:37'!
subclassesDoGently: aBlock
	"Evaluate aBlock for each of the receiver's immediate subclasses."
	thisClass subclassesDo: [:aSubclass |
		"The following test is for Class class which has to exclude
			the Metaclasses being subclasses of Class."
		aSubclass isInMemory ifTrue: [
			aSubclass isMeta ifFalse: [aBlock value: aSubclass class]]].! !


!Metaclass methodsFor: 'compiling'!
acceptsLoggingOfCompilation
	"Answer whether the receiver's method submisions and class defintions should be logged to the changes file and to the current change set.  The metaclass follows the rule of the class itself.  6/18/96 sw"

	^ thisClass acceptsLoggingOfCompilation! !

!Metaclass methodsFor: 'compiling'!
possibleVariablesFor: misspelled continuedFrom: oldResults

	^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults
! !

!Metaclass methodsFor: 'compiling'!
scopeHas: name ifTrue: assocBlock  

	^thisClass scopeHas: name ifTrue: assocBlock! !

!Metaclass methodsFor: 'compiling'!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself.  7/12/96 sw"

	^ thisClass wantsChangeSetLogging! !

!Metaclass methodsFor: 'compiling' stamp: 'sw 7/31/2000 14:29'!
wantsRecompilationProgressReported
	"The metaclass follows the rule of the class itself."

	^ thisClass wantsRecompilationProgressReported! !


!Metaclass methodsFor: 'fileIn/Out' stamp: 'sma 6/25/2000 16:30'!
definitionST80
	"Refer to the comment in ClassDescription|definition."

	^ String streamContents: 
		[:strm |
		strm print: self;
			crtab;
			nextPutAll: 'instanceVariableNames: ';
			store: self instanceVariablesString]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 6/7/2000 22:50'!
definitionST80: isST80
	"Refer to the comment in ClassDescription|definition."

	isST80 ifTrue: [^ self definitionST80].

	^ String streamContents: 
		[:strm |
		strm print: self;
			nextPutKeyword: ' instanceVariableNames: '
				withArg: self instanceVariablesString]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'!
fileOutInitializerOn: aStream
	(self methodDict includesKey: #initialize) ifTrue: 
		[aStream cr.
		aStream nextChunkPut: thisClass name , ' initialize'].! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
	^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool
	super fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	(aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: 
		[aFileStream cr.
		aFileStream cr.
		aFileStream nextChunkPut: thisClass name , ' initialize'.
		aFileStream cr]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'!
nonTrivial 
	"Answer whether the receiver has any methods or instance variables."

	^ self instVarNames size > 0 or: [self methodDict size > 0]! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:44'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

	(refStrm insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ self].	"do trace me"
	dp _ DiskProxy global: self theNonMetaClass name selector: #class
			args: (Array new).
	refStrm replace: self with: dp.
	^ dp
! !

!Metaclass methodsFor: 'fileIn/Out' stamp: 'tk 9/27/2000 11:39'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	(aDataStream insideASegment and: [self isSystemDefined not]) ifTrue: [
		^ super storeDataOn: aDataStream].	"do trace me"
	self error: 'use a DiskProxy to store a Class'! !


!Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'!
canZapMethodDictionary
	"Return true if it is safe to zap the method dictionary on #obsolete"
	thisClass == nil
		ifTrue:[^true]
		ifFalse:[^thisClass canZapMethodDictionary]! !

!Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'!
isObsolete
	"Return true if the receiver is obsolete"
	^thisClass == nil "Either no thisClass"
		or:[thisClass class ~~ self "or I am not the class of thisClass"
			or:[thisClass isObsolete]] "or my instance is obsolete"! !


!Metaclass methodsFor: 'enumerating' stamp: 'ar 7/15/1999 16:43'!
allInstancesDo: aBlock
	"There should be only one"
	thisClass class == self ifTrue:[^aBlock value: thisClass].
	^super allInstancesDo: aBlock! !

!Metaclass methodsFor: 'enumerating' stamp: 'tk 11/12/1999 11:45'!
allInstancesEverywhereDo: aBlock
	"There should be only one"
	thisClass class == self ifTrue:[^ aBlock value: thisClass].
	^ super allInstancesEverywhereDo: aBlock! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Metaclass class
	instanceVariableNames: ''!


!Metaclass class methodsFor: 'anti-corruption' stamp: 'di 11/24/1999 13:30'!
isScarySelector: newbieSelector

	"Return true if newbieSelector is already a part of Metaclass protocol."
	(Metaclass includesSelector: newbieSelector) ifTrue: [^ true].
	(ClassDescription includesSelector: newbieSelector) ifTrue: [^ true].
	(Behavior includesSelector: newbieSelector) ifTrue: [^ true].
	^ false
! !
Object subclass: #MethodChangeRecord
	instanceVariableNames: 'changeType currentMethod infoFromRemoval '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!
!MethodChangeRecord commentStamp: '<historical>' prior: 0!
MethodChangeRecords are used to record method changes.  Here is a simple summary of the relationship between the changeType symbol and the recording of prior state

			|	prior == nil			|	prior not nil	
	---------	|----------------------------	|--------------------
	add		|	add					|	change
	---------	|----------------------------	|--------------------
	remove	|	addedThenRemoved	|	remove

Structure:
changeType			symbol -- as summarized above
currentMethod	method
				This is the current version of the method.
				It can be used to assert this change upon entry to a layer. 
infoFromRemoval -- an array of size 2.
				The first element is the source index of the last version of the method.
				The second element is the category in which it was defined, so it
				can be put back there if re-accepted from a version browser.

Note that the above states each have an associated revoke action:
	add --> remove
	change --> change back
	remove --> add back
	addedThenRemoved --> no change
However all of these are accomplished trivially by restoring the original method dictionary.!


!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
changeType

	^ changeType! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:34'!
currentMethod

	^ currentMethod! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
methodInfoFromRemoval
	"Return an array with the source index of the last version of the method,
	and the category in which it was defined (so it can be put back there if
	re-accepted from a version browser)."

	(changeType == #remove or: [changeType == #addedThenRemoved])
		ifTrue: [^ infoFromRemoval]
		ifFalse: [^ nil]! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/4/2000 11:05'!
noteChangeType: newChangeType

	(changeType == #addedThenRemoved and: [newChangeType == #change])
		ifTrue: [changeType _ #add]
		ifFalse: [changeType _ newChangeType]! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 11:05'!
noteMethodInfoFromRemoval: info
	"Store an array with the source index of the last version of the method,
	and the category in which it was defined (so it can be put back there if
	re-accepted from a version browser)."

	infoFromRemoval _ info! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:32'!
noteNewMethod: newMethod

	currentMethod _ newMethod! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'!
printOn: strm

	super printOn: strm.
	strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! !

!MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 10:47'!
priorMethod: ignored

	"We do not save original versions of changed methods because we only
	revoke changes at the level of entire classes, and that is done by
	restoration of the entire methodDictionary."! !
ContextPart variableSubclass: #MethodContext
	instanceVariableNames: 'method receiverMap receiver '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodContext commentStamp: '<historical>' prior: 0!
My instances hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context.
	
MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed.

MethodContexts must only be created using the method newForMethod:.  Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method.  Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector.  Any store into stackp other than by the primitive method stackp: is potentially fatal.!


!MethodContext methodsFor: 'initialize-release' stamp: 'di 1/11/1999 10:24'!
restart
	"Reinitialize the receiver so that it is in the state it was at its creation."

	pc _ method initialPC.
	self stackp: method numTemps! !

!MethodContext methodsFor: 'initialize-release' stamp: 'ikp 12/23/1999 15:56'!
restartWith: aCompiledMethod 
	"Reinitialize the receiver as though it had been for a different method. 
	Used by a Debugger when one of the methods to which it refers is 
	recompiled."

	method _ aCompiledMethod.
	receiverMap _ nil.
	^self restart! !


!MethodContext methodsFor: 'accessing' stamp: 'RAA 1/5/2001 09:45'!
hasInstVarRef
	"Answer whether the receiver references an instance variable."

	| scanner end printer |

	scanner _ InstructionStream on: method.
	printer _ InstVarRefLocator new.
	end _ self method endPC.

	[scanner pc <= end] whileTrue: [
		(printer interpretNextInstructionUsing: scanner) ifTrue: [^true].
	].
	^false! !

!MethodContext methodsFor: 'accessing'!
home 
	"Refer to the comment in ContextPart|home."

	^self! !

!MethodContext methodsFor: 'accessing'!
method

	^method! !

!MethodContext methodsFor: 'accessing'!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^receiver! !

!MethodContext methodsFor: 'accessing'!
removeSelf
	"Nil the receiver pointer and answer its former value."

	| tempSelf |
	tempSelf _ receiver.
	receiver _ nil.
	^tempSelf! !

!MethodContext methodsFor: 'accessing'!
tempAt: index 
	"Refer to the comment in ContextPart|tempAt:."

	^self at: index! !

!MethodContext methodsFor: 'accessing'!
tempAt: index put: value 
	"Refer to the comment in ContextPart|tempAt:put:."

	^self at: index put: value! !


!MethodContext methodsFor: 'private' stamp: 'di 1/14/1999 22:30'!
instVarAt: index put: value
	index = 3 ifTrue: [self stackp: value. ^ value].
	^ super instVarAt: index put: value! !

!MethodContext methodsFor: 'private' stamp: 'ikp 12/23/1999 15:56'!
setSender: s receiver: r method: m arguments: args 
	"Create the receiver's initial state."

	sender _ s.
	receiver _ r.
	method _ m.
	receiverMap _ nil.
	pc _ method initialPC.
	self stackp: method numTemps.
	1 to: args size do: [:i | self at: i put: (args at: i)]! !


!MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 6/7/1999 20:46'!
cannotReturn: result

	Debugger
		openContext: thisContext
		label: 'computation has been terminated'
		contents: thisContext printString! !

!MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 3/23/1999 13:00'!
receiver: r

	receiver := r! !


!MethodContext methodsFor: 'controlling' stamp: 'ikp 10/2/2000 15:26'!
answer: anObject
	"Modify my code, from the current program counter value, to answer anObject."

	self push: anObject.
	(method at: pc) = 124 ifFalse: [
		method _ (
			(method clone)
				at: pc + 1 put: 124;
				yourself)]! !


!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/19/2000 23:55'!
cachedStackTop
	"WARNING - this method depends on a very dirty trick, viz. snitching information off the variable stack of a particular CompiledMethod.  So if you add/remove a temp in BlockContext>>valueUninterruptably, this method will fail, probably with some horrible consequences I'd rather not think through just now ... assumption is that the variable declaration in that method looks like:
		| sendingContext result homeSender |"

	^self tempAt: 3! !

!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/20/2000 00:05'!
cachesStack

	^self selector == #valueUninterruptably
		and: [self receiver class == BlockContext]! !

!MethodContext methodsFor: 'private-debugger' stamp: 'tfei 3/20/2000 00:24'!
hideFromDebugger

	| sndr sndrHome |
	^self cachesStack
		or: [(sndr := self sender) ~~ nil
			and: [(sndrHome := sndr home) ~~ nil
				and: [sndrHome cachesStack]]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MethodContext class
	instanceVariableNames: ''!

!MethodContext class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:06'!
sender: s receiver: r method: m arguments: args 
	"Answer an instance of me with attributes set to the arguments."

	^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! !
Dictionary variableSubclass: #MethodDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodDictionary commentStamp: '<historical>' prior: 0!
I am just like a normal Dictionary, except that I am implemented differently.  Each Class has an instances of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves.

In a normal Dictionary, the instance variable 'array' holds an array of Associations.  Since there are thousands of methods in the system, these Associations waste space.  

Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance.  The variable 'array' holds the values, which are CompiledMethods.!


!MethodDictionary methodsFor: 'accessing'!
add: anAssociation
	^ self at: anAssociation key put: anAssociation value! !

!MethodDictionary methodsFor: 'accessing'!
at: key ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
	^ array at: index! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 10/12/2000 17:25'!
at: key put: value
	"Set the value at key to be value."
	| index |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil
		ifTrue: 
			[tally _ tally + 1.
			self basicAt: index put: key]
		ifFalse:
			[(array at: index) flushCache].
	array at: index put: value.
	self fullCheck.
	^ value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'tk 6/30/2000 00:14'!
includesKey: aSymbol
	"This override assumes that pointsTo is a fast primitive"

	aSymbol ifNil: [^ false].
	^ super pointsTo: aSymbol! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:17'!
keyAtIdentityValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."
	| theKey |
	1 to: self basicSize do:
		[:index |
		value == (array at: index)
			ifTrue:
				[(theKey _ self basicAt: index) == nil
					ifFalse: [^ theKey]]].
	^ exceptionBlock value! !

!MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:00'!
keyAtValue: value ifAbsent: exceptionBlock
	"Answer the key whose value equals the argument, value. If there is
	none, answer the result of evaluating exceptionBlock."
	| theKey |
	1 to: self basicSize do:
		[:index |
		value = (array at: index)
			ifTrue:
				[(theKey _ self basicAt: index) == nil
					ifFalse: [^ theKey]]].
	^ exceptionBlock value! !


!MethodDictionary methodsFor: 'removing'!
removeKey: key ifAbsent: errorBlock 
	"The interpreter might be using this MethodDict while
	this method is running!!  Therefore we perform the removal
	in a copy, and then atomically become that copy"
	| copy |
	copy _ self copy.
	copy removeDangerouslyKey: key ifAbsent: [^ errorBlock value].
	self become: copy! !


!MethodDictionary methodsFor: 'enumeration'!
associationsDo: aBlock 
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil ifFalse:
			[aBlock value: (Association key: key
									value: (array at: i))]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'to 1/14/98 10:13'!
do: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (self basicAt: i) == nil ifFalse:
			[aBlock value: (array at: i)]]
! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 08:05'!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys and values passed to the block"
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil ifFalse:
			[aBlock value: key value: (array at: i)]
		]! !

!MethodDictionary methodsFor: 'enumeration'!
keysDo: aBlock 
	| key |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (key _ self basicAt: i) == nil
			ifFalse: [aBlock value: key]]! !

!MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 07:29'!
valuesDo: aBlock 
	| value |
	tally = 0 ifTrue: [^ self].
	1 to: self basicSize do:
		[:i | (value _ array at: i) == nil
			ifFalse: [aBlock value: value]]! !


!MethodDictionary methodsFor: 'private' stamp: 'tk 8/21/97 16:26'!
copy
	^ self shallowCopy withArray: array shallowCopy! !

!MethodDictionary methodsFor: 'private' stamp: 'di 11/4/97 20:11'!
grow 
	| newSelf key |
	newSelf _ self species new: self basicSize.  "This will double the size"
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private'!
keyAt: index

	^ self basicAt: index! !

!MethodDictionary methodsFor: 'private'!
methodArray
	^ array! !

!MethodDictionary methodsFor: 'private'!
rehash 
	| newSelf key |
	newSelf _ self species new: self size.
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	self become: newSelf! !

!MethodDictionary methodsFor: 'private' stamp: 'RAA 12/17/2000 11:11'!
rehashWithoutBecome
	| newSelf key |
	newSelf _ self species new: self size.
	1 to: self basicSize do:
		[:i | key _ self basicAt: i.
		key == nil ifFalse: [newSelf at: key put: (array at: i)]].
	^newSelf! !

!MethodDictionary methodsFor: 'private'!
removeDangerouslyKey: key ifAbsent: aBlock
	"This is not really dangerous.  But if normal removal
	were done WHILE a MethodDict were being used, the
	system might crash.  So instead we make a copy, then do
	this operation (which is NOT dangerous in a copy that is
	not being used), and then use the copy after the removal."

	| index element |
	index _ self findElementOrNil: key.
	(self basicAt: index) == nil ifTrue: [ ^ aBlock value ].
	element _ array at: index.
	array at: index put: nil.
	self basicAt: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ element! !

!MethodDictionary methodsFor: 'private'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject identityHash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ self basicAt: index) == nil or: [element == anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!MethodDictionary methodsFor: 'private'!
swap: oneIndex with: otherIndex
	| element |
	element _ self basicAt: oneIndex.
	self basicAt: oneIndex put: (self basicAt: otherIndex).
	self basicAt: otherIndex put: element.
	super swap: oneIndex with: otherIndex.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MethodDictionary class
	instanceVariableNames: ''!

!MethodDictionary class methodsFor: 'instance creation' stamp: 'di 11/4/97 20:11'!
new: nElements
	"Create a Dictionary large enough to hold nElements without growing.
	Note that the basic size must be a power of 2.
	It is VITAL (see grow) that size gets doubled if nElements is a power of 2"
	| size |
	size _ 1 bitShift: nElements highBit.
	^ (self basicNew: size) init: size! !
Object subclass: #MethodFinder
	instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists '
	classVariableNames: 'AddAndRemove Approved Blocks Dangerous '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!MethodFinder commentStamp: '<historical>' prior: 0!
Find a method in the system from a set of examples.  Done by brute force, trying every possible selector.  Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ).
Submit an array of the form ((data1 data2) answer  (data1 data2) answer).

	MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10).

answer:  'data1 + data2'

More generally, use the brace notation to construct live examples.

The program tries data1 as the receiver, and
	tries all other permutations of the data for the receiver and args, and
	tries leaving out one argument, and
	uses all selectors data understands, and
	uses all selectors in all od data's superclasses.

Floating point values must be precise to 0.01 percent, or (X * 0.0001).

If you get an error, you have probably discovered a selector that needs to be removed from the Approved list.  See MethodFinder.initialize.  Please email the Squeak Team.

Only considers 0, 1, 2, and 3 argument messages.  The argument data may have 1 to 5 entries, but only a max of 4 used at a time.  For now, we only test messages that use given number of args or one fewer.  For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns.

Three sets of selectors:  Approved, AddAndRemove, and Blocks selectors.  When testing a selector in AddAndRemove, deepCopy the receiver.  We do not handle selectors that modify an argument (printOn: etc.).  Blocks is a set of (selector argNumber) where that argument must be a block.

For perform, the selector is tested.  It must be in the Approved list.

do: is not on the Approved list.  It does not produce a result that can be tested.  Type 'do' into the upper pane of the Selector Finder to find messages list that.

[Later, allow the user to supply a block that tests the answer, not just the literal answer.]
	MethodFinder methodFor: { { true. [3]. [4]}. 3}. 
Later allow this to work without the blocks around 3 and 4.!


!MethodFinder methodsFor: 'initialize' stamp: 'tk 7/1/2000 23:11'!
cleanInputs: dataAndAnswerString
	"Find an remove common mistakes.  Complain when ill formed."

| fixed ddd rs places |
ddd _ dataAndAnswerString.
fixed _ false.

rs _ ReadStream on: ddd, ' '.
places _ OrderedCollection new.
[rs upToAll: '#true'.  rs atEnd] whileFalse: [places addFirst: rs position-4]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#false'.  rs atEnd] whileFalse: [places addFirst: rs position-5]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

fixed ifTrue: [self inform: '#(true false) are Symbols, not Booleans.  
Next time use { true. false }.'].

fixed _ false.
rs _ ReadStream on: ddd.
places _ OrderedCollection new.
[rs upToAll: '#nil'.  rs atEnd] whileFalse: [places addFirst: rs position-3]. 
places do: [:pos | ddd _ ddd copyReplaceFrom: pos to: pos with: ''.
	fixed _ true]. 	"remove #"

fixed ifTrue: [self inform: '#nil is a Symbol, not the authentic UndefinedObject.  
Next time use nil instead of #nil'].

^ ddd
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 12/29/2000 13:38'!
copy: mthFinder addArg: aConstant
	| more |
	"Copy inputs and answers, add an additional data argument to the inputs.  The same constant for every example".

	more _ Array with: aConstant.
	data _ mthFinder data collect: [:argList | argList, more].
	answers _ mthFinder answers.
	self load: nil.
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 12/27/2000 09:48'!
initialize
	"The methods we are allowed to use.  (MethodFinder new initialize) "

	Approved _ Set new.
	AddAndRemove _ Set new.
	Blocks _ Set new.
	"These modify an argument: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom:"

"Object"  
	#("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom:
"accessing" at: basicAt: basicSize bindWithTemp: in: size yourself 
"testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps 
"comparing" = == closeTo: hash hashMappedBy: identityHash identityHashMappedBy: identityHashPrintString ~= ~~ 
"copying" clone copy shallowCopy 
"dependents access" canDiscardEdits dependents hasUnacceptedEdits 
"updating" changed changed: okToChange update: windowIsClosing 
"printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation 
"class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass 
"error handling" 
"user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel: 
"system primitives" asOop instVarAt: instVarNamed: 
"private" 
"associating" -> 
"converting" as: asOrderedCollection asString 
"casing" caseOf: caseOf:otherwise: 
"binding" bindingOf: 
"macpal" contentsChanged currentEvent currentHand currentWorld flash ifKindOf:thenDo: instanceVariableValues scriptPerformer 
"flagging" flag: 
"translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel].
	#(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:"
"message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: 
) do: [:sel | AddAndRemove add: sel].

"Boolean, True, False, UndefinedObject"  
	#("logical operations" & eqv: not xor: |
"controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or:
"copying" 
"testing" isEmptyOrNil) do: [:sel | Approved add: sel].

"Behavior" 
	#("initialize-release"
"accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass
"testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords
"copying"
"printing" defaultNameStemForInstances printHierarchy
"creating class hierarchy"
"creating method dictionary"
"instance creation" basicNew basicNew: new new:
"accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses
"accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent:
"accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames
"testing class hierarchy" inheritsFrom: kindOfSubclass
"testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: scopeHas:ifTrue: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto:
"enumerating"
"user interface"
"private" indexIfCompact) do: [:sel | Approved add: sel].

"ClassDescription"
	#("initialize-release" 
"accessing" classVersion isMeta name theNonMetaClass
"copying" 
"printing" classVariablesString instanceVariablesString sharedPoolsString
"instance variables" checkForInstVarsOK: 
"method dictionary" 
"organization" category organization whichCategoryIncludesSelector:
"compiling" acceptsLoggingOfCompilation wantsChangeSetLogging
"fileIn/Out" definition
"private" ) do: [:sel | Approved add: sel].

"Class"
	#("initialize-release" 
"accessing" classPool
"testing"
"copying" 
"class name" 
"instance variables" 
"class variables" classVarAt: classVariableAssociationAt:
"pool variables" 
"compiling" 
"subclass creation" 
"fileIn/Out" ) do: [:sel | Approved add: sel]. 

"Metaclass"
	#("initialize-release" 
"accessing" isSystemDefined soleInstance
"copying" "instance creation" "instance variables"  "pool variables" "class hierarchy"  "compiling"
"fileIn/Out"  nonTrivial ) do: [:sel | Approved add: sel].

"Context, BlockContext"
	#(receiver client method receiver tempAt: 
"debugger access" mclass pc selector sender shortStack sourceCode tempNames tempsAndValues
"controlling"  "printing" "system simulation" 
"initialize-release" 
"accessing" hasMethodReturn home numArgs
"evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
"controlling"  "scheduling"  "instruction decoding"  "printing" "private"  "system simulation" ) do: [:sel | Approved add: sel].
	#(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].

"Message"
	#("inclass, instance creation" selector: selector:argument: selector:arguments:
"accessing" argument argument: arguments sends:
"printing" "sending" ) do: [:sel | Approved add: sel].
	#("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].

"Magnitude"
	#("comparing" < <= > >= between:and:
"testing" max: min: min:max: ) do: [:sel | Approved add: sel].

"Date, Time"
	#("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
	"in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
"accessing" day leap monthIndex monthName weekday year
"arithmetic" addDays: subtractDate: subtractDays:
"comparing"
"inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
"converting" asSeconds
"printing" mmddyy mmddyyyy printFormat: printOn:format:
"private" firstDayOfMonthIndex: weekdayIndex 
	"in class, instance creation" fromSeconds: now 
	"in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
"accessing" hours minutes seconds
"arithmetic" addTime: subtractTime:
"comparing"
"printing" intervalString print24 
"converting") do: [:sel | Approved add: sel].
	#("private" hours: hours:minutes:seconds: day:year: 
		 ) do: [:sel | AddAndRemove add: sel].

"Number"
	#("in class" readFrom:base: 
"arithmetic" * + - / // \\ abs negated quo: reciprocal rem:
"mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan
"truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated
"comparing"
"testing" even isDivisibleBy: isInf isInfinite isNaN isZero negative odd positive sign strictlyPositive
"converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees
"intervals" to: to:by: 
"printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel].

"Integer"
	#("in class" primesUpTo:
"testing" isPowerOfTwo
"arithmetic" alignedTo:
"comparing"
"truncation and round off" atRandom normalize
"enumerating" timesRepeat:
"mathematical functions" degreeCos degreeSin factorial gcd: lcm: take:
"bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask:
"converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit
"printing" asStringWithCommas hex hex8 radix:
"system primitives" lastDigit replaceFrom:to:with:startingAt:
"private" "benchmarks" ) do: [:sel | Approved add: sel].

"SmallInteger, LargeNegativeInteger, LargePositiveInteger"
	#("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" 
"system primitives" digitAt: digitLength 
"private" fromString:radix: ) do: [:sel | Approved add: sel].
	#(digitAt:put: ) do: [:sel | AddAndRemove add: sel].

"Float"
	#("arithmetic"
"mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower:
"comparing" "testing"
"truncation and round off" exponent fractionPart integerPart significand significandAsInteger
"converting" asApproximateFraction asIEEE32BitWord asTrueFraction
"copying") do: [:sel | Approved add: sel].

"Fraction, Random"
	#(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel].
	#(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel].

"Collection"
	#("accessing" anyOne
"testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf:
"enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect:
"converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection:
"printing"
"private" maxSize
"arithmetic"
"math functions" average max median min range sum) do: [:sel | Approved add: sel].
	#("adding" add: addAll: addIfNotPresent:
"removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel].

"SequenceableCollection"
	#("comparing" hasEqualElements:
"accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third
"removing"
"copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy:
"enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval:
"converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed
"private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel].
	#( swap:with:) do: [:sel | AddAndRemove add: sel].

"ArrayedCollection, Bag"
	#("private" defaultElement 
"sorting" isSorted
"accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" 
	) do: [:sel | Approved add: sel].
	#( mergeSortFrom:to:by: sort sort: add: add:withOccurrences:
"private" setDictionary ) do: [:sel | AddAndRemove add: sel].

"Other messages that modify the receiver"
	#(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with:  removeFirst removeLast) do: [:sel | AddAndRemove add: sel].

	self initialize2.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: Set
"

! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 7/4/2000 12:10'!
initialize2
	"The methods we are allowed to use.  (MethodFinder new initialize) "

"Set"
	#("in class" sizeFor:
"testing" "adding" "removing" "enumerating"
"private" array findElementOrNil: 
"accessing" someElement) do: [:sel | Approved add: sel].

"Dictionary, IdentityDictionary, IdentitySet"
	#("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys
"testing" includesKey: ) do: [:sel | Approved add: sel].
	#(removeKey: removeKey:ifAbsent:
) do: [:sel | AddAndRemove add: sel].

"LinkedList, Interval, MappedCollection"
	#("in class"  from:to: from:to:by:
"accessing" contents) do: [:sel | Approved add: sel].
	#(
"adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel].

"OrderedCollection, SortedCollection"
	#("accessing" after: before:
"copying" copyEmpty
"adding"  growSize
"removing" "enumerating" "private" 
"accessing" sortBlock) do: [:sel | Approved add: sel].
	#("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast:
"removing" removeAt: removeFirst removeLast
"accessing" sortBlock:) do: [:sel | AddAndRemove add: sel].

"Character"
	#("in class, instance creation" allCharacters digitValue: new separators
	"accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab
	"constants" alphabet characterTable
"accessing" asciiValue digitValue
"comparing"
"testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish
"copying"
"converting" asIRCLowercase asLowercase asUppercase
	) do: [:sel | Approved add: sel].

"String"
	#("in class, instance creation" crlf fromPacked:
	"primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: 	"internet" valueOfHtmlEntity:
"accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit
"comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt:
"copying" copyReplaceTokens:with: padded:to:with:
"converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks
"displaying" "printing"
"system primitives" compare:with:collated: 
"Celeste" withCRs
"internet" decodeMimeHeader decodeQuotedPrintable replaceHtmlCharRefs unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting
"testing" isAllSeparators lastSpacePosition
"paragraph support" indentationIfBlank:
"arithmetic" ) do: [:sel | Approved add: sel].
	#(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel].

"Symbol"
	#("in class, private" hasInterned:ifTrue:
	"access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping:
"accessing" "comparing" "copying" "converting" "printing" 
"testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel].

"Array"
	#("comparing" "converting" evalStrings 
"printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel].

"Array2D"
	#("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel].
	#(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel].

"ByteArray"
	#("accessing" doubleWordAt: wordAt: 
"platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: 
"converting") do: [:sel | Approved add: sel].
	#(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian:
	) do: [:sel | AddAndRemove add: sel].

"FloatArray"		"Dont know what happens when prims not here"
	false ifTrue: [#("accessing" "arithmetic" *= += -= /=
"comparing"
"primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar:
"primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to:
"converting" "private" "user interface") do: [:sel | Approved add: sel].
	].

"IntegerArray, WordArray"
"RunArray"
	#("in class, instance creation" runs:values: scanFrom:
"accessing" runLengthAt: 
"adding" "copying"
"private" runs values) do: [:sel | Approved add: sel].
	#(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty:
		) do: [:sel | AddAndRemove add: sel].

"Stream  -- many operations change its state"
	#("testing" atEnd) do: [:sel | Approved add: sel].
	#("accessing" next: nextMatchAll: nextMatchFor: upToEnd
next:put: nextPut: nextPutAll: "printing" print: printHtml:
	) do: [:sel | AddAndRemove add: sel].

"PositionableStream"
	#("accessing" contentsOfEntireFile originalContents peek peekFor: "testing"
"positioning" position ) do: [:sel | Approved add: sel].
	#(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel].
	"Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics.  We want to find the messages that convert Streams to other things."

"ReadWriteStream"
	#("file status" closed) do: [:sel | Approved add: sel].
	#("accessing" next: on: ) do: [:sel | AddAndRemove add: sel].

"WriteStream"
	#("in class, instance creation" on:from:to: with: with:from:to:
		) do: [:sel | Approved add: sel].
	#("positioning" resetToStart
"character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel].

"LookupKey, Association, Link"
	#("accessing" key nextLink) do: [:sel | Approved add: sel].
	#(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel].

"Point"
	#("in class, instance creation" r:degrees: x:y:
"accessing" x y "comparing" "arithmetic" "truncation and round off"
"polar coordinates" degrees r theta
"point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector
"converting" asFloatPoint asIntegerPoint corner: extent: rect:
"transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying"
"interpolating" interpolateTo:at:) do: [:sel | Approved add: sel].

"Rectangle"
	#("in class, instance creation" center:extent: encompassing: left:right:top:bottom: 
	merging: origin:corner: origin:extent: 
"accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight
"comparing"
"rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth:
"testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide
"truncation and round off"
"transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying"
	) do: [:sel | Approved add: sel].

"Color"
	#("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range:
	"named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow
	"other" colorNames indexedColors pixelScreenForDepth: quickHighLight:
"access" alpha blue brightness green hue luminance red saturation
"equality"
"queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor
"transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with:
"groups of shades" darkShades: lightShades: mix:shades: wheel:
"printing" shortPrintString
"other" colorForInsets rgbTriplet
"conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32
"private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying"
	) do: [:sel | Approved add: sel].

"	For each selector that requires a block argument, add (selector argNum) 
		to the set Blocks."
"ourClasses _ #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color).
ourClasses do: [:clsName | cls _ Smalltalk at: clsName.
	(cls selectors) do: [:aSel |
		((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
			(cls formalParametersAt: aSel) withIndexDo: [:tName :ind |
				(tName endsWith: 'Block') ifTrue: [
					Blocks add: (Array with: aSel with: ind)]]]]].
"
#((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (ifKindOf:thenDo: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
	Blocks add: anArray].

self initialize3.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: TranslucentColor class 
"
"Do not forget class messages for each of these classes"
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 7/18/1999 23:06'!
initialize3
	"more selectors to consider"! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 12/29/2000 13:22'!
load: dataWithAnswers
	"Find a function that takes the data and gives the answers.  Odd list entries are data for it, even ones are the answers.  nil input means data and answers were supplied already."
"  (MethodFinder new) load: #( (4 3) 7  (-10 5) -5  (-3 11) 8);
		findMessage  "

dataWithAnswers ifNotNil: [
	data _ Array new: dataWithAnswers size // 2.
	1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)].
	answers _ Array new: data size.
	1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]].
data do: [:list | 
	(list isKindOf: SequenceableCollection) ifFalse: [
		^ self inform: 'first and third items are not Arrays'].
	].
argMap _ (1 to: data first size) asArray.
data do: [:list | list size = argMap size ifFalse: [
		self inform: 'data arrays must all be the same size']].
argMap size > 4 ifTrue: [self inform: 'No more than a receiver and 
three arguments allowed'].
	"Really only test receiver and three args." 
thisData _ data copy.
mapStage _ mapList _ nil.
! !

!MethodFinder methodsFor: 'initialize' stamp: 'sw 1/14/2000 14:03'!
noteDangerous
	"Remember the methods with really bad side effects."

	Dangerous _ Set new.
"Object accessing, testing, copying, dependent access, macpal, flagging"
	#(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
		do: [:sel | Dangerous add: sel].

"Object error handling"
	#(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:)
		do: [:sel | Dangerous add: sel].

"Object user interface"
	#(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
		do: [:sel | Dangerous add: sel].

"Object system primitives"
	#(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
		do: [:sel | Dangerous add: sel].

"Object private"
	#(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
		do: [:sel | Dangerous add: sel].

"Object, translation support"
	#(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
		do: [:sel | Dangerous add: sel].

"Object, objects from disk, finalization.  And UndefinedObject"
	#(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until:   suspend)
		do: [:sel | Dangerous add: sel].

"No Restrictions:   Boolean, False, True, "

"Morph"
	#(fullCopy copyRecordingIn:)
		do: [:sel | Dangerous add: sel].

"Behavior"
	#(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: 
"creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
"user interface" allCallsOn: browse browseAllAccessesTo: browseAllCallsOn: browseAllStoresInto: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
"private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: removeSelectorSimply:)
		do: [:sel | Dangerous add: sel].

"Others "
	#("no tangible result" do: associationsDo:  
"private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
		do: [:sel | Dangerous add: sel].


	#(    fileOutPrototype addSpareFields makeFileOutFile )
		do: [:sel | Dangerous add: sel].
	#(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: )
		do: [:sel | Dangerous add: sel].

 ! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/14/1999 11:16'!
organizationFiltered: aClass
	"Return the organization of the class with all selectors defined in superclasses removed.  (except those in Object)"

	| org str |
	org _ aClass organization deepCopy.
	Dangerous do: [:sel |
			org removeElement: sel].
	Approved do: [:sel |
			org removeElement: sel].
	AddAndRemove do: [:sel |
			org removeElement: sel].
	str _ org printString copyWithout: $(.
	str _ '(', (str copyWithout: $) ).
	str _ str replaceAll: $' with: $".
	^ str
! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/27/1999 17:24'!
test2: anArray
	"look for bad association"

	anArray do: [:sub |
		sub class == Association ifTrue: [
			(#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [
				self error: 'bad assn'].
			(#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [
				self error: 'bad assn'].

	"			sub value class == Association ifTrue: [
					self error: 'bad assn'].
				(sub value isKindOf: Class) ifTrue: [
					self error: 'class in assn'].
				sub value class == Symbol ifTrue: [sub value asciiValue = 204 '$Ì' ifTrue: [
					self error: 'Write into char']].
				sub value == $Ì ifTrue: [
					self error: 'Write into char']
	"].
		sub class == Array ifTrue: [
			sub do: [:element | 
				element class == String ifTrue: [element first asciiValue < 32 ifTrue: [
						self error: 'store into string in data']].
				element class == Association ifTrue: [
					element value class == Association ifTrue: [
						self error: 'bad assn']]]].
		sub class == Date ifTrue: [sub year isInteger ifFalse: [
				self error: 'stored into input date!!!!']].
		sub class == Dictionary ifTrue: [
				sub size > 0 ifTrue: [
					self error: 'store into dictionary']].
		sub class == OrderedCollection ifTrue: [
				sub size > 4 ifTrue: [
					self error: 'store into OC']].
		].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 4/24/1999 19:34'!
test3
	"find the modification of the caracter table"

	(#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/4/1999 20:18'!
testFromTuple: nth
	"verify that the methods allowed don't crash the system.  Try N of each of the fundamental types.  up to 4 of each kind." 

| objects nonRepeating even other aa cnt |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
	(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
	).

objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
	{Point class. SmallInteger class. Association class. Array class}.
	"{ 4 blocks }."
	{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
	{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
	{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
	{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 
		#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
	{3->true. 5.6->$a. #x->2. 'abcd'->false}.
	{9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}.
	{Color red.  Color blue. Color black. Color gray}}.

self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested.  " 
cnt _ 0.
nth to: 4 do: [:take |
	nonRepeating _ OrderedCollection new.
	objects do: [:each |
		nonRepeating addAll: (each copyFrom: 1 to: take)].
	"all combinations of take, from nonRepeating"
	even _ true.
	nonRepeating combinations: take atATimeDo: [:tuple |
		even ifTrue: [other _ tuple clone]
			ifFalse: [self load: (aa _ Array with: tuple with: 1 with: other with: 7).
				(cnt _ cnt+1) \\ 50 = 0 ifTrue: [
					Transcript cr; show: aa first printString].
				self search: true.
				self test2: aa.
				self test2: nonRepeating.
				"self test2: objects"].
		even _ even not].
	].! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 5/4/1999 20:19'!
testRandom
	"verify that the methods allowed don't crash the system.  Pick 3 or 4 from a mixed list of the fundamental types." 

| objects other aa cnt take tuple fName sss |
objects _ #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
	(x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
	).

objects _ objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
	{Point class. SmallInteger class. Association class. Array class}.
	"{ 4 blocks }."
	{Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
	{'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
	{Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
	{#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection. 
		#($a 3 d) asOrderedCollection. #() asOrderedCollection}.
	{3->true. 5.6->$a. #x->2. 'abcd'->false}.
	{9@3 extent: 5@4. 0@0 extent: 45@9. -3@-7 extent: 2@2. 4@4 extent: 16@16}.
	{Color red.  Color blue. Color black. Color gray}}.

self test2: objects.
"rec+0, rec+1, rec+2, rec+3 need to be tested.  " 
fName _ (FileDirectory default fileNamesMatching: '*.ran') first.
sss _ fName splitInteger first.
(Collection classPool at: #RandomForPicking) seed: sss.
cnt _ 0.
[take _ #(3 4) atRandom.
	tuple _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
	other _ (1 to: take) collect: [:ind | (objects atRandom) atRandom].
	self load: (aa _ Array with: tuple with: 1 with: other with: 7).
	((cnt _ cnt+1) \\ 10 = 0) " | (cnt > Skip)" ifTrue: [
		Transcript cr; show: cnt printString; tab; tab; show: aa first printString].
	cnt > (Smalltalk at: #StopHere) ifTrue: [self halt].		"stop just before crash"
	cnt > (Smalltalk at: #Skip) ifTrue: ["skip this many at start"
		self search: true.
		self test2: aa first.  self test2: (aa at: 3).
		"self test2: objects"
		].
	true] whileTrue.
	! !

!MethodFinder methodsFor: 'initialize' stamp: 'tk 1/18/2001 23:41'!
verify
	"Test a bunch of examples"
	"	MethodFinder new verify    "
Approved ifNil: [self initialize].	"Sets of allowed selectors"
(MethodFinder new load: #( (0) 0  (30) 0.5  (45) 0.707106  (90) 1)
	) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it'].
(MethodFinder new load:  { { true. [3]. [4]}. 3.  { false. [0]. [6]}. 6}
	) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [
		self error: 'should have found it'].
(MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false}
	) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it'].
		"will correct the date type of #true, and complain"
(MethodFinder new load: #((4 2) '2r100'   (255 16) '16rFF'    (14 8) '8r16')
	) searchForOne asArray = 
		#('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2')
			  ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: {{Point x: 3 y: 4}. 4.  {Point x: 1 y: 5}. 5}
	) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(('abcd') $a  ('TedK') $T)
	) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne')
		 ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(('abcd' 1) $a  ('Ted ' 3) $d )
	) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2')
		ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #(((12 4 8)) 24  ((1 3 6)) 10 )
	) searchForOne asArray=  #('data1 sum') ifFalse: [self error: 'should have found it'].	
		"note extra () needed for an Array object as an argument"

(MethodFinder new load: #((14 3) 11  (-10 5) -15  (4 -3) 7)
	) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: #((4) 4  (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612)
	) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it'].
(MethodFinder new load: {#(4 3). true.  #(-7 3). false.  #(5 1). true.  #(5 5). false}
	) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((5) 0.2   (2) 0.5)
	) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((12 4 8) 2  (1 3 6) 2  (5 2 16) 8)
	) searchForOne asArray = #()     " '(data3 / data2) ' want to be able to leave out args"  
		ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((0.0) 0.0  (1.5) 0.997495  (0.75) 0.681639)
	) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it'].	
(MethodFinder new load: #((7 5) 2   (4 5) 4   (-9 4) 3)
	) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it'].	
! !


!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
argMap
	^ argMap ! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/18/1999 14:46'!
makeAllMaps 
	"Make a giant list of all permutations of the args.  To find the function, we will try these permutations of the input data.  receiver, args."

	| ii |
	mapList _ Array new: argMap size factorial.
	ii _ 1.
	argMap permutationsDo: [:perm |
		mapList at: ii put: perm copy.
		ii _ ii + 1].
	mapStage _ 1.	"about to be bumped"! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
mapData 
	"Force the data through the map (permutation) to create the data to test."

	thisData _ data collect: [:realData |
					argMap collect: [:ind | realData at: ind]].
		! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 5/24/1999 16:31'!
permuteArgs 
	"Run through ALL the permutations.  First one was as presented."

	data first size <= 1 ifTrue: [^ false].	"no other way"
	mapList ifNil: [self makeAllMaps].
	mapStage _ mapStage + 1.
	mapStage > mapList size ifTrue: [^ false].
	argMap _ mapList at: mapStage.
	self mapData.
	^ true
	! !

!MethodFinder methodsFor: 'arg maps' stamp: 'tk 4/24/1999 19:29'!
thisData
	^ thisData ! !


!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 18:18'!
exceptions
	"Handle some very slippery selectors.
	asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!" 

	| aSel |
	answers first class == Symbol ifFalse: [^ self].
	thisData first first class == String ifFalse: [^ self].
	aSel _ #asSymbol.
	(self testPerfect: aSel) ifTrue: [
		selector add: aSel.
		expressions add: (String streamContents: [:strm | 
			strm nextPutAll: 'data', argMap first printString.
			aSel keywords doWithIndex: [:key :ind |
				strm nextPutAll: ' ',key.
				(key last == $:) | (key first isLetter not)
					ifTrue: [strm nextPutAll: ' data', 
						(argMap at: ind+1) printString]]])].
! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 18:35'!
findMessage
	"Control the search."

	data do: [:alist |
		(alist isKindOf: SequenceableCollection) ifFalse: [
			^ OrderedCollection with: 'first and third items are not Arrays']].
	Approved ifNil: [self initialize].	"Sets of allowed selectors"
	expressions _ OrderedCollection new.
	self search: true.	"multi"
	expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function'].
	expressions class = String ifTrue: [^ OrderedCollection with: expressions].
 	^ expressions! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/4/2001 14:10'!
insertConstants
	"see if one of several known expressions will do it. C is the constant we discover here."
	"C  data1+C  data1*C  data1//C  (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) 
 (data1 mod C)"

	thisData size >= 2 ifFalse: [^ self].	"need 2 examples"
	(thisData at: 1) size = 1 ifFalse: [^ self].	"only one arg, data1"

	self const ifTrue: [^ self].
	self constEquiv ifTrue: [^ self].	" ==  ~= "
	self constLessThan ifTrue: [^ self].	" <=  and  >= "

	self allNumbers ifFalse: [^ self].
	self constMod ifTrue: [^ self].
	self constPlus ifTrue: [^ self].
	self constMult ifTrue: [^ self].
	self constDiv ifTrue: [^ self].
	self constLinear ifTrue: [^ self].
! !

!MethodFinder methodsFor: 'search' stamp: 'tk 12/29/2000 12:54'!
search: multi
	"if Multi is true, collect all selectors that work."
	| old |
	selector _ OrderedCollection new.	"list of them"
	old _ Preferences autoAccessors.
	Preferences disableGently: #autoAccessors.
	self simpleSearch.
	multi not & (selector isEmpty not) ifTrue:
		[old ifTrue: [Preferences enableGently: #autoAccessors].
		^ selector].

	[self permuteArgs] whileTrue:
		[self simpleSearch.
		multi not & (selector isEmpty not) ifTrue:
			[old ifTrue: [Preferences enableGently: #autoAccessors].
			^ selector]].

	self insertConstants.
	old ifTrue: [Preferences enableGently: #autoAccessors].
	"(selector isEmpty not) ifTrue: [^ selector]].    expression is the answer, not a selector"
	^ #()! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 17:53'!
searchForOne
	"Look for and return just one answer"

	expressions _ OrderedCollection new.
	self search: false.	"non-multi"
	^ expressions
			! !

!MethodFinder methodsFor: 'search' stamp: 'tk 1/8/2001 18:17'!
simpleSearch
	"Run through first arg's class' selectors, looking for one that works."

| class supers listOfLists |
self exceptions.
class _ thisData first first class.
"Cache the selectors for the receiver class"
(class == cachedClass and: [cachedArgNum = ((argMap size) - 1)]) 
	ifTrue: [listOfLists _ cachedSelectorLists]
	ifFalse: [supers _ class withAllSuperclasses.
		listOfLists _ OrderedCollection new.
		supers do: [:cls |
			listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)].
		cachedClass _ class.
		cachedArgNum _ (argMap size) - 1.
		cachedSelectorLists _ listOfLists].
listOfLists do: [:selectorList |
	selectorList do: [:aSel |
		(selector includes: aSel) ifFalse: [
			((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
				(self testPerfect: aSel) ifTrue: [
					selector add: aSel.
					expressions add: (String streamContents: [:strm | 
						strm nextPutAll: 'data', argMap first printString.
						aSel keywords doWithIndex: [:key :ind |
							strm nextPutAll: ' ',key.
							(key last == $:) | (key first isLetter not)
								ifTrue: [strm nextPutAll: ' data', 
									(argMap at: ind+1) printString]]])
					]]]]].
! !

!MethodFinder methodsFor: 'search' stamp: 'tk 4/30/1999 14:22'!
testPerfect: aSelector
	"Try this selector!! Return true if it answers every example perfectly.  Take the args in the order they are.  Do not permute them.  Survive errors.  later cache arg lists."

| sz argList val rec activeSel perform |
	"Transcript cr; show: aSelector.		debug"
perform _ aSelector beginsWith: 'perform:'.
sz _ argMap size.
1 to: thisData size do: [:ii | "each example set of args"
	argList _ (thisData at: ii) copyFrom: 2 to: sz.
	perform
		ifFalse: [activeSel _ aSelector]
		ifTrue: [activeSel _ argList first.	"what will be performed"
			((Approved includes: activeSel) or: [AddAndRemove includes: activeSel])
				ifFalse: [^ false].	"not approved"
			aSelector == #perform:withArguments: 
				ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error" 
							ifFalse: [^ false]]
				ifFalse: [activeSel numArgs = (aSelector numArgs - 1) 
							ifFalse: [^ false]]].
	1 to: sz do: [:num | 
		(Blocks includes: (Array with: activeSel with: num)) ifTrue: [
			(argList at: num) class == BlockContext ifFalse: [^ false]]].
	rec _ (AddAndRemove includes: activeSel) 
			ifTrue: [(thisData at: ii) first class == Symbol ifTrue: [^ false].
						"vulnerable to modification"
				(thisData at: ii) first copyTwoLevel] 	"protect from damage"
			ifFalse: [(thisData at: ii) first].
	val _ [rec perform: aSelector withArguments: argList] 
				ifError: [:aString :aReceiver | 
							"self test3."
							"self test2: (thisData at: ii)."
							^ false].
	"self test3."
	"self test2: (thisData at: ii)."
	((answers at: ii) closeTo: val) ifFalse: [^ false].
	].
^ true! !


!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'!
answers

	^ answers! !

!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:39'!
data

	^ data! !

!MethodFinder methodsFor: 'access' stamp: 'tk 12/29/2000 13:20'!
expressions
	^ expressions! !

!MethodFinder methodsFor: 'access' stamp: 'tk 1/4/2001 17:18'!
selectors
	"Note the inst var does not have an S on the end"

	^ selector! !


!MethodFinder methodsFor: 'find a constant' stamp: 'tk 12/29/2000 22:34'!
allNumbers
	"Return true if all answers and all data are numbers."

	answers do: [:aa | aa isNumber ifFalse: [^ false]].
	thisData do: [:vec |
			vec do: [:nn | nn isNumber ifFalse: [^ false]]].
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:45'!
const
	| const |
	"See if (^ constant) is the answer"

	"quick test"
	((const _ answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false].
	3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]].
	expressions add: '^ ', const printString.
	selector add: #yourself.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'!
constDiv
	| const subTest got |
	"See if (data1 // C) is the answer"

	const _ ((thisData at: 1) at: 1) // (answers at: 1).  "May not be right!!"
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:48'!
constEquiv
	| const subTest got |
	"See if (data1 = C) or (data1 ~= C) is the answer"

	"quick test"
	((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
	2 to: answers size do: [:ii | 
		((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].

	const _ (thisData at: 1) at: 1.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: ["try other polarity for ~~ "
		(ii _ answers indexOf: (answers at: 1) not) > 0 ifTrue: [
		const _ (thisData at: ii) at: 1.
		got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not]]. 
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:46'!
constLessThan
	| const subTest got minConst maxConst tt |
	"See if (data1 <= C) or (data1 >= C) is the answer"

	"quick test"
	((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
	2 to: answers size do: [:ii | 
		((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].

	minConst _ Float infinity.  maxConst _ minConst negated.
	answers withIndexDo: [:aa :ii |
		aa ifTrue: [tt _ (thisData at: ii) at: 1.
			minConst _ minConst min: tt.
			maxConst _ maxConst max: tt]].
	const _ (thisData at: 1) at: 1.
	got _ (subTest _ MethodFinder new copy: self addArg: minConst) 
				searchForOne isEmpty not.
	got ifFalse: ["try other extreme for <= >= "
		got _ (subTest _ MethodFinder new copy: self addArg: maxConst) 
				searchForOne isEmpty not]. 
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:47'!
constLinear
	| const subTest got denom num slope offset |
	"See if (data1 * C1) + C2 is the answer.  In the form  #(C2 C1) polynomialEval: data1 "

	denom _ ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1).
	denom = 0 ifTrue: [^ false].   "will divide by it"
	num _ (answers at: 2) - (answers at: 1).

    slope := (num asFloat / denom) reduce.
    offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce.

	const _ Array with: offset with: slope.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/18/2001 22:46'!
constMod
	| subTest low |
	"See if mod, (data1 \\ C) is the answer"

	low _ answers max.
	low+1 to: low+20 do: [:const |
		subTest _ MethodFinder new copy: self addArg: const.
		(subTest testPerfect: #\\) ifTrue: [
			expressions add: 'data1 \\ ', const printString.
			selector add: #\\.
			^ true]].
	^ false! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:49'!
constMult
	| const subTest got |
	"See if (data1 * C) is the answer"

	((thisData at: 1) at: 1) = 0 ifTrue: [^ false].
	const _ ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce.
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

!MethodFinder methodsFor: 'find a constant' stamp: 'tk 1/8/2001 17:48'!
constPlus
	| const subTest got |
	"See if (data1 + C) is the answer"

	const _ (answers at: 1) - ((thisData at: 1) at: 1).
	got _ (subTest _ MethodFinder new copy: self addArg: const) 
				searchForOne isEmpty not.
	got ifFalse: [^ false]. 

	"replace data2 with const in expressions"
	subTest expressions do: [:exp |
		expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
	selector addAll: subTest selectors.
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MethodFinder class
	instanceVariableNames: ''!

!MethodFinder class methodsFor: 'as yet unclassified' stamp: 'tk 1/8/2001 18:17'!
methodFor: dataAndAnswers
	"Return a Squeak expression that computes these answers.  (This method is called by the comment in the bottom pane of a MethodFinder.  Do not delete this method.)"

	| resultOC selFinder resultString |
	resultOC _ (self new) load: dataAndAnswers; findMessage.
	resultString _ String streamContents: [:strm |
		resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]].
	Smalltalk isMorphic ifTrue: [
		selFinder _ (Display bestGuessOfCurrentWorld 
				submorphThat: [:mm | mm class == SystemWindow and: 
									[mm model isKindOf: SelectorBrowser]] 
				ifNone: [^ resultString]) model.
		selFinder searchResult: resultOC].
	^ resultString! !
CodeHolder subclass: #MethodHolder
	instanceVariableNames: 'methodClass methodSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/23/1999 22:48'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
	aCustomMenu addLine.
	aCustomMenu add: 'whose script is this?' target: self action: #identifyScript
	! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'tk 8/30/2000 13:07'!
compiledMethod

	^ methodClass compiledMethodAt: methodSelector! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/19/2000 14:48'!
contents
	contents _ methodClass sourceCodeAt: methodSelector ifAbsent: [''].
	currentCompiledMethod _ methodClass compiledMethodAt: methodSelector ifAbsent: [nil].
	Preferences browseWithPrettyPrint ifTrue:
		[contents _ methodClass compilerClass new
			format: contents in: methodClass notifying: nil decorated: Preferences colorWhenPrettyPrinting].
	self showDiffs ifTrue:
		[contents _ self diffFromPriorSourceFor: contents].

	contents _ contents asText makeSelectorBoldIn: methodClass.
	
	^ contents! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 13:06'!
contents: input notifying: aController 
	| selector |
	(selector _ Parser new parseSelector: input asText) ifNil:
		[self inform: 'Sorry - invalid format for the 
method name and arguments -- cannot accept.'.
		^ false].

	selector == methodSelector ifFalse:
		[self inform:
'You cannot change the name of
the method here -- it must continue
to be ', methodSelector.
		^ false].

	selector _ methodClass
				compile: input asText
				classified: self selectedMessageCategoryName
				notifying: aController.
	selector == nil ifTrue: [^ false].
	contents _ input asString copy.
	currentCompiledMethod _ methodClass compiledMethodAt: methodSelector.
	^ true! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'tk 8/30/2000 11:27'!
doItReceiver
	"This class's classPool has been jimmied to be the classPool of the class 
	being browsed. A doIt in the code pane will let the user see the value of 
	the class variables."

	^ self selectedClass ifNil: [FakeClassPool new]! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/23/1999 23:01'!
identifyScript
	| msg aPlayer |
	msg _ methodClass isUniClass
		ifTrue:
			[aPlayer _ methodClass someInstance.
			aPlayer costume
				ifNotNil:
					['This holds code for a script
named ', methodSelector, ' belonging
to an object named ', aPlayer externalName]
				ifNil:
					['This formerly held code for a script
named ', methodSelector, ' for a Player
who once existed but now is moribund.']]
		ifFalse:
			['This holds code for the method
named ', methodSelector, '
for class ', methodClass name].
	self inform: msg! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 13:05'!
methodClass: aClass methodSelector: aSelector
	methodClass _ aClass.
	methodSelector _ aSelector.
	currentCompiledMethod _ aClass compiledMethodAt: aSelector ifAbsent: [nil]! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 09:40'!
selectedClass
	^ methodClass theNonMetaClass! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 14:30'!
selectedClassOrMetaClass
	^ methodClass! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 10:16'!
selectedMessageCategoryName
	^ methodClass organization categoryOfElement: methodSelector! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 09:39'!
selectedMessageName
	^ methodSelector! !

!MethodHolder methodsFor: 'as yet unclassified' stamp: 'tk 8/30/2000 13:08'!
versions
	"Return a VersionsBrowser (containing a list of ChangeRecords) of older versions of this method."

	^ VersionsBrowser new scanVersionsOf: self compiledMethod
			class: self selectedClass 
			meta: methodClass isMeta 
			category: self selectedMessageCategoryName
				"(classOfMethod whichCategoryIncludesSelector: selectorOfMethod)"
			selector: methodSelector! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MethodHolder class
	instanceVariableNames: ''!

!MethodHolder class methodsFor: 'instance creation' stamp: 'sw 10/27/2000 17:28'!
isolatedCodePaneForClass: aClass selector: aSelector
	"Answer a MethodMorph on the given class and selector"

	| aCodePane aMethodHolder |

	aMethodHolder _ self new.
	aMethodHolder methodClass: aClass methodSelector: aSelector.

	aCodePane _ MethodMorph on: aMethodHolder text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	aMethodHolder addDependent: aCodePane.
	aCodePane borderWidth: 2; color: Color white.
	aCodePane scrollBarOnLeft: false.
	aCodePane width: 300.
	^ aCodePane! !

!MethodHolder class methodsFor: 'instance creation' stamp: 'sw 10/23/2000 18:55'!
makeIsolatedCodePaneForClass: aClass selector: aSelector
	"Create, and place in the morphic Hand, an isolated code pane bearing source code for the given class and selector"

	(self isolatedCodePaneForClass: aClass selector: aSelector) openInHand! !
ObjectWithDocumentation subclass: #MethodInterface
	instanceVariableNames: 'selector argumentSpecifications resultSpecification userLevel attributeKeywords defaultStatus defaultFiresPerTick '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!
!MethodInterface commentStamp: '<historical>' prior: 0!
A MethodInterface describes the interface for a single method.  The most generic form is not bound to any particular class or object but rather describes an idealized interface.

	selector					A symbol - the selector being described
	argumentSpecifications	A list of specifications for the formal arguments of the method
	resultSpecification 		A characterization of the return value of the method
	userLevel				
	attributeKeywords		A list of symbols, comprising keywords that the user wishes to
								associate with this method
	defaultStatus			The status to apply to new instances of the class by default
	defaultFiresPerTick		How many fires per tick, by default, should be allowed if ticking.


!


!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:31'!
attributeKeywords
	"Answer a list of attribute keywords associated with the receiver"

	^ attributeKeywords ifNil: [attributeKeywords _ OrderedCollection new]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:32'!
flagAttribute: aSymbol
	"Mark the receiver as having the given category-keyword"

	(self attributeKeywords includes: aSymbol) ifFalse: [attributeKeywords add: aSymbol]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:33'!
flagAttributes: attributeSymbolList
	"Mark the receiver has being flagged with all the symbols in the list provided"

	attributeSymbolList do: [:aSym | self flagAttribute: aSym]! !

!MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 1/26/2001 16:34'!
isFlaggedAs: aSymbol
	"Answer whether the receiver is flagged with the given trait"

	^ self attributeKeywords includes: aSymbol! !


!MethodInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:46'!
initialize
	"Initialize the receiver"

	super initialize.
	attributeKeywords _ OrderedCollection new.
	defaultStatus _ #normal.
	defaultFiresPerTick _ 1.
! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:39'!
initializeFor: aSelector
	"Initialize the receiver to have the given selector"

	selector _ aSelector.
	attributeKeywords _ OrderedCollection new.
	defaultStatus _ #normal.
	defaultFiresPerTick _ 1.
! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 23:20'!
initializeFromEToyCommandSpec: tuple category: aCategorySymbol
	"tuple holds an old etoy command-item spec, of the form found in #additionsToViewerCategories methods.   Initialize the receiver to hold the same information"

	selector _ tuple second.
	self documentation: tuple third.
	aCategorySymbol ifNotNil: [self flagAttribute: aCategorySymbol].
	tuple size > 3 ifTrue:
		[argumentSpecifications _ OrderedCollection with:
			(Variable new variableType: tuple fourth)]
	! !

!MethodInterface methodsFor: 'initialization' stamp: 'sw 1/30/2001 20:14'!
initializeFromEToySlotSpec: tuple
	"tuple holds an old etoyslot-item spec, of the form found in #additionsToViewerCategories methodds.   Initialize the receiver to hold the same information"

	| setter |
	selector _ tuple seventh.
	self documentation: tuple third.
	resultSpecification _ ResultSpecification new.
	resultSpecification resultType: tuple fourth.

	((tuple fifth == #readWrite) and: [((tuple size >= 9) and: [(setter _ tuple at: 9) ~~ #unused])]) ifTrue:
		[resultSpecification companionSetterSelector: setter].
		

"slot amount 'The amount of displacement' number readOnly player getAmount unused unused"
	! !


!MethodInterface methodsFor: 'access' stamp: 'sw 1/23/2001 18:37'!
selector
	"Answer the receiver's selector"

	^ selector! !


!MethodInterface methodsFor: 'status' stamp: 'sw 1/23/2001 17:16'!
defaultStatus
	"Answer the receiver's default defaultStatus"

	^ defaultStatus! !

!MethodInterface methodsFor: 'status' stamp: 'sw 1/23/2001 17:00'!
defaultStatus: aStatus
	"Set the receiver's defaultStatus as indicated"

	defaultStatus _ aStatus! !
PluggableTextMorph subclass: #MethodMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!MethodMorph methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 17:38'!
initialize
	super initialize.
	self useRoundedCorners! !

!MethodMorph methodsFor: 'as yet unclassified' stamp: 'tk 9/7/2000 22:07'!
installRollBackButtons: target
	| mine |
	"If I don't already have such a button, put one in at the upper right.  Set its target to the furtherest enclosing book.  Send chooseAndRevertToVersion when clicked.  Stay in place via scrollBar install."

	mine _ self submorphNamed: #chooseAndRevertToVersion ifNone: [nil].
	mine ifNil: [mine _ SimpleButtonMorph new.
		"mine height: mine height - 2."
		mine label: 'Roll Back'; cornerStyle: #square.
		mine color: Color white; borderColor: Color black.
		mine actionSelector: #chooseAndRevertToVersion.
		mine align: mine topRight with: (self findA: ScrollBar) topLeft +(1@1).
		self addMorphFront: mine.
		mine height: mine height - 5 "14"].
	mine target: target.! !

!MethodMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 09:41'!
step
	model updateCodePaneIfNeeded! !

!MethodMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/1999 23:03'!
stepTime
	^ 3000! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MethodMorph class
	instanceVariableNames: ''!

!MethodMorph class methodsFor: 'as yet unclassified' stamp: 'kfr 5/3/2000 12:52'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
ParseNode subclass: #MethodNode
	instanceVariableNames: 'selectorOrFalse precedence arguments block literals primitive encoder temporaries '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!MethodNode commentStamp: '<historical>' prior: 0!
I am the root of the parse tree.!


!MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'!
block
	^ block! !

!MethodNode methodsFor: 'initialize-release'!
selector: selOrFalse arguments: args precedence: p temporaries: temps block: blk encoder: anEncoder primitive: prim 
	"Initialize the receiver with respect to the arguments given."

	encoder _ anEncoder.
	selectorOrFalse _ selOrFalse.
	precedence _ p.
	arguments _ args.
	temporaries _ temps.
	block _ blk.
	primitive _ prim! !


!MethodNode methodsFor: 'code generation'!
encoder
	^ encoder! !

!MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:48'!
generate: trailer 
	"The receiver is the root of a parse tree. Answer a CompiledMethod. The
	argument, trailer, is the references to the source code that is stored with 
	every CompiledMethod."

	| blkSize nLits stack strm nArgs method |
	self generate: trailer ifQuick: 
		[:m |  method _ m.
		method cacheTempNames: self tempNames.
		^ method].
	nArgs _ arguments size.
	blkSize _ block sizeForEvaluatedValue: encoder.
	literals _ encoder allLiterals.
	(nLits _ literals size) > 255
		ifTrue: [^self error: 'Too many literals referenced'].
	method _ CompiledMethod	"Dummy to allocate right size"
				newBytes: blkSize
				trailerBytes: trailer 
				nArgs: nArgs
				nTemps: encoder maxTemp
				nStack: 0
				nLits: nLits
				primitive: primitive.
	strm _ ReadWriteStream with: method.
	strm position: method initialPC - 1.
	stack _ ParseStack new init.
	block emitForEvaluatedValue: stack on: strm.
	stack position ~= 1 ifTrue: [^self error: 'Compiler stack
discrepancy'].
	strm position ~= (method size - trailer size) 
		ifTrue: [^self error: 'Compiler code size discrepancy'].
	method needsFrameSize: stack size.
	1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)].
	method cacheTempNames: self tempNames.
	^ method! !

!MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:45'!
generate: trailer ifQuick: methodBlock
	| v |
	(primitive = 0 and: [arguments size = 0 and: [block isQuick]])
		ifFalse: [^ self].
	v _ block code.
	v < 0
		ifTrue: [^ self].
	v = LdSelf
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)].
	(v between: LdTrue and: LdMinus1 + 3)
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)].
	v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType))
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)].
	v // 256 = 1
		ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]! !

!MethodNode methodsFor: 'code generation'!
selector 
	"Answer the message selector for the method represented by the receiver."

	(selectorOrFalse isMemberOf: Symbol)
		ifTrue: [^selectorOrFalse].
	^selectorOrFalse key! !

!MethodNode methodsFor: 'code generation'!
sourceMap
	"Answer a SortedCollection of associations of the form: pc (byte offset in 
	me) -> sourceRange (an Interval) in source text."

	self generate: #(0 0 0 0).
	^encoder sourceMap! !


!MethodNode methodsFor: 'converting' stamp: 'di 4/13/2000 21:09'!
decompileString 
	"Answer a string description of the parse tree whose root is the receiver."

	^ (DialectStream dialect: #ST80 contents: [:strm | self printOn: strm])
		asString
! !

!MethodNode methodsFor: 'converting' stamp: 'di 4/5/2000 10:07'!
decompileText 
	"Answer a string description of the parse tree whose root is the receiver."

	^ DialectStream
		dialect: (Preferences printAlternateSyntax ifTrue: [#SQ00] ifFalse: [#ST80])
		contents: [:strm | self printOn: strm]! !


!MethodNode methodsFor: 'printing' stamp: 'di 6/13/2000 00:46'!
printOn: aStream 

	precedence = 1
		ifTrue: 
			[aStream nextPutAll: self selector]
		ifFalse: 
			[self selector keywords with: arguments do: 
				[:kwd :arg | 
				aStream dialect = #SQ00
					ifTrue: [(kwd endsWith: ':')
							ifTrue: [aStream withStyleFor: #methodSelector
									do: [aStream nextPutAll: kwd allButLast].
									aStream nextPutAll: ' (']
							ifFalse: [aStream withStyleFor: #methodSelector
									do: [aStream nextPutAll: kwd].
									aStream space]]
					ifFalse: [aStream nextPutAll: kwd; space].
				aStream withStyleFor: #methodArgument
					do: [aStream nextPutAll: arg key].
				(aStream dialect = #SQ00 and: [kwd endsWith: ':'])
					ifTrue: [aStream nextPutAll: ') ']
					ifFalse: [aStream space]]].
	comment == nil ifFalse: 
			[aStream crtab: 1.
			self printCommentOn: aStream indent: 1].
	temporaries size > 0 ifTrue: 
			[aStream crtab: 1.
			aStream dialect = #SQ00
				ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Use']]
				ifFalse: [aStream nextPutAll: '|'].
			aStream withStyleFor: #temporaryVariable
				do: [temporaries do: 
						[:temp | aStream space; nextPutAll: temp key]].
			aStream dialect = #SQ00
				ifTrue: [aStream nextPutAll: '.']
				ifFalse: [aStream nextPutAll: ' |']].
	primitive > 0 ifTrue:
			[(primitive between: 255 and: 519) ifFalse:  " Dont decompile <prim> for, eg, ^ self "
				[aStream crtab: 1.
				self printPrimitiveOn: aStream]].
	aStream crtab: 1.
	^ block printStatementsOn: aStream indent: 0! !

!MethodNode methodsFor: 'printing' stamp: 'dvf 7/7/2000 14:23'!
printPrimitiveOn: aStream 
	"Print the primitive on aStream"
	| primIndex primDecl |
	primIndex _ primitive.
	primIndex = 0
		ifTrue: [^ self].
	primIndex = 120
		ifTrue: ["External call spec"
			^ aStream print: encoder literals first].
	aStream nextPutAll: '<primitive: '.
	primIndex = 117
		ifTrue: [primDecl _ encoder literals at: 1.
			aStream nextPut: $';
				
				nextPutAll: (primDecl at: 2);
				 nextPut: $'.
			(primDecl at: 1) notNil
				ifTrue: [aStream nextPutAll: ' module:';
						 nextPut: $';
						
						nextPutAll: (primDecl at: 1);
						 nextPut: $']]
		ifFalse: [aStream print: primIndex].
	aStream nextPut: $>.
	aStream nextPutAll: ' "'
			, ((Interpreter classPool at: #PrimitiveTable)
					at: primIndex + 1) , '" '.! !

!MethodNode methodsFor: 'printing'!
tempNames
	^ encoder tempNames! !


!MethodNode methodsFor: 'C translation' stamp: 'hg 8/14/2000 15:56'!
asTranslationMethodOfClass: aClass
 
	^ aClass new
		setSelector: selectorOrFalse
		args: arguments
		locals: encoder tempsAndBlockArgs
		block: block
		primitive: primitive;
		comment: comment
! !


!MethodNode methodsFor: 'tiles' stamp: 'di 11/16/2000 23:35'!
asMorphicSyntaxIn: morph
	| header tempMorph selNode |

	selNode _ selectorOrFalse class == SelectorNode 
		ifTrue: [selectorOrFalse] 
		ifFalse: [SelectorNode new key: selectorOrFalse code: nil].
	header _ morph addRow: Color white on: selNode.
	precedence = 1
		ifTrue: [header addToken: self selector type: #keyword1 on: selNode]
		ifFalse: [self selector keywords with: arguments do:
					[:kwd :arg | 
					header addToken: kwd type: #keyword2 on: selNode.
					(arg asMorphicSyntaxIn: header) color: #blockarg2]].
	self addCommentToMorph: morph.
	temporaries size > 0 ifTrue: [
		tempMorph _ morph addRow: #tempVariable on: (MethodTempsNode new).
		temporaries do: [:temp | temp asMorphicSyntaxIn: tempMorph ]
				separatedBy: [tempMorph addMorphBack: (tempMorph transparentSpacerOfSize: 4@4)]].
	(primitive > 0 and: [(primitive between: 255 and: 519) not]) ifTrue:
		["Dont decompile <prim> for, eg, ^ self "
		morph addTextRow: (String streamContents: [ :strm | self printPrimitiveOn: strm])].
	block asMorphicSyntaxIn: morph.
	^ morph
! !

!MethodNode methodsFor: 'tiles' stamp: 'tk 2/3/2001 02:10'!
asMorphicSyntaxUsing: aClass
	
	| morph |
	(morph _ aClass 
		column: #method 
		on: self)
		borderWidth: 0.
	self asMorphicSyntaxIn: morph.
	block _ morph submorphs last.
	block submorphs size = 1 ifTrue: [^ morph].	"keep '^ self' if that is the only thing in method"
	block submorphs last decompile string = '^  self ' ifTrue: [
		block submorphs last delete].
	^ morph! !

!MethodNode methodsFor: 'tiles' stamp: 'RAA 8/20/1999 19:56'!
rawSourceRanges

	self generate: #(0 0 0 0).
	^encoder rawSourceRanges! !
ParseNode subclass: #MethodTempsNode
	instanceVariableNames: 'temporaries '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
AlignmentMorph subclass: #MidiInputMorph
	instanceVariableNames: 'midiPortNumber midiSynth instrumentSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!MidiInputMorph commentStamp: '<historical>' prior: 0!
I am the user interface for a simple software MIDI synthesizer that is driven by external MIDI input. I come with controls for a single MIDI channel (channel 1), but allow channel controls for additional MIDI channels to be added by the user. The volume, pan, and instrument of each channel can be controlled independently.
!


!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 20:05'!
addChannel
	"Add a set of controls for another channel. Prompt the user for the channel number."

	| menu existingChannels newChannel |
	menu _ CustomMenu new.
	existingChannels _ Set new.
	1 to: 16 do: [:ch | (instrumentSelector at: ch) ifNotNil: [existingChannels add: ch]].
	1 to: 16 do: [:ch |
		(existingChannels includes: ch) ifFalse: [
			menu add: ch printString action: ch]].
	newChannel _ menu startUp.
	newChannel ifNotNil: [self addChannelControlsFor: newChannel].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
addChannelControlsFor: channelIndex

	| r divider col |
	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: (self channelNumAndMuteButtonFor: channelIndex).
	r addMorphBack: (Morph new extent: 10@5; color: color).  "spacer"
	r addMorphBack: (self panAndVolControlsFor: channelIndex).

	divider _ AlignmentMorph new
		extent: 10@1;
		borderWidth: 1;
		layoutInset: 0;
		borderColor: #raised;
		color: color;
		hResizing: #spaceFill;
		vResizing: #rigid.

	col _ self lastSubmorph.
	col addMorphBack: divider.
	col addMorphBack: r.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:58'!
atChannel: channelIndex from: aPopUpChoice selectInstrument: selection

	| oldSnd name snd instSelector |
	oldSnd _ midiSynth instrumentForChannel: channelIndex.
	(selection beginsWith: 'edit ') ifTrue: [
		name _ selection copyFrom: 6 to: selection size.
		aPopUpChoice contentsClipped: name.
		(oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) ifTrue: [
			EnvelopeEditorMorph openOn: oldSnd title: name].
		(oldSnd isKindOf: SampledInstrument) ifTrue: [
			EnvelopeEditorMorph openOn: oldSnd allNotes first title: name].
		^ self].

	snd _ nil.
	1 to: instrumentSelector size do: [:i |
		((channelIndex ~= i) and:
		 [(instSelector _ instrumentSelector at: i) notNil and:
		 [selection = instSelector contents]])
			ifTrue: [snd _ midiSynth instrumentForChannel: i]].  "use existing instrument prototype"

	snd ifNil: [
		selection = 'clink'
			ifTrue: [
				snd _ (SampledSound
					samples: SampledSound coffeeCupClink
					samplingRate: 11025) copy]
			ifFalse: [snd _ (AbstractSound soundNamed: selection) copy]].

	midiSynth instrumentForChannel: channelIndex put: snd.
	(instrumentSelector at: channelIndex) contentsClipped: selection.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:19'!
channelNumAndMuteButtonFor: channelIndex

	| muteButton instSelector r |
	muteButton _ SimpleSwitchMorph new
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		offColor: color;
		color: color;
		label: 'Mute';
		target: midiSynth;
		actionSelector: #mutedForChannel:put:;
		arguments: (Array with: channelIndex).
	instSelector _ PopUpChoiceMorph new
		extent: 95@14;
		contentsClipped: 'oboe1';
		target: self;
		actionSelector: #atChannel:from:selectInstrument:;
		getItemsSelector: #instrumentChoicesForChannel:;
		getItemsArgs: (Array with: channelIndex).
	instSelector arguments:
		(Array with: channelIndex with: instSelector).
	instrumentSelector at: channelIndex put: instSelector.

	r _ self makeRow
		hResizing: #rigid;
		vResizing: #spaceFill;
		extent: 70@10.
	r addMorphBack:
		(StringMorph
			contents: channelIndex printString
			font: (TextStyle default fontOfSize: 24)).
	channelIndex < 10
		ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)]  "spacer"
		ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)].  "spacer"
	r addMorphBack: instSelector.
	r addMorphBack: (AlignmentMorph newRow color: color).  "spacer"
	r addMorphBack: muteButton.
	^ r
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 07:33'!
closeMIDIPort

	midiSynth isOn ifTrue: [midiSynth stopMIDITracking].
	midiSynth closeMIDIPort.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 07:55'!
disableReverb: aBoolean

	aBoolean
		ifTrue: [SoundPlayer stopReverb]
		ifFalse: [SoundPlayer startReverb].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:19'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	self layoutInset: 3.
	color _ Color veryLightGray.
	self borderWidth: 2.

	midiPortNumber _ nil.
	midiSynth _ MIDISynth new.
	instrumentSelector _ Array new: 16.

	self removeAllMorphs.
	self addMorphBack: self makeControls.
	self addMorphBack:
		(AlignmentMorph newColumn color: color; layoutInset: 0).
	self addChannelControlsFor: 1.
	self extent: 20@20.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:20'!
instrumentChoicesForChannel: channelIndex

	| names inst |
	names _ AbstractSound soundNames asOrderedCollection.
	names _ names collect: [:n |
		inst _ AbstractSound soundNamed: n.
		(inst isKindOf: UnloadedSound)
			ifTrue: [n, '(out)']
			ifFalse: [n]].
	names add: 'clink'.
	names add: 'edit ', (instrumentSelector at: channelIndex) contents.
	^ names asArray
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'di 11/7/2000 12:22'!
invokeMenu
	"Invoke a menu of additonal commands."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu add: 'add channel' action: #addChannel.
	aMenu add: 'reload instruments' target: AbstractSound selector: #updateScorePlayers.
	midiSynth isOn ifFalse: [
		aMenu add: 'set MIDI port' action: #setMIDIPort.
		midiSynth midiPort
			ifNotNil: [aMenu add: 'close MIDI port' action: #closeMIDIPort]].	
	aMenu invokeOn: self defaultSelection: nil.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:41'!
makeControls

	| b r reverbSwitch onOffSwitch |
	b _ SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2;
		color: color.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (
		b fullCopy
			label: '<>';
			actWhen: #buttonDown;
			actionSelector: #invokeMenu).
	onOffSwitch _ SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'On';
		actionSelector: #toggleOnOff;
		target: self;
		setSwitchState: false.
	r addMorphBack: onOffSwitch.
	reverbSwitch _ SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'Reverb Disable';
		actionSelector: #disableReverb:;
		target: self;
		setSwitchState: SoundPlayer isReverbOn not.
	r addMorphBack: reverbSwitch.
	^ r
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:19'!
makeRow

	^ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:19'!
panAndVolControlsFor: channelIndex

	| volSlider panSlider c r middleLine |
	volSlider _ SimpleSliderMorph new
		color: color;
		extent: 101@2;
		target: midiSynth;
		arguments: (Array with: channelIndex);
		actionSelector: #volumeForChannel:put:;
		minVal: 0.0;
		maxVal: 1.0;
		adjustToValue: (midiSynth volumeForChannel: channelIndex).
	panSlider _ volSlider fullCopy
		actionSelector: #panForChannel:put:;
		minVal: 0.0;
		maxVal: 1.0;		
		adjustToValue: (midiSynth panForChannel: channelIndex).
	c _ AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap.
	middleLine _ Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(panSlider height - 4);
		position: panSlider center x@(panSlider top + 2).
	panSlider addMorphBack: middleLine.
	r _ self makeRow.
	r addMorphBack: (StringMorph contents: '0').
	r addMorphBack: volSlider.
	r addMorphBack: (StringMorph contents: '10').
	c addMorphBack: r.
	r _ self makeRow.
	r addMorphBack: (StringMorph contents: 'L').
	r addMorphBack: panSlider.
	r addMorphBack: (StringMorph contents: 'R').
	c addMorphBack: r.
	^ c
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 07:59'!
setMIDIPort

	| portNum |
	portNum _ SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	midiPortNumber _ portNum.
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 07:23'!
toggleOnOff

	midiSynth isOn
		ifTrue: [
			midiSynth stopMIDITracking]
		ifFalse: [
			midiPortNumber ifNil: [self setMIDIPort].
			midiPortNumber ifNil: [midiPortNumber _ 0].
			midiSynth midiPort: (SimpleMIDIPort openOnPortNumber: midiPortNumber).
			midiSynth startMIDITracking].
! !

!MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'di 11/7/2000 12:56'!
updateInstrumentsFromLibraryExcept: soundsBeingEdited
	"The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."

	"soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor).  If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."

	| unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
	unloadPostfix _ '(out)'.
	myInstruments _ Dictionary new.
	1 to: instrumentSelector size do: [:i |
		name _ (instrumentSelector at: i) contents.
		displaysAsUnloaded _ name endsWith: unloadPostfix.
		displaysAsUnloaded ifTrue: [
			name _ name copyFrom: 1 to: name size - unloadPostfix size].
		(myInstruments includesKey: name) ifFalse: [
			myInstruments at: name put:
				(name = 'clink'
					ifTrue: [
						(SampledSound
							samples: SampledSound coffeeCupClink
							samplingRate: 11025) copy]
					ifFalse: [
						(AbstractSound
							soundNamed: name
							ifAbsent: [
								(instrumentSelector at: i) contentsClipped: 'default'.
								FMSound default]) copy])].
		(soundsBeingEdited includes: (midiSynth instrumentForChannel: i)) ifFalse:
			["Do not update any instrument that is currently being edited"
			midiSynth instrumentForChannel: i put: (myInstruments at: name)].

		"update loaded/unloaded status in instrumentSelector if necessary"
		isUnloaded _ (myInstruments at: name) isKindOf: UnloadedSound.
		(displaysAsUnloaded and: [isUnloaded not])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name].
		(displaysAsUnloaded not and: [isUnloaded])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
! !
Object subclass: #MidiPrimTester
	instanceVariableNames: 'port '
	classVariableNames: 'CanSetClock CanUseSemaphore ClockTicksPerSec EchoOn EventsAvailable FlushDriver HasBuffer HasDurs HasInputClock Installed UseControllerCache Version '
	poolDictionaries: ''
	category: 'System-Serial Port'!
!MidiPrimTester commentStamp: '<historical>' prior: 0!
This class simply demonstrates and tests the MIDI primitives. MIDI applications should use Stephen Pope's MIDIPort class, which will replace this one.

The Macintosh, and perhaps some other platforms, can send and receive MIDI data over a serial port by using an external clock signal supplied by an external MIDI adapter to generate the correct MIDI baud rate. Typical clock speeds of such adapters are 1, 2, or 0.5 MHz. This clock speed can be specified when a MIDI port is opened. On other platforms, this clock speed parameter is ignored.
!


!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 10:30'!
getDriverParameters
	"Return a string that describes this platform's MIDI parameters."
	"MidiPrimTester new getDriverParameters"

	| s parameterNames v |
	parameterNames _ #(Installed Version HasBuffer HasDurs CanSetClock CanUseSemaphore EchoOn UseControllerCache EventsAvailable FlushDriver ClockTicksPerSec HasInputClock).

	s _ WriteStream on: String new.
	s cr.
	1 to: parameterNames size do: [:i |
		v _ self primMIDIParameterGet: i.
		s nextPutAll: (parameterNames at: i).
		s nextPutAll: ' = '.
		s print: v; cr].

	s nextPutAll: 'MIDI Echoing is '.
	(self canTurnOnParameter: EchoOn)
		ifTrue: [s nextPutAll: 'supported.'; cr]
		ifFalse: [s nextPutAll: 'not supported.'; cr].

	s nextPutAll: 'Controller Caching is '.
	(self canTurnOnParameter: UseControllerCache)
		ifTrue: [s nextPutAll: 'supported.'; cr]
		ifFalse: [s nextPutAll: 'not supported.'; cr].

	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:33'!
getInputForSeconds: seconds onPort: portNum
	"Collect MIDI input from the given port for the given number of seconds, and answer a string describing the data read."
	"MidiPrimTester new getInputForSeconds: 5 onPort: 0"

	| buf bufList endTime n midiStartTime s t |
	"collect the data"
	self openPort: portNum andDo: [
		buf _ ByteArray new: 1000.
		bufList _ OrderedCollection new.
		midiStartTime _ self primMIDIGetClock.
		endTime _ Time millisecondClockValue + (seconds * 1000).
		[Time millisecondClockValue < endTime] whileTrue: [
			n _ self primMIDIReadPort: portNum into: buf.
			n > 0 ifTrue: [bufList add: (buf copyFrom: 1 to: n)].
			(Delay forMilliseconds: 5) wait]].

	"format the data into a string"
	s _ WriteStream on: String new.
	s cr.
	bufList do: [:b |
		t _ (self bufferTimeStampFrom: b) - midiStartTime.
		s print: t.
		s nextPutAll: ': '.
		5 to: b size do: [:i | s print: (b at: i); space].
		s cr].
	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 10:05'!
getPortList
	"Return a string that describes this platform's MIDI ports."
	"MidiPrimTester new getPortList"

	| s portCount dir directionString |
	s _ WriteStream on: String new.
	s cr; nextPutAll: 'MIDI Ports:'; cr.
	portCount _ self primMIDIGetPortCount.
	0 to: portCount - 1 do: [:i |
		s tab.
		s print: i; nextPutAll: ': '. 
		s nextPutAll: (self primMIDIGetPortName: i).
		dir _ self primMIDIGetPortDirectionality: i.
		directionString _ dir printString.  "default"
		dir = 1 ifTrue: [directionString _ '(in)'].
		dir = 2 ifTrue: [directionString _ '(out)'].
		dir = 3 ifTrue: [directionString _ '(in/out)'].
		s space; nextPutAll: directionString; cr].
	^ s contents
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 11:24'!
playDrumRoll: mSecsBetweenNotes count: tapCount onPort: portNum
	"MidiPrimTester new playDrumRoll: 75 count: 64 onPort: 0"
	"Play middle-C tapCount times with the given space between notes. This example works best with a short percussive voice, like a drum."
	"Details: This test can be used to investigate the real-time performance of your system. On a 110 MHz PowerPC Mac, this method can genererate very fast and smooth drum rolls up to about 100 beats/sec (10 mSecs between notes). However, many factors can prevent one from seeing this level of performance including a slow CPU, lack of a level-2 cache, networking or other background processes stealing chunks of processor time from Squeak, or a sluggish MIDI synthesizer."
	"Details: By default, this method does an incremental GC on every note. While not really needed for this example, it illustrates a useful technique for real-time processing in Squeak: do an incremental GC when you know you have a few milliseconds of idle time to avoid triggering one during a time-critical task. In this case, we're also using the GC time to provide a small delay between the note-on and note-off events. If the GC time is too short, as it could be on a fast machine, the note may not sound at all unless you add a few milliseconds of additional delay!!"
	"Note: This example works best if the VM's millisecond clock has 1 millisecond resolution."

	| gcDuringNote noteOn noteOff endTime waitTime |
	gcDuringNote _ true.
	"these events use running status, so the command byte is omitted"
	noteOn _ #(60 100) as: ByteArray.
	noteOff _ #(60 0) as: ByteArray.
	self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000.

	"send an initial event with command byte to initiate running status"
	self primMIDIWritePort: portNum from: (#(144 60 0) as: ByteArray) at: 0.

	1 to: tapCount do: [:i |
		endTime _ Time millisecondClockValue + mSecsBetweenNotes.
		self primMIDIWritePort: portNum from: noteOn at: 0.
		gcDuringNote
			ifTrue: [
				"do quick GC; takes a few milliseconds and provides the note-down time"
				"Note: if GC is too fast on your machine, you need to add a few mSecs delay!!"
				Smalltalk garbageCollectMost]
			ifFalse: [(Delay forMilliseconds: 3) wait].

		self primMIDIWritePort: portNum from: noteOff at: 0.
		waitTime _ endTime - Time millisecondClockValue.
		waitTime > 0 ifTrue: [(Delay forMilliseconds: waitTime) wait]].

	self primMIDIClosePort: portNum.
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:16'!
playNoteOnPort: portNum
	"MidiPrimTester new playNoteOnPort: 0"

	| noteOn noteOff bytesWritten |
	noteOn _ #(144 60 100) as: ByteArray.
	noteOff _ #(144 60 0) as: ByteArray.
	self openPort: portNum andDo: [
		bytesWritten _ self primMIDIWritePort: portNum from: noteOn at: 0.
		(Delay forMilliseconds: 500) wait.
		bytesWritten _ bytesWritten + (self primMIDIWritePort: portNum from: noteOff at: 0)].

	bytesWritten = 6 ifFalse: [self error: 'not all bytes were sent'].
! !

!MidiPrimTester methodsFor: 'tests' stamp: 'jm 5/18/1998 15:17'!
playScale: mSecsPerNote onPort: portNum
	"MidiPrimTester new playScale: 130 onPort: 0"

	| noteOn noteOff |
	noteOn _ #(144 0 100) as: ByteArray.
	noteOff _ #(144 0 0) as: ByteArray.
	self openPort: portNum andDo: [
		#(60 62 64 65 67 69 71 72 74 72 71 69 67 65 64 62 60) do: [:midiKey | 
			noteOn at: 2 put: midiKey.
			noteOff at: 2 put: midiKey.
			self primMIDIWritePort: portNum from: noteOn at: 0.
			(Delay forMilliseconds: mSecsPerNote - 10) wait.
			self primMIDIWritePort: portNum from: noteOff at: 0.
			(Delay forMilliseconds: 10) wait]].
! !


!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIClosePort: portNum

	<primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetClock

	<primitive: 'primitiveMIDIGetClock' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortCount

	<primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortDirectionality: portNum

	<primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIGetPortName: portNum

	<primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate
	"Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms."

	<primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIParameterGet: whichParameter

	<primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIParameterSet: whichParameter to: newValue

	<primitive: 'primitiveMIDIParameterGetOrSet' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIReadPort: portNum into: byteArray

	<primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!MidiPrimTester methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIWritePort: portNum from: byteArray at: midiClockValue

	<primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'>
	self primitiveFailed.
! !


!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'!
bufferTimeStampFrom: aByteArray
	"Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long."

	^ ((aByteArray at: 1) bitShift: 24) +
	  ((aByteArray at: 2) bitShift: 16) +
	  ((aByteArray at: 3) bitShift: 8) +
	   (aByteArray at: 4)
! !

!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 12:48'!
canTurnOnParameter: whichParameter
	"Return true if the given MIDI parameter can be turned on. Leave the parameter in its orginal state."

	| old canSet |
	old _ self primMIDIParameterGet: whichParameter.
	self primMIDIParameterSet: whichParameter to: 1.
	canSet _ (self primMIDIParameterGet: whichParameter) = 1.
	self primMIDIParameterSet: whichParameter to: old.
	^ canSet
! !

!MidiPrimTester methodsFor: 'private' stamp: 'jm 5/18/1998 15:32'!
openPort: portNum andDo: aBlock
	"Open the given MIDI port, evaluate the block, and close the port again. Answer the value of the block."

	| result |
	self primMIDIClosePort: portNum.
	self primMIDIOpenPort: portNum readSemaIndex: 0 interfaceClockRate: 1000000.
	result _ aBlock value.
	self primMIDIClosePort: portNum.
	^ result
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MidiPrimTester class
	instanceVariableNames: ''!

!MidiPrimTester class methodsFor: 'class initialization' stamp: 'jm 5/18/1998 09:50'!
initialize
	"Initialize the MIDI parameter constants."
	"MidiPrimTester initialize"

	Installed _ 1.
		"Read-only. Return 1 if a MIDI driver is installed, 0 if not.
		 On OMS-based MIDI drivers, this returns 1 only if the OMS
		 system is properly installed and configured."

	Version _ 2.
		"Read-only. Return the integer version number of this MIDI driver.
		 The version numbering sequence is relative to a particular driver.
		 That is, version 3 of the Macintosh MIDI driver is not necessarily
		 related to version 3 of the Win95 MIDI driver."

	HasBuffer _ 3.
		"Read-only. Return 1 if this MIDI driver has a time-stamped output
		 buffer, 0 otherwise. Such a buffer allows the client to schedule
		 MIDI output packets to be sent later. This can allow more precise
		 timing, since the driver uses timer interrupts to send the data
		 at the right time even if the processor is in the midst of a
		 long-running Squeak primitive or is running some other application
		 or system task."

	HasDurs _ 4.
		"Read-only. Return 1 if this MIDI driver supports an extended
		 primitive for note-playing that includes the note duration and
		 schedules both the note-on and the note-off messages in the
		 driver. Otherwise, return 0."

	CanSetClock _ 5.
		"Read-only. Return 1 if this MIDI driverÕs clock can be set
		 via an extended primitive, 0 if not."

	CanUseSemaphore _ 6.
		"Read-only. Return 1 if this MIDI driver can signal a semaphore
		 when MIDI input arrives. Otherwise, return 0. If this driver
		 supports controller caching and it is enabled, then incoming
		 controller messages will not signal the semaphore."

	EchoOn _ 7.
		"Read-write. If this flag is set to a non-zero value, and if
		 the driver supports echoing, then incoming MIDI events will
		 be echoed immediately. If this driver does not support echoing,
		 then queries of this parameter will always return 0 and
		 attempts to change its value will do nothing."

	UseControllerCache _ 8.
		"Read-write. If this flag is set to a non-zero value, and if
		 the driver supports a controller cache, then the driver will
		 maintain a cache of the latest value seen for each MIDI controller,
		 and control update messages will be filtered out of the incoming
		 MIDI stream. An extended MIDI primitive allows the client to
		 poll the driver for the current value of each controller. If
		 this driver does not support a controller cache, then queries
		 of this parameter will always return 0 and attempts to change
		 its value will do nothing."

	EventsAvailable _ 9.
		"Read-only. Return the number of MIDI packets in the input queue."

	FlushDriver _ 10.
		"Write-only. Setting this parameter to any value forces the driver
		 to flush its I/0 buffer, discarding all unprocessed data. Reading
		 this parameter returns 0. Setting this parameter will do nothing
		 if the driver does not support buffer flushing."

	ClockTicksPerSec _ 11.
		"Read-only. Return the MIDI clock rate in ticks per second."

	HasInputClock _ 12.
		"Read-only. Return 1 if this MIDI driver timestamps incoming
		 MIDI data with the current value of the MIDI clock, 0 otherwise.
		 If the driver does not support such timestamping, then the
		 client must read input data frequently and provide its own
		 timestamping."
! !
Object subclass: #MimeConverter
	instanceVariableNames: 'dataStream mimeStream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'!
dataStream
	^dataStream! !

!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
dataStream: anObject
	dataStream _ anObject! !

!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'!
mimeStream
	^mimeStream! !

!MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
mimeStream: anObject
	mimeStream _ anObject! !


!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:30'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream"

	self subclassResponsibility! !

!MimeConverter methodsFor: 'conversion' stamp: 'bf 11/12/1998 13:31'!
mimeEncode
	"Do conversion reading from dataStream writing to mimeStream"

	self subclassResponsibility! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MimeConverter class
	instanceVariableNames: ''!

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:47'!
forEncoding: encodingString
	"Answer a converter class for the given encoding or nil if unknown"
	encodingString ifNil: [^nil].
	^ encodingString asLowercase caseOf: 
		{ ['base64'] -> [Base64MimeConverter].
		  ['quoted-printable'] -> [QuotedPrintableMimeConverter]}
		otherwise: [].
! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:43'!
mimeDecode: aStringOrStream as: contentsClass
	^ contentsClass streamContents: [:out |
		self mimeDecode: aStringOrStream to: out]! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeDecode: aStringOrStream to: outStream
	self new
		mimeStream: (aStringOrStream isStream
			ifTrue: [aStringOrStream]
			ifFalse: [ReadStream on: aStringOrStream]);
		dataStream: outStream;
		mimeDecode! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeEncode: aCollectionOrStream
	^ String streamContents: [:out |
		self mimeEncode: aCollectionOrStream to: out]! !

!MimeConverter class methodsFor: 'convenience' stamp: 'bf 3/10/2000 14:40'!
mimeEncode: aCollectionOrStream to: outStream
	self new
		dataStream: (aCollectionOrStream isStream
			ifTrue: [aCollectionOrStream]
			ifFalse: [ReadStream on: aCollectionOrStream]);
		mimeStream: outStream;
		mimeEncode! !
InterpreterPlugin subclass: #MiscPrimitivePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MiscPrimitivePlugin class
	instanceVariableNames: ''!

!MiscPrimitivePlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 17:21'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"MiscPrimitivePlugin translateLocally"
	| code |
	code _ cg codeStringForPrimitives: self translatedPrimitives.
	self storeString: code onFileNamed: fullName.! !

!MiscPrimitivePlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 16:14'!
translatedPrimitives
	"an assorted list of various primitives"
	^#(
		(Bitmap compress:toByteArray:)
		(Bitmap decompress:fromByteArray:at:)
		(Bitmap encodeBytesOf:in:at:)
		(Bitmap encodeInt:in:at:)
		(String compare:with:collated:)
		(String translate:from:to:table:)	
		(String findFirstInString:inSet:startingAt:)
		(String indexOfAscii:inString:startingAt:)
		(String findSubstring:in:startingAt:matchTable:)
		(SampledSound convert8bitSignedFrom:to16Bit:)
	)
! !
AbstractSound subclass: #MixedSound
	instanceVariableNames: 'sounds leftVols rightVols soundDone '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!MixedSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:57'!
initialize

	super initialize.
	sounds _ Array new.
	leftVols _ Array new.
	rightVols _ Array new.
! !


!MixedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:05'!
duration
	"Answer the duration of this sound in seconds."

	| dur |
	dur _ 0.
	sounds do: [:snd | dur _ dur max: snd duration].
	^ dur
! !

!MixedSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:37'!
sounds

	^ sounds
! !


!MixedSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'!
doControl

	super doControl.
	1 to: sounds size do: [:i | (sounds at: i) doControl].
! !

!MixedSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 13:42'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."

	| snd left right |
	1 to: sounds size do: [:i |
		(soundDone at: i) ifFalse: [
			snd _ sounds at: i.
			left _ (leftVol * (leftVols at: i)) // ScaleFactor.
			right _ (rightVol * (rightVols at: i)) // ScaleFactor.
			snd samplesRemaining > 0
				ifTrue: [
					snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
				ifFalse: [soundDone at: i put: true]]].
! !

!MixedSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 17:07'!
reset

	super reset.
	sounds do: [:snd | snd reset].
	soundDone _ (Array new: sounds size) atAllPut: false.
! !

!MixedSound methodsFor: 'sound generation' stamp: 'jm 12/8/97 17:08'!
samplesRemaining

	| remaining r |
	remaining _ 0.
	1 to: sounds size do: [:i |
		r _ (sounds at: i) samplesRemaining.
		r > remaining ifTrue: [remaining _ r]].

	^ remaining
! !

!MixedSound methodsFor: 'sound generation' stamp: 'jm 1/10/1999 08:45'!
stopGracefully
	"End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."

	super stopGracefully.
	sounds do: [:s | s stopGracefully].
! !


!MixedSound methodsFor: 'composition'!
+ aSound
	"Return the mix of the receiver and the argument sound."

	^ self add: aSound
! !

!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'!
add: aSound
	"Add the given sound with a pan setting of centered and no attenuation."

	self add: aSound pan: 0.5 volume: 1.0.
! !

!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 13:47'!
add: aSound pan: leftRightPan
	"Add the given sound with the given left-right panning and no attenuation."

	self add: aSound pan: leftRightPan volume: 1.0.
! !

!MixedSound methodsFor: 'composition' stamp: 'jm 1/5/98 17:33'!
add: aSound pan: leftRightPan volume: volume
	"Add the given sound with the given left-right pan, where 0.0 is full left, 1.0 is full right, and 0.5 is centered. The loudness of the sound will be scaled by volume, which ranges from 0 to 1.0."

	| pan vol |
	pan _ ((leftRightPan * ScaleFactor) asInteger max: 0) min: ScaleFactor.
	vol _ ((volume * ScaleFactor) asInteger max: 0) min: ScaleFactor.
	sounds _ sounds copyWith: aSound.
	leftVols _ leftVols copyWith: ((ScaleFactor - pan) * vol) // ScaleFactor.
	rightVols _ rightVols copyWith: (pan * vol) // ScaleFactor.
! !


!MixedSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!MixedSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:33'!
copySounds
	"Private!! Support for copying. Copy my component sounds and settings array."

	sounds _ sounds collect: [:s | s copy].
	leftVols _ leftVols copy.
	rightVols _ rightVols copy.
! !
Controller subclass: #ModalController
	instanceVariableNames: 'modeActive '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!ModalController commentStamp: '<historical>' prior: 0!
I am a controller that puts the poor user into a mode by not relinquishing control. However, I do pass control onto my underlings. Some underling is expected to end the mode by sending me 'close'. Watch out Larry Tesler, the mode lives on...
!


!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:05'!
close
	"This is how we leave the mode." 

	modeActive _ false.
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:02'!
controlInitialize

	modeActive _ true.
	^ super controlInitialize
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:00'!
isControlActive

	^ modeActive
! !

!ModalController methodsFor: 'as yet unclassified' stamp: 'jm 5/1/1998 07:00'!
isControlWanted

	^ modeActive
! !
StandardSystemView subclass: #ModalSystemWindowView
	instanceVariableNames: 'modalBorder '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!ModalSystemWindowView commentStamp: '<historical>' prior: 0!
I am a view for a Modal System Window.  I vary from StandardSystemView, of which I am a subclass in a few ways:

	(1) I use ModalController as my default controller;
	(2) When asked to update with the symbol #close, I direct the controller to close;
	(3) I display a slightly different title bar with no control boxes.!


!ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/18/2000 20:41'!
borderWidth: anObject

	modalBorder _ false.
	^super borderWidth: anObject! !

!ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 00:50'!
initialize 
	"Refer to the comment in View|initialize."
	super initialize.
	self borderWidth: 5.
	self noLabel.
	modalBorder _ true.! !


!ModalSystemWindowView methodsFor: 'modal dialog' stamp: 'acg 2/18/2000 23:47'!
doModalDialog

	| savedArea |
	self resizeInitially.
	self resizeTo: 
		((self windowBox)
			align: self windowBox center
			with: Display boundingBox aboveCenter).
	savedArea _ Form fromDisplay: self windowBox.
	self display.
	self controller startUp.
	self release.
	savedArea displayOn: Display at: self windowOrigin.
! !


!ModalSystemWindowView methodsFor: 'controller access' stamp: 'acg 2/9/2000 00:58'!
defaultControllerClass

	^ModalController! !


!ModalSystemWindowView methodsFor: 'label access' stamp: 'acg 2/9/2000 08:35'!
backgroundColor
	^Color lightYellow! !


!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/18/2000 20:24'!
display

	super display.
	self displayLabelBackground: false.
	self displayLabelText.
! !

!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/19/2000 00:59'!
displayBorder
	"Display the receiver's border (using the receiver's borderColor)."

	modalBorder ifFalse: [^super displayBorder].

	Display
		border: self displayBox
		widthRectangle: (1@1 corner: 2@2)
		rule: Form over
		fillColor: Color black.
	Display
		border: (self displayBox insetBy: (1@1 corner: 2@2))
		widthRectangle: (4@4 corner: 3@3)
		rule: Form over
		fillColor: (Color r: 16rEA g: 16rEA b: 16rEA).
! !

!ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/9/2000 07:21'!
displayLabelBoxes
	"Modal dialogs don't have closeBox or growBox."
! !


!ModalSystemWindowView methodsFor: 'model access' stamp: 'acg 2/9/2000 00:57'!
update: aSymbol
	aSymbol = #close
		ifTrue: [^self controller close].
	^super update: aSymbol! !
Object subclass: #Model
	instanceVariableNames: 'dependents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Model commentStamp: '<historical>' prior: 0!
Provides a superclass for classes that function as models.  The only behavior provided is fast dependents maintentance, which bypasses the generic DependentsFields mechanism.  1/23/96 sw!


!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:26'!
canDiscardEdits
	"Answer true if none of the views on this model has unaccepted edits that matter."

	dependents ifNil: [^ true].
	^ super canDiscardEdits
! !

!Model methodsFor: 'dependents' stamp: 'sw 1/9/2001 12:46'!
containingWindow
	"Answer the window that holds the receiver.  The dependents technique is odious and may not be airtight, if multiple windows have the same model."

	^ self dependents detect:
		[:d | (d isKindOf: SystemWindow orOf: StandardSystemView) and: [d model == self]] ifNone: [nil]! !

!Model methodsFor: 'dependents' stamp: 'jm 3/24/98 15:12'!
hasUnacceptedEdits
	"Answer true if any of the views on this model has unaccepted edits."

	dependents == nil ifTrue: [^ false].
	^ super hasUnacceptedEdits
! !

!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'!
myDependents
	^ dependents! !

!Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'!
myDependents: aCollectionOrNil
	dependents _ aCollectionOrNil! !

!Model methodsFor: 'dependents' stamp: 'sma 4/30/2000 09:59'!
topView
	"Find the first top view on me. Is there any danger of their being two with the same model?  Any danger from ungarbage collected old views?  Ask if schedulled?"

	dependents ifNil: [^ nil].
	Smalltalk isMorphic ifTrue: [
		dependents do:
			[:v | ((v isKindOf: SystemWindow) and: [v isInWorld]) ifTrue: [^ v]].
		^ nil].
	dependents do: [:v | v superView ifNil: [v model == self ifTrue: [^ v]]].
	^ nil
! !


!Model methodsFor: 'text links' stamp: 'di 1/15/98 23:32'!
linkMethod: classAndMethod
	"Make a linked message list and put this method in it"
	| list |
	list _ OrderedCollection new.
	list add: classAndMethod.
	LinkedMessageSet openMessageList: list name: 'Linked by HyperText'.! !


!Model methodsFor: 'menus' stamp: 'di 4/11/98 11:34'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked." 

	"default is that the editor does all"
	^ otherTarget perform: selector.! !

!Model methodsFor: 'menus' stamp: 'tk 4/17/1998 17:28'!
selectedClass
	"All owners of TextViews are asked this during a doIt"
	^ nil! !

!Model methodsFor: 'menus' stamp: 'di 4/17/1998 08:29'!
step
	"Default for moephic models is no-op"! !

!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'!
trash
	"What should be displayed if a trash pane is restored to initial state"

	^ ''! !

!Model methodsFor: 'menus' stamp: 'sw 12/15/2000 13:21'!
trash: ignored
	"Whatever the user submits to the trash, it need not be saved."

	^ true! !


!Model methodsFor: 'keyboard' stamp: 'sw 1/29/2001 00:54'!
arrowKey: aChar from: view
	"Process the up and down arrows in a list pane.  Note that the listView tells us what index variable, how to get the list, and how to move the index.  Derived from a Martin Pammer submission, 02/98"

     | keyEvent oldSelection nextSelection max min howMany anEvent |

	(#(1 4 11 12 30 31) includes: (keyEvent _ aChar asciiValue)) ifFalse:
		[(Smalltalk isMorphic and: [false]) ifTrue:
			[((anEvent _ view currentEvent) isKindOf: KeyboardEvent) ifTrue: [self currentWorld keystrokeInWorld: anEvent]].
			self flag: #deferred.
			"Would like to pass all command-keys that pass through the hands of the model via this protocol but are not in fact interecepted here on to the desktop, where they might be quite relevant.  But when we obtain the event this way we are not getting the keyboard event"
			^ self].

     oldSelection := view getCurrentSelectionIndex.
     nextSelection := oldSelection.
     max := view maximumSelection.
     min := view minimumSelection.
     howMany := view numSelectionsInView.	"get this exactly??"

     keyEvent == 31 ifTrue:
		["down-arrow; move down one, wrapping to top if needed"
		nextSelection := oldSelection + 1.
		nextSelection > max ifTrue: [nextSelection _ 1]].

     keyEvent == 30 ifTrue:
		["up arrow; move up one, wrapping to bottom if needed"
		nextSelection := oldSelection - 1.
		nextSelection < 1 ifTrue: [nextSelection _ max]].

     keyEvent == 1  ifTrue: [nextSelection := 1].  "home"
     keyEvent == 4  ifTrue: [nextSelection := max].   "end"
     keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection - howMany)].  "page up"
     keyEvent == 12  ifTrue: [nextSelection := (oldSelection + howMany) min: max].  "page down"
     nextSelection = oldSelection  ifFalse:
		[self okToChange
			ifTrue:
				[view changeModelSelection: nextSelection.
				"view controller moveMarker"]]
			! !
Date subclass: #Month
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Magnitudes'!

!Month methodsFor: 'converting' stamp: 'LC 7/26/1998 12:49'!
asDate
	^ Date
		newDay: 1
		month: self name
		year: self year! !

!Month methodsFor: 'converting' stamp: 'LC 7/26/1998 12:53'!
next
	^ self class fromDate: (self addDays: self duration)! !

!Month methodsFor: 'converting' stamp: 'LC 7/26/1998 02:43'!
previous
	^ self class fromDate: (self subtractDays: 1)
! !


!Month methodsFor: 'inquiries' stamp: 'LC 7/27/1998 04:38'!
duration
	^ self daysInMonth! !

!Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 02:53'!
firstDate
	^ self asDate! !

!Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:51'!
index
	^ self monthIndex! !

!Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:52'!
lastDate
	^ self firstDate addDays: self duration - 1! !

!Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:50'!
name
	^ self monthName! !


!Month methodsFor: 'enumerationg' stamp: 'LC 7/27/1998 04:36'!
eachWeekDo: aBlock
	| week |
	week _ self firstDate week.
	[week firstDate <= self lastDate]
		whileTrue:
			[aBlock value: week.
			week _ week next]! !


!Month methodsFor: 'printing' stamp: 'LC 7/26/1998 02:24'!
printOn: aStream
	aStream nextPutAll: self monthName, ' ', self year printString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Month class
	instanceVariableNames: ''!

!Month class methodsFor: 'instance creation' stamp: 'LC 7/26/1998 12:47'!
fromDate: aDate
	^ self
		newDay: 1
		month: aDate monthName
		year: aDate year! !

!Month class methodsFor: 'instance creation' stamp: 'LC 7/26/1998 12:48'!
readFrom: aStream
	| m y c |
	m _ (ReadWriteStream with: '') reset.
	[(c _ aStream next) isSeparator] whileFalse: [m nextPut: c].
	[(c _ aStream next) isSeparator] whileTrue.
	y _ (ReadWriteStream with: '') reset.
		y nextPut: c.
	[aStream atEnd] whileFalse: [y nextPut: aStream next].
	^ self fromDate: (Date newDay: 1 month: m contents asSymbol year: y contents asNumber)

	"
	Month readFrom: (ReadWriteStream with: 'July 1998') reset
	"! !
AlignmentMorph subclass: #MonthMorph
	instanceVariableNames: 'month todayCache tileRect model '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!MonthMorph methodsFor: 'initialization' stamp: 'di 9/24/2000 12:15'!
highlightToday

	todayCache _ Date today.
	self allMorphsDo:
		[:m | (m isKindOf: SimpleSwitchMorph) ifTrue:
				[(m arguments isEmpty not and: [m arguments first = todayCache])
					ifTrue: [m borderWidth: 2; borderColor: Color yellow]
					ifFalse: [m borderWidth: 1; setSwitchState: m color = m onColor]]].

! !

!MonthMorph methodsFor: 'initialization' stamp: 'ar 12/15/2000 00:10'!
initialize
	super initialize.
	tileRect _ 0@0 extent: 23@19.
	self layoutInset: 1;
		color: Color red;
		listDirection: #topToBottom;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		month: Date today month.
	self rubberBandCells: false.
	self extent: 160@130.! !

!MonthMorph methodsFor: 'initialization' stamp: 'ar 12/15/2000 00:17'!
initializeHeader
	| title sep  frame button monthName |
	title _ (self findA: WeekMorph) title.
	title hResizing: #spaceFill.
	"should be done by WeekMorph but isn't"
	title submorphsDo:[:m| m hResizing: #spaceFill].
	monthName _ month name.
	self width < 160 ifTrue:
		[(#(6 7 9) includes: month index)
			ifTrue: [monthName _ monthName copyFrom: 1 to: 4]
			ifFalse: [monthName _ monthName copyFrom: 1 to: 3]].
	sep _ Morph new color: Color transparent; extent: title width @ 1.
	self
		addMorph: sep;
		addMorph: title;
		addMorph: sep copy.
	button _ SimpleButtonMorph new
				target: self;
				actWhen: #whilePressed;
				color: (Color r: 0.8 g: 0.8 b: 0.8).
	frame _ AlignmentMorph new
		color: Color transparent;
		listDirection: #leftToRight;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		layoutInset: 0.
	frame
		addMorph:
			(button
				label: '>>';
				actionSelector: #nextYear;
				width: 15);
		addMorph:
			(button copy
				label: '>';
				actionSelector: #next;
				width: 15);
		addMorph:
			((AlignmentMorph new
				color: Color transparent;
				listDirection: #topToBottom;
				"hResizing: #shrinkWrap;"
				wrapCentering: #center; cellPositioning: #topCenter;
				extent: (title fullBounds width - (button width * 3)) @ title height)
				addMorph:
					(StringMorph new
						contents:
							monthName, ' ', month year printString));
		addMorph:
			(button copy
				label: '<';
				actionSelector: #previous;
				width: 15);
		addMorph:
			(button copy
				label: '<<';
				actionSelector: #previousYear;
				width: 15).
	self addMorph: frame! !

!MonthMorph methodsFor: 'initialization' stamp: 'ar 12/15/2000 00:08'!
initializeWeeks
	| weeks firstWeek lastWeek |
	self removeAllMorphs.
	weeks _ OrderedCollection new.
	(firstWeek _ month firstDate week) asDate dayOfMonth = 1 ifTrue:
		["If the entire first week is this month, then insert prior week"
		weeks add: (WeekMorph newWeek: firstWeek previous month: month tileRect: tileRect model: model)].
	month eachWeekDo:
		[:each |
		weeks add: (WeekMorph newWeek: (lastWeek _ each) month: month tileRect: tileRect model: model)].
	weeks size < 6 ifTrue:
		["If there's room at the bottom, add another week of next month."
		weeks add: (WeekMorph newWeek: lastWeek next month: month tileRect: tileRect model: model)].
	weeks reverseDo: [:each | 
		each hResizing: #spaceFill; vResizing: #spaceFill.
		"should be done by WeekMorph but isn't"
		each submorphsDo:[:m| m hResizing: #spaceFill; vResizing: #spaceFill].
		self addMorph: each].
	self initializeHeader.
	self highlightToday

! !

!MonthMorph methodsFor: 'initialization' stamp: 'dhhi 9/14/2000 14:19'!
model: aModel

	model _ aModel! !


!MonthMorph methodsFor: 'access' stamp: 'dhhi 9/18/2000 11:05'!
month
	^ month! !

!MonthMorph methodsFor: 'access' stamp: 'LC 7/27/1998 23:08'!
selectedDates
	| answer |
	answer _ SortedCollection new.
	self submorphsDo:
		[:each |
		(each isKindOf: WeekMorph) ifTrue: [answer addAll: each selectedDates]].
	^ answer ! !



!MonthMorph methodsFor: 'controls' stamp: 'di 6/5/2000 10:21'!
chooseYear

	| newYear yearString |
	newYear _ (SelectionMenu selections: {'today'} , (month year - 5 to: month year + 5) , {'other...'}) startUpWithCaption: 'Choose another year'.
	newYear ifNil: [^ self].
	newYear isNumber ifTrue:
		[^ self month: (Month newDay: 1 month: month monthName year: newYear)].
	newYear = 'today' ifTrue:
		[^ self month: (Month fromDate: Date today)].
	yearString _ FillInTheBlank request: 'Type in a year' initialAnswer: Date today year asString.
	yearString ifNil: [^ self].
	newYear _ yearString asNumber.
	(newYear between: 0 and: 9999) ifTrue:
		[^ self month: (Month newDay: 1 month: month monthName year: newYear)].
! !

!MonthMorph methodsFor: 'controls' stamp: 'di 9/24/2000 22:46'!
month: aMonth
	month _ aMonth.
	model ifNotNil: [model setDate: nil fromButton: nil down: false].
	self initializeWeeks! !

!MonthMorph methodsFor: 'controls' stamp: 'LC 7/27/1998 04:52'!
next
	self month: month next! !

!MonthMorph methodsFor: 'controls' stamp: 'di 6/5/2000 10:29'!
nextYear
	self month: (Month newDay: 1 month: month monthName year: month year + 1)
! !

!MonthMorph methodsFor: 'controls' stamp: 'LC 7/27/1998 04:53'!
previous
	self month: month previous! !

!MonthMorph methodsFor: 'controls' stamp: 'di 6/5/2000 10:29'!
previousYear
	self month: (Month newDay: 1 month: month monthName year: month year - 1)
! !

!MonthMorph methodsFor: 'controls' stamp: 'sge 5/19/2000 20:43'!
startMondayOrSundayString
	^ Week startMonday
		ifTrue: ['start Sunday']
		ifFalse: ['start Monday']! !

!MonthMorph methodsFor: 'controls' stamp: 'sge 5/18/2000 06:00'!
toggleStartMonday
	Week toggleStartMonday.
	self initializeWeeks
! !


!MonthMorph methodsFor: 'stepping' stamp: 'di 12/21/2000 13:41'!
step

	todayCache = Date today
		ifFalse: [self highlightToday  "Only happens once a day"]! !

!MonthMorph methodsFor: 'stepping' stamp: 'di 9/24/2000 12:21'!
stepTime
	"Only time stepping matters is when you start up an image where an old date is selected"

	^ 3000  "Three seconds should be good enough response"! !


!MonthMorph methodsFor: 'all' stamp: 'di 6/5/2000 09:31'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu 
		addLine;
		addUpdating: #startMondayOrSundayString action: #toggleStartMonday;
		add: 'jump to year...' action: #chooseYear.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MonthMorph class
	instanceVariableNames: ''!

!MonthMorph class methodsFor: 'as yet unclassified' stamp: 'di 12/21/2000 15:19'!
newWithModel: aModel
	^ (self basicNew model: aModel) initialize! !
GesturalEvent subclass: #MoodGesturalEvent
	instanceVariableNames: 'state '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!MoodGesturalEvent methodsFor: 'accessing' stamp: 'len 9/7/1999 02:22'!
state
	^ state! !

!MoodGesturalEvent methodsFor: 'accessing' stamp: 'len 9/12/1999 05:03'!
state: aSymbol
	state _ aSymbol asSymbol! !


!MoodGesturalEvent methodsFor: 'playing' stamp: 'len 9/7/1999 02:23'!
actOn: aHeadMorph
	aHeadMorph face perform: self state! !


!MoodGesturalEvent methodsFor: 'printing' stamp: 'len 9/7/1999 02:26'!
printOn: aStream
	aStream nextPutAll: 'set ', self state, ' mood'! !
Object subclass: #Morph
	instanceVariableNames: 'bounds owner submorphs fullBounds color extension '
	classVariableNames: 'EmptyArray '
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!Morph commentStamp: '<historical>' prior: 0!
A morph (from the Greek "shape" or "form") is an interactive graphical object.

All morphs owned by a morph are held in submorphs.  

All coordinates are global screen coordinates.  (Except those that are flexed, contained inside a FlexMorph.)

All show on the screen unless they are 'hidden'.  Hidden morphs have the property #hidden set to true.!


!Morph methodsFor: 'initialization' stamp: 'sw 10/2/97 23:08'!
initialExtent
	| ext |
	(ext _ self valueOfProperty: #initialExtent)
		ifNotNil:
			[^ ext].
	^ super initialExtent! !

!Morph methodsFor: 'initialization' stamp: 'ar 6/25/1999 11:12'!
initialize

	bounds _ 0@0 corner: 50@40.
	owner _ nil.
	submorphs _ EmptyArray.
	color _ self defaultColor.
! !

!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:57'!
intoWorld: aWorld
	"The receiver has just appeared in a new world. Note:
		* aWorld can be nil (due to optimizations in other places)
		* owner is already set
		* owner's submorphs may not include receiver yet.
	Important: Keep this method fast - it is run whenever morphs are added."
	aWorld ifNil:[^self].
	self wantsSteps ifTrue:[aWorld startStepping: self].
	self submorphsDo:[:m| m intoWorld: aWorld].
! !

!Morph methodsFor: 'initialization' stamp: 'RAA 10/18/2000 12:33'!
openCenteredInWorld

	self 
		fullBounds;
		position: Display extent - self extent // 2;
		openInWorld.! !

!Morph methodsFor: 'initialization' stamp: 'sw 3/21/2000 14:46'!
openInHand
	"Attach the receiver to the current hand in the current morphic world"

	self currentHand attachMorph: self! !

!Morph methodsFor: 'initialization' stamp: 'jm 7/5/1998 12:40'!
openInMVC

	MorphWorldView
		openWorldWith: self
		labelled: self defaultLabelForInspector.
! !

!Morph methodsFor: 'initialization' stamp: 'djp 10/24/1999 17:13'!
openInWindow

	^self openInWindowLabeled: self defaultLabelForInspector
! !

!Morph methodsFor: 'initialization' stamp: 'sma 4/22/2000 20:28'!
openInWindowLabeled: aString

	^self openInWindowLabeled: aString inWorld: self currentWorld! !

!Morph methodsFor: 'initialization' stamp: 'RAA 5/25/2000 08:12'!
openInWindowLabeled: aString inWorld: aWorld

	| window extent |

	window _ (SystemWindow labelled: aString) model: nil.
	window 
		" guess at initial extent"
		bounds:  (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld);
		addMorph: self frame: (0@0 extent: 1@1);
		updatePaneColors.
	" calculate extent after adding in case any size related attributes were changed.  Use
	fullBounds in order to trigger re-layout of layout morphs"
	extent _ self fullBounds extent + 
			(window borderWidth@window labelHeight) + window borderWidth.
	window extent: extent.
	aWorld addMorph: window.
	window activate.
	aWorld startSteppingSubmorphsOf: window.
	^window
! !

!Morph methodsFor: 'initialization' stamp: 'RAA 6/14/2000 18:09'!
openInWorld
        "Add this morph to the world.  If in MVC, then provide a Morphic window for it."

        self couldOpenInMorphic
                ifTrue: [self openInWorld: self currentWorld]
                ifFalse: [self openInMVC]! !

!Morph methodsFor: 'initialization' stamp: 'bf 1/5/2000 19:57'!
openInWorld: aWorld
	"Add this morph to the requested World."
	(aWorld viewBox origin ~= (0@0) and: [self position = (0@0)]) ifTrue:
		[self position: aWorld viewBox origin].
	aWorld addMorph: self.
	aWorld startSteppingSubmorphsOf: self! !

!Morph methodsFor: 'initialization' stamp: 'ar 1/31/2001 13:58'!
outOfWorld: aWorld
	"The receiver has just appeared in a new world. Notes:
		* aWorld can be nil (due to optimizations in other places)
		* owner is still valid
	Important: Keep this method fast - it is run whenever morphs are removed."
	aWorld ifNil:[^self].
	"ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself."
	"aWorld stopStepping: self."
	self submorphsDo:[:m| m outOfWorld: aWorld].
! !

!Morph methodsFor: 'initialization' stamp: 'sw 9/11/1998 11:13'!
standardPalette
	"Answer a standard palette forced by some level of enclosing presenter, or nil if none"
	| pal aPresenter itsOwner |
	(aPresenter _ self presenter) ifNil: [^ nil].
	^ (pal _ aPresenter ownStandardPalette)
		ifNotNil: [pal]
		ifNil:	[(itsOwner _ aPresenter associatedMorph owner)
					ifNotNil:
						[itsOwner standardPalette]
					ifNil:
						[nil]]! !


!Morph methodsFor: 'classification' stamp: 'di 5/7/1998 01:21'!
isAlignmentMorph

	^ false! !

!Morph methodsFor: 'classification' stamp: 'ar 9/15/2000 17:56'!
isBalloonHelp
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:52'!
isFlap
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:54'!
isFlapOrTab
	^self isFlap or:[self isFlapTab]! !

!Morph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:53'!
isFlapTab
	^false! !

!Morph methodsFor: 'classification' stamp: 'ar 8/10/1998 18:50'!
isFlashMorph
	^false! !

!Morph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'!
isFlexMorph

	^ false
! !

!Morph methodsFor: 'classification'!
isHandMorph

	^ false! !

!Morph methodsFor: 'classification' stamp: 'ar 10/3/2000 18:11'!
isModalShell
	^false! !

!Morph methodsFor: 'classification'!
isMorph

	^ true! !

!Morph methodsFor: 'classification' stamp: 'ar 10/5/2000 16:40'!
isMorphicModel
	^false! !

!Morph methodsFor: 'classification' stamp: 'sw 1/29/98 21:51'!
isPlayfieldLike
	^ false! !

!Morph methodsFor: 'classification' stamp: 'jm 5/7/1998 13:45'!
isRenderer
	"A *renderer* morph transforms the appearance of its submorph in some manner. For example, it might supply a drop shadow or scale and rotate the morph it encases. Answer true if this morph acts as a renderer. This default implementation returns false."
	"Details: A renderer is assumed to have a single submorph. Renderers may be nested to concatenate their transformations. It is useful to be able to find the outer-most renderer. This can be done by ascending the owner chain from the rendered morph. To find the morph being rendered, one can descend through the (singleton) submorph lists of the renderer chain until a non-renderer is encountered."

	^ false
! !

!Morph methodsFor: 'classification' stamp: 'di 11/2/2000 13:24'!
isSyntaxMorph
	^false! !

!Morph methodsFor: 'classification'!
isWorldMorph

	^ false! !

!Morph methodsFor: 'classification'!
isWorldOrHandMorph

	^ self isWorldMorph or: [self isHandMorph]! !


!Morph methodsFor: 'accessing' stamp: 'sw 8/11/1998 16:46'!
actorState
	"This method instantiates actorState as a side-effect.
	For simple queries, use actorStateOrNil"
	| state |
	state _ self actorStateOrNil.
	state ifNil:
		[state _ ActorState new initializeFor: self assuredPlayer.
		self actorState: state].
	^ state! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:05'!
actorState: anActorState
	extension == nil ifTrue: [self assureExtension].
	extension actorState: anActorState! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:06'!
actorStateOrNil
	extension == nil ifTrue: [^ nil].
	^ extension actorState! !

!Morph methodsFor: 'accessing' stamp: 'tk 2/6/1999 22:43'!
asMorph
	^ self! !

!Morph methodsFor: 'accessing' stamp: 'sma 12/23/1999 13:13'!
balloonText
	"Answer balloon help text or nil, if no help is available.
	NB: subclasses may override such that they programatically construct
	the text, for economy's sake, such as model phrases in a Viewer"

	| text |
	extension == nil ifTrue: [^ nil].
	(text _ extension balloonText) ifNotNil: [^ text].
	(text _ extension balloonTextSelector)
		ifNotNil: [^ (ScriptingSystem helpStringFor: text)
			withNoLineLongerThan: Preferences maxBalloonHelpLineLength].
	^ nil! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:07'!
balloonTextSelector: aSelector
	extension == nil ifTrue: [self assureExtension].
	extension balloonTextSelector: aSelector! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:07'!
beSticky
	extension == nil ifTrue: [self assureExtension].
	extension sticky: true! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/27/2000 17:33'!
beUnsticky
	"If the receiver is marked as sticky, make it now be unsticky"

	extension ifNotNil:
		[extension sticky: false]! !

!Morph methodsFor: 'accessing' stamp: 'ar 11/9/2000 01:36'!
borderWidth

	^ 0! !

!Morph methodsFor: 'accessing' stamp: 'ar 11/9/2000 01:36'!
borderWidth: aNumber
! !

!Morph methodsFor: 'accessing'!
color

	^ color! !

!Morph methodsFor: 'accessing' stamp: 'jm 8/24/97 21:26'!
color: aColor

	color = aColor ifFalse: [
		color _ aColor.
		self changed].
! !

!Morph methodsFor: 'accessing' stamp: 'sw 2/16/98 03:44'!
colorForInsets
	"Return the color to be used for shading inset borders.  The default is my own color, but it might want to be, eg, my owner's color.  Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned"

	^ color colorForInsets
! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:08'!
eventHandler
	extension == nil ifTrue: [^ nil].
	^ extension eventHandler! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:08'!
eventHandler: anEventHandler
	"Note that morphs can share eventHandlers and all is OK.  "
	extension == nil ifTrue: [self assureExtension].
	extension eventHandler: anEventHandler! !

!Morph methodsFor: 'accessing' stamp: 'ar 9/22/2000 13:36'!
forwardDirection
	"Return the receiver's forward direction (in eToy terms)"
	^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! !

!Morph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:25'!
hasTranslucentColor
	"Answer true if this any of this morph is translucent but not transparent."

	^ color isColor and: [color isTranslucentColor]
! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'!
highlight
	"The receiver is being asked to appear in a highlighted state.  Mostly used for textual morphs"
	self color: self highlightColor! !

!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'!
highlightColor
	
	| val |
	^ (val _ self valueOfProperty: #highlightColor)
		ifNotNil:
			[val ifNil: [self error: 'nil highlightColor']]
		ifNil:
			[owner ifNil: [self color] ifNotNil: [owner highlightColor]]! !

!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'!
highlightColor: aColor
	self setProperty: #highlightColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:09'!
isLocked
	extension == nil ifTrue: [^ false].
	^ extension locked! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/27/2000 17:42'!
isShared
	"Answer whether the receiver has the #shared property.  This property allows it to be treated as a 'background' item"

	^ self hasProperty: #shared! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:10'!
isSticky
	extension == nil ifTrue: [^ false].
	^ extension sticky! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/4/97 12:05'!
lock
	self lock: true! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:10'!
lock: aBoolean
	extension == nil ifTrue:
		[aBoolean ifFalse: [^ self].
		self assureExtension].
	extension locked: aBoolean! !

!Morph methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:35'!
modelOrNil
	^ nil! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:10'!
player
	extension == nil ifTrue: [^ nil].
	^ extension player! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:10'!
player: anObject
	extension == nil ifTrue: [self assureExtension].
	extension player: anObject! !

!Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'!
regularColor
	
	| val |
	^ (val _ self valueOfProperty: #regularColor)
		ifNotNil:
			[val ifNil: [self error: 'nil regularColor']]
		ifNil:
			[owner ifNil: [self color] ifNotNil: [owner regularColor]]! !

!Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'!
regularColor: aColor
	self setProperty: #regularColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 14:56'!
rememberedColor
	"Answer a rememberedColor, or nil if none"

	^ self valueOfProperty: #rememberedColor ifAbsent: [nil]! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/29/2000 15:47'!
rememberedColor: aColor
	"Place aColor in a property so I can retrieve it later.  A tortuous but expedient flow of data"

	^ self setProperty: #rememberedColor toValue: aColor! !

!Morph methodsFor: 'accessing' stamp: 'tk 12/4/1998 13:06'!
sqkPage
	^ self valueOfProperty: #SqueakPage! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 22:12'!
toggleStickiness
	extension == nil ifTrue: [^ self beSticky].
	extension sticky: extension sticky not! !

!Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'!
unHighlight
	self color: self regularColor! !

!Morph methodsFor: 'accessing' stamp: 'di 8/11/1998 12:33'!
unlock
	self lock: false! !

!Morph methodsFor: 'accessing' stamp: 'sw 8/15/97 23:59'!
unlockContents
	self submorphsDo:
		[:m | m unlock]! !

!Morph methodsFor: 'accessing' stamp: 'tk 2/17/1999 11:45'!
url
	"If I have been assigned a url, return it.  For PasteUpMorphs mostly."
	| sq |
	(sq _ self sqkPage) ifNotNil: [^ sq url].
	^ self valueOfProperty: #url
		! !

!Morph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:54'!
userString
	"Do I have a text string to be searched on?"

	^ nil! !


!Morph methodsFor: 'access properties' stamp: 'di 8/11/1998 22:09'!
hasProperty: propName
	"Answer whether the receiver has the given property.  Deemed to have it only if I have a property dictionary entry for it and that entry is neither nil nor false"
	extension == nil ifTrue: [^ false].
	^ extension hasProperty: propName! !

!Morph methodsFor: 'access properties' stamp: 'di 8/16/1998 11:13'!
removeProperty: propName
	extension == nil ifTrue: [^ self].
	extension removeProperty: propName! !

!Morph methodsFor: 'access properties' stamp: 'di 8/11/1998 22:12'!
setProperty: propName toValue: aValue

	aValue ifNil: [^ self removeProperty: propName].
	extension == nil ifTrue: [self assureExtension].
	extension setProperty: propName toValue: aValue! !

!Morph methodsFor: 'access properties' stamp: 'di 8/11/1998 22:13'!
valueOfProperty: propName
	extension == nil ifTrue: [^ nil].
	^ extension valueOfProperty: propName! !

!Morph methodsFor: 'access properties' stamp: 'di 8/11/1998 22:13'!
valueOfProperty: propName ifAbsent: aBlock
	extension == nil ifTrue: [^ aBlock value].
	^ extension valueOfProperty: propName ifAbsent: aBlock! !

!Morph methodsFor: 'access properties' stamp: 'sw 10/3/2000 11:20'!
valueOfProperty: propName ifPresentDo: aBlock
	"If the receiver has a property of the given name, evaluate aBlock on behalf of the value of that property"

	extension == nil ifTrue: [^ self].
	^ aBlock value: (extension valueOfProperty: propName ifAbsent: [^ self])! !


!Morph methodsFor: 'copying'!
copy

	^ self copyWithoutSubmorphs! !

!Morph methodsFor: 'copying' stamp: 'tk 9/20/97 23:36'!
copyRecordingIn: dict
	"Recursively copy this entire composite morph, recording the correspondence between old and new morphs in the given dictionary. This dictionary will be used to update intra-composite references in the copy.  See updateReferencesUsing:
	Rules:  All morphs being copied must be in the submorph&owner hierarchy of the first object being copied.  Any morph this is NOT in submorph&owner hierarchy, and is only held by an inst var or by an array, etc., MUST be copied by an override of this method for the class of the instance that holds onto it.  This is really hard to obey!!!!!!"

	| new |
	new _ self copy.
	dict at: self put: new.
	submorphs size > 0 ifTrue: [
		new privateSubmorphs:
			(submorphs collect: [:m |
				(m copyRecordingIn: dict) privateOwner: new])].
	new copyPropertiesFrom: self dict: dict.
	^ new! !

!Morph methodsFor: 'copying'!
copyWithoutSubmorphs

	^ self clone
		privateOwner: nil;
		privateSubmorphs: EmptyArray;
		privateBounds: (bounds origin corner: bounds corner)  "deep-copy bounds"! !

!Morph methodsFor: 'copying' stamp: 'tk 4/30/1999 15:59'!
deepCopy

	self error: 'Please use veryDeepCopy or fullCopy'.
	^ self shallowCopy! !

!Morph methodsFor: 'copying' stamp: 'sw 1/15/2001 19:34'!
duplicate
	"Make and return a duplicate of the receiver"

	| newMorph aName w |
	self okayToDuplicate ifFalse: [^ self].
	aName _ (w _ self world) ifNotNil:
		[w nameForCopyIfAlreadyNamed: self].
	newMorph _ self veryDeepCopy.
	aName ifNotNil: [newMorph setNameTo: aName].

	newMorph arrangeToStartStepping.
	newMorph privateOwner: nil. "no longer in world"
	newMorph isPartsDonor: false. "no longer parts donor"
	^ newMorph! !

!Morph methodsFor: 'copying' stamp: 'tk 8/21/97 15:05'!
fullCopy
	"Produce a copy of me with my entire tree of submorphs.  Morphs
mentioned more than once are all directed to a single new copy.  Simple
inst vars are not copied, so you must override to copy Arrays, etc.  "

	| dict new |
	dict _ IdentityDictionary new: 1000.
	new _ self copyRecordingIn: dict.
	new allMorphsDo: [:m | m updateReferencesUsing: dict].
	^ new! !

!Morph methodsFor: 'copying' stamp: 'sw 1/20/2001 00:28'!
fullCopyWithoutFormerOwner
	"Like fullCopy, but does not copy over the former owner, which could bring a huge amount of extraneous baggage with it."

	| dict new anOwner |
	anOwner _ self formerOwner.
	self removeProperty: #formerOwner.
	dict _ IdentityDictionary new: 1000.
	new _ self copyRecordingIn: dict.
	new allMorphsDo: [:m | m updateReferencesUsing: dict].
	anOwner ifNotNil: [self formerOwner: anOwner].
	^ new! !

!Morph methodsFor: 'copying' stamp: 'di 8/11/1998 22:13'!
updateReferencesUsing: aDictionary
	"Update intra-morph references within a composite morph that has
been copied. For example, if a button refers to morph X in the orginal
composite then the copy of that button in the new composite should refer to
the copy of X in new composite, not the original X. This default
implementation updates the contents of any morph-bearing slot. It may be
overridden to avoid this behavior if so desired."
	| old |
	Morph instSize + 1 to: self class instSize do:
		[:i | old _ self instVarAt: i.
		old isMorph ifTrue:
			[self instVarAt: i put: (aDictionary at: old ifAbsent: [old])]].
	extension == nil ifFalse: [extension updateReferencesUsing: aDictionary]! !

!Morph methodsFor: 'copying' stamp: 'sw 2/1/2001 23:11'!
usableSiblingInstance
	"Return another similar morph whose Player is of the same class as mine"

	|  aName usedNames newPlayer newMorph topRenderer |
	self flag: #noteToTed.  "I think this may have deviated majorly from your mainstream veryDeepCopy work, so there will probably be some problems entailed"
	(topRenderer _ self topRendererOrSelf) == self ifFalse: [^ topRenderer usableSiblingInstance].

	self player assureUniClass.
	newMorph _ self veryDeepCopyWithoutPlayer.
	newPlayer _ self player class new costume: newMorph.
	newPlayer copyAddedStateFrom: self player.
	newPlayer resetCostumeList.
	self isFlexMorph ifTrue: [newMorph renderedMorph player: newPlayer]. "???"
	newMorph actorState: (self player actorState shallowCopy initializeFor: newPlayer).

	(aName _ self knownName) == nil ifTrue:
		[self player ~~ nil ifTrue: [aName _ newMorph innocuousName]].
			"Force a difference here"
	aName ~~ nil ifTrue:
		[usedNames _ (self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames]) copyWith: aName.
		newMorph setNameTo: (Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not])].
	newMorph privateOwner: nil.
	(newMorph renderedMorph eventHandler ~~ nil) ifTrue:
		[newPlayer assureEventHandlerRepresentsStatus].
	self currentWorld addMorphBack: newMorph.

	self presenter flushPlayerListCache.

	^ newMorph! !

!Morph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:27'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  See veryDeepInner:, veryDeepFixupWith:"

	self prepareToBeSaved.
	^ super veryDeepCopyWith: deepCopier! !

!Morph methodsFor: 'copying' stamp: 'sw 1/30/2001 21:35'!
veryDeepCopyWithoutPlayer
	"Make a very deep copy of the receiver but do not include its player in it -- obliterate it wherever it occurs, then make the very deep copy, then restore it where needed in the original"

	| hold copy holdState renderedMorph playerOfRenderedMorph |
	hold _ self player.
	holdState _ self actorStateOrNil.
	holdState ifNotNil: [self actorState: nil].
	(renderedMorph _ self renderedMorph) ~~ self
		ifTrue: [playerOfRenderedMorph _ renderedMorph player.
				renderedMorph player: nil.]
		ifFalse:	[nil].
	self player: nil.
	copy _ self veryDeepCopy.
		"My player should not be there, and the formerOwner thing should no longer be
		a problem owing to Andreas's recent fixes for that"
	holdState ifNotNil:
		[copy actorState: (holdState copyWithPlayerReferenceNilled)].
	self player: hold.
	playerOfRenderedMorph ifNotNil: [renderedMorph player: playerOfRenderedMorph].
	holdState ifNotNil: [self actorState: holdState].
	^ copy! !

!Morph methodsFor: 'copying' stamp: 'tk 1/7/1999 12:32'!
veryDeepFixupWith: deepCopier
	"If some fields were weakly copied, fix new copy here."

"super veryDeepFixupWith: deepCopier."
"My owner should already have been fixed up."! !

!Morph methodsFor: 'copying' stamp: 'tk 1/7/1999 12:30'!
veryDeepInner: deepCopier
	"The inner loop, so it can be overridden when a field should not be traced."

	"super veryDeepInner: deepCopier.	know Object has no inst vars"
	bounds _ bounds clone.	"Points are shared with original"
	"owner _ owner.	special, see veryDeepFixupWith:"
	submorphs _ submorphs veryDeepCopyWith: deepCopier.
	self submorphsDo: [:mySub | mySub privateOwner: self].		"I am the owner!!"
		"My owner field:  If owner is in tree being copied, he will set it.  
		If not, if I am top object, caller will addMorph: me to another morph.
			if I am not in the submorph tree, I should not be copied.  The field I
			am in needs to be weakly copied."
	"fullBounds _ fullBounds.	fullBounds is shared with original!!"
	color _ color veryDeepCopyWith: deepCopier.
		"color, if simple, will return self. may be complex"
	extension _ extension veryDeepCopyWith: deepCopier.
		"extension is treated like any generic inst var"
! !


!Morph methodsFor: 'structure' stamp: 'RAA 6/7/2000 09:58'!
activeHand

	self flag: #bob.		"need to do a better job here"
	^ (self outermostWorldMorph ifNil: [^ nil]) activeHand! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 01:00'!
allOwners
	"Return the owners of the reciever"

	^ Array streamContents: [:strm | self allOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:47'!
allOwnersDo: aBlock
	"Evaluate aBlock with all owners of the receiver"
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'structure' stamp: 'tk 1/13/2001 21:09'!
bestGuessOfCurrentWorld
	"Return world I am in, or current world if none."

	^ self world ifNil: [Display bestGuessOfCurrentWorld]
	! !

!Morph methodsFor: 'structure' stamp: 'RAA 6/7/2000 09:57'!
currentHand

	self flag: #bob.		"need to do a better job here"
	^ (self outermostWorldMorph ifNil: [^ super currentHand]) primaryHand! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:48'!
firstOwnerSuchThat: conditionBlock

	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
	^ nil
! !

!Morph methodsFor: 'structure' stamp: 'ar 10/3/2000 15:36'!
hasOwner: aMorph
	"Return true if the receiver has aMorph in its owner chain"
	aMorph ifNil:[^true].
	self allOwnersDo:[:m| m = aMorph ifTrue:[^true]].
	^false! !

!Morph methodsFor: 'structure' stamp: 'jm 7/8/97 10:08'!
isInWorld
	"Return true if this morph is in a world."

	^ self world ~~ nil! !

!Morph methodsFor: 'structure' stamp: 'sw 8/29/2000 14:55'!
morphPreceding: aSubmorph
	"Answer the morph immediately preceding aSubmorph, or nil if none"

	| anIndex |
	anIndex _ submorphs indexOf: aSubmorph ifAbsent: [^ nil].
	^ anIndex > 1
		ifTrue:
			[submorphs at: (anIndex - 1)]
		ifFalse:
			[nil]! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:13'!
nearestOwnerThat: conditionBlock
	"Return the first enclosing morph for which aBlock evaluates to true, or nil if none"

	^ self firstOwnerSuchThat: conditionBlock
! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:49'!
orOwnerSuchThat: conditionBlock

	(conditionBlock value: self) ifTrue: [^ self].
	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]].
	^ nil

! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:50'!
outermostMorphThat: conditionBlock
	"Return the outermost containing morph for which aBlock is true, or nil if none"

	| outermost |
	self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [outermost _ m]].
	^ outermost! !

!Morph methodsFor: 'structure' stamp: 'RAA 5/25/2000 15:39'!
outermostWorldMorph

	| outer |
	outer _ self outermostMorphThat: [ :x | x isWorldMorph].
	outer ifNotNil: [^outer].
	self isWorldMorph ifTrue: [^self].
	^nil! !

!Morph methodsFor: 'structure'!
owner
	"Returns the owner of this morph, which may be nil."

	^ owner! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:18'!
ownerThatIsA: aClass
	"Return the first enclosing morph that is a kind of aClass, or nil if none"

	^ self firstOwnerSuchThat: [:m | m isKindOf: aClass]! !

!Morph methodsFor: 'structure' stamp: 'di 11/12/2000 16:20'!
ownerThatIsA: firstClass orA: secondClass
	"Return the first enclosing morph that is a kind of one of the two classes given, or nil if none"

	^ self firstOwnerSuchThat: [:m | (m isKindOf: firstClass) or: [m isKindOf: secondClass]]! !

!Morph methodsFor: 'structure' stamp: 'sw 7/1/1998 18:02'!
pasteUpMorph
	"Answer the closest containing morph that is a PasteUp morph"
	^ self ownerThatIsA: PasteUpMorph! !

!Morph methodsFor: 'structure' stamp: 'sw 3/3/1999 13:08'!
presenter
	^ owner ifNotNil: [owner presenter] ifNil: [self currentWorld presenter]! !

!Morph methodsFor: 'structure' stamp: 'RAA 6/13/2000 15:01'!
primaryHand

        | outer |
        outer _ self outermostWorldMorph ifNil: [^ nil].
        ^ outer activeHand ifNil: [outer firstHand]! !

!Morph methodsFor: 'structure' stamp: 'jm 5/7/1998 15:49'!
renderedMorph
	"If the receiver is a renderer morph, answer the rendered morph. Otherwise, answer the receiver. A renderer morph with no submorphs answers itself. See the comment in Morph>isRenderer."

	self isRenderer ifFalse: [^ self].
	submorphs size = 0 ifTrue: [^ self].
	^ self firstSubmorph renderedMorph.
! !

!Morph methodsFor: 'structure'!
root
	"Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph."

	(owner = nil or: [owner isWorldOrHandMorph]) ifTrue: [^ self].
	^ owner root! !

!Morph methodsFor: 'structure' stamp: 'di 8/4/1999 15:41'!
rootAt: location
	"Just return myself, unless I am a WorldWindow.
	If so, then return the appropriate root in that world"

	^ self! !

!Morph methodsFor: 'structure' stamp: 'sw 8/30/1998 09:47'!
topPasteUp
	"If the receiver is in a world, return that; otherwise return the outermost pasteup morph"
	^ self outermostMorphThat: [:m | m isKindOf: PasteUpMorph]! !

!Morph methodsFor: 'structure' stamp: 'RAA 6/11/2000 23:45'!
topRendererOrSelf
	"Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer."

	| top topsOwner |
	owner ifNil: [^ self].
	self isWorldMorph ifTrue: [^self].	"ignore scaling of this world"
	top _ self.
	topsOwner _ top owner.
	[(topsOwner ~~ nil) and: [topsOwner isRenderer]] whileTrue: [
		top _ topsOwner.
		topsOwner _ top owner].
	^ top
! !

!Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:59'!
withAllOwners
	"Return the receiver and all its owners"

	^ Array streamContents: [:strm | self withAllOwnersDo: [:m | strm nextPut: m]]! !

!Morph methodsFor: 'structure' stamp: 'ar 9/14/2000 16:48'!
withAllOwnersDo: aBlock
	"Evaluate aBlock with the receiver and all of its owners"
	aBlock value: self.
	owner ifNotNil:[^owner withAllOwnersDo: aBlock].! !

!Morph methodsFor: 'structure' stamp: 'di 6/7/1999 20:04'!
world
	^ owner == nil ifTrue: [nil] ifFalse: [owner world]! !


!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/6/2000 19:09'!
allKnownNames
	"Return a list of all known names based on the scope of the receiver"
	| allNames theName |
	self isPartsBin ifTrue:[^#()]. "Don't report names from parts bins"
	allNames _ WriteStream on: #().
	self submorphsDo:[:m|
		(theName _ m knownName) ifNotNil:[allNames nextPut: theName].
		allNames nextPutAll: m allKnownNames.
	].
	^allNames contents! !

!Morph methodsFor: 'submorphs-accessing'!
allMorphs
	"Return a collection containing all morphs in this composite morph (including the receiver)."

	| all |
	all _ OrderedCollection new: 100.
	self allMorphsDo: [: m | all add: m].
	^ all! !

!Morph methodsFor: 'submorphs-accessing'!
allMorphsDo: aBlock
	"Evaluate the given block for all morphs in this composite morph (including the receiver)."

	submorphs size > 0 ifTrue: [
		submorphs do: [:m | m allMorphsDo: aBlock].
	].
	aBlock value: self.
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/31/97 20:05'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"

	^ OrderedCollection new! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'!
findA: aClass
	"Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."

	^self submorphs
		detect: [:p | p isKindOf: aClass]
		ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'LC 9/28/1999 19:12'!
findDeepSubmorphThat: block1 ifAbsent: block2 
	self
		allMorphsDo: [:m | (block1 value: m)
				== true ifTrue: [^ m]].
	^ block2 value! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 1/9/2001 12:30'!
findDeeplyA: aClass
	"Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."

	^ (self allMorphs copyWithout: self)
		detect: [:p | p isKindOf: aClass]
		ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing'!
firstSubmorph

	^ submorphs at: 1! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 17:11'!
hasSubmorphWithProperty: aSymbol
	submorphs detect: [:m | m hasProperty: aSymbol] ifNone: [^ false].
	^ true! !

!Morph methodsFor: 'submorphs-accessing'!
hasSubmorphs

	^ submorphs size > 0! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/31/2000 11:04'!
indexOfMorphAbove: aPoint
	"Return index of lowest morph whose bottom is above aPoint.
	Will return 0 if the first morph is not above aPoint."

	submorphs withIndexDo: [:mm :ii | 
		mm fullBounds bottom >= aPoint y ifTrue: [^ ii - 1]].
	^ submorphs size! !

!Morph methodsFor: 'submorphs-accessing'!
lastSubmorph

	^ submorphs at: submorphs size! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'!
morphsAt: aPoint
	"Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  The order is deepest embedding first."
	^self morphsAt: aPoint unlocked: false! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/7/2000 20:43'!
morphsAt: aPoint behind: aMorph unlocked: aBool
	"Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."
	| isBack found all tfm |
	(aMorph == nil or:[owner == nil]) ifTrue:["Traverse down"
		(self fullBounds containsPoint: aPoint) ifFalse:[^#()].
		(aBool and:[self isLocked or:[self visible not]]) ifTrue:[^#()].
		all _ nil.
	] ifFalse:[ "Traverse up"
		tfm _ self transformedFrom: owner.
		all _ owner morphsAt: (tfm localPointToGlobal: aPoint) behind: self unlocked: aBool.
		all _ WriteStream with: all.
	].
	isBack _ aMorph == nil.
	self submorphsDo:[:m|
		isBack ifTrue:[
			tfm _ m transformedFrom: self.
			found _ m morphsAt: (tfm globalPointToLocal: aPoint) behind: nil unlocked: aBool.
			found size > 0 ifTrue:[
				all ifNil:[all _ WriteStream on: #()].
				all nextPutAll: found]].
		m == aMorph ifTrue:[isBack _ true]].
	(isBack and:[self containsPoint: aPoint]) ifTrue:[
		all ifNil:[^Array with: self].
		all nextPut: self].
	^all ifNil:[#()] ifNotNil:[all contents].
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:40'!
morphsAt: aPoint unlocked: aBool
	"Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself.  The order is deepest embedding first."
	| mList |
	mList _ WriteStream on: #().
	self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m].
	^mList contents! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:37'!
morphsAt: aPoint unlocked: aBool do: aBlock
	"Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account."
	| tfm |
	(self fullBounds containsPoint: aPoint) ifFalse:[^self].
	(aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self].
	self submorphsDo:[:m|
		tfm _ m transformedFrom: self.
		m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock].
	(self containsPoint: aPoint) ifTrue:[aBlock value: self].! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 10/8/2000 15:44'!
rootMorphsAt: aPoint
	"Return the list of root morphs containing the given point, excluding the receiver.
	ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
self flag: #arNote. "check this at some point"
	^ self submorphs select:
		[:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'RAA 6/11/2000 20:41'!
rootMorphsAtGlobal: aPoint
	"Return the list of root morphs containing the given point, excluding the receiver.
	ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"

	^ self rootMorphsAt: (self pointFromWorld: aPoint)! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'ar 11/12/2000 22:31'!
shuffleSubmorphs
	"Randomly shuffle the order of my submorphs.  Don't call this method lightly!!"

	| bg |
	self invalidRect: self fullBounds.
	(submorphs size > 0 and: [submorphs last mustBeBackmost]) ifTrue:
		[bg _ submorphs last.
		bg privateDelete].
	submorphs _ submorphs shuffled.
	bg ifNotNil: [self addMorphBack: bg].
	self layoutChanged! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:12'!
submorphAfter
	"Return the submorph after (behind) me, or nil"
	| ii |
	owner ifNil: [^ nil].
	^ (ii _ owner submorphIndexOf: self) = owner submorphs size 
		ifTrue: [nil]
		ifFalse: [owner submorphs at: ii+1].
	
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'tk 10/20/2000 13:13'!
submorphBefore
	"Return the submorph after (behind) me, or nil"
	| ii |
	owner ifNil: [^ nil].
	^ (ii _ owner submorphIndexOf: self) = 1 
		ifTrue: [nil]
		ifFalse: [owner submorphs at: ii-1].
	
! !

!Morph methodsFor: 'submorphs-accessing'!
submorphCount

	^ submorphs size! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 4/9/98 14:26'!
submorphNamed: aName
	^ self submorphNamed: aName ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/29/2000 16:10'!
submorphNamed: aName ifNone: aBlock
	"Find the first submorph with this name, or a button with an action selector of that name"

	| sub args |
	self submorphs do: [:p | p knownName = aName ifTrue: [^ p]].
	self submorphs do: [:button |
		(button respondsTo: #actionSelector) ifTrue:
			[button actionSelector == aName ifTrue: [^ button]].
		((button respondsTo: #arguments) and: [(args _ button arguments) notNil])
			ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^ button]].
		(button isKindOf: AlignmentMorph) ifTrue:
			[(sub _ button submorphNamed: aName ifNone: [nil]) ifNotNil: [^ sub]]].
	^ aBlock value! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'rhi 9/10/2000 12:12'!
submorphOfClass: aClass

	^self findA: aClass! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/26/1999 23:42'!
submorphThat: block1 ifNone: block2
	^ submorphs detect: [:m | (block1 value: m) == true] ifNone: [block2 value]
	! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 18:47'!
submorphWithProperty: aSymbol
	^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! !

!Morph methodsFor: 'submorphs-accessing'!
submorphs

	^ submorphs copy! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:30'!
submorphsBehind: aMorph do: aBlock
	| behind |
	behind _ false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind _ true]
						ifFalse: [behind ifTrue: [aBlock value: m]]].
! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 5/13/1998 20:42'!
submorphsDo: aBlock

	submorphs size = 0 ifTrue: [^ self].
	submorphs do: aBlock.! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/4/97 14:29'!
submorphsInFrontOf: aMorph do: aBlock
	| behind |
	behind _ false.
	submorphs do:
		[:m | m == aMorph ifTrue: [behind _ true]
						ifFalse: [behind ifFalse: [aBlock value: m]]].
! !

!Morph methodsFor: 'submorphs-accessing'!
submorphsReverseDo: aBlock

	submorphs reverseDo: aBlock.! !

!Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/15/97 22:03'!
submorphsSatisfying: aBlock
	^ submorphs select: [:m | (aBlock value: m) == true]! !


!Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/15/1998 14:23'!
abandon
	"Like delete, but we really intend not to use this morph again.  Clean up a few things."

	self delete! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 13:15'!
addAllMorphs: aCollection
	| any box invalidate myWorld itsWorld |
	myWorld _ self world.
	invalidate _ myWorld notNil.
	box _ nil.
	aCollection do: [:m |
		any _ m.
		m owner ifNotNil: [
			itsWorld _ m world.
			itsWorld == myWorld ifFalse:[m outOfWorld: itsWorld].
			m owner privateRemoveMorph: m].
		invalidate ifTrue:[
			box ifNil:[box _ m fullBounds copy] 
				ifNotNil:[box _ box quickMerge: m fullBounds]].
		m privateOwner: self.
		itsWorld == myWorld ifFalse:[m intoWorld: myWorld].
	].
	submorphs _ submorphs, aCollection.
	self layoutChanged.
	box ifNotNil:[self invalidRect: box from: any].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 13:18'!
addAllMorphs: aCollection after: anotherMorph

	| index box any invalidate myWorld itsWorld |
	myWorld _ self world.
	invalidate _ myWorld notNil.
	box _ nil.
	index _ submorphs indexOf: anotherMorph ifAbsent: [submorphs size].
	aCollection do: [:m |
		any _ m.
		m owner ifNotNil: [
			itsWorld _ m world.
			itsWorld == myWorld ifFalse:[m outOfWorld: itsWorld].
			m owner privateRemoveMorph: m].
		invalidate ifTrue:[
			box ifNil:[box _ m fullBounds copy] 
				ifNotNil:[box _ box quickMerge: m fullBounds]].
		m privateOwner: self.
		itsWorld == myWorld ifFalse:[m intoWorld: myWorld].
	].
	submorphs _ (submorphs copyFrom: 1 to: index), aCollection,
			(submorphs copyFrom: index+1 to: submorphs size).
	self layoutChanged.
	box ifNotNil:[self invalidRect: box from: any].! !

!Morph methodsFor: 'submorphs-add/remove'!
addMorph: aMorph

	self addMorphFront: aMorph.! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'!
addMorph: newMorph after: aMorph
	"Add the given morph as one of my submorphs, inserting it after anotherMorph"
	^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph)+1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/7/2000 08:29'!
addMorph: aMorph asElementNumber: aNumber
	"Add the given morph so that it becomes the aNumber'th element of my submorph list.  If aMorph is already one of my submorphs, reposition it"

	(submorphs includes: aMorph) ifTrue:
		[aMorph privateDelete].
	(aNumber <= submorphs size)
		ifTrue:
			[self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
		ifFalse:
			[self addMorphBack: aMorph]
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:44'!
addMorph: newMorph behind: aMorph
	"Add a morph to the list of submorphs behind the specified morph"
	^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'JW 2/1/2001 12:52'!
addMorph: aMorph fullFrame: aLayoutFrame

	aMorph layoutFrame: aLayoutFrame.
	aMorph hResizing: #spaceFill; vResizing: #spaceFill.
	self addMorph: aMorph.

! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:45'!
addMorph: newMorph inFrontOf: aMorph
	"Add a morph to the list of submorphs in front of the specified morph"
	^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:55'!
addMorphBack: aMorph
	^self privateAddMorph: aMorph atIndex: submorphs size+1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/15/2000 19:34'!
addMorphCentered: aMorph

	aMorph position: bounds center - (aMorph extent // 2).
	self addMorphFront: aMorph.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'!
addMorphFront: aMorph
	^self privateAddMorph: aMorph atIndex: 1! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/15/1998 23:42'!
addMorphFront: aMorph fromWorldPosition: wp

	self addMorphFront: aMorph.
	aMorph position: (self transformFromWorld globalPointToLocal: wp)! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 6/17/1998 16:04'!
addMorphNearBack: aMorph
	| bg |
	(submorphs size > 0 and: [submorphs last mustBeBackmost]) ifTrue:
		[bg _ submorphs last.
		bg privateDelete].
	self addMorphBack: aMorph.
	bg ifNotNil: [self addMorphBack: bg]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 9/2/1999 15:12'!
comeToFront
	| outerMorph |
	outerMorph _ self topRendererOrSelf.
	(outerMorph owner == nil or: [outerMorph owner hasSubmorphs not]) ifTrue: [^ self].
	outerMorph owner firstSubmorph == outerMorph ifFalse:
		[outerMorph owner addMorphFront: outerMorph]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/27/97 23:26'!
copyWithoutSubmorph: sub
	"Needed to get a morph to draw without one of its submorphs.
	NOTE:  This must be thrown away immediately after use."
	^ self clone privateSubmorphs: (submorphs copyWithout: sub)! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 8/29/2000 14:04'!
delete
	"Remove the receiver as a submorph of its owner and make its new owner be nil."
	| aWorld |
	owner ifNotNil:
		[(extension == nil or: [self player == nil])
		ifTrue: [owner privateRemoveMorph: self.
				owner _ nil]
		ifFalse: ["Player must be notified"
				aWorld _ self world ifNil: [World].	"or some proper of getting the World"
				owner privateRemoveMorph: self.
				owner _ nil.
				self player noteDeletionOf: self fromWorld: aWorld]
		].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 7/3/1998 11:02'!
deleteSubmorphsWithProperty: aSymbol
	submorphs copy do:
		[:m | (m hasProperty: aSymbol) ifTrue: [m delete]]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 6/17/1999 14:21'!
dismissViaHalo
	"The user has clicked in the delete halo-handle.  This provides a hook in case some concomitant action should be taken, or if the paticular morph is not one which should be put in the trash can, for example."

	TrashCanMorph moveToTrash: self! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 4/9/98 22:44'!
goBehind

	owner addMorphNearBack: self.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 2/15/98 23:34'!
privateDelete
	"Remove the receiver as a submorph of its owner and make its new owner be nil, without informing anyone other than my owner"

	owner ifNotNil:
		[owner privateRemoveMorph: self.
		owner _ nil].! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 13:19'!
removeAllMorphs
	| myWorld |
	myWorld _ self world.
	(fullBounds notNil or:[self isInWorld]) ifTrue:[self invalidRect: self fullBounds].
	submorphs do: [:m | m outOfWorld: myWorld; privateOwner: nil].
	submorphs _ EmptyArray.
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 13:19'!
removeAllMorphsIn: aCollection
	"greatly speeds up the removal of *lots* of submorphs"
	| set myWorld |
	myWorld _ self world.
	(fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds].
	aCollection do: [:m | m outOfWorld: myWorld; privateOwner: nil].
	set _ IdentitySet new: aCollection size * 4 // 3.
	aCollection do: [:each | set add: each].
	submorphs _ submorphs reject: [ :each | set includes: each].
	self layoutChanged.
! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/25/1999 23:34'!
replaceSubmorph: oldMorph by: newMorph
	| index itsPosition w |
	oldMorph stopStepping.
	itsPosition _ oldMorph referencePositionInWorld.
	index _ submorphs indexOf: oldMorph.
	oldMorph privateDelete.
	self privateAddMorph: newMorph atIndex: index.
	newMorph referencePositionInWorld: itsPosition.
	(w _ newMorph world) ifNotNil:
		[w startSteppingSubmorphsOf: newMorph]! !

!Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/1/2000 10:16'!
submorphIndexOf: aMorph
	"Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list"

	^ submorphs indexOf: aMorph ifAbsent: [nil]! !


!Morph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:10'!
areasRemainingToFill: aRectangle
	"May be overridden by any subclasses with opaque regions"

	^ Array with: aRectangle! !

!Morph methodsFor: 'drawing' stamp: 'sw 6/4/2000 22:02'!
boundingBoxOfSubmorphs
	| aBox |
	aBox _ bounds origin extent: self minimumExtent.  "so won't end up with something empty"
	submorphs do:
		[:m | m visible ifTrue: [aBox _ aBox quickMerge: m fullBounds]].
	^ aBox
! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/4/2000 23:39'!
changeClipSubmorphs
	self clipSubmorphs: self clipSubmorphs not.! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:21'!
clipLayoutCells
	"Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds."
	extension == nil ifTrue:[^false].
	^self valueOfProperty: #clipLayoutCells ifAbsent:[false].! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:22'!
clipLayoutCells: aBool
	"Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds."
	aBool == false
		ifTrue:[self removeProperty: #clipLayoutCells]
		ifFalse:[self setProperty: #clipLayoutCells toValue: aBool].
	self changed.! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:17'!
clipSubmorphs
	"Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds."
	extension == nil ifTrue:[^false]. "get out quickly"
	^self valueOfProperty: #clipSubmorphs ifAbsent:[false].! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/12/2000 18:47'!
clipSubmorphs: aBool
	"Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds."
	self invalidRect: self fullBounds.
	aBool == false
		ifTrue:[self removeProperty: #clipSubmorphs]
		ifFalse:[self setProperty: #clipSubmorphs toValue: aBool].
	self invalidRect: self fullBounds.! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:16'!
clippingBounds
	"Return the bounds to which any submorphs should be clipped if the property is set"
	^self innerBounds! !

!Morph methodsFor: 'drawing' stamp: 'tk 8/2/1998 14:33'!
doesOwnRotation
	"Some morphs don't want to TransformMorph to rotate their images, but we do"
	^ false! !

!Morph methodsFor: 'drawing' stamp: 'panda 4/28/2000 11:59'!
drawDropHighlightOn: aCanvas
	self highlightedForDrop ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self dropHighlightColor].! !

!Morph methodsFor: 'drawing' stamp: 'RAA 11/7/2000 15:52'!
drawDropShadowOn: aCanvas

	aCanvas 
		translateBy: self shadowOffset 
		during: [ :shadowCanvas |
			shadowCanvas shadowColor: self shadowColor.
			shadowCanvas roundCornersOf: self during: [ shadowCanvas drawMorph: self ]
		].
! !

!Morph methodsFor: 'drawing' stamp: 'ar 4/2/1999 13:13'!
drawErrorOn: aCanvas
	"The morph (or one of its submorphs) had an error in its drawing method."
	aCanvas
		frameAndFillRectangle: bounds
		fillColor: Color red
		borderWidth: 1
		borderColor: Color yellow.
	aCanvas line: bounds topLeft to: bounds bottomRight width: 1 color: Color yellow.
	aCanvas line: bounds topRight to: bounds bottomLeft width: 1 color: Color yellow.! !

!Morph methodsFor: 'drawing' stamp: '   9/3/2000 13:55'!
drawMouseDownHighlightOn: aCanvas
	self highlightedForMouseDown ifTrue: [
		aCanvas frameRectangle: self fullBounds color: self color darker darker].! !

!Morph methodsFor: 'drawing' stamp: 'ar 6/18/1999 07:38'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: self fillStyle.
! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/26/2000 19:55'!
drawOnCanvas: aCanvas
	^aCanvas fullDraw: self.
! !

!Morph methodsFor: 'drawing' stamp: 'mpw 8/10/1930 05:21'!
drawPostscriptOn: aCanvas

	self drawOn:aCanvas.
! !

!Morph methodsFor: 'drawing' stamp: 'RAA 11/7/2000 17:14'!
drawRolloverBorderOn: aCanvas

	| colorToUse offsetToUse myShadow newForm f |

	colorToUse _ self valueOfProperty: #rolloverColor ifAbsent: [Color blue alpha: 0.5].
	offsetToUse _ self valueOfProperty: #rolloverWidth ifAbsent: [10@10].

	self hasRolloverBorder: false.
	myShadow _ self shadowForm.
	self hasRolloverBorder: true.

	myShadow offset: 0@0.
	f _ ColorForm extent: myShadow extent depth: 1.
	myShadow displayOn: f.
	f colors: {Color transparent. colorToUse}.

	newForm _ Form extent: offsetToUse * 2 + myShadow extent depth: 32.
     (WarpBlt current toForm: newForm)
		sourceForm: f;
		cellSize: 2; 
		combinationRule: 3;
		copyQuad: f boundingBox innerCorners toRect: newForm boundingBox.
	aCanvas 
		translateBy: offsetToUse negated
		during: [ :shadowCanvas |
			shadowCanvas shadowColor: colorToUse.
			shadowCanvas paintImage: newForm at: self position.
		].

! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/1/2000 15:38'!
drawSubmorphsOn: aCanvas
	"Display submorphs back to front"
	| drawBlock |
	submorphs size = 0 ifTrue:[^self].
	drawBlock _ [:canvas| submorphs reverseDo:[:m| canvas fullDrawMorph: m]].
	self clipSubmorphs ifTrue:[
		aCanvas clipBy: self clippingBounds during: drawBlock.
	] ifFalse:[
		drawBlock value: aCanvas.
	].! !

!Morph methodsFor: 'drawing' stamp: 'RAA 1/6/2001 22:12'!
expandFullBoundsForDropShadow: aRectangle
	"Return an expanded rectangle for an eventual drop shadow"
	| delta box |

	box _ aRectangle.
	delta _ self shadowOffset.
	box _ delta x >= 0 
		ifTrue:[box right: aRectangle right + delta x]
		ifFalse:[box left: aRectangle left + delta x].
	box _ delta y >= 0
		ifTrue:[box bottom: aRectangle bottom + delta y]
		ifFalse:[box top: aRectangle top + delta y].
	^box! !

!Morph methodsFor: 'drawing' stamp: 'ar 11/8/2000 19:29'!
expandFullBoundsForRolloverBorder: aRectangle
	| delta |
	delta _ self valueOfProperty: #rolloverWidth ifAbsent: [10@10].
	^aRectangle expandBy: delta.

! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 10:23'!
flash
	| c w |
	c _ self color.
	self color: Color black.
	(w _ self world) ifNotNil: [w displayWorldSafely].
	self color: c
! !

!Morph methodsFor: 'drawing' stamp: 'di 11/20/2000 08:20'!
fullDrawOn: aCanvas
	"Draw the full Morphic structure on the given Canvas"

	self visible ifFalse: [^ self].
	(self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas].
	"Note: At some point we should generalize this into some sort of 
	multi-canvas so that we can cross-optimize some drawing operations."
	"Pass 1: Draw eventual drop-shadow"
	self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas].
	(self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not])
		ifTrue: [self drawRolloverBorderOn: aCanvas].

	"Pass 2: Draw receiver itself"
	aCanvas roundCornersOf: self during:[
		aCanvas drawMorph: self.
		self drawSubmorphsOn:aCanvas.
		self drawDropHighlightOn: aCanvas.
		self drawMouseDownHighlightOn: aCanvas].! !

!Morph methodsFor: 'drawing' stamp: 'mpw 8/10/1930 05:25'!
fullDrawPostscriptOn: aCanvas

	self fullDrawOn:aCanvas.
! !

!Morph methodsFor: 'drawing' stamp: 'ar 10/29/2000 19:31'!
hasClipSubmorphsString
	^self clipSubmorphs
		ifTrue:['<on>clip submorphs']
		ifFalse:['<off>clip submorphs']! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/30/1998 18:27'!
hide
	owner ifNil: [^ self].
	self visible ifTrue: [self visible: false.  self changed]! !

!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'!
highlightForMouseDown
	self highlightForMouseDown: true! !

!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'!
highlightForMouseDown: aBoolean
	self setProperty: #highlightedForMouseDown toValue: aBoolean.
	self changed! !

!Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:48'!
highlightedForMouseDown
	^(self valueOfProperty: #highlightedForMouseDown) == true! !

!Morph methodsFor: 'drawing' stamp: 'jm 6/11/97 17:21'!
imageForm

	^ self imageFormForRectangle: self fullBounds
! !

!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'!
imageForm: depth forRectangle: rect
	| canvas |
	canvas _ Display defaultCanvasClass extent: rect extent depth: depth.
	canvas translateBy: rect topLeft negated
		during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ canvas form offset: rect topLeft! !

!Morph methodsFor: 'drawing' stamp: 'di 7/8/1998 12:42'!
imageFormDepth: depth

	^ self imageForm: depth forRectangle: self fullBounds
! !

!Morph methodsFor: 'drawing' stamp: 'di 9/9/1998 22:25'!
imageFormForRectangle: rect

	^ self imageForm: Display depth forRectangle: rect
! !

!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'!
imageFormWithout: stopMorph andStopThere: stopThere
	"Like imageForm, except it does not display stopMorph,
	and it will not display anything above it if stopThere is true.
	Returns a pair of the imageForm and a boolean that is true
		if it has hit stopMorph, and display should stop."
	| canvas rect |
	rect _ self fullBounds.
	canvas _ ColorPatchCanvas extent: rect extent depth: Display depth.
	canvas stopMorph: stopMorph.
	canvas doStop: stopThere.
	canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ Array with: (canvas form offset: rect topLeft)
			with: canvas foundMorph! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:25'!
refreshWorld
	| aWorld |
	(aWorld _ self world) ifNotNil: [aWorld displayWorldSafely]
! !

!Morph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:23'!
shadowForm
	"Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero."
	| canvas |
	canvas _ (Display defaultCanvasClass extent: bounds extent depth: 1)
				asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp"
	canvas translateBy: bounds topLeft negated
		during:[:tempCanvas| tempCanvas fullDrawMorph: self].
	^ canvas form offset: bounds topLeft
! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/22/1998 20:29'!
show
	"Make sure this morph is on-stage."
	self visible ifFalse: [self visible: true.  self changed]! !

!Morph methodsFor: 'drawing' stamp: 'sw 10/19/1998 22:21'!
visible
	extension ifNil: [^ true].
	^ extension visible! !

!Morph methodsFor: 'drawing' stamp: 'sw 6/9/1999 22:36'!
visible: aBoolean
	extension ifNil: [aBoolean ifTrue: [^ self]].
	self visible == aBoolean ifTrue: [^ self].
	self assureExtension visible: aBoolean.
	self changed! !


!Morph methodsFor: 'geometry' stamp: 'di 7/24/97 11:55'!
align: aPoint1 with: aPoint2
	"Translate by aPoint2 - aPoint1."

	^ self position: self position + (aPoint2 - aPoint1)! !

!Morph methodsFor: 'geometry'!
bottom

	^ bounds bottom! !

!Morph methodsFor: 'geometry' stamp: 'sw 5/5/1998 01:24'!
bottom: aNumber
	self position: (bounds left @ (aNumber - self height))! !

!Morph methodsFor: 'geometry' stamp: 'tk 9/8/97 10:44'!
bottomLeft

	^ bounds bottomLeft! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/17/1998 14:30'!
bottomLeft: aPoint
	self bottom: aPoint y.
	self left: aPoint x! !

!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:17'!
bottomRight

	^ bounds bottomRight! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/17/1998 14:08'!
bottomRight: aPoint
	self bottom: aPoint y.
	self right: aPoint x! !

!Morph methodsFor: 'geometry' stamp: 'jm 8/3/97 15:50'!
bounds
	"Return the bounds of this morph."
	"Note: It is best not to override this method because many methods in Morph and its subclasses use the instance variable directly rather than 'self bounds'. Instead, subclasses should be sure that the bounds instance variable is correct."

	^ bounds
! !

!Morph methodsFor: 'geometry' stamp: 'ar 12/14/2000 13:48'!
bounds: newBounds
	| oldExtent newExtent |
	oldExtent _ self extent.
	newExtent _ newBounds extent.
	(oldExtent dotProduct: oldExtent) <= (newExtent dotProduct: newExtent) ifTrue:[
		"We're growing. First move then resize."
		self position: newBounds topLeft; extent: newExtent.
	] ifFalse:[
		"We're shrinking. First resize then move."
		self extent: newExtent; position: newBounds topLeft.
	].! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
bounds: aRectangle from: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	owner ifNil: [^ aRectangle].
	^(owner transformFrom: referenceMorph) globalBoundsToLocal: aRectangle
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
bounds: aRectangle in: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	owner ifNil: [^ aRectangle].
	^(owner transformFrom: referenceMorph) localBoundsToGlobal: aRectangle
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:04'!
boundsIn: referenceMorph
	"Return the receiver's bounds as seen by aMorphs coordinate frame"
	^self bounds: self bounds in: referenceMorph! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:05'!
boundsInWorld
	^self bounds: self bounds in: self world! !

!Morph methodsFor: 'geometry'!
center

	^ bounds center! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'!
center: aPoint
	self position: (aPoint - (self extent // 2))! !

!Morph methodsFor: 'geometry'!
extent

	^ bounds extent! !

!Morph methodsFor: 'geometry' stamp: 'di 8/22/2000 07:45'!
extent: aPoint

	bounds extent = aPoint ifTrue: [^ self].
	self changed.
	bounds _ bounds topLeft extent: aPoint.
	self layoutChanged.
	self changed.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'!
fullBoundsInWorld
	^self bounds: self fullBounds in: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'!
globalPointToLocal: aPoint
	^self point: aPoint from: nil! !

!Morph methodsFor: 'geometry' stamp: 'di 8/25/2000 00:35'!
gridPoint: ungriddedPoint

	^ ungriddedPoint! !

!Morph methodsFor: 'geometry' stamp: 'ar 9/15/2000 14:21'!
griddedPoint: ungriddedPoint

	| griddingContext |
	self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding"
	(griddingContext _ self pasteUpMorph) ifNil: [^ ungriddedPoint].
	^ griddingContext gridPoint: ungriddedPoint! !

!Morph methodsFor: 'geometry'!
height

	^ bounds height! !

!Morph methodsFor: 'geometry' stamp: 'jm 1/29/98 14:26'!
height: aNumber

	self extent: self width@aNumber asInteger.
! !

!Morph methodsFor: 'geometry'!
innerBounds
	"Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds."

	^ bounds! !

!Morph methodsFor: 'geometry'!
left

	^ bounds left! !

!Morph methodsFor: 'geometry' stamp: 'sw 5/5/1998 01:22'!
left: aNumber
	self position: (aNumber @ bounds top)! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:07'!
localPointToGlobal: aPoint
	^self point: aPoint in: nil! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 21:59'!
minimumExtent
	| ext |
	"This returns the minimum extent that the morph may be shrunk to.  Not honored in too many places yet, but respected by the resizeToFit feature, at least.  copied up from SystemWindow 6/00"
	(ext _ self valueOfProperty: #minimumExtent)
		ifNotNil:
			[^ ext].
	^ 100 @ 80! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 22:00'!
minimumExtent: aPoint
	"Remember a minimumExtent, for possible future use"

	self setProperty: #minimumExtent toValue: aPoint
! !

!Morph methodsFor: 'geometry' stamp: 'sw 7/10/1999 17:26'!
nextOwnerPage
	"Tell my container to advance to the next page"
	| targ |
	targ _ self ownerThatIsA: BookMorph.
	targ ifNotNil: [targ nextPage]! !

!Morph methodsFor: 'geometry' stamp: 'ar 11/12/2000 22:06'!
outerBounds
	"Return the 'outer' bounds of the receiver, e.g., the bounds that need to be invalidated when the receiver changes."
	| box |
	box _ self bounds.
	self hasDropShadow ifTrue:[box _ self expandFullBoundsForDropShadow: box].
	self hasRolloverBorder ifTrue:[box _ self expandFullBoundsForRolloverBorder: box].
	^box! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'!
point: aPoint from: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'!
point: aPoint in: aReferenceMorph

	owner ifNil: [^ aPoint].
	^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint.
! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:02'!
pointFromWorld: aPoint
	^self point: aPoint from: self world! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:03'!
pointInWorld: aPoint
	^self point: aPoint in: self world! !

!Morph methodsFor: 'geometry'!
position

	^ bounds topLeft! !

!Morph methodsFor: 'geometry' stamp: 'ar 12/14/2000 13:46'!
position: aPoint
	"Change the position of this morph and and all of its submorphs."

	| delta box |
	delta _ aPoint - bounds topLeft.
	(delta x = 0 and: [delta y = 0]) ifTrue: [^ self].  "Null change"
	box _ self fullBounds.
	(delta dotProduct: delta) > 100 ifTrue:[
		"e.g., more than 10 pixels moved"
		self invalidRect: box.
		self invalidRect: (box translateBy: delta).
	] ifFalse:[
		self invalidRect: (box merge: (box translateBy: delta)).
	].
	self privateFullMoveBy: delta.! !

!Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'!
positionInWorld

	^ self pointInWorld: self position.
! !

!Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'!
positionSubmorphs
	self submorphsDo:
		[:aMorph | aMorph snapToEdgeIfAppropriate]! !

!Morph methodsFor: 'geometry' stamp: 'sw 7/10/1999 17:27'!
previousOwnerPage
	"Tell my container to advance to the previous page"
	| targ |
	targ _ self ownerThatIsA: BookMorph.
	targ ifNotNil: [targ previousPage]! !

!Morph methodsFor: 'geometry'!
right

	^ bounds right! !

!Morph methodsFor: 'geometry' stamp: 'sw 5/5/1998 01:23'!
right: aNumber
	self position: ((aNumber - bounds width) @ bounds top)! !

!Morph methodsFor: 'geometry' stamp: 'bf 1/5/2000 19:08'!
screenLocation
	"For compatibility only"

	^ self fullBounds origin! !

!Morph methodsFor: 'geometry' stamp: 'sma 2/5/2000 13:58'!
screenRectangle
	"For compatibility only"

	^ self fullBounds! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:15'!
setConstrainedPositionFrom: aPoint
	"Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds."

	| trialRect delta boundingMorph |
	owner ifNil:[^self].
	trialRect _ aPoint extent: self bounds extent.
	boundingMorph _ self topRendererOrSelf owner.
	delta _ boundingMorph
			ifNil:    [0@0]
			ifNotNil: [trialRect amountToTranslateWithin: boundingMorph bounds].
	self position: aPoint + delta.
	self layoutChanged  "So that, eg, surrounding text will readjust"
! !

!Morph methodsFor: 'geometry' stamp: 'ar 9/28/2000 13:55'!
shiftSubmorphsBy: delta
	self shiftSubmorphsOtherThan: (submorphs select: [:m | m isFlapOrTab]) by: delta! !

!Morph methodsFor: 'geometry' stamp: 'sw 2/16/1999 22:05'!
shiftSubmorphsOtherThan: listNotToShift by: delta
	| rejectList |
	rejectList _ listNotToShift ifNil: [OrderedCollection new].
	(submorphs copyWithoutAll: rejectList) do:
		[:m | m position: (m position + delta)]! !

!Morph methodsFor: 'geometry'!
top

	^ bounds top! !

!Morph methodsFor: 'geometry' stamp: 'sw 5/5/1998 01:23'!
top: aNumber
	self position: (bounds left @ aNumber)! !

!Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'!
topLeft

	^ bounds topLeft! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/17/1998 14:30'!
topLeft: aPoint
	self top: aPoint y.
	self left: aPoint x! !

!Morph methodsFor: 'geometry' stamp: 'sw 8/20/97 23:04'!
topRight

	^ bounds topRight! !

!Morph methodsFor: 'geometry' stamp: 'sw 6/17/1998 14:29'!
topRight: aPoint
	self top: aPoint y.
	self right: aPoint x! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/22/2000 18:03'!
transformedBy: aTransform
	aTransform isIdentity ifTrue:[^self].
	aTransform isPureTranslation ifTrue:[
		^self position: (aTransform localPointToGlobal: self position).
	].
	^self addFlexShell transformedBy: aTransform! !

!Morph methodsFor: 'geometry'!
width

	^ bounds width! !

!Morph methodsFor: 'geometry' stamp: 'jm 1/29/98 14:26'!
width: aNumber

	self extent: aNumber asInteger@self height.
! !

!Morph methodsFor: 'geometry' stamp: 'di 2/23/98 11:36'!
worldBounds
	^ self world bounds! !

!Morph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:16'!
worldBoundsForHalo
	"To restore older behavior, change this to return  self fullBoundsInWorld"

	^ self boundsIn: nil! !


!Morph methodsFor: 'rotate scale and flex' stamp: 'RAA 7/6/2000 12:52'!
addFlexShell
	"Wrap a rotating and scaling shell around this morph."

	| oldHalo flexMorph myWorld |

	myWorld _ self world.
	oldHalo _ self halo.
	self owner addMorph:
		(flexMorph _ self newTransformationMorph asFlexOf: self).
	self transferStateToRenderer: flexMorph.
	oldHalo ifNotNil: [oldHalo setTarget: flexMorph].
	myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph].

	^ flexMorph! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 11/24/1998 14:19'!
keepsTransform
	"Return true if the receiver will keep it's transform while being grabbed by a hand."
	^false! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'ar 2/16/1999 18:59'!
newTransformationMorph
	^TransformationMorph new! !

!Morph methodsFor: 'rotate scale and flex' stamp: 'jm 4/25/1998 05:19'!
rotationDegrees
	"Default implementation."

	^ 0.0
! !


!Morph methodsFor: 'geometry testing'!
containsPoint: aPoint

	^ self bounds containsPoint: aPoint! !

!Morph methodsFor: 'geometry testing' stamp: 'di 5/3/2000 19:05'!
fullContainsPoint: aPoint

	(self fullBounds containsPoint: aPoint) ifFalse: [^ false].  "quick elimination"
	(self containsPoint: aPoint) ifTrue: [^ true].  "quick acceptance"
	submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]].
	^ false
! !

!Morph methodsFor: 'geometry testing' stamp: 'sw 9/7/2000 12:19'!
obtrudesBeyondContainer
	"Answer whether the receiver obtrudes beyond the bounds of its container"

	| top |
	top _ self topRendererOrSelf.
	(top owner == nil or: [top owner isHandMorph]) ifTrue: [^ false].
	^ (top owner bounds containsRect: top bounds) not
	! !


!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 12:00'!
addTransparentSpacerOfSize: aPoint
	self addMorphBack: (self transparentSpacerOfSize: aPoint)! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 12:01'!
beTransparent
	self color: Color transparent! !

!Morph methodsFor: 'geometry eToy' stamp: 'RAA 11/8/2000 18:29'!
cartesianBoundsTopLeft
	"Answer the origin of this morph relative to it's container's cartesian origin. 
	NOTE: y DECREASES toward the bottom of the screen"

	| w container |

	w _ self world ifNil: [^ bounds origin].
	container _ self referencePlayfield ifNil: [w].
	^ (bounds left - container cartesianOrigin x) @
		(container cartesianOrigin y - bounds top)! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 1/17/2000 20:52'!
cartesianXY
	"Answer the receiver's x-y cartesian coordinates"
	^ self x @ self y
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 1/17/2000 20:55'!
cartesianXY: coords
	^ self x: coords x y: coords y
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/1998 15:10'!
color: sensitiveColor sees: soughtColor
	"Return true if any of my pixels of sensitiveColor intersect with pixels of soughtColor."
	| myImage sensitivePixelMask map patchBelowMe tfm morphAsFlexed i1 |
	"Make a mask with black where sensitiveColor is, white elsewhere"
	tfm _ self transformFrom: self world.
	morphAsFlexed _ tfm isIdentity
		ifTrue: [self]
		ifFalse: [TransformationMorph new
					flexing: self clone
					byTransformation: tfm].
	myImage _ morphAsFlexed imageForm offset: 0@0.
	sensitivePixelMask _ Form extent: myImage extent depth: 1.
	map _ Bitmap new: (1 bitShift: (myImage depth min: 15)).
	map at: (i1 _ sensitiveColor indexInMap: map) put: 1.
	sensitivePixelMask copyBits: sensitivePixelMask boundingBox
		from: myImage form at: 0@0 colorMap: map.

	"get an image of the world below me"
	patchBelowMe _ self world patchAt: morphAsFlexed fullBounds
								without: self andNothingAbove: false.
"
sensitivePixelMask displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with the sensitive pixels"
	map at: i1 put: 0.  "clear map and reuse it"
	map at: (soughtColor indexInMap: map) put: 1.
	sensitivePixelMask copyBits: patchBelowMe boundingBox
		from: patchBelowMe at: 0@0 clippingBox: patchBelowMe boundingBox
		rule: Form and fillColor: nil map: map.
"
sensitivePixelMask displayAt: 200@0.
"
	^ (sensitivePixelMask tallyPixelValues at: 2) > 0
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 9/9/1998 22:49'!
colorUnder
	"Return the color of under the receiver's center."

	self isInWorld
		ifTrue: [^ self world colorAt: (self pointInWorld: self referencePosition) belowMorph: self]
		ifFalse: [^ Color black].
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/2000 11:54'!
degreesOfFlex
	"Return any rotation due to flexing"
	"NOTE: because renderedMorph, which is used by the halo to set heading, goes down through dropShadows as well as transformations, we need this method (and its other implems) to come back up through such a chain."
	^ 0.0! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 14:29'!
forwardDirection: newDirection
	"Set the receiver's forward direction (in eToy terms)"
	self setProperty: #forwardDirection toValue: newDirection.! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 9/8/2000 16:35'!
getIndexInOwner
	"Answer which position the receiver holds in its owner's hierarchy"

	"NB: There is some concern about submorphs that aren't really to be counted, such as a background morph of a playfield."

	| container topRenderer |
	container _ (topRenderer _ self topRendererOrSelf) owner.
	^ container submorphIndexOf: topRenderer.! !

!Morph methodsFor: 'geometry eToy' stamp: 'tk 12/15/1998 14:03'!
goHome

	| box |
	(owner isInMemory and: [owner ~~ nil]) ifTrue: [
		self visible ifTrue: [
			box _ owner.
			self left < box left ifTrue: [self position: box left@self position y].
			self right > box right ifTrue: [self position: (box right - self width)@self position y].
			self top < box top ifTrue: [self position: self position x@box top].
			self bottom > box bottom ifTrue: [
				self position: self position x@(box bottom - self height)]]].
! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/2000 11:50'!
heading
	"Return the receiver's heading (in eToy terms)"
	owner ifNil: [^ self forwardDirection].
	^ self forwardDirection + owner degreesOfFlex! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 13:37'!
heading: newHeading
	"Set the receiver's heading (in eToy terms)"
	self isFlexed ifFalse:[self addFlexShell].
	owner rotationDegrees: (newHeading - self forwardDirection).! !

!Morph methodsFor: 'geometry eToy'!
move: aMorph toPosition: aPointOrNumber
	"Support for e-toy demo. Move the given submorph to the given position. Allows the morph's owner to determine the policy for motion. For example, moving forward through a table might mean motion only in the x-axis with wrapping modulo the table size."

	aMorph position: aPointOrNumber asPoint.
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:12'!
referencePosition
	"Return the current reference position of the receiver"
	| box |
	box _ self bounds.
	^box origin + (self rotationCenter * box extent).
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/27/2000 14:04'!
referencePosition: aPosition
	"Move the receiver to match its reference position with aPosition"
	| newPos intPos |
	newPos _ self position + (aPosition - self referencePosition).
	intPos _ newPos asIntegerPoint.
	newPos = intPos 
		ifTrue:[self position: intPos]
		ifFalse:[self position: newPos].! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/25/1999 16:49'!
referencePositionInWorld

	^ self pointInWorld: self referencePosition
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/25/1999 23:33'!
referencePositionInWorld: aPoint
	| localPosition |
	localPosition _ owner
		ifNil: [aPoint]
		ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint].

	self referencePosition: localPosition
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:10'!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	^self valueOfProperty: #rotationCenter ifAbsent:[0.5@0.5]
! !

!Morph methodsFor: 'geometry eToy' stamp: 'ar 9/22/2000 20:11'!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	aPointOrNil isNil
		ifTrue:[self removeProperty: #rotationCenter]
		ifFalse:[self setProperty: #rotationCenter toValue: aPointOrNil]
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 8/31/2000 11:18'!
setIndexInOwner: anInteger
	"Answer which position the receiver holds in its owner's hierarchy"

	"There is some concern about submorphs that aren't really to be counted, such as a background morph of a playfield."
	| container topRenderer indexToUse |
	container _ (topRenderer _ self topRendererOrSelf) owner.
	indexToUse _ (anInteger min: container submorphCount) max: 1.
	container addMorph: topRenderer asElementNumber: indexToUse! !

!Morph methodsFor: 'geometry eToy' stamp: 'di 10/1/1998 15:54'!
touchesColor: soughtColor
	"Return true if any of my pixels overlap pixels of soughtColor."
	| map patchBelowMe shadowForm tfm morphAsFlexed |
	"Make a sahdow mask with black in my shape, white elsewhere"
	tfm _ self transformFrom: self world.
	morphAsFlexed _ tfm isIdentity
		ifTrue: [self]
		ifFalse: [TransformationMorph new
					flexing: self clone
					byTransformation: tfm].
	shadowForm _ morphAsFlexed shadowForm offset: 0@0.

	"get an image of the world below me"
	patchBelowMe _ (self world patchAt: morphAsFlexed fullBounds
								without: self andNothingAbove: false) offset: 0@0.
"
shadowForm displayAt: 0@0.
patchBelowMe displayAt: 100@0.
"
	"intersect world pixels of the color we're looking for with our shape."
	map _ Bitmap new: (1 bitShift: (patchBelowMe depth min: 15)).
	map at: (soughtColor indexInMap: map) put: 1.
	shadowForm copyBits: patchBelowMe boundingBox
		from: patchBelowMe
		at: 0@0
		clippingBox: patchBelowMe boundingBox
		rule: Form and
		fillColor: nil
		map: map.
"
shadowForm displayAt: 200@0.
"
	^ (shadowForm tallyPixelValues at: 2) > 0
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 10/23/1998 11:50'!
transparentSpacerOfSize: aPoint
	^ (Morph new extent: aPoint) color: Color transparent! !

!Morph methodsFor: 'geometry eToy' stamp: 'tk 7/8/1998 23:47'!
wrap

	| myBox box newX newY wrapped |
	owner ifNil: [^ self].
	myBox _ self fullBounds.
	myBox corner < (50000@50000) ifFalse: [
		self inform: 'Who is trying to wrap a hidden object?'. ^ self].
	box _ owner bounds.
	newX _ self position x.
	newY _ self position y.
	wrapped _ false.
	((myBox right < box left) or: [myBox left > box right]) ifTrue: [
		newX _ box left + ((self position x - box left) \\ box width).
		wrapped _ true].
	((myBox bottom < box top) or: [myBox top > box bottom]) ifTrue: [
		newY _ box top + ((self position y - box top) \\ box height).
		wrapped _ true].
	self position: newX@newY.
	(wrapped and: [owner isPlayfieldLike])
		ifTrue: [owner changed].  "redraw all turtle trails if wrapped"

! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 7/7/1999 12:36'!
x
	"Return my horizontal position relative to the cartesian origin of a relevant playfield"

	| aPlayfield |
	aPlayfield _ self referencePlayfield.
	^ aPlayfield == nil
		ifTrue: [self referencePosition x]
		ifFalse: [self referencePosition x - aPlayfield cartesianOrigin x]! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 7/7/1999 12:36'!
x: aNumber
	"Set my horizontal position relative to the cartesian origin of the playfield or the world."

	|  offset  aPlayfield newX |

	aPlayfield _ self referencePlayfield.
	offset _ self left - self referencePosition x.
	aPlayfield == nil
		ifTrue: [newX _ aNumber + offset]
		ifFalse: [newX _ aPlayfield cartesianOrigin x + aNumber + offset].
	self position: newX@bounds top.

! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 1/17/2000 20:04'!
x: xCoord y: yCoord
	| aWorld xyOffset delta aPlayfield |
	(aWorld _ self world) ifNil: [^ self position: xCoord @ yCoord].
	xyOffset _ self topLeft - self referencePosition.
	delta _ (aPlayfield _ self referencePlayfield)
		ifNil:
			[xCoord @ (aWorld bottom - yCoord)]
		ifNotNil:
			[aPlayfield cartesianOrigin + (xCoord @ (yCoord negated))].
	self position: (xyOffset + delta)
! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 7/7/1999 12:37'!
y
	"Return my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen."

	| w aPlayfield |
	w _ self world.
	w ifNil: [^ bounds top].
	aPlayfield _ self referencePlayfield.

	^ aPlayfield == nil
		ifTrue: [w cartesianOrigin y - self referencePosition y]
		ifFalse: [aPlayfield cartesianOrigin y - self referencePosition y]! !

!Morph methodsFor: 'geometry eToy' stamp: 'sw 7/7/1999 12:37'!
y: aNumber
	"Set my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen."

	| w offset newY aPlayfield |

	w _ self world.
	w ifNil: [^ self position: bounds left @ aNumber].
	aPlayfield _ self referencePlayfield.
	offset _ self top - self referencePosition y.
	aPlayfield == nil
		ifTrue: [newY _ (w bottom - aNumber) + offset]
		ifFalse: [newY _ (aPlayfield cartesianOrigin y - aNumber) + offset].
	self position: bounds left @ newY.
! !


!Morph methodsFor: 'thumbnail' stamp: 'sw 10/26/2000 08:32'!
demandsThumbnailing
	"Answer whether the receiver, if in a thumbnailable parts bin, wants to be thumbnailed whether or not size requires it"

	^ false! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 8/16/2000 17:40'!
morphRepresented
	"If the receiver is an alias, answer the morph it represents; else answer self"

	^ self! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'!
permitsThumbnailing
	^ true! !

!Morph methodsFor: 'thumbnail' stamp: 'ar 11/9/2000 20:42'!
readoutForField: fieldSym
	"Provide a readout that will show the value of the slot/pseudoslot of the receiver generated by sending fieldSym to the receiver"

	| aContainer |
	"still need to get this right"
	aContainer _ AlignmentMorph newColumn.
	aContainer layoutInset: 0; hResizing: #rigid; vResizing: #shrinkWrap.
	aContainer addMorphBack: (StringMorph new contents: (self perform: fieldSym) asString).
	^ aContainer! !

!Morph methodsFor: 'thumbnail' stamp: 'sw 12/6/2000 21:28'!
representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight
	"Return a morph representing the receiver but which is no taller than aHeight.  If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth.  If the receiver personally *demands* thumbnailing, do it even if there is no size-related reason to do it."

	self demandsThumbnailing ifFalse:
		[self permitsThumbnailing ifFalse: [^ self].
		(self fullBounds height <= maxHeight and: [self fullBounds width <= maxWidth]) ifTrue: [^ self]].

	^ MorphThumbnail new extent: maxWidth @ (thumbnailHeight min: self fullBounds height); morphRepresented: self! !

!Morph methodsFor: 'thumbnail' stamp: 'tk 3/28/2000 11:08'!
updateThumbnailUrl
	"If I have a cached thumbnail, then update it's urls."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail pageMorph: self url inBook: owner url]
			ifFalse: [self removeProperty: #computeThumbnail]].
			"Test and removal are because the thumbnail is being replaced 
			by another Morph.  We don't know why.  Need to fix that at 
			the source."! !

!Morph methodsFor: 'thumbnail' stamp: 'tk 3/28/2000 21:55'!
updateThumbnailUrlInBook: bookUrl
	"If I have a cached thumbnail, then update it's urls."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail pageMorph: self url inBook: bookUrl]
			ifFalse: [self removeProperty: #computeThumbnail]].
			"Test and removal are because the thumbnail is being replaced 
			by another Morph.  We don't know why.  Need to fix that at 
			the source."! !


!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:00'!
aboutToBeGrabbedBy: aHand
	"The receiver is being grabbed by a hand.
	Perform necessary adjustments (if any) and return the actual morph
	that should be added to the hand."
	| extentToHandToHand cmd |
	self formerOwner: owner.
	self formerPosition: self position.
	cmd _ self undoGrabCommand.
	cmd ifNotNil:[self setProperty: #undoGrabCommand toValue: cmd].
	(extentToHandToHand _ self valueOfProperty: #expandedExtent)
			ifNotNil:
				[self removeProperty: #expandedExtent.
				self extent: extentToHandToHand].
	^self "Grab me"! !

!Morph methodsFor: 'dropping/grabbing'!
asDraggableMorph
	^self! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'!
disableDragNDrop
	self enableDragNDrop: false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'!
dragEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dragEnabled) == true
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'!
dragEnabled: aBool
	^self enableDrag: aBool! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:20'!
dragNDropEnabled
	"Note: This method is only useful for dragEnabled == dropEnabled at all times"
	self separateDragAndDrop.
	^self dragEnabled and:[self dropEnabled]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:36'!
dragSelectionColor
	^ Color magenta! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'!
dropEnabled
	"Get this morph's ability to add and remove morphs via drag-n-drop."
	^(self valueOfProperty: #dropEnabled) == true
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'!
dropEnabled: aBool
	^self enableDrop: aBool! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:52'!
dropHighlightColor
	^ Color blue! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:08'!
dropSuccessColor
	^ Color blue! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'!
enableDrag: aBoolean
	self setProperty: #dragEnabled toValue: aBoolean! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'!
enableDragNDrop
	self enableDragNDrop: true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:21'!
enableDragNDrop: aBoolean
	"Set both properties at once"
	self separateDragAndDrop.
	self enableDrag: aBoolean.
	self enableDrop: aBoolean.! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'!
enableDrop: aBoolean
	self setProperty: #dropEnabled toValue: aBoolean! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'!
formerOwner
	^self valueOfProperty: #formerOwner! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'!
formerOwner: aMorphOrNil
	aMorphOrNil == nil
		ifTrue:[self removeProperty: #formerOwner]
		ifFalse:[self setProperty: #formerOwner toValue: aMorphOrNil]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'!
formerPosition
	^self valueOfProperty: #formerPosition! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:12'!
formerPosition: formerPosition
	formerPosition == nil
		ifTrue:[self removeProperty: #formerPosition]
		ifFalse:[self setProperty: #formerPosition toValue: formerPosition]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 15:13'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 11:51'!
highlightForDrop
	self highlightForDrop: true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:01'!
highlightForDrop: aBoolean
	self setProperty: #highlightedForDrop toValue: aBoolean.
	self changed! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:53'!
highlightedForDrop
	^(self valueOfProperty: #highlightedForDrop) == true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 10/26/2000 13:06'!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"

	| aWindow partsBinCase cmd aStack |
	self formerOwner: nil.
	self formerPosition: nil.
	cmd _ self valueOfProperty: #undoGrabCommand.
	cmd ifNotNil:[aMorph rememberCommand: cmd.
				self removeProperty: #undoGrabCommand].
	(partsBinCase _ aMorph isPartsBin) ifFalse:
		[self isPartsDonor: false].
	(aWindow _ aMorph ownerThatIsA: SystemWindow) ifNotNil:
		[aWindow isActive ifFalse:
			[aWindow activate]].
	(self isInWorld and: [partsBinCase not]) ifTrue:
		[self world startSteppingSubmorphsOf: self].
	"Note an unhappy inefficiency here:  the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage."

	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[aStack reassessBackgroundShape]
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 14:35'!
rejectDropMorphEvent: evt
	"The receiver has been rejected, and must be put back somewhere.  There are three cases:
	(1)  It remembers its former owner and position, and goes right back there
	(2)  It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes.
	(3)  Neither former owner nor position is remembered, in which case it is whisked to the Trash"

	self removeProperty: #undoGrabCommand.
	(self formerOwner notNil and: [self formerOwner isPartsBin not]) ifTrue:
		[^ self slideBackToFormerSituation: evt].

	self formerPosition ifNotNil:  "Position but no owner -- can just make it vanish"
		[^ self vanishAfterSlidingTo: self formerPosition event: evt].
		
	self slideToTrash: evt! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'!
repelsMorph: aMorph event: ev
	^ false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:02'!
resetHighlightForDrop
	self highlightForDrop: false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'!
separateDragAndDrop
	"Conversion only. Separate the old #dragNDropEnabled into #dragEnabled and #dropEnabled and remove the old property."
	| dnd |
	(self hasProperty: #dragNDropEnabled) ifFalse:[^self].
	dnd _ (self valueOfProperty: #dragNDropEnabled) == true.
	self dragEnabled: dnd.
	self dropEnabled: dnd.
	self removeProperty: #dragNDropEnabled.
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:19'!
slideBackToFormerSituation: evt

	| slideForm formerOwner formerPosition aWorld startPoint endPoint trans |
	formerOwner _ self formerOwner.
	formerPosition _ self formerPosition.
	aWorld _ self world.

	trans _ formerOwner transformFromWorld.
	trans isPureTranslation 
		ifTrue: [slideForm _ self imageForm offset: 0@0]
		ifFalse: [slideForm _ ((TransformationMorph new asFlexOf: self) transform: trans)
								imageForm offset: 0@0].

	startPoint _ evt hand fullBounds origin.
	endPoint _ trans localPointToGlobal: formerPosition.
	owner privateRemoveMorph: self.
	aWorld displayWorld.
	slideForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15.
	formerOwner addMorph: self.
	self position: formerPosition.
	self justDroppedInto: formerOwner event: evt.
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'bf 1/5/2000 19:10'!
slideToTrash: evt

	| aForm aWorld trash startPoint endPoint |
	aForm _ self imageForm offset: 0@0.
	aWorld _ self world.
	trash _ aWorld findA: TrashCanMorph.
	trash ifNil: [^ self].
	startPoint _ evt hand fullBounds origin.
	endPoint _ trash position.
	self delete.
	aWorld displayWorld.
	aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15.
	trash acceptDroppingMorph: self event: evt.
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'mir 1/4/2001 11:02'!
startDrag: anItem with: anObject
	self currentHand attachMorph: anObject! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:46'!
toggleDragNDrop
	"Toggle this morph's ability to add and remove morphs via drag-n-drop."

		self enableDragNDrop: self dragNDropEnabled not.
! !

!Morph methodsFor: 'dropping/grabbing'!
transportedMorph
	^self! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'tk 1/3/2001 12:46'!
undoGrabCommand
	"Return the undo command for grabbing the receiver"
	| cmd |
	owner ifNil:[^nil]. "no owner - no undo"
	^(cmd _ Command new)
		cmdWording: 'move ', (String streamContents: [:s | self printOn: s] limitedTo: 18);
		undoTarget: self
		selector: #undoMove:redo:owner:bounds:predecessor:
		arguments: {cmd. false. owner. self bounds. (owner morphPreceding: self)}! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'bf 1/5/2000 19:11'!
vanishAfterSlidingTo: aPosition event: evt

	| aForm aWorld startPoint endPoint |
	aForm _ self imageForm offset: 0@0.
	aWorld _ self world.
	startPoint _ evt hand fullBounds origin.
	self delete.
	aWorld displayWorld.
	endPoint _ aPosition.
	aForm slideFrom: startPoint  to: endPoint nSteps: 12 delay: 15.
	Preferences soundsEnabled ifTrue: [TrashCanMorph playDeleteSound].
! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:24'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. Note that for a successful drop operation both parties need to agree. The symmetric check is done automatically via aMorph wantsToBeDroppedInto: self."

	^self dropEnabled! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph. This check is symmetric to #wantsDroppedMorph:event: to give both parties a chance of figuring out whether they like each other."
	^true! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/10/1999 05:44'!
wantsToBeOpenedInWorld
	"Return true if the receiver wants to be put into the World directly,
	rather than allowing the user to place it (e.g., prevent attaching me
	to the hand after choosing 'new morph' in the world menu)"
	^false! !

!Morph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 16:58'!
willingToBeDiscarded
	^ true! !


!Morph methodsFor: 'event handling' stamp: 'tk 9/6/2000 12:42'!
click
	"Pretend the user clicked on me."

	(self handlesMouseDown: nil) ifTrue: [
		self mouseDown: nil.
		self mouseUp: nil].! !

!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'!
click: evt
	"Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
	LC 2/14/2000 08:32 - added: EventHandler notification"

	self eventHandler ifNotNil:
		[self eventHandler click: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'sw 3/8/1999 00:17'!
cursorPoint
	^ self currentHand lastEvent cursorPoint! !

!Morph methodsFor: 'event handling' stamp: 'LC 5/18/2000 09:54'!
doubleClick: evt
	"Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing.
	LC 2/14/2000 08:32 - added: EventHandler notification"

	self eventHandler ifNotNil:
		[self eventHandler doubleClick: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'!
dropFiles: anEvent
	"Handle a number of files dropped from the OS"
! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/28/2000 22:18'!
handlesKeyboard: evt
	"Return true if the receiver wishes to handle the given keyboard event"
	self eventHandler ifNotNil: [^ self eventHandler handlesKeyboard: evt].
	^ false
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:04'!
handlesMouseDown: evt
	"Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?"
	"NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism.  Subclasses that implement these messages directly should override this one to return true." 

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt].
	^ false
! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'!
handlesMouseOver: evt
	"Do I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty?  The default response is false, except if you have added sensitivity to mouseEnter: or mouseLeave:, using the on:send:to: mechanism." 

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseOver: evt].
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:31'!
handlesMouseOverDragging: evt
	"Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient.  The default response is false, except if you have added sensitivity to mouseEnterLaden: or mouseLeaveLaden:, using the on:send:to: mechanism."
	"NOTE:  If the hand state matters in these cases, it may be tested by constructs such as
		event anyButtonPressed
		event hand hasSubmorphs"

	self eventHandler ifNotNil: [^ self eventHandler handlesMouseOverDragging: evt].
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:06'!
handlesMouseStillDown: evt
	"Return true if the receiver wants to get repeated #mouseStillDown: messages between #mouseDown: and #mouseUp"
	self eventHandler ifNotNil: [^ self eventHandler handlesMouseStillDown: evt].
	^ false
! !

!Morph methodsFor: 'event handling' stamp: 'sw 4/2/98 14:16'!
hasFocus
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 18:23'!
keyDown: anEvent
	"Handle a key down event. The default response is to do nothing."! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'!
keyStroke: anEvent
	"Handle a keystroke event.  The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler keyStroke: anEvent fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 18:23'!
keyUp: anEvent
	"Handle a key down event. The default response is to do nothing."! !

!Morph methodsFor: 'event handling'!
keyboardFocusChange: aBoolean
	"The message is sent to a morph when its keyboard focus change. The given argument indicates that the receiver is gaining keyboard focus (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing."! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:04'!
mouseDown: evt
	"Handle a mouse down event. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseDown: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:00'!
mouseEnter: evt
	"Handle a mouseEnter event, meaning the mouse just entered my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseEnter: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:33'!
mouseEnterDragging: evt
	"Handle a mouseEnterDragging event, meaning the mouse just entered my bounds with a button pressed or laden with submorphs.  The default response is to let my eventHandler, if any, handle it, or else to do nothing."

	self eventHandler ifNotNil:
		[^ self eventHandler mouseEnterDragging: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'!
mouseLeave: evt
	"Handle a mouseLeave event, meaning the mouse just left my bounds with no button pressed. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseLeave: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:38'!
mouseLeaveDragging: evt
	"Handle a mouseLeaveLaden event, meaning the mouse just left my bounds with a button pressed or laden with submorphs. The default response is to let my eventHandler, if any, handle it; else to do nothing."

	self eventHandler ifNotNil:
		[self eventHandler mouseLeaveDragging: evt fromMorph: self]! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:04'!
mouseMove: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."
	self eventHandler ifNotNil:
		[self eventHandler mouseMove: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/22/2000 17:08'!
mouseStillDown: evt
	"Handle a mouse move event. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseStillDown: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:02'!
mouseStillDownThreshold
	"Return the number of milliseconds after which mouseStillDown: should be sent"
	^200! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:05'!
mouseUp: evt
	"Handle a mouse up event. The default response is to let my eventHandler, if any, handle it."

	self eventHandler ifNotNil:
		[self eventHandler mouseUp: evt fromMorph: self].
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:01'!
on: eventName send: selector to: recipient
	self eventHandler ifNil: [self eventHandler: EventHandler new].
	self eventHandler on: eventName send: selector to: recipient! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:04'!
on: eventName send: selector to: recipient withValue: value
	"NOTE: selector must take 3 arguments, of which value will be the 3rd"

	self eventHandler ifNil: [self eventHandler: EventHandler new].
	self eventHandler on: eventName send: selector to: recipient withValue: value
! !

!Morph methodsFor: 'event handling' stamp: 'tk 8/10/1998 16:02'!
removeLink: actionCode
	self eventHandler ifNotNil:
		[self eventHandler on: actionCode send: nil to: nil]! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:06'!
restoreSuspendedEventHandler
	| savedHandler |
	(savedHandler _ self valueOfProperty: #suspendedEventHandler) ifNotNil:
		[self eventHandler: savedHandler].
	submorphs do: [:m | m restoreSuspendedEventHandler]
! !

!Morph methodsFor: 'event handling' stamp: 'mir 5/23/2000 17:43'!
startDrag: evt
	"Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing."

	self eventHandler ifNotNil:
		[self eventHandler startDrag: evt fromMorph: self].! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/16/1998 08:07'!
suspendEventHandler
	self eventHandler ifNotNil:
		[self setProperty: #suspendedEventHandler toValue: self eventHandler.
		self eventHandler: nil].
	submorphs do: [:m | m suspendEventHandler].  "All those rectangles"! !

!Morph methodsFor: 'event handling' stamp: 'ar 9/14/2000 17:48'!
transformFrom: uberMorph
	"Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil. 
	Note:  This method cannot be used to map into the receiver's coordinate system!!"
	(self == uberMorph or:[owner == nil]) ifTrue:[^IdentityTransform new].
	^ owner transformFrom: uberMorph
! !

!Morph methodsFor: 'event handling' stamp: 'RAA 6/19/2000 07:13'!
transformFromOutermostWorld
	"Return a transform to map world coordinates into my local coordinates"

	"self isWorldMorph ifTrue: [^ MorphicTransform identity]."
	^ self transformFrom: self outermostWorldMorph! !

!Morph methodsFor: 'event handling'!
transformFromWorld
	"Return a transform to map world coordinates into my local coordinates"

	^ self transformFrom: nil! !

!Morph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:28'!
wantsDropFiles: anEvent
	"Return true if the receiver wants files dropped from the OS."
	^false! !

!Morph methodsFor: 'event handling' stamp: 'di 9/14/2000 11:46'!
wantsEveryMouseMove
	"Unless overridden, this method allows processing to skip mouse move events
	when processing is lagging.  No 'significant' event (down/up, etc) will be skipped."

	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 11/3/97 02:11'!
wantsKeyboardFocusFor: aSubmorph
	"Answer whether a plain mouse click on aSubmorph, a text-edit-capable thing, should result in a text selection there"
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 5/6/1998 12:54'!
wouldAcceptKeyboardFocus
	"Answer whether a plain mouse click on the receiver should result in a text selection there"
	^ false! !

!Morph methodsFor: 'event handling' stamp: 'sw 8/29/2000 14:57'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver is in the running as the new keyboard focus if the tab key were hit at a meta level.  This provides the leverage for tabbing among fields of a card, for example."

	^ false! !


!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
choosePenColor: evt
	self assuredPlayer choosePenColor: evt! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
choosePenSize
	self assuredPlayer choosePenSize! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenColor
	^ self player ifNotNil: [self actorState getPenColor] ifNil: [Color green]! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenDown
	self player ifNil: [^ false].
	^ self actorState getPenDown! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:53'!
getPenSize
	self player ifNil: [^ 1].
	^ self actorState getPenSize! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
liftPen
	self assuredPlayer liftPen! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
lowerPen
	self assuredPlayer lowerPen! !

!Morph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:46'!
penColor: aColor
	self assuredPlayer penColor: aColor! !

!Morph methodsFor: 'pen' stamp: 'di 9/3/1998 10:38'!
penUpWhile: changeBlock 
	"Suppress any possible pen trail during the execution of changeBlock"
	self getPenDown
		ifTrue: ["If this is a costume for a player with its pen down, suppress any line."
				self liftPen.
				changeBlock value.
				self lowerPen]
		ifFalse: ["But usually, just do it."
				changeBlock value]! !

!Morph methodsFor: 'pen' stamp: 'di 9/10/1998 16:18'!
trailMorph
	"You can't draw trails on me, but try my owner."
	owner == nil ifTrue: [^ nil].
	^ owner trailMorph! !


!Morph methodsFor: 'naming' stamp: 'di 4/26/1998 10:29'!
choosePartName
	"Pick an unused name for this morph."
	| className |
	(self world model isKindOf: Component) ifTrue:
		[self knownName ifNil: [^ self nameMeIn: self world]
					ifNotNil: [^ self renameMe]].
	className _ self class name.
	(className size > 5 and: [className endsWith: 'Morph'])
		ifTrue: [className _ className copyFrom: 1 to: className size - 5].
	^ self world model addPartNameLike: className withValue: self! !

!Morph methodsFor: 'naming' stamp: 'sw 1/25/2000 13:24'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver.  The default is to let the class specify, but certain instances will want to override.  (PasteUpMorphs serving as Worlds come to mind"

	^ self class defaultNameStemForInstances! !

!Morph methodsFor: 'naming' stamp: 'sw 10/31/2000 09:28'!
downshiftedNameOfObjectRepresented
	"Answer the downshiped version of the external name of the object represented"

	^ self nameOfObjectRepresented asLowercase! !

!Morph methodsFor: 'naming' stamp: 'sw 10/30/1998 14:46'!
externalName
	^ self knownName ifNil: [self innocuousName]! !

!Morph methodsFor: 'naming' stamp: 'sw 1/25/2000 13:29'!
innocuousName
	"Choose an innocuous name for the receiver -- one that does not end in the word Morph"

	| className allKnownNames |
	className _ self defaultNameStemForInstances.
	(className size > 5 and: [className endsWith: 'Morph'])
		ifTrue: [className _ className copyFrom: 1 to: className size - 5].
	className _ className asString.
	allKnownNames _ self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames].
	^ Utilities keyLike: className asString satisfying:
		[:aName | (allKnownNames includes: aName) not]! !

!Morph methodsFor: 'naming' stamp: 'di 8/11/1998 22:10'!
knownName
	extension == nil ifTrue: [^ nil].
	^ extension externalName! !

!Morph methodsFor: 'naming' stamp: 'sw 11/3/97 01:57'!
name: aName
	(aName isKindOf: String) ifTrue:
		[self setNameTo: aName]! !

!Morph methodsFor: 'naming' stamp: 'sw 9/21/2000 13:18'!
nameForFindWindowFeature
	"Answer the name to show in a list of windows-and-morphs to represent the receiver"

	^ self knownName ifNil: [self class name]! !

!Morph methodsFor: 'naming'!
nameInModel
	"Return the name for this morph in the underlying model or nil."

	| w |
	w _ self world.
	w == nil
		ifTrue: [^ nil]
		ifFalse: [^ w model nameFor: self].
! !

!Morph methodsFor: 'naming' stamp: 'sw 10/31/2000 09:24'!
nameOfObjectRepresented
	"Answer the external name of the object represented"

	^ self externalName! !

!Morph methodsFor: 'naming' stamp: 'tk 1/31/2001 15:52'!
renameTo: aName
	"Set Player name in costume.  Update Viewers.  Fix all tiles (old style).  fix References.  New tiles: recompile, and recreate open scripts.  If coming in from disk, and have name conflict, References will already have new name."
	| aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName ut |
	oldName _ self knownName.
	(renderer _ self topRendererOrSelf) setNameTo: aName.
	putInViewer _ false.
	((aPresenter _ self presenter) isNil or: [renderer player isNil]) ifFalse:
		[putInViewer _ aPresenter currentlyViewing: renderer player.
		putInViewer ifTrue:
			[renderer player viewerFlapTab hibernate]].  "empty it temporarily"
	(aPasteUp _ self topPasteUp) ifNotNil:
		[aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]].

	"Fix References dictionary.  See restoreReferences to know why oldKey is 
		already aName, but oldName is the old name."
	oldKey _ References keyAtIdentityValue: renderer player ifAbsent: [nil].
	oldKey ifNotNil:
		[assoc _ References associationAt: oldKey.
		oldKey = aName ifFalse: ["normal rename"
			assoc key: aName asSymbol.
			References rehash]].

	putInViewer ifTrue: [aPresenter viewMorph: self].	"recreate my viewer"
	oldKey ifNil: [^ aName].

	"Force strings in tiles to be remade with new name.  New tiles only."
	ut _ aPasteUp 
		ifNil: [self player isUniversalTiles]
		ifNotNil: [aPasteUp valueOfProperty: #universalTiles ifAbsent: [false]].
	ut ifFalse: [^ aName].
	classes _ (Smalltalk allCallsOn: assoc) collect: [:classAndMethod | 
		(classAndMethod findTokens: Character separators) first asSymbol].
	(classes asSet) do: [:clsName |
		(Smalltalk at: clsName) replaceSilently: oldName to: aName].
		"replace in text body of all methods.  Can be wrong!!"
	"Redo the tiles that are showing.  This is also done in caller in unhibernate."
	aPasteUp ifNotNil: [
		aPasteUp allTileScriptingElements do: [:mm | "just ScriptEditorMorphs".
			(mm isKindOf: ScriptEditorMorph) ifTrue:
				[((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc)
					ifTrue: [mm hibernate; unhibernate]]]].
	^ aName! !

!Morph methodsFor: 'naming' stamp: 'di 8/11/1998 22:11'!
setNamePropertyTo: aName
	extension == nil ifTrue: [self assureExtension].
	extension externalName: aName! !

!Morph methodsFor: 'naming' stamp: 'sw 9/7/1999 16:31'!
setNameTo: aName
	| nameToUse nameString |
	nameToUse _ aName ifNotNil:
		[(nameString _ aName asString) size > 0 ifTrue: [nameString] ifFalse: ['É']].
	self setNamePropertyTo: nameToUse "no Texts here!!"! !

!Morph methodsFor: 'naming' stamp: 'tk 8/10/1998 16:00'!
specialNameInModel
	"Return the name for this morph in the underlying model or nil."
	"Not an easy problem.  For now, take the first part of the mouseDownSelector symbol in my eventHandler (fillBrushMouseUp:morph: gives 'fillBrush').  5/26/97 tk"

	| hh |
	(self isKindOf: MorphicModel)
		ifTrue: [^ self slotName]
		ifFalse: [
			self eventHandler ifNotNil: [
				self eventHandler mouseDownSelector ifNotNil: [
					hh _ self eventHandler mouseDownSelector indexOfSubCollection: 'Mouse' 
								startingAt: 1.
					hh > 0 ifTrue: [^ self eventHandler mouseDownSelector copyFrom: 1 to: hh-1]].
				self eventHandler mouseUpSelector ifNotNil: [
					hh _ self eventHandler mouseUpSelector indexOfSubCollection: 'Mouse' 
								startingAt: 1.
					hh > 0 ifTrue: [^ self eventHandler mouseUpSelector copyFrom: 1 to: hh-1]].
				]].

			"	(self eventHandler mouseDownRecipient respondsTo: #nameFor:) ifTrue: [
					^ self eventHandler mouseDownRecipient nameFor: self]]].	"
			"myModel _ self findA: MorphicModel.
			myModel ifNotNil: [^ myModel slotName]"
	
	^ self world specialNameInModelFor: self
! !

!Morph methodsFor: 'naming' stamp: 'sw 10/27/2000 17:47'!
tryToRenameTo: aName
	"A new name has been submited; make sure it's appropriate, and react accordingly.  This circumlocution provides the hook by which the simple renaming of a field can result in a change to variable names in a stack, etc.  There are some problems to worry about here."

	| aStack |
	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[self topRendererOrSelf setNameTo: aName.
			aStack reassessBackgroundShape]
		ifFalse:
			[self renameTo: aName]! !

!Morph methodsFor: 'naming' stamp: 'sw 1/29/2001 02:49'!
updateAllScriptingElements
	"A sledge-hammer sweep from the world down to make sure that all live scripting elements are up to date.  Presently in eclipse, not sent at the moment."

	| aPasteUp |
	(aPasteUp _ self topPasteUp) ifNotNil:
		[aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]! !


!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:27'!
arrangeToStartStepping
	"Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does"

	self arrangeToStartSteppingIn: self world! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:26'!
arrangeToStartSteppingIn: aWorld
	"Start getting sent the 'step' message in aWorld.  Like startSteppingIn:, but without the initial one to get started'"
	aWorld ifNotNil:
		[aWorld startStepping: self.
		self changed]! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:28'!
isStepping
	"Return true if the receiver is currently stepping in its world"
	| aWorld |
	^ (aWorld _ self world)
		ifNil:		[false]
		ifNotNil:	[aWorld isStepping: self]! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:43'!
isSteppingSelector: aSelector
	"Return true if the receiver is currently stepping in its world"
	| aWorld |
	^ (aWorld _ self world)
		ifNil:		[false]
		ifNotNil:	[aWorld isStepping: self selector: aSelector]! !

!Morph methodsFor: 'stepping and presenter'!
start
	"Start running my script. For ordinary morphs, this means start stepping."

	self startStepping.
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 1/31/2001 13:07'!
startStepping
	"Start getting sent the 'step' message."
	self startStepping: #stepAt: at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:36'!
startStepping: aSelector at: scheduledTime arguments: args stepTime: stepTime
	"Start stepping the receiver"
	| w |
	w _ self world.
	w ifNotNil: [
		w startStepping: self at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.
		self changed].! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 7/19/1998 11:51'!
startSteppingIn: aWorld
	"Start getting sent the 'step' message in aWorld"

	self step.  "one to get started!!"
	aWorld ifNotNil: [aWorld startStepping: self].
	self changed! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 10/22/2000 16:42'!
startSteppingSelector: aSelector
	"Start getting sent the 'step' message."
	self startStepping: aSelector at: Time millisecondClockValue arguments: nil stepTime: nil.! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 5/25/2000 22:48'!
step
	| aPlayer |
	"Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message.  The generic version dispatches control to the player, if any.  The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph.  In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing."

	(aPlayer _ self player) ifNotNil: 
		[(owner notNil and: [owner isRenderer not]) ifTrue:
			[aPlayer step]]
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/20/1999 15:20'!
stepAt: millisecondClockValue
	"Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message.
	The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch.
	Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value"
	
	self step
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'RAA 1/16/2001 17:20'!
stepTime
	"Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second."

	^ self topRendererOrSelf player ifNotNil: [10] ifNil: [1000]! !

!Morph methodsFor: 'stepping and presenter'!
stop
	"Stop running my script. For ordinary morphs, this means stop stepping."

	self stopStepping.
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'!
stopStepping
	"Stop getting sent the 'step' message."

	| w |
	w _ self world.
	w ifNotNil: [w stopStepping: self].
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'ar 12/15/2000 00:00'!
stopSteppingSelector: aSelector
	"Stop getting sent the given message."
	| w |
	w _ self world.
	w ifNotNil: [w stopStepping: self selector: aSelector].
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/11/1999 12:59'!
stopSteppingSelfAndSubmorphs
	self allMorphsDo: [:m | m stopStepping]
! !

!Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/19/1999 08:31'!
wantsSteps
	"Return true if the receiver overrides the default Morph step method."
	"Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph."

	| c |
	self isPartsDonor ifTrue: [^ false].
	self player wantsSteps ifTrue: [^ true].
	c _ self class.
	[c includesSelector: #step] whileFalse: [c _ c superclass].
	^ c ~= Morph! !


!Morph methodsFor: 'menus' stamp: 'sw 5/15/2000 00:29'!
absorbStateFromRenderer: aRenderer 
	| current |
	"Transfer knownName, actorState, and player info over from aRenderer, which was formerly imposed above me as a transformation shell but is now going away."

	(current _ aRenderer actorStateOrNil) ifNotNil:
		[self actorState: current.
		aRenderer actorState: nil].

	(current _ aRenderer knownName) ifNotNil:
		[self setNameTo: current.
		aRenderer setNameTo: nil].

	(current _ aRenderer player) ifNotNil:
		[self player: current.
		current rawCostume: self.
		aRenderer player: nil]! !

!Morph methodsFor: 'menus' stamp: 'sw 1/29/2001 02:50'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	"Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo."

	| unlockables aPlayer |
	aMenu addLine.
	self maybeAddCollapseItemTo: aMenu.

	aMenu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	aMenu addLine.
	aMenu add: 'copy Postscript' action: #clipPostscript.
	aMenu add: 'print PS to file...' target: self selector: #printPSToFile.

	(aPlayer _ self topRendererOrSelf player) ifNotNil:
		[aMenu addLine.
		aMenu add: 'make a sibling instance' target: self action: #makeNewPlayerInstance:.
		aMenu balloonTextForLastItem: 'Makes another morph whose player is of the same class as this one.  Both siblings will share the same scripts'.

		aMenu add: 'make multiple siblings...' target: self action: #makeMultipleSiblings:.
		aMenu balloonTextForLastItem: 'Make any number of sibling instances all at once'.

		(aPlayer belongsToUniClass and: [aPlayer class instanceCount > 1]) ifTrue:
			[aMenu add: 'make all siblings look like me' target: self action: #makeSiblingsLookLikeMe:.
			aMenu balloonTextForLastItem: 'make all my sibling instances look like me.'.

			aMenu add: 'bring all siblings to my location' target: self action: #bringAllSiblingsToMe:.
			aMenu balloonTextForLastItem: 'find all sibling instances and bring them to me'.

			aMenu add: 'apply status to all siblngs' target: self action: #applyStatusToAllSiblings:.
			aMenu balloonTextForLastItem: 'apply the current status of all of my scripts to the scripts of all my siblings']].
	aMenu addLine.

	self addFillStyleMenuItems: aMenu hand: aHandMorph.
	self addDropShadowMenuItems: aMenu hand: aHandMorph.
	self addLayoutMenuItems: aMenu hand: aHandMorph.
	aMenu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
	aMenu addLine.
	self potentialEmbeddingTargets size > 1 ifTrue:
		[aMenu add: 'embed...' target: self action: #embedInto:].

	aMenu defaultTarget: self.
	aMenu addUpdating: #lockedString action: #lockUnlockMorph.
	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size == 1 ifTrue:
		[aMenu add: 'unlock "', unlockables first externalName, '"' action: #unlockContents].
	unlockables size > 1 ifTrue:
		[aMenu add: 'unlock all contents' action: #unlockContents.
		aMenu add: 'unlock...' action: #unlockOneSubpart].

	aMenu
		defaultTarget: self;
		add: 'add mouse up action' action: #addMouseUpAction;
		add: 'remove mouse up action' action: #removeMouseUpAction.

	aMenu addLine.

	(owner notNil and: [owner isStackBackground]) ifTrue:
		[self isShared
			ifFalse:
				[aMenu add: 'put onto Background' target: self action: #putOnBackground]
			ifTrue:
				[aMenu add: 'remove from Background' target: self action: #putOnForeground.
				self couldHoldSeparateDataForEachInstance ifTrue:
					[self holdsSeparateDataForEachInstance
						ifFalse:
							[aMenu add: 'start holding separate data for each instance' target: self action: #makeHoldSeparateDataForEachInstance]
						ifTrue:
							[aMenu add: 'stop holding separate data for each instance' target: self action: #stopHoldingSeparateDataForEachInstance].
							aMenu add: 'be default value on new card' target: self action: #setAsDefaultValueForNewCard.
							(self hasProperty: #thumbnailImage)
								ifTrue:
									[aMenu add: 'stop using for reference thumbnail' target: self action: #stopUsingForReferenceThumbnail]
								ifFalse:
									[aMenu add: 'start using for reference thumbnail' target: self action: #startUsingForReferenceThumbnail]]].
				aMenu addLine].

	aMenu defaultTarget: self topRendererOrSelf.
	aMenu add: 'draw new path' action: #definePath.
	(self hasProperty: #pathPoints) ifTrue:
		[aMenu add: 'follow path' action: #followPath.
		aMenu add: 'delete path' action: #deletePath].

	(owner == nil) ifFalse:
		[aMenu add: 'send to back' action: #goBehind.
		aMenu add: 'bring to front' action: #comeToFront].

	aMenu defaultTarget: aHandMorph.
! !

!Morph methodsFor: 'menus' stamp: 'sw 4/27/1998 03:44'!
addCustomHaloMenuItems: aMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand from the halo.  To get started, we defer to the counterpart method used with the option-menu, but in time we can have separate menu choices for halo-menus and for option-menus"

	self addCustomMenuItems: aMenu hand: aHandMorph! !

!Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	| realOwner realMorph |
	"Add morph-specific items to the given menu which was invoked by the given hand.  Note the special-casing of Worlds, for which some of the the otherwise generic items are excluded."
	aCustomMenu addUpdating: #hasDragAndDropEnabledString action: #changeDragAndDrop.

	self isWorldMorph
		ifFalse:
			[(self isKindOf: SystemWindow)
				ifFalse: [aCustomMenu add: 'put in a window' action: #embedInWindow].
			aCustomMenu addUpdating: #stickinessString target: self action: #toggleStickiness.
			aCustomMenu add: 'adhere to edge...' action: #adhereToEdge]
		ifTrue:
			[aCustomMenu add: 'desktop menu...' target: self action: #putUpDesktopMenu:.
			aCustomMenu addLine].

	Preferences noviceMode ifFalse:
		[self addDebuggingItemsTo: aCustomMenu hand: aHandMorph].

	realOwner _ (realMorph _ self topRendererOrSelf) owner.
	(realOwner isKindOf: TextPlusPasteUpMorph) ifTrue:
		[aCustomMenu add: 'GeeMail stuff...' subMenu: (realOwner textPlusMenuFor: realMorph)]! !

!Morph methodsFor: 'menus' stamp: 'bf 10/18/1999 17:12'!
addFillStyleMenuItems: aMenu hand: aHand
	"Add the items for changing the current fill style of the Morph"
	| menu |
	self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' target: self action: #changeColor].
	menu _ MenuMorph new defaultTarget: self.
	self fillStyle addFillStyleMenuItems: menu hand: aHand from: self.
	menu addLine.
	menu add: 'solid fill' action: #useSolidFill.
	menu add: 'gradient fill' action: #useGradientFill.
	menu add: 'bitmap fill' action: #useBitmapFill.
	menu add: 'default fill' action: #useDefaultFill.
	aMenu add: 'fill style' subMenu: menu.
	"aMenu add: 'change color...' action: #changeColor"! !

!Morph methodsFor: 'menus' stamp: 'di 3/19/2000 13:41'!
addPaintingItemsTo: aMenu hand: aHandMorph
	| subMenu movies |
	subMenu _ MenuMorph new defaultTarget: self.

	subMenu add: 'repaint' action: #editDrawing.
	subMenu add: 'set rotation center' action: #setRotationCenter.
	subMenu add: 'reset forward-direction' action: #resetForwardDirection.
	subMenu add: 'set rotation style' action: #setRotationStyle.
	subMenu add: 'erase pixels of color' action: #erasePixelsOfColor:.
	subMenu add: 'recolor of pixels of color' action: #recolorPixelsOfColor:.
	movies _
		(self world rootMorphsAt: aHandMorph targetOffset)
			select: [:m | (m isKindOf: MovieMorph) or:
						[m isKindOf: SketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' action: #insertIntoMovie:].
	aMenu add: 'painting...' subMenu: subMenu! !

!Morph methodsFor: 'menus' stamp: 'sw 6/19/1999 23:15'!
addTitleForHaloMenu: aMenu
	aMenu addTitle: self externalName! !

!Morph methodsFor: 'menus' stamp: 'RAA 6/12/2000 09:02'!
adhereToEdge
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	#(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none)
		do: [:each |
			each == #-
				ifTrue: [menu addLine]
				ifFalse: [menu add: each asString selector: #setToAdhereToEdge: argument: each]].
	menu popUpEvent: self currentEvent in: self world! !

!Morph methodsFor: 'menus' stamp: 'sw 2/7/2000 10:57'!
adhereToEdge: edgeSymbol
	(owner == nil or: [owner isHandMorph]) ifTrue: [^ self].
	self perform: (edgeSymbol, ':') asSymbol withArguments: (Array with: (owner perform: edgeSymbol))! !

!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:14'!
adjustedCenter
	"Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph"

	^ self center! !

!Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:12'!
adjustedCenter: c
	"Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge.  By default this simply sets the receiver's center.   Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle  other than the receiver's center."

	self center: c! !

!Morph methodsFor: 'menus' stamp: 'ar 10/5/2000 17:20'!
allMenuWordings
	| tempMenu |
	tempMenu _ self buildHandleMenu: self currentHand.
	tempMenu allMorphsDo: [:m | m step].  "Get wordings current"
	^ tempMenu allWordings! !

!Morph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:45'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #fillStyle:;
		originalColor: self color;
		putUpFor: self near: self fullBoundsInWorld! !

!Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'!
changeDragAndDrop
	^self enableDragNDrop: self dragNDropEnabled not! !

!Morph methodsFor: 'menus' stamp: 'sw 12/17/1998 12:09'!
chooseNewGraphic
	"Used by any morph that can be represented by a graphic"
	self chooseNewGraphicCoexisting: false
! !

!Morph methodsFor: 'menus' stamp: 'sw 8/18/2000 09:34'!
chooseNewGraphicCoexisting: aBoolean
	"Allow the user to choose a different form for her form-based morph"

	| reasonableForms replacee aGraphicalMenu myGraphic |
	reasonableForms _ (SketchMorph allInstances
		select:
			[:m | ((m owner isKindOf: SketchEditorMorph) or: [m owner isKindOf: IconicButton]) not]
		thenCollect:
			 [:m | m form]) asSet "eliminate duplicates" asOrderedCollection.

	reasonableForms addAll: (Smalltalk imageImports collect: [:f | f]).
	reasonableForms _ reasonableForms asSet asOrderedCollection.
	(reasonableForms includes: (myGraphic _ self form))
		ifTrue:
			[reasonableForms remove: myGraphic].
	reasonableForms addFirst: myGraphic.

	aGraphicalMenu _ GraphicalMenu new initializeFor: self withForms: reasonableForms coexist: aBoolean.
	aBoolean
		ifFalse:
			[replacee _ self topRendererOrSelf.
			replacee owner replaceSubmorph: replacee by: aGraphicalMenu]
		ifTrue:
			[self primaryHand attachMorph: aGraphicalMenu]! !

!Morph methodsFor: 'menus' stamp: 'sw 10/27/2000 17:34'!
chooseNewGraphicFromHalo
	"Allow the user to select a changed graphic to replace the one in the receiver"

	self currentWorld abandonAllHalos.
	self chooseNewGraphicCoexisting: true
! !

!Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'!
collapse
	CollapsedMorph new beReplacementFor: self! !

!Morph methodsFor: 'menus' stamp: 'ar 10/25/2000 23:17'!
doMenuItem: menuString
	| aMenu anItem aNominalEvent aHand |
	aMenu _ self buildHandleMenu: (aHand _ self currentHand).
	aMenu allMorphsDo: [:m | m step].  "Get wordings current"
	anItem _ aMenu itemWithWording: menuString.
	anItem ifNil:
		[^ self player scriptingError: 'Menu item not found: ', menuString].
	aNominalEvent _  MouseButtonEvent new
		setType: #mouseDown
		position: anItem bounds center
		which: 4 "red"
		buttons: 4 "red"
		hand: aHand
		stamp: nil.
	anItem invokeWithEvent: aNominalEvent! !

!Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:03'!
hasDragAndDropEnabledString
	^self dragNDropEnabled ifTrue:['<on>drag and drop'] ifFalse:['<off>drag and drop']! !

!Morph methodsFor: 'menus' stamp: 'sw 2/16/1999 14:32'!
inspectInMorphic
	self currentHand attachMorph: ((Inspector openAsMorphOn: self) extent: 300@200)! !

!Morph methodsFor: 'menus' stamp: 'ar 10/5/2000 16:55'!
inspectInMorphic: evt
	evt hand attachMorph: ((Inspector openAsMorphOn: self) extent: 300@200)! !

!Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'!
lockUnlockMorph
	"If the receiver is locked, unlock it; if unlocked, lock it"

	self isLocked ifTrue: [self unlock] ifFalse: [self lock]! !

!Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'!
lockedString
	"Answer the string to be shown in a menu to represent the 'locked' status"

	^ self isLocked
		ifTrue:
			['<on>locked']
		ifFalse:
			['<off>locked']! !

!Morph methodsFor: 'menus' stamp: 'sw 10/29/1999 15:34'!
makeNascentScript
	^ self notYetImplemented! !

!Morph methodsFor: 'menus' stamp: 'ar 9/15/2000 21:05'!
maybeAddCollapseItemTo: aMenu
	"If appropriate, add a collapse item to the given menu"

	| anOwner |
	(anOwner _ self topRendererOrSelf owner) ifNotNil:
			[anOwner isWorldMorph ifTrue:
				[aMenu add: #collapse target: self action: #collapse]]! !

!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:13'!
menuItemAfter: menuString
	| allWordings |
	allWordings _ self allMenuWordings.
	^ allWordings atWrap: ((allWordings indexOf: menuString) + 1)! !

!Morph methodsFor: 'menus' stamp: 'sw 11/22/1999 12:14'!
menuItemBefore: menuString
	| allWordings |
	allWordings _ self allMenuWordings.
	^ allWordings atWrap: ((allWordings indexOf: menuString) - 1)! !

!Morph methodsFor: 'menus' stamp: 'RAA 2/1/2001 15:54'!
printPSToFile
	
	self printPSToFileNamed: 'MyMorph'

! !

!Morph methodsFor: 'menus' stamp: 'RAA 2/1/2001 15:54'!
printPSToFileNamed: aString
	"Ask the user for a filename and print this morph as postscript."

	| fileName rotateFlag |
	fileName _ aString asFileName.
	fileName _ FillInTheBlank 
		request: 'File name? (".eps" will be added to end)' 
		initialAnswer: fileName.
	fileName size == 0 ifTrue: [^ self beep].
	(fileName endsWith: '.eps') ifFalse: [fileName _ fileName,'.eps'].

	rotateFlag _ ((PopUpMenu labels:
'portrait (tall)
landscape (wide)')
			startUpWithCaption: 'Choose orientation...') = 2.

	(FileStream newFileNamed: fileName)
		nextPutAll: (
			PostscriptCanvas defaultCanvasType morphAsPostscript: self rotated: rotateFlag
		); close.

! !

!Morph methodsFor: 'menus' stamp: 'sw 10/27/2000 06:39'!
putOnBackground
	"Place the receiver, formerly private to its card, onto the shared background.  If the receiver needs data carried on its behalf by the card, such data will be represented on every card."

	(self hasProperty: #shared) ifTrue: [^ self].  "Already done"

	self setProperty: #shared toValue: true.
	self stack ifNotNil: [self stack reassessBackgroundShape]! !

!Morph methodsFor: 'menus' stamp: 'sw 10/26/2000 11:50'!
putOnForeground
	"Place the receiver, formerly on the background, onto the foreground.  If the receiver needs data carried on its behalf by the card, those data will be lost, so in this case get user confirmation before proceeding."

	self holdsSeparateDataForEachInstance "later add the refinement of not putting up the following confirmer if only a single instance of the current background's uniclass exists"
		ifTrue:
			[self confirm: 'Caution -- every card of this background
formerly had its own value for this
item.  If you put it on the foreground,
the values  of this item on all other
cards will be lost'
				orCancel: [^ self]].

	self removeProperty: #shared.
	self pasteUpMorph reassessBackgroundShape.
	"still work to be done here!!"! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:36'!
resetForwardDirection
	self forwardDirection: 0.! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:15'!
setRotationCenter
	| p |
	self world displayWorld.
	Cursor crossHair showWhile:
		[p _ Sensor waitButton].
	Sensor waitNoButton.
	self setRotationCenterFrom: (self transformFromWorld globalPointToLocal: p).

! !

!Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:14'!
setRotationCenterFrom: aPoint
	self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! !

!Morph methodsFor: 'menus' stamp: 'di 12/21/2000 17:18'!
setToAdhereToEdge: anEdge
	anEdge ifNil: [^ self].
	anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo].
	self setProperty: #edgeToAdhereTo toValue: anEdge.
! !

!Morph methodsFor: 'menus' stamp: 'sw 8/30/1998 09:42'!
snapToEdgeIfAppropriate
	| edgeSymbol oldBounds aWorld |
	(edgeSymbol _ self valueOfProperty: #edgeToAdhereTo) ifNotNil:
		[oldBounds _ bounds.
		self adhereToEdge: edgeSymbol.
		bounds ~= oldBounds ifTrue: [(aWorld _ self world) ifNotNil: [aWorld viewBox ifNotNil:
			[aWorld displayWorld]]]]! !

!Morph methodsFor: 'menus' stamp: 'sw 9/21/2000 22:50'!
stickinessString
	"Answer the string to be shown in a menu to represent the stickiness status"

	^ self isSticky
		ifTrue: ['<yes>sticky']
		ifFalse: ['<no>sticky']
! !

!Morph methodsFor: 'menus' stamp: 'sw 5/18/2000 18:01'!
transferStateToRenderer: aRenderer
	| current |
	"Transfer knownName, actorState, and player info over to aRenderer, which is being imposed above me as a transformation shell"

	(current _ self actorStateOrNil) ifNotNil:
		[aRenderer actorState: current.
		self actorState: nil].

	(current _ self knownName) ifNotNil:
		[aRenderer setNameTo: current.
		self setNameTo: nil].

	(current _ self player) ifNotNil:
		[aRenderer player: current.
		self player rawCostume: aRenderer.
		"self player: nil"]! !

!Morph methodsFor: 'menus' stamp: 'RAA 11/14/2000 13:46'!
uncollapseSketch

	| uncollapsedVersion w whomToDelete |

	(w _ self world) ifNil: [^self].
	uncollapsedVersion _ self valueOfProperty: #uncollapsedMorph.
	uncollapsedVersion ifNil: [^self].
	whomToDelete _ self valueOfProperty: #collapsedMorphCarrier.
	uncollapsedVersion setProperty: #collapsedPosition toValue: whomToDelete position.

	whomToDelete delete.
	w addMorphFront: uncollapsedVersion.

! !


!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 18:57'!
addHalo
	"Invoke a halo programatically (e.g., not from a meta gesture)"
	^self addHalo: nil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/10/2000 19:03'!
addHalo: evt
	| halo prospectiveHaloClass |
	prospectiveHaloClass _ Smalltalk at: self haloClass ifAbsent: [HaloMorph].
	halo _ prospectiveHaloClass new bounds: self worldBoundsForHalo.
	halo popUpFor: self event: evt.
	^halo! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/7/1999 21:55'!
addHalo: evt from: formerHaloOwner
	"Transfer a halo from the former halo owner to the receiver"
	^self addHalo: evt! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/4/2000 11:49'!
addHaloFor: aHand
	| halo prospectiveHaloClass |
	prospectiveHaloClass _ Smalltalk at: self haloClass ifAbsent: [HaloMorph].
	halo _ prospectiveHaloClass new bounds: self worldBoundsForHalo.
	halo popUpFor: self hand: aHand.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/26/2000 16:33'!
addHandlesTo: aHaloMorph box: box
	aHaloMorph haloBox: box.
	Preferences haloSpecifications do:
		[:aSpec | 
			aHaloMorph perform: aSpec addHandleSelector with: aSpec].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/22/2000 20:41'!
addOptionalHandlesTo: aHalo box: box
	aHalo addDirectionHandles! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/21/1999 17:52'!
addSimpleHandlesTo: aHaloMorph box: aBox
	^ aHaloMorph addSimpleHandlesTo: aHaloMorph box: aBox! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/26/2000 19:37'!
addWorldHandlesTo: aHaloMorph box: box
	aHaloMorph haloBox: box.
	Preferences haloSpecificationsForWorld do:
		[:aSpec | 
			aHaloMorph perform: aSpec addHandleSelector with: aSpec].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:54'!
balloonColor
	^ self
		valueOfProperty: #balloonColor
		ifAbsent: [self defaultBalloonColor]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:55'!
balloonColor: aColor
	^ self
		setProperty: #balloonColor
		toValue: aColor! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:27'!
balloonHelpAligner
	"Answer the morph to which the receiver's balloon help should point"
	^ (self valueOfProperty: #balloonTarget) ifNil: [self]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/11/2000 21:44'!
balloonHelpDelayTime
	"Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true."
	^800! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/31/2000 06:04'!
balloonHelpTextForHandle: aHandle
	"Answer a string providing balloon help for the given halo handle"

	|  itsSelector |
	itsSelector _ aHandle eventHandler firstMouseSelector.
	#(	(addFullHandles							'More halo handles')
		(addSimpleHandles						'Fewer halo handles')
		(chooseEmphasisOrAlignment				'Emphasis & alignment')
		(chooseFont								'Change font')
		(chooseNewGraphicFromHalo				'Choose a new graphic')
		(chooseStyle								'Change style')
		(dismiss									'Remove')
		(doDebug:with:							'Debug')
		(doDirection:with:						'Choose forward direction')
		(doDup:with:							'Duplicate')
		(doMenu:with:							'Menu')
		(doGrab:with:							'Pick up')
		(doRecolor:with:							'Change color')
		(editButtonsScript						'See the script for this button')
		(editDrawing							'Repaint')
		(maybeDoDup:with:						'Duplicate')
		(makeNascentScript						'Make a scratch script')
		(makeNewDrawingWithin				'Paint new object')
		(mouseDownInCollapseHandle:with:		'Collapse morph')
		(mouseDownOnHelpHandle:				'Help')
		(openViewerForArgument				'Open a Viewer for me')
		(paintBackground						'Paint background')
		(prepareToTrackCenterOfRotation:with:	'Set center of rotation')
		(presentViewMenu						'Present the Viewing menu')
		(startDrag:with:							'Move')
		(startGrow:with:							'Change size') 
		(startRot:with:							'Rotate')
		(startScale:with:							'Change scale') 
		(tearOffTile								'Make a tile representing this object')
		(trackCenterOfRotation:with:				'Set center of rotation')) 


	do:
		[:pair | itsSelector == pair first ifTrue: [^ pair last]].

	(itsSelector == #mouseDownInDimissHandle:with:) ifTrue:
		[^ Preferences preserveTrash
			ifTrue:
				['Move to trash']
			ifFalse:
				['Remove from screen']].

	^ 'unknown halo handle'! !

!Morph methodsFor: 'halos and balloon help' stamp: 'RAA 7/21/2000 11:10'!
boundsForBalloon

	"some morphs have bounds that are way too big"
	^self boundsInWorld! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 3/1/2000 11:39'!
comeToFrontAndAddHalo
	self comeToFront.
	self addHalo! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 16:15'!
defaultBalloonColor
	^ Display depth <= 2
		ifTrue: [Color white]
		ifFalse: [BalloonMorph balloonColor]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/11/2000 18:24'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	"May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click"

	^ false
	! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:03'!
deleteBalloon
	"If I am showing a balloon, delete it."
	| w |
	w _ self world ifNil:[^self].
	w deleteBalloonTarget: self.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/31/2000 11:12'!
editBalloonHelpContent: aString
	| reply |
	reply _ FillInTheBlank
		multiLineRequest: 'Edit the balloon help text for ' , self externalName
		centerAt: Sensor cursorPoint
		initialAnswer: (aString ifNil: [self noHelpString] ifNotNil: [aString])
		answerHeight: 200.
	reply ifNil: [^ self].  "User cancelled out of the dialog"
	(reply isEmpty or: [reply asString = self noHelpString])
		ifTrue: [self setBalloonText: nil]
		ifFalse: [self setBalloonText: reply]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'!
editBalloonHelpText
	"Modify the receiver's balloon help text."

	self editBalloonHelpContent: self balloonText! !

!Morph methodsFor: 'halos and balloon help' stamp: 'RAA 7/6/2000 12:54'!
halo

	(self world ifNil: [^nil]) haloMorphs do: [:h | h target == self ifTrue: [^ h]].
	^ nil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:13'!
haloClass
	"Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver"

	^ #HaloMorph
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/11/2000 21:44'!
haloDelayTime
	"Return the number of milliseconds before a halo should be put up on the receiver. The halo will only be put up if the receiver responds to #wantsHalo by returning true."
	^800! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/15/2000 16:16'!
hasHalo
	^self hasProperty: #hasHalo.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 9/28/2000 17:54'!
hasHalo: aBool
	aBool
		ifTrue:[self setProperty: #hasHalo toValue: true]
		ifFalse:[self removeProperty: #hasHalo]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 7/3/1999 20:05'!
isLikelyRecipientForMouseOverHalos
	^ self player ~~ nil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/6/2000 14:06'!
mightEntertainDirectionHandles
	"Answer whether the receiver, by its very nature, might possibly be happy to have direction handles shown for it in its halo"

	^ true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:05'!
mouseDownOnHelpHandle: anEvent
	"The mouse went down in the show-balloon handle"
	
	| str |
	anEvent shiftPressed ifTrue: [^ self editBalloonHelpText].
	str _ self balloonText.
	str ifNil: [str _ self noHelpString].
	self showBalloon: str hand: anEvent hand.
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 9/19/97 13:46'!
noHelpString
	^ 'Help not yet supplied'! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/26/2000 12:11'!
okayToAddGrabHandle
	"Answer whether a halo on the receiver should offer a grab handle.  This provides a hook for making it harder to deconstruct some strucures even momentarily"

	^ self holdsSeparateDataForEachInstance not ! !

!Morph methodsFor: 'halos and balloon help' stamp: 'di 2/20/98 15:24'!
removeHalo
	| h |
	h _ self halo.
	h ifNotNil: [h delete]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:32'!
setBalloonText: stringOrText
	"Set receiver's balloon help text. Pass nil to remove the help."

	self setBalloonText: stringOrText maxLineLength: Preferences maxBalloonHelpLineLength! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 3/23/2000 13:50'!
setBalloonText: stringOrText maxLineLength: aLength
	"Set receiver's balloon help text. Pass nil to remove the help."

	(extension isNil and: [stringOrText isNil]) ifTrue: [^ self].
	self assureExtension balloonText: (stringOrText
		ifNil: [nil]
		ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/29/1999 17:38'!
setCenteredBalloonText: aString
	self setBalloonText: aString.
	self setProperty: #helpAtCenter toValue: true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/3/2000 17:06'!
showBalloon: msgString
	"Pop up a balloon containing the given string,
	first removing any existing BalloonMorphs in the world."
	| w |
	self showBalloon: msgString hand: ((w _ self world) ifNotNil:[w activeHand]).! !

!Morph methodsFor: 'halos and balloon help' stamp: 'bf 11/1/2000 15:58'!
showBalloon: msgString hand: aHand
	"Pop up a balloon containing the given string,
	first removing any existing BalloonMorphs in the world."

	| w balloon h |
	(w _ self world) ifNil: [^ self].
	h _ aHand.
	h ifNil:[
		h _ w activeHand].
	balloon _ BalloonMorph string: msgString for: self balloonHelpAligner.
	balloon popUpFor: self hand: h.! !

!Morph methodsFor: 'halos and balloon help' stamp: 'ar 10/8/2000 00:47'!
transferHalo: event from: formerHaloOwner
	"Progressively transfer the halo to the next likely recipient"
	| localEvt w target |

	self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers."
	(formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[
		event shiftPressed ifTrue:[
			target _ owner.
			localEvt _ event transformedBy: (self transformedFrom: owner).
		] ifFalse:[
			target _ self renderedMorph.
			localEvt _ event transformedBy: (target transformedFrom: self).
		].
		^target transferHalo: localEvt from: target].

	"Never transfer halo to top-most world"
	(self isWorldMorph and:[owner isNil]) ifFalse:[
		(self wantsHaloFromClick and:[formerHaloOwner ~~ self]) 
			ifTrue:[^self addHalo: event from: formerHaloOwner]].

	event shiftPressed ifTrue:[
		"Pass it outwards"
		owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner].
		"We're at the top level; throw the event back in to find recipient"
		formerHaloOwner removeHalo.
		^self processEvent: event copy resetHandlerFields.
	].
	self submorphsDo:[:m|
		localEvt _ event transformedBy: (m transformedFrom: self).
		(m fullContainsPoint: localEvt position) 
			ifTrue:[^m transferHalo: event from: formerHaloOwner].
	].
	"We're at the bottom most level; throw the event back up to the root to find recipient"
	formerHaloOwner removeHalo.
	w _ self world.
	localEvt _ event transformedBy: (self transformedFrom: w) inverseTransformation.
	^w processEvent: localEvt resetHandlerFields.
! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'!
wantsBalloon
	"Answer true if receiver wants to show a balloon help text is a few moments." 

	^ self balloonText notNil! !

!Morph methodsFor: 'halos and balloon help' stamp: 'di 9/26/2000 09:52'!
wantsDirectionHandles

	^ Preferences showDirectionHandles ! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/27/2000 15:33'!
wantsHalo
	| topOwner |
	^ (topOwner _ self topRendererOrSelf owner) ~~ nil and:
		[topOwner wantsHaloFor: self]! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/8/98 13:26'!
wantsHaloFor: aSubMorph
	^ false! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'!
wantsHaloFromClick
	^ true! !

!Morph methodsFor: 'halos and balloon help' stamp: 'sw 10/9/2000 16:56'!
wantsScriptorHaloHandle
	"Answer whether the receiver would like to have a Scriptor halo handle put up on its behalf.  Initially, only the ScriptableButton says yes"

	^ false! !


!Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 22:21'!
changed
	"Report that the area occupied by this morph should be redrawn."
	^self invalidRect: self outerBounds! !

!Morph methodsFor: 'change reporting' stamp: 'sw 9/10/1998 08:18'!
colorChangedForSubmorph: aSubmorph
	"The color associated with aSubmorph was changed through the UI; react if needed"! !

!Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:50'!
invalidRect: damageRect
	^self invalidRect: damageRect from: self! !

!Morph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:41'!
invalidRect: aRectangle from: aMorph
	| damageRect |
	damageRect _ aRectangle.
	aMorph == self ifFalse:[
		"Clip to receiver's clipping bounds if the damage came from a child"
		self clipSubmorphs 
			ifTrue:[damageRect _ aRectangle intersect: self clippingBounds]].
	owner ifNotNil: [owner invalidRect: damageRect from: self].
	self wonderlandTexture ifNotNil:[self isValidWonderlandTexture: false].
! !

!Morph methodsFor: 'change reporting' stamp: 'sw 7/8/1998 13:21'!
ownerChanged
	"The receiver's owner, some kind of a pasteup, has changed its layout."

	self snapToEdgeIfAppropriate! !

!Morph methodsFor: 'change reporting' stamp: 'sw 9/10/1998 08:18'!
userSelectedColor: aColor
	"The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react"
	self color: aColor.
	owner ifNotNil: [owner colorChangedForSubmorph: self]! !


!Morph methodsFor: 'player' stamp: 'sw 8/10/2000 00:06'!
assureExternalName
	| aName |
	^ (aName _ self knownName) ifNil:
		[self setNameTo: (aName _ self externalName).
		^ aName]! !

!Morph methodsFor: 'player' stamp: 'sw 2/19/1999 09:06'!
assuredPlayer
	"Answer the receiver's player, creating a new one if none currently exists"

	| aPlayer |
	(aPlayer _ self player) ifNil:
		[self assureExternalName.  "a default may be given if not named yet"
		self player: (aPlayer _ self newPlayerInstance).  
			"Different morphs may demand different player types"
		aPlayer costume: self.
		self presenter ifNotNil: [self presenter flushPlayerListCache]].
	^ aPlayer! !

!Morph methodsFor: 'player' stamp: 'sw 10/27/2000 17:38'!
currentDataValue
	"Answer the data value associated with the receiver.  Useful in conjunction with default-value setting"

	^ nil! !

!Morph methodsFor: 'player' stamp: 'sw 9/15/1998 13:33'!
newPlayerInstance
	^ UnscriptedPlayer newUserInstance! !

!Morph methodsFor: 'player' stamp: 'sw 1/22/2001 14:25'!
okayToDuplicate
	"Formerly this protocol was used to guard against awkward situations when there were anonymous scripts in the etoy system.  Nowadays we just always allow duplication"

	^ true! !

!Morph methodsFor: 'player' stamp: 'sw 8/11/1998 16:54'!
showPlayerMenu
	self player ifNotNil:
		[self player showPlayerMenu]! !

!Morph methodsFor: 'player' stamp: 'sw 10/6/2000 07:37'!
variableDocks
	"Answer a list of VariableDocker objects for docking up my data with an instance held in my containing playfield.  The simple presence of some objects on a Playfield will result in the maintenance of instance data on the corresponding Card.  This is a generalization of the HyperCard 'field' idea.  If there is already a cachedVariableDocks cached, use that.  For this all to work happily, one must be certain to invalidate the #cachedVariableDocks cache when that's appropriate."

	^ self valueOfProperty: #cachedVariableDocks ifAbsent: [#()]! !


!Morph methodsFor: 'player commands' stamp: 'jm 5/16/1998 10:44'!
beep

	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		(sampledSound new
			setSamples: sampledSound coffeeCupClink
			samplingRate: 12000) play.
		^ self].

	Smalltalk beep.
! !

!Morph methodsFor: 'player commands' stamp: 'jm 5/16/1998 10:36'!
beep: soundName

	self playSoundNamed: soundName.
! !

!Morph methodsFor: 'player commands'!
jumpTo: aPoint
	"Let my owner decide how I move."

	owner move: self toPosition: aPoint.
! !

!Morph methodsFor: 'player commands' stamp: 'sw 2/16/1999 11:33'!
makeFenceSound
	Preferences soundsEnabled ifTrue:
		[self playSoundNamed: 'scratch'].
! !

!Morph methodsFor: 'player commands'!
set: aPointOrNumber
	"Set my position."

	self jumpTo: aPointOrNumber.
! !


!Morph methodsFor: 'player viewer' stamp: 'sw 4/18/1998 01:37'!
openViewerForArgument
	self presenter viewMorph: self! !

!Morph methodsFor: 'player viewer' stamp: 'sw 3/13/98 17:40'!
updateLiteralLabel
	"Backstop -- updatingStringMorphs inform their owners with this message when they've changed; some Morphs care, others don't"! !


!Morph methodsFor: 'scripting' stamp: 'ar 1/25/2001 12:50'!
asEmptyPermanentScriptor
	"Answer a new empty permanent scriptor derived from info deftly secreted in the receiver.  Good grief"

	| aScriptor aPlayer |
	aPlayer _ self valueOfProperty: #newPermanentPlayer.
	aPlayer assureUniClass.
	aScriptor _  aPlayer newScriptorAround: nil.
	aScriptor position: (self world primaryHand position - (10 @ 10)).
	aPlayer updateAllViewersAndForceToShow: #scripts.
	^ aScriptor! !

!Morph methodsFor: 'scripting' stamp: 'sw 9/8/2000 16:32'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"

	| aClass aList predetermined genericItems |
	aClass _ self renderedMorph class.
	aList _ OrderedCollection new.
	[aClass == Morph] whileFalse:
		[(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
			[aList addAllFirst: (aClass additionsToViewerCategories collect:
				[:categorySpec | categorySpec first])].
		aClass _ aClass superclass]. 

	genericItems _ Morph additionsToViewerCategories collect:
			[:categorySpec | categorySpec first].
	aList removeAllFoundIn: genericItems.

	aList addAllFirst: (Morph additionsToViewerCategories collect:
			[:categorySpec | categorySpec first]) asSet asOrderedCollection.
	predetermined _ #(basic #'color & border' geometry motion #'pen use' tests miscellaneous) select:
		[:sym | aList includes: sym].  "bulletproof agains change in those names elsewhere"
	aList removeAllFoundIn: predetermined.
	^ predetermined, aList
! !

!Morph methodsFor: 'scripting' stamp: 'sw 9/8/2000 16:33'!
categoryElementsFor: aCategorySymbol
	"Answer a list of tuples that characterize the elements in the given category.  Every class in the receiver's superclass chain which implements #additionsToViewerCategories is given the chance to add elements to the category"

	| aClass aList |
	aClass _ self renderedMorph class.
	aList _ OrderedCollection new.
	[aClass == Morph] whileFalse:
		[(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
			[aList addAllFirst: (aClass additionsToViewerCategory: aCategorySymbol)].
		aClass _ aClass superclass]. 
	aList addAllFirst: (Morph additionsToViewerCategory: aCategorySymbol).
	^ aList
! !

!Morph methodsFor: 'scripting' stamp: 'sw 5/13/1998 13:11'!
instantiatedUserScriptsDo: aBlock
	| aState |
	(aState _ self actorState) ifNotNil:
		[aState instantiatedUserScriptsDictionary do: aBlock]! !

!Morph methodsFor: 'scripting' stamp: 'tk 10/1/97 18:23'!
isTileLike
	"Cannot be dropped into a script"
	^ false! !

!Morph methodsFor: 'scripting' stamp: 'sw 4/21/1998 21:33'!
isTileScriptingElement
	^ false! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:53'!
jettisonScripts
	self player ifNotNil: [self player class jettisonScripts]! !

!Morph methodsFor: 'scripting' stamp: 'LC 9/28/1999 21:57'!
makeAllTilesColored
	self allMorphsDo: 
		[:m | m restoreTypeColor]! !

!Morph methodsFor: 'scripting' stamp: 'LC 9/28/1999 21:57'!
makeAllTilesGreen
	self allMorphsDo: 
		[:m | m useUniformTileColor]! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:59'!
restoreTypeColor
	self player ifNotNil: [self player allScriptEditors do:
		[:anEditor | anEditor allMorphsDo:
			[:m | m restoreTypeColor]]]! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:46'!
scriptEditorFor: aScriptName
	^ self assuredPlayer scriptEditorFor: aScriptName! !

!Morph methodsFor: 'scripting' stamp: 'sw 7/20/1999 08:13'!
scriptPerformer
	^ self topRendererOrSelf player ifNil: [self]! !

!Morph methodsFor: 'scripting' stamp: 'sw 10/6/1998 17:10'!
tearOffTile
	^ self assuredPlayer tearOffTileForSelf! !

!Morph methodsFor: 'scripting' stamp: 'tk 12/1/2000 15:22'!
updatingTileForArgType: typeSymbol partName: partName getSelector: getSelector putSelector: putSelector
	"Answer a readout tile representing the given part's value, given the putter, getter, and type information"

	| aColor aTile displayer |
	aColor _ Color lightGray lighter.
	aTile _ typeSymbol == #number
		ifTrue:
			[NumericReadoutTile new typeColor: aColor]
		ifFalse:	
			[typeSymbol == #sound
				ifTrue:
					[SoundReadoutTile new typeColor: aColor]
				ifFalse:
					[typeSymbol == #buttonPhase
						ifTrue:
							[SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType:  typeSymbol]
						ifFalse:
							[StringReadoutTile new typeColor: aColor]]].

 	displayer _ UpdatingStringMorph new
		getSelector: getSelector;
		target: self player;
		growable: true;
		minimumWidth: 24;
		putSelector: ((putSelector == #unused) ifTrue: [nil] ifFalse: [putSelector]).

	(typeSymbol == #number)
		ifTrue:
			 [((#(cursor  "etc...") includes: partName) and: [self isKindOf: GraphMorph])
				ifTrue:
					[displayer floatPrecision: 0.1]
				ifFalse:
					[(self player slotInfo includesKey: partName)  "i.e., a user-defined numeric slot"
						ifTrue:
							[displayer floatPrecision: (self player slotInfoAt: partName) floatPrecision]]].
	typeSymbol == #string
		ifTrue:
			[displayer useStringFormat.
			displayer growable: true]
		ifFalse:
			[(typeSymbol == #sound)
				ifTrue: 	[displayer useStringFormat]
				ifFalse:	[displayer useDefaultFormat]].
	aTile addMorphBack: displayer.
	((putSelector ~~ #unused) and: [#(number sound boolean buttonPhase) includes: typeSymbol])  ifTrue: [aTile addArrows].
	aTile setLiteralInitially: (self scriptPerformer perform: getSelector).
	^ aTile! !

!Morph methodsFor: 'scripting' stamp: 'sw 8/11/1998 16:55'!
useUniformTileColor
	self player ifNotNil:
		[self player allScriptEditors do:
			[:anEditor | anEditor allMorphsDo:
				[:m | m useUniformTileColor]]]! !

!Morph methodsFor: 'scripting' stamp: 'sw 10/18/2000 10:32'!
viewAfreshIn: aPasteUp showingScript: aScriptName at: aPosition
	"Obtain a smartly updated ScriptEditor for the given script name and zap it into place at aPosition"

	| anEditor |
	self player updateAllViewersAndForceToShow: #scripts.
	anEditor _ self player scriptEditorFor: aScriptName.
	aPasteUp ifNotNil: [aPasteUp addMorph: anEditor].
	anEditor position: aPosition.
	anEditor currentWorld startSteppingSubmorphsOf: anEditor! !


!Morph methodsFor: 'e-toy support' stamp: 'sw 2/9/1999 17:43'!
adaptToWorld: aWorld
	"The receiver finds itself operating in a possibly-different new world.  If any of the receiver's parts are world-dependent (such as a target of a SimpleButtonMorph, etc.), then have them adapt accordingly"
	submorphs do: [:m | m adaptToWorld: aWorld].
	self eventHandler ifNotNil:
		[self eventHandler adaptToWorld: aWorld]! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 12/17/1998 11:16'!
allMorphsAndBookPagesInto: aSet
	"Return a set of all submorphs.  Don't forget the hidden ones like BookMorph pages that are not showing.  Consider only objects that are in memory (see allNonSubmorphMorphs)." 

	submorphs do: [:m | m allMorphsAndBookPagesInto: aSet].
	self allNonSubmorphMorphs do: [:m | 
			(aSet includes: m) ifFalse: ["Stop infinite recursion"
				m allMorphsAndBookPagesInto: aSet]].
	aSet add: self.
	^ aSet
	! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 1/13/2001 11:27'!
appearsToBeSameCostumeAs: aMorph

	^false
! !

!Morph methodsFor: 'e-toy support'!
asNumber: aPointOrNumber
	"Support for e-toy demo."

	aPointOrNumber class = Point
		ifTrue: [^ aPointOrNumber r]
		ifFalse: [^ aPointOrNumber].
! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/26/2000 14:12'!
asWearableCostume
	"Return a wearable costume for some player"
	^(SketchMorph withForm: self imageForm) copyCostumeStateFrom: self! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 12/20/1999 17:36'!
automaticViewing
	"Backstop, in case this message gets sent to an owner that is not a playfield"
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/1/97 00:18'!
configureForKids
	submorphs ifNotNil:
		[submorphs do: [:m | m configureForKids]]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 5/23/2000 03:42'!
containingWindow
	^ self ownerThatIsA: SystemWindow! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:38'!
copyCostumeStateFrom: aMorph
	"Copy all state that should be persistant for costumes from aMorph"
	self rotationCenter: aMorph rotationCenter.
	self rotationStyle: aMorph rotationStyle.
	self referencePosition: aMorph referencePosition.
	self forwardDirection: aMorph forwardDirection.
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:36'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:37'!
creationStamp
	"Answer the creation stamp stored within the receiver, if any"

	^ self valueOfProperty: #creationStamp ifAbsent: [super creationStamp]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/22/1998 20:28'!
currentPlayerDo: aBlock
	"If the receiver is a viewer/scriptor associated with a current Player object, evaluate the given block against that object"! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/8/2000 16:34'!
cursor
	"vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"

	^ 1! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/7/2000 09:28'!
cursor: aNumber
	"vacuous backstop in case it gets sent to a morph that doesn't know what to do with it"
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/24/2000 05:52'!
defaultValueOrNil
	"If the receiver has a property named #defaultValue, return that property's value, else return nil"

	^ self valueOfProperty: #defaultValue ifAbsent: [nil]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/25/2000 06:57'!
defaultVariableName
	"If the receiver is of the sort that wants a variable maintained on its behalf in the 'card' data, then return a variable name to be used for that datum.  What is returned here is only a point of departure in the forthcoming negotiation"

	^ Utilities wellFormedInstanceVariableNameFrom: (self valueOfProperty: #variableName ifAbsent: [self externalName])! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 1/28/1999 16:13'!
definePath
	| points lastPoint aForm offset currentPoint dwell ownerPosition |
	points _ OrderedCollection new: 70.
	lastPoint _ nil.
	aForm _ self imageForm.
	offset _ aForm extent // 2.
	ownerPosition _ owner position.
	Cursor move show.
	Sensor waitButton.
	[Sensor anyButtonPressed and: [points size < 100]] whileTrue:
		[currentPoint _ Sensor cursorPoint.
		dwell _ 0.
		currentPoint = lastPoint
			ifTrue:
				[dwell _ dwell + 1.
				((dwell \\ 1000) = 0) ifTrue:
					[self beep]]
			ifFalse:
				[self position: (currentPoint - offset).
				self world displayWorld.
				(Delay forMilliseconds: 20) wait.
				points add: currentPoint.
				lastPoint _ currentPoint]].
	points size > 1
		ifFalse:
			[self inform: 'no path obtained']
		ifTrue:
			[points size = 100 ifTrue: [self playSoundNamed: 'croak'].

			Transcript cr; show: 'path defined with
', points size printString, ' points'.
			self renderedMorph setProperty: #pathPoints toValue: 
				(points collect: [:p | p - ownerPosition])].

	Cursor normal show
		! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 1/5/1999 10:05'!
deletePath
	self removeProperty: #pathPoints! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 5/25/2000 09:06'!
embedInWindow

	| window worldToUse |

	worldToUse _ self world.		"I'm assuming we are already in a world"
	window _ (SystemWindow labelled: self defaultLabelForInspector) model: nil.
	window bounds: ((self position - ((0@window labelHeight) + window borderWidth))
						corner: self bottomRight + window borderWidth).
	window addMorph: self frame: (0@0 extent: 1@1).
	window updatePaneColors.
	worldToUse addMorph: window.
	window activate! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/1999 23:32'!
embeddedInMorphicWindowLabeled: labelString
	| window |
	window _ (SystemWindow labelled: labelString) model: nil.
	window setStripeColorsFrom: nil defaultBackgroundColor.
	window addMorph: self frame: (0@0 extent: 1@1).
	^ window! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 2/15/1999 19:38'!
enforceTileColorPolicy
	Preferences coloredTilesEnabled
		ifTrue:
			[self makeAllTilesColored]
		ifFalse:
			[self makeAllTilesGreen]! !

!Morph methodsFor: 'e-toy support' stamp: 'RAA 10/4/2000 08:29'!
fenceEnabled

	"in case a non-pasteUp is used as a container"

	^Preferences fenceEnabled! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 1/5/1999 17:16'!
followPath
	| pathPoints offset |
	(pathPoints _ self renderedMorph valueOfProperty: #pathPoints) ifNil: [^ self beep].
	offset _ owner position - (self extent // 2).
	pathPoints do:
		[:aPoint |
			self position: aPoint + offset.
			self world displayWorld.
			(Delay forMilliseconds: 20) wait]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/1/2000 10:15'!
getNumericValue
	"Only certain kinds of morphs know how to deal with this frontally; here we provide support for a numeric property of any morph"

	^ self valueOfProperty: #numericValue ifAbsent: [0]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/23/2000 14:49'!
goToNextCardInStack
	"Tell my stack to advance to the next page"

	self stackDo: [:aStack | aStack goToNextCardInStack]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/23/2000 14:52'!
goToPreviousCardInStack
	"Tell my stack to advance to the previous card"
	
	self stackDo: [:aStack | aStack goToPreviousCardInStack]! !

!Morph methodsFor: 'e-toy support' stamp: 'di 8/29/2000 20:46'!
gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor

	| bigGrid gridForm gridOrigin |
	gridOrigin _ origin \\ smallGrid.
	bigGrid _ (40 roundTo: smallGrid asPoint x) @ (40 roundTo: smallGrid asPoint y).
	gridForm _ Form extent: bigGrid depth: Display depth.
	backColor ifNotNil: [gridForm fillWithColor: backColor].
	gridOrigin x to: gridForm width by: smallGrid x do:
		[:x | gridForm fill: (x@0 extent: 1@gridForm height) fillColor: lineColor].
	gridOrigin y to: gridForm height by: smallGrid y do:
		[:y | gridForm fill: (0@y extent: gridForm width@1) fillColor: lineColor].
	^ InfiniteForm with: gridForm
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:41'!
holdsSeparateDataForEachInstance
	"Answer whether the receiver is currently behaving as a 'background field', i.e., whether it is marked as shared (viz. occurring on the background of a stack) *and* is marked as holding separate data for each instance"

	^ self isShared and: [self hasProperty: #holdsSeparateDataForEachInstance]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/21/1998 15:54'!
isAViewer
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 6/30/1999 20:29'!
isCandidateForAutomaticViewing
	^ true! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/23/2000 14:40'!
isStackBackground
	"Answer whether the receiver serves as a background of a stack"

	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/9/2000 16:48'!
listViewLineForFieldList: aFieldList
	"Answer a ListLineView object which describes the receiver"

	| aLine |
	aLine _ ListViewLine new objectRepresented: self.
	aFieldList do:
		[:fieldSym | aLine addMorphBack: (self readoutForField: fieldSym).
		aLine addTransparentSpacerOfSize: (7 @ 0)].
	^ aLine! !

!Morph methodsFor: 'e-toy support' stamp: 'sge 2/13/2000 07:20'!
makeGraphPaper
	| smallGrid backColor lineColor |
	smallGrid _ Compiler evaluate: (FillInTheBlank request: 'Enter grid size' initialAnswer: '16').
	smallGrid ifNil: [^ self].
	Utilities informUser: 'Choose a background color' during: [backColor _ Color fromUser].
	Utilities informUser: 'Choose a line color' during: [lineColor _ Color fromUser].
	self makeGraphPaperGrid: smallGrid background: backColor line: lineColor.! !

!Morph methodsFor: 'e-toy support' stamp: 'di 9/7/2000 20:44'!
makeGraphPaperGrid: smallGrid background: backColor line: lineColor

	| gridForm |
	gridForm _ self gridFormOrigin: 0@0 grid: smallGrid asPoint background: backColor line: lineColor.
	self color: gridForm.
	self world ifNotNil: [self world fullRepaintNeeded].
	self changed: #newColor.  "propagate to view"
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:43'!
makeHoldSeparateDataForEachInstance
	"Mark the receiver as holding separate data for each instance (i.e., like a 'background field') and reassess the shape of the corresponding background so that it will be able to accommodate this arrangement."

	self setProperty: #holdsSeparateDataForEachInstance toValue: true.
	self pasteUpMorph reassessBackgroundShape! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 4/16/1998 13:46'!
mustBeBackmost
	"Answer whether the receiver needs to be the backmost morph in its owner's submorph list"

	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/12/97 17:52'!
nextPageButton
	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #nextOwnerPage; label: '->'; color: Color yellow.
	aButton setNameTo: 'next'.
	^ aButton! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/2000 11:37'!
noteNegotiatedName: uniqueName for: requestedName
	"This works, kind of, for morphs that have a single variable.  Still holding out for generality of morphs being able to have multiple variables, but need a driving example"

	self setProperty: #variableName toValue: uniqueName.
	self setProperty: #setterSelector toValue: (Utilities setterSelectorFor: uniqueName).
	self setNameTo: uniqueName! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/9/2000 06:43'!
objectViewed
	"Answer the morph associated with the player that the structure the receiver currently finds itself within represents."

	^ (self outermostMorphThat: [:o | o isKindOf: Viewer orOf: ScriptEditorMorph]) objectViewed! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 6/26/1998 16:05'!
previousPageButton
	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #previousOwnerPage; color: Color yellow; label: '<-'.
	aButton setNameTo: 'previous'.
	^ aButton! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 10/5/2000 18:19'!
referencePlayfield
	"Answer the PasteUpMorph to be used for cartesian-coordinate reference"

	| former |
	owner ifNotNil:
		[owner isPlayfieldLike ifTrue: [^ owner].
		(owner isHandMorph and: [(former _ self formerOwner) notNil])
			ifTrue:
				[^ former isPlayfieldLike 
					ifTrue: [former]
					ifFalse: [former referencePlayfield]]].
	^ self world! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'!
rotationStyle
	"Return the 'rotation style' of the receiver"
	^#normal! !

!Morph methodsFor: 'e-toy support' stamp: 'ar 9/23/2000 22:40'!
rotationStyle: aSymbol
	"Set the 'rotation style' of the receiver; this is ignored for non-sketches"! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/24/2000 06:30'!
setAsDefaultValueForNewCard
	"Set the receiver's current value as the one to be used to supply the default value for a variable on a new card.  This implementation does not support multiple variables per morph, which is problematical"

	self setProperty: #defaultValue toValue: self currentDataValue deepCopy! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 9/15/2000 06:26'!
setNumericValue: aValue
	"Set the receiver's contents to reflect the given numeric value.  Only certain kinds of morphs know what to do with this, the rest, for now, stash the number in a property, where it may not be visible but at least it won't be lost, and can be retrieved by the companion getter.  This code is never reached under normal circumstances, because the #numericValue slot is not shown in Viewers for most kinds of morphs, and those kinds of morphs that do show it also reimplement this method.  However, this code *could* be reached via a user script which sends #setNumericValue: but whose receiver has been changed, via tile-scripting drag and drop for example, to one that doesn't directly handle numbers"

	ScriptingSystem informScriptingUser: 'an unusual setNumericValue: call was made'.
	self renderedMorph setProperty: #numericValue toValue: aValue
! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:18'!
setStandardTexture
	| parms |
	parms _ self textureParameters.
	self makeGraphPaperGrid: parms first
		background: parms second
		line: parms third! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 17:46'!
slotSpecifications
	"A once and possibly future feature; retained here for backward-compatibility bulletproofing."

	^ #()! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/27/2000 06:46'!
stack
	"Answer the nearest containing Stack, or, if none, a stack in the current project, and if still none, nil.  The extra messines is because uninstalled backgrounds won't have backpointers to their stack."

	| aStack |
	(aStack _ self ownerThatIsA: StackMorph) ifNotNil: [^ aStack].
	^ Project current currentStack! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/23/2000 14:38'!
stackDo: aBlock
	"If the receiver has a stack, evaluate aBlock on its behalf"

	| aStack |
	(aStack _ self ownerThatIsA: StackMorph) ifNotNil:
		[^ aBlock value: aStack]! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/2000 13:28'!
stopHoldingSeparateDataForEachInstance
	"Make the receiver no longer hold separate data for each instance"

	self removeProperty: #holdsSeparateDataForEachInstance.
	self pasteUpMorph reassessBackgroundShape! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/11/1998 16:55'!
succeededInRevealing: aPlayer
	aPlayer == self player ifTrue: [^ true].
	submorphs do:
		[:m | (m succeededInRevealing: aPlayer) ifTrue: [^ true]].
	^ false! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 7/21/1998 21:17'!
textureParameters
	"Answer a triplet giving the preferred grid size, background color, and line color.  The choices here are as suggested by Alan, 9/13/97"

	^ Array with: 16 with: Color lightYellow with: Color lightGreen lighter lighter! !

!Morph methodsFor: 'e-toy support' stamp: 'sw 8/16/97 17:16'!
unlockOneSubpart
	| unlockables aMenu reply |
	unlockables _ self submorphs select:
		[:m | m isLocked].
	unlockables size <= 1 ifTrue: [^ self unlockContents].
	aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m externalName]) selections: unlockables.
	reply _ aMenu startUpWithCaption: 'Who should be be unlocked?'.
	reply == nil ifTrue: [^ self].
	reply unlock! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 10/19/1999 07:16'!
updateCachedThumbnail
	"If I have a cached thumbnail, then update it.  Copied up from Dan's original version in PasteUpMorph so it can be used by all morphs."
	| cachedThumbnail |

	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[(cachedThumbnail respondsTo: #computeThumbnail) 
			ifTrue: [cachedThumbnail computeThumbnail]
			ifFalse: [self removeProperty: #computeThumbnail]].
		"Test and removal are because the thumbnail is being replaced by another Morph.  We don't know why.  Need to fix that at the source."! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 9/3/1999 11:46'!
wrappedInWindow: aSystemWindow
	| aWindow |
	aWindow _ aSystemWindow model: Model new.
	aWindow addMorph: self frame: (0@0 extent: 1@1).
	aWindow extent: self extent.
	^ aWindow! !

!Morph methodsFor: 'e-toy support' stamp: 'tk 9/3/1999 11:46'!
wrappedInWindowWithTitle: aTitle
	| aWindow |
	aWindow _ (SystemWindow labelled: aTitle) model: Model new.
	aWindow addMorph: self frame: (0@0 extent: 1@1).
	aWindow extent: self extent + (2 @ 18).
	^ aWindow! !



!Morph methodsFor: 'parts bin' stamp: 'di 11/13/2000 00:49'!
inPartsBin

	self isPartsDonor ifTrue: [^ true].
	self allOwnersDo: [:m | m isPartsBin ifTrue: [^ true]].
	^ false
! !

!Morph methodsFor: 'parts bin' stamp: 'sw 8/12/97 14:16'!
isPartsBin
	^ false! !

!Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 22:09'!
isPartsDonor
	extension == nil ifTrue: [^ false].
	^ extension isPartsDonor! !

!Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 22:10'!
isPartsDonor: aBoolean
	extension == nil ifTrue:
		[aBoolean ifFalse: [^ self].
		self assureExtension].
	extension isPartsDonor: aBoolean! !

!Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 13:02'!
markAsPartsDonor
	"Mark the receiver specially so that mouse actions on it are interpreted as 'tearing off a copy'"

	self isPartsDonor: true! !

!Morph methodsFor: 'parts bin' stamp: 'ar 10/6/2000 22:45'!
partRepresented
	^self! !

!Morph methodsFor: 'parts bin' stamp: 'sw 4/22/1998 14:45'!
residesInPartsBin
	"Answer true if the receiver is, or has some ancestor owner who is, a parts bin"
	^ owner ifNotNil: [owner residesInPartsBin] ifNil: [false]! !


!Morph methodsFor: 'printing' stamp: 'di 9/22/1999 08:45'!
asEPS

	^ EPSCanvas morphAsPostscript: self rotated: false.
! !

!Morph methodsFor: 'printing'!
asPostscript
	^self asEPS.
! !

!Morph methodsFor: 'printing' stamp: 'di 9/22/1999 08:45'!
asPostscriptPrintJob

	^ DSCPostscriptCanvas morphAsPostscript: self rotated: false.
! !

!Morph methodsFor: 'printing' stamp: 'ar 1/16/2001 17:06'!
clipPostscript
	^Clipboard clipboardText: self asPostscript.

! !

!Morph methodsFor: 'printing'!
colorString: aColor
	aColor == nil ifTrue: [^ 'nil'].
	Color colorNames do: [:colorName | aColor = (Color perform: colorName)
								ifTrue: [^ 'Color ' , colorName]].
	^ aColor storeString! !

!Morph methodsFor: 'printing'!
constructorString

	^ String streamContents: [:s | self printConstructorOn: s indent: 0].
! !

!Morph methodsFor: 'printing' stamp: 'sw 5/29/2000 00:41'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."
	^ super printString truncateTo: 40! !

!Morph methodsFor: 'printing'!
fullPrintOn: aStream

	aStream nextPutAll: self class name , ' newBounds: (';
		print: bounds;
		nextPutAll: ') color: ' , (self colorString: color)! !

!Morph methodsFor: 'printing'!
initString

	^ String streamContents: [:s | self fullPrintOn: s]! !

!Morph methodsFor: 'printing' stamp: 'RAA 2/1/2001 17:42'!
pagesHandledAutomatically

	^false! !

!Morph methodsFor: 'printing'!
printConstructorOn: aStream indent: level

	^ self printConstructorOn: aStream indent: level nodeDict: IdentityDictionary new
! !

!Morph methodsFor: 'printing'!
printConstructorOn: aStream indent: level nodeDict: nodeDict
	| nodeString |
	(nodeString _ nodeDict at: self ifAbsent: [nil])
		ifNotNil: [^ aStream nextPutAll: nodeString].
	submorphs isEmpty ifFalse: [aStream nextPutAll: '('].
	aStream nextPutAll: '('.
	self fullPrintOn: aStream.
	aStream nextPutAll: ')'.
	submorphs isEmpty ifTrue: [^ self].
	submorphs size <= 4
	ifTrue:
		[aStream crtab: level+1;
			nextPutAll: 'addAllMorphs: (Array'.
		1 to: submorphs size do:
			[:i | aStream crtab: level+1; nextPutAll: 'with: '.
			(submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict].
		aStream nextPutAll: '))']
	ifFalse:
		[aStream crtab: level+1;
			nextPutAll: 'addAllMorphs: ((Array new: ', submorphs size printString, ')'.
		1 to: submorphs size do:
			[:i |
			aStream crtab: level+1; nextPutAll: 'at: ', i printString, ' put: '.
			(submorphs at: i) printConstructorOn: aStream indent: level+1 nodeDict: nodeDict.
			aStream nextPutAll: ';'].
		aStream crtab: level+1; nextPutAll: 'yourself))']! !

!Morph methodsFor: 'printing' stamp: 'sw 9/5/2000 06:49'!
printOn: aStream

	| aName |
	super printOn: aStream.

	(aName _ self knownName) ~~ nil ifTrue:
		[aStream nextPutAll: '<', aName, '>'].

	aStream nextPutAll: '('.
	aStream print: self identityHash;
			nextPutAll: ')'.! !

!Morph methodsFor: 'printing' stamp: 'RAA 9/18/2000 10:22'!
printSpecs

	| printSpecs |

	printSpecs _ self valueOfProperty: #PrintSpecifications.
	printSpecs ifNil: [
		printSpecs _ PrintSpecifications defaultSpecs.
		self printSpecs: printSpecs.
	].
	^printSpecs! !

!Morph methodsFor: 'printing' stamp: 'RAA 9/18/2000 10:21'!
printSpecs: aPrintSecification

	self setProperty: #PrintSpecifications toValue: aPrintSecification.
! !

!Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 18:00'!
printStructureOn: aStream indent: tabCount

	tabCount timesRepeat: [aStream tab].
	self printOn: aStream.
	aStream cr.
	self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1].
! !

!Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 17:58'!
structureString
	"Return a string that showing this morph and all its submorphs in an indented list that reflects its structure."

	| s |
	s _ WriteStream on: (String new: 1000).
	self printStructureOn: s indent: 0.
	^ s contents
! !

!Morph methodsFor: 'printing' stamp: 'sw 10/27/2000 17:47'!
textToPaste
	"If the receiver has text to offer pasting, answer it, else answer nil"

	^ nil! !


!Morph methodsFor: 'property extension' stamp: 'sw 10/20/1998 00:27'!
assureExtension

	extension == nil ifTrue: [extension _ MorphExtension new initialize].
	^ extension! !

!Morph methodsFor: 'property extension' stamp: 'di 8/11/1998 22:08'!
copyPropertiesFrom: donorMorph dict: dict
	(extension _ donorMorph extension copy) == nil ifTrue: [^ self].
	extension copyPropertiesFrom: donorMorph dict: dict! !

!Morph methodsFor: 'property extension' stamp: 'di 8/10/1998 14:25'!
extension
	^ extension! !

!Morph methodsFor: 'property extension' stamp: 'di 8/11/1998 12:01'!
otherProperties
	extension == nil ifTrue: [^ nil].
	^ extension otherProperties! !

!Morph methodsFor: 'property extension' stamp: 'ar 11/13/2000 19:27'!
resetExtension
	"Reset the extension slot if it is not needed"
	extension ifNil:[^false]. "not removed"
	extension isDefault ifTrue:[
		extension _ nil.
		^true].
	^false! !


!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:35'!
fullLoadCachedState
	"Load the cached state of the receiver and its full submorph tree."

	self allMorphsDo: [:m | m loadCachedState].
! !

!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:34'!
fullReleaseCachedState
	"Release the cached state of the receiver and its full submorph tree."

	self allMorphsDo: [:m | m releaseCachedState].
! !

!Morph methodsFor: 'caching' stamp: 'jm 11/13/97 16:37'!
loadCachedState
	"Load the cached state of this morph. This method may be called to pre-load the cached state of a morph to avoid delays when it is first used. (Cached state can always be recompued on demand, so a morph should not rely on this method being called.) Implementations of this method should do 'super loadCachedState'. This default implementation does nothing."
! !

!Morph methodsFor: 'caching' stamp: 'ar 11/12/2000 18:41'!
releaseCachedState
	"Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'."
	self wonderlandTexture: nil. "We can recreate it if needed"! !


!Morph methodsFor: 'debug and other' stamp: 'ar 10/5/2000 17:04'!
addDebuggingItemsTo: aMenu hand: aHandMorph
	aMenu add: 'debug...' subMenu:  (self buildDebugMenu: aHandMorph)! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'!
addMouseActionIndicatorsWidth: anInteger color: aColor

	self deleteAnyMouseActionIndicators.

	self changed.
	self hasRolloverBorder: true.
	self setProperty: #rolloverWidth toValue: anInteger@anInteger.
	self setProperty: #rolloverColor toValue: aColor.
	self layoutChanged.
	self changed.

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/13/2000 11:19'!
addMouseUpAction 

	| codeToRun oldCode |

	oldCode _ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [''].
	codeToRun _ FillInTheBlank request: 'MouseUp expression:' initialAnswer: oldCode.
	self addMouseUpActionWith: codeToRun

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 11/12/2000 13:44'!
addMouseUpActionWith: codeToRun

	((codeToRun isKindOf: MessageSend) not and: [codeToRun isEmptyOrNil]) ifTrue: [^self].
	self setProperty: #mouseUpCodeToRun toValue: codeToRun.
	self
		on: #mouseUp 
		send: #programmedMouseUp:for:
		to: self.
	self
		on: #mouseDown
		send: #programmedMouseDown:for:
		to: self.
	self
		on: #mouseEnter
		send: #programmedMouseEnter:for:
		to: self.
	self
		on: #mouseLeave
		send: #programmedMouseLeave:for:
		to: self.

! !

!Morph methodsFor: 'debug and other' stamp: 'sw 1/3/2001 06:42'!
addViewingItemsTo: aMenu
	"Add viewing-related items to the given menu.  If any are added, this method is also responsible for adding a line after them"! !

!Morph methodsFor: 'debug and other' stamp: 'tk 1/26/1999 09:22'!
allStringsAfter: aSubmorph
	"return an OrderedCollection of strings of text in my submorphs.  If aSubmorph is non-nil, begin with that container."

	| list string ok |
	list _ OrderedCollection new.
	ok _ aSubmorph == nil.
	self allMorphsDo: [:sub | 
		ok ifFalse: [ok _ sub == aSubmorph].		"and do this one too"
		ok ifTrue: [
			(string _ sub userString) ifNotNil: [
				(string isKindOf: String) 
					ifTrue: [list add: string]
					ifFalse: [list addAll: string]]]].
	^ list! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:27'!
altSpecialCursor0
	"an arrow"
	^(Form
	extent: 16@16
	depth: 8
	fromArray: #( 0 0 0 0 14869218 3806520034 3806520034 3791650816 14848144 2425393296 2425393378 0 14848144 2425393296 2425414144 0 14848144 2425393296 2430730240 0 14848144 2425393296 3791650816 0 14848144 2425393378 3791650816 0 14848144 2425414370 3806461952 0 14848144 2430788322 3806519808 0 14848144 3791651042 3806520034 0 14848226 0 3806520034 3791650816 14868992 0 14869218 3806461952 14811136 0 58082 3806519808 0 0 226 3806520034 0 0 0 3806520034 0 0 0 14869218)
	offset: 0@0)
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:28'!
altSpecialCursor1
	"a star and an arrow"
	^(Form
	extent: 31@26
	depth: 8
	fromArray: #( 14417920 0 0 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3705461760 0 0 0 0 0 14474460 3705461980 3705405440 0 0 0 0 0 56540 3705461980 3690987520 0 0 3690987520 0 0 220 3705461980 3705461760 0 0 3690987520 0 0 220 3705405440 3705461980 0 0 3705405440 0 0 0 3705461760 56540 3690987520 220 3705405440 0 0 0 3705405440 220 3705461760 220 3705405440 0 0 0 0 0 14474460 220 3705461760 0 0 0 0 0 56540 3691044060 3705461760 0 0 0 0 0 220 3705461980 3705461760 0 0 0 0 56540 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 220 3705461980 3705461980 3705461980 3705461980 3705461760 0 0 0 3705461980 3705461980 3705461980 3705461980 3705405440 0 0 0 14474460 3705461980 3705461980 3705461980 3690987520 0 0 0 56540 3705461980 3705461980 3705461760 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 0 3705461980 3705461980 3690987520 0 0 0 0 0 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 3705461980 3705405440 0 0 0 0 220 3705461980 14474460 3705405440 0 0 0 0 220 3705405440 220 3705461760 0 0 0 0 56540 3690987520 0 3705461760 0 0 0 0 56540 0 0 14474240 0)
	offset: 0@0)! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:41'!
altSpecialCursor2
	| f |
	"a blue box with transparent center"
	f _ Form extent: 32@32 depth: 32.
	f offset: (f extent // 2) negated.
	f fill: f boundingBox rule: Form over fillColor: (Color blue alpha: 0.5).
	f fill: (f boundingBox insetBy: 4) rule: Form over fillColor: Color transparent.
	^f
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:42'!
altSpecialCursor3
	
	^self altSpecialCursor3: Color blue! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:41'!
altSpecialCursor3: aColor
	| f box |
	"a bulls-eye pattern in this color"
	f _ Form extent: 32@32 depth: 32.
	f offset: (f extent // 2) negated.
	box _ f boundingBox.
	[ box width > 0] whileTrue: [
		f fill: box rule: Form over fillColor: aColor.
		f fill: (box insetBy: 2) rule: Form over fillColor: Color transparent.
		box _ box insetBy: 4.
	].
	^f
! !

!Morph methodsFor: 'debug and other' stamp: 'sw 1/3/2001 07:11'!
buildDebugMenu: aHand
	"Answer a debugging menu for the receiver.  The hand argument is seemingly historical and plays no role presently"

	| aMenu aPlayer |

	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	(self hasProperty: #errorOnDraw) ifTrue:
		[aMenu add: 'start drawing again' action: #resumeAfterDrawError.
		aMenu addLine].
	(self hasProperty: #errorOnStep) ifTrue:
		[aMenu add: 'start stepping again' action: #resumeAfterStepError.
		aMenu addLine].

	aMenu add: 'inspect morph' action: #inspectInMorphic:.
	aMenu add: 'inspect owner chain' action: #inspectOwnerChain.
	Smalltalk isMorphic ifFalse:
		[aMenu add: 'inspect morph (in MVC)' action: #inspect].

	(self isKindOf: MorphicModel) ifTrue:
		[aMenu add: 'inspect model' target: self model action: #inspect].
	(aPlayer _ self player) ifNotNil:
		[aMenu add: 'inspect player' target: aPlayer action: #inspect].

     aMenu add: 'explore morph' target: self selector: #explore.

	aPlayer ifNotNil: [aPlayer class isUniClass ifTrue: [aMenu add: 'browse player class' target: aPlayer action: #browseHierarchy].
		"aMenu add: 'browse player protocol' target: self action: #browseProtocolForPlayer"].

	aMenu add: 'browse morph class' target: self selector: #browseHierarchy.
	"aMenu add: 'browse morph protocol' target: self selector: #haveFullProtocolBrowsed."
	aMenu addLine.
	self addViewingItemsTo: aMenu.
	aMenu 
		add: 'make own subclass' action: #subclassMorph;
		add: 'internal name ' action: #choosePartName;
		add: 'save morph in file'  action: #saveOnFile;
		addLine;
		add: 'call #tempCommand' action: #tempCommand;
		add: 'define #tempCommand' action: #defineTempCommand;
		addLine;

		add: 'control-menu...' target: self selector: #invokeMetaMenu:;
		add: 'edit balloon help' action: #editBalloonHelpText.

	^ aMenu! !

!Morph methodsFor: 'debug and other' stamp: 'sw 11/2/1998 15:54'!
defineTempCommand
	"To use this, comment out what's below here, and substitute your own code.
You will then be able to invoke it from the standard debugging menus.  If invoked from the world menu, you'll always get it invoked on behalf of the world, but if invoked from an individual morph's meta-menu, it will be invoked on behalf of that individual morph.

Note that you can indeed reimplement tempCommand in an individual morph's class if you wish"

	Browser openMessageBrowserForClass: Morph
		selector: #tempCommand editString: nil! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'!
deleteAnyMouseActionIndicators

	self changed.
	(self valueOfProperty: #mouseActionIndicatorMorphs ifAbsent: [#()]) do: [ :each |
		each deleteWithSiblings		"one is probably enough, but be safe"
	].
	self removeProperty: #mouseActionIndicatorMorphs.
	self hasRolloverBorder: false.
	self removeProperty: #rolloverWidth.
	self removeProperty: #rolloverColor.
	self layoutChanged.
	self changed.

! !

!Morph methodsFor: 'debug and other' stamp: 'ar 10/5/2000 17:38'!
inspectArgumentsPlayerInMorphic: evt
	evt hand attachMorph: ((Inspector openAsMorphOn: self player) extent: 300@200)! !

!Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:31'!
inspectOwnerChain
	self ownerChain inspectWithLabel: 'Owner chain for ', self printString! !

!Morph methodsFor: 'debug and other'!
installModelIn: ignored
	"Simple morphs have no model"
	"See MorphicApp for other behavior"! !

!Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:28'!
ownerChain
	"Answer a list of objects representing the receiver and all of its owners.   The first element is the receiver, and the last one is typically the world in which the receiver resides"
	| c next |
	c _ OrderedCollection with: self.
	next _ self.
	[(next _ next owner) ~~ nil] whileTrue: [c add: next].
	^ c asArray! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'!
programmedMouseDown: anEvent for: aMorph

	aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:16'!
programmedMouseEnter: anEvent for: aMorph

	aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).

! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/12/2000 11:10'!
programmedMouseLeave: anEvent for: aMorph

	self deleteAnyMouseActionIndicators.
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 11/12/2000 13:42'!
programmedMouseUp: anEvent for: aMorph

	| aCodeString |

	self deleteAnyMouseActionIndicators.
	aCodeString _ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self].
	(self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	[
		(aCodeString isKindOf: MessageSend) ifTrue: [
			aCodeString value
		] ifFalse: [
			Compiler
				evaluate: aCodeString
				for: self
				notifying: nil
				logged: false
		].
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: self].		"in case a save/load progress display needs a home"
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:57'!
programmedMouseUp: anEvent for: aMorph with: aCodeString

	self flag: #bob.		"no longer used, but there may be old morphs out there"
	anEvent hand showTemporaryCursor: nil.
	(self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self].
	[
		Compiler
			evaluate: aCodeString
			for: self
			notifying: nil
			logged: false
	]
		on: ProgressTargetRequestNotification
		do: [ :ex | ex resume: self].		"in case a save/load progress display needs a home"
! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 7/7/2000 16:43'!
removeMouseUpAction

	self primaryHand showTemporaryCursor: nil.
	self removeProperty: #mouseUpCodeToRun.
	#(mouseUp mouseEnter mouseLeave mouseDown) do: [ :sym |
		self
			on: sym 
			send: #yourself 
			to: nil.
	]

! !

!Morph methodsFor: 'debug and other' stamp: 'sw 10/27/2000 17:45'!
reportableSize
	"Answer a size worth reporting as the receiver's size in a list view"

	| total |
	total _ super reportableSize.
	submorphs do:
		[:m | total _ total + m reportableSize].
	^ total! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'!
resumeAfterDrawError

	self changed.
	self removeProperty:#errorOnDraw.
	self changed.! !

!Morph methodsFor: 'debug and other' stamp: 'RAA 5/24/2000 18:20'!
resumeAfterStepError
	"Resume stepping after an error has occured."

	self startStepping. "Will #step"
	self removeProperty:#errorOnStep. "Will remove prop only if #step was okay"
! !

!Morph methodsFor: 'debug and other' stamp: 'sw 11/2/1998 15:51'!
tempCommand
	"Generic backstop.  If you care to, you can comment out what's below here, and substitute your own code, though the intention of design of the feature is that you leave this method as it is, and instead reimplement tempCommand in the class of whatever individual morph you care to.  In any case, once you have your own #tempCommand in place, you will then be able to invoke it from the standard debugging menus."

	self inform: 'Before calling tempCommand, you
should first give it a definition.  To
do this, choose "define tempCommand"
from the debug menu.'! !


!Morph methodsFor: 'private' stamp: 'sw 10/25/2000 06:11'!
moveWithPenDownBy: delta
	"If this is a costume for a player with its pen down, draw a line."

	| trailMorph tfm start tfmEnd |
	(trailMorph _ self trailMorph) ifNotNil:
		[tfm _ self owner transformFrom: trailMorph.
		start _  self referencePosition.
		trailMorph batchPenTrails
			ifTrue: [trailMorph notePenDown: true
								forPlayer: self player
								at: (tfm localPointToGlobal: start)]
			ifFalse: [trailMorph drawPenTrailFor: self
								from: (tfm localPointToGlobal: start)
								to: (tfmEnd _ tfm localPointToGlobal: start + delta).
					trailMorph noteNewLocation: tfmEnd forPlayer: self player]]
! !

!Morph methodsFor: 'private' stamp: 'sw 10/25/2000 06:11'!
moveWithPenDownByRAA: delta

	| trailMorph tfm start tfmEnd xStart |

	self flag: #bob.		"temp revert to old version for Alan's demo"

	"If this is a costume for a player with its pen down, draw a line."
	(trailMorph _ self trailMorph) ifNil: [^self].

	tfm _ self owner transformFrom: "trailMorph" self world.
	start _  self referencePosition.
	trailMorph batchPenTrails 
		ifTrue:
			[trailMorph notePenDown: true forPlayer: self player at: (tfm localPointToGlobal: start)] 		ifFalse:
			[xStart _ (tfm localPointToGlobal: start).
			tfmEnd _ tfm localPointToGlobal: start + delta.
			trailMorph drawPenTrailFor: self from: xStart to: tfmEnd.

			"I don't think we should be doing this if batchPenTrails is false"
			"trailMorph noteNewLocation: tfmEnd forPlayer: self player."]
	! !

!Morph methodsFor: 'private' stamp: 'RAA 2/1/2001 14:45'!
privateAddMorph: aMorph atIndex: index

	| oldIndex myWorld itsWorld |
	((index >= 1) and: [index <= (submorphs size + 1)])
		ifFalse: [^ self error: 'index out of range'].
	myWorld _ self world.
	aMorph owner == self ifTrue:[
		"aMorph's position changes within in the submorph chain"
		oldIndex _ submorphs indexOf: aMorph.
		oldIndex < index ifTrue:[
			"moving aMorph to back"
			submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1.
			submorphs at: index-1 put: aMorph.
		] ifFalse:[
			"moving aMorph to front"
			oldIndex-1 to: index by: -1 do:[:i|
				submorphs at: i+1 put: (submorphs at: i)].
			submorphs at: index put: aMorph.
		].
	] ifFalse:[
		"adding a new morph"
		aMorph owner ifNotNil:[
			itsWorld _ aMorph world.
			itsWorld == myWorld ifFalse:[aMorph outOfWorld: itsWorld].
			aMorph owner privateRemoveMorph: aMorph].
		aMorph privateOwner: self.
		submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).
		itsWorld == myWorld ifFalse:[aMorph intoWorld: myWorld].
	].
	self layoutChanged.
	myWorld ifNotNil:[self invalidRect: aMorph fullBounds from: aMorph].! !

!Morph methodsFor: 'private'!
privateBounds: boundsRect
	"Private!! Use position: and/or extent: instead."

	fullBounds _ nil.
	bounds _ boundsRect.! !

!Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'!
privateColor: aColor

	color _ aColor.
! !

!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:31'!
privateDeleteWithAbsolutelyNoSideEffects
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	"used to delete a morph from an inactive world"

	owner ifNil: [^self].
	owner privateRemoveMorphWithAbsolutelyNoSideEffects: self.
	owner _ nil.

! !

!Morph methodsFor: 'private' stamp: 'tk 8/30/1998 09:58'!
privateFullBounds: boundsRect
	"Private!! Computed automatically."

	fullBounds _ boundsRect.! !

!Morph methodsFor: 'private' stamp: 'jm 7/8/97 08:32'!
privateFullMoveBy: delta
	"Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method."

	self privateMoveBy: delta.
	1 to: submorphs size do: [:i |
		(submorphs at: i) privateFullMoveBy: delta].
! !

!Morph methodsFor: 'private' stamp: 'ar 11/12/2000 18:58'!
privateMoveBy: delta
	"Private!! Use 'position:' instead."
	| fill |
	extension ifNotNil:[
		extension player ifNotNil:[
			"Most cases eliminated fast by above test"
			self getPenDown ifTrue:[
				"If this is a costume for a player with its pen down, draw a line."
				self moveWithPenDownBy: delta]]].
	bounds _ bounds translateBy: delta.
	fullBounds ifNotNil:[fullBounds _ fullBounds translateBy: delta].
	fill _ self fillStyle.
	fill isOrientedFill ifTrue:[fill origin: fill origin + delta].
! !

!Morph methodsFor: 'private'!
privateOwner: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	owner _ aMorph.! !

!Morph methodsFor: 'private' stamp: 'ar 11/13/2000 01:43'!
privateRemoveMorph: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	self isInWorld ifTrue:[self invalidRect: aMorph fullBounds from: aMorph].
	submorphs _ submorphs copyWithout: aMorph.
	self layoutChanged.
! !

!Morph methodsFor: 'private' stamp: 'RAA 5/23/2000 11:30'!
privateRemoveMorphWithAbsolutelyNoSideEffects: aMorph
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."
	"used to delete a morph from an inactive world"

	submorphs _ submorphs copyWithout: aMorph.

! !

!Morph methodsFor: 'private'!
privateSubmorphs
	"Private!! Use 'submorphs' instead."

	^ submorphs! !

!Morph methodsFor: 'private'!
privateSubmorphs: aCollection
	"Private!! Should only be used by methods that maintain the ower/submorph invariant."

	submorphs _ aCollection.! !


!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 08:35'!
attachToResource
	"Produce a morph from a file -- either a saved .morph file or a graphics file"

	| pathName |
	pathName _ Utilities chooseFileWithSuffixFromList: (#('.morph'), Utilities graphicsFileSuffixes)
			withCaption: 'Choose a file
to load'.
	pathName ifNil: [^ self].  "User made no choice"
	pathName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .morph, .gif,
.bmp, .jpeg, .jpe, .jp, or .form)'].

	self setProperty: #resourceFilePath toValue: pathName! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 9/28/2000 15:45'!
objectForDataStream: refStrm
	| dp |
	"I am being written out on an object file"

	self sqkPage ifNotNil: [
		(refStrm rootObject == self) | (refStrm rootObject == self sqkPage) ifFalse: [
			self url size > 0 ifTrue: [
				dp _ self sqkPage copyForSaving.	"be careful touching this object!!"
				refStrm replace: self with: dp.
				^ dp]]].
	self prepareToBeSaved.		"Amen"
	^ self
! !

!Morph methodsFor: 'fileIn/out' stamp: 'di 11/14/97 10:24'!
prepareToBeSaved
	"Prepare this morph to be saved to disk. Subclasses should nil out any instance variables that holds state that should not be saved, such as cached Forms. Note that this operation may take more drastic measures than releaseCachedState; for example, it might discard the transcript of an interactive chat session."

	self releaseCachedState.
	fullBounds _ nil.
! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 2/17/1999 17:50'!
reserveUrl: urlString
	"Write a dummy object to the server to hold a name and place for this object."

	| dummy ext str |
	dummy _ PasteUpMorph new.
	dummy borderWidth: 2.
	dummy setProperty: #initialExtent toValue: (ext _ 300@100).
	dummy topLeft: 50@50; extent: ext.	"reset when comes in"
	str _ (TextMorph new) topLeft: dummy topLeft + (10@10); 
		extent: dummy width - 15 @ 30.
	dummy addMorph: str.
	str contents: 'This is a place holder only.  Please \find the original page and choose \"send this page to server"' withCRs.
	str extent: dummy width - 15 @ 30.
	dummy saveOnURL: urlString.

	"Claim that url myself"
	self setProperty: #SqueakPage toValue: dummy sqkPage.
	(dummy sqkPage) contentsMorph: self; dirty: true.
	^ self url! !

!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 08:52'!
saveAsResource

	| pathName |
	(self hasProperty: #resourceFilePath) ifFalse: [^ self].
	pathName _ self valueOfProperty: #resourceFilePath.
	(pathName asLowercase endsWith: '.morph') ifFalse:
		[^ self error: 'Can only update morphic resources'].
	(FileStream newFileNamed: pathName) fileOutClass: nil andObject: self.! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 2/9/1999 20:18'!
saveDocPane

	DocLibrary external saveDocCheck: self! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 3/4/1999 09:48'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| aFileName fileStream ok |
	aFileName _ ('my ', self class name) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' 
			initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ self beep].
	self allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.morph'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.morph'].
	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 7/16/1999 13:03'!
saveOnURL
	"Ask the user for a url and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| um pg |
	(pg _ self saveOnURLbasic) == #cancel ifTrue: [^ self].
	um _ URLMorph newForURL: pg url.
	um setURL: pg url page: pg.
	pg isContentsInMemory ifTrue: [pg computeThumbnail].
	um isBookmark: true.
	um removeAllMorphs.
	um color: Color transparent.
	self primaryHand attachMorph: um.! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 11/20/1998 11:47'!
saveOnURL: suggestedUrlString
	"Save myself on a SmartReferenceStream file.  If I don't already have a url, use the suggested one.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| url pg stamp pol |
	(pg _ self valueOfProperty: #SqueakPage) ifNil: [pg _ SqueakPage new]
		ifNotNil: [pg contentsMorph ~~ self ifTrue: [
				self inform: 'morph''s SqueakPage property is out of date'.
				pg _ SqueakPage new]].
	(url _ pg url) ifNil: [url _ pg urlNoOverwrite: suggestedUrlString].
	stamp _ Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: self author: stamp.
	SqueakPageCache atURL: url put: pg.	"setProperty: #SqueakPage"
	(pol _ pg policy) ifNil: [pol _ #neverWrite].
	pg policy: #now; dirty: true.  pg write.	"force the write"
	pg policy: pol.
	^ pg! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 7/16/1999 13:02'!
saveOnURLbasic
	"Ask the user for a url and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| url pg stamp pol |
	(pg _ self valueOfProperty: #SqueakPage) ifNil: [pg _ SqueakPage new]
		ifNotNil: [pg contentsMorph ~~ self ifTrue: [
				self inform: 'morph''s SqueakPage property is out of date'.
				pg _ SqueakPage new]].
	(url _ pg url) ifNil: [
		url _ ServerDirectory defaultStemUrl, '1.sp'.	"A new legal place"
		url _ FillInTheBlank 
				request: 'url of a place to store this object.
Must begin with file:// or ftp://' 
				initialAnswer: url.
		url size == 0 ifTrue: [^ #cancel]].
	stamp _ Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: self author: stamp.
	SqueakPageCache atURL: url put: pg.	"setProperty: #SqueakPage"
	(pol _ pg policy) ifNil: [pol _ #neverWrite].
	pg policy: #now; dirty: true.  pg write.	"force the write"
	pg policy: pol.
	^ pg! !

!Morph methodsFor: 'fileIn/out' stamp: 'tk 7/11/1998 18:53'!
storeDataOn: aDataStream
	"Let all Morphs be written out.  All owners are weak references.  They only go out if the owner is in the tree being written."
	| cntInstVars cntIndexedVars ti localInstVars |

	"block my owner unless he is written out by someone else"
	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	localInstVars _ Morph instVarNames.
	ti _ 2.  
	((localInstVars at: ti) = 'owner') & (Morph superclass == Object) ifFalse:
			[self error: 'this method is out of date'].
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: ti-1 do:
		[:i | aDataStream nextPut: (self instVarAt: i)].
	aDataStream nextPutWeak: owner.	"owner only written if in our tree"
	ti+1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self instVarAt: i)].
	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]! !

!Morph methodsFor: 'fileIn/out' stamp: 'di 11/18/1999 09:15'!
updateAllFromResources

	self allMorphsDo: [:m | m updateFromResource]! !

!Morph methodsFor: 'fileIn/out' stamp: 'mdr 9/4/2000 10:46'!
updateFromResource

	| pathName newMorph f |
	(pathName _ self valueOfProperty: #resourceFilePath) ifNil: [^ self].
	(pathName asLowercase endsWith: '.morph')
		ifTrue:
			[newMorph _ (FileStream readOnlyFileNamed: pathName) fileInObjectAndCode.
			(newMorph isKindOf: Morph) ifFalse: [^ self error: 'Resource not a single morph']]
		ifFalse:
			[f _ Form fromFileNamed: pathName.
			f ifNil: [^ self error: 'unrecognized image file format'].
			newMorph _ SketchMorph withForm: f].
	newMorph setProperty: #resourceFilePath toValue: pathName.
	self owner replaceSubmorph: self by: newMorph
! !


!Morph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 16:42'!
convertAugust1998: varDict using: smartRefStrm
	"These variables are automatically stored into the new instance ('bounds' 'owner' 'submorphs' 'fullBounds' 'color' ).
	This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."

	"Be sure to to fill in ('extension' ) and deal with the information in ('eventHandler' 'properties' 'costumee' )"

"This method moves all property variables as well as eventHandler, and costumee into a morphicExtension."
	| propVal |
	"Move refs to eventhandler and costumee into extension"
	(varDict at: 'eventHandler') == nil ifFalse: [self eventHandler: (varDict at: 'eventHandler')].
	(varDict at: 'costumee') == nil ifFalse: [self player: (varDict at: 'costumee')].
	(varDict at: 'properties') == nil ifFalse:
		[(varDict at: 'properties') keys do:
			[:key |  "Move property extensions into extension"
			propVal _ (varDict at: 'properties') at: key.
			propVal ifNotNil:
				[key == #possessive
				ifTrue: [propVal == true ifTrue: [self bePossessive]]
				ifFalse: [key ifNotNil: [
					self assureExtension.
					extension convertProperty: key toValue: propVal]]]].
			].
! !

!Morph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 16:45'!
convertNovember2000DropShadow: varDict using: smartRefStrm
	| rend |
	"Work hard to eliminate the DropShadow.  Inst vars are already stored into."

	submorphs size > 0 ifTrue: [
		rend _ submorphs first renderedMorph.	"a text?"
		rend setProperty: #hasDropShadow toValue: true.
		rend setProperty: #shadowColor toValue: (varDict at: 'color').
		rend setProperty: #shadowOffset toValue: (varDict at: 'shadowOffset').
		"ds owner ifNotNil: [ds owner addAllMorphs: ds submorphs].   ^rend does this"
		rend privateOwner: owner.
		extension ifNotNil: [
			extension actorState ifNotNil: [
				rend actorState: extension actorState].
			extension externalName ifNotNil: [
				rend setNameTo: extension externalName].
			extension player ifNotNil: [
				rend player: extension player.
				extension player rawCostume: rend]].
		^ rend].
	(rend _ Morph new) color: Color transparent.
	^ rend
! !

!Morph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 18:00'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	(varDict at: #ClassName) == #DropShadowMorph ifTrue: [
		varDict at: #ClassName put: #Morph.	"so we don't repeat this"
		^self convertNovember2000DropShadow: varDict using: smartRefStrm
	].
	varDict at: 'costumee' ifPresent: [ :x | self convertAugust1998: varDict using: smartRefStrm].

	"5/18/2000"
	varDict at: 'openToDragNDrop' ifPresent: [ :x | self enableDragNDrop: x ].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.


! !


!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^self class == Morph "no subclasses"! !

!Morph methodsFor: 'visual properties' stamp: 'sw 1/27/2000 19:18'!
canSetColor
	"Answer true iff the receiver can meaningfully have its color changed"
	^ true! !

!Morph methodsFor: 'visual properties' stamp: 'sw 10/7/2000 10:16'!
cornerStyle
	"Answer the style, #square or #rounded, of corners.  This is a backstop implementation for morphs that don't do rounded corners."

	^ #square! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'!
defaultColor
	"Return the default fill style for the receiver"
	^Color blue! !

!Morph methodsFor: 'visual properties' stamp: 'ar 11/12/2000 18:59'!
fillStyle
	"Return the current fillStyle of the receiver."
	extension ifNil:[^color ifNil:[self defaultColor]].
	^self valueOfProperty: #fillStyle ifAbsent:[
		"Workaround already converted morphs"
		color ifNil:[self defaultColor]].! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 07:05'!
fillStyle: aFillStyle
	"Set the current fillStyle of the receiver."
	self setProperty: #fillStyle toValue: aFillStyle.
	"Workaround for Morphs not yet converted"
	color _ aFillStyle asColor.
	self changed.! !

!Morph methodsFor: 'visual properties' stamp: 'RAA 7/23/2000 17:49'!
fillWithRamp: rampSpecs oriented: aRatio

	| fill |
	fill _ GradientFillStyle ramp: rampSpecs.
	fill origin: self bounds topLeft.
	fill direction: (self bounds extent * aRatio) truncated.
	fill radial: false.
	self fillStyle: fill.
! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 12:00'!
useBitmapFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	| fill |
	self fillStyle isBitmapFill ifTrue:[^self]. "Already done"
	fill _ BitmapFillStyle fromForm: ImageMorph defaultForm.
	"Note: Must fix the origin due to global coordinates"
	fill origin: self bounds origin.
	self fillStyle: fill.! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:11'!
useDefaultFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	self fillStyle: self defaultColor.! !

!Morph methodsFor: 'visual properties' stamp: 'bf 5/14/2000 22:33'!
useGradientFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	| fill color1 color2 |
	self fillStyle isGradientFill ifTrue:[^self]. "Already done"
	color1 _ self color dominantColor.
	color2 _ color1 negated.
	fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}.
	fill origin: self topLeft.
	fill direction: 0 @ self bounds extent y.
	fill normal: self bounds extent x @ 0.
	fill radial: false.
	self fillStyle: fill.! !

!Morph methodsFor: 'visual properties' stamp: 'ar 6/18/1999 06:57'!
useSolidFill
	"Make receiver use a solid fill style (e.g., a simple color)"
	self fillStyle isSolidFill ifTrue:[^self]. "Already done"
	self fillStyle: self fillStyle asColor. "Try minimizing changes"! !


!Morph methodsFor: 'texture support' stamp: 'ar 11/12/2000 18:40'!
asTexture
	"Represent the receiver as a Wonderland texture."
	| canvas texture hqTexture texExtent tempForm valid |
	hqTexture _ self valueOfProperty: #highQualityTexture ifAbsent:[false].
	valid _ self isValidWonderlandTexture.
	texture _ self wonderlandTexture.
	"Determine the size we expect the texture to be.
	Note: This size must never be less than the receiver's since
	this will lead to (unwanted) clipping."
	texExtent _ self extent.
	hqTexture ifTrue:[
		"High quality textures round up to next power of two"
		texExtent _ texExtent x asLargerPowerOfTwo @ texExtent y asLargerPowerOfTwo.
	].
	(texture == nil or:[texture extent ~= texExtent]) ifTrue:[
		self removeProperty: #wonderlandTexture.
		texture _ nil. "Clean up for GC"
		texture _ B3DTexture extent: texExtent depth: 32.
		texture interpolate: false.
		texture wrap: false.
		texture envMode: 0.
		valid _ false].
	valid ifFalse:[
		canvas _ texture getCanvas.
		canvas translateBy: self topLeft negated
			during:[:tempCanvas| tempCanvas fullDrawMorph: self].
		self isValidWonderlandTexture: true.
		"High quality textures need an extra pass here"
		(texExtent ~= self extent) ifTrue:[
			tempForm _ texture contentsOfArea: (0@0 extent: self extent).
			tempForm displayInterpolatedOn: texture].
	].
	self setProperty: #wonderlandTexture toValue: texture.
	^ texture! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/7/1999 23:17'!
installAsWonderlandTextureOn: anActor
	"Make the receiver a texture for the given actor"
	^anActor setTexturePointer: self! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/12/2000 18:40'!
isValidWonderlandTexture
	"Return true if the receiver is a valid wonderland texture"
	extension == nil ifTrue:[^false].
	^self valueOfProperty: #isValidWonderlandTexture ifAbsent:[true]! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/12/2000 18:40'!
isValidWonderlandTexture: aBool
	"Return true if the receiver is a valid wonderland texture"
	aBool == true
		ifTrue:[self removeProperty: #isValidWonderlandTexture]
		ifFalse:[self setProperty: #isValidWonderlandTexture toValue: aBool].! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/7/1999 23:30'!
mapPrimitiveVertex: aPrimitiveVertex
	"Map the given primitive vertex into 2D space."
	| pt |
	pt _ aPrimitiveVertex texCoordS @ aPrimitiveVertex texCoordT.
	^(self extent * pt) asIntegerPoint + self position.! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/12/2000 18:35'!
wonderlandTexture
	"Return the current wonderland texture associated with the receiver"
	extension == nil ifTrue:[^nil].
	^self valueOfProperty: #wonderlandTexture ifAbsent:[nil]! !

!Morph methodsFor: 'texture support' stamp: 'ar 11/12/2000 18:36'!
wonderlandTexture: aTexture
	"Return the current wonderland texture associated with the receiver"
	aTexture == nil
		ifTrue:[self removeProperty: #wonderlandTexture]
		ifFalse:[self setProperty: #wonderlandTexture toValue: aTexture].! !


!Morph methodsFor: 'WiW support' stamp: 'RAA 12/16/2000 18:47'!
addMorphInFrontOfLayer: aMorph

	| targetLayer |
	targetLayer _ aMorph morphicLayerNumber.
	submorphs do: [ :each |
		each == aMorph ifTrue: [^self].
		"the <= is the difference - it insures we go to the front of our layer"
		targetLayer <= each morphicLayerNumber ifTrue: [
			^self addMorph: aMorph inFrontOf: each
		].
	].
	self addMorphBack: aMorph
! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 6/29/2000 10:49'!
addMorphInLayer: aMorph

	submorphs do: [ :each |
		each == aMorph ifTrue: [^self].
		aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [
			^self addMorph: aMorph inFrontOf: each
		].
	].
	self addMorphBack: aMorph
! !

!Morph methodsFor: 'WiW support' stamp: 'ar 11/9/2000 20:42'!
eToyRejectDropMorph: morphToDrop event: evt

	| tm am |

	tm _ TextMorph new 
		beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 24);
		contents: 'GOT IT!!'.
	(am _ AlignmentMorph new)
		color: Color yellow;
		layoutInset: 10;
		useRoundedCorners;
		vResizing: #shrinkWrap;
		hResizing: #shrinkWrap;
		addMorph: tm;
		fullBounds;
		position: (self bounds center - (am extent // 2));
		openInWorld: self world.
	(SampledSound soundNames includes: 'yum') ifFalse: [
		(FileDirectory default fileExists: '') ifTrue: [
			SampledSound addLibrarySoundNamed: 'yum' fromAIFFfileNamed: 'yum.aif'
		].
	].
	(SampledSound soundNames includes: 'yum') ifTrue: [
		SampledSound playSoundNamed: 'yum'
	].
	morphToDrop rejectDropMorphEvent: evt.		"send it back where it came from"
	am delete
! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 7/19/2000 20:44'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^(owner isNil or: [owner isWorldMorph]) ifTrue: [
		self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
	] ifFalse: [
		owner morphicLayerNumber
	].

	"leave lots of room for special things"! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 7/16/2000 13:54'!
randomBoundsFor: aMorph

	| trialRect |
	trialRect _ (
		self topLeft + 
			((self width * (15 + 75 atRandom/100)) rounded @
			(self height * (15 + 75 atRandom/100)) rounded)
	) extent: aMorph extent.
	^trialRect translateBy: (trialRect amountToTranslateWithin: self bounds)
! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 8/14/2000 12:09'!
shouldGetStepsFrom: aWorld

	self world == aWorld ifTrue: [^true].
	(self ownerThatIsA: HandMorph) ifNotNil: [^true].
	^false! !

!Morph methodsFor: 'WiW support' stamp: 'di 9/24/2000 12:48'!
worldMorphsDo: aBlock
	"Evaluate the given block for all worlds in this composite morph (including the receiver).
	May be overriden to save looking in useless places."

	submorphs size > 0 ifTrue:
		[submorphs do: [:m | m worldMorphsDo: aBlock]].
	self isWorldMorph ifTrue: [aBlock value: self]! !

!Morph methodsFor: 'WiW support' stamp: 'RAA 6/13/2000 11:54'!
worldUnderCursor

        "will ultimately allow one Hand to service multiple worlds"

        ^Display morphicWorldAt: Sensor cursorPoint
! !


!Morph methodsFor: 'rounding' stamp: 'ar 9/1/2000 13:44'!
roundedCorners
	"Return a list of those corners to round"
	^#(1 2 3 4) "all of 'em"! !

!Morph methodsFor: 'rounding' stamp: 'sw 10/27/2000 17:46'!
roundedCornersString
	"Answer the string to put in a menu that will invite the user to switch to the opposite corner-rounding mode"

	^ (self wantsRoundedCorners
		ifTrue:
			['<yes>']
		ifFalse:
			['<no>']), 'rounded corners'
! !

!Morph methodsFor: 'rounding' stamp: 'di 8/12/2000 14:51'!
toggleCornerRounding
	self wantsRoundedCorners
		ifTrue: [self removeProperty: #roundedCorners]
		ifFalse: [self setProperty: #roundedCorners toValue: true].
	self changed! !

!Morph methodsFor: 'rounding' stamp: 'di 8/12/2000 14:44'!
wantsRoundedCorners
	"Default response is simple, fast, and false.
	May be overridden to allow almost any morph to be rounded."

	^ false! !


!Morph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:15'!
commandHistory
	"Return the command history for the receiver"
	| w |
	(w _ self world) ifNotNil:[^w commandHistory].
	(w _ self currentWorld) ifNotNil:[^w commandHistory].
	^CommandHistory new. "won't really record anything but prevent breaking things"! !

!Morph methodsFor: 'undo' stamp: 'ar 10/10/2000 17:21'!
undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor
	"Handle undo and redo of move commands in morphic"

	self owner ifNil: [^ self beep].
	redo ifFalse:
		["undo sets up the redo state first"
		cmd redoTarget: self
			selector: #undoMove:redo:owner:bounds:predecessor:
			arguments: {cmd. true. owner. bounds. (owner morphPreceding: self)}].

	formerOwner ifNotNil:
		[formerPredecessor
			ifNil: [formerOwner addMorphFront: self]
			ifNotNil: [formerOwner addMorph: self after: formerPredecessor]].
	self bounds: formerBounds.
	(self isKindOf: SystemWindow) ifTrue: [self activate]! !


!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: #() after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: #() at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1) after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1) at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 with: arg2 after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) after: delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector with: arg1 with: arg2 at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: (Array with: arg1 with: arg2) at: scheduledTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:35'!
addAlarm: aSelector withArguments: args after: delayTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	^self addAlarm: aSelector withArguments: args at: Time millisecondClockValue + delayTime! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'!
addAlarm: aSelector withArguments: args at: scheduledTime
	"Add an alarm (that is an action to be executed once) with the given set of parameters"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler addAlarm: aSelector withArguments: args for: self at: scheduledTime].! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/11/2000 16:34'!
alarmScheduler
	"Return the scheduler being responsible for triggering alarms"
	^self world! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:14'!
removeAlarm: aSelector
	"Remove the given alarm"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler removeAlarm: aSelector for: self].! !

!Morph methodsFor: 'events-alarms' stamp: 'ar 9/14/2000 12:15'!
removeAlarm: aSelector at: scheduledTime
	"Remove the given alarm"
	| scheduler |
	scheduler _ self alarmScheduler.
	scheduler ifNotNil:[scheduler removeAlarm: aSelector at: scheduledTime for: self].! !


!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:58'!
containsPoint: aPoint event: anEvent
	"Return true if aPoint is considered to be inside the receiver for the given event.
	The default implementation treats locked children as integral part of their owners."
	(self fullBounds containsPoint: aPoint) ifFalse:[^false].
	(self containsPoint: aPoint) ifTrue:[^true].
	self submorphsDo:[:m|
		(m isLocked and:[m fullContainsPoint: 
			((m transformedFrom: self) globalPointToLocal: aPoint)]) ifTrue:[^true]].
	^false! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 14:51'!
defaultEventDispatcher
	"Return the default event dispatcher to use with events that are directly sent to the receiver"
	^MorphicEventDispatcher new! !

!Morph methodsFor: 'events-processing' stamp: 'ar 1/10/2001 21:35'!
handleDropFiles: anEvent
	"Handle a drop from the OS."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(self wantsDropFiles: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self dropFiles: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'di 12/12/2000 14:39'!
handleDropMorph: anEvent
	"Handle a dropping morph."
	| aMorph localPt |
	aMorph _ anEvent contents.
	"Do a symmetric check if both morphs like each other"
	((self wantsDroppedMorph: aMorph event: anEvent)	"I want her"
		and: [aMorph wantsToBeDroppedInto: self])		"she wants me"
		ifFalse: [aMorph removeProperty: #undoGrabCommand.
				^ self].
	anEvent wasHandled: true.
	"Transform the morph into the receiver's coordinate frame. This is currently incomplete since it only takes the offset into account where it really should take the entire transform."
	localPt _ (self transformedFrom: anEvent hand world) "full transform down"
				globalPointToLocal: aMorph referencePosition.
	aMorph referencePosition: localPt.
	self acceptDroppingMorph: aMorph event: anEvent.
	aMorph justDroppedInto: self event: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:13'!
handleEvent: anEvent
	"Handle the given event"
	^anEvent sentTo: self.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/4/2000 18:48'!
handleFocusEvent: anEvent
	"Handle the given event. This message is sent if the receiver currently has the focus and is therefore receiving events directly from some hand."
	^self handleEvent: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'!
handleKeyDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	^self keyDown: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:01'!
handleKeyUp: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	^self keyUp: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 23:23'!
handleKeystroke: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	^self keyStroke: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/16/2000 14:22'!
handleListenEvent: anEvent
	"Handle the given event. This message is sent if the receiver is a registered listener for the given event."
	^anEvent sentTo: self.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/25/2000 18:04'!
handleMouseDown: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.
	anEvent controlKeyPressed ifTrue:[^self invokeMetaMenu: anEvent].
	"Make me modal during mouse transitions"
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent].
	self mouseDown: anEvent.
	anEvent hand removeHaloFromClick: anEvent on: self.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue + self mouseStillDownThreshold
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/28/2000 17:01'!
handleMouseEnter: anEvent
	"System level event handling."
	self wantsHalo "If receiver wants halo and balloon, trigger balloon after halo"
		ifTrue:[anEvent hand triggerHaloFor: self after: self haloDelayTime]
		ifFalse:[self wantsBalloon
			ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]].
	(anEvent isDraggingEvent) ifTrue:[
		(self handlesMouseOverDragging: anEvent) ifTrue:[
			anEvent wasHandled: true.
			self mouseEnterDragging: anEvent].
		^self].
	(self handlesMouseOver: anEvent) ifTrue:[
		anEvent wasHandled: true.
		self mouseEnter: anEvent.
	].! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/6/2000 00:15'!
handleMouseLeave: anEvent
	"System level event handling."
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent isDraggingEvent ifTrue:[
		(self handlesMouseOverDragging: anEvent) ifTrue:[
			anEvent wasHandled: true.
			self mouseLeaveDragging: anEvent].
		^self].
	(self handlesMouseOver: anEvent) ifTrue:[
		anEvent wasHandled: true.
		self mouseLeave: anEvent.
	].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/25/2000 18:04'!
handleMouseMove: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	"Rules say that by default a morph gets #mouseMove iff
		* the hand is not dragging anything,
			+ and some button is down,
			+ and the receiver is the current mouse focus."
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
	anEvent wasHandled: true.
	self mouseMove: anEvent.
	(self handlesMouseStillDown: anEvent) ifTrue:[
		"Step at the new location"
		self startStepping: #handleMouseStillDown: 
			at: Time millisecondClockValue
			arguments: {anEvent copy resetHandlerFields}
			stepTime: 1].
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/25/2000 14:38'!
handleMouseOver: anEvent
	"System level event handling."
	anEvent hand noticeMouseOver: self event: anEvent! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:11'!
handleMouseStillDown: anEvent
	"Called from the stepping mechanism for morphs wanting continuously repeated 'yes the mouse is still down, yes it is still down, yes it has not changed yet, no the mouse is still not up, yes the button is down' etc messages"
	(anEvent hand mouseFocus == self) 
		ifFalse:[^self stopSteppingSelector: #handleMouseStillDown:].
	self mouseStillDown: anEvent.
! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/22/2000 17:09'!
handleMouseUp: anEvent
	"System level event handling."
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	anEvent blueButtonChanged
		ifTrue:[self blueButtonUp: anEvent]
		ifFalse:[self mouseUp: anEvent.
				self stopSteppingSelector: #handleMouseStillDown:].! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/14/2000 15:20'!
handleUnknownEvent: anEvent
	"An event of an unknown type was sent to the receiver. What shall we do?!!"
	Smalltalk beep.
	anEvent printString displayAt: 0@0.
	anEvent wasHandled: true.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/7/2000 20:59'!
handlerForMouseDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event"
	anEvent blueButtonPressed ifTrue:[^self handlerForBlueButtonDown: anEvent].
	anEvent controlKeyPressed ifTrue:[^self handlerForMetaMenu: anEvent].
	(self handlesMouseDown: anEvent) ifFalse:[^nil]. "not interested"
	anEvent handler ifNil:[^self]. "Nobody else was interested"
	self mouseDownPriority >= anEvent handler mouseDownPriority 
		ifTrue:[^self] "Same priority but I am innermost"
		ifFalse:[^nil]. "Other guy has higher priority than I"! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/10/2000 19:11'!
mouseDownPriority
	"Return the default mouse down priority for the receiver"
	(self isPartsDonor or:[self isPartsBin])
		ifTrue:[^50]
		ifFalse:[^0].
	self flag: #workAround.
	"The above is a workaround for the complete confusion between parts donors and parts bins. Morphs residing in a parts bin may or may not have the parts donor property set; if they have they may or may not actually handle events. To work around this, parts bins get an equal priority to parts donors so that when a morph in the parts bin does have the property set but does not handle the event we still get a copy from picking it up through the parts bin. Argh. This just *cries* for a cleanup."! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/13/2000 17:14'!
processEvent: anEvent
	"Process the given event using the default event dispatcher."
	^self processEvent: anEvent using: self defaultEventDispatcher! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/18/2000 19:14'!
processEvent: anEvent using: defaultDispatcher
	"This is the central entry for dispatching events in morphic. Given some event and a default dispatch strategy, find the right receiver and let him handle it.
	WARNING: This is a powerful hook. If you want to use a different event dispatcher from the default, here is the place to hook it in. Depending on how the dispatcher is written (e.g., whether it calls simply #processEvent: or #processEvent:using:) you can change the dispatch strategy for entire trees of morphs. Similarly, you can disable entire trees of morphs from receiving any events whatsoever. Read the documentation in class MorphicEventDispatcher before playing with it. "
	(self rejectsEvent: anEvent) ifTrue:[^#rejected].
	^defaultDispatcher dispatchEvent: anEvent with: self! !

!Morph methodsFor: 'events-processing' stamp: 'ar 10/5/2000 19:25'!
rejectDropEvent: anEvent
	"This hook allows the receiver to repel a drop operation currently executed. The method is called prior to checking children so the receiver must validate that the event was really designated for it.
	Note that the ordering of the tests below is designed to avoid a (possibly expensive) #fullContainsPoint: test. If the receiver doesn't want to repel the morph anyways we don't need to check after all."
	(self repelsMorph: anEvent contents event: anEvent) ifFalse:[^self]. "not repelled"
	(self fullContainsPoint: anEvent position) ifFalse:[^self]. "not for me"
	"Throw it away"
	anEvent wasHandled: true.
	anEvent contents rejectDropMorphEvent: anEvent.! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/12/2000 23:40'!
rejectsEvent: anEvent
	"Return true to reject the given event. Rejecting an event means neither the receiver nor any of it's submorphs will be given any chance to handle it."
	^self isLocked or:[self visible not]! !

!Morph methodsFor: 'events-processing' stamp: 'ar 9/15/2000 21:09'!
transformedFrom: uberMorph
	"Return a transform to map coordinates of uberMorph, a morph above me in my owner chain, into the coordinates of MYSELF not any of my children."
	self flag: #arNote. "rename this method"
	owner ifNil:[^IdentityTransform new].
	^ (owner transformFrom: uberMorph)! !


!Morph methodsFor: 'meta-actions' stamp: 'sw 1/29/2001 02:50'!
applyStatusToAllSiblings: evt
	"Apply the statuses of all my scripts to the script status of all my siblings"

	| aPlayer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPlayer instantiatedUserScriptsDo: 
		[:aScriptInstantiation | aScriptInstantiation assignStatusToAllSiblings]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:51'!
beThisWorldsModel

	self world setModel: self.
	self model: nil slotName: nil.	"A world's model cannot have another model"! !

!Morph methodsFor: 'meta-actions' stamp: 'RAA 1/19/2001 09:09'!
blueButtonDown: anEvent
	"Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
	| h tfm doNotDrag |
	h _ anEvent hand halo.
	"Prevent wrap around halo transfers originating from throwing the event back in"
	doNotDrag _ false.
	h ifNotNil:[
		(h innerTarget == self) ifTrue:[doNotDrag _ true].
		(h innerTarget hasOwner: self) ifTrue:[doNotDrag _ true].
		(self hasOwner: h target) ifTrue:[doNotDrag _ true]].

	tfm _ (self transformedFrom: nil) inverseTransformation.

	"cmd-drag on flexed morphs works better this way"
	h _ self addHalo: (anEvent transformedBy: tfm).
	doNotDrag ifTrue:[^self].
	"Initiate drag transition if requested"
	anEvent hand 
		waitForClicksOrDrag: h
		event: (anEvent transformedBy: tfm)
		selectors: { nil. nil. #dragTarget:. }
		threshold: 5.
	"Pass focus explicitly here"
	anEvent hand newMouseFocus: h.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 9/15/2000 20:25'!
blueButtonUp: anEvent
	"Ignored. Theoretically we should never get here since control is transferred to the halo on #blueButtonDown: but subclasses may implement this differently."! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/19/2001 18:10'!
bringAllSiblingsToMe: evt
	"bring all siblings of the receiver's player found in the same container to the receiver's location."

	| aPlayer aPosition aContainer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPosition _ self topRendererOrSelf position.
	aContainer _ self topRendererOrSelf owner.
	(aPlayer class allInstances copyWithout: aPlayer) do:
		[:each |
			(aContainer submorphs includes: each costume) ifTrue:
				[each costume  position: aPosition]]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/29/2000 21:04'!
buildHandleMenu: aHand
	"Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu."

	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	self addAddHandMenuItemsForHalo: menu hand: aHand.
	menu defaultTarget: self.
	self addCustomHaloMenuItems: menu hand: aHand.
	menu addLine.
	self player ifNotNil: [self player addPlayerMenuItemsTo: menu hand: aHand].
	menu defaultTarget: aHand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 11/4/2000 23:39'!
buildMetaMenu: evt
	"Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph."
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addStayUpItem.
	menu add: 'grab' action: #grabMorph:.
	menu add: 'copy to paste buffer' action: #copyToPasteBuffer:.
	self maybeAddCollapseItemTo: menu.
	menu add: 'delete' action: #dismissMorph:.
	menu addLine.
	menu add: 'copy Postscript' action: #clipPostscript.
	menu add: 'print PS to file...' action: #printPSToFile.
	menu addLine.
	menu add: 'go behind' action: #goBehind.
	menu add: 'add halo' action: #addHalo:.
	menu add: 'duplicate' action: #maybeDuplicateMorph:.

	self potentialEmbeddingTargets size > 1 ifTrue:
		[menu add: 'embed...' action: #embedInto:].

	menu add: 'resize' action: #resizeMorph:.
	"Give the argument control over what should be done about fill styles"
	self addFillStyleMenuItems: menu hand: evt hand.
	self addDropShadowMenuItems: menu hand: evt hand.
	self addLayoutMenuItems: menu hand: evt hand.
	menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #().
	menu addLine.

	(self morphsAt: evt position) size > 1 ifTrue:
		[menu add: 'submorphs...'
			target: self
			selector: #invokeMetaMenuAt:event:
			argument: evt position].
	menu addLine.
	menu add: 'inspect' selector: #inspectAt:event: argument: evt position.
	menu add: 'explore' action: #explore.
	menu add: 'browse hierarchy' action: #browseHierarchy.
	menu add: 'make own subclass' action: #subclassMorph.
	menu addLine.
	menu add: 'set variable name...' action: #choosePartName.
	(self isMorphicModel) ifTrue:
		[menu add: 'save morph as prototype' action: #saveAsPrototype.
		(self ~~ self world modelOrNil) ifTrue:
			 [menu add: 'become this world''s model' action: #beThisWorldsModel]].
	menu add: 'save morph in file' action: #saveOnFile.
	(self hasProperty: #resourceFilePath)
		ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph')
				ifTrue: [menu add: 'save as resource' action: #saveAsResource].
				menu add: 'update from resource' action: #updateFromResource]
		ifFalse: [menu add: 'attach to resource' action: #attachToResource].
	menu add: 'show actions' action: #showActions.
	menu addLine.
	self addCustomMenuItems: menu hand: evt hand.
	^ menu
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 18:54'!
changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand
	"Put up a color picker for changing some kind of color.  May be modal or modeless, depending on #modalColorPickers setting"
	self flag: #arNote. "Simplify this due to anObject == self for almost all cases"
	^ ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: aHand;
		target: anObject;
		selector: aSymbol;
		originalColor: aColor;
		putUpFor: anObject near: (anObject isMorph
					ifTrue:	 [Rectangle center: self position extent: 20]
					ifFalse: [anObject == self world
								ifTrue: [anObject viewBox bottomLeft + (20@-20) extent: 200]
								ifFalse: [anObject fullBoundsInWorld]]);
		yourself! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:44'!
copyToPasteBuffer: evt
	self okayToDuplicate ifTrue:[evt hand copyToPasteBuffer: self].! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:46'!
dismissMorph: evt
	| w |
	w _ self world ifNil:[^self].
	w abandonAllHalos; stopStepping: self.
	self delete
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 11/4/2000 17:56'!
duplicateMorph: evt
	"Make and return a duplicate of the receiver's argument"
	| dup |
	dup _ self duplicate.
	evt hand grabMorph: dup from: owner. "duplicate was ownerless so use #grabMorph:from: here"
	^dup! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/7/2000 20:53'!
embedInto: evt
	"Embed the receiver into some other morph"
	|  menu target |
	menu _ CustomMenu new.
	self potentialEmbeddingTargets  do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUpWithCaption: ('Place ', self externalName, ' in...').
	target ifNil:[^self].
	target addMorphFront: self fromWorldPosition: self positionInWorld.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/6/2000 16:37'!
grabMorph: evt

	evt hand grabMorph: self! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/7/2000 18:44'!
handlerForBlueButtonDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event.
	Note: Halos handle blue button events themselves so we will only be asked if there is currently no halo on top of us."
	self wantsHaloFromClick ifFalse:[^nil].
	anEvent handler ifNil:[^self].
	anEvent handler isPlayfieldLike ifTrue:[^self]. "by default exclude playfields"
	(anEvent shiftPressed)
		ifFalse:[^nil] "let outer guy have it"
		ifTrue:[^self] "let me have it"
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/12/2000 17:07'!
handlerForMetaMenu: evt
	"Return the prospective handler for invoking the meta menu. By default, the top-most morph in the innermost world gets this menu"
	self isWorldMorph ifTrue:[^self].
	evt handler ifNotNil:[evt handler isWorldMorph ifTrue:[^self]].
	^nil! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/10/2000 14:09'!
inspectAt: aPoint event: evt
	| menu morphs target |
	menu _ CustomMenu new.
	morphs _ self morphsAt: aPoint.
	(morphs includes: self) ifFalse:[morphs _ morphs copyWith: self].
	morphs do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUpWithCaption: ('inspect whom?
(deepest at top)').
	target ifNil:[^self].
	target inspectInMorphic: evt! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:54'!
invokeMetaMenu: evt
	| menu |
	menu _ self buildMetaMenu: evt.
	menu addTitle: self externalName.
	menu popUpEvent: evt in: self world! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/10/2000 14:26'!
invokeMetaMenuAt: aPoint event: evt
	| menu morphs target |
	menu _ CustomMenu new.
	morphs _ self morphsAt: aPoint.
	(morphs includes: self) ifFalse:[morphs _ morphs copyWith: self].
	morphs size = 1 ifTrue:[morphs first invokeMetaMenu: evt].
	morphs do: [:m | 
		menu add: (m knownName ifNil:[m class name asString]) action: m].
	target _ menu startUp.
	target ifNil:[^self].
	target invokeMetaMenu: evt! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/15/2001 00:23'!
makeMultipleSiblings: evt
	"Make multiple siblings, first prompting the user for how many"

	| result |
	result _ FillInTheBlank request: 'how many siblings do you want?' initialAnswer: '2'.
	result isEmptyOrNil ifTrue: [^ self].
	result first isDigit ifFalse: [^ self beep].
	self topRendererOrSelf makeSiblings: result asInteger.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 19:20'!
makeNewPlayerInstance: evt
	"Make a duplicate of the receiver's argument.  This is called only where the argument has an associated Player as its costumee, and the intent here is to make another instance of the same uniclass as the donor Player itself.  Much works, but there are flaws so this shouldn't be used without recognizing the risks"

	evt hand attachMorph: self usableSiblingInstance! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/29/2001 17:11'!
makeSiblings: count
	"Make multiple sibling, and return the list"

	| aPosition anInstance listOfNewborns |
	aPosition _ self position.
	listOfNewborns _ (1 to: count asInteger) asArray collect: 
		[:anIndex |
			anInstance _ self usableSiblingInstance.
			owner addMorphFront: anInstance.
			aPosition _ aPosition + (10@10).
			anInstance position: aPosition.
			anInstance].
	self currentWorld startSteppingSubmorphsOf: self topRendererOrSelf owner.
	^ listOfNewborns! !

!Morph methodsFor: 'meta-actions' stamp: 'sw 1/12/2001 22:47'!
makeSiblingsLookLikeMe: evt
	"Make all my siblings wear the same costume that I am wearing."

	| aPlayer |
	(aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [self error: 'not uniclass'].
	aPlayer class allInstancesDo:
		[:anInstance | anInstance == aPlayer ifFalse:
			[anInstance wearCostumeOf: aPlayer]]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 17:32'!
maybeDuplicateMorph: evt
	self okayToDuplicate ifTrue:[^self duplicateMorph: evt]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/7/2000 20:56'!
potentialEmbeddingTargets
	"Return the potential targets for embedding the receiver"
	owner ifNil:[^#()].
	^owner morphsAt: self referencePosition behind: self unlocked: true! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 11/8/2000 22:51'!
resizeMorph: evt
	| handle |
	handle _ HandleMorph new forEachPointDo: [:newPoint | 
		self extent: (self griddedPoint: newPoint) - self bounds topLeft].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:50'!
saveAsPrototype
	(SelectionMenu confirm: 'Make this morph the prototype for ', self class printString, '?')
		ifFalse: [^ self].
	self class prototype: self.
! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:52'!
showActions
	"Put up a message list browser of all the code that this morph
would run for mouseUp, mouseDown, mouseMove, mouseEnter, mouseLeave, and
mouseLinger.  tk 9/13/97"
	| list cls selector |
	"the eventHandler"
	self eventHandler ifNil: [list _ SortedCollection new]
			ifNotNil: [
				list _ self eventHandler messageList.
				(self eventHandler handlesMouseDown: nil) 
					ifFalse:[list add: 'HandMorph grabMorph:']].
	"If not those, then non-default raw events"
	#(keyStroke: mouseDown: mouseEnter: mouseLeave: mouseMove: mouseUp:
	doButtonAction)
		do: [:sel |
			cls _ self class classThatUnderstands: sel.
			cls ifNotNil: ["want more than default behavior"
				cls == Morph ifFalse: [list add: cls name, ' ',sel]]].
	"The mechanism on a Button"
	(self respondsTo: #actionSelector) ifTrue: ["A button"
		selector _ self actionSelector.
		cls _ self target class classThatUnderstands: selector.
			cls ifNotNil: ["want more than default behavior"
				cls == Morph ifFalse: [list add: cls name, ' ',selector]]].
	MessageSet openMessageList: list name: 'Actions of ', self printString.! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 19:21'!
showHiders
	self allMorphsDo:[:m | m show]! !

!Morph methodsFor: 'meta-actions' stamp: 'ar 10/5/2000 16:50'!
subclassMorph
	"Create a new subclass of this morph's class and make this morph be an instance of it."

	| oldClass newClassName newClass newMorph |
	oldClass _ self class.
	newClassName _ FillInTheBlank
		request: 'Please give this new class a name'
		initialAnswer: oldClass name.
	newClassName = '' ifTrue: [^ self].
	(Smalltalk includesKey: newClassName)
		ifTrue: [^ self inform: 'Sorry, there is already a class of that name'].

	newClass _ oldClass subclass: newClassName asSymbol
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: oldClass category asString.
	newMorph _ self as: newClass.
	self become: newMorph.
! !


!Morph methodsFor: 'testing' stamp: 'RAA 12/4/2000 10:44'!
canDrawAtHigherResolution

	^false! !

!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'!
completeModificationHash

"World completeModificationHash"

	| resultSize result here i |
	resultSize _ 10.
	result _ ByteArray new: resultSize.
	self allMorphsDo: [ :each | 
		here _ each modificationHash.
		here withIndexDo: [ :ch :index |
			i _ index \\ resultSize + 1.
			result at: i put: ((result at: i) bitXor: ch asciiValue)
		].
	].
	^result! !

!Morph methodsFor: 'testing' stamp: 'ar 9/22/2000 13:44'!
isFlexed
	"Return true if the receiver is currently flexed"
	owner ifNil:[^false].
	^owner isFlexMorph! !

!Morph methodsFor: 'testing' stamp: 'RAA 10/20/2000 14:47'!
modificationHash

	^String 
		streamContents: [ :strm |
			self longPrintOn: strm
		]
		limitedTo: 25
! !


!Morph methodsFor: 'drop shadows' stamp: 'RAA 1/19/2001 07:51'!
addDropShadow

	self hasDropShadow ifTrue:[^self].
	self changed.
	self hasDropShadow: true.
	self shadowOffset: 3@3.
	self layoutChanged.
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:17'!
addDropShadowMenuItems: aMenu hand: aHand
	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addUpdating: #hasDropShadowString
		action: #toggleDropShadow.
	menu addLine.
	menu add: 'shadow color...' target: self selector: #changeShadowColor.
	menu add: 'shadow offset...' target: self selector: #setShadowOffset:.
	aMenu add: 'drop shadow' subMenu: menu.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'!
changeShadowColor
	"Change the shadow color of the receiver -- triggered, e.g. from a menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #shadowColor:;
		originalColor: self shadowColor;
		putUpFor: self near: self fullBoundsInWorld! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 23:22'!
hasDropShadow
	extension == nil ifTrue:[^false].
	^self valueOfProperty: #hasDropShadow ifAbsent:[false]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:03'!
hasDropShadow: aBool
	aBool
		ifTrue:[self setProperty: #hasDropShadow toValue: true]
		ifFalse:[self removeProperty: #hasDropShadow]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:17'!
hasDropShadowString
 	^self hasDropShadow 
		ifTrue:['<on>show shadow'] 
		ifFalse:['<off>show shadow']! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 23:23'!
hasRolloverBorder
	extension == nil ifTrue:[^false].
	^self valueOfProperty: #hasRolloverBorder ifAbsent:[false]! !

!Morph methodsFor: 'drop shadows' stamp: 'RAA 11/7/2000 15:54'!
hasRolloverBorder: aBool
	aBool
		ifTrue:[self setProperty: #hasRolloverBorder toValue: true]
		ifFalse:[self removeProperty: #hasRolloverBorder]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:57'!
removeDropShadow
	self hasDropShadow ifFalse:[^self].
	self changed.
	self hasDropShadow: false.
	fullBounds ifNotNil:[fullBounds _ self privateFullBounds].
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:58'!
setShadowOffset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | self shadowPoint: newPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:59'!
shadowColor
	^self valueOfProperty: #shadowColor ifAbsent:[Color black]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:22'!
shadowColor: aColor
	self shadowColor = aColor ifFalse:[self changed].
	self setProperty: #shadowColor toValue: aColor.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 18:57'!
shadowOffset
	"Return the current shadow offset"
	^self valueOfProperty: #shadowOffset ifAbsent:[0@0]! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 19:00'!
shadowOffset: aPoint
	"Set the current shadow offset"
	(aPoint isNil or:[(aPoint x isZero) & (aPoint y isZero)])
		ifTrue:[self removeProperty: #shadowOffset]
		ifFalse:[self setProperty: #shadowOffset toValue: aPoint].! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 11/12/2000 18:58'!
shadowPoint: newPoint
	self changed.
	self shadowOffset: newPoint - self center // 5.
	fullBounds ifNotNil:[fullBounds _ self privateFullBounds].
	self changed.! !

!Morph methodsFor: 'drop shadows' stamp: 'ar 10/26/2000 20:16'!
toggleDropShadow
	self hasDropShadow
		ifTrue:[self removeDropShadow]
		ifFalse:[self addDropShadow].! !


!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:33'!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver."
	| layout |
	layout _ self layoutPolicy.
	layout ifNil:[^self addMorph: aMorph].
	self privateAddMorph: aMorph 
		atIndex: (layout indexForInserting: aMorph at: evt position in: self).! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:34'!
adjustLayoutBounds
	"Adjust the receivers bounds depending on the resizing strategy imposed"
	| hFit vFit box myExtent extent |
	hFit _ self hResizing.
	vFit _ self vResizing.
	(hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed"
	box _ self layoutBounds.
	myExtent _ box extent.
	extent _ self submorphBounds corner - box origin.
	hFit == #shrinkWrap ifTrue:[myExtent _ extent x @ myExtent y].
	vFit == #shrinkWrap ifTrue:[myExtent _ myExtent x @ extent y].
	"Make sure we don't get smaller than minWidth/minHeight"
	myExtent x < self minWidth ifTrue:[
		myExtent _ (myExtent x max: 
			(self minWidth - self bounds width + self layoutBounds width)) @ myExtent y].
	myExtent y < self minHeight ifTrue:[
		myExtent _ myExtent x @ (myExtent y max:
			(self minHeight - self bounds height + self layoutBounds height))].
	self layoutBounds: (box origin extent: myExtent).! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:19'!
doLayoutIn: layoutBounds
	"Compute a new layout based on the given layout bounds."
	| layout box priorBounds |
	"Note: Testing for #bounds or #layoutBounds would be sufficient to
	figure out if we need an invalidation afterwards but #outerBounds
	is what we need for all leaf nodes so we use that."
	priorBounds _ self outerBounds.
	submorphs size = 0 ifTrue:[^fullBounds _ priorBounds].
	"Send #ownerChanged to our children"
	submorphs do:[:m| m ownerChanged].
	layout _ self layoutPolicy.
	layout ifNotNil:[layout layout: self in: layoutBounds].
	self adjustLayoutBounds.
	fullBounds _ self privateFullBounds.
	box _ self outerBounds.
	box = priorBounds
		ifFalse:[self invalidRect: (priorBounds quickMerge: box)].! !

!Morph methodsFor: 'layout' stamp: 'ar 11/11/2000 17:27'!
fullBounds
	"Return the bounding box of the receiver and all its children. Recompute the layout if necessary."
	fullBounds ifNotNil:[^fullBounds].
	self doLayoutIn: self layoutBounds.
	^fullBounds! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:10'!
layoutBounds
	"Return the bounds for laying out children of the receiver"
	| inset box |
	inset _ self layoutInset.
	box _ self innerBounds.
	inset isZero ifTrue:[^box].
	^box insetBy: inset.! !

!Morph methodsFor: 'layout' stamp: 'ar 10/31/2000 21:09'!
layoutBounds: aRectangle
	"Set the bounds for laying out children of the receiver.
	Note: written so that #layoutBounds can be changed without touching this method"
	| outer inner |
	outer _ self bounds.
	inner _ self layoutBounds.
	bounds _ aRectangle origin + (outer origin - inner origin) corner:
				aRectangle corner + (outer corner - inner corner).! !

!Morph methodsFor: 'layout' stamp: 'ar 1/27/2001 14:41'!
layoutChanged
	| layout |
	fullBounds ifNil:[^self]. "layout will be recomputed so don't bother"
	fullBounds _ nil.
	layout _ self layoutPolicy.
	layout ifNotNil:[layout flushLayoutCache].
	owner ifNotNil: [owner layoutChanged].
	"note: does not send #ownerChanged here - we'll do this when computing the new layout"! !

!Morph methodsFor: 'layout' stamp: 'ar 11/13/2000 01:51'!
layoutInBounds: cellBounds
	"Layout specific. Apply the given bounds to the receiver after being layed out in its owner."
	| box aSymbol delta |
	fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds."
		cellBounds origin = self bounds origin ifFalse:[
			box _ self outerBounds.
			delta _ cellBounds origin - self bounds origin.
			self invalidRect: (box merge: (box translateBy: delta)).
			self privateFullMoveBy: delta]. "sigh..."
		box _ cellBounds origin extent: "adjust for #rigid receiver"
			(self hResizing == #rigid ifTrue:[self bounds extent x] ifFalse:[cellBounds extent x]) @
			(self vResizing == #rigid ifTrue:[self bounds extent y] ifFalse:[cellBounds extent y]).
		"Compute inset of layout bounds"
		box _ box origin - (self bounds origin - self layoutBounds origin) corner:
					box corner - (self bounds corner - self layoutBounds corner).
		"And do the layout within the new bounds"
		self layoutBounds: box.
		self doLayoutIn: box].
	cellBounds = bounds ifTrue:[^self]. "already up to date"
	cellBounds extent = bounds extent "nice fit"
		ifTrue:[^self position: cellBounds origin].
	box _ bounds.
	"match #spaceFill constraints"
	self hResizing == #spaceFill 
		ifTrue:[box _ box origin extent: cellBounds width @ box height].
	self vResizing == #spaceFill
		ifTrue:[box _ box origin extent: box width @ cellBounds height].
	"align accordingly"
	aSymbol _ (owner ifNil:[self]) cellPositioning.
	box _ box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol).
	"and install new bounds"
	self bounds: box.! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:35'!
layoutProportionallyIn: newBounds
	"Layout specific. Apply the given bounds to the receiver."
	| box frame |
	frame _ self layoutFrame ifNil:[^self].
	"before applying the proportional values make sure the receiver's layout is computed"
	self fullBounds. "sigh..."
	"compute the cell size the receiver has given its layout frame"
	box _ frame layout: self bounds in: newBounds.
	(box = self bounds) ifTrue:[^self]. "no change"
	^self layoutInBounds: box.! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 17:43'!
minExtent
	"Layout specific. Return the minimum size the receiver can be represented in.
	Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied."
	| layout minExtent extra hFit vFit |
	hFit _ self hResizing.
	vFit _ self vResizing.
	(hFit == #spaceFill or:[vFit == #spaceFill]) ifFalse:[
		"The receiver will not adjust to parents layout by growing or shrinking,
		which means that an accurate layout defines the minimum size."
		^self fullBounds extent].

	"An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)"
	self hasSubmorphs ifFalse:[
		hFit == #shrinkWrap ifTrue:[hFit _ #rigid].
		vFit == #shrinkWrap ifTrue:[vFit _ #rigid]].
	layout _ self layoutPolicy.
	layout == nil
		ifTrue:[minExtent _ 0@0]
		ifFalse:[minExtent _ layout minExtentOf: self in: self layoutBounds].
	hFit == #rigid
		ifTrue:[	minExtent _ self fullBounds extent x @ minExtent y]
		ifFalse:[	extra _ self bounds width - self layoutBounds width.
				minExtent _ (minExtent x + extra) @ minExtent y].
	vFit == #rigid
		ifTrue:[minExtent _ minExtent x @ self fullBounds extent y]
		ifFalse:[extra _ self bounds height - self layoutBounds height.
				minExtent _ minExtent x @ (minExtent y + extra)].
	minExtent _ minExtent max: (self minWidth@self minHeight).
	^minExtent! !

!Morph methodsFor: 'layout' stamp: 'ar 11/11/2000 23:46'!
minHeight
	extension == nil ifTrue:[^2].
	^self valueOfProperty: #minHeight ifAbsent:[2]! !

!Morph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:45'!
minHeight: aNumber
	aNumber == nil
		ifTrue:[self removeProperty: #minHeight]
		ifFalse:[self setProperty: #minHeight toValue: aNumber].
	self layoutChanged.! !

!Morph methodsFor: 'layout' stamp: 'ar 11/11/2000 23:46'!
minWidth
	extension == nil ifTrue:[^2].
	^self valueOfProperty: #minWidth ifAbsent:[2]! !

!Morph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:45'!
minWidth: aNumber
	aNumber == nil
		ifTrue:[self removeProperty: #minWidth]
		ifFalse:[self setProperty: #minWidth toValue: aNumber].
	self layoutChanged.! !

!Morph methodsFor: 'layout' stamp: 'ar 11/12/2000 23:12'!
privateFullBounds
	"Private. Compute the actual full bounds of the receiver"
	| box |
	submorphs size = 0 ifTrue: [^self outerBounds].
	box _ self outerBounds copy.
	self clipSubmorphs
		ifTrue:[box _ box quickMerge: (self submorphBounds intersect: self clippingBounds)]
		ifFalse:[box _ box quickMerge: self submorphBounds].
	^ box origin asIntegerPoint corner: box corner asIntegerPoint
! !

!Morph methodsFor: 'layout' stamp: 'ar 11/2/2000 17:42'!
submorphBounds
	"Private. Compute the actual full bounds of the receiver"
	| box subBox |
	submorphs do: [:m | 
		(m visible) ifTrue: [
			subBox _ m fullBounds.
			box 
				ifNil:[box _ subBox copy]
				ifNotNil:[box _ box quickMerge: subBox]]].
	box ifNil:[^self bounds]. "e.g., having submorphs but not visible"
	^ box origin asIntegerPoint corner: box corner asIntegerPoint
! !


!Morph methodsFor: 'layout-menu' stamp: 'ar 11/2/2000 14:56'!
addCellLayoutMenuItems: aMenu hand: aHand
	"Cell (e.g., child) related items"
	| menu sub |
	menu _ MenuMorph new defaultTarget: self.
		menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout.
		menu addLine.

		sub _ MenuMorph new defaultTarget: self.
		#(rigid shrinkWrap spaceFill) do:[:sym|
			sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)].
		menu add:'horizontal resizing' subMenu: sub.

		sub _ MenuMorph new defaultTarget: self.
		#(rigid shrinkWrap spaceFill) do:[:sym|
			sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)].
		menu add:'vertical resizing' subMenu: sub.

	aMenu ifNotNil:[aMenu add: 'child layout' subMenu: menu].
	^menu! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/2/2000 14:59'!
addLayoutMenuItems: topMenu hand: aHand
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout.
	aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout.
	aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout.
	aMenu addLine.
	aMenu add: 'change layout inset...' action: #changeLayoutInset:.
	aMenu addLine.
	self addCellLayoutMenuItems: aMenu hand: aHand.
	self addTableLayoutMenuItems: aMenu hand: aHand.
	topMenu ifNotNil:[topMenu add: 'layout' subMenu: aMenu].
	^aMenu! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/2/2000 22:39'!
addTableLayoutMenuItems: aMenu hand: aHand
	| menu sub |
	menu _ MenuMorph new defaultTarget: self.
	menu addUpdating: #hasReverseCellsString action: #changeReverseCells.
	menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells.
	menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells.
	menu addLine.
	menu add: 'change cell inset...' action: #changeCellInset:.
	menu add: 'change min cell size...' action: #changeMinCellSize:.
	menu add: 'change max cell size...' action: #changeMaxCellSize:.
	menu addLine.

	sub _ MenuMorph new defaultTarget: self.
	#(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
		sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)].
	menu add: 'list direction' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym|
		sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)].
	menu add: 'wrap direction' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym|
		sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)].
	menu add: 'cell positioning' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(topLeft bottomRight center justified) do:[:sym|
		sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)].
	menu add: 'list centering' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(topLeft bottomRight center justified) do:[:sym|
		sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)].
	menu add: 'wrap centering' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none equal) do:[:sym|
		sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)].
	menu add: 'list spacing' subMenu: sub.

	sub _ MenuMorph new defaultTarget: self.
	#(none localRect localSquare globalRect globalSquare) do:[:sym|
		sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)].
	menu add: 'cell spacing' subMenu: sub.

	aMenu ifNotNil:[aMenu add: 'table layout' subMenu: menu].
	^menu! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:08'!
changeCellInset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self cellInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 18:54'!
changeClipLayoutCells
	self invalidRect: self fullBounds.
	self clipLayoutCells: self clipLayoutCells not.
	self invalidRect: self fullBounds.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeDisableTableLayout
	self disableTableLayout: self disableTableLayout not.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:09'!
changeLayoutInset: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self layoutInset: (newPoint - evt cursorPoint) asIntegerPoint // 5].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeListDirection: aSymbol
	| listDir wrapDir |
	self listDirection: aSymbol.
	(self wrapDirection == #none) ifTrue:[^self].
	"otherwise automatically keep a valid table layout"
	listDir _ self listDirection.
	wrapDir _ self wrapDirection.
	(listDir == #leftToRight or:[listDir == #rightToLeft]) ifTrue:[
		wrapDir == #leftToRight ifTrue:[^self wrapDirection: #topToBottom].
		wrapDir == #rightToLeft ifTrue:[^self wrapDirection: #bottomToTop].
	] ifFalse:[
		wrapDir == #topToBottom ifTrue:[^self wrapDirection: #leftToRight].
		wrapDir == #bottomToTop ifTrue:[^self wrapDirection: #rightToLeft].
	].
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeMaxCellSize: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self maxCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeMinCellSize: evt
	| handle |
	handle _ HandleMorph new forEachPointDo:[:newPoint |
		self minCellSize: (newPoint - evt cursorPoint) asIntegerPoint].
	evt hand attachMorph: handle.
	handle startStepping.
! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeNoLayout
	self layoutPolicy ifNil:[^self]. "already no layout"
	self layoutPolicy: nil.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:19'!
changeProportionalLayout
	| layout |
	((layout _ self layoutPolicy) notNil and:[layout isProportionalLayout])
		ifTrue:[^self]. "already proportional layout"
	self layoutPolicy: ProportionalLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeReverseCells
	self reverseTableCells: self reverseTableCells not.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'!
changeRubberBandCells
	self rubberBandCells: self rubberBandCells not.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:20'!
changeTableLayout
	| layout |
	((layout _ self layoutPolicy) notNil and:[layout isTableLayout])
		ifTrue:[^self]. "already table layout"
	self layoutPolicy: TableLayout new.
	self layoutChanged.! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:15'!
hasClipLayoutCellsString
	self clipLayoutCells
		ifTrue:[^'<on>clip to cell size']
		ifFalse:[^'<off>clip to cell size']! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:16'!
hasDisableTableLayoutString
	self disableTableLayout
		ifTrue:[^'<on>disable layout in tables']
		ifFalse:[^'<off>disable layout in tables']! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:16'!
hasNoLayoutString
	^self layoutPolicy == nil
		ifTrue:['<on>no layout']
		ifFalse:['<off>no layout'].! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:16'!
hasProportionalLayoutString
	| layout |
	^((layout _ self layoutPolicy) notNil and:[layout isProportionalLayout])
		ifTrue:['<on>proportional layout']
		ifFalse:['<off>proportional layout'].! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:16'!
hasReverseCellsString
	self reverseTableCells
		ifTrue:[^'<on>reverse table cells']
		ifFalse:[^'<off>reverse table cells']! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 11/2/2000 22:39'!
hasRubberBandCellsString
	^self rubberBandCells ifTrue:['<on>rubber band cells'] ifFalse:['<off>rubber band cells']! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:16'!
hasTableLayoutString
	| layout |
	^((layout _ self layoutPolicy) notNil and:[layout isTableLayout])
		ifTrue:['<on>table layout']
		ifFalse:['<off>table layout'].! !

!Morph methodsFor: 'layout-menu' stamp: 'ar 10/31/2000 19:17'!
layoutMenuPropertyString: aSymbol from: currentSetting
	| index |
	^String streamContents:[:s|
		s nextPutAll: (aSymbol == currentSetting ifTrue:['<on>'] ifFalse:['<off>']).
		index _ 1.
		aSymbol keysAndValuesDo:[:idx :ch|
			ch isUppercase ifTrue:[
				s nextPutAll: (aSymbol copyFrom: index to: idx-1) asLowercase.
				s nextPutAll:' '.
				index _ idx]].
		index < aSymbol size ifTrue:[s nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]].
! !


!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:56'!
assureLayoutProperties
	| props |
	props _ self layoutProperties.
	props == self ifTrue:[props _ nil].
	props ifNil:[
		props _ LayoutProperties new initializeFrom: self.
		self layoutProperties: props].
	^props! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:57'!
assureTableProperties
	| props |
	props _ self layoutProperties.
	props == self ifTrue:[props _ nil].
	props ifNil:[
		props _ TableLayoutProperties new initializeFrom: self.
		self layoutProperties: props].
	props includesTableProperties 
		ifFalse:[self layoutProperties: (props _ props asTableLayoutProperties)].
	^props! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellInset
	"Layout specific. This property specifies an extra inset for each cell in the layout."
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props cellInset].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellInset: aNumber
	"Layout specific. This property specifies an extra inset for each cell in the layout."
	self assureTableProperties cellInset: aNumber.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:54'!
cellPositioning
	"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
		#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 
	which align the receiver's bounds with the cell at the given point."
	| props |
	props _ self layoutProperties.
	^props ifNil:[#center] ifNotNil:[props cellPositioning].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:39'!
cellPositioning: aSymbol
	"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
		#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center 
	which align the receiver's bounds with the cell at the given point."
	self assureTableProperties cellPositioning: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:48'!
cellPositioningString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellPositioning! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:55'!
cellSpacing
	"Layout specific. This property describes how the cell size for each element in a list should be computed.
		#globalRect - globally equal rectangular cells
		#globalSquare - globally equal square cells
		#localRect - locally (e.g., per row/column) equal rectangular cells
		#localSquare - locally (e.g., per row/column) equal square cells
		#none - cells are sized based on available row/column constraints
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props cellSpacing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'!
cellSpacing: aSymbol
	"Layout specific. This property describes how the cell size for each element in a list should be computed.
		#globalRect - globally equal rectangular cells
		#globalSquare - globally equal square cells
		#localRect - locally (e.g., per row/column) equal rectangular cells
		#localSquare - locally (e.g., per row/column) equal square cells
		#none - cells are sized based on available row/column constraints
	"
	self assureTableProperties cellSpacing: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
cellSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self cellSpacing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:56'!
disableTableLayout
	"Layout specific. Disable laying out the receiver in table layout"
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props disableTableLayout].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'!
disableTableLayout: aBool
	"Layout specific. Disable laying out the receiver in table layout"
	self assureLayoutProperties disableTableLayout: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:57'!
hResizing
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#rigid] ifNotNil:[props hResizing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:06'!
hResizing: aSymbol
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	self assureLayoutProperties hResizing: aSymbol.
	self layoutChanged.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'!
hResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self hResizing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:19'!
layoutFrame
	"Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout"
	extension == nil ifTrue:[^nil].
	^extension layoutFrame! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:20'!
layoutFrame: aLayoutFrame
	"Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout"
	self layoutFrame == aLayoutFrame ifTrue:[^self].
	self assureExtension layoutFrame: aLayoutFrame.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'!
layoutInset
	"Return the extra inset for layouts"
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props layoutInset].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 16:38'!
layoutInset: aNumber
	"Return the extra inset for layouts"
	self assureTableProperties layoutInset: aNumber.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:19'!
layoutPolicy
	"Layout specific. Return the layout policy describing how children of the receiver should appear."
	extension == nil ifTrue:[^nil]. "shortcut for speed"
	^extension layoutPolicy! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'!
layoutPolicy: aLayoutPolicy
	"Layout specific. Return the layout policy describing how children of the receiver should appear."
	self layoutPolicy == aLayoutPolicy ifTrue:[^self].
	self assureExtension layoutPolicy: aLayoutPolicy.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:19'!
layoutProperties
	"Return the current layout properties associated with the receiver"
	extension == nil ifTrue:[^nil].
	^extension layoutProperties! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/14/2000 17:21'!
layoutProperties: newProperties
	"Return the current layout properties associated with the receiver"
	self layoutProperties == newProperties ifTrue:[^self].
	self assureExtension layoutProperties: newProperties.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:58'!
listCentering
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of primary direction
		#bottomRight - center at end of primary direction
		#center - center in the middle of primary direction
		#justified - insert extra space inbetween rows/columns
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topLeft] ifNotNil:[props listCentering].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:05'!
listCentering: aSymbol
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of primary direction
		#bottomRight - center at end of primary direction
		#center - center in the middle of primary direction
		#justified - insert extra space inbetween rows/columns
	"
	self assureTableProperties listCentering: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listCentering! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
listDirection
	"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
	indicating the direction in which any layout should take place"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topToBottom] ifNotNil:[props listDirection].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
listDirection: aSymbol
	"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
	indicating the direction in which any layout should take place"
	self assureTableProperties listDirection: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listDirection! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
listSpacing
	"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
		#equal - all rows have the same height
		#none - all rows may have different heights
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props listSpacing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
listSpacing: aSymbol
	"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
		#equal - all rows have the same height
		#none - all rows may have different heights
	"
	self assureTableProperties listSpacing: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 02:47'!
listSpacingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self listSpacing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 19:59'!
maxCellSize
	"Layout specific. This property specifies the maximum size of a table cell."
	| props |
	props _ self layoutProperties.
	^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
maxCellSize: aPoint
	"Layout specific. This property specifies the maximum size of a table cell."
	self assureTableProperties maxCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:00'!
minCellSize
	"Layout specific. This property specifies the minimal size of a table cell."
	| props |
	props _ self layoutProperties.
	^props ifNil:[0] ifNotNil:[props minCellSize].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
minCellSize: aPoint
	"Layout specific. This property specifies the minimal size of a table cell."
	self assureTableProperties minCellSize: aPoint.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'!
reverseTableCells
	"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props reverseTableCells].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
reverseTableCells: aBool
	"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
	self assureTableProperties reverseTableCells: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:01'!
rubberBandCells
	"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
	| props |
	props _ self layoutProperties.
	^props ifNil:[false] ifNotNil:[props rubberBandCells].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:04'!
rubberBandCells: aBool
	"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
	self assureTableProperties rubberBandCells: aBool.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/10/2000 14:39'!
spaceFillWeight
	"Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells."
	extension == nil ifTrue:[^1]. "get out quickly"
	^self valueOfProperty: #spaceFillWeight ifAbsent:[1]! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/15/2000 14:16'!
spaceFillWeight: aNumber
	"Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells."
	aNumber = 1
		ifTrue:[self removeProperty: #spaceFillWeight]
		ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber].
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'!
vResizing
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#rigid] ifNotNil:[props vResizing].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
vResizing: aSymbol
	"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
		#rigid			-	do not resize the receiver
		#spaceFill		-	resize to fill owner's available space
		#shrinkWrap	- resize to fit children
	"
	self assureLayoutProperties vResizing: aSymbol.
	self layoutChanged.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/31/2000 20:45'!
vResizingString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self vResizing! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:02'!
wrapCentering
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of secondary direction
		#bottomRight - center at end of secondary direction
		#center - center in the middle of secondary direction
		#justified - insert extra space inbetween rows/columns
	"
	| props |
	props _ self layoutProperties.
	^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapCentering: aSymbol
	"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
		#topLeft - center at start of secondary direction
		#bottomRight - center at end of secondary direction
		#center - center in the middle of secondary direction
		#justified - insert extra space inbetween rows/columns
	"
	self assureTableProperties wrapCentering: aSymbol.
	self layoutChanged.! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'!
wrapCenteringString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapCentering! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapDirection
	"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
		#none
	indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
	| props |
	props _ self layoutProperties.
	^props ifNil:[#none] ifNotNil:[props wrapDirection].! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 11/13/2000 20:03'!
wrapDirection: aSymbol
	"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
		#leftToRight
		#rightToLeft
		#topToBottom
		#bottomToTop
		#none
	indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
	self assureTableProperties wrapDirection: aSymbol.
	self layoutChanged.
! !

!Morph methodsFor: 'layout-properties' stamp: 'ar 10/29/2000 03:00'!
wrapDirectionString: aSymbol
	^self layoutMenuPropertyString: aSymbol from: self wrapDirection ! !


!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 17:29'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	"a hack to allow for abitrary morphs to be dropped into piano roll"
	t > rightTime ifTrue: [^ self].  
	t < leftTime ifTrue: [^ self].
	morphList add: (self left: (pianoRoll xForTime: t)).
! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 15:48'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"a hack to allow for abitrary morphs to be dropped into piano roll"
	self triggerActionFromPianoRoll.! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 17:21'!
justDroppedIntoPianoRoll: pianoRoll event: evt
	
	| ambientEvent startTimeInScore |
	startTimeInScore _ pianoRoll timeForX: self left.

	ambientEvent _ AmbientEvent new 
		morph: self;
		time: startTimeInScore.

	pianoRoll score addAmbientEvent: ambientEvent.

	"self endTime > pianoRoll scorePlayer durationInTicks ifTrue:
		[pianoRoll scorePlayer updateDuration]"
! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 23:21'!
pauseFrom: scorePlayer

	"subclasses should take five"! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 23:22'!
resetFrom: scorePlayer

	"subclasses should revert to their initial state"! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 23:21'!
resumeFrom: scorePlayer

	"subclasses should continue from their current position"
	"a hack to allow for abitrary morphs to be dropped into piano roll"! !

!Morph methodsFor: 'piano rolls' stamp: 'RAA 12/11/2000 23:05'!
triggerActionFromPianoRoll

	| evt |
	"a hack to allow for abitrary morphs to be dropped into piano roll"
	self world ifNil: [^self].
	evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self programmedMouseUp: evt for: self.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Morph class
	instanceVariableNames: ''!

!Morph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Return true for all classes that can be instantiated from the menu"
	^ true! !

!Morph class methodsFor: 'instance creation'!
new

	^ super new initialize! !

!Morph class methodsFor: 'instance creation'!
newBounds: bounds

	^ self new privateBounds: bounds! !

!Morph class methodsFor: 'instance creation' stamp: 'jm 5/29/1998 21:28'!
newBounds: bounds color: color

	^ (self new privateBounds: bounds) privateColor: color
! !

!Morph class methodsFor: 'instance creation' stamp: 'sw 8/4/97 12:05'!
newSticky

	^ self new beSticky! !


!Morph class methodsFor: 'class initialization'!
initialize
	"Morph initialize"

	"this empty array object is shared by all morphs with no submorphs:"
	EmptyArray _ Array new.
! !


!Morph class methodsFor: 'misc' stamp: 'sw 8/4/1998 16:51'!
morphsUnknownToTheirOwners
	"Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists"
	"Morph morphsUnknownToTheirOwners"
	| problemMorphs itsOwner |
	problemMorphs _ OrderedCollection new.
	self allSubInstances do:
		[:m | (m isHandMorph not and: [((itsOwner _ m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])])
			ifTrue:
				[problemMorphs add: m]].
	^ problemMorphs! !


!Morph class methodsFor: 'scripting' stamp: 'sw 1/31/2001 01:24'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
		(#basic (
			(slot x 'The x coordinate' number readWrite player getX player setX:)
			(slot y  	'The y coordinate' number readWrite	player 	getY player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' number)
			(command turn: 'Change the heading of the object by the specified amount' number)
			(command beep: 'Make the specified sound' sound)))

		"note: if you change the thing below you also need to change #tileScriptCommands."
		(#scripts (
			(command emptyScript 'an empty script'))
		)
		(#'color & border' (
			(slot color 'The color of the object' color readWrite player getColor  player  setColor:)
			(slot colorUnder 'The color under the center of the object' color readOnly player getColorUnder unused  unused )
			(slot luminanceUnder 'The luminance under the center of the object' number readOnly player getLuminanceUnder unused unused)
			(slot saturationUnder 'The saturation under the center of the object' number readOnly player getSaturationUnder unused unused)
			(slot brightnessUnder 'The brightness under the center of the object' number readOnly player getBrightnessUnder unused unused)
			(slot borderColor 'The color of the object''s border' color readWrite player getBorderColor player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' number readWrite player getBorderWidth player setBorderWidth:)
			(slot roundedCorners 'Whether corners should be rounded' boolean readWrite player getRoundedCorners player setRoundedCorners:)))

		(geometry (
			(slot  scaleFactor 'Yeah, the scale factor' number readWrite player getScaleFactor player setScaleFactor:)
			(slot  left   'The left edge, yeah' number readWrite player getLeft  player  setLeft:)
			(slot right  'The right edge, yeah' number readWrite player getRight  player  setRight:)
			(slot  top  'The top edge' number readWrite player getTop  player  setTop:) 
			(slot  bottom  'The bottom edge' number readWrite player getBottom  player  setBottom:) 
			(slot  width  'The width' number readWrite player getWidth  player  setWidth:)
			(slot  height  'The height' number readWrite player getHeight  player  setHeight:) 
			(slot x   'The x coordinate' number readWrite player  getX   player setX:)
			(slot y   'The y coordinate' number readWrite player  getY  player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading  player setHeading:)))

		(miscellaneous (
			(command doMenuItem: 'do the menu item' menu) 
			(command show 'show the guy')
			(command hide 'hide the guy')
			(command wearCostumeOf: 'wear the costume of...' player)
			(command startScript: 'start the given script ticking' string)
			(command stopScript: 'make the given script be "normal"' string)
			(command pauseScript: 'make the given script be "paused"' string)
			(command tellAllSiblings: 'send a message to all siblings' string)
			(slot copy 'returns a copy of this object' player readOnly player getNewClone	 unused unused)
			(slot elementNumber 'my index in my container' number readWrite player getIndexInOwner player setIndexInOwner:)))

		(motion (
			(slot x 'The x coordinate' number readWrite player getX player setX:)
			(slot y  	'The y coordinate' number readWrite	player 	getY player setY:)
			(slot heading  'Which direction the object is facing.  0 is straight up' number readWrite player getHeading player setHeading:)
			(command forward: 'Moves the object forward in the direction it is heading' number)
			(slot obtrudes 'whether the object sticks out over its container''s edge' boolean readOnly player getObtrudes unused unused) 
			(command moveToward: 'move toward the given object' player) 
			(command turn: 'Change the heading of the object by the specified amount' number)
			(command bounce: 'bounce off the edge if hit' sound) 
			(command wrap 'wrap off the edge if appropriate') 
			(command followPath 'follow the yellow brick road') 
			(command goToRightOf: 'place this object to the right of another' player)))

		(#'pen use' (
			(slot penColor 'the color of ink used by the pen' color readWrite player getPenColor player setPenColor:) 
			(slot penSize 'the width of the pen' number readWrite player getPenSize player setPenSize:) 
			(slot penDown 'whether the pen is currently down' boolean readWrite player getPenDown player setPenDown:)))

		(#tests (
			(slot isOverColor 'whether any part of the object is over the given color' boolean	readOnly player seesColor: unused unused) 
			(slot isUnderMouse 'whether the object is under the current mouse position' boolean readOnly	player getIsUnderMouse unused unused)
			(slot colorSees	'whether the given color sees the given color' boolean readOnly	player color:sees:	unused	unused)
			(slot touchesA	'whether I touch something that looks like...' boolean readOnly player touchesA:	unused	unused)
			(slot obtrudes 'whether the object sticks out over its container''s edge' boolean readOnly player getObtrudes unused unused))))! !

!Morph class methodsFor: 'scripting' stamp: 'sw 9/8/2000 16:34'!
additionsToViewerCategory: aCategoryName
	"Answer a list of viewer specs for items to be added to the given category on behalf of the receiver.  Each class in a morph's superclass chain is given the opportunity to add more things"

	self additionsToViewerCategories do:
		[:anAddition | anAddition first == aCategoryName ifTrue: [^ anAddition second]].
	^ #()! !

!Morph class methodsFor: 'scripting' stamp: 'sw 8/11/97 13:17'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	^ self new markAsPartsDonor! !

!Morph class methodsFor: 'scripting' stamp: 'sw 1/30/2001 14:30'!
helpContributions
	"Answer a list of pairs of the form (<symbol> <help message> ) to contribute to the system help dictionary"
	
"NB: Many of the items here are not needed any more since they're specified as part of command definitions now.  Someone needs to take the time to go through the list and remove items no longer needed.  But who's got that kind of time?"

	^ #(
		(acceptScript:for:
			'submit the contents of the given script editor as the code defining the given selector')
		(actorState
			'return the ActorState object for the receiver, creating it if necessary')
		(addInstanceVariable
			'start the interaction for adding a new instance variable to the receiver')
		(addPlayerMenuItemsTo:hand:
			'add player-specific menu items to the given menu, on behalf of the given hand.  At present, these are only commands relating to the turtle')
		(addYesNoToHand
			'Press here to tear off a  TEST/YES/NO unit which you can drop into your script')
		(allScriptEditors
			'answer a list off the extant ScriptEditors for the receiver')
		(amount
			'The amount of displacement')
		(angle	
			'The angular displacement')
		(anonymousScriptEditorFor:
			'answer a new ScriptEditor object to serve as the place for scripting an anonymous (unnamed, unsaved) script for the receiver')
		(append:
			'add an object to this container')
		(assignDecrGetter:setter:amt:
			'evaluate the decrement variant of assignment')
		(assignGetter:setter:amt:
			'evaluate the vanilla variant of assignment')
		(assignIncrGetter:setter:amt:
			'evalute the increment version of assignment')
		(assignMultGetter:setter:amt:
			'evaluate the multiplicative version of assignment')
		(assureEventHandlerRepresentsStatus
			'make certain that the event handler associated with my current costume is set up to conform to my current script-status')
		(assureExternalName
			'If I do not currently have an external name assigned, get one now')
		(assureUniClass
			'make certain that I am a member a uniclass (i.e. a unique subclass); if I am not, create one now and become me into an instance of it')
		(availableCostumeNames
			'answer a list of strings representing the names of all costumes currently available for me')
		(availableCostumesForArrows
			'answer a list of actual, instantiated costumes for me, which can be cycled through as the user hits a next-costume or previous-costume button in a viewer')
		(beep:
			'make the specified sound')
		(borderColor
			'The color of the object''s border')
		(borderWidth
			'The width of the object''s border')
		(bottom
			'My bottom edge, measured downward from the top edge of the world')
		(bounce:
			'If object strayed beyond the boundaries of its container, make it reflect back into it, making the specified noise while doing so.')
		(bounce
			'If object strayed beyond the boundaries of its container, make it reflect back into it')
		(chooseTrigger
'When this script should run.
"normal" means "only when called"')
		(clearTurtleTrails
			'Clear all the pen trails in the interior.')
		(color	
			'The object''s interior color')
		(colorSees
			'Whether a given color in the object is over another given color')
		(colorUnder
			'The color under the center of the object')
		(copy
			'Return a new object that is very much like this one')
		(cursor	
			'The index of the chosen element')
		(deleteCard
			'Delete the current card.')
		(dismiss
			'Click here to dismiss me')
		(elementNumber
			'My element number as seen by my owner')
		(firstPage
			'Go to first page of book')
		(followPath
				'Retrace the path the object has memorized, if any.')
		(forward:
			'Moves the object forward in the direction it is heading') 
		(goto:
			'Go to the specfied book page')
		(goToNextCardInStack
			'Go to the next card')
		(goToPreviousCardInStack
			'Go to the previous card.')
		(goToRightOf:
			'Align the object just to the right of any specified object.')
		(heading
			'Which direction the object is facing.  0 is straight up') 
		(height	
			'The distance between the top and bottom edges of the object')
		(hide
			'Make the object so that it does not display and cannot handle input')
		(initiatePainting	
			'Initiate painting of a new object in the standard playfield.')
		(initiatePaintingIn:
			'Initiate painting of a new object in the given place.')
		(isOverColor
			'Whether any part of this object is directly over the specified color')
		(isUnderMouse
			'Whether any part of this object is beneath the current mouse-cursor position')
		(lastPage
			'Go to the last page of the book.')
		(left
			'My left edge, measured from the left edge of the World')
		(leftRight
			'The horizontal displacement')
		(liftAllPens
			'Lift the pens on all the objects in my interior.')
		(lowerAllPens
			'Lower the pens on all the objects in my interior.')
		(mouseX
			'The x coordinate of the mouse pointer')
		(mouseY
			'The y coordinate of the mouse pointer')
		(moveToward:
			'Move in the direction of another object.')
		(insertCard
			'Create a new card.')
		(nextPage
			'Go to next page.')
		(numberAtCursor
			'The number held by the object at the chosen element')
		(objectNameInHalo
			'Object''s name -- To change: click here, edit, hit ENTER')
		(obtrudes
			'Whether any part of the object sticks out beyond its container''s borders')
		(offerScriptorMenu
			'Scriptee and script name.
Press to get a menu')
		(pauseScript:
			'Make a running script become paused.')
		(penDown
			'Whether the object''s pen is down (true) or up (false)')
		(penColor
			'The color of the object''s pen')
		(penSize	
			'The size of the object''s pen')
		(playerSeeingColorPhrase
			'The player who "sees" a given color')
		(previousPage
			'Go to previous page')

		(show
			'If object was hidden, make it show itself again.')
		(startScript:
			'Make a script start running.')
		(stopScript:
			'Make a script stop running.')
		(top
			'My top edge, measured downward from the top edge of the world')
		(right
			'My right edge, measured from the left edge of the world')
		(roundUpStrays
			'Bring all out-of-container subparts back into view.')
		(scaleFactor
			'The amount by which the object is scaled')
		(stopScript:
			'make the specified script stop running')
		(tellAllSiblings:
			'send a message to all of my sibling instances')
		(try
			'Run this command once.')
		(tryMe
			'Click here to run this script once; hold button down to run repeatedly')
		(turn:				
			'Change the heading of the object by the specified amount')
		(unhideHiddenObjects
			'Unhide all hidden objects.')
		(upDown
			'The vertical displacement')
		(userScript
			'This is a script defined by you.')
		(userSlot
			'This is an instance variable defined by you.  Click here to change its type')
		(valueAtCursor
			'The chosen element')
		(wearCostumeOf:
			'Wear the same kind of costume as the other object')
		(width	
			'The distance between the left and right edges of the object')
		(wrap
			'If object has strayed beond the boundaries of its container, make it reappear from the opposite edge.')
		(x
			'The x coordinate, measured from the left of the container')
		(y
			'The y-coordinate, measured upward from the bottom of the container')

		)
! !
Object subclass: #MorphExtension
	instanceVariableNames: 'locked visible sticky balloonText balloonTextSelector externalName isPartsDonor actorState player eventHandler otherProperties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MorphExtension commentStamp: '<historical>' prior: 0!
MorphExtension provides access to extra instance state that is not required in most simple morphs.  This allows simple morphs to remain relatively lightweight while still admitting more complex structures as necessary.  The otherProperties field takes this policy to the extreme of allowing any number of additional named attributes, albeit at a certain cost in speed and space.!


!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:53'!
actorState
	^ actorState! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:56'!
actorState: newValue
	actorState _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:52'!
balloonText
	^ balloonText! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:55'!
balloonText: newValue
	balloonText _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:52'!
balloonTextSelector
	^ balloonTextSelector! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:55'!
balloonTextSelector: newValue
	balloonTextSelector _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:54'!
eventHandler
	^ eventHandler! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:56'!
eventHandler: newValue
	eventHandler _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 14:47'!
externalName
	^ externalName! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 14:47'!
externalName: newValue
	externalName _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/14/1998 13:07'!
isPartsDonor
	^ isPartsDonor! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/11/1998 12:52'!
isPartsDonor: newValue
	isPartsDonor _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/14/1998 13:07'!
locked
	^ locked! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:54'!
locked: newValue
	locked _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:53'!
player
	^ player! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:56'!
player: newValue
	player _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/14/1998 13:07'!
sticky
	^ sticky! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:55'!
sticky: newValue
	sticky _ newValue! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/14/1998 13:07'!
visible
	^ visible! !

!MorphExtension methodsFor: 'named access' stamp: 'di 8/10/1998 12:55'!
visible: newValue
	visible _ newValue! !


!MorphExtension methodsFor: 'other properties' stamp: 'di 8/11/1998 22:56'!
hasProperty: propName
	"Answer whether the receiver has the given property.  Deemed to have it only if I have a property dictionary entry for it and that entry is neither nil nor false"
	| prop |
	otherProperties == nil ifTrue: [^ false].
	prop _ otherProperties at: propName ifAbsent: [nil].
	prop == nil ifTrue: [^ false].
	prop == false ifTrue: [^ false].
	^ true! !

!MorphExtension methodsFor: 'other properties' stamp: 'di 8/11/1998 12:02'!
otherProperties
	^ otherProperties! !

!MorphExtension methodsFor: 'other properties' stamp: 'di 8/11/1998 22:56'!
removeProperty: propName
	otherProperties == nil ifTrue: [^ self].
	otherProperties removeKey: propName ifAbsent: [].
	otherProperties size == 0 ifTrue: [otherProperties _ nil]! !

!MorphExtension methodsFor: 'other properties' stamp: 'di 8/11/1998 22:57'!
setProperty: propName toValue: aValue
	"These special cases move old properties into named fields of the extension"
	otherProperties == nil ifTrue: [otherProperties _ IdentityDictionary new].
	otherProperties at: propName put: aValue.
! !

!MorphExtension methodsFor: 'other properties' stamp: 'th 12/15/1999 14:18'!
valueOfProperty: propName 
	^ self valueOfProperty: propName ifAbsent: [nil]! !

!MorphExtension methodsFor: 'other properties' stamp: 'di 8/11/1998 22:57'!
valueOfProperty: propName ifAbsent: aBlock
	otherProperties == nil ifTrue: [^ aBlock value].
	^ otherProperties at: propName ifAbsent: [^ aBlock value]! !


!MorphExtension methodsFor: 'copying' stamp: 'di 8/11/1998 15:14'!
copyPropertiesFrom: donorMorph dict: dict
	| val |
	otherProperties _ donorMorph otherProperties copy.
	otherProperties ifNotNil: [
		otherProperties associationsDo:
			[:assn | val _ assn value.
			val isMorph ifTrue: [
				val owner ifNil: [assn value: (val copyRecordingIn: dict)]]]].
					"note side effecting.  Any un-owned morph belongs to us."! !

!MorphExtension methodsFor: 'copying' stamp: 'ar 1/25/2001 12:49'!
copyWeakly
	"list of names of properties whose values should be weak-copied when veryDeepCopying a morph.  See DeepCopier."

	^ #(formerOwner newPermanentPlayer)	"add yours to this list" 

"formerOwner should really be nil at the time of the copy, but this will work just fine."!
]style[(10 101 10 157)f1b,f1,f1LDeepCopier Comment;,f1! !

!MorphExtension methodsFor: 'copying' stamp: 'di 8/11/1998 15:16'!
updateReferencesUsing: aDictionary
	"Update intra-morph references within a composite morph that has
been copied. For example, if a button refers to morph X in the orginal
composite then the copy of that button in the new composite should refer to
the copy of X in new composite, not the original X. This default
implementation updates the contents of any morph-bearing slot."
	| old |
	eventHandler == nil ifFalse:
		[self eventHandler: self eventHandler copy.
		1 to: self eventHandler class instSize do:
			[:i | old _ eventHandler instVarAt: i.
			old isMorph ifTrue:
				[eventHandler instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]].
	otherProperties ifNotNil: [
		otherProperties associationsDo:
			[:assn | assn value: (aDictionary at: assn value ifAbsent: [assn value])]].
			"note side effecting"
! !

!MorphExtension methodsFor: 'copying' stamp: 'tk 1/22/2001 17:51'!
veryDeepFixupWith: deepCopier
	| list |
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	otherProperties ifNotNil: [
		list _ self copyWeakly.	"Properties whose values are only copied weakly"
		"replace those values if they were copied via another path"
		list do: [:pp | 
			(otherProperties at: pp ifAbsent: [nil]) ifNotNil: [
				otherProperties at: pp put: 
					(deepCopier references at: (otherProperties at: pp) 
									ifAbsent: [(otherProperties at: pp)])]]].

! !

!MorphExtension methodsFor: 'copying' stamp: 'tk 1/28/2001 22:13'!
veryDeepInner: deepCopier
	| list values vv |
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  This is special code for the dictionary.  See DeepCopier."

	super veryDeepInner: deepCopier.
	locked _ locked veryDeepCopyWith: deepCopier.
 	visible _ visible veryDeepCopyWith: deepCopier.
 	sticky _ sticky veryDeepCopyWith: deepCopier.
 	balloonText _ balloonText veryDeepCopyWith: deepCopier.
 	balloonTextSelector _ balloonTextSelector veryDeepCopyWith: deepCopier.
 	externalName _ externalName veryDeepCopyWith: deepCopier.
 	isPartsDonor _ isPartsDonor veryDeepCopyWith: deepCopier.
 	actorState _ actorState veryDeepCopyWith: deepCopier.
 	player _ player veryDeepCopyWith: deepCopier.	"Do copy the player of this morph"
 	eventHandler _ eventHandler veryDeepCopyWith: deepCopier.	"has its own restrictions"

	otherProperties ifNotNil: [
		otherProperties _ otherProperties copy.
		list _ self copyWeakly.	"Properties whose values are only copied weakly"
		values _ list collect: [:pp | 
			vv _ otherProperties at: pp ifAbsent: [nil].
			vv ifNotNil: [otherProperties at: pp put: nil]. "zap it"
			vv].
	 	otherProperties _ otherProperties veryDeepCopyWith: deepCopier.
		1 to: list size do: [:ii | "put old values back"
			(values at: ii) ifNotNil: [otherProperties at: (list at: ii) put: (values at: ii)]]].
!
]style[(25 153 10 1164)f1b,f1,f1LDeepCopier Comment;,f1! !


!MorphExtension methodsFor: 'object fileIn' stamp: 'tk 4/8/1999 12:45'!
comeFullyUpOnReload: smartRefStream
	"inst vars have default booplean values."

	locked ifNil: [locked _ false].
	visible ifNil: [visible _ true].
	sticky ifNil: [sticky _ false].
	isPartsDonor ifNil: [isPartsDonor _ false].
	^ self! !

!MorphExtension methodsFor: 'object fileIn' stamp: 'tk 8/12/1998 14:31'!
convertProperty: propName toValue: aValue
	"These special cases move old properties into named fields of the extension"
	propName == #locked ifTrue: [^ locked _ aValue].
	propName == #visible ifTrue: [^ visible _ aValue].
	propName == #sticky ifTrue: [^ sticky _ aValue].
	propName == #balloonText ifTrue: [^ balloonText _ aValue].
	propName == #balloonTextSelector ifTrue: [^ balloonTextSelector _ aValue].
	propName == #actorState ifTrue: [^ actorState _ aValue].
	propName == #player ifTrue: [^ player _ aValue].
	propName == #name ifTrue: [^ externalName _ aValue].  "*renamed*"
	propName == #partsDonor ifTrue: [^ isPartsDonor _ aValue].  "*renamed*"
	otherProperties == nil ifTrue: [otherProperties _ IdentityDictionary new].
	otherProperties at: propName put: aValue.
! !


!MorphExtension methodsFor: 'initialization' stamp: 'di 8/16/1998 12:02'!
initialize
	"Init all booleans to default values"
	locked _ false.
	visible _ true.
	sticky _ false.
	isPartsDonor _ false.
! !


!MorphExtension methodsFor: 'other' stamp: 'ar 11/13/2000 19:08'!
isDefault
	"Return true if the receiver is a default and can be omitted"
	locked == true ifTrue:[^false].
	visible == false ifTrue:[^false].
	sticky == true ifTrue:[^false].
	balloonText == nil ifFalse:[^false].
	balloonTextSelector == nil ifFalse:[^false].
	externalName == nil ifFalse:[^false].
	isPartsDonor == true ifTrue:[^false].
	actorState == nil ifFalse:[^false].
	player == nil ifFalse:[^false].
	eventHandler == nil ifFalse:[^false].
	otherProperties == nil ifFalse:[otherProperties size > 0 ifTrue:[^false]].
	^true! !

!MorphExtension methodsFor: 'other' stamp: 'sw 10/7/1999 15:16'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' ', self identityHashPrintString.
	locked == true ifTrue: [aStream nextPutAll: ' [locked] '].
	visible == false ifTrue: [aStream nextPutAll: '[not visible] '].
	sticky == true ifTrue: [aStream nextPutAll: ' [sticky] '].
	balloonText ifNotNil: [aStream nextPutAll: ' [balloonText] '].
	balloonTextSelector ifNotNil: [aStream nextPutAll: ' [balloonTextSelector: ', balloonTextSelector printString, '] '].
	externalName ifNotNil: [aStream nextPutAll: ' [externalName = ', externalName, ' ] '].
	isPartsDonor == true ifTrue: [aStream nextPutAll: ' [isPartsDonor] '].
	player ifNotNil: [aStream nextPutAll: ' [player = ', player printString, '] '].
	eventHandler ifNotNil: [aStream nextPutAll: ' [eventHandler = ', eventHandler printString, '] '].
	otherProperties isEmptyOrNil ifTrue: [^ self].

	aStream nextPutAll: ' [other: '.
	otherProperties keysDo: [:aKey | aStream nextPutAll: ' (', aKey, ' -> ', (otherProperties at: aKey) printString, ')'].
	aStream nextPut: $]! !

!MorphExtension methodsFor: 'other' stamp: 'ar 5/20/1999 15:33'!
removeOtherProperties
	"Remove the 'other' properties"
	otherProperties _ nil.! !

!MorphExtension methodsFor: 'other' stamp: 'ar 11/13/2000 13:18'!
sortedPropertyNames
	| props |
	props _ WriteStream on: (Array new: 10).
	locked == true ifTrue:[props nextPut: #locked].
	visible == false ifTrue:[props nextPut: #visible].
	sticky == true ifTrue:[props nextPut: #sticky].
	balloonText == nil ifFalse:[props nextPut: #balloonText].
	balloonTextSelector == nil ifFalse:[props nextPut: #balloonTextSelector].
	externalName == nil ifFalse:[props nextPut: #externalName].
	isPartsDonor == true ifTrue:[props nextPut: #isPartsDonor].
	actorState == nil ifFalse:[props nextPut: #actorState].
	player == nil ifFalse:[props nextPut: #player].
	eventHandler == nil ifFalse:[props nextPut: #eventHandler].
	otherProperties == nil ifFalse:[
		otherProperties associationsDo:[:a| props nextPut: a key]].
	^props contents sort:[:s1 :s2| s1 <= s2].! !


!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:17'!
layoutFrame
	^self valueOfProperty: #layoutFrame ifAbsent:[nil]! !

!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:17'!
layoutFrame: aLayoutFrame
	aLayoutFrame == nil
		ifTrue:[self removeProperty: #layoutFrame]
		ifFalse:[self setProperty: #layoutFrame toValue: aLayoutFrame].
! !

!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:17'!
layoutPolicy
	^self valueOfProperty: #layoutPolicy ifAbsent:[nil]! !

!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:18'!
layoutPolicy: aLayoutPolicy
	aLayoutPolicy == nil
		ifTrue:[self removeProperty: #layoutPolicy]
		ifFalse:[self setProperty: #layoutPolicy toValue: aLayoutPolicy].
! !

!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:18'!
layoutProperties
	^self valueOfProperty: #layoutProperties ifAbsent:[nil]! !

!MorphExtension methodsFor: 'layout properties' stamp: 'ar 11/14/2000 17:18'!
layoutProperties: newProperties
	"Return the current layout properties associated with the receiver"
	newProperties == nil
		ifTrue:[self removeProperty: #layoutProperties]
		ifFalse:[self setProperty: #layoutProperties toValue: newProperties].! !
ObjectOut subclass: #MorphObjectOut
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 4/6/1999 10:00'!
doesNotUnderstand: aMessage 
	"Bring in the object, install, then resend aMessage"
	| aMorph myUrl oldFlag response |
	"Transcript show: thisContext sender selector; cr." "useful for debugging"
	oldFlag _ recursionFlag.
	recursionFlag _ true.
	myUrl _ url.	"can't use inst vars after become"
	"fetch the object"
	aMorph _ self xxxFetch.		"watch out for the become!!"
			"Now we ARE a MORPH"
	oldFlag == true ifTrue: [
		response _ (PopUpMenu labels: 'proceed normally\debug' withCRs)
			startUpWithCaption: 'Object being fetched for a second time.
Should not happen, and needs to be fixed later.'.
		response = 2 ifTrue: [self halt]].	"We are already the new object"

	aMorph setProperty: #SqueakPage toValue: 
			(SqueakPageCache pageCache at: myUrl).
	"Can't be a super message, since this is the first message sent to this object"
	^ aMorph perform: aMessage selector withArguments: aMessage arguments
! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 10/22/1998 15:43'!
fullReleaseCachedState
	"do nothing, especially don't bring in my object!!"! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 00:08'!
smallThumbnailForPageSorter

	^ self sqkPage thumbnail! !

!MorphObjectOut methodsFor: 'as yet unclassified' stamp: 'tk 2/24/1999 00:09'!
thumbnailForPageSorter

	^ self sqkPage thumbnail! !
SketchMorph subclass: #MorphThumbnail
	instanceVariableNames: 'morphRepresented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Books'!
!MorphThumbnail commentStamp: '<historical>' prior: 0!
A morph whose appearance is a thumbnail of some other morph.!


!MorphThumbnail methodsFor: 'copying' stamp: 'tk 1/8/1999 09:39'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
morphRepresented _ deepCopier references at: morphRepresented 
		ifAbsent: [morphRepresented].! !

!MorphThumbnail methodsFor: 'copying' stamp: 'tk 1/8/1999 09:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
morphRepresented _ morphRepresented.		"Weakly copied"! !


!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:07'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'reveal original morph' action: #revealOriginal.
	aCustomMenu add: 'grab original morph' action: #grabOriginal.
! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 11/13/1998 09:53'!
computeThumbnail
	"Assumption on entry:
       The receiver's width represents the maximum width allowable.
       The receiver's height represents the exact height desired."

	| f scaleX scaleY |
	f _ morphRepresented imageForm.
	morphRepresented fullReleaseCachedState.
	scaleY _ self height / f height.  "keep height invariant"
	scaleX _ ((morphRepresented width * scaleY) <= self width)
		ifTrue:
			[scaleY]  "the usual case; same scale factor, to preserve aspect ratio"
		ifFalse:
			[self width / f width].
	self form: (f magnify: f boundingBox by: (scaleX @ scaleY) smoothing: 2).
	self extent: originalForm extent! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:08'!
grabOriginal
	self primaryHand attachMorph: morphRepresented! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 07:05'!
initialize

	| f |
	super initialize.
	color _ Color lightGray.  "background color"
	f _ Form extent: 60@80 depth: Display depth.
	f fill: f boundingBox fillColor: color.
	self form: f
! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'bf 3/31/1999 12:24'!
innocuousName
	^ morphRepresented isNil
		ifTrue: [super innocuousName]
		ifFalse: [morphRepresented innocuousName]! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'jm 11/17/97 17:30'!
morphRepresented

	^ morphRepresented
! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'ar 10/7/2000 15:38'!
morphRepresented: aMorph

	morphRepresented _ aMorph.
	self computeThumbnail.
! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'bf 3/31/1999 07:54'!
representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight

	"Return a morph representing the receiver but which is no taller than aHeight.  If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth"

	(self height <= maxHeight and: [self width <= maxWidth]) ifTrue: [^ self].

	^ MorphThumbnail new
		extent: maxWidth @ (thumbnailHeight min: self height);
		morphRepresented: morphRepresented! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:04'!
revealOriginal
	((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail])
		ifTrue:
			[^ self beep].
	morphRepresented owner == nil ifTrue:
		[^ owner replaceSubmorph: self by: morphRepresented].
	self beep.! !

!MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 07:05'!
smaller
	self form: (self form copy: (0@0 extent: self form extent // 2))! !


!MorphThumbnail methodsFor: 'parts bin' stamp: 'ar 10/7/2000 15:38'!
isPartsDonor
	^self partRepresented isPartsDonor! !

!MorphThumbnail methodsFor: 'parts bin' stamp: 'ar 10/7/2000 15:38'!
isPartsDonor: aBool
	self partRepresented isPartsDonor: aBool! !

!MorphThumbnail methodsFor: 'parts bin' stamp: 'ar 10/6/2000 22:46'!
partRepresented
	^self morphRepresented! !
Controller subclass: #MorphWorldController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Morphic'!
!MorphWorldController commentStamp: '<historical>' prior: 0!
I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. (See the class comment in GestureController for more details about gestures.) I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point.

The mapping of gestures to actions is as follows (see GestureController comment for more about gestures):

  Click:
	click on glyph				select glyph
	shift-click on glyph			toggle selection of that glyph
	click on background			clear selection
  Double click:
	double-click on glyph			inspect glyph
	double-click on background		select all
  Hold/Drag/Sweep:
	hold (no movement)			yellow-button menu
	drag (up/left movement)		scrolling hand
	sweep (down/right movement)	select glyphs in region
	shift-sweep					toggle selection of glyphs in region
!


!MorphWorldController methodsFor: 'control sequence' stamp: 'jm 2/20/98 13:37'!
controlActivity
	"Do one step of the Morphic interaction loop. Called repeatedly while window is active."

	model doOneCycle.
! !

!MorphWorldController methodsFor: 'control sequence' stamp: 'di 11/26/1999 10:00'!
controlInitialize
	"This window is becoming active."

	true ifTrue: [model becomeTheActiveWorldWith: nil].

	model canvas ifNil: [  "i.e., only on first entry"
		"In case of, eg, inspect during balloon help..."
		model submorphsDo: [:m |  "delete any existing balloons"
			(m isKindOf: BalloonMorph) ifTrue: [m delete]].

		model handsDo: [:h | h initForEvents].
		view displayView].  "initializes the WorldMorph's canvas"
! !

!MorphWorldController methodsFor: 'control sequence' stamp: 'jm 2/20/98 14:34'!
controlLoop 
	sensor leftShiftDown ifTrue:
		["Hold shift down when activating a Morphic window to take stats"
		(self confirm: 'The shift key was down;
do you really want to spy on Morphic?') ifTrue:
			[^ MessageTally spyOn: [super controlLoop. Cursor normal show]]].

	"Overridden to keep control active when the hand drags something out of the view"
	[self viewHasCursor or:
		[Sensor anyButtonPressed or: [model primaryHand submorphs size > 0]]]
		whileTrue:
			[self controlActivity. Processor yield].
! !

!MorphWorldController methodsFor: 'control sequence' stamp: 'jm 2/20/98 13:36'!
controlTerminate 
	"This window is becoming inactive; restore the normal cursor."

	Cursor normal show.
! !

!MorphWorldController methodsFor: 'control sequence' stamp: 'jm 6/17/97 10:29'!
isControlActive

	^ sensor redButtonPressed or: [self viewHasCursor]! !
View subclass: #MorphWorldView
	instanceVariableNames: ''
	classVariableNames: 'FullColorWhenInactive '
	poolDictionaries: ''
	category: 'ST80-Morphic'!
!MorphWorldView commentStamp: '<historical>' prior: 0!
I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController.

SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction.

Instance Variables:
	offset				the current offset of this view (used for scrolling)
	enclosingRect 		a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)
	backgroundForm		a <Form> containing the fixed background
	visibleForeground		the glyphs that are changing but not selected during an interaction
	selectedForeground	the selected glyphs that are changing during an interaction!


!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'dew 11/8/1999 02:00'!
computeInsetDisplayBox
	"This overrides the same method in View.  (It avoids using displayTransform: because it can return inaccurate results, causing a MorphWorldView's inset display box to creep inward when resized.)"

	^superView insetDisplayBox insetBy: borderWidth! !

!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 10:34'!
deEmphasizeView 
	"This window is becoming inactive."

	Cursor normal show.    "restore the normal cursor"
	model deEmphasizeViewMVC: self topView cacheBitsAsTwoTone.
! !

!MorphWorldView methodsFor: 'as yet unclassified'!
defaultControllerClass

	^ MorphWorldController! !

!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'dew 11/8/1999 02:01'!
displayView
	"This method is called by the system when the top view is framed or moved."
	| topView |
	model viewBox: self insetDisplayBox.
	self updateSubWindowExtent.
	topView _ self topView.
	(topView == ScheduledControllers scheduledControllers first view
		or: [topView cacheBitsAsTwoTone not])
		ifTrue: [model displayWorldSafely]
		ifFalse: [model displayWorldAsTwoTone].  "just restoring the screen"! !

!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'sw 9/26/97 20:56'!
update: symbol

	^ symbol == #newColor
		ifTrue: [self topView backgroundColor: model color dominantColor; uncacheBits; display]
		ifFalse: [super update: symbol].
! !

!MorphWorldView methodsFor: 'as yet unclassified' stamp: 'RAA 11/25/1999 09:19'!
updateSubWindowExtent
	"If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView."

	| numMorphs subWindow scrollBarWidth |
	numMorphs _ model submorphs size.
	"(Allow for the existence of an extra NewHandleMorph (for resizing).)"
	(numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^ self].
	subWindow _ model submorphs
					detect: [:ea | ea respondsTo: #label]
					ifNone: [^ self].
	superView label = subWindow label ifFalse: [^ self].
	(Preferences valueOfFlag: #inboardScrollbars)
		ifTrue: [scrollBarWidth _ 0]
		ifFalse: [scrollBarWidth _ 14].
	subWindow position: model position + (scrollBarWidth@-16).	"adjust for WiW changes"
	subWindow extent: model extent - (scrollBarWidth@-16).
	subWindow isActive ifFalse: [subWindow activate].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphWorldView class
	instanceVariableNames: ''!

!MorphWorldView class methodsFor: 'instance creation' stamp: 'RAA 11/25/1999 23:43'!
convertToMVCWiWPasteUpMorph
"
MorphWorldView convertToMVCWiWPasteUpMorph
"
	| current w newModel topView |

	Smalltalk isMorphic ifTrue: [^self inform: 'do this in MVC'].
	current _ self allInstances select: [ :each | each model class == PasteUpMorph].
	current do: [ :oldWorldView |
		w _ MVCWiWPasteUpMorph newWorldForProject: nil.
		w 
			color: oldWorldView model color;
			addAllMorphs: oldWorldView model submorphs.
		newModel _ CautiousModel new initialExtent: 300@300.
		topView _ self fullColorWhenInactive
			ifTrue: [ColorSystemView new]
			ifFalse: [StandardSystemView new].
		topView
			model: newModel;
			label: oldWorldView topView label;
			borderWidth: 1;
			addSubView: (self new initialize model: w);
			backgroundColor: w color.
		topView controller openNoTerminate.
		topView reframeTo: (oldWorldView topView expandedFrame expandBy:
				(0@0 extent: (0@topView labelHeight))).
		oldWorldView topView controller closeAndUnscheduleNoTerminate.
	].
	ScheduledControllers restore.
	Processor terminateActive.! !

!MorphWorldView class methodsFor: 'instance creation'!
fullColorWhenInactive

	FullColorWhenInactive ifNil: [FullColorWhenInactive _ true].
	^ FullColorWhenInactive
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'di 2/26/98 09:17'!
fullColorWhenInactive: fullColor
	"MorphWorldView fullColorWhenInactive: true"
	"If FullColorWhenInactive is true then WorldMorphViews will created inside StandardSystemViews that cache their contents in full-color when the window is inactive. If it is false, only a half-tone gray approximation of the colors will be cached to save space."

	FullColorWhenInactive _ fullColor.

	"Retroactively convert all extant windows"
	((fullColor ifTrue: [StandardSystemView] ifFalse: [ColorSystemView])
		allInstances select:
			[:v | v subViews notNil and: [v subViews isEmpty not and: [v firstSubView isKindOf: MorphWorldView]]])
		do: [:v | v uncacheBits.
			v controller toggleTwoTone]! !

!MorphWorldView class methodsFor: 'instance creation'!
openOn: aMorphWorld
	"Open a view on the given WorldMorph."

	self openOn: aMorphWorld label: 'A Morphic World'.! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 10/2/97 23:17'!
openOn: aWorldMorph label: aString
	"Open a view with the given label on the given WorldMorph."
	^ self openOn: aWorldMorph label: aString model: (CautiousModel new initialExtent: aWorldMorph initialExtent)! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 9/21/1998 17:54'!
openOn: aWorldMorph label: aString cautionOnClose: aBoolean
	"Open a view with the given label on the given WorldMorph."
	| aModel |
	aModel _ aBoolean
		ifTrue:		[CautiousModel new]
		ifFalse:		[WorldViewModel new].
	^ self openOn: aWorldMorph label: aString model: (aModel initialExtent: aWorldMorph initialExtent)! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'jm 1/31/98 20:24'!
openOn: aWorldMorph label: aString extent: aPoint
	"Open a view with the given label and extent on the given WorldMorph."

	^ self openOn: aWorldMorph
		label: aString
		model: (CautiousModel new initialExtent: aPoint)
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 5/4/1998 23:47'!
openOn: aWorldMorph label: aString model: aModel
	"Open a view with the given label on the given WorldMorph."
	| topView |
	topView _ self fullColorWhenInactive
		ifTrue: [topView _ ColorSystemView new]
		ifFalse: [topView _ StandardSystemView new].
	topView model: aModel;
		label: aString;
		borderWidth: 1;
		"minimumSize: aWorldMorph extent + (2@2); " "add border width"
		addSubView: (self new initialize model: aWorldMorph);
		backgroundColor: aWorldMorph color.
	topView controller open.
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'di 11/26/1999 11:46'!
openWorld

	| w |
	(w _ MVCWiWPasteUpMorph newWorldForProject: nil).
	w bounds: (0@0 extent: 400@300).
	self openOn: w
		label: 'A Morphic World'
		extent: w fullBounds extent + 2.
! !

!MorphWorldView class methodsFor: 'instance creation' stamp: 'sma 6/12/2000 14:18'!
openWorldWith: aMorph labelled: labelString

	| w |
	(w _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph.
	w extent: aMorph fullBounds extent.
	w startSteppingSubmorphsOf: aMorph.
	self openOn: w
		label: labelString
		extent: w fullBounds extent + 2.
! !
MessageSend subclass: #MorphicAlarm
	instanceVariableNames: 'scheduledTime numArgs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:44'!
scheduledTime
	"Return the time (in milliseconds) that the receiver is scheduled to be executed"
	^scheduledTime! !

!MorphicAlarm methodsFor: 'accessing' stamp: 'ar 9/11/2000 16:45'!
scheduledTime: msecs
	"Set the time (in milliseconds) that the receiver is scheduled to be executed"
	scheduledTime _ msecs! !


!MorphicAlarm methodsFor: 'evaluating' stamp: 'ar 10/22/2000 17:36'!
value: anArgument
	| nArgs |
	numArgs ifNil:[numArgs _ selector numArgs].
	nArgs _ arguments ifNil:[0] ifNotNil:[arguments size].
	nArgs = numArgs ifTrue:[
		"Ignore extra argument"
		^self value].
	^arguments isNil
		ifTrue: [receiver perform: selector with: anArgument]
		ifFalse: [receiver perform: selector withArguments: (arguments copyWith: anArgument)]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicAlarm class
	instanceVariableNames: ''!

!MorphicAlarm class methodsFor: 'instance creation' stamp: 'ar 9/11/2000 16:44'!
scheduledAt: scheduledTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime.! !
Object subclass: #MorphicEvent
	instanceVariableNames: 'timeStamp source '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!MorphicEvent commentStamp: '<historical>' prior: 0!
This class represents the base for all events.

Instance variables:
	stamp	<Integer>	The millisecond clock time stamp (based on Time millisecondClock)
	source	<Hand | nil>	If non-nil the hand that generated the event.!


!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 21:28'!
cursorPoint
	"Backward compatibility. Use #position instead"
	^ self position! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:48'!
hand
	"Return the source that generated the event"
	^source! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:29'!
timeStamp
	"Return the millisecond clock value at which the event was generated"
	^timeStamp ifNil:[timeStamp _ Time millisecondClockValue]! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:34'!
type
	"Return a symbol indicating the type this event."
	^self subclassResponsibility! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:19'!
wasHandled
	"Return true if this event was handled. May be ignored for some types of events."
	^false! !

!MorphicEvent methodsFor: 'accessing' stamp: 'ar 10/10/2000 01:20'!
wasHandled: aBool
	"Determine if this event was handled. May be ignored for some types of events."! !


!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/22/2000 10:36'!
isDraggingEvent
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:17'!
isDropEvent
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'!
isKeyboard
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 10/10/2000 21:27'!
isKeystroke
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'!
isMorphicEvent
	^true! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'!
isMouse
	^false! !

!MorphicEvent methodsFor: 'testing' stamp: 'ar 9/14/2000 18:21'!
isMouseOver
	^self type == #mouseOver! !


!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'!
= anEvent
	anEvent isMorphicEvent ifFalse:[^false].
	^self type = anEvent type! !

!MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'!
hash
	^self type hash! !


!MorphicEvent methodsFor: 'transforming' stamp: 'ar 9/13/2000 15:47'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
! !


!MorphicEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:12'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	^anObject handleUnknownEvent: self! !


!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
! !

!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/10/2000 01:18'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"! !

!MorphicEvent methodsFor: 'initialize' stamp: 'ar 10/24/2000 16:21'!
type: eventType readFrom: aStream
	"Read a MorphicEvent from the given stream."
! !


!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 21:26'!
setHand: aHand
	source _ aHand! !

!MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 20:53'!
setTimeStamp: stamp
	timeStamp _ stamp.! !


!MorphicEvent methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 16:05'!
convertOctober2000: varDict using: smartRefStrm
	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	"These are going away #('type' 'cursorPoint' 'buttons' 'keyValue' 'sourceHand').  Possibly store their info in another variable?"
	| type cursorPoint buttons keyValue sourceHand |
	type _ varDict at: 'type'.
	cursorPoint _ varDict at: 'cursorPoint'.
	buttons _ varDict at: 'buttons'.
	keyValue _ varDict at: 'keyValue'.
	sourceHand _ varDict at: 'sourceHand'.
	type == #mouseMove ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: cursorPoint
			endPoint: cursorPoint
			trail: #() 
			buttons: buttons 
			hand: sourceHand 
			stamp: nil].
	(type == #mouseDown) | (type == #mouseUp) ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: cursorPoint
				which: 0
				buttons: buttons
				hand: sourceHand
				stamp: nil].
	(type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: cursorPoint
			keyValue: keyValue
			hand: sourceHand
			stamp: nil].
	"All others will be handled there"
	^MorphicUnknownEvent new! !

!MorphicEvent methodsFor: 'object fileIn' stamp: 'RAA 12/21/2000 11:35'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	| answer |

	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	varDict at: 'cursorPoint' ifPresent: [ :x | 
		answer _ self convertOctober2000: varDict using: smartRefStrm.
		varDict removeKey: 'cursorPoint'.	"avoid doing this again"
		^answer
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.


! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicEvent class
	instanceVariableNames: ''!

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 00:44'!
convertObsolete: anEvent
	"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
	| type cursorPoint buttons keyValue sourceHand |
	type _ anEvent type.
	cursorPoint _ anEvent cursorPoint.
	buttons _ anEvent buttons.
	keyValue _ anEvent keyValue.
	sourceHand _ anEvent hand.
	type == #mouseMove ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: cursorPoint
			endPoint: cursorPoint
			trail: #() 
			buttons: buttons 
			hand: sourceHand 
			stamp: nil].
	(type == #mouseDown) | (type == #mouseUp) ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: cursorPoint
				which: 0
				buttons: buttons
				hand: sourceHand
				stamp: nil].
	(type == #keystroke) | (type == #keyDown) | (type == #keyUp) ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: cursorPoint
			keyValue: keyValue
			hand: sourceHand
			stamp: nil].
	^nil! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/25/2000 23:32'!
fromStringArray: array
	"decode an event that was encoded with encodedAsStringArray"
	| type |
	type := (array at: 1).
	(type = 'mouseMove')
		ifTrue:[^MouseMoveEvent new decodeFromStringArray: array].
	(type = 'mouseDown' or:[type = 'mouseUp']) 
		ifTrue:[^MouseButtonEvent new decodeFromStringArray: array].
	(type = 'keystroke' or:[type = 'keyDown' or:[type = 'keyUp']]) 
		ifTrue:[^KeyboardEvent new decodeFromStringArray: array].
	^nil! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 00:49'!
readFrom: aStream
	"Read a MorphicEvent from the given stream."
	| typeString c |
	typeString _ String streamContents:
		[:s |   [(c _ aStream next) isLetter] whileTrue: [s nextPut: c]].
	typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream].
	typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream].
	typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream].

	typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream].
	typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream].
	typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream].

	typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream].
	typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream].
	typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream].

	typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream].

	^nil
! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/25/2000 21:58'!
readFromObsolete: aStream
	"Read one of those old and now obsolete events from the stream"
	| type x y buttons keyValue typeString c |
	typeString _ String streamContents:
		[:s |   [(c _ aStream next) isLetter] whileTrue: [s nextPut: c]].
	typeString = 'mouseMove'
		ifTrue: [type _ #mouseMove  "fast treatment of common case"]
		ifFalse: [type _ typeString asSymbol].

	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	aStream skip: 1.

	buttons _ Integer readFrom: aStream.
	aStream skip: 1.

	keyValue _ Integer readFrom: aStream.

	typeString = 'mouseMove' ifTrue:[
		^MouseMoveEvent new
			setType: #mouseMove 
			startPoint: x@y 
			endPoint: x@y 
			trail: #() 
			buttons: buttons 
			hand: nil 
			stamp: nil].
	(typeString = 'mouseDown') | (typeString = 'mouseUp') ifTrue:[
			^MouseButtonEvent new
				setType: type
				position: x@y
				which: 0
				buttons: buttons
				hand: nil
				stamp: nil].
	(typeString = 'keystroke') | (typeString = 'keyDown') | (typeString = 'keyUp') ifTrue:[
		^KeyboardEvent new
			setType: type
			buttons: buttons
			position: x@y
			keyValue: keyValue
			hand: nil
			stamp: nil].

	^nil! !

!MorphicEvent class methodsFor: 'instance creation' stamp: 'ar 10/24/2000 16:32'!
type: eventType readFrom: aStream
	^self new type: eventType readFrom: aStream! !
Object subclass: #MorphicEventDecoder
	instanceVariableNames: 'connection '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!MorphicEventDecoder commentStamp: '<historical>' prior: 0!
decode messages sent via a MorphicEventEncoder.!


!MorphicEventDecoder methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:42'!
connection: aConnection
	connection := aConnection! !


!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'RAA 11/8/2000 15:15'!
apply: aStringArray to: aHand
	"decode aStringArray, and apply the encoded command to aHand"

	aStringArray first = 'event' ifTrue: [
		^self applyEventMessage: aStringArray to: aHand
	].
	aStringArray first = 'viewExtent' ifTrue: [
		^self applyViewExtentMessage: aStringArray to: aHand
	].
	aStringArray first = 'beginBuffering' ifTrue: [
		^aHand convertRemoteClientToBuffered
	].

	^self error: 'unknown message type: ', aStringArray first! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ar 10/26/2000 01:55'!
applyEventMessage: aStringArray to: aHand
	| event |
	event := MorphicEvent fromStringArray: (aStringArray copyFrom: 2 to: aStringArray size).
	event ifNotNil:[aHand queueEvent: event].! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 3/25/2000 16:56'!
applyMessagesTo: aHand
	| msg |
	"apply all queued events to the given hand"
	"currently, there is no way to extract the rawmessages.  This is simply because I didn't feel like implementing individual classes for each message -lex"
	[ msg := connection nextOrNil.  msg notNil ] whileTrue: [
		self apply: msg to: aHand ].
! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 4/11/2000 19:00'!
applyViewExtentMessage: aStringArray to: aHand
	| newViewExtent |
	newViewExtent := CanvasDecoder decodePoint: aStringArray second.

	aHand setViewExtent: newViewExtent! !

!MorphicEventDecoder methodsFor: 'handling messages' stamp: 'ls 3/24/2000 22:54'!
processIO
	connection processIO! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicEventDecoder class
	instanceVariableNames: ''!

!MorphicEventDecoder class methodsFor: 'instance creation' stamp: 'ls 3/24/2000 21:43'!
on: aStringArray
	^self basicNew connection: aStringArray! !
Object subclass: #MorphicEventDispatcher
	instanceVariableNames: 'lastType lastDispatch '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!
!MorphicEventDispatcher commentStamp: '<historical>' prior: 0!
The class represents a strategy for dispatching events to some immediate child of a morph. It is used by morphs to delegate the somewhat complex action of dispatching events accurately. !


!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 01:20'!
dispatchDefault: anEvent with: aMorph
	"Dispatch the given event. The event will be passed to the front-most visible submorph that contains the position wrt. to the event."
	| localEvt index child morphs inside |
	"See if we're fully outside aMorphs bounds"
	(aMorph fullBounds containsPoint: anEvent position) ifFalse:[^#rejected]. "outside"
	"Traverse children"
	index _ 1.
	morphs _ aMorph submorphs.
	inside _ false.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			"Not rejected. The event was in some submorph of the receiver"
			inside _ true.
			localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
			index _ morphs size. "break"
		].
		index _ index + 1.
	].

	"Check for being inside the receiver"
	inside ifFalse:[inside _ aMorph containsPoint: anEvent position event: anEvent].
	inside ifTrue:[^aMorph handleEvent: anEvent].
	^#rejected
! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:13'!
dispatchDropEvent: anEvent with: aMorph
	"Find the appropriate receiver for the event and let it handle it. The dispatch is similar to the default dispatch with one difference: Morphs are given the chance to reject an entire drop operation. If the operation is rejected, no drop will be executed."
	| inside index morphs child localEvt |
	"Try to get out quickly"
	(aMorph fullBounds containsPoint: anEvent cursorPoint)
		ifFalse:[^#rejected].
	"Give aMorph a chance to repel the dropping morph"
	aMorph rejectDropEvent: anEvent.
	anEvent wasHandled ifTrue:[^self].

	"Go looking if any of our submorphs wants it"
	index _ 1.
	inside _ false.
	morphs _ aMorph submorphs.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			localEvt wasHandled ifTrue:[^anEvent wasHandled: true]. "done"
			inside _ true.
			index _ morphs size]. "break"
		index _ index + 1.
	].

	inside ifFalse:[inside _ aMorph containsPoint: anEvent cursorPoint event: anEvent].
	inside ifTrue:[^aMorph handleEvent: anEvent].
	^#rejected! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:43'!
dispatchEvent: anEvent with: aMorph
	"Dispatch the given event for a morph that has chosen the receiver to dispatch its events. The method implements a shortcut for repeated dispatches of events using the same dispatcher."
	anEvent type == lastType ifTrue:[^self perform: lastDispatch with: anEvent with: aMorph].
	"Otherwise classify"
	lastType _ anEvent type.
	anEvent isMouse ifTrue:[
		anEvent isMouseDown ifTrue:[
			lastDispatch _ #dispatchMouseDown:with:.
			^self dispatchMouseDown: anEvent with: aMorph]].
	anEvent type == #dropEvent ifTrue:[
		lastDispatch _ #dispatchDropEvent:with:.
		^self dispatchDropEvent: anEvent with: aMorph].
	lastDispatch _ #dispatchDefault:with:.
	^self dispatchDefault: anEvent with: aMorph! !

!MorphicEventDispatcher methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:14'!
dispatchMouseDown: anEvent with: aMorph
	"Find the appropriate receiver for the event and let it handle it. Default rules:
	* The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event.
	* When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is.
	* When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed.
	* If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event.
"
	| globalPt localEvt index child morphs handler inside lastHandler |
	"Try to get out quickly"
	globalPt _ anEvent cursorPoint.
	(aMorph fullBounds containsPoint: globalPt) ifFalse:[^#rejected].

	"Install the prospective handler for the receiver"
	lastHandler _ anEvent handler. "in case the mouse wasn't even in the receiver"
	handler _ aMorph handlerForMouseDown: anEvent.
	handler ifNotNil:[anEvent handler: handler].

	"Now give our submorphs a chance to handle the event"
	index _ 1.
	morphs _ aMorph submorphs.
	[index <= morphs size] whileTrue:[
		child _ morphs at: index.
		localEvt _ anEvent transformedBy: (child transformedFrom: aMorph).
		(child processEvent: localEvt using: self) == #rejected ifFalse:[
			"Some child did contain the point so we're part of the top-most chain."
			inside _ false.
			localEvt wasHandled ifTrue:[anEvent copyHandlerState: localEvt].
			index _ morphs size].
		index _ index + 1.
	].

	(inside == false or:[aMorph containsPoint: anEvent cursorPoint event: anEvent]) ifTrue:[
		"Receiver is in the top-most unlocked, visible chain."
		handler ifNotNil:[handler handleEvent: anEvent].
		"Note: Re-installing the handler is not really necessary but good style."
		anEvent handler: lastHandler.
		^self
	].
	"Mouse was not on receiver nor any of its children"
	anEvent handler: lastHandler.
	^#rejected! !
Object subclass: #MorphicEventEncoder
	instanceVariableNames: 'connection lastEventSent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!MorphicEventEncoder commentStamp: '<historical>' prior: 0!
A filter which translates MorphEvent's into StringArray's.!


!MorphicEventEncoder methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:38'!
connection: aConnection
	connection := aConnection! !


!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/24/2000 21:42'!
flush
	connection flush! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/24/2000 21:38'!
processIO
	connection processIO! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'RAA 12/13/2000 08:19'!
requestBufferedConnection
	"request the opposite side to send complete screen updates rather than discrete drawing commands"
	
	connection nextPut: { 'beginBuffering' }
! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 3/26/2000 01:08'!
sendEvent: anEvent
	(anEvent isMouseMove and: [ anEvent = lastEventSent ]) ifTrue: [
		"save on network traffic--don't send duplicate mouse moves"
		^self ].
	lastEventSent := anEvent.
	connection nextPut: #('event'), anEvent encodedAsStringArray! !

!MorphicEventEncoder methodsFor: 'network I/O' stamp: 'ls 4/11/2000 18:59'!
sendViewExtent: newExtent
	"inform the opposite side that our view extent has changed"
	
	connection nextPut: { 'viewExtent'. CanvasEncoder encodePoint: newExtent }
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicEventEncoder class
	instanceVariableNames: ''!

!MorphicEventEncoder class methodsFor: 'instance creation' stamp: 'ls 3/24/2000 21:43'!
on: aStringArray
	^self basicNew connection: aStringArray! !
BorderedMorph subclass: #MorphicModel
	instanceVariableNames: 'model slotName open '
	classVariableNames: 'TimeOfError '
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MorphicModel commentStamp: '<historical>' prior: 0!
MorphicModels are used to represent structures with state and behavior as well as graphical structure.  A morphicModel is usually the root of a morphic tree depicting its appearance.  The tree is constructed concretely by adding its consituent morphs to a world.

When a part is named in a world, it is given a new slot in the model.  When a part is sensitized, it is named, and a set of mouse-driven methods is also generated in the model.  These may be edited to induce particular behavior.  When a variable is added through the morphic world, it is given a slot in the model, along with a set of access methods.

In addition for public variables (and this is the default for now), methods are generated and called in any outer model in which this model gets embedded, thus propagating variable changes outward.!


!MorphicModel methodsFor: 'initialization' stamp: 'sw 5/4/1999 14:34'!
delete

	(model isKindOf: MorphicModel) ifFalse: [^ super delete].

	slotName ifNotNil:
		[(PopUpMenu confirm:
'Shall I remove the slot ', slotName, '
along with all associated methods?') ifTrue: [
		(model class selectors select: [:s | s beginsWith: slotName])
			do: [:s | model class removeSelector: s].
		(model class instVarNames includes: slotName)
			ifTrue: [model class removeInstVarName: slotName].
	] ifFalse: [
		(PopUpMenu confirm:
'...but should I at least dismiss this morph?
[choose no to leave everything unchanged]')
			ifFalse: [^ self]]].

	super delete.
! !

!MorphicModel methodsFor: 'initialization' stamp: 'tk 4/15/97'!
duplicate: newGuy from: oldGuy
	"oldGuy has just been duplicated and will stay in this world.  Make sure all the MorphicModel requirements are carried out for the copy.  Ask user to rename it.  "

	newGuy installModelIn: oldGuy world.
	newGuy copySlotMethodsFrom: oldGuy slotName.! !

!MorphicModel methodsFor: 'initialization' stamp: 'di 7/17/97 10:32'!
initialize
	super initialize.
	open _ false.
	bounds _ 0@0 corner: 200@100.
	self color: Color transparent;
		setBorderWidth: 2 borderColor: Color yellow! !

!MorphicModel methodsFor: 'initialization' stamp: 'jm
 8/20/1998 09:08'!
model: anObject
	"Set my model and make me me a dependent of the given object."

	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model _ anObject.
! !

!MorphicModel methodsFor: 'initialization' stamp: 'di 6/21/97 13:25'!
model: thang slotName: nameOfThisPart
	model _ thang.
	slotName _ nameOfThisPart.
	open _ false.! !


!MorphicModel methodsFor: 'access' stamp: 'ar 10/6/2000 19:21'!
allKnownNames
	"Answer a list of all the names of all named objects borne in my instance variable values"

	^ super allKnownNames, (self instanceVariableValues select: [:e | (e ~~ nil) and: [e knownName ~~ nil]] thenCollect: [:e | e knownName])! !

!MorphicModel methodsFor: 'access'!
model 
	^ model! !

!MorphicModel methodsFor: 'access' stamp: 'sw 10/23/1999 22:36'!
modelOrNil
	^ model! !

!MorphicModel methodsFor: 'access'!
slotName
	^ slotName! !

!MorphicModel methodsFor: 'access' stamp: '6/7/97 10:40 di'!
wantsSlot
	"Override this default for models that want to be installed in theri model"
	^ false! !


!MorphicModel methodsFor: 'geometry'!
newBounds: newBounds
	self bounds: newBounds! !

!MorphicModel methodsFor: 'geometry'!
recomputeBounds

	| bnds |
	bnds _ submorphs first bounds.
	bounds _ bnds origin corner: bnds corner. "copy it!!"
	fullBounds _ nil.
	bounds _ self fullBounds.
! !


!MorphicModel methodsFor: 'printing'!
initString

	^ String streamContents:
		[:s | s nextPutAll: self class name;
			nextPutAll: ' newBounds: (';
			print: bounds;
			nextPutAll: ') model: self slotName: ';
			print: slotName]! !


!MorphicModel methodsFor: 'compilation'!
addPartNameLike: className withValue: aMorph
	| otherNames i default partName stem |
	stem _ className first asLowercase asString , className allButFirst.
	otherNames _ self class allInstVarNames.
	i _ 1.
	[otherNames includes: (default _ stem, i printString)]
		whileTrue: [i _ i + 1].
	partName _ FillInTheBlank
		request: 'Please give this part a name'
		initialAnswer: default.
	(otherNames includes: partName)
		ifTrue: [self inform: 'Sorry, that name is already used'. ^ nil].
	self class addInstVarName: partName.
	self instVarAt: self class instSize put: aMorph.  "Assumes added as last field"
	^ partName! !

!MorphicModel methodsFor: 'compilation' stamp: 'sw 4/28/1998 00:21'!
assureNameFor: anObject
	| aName |
	(aName _ self nameFor: anObject) ifNotNil: [^ aName].
	^ self namePartSilently: anObject! !

!MorphicModel methodsFor: 'compilation' stamp: 'tk 4/15/97'!
choosePartName
	"When I am renamed, get a slot, make default methods, move any existing methods.  ** Does not clean up old inst var name or methods**  "

	| old |
	old _ slotName.
	super choosePartName.
	slotName ifNil: [^ self].  "user chose bad slot name"
	self model: self world model slotName: slotName.
	old == nil 
		ifTrue: [self compilePropagationMethods]
		ifFalse: [self copySlotMethodsFrom: old].
			"old ones not erased!!"! !

!MorphicModel methodsFor: 'compilation' stamp: 'tk 4/18/97'!
compileAccessForSlot: aSlotName
	"Write the method to get at this inst var.  "
	"Instead call the right thing to make this happen?"

	| s  |
	s _ WriteStream on: (String new: 2000).
	s nextPutAll: aSlotName; cr; tab; nextPutAll: '^', aSlotName.
	self class
		compile: s contents
		classified: 'public access'
		notifying: nil.
! !

!MorphicModel methodsFor: 'compilation'!
compileInitMethods
	| s nodeDict varNames |
	nodeDict _ IdentityDictionary new.
	s _ WriteStream on: (String new: 2000).
	varNames _ self class allInstVarNames.
	s nextPutAll: 'initMorph'.
	3 to: self class instSize do:
		[:i | (self instVarAt: i) isMorph ifTrue:
			[s cr; tab; nextPutAll: (varNames at: i) , ' _ '.
			s nextPutAll: (self instVarAt: i) initString; nextPutAll: '.'.
			nodeDict at: (self instVarAt: i) put: (varNames at: i)]].
	submorphs do: 
		[:m | s cr; tab; nextPutAll: 'self addMorph: '.
		m printConstructorOn: s indent: 1 nodeDict: nodeDict.
		s nextPutAll: '.'].
	self class
		compile: s contents
		classified: 'initialization'
		notifying: nil.! !

!MorphicModel methodsFor: 'compilation'!
compilePropagationMethods
	| varName |
	(self class organization listAtCategoryNamed: 'private - propagation' asSymbol)
		do: [:sel | varName _ sel allButLast.
			model class compilePropagationForVarName: varName slotName: slotName]! !

!MorphicModel methodsFor: 'compilation' stamp: '6/7/97 10:43 di'!
installModelIn: aWorld

	self wantsSlot ifFalse: [^ self].  "No real need to install"
	slotName _ aWorld model addPartNameLike: self class name withValue: self.
	slotName ifNil: [^ self].  "user chose bad slot name"
	self model: aWorld model slotName: slotName.
	self compilePropagationMethods.
	aWorld model compileAccessForSlot: slotName.
! !

!MorphicModel methodsFor: 'compilation' stamp: 'sw 11/1/97 00:41'!
instanceVariableValues
	"MorphicModel76 someInstance instanceVariableValues"
	| c |
	c _ OrderedCollection new.
	self class superclass instSize + 1 to: self class instSize do:
		[:i | c add: (self instVarAt: i)].
	^ c! !

!MorphicModel methodsFor: 'compilation'!
nameFor: aMorph
	"Return the name of the slot containing the given morph or nil if that morph has not been named."

	| allNames start |
	allNames _ self class allInstVarNames.
	start _ MorphicModel allInstVarNames size + 1.
	start to: allNames size do: [:i |
		(self instVarAt: i) == aMorph ifTrue: [^ allNames at: i]].
	^ nil
! !

!MorphicModel methodsFor: 'compilation' stamp: 'sw 1/29/98 21:44'!
namePartSilently: anObject

	| stem otherNames i partName |
	stem _ anObject class name.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString, stem allButFirst.
	otherNames _ self class allInstVarNames.
	i _ 1.
	[otherNames includes: (partName _ stem, i printString)]
		whileTrue: [i _ i + 1].
	self class addInstVarName: partName.
	self instVarAt: self class instSize put: anObject.  "assumes added as last field"

	self class compileAccessorsFor: partName.
	^ partName! !

!MorphicModel methodsFor: 'compilation'!
propagate: value as: partStoreSelector
	model ifNil: [^ self].
"
	Later we can cache this for more speed as follows...
	(partName == cachedPartName and: [slotName == cachedSlotName])
		ifFalse: [cachedPartName _ partName.
				cachedSlotName _ slotName.
				cachedStoreSelector _ (slotName , partStoreSelector) asSymbol].
	model perform: cachedStoreSelector with: value].
"
	model perform: (self slotSelectorFor: partStoreSelector) with: value! !

!MorphicModel methodsFor: 'compilation' stamp: 'tk 10/31/97 12:33'!
removeAll
	"Clear out all script methods and subpart instance variables in me.  Start over."
	"self removeAll"
	"MorphicModel2 removeAll"

self class == MorphicModel ifTrue: [^ self].	"Must be a subclass!!"
self class removeCategory: 'scripts'.
self class instVarNames do: [:nn | self class removeInstVarName: nn].! !

!MorphicModel methodsFor: 'compilation'!
slotSelectorFor: selectorBody
	| selector |
	model ifNil: [^ nil].
	"Make up selector from slotname if any"
	selector _ (slotName ifNil: [selectorBody]
					ifNotNil: [slotName , selectorBody]) asSymbol.
	(model canUnderstand: selector) ifFalse:
		[self halt: 'Compiling a null response for ' , model class name , '>>' , selector].
	^ selector! !

!MorphicModel methodsFor: 'compilation'!
use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock
	| selector |
	model ifNil: [^ nil].
	cachedSelector ifNil:
			["Make up selector from slotname if any"
			selector _ (slotName ifNil: [selectorBody]
								ifNotNil: [slotName , selectorBody]) asSymbol.
			(model class canUnderstand: selector) ifFalse:
				[(self confirm: 'Shall I compile a null response for'
							, Character cr asString
							, model class name , '>>' , selector)
						ifFalse: [self halt].
				model class compile: (String streamContents:
								[:s | selector keywords doWithIndex:
										[:k :i | s nextPutAll: k , ' arg' , i printString].
								s cr; nextPutAll: '"Automatically generated null response."'.
								s cr; nextPutAll: '"Add code below for appropriate behavior..."'.])
							classified: 'input events'
							notifying: nil]]
		ifNotNil:
			[selector _ cachedSelector].
	^ selectorBlock value: selector! !


!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:17'!
allowSubmorphExtraction
	^ self isOpen
! !

!MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'!
isOpen
	"Support drag/drop and other edits."
	^ open! !


!MorphicModel methodsFor: 'menu' stamp: 'sw 10/5/1998 14:55'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph].
	self isOpen ifTrue: [aCustomMenu add: 'close editing' action: #closeToEdits]
			ifFalse: [aCustomMenu add: 'open editing' action: #openToEdits].
! !

!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!
closeToEdits
	"Disable this morph's ability to add and remove morphs via drag-n-drop."

	open _ false
! !

!MorphicModel methodsFor: 'menu' stamp: 'di 6/20/97 15:36'!
openToEdits
	"Enable this morph's ability to add and remove morphs via drag-n-drop."

	open _ true
! !


!MorphicModel methodsFor: 'testing' stamp: 'ar 10/5/2000 16:40'!
isMorphicModel
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicModel class
	instanceVariableNames: 'prototype '!

!MorphicModel class methodsFor: 'instance creation' stamp: 'di 2/21/98 11:01'!
includeInNewMorphMenu
	"Only include Models that are appropriate"
	^ false! !

!MorphicModel class methodsFor: 'instance creation' stamp: 'tk 8/13/1998 12:58'!
new
	"Return a copy of the prototype, if there is one.
	Otherwise create a new instance normally."

	self hasPrototype ifTrue: [^ prototype veryDeepCopy].
	^ super new
! !

!MorphicModel class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:27'!
newBounds: bounds model: thang slotName: nameOfThisPart
	^ (super new model: thang slotName: nameOfThisPart)
		newBounds: bounds! !


!MorphicModel class methodsFor: 'compilation' stamp: 'sw 5/13/1998 14:33'!
acceptsLoggingOfCompilation
	"Dont log sources for my automatically-generated subclasses.  Can easily switch this back when it comes to deal with Versions, etc."

	^ self == MorphicModel or: [(name last isDigit) not]! !

!MorphicModel class methodsFor: 'compilation' stamp: 'tk 3/10/98 18:03'!
categoryForSubclasses
	^ 'Morphic-Models'! !

!MorphicModel class methodsFor: 'compilation'!
chooseNewName
	"Rename this class."
	| oldName newName |
	oldName _ self name.
		[newName _ (FillInTheBlank request: 'Please give this Model a name'
					initialAnswer: oldName) asSymbol.
		newName = oldName ifTrue: [^ self].
		Smalltalk includesKey: newName]
		whileTrue:
		[PopUpMenu notify: 'Sorry, that name is already in use.'].
	self rename: newName.! !

!MorphicModel class methodsFor: 'compilation'!
compileAccessorsFor: varName
	self compile: (
'&var
	"Return the value of &var"
	^ &var'
			copyReplaceAll: '&var' with: varName)
		classified: 'public access' notifying: nil.
	self compile: (
'&varPut: newValue
	"Assign newValue to &var.
	Add code below to update related graphics appropriately..."

	&var _ newValue.'
			copyReplaceAll: '&var' with: varName)
		classified: 'public access' notifying: nil.
	self compile: (
'&var: newValue
	"Assigns newValue to &var and updates owner"
	&var _ newValue.
	self propagate: &var as: ''&var:'''
			copyReplaceAll: '&var' with: varName)
		classified: 'private - propagation' notifying: nil.
! !

!MorphicModel class methodsFor: 'compilation'!
compilePropagationForVarName: varName slotName: slotName
	self compile: ((
'&slot&var: newValue
	"The value of &var in &slot has changed to newValue.
	This value can be read elsewhere in code with
		&slot &var
	and it can be stored into with
		&slot &varPut: someValue"

	"Add code for appropriate response here..."'
			copyReplaceAll: '&var' with: varName)
			copyReplaceAll: '&slot' with: slotName)
		classified: 'input events' notifying: nil.
! !

!MorphicModel class methodsFor: 'compilation'!
newSubclass
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [i _ i + 1].

	^ self subclass: className
		instanceVariableNames: ''
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Morphic-Models'! !

!MorphicModel class methodsFor: 'compilation' stamp: 'tk 3/15/98 20:13'!
officialClass
	"We want to make a new instance of the receiver, which is a subclass of MorphicModel.  Answer who to make a new subclass of.  Also used to tell if a given class is a UniClass, existing only for its single instance."

	^ self name last isDigit ifTrue: [MorphicModel] ifFalse: [self]
		"MorphicModel7 can not have subclasses, but Slider and SystemWindow may"! !

!MorphicModel class methodsFor: 'compilation' stamp: 'sw 8/4/97 17:16'!
wantsChangeSetLogging
	"Log changes for MorphicModel itself and for things like PlayWithMe2, but not for automatically-created subclasses like MorphicModel1, MorphicModel2, etc."

	^ self == MorphicModel or:
		[(self class name beginsWith: 'Morphic') not]! !


!MorphicModel class methodsFor: 'queries'!
hasPrototype
	"Return true if there is a prototype for this morph."

	^ prototype ~~ nil
! !


!MorphicModel class methodsFor: 'prototype access'!
prototype
	"Return the prototype for this morph."

	^ prototype
! !

!MorphicModel class methodsFor: 'prototype access' stamp: 'tk 8/13/1998 12:58'!
prototype: aMorph
	"Store a copy of the given morph as a prototype to be copied to make new instances."

	aMorph ifNil: [prototype _ nil. ^ self].

	prototype _ aMorph veryDeepCopy.
	(prototype isKindOf: MorphicModel) ifTrue: 
		[prototype model: nil slotName: nil].
! !


!MorphicModel class methodsFor: 'housekeeping' stamp: 'jm 7/30/97 16:40'!
removeUninstantiatedModels
	"With the user's permission, remove the classes of any models that have neither instances nor subclasses."
	"MorphicModel removeUninstantiatedModels"

	| candidatesForRemoval ok |
	Smalltalk garbageCollect.
	candidatesForRemoval _
		MorphicModel subclasses select: [:c |
			(c instanceCount = 0) and: [c subclasses size = 0]].
	candidatesForRemoval do: [:c |
		ok _ self confirm: 'Are you certain that you
want to delete the class ', c name, '?'.
		ok ifTrue: [c removeFromSystem]].
! !
MorphicModel subclass: #MorphicModel2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!
MorphicModel subclass: #MorphicModel3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!
MorphicModel subclass: #MorphicModel4
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!
DisplayTransform subclass: #MorphicTransform
	instanceVariableNames: 'offset angle scale '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Transformations'!
!MorphicTransform commentStamp: '<historical>' prior: 0!
This class implements simple translation, scaling and rotation for points, as well as inverse transformations.  These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.!


!MorphicTransform methodsFor: 'accessing'!
angle
	^ angle! !

!MorphicTransform methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:33'!
inverseTransformation
	"Return the inverse transformation of the receiver"
	^MorphicTransform
		offset: (self transform: 0@0) - (self transform: offset)
		angle: angle negated
		scale: scale reciprocal! !

!MorphicTransform methodsFor: 'accessing'!
offset
	^ offset
! !

!MorphicTransform methodsFor: 'accessing'!
scale
	^ scale! !

!MorphicTransform methodsFor: 'accessing'!
withAngle: a
	"Return a copy of me with a different Angle"
	^ self copy setAngle: a! !

!MorphicTransform methodsFor: 'accessing'!
withOffset: a
	"Return a copy of me with a different Offset"
	^ self copy setOffset: a! !

!MorphicTransform methodsFor: 'accessing'!
withScale: a
	"Return a copy of me with a different Scale"
	^ self copy setScale: a! !


!MorphicTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:10'!
composedWith: aTransform
	"Return a new transform that has the effect of transforming points first by the receiver and then by the argument."

	self isIdentity ifTrue: [^ aTransform].
	aTransform isIdentity ifTrue: [^ self].
	^ CompositeTransform new globalTransform: self
							localTransform: aTransform! !

!MorphicTransform methodsFor: 'transformations' stamp: 'ar 11/21/2000 17:36'!
composedWithLocal: aTransform
	aTransform isIdentity ifTrue:[^self].
	self isIdentity ifTrue:[^aTransform].
	aTransform isMorphicTransform ifFalse:[^super composedWithLocal: aTransform].
	self isPureTranslation ifTrue:[
		^aTransform withOffset: aTransform offset - self offset].
	aTransform isPureTranslation ifTrue:[
		^self withOffset: (self localPointToGlobal: aTransform offset negated) negated].
	^super composedWithLocal: aTransform.! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:10'!
invert: aPoint
	"Transform the given point from local to global coordinates."
	| p3 p2 |
	self isPureTranslation ifTrue: [^ aPoint - offset].
	p3 _  aPoint * scale.
	p2 _ ((p3 x * angle cos) + (p3 y * angle sin))
		@ ((p3 y * angle cos) - (p3 x * angle sin)).
	^ (p2 - offset)
! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'!
invertBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from local back to global coordinates.  NOTE: if the transformation
	is not just a translation, then it will compute the bounding box
	in global coordinates."
	| outerRect |
	self isPureTranslation
	ifTrue:
		[^ (self invert: aRectangle topLeft)
			corner: (self invert: aRectangle bottomRight)]
	ifFalse:
		[outerRect _ Rectangle encompassing:
			(aRectangle innerCorners collect: [:p | self invert: p]).
		"Following asymmetry due to likely subsequent truncation"
		^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/2/1998 08:54'!
invertRect: aRectangle

	self error: 'method name changed to emphasize enclosing bounds'.
	^ self invertBoundsRect: aRectangle! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:05'!
transform: aPoint
	"Transform the given point from global to local coordinates."
	| p2 p3 |
	self isPureTranslation ifTrue: [^ aPoint + offset].
	p2 _ aPoint + offset.
	p3 _ (((p2 x * angle cos) - (p2 y * angle sin))
		@ ((p2 y * angle cos) + (p2 x * angle sin)))
			/ scale.
	^ p3! !

!MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'!
transformBoundsRect: aRectangle
	"Return a rectangle whose coordinates have been transformed
	from global to local coordinates.  NOTE: if the transformation
	is not just a translation, then it will compute the bounding box
	in global coordinates."
	| outerRect |
	self isPureTranslation
	ifTrue:
		[^ (self transform: aRectangle topLeft)
			corner: (self transform: aRectangle bottomRight)]
	ifFalse:
		[outerRect _ Rectangle encompassing:
			(aRectangle innerCorners collect: [:p | self transform: p]).
		"Following asymmetry due to likely subsequent truncation"
		^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! !


!MorphicTransform methodsFor: 'private'!
setAngle: aFloat

	angle _ aFloat.
! !

!MorphicTransform methodsFor: 'private'!
setOffset: aPoint

	offset _ aPoint.
! !

!MorphicTransform methodsFor: 'private'!
setOffset: aPoint angle: a scale: s

	offset _ aPoint.
	angle _ a.
	scale _ s! !

!MorphicTransform methodsFor: 'private'!
setScale: aFloat

	scale _ aFloat.
! !


!MorphicTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 20:58'!
setIdentiy
	scale _ 1.0.
	offset _ 0@0.
	angle _ 0.0.! !


!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'!
isIdentity
	"Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself."

	^ self isPureTranslation and: [offset = (0@0)]
! !

!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 19:51'!
isMorphicTransform
	^true! !

!MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'!
isPureTranslation
	"Return true if the receiver specifies no rotation or scaling."

	^ angle = 0.0 and: [scale = 1.0]
! !


!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:13'!
globalPointToLocal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self transform: aPoint! !

!MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:32'!
localPointToGlobal: aPoint
	"Transform aPoint from global coordinates into local coordinates"
	^self invert: aPoint! !


!MorphicTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:14'!
asMatrixTransform2x3
	^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal:
		(MatrixTransform2x3 withScale: scale))
			offset: offset negated! !

!MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'!
asMorphicTransform

	^ self! !


!MorphicTransform methodsFor: 'printing' stamp: 'ar 5/19/1999 18:21'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'angle = '; print: angle;
		nextPutAll:'; scale = '; print: scale;
		nextPutAll:'; offset = '; print: offset;
		nextPut:$).! !


!MorphicTransform methodsFor: 'encoding' stamp: 'ls 10/9/1999 19:06'!
encodeForRemoteCanvas
	"encode this transform into a string for use by a RemoteCanvas"
	^String streamContents: [ :str |
		str nextPutAll: 'Morphic,';
			print: offset x truncated;
			nextPut: $,;
			print: offset y truncated;
			nextPut: $,;
			print: scale;
			nextPut: $,;
			print: angle
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MorphicTransform class
	instanceVariableNames: ''!

!MorphicTransform class methodsFor: 'instance creation' stamp: 'ls 3/27/2000 22:15'!
fromRemoteCanvasEncoding: encoded
	"DisplayTransform fromRemoteCanvasEncoding:  'Morphic,-88,-128,1.345165663873898,0.1352584843149221'"
	| type offsetXEnc offsetYEnc scaleEnc angleEnc offsetX offsetY angle scale rs |

	"separate the numbers"
	rs := ReadStream on: encoded.
	type := rs upTo: $,.
	offsetXEnc := rs upTo: $,.
	offsetYEnc := rs upTo: $,.
	scaleEnc := rs upTo: $,.
	angleEnc := rs upToEnd.

	"decode the numbers"
	offsetX _ Integer readFromString: offsetXEnc.
	offsetY _ Integer readFromString: offsetYEnc.

	scale _ Number readFromString: scaleEnc.
	angle _ Number readFromString: angleEnc.

	"create an instance"
	^self offset: offsetX@offsetY angle: angle scale: scale! !

!MorphicTransform class methodsFor: 'instance creation'!
identity

	^ self offset: 0@0 angle: 0.0 scale: 1.0! !

!MorphicTransform class methodsFor: 'instance creation'!
new

	^ self offset: 0@0
! !

!MorphicTransform class methodsFor: 'instance creation'!
offset: aPoint

	^ self offset: aPoint angle: 0.0 scale: 1.0! !

!MorphicTransform class methodsFor: 'instance creation'!
offset: aPoint angle: a scale: s

	^ self basicNew setOffset: aPoint angle: a scale: s! !
MorphicEvent subclass: #MorphicUnknownEvent
	instanceVariableNames: 'type argument '
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants '
	category: 'Morphic-Events'!

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'!
argument
	^argument! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'!
argument: arg
	argument _ arg! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'!
position
	^0@0! !

!MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'!
type
	^type! !


!MorphicUnknownEvent methodsFor: 'printing' stamp: 'ar 10/26/2000 01:19'!
storeOn: aStream
	aStream nextPutAll: 'unknown'.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	{type. argument} storeOn: aStream.! !


!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:59'!
setType: evtType argument: arg
	type _ evtType.
	argument _ arg.! !

!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:58'!
setType: evtType argument: arg hand: evtHand stamp: stamp
	type _ evtType.
	argument _ arg.
	source _ evtHand.
	timeStamp _ stamp.! !

!MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/26/2000 01:20'!
type: eventType readFrom: aStream
	| typeAndArg |
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	typeAndArg _ Object readFrom: aStream.
	type _ typeAndArg first.
	argument _ typeAndArg last.! !


!MorphicUnknownEvent methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	type ifNil: [type _ #startSound].
	source ifNil: [source _ varDict at: 'sourceHand'].
	argument ifNil: [argument _ varDict at: 'sound' ifAbsent: [nil]].	"???"
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !
Morph subclass: #MouseActionIndicatorMorph
	instanceVariableNames: 'siblings '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!MouseActionIndicatorMorph commentStamp: '<historical>' prior: 0!
I am used to highlight morphs which have a special mouseup action!


!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:49'!
deleteWithSiblings

	siblings do: [ :each | each delete]
! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:48'!
handlesMouseOver: evt

	^true! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:52'!
handlesMouseOverDragging: evt

	^true! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:48'!
initialize

	super initialize.
	siblings _ #().! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:50'!
mouseEnter: evt

	self deleteWithSiblings
! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/17/2000 09:52'!
mouseEnterDragging: evt

	self deleteWithSiblings
! !

!MouseActionIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:49'!
siblings: aCollection

	siblings _ aCollection.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MouseActionIndicatorMorph class
	instanceVariableNames: ''!

!MouseActionIndicatorMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 11:08'!
world: aWorld inner: innerRectangle outer: outerRectangle color: aColor

	| allRects allMorphs |

	allRects _ outerRectangle areasOutside: innerRectangle.
	allMorphs _ allRects collect: [ :each |
		self new bounds: each; color: aColor
	].
	allMorphs do: [ :each |
		each siblings: allMorphs; openInWorld: aWorld
	].
	^allMorphs


! !
MouseEvent subclass: #MouseButtonEvent
	instanceVariableNames: 'whichButton '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseButtonEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'!
setType: evtType position: evtPos which: button buttons: evtButtons hand: evtHand stamp: stamp
	type _ evtType.
	position _ evtPos.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.
	whichButton _ button.
	timeStamp _ stamp.! !

!MouseButtonEvent methodsFor: 'private' stamp: 'ar 10/24/2000 16:29'!
type: eventType readFrom: aStream
	super type: eventType readFrom: aStream.
	aStream skip: 1.
	whichButton _ Integer readFrom: aStream.! !


!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'!
blueButtonChanged
	"Answer true if the blue mouse button has changed. This is the third mouse button or cmd+click on the Mac."

	^ whichButton anyMask: 1! !

!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:58'!
redButtonChanged
	"Answer true if the red mouse button has changed. This is the first mouse button."

	^ whichButton anyMask: 4! !

!MouseButtonEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 19:59'!
yellowButtonChanged
	"Answer true if the yellow mouse button has changed. This is the second mouse button or option+click on the Mac."

	^ whichButton anyMask: 2! !


!MouseButtonEvent methodsFor: 'dispatching' stamp: 'ar 9/16/2000 13:05'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseDown ifTrue:[^anObject handleMouseDown: self].
	type == #mouseUp ifTrue:[^anObject handleMouseUp: self].
	^super sentTo: anObject! !


!MouseButtonEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:29'!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	whichButton storeOn: aStream.! !


!MouseButtonEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:31'!
decodeFromStringArray: array
	"decode the receiver from an array of strings"
	type _ array first asSymbol.
	position _ CanvasDecoder decodePoint: (array at: 2).
	buttons _ CanvasDecoder decodeInteger: (array at: 3).
	whichButton _ CanvasDecoder decodeInteger: (array at: 4).
! !

!MouseButtonEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:24'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodeInteger: whichButton.
	}! !
Object subclass: #MouseClickState
	instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dragSelector dragThreshold '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!
!MouseClickState commentStamp: '<historical>' prior: 0!
MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars.

Instance variables:
	clickClient 	<Morph>		The client wishing to receive #click:, #dblClick:, or #drag messages
	clickState 	<Symbol>	The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut)
	firstClickDown 	<MorphicEvent>	The #mouseDown event after which the client wished to receive #click: or similar messages
	firstClickUp 	<MorphicEvent>	The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured)
	firstClickTime 	<Integer>	The millisecond clock value of the first event
	clickSelector 	<Symbol>	The selector to use for sending #click: messages
	dblClickSelector 	<Symbol>	The selector to use for sending #doubleClick: messages
	dblClickTime 	<Integer>	Timout in milliseconds for a double click operation
	dragSelector 	<Symbol>	The selector to use for sending #drag: messages
	dragThreshold 	<Integer>	Threshold used for determining if a #drag: message is sent (pixels!!)
!


!MouseClickState methodsFor: 'initialize' stamp: 'ar 9/18/2000 18:22'!
client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut drag: aDragSelector threshold: aNumber event: firstClickEvent
	clickClient _ aMorph.
	clickSelector _ aClickSelector.
	dblClickSelector _ aDblClickSelector.
	dblClickTime _ timeOut.
	dragSelector _ aDragSelector.
	dragThreshold _ aNumber.
	firstClickDown _ firstClickEvent.
	firstClickTime _ firstClickEvent timeStamp.
	clickState _ #firstClickDown.! !

!MouseClickState methodsFor: 'initialize' stamp: 'ar 10/9/2000 19:08'!
handleEvent: evt from: aHand
	"Process the given mouse event to detect a click, double-click, or drag.
	Return true if the event should be processed by the sender, false if it shouldn't.
	NOTE: This method heavily relies on getting *all* mouse button events."
	| localEvt timedOut isDrag |
	timedOut _ (evt timeStamp - firstClickTime) > dblClickTime.
	localEvt _ evt transformedBy: (clickClient transformedFrom: aHand owner).
	isDrag _ (localEvt cursorPoint - firstClickDown cursorPoint) r > dragThreshold.
	clickState == #firstClickDown ifTrue: [
		"Careful here - if we had a slow cycle we may have a timedOut mouseUp event"
		(timedOut and:[localEvt isMouseUp not]) ifTrue:[
			"timeout before #mouseUp -> keep waiting for drag if requested"
			clickState _ #firstClickTimedOut.
			dragSelector ifNil:[
				aHand resetClickState.
				clickSelector ifNotNil:[clickClient perform: clickSelector with: firstClickDown]].
			^true].
		localEvt isMouseUp ifTrue:[
			"If timedOut or the client's not interested in dbl clicks get outta here"
			(timedOut or:[dblClickSelector isNil]) ifTrue:[
				aHand resetClickState.
				clickSelector ifNotNil:[clickClient perform: clickSelector with: firstClickDown].
				^true].
			"Otherwise transfer to #firstClickUp"
			firstClickUp _ evt copy.
			clickState _ #firstClickUp.
			^false].
		isDrag ifTrue:["drag start"
			aHand resetClickState.
			dragSelector == nil "If no drag selector send #click instead"
				ifTrue:[clickSelector ifNotNil:[clickClient perform: clickSelector with: firstClickDown]]
				ifFalse:[clickClient perform: dragSelector with: localEvt].
			^true].
		^false].

	clickState == #firstClickTimedOut ifTrue:[
		localEvt isMouseUp ifTrue:["neither drag nor double click"
			aHand resetClickState.
			clickSelector ifNotNil:[clickClient perform: clickSelector with: firstClickDown].
			^true].
		isDrag ifTrue:["drag start"
			aHand resetClickState.
			dragSelector ifNotNil:[clickClient perform: dragSelector with: localEvt].
			^true].
		^false].

	clickState = #firstClickUp ifTrue:[
		(timedOut) ifTrue:[
			"timed out after mouseUp - send #click: and mouseUp"
			aHand resetClickState.
			clickSelector ifNotNil:[clickClient perform: clickSelector with: firstClickDown].
			"Note: Using aHand handleEvent here (rather than clickClient handleMouseUp:) to be consistent with a timeout before firstClickUp in which case aHand would process the up event."
			aHand handleEvent: firstClickUp.
			^true].
		localEvt isMouseDown ifTrue:["double click"
			aHand resetClickState.
			dblClickSelector ifNotNil:[clickClient perform: dblClickSelector with: firstClickDown].
			^false]].
	^true! !

MouseSensorMorph subclass: #MouseDownMorph
	instanceVariableNames: 'mouseDownSelector mouseMoveSelector mouseUpSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!MouseDownMorph methodsFor: 'menu' stamp: 'sw 11/16/1998 08:22'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
"template..."
	aCustomMenu addLine.
	aCustomMenu add: 'set variable name...' action: #renameMe.
	aCustomMenu addLine.
	aCustomMenu add: 'plug mouseDown to model slot' action: #plugMouseDownToSlot.
	aCustomMenu add: 'plug mouseMove to model slot' action: #plugMouseMoveToSlot.
	aCustomMenu add: 'plug all to model slots' action: #plugAllToSlots.
	aCustomMenu addLine.
	aCustomMenu add: 'plug mouseDown to model' action: #plugMouseDownToModel.
	aCustomMenu add: 'plug mouseMove to model' action: #plugMouseMoveToModel.
	aCustomMenu add: 'plug all to model' action: #plugAllToModel.
	aCustomMenu addLine.
	aCustomMenu add: 'set target...' action: #setTarget.
	aCustomMenu add: 'set mouseDown selector...' action: #setMouseDownSelector.
	aCustomMenu add: 'set mouseMove selector...' action: #setMouseMoveSelector.
	aCustomMenu add: 'set mouseUp selector...' action: #setMouseUpSelector.
! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/16/98 08:13'!
plugAllToModel
	self plugMouseDownToModel; plugMouseMoveToSlot! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/16/98 08:13'!
plugAllToSlots
	self plugMouseDownToSlot; plugMouseMoveToSlot.
! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/25/1998 21:45'!
plugMouseDownToModel
	mouseDownSelector _ (self knownName , 'MouseDown:event:') asSymbol.
	model class compile: (

'&nameMouseDown: trueOrFalse event: event
	"A mouseDown event has occurred.
	Add code to handle it here below..."'

			copyReplaceAll: '&name' with: self knownName)
		classified: 'input events' notifying: nil! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/25/1998 21:45'!
plugMouseDownToSlot
	| varName |
	mouseDownSelector _ (self knownName , 'MouseDown:event:') asSymbol.
	varName _ self knownName , 'MouseDown'.
	model class addSlotNamed: varName.
	model class compile: (

'&name: trueOrFalse event: event
	"A mouseDown event has occurred.
	Add code to handle it here below..."
	&name _ trueOrFalse.'

			copyReplaceAll: '&name' with: varName)
		classified: 'input events' notifying: nil! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/25/1998 21:44'!
plugMouseMoveToModel
	mouseMoveSelector _ (self knownName , 'MouseMove:event:') asSymbol.
	model class compile: (

'&nameMouseMove: location event: event
	"A mouseMove event has occurred.
	Add code to handle it here below..."'

			copyReplaceAll: '&name' with: self knownName)
		classified: 'input events' notifying: nil! !

!MouseDownMorph methodsFor: 'menu' stamp: 'di 4/25/1998 21:44'!
plugMouseMoveToSlot
	| varName |
	mouseMoveSelector _ (self knownName , 'MouseMove:event:') asSymbol.
	varName _ self knownName , 'MouseMove'.
	model class addSlotNamed: varName.
	model class compile: (

'&name: location event: event
	"A mouseMove event has occurred.
	Add code to handle it here below..."
	&name _ location.'

			copyReplaceAll: '&name' with: varName)
		classified: 'input events' notifying: nil! !


!MouseDownMorph methodsFor: 'event handling' stamp: 'di 4/13/98 15:55'!
handlesMouseDown: evt

	^ model ~~ nil
! !

!MouseDownMorph methodsFor: 'event handling' stamp: 'di 4/17/1998 13:52'!
mouseDown: event
	"Relay a mouseDown event to my model."

	mouseDownSelector ifNotNil:
		[mouseDownSelector numArgs = 0
			ifTrue: [^ model perform: mouseDownSelector].
		mouseDownSelector numArgs = 1
			ifTrue: [^ model perform: mouseDownSelector with: event].
		mouseDownSelector numArgs = 2
			ifTrue: [^ model perform: mouseDownSelector with: true with: event].
		^ self error: 'mouseDownselector must take 0, 1, or 2 arguments']! !

!MouseDownMorph methodsFor: 'event handling' stamp: 'di 4/17/1998 14:11'!
mouseMove: event
	"Relay a mouseMove event to my model."

	mouseMoveSelector ifNotNil:
		[mouseMoveSelector numArgs = 0
			ifTrue: [^ model perform: mouseMoveSelector].
		mouseMoveSelector numArgs = 1
			ifTrue: [^ model perform: mouseMoveSelector with: event cursorPoint].
		mouseMoveSelector numArgs = 2
			ifTrue: [^ model perform: mouseMoveSelector with: event cursorPoint with: event].
		^ self error: 'mouseMoveSelector must take 0, 1, or 2 arguments']! !

!MouseDownMorph methodsFor: 'event handling' stamp: 'di 4/17/1998 13:53'!
mouseUp: event
	"Relay a mouseUp event to my model."

	mouseUpSelector ifNotNil:
		[mouseUpSelector numArgs = 0
			ifTrue: [^ model perform: mouseUpSelector].
		mouseUpSelector numArgs = 1
			ifTrue: [^ model perform: mouseUpSelector with: event].
		^ self error: 'mouseUpselector must take 0, or 1 argument'].
	mouseDownSelector ifNotNil:
		["Or send mouseDown: false..."
		mouseDownSelector numArgs = 2
			ifTrue: [^ model perform: mouseDownSelector with: false with: event].
		^ self error: 'mouseDownselector must take 2 arguments']! !
UserInputEvent subclass: #MouseEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseEvent methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:26'!
noticeMouseOver: aMorph
	source ifNotNil:[source noticeMouseOver: aMorph event: self].! !

!MouseEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'!
position
	^position! !


!MouseEvent methodsFor: 'testing' stamp: 'ar 10/5/2000 19:43'!
isDraggingEvent
	source ifNil:[^false].
	source hasSubmorphs ifTrue:[^true].
	self anyButtonPressed ifTrue:[^true].
	^false! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:30'!
isMouse
	^true! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseDown
	^self type == #mouseDown! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseEnter
	^self type == #mouseEnter! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseLeave
	^self type == #mouseLeave! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseMove
	^self type == #mouseMove! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'!
isMouseUp
	^self type == #mouseUp! !

!MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'!
isMove
	^false! !


!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:50'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	position = aMorphicEvent position ifFalse: [^ false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	^ true
! !

!MouseEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:47'!
hash
	^ position hash + buttons hash! !


!MouseEvent methodsFor: 'button state' stamp: 'ar 9/13/2000 15:38'!
anyButtonPressed
	"Answer true if any mouse button is being pressed."

	^ buttons anyMask: 7! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/13/2000 15:38'!
blueButtonPressed
	"Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac."

	^ buttons anyMask: 1! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/15/2000 22:51'!
cursorPoint
	"Answer the location of the cursor's hotspot when this event occured."

	^ position! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/13/2000 15:39'!
redButtonPressed
	"Answer true if the red mouse button is being pressed. This is the first mouse button."

	^ buttons anyMask: 4! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/15/2000 22:51'!
targetPoint
	"Answer the location of the cursor's hotspot, adjusted by the offset
	of the last mouseDown relative to the recipient morph."

	^ position - source targetOffset! !

!MouseEvent methodsFor: 'button state' stamp: 'ar 9/13/2000 15:40'!
yellowButtonPressed
	"Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac."

	^ buttons anyMask: 2! !



!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'!
asMouseEnter
	^self clone setType: #mouseEnter! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 10/10/2000 21:17'!
asMouseLeave
	^self clone setType: #mouseLeave! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 10/6/2000 18:59'!
asMouseMove
	"Convert the receiver into a mouse move"
	^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time millisecondClockValue.! !

!MouseEvent methodsFor: 'converting' stamp: 'ar 9/25/2000 14:29'!
asMouseOver
	"Convert the receiver into a mouse over event"
	^MouseEvent new setType: #mouseOver position: position buttons: buttons hand: source! !


!MouseEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseOver ifTrue:[^anObject handleMouseOver: self].
	type == #mouseEnter ifTrue:[^anObject handleMouseEnter: self].
	type == #mouseLeave ifTrue:[^anObject handleMouseLeave: self].
	^super sentTo: anObject.! !


!MouseEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 22:01'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self cursorPoint printString; space.
	aStream nextPutAll: type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream nextPutAll: timeStamp printString.
	aStream nextPut: $].! !

!MouseEvent methodsFor: 'printing' stamp: 'ar 10/25/2000 22:09'!
storeOn: aStream

	aStream nextPutAll: type.
	aStream space.
	self timeStamp storeOn: aStream.
	aStream space.
	position x storeOn: aStream.
	aStream space.
	position y storeOn: aStream.
	aStream space.
	buttons storeOn: aStream.! !


!MouseEvent methodsFor: 'private' stamp: 'ar 10/10/2000 21:15'!
setType: aSymbol
	"For quick conversion between event types"
	type _ aSymbol.! !

!MouseEvent methodsFor: 'private' stamp: 'ar 9/15/2000 22:53'!
setType: evtType position: evtPos buttons: evtButtons hand: evtHand
	type _ evtType.
	position _ evtPos.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.! !

!MouseEvent methodsFor: 'private' stamp: 'ar 10/25/2000 22:08'!
type: eventType readFrom: aStream
	| x y |
	type _ eventType.
	timeStamp _ Integer readFrom: aStream.
	aStream skip: 1.
	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	aStream skip: 1.
	buttons _ Integer readFrom: aStream.
	position _ x@y.
! !
Controller subclass: #MouseMenuController
	instanceVariableNames: 'redButtonMenu redButtonMessages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!MouseMenuController commentStamp: '<historical>' prior: 0!
I am a Controller that modifies the scheduling of user activities so that the three mouse buttons can be used to make selections or display menus. The menu items are unary messages to the value of sending my instance the message menuMessageReceiver.!


!MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'!
release
	super release.
	redButtonMenu release! !

!MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'!
reset
	"Eliminate references to all mouse button menus."

	redButtonMenu _ nil.
	redButtonMessages _ nil! !


!MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:28'!
controlActivity
	"Refer to the comment in Controller|controlActivity."
	| cursorPoint |
	cursorPoint _ sensor cursorPoint.
	super controlActivity.
	(cursorPoint = sensor cursorPoint and: [self viewHasCursor])
		ifTrue: 
			[sensor redButtonPressed ifTrue: [^ self redButtonActivity].
			sensor yellowButtonPressed ifTrue: [^ self yellowButtonActivity].
			sensor blueButtonPressed ifTrue: [^ self blueButtonActivity]]! !

!MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 11:24'!
isControlActive 
	"In contrast to class Controller, only blue button but not yellow button
	events will end the receiver's control loop."

	^ self viewHasCursor and: [sensor blueButtonPressed not]! !


!MouseMenuController methodsFor: 'menu setup'!
redButtonMenu: aSystemMenu redButtonMessages: anArray 
	"Initialize the pop-up menu that should appear when the user presses the 
	red mouse button to be aSystemMenu. The corresponding messages that 
	should be sent are listed in the array, anArray."

	redButtonMenu release.
	redButtonMenu _ aSystemMenu.
	redButtonMessages _ anArray! !


!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 15:01'!
blueButtonActivity
	"This normally opens the window menu. It is a no-op here
	as only the StandardSystemController deals with that kind
	of menus."! !

!MouseMenuController methodsFor: 'menu messages'!
performMenuMessage: aSelector
	"Perform a menu command by sending self the message aSelector.
	 Default does nothing special."

	^self perform: aSelector! !

!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:56'!
redButtonActivity
	"Determine which item in the red button pop-up menu is selected. If one 
	is selected, then send the corresponding message to the object designated 
	as the menu message receiver."

	| index |
	redButtonMenu ~~ nil
		ifTrue: 
			[index _ redButtonMenu startUp.
			index ~= 0 
				ifTrue: [self perform: (redButtonMessages at: index)]]
		ifFalse: [super controlActivity]! !

!MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:59'!
yellowButtonActivity
	"This normally opens a popup menu. Determine the selected
	item and, if one is selected, then send the corresponding message
	to either the model or the receiver."

	^ self pluggableYellowButtonActivity: sensor leftShiftDown! !


!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:36'!
getPluggableYellowButtonMenu: shiftKeyState
	^ view getMenu: shiftKeyState! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:38'!
pluggableYellowButtonActivity: shiftKeyState
	"Invoke the model's popup menu."

	| menu selector |
	(menu _ self getPluggableYellowButtonMenu: shiftKeyState)
		ifNil: [sensor waitNoButton]
		ifNotNil:
			[(selector _ menu startUp) ifNil: [^ self].
			self terminateAndInitializeAround: [model perform: selector orSendTo: self]]! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'!
shiftedYellowButtonActivity
	"Invoke the model's special popup menu."

	^ self pluggableYellowButtonActivity: true! !

!MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'!
unshiftedYellowButtonActivity
	"Invoke the model's normal popup menu."

	^ self pluggableYellowButtonActivity: false! !
MouseEvent subclass: #MouseMoveEvent
	instanceVariableNames: 'startPoint trail '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'!
endPoint
	"Return the point where the movement ended."
	^position! !

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:25'!
startPoint
	"Return the point where the movement started."
	^startPoint! !

!MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 10/24/2000 16:33'!
trail
	"Return any immediate points that have been assembled along the move"
	^trail ifNil:[#()]! !


!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'!
= aMorphicEvent
	super = aMorphicEvent ifFalse:[^false].
	position = aMorphicEvent position ifFalse: [^ false].
	startPoint = aMorphicEvent startPoint ifFalse: [^ false].
	buttons = aMorphicEvent buttons ifFalse: [^ false].
	^ true
! !

!MouseMoveEvent methodsFor: 'comparing' stamp: 'ar 9/15/2000 22:49'!
hash
	^ position hash + startPoint hash + buttons hash! !


!MouseMoveEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:29'!
isMove
	^true! !


!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.
	startPoint _  aMorphicTransform globalPointToLocal: startPoint.! !

!MouseMoveEvent methodsFor: 'transforming' stamp: 'ar 9/15/2000 22:52'!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position _ position + delta.
	startPoint _ startPoint + delta.! !


!MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 22:00'!
printOn: aStream

	aStream nextPut: $[.
	aStream nextPutAll: self startPoint printString; space.
	aStream nextPutAll: self endPoint printString; space.
	aStream nextPutAll: self type; space.
	aStream nextPutAll: self modifierString.
	aStream nextPutAll: self buttonString.
	aStream nextPutAll: timeStamp printString.
	aStream nextPut: $].! !

!MouseMoveEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:30'!
storeOn: aStream
	super storeOn: aStream.
	aStream space.
	self startPoint x storeOn: aStream.
	aStream space.
	self startPoint y storeOn: aStream.
	aStream space.
	"trail storeOn: aStream."! !


!MouseMoveEvent methodsFor: 'dispatching' stamp: 'ar 10/10/2000 21:15'!
sentTo: anObject
	"Dispatch the receiver into anObject"
	type == #mouseMove ifTrue:[^anObject handleMouseMove: self].
	^super sentTo: anObject.
! !


!MouseMoveEvent methodsFor: 'private' stamp: 'ar 10/5/2000 23:55'!
setType: evtType startPoint: evtStart endPoint: evtEnd trail: evtTrail buttons: evtButtons hand: evtHand stamp: stamp
	type _ evtType.
	startPoint _ evtStart.
	position _ evtEnd.
	trail _ evtTrail.
	buttons _ evtButtons.
	source _ evtHand.
	wasHandled _ false.
	timeStamp _ stamp.! !

!MouseMoveEvent methodsFor: 'private' stamp: 'ar 10/24/2000 16:31'!
type: eventType readFrom: aStream
	| x y |
	super type: eventType readFrom: aStream.
	aStream skip: 1.
	x _ Integer readFrom: aStream.
	aStream skip: 1.
	y _ Integer readFrom: aStream.
	startPoint _ x@y.! !


!MouseMoveEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:30'!
decodeFromStringArray: array
	"decode the receiver from an array of strings"
	type _ array first asSymbol.
	position _ CanvasDecoder decodePoint: (array at: 2).
	buttons _ CanvasDecoder decodeInteger: (array at: 3).
	startPoint _ CanvasDecoder decodePoint: (array at: 4).
! !

!MouseMoveEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:25'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
		CanvasEncoder encodePoint: startPoint.
	}! !
Object subclass: #MouseOverHandler
	instanceVariableNames: 'mouseOverMorphs enteredMorphs overMorphs leftMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!MouseOverHandler methodsFor: 'initialize-release' stamp: 'ar 9/28/2000 17:08'!
initialize
	mouseOverMorphs _ #().! !


!MouseOverHandler methodsFor: 'event handling' stamp: 'ar 9/28/2000 18:52'!
noticeMouseOver: aMorph event: anEvent
	"Remember that the mouse is currently over some morph"
	(leftMorphs includes: aMorph) 
		ifTrue:[leftMorphs remove: aMorph]
		ifFalse:[enteredMorphs nextPut: aMorph].
	overMorphs nextPut: aMorph.
! !

!MouseOverHandler methodsFor: 'event handling' stamp: 'ar 11/1/2000 15:08'!
processMouseOver: anEvent
	"Re-establish the z-order for all morphs wrt the given event"
	| hand localEvt focus evt |
	hand _ anEvent hand.
	leftMorphs _ mouseOverMorphs asIdentitySet.
	"Assume some coherence for the number of objects in over list"
	overMorphs _ WriteStream on: (Array new: leftMorphs size).
	enteredMorphs _ WriteStream on: #().
	"Now go looking for eventual mouse overs"
	hand handleEvent: anEvent asMouseOver.
	"Get out early if there's no change"
	(leftMorphs size = 0 and:[enteredMorphs position = 0]) 
		ifTrue:[^leftMorphs _ enteredMorphs _ overMorphs _ nil].
	focus _ hand mouseFocus.
	"Send #mouseLeave as appropriate"
	evt _ anEvent asMouseLeave.
	"Keep the order of the left morphs by recreating it from the mouseOverMorphs"
	leftMorphs size > 1 ifTrue:[leftMorphs _ mouseOverMorphs select:[:m| leftMorphs includes: m]].
	leftMorphs do:[:m|
		(m hasOwner: focus) 
			ifTrue:[localEvt _ evt transformedBy: (m transformedFrom: hand).
					m handleEvent: localEvt]
			ifFalse:[overMorphs nextPut: m]].
	"Send #mouseEnter as appropriate"
	evt _ anEvent asMouseEnter.
	enteredMorphs _ enteredMorphs contents.
	enteredMorphs reverseDo:[:m|
		(m hasOwner: focus) 
			ifTrue:[	localEvt _ evt transformedBy: (m transformedFrom: hand).
					m handleEvent: localEvt]].
	"And remember the over list"
	mouseOverMorphs _ overMorphs contents.
	leftMorphs _ enteredMorphs _ overMorphs _ nil.
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MouseOverHandler class
	instanceVariableNames: ''!

!MouseOverHandler class methodsFor: 'instance creation' stamp: 'ar 9/22/2000 10:57'!
new
	^super new initialize! !
MouseSensorMorph subclass: #MouseOverMorph
	instanceVariableNames: 'mouseEnterSelector mouseMoveSelector mouseLeaveSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!MouseOverMorph methodsFor: 'event handling' stamp: 'di 4/13/98 15:55'!
handlesMouseOver: evt

	^ model ~~ nil
! !

!MouseOverMorph methodsFor: 'event handling' stamp: 'di 4/17/1998 13:55'!
mouseEnter: event
	"Relay a mouseEnter event to my model."

	mouseEnterSelector ifNotNil:
		[mouseEnterSelector numArgs = 0
			ifTrue: [^ model perform: mouseEnterSelector].
		mouseEnterSelector numArgs = 1
			ifTrue: [^ model perform: mouseEnterSelector with: event].
		mouseEnterSelector numArgs = 2
			ifTrue: [^ model perform: mouseEnterSelector with: true with: event].
		^ self error: 'mouseEnterselector must take 0, 1, or 2 arguments']! !

!MouseOverMorph methodsFor: 'event handling' stamp: 'di 4/17/1998 14:15'!
mouseLeave: event
	"Relay a mouseLeave event to my model."

	mouseLeaveSelector ifNotNil:
		[mouseLeaveSelector numArgs = 0
			ifTrue: [^ model perform: mouseLeaveSelector].
		mouseLeaveSelector numArgs = 1
			ifTrue: [^ model perform: mouseLeaveSelector with: event].
		^ self error: 'mouseLeaveSelector must take 0, or 1 argument'].

	mouseEnterSelector ifNotNil:
		["Or send mouseEnter: false..."
		mouseEnterSelector numArgs = 2
			ifTrue: [^ model perform: mouseEnterSelector with: false with: event].
		^ self error: 'mouseEnterSelector must take 2 arguments']! !

!MouseOverMorph methodsFor: 'event handling' stamp: 'bf 3/16/2000 18:57'!
mouseMove: event
	"Relay a mouseMove event to my model."

	mouseMoveSelector ifNotNil:
		[mouseMoveSelector numArgs = 0
			ifTrue: [^ model perform: mouseMoveSelector].
		mouseMoveSelector numArgs = 1
			ifTrue: [^ model perform: mouseMoveSelector with: event cursorPoint].
		mouseMoveSelector numArgs = 2
			ifTrue: [^ model perform: mouseMoveSelector with: event cursorPoint with: event].
		^ self error: 'mouseMoveSelector must take 0, 1, or 2 arguments']! !
Component subclass: #MouseSensorMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!MouseSensorMorph methodsFor: 'initialization' stamp: 'di 4/13/98 12:18'!
initialize
	super initialize.
	self bounds: (0@0 extent: 20@20)! !


!MouseSensorMorph methodsFor: 'testing' stamp: 'di 5/7/1998 00:41'!
installed

self halt: 'under construction'
"
	^ (owner ~~ nil) and: [owner isWorldOrHandMorph not]
"! !


!MouseSensorMorph methodsFor: 'drawing' stamp: 'ar 6/17/1999 00:50'!
fullDrawOn: aCanvas
	self installed ifFalse: [aCanvas drawMorph: self]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MouseSensorMorph class
	instanceVariableNames: ''!

!MouseSensorMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/15/98 21:53'!
includeInNewMorphMenu
	"Only include instances of subclasses of me"
	^ self ~~ MouseSensorMorph! !
MovieClipStartMorph subclass: #MovieClipEndMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!MovieClipEndMorph commentStamp: '<historical>' prior: 0!
The idea is that soon we will show the soundtrack extending between the start cue and the end morph.!


!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/26/2000 00:25'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	"Ignored -- all display is done by the starting morph -- see superclass"! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/11/2000 23:06'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	movieClipPlayer ifNotNil:
		["If being shown as a clip, then tell the clipPlayer to stop showing this clip"
		movieClipPlayer stopRunning]! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/22/2000 17:28'!
movieFileName: movieFileName image: aForm player: aMoviePlayer frameNumber: n

	movieClipFileName _ movieFileName.
	self image: aForm frameNumber: n.
	moviePlayerMorph _ movieClipPlayer _ aMoviePlayer.
	scoreEvent _ AmbientEvent new morph: self.
! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/22/2000 12:43'!
pauseFrom: scorePlayer

	"Ignored"! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/22/2000 12:43'!
resetFrom: scorePlayer

	"Ignored"! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/22/2000 12:43'!
resumeFrom: scorePlayer

	"Ignored"! !

!MovieClipEndMorph methodsFor: 'as yet unclassified' stamp: 'di 10/23/2000 10:42'!
thumbnailHeight

	^ 30! !
MovieFrameSyncMorph subclass: #MovieClipStartMorph
	instanceVariableNames: 'movieClipPlayer movieClipFileName soundTrackFileName soundTrackPlayerReady soundTrackMorph soundTrackTimeScale scoreEvent endMorph clipColor colorMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!MovieClipStartMorph commentStamp: '<historical>' prior: 0!
This class and its subclasses act to syncronize movie players with the progress of a MIDI score and further background can be found in the comment for MoviePlayerMorph.

MovieClipStartMorphs are used where you have a movie clip player plex.  You can create such a plex by opening a midi score, spawning a piano roll (by the button of that name), and then choosing 'add movie clip player' from the piano roll menu.  Much simpler, you can open a MoviePlayerMorph as a new morph, and then choose 'make a new movie' from its menu.  This plex then serves as a central editable score for composing movie clips.

To add a new movie clip to the score, open a movie from the fileList (or as a new morph followed by 'open a movie').  Play or otherwise position the clip to the desired starting position, and then tear off a thumbnail and drop it into the score at the desired time.  The starting thumbnail (MovieClipStartMorph) will appear in the score, tied to an endMorph by a colored stripe.  The ending time will be chosen based on the total length of the clip, a default starting clip length (200 frames), and possible interference with other clips that follow it.

To reposition a clip, you can pick up its clipStart with halo black handle, and drop it elsewhere.  The rest of the clip will follow as best it can.  To delete a clip, delete its clipStart.  To change the duration of a clip, play the composition up to some point in that clip, and pause it.  Then use the  controls on the central movie player to move forward or backward to the desired ending frame, and choose 'end clip here' from the player menu.!


!MovieClipStartMorph methodsFor: 'initialization' stamp: 'di 10/23/2000 10:40'!
image: aForm frameNumber: n

	self image: (aForm magnifyBy: self thumbnailHeight asFloat / aForm height).
	frameNumber _ n.! !

!MovieClipStartMorph methodsFor: 'initialization' stamp: 'di 10/29/2000 09:23'!
justDroppedInto: newOwner event: evt
	| pianoRoll syncMorph |
	"When dropping this morph into a pianoRoll, add a corresponding
	event to the score so that it will always appear when played,
	in addition to possibly triggering other actions"

	(newOwner isKindOf: PianoRollScoreMorph)
	ifTrue:
		[pianoRoll _ newOwner.
		pianoRoll movieClipPlayer ifNil:
			["This PianoRoll is not a clip player -- replace me by a SyncMorph"
			syncMorph _ MovieFrameSyncMorph new
						image: image
						player: moviePlayerMorph
						frameNumber: frameNumber.
			pianoRoll replaceSubmorph: self by: syncMorph.
			"rewrite to use justDroppedInto:..."
			pianoRoll score removeAmbientEventWithMorph: self;
					addAmbientEvent: (scoreEvent
						morph: syncMorph;
						time: (pianoRoll timeForX: self left)).
			^ self].

		self movieClipPlayer: pianoRoll movieClipPlayer.
		self setTimeInScore: pianoRoll score
					near: (pianoRoll timeForX: self left).
		self endTime > newOwner scorePlayer durationInTicks ifTrue:
			[newOwner scorePlayer updateDuration]]
	ifFalse:
		["Dropped it somewhere else -- delete related morphs"
		endMorph ifNotNil: [endMorph delete].
		soundTrackMorph ifNotNil: [soundTrackMorph delete]].

	super justDroppedInto: newOwner event: evt
! !

!MovieClipStartMorph methodsFor: 'initialization' stamp: 'di 10/23/2000 10:32'!
movieFileName: movieFileName soundTrackFileName: soundFileName
			image: aForm player: aMoviePlayer frameNumber: n
	movieClipFileName _ movieFileName.
	soundTrackFileName _ soundFileName.
	self image: aForm frameNumber: n.
	moviePlayerMorph _ aMoviePlayer.
	soundTrackPlayerReady _ moviePlayerMorph scorePlayer copy.
	scoreEvent _ AmbientEvent new morph: self.
! !


!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/19/2000 14:27'!
endMorph

	^ endMorph! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/19/2000 16:41'!
frameNumber: newFrame

	frameNumber _ newFrame! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/4/2000 17:18'!
movieClipPlayer: aMoviePlayerMorph
	"For now, these morphs work both as a sync point in a long movie, and
	as a cue point for a short clip in a longer score.
	To a cue point, this method provides a reference to the clip player."

	movieClipPlayer _ aMoviePlayerMorph! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/25/2000 22:02'!
relatedPlayer
 
	^ movieClipPlayer! !

!MovieClipStartMorph methodsFor: 'access' stamp: 'di 10/19/2000 12:24'!
scoreEvent
	^ scoreEvent! !


!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/25/2000 22:27'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime
	"This code handles both the start and end morphs."

	| startX endX h delta |
	self startTime > rightTime
		ifTrue: [^ self  "Start time has not come into view."].  
	self endTime < leftTime
		ifTrue: [^ self  "End time has passed out of view."].

	startX _ pianoRoll xForTime: self startTime.
	endX _ pianoRoll xForTime: self endTime.
	h _ self colorMargin.  "Height of highlight bar over thumbnails."
	morphList add: 
		(self align: self bottomLeft
			with: startX @ (pianoRoll bottom - pianoRoll borderWidth - h)).
	morphList add: 
		(endMorph align: endMorph bounds rightCenter
			with: endX @ self center y).
	morphList add: 
		(self colorMorph bounds: (self topLeft - (0@h) corner: endMorph right @ (self bottom + h))).

	(soundTrackMorph == nil and: [moviePlayerMorph scorePlayer == nil]) ifFalse:
		["Wants a sound track"
		(soundTrackMorph == nil or: [pianoRoll timeScale ~= soundTrackTimeScale])
			ifTrue: ["Needs a new sound track"
					self buildSoundTrackMorphFor: pianoRoll].
		morphList add: 
			(soundTrackMorph align: soundTrackMorph bottomLeft with: colorMorph topLeft).
		self soundTrackOnBottom ifTrue:
			[soundTrackMorph align: soundTrackMorph bottomLeft with: self bottomLeft.
			delta _ 0 @ self soundTrackHeight.
			self position: self position - delta.
			endMorph position: endMorph position - delta.
			colorMorph position: colorMorph position - delta]]
! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:46'!
colorMargin
	"How far the clip span color highlight extends outside the starting clip"

	^ 5! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:14'!
colorMorph
	colorMorph ifNotNil: [^ colorMorph].

	"Make up a morph to highlight the span of this clip."
	ColorIndex _ (ColorIndex ifNil: [0]) + 2 \\ 8 + 1.
	^ colorMorph _ Morph newBounds: (0@0 extent: 9@9) color: ((Color wheel: 8) at: ColorIndex)
! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:24'!
delete
	(owner isKindOf: PianoRollScoreMorph) ifTrue:
		[owner score removeAmbientEventWithMorph: self.
		endMorph ifNotNil: [owner score removeAmbientEventWithMorph: endMorph]].
	endMorph ifNotNil: [endMorph delete].
	soundTrackMorph ifNotNil: [soundTrackMorph delete].
	colorMorph ifNotNil: [colorMorph delete].
	super delete.
! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:23'!
soundTrackHeight

	^ 40! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 10:58'!
soundTrackOnBottom  "a local preference during test"

	^ false! !

!MovieClipStartMorph methodsFor: 'drawing' stamp: 'di 10/23/2000 12:32'!
thumbnailHeight

	^ 60! !


!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/26/2000 00:09'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"If being shown as a clip, then tell the clipPlayer to start showing this clip"
	movieClipPlayer setCueMorph: self.
	movieClipPlayer openFileNamed: movieClipFileName
			withScorePlayer: soundTrackPlayerReady copy
			andPlayFrom: frameNumber.
! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:24'!
endTime

	^ endMorph scoreEvent time! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:27'!
frameAtTick: time
	"Return the frame number corresponding to the given tick time"

	^ frameNumber +
		((time - self startTime) asFloat
			/ (self endTime - self startTime)
			* (endMorph frameNumber - frameNumber)) asInteger! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/11/2000 21:40'!
nextSyncEventAfter: index inTrack: track
	| evt |
	index to: track size do:
		[:i | evt _ track at: i.
		((evt morph isMemberOf: self class)
			and: [evt morph moviePlayerMorph == moviePlayerMorph])
			ifTrue: [^ evt]].
	^ nil! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/26/2000 00:17'!
resetFrom: scorePlayer

	(movieClipPlayer cueMorph == nil or: [self startTime < movieClipPlayer cueMorph startTime]) ifTrue:
		[movieClipPlayer openFileNamed: movieClipFileName
				withScorePlayer: soundTrackPlayerReady copy
				andPlayFrom: frameNumber;
			setCueMorph: self;
			step;
			pauseFrom: scorePlayer]
! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/25/2000 22:03'!
resumeFrom: scorePlayer

	| time |
	"New movie clip style of use."
	time _ scorePlayer ticksSinceStart.
	time < self startTime ifTrue: [^ self].  "It's not my time yet"
	time > self endTime ifTrue: [^ self].  "It's past my time"

	"The player is starting in the midst of this clip."
	movieClipPlayer openFileNamed: movieClipFileName
				withScorePlayer: soundTrackPlayerReady copy
				andPlayFrom: (self frameAtTick: time);
		setCueMorph: self.
! !

!MovieClipStartMorph methodsFor: 'events' stamp: 'di 10/22/2000 20:24'!
startTime

	^ scoreEvent time! !


!MovieClipStartMorph methodsFor: 'private' stamp: 'di 10/21/2000 23:28'!
buildSoundTrackMorphFor: pianoRoll
	| stopTime soundTrackForm startTime samplesPerTick samplesPerMs |
	soundTrackTimeScale _ pianoRoll timeScale.  "pixels per tick"
	samplesPerTick _ moviePlayerMorph scorePlayer originalSamplingRate   "Samples per sec"
						* pianoRoll scorePlayer secsPerTick.  "secs per tick"
	samplesPerMs _ moviePlayerMorph scorePlayer originalSamplingRate / 1000.0.
	startTime _ frameNumber * moviePlayerMorph msPerFrame.  "ms"
	stopTime _ endMorph frameNumber * moviePlayerMorph msPerFrame.
	soundTrackForm _ moviePlayerMorph scorePlayer
		volumeForm: self soundTrackHeight
		from: (startTime * samplesPerMs) rounded
		to: (stopTime * samplesPerMs) rounded
		nSamplesPerPixel: samplesPerTick / soundTrackTimeScale.
	^ soundTrackMorph _ ImageMorph new image: soundTrackForm! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'di 10/29/2000 08:02'!
setEndFrameNumber: frame

	self setEndFrameNumber: frame tickTime: nil! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'di 10/29/2000 09:17'!
setEndFrameNumber: frameOrNil tickTime: timeOrNil
	"May be called with either time or frame being nil,
	in which case the other will br computed."

	| pianoRoll frame time |
	pianoRoll _ movieClipPlayer pianoRoll.
	frame _ frameOrNil ifNil:
		[frameNumber + 
			((timeOrNil - self startTime)
			* (pianoRoll scorePlayer secsPerTick*1000.0)
			/ moviePlayerMorph msPerFrame) asInteger - 1].
	time _ timeOrNil ifNil:
		[self startTime +   "in ticks"
			(pianoRoll scorePlayer ticksForMSecs:
			(frameOrNil - frameNumber) * moviePlayerMorph msPerFrame)].
	endMorph ifNil:
		[endMorph _ MovieClipEndMorph new
			movieFileName: movieClipFileName
			image: (moviePlayerMorph pageFormForFrame: frame)
			player: movieClipPlayer
			frameNumber: frame]
		ifNotNil:
		[endMorph image: (moviePlayerMorph pageFormForFrame: frame)
			frameNumber: frame].

	endMorph scoreEvent time: time.
	pianoRoll score removeAmbientEventWithMorph: endMorph;
		addAmbientEvent: endMorph scoreEvent.
	soundTrackMorph _ nil.  "Force it to be recomputed."
	pianoRoll rebuildFromScore
! !

!MovieClipStartMorph methodsFor: 'private' stamp: 'di 10/30/2000 08:21'!
setTimeInScore: score near: dropTime
	"Find a time to place this clip that does not overlap other clips.
	So, if I start in the middle of another clip, move me to the end of it,
	and if I start very soon after another clip, put me right at the end.
	Then, if my end goes beyond the start of another clip, shorten me
	so I end right before that clip."

	| startTime endTime delta endFrame |
	startTime _ dropTime.
	endMorph ifNil: [endFrame _ moviePlayerMorph frameCount]
			ifNotNil: [endFrame _ endMorph frameNumber].
	endTime _ startTime   "in ticks"
		+ (movieClipPlayer pianoRoll scorePlayer ticksForMSecs:
			(endFrame - frameNumber)
			* moviePlayerMorph msPerFrame).
	score eventMorphsDo:
		[:m | (m ~~ self and: [m isMemberOf: self class]) ifTrue:
				[((startTime between: m startTime and: m endTime)
					or: [startTime between: m endTime and: m endTime+50])
					ifTrue: ["If I start in the middle of another clip, or a little
							past its end, move me exactly to the end of it"
							delta _ (m endTime + 1) - startTime.
							startTime _ startTime + delta.
							endTime _ endTime + delta].
				(endTime between: m startTime and: m endTime)
					ifTrue: ["If my end goes overlaps another clip, shorten me so I fit."
							endTime _ m startTime - 1].
				]].
	scoreEvent time: startTime.
	score removeAmbientEventWithMorph: self;
			addAmbientEvent: scoreEvent.
	self setEndFrameNumber: endFrame tickTime: endTime.
! !
ImageMorph subclass: #MovieFrameSyncMorph
	instanceVariableNames: 'moviePlayerMorph frameNumber '
	classVariableNames: 'ColorIndex '
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!MovieFrameSyncMorph commentStamp: '<historical>' prior: 0!
This class and its subclasses act to syncronize movie players with the progress of a MIDI score and further background can be found in the comment for MoviePlayerMorph.

There are two main forms of synchroniztion.

MovieFrameSyncMorphs are used where you have a MIDI score open with a piano roll, and a separate MoviePlayer Morph.  A MovieFrameSyncMorph can be torn off from the MoviePlayer with a shift-drag gesture or menu command, and can then be dropped into a MIDI score.  They are used to start a movie player at a given place in the score, and then to stretch or compress the movie frame rate so that certain frames are synchronized with the corresponding points in the score.

MovieClipStartMorphs (q.v.) and MovieClipEndMorphs are used for the other kind of synchronization, namely where you wish to assemble a number of movie clips in a sequence.!


!MovieFrameSyncMorph methodsFor: 'initialization' stamp: 'di 8/5/1998 17:04'!
image: aForm player: aMoviePlayer frameNumber: n
	self image: aForm.
	moviePlayerMorph _ aMoviePlayer.
	frameNumber _ n! !

!MovieFrameSyncMorph methodsFor: 'initialization' stamp: 'di 10/29/2000 09:22'!
justDroppedInto: newOwner event: evt 
	| pianoRoll |
	"When dropping this morph into a pianoRoll, add a corresponding
	event to the score so that it will always appear when played,
	in addition to possibly triggering other actions"

	(self isMemberOf: MovieFrameSyncMorph) ifFalse:
		[^ super justDroppedInto: newOwner event: evt].

	(newOwner isKindOf: PianoRollScoreMorph)
	ifTrue:
		["Legacy code for existing sync morphs"
		pianoRoll _ newOwner.
		pianoRoll score
			removeAmbientEventWithMorph: self;
			addAmbientEvent: (AmbientEvent new
						morph: self;
						time: (pianoRoll timeForX: self left))].

	super justDroppedInto: newOwner event: evt
! !

!MovieFrameSyncMorph methodsFor: 'initialization' stamp: 'RAA 12/11/2000 22:58'!
justDroppedIntoPianoRoll: pianoRoll event: evt

	"since these morphs handle their own dropping, ignore"! !


!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 8/6/1998 14:13'!
frameNumber
	^ frameNumber! !

!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 10/11/2000 21:39'!
moviePlayerMorph
 
	^ moviePlayerMorph! !

!MovieFrameSyncMorph methodsFor: 'access' stamp: 'di 10/25/2000 22:02'!
relatedPlayer
 
	^ moviePlayerMorph! !


!MovieFrameSyncMorph methodsFor: 'drawing' stamp: 'di 10/25/2000 22:36'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| leftX |
	t > rightTime ifTrue: [^ self  "Start time has not come into view."].  
	leftX _ pianoRoll xForTime: t.
	(leftX + self width) < pianoRoll left ifTrue: [^ self  "End time has passed out of view."].
	morphList add: 
		(self align: self bottomLeft
			with: leftX @ (pianoRoll bottom - pianoRoll borderWidth)).
! !


!MovieFrameSyncMorph methodsFor: 'events' stamp: 'di 10/26/2000 00:08'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick
	| next |
	"Set frame number and milliseconds since start in case of drift"
	moviePlayerMorph frameNumber: frameNumber
		msSinceStart: scorePlayer millisecondsSinceStart.

	"If there is a later sync point, set the appropriate frame rate until then."
	(next _ self nextSyncEventAfter: index inTrack: track) == nil ifFalse:
		[moviePlayerMorph msPerFrame: (next time - ticks) * secsPerTick * 1000.0
						/ (next morph frameNumber - self frameNumber)].
! !

!MovieFrameSyncMorph methodsFor: 'events' stamp: 'di 10/24/2000 18:22'!
nextSyncEventAfter: index inTrack: track
	| evt |
	index to: track size do:
		[:i | evt _ track at: i.
		((evt morph isMemberOf: self class)
			and: [evt morph moviePlayerMorph == moviePlayerMorph])
			ifTrue: [^ evt]].
	^ nil! !

!MovieFrameSyncMorph methodsFor: 'events' stamp: 'di 10/25/2000 22:03'!
pauseFrom: scorePlayer

	self relatedPlayer pauseFrom: scorePlayer! !

!MovieFrameSyncMorph methodsFor: 'events' stamp: 'di 10/25/2000 22:02'!
resetFrom: scorePlayer

	self relatedPlayer resetFrom: scorePlayer! !

!MovieFrameSyncMorph methodsFor: 'events' stamp: 'di 10/25/2000 22:03'!
resumeFrom: scorePlayer

	self relatedPlayer resumeFrom: scorePlayer! !
Morph subclass: #MovieMorph
	instanceVariableNames: 'playMode msecsPerFrame rotationDegrees scalePoint frameList currentFrameIndex dwellCount '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!MovieMorph methodsFor: 'initialization' stamp: 'jm 7/24/97 15:05'!
initialize

	super initialize.
	color _ (Color r: 1 g: 0 b: 1).
	playMode _ #stop.  "#stop, #playOnce, or #loop"
	msecsPerFrame _ 200.
	rotationDegrees _ 0.
	scalePoint _ 1.0@1.0.
	frameList _ EmptyArray.
	currentFrameIndex _ 1.
	dwellCount _ 0.
! !


!MovieMorph methodsFor: 'accessing'!
form

	^ self currentFrame form
! !

!MovieMorph methodsFor: 'accessing'!
rotationDegrees

	^ rotationDegrees
! !

!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'!
scalePoint

	^ scalePoint
! !

!MovieMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:05'!
scalePoint: newScalePoint

	| frame |
	newScalePoint ~= scalePoint ifTrue: [
		self changed.
		scalePoint _ newScalePoint.
		frame _ self currentFrame.
		frame ifNotNil: [frame scalePoint: newScalePoint].
		self layoutChanged.
		self changed].
! !


!MovieMorph methodsFor: 'drawing'!
drawOn: aCanvas

	| frame |
	frame _ self currentFrame.
	frame ~~ nil
		ifTrue: [^ frame drawOn: aCanvas]
		ifFalse: [^ super drawOn: aCanvas].
! !


!MovieMorph methodsFor: 'geometry-testing'!
containsPoint: p

	| frame |
	frame _ self currentFrame.
	((frame ~~ nil) and: [playMode = #stop])
		ifTrue: [^ frame containsPoint: p]
		ifFalse: [^ super containsPoint: p].
! !


!MovieMorph methodsFor: 'stepping'!
step

	playMode = #stop ifTrue: [^ self].

	dwellCount > 0 ifTrue: [
		dwellCount _ dwellCount - 1.
		^ self].

	currentFrameIndex < frameList size
		ifTrue: [^ self setFrame: currentFrameIndex + 1].

	playMode = #loop
		ifTrue: [self setFrame: 1]
		ifFalse: [playMode _ #stop].
! !

!MovieMorph methodsFor: 'stepping'!
stepTime

	^ msecsPerFrame
! !


!MovieMorph methodsFor: 'menu' stamp: 'sw 4/16/1998 22:45'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	| movies subMenu |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	subMenu _ MenuMorph new defaultTarget: self.
	frameList size > 1 ifTrue: [
		subMenu add: 'repaint' action: #editDrawing.
		subMenu add: 'set rotation center' action: #setRotationCenter.
		subMenu add: 'play once' action: #playOnce.
		subMenu add: 'play loop' action: #playLoop.
		subMenu add: 'stop playing' action: #stopPlaying.
		currentFrameIndex > 1 ifTrue: [
			subMenu add: 'previous frame' action: #previousFrame].
		currentFrameIndex < frameList size ifTrue: [
			subMenu add: 'next frame' action: #nextFrame]].
	subMenu add: 'extract this frame' action: #extractFrame:.
	movies _
		(self world rootMorphsAt: aHandMorph targetOffset)
			select: [:m | (m isKindOf: MovieMorph) or:
						[m isKindOf: SketchMorph]].
	(movies size > 1) ifTrue:
		[subMenu add: 'insert into movie' action: #insertIntoMovie:].
	aCustomMenu add: 'movie...' subMenu: subMenu
! !

!MovieMorph methodsFor: 'menu'!
advanceFrame

	currentFrameIndex < frameList size
		ifTrue: [self setFrame: currentFrameIndex + 1]
		ifFalse: [self setFrame: 1].
! !

!MovieMorph methodsFor: 'menu' stamp: 'sw 4/22/1998 17:29'!
editDrawing
	| frame |
	frame _ self currentFrame.
	frame ~~ nil ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]! !

!MovieMorph methodsFor: 'menu'!
extractFrame: evt

	| f |
	f _ self currentFrame.
	f ifNil: [^ self].
	frameList _ frameList copyWithout: f.
	frameList isEmpty
		ifTrue: [self position: f position]
		ifFalse: [self setFrame: currentFrameIndex].
	evt hand attachMorph: f.
! !

!MovieMorph methodsFor: 'menu' stamp: 'sw 4/2/98 15:48'!
insertIntoMovie: evt

	| movies aTarget |
	movies _
		(self world rootMorphsAt: evt hand targetOffset)
			select: [:m | ((m isKindOf: MovieMorph) or:
						 [m isKindOf: SketchMorph]) and: [m ~= self]].
	movies isEmpty ifTrue: [^ self].
	aTarget _ movies first.
	(aTarget isKindOf: SketchMorph) ifTrue:
		[aTarget _ aTarget replaceSelfWithMovie].
	movies first insertFrames: frameList.
	self delete.
! !

!MovieMorph methodsFor: 'menu'!
nextFrame

	currentFrameIndex < frameList size
		ifTrue: [self setFrame: currentFrameIndex + 1].
! !

!MovieMorph methodsFor: 'menu'!
playLoop

	playMode _ #loop.
! !

!MovieMorph methodsFor: 'menu'!
playOnce

	self setFrame: 1.
	playMode _ #playOnce.
! !

!MovieMorph methodsFor: 'menu'!
previousFrame

	currentFrameIndex > 1
		ifTrue: [self setFrame: currentFrameIndex - 1].
! !

!MovieMorph methodsFor: 'menu'!
stopPlaying

	playMode _ #stop.
	self setFrame: 1.
! !


!MovieMorph methodsFor: 'private'!
currentFrame

	frameList isEmpty ifTrue: [^ nil].
	currentFrameIndex > frameList size
		ifTrue: [currentFrameIndex _ frameList size].
	currentFrameIndex < 1
		ifTrue: [currentFrameIndex _ 1].
	^ frameList at: currentFrameIndex
! !

!MovieMorph methodsFor: 'private'!
insertFrames: newFrames
	"Insert the given collection of frames into this movie just after the currentrame."

	frameList isEmpty ifTrue: [
		frameList _ newFrames asArray copy.
		self setFrame: 1.
		^ self].

	frameList _
		frameList
			copyReplaceFrom: currentFrameIndex + 1  "insert before"
			to: currentFrameIndex
			with: newFrames.
! !

!MovieMorph methodsFor: 'private' stamp: 'ar 9/23/2000 12:44'!
setFrame: newFrameIndex

	| oldFrame p newFrame |
	oldFrame _ self currentFrame.
	oldFrame ifNil: [^ self].

	self changed.
	p _ oldFrame referencePosition.
	currentFrameIndex _ newFrameIndex.
	currentFrameIndex > frameList size
		ifTrue: [currentFrameIndex _ frameList size].
	currentFrameIndex < 1
		ifTrue: [currentFrameIndex _ 1].
	newFrame _ frameList at: currentFrameIndex.
	newFrame referencePosition: p.
	oldFrame delete.
	self addMorph: newFrame.
	dwellCount _ newFrame framesToDwell.
	self layoutChanged.
	self changed.
! !
BookMorph subclass: #MoviePlayerMorph
	instanceVariableNames: 'movieFileName movieFile frameSize frameDepth frameNumber frameCount playDirection msSinceStart msAtStart msAtLastSync frameAtLastSync msPerFrame frameBufferIfScaled soundTrackFileName scorePlayer soundTrackForm soundTrackMorph pianoRoll cueMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!MoviePlayerMorph commentStamp: '<historical>' prior: 0!
MoviePlayerMorph plays images from a file using async io.  The file format is simple but non-standard (see below).

The heart of the play logic is in the step method.  Note that play is driven by a simulated time since start.  For a movie with a sound score, this is the millisecondsSinceStart of the score player, whereas a movie by itself gets this from the millisecondClock minus msAtStart.

Movie players are designed to be used in three ways
	1.  Select a movie in the file list, 'open as movie', and play it.
	2.  As in (1), but drop thumbnails for various frames into a
		MIDI piano roll to synchronize video with music.
	3.  Open a MoviePlayerMorph as a 'new morph', and choose
		'make a new movie' from the menu.

In (1) and (2), a shift-drag is used to 'tear off' a thumbnail reference morph to the currently visible frame of this clips.  The thumbnail can then be dropped in a MIDI score player to either syncronize that frame with what point in the music, or to cause that clip to being playing in the shared player of a SqueakMovie plex.

When making a new movie, an empty score and piano roll are linked to the movie player, as a SqueakMovie plex. You can then open another movie as a clip, and drop a thumbnail morph into the score to start that clip playing at that frame in the shared player.  If you pause while playing that clip, you can manually play the clip forward and backward in the current clip.  if you stop at a given frame, you can choose 'end clip here' from the shared player menu to shorten or lengthen the clip.

Clips can be moved by picking up the starting thumbnail (use halo black handle), and dropping them elsewhere.  If you try to place one clip in the middle of another, it will slide to the end.  If you position one clip close to the end of another, it will sidle up to make them contiguous.

If you wish a soundtrack to be included with a clip, make sure it has been opened in the source clip player before tearing off the starting thumbnail.

About the .movie file format...
The following code was used to convert 27 files into a movie.  They were named
	'BalloonDrop10fps003.bmp' through 'BalloonDrop10fps081.bmp'
incrementing by 003.  Each was known to be a 320x240 image in 32-bit BMP format.
Note the 27 in the 5th line is the number of frames, = (3 to: 81 by: 3) size.

	| ps zps f32 out ff |
	out _ FileStream newFileNamed: 'BalloonDrop10fps.movie'.
	out binary.
	ff _ Form extent: 320@240 depth: 16.
	#(22 320 240 16 27 100000) , (7 to: 32)
		do: [:i | out nextInt32Put: i].
		
	3 to: 81 by: 3 do:
		[:i | ps _ i printString. zps _ ps padded: #left to: 3 with: $0.
		f32 _ Form fromFileNamed:
			'BalloonDrop10fps' , zps , '.bmp'.
		f32 displayOn: ff at: 0@0.  "Convert down to 16 bits"
		ff display; writeOnMovie: out].
	out close.
!


!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/30/2000 08:10'!
duplicate
	| dup |
	playDirection ~= 0 ifTrue: [self stopPlay].
	dup _ super duplicate.
	dup scorePlayer: scorePlayer copy.  "Share sound track if any."
	^ dup duplicateMore startStepping! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/30/2000 08:11'!
duplicateMore
	"Duplicate dies not replicate Forms, but MoviePlayers need this."

	frameBufferIfScaled _ frameBufferIfScaled deepCopy.
	currentPage image: currentPage image deepCopy.
! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/8/2000 21:43'!
openFileNamed: fName 
	self pvtOpenFileNamed: fName.
	self goToPage: 1! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/27/2000 15:22'!
openFileNamed: fName withScorePlayer: playerReady andPlayFrom: frameNo
	"Note: The plan is that the score player (a SampledSound) is already spaced
	forward to this frame number so it does not need to be reset as would normally
	happen in startRunning."

	self pvtOpenFileNamed: fName.
	scorePlayer _ playerReady.
	frameNumber _ frameNo.
	frameAtLastSync _ frameNo.
	msAtLastSync _ frameAtLastSync * msPerFrame.
	self playForward.! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 7/6/1998 23:37'!
position: newPos
	super position: newPos.
	(currentPage ~~ nil and: [currentPage left odd])
		ifTrue: ["crude word alignment for depth = 16"
				super position: newPos + (1@0)]! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:42'!
setInitialState
	super setInitialState.
	self layoutInset: 3.
	self borderWidth: 2.
	self color: Color veryLightGray.
	pageSize _ frameSize _ 200@200.
	frameDepth _ 8.
	self disableDragNDrop! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/28/2000 17:04'!
stopSoundTrackIfAny

	scorePlayer == nil ifTrue:[^ self].
	(scorePlayer isKindOf: SampledSound)
		ifTrue: [scorePlayer endGracefully]
		ifFalse: [scorePlayer _ nil]! !

!MoviePlayerMorph methodsFor: 'initialization' stamp: 'di 10/22/2000 23:41'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'di 10/29/2000 12:02'!
extent: newExtent

	| tlMargin brMargin pageExtent scale fullSizeImage |
	fullSizeImage _ frameBufferIfScaled ifNil: [currentPage image].
	frameCount ifNil: [^ self].  "Not yet open"
	tlMargin _ currentPage topLeft - self topLeft.
	brMargin _ self bottomRight - currentPage bottomRight.
	pageExtent _ newExtent - brMargin - tlMargin.
	scale _ pageExtent x asFloat / frameSize x min: pageExtent y asFloat / frameSize y.
	(scale _ scale max: 0.25) > 0.9 ifTrue: [scale _ 1.0].

	pageExtent _ (frameSize * scale) rounded.
	pageExtent = frameSize
		ifTrue: [currentPage image: fullSizeImage.
				frameBufferIfScaled _ nil]
		ifFalse: [currentPage image: (Form extent: pageExtent depth: frameDepth).
				frameBufferIfScaled _ fullSizeImage.
				(WarpBlt current toForm: currentPage image) sourceForm: fullSizeImage;
					combinationRule: 3;
					copyQuad: fullSizeImage boundingBox innerCorners
						toRect: currentPage image boundingBox].
	^ self layoutChanged
! !

!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'di 10/16/2000 13:20'!
fullControlSpecs
	^ #(	
			( '¥'		invokeBookMenu 'Invoke menu')
			( '<--'		firstPage		'Go to first page')
			( '<<'		playReverse		'Play backward')
			( '<-' 		previousPage	'Back one frame')
			( '| |' 		stopPlay		'Stop playback')
			( '->'		nextPage		'Forward one frame')
			( '>>'		playForward	'Play forward')
			( '-->'		lastPage			'Go to final page')
			( '<->'		scanBySlider	'Scan by slider'  'menu')
		"Note extra spec 'menu' causes mousedown activation -- see makePageControlsFrom:"
	)! !

!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'di 7/6/1998 14:05'!
insertPage
	^ self makeMyPage! !

!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'di 10/24/2000 17:22'!
showHideSoundTrack

	soundTrackForm ifNotNil:
		[soundTrackMorph delete.
		^ soundTrackForm _ soundTrackMorph _ nil].

	soundTrackForm _ scorePlayer volumeForm: 20 from: 1 to: scorePlayer samples size nSamplesPerPixel: 250.
	soundTrackMorph _ ImageMorph new image: (Form extent: 140 @ soundTrackForm height).
	soundTrackMorph addMorph:
		(Morph newBounds: (soundTrackMorph bounds topCenter extent: 1@soundTrackMorph height)
					color: Color red).
	self addMorph: soundTrackMorph after: currentPage.
	self layoutChanged.
	self stepSoundTrack.
! !

!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'di 10/24/2000 16:55'!
showPageControls
	self showPageControls: self fullControlSpecs.
! !

!MoviePlayerMorph methodsFor: 'controls and layout' stamp: 'ar 11/9/2000 20:42'!
showPageControls: controlSpecs 
	| pageControls |
	self hidePageControls.

	pageControls _ self makePageControlsFrom: controlSpecs.
	pageControls borderWidth: 0; layoutInset: 0; extent: pageControls width@14.
	pageControls  setProperty: #pageControl toValue: true.
	pageControls setNameTo: 'Page Controls'.
	pageControls eventHandler: (EventHandler new on: #mouseDown send: #move to: self).
	self addMorphBack: pageControls beSticky! !


!MoviePlayerMorph methodsFor: 'events' stamp: 'di 10/16/2000 13:27'!
handlesMouseDown: evt
	"We use shift drag to 'tear off' a thumbnail"

	evt shiftPressed ifTrue: [^ true].
	^ super handlesMouseDown: evt! !

!MoviePlayerMorph methodsFor: 'events' stamp: 'di 10/16/2000 13:32'!
mouseDown: evt
	"We use shift drag to 'tear off' a thumbnail"

	evt shiftPressed ifTrue: [^ self makeThumbnailInHand: evt hand].
	^ super mouseDown: evt
		! !


!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/26/2000 00:18'!
cueMorph
	^ cueMorph! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/4/2000 17:19'!
fileName
	^ movieFileName! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/22/2000 10:54'!
frameCount

	^ frameCount! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/22/2000 16:01'!
frameNumber: n

	frameNumber _ n! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 6/1/1999 09:13'!
frameNumber: n msSinceStart: ms
	"Set the current frame number, and save the scorePlayer's simulated time for synchronization."

	frameAtLastSync _ n.
	msAtLastSync _ ms.
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/19/2000 16:31'!
msPerFrame
	^ msPerFrame! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 6/1/1999 08:55'!
msPerFrame: n
	"Set a new frame rate, base on, eg, score synchronization info."

	msPerFrame _ n.
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/23/2000 01:45'!
pageFormForFrame: frameNo

	| f form oldFrame |
oldFrame _ frameNumber.
self goToPage: frameNo.
form _ currentPage image deepCopy.
self goToPage: oldFrame.
true ifTrue: [^ form].

	f _ FileStream readOnlyFileNamed: movieFileName.
	form _ Form extent: frameSize depth: frameDepth.

	"For some weird reason, the next line does not work..."
	f position: (self filePosForFrameNo: frameNo).
	"... but this line was found empirically to work instead."
	f position: (128 + ((frameNo-1)*(form bits size*4+4)) + 4).

	f nextInto: form bits.
	f close.
	^ form! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/15/2000 19:15'!
relativePosition

	^ frameNumber asFloat / frameCount! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/11/2000 12:13'!
scorePlayer

	^ scorePlayer! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/11/2000 12:20'!
scorePlayer: aScorePlayer

	scorePlayer _ aScorePlayer! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/19/2000 10:27'!
setCueMorph: aMorph
	cueMorph _ aMorph
! !

!MoviePlayerMorph methodsFor: 'access' stamp: 'di 10/13/2000 11:51'!
soundTrackFileName
	^ soundTrackFileName! !


!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 7/6/1998 19:32'!
firstPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: 1
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 9/7/2000 09:34'!
goToPage: i
	currentPage ifNil: [self makeMyPage].
	frameNumber _ i.
	playDirection _ 0.
	self startRunning; step.  "will stop after first step"
	soundTrackMorph doIfNotNil: [:m | m image fillWhite].
	self stepSoundTrack.
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 10/16/2000 11:02'!
goToRelativePosition: newPos

	movieFile ifNotNil: [^ self].
	self goToPage: ((newPos*frameCount) asInteger min: frameCount max: 1).
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 7/6/1998 19:29'!
lastPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: frameCount
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 7/6/1998 19:29'!
nextPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: (frameNumber _ frameNumber + 1 min: frameCount).
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 8/17/1998 21:30'!
playForward
	(playDirection ~= 0 or: [frameNumber >= frameCount]) ifTrue:
		[^ self]. "No-op during play or at end"
	playDirection _ 1.
	self startRunning! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 8/17/1998 21:30'!
playReverse
	(playDirection ~= 0 or: [frameNumber <= 1]) ifTrue:
		[^ self]. "No-op during play or at end"
	playDirection _ -1.
	self startRunning! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 7/6/1998 19:29'!
previousPage
	playDirection = 0 ifFalse: [^ self]. "No-op during play"
	self goToPage: (frameNumber _ frameNumber - 1 max: 1).
! !

!MoviePlayerMorph methodsFor: 'player control' stamp: 'di 10/13/2000 20:06'!
stopPlay

	playDirection _ 0.
	self step! !


!MoviePlayerMorph methodsFor: 'score events' stamp: 'di 10/25/2000 22:04'!
pauseFrom: player

	playDirection _ 0.
	self step.! !

!MoviePlayerMorph methodsFor: 'score events' stamp: 'di 10/25/2000 22:06'!
resetFrom: player
	self pauseFrom: player.
	self firstPage! !

!MoviePlayerMorph methodsFor: 'score events' stamp: 'di 10/22/2000 12:56'!
resumeFrom: player
	playDirection ~= 0 ifTrue: [^ self].  "Already running"
	playDirection _ 1.
	pianoRoll ifNil:
		["Sync movie to score player if not a clip player"
		scorePlayer _ player].
	self startRunning! !


!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 9/5/2000 23:09'!
fileByteCountPerFrame
	
	^ (frameBufferIfScaled ifNil: [currentPage image]) bits size * 4
! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 5/27/1999 22:40'!
filePosForFrameNo: frameNo
	
	^ 128 + ((frameNo-1)*(4+self fileByteCountPerFrame)) + 4
! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 10/28/2000 21:36'!
startRunning

	| ms |
	(frameBufferIfScaled ifNil: [currentPage image]) unhibernate.
	movieFile _ AsyncFile new open: movieFileName forWrite: false.
	movieFile primReadStart: movieFile fileHandle
			fPosition: (self filePosForFrameNo: frameNumber)
			count: self fileByteCountPerFrame.
	scorePlayer == nil
		ifTrue: [ms _ Time millisecondClockValue.
				msAtStart _ ms - ((frameNumber-1) * msPerFrame).
				msAtLastSync _ ms - msAtStart.
				frameAtLastSync _ frameNumber]
		ifFalse: [(playDirection > 0 and: [scorePlayer isKindOf: SampledSound]) ifTrue:
					[scorePlayer reset;
							playSilentlyUntil: (frameNumber - 1 * msPerFrame / 1000.0);						initialVolume: 1.0.
					[scorePlayer resumePlaying.
					msAtLastSync _ scorePlayer millisecondsSinceStart]
						forkAt: Processor userInterruptPriority].
				msAtLastSync _ scorePlayer millisecondsSinceStart.
				frameAtLastSync _ frameNumber]! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 10/24/2000 17:31'!
step
	"NOTE:  The movie player has two modes of play, depending on whether scorePlayer is nil or not.  If scorePlayer is nil, then play runs according to the millisecond clock.  If scorePlayer is not nil, then the scorePlayer is consulted for synchronization.  If the movie is running ahead, then some calls on step will skip their  action until the right time.  If the movie is running behind, then the frame may advance by more than one to maintain synchronization."

	"ALSO: This player operates with overlapped disk i/o.  This means that while one frame is being displayed, the next frame in sequence is being read into a disk buffer.  The value of frameNumber corresponds to the frame currently visible."

	"This code may not work right for playing backwards right now.
	Single-step and backwards (dir <= 0) should just run open-loop."

	|  byteCount simTime ms nextFrameNumber |
	movieFile == nil ifTrue: [^ self].
	scorePlayer == nil
		ifTrue: [(ms _ Time millisecondClockValue) < msAtStart ifTrue:  "clock rollover"
					[msAtStart _ ms - (frameNumber * msPerFrame)].
				simTime _ ms - msAtStart]
		ifFalse: [simTime _ scorePlayer millisecondsSinceStart].
	playDirection > 0
		ifTrue: [nextFrameNumber _ frameAtLastSync + ((simTime - msAtLastSync)//msPerFrame).
				nextFrameNumber = frameNumber ifTrue:
					[((scorePlayer isKindOf: AbstractSound) and: [scorePlayer isPlaying not])
						ifTrue: [^ self stopRunning].
					^ self]]
		ifFalse: [playDirection < 0 ifTrue: [nextFrameNumber _ frameNumber - 1]
								ifFalse: [nextFrameNumber _ frameNumber]].

	byteCount _ self fileByteCountPerFrame.
	self stepSoundTrack.
	movieFile waitForCompletion.
	movieFile primReadResult: movieFile fileHandle
			intoBuffer: (frameBufferIfScaled ifNil: [currentPage image]) bits
			at: 1 count: byteCount//4.
	frameBufferIfScaled ifNotNil:
		["If this player has been shrunk, then we have to warp to the current page."
		(WarpBlt current toForm: currentPage image) sourceForm: frameBufferIfScaled;
				combinationRule: 3;
						"Use smoothing if just stepping"
				cellSize: (playDirection = 0 ifTrue: [2] ifFalse: [1]);
				copyQuad: frameBufferIfScaled boundingBox innerCorners
					toRect: currentPage image boundingBox].
	currentPage changed.
	frameNumber _ nextFrameNumber.	

	(playDirection = 0
		or: [(playDirection > 0 and: [frameNumber >= frameCount])
		or: [playDirection < 0 and: [frameNumber <= 1]]])
		ifTrue: [^ self stopRunning].

	"Start the read operation for the next frame..."
	movieFile primReadStart: movieFile fileHandle
			fPosition: (self filePosForFrameNo: frameNumber)
			count: byteCount.
! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 9/6/2000 21:55'!
stepSoundTrack

	| x image timeInMillisecs |
	scorePlayer ifNil: [^ self].
	soundTrackForm ifNil: [^ self].
	playDirection = 0
		ifTrue: ["Stepping forward or back"
				timeInMillisecs _ frameNumber - 1 * msPerFrame]
		ifFalse: ["Driven by sound track"
				timeInMillisecs _ scorePlayer millisecondsSinceStart].
	x _ timeInMillisecs / 1000.0 * scorePlayer originalSamplingRate // 250.
	image _ soundTrackMorph image.
	image copy: (image boundingBox translateBy: (x - (image width//2)) @ 0)
			from: soundTrackForm to: 0@0 rule: Form over.
	soundTrackMorph changed.! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 8/8/1998 11:57'!
stepTime
	^ 0  "step as fast as possible"! !

!MoviePlayerMorph methodsFor: 'stepping' stamp: 'di 10/8/2000 22:27'!
stopRunning
	"Must only be called with no outstanding file read requests..."
	movieFile ifNotNil: [movieFile close.  movieFile _ nil].
	playDirection _ 0.
	self stopSoundTrackIfAny
! !


!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/13/2000 11:47'!
addSoundTrack

	| fileName |
	fileName _ Utilities chooseFileWithSuffixFromList: #('.aif' '.wav')
					withCaption: 'Choose a sound track file'.
	fileName == nil ifTrue: [^ self].
	soundTrackFileName _ fileName.
	self tryToShareScoreFor: soundTrackFileName.
	scorePlayer ifNil:
		[('*aif' match: fileName) ifTrue:
			[scorePlayer _ SampledSound fromAIFFfileNamed: fileName].
		('*wav' match: fileName) ifTrue:
			[scorePlayer _ SampledSound fromWaveFileNamed: fileName]].
	soundTrackForm ifNotNil:
		["Compute new soundTrack if we're showing it."
		self showHideSoundTrack; showHideSoundTrack]! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/19/2000 17:07'!
endClipHere
	"Change set the termination time for this clip via the endMorph"

	cueMorph ifNil: [^ self].
	cueMorph setEndFrameNumber: frameNumber
! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/28/2000 11:09'!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MVCMenuMorph new defaultTarget: self.
	aMenu add:	'make a new movie' action: #makeAMovie.
	aMenu add:	'open movie file' action: #openMovieFile.
	aMenu add:	'add sound track' action: #addSoundTrack.
	aMenu addLine.
	scorePlayer ifNotNil:
		[soundTrackForm == nil
			ifTrue: [aMenu add:	'show sound track' action: #showHideSoundTrack]
			ifFalse: [aMenu add:	'hide sound track' action: #showHideSoundTrack]].
	aMenu add:	'make thumbnail' action: #thumbnailForThisPage.
	cueMorph ifNotNil:
		["Should check if piano roll and score already have a start event
		prior to this time."
		aMenu add:	'end clip here' action: #endClipHere].

	aMenu popUpEvent: self world activeHand lastEvent in: self world
! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/24/2000 17:02'!
makeAMovie
	| scoreController score |
	frameSize _ 640@480.  frameDepth _ 16.  self makeMyPage; changed.

	(score _ MIDIScore new initialize) "addAmbientEvent: (AmbientEvent new time: 200*60)".
	scoreController _ ScorePlayerMorph new
			onScorePlayer: (ScorePlayer onScore: score) title: 'sMovie'.
	pianoRoll _ PianoRollScoreMorph new on: scoreController scorePlayer.
	self pianoRoll: pianoRoll.  "back link"
	pianoRoll enableDragNDrop;
		useRoundedCorners;
		movieClipPlayer: self;
		borderWidth: 2;
		extent: self width @ 120;
		align: pianoRoll topLeft with: self bottomLeft - (0@2);
		openInWorld.
	scoreController extent: self width @ scoreController height;
		align: scoreController topLeft with: pianoRoll bottomLeft - (0@2);
		openInWorld.

! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 9/7/2000 09:44'!
openMovieFile
	| fileName |
	fileName _ Utilities chooseFileWithSuffixFromList: #('.movie')
					withCaption: 'Choose a movie file to open'.
	fileName ifNotNil:
		[self openFileNamed: fileName.
		self showMoreControls]! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/16/2000 13:21'!
scanBySlider
	| scrollSlider handle |
	scrollSlider _ SimpleSliderMorph new extent: 150@10;
		color: color; sliderColor: Color gray;
		target: self; actionSelector: #goToRelativePosition:;
		adjustToValue: self relativePosition.
	(handle _ scrollSlider firstSubmorph) on: #mouseUp send: #delete to: scrollSlider.
	scrollSlider align: handle center with: self activeHand position.
	self world addMorph: scrollSlider.
	self activeHand targetOffset: (handle width // 2) @ 0.
	self activeHand newMouseFocus: handle! !

!MoviePlayerMorph methodsFor: 'menu' stamp: 'di 10/16/2000 13:31'!
thumbnailForThisPage
	"Overridden to make a MovieFrameSyncMorph"

	^ self makeThumbnailInHand: self activeHand
! !


!MoviePlayerMorph methodsFor: 'movie clip player' stamp: 'di 10/19/2000 22:02'!
pianoRoll
	^ pianoRoll! !

!MoviePlayerMorph methodsFor: 'movie clip player' stamp: 'di 10/4/2000 16:38'!
pianoRoll: aPianoRollScoreMorph
	"Provides access also to the score and scorePlayer"

	pianoRoll _ aPianoRollScoreMorph
! !


!MoviePlayerMorph methodsFor: 'private' stamp: 'di 10/24/2000 16:59'!
makeMyPage

	currentPage ifNotNil:
		[(currentPage isMemberOf: ImageMorph)
			ifTrue: ["currentPage is already an ImageMorph."
					(currentPage image extent = frameSize
						and: [currentPage image depth = frameDepth])
						ifTrue: [^ self  "page is already properly dimensioned."].
					^ currentPage image: (Form extent: frameSize depth: frameDepth)]
			ifFalse: [currentPage releaseCachedState; delete]].
	currentPage _ ImageMorph new image: (Form extent: frameSize depth: frameDepth).
	currentPage lock.
	pages _ OrderedCollection with: currentPage.
	self addMorphFront: currentPage! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'di 10/25/2000 23:01'!
makeThumbnailInHand: aHand

	scorePlayer ifNotNil:
		["Position the soundTrack for this frameNumber"
		scorePlayer reset; playSilentlyUntil: frameNumber - 1 * msPerFrame / 1000.0].

	aHand attachMorph:
		(MovieClipStartMorph new
			movieFileName: movieFileName
			soundTrackFileName: soundTrackFileName
			image: currentPage image
			player: self
			frameNumber: frameNumber)
! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'di 10/17/2000 08:45'!
pvtOpenFileNamed: fName
	| f w h d n m |
	self stopRunning.
	fName = movieFileName ifTrue: [^ self].  "No reopen necessary on same file"

	movieFileName _ fName.
	"Read movie file parameters from 128-byte header...
		(records follow as {N=int32, N words}*)"
	f _ (FileStream oldFileNamed: movieFileName) binary.
		f nextInt32.
		w _ f nextInt32.
		h _ f nextInt32.
		d _ f nextInt32.
		n _ f nextInt32.
		m _ f nextInt32.
		f close.
	pageSize _ frameSize _ w@h.
	frameDepth _ d.
	frameCount _ n.
	frameNumber _ 1.
	playDirection _ 0.
	msAtLastSync _ 0.
	msPerFrame _ m/1000.0.
	self makeMyPage.
	(Smalltalk extraVMMemory < self fileByteCountPerFrame) ifTrue:
		[^ PopUpMenu notify:
'Playing movies in Squeak requires that extra memory be allocated
for asynchronous file IO.  This particular movie requires a buffer of
' ,
(self fileByteCountPerFrame printString) , ' bytes, but you only have ' , (Smalltalk extraVMMemory printString) , ' allocated.
You can evaluate ''Smalltalk extraVMMemory'' to check your allocation,
and ''Smalltalk extraVMMemory: 485000'' or the like to increase your allocation.
Note that raising your allocation in this way only marks your image as
needing this much, so you must then save, quit, and start over again
before you can run this movie.  Good luck.'].
! !

!MoviePlayerMorph methodsFor: 'private' stamp: 'di 10/22/2000 10:39'!
tryToShareScoreFor: fileName

	scorePlayer _ nil.
	self class allInstancesDo:
		[:mp | mp == self ifFalse:
			[mp soundTrackFileName = fileName ifTrue:
				["Found this score already open in another player
					-- return a copy that shares the same sound buffer."
				mp scorePlayer ifNotNil: [^ scorePlayer _ mp scorePlayer copy reset]]]]! !
HttpUrl subclass: #MswUrl
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!MswUrl commentStamp: '<historical>' prior: 0!
(out of date class....)!


!MswUrl methodsFor: 'misc' stamp: 'ls 7/1/1998 02:23'!
httpUrlOfServer
	"return the HTTP address to make queries to"	
	#XXX.  "should come up with a better name for this when I'm less tired"
	^HttpUrl schemeName: 'http'  authority: authority  path: path  query: nil.! !


!MswUrl methodsFor: 'access' stamp: 'ls 7/12/1998 23:34'!
query
	"return the query.  There is never a MuSwiki URL without a query; the query defaults to 'top' if none is explicitly specified"
	| q |
	q _ super query.
	q isNil ifTrue: [ q _ 'top' ].
	^q! !
SoundCodec subclass: #MuLawCodec
	instanceVariableNames: ''
	classVariableNames: 'DecodingTable '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!MuLawCodec commentStamp: '<historical>' prior: 0!
I represent a mu-law (u-law) codec. I compress sound data by a factor of 2:1 by encoding the most significant 12 bits of each 16-bit sample as a signed, exponentially encoded byte. The idea is to use more resolution for smaller lower sample values. This encoding was developed for the North American phone system and a variant of it, a-law, is a European phone standard. It is a popular sound encoding on Unix platforms (.au files).
!


!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:15'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	^ 1
! !

!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 14:10'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| dst |
	dst _ dstIndex.
	srcIndex to: srcIndex + frameCount - 1 do: [:src |
		dstSoundBuffer at: dst put: (DecodingTable at: (srcByteArray at: src) + 1).
		dst _ dst + 1].
	^ Array with: frameCount with: frameCount
! !

!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'di 2/8/1999 22:25'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	srcIndex to: srcIndex + frameCount - 1 do: [:i |
		dstByteArray at: i put: (self uLawEncodeSample: (srcSoundBuffer at: i))].
	^ Array with: frameCount with: frameCount
! !

!MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:11'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	^ 1
! !


!MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:28'!
uLawDecodeSample: byte
	"Decode a 16-bit signed sample from 8 bits using uLaw decoding"

	^ DecodingTable at: byte + 1! !

!MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:30'!
uLawEncodeSample: sample
	"Encode a 16-bit signed sample into 8 bits using uLaw encoding"

	| s |
	s _ sample // 8.  "drop 3 least significant bits"
	s < 0 ifTrue: [^ (self uLawEncode12Bits: 0-s) + 16r80]
		ifFalse: [^ (self uLawEncode12Bits: s)].
! !


!MuLawCodec methodsFor: 'private' stamp: 'di 2/9/1999 13:25'!
uLawEncode12Bits: s
	"Encode a 12-bit unsigned sample (0-4095) into 7 bits using uLaw encoding.
	This gets called by a method that scales 16-bit signed integers down to a
		12-bit magnitude, and then ORs in 16r80 if they were negative.
	Detail: May get called with s >= 4096, and this works fine."

	s < 496 ifTrue: [
		s < 112 ifTrue: [
			s < 48 ifTrue: [
				s < 16
					ifTrue: [^ 16r70 bitOr: (15 - s)]
					ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
			^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
		s < 240
			ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
			ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].

	s < 2032 ifTrue: [
		s < 1008
			ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
			ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].

	s < 4080
		ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
		ifFalse: [^ 0].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MuLawCodec class
	instanceVariableNames: ''!

!MuLawCodec class methodsFor: 'class initialization' stamp: 'di 2/9/1999 14:57'!
initialize
	"Build the 256 entry table to be used to decode 8-bit uLaw-encoded samples."
	"MuLawCodec initialize"

	| encoded codec lastEncodedPos lastEncodedNeg |
	DecodingTable _ Array new: 256.
	codec _ self new.
	lastEncodedPos _ nil.
	lastEncodedNeg _ nil.
	4095 to: 0 by: -1 do: [:s |
		encoded _ codec uLawEncode12Bits: s.
		lastEncodedPos = encoded
			ifFalse: [
				DecodingTable at: (encoded + 1) put: (s bitShift: 3).
				lastEncodedPos _ encoded].
		encoded _ encoded bitOr: 16r80.
		lastEncodedNeg = encoded
			ifFalse: [
				DecodingTable at: (encoded + 1) put: (s bitShift: 3) negated.
				lastEncodedNeg _ encoded]].
! !
PluggableCanvas subclass: #MultiCanvas
	instanceVariableNames: 'canvases extent depth '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!MultiCanvas commentStamp: '<historical>' prior: 0!
A canvas which forwards drawing commands to sub-canvases.!


!MultiCanvas methodsFor: 'initialization' stamp: 'RAA 8/1/2000 13:50'!
allocateForm: extentPoint
	"Allocate a new form which is similar to the receiver and can be used for accelerated blts"
	^Form extent: extentPoint depth: self depth! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
depth
	^depth! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
depth: newDepth
	"set the extent to be used with this canvas"
	depth := newDepth.! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:35'!
extent
	^extent! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'!
extent: newExtent
	"set the extent to be used with this canvas"
	extent := newExtent.! !

!MultiCanvas methodsFor: 'initialization' stamp: 'ls 4/8/2000 22:34'!
initialize
	canvases := Set new.
	extent := 600@400.
	depth := 32. ! !


!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'!
addCanvas: aCanvas
	canvases add: aCanvas! !

!MultiCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 17:46'!
clipRect
	
	^super clipRect ifNil: [
		0@0 extent: 5000@5000
	].! !

!MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'!
removeCanvas: aCanvas
	canvases remove: aCanvas ifAbsent: []! !


!MultiCanvas methodsFor: 'private' stamp: 'RAA 11/6/2000 14:17'!
apply: aCommand

	self flag: #roundedRudeness.	
	"This rudeness is to help get rounded corners to work right on RemoteCanvases. Since the RemoteCanvas has no other way to read its bits, we are grabbing them from Display for now. To support this, we need to see that the Display is written before any RemoteCanvases"

	canvases do: [ :canvas | 
		(canvas isKindOf: FormCanvas) ifTrue: [aCommand value: canvas]
	].
	canvases do: [ :canvas | 
		(canvas isKindOf: FormCanvas) ifFalse: [aCommand value: canvas]
	].
! !

!MultiCanvas methodsFor: 'private' stamp: 'RAA 8/14/2000 10:27'!
contentsOfArea: aRectangle into: aForm

	self apply: [ :c |
		(c isKindOf: FormCanvas) ifTrue: [
			c contentsOfArea: aRectangle into: aForm.
			^aForm
		].
	].
	self apply: [ :c |
		c contentsOfArea: aRectangle into: aForm.
		^aForm.
	].
	^aForm! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MultiCanvas class
	instanceVariableNames: ''!

!MultiCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:49'!
new
	^super new initialize! !
FormCanvas subclass: #MultiResolutionCanvas
	instanceVariableNames: 'deferredMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/4/2000 12:00'!
deferredMorphs

	^deferredMorphs! !

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/4/2000 11:58'!
deferredMorphs: aCollection

	deferredMorphs _ aCollection! !

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/4/2000 12:00'!
fullDraw: aMorph

	aMorph canDrawAtHigherResolution ifTrue: [
		deferredMorphs ifNil: [deferredMorphs _ OrderedCollection new].
		deferredMorphs add: aMorph.
	] ifFalse: [
		super fullDraw: aMorph
	].! !

!MultiResolutionCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 12/17/2000 13:25'!
initializeFrom: aFormCanvas

	origin _ aFormCanvas origin.
	clipRect _ aFormCanvas privateClipRect.
	form _ aFormCanvas form.
	port _ aFormCanvas privatePort.
	shadowColor _ aFormCanvas shadowColor.
! !
SketchMorph subclass: #MultiuserTinyPaint
	instanceVariableNames: 'drawState '
	classVariableNames: 'LastMouseIndex PenColorIndex PenIndex PenSizeIndex '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!MultiuserTinyPaint commentStamp: '<historical>' prior: 0!
A very simple paint program that handles multiple users (hands).
Each user has their own brush size and color.
!


!MultiuserTinyPaint methodsFor: 'initialization' stamp: 'jm 11/4/97 07:15'!
initialize

	super initialize.
	color _ Color veryVeryLightGray.
	drawState _ IdentityDictionary new.
	self clear.
! !


!MultiuserTinyPaint methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

	^ true
! !

!MultiuserTinyPaint methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
mouseDown: evt

	| state |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.
	state at: LastMouseIndex put: evt cursorPoint.
! !

!MultiuserTinyPaint methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
mouseMove: evt

	| state lastP p pen |
	state _ drawState at: evt hand ifAbsent: [^ self].
	lastP _ state at: LastMouseIndex.
	p _ evt cursorPoint.
	p = lastP ifTrue: [^ self].

	pen _ state at: PenIndex.
	pen drawFrom: lastP - bounds origin to: p - bounds origin.
	self invalidRect: (
		((lastP min: p) - pen sourceForm extent) corner:
		((lastP max: p) + pen sourceForm extent)).
	state at: LastMouseIndex put: p.
! !


!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/26/97 14:50'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'clear' action: #clear.
	aCustomMenu add: 'pen color' action: #setPenColor:.
	aCustomMenu add: 'pen size' action: #setPenSize:.
"	aCustomMenu add: 'fill' action: #fill:."
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor hand: hand

	| state |
	(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
	state _ drawState at: hand.
	(state at: PenIndex) color: aColor.
	state at: PenColorIndex put: aColor.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
clear

	| newPen |
	self form: ((Form extent: 400@300 depth: 8) fillColor: color).
	drawState do: [:state |
		newPen _ Pen newOnForm: originalForm.
		newPen roundNib: (state at: PenSizeIndex).
		newPen color: (state at: PenColorIndex).
		state at: PenIndex put: newPen].
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 19:12'!
fill: evt

	| state fillPt |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.

	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: (state at: PenColorIndex) interiorPoint: fillPt.
	self changed.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'jm 9/26/97 14:47'!
penSize: anInteger hand: hand

	| state |
	(drawState includesKey: hand) ifFalse: [self createDrawStateFor: hand].
	state _ drawState at: hand.
	state at: PenSizeIndex put: anInteger.
	(state at: PenIndex) roundNib: anInteger.
! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:52'!
setPenColor: evt
	| state |
	(drawState includesKey: evt hand) ifFalse: [self createDrawStateFor: evt hand].
	state _ drawState at: evt hand.
	self changeColorTarget: self selector: #brushColor:hand: originalColor: (state at: PenColorIndex) hand: evt hand! !

!MultiuserTinyPaint methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:07'!
setPenSize: evt

	| menu sizes |
	menu _ MenuMorph new.
	sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w |
		menu add: w printString
			target: self
			selector: #penSize:hand:
			argumentList: (Array with: w with: evt hand)].

	menu popUpEvent: evt in: self world! !


!MultiuserTinyPaint methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
createDrawStateFor: aHand

	| pen state |
	pen _ Pen newOnForm: originalForm.
	state _ Array new: 4.
	state at: PenIndex put: pen.
	state at: PenSizeIndex put: 3.
	state at: PenColorIndex put: Color red.
	state at: LastMouseIndex put: nil.
	drawState at: aHand put: state.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MultiuserTinyPaint class
	instanceVariableNames: ''!

!MultiuserTinyPaint class methodsFor: 'class initialization' stamp: 'jm 11/4/97 07:15'!
initialize
	"MultiuserTinyPaint initialize"

	"indices into the state array for a given hand"
	PenIndex _ 1.
	PenSizeIndex _ 2.
	PenColorIndex _ 3.
	LastMouseIndex _ 4.
! !
Error subclass: #MyResumableTestError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Tests'!

!MyResumableTestError methodsFor: 'exceptionDescription' stamp: 'tfei 6/13/1999 00:46'!
isResumable

	^true! !
Error subclass: #MyTestError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Tests'!
Notification subclass: #MyTestNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Tests'!
UpdatingStringMorph subclass: #NameStringInHalo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'sw 9/17/1999 13:41'!
cancelEdits
	self interimContents: target externalName.
	super cancelEdits! !

!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'sw 9/7/1999 21:27'!
drawOn: aCanvas
	aCanvas fillRectangle: self bounds color: Color white.
	super drawOn: aCanvas.! !

!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'sw 9/17/1999 13:17'!
interimContents: aString
	self contents: aString.
	self placeContents! !

!NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'di 11/25/1999 23:40'!
placeContents
	| namePosition |
	(owner notNil and: [owner isInWorld]) ifTrue:
		[namePosition _ owner basicBox bottomCenter -
			((self width // 2) @ (owner handleSize negated // 2 - 1)).
		namePosition _ namePosition min: self world viewBox bottomRight - self extent y + 2.
		self bounds: (namePosition extent: self extent)]! !
Object subclass: #NebraskaClient
	instanceVariableNames: 'connection encoder hand canvas '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!NebraskaClient commentStamp: '<historical>' prior: 0!
A client that has connected to a Nebraska server, seen from the server's point of view.!


!NebraskaClient methodsFor: 'network' stamp: 'ls 4/9/2000 14:43'!
extent: newExtent  depth: newDepth
	encoder extent: newExtent  depth: newDepth! !

!NebraskaClient methodsFor: 'network' stamp: 'ls 3/25/2000 22:25'!
isConnected
	^connection isConnected! !

!NebraskaClient methodsFor: 'network' stamp: 'ls 3/25/2000 22:25'!
processIO
	connection processIO.! !


!NebraskaClient methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:05'!
convertToBuffered

	canvas purgeOutputQueue.
	canvas _ canvas asBufferedCanvas.! !

!NebraskaClient methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:28'!
destroy
	hand ifNotNil:[hand world ifNotNil:[hand world removeHand: hand]].
	connection ifNotNil:[connection destroy].
	encoder _ canvas _ hand _ connection _ nil.! !

!NebraskaClient methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:14'!
initialize: aConnection

	| remoteAddress userPicture |

	connection := aConnection.
	hand := RemoteControlledHandMorph on: (MorphicEventDecoder on: aConnection).
	hand nebraskaClient: self.
	remoteAddress _ connection remoteAddress.
	remoteAddress ifNotNil: [remoteAddress _ NetNameResolver stringFromAddress: remoteAddress].
	userPicture _ EToySenderMorph pictureForIPAddress: remoteAddress.
	hand
		userInitials: ((EToySenderMorph nameForIPAddress: remoteAddress) ifNil: ['???'])
		andPicture: (userPicture ifNotNil: [userPicture scaledToSize: 16@20]).
	encoder := CanvasEncoder on: aConnection.
	canvas := RemoteCanvas
		connection: encoder
		clipRect: NebraskaServer extremelyBigRectangle
		transform: MorphicTransform identity! !


!NebraskaClient methodsFor: 'attributes' stamp: 'ls 3/25/2000 22:27'!
canvas
	"return the hand this canvas that should be drawn on for this client"
	^canvas! !

!NebraskaClient methodsFor: 'attributes' stamp: 'ls 3/25/2000 22:27'!
hand
	"return the hand this client is controlling"
	^hand! !


!NebraskaClient methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 23:59'!
backlog

	^connection backlog! !

!NebraskaClient methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:30'!
currentStatusString

	(connection isNil or: [connection isConnected not]) ifTrue: [^'nada'].
	^(NetNameResolver stringFromAddress: connection remoteAddress),
		' - ',
		(self backlog // 1024) printString,'k'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NebraskaClient class
	instanceVariableNames: ''!

!NebraskaClient class methodsFor: 'instance creation' stamp: 'ls 3/25/2000 22:28'!
onConnection: aStringSocket
	^self new initialize: aStringSocket! !
Object subclass: #NebraskaDebug
	instanceVariableNames: ''
	classVariableNames: 'DEBUG Details '
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!NebraskaDebug commentStamp: '<historical>' prior: 0!
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.

NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug stopAndShowAll
NebraskaDebug killStats
StringSocket showRatesSeen
StringSocket clearRatesSeen
NebraskaDebug showAndClearStats: #allStats
NebraskaDebug showAndClearStats: #queuedbufferSizes


CanvasEncoder beginStats
CanvasEncoder showStats
CanvasEncoder killStats
NebraskaDebug showStats: #peerBytesSent
NebraskaDebug showStats: #soundReductionTime
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug showStats: #SendReceiveStats
NebraskaDebug showStats: #sendDeltas
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #sketch
NebraskaDebug showStats: #addToOutBuf:
----
buffered off, painting 125kb/s, dragging 400kb/s
buffered on, painting 100kb/s, dragging 170kb/s!
]style[(62 142 14 78 17 3 73 415)f1cblue;,f1cblack;,f1,f1cblack;,f1cred;,f1cblack;,f1cblue;,f1cblack;!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NebraskaDebug class
	instanceVariableNames: ''!

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 13:41'!
at: queueName add: anArray

	| now |

	DEBUG ifNil: [
		queueName == #sketchZZZ ifFalse: [^self].
		"Details _ OrderedCollection new."
		self beginStats.
	].
	(Details notNil and: [Details size < 20]) ifTrue: [
		Details add: thisContext longStack
	].
	now _ Time millisecondClockValue.
	DEBUG add: {now},anArray,{queueName}.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:33'!
beginStats

	DEBUG _ OrderedCollection new! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/13/2000 19:22'!
killStats

	DEBUG _ nil.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:34'!
showAndClearStats: queueName

	DEBUG ifNil: [^1 beep].
	self 
		showStats: queueName 
		from: DEBUG.
	DEBUG _ nil.! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 09:03'!
showStats

	DEBUG ifNil: [^1 beep].
	DEBUG explore.! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:35'!
showStats: queueName

	DEBUG ifNil: [^1 beep].
	self 
		showStats: queueName 
		from: DEBUG.
! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:44'!
showStats: queueName from: aCollection

	| xx answer prevTime currTime |

	prevTime _ nil.
	answer _ String streamContents: [ :s | 
		s nextPutAll: (aCollection last first - aCollection first first) asStringWithCommas,' ms';cr;cr.
		aCollection withIndexDo: [ :each :index | 
			(queueName == #allStats or: [queueName == each last]) ifTrue: [
				currTime _ each first.
				xx _ currTime printString.
				prevTime ifNil: [prevTime _ currTime].
				s nextPutAll: index printString,'.  ',
					(xx allButLast: 3),'.',(xx last: 3),' ',(currTime - prevTime) printString,' '.
				s nextPutAll: each allButFirst printString; cr.
				prevTime _ currTime.
			].
		]
	].
	StringHolder new 
		contents: answer;
		openLabel: queueName! !

!NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 10:36'!
stopAndShowAll

	| prev |

self halt.	"not updated to new format"

	prev _ DEBUG.
	DEBUG _ nil.
	prev ifNil: [^1 beep].
	prev keysAndValuesDo: [ :k :v |
		self showStats: k from: v
	].! !
ProjectNavigationMorph subclass: #NebraskaNavigationMorph
	instanceVariableNames: 'nebraskaBorder nebraskaTerminal '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:49'!
addButtons

	self addARow: {
		self inAColumn: {self buttonScale}.
		self inAColumn: {self buttonQuit}.
		self inAColumn: {self buttonBuffered}.
	}.
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:26'!
bufferNebraska

	nebraskaTerminal requestBufferedConnection
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:23'!
buttonBuffered

	^self makeButton: 'B' balloonText: 'Request buffered Nebraska session' for: #bufferNebraska
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:36'!
buttonQuit

	^self makeButton: 'Quit' balloonText: 'Quit this Nebraska session' for: #quitNebraska
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:34'!
buttonScale

	^self makeButton: '1x1' balloonText: 'Switch between 1x1 and scaled view' for: #toggleFullView
! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:47'!
currentNavigatorVersion

	^1		"not particularly relevant here"! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:27'!
fontForButtons

	^Preferences standardButtonFont! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:29'!
initialColor

	^Color yellow! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:35'!
nebraskaBorder: aNebraskaBorder

	nebraskaBorder _ aNebraskaBorder! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 08:25'!
nebraskaTerminal: aNebraskaTerminal

	nebraskaTerminal _ aNebraskaTerminal! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:44'!
positionVertically

	| w |
	w _ self world ifNil: [^self].
	self top < w top ifTrue: [self top: w top].
	self bottom > w bottom ifTrue: [self bottom: w bottom].! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:47'!
quitNebraska

	nebraskaBorder ifNotNil: [nebraskaBorder delete].
	self delete.! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:37'!
step

	super step.
	(nebraskaBorder isNil or: [nebraskaBorder world isNil]) ifTrue: [self delete].! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:48'!
toggleFullView

	nebraskaBorder ifNotNil: [nebraskaBorder toggleFullView]! !

!NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:42'!
wantsToBeDroppedInto: aMorph

	"avoid difficulties in placement"
	^(aMorph isKindOf: NetworkTerminalMorph) not! !
Model subclass: #NebraskaServer
	instanceVariableNames: 'worldDepth world clients listenQueue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!NebraskaServer commentStamp: '<historical>' prior: 0!
A Nebraska server has a private world and some collection of clients.  It associates a RemoteControlledHand for each client.  Redraw events in the world are broadcasted to all connected clients.  A Nebraska server can listen on a TCP/IP port and accept new clients. Current version has been modified so that the server serves the world in which it was launched. Other variations are certainly possible.

To start a server, execute the following code:
	NebraskaServerMorph serveWorld: World

To start a client, run the following in another image:
	NetworkTerminalMorph openAndConnectTo: 'servername'

Fill in your server's hostname for 'servername'. At this point, everything should be working!!

Before starting a server, you can tweak these:
BufferedCanvas enabled: false.
BufferedCanvas enabled: true.

At any time you can do these:
NebraskaDebug beginStats
NebraskaDebug showStats
NebraskaDebug showStats: #delays
NebraskaDebug showStats: #bigImage
NebraskaDebug showStats: #FormEncodeTimes
NebraskaDebug killStats

NOTE: if you want to have a local view of the server, you shouldn't use the TCP connections. The problem is that the server will occasionally do a #flush, and it won't work due to single threading. The better solution is to use a LoopBackStringSocket instead of a regular StringSocket, but there is no handy method for that right now....


!
]style[(266 136 49 39 56 53 96 46 1 62 29 525)f1,f1cred;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cred;,f1cblue;,f1!


!NebraskaServer methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:02'!
destroy
	self stopListening.
	clients do:[:each| each destroy].
	self breakDependents.! !

!NebraskaServer methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:20'!
initialize
	clients := IdentitySet new.
	self extent: 800@600 depth: 16.! !

!NebraskaServer methodsFor: 'initialization' stamp: 'ar 10/26/2000 13:49'!
initializeForWorld: aWorld

	world _ aWorld.
	clients _ IdentitySet new.
	self extent: world extent depth: Display depth.
	aWorld remoteServer: self.! !


!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:35'!
acceptNewConnections
	| connection |
	listenQueue ifNil: [ ^self ].
	[ clients size > 20 ifTrue: [ "too many connections!!" ^self ].
	  connection := listenQueue getConnectionOrNil.  
	  connection isNil ] 
	whileFalse: [
	  self addClientFromConnection: (StringSocket on: connection) ].! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 7/22/2000 07:23'!
acceptNullConnection

	| twins |

	twins _ LoopbackStringSocket newPair.
	self addClientFromConnection: twins first.
	(NullTerminalMorph new connection: twins second) openInWorld.
! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 7/20/2000 12:57'!
acceptPhonyConnection

	| twins |

	twins _ LoopbackStringSocket newPair.
	self addClientFromConnection: twins first.
	(NetworkTerminalMorph new connection: twins second) inspect "openInWorld".
! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 7/20/2000 10:03'!
addClientFromConnection: connection
	| client |

	client := NebraskaClient onConnection: connection.
	clients add: client.
	client extent: world extent  depth: worldDepth.
	world addRemoteClient: client.
	self changed: #numClients.! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 8/1/2000 00:01'!
backlog

	^clients inject: 0 into: [ :max :each | max max: each backlog]! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:36'!
processIO
	self pruneDeadConnections.
	self acceptNewConnections.! !

!NebraskaServer methodsFor: 'networking' stamp: 'ar 10/26/2000 14:20'!
pruneDeadConnections
	| deadConnections |
	deadConnections := clients select: [ :client | client isConnected not ].
	deadConnections do: [ :client |
		world removeRemoteClient: client].

	deadConnections isEmpty ifTrue:[ ^self ].

	clients removeAll: deadConnections.
	self changed: #numClients.! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:31'!
startListeningOnPort: portNumber
	Socket initializeNetwork.
	self stopListening.
	listenQueue := ConnectionQueue portNumber: portNumber  queueLength: 5.! !

!NebraskaServer methodsFor: 'networking' stamp: 'RAA 7/31/2000 22:28'!
step

	self processIO.

	"savedWorld := Processor activeProcess world.
	Processor activeProcess setWorld: world."

	self flag: #bob.		"in this version, world is THE WORLD, so it steps itself"
	"world doOneCycle."

	"Processor activeProcess setWorld: savedWorld."

	clients do: [ :each | each canvas apply: [ :ignore | ]].	"for modes that need a little push"
! !

!NebraskaServer methodsFor: 'networking' stamp: 'ls 3/25/2000 22:32'!
stopListening
	listenQueue ifNil: [ ^self ].
	listenQueue destroy.
	listenQueue := nil.! !


!NebraskaServer methodsFor: 'attributes' stamp: 'ls 4/11/2000 19:48'!
extent: newExtent  depth: newDepth
	"modify the extent and/or depth of the shared world"
	clients do: [ :client |
		client extent: newExtent depth: newDepth ].
	world extent: newExtent.

	worldDepth := newDepth.! !

!NebraskaServer methodsFor: 'attributes' stamp: 'ls 4/11/2000 18:41'!
numClients
	"return the number of connected clients"
	^clients size! !

!NebraskaServer methodsFor: 'attributes' stamp: 'ls 3/25/2000 23:13'!
sharedWorld
	^world! !


!NebraskaServer methodsFor: 'accessing' stamp: 'ar 10/26/2000 14:23'!
clients
	^clients ifNil:[#()].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NebraskaServer class
	instanceVariableNames: ''!

!NebraskaServer class methodsFor: 'instance creation' stamp: 'ls 3/25/2000 22:39'!
new
	^super new initialize! !

!NebraskaServer class methodsFor: 'instance creation' stamp: 'RAA 7/20/2000 10:24'!
newForWorld: aWorld

	^super new initializeForWorld: aWorld! !

!NebraskaServer class methodsFor: 'instance creation' stamp: 'ar 10/26/2000 14:00'!
serveWorld: aWorld

	^self serveWorld: aWorld onPort: self defaultPort! !

!NebraskaServer class methodsFor: 'instance creation' stamp: 'RAA 11/6/2000 17:22'!
serveWorld: aWorld onPort: aPortNumber

	| server |

	Utilities authorName.	"since we will need it later"

	server _ self newForWorld: aWorld.
	server startListeningOnPort: aPortNumber.
	^server
	"server acceptNullConnection"		"server acceptPhonyConnection."
! !


!NebraskaServer class methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/2000 12:06'!
defaultPort

	^9091! !

!NebraskaServer class methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 14:59'!
extremelyBigRectangle

	^(0@0 extent: 5000@5000)! !
AlignmentMorphBob1 subclass: #NebraskaServerMorph
	instanceVariableNames: 'server slowCounter previousBacklog lastFullUpdateTime currentStatusString fullDisplay previousClients '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!NebraskaServerMorph commentStamp: '<historical>' prior: 0!
A cheezy morph that simply steps a Nebraska server instance over and over.!


!NebraskaServerMorph methodsFor: 'initialization' stamp: 'RAA 12/11/2000 11:42'!
initialize

	super initialize.
	fullDisplay _ true.
	color _ Color white.
	lastFullUpdateTime _ 0.
	self listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'RAA 12/11/2000 12:22'!
rebuild

	| myServer |

	self removeAllMorphs.
	self updateCurrentStatusString.
	self addARow: {
		self inAColumn: {
			SimpleButtonMorph new target: self; actionSelector: #delete; label: 'X'.
		}.
		self inAColumn: {
			UpdatingStringMorph new
				useStringFormat;
				target:  self;
				getSelector: #currentStatusString;
				contents: self currentStatusString;
				stepTime: 2000;
				lock.
		}.
		self inAColumn: {
			SimpleButtonMorph new target: self; actionSelector: #toggleFull; label: 'O'.
		}.
	}.
	myServer _ self server.
	(myServer isNil or: [fullDisplay not]) ifTrue: [
		^World startSteppingSubmorphsOf: self
	].
	self addARow: {
		self inAColumn: {
			(StringMorph contents: '--clients--') lock.
		}.
	}.

	myServer clients do: [ :each |
		self addARow: {
			UpdatingStringMorph new
				useStringFormat;
				target: each;
				getSelector: #currentStatusString;
				contents: each currentStatusString;
				stepTime: 2000;
				lock.
		}
	].
	World startSteppingSubmorphsOf: self.! !

!NebraskaServerMorph methodsFor: 'initialization' stamp: 'RAA 11/8/2000 16:13'!
toggleFull

	fullDisplay _ fullDisplay not.
	self rebuild.
! !


!NebraskaServerMorph methodsFor: 'stepping and presenter' stamp: 'RAA 11/8/2000 15:57'!
stepTime

	^10! !

!NebraskaServerMorph methodsFor: 'stepping and presenter' stamp: 'RAA 11/8/2000 16:03'!
update: aSymbol

	self rebuild.! !


!NebraskaServerMorph methodsFor: 'structure' stamp: 'ar 10/26/2000 14:07'!
delete
	self server ifNotNil:[
		(self confirm:'Shutdown the server?') 
			ifTrue:[self world remoteServer: nil]].
	super delete.! !

!NebraskaServerMorph methodsFor: 'structure' stamp: 'RAA 12/11/2000 12:19'!
step

	| now |

	self server ifNil: [ ^self ].
	self server step.
	now _ Time millisecondClockValue.
	(now - lastFullUpdateTime) abs > 5000 ifTrue: [
		lastFullUpdateTime _ now.
		(previousBacklog = self server backlog and: [self server clients = previousClients]) ifFalse: [
			previousClients _ self server clients copy.
			self rebuild
		]
	].
! !


!NebraskaServerMorph methodsFor: 'drawing' stamp: 'RAA 12/13/2000 08:31'!
updateCurrentStatusString

	self server ifNil:[
		currentStatusString _ '<server not active>'
	] ifNotNil:[
		currentStatusString _ 
			'server with ', 
			self server numClients printString, 
			' clients  ',
			((previousBacklog _ self server backlog) // 1024) printString,'k'
	].
! !


!NebraskaServerMorph methodsFor: 'accessing' stamp: 'RAA 11/8/2000 16:07'!
currentStatusString

	^currentStatusString! !

!NebraskaServerMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 14:05'!
server
	^self world remoteServer! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NebraskaServerMorph class
	instanceVariableNames: ''!

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/15/2000 14:49'!
killOldServers

	NebraskaServerMorph allInstances do: [ :each |
		each delete.
	].
	NebraskaServer allInstances do: [ :each |
		each stopListening.
		DependentsFields removeKey: each ifAbsent: [].
	].
! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 14:55'!
serveWorld: aWorld
	^self serveWorld: aWorld onPort: NebraskaServer defaultPort! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 14:05'!
serveWorld: aWorld onPort: aPortNumber

	| server |
	server := NebraskaServer serveWorld: aWorld onPort: aPortNumber.
	(self new) openInWorld: aWorld.

	"server acceptNullConnection"		"server acceptPhonyConnection."
! !
Object subclass: #NetNameResolver
	instanceVariableNames: ''
	classVariableNames: 'DefaultHostName HaveNetwork LastContact ResolverBusy ResolverError ResolverReady ResolverSemaphore ResolverUninitialized '
	poolDictionaries: ''
	category: 'Network-Kernel'!
!NetNameResolver commentStamp: '<historical>' prior: 0!
This class implements TCP/IP style network name lookup and translation facilities.

Attempt to keep track of whether there is a network available.
HaveNetwork	true if last attempt to contact the network was successful.
LastContact		Time of that contact (totalSeconds).
haveNetwork	returns true, false, or #expired.  True means there was contact in the last 30 minutes.  False means contact failed or was false last time we asked.  Get out of false state by making contact with a server in some way (FileList or updates).!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NetNameResolver class
	instanceVariableNames: ''!

!NetNameResolver class methodsFor: 'class initialization' stamp: 'jm 9/17/97 16:18'!
initialize
	"NetNameResolver initialize"
	"Note: On the Mac, the name resolver is asynchronous (i.e., Squeak can do other things while it is working), but can only handle one request at a time. On other platforms, such as Unix, the resolver is synchronous; a call to, say, the name lookup primitive will block all Squeak processes until it returns."

	"Resolver Status Values"
	ResolverUninitialized _ 0.	"network is not initialized"
	ResolverReady _ 1.			"resolver idle, last request succeeded"
	ResolverBusy _ 2.			"lookup in progress"
	ResolverError _ 3.			"resolver idle, last request failed"

	DefaultHostName _ ''.
! !


!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 06:19'!
addressFromString: addressString
	"Return the internet address represented by the given string. The string should contain four positive decimal integers delimited by periods, commas, or spaces, where each integer represents one address byte. Return nil if the string is not a host address in an acceptable format."
	"NetNameResolver addressFromString: '1.2.3.4'"
	"NetNameResolver addressFromString: '1,2,3,4'"
	"NetNameResolver addressFromString: '1 2 3 4'"

	| newAddr s byte delimiter |
	newAddr _ ByteArray new: 4.
	s _ ReadStream on: addressString.
	s skipSeparators.
	1 to: 4 do: [:i |
		byte _ self readDecimalByteFrom: s.
		byte = nil ifTrue: [^ nil].
		newAddr at: i put: byte.
		i < 4 ifTrue: [
			delimiter _ s next.
			((delimiter = $.) or: [(delimiter = $,) or: [delimiter = $ ]])
				ifFalse: [^ nil]]].
	^ newAddr
! !

!NetNameResolver class methodsFor: 'address string utils' stamp: 'jm 9/15/97 16:52'!
stringFromAddress: addr
	"Return a string representing the given host address as four decimal bytes delimited with decimal points."
	"NetNameResolver stringFromAddress: NetNameResolver localHostAddress"

	| s |
	s _ WriteStream on: ''.
	1 to: 3 do: [ :i | (addr at: i) printOn: s. s nextPut: $.].
	(addr at: 4) printOn: s.
	^ s contents
! !


!NetNameResolver class methodsFor: 'lookups' stamp: 'ls 9/5/1998 01:14'!
addressForName: aString
	^self addressForName: aString timeout: 60! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 17:35'!
addressForName: hostName timeout: secs
	"Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds."
	"NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30"
	"NetNameResolver addressForName: '100000jobs.de' timeout: 30"
	"NetNameResolver addressForName: '1.7.6.4' timeout: 30"
	"NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)"

	| deadline ready success result |

	"check if this is a valid numeric host address (e.g. 1.2.3.4)"
	result _ self addressFromString: hostName.
	result isNil ifFalse: [^result].

	"Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)"
	deadline _ Time millisecondClockValue + (secs * 1000).
	ready _ self waitForResolverReadyUntil: deadline.
	ready ifFalse: [^ nil].

	self primStartLookupOfName: hostName.
	success _ self waitForCompletionUntil: deadline.
	success
		ifTrue: [^ self primNameLookupResult]
		ifFalse: [^ nil].
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:52'!
localAddressString
	"Return a string representing the local host address as four decimal bytes delimited with decimal points."
	"NetNameResolver localAddressString"

	^ NetNameResolver stringFromAddress: NetNameResolver localHostAddress
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:31'!
localHostAddress
	"Return the local address of this host."
	"NetNameResolver localHostAddress"

	^ self primLocalAddress
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/15/97 16:46'!
nameForAddress: hostAddress timeout: secs
	"Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses."
	"NetNameResolver
		nameForAddress: (NetNameResolver addressFromString: '128.111.92.40')
		timeout: 30"

	| deadline ready success |
	deadline _ Time millisecondClockValue + (secs * 1000).
	ready _ self waitForResolverReadyUntil: deadline.
	ready ifFalse: [^ nil].

	self primStartLookupOfAddress: hostAddress.
	success _ self waitForCompletionUntil: deadline.
	success
		ifTrue: [^ self primAddressLookupResult]
		ifFalse: [^ nil].
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 9/17/97 16:26'!
promptUserForHostAddress
	"Ask the user for a host name and return its address."
	"NetNameResolver promptUserForHostAddress"

	^ NetNameResolver promptUserForHostAddressDefault: ''
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'jm 11/4/97 07:15'!
promptUserForHostAddressDefault: defaultName
	"Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default."
	"NetNameResolver promptUserForHostAddressDefault: ''"

	| default hostName serverAddr |
	Socket initializeNetwork.
	defaultName isEmpty
		ifTrue: [default _ DefaultHostName]
		ifFalse: [default _ defaultName].
	hostName _ FillInTheBlank
		request: 'Host name or address?'
		initialAnswer: default.
	hostName isEmpty ifTrue: [^ 0].
	serverAddr _ NetNameResolver addressForName: hostName timeout: 15.
	serverAddr = nil ifTrue: [self error: 'Could not find the address for ', hostName].
	hostName size > 0 ifTrue: [DefaultHostName _ hostName].
	^ serverAddr
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'!
resolverError
	^self primNameResolverError
! !

!NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'!
resolverStatus
	^self primNameResolverStatus
! !


!NetNameResolver class methodsFor: 'network initialization' stamp: 'tk 2/15/1999 14:35'!
haveNetwork
	"Our best estimate of whether a network is available.  Caller will want to ask user if we should try this time."

	HaveNetwork ifFalse: [^ false].
	Time totalSeconds - LastContact > 1800 "30 min" ifTrue: [^ #expired].
	^ true	"are current"! !

!NetNameResolver class methodsFor: 'network initialization' stamp: 'tk 2/15/1999 14:47'!
haveNetwork: boolean
	"Allow user to say we don't want to try to start a connection.  Not enforced.  Only for caller's information when he asks."

	HaveNetwork _ boolean.
	LastContact _ Time totalSeconds.! !

!NetNameResolver class methodsFor: 'network initialization' stamp: 'RAA 6/10/2000 10:38'!
initializeNetworkIfFail: errorBlock
	"Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails."
	"NetNameResolver initializeNetworkIfFail: [self error: 'network initialization failed']"

	| semaIndex result |
	self resolverStatus = ResolverUninitialized
		ifFalse: [
			LastContact _ Time totalSeconds.  HaveNetwork _ true.
			^ self].  "network is already initialized"

	LastContact _ Time totalSeconds.  HaveNetwork _ false.	"in case abort"
	ResolverSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: ResolverSemaphore.

	Utilities informUser:
'Initializing the network drivers; this may
take up to 30 seconds and can''t be interrupted'
		during: [result _ self primInitializeNetwork: semaIndex].
	Display repaintMorphicDisplayNow.  "take the informer down"

	"result is nil if network initialization failed, self if it succeeds"
	result ifNil: [errorBlock value]
		ifNotNil: [HaveNetwork _ true].
! !

!NetNameResolver class methodsFor: 'network initialization' stamp: 'ar 2/2/2001 15:09'!
primInitializeNetwork: resolverSemaIndex
	"Initialize the network drivers on platforms that need it, such as the Macintosh, and return nil if network initialization failed or the reciever if it succeeds. Since mobile computers may not always be connected to a network, this method should NOT be called automatically at startup time; rather, it should be called when first starting a networking application. It is a noop if the network driver has already been initialized. If non-zero, resolverSemaIndex is the index of a VM semaphore to be associated with the network name resolver. This semaphore will be signalled when the resolver status changes, such as when a name lookup query is completed."
	"Note: some platforms (e.g., Mac) only allow only one name lookup query at a time, so a manager process should be used to serialize resolver lookup requests."

	<primitive: 'primitiveInitializeNetwork' module: 'SocketPlugin'>
	^ nil  "return nil if primitive fails"
! !


!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAbortLookup
	"Abort the current lookup operation, freeing the name resolver for the next query."

	<primitive: 'primitiveResolverAbortLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAddressLookupResult
	"Return the host name found by the last host address lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverAddressLookupResult' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primLocalAddress
	"Return the local address of this host."

	<primitive: 'primitiveResolverLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameLookupResult
	"Return the host address found by the last host name lookup. Returns nil if the last lookup was unsuccessful."

	<primitive: 'primitiveResolverNameLookupResult' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameResolverError
	"Return an integer reflecting the error status of the last network name resolver request. Zero means no error."

	<primitive: 'primitiveResolverError' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primNameResolverStatus
	"Return an integer reflecting the status of the network name resolver. For a list of possible values, see the comment in the 'initialize' method of this class."

	<primitive: 'primitiveResolverStatus' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartLookupOfAddress: hostAddr
	"Look up the given host address in the Domain Name Server to find its name. This call is asynchronous. To get the results, wait for it to complete or time out and then use primAddressLookupResult."

	<primitive: 'primitiveResolverStartAddressLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !

!NetNameResolver class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartLookupOfName: hostName
	"Look up the given host name in the Domain Name Server to find its address. This call is asynchronous. To get the results, wait for it to complete or time out and then use primNameLookupResult."

	<primitive: 'primitiveResolverStartNameLookup' module: 'SocketPlugin'>
	self primitiveFailed
! !


!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 13:57'!
readDecimalByteFrom: aStream
	"Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255.
JMM - 000503 fixed didn't work correctly"

	| digitSeen value digit |
	digitSeen _ false.
	value _ 0.
	[aStream atEnd] whileFalse: 
		[digit _ aStream next digitValue.
		(digit < 0 or: [digit > 9]) ifTrue: [
			aStream skip: -1.
			(digitSeen not or: [value > 255]) ifTrue: [^ nil].
			^ value].
		digitSeen _ true.
		value _ (value * 10) + digit].
	(digitSeen not or: [value > 255]) ifTrue: [^ nil].
	^ value
! !

!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:35'!
waitForCompletionUntil: deadline
	"Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period."

	| status |
	status _ self resolverStatus.
	[(status = ResolverBusy) and:
	 [Time millisecondClockValue < deadline]]
		whileTrue: [
			"wait for resolver to be available"
			ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self resolverStatus].

	status = ResolverReady
		ifTrue: [^ true]
		ifFalse: [
			status = ResolverBusy ifTrue: [self primAbortLookup].
			^ false].
! !

!NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:36'!
waitForResolverReadyUntil: deadline
	"Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period."

	| status |
	status _ self resolverStatus.
	status = ResolverUninitialized ifTrue: [^ false].

	[(status = ResolverBusy) and:
	 [Time millisecondClockValue < deadline]]
		whileTrue: [
			"wait for resolver to be available"
			ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self resolverStatus].

	^ status ~= ResolverBusy
! !
EmbeddedWorldBorderMorph subclass: #NetworkTerminalBorderMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!

!NetworkTerminalBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/15/2000 12:21'!
boxesAndColorsAndSelectors

	^#()! !

!NetworkTerminalBorderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/14/2000 14:12'!
initialize

	super initialize.
	self setBalloonText: nil.		"'I am a view on another Squeak'."
	self layoutInset: 0.
! !

!NetworkTerminalBorderMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/2/2000 21:24'!
toggleFullView
	"Toggle the full view for network terminal"
	| fullExtent priorExtent |
	fullExtent _ self worldIEnclose extent + (2 * self borderWidth).
	priorExtent _ self valueOfProperty: #priorExtent.
	priorExtent ifNil:[
		self setProperty: #priorExtent toValue: self extent.
		self extent: fullExtent.
		self position: self position + self borderWidth asPoint negated.
	] ifNotNil:[
		self removeProperty: #priorExtent.
		self extent: priorExtent.
		self position: (self position max: 0@0).
	].! !
Morph subclass: #NetworkTerminalMorph
	instanceVariableNames: 'connection decoder eventEncoder backgroundForm enteringHand '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!NetworkTerminalMorph commentStamp: '<historical>' prior: 0!
A morph used to communicate with a remote image.  It sends all mouse/keyboard events to the remote side, and it displays canvas commands that are sent back.!


!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 12:06'!
connection: aConnection

	connection := aConnection.
	decoder := CanvasDecoder connection: aConnection.
	eventEncoder := MorphicEventEncoder on: aConnection.! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'ar 11/2/2000 21:18'!
initialize
	super initialize.
	backgroundForm _ (
		(StringMorph contents: '......' font: (TextStyle default fontOfSize: 24))
			color: Color white
	) imageForm.
	bounds _ backgroundForm boundingBox.
! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 10:45'!
openInStyle: aSymbol

	aSymbol == #naked ifTrue: [
		self openInWorld.
	].
	aSymbol == #scaled ifTrue: [
		self openScaled.
	].
	aSymbol == #bordered ifTrue: [
		AlignmentMorph newColumn
			hResizing: 	#shrinkWrap;
			vResizing: 	#shrinkWrap;
			borderWidth: 8;
			borderColor: Color blue;
			addMorph: self;
			openInWorld.
	].

	[
		[self world isNil] whileFalse: [(Delay forSeconds: 2) wait].
		self disconnect.
	] fork.

! !

!NetworkTerminalMorph methodsFor: 'initialization' stamp: 'RAA 12/13/2000 08:25'!
openScaled

	| window tm |
	window _ NetworkTerminalBorderMorph new
		minWidth: 100;
		minHeight: 100;
		borderWidth: 8;
		borderColor: Color orange;
		bounds: (0@0 extent: Display extent * 3 // 4).
	tm _ BOBTransformationMorph new.
	tm useRegularWarpBlt: true.		"try to reduce memory used"
	window addMorphBack: tm.
	tm addMorph: self.
	window openInWorld.
	NebraskaNavigationMorph new 
		nebraskaBorder: window;
		nebraskaTerminal: self;
		openInWorld.! !


!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'RAA 7/24/2000 11:43'!
drawOn: aCanvas

	backgroundForm ifNotNil: [
		aCanvas clipBy: bounds during: [ :c |
			c drawImage: backgroundForm at: bounds topLeft
		].
	].
! !

!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'RAA 8/28/2000 12:06'!
forceToFront: aRegion
	| highQuality |
	"force the given region from the drawing form onto the background form"

	highQuality _ false.		"highQuality is slower"

	self updateBackgroundForm.
	backgroundForm
		copy: aRegion
		from: aRegion topLeft
		in: decoder drawingForm
		rule: Form over.
	self invalidRect: (
		highQuality ifTrue: [
			bounds
		] ifFalse: [
			(aRegion expandBy: 4) translateBy: bounds topLeft	"try to remove gribblys"
		]
	)
! !

!NetworkTerminalMorph methodsFor: 'drawing' stamp: 'RAA 8/28/2000 11:28'!
updateBackgroundForm
	"make sure that our background form matches what the server has most recently requested"

	| drawingForm |

	drawingForm _ decoder drawingForm.
	(drawingForm extent = backgroundForm extent and: [
		drawingForm depth = backgroundForm depth ]) ifTrue: [
			"they match just fine"
			^self ].

	backgroundForm _ drawingForm deepCopy.		"need copy to capture the moment"
	self extent: backgroundForm extent.! !


!NetworkTerminalMorph methodsFor: 'stepping and presenter' stamp: 'ar 10/25/2000 23:19'!
step

	decoder ifNil: [ ^self ].
	decoder processIOOnForce: [ :rectangle | self forceToFront: rectangle ].! !

!NetworkTerminalMorph methodsFor: 'stepping and presenter' stamp: 'ls 3/25/2000 16:58'!
stepTime
	^10! !


!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 11/5/2000 13:22'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy outData null |

	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [			"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we don't really want it"
	myCopy _ morphToDrop veryDeepCopy.	"gradient fills require doing this second"
	myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position.

	outData _ myCopy eToyStreamedRepresentationNotifying: nil.
	null _ String with: 0 asCharacter.
	EToyPeerToPeer new 
		sendSomeData: {
			EToyIncomingMessage typeMorph,null. 
			Preferences defaultAuthorName,null.
			outData
		}
		to: (NetNameResolver stringFromAddress: connection remoteAddress)
		for: self.
! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 11/5/2000 13:23'!
commResult: anArrayOfAssociations

	"ignore for now"! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:02'!
handleKeyDown: anEvent
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:02'!
handleKeyUp: anEvent
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:11'!
handleKeystroke: anEvent
	anEvent wasHandled ifTrue:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:03'!
handleMouseDown: anEvent
	anEvent wasHandled ifTrue:[^self].
	anEvent hand removePendingBalloonFor: self.
	anEvent hand removePendingHaloFor: self.
	anEvent wasHandled: true.
	anEvent hand newMouseFocus: self event: anEvent.
	anEvent hand removeHaloFromClick: anEvent on: self.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:04'!
handleMouseMove: anEvent
	anEvent wasHandled ifTrue:[^self]. "not interested"
	(anEvent hand hasSubmorphs) ifTrue:[^self].
	(anEvent anyButtonPressed and:[anEvent hand mouseFocus ~~ self]) ifTrue:[^self].
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:03'!
handleMouseUp: anEvent
	anEvent wasHandled ifTrue:[^self]. "not interested"
	anEvent hand mouseFocus == self ifFalse:[^self]. "Not interested in other parties"
	anEvent hand releaseMouseFocus: self.
	anEvent wasHandled: true.
	self sendEventAsIs: anEvent.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/24/2000 18:06'!
handlerForMouseDown: anEvent
	^self! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:25'!
handlesMouseOver: evt
	^true! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:24'!
mouseEnter: evt
	evt hand newKeyboardFocus: self.
	evt hand needsToBeDrawn ifTrue:[Cursor blank show].! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 15:25'!
mouseLeave: evt

	evt hand needsToBeDrawn ifTrue:[Cursor normal show].! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 11:34'!
sendEvent: evt

	self sendEventAsIs: (evt translatedBy: bounds topLeft negated).! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 11:33'!
sendEventAsIs: evt

	eventEncoder ifNil: [ ^self ].
	eventEncoder sendEvent: evt.! !

!NetworkTerminalMorph methodsFor: 'event handling' stamp: 'RAA 11/5/2000 13:26'!
wantsDroppedMorph: aMorph event: evt

	^true.! !


!NetworkTerminalMorph methodsFor: 'geometry' stamp: 'RAA 7/24/2000 11:35'!
extent: newExtent

	super extent: newExtent.
	eventEncoder sendViewExtent: self extent! !


!NetworkTerminalMorph methodsFor: 'shutting down' stamp: 'ls 4/11/2000 18:36'!
disconnect
	connection ifNotNil: [ connection destroy ].
	eventEncoder := connection := decoder := nil.! !

!NetworkTerminalMorph methodsFor: 'shutting down' stamp: 'RAA 12/13/2000 08:21'!
requestBufferedConnection

	eventEncoder ifNotNil: [eventEncoder requestBufferedConnection].
! !


!NetworkTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/29/2000 12:13'!
addScalingMenuItems: menu hand: aHandMorph

	"for comaptibility when in scaled frame"! !

!NetworkTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 13:00'!
areasRemainingToFill: aRectangle
	"I assume that we are opaque"

	^ aRectangle areasOutside: self bounds! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NetworkTerminalMorph class
	instanceVariableNames: ''!

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 8/4/2000 15:13'!
connectTo: serverHost

	^self connectTo: serverHost port: NebraskaServer defaultPort

! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 8/4/2000 15:12'!
connectTo: serverHost port: serverPort

	| stringSock |

	stringSock _ self socketConnectedTo: serverHost port: serverPort.
	^self new connection: stringSock
! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 7/24/2000 12:08'!
openAndConnectTo: serverHost

	^self openAndConnectTo: serverHost port: NebraskaServer defaultPort

! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 8/15/2000 10:09'!
openAndConnectTo: serverHost port: serverPort

	| stringSock me |

	stringSock _ self socketConnectedTo: serverHost port: serverPort.
	me _ self new connection: stringSock.
	^me openInStyle: #naked
! !

!NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'RAA 7/24/2000 12:14'!
socketConnectedTo: serverHost  port: serverPort

	| sock |

	Socket initializeNetwork.
	sock _ Socket new.
	sock connectTo: (NetNameResolver addressForName: serverHost) port: serverPort.
	sock waitForConnectionUntil: Socket standardDeadline.
	sock isConnected ifFalse: [ self error: 'could not connect to server' ].
	^StringSocket on: sock

! !
HandleMorph subclass: #NewHandleMorph
	instanceVariableNames: 'hand offset waitingForClickInside '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!NewHandleMorph methodsFor: 'all' stamp: 'di 5/18/1998 15:27'!
followHand: aHand forEachPointDo: block1 lastPointDo: block2
	hand _ aHand.
	pointBlock _ block1.
	lastPointBlock _ block2.
	self position: hand lastEvent cursorPoint - (self extent // 2)! !

!NewHandleMorph methodsFor: 'all' stamp: 'sw 11/5/1998 10:24'!
initialize
	waitingForClickInside _ true.
	super initialize.
	Preferences noviceMode ifTrue: [self setBalloonText: 'stretch']! !

!NewHandleMorph methodsFor: 'all' stamp: 'di 4/30/1999 14:06'!
justDroppedInto: aMorph event: anEvent
	"No dropping behavior because stepping will delete me.
	Moreover it needs to be done that way to evaluate lastPointBlock"
! !

!NewHandleMorph methodsFor: 'all' stamp: 'RAA 1/10/2001 10:15'!
morphicLayerNumber

	^1		"handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"! !

!NewHandleMorph methodsFor: 'all' stamp: 'di 5/17/1998 21:57'!
step
	| evt |
	evt _ hand lastEvent.
	evt anyButtonPressed
		ifTrue: [waitingForClickInside _ false.
				self position: evt cursorPoint - (self extent // 2).
				pointBlock value: self center]
		ifFalse: [waitingForClickInside
					ifTrue: [(self containsPoint: evt cursorPoint)
								ifFalse: ["mouse wandered out before clicked"
										^ self delete]]
					ifFalse: [lastPointBlock value: self center.
							^ self delete]]! !

!NewHandleMorph methodsFor: 'all' stamp: 'ar 10/5/2000 18:16'!
undoGrabCommand
	^nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NewHandleMorph class
	instanceVariableNames: ''!

!NewHandleMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 10:08'!
includeInNewMorphMenu
	^ false! !
Object subclass: #NewParagraph
	instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!NewParagraph commentStamp: '<historical>' prior: 0!
A Paragraph represents text that has been laid out, or composed, in some container.
	text 		A Text with encoded per-character emphasis.
	textStyle	A TextStyle with font set, line height and horizontal alignment.
	firstCharacterIndex    The starting index in text for this paragraph, allowing
				composition of a long text into a number of containers.
	container	A Rectangle or TextContainer that determines where text can go.
	lines		An Array of TextLines comprising the final layout of the text
				after it has been composed within its container.
	positionWhenComposed   As its name implies.  Allows display at new locations
				without the need to recompose the text.
Lines are ordered vertically.  However, for a given y, there may be several lines in left to right order.  Lines must never be empty, even if text is empty.!


!NewParagraph methodsFor: 'access' stamp: 'di 11/16/97 09:02'!
adjustedFirstCharacterIndex
	"Return the index in the text where this paragraph WOULD begin if nothing had changed, except the size of the text -- ie if there have only been an insertion of deletion in the preceding morphs"
	offsetToEnd ifNil: [^ -1].
	^ text size - offsetToEnd! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/24/97 17:38'!
extent
	^ container width @ (lines last bottom - lines first top)! !

!NewParagraph methodsFor: 'access' stamp: 'di 11/8/97 15:41'!
firstCharacterIndex
	^ firstCharacterIndex! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 21:01'!
lastCharacterIndex
	^ lines last last! !

!NewParagraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'!
numberOfLines

	^lines size! !

!NewParagraph methodsFor: 'access' stamp: 'sw 1/13/98 21:31'!
string
	^ text string! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'!
text
	^ text! !

!NewParagraph methodsFor: 'access' stamp: 'jm 11/19/97 20:27'!
textOwner: ignored  "See TextOnCurve"! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'!
textStyle
	^ textStyle! !

!NewParagraph methodsFor: 'access' stamp: 'di 10/23/97 19:33'!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."
	textStyle _ aTextStyle! !


!NewParagraph methodsFor: 'composition' stamp: 'di 11/8/97 15:31'!
compose: t style: ts from: startingIndex in: textContainer
	text _ t.
	textStyle _ ts.
	firstCharacterIndex _ startingIndex.
	offsetToEnd _ text size - firstCharacterIndex.
	container _ textContainer.
	self composeAll! !

!NewParagraph methodsFor: 'composition' stamp: 'di 4/28/1999 10:26'!
composeAll
	self composeLinesFrom: firstCharacterIndex to: text size delta: 0
		into: OrderedCollection new priorLines: Array new atY: container top! !

!NewParagraph methodsFor: 'composition' stamp: 'di 11/15/97 09:21'!
composeAllStartingAt: characterIndex
	firstCharacterIndex _ characterIndex.
	offsetToEnd _ text size - firstCharacterIndex.
	self composeAll! !

!NewParagraph methodsFor: 'composition' stamp: 'ar 5/18/2000 18:34'!
composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines
	atY: startingY
	"While the section from start to stop has changed, composition may ripple all the way to the end of the text.  However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values"

	| charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine |
	charIndex _ start.
	lines _ lineColl.
	lineY _ startingY.
	lineHeightGuess _ textStyle lineGrid.
	maxRightX _ container left.
	maybeSlide _ stop < text size and: [container isMemberOf: Rectangle].
	sliding _ false.
	priorIndex _ 1.
	bottom _ container bottom.
	scanner _ CompositionScanner new text: text textStyle: textStyle.
	firstLine _ true.
	[charIndex <= text size and: [(lineY + lineHeightGuess) <= bottom]]
		whileTrue:
		[sliding
			ifTrue:
			["Having detected the end of rippling recoposition, we are only sliding old lines"
			priorIndex < priorLines size
				ifTrue: ["Adjust and re-use previously composed line"
						priorIndex _ priorIndex + 1.
						priorLine _ (priorLines at: priorIndex)
									slideIndexBy: delta andMoveTopTo: lineY.
						lineColl addLast: priorLine.
						lineY _ priorLine bottom.
						charIndex _ priorLine last + 1]
				ifFalse: ["There are no more priorLines to slide."
						sliding _ maybeSlide _ false]]
			ifFalse:
			[lineHeight _ lineHeightGuess.
			saveCharIndex _ charIndex.
			hitCR _ false.
			row _ container rectanglesAt: lineY height: lineHeight.
			1 to: row size do:
				[:i | (charIndex <= text size and: [hitCR not]) ifTrue:
						[line _ scanner composeFrom: charIndex inRectangle: (row at: i)
								firstLine: firstLine leftSide: i=1 rightSide: i=row size.
					lines addLast: line.
					(text at: line last) = Character cr ifTrue: [hitCR _ true].
					lineHeight _ lineHeight max: line lineHeight.  "includes font changes"
					charIndex _ line last + 1]].
			row size >= 1 ifTrue:
			[lineY _ lineY + lineHeight.
			lineY > bottom
				ifTrue: ["Oops -- the line is really too high to fit -- back out"
						charIndex _ saveCharIndex.
						row do: [:r | lines removeLast]]
				ifFalse: ["It's OK -- the line still fits."
						maxRightX _ maxRightX max: scanner rightX.
						1 to: row size - 1 do:  "Adjust heights across row if necess"
							[:i | (lines at: lines size - row size + i)
									lineHeight: lines last lineHeight
									baseline: lines last baseline].
						charIndex > text size ifTrue:
							["end of text"
							hitCR ifTrue:
								["If text ends with CR, add a null line at the end"
								((lineY + lineHeightGuess) <= container bottom) ifTrue:
									[row _ container rectanglesAt: lineY height: lineHeightGuess.
									row size > 0 ifTrue:
										[line _ (TextLine start: charIndex stop: charIndex-1
											internalSpaces: 0 paddingWidth: 0)
										rectangle: row first;
										lineHeight: lineHeightGuess baseline: textStyle baseline.
										lines addLast: line]]].
							lines _ lines asArray.
							^ maxRightX].
						firstLine _ false]]
				ifFalse:
				[lineY _ lineY + lineHeight].
			(maybeSlide and: [charIndex > stop]) ifTrue:
				["Check whether we are now in sync with previously composed lines"
				 [priorIndex < priorLines size
					and: [(priorLines at: priorIndex) first < (charIndex - delta)]]
						whileTrue: [priorIndex _ priorIndex + 1].
				(priorLines at: priorIndex) first = (charIndex - delta)
					ifTrue: ["Yes -- next line will have same start as prior line."
							priorIndex _ priorIndex - 1.
							maybeSlide _ false.
							sliding _ true]
					ifFalse: [priorIndex = priorLines size ifTrue:
								["Weve reached the end of priorLines,
								so no use to keep looking for lines to slide."
								maybeSlide _ false]]]]].
	firstLine ifTrue:
		["No space in container or empty text"
		line _ (TextLine start: start stop: start-1
						internalSpaces: 0 paddingWidth: 0)
				rectangle: (container topLeft extent: 0@lineHeightGuess);
				lineHeight: lineHeightGuess baseline: textStyle baseline.
		lines _ Array with: line].
	"end of container"
	lines _ lines asArray.
	^ maxRightX! !

!NewParagraph methodsFor: 'composition' stamp: 'di 10/22/97 11:13'!
compositionRectangle
	^ container! !

!NewParagraph methodsFor: 'composition' stamp: 'di 4/28/1999 10:13'!
recomposeFrom: start to: stop delta: delta
	"Recompose this paragraph.  The altered portion is between start and stop.
	Recomposition may continue to the end of the text, due to a ripple effect.
	Delta is the amount by which the current text is longer than it was
	when its current lines were composed."
	| startLine newLines |
	"Have to recompose line above in case a word-break was affected."
	startLine _ (self lineIndexForCharacter: start) - 1 max: 1.
	[startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]]
		whileTrue: [startLine _ startLine - 1].  "Find leftmost of line pieces"
	newLines _ OrderedCollection new: lines size + 1.
	1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)].
	self composeLinesFrom: (lines at: startLine) first to: stop delta: delta
			into: newLines priorLines: lines
			atY: (lines at: startLine) top! !


!NewParagraph methodsFor: 'selection' stamp: 'ar 5/18/2000 18:33'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| line |
	line _ lines at: (self lineIndexForPoint: aPoint).
	^ (CharacterBlockScanner new text: text textStyle: textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'ar 5/18/2000 18:33'!
characterBlockForIndex: index 
	"Answer a CharacterBlock for the character in text at index."
	| line |
	line _ lines at: (self lineIndexForCharacter: index).
	^ (CharacterBlockScanner new text: text textStyle: textStyle)
		characterBlockAtPoint: nil index: ((index max: line first) min: text size+1)
		in: line! !

!NewParagraph methodsFor: 'selection' stamp: 'jm 11/19/97 22:56'!
containsPoint: aPoint
	^ (lines at: (self lineIndexForPoint: aPoint)) rectangle
		containsPoint: aPoint! !

!NewParagraph methodsFor: 'selection' stamp: 'di 10/5/1998 12:59'!
defaultCharacterBlock
	^ (CharacterBlock new stringIndex: firstCharacterIndex text: text
			topLeft: lines first topLeft extent: 0 @ 0)
		textLine: lines first! !

!NewParagraph methodsFor: 'selection' stamp: 'di 11/30/97 12:10'!
selectionRects
	"Return an array of rectangles representing the selection region."
	selectionStart ifNil: [^ Array new].
	^ self selectionRectsFrom: selectionStart to: selectionStop! !

!NewParagraph methodsFor: 'selection' stamp: 'di 6/7/2000 16:52'!
selectionRectsFrom: characterBlock1 to: characterBlock2 
	"Return an array of rectangles representing the area between the two character blocks given as arguments."
	| line1 line2 rects cb1 cb2 w |
	characterBlock1 <= characterBlock2
		ifTrue: [cb1 _ characterBlock1.  cb2 _ characterBlock2]
		ifFalse: [cb2 _ characterBlock1.  cb1 _ characterBlock2].
	cb1 = cb2 ifTrue:
		[w _ self caretWidth.
		^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))].
	line1 _ self lineIndexForCharacter: cb1 stringIndex.
	line2 _ self lineIndexForCharacter: cb2 stringIndex.
	line1 = line2 ifTrue:
		[^ Array with: (cb1 topLeft corner: cb2 bottomRight)].
	rects _ OrderedCollection new.
	rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight).
	(container isMemberOf: Rectangle)
		ifTrue: [(line1+1) <= (line2-1) ifTrue:
					[rects addLast: ((lines at: line1+1) topLeft
								corner: (lines at: line2-1) bottomRight)]]
		ifFalse: [(line1+1) to: (line2-1) do:
					[:i | rects addLast: (lines at: i) rectangle]].
	rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft).
	^ rects! !

!NewParagraph methodsFor: 'selection' stamp: 'di 12/2/97 19:57'!
selectionStart: startBlock selectionStop: stopBlock
	selectionStart _ startBlock.
	selectionStop _ stopBlock.! !


!NewParagraph methodsFor: 'editing' stamp: 'sw 12/7/1999 11:34'!
clickAt: clickPoint for: model controller: editor
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action target |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle) 
		do: [:att | att mayActOnClick ifTrue:
				[
	"			range _ text rangeOf: att startingAt: startBlock stringIndex.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last).
				box _ boxes detect: [:each | each containsPoint: clickPoint].
					*This doesn't work in morphic*
				Need to replace by a highlighting morph that waits for moueUp.
				Utilities awaitMouseUpIn: (editor transform invertRect: box)
						repeating: []
						ifSucceed: [(att actOnClickFor: model) ifTrue: [action _ true]].
	"
				(target _ model) ifNil: [target _ editor morph].
				(att actOnClickFor: target)
					ifTrue: [Sensor waitNoButton.  "FIX THIS"
							action _ true]]].
	^ action! !

!NewParagraph methodsFor: 'editing' stamp: 'di 4/28/1999 10:14'!
replaceFrom: start to: stop with: aText displaying: displayBoolean 
	"Edit the text, and then recompose the lines." 
	text replaceFrom: start to: stop with: aText.
	self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! !


!NewParagraph methodsFor: 'display' stamp: 'di 8/13/2000 12:27'!
asParagraphForPostscript

	^ self! !

!NewParagraph methodsFor: 'display' stamp: 'di 12/1/97 19:52'!
caretWidth
	^ 2! !

!NewParagraph methodsFor: 'display' stamp: 'di 5/7/1998 09:21'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"
	| visibleRectangle offset leftInRun line |
	visibleRectangle _ aCanvas clipRect.
	offset _ somePosition - positionWhenComposed.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ lines at: i.
			self displaySelectionInLine: line on: aCanvas.
			line first <= line last ifTrue:
				[leftInRun _ displayScanner displayLine: line
								offset: offset leftInRun: leftInRun]].
! !

!NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:05'!
displaySelectionInLine: line on: aCanvas
	| leftX rightX w caretColor |
	selectionStart ifNil: [^ self].  "No selection"
	selectionStart = selectionStop
		ifTrue: ["Only show caret on line where clicked"
				selectionStart textLine ~= line ifTrue: [^ self]]
		ifFalse: ["Test entire selection before or after here"
				(selectionStop stringIndex < line first
					or: [selectionStart stringIndex > (line last+1)])
					ifTrue: [^ self].  "No selection on this line"
				(selectionStop stringIndex = line first
					and: [selectionStop textLine ~= line])
					ifTrue: [^ self].  "Selection ends on line above"
				(selectionStart stringIndex = (line last+1)
					and: [selectionStop textLine ~= line])
					ifTrue: [^ self]].  "Selection begins on line below"

	selectionStart stringIndex < line first
		ifTrue: [leftX _ line left]
		ifFalse: [leftX _ selectionStart left].
	(selectionStop stringIndex > (line last+1)
			or: [selectionStop stringIndex = (line last+1)
					and: [selectionStop textLine ~= line]])
		ifTrue: [rightX _ line right]
		ifFalse: [rightX _ selectionStop left].
	selectionStart = selectionStop
		ifTrue:
		[rightX _ rightX + 1.
		w _ self caretWidth.
		caretColor _ self insertionPointColor.
		1 to: w do:
			[:i |  "Draw caret triangles at top and bottom"
			aCanvas fillRectangle: ((leftX-w+i-1)@(line top+i-1) extent: (w-i*2+3)@1)
				color: caretColor.
			aCanvas fillRectangle: ((leftX-w+i-1)@(line bottom-i) extent: (w-i*2+3)@1)
				color: caretColor].
		aCanvas fillRectangle: (leftX@line top corner: rightX@line bottom)
				color: caretColor]
	ifFalse:
		[aCanvas fillRectangle: (leftX@line top corner: rightX@line bottom)
				color: self selectionColor]
! !

!NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:04'!
insertionPointColor
	^ Display depth <= 2
		ifTrue: [Color black]
		ifFalse: [Preferences insertionPointColor]! !

!NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:03'!
selectionColor
	Display depth = 1 ifTrue: [^ Color veryLightGray].
	Display depth = 2 ifTrue: [^ Color gray].
	^ Preferences textHighlightColor! !


!NewParagraph methodsFor: 'private' stamp: 'di 11/8/97 15:47'!
adjustLineIndicesBy: delta
	firstCharacterIndex _ firstCharacterIndex + delta.
	lines do: [:line | line slide: delta].
! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/26/97 15:57'!
adjustRightX
	| shrink |
	shrink _ container right - maxRightX.
	lines do: [:line | line paddingWidth: (line paddingWidth - shrink)].
	container _ container withRight: maxRightX! !

!NewParagraph methodsFor: 'private' stamp: 'di 5/21/1998 21:45'!
deepCopy
	"Don't want to copy the container (etc) or fonts in the TextStyle."
	| new |
	new _ self copy.
	new textStyle: textStyle copy
		lines: lines copy
		text: text deepCopy.
	^ new! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:17'!
fastFindFirstLineSuchThat: lineBlock
	"Perform a binary search of the lines array and return the index
	of the first element for which lineBlock evaluates as true.
	This assumes the condition is one that goes from false to true for
	increasing line numbers (as, eg, yval > somey or start char > somex).
	If lineBlock is not true for any element, return size+1."
	| index low high |
	low _ 1.
	high _ lines size.
	[index _ high + low // 2.
	low > high]
		whileFalse: 
			[(lineBlock value: (lines at: index))
				ifTrue: [high _ index - 1]
				ifFalse: [low _ index + 1]].
	^ low! !

!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:30'!
indentationOfLineIndex: lineIndex ifBlank: aBlock
	"Answer the number of leading tabs in the line at lineIndex.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value.
	 If the line is word-wrap overflow, back up a line and recur."

	| arrayIndex first last cr |
	cr _ Character cr.
	arrayIndex _ lineIndex.
	[first _ (lines at: arrayIndex) first.
	 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap"
		[arrayIndex _ arrayIndex - 1].
	last _ (lines at: arrayIndex) last.
	
	^(text string copyFrom: first to: last) indentationIfBlank: aBlock.
! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:11'!
lineIndexForCharacter: index
	"Answer the index of the line in which to select the character at index."
	^ (self fastFindFirstLineSuchThat: [:line | line first > index]) - 1 max: 1! !

!NewParagraph methodsFor: 'private' stamp: 'di 4/14/98 13:13'!
lineIndexForPoint: aPoint
	"Answer the index of the line in which to select the character nearest to aPoint."
	| i py |
	py _ aPoint y truncated.

	"Find the first line at this y-value"
	i _ (self fastFindFirstLineSuchThat: [:line | line bottom > py]) min: lines size.

	"Now find the first line at this x-value"
	[i < lines size and: [(lines at: i+1) top = (lines at: i) top
				and: [aPoint x >= (lines at: i+1) left]]]
		whileTrue: [i _ i + 1].
	^ i! !

!NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:04'!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."
	"apparently the selector changed with NewParagraph"

	^self lineIndexForCharacter: characterIndex 
! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/24/97 17:40'!
lines
	^ lines! !

!NewParagraph methodsFor: 'private' stamp: 'di 11/7/97 12:00'!
moveBy: delta
	lines do: [:line | line moveBy: delta].
	positionWhenComposed _ positionWhenComposed + delta.
	container _ container translateBy: delta! !

!NewParagraph methodsFor: 'private' stamp: 'di 10/21/97 21:36'!
positionWhenComposed: pos
	positionWhenComposed _ pos! !

!NewParagraph methodsFor: 'private' stamp: 'di 5/21/1998 21:47'!
textStyle: ts lines: l text: t
	"Private -- just a service for deepCopy"
	textStyle _ ts.
	lines _ l.
	text _ t.! !


!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
centered 
	textStyle centered! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
justified 
	textStyle justified! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
leftFlush 
	textStyle leftFlush! !

!NewParagraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'!
rightFlush 
	textStyle rightFlush! !

SystemWindow subclass: #NewWorldWindow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 01:31'!
addMorph: aMorph frame: relFrame
	| cc |
	cc _ aMorph color.
	super addMorph: aMorph frame: relFrame.
	aMorph color: cc.! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 18:30'!
amendSteppingStatus! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 12:30'!
openInWorld: aWorld
	| xxx |
	"This msg and its callees result in the window being activeOnlyOnTop"

	xxx _ RealEstateAgent initialFrameFor: self world: aWorld.

	"Bob say: 'opening in ',xxx printString,' out of ',aWorld bounds printString.
	6 timesRepeat: [Display flash: xxx andWait: 300]."

	self bounds: xxx.
	aWorld addMorph: self.
	self activate.
	aWorld startSteppingSubmorphsOf: self.
! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 08:47'!
setStripeColorsFrom: paneColor

	"Since our world may be *any* color, try to avoid really dark colors so title will show"
	| revisedColor |
	revisedColor _ paneColor atLeastAsLuminentAs: 0.1 .
	self isActive ifTrue: [
		stripes second 
			color: revisedColor; 
			borderColor: stripes second color darker.
		stripes first 
			color: stripes second borderColor darker;
			borderColor: stripes first color darker.
		^self
	].
	"This could be much faster"
	stripes second 
		color: revisedColor; 
		borderColor: revisedColor.
	stripes first 
		color: revisedColor; 
		borderColor: revisedColor! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 08:33'!
setWindowColor: incomingColor
	| existingColor aColor |

	incomingColor ifNil: [^ self].  "it happens"
	aColor _ incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor 
		or: [aColor = Color black]) ifTrue: [^ self].
	existingColor _ self paneColorToUse.
	existingColor ifNil: [^ self beep].
	self setStripeColorsFrom: aColor
		
! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 19:25'!
spawnReframeHandle: event
	"The mouse has crossed a pane border.  Spawn a reframe handle."
	| resizer localPt pt ptName newBounds |

	allowReframeHandles ifFalse: [^ self].
	owner ifNil: [^ self  "Spurious mouseLeave due to delete"].
	(self isActive not or: [self isCollapsed]) ifTrue:  [^ self].
	((self world ifNil: [^ self]) firstSubmorph isKindOf: NewHandleMorph) ifTrue:
		[^ self  "Prevent multiple handles"].

"Transcript show: event hand printString,'  ',event hand world printString,
		'  ',self world printString,' ',self outermostWorldMorph printString; cr; cr."
	pt _ event cursorPoint.
	self bounds forPoint: pt closestSideDistLen:
		[:side :dist :len |  "Check for window side adjust"
		dist <= 2  ifTrue: [ptName _ side]].
	ptName ifNil:
		["Check for pane border adjust"
		^ self spawnPaneFrameHandle: event].
	#(topLeft bottomRight bottomLeft topRight) do:
		[:corner |  "Check for window corner adjust"
		(pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName _ corner]].

	resizer _ NewHandleMorph new
		followHand: event hand
		forEachPointDo:
			[:p | localPt _ self pointFromWorld: p.
			newBounds _ self bounds
				withSideOrCorner: ptName
				setToPoint: localPt
				minExtent: self minimumExtent.
			self fastFramingOn 
			ifTrue:
				[self doFastWindowReframe: ptName]
			ifFalse:
				[self bounds: newBounds.
				(Preferences roundedWindowCorners
					and: [#(bottom right bottomRight) includes: ptName])
					ifTrue:
					["Complete kluge: causes rounded corners to get painted correctly,
					in spite of not working with top-down displayWorld."
					ptName = #bottom ifFalse:
						[self invalidRect: (self bounds topRight - (6@0) extent: 7@7)].
					ptName = #right ifFalse:
						[self invalidRect: (self bounds bottomLeft - (0@6) extent: 7@7)].
					self invalidRect: (self bounds bottomRight - (6@6) extent: 7@7)]]]
		lastPointDo:
			[:p | ].
	self world addMorph: resizer.
	resizer startStepping.
! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 18:21'!
updatePaneColors
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColorToUse.

	"paneMorphs do: [:p | p color: self paneColorToUse]."	"since pane is a world, skip this"
! !

!NewWorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 6/1/2000 18:33'!
wantsSteps
	
	^true! !
Controller subclass: #NoController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!NoController commentStamp: '<historical>' prior: 0!
I represent a controller that never wants control. I am the controller for views that are non-interactive.!


!NoController methodsFor: 'basic control sequence'!
startUp
	"I do nothing."

	^self! !


!NoController methodsFor: 'control defaults'!
isControlActive 
	"Refer to the comment in Controller|isControlActive."

	^false! !

!NoController methodsFor: 'control defaults'!
isControlWanted 
	"Refer to the comment in Controller|isControlWanted."

	^false! !
Object subclass: #Note
	instanceVariableNames: 'author timestamp text children title parent url '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!Note commentStamp: '<historical>' prior: 0!
Notes are general structures for users notes.  Being used in the Comment application and others.!


!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:19'!
addChild: aNote
	children add: aNote
! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:17'!
author
	^author! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:17'!
author: anAuthor
	author _ anAuthor! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:18'!
children
	^children
! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:39'!
children: aCollection
	children _ aCollection.
! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:26'!
parent
	^parent! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:26'!
parent: whatever
	parent _ whatever! !

!Note methodsFor: 'access' stamp: 'mjg 11/24/97 15:12'!
storeOn: aStream
	aStream nextPutAll: '(Note new;'.
	aStream nextPutAll: 'author: ',self author storeString,';'.
	aStream nextPutAll: 'text: ',self text storeString,';'.
	aStream nextPutAll: 'parent: ',self parent storeString,';'.
	aStream nextPutAll: 'timestamp: ',self timestamp storeString,';'.
	aStream nextPutAll: 'title: ',self title storeString,';'.
	aStream nextPutAll: 'url: ',self url storeString,';'.
	aStream nextPutAll: 'yourself)'.! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:17'!
text
	^text! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:18'!
text: aString
	text _ aString! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:18'!
timestamp
	^timestamp! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:18'!
timestamp: aDateandTime
	timestamp _ aDateandTime! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:17'!
title
	^title! !

!Note methodsFor: 'access' stamp: 'mjg 11/17/97 14:17'!
title: aString
	title _ aString! !

!Note methodsFor: 'access' stamp: 'mjg 11/19/97 10:45'!
url
	^url! !

!Note methodsFor: 'access' stamp: 'mjg 11/19/97 10:45'!
url: aString
	url_aString.! !
AbstractScoreEvent subclass: #NoteEvent
	instanceVariableNames: 'duration midiKey velocity channel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!NoteEvent commentStamp: '<historical>' prior: 0!
Represents a note on or off event in a MIDI score.
!


!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:02'!
channel

	^ channel
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:02'!
channel: midiChannel

	channel _ midiChannel.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 19:10'!
duration

	^ duration
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:49'!
duration: aNumber

	duration _ aNumber.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'!
endTime

	^ time + duration
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 22:07'!
key: midiKeyNum velocity: midiVelocity channel: midiChannel

	midiKey _ midiKeyNum.
	velocity _ midiVelocity.
	channel _ midiChannel.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/18/97 20:58'!
midiKey

	^ midiKey
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 09:35'!
midiKey: midiKeyNum

	midiKey _ midiKeyNum.
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:06'!
pitch
	"Convert my MIDI key number to a pitch and return it."

	^ AbstractSound pitchForMIDIKey: midiKey
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/30/97 09:32'!
velocity

	^ velocity
! !

!NoteEvent methodsFor: 'accessing' stamp: 'jm 12/31/97 11:51'!
velocity: midiVelocity

	velocity _ midiVelocity.
! !


!NoteEvent methodsFor: 'classification' stamp: 'jm 12/31/97 11:48'!
isNoteEvent

	^ true
! !


!NoteEvent methodsFor: 'printing' stamp: 'jm 1/3/98 08:58'!
keyName
	"Return a note name for my pitch."

	| pitchName octave |
	pitchName _ #(c cs d ef e f fs g af a bf b) at: (midiKey \\ 12) + 1.
	octave _ (#(-1 0 1 2 3 4 5 6 7 8 9) at: (midiKey // 12) + 1) printString.
	^ pitchName, octave
! !

!NoteEvent methodsFor: 'printing' stamp: 'jm 1/3/98 08:59'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': '.
	aStream nextPutAll: self keyName.
	aStream space.
	duration printOn: aStream.
	aStream nextPut: $).
! !


!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:58'!
endNoteOnMidiPort: aMidiPort
	"Output a noteOff event to the given MIDI port. (Actually, output a noteOff event with zero velocity. This does the same thing, but allows running status to be used when sending a mixture of note on and off commands.)"

	aMidiPort
		midiCmd: 16r90
		channel: channel
		byte: midiKey
		byte: 0.
! !

!NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:56'!
startNoteOnMidiPort: aMidiPort
	"Output a noteOn event to the given MIDI port."

	aMidiPort
		midiCmd: 16r90
		channel: channel
		byte: midiKey
		byte: velocity.
! !
Exception subclass: #Notification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!Notification commentStamp: '<historical>' prior: 0!
A Notification is an indication that something interesting has occurred.  If it is not handled, it will pass by without effect.!


!Notification methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:18'!
defaultAction
	"No action is taken. The value nil is returned as the value of the message that signaled the exception."


	^nil! !

!Notification methodsFor: 'exceptionDescription' stamp: 'tfei 6/4/1999 18:17'!
isResumable
	"Answer true. Notification exceptions by default are specified to be resumable."

	^true! !
PluggableCanvas subclass: #NullCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!NullCanvas commentStamp: '<historical>' prior: 0!
A canvas which ignores all drawing commands.!


!NullCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 21:10'!
apply: aBlock
	"do nothing"! !

!NullCanvas methodsFor: 'private' stamp: 'ls 3/27/2000 21:41'!
clipBy: region during: aBlock
	"do this in order that timing runs work better"
	aBlock value: self! !

!NullCanvas methodsFor: 'private' stamp: 'ls 3/27/2000 21:39'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	"do this in order that timing runs work better"
	aBlock value: self! !

!NullCanvas methodsFor: 'private' stamp: 'ls 3/27/2000 21:40'!
translateBy: delta during: aBlock
	"do this in order that timing runs work better"
	aBlock value: self! !


!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:11'!
clipRect
	^1@1 extent: 99@99! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:26'!
copyClipRect: clipRect
	"who cares what the clipping rectangle is?"
	^self! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:11'!
extent
	^100@100! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:12'!
form
	^Form extent: self extent! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:12'!
isBalloonCanvas
	^false! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:13'!
isShadowDrawing
	^false! !

!NullCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:13'!
origin
	^0@0! !
Object subclass: #NullEncoder
	instanceVariableNames: 'target filterSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

!NullEncoder methodsFor: 'initialization' stamp: 'MPW 1/1/1901 00:04'!
initWithTarget:aTarget
	target _ aTarget.
	filterSelector _ self class filterSelector.
	^self.
! !


!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:17'!
forward:anObject
	anObject ~= nil ifTrue:[target write:anObject].
! !

!NullEncoder methodsFor: 'writing' stamp: 'mpw 8/13/1999 10:54'!
write:anObject
	filterSelector  ifNil:[filterSelector_self class filterSelector].
	anObject ifNotNil: [anObject perform:filterSelector with:self].
! !

!NullEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 01:16'!
writeObject:anObject
	^self forward:anObject.
! !


!NullEncoder methodsFor: 'accessing' stamp: 'RAA 9/17/2000 11:53'!
close

	^target close.
! !

!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:56'!
contents
	^target contents.
! !

!NullEncoder methodsFor: 'accessing' stamp: 'MPW 1/1/1901 00:16'!
target
	^target.! !


!NullEncoder methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:19'!
process:anObject
	self write:anObject.
	^self contents.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

NullEncoder class
	instanceVariableNames: ''!

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:55'!
stream
	^self streamOn:self defaultTarget. 
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 00:05'!
stream:newTarget
	^self new initWithTarget:newTarget.
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 01:15'!
streamOn:newTargetCollection
	^self new initWithTarget:newTargetCollection.
! !

!NullEncoder class methodsFor: 'creation' stamp: 'MPW 1/1/1901 02:20'!
streamOnFile:fileName
	^self new initWithTarget:(FileStream newFileNamed: fileName).
! !


!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'!
defaultTarget
	^OrderedCollection new.
! !

!NullEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 00:02'!
filterSelector
	^#writeOnFilterStream:
! !


!NullEncoder class methodsFor: 'processing' stamp: 'MPW 1/1/1901 01:20'!
process:anObject
	^self stream process:anObject.

! !
NetworkTerminalMorph subclass: #NullTerminalMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!

!NullTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 07:20'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds fillStyle: Color orange.
	aCanvas frameRectangle: self bounds color: Color black! !

!NullTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 07:21'!
extent: newExtent

	| aPoint |
	aPoint _ 50@50.
	bounds extent = aPoint ifFalse: [
		self changed.
		bounds _ bounds topLeft extent: aPoint.
		self layoutChanged.
		self changed
	].
	eventEncoder sendViewExtent: newExtent! !

!NullTerminalMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 07:22'!
forceToFront: aRegion
	"force the given region from the drawing form onto the background form"
	self updateBackgroundForm.

! !
Magnitude subclass: #Number
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Number commentStamp: '<historical>' prior: 0!
I am an abstract representation of a number. My subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity.

All my subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons.  It works as follows:  If
	self<typeA> op: arg<typeB>
fails because of incompatible types, then it is retried in the following guise:
	(arg adaptTypeA: self) op: arg adaptToTypeA.
This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved.  If self is more general, then arg will be converted, and viceVersa.  This mechanism is extensible to any new number classes that one might wish to add to Squeak.  The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.!


!Number methodsFor: 'arithmetic'!
* aNumber 
	"Answer the result of multiplying the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
+ aNumber 
	"Answer the sum of the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
- aNumber 
	"Answer the difference between the receiver and aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
/ aNumber 
	"Answer the result of dividing the receiver by aNumber."

	self subclassResponsibility! !

!Number methodsFor: 'arithmetic'!
// aNumber 
	"Integer quotient defined by division with truncation toward negative 
	infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder 
	from this division."

	^(self / aNumber) floor! !

!Number methodsFor: 'arithmetic'!
\\ aNumber 
	"modulo. Remainder defined in terms of //. Answer a Number with the 
	same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1."

	^self - (self // aNumber * aNumber)! !

!Number methodsFor: 'arithmetic'!
abs
	"Answer a Number that is the absolute value (positive magnitude) of the 
	receiver."

	self < 0
		ifTrue: [^self negated]
		ifFalse: [^self]! !

!Number methodsFor: 'arithmetic'!
negated
	"Answer a Number that is the negation of the receiver."

	^0 - self! !

!Number methodsFor: 'arithmetic'!
quo: aNumber 
	"Integer quotient defined by division with truncation toward zero. -9 quo: 
	4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division."

	^(self / aNumber) truncated! !

!Number methodsFor: 'arithmetic'!
reciprocal
	"Answer 1 divided by the receiver. Create an error notification if the 
	receiver is 0."

	self = 0
		ifTrue: [^self error: 'zero has no reciprocal']
		ifFalse: [^1 / self]! !

!Number methodsFor: 'arithmetic'!
rem: aNumber 
	"Remainder defined in terms of quo:. Answer a Number with the same 
	sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1."

	^self - ((self quo: aNumber) * aNumber)! !


!Number methodsFor: 'mathematical functions'!
arcCos 
	"The receiver is the cosine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcCos! !

!Number methodsFor: 'mathematical functions'!
arcSin
	"The receiver is the sine of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcSin! !

!Number methodsFor: 'mathematical functions'!
arcTan
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^self asFloat arcTan! !

!Number methodsFor: 'mathematical functions' stamp: 'jsp 2/24/1999 15:20'!
arcTan: denominator
	"The receiver is the tangent of an angle. Answer the angle measured in 
	radians."

	^(self asFloat) arcTan: denominator.! !

!Number methodsFor: 'mathematical functions'!
cos
	"The receiver represents an angle measured in radians. Answer its cosine."

	^self asFloat cos! !

!Number methodsFor: 'mathematical functions'!
exp
	"Answer the exponential of the receiver as a floating point number."

	^self asFloat exp! !

!Number methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:16'!
floorLog: radix
	"Answer the floor of the log base radix of the receiver."

	^ self asFloat floorLog: radix
! !

!Number methodsFor: 'mathematical functions' stamp: 'ar 8/31/2000 20:05'!
interpolateTo: aNumber at: param
	^self + (aNumber - self * param)! !

!Number methodsFor: 'mathematical functions'!
ln
	"Answer the natural log of the receiver."

	^self asFloat ln! !

!Number methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'!
log
	"Answer the base-10 log of the receiver."

	^self asFloat log! !

!Number methodsFor: 'mathematical functions'!
log: aNumber 
	"Answer the log base aNumber of the receiver."

	^self ln / aNumber ln! !

!Number methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:35'!
raisedTo: aNumber 
	"Answer the receiver raised to aNumber."

	aNumber isInteger ifTrue:
		["Do the special case of integer power"
		^ self raisedToInteger: aNumber].
	self < 0 ifTrue:
		[ self error: self printString, ' raised to a non-integer power' ].
	aNumber = 0 ifTrue: [^ 1].		"Special case of exponent=0"
	(self = 0) | (aNumber = 1) ifTrue:
		[^ self].						"Special case of exponent=1"
	^ (aNumber * self ln) exp		"Otherwise use logarithms"! !

!Number methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:32'!
raisedToInteger: anInteger 
	"Answer the receiver raised to the power anInteger where the argument 
	must be a kind of Integer. This is a special case of raisedTo:."

	anInteger isInteger ifFalse:
		[^self error: 'raisedToInteger: only works for integral arguments'].
	anInteger = 0 ifTrue: [^ 1].
	(self = 0) | (anInteger = 1) ifTrue: [^ self].
	anInteger > 1 ifTrue:
		[^ (self * self raisedToInteger: anInteger // 2)
					* (self raisedToInteger: anInteger \\ 2)].
	^ (self raisedToInteger: anInteger negated) reciprocal! !

!Number methodsFor: 'mathematical functions'!
sin
	"The receiver represents an angle measured in radians. Answer its sine."

	^self asFloat sin! !

!Number methodsFor: 'mathematical functions'!
sqrt
	"Answer the square root of the receiver."

	^self asFloat sqrt! !

!Number methodsFor: 'mathematical functions'!
squared
	"Answer the receiver multipled by itself."

	^self * self! !

!Number methodsFor: 'mathematical functions'!
tan
	"The receiver represents an angle measured in radians. Answer its 
	tangent."

	^self asFloat tan! !


!Number methodsFor: 'truncation and round off'!
ceiling
	"Answer the integer nearest the receiver toward positive infinity."

	self <= 0.0
		ifTrue: [^self truncated]
		ifFalse: [^self negated floor negated]! !

!Number methodsFor: 'truncation and round off' stamp: 'di 2/19/98 21:58'!
detentBy: detent atMultiplesOf: grid snap: snap
	"Map all values that are within detent/2 of any multiple of grid to that multiple.  Otherwise, if snap is true, return self, meaning that the values in the dead zone will never be returned.  If snap is false, then expand the range between dead zones so that it covers the range between multiples of the grid, and scale the value by that factor."
	| r1 r2 |
	r1 _ self roundTo: grid.  "Nearest multiple of grid"
	(self roundTo: detent) = r1 ifTrue: [^ r1].  "Snap to that multiple..."
	snap ifTrue: [^ self].  "...or return self"

	r2 _ self < r1  "Nearest end of dead zone"
		ifTrue: [r1 - (detent asFloat/2)]
		ifFalse: [r1 + (detent asFloat/2)].
	"Scale values between dead zones to fill range between multiples"
	^ r1 + ((self - r2) * grid asFloat / (grid - detent))
"
	(170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: true] 	(170 to: 190 by: 2) collect: [:a | a detentBy: 10 atMultiplesOf: 90 snap: false]
	(3.9 to: 4.1 by: 0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: true] 	(-3.9 to: -4.1 by: -0.02) collect: [:a | a detentBy: 0.1 atMultiplesOf: 1.0 snap: false]
"! !

!Number methodsFor: 'truncation and round off'!
floor
	"Answer the integer nearest the receiver toward negative infinity."

	| truncation |
	truncation _ self truncated.
	self >= 0 ifTrue: [^truncation].
	self = truncation
		ifTrue: [^truncation]
		ifFalse: [^truncation - 1]! !

!Number methodsFor: 'truncation and round off' stamp: 'di 10/4/1999 08:08'!
roundTo: quantum 
	"Answer the nearest number that is a multiple of quantum."

	^(self / quantum) rounded * quantum! !

!Number methodsFor: 'truncation and round off'!
roundUpTo: aNumber 
	"Answer the next multiple of aNumber toward infinity that is nearest the 
	receiver."

	^(self/aNumber) ceiling * aNumber! !

!Number methodsFor: 'truncation and round off'!
rounded
	"Answer the integer nearest the receiver."

	^(self + (self sign / 2)) truncated! !

!Number methodsFor: 'truncation and round off'!
truncateTo: aNumber 
	"Answer the next multiple of aNumber toward zero that is nearest the 
	receiver."

	^(self quo: aNumber)
		* aNumber! !

!Number methodsFor: 'truncation and round off'!
truncated
	"Answer an integer nearest the receiver toward zero."

	^self quo: 1! !


!Number methodsFor: 'testing' stamp: 'sw 4/25/1998 12:50'!
basicType
	^ #number! !

!Number methodsFor: 'testing'!
even
	"Answer whether the receiver is an even number."

	^self \\ 2 = 0! !

!Number methodsFor: 'testing' stamp: 'sw 12/30/1998 13:21'!
isDivisibleBy: aNumber
	aNumber = 0 ifTrue: [^ false].
	aNumber isInteger ifFalse: [^ false].
	^ (self \\ aNumber) = 0! !

!Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'!
isInf
	^ false! !

!Number methodsFor: 'testing' stamp: 'tao 4/19/98 23:33'!
isInfinite

	^ false! !

!Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'!
isNaN
	^ false! !

!Number methodsFor: 'testing'!
isNumber
	^ true! !

!Number methodsFor: 'testing'!
isZero
	^self = 0! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'!
negative
	"Answer whether the receiver is mathematically negative."

	^ self < 0! !

!Number methodsFor: 'testing'!
odd
	"Answer whether the receiver is an odd number."

	^self even == false! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:17'!
positive
	"Answer whether the receiver is positive or equal to 0. (ST-80 protocol).
	See also strictlyPositive"

	^ self >= 0! !

!Number methodsFor: 'testing'!
sign
	"Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0."

	self > 0 ifTrue: [^1].
	self < 0 ifTrue: [^-1].
	^0! !

!Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'!
strictlyPositive
	"Answer whether the receiver is mathematically positive."

	^ self > 0! !


!Number methodsFor: 'converting'!
@ y 
	"Primitive. Answer a Point whose x value is the receiver and whose y 
	value is the argument. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 18>
	^Point x: self y: y! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a Collection, return a Collection of
	the results of each element combined with me in that expression."

	^ rcvr collect: [:element | element perform: selector with: self]! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:21'!
adaptToFloat: rcvr andSend: selector 
	"If I am involved in arithmetic with a Float, convert me to a Float."
	^ rcvr perform: selector with: self asFloat! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToFraction: rcvr andSend: selector
	"If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToInteger: rcvr andSend: selector
	"If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock."
	^ self subclassResponsibility! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a Point, convert me to a Point."
	^ rcvr perform: selector with: self@self! !

!Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !

!Number methodsFor: 'converting'!
asInteger
	"Answer an Integer nearest the receiver toward zero."

	^self truncated! !

!Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'!
asNumber
	^ self! !

!Number methodsFor: 'converting'!
asPoint
	"Answer a Point with the receiver as both coordinates; often used to 
	supply the same value in two dimensions, as with symmetrical gridding 
	or scaling."

	^self @ self! !

!Number methodsFor: 'converting' stamp: 'sw 9/8/97 16:30'!
asSmallAngleDegrees
	"Return the receiver normalized to lie within the range (-180, 180)"

	| pos |
	pos _ self \\ 360.
	pos > 180 ifTrue: [pos _ pos - 360].
	^ pos

"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallAngleDegrees]"! !

!Number methodsFor: 'converting' stamp: 'sw 10/7/1999 12:24'!
asSmallPositiveDegrees
	"Return the receiver normalized to lie within the range (0, 360)"

	| result |
	result _ self.
	[result < 0] whileTrue: [result _ result + 360].
	^ result \\ 360

"#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallPositiveDegrees]"! !

!Number methodsFor: 'converting'!
degreesToRadians
	"The receiver is assumed to represent degrees. Answer the conversion to 
	radians."

	^self asFloat degreesToRadians! !

!Number methodsFor: 'converting'!
radiansToDegrees
	"The receiver is assumed to represent radians. Answer the conversion to 
	degrees."

	^self asFloat radiansToDegrees! !


!Number methodsFor: 'intervals'!
to: stop
	"Answer an Interval from the receiver up to the argument, stop, 
	incrementing by 1."

	^Interval from: self to: stop by: 1! !

!Number methodsFor: 'intervals'!
to: stop by: step
	"Answer an Interval from the receiver up to the argument, stop, 
	incrementing by step."

	^Interval from: self to: stop by: step! !

!Number methodsFor: 'intervals' stamp: 'tao 1/30/1999 08:58'!
to: stop by: step do: aBlock 
	"Normally compiled in-line, and therefore not overridable.
	Evaluate aBlock for each element of the interval (self to: stop by: 
step)."
	| nextValue |
	nextValue _ self.
	step = 0 ifTrue: [self error: 'step must be non-zero'].
	step < 0
		ifTrue: [[stop <= nextValue]
				whileTrue: 
					[aBlock value: nextValue.
					nextValue _ nextValue + step]]
		ifFalse: [[stop >= nextValue]
				whileTrue: 
					[aBlock value: nextValue.
					nextValue _ nextValue + step]]! !

!Number methodsFor: 'intervals'!
to: stop do: aBlock 
	"Normally compiled in-line, and therefore not overridable.
	Evaluate aBlock for each element of the interval (self to: stop by: 1)."
	| nextValue |
	nextValue _ self.
	[nextValue <= stop]
		whileTrue: 
			[aBlock value: nextValue.
			nextValue _ nextValue + 1]! !


!Number methodsFor: 'printing'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."

	^ super defaultLabelForInspector, ': ', self printString! !

!Number methodsFor: 'printing' stamp: 'sw 6/29/1999 21:10'!
isOrAreStringWith: aNoun
	| result |
	result _ self = 1
		ifTrue:
			[' is one ']
		ifFalse:
			[self = 0
				ifTrue:
					[' are no ']
				ifFalse:
					[' are ', self printString, ' ']].
	result _ result, aNoun.
	self = 1 ifFalse: [result _ result, 's'].
	^ result

"#(0 1 2 98.6) do:
	[:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! !

!Number methodsFor: 'printing' stamp: 'sw 10/31/97 13:54'!
newTileMorphRepresentative
	^ TileMorph new addArrows; setLiteral: self; addSuffixIfCan
! !

!Number methodsFor: 'printing'!
printOn: aStream
	"Default print radix is 10"
	self printOn: aStream base: 10! !

!Number methodsFor: 'printing'!
printStringBase: base
	^ String streamContents:
		[:strm | self printOn: strm base: base]! !

!Number methodsFor: 'printing'!
storeOn: aStream 
	"Normal printing is OK for storing"
	self printOn: aStream! !

!Number methodsFor: 'printing'!
storeOn: aStream base: base
	"Append my printed representation to aStream, incuding the base."

	self printOn: aStream base: base! !

!Number methodsFor: 'printing'!
storeStringBase: base
	^ String streamContents: [:strm | self storeOn: strm base: base]! !

!Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'!
stringForReadout
	^ self rounded printString! !


!Number methodsFor: 'comparing' stamp: 'tk 4/16/1999 18:26'!
closeTo: num
	"are these two numbers close?"

	| ans |
	num isFloat ifTrue: [^ num closeTo: self asFloat].
	[ans _ self = num] ifError: [:aString :aReceiver | ^ false].
	^ ans! !


!Number methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'!
byteEncode:aStream
	^aStream writeNumber:self.
! !


!Number methodsFor: 'as yet unclassified'!
reduce
    "If self is close to an integer, return that integer"
    ^ self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Number class
	instanceVariableNames: ''!

!Number class methodsFor: 'instance creation' stamp: 'bf 12/9/1998 19:21'!
readFrom: stringOrStream 
	"Answer a number as described on aStream.  The number may
	include a leading radix specification, as in 16rFADE"
	| value base aStream sign |
	aStream _ (stringOrStream isMemberOf: String)
		ifTrue: [ReadStream on: stringOrStream]
		ifFalse: [stringOrStream].
	(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
	sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
	(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
	base _ 10.
	value _ Integer readFrom: aStream base: base.
	(aStream peekFor: $r)
		ifTrue: 
			["<base>r<integer>"
			(base _ value) < 2 ifTrue: [^self error: 'Invalid radix'].
			(aStream peekFor: $-) ifTrue: [sign _ sign negated].
			value _ Integer readFrom: aStream base: base].
	^ self readRemainderOf: value from: aStream base: base withSign: sign.! !

!Number class methodsFor: 'instance creation' stamp: 'tao 4/23/98 12:24'!
readFrom: stringOrStream base: base
	"Answer a number as described on aStream in the given number base."

	| aStream sign |
	aStream _ (stringOrStream isMemberOf: String)
		ifTrue: [ReadStream on: stringOrStream]
		ifFalse: [stringOrStream].
	(aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan].
	sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1].
	(aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign].
	^ self readRemainderOf: (Integer readFrom: aStream base: base)
			from: aStream base: base withSign: sign! !

!Number class methodsFor: 'instance creation' stamp: 'tao 4/23/98 12:12'!
readRemainderOf: integerPart from: aStream base: base withSign: sign
	"Read optional fractional part and exponent, and return the final result"

	| value fraction fracpos |

	value _ integerPart.
	(aStream peekFor: $.)
		ifTrue: 
			["<integer>.<fraction>"
			(aStream atEnd not and: [aStream peek digitValue between: 0 and: base - 1])
				ifTrue: 
					[fracpos _ aStream position.
					fraction _ Integer readFrom: aStream base: base.
					fraction _ 
						fraction asFloat / (base raisedTo: aStream position - fracpos).
					value _ value asFloat + fraction]
				ifFalse: 
					["oops - just <integer>."
					aStream skip: -1.		"un-gobble the period"
					^ value * sign
					"Number readFrom: '3r-22.2'"]].
	(aStream peekFor: $e)
		ifTrue: 
			["<integer>e<exponent>"
			value _ value * (base raisedTo: (Integer readFrom: aStream))].
	(value isFloat and: [value = 0.0 and: [sign = -1]])
		ifTrue: [^ Float negativeZero]
		ifFalse: [^ value * sign]! !
TileMorph subclass: #NumericReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!NumericReadoutTile methodsFor: 'keyboard' stamp: 'sw 11/5/97 14:03'!
wantsKeyboardFocusFor: aSubmorph
	^ aSubmorph putSelector notNil! !


!NumericReadoutTile methodsFor: 'literal' stamp: 'sw 9/10/1999 16:08'!
literal: anObject
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last informTarget! !

!NumericReadoutTile methodsFor: 'literal' stamp: 'sw 9/15/1999 15:14'!
setLiteralTo: anObject width: w
	"like literal:width: but does not inform the target"
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last setWidth: w.
	self updateLiteralLabel! !


!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 9/15/2000 23:27'!
abandonLabelFocus
	| aLabel |
	"If the receiver's label has editing focus, abandon it"
	self flag: #arNote. "Probably unnecessary"
	(aLabel _ self labelMorph) ifNotNil:
		[aLabel hasFocus ifTrue:
			[aLabel contents: aLabel readFromTarget.
			aLabel handsWithMeForKeyboardFocus do:
				[:aHand | aHand releaseKeyboardFocus]]]! !

!NumericReadoutTile methodsFor: 'mouse' stamp: 'di 1/21/98 09:38'!
arrowAction: delta
	"Update value based on delta"
	self literal: literal + delta! !

!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 10/25/2000 18:07'!
handlesMouseMove: evt
	^true! !

!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 10/22/2000 17:41'!
handlesMouseStillDown: evt
	^true! !

!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 10/25/2000 18:06'!
mouseDown: evt
	^self mouseStillDown: evt! !

!NumericReadoutTile methodsFor: 'mouse' stamp: 'ar 10/22/2000 17:42'!
mouseStillDown: evt
	"Copied from TileMorph mouseMove to use literal:width: rather than literal:."

	| p label |
	self flag: #arNote. "Fix 'significant' events below"
	upArrow ifNotNil:
		[p _ evt cursorPoint.
		self abandonLabelFocus.
		label _ self findA: UpdatingStringMorph.

		label ifNotNil:
			[label step. literal _ label valueFromContents].

		(upArrow containsPoint: p)
			ifTrue: [self variableDelay:
						[self literal: (self numericValue + 1)].
					^ evt "hand noteSignificantEvent: evt"].
		(downArrow containsPoint: p)
			ifTrue: [self variableDelay:
						[self literal: (self numericValue - 1)].
					^ evt "hand noteSignificantEvent: evt"]].

	super mouseStillDown: evt.
! !


!NumericReadoutTile methodsFor: 'size' stamp: 'sw 9/17/1999 08:01'!
basicWidth
	^ 26! !

!NumericReadoutTile methodsFor: 'size' stamp: 'sw 9/17/1999 08:18'!
minimumWidth
	^ 40! !
MacExternalData variableWordSubclass: #OSAID
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Applescript'!
!OSAID commentStamp: '<historical>' prior: 0!
I am an ExternalData representation of an OSAID handle.  OSAIDs are low-level representations of Applescript information stored in an active scripting component.  For further Information, see Apple's Inside Macintosh: Interapplication Communications, at

	http://developer.apple.com/techpubs/mac/IAC/IAC-2.html.

Essentially, I represent a record comprising a one-word handle for manipulation by the scripting component.  Virtually all operations are done on objects with OSAID forms.  Accordingly, text and compiled script information is reduced to AEDesc objects, and then processed into or from OSAID form for later manipulation.  The OSAID can then be "coerced" back into text or compiled script information, typically indirectly through AEDesc Objects. !
]style[(256 54 448)f1,f1Rhttp://developer.apple.com/techpubs/mac/IAC/IAC-2.html;,f1!


!OSAID methodsFor: 'interpretation' stamp: 'acg 9/26/1999 02:14'!
doIt

	^self doItWith: Applescript generic in: (OSAID new) mode: 0! !

!OSAID methodsFor: 'interpretation' stamp: 'acg 9/26/1999 02:14'!
doItWith: anApplescriptInstance in: aContext mode: anInteger

	| resultID displayResult |
	resultID _ anApplescriptInstance executeOSAID: self in: aContext mode: anInteger.
	resultID ifNil: [^nil].
	displayResult _ anApplescriptInstance 
		displayAndDisposeOSAID: resultID 
		as: 'TEXT' 
		mode: anInteger.
	displayResult ifNil: [^nil].
	^displayResult asStringThenDispose! !

!OSAID methodsFor: 'interpretation' stamp: 'acg 9/22/1999 09:16'!
isEmpty

	^(self at: 1) isZero! !


!OSAID methodsFor: 'conversions' stamp: 'acg 9/26/1999 18:26'!
asAEDescWith: anApplescriptInstance

	^anApplescriptInstance storeOSAID: self type: 'scpt' mode: 0
	! !

!OSAID methodsFor: 'conversions' stamp: 'acg 9/26/1999 18:27'!
asCompiledApplescriptWith: anApplescriptInstance

	| anAEDesc |
	anAEDesc _ self asAEDescWith: anApplescriptInstance.
	anAEDesc ifNil: [^nil].
	^anAEDesc asCompiledApplescriptThenDispose	! !


!OSAID methodsFor: 'creation/release' stamp: 'acg 9/26/1999 00:28'!
dispose

	^self disposeWith: Applescript generic! !

!OSAID methodsFor: 'creation/release' stamp: 'acg 9/22/1999 08:34'!
disposeWith: aComponent

	| result |
	(0 = (self at: 1)) ifTrue:
		[self error: 'cannot dispose unallocated OSAID'].
	result _ aComponent primOSADispose: self.
	result isZero ifFalse: 
		[self error: 'dispose operation failed'].
	self at: 1 put: 0.
	^nil! !


!OSAID methodsFor: 'private' stamp: 'acg 9/21/1999 00:05'!
initialize

	self at: 1 put: 0! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

OSAID class
	instanceVariableNames: ''!

!OSAID class methodsFor: 'as yet unclassified' stamp: 'acg 9/21/1999 00:05'!
new

	^(super new: 1) initialize; yourself! !
ProtoObject subclass: #Object
	instanceVariableNames: ''
	classVariableNames: 'DependentsFields EventsFields '
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!Object commentStamp: '<historical>' prior: 0!
Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses.

Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here.

Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes.

Class Variables:
	DependentsFields		an IdentityDictionary
		Provides a virtual 'dependents' field so that any object may have one
		or more dependent views, synchronized by the changed:/update: protocol.
		Note that class Model has a real slot for its dependents, and overrides
		the associated protocol with more efficient implementations.
	EventsFields			an IdentityDictionary that maps each object to its dependents.
		Registers a message send (consisting of a selector and a receiver object)
		which should be performed when anEventSymbol is triggered by the receiver.
		Part of a new event notification framework which could eventually replace
		the existing changed/update mechanism.  It is intended to be compatible
		with Dolphin Smalltalk and VSE as much as possible.

Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.!


!Object methodsFor: 'accessing' stamp: 'sw 4/30/1998 12:18'!
addInstanceVarNamed: aName withValue: aValue
	"Add an instance variable named aName and give it value aValue"
	self class addInstVarName: aName asString.
	self instVarAt: self class instSize put: aValue! !

!Object methodsFor: 'accessing' stamp: 'di 3/29/1999 11:39'!
at: index 
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue:
		[self class isVariable
			ifTrue: [self errorSubscriptBounds: index]
			ifFalse: [self error: (self class name) , 's are not indexable']].
	index isNumber
		ifTrue: [^self at: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
at: index modify: aBlock
	"Replace the element of the collection with itself transformed by the block"
	^ self at: index put: (aBlock value: (self at: index))! !

!Object methodsFor: 'accessing' stamp: 'di 3/29/1999 11:41'!
at: index put: value 
	"Primitive. Assumes receiver is indexable. Store the argument value in 
	the indexable element of the receiver indicated by index. Fail if the 
	index is not an Integer or is out of bounds. Or fail if the value is not of 
	the right type for this kind of collection. Answer the value that was 
	stored. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger ifTrue:
		[self class isVariable
			ifTrue: [(index >= 1 and: [index <= self size])
					ifTrue: [self errorImproperStore]
					ifFalse: [self errorSubscriptBounds: index]]
			ifFalse: [self error: (self class name) , 's are not indexable']].
	index isNumber
		ifTrue: [^self at: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
basicAt: index 
	"Primitive. Assumes receiver is indexable. Answer the value of an 
	indexable element in the receiver. Fail if the argument index is not an 
	Integer or is out of bounds. Essential. Do not override in a subclass. See 
	Object documentation whatIsAPrimitive."

	<primitive: 60>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber
		ifTrue: [^self basicAt: index asInteger]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
basicAt: index put: value 
	"Primitive. Assumes receiver is indexable. Store the second argument 
	value in the indexable element of the receiver indicated by index. Fail 
	if the index is not an Integer or is out of bounds. Or fail if the value is 
	not of the right type for this kind of collection. Answer the value that 
	was stored. Essential. Do not override in a subclass. See Object 
	documentation whatIsAPrimitive."

	<primitive: 61>
	index isInteger
		ifTrue: [(index >= 1 and: [index <= self size])
					ifTrue: [self errorImproperStore]
					ifFalse: [self errorSubscriptBounds: index]].
	index isNumber
		ifTrue: [^self basicAt: index asInteger put: value]
		ifFalse: [self errorNonIntegerIndex]! !

!Object methodsFor: 'accessing'!
basicSize
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. Do not 
	override in any subclass. See Object documentation whatIsAPrimitive."

	<primitive: 62>
	"The number of indexable fields of fixed-length objects is 0"
	^0	! !

!Object methodsFor: 'accessing'!
bindWithTemp: aBlock
	^ aBlock value: self value: nil! !

!Object methodsFor: 'accessing' stamp: 'di 11/8/2000 21:05'!
doIfNotNil: aBlock
	"Deprecated -- use ifNotNilDo:"

	^ self ifNotNilDo: aBlock
! !

!Object methodsFor: 'accessing' stamp: 'di 11/8/2000 21:04'!
ifNotNilDo: aBlock
	"Evaluate the given block with the receiver as its argument."

	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'tk 4/17/1999 10:09'!
in: aBlock
	"Evaluate the given block with the receiver as its argument."

	(aBlock isKindOf: BlockContext) ifFalse: [self error: 'expecting a block'].
	^ aBlock value: self
! !

!Object methodsFor: 'accessing' stamp: 'sw 10/17/2000 11:15'!
presenter
	"Answer the presenter object associated with the receiver.  For morphs, there is in effect a clear containment hierarchy of presenters (accessed via their association with PasteUpMorphs); for arbitrary objects the hook is simply via the current world, at least at present."

	^ self currentWorld presenter! !

!Object methodsFor: 'accessing'!
readFromString: aString
	"Create an object based on the contents of aString."

	^self readFrom: (ReadStream on: aString)! !

!Object methodsFor: 'accessing' stamp: 'di 3/29/1999 13:10'!
size
	"Primitive. Answer the number of indexable variables in the receiver. 
	This value is the same as the largest legal subscript. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 62>
	self class isVariable ifFalse: [self errorNotIndexable].
	^ 0! !

!Object methodsFor: 'accessing'!
yourself
	"Answer self."! !


!Object methodsFor: 'testing' stamp: 'sw 4/25/1998 12:50'!
basicType
	"number string boolean player collection sound color etc"
	^ #object! !

!Object methodsFor: 'testing' stamp: 'sw 10/16/2000 10:41'!
beViewed
	"Open up a viewer on the receiver.  The Presenter is invited to decide just how to present this viewer"

	self presenter viewObject: self! !

!Object methodsFor: 'testing' stamp: 'sw 10/16/2000 11:01'!
costumes
	"Answer a list of costumes associated with the receiver.  The appearance of this method in class Object serves only as a backstop, probably only transitionally"

	^ nil! !

!Object methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'!
haltIfNil! !

!Object methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'!
isBehavior
	"Return true if the receiver is a behavior.
	Note: Do not override in any class except behavior."
	^false! !

!Object methodsFor: 'testing' stamp: 'ar 8/17/1999 19:43'!
isCollection
	"Return true if the receiver is some sort of Collection and responds to basic collection messages such as #size and #do:"
	^false! !

!Object methodsFor: 'testing'!
isColor
	"Answer true if receiver is a Color. False by default."

	^ false
! !

!Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'!
isFloat
	"Overridden to return true in Float, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: 'len 1/13/98 21:18'!
isFraction
	"Answer true if the receiver is a Fraction."

	^ false! !

!Object methodsFor: 'testing'!
isInteger
	"Overridden to return true in Integer."

	^ false! !

!Object methodsFor: 'testing'!
isMorph

	^ false! !

!Object methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'!
isMorphicEvent
	^false! !

!Object methodsFor: 'testing'!
isNumber
	"Overridden to return true in Number, natch"
	^ false! !

!Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'!
isPoint
	"Overridden to return true in Point."

	^ false! !

!Object methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'!
isPseudoContext
	^false! !

!Object methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'!
isStream
	"Return true if the receiver responds to the stream protocol"
	^false
! !

!Object methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'!
isString
	"Overridden to return true in String, natch"
	^ false! !

!Object methodsFor: 'testing'!
isText
	^ false! !

!Object methodsFor: 'testing' stamp: 'tk 10/21/97 12:45'!
isTransparent
	^ false! !

!Object methodsFor: 'testing' stamp: 'ls 7/14/1998 21:45'!
isWebBrowser
	"whether this object is a web browser.  See class: Scamper"
	^false! !

!Object methodsFor: 'testing' stamp: 'sw 10/27/2000 06:58'!
knownName
	"If a formal name has been handed out for this object, answer it, else nil"
	
	^ Preferences capitalizedReferences
		ifTrue:
			[References keyAtValue: self ifAbsent: [nil]]
		ifFalse:
			[nil]! !

!Object methodsFor: 'testing' stamp: 'sw 9/27/96'!
name
	"Answer a name for the receiver.  This is used generically in the title of certain inspectors, such as the referred-to inspector, and specificially by various subsystems.  By default, we let the object just print itself out..  "

	^ self printString! !

!Object methodsFor: 'testing' stamp: 'sw 10/27/2000 17:52'!
nameForViewer
	"Answer a name to be shown in a Viewer that is viewing the receiver"

	| aName |
	(aName _ self uniqueNameForReferenceOrNil) ifNotNil: [^ aName].

	^ (self printString copyWithout: Character cr) withNoLineLongerThan:  20! !

!Object methodsFor: 'testing'!
notNil
	"Coerces nil to false and everything else to true."

	^true! !

!Object methodsFor: 'testing' stamp: 'sw 1/18/2001 13:43'!
showDiffs
	"Answer whether the receiver, serving as the model of a text-bearing entity, is 'showing differences' -- if it is, the editor may wish to show special feedback"

	^ false! !

!Object methodsFor: 'testing' stamp: 'sw 10/20/1999 14:52'!
stepAt: millisecondClockValue in: aWindow

	^ self stepIn: aWindow! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:16'!
stepIn: aWindow

	^ self step! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:21'!
stepTime
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:22'!
stepTimeIn: aSystemWindow
	
	^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! !

!Object methodsFor: 'testing' stamp: 'di 1/8/1999 15:04'!
wantsSteps
	"Overridden by morphic classes whose instances want to be stepped,
	or by model classes who want their morphic views to be stepped."

	^ false! !

!Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:26'!
wantsStepsIn: aSystemWindow
	
	^ self wantsSteps! !


!Object methodsFor: 'comparing'!
= anObject 
	"Answer whether the receiver and the argument represent the same 
	object. If = is redefined in any subclass, consider also redefining the 
	message hash."

	^self == anObject! !

!Object methodsFor: 'comparing' stamp: 'tk 4/16/1999 18:26'!
closeTo: anObject
	"Answer whether the receiver and the argument represent the same
	object. If = is redefined in any subclass, consider also redefining the
	message hash."

	| ans |
	[ans _ self = anObject] ifError: [:aString :aReceiver | ^ false].
	^ ans! !

!Object methodsFor: 'comparing'!
hash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	May be overridden, and should be overridden in any classes that define = "

	^ self identityHash! !

!Object methodsFor: 'comparing' stamp: 'pm 9/23/97 09:36'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^map newHashFor: self! !

!Object methodsFor: 'comparing' stamp: 'di 9/27/97 20:23'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^map newHashFor: self! !

!Object methodsFor: 'comparing' stamp: 'sw 8/20/1998 12:34'!
identityHashPrintString
	"'fred' identityHashPrintString"

	^ '(', self identityHash printString, ')'! !

!Object methodsFor: 'comparing'!
~= anObject 
	"Answer whether the receiver and the argument do not represent the 
	same object."

	^self = anObject == false! !


!Object methodsFor: 'copying'!
clone

	<primitive: 148>
	self primitiveFailed! !

!Object methodsFor: 'copying'!
copy
	"Answer another instance just like the receiver. Subclasses typically 
	override this method; they typically do not override shallowCopy."

	^self shallowCopy! !

!Object methodsFor: 'copying' stamp: 'tk 8/20/1998 16:01'!
copyAddedStateFrom: anotherObject
	"Copy over the values of instance variables added by the receiver's class from anotherObject to the receiver.  These will be remapped in mapUniClasses, if needed."

	self class superclass instSize + 1 to: self class instSize do:
		[:index | self instVarAt: index put: (anotherObject instVarAt: index)]! !

!Object methodsFor: 'copying' stamp: 'tk 11/27/1998 09:00'!
copyFrom: anotherObject
	"Copy to myself all instance variables I have in common with anotherObject.  This is dangerous because it ignores an object's control over its own inst vars.  "

	| mine his |
	mine _ self class allInstVarNames.
	his _ anotherObject class allInstVarNames.
	1 to: (mine size min: his size) do: [:ind |
		(mine at: ind) = (his at: ind) ifTrue: [
			self instVarAt: ind put: (anotherObject instVarAt: ind)]].
	self class isVariable & anotherObject class isVariable ifTrue: [
		1 to: (self basicSize min: anotherObject basicSize) do: [:ind |
			self basicAt: ind put: (anotherObject basicAt: ind)]].! !

!Object methodsFor: 'copying' stamp: 'di 6/9/1999 14:44'!
copySameFrom: otherObject
	"Copy to myself all instance variables named the same in otherObject.
	This ignores otherObject's control over its own inst vars."

	| myInstVars otherInstVars match |
	myInstVars _ self class allInstVarNames.
	otherInstVars _ otherObject class allInstVarNames.
	myInstVars doWithIndex: [:each :index |
		(match _ otherInstVars indexOf: each) > 0 ifTrue:
			[self instVarAt: index put: (otherObject instVarAt: match)]]
! !

!Object methodsFor: 'copying' stamp: 'tk 4/20/1999 14:44'!
copyTwoLevel
	"one more level than a shallowCopy"

	| newObject class index |
	class _ self class.
	newObject _ self clone.
	newObject == self ifTrue: [^ self].
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index) shallowCopy.
					index _ index - 1]].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index) shallowCopy.
			index _ index - 1].
	^newObject! !

!Object methodsFor: 'copying'!
deepCopy
	"Answer a copy of the receiver with its own copy of each instance 
	variable."

	| newObject class index |
	class _ self class.
	(class == Object) ifTrue: [^self].
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			newObject _ class basicNew: index.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index) deepCopy.
					index _ index - 1]]
		ifFalse: [newObject _ class basicNew].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index) deepCopy.
			index _ index - 1].
	^newObject! !

!Object methodsFor: 'copying' stamp: 'hg 11/23/1999 13:43'!
initialDeepCopierSize
	"default value is 4096; other classes may override this, esp. for smaller (=faster) sizes"

	^4096! !

!Object methodsFor: 'copying' stamp: 'jm 11/14/97 11:08'!
shallowCopy
	"Answer a copy of the receiver which shares the receiver's instance variables."
	| class newObject index |
	<primitive: 148>
	class _ self class.
	class isVariable
		ifTrue: 
			[index _ self basicSize.
			newObject _ class basicNew: index.
			[index > 0]
				whileTrue: 
					[newObject basicAt: index put: (self basicAt: index).
					index _ index - 1]]
		ifFalse: [newObject _ class basicNew].
	index _ class instSize.
	[index > 0]
		whileTrue: 
			[newObject instVarAt: index put: (self instVarAt: index).
			index _ index - 1].
	^ newObject! !

!Object methodsFor: 'copying' stamp: 'tk 1/2/2001 10:53'!
veryDeepCopy
	"Do a complete tree copy using a dictionary.  An object in the tree twice is only copied once.  All references to the object in the copy of the tree will point to the new copy."

	| copier new refs newDep newModel |
	copier _ DeepCopier new initialize: self initialDeepCopierSize.
	new _ self veryDeepCopyWith: copier.
	copier mapUniClasses.
	copier references associationsDo: [:assoc | 
		assoc value veryDeepFixupWith: copier].
	"Fix dependents"
	refs _ copier references.
	DependentsFields associationsDo: [:pair |
		pair value do: [:dep | 
			(newDep _ refs at: dep ifAbsent: [nil]) ifNotNil: [
				newModel _ refs at: pair key ifAbsent: [pair key].
				newModel addDependent: newDep]]].
	^ new! !

!Object methodsFor: 'copying' stamp: 'tk 1/8/2001 10:36'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new uc sup has mine |
	deepCopier references at: self ifPresent: [:newer | ^ newer]. 	"already did him"
	class _ self class.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self clone.
	class isSystemDefined ifFalse: [
		uc _ deepCopier uniClasses at: class ifAbsent: [nil].
		uc ifNil: [deepCopier uniClasses at: class put: (uc _ self copyUniClassWith: deepCopier)].
		new _ uc new].
	deepCopier references at: self put: new.	"remember"
	(class isVariable and: [class isPointers]) ifTrue: 
		[index _ self basicSize.
		[index > 0] whileTrue: 
			[sub _ self basicAt: index.
			(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
				ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)]
				ifNotNil: [new basicAt: index put: subAss value].
			index _ index - 1]].
	"Ask each superclass if it wants to share (weak copy) any inst vars"
	new veryDeepInner: deepCopier.		"does super a lot"

	"other superclasses want all inst vars deep copied"
	sup _ class.  index _ class instSize.
	[has _ sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil].
	mine _ sup instVarNames.
	has ifNotNil: [index _ index - mine size]
		ifNil: [1 to: mine size do: [:xx |
				sub _ self instVarAt: index.
				(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
						"use association, not value, so nil is an exceptional value"
					ifNil: [new instVarAt: index put: 
								(sub veryDeepCopyWith: deepCopier)]
					ifNotNil: [new instVarAt: index put: subAss value].
				index _ index - 1]].
	(sup _ sup superclass) == nil] whileFalse.
	new rehash.	"force Sets and Dictionaries to rehash"
	^ new
! !

!Object methodsFor: 'copying' stamp: 'tk 1/6/1999 17:39'!
veryDeepFixupWith: deepCopier
	"I have no fields and no superclass.  Catch the super call."
! !

!Object methodsFor: 'copying' stamp: 'tk 1/6/1999 15:47'!
veryDeepInner: deepCopier
	"I have no fields and no superclass"
! !


!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:24'!
addDependent: anObject
	"Make the given object one of the receiver's dependents."

	| dependents |
	dependents _ self dependents.
	(dependents includes: anObject) ifFalse:
		[self myDependents: (dependents copyWith: anObject)].
	^ anObject! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:53'!
breakDependents
	"Remove all of the receiver's dependents."

	self myDependents: nil! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:26'!
canDiscardEdits
	"Answer true if none of the views on this model has unaccepted edits that matter."

	self dependents
		do: [:each | each canDiscardEdits ifFalse: [^ false]]
		without: self.
	^ true! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:58'!
dependents
	"Answer a collection of objects that are 'dependent' on the receiver;
	 that is, all objects that should be notified if the receiver changes."

	^ self myDependents ifNil: [#()]! !

!Object methodsFor: 'dependents access'!
evaluate: actionBlock wheneverChangeIn: aspectBlock
	| viewerThenObject objectThenViewer |
	objectThenViewer _ self.
	viewerThenObject _ ObjectViewer on: objectThenViewer.
	objectThenViewer become: viewerThenObject.
	"--- Then ---"
	objectThenViewer xxxViewedObject: viewerThenObject
			evaluate: actionBlock
			wheneverChangeIn: aspectBlock! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:59'!
hasUnacceptedEdits
	"Answer true if any of the views on this object has unaccepted edits."

	self dependents
		do: [:each | each hasUnacceptedEdits ifTrue: [^ true]]
		without: self.
	^ false! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:55'!
myDependents
	"Private. Answer a list of all the receiver's dependents."

	^ DependentsFields at: self ifAbsent: []! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:52'!
myDependents: aCollectionOrNil
	"Private. Set (or remove) the receiver's dependents list."

	aCollectionOrNil
		ifNil: [DependentsFields removeKey: self ifAbsent: []]
		ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:26'!
release
	"Remove references to objects that may refer to the receiver. This message 
	should be overridden by subclasses with any cycles, in which case the 
	subclass should also include the expression super release."

	self breakDependents.
	self removeAllEventsTriggered! !

!Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:23'!
removeDependent: anObject
	"Remove the given object as one of the receiver's dependents."

	| dependents |
	dependents _ self dependents reject: [:each | each == anObject].
	self myDependents: (dependents isEmpty ifFalse: [dependents]).
	^ anObject! !


!Object methodsFor: 'updating'!
changed
	"Receiver changed in a general way; inform all the dependents by 
	sending each dependent an update: message."

	self changed: self! !

!Object methodsFor: 'updating'!
changed: aParameter 
	"Receiver changed. The change is denoted by the argument aParameter. 
	Usually the argument is a Symbol that is part of the dependent's change 
	protocol. Inform all of the dependents."

	self dependents do: [:aDependent | aDependent update: aParameter]! !

!Object methodsFor: 'updating' stamp: 'sw 10/12/1999 18:15'!
handledListVerification
	"When a self-updating PluggableListMorph lazily checks to see the state of affairs, it first gives its model an opportunity to handle the list verification itself (this is appropriate for some models, such as VersionsBrowser); if a list's model has indeed handled things itself, it returns true here"

	^ false! !

!Object methodsFor: 'updating' stamp: 'sw 10/31/1999 00:15'!
noteSelectionIndex: anInteger for: aSymbol
	"backstop"! !

!Object methodsFor: 'updating'!
okToChange
	"Allows a controller to ask this of any model"
	^ true! !

!Object methodsFor: 'updating' stamp: 'sma 2/29/2000 20:05'!
update: aParameter 
	"Receive a change notice from an object of whom the receiver is a 
	dependent. The default behavior is to do nothing; a subclass might want 
	to change itself in some way."

	^ self! !

!Object methodsFor: 'updating' stamp: 'sw 10/19/1999 14:39'!
updateListsAndCodeIn: aWindow
	self canDiscardEdits ifFalse: [^ self].
	aWindow updatablePanes do: [:aPane | aPane verifyContents]! !

!Object methodsFor: 'updating' stamp: 'jm 8/20/1998 18:26'!
windowIsClosing
	"This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open."
! !


!Object methodsFor: 'printing' stamp: 'di 6/20/97 08:57'!
fullPrintString
	"Answer a String whose characters are a description of the receiver."

	^ String streamContents: [:s | self printOn: s]! !

!Object methodsFor: 'printing'!
isLiteral
	"Answer whether the receiver has a literal text form recognized by the 
	compiler."

	^false! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:28'!
longPrintOn: aStream
	"Append to the argument, aStream, the names and values of all 
	of the receiver's instance variables."

	self class allInstVarNames doWithIndex:
		[:title :index |
		aStream nextPutAll: title;
		 nextPut: $:;
		 space;
		 tab;
		 print: (self instVarAt: index);
		 cr]! !

!Object methodsFor: 'printing' stamp: 'sw 9/2/1999 15:18'!
longPrintString
	"Answer a String whose characters are a description of the receiver."
	^ String streamContents: [:aStream | self longPrintOn: aStream]! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:31'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that  
	identifies the receiver."

	| title |
	title _ self class name.
	aStream
		nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']);
		nextPutAll: title! !

!Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:22'!
printString
	"Answer a String whose characters are a description of the receiver. 
	If you want to print without a character limit, use fullPrintString."

	^ self printStringLimitedTo: 50000! !

!Object methodsFor: 'printing' stamp: 'tk 5/7/1999 16:20'!
printStringLimitedTo: limit
	"Answer a String whose characters are a description of the receiver.
	If you want to print without a character limit, use fullPrintString."
	| limitedString |
	limitedString _ String streamContents: [:s | self printOn: s] limitedTo: limit.
	limitedString size < limit ifTrue: [^ limitedString].
	^ limitedString , '...etc...'! !

!Object methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:30'!
propertyList
	"Answer a String whose characters are a property-list description of the receiver."

	^ PropertyListEncoder process:self.
! !

!Object methodsFor: 'printing' stamp: 'sw 10/17/2000 11:16'!
reportableSize
	"Answer a string that reports the size of the receiver -- useful for showing in a list view, for example"

	^ (self basicSize + self class instSize) printString! !

!Object methodsFor: 'printing'!
storeOn: aStream 
	"Append to the argument aStream a sequence of characters that is an 
	expression whose evaluation creates an object similar to the receiver."

	aStream nextPut: $(.
	self class isVariable
		ifTrue: [aStream nextPutAll: '(', self class name, ' basicNew: ';
					store: self basicSize;
					nextPutAll: ') ']
		ifFalse: [aStream nextPutAll: self class name, ' basicNew'].
	1 to: self class instSize do:
		[:i |
		aStream nextPutAll: ' instVarAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self instVarAt: i);
			nextPut: $;].
	1 to: self basicSize do:
		[:i |
		aStream nextPutAll: ' basicAt: ';
			store: i;
			nextPutAll: ' put: ';
			store: (self basicAt: i);
			nextPut: $;].
	aStream nextPutAll: ' yourself)'
! !

!Object methodsFor: 'printing' stamp: 'di 6/20/97 09:12'!
storeString
	"Answer a String representation of the receiver from which the receiver 
	can be reconstructed."

	^ String streamContents: [:s | self storeOn: s]! !

!Object methodsFor: 'printing' stamp: 'sw 5/2/1998 13:55'!
stringForReadout
	^ self stringRepresentation! !

!Object methodsFor: 'printing'!
stringRepresentation
	"Answer a string that represents the receiver.  For most objects this is simply its printString, but for strings themselves, it's themselves.  6/12/96 sw"

	^ self printString ! !


!Object methodsFor: 'class membership'!
class
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!Object methodsFor: 'class membership'!
isKindOf: aClass 
	"Answer whether the class, aClass, is a superclass or class of the receiver."

	self class == aClass
		ifTrue: [^true]
		ifFalse: [^self class inheritsFrom: aClass]! !

!Object methodsFor: 'class membership' stamp: 'sw 2/16/98 02:08'!
isKindOf: aClass orOf: anotherClass
	"Answer whether either of the classes, aClass or anotherClass,, is a superclass or class of the receiver.  A convenience; could be somewhat optimized"
	^ (self isKindOf: aClass) or: [self isKindOf: anotherClass]! !

!Object methodsFor: 'class membership'!
isMemberOf: aClass 
	"Answer whether the receiver is an instance of the class, aClass."

	^self class == aClass! !

!Object methodsFor: 'class membership'!
respondsTo: aSymbol 
	"Answer whether the method dictionary of the receiver's class contains 
	aSymbol as a message selector."

	^self class canUnderstand: aSymbol! !

!Object methodsFor: 'class membership' stamp: 'tk 10/21/1998 12:38'!
xxxClass
	"For subclasses of nil, such as ObjectOut"
	^ self class! !


!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol 
	"Send the unary selector, aSymbol, to the receiver.
	Fail if the number of arguments expected by the selector is not zero.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array new: 0)! !

!Object methodsFor: 'message handling' stamp: 'sw 10/30/1998 18:27'!
perform: selector orSendTo: otherTarget
	"If I wish to intercept and handle selector myself, do it; else send it to otherTarget"
	^ otherTarget perform: selector! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol with: anObject 
	"Send the selector, aSymbol, to the receiver with anObject as its argument.
	Fail if the number of arguments expected by the selector is not one.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array with: anObject)! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'!
perform: aSymbol with: firstObject with: secondObject 
	"Send the selector, aSymbol, to the receiver with the given arguments.
	Fail if the number of arguments expected by the selector is not two.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:51'!
perform: aSymbol with: firstObject with: secondObject with: thirdObject 
	"Send the selector, aSymbol, to the receiver with the given arguments.
	Fail if the number of arguments expected by the selector is not three.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 83>
	^ self perform: aSymbol
		withArguments: (Array with: firstObject with: secondObject with: thirdObject)! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:55'!
perform: selector withArguments: argArray 
	"Send the selector, aSymbol, to the receiver with arguments in argArray.
	Fail if the number of arguments expected by the selector 
	does not match the size of argArray.
	Primitive. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 84>
	^ self perform: selector withArguments: argArray inSuperclass: self class! !

!Object methodsFor: 'message handling' stamp: 'di 3/26/1999 08:00'!
perform: selector withArguments: argArray inSuperclass: lookupClass
	"NOTE:  This is just like perform:withArguments:, except that
	the message lookup process begins, not with the receivers's class,
	but with the supplied superclass instead.  It will fail if lookupClass
	cannot be found among the receiver's superclasses.
	Primitive. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 100>
	(selector isMemberOf: Symbol)
		ifFalse: [^ self error: 'selector argument must be a Symbol'].
	(selector numArgs = argArray size)
		ifFalse: [^ self error: 'incorrect number of arguments'].
	(self class == lookupClass or: [self class inheritsFrom: lookupClass])
		ifFalse: [^ self error: 'lookupClass is not in my inheritance chain'].
	self primitiveFailed! !


!Object methodsFor: 'error handling' stamp: 'sma 5/6/2000 19:35'!
assert: aBlock
	"Throw an assertion error if aBlock does not evaluates to true."

	aBlock value ifFalse: [AssertionFailure signal: 'Assertion failed']! !

!Object methodsFor: 'error handling' stamp: 'di 3/19/1999 10:31'!
cannotInterpret: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector.  Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose."

"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent."

	| handler errorString |
	(self class lookupSelector: aMessage selector) == nil ifFalse:
		["Simulated lookup succeeded -- resend the message."
		^ aMessage sentTo: self].

	"Could not recover by simulated lookup -- it's an error"
	errorString _ 'MethodDictionary fault'.
	(handler _ Processor activeProcess errorHandler) notNil
		ifTrue: [handler value: errorString value: self]
		ifFalse: [Debugger openContext: thisContext
					label: errorString
					contents: thisContext shortStack].
	^ aMessage sentTo: self! !

!Object methodsFor: 'error handling'!
caseError
	"Report an error from an in-line or explicit case statement."

	self error: 'Case not found, and no otherwise clause'! !

!Object methodsFor: 'error handling' stamp: 'sma 5/28/2000 15:48'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."

	"nil confirm: 'Are you hungry?'"

	^ PopUpMenu confirm: queryString! !

!Object methodsFor: 'error handling' stamp: 'sma 5/28/2000 15:55'!
confirm: aString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."

	^ PopUpMenu confirm: aString orCancel: cancelBlock! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 10:20'!
doesNotUnderstand: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)."
	"Testing: (3 activeProcess)"

	(Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage])
		ifTrue: [^ aMessage sentTo: self].
	MessageNotUnderstood new message: aMessage;
		signal.
	^aMessage sentTo: self! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:55'!
error: aString 
	"Throw a generic Error exception."

	^Error new signal: aString! !

!Object methodsFor: 'error handling' stamp: 'ar 6/28/2000 05:54'!
externalCallFailed
	"A call to an external function has failed."

	^ ExternalFunction externalCallFailed! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:54'!
halt
	"This is the typical message to use for inserting breakpoints during 
	debugging. It behaves like halt:, but does not call on halt: in order to 
	avoid putting this message on the stack. Halt is especially useful when 
	the breakpoint message is an arbitrary one."

	Halt signal! !

!Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:59'!
halt: aString 
	"This is the typical message to use for inserting breakpoints during 
	debugging. It creates and schedules a Notifier with the argument, 
	aString, as the label."
	
	Halt new signal: aString! !

!Object methodsFor: 'error handling' stamp: 'bf 9/27/1999 17:14'!
handles: exception
	"This method exists to break an endless loop in Exception>>findHandlerFrom: if the exception
is invalid"
	^false! !

!Object methodsFor: 'error handling' stamp: 'tk 4/16/1998 15:54'!
notify: aString 
	"Create and schedule a Notifier with the argument as the message in 
	order to request confirmation before a process can proceed."

	Debugger
		openContext: thisContext
		label: 'Notifier'
		contents: aString

	"nil notify: 'confirmation message'"! !

!Object methodsFor: 'error handling'!
notify: aString at: location
	"Create and schedule a Notifier with the argument as the message in 
	order to request confirmation before a process can proceed. Subclasses can
	override this and insert an error message at location within aString."

	self notify: aString

	"nil notify: 'confirmation message' at: 12"! !

!Object methodsFor: 'error handling'!
primitiveFailed
	"Announce that a primitive has failed and there is no appropriate 
	Smalltalk code to run."

	self error: 'a primitive has failed'! !

!Object methodsFor: 'error handling'!
shouldNotImplement
	"Announce that, although the receiver inherits this message, it should 
	not implement it."

	self error: 'This message is not appropriate for this object'! !

!Object methodsFor: 'error handling'!
subclassResponsibility
	"This message sets up a framework for the behavior of the class' 
	subclasses. Announce that the subclass should have implemented this 
	message."

	self error: 'My subclass should have overridden one of my messages.'! !

!Object methodsFor: 'error handling'!
tryToDefineVariableAccess: aMessage
	"See if the message just wants to get at an instance variable of this class.  Ask the user if its OK.  If so, define the message to read or write that instance or class variable and retry."
	| ask newMessage sel |
	aMessage arguments size > 1 ifTrue: [^ false].
	sel _ aMessage selector asString.	"works for 0 args"
	aMessage arguments size = 1 ifTrue: [
		sel last = $: ifFalse: [^ false].
		sel _ sel copyWithout: $:].
	(self class instVarNames includes: sel) ifFalse: [
		(self class classVarNames includes: sel asSymbol) ifFalse: [
			^ false]].
	ask _ self confirm: 'A ', thisContext sender sender receiver 
		class printString, ' wants to ', 
		(aMessage arguments size = 1 ifTrue: ['write into'] ifFalse: ['read from']), '
', sel ,' in class ', self class printString, '.
Define a this access message?'.
	ask ifTrue: [
		aMessage arguments size = 1 
			ifTrue: [newMessage _ aMessage selector, ' anObject
	', sel, ' _ anObject']
			ifFalse: [newMessage _ aMessage selector, '
	^', aMessage selector].
		self class compile: newMessage classified: 'accessing' notifying: nil].
	^ ask! !


!Object methodsFor: 'user interface' stamp: 'sw 10/4/1999 08:13'!
addModelItemsToWindowMenu: aMenu
	"aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window.  Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! !

!Object methodsFor: 'user interface' stamp: 'sw 10/5/1998 14:39'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 
	"The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items"
! !

!Object methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:43'!
asExplorerString
	^ self printString! !

!Object methodsFor: 'user interface'!
basicInspect
	"Create and schedule an Inspector in which the user can examine the 
	receiver's variables. This method should not be overriden."

	Inspector openOn: self withEvalPane: false! !

!Object methodsFor: 'user interface'!
beep
	"Make a beep sound.  Every object would like to be able to speak.  6/10/96 sw"

	Smalltalk beep! !

!Object methodsFor: 'user interface' stamp: 'sw 5/8/2000 01:59'!
browseHierarchy

	^ HierarchyBrowser newFor: self class

"(2@7) browseHierarchy"! !

!Object methodsFor: 'user interface' stamp: 'sw 7/13/1999 15:53'!
defaultBackgroundColor
	"Answer the color to be used as the base window color for a window whose model is an object of the receiver's class"
	
	^ Preferences windowColorFor: self class name! !

!Object methodsFor: 'user interface'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."

	^ self class name! !

!Object methodsFor: 'user interface' stamp: 'RAA 7/10/2000 08:11'!
eToyStreamedRepresentationNotifying: aWidget

	| outData |
	[ outData _ SmartRefStream streamedRepresentationOf: self ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				aWidget ifNotNil: [aWidget flashIndicator: #working].
			].
		].
	^outData
! !

!Object methodsFor: 'user interface' stamp: 'RAA 6/21/1999 15:32'!
explore

	^ObjectExplorer new openExplorerFor: self! !

!Object methodsFor: 'user interface' stamp: 'sw 8/15/97 17:25'!
fullScreenSize
	"Answer the size to which a window displaying the receiver should be set"
	| adj |
	adj _ (3 * Preferences scrollBarWidth) @ 0.
	^ Rectangle origin: adj extent: (DisplayScreen actualScreenSize - adj)! !

!Object methodsFor: 'user interface' stamp: 'RAA 6/21/1999 11:27'!
hasContentsInExplorer

	^self basicSize > 0 or: [self class allInstVarNames isEmpty not]
! !

!Object methodsFor: 'user interface' stamp: 'sma 5/28/2000 15:59'!
inform: aString
	"Display a message for the user to read and then dismiss. 6/9/96 sw"

	aString isEmptyOrNil ifFalse: [PopUpMenu inform: aString]! !

!Object methodsFor: 'user interface'!
initialExtent
	"Answer the desired extent for the receiver when a view on it is first opened on the screen. 
	5/22/96 sw: in the absence of any override, obtain from RealEstateAgent"

	^ RealEstateAgent standardWindowExtent! !

!Object methodsFor: 'user interface' stamp: 'di 5/19/1998 20:43'!
inspect
	"Create and schedule an Inspector in which the user can examine the receiver's variables."

	Inspector openOn: self withEvalPane: true! !

!Object methodsFor: 'user interface'!
inspectWithLabel: aLabel
	Inspector openOn: self withEvalPane: true withLabel: aLabel! !

!Object methodsFor: 'user interface' stamp: 'sw 10/16/2000 11:11'!
launchTileToRefer
	"Create a tile to reference the receiver, and attach it to the hand"

	self currentHand attachMorph: self tileToRefer! !

!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:26'!
modelSleep
	"A window with me as model is being exited or collapsed or closed.
	Default response is no-op" ! !

!Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:01'!
modelWakeUp
	"A window with me as model is being entered or expanded.  Default response is no-op" ! !

!Object methodsFor: 'user interface' stamp: 'sw 10/16/1999 22:45'!
modelWakeUpIn: aWindow
	"A window with me as model is being entered or expanded.  Default response is no-op" 
	self modelWakeUp! !

!Object methodsFor: 'user interface' stamp: 'sw 3/8/1999 15:27'!
mouseUpBalk: evt
	"A button I own got a mouseDown, but the user moved out before letting up.  Certain kinds of objects (so-called 'radio buttons', for example, and other structures that must always have some selection, e.g. PaintBoxMorph) wish to take special action in this case; this default does nothing."
! !

!Object methodsFor: 'user interface' stamp: 'sw 8/22/97 13:14'!
newTileMorphRepresentative
	^ TileMorph new setLiteral: self! !

!Object methodsFor: 'user interface'!
notYetImplemented
	self inform: 'Not yet implemented'! !

!Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'!
windowActiveOnFirstClick
	"Return true if my window should be active on first click."

	^ false! !

!Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'!
windowReqNewLabel: labelString
	"My window's title has been edited.
	Return true if this is OK, and override for further behavior."

	^ true! !


!Object methodsFor: 'system primitives'!
asOop
	"Primitive. Answer a SmallInteger whose value is half of the receiver's 
	object pointer (interpreting object pointers as 16-bit signed quantities). 
	Fail if the receiver is a SmallInteger. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 75>
	self primitiveFailed! !

!Object methodsFor: 'system primitives' stamp: 'di 1/9/1999 15:19'!
becomeForward: otherObject 
	"Primitive. All variables in the entire system that used to point
	to the receiver now point to the argument.
	Fails if either argument is a SmallInteger."

	(Array with: self)
		elementsForwardIdentityTo:
			(Array with: otherObject)! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 10:59'!
className
	"Answer a string characterizing the receiver's class, for use in list views for example"

	^ self class name asString! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:04'!
creationStamp
	"Answer a string which reports the creation particulars of the receiver.  Intended perhaps for list views, but this is presently a feature not easily accessible"

	^ '<no creation stamp>'! !

!Object methodsFor: 'system primitives'!
instVarAt: index 
	"Primitive. Answer a fixed variable in an object. The numbering of the 
	variables corresponds to the named instance variables. Fail if the index 
	is not an Integer or is not the index of a fixed variable. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 73>
	"Access beyond fixed variables."
	^self basicAt: index - self class instSize		! !

!Object methodsFor: 'system primitives'!
instVarAt: anInteger put: anObject 
	"Primitive. Store a value into a fixed variable in the receiver. The 
	numbering of the variables corresponds to the named instance variables. 
	Fail if the index is not an Integer or is not the index of a fixed variable. 
	Answer the value stored as the result. Using this message violates the 
	principle that each object has sovereign control over the storing of 
	values into its instance variables. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 74>
	"Access beyond fixed fields"
	^self basicAt: anInteger - self class instSize put: anObject! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:09'!
instVarNamed: aString
	"Return the value of the instance variable in me with that name.  Slow and unclean, but very useful. "

	^ self instVarAt: (self class allInstVarNames indexOf: aString asString)


! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/16/2000 11:10'!
instVarNamed: aString put: aValue
	"Store into the value of the instance variable in me of that name.  Slow and unclean, but very useful. "

	^ self instVarAt: (self class allInstVarNames indexOf: aString asString) put: aValue
! !

!Object methodsFor: 'system primitives' stamp: 'sw 10/17/2000 11:12'!
oopString
	"Answer a string that represents the oop of the receiver"

	^ self asOop printString! !

!Object methodsFor: 'system primitives' stamp: 'di 3/27/1999 12:21'!
rootStubInImageSegment: imageSegment

	^ ImageSegmentRootStub new
		xxSuperclass: nil
		format: nil
		segment: imageSegment! !

!Object methodsFor: 'system primitives'!
someObject
	"Primitive. Answer the first object in the enumeration of all
	 objects."

	<primitive: 138>
	self primitiveFailed.! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'!
tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."
	<primitive:'' module:''>
	^ ContextPart primitiveFailToken! !

!Object methodsFor: 'system primitives' stamp: 'di 2/10/1999 22:16'!
tryPrimitive: primIndex withArgs: argumentArray
	"This method is a template that the Smalltalk simulator uses to 
	execute primitives. See Object documentation whatIsAPrimitive."

	<primitive: 118>
	^ ContextPart primitiveFailToken! !


!Object methodsFor: 'private'!
errorImproperStore
	"Create an error notification that an improper store was attempted."

	self error: 'Improper store into indexable object'! !

!Object methodsFor: 'private'!
errorNonIntegerIndex
	"Create an error notification that an improper object was used as an index."

	self error: 'only integers should be used as indices'! !

!Object methodsFor: 'private' stamp: 'di 3/29/1999 12:39'!
errorNotIndexable
	"Create an error notification that the receiver is not indexable."

	self error: (self class name) , 's are not indexable'! !

!Object methodsFor: 'private'!
errorSubscriptBounds: index 
	"Create an error notification that an improper integer was used as an index."

	self error: 'subscript is out of bounds: ' , index printString! !

!Object methodsFor: 'private'!
mustBeBoolean
	"Catches attempts to test truth of non-Booleans.  This message is sent from the
	interpreter."

	self error: 'NonBoolean receiver--proceed for truth.'.
	^true! !

!Object methodsFor: 'private' stamp: 'di 11/3/2000 18:42'!
primitiveError: aString 
	"This method is called when the error handling results in a recursion in 
	calling on error: or halt or halt:."

	| context |
	Sensor eventQueue: nil. "Or else we won't get keyboard and possibly run out of memory"
	(String
		streamContents: 
			[:s |
			s nextPutAll: '***System error handling failed***'.
			s cr; nextPutAll: aString.
			context _ thisContext sender sender.
			20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]].
			s cr; nextPutAll: '-------------------------------'.
			s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
			s cr; nextPutAll: 'Type any other character to restart.'])
		displayAt: 0 @ 0.
	[Sensor keyboardPressed] whileFalse.
	Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator].
	Smalltalk isMorphic
		ifTrue: [Display reinstallMorphicWorldAfterError]
		ifFalse: [ScheduledControllers searchForActiveController]! !

!Object methodsFor: 'private'!
species
	"Answer the preferred class for reconstructing the receiver.  For example, 
	collections create new collections whenever enumeration messages such as 
	collect: or select: are invoked.  The new kind of collection is determined by 
	the species of the original collection.  Species and class are not always the 
	same.  For example, the species of Interval is Array."

	^self class! !

!Object methodsFor: 'private'!
storeAt: offset inTempFrame: aContext
	"This message had to get sent to an expression already on the stack
	as a Block argument being accessed by the debugger.
	Just re-route it to the temp frame."
	^ aContext tempAt: offset put: self! !


!Object methodsFor: 'associating'!
-> anObject
	"Answer an Association between self and anObject"

	^Association new key: self value: anObject! !


!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'!
adaptToFloat: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Float,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:14'!
adaptToFraction: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Fraction,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'!
adaptToInteger: rcvr andSend: selector
	"If no method has been provided for adapting an object to a Integer,
	then it may be adequate to simply adapt it to a number."
	^ self adaptToNumber: rcvr andSend: selector! !

!Object methodsFor: 'converting'!
as: aSimilarClass
	"Create an object of class aSimilarClass that has similar contents to the receiver."

	^ aSimilarClass newFrom: self! !

!Object methodsFor: 'converting' stamp: 'svp 5/16/2000 18:14'!
asDraggableMorph
	^(StringMorph contents: self printString)
		color: Color white;
		yourself! !

!Object methodsFor: 'converting' stamp: 'sma 5/12/2000 17:39'!
asOrderedCollection
	"Answer an OrderedCollection with the receiver as its only element."

	^ OrderedCollection with: self! !

!Object methodsFor: 'converting'!
asString
	"Answer a string that represents the receiver."

	^ self printString ! !

!Object methodsFor: 'converting' stamp: 'RAA 8/2/1999 12:41'!
complexContents

	^self! !

!Object methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'!
withoutListWrapper

	^self! !


!Object methodsFor: 'casing'!
caseOf: aBlockAssociationCollection
	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, report an error."

	^ self caseOf: aBlockAssociationCollection otherwise: [self caseError]

"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}"! !

!Object methodsFor: 'casing'!
caseOf: aBlockAssociationCollection otherwise: aBlock
	"The elements of aBlockAssociationCollection are associations between blocks.
	 Answer the evaluated value of the first association in aBlockAssociationCollection
	 whose evaluated key equals the receiver.  If no match is found, answer the result
	 of evaluating aBlock."

	aBlockAssociationCollection associationsDo:
		[:assoc | (assoc key value = self) ifTrue: [^assoc value value]].
	^ aBlock value

"| z | z _ {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"| z | z _ {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]}. #b caseOf: z otherwise: [0]"
"The following are compiled in-line:"
"#b caseOf: {[#a]->[1+1]. ['b' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"
"#b caseOf: {[#a]->[1+1]. ['d' asSymbol]->[2+2]. [#c]->[3+3]} otherwise: [0]"! !


!Object methodsFor: 'binding'!
bindingOf: aString
	^nil! !


!Object methodsFor: 'macpal' stamp: 'sw 12/14/2000 10:46'!
beep: soundName
	"Make the given sound, unless the making of sound is disabled in Preferences"

	Preferences soundsEnabled
		ifTrue: [self playSoundNamed: soundName]
! !

!Object methodsFor: 'macpal' stamp: 'sw 5/7/1998 23:00'!
codeStrippedOut: messageString
	"When a method is stripped out for external release, it is replaced by a method that calls this"

	self halt: 'Code stripped out -- ', messageString, '-- do not proceed.'! !

!Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 17:31'!
contentsChanged
	self changed: #contents! !

!Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 12:02'!
currentEvent
	"Answer the current Morphic event.  This method never returns nil."
	^ self currentHand lastEvent! !

!Object methodsFor: 'macpal' stamp: 'di 6/7/1999 15:42'!
currentHand
	"Return a usable HandMorph -- the one associated with the object's current environment.  This method will always return a hand, even if it has to conjure one up as a last resort.  If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned."

	^ self currentWorld primaryHand! !

!Object methodsFor: 'macpal' stamp: 'RAA 5/26/2000 10:04'!
currentWorld
	"Answer a morphic world that is the current UI focus.
		If in a morphic project, it's that project's world.  
		If in an mvc project, it is the topmost morphic-mvc-window's worldMorph. 
		If in an mvc project that has no morphic-mvc-windows, then it's just some existing worldmorph instance.
		If in an mvc project in a Squeak that has NO WorldMorph instances, one is created.

	This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one."

	| aView aSubview |
	
	^Display getCurrentMorphicWorld ifNil: [
		aView _ ScheduledControllers controllerSatisfying:
			[:ctrl | (aSubview _ ctrl view firstSubView) notNil and:
				[aSubview model isMorph and: [aSubview model isWorldMorph]]].
		aView
			ifNotNil:
				[aSubview model]
			ifNil:
				[MVCWiWPasteUpMorph newWorldForProject: nil]
	].! !

!Object methodsFor: 'macpal' stamp: 'jm 5/6/1998 22:35'!
flash
	"Do nothing."
! !

!Object methodsFor: 'macpal' stamp: 'sw 10/13/97 16:38'!
ifKindOf: aClass thenDo: aBlock
	^ (self isKindOf: aClass) ifTrue: [aBlock value: self]! !

!Object methodsFor: 'macpal' stamp: 'sw 6/16/1998 15:07'!
instanceVariableValues
	"Answer a collection whose elements are the values of those instance variables of the receiver which were added by the receiver's class"
	| c |
	c _ OrderedCollection new.
	self class superclass instSize + 1 to: self class instSize do:
		[:i | c add: (self instVarAt: i)].
	^ c! !

!Object methodsFor: 'macpal' stamp: 'sw 10/24/2000 07:04'!
objectRepresented
	"most objects represent themselves; this provides a hook for aliases to grab on to"

	^ self! !

!Object methodsFor: 'macpal' stamp: 'jm 5/16/1998 10:32'!
playSoundNamed: soundName
	"Play the sound with the given name. Do nothing if this image lacks sound playing facilities."

	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		sampledSound playSoundNamed: soundName asString].
! !

!Object methodsFor: 'macpal' stamp: 'jm 2/24/1999 12:40'!
scriptPerformer

	^ self
! !


!Object methodsFor: 'flagging' stamp: 'sw 8/4/97 16:49'!
isThisEverCalled
	^ self isThisEverCalled: thisContext sender printString! !

!Object methodsFor: 'flagging'!
isThisEverCalled: msg
	"Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached.  2/5/96 sw"

	self halt: 'This is indeed called: ', msg printString! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'!
logEntry

	Transcript show: 'Entered ', thisContext sender printString; cr.
! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'!
logExecution

	Transcript show: 'Executing ', thisContext sender printString; cr.
! !

!Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:22'!
logExit

	Transcript show:  'Exited ', thisContext sender printString; cr.
! !


!Object methodsFor: 'translation support' stamp: 'acg 9/19/1999 20:39'!
asIf: aClass var: aString

	|index|
	index _ aClass allInstVarNames 
		indexOf: aString
		ifAbsent: [self error: 'must use instVar name'].
	^self instVarAt: index
! !

!Object methodsFor: 'translation support' stamp: 'acg 10/5/1999 06:35'!
asIf: aClass var: aString asValue: someClass

	^(self asIf: aClass var: aString) asValue: someClass
! !

!Object methodsFor: 'translation support' stamp: 'acg 9/19/1999 20:40'!
asIf: aClass var: aString put: aValue

	|index|
	index _ aClass allInstVarNames 
		indexOf: aString
		ifAbsent: [self error: 'must use instVar name'].
	^self instVarAt: index put: aValue
! !

!Object methodsFor: 'translation support' stamp: 'acg 9/20/1999 11:30'!
asOop: aClass

	(self class isVariable and: [self class instSize > 0])
		ifTrue: [self error: 'cannot auto-coerce indexable objects with named instance variables'].
	(aClass ccgCanConvertFrom: self)
		ifFalse: [self error: 'incompatible object for this coercion'].
	^self! !

!Object methodsFor: 'translation support' stamp: 'acg 9/19/1999 20:21'!
asSmallIntegerObj

	^self! !

!Object methodsFor: 'translation support' stamp: 'acg 10/5/1999 06:21'!
asValue: aClass

	^self! !

!Object methodsFor: 'translation support'!
cCode: codeString
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'jm 2/15/1999 13:11'!
cCode: codeString inSmalltalk: aBlock
	"Support for Smalltalk-to-C translation. The given string is output literally when generating C code. If this code is being simulated in Smalltalk, answer the result of evaluating the given block."

	^ aBlock value
! !

!Object methodsFor: 'translation support'!
cCoerce: value to: cType
	"Type coercion for translation only; just return the value when running in Smalltalk."

	^ value! !

!Object methodsFor: 'translation support' stamp: 'ar 9/18/1998 23:27'!
export: aBoolean
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support'!
inline: inlineFlag
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'acg 9/19/1999 11:51'!
primitive: primID parameters: parmSpecs receiver: rcvrSpec

	| tMethod |
	tMethod _ TestTMethod new 
		fromContext: thisContext sender 
		primitive: primID 
		parameters: parmSpecs 
		receiver: rcvrSpec.
	^tMethod simulatePrologInContext: thisContext sender! !

!Object methodsFor: 'translation support' stamp: 'acg 1/1/2000 12:45'!
remapOop: oopOrList in: aBlock
	"For translation only; noop when running in Smalltalk."
	^aBlock value! !

!Object methodsFor: 'translation support'!
returnTypeC: typeString
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support'!
sharedCodeNamed: label inCase: caseNumber
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'acg 1/1/2000 12:46'!
stAt: index

	^self at: index! !

!Object methodsFor: 'translation support' stamp: 'acg 1/1/2000 12:46'!
stAt: index put: value

	^self at: index put: value! !

!Object methodsFor: 'translation support' stamp: 'acg 1/1/2000 22:42'!
stSize

	^self size! !

!Object methodsFor: 'translation support' stamp: 'ar 2/21/2000 00:42'!
static: aBoolean
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'acg 12/18/1999 11:31'!
suppressFailureGuards: failureGuardFlag
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support'!
var: varSymbol declareC: declString
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'sma 3/3/2000 12:06'!
var: varSymbol type: typeString
	"For translation only; noop when running in Smalltalk."! !

!Object methodsFor: 'translation support' stamp: 'sma 3/3/2000 12:06'!
var: varSymbol type: typeString array: array
	"For translation only; noop when running in Smalltalk."! !


!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:46'!
comeFullyUpOnReload: smartRefStream
	"Normally this read-in object is exactly what we want to store. 7/26/96 tk"

	^ self! !

!Object methodsFor: 'objects from disk' stamp: 'RAA 12/20/2000 16:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm

	"subclasses should implement if they wish to convert old instances to modern ones"! !

!Object methodsFor: 'objects from disk' stamp: 'RAA 1/10/2001 14:02'!
indexIfCompact

	^0		"helps avoid a #respondsTo: in publishing"! !

!Object methodsFor: 'objects from disk' stamp: 'tk 2/24/1999 11:08'!
objectForDataStream: refStrm
    "Return an object to store on an external data stream."

    ^ self! !

!Object methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 12:05'!
readDataFrom: aDataStream size: varsOnDisk
	"Fill in the fields of self based on the contents of aDataStream.  Return self.
	 Read in the instance-variables written by Object>>storeDataOn:.
	 NOTE: This method must send beginReference: before reading any objects from aDataStream that might reference it.
	 Allow aDataStream to have fewer inst vars.  See SmartRefStream."
	| cntInstVars cntIndexedVars |

	cntInstVars _ self class instSize.
	self class isVariable
		ifTrue: [cntIndexedVars _ varsOnDisk - cntInstVars.
				cntIndexedVars < 0 ifTrue: [
					self error: 'Class has changed too much.  Define a convertxxx method']]
		ifFalse: [cntIndexedVars _ 0.
				cntInstVars _ varsOnDisk]. 	"OK if fewer than now"

	aDataStream beginReference: self.
	1 to: cntInstVars do:
		[:i | self instVarAt: i put: aDataStream next].
	1 to: cntIndexedVars do:
		[:i | self basicAt: i put: aDataStream next].
	"Total number read MUST be equal to varsOnDisk!!"
	^ self	"If we ever return something other than self, fix calls 
			on (super readDataFrom: aDataStream size: anInteger)"! !

!Object methodsFor: 'objects from disk' stamp: 'tk 6/26/97 13:48'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  Does not file out the class of the object.  tk 6/26/97 13:48"

	| aFileName fileStream |
	aFileName _ self class name asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ self beep].

	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self.! !

!Object methodsFor: 'objects from disk' stamp: 'tk 11/7/2000 13:29'!
storeDataOn: aDataStream
	"Store myself on a DataStream. Answer self.  This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream.
	 NOTE: This method must send 'aDataStream beginInstance:size:'
		and then put a number of objects (via aDataStream nextPut:/nextPutWeak:).
	 Cf. readDataFrom:size:, which must read back what this puts
	when given the size that it gave to beginInstance:size:. -- 11/15/92 jhm"
	| cntInstVars cntIndexedVars |

	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self instVarAt: i)].

	(aDataStream byteStream class == DummyStream) ifFalse: [
		1 to: cntIndexedVars do:
			[:i | aDataStream nextPut: (self basicAt: i)]].
		"save a little time if dummy stream"! !


!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:26'!
actAsExecutor
	"Prepare the receiver to act as executor for any resources associated with it"
	self breakDependents! !

!Object methodsFor: 'finalization' stamp: 'ar 3/20/98 22:19'!
executor
	"Return an object which can act as executor for finalization of the receiver"
	^self shallowCopy actAsExecutor! !

!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:27'!
finalize
	"Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."! !

!Object methodsFor: 'finalization' stamp: 'ar 3/21/98 18:38'!
retryWithGC: execBlock until: testBlock
	"Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try."
	| blockValue |
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	Smalltalk garbageCollectMost.
	blockValue := execBlock value.
	(testBlock value: blockValue) ifTrue:[^blockValue].
	Smalltalk garbageCollect.
	^execBlock value.! !


!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:42'!
byteEncode:aStream
	self flattenOnStream:aStream.
! !

!Object methodsFor: 'filter streaming'!
drawOnCanvas:aStream
	self flattenOnStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:31'!
elementSeparator
	^nil.! !

!Object methodsFor: 'filter streaming'!
encodePostscriptOn:aStream
	self byteEncode:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:07'!
flattenOnStream:aStream
	self writeOnFilterStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'mpw 6/22/1930 22:56'!
fullDrawPostscriptOn:aStream
	^aStream fullDraw:self.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:51'!
printOnStream:aStream
	self byteEncode:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:49'!
putOn:aStream
	^aStream nextPut:self.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:53'!
storeOnStream:aStream
	self printOnStream:aStream.
! !

!Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:06'!
writeOnFilterStream:aStream
	aStream writeObject:self.
! !


!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:12'!
myEvents
	"Private. Answer a Dictionary with the receiver's events or nil if no
	events have been registered. Subclasses may overwrite this method
	for performance reasons."

	^ EventsFields at: self ifAbsent: []! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:13'!
myEvents: aDictionaryOrNil
	"Private. Set (or remove) the receiver's dictionary of events.
	Subclasses may overwrite this method for performance reasons."

	aDictionaryOrNil
		ifNil: [EventsFields removeKey: self ifAbsent: []]
		ifNotNil: [EventsFields at: self put: aDictionaryOrNil]! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:22'!
noEventsDo: aBlock
	"Evaluate aBlock while ensuring that the receiver will not trigger
	any events. Answer the result of evaluating aBlock."

	| events |
	events _ self myEvents.
	^ [self myEvents: nil. aBlock value] ensure: [self myEvents: events]! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:26'!
removeAllEventsTriggered
	"Remove all events triggered by the receiver."

	self myEvents: nil! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:14'!
removeEventsTriggeredFor: anObject
	"Remove all that events trigged by the receiver which would have
	been send to anObject."

	| events |
	events _ self myEvents ifNil: [^ self].
	events copy keysAndValuesDo:
		[:evtSym :msgSendSet |
		| newSet |
		newSet _ msgSendSet reject: [:each | each receiver == anObject].
		msgSendSet size = newSet size ifFalse:
			[newSet isEmpty
				ifTrue: [events removeKey: evtSym]
				ifFalse: [events at: evtSym put: newSet]]].
	self myEvents: (events isEmpty ifFalse: [events])! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:17'!
trigger: anEventSymbol
	"Evaluate all message sends registered for anEventSymbol."

	((self myEvents ifNil: [^ self])
		at: anEventSymbol ifAbsent: [^ self])
			do: [:each | each value]! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:18'!
trigger: anEventSymbol with: aParameter
	"Evaluate all message sends registered for anEventSymbol
	and pass aParamter to the registered actions."

	self trigger: anEventSymbol withArguments: (Array with: aParameter)! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:18'!
trigger: anEventSymbol withArguments: anArray
	"Evaluate all message sends registered for anEventSymbol
	and pass anArray to the registered actions."

	((self myEvents ifNil: [^ self])
		at: anEventSymbol ifAbsent: [^ self])
			do: [:each | each valueWithArguments: anArray]! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 21:16'!
when: anEventSymbol perform: aMessageSend
	"Register aMessageSend as action for anEventSymbol."

	| events |
	(events _ self myEvents) ifNil:
		[self myEvents: (events _ IdentityDictionary new)].
	(events
		at: anEventSymbol 
		ifAbsentPut: [Set new]) add: aMessageSend! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:47'!
when: anEventSymbol send: aSelector to: anObject
	self
		when: anEventSymbol
		perform: (MessageSend receiver: anObject selector: aSelector)! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:49'!
when: anEventSymbol send: aSelector to: anObject with: anArgument
	self
		when: anEventSymbol
		perform: (MessageSend receiver: anObject selector: aSelector argument: anArgument)! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:48'!
when: anEventSymbol send: aSelector to: anObject withArguments: anArray
	self
		when: anEventSymbol
		perform: (MessageSend receiver: anObject selector: aSelector arguments: anArray)! !

!Object methodsFor: 'events' stamp: 'sma 2/29/2000 20:32'!
when: anEventSymbol sendTo: anObject
	self when: anEventSymbol send: anEventSymbol to: anObject! !


!Object methodsFor: 'scripting' stamp: 'sw 3/10/2000 13:57'!
defaultFloatPrecisionFor: aGetSelector
	"Answer a number indicating the default float precision to be used in a numeric readout for which the receiver is the model."

	^ 1! !


!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:03'!
acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph 
	self subclassResponsibility! !

!Object methodsFor: 'drag and drop' stamp: 'mir 5/16/2000 11:35'!
dragAnimationFor: item transferMorph: transferMorph 
	"Default do nothing"! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:20'!
dragPassengerFor: item inMorph: dragSource 
	^item! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'!
dragTransferType
	^nil! !

!Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:05'!
dragTransferTypeForMorph: dragSource 
	^nil! !

!Object methodsFor: 'drag and drop' stamp: 'mir 5/8/2000 17:19'!
wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM 
	^false! !


!Object methodsFor: 'world hacking' stamp: 'RAA 6/14/2000 18:12'!
couldOpenInMorphic

        "is there an obvious morphic world in which to open a new morph?"

        ^World notNil or: [RequestCurrentWorldNotification signal notNil]! !


!Object methodsFor: 'logging' stamp: 'mir 8/10/1999 16:05'!
flag: aFlagString log: aString
	Transcript show: aString; cr
	! !

!Object methodsFor: 'logging' stamp: 'mir 8/10/1999 16:05'!
flag: aFlagString streamLog: aBlockWithStreamArgument
	! !

!Object methodsFor: 'logging' stamp: 'mir 8/10/1999 18:05'!
log: aString
	Transcript show: aString; cr
	! !


!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'!
capturedState
	"May be overridden in subclasses."

	^ self shallowCopy
! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:29'!
commandHistory
	"Return the command history for the receiver"
	| w |
	(w _ self currentWorld) ifNotNil: [^ w commandHistory].
	^ CommandHistory new. "won't really record anything but prevent breaking things"! !

!Object methodsFor: 'undo' stamp: 'di 12/12/2000 15:01'!
purgeAllCommands
	"Purge all commands for this object"
	Preferences useUndo ifFalse: [^ self]. "get out quickly"
	self commandHistory purgeAllCommandsSuchThat: [:cmd | cmd undoTarget == self].
! !

!Object methodsFor: 'undo' stamp: 'di 9/12/2000 08:15'!
redoFromCapturedState: st 
	"May be overridden in subclasses.  See also capturedState"

	self undoFromCapturedState: st  "Simple cases are symmetric"
! !

!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'!
refineRedoTarget: target selector: aSymbol arguments: arguments in: refineBlock 
	"Any object can override this method to refine its redo specification"

	^ refineBlock
		value: target
		value: aSymbol
		value: arguments! !

!Object methodsFor: 'undo' stamp: 'sw 11/16/2000 14:42'!
refineUndoTarget: target selector: aSymbol arguments: arguments in: refineBlock 
	"Any object can override this method to refine its undo specification"

	^ refineBlock
		value: target
		value: aSymbol
		value: arguments! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'!
rememberCommand: aCommand
	"Remember the given command for undo"
	Preferences useUndo ifFalse: [^ self]. "get out quickly"
	^ self commandHistory rememberCommand: aCommand! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:30'!
rememberUndoableAction: actionBlock named: caption
	| cmd result |
	cmd _ Command new cmdWording: caption.
	cmd undoTarget: self selector: #undoFromCapturedState: argument: self capturedState.
	result _ actionBlock value.
	cmd redoTarget: self selector: #redoFromCapturedState: argument: self capturedState.
	self rememberCommand: cmd.
	^ result! !

!Object methodsFor: 'undo' stamp: 'di 9/11/2000 20:32'!
undoFromCapturedState: st 
	"May be overridden in subclasses.  See also capturedState"

	self copyFrom: st
! !


!Object methodsFor: 'viewer' stamp: 'sw 10/16/2000 10:35'!
assureUniClass
	"If the receiver is not yet an instance of a uniclass, create a uniclass for it and make the receiver become an instance of that class."

	| anInstance |
	self belongsToUniClass ifTrue: [^ self].
	anInstance _ self class instanceOfUniqueClass.
	self become: (self as: anInstance class).
	^ anInstance! !

!Object methodsFor: 'viewer' stamp: 'sw 10/16/2000 10:41'!
belongsToUniClass
	"Answer whether the receiver belongs to a uniclass.  For the moment (this is not entirely satisfactory) this is precisely equated with the classname ending in a digit"

	^ self class name endsWithDigit! !

!Object methodsFor: 'viewer' stamp: 'sw 10/27/2000 10:47'!
categoriesForViewer: aViewer
	"Answer a list of symbols representing the categories of methods/inst vars for the receiver, for the given viewer.  The deeper functionality here has yet to be ported forward from earlier demos."

	| filter ivs |
	true ifTrue: [^ self class organization categories].

	filter _ aViewer filteringScheme.

	(filter == #minimal) ifTrue: [^ self class  minimalViewerCategoriesIn: aViewer].
	(filter == #myOwn) ifTrue: [^ self class rootViewerCategoriesIn: aViewer].
	(filter == #eToy) ifTrue: [^ self class etoyViewerCategoriesIn: aViewer].
	(filter == #custom) ifTrue: [^ self class customViewerCategoriesIn: aViewer].
	(filter == #most) ifTrue: [^ self class mostViewerCategoriesIn: aViewer].
	(filter == #standard) ifTrue: [^ self class standardViewerCategoriesIn: aViewer].
	(filter == #all) ifTrue: [^ self class allViewerCategoriesIn: aViewer].
	(filter == (ivs _ #instanceVariables)) ifTrue: [^ Array with: ivs].! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 07:19'!
categoryElementsFor: aCategorySymbol
	"Just a start.  Answer a list of tuples that characterize the elements in the given category.  Every class in the receiver's superclass chain which implements #additionsToViewerCategories is given the chance to add elements to the category.  In this first version, only methods with 0 or 1 arguments are included, because of the limitations of PhraseTileMorphs.  Later, the entire method vocabulary of a category will be incorporated, and we will use type hints for the arguments, and we will support a way that methods with return-value types can have type-appropriate readouts for their values, etc."

	| aList org |
	org _  self class organization.
	aList _ (org listAtCategoryNamed: aCategorySymbol) select:
		[:anElement | anElement numArgs < 2].
	^ aList collect:
		[:sel | 
			sel numArgs == 0
				ifTrue:
					[Array with: #command with: sel with: 'help here later']
				ifFalse:
					[Array with: #command with: sel with: 'help here later' with: #string]]! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 07:20'!
chooseNewNameForReference
	"Offer an opportunity for the receiver, presumed already to be known in the References registry, to be renamed"

	|  nameSym current newName |
	current _ References keyAtValue: self ifAbsent: [^ self error: 'not found in References'].

	newName _ FillInTheBlank request: 'Please enter new name' initialAnswer: current.
	"Want to user some better way of determining the validity of the chosen identifier, and also want to give more precise diagnostic if the string the user types in is not acceptable.  Work to be done here."

	newName isEmpty ifTrue: [^ nil].
	((Scanner isLiteralSymbol: newName) and: [(newName includes: $:) not])
		ifTrue:
			[nameSym _ newName capitalized asSymbol.
			(((References includesKey:  nameSym) not and:
				[(Smalltalk includesKey: nameSym) not]) and:
						[(ScriptingSystem allKnownClassVariableNames includes: nameSym) not])
					ifTrue:
						[(References associationAt: current) key: nameSym.
						References rehash.
						^ nameSym]].
	self inform: 'Sorry, that name is not available.'.
	^ nil! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 17:27'!
commandPhraseFor: commandSpec inViewer: aViewer
	"Translate commandSpec into a PhraseTileMorph.  Put balloon help into the phrase.  This work derives from the original e-toy work, where its code was specific to the Player/Morph architecture; it is now elevated to class Object, but really only reliably works when the viewee is indeed  a Player."

	| aRow resultType cmd argType argTile selfTile aPhrase balloonTextSelector stat inst |

	resultType _ (commandSpec at: 1).
	cmd _ (commandSpec at: 2).
	commandSpec size = 3
		ifTrue:
			[aPhrase _ PhraseTileMorph new setOperator: cmd
				type: resultType
				rcvrType: #player]
		ifFalse: "commandSpec size is four"
			[argType _ commandSpec at: 4.
			aPhrase _ PhraseTileMorph new setOperator: cmd
				type: resultType
				rcvrType: #player
				argType: argType.
			argTile _ self tileForArgType: argType inViewer: aViewer.
			argTile position: aPhrase lastSubmorph position.
			aPhrase lastSubmorph addMorph: argTile].

	(self belongsToUniClass and:
			[self class includesSelector: cmd])
		ifTrue: [balloonTextSelector _ #userScript].

	aPhrase operatorTile balloonTextSelector: (balloonTextSelector ifNil: [cmd]).
	aPhrase markAsPartsDonor.

	selfTile _ aViewer tileForSelf.
	selfTile position: aPhrase firstSubmorph position.
	aPhrase firstSubmorph addMorph: selfTile.

	aRow _ ViewerRow newRow borderWidth: 0; color: aViewer color.
	aRow elementSymbol: cmd asSymbol.

	aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase).
	aRow addMorphBack: (Morph new extent: 4@2; beTransparent).
	aRow addMorphBack: (aViewer infoButtonFor: cmd).
	aRow addMorphBack: aPhrase.
	false "(names includes: cmd)" ifTrue:
		[aPhrase userScriptSelector: cmd.
		aPhrase beTransparent.
		aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
		aRow addMorphBack: (stat _ (inst _ self scriptInstantiationForSelector: cmd) statusControlMorph).
		inst updateStatusMorph: stat.].

	aRow beSticky; disableDragNDrop.

	^ aRow! !

!Object methodsFor: 'viewer' stamp: 'sw 2/14/2000 14:24'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver.  The default is to let the class specify, but certain instances will want to override.  (PasteUpMorphs serving as Worlds come to mind"

	^ self class defaultNameStemForInstances! !

!Object methodsFor: 'viewer' stamp: 'sw 10/27/2000 17:51'!
elementTypeFor: aStringOrSymbol
	"Answer a symbol characterizing what kind of element aStringOrSymbol represents.  Realistically, at present, this always just returns #systemScript; a prototyped but not-incorporated architecture supported use of a leading colon to characterize an inst var of a system class, and for the moment we still see its remnant here."

	^ (aStringOrSymbol first == $:) ifTrue: [#systemSlot] ifFalse: [#systemScript]! !

!Object methodsFor: 'viewer' stamp: 'sw 10/27/2000 17:51'!
infoFor: anElement inViewer: aViewer
	"The user made a gesture asking for info/menu relating to me.  Some of the messages dispatched here are not yet available in this image"

	| aMenu elementType |
	elementType _ self elementTypeFor: anElement.
	((elementType = #systemSlot) | (elementType == #userSlot))
		ifTrue:	[^ self slotInfoButtonHitFor: anElement inViewer: aViewer].
	self flag: #deferred.  "Use a traditional MenuMorph, and reinstate the pacify thing"
	aMenu _ MenuMorph new defaultTarget: aViewer.
	#(	('implementors'			browseImplementorsOf:)
		('senders'				browseSendersOf:)
		('versions'				browseVersionsOf:)
		-
		('browse full'			browseMethodFull:)
		('inheritance'			browseMethodInheritance:)
		-
		('about this method'		aboutMethod:)) do:

			[:pair |
				pair = '-'
					ifTrue:
						[aMenu addLine]
					ifFalse:
						[aMenu add: pair first target: aViewer selector: pair second argument: anElement]].
	aMenu addLine.
	aMenu defaultTarget: self.
	#(	('destroy script'		removeScript:)
		('rename script'		renameScript:)
		('pacify script'		pacifyScript:)) do:
			[:pair |
				aMenu add: pair first target: self selector: pair second argument: anElement].

	aMenu items size == 0 ifTrue:
		[aMenu add: 'ok' action: nil].  "in case it was a slot -- weird, transitional"

	aMenu addTitle: anElement asString, ' (', elementType, ')'.

	aMenu popUpInWorld: self currentWorld.
 ! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 18:30'!
initialTypeForSlotNamed: aName
	"Answer the initial type to be ascribed to the given instance variable"

	^ #object! !

!Object methodsFor: 'viewer' stamp: 'sw 10/24/2000 11:36'!
newScriptorAround: aPhraseTileMorph
	"Sprout a scriptor around aPhraseTileMorph, thus making a new script.  This is where generalized scriptors will be threaded in"

	^ nil! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 18:10'!
offerViewerMenuFor: aViewer event: evt
	"Offer the primary Viewer menu to the user.  Copied up from Player code, but most of the functions suggested here don't work for non-Player objects, many aren't even defined, some relate to exploratory sw work not yet reflected in the current corpus.  Think of this as a beginning!!"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	aMenu title: '**CAUTION -- UNDER CONSTRUCTION!!**
', self nameForViewer.
	(aViewer affordsUniclass and: [self belongsToUniClass not]) ifTrue:
		[aMenu add: 'give me a Uniclass' action: #assureUniClass.
		aMenu addLine].

	aMenu add: 'rename me' target: aViewer selector: #chooseNewNameForReference.
	self belongsToUniClass ifTrue:
		[aMenu add: 'add a new instance variable' target: self selector: #addInstanceVariableIn: argument: aViewer.
		aMenu add: 'add a new script' target: aViewer selector: #newPermanentScriptIn: argument: aViewer.
		aMenu addLine.
		aMenu add: 'make my class be first-class' target: self selector: #makeFirstClassClassIn: argument: aViewer.
		aMenu add: 'move my changes up to my superclass' target: self action: #promoteChangesToSuperclass.
		aMenu addLine].

	aMenu add: 'toggle scratch pane' target: aViewer selector: #toggleScratchPane.
	aMenu add: 'make a nascent script for me' target: aViewer selector: #makeNascentScript.
	aMenu add: 'tear off a tile' target: self selector: #launchTileToRefer.
	aMenu addLine.
	aMenu add: 'inspect me' target: self selector: #inspect.
	aMenu add: 'inspect my class' target: self class action: #inspect.
	aMenu add: 'references to me' target: aViewer action: #browseReferencesToObject.
	aMenu addLine.
	aMenu add: 'browse full' action: #browseOwnClassFull.
	aMenu add: 'browse hierarchy' action: #browseOwnClassHierarchy.
	aMenu add: 'browse protocol' action: #browseOwnClassProtocol.
	aMenu add: 'browse sub-protocol' action: #browseOwnClassSubProtocol.
	aMenu addLine.
	aMenu add: 'set user level...' target: aViewer action: #setUserLevel.
	aMenu addLine.
	aMenu add: 'inspect this Viewer' target: aViewer action: #inspect.

	aMenu popUpEvent: evt in: aViewer currentWorld! !

!Object methodsFor: 'viewer' stamp: 'sw 10/25/2000 17:42'!
offerViewerMenuForEvt: anEvent morph: aMorph
	"Offer the viewer's primary menu to the user.  aMorph is some morph within the viewer itself, the one within which a mousedown triggered the need for this menu, and it is used only to retrieve the Viewer itself"

	self offerViewerMenuFor: (aMorph ownerThatIsA: StandardViewer) event: anEvent! !

!Object methodsFor: 'viewer' stamp: 'sw 1/22/2001 15:20'!
renameScript: oldSelector
	"prompt the user for a new selector and apply it.  Presently only works for players"

	self notYetImplemented! !

!Object methodsFor: 'viewer' stamp: 'sw 10/24/2000 10:53'!
tileForArgType: typeSymbol inViewer: aViewer
	"Answer a tile to represent an argument of the given type; the viewer argument is actually used, but nowadays in only a vacuous sense that should be excised, since the viewer does not use anything about itself in its subsequent code"

	| aColor aPlayer |
	typeSymbol == #player ifTrue:
		[aPlayer _ self presenter
			ifNotNil:
				[self presenter standardPlayer]
			ifNil:  "It happens, if costume is not currently in a world"
				[self].
		^ aViewer tileForPlayer:  aPlayer].
	aColor _ ScriptingSystem colorForType: typeSymbol.
	typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor].
	typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor].
	typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative].
	typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType:  typeSymbol].

	self error: 'Unrecognized type'! !

!Object methodsFor: 'viewer' stamp: 'sw 10/5/2000 09:35'!
tilePhrasesForCategory: aCategory inViewer: aViewer
	"Return an array of phrases for the category"

	^ (self tilePhrasesSpecsForCategory: aCategory) collect:
		[:aSpec |
			aSpec first == #slot
				ifTrue:
					[aViewer phraseForSlot: aSpec]
				ifFalse:
					[self commandPhraseFor: aSpec inViewer: aViewer]]! !

!Object methodsFor: 'viewer' stamp: 'sw 10/5/2000 09:34'!
tilePhrasesSpecsForCategory: aCategory
	"Return an array of slot and script names and info for use in a viewer on the receiver.  These can be of two flavors - command and slot."

	^ (self usablePhraseSpecsIn: (self categoryElementsFor: aCategory asSymbol))


"The format of the specs is illustrated by:
	(slot heading 'the direction'	number	 readWrite player getHeading player setHeading:)
	(command wearCostumeOf: 'change appearance to look like' player)"

! !

!Object methodsFor: 'viewer' stamp: 'sw 10/17/2000 11:27'!
uniqueInstanceVariableNameLike: aString excluding: takenNames
	"Answer a nice instance-variable name to be added to the receiver which resembles aString, making sure it does not coincide with any element in takenNames"

	| okBase uniqueName usedNames |
	usedNames _ self class allInstVarNamesEverywhere.
	usedNames removeAllFoundIn: self class instVarNames.
	usedNames addAll: takenNames.
	okBase _ Utilities wellFormedInstanceVariableNameFrom: aString.

	uniqueName _ Utilities keyLike: okBase satisfying: 
		[:aKey | (usedNames includes: aKey) not].

	^ uniqueName! !

!Object methodsFor: 'viewer' stamp: 'sw 10/17/2000 11:29'!
uniqueNameForReference
	"Answer a nice name by which the receiver can be referred to by other objects.  At present this uses a global References dictionary to hold the database of references, but in due course this will need to acquire some locality"

	| aName nameSym stem knownClassVars |
	(References includesIdentity: self) ifTrue: [^ References keyAtValue: self].

	stem _ (self knownName ifNil: [self defaultNameStemForInstances asString]) capitalized.
	knownClassVars _ ScriptingSystem allKnownClassVariableNames.
	aName _ Utilities keyLike:  stem satisfying:
		[:jinaLake |
			nameSym _ jinaLake asSymbol.
			 ((References includesKey:  nameSym) not and:
				[(Smalltalk includesKey: nameSym) not]) and:
						[(knownClassVars includes: nameSym) not]].

	References at: (aName _ aName asSymbol) put: self.
	^ aName! !

!Object methodsFor: 'viewer' stamp: 'sw 10/17/2000 11:29'!
uniqueNameForReferenceOrNil
	"If the receiver has a unique name for reference, return it here, else return nil"

	^ References keyForIdentity: self! !

!Object methodsFor: 'viewer' stamp: 'sw 10/24/2000 07:08'!
usablePhraseSpecsIn: aList
	"Filter aList, returning a subset list of apt phrases"

	^ aList
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Object class
	instanceVariableNames: ''!

!Object class methodsFor: 'instance creation' stamp: 'RAA 6/22/2000 14:14'!
categoryForUniclasses
	"Answer the category into which to place unique-class instances"
	^ 'Morphic-UserObjects'! !

!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'!
chooseUniqueClassName
	| i className |
	i _ 1.
	[className _ (self name , i printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [i _ i + 1].
	^ className! !

!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'!
copyMethodDictionaryFrom: donorClass
	"Copy the method dictionary of the donor class over to the receiver"

	methodDict _ donorClass copyOfMethodDictionary.
	organization _ donorClass organization deepCopy! !

!Object class methodsFor: 'instance creation' stamp: 'tk 8/22/1998 08:22'!
initialInstance
	"Answer the first instance of the receiver, generate an error if there is one already"
	"self instanceCount > 0 ifTrue: [self error: 'instance(s) already exist.']."
		"Debugging test that is very slow"
	^ self new! !

!Object class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:30'!
initializedInstance
	^ self new! !

!Object class methodsFor: 'instance creation' stamp: 'sw 10/16/2000 10:58'!
instanceOfUniqueClass
	"Answer an instance of a unique subclass of the receiver"

	^ self instanceOfUniqueClassWithInstVarString: '' andClassInstVarString: ''! !

!Object class methodsFor: 'instance creation' stamp: 'tk 8/22/1998 08:27'!
instanceOfUniqueClassWithInstVarString: instVarString andClassInstVarString: classInstVarString
	"Create a unique class for the receiver, and answer an instance of it"

	^ (self newUniqueClassInstVars: instVarString 
		classInstVars: classInstVarString) initialInstance! !

!Object class methodsFor: 'instance creation' stamp: 'sw 10/23/1999 22:51'!
isUniClass
	^ false! !

!Object class methodsFor: 'instance creation' stamp: 'di 6/9/1999 14:27'!
newFrom: aSimilarObject
	"Create an object that has similar contents to aSimilarObject.
	If the classes have any instance varaibles with the same names, copy them across.
	If this is bad for a class, override this method."

	^ self basicNew copySameFrom: aSimilarObject! !

!Object class methodsFor: 'instance creation' stamp: 'tk 6/29/1998 12:11'!
newUniqueClassInstVars: instVarString classInstVars: classInstVarString
	"Create a unique class for the receiver"

	| aName aClass |
	self isSystemDefined ifFalse:
		[^ superclass newUniqueClassInstVars: instVarString classInstVars: classInstVarString].
	aName _ self chooseUniqueClassName.
	aClass _ self subclass: aName instanceVariableNames: instVarString 
		classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses.
	classInstVarString size > 0 ifTrue:
		[aClass class instanceVariableNames: classInstVarString].
	^ aClass! !

!Object class methodsFor: 'instance creation' stamp: 'sw 7/28/97 15:56'!
newUserInstance
	"Answer an instance of an appropriate class to serve as a user object in the containment hierarchy"

	^ self instanceOfUniqueClass! !

!Object class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 15:46'!
readCarefullyFrom: textOrString
	"Create an object based on the contents of textOrString.  Return an error instead of putting up a SyntaxError window."

	| object ok |
	ok _ (textOrString isKindOf: Stream) or: [textOrString isKindOf: String].
	(ok or: [textOrString isKindOf: Text]) ifFalse: [^ self error: 'expected String or Text'].
	object _ Compiler evaluate: textOrString for: nil 
				notifying: #error: "signal we want errors" logged: false.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !

!Object class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 07:05'!
readFrom: aStream
	"Create an object based on the contents of aStream."

	| object ok |
	ok _ (aStream isKindOf: Stream) or: [aStream isKindOf: String].
	(ok or: [aStream isKindOf: Text]) ifFalse: [^ self error: 'expected String or Text'].
	object _ Compiler evaluate: aStream.
	(object isKindOf: self) ifFalse: [self error: self name, ' expected'].
	^object! !


!Object class methodsFor: 'documentation'!
howToModifyPrimitives
	"You are allowed to write methods which specify primitives, but please use 
	caution.  If you make a subclass of a class which contains a primitive method, 
	the subclass inherits the primitive.  The message which is implemented 
	primitively may be overridden in the subclass (E.g., see at:put: in String's 
	subclass Symbol).  The primitive behavior can be invoked using super (see 
	Symbol string:). 
	 
	A class which attempts to mimic the behavior of another class without being 
	its subclass may or may not be able to use the primitives of the original class.  
	In general, if the instance variables read or written by a primitive have the 
	same meanings and are in the same fields in both classes, the primitive will 
	work.  

	For certain frequently used 'special selectors', the compiler emits a 
	send-special-selector bytecode instead of a send-message bytecode.  
	Special selectors were created because they offer two advantages.  Code 
	which sends special selectors compiles into fewer bytes than normal.  For 
	some pairs of receiver classes and special selectors, the interpreter jumps 
	directly to a primitive routine without looking up the method in the class.  
	This is much faster than a normal message lookup. 
	 
	A selector which is a special selector solely in order to save space has a 
	normal behavior.  Methods whose selectors are special in order to 
	gain speed contain the comment, 'No Lookup'.  When the interpreter 
	encounters a send-special-selector bytecode, it checks the class of the 
	receiver and the selector.  If the class-selector pair is a no-lookup pair, 
	then the interpreter swiftly jumps to the routine which implements the 
	corresponding primitive.  (A special selector whose receiver is not of the 
	right class to make a no-lookup pair, is looked up normally).  The pairs are 
	listed below.  No-lookup methods contain a primitive number specification, 
	<primitive: xx>, which is redundant.  Since the method is not normally looked 
	up, deleting the primitive number specification cannot prevent this 
	primitive from running.  If a no-lookup primitive fails, the method is looked 
	up normally, and the expressions in it are executed. 
	 
	No Lookup pairs of (class, selector) 
	 
	SmallInteger with any of		+ - * /  \\  bitOr: bitShift: bitAnd:  // 
	SmallInteger with any of		=  ~=  >  <  >=  <= 
	Any class with					== 
	Any class with 					@ 
	Point with either of				x y 
	ContextPart with					blockCopy: 
	BlockContext with either of 		value value:
	"

	self error: 'comment only'! !

!Object class methodsFor: 'documentation'!
whatIsAPrimitive
	"Some messages in the system are responded to primitively. A primitive   
	response is performed directly by the interpreter rather than by evaluating   
	expressions in a method. The methods for these messages indicate the   
	presence of a primitive response by including <primitive: xx> before the   
	first expression in the method.   
	  
	Primitives exist for several reasons. Certain basic or 'primitive' 
	operations cannot be performed in any other way. Smalltalk without 
	primitives can move values from one variable to another, but cannot add two 
	SmallIntegers together. Many methods for arithmetic and comparison 
	between numbers are primitives. Some primitives allow Smalltalk to 
	communicate with I/O devices such as the disk, the display, and the keyboard. 
	Some primitives exist only to make the system run faster; each does the same 
	thing as a certain Smalltalk method, and its implementation as a primitive is 
	optional.  
	  
	When the Smalltalk interpreter begins to execute a method which specifies a 
	primitive response, it tries to perform the primitive action and to return a 
	result. If the routine in the interpreter for this primitive is successful, 
	it will return a value and the expressions in the method will not be evaluated. 
	If the primitive routine is not successful, the primitive 'fails', and the 
	Smalltalk expressions in the method are executed instead. These 
	expressions are evaluated as though the primitive routine had not been 
	called.  
	  
	The Smalltalk code that is evaluated when a primitive fails usually 
	anticipates why that primitive might fail. If the primitive is optional, the 
	expressions in the method do exactly what the primitive would have done (See 
	Number @). If the primitive only works on certain classes of arguments, the 
	Smalltalk code tries to coerce the argument or appeals to a superclass to find 
	a more general way of doing the operation (see SmallInteger +). If the 
	primitive is never supposed to fail, the expressions signal an error (see 
	SmallInteger asFloat).  
	  
	Each method that specifies a primitive has a comment in it. If the primitive is 
	optional, the comment will say 'Optional'. An optional primitive that is not 
	implemented always fails, and the Smalltalk expressions do the work 
	instead.  
	 
	If a primitive is not optional, the comment will say, 'Essential'. Some 
	methods will have the comment, 'No Lookup'. See Object 
	howToModifyPrimitives for an explanation of special selectors which are 
	not looked up.  
	  
	For the primitives for +, -, *, and bitShift: in SmallInteger, and truncated 
	in Float, the primitive constructs and returns a 16-bit 
	LargePositiveInteger when the result warrants it. Returning 16-bit 
	LargePositiveIntegers from these primitives instead of failing is 
	optional in the same sense that the LargePositiveInteger arithmetic 
	primitives are optional. The comments in the SmallInteger primitives say, 
	'Fails if result is not a SmallInteger', even though the implementor has the 
	option to construct a LargePositiveInteger. For further information on 
	primitives, see the 'Primitive Methods' part of the chapter on the formal 
	specification of the interpreter in the Smalltalk book."

	self error: 'comment only'! !


!Object class methodsFor: 'private' stamp: 'sma 2/29/2000 20:12'!
initializeDependentsFields
	DependentsFields _ IdentityDictionary new

	"Object initializeDependentsFields"! !

!Object class methodsFor: 'private' stamp: 'sma 2/29/2000 20:12'!
initializeEventsFields
	EventsFields _ IdentityDictionary new

	"Object initializeEventsFields"! !


!Object class methodsFor: 'objects from disk' stamp: 'tk 1/8/97'!
createFrom: aSmartRefStream size: varsOnDisk version: instVarList
	"Create an instance of me so objects on the disk can be read in.  Tricky part is computing the size if variable.  Inst vars will be filled in later.  "

	^ self isVariable
		ifFalse: [self basicNew]
		ifTrue: ["instVarList is names of old class's inst vars plus a version number" 
				self basicNew: (varsOnDisk - (instVarList size - 1))]
! !


!Object class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:05'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asNakedOopFrom: anInteger on: aStream! !

!Object class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 13:01'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !

!Object class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !

!Object class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 16:09'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asKindOf: self from: anInteger! !

!Object class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:12'!
ccgCanConvertFrom: anObject

	^anObject isKindOf: self! !

!Object class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 00:19'!
ccgDeclareCForVar: aSymbolOrString

	^'int ', aSymbolOrString! !
AbstractHierarchicalList subclass: #ObjectExplorer
	instanceVariableNames: 'rootObject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!ObjectExplorer commentStamp: '<historical>' prior: 0!
ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like:

World explore

and enjoy.!
]style[(101 13 12)f1,f3cblue;,f1!


!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:22'!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
	^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:11'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ 1 to: 0  "null selection"! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:15'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	^nil! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:19'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	currentSelection ifNil: [^rootObject].
	^currentSelection withoutListWrapper
! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'sma 2/5/2000 14:23'!
explorerFor: anObject
	| window listMorph |
	rootObject _ anObject.
	window _ (SystemWindow labelled: 'Explorer') model: self.
	window addMorph: (listMorph _ SimpleHierarchicalListMorph 
			on: self
			list: #getList
			selected: #getCurrentSelection
			changeSelected: #noteNewSelection:
			menu: #genericMenu:
			keystroke: nil)
		frame: (0@0 corner: 1@0.8).
	window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
					askBeforeDiscardingEdits: false)
		frame: (0@0.8 corner: 1@1).
	listMorph autoDeselect: false.
     ^ window! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'ccn 7/3/2000 22:35'!
genericMenu: aMenu

	| insideObject menu |
	currentSelection ifNil:
		[menu _ aMenu.
		menu add: '*nothing selected*' target: self selector: #yourself]
	 ifNotNil:
		[menu _ DumberMenuMorph new defaultTarget: self.
		insideObject _ currentSelection withoutListWrapper.
		menu 
			add: 'explore' target: insideObject  selector: #explore;
			add: 'inspect' target: insideObject  selector: #inspect;
			addLine;
			add: 'objects pointing to this value' target: Smalltalk  selector:  #browseAllObjectReferencesTo:except:ifNone:  argumentList: (Array with: insideObject with: #() with: nil);
			addLine;
			add: 'browse full' target: Browser  selector: #fullOnClass:  argument: insideObject class;
			add: 'browse class' target: insideObject class  selector: #browse;
			add: 'browse hierarchy' target: Utilities  selector:  #spawnHierarchyForClass:selector: argumentList: (Array with: insideObject class with: nil).
		insideObject class == Symbol ifTrue: [
			menu 
				addLine;
				add: ('senders of ', insideObject printString) target: Smalltalk  selector: #browseAllCallsOn:  argument: insideObject;
				add: ('implementors of ', insideObject printString) target: Smalltalk  selector: #browseAllImplementorsOf:  argument: insideObject]].

	^ menu! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:22'!
getList

	^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self)
! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 16:23'!
initialExtent

	^300@500! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 16:24'!
openExplorerFor: anObject
"
ObjectExplorer new openExplorerFor: Smalltalk
"

    (self explorerFor: anObject) openInWorld.
    ^ self
! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:19'!
selectedClass
	"Answer the class of the receiver's current selection"

	^self doItReceiver class
! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:10'!
trash
	"What goes in the bottom pane"
	^ ''! !

!ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'RAA 9/23/1999 13:10'!
trash: newText
	"Don't save it"
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectExplorer class
	instanceVariableNames: ''!

!ObjectExplorer class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:55'!
about

	StringHolder new textContents: self comment; openLabel: 'about ',self asString! !
ListItemWrapper subclass: #ObjectExplorerWrapper
	instanceVariableNames: 'itemName '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!ObjectExplorerWrapper commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 15:48'!
canBeDragged

	^false! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'bf 3/16/2000 18:07'!
contents
	| answer |
	answer _ OrderedCollection new.
	"Don't show internal representation of these"
	({OrderedCollection. FloatArray. Dictionary} anySatisfy: [:class | item isKindOf: class])
		ifTrue: [
			item keysAndValuesDo: [:key :value |
				answer add: (ObjectExplorerWrapper
					with: value
					name: (key printString contractTo: 32)
					model: item)].
			^ answer].
	"Same for Sets, but must provide an index"
	(item isKindOf: Set) ifTrue: [
		item doWithIndex: [:each :index |
			answer add: (ObjectExplorerWrapper
				with: each
				name: index printString
				model: item)].
		^ answer].
	"For all others, show named vars first, then indexed vars"
	item class allInstVarNames asArray doWithIndex: [:each :index |
		answer add: (ObjectExplorerWrapper
			with: (item instVarAt: index)
			name: each
			model: item)].
	1 to: item basicSize do: [:index |
		answer add: (ObjectExplorerWrapper
			with: (item basicAt: index)
			name: index printString
			model: item)].
	^ answer! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 11:27'!
hasContents

	^item hasContentsInExplorer
	
! !

!ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:49'!
setItem: anObject name: aString model: aModel

	item _ anObject.
	model _ aModel.
	itemName _ aString.! !


!ObjectExplorerWrapper methodsFor: 'converting' stamp: 'sma 11/12/2000 11:45'!
asString
	| string |
	string _ itemName , ': ' , item asExplorerString.
	(string includes: Character cr)
		ifTrue: [^ string withSeparatorsCompacted].
	^ string! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectExplorerWrapper class
	instanceVariableNames: ''!

!ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:50'!
with: anObject name: aString model: aModel

	^self new 
		setItem: anObject name: aString model: aModel! !
Object subclass: #ObjectMemory
	instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold statFullGCs statFullGCMSecs statIncrGCs statIncrGCMSecs statTenures statRootTableOverflows freeContexts freeLargeContexts interruptCheckCounter displayBits totalObjectFoundAtStartup '
	classVariableNames: 'AllButHashBits AllButMarkBit AllButMarkBitAndTypeMask AllButRootBit AllButTypeMask BaseHeaderSize BlockContextProto CharacterTable ClassArray ClassBitmap ClassBlockContext ClassByteArray ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassPoint ClassProcess ClassPseudoContext ClassSemaphore ClassString ClassTranslatedMethod CompactClassMask CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero CtxtTempFrameStart DoAssertionChecks Done ExternalObjectsArray FalseObject FloatProto GCTopMarker HashBits HashBitsOffset HeaderTypeClass HeaderTypeFree HeaderTypeGC HeaderTypeShort HeaderTypeSizeAndClass LargeContextBit LargeContextSize MarkBit MethodContextProto NilContext NilObject RemapBufferSize RootBit RootTableSize SchedulerAssociation SelectorCannotInterpret SelectorCannotReturn SelectorDoesNotUnderstand SelectorMustBeBoolean SizeMask SmallContextSize SpecialSelectors StackStart StartField StartObj TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject TypeMask Upward '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!ObjectMemory commentStamp: '<historical>' prior: 0!
This class describes a 32-bit direct-pointer object memory for Smalltalk.  The model is very simple in principle:  a pointer is either a SmallInteger or a 32-bit direct object pointer.

SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.

All object pointers point to a header, which may be followed by a number of data fields.  This object memory achieves considerable compactness by using a variable header size (the one complexity of the design).  The format of the 0th header word is as follows:
	3 bits	reserved for gc (mark, old, dirty)
	12 bits	object hash (for HashSets)
	5 bits	compact class index
	4 bits	object format
	6 bits	object size in 32-bit words
	2 bits	header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)

If a class is in the compact class table, then this is the only header information needed.  If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits.  It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.

The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).

This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers.  It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.!


!ObjectMemory methodsFor: 'initialization' stamp: 'JMM 11/18/2000 17:50'!
adjustAllOopsBy: bytesToShift
	"Adjust all oop references by the given number of bytes. This is done just after reading in an image when the new base address of the object heap is different from the base address in the image."
	"ar 10/7/1998 - Clear the RootBit of all objects"
	"di 11/18/2000 - return number of objects found"

	| oop header totalObjects |
	"Note: Don't bypass this method even if bytesToShift is zero 
		until the RootBit problem has been fixed in the appropriate places."
	"bytesToShift = 0 ifTrue: [ ^ nil ]."

	totalObjects _ 0.
	oop _ self firstObject.
	[oop < endOfMemory] whileTrue: [
		(self isFreeObject: oop) ifFalse: [
			totalObjects _ totalObjects + 1.
			header _ self longAt: oop.
			self longAt: oop put: (header bitAnd: AllButRootBit).
			self adjustFieldsAndClassOf: oop by: bytesToShift.
 		].
		oop _ self objectAfter: oop.
	].
	^totalObjects
! !

!ObjectMemory methodsFor: 'initialization'!
adjustFieldsAndClassOf: oop by: offsetBytes
	"Adjust all pointers in this object by the given offset."

	| fieldAddr fieldOop classHeader newClassOop |
	fieldAddr _ oop + (self lastPointerOf: oop).
	[fieldAddr > oop] whileTrue: [
		fieldOop _ self longAt: fieldAddr.
		(self isIntegerObject: fieldOop) ifFalse: [
			self longAt: fieldAddr put: (fieldOop + offsetBytes).
		].
		fieldAddr _ fieldAddr - 4.
	].

	(self headerType: oop) ~= HeaderTypeShort ifTrue: [
		"adjust class header if not a compact class"

		classHeader _ self longAt: (oop - 4).
		newClassOop _
			(classHeader bitAnd: AllButTypeMask) + offsetBytes.
		self longAt: (oop - 4) put: (newClassOop bitOr: (classHeader bitAnd: TypeMask)).
	].
! !

!ObjectMemory methodsFor: 'initialization' stamp: 'JMM 11/18/2000 18:03'!
initializeMemoryFirstFree: firstFree 
	"Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans."
	"Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks).
di 11/18/2000 Re totalObjectFoundAtStartup Provide a margin of one byte per object to be used for forwarding pointers at GC time.  Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory.  In most cases it will be adequate to do compaction in a single pass."

	| fwdBlockBytes |
	"reserve space for forwarding blocks"
	fwdBlockBytes _ totalObjectFoundAtStartup.
	(memoryLimit - fwdBlockBytes) >= (firstFree + BaseHeaderSize) ifFalse: [
		"reserve enough space for a minimal free block of BaseHeaderSize bytes"
		fwdBlockBytes _ memoryLimit - (firstFree + BaseHeaderSize).
	].

	"set endOfMemory and initialize freeBlock"
	endOfMemory _ memoryLimit - fwdBlockBytes.
	freeBlock _ firstFree.
	self setSizeOfFree: freeBlock to: (endOfMemory - firstFree).  "bytes available for oops"

	"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
	self setSizeOfFree: endOfMemory to: BaseHeaderSize.

	DoAssertionChecks ifTrue: [
		((freeBlock < endOfMemory) and: [endOfMemory < memoryLimit])
			ifFalse: [ self error: 'error in free space computation' ].	
		(self oopFromChunk: endOfMemory) = endOfMemory
			ifFalse: [ self error: 'header format must have changed' ].
		(self objectAfter: freeBlock) = endOfMemory
			ifFalse: [ self error: 'free block not properly initialized' ].
	].! !

!ObjectMemory methodsFor: 'initialization' stamp: 'di 11/18/2000 21:41'!
initializeObjectMemory: bytesToShift
	"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
	"Assume: image reader initializes the following variables:
		memory
		endOfMemory
		memoryLimit
		specialObjectsOop
		lastHash
	"
	"di 11/18/2000 fix slow full GC"
	self inline: false.

	"set the start of the young object space"
	youngStart _ endOfMemory.

	"image may be at a different address; adjust oops for new location"
	totalObjectFoundAtStartup _ (self adjustAllOopsBy: bytesToShift) bitAnd: 16rFFFFFFFC.

	self initializeMemoryFirstFree: endOfMemory.
		"initializes endOfMemory, freeBlock"

	specialObjectsOop _ specialObjectsOop + bytesToShift.

	"heavily used special objects"
	nilObj	_ self splObj: NilObject.
	falseObj	_ self splObj: FalseObject.
	trueObj	_ self splObj: TrueObject.

	rootTableCount _ 0.
	child _ 0.
	field _ 0.
	parentField _ 0.
	freeContexts _ NilContext.
	freeLargeContexts _ NilContext.
	allocationCount _ 0.
	lowSpaceThreshold _ 0.
	signalLowSpace _ false.
	compStart _ 0.
	compEnd _ 0.
	fwdTableNext _ 0.
	fwdTableLast _ 0.
	remapBufferCount _ 0.
	allocationsBetweenGCs _ 4000.  "do incremental GC after this many allocations"
	tenuringThreshold _ 2000.  "tenure all suriving objects if count is over this threshold"

	"garbage collection statistics"
	statFullGCs _ 0.
	statFullGCMSecs _ 0.
	statIncrGCs _ 0.
	statIncrGCMSecs _ 0.
	statTenures _ 0.
	statRootTableOverflows _ 0.

	displayBits _ 0.  "support for the Acorn VM; ignored if zero"
! !


!ObjectMemory methodsFor: 'interpreter access'!
fetchByte: byteIndex ofObject: oop

	^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 11/27/1998 11:19'!
fetchClassOf: oop
	| ccIndex |
	self inline: true.
	(self isIntegerObject: oop)
		ifTrue: [ ^ self splObj: ClassInteger ].

	ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
	ccIndex = 0
		ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: ["look up compact class"
				^ self fetchPointer: ccIndex - 1
					ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)
		].
! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 11/27/1998 11:18'!
fetchClassOfNonInt: oop
	| ccIndex |
	self inline: true.

	ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F.
	ccIndex = 0
		ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: ["look up compact class"
				^ self fetchPointer: ccIndex - 1
					ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)]
! !

!ObjectMemory methodsFor: 'interpreter access'!
fetchPointer: fieldIndex ofObject: oop

	^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! !

!ObjectMemory methodsFor: 'interpreter access'!
fetchWord: fieldIndex ofObject: oop

	^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! !

!ObjectMemory methodsFor: 'interpreter access'!
fetchWordLengthOf: objectPointer

	| sz |
	sz _ self sizeBitsOf: objectPointer.
	^ (sz - BaseHeaderSize) >> 2! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'jm 12/6/1998 17:12'!
instantiateClass: classPointer indexableSize: size
	| hash header1 header2 cClass byteSize format inc binc header3 hdrSize fillWord newObj sizeHiBits |
"
	NOTE: This method supports the backward-compatible split instSize field of the
	class format word.  The sizeHiBits will go away and other shifts change by 2
	when the split fields get merged in an (incompatible) image change.
"
	self inline: false.
	DoAssertionChecks ifTrue: [
		size < 0 ifTrue: [ self error: 'cannot have a negative indexable field count' ]].

	hash _ self newObjectHash.
	header1 _ self formatOfClass: classPointer. "Low 2 bits are 0"
	sizeHiBits _ (header1 bitAnd: 16r60000) >> 9.
	header1 _ (header1 bitAnd: 16r1FFFF) bitOr: ((hash << HashBitsOffset) bitAnd: HashBits).
	header2 _ classPointer.
	header3 _ 0.

	cClass _ header1 bitAnd: CompactClassMask. "compact class field from format word"
	byteSize _ (header1 bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
	format _ (header1 >> 8) bitAnd: 16rF.

	format < 8 ifTrue: [
		"Bitmaps and Arrays"
		inc _ size * 4.
	] ifFalse: [
		"Strings and Methods"
		inc _ (size + 3) bitAnd: AllButTypeMask. "round up"
		binc _ 3 - ((size + 3) bitAnd: 3). "odd bytes"
		"low bits of byte size go in format field"
		header1 _ header1 bitOr: (binc << 8).
	].

	(byteSize + inc) > 255 ifTrue: [
		"requires size header word"
		header3 _ byteSize + inc.
		header1 _ header1 - (byteSize bitAnd: 16rFF).  "Clear qsize field"
	] ifFalse: [
		header1 _ header1 + inc.
	].
	byteSize _ byteSize + inc.

	header3 > 0 ifTrue: [
		"requires full header"
		hdrSize _ 3.
	] ifFalse: [
		cClass = 0
			ifTrue: [ hdrSize _ 2 ]
			ifFalse: [ hdrSize _ 1 ].
	].
	format <= 4  "if pointers, fill with nil oop"
		ifTrue: [ fillWord _ nilObj ]
		ifFalse: [ fillWord _ 0 ].

	newObj _ self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord.
	^ newObj! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 12/4/1998 02:36'!
instantiateContext: classPointer sizeInBytes: sizeInBytes
	"This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word."

	| hash header1 header2 hdrSize |
	hash _ self newObjectHash.
	header1 _ ((hash << HashBitsOffset) bitAnd: HashBits) bitOr:
			   (self formatOfClass: classPointer).
	header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask)).
	header2 _ classPointer.

	(header1 bitAnd: CompactClassMask) = 0 "is compact class field from format word zero?"
		ifTrue: [ hdrSize _ 2 ]
		ifFalse: [ hdrSize _ 1 ].

	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0! !

!ObjectMemory methodsFor: 'interpreter access' stamp: 'di 12/4/1998 01:33'!
instantiateSmallClass: classPointer sizeInBytes: sizeInBytes fill: fillValue
	"This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word."

	| hash header1 header2 hdrSize |
	hash _ self newObjectHash.
	header1 _ ((hash << HashBitsOffset) bitAnd: HashBits) bitOr:
			   (self formatOfClass: classPointer).
	header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask)).
	header2 _ classPointer.

	(header1 bitAnd: CompactClassMask) = 0 "is compact class field from format word zero?"
		ifTrue: [ hdrSize _ 2 ]
		ifFalse: [ hdrSize _ 1 ].

	^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: true with: fillValue! !

!ObjectMemory methodsFor: 'interpreter access'!
integerObjectOf: value
	value < 0
		ifTrue: [^ ((16r80000000 + value) << 1) + 1]
		ifFalse: [^ (value << 1) + 1]! !

!ObjectMemory methodsFor: 'interpreter access'!
integerValueOf: objectPointer
	"Translator produces 'objectPointer >> 1'"

	((objectPointer bitAnd: 16r80000000) ~= 0)
		ifTrue: ["negative"
				^ ((objectPointer bitAnd: 16r7FFFFFFF) >> 1)
					- 16r3FFFFFFF - 1  "Faster than -16r40000000 (a LgInt)"]
		ifFalse: ["positive"
				^ objectPointer >> 1]! !

!ObjectMemory methodsFor: 'interpreter access'!
isIntegerObject: objectPointer

	^ (objectPointer bitAnd: 1) > 0! !

!ObjectMemory methodsFor: 'interpreter access'!
isIntegerValue: intValue
	"Return true if the given value can be represented as a Smalltalk integer value."
	"Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits."

	^ (intValue bitXor: (intValue << 1)) >= 0! !

!ObjectMemory methodsFor: 'interpreter access'!
nilObject  "For access from BitBlt module"
	^ nilObj! !

!ObjectMemory methodsFor: 'interpreter access'!
popRemappableOop
	"Pop and return the possibly remapped object from the remap buffer."

	| oop |
	oop _ remapBuffer at: remapBufferCount.
	remapBufferCount _ remapBufferCount - 1.
	^ oop! !

!ObjectMemory methodsFor: 'interpreter access'!
pushRemappableOop: oop
	"Record the given object in a the remap buffer. Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped."

	remapBuffer at: (remapBufferCount _ remapBufferCount + 1) put: oop.! !

!ObjectMemory methodsFor: 'interpreter access'!
splObj: index
	"Return one of the objects in the SpecialObjectsArray"
	^ self fetchPointer: index ofObject: specialObjectsOop! !

!ObjectMemory methodsFor: 'interpreter access'!
storeByte: byteIndex ofObject: oop withValue: valueByte

	^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex
		put: valueByte! !

!ObjectMemory methodsFor: 'interpreter access'!
storePointer: fieldIndex ofObject: oop withValue: valuePointer
	"Note must check here for stores of young objects into old ones."

	(oop < youngStart) ifTrue: [
		self possibleRootStoreInto: oop value: valuePointer.
	].

	^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)
		put: valuePointer! !

!ObjectMemory methodsFor: 'interpreter access'!
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
	"Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root."

	^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)
			put: valuePointer
! !

!ObjectMemory methodsFor: 'interpreter access'!
storeWord: fieldIndex ofObject: oop withValue: valueWord

	^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)
		put: valueWord! !


!ObjectMemory methodsFor: 'memory access'!
checkAddress: byteAddress
	"Keep this method around for debugging the C code."

	byteAddress < (self startOfMemory) ifTrue: [
		self error: 'bad address: negative'.
	].
	byteAddress >= memoryLimit ifTrue: [
		self error: 'bad address: past end of heap'.
	].! !

!ObjectMemory methodsFor: 'memory access'!
checkedByteAt: byteAddress
	"Assumes zero-based array indexing."

	self checkAddress: byteAddress.
	^ self byteAt: byteAddress! !

!ObjectMemory methodsFor: 'memory access'!
checkedByteAt: byteAddress put: byte
	"Assumes zero-based array indexing."

	self checkAddress: byteAddress.
	self byteAt: byteAddress put: byte.! !

!ObjectMemory methodsFor: 'memory access'!
checkedLongAt: byteAddress
	"Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."

	self checkAddress: byteAddress.
	self checkAddress: byteAddress + 3.
	^ self longAt: byteAddress! !

!ObjectMemory methodsFor: 'memory access'!
checkedLongAt: byteAddress put: a32BitInteger
	"Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass."

	self checkAddress: byteAddress.
	self checkAddress: byteAddress + 3.
	self longAt: byteAddress put: a32BitInteger.! !

!ObjectMemory methodsFor: 'memory access' stamp: 'di 3/5/1999 17:23'!
validateRoots 
	"Verify that every old object that points to a new object 
		has its root bit set, and
		appears in the rootTable.
	This method should not be called if the rootTable is full, because roots
	are no longer recorded, and incremental collections are not attempted.
	If DoAssertionChecks is true, this routine will halt on an unmarked root.
	Otherwise, this routine will merely return true in that case."
	| oop fieldAddr fieldOop header badRoot |
	badRoot _ false.
	oop _ self firstObject.

	[oop < youngStart] whileTrue:
		[(self isFreeObject: oop) ifFalse:
			[fieldAddr _ oop + (self lastPointerOf: oop).
			[fieldAddr > oop] whileTrue:
				[fieldOop _ self longAt: fieldAddr.
				(fieldOop >= youngStart and: [(self isIntegerObject: fieldOop) not]) ifTrue:
					["fieldOop is a pointer to a young object"
					header _ self longAt: oop.
					(header bitAnd: RootBit) = 0
					ifTrue:
						["Forbidden: points to young obj but root bit not set."
						DoAssertionChecks ifTrue: [self error: 'root bit not set'].
						badRoot _ true]
					ifFalse:
						["Root bit is set"
						"Extreme test -- validate that oop was entered in rootTable too..."
						"Disabled for now...
						found _ false.
						1 to: rootTableCount do:
							[:i | oop = (rootTable at: i) ifTrue: [found _ true]].
						found ifFalse:
							[DoAssertionChecks ifTrue: [self error: 'root table not set'].
							badRoot _ true].
						..."
						]].
				fieldAddr _ fieldAddr - 4]].
		oop _ self objectAfter: oop].
	^ badRoot! !


!ObjectMemory methodsFor: 'header access'!
baseHeader: oop

	^ self longAt: oop! !

!ObjectMemory methodsFor: 'header access'!
classHeader: oop

	^ self longAt: oop - 4! !

!ObjectMemory methodsFor: 'header access' stamp: 'di 3/18/1999 19:38'!
formatOf: oop
"       0      no fields
        1      fixed fields only (all containing pointers)
        2      indexable fields only (all containing pointers)
        3      both fixed and indexable fields (all containing pointers)
        4      both fixed and indexable weak fields (all containing pointers).

        5      unused
        6      indexable word fields only (no pointers)
        7      unused
 
    8-11      indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
   12-15     compiled methods:
                   # of literal oops specified in method header,
                   followed by indexable bytes (same interpretation of low 2 bits as above)
"

	^ ((self baseHeader: oop) >> 8) bitAnd: 16rF! !

!ObjectMemory methodsFor: 'header access'!
hashBitsOf: oop

	^ ((self baseHeader: oop) >> 17) bitAnd: 16rFFF! !

!ObjectMemory methodsFor: 'header access'!
headerType: oop

	^ (self longAt: oop) bitAnd: TypeMask! !

!ObjectMemory methodsFor: 'header access'!
isBytes: oop
	"Answer true if the argument contains indexable bytes. See comment in formatOf:"
	"Note: Includes CompiledMethods."

	^ (self formatOf: oop)  >= 8! !

!ObjectMemory methodsFor: 'header access'!
isFreeObject: oop

	^ (self headerType: oop) = HeaderTypeFree! !

!ObjectMemory methodsFor: 'header access'!
isPointers: oop
	"Answer true if the argument has only fields that can hold oops. See comment in formatOf:"

	^ (self formatOf: oop) <= 4! !

!ObjectMemory methodsFor: 'header access' stamp: 'ar 3/21/98 02:38'!
isWeak: oop
	"Answer true if the argument has only weak fields that can hold oops. See comment in formatOf:"
	^ (self formatOf: oop) = 4! !

!ObjectMemory methodsFor: 'header access'!
isWords: oop
	"Answer true if the argument contains only indexable words (no oops). See comment in formatOf:"

	^ (self formatOf: oop) = 6! !

!ObjectMemory methodsFor: 'header access'!
isWordsOrBytes: oop
	"Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:"
	"Note: Excludes CompiledMethods."

	| fmt |
	fmt _ self formatOf: oop.
	^ fmt = 6 or: [(fmt >= 8) and: [fmt <= 11]]! !

!ObjectMemory methodsFor: 'header access'!
newObjectHash
	"Answer a new 16-bit pseudo-random number for use as an identity hash."

	lastHash _ 13849 + (27181 * lastHash) bitAnd: 65535.
	^ lastHash
! !

!ObjectMemory methodsFor: 'header access' stamp: 'go 11/18/1998 11:04'!
rightType: headerWord
	"Computer the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing."

	(headerWord bitAnd: SizeMask) = 0  "zero size field in header word"
		ifTrue: [ ^ HeaderTypeSizeAndClass ]
		ifFalse: [
			(headerWord bitAnd: CompactClassMask) = 0
				ifTrue: [ ^ HeaderTypeClass ]
				ifFalse: [ ^ HeaderTypeShort ]].! !

!ObjectMemory methodsFor: 'header access' stamp: 'go 11/13/1998 17:04'!
setSizeOfFree: chunk to: byteSize
	"Set the header of the given chunk to make it be a free chunk of the given size."

	self longAt: chunk put: ((byteSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).! !

!ObjectMemory methodsFor: 'header access' stamp: 'go 11/17/1998 15:57'!
sizeBitsOf: oop
	"Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
	"Note: byte indexable objects need to have low bits subtracted from this size."

	| header |
	header _ self baseHeader: oop.
	(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: [ ^ header bitAnd: SizeMask ].! !

!ObjectMemory methodsFor: 'header access' stamp: 'go 11/17/1998 15:57'!
sizeBitsOfSafe: oop
	"Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."

	| header type |
	header _ self baseHeader: oop.
	type _ self rightType: header.
	type = HeaderTypeSizeAndClass
		ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: [ ^ header bitAnd: SizeMask ].! !

!ObjectMemory methodsFor: 'header access'!
sizeHeader: oop

	^ self longAt: oop - 8! !

!ObjectMemory methodsFor: 'header access' stamp: 'go 11/13/1998 17:04'!
sizeOfFree: oop
	"Return the size of the given chunk in bytes. Argument MUST be a free chunk."

	^ (self longAt: oop) bitAnd: AllButTypeMask! !


!ObjectMemory methodsFor: 'object enumeration'!
accessibleObjectAfter: oop
	"Return the accessible object following the given object or free chunk in the heap. Return nil when heap is exhausted."

	| obj |
	self inline: false.
	obj _ self objectAfter: oop.
	[obj < endOfMemory] whileTrue: [
		(self isFreeObject: obj) ifFalse: [ ^obj ].
		obj _ self objectAfter: obj.
	].
	^ nil! !

!ObjectMemory methodsFor: 'object enumeration'!
firstAccessibleObject
	"Return the first accessible object in the heap."

	| obj |
	obj _ self firstObject.
	[obj < endOfMemory] whileTrue: [
		(self isFreeObject: obj) ifFalse: [ ^obj ].
		obj _ self objectAfter: obj.
	].
	self error: 'heap is empty'! !

!ObjectMemory methodsFor: 'object enumeration'!
firstObject
	"Return the first object or free chunk in the heap."

	^ self oopFromChunk: self startOfMemory! !

!ObjectMemory methodsFor: 'object enumeration'!
initialInstanceOf: classPointer
	"Support for instance enumeration. Return the first instance of the given class, or nilObj if it has no instances."

	| thisObj thisClass |
	thisObj _ self firstAccessibleObject.
	[thisObj = nil] whileFalse: [
		thisClass _ self fetchClassOf: thisObj.
		thisClass = classPointer ifTrue: [ ^thisObj ].
		thisObj _ self accessibleObjectAfter: thisObj.
	].
	^nilObj! !

!ObjectMemory methodsFor: 'object enumeration'!
instanceAfter: objectPointer
	"Support for instance enumeration. Return the next instance of the class of the given object, or nilObj if the enumeration is complete."

	| classPointer thisObj thisClass |
	classPointer _ (self fetchClassOf: objectPointer).
	thisObj _ self accessibleObjectAfter: objectPointer.
	[thisObj = nil] whileFalse: [
		thisClass _ self fetchClassOf: thisObj.
		thisClass = classPointer ifTrue: [ ^thisObj ].
		thisObj _ self accessibleObjectAfter: thisObj.
	].
	^nilObj! !

!ObjectMemory methodsFor: 'object enumeration' stamp: 'di 12/27/1998 23:17'!
lastPointerOf: oop
	"Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct."
	| fmt sz methodHeader header |
	self inline: true.
	header _ self baseHeader: oop.
	fmt _ (header >> 8) bitAnd: 16rF.
	fmt <= 4 ifTrue:
		[(fmt = 3 and: [self isContextHeader: header]) ifTrue:
			["contexts end at the stack pointer"
			^ (CtxtTempFrameStart + (self fetchStackPointerOf: oop)) * 4].
		sz _ self sizeBitsOfSafe: oop.
		^ sz - BaseHeaderSize  "all pointers"].
	fmt < 12 ifTrue: [ ^0 ].  "no pointers"

	"CompiledMethod: contains both pointers and bytes:"
	methodHeader _ self longAt: oop + BaseHeaderSize.
	^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! !

!ObjectMemory methodsFor: 'object enumeration' stamp: 'jm 11/25/1998 16:34'!
objectAfter: oop
	"Return the object or free chunk immediately following the given object or free chunk in memory. Return endOfMemory when enumeration is complete."

	| sz |
	self inline: true.
	DoAssertionChecks ifTrue: [
		oop >= endOfMemory ifTrue: [ self error: 'no objects after the end of memory' ].
	].

	(self isFreeObject: oop)
		ifTrue: [ sz _ self sizeOfFree: oop ]
		ifFalse: [ sz _ self sizeBitsOf: oop ].

	^ self oopFromChunk: (oop + sz)! !

!ObjectMemory methodsFor: 'object enumeration'!
startOfMemory
	"Return the start of object memory."

	^ self cCode: '(int) memory'! !


!ObjectMemory methodsFor: 'oop/chunk conversion'!
chunkFromOop: oop
	"Compute the chunk of this oop by subtracting its extra header bytes."

	| extra |
	extra _ self extraHeaderBytes: oop.
	^ oop - extra! !

!ObjectMemory methodsFor: 'oop/chunk conversion'!
extraHeaderBytes: oopOrChunk
	"Return the number of extra bytes used by the given object's header."
	"Warning: This method should not be used during marking, when the header type bits of an object may be incorrect."

	| type extra |
	self inline: true.
	type _ self headerType: oopOrChunk.
	type > 1 ifTrue: [
		extra _ 0.  "free chunk (type 2) or 1-word header (type 3); most common"
	] ifFalse: [
		type = 1
			ifTrue: [ extra _ 4.  "2-word header (type 1)" ]
			ifFalse: [ extra _ 8.  "3-word header (type 0)" ].
	].
	^ extra! !

!ObjectMemory methodsFor: 'oop/chunk conversion'!
oopFromChunk: chunk
	"Compute the oop of this chunk by adding its extra header bytes."

	| extra |
	extra _ self extraHeaderBytes: chunk.
	^ chunk + extra! !


!ObjectMemory methodsFor: 'allocation' stamp: 'jm 12/6/1998 17:12'!
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord
	"Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value."

	| newObj remappedClassOop end i |
	self inline: true.
	"remap classOop in case GC happens during allocation"
	hdrSize > 1 ifTrue: [ self pushRemappableOop: classOop ].
  	newObj _ self allocateChunk: byteSize + ((hdrSize - 1) * 4).
	hdrSize > 1 ifTrue: [ remappedClassOop _ self popRemappableOop ].

	hdrSize = 3 ifTrue: [
		self longAt: newObj      put: (extendedSize bitOr: HeaderTypeSizeAndClass).
		self longAt: newObj + 4 put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
		self longAt: newObj + 8 put: (baseHeader bitOr: HeaderTypeSizeAndClass).
		newObj _ newObj + 8.
	].
	hdrSize = 2 ifTrue: [
		self longAt: newObj      put: (remappedClassOop bitOr: HeaderTypeClass).
		self longAt: newObj + 4 put: (baseHeader bitOr: HeaderTypeClass).
		newObj _ newObj + 4.
	].
	hdrSize = 1 ifTrue: [
		self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort).
	].

	"clear new object"
	doFill ifTrue:
		[end _ newObj + byteSize.
		i _ newObj + 4.
		[i < end] whileTrue:
			[self longAt: i put: fillWord.
			i _ i + 4]].

	DoAssertionChecks ifTrue: [
		self okayOop: newObj.
		self oopHasOkayClass: newObj.
		(self objectAfter: newObj) = freeBlock
			ifFalse: [ self error: 'allocate bug: did not set header of new oop correctly' ].
		(self objectAfter: freeBlock) = endOfMemory
			ifFalse: [ self error: 'allocate bug: did not set header of freeBlock correctly' ].
	].

	^ newObj! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 19:36'!
allocateChunk: byteSize 
	"Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s)."
	"Details: To limit the time per incremental GC, do one every so many allocations."

	| enoughSpace newFreeSize newChunk |
	self inline: true.
	allocationCount >= allocationsBetweenGCs ifTrue: [
		"do an incremental GC every so many allocations to keep pauses short"
		self incrementalGC.
	].

	enoughSpace _ self sufficientSpaceToAllocate: byteSize.
	enoughSpace ifFalse: [
		"signal that space is running low, put proceed with allocation if possible"
		signalLowSpace _ true.
		lowSpaceThreshold _ 0.  "disable additional interrupts until lowSpaceThreshold is reset by image"
		interruptCheckCounter _ 0.
	].

	(self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ')
		< (self cCoerce: (byteSize + BaseHeaderSize) to: 'unsigned ') ifTrue: [
		self error: 'out of memory'.
	].

	"if we get here, there is enough space for allocation to succeed"
	newFreeSize _ (self sizeOfFree: freeBlock) - byteSize.
	newChunk _ freeBlock.
	freeBlock _ freeBlock + byteSize.
	"Assume: client will initialize object header of free chunk, so following is not needed:"
	"self setSizeOfFree: newChunk to: byteSize."
	self setSizeOfFree: freeBlock to: newFreeSize.
	allocationCount _ allocationCount + 1.

	^ newChunk! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 10/22/1999 11:52'!
allocateOrRecycleContext: needsLarge
	"Return a recycled context or a newly allocated one if none is available for recycling."
	| cntxt |
	needsLarge = 0
	ifTrue: [freeContexts ~= NilContext ifTrue:
				[cntxt _ freeContexts.
				freeContexts _ self fetchPointer: 0 ofObject: cntxt.
				^ cntxt]]
	ifFalse: [freeLargeContexts ~= NilContext ifTrue:
				[cntxt _ freeLargeContexts.
				freeLargeContexts _ self fetchPointer: 0 ofObject: cntxt.
				^ cntxt]].
	
	needsLarge = 0
		ifTrue: [cntxt _ self instantiateContext: (self splObj: ClassMethodContext)
				sizeInBytes: SmallContextSize]
		ifFalse: [cntxt _ self instantiateContext: (self splObj: ClassMethodContext)
				sizeInBytes: LargeContextSize].
	"Required init -- above does not fill w/nil.  All others get written."
	self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt
					withValue: nilObj.
	^ cntxt
! !

!ObjectMemory methodsFor: 'allocation'!
clone: oop
	"Return a shallow copy of the given object."
	"Assume: Oop is a real object, not a small integer."

	| extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
	self inline: false.
	extraHdrBytes _ self extraHeaderBytes: oop.
	bytes _ self sizeBitsOf: oop.
	bytes _ bytes + extraHdrBytes.

	"allocate space for the copy, remapping oop in case of a GC"
	self pushRemappableOop: oop.
	newChunk _ self allocateChunk: bytes.
	remappedOop _ self popRemappableOop.

	"copy old to new including all header words"
	toIndex _ newChunk - 4.  "loop below uses pre-increment"
	fromIndex _ (remappedOop - extraHdrBytes) - 4.
	lastFrom _ fromIndex + bytes.
	[fromIndex < lastFrom] whileTrue: [
		self longAt: (toIndex _ toIndex + 4)
			put: (self longAt: (fromIndex _ fromIndex + 4)).
	].
	newOop _ newChunk + extraHdrBytes.  "convert from chunk to oop"

	"fix base header: compute new hash and clear Mark and Root bits"
	hash _ self newObjectHash.
	header _ (self longAt: newOop) bitAnd: 16r1FFFF.
		"use old ccIndex, format, size, and header-type fields"
	header _ header bitOr: ((hash << 17) bitAnd: 16r1FFE0000).
	self longAt: newOop put: header.
	^ newOop
! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 10/22/1999 10:40'!
recycleContextIfPossible: cntxOop
	| header |
	"If possible, save the given context on a list of free contexts to be recycled."
	"Note: The context is not marked free, so it can be reused with minimal fuss.  The recycled context lists are cleared at every garbage collect."

	self inline: true.
	"only recycle young contexts (which should be most of them)"
	cntxOop >= youngStart ifTrue:
		[header _ self baseHeader: cntxOop.
		(self isMethodContextHeader: header) ifTrue:
			["It's a young context, alright."
			(header bitAnd: SizeMask) = SmallContextSize
				ifTrue:
				["Recycle small contexts"
				self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeContexts.
				freeContexts _ cntxOop].
			(header bitAnd: SizeMask) = LargeContextSize
				ifTrue:
				["Recycle large contexts"
				self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeLargeContexts.
				freeLargeContexts _ cntxOop]]]
! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 16:35'!
sufficientSpaceAfterGC: minFree
	"Return true if there is enough free space after doing a garbage collection. If not, signal that space is low."

	self inline: false.
	self incrementalGC.  "try to recover some space"
	(self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ')
		< (self cCoerce: minFree to: 'unsigned ')
		ifTrue:
		[signalLowSpace ifTrue: [ ^ false ].  "give up; problem is already noted"
		self fullGC.  "try harder"
		"for stability, require more free space after doing an expensive full GC"
		(self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ')
			< ((self cCoerce: minFree to: 'unsigned ') + 15000)
			ifTrue: [ ^ false ].  "still not enough"
	].
	^ true! !

!ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 19:30'!
sufficientSpaceToAllocate: bytes
	"Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection."

	| minFree |
	self inline: true.
	minFree _ lowSpaceThreshold + bytes + BaseHeaderSize.

	"check for low-space"
	(self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ')
		>= (self cCoerce: minFree to: 'unsigned ')
		ifTrue: [^ true]
		ifFalse: [^ self sufficientSpaceAfterGC: minFree].! !


!ObjectMemory methodsFor: 'garbage collection' stamp: 'di 2/26/1999 17:17'!
beRootIfOld: oop
	"If this object is old, mark it as a root (because a new object may be stored into it)"

	self inline: false.
	((oop < youngStart) and: [(self isIntegerObject: oop) not]) ifTrue:
		["Yes, oop is an old object"
		self noteAsRoot: oop headerLoc: oop].! !

!ObjectMemory methodsFor: 'garbage collection'!
clearRootsTable
	"Clear the root bits of the current roots, then empty the roots table."
	"Caution: This should only be done when the young object space is empty."

	| oop |
	"reset the roots table (after this, all objects are old so there are no roots)"
	1 to: rootTableCount do: [ :i |
		"clear root bits of current root table entries"
		oop _ rootTable at: i.
		self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit).
		rootTable at: i put: 0.
	].
	rootTableCount _ 0.! !

!ObjectMemory methodsFor: 'garbage collection'!
fullCompaction
	"Move all accessible objects down to leave one big free chunk at the end of memory."
	"Assume: Incremental GC has just been done to maximimize forwarding table space."

	"need not move objects below the first free chunk"
	compStart _ self lowestFreeAfter: (self startOfMemory).
	compStart = freeBlock ifTrue: [
		"memory is already compact; only free chunk is at the end"
		^ self initializeMemoryFirstFree: freeBlock
	].

	"work up through memory until all free space is at the end"
	[compStart < freeBlock] whileTrue: [
		"free chunk returned by incCompBody becomes start of next compaction"
		compStart _ self incCompBody.  "bubble of free space moves up each time"
	].! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 3/15/1999 22:51'!
fullGC
	"Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them."

	| startTime |
	self inline: false.
	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 0 to: 7].
	self preGCAction: true.
	startTime _ self ioMicroMSecs.
	self clearRootsTable.
	youngStart _ self startOfMemory.  "process all of memory"
	self markPhase.
	self sweepPhase.
	self fullCompaction.
	allocationCount _ 0.
	statFullGCs _ statFullGCs + 1.
	statFullGCMSecs _ statFullGCMSecs + (self ioMicroMSecs - startTime).

	youngStart _ freeBlock.  "reset the young object boundary"
	self postGCAction.
	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 0 to: 7].
! !

!ObjectMemory methodsFor: 'garbage collection'!
incrementalCompaction
	"Move objects down to make one big free chunk. Compact the last N objects (where N = number of forwarding table entries) of the young object area."
	"Assume: compStart was set during the sweep phase"

	compStart = freeBlock ifTrue: [
		"Note: If compStart = freeBlock then either the young space is already compact
		 or there are enough forwarding table entries to do a one-pass incr. compaction."

		self initializeMemoryFirstFree: freeBlock.
	] ifFalse: [
		self incCompBody.
	].
! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 3/9/1999 11:07'!
incrementalGC
	"Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area."

	| survivorCount startTime |
	self inline: false.
	rootTableCount >= RootTableSize ifTrue: [
		"root table overflow; cannot do an incremental GC (this should be very rare)"
		statRootTableOverflows _ statRootTableOverflows + 1.
		^ self fullGC].

	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 8 to: 15].
	DoAssertionChecks ifTrue: [self validateRoots].
	self preGCAction: false.
	"incremental GC and compaction"
	startTime _ self ioMicroMSecs.
	self markPhase.
	survivorCount _ self sweepPhase.
	self incrementalCompaction.
	allocationCount _ 0.
	statIncrGCs _ statIncrGCs + 1.
	statIncrGCMSecs _ statIncrGCMSecs + (self ioMicroMSecs - startTime).

	survivorCount > tenuringThreshold ifTrue: [
		"move up the young space boundary if there are too many survivors;
		 this limits the number of objects that must be processed on future
		 incremental GC's"

		statTenures _ statTenures + 1.
		self clearRootsTable.
		youngStart _ freeBlock.  "reset the young object boundary"
	].
	self postGCAction.
	DoAssertionChecks ifTrue: [self reverseDisplayFrom: 8 to: 15].
! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'go 11/17/1998 15:56'!
lowestFreeAfter: chunk
	"Return the first free block after the given chunk in memory."

	| oop oopHeader oopHeaderType oopSize |
	self inline: false.
	oop _ self oopFromChunk: chunk.
	[oop < endOfMemory] whileTrue: [
		oopHeader _ self baseHeader: oop.
		oopHeaderType _ oopHeader bitAnd: TypeMask.
		(oopHeaderType = HeaderTypeFree)
			ifTrue: [ ^ oop ]
			ifFalse: [
				oopHeaderType = HeaderTypeSizeAndClass
					ifTrue: [ oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
					ifFalse: [ oopSize _ oopHeader bitAnd: SizeMask ].
			].
		oop _ self oopFromChunk: (oop + oopSize).
	].
	self error: 'expected to find at least one free object'.
! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'di 2/26/1999 17:16'!
noteAsRoot: oop headerLoc: headerLoc
	"Record that the given oop in the old object area points to an object in the young area.
	HeaderLoc is usually = oop, but may be an addr in a forwarding block."

	| header |
	self inline: true.
	header _ self longAt: headerLoc.
	(header bitAnd: RootBit) = 0 ifTrue:
		["record oop as root only if not already recorded"
		rootTableCount < RootTableSize ifTrue:
			["record root only if there is room in the roots table"
			rootTableCount _ rootTableCount + 1.
			rootTable at: rootTableCount put: oop.
			self longAt: headerLoc put: (header bitOr: RootBit)]].
! !

!ObjectMemory methodsFor: 'garbage collection' stamp: 'di 2/26/1999 17:17'!
possibleRootStoreInto: oop value: valueObj
	"oop is an old object.  If valueObj is young, mark the object as a root."

	self inline: false.
	((valueObj >= youngStart) and: [(self isIntegerObject: valueObj) not]) ifTrue:
		["Yes, valueObj is a young object"
		self noteAsRoot: oop headerLoc: oop].! !


!ObjectMemory methodsFor: 'gc -- mark and sweep'!
aComment
	"The mark phase is based on a pointer reversing traversal. This is a little tricky because the class, which is needed by the traversal, may be in either the header (as a compact class index) or in the word above the header. See memo 'Revised object format'.
	Compact classes are marked and traced separately.
	How do you know that you are returning from having marked a class? Parent pointer has 10 in low bits.

Here are the states an object may be in, followed by what to do next in brackets []:

  Start Object: parentField is set, [obj _ child]:
	obj is pointed at by a field in parent that is being traced now. obj is marked.
		[(parent goes up to the next field) field addr _ obj. go to Upward]
	obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has no pointers.
		[put 10 into low bits of header. field addr _ obj. go to Start Field (to process class word)]
	obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has pointers.
		[put 10 into low bits of header. point to last field. go to Start Field]

  Start Field: 
	Field ends in 10. It is the header. Short Class is not 0.
		[Set low bits to correct value. (have parent pointer) go to Upward]
	Field ends in 10. It is the header. Short Class is 0.
		[child _ word above header. low bits of child _ 01. class word _ parentField. parentField _ loc of class word. go to Start Obj]
	Field is Integer.
		[point one word up, go to Start Field]
	Field is oop.
		[child _ field. field _ parentField. parentField _ loc of field. go to Start Obj]

  Upward [restore low bits of header (at field addr)]:
	parentField is 3. (bits 11, int 1).
		[done!!]
	parentField ends in 00.
		[child _ field addr. field addr _ parentField. parentField _ field addr contents.
		field addr contents _ child (addr of prev object. its oop). field addr - 4. go to Start Field]
	parentField ends in 01. Were tracing the class.
		[child _ field addr. field addr _ parentField (loc of class word). parentField _ field addr contents.
		field addr contents _ child (addr of prev object. its oop). field addr + 4 (header). go to Upward]
"! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 10/6/1999 10:02'!
markAndTrace: oop
	"Mark all objects reachable from the given one.
	Trace from the given object even if it is old.
	Do not trace if it is already marked.
	Mark it only if it is a young object."
	"Tracer state variables:
		child		object being examined
		field		next field of child to examine
		parentField	field where child was stored in its referencing object"

	| header lastFieldOffset action |
	header _ self longAt: oop.
	(header bitAnd: MarkBit) = 0 ifFalse: [^ 0  "already marked"].

	"record tracing status in object's header"
	header _ (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC.
	oop >= youngStart ifTrue: [ header _ header bitOr: MarkBit ].  "mark only if young"
	self longAt: oop put: header.

	"initialize the tracer state machine"
	parentField _ GCTopMarker.
	child _ oop.
	lastFieldOffset _ self lastPointerOf: oop.
	field _ oop + lastFieldOffset.
	action _ StartField.

	"run the tracer state machine until all objects reachable from oop are marked"
	[action = Done] whileFalse: [
		action = StartField	ifTrue: [ action _ self startField ].
		action = StartObj		ifTrue: [ action _ self startObj ].
		action = Upward		ifTrue: [ action _ self upward ].
	].! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 10/22/1999 10:44'!
markPhase
	"Mark phase of the mark and sweep garbage collector. Set the mark bits of all reachable objects. Free chunks are untouched by this process."
	"Assume: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots. (Make sure this stays true!!!!)."

	| oop |
	self inline: false.
	"clear the recycled context lists"
	freeContexts _ NilContext.
	freeLargeContexts _ NilContext.

	"trace the interpreter's objects, including the active stack and special objects array"
	self markAndTraceInterpreterOops.

	"trace the roots"
	1 to: rootTableCount do: [ :i | 
		oop _ rootTable at: i.
		self markAndTrace: oop.
	].
! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 3/28/1999 14:28'!
startField
	"Examine and possibly trace the next field of the object being traced. See comment in markAndTrace for explanation of tracer state variables."

	| typeBits childType |
	self inline: true.

	child _ self longAt: field.
	typeBits _ child bitAnd: TypeMask.

	(typeBits bitAnd: 1) = 1 ifTrue: [
		"field contains a SmallInteger; skip it"
		field _ field - 4.
		^ StartField
	].

	typeBits = 0 ifTrue: [
		"normal oop, go down"
		self longAt: field put: parentField.
		parentField _ field.
		^ StartObj
	].

	typeBits = 2 ifTrue: [
		"reached the header; do we need to process the class word?"
		(child bitAnd: CompactClassMask) ~= 0 ifTrue: [
			"object's class is compact; we're done"
			"restore the header type bits"
			child _ child bitAnd: AllButTypeMask.
			childType _ self rightType: child.
			self longAt: field put: (child bitOr: childType).
			^ Upward
		] ifFalse: [
			"object has a full class word; process that class"
			child _ self longAt: (field - 4).  "class word"
			child _ child bitAnd: AllButTypeMask.  "clear type bits"
			self longAt: (field - 4) put: parentField.
			parentField _ (field - 4) bitOr: 1.  "point at class word; mark as working on the class."
			^ StartObj
		].
	].! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 3/28/1999 14:27'!
startObj
	"Start tracing the object 'child' and answer the next action. The object may be anywhere in the middle of being swept itself. See comment in markAndTrace for explanation of tracer state variables."

	| oop header lastFieldOffset |
	self inline: true.

	oop _ child.
	oop < youngStart ifTrue: [
		"old object; skip it"
		 field _ oop.
		^ Upward
	].

	header _ self longAt: oop.
	(header bitAnd: MarkBit) = 0 ifTrue: [
		"unmarked; mark and trace"
		"<-- Finalization support: Do not trace the object's indexed fields if it's a weak class -->"
		(self isWeak: oop) ifTrue:[
			"Set lastFieldOffset before the weak fields in the receiver"
			lastFieldOffset := (self nonWeakFieldsOf: oop) << 2.
		] ifFalse:[
			"Do it the usual way"
			lastFieldOffset _ self lastPointerOf: oop.
		].
		header _ header bitAnd: AllButTypeMask.
		header _ (header bitOr: MarkBit) bitOr: HeaderTypeGC.
		self longAt: oop put: header.
		field _ oop + lastFieldOffset.
		^ StartField	"trace its fields and class"
	] ifFalse: [
		"already marked; skip it"
		field _ oop.
		^ Upward
	].! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 1/12/1999 12:25'!
sweepPhase
	"Sweep memory from youngStart through the end of memory. Free all inaccessible objects and coalesce adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects."
	"Details: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accomodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk--the one at the end of the heap."

	| entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize |
	self inline: false.
	entriesAvailable _ self fwdTableInit: 8.  "Two-word blocks"
.
	survivors _ 0.
	freeChunk _ nil.
	firstFree _ nil.  "will be updated later"
	oop _ self oopFromChunk: youngStart.
	[oop < endOfMemory] whileTrue: [
		"get oop's header, header type, size, and header size"
		oopHeader _ self baseHeader: oop.
		oopHeaderType _ oopHeader bitAnd: TypeMask.
		(oopHeaderType = HeaderTypeShort) ifTrue: [
			oopSize _ oopHeader bitAnd: SizeMask.
			hdrBytes _ 0.
		] ifFalse: [
			(oopHeaderType = HeaderTypeClass) ifTrue: [
				oopSize _ oopHeader bitAnd: SizeMask.
				hdrBytes _ 4.
			] ifFalse: [
				(oopHeaderType = HeaderTypeSizeAndClass) ifTrue: [
					oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask.
					hdrBytes _ 8.
				] ifFalse: [  "free chunk"
					oopSize _ oopHeader bitAnd: AllButTypeMask.
					hdrBytes _ 0.
				].
			].
		].

		(oopHeader bitAnd: MarkBit) = 0 ifTrue: ["object is not marked; free it"
			"<-- Finalization support: We need to mark each oop chunk as free -->"
			self longAt: oop - hdrBytes put: HeaderTypeFree.
			freeChunk ~= nil ifTrue: [
				"enlarge current free chunk to include this oop"
				freeChunkSize _ freeChunkSize + oopSize + hdrBytes.
			] ifFalse: [
				"start a new free chunk"
				freeChunk _ oop - hdrBytes.  "chunk may start 4 or 8 bytes before oop"
				freeChunkSize _ oopSize + (oop - freeChunk).  "adjust size for possible extra header bytes"
				firstFree = nil ifTrue: [ firstFree _ freeChunk ].
			].
		] ifFalse: [
			"object is marked; clear its mark bit and possibly adjust the compaction start"
			self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
			"<-- Finalization support: Check if we're running about a weak class -->"
			(self isWeak: oop) ifTrue:[
				self finalizeReference: oop.
			].
			entriesAvailable > 0 ifTrue: [
				entriesAvailable _ entriesAvailable - 1.
			] ifFalse: [
				"start compaction at the last free chunk before this object"
				firstFree _ freeChunk.
			].
			freeChunk ~= nil ifTrue: [
				"record the size of the last free chunk"
				self longAt: freeChunk
					    put: ((freeChunkSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).
			].
			freeChunk _ nil.
			survivors _ survivors + 1.
		].
		oop _ self oopFromChunk: (oop + oopSize).  "get next oop"
	].

	freeChunk ~= nil ifTrue: [
		"record size of final free chunk"
		self longAt: freeChunk
			    put: ((freeChunkSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).
	].

	oop = endOfMemory
		ifFalse: [ self error: 'sweep failed to find exact end of memory' ].

	firstFree = nil
		ifTrue: [ self error: 'expected to find at least one free object' ]
		ifFalse: [ compStart _ firstFree ].

	displayBits = 0 ifFalse: [
		"TPR: clear mark bit of Acorn's displayBits object, which may lie outside object space"
		oopHeader _ self baseHeader: displayBits.
		self longAt: displayBits put: (oopHeader bitAnd: AllButMarkBit)].	

	^ survivors
! !

!ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 3/28/1999 14:28'!
upward
	"Return from marking an object below. Incoming:
		field = oop we just worked on, needs to be put away
		parentField = where to put it in our object
	NOTE: Type field of object below has already been restored!!!!!!"

	| type header |
	self inline: true.

	(parentField bitAnd: 1) = 1 ifTrue: [
		parentField = GCTopMarker ifTrue: [
			"top of the chain"
			header _ (self longAt: field) bitAnd: AllButTypeMask.
			type _ self rightType: header.
			self longAt: field put: header + type.  "install type on class oop"
			^ Done
		] ifFalse: [
			"was working on the extended class word"
			child _ field.	"oop of class"
			field _ parentField - 1.  "class word, ** clear the low bit **"
			parentField _ self longAt: field.
			header _ self longAt: field+4.  "base header word"
			type _ self rightType: header.
			self longAt: field put: child + type.  "install type on class oop"
			field _ field + 4.  "point at header"
			"restore type bits"
			header _ header bitAnd: AllButTypeMask.
			self longAt: field put: (header + type).
			^ Upward
		].
	] ifFalse: [
		"normal"
		child _ field.  "who we worked on below"
		field _ parentField.  "where to put it"
		parentField _ self longAt: field.
		self longAt: field put: child.
		field _ field - 4.  "point at header"
		^ StartField
	].! !


!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 2/26/1999 17:22'!
beRootWhileForwarding: oop
	"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
	"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."

	| header fwdBlock |
	header _ self longAt: oop.
	(header bitAnd: MarkBit) ~= 0
		ifTrue: ["This oop is forwarded"
				fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
				DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
				self noteAsRoot: oop headerLoc: fwdBlock + 4]
		ifFalse: ["Normal -- no forwarding"
				self noteAsRoot: oop headerLoc: oop]! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 14:09'!
fwdBlockGet: blkSize
	"Return the address of a two- or four-word forwarding block or nil if no more entries are available."

	fwdTableNext _ fwdTableNext + blkSize.
	fwdTableNext <= fwdTableLast
		ifTrue: [ ^ fwdTableNext ]
		ifFalse: [ ^ nil ].  "no more forwarding blocks available"! !

!ObjectMemory methodsFor: 'gc -- compaction'!
fwdBlockValidate: addr
	"Raise an error if the given address is not a valid forward table entry."

	(( addr > endOfMemory) and:
	 [(addr <= fwdTableNext) and:
	 [(addr bitAnd: 3) = 0]])
		ifFalse: [ self error: 'invalid fwd table entry' ].! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 1/13/1999 10:55'!
fwdTableInit: blkSize
	"Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."

	self inline: false.
	"set endOfMemory to just after a minimum-sized free block"
	self setSizeOfFree: freeBlock to: BaseHeaderSize.
	endOfMemory _ freeBlock + BaseHeaderSize.

	"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
	self setSizeOfFree: endOfMemory to: BaseHeaderSize.

	"use all memory free between freeBlock and memoryLimit for forwarding table"
	"Note: Forward blocks must be quadword aligned."
	fwdTableNext _ (endOfMemory + BaseHeaderSize + 7) bitAnd: 16rFFFFFFF8.
	fwdTableLast _ memoryLimit - blkSize.  "last forwarding table entry"

	"return the number of forwarding blocks available"
	^ (fwdTableLast - fwdTableNext) // blkSize  "round down"! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 12:25'!
incCompBody
	"Move objects to consolidate free space into one big chunk. Return the newly created free chunk."

	| bytesFreed |
	self inline: false.
	"reserve memory for forwarding table"
	self fwdTableInit: 8.  "Two-word blocks"

	"assign new oop locations, reverse their headers, and initialize forwarding blocks"
	bytesFreed _ self incCompMakeFwd.

	"update pointers to point at new oops"
	self mapPointersInObjectsFrom: youngStart to: endOfMemory.

	"move the objects and restore their original headers; return the new free chunk"
	^ self incCompMove: bytesFreed! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 12:32'!
incCompMakeFwd
	"Create and initialize forwarding blocks for all non-free objects following compStart. If the supply of forwarding blocks is exhausted, set compEnd to the first chunk above the area to be compacted; otherwise, set it to endOfMemory. Return the number of bytes to be freed."

	| bytesFreed oop fwdBlock newOop |
	bytesFreed _ 0.
	oop _ self oopFromChunk: compStart.
	[oop < endOfMemory] whileTrue: [
		(self isFreeObject: oop) ifTrue: [
			bytesFreed _ bytesFreed + (self sizeOfFree: oop).
		] ifFalse: [
			"create a forwarding block for oop"
			fwdBlock _ self fwdBlockGet: 8.  "Two-word block"
			fwdBlock = nil ifTrue: [
				"stop; we have used all available forwarding blocks"
				compEnd _ self chunkFromOop: oop.
				^ bytesFreed
			].

			newOop _ oop - bytesFreed.
			self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false.
		].
		oop _ self objectAfterWhileForwarding: oop.
	].
	compEnd _ endOfMemory.
	^ bytesFreed! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 19:45'!
incCompMove: bytesFreed
	"Move all non-free objects between compStart and compEnd to their new locations, restoring their headers in the process. Create a new free block at the end of memory. Return the newly created free chunk."
	"Note: The free block used by the allocator always must be the last free block in memory. It may take several compaction passes to make all free space bubble up to the end of memory."

	| oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz |
	newOop _ nil.
	oop _ self oopFromChunk: compStart.
	[oop < compEnd] whileTrue: [
		next _ self objectAfterWhileForwarding: oop.
		(self isFreeObject: oop) ifFalse: [
			"a moving object; unwind its forwarding block"
			fwdBlock _ ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1.
			DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
			newOop _ self longAt: fwdBlock.
			header _ self longAt: fwdBlock + 4.
			self longAt: oop put: header.  "restore the original header"
			bytesToMove _ oop - newOop.

			"move the oop (including any extra header words)"
			sz _ self sizeBitsOf: oop.
			firstWord _ oop - (self extraHeaderBytes: oop).
			lastWord _ (oop + sz) - BaseHeaderSize.
			firstWord to: lastWord by: 4 do: [ :w |
				self longAt: (w - bytesToMove) put: (self longAt: w).
			].
		].
		oop _ next.
	].

	newOop = nil ifTrue: [
		"no objects moved"
		oop _ self oopFromChunk: compStart.
		((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
			ifTrue: [ newFreeChunk _ oop ]
			ifFalse: [ newFreeChunk _ freeBlock ].
	] ifFalse: [
		"initialize the newly freed memory chunk"
		"newOop is the last object moved; free chunk starts right after it"
		newFreeChunk _ newOop + (self sizeBitsOf: newOop).
		self setSizeOfFree: newFreeChunk to: bytesFreed.
	].

	DoAssertionChecks ifTrue: [
		(self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd)
			ifFalse: [ self error: 'problem creating free chunk after compaction' ].
	].

	(self objectAfter: newFreeChunk) = endOfMemory ifTrue: [
		self initializeMemoryFirstFree: newFreeChunk.
	] ifFalse: [
		"newFreeChunk is not at end of memory; re-install freeBlock"
		self initializeMemoryFirstFree: freeBlock.
	].

	^ newFreeChunk! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 14:08'!
initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag
	"Initialize the given forwarding block to map oop to newOop, and replace oop's header with a pointer to the fowarding block."
	"Details: The mark bit is used to indicate that an oop is forwarded. When an oop is forwarded, its header (minus the mark bit) contains the address of its forwarding block. (The forwarding block address is actually shifted right by one bit so that its top-most bit does not conflict with the header's mark bit; since fowarding blocks are stored on word boundaries, the low two bits of the address are always zero.) The first word of the forwarding block is the new oop; the second word is the oop's orginal header. In the case of a forward become, a four-word block is used, with the third field being a backpointer to the old oop (for header fixup), and the fourth word is unused.  The type bits of the forwarding header are the same as those of the original header."

	| originalHeader originalHeaderType |
	self inline: true.
	originalHeader _ self longAt: oop.
	DoAssertionChecks ifTrue: [
		fwdBlock = nil
			ifTrue: [ self error: 'ran out of forwarding blocks in become' ].
		(originalHeader bitAnd: MarkBit) ~= 0
			ifTrue: [ self error: 'object already has a forwarding table entry' ].
	].

	originalHeaderType _ originalHeader bitAnd: TypeMask.
	self longAt: fwdBlock put: newOop.
	self longAt: fwdBlock + 4 put: originalHeader.
	backFlag ifTrue:
		[self longAt: fwdBlock + 8 put: oop].
	self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType)).
! !

!ObjectMemory methodsFor: 'gc -- compaction'!
isObjectForwarded: oop
	"Return true if the given object has a forwarding table entry during a compaction or become operation."

	^ (oop bitAnd: 1) = 0 "(isIntegerObject: oop) not" and:
	   [ ((self longAt: oop) bitAnd: MarkBit) ~= 0 ]! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 12/27/1998 23:18'!
lastPointerWhileForwarding: oop
	"The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle."

	| header fwdBlock fmt size methodHeader |
	self inline: true.
	header _ self longAt: oop.
	(header bitAnd: MarkBit) ~= 0 ifTrue: [
		"oop is forwarded; get its real header from its forwarding table entry"
		fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
		DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
		header _ self longAt: fwdBlock + 4.
	].

	fmt _ (header >> 8) bitAnd: 16rF.
	fmt <= 4 ifTrue:
		[(fmt = 3 and: [self isContextHeader: header]) ifTrue:
			["contexts end at the stack pointer"
			^ (CtxtTempFrameStart + (self fetchStackPointerOf: oop)) * 4].
		"do sizeBitsOf: using the header we obtained"
		(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
			ifTrue: [ size _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
			ifFalse: [ size _ header bitAnd: SizeMask ].
		^ size - BaseHeaderSize].
	fmt < 12 ifTrue: [ ^ 0 ].  "no pointers"

	methodHeader _ self longAt: oop + BaseHeaderSize.
	^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'ikp 12/18/1998 22:49'!
mapPointersInObjectsFrom: memStart to: memEnd
	"Use the forwarding table to update the pointers of all non-free objects in the given range of memory. Also remap pointers in root objects which may contains pointers into the given memory range."

	| oop |
	self inline: false.
	self compilerMapHookFrom: memStart to: memEnd.
	"update interpreter variables"
	self mapInterpreterOops.

	"update pointers in root objects"
	1 to: rootTableCount do: [ :i | 
		oop _ rootTable at: i.
		((oop < memStart) or: [oop >= memEnd]) ifTrue: [
			"Note: must not remap the fields of any object twice!!"
			"remap this oop only if not in the memory range covered below"
			self remapFieldsAndClassOf: oop.
		].
	].

	"update pointers in the given memory range"
	oop _ self oopFromChunk: memStart.
	[oop < memEnd] whileTrue: [
		(self isFreeObject: oop) ifFalse: [
			self remapFieldsAndClassOf: oop.
		].
		oop _ self objectAfterWhileForwarding: oop.
	].! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 19:59'!
objectAfterWhileForwarding: oop
	"Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."

	| header fwdBlock realHeader sz |
	self inline: true.
	header _ self longAt: oop.
	(header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ].  "oop not forwarded"

	"Assume: mark bit cannot be set on a free chunk, so if we get here,
	 oop is not free and it has a forwarding table entry"

	fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1.
	DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
	realHeader _ self longAt: fwdBlock + 4.
	"following code is like sizeBitsOf:"
	(realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass
		ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
		ifFalse: [ sz _ realHeader bitAnd: SizeMask ].

	^ self oopFromChunk: (oop + sz)! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:00'!
remap: oop
	"Map the given oop to its new value during a compaction or become: operation. If it has no forwarding table entry, return the oop itself."

	| fwdBlock |
	self inline: false.
	(self isObjectForwarded: oop) ifTrue: [
		"get the new value for oop from its forwarding block"
		fwdBlock _ ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1.
		DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
		^ self longAt: fwdBlock
	].
	^ oop! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:00'!
remapClassOf: oop
	"Update the class of the given object, if necessary, using its forwarding table entry."
	"Note: Compact classes need not be remapped since the compact class field is just an index into the compact class table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."

	| classHeader classOop fwdBlock newClassOop newClassHeader |
	(self headerType: oop) = HeaderTypeShort ifTrue: [ ^nil ].  "compact classes needn't be mapped"

	classHeader _ self longAt: (oop - 4).
	classOop _ classHeader bitAnd: AllButTypeMask.
	(self isObjectForwarded: classOop) ifTrue: [
		fwdBlock _ ((self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
		DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
		newClassOop _ self longAt: fwdBlock.
		newClassHeader _ newClassOop bitOr: (classHeader bitAnd: TypeMask).
		self longAt: (oop - 4) put: newClassHeader.

		"The following ensures that become: into an old object's class makes it a root.
		  It does nothing during either incremental or full compaction because
		  oop will never be < youngStart."
		((oop < youngStart) and: [newClassOop >= youngStart])
			ifTrue: [ self beRootWhileForwarding: oop ].
	].! !

!ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:01'!
remapFieldsAndClassOf: oop
	"Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if necessary."
	"Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."

	| fieldOffset fieldOop fwdBlock newOop |
	self inline: true.
	fieldOffset _ self lastPointerWhileForwarding: oop.
	[fieldOffset >= BaseHeaderSize] whileTrue: [
		fieldOop _ self longAt: (oop + fieldOffset).
		(self isObjectForwarded: fieldOop) ifTrue: [
			"update this oop from its forwarding block"
			fwdBlock _ ((self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask) << 1.
			DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ].
			newOop _ self longAt: fwdBlock.
			self longAt: (oop + fieldOffset) put: newOop.

			"The following ensures that become: into old object makes it a root.
			  It does nothing during either incremental or full compaction because
			  oop will never be < youngStart."
			((oop < youngStart) and: [newOop >= youngStart])
				ifTrue: [ self beRootWhileForwarding: oop ].
		].
		fieldOffset _ fieldOffset - 4.
	].
	self remapClassOf: oop.! !


!ObjectMemory methodsFor: 'become'!
allYoung: array1 and: array2
	"Return true if all the oops in both arrays, and the arrays themselves, are in the young object space."

	| fieldOffset |
	array1 < youngStart ifTrue: [ ^ false ].
	array2 < youngStart ifTrue: [ ^ false ].
	fieldOffset _ self lastPointerOf: array1.  "same size as array2"
	[fieldOffset >= BaseHeaderSize] whileTrue: [
		(self longAt: array1 + fieldOffset) < youngStart ifTrue: [ ^ false ].
		(self longAt: array2 + fieldOffset) < youngStart ifTrue: [ ^ false ].
		fieldOffset _ fieldOffset - 4.
	].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'di 1/9/1999 17:12'!
become: array1 with: array2
	^ self become: array1 with: array2 twoWay: true! !

!ObjectMemory methodsFor: 'become' stamp: 'di 1/12/1999 14:17'!
become: array1 with: array2 twoWay: twoWayFlag
	"All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. Returns true if the primitive succeeds."
	"Implementation: Uses forwarding blocks to update references as done in compaction."

	(self fetchClassOf: array1) = (self splObj: ClassArray) ifFalse: [ ^ false ].
	(self fetchClassOf: array2) = (self splObj: ClassArray) ifFalse: [ ^ false ].
	(self lastPointerOf: array1) = (self lastPointerOf: array2) ifFalse: [ ^ false ].
	(self containOnlyOops: array1 and: array2) ifFalse: [ ^ false ].

	(self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag)
		ifFalse: [^ false].  "fail; not enough space for forwarding table"

	(self allYoung: array1 and: array2) ifTrue: [
		"sweep only the young objects plus the roots"
		self mapPointersInObjectsFrom: youngStart to: endOfMemory.
	] ifFalse: [
		"sweep all objects"
		self mapPointersInObjectsFrom: (self startOfMemory) to: endOfMemory.
	].

	twoWayFlag
		ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2]
		ifFalse: [self restoreHeadersAfterForwardBecome].
	self initializeMemoryFirstFree: freeBlock.  "re-initialize memory used for forwarding table"

	^ true  "success"! !

!ObjectMemory methodsFor: 'become'!
containOnlyOops: array1 and: array2
	"Return true if neither array contains a small integer. You can't become: integers!!"

	| fieldOffset |
	fieldOffset _ self lastPointerOf: array1.  "same size as array2"
	[fieldOffset >= BaseHeaderSize] whileTrue: [
		(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [ ^ false ].
		(self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [ ^ false ].
		fieldOffset _ fieldOffset - 4.
	].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'jm 1/13/1999 10:56'!
prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag
	"Ensure that there are enough forwarding blocks to accomodate this become, then prepare forwarding blocks for the pointer swap. Return true if successful."
	"Details: Doing a GC might generate enough space for forwarding blocks if we're short. However, this is an uncommon enough case that it is better handled by primitive fail code at the Smalltalk level."

	| entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
	entriesNeeded _ (self lastPointerOf: array1) // 4.  "need enough entries for all oops"
	twoWayFlag
		ifTrue: ["Double the number of blocks for two-way become"
				entriesNeeded _ entriesNeeded * 2.
				fwdBlkSize _ 8  "Note: Forward blocks must be quadword aligned."]
		ifFalse: ["One-way become needs backPointers in fwd blocks."
				fwdBlkSize _ 16  "Note: Forward blocks must be quadword aligned."].
	entriesAvailable _ self fwdTableInit: fwdBlkSize.
	entriesAvailable < entriesNeeded ifTrue: 
		[self initializeMemoryFirstFree: freeBlock.  "re-initialize the free block"
		^ false].

	fieldOffset _ self lastPointerOf: array1.
	[fieldOffset >= BaseHeaderSize] whileTrue: 
		[oop1 _ self longAt: array1 + fieldOffset.
		oop2 _ self longAt: array2 + fieldOffset.
		fwdBlock _ self fwdBlockGet: fwdBlkSize.
		self initForwardBlock: fwdBlock mapping: oop1 to: oop2 withBackPtr: twoWayFlag not.
		twoWayFlag ifTrue:
			["Second block maps oop2 back to oop1 for two-way become"
			fwdBlock _ self fwdBlockGet: fwdBlkSize.
			self initForwardBlock: fwdBlock mapping: oop2 to: oop1 withBackPtr: twoWayFlag not].
		fieldOffset _ fieldOffset - 4].
	^ true! !

!ObjectMemory methodsFor: 'become' stamp: 'jm 11/25/1998 19:41'!
restoreHeaderOf: oop
	"Restore the original header of the given oop from its forwarding block."

	| fwdHeader fwdBlock |
	fwdHeader _ self longAt: oop.
	fwdBlock _ (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1.

	DoAssertionChecks ifTrue: [
		(fwdHeader bitAnd: MarkBit) = 0 ifTrue: [
			self error: 'attempting to restore the header of an object that has no forwarding block'.
		].
		self fwdBlockValidate: fwdBlock.
	].

	self longAt: oop put: (self longAt: fwdBlock + 4).  "restore orginal header"! !

!ObjectMemory methodsFor: 'become' stamp: 'di 3/28/1999 08:03'!
restoreHeadersAfterBecoming: list1 with: list2
	"Restore the headers of all oops in both lists. Exchange their hash bits so becoming objects in identity sets and dictionaries doesn't change their hash value."

	| fieldOffset oop1 oop2 hdr1 hdr2 |
	fieldOffset _ self lastPointerOf: list1.
	[fieldOffset >= BaseHeaderSize] whileTrue: [
		oop1 _ self longAt: list1 + fieldOffset.
		oop2 _ self longAt: list2 + fieldOffset.
		self restoreHeaderOf: oop1.
		self restoreHeaderOf: oop2.
		"Exchange has bits of the two objects."
		hdr1 _ self longAt: oop1.
		hdr2 _ self longAt: oop2.
		self longAt: oop1 put:
			((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
		self longAt: oop2 put:
			((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits)).
		fieldOffset _ fieldOffset - 4.
	].! !

!ObjectMemory methodsFor: 'become' stamp: 'di 3/28/1999 08:23'!
restoreHeadersAfterForwardBecome
	"Forward become leaves us with no original oops in the mutated object list,
	so we must enumerate the (four-word) forwarding blocks
	where we have stored backpointers."

	| oop1 fwdBlock oop2 hdr1 hdr2 |
	"This loop start is copied from fwdBlockGet:"
	fwdBlock _ (endOfMemory + BaseHeaderSize + 7) bitAnd: 16rFFFFFFF8.
	fwdBlock _ fwdBlock + 16.  "fwdBlockGet: did a pre-increment"
	[fwdBlock <= fwdTableNext]  "fwdTableNext points to the last active block"
		whileTrue:
		[oop1 _ self longAt: fwdBlock + 8.  "Backpointer to mutated object."
		oop2 _ self longAt: fwdBlock.
		self restoreHeaderOf: oop1.
		"Change the hash of the new oop (oop2) to be that of the old (oop1)
		so mutated objects in hash structures will be happy after the change."
		hdr1 _ self longAt: oop1.
		hdr2 _ self longAt: oop2.
		self longAt: oop2 put:
			((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits)).
		fwdBlock _ fwdBlock + 16].! !


!ObjectMemory methodsFor: 'finalization' stamp: 'ar 3/21/98 23:14'!
aFinalizationComment
	"This finalization scheme assumes to have weak classes in which the fields are not traced during the mark phase of a GC. This means, if an object is referenced only by any instances of weak classes it can be collected. In turn, we need to find out if an object referenced by a weak class is actually being collected because we have to invalidate the weak object pointer and to signal that the object has gone.
	How do we know that an object referenced by a weak class is being collected? Well,  this is based on two observations. First, objects will not change their relative locations in memory, meaning that if object A is created BEFORE object B it will always have a physical memory address which is LESS than B. Secondly, GC always works from a given starting address (youngStart during incremental GC; startOfMemory during fullGC) up to end of memory. If we can somehow garantuee that the weak reference is created after the object it points to we can easily implement the following simple scheme:
	1) Mark phase
		Do not trace the fields of any instances of weak classes.
	2) Sweep phase:
		a) Explicitly mark all free objects.
		b) 	If a weak reference is encountered check the the object it points to. 
			If the object is marked as free than we know that this weak reference's object is gone.
			Signal that it is gone.

	There is, however, one small problem with this approach. We cannot always garantuee that WeakReferences point backwards such as in the following piece of code:
		| o1 o2 w1 w2 |
		o1 _ Object new.
		w1 _ WeakReference on: o1.
		o2 _ Object new.
		w2 _ WeakReference on: o2.
		o1 become: o2.
The become: operation makes w1 point to o2 and because o2 has been created AFTER w1 the object reference in w1 points forward. Why might this be a problem? Well, if the GC would start after the weak reference AND free the object then the weak reference would simply point to an invalid memory location (since we've not been checking the weak reference during sweep phase).

	Fortunately, this can not happen in the current ObjectMemory implementation. Why? Well, the only GC not starting at the beginning of the memory is incremental GC. Incremental GC however is only executed in so-called youngSpace. If both, the weak reference AND the object it points to reside in youngSpace then we can still check the weak reference. If however, the weak reference is not in youngSpace but the object is, then the object is itself a root in young space and will be marked by the GC even if it is only referenced by the WeakReference.

	In the end, we just need a little adjustment in step 2b) of the above procedure which looks as follows:
		If the weak reference points 
			* backwards: check if the object header is marked free
			* forwards: check if the object has been marked in markPhase.

	Note that a number of finalizations will only be executed during a fullGC. This happens if either the WeakReference or the object reside outside youngSpace. So, if you must garantuee that some object has been finalized you definitely need to do a fullGC.

ar 3/20/98 17:20"

	self error:'Comment only'.! !

!ObjectMemory methodsFor: 'finalization' stamp: 'ar 3/23/98 22:39'!
finalizeReference: oop
	"During sweep phase we have encountered a weak reference. Check if
	its object has gone away (or is about to) and if so, signal a semaphore."
	| weakOop oopGone chunk firstField lastField |
	"Do *not* inline this in sweepPhase - it is quite an unlikely case to run into a weak reference"
	self inline: false.
	firstField := BaseHeaderSize + ((self nonWeakFieldsOf: oop) << 2).
	lastField := self lastPointerOf: oop.
	firstField to: lastField by: 4 do:[:i|
		weakOop := self longAt: oop+i.
		((weakOop == nilObj) or:[(self isIntegerObject: weakOop)]) ifFalse:[
			"Check if the object is being collected.
			If the weak reference points 
				* backward: check if the weakOops chunk is free
				* forward: check if the weakOoop has been marked by GC"
			weakOop < oop 
				ifTrue:[	chunk _ self chunkFromOop: weakOop.
						oopGone _ ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
				ifFalse:[oopGone _ ((self baseHeader: weakOop) bitAnd: MarkBit) = 0].
			oopGone ifTrue:[
					"Store nil in the pointer and signal the interpreter"
					self longAt: oop+i put: nilObj.
					self signalFinalization: oop].
		].
	].! !


!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
characterTable
	^self splObj: CharacterTable! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classArray
	^self splObj: ClassArray! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classBitmap
	^self splObj: ClassBitmap! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:06'!
classByteArray
	^self splObj: ClassByteArray! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classCharacter
	^self splObj: ClassCharacter! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 00:50'!
classExternalAddress
	^self splObj: ClassExternalAddress! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 18:23'!
classExternalData
	^self splObj: ClassExternalData! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 18:23'!
classExternalFunction
	^self splObj: ClassExternalFunction! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/17/1999 19:45'!
classExternalLibrary
	^self splObj: ClassExternalLibrary! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 15:23'!
classExternalStructure
	^self splObj: ClassExternalStructure! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classFloat
	^self splObj: ClassFloat! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/21/1999 23:22'!
classLargeNegativeInteger
	^self splObj: ClassLargeNegativeInteger! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classLargePositiveInteger
	^self splObj: ClassLargePositiveInteger! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:07'!
classPoint
	^self splObj: ClassPoint! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:11'!
classSemaphore
	^self splObj: ClassSemaphore! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:11'!
classSmallInteger
	^self splObj: ClassInteger! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
classString
	^self splObj: ClassString! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
displayObject
	^self splObj: TheDisplay! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:12'!
falseObject
	^falseObj! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 11/28/1999 19:04'!
isInMemory: address
	"Return true if the given address is in ST object memory"
	^address >= self startOfMemory and:[address < endOfMemory]! !

!ObjectMemory methodsFor: 'plugin support' stamp: 'ar 10/7/1998 18:16'!
trueObject
	^trueObj! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectMemory class
	instanceVariableNames: ''!

!ObjectMemory class methodsFor: 'initialization' stamp: 'JMM 11/18/2000 17:59'!
initialize
	"ObjectMemory initialize"

	"Translation flags (booleans that control code generation via conditional translation):"
	DoAssertionChecks _ false.  "generate assertion checks"

	self initializeSpecialObjectIndices.
	self initializeObjectHeaderConstants.

	SmallContextSize _ 92.  "16 indexable fields"
	LargeContextSize _ 252.  "56 indexable fileds.  Max with single header word."
	LargeContextBit _ 16r40000.  "This bit set in method headers if large context is needed."
	CtxtTempFrameStart _ 6.  "Copy of TempFrameStart in Interp"
	NilContext _ 1.  "the oop for the integer 0; used to mark the end of context lists"

	RemapBufferSize _ 25.
	RootTableSize _ 2500.  "number of root table entries (4 bytes/entry)"

	"tracer actions"
	StartField _ 1.
	StartObj _ 2.
	Upward _ 3.
	Done _ 4.! !

!ObjectMemory class methodsFor: 'initialization' stamp: 'go 11/18/1998 10:42'!
initializeObjectHeaderConstants

	BaseHeaderSize _ 4.

	"masks for type field"
	TypeMask _ 3.
	AllButTypeMask _ 16rFFFFFFFF - TypeMask.

	"type field values"
	HeaderTypeSizeAndClass _ 0.
	HeaderTypeClass _ 1.
	HeaderTypeFree _ 2.
	HeaderTypeShort _ 3.

	"type field values used during the mark phase of GC"
	HeaderTypeGC _ 2.
	GCTopMarker _ 3.  "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase."

	"base header word bit fields"
	HashBits _ 16r1FFE0000.
	AllButHashBits _ 16rFFFFFFFF - HashBits.
	HashBitsOffset _ 17.
	SizeMask _ 16rFC.
	CompactClassMask _ 16r1F000.

	"masks for root and mark bits"
	MarkBit _ 16r80000000.
	RootBit _ 16r40000000.
	AllButMarkBit _ 16rFFFFFFFF - MarkBit.
	AllButRootBit _ 16rFFFFFFFF - RootBit.

	AllButMarkBitAndTypeMask _ AllButTypeMask - MarkBit.! !

!ObjectMemory class methodsFor: 'initialization' stamp: 'ar 11/21/1999 15:23'!
initializeSpecialObjectIndices
	"Initialize indices into specialObjects array."

	NilObject _ 0.
	FalseObject _ 1.
	TrueObject _ 2.
	SchedulerAssociation _ 3.
	ClassBitmap _ 4.
	ClassInteger _ 5.
	ClassString _ 6.
	ClassArray _ 7.
	"SmalltalkDictionary _ 8."  "Do not delete!!"
	ClassFloat _ 9.
	ClassMethodContext _ 10.
	ClassBlockContext _ 11.
	ClassPoint _ 12.
	ClassLargePositiveInteger _ 13.
	TheDisplay _ 14.
	ClassMessage _ 15.
	ClassCompiledMethod _ 16.
	TheLowSpaceSemaphore _ 17.
	ClassSemaphore _ 18.
	ClassCharacter _ 19.
	SelectorDoesNotUnderstand _ 20.
	SelectorCannotReturn _ 21.
	TheInputSemaphore _ 22.
	SpecialSelectors _ 23.
	CharacterTable _ 24.
	SelectorMustBeBoolean _ 25.
	ClassByteArray _ 26.
	ClassProcess _ 27.
	CompactClasses _ 28.
	TheTimerSemaphore _ 29.
	TheInterruptSemaphore _ 30.
	FloatProto _ 31.
	SelectorCannotInterpret _ 34.
	MethodContextProto _ 35.
	BlockContextProto _ 37.
	ExternalObjectsArray _ 38.
	ClassPseudoContext _ 39.
	ClassTranslatedMethod _ 40.
	TheFinalizationSemaphore _ 41.
	ClassLargeNegativeInteger _ 42.

	ClassExternalAddress _ 43.
	ClassExternalStructure _ 44.
	ClassExternalData _ 45.
	ClassExternalFunction _ 46.
	ClassExternalLibrary _ 47.! !


!ObjectMemory class methodsFor: 'translation' stamp: 'sma 3/3/2000 12:40'!
declareCVarsIn: aCCodeGenerator
	aCCodeGenerator var: #memory type: #'unsigned char*'.
	aCCodeGenerator
		var: #remapBuffer
		declareC: 'int remapBuffer[', (RemapBufferSize + 1) printString, ']'.
	aCCodeGenerator
		var: #rootTable
		declareC: 'int rootTable[', (RootTableSize + 1) printString, ']'! !
ProtoObject subclass: #ObjectOut
	instanceVariableNames: 'url page recursionFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ObjectOut commentStamp: '<historical>' prior: 0!
I am a stand-in for an object that is out on the disk.  The object that is out on the disk is the head of a tree of objects that are out.  See SqueakPage.

When any message is sent to me, I don't understand it, and bring in my true object.  I become myself with the objects and resend the message.  

I may not represent the object nil.  
The file is represented as a url, and that url may point at any file on the net.  

page is a SqueakPage.
If the cache already has an object, widely in use, that claims to be the object for my url, what do I do?  I can't become him, since others believe that he is the true object.  Run through memory and replace refs to me with refs to him.  Be careful not to trigger a fault.  Become me to a string, then find pointers and replace?

[[[They don't want to end up holding an ObjectOut.  (would oscillate back and forth)  This is a problem.  A user could bring in two trees that both refer to a 3rd url.  (check with cache before installing any new ObjectOut) Two trees could be written to the same url.
Or, I remain an ObjectOut, and keep getting notUnderstood, and keep returning the other guy.
Or I smash the cache, and install MY page and object.  Other guy is a copy -- still in, but with no place in the cache.  When we both write to the same url, there will be trouble.]  No -- search and replace.]]]
!


!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 4/6/1999 10:01'!
doesNotUnderstand: aMessage 
	"Bring in the object, install, then resend aMessage"
	| realObject oldFlag response |
	oldFlag _ recursionFlag.
	recursionFlag _ true.
	"fetch the object"
	realObject _ self xxxFetch.		"watch out for the become!!"
			"Now we ARE the realObject"
	oldFlag == true ifTrue: [
		response _ (PopUpMenu labels: 'proceed normally\debug' withCRs)
			startUpWithCaption: 'Object being fetched for a second time.
Should not happen, and needs to be fixed later.'.
		response = 2 ifTrue: [self halt]].	"We are already the new object"

	"Can't be a super message, since this is the first message sent to this object"
	^ realObject perform: aMessage selector withArguments: aMessage arguments! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 11/16/1998 09:57'!
xxxFetch
	"Bring in my object and replace all references to me with references to him.  First try looking up my url in the pageCache.  Then try the page (and install it, under its url).  Then start from scratch with the url."

	| truePage object existing |
	existing _ SqueakPageCache pageCache at: url ifAbsent: [nil].
	existing ifNotNil: [existing isContentsInMemory
		ifTrue: [page _ truePage _ existing]].	"This url already has an object in this image"
	truePage ifNil: [
		truePage _ SqueakPageCache atURL: url oldPage: page].
	object _ truePage isContentsInMemory 
		ifTrue: [truePage contentsMorph]
		ifFalse: [truePage fetchInformIfError].	"contents, not the page"
			"Later, collect pointers to object and fix them up.  Not scan memory"
	object ifNil: [^ 'Object could not be fetched.'].
	"recursionFlag _ false."  	"while I still have a pointer to myself"
	truePage contentsMorph: object.
	page _ truePage.
	self xxxFixup.
	^ object	"the final object!!"
 ! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 11/15/1998 19:59'!
xxxFixup
	"There is already an object in memory for my url.  All pointers to me need to be pointers to him.  Can't use become, because other pointers to him must stay valid."

	| real temp list |
	real _ page contentsMorph.
	real == self ifTrue: [page error: 'should be converted by now'].
	temp _ self.
	list _ (Smalltalk pointersTo: temp) asOrderedCollection.
	list add: thisContext.  list add: thisContext sender.
	list do: [:holder |
		1 to: holder class instSize do:
			[:i | (holder instVarAt: i) == temp ifTrue: [holder instVarAt: i put: real]].
		1 to: holder basicSize do:
			[:i | (holder basicAt: i) == temp ifTrue: [holder basicAt: i put: real]].
		].
	^ real! !

!ObjectOut methodsFor: 'fetch from disk' stamp: 'tk 10/21/1998 13:01'!
xxxSetUrl: aString page: aSqkPage

	url _ aString.
	page _ aSqkPage.! !


!ObjectOut methodsFor: 'object storage' stamp: 'tk 2/17/2000 22:21'!
comeFullyUpOnReload: smartRefStream
	"Normally this read-in object is exactly what we want to store.  Try to dock first.  If it is here already, use that one."

	| sp |
	"Transcript show: 'has ref to: ', url; cr."
	(sp _ SqueakPageCache pageCache at: page ifAbsent: [nil]) ifNotNil: [
		sp isContentsInMemory ifTrue: [^ sp contentsMorph]].
	^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 2/24/1999 11:14'!
objectForDataStream: refStrm
    "Return an object to store on a data stream (externalize myself)."

    ^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 14:37'!
readDataFrom: aDataStream size: varsOnDisk
	"Make self be an object based on the contents of aDataStream, which was generated by the object's storeDataOn: method. Return self."
	| cntInstVars |
	cntInstVars _ self xxxClass instSize.
	self xxxClass isVariable
		ifTrue: [self xxxClass error: 'needs updating']	"assume no variable subclasses"
		ifFalse: [cntInstVars _ varsOnDisk].

	aDataStream beginReference: self.
	1 to: cntInstVars do:
		[:i | self xxxInstVarAt: i put: aDataStream next].
"	1 to: cntIndexedVars do:
		[:i | self basicAt: i put: aDataStream next].
"
	^ self! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 15:18'!
storeDataOn: aDataStream
	"Store myself on a DataStream. See also objectToStoreOnDataStream.
	must send 'aDataStream beginInstance:size:'"
	| cntInstVars |

	cntInstVars _ self class instSize.
	"cntIndexedVars _ self basicSize."
	aDataStream
		beginInstance: self xxxClass
		size: cntInstVars "+ cntIndexedVars".
	1 to: cntInstVars do:
		[:i | aDataStream nextPut: (self xxxInstVarAt: i)].
"	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]
"! !

!ObjectOut methodsFor: 'object storage' stamp: 'tk 10/22/1998 15:29'!
veryDeepCopyWith: deepCopier
	"Copy me and the entire tree of objects I point to.  An object in the tree twice is copied once, and both references point to him.  deepCopier holds a dictionary of objects we have seen.  Some classes refuse to be copied.  Some classes are picky about which fields get deep copied."
	| class index sub subAss new absent |
	new _ deepCopier references at: self ifAbsent: [absent _ true].
	absent ifNil: [^ new].	"already done"
	class _ self xxxClass.
	class isMeta ifTrue: [^ self].		"a class"
	new _ self xxxClone.
	"not a uniClass"
	deepCopier references at: self put: new.	"remember"
	"class is not variable"
	index _ class instSize.
	[index > 0] whileTrue: 
		[sub _ self xxxInstVarAt: index.
		(subAss _ deepCopier references associationAt: sub ifAbsent: [nil])
			ifNil: [new xxxInstVarAt: index put: (sub veryDeepCopyWith: deepCopier)]
			ifNotNil: [new xxxInstVarAt: index put: subAss value].
		index _ index - 1].
	new rehash.	"force Sets and Dictionaries to rehash"
	^ new
! !


!ObjectOut methodsFor: 'basics' stamp: 'tk 10/30/1998 15:11'!
isInMemory
	"We are a place holder for an object that is out."
	^ false! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/21/1998 12:28'!
xxxClass
	"Primitive. Answer the object which is the receiver's class. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 111>
	self primitiveFailed! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 15:31'!
xxxClone

	<primitive: 148>
	self primitiveFailed! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 15:19'!
xxxInstVarAt: index 
	"Primitive. Answer a fixed variable in an object. The numbering of the 
	variables corresponds to the named instance variables. Fail if the index 
	is not an Integer or is not the index of a fixed variable. Essential. See 
	Object documentation whatIsAPrimitive."

	<primitive: 73>
	self primitiveFailed ! !

!ObjectOut methodsFor: 'basics' stamp: 'tk 10/22/1998 14:39'!
xxxInstVarAt: anInteger put: anObject 
	"Primitive. Store a value into a fixed variable in the receiver. The 
	numbering of the variables corresponds to the named instance variables. 
	Fail if the index is not an Integer or is not the index of a fixed variable. 
	Answer the value stored as the result. Using this message violates the 
	principle that each object has sovereign control over the storing of 
	values into its instance variables. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 74>
	self primitiveFailed ! !


!ObjectOut methodsFor: 'access' stamp: 'tk 12/4/1998 13:01'!
sqkPage
	^ page! !

!ObjectOut methodsFor: 'access' stamp: 'tk 12/4/1998 13:01'!
url
	^ url! !

!ObjectOut methodsFor: 'access' stamp: 'tk 1/15/1999 11:43'!
url: aString

	url _ aString! !

!ObjectOut methodsFor: 'access' stamp: 'tk 12/18/1998 21:29'!
xxxReset
	"mark as never brought in"
	recursionFlag _ nil! !
AlignmentMorph subclass: #ObjectRepresentativeMorph
	instanceVariableNames: 'objectRepresented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/17/2000 11:35'!
categoriesForViewer
	"Answer a list of symbols representing the categories to offer in the viewer, in order"

	^ objectRepresented class organization categories
! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/31/2000 09:31'!
categoryElementsFor: aCategorySymbol
	"Answer a list of tuples that characterize the elements in the given category.  Every class in the receiver's superclass chain which implements #additionsToViewerCategories is given the chance to add elements to the category"

	| aList org |
	org _  objectRepresented class organization.
	aList _ (org listAtCategoryNamed: aCategorySymbol) select:
		[:anElement | anElement numArgs < 2].
	^ aList collect:
		[:sel | 
			sel numArgs == 0
				ifTrue:
					[Array with: #command with: sel with: 'help here later']
				ifFalse:
					[Array with: #command with: sel with: 'help here later' with: #string]]! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/31/2000 09:22'!
nameOfObjectRepresented
	"Answer the external name of the object represented"

	^ objectRepresented externalName! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/17/2000 11:42'!
objectRepresented
	"Answer the object represented by the receiver"

	^ objectRepresented! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject
	"Set the receiver's representee.  This clears out any preexisting state in the receiver"

	objectRepresented _ anObject.
	self removeAllMorphs.
	self hResizing: #shrinkWrap.  
	self vResizing: #shrinkWrap.
	self addMorphBack: (StringMorph new contents: anObject name asString).
	self setNameTo: anObject name
	! !

!ObjectRepresentativeMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/1/2000 15:55'!
objectRepresented: anObject labelString: aLabel
	"Set the receiver's representee as indicated, and use the given label to tag it"

	objectRepresented _ anObject.
	self removeAllMorphs.
	self hResizing: #shrinkWrap.  
	self vResizing: #shrinkWrap.
	self addMorphBack: (StringMorph new contents: aLabel asString).
	self setNameTo: aLabel asString
	! !
Object subclass: #ObjectScanner
	instanceVariableNames: 'pvt3SmartRefStrm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ObjectScanner commentStamp: '<historical>' prior: 0!
An instance of this class is the compiler's context for filing in a SmartRefStream containing instance-specific classes.  When the old name of a new object's class conflicts with an existing class name, install a class var in me.  It has the old name but points at the new class.  The compiler uses it when compiling the code in the fileIn.  Fill the SmartRefStream's renamed class dictionary.

An object fileout:
!!ObjectScanner new initialize!!      "allow me to take control with scanFrom:"

Player subclass: Player23 instanceVariableNames: 'foo' classVariableNames: '' 
	poolDictionaries: nil category: 'Instance Specific'!!
	"I prescan this and (self rename: #Player23 toBe: #Player30)"

!!Player23 methodsFor: 'all' stamp: 'tk 3/9/98 18:58'!!	"actually sent to Player30"
foo
	^ foo!! !!

!!self smartRefStream!!<binary representation of the objects>!!


!


!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 3/15/98 20:17'!
clear
	"remove all old class vars.  They were UniClasses being remapped to aviod a name conflict."

	self class classPool keys do: [:key |
		self class classPool removeKey: key].	"brute force"! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 8/15/1998 15:26'!
initialize
	"remove all old class vars that are not instance-specific classes being renamed"

	self clear.
	"Most importantly, return self, so a fileIn will let ObjectScanner seize control.  So UniClasses can be remapped.  See the transfer of control where ReadWriteStream fileIn calls scanFrom:"!
]style[(10 247 22 17)f1b,f1,f1LReadWriteStream fileIn;,f1! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 8/12/1999 15:41'!
lookAhead: aChunk
	"See if this chunk is a class Definition, and if the new class name already exists and is instance-specific.  Modify the chunk, and record the rename in the SmartRefStream and in me."

	| pieces sup oldName existing newName newDefn |
	aChunk size < 90 ifTrue: [^ aChunk].		"class defn is big!!"
	(aChunk at: 1) == $!! ifTrue: [^ aChunk].	"method def, fast exit"
	pieces _ (aChunk copyFrom: 1 to: (300 min: aChunk size)) findTokens: ' #	\' withCRs.
	pieces size < 3 ifTrue: [^ aChunk].	"really bigger, but just took front"
	(pieces at: 2) = 'subclass:' ifFalse: [^ aChunk].
	sup _ Smalltalk at: (pieces at: 1) asSymbol ifAbsent: [^ aChunk].
	sup class class == Metaclass ifFalse: [^ aChunk].
	((oldName _ pieces at: 3) at: 1) isUppercase ifFalse: [^ aChunk].
	oldName _ oldName asSymbol.
	(Smalltalk includesKey: oldName) ifFalse: [^ aChunk].	"no conflict"
	existing _ Smalltalk at: oldName.
	(existing isKindOf: Class) ifFalse: [^ aChunk].	"Write over non-class global"
	existing isSystemDefined ifTrue: [^ aChunk].	"Go ahead and redefine it!!"
	"Is a UniClass"
	newName _ sup chooseUniqueClassName.
	newDefn _ aChunk copyReplaceAll: oldName with: newName.
	Compiler evaluate: newDefn for: self logged: true.	"Create the new class"
	self rename: oldName toBe: newName.
	^ newName asString		"to be evaluated"
! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 3/15/98 20:21'!
rename: existingName toBe: newName
	"See if there is a conflict between what the fileIn wants to call the new UniClass (Player23) and what already exists for another unique instance.  If conflict, make a class variable to intercept the existingName and direct it to class newName."

	existingName = newName ifFalse: [
		self class ensureClassPool.	"create the dictionary"
		"can't use addClassVarName: because it checks for conflicts with Smalltalk"
		(self class classPool includesKey: existingName) ifFalse: 
			["Pick up any refs in Undeclared"
			self class classPool declare: existingName from: Undeclared].
		self class classPool at: existingName put: (Smalltalk at: newName).
		pvt3SmartRefStrm renamed at: existingName put: newName]! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 3/15/98 20:22'!
scanFrom: aByteStream
	"Sieze control of the fileIn.  Put myself in as the context.  If any UniClasses (for just one instance) are defined, they will do it through me, and I will look for conflicting class names.  If so, install the old name as a class var of me, so the compile will work.  Tell my SmartRefStream about renaming the class."

	| valWithOddName47 scannerNamed53 chunkNamed117 |
	pvt3SmartRefStrm _ SmartRefStream on: aByteStream.
	aByteStream ascii.
	[aByteStream atEnd] whileFalse:
		[aByteStream skipSeparators.
		valWithOddName47 _ (aByteStream peekFor: $!!)
			ifTrue: [chunkNamed117 _ aByteStream nextChunk.	"debug"
					scannerNamed53 _ Compiler evaluate: chunkNamed117
							for: self logged: false.
					scannerNamed53 class == self class 
						ifTrue: ["I already am the scanner for this file"]
						ifFalse: [scannerNamed53 scanFrom: aByteStream]]
			ifFalse: [chunkNamed117 _ aByteStream nextChunk.
					chunkNamed117 _ self lookAhead: chunkNamed117.
					Compiler evaluate: chunkNamed117 for: self logged: true].
		aByteStream skipStyleChunk].
	^ valWithOddName47! !

!ObjectScanner methodsFor: 'as yet unclassified' stamp: 'tk 3/15/98 19:33'!
smartRefStream

	^ pvt3SmartRefStrm! !
Stream subclass: #ObjectSocket
	instanceVariableNames: 'socket outBuf outBufIndex outBufSize inBuf inBufIndex inBufLastIndex outObjects inObjects '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-ObjectSocket'!
!ObjectSocket commentStamp: '<historical>' prior: 0!
This is a socket which sends arrays of strings back and forth.  This is less convenient than ObjectSockets but it is more secure.

An array of strings is represented on the network as:

	4-bytes		number of strings in the array
	4-byte		number of bytes in the first string
	n1-bytes		characters in the first string
	4-bytes		number of bytes in the second string
	n2-bytes	characters in the second string
	...

!


!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
next
	^inObjects removeFirst	! !

!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
nextOrNil
	inObjects isEmpty
		ifTrue: [ ^nil ]
		ifFalse: [ ^inObjects removeFirst ]! !

!ObjectSocket methodsFor: 'stream protocol' stamp: 'ls 4/25/2000 18:48'!
nextPut: anObject
	outObjects addLast: anObject! !


!ObjectSocket methodsFor: 'private-initialization' stamp: 'ls 4/25/2000 18:49'!
initialize: aSocket
	socket _ aSocket.
	inBuf _ String new: 1000.
	inBufIndex _ 1.
	inBufLastIndex := 0.

	outBuf _ nil.

	inObjects _ OrderedCollection new.
	outObjects _ OrderedCollection new.
! !


!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/2000 12:01'!
destroy
	socket destroy.
	socket _ nil.! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'RAA 7/20/2000 15:10'!
isConnected

	^socket notNil and: [socket isConnected]! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'ls 1/8/1999 16:14'!
processIO
	"do some as much network IO as possible"

	self processOutput.
	self processInput.! !

!ObjectSocket methodsFor: 'as yet unclassified' stamp: 'RAA 8/4/2000 15:38'!
remoteAddress

	self isConnected ifFalse: [^nil].
	^socket remoteAddress! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectSocket class
	instanceVariableNames: ''!

!ObjectSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/20/2000 15:47'!
on: aSocket

	^self basicNew initialize: aSocket! !
nil subclass: #ObjectTracer
	instanceVariableNames: 'tracedObject recursionFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ObjectTracer commentStamp: '<historical>' prior: 0!
An ObjectTracer can be wrapped around another object, and then give you a chance to inspect it whenever it receives messages from the outside.  For instance...
	(ObjectTracer on: Display) flash: (50@50 extent: 50@50)
will give control to a debugger just before the message flash is sent.
Obviously this facility can be embellished in many useful ways.
See also the even more perverse subclass, ObjectViewer, and its example.
!


!ObjectTracer methodsFor: 'very few messages' stamp: 'jm 4/19/1998 20:27'!
doesNotUnderstand: aMessage 
	"All external messages (those not caused by the re-send) get trapped here"
	"Present a dubugger before proceeding to re-send the message"

	Debugger openContext: thisContext
				label: 'About to perform: ', aMessage selector
				contents: thisContext shortStack.
	^ aMessage sentTo: tracedObject.
! !

!ObjectTracer methodsFor: 'very few messages'!
xxxUnTrace

	tracedObject become: self! !

!ObjectTracer methodsFor: 'very few messages'!
xxxViewedObject
	"This message name must not clash with any other (natch)."
	^ tracedObject! !

!ObjectTracer methodsFor: 'very few messages'!
xxxViewedObject: anObject
	"This message name must not clash with any other (natch)."
	tracedObject _ anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectTracer class
	instanceVariableNames: ''!

!ObjectTracer class methodsFor: 'instance creation'!
on: anObject
	^ self new xxxViewedObject: anObject! !
ObjectTracer subclass: #ObjectViewer
	instanceVariableNames: 'valueBlock lastValue changeBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ObjectViewer commentStamp: '<historical>' prior: 0!
ObjectViewers offers the same kind of interception of messages (via doesnotUnderstand:) as ObjectTracers, but instead of just being wrappers, they actually replace the object being viewed.  This makes them a lot more dangerous to use, but one can do amazing things.  For instance, the example below actually intercepts the InputSensor object, and prints the mouse coordinates asynchronously, every time they change:
	Sensor evaluate: [Sensor cursorPoint printString displayAt: 0@0]
		wheneverChangeIn: [Sensor cursorPoint].
To exit from this example, execute:
	Sensor xxxUnTrace
!


!ObjectViewer methodsFor: 'very few messages'!
doesNotUnderstand: aMessage 
	"Check for change after sending aMessage"
	| returnValue newValue |
	recursionFlag ifTrue: [^ aMessage sentTo: tracedObject].
	recursionFlag _ true.
	returnValue _ aMessage sentTo: tracedObject.
	newValue _ valueBlock value.
	newValue = lastValue ifFalse:
		[changeBlock value.
		lastValue _ newValue].
	recursionFlag _ false.
	^ returnValue! !

!ObjectViewer methodsFor: 'very few messages'!
xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2
	"This message name must not clash with any other (natch)."
	tracedObject _ viewedObject.
	valueBlock _ block2.
	changeBlock _ block1.
	recursionFlag _ false! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectViewer class
	instanceVariableNames: ''!

!ObjectViewer class methodsFor: 'instance creation'!
on: viewedObject evaluate: block1 wheneverChangeIn: block2
	^ self new xxxViewedObject: viewedObject evaluate: block1 wheneverChangeIn: block2! !
Object subclass: #ObjectWithDocumentation
	instanceVariableNames: 'authoringStamp documentation properties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 12/1/2000 22:34'!
documentation
	"Answer the receiver's documentation"

	^ documentation ifNil: ['no documentation available, sorry']! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 12/1/2000 22:34'!
documentation: maneno
	"Set the receiver's documentation"

	documentation _ maneno! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 1/26/2001 16:15'!
documentationOrNil
	"Answer the contents of the receiver's documentation slot"

	^ documentation! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 1/26/2001 16:57'!
editDescription
	"Allow the user to see and edit the documentation for this object"

	| reply |
	reply _ FillInTheBlank
		multiLineRequest: 'Kindly edit the description'
		centerAt: Sensor cursorPoint
		initialAnswer: self documentation
		answerHeight: 200.
	reply ifNil: [^ self].  "User cancelled out of the dialog"
	reply isEmptyOrNil ifFalse: [self documentation: reply]! !

!ObjectWithDocumentation methodsFor: 'documentation' stamp: 'sw 1/29/2001 09:28'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	authoringStamp _ Utilities changeStampPerSe
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ObjectWithDocumentation class
	instanceVariableNames: ''!

!ObjectWithDocumentation class methodsFor: 'instance creation' stamp: 'sw 12/11/2000 15:36'!
new
	"Create a new instance of the receiver, and initialize it"

	^ super new initialize! !
Switch subclass: #OneOnSwitch
	instanceVariableNames: 'connection '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!OneOnSwitch commentStamp: '<historical>' prior: 0!
I am a kind of Switch that can be connected to some related object, typically to a collection of my instances. When my instance is created, its connection is set to a particular object. When the object changes because an Switch it refers to is turned on, an update message is broadcasted. All the connected OneOnSwitches, except the changed one, turn off. This allows OneOnSwitches to maintain the constraint that at most one of them will be on at any time. OneOnSwitches can thus be made to act like "car radio" switches.!


!OneOnSwitch methodsFor: 'initialize-release'!
release

	super release.
	self isConnectionSet ifTrue: [connection removeDependent: self]! !


!OneOnSwitch methodsFor: 'state'!
turnOn
	"Does nothing if it is already on. If it is not, it is set to 'on', its
	dependents are 	notified of the change, its connection is notified, and
	its action is executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed.
			self notifyConnection.
			self doAction: onAction]! !


!OneOnSwitch methodsFor: 'connection'!
connection
	"Answer the object that connects the receiver to other Switches."

	^connection! !

!OneOnSwitch methodsFor: 'connection'!
connection: anObject 
	"Set anObject to be the connection among two or more Switches. Make the 
	receiver a dependent of the argument, anObject."

	connection _ anObject.
	connection addDependent: self! !

!OneOnSwitch methodsFor: 'connection'!
isConnectionSet
	"Answer whether the receiver is connected to an object that coordinates 
	updates among switches."

	connection == nil
		ifTrue: [^false]
		ifFalse: [^true]! !

!OneOnSwitch methodsFor: 'connection'!
notifyConnection
	"Send the receiver's connection (if it exists) the message 'changed: self' in 
	order for the connection to broadcast the change to other objects 
	connected by the connection."
	
	self isConnectionSet ifTrue: [self connection changed: self]! !


!OneOnSwitch methodsFor: 'updating'!
update: aOneOnSwitch 
	"Does nothing if aOneOnSwitch is identical to this object. If it is not, this 
	object is turned off. This message is sent by the connection (an Object)
	when some related OneOnSwitch (possibly this one) has changed. This
	allows a group of related OneOnSwitches to maintain the constraint that
	at most one will be on at any time."

	self ~~ aOneOnSwitch ifTrue: [self turnOff]! !
Behavior subclass: #Oop
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!Oop commentStamp: '<historical>' prior: 0!
Cooercion specification for Identity coercions:

	x asOop: Oop == x
	y asValue: Oop == y!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Oop class
	instanceVariableNames: ''!

!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 13:02'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !

!Oop class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:10'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg emitCExpression: aNode on: aStream! !

!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 15:58'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asRawOopFrom: anInteger! !

!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:17'!
ccgCanConvertFrom: anObject

	^(anObject isKindOf: SmallInteger) not! !

!Oop class methodsFor: 'plugin generation' stamp: 'acg 9/16/1999 21:53'!
ccgDeclareCForVar: aSymbolOrString

	^'int ', aSymbolOrString! !
SequenceableCollection subclass: #OrderedCollection
	instanceVariableNames: 'array firstIndex lastIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!OrderedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by the collector.!


!OrderedCollection methodsFor: 'accessing'!
at: anInteger 
	"Answer my element at index anInteger. at: is used by a knowledgeable
	client to access an existing element"

	(anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex])
		ifTrue: [self errorNoSuchElement]
		ifFalse: [^ array at: anInteger + firstIndex - 1]! !

!OrderedCollection methodsFor: 'accessing'!
at: anInteger put: anObject 
	"Put anObject at element index anInteger. at:put: cannot be used to
	append, front or back, to an ordered collection; it is used by a
	knowledgeable client to replace an element."

	| index |
	index _ anInteger asInteger.
	(index < 1 or: [index + firstIndex - 1 > lastIndex])
		ifTrue: [self errorNoSuchElement]
		ifFalse: [^array at: index + firstIndex - 1 put: anObject]! !

!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:42'!
capacity
	"Answer the current capacity of the receiver."

	^ array size! !

!OrderedCollection methodsFor: 'accessing'!
inspect
	"Open an OrderedCollectionInspector on the receiver.
	Use basicInspect to get a normal type of inspector."

	OrderedCollectionInspector openOn: self withEvalPane: true! !

!OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'!
size
	"Answer how many elements the receiver contains."

	^ lastIndex - firstIndex + 1! !


!OrderedCollection methodsFor: 'copying'!
copyEmpty
	"Answer a copy of the receiver that contains no elements."

	^self species new! !

!OrderedCollection methodsFor: 'copying' stamp: 'di 12/12/2000 10:15'!
copyFrom: startIndex to: endIndex 
	"Answer a copy of the receiver that contains elements from position
	startIndex to endIndex."

	| targetCollection |
	endIndex < startIndex ifTrue: [^self species new: 0].
	targetCollection _ self species new: endIndex + 1 - startIndex.
	startIndex to: endIndex do: [:index | targetCollection addLast: (self at: index)].
	^ targetCollection! !

!OrderedCollection methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: replacementCollection 
	"Answer a copy of the receiver with replacementCollection's elements in
	place of the receiver's start'th to stop'th elements. This does not expect
	a 1-1 map from replacementCollection to the start to stop elements, so it
	will do an insert or append."

	| newOrderedCollection delta startIndex stopIndex |
	"if start is less than 1, ignore stop and assume this is inserting at the front. 
	if start greater than self size, ignore stop and assume this is appending. 
	otherwise, it is replacing part of me and start and stop have to be within my 
	bounds. "
	delta _ 0.
	startIndex _ start.
	stopIndex _ stop.
	start < 1
		ifTrue: [startIndex _ stopIndex _ 0]
		ifFalse: [startIndex > self size
				ifTrue: [startIndex _ stopIndex _ self size + 1]
				ifFalse: 
					[(stopIndex < (startIndex - 1) or: [stopIndex > self size])
						ifTrue: [self errorOutOfBounds].
					delta _ stopIndex - startIndex + 1]].
	newOrderedCollection _ 
		self species new: self size + replacementCollection size - delta.
	1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)].
	1 to: replacementCollection size do: 
		[:index | newOrderedCollection add: (replacementCollection at: index)].
	stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)].
	^newOrderedCollection! !

!OrderedCollection methodsFor: 'copying'!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and 
	includes the argument, newElement, at the end."

	| newCollection |
	newCollection _ self copy.
	newCollection add: newElement.
	^newCollection! !

!OrderedCollection methodsFor: 'copying' stamp: 'sw 1/26/96'!
reversed
	"Answer a copy of the receiver with element order reversed.  "
	| newCol |
	newCol _ self species new.
	self reverseDo:
		[:elem | newCol addLast: elem].
	^ newCol

"#(2 3 4 'fred') reversed"! !


!OrderedCollection methodsFor: 'adding'!
add: newObject

	^self addLast: newObject! !

!OrderedCollection methodsFor: 'adding'!
add: newObject after: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just succeeding oldObject. Answer newObject."
	
	| index |
	index _ self find: oldObject.
	self insert: newObject before: index + 1.
	^newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'di 3/15/1999 14:01'!
add: newObject afterIndex: index 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just after index. Answer newObject."

	self insert: newObject before: firstIndex + index.
	^ newObject! !

!OrderedCollection methodsFor: 'adding'!
add: newObject before: oldObject 
	"Add the argument, newObject, as an element of the receiver. Put it in 
	the sequence just preceding oldObject. Answer newObject."
	
	| index |
	index _ self find: oldObject.
	self insert: newObject before: index.
	^newObject! !

!OrderedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 11:26'!
addAll: aCollection 
	"Add each element of aCollection at my end. Answer	aCollection."

	^ self addAllLast: aCollection! !

!OrderedCollection methodsFor: 'adding'!
addAllFirst: anOrderedCollection 
	"Add each element of anOrderedCollection at the beginning of the 
	receiver. Answer anOrderedCollection."

	anOrderedCollection reverseDo: [:each | self addFirst: each].
	^anOrderedCollection! !

!OrderedCollection methodsFor: 'adding'!
addAllLast: anOrderedCollection 
	"Add each element of anOrderedCollection at the end of the receiver. 
	Answer anOrderedCollection."

	anOrderedCollection do: [:each | self addLast: each].
	^anOrderedCollection! !

!OrderedCollection methodsFor: 'adding'!
addFirst: newObject 
	"Add newObject to the beginning of the receiver. Answer newObject."

	firstIndex = 1 ifTrue: [self makeRoomAtFirst].
	firstIndex _ firstIndex - 1.
	array at: firstIndex put: newObject.
	^ newObject! !

!OrderedCollection methodsFor: 'adding'!
addLast: newObject 
	"Add newObject to the end of the receiver. Answer newObject."

	lastIndex = array size ifTrue: [self makeRoomAtLast].
	lastIndex _ lastIndex + 1.
	array at: lastIndex put: newObject.
	^ newObject! !

!OrderedCollection methodsFor: 'adding'!
grow
	"Become larger. Typically, a subclass has to override this if the subclass
	adds instance variables."
	| newArray |
	newArray _ Array new: self size + self growSize.
	newArray replaceFrom: 1 to: array size with: array startingAt: 1.
	array _ newArray! !

!OrderedCollection methodsFor: 'adding'!
growSize
	^ array size max: 2! !


!OrderedCollection methodsFor: 'removing'!
remove: oldObject ifAbsent: absentBlock

	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue: 
			[oldObject = (array at: index)
				ifTrue: 
					[self removeIndex: index.
					^ oldObject]
				ifFalse: [index _ index + 1]].
	^ absentBlock value! !

!OrderedCollection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:24'!
removeAllSuchThat: aBlock 
	"Evaluate aBlock for each element and remove all that elements from
	the receiver for that aBlock evaluates to true."

	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue: 
			[(aBlock value: (array at: index))
				ifTrue: [self removeIndex: index]
				ifFalse: [index _ index + 1]]! !

!OrderedCollection methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'!
removeAt: index
	| removed |
	removed _ self at: index.
	self removeIndex: index + firstIndex - 1.
	^removed! !

!OrderedCollection methodsFor: 'removing'!
removeFirst
	"Remove the first element of the receiver and answer it. If the receiver is 
	empty, create an error notification."
	| firstObject |
	self emptyCheck.
	firstObject _ array at: firstIndex.
	array at: firstIndex put: nil.
	firstIndex _ firstIndex + 1.
	^ firstObject! !

!OrderedCollection methodsFor: 'removing'!
removeLast
	"Remove the last element of the receiver and answer it. If the receiver is 
	empty, create an error notification."
	| lastObject |
	self emptyCheck.
	lastObject _ array at: lastIndex.
	array at: lastIndex put: nil.
	lastIndex _ lastIndex - 1.
	^ lastObject! !


!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'!
collect: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect the 
	resulting values into a collection that is like me. Answer the new 
	collection. Override superclass in order to use addLast:, not at:put:."

	| newCollection |
	newCollection _ self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (aBlock value: (array at: index))].
	^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/18/2000 17:34'!
collect: aBlock from: fromIndex to: toIndex
	"Override superclass in order to use addLast:, not at:put:."
	| result |
	(fromIndex < 1 or:[toIndex + firstIndex - 1 > lastIndex])
		ifTrue: [^self errorNoSuchElement].
	result _ self species new: toIndex - fromIndex + 1.
	firstIndex + fromIndex - 1 to: firstIndex + toIndex - 1 do:
		[:index | result addLast: (aBlock value: (array at: index))].
	^ result
! !

!OrderedCollection methodsFor: 'enumerating'!
do: aBlock 
	"Override the superclass for performance reasons."
	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue: 
			[aBlock value: (array at: index).
			index _ index + 1]! !

!OrderedCollection methodsFor: 'enumerating'!
reverseDo: aBlock 
	"Override the superclass for performance reasons."
	| index |
	index _ lastIndex.
	[index >= firstIndex]
		whileTrue: 
			[aBlock value: (array at: index).
			index _ index - 1]! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:13'!
select: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect into
	a new collection like the receiver, only those elements for which aBlock
	evaluates to true."

	| newCollection element |
	newCollection _ self copyEmpty.
	firstIndex to: lastIndex do:
		[:index |
		(aBlock value: (element _ array at: index))
			ifTrue: [newCollection addLast: element]].
	^ newCollection! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with 
	corresponding elements from this collection and otherCollection."
	| result |
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	result _ self species new: self size.
	1 to: self size do:
		[:index | result addLast: (twoArgBlock value: (self at: index)
									value: (otherCollection at: index))].
	^ result! !

!OrderedCollection methodsFor: 'enumerating' stamp: 'bf 5/16/2000 16:30'!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block. Override superclass in order to use addLast:, not at:put:."

	| newCollection |
	newCollection _ self species new: self size.
	firstIndex to: lastIndex do:
		[:index |
		newCollection addLast: (elementAndIndexBlock
			value: (array at: index)
			value: index - firstIndex + 1)].
	^ newCollection! !


!OrderedCollection methodsFor: 'private'!
collector  "Private"
	^ array! !

!OrderedCollection methodsFor: 'private'!
errorConditionNotSatisfied

	self error: 'no element satisfies condition'! !

!OrderedCollection methodsFor: 'private'!
errorNoSuchElement

	self error: 'attempt to index non-existent element in an ordered collection'! !

!OrderedCollection methodsFor: 'private' stamp: 'sma 6/15/2000 13:21'!
find: oldObject
	| index |
	index _ firstIndex.
	[index <= lastIndex]
		whileTrue:
			[(array at: index) = oldObject ifTrue: [^ index].
			index _ index + 1].
	self errorNotFound: oldObject! !

!OrderedCollection methodsFor: 'private' stamp: 'sma 6/15/2000 13:27'!
insert: anObject before: spot
	| index delta spotIndex|
	spotIndex _ spot.
	delta _ spotIndex - firstIndex.
	firstIndex = 1
		ifTrue: 
			[self makeRoomAtFirst.
			spotIndex _ firstIndex + delta].
	firstIndex _ firstIndex - 1.
	array
		replaceFrom: firstIndex
		to: spotIndex - 2
		with: array
		startingAt: firstIndex + 1.
	array at: spotIndex - 1 put: anObject.
"	index _ firstIndex _ firstIndex - 1.
	[index < (spotIndex - 1)]
		whileTrue: 
			[array at: index put: (array at: index + 1).
			index _ index + 1].
	array at: index put: anObject."
	^ anObject! !

!OrderedCollection methodsFor: 'private'!
makeRoomAtFirst
	| delta index |
	delta _ array size - self size.
	delta = 0 ifTrue: 
			[self grow.
			delta _ array size - self size].
	lastIndex = array size ifTrue: [^ self]. "just in case we got lucky"
	index _ array size.
	[index > delta]
		whileTrue: 
			[array at: index put: (array at: index - delta + firstIndex - 1).
			array at: index - delta + firstIndex - 1 put: nil.
			index _ index - 1].
	firstIndex _ delta + 1.
	lastIndex _ array size! !

!OrderedCollection methodsFor: 'private'!
makeRoomAtLast
	| newLast delta |
	newLast _ self size.
	array size - self size = 0 ifTrue: [self grow].
	(delta _ firstIndex - 1) = 0 ifTrue: [^ self].
	"we might be here under false premises or grow did the job for us"
	1 to: newLast do:
		[:index |
		array at: index put: (array at: index + delta).
		array at: index + delta put: nil].
	firstIndex _ 1.
	lastIndex _ newLast! !

!OrderedCollection methodsFor: 'private' stamp: 'ar 5/22/2000 12:17'!
removeIndex: removedIndex
	array 
		replaceFrom: removedIndex 
		to: lastIndex - 1 
		with: array 
		startingAt: removedIndex+1.
	array at: lastIndex put: nil.
	lastIndex _ lastIndex - 1.! !

!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'!
reset
	firstIndex _ array size // 3 max: 1.
	lastIndex _ firstIndex - 1! !

!OrderedCollection methodsFor: 'private' stamp: 'ar 4/16/1999 07:59'!
resetTo: index
	firstIndex _ index.
	lastIndex _ firstIndex - 1! !

!OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'!
setCollection: anArray
	array _ anArray.
	self reset! !

!OrderedCollection methodsFor: 'private' stamp: 'apb 10/15/2000 18:10'!
setContents: anArray
	array _ anArray.
	firstIndex _ 1.
	lastIndex _ array size.! !


!OrderedCollection methodsFor: 'testing' stamp: 'bf 8/20/1999 15:08'!
hasContentsInExplorer

	^self isEmpty not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

OrderedCollection class
	instanceVariableNames: ''!

!OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:41'!
new
	^ self new: 10! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:42'!
new: anInteger 
	^ super new setCollection: (Array new: anInteger)! !

!OrderedCollection class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newCollection |
	newCollection _ self new: aCollection size.
	newCollection addAll: aCollection.
	^newCollection

"	OrderedCollection newFrom: {1. 2. 3}
	{1. 2. 3} as: OrderedCollection
	{4. 2. 7} as: SortedCollection
"! !

!OrderedCollection class methodsFor: 'instance creation' stamp: 'apb 10/15/2000 22:02'!
ofSize: n
	"Create a new collection of size n with nil as its elements.
	This method exists because OrderedCollection new: n creates an
	empty collection,  not one of size n."
	| collection |
	collection _ self new: n.
	collection setContents: (collection collector).
	^ collection
! !
Inspector subclass: #OrderedCollectionInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Inspector'!

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'tk 4/13/1998 09:49'!
fieldList
	^ self baseFieldList ,
		(object size <= (self i1 + self i2)
			ifTrue: [(1 to: object size)
						collect: [:i | i printString]]
			ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size)
						collect: [:i | i printString]])
"
OrderedCollection new inspect
(OrderedCollection newFrom: #(3 5 7 123)) inspect
(OrderedCollection newFrom: (1 to: 1000)) inspect
"! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:38'!
replaceSelectionValue: anObject 
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. The value of the selected variable is set to the value, anObject."

	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ super replaceSelectionValue: anObject].
	object at: self selectedObjectIndex put: anObject! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:28'!
selectedObjectIndex
	"Answer the index of the inspectee's collection that the current selection refers to."

	| basicIndex |
	basicIndex _ selectionIndex - 2 - object class instSize.
	^ (object size <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [basicIndex]
		ifFalse: [object size - (self i1 + self i2) + basicIndex]! !

!OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'sw 9/16/97 22:39'!
selection
	"The receiver has a list of variables of its inspected object.
	One of these is selected. Answer the value of the selected variable."

	(selectionIndex - 2) <= object class instSize
		ifTrue: [^ super selection].
	^ object at: self selectedObjectIndex! !
FillStyle subclass: #OrientedFillStyle
	instanceVariableNames: 'origin direction normal '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'!
direction
	^direction! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'!
direction: aPoint
	direction _ aPoint! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:31'!
normal
	^normal ifNil:[normal _ direction y negated @ direction x]! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:37'!
normal: aPoint
	normal _ aPoint! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'!
origin
	^origin! !

!OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'!
origin: aPoint
	origin _ aPoint.! !


!OrientedFillStyle methodsFor: 'testing' stamp: 'ar 6/18/1999 07:57'!
isOrientedFill
	"Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)"
	^true! !


!OrientedFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 07:41'!
addFillStyleMenuItems: aMenu hand: aHand from: aMorph
	"Add the items for changing the current fill style of the receiver"
	aMenu add: 'change origin' target: self selector: #changeOriginIn:event: argument: aMorph.
	aMenu add: 'change orientation' target: self selector: #changeOrientationIn:event: argument: aMorph.! !

!OrientedFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 07:41'!
changeOrientationIn: aMorph event: evt
	"Interactively change the origin of the receiver"
	| handle |
	handle _ HandleMorph new forEachPointDo:[:pt|
		self direction: pt - self origin.
		self normal: nil.
		aMorph changed].
	evt hand attachMorph: handle.
	handle startStepping.! !

!OrientedFillStyle methodsFor: 'Morphic menu' stamp: 'ar 6/18/1999 07:28'!
changeOriginIn: aMorph event: evt
	"Interactively change the origin of the receiver"
	| handle |
	handle _ HandleMorph new forEachPointDo:[:pt|
		self origin: pt.
		aMorph changed].
	evt hand attachMorph: handle.
	handle startStepping.! !
ImageReadWriter subclass: #PCXReadWriter
	instanceVariableNames: 'version encoding colorPlanes isGrayScale width height bitsPerPixel colorPalette rowByteSize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Files'!

!PCXReadWriter methodsFor: 'accessing' stamp: 'tao 10/6/97 10:11'!
nextImage
	"Read in the next PCX image from the stream."

	| bytes form |
	self readHeader.
	bytes _ self readBody.
	colorPalette _ self readPalette.
	self close.
	form _ ColorForm extent: width@height depth: bitsPerPixel.
	(Form new hackBits: bytes) displayOn: (Form new hackBits: form bits).
	form colors: colorPalette.
	^ form
! !


!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 08:38'!
nextWord
	^self next + (self next bitShift: 8)! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 10:07'!
readBody

	| array scanLine rowBytes position byte count pad |
	pad _ #(0 3 2 1) at: (width \\ 4 + 1).
	array _ ByteArray new: ((width + pad) * height * bitsPerPixel) // 8.
	scanLine _ ByteArray new: rowByteSize.
	position _ 1.
	1 to: height do:
		[:line |
		rowBytes _ 0.
		[rowBytes < rowByteSize] whileTrue:
			[byte _ self next.
			byte < 16rC0
				ifTrue:
					[rowBytes _ rowBytes + 1.
					scanLine at: rowBytes put: byte]
				ifFalse:
					[count _ byte - 16rC0.
					byte _ self next.
					1 to: count do: [:i | scanLine at: rowBytes + i put: byte].
					rowBytes _ rowBytes + count]].
		array
			replaceFrom: position
			to: position + width - 1
			with: scanLine
			startingAt: 1.
		position _ position + width + pad].
	^ array
! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 09:42'!
readHeader

	| xMin xMax yMin yMax |
	self next.	"skip over manufacturer field"
	version _ self next.
	encoding _ self next.
	bitsPerPixel _ self next.
	xMin _ self nextWord.
	yMin _ self nextWord.
	xMax _ self nextWord.
	yMax _ self nextWord.
	width _ xMax - xMin + 1.
	height _ yMax - yMin + 1.
	self next: 4. "skip over device resolution"
	self next: 49. "skip over EGA color palette"
	colorPlanes _ self next.
	rowByteSize _ self nextWord.
	isGrayScale _ (self next: 2) = 2.
	self next: 58. "skip over filler".



! !

!PCXReadWriter methodsFor: 'private-decoding' stamp: 'tao 10/6/97 08:29'!
readPalette

	| r g b array |
	self next = 12 ifFalse: [self error: 'no Color Palette!!'].
	array _ Array new: (1 bitShift: bitsPerPixel).
	1 to: array size do:
		[:i |
		r _ self next.  g _ self next.  b _ self next.
		array at: i put: (Color r: r g: g b: b range: 255)].
	^ array.
! !
Model subclass: #PDA
	instanceVariableNames: 'userCategories allPeople allEvents recurringEvents allToDoItems allNotes date category currentItem currentItemText currentItemSelection categoryList categoryListIndex peopleList peopleListIndex scheduleList scheduleListIndex toDoList toDoListIndex notesList notesListIndex dateButtonPressed viewDescriptionOnly '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!
!PDA commentStamp: '<historical>' prior: 0!
PDA help text...
A lot about the PDA should be obvious just by opening one up and playing with the sample data.  The PDA holds a complete database of people, events, to-do items and notes.  The date and keyword selected determine which records are visible at any given time.

All records
All records in the database have a number of pre-allocated fields, and these are displayed in the obvious manner in the current item pane at the bottom, when the record is selected.  Care must be taken to enter only valid data as the contents of any field.  This is usually simple but, for instance, matching string quotes can be a problem (embedded string quotes must be doubled).

Any item may be augmented by any number of fields, provided that the field names do not conflict with existing ones, and that the contents are valid Squeak objects.

The description field may often carry a long body of text so, for this reason, a special feature is provided for viewing only the description of the current item.  This makes it a lot easier to read long notes (like this one), and it saves the user from worrying about matching quotes and other punctuation.  Sorry it's a mode -- use the menu of the bottom pane to switch modes.

People
Since the name field is not split into first, middle, last as in some databases, you are encouraged to adopt the following format:
	Lastname, First I., Jr. (Nickname) (&Spousename)
which allows for useful processing for invitations and the like.

ToDoItems
ToDo items are designed not to be removed, but only to be marked done.  This allows the database to be browsed retroactively, with the to-do items appearing and disappearing on the dates the tasks were introduced and completed respectively.  Note that toDo items have a deadline field whose obvious associated semantics (see alarms) have not yet been implemented.

Schedule
Scedule items are relatively simple.  It is intended that if duration is specified, and that if time+duration overlaps ensuing events, that the ensuing events will be show in red or someting like that.  Alarms have not yet been implemented, but they will accept an integer field equal to the number of minutes prior to event time that the alarm should appear.  Presumably an alarm will apppear as a new object on the screen that announces the event, sounds a continuing audible sound, and allows easy dismissal by clicking or keystroke.

A number of short forms are allowed for the time field, such as '4p' asTime.
An event with time = nil will appear with dashes at the beginning of the day.

RecurringEvents
Recurring events are treated specially.  Each master event is consulted to generate derivative events in the schedule for any given day.  You can edit the derivative events, at which point they will become permanent events just like any other.  An unedited recurring event is a virtual object -- if you edit the master, its derivative copies may disappear from one time and reappear at another.  For this reason it is recommended that you never alter the date of a recurring event.  Instead, declare its last date, causing an end to that series, and create another recurring event for the new schedule if desired.  In this manner all the past schedule will continue to appear as it did when it was current.

To examine or alter recurring events, select the 'recurring' category (this will need further filtering for large databases).  The currently supported recurrence rules include
	#eachDay - for example, a 2-week vacation (give first and last dates).
	#dayOfWeek - for example, every Thursday
	#dayOfMonth - for example, on the first day of every month
	#dateOfYear - for example, birthdays and many holidays
	#nthWeekdayOfMonth - for example, the second Tuesday of every month
	#nthWeekdayOfMonthEachYear - for example, Thanksgiving
(The Squeak PDA does not support the recurrence rule for Easter Sunday ;-).

Notes
Notes are simple a place to capture thoughts and information relevant to the different areas of your life while you are in the simple planning mood inspired by using a PDA.  The ability to view the current item's description only is especially useful for notes.

Spawn Entire Month
While this feature (accessible from bottom pane menu) is very crude and does not offer interaction, its real purpose is for printing.  Expand the spawned window to full screen, use the morph menu to choose 'print PS to File...', and then send the resulting .eps file to your printer.  (At the time of this writing portrait and landscpe options were reversed ;-).!


!PDA methodsFor: 'initialization' stamp: 'dhhi 9/18/2000 11:39'!
initialize
	viewDescriptionOnly _ false.
	self userCategories: self sampleCategoryList
		allPeople: self samplePeopleList
		allEvents: self sampleScheduleList
		recurringEvents: self sampleRecurringEventsList
		allToDoItems: self sampleToDoList
		allNotes: self sampleNotes
		dateSelected: Date today
	! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/16/2000 17:56'!
labelString

	| today |
	today _ Date today.
	^ String streamContents:
		[:s | s nextPutAll: today weekday; space.
		Time now print24: false showSeconds: false on: s.
		s nextPutAll: '  --  '.
		s nextPutAll: today monthName; space; print: today dayOfMonth;
			nextPutAll: ', '; print: today year]! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/17/2000 15:29'!
loadDatabase

	| aName aFileStream list |
	aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz')
		withCaption: 'Choose a file to load'.
	aName ifNil: [^ self].  "User made no choice"
	aName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .data or .data.gz)'].

	aFileStream _ FileStream oldFileNamed: aName.

	list _ aFileStream fileInObjectAndCode.
	userCategories _ list at: 1.
	allPeople _ list at: 2.
	allEvents _ list at: 3.
	recurringEvents _ list at: 4.
	allToDoItems _ list at: 5.
	allNotes _ list at: 6.
	date _ Date today.
	self selectCategory: 'all'.
! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/17/2000 17:59'!
mergeDatabase

	| aName aFileStream list |
	aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz')
		withCaption: 'Choose a file to load'.
	aName ifNil: [^ self].  "User made no choice"
	aName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .data or .data.gz)'].

	aFileStream _ FileStream oldFileNamed: aName.

	list _ aFileStream fileInObjectAndCode.
	userCategories _ ((list at: 1) , userCategories) asSet asArray sort.
	allPeople _ ((list at: 2) , allPeople) asSet asArray sort.
	allEvents _ ((list at: 3) , allEvents) asSet asArray sort.
	recurringEvents _ ((list at: 4) , recurringEvents) asSet asArray sort.
	allToDoItems _ ((list at: 5) , allToDoItems) asSet asArray sort.
	allNotes _ ((list at: 6) , allNotes) asSet asArray sort.
	date _ Date today.
	self selectCategory: 'all'.
! !

!PDA methodsFor: 'initialization' stamp: 'di 12/21/2000 15:18'!
openAsMorphIn: window  "PDA new openAsMorph openInWorld"
	"Create a pluggable version of all the morphs for a Browser in Morphic"
	| dragNDropFlag paneColor chooser |
	window color: Color black.
	paneColor _ (Color r: 0.6 g: 1.0 b: 0.0).
	window model: self.

	dragNDropFlag _ Preferences browseWithDragNDrop.
	window addMorph: ((PluggableListMorph on: self list: #peopleListItems
			selected: #peopleListIndex changeSelected: #peopleListIndex:
			menu: #peopleMenu: keystroke: #peopleListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0@0 corner: 0.3@0.25).
	window addMorph: ((chooser _ PDAChoiceMorph new color: paneColor) contentsClipped: 'all';
			target: self; actionSelector: #chooseFrom:categoryItem:; arguments: {chooser};
			getItemsSelector: #categoryChoices)
		frame: (0@0.25 corner: 0.3@0.3).
	window addMorph: ((MonthMorph newWithModel: self) color: paneColor; extent: 148@109)
		frame: (0.3@0 corner: 0.7@0.3).
	window addMorph: (PDAClockMorph new color: paneColor;
						faceColor: (Color r: 0.4 g: 0.8 b: 0.6))  "To match monthMorph"
		frame: (0.7@0 corner: 1.0@0.3).

	window addMorph: ((PluggableListMorph on: self list: #toDoListItems
			selected: #toDoListIndex changeSelected: #toDoListIndex:
			menu: #toDoMenu: keystroke: #toDoListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0@0.3 corner: 0.3@0.7).
	window addMorph: ((PluggableListMorph on: self list: #scheduleListItems
			selected: #scheduleListIndex changeSelected: #scheduleListIndex:
			menu: #scheduleMenu: keystroke: #scheduleListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0.3@0.3 corner: 0.7@0.7).
	window addMorph: ((PluggableListMorph on: self list: #notesListItems
			selected: #notesListIndex changeSelected: #notesListIndex:
			menu: #notesMenu: keystroke: #notesListKey:from:) enableDragNDrop: dragNDropFlag)
		frame: (0.7@0.3 corner: 1@0.7).

	window addMorph: (PluggableTextMorph on: self
			text: #currentItemText accept: #acceptCurrentItemText:
			readSelection: #currentItemSelection menu: #currentItemMenu:)
		frame: (0@0.7 corner: 1@1).
	window firstSubmorph color: paneColor.
	window updatePaneColors.

	window step.
	^ window! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/18/2000 11:08'!
openMonthView
	| row month col paneExtent window paneColor nRows |
	month _ date notNil
		ifTrue: [date month]
		ifFalse: ["But... it's here somewhere..."
				((self dependents detect: [:m | m isKindOf: PDAMorph])
					findA: MonthMorph) month].
	window _ SystemWindow labelled: month printString.
	paneColor _ Color transparent.
	window color: (Color r: 0.968 g: 1.0 b: 0.355).
	nRows _ 0.  month eachWeekDo: [:w | nRows _ nRows + 1].
	paneExtent _ ((1.0/7) @ (1.0/nRows)).
	row _ 0.
	month eachWeekDo:
		[:week | col _ 0.
		week do:
			[:day | day month = month ifTrue:
				[window addMorph: ((PluggableListMorph on: self list: nil
						selected: nil changeSelected: nil menu: nil keystroke: nil)
							list: {(day dayOfMonth printString , '  ' , day weekday) asText allBold}
								, (self scheduleListForDay: day))
					frame: (paneExtent * (col@row) extent: paneExtent)].
			col _ col + 1].
		row _ row + 1].

	window firstSubmorph color: paneColor.
	window updatePaneColors.
	window openInWorld! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/17/2000 21:24'!
rekeyAllRecordsFrom: oldKey to: newKey

	allPeople do: [:r | r rekey: oldKey to: newKey].
	allEvents do: [:r | r rekey: oldKey to: newKey].
	recurringEvents do: [:r | r rekey: oldKey to: newKey].
	allToDoItems do: [:r | r rekey: oldKey to: newKey].
	allNotes do: [:r | r rekey: oldKey to: newKey].
! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/17/2000 15:13'!
saveDatabase

	(FileStream newFileNamed: (FileDirectory default nextNameFor: 'PDA' extension: 'pda'))
		fileOutClass: nil
		andObject: {userCategories. allPeople. allEvents. recurringEvents. allToDoItems. allNotes}.! !

!PDA methodsFor: 'initialization' stamp: 'dhhi 9/17/2000 15:17'!
userCategories: cats allPeople: ppl allEvents: evts recurringEvents: recEvts allToDoItems: todo allNotes: notes dateSelected: aDate

	userCategories _ cats.
	allPeople _ ppl.
	allEvents _ evts.
	recurringEvents _ recEvts.
	allToDoItems _ todo.
	allNotes _ notes.
	
	date _ aDate.  "Because updates ahead will need *both* date and category"
	self selectCategory: 'all'.
	self selectDate: aDate.  "Superfluous, but might not be"! !


!PDA methodsFor: 'date' stamp: 'dhhi 9/16/2000 13:27'!
selectDate: aDate

	date _ aDate.
	self updateScheduleList.
	self updateToDoList.
	self updateCurrentItem.! !

!PDA methodsFor: 'date' stamp: 'di 9/24/2000 22:23'!
setDate: aDate fromButton: aButton down: down

	dateButtonPressed ifNotNil: [dateButtonPressed setSwitchState: false].
	down ifTrue: [self selectDate: aDate.
				dateButtonPressed _ aButton]
		ifFalse: [self selectDate: nil.
				dateButtonPressed _ nil].
	self currentItem: nil.
	aButton ifNotNil: [aButton owner owner highlightToday] "ugly hack to restore highlight for today"! !


!PDA methodsFor: 'category' stamp: 'dhhi 9/17/2000 21:13'!
categoryChoices
	"Return a list for the popup chooser"
	| special |
	special _ {'all'. 'recurring'. nil}.
	(special includes: category) ifTrue:
		[^ special , userCategories , {nil. 'add new key'}].
	^ special , userCategories , {nil. 'remove ' , self categorySelected. 'rename ' , self categorySelected. nil. 'add new key'}! !

!PDA methodsFor: 'category' stamp: 'dhhi 9/14/2000 22:46'!
categorySelected

	^ category ifNil: ['all']
! !

!PDA methodsFor: 'category' stamp: 'dhhi 9/18/2000 11:30'!
chooseFrom: chooserMorph categoryItem: item

	| newKey menu |
	newKey _ item.
	self okToChange ifFalse: [^ self].
	(item = 'add new key') ifTrue:
		[newKey _ FillInTheBlank request: 'New key to use'
						initialAnswer: self categorySelected.
		newKey isEmpty ifTrue: [^ self].
		(userCategories includes: newKey) ifTrue: [^ self].
		userCategories _ (userCategories copyWith: newKey) sort].
	(item beginsWith: 'remove ') ifTrue:
		[(self confirm: 'Removal of this category will cause all items formerly
categorized as ''' , self categorySelected , ''' to be reclassified as ''all''.
Is this really what you want to do?
[unless there are very few, choose ''no'']')
			ifFalse: [^ self].
		self rekeyAllRecordsFrom: self categorySelected to: 'all'.
		userCategories _ userCategories copyWithout: self categorySelected.
		newKey _ 'all'].
	(item beginsWith: 'rename ') ifTrue:
		[menu _ CustomMenu new.
		userCategories do: [:key | menu add: key action: key].
		newKey _ menu startUpWithCaption: 'Please select the new key for
items now categorized as ''' , self categorySelected , '''.'.
		newKey ifNil: [^ self].
		(self confirm: 'Renaming this category will cause all items formerly
categorized as ''' , self categorySelected , ''' to be reclassified as ''' , newKey , '''.
Is this really what you want to do?')
			ifFalse: [^ self].
		self rekeyAllRecordsFrom: self categorySelected to: newKey.
		userCategories _ userCategories copyWithout: self categorySelected].
	self selectCategory: newKey.
	chooserMorph contentsClipped: newKey! !

!PDA methodsFor: 'category' stamp: 'dhhi 9/16/2000 19:14'!
selectCategory: cat

	category _ cat.
	self updateScheduleList.
	self updateToDoList.
	self updatePeopleList.
	self updateNotesList.
	currentItem ifNil: [^ self].
	(scheduleListIndex + toDoListIndex + peopleListIndex + notesListIndex) = 0 ifTrue:
		["Old current item is no longer current (not in any list)"
		currentItem _ nil.
		self changed: #currentItemText]! !


!PDA methodsFor: 'people' stamp: 'dhhi 9/16/2000 13:30'!
addPerson
	| newPerson |
	newPerson _ PDAPerson new key: self categorySelected; name: 'Last, First'.
	allPeople _ allPeople copyWith: newPerson.
	self currentItem: newPerson.
	self updatePeopleList! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/13/2000 17:19'!
peopleList
	"Return the value of peopleList"
	^ peopleList! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/13/2000 17:19'!
peopleListIndex
	"Return the value of peopleListIndex"
	^ peopleListIndex! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/18/2000 11:30'!
peopleListIndex: newValue
	"Assign newValue to peopleListIndex."

	peopleListIndex = newValue ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	peopleListIndex _ newValue.
	self currentItem: (peopleListIndex ~= 0
						ifTrue: [peopleList at: peopleListIndex]
						ifFalse: [nil]).
	self changed: #peopleListIndex.! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/14/2000 09:54'!
peopleListItems

	^ peopleList collect: [:p | p asListItem]! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/16/2000 12:35'!
peopleMenu: aMenu

	aMenu add: 'add new person' target: self selector: #addPerson.
	peopleListIndex > 0 ifTrue:
		[aMenu add: 'remove person' target: self selector: #removePerson].
	^ aMenu! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/16/2000 13:02'!
removePerson

	allPeople _ allPeople copyWithout: currentItem.
	self currentItem: nil.
	self updatePeopleList.
! !

!PDA methodsFor: 'people' stamp: 'dhhi 9/16/2000 08:44'!
updatePeopleList

	peopleList _ (allPeople select: [:c | c matchesKey: category]) sort.
	peopleListIndex _ peopleList indexOf: currentItem.
	self changed: #peopleListItems! !


!PDA methodsFor: 'schedule' stamp: 'di 2/1/2001 09:23'!
addEvent
	| newEvent |
	newEvent _ PDAEvent new key: self categorySelected; date: date;
						time: (Time readFromString: '7 am');
						description: 'new event'.
	allEvents _ allEvents copyWith: newEvent.
	self currentItem: newEvent.
	self updateScheduleList! !

!PDA methodsFor: 'schedule' stamp: 'di 2/1/2001 10:00'!
addRecurringEvent
	| newEvent |
	newEvent _ PDARecurringEvent new key: self categorySelected;
						firstDate: date; recurrence: PDARecurringEvent chooseRecurrence;
						description: 'recurring event'.
	newEvent key = 'recurring' ifTrue: [newEvent key: 'all'].
	newEvent recurrence == #eachDay ifTrue: [newEvent lastDate: (date addDays: 1)].
	recurringEvents _ recurringEvents copyWith: newEvent.
	self currentItem: newEvent.
	self updateScheduleList! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/17/2000 22:37'!
declareLastDate
	(self confirm: 'Please confirm termination of this event as of
' , date printString , '.')
		ifFalse: [^ self].
	currentItem lastDate: date.
	self currentItem: currentItem
! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/17/2000 22:37'!
declarelastDate
	(self confirm: 'Please confirm termination of this event as of
' , date printString , '.')
		ifFalse: [^ self].
	currentItem lastDate: date.
	self currentItem: currentItem
! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/18/2000 16:13'!
removeEvent

	(currentItem isKindOf: PDARecurringEvent)
	ifTrue: [(self confirm:
'Rather than remove a recurring event, it is
better to declare its last day to keep the record.
Do you still wish to remove it?')
				ifFalse: [^ self].
			recurringEvents _ recurringEvents copyWithout: currentItem]
	ifFalse: [allEvents _ allEvents copyWithout: currentItem].
	self currentItem: nil.
	self updateScheduleList.
! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/13/2000 17:19'!
scheduleList
	"Return the value of scheduleList"
	^ scheduleList! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/18/2000 09:29'!
scheduleListForDay: aDate

	| dayList |
	dayList _ ((allEvents select: [:c | c matchesKey: 'all' andMatchesDate: aDate])
			, ((recurringEvents select: [:c | c matchesKey: 'all' andMatchesDate: aDate])
					collect: [:re | (re as: PDAEvent) date: aDate])) sort.
	^ dayList collect: [:evt | evt asListItem]! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/13/2000 17:19'!
scheduleListIndex
	"Return the value of scheduleListIndex"
	^ scheduleListIndex! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/18/2000 11:30'!
scheduleListIndex: newValue
	"Assign newValue to scheduleListIndex."

	scheduleListIndex = newValue ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	scheduleListIndex _ newValue.
	self currentItem: (scheduleListIndex ~= 0
						ifTrue: [scheduleList at: scheduleListIndex]
						ifFalse: [nil]).
	self changed: #scheduleListIndex.! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/14/2000 09:55'!
scheduleListItems

	^ scheduleList collect: [:p | p asListItem]! !

!PDA methodsFor: 'schedule' stamp: 'di 2/1/2001 09:28'!
scheduleMenu: aMenu

	date ifNil: [^ aMenu add: 'select a date' target: self selector: #yourself.].
	self categorySelected ~= 'recurring' ifTrue:
		[aMenu add: 'add new event' target: self selector: #addEvent].
	aMenu add: 'add recurring event' target: self selector: #addRecurringEvent.
	scheduleListIndex > 0 ifTrue:
		[(currentItem isKindOf: PDARecurringEvent) ifTrue:
			[aMenu add: 'declare last date' target: self selector: #declareLastDate].
		aMenu add: 'remove event' target: self selector: #removeEvent].
	^ aMenu! !

!PDA methodsFor: 'schedule' stamp: 'dhhi 9/18/2000 16:09'!
updateScheduleList

	(date == nil and: [category ~= 'recurring']) ifTrue:
		[scheduleList _ Array new.  scheduleListIndex _ 0.
		^ self changed: #scheduleListItems].
	category = 'recurring'
	ifTrue: ["When 'recurring' is selected, edit actual masters"
			scheduleList _ (recurringEvents select:
				[:c | c matchesKey: category andMatchesDate: date]) sort]
	ifFalse: ["Otherwise, recurring events just spawn copies."
			scheduleList _ ((allEvents select: [:c | c matchesKey: category andMatchesDate: date])
			, ((recurringEvents select: [:c | c matchesKey: category andMatchesDate: date])
					collect: [:re | (re as: PDAEvent) date: date])) sort].
	scheduleListIndex _ scheduleList indexOf: currentItem.
	self changed: #scheduleListItems! !


!PDA methodsFor: 'to do' stamp: 'dhhi 9/16/2000 13:40'!
addToDoItem
	| newToDoItem |
	newToDoItem _ PDAToDoItem new key: self categorySelected; description: 'new item to do';
					dayPosted: Date today; priority: 1.
	allToDoItems _ allToDoItems copyWith: newToDoItem.
	self currentItem: newToDoItem.
	self updateToDoList! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/17/2000 22:36'!
declareItemDone
	| report |
	report _ FillInTheBlank request:
'This item will be declared done as of
' , date printString , '.
Please give a short summary of status'
		initialAnswer: 'Completed.'.
	(report == nil or: [report isEmpty]) ifTrue: [^ self].
	currentItem dayDone: date;
			result: report.
	self currentItem: currentItem! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/17/2000 22:04'!
removeToDoItem

	(self confirm: 'Rather than remove an item, it is
better to declare it done with a reason such as
''gave up'', or ''not worth it'', to keep the record.
Do you still wish to remove it?')
		ifFalse: [^ self].
	allToDoItems _ allToDoItems copyWithout: currentItem.
	self currentItem: nil.
	self updateToDoList.
! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/13/2000 17:19'!
toDoList
	"Return the value of toDoList"
	^ toDoList! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/13/2000 17:19'!
toDoListIndex
	"Return the value of toDoListIndex"
	^ toDoListIndex! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/18/2000 11:31'!
toDoListIndex: newValue
	"Assign newValue to toDoListIndex."

	toDoListIndex = newValue ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	toDoListIndex _ newValue.
	self currentItem: (toDoListIndex ~= 0
						ifTrue: [toDoList at: toDoListIndex]
						ifFalse: [nil]).
	self changed: #toDoListIndex.! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/14/2000 09:55'!
toDoListItems

	^ toDoList collect: [:p | p asListItem]! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/17/2000 22:06'!
toDoMenu: aMenu

	date ifNil: [^ aMenu add: 'select a date' target: self selector: #yourself.].
	aMenu add: 'add new item' target: self selector: #addToDoItem.
	toDoListIndex > 0 ifTrue:
		[aMenu add: 'declare item done' target: self selector: #declareItemDone.
		aMenu add: 'remove item' target: self selector: #removeToDoItem].
	^ aMenu! !

!PDA methodsFor: 'to do' stamp: 'dhhi 9/17/2000 20:23'!
updateToDoList

	date ifNil:
		[toDoList _ Array new. toDoListIndex _ 0.
		^ self changed: #toDoListItems].
	toDoList _ (allToDoItems select: [:c | c matchesKey: category andMatchesDate: date]) sort.
	toDoListIndex _ toDoList indexOf: currentItem.
	self changed: #toDoListItems! !


!PDA methodsFor: 'notes' stamp: 'dhhi 9/16/2000 13:38'!
addNote
	| newNote |
	newNote _ PDARecord new key: self categorySelected; description: 'new note'.
	allNotes _ allNotes copyWith: newNote.
	self currentItem: newNote.
	self updateNotesList! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/14/2000 22:55'!
notesList
	"Return the value of notesList"
	^ notesList! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/14/2000 22:55'!
notesListIndex
	"Return the value of notesListIndex"
	^ notesListIndex! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/18/2000 11:31'!
notesListIndex: newValue
	"Assign newValue to notesListIndex."

	notesListIndex = newValue ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	notesListIndex _ newValue.
	self currentItem: (notesListIndex ~= 0
						ifTrue: [notesList at: notesListIndex]
						ifFalse: [nil]).
	self changed: #notesListIndex.! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/14/2000 22:56'!
notesListItems

	^ notesList collect: [:p | p asListItem]! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/16/2000 13:40'!
notesMenu: aMenu

	aMenu add: 'add new note' target: self selector: #addNote.
	toDoListIndex > 0 ifTrue:
		[aMenu add: 'remove note' target: self selector: #removeNote].
	^ aMenu! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/16/2000 13:39'!
removeNote

	allNotes _ allNotes copyWithout: currentItem.
	self currentItem: nil.
	self updateNotesList.
! !

!PDA methodsFor: 'notes' stamp: 'dhhi 9/16/2000 08:54'!
updateNotesList

	notesList _ (allNotes select: [:c | c matchesKey: self categorySelected]) sort.
	self notesListIndex: (notesList indexOf: currentItem).
	self changed: #notesListItems! !


!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/18/2000 11:48'!
acceptCurrentItemText: aText

	currentItem ifNil:
		[PopUpMenu notify: 'Can''t accept -- no item is selected'. ^ false].
	viewDescriptionOnly ifTrue:
		[currentItem description: aText string. ^ true].

	currentItem readFrom: aText.
	(currentItem isKindOf: PDAEvent) ifTrue: [self updateScheduleList].
	(currentItem isMemberOf: PDAToDoItem) ifTrue: [self updateToDoList].
	(currentItem isMemberOf: PDAPerson) ifTrue: [self updatePeopleList].
	(currentItem isMemberOf: PDARecord) ifTrue: [self updateNotesList].
	^ true! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/18/2000 11:36'!
clearUserEditFlag
	"Clear the hasUnacceptedEdits flag in all my dependent views."

	self changed: #clearUserEdits! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/14/2000 10:09'!
currentItem
	"Return the value of currentItem"
	currentItem ifNil: [^ 'No item is selected.'].
	^ currentItem! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/16/2000 09:03'!
currentItem: newValue
	"Assign newValue to currentItem."

	currentItem class == newValue class ifFalse:
		["get rid of this hideous hack"
		(currentItem isMemberOf: PDAEvent) ifTrue: [self scheduleListIndex: 0].
		(currentItem isMemberOf: PDAToDoItem) ifTrue: [self toDoListIndex: 0].
		(currentItem isMemberOf: PDAPerson) ifTrue: [self peopleListIndex: 0].
		(currentItem isMemberOf: PDARecord) ifTrue: [self notesListIndex: 0]].
	currentItem _ newValue.
	self changed: #currentItemText! !

!PDA methodsFor: 'currentItem' stamp: 'di 9/29/2000 08:00'!
currentItemMenu: aMenu
	| donorMenu labels |
	viewDescriptionOnly
		ifTrue: [aMenu add: 'view entire records' target: self selector: #toggleDescriptionMode]
		ifFalse: [aMenu add: 'view descriptions only' target: self selector: #toggleDescriptionMode].
	aMenu addLine.
	aMenu add: 'save database' target: self selector: #saveDatabase.
	aMenu add: 'load database from file...' target: self selector: #loadDatabase.
	aMenu add: 'spawn entire month' target: self selector: #openMonthView.
	aMenu addLine.
	aMenu add: 'accept (s)' target: self selector: #accept.
	aMenu add: 'cancel (l)' target: self selector: #cancel.
	aMenu addLine.
	donorMenu _ ParagraphEditor yellowButtonMenu.
	labels _ donorMenu labelString findTokens: String cr.
	aMenu labels: (labels allButLast: 4) lines: donorMenu lineArray selections: donorMenu selections.
	^ aMenu! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/14/2000 10:09'!
currentItemSelection
	"Return the value of currentItemSelection"
	currentItemSelection ifNil: [^ 1 to: 0].
	^ currentItemSelection! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/13/2000 17:19'!
currentItemSelection: newValue
	"Assign newValue to currentItemSelection."

	currentItemSelection _ newValue.! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/18/2000 11:51'!
currentItemText

	currentItem ifNil: [^ 'no item is selected'].
	viewDescriptionOnly
		ifTrue: [currentItem description ifNil:
					[^ 'No description has yet been entered for this item'].
				^ currentItem description asText]
		ifFalse: [^ currentItem asText]! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/18/2000 11:28'!
okToChange

	self canDiscardEdits ifTrue: [^ true].
	self changed: #wantToChange.  "Solicit cancel from view"
	^ self canDiscardEdits
! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/18/2000 11:42'!
toggleDescriptionMode

	self okToChange ifFalse: [^ self].
	viewDescriptionOnly _ viewDescriptionOnly not.
	self changed: #currentItemText! !

!PDA methodsFor: 'currentItem' stamp: 'dhhi 9/16/2000 13:29'!
updateCurrentItem

	(peopleList includes: currentItem) ifTrue: [^ self].
	(scheduleList includes: currentItem) ifTrue: [^ self].
	(toDoList includes: currentItem) ifTrue: [^ self].
	(notesList includes: currentItem) ifTrue: [^ self].
	self currentItem: nil! !


!PDA methodsFor: 'example' stamp: 'dhhi 9/17/2000 15:26'!
sampleCategoryList

	^ { 'home'. 'work'. 'services' }! !

!PDA methodsFor: 'example' stamp: 'dhhi 9/18/2000 16:41'!
sampleNotes

	^ {
	PDARecord new key: 'home'; description: 'sprinkler schedule'.
	PDARecord new key: 'home'; description: 'directions to our house
Take the expressway, #93 south
Then south on Rte 24
East at the T with 195
Take exit 12 and go right to Faunce Corner
Cross rte 6, continue on Old Westport Rd
takes a bend left and becomes Chase Rd
Continue for 3.5-4 mi
Rt at T intersection on Russell Mills Rd
Pass DPW on left
Lg Yellow bldg Davall''s store
left on Rocko Dundee Rd
down a swail and up.  We''re #419 on the left'.
	PDARecord new key: 'work'; description: 'archaeology memo'.
	PDARecord new key: 'work'; description: 'worlds and envts memo'.
	PDARecord new key: 'work'; description: PDA comment string.
	}! !

!PDA methodsFor: 'example' stamp: 'dhhi 9/18/2000 16:06'!
samplePeopleList

	^ {
	PDAPerson new key: 'work'; name: 'Carson, Kit (&Lilly)'; phone: '888-555-1234'; email: 'Kit.Carson@Cosmo.com'.
	PDAPerson new key: 'work'; name: 'Kidd, William (Billy)'; phone: '888-555-1234'; email: 'William.Kidd@Cosmo.com'.
	PDAPerson new key: 'services'; name: 'Dewey, Cheatham & Howe'; phone: '888-555-1234'; email: 'AndHow@Cosmo.com'.
	PDAPerson new key: 'home'; name: 'Duck, Donald'; phone: '888-555-1234'; email: 'Donald.Duck@Cosmo.com'.
	PDAPerson new key: 'home'; name: 'Duck, Huey'; phone: '888-555-1234'; email: 'Huey.Duck@Cosmo.com'.
	PDAPerson new key: 'home'; name: 'Duck, Dewey'; phone: '888-555-1234'; email: 'Dewey.Duck@Cosmo.com'.
	PDAPerson new key: 'home'; name: 'Duck, Louie'; phone: '888-555-1234'; email: 'Louie.Duck@Cosmo.com'.
	}! !

!PDA methodsFor: 'example' stamp: 'dhhi 9/17/2000 14:19'!
sampleRecurringEventsList

	^ {
	PDARecurringEvent new key: 'home'; description: 'take out trash'; recurrence: #dayOfWeek; firstDate: (Date readFromString: '7 September 1999').
	PDARecurringEvent new key: 'home'; description: 'pay bills'; recurrence: #dayOfMonth; firstDate: (Date readFromString: '1 September 1999').
	PDARecurringEvent new key: 'all'; description: 'Columbus Day'; recurrence: #dateOfYear; firstDate: (Date readFromString: '12 October 1999').
	PDARecurringEvent new key: 'all'; description: 'Christmas'; recurrence: #dateOfYear; firstDate: (Date readFromString: '25 December 1999').
	PDARecurringEvent new key: 'all'; description: 'New Years'; recurrence: #dateOfYear; firstDate: (Date readFromString: '1 January 1999').
	PDARecurringEvent new key: 'all'; description: 'April Fools Day'; recurrence: #dateOfYear; firstDate: (Date readFromString: '1 April 1999').
	PDARecurringEvent new key: 'all'; description: 'Independence Day'; recurrence: #dateOfYear; firstDate: (Date readFromString: '4 July 1999').
	PDARecurringEvent new key: 'all'; description: 'Thanksgiving Day'; recurrence: #nthWeekdayOfMonthEachYear; firstDate: (Date readFromString: '25 November 1999').
	}! !

!PDA methodsFor: 'example' stamp: 'dhhi 9/18/2000 16:02'!
sampleScheduleList

	^ {
	PDAEvent new key: 'home'; date: Date today; description: 'wake up'; time: (Time new hours: 6).
	PDAEvent new key: 'home'; date: Date today; description: 'go for a run'; time: (Time new hours: 7).
	PDAEvent new key: 'home'; date: Date today; description: 'take a shower'; time: (Time new hours: 8).
	PDAEvent new key: 'home'; date: (Date today addDays: 2); description: 'dinner out'; time: (Time new hours: 18).
	PDAEvent new key: 'work'; date: (Date today addDays: 1); description: 'conf call'; time: (Time new hours: 10).
	PDAEvent new key: 'work'; date: (Date today addDays: 2); description: 'Leave for Conference'; time: (Time new hours: 8).
	PDAEvent new key: 'work'; date: Date today; description: 'call Boss'; time: (Time new hours: 15).
	PDAEvent new key: 'work'; date: Date today; description: 'Call about 401k'; time: (Time new hours: 10).
	}! !

!PDA methodsFor: 'example' stamp: 'dhhi 9/18/2000 16:05'!
sampleToDoList

	^ {
	PDAToDoItem new key: 'work'; dayPosted: (Date today subtractDays: 3); description: 'release external updates'; priority: 2.
	PDAToDoItem new key: 'work'; dayPosted: (Date today subtractDays: 3); description: 'first pass of sMovie'; priority: 1.
	PDAToDoItem new key: 'work'; dayPosted: (Date today subtractDays: 2); description: 'first pass of PDA'; priority: 2.
	PDAToDoItem new key: 'work'; dayPosted: (Date today subtractDays: 2); description: 'changes for finite undo'; priority: 2.
	PDAToDoItem new key: 'work'; dayPosted: (Date today subtractDays: 1); description: 'Msg to Freeman Zork'; priority: 1.
	PDAToDoItem new key: 'home'; dayPosted: (Date today subtractDays: 1); description: 'Fix fridge'; priority: 1.
	PDAToDoItem new key: 'home'; dayPosted: (Date today subtractDays: 3); description: 'Fix roof'; priority: 3.
	PDAToDoItem new key: 'home'; dayPosted: (Date today subtractDays: 3); description: 'Call about driveway'; priority: 4.
	}! !


!PDA methodsFor: 'menus' stamp: 'dhhi 9/16/2000 12:23'!
perform: selector orSendTo: otherTarget
	"This should be the default in Object"

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !
PopUpChoiceMorph subclass: #PDAChoiceMorph
	instanceVariableNames: 'backgroundColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAChoiceMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:05'!
color

	^ backgroundColor! !

!PDAChoiceMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:10'!
color: aColor

	backgroundColor _ aColor.
	self changed! !

!PDAChoiceMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:07'!
drawOn: aCanvas

	| offset |
	offset _ 4@(bounds height - self fontToUse height // 2).
	aCanvas frameAndFillRectangle: bounds fillColor: backgroundColor
			borderWidth: 1 borderColor: Color black.
	aCanvas text: contents
			bounds: ((bounds translateBy: offset) intersect: bounds)
			font: self fontToUse color: Color black.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PDAChoiceMorph class
	instanceVariableNames: ''!

!PDAChoiceMorph class methodsFor: 'as yet unclassified' stamp: 'dhhi 9/18/2000 15:16'!
includeInNewMorphMenu

	^ false! !
WatchMorph subclass: #PDAClockMorph
	instanceVariableNames: 'backgroundColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAClockMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:18'!
color
	^ backgroundColor! !

!PDAClockMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:19'!
color: aColor
	backgroundColor _ aColor.
	self changed! !

!PDAClockMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:20'!
drawOn: aCanvas

	aCanvas frameAndFillRectangle: bounds fillColor: backgroundColor
				borderWidth: 1 borderColor: borderColor.
	super drawOn: aCanvas.
! !

!PDAClockMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/16/2000 18:18'!
faceColor: aColor
	super color: aColor! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PDAClockMorph class
	instanceVariableNames: ''!

!PDAClockMorph class methodsFor: 'as yet unclassified' stamp: 'dhhi 9/18/2000 15:17'!
includeInNewMorphMenu

	^ false! !
PDARecord subclass: #PDAEvent
	instanceVariableNames: 'date time duration alarm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAEvent methodsFor: 'date' stamp: 'dhhi 9/13/2000 17:21'!
date
	"Return the value of date"
	^ date! !

!PDAEvent methodsFor: 'date' stamp: 'dhhi 9/13/2000 17:21'!
date: newValue
	"Assign newValue to date."

	date _ newValue.! !

!PDAEvent methodsFor: 'date' stamp: 'dhhi 9/14/2000 09:23'!
matchesDate: aDate

	^ date = aDate! !


!PDAEvent methodsFor: 'time' stamp: 'dhhi 9/17/2000 20:34'!
asListItem

	| timeString ampm |
	time ifNil: [^ '-- ' , (description copyUpTo: Character cr) , ' --'].
	timeString _ time printString.
	ampm _ timeString last: 2.
	^ (timeString allButLast: 3) , ampm , '  ' , (description copyUpTo: Character cr)! !

!PDAEvent methodsFor: 'time' stamp: 'dhhi 9/13/2000 17:21'!
time
	"Return the value of time"
	^ time! !

!PDAEvent methodsFor: 'time' stamp: 'dhhi 9/16/2000 13:13'!
time: newValue
	"Assign newValue to time."

	time _ newValue! !


!PDAEvent methodsFor: 'duration' stamp: 'dhhi 9/13/2000 17:21'!
duration
	"Return the value of duration"
	^ duration! !

!PDAEvent methodsFor: 'duration' stamp: 'dhhi 9/13/2000 17:21'!
duration: newValue
	"Assign newValue to duration."

	duration _ newValue.! !


!PDAEvent methodsFor: 'comparing' stamp: 'dhhi 9/17/2000 09:54'!
<= other

	date = other date ifFalse: [^ date < other date].
	time == nil ifTrue: [^ true].
	other time == nil ifTrue: [^ false].
	^ time <= other time! !
SystemWindow subclass: #PDAMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/18/2000 15:53'!
initialize

	super initialize.
	color _ Color lightGray.
	self extent: 406 @ 408.
	PDA new initialize openAsMorphIn: self.! !

!PDAMorph methodsFor: 'as yet unclassified' stamp: 'dhhi 9/15/2000 00:13'!
stepTime

	^ (60 - Time now seconds + 1) * 1000
! !

!PDAMorph methodsFor: 'as yet unclassified' stamp: 'di 9/10/2000 11:31'!
wantsSteps

	^ true  "collapsed or not"! !
PDARecord subclass: #PDAPerson
	instanceVariableNames: 'name address phone email '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAPerson methodsFor: 'comparing' stamp: 'dhhi 9/15/2000 10:14'!
<= other

	^ name <= other name! !


!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
address
	"Return the value of address"
	^ address! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
address: newValue
	"Assign newValue to address."

	address _ newValue.! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/14/2000 09:57'!
asListItem

	^ name! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
email
	"Return the value of email"
	^ email! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
email: newValue
	"Assign newValue to email."

	email _ newValue.! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
name
	"Return the value of name"
	^ name! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
name: newValue
	"Assign newValue to name."

	name _ newValue.! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
phone
	"Return the value of phone"
	^ phone! !

!PDAPerson methodsFor: 'public access' stamp: 'dhhi 9/13/2000 17:21'!
phone: newValue
	"Assign newValue to phone."

	phone _ newValue.! !
Object subclass: #PDARecord
	instanceVariableNames: 'key description otherFields '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDARecord methodsFor: 'key' stamp: 'dhhi 9/13/2000 17:39'!
key
	"Return the value of key"
	^ key! !

!PDARecord methodsFor: 'key' stamp: 'dhhi 9/13/2000 17:39'!
key: newValue
	"Assign newValue to key."

	key _ newValue.! !

!PDARecord methodsFor: 'key' stamp: 'dhhi 9/16/2000 09:06'!
matchesKey: aString

	key ifNil: [^ true].  "unkeyed items show up as 'all' "
	(aString = 'all' or: [key = 'all']) ifTrue: [^ true].
	^ key = aString! !

!PDARecord methodsFor: 'key' stamp: 'dhhi 9/17/2000 15:41'!
matchesKey: aString andMatchesDate: aDate
	"May be overridden for efficiency"
	^ (self matchesKey: aString) and: [self matchesDate: aDate]! !

!PDARecord methodsFor: 'key' stamp: 'dhhi 9/17/2000 21:25'!
rekey: oldKey to: newKey

	key = oldKey ifTrue: [key _ newKey]! !


!PDARecord methodsFor: 'description' stamp: 'dhhi 9/13/2000 17:39'!
description
	"Return the value of description"
	^ description! !

!PDARecord methodsFor: 'description' stamp: 'dhhi 9/13/2000 17:39'!
description: newValue
	"Assign newValue to description."

	description _ newValue.! !


!PDARecord methodsFor: 'other fields' stamp: 'dhhi 9/13/2000 17:39'!
otherFields
	"Return the value of otherFields"
	^ otherFields! !

!PDARecord methodsFor: 'other fields' stamp: 'dhhi 9/13/2000 17:39'!
otherFields: newValue
	"Assign newValue to otherFields."

	otherFields _ newValue.! !


!PDARecord methodsFor: 'comparing' stamp: 'dhhi 9/15/2000 09:58'!
<= other

	^ (description compare: other description) <= 2  "Case-insensitive"! !


!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/15/2000 10:52'!
allFieldsWithValuesDo: nameValueBlock

	self sharedFieldsWithValuesDo: nameValueBlock.
	otherFields ifNotNil:
		[otherFields associationsDo:
			[:assn | nameValueBlock value: assn key value: assn value]]! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/18/2000 09:16'!
asListItem

	^ description copyUpTo: Character cr! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/16/2000 19:06'!
asText

	^ String streamContents:
		[:s | self allFieldsWithValuesDo:
			[:field :value | s nextPutAll: field; nextPutAll: ': '; store: value; cr]]! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/17/2000 08:22'!
printOn: aStream

	super printOn: aStream.
	aStream space; nextPutAll: self asListItem! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/16/2000 08:31'!
readField: fieldName fromString: aString fields: sharedFields base: instVarBase
	"This message should be overridden in subclasses to recognize the types for the various fields.  If a fieldName is not recognized below, super will invoke this method at the end."

	(sharedFields includes: fieldName) ifTrue:
		[^ self instVarAt: instVarBase + (sharedFields indexOf: fieldName)
				put: (Compiler evaluate: aString)].

	otherFields ifNil: [otherFields _ Dictionary new].
	otherFields at: fieldName put: (Compiler evaluate: aString)
! !

!PDARecord methodsFor: 'as text' stamp: 'di 9/29/2000 07:48'!
readFrom: aText
	| buffer tokenStream fieldName token |
	tokenStream _ ReadStream on: (Scanner new scanTokens: aText asString).
	buffer _ WriteStream on: (String new: 500).
	fieldName _ nil.
	self sharedFieldsWithBaseDo:
		[:fields :instVarBase |  
		[tokenStream atEnd] whileFalse:
			[token _ tokenStream next.
			((token isMemberOf: Symbol) and: [token endsWith: ':'])
				ifTrue: [fieldName ifNotNil:
							[self readField: fieldName fromString: buffer contents
								fields: fields base: instVarBase].
						buffer reset.  fieldName _ token allButLast]
				ifFalse: [(token isMemberOf: Symbol)
							ifTrue: [buffer nextPutAll: token; space]
							ifFalse: [buffer print: token; space]]].
		self readField: fieldName fromString: buffer contents
			fields: fields base: instVarBase]! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/15/2000 15:29'!
sharedFieldsWithBaseDo: fieldsAndBaseBlock

	| fields base |
	fields _ self class allInstVarNames allButFirst: (base _ PDARecord superclass instSize).
	fieldsAndBaseBlock value: fields value: base! !

!PDARecord methodsFor: 'as text' stamp: 'dhhi 9/15/2000 15:31'!
sharedFieldsWithValuesDo: nameValueBlock

	self sharedFieldsWithBaseDo:
		[:fields :instVarBase |
		fields withIndexDo:
			[:field :i | field = 'otherFields' ifFalse:
				[nameValueBlock value: field value: (self instVarAt: instVarBase + i)]]]! !
PDAEvent subclass: #PDARecurringEvent
	instanceVariableNames: 'recurrence firstDate lastDate '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'dhhi 9/17/2000 09:31'!
firstDate: aDate

	firstDate _ aDate
! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'dhhi 9/17/2000 09:32'!
lastDate: aDate

	lastDate _ aDate
! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'di 9/22/2000 12:57'!
matchesDate: aDate

	(firstDate == nil or: [firstDate > aDate]) ifTrue: [^ false].
	(lastDate ~~ nil and: [lastDate < aDate]) ifTrue: [^ false].
	recurrence == #eachDay ifTrue:
		[^ true].
	recurrence == #dayOfWeek ifTrue:
		[^ aDate weekday = firstDate weekday].
	recurrence == #dayOfMonth ifTrue:
		[^ aDate dayOfMonth = firstDate dayOfMonth].
	recurrence == #dateOfYear ifTrue:
		[^ aDate monthIndex = firstDate monthIndex
			and: [aDate dayOfMonth = firstDate dayOfMonth]].
	recurrence == #nthWeekdayOfMonth ifTrue:
		[^ aDate weekday = firstDate weekday
			and: [(aDate dayOfMonth - 1 // 7) = (firstDate dayOfMonth - 1 // 7)]].
	recurrence == #nthWeekdayOfMonthEachYear ifTrue:
		[^ aDate monthIndex = firstDate monthIndex
			and: [aDate weekday = firstDate weekday
			and: [(aDate dayOfMonth - 1 // 7) = (firstDate dayOfMonth - 1 // 7)]]].
! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'dhhi 9/17/2000 15:46'!
matchesKey: aString andMatchesDate: aDate

	aString = 'recurring' ifTrue: [^ true].
	^ super matchesKey: aString andMatchesDate: aDate! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'di 2/1/2001 09:09'!
readField: fieldName fromString: aString fields: sharedFields base: instVarBase
	"Overridden to check for valid recurrence symbol"

	fieldName = 'recurrence' ifTrue: [^ self recurrence: aString withBlanksTrimmed asSymbol].
	^ super readField: fieldName fromString: aString fields: sharedFields base: instVarBase
! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'di 2/1/2001 09:53'!
recurrence
	"Return the value of recurrence"
	^ recurrence! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'di 2/1/2001 09:33'!
recurrence: rSymbol
	(self validRecurrenceSymbols includes: rSymbol)
		ifFalse: [^ self error: 'unrecognized recurrence symbol: , rSymbol'].
	recurrence _ rSymbol! !

!PDARecurringEvent methodsFor: 'as yet unclassified' stamp: 'di 2/1/2001 09:32'!
validRecurrenceSymbols
	^ #(eachDay dayOfWeek dayOfMonth dateOfYear nthWeekdayOfMonth nthWeekdayOfMonthEachYear)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PDARecurringEvent class
	instanceVariableNames: ''!

!PDARecurringEvent class methodsFor: 'as yet unclassified' stamp: 'di 2/1/2001 09:44'!
chooseRecurrence

	^ (CustomMenu selections: self basicNew validRecurrenceSymbols) startUp
		ifNil: [#dateOfYear]! !
PDARecord subclass: #PDAToDoItem
	instanceVariableNames: 'dayPosted dayDone priority deadline result '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-PDA'!

!PDAToDoItem methodsFor: 'day posted' stamp: 'dhhi 9/13/2000 17:21'!
dayPosted
	"Return the value of dayPosted"
	^ dayPosted! !

!PDAToDoItem methodsFor: 'day posted' stamp: 'dhhi 9/13/2000 17:21'!
dayPosted: newValue
	"Assign newValue to dayPosted."

	dayPosted _ newValue.! !

!PDAToDoItem methodsFor: 'day posted' stamp: 'dhhi 9/14/2000 09:32'!
matchesDate: aDate

	dayPosted > aDate ifTrue: [^ false].
	dayDone ifNil: [^ true].
	^ dayDone >= aDate! !


!PDAToDoItem methodsFor: 'day done' stamp: 'dhhi 9/13/2000 17:21'!
dayDone
	"Return the value of dayDone"
	^ dayDone! !

!PDAToDoItem methodsFor: 'day done' stamp: 'dhhi 9/13/2000 17:21'!
dayDone: newValue
	"Assign newValue to dayDone."

	dayDone _ newValue.! !


!PDAToDoItem methodsFor: 'deadline' stamp: 'dhhi 9/13/2000 17:21'!
deadline
	"Return the value of deadline"
	^ deadline! !

!PDAToDoItem methodsFor: 'deadline' stamp: 'dhhi 9/13/2000 17:21'!
deadline: newValue
	"Assign newValue to deadline."

	deadline _ newValue.! !


!PDAToDoItem methodsFor: 'priority' stamp: 'dhhi 9/13/2000 17:21'!
priority
	"Return the value of priority"
	^ priority! !

!PDAToDoItem methodsFor: 'priority' stamp: 'dhhi 9/13/2000 17:21'!
priority: newValue
	"Assign newValue to priority."

	priority _ newValue.! !


!PDAToDoItem methodsFor: 'result' stamp: 'dhhi 9/13/2000 17:21'!
result
	"Return the value of result"
	^ result! !

!PDAToDoItem methodsFor: 'result' stamp: 'dhhi 9/13/2000 17:21'!
result: newValue
	"Assign newValue to result."

	result _ newValue.! !


!PDAToDoItem methodsFor: 'description' stamp: 'dhhi 9/14/2000 23:27'!
asListItem

	^ (priority ifNil: [0]) printString , ' ' , super asListItem! !


!PDAToDoItem methodsFor: 'comparing' stamp: 'dhhi 9/15/2000 10:12'!
<= other

	priority = other priority ifFalse: [^ priority < other priority].
	^ super <= other! !
Object subclass: #PHOReader
	instanceVariableNames: 'stream phonemes events pitches time '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!
!PHOReader commentStamp: '<historical>' prior: 0!
My instances read PHO files with lines of the form 'phoneme duration time0 pitch0 time1 pitch1 ...'. Time is in milliseconds, and pitch is in hertz. Files on this format are used as inputs for the MBROLA synthesizer, and there are lots of them available on the web. Here's an example:

_  120 0 105
m  60 33 105
E  70 42 102
r  50 20 108
I  50 20 125 100 142
k  100
r  50 80 137
I  50 80 121
s  70
m  50
@  90 33 111 88 108
s  90
!


!PHOReader methodsFor: 'initialization' stamp: 'len 6/15/1999 00:36'!
initialize
	events _ OrderedCollection new.
	pitches _ OrderedCollection new.
	time _ 0.0.
	phonemes _ PhonemeSet sampaToArpabet! !


!PHOReader methodsFor: 'accessing' stamp: 'len 9/27/1999 23:01'!
addPitches
	| offset |
	offset _ 0.0.
	events do: [ :each |
		each pitchPoints: (self pitchesBetween: offset and: offset + each duration).
		offset _ offset + each duration].! !

!PHOReader methodsFor: 'accessing' stamp: 'len 8/29/1999 02:16'!
events
	^ CompositeEvent new addAll: events; yourself! !

!PHOReader methodsFor: 'accessing' stamp: 'len 11/28/1999 04:00'!
nextEvent
	| line phonemeName phoneme duration answer ptime pitch |
	line _ ReadStream on: stream nextLine.
	phonemeName _ line upTo: Character space.
	phoneme _ phonemes at: phonemeName.
	[line peek isSeparator] whileTrue: [line next].
	duration _ (line upTo: Character space) asNumber / 1000.0.
	answer _ PhoneticEvent new phoneme: phoneme; duration: duration; loudness: 1.0.
	[line atEnd]
		whileFalse: [ptime _ (line upTo: Character space) asNumber * duration / 100.0.
					pitch _ (line upTo: Character space) asNumber asFloat.
					pitches add: time + ptime @ pitch].
	time _ time + duration.
	^ answer! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/15/1999 00:38'!
pitchAt: t
	"Answer the pitch of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	xVal _ pitches first x.
	count _ 1.
	[xVal < t]
		whileTrue: [count _ count + 1.
					count > pitches size ifTrue: [^ pitches last y].
					xVal _ (pitches at: count) x].
	xVal = t ifTrue: [^ (pitches at: count) y].
	count = 1 ifTrue: [^ pitches first y].
	x1 _ (pitches at: count - 1) x.
	x2 _ (pitches at: count) x.
	y1 _ (pitches at: count - 1) y.
	y2 _ (pitches at: count) y.
	^ (t - x1) / (x2 - x1) * (y2 - y1) + y1! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/20/1999 23:57'!
pitchesBetween: t1 and: t2
	| step |
	step _ (t2 - t1 / 0.035) asInteger + 1. "step small enough"
	^ (t1 to: t2 by: t2 - t1 / step) collect: [ :each | each - t1 @ (self pitchAt: each)]! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/17/1999 01:45'!
plotPitch
	Utilities plot: ((0 to: time by: 0.050) collect: [ :each | self pitchAt: each])! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/15/1999 00:40'!
read
	stream reset.
	[stream atEnd] whileFalse: [events add: self nextEvent].
	self addPitches! !

!PHOReader methodsFor: 'accessing' stamp: 'len 6/15/1999 00:29'!
stream: aStream
	stream _ aStream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PHOReader class
	instanceVariableNames: ''!

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/15/1999 00:48'!
eventsFromStream: aStream
	^ self new stream: aStream; read; events! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/15/1999 00:49'!
eventsFromString: aString
	^ self eventsFromStream: (ReadStream on: aString)! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/15/1999 00:31'!
new
	^ super new initialize! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/17/1999 01:47'!
plotPitchFromStream: aStream
	^ self new stream: aStream; read; plotPitch! !

!PHOReader class methodsFor: 'instance creation' stamp: 'len 6/17/1999 01:47'!
plotPitchFromString: aString
	^ self plotPitchFromStream: (ReadStream on: aString)! !


!PHOReader class methodsFor: 'examples' stamp: 'len 9/13/1999 01:29'!
aliceExample
	| events |
	events _ self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 0.63489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/28/1999 03:05'!
aliceExampleFemale
	| events |
	events _ self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 1.3].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/14/1999 01:09'!
aliceExampleMale
	| events |
	events _ self eventsFromString: self aliceExampleString.
	events do: [ :each | each pitchBy: 0.63489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/29/1999 04:36'!
aliceShortExample
	| events |
	events _ self eventsFromString: self aliceShortExampleString.
	events do: [ :each | each pitchBy: 1.3].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 12/9/1999 02:09'!
aliceShortExampleMale
	| events |
	events _ self eventsFromString: self aliceShortExampleString.
	events do: [ :each | each pitchBy: 0.4].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:47'!
mbrolaExample
	^ self eventsFromString:
'_ 50
E 40 0 102
m 50
b 50
r 30
@U 80 5 119 35 126 70 140
l 50
@ 50 50 173
w 100 75 133
V 30 85 114
z 60 75 101
d 60
@ 40
v 40 85 105
E 60 75 121
l 50 70 121
@ 60 60 150
p 50
d 70
b 70 0 90
AI 130 85 101
T 70
j 50 0 180
E 120 0 185 95 131
r 40
i 90 85 135
d 80 60 134
@ 50 0 119 50 114
t 70
w 70 10 117 65 127 85 115
A 180 0 102 55 91 95 85
_ 100
_ 100
I 80 18 111
t 80
s 50
@ 30
s 70
p 80
i 80 25 171 85 200
tS 110
s 70
I 30 35 112
n 40
T 80
@ 40 85 108
s 80
AI 130 80 115
z 70 90 125
r= 120 75 111
b 80
EI 80 95 133
z 70
d 50
A 40
n 30
D 60
@ 30 65 121
k 90
A 30
n 30 100 140
k 80
{ 70 5 170
t 70
@ 40 50 186
n 40 75 163
EI 100 90 173
S 130
@ 40
n 30 65 153
V 40
v 70 0 148
d 60
AI 130 5 112 80 109
f 110
@U 160 87 88
n 70
z 210 88 82
_ 80
_ 100
I 40 0 140
t 50
t 100
EI 60 50 221
k 70
s 80
@ 30 0 190
l 50
I 30 65 180
s 110
t 70
V 50 20 171
v 50
f 90
@U 140 25 157
n 30
i 60 66 160
m 50 60 130
z 80
@ 40 62 78
z 80
I 70 78 134
n 50 70 163
p 120
U 90 15 119 75 98
t 90
_ 140
_ 100
t 60 0 111
u 50 80 119
g 70
E 50 90 145
D 50
r= 50 40 139 90 163
w 90
I 30 15 114
D 50
_ 40
p 50
r 30 0 102
@ 30 65 110
s 120
A 50 90 148
d 80
I 50 50 178
k 80
I 50 66 167
n 60
f 50
r= 50 90 125
m 50
EI 140 95 96
S 140
@ 80 35 168
n 100 95 142
_ 190
{ 90 0 133
n 30
d 30
p 80
r 40
@ 40 0 97 65 103
d 70
j 20
u 60 65 150
s 90
I 30 50 210
z 50
s 140
p 70
i 130 0 138 95 98
tS 160
{ 70 0 127
t 50
D 50
@ 30 15 93
s 140
{ 30 35 127
m 50
p 70
l 50
I 30 35 184
N 70
f 70
r 60
i 90 30 125
k 40
w 30
@ 30 15 185
n 30
s 100
i 50 20 148 70 142
V 30 5 148
v 40
D 80
@ 40 25 106
d 80
AI 150 95 115
f 90
@U 130 95 114
n 70
d 80
EI 80 80 137
4 50
@ 30
b 100
EI 120 95 78
s 210
_ 80'! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:48'!
pushExample
	^ self eventsFromString:
'_  60 0 137
p  50 100 137
u  110 90 137
S  100 10 121
D  90
@  70 57 114 100 102
s  70
t  50
A 100 57 121 64 121
r 40
t  50
b  110
V  140 21 117 57 100 92 100
_ 3
n  130 25 102 50 105
t  60
u  70 28 129 71 111
b  70
i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93
_  140 92 93 100 100'! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/16/1999 01:47'!
pushExampleFemale
	| events |
	events _ self pushExample.
	events do: [ :each | each pitchBy: 1.93489].
	^ events! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/26/1999 23:47'!
pushShortExample
	^ self eventsFromString:
'i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93'.
"
'_ 3
n  130 25 102 50 105
t  60
u  70 28 129 71 111
b  70
i  70 50 102
g  20 10 100 80 102
i  130 25 117 66 114
n  260 3 111 23 105 42 97 61 93 73 93
_  140 92 93 100 100'"! !

!PHOReader class methodsFor: 'examples' stamp: 'len 7/27/1999 01:48'!
xmasExample
	^ self eventsFromString:
'_  120 0 105
m  60 33 105
E  70 42 102
r  50 20 108
I  50 20 125 100 142
k  100
r  50 80 137
I  50 80 121
s  70
m  50
@  90 33 111 88 108
s  90
{  70
n  100 50 105 100 97
d  50 80 93
h  50 20 93
{  50 20 102 60 114
p  50
i  50 100 125
n  60 83 121
u 100
j  130 7 121 23 121 100 108
r=  250 41 102 83 97
_  210 95 86 100 100'
! !

!PHOReader class methodsFor: 'examples' stamp: 'len 9/29/1999 02:56'!
xmasKidExample
	| events |
	events _ self xmasExample.
	events do: [ :each | each pitchBy: 1.6].
	^ events! !


!PHOReader class methodsFor: 'examples-private' stamp: 'len 7/27/1999 01:45'!
aliceExampleString
	^ '_ 48 0 222
{ 80 40 222 90 235
l 72 44 250 66 250
I 80
s 88
w 40 80 235
@ 40 80 210
z 64 12 210 50 181 75 181
b 72 33 173 88 181
I 56 71 181
g 56 28 153 100 166
I 64 62 160
n 40 60 160
I 88 27 166
N 40 100 166
t 80 20 160
U 40 40 181 80 166
g 48 100 166
E 104 38 153 76 137
t 56
v 48
E 72 11 166 66 153
r 88 18 160 63 166
i 112.8 14 166 49 173 77 173
t 104.8 98 137
AI 178.4 21 148 70 148 92 137
r= 108 25 137 62 133 98 129
d 49
@ 59.2 6 137 73 133
v 46
s 89
I 40 40 173
t 40 40 166
I 64 62 166
N 72 22 160 77 153
b 40 40 142 100 153
AI 136 29 142
h 80 30 142 100 148
r= 64 62 153 100 153
s 125
I 64 37 210 100 190
s 72 11 190
t 72
r= 104 30 160 69 142
O 72
n 40 40 142
D 40 40 153
@ 40 40 160
b 40 40 153 100 160
{ 216 18 166 51 166 70 153 88 137 100 133
n 40
k 56
_ 144 94 129 100 100
_ 100 0 137
{ 40
n 88 9 137 36 137 72 142
t 40 40 137 60 133
@ 48 16 148 100 148
h 40 100 142
{ 48 83 148
v 48 16 142
I 56 14 148 85 137
N 56 71 137
n 64 37 137 100 142
O 96 41 137 83 153 100 153
T 64
I 56 42 166
N 64 12 160 75 153
t 80 30 142
@ 56 28 166 100 148
d 56 71 137
u 160 15 160 45 160 70 153 95 142
w 136 23 137 58 137 88 148
A 112 21 153 57 160 92 173
n 64 50 166 62 153
s 56
O 48 50 153
r 40 40 142 100 133
t 130
w 56 57 166
AI 168 9 173 33 166 57 153 80 148 100 148
s 88
_ 300
S 92
i 48 50 235
h 40 40 235 100 250
@ 40 60 210 100 210
d 40
p 40
i 150
k 56
d 56
I 72 44 222 100 210
n 40 80 210
t 56
@ 48 83 181
D 40 39 173 99 173
@ 39.2 100 160
b 104 30 153 100 153
U 112 35 153 85 153 100 153
k 72
h 56
r= 48 50 200
s 136 5 181
I 64 25 166 87 142
s 56 14 137
t 56
r= 56 28 173 100 173
w 56 71 166
@ 56 42 181
z 48 16 181 50 173
r 120 73 181
i 104 7 190 69 190 100 181
d 40
I 112 7 166 50 137 85 129
N 80 30 114 50 111
_ 56 83 111 100 100
_ 140 0 153
b 40 60 153 100 153
U 64 75 148
4 40 80 148 100 142
I 40
t 40 40 148
h 40 40 142
{ 48 33 137
d 136 5 133 11 129 88 148
n 48 66 148
@U 144 16 160 44 173 72 190 100 210
p 80
I 96 75 190 100 181
k 56
tS 96
r= 104 30 190 69 181
z 72 11 181 33 173
O 40 60 173
r 64 37 160 100 153
k 72 11 153
O 152 63 190 89 200
n 40 60 181
v 40 60 166
r= 40 60 160
s 104 15 142
EI 120 20 190 53 190 86 210
S 104 7 210
@ 56 28 181 100 160
n 64 62 153 100 137
z 40
I 56 14 148 85 133
n 40 100 133
I 96 41 129 83 125
t 80
_ 64 85 125 100 100
_ 140 0 222
{ 56 14 222 28 220 42 235 85 235 100 220
n 96 33 222 75 235 100 235
w 48 33 222 66 250
O 90
4 48 50 222 66 252
I 48 33 250
z 64 12 235 62 210
D 56
@ 56 71 190
j 104 23 166 61 166 100 181
u 112 35 190 42 210 71 210 100 210
s 150
@ 56 42 200
v 40 20 160 60 148
@ 64 25 153 87 142
b 136 23 133 47 137
U 96 8 160 50 173 91 181 100 181
k 56
_ 56
T 56
O 119.2 20 166 53 142 80 137
4 40 20 133
{ 136 5 137 35 129 64 125
l 48 16 125 100 133
I 80 50 153 100 181
s 120
_ 40
_ 40
w 88 9 166 54 142
I 40 40 142
D 40 40 137
aU 62.4 38 137 63 133
t 80
p 55
I 72 16 210 38 210
k 40
tS 75.2 99 173
r= 136 29 160 64 160 76 166
z 48
O 44 90 185
r 60 6 198 46 200 72 190
k 40
O 81.6 12 148 61 133
n 40 20 133
v 48 33 133
r= 56 28 181 100 181
s 120 6 173
EI 136 11 222 41 210 94 210
S 120
@ 128 12 190 43 148 75 137
n 64 12 129 50 125
_ 80 88 125 100 100'! !

!PHOReader class methodsFor: 'examples-private' stamp: 'len 7/27/1999 01:46'!
aliceShortExampleString
	^ '_ 48 0 222
{ 80 40 222 90 235
l 72 44 250 66 250
I 80
s 88
w 40 80 235
@ 40 80 210
z 64 12 210 50 181 75 181
b 72 33 173 88 181
I 56 71 181
g 56 28 153 100 166
I 64 62 160
n 40 60 160
I 88 27 166
N 40 100 166
t 80 20 160
U 40 40 181 80 166
g 48 100 166
E 104 38 153 76 137
t 56
v 48
E 72 11 166 66 153
r 88 18 160 63 166
i 112.8 14 166 49 173 77 173
t 104.8 98 137
AI 178.4 21 148 70 148 92 137
r= 108 25 137 62 133 98 129
d 49
@ 59.2 6 137 73 133
v 46
s 89
I 40 40 173
t 40 40 166
I 64 62 166
N 72 22 160 77 153
b 40 40 142 100 153
AI 136 29 142
h 80 30 142 100 148
@ 60 50 150
r= 64 62 153 100 153
s 125
I 64 37 210 100 190
s 72 11 190
t 72
r= 104 30 160 69 142
O 72
n 40 40 142
D 40 40 153
@ 40 40 160
b 40 40 153 100 160
{ 216 18 166 51 166 70 153 88 137 100 133
n 40
k 56
_ 144 94 129 100 100'! !
ImageReadWriter subclass: #PNGReadWriter
	instanceVariableNames: 'chunk form width height depth bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen '
	classVariableNames: 'BPP BlockHeight BlockWidth Debugging '
	poolDictionaries: ''
	category: 'Graphics-Files'!
!PNGReadWriter commentStamp: '<historical>' prior: 0!
I am a subclass of ImageReadWriter that decodes Portable Network Graphics
(PNG) images.

Submitted by Duane Maxwell!


!PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'!
debugging

	^Debugging == true! !

!PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'!
nextImage

	filtersSeen _ Bag new.
	globalDataChunk _ nil.
	transparentPixelValue _ nil.
	unknownChunks _ Set new.
	stream reset.
	(stream respondsTo: #binary) ifTrue: [ stream binary] .
	stream skip: 8.
	[stream atEnd] whileFalse: [
		self processNextChunk.
	].
	chunk _ globalDataChunk.
	chunk ifNotNil: [self processIDATChunk].
	unknownChunks isEmpty ifFalse: [
		"Transcript show: ' ',unknownChunks asSortedCollection asArray printString."
	].
	self debugging ifTrue: [
		Transcript cr; show: 'form = ',form printString.
		Transcript cr; show: 'colorType = ',colorType printString.
		Transcript cr; show: 'interlaceMethod = ',interlaceMethod printString.
		Transcript cr; show: 'filters = ',filtersSeen sortedCounts asArray printString.
	].
	^ form
! !

!PNGReadWriter methodsFor: 'accessing' stamp: 'DSM 3/24/2000 01:12'!
understandsImageFormat
	#(137 80 78 71 13 10 26 10) do: [ :byte |
		stream next = byte ifFalse: [^ false]].
	^ true
! !


!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 12:03'!
processBackgroundChunk

	| val red green blue max |

	"Transcript show: '  BACKGROUND: ',chunk printString."
	colorType = 3 ifTrue: [
		form fillColor: (palette at: chunk first).
		^self
	].
	max _ (2 raisedTo: bitsPerChannel) - 1.
	(colorType = 0 or: [colorType = 4]) ifTrue: [
		val _ chunk unsignedShortAt: 1 bigEndian: true.
		form fillColor: (Color gray: val / max).
		^self
	].
	(colorType = 2 or: [colorType = 6]) ifTrue: [
		red _ chunk unsignedShortAt: 1 bigEndian: true.
		green _ chunk unsignedShortAt: 3 bigEndian: true.
		blue _ chunk unsignedShortAt: 5 bigEndian: true.
		form fillColor: (Color r: red/max g: green/max b: blue/max).
		^self
	].
"self halt."

"====
The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. 

For color type 3 (indexed color), the bKGD chunk contains: 


   Palette index:  1 byte

The value is the palette index of the color to be used as background. 

For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: 


   Gray:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. 

For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: 


   Red:   2 bytes, range 0 .. (2^bitdepth)-1
   Green: 2 bytes, range 0 .. (2^bitdepth)-1
   Blue:  2 bytes, range 0 .. (2^bitdepth)-1

(For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. 

When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. 
==="
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 17:00'!
processIDATChunk

	interlaceMethod = 0
		ifTrue: [ self processNonInterlaced ]
		ifFalse: [ self processInterlaced ]
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'DSM 3/26/2000 21:35'!
processIHDRChunk
	width _ chunk longAt: 1 bigEndian: true.
	height _ chunk longAt: 5 bigEndian: true.
	bitsPerChannel _ chunk at: 9.
	colorType _ chunk at: 10.
	"compression _ chunk at: 11." "TODO - validate compression"
	"filterMethod _ chunk at: 12." "TODO - validate filterMethod"
	interlaceMethod _ chunk at: 13. "TODO - validate interlace method"
	(#(2 4 6) includes: colorType)
		ifTrue: [
			depth _ 32.
			form _ Form extent: width@height depth: depth
			].
	(#(0 3) includes: colorType)
		ifTrue: [
			depth _ bitsPerChannel min: 8.
			form _ ColorForm extent: width@height depth: depth.
			colorType = 0 ifTrue: [ "grayscale"
				form colors: (self grayColorsFor: depth).
				]
			].
	bitsPerPixel _ (BPP at: colorType+1) at: bitsPerChannel highBit.
	bytesPerScanline _ width * bitsPerPixel + 7 // 8.
	rowSize _ form width * form depth + 31 >> 5.
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/6/2000 22:31'!
processInterlaced
	| z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp |
	startingCol _ #(0 4 0 2 0 1 0 ).
	colIncrement _ #(8 8 4 4 2 2 1 ).
	rowIncrement _ #(8 8 8 4 4 2 2 ).
	startingRow _ #(0 0 4 0 2 0 1 ).
	z _ ZLibReadStream on: chunk from: 1 to: chunk size.
	1 to: 7 do: [:pass |
		(self doPass: pass)
			ifTrue:
				[cx _ colIncrement at: pass.
				sc _ startingCol at: pass.
				bytesPerPass _ width - sc + cx - 1 // cx * bitsPerPixel + 7 // 8.
				prevScanline _ ByteArray new: bytesPerPass.
				thisScanline _ ByteArray new: bytesPerScanline.
				(startingRow at: pass)
					to: height - 1
					by: (rowIncrement at: pass)
					do: [:y |
						filter _ z next.
						filtersSeen add: filter.
						(filter isNil or: [(filter between: 0 and: 4) not])
							ifTrue: [^ self].
						thisScanline _ z next: bytesPerPass into: thisScanline startingAt: 1.
						self filterScanline: filter count: bytesPerPass.
						self copyPixels: y at: sc by: cx.
						temp := prevScanline.
						prevScanline := thisScanline.
						thisScanline := temp.
					]
				]
	].! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 11:43'!
processNextChunk

	| length asciiType |

	length _ self nextLong.
	asciiType _ (self next: 4) asString.
	chunk _ self next: length.
	"crc _" self nextLong. "TODO - validate crc"
	asciiType = 'IEND' ifTrue: [^self	"*should* be the last chunk"].
	asciiType = 'sBIT' ifTrue: [^self	"could indicate unusual sample depth in original"].
	asciiType = 'gAMA' ifTrue: [^self 	"indicates gamma correction value"].
	asciiType = 'bKGD' ifTrue: [^self processBackgroundChunk].
	asciiType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk].
	asciiType = 'tRNS' ifTrue: [^self processTransparencyChunk].

	asciiType = 'IHDR' ifTrue: [^self processIHDRChunk].
	asciiType = 'PLTE' ifTrue: [^self processPLTEChunk].
	asciiType = 'IDAT' ifTrue: [
		"---since the compressed data can span multiple
		chunks, stitch them all together first. later,
		if memory is an issue, we need to figure out how
		to do this on the fly---"
		globalDataChunk _ globalDataChunk ifNil: [chunk] ifNotNil:
			[globalDataChunk,chunk].
		^self
	].
	unknownChunks add: asciiType.
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/6/2000 22:42'!
processNonInterlaced
	| z filter temp |
	z _ ZLibReadStream on: chunk from: 1 to: chunk size.
	prevScanline _ ByteArray new: bytesPerScanline.
	thisScanline := ByteArray new: bytesPerScanline.
	0 to: height-1 do: [ :y |
		filter _ (z next: 1) first.
		filtersSeen add: filter.
		(filter isNil or: [(filter between: 0 and: 4) not])
			ifTrue: [^ self].
		thisScanline _ z next: bytesPerScanline into: thisScanline startingAt: 1.
		self filterScanline: filter count: bytesPerScanline.
		self copyPixels: y.
		temp := prevScanline.
		prevScanline := thisScanline.
		thisScanline := temp.
		]
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 11:13'!
processPLTEChunk

	| colorCount i |

	colorCount _ chunk size // 3. "TODO - validate colorCount against depth"
	palette _ Array new: colorCount.
	0 to: colorCount-1 do: [ :index |
		i _ index * 3 + 1.
		palette at: index+1 put:
			(Color r: (chunk at: i)/255 g: (chunk at: i+1)/255 b: (chunk at: i+2)/255)
		].
	(form isKindOf: ColorForm) ifTrue: [
		form colors: palette
	] ifFalse: [
		self flag: #bob.		"palette for true color image!!!!"
	].
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/5/2000 11:24'!
processPhysicalPixelChunk

	"Transcript show: '  PHYSICAL: ',chunk printString."
! !

!PNGReadWriter methodsFor: 'chunks' stamp: 'RAA 11/4/2000 16:22'!
processTransparencyChunk

	| red green blue |

	"Transcript show: '  TRANSPARENCY ',chunk printString."
	colorType = 0 ifTrue: [
		transparentPixelValue _ chunk unsignedShortAt: 1 bigEndian: true.
		^self
	].
	colorType = 2 ifTrue: [
		red _ chunk at: 2.
		green _ chunk at: 2.
		blue _ chunk at: 2.
		transparentPixelValue _ 16rFF00 + red << 8 + green << 8 + blue.
		^self
	].
	colorType = 3 ifTrue: [
		chunk withIndexDo: [ :alpha :index |
			palette at: index put: ((palette at: index) alpha: alpha/255)
		].
		^self
	].
! !


!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:43'!
filterAverage: count
	"Use the average of the pixel to the left and the pixel above as a predictor"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	1 to: delta do: [:i |
		thisScanline at: i put: ((thisScanline at: i) + ((prevScanline at: i) // 2) bitAnd: 255)].
	delta + 1 to: count do: [:i |
		thisScanline at: i put:
			((thisScanline at: i)
			+ ((prevScanline at: i)
			+ (thisScanline at: i - delta) // 2) bitAnd: 255)]! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'!
filterHorizontal: count
	"Use the pixel to the left as a predictor"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	delta+1 to: count do: [ :i |
		thisScanline at: i put: (((thisScanline at: i) +
(thisScanline at: i-delta)) bitAnd: 255) ]


! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:55'!
filterNone: count
! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'RAA 11/7/2000 09:45'!
filterPaeth: count
	"Select one of (the pixel to the left, the pixel above and the pixel to above left) to
	predict the value of this pixel"

	| delta |
	delta _ bitsPerPixel // 8 max: 1.
	1 to: delta do: [ :i |
		thisScanline at: i put:
			(((thisScanline at: i) + (prevScanline at: i)) bitAnd: 255)].
	delta+1 to: count do: [ :i |
		thisScanline
			at: i
			put: (((thisScanline at: i) + (self
				paethPredictLeft: (thisScanline at: i-delta)
				above: (prevScanline at: i)
				aboveLeft: (prevScanline at: i-delta)))
					bitAnd: 255)]

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:08'!
filterScanline: filterType count: count

	self
		perform: (
			#(filterNone: filterHorizontal: filterVertical: filterAverage: filterPaeth:)
				at: filterType+1)
		with: count.

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'DSM 3/25/2000 17:54'!
filterVertical: count
	"Use the pixel above as a predictor"

	1 to: count do: [ :i |
		thisScanline at: i put: (((thisScanline at: i) +
(prevScanline at: i)) bitAnd: 255) ]

! !

!PNGReadWriter methodsFor: 'filtering' stamp: 'eat 9/11/2000 20:05'!
paethPredictLeft: a above: b aboveLeft: c
	"Predicts the value of a pixel based on nearby pixels, based on
Paeth (GG II, 1991)"

	| pa pb pc |
	pa _ b > c ifTrue: [b - c] ifFalse: [c - b].
	pb _ a > c ifTrue: [a - c] ifFalse: [c - a].
	pc _ a + b - c - c.
	pc < 0 ifTrue: [
		pc := pc * -1].
	((pa <= pb) and: [pa <= pc]) ifTrue: [^ a].
	(pb <= pc) ifTrue: [^ b].
	^ c
! !


!PNGReadWriter methodsFor: 'pixel copies' stamp: 'DSM 3/26/2000 21:32'!
copyPixels: y
	"Handle non-interlaced pixels of supported colorTypes"

	| s |
	s _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed:
		  copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1.
	self perform: s asSymbol with: y
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:08'!
copyPixels: y at: startX by: incX
	"Handle interlaced pixels of supported colorTypes"

	| s |
	s _ #(copyPixelsGray:at:by: nil copyPixelsRGB:at:by: copyPixelsIndexed:at:by:
		  copyPixelsGrayAlpha:at:by: nil copyPixelsRGBA:at:by:) at: colorType+1.
	self perform: s asSymbol with: y with: startX with: incX
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:12'!
copyPixelsGray: y 
	"Handle non-interlaced grayscale color mode (colorType = 0)"
	| blitter pixPerByte mask shifts pixelNumber rawByte pixel transparentIndex |
	blitter _ BitBlt current bitPokerToForm: form.
	transparentIndex _ form colors size.
	bitsPerChannel = 16
		ifTrue: [0
				to: width - 1
				do: [:x | blitter pixelAt: x @ y put: 255
							- (thisScanline at: x << 1 + 1)].
			^ self]
		ifFalse: [bitsPerChannel = 8
				ifTrue: [1
						to: width
						do: [:x | blitter
								pixelAt: x - 1 @ y
								put: (thisScanline at: x)].
					^ self].
			bitsPerChannel = 1
				ifTrue: [pixPerByte _ 8.
					mask _ 1.
					shifts _ #(7 6 5 4 3 2 1 0 )].
			bitsPerChannel = 2
				ifTrue: [pixPerByte _ 4.
					mask _ 3.
					shifts _ #(6 4 2 0 )].
			bitsPerChannel = 4
				ifTrue: [pixPerByte _ 2.
					mask _ 15.
					shifts _ #(4 0 )].
			pixelNumber _ 0.
			0 to: width - 1 do: [:x | 
				rawByte _ thisScanline at: pixelNumber // pixPerByte + 1.
				pixel _ rawByte
							>> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask.
				pixel = transparentPixelValue ifTrue: [pixel _ transparentIndex].
				blitter pixelAt: x @ y put: pixel.
				pixelNumber _ pixelNumber + 1
			]
		]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGray: y at: startX by: incX
	"Handle interlaced grayscale color mode (colorType = 0)"

	| b offset bits w pixel mask blitter pixelNumber pixPerByte rawByte
shifts |
	bitsPerChannel = 16
		ifTrue: [
			b _ BitBlt current bitPokerToForm: form.
			startX to: width-1 by: incX do: [ :x |
				b pixelAt: x@y put: 255 - (thisScanline at: (x//incX<<1)+1).
				].
			^ self
			].
	offset _ y*rowSize+1.
	bits _ form bits.
	bitsPerChannel = 8 ifTrue: [
		startX to: width-1 by: incX do: [ :x |
			w _ offset + (x>>2).
			b _ 3- (x \\ 4) * 8.
			pixel _ (thisScanline at: x // incX + 1)<<b.
			mask _ (255<<b) bitInvert32.
			bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel)
		].
		^ self
	].
	bitsPerChannel = 1 ifTrue: [
		pixPerByte _ 8.
		mask _ 1.
		shifts _ #(7 6 5 4 3 2 1 0).
	].
	bitsPerChannel = 2 ifTrue: [
		pixPerByte _ 4.
		mask _ 3.
		shifts _ #(6 4 2 0).
	].
	bitsPerChannel = 4 ifTrue: [
		pixPerByte _ 2.
		mask _ 15.
		shifts _ #(4 0).
	].

	blitter _ BitBlt current bitPokerToForm: form.
	pixelNumber _ 0.
	startX to: width-1 by: incX do: [ :x |
		rawByte _ thisScanline at: (pixelNumber // pixPerByte) + 1.
		pixel _ (rawByte >> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask.
		blitter pixelAt: (x@y) put: pixel.
		pixelNumber _ pixelNumber + 1.
	].
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGrayAlpha: y
	"Handle non-interlaced grayscale with alpha color mode (colorType = 4)"

	| i pixel gray b |
	b _ BitBlt current bitPokerToForm: form.
	bitsPerChannel = 8
		ifTrue: [
			0 to: width-1 do: [ :x |
				i _ (x << 1) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
		ifFalse: [
			0 to: width-1 do: [ :x |
				i _ (x << 2) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:09'!
copyPixelsGrayAlpha: y at: startX by: incX
	"Handle interlaced grayscale with alpha color mode (colorType = 4)"

	| i pixel gray b |
	b _ BitBlt current bitPokerToForm: form.
	bitsPerChannel = 8
		ifTrue: [
			startX to: width-1 by: incX do: [ :x |
				i _ (x // incX << 1) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+1)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
		ifFalse: [
			startX to: width-1 by: incX do: [ :x |
				i _ (x // incX << 2) + 1.
				gray _ thisScanline at: i.
				pixel _ ((thisScanline at: i+2)<<24) + (gray<<16) + (gray<<8) + gray.
				b pixelAt: x@y put: pixel.
				]
			]
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:10'!
copyPixelsIndexed: y
	"Handle non-interlaced indexed color mode (colorType = 3)"
	| blitter pixPerByte mask shifts pixelNumber rawByte pixel |
	blitter _ BitBlt current bitPokerToForm: form.
	bitsPerChannel = 8
		ifTrue:
			[1 to: width do: [:x | blitter pixelAt: x - 1 @ y put: (thisScanline at: x)].
			^ self].
	bitsPerChannel = 1
		ifTrue:
			[pixPerByte _ 8.
			mask _ 1.
			shifts _ #(7 6 5 4 3 2 1 0 )].
	bitsPerChannel = 2
		ifTrue:
			[pixPerByte _ 4.
			mask _ 3.
			shifts _ #(6 4 2 0 )].
	bitsPerChannel = 4
		ifTrue:
			[pixPerByte _ 2.
			mask _ 15.
			shifts _ #(4 0 )].
	pixelNumber _ 0.
	0 to: width - 1 do:
		[:x |
		rawByte _ thisScanline at: pixelNumber // pixPerByte + 1.
		pixel _ rawByte >> (shifts at: pixelNumber \\ pixPerByte + 1) bitAnd: mask.
		blitter pixelAt: x @ y put: pixel.
		pixelNumber _ pixelNumber + 1]! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:23'!
copyPixelsIndexed: y at: startX by: incX
	"Handle interlaced indexed color mode (colorType = 3)"

	| offset b bits w pixel mask pixPerByte shifts blitter pixelNumber rawByte |
	offset _ y*rowSize+1.
	bits _ form bits.
	bitsPerChannel = 8
		ifTrue: [
			startX to: width-1 by: incX do: [ :x |
				w _ offset + (x>>2).
				b _ 3 - (x \\ 4) * 8.
				pixel _ (thisScanline at: x // incX + 1)<<b.
				mask _ (255<<b) bitInvert32.
				bits at: w put: (((bits at: w) bitAnd: mask) bitOr: pixel)].
			^ self ].
	bitsPerChannel = 1 ifTrue: [
		pixPerByte _ 8.
		mask _ 1.
		shifts _ #(7 6 5 4 3 2 1 0).
	].
	bitsPerChannel = 2 ifTrue: [
		pixPerByte _ 4.
		mask _ 3.
		shifts _ #(6 4 2 0).
	].
	bitsPerChannel = 4 ifTrue: [
		pixPerByte _ 2.
		mask _ 15.
		shifts _ #(4 0).
	].

	blitter _ BitBlt current bitPokerToForm: form.
	pixelNumber _ 0.
	startX to: width-1 by: incX do: [ :x |
		rawByte _ thisScanline at: (pixelNumber // pixPerByte) + 1.
		pixel _ (rawByte >> (shifts at: (pixelNumber \\ pixPerByte) + 1)) bitAnd: mask.
		blitter pixelAt: (x@y) put: pixel.
		pixelNumber _ pixelNumber + 1.
	].
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/7/2000 09:30'!
copyPixelsRGB: y
	"Handle non-interlaced RGB color mode (colorType = 2)"

	| i pixel tempForm tempBits |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	pixel at: 4 put: 16rFF.
	bitsPerChannel = 8 ifTrue: [
		i := 1.
		1 to: width do: [ :x |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: x put: pixel.
			i _ i + 3.
		]
	] ifFalse: [
		i := 1.
		1 to: width do: [ :x |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x put: pixel.
			i _ i + 6.
		]
	].
	transparentPixelValue ifNotNil: [
		1 to: width do: [ :x |
			(tempBits at: x) = transparentPixelValue ifTrue: [
				tempBits at: x put: 0.
			].
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paint.
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/5/2000 11:16'!
copyPixelsRGB: y at: startX by: incX
	"Handle interlaced RGB color mode (colorType = 2)"

	| i pixel tempForm tempBits xx loopsToDo |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	pixel at: 4 put: 16rFF.
	loopsToDo _ width - startX + incX - 1 // incX.
	bitsPerChannel = 8 ifTrue: [
		i _ (startX // incX * 3) + 1.
		xx _ startX+1.
		1 to: loopsToDo do: [ :j |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: xx put: pixel.
			i _ i + 3.
			xx _ xx + incX.
		]
	] ifFalse: [
		i _ (startX // incX * 6) + 1.
		xx _ startX+1.
		1 to: loopsToDo do: [ :j |
			pixel
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: xx put: pixel.
			i _ i + 6.
			xx _ xx + incX.
		].
	].
	transparentPixelValue ifNotNil: [
		startX to: width-1 by: incX do: [ :x |
			(tempBits at: x+1) = transparentPixelValue ifTrue: [
				tempBits at: x+1 put: 0.
			].
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paint.

! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 16:20'!
copyPixelsRGBA: y
	"Handle non-interlaced RGBA color modes (colorType = 6)"

	| i pixel tempForm tempBits |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	bitsPerChannel = 8 ifTrue: [
		i := -3.
		0 to: width-1 do: [ :x |
			i := i + 4.
			pixel at: 4 put: (thisScanline at: i+3);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: x+1 put: pixel.
		]
	] ifFalse: [
		i := -7.
		0 to: width-1 do: [ :x |
			i := i + 8.
			pixel at: 4 put: (thisScanline at: i+6);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x+1 put: pixel.
		]
	].
	tempForm displayOn: form at: 0@y rule: Form paint.
! !

!PNGReadWriter methodsFor: 'pixel copies' stamp: 'RAA 11/4/2000 18:14'!
copyPixelsRGBA: y at: startX by: incX
	"Handle interlaced RGBA color modes (colorType = 6)"

	| i pixel tempForm tempBits |

	tempForm _ Form extent: width@1 depth: 32.
	tempBits _ tempForm bits.
	pixel := LargePositiveInteger new: 4.
	bitsPerChannel = 8 ifTrue: [
		i _ (startX // incX << 2) + 1.
		startX to: width-1 by: incX do: [ :x |
			pixel at: 4 put: (thisScanline at: i+3);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+1);
				at: 1 put: (thisScanline at: i+2).
			tempBits at: x+1 put: pixel.
			i _ i + 4.
		]
	] ifFalse: [
		i _ (startX // incX << 3) +1.
		startX to: width-1 by: incX do: [ :x |
			pixel at: 4 put: (thisScanline at: i+6);
				at: 3 put: (thisScanline at: i);
				at: 2 put: (thisScanline at: i+2);
				at: 1 put: (thisScanline at: i+4).
			tempBits at: x+1 put: pixel.
			i _ i + 8.
		].
	].
	tempForm displayOn: form at: 0@y rule: Form paint.

! !


!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'DSM 4/27/2000 13:09'!
doPass: pass
	"Certain interlace passes are skipped with certain small image
dimensions"

	pass = 1 ifTrue: [ ^ true ].
	((width = 1) and: [height = 1]) ifTrue: [ ^ false ].
	pass = 2 ifTrue: [ ^ width >= 5 ].
	pass = 3 ifTrue: [ ^ height >= 5 ].
	pass = 4 ifTrue: [ ^ (width >=3 ) or: [height >= 5] ].
	pass = 5 ifTrue: [ ^ height >=3 ].
	pass = 6 ifTrue: [ ^ width >=2 ].
	pass = 7 ifTrue: [ ^ height >=2 ].

! !

!PNGReadWriter methodsFor: 'miscellaneous' stamp: 'RAA 11/4/2000 12:07'!
grayColorsFor: d
	"return a color table for a gray image"

	palette _ Array new: 1<<d.
	d = 1 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: Color white.
		^ palette,{Color transparent}
		].
	d = 2 ifTrue: [
		palette at: 1 put: Color black.
		palette at: 2 put: (Color gray: 0.3333).
		palette at: 3 put: (Color gray: 0.6667).
		palette at: 4 put: Color white.
		^ palette,{Color transparent}.
		].
	d = 4 ifTrue: [
		0 to: 15 do: [ :g |
			palette at: g+1 put: (Color gray: (g/15) asFloat) ].
		^ palette,{Color transparent}
		].
	d = 8 ifTrue: [
		0 to: 255 do: [ :g |
			palette at: g+1 put: (Color gray: (g/255) asFloat) ].
		^ palette		"??transparent??"
		].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PNGReadWriter class
	instanceVariableNames: ''!

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:22'!
createAFormFrom: data

	| error f |

	error _ ''.
	f _ [
		self formFromStream: (RWBinaryOrTextStream with: data)
	] ifError: [ :a :b |
		error _ a printString,'  ',b printString.
		(StringMorph contents: error) color: Color red; imageForm
	].
	^{f. error}! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:20'!
debugging: aBoolean

	Debugging _ aBoolean! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/4/2000 10:51'!
initialize
	"
	PNGReadWriter initialize
	"

	BPP _ {	#(1 2 4 8 16).
			#(0 0 0 0 0).
			#(0 0 0 24 48).
			#(1 2 4 8 0).
			#(0 0 0 16 32).
			#(0 0 0 0 0).
			#(0 0 0 32 64).
			#(0 0 0 0 0) }.

	BlockHeight _ #(8 8 4 4 2 2 1).
	BlockWidth _ #(8 4 4 2 2 1 1)
! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 11/7/2000 09:15'!
insertMorph: aMorph named: aString into: aBook

	| newPage |

	aBook ifNil: [^self].
	newPage _ aBook insertPageLabel: aString morphs: {aMorph}.
	newPage color: Color lightYellow.
	newPage extent: (
		newPage submorphs inject: 10@10 into: [ :ex :m |
			m left: 10.
			ex max: m width @ m bottom
		]
	) + (20@20).
! !

!PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'RAA 12/10/2000 10:11'!
test1
"PNGReadWriter test1"
	| data t error d0 d1 f fileInfo book result d2 |

	Debugging _ true.
	1 = 1 ifTrue: [
		book _ BookMorph new.
		book setProperty: #transitionSpec toValue: {'silence'. #none. #none}.
	].
	d0 _ FileDirectory default.
	d1 _ d0 directoryNamed: 'PngSuite Folder'.
	d2 _ d0 directoryNamed: 'BIG PNG'.
	{d0. d1. d2}.		"keep compiler quiet"
"==
citrus_none_sub.png
citrus_adm7_adap.png
citrus_adm7_aver.png
citrus_adm7_non.png
citrus_adm7_paeth.png
pngs-img-ie5mac.png
=="
	fileInfo _ {
		d2. {'citrus_adm7_adap.png'}.
		"d1. d1 fileNames."
	}.
	fileInfo pairsDo: [ :dir :fileNames |
		fileNames do: [ :each |
			Transcript cr; show: each.
			data _ (dir fileNamed: each) contentsOfEntireFile.
			error _ ''.
			MessageTally spyOn: [
				t _ [
					result _ self createAFormFrom: data.
					f_ result first.
					error _ result second.
				] timeToRun.].
			self insertMorph: f asMorph named: each into: book.
			Transcript show: each,'  ',data size printString,' = ',t printString,' ms',error; cr.
		].
	].
	book ifNotNil: [book openInWorld].
	Debugging _ false.! !
Object subclass: #POEdgeList
	instanceVariableNames: 'vertices halfedges faces '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POEdgeList commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POEdgeList methodsFor: 'accessing' stamp: 'ar 4/6/2000 18:56'!
edgeFrom: start to: end 
	| startVertex endVertex halfedge twinedge oldedge |
	start asPoint = end asPoint ifTrue: [self error: 'start = end'].
	startVertex _ self vertexAt: start.
	endVertex _ self vertexAt: end.
	halfedge _ POHalfedge new origin: startVertex.
	twinedge _ POHalfedge new origin: endVertex.
	halfedge opposite: twinedge;
	 next: twinedge;
	 prev: twinedge.
	twinedge opposite: halfedge;
	 next: halfedge;
	 prev: halfedge.
	oldedge _ self halfedges at: halfedge ifAbsent:
			[startVertex halfedge ifNil: [startVertex halfedge: halfedge]
				ifNotNil: [self attachHalfedge: halfedge].
			endVertex halfedge ifNil: [endVertex halfedge: twinedge]
				ifNotNil: [self attachHalfedge: twinedge].
			self halfedges at: twinedge put: twinedge.
			self halfedges at: halfedge put: halfedge.].
	^ oldedge! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 1/17/2000 12:07'!
faces
	^ faces! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 1/17/2000 12:07'!
halfedges
	^ halfedges! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:00'!
length
	| total |
	total _ 0.
	self halfedges do: [:edge | total _ total + edge length].
	^ total / 2! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 1/25/2000 16:27'!
removeTriangle: triangle 
	self faces removeKey: triangle ifAbsent: [^ self].
	triangle vertices do: [:vertex | vertex faces remove: triangle]! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:48'!
triangle: first to: second to: third 
	| e1 e2 e3 triangle oldtriangle area p1 p2 p3 |
	p1 _ first.
	p2 _ second.
	p3 _ third.
	area _ p2 y + p1 y * (p2 x - p1 x) + (p3 y + p2 y * (p3 x - p2 x)) + (p1 y + p3 y * (p1 x - p3 x)).
	area positive
		ifTrue: 
			[p1 _ second.
			p2 _ first].
	e1 _ self edgeFrom: p1 to: p2.
	e2 _ self edgeFrom: p2 to: p3.
	e3 _ self edgeFrom: p3 to: p1.
	triangle _ POTriangle
				with: e1
				with: e2
				with: e3.
	oldtriangle _ self faces at: triangle ifAbsent: [self faces at: triangle put: triangle].
	triangle vertices do: [:vertex | vertex faces add: triangle].
	^ oldtriangle! !

!POEdgeList methodsFor: 'accessing' stamp: 'ar 4/6/2000 18:55'!
vertexAt: aPoint 
	| oldVertex |
	oldVertex _ self vertices at: aPoint asPoint ifAbsentPut: [POVertex at: aPoint].
	^ oldVertex! !

!POEdgeList methodsFor: 'accessing' stamp: 'laza 1/17/2000 12:07'!
vertices
	^ vertices! !


!POEdgeList methodsFor: 'edges' stamp: 'laza 1/13/2000 17:00'!
incidentEdgesAt: aVertex 
	^ self halfedges select: [:edge | edge origin = aVertex]! !

!POEdgeList methodsFor: 'edges' stamp: 'ar 4/6/2000 18:35'!
removeEdge: anEdge 
	anEdge origin isDeadEnd
		ifTrue: [self vertices removeKey: (anEdge origin halfedge: nil) asPoint
				ifAbsent: []]
		ifFalse: [self cutHalfedge: anEdge].
	anEdge opposite origin isDeadEnd
		ifTrue: [self vertices removeKey: (anEdge destination halfedge: nil) asPoint
				ifAbsent: []]
		ifFalse: [self cutHalfedge: anEdge opposite].
	self halfedges removeKey: anEdge ifAbsent: [].
	self halfedges removeKey: anEdge opposite ifAbsent: [].! !


!POEdgeList methodsFor: 'initializing' stamp: 'laza 1/14/2000 14:20'!
initialize
	vertices _ Dictionary new.
	halfedges _ Dictionary new.
	faces _ Dictionary new! !


!POEdgeList methodsFor: 'private' stamp: 'laza 1/13/2000 17:00'!
attachHalfedge: aHalfedge 
	| left right |
	left _ self closestEdgeTo: aHalfedge.
	right _ left prev.
	aHalfedge prev: right.
	right next: aHalfedge.
	aHalfedge opposite next: left.
	left prev: aHalfedge opposite! !

!POEdgeList methodsFor: 'private' stamp: 'laza 3/23/2000 12:13'!
closestEdgeTo: aHalfedge
	| minAngle angle minEdge |
	minAngle _ 2 * Float pi.
	(self incidentEdgesAt: aHalfedge origin)
		do: 
			[:edge | 
			angle _ edge angleTo: aHalfedge.
			angle < minAngle
				ifTrue: 
					[minAngle _ angle.
					minEdge _ edge]].
	^ minEdge! !

!POEdgeList methodsFor: 'private' stamp: 'laza 1/13/2000 17:00'!
cutHalfedge: anEdge
	anEdge prev next: anEdge opposite next.
	anEdge opposite next prev: anEdge prev.
	anEdge origin halfedge: anEdge opposite next. ! !


!POEdgeList methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:00'!
clearAllEdgeTags
	self halfedges do: [:edge | edge clearAllTags]! !

!POEdgeList methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:00'!
clearAllTags
	self clearAllEdgeTags.
	self clearAllVertexTags! !

!POEdgeList methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:00'!
clearAllVertexTags
	self vertices do: [:vertex | vertex clearAllTags]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POEdgeList class
	instanceVariableNames: ''!

!POEdgeList class methodsFor: 'instance creation' stamp: 'laza 3/23/2000 15:56'!
new
	| el |
	el _ super new initialize.
	"(TDEdgeListDebuggerMorph on: el) openInWorld."
	^ el! !
Object subclass: #POHalfedge
	instanceVariableNames: 'opposite next prev origin face tags '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POHalfedge commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
destination
	^ self opposite origin! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
destination: aVertex
	self opposite origin: aVertex! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
face
	^ face! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
face: anObject
	face _ anObject! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
midpoint
	^ self origin + self destination /2! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
next
	^next! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
next: aHalfedge
	next _ aHalfedge! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
opposite
	^ opposite! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
opposite: aHalfedge
	opposite _ aHalfedge! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
origin
	^ origin! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
origin: aVertex 
	origin _ aVertex! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/24/2000 04:02'!
otherEnd: aVertex
	self origin = aVertex ifTrue: [^ self destination]
ifFalse: [^ self origin]! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
prev
	^ prev! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
prev: aHalfedge 
	prev _ aHalfedge! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/24/2000 11:34'!
sharesVertexWith: aHalfedge 
	(self origin = aHalfedge origin or: [self origin = aHalfedge destination])
		ifTrue: [^ self origin].
	(self destination = aHalfedge origin or: [self destination = aHalfedge destination])
		ifTrue: [^ self destination].
	^ nil! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
tags
	tags ifNil: [tags _ Dictionary new].
	^ tags! !

!POHalfedge methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:01'!
tags: aDictionary 
	tags _ aDictionary! !


!POHalfedge methodsFor: 'comparing' stamp: 'laza 1/13/2000 17:01'!
= aHalfedge
	^ (self origin = aHalfedge origin) and: [self opposite origin = aHalfedge opposite origin]! !

!POHalfedge methodsFor: 'comparing' stamp: 'laza 1/13/2000 17:01'!
hash
	^ self origin hash! !


!POHalfedge methodsFor: 'measure' stamp: 'laza 3/23/2000 12:17'!
angleTo: anHalfedge 
	"Returns the angle in radians between self and anHalfedge as if they
	had the same origin. The angle is measured counter clockwise."
	| angle |
	angle _ ((self vector dotProduct: anHalfedge vector)
				/ (self length * anHalfedge length)) safeArcCos.
	(self sideOf: anHalfedge destination)
		= #right ifTrue: [angle _ 2 * Float pi - angle].
	^ angle!
]style[(19 2 134 216)f1b,f1,f1cblack;,f1! !

!POHalfedge methodsFor: 'measure' stamp: 'laza 1/13/2000 17:01'!
length
	^ self vector r! !

!POHalfedge methodsFor: 'measure' stamp: 'laza 1/13/2000 17:01'!
vector
	^ self destination - self origin! !


!POHalfedge methodsFor: 'printing' stamp: 'laza 1/13/2000 17:01'!
printOn: aStream 
	self origin printOn: aStream.
	aStream nextPutAll: '->'.
	self opposite origin printOn: aStream.	! !


!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:01'!
clearAllTags
	self tags: Dictionary new! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/29/2000 20:46'!
clearTag: aSymbol 
	self tags removeKey: aSymbol ifAbsent: []!
]style[(10 7 3 4 17 7 13)f1b,f1cmagenta;ib,f1,f1cblue;b,f1,f1cmagenta;b,f1! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:01'!
getTag: aSymbol 
	^ self tags at: aSymbol ifAbsent: [nil]! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:01'!
setTag: aSymbol 
	self tags at: aSymbol put: true! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:01'!
setTag: aSymbol to: anObject
	self tags at: aSymbol put: anObject! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/25/2000 16:36'!
setTagAll: aSymbol 
	self setTagEdge: aSymbol.
	self setTagEnds: aSymbol! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/25/2000 16:35'!
setTagEdge: aSymbol 
	self setTag: aSymbol.
	self opposite setTag: aSymbol! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/25/2000 16:34'!
setTagEnds: aSymbol
	self origin setTag: aSymbol.
	self destination setTag: aSymbol.! !

!POHalfedge methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:01'!
testTag: aSymbol 
	^ self tags includesKey: aSymbol! !


!POHalfedge methodsFor: 'testing' stamp: 'laza 1/13/2000 17:01'!
hasAllInsideCircle: aCollection 
	"Tests if all Points in aCollection are inside the circle which has this  
	edge as a diameter"
	aCollection do: [:aPoint | (self origin - aPoint dotProduct: self destination - aPoint)
			> 0 ifTrue: [^ false]].
	^ true! !

!POHalfedge methodsFor: 'testing' stamp: 'ar 4/6/2000 18:56'!
oneEndIs: aVertex
	^(self origin asPoint = aVertex asPoint or: [self destination asPoint = aVertex asPoint])! !

!POHalfedge methodsFor: 'testing' stamp: 'laza 1/13/2000 17:01'!
sideOf: aPoint 
	| result |
	result _ self destination - self origin crossProduct: aPoint - self origin.
	result > 0 ifTrue: [^ #left].
	result < 0 ifTrue: [^ #right].
	^ #center! !


!POHalfedge methodsFor: 'converting' stamp: 'laza 1/26/2000 17:09'!
asB3DVector3
	^ self destination asB3DVector3 - self origin asB3DVector3! !
Object subclass: #POObject
	instanceVariableNames: 'triangulation polygon skeleton '
	classVariableNames: 'Subdivisions '
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POObject commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:19'!
polygon
	^polygon! !

!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:16'!
polygon: anObject
	polygon _ anObject! !

!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:57'!
skeleton
	^skeleton! !

!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 12:00'!
skeleton: anObject
	skeleton _ anObject! !

!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:18'!
triangulation
	^triangulation! !

!POObject methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:16'!
triangulation: anObject
	triangulation _ anObject! !


!POObject methodsFor: 'converting' stamp: 'laza 3/29/2000 03:29'!
asB3DSimpleMesh
	| facets rightEyelets leftEyelets bounds triangle rightLeg end |
	bounds _ self polygon bounds.
	self elevateSpine.
	facets _ OrderedCollection new.

	end _ triangle _ self triangulation faces keys anyOne.
	leftEyelets _ self eyeletsFor: triangle leftLeg in: bounds extent.

	[
		rightLeg _ triangle rightLeg.
		rightEyelets _ self eyeletsFor: rightLeg in: bounds extent.
		self tie: leftEyelets with: rightEyelets to: facets.
		
		leftEyelets _ rightEyelets.
		triangle _ rightLeg opposite face.
		triangle = end] whileFalse.

	self addOtherHemisphereTo: facets.

	^ (B3DSimpleMesh withAll: facets) asIndexedMesh! !


!POObject methodsFor: 'skeleton' stamp: 'laza 1/17/2000 11:38'!
classify
	| count |
	self triangulation faces do: [:triangle |
		count _ triangle borderEdges size.
		count = 0 ifTrue: [triangle type: #junction].
		count = 1 ifTrue: [triangle type: #sleeve].
		count = 2 ifTrue: [triangle type: #terminal]]
		! !

!POObject methodsFor: 'skeleton' stamp: 'laza 1/31/2000 06:40'!
elevateSpine
	| spineVertices triangle edge spineEdges height |
	spineVertices _ self triangulation vertices
				select: [:vertex | (vertex testTag: #spine)
						and: [(self polygon vertices includes: vertex asPoint) not]].
	spineVertices size = 0
		ifTrue: 
			[triangle _ self triangulation faces keys someElement.
			edge _ triangle borderEdges first.
			spineVertices _ Array with: (triangle oppositeVertexOf: edge)].
	spineVertices do: [:vertex | vertex z: ((self triangulation incidentEdgesAt: vertex)
				collect: [:each | each length]) average].
	spineVertices do: 
		[:vertex | 
		spineEdges _ (self triangulation incidentEdgesAt: vertex)
					select: [:halfedge | halfedge testTag: #spine].
		spineEdges size > 0
			ifTrue: 
				[height _ (spineEdges collect: [:halfedge | halfedge destination z]) average.
				vertex z: height]]! !

!POObject methodsFor: 'skeleton' stamp: 'laza 1/31/2000 05:35'!
prune
	| terminals triangle edge corner fanEnds outer fanCenter further edgePrev postProcess untouched junctions sleeves bottom mid1 mid2 index left right newedge inner |
	postProcess _ Set new.
	terminals _ (self triangulation faces select: [:each | each type = #terminal]) keys.
	terminals do: 
		[:terminal | 
		triangle _ terminal.
		edgePrev _ nil.
		edge _ triangle innerEdges first.
		corner _ triangle oppositeVertexOf: edge.
		fanEnds _ OrderedCollection with: corner.
		[triangle type ~= #junction and: [edge hasAllInsideCircle: fanEnds]]
			whileTrue: 
				[self triangulation removeTriangle: triangle;
				 removeEdge: edge.
				triangle _ edge opposite face.
				edgePrev _ edge.
				edge _ (triangle innerEdges copyWithout: edge opposite) first.
				corner _ triangle oppositeVertexOf: edge.
				fanEnds add: corner].
		triangle type = #sleeve
			ifTrue: 
				[self triangulation removeTriangle: triangle.
				outer _ edge next.
				fanCenter _ edge midpoint.
				"self triangulation removeEdge: edge."
				[outer origin = edge origin]
					whileFalse: 
						[further _ outer next.
						self triangulation
							triangle: fanCenter
							to: outer origin
							to: outer destination.
						outer _ further]].
		triangle type = #junction
			ifTrue: 
				[postProcess add: triangle.
				self triangulation removeTriangle: triangle.
				outer _ edgePrev next.
				fanCenter _ triangle center.
				self triangulation removeEdge: edgePrev.
				[outer origin = edgePrev origin]
					whileFalse: 
						[further _ outer next.
						self triangulation
							triangle: fanCenter
							to: outer origin
							to: outer destination.
						outer _ further]]].
	junctions _ (self triangulation faces select: [:each | each type = #junction]) keys.
	postProcess addAll: junctions.
	postProcess do: 
		[:face | 
		self triangulation removeTriangle: face.
		untouched _ face edges select: [:halfedge | self triangulation halfedges includes: halfedge].
		untouched do: 
			[:halfedge | 
			"self triangulation removeEdge: halfedge."
			triangle _ self triangulation
						triangle: face center
						to: halfedge origin
						to: halfedge destination.
			triangle type: #inner.
			edge _ self triangulation edgeFrom: face center to: halfedge origin.
			edge setTag: #border.
			edge opposite setTag: #border.
			edge _ self triangulation edgeFrom: face center to: halfedge destination.
			edge setTag: #border.
			edge opposite setTag: #border]].
	sleeves _ (self triangulation faces select: [:each | each type = #sleeve]) keys.
	sleeves do: 
		[:face | 
		self triangulation removeTriangle: face.
		bottom _ face borderEdges first.
		index _ face edges indexOf: bottom.
		left _ face edges atWrap: index + 1.
		right _ face edges atWrap: index + 2.
		mid1 _ left midpoint.
		mid2 _ right midpoint.
		self triangulation removeEdge: left;
		 removeEdge: right.
		(bottom origin
			isInsideCircle: bottom destination
			with: mid1
			with: mid2)
			ifTrue: [corner _ bottom origin]
			ifFalse: [corner _ bottom destination].
		self triangulation
			triangle: mid1
			to: mid2
			to: corner;
		
			triangle: bottom origin
			to: bottom destination
			to: (face oppositeEdgeOf: corner) midpoint;
		
			triangle: mid2
			to: mid1
			to: (face oppositeVertexOf: bottom).
		edge _ self triangulation edgeFrom: mid1 to: mid2.
		edge setTagAll: #spine].
	terminals _ (self triangulation faces
				select: [:each | each type = #terminal or: [each type = #inner]]) keys.
	terminals do: 
		[:face | 
		self triangulation removeTriangle: face.
		edge _ face innerEdges first.
		corner _ face oppositeVertexOf: edge.
		(self triangulation
			triangle: corner
			to: edge origin
			to: edge midpoint)
			type: face type.
		(self triangulation
			triangle: corner
			to: edge destination
			to: edge midpoint)
			type: face type.
		newedge _ self triangulation edgeFrom: corner to: edge midpoint.
		newedge setTagAll: #spine].
	inner _ (self triangulation faces select: [:each | each type = #inner]) keys.
	inner do: [:face | face edges do: 
			[:halfedge | 
			halfedge clearTag: #border.
			halfedge opposite clearTag: #border]]! !

!POObject methodsFor: 'skeleton' stamp: 'laza 1/17/2000 12:04'!
tailor
	| edge |
	self polygon circulation = #left ifTrue: [self polygon reverseCirculation].
	self polygon do: 
		[:point | 
		edge _ self triangulation edgeFrom: point to: (self polygon after: point).
		edge opposite setTag: #border.
		edge face
			ifNotNil: 
				[self triangulation removeTriangle: edge face.
				edge face: nil]]! !


!POObject methodsFor: 'private' stamp: 'laza 4/5/2000 09:53'!
addOtherHemisphereTo: facets
	| oppositeFacets oppositeVertices vertex |
	oppositeFacets _ OrderedCollection new.

	facets do:
		[:tri|
			oppositeVertices _ Array new: 3.
			1 to: tri size do:
				[:idx|
					vertex _ tri at: idx.
					"vertex position z = 0
						ifFalse: ["
							vertex _ vertex deepCopy.
							vertex position z: (vertex position z negated).
							vertex texCoord ifNotNil: [vertex texCoord u: (1.0 - (vertex texCoord u))].
							vertex normal ifNotNil: [vertex normal z: (vertex normal z negated)].
					self flag: #TODO. "Orientation?"
					oppositeVertices at: idx put: vertex]. 
			oppositeFacets add: (B3DSimpleMeshFace withAll: oppositeVertices)].

	facets addAll: oppositeFacets
					! !

!POObject methodsFor: 'private' stamp: 'laza 4/4/2000 09:52'!
b3dVertexAt: aB3DVector normal: norm in: extent
	| vertex tpos center uc vc |
	vertex _ B3DSimpleMeshVertex new position: aB3DVector.
	center _ extent * 0.5.
	uc _ ((center x + aB3DVector x / extent x * 0.5) min: 0.5) max: 0.0.
	vc _ ((center y + aB3DVector y / extent y) min: 1.0) max: 0.0.
	tpos _ B3DVector2 u: uc v: vc.
	vertex texCoord: tpos.
	vertex normal: norm.
	^ vertex
! !

!POObject methodsFor: 'private' stamp: 'laza 3/28/2000 18:40'!
eyeletsFor: aHalfedge in: extent
	| eyelets start end axis center rotation nib scale abscissa ordinate omega pos |
	eyelets _ OrderedCollection new: Subdivisions + 1.
	aHalfedge origin z = 0
		ifTrue: [start _ aHalfedge origin. end _ aHalfedge destination]
		ifFalse: [start _ aHalfedge destination. end _ aHalfedge origin].
	start _ start asB3DVector3.
	end _ end asB3DVector3.
	axis _ end - start cross: 0 @ 0 @ 1.
	center _ end copy z: 0.
	abscissa _ (center - start) length.
	ordinate _ end z.
	omega _ 90.0 / Subdivisions.
	scale _ (end - center) length.
	nib _ end - center / scale.
	rotation _ (B3DRotation angle: omega axis: axis) asMatrix4x4.
	1 to: Subdivisions do: 
		[:segment |
		pos _ nib * scale + center.
		eyelets add: (self b3dVertexAt: pos normal: nib in: extent).
		nib _ rotation localPointToGlobal: nib.
		scale _ (((omega * segment) degreeCos * ordinate) squared + ((omega * segment) degreeSin * abscissa) squared) sqrt].
	pos _ start.
	eyelets add: (self b3dVertexAt: pos normal: nib in: extent).
	^ eyelets! !

!POObject methodsFor: 'private' stamp: 'laza 3/28/2000 12:20'!
tie: left with: right to: facets
	| offset |
	left first position = right first position
		ifTrue: [
			facets add:
				(B3DSimpleMeshFace
					with: left first
					with: right second
					with: left second).
				offset _ 1]
		ifFalse: [
			facets add:
				(B3DSimpleMeshFace
					with: right last
					with: (left at: Subdivisions)
					with: (right at: Subdivisions)).
				offset _ 0].

	1 + offset to: Subdivisions - 1 + offset do:
		[:idx|
			facets add:
					(B3DSimpleMeshFace
						with: (left at: idx)
						with: (right at: idx)
						with: (left at: idx + 1));
				add:
					(B3DSimpleMeshFace
						with: (right at: idx)
						with: (right at: idx + 1)
						with: (left at: idx + 1))]



! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POObject class
	instanceVariableNames: ''!

!POObject class methodsFor: 'instance creation' stamp: 'laza 3/24/2000 13:48'!
createOn: aSimplePolygon
	| tdo  |
	tdo _ self new.
	tdo polygon: aSimplePolygon.
	tdo triangulation: (POTriangulation on: aSimplePolygon vertices).
	tdo tailor; classify; prune.
	^ tdo! !


!POObject class methodsFor: 'initialize-release' stamp: 'laza 1/29/2000 19:09'!
initialize
	"TDObject initialize"
	Subdivisions _ 6! !


!POObject class methodsFor: 'tests' stamp: 'laza 3/24/2000 13:49'!
test1
	"POObject test1"
	| to v1 v2 h t |
	to _ self new.
	v1 _ POVertex at: 0 @ 20.
	v2 _ (POVertex at: 20 @ 0)
				z: 10.
	h _ POHalfedge new origin: v1.
	t _ POHalfedge new origin: v2.
	h opposite: t.
	t opposite: h.
	(to eyeletsFor: h) inspect! !
SimpleClientSocket subclass: #POPSocket
	instanceVariableNames: 'serverName userName password progressObservers numMessages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!POPSocket commentStamp: '<historical>' prior: 0!
Post Office Protocol.  This is used to download email over the network, usually from an intermittent connection.  To see how to use it, see POPSocket classe>>example.!


!POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:14'!
addProgressObserver: anObserver
	"progress will be sent to anObserver.  anObserver should respond to show:, endEntry, cr....  Transcript things"
	progressObservers add: anObserver! !

!POPSocket methodsFor: 'initialization' stamp: 'ar 5/5/1999 23:25'!
initialize: socketType
	super initialize: socketType.
	progressObservers _ IdentitySet new.! !

!POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:10'!
password: aString
	"set the password to use"
	password _ aString ! !

!POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:22'!
serverName: aString
	"set the server name to connect to"
	serverName _ aString! !

!POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:10'!
userName: aString
	"set the username to use"
	userName _ aString! !


!POPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/14/1998 12:51'!
connectToPOP
	"connect to the POP server"
	| address response |

	Socket initializeNetwork.

	address _ NetNameResolver addressForName: serverName timeout: 15.
	address = nil ifTrue: [
		self error: 'Could not find host address'].

	"connect the socket"
	self connectTo: address port: 110.
	(self waitForConnectionUntil: POPSocket standardDeadline) ifFalse: [
		self close.
		self reportToObservers: 'failed to connect to server'.
		^false ].
	"get a hello message"
	self reportToObservers: (response _ self getResponse).
	(response beginsWith: '+') ifFalse: [ self close.  ^false ].


	"login"
	self sendCommand: 'USER ', userName.
	self reportToObservers: (response _ self getResponse).
	(response beginsWith: '+') ifFalse: [ self close. ^false ].
	self sendCommand: 'PASS ', password.
	self reportToObservers: (response _ self getResponse).
	(response beginsWith: '+') ifFalse: [ self close. ^false ].

	^true! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 01:55'!
deleteAllMessages
	"delete all messages"
	1 to: self numMessages do: [ :num |
		self deleteMessage: num ]! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/7/1998 06:07'!
deleteMessage: num
	"delete the numbered message"
	self sendCommand: 'DELE ', num printString.
	self reportToObservers: self getResponse.
! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/2/1998 16:05'!
disconnectFromPOP
	"Send a QUIT message, then disconnect."

	self isValid ifFalse: [^ self].  "already closed"
	self reportToObservers: 'closing connection'.
	numMessages _ nil.
	self sendCommand: 'QUIT'.
	self reportToObservers: self getResponse.
	self closeAndDestroy.
! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 01:54'!
messagesDo: aBlock
	"perform aBlock on each message text"
	| thisMessage |

	1 to: self numMessages do: [ :num |
		thisMessage _ self retrieveMessage: num.
		aBlock value: thisMessage.
	].
	
! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'mdr 2/16/1999 12:53'!
numMessages
	"Query the server and answer the number of messages that are in the user's mailbox."

	| response answerString |
	numMessages ifNotNil: [^ numMessages].  "cached result of earlier query"

	self sendCommand: 'STAT'.
	response _ self getResponse.
	self reportToObservers: response.
	(response beginsWith: '+OK') ifFalse: [^ 0].  "error"
	answerString _ (response findTokens: Character separators) second.

	"NB: It is important to cache the result so that all operations, especially delete and deleteAll, are done on the same set of messages"
	numMessages _ answerString asNumber asInteger.	"cache the result"

	^ numMessages! !

!POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/7/1998 06:04'!
retrieveMessage: number
	"retrieve the numbered message"
	| response |

	self sendCommand: 'RETR ', number printString.
	response _ self getResponse.
	self reportToObservers: response.
	(response beginsWith: '+OK') ifFalse: [
		self error: 'error: ', response ].

	^self getMultilineResponse.! !


!POPSocket methodsFor: 'private' stamp: 'ls 9/10/1998 19:57'!
reportToObservers: aString
	"send aString to all observers"
	progressObservers do: [ :observer |
		observer show: aString.
		aString last = Character cr ifFalse: [ observer show: String cr ]].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POPSocket class
	instanceVariableNames: ''!

!POPSocket class methodsFor: 'as yet unclassified' stamp: 'ls 9/10/1998 19:44'!
example
	"POPSocket example"
	"download a user's messages into an OrderedCollection and inspect the OrderedCollection"

	| ps messages |
	ps _ POPSocket new.
	ps serverName: (FillInTheBlank request: 'POP server').
	ps userName: (FillInTheBlank request: 'POP username').
	ps password: (FillInTheBlank request: 'POP password').
	ps addProgressObserver: Transcript.

	messages _ OrderedCollection new.
	ps connectToPOP.
	ps messagesDo: [ :messageText |
		messages add: messageText ].
	ps disconnectFromPOP.

	messages inspect.! !
Object subclass: #POSimplePolygon
	instanceVariableNames: 'vertices assorts '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POSimplePolygon commentStamp: '<historical>' prior: 0!
I represent a polygon that is defined by a sequence of vertices. Every vertex is connected to two other vertices.!


!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/5/2000 17:08'!
after: aVertex 
	| index |
	index _ self vertices indexOf: aVertex.
	^ self vertices atWrap: index + 1! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/5/2000 17:08'!
before: aVertex 
	| index |
	index _ self vertices indexOf: aVertex.
	^ self vertices atWrap: index - 1! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 3/21/2000 14:52'!
boundingBox
	^ vertices inject: (vertices first extent: 0@0) into: [:rec :pts| 
		rec encompass: pts].
! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 2/11/2000 11:21'!
bounds
	| origin corner |
	origin _ self vertices first.
	corner _ self vertices last.
	self vertices do: 
		[:vertex | 
		origin _ origin min: vertex.
		corner _ corner max: vertex].
	^ origin corner: corner! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/4/2000 17:21'!
end
	self vertices end! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/5/2000 17:10'!
nextButOne: aVertex 
	| index |
	index _ self vertices indexOf: aVertex.
	^ self vertices atWrap: index + 2! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/5/2000 11:28'!
size
	^ self vertices size! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/4/2000 17:20'!
start
	self vertices first! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/4/2000 16:41'!
vertices
	vertices ifNil: [vertices _ OrderedCollection new].
	^ vertices! !

!POSimplePolygon methodsFor: 'accessing' stamp: 'laza 1/4/2000 16:41'!
vertices: anOrderedCollection
	vertices _ anOrderedCollection
	! !


!POSimplePolygon methodsFor: 'adding' stamp: 'laza 1/4/2000 22:37'!
add: aVertex 
	^ self addLast: aVertex! !

!POSimplePolygon methodsFor: 'adding' stamp: 'laza 1/4/2000 22:38'!
add: newVertex after: oldVertex 
	^ self vertices add: newVertex after: oldVertex! !

!POSimplePolygon methodsFor: 'adding' stamp: 'laza 1/4/2000 22:38'!
add: newVertex before: oldVertex 
	^ self vertices add: newVertex before: oldVertex! !

!POSimplePolygon methodsFor: 'adding' stamp: 'laza 1/17/2000 11:01'!
addAll: aCollection 
^self vertices addAll: aCollection! !

!POSimplePolygon methodsFor: 'adding' stamp: 'laza 1/4/2000 22:38'!
addLast: aVertex 
	^ self vertices addLast: aVertex! !


!POSimplePolygon methodsFor: 'converting' stamp: 'laza 1/6/2000 11:10'!
asEdgeList
	| edgeList |
	edgeList _ POEdgeList new.
	self vertices do: [:vertex | edgeList edgeFrom: vertex to: (self after: vertex)]! !

!POSimplePolygon methodsFor: 'converting' stamp: 'laza 1/5/2000 12:00'!
asSortedCollection
	"Returns a SortedCollection of my vertices. The sort order is      
	lexicographically.    
	This can be used as an eventqueue for sweepline algorithms."
	^ self assorts copy! !

!POSimplePolygon methodsFor: 'converting' stamp: 'laza 4/4/2000 10:00'!
normalizedWithin: bounds
	| center sp box scale |
	scale _ bounds extent y * 0.5.
	scale _ scale @ scale negated.
	box _ self boundingBox.
	center _ box origin + box corner * 0.5.
	sp _ POSimplePolygon new.
	vertices do: [:each|
		sp add: each - center / scale].
	^ sp! !


!POSimplePolygon methodsFor: 'enumerating' stamp: 'laza 1/17/2000 11:09'!
do: aBlock
	self vertices do: aBlock! !


!POSimplePolygon methodsFor: 'geometry' stamp: 'laza 1/4/2000 18:17'!
center
	^ self vertices average! !

!POSimplePolygon methodsFor: 'geometry' stamp: 'laza 3/20/2000 17:09'!
length
	| length |
	length _ 0.
	self vertices do: [:vertex | length _ length + (vertex dist: (self after: vertex))].
	^ length! !

!POSimplePolygon methodsFor: 'geometry' stamp: 'laza 1/17/2000 11:21'!
reverseCirculation
	self vertices: self vertices reversed!
]style[(18 2 4 33)f1b,f1,f1cblue;b,f1! !


!POSimplePolygon methodsFor: 'point reduction' stamp: 'laza 3/20/2000 17:24'!
normalizeTo: normLength
	| num unitLength normalized cumulativeLength proportion edgeLength start end |
	num _ self length // normLength.
	num _ num max: 8.
	unitLength _ self length / num.
	normalized _ OrderedCollection new: num.
	normalized add: self vertices first.
	cumulativeLength _ 0.
	1 to: self vertices size do: [:idx|
		start _ self vertices at: idx.
		end _ self vertices atWrap: idx+1.
		edgeLength _ start dist: end.
		cumulativeLength _ cumulativeLength + edgeLength.
		[cumulativeLength >= unitLength]
			whileTrue: 
				[cumulativeLength _ cumulativeLength - unitLength.
				proportion _ cumulativeLength / edgeLength.
				normalized add: (end interpolateTo: start at: proportion)]].
	self vertices: normalized! !

!POSimplePolygon methodsFor: 'point reduction' stamp: 'laza 1/6/2000 10:58'!
reduceTo: reduceLength 
	| stream start end ahead cumulativeAngle cumulativeLength reduced aheadVector endVector angle found |
	stream _ ReadStream on: self vertices.
	start _ stream next.
	end _ stream next.
	reduced _ OrderedCollection with: start.
	[stream atEnd]
		whileFalse: 
			[cumulativeAngle _ 0.
			cumulativeLength _ 0.
			endVector _ start - end.
			found _ false.
			[found or: [stream atEnd]]
				whileFalse: 
					[ahead _ stream next.
					aheadVector _ end - ahead.
					angle _ endVector theta - aheadVector theta.
					cumulativeAngle _ cumulativeAngle + angle.
					cumulativeLength _ cumulativeLength + endVector r.
					(cumulativeAngle abs > 0.2 or: [cumulativeLength > reduceLength])
						ifTrue: 
							[reduced add: end.
							found _ true].
					found
						ifFalse: 
							[end _ ahead.
							endVector _ aheadVector]].
			start _ end.
			end _ ahead].
	self vertices: reduced! !


!POSimplePolygon methodsFor: 'private' stamp: 'laza 1/5/2000 12:00'!
assorts
	"Builds a SortedCollection of my vertices. The sort order is       
	lexicographically.     
	This can be used as an eventqueue for sweepline algorithms."
	assorts
		ifNil: 
			[assorts _ SortedCollection
						sortBlock: [:a :b | a x < b x
								or: [a x = b x and: [a y < b y]]].
			assorts addAll: self vertices].
	^ assorts! !


!POSimplePolygon methodsFor: 'removing' stamp: 'laza 1/4/2000 22:41'!
remove: aVertex 
	^ self vertices remove: aVertex! !


!POSimplePolygon methodsFor: 'testing' stamp: 'laza 1/6/2000 10:25'!
circulation
"The circulation of a simple polygon can be #left (counterclockwise) or #right (clockwise)"
	| mostLeft |
	self isSimple
		ifTrue: 
			[mostLeft _ self asSortedCollection first.
			^ (self before: mostLeft)
				to: mostLeft sideOf: (self after: mostLeft)].
	self error: 'Polygon is not simple!!'! !

!POSimplePolygon methodsFor: 'testing' stamp: 'laza 1/4/2000 18:13'!
includes: aVertex
	^ self vertices includes: aVertex! !

!POSimplePolygon methodsFor: 'testing' stamp: 'laza 1/4/2000 18:24'!
is: first connectedWith: second 
	^ (self after: first)
		= second or: [self before: first = second]! !

!POSimplePolygon methodsFor: 'testing' stamp: 'laza 1/17/2000 12:16'!
isSimple
	"	| queue edges event prev next sleeve1 sleeve2 |
queue _ self asSortedCollection removeLast; yourself. 
	edges _ OrderedCollection new. 
	[queue isEmpty] 
	whileFalse:  
	[event _ queue removeFirst. 
	prev _ self before: event. 
	next _ self after: event. 
	sleeve1 _ prev x <= event x. 
	sleeve2 _ next x <= event x. 
	sleeve1 ifTrue: [edges remove: prev]. 
	sleeve2 ifTrue: [edges remove: event]. 
	sleeve1 ifFalse: [edges do: [:origin | ((origin 
	to: (self after: origin) 
	intersects: prev 
	to: event) 
	and: [prev ~= (self after: origin)]) 
	ifTrue: [^ false]]]. 
	sleeve2 ifFalse: [edges do: [:origin | ((origin 
	to: (self after: origin) 
	intersects: event 
	to: next) 
	and: [next ~= origin]) 
	ifTrue: [^ false]]]. 
	sleeve1 ifFalse: [edges add: prev]. 
	sleeve2 ifFalse: [edges add: event]]."

	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POSimplePolygon class
	instanceVariableNames: ''!

!POSimplePolygon class methodsFor: 'examples' stamp: 'laza 1/6/2000 10:26'!
testCircle
	"SimplePolygon testCircle"
	| sp |
	sp _ self new vertices: (OrderedCollection new add: 0 @ 50;
				 add: 100 @ 10;
				 add: 200 @ 100;
				 add: 120 @ 300;
				 yourself).
	"add: 150 @ 320;"
	"add: 140 @ 20;"
	self inform: sp circulation asString! !

!POSimplePolygon class methodsFor: 'examples' stamp: 'laza 1/6/2000 10:44'!
testFly
	"SimplePolygon testFly"
	| sp |
	sp _ self new vertices: (OrderedCollection new add: 0 @ 10;
				 add: 10 @ 0;
				 add: 19 @ 10;
				 add: 30 @ 20;
				 add: 40 @ 10;
				 add: 30 @ 0;
				 add: 21 @ 10;
				 add: 10 @ 20;
				 yourself).
	self inform: sp isSimple asString! !

!POSimplePolygon class methodsFor: 'examples' stamp: 'laza 1/6/2000 10:27'!
testTriangle
	"SimplePolygon testTriangle"
	| sp |
	sp _ self new vertices: (OrderedCollection new add: 0 @ 0;
				 add: 10 @ 10;
				 add: 20 @ 0;
				 yourself).
	self inform: sp circulation asString! !
Object subclass: #POTriangle
	instanceVariableNames: 'edges subTriangles type '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POTriangle commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POTriangle methodsFor: 'accessing' stamp: 'laza 1/17/2000 12:01'!
center
	^ (self edges collect: [:each| each origin]) average! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:59'!
edges
	^ edges! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/24/2000 16:27'!
edges: anArray
	edges _ anArray.
	edges do: [:edge | edge face: self]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/26/2000 12:33'!
edgesWithAnyTag
	^ self edges select: [:edge | edge tags isEmptyOrNil not]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:33'!
edgesWithTag: aSymbol
	^ self edges select: [:edge| edge testTag: aSymbol]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/26/2000 09:28'!
edgesWithoutAnyTag
	^ self edges select: [:edge | edge tags isEmptyOrNil]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/17/2000 11:35'!
edgesWithoutTag: aSymbol 
	^ self edges reject: [:edge | edge testTag: aSymbol]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/24/2000 16:35'!
oppositeEdgeOf: aVertex 
	^ (self edges
		detect: [:edge | (edge oneEndIs: aVertex) not]).! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/24/2000 16:37'!
oppositeVertexOf: anEdge 
	^ self vertices detect: [:vertex| (anEdge oneEndIs: vertex) not]! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/14/2000 15:45'!
sharesCornerWith: aTriangle 
	^ self vertices includesAnyOf: aTriangle vertices! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:59'!
subTriangles
	^ subTriangles! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:59'!
subTriangles: anObject
	subTriangles _ anObject! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:59'!
type
	^ type! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:59'!
type: aSymbol
	type _ aSymbol! !

!POTriangle methodsFor: 'accessing' stamp: 'laza 1/14/2000 12:17'!
vertices
	^ self edges collect: [:edge| edge origin]! !


!POTriangle methodsFor: 'comparing' stamp: 'laza 1/25/2000 14:16'!
= aTDTriangle 
	^ self edges asSet = aTDTriangle edges asSet! !

!POTriangle methodsFor: 'comparing' stamp: 'laza 1/14/2000 10:59'!
hash
	^ self edges hash! !


!POTriangle methodsFor: 'converting' stamp: 'laza 1/25/2000 15:30'!
asB3DSimpleMeshFace
	| vectors |
	vectors _ self vertices collect: [:vertex | B3DSimpleMeshVertex new position: vertex asB3DVector3].
	^ B3DSimpleMeshFace withAll: vectors! !


!POTriangle methodsFor: 'point location' stamp: 'laza 1/13/2000 16:59'!
whereIs: aPoint 
	| location side |
	location _ #inside.
	self edges do: 
		[:edge | 
		side _ edge sideOf: aPoint.
		side = #right ifTrue: [^ #outside].
		side = #center ifTrue: [location _ #edge]].
	^ location! !


!POTriangle methodsFor: 'printing' stamp: 'laza 1/13/2000 16:59'!
printOn: aStream 
self type ifNotNil: [self type first asString printOn: aStream].
			self edges do: 
		[:edge | 
		edge origin printOn: aStream]! !


!POTriangle methodsFor: 'skeleton' stamp: 'laza 1/26/2000 09:47'!
borderEdges
	^ self edgesWithTag: #border! !

!POTriangle methodsFor: 'skeleton' stamp: 'laza 1/26/2000 09:47'!
innerEdges
	^ self edgesWithoutTag: #border! !

!POTriangle methodsFor: 'skeleton' stamp: 'laza 1/31/2000 04:54'!
leftLeg
	"If one edge of the triangle is tagged as #border or #spine then return   
	 the edge that is before the border edge or after the spine edge."
	| bidx sidx |
	bidx _ sidx _ 0.
	1 to: self edges size do: 
		[:idx | 
		((self edges at: idx)
			testTag: #border)
			ifTrue: [bidx _ idx].
		((self edges at: idx)
			testTag: #spine)
			ifTrue: [sidx _ idx]].
	bidx > 0 ifTrue: [^ self edges atWrap: bidx + 1].
	^ self edges atWrap: sidx - 1! !

!POTriangle methodsFor: 'skeleton' stamp: 'laza 1/31/2000 04:55'!
rightLeg
	"If one edge of the triangle is tagged as #border or #spine then return   
	the edge that is before the border edge or after the spine edge."
	| bidx sidx |
	bidx _ sidx _ 0.
	1 to: self edges size do: 
		[:idx | 
		((self edges at: idx)
			testTag: #border)
			ifTrue: [bidx _ idx].
		((self edges at: idx)
			testTag: #spine)
			ifTrue: [sidx _ idx]].
	bidx > 0 ifTrue: [^ self edges atWrap: bidx - 1].
	^ self edges atWrap: sidx + 1! !


!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
addSubTriangle: aTriangle
	self subTriangles ifNil: [
		self subTriangles: (OrderedCollection new: 3)].
	self subTriangles add: aTriangle! !

!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
contains: aPoint 
	| triangle |
	(self whereIs: aPoint)
		= #outside
		ifTrue: [^ nil]
		ifFalse: [self subTriangles isEmptyOrNil ifTrue: [^ self]
		ifFalse: [self subTriangles do: [:subTriangle | 
			triangle _ subTriangle contains: aPoint.
			triangle ifNotNil: [^triangle]]]]! !

!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
depth
	| depth |
	self subTriangles ifNil: [^ 0]
		ifNotNil: 
			[depth _ 0.
			self subTriangles do: [:subTriangle | depth _ depth max: subTriangle depth].
			^ depth + 1]! !

!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
leafs
	| size |
	self type = #done ifTrue: [^ 0].
	self type: #done.
	self subTriangles ifNil: [^ 1]
		ifNotNil: 
			[size _ 0.
			self subTriangles do: [:subTriangle | size _ size + subTriangle leafs].
			^ size]! !

!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
removeSubTriangle: aTriangle 
	self subTriangles remove: aTriangle ifAbsent: []! !

!POTriangle methodsFor: 'subtriangles' stamp: 'laza 1/13/2000 16:59'!
size
	| size |
	(self type = #done)
		ifTrue: [^ 0].
	self type: #done.
	self subTriangles ifNil: [^ 1]
		ifNotNil: 
			[size _ 0.
			self subTriangles do: [:subTriangle | size _ size + subTriangle size].
			^ size + 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POTriangle class
	instanceVariableNames: ''!

!POTriangle class methodsFor: 'instance creation' stamp: 'laza 1/24/2000 16:26'!
with: pointArray
	^ self new edges: pointArray! !

!POTriangle class methodsFor: 'instance creation' stamp: 'laza 1/24/2000 16:26'!
with: a with: b with: c 
	^ self with: (Array
			with: a
			with: b
			with: c)! !
POEdgeList subclass: #POTriangulation
	instanceVariableNames: 'points toptriangle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POTriangulation commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POTriangulation methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:47'!
points
	^points! !

!POTriangulation methodsFor: 'accessing' stamp: 'laza 1/13/2000 16:47'!
points: anObject
	points _ anObject! !

!POTriangulation methodsFor: 'accessing' stamp: 'laza 1/14/2000 15:51'!
toptriangle
	^ toptriangle! !


!POTriangulation methodsFor: 'private' stamp: 'laza 1/14/2000 12:51'!
addBoundingTriangle
	| radius p1 p2 p3 center |
	radius _ 0.
	center _ 0 @ 0.
	self points do: [:point | center _ center + point].
	center _ center / self points size.
	self points do: [:point | radius _ ((point x - center x) abs max: (point y - center y) abs)
					max: radius].
	radius _ 3 * radius.
	p1 _ radius @ 0 + center.
	p2 _ 0 @ radius + center.
	p3 _ radius negated @ radius negated + center.
	toptriangle _ self triangle: p1 to: p2 to: p3! !

!POTriangulation methodsFor: 'private' stamp: 'laza 1/17/2000 15:45'!
legalize: anEdge with: aPoint 
	| triangle incidentTriangle otherPoint left right |
	triangle _ anEdge face.
	incidentTriangle _ anEdge opposite face.
	incidentTriangle isNil ifTrue: [^ self].
	otherPoint _ incidentTriangle oppositeVertexOf: anEdge opposite.
	(otherPoint
		isInsideCircle: anEdge origin
		with: anEdge destination
		with: aPoint)
		ifTrue: 
			[self removeEdge: anEdge.
			left _ self
						triangle: aPoint
						to: otherPoint
						to: anEdge origin.
			right _ self
						triangle: aPoint
						to: otherPoint
						to: anEdge destination.
			triangle addSubTriangle: left;
			 addSubTriangle: right.
			incidentTriangle addSubTriangle: left;
			 addSubTriangle: right.
			self removeTriangle: triangle;
			 removeTriangle: incidentTriangle.
			self legalize: (left oppositeEdgeOf: aPoint)
				with: aPoint.
			self legalize: (right oppositeEdgeOf: aPoint)
				with: aPoint]! !

!POTriangulation methodsFor: 'private' stamp: 'laza 1/14/2000 12:03'!
splitTriangle: boundingTriangle at: point 
	| triangle |
	boundingTriangle edges do: 
		[:edge | 
		triangle _ self
					triangle: edge origin
					to: edge destination
					to: point.
		boundingTriangle addSubTriangle: triangle].
	self removeTriangle: boundingTriangle! !


!POTriangulation methodsFor: 'triangulation' stamp: 'laza 1/28/2000 16:25'!
triangulate
	| triangle |
	self addBoundingTriangle.
	self points do: 
		[:point | 
		triangle _ toptriangle contains: point.
		self splitTriangle: triangle at: point.
		triangle edges do: [:edge | self legalize: edge with: point]].
	"Remove bounding triangle and incident triangles"
	self faces copy do: [:face | (face sharesCornerWith: toptriangle)
			ifTrue: [self removeTriangle: face]].
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POTriangulation class
	instanceVariableNames: ''!

!POTriangulation class methodsFor: 'instance creation' stamp: 'laza 3/23/2000 15:16'!
on: points 
	^ self new points: points;
	 triangulate! !
Point subclass: #POVertex
	instanceVariableNames: 'halfedge tags faces z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Pooh'!
!POVertex commentStamp: '<historical>' prior: 0!
Main comment stating the purpose of this class and relevant relationship to other classes.

Possible useful expressions for doIt or printIt.

Structure:
 instVar1		type -- comment about the purpose of instVar1
 instVar2		type -- comment about the purpose of instVar2

Any further useful comments about the general approach of this implementation.!


!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
degree
	| edge count start |
	start _ self halfedge.
	start ifNil: [^ 0].
	edge _ start opposite.
	count _ 1.
	[edge next = start]
		whileFalse: 
			[edge _ edge next opposite.
			count _ count + 1].
	^ count! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
faces
	faces ifNil: [faces _ Set new].
	^ faces! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
faces: aSet
	faces _ aSet! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
halfedge
	^ halfedge! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
halfedge: aHalfedge
	halfedge _ aHalfedge! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
incidentEdges
	| edge start edges |
	edges _ OrderedCollection new.
	start _ self halfedge.
	start ifNil: [^ nil].
	edge _ start.
	edges add: edge.
	[edge opposite next = start]
		whileFalse: 
			[edge _ edge opposite next.
			edges add: edge].
	^ edges! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
tags
	tags ifNil: [tags _ Dictionary new].
	^ tags! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/13/2000 17:02'!
tags: aDictionary
	tags _ aDictionary! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/25/2000 16:44'!
z
	^ z! !

!POVertex methodsFor: 'accessing' stamp: 'laza 1/25/2000 16:44'!
z: aNumber
	z _ aNumber
! !


!POVertex methodsFor: 'converting' stamp: 'laza 1/31/2000 05:21'!
asB3DVector3
	^ B3DVector3
		x: self x 
		y: self y 
		z: self z ! !

!POVertex methodsFor: 'converting' stamp: 'laza 1/31/2000 05:21'!
asPoint
	^ Point x: self x y: self y ! !


!POVertex methodsFor: 'printing' stamp: 'laza 1/28/2000 16:06'!
printOn: aStream 
	aStream nextPut: $<.
	super printOn: aStream.
	self z = 0 ifFalse: [aStream nextPut: $@. self z printOn: aStream].
	aStream nextPut: $>! !


!POVertex methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:02'!
clearAllTags
	self tags: Dictionary new! !

!POVertex methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:02'!
clearTag: aSymbol 
	self tags remove: aSymbol ifAbsent: []! !

!POVertex methodsFor: 'tagging' stamp: 'laza 1/13/2000 17:02'!
setTag: aSymbol 
	self tags at: aSymbol put: true! !

!POVertex methodsFor: 'tagging' stamp: 'laza 1/25/2000 17:06'!
testTag: aSymbol 
	^ self tags includesKey: aSymbol!
]style[(9 7 5 4 19 7)f1b,f1cmagenta;ib,f1,f1cblue;b,f1,f1cmagenta;b! !


!POVertex methodsFor: 'testing' stamp: 'laza 1/13/2000 17:02'!
isConnected
	^ self halfedge isNil not! !

!POVertex methodsFor: 'testing' stamp: 'laza 1/13/2000 17:02'!
isDeadEnd
	^ self isConnected and: [self halfedge opposite next = self halfedge]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

POVertex class
	instanceVariableNames: ''!

!POVertex class methodsFor: 'instance creation' stamp: 'laza 1/25/2000 16:46'!
at: aPoint 
	^ (self x: aPoint x y: aPoint y) z: 0! !
SwikiAction subclass: #PSwikiAction
	instanceVariableNames: 'authorizer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!PSwikiAction commentStamp: '<historical>' prior: 0!
A Swiki with the potential for a password on each page.  Requires the special folder 'pswiki' from the swiki web site.!


!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 2/6/98 15:43'!
auth
	^authorizer! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 2/6/98 15:44'!
auth: anAuth
	authorizer _ anAuth.! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 13:06'!
browse: pageRef from: request
	"Check authorization"
	(pageRef privs includesSubString: 'read') ifTrue:
		[(authorizer user: request userID) = pageRef coreID
		ifFalse: [self error: (PWS unauthorizedFor: authorizer realm)]].
	request reply: PWS success; reply: PWS contentHTML.
	request reply: PWS crlf.
	^super browse: pageRef from: request
! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 5/1/98 09:58'!
edit: pageRef from: request
	"Check authorization"
	(pageRef privs includesSubString: 'write') ifTrue:
		[(authorizer user: request userID) = pageRef coreID
		ifFalse: [self error: (PWS unauthorizedFor: authorizer realm)]].
	request reply: PWS success; reply: PWS contentHTML.
	request reply: PWS crlf.
request reply: (HTMLformatter evalEmbedded: 
							(self fileContents: source , 'pedit.html')
						with: pageRef).
	pageRef noteEditRequest.
	^ self! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'mjg 9/10/1998 15:35'!
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 atID: coreRef.
		page user: request peerName.  "Address is machine, user only if
logged in"
		 page pageStatus = #new ifTrue: [page pageStatus: #standard].
		page _ urlmap
			storeID: coreRef
			username: (request fields at: 'username' ifAbsent:
[''])
			password: (request fields at: 'password' ifAbsent: [''])
			privs: (request fields at: 'privs' ifAbsent: [''])
			text: (request fields at: 'text' ifAbsent: ['blank
text'])
			from: request peerName.
		page user: request userID.  "Address is machine, user only
if logged in"
		^ self].	"return self means do serve the edited page
afterwards"
	request fields keys do: [:aTag |
		(aTag beginsWith: 'text-') ifTrue: [
			urlmap
				storeID: coreRef
				text: (request fields at: aTag)
withSqueakLineEndings
				insertAt: (aTag copyFrom: 6 to: aTag size).
	"string"
			^ self]].
	"oops, a new kind!!"
	Transcript show: 'Unknown data from client. '; show: request fields
printString; cr.
! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 5/21/1998 16:47'!
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 ***"! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 9/16/1998 16:21'!
process: request
	"URLs are of the form:
	{swikiname} to browse Front Page
	{swikiname}.{coreID} to browse the page
	{swikiname}.{coreID}.edit  to edit the page
	{swikiname}.{coreID}.all  displays the page and all its references
	{swikiname}.{coreID}.versions displays the last three versions of the page
	{swikiname}.searchresult  conducts the search and displays the result
	{swikiname}.recent  to bring up the recent changes list
	{swikiname}.{coreID}.searchresult  returns a search for references to coreID's key
	{swikiname}.{picName}.gif (or jpeg, jpg, jpe, upper or lower case) 
		return the picture stored in the {swikiname} folder."
	"Transcript show: 'Got request ',(request url); cr."

	| coreRef pageRef command formattedPage theLast |
	self log: request.
	theLast _ request message last asLowercase.
	theLast = 'gif' ifTrue: [^ self process: request MIMEtype: 'image/gif'].
	theLast = 'jpeg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'jpg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'jpe' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'html' ifTrue: [^ self process: request MIMEtype: 'text/html'].
	request message size < 2
		ifTrue: [coreRef _ '1']
		ifFalse: [coreRef _ request message at: 2].
	request fields ifNotNil: ["Are there input fields?"
		(self inputFrom: request) == #return ifTrue: [^ self]].
	coreRef = 'recent' ifTrue:
			[request reply: PWS crlf, (HTMLformatter
					evalEmbedded: (self fileContents: source, 'recent.html')
					with: urlmap recent).
			^ self].
"	request reply: PWS crlf.		End of header.  Move this when we want to report more header
"	"At this point, coreRef is a page reference"
	pageRef _ urlmap atID: coreRef.
	request message size > 2 ifTrue: ["SearchResult, All, Versions, or Edit"
		command _ request message at: 3.
		command = 'edit' ifTrue:
			[^self edit: pageRef from: request].
		command = 'versions' ifTrue:
					[request reply: ((self formatterFor: 'versions') format: pageRef).
					^self].
		command = 'searchresult' ifTrue:
			[request reply: (HTMLformatter evalEmbedded:
							(self fileContents: source , 'results.html')
						with: (urlmap searchFor: pageRef name)).
			^ self].
		command = 'all' ifTrue:
			[formattedPage _ urlmap allPagesFrom: pageRef for: request.
			request reply: (HTMLformatter evalEmbedded:
							(self fileContents: source, 'page.html')
						with: formattedPage).
			^ self].
		(request message at: 1) = (request message at: 2) ifTrue: [
			request reply: '<h1>Your original url has a slash after it.  Please remove it.</h1>'.
			request message: (request message copyFrom: 2 to: request message size).
			^ self process: request].	"(success and contentHTML will be sent twice!!)"
		Transcript show: 'Unknown command: ', command; cr.
		^ self].
	"Just a browse"
	^ self browse: pageRef from: request! !

!PSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 5/22/1998 10:23'!
restore: nameOfSwiki
	"Read all files in the directory 'nameOfSwiki'.  Reconstruct the url map."

	super restore: nameOfSwiki.
	authorizer _ Authorizer new.	"<- not restored from disk in this implementation"
	authorizer realm: name.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PSwikiAction class
	instanceVariableNames: ''!

!PSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:53'!
mapClass
	"The class of my pages"
	^ PURLmap! !

!PSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/14/1998 18:22'!
pageClass
	"The class of my pages"
	^ PSwikiPage! !

!PSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/22/1998 10:03'!
setUp: actionName
	"Set up a named protected Swiki"
	| action auth |

	super setUp: actionName.
	action _ PWS actions at: actionName.
	auth _ Authorizer new.	"*** for now, not restored from the disk***"
	auth realm: actionName.
	action auth: auth.
	^ action
! !
SwikiPage subclass: #PSwikiPage
	instanceVariableNames: 'username password privs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:59'!
fromFileNamed: filePath action: aSwikiAction
	"Fill in all parts of this page from the info in its file"

	| theFile |
	map _ aSwikiAction urlmap.
	file _ filePath.
	theFile _ FileStream oldFileNamed: file.
	coreID _ theFile localName.
	url _ aSwikiAction name, '.', coreID.
	username _ ''. password _ ''. privs _ ''.
	self scanFrom: theFile.	"name, date"
	(username size > 1) ifTrue: ["Set up the authorization"
		aSwikiAction auth mapName: username password: password
			to: coreID.].
	address _ ''.		"should be page that points at it, but how get that?"! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/6/98 15:21'!
name: pageName date: dateString time: timeString by: who authName: aName authPW: thePass privs: thePrivs text: theString back: bytes
	"Record the name of this page during startup.  When reading the page in order to serve it, this is NOT executed.  The text is read from the file explicitly."
	
	name _ pageName.
	date _ dateString asDate.
	username _ aName.
	password _ thePass.
	privs _ thePrivs.! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'BJP 9/10/1998 14:33'!
outputFormat
	| formatCollection textBlock |
"Ah, yes, my first experience with class vars. I need to think about this
scheme a bit, but it's only	 a placeholder anyway. BJP"

	formatCollection _ OrderedCollection newFrom: super outputFormat.
	textBlock _ formatCollection last.
	^ formatCollection
		add: [:thePage | 'authName: ', thePage username
printString, '; ']
before: textBlock;
		add: [:thePage | 'authPW: ', thePage password printString,
'; ']
before: textBlock;
		add: [:thePage | 'privs: ', thePage privs printString, '; ']
before: textBlock.! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:54'!
password
	^password! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:54'!
password: aString
	password _ aString! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:48'!
privs
	^privs! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:52'!
privs: aString
	"Privilege string should contain 'read' or 'write' for what's protected"
	privs _ aString! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:53'!
username
	^username
! !

!PSwikiPage methodsFor: 'as yet unclassified' stamp: 'mjg 2/9/98 11:54'!
username: aName
	username _ aName.
! !
URLmap subclass: #PURLmap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!PURLmap methodsFor: 'as yet unclassified' stamp: 'BJP 9/10/1998 14:40'!
allPagesFrom: pageRef for: request
	| formattedPage refPages allPages peer |
	(request isKindOf: PWS) ifTrue: [peer _ request peerName] ifFalse:
[peer_''].
	formattedPage _ pageRef copy.  "Make a copy, then format the text."
	refPages _ OrderedCollection new.
	formattedPage formatted: (action formatter swikify: (pageRef text)

	linkhandler: [:link | self linkFor: link

				from: peer

				storingTo: refPages]).
	refPages _ refPages reject: [:page | page pageStatus = #new].
	"Now, put all referenced pages into the page"
	allPages _ WriteStream on: String new.
	allPages nextPutAll: '<h2>',(pageRef name),'</h2>', formattedPage
formatted.
	refPages do: [:page |
		(page privs includesSubString: 'read') ifTrue:
			[(action auth user: request userID) = page coreID
			ifFalse: [self error: (PWS unauthorizedFor: (page
name))]].
		allPages nextPutAll: '<h2>',(page name),'</h2>'.
		allPages nextPutAll: (HTMLformatter swikify: (page text)

	linkhandler: [:link | self linkFor: link

				from: peer

				storingTo:
(OrderedCollection new)]).].
	formattedPage formatted: allPages contents. "Put all the pages into THE
page"
	^formattedPage
! !

!PURLmap methodsFor: 'as yet unclassified' stamp: 'BJP 9/10/1998 14:36'!
newpage: label from: peer
	| newpage newfile |
		newpage _ PSwikiPage new.
		self at: label put: newpage.
		newfile _ pages size printString.
		newpage address: peer.
		newpage date: (Date today).
		newpage coreID: newfile.
		newpage name: label.
		newpage username: ''.
		newpage password: ''.
		newpage privs: ''.
		newpage pageStatus: #new.
		newpage file: ((ServerAction serverDirectory),
			directory, (ServerAction pathSeparator), newfile).
		newpage text: 'Describe ',label,' here'.
		newpage map: self.
		newpage url: (action name),'.',newfile.
	^newpage
! !

!PURLmap methodsFor: 'as yet unclassified' stamp: 'BJP 9/10/1998 14:39'!
recent
	| response sortedPages currentDate |
	sortedPages _ pages reject: [:page | page pageStatus = #new].
	sortedPages _ sortedPages asSortedCollection: [:a :b | (a date = b
date) ifTrue: [a time > b time]
			ifFalse: [a date > b date]].
	response _ WriteStream on: String new.
	response nextPutAll: '<h2>Recent Changes</h2><ul>'.
	currentDate _ Date new.
	sortedPages do: [:page |
		(currentDate ~= page date)
		ifTrue: [
			currentDate _ page date.
			response nextPutAll: '</ul><p><b>',(currentDate
printString),'</b><p><ul>'.].
		response nextPutAll: '<li>',(self pageURL:
page),'...',(page address).
		(page privs includesSubString: 'read') ifTrue:
			[response nextPutAll: '  <b>Read protected</b>'.].
		(page privs includesSubString: 'write') ifTrue:
			[response nextPutAll: '  <b>Write protected</b>'.].].
	response nextPutAll: '</ul>'.
	^response contents
! !

!PURLmap methodsFor: 'as yet unclassified' stamp: 'BJP 9/10/1998 14:41'!
storeID: id  username: theUsername password: thePassword privs: thePrivs
text: text from: peer
	| page |
	page _ self atID: id.
	page date: (Date today).
	page address: peer.
	(theUsername size > 1) ifTrue: [
		page username: theUsername.
		page password: thePassword.
		page privs: thePrivs.
		"Set up the authorization"
		action auth mapName: theUsername password: thePassword
			to: id.].
	page text: text.
	^ page! !
Object subclass: #PWS
	instanceVariableNames: 'peerName userId message fields connection log url header '
	classVariableNames: 'ActionTable BackupJobs ClientNameCache ServerLog ServerPort ServerProcess ServerStatus '
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!PWS commentStamp: '<historical>' prior: 0!
PWS is the PluggableWebServer.  Documentation for it can be found at
http://www.cc.gatech.edu/fac/mark.guzdial/squeak/pws/.

The PWS decouples the networking and HTTP translation roles of a Web Server
from the URL translation and CGI execution roles. The latter roles are
played by ServerActions.

To record a ServerAction for the PWS, use PWS link: key to: action. Key is
a string that will be parsed out of the incoming URL.

See PWS class howToStart.

PWS (and its associated files) are based on Georg Gollman's WebServer,
extended by Mark Guzdial.  Those portions are copyright 1997 Georgia Tech
Research Corporation and are used with permission.  Mark Guzdial's work on
PWS was funded in part by NSF grant REC-9550458.

!
]style[(432 20 273)f1,f1LPWS class howToStart;,f1!


!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
fields

   "Return the value of the instance variable 'fields'."
   ^fields! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
log
   "Return the value of the instance variable 'log'."
   ^log! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
log: aString
	"Add to the log."

	log nextPutAll: aString! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
message

   "Return the value of the instance variable 'message'."
   ^message! !

!PWS methodsFor: 'Accessing' stamp: 'tk 9/16/1998 15:50'!
message: anArray

   message _ anArray! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
objectsInField: fieldName
  "Extract the array of objects denoted by 'fieldName', return an empty array if there are none."

  | sel |
  sel := fields at: fieldName ifAbsent: [ ^#() ].
  (sel isKindOf: Array) ifFalse: [ sel := { sel } ].
  ^sel collect: [ :s | self objectFromString: s ]
! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:23'!
peerName
  "Return the requesting ipAddress"

  ^peerName! !

!PWS methodsFor: 'Accessing' stamp: 'jm 3/10/98 11:00'!
reply: aString
	"Send back part of the reply. If we are in roll forward mode just do nothing."

	((connection ~~ nil) and: [connection isConnected])
		ifTrue: [connection sendData: aString].
! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 10/25/97 14:33'!
url
	^ url
! !

!PWS methodsFor: 'Accessing' stamp: 'mjg 11/6/97 16:57'!
userID

   "Return the value of the instance variable 'userID'."
   ^userId! !


!PWS methodsFor: 'Initializing' stamp: 'jm 3/13/98 12:56'!
clientName: addr
	"Return the host name of the client connecting via the given socket. If the host name cannot be found, return a string representing that host's numeric IP address."
	"Details: Since querying the domain name server can take many seconds (up to 13 second delays were observed during busy times), the results of this query are cached. This cache is flushed when the server starts up, although it could be flushed, say, hourly."

	| addrString name |
	addrString _ NetNameResolver stringFromAddress: addr.
	(ClientNameCache includesKey: addrString) ifFalse: [
		name _ NetNameResolver nameForAddress: addr timeout: 15.
		name ifNil: [name _ addrString].  "lookup failed or timed out; use numeric address"
		ClientNameCache at: addrString put: name].

	^ ClientNameCache at: addrString
! !

!PWS methodsFor: 'Initializing' stamp: 'ls 7/22/1998 22:47'!
initializeFrom: aSocket
	"Initialize me from aSocket."
	| request idx |
	log _ WriteStream on: ''.
	connection _ aSocket.
	request _ self readRequest.	"sets header"
	header _ header substrings.
	url _ self unEscape: (header at: 2).
	((idx _ header indexOf: 'Authorization:') ~= 0 and: [(header at:
idx + 1)
			= 'Basic'])
		ifTrue: [userId _ header at: idx + 2].

	peerName _ self clientName: connection remoteAddress.

	log
		nextPutAll: Time totalSeconds asString; tab;
		nextPutAll: peerName asString; tab;
		nextPutAll: userId asString; tab;
		nextPutAll: url; tab;
		nextPutAll: request last asString; tab.

	request last notNil
		ifTrue: [ fields := self decodeFields: request last ]
		ifFalse: [ (url includes: $?) ifTrue: [
			idx _ url indexOf: $?.
			idx = url size
				ifTrue: [ "empty request" fields _
Dictionary new ]
				ifFalse: [
					fields _ self decodeFields:
						(url copyFrom: idx+1 to:
url size) ].
			url _ url copyFrom: 1 to: idx-1 ] ].

	message := url findTokens: '/.\?:='.
! !

!PWS methodsFor: 'Initializing' stamp: 'ls 7/22/1998 22:44'!
readRequest
	"Read the request and return an array of header and query."

	| idx request query length |
	request := ''.
	[	request := request, connection getData.
		(idx := request findString: (self class crlfcrlf)
startingAt: 1) = 0 ] whileTrue.
	header := request copyFrom: 1 to: idx - 1.
	(request beginsWith: 'POST') ifTrue: [
		(length := request asUppercase findString:
'CONTENT-LENGTH:' startingAt: 1) = 0
			ifTrue: [ self error: '* noLength' ].
		length := (request copyFrom: length + 15 to:
		  (request indexOf: Character cr startingAt: length
ifAbsent: []))
			withBlanksTrimmed asNumber + idx + 3.
		[ request size < length ] whileTrue: [ request := request,
connection getData ].
		query := (request copyFrom: idx + 3 to: request size)
withBlanksTrimmed ].
	"Transcript show: request."
	^{ header. query }! !


!PWS methodsFor: 'Processing' stamp: 'mjg 10/24/97 17:27'!
decodeFields: aString
  "Convert the form fields in aString to a query dictionary."

  | query dict i key value |

  query := aString findTokens: '&'.
  dict := Dictionary new.
  query do: [ :tag |
    i := tag indexOf: $=.
    key := tag copyFrom: 1 to: i - 1.
    value := i < tag size ifTrue: [ self unEscape: (tag copyFrom: i + 1 to: tag size) ] ifFalse: [ nil ].
    (dict includesKey: key)
     ifFalse: [ dict at: key put: value ]
     ifTrue: [
      ((dict at: key) isKindOf: String) 
		ifTrue: [ dict at: key put: (OrderedCollection with: (dict at: key)) ].
      (dict at: key) add: value
     ]
  ].
  ^dict! !

!PWS methodsFor: 'Processing' stamp: 'jm 3/13/98 15:33'!
getReply
	"Generate a reply based on the action selected by the first word of the URL."

	| key |
	message size > 0
		ifTrue: [key _ (message at: 1) asLowercase]
		ifFalse: [key _ 'default'].
	(ActionTable includesKey: key) ifFalse: [key _ 'default'].

	"Transcript show: ('Request: ' , url printString, ' from: ', peerName, ' action: ', key) ; cr."
	(ActionTable at: key) process: self.
! !

!PWS methodsFor: 'Processing' stamp: 'tk 7/15/1998 12:06'!
report: msg for: rec
	"Write an error report."

	| s |
	self log: '*** ', rec asString, ': ', msg.
	s _ (msg indexOfSubCollection: 'HTTP' startingAt: 1) = 1
		ifTrue: [msg]
		ifFalse: ['HTTP/1.0 400 Bad Request -- ', self class
crlfcrlf, msg].
	[self reply: s] ifError: [:m :r | "ignore errors"].
! !

!PWS methodsFor: 'Processing' stamp: 'ls 7/28/1998 01:09'!
unEscape: aString
  "Convert escape sequences to their proper characters."

	| rs ws c |
	rs := ReadStream on: aString.
	ws := WriteStream on: ''.
	[ rs atEnd ] whileFalse: [
		c := rs next.
		ws nextPut:
			(c = $+ ifTrue: [ $  ] ifFalse: [
				c = $%
					ifTrue: [ (Number readFrom: (rs
next: 2) asUppercase base: 16) asCharacter ]
					ifFalse: [ c ]
				]).
		].
	^ws contents ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PWS class
	instanceVariableNames: ''!

!PWS class methodsFor: 'HTTPcodes' stamp: 'tk 1/31/98 14:34'!
content: type
	"Can also return image types"
	^'Content-Type: ', type, self crlf
! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 10/25/97 12:18'!
contentHTML
	^self content: 'text/html'
! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 10/25/97 12:16'!
crlf
	^String with: Character cr with: Character linefeed! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 10/25/97 12:16'!
crlfcrlf
	^self crlf , self crlf.
! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 11/17/97 13:01'!
notFound
	^'HTTP/1.0 404 FILE NOT FOUND',self crlf,'<title>File Not Found</title><h2>File Not Found</h2>'! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 10/25/97 12:26'!
redirectTo: URL
	^'HTTP/1.0 302 FOUND', self crlf, 'Location: ',URL, self crlf,'URI: ',URL,
	self crlfcrlf! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'mjg 10/25/97 12:17'!
success
	^'HTTP/1.0 200 OK',self crlf! !

!PWS class methodsFor: 'HTTPcodes' stamp: 'tk 6/24/1998 16:24'!
unauthorizedFor: realm
	^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"',
	self crlfcrlf, '<html><title>Unauthorized</title><body><h2>Unauthorized for ',realm, '</h2></body></html>'

! !


!PWS class methodsFor: 'Backups' stamp: 'mjg 11/10/97 09:21'!
addToBackupJob: block
	"Stores blocks to be executed hourly at snapshot time."
	BackupJobs add: block.
! !


!PWS class methodsFor: 'ServerActions' stamp: 'mjg 11/6/97 16:58'!
actions
	^ActionTable! !

!PWS class methodsFor: 'ServerActions' stamp: 'tk 2/3/98 15:17'!
link: key to: action
	ActionTable at: key asLowercase put: action.
! !


!PWS class methodsFor: 'Initializing' stamp: 'tk 9/13/1998 18:36'!
checkVersion
	"This is Squeak 2.2.  Make sure that the Server:swiki folder is the version for 2.2."

	| fName |
	fName _ ServerAction serverDirectory, 'swiki', (ServerAction pathSeparator), 
				'page.html'.
	(FileDirectory new fileExists: fName) ifFalse: [self inform: 'The path to the Server folder is wrong.
Please modify the following method ...'. 
	Browser openMessageBrowserForClass: ServerAction class 
		selector: #serverDirectory editString: nil.
	^ false].

	fName _ ServerAction serverDirectory, 'swiki', (ServerAction pathSeparator), 
				'render.html'.
	(FileDirectory new fileExists: fName) ifFalse: [self inform: 'Initialization failed.  ''swiki'' folder is out of date.
Get one from:
http://guzdial.cc.gatech.edu/st/Swiki-GuzPWS2.tar or
http://guzdial.cc.gatech.edu/st/Swiki-GuzPWS2.sea'. ^ false].
	^ true
! !

!PWS class methodsFor: 'Initializing' stamp: 'tk 9/13/1998 18:03'!
howToStart
	"To set up your new Swiki, you need a copy of the 'Server' folder
found at:
http://www.cc.gatech.edu/fac/mark.guzdial/squeak/pws/
Put the 'Server' folder into the folder that your image is in.

Modify this method to be a path to your Server folder, select it, and
choose fileItIn:
!!ServerAction class methodsFor: 'System Services' stamp: 'tk 1/19/98 12:52'!!
serverDirectory
	^ 'Hard Disk:Squeak1.31:Server:'
!! !!

Then do:
	PWS initializeAll.

To enable a new Swiki called OurOwnArea.
Make a folder named OurOwnArea in the Server folder.  Then do:
	SwikiAction setUp: 'OurOwnArea'.
	(its main URL is http://thisMachine:80/OurOwnArea.1)

<<<<There has been a major change between Squeak 2.1 and 2.2.  If you are reloading an existing Swiki for the first time in Squeak 2.2, 
Do this instead of the normal reload.
	SwikiAction new restore: 'myswiki'.		'<- New line for each additional Swiki area'.
	SwikiAction new restore: 'myswiki'.		'Case DOES matter in the name of Swiki here.'.
	(PWS actions select: [ :action | action isKindOf: SwikiAction ])
		do: [ :action | action fixAllLineEndings ].
	PWS serveOnPort: 80 loggingTo: 'log.txt'.
(This to converts LineFeeds to CarriageReturns in all of your swiki data files.  Only do this the first time!!)
>>>>>

Suppose you already have a Swiki called 'myswiki'.
To start up:
	SwikiAction new restore: 'myswiki'.		'<- New line for each additional Swiki area'.
	SwikiAction new restore: 'myswiki'.		'Case DOES matter in the name of Swiki here.'.
	PWS serveOnPort: 80 loggingTo: 'log.txt'.

To stop the server:
	PWS stopServer.

-----------------------
To purge a particular file of all except the latest version:
	((PWS actions at: 'myswiki' asLowercase) urlmap atID: '3') condenseChanges.

To roll the entire wiki back to a previous time:
	""This does not erase data, it just copies the older page to the end""
	(PWS actions at: 'myswiki' asLowercase) rollBack: '1/28/98' asDate
			at: '1:30 am' asTime.

The look of a served page is controlled by a template.  Templates live in
the 'swiki' folder in the 'Server' folder.  Beware that templates are
cached by HTMLformatter.  If you change a template, you will not see the
effect until you reload the Swiki.

To set up a Swiki with a password (same for all users), see
AuthorizedSwikiAction comment.

To enable a privledged user to execute code remotely (on a workspace page):
	(PWS actions at: 'authorized') mapName: 'JSmith' password:
'hard2guess' to: 'JSmith'.
	(URL is http://thisMachine:80/authorized.workspace.html)

To backup the user data to the disk, do nothing.  All info is already
inside the page files on the disk.

To enable a new Swiki that evaluates Squeak code submitted by the user.
Make a folder named SqkEval in the Server folder.  Then do:
	ActiveSwikiAction setUp: 'SqkEval'.
	(this is dangerous, because there are still ways a user could crash
your server)

To convert a Swiki with LineFeed line endings to CarriageReturn line
endings, execute these lines:
          (PWS actions select: [ :action | action isKindOf: SwikiAction ])
		do: [ :action | action fixAllLineENdings ]

To convert from an old pre-Squeak1.3 Swiki to the new page format:
	(In the old image, do a backup:)
		| mine | mine _ PWS actions at: 'myswiki'.
		mine saveTo: mine path,'backup28JanA'.
	(Quit.  Start the new image which has this version of the Swiki code)
	(Do not start the server!!!!!!)
		PWS initializeAll.
		SwikiAction restore: 'myswiki' from:
			(ServerAction serverDirectory), 'myswiki:backup28JanA'.
		(PWS actions at: 'myswiki' asLowercase) convert.
	(do these steps for each Swiki you have)
	(now, start the server)
	PWS serveOnPort: 80 loggingTo: 'log.txt'.
"!
]style[(10 712 46 2904)f1b,f1,f3,f1! !

!PWS class methodsFor: 'Initializing' stamp: 'jm 3/9/98 17:57'!
initialize
	"PWS initialize"

	BackupJobs _ OrderedCollection new.
	ActionTable _ Dictionary new.
! !

!PWS class methodsFor: 'Initializing' stamp: 'tk 9/13/1998 18:20'!
initializeAll
	| anAuthorizer |
	(self checkVersion) ifFalse: [^ false].
	anAuthorizer _ Authorizer new.
	anAuthorizer realm: 'AuthorizedSpace'.
"	anAuthorizer mapName: 'JSmith' password: 'hard2guess' to: 'JSmith'.  "
		"No default account!!  See howToStart to enable remote code execution."
	self link: 'authorized' to: (AuthorizedServerAction new authorizer: anAuthorizer).
	self link: 'chat' to: ChatPage new.
	self link: 'default' to: ServerAction new.
	self link: 'embedded' to: EmbeddedServerAction new.
	self link: 'smtlk' to: CodeServer new.
	self link: 'chunk' to: CodeServer new.
	Comment setUpExample.
	self link: 'comment' to: (SinglePlugServerAction new 
			processBlock: [:request | Comment process: request]).
! !


!PWS class methodsFor: 'Serving' stamp: 'jm 10/3/1998 08:48'!
doBackupJobs
	"This is just a wrapper so we don't have to restart the server loop when we add/remove jobs."

	| problemReport |
	BackupJobs do: [:block |
		problemReport _ nil.
		[block value] ifError: [:msg :rec |
			problemReport _ '*** ', rec asString, ': ', msg asString].
		problemReport ifNotNil: [^ problemReport]].

	^ 'Backup jobs completed'
! !

!PWS class methodsFor: 'Serving' stamp: 'jm 3/9/98 19:56'!
loopOnPort: portNumber loggingTo: fileName
	"Loop forever handling HTTP requests. Run backup jobs periodically."

	| secondsBetweenBackups nextBackupTime socket logEntry |
	secondsBetweenBackups _ 1 * (60 * 60).
	nextBackupTime _ Time totalSeconds + secondsBetweenBackups.
	[true] whileTrue: [
		socket _ ServerPort getConnectionOrNil.
		socket notNil
			ifTrue: [
				logEntry _ self serve: socket.
				ServerLog nextPutAll: logEntry; cr]
			ifFalse: [
				Time totalSeconds > nextBackupTime
					ifTrue: [  "time to back up!!"
						logEntry _ self doBackupJobs.
						ServerLog nextPutAll: logEntry; cr.
						nextBackupTime _ Time totalSeconds + secondsBetweenBackups]
					ifFalse: [
						(Delay forMilliseconds: 100) wait]]].
! !

!PWS class methodsFor: 'Serving' stamp: 'mjg 4/21/2000 14:07'!
serve: aSocket
	"Respond to a request arriving on the given socket and return a string to be entered in the log file."

    | inst reportMsg |
     inst _ self new.
     [inst initializeFrom: aSocket.
     inst getReply]
         ifError: [:msg :rec |  "Fix by Mark Schwenk to deal with Exceptions"
	    reportMsg _ (msg size >= 8 and: [(msg copyFrom: 1 to: 7) = 'Error: '])
                ifTrue: [msg copyFrom: 8 to: msg size]
                ifFalse: [msg].
            inst report: reportMsg for: rec].            
     aSocket closeAndDestroy: 30.
     ^ inst log contents

! !

!PWS class methodsFor: 'Serving' stamp: 'jm 3/13/98 11:45'!
serveOnPort: portNumber loggingTo: fileName
	"Start up the HTTP server loop for the given port number and log file."

	self stopServer.
	Socket initializeNetwork.
	ServerLog _ FileStream fileNamed: fileName.
	ServerLog position: ServerLog size.
	ServerPort _ ConnectionQueue portNumber: portNumber queueLength: 6.
	ClientNameCache _ Dictionary new.

	ServerProcess _ [self loopOnPort: portNumber loggingTo: fileName] newProcess.
	ServerProcess priority: Processor lowIOPriority.
	ServerProcess resume.
! !

!PWS class methodsFor: 'Serving' stamp: 'tk 7/15/1998 11:27'!
serveShowingErrorsOnPort: portNumber
	"Start up the HTTP server loop for debugging!!  Operate in this
process, synchronously.  Force errors to stop the server and show on the
screen.."

	| socket logEntry inst |
	self stopServer.
	Socket initializeNetwork.
	ServerLog _ FileStream fileNamed: 'dummy.log'.
	ServerLog position: ServerLog size.
	ServerPort _ ConnectionQueue portNumber: portNumber queueLength: 6.
	ClientNameCache _ Dictionary new.

	[true] whileTrue: [
		socket _ ServerPort getConnectionOrNil.
		socket notNil
			ifTrue: ["serve:"
				inst _ self new.
				inst initializeFrom: socket.
				inst getReply.
				socket closeAndDestroy: 30.
				logEntry _ inst log contents]		"no
logging for now"
			ifFalse: [(Delay forMilliseconds: 100) wait]].
! !

!PWS class methodsFor: 'Serving' stamp: 'di 2/4/1999 15:15'!
shutDown

	self stopServer! !

!PWS class methodsFor: 'Serving' stamp: 'jm 3/13/98 12:21'!
stopServer
	"Shut down the server."

	ServerProcess	ifNotNil: [ServerProcess terminate].
	ServerPort		ifNotNil: [ServerPort destroy].
	ServerLog		ifNotNil: [ServerLog close].
	ServerProcess _ ServerPort _ ServerLog _ ClientNameCache _ nil.
! !
Browser subclass: #PackagePaneBrowser
	instanceVariableNames: 'package packageListIndex packageList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!
!PackagePaneBrowser commentStamp: '<historical>' prior: 0!
A package browser represents a hierarchical query path through an organization of class and method information.   It parses class categories into a two-level hierarchy on the first '-' character, giving "packages" (e.g.,  Magnitude, Collections, Graphics, etc.), and "categories" (e.g., Magnitude-General and Magnitude-Number).

Instance Variables:
	package  <Symbol> the "category header," e.g., #Magnitudes or #Collections
	packageListIndex <Integer> The index in the package list
	packageList  <OrderedCollection of String> the list of package names
!


!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'stp 04/07/1999 04:21'!
defaultBackgroundColor
	"PackageBrowser openBrowser"

"	^yellow"
	^ Color r: 1.0 g: 1.0 b: 0.3! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'sw 1/13/2000 16:45'!
defaultBrowserTitle
	^ 'Package Browser'! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'JW 2/2/2001 21:25'!
openAsMorphEditing: editString 
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	"PackagePaneBrowser openBrowser"

	| listHeight window |
	listHeight _ 0.4.

	(window _ SystemWindow labelled: 'later')
		model: self.

	window addMorph: (PluggableListMorph
				on: self
				list: #packageList
				selected: #packageListIndex
				changeSelected: #packageListIndex:
				menu: #packageMenu:
				keystroke: #packageListKey:from:)
		frame: (0 @ 0 extent: 0.15 @ listHeight).

	window addMorph: (self buildMorphicSystemCatList)
		frame: (0.15 @ 0 extent: 0.2 @ listHeight).

	self addClassAndSwitchesTo: window at: (0.35 @ 0 extent: 0.25 @ listHeight) plus: 0.

	window addMorph: (self buildMorphicMessageCatList)
		frame: (0.6 @ 0 extent: 0.15 @ listHeight).

	window addMorph: (self buildMorphicMessageList)
		frame: (0.75 @ 0 extent: 0.25 @ listHeight).

	self addLowerPanesTo: window at: (0@listHeight extent: 1@1) with: editString.

	window setUpdatablePanesFrom:
		#(packageList systemCategoryList classList messageCategoryList messageList ).
	^ window! !

!PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'stp 10/06/1998 22:02'!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super systemOrganizer: aSystemOrganizer .
	packageListIndex := 0! !


!PackagePaneBrowser methodsFor: 'package list' stamp: 'sw 1/24/2001 21:25'!
openEditString: aString
	"Create a pluggable version of all the views for a Browser, including views and controllers."
	"PackageBrowser openBrowser"

	| packageListView systemCategoryListView classListView messageCategoryListView
	  messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView |

	self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString].

	topView := StandardSystemView new model: self.
	topView borderWidth: 1.  "label and minSize taken care of by caller"

	packageListView := PluggableListView on: self
		list: #packageList
		selected: #packageListIndex
		changeSelected: #packageListIndex:
		menu: #packageMenu:.
	packageListView window: (0 @ 0 extent: 20 @ 70).
	topView addSubView: packageListView.

	systemCategoryListView := PluggableListView on: self
		list: #systemCategoryList
		selected: #systemCategoryListIndex
		changeSelected: #systemCategoryListIndex:
		menu: #systemCategoryMenu:.
	systemCategoryListView window: (20 @ 0 extent: 30 @ 70).
	topView addSubView: systemCategoryListView.

	classListView := PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: #classListMenu:shifted:.
	classListView window: (0 @ 0 extent: 50 @ 62).
	topView addSubView: classListView toRightOf: systemCategoryListView.

	switchView := self buildInstanceClassSwitchView.
	switchView borderWidth: 1.
	topView addSubView: switchView below: classListView.

	messageCategoryListView := PluggableListView on: self
		list: #messageCategoryList
		selected: #messageCategoryListIndex
		changeSelected: #messageCategoryListIndex:
		menu: #messageCategoryMenu:.
	messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageCategoryListView toRightOf: classListView.

	messageListView := PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #messageListMenu:shifted:
		keystroke: #messageListKey:from:.
	messageListView window: (0 @ 0 extent: 50 @ 70).
	topView addSubView: messageListView toRightOf: messageCategoryListView.

	self wantsAnnotationPane
		ifTrue:
			[annotationPane _ PluggableTextView on: self
				text: #annotation accept: nil
				readSelection: nil menu: nil.
			annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight).
			topView addSubView: annotationPane below: packageListView.
			underPane _ annotationPane.
			y _ 110 - self optionalAnnotationHeight]
		ifFalse:
			[underPane _ packageListView.
			y _ 110].

	self wantsOptionalButtons ifTrue:
		[optionalButtonsView _ self buildOptionalButtonsView.
		optionalButtonsView borderWidth: 1.
		topView addSubView: optionalButtonsView below: underPane.
		underPane _ optionalButtonsView.
		y _ y - self optionalButtonHeight].

	browserCodeView := PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	browserCodeView window: (0@0 extent: 200@y).
	topView addSubView: browserCodeView below: underPane.
	aString ifNotNil: [browserCodeView editString: aString.
			browserCodeView hasUnacceptedEdits: true].
	^ topView! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/06/1998 07:55'!
package
	"Answer the receiver's 'package'."

	^packageListIndex = 0
		ifFalse: [self packageList at: packageListIndex]
		ifTrue: [nil]! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/05/1998 20:36'!
packageList
	"Answer a list of the packages in the current system organization."

	| str cats stream |
	str := Set new: 100.
	stream := WriteStream on: (Array new: 100).
	systemOrganizer categories do:
		[ :categ | 
		cats := categ asString copyUpTo: $-.
		(str includes: cats) ifFalse: 
			[str add: cats.
			stream nextPut: cats]].
	^stream contents! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/05/1998 19:48'!
packageListIndex
	"Answer the index of the current package selection."

	^packageListIndex! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 12/01/1998 02:46'!
packageListIndex: anInteger 
	"Set anInteger to be the index of the current package selection."

	packageListIndex := anInteger.
	anInteger = 0
		ifFalse: [package := self packageList at: packageListIndex].
	messageCategoryListIndex := 0.
	systemCategoryListIndex := 0.
	messageListIndex := 0.
	classListIndex := 0.
	self setClassOrganizer.
	self changed: #packageSelectionChanged.
	self changed: #packageListIndex.	"update my selection"
	self changed: #systemCategoryList.	"update the category list"
	self systemCategoryListIndex: 0.	"update category list selection"
! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/06/1998 19:59'!
packageMenu: aMenu
	"Answer a Menu of operations on class packages to be 
	displayed when the operate menu button is pressed."

	^aMenu
			labels: 'find class...\recent classes...\reorganize\update' withCRs
			lines: #(2)
			selections: #(#findClass #recent #editSystemCategories #updatePackages)! !

!PackagePaneBrowser methodsFor: 'package list' stamp: 'stp 10/06/1998 07:47'!
updatePackages
	"Update the contents of the package list."

	editSelection := #none.
	self changed: #packageList.
	self changed: #package.
	self packageListIndex: 0 ! !


!PackagePaneBrowser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:59'!
selectCategoryForClass: theClass
	"Set the package and category lists to display the given class."

	| cat |
	cat := theClass category.
	self packageListIndex: (self packageList indexOf: (cat copyUpTo: $-)).	
	self systemCategoryListIndex: (self systemCategoryList indexOf: 
			(cat copyFrom: ((cat indexOf: $- ifAbsent: [0]) + 1) to: cat size)).! !

!PackagePaneBrowser methodsFor: 'system category list' stamp: 'di 12/20/1999 20:16'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0
		ifTrue: [^nil].
	packageListIndex = 0
		ifTrue: [^ self systemCategoryList at: systemCategoryListIndex].
	^ self package , '-' , (self systemCategoryList at: systemCategoryListIndex)! !

!PackagePaneBrowser methodsFor: 'system category list' stamp: 'di 12/16/1999 16:14'!
systemCategoryList
	"Answer the sequenceable collection containing the class categories that 
	the receiver accesses."

	| prefix |
	packageListIndex = 0 ifTrue: [^ systemOrganizer categories].
	prefix := self package, '-'.
	^ Array streamContents:
		[:strm |
		systemOrganizer categories do: 
			[ :cat | (cat beginsWith: prefix) ifTrue:
				[strm nextPut: (cat copyFrom: prefix size + 1 to: cat size)]]]! !


!PackagePaneBrowser methodsFor: 'class list' stamp: 'ak 6/4/2000 09:57'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	^systemCategoryListIndex = 0
		ifTrue: [
			self systemCategoryList isEmpty
				ifTrue: [systemOrganizer listAtCategoryNumber: (systemOrganizer categories indexOf: self package asSymbol)]
				ifFalse: [Array new]]
		ifFalse: [systemOrganizer listAtCategoryNumber:
			(systemOrganizer categories indexOf: self selectedSystemCategoryName asSymbol)]! !

!PackagePaneBrowser methodsFor: 'class list' stamp: 'ak 6/4/2000 09:07'!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	| name envt |
	(name _ self selectedClassName) ifNil: [^ nil].
	"(envt _ self selectedEnvironment) ifNil: [^ nil]."
	envt_(Smalltalk environmentForCategory: self selectedSystemCategoryName).
	^ envt at: name! !


!PackagePaneBrowser methodsFor: 'dragNDrop util' stamp: 'sr 5/5/2000 17:52'!
dstCategoryDstListMorph: dstListMorph internal: internal 
	| dropMorph |
	^ internal & (dstListMorph getListSelector == #systemCategoryList)
		ifTrue: [(dropMorph _ dstListMorph potentialDropMorph) ifNotNil: [(self package , '-' , dropMorph contents) asSymbol]]
		ifFalse: [self selectedSystemCategoryName]! !


!PackagePaneBrowser methodsFor: 'dragNDrop' stamp: 'mir 5/29/2000 11:54'!
changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag 
	"only move semantic"
	| newClassCategory success |
	self flag: #stringSymbolProblem.
	success _ copyFlag not ifFalse: [^ false].
	newClassCategory _ self dstCategoryDstListMorph: dstListMorph internal: internal.
	(success _ newClassCategory notNil & (newClassCategory ~= class category))
		ifTrue: 
			[class category: newClassCategory.
			self changed: #classList.
			internal ifFalse: [self selectClass: class]].
	^ success! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PackagePaneBrowser class
	instanceVariableNames: ''!

!PackagePaneBrowser class methodsFor: 'instance creation' stamp: 'JW 2/2/2001 16:32'!
openBrowser
	"PackagePaneBrowser openBrowser"

	self openBrowserView: (self new openEditString: nil)
			label: 'Package Browser'! !
ImageMorph subclass: #PaintBoxColorPicker
	instanceVariableNames: 'currentColor locOfCurrent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!PaintBoxColorPicker commentStamp: '<historical>' prior: 0!
A pop-up, 16-bit color palette used as part of a PaintBoxMorph.
!


!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:57'!
beStatic

	"an aid for Nebraska: make the color chart a static image to reduce traffic"
	image isStatic ifFalse: [
		image _ image as: StaticForm
	].! !

!PaintBoxColorPicker methodsFor: 'initialization' stamp: 'jm 4/29/1998 21:24'!
initialize

	super initialize.
	currentColor _ Color black.
	locOfCurrent _ nil.
	self initMouseHandlers.
! !


!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:07'!
currentColor

	^ currentColor
! !

!PaintBoxColorPicker methodsFor: 'accessing' stamp: 'jm 4/29/1998 20:18'!
currentColor: aColor
	"Force me to select the given color."

	currentColor _ aColor.
	locOfCurrent _ nil.  "remove the marker"
! !


!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'!
drawOn: aCanvas
	"Image plus circles for currently selected color."

	| c |
	super drawOn: aCanvas.
	locOfCurrent ifNotNil: [
		c _ self ringColor.
		aCanvas
			fillOval: (Rectangle center: locOfCurrent + self topLeft extent: 9@9)
			color: Color transparent
			borderWidth: 1
			borderColor: c].
! !

!PaintBoxColorPicker methodsFor: 'drawing' stamp: 'jm 4/29/1998 20:00'!
ringColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	currentColor isTransparent ifTrue: [^ Color red].
	currentColor red < 0.5 ifTrue: [^ Color red].
	currentColor red > (currentColor green + (currentColor blue * 0.5))
		ifTrue: [^ Color green]
		ifFalse: [^ Color red].
! !


!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/5/2000 16:01'!
endColorSelection: evt
	"Update current color and report it to paint box."

	self selectColor: evt.
	"restore mouseLeave handling"
	self on: #mouseLeave send: #delete to: self.
! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'ar 10/25/2000 17:49'!
initMouseHandlers

	self on: #mouseDown send: #startColorSelection: to: self.
	self on: #mouseMove send: #selectColor: to: self.
	self on: #mouseUp send: #endColorSelection: to: self.
	self on: #mouseLeave send: #delete to: self.
! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'RAA 8/15/2000 16:37'!
selectColor: evt
	"Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically."

	| r |
	locOfCurrent _ evt cursorPoint - self topLeft.
	r _ Rectangle center: locOfCurrent extent: 9@9.
	locOfCurrent _ locOfCurrent + (r amountToTranslateWithin: (5@11 corner: 140@136)).
	locOfCurrent x > 128 ifTrue: [locOfCurrent _ 135@locOfCurrent y].  "snap into grayscale"
	locOfCurrent y < 17
		ifTrue: [
			locOfCurrent _ locOfCurrent x@11.  "snap into transparent"
			currentColor _ Color transparent]
		ifFalse: [
			currentColor _ image colorAt: locOfCurrent].

	(owner isKindOf: PaintBoxMorph) ifTrue: [owner takeColorEvt: evt from: self].

	self changed.
! !

!PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 4/29/1998 21:21'!
startColorSelection: evt
	"Start color selection. Make me stay up as long as the mouse is down."

	self on: #mouseLeave send: nil to: nil.
	self selectColor: evt.
! !
ImageMorph subclass: #PaintBoxMorph
	instanceVariableNames: 'action tool currentCursor thumbnail currentColor currentBrush colorMemory colorPatch stampHolder rotationTabForm scaleTabForm colorMemoryThin brushes focusMorph weakDependents recentColors '
	classVariableNames: 'AllOffImage AllOnImage AllPressedImage ColorChart OriginalBounds Prototype '
	poolDictionaries: ''
	category: 'Morphic-Support'!

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 16:47'!
addWeakDependent: anObject

	weakDependents ifNil: [^weakDependents _ WeakArray with: anObject].
	weakDependents _ weakDependents,{anObject} reject: [ :each | each isNil].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/15/2000 14:59'!
beStatic

	colorMemory ifNotNil: [colorMemory beStatic].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:55'!
createButtons
	"Create buttons one at a time and let the user place them over the background.  Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph.
	self createButtons.	"

| rect button nib |
#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel |
	(self submorphNamed: sel) ifNil: [
		PopUpMenu notify: 'Rectangle for ',sel.
		rect _ Rectangle fromUser.
		button _ ThreePhaseButtonMorph new.
		button onImage: nil; bounds: rect.
		self addMorph: button.
		button actionSelector: #tool:action:cursor:evt:; arguments: (Array with: button with: sel with: nil).
		button actWhen: #buttonUp; target: self.
		]].
#(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind |
	(self submorphNamed: sel) ifNil: [
		PopUpMenu notify: 'Rectangle for ',sel.
		rect _ Rectangle fromUser.
		button _ ThreePhaseButtonMorph new.
		button onImage: nil; bounds: rect.
		self addMorph: button.
		nib _ Form dotOfSize: (#(1 2 3 6 11 26) at: ind).
		button actionSelector: #brush:action:nib:evt:; 
				arguments: (Array with: button with: sel with: nib).
		button actWhen: #buttonUp; target: self.
		]].
"stamp:  Stamps are held in a ScrollingToolHolder.  Pickups and stamps and brushes are id-ed by the button == with item from a list."


! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/16/2000 01:36'!
fixupButtons

	| changes answer newSelector |
	changes _ Dictionary new.
	changes
		at: #brush:action:nib: put: #brush:action:nib:evt:;
		at: #tool:action:cursor: put: #tool:action:cursor:evt:;
		at: #pickup:action:cursor: put: #pickup:action:cursor:evt:;
		at: #keep:with: put: #keep:with:evt:;
		at: #undo:with: put: #undo:with:evt:;
		at: #scrollStamps:action: put: #scrollStamps:action:evt:;
		at: #toss:with: put: #toss:with:evt:;
		at: #eyedropper:action:cursor: put: #eyedropper:action:cursor:evt:;
		at: #clear:with: put: #clear:with:evt:;
		yourself.
	answer _ WriteStream on: String new.
	self allMorphsDo: [ :each |
		(each isKindOf: ThreePhaseButtonMorph) ifTrue: [
			answer nextPutAll: each actionSelector.
			(changes includesKey: each actionSelector) ifTrue: [
				each actionSelector: (newSelector _ changes at: each actionSelector).
				answer nextPutAll: ' <-- ',newSelector.
			].
			answer cr.
		].
	].
	^answer contents
	"StringHolder new
		contents: answer contents;
		openLabel: 'button fixups'"! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:55'!
init3
	"Just a record of how we loaded in the latest paintbox button images"
| bb rect lay pic16Bit aa blt on thin |
self loadoffImage: 'etoy_default.gif'.
self allMorphsDo: [:button |
	(button isKindOf: ThreePhaseButtonMorph) 
		ifTrue: [button offImage: nil]
		ifFalse: [button position: button position + (100@0)]].
(bb _ self submorphNamed: #keep:) position: bb position + (100@0).
(bb _ self submorphNamed: #toss:) position: bb position + (100@0).
(bb _ self submorphNamed: #undo:) position: bb position + (100@0).
"Transparent is (Color r: 1.0 g: 0 b: 1.0)"

self moveButtons.
self loadOnImage: 'etoy_in.gif'.
AllOnImage _ nil.	'save space'.	
self loadPressedImage: 'etoy_in.gif'.
AllPressedImage _ nil.	'save space'.
self loadCursors.

"position the stamp buttons"
stampHolder stampButtons owner last delete.
stampHolder pickupButtons last delete.
stampHolder stampButtons: (stampHolder stampButtons copyFrom: 1 to: 3).
stampHolder pickupButtons: (stampHolder pickupButtons copyFrom: 1 to: 3).
"| rect |"
stampHolder pickupButtons do: [:button |
		"PopUpMenu notify: 'Rectangle for ',sel."
		rect _ Rectangle fromUser.
		button bounds: rect.	"image is nil"
		].
"| rect lay |"
stampHolder clear.
stampHolder stampButtons do: [:button |
		button offImage: nil; pressedImage: nil.
		lay _ button owner.
		"PopUpMenu notify: 'Rectangle for ',sel."
		rect _ Rectangle fromUser.
		button image: (Form fromDisplay: (rect insetBy: 2)).
		lay borderWidth: 2.
		lay bounds: rect.	"image is nil"
		].
"| pic16Bit blt aa on |"
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: 'etoy_in.gif'.
	aa _ Form extent: OriginalBounds extent depth: 8.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	"Collect all the images for the buttons in the on state"
	stampHolder pickupButtons do: [:button |
			on _ ColorForm extent: button extent depth: 8.
					 on colors: pic16Bit colors.
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in: aa rule: Form over.
			button image: on; pressedImage: on; offImage: nil.
			].
	self invalidRect: bounds.

((self submorphNamed: #erase:) arguments at: 3) offset: (12@35).
((self submorphNamed: #eyedropper:) arguments at: 3) offset: (0@0).
((self submorphNamed: #fill:) arguments at: 3) offset: (10@44).
((self submorphNamed: #paint:) arguments at: 3) offset: (3@3). "unused"
((self submorphNamed: #rect:) arguments at: 3) offset: (6@17).
((self submorphNamed: #ellipse:) arguments at: 3) offset: (5@4).
((self submorphNamed: #polygon:) arguments at: 3) offset: (5@4).
((self submorphNamed: #line:) arguments at: 3) offset: (5@17).
((self submorphNamed: #star:) arguments at: 3) offset: (2@5).
thumbnail delete.
thumbnail _ nil.
(submorphs select: [:e | e class == RectangleMorph]) first bounds: 
	Rectangle fromUser.
(submorphs select: [:e | e class == RectangleMorph]) first borderWidth: 1; borderColor: Color black.
"| thin |"
	submorphs do: [:ss | ss class == ImageMorph ifTrue: [thin _ ss "first"]].
colorMemoryThin _ thin.
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:56'!
init4
	"Just a record of how Ted loaded in the paintbox button images, Feb 98"
| bb im pp newImage pic24Bit picNewBit blt |

"self loadoffImage: 'roundedPalette3.bmp'."
pic24Bit _ GIFReadWriter formFromServerFile: 'updates/137roundedPalette3.bmp'.
picNewBit _ Form extent: pic24Bit extent depth: 16.
pic24Bit displayOn: picNewBit.
OriginalBounds _ picNewBit boundingBox.
AllOffImage _ Form extent: OriginalBounds extent depth: 16.
blt _ BitBlt current toForm: AllOffImage.
blt sourceForm: picNewBit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.

AllOffImage mapColor: Color transparent to: Color black.
self image: AllOffImage.
self invalidRect: bounds.

self submorphsDo: [:button | button position: button position + (10@10)].
(im _ submorphs at: 28) class == ImageMorph ifTrue: [
	im position: im position + (2@0)].	"color picker"
"exercise it once"

(bb _ self submorphNamed: #keep:) position: bb position + (0@25).
(bb _ self submorphNamed: #toss:) position: bb position + (0@25).
(bb _ self submorphNamed: #undo:) position: bb position + (0@-25).
(bb _ self submorphNamed: #clear:) position: bb position + (0@-25).
(bb _ self submorphNamed: #undo:) position: bb position + (0@-69).
(bb _ self submorphNamed: #clear:) position: bb position + (0@-69).
self submorphsDo: [:button | 
	button class == AlignmentMorph ifTrue: [
		button position: button position + (0@25)].
	(button printString includesSubString: 'stamp:') ifTrue: [
		button position: button position + (0@25)]].
(bb _ self submorphNamed: #prevStamp:) position: bb position + (0@25).
(bb _ self submorphNamed: #nextStamp:) position: bb position + (0@25).

bb _ self submorphNamed: #keep:.
newImage _ bb pressedImage copy: (0@4 corner: (bb pressedImage boundingBox extent)).
bb onImage: newImage.  bb pressedImage: newImage.  bb extent: newImage extent.
bb position: bb position + (4@1).

pp _ (bb _ self submorphNamed: #toss:) pressedImage.
newImage _ pp copy: (0@4 corner: (bb pressedImage extent - (3@0))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@1).

pp _ (bb _ self submorphNamed: #undo:) pressedImage.
newImage _ pp copy: (0@0 corner: (bb pressedImage extent - (3@5))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@-1).

pp _ (bb _ self submorphNamed: #clear:) pressedImage.
newImage _ pp copy: (0@0 corner: (bb pressedImage extent - (0@5))).
bb onImage: newImage.  bb pressedImage: newImage.  
bb extent: newImage extent.
bb position: bb position + (3@-1).

pic24Bit _ GIFReadWriter formFromServerFile: 'updates/137pencil.bmp'.
picNewBit _ Form extent: pic24Bit extent depth: 16.
pic24Bit displayOn: picNewBit.
newImage _ picNewBit as8BitColorForm.
newImage transparentColor: (Color r: 0 g: 0 b: 0).
(bb _ self submorphNamed: #erase:) pressedImage: newImage; onImage: newImage;
	extent: newImage extent.

bb position: bb position + (-11@-1).
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 7/28/2000 23:26'!
initialize
	super initialize.
	colorMemory ifNotNil: [colorMemory on: #mouseDown send: #takeColorEvt:from: to: self].! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'jm 6/18/1999 18:58'!
loadColorChooser
	"Load Forms for ColorMemoryMorph."

	| doc closedForm openForm |
	doc _ Utilities objectStrmFromUpdates: 'colorPalClosed.obj'.
	closedForm _ doc fileInObjectAndCode mapColor: Color transparent to: Color black.
	doc _ Utilities objectStrmFromUpdates: 'colorPalOpen.obj'.
	openForm _ doc fileInObjectAndCode mapColor: Color transparent to: Color black.

	colorMemoryThin image: closedForm.
	colorMemoryThin position: self position + (0@140).

	colorMemory delete.	"delete old one"
	colorMemory _ PaintBoxColorPicker new image: openForm.
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:56'!
loadCursors
	"Display the form containing the cursors.  Transparent is (Color r: 1.0 g: 0 b: 1.0).  Grab the forms one at a time, and they are stored away.
	self loadCursors.	"

| button transp cursor map |
transp _ Color r: 1.0 g: 0 b: 1.0.
map _ Color indexedColors copy.	"just in case"
1 to: 256 do: [:ind | (map at: ind) = transp ifTrue: [
			map at: ind put: Color transparent]].

#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: ) do: [:sel |
	PopUpMenu notify: 'Rectangle for ',sel.
	cursor _ ColorForm fromUser.
	cursor colors: map.	"share it"
	button _ self submorphNamed: sel.
	button arguments at: 3 put: cursor.
	].
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'!
loadOnImage: fileName
	"Read in and convert the image for the paintBox with the buttons
on.  A .bmp 24-bit image.  For each button, cut that chunk out and save it."
	"	self loadOnImage: 'NoSh_on.bmp'.
		AllOnImage _ nil.	'save space'.	"

	| pic16Bit blt aa on type |
	type _ 'gif'.  "   gif or bmp  "
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	pic16Bit display.
	aa _ AllOnImage _ Form extent: OriginalBounds extent depth: 8.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	].
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	pic16Bit display.
	aa _ AllOnImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	aa mapColor: Color transparent to: Color black.
	].
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			type = 'gif' ifTrue: [on _ ColorForm extent: button extent depth: 8.
					 on colors: pic16Bit colors]
				ifFalse: [on _ Form extent: button extent depth: 16].
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in: aa rule: Form over.
			button onImage: on]].
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'!
loadPressedImage: fileName
	"Read in and convert the image for the paintBox with the buttons
on.  A .bmp 24-bit image.  For each button, cut that chunk out and save it."
	"	self loadPressedImage: 'NoSh_on.bmp'.
		AllPressedImage _ nil.	'save space'.	"

	| pic16Bit blt aa on type |
	type _ 'gif'.  "   gif or bmp  "
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	pic16Bit display.
	aa _ AllPressedImage _ Form extent: OriginalBounds extent depth: 8.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	].
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	pic16Bit display.
	aa _ AllPressedImage _ Form extent: OriginalBounds extent depth: 16.
	blt _ BitBlt current toForm: aa.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.
	aa mapColor: Color transparent to: Color black.
	].
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			type = 'gif' ifTrue: [on _ ColorForm extent: button extent depth: 8.
					 on colors: pic16Bit colors]
				ifFalse: [on _ Form extent: button extent depth: 16].
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in: aa rule: Form over.
			button pressedImage: on]].
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'ar 5/28/2000 12:10'!
loadoffImage: fileName
	"Read in and convert the background image for the paintBox.  All
buttons off.  A .bmp 24-bit image."
	"	Prototype loadoffImage: 'roundedPalette3.bmp'	"

	| pic16Bit blt type getBounds |
	type _ 'bmp'.  " gif or bmp  "
	getBounds _ 'fromPic'.	"fromUser = draw out rect of paintbox on image"
		"fromOB = just read in new bits, keep same size and place as last time."
		"fromPic = picture is just the PaintBox, use its bounds"
type = 'gif' ifTrue: [
	pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName.
	getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds"
			pic16Bit display.
			OriginalBounds _ Rectangle fromUser].
	getBounds = 'fromPic' ifTrue: [OriginalBounds _ pic16Bit boundingBox].
	].
		"Use OriginalBounds as it was last time".
type = 'bmp' ifTrue: [
	pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16.
	getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds"
			pic16Bit display.
			OriginalBounds _ Rectangle fromUser].
		"Use OriginalBounds as it was last time".
	(getBounds = 'fromPic') ifTrue: [OriginalBounds _ pic16Bit boundingBox].
	AllOffImage _ Form extent: OriginalBounds extent depth: 16.
	].

type = 'gif' ifTrue: [
	AllOffImage _ ColorForm extent: OriginalBounds extent depth: 8.
	AllOffImage colors: pic16Bit colors].

	blt _ BitBlt current toForm: AllOffImage.
	blt sourceForm: pic16Bit; combinationRule: Form over;
		sourceRect: OriginalBounds; destOrigin: 0@0; copyBits.

type = 'bmp' ifTrue: [AllOffImage mapColor: Color transparent to: Color black].
	self image: AllOffImage.
	self invalidRect: bounds.

	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/2000 11:57'!
moveButtons
	"Move buttons one at a time and let the user place them over the background.  Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph.
	self createButtons.	"

| rect button |
#(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel |
		PopUpMenu notify: 'Rectangle for ',sel.
		rect _ Rectangle fromUser.
		button _ self submorphNamed: sel.
		button bounds: rect.	"image is nil"
		].
#(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind |
		PopUpMenu notify: 'Rectangle for ',sel.
		rect _ Rectangle fromUser.
		button _ self submorphNamed: sel.
		button bounds: rect.	"image is nil"
		].
"stamp:  Stamps are held in a ScrollingToolHolder.  Pickups and stamps and brushes are id-ed by the button == with item from a list."

"
"
! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'tk 8/22/97 15:57'!
noVeneer
	"For a palette with a background (off) image, clear that image.
But first, for each button, cut that chunk out and save it in the offImage
part."
	"	self noVeneer.
		AllOffImage _ nil.	'save space.  irreversible'.	"

	| aa on |
	AllOffImage ifNil: [AllOffImage _ image].
	aa _ AllOffImage.
	"Collect all the images for the buttons in the on state"
	self allMorphsDo: [:button |
		(button isKindOf: ThreePhaseButtonMorph) ifTrue: [
			on _ Form extent: button extent depth: 16.
			on copy: (0@0 extent: button extent)
				from: (button topLeft - self topLeft) in:
aa rule: Form over.
			button offImage: on]].
	self image: (Form extent: AllOffImage extent depth: 1).
	self invalidRect: bounds.


	! !

!PaintBoxMorph methodsFor: 'initialization' stamp: 'RAA 8/16/2000 11:12'!
notifyWeakDependentsWith: arguments

	weakDependents ifNil: [^self].
	weakDependents do: [ :each |
		each ifNotNil: [
			each paintBoxChanged: arguments.
			each paintBoxChanged: {#changed. arguments second. true}.
		].
	].! !


!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 12:52'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	"super addCustomMenuItems: aCustomMenu hand: aHandMorph."
		"don't want the ones from ImageMorph"
	aCustomMenu add: 'grab stamp from screen' action: #grabFromScreen:.

! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:38'!
colorMemory

	^ colorMemory! !

!PaintBoxMorph methodsFor: 'other' stamp: 'di 10/14/97 10:15'!
colorMemory: aMorph

	colorMemory _ aMorph! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 10/31/97 13:35'!
colorPatch
	^ colorPatch! !

!PaintBoxMorph methodsFor: 'other' stamp: 'di 10/14/97 13:28'!
copyRecordingIn: dict
	"Overridden to copy the stamps holder."

	| new |
	new _ super copyRecordingIn: dict.
	new stampHolder: stampHolder copy.
	new colorMemory: (colorMemory copyRecordingIn: dict).
	^ new! !

!PaintBoxMorph methodsFor: 'other' stamp: 'ar 3/23/2000 14:18'!
focusMorph
	"Note: For backward compatibility we search the world for a SketchEditorMorph if the current focus morph is nil"
	^focusMorph ifNil:[focusMorph _ self world findA: SketchEditorMorph]! !

!PaintBoxMorph methodsFor: 'other' stamp: 'ar 3/23/2000 14:20'!
focusMorph: newFocus
	"Set the new focus morph"
	focusMorph ifNotNil:[focusMorph paletteDetached: self]. "In case the morph is interested"
	focusMorph _ newFocus.
	focusMorph ifNotNil:[focusMorph paletteAttached: self]. "In case the morph is interested"! !

!PaintBoxMorph methodsFor: 'other' stamp: 'sw 6/30/1999 20:33'!
isCandidateForAutomaticViewing
	^ false! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 11:57'!
maxBounds
	| rr |
	"fullBounds if all flop-out parts of the paintBox were showing."

	rr _ bounds merge: colorMemory bounds.
	rr _ rr merge: (self submorphNamed: 'stamps') bounds.
	rr _ rr origin corner: rr corner + (0@ (self submorphNamed: 'shapes') height 
				+ 10 "what is showing of (self submorphNamed: #toggleShapes) height").
	^ rr! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 8/22/2000 23:48'!
offsetFromMaxBounds
	"location of normal PaintBox within maxBounds."

	^ self left - colorMemory left @ 0! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'!
rotationTabForm
	^ rotationTabForm! !

!PaintBoxMorph methodsFor: 'other' stamp: 'tk 7/17/97 16:26'!
scaleTabForm
	^ scaleTabForm! !

!PaintBoxMorph methodsFor: 'other' stamp: 'di 10/14/97 10:13'!
updateReferencesUsing: aDictionary
	"Fix up stampHolder which is a ScrollingToolHolder, which is not a Morph"

	super updateReferencesUsing: aDictionary.
	stampHolder updateReferencesUsing: aDictionary.
	colorMemory updateReferencesUsing: aDictionary.! !


!PaintBoxMorph methodsFor: 'actions' stamp: 'laza 3/24/2000 17:58'!
action
	^ action	! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:35'!
actionCursor
	"Return the cursor to use with this painting action/tool. Offset of the form must be set."

	^self
		cursorFor: action
		oldCursor: currentCursor
		currentNib: self getNib
		color: currentColor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:16'!
brush: brushButton action: aSelector nib: aMask evt: evt
	"Set the current tool and action for the paintBox.  "

	currentBrush ifNotNil: [
		currentBrush == brushButton ifFalse: [currentBrush state: #off]].
	currentBrush _ brushButton.		"A ThreePhaseButtonMorph"

	"currentBrush state: #on.	already done"
	"aSelector is like brush3:.  Don't save it.  Can always say (currentBrush arguments at: 2)
	aMask is the brush shape.  Don't save it.  Can always say (currentBrush arguments at: 3)"

	self notifyWeakDependentsWith: {#currentNib. evt. currentBrush arguments at: 3}.

	self brushable ifFalse: [self setAction: #paint: evt: evt].	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 10/19/97 11:12'!
brushable
	"Return true if the current tool uses a brush."
	^ (#("non-brushable" eyedropper: fill: pickup: stamp:) indexOf: action) = 0! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:34'!
clear: clearButton with: clearSelector evt: evt

	| ss |
	(ss _ self focusMorph) 
		ifNotNil: [ss clearPainting: self]
		ifNil: [self notCurrentlyPainting].
	clearButton state: #off.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/15/97 13:35'!
colorable
	"Return true if the current tool uses a color."
	^ (#("These use no color" erase: eyedropper: "fill: does" pickup: stamp:) indexOf: action) = 0! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 17:06'!
currentColor: aColor evt: evt
	"Accept a color from the outside.  (my colorMemoryMorph must call takeColorEvt: evt from: colorPicker instead)"

	currentColor _ aColor.
	colorMemory currentColor: aColor.
	self notifyWeakDependentsWith: {#currentColor. evt. currentColor}.
	self showColor.
	self colorable ifFalse: [self setAction: #paint: evt: evt].	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:37'!
cursorFor: anAction oldCursor: oldCursor currentNib: aNibForm color: aColor 
	"Return the cursor to use with this painting action/tool. Offset of the 
	form must be set."

	| ff width co larger c box |

	anAction == #paint:
		ifTrue: ["Make a cursor from the brush and the color"
			width _ aNibForm width.
			c _ self ringColorFor: aColor.
			co _ oldCursor offset - (width // 4 @ 34 - (width // 6)) min: 0 @ 0.
			larger _ width negated + 10 @ 0 extent: oldCursor extent + (width @ width).
			ff _ oldCursor copy: larger.
			ff colors at: 1 put: Color transparent.
			ff colors at: 2 put: Color transparent.
			ff offset: co - (width @ width // 2).
			ff getCanvas
				fillOval: (Rectangle center: ff offset negated extent: width @ width)
				color: Color transparent
				borderWidth: 1
				borderColor: c.
			^ ff].
	anAction == #erase:
		ifTrue: ["Make a cursor from the cursor and the color"
			width _ aNibForm width.
			co _ oldCursor offset + (width // 2 @ 4) min: 0 @ 0.
			larger _ 0 @ 0 extent: oldCursor extent + (width @ width).
			ff _ oldCursor copy: larger.
			ff offset: co - (width @ width // 2).
			ff
				fill: (box _ co negated extent: width @ width)
				fillColor: (Color r: 0.5 g: 0.5 b: 1.0).
			ff
				fill: (box insetBy: 1 @ 1)
				fillColor: Color transparent.
			^ ff].
	^ oldCursor! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 09:26'!
deleteCurrentStamp: evt
	"The trash is telling us to delete the currently selected stamp"

	(tool arguments at: 2) == #stamp: ifTrue: [
		stampHolder remove: tool.
		self setAction: #paint: evt: evt].	"no use stamping with a blank stamp"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'kfr 9/1/2000 19:29'!
eyedropper: aButton action: aSelector cursor: aCursor evt: evt 
	"Take total control and pick up a color!!!!"
	| pt feedbackColor |
	aButton state: #on.
	tool
		ifNotNil: [tool state: #off].
	currentCursor _ aCursor.
	evt hand showTemporaryCursor: currentCursor hotSpotOffset: 6 negated @ 4 negated.
	"<<<< the form was changed a bit??"
	feedbackColor _ Display colorAt: Sensor cursorPoint.
	colorMemory align: colorMemory bounds topRight with: colorMemoryThin bounds topRight.
	self addMorphFront: colorMemory.
	"Full color picker"
	[Sensor anyButtonPressed]
		whileFalse: [pt _ Sensor cursorPoint.
			"deal with the fact that 32 bit displays may have garbage in the 
			alpha bits"
			feedbackColor _ Display depth = 32
						ifTrue: [Color
								colorFromPixelValue: ((Display pixelValueAt: pt)
										bitOr: 4278190080)
								depth: 32]
						ifFalse: [Display colorAt: pt].
			"the hand needs to be drawn"
			evt hand position: pt.
			self world displayWorldSafely].
	Sensor waitNoButton.
	evt hand showTemporaryCursor: nil hotSpotOffset: 0 @ 0.
	self currentColor: feedbackColor evt: evt.
	colorMemory delete.
	tool
		ifNotNil: [tool state: #on.
			currentCursor _ tool arguments at: 3].
	aButton state: #off! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:52'!
getColor
	^ currentColor! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:24'!
getNib
	^ currentBrush arguments at: 3! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 13:02'!
getSpecial
	^ action		"a selector like #paint:"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 12:55'!
grabFromScreen: evt
	"Allow the user to grab a picture from the screen OUTSIDE THE PAINTING AREA and install it in a blank stamp.  To get a stamp in the painting area, click on the stamp tool in a blank stamp."

	| stampButton form |
	"scroll to blank stamp"
	stampButton _ stampHolder stampButtons first.
	[(stampHolder stampFormFor: stampButton) == nil] whileFalse: [stampHolder scroll: 1].
	form _ Form fromUser.
	tool state: #off.
	tool _ stampHolder otherButtonFor: stampButton.
	stampHolder stampForm: form for: tool.	"install it"
	stampButton state: #on.
	stampButton doButtonAction: evt.
	evt hand showTemporaryCursor: (focusMorph getCursorFor: evt).
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 8/29/2000 15:31'!
indicateColorUnderMouse
	"Track the mouse with the special eyedropper cursor, and accept whatever color is under the mouse as the currently-chosen color; reflect that choice in the feedback box, and return that color."

	| pt feedbackColor |
	pt _ Sensor cursorPoint.
	"deal with the fact that 32 bit displays may have garbage in the alpha bits"
	feedbackColor _ Display depth = 32
		ifTrue: [ Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 16rFF000000) depth: 32] 		ifFalse: [Display colorAt: pt].

	self activeHand position: pt.
	self world displayWorldSafely.
	Display fill: colorPatch bounds fillColor: feedbackColor.
	^ feedbackColor	! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:48'!
keep: keepButton with: keepSelector evt: evt
	"Showing of the corrent palette (viewer or noPalette) is done by the block submitted to the SketchMorphEditor, see (EToyHand makeNewDrawing) and (SketchMorph editDrawingInWorld:forBackground:)."
	| ss |
	owner ifNil: [^ self].
	keepButton ifNotNil: [keepButton state: #off].
	(ss _ self focusMorph) 
		ifNotNil: [ss savePainting: self evt: evt]
		ifNil:
		[keepSelector == #silent ifTrue: [^ self].
		self notCurrentlyPainting].! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 08:10'!
mouseUpBalk: evt
	"A button I own got a mouseDown, but the user moved out before letting up.  Prevent this for the current tool.  Some tool must stay selected."

	tool state: #on.	"keep current one, even if user balked on it"
	currentBrush ifNotNil: [currentBrush state: #on].! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'sw 5/3/1998 18:22'!
notCurrentlyPainting
	self inform: 'You are not currently painting'! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:43'!
pickup: actionButton action: aSelector cursor: aCursor evt: evt
	"Special version for pickup: and stamp:, because of these tests"

	| ss picker old map stamper |

	self tool: actionButton action: aSelector cursor: aCursor evt: evt.

	aSelector == #stamp: ifTrue: [
		(stampHolder pickupButtons includes: actionButton) ifTrue: [
				stamper _ stampHolder otherButtonFor: actionButton.
				^ self pickup: stamper action: #stamp: cursor: (stamper arguments at: 3) evt: evt].
		(stampHolder stampFormFor: actionButton) 
			ifNil: [
				"If not stamp there, go to pickup mode"
				picker _ stampHolder otherButtonFor: actionButton.
				picker state: #on.
				^ self pickup: picker action: #pickup: cursor: (picker arguments at: 3) evt: evt]
			ifNotNil: [
				old _ stampHolder stampFormFor: actionButton.
				currentCursor _ ColorForm extent: old extent depth: 8.
				old displayOn: currentCursor.
				map _ Color indexedColors copy.
				map at: 1 put: Color transparent.
				currentCursor colors: map.
				currentCursor offset: currentCursor extent // -2.
				"Emphisize the stamp button"
				actionButton owner "layoutMorph" "color: (Color r: 1.0 g: 0.645 b: 0.419);"
					borderColor: (Color r: 0.65 g: 0.599 b: 0.8).
				]].

	aSelector == #pickup: ifTrue: [
		ss _ self focusMorph.
		ss ifNotNil: [currentCursor _ aCursor]	 
			ifNil: [self notCurrentlyPainting.
				self setAction: #paint: evt: evt]].
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 22:13'!
pickupForm: stampForm
	"Install the new picture in this stamp"

	| stampButton |
	stampHolder stampForm: stampForm for: tool.
	stampButton _ action == #pickup: 
		ifTrue: [stampHolder otherButtonFor: tool]
		ifFalse: [tool].	"was a nil stampForm"
	stampButton state: #on.
	stampButton doButtonAction.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/17/2000 14:59'!
pickupForm: stampForm evt: evt
	"Install the new picture in this stamp"

	| stampButton |
	stampHolder stampForm: stampForm for: tool.
	stampButton _ action == #pickup: 
		ifTrue: [stampHolder otherButtonFor: tool]
		ifFalse: [tool].	"was a nil stampForm"
	stampButton state: #on.
	stampButton doButtonAction: evt.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:40'!
plainCursor
	"Return the cursor to use with this painting action/tool. Offset of the form must be set."

	^currentCursor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 10/10/2000 16:38'!
plainCursor: aCursor event: anEvent
	"Set the cursor to use with this painting action/tool. Offset of the form must be set."

	currentCursor _ aCursor.
	anEvent hand showTemporaryCursor: aCursor.
	self notifyWeakDependentsWith: {#currentCursor. anEvent. currentCursor}.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:30'!
ringColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	^self ringColorFor: currentColor
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 13:29'!
ringColorFor: aColor
	"Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green"

	aColor isTransparent ifTrue: [^ Color red].
	aColor red < 0.5 ifTrue: [^ Color red].
	aColor red > (aColor green + (aColor blue * 0.5))
		ifTrue: [^ Color green]
		ifFalse: [^ Color red].
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:44'!
scrollStamps: actionButton action: aSelector evt: evt
	"Move the stamps over"

	aSelector == #prevStamp:
		ifTrue: [stampHolder scroll: -1]
		ifFalse: [stampHolder scroll: 1].
	actionButton state: #off.
	action == #stamp: ifTrue: ["reselect the stamp and compute the cursor"
		self stampForm 
			ifNil: [self setAction: #paint: evt: evt]
			ifNotNil: [tool doButtonAction: evt]].
		! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:57'!
setAction: aSelector evt: evt
	"Find this button and turn it on.  Does not work for stamps or pickups"

	| button |
	button _ self submorphNamed: aSelector.
 
	button ifNotNil: [
		button state: #on.
		button doButtonAction: evt].	"select it!!"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:58'!
showColor
	"Display the current color in all brushes, both on and off."

	| offIndex onIndex center |
	currentColor ifNil: [^ self].
	"colorPatch color: currentColor.	May delete later"
	(brushes == nil or: [brushes first owner ~~ self]) ifTrue: [
		brushes _ OrderedCollection new.
		#(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel |
			brushes addLast: (self submorphNamed: sel)]].
	center _ (brushes at: 6) offImage extent // 2.
	offIndex _ (brushes at: 6) offImage pixelValueAt: center.
	onIndex _ (brushes at: 6) onImage pixelValueAt: center.
	brushes do: [:bb |
		bb offImage colors at: offIndex+1 put: currentColor.
		bb offImage clearColormapCache.
		bb onImage colors at: onIndex+1 put: currentColor.
		bb onImage clearColormapCache.
		bb invalidRect: bb bounds].

	self invalidRect: (brushes first topLeft rect: brushes last bottomRight).
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 10/5/2000 11:59'!
showColorPalette: evt

	self comeToFront.
	colorMemory align: colorMemory bounds topRight 
			with: colorMemoryThin bounds topRight.
	self addMorphFront: colorMemory.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/22/2000 11:58'!
stampCursorBeCursorFor: anAction
	"User just chose a stamp.  Take that stamp picture and make it be the cursor for the tool named."
	"self stampCursorBeCursorFor: #star:.
	currentCursor offset: -9@-3.			Has side effect on the saved cursor."

	(self submorphNamed: anAction) arguments at: 3 put: currentCursor.
		"Already converted to 8 bits and in the right form"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'di 5/6/1998 21:08'!
stampDeEmphasize
	"Turn off an emphasized stamp.  Was turned on in pickup:action:cursor:"

	tool owner class == AlignmentMorph ifTrue: [
		tool "actionButton" owner "layoutMorph" color: Color transparent; 
					borderColor: Color transparent].! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/2/97 14:02'!
stampForm
	"Return the selected stamp"

	^ stampHolder stampFormFor: tool.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:47'!
stampHolder

	^ stampHolder! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/17/97 11:48'!
stampHolder: newOne

	stampHolder _ newOne! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:00'!
takeColor: aColor event: evt
	"Accept the given color programmatically"
	currentColor _ aColor.
	self notifyWeakDependentsWith: {#currentColor. evt. currentColor}.
	self showColor.
	self colorable ifFalse: [self setAction: #paint: evt: evt].	"User now thinking of painting"! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'ar 9/23/2000 20:39'!
takeColorEvt: evt from: colorPicker
	"Accept a new color from the colorMemory.  Programs use currentColor: instead.  Do not do this before the picker has a chance to set its own color!!"
	^self takeColor: colorPicker currentColor event: evt! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 16:06'!
toggleShapes
	| tab sh stamps |
	"The sub panel that has the shape tools on it.  Rect, line..."
	stamps _ self submorphNamed: 'stamps'.
	tab _ self submorphNamed: 'shapeTab'.
	(sh _ self submorphNamed: 'shapes') visible
		ifTrue: [sh hide.  tab top: stamps bottom-1]
		ifFalse: [sh comeToFront.  sh top: stamps bottom-9.  
				sh show.  tab top: sh bottom - tab height + 10].
	self layoutChanged.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 8/21/2000 15:57'!
toggleStamps
	| tab otherTab st shapes |
	"The sub panel that has the stamps in it.  For saving and moving parts of an image."
	shapes _ self submorphNamed: 'shapes'.
	otherTab _ self submorphNamed: 'shapeTab'.
	tab _ self submorphNamed: 'stampTab'.
	(st _ self submorphNamed: 'stamps') visible
		ifTrue: [st hide.  st bottom: self bottom.  tab top: self bottom-1.
				shapes top: self bottom-9.
				otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 
									ifFalse: [self bottom-1])]
		ifFalse: [st top: self bottom-10.  st show.  tab top: st bottom-0.
				shapes top: st bottom-9.
				otherTab top: (shapes visible ifTrue: [shapes bottom - otherTab height + 10] 
									ifFalse: [st bottom-0])].
	self layoutChanged.! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'tk 7/1/97 12:09'!
tool
	^ tool! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 12:38'!
tool: actionButton action: aSelector cursor: aCursor evt: evt
	"Set the current tool and action for the paintBox.  "

	tool ifNotNil: [
		tool == actionButton ifFalse: [
			tool state: #off.
			action == #stamp: ifTrue: [self stampDeEmphasize]]].
	tool _ actionButton.		"A ThreePhaseButtonMorph"
	"tool state: #on.	already done"
	action _ aSelector.		"paint:"
	currentCursor _ aCursor.
	self notifyWeakDependentsWith: {#action. evt. action}.
	self notifyWeakDependentsWith: {#currentCursor. evt. currentCursor}.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 01:45'!
toss: cancelButton with: cancelSelector evt: evt
	"Reject the painting.  Showing noPalette is done by the block submitted to the SketchEditorMorph"

	| focus |
	owner ifNil: ["it happens"  ^ self].
	(focus _ self focusMorph) 
		ifNotNil: [focus cancelPainting: self evt: evt]
		ifNil:
			[self delete].
	cancelButton state: #off.
! !

!PaintBoxMorph methodsFor: 'actions' stamp: 'RAA 8/16/2000 11:15'!
undo: undoButton with: undoSelector evt: evt
	| ss |
	(ss _ self focusMorph) 
		ifNotNil: [ss undoPainting: self evt: evt]
		ifNil: [self notCurrentlyPainting].
	undoButton state: #off.! !



!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 20:19'!
fixUpColorPicker
	| chart picker |
	chart _ ColorChart ifNil:[Cursor wait showWhile:[ColorChart _ (Color colorPaletteForDepth: 16 extent: 120@89)]].
	chart getCanvas frameRectangle: chart boundingBox color: Color black.
	picker _ Form extent: (chart extent + (14@12)) depth: 16.
	picker fillWhite.
	"top"
	picker copy: (0@0 extent: picker width@6)
			from: (colorMemory image width - picker width)@0 
			in: colorMemory image rule: Form over.
	"bottom"
	picker copy: (0@ (picker height-6) extent: picker width@6) 
			from: (colorMemory image width - picker width)@(colorMemory image height - 7)
			in: colorMemory image rule: Form over.
	"left"
	picker copy: (0@6 corner: 8@(picker height - 6))
			from: (colorMemory image boundingBox topLeft + (0@6)) 
			in: colorMemory image rule: Form over.
	"right"
	picker copy: (picker width-6@6 corner: picker width@(picker height - 6))
			from: (colorMemory image boundingBox topRight - (6@-6)) 
			in: colorMemory image rule: Form over.
	chart displayOn: picker at: 8@6.
	picker getCanvas frameRectangle: picker boundingBox color: Color black.
	colorMemory image: picker.
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 10/25/2000 17:50'!
fixUpRecentColors
	| inner outer border box form newImage canvas morph |
	self fixUpColorPicker.
	recentColors _ WriteStream on: Array new.
	form _ image.
	newImage _ Form extent: form extent + (0@41) depth: form depth.
	form displayOn: newImage.
	newImage copy: ((0@(form height-10)) extent: form width @ (newImage height - form height + 10)) 
		from: 0 @ (form height - (newImage height - form height + 10))
		in: form rule: Form over.
	canvas _ newImage getCanvas.
	canvas line: 12@(form height-10) to: 92@(form height-10) width: 1 color: Color black.
	canvas _ canvas copyOffset: 12@(form height-9).

	inner _ (Color r: 0.677 g: 0.71 b: 0.968).
	outer _ inner darker darker.
	border _  (Color r: 0.194 g: 0.258 b: 0.194).
	0 to: 1 do:[:y|
		0 to: 3 do:[:x|
			box _ (x*20) @ (y*20) extent: 20@20.
			morph _ BorderedMorph new bounds: ((box insetBy: 1) translateBy: canvas origin + bounds origin).
			morph borderWidth: 1; borderColor: border.
			morph color: Color white.
			morph on: #mouseDown send: #mouseDownRecent:with: to: self.
			morph on: #mouseMove send: #mouseStillDownRecent:with: to: self.
			morph on: #mouseUp send: #mouseUpRecent:with: to: self.
			self addMorphFront: morph.
			recentColors nextPut: morph.
			canvas fillRectangle: box color: Color white.
			canvas frameRectangle: (box insetBy: 1) color: border.
			canvas frameRectangle: (box) color: inner.
			box _ box insetBy: 1.
			canvas line: box topRight to: box bottomRight width: 1 color: outer.
			canvas line: box bottomLeft to: box bottomRight width: 1 color: outer.
	]].
	recentColors _ recentColors contents.
	self image: newImage.
	self toggleStamps.
	self toggleStamps.! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:54'!
mouseDownRecent: evt with: aMorph
	aMorph borderColor: Color white.
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 20:01'!
mouseStillDownRecent: evt with: aMorph
	(aMorph containsPoint: evt cursorPoint)
		ifTrue:[aMorph borderColor: Color white]
		ifFalse:[aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194)]
! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 19:59'!
mouseUpRecent: evt with: aMorph
	aMorph borderColor: (Color r: 0.194 g: 0.258 b: 0.194).
	(aMorph containsPoint: evt cursorPoint) ifTrue:[
		self takeColor: aMorph color event: evt.
	].! !

!PaintBoxMorph methodsFor: 'recent colors' stamp: 'ar 9/23/2000 20:09'!
recentColor: aColor
	"Remember the color as one of our recent colors"
	(recentColors anySatisfy:[:any| any color = aColor]) ifTrue:[^self]. "already remembered"
	recentColors size to: 2 by: -1 do:[:i|
		(recentColors at: i) color: (recentColors at: i-1) color.
	].
	(recentColors at: 1) color: aColor.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PaintBoxMorph class
	instanceVariableNames: ''!

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 8/21/2000 12:52'!
fixUpPrototype
	"PaintBoxMorph fixUpPrototype"
self error: 'who uses this?'.
	Prototype eventHandler: nil! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 8/21/2000 12:58'!
initialize
	"PaintBoxMorph initialize"

	Prototype eventHandler: nil.
	Prototype focusMorph: nil.
	Prototype stampHolder clear.  "clear stamps"
	Prototype delete.  "break link to world, if any"

	AllOnImage _ AllOffImage _ AllPressedImage _ nil.
	OriginalBounds _ nil.

! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 9/26/2000 09:28'!
initializeColorChart
	"PaintBoxMorph initializeColorChart"
	ColorChart _ (Color colorPaletteForDepth: 16 extent: 120@89)! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 9/23/2000 19:44'!
new

	| pb button dualUse formCanvas rect |
	pb _ Prototype fullCopy.
		"Assume that the PaintBox does not contain any scripted Players!!"
	pb stampHolder normalize.	"Get the stamps to show"
	"Get my own copies of the brushes so I can modify them"
	#(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel |
		button _ pb submorphNamed: sel.
		button offImage: button offImage deepCopy.
		dualUse _ button onImage == button pressedImage.	"sometimes shared"
		button onImage: button onImage deepCopy.
		dualUse
			ifTrue: [button pressedImage: button onImage]
			ifFalse: [button pressedImage: button pressedImage deepCopy].
		"force color maps for later mapping"
		button offImage.
		button onImage.
		button pressedImage.
		formCanvas _ button onImage getCanvas.
		formCanvas _ formCanvas
			copyOrigin: 0@0
			clipRect: (rect _ 0@0 extent: button onImage extent).
		(#(brush1: brush3:) includes: sel) ifTrue: [
			rect _ rect origin corner: rect corner - (2@2)].
		(#brush2: == sel) ifTrue: [
			rect _ rect origin corner: rect corner - (2@4)].
		formCanvas frameAndFillRectangle: rect fillColor: Color transparent
			borderWidth: 2 borderColor: (Color r: 0.599 g: 0.8 b: 1.0).
		].
	pb showColor.
	pb fixUpRecentColors.
	^ pb! !

!PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'tk 10/12/97 11:01'!
prototype
	"Later we will be a subclass of Model, and it will have a general version of this"
	^ Prototype! !
ImageMorph subclass: #PaintInvokingMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!PaintInvokingMorph commentStamp: '<historical>' prior: 0!
When this is dropped inside some appropriate place, then painting is invoked for that place.!


!PaintInvokingMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/16/1998 00:02'!
initialize
	super initialize.
	self image: (ScriptingSystem formAtKey: 'Painting')! !

!PaintInvokingMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/30/1999 20:31'!
isCandidateForAutomaticViewing
	^ self isPartsDonor not! !

!PaintInvokingMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/6/2000 22:50'!
justDroppedInto: aPasteUpMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"
	self delete.
	aPasteUpMorph makeNewDrawing: anEvent.! !

!PaintInvokingMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/6/2000 22:50'!
wantsToBeDroppedInto: aMorph
	"Only into PasteUps that are not part bins"
	^aMorph isPlayfieldLike and:[aMorph isPartsBin not]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PaintInvokingMorph class
	instanceVariableNames: ''!

!PaintInvokingMorph class methodsFor: 'as yet unclassified' stamp: 'sw 5/6/2000 02:28'!
authoringPrototype
	^ self new image: (ScriptingSystem formAtKey: 'Painting'); markAsPartsDonor; setBalloonText: 'drop this into any playfield or book page to make a new painting there'; yourself! !
DisplayText subclass: #Paragraph
	instanceVariableNames: 'clippingRectangle compositionRectangle destinationForm rule mask marginTabsLevel lines lastLine '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'ST80-Support'!
!Paragraph commentStamp: '<historical>' prior: 0!
I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.!


!Paragraph methodsFor: 'accessing'!
backgroundColor
	backColor == nil ifTrue: [^ Color white].
	^ backColor! !

!Paragraph methodsFor: 'accessing'!
clippingRectangle 
	"Answer the rectangle, defined in absolute coordinates, whose 
	intersection with the destinationForm is the area in which the characters 
	are constrained to display."

	^clippingRectangle! !

!Paragraph methodsFor: 'accessing' stamp: 'di 10/5/97 15:33'!
clippingRectangle: clipRect 
	clippingRectangle _ clipRect! !

!Paragraph methodsFor: 'accessing'!
compositionRectangle
	"Answer the rectangle whose width is the dimension, modified by 
	indents and tabsLevels, against which line wraparound is measured. The 
	height of the compositionRectangle is reset each time recomposition is 
	required."

	^compositionRectangle! !

!Paragraph methodsFor: 'accessing'!
compositionRectangle: compRectangle 
	"Set the rectangle whose width is the dimension, modified by indents and 
	tabsLevels, against which line wraparound is measured."

	compositionRectangle _ compRectangle.
	self composeAll! !

!Paragraph methodsFor: 'accessing'!
destinationForm 
	 "Answer the Form into which the characters are scanned."

	^destinationForm! !

!Paragraph methodsFor: 'accessing'!
fillColor 
	"Answer the Form with which each character is combined by the scanner 
	before applying the rule for display."

	^mask! !

!Paragraph methodsFor: 'accessing'!
fillColor: maskForm 
	"Set the argument, maskForm, to be the form with which each character 
	is combined by the scanner before applying the rule for display."

	mask _ maskForm! !

!Paragraph methodsFor: 'accessing'!
height 
	"Answer the height of the composition rectangle."

	^compositionRectangle height! !

!Paragraph methodsFor: 'accessing'!
indentationOfLineIndex: lineIndex ifBlank: aBlock
	"Answer the number of leading tabs in the line at lineIndex.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value.
	 If the line is word-wrap overflow, back up a line and recur."

	| arrayIndex first last reader leadingTabs lastSeparator cr tab ch |
	cr _ Character cr.
	tab _ Character tab.
	arrayIndex _ lineIndex.
	[first _ (lines at: arrayIndex) first.
	 first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap"
		[arrayIndex _ arrayIndex - 1].
	last _ (lines at: lastLine) last.
	reader _ ReadStream on: text string from: first to: last.
	leadingTabs _ 0.
	[reader atEnd not and: [(ch _ reader next) == tab]]
		whileTrue: [leadingTabs _ leadingTabs + 1].
	lastSeparator _ first - 1 + leadingTabs.
	[reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]]
		whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next].
	lastSeparator = last | (ch == cr)
		ifTrue: [^aBlock value: leadingTabs].
	^leadingTabs! !

!Paragraph methodsFor: 'accessing'!
mask 
	"Answer the Form with which each character is combined by the scanner 
	before applying the rule for display."

	^mask! !

!Paragraph methodsFor: 'accessing'!
numberOfLines 
	"Answer the number of lines of text in the receiver."

	^lastLine! !

!Paragraph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'!
replaceFrom: start to: stop with: aText displaying: displayBoolean
	"Replace the receiver's text starting at position start, stopping at stop, by 
	the characters in aText. It is expected that most requirements for 
	modifications to the receiver will call this code. Certainly all cut's or 
	paste's." 

	| compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex
	startLine stopLine replacementRange visibleRectangle startIndex newLine done
	newStop obsoleteY newY moveRectangle |

	text replaceFrom: start to: stop with: aText.		"Update the text."
	lastLine = 0 ifTrue:
		["if lines have never been set up, measure them and display
		all the lines falling in the visibleRectangle"
		self composeAll.
		displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]].

	"save -- things get pretty mashed as we go along"
	obsoleteLines _ lines copy.
	obsoleteLastLine _ lastLine.

	"find the starting and stopping lines"
	firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start.
	stopLine _ self lineIndexOfCharacterIndex: stop.

	"how many characters being inserted or deleted
		-- negative if aText size is < characterInterval size."
	replacementRange _ aText size - (stop - start + 1).
	"Give ourselves plenty of elbow room."
	compositionRectangle _ compositionRectangle withHeight: (textStyle lineGrid * 9999).
	"build a boundingBox of the actual screen space in question -- we'll need it later"
	visibleRectangle _ (clippingRectangle intersect: compositionRectangle)
							intersect: destinationForm boundingBox.
	compositionScanner _ CompositionScanner new forParagraph: self.		"Initialize a scanner."

	"If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears.  For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line."
	startIndex _ (lines at: firstLineIndex) first.
	startLine > 1
		ifTrue: 	[newLine _ compositionScanner composeLine: startLine - 1
						fromCharacterIndex: (lines at: startLine - 1) first
						inParagraph: self.
				(lines at: startLine - 1) = newLine
					ifFalse:	["start in line preceding the one with the starting character"
							startLine _ startLine - 1.
							self lineAt: startLine put: newLine.
							startIndex _ newLine last + 1]].
	startIndex > text size ifTrue:
		["nil lines after a deletion -- remeasure last line below"
		self trimLinesTo: (firstLineIndex - 1 max: 0).
		text size = 0 ifTrue:
			["entire text deleted -- clear visibleRectangle and return."
			displayBoolean ifTrue: [destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor].
			self updateCompositionHeight.
			^self]].

	"Now we really get to it."
	done _ false.
	lastLineIndex _ stopLine.
	[done or: [startIndex > text size]]
		whileFalse: 
		[self lineAt: firstLineIndex put:
			(newLine _ compositionScanner composeLine: firstLineIndex
							fromCharacterIndex: startIndex inParagraph: self).
		[(lastLineIndex > obsoleteLastLine
			or: ["no more old lines to compare with?"
				newLine last <
					(newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)])
			  	or: [done]]
			whileFalse: 
			[newStop = newLine last
				ifTrue:	["got the match"
						"get source and dest y's for moving the unchanged lines"
						obsoleteY _ self topAtLineIndex: lastLineIndex + 1
									using: obsoleteLines and: obsoleteLastLine.
						newY _ self topAtLineIndex: firstLineIndex + 1.
						stopLine _ firstLineIndex.
						done _ true.
							"Fill in the new line vector with the old unchanged lines.
							Update their starting and stopping indices on the way."
						((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do:
							[:upDatedIndex | 
							self lineAt: (firstLineIndex _ firstLineIndex + 1) 
								put: ((obsoleteLines at: upDatedIndex)
							  		slide: replacementRange)].
							"trim off obsolete lines, if any"
						self trimLinesTo: firstLineIndex]
				ifFalse:	[lastLineIndex _ lastLineIndex + 1]].
		startIndex _ newLine last + 1.
		firstLineIndex _ firstLineIndex + 1].

	"Now the lines are up to date -- Whew!!.  What remains is to move
	the 'unchanged' lines and display those which have changed."
	displayBoolean   "Not much to do if not displaying"
		ifFalse: [^ self updateCompositionHeight].
	startIndex > text size ifTrue:
		["If at the end of previous lines simply display lines from the line in
		which the first character of the replacement occured through the
		end of the paragraph."
		self updateCompositionHeight.
		self displayLines:
			(startLine to: (stopLine _ firstLineIndex min: lastLine)).
		destinationForm  "Clear out area at the bottom"
			fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1)
						extent: visibleRectangle extent)
					intersect: visibleRectangle)
			rule: rule fillColor: self backgroundColor]
		ifFalse:
		[newY ~= obsoleteY ifTrue:
			["Otherwise first move the unchanged lines within
			the visibleRectangle with a good old bitblt."
			moveRectangle _
				visibleRectangle left @ (obsoleteY max: visibleRectangle top)
					corner: visibleRectangle corner.
			destinationForm copyBits: moveRectangle from: destinationForm
				at: moveRectangle origin + (0 @ (newY-obsoleteY))
				clippingBox: visibleRectangle
				rule: Form over fillColor: nil].

		"Then display the altered lines."
		self displayLines: (startLine to: stopLine).

		newY < obsoleteY
			ifTrue:
			[(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom
				ifTrue:
				["A deletion may have 'pulled' previously undisplayed lines
				into the visibleRectangle.  If so, display them."
				self displayLines:
					((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY))
						to: (self lineIndexOfTop: visibleRectangle bottom))].
			"Clear out obsolete material at the bottom of the visibleRectangle."
			destinationForm
				fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1)
						extent: visibleRectangle extent)
					intersect: visibleRectangle)  "How about just corner: ??"
				rule: rule fillColor: self backgroundColor].

		(newY > obsoleteY and: [obsoleteY < visibleRectangle top])
			ifTrue:
				["An insertion may have 'pushed' previously undisplayed lines
				into the visibleRectangle.  If so, display them."
				self displayLines:
					((self lineIndexOfTop: visibleRectangle top)
						to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))].

		self updateCompositionHeight]! !

!Paragraph methodsFor: 'accessing'!
rule 
	"Answer the rule according to which character display behaves. For 
	example, rule may equal over, under, reverse."

	^rule! !

!Paragraph methodsFor: 'accessing'!
rule: ruleInteger 
	"Set the rule according to which character display behaves."

	rule _ ruleInteger! !

!Paragraph methodsFor: 'accessing' stamp: 'sw 10/29/1999 18:11'!
stringAtLineNumber: aNumber
	(aNumber > lastLine or: [aNumber < 1]) ifTrue: [^ nil].
	^ (text string copyFrom: (lines at: aNumber) first to: (lines at: aNumber) last) copyWithout: Character cr! !

!Paragraph methodsFor: 'accessing'!
text: aText 
	"Set the argument, aText, to be the text for the receiver."

	text _ aText.
	self composeAll! !


!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium
	"Because Paragraphs cache so much information, computation is avoided
	and displayAt: 0@0 is not appropriate here."

	self displayOn: aDisplayMedium
		at: compositionRectangle topLeft
		clippingBox: clippingRectangle
		rule: rule
		fillColor: mask! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint
	"Use internal clippingRect; destination cliping is done during actual display."

	self displayOn: aDisplayMedium at: aPoint
		clippingBox: (clippingRectangle translateBy: aPoint - compositionRectangle topLeft)
		rule: rule fillColor: mask! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"Default display message when aDisplayPoint is in absolute screen
	coordinates."

	rule _ ruleInteger.
	mask _ aForm.
	clippingRectangle _ clipRectangle.
	compositionRectangle _ aDisplayPoint extent: compositionRectangle extent.
	(lastLine == nil or: [lastLine < 1]) ifTrue: [self composeAll].
	self displayOn: aDisplayMedium lines: (1 to: lastLine)! !

!Paragraph methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 

	self				"Assumes offset has been set!!!!!!!!!!"
	  displayOn: aDisplayMedium
	  at: (offset 
			+ (displayTransformation applyTo: relativePoint) 
			- alignmentPoint) rounded
	  clippingBox: clipRectangle
	  rule: ruleInteger
	  fillColor: aForm.
	! !


!Paragraph methodsFor: 'display box access'!
boundingBox

	^offset extent: compositionRectangle extent! !

!Paragraph methodsFor: 'display box access'!
computeBoundingBox

	^offset extent: compositionRectangle extent! !


!Paragraph methodsFor: 'composition' stamp: 'ar 5/18/2000 18:34'!
composeAll
	"Compose a collection of characters into a collection of lines."

	| startIndex stopIndex lineIndex maximumRightX compositionScanner |
	lines _ Array new: 32.
	lastLine _ 0.
	maximumRightX _ 0.
	text size = 0
		ifTrue:
			[compositionRectangle _ compositionRectangle withHeight: 0.
			^maximumRightX].
	startIndex _ lineIndex _ 1.
	stopIndex _ text size.
	compositionScanner _ CompositionScanner new forParagraph: self.
	[startIndex > stopIndex] whileFalse: 
		[self lineAt: lineIndex 
				put: (compositionScanner composeLine: lineIndex 
										fromCharacterIndex: startIndex 
										inParagraph: self).
		 maximumRightX _ compositionScanner rightX max: maximumRightX.
		 startIndex _ (lines at: lineIndex) last + 1.
		 lineIndex _ lineIndex + 1].
	self updateCompositionHeight.
	self trimLinesTo: lineIndex - 1.
	^ maximumRightX! !

!Paragraph methodsFor: 'composition'!
wrappingBox: compositionRect clippingBox: clippingRect 
	"Set the composition rectangle for the receiver so that the lines wrap 
	within the rectangle, compositionRect, and the display of the text is 
	clipped by the rectangle, clippingRect."

	self compositionRectangle: compositionRect copy
				text: text
				style: textStyle
				offset: offset.
	clippingRectangle _ clippingRect copy! !


!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for characters in the text at point aPoint. It is 
	assumed that aPoint has been transformed into coordinates appropriate to 
	the receiver's destinationForm rectangle and the compositionRectangle."

	^CharacterBlockScanner new characterBlockAtPoint: aPoint in: self! !

!Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'!
characterBlockForIndex: targetIndex 
	"Answer a CharacterBlock for character in the text at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destinationForm rectangle and the compositionRectangle."

	^CharacterBlockScanner new characterBlockForIndex: targetIndex in: self! !

!Paragraph methodsFor: 'character location' stamp: 'di 10/5/1998 12:59'!
defaultCharacterBlock
	^ CharacterBlock new stringIndex: 1 text: text
			topLeft: compositionRectangle topLeft extent: 0 @ 0! !


!Paragraph methodsFor: 'selecting' stamp: 'ar 5/28/2000 12:10'!
caretFormForDepth: depth
	"Return a caret form for the given depth."
	"(Paragraph new caretFormForDepth: Display depth) displayOn: Display at: 0@0 rule: Form reverse"

	| box f bb map |
	box _ CaretForm boundingBox.
	f _ Form extent: box extent depth: depth.
	map _ (Color cachedColormapFrom: CaretForm depth to: depth) copy.
	map at: 1 put: (Color transparent pixelValueForDepth: depth).
	map at: 2 put: (Color quickHighLight: depth) first.  "pixel value for reversing"
	bb _ BitBlt current toForm: f.
	bb
		sourceForm: CaretForm;
		sourceRect: box;
		destOrigin: 0@0;
		colorMap: map;
 		combinationRule: Form over;
		copyBits.
	^ f! !

!Paragraph methodsFor: 'selecting' stamp: 'sw 12/7/1999 12:26'!
clickAt: clickPoint for: model controller: aController
	"Give sensitive text a chance to fire.  Display flash: (100@100 extent: 100@100)."
	| startBlock action range box boxes |
	action _ false.
	startBlock _ self characterBlockAtPoint: clickPoint.
	(text attributesAt: startBlock stringIndex forStyle: textStyle) 
		do: [:att | att mayActOnClick ifTrue:
				[range _ text rangeOf: att startingAt: startBlock stringIndex forStyle: textStyle.
				boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) 
							to: (self characterBlockForIndex: range last).
				box _ boxes detect: [:each | each containsPoint: clickPoint]
							ifNone: [^ action].
				Utilities awaitMouseUpIn: box repeating: []
					ifSucceed: [aController terminateAndInitializeAround:
								[(att actOnClickFor: model) ifTrue: [action _ true]]]]].
	^ action! !

!Paragraph methodsFor: 'selecting'!
extendSelectionAt: beginBlock endBlock: endBlock 
	"Answer with an Array of two CharacterBlocks that represent the text 
	selection that the user makes."
	
	(self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock
		ifTrue: [^self mouseMovedFrom: beginBlock 
					pivotBlock: endBlock
					showingCaret: (beginBlock = endBlock)]
		ifFalse: [^self mouseMovedFrom: endBlock 
					pivotBlock: beginBlock
					showingCaret: (beginBlock = endBlock)]
! !

!Paragraph methodsFor: 'selecting' stamp: 'jm 7/1/1999 12:31'!
hiliteRect: rect

	| highlightColor |
	highlightColor _ Color quickHighLight: destinationForm depth.
	rect ifNotNil: [
		destinationForm
			fill: rect
			rule: Form reverse
			fillColor: highlightColor.
		"destinationForm
			fill: (rect translateBy: 1@1)
			rule: Form reverse
			fillColor: highlightColor" ].
! !

!Paragraph methodsFor: 'selecting' stamp: 'jm 7/8/97 12:25'!
mouseMovedFrom: beginBlock pivotBlock: pivotBlock showingCaret: caretOn 
	| startBlock stopBlock showingCaret |
	stopBlock _ startBlock _ beginBlock.
	showingCaret _ caretOn.
	[Sensor redButtonPressed]
		whileTrue: 
			[stopBlock _ self characterBlockAtPoint: Sensor cursorPoint.
			stopBlock = startBlock
				ifFalse: 
					[showingCaret
						ifTrue: 
							[showingCaret _ false.
							self reverseFrom: pivotBlock to: pivotBlock].
			((startBlock >= pivotBlock and: [stopBlock >= pivotBlock])
				or: [startBlock <= pivotBlock and: [stopBlock <= pivotBlock]])
				ifTrue: 
					[self reverseFrom: startBlock to: stopBlock.
					startBlock _ stopBlock]
				ifFalse: 
					[self reverseFrom: startBlock to: pivotBlock.
					self reverseFrom: pivotBlock to: stopBlock.
					startBlock _ stopBlock].
			(clippingRectangle containsRect: stopBlock) ifFalse:
				[stopBlock top < clippingRectangle top
				ifTrue: [self scrollBy: stopBlock top - clippingRectangle top
						withSelectionFrom: pivotBlock to: stopBlock]
				ifFalse: [self scrollBy: stopBlock bottom + textStyle lineGrid - clippingRectangle bottom
						withSelectionFrom: pivotBlock to: stopBlock]]]].
	pivotBlock = stopBlock ifTrue:
		[showingCaret ifFalse:  "restore caret"
			[self reverseFrom: pivotBlock to: pivotBlock]].
	^ Array with: pivotBlock with: stopBlock! !

!Paragraph methodsFor: 'selecting'!
mouseSelect
	"Answer with an Array of two CharacterBlocks that represent the text 
	selection that the user makes.  Return quickly if the button is noticed up
	to make double-click more responsive."

	| pivotBlock startBlock stopBlock origPoint stillDown |
	stillDown _ Sensor redButtonPressed.
	pivotBlock _ startBlock _ stopBlock _
		self characterBlockAtPoint: (origPoint _ Sensor cursorPoint).
	stillDown _ stillDown and: [Sensor redButtonPressed].
	self reverseFrom: startBlock to: startBlock.
	[stillDown and: [Sensor cursorPoint = origPoint]] whileTrue:
		[stillDown _ Sensor redButtonPressed].
	(stillDown and: [clippingRectangle containsPoint: Sensor cursorPoint])
		ifFalse: [^Array with: pivotBlock with: stopBlock].
	^ self mouseMovedFrom: startBlock 
		pivotBlock: pivotBlock
		showingCaret: true! !

!Paragraph methodsFor: 'selecting'!
mouseSelect: clickPoint 
	"Track text selection and answer with an Array of two CharacterBlocks."
	| startBlock |
	startBlock _ self characterBlockAtPoint: clickPoint.
	self reverseFrom: startBlock to: startBlock.
	^ self mouseMovedFrom: startBlock 
		pivotBlock: startBlock
		showingCaret: true! !

!Paragraph methodsFor: 'selecting'!
reverseFrom: characterBlock1 to: characterBlock2 
	"Reverse area between the two character blocks given as arguments."
	| visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline caret |
	characterBlock1 = characterBlock2 ifTrue:
		[lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.
		baseline _ lineNo = 0 ifTrue: [textStyle baseline]
							ifFalse: [(lines at: lineNo) baseline].
		caret _ self caretFormForDepth: Display depth.
		^ caret  "Use a caret to indicate null selection"
				displayOn: destinationForm
				at: characterBlock1 topLeft + (-3 @ baseline)
				clippingBox: clippingRectangle
				rule: (false "Display depth>8" ifTrue: [9 "not-reverse"]
									ifFalse: [Form reverse])
				fillColor: nil].
	visibleRectangle _ 
		(clippingRectangle intersect: compositionRectangle)
			"intersect: destinationForm boundingBox" "not necessary".
	characterBlock1 top = characterBlock2 top
		ifTrue: [characterBlock1 left < characterBlock2 left
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft corner: characterBlock2 bottomLeft)
								intersect: visibleRectangle]
					ifFalse: 
						[initialRectangle _ 
							(characterBlock2 topLeft corner: characterBlock1 bottomLeft)
								intersect: visibleRectangle]]
		ifFalse: [characterBlock1 top < characterBlock2 top
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft 
								corner: visibleRectangle right @ characterBlock1 bottom)
								intersect: visibleRectangle.
						characterBlock1 bottom = characterBlock2 top
							ifTrue: 
								[finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]
							ifFalse: 
								[interiorRectangle _ 
									(visibleRectangle left @ characterBlock1 bottom
										corner: visibleRectangle right 
														@ characterBlock2 top)
										intersect: visibleRectangle.
								finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]]
				ifFalse: 
					[initialRectangle _ 
						(visibleRectangle left @ characterBlock1 top 
							corner: characterBlock1 bottomLeft)
							intersect: visibleRectangle.
					characterBlock1 top = characterBlock2 bottom
						ifTrue: 
							[finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]
						ifFalse: 
							[interiorRectangle _ 
								(visibleRectangle left @ characterBlock2 bottom 
									corner: visibleRectangle right @ characterBlock1 top)
									intersect: visibleRectangle.
							finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]]].
	self hiliteRect: initialRectangle.
	self hiliteRect: interiorRectangle.
	self hiliteRect: finalRectangle.! !

!Paragraph methodsFor: 'selecting' stamp: 'di 12/1/97 04:43'!
selectionRectsFrom: characterBlock1 to: characterBlock2 
	"Return an array of rectangles representing the area between the two character blocks given as arguments."
	| visibleRectangle initialRectangle interiorRectangle finalRectangle lineNo baseline |
	characterBlock1 = characterBlock2 ifTrue:
		[lineNo _ self lineIndexOfCharacterIndex: characterBlock1 stringIndex.
		baseline _ lineNo = 0 ifTrue: [textStyle baseline]
							ifFalse: [(lines at: lineNo) baseline].
		^ Array with: (characterBlock1 topLeft extent: 1 @ baseline)].
	visibleRectangle _ clippingRectangle intersect: compositionRectangle.
	characterBlock1 top = characterBlock2 top
		ifTrue: [characterBlock1 left < characterBlock2 left
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft corner: characterBlock2 bottomLeft)
								intersect: visibleRectangle]
					ifFalse: 
						[initialRectangle _ 
							(characterBlock2 topLeft corner: characterBlock1 bottomLeft)
								intersect: visibleRectangle]]
		ifFalse: [characterBlock1 top < characterBlock2 top
					ifTrue: 
						[initialRectangle _ 
							(characterBlock1 topLeft 
								corner: visibleRectangle right @ characterBlock1 bottom)
								intersect: visibleRectangle.
						characterBlock1 bottom = characterBlock2 top
							ifTrue: 
								[finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]
							ifFalse: 
								[interiorRectangle _ 
									(visibleRectangle left @ characterBlock1 bottom
										corner: visibleRectangle right 
														@ characterBlock2 top)
										intersect: visibleRectangle.
								finalRectangle _ 
									(visibleRectangle left @ characterBlock2 top 
										corner: characterBlock2 bottomLeft)
										intersect: visibleRectangle]]
				ifFalse: 
					[initialRectangle _ 
						(visibleRectangle left @ characterBlock1 top 
							corner: characterBlock1 bottomLeft)
							intersect: visibleRectangle.
					characterBlock1 top = characterBlock2 bottom
						ifTrue: 
							[finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]
						ifFalse: 
							[interiorRectangle _ 
								(visibleRectangle left @ characterBlock2 bottom 
									corner: visibleRectangle right @ characterBlock1 top)
									intersect: visibleRectangle.
							finalRectangle _ 
								(characterBlock2 topLeft 
									corner: visibleRectangle right 
												@ characterBlock2 bottom)
									intersect: visibleRectangle]]].
	^ (Array with: initialRectangle with: interiorRectangle with: finalRectangle)
			select: [:rect | rect notNil]! !


!Paragraph methodsFor: 'scrolling'!
scrollBy: heightToMove 
	^ self scrollBy: heightToMove withSelectionFrom: nil to: nil! !

!Paragraph methodsFor: 'scrolling'!
scrollBy: heightToMove withSelectionFrom: startBlock to: stopBlock 
	"Translate the composition rectangle up (dy<0) by heightToMove.
	Repainting text as necessary, and selection if blocks not nil.
	Return true unless scrolling limits have been reached."
	| max min amount |
	max _ 0 max: "cant scroll up more than dist to (top of) bottom line"
		compositionRectangle bottom - textStyle lineGrid - clippingRectangle top.
	min _ 0 min: "cant scroll down more than top is above clipRect"
		compositionRectangle top - clippingRectangle top.
	amount _ ((heightToMove truncateTo: textStyle lineGrid) min: max) max: min.
	amount ~= 0
		ifTrue: [self scrollUncheckedBy: amount
					withSelectionFrom: startBlock to: stopBlock.
				^ true]
		ifFalse: [^ false]! !

!Paragraph methodsFor: 'scrolling'!
scrollDelta
	"By comparing this before and after, you know if scrolling happened"
	^ clippingRectangle top - compositionRectangle top! !

!Paragraph methodsFor: 'scrolling'!
scrollUncheckedBy: heightToMove withSelectionFrom: startBlock to: stopBlock 
	"Scroll by the given amount.  Copy bits where possible, display the rest.
	If selection blocks are not nil, then select the newly visible text as well."
	| savedClippingRectangle delta |
	delta _ 0 @ (0 - heightToMove).
	compositionRectangle _ compositionRectangle translateBy: delta.
	startBlock == nil ifFalse:
		[startBlock moveBy: delta.
		stopBlock moveBy: delta].
	savedClippingRectangle _ clippingRectangle.
	clippingRectangle _ clippingRectangle intersect: Display boundingBox.
	heightToMove abs >= clippingRectangle height
	  ifTrue: 
		["Entire visible region must be repainted"
		self displayLines: (1 to: lastLine) affectedRectangle: clippingRectangle]
	  ifFalse:
		["Copy bits where possible / display the rest"
		destinationForm
			copyBits: clippingRectangle from: destinationForm
			at: clippingRectangle topLeft + delta
			clippingBox: clippingRectangle
			rule: Form over fillColor: nil.
		"Set clippingRectangle to 'vacated' area for lines 'pulled' into view."
		clippingRectangle _ heightToMove < 0
			ifTrue:  "On the top"
				[clippingRectangle topLeft corner: clippingRectangle topRight + delta]
			ifFalse:  "At the bottom"
				[clippingRectangle bottomLeft + delta corner: clippingRectangle bottomRight].
		self displayLines: (1 to: lastLine)   "Refresh vacated region"
			affectedRectangle: clippingRectangle].
	startBlock == nil ifFalse:
		[self reverseFrom: startBlock to: stopBlock].
	"And restore the clippingRectangle to its original value. "
	clippingRectangle _ savedClippingRectangle! !


!Paragraph methodsFor: 'alignment'!
centered 
	"Set the alignment for the style with which the receiver displays its text 
	so that text is centered in the composition rectangle."

	textStyle alignment: Centered! !

!Paragraph methodsFor: 'alignment'!
justified 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text end on an even border in the 
	composition rectangle."

	textStyle alignment: Justified! !

!Paragraph methodsFor: 'alignment'!
leftFlush 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text begin on an even border in the 
	composition rectangle. This is also known as ragged-right."

	textStyle alignment: LeftFlush! !

!Paragraph methodsFor: 'alignment'!
rightFlush 
	"Set the alignment for the style with which the receiver displays its text 
	so that the characters in each of text end on an even border in the 
	composition rectangle but the beginning of each line does not. This is 
	also known as ragged-left."

	textStyle alignment: RightFlush! !

!Paragraph methodsFor: 'alignment'!
toggleAlignment 
	"Set the alignment for the style with which the receiver displays its text 
	so that it moves from centered to justified to leftFlush to rightFlush and 
	back to centered again."

	textStyle alignment: textStyle alignment + 1! !


!Paragraph methodsFor: 'indicating'!
flash 
	"Complement twice the visible area in which the receiver displays."

	Display flash: clippingRectangle! !

!Paragraph methodsFor: 'indicating'!
outline 
	"Display a border around the visible area in which the receiver presents 
	its text."

	clippingRectangle bottom <= compositionRectangle bottom
	  ifTrue: [Display 
				border: (clippingRectangle intersect: compositionRectangle) 
				width: 2]
	  ifFalse: [Display 
				border: (clippingRectangle intersect: destinationForm boundingBox)
				width: 2].
	! !


!Paragraph methodsFor: 'utilities'!
clearVisibleRectangle 
	"Display the area in which the receiver presents its text so that the area 
	is all one tone--in this case, all white."

	destinationForm
	  fill: clippingRectangle
	  rule: rule
	  fillColor: self backgroundColor! !

!Paragraph methodsFor: 'utilities'!
deepCopy
	"Don't want to copy the destForm (Display) or fonts in the TextStyle.  9/13/96 tk"

	| new |
	new _ self copy.
	new textStyle: textStyle copy.
	new destinationForm: destinationForm.
	new lines: lines copy.
	new text: text deepCopy.
	^ new! !

!Paragraph methodsFor: 'utilities'!
destinationForm: destForm
	destinationForm _ destForm! !

!Paragraph methodsFor: 'utilities'!
fit
	"Make the bounding rectangle of the receiver contain all the text without 
	changing the width of the receiver's composition rectangle."

	[(self lineIndexOfTop: clippingRectangle top) = 1]
		whileFalse: [self scrollBy: (0-1)*textStyle lineGrid].
	self updateCompositionHeight.
	clippingRectangle _ clippingRectangle withBottom: compositionRectangle bottom! !

!Paragraph methodsFor: 'utilities'!
lines: lineArray
	lines _ lineArray! !

!Paragraph methodsFor: 'utilities'!
visibleRectangle 
	"May be less than the clippingRectangle if text ends part way down.
	Also some fearful history includes Display intersection;
	it shouldn't be necessary"

	^ (clippingRectangle intersect: compositionRectangle)
		intersect: destinationForm boundingBox! !


!Paragraph methodsFor: 'converting'!
asForm
	"Answer a Form made up of the bits that represent the receiver's displayable text."
	| theForm oldBackColor oldForeColor |
	theForm _ (ColorForm extent: compositionRectangle extent)
		offset: offset;
		colors: (Array
			with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor])
			with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])).

	oldBackColor _ backColor.
	oldForeColor _ foreColor.
	backColor _ Color white.
	foreColor _ Color black.
	self displayOn: theForm
		at: 0@0
		clippingBox: theForm boundingBox
		rule: Form over
		fillColor: nil.
	backColor _ oldBackColor.
	foreColor _ oldForeColor.
	^ theForm

"Example:
| p |
p _ 'Abc' asParagraph.
p foregroundColor: Color red backgroundColor: Color black.
p asForm displayOn: Display at: 30@30 rule: Form over"
! !

!Paragraph methodsFor: 'converting'!
asString
	"Answer the string of characters of the receiver's text."

	^text string! !

!Paragraph methodsFor: 'converting'!
asText
	"Answer the receiver's text."

	^text! !


!Paragraph methodsFor: 'private'!
bottomAtLineIndex: lineIndex 
	"Answer the bottom y of given line."
	| y |
	y _ compositionRectangle top.
	lastLine = 0 ifTrue: [^ y + textStyle lineGrid].
	1 to: (lineIndex min: lastLine) do:
		[:i | y _ y + (lines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private' stamp: 'tk 9/30/96'!
compositionRectangle: compositionRect text: aText style: aTextStyle offset: aPoint

	compositionRectangle _ compositionRect copy.
	text _ aText.
	textStyle _ aTextStyle.
	rule _ DefaultRule.
	mask _ nil.		"was DefaultMask "
	marginTabsLevel _ 0.
	destinationForm _ Display.
	offset _ aPoint.
	^self composeAll! !

!Paragraph methodsFor: 'private'!
compositionRectangleDelta
	"A handy number -- mostly for scrolling."

	^compositionRectangle top - clippingRectangle top! !

!Paragraph methodsFor: 'private'!
displayLines: linesInterval 
	^ self displayLines: linesInterval
		affectedRectangle: self visibleRectangle! !

!Paragraph methodsFor: 'private' stamp: 'ar 5/18/2000 18:34'!
displayLines: linesInterval affectedRectangle: affectedRectangle
	"This is the first level workhorse in the display portion of the TextForm routines.
	It checks to see which lines in the interval are actually visible, has the
	CharacterScanner display only those, clears out the areas in which display will
	occur, and clears any space remaining in the visibleRectangle following the space
	occupied by lastLine."

	| lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom |

	"Save some time by only displaying visible lines"
	firstLineIndex _ self lineIndexOfTop: affectedRectangle top.
	firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first].
	lastLineIndex _ self lineIndexOfTop: affectedRectangle bottom - 1.
	lastLineIndex > linesInterval last ifTrue:
			[linesInterval last > lastLine
		 		ifTrue: [lastLineIndex _ lastLine]
		  		ifFalse: [lastLineIndex _ linesInterval last]].
	lastLineIndexBottom _ (self bottomAtLineIndex: lastLineIndex).
	((Rectangle 
		origin: affectedRectangle left @ (topY _ self topAtLineIndex: firstLineIndex) 
		corner: affectedRectangle right @ lastLineIndexBottom)
	  intersects: affectedRectangle)
		ifTrue: [ " . . . (skip to clear-below if no lines displayed)"
				DisplayScanner new
					displayLines: (firstLineIndex to: lastLineIndex)
					in: self clippedBy: affectedRectangle].
	lastLineIndex = lastLine ifTrue: 
		 [destinationForm  "Clear out white space below last line"
		 	fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top)
				corner: affectedRectangle bottomRight)
		 	rule: rule fillColor: self backgroundColor]! !

!Paragraph methodsFor: 'private'!
displayOn: aDisplayMedium lines: lineInterval

	| saveDestinationForm |
	saveDestinationForm _ destinationForm.
	destinationForm _ aDisplayMedium.
	self displayLines: lineInterval.
	destinationForm _ saveDestinationForm! !

!Paragraph methodsFor: 'private'!
leftMarginForCompositionForLine: lineIndex 
	"Build the left margin for composition of a line. Depends upon
	marginTabsLevel and the indent."

	| indent |
	lineIndex = 1
		ifTrue: [indent _ textStyle firstIndent]
		ifFalse: [indent _ textStyle restIndent].
	^indent + (textStyle leftMarginTabAt: marginTabsLevel)! !

!Paragraph methodsFor: 'private'!
leftMarginForDisplayForLine: lineIndex 
	"Build the left margin for display of a line. Depends upon
	leftMarginForComposition, compositionRectangle left and the alignment."

	| pad |
	(textStyle alignment = LeftFlush or: [textStyle alignment = Justified])
		ifTrue: 
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex)].
	"When called from character location code and entire string has been cut,
	there are no valid lines, hence following nil check."
	(lineIndex <= lines size and: [(lines at: lineIndex) notNil])
		ifTrue: 
			[pad _ (lines at: lineIndex) paddingWidth]
		ifFalse: 
			[pad _ 
				compositionRectangle width - textStyle firstIndent - textStyle rightIndent].
	textStyle alignment = Centered 
		ifTrue: 
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex) + (pad // 2)].
	textStyle alignment = RightFlush 
		ifTrue:
			[^compositionRectangle left 
				+ (self leftMarginForCompositionForLine: lineIndex) + pad].
	self error: ['no such alignment']! !

!Paragraph methodsFor: 'private'!
lineAt: indexInteger put: aTextLineInterval 
	"Store a line, track last, and grow lines if necessary."
	indexInteger > lastLine ifTrue: [lastLine _ indexInteger].
	lastLine > lines size ifTrue: [lines _ lines , (Array new: lines size)].
	^lines at: indexInteger put: aTextLineInterval! !

!Paragraph methodsFor: 'private'!
lineIndexOfCharacterIndex: characterIndex 
	"Answer the line index for a given characterIndex."

	1 to: lastLine do: 
		[:lineIndex | 
		(lines at: lineIndex) last >= characterIndex ifTrue: [^lineIndex]].
	^lastLine! !

!Paragraph methodsFor: 'private'!
lineIndexOfTop: top 
	"Answer the line index at a given top y."
	| y line |
	lastLine = 0 ifTrue: [^ 1].
	y _ compositionRectangle top.
	1 to: lastLine do:
		[:i | line _ lines at: i.
		(y _ y + line lineHeight) > top ifTrue: [^ i]].
	^ lastLine
! !

!Paragraph methodsFor: 'private'!
lines

	^lines! !

!Paragraph methodsFor: 'private'!
moveBy: delta
	compositionRectangle _ compositionRectangle translateBy: delta.
	clippingRectangle _ clippingRectangle translateBy: delta.
! !

!Paragraph methodsFor: 'private'!
rightMarginForComposition
	"Build the right margin for a line. Depends upon compositionRectangle
	width, marginTabsLevel, and right indent."

	^compositionRectangle width 
		- (textStyle rightMarginTabAt: marginTabsLevel) 
		- textStyle rightIndent! !

!Paragraph methodsFor: 'private'!
rightMarginForDisplay 
	"Build the right margin for a line. Depends upon compositionRectangle
	rightSide, marginTabsLevel, and right indent."

	^compositionRectangle right - 
		textStyle rightIndent - (textStyle rightMarginTabAt: marginTabsLevel)! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle 
	"Set text and adjust bounding rectangles to fit."

	| shrink compositionWidth unbounded |
	unbounded _ Rectangle origin: 0 @ 0 extent: 9999@9999.
	compositionWidth _ self
		setWithText: aText style: aTextStyle compositionRectangle: unbounded clippingRectangle: unbounded.
	compositionRectangle _ compositionRectangle withWidth: compositionWidth.
	clippingRectangle _ compositionRectangle copy.
	shrink _ unbounded width - compositionWidth.
	"Shrink padding widths accordingly"
	1 to: lastLine do:
		[:i | (lines at: i) paddingWidth: (lines at: i) paddingWidth - shrink]! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect 
	"Set text and using supplied parameters. Answer max composition width."

	clippingRectangle _ clipRect copy.
	^self
		compositionRectangle: compRect
		text: aText
		style: aTextStyle
		offset: 0 @ 0! !

!Paragraph methodsFor: 'private'!
setWithText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: cf backColor: cb
	"Set text and using supplied parameters. Answer max composition width."

	clippingRectangle _ clipRect copy.
	self foregroundColor: cf backgroundColor: cb.
	^ self
		compositionRectangle: compRect
		text: aText
		style: aTextStyle
		offset: 0 @ 0! !

!Paragraph methodsFor: 'private'!
topAtLineIndex: lineIndex 
	"Answer the top y of given line."
	| y |
	y _ compositionRectangle top.
	lastLine = 0 ifTrue: [lineIndex > 0 ifTrue: [^ y + textStyle lineGrid]. ^ y].
	1 to: (lineIndex-1 min: lastLine) do:
		[:i | y _ y + (lines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private'!
topAtLineIndex: lineIndex using: otherLines and: otherLastLine
	"Answer the top y of given line."
	| y |
	y _ compositionRectangle top.
	otherLastLine = 0 ifTrue: [^ y].
	1 to: (lineIndex-1 min: otherLastLine) do:
		[:i | y _ y + (otherLines at: i) lineHeight].
	^ y
! !

!Paragraph methodsFor: 'private'!
trimLinesTo: lastLineInteger

	(lastLineInteger + 1 to: lastLine) do: [:i | lines at: i put: nil].
	(lastLine _ lastLineInteger) < (lines size // 2) 
		ifTrue: [lines _ lines copyFrom: 1 to: lines size - (lines size // 2)]! !

!Paragraph methodsFor: 'private'!
updateCompositionHeight
	"Mainly used to insure that intersections with compositionRectangle work." 

	compositionRectangle _ compositionRectangle withHeight:
		(self bottomAtLineIndex: lastLine) - compositionRectangle top.
	(text size ~= 0 and: [(text at: text size) = CR])
		ifTrue: [compositionRectangle _ compositionRectangle withHeight:
					compositionRectangle height + (lines at: lastLine) lineHeight]! !

!Paragraph methodsFor: 'private' stamp: 'di 8/30/97 11:14'!
withClippingRectangle: clipRect do: aBlock
	| saveClip |
	saveClip _ clippingRectangle.
	clippingRectangle _ clipRect.
		aBlock value.
	clippingRectangle _ saveClip! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Paragraph class
	instanceVariableNames: ''!

!Paragraph class methodsFor: 'instance creation'!
new
	"Do not allow an uninitialized view. Create with text that has no
	characters."

	^self withText: '' asText! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText 
	"Answer an instance of me with text set to aText and style set to the 
	system's default text style."

	^self withText: aText style: DefaultTextStyle copy! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText style: aTextStyle 
	"Answer an instance of me with text set to aText and style set to 
	aTextStyle."

	^super new setWithText: aText style: aTextStyle! !

!Paragraph class methodsFor: 'instance creation'!
withText: aText style: aTextStyle compositionRectangle: compRect clippingRectangle: clipRect foreColor: c1 backColor: c2
	"Answer an instance of me with text set to aText and style set to 
	aTextStyle, composition rectangle is compRect and the clipping rectangle 
	is clipRect."
	| para |
	para _ super new.
	para setWithText: aText
		style: aTextStyle
		compositionRectangle: compRect
		clippingRectangle: clipRect
		foreColor: c1 backColor: c2.
	^para! !


!Paragraph class methodsFor: 'examples' stamp: 'tk 9/30/96'!
example
	"This simple example illustrates how to display a few lines of text on the screen at the current cursor point.  
	Fixed. "

	| para point |
	point _ Sensor waitButton.
	para _ 'This is the first line of characters
and this is the second line.' asParagraph.
	para displayOn: Display at: point.

	"Paragraph example"! !
ScrollController subclass: #ParagraphEditor
	instanceVariableNames: 'paragraph startBlock stopBlock beginTypeInBlock emphasisHere initialText selectionShowing otherInterval '
	classVariableNames: 'ChangeText CmdActions FindText Keyboard ShiftCmdActions TextEditorYellowButtonMenu UndoInterval UndoMessage UndoParagraph UndoSelection Undone '
	poolDictionaries: 'TextConstants '
	category: 'Kernel-ST80 Remnants'!
!ParagraphEditor commentStamp: '<historical>' prior: 0!
I am a Controller for editing a Paragraph. I am a kind of ScrollController, so that more text can be created for the Paragraph than can be viewed on the screen. Editing messages are sent by issuing commands from a yellow button menu or from keys on the keyboard. My instances keep control as long as the cursor is within the view when the red or yellow mouse button is pressed; they give up control if the blue button is pressed.!


!ParagraphEditor methodsFor: 'initialize-release'!
changeParagraph: aParagraph 
	"Install aParagraph as the one to be edited by the receiver."

	UndoParagraph == paragraph ifTrue: [UndoParagraph _ nil].
	paragraph _ aParagraph.
	self resetState! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 11/30/97 10:13'!
resetState 
	"Establish the initial conditions for editing the paragraph: place caret 
	before first character, set the emphasis to that of the first character,
	and save the paragraph for purposes of canceling."

	startBlock _ paragraph defaultCharacterBlock.
	stopBlock _ startBlock copy.
	beginTypeInBlock _ nil.
	UndoInterval _ otherInterval _ 1 to: 0.
	self setEmphasisHere.
	selectionShowing _ false.
	initialText _ paragraph text copy! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 5/15/2000 13:51'!
stateArray
	^ {ChangeText.
		FindText.
		UndoInterval.
		UndoMessage.
		UndoParagraph.
		UndoSelection.
		Undone.
		self selectionInterval.
		self startOfTyping.
		emphasisHere}! !

!ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 10/5/1998 17:03'!
stateArrayPut: stateArray
	| sel |
	ChangeText _ stateArray at: 1.
	FindText _ stateArray at: 2.
	UndoInterval _ stateArray at: 3.
	UndoMessage _ stateArray at: 4.
	UndoParagraph _ stateArray at: 5.
	UndoSelection _ stateArray at: 6.
	Undone _ stateArray at: 7.
	sel _ stateArray at: 8.
	self selectFrom: sel first to: sel last.
	beginTypeInBlock _ stateArray at: 9.
	emphasisHere _ stateArray at: 10.! !


!ParagraphEditor methodsFor: 'accessing' stamp: 'tk 4/21/1998 09:55'!
initialText
	^ initialText! !

!ParagraphEditor methodsFor: 'accessing'!
replace: oldInterval with: newText and: selectingBlock 
	"Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection.  Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing."

	| undoInterval |
	undoInterval _ self selectionInterval.
	undoInterval = oldInterval ifFalse: [self selectInterval: oldInterval].
	UndoSelection _ self selection.
	self zapSelectionWith: newText.
	selectingBlock value.
	otherInterval _ self selectionInterval.
	self undoer: #undoAndReselect:redoAndReselect: with: undoInterval with: otherInterval! !

!ParagraphEditor methodsFor: 'accessing'!
replaceSelectionWith: aText
	"Remember the selection text in UndoSelection.
	 Deselect, and replace the selection text by aText.
	 Remember the resulting selectionInterval in UndoInterval and PriorInterval.
	 Set up undo to use UndoReplace."

	beginTypeInBlock ~~ nil ifTrue: [^self zapSelectionWith: aText]. "called from old code"
	UndoSelection _ self selection.
	self zapSelectionWith: aText.
	self undoer: #undoReplace! !

!ParagraphEditor methodsFor: 'accessing'!
selection
	"Answer the text in the paragraph that is currently selected."

	^paragraph text copyFrom: startBlock stringIndex to: stopBlock stringIndex - 1 ! !

!ParagraphEditor methodsFor: 'accessing'!
selectionAsStream
	"Answer a ReadStream on the text in the paragraph that is currently 
	selected."

	^ReadWriteStream
		on: paragraph string
		from: startBlock stringIndex
		to: stopBlock stringIndex - 1! !

!ParagraphEditor methodsFor: 'accessing'!
selectionInterval
	"Answer the interval that is currently selected."

	^startBlock stringIndex to: stopBlock stringIndex - 1 ! !

!ParagraphEditor methodsFor: 'accessing'!
setSearch: aString
	"Set the FindText and ChangeText to seek aString; except if already seeking aString, leave ChangeText alone so again will repeat last replacement."

	FindText string = aString
		ifFalse: [FindText _ ChangeText _ aString asText]! !

!ParagraphEditor methodsFor: 'accessing'!
text
	"Answer the text of the paragraph being edited."

	^paragraph text! !

!ParagraphEditor methodsFor: 'accessing' stamp: 'jm 3/18/98 20:38'!
userHasEdited
	"Note that the user has edited my text. Here it is just a noop so that the Character Recognizer won't fail when used with a vanilla ParagrahEditor."
! !

!ParagraphEditor methodsFor: 'accessing' stamp: 'sw 12/7/1999 11:39'!
zapSelectionWith: aText
	"Deselect, and replace the selection text by aText.
	 Remember the resulting selectionInterval in UndoInterval and otherInterval.
	 Do not set up for undo."

	| start stop |
	self deselect.
	start _ startBlock stringIndex.
	stop _ stopBlock stringIndex.
	(aText isEmpty and: [stop > start]) ifTrue:
		["If deleting, then set emphasisHere from 1st character of the deletion"
		emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]].
	(start = stop and: [aText size = 0]) ifFalse:
		[paragraph
			replaceFrom: start
			to: stop - 1
			with: aText
			displaying: true.
		self computeIntervalFrom: start to: start + aText size - 1.
		UndoInterval _ otherInterval _ self selectionInterval]! !


!ParagraphEditor methodsFor: 'controlling'!
controlInitialize

	super controlInitialize.
	self recomputeInterval.
	self initializeSelection.
	beginTypeInBlock _ nil! !

!ParagraphEditor methodsFor: 'controlling'!
controlTerminate

	self closeTypeIn.  "Must call to establish UndoInterval"
	super controlTerminate.
	self deselect! !

!ParagraphEditor methodsFor: 'controlling' stamp: 'sma 3/11/2000 15:17'!
normalActivity
	self processKeyboard.
	self processMouseButtons! !


!ParagraphEditor methodsFor: 'scrolling'!
computeMarkerRegion 
	"Refer to the comment in ScrollController|computeMarkerRegion."

	paragraph compositionRectangle height = 0
		ifTrue:	[^0@0 extent: Preferences scrollBarWidth @ scrollBar inside height]
		ifFalse:	[^0@0 extent:
					Preferences scrollBarWidth 
						@ ((paragraph clippingRectangle height asFloat /
							self scrollRectangleHeight * scrollBar inside height) rounded
							min: scrollBar inside height)]! !

!ParagraphEditor methodsFor: 'scrolling'!
markerDelta

	^marker top - scrollBar top - ((paragraph clippingRectangle top -
		paragraph compositionRectangle top) asFloat /
			(self scrollRectangleHeight max: 1) asFloat *
				scrollBar height asFloat) rounded! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollAmount 
	"Refer to the comment in ScrollController|scrollAmount."

	^sensor cursorPoint y - scrollBar top! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollBar
	^ scrollBar! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollBy: heightToMove
	"Move the paragraph by heightToMove, and reset the text selection."
	^ paragraph scrollBy: heightToMove withSelectionFrom: startBlock to: stopBlock! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollRectangleHeight

	^paragraph compositionRectangle height 
		+ paragraph lineGrid! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollToBottom
	"Scroll so that the tail end of the text is visible in the view.  5/6/96 sw"

	self scrollView: (paragraph clippingRectangle bottom 
		- paragraph compositionRectangle bottom)! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollToTop
	"Scroll so that the paragraph is at the top of the view."

	self scrollView: (paragraph clippingRectangle top 
		- paragraph compositionRectangle top)! !

!ParagraphEditor methodsFor: 'scrolling'!
scrollView: anInteger 
	"Paragraph scrolling uses opposite polarity"
	^ self scrollBy: anInteger negated! !

!ParagraphEditor methodsFor: 'scrolling'!
updateMarker
	"A variation of computeMarkerRegion--only redisplay the marker in the scrollbar if an actual change has occurred in the positioning of the paragraph."
	self moveMarkerTo: self computeMarkerRegion! !

!ParagraphEditor methodsFor: 'scrolling'!
viewDelta 
	"Refer to the comment in ScrollController|viewDelta."

	^paragraph clippingRectangle top 
		- paragraph compositionRectangle top 
		- ((marker top - scrollBar inside top) asFloat 
				/ scrollBar inside height asFloat * self scrollRectangleHeight asFloat)
			roundTo: paragraph lineGrid! !


!ParagraphEditor methodsFor: 'sensor access'!
processBlueButton
	"The user pressed the blue button on the mouse. Determine what action 
	to take."

	^self! !

!ParagraphEditor methodsFor: 'sensor access'!
processKeyboard
	"Determine whether the user pressed the keyboard. If so, read the keys."

	sensor keyboardPressed ifTrue: [self readKeyboard]! !

!ParagraphEditor methodsFor: 'sensor access'!
processMouseButtons
	"Determine whether the user pressed any mouse button. For each possible 
	button, determine what actions to take."

	sensor redButtonPressed ifTrue: [self processRedButton].
	sensor yellowButtonPressed ifTrue: [self processYellowButton].
	sensor blueButtonPressed ifTrue: [self processBlueButton]! !

!ParagraphEditor methodsFor: 'sensor access' stamp: 'tk 1/7/98 12:03'!
processRedButton
	"The user pressed a red mouse button, meaning create a new text 
	selection. Highlighting the selection is carried out by the paragraph 
	itself. Double clicking causes a selection of the area between the nearest 
	enclosing delimitors."

	| previousStartBlock previousStopBlock selectionBlocks tempBlock clickPoint oldDelta oldInterval |

	clickPoint _ sensor cursorPoint.
	(view containsPoint: clickPoint) ifFalse: [^ self].
	(paragraph clickAt: clickPoint for: model controller: self) ifTrue: [^ self].
	oldInterval _ startBlock stringIndex to: stopBlock stringIndex - 1.
	previousStartBlock _ startBlock.
	previousStopBlock _ stopBlock.
	oldDelta _ paragraph scrollDelta.
	sensor leftShiftDown
		ifFalse:
			[self deselect.
			self closeTypeIn.
			selectionBlocks _ paragraph mouseSelect: clickPoint]
		ifTrue:
			[selectionBlocks _ paragraph extendSelectionAt: startBlock endBlock: stopBlock.
			self closeTypeIn].
	selectionShowing _ true.
	startBlock _ selectionBlocks at: 1.
	stopBlock _ selectionBlocks at: 2.
	startBlock > stopBlock
		ifTrue: 
			[tempBlock _ startBlock.
			startBlock _ stopBlock.
			stopBlock _ tempBlock].
	(startBlock = stopBlock 
		and: [previousStartBlock = startBlock and: [previousStopBlock = stopBlock]])
		ifTrue: [self selectWord].
	oldDelta ~= paragraph scrollDelta "case of autoscroll"
			ifTrue: [self updateMarker].
	self setEmphasisHere.
	(self isDisjointFrom: oldInterval) ifTrue:
		[otherInterval _ oldInterval]! !

!ParagraphEditor methodsFor: 'sensor access'!
processYellowButton
	"User pressed the yellow button on the mouse. Determine what actions to 
	take."

	self yellowButtonActivity! !


!ParagraphEditor methodsFor: 'displaying'!
display
	"Redisplay the paragraph."

	| selectionState |
	selectionState _ selectionShowing.
	self deselect.
	paragraph foregroundColor: view foregroundColor
			backgroundColor: view backgroundColor;
			displayOn: Display.
	selectionState ifTrue: [self select]! !

!ParagraphEditor methodsFor: 'displaying'!
flash
	"Causes the view of the paragraph to complement twice in succession."

	paragraph flash! !


!ParagraphEditor methodsFor: 'menu messages' stamp: 'jm 5/3/1998 19:19'!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling."

	initialText _ paragraph text copy.
! !

!ParagraphEditor methodsFor: 'menu messages'!
again
	"Text substitution. If the left shift key is down, the substitution is made 
	throughout the entire Paragraph. Otherwise, only the next possible 
	substitution is made.
	Undoer & Redoer: #undoAgain:andReselect:typedKey:."

	"If last command was also 'again', use same keys as before"
	self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:)! !

!ParagraphEditor methodsFor: 'menu messages'!
align
	"Align text according to the next greater alignment value--cycling among 
	left flush, right flush, center, justified.  No effect on the undoability of the pre
	preceding command."

	paragraph toggleAlignment.
	paragraph displayOn: Display.
	self recomputeInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 5/4/2000 13:45'!
browseClassFromIt
	"Launch a hierarchy browser for the class indicated by the current selection.  If multiple classes matching the selection exist, let the user choose among them."

	| aClass |
	self lineSelectAndEmptyCheck: [^ self].

	aClass _ Utilities classFromPattern: (self selection string copyWithout: Character cr) withCaption: 'choose a class to browse...'.
	aClass ifNil: [^ view flash].

	self terminateAndInitializeAround:
		[Utilities spawnHierarchyForClass: aClass selector: nil]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/20/2000 12:18'!
browseIt
	"Launch a browser for the current selection, if appropriate"

	| aSymbol anEntry brow |

	Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].

	self lineSelectAndEmptyCheck: [^ self].
	(aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash].

	self terminateAndInitializeAround:
		[aSymbol first isUppercase
			ifTrue:
				[anEntry _ (Smalltalk
					at: aSymbol
					ifAbsent:
						[Smalltalk browseAllImplementorsOf: aSymbol.
						^ nil]).
				anEntry isNil ifTrue: [^ view flash].
				(anEntry isKindOf: Class)
					ifFalse:	[anEntry _ anEntry class].
				brow _ Preferences browseToolClass new.
				brow setClass: anEntry selector: nil.
				brow class
					openBrowserView: (brow openEditString: nil)
					label: 'System Browser']
			ifFalse:
				[Smalltalk browseAllImplementorsOf: aSymbol]]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 6/23/1998 11:08'!
browseItHere
	"Retarget the receiver's window to look at the selected class, if appropriate.  3/1/96 sw"
	| aSymbol foundClass b |
	(((b _ model) isKindOf: Browser) and: [b couldBrowseAnyClass])
		ifFalse: [^ view flash].
	model okToChange ifFalse: [^ view flash].
	self selectionInterval isEmpty ifTrue: [self selectWord].
	(aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash].

	self terminateAndInitializeAround:
		[foundClass _ (Smalltalk at: aSymbol ifAbsent: [nil]).
			foundClass isNil ifTrue: [^ view flash].
			(foundClass isKindOf: Class)
				ifTrue:
					[model systemCategoryListIndex: 
						(model systemCategoryList indexOf: foundClass category).
		model classListIndex: (model classList indexOf: foundClass name)]]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/15/98 12:57'!
cancel 
	"Restore the text of the paragraph to be the text saved since initialization 
	or the last accept.  Undoer & Redoer: undoAndReselect:redoAndReselect:.
	This used to call controlTerminate and controlInitialize but this seemed illogical.
	Sure enough, nobody overrode them who had cancel in the menu, and if
	anybody really cared they could override cancel."

	UndoSelection _ paragraph text.
	self undoer: #undoAndReselect:redoAndReselect: with: self selectionInterval with: (1 to: 0).
	view ifNotNil: [view clearInside].
	self changeParagraph: (paragraph text: initialText).
	UndoParagraph _ paragraph.
	otherInterval _ UndoInterval _ 1 to: initialText size. "so undo will replace all"
	paragraph displayOn: Display.
	self selectAt: 1.
	self scrollToTop
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:36'!
changeAlignment
	| aList reply  |
	aList _ #(leftFlush centered justified rightFlush).
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[paragraph perform: reply.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:39'!
changeEmphasis
	| aList reply  |
	aList _ #(plain bold italic narrow underlined struckOut).
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self setEmphasis: reply.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:42'!
changeEmphasisOrAlignment
	| aList reply  |
	aList _ #(plain bold italic narrow underlined struckOut leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: aList lines: #(6) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue:
				[paragraph perform: reply.
				self recomputeInterval]
			ifFalse:
				[self setEmphasis: reply.
				paragraph composeAll.
				self recomputeSelection.
				self mvcRedisplay]].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 12/30/1999 15:29'!
changeStyle
	"Let user change styles for the current text pane  
	 Moved from experimentalCommand to its own method  "

	| aList reply style |
	aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection.
	aList addFirst: 'DefaultTextStyle'.
	reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(style _ TextStyle named: reply) ifNil: [self beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:54'!
chooseAlignment
	self changeAlignment! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:37'!
clipboardText

	^ Clipboard clipboardText! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'!
clipboardText: text

	^ Clipboard clipboardText: text! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:38'!
clipboardTextPut: text

	^ Clipboard clipboardText: text! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 11/23/1998 15:21'!
compareToClipboard
	"Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user."
	| s1 s2 |
	s1 _ self clipboardText string.
	s2 _ paragraph text string.
	s1 = s2 ifTrue: [^ self inform: 'Exact match'].

	(StringHolder new textContents:
		(TextDiffBuilder buildDisplayPatchFrom: s1 to: s2))
		openLabel: 'Comparison to Clipboard Text'! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:09'!
copySelection
	"Copy the current selection and store it in the paste buffer, unless a caret.  Undoer & Redoer: undoCutCopy"

	self lineSelectAndEmptyCheck: [^ self].

	"Simulate 'substitute: self selection' without locking the controller"
	UndoSelection _ self selection.
	self undoer: #undoCutCopy: with: self clipboardText.
	UndoInterval _ self selectionInterval.
	self clipboardTextPut: UndoSelection! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 16:33'!
cut
	"Cut out the current selection and redisplay the paragraph if necessary.  Undoer & Redoer: undoCutCopy:"

	self lineSelectAndEmptyCheck: [^ self].

	self replaceSelectionWith: self nullText. 
	self undoer: #undoCutCopy: with: self clipboardText.
	self clipboardTextPut: UndoSelection! !

!ParagraphEditor methodsFor: 'menu messages'!
exchange
	"See comment in exchangeWith:"

	self exchangeWith: otherInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:34'!
experimentalCommand
	"Use for experimental command-key implementation.  Using this, 
	you can try things out without forever needing to reinitialize the 
	ParagraphEditor."

	self prettyPrint.
	^ true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ls 10/10/1999
11:36'!
explain
	"Try to shed some light on what kind of entity the current selection
is. 
	The selection must be a single token or construct. Insert the answer
after 
	the selection. Send private messages whose names begin with 'explain' 
	that return a string if they recognize the selection, else nil."

	| string tiVars cgVars selectors delimitors numbers sorry reply symbol
|
Cursor execute showWhile: 
			[sorry _ '"Sorry, I can''t explain that.  Please select a single
token, construct, or special character.'.
			sorry _ sorry , (view canDiscardEdits
							ifFalse: ['  Also, please cancel or accept."']
							ifTrue: ['"']).
			(string _ self selection asString) isEmpty
				ifTrue: [reply _ '']
				ifFalse: [string _ self explainScan: string.
					"Remove space, tab, cr"
					"Temps and Instance vars need only test strings that are all
letters"
					(string detect: [:char | (char isLetter or: [char isDigit]) not]
						ifNone: []) ifNil: 
							[tiVars _ self explainTemp: string.
							tiVars == nil ifTrue: [tiVars _ self explainInst: string]].
					(tiVars == nil and: [model respondsTo: #explainSpecial:])
						ifTrue: [tiVars _ model explainSpecial: string].
					tiVars == nil
						ifTrue: [tiVars _ '']
						ifFalse: [tiVars _ tiVars , '\' withCRs].
					"Context, Class, Pool, and Global vars, and Selectors need 
					only test symbols"
					(Symbol hasInterned: string ifTrue: [:s | symbol _ s])
						ifTrue: [cgVars _ self explainCtxt: symbol.
							cgVars == nil
								ifTrue: [cgVars _ self explainClass: symbol.
									cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].
							"See if it is a Selector (sent here or not)"
							selectors _ self explainMySel: symbol.
							selectors == nil
								ifTrue: 
									[selectors _ self explainPartSel: string.
									selectors == nil ifTrue: [
										selectors _ self explainAnySel: symbol]]]
						ifFalse: [selectors _ self explainPartSel: string].
					cgVars == nil
						ifTrue: [cgVars _ '']
						ifFalse: [cgVars _ cgVars , '\' withCRs].
					selectors == nil
						ifTrue: [selectors _ '']
						ifFalse: [selectors _ selectors , '\' withCRs].
					string size = 1
						ifTrue: ["single special characters"
							delimitors _ self explainChar: string]
						ifFalse: ["matched delimitors"
							delimitors _ self explainDelimitor: string].
					numbers _ self explainNumber: string.
					numbers == nil ifTrue: [numbers _ ''].
					delimitors == nil ifTrue: [delimitors _ ''].
					reply _ tiVars , cgVars , selectors , delimitors , numbers].
			reply size = 0 ifTrue: [reply _ sorry].
			self afterSelectionInsertAndSelect: reply]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:41'!
fileItIn
	"Make a Stream on the text selection and fileIn it.
	 1/24/96 sw: moved here from FileController; this function can be useful from any text window that shows stuff in chunk format"

	| selection |
	selection _ self selection.
	self terminateAndInitializeAround:
		[(ReadWriteStream on: selection string from: 1 to: selection size) fileIn].
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/5/1998 21:55'!
find
	"Prompt the user for a string to search for, and search the receiver from the current selection onward for it.  1/26/96 sw"

	| reply |
	reply _ FillInTheBlank request: 'Find what? ' initialAnswer: ''.
	reply size == 0 ifTrue: [^ self].
	self setSearch: reply.
	ChangeText _ FindText.  "Implies no replacement to againOnce: method"
	self againOrSame: true
	
! !

!ParagraphEditor methodsFor: 'menu messages'!
findAgain
	"Find the text-to-find again.  1/24/96 sw"

	self againOrSame: true! !

!ParagraphEditor methodsFor: 'menu messages'!
fit
	"Make the bounding rectangle of the paragraph contain all the text while 
	 not changing the width of the view of the paragraph.  No effect on undoability
	 of the preceding command."

	paragraph clearVisibleRectangle.
	paragraph fit.
	paragraph displayOn: Display; outline.
	self recomputeInterval! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:07'!
implementorsOfIt
	"Open an implementors browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self terminateAndInitializeAround: [Smalltalk browseAllImplementorsOf: aSelector]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'tk 6/30/2000 08:41'!
languagePrefs
	"Lets user set preference for primary natural language and languages to translate from and to.  Preferences naturalLanguage.  Preferences languageTranslateFrom."

	self terminateAndInitializeAround: [
		WordNet languagePrefs].

! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 11/2/1998 09:43'!
lineSelectAndEmptyCheck: returnBlock
	"If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."

	self selectLine.  "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
	startBlock = stopBlock ifTrue: [self flash.  ^ returnBlock value]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:26'!
methodNamesContainingIt
	"Open a browser on methods names containing the selected string"

	self lineSelectAndEmptyCheck: [^ self].
	Cursor wait showWhile:
		[self terminateAndInitializeAround: [Smalltalk browseMethodsWhoseNamesContain: self selection string withBlanksTrimmed]].
	Cursor normal show! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:10'!
methodSourceContainingIt
	"Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source).   EXTREMELY slow!!"

	self lineSelectAndEmptyCheck: [^ self].
	(self confirm: 'This will take a few minutes.
Shall I proceed?') ifFalse: [^ self].
	Smalltalk browseMethodsWithSourceString: self selection string! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/15/97 13:26'!
methodStringsContainingit
	"Open a browser on methods which contain the current selection as part of a string constant."

	self lineSelectAndEmptyCheck: [^ self].
	self terminateAndInitializeAround: [Smalltalk browseMethodsWithString: self selection string]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/2/97 11:34'!
mvcRedisplay
	"Overridable by subclasses that do their own display"
	Display fill: paragraph clippingRectangle 
			fillColor: view backgroundColor.	"very brute force"
	self display! !

!ParagraphEditor methodsFor: 'menu messages'!
paste
	"Paste the text from the shared buffer over the current selection and 
	redisplay if necessary.  Undoer & Redoer: undoAndReselect."

	self replace: self selectionInterval with: self clipboardText and:
		[self selectAt: stopBlock stringIndex]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'ar 1/15/2001 18:36'!
pasteRecent
	"Paste an item chose from RecentClippings."

	| clipping |
	(clipping _ Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self paste! !

!ParagraphEditor methodsFor: 'menu messages'!
performMenuMessage: aSelector
	"If a menu command is invoked, typeIn must be closed first, the selection
	 must be unhighlighted before and rehighlighted after, and the marker
	 must be updated."

	self closeTypeIn.
	self deselect.
	super performMenuMessage: aSelector.
	self selectAndScroll.
	self updateMarker! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/29/98 13:08'!
presentSpecialMenu
	"Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor.  Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane"

	| reply items |
	self terminateAndInitializeAround:
		[reply _ (PopUpMenu labelArray: (items _ self specialMenuItems) lines: #()) startUp.
		reply = 0 ifTrue: [^ self].
		Utilities evaluate: (items at: reply) in: [] to: self]
	! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:40'!
prettyPrint
	self prettyPrint: false! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:41'!
prettyPrint: decorated
	"Reformat the contents of the receiver's view (a Browser)."

	| selectedClass newText |
	model selectedMessageCategoryName ifNil: [^ view flash].
	selectedClass _ model selectedClassOrMetaClass.
	newText _ selectedClass compilerClass new
		format: self text
		in: selectedClass
		notifying: self
		decorated: decorated.
	newText ifNotNil:
		[self deselect; selectInvisiblyFrom: 1 to: paragraph text size.
		self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass).
		self selectAt: 1]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:40'!
prettyPrintWithColor
	self prettyPrint: true! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/7/2000 21:06'!
printerSetup
	
	TextPrinter defaultTextPrinter inspect
! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 6/26/1998 10:04'!
referencesToIt
	"Open a references browser on the selected symbol"
	| aSymbol |
	self selectionInterval isEmpty ifTrue: [self selectWord].
	((aSymbol _ self selectedSymbol) == nil or:
		[(Smalltalk includesKey: aSymbol) not])
			ifTrue: [^ view flash].

	self terminateAndInitializeAround: [Smalltalk browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/9/2000 00:15'!
saveContentsInFile
	| fileName stringToSave parentWindow labelToUse |
	stringToSave _ paragraph text string.
	stringToSave size == 0 ifTrue: [^ self inform: 'nothing to save.'].
	parentWindow _ self model dependents
						detect: [:dep | dep isKindOf: SystemWindow]
						ifNone: [nil].
	parentWindow isNil
		ifTrue: [labelToUse _ 'Untitled']
		ifFalse: [labelToUse _ parentWindow label].

	fileName _ FillInTheBlank request: 'File name? (".text" will be added to end)' 
			initialAnswer: labelToUse.
	fileName size == 0 ifTrue: [^ self beep].
	(fileName asLowercase endsWith: '.text') ifFalse: [fileName _ fileName,'.text'].

	(FileStream newFileNamed: fileName)
		nextPutAll: stringToSave; close! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'bf 10/13/1999 09:09'!
selectedSelector
	"Try to make a selector out of the current text selection"
	^self selection string findSelector! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 1/9/2001 05:33'!
selectedSymbol
	"Return the currently selected symbol, or nil if none.  Spaces, tabs and returns are ignored"

	| aString |
	startBlock = stopBlock ifTrue: [^ nil].
	aString _ self selection string copyWithoutAll:
		{Character space.  Character cr.  Character tab}.
	aString size == 0 ifTrue: [^ nil].
	Symbol hasInterned: aString  ifTrue: [:sym | ^ sym].

	^ nil! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'tk 1/22/2001 14:57'!
selectionAsTiles
	"Try to make new universal tiles from the selected text"
	| selection tiles |

	selection _ self selection.
	self terminateAndInitializeAround:
		[self currentHand attachMorph: (tiles _ Player tilesFrom: selection).
		tiles align: tiles topLeft 
			 with: self currentHand position + tiles cursorBaseOffset].! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/9/2000 00:15'!
sendContentsToPrinter
	| textToPrint printer parentWindow |
	textToPrint _ paragraph text.
	textToPrint size == 0 ifTrue: [^ self inform: 'nothing to print.'].
	printer _ TextPrinter defaultTextPrinter.
	parentWindow _ self model dependents
						detect: [:dep | dep isKindOf: SystemWindow]
						ifNone: [nil].
	parentWindow isNil
		ifTrue: [printer documentTitle: 'Untitled']
		ifFalse: [printer documentTitle: parentWindow label].
	printer printText: textToPrint.

! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 15:11'!
sendersOfIt
	"Open a senders browser on the selected selector"

	| aSelector |
	self lineSelectAndEmptyCheck: [^ self].
	(aSelector _ self selectedSelector) == nil ifTrue: [^ view flash].
	self terminateAndInitializeAround: [Smalltalk browseAllCallsOn: aSelector]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 8/1/97 16:12'!
setSearchString
	"Make the current selection, if any, be the current search string."
	startBlock = stopBlock ifTrue: [view flash. ^ self].
	self setSearch:  self selection string! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 5/20/1998 22:41'!
spawn
	"Create and schedule a message browser for the code of the model's 
	selected message. Retain any edits that have not yet been accepted."
	| code |
	code _ paragraph text string.
	self cancel.
	model spawn: code.! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:44'!
spawnWorkspace
	| toUse |
	self selectLine.
	toUse _ self selection asString.
	toUse size > 0 ifFalse:
		[toUse _ paragraph text string.
		toUse size > 0 ifFalse: [^ self flash]].
	"NB: BrowserCodeController's version does a cancel here"
	self terminateAndInitializeAround:
		[Utilities openScratchWorkspaceLabeled: 'Untitled' contents: toUse]! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/29/96'!
specialMenuItems
	"Refer to comment under #presentSpecialMenu.  .
	 : added objectsReferencingIt,"

	^ #(	'Transcript cr; show: ''testing'''
			'view superView model inspect'
			'view superView model browseObjClass'
			'view display'
			'self inspect'
			'view backgroundColor: Color fromUser'
			'view topView inspect'
			'self compareToClipboard'
			'view insideColor: Form white'
			'self objectsReferencingIt'
		) ! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'tk 7/9/2000 22:28'!
translateIt
	| aWord |
	"Translate a passage of text and open its definition in a separate window.  Use the FreeTranslation.com server.  Requires internet access.  Default is English-> Spanish, but set it with the 'choose language' menu item."

	self lineSelectAndEmptyCheck: [^ self].
	aWord _ self selection asString.
	self terminateAndInitializeAround: [
		FreeTranslation openScamperOn: aWord].


! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'SqR 11/14/2000 12:15'!
undo
	"Reset the state of the paragraph prior to the previous edit.
	 If another ParagraphEditor instance did that edit, UndoInterval is invalid;
	 just recover the contents of the undo-buffer at the start of the paragraph."

	sensor flushKeyboard. "a way to flush stuck keys"
	self closeTypeIn.

	UndoParagraph == paragraph ifFalse: "Can't undo another paragraph's edit"
		[UndoMessage _ Message selector: #undoReplace.
		UndoInterval _ 1 to: 0.
		Undone _ true].
	UndoInterval ~= self selectionInterval ifTrue: "blink the actual target"
		[self selectInterval: UndoInterval; deselect].

	"Leave a signal of which phase is in progress"
	UndoParagraph _ Undone ifTrue: [#redoing] ifFalse: [#undoing].
	UndoMessage sentTo: self.
	UndoParagraph _ paragraph! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'tk 6/27/2000 12:27'!
verifyWordSpelling
	| aWord answer |
	"Look up a single word and inform the user if it was found.  Use the WordNet server.  Requires internet access.  Default is English, but set it like this
	Preferences setPreference: #naturalLanguage toValue: #Deutsch.
	"

	self lineSelectAndEmptyCheck: [^ self].
	aWord _ self selection asString.

	Cursor execute showWhile: [
		answer _ WordNet lexiconServer verify: aWord].

	self terminateAndInitializeAround: [
		self inform: answer].

! !

!ParagraphEditor methodsFor: 'menu messages' stamp: 'tk 7/9/2000 22:29'!
wordDefinition
	| aWord |
	"Look up a single word and open its definition in a separate window.  Use the WordNet server.  Requires internet access.  Default is English, but set it like this
	Preferences setPreference: #naturalLanguage toValue: #Portuguese.
	"

	self lineSelectAndEmptyCheck: [^ self].
	aWord _ self selection asString.
	self terminateAndInitializeAround: [
		WordNet lexiconServer openScamperOn: aWord].


"This code for showing definition in a Workspace
	Cursor execute showWhile: [
		(aDefinition _ WordNet lexiconServer definitionsFor: aWord) ifNil: [
			^ view flash]].

	self terminateAndInitializeAround: [
		(StringHolder new contents: aDefinition) openLabel: aWord
		].
"

! !


!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 11:01'!
explainAnySel: symbol 
	"Is this any message selector?"

	| list reply |
	list _ Smalltalk allClassesImplementing: symbol.
	list size = 0 ifTrue: [^nil].
	list size < 12
		ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString]
		ifFalse: [reply _ ' is a message selector which is defined in many classes'].
	^'"' , symbol , reply , '."' , '\' withCRs, 'Smalltalk browseAllImplementorsOf: #' , symbol! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/14/1999 15:07'!
explainChar: string
	"Does string start with a special character?"

	| char |
	char _ string at: 1.
	char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement.  A period in the middle of a number means a decimal point.  (The number is an instance of class Float)."'].
	char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"'].
	char = $" ifTrue: [^'"Double quotes enclose a comment.  Smalltalk ignores everything between double quotes."'].
	char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol.  If parenthesis follow a hash mark, an instance of class Array is made.  It contains literal constants."'].
	(char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"'].
	(char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code.  It becomes an instance of BlockContext and is usually passed as an argument."'].
	(char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine.  If this method is primitive, its Smalltalk code is executed only when the primitive fails."'].
	char = $^ ifTrue: [^'"Uparrow means return from this method.  The value returned is the expression following the ^"'].
	char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method.  In a block, the vertical bar separates the argument names from the rest of the code."'].
	char = $_ ifTrue: [^'"Left arrow means assignment.  The value of the expression after the left arrow is stored into the variable before it."'].
	char = $; ifTrue: [^'"Semicolon means cascading.  The message after the semicolon is sent to the same object which received the message before the semicolon."'].
	char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow.  Methods which take more than one argument have selectors with more than one keyword.  (One keyword, ending with a colon, appears before each argument).', '\\' withCRs, 'A colon before a variable name just inside a block means that the block takes an agrument.  (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."'].
	char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"'].
	char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."'].
	char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."'].
	char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix.  The digits before the r denote the base and the digits after it express a number in that base."'].
	char = Character space ifTrue: [^'"the space Character"'].
	char = Character tab ifTrue: [^'"the tab Character"'].
	char = Character cr ifTrue: [^'"the carriage return Character"'].
	^nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'apb 10/1/2000 01:32'!
explainClass: symbol 
	"Is symbol a class variable or a pool variable?"
	| class reply classes |
	(model respondsTo: #selectedClassOrMetaClass)
		ifFalse: [^ nil].
	(class _ model selectedClassOrMetaClass) ifNil: [^ nil].
	"no class is selected"
	(class isKindOf: Metaclass)
		ifTrue: [class _ class soleInstance].
	classes _ (Array with: class)
				, class allSuperclasses.
	"class variables"
	reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name]
					ifNone: [])
					~~ nil]
				ifNone: [].
	reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').'].
	"pool variables"
	classes do: [:each | (each sharedPools
			detect: [:pool | (pool includesKey: symbol)
					and: 
						[reply _ pool.
						true]]
			ifNone: [])
			~~ nil].
	reply
		ifNil: [(Undeclared includesKey: symbol)
				ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'Smalltalk browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']]
		ifNotNil: 
			[classes _ WriteStream on: Array new.
			Smalltalk
				allBehaviorsDo: [:each | (each sharedPools
						detect: 
							[:pool | 
							self halt.
							pool == reply]
						ifNone: [])
						~~ nil ifTrue: [classes nextPut: each]].
			"Perhaps not print whole list of classes if too long. (unlikely)"
			^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'Smalltalk browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' associationAt: #' , symbol , ').'].
	^ nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'sw 5/3/1998 14:32'!
explainCtxt: symbol 
	"Is symbol a context variable?"

	| reply classes text cls |
	symbol = #nil ifTrue: [reply _ '"is a constant.  It is the only instance of class UndefinedObject.  nil is the initial value of all variables."'].
	symbol = #true ifTrue: [reply _ '"is a constant.  It is the only instance of class True and is the receiver of many control messages."'].
	symbol = #false ifTrue: [reply _ '"is a constant.  It is the only instance of class False and is the receiver of many control messages."'].
	symbol = #thisContext ifTrue: [reply _ '"is a context variable.  Its value is always the MethodContext which is executing this method."'].
	(model respondsTo: #selectedClassOrMetaClass) ifTrue: [
		cls _ model selectedClassOrMetaClass].
	cls ifNil: [^ reply].	  "no class known"
	symbol = #self ifTrue: 
			[classes _ cls withAllSubclasses.
			classes size > 12
				ifTrue: [text _ cls printString , ' or a subclass']
				ifFalse: 
					[classes _ classes printString.
					text _ 'one of these classes' , (classes copyFrom: 4 to: classes size)].
			reply _ '"is the receiver of this message; an instance of ' , text , '"'].
	symbol = #super ifTrue: [reply _ '"is just like self.  Messages to super are looked up in the superclass (' , cls superclass printString , ')"'].
	^reply! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 10:58'!
explainDelimitor: string
	"Is string enclosed in delimitors?"

	| str |
	(string at: 1) isLetter ifTrue: [^nil].  "only special chars"
	(string first = string last) ifTrue:
			[^ self explainChar: (String with: string first)]
		ifFalse:
			[(string first = $( and: [string last = $)]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $[ and: [string last = $]]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $< and: [string last = $>]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $# and: [string last = $)]) ifTrue:
				[^'"An instance of class Array.  The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."'].
			string first = $# ifTrue:
				[^'"An instance of class Symbol."'].
			(string first = $$ and: [string size = 2]) ifTrue:
				[^'"An instance of class Character.  This one is the character ', (String with: string last), '."'].
			(string first = $:) ifTrue:
				[str _ string allButFirst.
				(self explainTemp: str) ~~ nil ifTrue:
					[^'"An argument to this block will be bound to the temporary variable ',
						str, '."']]].
	^ nil! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 10:57'!
explainGlobal: symbol 
	"Is symbol a global variable?"
	| reply classes |
	reply _ Smalltalk at: symbol ifAbsent: [^nil].
	(reply isKindOf: Behavior)
		ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,
			'."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.'].
	symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
	reply class == Dictionary
		ifTrue: 
			[classes _ Set new.
			Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]
					ifNone: [])
					~~ nil ifTrue: [classes add: each]].
			classes _ classes printString.
			^'"is a global variable.  ' , symbol , ' is a Dictionary.  It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].
	^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 14:14'!
explainInst: string 
	"Is string an instance variable of this class?"
	| classes cls |

	(model respondsTo: #selectedClassOrMetaClass) ifTrue: [
		cls _ model selectedClassOrMetaClass].
	cls ifNil: [^ nil].	  "no class known"
	classes _ (Array with: cls)
				, cls allSuperclasses.
	classes _ classes detect: [:each | (each instVarNames
			detect: [:name | name = string] ifNone: [])
			~~ nil] ifNone: [^nil].
	classes _ classes printString.
	^ '"is an instance variable of the receiver; defined in class ' , classes , 
		'"\' withCRs , classes , ' browseAllAccessesTo: ''' , string , '''.'! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/20/1999 09:48'!
explainMySel: symbol 
	"Is symbol the selector of this method?  Is it sent by this method?  If 
	not, then expalin will call (explainPartSel:) to see if it is a fragment of a 
	selector sent here.  If not, explain will call (explainAnySel:) to catch any 
	selector. "

	| lits classes msg |
	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^nil].	"not in a message"
	classes _ Smalltalk allClassesImplementing: symbol.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	msg = symbol
		ifTrue: [^ '"' , symbol , ' is the selector of this very method!!  It is defined in ',
			classes , '.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: 
			[lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(lits detect: [:each | each == symbol]
				ifNone: [])
				== nil ifTrue: [^nil].
			^ '"' , symbol , ' is a message selector which is defined in ', classes , '.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].! !

!ParagraphEditor methodsFor: 'explain' stamp: 'apb 1/5/2000 16:56'!
explainNumber: string 
	"Is string a Number?"

	| strm c |
	(c _ string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1 and: [(string at: 2) isDigit]])
			ifFalse: [^nil]].
	strm _ ReadStream on: string.
	c _ Number readFrom: strm.
	strm atEnd ifFalse: [^nil].
	c printString = string
		ifTrue: [^'"' , string , ' is a ' , c class name , '"']
		ifFalse: [^'"' , string , ' (= ' , c printString , ') is a ' , c class name , '"']! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/20/1999 09:51'!
explainPartSel: string 
	"Is this a fragment of a multiple-argument selector sent in this method?"
	| lits whole reply classes s msg |

	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^ nil].  "not in a message"
	string last == $: ifFalse: [^ nil].
	"Name of this method"
	lits _ Array with: msg.
	(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
					ifNone: []) ~~ nil]
				ifNone: []) ~~ nil
		ifTrue: [reply _ ', which is the selector of this very method!!'.
			s _ '.  To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']
		ifFalse: 
			["Selectors called from this method"
			lits _ (model selectedClassOrMetaClass compiledMethodAt:
				msg) messages.
			(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
							ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifFalse: [string = 'primitive:'
					ifTrue: [^self explainChar: '<']
					ifFalse: [^nil]].
			reply _ '.'.
			s _ '.  To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].
	classes _ Smalltalk allClassesImplementing: whole.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	^ '"' , string , ' is one part of the message selector ' , whole, reply , '  It is defined in ' , classes , s! !

!ParagraphEditor methodsFor: 'explain'!
explainScan: string 
	"Remove beginning and trailing space, tab, cr.
	 1/15/96 sw: copied intact from BrowserCodeController"

	| c beg end |
	beg _ 1.
	end _ string size.
	
	[beg = end ifTrue: [^string copyFrom: 1 to: 1].
	"if all blank, tell about the first"
	c _ string at: beg.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [beg _ beg + 1].
	
	[c _ string at: end.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [end _ end - 1].
	^string copyFrom: beg to: end	"Return purely visible characters"! !

!ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/1/98 14:19'!
explainTemp: string 
	"Is string the name of a temporary variable (or block argument variable)?"

	| selectedClass tempNames i reply methodNode method msg |
	(model respondsTo: #selectedMessageName) ifFalse: [^ nil].
	(msg _ model selectedMessageName) ifNil: [^nil].	"not in a message"
	selectedClass _ model selectedClassOrMetaClass.
	tempNames _ selectedClass parserClass new 
			parseArgsAndTemps: model selectedMessage notifying: nil.
	method _ selectedClass compiledMethodAt: msg.
	(i _ tempNames findFirst: [:each | each = string]) = 0 ifTrue: [
		(method numTemps > tempNames size)
			ifTrue: 
				["It must be an undeclared block argument temporary"
				methodNode _ selectedClass compilerClass new
							parse: model selectedMessage
							in: selectedClass
							notifying: nil.
				tempNames _ methodNode tempNames]
			ifFalse: [^nil]].
	(i _ tempNames findFirst: [:each | each = string]) > 0 ifTrue: [i > method numArgs
			ifTrue: [reply _ '"is a temporary variable in this method"']
			ifFalse: [reply _ '"is an argument to this method"']].
	^reply! !


!ParagraphEditor methodsFor: 'editing keys'!
align: characterStream 
	"Triggered by Cmd-u;  cycle through alignment alternatives.  8/11/96 sw"

	sensor keyboard.		"flush character"
	self align.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
browseIt: characterStream 
	"Triggered by Cmd-B; browse the thing represented by the current selection, if plausible.  1/18/96 sw"

	sensor keyboard.		"flush character"
	self browseIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
browseItHere: characterStream 
	"Triggered by Cmd-shift-B; browse the thing represented by the current selection, if plausible, in the receiver's own window.  3/1/96 sw"

	sensor keyboard.		"flush character"
	self browseItHere.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:40'!
cancel: characterStream 
	"Cancel unsubmitted changes.  Flushes typeahead.  1/12/96 sw
	 1/22/96 sw: put in control terminate/init"

	sensor keyboard.
	self terminateAndInitializeAround: [self cancel].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 12/7/1999 11:37'!
changeEmphasis: characterStream 
	"Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change.  Keeps typeahead."
	| keyCode attribute oldAttributes index thisSel colors |		 "control 0..9 -> 0..9"
	keyCode _ ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.
	oldAttributes _ paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle.
	thisSel _ self selection.

	"Decipher keyCodes for Command 0-9..."
	(keyCode between: 1 and: 5) ifTrue:
		[attribute _ TextFontChange fontNumber: keyCode].
	keyCode = 6 ifTrue:
		[colors _ #(black magenta red yellow green blue cyan white).
		index _ (PopUpMenu labelArray: colors , #('Do it' 'Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method' 'URL' 'Copy hidden info')
							lines: (Array with: colors size)) startUp.
		index = 0 ifTrue: [^ true].
		index <= colors size
		ifTrue:
			[attribute _ TextColor color: (Color perform: (colors at: index))]
		ifFalse:
			[index _ index - colors size.
			index = 1 ifTrue: [attribute _ TextDoIt new.
				thisSel _ attribute analyze: self selection asString].
			index = 2 ifTrue: [attribute _ TextLink new. 
				thisSel _ attribute analyze: self selection asString with: 'Comment'].
			index = 3 ifTrue: [attribute _ TextLink new. 
				thisSel _ attribute analyze: self selection asString with: 'Definition'].
			index = 4 ifTrue: [attribute _ TextLink new. 
				thisSel _ attribute analyze: self selection asString with: 'Hierarchy'].
			index = 5 ifTrue: [attribute _ TextLink new. 
				thisSel _ attribute analyze: self selection asString].
			index = 6 ifTrue: [attribute _ TextURL new. 
				thisSel _ attribute analyze: self selection asString].
			index = 7 ifTrue: ["Copy hidden info"
				self copyHiddenInfo.  ^ true].	"no other action"
		thisSel ifNil: [^ true]].	"Could not figure out what to link to"
		].
	(keyCode between: 7 and: 11) ifTrue:
		[sensor leftShiftDown
		ifTrue:
			[keyCode = 10 ifTrue: [attribute _ TextKern kern: -1].
			keyCode = 11 ifTrue: [attribute _ TextKern kern: 1]]
		ifFalse:
			[attribute _ TextEmphasis perform:
					(#(bold italic narrow underlined struckOut) at: keyCode - 6).
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	(keyCode = 0) ifTrue:
		[attribute _ TextEmphasis normal].

	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream.
			emphasisHere _ Text addAttribute: attribute toArray: oldAttributes.
			^ true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 11:58'!
changeLfToCr: characterStream 
	"Replace all LFs by CRs.
	Triggered by Cmd-U -- useful when getting code from FTP sites"
	| cr lf |
	sensor keyboard.		"flush the triggering cmd-key character"
	cr _ Character cr.  lf _ Character linefeed.
	self replaceSelectionWith: (Text fromString:
			(self selection string collect: [:c | c = lf ifTrue: [cr] ifFalse: [c]])).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:31'!
compareToClipboard: characterStream 
	"Compare the receiver to the text on the clipboard.  Flushes typeahead.  5/1/96 sw"

	sensor keyboard.	
	self terminateAndInitializeAround: [self compareToClipboard].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'bf 3/16/2000 18:25'!
copyHiddenInfo
	"In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden
info.  Copy that to the clipboard.  You can paste it and see what it is.
Usually enclosed in <>."

	| attrList |
	attrList _ paragraph text attributesAt: (startBlock stringIndex +
stopBlock stringIndex)//2 forStyle: paragraph textStyle.
	attrList do: [:attr |
		(attr isKindOf: TextAction) ifTrue:
			[^ self clipboardTextPut: ('<', attr info, '>') asText]].
	"If none of the above"
	attrList do: [:attr |
		attr class == TextColor ifTrue:
			[^ self clipboardTextPut: attr color printString asText]].
	^ self clipboardTextPut: '[No hidden info]' asText! !

!ParagraphEditor methodsFor: 'editing keys'!
copySelection: characterStream 
	"Copy the current text selection.  Flushes typeahead."

	sensor keyboard.		"flush character"
	self copySelection.
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
cut: characterStream 
	"Cut out the current text selection.  Flushes typeahead."

	sensor keyboard.		"flush character"
	self cut.
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:23'!
doIt: characterStream 
	"Called when user hits cmd-d.  Select the current line, if relevant, then evaluate and execute.  2/1/96 sw.
	2/29/96 sw: don't call selectLine; it's done by doIt now"

	sensor keyboard.	
	self terminateAndInitializeAround: [self doIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
duplicate: characterStream
	"Paste the current selection over the prior selection, if it is non-overlapping and
	 legal.  Flushes typeahead.  Undoer & Redoer: undoAndReselect."

	sensor keyboard.
	self closeTypeIn.
	(startBlock ~= stopBlock and: [self isDisjointFrom: otherInterval])
		ifTrue: "Something to duplicate"
			[self replace: otherInterval with: self selection and:
				[self selectAt: stopBlock stringIndex]]
		ifFalse:
			[view flash].
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
enclose: characterStream
	"Insert or remove bracket characters around the current selection.
	 Flushes typeahead."

	| char left right startIndex stopIndex oldSelection which text |
	char _ sensor keyboard.
	self closeTypeIn.
	startIndex _ startBlock stringIndex.
	stopIndex _ stopBlock stringIndex.
	oldSelection _ self selection.
	which _ '([<{"''' indexOf: char ifAbsent: [ ^true ].
	left _ '([<{"''' at: which.
	right _ ')]>}"''' at: which.
	text _ paragraph text.
	((startIndex > 1 and: [stopIndex <= text size])
		and:
		[(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue:
			["already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse:
			["not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string ,(String with: right)
					emphasis: emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
exchange: characterStream
	"Exchange the current and prior selections.  Keeps typeahead."

	sensor keyboard.	 "Flush character"
	self closeTypeIn: characterStream.
	self exchange.
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'acg 12/7/1999 07:56'!
exploreIt: characterStream 
	"Explore the selection -- invoked via cmd-shift-I.  If there is no current selection, use the current line."

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self exploreIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
implementorsOfIt: characterStream 
	"Triggered by Cmd-m; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	sensor keyboard.		"flush character"
	self implementorsOfIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
inOutdent: characterStream delta: delta
	"Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead.  Derived from work by Larry Tesler back in December 1985.  Now triggered by Cmd-L and Cmd-R.  2/29/96 sw"

	| cr tab realStart realStop lines startLine stopLine start stop adjustStart indentation size origSize numLines inStream newString outStream |
	sensor keyboard.  "Flush typeahead"
	cr _ Character cr.
	tab _ Character tab.

	"Operate on entire lines, but remember the real selection for re-highlighting later"
	realStart _ startBlock stringIndex.
	realStop _ stopBlock stringIndex - 1.

	"Special case a caret on a line of its own, including weird case at end of paragraph"
	(realStart > realStop and:
				[realStart < 2 or: [(paragraph string at: realStart - 1) == cr]])
		ifTrue:
			[delta < 0
				ifTrue:
					[view flash]
				ifFalse:
					[self replaceSelectionWith: Character tab asSymbol asText.
					self selectAt: realStart + 1].
			^true].

	lines _ paragraph lines.
	startLine _ paragraph lineIndexOfCharacterIndex: realStart.
	stopLine _ paragraph lineIndexOfCharacterIndex: (realStart max: realStop).
	start _ (lines at: startLine) first.
	stop _ (lines at: stopLine) last.
	
	"Pin the start of highlighting unless the selection starts a line"
	adjustStart _ realStart > start.

	"Find the indentation of the least-indented non-blank line; never outdent more"
	indentation _ (startLine to: stopLine) inject: 1000 into:
		[:m :l |
		m _ m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])].			

	size _ origSize _ stop + 1 - start.
	numLines _ stopLine + 1 - startLine.
	inStream _ ReadStream on: paragraph string from: start to: stop.

	newString _ String new: size + ((numLines * delta) max: 0).
	outStream _ ReadWriteStream on: newString.

	"This subroutine does the actual work"
	self indent: delta fromStream: inStream toStream: outStream.

	"Adjust the range that will be highlighted later"
	adjustStart ifTrue: [realStart _ (realStart + delta) max: start].
	realStop _ realStop + outStream position - size.

	"Prepare for another iteration"
	indentation _ indentation + delta.
	size _ outStream position.
	inStream _ outStream setFrom: 1 to: size.

	outStream == nil
		ifTrue: 	"tried to outdent but some line(s) were already left flush"
			[view flash]
		ifFalse:
			[self selectInvisiblyFrom: start to: stop.
			size = newString size ifFalse: [newString _ outStream contents].
			self replaceSelectionWith: newString asText].
	self selectFrom: realStart to: realStop. 	"highlight only the original range"
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
indent: characterStream
	"Add a tab at the front of every line occupied by the selection. Flushes typeahead.  Invoked from keyboard via cmd-shift-R.  2/29/96 sw"

	^ self inOutdent: characterStream delta: 1! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'!
inspectIt: characterStream 
	"Inspect the selection -- invoked via cmd-i.  If there is no current selection, use the current line.  1/17/96 sw
	 2/29/96 sw: don't call selectLine; it's done by inspectIt now"

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self inspectIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:06'!
makeCapitalized: characterStream 
	"Force the current selection to uppercase.  Triggered by Cmd-X."
	| prev |
	sensor keyboard.		"flush the triggering cmd-key character"
	prev _ $-.  "not a letter"
	self replaceSelectionWith: (Text fromString:
			(self selection string collect:
				[:c | prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:00'!
makeLowercase: characterStream 
	"Force the current selection to lowercase.  Triggered by Cmd-X."

	sensor keyboard.		"flush the triggering cmd-key character"
	self replaceSelectionWith: (Text fromString: (self selection string asLowercase)).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'RAA 10/19/2000 16:23'!
makeProjectLink: characterStream 
	""

	| attribute oldAttributes thisSel |
	
	sensor keyboard.
	oldAttributes _ paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle.
	thisSel _ self selection.

	attribute _ TextSqkProjectLink new. 
	thisSel _ attribute analyze: self selection asString.

	thisSel ifNil: [^ true].
	beginTypeInBlock ~~ nil
		ifTrue:  "only change emphasisHere while typing"
			[self insertTypeAhead: characterStream.
			emphasisHere _ Text addAttribute: attribute toArray: oldAttributes.
			^ true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:00'!
makeUppercase: characterStream 
	"Force the current selection to uppercase.  Triggered by Cmd-X."

	sensor keyboard.		"flush the triggering cmd-key character"
	self replaceSelectionWith: (Text fromString: (self selection string asUppercase)).
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 8/1/97 15:18'!
methodNamesContainingIt: characterStream 
	"Browse methods whose selectors containing the selection in their names"

	sensor keyboard.		"flush character"
	self methodNamesContainingIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 9/9/97 16:44'!
methodStringsContainingIt: characterStream 
	"Invoked from cmd-E -- open a browser on all methods holding string constants containing it.  Flushes typeahead. "

	sensor keyboard.	
	self methodStringsContainingit.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
noop: characterStream 
	"Unimplemented keyboard command; just ignore it."

	sensor keyboard.	  "flush character"
	^ true
! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 1/19/2000 11:14'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "

	| aList reply |
	aList _ paragraph textStyle fontNamesWithPointSizes.
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self replaceSelectionWith:
			(Text string: self selection asString 
				attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! !

!ParagraphEditor methodsFor: 'editing keys'!
offerFontMenu: characterStream 
	"The user typed the command key that requests a font change; Offer the font menu.  5/27/96 sw
	 Keeps typeahead.  (?? should flush?)"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self offerFontMenu.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
outdent: characterStream
	"Remove a tab from the front of every line occupied by the selection. Flushes typeahead.  Invoked from keyboard via cmd-shift-L.  2/29/96 sw"

	^ self inOutdent: characterStream delta: -1! !

!ParagraphEditor methodsFor: 'editing keys'!
paste: characterStream 
	"Replace the current text selection by the text in the shared buffer.
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self paste.
	^true! !

!ParagraphEditor methodsFor: 'editing keys'!
pasteInitials: characterStream 
	"Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor.
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self replace: self selectionInterval with: (Text fromString: Utilities changeStamp) and: [self selectAt: stopBlock stringIndex].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'!
printIt: characterStream 
	"Print the results of evaluting the selection -- invoked via cmd-p.  If there is no current selection, use the current line.  1/17/96 sw
	 2/29/96 sw: don't call selectLine now, since it's called by doIt"

	sensor keyboard.		"flush character"
	self terminateAndInitializeAround: [self printIt].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
recognizer: characterStream 
	"Invoke Alan's character recognizer from cmd-r 2/2/96 sw"

	sensor keyboard.
	self recognizeCharacters.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
referencesToIt: characterStream 
	"Triggered by Cmd-N; browse references to the current selection"

	sensor keyboard.		"flush character"
	self referencesToIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'!
save: characterStream
	"Submit the current text.  Equivalent to 'accept' 1/18/96 sw
	 Keeps typeahead."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self terminateAndInitializeAround: [self accept].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys'!
sendersOfIt: characterStream 
	"Triggered by Cmd-n; browse implementors of the selector represented by the current selection, if plausible. 2/1/96 sw"

	sensor keyboard.		"flush character"
	self sendersOfIt.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 12/7/1999 11:38'!
setEmphasis: emphasisSymbol
	"Change the emphasis of the current selection."

	| oldAttributes attribute |
	oldAttributes _ paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle.
	(emphasisSymbol == #plain) 
		ifTrue:
			[attribute _ TextEmphasis normal]
		ifFalse:
			[attribute _ TextEmphasis perform: emphasisSymbol.
			oldAttributes do:
				[:att | (att dominates: attribute) ifTrue: [attribute turnOff]]].
	self replaceSelectionWith: (self selection addAttribute: attribute)! !

!ParagraphEditor methodsFor: 'editing keys'!
shiftEnclose: characterStream
	"Insert or remove bracket characters around the current selection.
	 Flushes typeahead."

	| char left right startIndex stopIndex oldSelection which text |
	char _ sensor keyboard.
	char = $9 ifTrue: [ char _ $( ].
	char = $, ifTrue: [ char _ $< ].
	char = $[ ifTrue: [ char _ ${ ].
	char = $' ifTrue: [ char _ $" ].
	char asciiValue = 27 ifTrue: [ char _ ${ ].	"ctrl-["

	self closeTypeIn.
	startIndex _ startBlock stringIndex.
	stopIndex _ stopBlock stringIndex.
	oldSelection _ self selection.
	which _ '([<{"''' indexOf: char ifAbsent: [1].
	left _ '([<{"''' at: which.
	right _ ')]>}"''' at: which.
	text _ paragraph text.
	((startIndex > 1 and: [stopIndex <= text size])
		and:
		[(text at: startIndex-1) = left and: [(text at: stopIndex) = right]])
		ifTrue:
			["already enclosed; strip off brackets"
			self selectFrom: startIndex-1 to: stopIndex.
			self replaceSelectionWith: oldSelection]
		ifFalse:
			["not enclosed; enclose by matching brackets"
			self replaceSelectionWith:
				(Text string: (String with: left), oldSelection string ,(String with: right)
					emphasis: emphasisHere).
			self selectFrom: startIndex+1 to: stopIndex].
	^true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'!
spawnIt: characterStream
	"Triggered by Cmd-o; spawn a new code window, if it makes sense."

	sensor keyboard.
	self terminateAndInitializeAround: [self spawn].
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 1/18/96'!
swapChars: characterStream 
	"Triggered byCmd-Y;.  Swap two characters, either those straddling the insertion point, or the two that comprise the selection.  Suggested by Ted Kaehler.  "

	| currentSelection aString chars |
	sensor keyboard.		"flush the triggering cmd-key character"
	(chars _ self selection) size == 0
		ifTrue:
			[currentSelection _ startBlock stringIndex]
		ifFalse:
			[chars size == 2
				ifFalse:
					[view flash.  ^ true]
				ifTrue:
					[currentSelection _ startBlock stringIndex + 1]].

	self selectFrom: currentSelection - 1 to: currentSelection.
	aString _ self selection string.
	self replaceSelectionWith: (Text fromString: aString reversed).
	self selectAt: currentSelection + 1.
	^ true! !

!ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 11/2/1998 15:50'!
tempCommand: characterStream 
	"Experimental.  Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators."
	Sensor keyboard.
	self experimentalCommand.
	^ true

	"sensor keyboard.
	self spawnWorkspace.
	^ true"! !

!ParagraphEditor methodsFor: 'editing keys'!
undo: characterStream 
	"Undo the last edit.  Keeps typeahead, so undo twice is a full redo."

	sensor keyboard. 	"flush character"
	self closeTypeIn: characterStream.
	self undo.
	^true! !


!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:51'!
comment
	"All key actions that are neither editing nor typing actions have to
	send closeTypeIn at first. See comment in openTypeIn closeTypeIn"! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:31'!
cursorDown: characterStream 

"Private - Move cursor from position in current line to same position in
next line. If next line too short, put at end. If shift key down,
select."

	| shift string right left start position textSize|

	self closeTypeIn: characterStream.
	shift := sensor leftShiftDown.
	sensor keyboard.

	string _ paragraph text string.
	textSize _ string size.
	left _ right _ stopBlock stringIndex.
	[left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:
[left _ left - 1].
	position _ stopBlock stringIndex - left.

	[right < textSize and: [(string at: right) ~= Character cr]] whileTrue:
[right _ right + 1].
	right _ start _ right + 1.
	[right < textSize and: [(string at: right) ~= Character cr]] whileTrue:
[right _ right + 1].

	shift
		ifTrue: 
			[
			start + position > right
				ifTrue: [self selectFrom: startBlock stringIndex to: right - 1]
				ifFalse: [self selectFrom: startBlock stringIndex to: start +
position - 1]
			]
		ifFalse: 
			[
			start + position > right
				ifTrue: [self selectFrom: right to: right - 1]
				ifFalse: [self selectFrom: start + position to: start + position -
1]
			].

	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/22/2000 17:42'!
cursorEnd: characterStream 

"Private - Move cursor end of current line. If cursor already at end of
line, put cursor at end of text"

	| string right stringSize |

	self closeTypeIn: characterStream.
	sensor keyboard.

	string _ paragraph text string.
	stringSize _ string size.
	right _ stopBlock stringIndex.
	[right <= stringSize and: [(string at: right) ~= Character cr]]
		whileTrue: [right _ right + 1].

	sensor commandKeyPressed ifTrue: [right _ stringSize + 1].

	sensor leftShiftDown
		ifTrue: [self selectFrom: startBlock stringIndex to: right - 1]
		ifFalse: [self selectAt: right].

	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/22/2000 17:42'!
cursorHome: characterStream 

"Private - Move cursor from position in current line to beginning of
current line. If cursor already at beginning of line, put cursor at
beginning of text"

	| string left |

	self closeTypeIn: characterStream.
	sensor keyboard.

	string _ paragraph text string.
	left _ startBlock stringIndex.
	[left > 1 and: [(string at: (left - 1)) ~= Character cr]]
		whileTrue: [left _ left - 1].

	sensor commandKeyPressed ifTrue: [left _ 1].

	sensor leftShiftDown
		ifTrue: [self selectFrom: left to: stopBlock stringIndex - 1]
		ifFalse: [self selectAt: left].

	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:54'!
cursorLeft: characterStream 
	"Private - Move cursor left one character if nothing selected, otherwise 
	move cursor to beginning of selection. If the shift key is down, start 
	selecting or extending current selection. Don't allow cursor past 
	beginning of text"
	| shift left |
	self closeTypeIn: characterStream.
	shift _ sensor leftShiftDown.
	left _ startBlock stringIndex - 1.
	sensor controlKeyPressed ifTrue: [left _ self previousWord: left].
	sensor keyboard.
	shift
		ifTrue: [startBlock stringIndex > 1
			ifTrue: [self selectFrom: left to: stopBlock stringIndex - 1]]
		ifFalse: [(startBlock stringIndex == stopBlock stringIndex and: [startBlock stringIndex > 1])
			ifTrue: [self selectAt: left]
			ifFalse: [self selectAt: startBlock stringIndex]].
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sbw 10/12/1999 12:11'!
cursorPageDown: characterStream 

	^self cursorPageJump: characterStream down: true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
cursorPageJump: characterStream down: aBoolean
"Private - Move cursor from position in current line to same position in the line on the next page up or down (direction is controlled by <aBoolean>. If next line too short, put at end. If shift key down, select.  This method is similar to #cursorDown:.  Haven't figured out how to intercept the shift key yet.

See Utilities createPageTestWorkspace to create a test MVC workspace."

	| string right left start position textSize currentLineNumber howManyLines visibleHeight totalHeight ratio deltaLines targetLine offsetAtTargetLine |
	self closeTypeIn: characterStream.
	sensor keyboard.  "Eat the key stroke."
	string _ paragraph text string.
	textSize _ string size.
	left _ right _ stopBlock stringIndex.
	"Calculate the position of the left edge."
	[left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1].
	"Calculate the offset from the left edge where cursor is now."
	position _ stopBlock stringIndex - left.
	"Calculate the current line number."
	currentLineNumber _ paragraph lineIndexOfCharacterIndex: stopBlock stringIndex.
	howManyLines _ paragraph numberOfLines.
	visibleHeight _ self visibleHeight.
	totalHeight _ self totalTextHeight.
	ratio _ visibleHeight / totalHeight.
	deltaLines _ (ratio * howManyLines) rounded - 2.
	targetLine _ aBoolean
		ifTrue: [(currentLineNumber + deltaLines) min: howManyLines]
		ifFalse: [(currentLineNumber - deltaLines) max: 1].
	offsetAtTargetLine _ (paragraph lines at: targetLine) first.
	"Calculate the position of the right edge of text of target line."
	right _ offsetAtTargetLine.
	[right < textSize and: [(string at: right) ~= Character cr]] whileTrue: [right _ right + 1].
	start _ offsetAtTargetLine.
	start + position > right
			ifTrue: [self selectForTopFrom: right to: right - 1]
			ifFalse: [self selectForTopFrom: start + position to: start + position - 1].
	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sbw 10/12/1999 12:11'!
cursorPageUp: characterStream 

	^self cursorPageJump: characterStream down: false! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
cursorRight: characterStream 
	"Private - Move cursor right one character if nothing selected, 
	otherwise move cursor to end of selection. If the shift key is down, 
	start selecting characters or extending already selected characters. 
	Don't allow cursor past end of text"
	| shift right |
	self closeTypeIn: characterStream.
	shift _ sensor leftShiftDown.
	right _ stopBlock stringIndex + 1.
	sensor controlKeyPressed ifTrue: [right _ self nextWord: right].
	sensor keyboard.
	shift
		ifTrue: [self selectFrom: startBlock stringIndex to: right - 1]
		ifFalse: [startBlock stringIndex == stopBlock stringIndex
				ifTrue: [self selectAt: right]
				ifFalse: [self selectAt: stopBlock stringIndex]].
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
cursorUp: characterStream 

"Private - Move cursor from position in current line to same position in
prior line. If prior line too short, put at end"

	| shift string left position start |

	self closeTypeIn: characterStream.
	shift := sensor leftShiftDown.
	sensor keyboard.

	string _ paragraph text string.
	left _ startBlock stringIndex.
	[left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:
[left _ left - 1].
	position _ startBlock stringIndex - left.
	start _ left.

	left _ left - 1.
	[left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:
[left _ left - 1].

	left < 1 ifTrue: [left _ 1].
	start = 1 ifTrue: [position _ 0].
	shift
		ifTrue: 
			[
			(start - left < position and: [start > 1])
				ifTrue: [self selectFrom: start - 1 to: stopBlock stringIndex - 1]
				ifFalse: [self selectFrom: left + position to: stopBlock stringIndex
- 1]
			]
		ifFalse: 
			[
			(start - left < position and: [start > 1])
				ifTrue: [self selectFrom: start - 1 to: start - 2]
				ifFalse: [self selectFrom: left + position to: left + position - 1]
			].

	^true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
selectCurrentTypeIn: characterStream 
	"Select what would be replaced by an undo (e.g., the last typeIn)."

	| prior |

	self closeTypeIn: characterStream.
	prior _ otherInterval.
	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self selectInterval: UndoInterval.
	otherInterval _ prior.
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sma 12/15/1999 11:46'!
selectWord: characterStream
	sensor keyboard.
	self closeTypeIn: characterStream.
	self selectWord.
	^ true! !

!ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'!
setSearchString: characterStream
	"Establish the current selection as the current search string."

	| aString |
	self closeTypeIn: characterStream.
	sensor keyboard.
	self lineSelectAndEmptyCheck: [^ true].
	aString _  self selection string.
	aString size == 0
		ifTrue:
			[self flash]
		ifFalse:
			[self setSearch: aString].
	^ true! !


!ParagraphEditor methodsFor: 'typing/selecting keys'!
argAdvance: characterStream
	"Invoked by Ctrl-a.  Useful after Ctrl-q.
	 Search forward from the end of the selection for a colon followed by
		a space.  Place the caret after the space.  If none are found, place the
		caret at the end of the text.  Does not affect the undoability of the 
	 	previous command."

	| start |
	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	start _ paragraph text findString: ': ' startingAt: stopBlock stringIndex.
	start = 0 ifTrue: [start _ paragraph text size + 1].
	self selectAt: start + 2.
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
backWord: characterStream 
	"If the selection is not a caret, delete it and leave it in the backspace buffer.
	 Else if there is typeahead, delete it.
	 Else, delete the word before the caret."

	| startIndex |
	sensor keyboard.
	characterStream isEmpty
		ifTrue:
			[startBlock = stopBlock
				ifTrue: "a caret, delete at least one character"
					[startIndex _ 1 max: startBlock stringIndex - 1.
					[startIndex > 1 and:
						[(paragraph text at: startIndex - 1) asCharacter tokenish]]
						whileTrue:
							[startIndex _ startIndex - 1]]
				ifFalse: "a non-caret, just delete it"
					[startIndex _ startBlock stringIndex].
			self backTo: startIndex]
		ifFalse:
			[characterStream reset].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sma 2/12/2000 20:17'!
backspace: characterStream 
	"Backspace over the last character."

	| startIndex |
	sensor leftShiftDown ifTrue: [^ self backWord: characterStream].
	characterStream isEmpty
		ifTrue:
			[startIndex _ startBlock stringIndex +
				(startBlock = stopBlock ifTrue: [0] ifFalse: [1]).
			[sensor keyboardPressed and:
			 [sensor keyboardPeek asciiValue = 8]] whileTrue: [
				"process multiple backspaces"
				sensor keyboard.
				startIndex _ 1 max: startIndex - 1.
			].
			self backTo: startIndex]
		ifFalse:
			[sensor keyboard.
			characterStream skip: -1].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
changeStyle: characterStream 
	"Put up the style-change menu"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self changeStyle.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'hg 10/6/2000 18:51'!
crWithIndent: characterStream 
	"Replace the current text selection with CR followed by as many tabs
	as on the current line (+/- bracket count) -- initiated by Shift-Return."
	| char s i tabCount |
	sensor keyboard.		"flush character"
	s _ paragraph string.
	i _ stopBlock stringIndex.
	tabCount _ 0.
	[(i _ i-1) > 0 and: [(char _ s at: i) ~= Character cr]]
		whileTrue:  "Count tabs and brackets (but not a leading bracket)"
		[(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount _ tabCount + 1].
		char = $[ ifTrue: [tabCount _ tabCount + 1].
		char = $] ifTrue: [tabCount _ tabCount - 1]].
	characterStream crtab: tabCount.  "Now inject CR with tabCount tabs"
	^ false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
displayIfFalse: characterStream 
	"Replace the current text selection with the text 'ifFalse:'--initiated by 
	ctrl-f."

	sensor keyboard.		"flush character"
	characterStream nextPutAll: 'ifFalse:'.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
displayIfTrue: characterStream 
	"Replace the current text selection with the text 'ifTrue:'--initiated by 
	ctrl-t."

	sensor keyboard.		"flush character"
	characterStream nextPutAll: 'ifTrue:'.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
doAgainMany: characterStream 
	"Do the previous thing again repeatedly. 1/26/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self againOrSame: (UndoMessage sends: #undoAgain:andReselect:typedKey:) many: true.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
doAgainOnce: characterStream 
	"Do the previous thing again once. 1/26/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self again.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
find: characterStream
	"Prompt the user for what to find, then find it, searching from the current selection onward.  1/24/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self find.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
findAgain: characterStream 
	"Find the desired text again.  1/24/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self findAgain.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sma 12/15/1999 12:20'!
forwardDelete: characterStream
	"Delete forward over the next character.
	  Make Undo work on the whole type-in, not just the one char.
	wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered."
	| startIndex usel upara uinterval ind stopIndex |
	startIndex _ startBlock stringIndex.
	startIndex > paragraph text size ifTrue:
		[sensor keyboard.
		^ false].
	startIndex = stopBlock stringIndex ifFalse:
		["there was a selection"
		sensor keyboard.
		self zapSelectionWith: self nullText.
		^ false].
	"Null selection - do the delete forward"
	beginTypeInBlock == nil	"no previous typing.  openTypeIn"
		ifTrue: [self openTypeIn. UndoSelection _ self nullText].
	uinterval _ UndoInterval deepCopy.
	"umes _ UndoMessage deepCopy.	Set already by openTypeIn"
	"usel _ UndoSelection deepCopy."
	upara _ UndoParagraph deepCopy.
	stopIndex := startIndex.
	(sensor keyboard asciiValue = 127 and: [sensor leftShiftDown])
		ifTrue: [stopIndex := (self nextWord: stopIndex) - 1].
	self selectFrom: startIndex to: stopIndex.
	self replaceSelectionWith: self nullText.
	self selectFrom: startIndex to: startIndex-1.
	UndoParagraph _ upara.  UndoInterval _ uinterval.
	UndoMessage selector == #noUndoer ifTrue: [
		(UndoSelection isText) ifTrue: [
			usel _ UndoSelection.
			ind _ startIndex. "UndoInterval startIndex"
			usel replaceFrom: usel size + 1 to: usel size with:
				(UndoParagraph text copyFrom: ind to: ind).
			UndoParagraph text replaceFrom: ind to: ind with:
self nullText]].
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
normalCharacter: characterStream 
	"A nonspecial character is to be added to the stream of characters."

	characterStream nextPut: sensor keyboard.
	^false! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
querySymbol: characterStream
	"Invoked by Ctrl-q to query the Symbol table and display alternate symbols.
	 See comment in completeSymbol:lastOffering: for details."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.	"keep typeahead"
	startBlock = stopBlock
		ifTrue: "Ctrl-q typed when a caret"
			[self perform: #completeSymbol:lastOffering: withArguments:
				((UndoParagraph == paragraph and: [UndoMessage sends: #undoQuery:lastOffering:])
					ifTrue: [UndoMessage arguments] "repeated Ctrl-q"
					ifFalse: [Array with: nil with: nil])] "initial Ctrl-q"
		ifFalse: "Ctrl-q typed when statements were highlighted"
			[view flash].
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
search: characterStream
	"Invoked by Ctrl-S.  Same as 'again', but always uses the existing FindText
	 and ChangeText regardless of the last edit."

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self againOrSame: true. "true means use same keys"
	^true! !

!ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sw 8/29/2000 14:58'!
selectAll
	"Make the selection be all the characters of the receiver"

	self selectFrom: 1 to: paragraph text string size! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
selectAll: characterStream 
	"select everything, invoked by cmd-a.  1/17/96 sw"

	sensor keyboard.		"flush character"
	self closeTypeIn: characterStream.
	self selectFrom: 1 to: paragraph text string size.
	^ true! !

!ParagraphEditor methodsFor: 'typing/selecting keys'!
simulatedBackspace
	"Backspace over the last character, derived from hand-char recognition.  2/5/96 sw"

	| startIndex |
	startIndex _ startBlock stringIndex + (startBlock = stopBlock ifTrue: [0] ifFalse: [1]).

	startIndex _ 1 max: startIndex - 1.
	self backTo: startIndex.
	^ false! !


!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:43'!
backTo: startIndex
	"During typing, backspace to startIndex.  Deleted characters fall into three
	 clusters, from left to right in the text: (1) preexisting characters that were
	 backed over; (2) newly typed characters that were backed over (excluding
	 typeahead, which never even appears); (3) preexisting characters that
	 were highlighted before typing began.  If typing has not yet been opened,
	 open it and watch for the first and third cluster.  If typing has been opened,
	 watch for the first and second cluster.  Save characters from the first and third
	 cluster in UndoSelection.  Tally characters from the first cluster in UndoMessage's parameter.
	 Delete all the clusters.  Do not alter Undoer or UndoInterval (except via
	 openTypeIn).  The code is shorter than the comment."

	| saveLimit newBackovers |
	saveLimit _ beginTypeInBlock == nil
		ifTrue: [self openTypeIn. UndoSelection _ self nullText. stopBlock stringIndex]
		ifFalse: [self startOfTyping].
	startBlock _ paragraph characterBlockForIndex: startIndex.
	startIndex < saveLimit ifTrue:
		[newBackovers _ self startOfTyping - startIndex.
		beginTypeInBlock _ startBlock stringIndex.
		UndoSelection replaceFrom: 1 to: 0 with:
			(paragraph text copyFrom: startIndex to: saveLimit - 1).
		UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers].
	self zapSelectionWith: self nullText.
	startBlock _ stopBlock copy! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:31'!
closeTypeIn
	"See comment in openTypeIn.  It is important to call closeTypeIn before executing
	 any non-typing key, making a new selection, etc.  It is called automatically for
	 menu commands.
	 Typing commands can call 'closeTypeIn: aCharacterStream' instead of this to
	 save typeahead.  Undoer & Redoer: undoAndReselect:redoAndReselect:."

	| begin start stop |
	beginTypeInBlock == nil ifFalse:
		[(UndoMessage sends: #noUndoer) ifTrue: "should always be true, but just in case..."
			[begin _ self startOfTyping.
			start _ startBlock stringIndex.
			stop _ stopBlock stringIndex.
			self undoer: #undoAndReselect:redoAndReselect:
				with: (begin + UndoMessage argument to: begin + UndoSelection size - 1)
				with: (stop to: stop - 1).
			UndoInterval _ begin to: stop - 1].
		beginTypeInBlock _ nil]! !

!ParagraphEditor methodsFor: 'typing support'!
closeTypeIn: characterStream
	"Call instead of closeTypeIn when you want typeahead to be inserted before the
	 control character is executed, e.g., from Ctrl-V."

	self insertTypeAhead: characterStream.
	self closeTypeIn! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'sma 12/15/1999 13:21'!
dispatchOnCharacter: char with: typeAheadStream
	"Carry out the action associated with this character, if any.
	Type-ahead is passed so some routines can flush or use it."

	| honorCommandKeys |
	((honorCommandKeys _ Preferences cmdKeysInText) and: [char = Character enter])
		ifTrue: [^ self dispatchOnEnterWith: typeAheadStream].

	"Special keys overwrite crtl+key combinations - at least on Windows. To resolve this
	conflict, assume that keys other than cursor keys aren't used together with Crtl." 
	((self class specialShiftCmdKeys includes: char asciiValue) and: [char asciiValue < 27])
		ifTrue: [^ sensor controlKeyPressed
			ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]
			ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]].

	"backspace, and escape keys (ascii 8 and 27) are command keys"
	((honorCommandKeys and: [sensor commandKeyPressed]) or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue:
		[^ sensor leftShiftDown
			ifTrue:
				[self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]
			ifFalse:
				[self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]].

	"the control key can be used to invoke shift-cmd shortcuts"
	(honorCommandKeys and: [sensor controlKeyPressed])
		ifTrue:
			[^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream].

	^ self perform: #normalCharacter: with: typeAheadStream! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 9/7/1999 11:26'!
dispatchOnEnterWith: typeAheadStream
	"Enter key hit.  Treat is as an 'accept', viz a synonym for cmd-s.  If cmd key is down, treat is as a synonym for print-it. "

	sensor keyboard.  "consume enter key"
	self terminateAndInitializeAround: [
	sensor commandKeyPressed
		ifTrue:
			[self printIt.]
		ifFalse: 
			[self closeTypeIn: typeAheadStream.
			self accept].
	].
	^ true! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'!
doneTyping
	beginTypeInBlock _ nil! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'sma 4/22/2000 17:21'!
insertTypeAhead: typeAhead
	typeAhead position = 0 ifFalse:
		[self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere).
		typeAhead reset.
		startBlock _ stopBlock copy]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:39'!
openTypeIn
	"Set up UndoSelection to null text (to be added to by readKeyboard and backTo:),
	 beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally
	 how many deleted characters were backspaced over rather than 'cut'.
	 You can't undo typing until after closeTypeIn."

	beginTypeInBlock == nil ifTrue:
		[UndoSelection _ self nullText.
		self undoer: #noUndoer with: 0.
		beginTypeInBlock _ startBlock stringIndex]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'!
readKeyboard
	"Key struck on the keyboard. Find out which one and, if special, carry 
	out the associated special action. Otherwise, add the character to the 
	stream of characters.  Undoer & Redoer: see closeTypeIn."

	| typeAhead char |
	typeAhead _ WriteStream on: (String new: 128).
	[sensor keyboardPressed] whileTrue: 
		[self deselect.
		 [sensor keyboardPressed] whileTrue: 
			[char _ sensor keyboardPeek.
			(self dispatchOnCharacter: char with: typeAhead) ifTrue:
				[self doneTyping.
				^self selectAndScroll; updateMarker].
			self openTypeIn].
		startBlock = stopBlock ifFalse: "save highlighted characters"
			[UndoSelection _ self selection]. 
		self zapSelectionWith: 
			(Text string: typeAhead contents emphasis: emphasisHere).
		typeAhead reset.
		startBlock _ stopBlock copy.
		sensor keyboardPressed ifFalse: 
			[self selectAndScroll.
			sensor keyboardPressed
				ifFalse: [self updateMarker]]]! !

!ParagraphEditor methodsFor: 'typing support'!
recognizeCharacters
	"Recognize hand-written characters and put them into the receiving pane.  Invokes Alan's character recognizer.  2/5/96 sw"

	self recognizeCharactersWhileMouseIn: view insetDisplayBox! !

!ParagraphEditor methodsFor: 'typing support'!
recognizeCharactersWhileMouseIn: box
	"Recognize hand-written characters and put them into the receiving pane.  Invokes Alan's character recognizer.  2/5/96 sw"

	| aRecognizer |
	Cursor marker showWhile:
		[aRecognizer _ CharRecog new.
		aRecognizer recognizeAndDispatch:
			[:char | char == BS
				ifTrue:
					[self simulatedBackspace]
				ifFalse:
					[self simulatedKeystroke: char]]
		until:
			[(box containsPoint: sensor cursorPoint) not]].
	view display! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'sw 12/7/1999 11:39'!
setEmphasisHere

	emphasisHere _ (paragraph text attributesAt: (startBlock stringIndex-1 max: 1) forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'sw 12/16/1998 13:14'!
simulatedKeystroke: char
	"Accept char as if it were struck on the keyboard.  This version does not yet deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits."

	self deselect.
	self openTypeIn.
	startBlock = stopBlock ifFalse: [UndoSelection _ self selection].
	self zapSelectionWith:
		(Text string: char asString emphasis: emphasisHere).
	self userHasEdited.
	startBlock _ stopBlock copy.
	self selectAndScroll.
	self updateMarker.
	view ifNotNil:
		[view topView uncacheBits
		"in mvc, this makes sure the recognized character shows up in the pane right now; in morphic, a different mechanism is used for the same effect -- see TextMorphEditor method #recognizeCharactersWhileMouseIn:"]
! !

!ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:45'!
startOfTyping
	"Compatibility during change from characterBlock to integer"
	beginTypeInBlock == nil ifTrue: [^ nil].
	beginTypeInBlock isNumber ifTrue: [^ beginTypeInBlock].
	"Last line for compatibility during change from CharacterBlock to Integer."
	^ beginTypeInBlock stringIndex
	! !


!ParagraphEditor methodsFor: 'undoers'!
undoAgain: indices andReselect: home typedKey: wasTypedKey
	"The last command was again.  Undo it. Redoer: itself."

	| findSize substText index subject |
	(self isRedoing & wasTypedKey) ifTrue: "redelete search key"
		[self selectInterval: home.
		self zapSelectionWith: self nullText].

	findSize _ (self isRedoing ifTrue: [FindText] ifFalse: [ChangeText]) size.
	substText _ self isUndoing ifTrue: [FindText] ifFalse: [ChangeText].
	(self isUndoing ifTrue: [indices size to: 1 by: -1] ifFalse: [1 to: indices size]) do:
		[:i |
		index _ indices at: i.
		(subject _ index to: index + findSize - 1) = self selectionInterval ifFalse:
			[self selectInterval: subject].
		FindText == ChangeText ifFalse: [self zapSelectionWith: substText]].

	self isUndoing
		ifTrue:  "restore selection to where it was when 'again' was invoked"
			[wasTypedKey
				ifTrue: "search started by typing key at a caret; restore it"
					[self selectAt: home first.
					self zapSelectionWith: FindText.
					self selectAt: home last + 1]
				ifFalse: [self selectInterval: home]].

	self undoMessage: UndoMessage forRedo: self isUndoing! !

!ParagraphEditor methodsFor: 'undoers'!
undoAndReselect: undoHighlight redoAndReselect: redoHighlight
	"Undo typing, cancel, paste, and other operations that are like replaces
	 but the selection is not the whole restored text after undo, redo, or both.
	 undoHighlight is selected after this phase and redoHighlight after the next phase.
	Redoer: itself."

	self replace: self selectionInterval with: UndoSelection and:
		[self selectInterval: undoHighlight].
	self undoMessage: (UndoMessage argument: redoHighlight) forRedo: self isUndoing
! !

!ParagraphEditor methodsFor: 'undoers'!
undoCutCopy: oldPasteBuffer
	"Undo of a cut, copy, or any edit that changed CurrentSelection.  Be sure
	 undo-copy does not lock the model.  Redoer: itself, so never isRedoing."

	| recentCut |
	recentCut _ self clipboardText.	
	UndoSelection size = UndoInterval size
		ifFalse: [self replaceSelectionWith: UndoSelection].
	self clipboardTextPut: oldPasteBuffer.
	self undoer: #undoCutCopy: with: recentCut! !

!ParagraphEditor methodsFor: 'undoers'!
undoQuery: hintText lastOffering: selectorOrNil
	"Undo ctrl-q.  selectorOrNil (if not nil) is the previously offered selector.
	 hintText is the original hint.  Redoer: completeSymbol."

	self zapSelectionWith: UndoSelection.
	self undoMessage: (Message selector: #completeSymbol:lastOffering: arguments: UndoMessage arguments) forRedo: true.
	self selectAt: stopBlock stringIndex! !

!ParagraphEditor methodsFor: 'undoers'!
undoReplace
	"Undo of any command that replaced a selection by other text that it left
	 highlighted, and that is undone and redone by simple reversal of the
	 operation.  This is the most common Undoer; call replaceSelectionWith:
	 to get this setup.  Redoer: itself, so never isRedoing."

	self replaceSelectionWith: UndoSelection! !


!ParagraphEditor methodsFor: 'undo support'!
isDoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^(self isUndoing | self isRedoing) not! !

!ParagraphEditor methodsFor: 'undo support'!
isRedoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^UndoParagraph == #redoing! !

!ParagraphEditor methodsFor: 'undo support'!
isUndoing
	"Call from a doer/undoer/redoer any time to see which it is."

	^UndoParagraph == #undoing! !

!ParagraphEditor methodsFor: 'undo support'!
noUndoer
	"The Undoer to use when the command can not be undone.  Checked for
	 specially by readKeyboard."

	UndoMessage _ Message selector: #noUndoer! !

!ParagraphEditor methodsFor: 'undo support'!
undoMessage: aMessage forRedo: aBoolean
	"Call this from an undoer/redoer to set up UndoMessage as the
	 corresponding redoer/undoer.  Also set up UndoParagraph, as well
	 as the state variable Undone.  It is assumed that UndoInterval has been
	 established (generally by zapSelectionWith:) and that UndoSelection has been
	 saved (generally by replaceSelectionWith: or replace:With:and:)."

	self isDoing ifTrue: [UndoParagraph _ paragraph].
	UndoMessage _ aMessage.
	Undone _ aBoolean! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector
	"See comment in undoMessage:.  Use this version when aSelector has no arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1
	"See comment in undoMessage:.  Use this version when aSelector has one argument, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector argument: arg1) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1 with: arg2
	"See comment in undoMessage:.  Use this version when aSelector has two arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2)) forRedo: false! !

!ParagraphEditor methodsFor: 'undo support'!
undoer: aSelector with: arg1 with: arg2 with: arg3
	"See comment in undoMessage:.  Use this version when aSelector has three arguments, and you are doing or redoing and want to prepare for undoing."

	self undoMessage: (Message selector: aSelector arguments: (Array with: arg1 with: arg2 with: arg3)) forRedo: false! !


!ParagraphEditor methodsFor: 'current selection'!
deselect
	"If the text selection is visible on the screen, reverse its highlight."

	selectionShowing ifTrue: [self reverseSelection]! !

!ParagraphEditor methodsFor: 'current selection'!
initializeSelection
	"Do the initial activity when starting up the receiver. For example, in the 
	ParagraphEditor highlight the current selection."

	self select! !

!ParagraphEditor methodsFor: 'current selection'!
recomputeInterval
	"The same characters are selected but their coordinates may have changed."

	self computeIntervalFrom: startBlock stringIndex to: stopBlock stringIndex - 1! !

!ParagraphEditor methodsFor: 'current selection'!
recomputeSelection
	"Redetermine the selection according to the start and stop block indices; 
	do not highlight."

	self deselect; recomputeInterval! !

!ParagraphEditor methodsFor: 'current selection'!
reverseSelection
	"Reverse the valence of the current selection highlighting."
	selectionShowing _ selectionShowing not.
	paragraph reverseFrom: startBlock to: stopBlock! !

!ParagraphEditor methodsFor: 'current selection'!
select
	"If the text selection is visible on the screen, highlight it."

	selectionShowing ifFalse: [self reverseSelection]! !

!ParagraphEditor methodsFor: 'current selection'!
selectAndScroll
	"Scroll until the selection is in the view and then highlight it."
	| lineHeight deltaY clippingRectangle |
	self select.
	lineHeight _ paragraph textStyle lineGrid.
	clippingRectangle _ paragraph clippingRectangle.
	deltaY _ stopBlock top - clippingRectangle top.
	deltaY >= 0 
		ifTrue: [deltaY _ stopBlock bottom - clippingRectangle bottom max: 0].
						"check if stopIndex below bottom of clippingRectangle"
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight)
									* deltaY sign]! !

!ParagraphEditor methodsFor: 'current selection' stamp: 'sbw 10/12/1999 16:51'!
selectAndScrollToTop
	"Scroll until the selection is in the view and then highlight it."
	| lineHeight deltaY clippingRectangle |
	self select.
	lineHeight _ paragraph textStyle lineGrid.
	clippingRectangle _ paragraph clippingRectangle.
	deltaY _ stopBlock top - clippingRectangle top.
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight)
									* deltaY sign]! !


!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/10/1998 22:00'!
afterSelectionInsertAndSelect: aString

	self insertAndSelect: aString at: stopBlock stringIndex ! !

!ParagraphEditor methodsFor: 'new selection'!
computeIntervalFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	startBlock _ paragraph characterBlockForIndex: start.
	stopBlock _ start > stop
		ifTrue: [startBlock copy]
		ifFalse: [paragraph characterBlockForIndex: stop + 1]! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:21'!
correctFrom: start to: stop with: aString
	"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier).  The user's selection is not changed, only corrected."
	| wasShowing userSelection delta loc |
	aString = '#insert period' ifTrue:
		[loc _ start.
		[(loc _ loc-1)>0 and: [(paragraph text string at: loc) isSeparator]]
			whileTrue: [loc _ loc-1].
		^ self correctFrom: loc+1 to: loc with: '.'].
	(wasShowing _ selectionShowing) ifTrue: [ self reverseSelection ].
	userSelection _ self selectionInterval.

	self selectInvisiblyFrom: start to: stop.
	self replaceSelectionWith: aString asText.

	delta _ aString size - (stop - start + 1).
	self selectInvisiblyFrom:
		userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
		to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
	wasShowing ifTrue: [ self reverseSelection ].
! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 12/17/1998 09:41'!
insertAndSelect: aString at: anInteger

	self replace: (anInteger to: anInteger - 1)
		with: (Text string: (' ' , aString)
					attributes: emphasisHere)
		and: [self selectAndScroll]! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/6/1998 15:25'!
nextTokenFrom: start direction: dir
	"simple token-finder for compiler automated corrections"
	| loc str |
	loc _ start + dir.
	str _ paragraph text string.
	[(loc between: 1 and: str size) and: [(str at: loc) isSeparator]]
		whileTrue: [loc _ loc + dir].
	^ loc! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/20/1998 08:31'!
notify: aString at: anInteger in: aStream 
	"The compilation of text failed. The syntax error is noted as the argument, 
	aString. Insert it in the text at starting character position anInteger."

	self insertAndSelect: aString at: (anInteger max: 1)! !

!ParagraphEditor methodsFor: 'new selection'!
selectAt: characterIndex 
	"Deselect, then place the caret before the character at characterIndex.
	 Be sure it is in view."

	self selectFrom: characterIndex to: characterIndex - 1! !

!ParagraphEditor methodsFor: 'new selection'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse:
		[self deselect.
		self selectInvisiblyFrom: start to: stop].
	self selectAndScroll! !

!ParagraphEditor methodsFor: 'new selection'!
selectInterval: anInterval
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	self selectFrom: anInterval first to: anInterval last! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/9/1998 20:59'!
selectInvisiblyFrom: start to: stop
	"Select the designated characters, inclusive.  Make no visual changes."

	^ self computeIntervalFrom: start to: stop! !

!ParagraphEditor methodsFor: 'new selection' stamp: 'di 5/10/1998 21:01'!
selectLine
	"Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
	| string left right |
	string _ paragraph text string.
	left _ startBlock stringIndex.
	right _ stopBlock stringIndex - 1.
	left > right ifFalse: [^ self].

	[left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue:
		[left _ left - 1].
	[right < string size and: [(string at: (right + 1)) ~= Character cr]] whileTrue:
		[right _ right + 1].
	self selectFrom: left to: (right min: string size)! !

!ParagraphEditor methodsFor: 'new selection'!
selectPrecedingIdentifier
	"Invisibly select the identifier that ends at the end of the selection, if any."

	| string sep stop tok |
	tok _ false.
	string _ paragraph text string.
	stop _ stopBlock stringIndex - 1.
	[stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop _ stop - 1].
	sep _ stop.
	[sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok _ true. sep _ sep - 1].
	tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]! !

!ParagraphEditor methodsFor: 'new selection'!
selectWord
	"Select delimited text or word--the result of double-clicking."

	| openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters
	string here hereChar start stop |
	string _ paragraph text string.
	here _ startBlock stringIndex.
	(here between: 2 and: string size)
		ifFalse: ["if at beginning or end, select entire string"
			^self selectFrom: 1 to: string size].
	leftDelimiters _ '([{<''"
'.
	rightDelimiters _ ')]}>''"
'.
	openDelimiter _ string at: here - 1.
	match _ leftDelimiters indexOf: openDelimiter.
	match > 0
		ifTrue: 
			["delimiter is on left -- match to the right"
			start _ here.
			direction _ 1.
			here _ here - 1.
			closeDelimiter _ rightDelimiters at: match]
		ifFalse: 
			[openDelimiter _ string at: here.
			match _ rightDelimiters indexOf: openDelimiter.
			match > 0
				ifTrue: 
					["delimiter is on right -- match to the left"
					stop _ here - 1.
					direction _ -1.
					closeDelimiter _ leftDelimiters at: match]
				ifFalse: ["no delimiters -- select a token"
					direction _ -1]].
	level _ 1.
	[level > 0 and: [direction > 0
			ifTrue: [here < string size]
			ifFalse: [here > 1]]]
		whileTrue: 
			[hereChar _ string at: (here _ here + direction).
			match = 0
				ifTrue: ["token scan goes left, then right"
					hereChar tokenish
						ifTrue: [here = 1
								ifTrue: 
									[start _ 1.
									"go right if hit string start"
									direction _ 1]]
						ifFalse: [direction < 0
								ifTrue: 
									[start _ here + 1.
									"go right if hit non-token"
									direction _ 1]
								ifFalse: [level _ 0]]]
				ifFalse: ["bracket match just counts nesting level"
					hereChar = closeDelimiter
						ifTrue: [level _ level - 1"leaving nest"]
						ifFalse: [hereChar = openDelimiter 
									ifTrue: [level _ level + 1"entering deeper nest"]]]].

	level > 0 ifTrue: ["in case ran off string end"	here _ here + direction].
	direction > 0
		ifTrue: [self selectFrom: start to: here - 1]
		ifFalse: [self selectFrom: here + 1 to: stop]! !


!ParagraphEditor methodsFor: 'private' stamp: 'sw 9/24/1999 15:41'!
againOnce: indices
	"Find the next occurrence of FindText.  If none, answer false.
	Append the start index of the occurrence to the stream indices, and, if
	ChangeText is not the same object as FindText, replace the occurrence by it.
	Note that the search is case-sensitive for replacements, otherwise not."

	| where |
	where _ paragraph text findString: FindText startingAt: stopBlock stringIndex
				caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]).
	where = 0 ifTrue: [^ false].
	self deselect; selectInvisiblyFrom: where to: where + FindText size - 1.
	ChangeText ~~ FindText ifTrue: [self zapSelectionWith: ChangeText].
	indices nextPut: where.
	self selectAndScroll.
	^ true! !

!ParagraphEditor methodsFor: 'private'!
againOrSame: useOldKeys
	"Subroutine of search: and again.  If useOldKeys, use same FindText and ChangeText as before.
	 1/26/96 sw: real worked moved to againOrSame:many:"

	^ self againOrSame: useOldKeys many: sensor leftShiftDown! !

!ParagraphEditor methodsFor: 'private'!
againOrSame: useOldKeys many: many
	"Subroutine of search: and again.  If useOldKeys, use same FindText and ChangeText as before.  If many is true, do it repeatedly.  Created 1/26/96 sw by adding the many argument to #againOrSame."

	|  home indices wasTypedKey |

	home _ self selectionInterval.  "what was selected when 'again' was invoked"

	"If new keys are to be picked..."
	useOldKeys ifFalse: "Choose as FindText..."
		[FindText _ UndoSelection.  "... the last thing replaced."
		"If the last command was in another paragraph, ChangeText is set..."
		paragraph == UndoParagraph ifTrue: "... else set it now as follows."
			[UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink"
			ChangeText _ ((UndoMessage sends: #undoCutCopy:) and: [startBlock ~= stopBlock])
				ifTrue: [FindText] "== objects signal no model-locking by 'undo copy'"
				ifFalse: [self selection]]]. "otherwise, change text is last-replaced text"

	(wasTypedKey _ FindText size = 0)
		ifTrue: "just inserted at a caret"
			[home _ self selectionInterval.
			self replaceSelectionWith: self nullText.  "delete search key..."
			FindText _ ChangeText] "... and search for it, without replacing"
		ifFalse: "Show where the search will start"
			[home last = self selectionInterval last ifFalse:
				[self selectInterval: home]].

	"Find and Change, recording start indices in the array"
	indices _ WriteStream on: (Array new: 20). "an array to store change locs"
	[(self againOnce: indices) & many] whileTrue. "<-- this does the work"
	indices isEmpty ifTrue:  "none found"
		[self flash.
		wasTypedKey ifFalse: [^self]].

	(many | wasTypedKey) ifFalse: "after undo, select this replacement"
		[home _ startBlock stringIndex to:
			startBlock stringIndex + UndoSelection size - 1].

	self undoer: #undoAgain:andReselect:typedKey: with: indices contents with: home with: wasTypedKey! !

!ParagraphEditor methodsFor: 'private'!
completeSymbol: hintText lastOffering: selectorOrNil
	"Invoked by Ctrl-q when there is only a caret.
		Do selector-completion, i.e., try to replace the preceding identifier by a
		selector that begins with those characters & has as many keywords as possible.
	 	Leave two spaces after each colon (only one after the last) as space for
		arguments.  Put the caret after the space after the first keyword.  If the
		user types Ctrl-q again immediately, choose a different selector.
	 Undoer: #undoQuery:lastOffering:; Redoer: itself.
	If redoing, just redisplay the last offering, selector[OrNil]."

	| firstTime input prior caret newStart sym kwds blockNode outStream |
	firstTime _ self isRedoing
		ifTrue: [prior _ sym _ selectorOrNil. true]
		ifFalse: [hintText isNil].
	firstTime
		ifTrue: "Initial Ctrl-q (or redo)"					
			[caret _ startBlock stringIndex.
			self selectPrecedingIdentifier.
			input _ self selection]
		ifFalse: "Repeated Ctrl-q"
			[caret _ UndoInterval first + hintText size.
			self selectInvisiblyFrom: UndoInterval first to: UndoInterval last.
			input _ hintText.
			prior _ selectorOrNil].
	(input size ~= 0 and: [sym ~~ nil or:
			[(sym _ Symbol thatStarts: input string skipping: prior) ~~ nil]])
		ifTrue: "found something to offer"
			[newStart _ startBlock stringIndex.
			outStream _ WriteStream on: (String new: 2 * sym size).
			1 to: (kwds _ sym keywords) size do:
				[:i |
				outStream nextPutAll: (kwds at: i).
				i = 1 ifTrue: [caret _ newStart + outStream contents size + 1].
				outStream nextPutAll:
					(i < kwds size ifTrue: ['  '] ifFalse: [' '])].
			UndoSelection _ input.
			self deselect; zapSelectionWith: outStream contents asText.
			self undoer: #undoQuery:lastOffering: with: input with: sym]
		ifFalse: "no more matches"
			[firstTime ifFalse: "restore original text & set up for a redo"
				[UndoSelection _ self selection.
				self deselect; zapSelectionWith: input.
				self undoer: #completeSymbol:lastOffering: with: input with: prior.
				Undone _ true].
			view flash].
	self selectAt: caret! !

!ParagraphEditor methodsFor: 'private'!
exchangeWith: prior
	"If the prior selection is non-overlapping and legal, exchange the text of
	 it with the current selection and leave the currently selected text selected
	 in the location of the prior selection (or leave a caret after a non-caret if it was
	 exchanged with a caret).  If both selections are carets, flash & do nothing.
	 Don't affect the paste buffer.  Undoer: itself; Redoer: Undoer."

	| start stop before selection priorSelection delta altInterval |
	start _ startBlock stringIndex.
	stop _ stopBlock stringIndex - 1.
	((prior first <= prior last) | (start <= stop) "Something to exchange" and:
			[self isDisjointFrom: prior])
		ifTrue:
			[before _ prior last < start.
			selection _ self selection.
			priorSelection _ paragraph text copyFrom: prior first to: prior last.

			delta _ before ifTrue: [0] ifFalse: [priorSelection size - selection size].
			self zapSelectionWith: priorSelection.
			self selectFrom: prior first + delta to: prior last + delta.

			delta _ before ifTrue: [stop - prior last] ifFalse: [start - prior first].
			self zapSelectionWith: selection.
			altInterval _ prior first + delta to: prior last + delta.
			self undoer: #exchangeWith: with: altInterval.
			"If one was a caret, make it otherInterval & leave the caret after the other"
			prior first > prior last ifTrue: [self selectAt: UndoInterval last + 1].
			otherInterval _ start > stop
				ifTrue: [self selectAt: altInterval last + 1. UndoInterval]
				ifFalse: [altInterval]]
		ifFalse:
			[view flash]! !

!ParagraphEditor methodsFor: 'private' stamp: 'tk 7/14/2000 12:15'!
getPluggableYellowButtonMenu: shiftKeyState
	| customMenu |
	^ ((view ~~ nil) and: [(customMenu _ view getMenu: shiftKeyState) notNil])
		ifTrue: [customMenu]
		ifFalse:
			[shiftKeyState
				ifTrue: [self class shiftedYellowButtonMenu]
				ifFalse: [self class yellowButtonMenu]]! !

!ParagraphEditor methodsFor: 'private'!
indent: delta fromStream: inStream toStream: outStream
	"Append the contents of inStream to outStream, adding or deleting delta or -delta
	 tabs at the beginning, and after every CR except a final CR.  Do not add tabs
	 to totally empty lines, and be sure nothing but tabs are removed from lines."

	| ch skip cr tab prev atEnd |
	cr _ Character cr.
	tab _ Character tab.
	delta > 0
		ifTrue: "shift right"
			[prev _ cr.
			 [ch _ (atEnd _ inStream atEnd) ifTrue: [cr] ifFalse: [inStream next].
			  (prev == cr and: [ch ~~ cr]) ifTrue:
				[delta timesRepeat: [outStream nextPut: tab]].
			  atEnd]
				whileFalse:
					[outStream nextPut: ch.
					prev _ ch]]
		ifFalse: "shift left"
			[skip _ delta. "a negative number"
			 [inStream atEnd] whileFalse:
				[((ch _ inStream next) == tab and: [skip < 0]) ifFalse:
					[outStream nextPut: ch].
				skip _ ch == cr ifTrue: [delta] ifFalse: [skip + 1]]]! !

!ParagraphEditor methodsFor: 'private'!
isDisjointFrom: anInterval
	"Answer true if anInterval is a caret not touching or within the current
	 interval, or if anInterval is a non-caret that does not overlap the current
	 selection."

	| fudge |
	fudge _ anInterval size = 0 ifTrue: [1] ifFalse: [0].
	^(anInterval last + fudge < startBlock stringIndex or:
			[anInterval first - fudge >= stopBlock stringIndex])
! !

!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:32'!
nextWord: position
	| string index |
	string _ paragraph text string.
	index _ position.
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
		whileTrue: [index _ index + 1].
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
		whileTrue: [index _ index + 1].
	^ index! !

!ParagraphEditor methodsFor: 'private'!
nullText

	^Text string: '' emphasis: emphasisHere! !

!ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:33'!
previousWord: position
	| string index |
	string _ paragraph text string.
	index _ position.
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]]
		whileTrue: [index _ index - 1].
	[(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]]
		whileTrue: [index _ index - 1].
	^ index + 1! !


!ParagraphEditor methodsFor: 'do-its' stamp: 'di 5/10/1998 21:38'!
doIt
	"Set the context to include pool vars of the model.  Then evaluate."
	^ self evaluateSelection.
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'sw 12/24/1998 12:42'!
evaluateSelection
	"Treat the current selection as an expression; evaluate it and return the result"
	| result rcvr ctxt |
	self lineSelectAndEmptyCheck: [^ ''].

	(model respondsTo: #doItReceiver) 
		ifTrue: [FakeClassPool adopt: model selectedClass.  "Include model pool vars if any"
				rcvr _ model doItReceiver.
				ctxt _ model doItContext]
		ifFalse: [rcvr _ ctxt _ nil].
	result _ rcvr class evaluatorClass new evaluate: self selectionAsStream
				in: ctxt to: rcvr notifying: self
				ifFail: [FakeClassPool adopt: nil.
						^ #failedDoit].
	FakeClassPool adopt: nil.
	Smalltalk logChange: self selection string.
	^ result! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'acg 12/7/1999 07:53'!
exploreIt
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [result explore].
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 9/7/1999 11:25'!
inspectIt
	"1/13/96 sw: minor fixup"
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [result inspect].
! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 9/7/1999 08:42'!
objectsReferencingIt
	"Open a list inspector on all objects that reference the object that results when the current selection is evaluated.  "
	| result |
	self terminateAndInitializeAround: [
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
		ifTrue: [view flash]
		ifFalse: [Smalltalk
					browseAllObjectReferencesTo: result
					except: #()
					ifNone: [:obj | view topView flash]].
	]! !

!ParagraphEditor methodsFor: 'do-its' stamp: 'di 5/10/1998 21:52'!
printIt
	"Treat the current text selection as an expression; evaluate it. Insert the 
	description of the result of evaluation after the selection and then make 
	this description the new text selection."
	| result |
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [view flash]
			ifFalse: [self afterSelectionInsertAndSelect: result printString]! !


!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:40'!
totalTextHeight

	^paragraph boundingBox height! !

!ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:33'!
visibleHeight

	^paragraph clippingRectangle height! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ParagraphEditor class
	instanceVariableNames: ''!

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'sw 5/27/2000 00:03'!
abandonChangeText
	"Call this to get out of the maddening situation in which the system keeps aggressively trying to do a replacement that you no longer wish to make, every time you make choose a new method in a list."
	ChangeText _ FindText

	"ParagraphEditor abandonChangeText"
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'ar 1/15/2001 18:47'!
initialize 
	"Initialize the keyboard shortcut maps and the shared buffers
	for copying text across views and managing again and undo.
	Marked this method changed to trigger reinit" 
 
	"ParagraphEditor initialize"

	UndoSelection _ FindText _ ChangeText _ Text new.
	UndoMessage _ Message selector: #halt.

	self initializeCmdKeyShortcuts.
	self initializeShiftCmdKeyShortcuts.
	self initializeTextEditorMenus
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'di 4/26/2000 20:32'!
initializeTextEditorMenus   "ParagraphEditor initializeTextEditorMenus"
		"Initialize the yellow button pop-up menu and corresponding messages."

	TextEditorYellowButtonMenu _ SelectionMenu
		labels: 
'find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
paste...
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)
show bytecodes
more...' 
		lines: #(3 5 9 12 14 15)
		selections: #(find findAgain setSearchString again undo copySelection cut paste pasteRecent doIt printIt inspectIt accept cancel showBytecodes shiftedYellowButtonActivity)
! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'tk 1/22/2001 14:35'!
shiftedYellowButtonMenu
	| ww |
	"Answer the menu to be presented when the yellow button is pressed while the shift key is down"

^ SelectionMenu fromArray: (Array streamContents: [:strm | 
	strm nextPutAll: #(
		('set font... (k)'					offerFontMenu)
		('set style... (K)'					changeStyle)
		('set alignment...'				chooseAlignment)
		-								).
	(ww _ World) isMorph ifTrue: [
		(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifTrue: [
			strm nextPutAll: #(
				('tiles from it'			selectionAsTiles))]].

	strm nextPutAll: #(
		('explain'						explain)
		('pretty print'					prettyPrint)
		('pretty print with color'		prettyPrintWithColor)
		('file it in'						fileItIn)
		('recognizer (r)'					recognizeCharacters)
		('spawn (o)'						spawn)
		-
		('definition of word'				wordDefinition)
		('verify spelling of word'		verifyWordSpelling)
"		('spell check it'					spellCheckIt)	"
		('translate it'					translateIt)
		('choose language'				languagePrefs)
		-
		('browse it (b)'					browseIt)
		('senders of it (n)'				sendersOfIt)
		('implementors of it (m)'		implementorsOfIt)
		('references to it (N)'			referencesToIt)
		('selectors containing it (W)'		methodNamesContainingIt)
		('method strings with it (E)'		methodStringsContainingit)
		('method source with it'			methodSourceContainingIt)
		-
		('save contents to file...'			saveContentsInFile)
		('send contents to printer'		sendContentsToPrinter)
		('printer setup'					printerSetup)
		-
		('special menu...'				presentSpecialMenu)
		('more...'						yellowButtonActivity))]).

! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'tk 3/31/98 16:25'!
yellowButtonMenu

	^ TextEditorYellowButtonMenu! !

!ParagraphEditor class methodsFor: 'class initialization' stamp: 'di 4/17/1999 00:33'!
yellowButtonMessages

	^ TextEditorYellowButtonMenu selections! !


!ParagraphEditor class methodsFor: 'instance creation'!
new
	"Answer a new instance of me with a null Paragraph to be edited."

	| aParagraphEditor |
	aParagraphEditor _ super new.
	aParagraphEditor initialize.
	aParagraphEditor changeParagraph: '' asParagraph.
	^aParagraphEditor! !

!ParagraphEditor class methodsFor: 'instance creation'!
newParagraph: aParagraph 
	"Answer an instance of me with aParagraph as the text to be edited."

	| aParagraphEditor |
	aParagraphEditor _ super new.
	aParagraphEditor initialize.
	aParagraphEditor changeParagraph: aParagraph.
	^aParagraphEditor! !


!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sma 12/15/1999 11:29'!
initializeCmdKeyShortcuts
	"Initialize the (unshifted) command-key shortcut table."
	"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
	"ParagraphEditor initialize"

	| cmdMap cmds |
	cmdMap _ Array new: 256 withAll: #noop:.  "use temp in case of a crash"
	cmdMap at: ( 1 + 1) put: #cursorHome:.			"home key"
	cmdMap at: ( 4 + 1) put: #cursorEnd:.			"end key"
	cmdMap at: ( 8 + 1) put: #backspace:.			"ctrl-H or delete key"
	cmdMap at: (11 + 1) put: #cursorPageUp:.			"page up key"
	cmdMap at: (12 + 1) put: #cursorPageDown:.		"page down key"
	cmdMap at: (13 + 1) put: #crWithIndent:.			"cmd-Return"
	cmdMap at: (27 + 1) put: #selectCurrentTypeIn:.	"escape key"
	cmdMap at: (28 + 1) put: #cursorLeft:.			"left arrow key"
	cmdMap at: (29 + 1) put: #cursorRight:.			"right arrow key"
	cmdMap at: (30 + 1) put: #cursorUp:.				"up arrow key"
	cmdMap at: (31 + 1) put: #cursorDown:.			"down arrow key"
	cmdMap at: (32 + 1) put: #selectWord:.			"space bar key"
	cmdMap at: (127 + 1) put: #forwardDelete:.		"del key"

	'0123456789-=' do: [ :char | cmdMap at: (char asciiValue + 1) put: #changeEmphasis: ].
	'([{''"<' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose: ].
	cmdMap at: ($, asciiValue + 1) put: #shiftEnclose:.

	cmds _ #(
		$a	selectAll:
		$b	browseIt:
		$c	copySelection:
		$d	doIt:
		$e	exchange:
		$f	find:
		$g	findAgain:
		$h	setSearchString:
		$i	inspectIt:
		$j	doAgainOnce:
		$k  offerFontMenu:
		$l	cancel:
		$m	implementorsOfIt:
		$n	sendersOfIt:
		$o	spawnIt:
		$p	printIt:
		$q	querySymbol:
		$r	recognizer:
		$s	save:
		$t	tempCommand:
		$u	align:
		$v	paste:
		$w	backWord:
		$x	cut:
		$y	swapChars:
		$z	undo:
	).
	1 to: cmds size by: 2 do: [ :i |
		cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1).
	].
	CmdActions _ cmdMap
! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'RAA 10/19/2000 16:10'!
initializeShiftCmdKeyShortcuts
	"Initialize the shift-command-key (or control-key) shortcut table."
	"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
	"wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the 
	capitalized versions of the letters.
	TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."

	| cmdMap cmds |
	"shift-command and control shortcuts"
	cmdMap _ Array new: 256 withAll: #noop:.  "use temp in case of a crash"
	cmdMap at: ( 1 + 1) put: #cursorHome:.			"home key"
	cmdMap at: ( 4 + 1) put: #cursorEnd:.			"end key"
	cmdMap at: ( 8 + 1) put: #forwardDelete:.		"ctrl-H or delete key"
	cmdMap at: (11 + 1) put: #cursorPageUp:.			"page up key"
	cmdMap at: (12 + 1) put: #cursorPageDown:.		"page down key"
	cmdMap at: (13 + 1) put: #crWithIndent:.			"ctrl-Return"
	cmdMap at: (27 + 1) put: #selectCurrentTypeIn:.	"escape key"
	cmdMap at: (28 + 1) put: #cursorLeft:.			"left arrow key"
	cmdMap at: (29 + 1) put: #cursorRight:.			"right arrow key"
	cmdMap at: (30 + 1) put: #cursorUp:.				"up arrow key"
	cmdMap at: (31 + 1) put: #cursorDown:.			"down arrow key"
	cmdMap at: (32 + 1) put: #selectWord:.			"space bar key"
	cmdMap at: (45 + 1) put: #changeEmphasis:.		"cmd-sh-minus"
	cmdMap at: (61 + 1) put: #changeEmphasis:.		"cmd-sh-plus"
	cmdMap at: (127 + 1) put: #forwardDelete:.		"del key"

	"Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $("
	'9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose: ].	"({< and double-quote"
	"Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command."
	cmdMap at: (27 + 1) put: #shiftEnclose:.	"ctrl-["
	"'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]."

	cmds _ #(
		$a	argAdvance:
		$b	browseItHere:
		$c	compareToClipboard:
		$d	duplicate:
		$e	methodStringsContainingIt:
		$f	displayIfFalse:
		$i	exploreIt:
		$j	doAgainMany:
		$k	changeStyle:
		$l	outdent:
		$n	referencesToIt:
		$p	makeProjectLink:
		$r	indent:
		$s	search:
		$t	displayIfTrue:
		$u	changeLfToCr:
		$v	pasteInitials:
		$w	methodNamesContainingIt:
		$x	makeLowercase:
		$y	makeUppercase:
		$z	makeCapitalized:
	).
	1 to: cmds size by: 2 do: [ :i |
		cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1).		"plain keys"
		cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1).		"shifted keys"
		cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1).		"ctrl keys"
	].
	ShiftCmdActions _ cmdMap! !

!ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sbw 10/8/1999 21:42'!
specialShiftCmdKeys

"Private - return array of key codes that represent single keys acting
as if shift-command were also being pressed"

^#(
	1	"home"
	3	"enter"
	4	"end"
	8	"backspace"
	11	"page up"
	12	"page down"
	27	"escape"
	28	"left arrow"
	29	"right arrow"
	30	"up arrow"
	31	"down arrow"
	127	"delete"
	)! !

CompositeAnimation subclass: #ParallelAnimation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!ParallelAnimation commentStamp: '<historical>' prior: 0!
This class extends CompositeAnimations for composite animations (an animation built of 2 or more animations) that all run in parallel.
!


!ParallelAnimation methodsFor: 'initialization' stamp: 'jsp 2/26/1999 15:36'!
children: childCollection undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs to run."

	| childDuration |
	undoable _ canUndo.
	myWonderland _ aWonderland.
	myScheduler _ aWonderland getScheduler.
	loopCount _ 1.
	direction _ Forward.

	super initialize.

	"Add children"
	childCollection do: [:child | self append: child. child setUndoable: false ].

	"Calculate duration"
	duration _ 0.
	children do: [:child | childDuration _ ((child getDuration) * (child getLoopCount)).
							(childDuration > duration) ifTrue: [ duration _ childDuration. ]. ].

	state _ Waiting.
	myScheduler addAnimation: self.! !


!ParallelAnimation methodsFor: 'management' stamp: 'jsp 2/26/1999 15:28'!
prologue: currentTime
	"This method performs any actions that need to be done before the parallel animation starts."

	super prologue: currentTime.

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (UndoAnimation new: (self makeUndoVersion)).
					].

	children do: [:child | child prologue: currentTime. ].

	(direction = Reverse) ifTrue: [ children do: [:child | child pause ] ].
! !

!ParallelAnimation methodsFor: 'management' stamp: 'jsp 2/26/1999 15:33'!
update: currentTime
	"This method updates the parallel animation based on the current time, which mainly consists of updating all the component animations."

	| index |

	(state = Waiting) ifTrue: [self prologue: currentTime].

	(state = Running) ifTrue: [
			state _ Finished.

			"Update every child.  If any one of them is not Stopped set our state back to Running"

			index _ 1.
			children do: [: child |  ((child getState) = Running) ifTrue: [child update: currentTime].
					((child getState) = Finished) ifTrue: [child epilogue: currentTime].
					((child getState) = Waiting) ifTrue: [child prologue: currentTime].
					((child getState) = Stopped) ifFalse: [state _ Running].

					((direction = Reverse) and: [ ((child getState) = Paused) ]) ifTrue: [
						((currentTime - startTime) >
								(duration - ((child getDuration) * (childLoopCounts at: index))))
									ifTrue: [ child resume ] ].
					index _ index + 1.
						].

							  ].

	(state = Finished) ifTrue: [self epilogue: currentTime].
! !


!ParallelAnimation methodsFor: 'copying' stamp: 'jsp 3/3/1999 12:31'!
copy
	"Creates the undo version of an animation"

	| anim copyOfChildren copyOfChild i |

	anim _ ParallelAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: false
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].

	^ anim.
! !

!ParallelAnimation methodsFor: 'copying' stamp: 'jsp 2/26/1999 14:57'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim copyOfChildren copyOfChild i |

	anim _ ParallelAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: false
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].
	anim reverseDirection.

	"Undoing a parallel animation takes 1 second"	
	anim scaleDuration: (1 / duration).
	anim stop.

	^ anim.
! !

!ParallelAnimation methodsFor: 'copying' stamp: 'jsp 4/9/1999 14:21'!
reversed
	"Creates a reversed version of an animation"

	| anim copyOfChildren copyOfChild i |

	anim _ ParallelAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: true
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].
	anim reverseDirection.

	anim stop.

	^ anim.
! !
Object subclass: #ParseNode
	instanceVariableNames: 'comment '
	classVariableNames: 'Bfp BtpLong CodeBases CodeLimits DblExtDoAll Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue LoadLong LongLongDoAll NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendLong2 SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop '
	poolDictionaries: ''
	category: 'System-Compiler'!
!ParseNode commentStamp: '<historical>' prior: 0!
This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.!


!ParseNode methodsFor: 'testing'!
assignmentCheck: encoder at: location
	"For messageNodes masquerading as variables for the debugger.
	For now we let this through - ie we allow stores ev
	into args.  Should check against numArgs, though."
	^ -1! !

!ParseNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^false! !

!ParseNode methodsFor: 'testing'!
canCascade

	^false! !

!ParseNode methodsFor: 'testing'!
isArg

	^false! !

!ParseNode methodsFor: 'testing'!
isComplex
	"Used for pretty printing to determine whether to start a new line"

	^false! !

!ParseNode methodsFor: 'testing'!
isConstantNumber  "Overridden in LiteralNode"
	^false! !

!ParseNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:14'!
isLiteral

	^ false! !

!ParseNode methodsFor: 'testing'!
isMessage: selSymbol receiver: rcvrPred arguments: argsPred
	"See comment in MessageNode."

	^false! !

!ParseNode methodsFor: 'testing'!
isReturnSelf

	^false! !

!ParseNode methodsFor: 'testing'!
isReturningIf

	^false! !

!ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'!
isSelfPseudoVariable	
	"Overridden in VariableNode."
	^false! !

!ParseNode methodsFor: 'testing'!
isSpecialConstant
	^ false! !

!ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'!
isTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isUndefTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isUnusedTemp
	^ false! !

!ParseNode methodsFor: 'testing'!
isVariableReference

	^false! !

!ParseNode methodsFor: 'testing'!
nowHasDef  "Ignored in all but VariableNode"! !

!ParseNode methodsFor: 'testing'!
nowHasRef  "Ignored in all but VariableNode"! !

!ParseNode methodsFor: 'testing'!
toDoIncrement: ignored
	"Only meant for Messages or Assignments - else return nil"
	^ nil! !


!ParseNode methodsFor: 'code generation'!
emitBranchOn:
condition dist: dist pop: stack on: strm
	stack pop: 1.
	dist = 0 ifTrue: [^ strm nextPut: Pop].
	condition
		ifTrue: [self emitLong: dist code: BtpLong on: strm]
		ifFalse: [self emitShortOrLong: dist code: Bfp on: strm]! !

!ParseNode methodsFor: 'code generation'!
emitForEffect: stack on: strm

	self emitForValue: stack on: strm.
	strm nextPut: Pop.
	stack pop: 1! !

!ParseNode methodsFor: 'code generation'!
emitForReturn: stack on: strm

	self emitForValue: stack on: strm.
	strm nextPut: EndMethod! !

!ParseNode methodsFor: 'code generation'!
emitJump: dist on: strm

	dist = 0 ifFalse: [self emitShortOrLong: dist code: Jmp on: strm]! !

!ParseNode methodsFor: 'code generation'!
emitLong: dist code: longCode on: aStream 
	"Force a two-byte jump."
	| code distance |
	code _ longCode.
	distance _ dist.
	distance < 0
		ifTrue: 
			[distance _ distance + 1024.
			code _ code - 4]
		ifFalse: 
			[distance > 1023 ifTrue: [distance _ -1]].
	distance < 0
		ifTrue: 
			[self error: 'A block compiles more than 1K bytes of code']
		ifFalse: 
			[aStream nextPut: distance // 256 + code.
			aStream nextPut: distance \\ 256]! !

!ParseNode methodsFor: 'code generation'!
emitShortOrLong: dist code: shortCode on: strm
	(1 <= dist and: [dist <= JmpLimit])
		ifTrue: [strm nextPut: shortCode + dist - 1]
		ifFalse: [self emitLong: dist code: shortCode + (JmpLong-Jmp) on: strm]! !

!ParseNode methodsFor: 'code generation'!
sizeBranchOn: condition dist: dist
	dist = 0 ifTrue: [^1].
	^ condition
		ifTrue: [2]  "Branch on true is always 2 bytes"
		ifFalse: [self sizeShortOrLong: dist]! !

!ParseNode methodsFor: 'code generation'!
sizeForEffect: encoder

	^(self sizeForValue: encoder) + 1! !

!ParseNode methodsFor: 'code generation'!
sizeForReturn: encoder

	^(self sizeForValue: encoder) + 1! !

!ParseNode methodsFor: 'code generation'!
sizeJump: dist

	dist = 0 ifTrue: [^0].
	^self sizeShortOrLong: dist! !

!ParseNode methodsFor: 'code generation'!
sizeShortOrLong: dist

	(1 <= dist and: [dist <= JmpLimit])
		ifTrue: [^1].
	^2! !


!ParseNode methodsFor: 'encoding'!
encodeSelector: selector

	^nil! !


!ParseNode methodsFor: 'comment'!
comment

	^comment! !

!ParseNode methodsFor: 'comment'!
comment: newComment

	comment _ newComment! !


!ParseNode methodsFor: 'converting'!
asReturnNode

	^ReturnNode new expr: self! !


!ParseNode methodsFor: 'printing' stamp: 'tk 10/16/2000 13:57'!
nodePrintOn: aStrm indent: nn
	| var aaStrm myLine |
	"Show just the sub nodes and the code."

	(aaStrm _ aStrm) ifNil: [aaStrm _ WriteStream on: (String new: 500)].
	nn timesRepeat: [aaStrm tab].
	aaStrm nextPutAll: self class name; space.
	myLine _ self printString copyWithout: Character cr.
	myLine _ myLine copyFrom: 1 to: (myLine size min: 70).
	aaStrm nextPutAll: myLine; cr.
	1 to: self class instSize do: [:ii | 
		var _ self instVarAt: ii.
		(var respondsTo: #asReturnNode) ifTrue: [var nodePrintOn: aaStrm indent: nn+1]].
	1 to: self class instSize do: [:ii | 
		var _ self instVarAt: ii.
		(var isKindOf: SequenceableCollection) ifTrue: [
				var do: [:aNode | 
					(aNode respondsTo: #asReturnNode) ifTrue: [
						aNode nodePrintOn: aaStrm indent: nn+1]]]].
	^ aaStrm
! !

!ParseNode methodsFor: 'printing' stamp: 'di 4/5/2000 15:11'!
printCommentOn: aStream indent: indent 
	| thisComment |
	comment == nil ifTrue: [^ self].
	aStream withStyleFor: #comment
		do: [1 to: comment size do: 
				[:index | 
				index > 1 ifTrue: [aStream crtab: indent].
				aStream nextPut: $".
				thisComment _ comment at: index.
				self printSingleComment: thisComment
					on: aStream
					indent: indent.
				aStream nextPut: $"]].
	comment _ nil! !

!ParseNode methodsFor: 'printing' stamp: 'di 4/19/2000 11:58'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: '{'.
	aStream nextPutAll: ((DialectStream dialect: #ST80
								contents: [:strm | self printOn: strm indent: 0])
							asString).
	aStream nextPutAll: '}'! !

!ParseNode methodsFor: 'printing'!
printOn: aStream indent: anInteger 
	"If control gets here, avoid recursion loop."

	super printOn: aStream! !

!ParseNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p

	self printOn: aStream indent: level! !


!ParseNode methodsFor: 'private' stamp: 'sma 5/28/2000 10:47'!
nextWordFrom: aStream setCharacter: aBlock
	| outStream char |
	outStream _ WriteStream on: (String new: 16).
	[(aStream peekFor: Character space) 
		or: [aStream peekFor: Character tab]] whileTrue.
	[aStream atEnd
		or:
			[char _ aStream next.
			char = Character cr or: [char = Character space]]]
		whileFalse: [outStream nextPut: char].
	aBlock value: char.
	^ outStream contents! !

!ParseNode methodsFor: 'private' stamp: 'sma 5/28/2000 10:45'!
printSingleComment: aString on: aStream indent: indent 
	"Print the comment string, assuming it has been indented indent tabs.
	Break the string at word breaks, given the widths in the default
	font, at 450 points."

	| readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar |
	readStream _ ReadStream on: aString.
	font _ TextStyle default defaultFont.
	tabWidth _ TextConstants at: #DefaultTab.
	spaceWidth _ font widthOf: Character space.
	position _ indent * tabWidth.
	lineBreak _ 450.
	[readStream atEnd]
		whileFalse: 
			[word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc].
			wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)].
			position _ position + wordWidth.
			position > lineBreak
				ifTrue: 
					[aStream crtab: indent.
					position _ indent * tabWidth + wordWidth + spaceWidth.
					lastChar = Character cr
						ifTrue: [[readStream peekFor: Character tab] whileTrue].
					word isEmpty ifFalse: [aStream nextPutAll: word; space]]
				ifFalse: 
					[aStream nextPutAll: word.
					readStream atEnd
						ifFalse: 
							[position _ position + spaceWidth.
							aStream space].
					lastChar = Character cr
						ifTrue: 
							[aStream crtab: indent.
							position _ indent * tabWidth.
							[readStream peekFor: Character tab] whileTrue]]]! !


!ParseNode methodsFor: 'tiles' stamp: 'di 11/14/2000 16:52'!
addCommentToMorph: aMorph
	| row |
	(comment isNil or: [comment isEmpty]) ifTrue: [^ self].
	row _ aMorph addTextRow:
		(String streamContents: [:strm | self printCommentOn: strm indent: 1]).
	row firstSubmorph color: (SyntaxMorph translateColor: #comment).
	row parseNode: (self as: CommentNode).
! !

!ParseNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 12:24'!
asMorphicSyntaxIn: parent

	| morph |
	"Default for missing implementations"

	morph _ parent addColumn: #error on: self.
	morph addTextRow: self class printString.
	^morph
	

! !

!ParseNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 13:06'!
currentValueIn: aContext

	^nil! !

!ParseNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 18:18'!
explanation

	^self class printString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ParseNode class
	instanceVariableNames: ''!

!ParseNode class methodsFor: 'class initialization'!
initialize
	"ParseNode initialize. VariableNode initialize"
	LdInstType _ 1.
	LdTempType _ 2.
	LdLitType _ 3.
	LdLitIndType _ 4.
	SendType _ 5.
	CodeBases _ #(0 16 32 64 208 ).
	CodeLimits _ #(16 16 32 32 16 ).
	LdSelf _ 112.
	LdTrue _ 113.
	LdFalse _ 114.
	LdNil _ 115.
	LdMinus1 _ 116.
	LoadLong _ 128.
	Store _ 129.
	StorePop _ 130.
	ShortStoP _ 96.
	SendLong _ 131.
	DblExtDoAll _ 132.
	SendLong2 _ 134.
	LdSuper _ 133.
	Pop _ 135.
	Dup _ 136.
	LdThisContext _ 137.
	EndMethod _ 124.
	EndRemote _ 125.
	Jmp _ 144.
	Bfp _ 152.
	JmpLimit _ 8.
	JmpLong _ 164.  "code for jmp 0"
	BtpLong _ 168.
	SendPlus _ 176.
	Send _ 208.
	SendLimit _ 16! !
Object subclass: #ParseStack
	instanceVariableNames: 'position length '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!ParseStack commentStamp: '<historical>' prior: 0!
I keep track of the current and high position of the stack that will be needed by code being compiled.!


!ParseStack methodsFor: 'initialize-release'!
init

	length _ position _ 0! !


!ParseStack methodsFor: 'accessing'!
pop: n

	(position _ position - n) < 0 
		ifTrue: [self error: 'Parse stack underflow']! !

!ParseStack methodsFor: 'accessing'!
push: n

	(position _ position + n) > length 
		ifTrue: [length _ position]! !

!ParseStack methodsFor: 'accessing'!
size

	^length! !


!ParseStack methodsFor: 'results'!
position

	^position! !


!ParseStack methodsFor: 'printing'!
printOn: aStream
	
	super printOn: aStream.
	aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! !
Scanner subclass: #Parser
	instanceVariableNames: 'here hereType hereMark prevToken prevMark encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!Parser commentStamp: '<historical>' prior: 0!
I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.!


!Parser methodsFor: 'public access'!
encoder
	^ encoder! !

!Parser methodsFor: 'public access' stamp: 'RAA 6/14/2000 14:34'!
parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock 
        "Answer a MethodNode for the argument, sourceStream, that is the root of 
        a parse tree. Parsing is done with respect to the argument, class, to find 
        instance, class, and pool variables; and with respect to the argument, 
        ctxt, to find temporary variables. Errors in parsing are reported to the 
        argument, req, if not nil; otherwise aBlock is evaluated. The argument 
        noPattern is a Boolean that is true if the the sourceStream does not 
        contain a method header (i.e., for DoIts)."

         | meth repeatNeeded myStream parser |
        (req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]])
                ifTrue: [parser _ self as: DialectParser]
                ifFalse: [parser _ self].
        myStream _ sourceStream.
        [repeatNeeded _ false.
        parser init: myStream notifying: req failBlock: [^ aBlock value].
        doitFlag _ noPattern.
        failBlock_ aBlock.
        [meth _ parser method: noPattern context: ctxt
                                encoder: (Encoder new init: class context: ctxt notifying: parser)] 
                on: ParserRemovedUnusedTemps 
                do: 
                        [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not.
                        myStream _ ReadStream on: requestor text string.
                        ex resume].
        repeatNeeded] whileTrue.
        encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow"
        ^ meth! !

!Parser methodsFor: 'public access' stamp: 'RAA 6/14/2000 13:50'!
parseArgsAndTemps: aString notifying: req 
        "Parse the argument, aString, notifying req if an error occurs. Otherwise, 
        answer a two-element Array containing Arrays of strings (the argument 
        names and temporary variable names)."

        (req notNil and: [RequestAlternateSyntaxSetting signal]) ifTrue:
                [^ (self as: DialectParser) parseArgsAndTemps: aString notifying: req].
        aString == nil ifTrue: [^#()].
        doitFlag _ false.               "Don't really know if a doit or not!!"
        ^self initPattern: aString
                notifying: req
                return: [:pattern | (pattern at: 2) , self temporaries]! !

!Parser methodsFor: 'public access'!
parseMethodComment: aString setPattern: aBlock
	"Answer the method comment for the argument, aString. Evaluate aBlock 
	with the message pattern in the form #(selector, arguments, precedence)."

	self
		initPattern: aString
		notifying: nil
		return: aBlock.
	currentComment==nil
		ifTrue:	[^OrderedCollection new]
		ifFalse:	[^currentComment]! !

!Parser methodsFor: 'public access'!
parseSelector: aString 
	"Answer the message selector for the argument, aString, which should 
	parse successfully up to the temporary declaration or the end of the 
	method header."

	^self
		initPattern: aString
		notifying: nil
		return: [:pattern | pattern at: 1]! !


!Parser methodsFor: 'expression types'!
argumentName

	hereType == #word
		ifFalse: [^self expected: 'Argument name'].
	^self advance! !

!Parser methodsFor: 'expression types'!
assignment: varNode
	" var '_' expression => AssignmentNode."
	| loc |
	(loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0
		ifTrue: [^self notify: 'Cannot store into' at: loc].
	varNode nowHasDef.
	self advance.
	self expression ifFalse: [^self expected: 'Expression'].
	parseNode _ AssignmentNode new
				variable: varNode
				value: parseNode
				from: encoder.
	^true! !

!Parser methodsFor: 'expression types' stamp: 'sma 2/27/2000 22:38'!
blockExpression
	"[ ({:var} |) (| {temps} |) (statements) ] => BlockNode."

	| variableNodes temporaryBlockVariables |

	variableNodes _ OrderedCollection new.

	"Gather parameters."
	[self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)].
	(variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar'].

	temporaryBlockVariables _ self temporaryBlockVariables.
	self statements: variableNodes innerBlock: true.
	parseNode temporaries: temporaryBlockVariables.

	(self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket'].

	"The scope of the parameters and temporary block variables is no longer active."
	temporaryBlockVariables do: [:variable | variable scope: -1].
	variableNodes do: [:variable | variable scope: -1]! !

!Parser methodsFor: 'expression types' stamp: 'di 3/8/2000 09:36'!
braceExpression
	" { elements } => BraceNode."

	| elements locations loc more |
	elements _ OrderedCollection new.
	locations _ OrderedCollection new.
	self advance.
	more _ hereType ~~ #rightBrace.
	[more]
		whileTrue: 
			[loc _ hereMark + requestorOffset.
			self expression
				ifTrue: 
					[elements addLast: parseNode.
					locations addLast: loc]
				ifFalse:
					[^self expected: 'Variable or expression'].
			(self match: #period)
				ifTrue: [more _ hereType ~~ #rightBrace]
				ifFalse: [more _ false]].
	parseNode _ BraceNode new elements: elements sourceLocations: locations.
	(self match: #rightBrace)
		ifFalse: [^self expected: 'Period or right brace'].
	^true! !

!Parser methodsFor: 'expression types'!
cascade
	" {; message} => CascadeNode."

	| rcvr msgs |
	parseNode canCascade
		ifFalse: [^self expected: 'Cascading not'].
	rcvr _ parseNode cascadeReceiver.
	msgs _ OrderedCollection with: parseNode.
	[self match: #semicolon]
		whileTrue: 
			[parseNode _ rcvr.
			(self messagePart: 3 repeat: false)
				ifFalse: [^self expected: 'Cascade'].
			parseNode canCascade
				ifFalse: [^self expected: '<- No special messages'].
			parseNode cascadeReceiver.
			msgs addLast: parseNode].
	parseNode _ CascadeNode new receiver: rcvr messages: msgs! !

!Parser methodsFor: 'expression types' stamp: 'di 11/19/1999 07:43'!
expression

	(hereType == #word and: [tokenType == #leftArrow])
		ifTrue: [^ self assignment: self variable].
	hereType == #leftBrace
		ifTrue: [self braceExpression]
		ifFalse: [self primaryExpression ifFalse: [^ false]].
	(self messagePart: 3 repeat: true)
		ifTrue: [hereType == #semicolon ifTrue: [self cascade]].
	^ true! !

!Parser methodsFor: 'expression types' stamp: 'di 4/5/2000 08:27'!
keylessMessagePartTest: level repeat: repeat
! !

!Parser methodsFor: 'expression types'!
messagePart: level repeat: repeat

	| start receiver selector args precedence words keywordStart |
	[receiver _ parseNode.
	(hereType == #keyword and: [level >= 3])
		ifTrue: 
			[start _ self startOfNextToken.
			selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			words _ OrderedCollection new.
			[hereType == #keyword]
				whileTrue: 
					[keywordStart _ self startOfNextToken + requestorOffset.
					selector nextPutAll: self advance.
					words addLast: (keywordStart to: self endOfLastToken + requestorOffset).
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 2 repeat: true.
					args addLast: parseNode].
			(Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym])
				ifFalse: [ selector _ self correctSelector: selector contents
										wordIntervals: words
										exprInterval: (start to: self endOfLastToken)
										ifAbort: [ ^ self fail ] ].
			precedence _ 3]
		ifFalse: [((hereType == #binary or: [hereType == #verticalBar])
				and: [level >= 2])
				ifTrue: 
					[start _ self startOfNextToken.
					selector _ self advance asSymbol.
					self primaryExpression ifFalse: [^self expected: 'Argument'].
					self messagePart: 1 repeat: true.
					args _ Array with: parseNode.
					precedence _ 2]
				ifFalse: [hereType == #word
						ifTrue: 
							[start _ self startOfNextToken.
							selector _ self advance.
							args _ #().
							words _ OrderedCollection with: (start  + requestorOffset to: self endOfLastToken + requestorOffset).
							(Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym])
								ifFalse: [ selector _ self correctSelector: selector
													wordIntervals: words
													exprInterval: (start to: self endOfLastToken)
													ifAbort: [ ^ self fail ] ].
							precedence _ 1]
						ifFalse: [^args notNil]]].
	parseNode _ MessageNode new
				receiver: receiver
				selector: selector
				arguments: args
				precedence: precedence
				from: encoder
				sourceRange: (start to: self endOfLastToken).
	repeat]
		whileTrue: [].
	^true! !

!Parser methodsFor: 'expression types' stamp: 'di 5/30/2000 22:06'!
method: doit context: ctxt encoder: encoderToUse
	" pattern [ | temporaries ] block => MethodNode."

	| sap blk prim temps messageComment methodNode |
	encoder _ encoderToUse.
	sap _ self pattern: doit inContext: ctxt.
	"sap={selector, arguments, precedence}"
	(sap at: 2) do: [:argNode | argNode isArg: true].
	temps _ self temporaries.
	messageComment _ currentComment.
	currentComment _ nil.
	prim _ doit ifTrue: [0] ifFalse: [self primitive].
	self statements: #() innerBlock: doit.
	blk _ parseNode.
	doit ifTrue: [blk returnLast]
		ifFalse: [blk returnSelfIfNoOther].
	hereType == #doIt ifFalse: [^self expected: 'Nothing more'].
	self interactive ifTrue: [self removeUnusedTemps].
	methodNode _ self newMethodNode comment: messageComment.
	^ methodNode
		selector: (sap at: 1)
		arguments: (sap at: 2)
		precedence: (sap at: 3)
		temporaries: temps
		block: blk
		encoder: encoder
		primitive: prim! !

!Parser methodsFor: 'expression types' stamp: 'di 5/30/2000 21:59'!
newMethodNode

	^ MethodNode new! !

!Parser methodsFor: 'expression types' stamp: 'di 4/5/2000 16:52'!
pattern: fromDoit inContext: ctxt 
	" unarySelector | binarySelector arg | keyword arg {keyword arg} =>  
	{selector, arguments, precedence}."
	| args selector |
	doitFlag _ fromDoit.
	fromDoit ifTrue:
			[ctxt == nil
				ifTrue: [^ {#DoIt. {}. 1}]
				ifFalse: [^ {#DoItIn:. {encoder encodeVariable: 'homeContext'}. 3}]].

	hereType == #word ifTrue: [^ {self advance asSymbol. {}. 1}].

	(hereType == #binary or: [hereType == #verticalBar])
		ifTrue: 
			[selector _ self advance asSymbol.
			args _ Array with: (encoder bindArg: self argumentName).
			^ {selector. args. 2}].

	hereType == #keyword
		ifTrue: 
			[selector _ WriteStream on: (String new: 32).
			args _ OrderedCollection new.
			[hereType == #keyword]
				whileTrue: 
					[selector nextPutAll: self advance.
					args addLast: (encoder bindArg: self argumentName)].
			^ {selector contents asSymbol. args. 3}].

	^ self expected: 'Message pattern'! !

!Parser methodsFor: 'expression types'!
primaryExpression 
	hereType == #word 
		ifTrue: 
			[parseNode _ self variable.
			(parseNode isUndefTemp and: [self interactive])
				ifTrue: [self queryUndefined].
			parseNode nowHasRef.
			^ true].
	hereType == #leftBracket
		ifTrue: 
			[self advance.
			self blockExpression.
			^true].
	hereType == #leftBrace
		ifTrue: 
			[self braceExpression.
			^true].
	hereType == #leftParenthesis
		ifTrue: 
			[self advance.
			self expression ifFalse: [^self expected: 'expression'].
			(self match: #rightParenthesis)
				ifFalse: [^self expected: 'right parenthesis'].
			^true].
	(hereType == #string or: [hereType == #number or: [hereType == #literal]])
		ifTrue: 
			[parseNode _ encoder encodeLiteral: self advance.
			^true].
	(here == #- and: [tokenType == #number])
		ifTrue: 
			[self advance.
			parseNode _ encoder encodeLiteral: self advance negated.
			^true].
	^false! !

!Parser methodsFor: 'expression types' stamp: 'di 6/7/2000 08:45'!
statements: argNodes innerBlock: inner

	| stmts returns start more blockComment |
	stmts _ OrderedCollection new.
	"give initial comment to block, since others trail statements"
	blockComment _ currentComment.
	currentComment _ nil.
	returns _ false.
	more _ hereType ~~ #rightBracket.
	[more]
		whileTrue: 
		[start _ self startOfNextToken.
		(returns _ self matchReturn)
			ifTrue: 
				[self expression
					ifFalse: [^self expected: 'Expression to return'].
				self addComment.
				stmts addLast: (parseNode isReturningIf
					ifTrue: [parseNode]
					ifFalse: [ReturnNode new
							expr: parseNode
							encoder: encoder
							sourceRange: (start to: self endOfLastToken)])]
			ifFalse: 
				[self expression
					ifTrue: 
						[self addComment.
						stmts addLast: parseNode]
					ifFalse: 
						[self addComment.
						stmts size = 0
							ifTrue: 
								[stmts addLast: 
									(encoder encodeVariable:
										(inner ifTrue: ['nil'] ifFalse: ['self']))]]].
		returns 
			ifTrue: 
				[self match: #period.
				(hereType == #rightBracket or: [hereType == #doIt])
					ifFalse: [^self expected: 'End of block']].
		more _ returns not and: [self match: #period]].
	parseNode _ BlockNode new
				arguments: argNodes
				statements: stmts
				returns: returns
				from: encoder.
	parseNode comment: blockComment.
	^ true! !

!Parser methodsFor: 'expression types' stamp: 'tk 1/3/2000 13:56'!
temporaries
	" [ '|' (variable)* '|' ]"
	| vars theActualText |
	(self match: #verticalBar) ifFalse: 
		["no temps"
		doitFlag ifTrue: [requestor
				ifNil: [tempsMark _ 1]
				ifNotNil: [tempsMark _ requestor selectionInterval first].
			^ #()].
		tempsMark _ prevMark + prevToken.
		tempsMark > 0 ifTrue:
			[theActualText _ source contents.
			[tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]]
				whileTrue: [tempsMark _ tempsMark + 1]].
			^ #()].
	vars _ OrderedCollection new.
	[hereType == #word]
		whileTrue: [vars addLast: (encoder bindTemp: self advance)].
	(self match: #verticalBar) ifTrue: 
		[tempsMark _ prevMark.
		^ vars].
	^ self expected: 'Vertical bar'! !

!Parser methodsFor: 'expression types' stamp: 'crl 2/26/1999 12:22'!
temporaryBlockVariables
	"Scan and answer temporary block variables."

	| variables |

	(self match: #verticalBar) ifFalse: [
		"There are't any temporary variables."
		^#()].

	variables _ OrderedCollection new.
	[hereType == #word] whileTrue: [variables addLast: (encoder bindBlockTemp: self advance)].
	(self match: #verticalBar) ifTrue: [^variables].
	^self expected: 'Vertical bar'! !

!Parser methodsFor: 'expression types' stamp: 'di 12/4/1999 21:04'!
variable

	| varName varStart varEnd |
	varStart _ self startOfNextToken + requestorOffset.
	varName _ self advance.
	varEnd _ self endOfLastToken + requestorOffset.
	^ encoder encodeVariable: varName
		sourceRange: (varStart to: varEnd)
		ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]! !


!Parser methodsFor: 'scanning' stamp: 'sn 9/19/97 19:32'!
advance
    | this |
    prevMark _ hereMark.
    prevToken _ "Now means prev size"
        self previousTokenSize.
    this _ here.
    here _ token.
    hereType _ tokenType.
    hereMark _ mark.
    self scanToken.
    ^this! !

!Parser methodsFor: 'scanning' stamp: 'di 4/18/2000 13:26'!
endOfLastToken

	^ prevMark + prevToken - 1! !

!Parser methodsFor: 'scanning'!
match: type 
	"Answer with true if next tokens type matches."

	hereType == type
		ifTrue: 
			[self advance.
			^true].
	^false! !

!Parser methodsFor: 'scanning' stamp: 'di 6/7/2000 08:44'!
matchReturn

	^ self match: #upArrow! !

!Parser methodsFor: 'scanning'!
matchToken: thing 
	"Matches the token, not its type."

	here = thing ifTrue: [self advance. ^true].
	^false! !

!Parser methodsFor: 'scanning'!
startOfNextToken
	"Return starting position in source of next token."

	hereType == #doIt ifTrue: [^source position + 1].
	^hereMark! !


!Parser methodsFor: 'temps'!
bindArg: name

	^ self bindTemp: name! !

!Parser methodsFor: 'temps'!
bindTemp: name

	^name! !


!Parser methodsFor: 'error handling' stamp: 'di 4/24/2000 14:35'!
expected: aString 
	"Notify a problem at token 'here'."

	tokenType == #doIt ifTrue: [hereMark _ hereMark + 1].
	hereType == #doIt ifTrue: [hereMark _ hereMark + 1].
	^ self notify: aString , ' expected' at: hereMark + requestorOffset! !

!Parser methodsFor: 'error handling'!
fail

	| exitBlock |
	encoder == nil
		ifFalse: [encoder release. encoder _ nil]. "break cycle"
	exitBlock _ failBlock.
	failBlock _ nil.
	^exitBlock value! !

!Parser methodsFor: 'error handling'!
interactive

	^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! !

!Parser methodsFor: 'error handling'!
notify: aString 
	"Notify problem at token before 'here'."

	^self notify: aString at: prevMark + requestorOffset! !

!Parser methodsFor: 'error handling'!
notify: string at: location
	requestor isNil
		ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail  "failure setting up syntax error"].
				SyntaxError 
					errorInClass: encoder classEncoding
					withCode: 
						(source contents
							copyReplaceFrom: location
							to: location - 1
							with: string , ' ->')
					doitFlag: doitFlag]
		ifFalse: [requestor
					notify: string , ' ->'
					at: location
					in: source].
	^self fail! !

!Parser methodsFor: 'error handling' stamp: 'di 2/9/1999 15:43'!
offEnd: aString 
	"Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!"

	requestorOffset == nil
		ifTrue: [^ self notify: aString at: mark]
		ifFalse: [^ self notify: aString at: mark + requestorOffset]
! !


!Parser methodsFor: 'error correction' stamp: 'di 12/1/2000 14:39'!
correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction
	"Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated.  abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector.  Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts."

	| alternatives aStream choice correctSelector userSelection lines firstLine |
	"If we can't ask the user, assume that the keyword will be defined later"
	self interactive ifFalse: [ ^ proposedKeyword asSymbol ].

	userSelection _ requestor selectionInterval.
	requestor selectFrom: spots first first to: spots last last.
	requestor select.
	alternatives _ Symbol possibleSelectorsFor: proposedKeyword.

	aStream _ WriteStream on: (String new: 200).
	aStream nextPutAll: (proposedKeyword contractTo: 35); cr.
	firstLine _ 1.
 	alternatives do:
		[:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr].
	aStream nextPutAll: 'cancel'.
	lines _ Array with: firstLine with: (alternatives size + firstLine).
	
	choice _ (PopUpMenu labels: aStream contents lines: lines)
		startUpWithCaption: 
'Unknown selector, please 
confirm, correct, or cancel'.

	(choice = 0) | (choice > (lines at: 2))
		ifTrue: [ ^ abortAction value ].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.

	choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ].
	correctSelector _ alternatives at: choice - 1.
	self substituteSelector: correctSelector keywords wordIntervals: spots.
	((proposedKeyword last ~~ $:) and: [correctSelector last == $:]) ifTrue: [
		^ abortAction value].
	^ correctSelector.
! !

!Parser methodsFor: 'error correction' stamp: 'sw 11/10/1999 13:26'!
correctVariable: proposedVariable interval: spot
	"Correct the proposedVariable to a known variable, or declare it as a new
	variable if such action is requested.  We support declaring lowercase
	variables as temps, and uppercase variables as Globals or ClassVars,
	depending on whether the context is nil (class=UndefinedObject).
	Spot is the interval within the test stream of the variable."

	| alternatives aStream choice userSelection temp binding globalToo |
	"If we can't ask the user for correction, make it undeclared"
	self interactive ifFalse: [^ encoder undeclared: proposedVariable].

	temp _ proposedVariable first isLowercase.
	"First check to see if the requestor knows anything about the variable"
	(temp and: [(binding _ requestor bindingOf: proposedVariable) notNil])
		ifTrue: [^ encoder global: binding name: proposedVariable].
	userSelection _ requestor selectionInterval.
	requestor selectFrom: spot first to: spot last.
	requestor select.

	alternatives _ encoder possibleVariablesFor: proposedVariable.

	aStream _ WriteStream on: (String new: 200).
	globalToo _ 0.
	aStream nextPutAll: 'declare ' ,
		(temp ifTrue: ['temp']
			ifFalse: [encoder classEncoding == UndefinedObject
					ifTrue: ['Global']
					ifFalse: [globalToo _ 1.  'Class Variable']]); cr.
	globalToo = 1 ifTrue: [aStream nextPutAll: 'declare Global'; cr].
	alternatives do:
		[:sel | aStream nextPutAll: sel; cr].
	aStream nextPutAll: 'cancel'.

	choice _ (PopUpMenu
				labels: aStream contents
				lines: (Array with: (globalToo + 1) with: (globalToo + alternatives size + 1)))
		startUpWithCaption:
(('Unknown variable: ', proposedVariable, '
please correct, or cancel:') asText makeBoldFrom: 19 to: 19 + proposedVariable size).
	(choice = 0) | (choice > (globalToo + alternatives size + 1))
		ifTrue: [^ self fail].

	requestor deselect.
	requestor selectInvisiblyFrom: userSelection first to: userSelection last.
	choice =1 ifTrue:
			[temp ifTrue: [^ self declareTempAndPaste: proposedVariable]
				ifFalse: [encoder classEncoding == UndefinedObject
					ifTrue: [^ self declareGlobal: proposedVariable]
					ifFalse: [^ self declareClassVar: proposedVariable]]].
	(choice = 2) & (globalToo = 1) ifTrue: [^ self declareGlobal: proposedVariable].
	"Spelling correction"
	self substituteWord: (alternatives at: choice-1-globalToo)
			wordInterval: spot
			offset: 0.
	^ encoder encodeVariable: (alternatives at: choice-1-globalToo)! !

!Parser methodsFor: 'error correction'!
declareClassVar: name
	| sym class |
	sym _ name asSymbol.
	class _ encoder classEncoding.
	class _ class theNonMetaClass.		"not the metaclass"
	class addClassVarName: name.
	^ encoder global: (class classPool associationAt: sym)
			name: sym! !

!Parser methodsFor: 'error correction'!
declareGlobal: name
	| sym |
	sym _ name asSymbol.
	Smalltalk at: sym put: nil.
	^ encoder global: (Smalltalk associationAt: sym) name: sym! !

!Parser methodsFor: 'error correction' stamp: 'di 10/12/1999 15:17'!
declareTempAndPaste: name
	| insertion tabbed |
	(requestor text string at: tempsMark) = $|
				ifTrue:  "Paste it before the second vertical bar"
					[insertion _ name, ' '.
					(requestor text string at: tempsMark-1) isSeparator
						ifFalse: [insertion _ ' ', insertion].
					tempsMark _ tempsMark +
						(self substituteWord: insertion
							wordInterval: (tempsMark to: tempsMark-1)
							offset: 0)]
				ifFalse:  "No bars - insert some with CR, tab"
					[insertion _ '| ' , name , ' |
'.
					tabbed _ tempsMark > 1
						and: [(requestor text string at: tempsMark-1) = Character tab].
					tabbed
						ifTrue: [insertion _ insertion , (String with: Character tab)].
					tempsMark _ tempsMark +
						(self substituteWord: insertion
							wordInterval: (tempsMark to: tempsMark-1)
							offset: 0)
						- (tabbed ifTrue: [3] ifFalse: [2])].
			^ encoder bindAndJuggle: name! !

!Parser methodsFor: 'error correction'!
queryUndefined
	| varStart varName | 
	varName _ parseNode key.
	varStart _ self endOfLastToken + requestorOffset - varName size + 1.
	requestor selectFrom: varStart to: varStart + varName size - 1; select.
	((PopUpMenu labels:
'yes
no') startUpWithCaption:
		((varName , ' appears to be
undefined at this point.
Proceed anyway?') asText makeBoldFrom: 1 to: varName size))
		= 1 ifFalse: [^ self fail]! !

!Parser methodsFor: 'error correction' stamp: 'sma 4/28/2000 19:00'!
removeUnusedTemps 
	| str end start madeChanges | 

	madeChanges _ false.
	str _ requestor text string.
	((tempsMark between: 1 and: str size)
		and: [(str at: tempsMark) = $|]) ifFalse: [^ self].
	encoder unusedTempNames do:
		[:temp |
		((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption:
			((temp , ' appears to be
unused in this method.
OK to remove it?') asText makeBoldFrom: 1 to: temp size))
			= 1
		ifTrue:
		[(encoder encodeVariable: temp) isUndefTemp
			ifTrue:
			[end _ tempsMark.
			["Beginning at right temp marker..."
			start _ end - temp size + 1.
			end < temp size or: [temp = (str copyFrom: start to: end)
					and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]]
			whileFalse:
				["Search left for the unused temp"
				end _ requestor nextTokenFrom: end direction: -1].
			end < temp size ifFalse:
				[(str at: start-1) = $  ifTrue: [start _ start-1].
				requestor correctFrom: start to: end with: ''.
				str _ str copyReplaceFrom: start to: end with: ''. 
				madeChanges _ true.
				tempsMark _ tempsMark - (end-start+1)]]
			ifFalse:
			[PopUpMenu notify:
'You''ll first have to remove the
statement where it''s stored into']]].
	madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! !

!Parser methodsFor: 'error correction'!
substituteSelector: selectorParts wordIntervals: spots
	"Substitute the correctSelector into the (presuamed interactive) receiver."
	| offset |
	offset _ 0.
	selectorParts with: spots do:
		[ :word :interval |
		offset _ self substituteWord: word wordInterval: interval offset: offset ]
! !

!Parser methodsFor: 'error correction'!
substituteWord: correctWord wordInterval: spot offset: o
	"Substitute the correctSelector into the (presuamed interactive) receiver."

	requestor correctFrom: (spot first + o)
					to: (spot last + o)
					with: correctWord.

	requestorOffset _ requestorOffset + correctWord size - spot size.
	^ o + correctWord size - spot size! !


!Parser methodsFor: 'private'!
addComment

	parseNode ~~ nil
		ifTrue: 
			[parseNode comment: currentComment.
			currentComment _ nil]! !

!Parser methodsFor: 'private'!
init: sourceStream notifying: req failBlock: aBlock

	requestor _ req.
	failBlock _ aBlock.
	super scan: sourceStream.
	prevMark _ hereMark _ mark.
	requestorOffset _ 0.
	self advance! !

!Parser methodsFor: 'private'!
initPattern: aString notifying: req return: aBlock

	| result |
	self
		init: (ReadStream on: aString asString)
		notifying: req
		failBlock: [^nil].
	encoder _ self.
	result _ aBlock value: (self pattern: false inContext: nil).
	encoder _ failBlock _ nil.  "break cycles"
	^result! !

!Parser methodsFor: 'private' stamp: 'di 3/29/1999 13:10'!
previousTokenSize
	"Answer the size of the previous token. Bugfix for Strings."

	| hereSize |
	hereType == #number ifTrue: [^ mark - prevMark].
	hereSize _ here ifNil: [0] ifNotNil: [here size].
	hereType == #string ifTrue: [^ hereSize + 2].   "One for each single quote"
	^ hereSize! !


!Parser methodsFor: 'primitives'!
allocateLiteral: lit
	encoder litIndex: lit! !

!Parser methodsFor: 'primitives' stamp: 'hg 2/29/2000 10:41'!
externalFunctionDeclaration
	"Parse the function declaration for a call to an external library."
	| descriptorClass callType retType externalName args argType module fn |
	descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil].
	descriptorClass == nil ifTrue:[^0].
	callType _ descriptorClass callingConventionFor: here.
	callType == nil ifTrue:[^0].
	"Parse return type"
	self advance.
	retType _ self externalType: descriptorClass.
	retType == nil ifTrue:[^self expected:'return type'].
	"Parse function name or index"
	externalName _ here.
	(self match: #string) 
		ifTrue:[externalName _ externalName asSymbol]
		ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']].
	(self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list'].
	args _ WriteStream on: Array new.
	[here == #)] whileFalse:[
		argType _ self externalType: descriptorClass.
		argType == nil ifTrue:[^self expected:'argument'].
		argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType].
	].
	(self matchToken:')' asSymbol) ifFalse:[^self expected:')'].
	(self matchToken: 'module:') ifTrue:[
		module _ here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module _ module asSymbol].
	Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn|
		fn _ xfn name: externalName 
				module: module 
				callType: callType
				returnType: retType
				argumentTypes: args contents.
		self allocateLiteral: fn.
	].
	^120! !

!Parser methodsFor: 'primitives' stamp: 'ar 12/2/1999 16:49'!
externalType: descriptorClass
	"Parse an return an external type"
	| xType |
	xType _ descriptorClass atomicTypeNamed: here.
	xType == nil ifTrue:["Look up from class scope"
		Symbol hasInterned: here ifTrue:[:sym|
			xType _ descriptorClass structTypeNamed: sym]].
	xType == nil ifTrue:[
		"Raise an error if user is there"
		self interactive ifTrue:[^nil].
		"otherwise go over it silently"
		xType _ descriptorClass forceTypeNamed: here].
	self advance.
	(self matchToken:#*)
		ifTrue:[^xType asPointerType]
		ifFalse:[^xType]! !

!Parser methodsFor: 'primitives'!
primitive
	| n |
	(self matchToken: #<) ifFalse: [^ 0].
	n _ self primitiveDeclarations.
	(self matchToken: #>) ifFalse: [^ self expected: '>'].
	^ n! !

!Parser methodsFor: 'primitives' stamp: 'ar 11/16/1999 22:01'!
primitiveDeclarations
	| prim module |
	(self matchToken: 'primitive:') ifFalse:[^self externalFunctionDeclaration].
	prim _ here.
	(self match: #number) ifTrue:[^prim].	"Indexed primitives"
	(self match: #string) ifFalse:[^self expected:'Integer or String'].
	(self matchToken: 'module:') ifTrue:[
		module _ here.
		(self match: #string) ifFalse:[^self expected: 'String'].
		module _ module asSymbol].
	(self allocateLiteral: (Array with: module with: prim asSymbol with: 0 with: 0)).
	^117! !
Notification subclass: #ParserRemovedUnusedTemps
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Tests'!
SystemWindow subclass: #PartsWindow
	instanceVariableNames: 'book prevButton nextButton menuButton openForEditing '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1998 16:41'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'parts window controls...' action: #invokePartsWindowMenu
! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:51'!
adjustBookControls
	| inner |
	prevButton ifNil: [^ self].
	prevButton align: prevButton topLeft with: (inner _ self innerBounds) topLeft + (32 @ -1).
	nextButton align: nextButton topRight with: inner topRight - (18 @ 1).
	menuButton align: menuButton topLeft with: inner topRight + (-42 @ 5).! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'RAA 12/26/2000 14:31'!
book: aBook

	book _ aBook.
	self addMorph: aBook frame: (0@0 extent: 1@1).
	book beSticky.
	self extent: aBook extent + (0@self labelHeight).
	nextButton target: aBook.
	prevButton target: aBook! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:30'!
closeEditing
	openForEditing _ false.
	self color: Color white.
	book pages do:
		[:aPage | aPage setPartsBinStatusTo: true]! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/8/1998 13:44'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 18:06'!
initialize
	| aFont aForm |
	super initialize.
	color _ Color white.
	openForEditing _ false.
	aFont _ Preferences standardButtonFont.
	self addMorph: (prevButton _ SimpleButtonMorph new borderWidth: 0;
			label: '<' font: aFont; color: Color transparent;
			setBalloonText: 'previous page';
			actionSelector: #previousPage; target: self; extent: 16@16).
	self addMorph: (nextButton _ SimpleButtonMorph new borderWidth: 0;
			label: '>' font: aFont; color: Color transparent;
			setBalloonText: 'next page';
			actionSelector: #nextPage; target: self; extent: 16@16).
	menuButton _ ThreePhaseButtonMorph new onImage: (aForm _ ScriptingSystem formAtKey: 'OfferToUnlock'); offImage: (ScriptingSystem formAtKey: 'OfferToLock'); pressedImage: (ScriptingSystem formAtKey: 'OfferToLock'); extent: aForm extent; state: #on.
	menuButton target: self; actionSelector: #toggleStatus; actWhen: #buttonUp.
	menuButton setBalloonText: 'open for editing'.
	self addMorph: menuButton.
"
	self addMorph: (menuButton _ SimpleButtonMorph new borderWidth: 0;
			label: '¥' font: aFont; color: Color transparent;
			actWhen: #buttonDown;
			actionSelector: #invokePartsWindowMenu; target: self; extent: 16@16)."

	self adjustBookControls! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/11/2000 07:33'!
invokePartsWindowMenu
	"Put up a menu offering parts-bin controls"

	| aMenu sel |
	aMenu _ MVCMenuMorph new.
	aMenu defaultTarget: aMenu.
	openForEditing
		ifTrue:
			[aMenu add: 'resume being a parts bin' selector: #selectMVCItem: argument:	#toggleStatus]
		ifFalse:
			[aMenu add: 'open for editing' selector: #selectMVCItem: argument:#toggleStatus].
	aMenu add: 'sort pages'	selector: #selectMVCItem: argument: #sortPages.
	aMenu add: 'save as Custom Parts Bin' selector: #selectMVCItem: argument: #saveAsCustomPartsBin.
	sel _ aMenu invokeAt: self primaryHand position in: self world.
	sel ifNotNil: [self perform: sel].
! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:30'!
openEditing
	openForEditing _ true.
	self color: Color green.
	book pages do:
		[:aPage | aPage setPartsBinStatusTo: false]! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/12/1998 17:46'!
saveAsCustomPartsBin
	| aBin |
	self closeEditing.
	labelString = 'Standard Parts' ifTrue: [self setLabel: 'Custom Parts'].
	aBin _ self veryDeepCopy.

	ScriptingSystem setCustomPartsBinFrom: aBin.
	self inform: 
'Okay; from now on, when you request
''custom parts bin'' from the ''authoring tools...''
menu, you will obtain a copy of this parts bin'! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:39'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ 115! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 17:12'!
sortPages
	book sortPages! !

!PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/7/1998 21:56'!
toggleStatus
	openForEditing _ openForEditing not.
	openForEditing
		ifTrue:
			[self openEditing.
			menuButton state: #off.
			menuButton setBalloonText: 'resume being a parts bin']
		ifFalse:
			[self closeEditing.
			menuButton state: #on.
			menuButton setBalloonText: 'open for editing']! !
Object subclass: #Password
	instanceVariableNames: 'cache sequence '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!Password commentStamp: '<historical>' prior: 0!
"Hold a password.  There are three ways to get the password.

If there is no password (sequence == nil), ask the user for it.

If the use supplied one during this session, return that.  It is cleared at shutDown.

If sequence is a number, get the server passwords off the disk.  File 'sqk.info' must be in the same folder 'Squeak.sources' file.  Decode the file.  Return the password indexed by sequence."!


!Password methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 21:08'!
decode: string
	"Xor with secret number -- just so file won't have raw password in it"
	| kk rand |
	rand _ Random new seed: 234237.
	kk _ (ByteArray new: string size) collect: [:bb | (rand next * 255) asInteger].
	1 to: kk size do: [:ii |
		kk at: ii put: ((kk at: ii) bitXor: (string at: ii) asciiValue)].
	^ kk asString! !

!Password methodsFor: 'as yet unclassified' stamp: 'mdr 9/4/2000 10:47'!
serverPasswords
	"Get the server passwords off the disk and decode them. The file 'sqk.info' must be in the same folder as the Squeak application (VM) that is running this image. (Note: This code works even if you are running with no system sources file.)"

	| dir encodedPasswords |
	dir _ FileDirectory on: Smalltalk vmPath.
	(dir fileExists: 'sqk.info') ifFalse: [^ nil].	"Caller will ask user for password"
	encodedPasswords _ (dir readOnlyFileNamed: 'sqk.info') contentsOfEntireFile.
		"If you don't have this file, and you really do want to release 
		an update, contact Ted Kaehler."
	^ (self decode: encodedPasswords) findTokens: String cr
! !


!Password methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
cache: anObject
	cache _ anObject! !

!Password methodsFor: 'accessing' stamp: 'jcg 12/28/2000 21:02'!
passwordFor: serverDir
	"Returned the password from one of many sources.  OK if send in a nil arg."

	| sp msg |
	cache ifNotNil: [^ cache].
	sequence ifNotNil: [
		(sp _ self serverPasswords) ifNotNil: [
			sequence <= sp size ifTrue: [^ sp at: sequence]]].
	msg _ (serverDir isKindOf: ServerDirectory)
		ifTrue: [serverDir moniker]
		ifFalse: ['this directory'].
	(serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [
			^ cache _ FillInTheBlank request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs
			initialAnswer: 'yourName@company.com'].

	^ cache _ FillInTheBlank requestPassword: 'Password for ', msg, ':'.
		"Diff between empty string and abort?"! !

!Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:14'!
sequence: anNumber
	sequence _ anNumber! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Password class
	instanceVariableNames: ''!

!Password class methodsFor: 'as yet unclassified' stamp: 'tk 6/24/1999 11:36'!
shutDown
	"Forget all cached passwords, so they won't stay in the image"

	self allSubInstancesDo: [:each | each cache: nil].! !
BorderedMorph subclass: #PasteUpMorph
	instanceVariableNames: 'presenter model cursor padding backgroundMorph turtleTrailsForm turtlePen lastTurtlePositions isPartsBin autoLineLayout indicateCursor resizeToFit wantsMouseOverHalos worldState griddingOn '
	classVariableNames: 'DisableDeferredUpdates MinCycleLapse StillAlive '
	poolDictionaries: ''
	category: 'Morphic-Worlds'!
!PasteUpMorph commentStamp: '<historical>' prior: 0!
A morph whose submorphs comprise a paste-up of rectangular subparts which "show through".

Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided.

A World, the entire Smalltalk screen, is a PasteUpMorph.  A World responds true to isWorld.  Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:.  A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu.

This class is young and still under construction, and a number of its (many) instance variables are not yet fully deployed.!


!PasteUpMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 15:09'!
initialize
	owner _ nil.
	submorphs _ EmptyArray.
	borderWidth _ 1.
	borderColor _ Color r: 0.861 g: 1.0 b: 0.722.
	color _ Color r: 0.8 g: 1.0 b: 0.6.
	bounds _ 0@0 corner: 50@40.
	cursor _ 1.
	padding _ 3.
	self enableDragNDrop.
	self isWorldMorph ifTrue: [self setProperty: #automaticPhraseExpansion toValue: true].
	self clipSubmorphs: true.! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'sw 1/30/2001 22:45'!
newPlayerInstance
	"Answer a naked CardPlayer instance given that one does not yet exist; hence, launch a uniclass and answer an instance of it.  cf inherited version."

	^ UnscriptedCardPlayer newUserInstance! !

!PasteUpMorph methodsFor: 'initialization' stamp: 'tk 2/3/2000 21:38'!
releaseCachedState

	super releaseCachedState.
	turtleTrailsForm ifNotNil: [turtleTrailsForm hibernate].! !


!PasteUpMorph methodsFor: 'classification' stamp: 'ar 9/28/2000 13:51'!
isFlap
	^self hasProperty: #flap! !

!PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'!
isWorldMorph

	^ worldState notNil! !

!PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'!
world

	worldState == nil ifTrue: [^ super world].
	^ self! !


!PasteUpMorph methodsFor: 'cursor' stamp: 'di 7/27/1999 10:24'!
cursor 
	^ cursor
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/7/2000 11:43'!
cursor: aNumber
	"for backward compatibility"

	self cursorWrapped: aNumber! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/7/2000 11:42'!
cursorWrapped: aNumber
	"Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed."

	| truncP |
	cursor ~= aNumber ifTrue: 
		[cursor _ self asNumber: aNumber.
		truncP _ cursor truncated.
		truncP > submorphs size ifTrue:
			[submorphs size > 0
				ifTrue: [cursor _ cursor \\ submorphs size]
				ifFalse: [cursor _ 1]].
		truncP < 0 ifTrue: [cursor _ 1].
		self changed]
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/8/2000 16:41'!
numberAtCursor
	"Answer the number represented by the object at my current cursor position"

	| chosenMorph |
	submorphs isEmpty ifTrue: [^ 0].
	chosenMorph _ submorphs at: ((cursor truncated max: 1) min: submorphs size).
	^ chosenMorph getNumericValue
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'!
rectifyCursor
	cursor _ ((cursor truncated max: 1) min: submorphs size)
! !

!PasteUpMorph methodsFor: 'cursor'!
selectedRect
	"Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph."

	| p |
	p _ cursor asInteger.
	p > submorphs size ifTrue: [p _ submorphs size].
	p < 1 ifTrue: [p _ 1].
	^ (submorphs at: p) fullBounds expandBy: 2.
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 9/8/2000 16:42'!
valueAtCursor
	"Answer the submorph of mine indexed by the value of my 'cursor' slot"

	submorphs isEmpty ifTrue: [^ self presenter standardPlayer costume].
	^ submorphs at: ((cursor truncated max: 1) min: submorphs size)
! !

!PasteUpMorph methodsFor: 'cursor' stamp: 'sw 5/12/1998 10:55'!
valueAtCursor: aMorph
	submorphs isEmpty ifTrue: [^ self].
	self rectifyCursor.
	self replaceSubmorph: self valueAtCursor by: aMorph! !


!PasteUpMorph methodsFor: 'display' stamp: 'bf 5/4/2000 15:27'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^ true! !

!PasteUpMorph methodsFor: 'display' stamp: 'bf 5/6/2000 12:25'!
color: aColor
	"For backwards compatibility with GradientFillMorph"

	self flag: #fixThis.
	self removeProperty: #fillStyle.
	^ super color: aColor! !

!PasteUpMorph methodsFor: 'display' stamp: 'di 8/28/2000 23:24'!
drawOn: aCanvas
	"Update and draw the turtleTrails form. See the comment in updateTrailsForm."

	super drawOn: aCanvas.
	(self griddingOn and: [self gridVisible]) ifTrue:
		[aCanvas fillRectangle: self bounds fillStyle:
			(self gridFormOrigin: self gridOrigin + self position grid: self gridModulus background: nil line: Color lightGray)].
	self updateTrailsForm.
	turtleTrailsForm ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].

	(submorphs size > 0 and: [self indicateCursor]) ifTrue:
		[aCanvas
			frameRectangle: self selectedRect
			width: 2
			color: Color black].

! !

!PasteUpMorph methodsFor: 'display' stamp: 'bf 5/6/2000 12:31'!
gradientFillColor: aColor
	"For backwards compatibility with GradientFillMorph"

	self flag: #fixThis.
	self useGradientFill.
	self fillStyle colorRamp: {0.0 -> color. 1.0 -> aColor}.
	self changed
! !

!PasteUpMorph methodsFor: 'display' stamp: 'sw 10/18/2000 10:54'!
printOn: aStream
	"Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is"

	super printOn: aStream.
	self isWorldMorph ifTrue: [aStream nextPutAll: ' [world]']! !

!PasteUpMorph methodsFor: 'display' stamp: 'ar 10/5/2000 18:52'!
setGradientColor: evt
	"For backwards compatibility with GradientFillMorph"

	self flag: #fixThis.
	self changeColorTarget: self selector: #gradientFillColor:
		originalColor: (self fillStyle isGradientFill
			ifTrue: [self fillStyle colorRamp last value]
			ifFalse: [color])
		hand: evt hand.! !


!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'tk 1/22/2001 13:35'!
acceptDroppingMorph: dropped event: evt
	"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"

	| mm tfm aMorph |
	aMorph _ self morphToDropFrom: dropped.
	self isWorldMorph
		ifTrue:["Add the given morph to this world and start stepping it if it wants to be."
				self addMorphFront: aMorph.
				(aMorph fullBounds intersects: self viewBox) ifFalse:
					[self beep.  aMorph position: self bounds center]]
		ifFalse:[super acceptDroppingMorph: aMorph event: evt].

	aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
	aMorph allMorphsDo:  "Establish any penDown morphs in new world"
		[:m | m player ifNotNil:
			[m player getPenDown ifTrue:
				[((mm _ m player costume) notNil and: [(tfm _ mm owner transformFrom: self) notNil])
					ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition)
									forPlayer: m player]]]].

	self isPartsBin
		ifTrue:
			[aMorph isPartsDonor: true.
			aMorph stopSteppingSelfAndSubmorphs.
			aMorph suspendEventHandler]
		ifFalse:
			[self world startSteppingSubmorphsOf: aMorph].

	self presenter morph: aMorph droppedIntoPasteUpMorph: self.

	self showingListView ifTrue:
		[self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
		self currentWorld abandonAllHalos]! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 6/18/1998 09:10'!
automaticPhraseExpansion
	^ self hasProperty: #automaticPhraseExpansion! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/6/1999 08:39'!
automaticViewing
	^ self hasProperty: #automaticViewing! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 1/25/2001 19:49'!
dropFiles: anEvent
	"Handle a number of dropped files from the OS.
	TODO:
		- use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu)
		- remember the resource location or (when in browser) even the actual file handle
	"
	| numFiles stream sketch type |
	numFiles _ anEvent contents.
	1 to: numFiles do:[:i|
		stream _ FileStream requestDropStream: i.
		type _ stream mimeTypes.
		type ifNotNil:[type _ type first]. "for now just use the first one"
		"only image files will be handled for now"
		(type notNil and:[type beginsWith: 'image/']) ifTrue:[
			stream binary.
			sketch _ SketchMorph withForm: (Form fromBinaryStream: stream).
			self addMorph: sketch centeredNear: anEvent position.
		] ifFalse:[
			"just get us a text editor"
			stream edit.
		].
	].! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 9/1/2000 05:37'!
justDroppedInto: aMorph event: anEvent
	"This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph"

	super justDroppedInto: aMorph event: anEvent.
	self isPartsBin ifTrue: [self setPartsBinStatusTo: true]  "gets some things right about the subtle case of dropping a parts bin"
! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'tk 1/22/2001 13:50'!
morphToDropFrom: aMorph
	"Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited.  Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."

	| aNail representee handy posBlock tempPos |
	handy _ self primaryHand.
	posBlock _ [:z | 
			tempPos _ handy position - (handy targetOffset - aMorph formerPosition * (z extent / aMorph extent)) rounded.
			self pointFromWorld: tempPos].
	self alwaysShowThumbnail
		ifTrue: [aNail _ aMorph
						representativeNoTallerThan: self maxHeightToAvoidThumbnailing
						norWiderThan: self maximumThumbnailWidth
						thumbnailHeight: self heightForThumbnails.
			aNail == aMorph
				ifFalse: [aNail
						position: (posBlock value: aNail)].
			^ aNail].
	((aMorph isKindOf: MorphThumbnail)
			and: [(representee _ aMorph morphRepresented) owner == nil])
		ifTrue: [representee
				position: (posBlock value: representee).
			^ representee].

	self showingListView ifTrue:
		[^ aMorph listViewLineForFieldList: (self valueOfProperty: #fieldListSelectors)].

	(aMorph hasProperty: #newPermanentScript)
		ifTrue: [^ aMorph asEmptyPermanentScriptor].
	self automaticPhraseExpansion
		ifFalse: [^ aMorph].
	((aMorph isKindOf: PhraseTileMorph) or: [aMorph isKindOf: SyntaxMorph])
		ifFalse: [^ aMorph].
	^ aMorph morphToDropInPasteUp: self! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/6/1999 13:26'!
originAtCenter
	^ self hasProperty: #originAtCenter! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 5/2/1998 11:31'!
positionNear: aPoint forExtent: anExtent adjustmentSuggestion: adjustmentPoint
	"Compute a plausible positioning for adding a subpart of size anExtent, somewhere near aPoint, using adjustmentPoint as the unit of adjustment"

	| adjustedPosition |
	adjustedPosition _ aPoint.
	[((self morphsAt: (adjustedPosition + (anExtent // 2))) size > 1) and:  "that 1 is self here"
		[bounds containsPoint: adjustedPosition]]
	whileTrue:
		[adjustedPosition _ adjustedPosition + adjustmentPoint].

	^ adjustedPosition! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'!
repelsMorph: aMorph event: ev
	(aMorph wantsToBeDroppedInto: self) ifFalse: [^ false].
	self dropEnabled ifFalse: [^ true].
	(self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true].
	^ super repelsMorph: aMorph event: ev "consults #repelling flag"! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 1/10/2001 21:29'!
wantsDropFiles: anEvent
	^self isWorldMorph! !

!PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'!
wantsDroppedMorph: aMorph event: evt
	self isWorldMorph ifTrue:[^true]. "always"
	self visible ifFalse: [^ false].  "will be a call to #hidden again very soon"
	self dropEnabled ifFalse: [^ false].
	^ true! !


!PasteUpMorph methodsFor: 'layout' stamp: 'sw 3/24/1999 14:11'!
addCenteredAtBottom: aMorph offset: anOffset
	"Add aMorph beneath all other morphs currently in the receiver, centered horizontally, with the vertical offset from the bottom of the previous morph given by anOffset"
	| curBot |
	curBot _ 0.
	submorphs do: [:m | curBot _ curBot max: m bottom].
	self addMorphBack: aMorph.
	aMorph position: ((self center x - (aMorph width // 2)) @ (curBot + anOffset))! !

!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:47'!
convertAlignment
	self clipSubmorphs: true.
	(autoLineLayout == true) ifTrue:[
		self layoutPolicy: TableLayout new.
		self layoutInset: 8; cellInset: 4.
		self listDirection: #leftToRight; wrapDirection: #topToBottom.
		self minHeight: self height.
	] ifFalse:[
		self layoutPolicy: nil.
		self layoutInset: 0; cellInset: 0.
	].
	(resizeToFit == true) ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!PasteUpMorph methodsFor: 'layout' stamp: 'sw 8/3/1998 13:43'!
laySubpartsOutInOneRow
	| aPosition |
	aPosition _ 0 @ padding.
	submorphs do:
	[:aMorph |
		aMorph position: (aPosition + (padding @ 0)).
		aPosition _ aMorph topRight]! !

!PasteUpMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 13:43'!
layoutChanged
	"The receiver's layout changed; inform above and below"
	super layoutChanged.
	(self valueOfProperty: #SqueakPage) ifNotNil: [
		self setProperty: #pageDirty toValue: true].
		"I am the morph of a SqueakPage, I have changed and 
		need to be written out again"
! !


!PasteUpMorph methodsFor: 'menu & halo' stamp: 'di 9/21/2000 08:19'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	"Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo.  Copied down from morph and hand-edited for the world"

	self isWorldMorph ifFalse: [^ super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph].

	aMenu addLine.
	aMenu add: 'copy Postscript' action: #clipPostscript.
	aMenu add: 'print PS to file...' target: self selector: #printPSToFile.
	aMenu addLine.
	self addFillStyleMenuItems: aMenu hand: aHandMorph.
	aMenu
		defaultTarget: self;
		add: 'add mouse up action' action: #addMouseUpAction;
		add: 'remove mouse up action' action: #removeMouseUpAction;
		defaultTarget: aHandMorph.
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:20'!
addCustomMenuItems: menu hand: aHandMorph

	super addCustomMenuItems: menu hand: aHandMorph.
	self addStackMenuItems: menu hand: aHandMorph.
	self addPenMenuItems: menu hand: aHandMorph.
	self addPlayfieldMenuItems: menu hand: aHandMorph.
	(self isWorldMorph and: [owner isKindOf: BOBTransformationMorph]) ifTrue: [
		self addScalingMenuItems: menu hand: aHandMorph.
	].

	menu addLine! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/30/2000 18:12'!
addPenMenuItems: menu hand: aHandMorph
	"Add a pen-trails-within submenu to the given menu"

	| subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	self addPenTrailsMenuItemsTo: subMenu.
	menu add: 'pens trails within...' subMenu: subMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/30/2000 18:12'!
addPenTrailsMenuItemsTo: aMenu
	| oldTarget |
	"Add items relating to pen trails to aMenu"

	oldTarget _ aMenu defaultTarget.
	aMenu defaultTarget: self.
	aMenu add: 'clear pen trails' action: #clearTurtleTrails.
	aMenu add: 'all pens up' action: #liftAllPens.
	aMenu add: 'all pens down' action: #lowerAllPens.
	aMenu defaultTarget: oldTarget! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/16/1999 09:04'!
addPlayfieldMenuItems: menu hand: aHandMorph

	menu add: 'playfield options...' target: self action: #presentPlayfieldMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 7/13/2000 10:28'!
addScalingMenuItems: menu hand: aHandMorph

	| subMenu |

	(subMenu _ MenuMorph new)
		defaultTarget: self;
		add: 'show application view' action: #showApplicationView;
		add: 'show factory view' action: #showFactoryView;
		add: 'show whole world view' action: #showFullView;
		add: 'expand' action: #showExpandedView;
		add: 'reduce' action: #showReducedView;
		addLine;
		add: 'define application view' action: #defineApplicationView;
		add: 'define factory view' action: #defineFactoryView.
	menu
		add: 'world scale and clip...'
		subMenu: subMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/23/2000 14:41'!
addStackMenuItems: menu hand: aHandMorph
	"Add appropriate stack-related items to the given menu"

	self isStackBackground
		ifTrue:
			[menu add: 'card & stack...' target: self action: #presentCardAndStackMenu]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:50'!
autoExpansionString
	"Answer the string to be shown in a menu to represent the auto-phrase-expansion status"

	^ (self hasProperty: #automaticPhraseExpansion)
		ifTrue:
			['<on>auto-phrase-expansion']
		ifFalse:
			['<off>auto-phrase-expansion']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:50'!
autoLineLayoutString
	"Answer the string to be shown in a menu to represent the auto-line-layout status"

	^ self autoLineLayout
		ifTrue:
			['<on>auto-line-layout']
		ifFalse:
			['<off>auto-line-layout']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:51'!
autoViewingString
	"Answer the string to be shown in a menu to represent the automatic-viewing status"

	^ self automaticViewing
		ifTrue:
			['<on>automatic viewing']
		ifFalse:
			['<off>automatic viewing']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/25/2000 06:06'!
batchPenTrailsString
	"Answer the string to be shown in a menu to represent the batch-pen-trails enabled status"

	^ self batchPenTrails
		ifTrue:
			['<on>batch pen trails']
		ifFalse:
			['<off>batch pen trails']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'ar 10/5/2000 17:04'!
buildDebugMenu: aHandMorph
	| aMenu |
	aMenu _ super buildDebugMenu: aHandMorph.
	aMenu add:  'abandon costume history' target: self action: #abandonCostumeHistory.
	^ aMenu! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 1/10/2000 16:44'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"
	^ true
	! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:31'!
defineApplicationView

	| r |
	r _ Rectangle fromUser.
	self 
		setProperty: #applicationViewBounds 
		toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:29'!
defineFactoryView

	| r |
	r _ Rectangle fromUser.
	self 
		setProperty: #factoryViewBounds 
		toValue: ((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated ! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'ar 10/3/2000 17:02'!
deleteBalloonTarget: aMorph
	"Delete the balloon help targeting the given morph"
	self handsDo:[:h| h deleteBalloonTarget: aMorph].! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 10/4/2000 08:23'!
fenceEnabledString
	"Answer the string to be shown in a menu to represent the fence enabled status"

	^self fenceEnabled
		ifTrue:
			['<on>fence enabled']
		ifFalse:
			['<off>fence enabled']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:51'!
indicateCursorString
	"Answer the string to be shown in a menu to represent the whether-to-indicate-cursor status"

	^ self indicateCursor
		ifTrue:
			['<on>indicate cursor']
		ifFalse:
			['<off>indicate cursor']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:51'!
isOpenForDragNDropString
	"Answer the string to be shown in a menu to represent the open-to-drag-n-drop status"

	^ self dragNDropEnabled
		ifTrue:
			['<on>open to drag & drop']
		ifFalse:
			['<off>open to drag & drop']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:51'!
isPartsBinString
	"Answer the string to be shown in a menu to represent the parts-bin status"

	^ self isPartsBin
		ifTrue:
			['<on>parts bin']
		ifFalse:
			['<off>parts bin']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 11/6/2000 14:08'!
mightEntertainDirectionHandles
	"Answer whether the receiver, by its very nature, might possibly be happy to have direction handles shown for it in its halo"

	^ false! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:54'!
mouseOverHalosString
	"Answer the string to be shown in a menu to represent the mouse-over-halos status"

	^ self wantsMouseOverHalos
		ifTrue:
			['<on>mouse-over halos']
		ifFalse:
			['<off>mouse-over halos']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:54'!
originAtCenterString
	"Answer the string to be shown in a menu to represent the origin-at-center status"

	^ (self hasProperty: #originAtCenter)
		ifTrue:
			['<on>origin-at-center']
		ifFalse:
			['<off>origin-at-center']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 1/8/2001 15:14'!
playfieldOptionsMenu
	"Answer an auxiliary menu with options specific to playfields -- too many to be housed in the main menu"

	| aMenu isWorld |
	isWorld _ self isWorldMorph.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	aMenu add: 'save on file...' action: #saveOnFile.
	aMenu add: 'save as SqueakPage at url...' action: #saveOnURL.
	aMenu add: 'update all from resources' action: #updateAllFromResources.
	(self valueOfProperty: #classAndMethod) ifNotNil:
		[aMenu add: 'broadcast as documentation' action: #saveDocPane].
	aMenu add: 'round up strays' action: #roundUpStrays.
	aMenu balloonTextForLastItem:  'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.'.
	aMenu add: 'show all players' action: #showAllPlayers.
	aMenu balloonTextForLastItem:  'Make visible the viewers for all players which have user-written scripts in this playfield.'.
	aMenu add: 'hide all players' action: #hideAllPlayers.
	aMenu balloonTextForLastItem:  'Make invisible the viewers for all players in this playfield. This will save space before you publish this project'.


	aMenu addLine.
	aMenu add: 'shuffle contents' action: #shuffleSubmorphs.
	aMenu balloonTextForLastItem: 'Rearranges my contents in random order'.
	self griddingOn
		ifTrue: [aMenu add: 'turn gridding off' action: #griddingOnOff.
				aMenu add: (self gridVisible ifTrue: ['hide'] ifFalse: ['show']) , ' grid'
						action: #gridVisibleOnOff.
				aMenu add: 'set grid spacing...' action: #setGridSpec]
		ifFalse: [aMenu add: 'turn gridding on' action: #griddingOnOff].
	aMenu addLine.

	#(	(autoLineLayoutString	toggleAutoLineLayout
			'whether submorphs should automatically be laid out in lines')
		(indicateCursorString	toggleIndicateCursor
			'whether the "current" submorph should be indicated with a dark black border')
		(isPartsBinString		toggleIsPartsBin
			'whether dragging an object from the interior should produce a COPY of the object')
		(isOpenForDragNDropString	toggleDragNDrop
			'whether objects can be dropped into and dragged out of me')
		(mouseOverHalosString	toggleMouseOverHalos
			'whether objects should put up halos when the mouse is over them')
		(autoExpansionString	toggleAutomaticPhraseExpansion
			'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
		(originAtCenterString	toggleOriginAtCenter
			'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
		(showThumbnailString	toggleAlwaysShowThumbnail
			'whether large objects should be represented by thumbnail miniatures of themselves')
		(fenceEnabledString	toggleFenceEnabled
			'whether moving objects should stop at the edge of their container')
		(batchPenTrailsString	toggleBatchPenTrails 
			'if true, detailed movement of pens between display updates is ignored.  Thus multiple line segments drawn within a script may not be seen individually.')

	) do:

			[:triplet |
				(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail) includes: triplet second]) ifFalse:
					[aMenu addUpdating: triplet first action: triplet second.
					aMenu balloonTextForLastItem: triplet third]]. 

	aMenu addUpdating: #autoViewingString action: #toggleAutomaticViewing.
	aMenu balloonTextForLastItem:  'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.'.

	((isWorld not or: [self backgroundSketch notNil]) or: [presenter isNil])
		ifTrue:
			[aMenu addLine].

	isWorld ifFalse:
		[aMenu add: 'set thumbnail height...' action: #setThumbnailHeight.
		aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them'.
		aMenu add: 'behave like a Holder' action: #becomeLikeAHolder.
		aMenu balloonTextForLastItem: 'Set properties to make this object nicely set up to hold frames of a scripted animation.'].

	self backgroundSketch ifNotNil:
		[aMenu add: 'delete background painting' action: #deleteBackgroundPainting.
		aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.'].
	presenter ifNil:
		[aMenu add: 'make detachable' action: #makeDetachable.
		aMenu balloonTextForLastItem: 'Allow this area to be separately governed by its own controls.'].

	aMenu addLine.
	aMenu add: 'use standard texture' action: #setStandardTexture.
	aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.'.
	aMenu add: 'make graph paper...' action: #makeGraphPaper.
	aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.'.
	aMenu addTitle: 'playfield options...'.

	^ aMenu
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 10/26/2000 11:32'!
presentCardAndStackMenu
	"Put up a menu holding card/stack-related options."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.		
	aMenu addStayUpItem.
	aMenu addTitle: 'card und stack'.
	aMenu add: 'add new card' action: #insertCard.
	aMenu add: 'delete this card' action: #deleteCard.
	aMenu add: 'go to next card' action: #goToNextCardInStack.
	aMenu add: 'go to previous card' action: #goToPreviousCardInStack.
	aMenu addLine.
	aMenu add: 'show foreground objects' action: #showForegroundObjects.
	aMenu add: 'show background objects' action: #showBackgroundObjects.
	aMenu add: 'show designations' action: #showDesignationsOfObjects.
	aMenu add: 'explain designations'  action: #explainDesignations.
	aMenu popUpInWorld: (self world ifNil: [self currentWorld])! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/12/2000 09:14'!
presentPlayfieldMenu

	self playfieldOptionsMenu popUpForHand: self activeHand in: self world! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 1/3/2001 06:43'!
presentViewMenu
	"Answer an auxiliary menu with options specific to viewing playfields -- this is put up from the provisional 'view' halo handle, on pasteup morphs only."

	| aMenu isWorld |
	isWorld _ self isWorldMorph.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addStayUpItem.
	self addViewingItemsTo: aMenu.

	#(	"(autoLineLayoutString	toggleAutoLineLayout
			'whether submorphs should automatically be laid out in lines')"
		(indicateCursorString	toggleIndicateCursor
			'whether the "current" submorph should be indicated with a dark black border')
		(resizeToFitString		toggleResizeToFit
			'whether I should automatically strive exactly to fit my contents')
		(behaveLikeAHolderString	toggleBehaveLikeAHolder
			'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.')
		(isPartsBinString		toggleIsPartsBin
			'whether dragging an object from the interior should produce a COPY of the object')
		(isOpenForDragNDropString	toggleDragNDrop
			'whether objects can be dropped into and dragged out of me')
		(mouseOverHalosString	toggleMouseOverHalos
			'whether objects should put up halos when the mouse is over them')
		(autoExpansionString	toggleAutomaticPhraseExpansion
			'whether tile phrases, dropped on me, should automatically sprout Scriptors around them')
		(originAtCenterString	toggleOriginAtCenter
			'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield')
		(showThumbnailString	toggleAlwaysShowThumbnail
			'whether large objects should be represented by thumbnail miniatures of themselves')
		(fenceEnabledString	toggleFenceEnabled
			'whether moving objects should stop at the edge of their container')
		(autoViewingString		toggleAutomaticViewing
			'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.')
		(griddingString			griddingOnOff
			'whether gridding should be used in my interior')
		(gridVisibleString		gridVisibleOnOff
			'whether the grid should be shown when gridding is on')


	) do:

			[:triplet |
				(isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail toggleAutomaticViewing ) includes: triplet second]) ifFalse:
					[aMenu addUpdating: triplet first action: triplet second.
					aMenu balloonTextForLastItem: triplet third]]. 

	aMenu addLine.
	aMenu add: 'round up strays' action: #roundUpStrays.
	aMenu balloonTextForLastItem:  'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.'.
	aMenu add: 'shuffle contents' action: #shuffleSubmorphs.
	aMenu balloonTextForLastItem: 'Rearranges my contents in random order'.
	aMenu add: 'set grid spacing...' action: #setGridSpec.
	aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on'.

	isWorld ifFalse:
		[aMenu add: 'set thumbnail height...' action: #setThumbnailHeight.
		aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them'].

	self backgroundSketch ifNotNil:
		[aMenu add: 'delete background painting' action: #deleteBackgroundPainting.
		aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.'].
	aMenu addLine.
	self addPenTrailsMenuItemsTo: aMenu.
	aMenu addLine.
	aMenu add: 'use standard texture' action: #setStandardTexture.
	aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.'.
	aMenu add: 'make graph paper...' action: #makeGraphPaper.
	aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.'.
	aMenu addTitle: 'viewing options for "', self externalName, '"'.

	aMenu popUpForHand: self activeHand in: self world
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 2/3/2001 16:45'!
saveOnFile
	"Ask the user for a filename and save myself on a SmartReferenceStream file.  Writes out the version and class structure.  The file is fileIn-able.  UniClasses will be filed out."

	| aFileName fileStream ok |

	self flag: #bob0302.
	self isWorldMorph ifTrue: [^self project storeLocallyOnly].

	aFileName _ ('my ', self class name) asFileName.	"do better?"
	aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' 
			initialAnswer: aFileName.
	aFileName size == 0 ifTrue: [^ self beep].
	self allMorphsDo: [:m | m prepareToBeSaved].

	ok _ aFileName endsWith: '.project'.	"don't double them"
	ok _ ok | (aFileName endsWith: '.sp').
	ok ifFalse: [aFileName _ aFileName,'.project'].
	fileStream _ FileStream newFileNamed: aFileName.
	fileStream fileOutClass: nil andObject: self.	"Puts UniClass definitions out anyway"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'!
showApplicationView

	self transformToShow: (self valueOfProperty: #applicationViewBounds ifAbsent: [bounds])
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:47'!
showExpandedView

	owner	"the transform"
		owner	"the green border"
			bounds: Display boundingBox! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:33'!
showFactoryView

	self transformToShow: (self valueOfProperty: #factoryViewBounds ifAbsent: [bounds])
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 7/13/2000 10:17'!
showFullView

	self transformToShow: bounds
		! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 11:46'!
showReducedView

	| r |
	r _ Display extent // 4 extent: Display extent // 2.
	owner	"the transform"
		owner	"the green border"
			bounds: r! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 9/21/2000 22:53'!
showThumbnailString
	"Answer the string to be shown in a menu to represent the show-thumbnails status"

	^( self hasProperty: #alwaysShowThumbnail)
		ifTrue:
			['<on>show thumbnails']
		ifFalse:
			['<off>show thumbnails']
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'RAA 6/26/2000 19:10'!
transformToShow: aRectangle

	owner changeWorldBoundsToShow: aRectangle
! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'di 9/26/2000 21:39'!
wantsDirectionHandles

	^ super wantsDirectionHandles and: [self isWorldMorph not]! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'ar 10/11/2000 18:22'!
wantsHaloFor: aSubMorph
	"Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph"

	^ wantsMouseOverHalos == true and:
		 [self visible and:
			[isPartsBin ~~ true and:
				[self dropEnabled and:
					[self isWorldMorph not or: [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]]

	"The odd logic at the end of the above says...

		*  If we're an interior playfield, then if we're set up for mouseover halos, show em.
		*  If we're a World that's set up for mouseover halos, only show 'em if the putative
				recipient is a SketchMorph.

	This (old) logic was put in to suit a particular need in early e-toy days and seems rather strange now!!"! !

!PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 1/25/2000 17:44'!
wantsHaloFromClick
	^ (owner isKindOf: SystemWindow) not! !


!PasteUpMorph methodsFor: 'model' stamp: 'sw 5/13/1998 00:21'!
createCustomModel
	"Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class."

	model == nil ifFalse: [^ self].
	model _ MorphicModel newSubclass new.
! !

!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:18'!
model
	"Return the model object for this world. If the world has no model, then create one."

	self createCustomModel.
	^ model! !

!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:18'!
modelOrNil
	"Return the model object for this world, or nil if it doesn't have one."

	^ model
! !

!PasteUpMorph methodsFor: 'model' stamp: 'sw 4/1/98 21:17'!
setModel: aModelMorph
	"Set the model for this world. Methods for sensitized morphs will be compiled into the class for this model."

	model _ aModelMorph
! !


!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:48'!
autoLineLayout
	| layout |
	layout _ self layoutPolicy ifNil:[^false].
	layout isTableLayout ifFalse:[^false].
	self listDirection == #leftToRight ifFalse:[^false].
	self wrapDirection == #topToBottom ifFalse:[^false].
	^true! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 15:07'!
autoLineLayout: aBoolean
	"Make the receiver be viewed with auto-line-layout, which means that its submorphs will be laid out left-to-right and then top-to-bottom in the manner of a word processor, or (if aBoolean is false,) cease applying auto-line-layout"

	aBoolean ifTrue:
		[self viewingNormally ifTrue: [self saveBoundsOfSubmorphs]].
	aBoolean ifTrue:[
		self layoutPolicy: TableLayout new.
		self layoutInset: 8; cellInset: 4.
		self listDirection: #leftToRight; wrapDirection: #topToBottom.
	] ifFalse:[
		self layoutPolicy: nil.
		self layoutInset: 0; cellInset: 0.
	].
! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 9/28/1998 13:15'!
automaticViewing: aBoolean
	self setProperty: #automaticViewing toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:04'!
batchPenTrails
	"Answer whether pen trails should be batched in the receiver"

	^ self valueOfProperty: #batchPenTrails ifAbsent: [Preferences batchPenTrails]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:05'!
batchPenTrails: aBoolean

	self setProperty: #batchPenTrails toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 14:06'!
becomeLikeAHolder
	(self autoLineLayout and: [self indicateCursor])
		ifTrue:
			[^ self inform: 'This view is ALREADY
behaving like a holder, which
is to say, it is set to indicate the
cursor and to have auto-line-layout.'].
 
	self behaveLikeHolder
	! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/17/2000 12:02'!
behaveLikeAHolderString
	"Answer a string to be displayed in a menu to characterize whether the receiver is currently behaving like a holder"

	^ (self behavingLikeAHolder ifTrue: ['<yes>'] ifFalse: ['<no>']), 'behave like a holder'! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:36'!
behaveLikeHolder
 
	self resizeToFit: true; autoLineLayout: true; indicateCursor: true! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:36'!
behaveLikeHolder: aBoolean
 	"Change the receiver's viewing properties such that they conform to what we commonly call a Holder, viz: resize-to-fit, do auto-line-layout, and indicate the 'cursor'"

	self resizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean
	! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/17/2000 12:04'!
behavingLikeAHolder
	"Answer whether the receiver is currently behaving like a Holder"

	^ self resizeToFit and: [self indicateCursor and: [self autoLineLayout]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'RAA 10/4/2000 08:24'!
fenceEnabled

	^ self valueOfProperty: #fenceEnabled ifAbsent: [Preferences fenceEnabled]! !

!PasteUpMorph methodsFor: 'options' stamp: 'RAA 10/4/2000 08:24'!
fenceEnabled: aBoolean

	self setProperty: #fenceEnabled toValue: aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:58'!
indicateCursor
	^ indicateCursor == true! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/1/98 16:59'!
indicateCursor: aBoolean
	indicateCursor _ aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/13/1998 18:15'!
isPartsBin
	^ isPartsBin == true! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 4/23/1998 16:49'!
isPartsBin: aBoolean
	isPartsBin _ aBoolean! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 11/13/1998 09:55'!
replaceTallSubmorphsByThumbnails
	|  itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
	heightForThumbnails _ self heightForThumbnails.
	maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing.
	maxWidthForThumbnails _ self maximumThumbnailWidth.
	self submorphs do:
		[:aMorph |
			itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
			(aMorph == itsThumbnail)
				ifFalse:
					[self replaceSubmorph: aMorph by: itsThumbnail]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:49'!
resizeToFit
	^self vResizing == #shrinkWrap! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/9/2000 12:49'!
resizeToFit: aBoolean
	aBoolean ifTrue:[
		self vResizing: #shrinkWrap.
	] ifFalse:[
		self vResizing: #rigid.
	].! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/18/2000 10:58'!
resizeToFitString
	"Answer a string, to be used in a self-updating menu, to represent whether the receiver is currently using resize-to-fit or not"

	^ (self resizeToFit ifTrue: ['<yes>'] ifFalse: ['<no>']), 'resize to fit'! !

!PasteUpMorph methodsFor: 'options' stamp: 'panda 4/25/2000 15:42'!
setPartsBinStatusTo: aBoolean
	isPartsBin _ aBoolean.
	aBoolean ifFalse: [self enableDragNDrop].
		"but note that we no longer reset openToDragNDrop to false upon making it a parts bin again"
	isPartsBin
		ifTrue:
			[submorphs do:
				[:m | m isPartsDonor: true.
					m stopStepping.
					m suspendEventHandler]]
		ifFalse:
			[submorphs do:
				[:m | m isPartsDonor: false.
					m restoreSuspendedEventHandler].
			self world ifNotNil: [self world startSteppingSubmorphsOf: self]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 11:05'!
setThumbnailHeight
	|  reply |
	(self hasProperty: #alwaysShowThumbnail) ifFalse:
		[^ self inform: 'setting the thumbnail height is only
applicable when you are currently
showing thumbnails.'].
	reply _ FillInTheBlank
		request: 'New height for thumbnails? '
		initialAnswer: self heightForThumbnails printString.
	reply isEmpty ifTrue: [^ self].
	reply _ reply asNumber.
	(reply > 0 and: [reply <= 150]) ifFalse:
		[^ self inform: 'Please be reasonable!!'].
	self setProperty: #heightForThumbnails toValue: reply.
	self updateSubmorphThumbnails! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1998 16:26'!
toggleAlwaysShowThumbnail
	(self hasProperty: #alwaysShowThumbnail)
		ifTrue:
			[self removeProperty: #alwaysShowThumbnail]
		ifFalse:
			[self setProperty: #alwaysShowThumbnail toValue: true].
	self updateSubmorphThumbnails! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'!
toggleAutoLineLayout
	"Toggle the auto-line-layout setting"

	self autoLineLayout: self autoLineLayout not.
	self autoLineLayout ifFalse: [self restoreBoundsOfSubmorphs].! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/18/1998 09:12'!
toggleAutomaticPhraseExpansion
	| expand |
	expand _ self hasProperty: #automaticPhraseExpansion.
	expand
		ifTrue:
			[self removeProperty: #automaticPhraseExpansion]
		ifFalse:
			[self setProperty: #automaticPhraseExpansion toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/18/1998 09:13'!
toggleAutomaticViewing
	| current |
	current _ self automaticViewing.
	current
		ifTrue:
			[self removeProperty: #automaticViewing]
		ifFalse:
			[self setProperty: #automaticViewing toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/25/2000 06:06'!
toggleBatchPenTrails
	
	self batchPenTrails: self batchPenTrails not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/23/2000 19:04'!
toggleBehaveLikeAHolder
	"Toggle whether or not the receiver is currently behaving like a holder"

	self behaveLikeHolder: (self behavingLikeAHolder not)! !

!PasteUpMorph methodsFor: 'options' stamp: 'RAA 10/4/2000 08:26'!
toggleFenceEnabled
	
	self fenceEnabled: self fenceEnabled not! !

!PasteUpMorph methodsFor: 'options' stamp: 'ar 11/8/2000 22:37'!
toggleIndicateCursor
	indicateCursor _ self indicateCursor not.
	self changed.! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 9/30/1998 17:24'!
toggleIsPartsBin
	"Not entirely happy with the openToDragNDrop not being directly manipulable etc, but still living with it for now."
	self setPartsBinStatusTo: self isPartsBin not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 1/27/2000 14:51'!
toggleMouseOverHalos
	wantsMouseOverHalos _ self wantsMouseOverHalos not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1999 13:36'!
toggleOriginAtCenter
	| hasIt |
	hasIt _ self hasProperty: #originAtCenter.
	hasIt
		ifTrue:
			[self removeProperty: #originAtCenter]
		ifFalse:
			[self setProperty: #originAtCenter toValue: true]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 10/23/2000 19:04'!
toggleResizeToFit
	"Toggle whether the receiver is set to resize-to-fit"

	self resizeToFit: self resizeToFit not! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 11/13/1998 09:56'!
updateSubmorphThumbnails
	| thumbsUp itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
	thumbsUp _ self alwaysShowThumbnail.
	heightForThumbnails _ self heightForThumbnails.
	maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing.
	maxWidthForThumbnails _ self maximumThumbnailWidth.
	self submorphs do:
		[:aMorph | thumbsUp
			ifTrue:
				[itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
				(aMorph == itsThumbnail)
					ifFalse:
						[self replaceSubmorph: aMorph by: itsThumbnail]]
			ifFalse:
				[(aMorph isKindOf: MorphThumbnail)
					ifTrue:
						[self replaceSubmorph: aMorph by: aMorph morphRepresented]]]! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'!
wantsMouseOverHalos
	^ wantsMouseOverHalos == true! !

!PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'!
wantsMouseOverHalos: aBoolean
	wantsMouseOverHalos _ aBoolean! !


!PasteUpMorph methodsFor: 'painting' stamp: 'sw 4/1/98 16:37'!
backgroundSketch

	backgroundMorph ifNil: [^ nil].
	backgroundMorph owner ifNil:
		[backgroundMorph _ nil].	"has been deleted"
	^ backgroundMorph! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 10/17/2000 11:56'!
backgroundSketch: aSketchMorphOrNil
	"Set the receiver's background graphic as indicated.  If nil is supplied, remove any existing background graphic.  In any case, delete any preexisting background graphic."

	backgroundMorph ifNotNil: [backgroundMorph delete].  "replacing old background"

	aSketchMorphOrNil ifNil: [backgroundMorph _ nil.  ^ self].

	backgroundMorph _ StickySketchMorph new form: aSketchMorphOrNil form.
	backgroundMorph position: aSketchMorphOrNil position.
	self addMorphBack: backgroundMorph.
	aSketchMorphOrNil delete.
	backgroundMorph lock.
	backgroundMorph setProperty: #shared toValue: true.
	^ backgroundMorph
! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 6/16/1999 11:16'!
deleteBackgroundPainting
	backgroundMorph
		ifNotNil:
			[backgroundMorph delete.
			backgroundMorph _ nil]
		ifNil:
			[self inform: 'There is presently no
background painting
to delete.']! !

!PasteUpMorph methodsFor: 'painting' stamp: 'ar 10/5/2000 19:18'!
makeNewDrawingWithin
	| evt |
	evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand.
	self primaryHand makeNewDrawing: evt
! !

!PasteUpMorph methodsFor: 'painting' stamp: 'ar 10/5/2000 19:11'!
paintBackground
	| pic rect |
	self world abandonAllHalos.
	self world stopRunningAll.
	pic _ self backgroundSketch.
	pic ifNotNil: [pic editDrawingIn: self forBackground: true]		"need to resubmit it? (tck comment)"
		ifNil: [rect _ self bounds.
			pic _ self world drawingClass new form: 
				(Form extent: rect extent depth: Display depth).
			pic bounds: rect.
			"self world addMorphBack: pic.  done below"
			pic _ self backgroundSketch: pic.	"returns a different guy"
			pic ifNotNil: [pic editDrawingIn: self forBackground: true]]! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/22/1998 12:26'!
paintingBoundsAround: aPoint
	"Return a rectangle for painting centered on the given point. Both the argument point and the result rectangle are in world coordinates."

	| paintExtent maxPaintArea myBnds |
	paintExtent _ self reasonablePaintingExtent.
	maxPaintArea _ paintExtent x * paintExtent y.
	myBnds _ self boundsInWorld.
	(myBnds area <= maxPaintArea) ifTrue: [^ myBnds].
	^ (aPoint - (paintExtent // 2) extent: paintExtent) intersect: myBnds
! !

!PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/29/1998 07:35'!
reasonablePaintingExtent
	^ Preferences unlimitedPaintArea
		ifTrue:
			[3000 @ 3000]
		ifFalse:
			[Preferences defaultPaintingExtent]! !


!PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/1/98 16:38'!
clearTurtleTrails

	turtleTrailsForm _ nil.
	turtlePen _ nil.
	self changed.
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 5/23/2000 16:54'!
createOrResizeTrailsForm
	"If necessary, create a new turtleTrailsForm or resize the existing one to fill my bounds. On return, turtleTrailsForm exists and is the correct size."

	| newForm |
	turtleTrailsForm ifNil:
		["create new TrailsForm if needed"
		turtleTrailsForm _ Form extent: self extent depth: 8.
		turtlePen _ nil].

	turtleTrailsForm extent = self extent ifFalse:
		["resize TrailsForm if my size has changed"
		newForm _ Form extent: self extent depth: 8.
		newForm copy: self bounds from: turtleTrailsForm
					to: 0@0 rule: Form paint.
		turtleTrailsForm _ newForm.
		turtlePen _ nil].

	"Recreate Pen for this form"
	turtlePen ifNil: [turtlePen _ Pen newOnForm: turtleTrailsForm].! !

!PasteUpMorph methodsFor: 'pen' stamp: 'ar 3/14/2000 23:23'!
drawPenTrailFor: aMorph from: oldPoint to: targetPoint
	"Draw a pen trail for aMorph, using its pen state (the pen is assumed to be down)."
	"The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."
	| origin mPenSize offset turtleTrailsDelta newPoint |
	turtleTrailsDelta _ self valueOfProperty: #turtleTrailsDelta ifAbsent:[0@0].
	newPoint _ targetPoint - turtleTrailsDelta.
	oldPoint = newPoint ifTrue:[^self].
	self createOrResizeTrailsForm.
	origin _ self topLeft.
	mPenSize _ aMorph getPenSize.
	turtlePen sourceForm width ~= mPenSize
		ifTrue: [turtlePen squareNib: mPenSize].
	offset _ (mPenSize // 2)@(mPenSize // 2).
	turtlePen color: aMorph getPenColor.
	turtlePen drawFrom: (oldPoint - origin - offset) asIntegerPoint
				to: (newPoint - origin - offset) asIntegerPoint.
	self invalidRect: ((oldPoint rect: newPoint) expandBy: mPenSize)
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:47'!
liftAllPens
	submorphs do: [:m | m assuredPlayer liftPen]! !

!PasteUpMorph methodsFor: 'pen' stamp: 'sw 8/11/1998 16:47'!
lowerAllPens
	submorphs do: [:m | m assuredPlayer lowerPen]
! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 5/24/2000 15:13'!
noteNewLocation: location forPlayer: player
	"Note that a morph has just moved with its pen down, begining at startPoint.
	Only used in conjunction with Preferences batchPenTrails."

	lastTurtlePositions ifNil: [lastTurtlePositions _ IdentityDictionary new].
	lastTurtlePositions at: player put: location! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 5/24/2000 15:10'!
notePenDown: penDown forPlayer: player at: location
	"Note that a morph has just moved with its pen down, begining at startPoint.
	Only used in conjunction with Preferences batchPenTrails."

	| startLoc |
	lastTurtlePositions ifNil: [lastTurtlePositions _ IdentityDictionary new].
	penDown
		ifTrue: ["Putting the Pen down -- record current location"
				(lastTurtlePositions includesKey: player) ifFalse:
					[lastTurtlePositions at: player put: location]]
		ifFalse: ["Picking the Pen up -- draw to current location and remove"
				(startLoc _ lastTurtlePositions at: player ifAbsent: [nil]) ifNotNil:
					[self drawPenTrailFor: player costume
							from: startLoc to: location].
				lastTurtlePositions removeKey: player ifAbsent: []]! !

!PasteUpMorph methodsFor: 'pen' stamp: 'di 9/10/1998 16:17'!
trailMorph
	"Yes, you can draw trails on me."
	^ self! !

!PasteUpMorph methodsFor: 'pen' stamp: 'RAA 7/13/2000 18:39'!
updateTrailsForm 
	"Update the turtle-trails form using the current positions of all pens.
	Only used in conjunction with Preferences batchPenTrails."

	"Details: The positions of all morphs with their pens down are recorded each time the draw method is called. If the list from the previous display cycle isn't empty, then trails are drawn from the old to the new positions of those morphs on the turtle-trails form. The turtle-trails form is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."

	| morph oldPoint newPoint removals player tfm |

	self flag: #bob.		"transformations WRONG here"

	(lastTurtlePositions == nil or: [lastTurtlePositions size = 0]) ifTrue: [^ self].

	removals _ OrderedCollection new.
	lastTurtlePositions associationsDo: [:assoc |
		player _ assoc key.
		morph _ player costume.
		(player getPenDown and: [morph trailMorph == self])
			 ifTrue:
				[oldPoint _ assoc value.
				tfm _ morph owner transformFrom: self.
				newPoint _ tfm localPointToGlobal: morph referencePosition.
				newPoint = oldPoint ifFalse:
					[assoc value: newPoint.
					self drawPenTrailFor: morph from: oldPoint to: newPoint]]
			ifFalse: [removals add: player]].
	removals do: [:key | lastTurtlePositions removeKey: key ifAbsent: []]! !


!PasteUpMorph methodsFor: 'scripting' stamp: 'tk 1/31/2001 15:58'!
allTileScriptingElements
	"Answer a list of all the morphs that pertain to tile-scripting.  A sledge-hammer"

	| all morphs |
	morphs _ IdentitySet new: 400.
	self allMorphsAndBookPagesInto: morphs.
	all _ morphs select: [:s | s isTileScriptingElement].
"	self closedViewerFlapTabs do:
		[:aTab | all addAll: aTab referent allTileScriptingElements].
"
	^ all asOrderedCollection! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'RAA 1/8/2001 15:17'!
hideAllPlayers

	| a |
	a _ OrderedCollection new.
	self allMorphsDo: [ :x | 
		(x isKindOf: ViewerFlapTab) ifTrue: [a add: x]
	].
	a do: [ :each | each delete].
! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'sw 1/25/2000 13:07'!
isCandidateForAutomaticViewing
	"A viewer on a world is a dangerous thing to get casually!!"

	^ self isWorldMorph not! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'tk 6/14/1998 15:18'!
scriptorForTextualScript: aSelector ofPlayer: aPlayer
	| aScriptor |
	self world ifNil: [^ nil].
	aScriptor _ ScriptEditorMorph new setMorph: aPlayer costume scriptName: aSelector.
	aScriptor position: (self primaryHand position - (10 @ 10)).
	^ aScriptor! !

!PasteUpMorph methodsFor: 'scripting' stamp: 'RAA 1/8/2001 15:24'!
showAllPlayers

	| a |
	a _ OrderedCollection new.
	self allMorphsDo: [ :x | 
		(x player notNil and: [x player hasUserDefinedScripts]) ifTrue: [a add: x]
	].
	a do: [ :each | each openViewerForArgument].
! !


!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/26/2000 10:56'!
beAStackBackground
	"Transform the receiver into one that has stack-background behavior.  If just becoming a stack, allocate a uniclass to represent the cards (if one does not already exist"

	self assuredPlayer assureUniClass.
	self setProperty: #tabAmongFields toValue: true.
	self setProperty: #stackBackground toValue: true.
	self reassessBackgroundShape! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/19/2000 19:15'!
currentDataInstance
	"Answer the current data instance"

	^ self player! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 1/25/2000 13:34'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ self isWorldMorph
		ifFalse:
			[super defaultNameStemForInstances]
		ifTrue:
			['world']! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 5/8/1998 13:39'!
doWrap
	"Determine whether a 'next' request at the end of my list should wrap around to the beginning, etc."

	self flag: #deferred.  "Hang this maybe on a property"
	^ true! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/31/2000 04:59'!
explainDesignations
	"Hand the user an object that contains explanations for the designation feedback used"

	StackMorph designationsExplainer openInHand

	"self currentWorld explainDesignations"! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/23/2000 16:03'!
insertCard
	"Insert a new card in the stack, with the receiver as its background, and have it become the current card of the stack"

	self stackDo: [:aStack | aStack insertCardOfBackground: self]! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 1/29/2001 18:18'!
installAsCurrent: anInstance
	"Install anInstance as the one currently viewed in the receiver.  Dock up all the morphs in the receiver which contain data rooted in the player instance to the instance data.  Run any 'opening' scripts that pertain."

	| fieldList itsFocus |
	self player == anInstance ifTrue: [^ self].
	fieldList _ self allMorphs select:
		[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]].
	self currentWorld hands do:
		[:aHand | (itsFocus _ aHand keyboardFocus) notNil ifTrue:
			[(fieldList includes: itsFocus) ifTrue: [aHand newKeyboardFocus: nil]]].

	self player uninstallFrom: self.  "out with the old"

	anInstance installPrivateMorphsInto: self.
	self changed.
	anInstance costume: self.
	self player: anInstance.
	self player class variableDocks do:
		[:aVariableDock | aVariableDock dockMorphUpToInstance: anInstance].
	self currentWorld startSteppingSubmorphsOf: self.
	anInstance runAllOpeningScripts! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/26/2000 10:58'!
isStackBackground
	"Answer whether the receiver serves as a background of a stack"

	^ (owner isKindOf: StackMorph) or: [self hasProperty: #stackBackground]

	"This odd property-based check is because when a paste-up-morph is not the *current* background of a stack, it is maddeningly ownerlyess"! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/23/2000 17:02'!
newCard
	"Create a new card for the receiver and return it"

	| aNewInstance |
	self isStackBackground ifFalse: [^ self beep].  "bulletproof against deconstruction"
	aNewInstance _ self player class baseUniclass new.
	^ aNewInstance! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 11/3/2000 17:06'!
reassessBackgroundShape
	"A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'."

	| takenNames uniqueName requestedName  variableDocks docks |

	"Caution: still to be done: the mechanism so that when a new instance variable is added, it gets initialized in all subinstances of the receiver's player, which are the cards of this shape.  One needs to take into account here the instance variable names coming in; those that are unchanged should keep their values, but those that have newly arrived should obtain their default values from the morphs on whose behalf they are being maintained in the model"

	true ifTrue: "Cursor wait showWhile:"
		[variableDocks _ OrderedCollection new.  "This will be stored in the uniclass's class-side inst var #variableDocks"
		takenNames _ OrderedCollection new.
		(self submorphs select: [:aMorph | aMorph holdsSeparateDataForEachInstance]) do: 
			[:aMorph |
				docks _ aMorph variableDocks.  
		"Each morph can request multiple variables.  
		This complicates matters somewhat but creates a generality for Fabrk-like uses.
		Each spec is an instance of VariableDock, and it provides a point of departure
		for the negotiation between the PasteUp and its constitutent morphs"
				docks do:
					[:aVariableDock |
						uniqueName _ self player uniqueInstanceVariableNameLike: (requestedName _ aVariableDock variableName) excluding: takenNames.
						uniqueName ~= requestedName ifTrue:
							[aVariableDock variableName: uniqueName.
							aMorph noteNegotiatedName: uniqueName for: requestedName].

						takenNames add: uniqueName].
				variableDocks addAll: docks].
		
		self player class setNewInstVarNames: 
			(variableDocks collect: [:info | info variableName asString]).  "NB: sets up accessors, and removes obsolete ones"
		self player class newVariableDocks: variableDocks]
! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/18/2000 10:57'!
relaxGripOnVariableNames
	"Abandon any memory of specific variable names that should be preserved.  The overall situation here is not yet completely understood, and this relaxation is basically always done on each reassessment of the background shape nowadays.  But this doesn't feel quite right, because if the user has somehow intervened to specify certain name preference we should perhaps honored it.  Or perhaps that is no longer relevant.  ????"

	self submorphs do:
		[:m | m removeProperty: #variableName.
		m removeProperty: #setterSelector].
	self reassessBackgroundShape
! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/18/2000 10:58'!
reshapeBackground
	"Abandon any memory of variable-name preferences, and reassess the shape of the background"

	self relaxGripOnVariableNames.
	self reassessBackgroundShape.! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/23/2000 19:00'!
showBackgroundObjects
	"Momentarily highlight just the background objects on the current playfield"

	self isStackBackground ifFalse: [^ self].
	self invalidRect: self bounds.
	self currentWorld doOneCycle.
	Display restoreAfter:
		[self submorphsDo:
			[:aMorph | (aMorph renderedMorph hasProperty: #shared)
				ifTrue:
					[Display border: (aMorph fullBoundsInWorld insetBy:  -6) width: 6 rule: Form over fillColor: Color blue]]]! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/23/2000 19:00'!
showDesignationsOfObjects
	"Momentarily show the designations of objects on the receiver"

	| colorToUse aLabel |
	self isStackBackground ifFalse: [^ self].
	
	self submorphsDo: [:aMorph | 
		aMorph renderedMorph holdsSeparateDataForEachInstance 
			ifTrue:
				[colorToUse _ Color orange.
				aLabel _ aMorph externalName]
			ifFalse:
				[colorToUse _ aMorph isShared
					ifFalse:	[Color red]
					ifTrue:	[Color green].
				aLabel _ nil].
		Display border: (aMorph fullBoundsInWorld insetBy:  -6) width: 6 rule: Form over fillColor: colorToUse.
		aLabel ifNotNil:
			[aLabel asString displayOn: Display at: (aMorph fullBoundsInWorld bottomLeft + (0 @ 5))]].
	Sensor anyButtonPressed
		ifTrue:	[Sensor waitNoButton]
		ifFalse:	[Sensor waitButton].

	Display repaintMorphicDisplay! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/23/2000 19:00'!
showForegroundObjects
	"Temporarily highlight the foreground objects"

	self isStackBackground ifFalse: [^ self].
	Display restoreAfter:
		[self submorphsDo:
			[:aMorph | aMorph renderedMorph isShared
				ifFalse:
					[Display border: (aMorph fullBoundsInWorld insetBy:  -6) width: 6 rule: Form over fillColor: Color orange]]]! !

!PasteUpMorph methodsFor: 'stack/card' stamp: 'sw 10/18/2000 11:01'!
tabHitWithEvent: anEvent
	"The tab key was hit. The keyboard focus has referred this event to me, though this perhaps seems rather backwards.  Anyway, the assumption is that I have the property #tabAmongFields, so now the task is to tab to the next field"

	| currentFocus fieldList anIndex itemToHighlight |

	currentFocus _ anEvent hand keyboardFocus.
	fieldList _ self allMorphs select:
		[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]].

	anIndex _ fieldList indexOf: currentFocus ifAbsent: [nil].
	itemToHighlight _ fieldList atWrap: 
		(anIndex ifNotNil: [anEvent shiftPressed ifTrue: [anIndex - 1] ifFalse: [anIndex + 1]]
				ifNil: [1]).
	anEvent hand newKeyboardFocus: itemToHighlight. self flag: #arNote. "really???"
	itemToHighlight editor selectAll.
	itemToHighlight invalidRect: itemToHighlight bounds 
! !


!PasteUpMorph methodsFor: 'misc' stamp: 'sw 9/9/1998 10:45'!
abandonCostumeHistory
	self allMorphsDo:
		[:m | m player ifNotNil: [m player forgetOtherCostumes]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/24/1998 19:46'!
allScriptEditors
	^ self allMorphs select:
		[:s | s isKindOf: ScriptEditorMorph]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/24/2000 13:51'!
allScriptors
	"Answer a list of all active scriptors running on behalf of the receiver.  This is a hook used in past demos and with a future life which however presently is vacuous"

	^ #()
"
	^ self allMorphs select: [:m | m isKindOf: Scriptor]"! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1998 14:19'!
alwaysShowThumbnail
	^ self hasProperty: #alwaysShowThumbnail! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'!
cachedOrNewThumbnailFrom: newThumbnail
	"If I have a cached thumbnail, and it is of the desired extent, then ruturn it.
	Otherwise produce one in newThumbnail and return it (after caching).
	This code parallels what happens in page: to match resultant extent."
	| cachedThumbnail scale ext |
	scale _ newThumbnail height / self fullBounds height.
	ext _ (self fullBounds extent * scale) truncated.
	(cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil:
		[cachedThumbnail extent = ext ifTrue: [^ cachedThumbnail]].
	self setProperty: #cachedThumbnail toValue: (newThumbnail page: self).
	^ newThumbnail! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1999 13:30'!
cartesianOrigin
	^ self originAtCenter
		ifFalse:
			[self bottomLeft]
		ifTrue:
			[self center]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 9/8/2000 18:52'!
closedViewerFlapTabs
	"Answer all the viewer flap tabs in receiver that are closed"

	^ self submorphs select:
		[:m | (m isKindOf: ViewerFlapTab) and: [m flapShowing not]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/23/2000 16:04'!
containsCard: aCard
	"Answer whether the given card belongs to the uniclass representing the receiver"

	^ self isStackBackground and: [aCard isKindOf: self player class baseUniclass]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 4/1/98 17:36'!
demandsBoolean
	"Sent by some scripting objects to their container"
	^ false! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'!
heightForThumbnails
	^ self valueOfProperty: #heightForThumbnails ifAbsent: [50]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/25/1999 22:44'!
hideViewerFlapsOtherThanFor: aPlayer
	self flapTabs do:
		[:aTab | (aTab isKindOf: ViewerFlapTab)
			ifTrue:
				[aTab scriptedPlayer == aPlayer
					ifFalse:
						[aTab hideFlap]]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 2/15/1999 19:32'!
impartPrivatePresenter
	presenter ifNil:
		[presenter _ Presenter new associatedMorph: self.
		presenter standardPlayer]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ar 9/28/2000 13:58'!
innocuousName
	^ (self isFlap)
		ifTrue:
			['flap']
		ifFalse:
			[super innocuousName]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ar 11/12/2000 18:53'!
invalidRect: damageRect from: aMorph
        "Clip damage reports to my bounds, since drawing is clipped to my bounds."

        self == self outermostWorldMorph 
                ifTrue: [worldState recordDamagedRect: damageRect]
                ifFalse: [super invalidRect: damageRect from: aMorph]
! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/29/98 21:50'!
isPlayfieldLike
	^ true! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/16/1999 11:09'!
makeDetachable
	presenter
		ifNil:
			[self impartPrivatePresenter.
			self borderWidth: 1;  borderColor: Color green darker]
		ifNotNil:
			[self inform: 'This view is ALREADY detachable']! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'!
maxHeightToAvoidThumbnailing
	^ self valueOfProperty: #maxHeightToAvoidThumbnailing ifAbsent: [80]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/13/1998 10:06'!
maximumThumbnailWidth
	^ self valueOfProperty: #maximumThumbnailWidth ifAbsent: [200 min: (self width - 10)]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/5/1999 16:07'!
mouseX
	^ self isInWorld
		ifTrue:
			[(self cursorPoint x) - self left]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/5/1999 16:55'!
mouseY
	^ self isInWorld
		ifTrue:
			[self bottom - (self cursorPoint y)]
		ifFalse:
			[0]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 8/16/2000 17:42'!
nameForCopyIfAlreadyNamed: aMorph
	"Answer a name to set for a copy of aMorph if aMorph itself is named, else nil"

	| aName usedNames |
	^ (aName _ aMorph knownName) ifNotNil:
		[usedNames _ self allKnownNames.
		Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 4/23/1998 18:50'!
padding: aNumber
	padding _ aNumber! !

!PasteUpMorph methodsFor: 'misc' stamp: 'RAA 6/1/2000 10:28'!
position: aPoint
	"Prevent moving a world (e.g. via HandMorph>>specialGesture:)"

	"for now, let's allow it and see what happens"

	self isWorldMorph ifFalse: [^super position: aPoint].
	super position: aPoint.
	self viewBox ifNotNil: [self viewBox: (aPoint extent: self viewBox extent)].

! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 9/3/1998 09:19'!
prepareToBeSaved

	super prepareToBeSaved.
	turtlePen _ nil! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 6/8/1999 14:06'!
presenter
	"Normally only the world will have a presenter, but the architecture supports individual localized presenters as well"

	^ presenter ifNil:
		[self isWorldMorph
			ifTrue: [presenter _ Presenter new associatedMorph: self]
			ifFalse: [super presenter]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 6/8/1999 14:22'!
residesInPartsBin
	"Answer true if the receiver is, or has some ancestor owner who is, a parts bin"

	self isWorldMorph
		ifTrue: [^ self isPartsBin]
		ifFalse: [^ self isPartsBin or: [super residesInPartsBin]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ar 9/28/2000 13:57'!
roundUpStrays
	self submorphsDo:
		[:m |
			(m isFlapOrTab)
				ifFalse:
					[m goHome.
					m isPlayfieldLike ifTrue: [m roundUpStrays]]]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'RAA 8/14/2000 12:10'!
shouldGetStepsFrom: aWorld

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^self outermostWorldMorph == aWorld
	].
	^super shouldGetStepsFrom: aWorld! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:45'!
smallThumbnailForPageSorter

	^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new smaller! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 3/23/2000 12:52'!
startRunningAll
	"Start running all scripted morphs.  Triggered by user hitting GO button"

	self presenter flushPlayerListCache.  "Inefficient, but makes sure things come right whenever GO hit"
	self presenter allExtantPlayers do: [:aPlayer | aPlayer costume residesInPartsBin ifFalse: [aPlayer startRunning]].
	self allScriptors do:
		[:aScriptor | aScriptor startRunningIfPaused].

	self world updateStatusForAllScriptEditors! !

!PasteUpMorph methodsFor: 'misc' stamp: 'RAA 8/14/2000 11:50'!
step

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^self runLocalStepMethods
	].
	super step! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/23/2000 19:03'!
stepAll
	"tick all the paused player scripts in the receiver"

	self presenter allExtantPlayers do:
		[:aPlayer | 
			aPlayer startRunning; step; stopRunning].

	self allScriptors do:
		[:aScript | aScript startRunningIfPaused; step; pauseIfTicking].
! !

!PasteUpMorph methodsFor: 'misc' stamp: 'RAA 8/14/2000 11:50'!
stepTime

	(self isWorldMorph and: [owner notNil]) ifTrue: [
		^1
	].
	^super stepTime! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/24/2000 07:33'!
stopRunningAll
	"Reset all ticking scripts to be paused.  Triggered by user hitting STOP button"

	self presenter allExtantPlayers do:
		[:aPlayer |
		aPlayer stopRunning].
	self allScriptors do:
		[:aScript | aScript pauseIfTicking].

	self world updateStatusForAllScriptEditors! !

!PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'!
thumbnailForPageSorter

	^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/1/1999 16:04'!
unhideHiddenObjects
	self allMorphsDo:
		[:m | m show]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/24/1998 19:47'!
updateStatusForAllScriptEditors
	self allScriptEditors do: [:anEditor | anEditor updateStatus]! !

!PasteUpMorph methodsFor: 'misc' stamp: 'ar 12/19/2000 18:58'!
viewerFlapTabFor: anObject
	"Open up a Viewer on aMorph in its own flap, creating it if necessary"

	| bottomMost aPlayer aFlapTab |
	bottomMost _ self top.
	aPlayer _ anObject isMorph ifTrue: [anObject assuredPlayer] ifFalse: [anObject objectRepresented].
	self flapTabs do:
		[:aTab | (aTab isKindOf: ViewerFlapTab)
			ifTrue:
				[bottomMost _ aTab bottom max: bottomMost.
				aTab scriptedPlayer == aPlayer
					ifTrue:
						[^ aTab]]].
	"Not found; make a new one"
	aFlapTab _ (Utilities newFlapTitled: anObject nameForViewer onEdge: #right inPasteUp: self)
		as: ViewerFlapTab.
	aFlapTab initializeFor: aPlayer topAt: bottomMost + 2.
	aFlapTab referent color: (Color green muchLighter alpha: 0.5).
	aFlapTab referent borderWidth: 0.
	aFlapTab referent setProperty: #automaticPhraseExpansion toValue: true.
	Preferences compactViewerFlaps 
		ifTrue:[aFlapTab makeFlapCompact: true].
	self addMorphFront: aFlapTab.
	aFlapTab adaptToWorld: self.
	^ aFlapTab! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/30/2000 17:27'!
viewerFlapTabForObject: anObject
	"Open up a Viewer on anObject in its own flap, creating it if necessary.  This is the viewer-for-any-object version of this method, but in the current corpus of code is not hooked up."

	| bottomMost aFlapTab |
	bottomMost _ 0.
	self flapTabs do:
		[:aTab | (aTab isKindOf: ViewerFlapTab)
			ifTrue:
				[bottomMost _ aTab bottom max: bottomMost.
				aTab scriptedPlayer == anObject
					ifTrue:
						[^ aTab]]].
	"Not found; make a new one"
	aFlapTab _ (Utilities newFlapTitled: anObject externalName onEdge: #right) as: ViewerFlapTab.
	aFlapTab initializeFor: anObject topAt: bottomMost + 2.
	aFlapTab referent color: (Color green muchLighter alpha: 0.5).
	aFlapTab referent setProperty: #automaticPhraseExpansion toValue: true.
	self addMorphFront: aFlapTab.
	aFlapTab adaptToWorld: self.
	^ aFlapTab! !

!PasteUpMorph methodsFor: 'misc' stamp: 'sw 5/6/1998 17:07'!
wantsKeyboardFocusFor: aSubmorph
	aSubmorph inPartsBin ifTrue: [^ false].
	aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true].
	^ super wantsKeyboardFocusFor: aSubmorph! !


!PasteUpMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"transition from project to worldState (8/16/1999)"
	worldState ifNil: [varDict at: 'project' ifPresent: [ :x | worldState _ x]].

	"elimination of specific gradient stuff (5/6/2000)"
	varDict at: 'fillColor2' ifPresent: [ :color2 |
		(color isColor and: [color2 isColor and: [color ~= color2]]) ifTrue: [
			self useGradientFill.
			self fillStyle
				colorRamp: {0.0 -> color. 1.0 -> color2};
				radial: false;
				origin: self position;
				direction: ((varDict at: 'gradientDirection') == #vertical 
					ifTrue:[0@self height] 
					ifFalse:[self width@0]).
		]
	].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !


!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:37'!
accommodateFlap: aFlapTab
	"Shift submorphs over, if appropriate"
	| offset |
	aFlapTab slidesOtherObjects ifTrue:
		[offset _ self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
		self shiftSubmorphsBy: offset]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 11/6/2000 11:41'!
addGlobalFlaps 
	"Must make global flaps adapt to world.  Do this even if not shown, so the old world will not be pointed at by the flaps."

	| use thisWorld |

	use _ true.
	(Preferences valueOfFlag: #useGlobalFlaps) ifFalse: [use _ false].
	CurrentProjectRefactoring currentFlapsSuppressed ifTrue: [use _ false].
	"Smalltalk isMorphic ifFalse: [use _ false]."
	thisWorld _ use 
		ifTrue: [self]
		ifFalse: [(PasteUpMorph new) initForProject:  "fake to be flap owner"
						WorldState new;
					bounds: (0@0 extent: 4000@4000);
					viewBox: (0@0 extent: 4000@4000)].
	
	Utilities globalFlapTabs do: [:aFlapTab |
		(CurrentProjectRefactoring isFlapEnabled: aFlapTab) ifTrue:
			[(aFlapTab world == thisWorld) ifFalse:
				[thisWorld addMorphFront: aFlapTab.
				aFlapTab adaptToWorld: thisWorld].	"always do"
			use ifTrue: [
				aFlapTab spanWorld.
				aFlapTab adjustPositionAfterHidingFlap.
				aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]].

"
	Utilities clobberFlapTabList.
	Utilities initializeStandardFlaps.
	self currentWorld deleteAllFlapArtifacts.
	self currentWorld addGlobalFlaps.
"! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/17/1999 16:02'!
assureFlapTabsFitOnScreen
	self flapTabs do:
		[:m | m fitOnScreen]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 10/30/2000 22:02'!
bringFlapTabsToFront
	(submorphs select:[:m| m isFlapOrTab]) do:[:m| self addMorphInLayer: m].! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 7/28/1999 15:42'!
correspondingFlapTab
	"If there is a flap tab whose referent is me, return it, else return nil"
	self currentWorld flapTabs do:
		[:aTab | aTab referent == self ifTrue: [^ aTab]].
	^ nil! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:55'!
deleteAllFlapArtifacts
	"self currentWorld deleteAllFlapArtifacts"

	self submorphs do:[:m | m isFlapOrTab ifTrue:[m delete]]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:56'!
deleteGlobalFlapArtifacts
	"self currentWorld deleteGlobalFlapArtifacts"

	| localFlaps |
	localFlaps _ self localFlapTabs collect: [:m | m referent].
	self submorphs do:
		[:m | 
			((m isFlapTab) and: [m isGlobal]) ifTrue: [m delete].
			m isFlap ifTrue:[(localFlaps includes: m) ifFalse: [m delete]]]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:56'!
flapTabs
	^ self submorphs select:[:m| m isFlapTab]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'ar 9/28/2000 13:57'!
localFlapTabs
	| globalList aList aFlapTab |
	globalList _ Utilities globalFlapTabsIfAny.
	aList _ OrderedCollection new.
	submorphs do:
		[:m | ((m isFlapTab) and: [(globalList includes: m) not])
			ifTrue:
				[aList add: m]
			ifFalse:
				[((m isFlap) and:
					[(aFlapTab _ m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil])
						ifTrue:
							[aList add: aFlapTab]]].
	^ aList! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/11/1999 10:53'!
offsetForAccommodating: anExtent onEdge: edgeSymbol
	"Answer a delta to be applied to my submorphs in order tfor anExtent to be slid inboard on the indicated edge"
	edgeSymbol == #left ifTrue: [^ anExtent x @ 0].
	edgeSymbol == #right ifTrue: [^ anExtent x negated @ 0].
	edgeSymbol == #top ifTrue: [^ 0 @ anExtent y].
	edgeSymbol == #bottom ifTrue: [^ 0 @ anExtent y negated].! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 6/25/1999 21:35'!
paintingFlapTab
	"If the receiver has a flap which has a paintbox, return it, else return nil"
	self flapTabs do:
		[:aTab | aTab referent submorphsDo:
			[:aMorph | (aMorph isKindOf: PaintBoxMorph) ifTrue: [^ aTab]]].
	^ nil! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'RAA 1/9/2001 06:59'!
releaseViewers
	"In preparation for saving, make the flapTabs release their viewers."

	self flapTabs do: [:ft | 
		(ft respondsTo: #hibernate) ifTrue: [ft hibernate]]! !

!PasteUpMorph methodsFor: 'flaps' stamp: 'sw 2/15/1999 20:36'!
removeAccommodationForFlap: aFlapTab
	"Shift submorphs over, if appropriate"
	| offset |
	aFlapTab slidesOtherObjects ifTrue:
		[offset _ self offsetForAccommodating: aFlapTab referent extent onEdge: aFlapTab edgeToAdhereTo.
		self shiftSubmorphsBy: offset negated]! !


!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
activeHand

	^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
canvas

	^ worldState canvas! !

!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
firstHand

	^ worldState hands first! !

!PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'!
hands

	^ worldState hands! !

!PasteUpMorph methodsFor: 'project state' stamp: 'RAA 5/24/2000 11:11'!
handsDo: aBlock

	^ worldState handsDo: aBlock! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 10/9/1999 22:51'!
isStepping: aMorph
	^ worldState isStepping: aMorph! !

!PasteUpMorph methodsFor: 'project state' stamp: 'ar 10/22/2000 16:43'!
isStepping: aMorph selector: aSelector
	^ worldState isStepping: aMorph selector: aSelector! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 06:45'!
listOfSteppingMorphs
	^ worldState listOfSteppingMorphs

"self currentWorld listOfSteppingMorphs"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 5/23/2000 03:46'!
modelWakeUp

	| aWindow |
	"I am the model of a SystemWindow, that has just been activated"
	owner == nil ifTrue: [^ self].  "Not in Morphic world"
	(owner isKindOf: TransformMorph) ifTrue: [^ self viewBox: self fullBounds].
	(aWindow _ self containingWindow) ifNotNil:
		[self viewBox = aWindow panelRect ifFalse:
			[self viewBox: aWindow panelRect]]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'!
stepListSize
	^ worldState stepListSize

"Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'!
stepListSummary
	^ worldState stepListSummary

"Transcript cr show: self currentWorld stepListSummary"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:59'!
steppingMorphsNotInWorld
	| all |
	all _ self allMorphs.
	^ self listOfSteppingMorphs select: [:m | (all includes: m) not]

	"self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! !

!PasteUpMorph methodsFor: 'project state' stamp: 'sw 12/13/1999 12:26'!
viewBox
	"This tortured workaround arises from a situation encountered in which a PasteUpMorph was directliy lodged as a submorph of another PasteUpMorph of identical size, with the former bearing flaps but the latter being the world"
	^ worldState ifNotNil: [worldState viewBox] ifNil: [self pasteUpMorph viewBox]! !

!PasteUpMorph methodsFor: 'project state' stamp: 'ar 9/15/2000 23:28'!
viewBox: newViewBox

	| vb |
	((vb _ self viewBox) == nil or: [vb extent ~= newViewBox extent])
		ifTrue: [worldState canvas: nil].

	worldState viewBox: newViewBox.
	super position: newViewBox topLeft.

"23 may 2000 - RAA - let's see if this is ok"

	bounds _ newViewBox.	"0@0 extent: newViewBox extent."
	"Paragraph problem workaround; clear selections to avoid screen droppings:"
	self flag: #arNote. "Probably unnecessary"
	worldState handsDo: [:h | h releaseKeyboardFocus].
	self fullRepaintNeeded.

! !


!PasteUpMorph methodsFor: 'update cycle' stamp: 'di 7/15/1999 09:51'!
startBackgroundProcess
	"Start a process to update this world in the background. Return the process created."

	| p |
	p _ [[true] whileTrue: [
		self doOneCycleInBackground.
		(Delay forMilliseconds: 20) wait]] newProcess.
	p resume.
	^ p
! !


!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:10'!
cleanseStepList
	"Remove morphs from the step list that are not in this World.  Often were in a flap that has moved on to another world."

	worldState cleanseStepListForWorld: self! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 6/7/2000 10:12'!
runLocalStepMethods

	worldState runLocalStepMethodsIn: self
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 10:27'!
runStepMethods

	worldState runStepMethodsIn: self
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:39'!
startStepping: aMorph
	"Add the given morph to the step list. Do nothing if it is already being stepped."
	^self startStepping: aMorph at: Time millisecondClockValue selector: #stepAt: arguments: nil stepTime: nil! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:08'!
stopStepping: aMorph
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph
! !

!PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:40'!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."

	worldState stopStepping: aMorph selector: aSelector
! !


!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 19:25'!
abandonAllHalos
	self flag: #arNote. "Remove the method"
	^self deleteAllHalos! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 22:29'!
activeHand: aHandMorph
	"temporarily retained for old main event loops"

	worldState activeHand: aHandMorph.

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
addAllMorphs: array

	super addAllMorphs: array.
	self isWorldMorph
		ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/26/2000 14:52'!
addHand: aHandMorph
	"Add the given hand to the list of hands for this world."

	aHandMorph owner ifNotNil:[aHandMorph owner removeHand: aHandMorph].
	worldState addHand: aHandMorph.
	aHandMorph privateOwner: self.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
addMorph: aMorph centeredNear: aPoint
	"Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world."

	| trialRect delta |
	trialRect _ Rectangle center: aPoint extent: aMorph fullBounds extent.
	delta _ trialRect amountToTranslateWithin: bounds.
	aMorph position: trialRect origin + delta.
	self addMorph: aMorph.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
addMorphsAndModel: aMorphOrList
	"Dump in submorphs, model, and stepList from aMorphOrList.  Used to bring a world, paste-up, or other morph in from an object file."

	aMorphOrList isMorph
		ifTrue:
			[aMorphOrList isWorldMorph
				ifFalse:
					["one morph, put on hand"
					"aMorphOrList installModelIn: self.  	a chance to install model pointers"
					aMorphOrList privateOwner: nil.
					self firstHand attachMorph: aMorphOrList.
					self startSteppingSubmorphsOf: aMorphOrList]
				ifTrue: 
					[model == nil
						ifTrue:
							[self setModel: (aMorphOrList modelOrNil)]
						ifFalse:
							[aMorphOrList modelOrNil ifNotNil:
								[aMorphOrList modelOrNil privateOwner: nil.
								self addMorph: (aMorphOrList modelOrNil)]].
					aMorphOrList privateSubmorphs reverseDo: [:m |
						m privateOwner: nil.
						self addMorph: m.
						m changed].
					(aMorphOrList instVarNamed: 'stepList') do:
						[:entry | entry first startSteppingIn: self]]]

		ifFalse:  "list, add them all"
			[aMorphOrList reverseDo: [:m |
				m privateOwner: nil.
				self addMorph: m.
				self startSteppingSubmorphsOf: m.	"It may not want this!!"
				m changed]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:09'!
allMorphsDo: aBlock
	"Enumerate all morphs in the world, including those held in hands."

	super allMorphsDo: aBlock.
	self isWorldMorph
		ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 13:55'!
allNonFlapRelatedSubmorphs
	"Answer all non-window submorphs that are not flap-related"
	^ submorphs select:
		[:m | (m isKindOf: SystemWindow) not and: [m isFlapOrTab not]]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 13:18'!
assureNotPaintingElse: aBlock
	"If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock"

	self sketchEditorOrNil ifNotNil:
		[self inform: 'Sorry, you can only paint
one object at a time'.
		Cursor normal show.
		^ aBlock value]
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:45'!
assuredCanvas
	
	^worldState assuredCanvas! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/19/2000 07:44'!
beWorldForProject: aProject

	self privateOwner: nil.
	worldState _ WorldState new.
	self addHand: HandMorph new.
	self setProperty: #automaticPhraseExpansion toValue: true.
	self setProperty: #optimumExtentFromAuthor toValue: Display extent.
	self startSteppingSubmorphsOf: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'bf 1/5/2000 19:25'!
chooseClickTarget
	Cursor crossHair showWhile:
		[Sensor waitButton].
	Cursor down showWhile:
		[Sensor anyButtonPressed].
	^ (self morphsAt: Sensor cursorPoint) first! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
colorAt: aPoint belowMorph: aMorph
	"Return the color of the pixel immediately behind the given morph at the given point.
	NOTE: due to some bounds wobble in flexing, we take the middle of 3x3 rect."
	^ (self patchAt: (aPoint-1 extent: 3) without: aMorph andNothingAbove: true)
		colorAt: 1@1
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/15/2000 23:28'!
deEmphasizeViewMVC: asTwoTone
	self flag: #arNote. "Probably unnecessary"
	worldState handsDo:          "free dependents links if any"
		[:h | h releaseKeyboardFocus].
	worldState canvas: nil.		"free model's canvas to save space"
	self fullReleaseCachedState.
	asTwoTone ifTrue: [
		"draw deEmphasized as a two-tone (monochrome) form"
		self displayWorldAsTwoTone].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/17/2000 15:33'!
deleteAllHalos
	self haloMorphs do:
		[:m | (m target isKindOf: SelectionMorph) ifTrue: [m target delete].
		m delete].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'!
displayWorld

	self outermostWorldMorph privateOuterDisplayWorld
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 13:20'!
displayWorldAsTwoTone
	"Display the world in living black-and-white. (This is typically done to save space.)"

	worldState displayWorldAsTwoTone: self submorphs: submorphs color: color
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/1/2000 14:24'!
displayWorldNonIncrementally
	"Display the morph world non-incrementally. Used for testing."

	(worldState canvas == nil or:
	 [(worldState canvas extent ~= self viewBox extent) or:
	 [worldState canvas form depth ~= Display depth]]) ifTrue: [
		"allocate a new offscreen canvas the size of the window"
		worldState canvas: (Display defaultCanvasClass extent: self viewBox extent)].

	worldState canvas fillColor: color.
	submorphs reverseDo: [:m | worldState canvas fullDrawMorph: m].
	worldState handsReverseDo: [:h | worldState canvas fullDrawMorph: h].
	worldState canvas form displayOn: Display at: self viewBox origin.
	self fullRepaintNeeded.  "don't collect damage"
	Display forceDisplayUpdate.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:23'!
displayWorldSafely

	worldState displayWorldSafely: self.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 11:57'!
doOneCycle

	worldState doOneCycleFor: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:14'!
doOneCycleInBackground
	
	worldState doOneCycleInBackground
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 11:59'!
doOneSubCycle
	"Like doOneCycle, but preserves activeHand."

	worldState doOneSubCycleFor: self! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 9/19/2000 22:17'!
dragThroughOnDesktop: evt
	"Draw out a selection rectangle"
	| selection |
	selection _ SelectionMorph newBounds: (evt cursorPoint extent: 8@8).
	self addMorph: selection.
	^ selection extendByHand: evt hand
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 17:45'!
embeddedProjectDisplayMode

	"#naked - the embedded project/world is just a pasteup in the outer p/w
	#window - the embedded p/w is in a system window in the outer p/w
	#frame - the embedded p/w is in a green frame and clipped
	#scaled - the embedded p/w is in a green frame and scaled to fit"

	^#scaled
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/3/2000 09:44'!
exit

	CurrentProjectRefactoring exitCurrentProject
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/20/2000 12:42'!
extent: aPoint

	super extent: aPoint.
	worldState ifNotNil: [
		worldState viewBox ifNotNil: [
			worldState canvas: nil.
			worldState viewBox: bounds
		].
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 5/28/2000 12:10'!
flashRects: rectangleList color: aColor
	"For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work."
	"Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode."

	| blt screenRect |
	blt _ (BitBlt current toForm: Display)
		sourceForm: nil;
		sourceOrigin: 0@0;
		clipRect: self viewBox;
		combinationRule: Form reverse.
	rectangleList do: [:r |
		screenRect _ r translateBy: self viewBox origin.
		blt destRect: screenRect; copyBits.
		Display forceToScreen: screenRect; forceDisplayUpdate.
		(Delay forMilliseconds: 15) wait.
		blt destRect: screenRect; copyBits.
		Display forceToScreen: screenRect; forceDisplayUpdate].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/2/2000 10:22'!
fullContainsPoint: pt
	"The world clips its children"

	worldState ifNil: [^super fullContainsPoint: pt].
	^bounds containsPoint: pt

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:12'!
fullRepaintNeeded

	worldState doFullRepaint.
	SystemWindow windowsIn: self
		satisfying: [:w | w makeMeVisible. false].

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:11'!
goBack

	Project returnToPreviousProject.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/15/2000 16:15'!
haloMorphOrNil
	self flag: #arNote. "Remove this method"
	^self someHalo! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/28/2000 18:00'!
haloMorphs
	^ self hands collect:[:h| h halo] thenSelect:[:halo| halo notNil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/27/1999 10:46'!
handleFatalDrawingError: errMsg
	"Handle a fatal drawing error."
	Smalltalk isMorphic ifFalse:[^self error: errMsg]. "Can still handle it from MVC"
	Display deferUpdates: false. "Just in case"
	self primitiveError: errMsg.

	"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 2/3/2001 13:09'!
initForProject: aWorldState

	worldState _ aWorldState.
	bounds _ Display boundingBox.
	color _ (Color r:0.937 g: 0.937 b: 0.937).
	self addHand: HandMorph new.
	self setProperty: #automaticPhraseExpansion toValue: true.
	self setProperty: #optimumExtentFromAuthor toValue: Display extent.
	self borderWidth: 0.
	model _ nil.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 7/30/2000 16:32'!
install

	owner _ nil.	"since we may have been inside another world previously"

	submorphs do: [:ss | ss owner == nil ifTrue: [ss privateOwner: self]].
		"Transcript that was in outPointers and then got deleted."
	self viewBox: Display boundingBox.
	Sensor eventQueue: SharedQueue new.
	worldState handsDo: [:h | h initForEvents].

	self installFlaps.

	SystemWindow noteTopWindowIn: self.
	self displayWorldSafely.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 11/10/2000 15:23'!
installAsActiveSubprojectIn: enclosingWorld at: newBounds titled: aString

	| window howToOpen tm boundsForWorld |

	howToOpen _ self embeddedProjectDisplayMode.	
				"#scaled may be the only one that works at the moment"

	submorphs do: [:ss | ss owner == nil ifTrue: [ss privateOwner: self]].
		"Transcript that was in outPointers and then got deleted."

	boundsForWorld _ howToOpen == #naked ifTrue: [newBounds] ifFalse: [bounds].
	worldState canvas: nil.
	worldState viewBox: boundsForWorld.

	self bounds: boundsForWorld.

	"self viewBox: Display boundingBox."
	"worldState handsDo: [:h | h initForEvents]."

	self installFlaps.

	"SystemWindow noteTopWindowIn: self."
	"self displayWorldSafely."

	howToOpen == #naked ifTrue: [
		enclosingWorld addMorphFront: self.
	].
	howToOpen == #window ifTrue: [
		window _ (NewWorldWindow labelled: aString) model: self.
		window addMorph: self frame: (0@0 extent: 1.0@1.0).
		window openInWorld: enclosingWorld.
	].
	howToOpen == #frame ifTrue: [
		window _ AlignmentMorphBob1 new
			minWidth: 100;
			minHeight: 100;
			borderWidth: 8;
			borderColor: Color green;
			bounds: newBounds.
		window addMorph: self.
		window openInWorld: enclosingWorld.
	].
	howToOpen == #scaled ifTrue: [
		self position: 0@0.
		window _ EmbeddedWorldBorderMorph new
			minWidth: 100;
			minHeight: 100;
			borderWidth: 8;
			borderColor: Color green;
			bounds: newBounds.
		tm _ BOBTransformationMorph new.
		window addMorph: tm.
		tm addMorph: self.
		window openInWorld: enclosingWorld.
		tm changeWorldBoundsToShow: bounds.
		self arrangeToStartSteppingIn: enclosingWorld.
		"tm scale: (tm width / self width min: tm height / self height) asFloat."
	].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 16:16'!
installAsActiveSubprojectIn: enclosingWorld titled: aString

	| opt newWidth |

	opt _ self optimumExtentFromAuthor.
	(opt x > (enclosingWorld width * 0.7) or: 
			[opt y > (enclosingWorld height * 0.7)]) ifTrue: [
		newWidth _ enclosingWorld width // 2.
		opt _ newWidth @ (opt y * newWidth / opt x) truncated
	].
	^self 
		installAsActiveSubprojectIn: enclosingWorld 
		at: (enclosingWorld topLeft + (enclosingWorld extent - opt // 2) extent: opt) 
		titled: aString
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
installFlaps
	self addGlobalFlaps.
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringFlapTabsToFront! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:20'!
jumpToProject

	Project jumpToProject.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
nextPage
	"backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command.  If we get here, the 'next' button was not embedded in a book, so we can do nothing useful"

	self beep! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
open
	"Open a view on this WorldMorph."

	MorphWorldView openOn: self.! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
openWithTitle: aString cautionOnClose: aBoolean
	"Open a view on this WorldMorph with the given title."

	MorphWorldView openOn: self label: aString cautionOnClose: aBoolean! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/11/2000 15:09'!
optimumExtentFromAuthor

	| opt |
	^self 
		valueOfProperty: #optimumExtentFromAuthor 
		ifAbsent: [
			opt _ bounds extent.
			self setProperty: #optimumExtentFromAuthor toValue: opt.
			^opt
		]

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
paintArea
	"What rectangle should the user be allowed to create a new painting in??  An area beside the paintBox.  Allow playArea to override with its own bounds!!  "

	| playfield paintBoxBounds |
	playfield _ self submorphNamed: 'playfield' ifNone: [nil].
	playfield ifNotNil: [^ playfield bounds].

	paintBoxBounds _ self paintBox bounds.
	self firstHand targetOffset x < paintBoxBounds center x
		ifTrue: [^ bounds topLeft corner: paintBoxBounds left@bounds bottom]   "paint on left side"
		ifFalse: [^ paintBoxBounds right@bounds top corner: bounds bottomRight].  "paint on right side"
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
paintAreaFor: aSketchMorph
	"Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph"
	| itsOwner |
	((itsOwner _ aSketchMorph owner) ~~ nil and: [itsOwner isPlayfieldLike])
		ifTrue: [^ itsOwner bounds].  "handles every plausible situation"

	^ self paintArea! !

!PasteUpMorph methodsFor: 'world state' stamp: 'tk 8/21/2000 15:36'!
paintBox
	"Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one."

	| newPaintBox refPoint aPalette |
	self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
	refPoint _ (aPalette _ self standardPalette)
		ifNotNil:
			[aPalette showNoPalette.
			aPalette topRight + (0 @ 12)]
		ifNil:
			[self topRight].
	newPaintBox _ PaintBoxMorph new.
	newPaintBox position: (refPoint - (newPaintBox width @ 0)). 
	self addMorph: newPaintBox.
	^ newPaintBox
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 12:01'!
paintBoxOrNil
	"Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph return nil"

	self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]].
	^ nil
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:10'!
patchAt: patchRect without: stopMorph andNothingAbove: stopThere
	"Return a complete rendering of this patch of the display screen
	without stopMorph, and possibly without anything above it."
	| c |
	c _ ColorPatchCanvas extent: patchRect extent depth: Display depth.
	c stopMorph: stopMorph.
	c doStop: stopThere.
	c _ c copyOrigin: patchRect topLeft negated clipRect: (0@0 extent: patchRect extent).
	(self bounds containsRect: patchRect) ifFalse:
		["Need to fill area outside bounds with black."
		c form fillColor: Color black].
	(self bounds intersects: patchRect) ifFalse:
		["Nothing within bounds to show."
		^ c form].
	c fillRectangle: self bounds color: color.  "Fill bounds with world color."
	self drawSubmorphsOn: c.
	worldState handsReverseDo: [:h | h drawSubmorphsOn: c].
	^c form
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 10:38'!
pauseEventRecorder
	"Suspend any event recorder, and return it if found"

	| er |
	worldState handsDo: [:h | (er _ h pauseEventRecorderIn: self) ifNotNil: [^ er]].
	^ nil! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
previousPage
	"backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command.  If we get here, the button was not embedded in a book, so we can do nothing useful"

	self beep! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/1/2000 14:23'!
privateMoveBy: delta

	super privateMoveBy: delta.
	worldState ifNotNil: [
		worldState viewBox ifNotNil: [
			worldState viewBox: bounds
		].
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'!
privateOuterDisplayWorld

	worldState displayWorld: self submorphs: submorphs
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 8/29/2000 16:11'!
referencePlayfield
	"Answer a pasteup morph to be used as the reference for cartesian coordinates"

	self isWorldMorph
		ifTrue: [^ self submorphNamed: 'playfield' ifNone: [self]]
		ifFalse: [^ super referencePlayfield]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/5/2000 16:23'!
removeHand: aHandMorph
	"Remove the given hand from the list of hands for this world."

	(worldState hands includes: aHandMorph) ifFalse: [^self].
	aHandMorph dropMorphs.
	self invalidRect: aHandMorph fullBounds.
	worldState removeHand: aHandMorph.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 8/7/2000 12:09'!
repairEmbeddedWorlds

	| transform eWorld toDoList |

	toDoList _ OrderedCollection new.
	self allMorphsDo: [ :each |
		(each isKindOf: EmbeddedWorldBorderMorph) ifTrue: [
			transform _ each submorphs at: 1 ifAbsent: [nil].
			transform ifNotNil: [
				eWorld _ transform submorphs at: 1 ifAbsent: [nil].
				eWorld ifNotNil: [
					toDoList add: {transform. eWorld}.
				].
			].
			"Smalltalk at: #Q put: {self. each. transform. eWorld}."
		].
	].
	toDoList do: [ :each |
		each first addMorph: each second.
	].! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 08:04'!
restoreDisplay

	Display restoreMorphicDisplay.	"I don't actually expect this to be called"! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/3/2000 09:09'!
restoreFlapsDisplay
	(Preferences useGlobalFlaps and: [CurrentProjectRefactoring currentFlapsSuppressed not]) ifTrue:
		[Utilities globalFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld]].
	self localFlapTabs do:
			[:aFlapTab | aFlapTab adaptToWorld].
	self assureFlapTabsFitOnScreen.
	self bringFlapTabsToFront! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
saveAsWorld
	| worldName s |
	worldName _ FillInTheBlank
		request: 'Please give this world a name'
		initialAnswer: 'test'.
	((self class class includesSelector: worldName asSymbol) and:
		[(PopUpMenu confirm: 'OK to overwrite ' , worldName , '?') not])
		ifTrue: [^ self].

	s _ WriteStream on: (String new: 1000).
	s	nextPutAll: worldName; cr; tab;
		nextPutAll: '"' , self class name , ' ' , worldName, ' open"'; cr; cr; tab;
		nextPutAll: '^ '.
	self printConstructorOn: s indent: 0.
	s cr.

	self class class
		compile: s contents
		classified: 'examples'
		notifying: nil.! !

!PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 13:09'!
sketchEditorOrNil
	"Return a SketchEditorMorph found in the world, if any, else nil"

	^ self findA: SketchEditorMorph
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 7/16/2000 00:36'!
sleep

	self flag: #bob.		"Alan wanted this"

	worldState canvas ifNil: [^ self  "already called (clean this up)"].
	Cursor normal show.	"restore the normal cursor"

">>>> Alan wanted this out
	(turtleTrailsForm ~~ nil and: [self confirm: 'May I clear the pen trails
in this worldState to save space?']) ifTrue: [self clearTurtleTrails].
<<<<<"

	worldState canvas: nil.		"free my canvas to save space"
	self fullReleaseCachedState.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'ar 9/15/2000 11:44'!
someHalo
	"Return some halo that's currently visible in the world"
	| m |
	^ (m _ self haloMorphs) size > 0 ifTrue: [m first] ifFalse: [nil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
specialNameInModelFor: aMorph
	^ model ifNotNil: [model nameFor: aMorph] ifNil: [nil]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
standardPlayerHit

	self playSoundNamed: #peaks.
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
standardSystemController
	^ ScheduledControllers controllerSatisfying:
		[:c | (c view subViews size > 0) and:
			[c view firstSubView model == self]].
! !

!PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/1/2000 19:01'!
startSteppingSubmorphsOf: aMorph

	"Ensure that all submorphs of the given morph that want to be stepped are added to the step list.   Typically used after adding a morph to the world."

	aMorph allMorphsDo: [:m |
		m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world].
	]

! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
triggerClosingScripts
	"If the receiver has any scripts set to run on closing, run them now"
	| aPlayer |
	(aPlayer _ self player) ifNotNil:
		[aPlayer runAllClosingScripts]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
triggerOpeningScripts
	"If the receiver has any scripts set to run on opening, run them now"
	| aPlayer |
	(aPlayer _ self player) ifNotNil:
		[aPlayer runAllOpeningScripts]! !

!PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'!
veryDeepCopyWith: deepCopier
	"See storeDataOn:"

	self isWorldMorph
		ifTrue: ["maybe ^ self later?  For now, catch all offenders."
				^ self error: 'Worlds should not be copied']
		ifFalse: [^ super veryDeepCopyWith: deepCopier]! !


!PasteUpMorph methodsFor: 'accessing' stamp: 'ar 9/28/2000 14:00'!
beFlap: aBool
	aBool
		ifTrue:[self setProperty: #flap toValue: true]
		ifFalse:[self removeProperty: #flap]! !


!PasteUpMorph methodsFor: 'project' stamp: 'tk 9/3/1999 12:07'!
project
	"Find the project that owns me.  Not efficient to call this."

	^ Project ofWorld: self! !

!PasteUpMorph methodsFor: 'project' stamp: 'tk 3/27/2000 20:38'!
releaseSqueakPages
	| uu |
	"If this world has a book with SqueakPages, then clear the SqueakPageCache"

	submorphs do: [:sub | (sub isKindOf: BookMorph) ifTrue: [
		uu _ sub valueOfProperty: #url ifAbsent: [nil].
		uu ifNotNil: [(SqueakPageCache pageCache includesKey: uu) ifTrue: [
				SqueakPageCache initialize]]]].	"wipe the cache"! !

!PasteUpMorph methodsFor: 'project' stamp: 'tk 9/9/1999 12:08'!
storeProjectsAsSegments
	"Force my sub-projects out to disk"

submorphs do: [:sub |
	(sub isKindOf: SystemWindow) ifTrue: [
		(sub model isKindOf: Project) ifTrue: [
			sub model storeSegment]]].	"OK if was already out"! !


!PasteUpMorph methodsFor: 'interaction loop' stamp: 'RAA 5/24/2000 11:55'!
doOneCycleNow
	"Do one cycle of the interactive loop. This method is called repeatedly when the world is running."

	worldState doOneCycleNowFor: self.
! !

!PasteUpMorph methodsFor: 'interaction loop' stamp: 'ar 10/10/2000 14:12'!
keyStroke: anEvent
	"A keystroke has been made.  Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:"

	super keyStroke: anEvent.  "Give event handlers a chance"
	(anEvent keyCharacter == Character tab) ifTrue:
		[(self hasProperty: #tabAmongFields)
			ifTrue:[^ self tabHitWithEvent: anEvent]].
	self isWorldMorph ifTrue:
		[self keystrokeInWorld: anEvent]! !


!PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 6/3/2000 09:48'!
restartWorldCycleWithEvent: evt

	"RAA 27 Nov 99 - redispatch that click picked up from our inner world"
	evt ifNotNil: [
		self primaryHand handleEvent: (evt setHand: self primaryHand).
	].
	CurrentProjectRefactoring currentSpawnNewProcessAndTerminateOld: true
! !

!PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 11/14/1999 15:07'!
validateMouseEvent: evt

	! !


!PasteUpMorph methodsFor: 'private' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber

	self isFlap ifTrue:[^26]. 	"As navigators"
	^super morphicLayerNumber.! !

!PasteUpMorph methodsFor: 'private' stamp: 'ar 3/14/2000 23:20'!
privateFullMoveBy: delta
	"Private. Overridden to prevent drawing turtle trails when a playfield is moved"
	self setProperty: #turtleTrailsDelta toValue: delta.
	super privateFullMoveBy: delta.
	self removeProperty: #turtleTrailsDelta.
! !


!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:19'!
addRemoteClient: aClient
	self addHand: aClient hand.
	worldState addRemoteCanvas: aClient canvas.
	aClient canvas fullDrawMorph: self.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'RAA 11/8/2000 15:04'!
convertRemoteClientToBuffered: aClient

	worldState removeRemoteCanvas: aClient canvas.
	aClient convertToBuffered.
	worldState addRemoteCanvas: aClient canvas.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 15:03'!
hasRemoteServer
	^self remoteServer notNil! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:44'!
releaseRemoteServer
	"My server has been transferred to some other world. Release pending references"
	^worldState releaseRemoteServer.! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:08'!
remoteServer
	^worldState remoteServer.! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'RAA 11/6/2000 17:24'!
remoteServer: aNebraskaServer

	| h |

	worldState remoteServer: aNebraskaServer.
	h _ self primaryHand.
	aNebraskaServer ifNil:[
		(h hasProperty: #representingTheServer) ifTrue: [
			h removeProperty: #representingTheServer.
			h userInitials: '' andPicture: nil.
		]
	] ifNotNil:[
		(h hasProperty: #representingTheServer) ifFalse: [
			h setProperty: #representingTheServer toValue: true.
			h userInitials: Utilities authorName andPicture: nil.
		]
	].! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 14:19'!
removeRemoteClient: aClient
	self removeHand: aClient hand.
	worldState removeRemoteCanvas: aClient canvas.
	self changed.  "force a redraw"
! !

!PasteUpMorph methodsFor: 'Nebraska' stamp: 'ar 10/26/2000 15:19'!
transferRemoteServerFrom: aWorld
	"Transfer the remote server which was associated with aWorld (if any) to the receiver"
	| server |
	(aWorld notNil and:[aWorld isMorph and:[aWorld isWorldMorph]]) ifFalse:[^self].
	server _ aWorld remoteServer.
	server ifNotNil:[
		self remoteServer: server.
		server clients do:[:each| self addRemoteClient: each].
		self primaryHand
			userInitials: (aWorld primaryHand userInitials)
			andPicture: (aWorld primaryHand userPicture).
		aWorld primaryHand userInitials: '' andPicture: nil].
	aWorld releaseRemoteServer.! !


!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'!
gridModulus

	^ self gridSpec extent! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'!
gridModulus: newModulus

	self gridSpecPut: (self gridOrigin extent: newModulus).
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'!
gridOrigin

	^ self gridSpec origin! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'!
gridOrigin: newOrigin

	^ self gridSpecPut: (newOrigin extent: self gridModulus)! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/28/2000 23:13'!
gridPoint: ungriddedPoint

	self griddingOn ifFalse: [^ ungriddedPoint].
	^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus)
					+ self position + self gridOrigin! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:26'!
gridSpec
	"Gridding rectangle provides origin and modulus"

	^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'!
gridSpecPut: newSpec
	"Gridding rectangle provides origin and modulus"

	^ self setProperty: #gridSpec toValue: newSpec! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:11'!
gridVisible

	^ self hasProperty: #gridVisible! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'!
gridVisibleOnOff

	self setProperty: #gridVisible toValue: self gridVisible not.
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'sw 10/17/2000 12:10'!
gridVisibleString
	"Answer a string to be used in a menu offering the opportunity to show or hide the grid"

	^ (self gridVisible ifTrue: ['<yes>'] ifFalse: ['<no>']), 'show grid when gridding'! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:15'!
griddingOn

	^ griddingOn ifNil: [false]! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:48'!
griddingOnOff

	griddingOn _ self griddingOn not.
	self changed! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'sw 10/17/2000 12:10'!
griddingString
	"Answer a string to use in a menu offering the user the opportunity to start or stop using gridding"

	^ (self griddingOn ifTrue: ['<yes>'] ifFalse: ['<no>']), 'use gridding'! !

!PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/28/2000 21:04'!
setGridSpec
	"Gridding rectangle provides origin and modulus"
	| response result mx |
	mx _ 36.  "... because it was that way before ..."
	response _ FillInTheBlank
			request: 'New grid origin (usually 0@0):'
			initialAnswer: self gridOrigin printString.
	response isEmpty ifTrue: [^ self].
	result _ [Compiler evaluate: response] ifError: [^ self].
	(result isPoint and: [(result >= (0@0)) & (result < (mx @ mx))])
		ifTrue: [self gridOrigin: result]
		ifFalse: [self inform: 'Must be a Point with coordinates between 0 & '
								, (mx-1) printString].

	response _ FillInTheBlank
			request: 'New grid spacing:'
			initialAnswer: self gridModulus printString.
	response isEmpty ifTrue: [^ self].
	result _ [Compiler evaluate: response] ifError: [^ self].
	(result isPoint and: [(result > (0@0)) & (result <= (mx @ mx))])
		ifTrue: [self gridModulus: result]
		ifFalse: [self inform: 'Must be a Point with coordinates between 1 & '
								, mx printString].

! !


!PasteUpMorph methodsFor: 'undo' stamp: 'RAA 9/21/2000 20:07'!
clearCommandHistory

	worldState ifNotNil: [worldState clearCommandHistory]! !

!PasteUpMorph methodsFor: 'undo' stamp: 'ar 8/31/2000 23:16'!
commandHistory
	"Return the command history for the receiver"
	^self isWorldMorph
		ifTrue:[worldState commandHistory]
		ifFalse:[super commandHistory]! !


!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:40'!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
	"Add a new alarm with the given set of parameters"
	worldState addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime.! !

!PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:39'!
removeAlarm: aSelector for: aTarget
	"Remove the alarm with the given selector"
	worldState removeAlarm: aSelector for: aTarget! !


!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/16/2000 18:37'!
addMorphFront: aMorph

	^self addMorphInFrontOfLayer: aMorph
! !

!PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 9/28/2000 14:21'!
addMorphInLayer: aMorph
	super addMorphInLayer: aMorph.
	aMorph isFlapOrTab ifFalse:[self bringFlapTabsToFront].! !


!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 1/3/2001 06:42'!
addViewingItemsTo: aMenu
	"Add viewing-related items to the given menu.  If any are added, this method is also responsible for adding a line after them"

	#(	(viewingByIconString 			viewByIcon)
		(viewingByNameString 			viewByName)
		"(viewingBySizeString 			viewBySize)"
		(viewingNonOverlappingString 	viewNonOverlapping)) do:
			[:pair |  aMenu addUpdating: pair first target:  self action: pair second].
	aMenu addLine
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/9/2000 13:49'!
imposeListViewSortingBy: sortOrderSymbol retrieving: fieldListSelectors
	"Establish a list view of the receiver's contents, sorting the contents by the criterion represented by sortOrderSymbol, and displaying readouts as indicated by the list of field selectors."
	| rep |

	self setProperty: #sortOrder toValue: sortOrderSymbol.
	self setProperty: #fieldListSelectors toValue: fieldListSelectors.

	self showingListView ifFalse:
		[self autoLineLayout ifFalse: [self saveBoundsOfSubmorphs].
		self setProperty: #showingListView toValue: true.
		self layoutPolicy: TableLayout new.
		self layoutInset: 2; cellInset: 2.
		self listDirection: #topToBottom.
		self wrapDirection: #none].

	self submorphs "important that it be a copy" do:
		[:aMorph | 
			rep _ aMorph listViewLineForFieldList: fieldListSelectors.
			rep hResizing: #spaceFill.
			self replaceSubmorph: aMorph by: rep].

	self sortSubmorphsBy: (self valueOfProperty: #sortOrder).! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/5/2000 06:42'!
restoreBoundsOfSubmorphs
	"restores the saved xy-positions and extents"

	submorphs do:
		[:aSubmorph |
			aSubmorph valueOfProperty: #savedExtent ifPresentDo:
				[:anExtent | aSubmorph extent: anExtent].
			aSubmorph valueOfProperty: #savedPosition ifPresentDo:
				[:aPosition | aSubmorph position: aPosition]]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/18/2000 10:59'!
saveBoundsOfSubmorphs
	"store the current xy-positions and extents of submorphs for future use"

	submorphs do:
		[:aSubmorph |
			aSubmorph setProperty: #savedExtent toValue: aSubmorph extent.
			aSubmorph setProperty: #savedPosition toValue: aSubmorph position]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/29/2000 17:22'!
scriptSelectorToTriggerFor: aButtonMorph
	"Answer a new selector which will bear the code for aButtonMorph in the receiver"

	| buttonName selectorName |
	buttonName _ aButtonMorph externalName.
	selectorName _ ScriptingSystem acceptableScriptNameFrom: buttonName  forScriptCurrentlyNamed:  nil asScriptNameIn: self assuredPlayer world: self world.

	buttonName ~= selectorName ifTrue:
		[aButtonMorph setNameTo: selectorName].
	^ selectorName! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/23/2000 19:01'!
showingListView
	"Answer whether the receiver is currently showing a list view"

	^ self hasProperty: #showingListView
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/12/2000 22:37'!
sortSubmorphsBy: sortOrderSymbol
	"Sort the receiver's submorphs by the criterion indicated in the provided symbol"
	self invalidRect: self fullBounds.
	submorphs _ submorphs sortBy:[:a :b | (a perform: sortOrderSymbol) <= (b perform: sortOrderSymbol)].
	self layoutChanged.! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/9/2000 13:50'!
viewByIcon
	"The receiver has been being viewed in some constrained layout view; now restore it to its normal x-y-layout view"

	|  oldSubs |
	self showingListView
		ifTrue:
			[oldSubs _ submorphs.
			self removeAllMorphs.
			self layoutPolicy: nil.
			oldSubs do:
				[:aSubmorph |
					self addMorphBack:  aSubmorph objectRepresented].
			self restoreBoundsOfSubmorphs.
			self removeProperty: #showingListView]
		ifFalse:
			[self autoLineLayout == true ifTrue: [self toggleAutoLineLayout]]! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/31/2000 09:29'!
viewByName
	"Make the receiver show its subparts as a vertical list of lines of information, sorted by object name"

	self imposeListViewSortingBy: #downshiftedNameOfObjectRepresented retrieving: #(nameOfObjectRepresented reportableSize  className oopString)! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/31/2000 07:08'!
viewBySize
	"Make the receiver show its subparts as a vertical list of lines of information, sorted by object size"

	self imposeListViewSortingBy: #reportableSize retrieving: #(externalName reportableSize className oopString)! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 22:37'!
viewNonOverlapping
	"Make the receiver show its contents as full-size morphs laid out left-to-right and top-to-bottom to be non-overlapping."

	self viewingNormally ifTrue:
		[self saveBoundsOfSubmorphs].
	self showingListView ifTrue:
		[self viewByIcon.
		self removeProperty: #showingListView].
	self autoLineLayout: true.! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 18:13'!
viewingByIconString
	"Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by icon or not"

	^ (self showingListView or: [self autoLineLayout == true])
		ifFalse:	['<yes>view by icon']
		ifTrue:	['<no>view by icon']
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/31/2000 09:28'!
viewingByNameString
	"Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by name or not"

	^ (self showingListView and: [(self valueOfProperty: #sortOrder ifAbsent: [nil]) == #downshiftedNameOfObjectRepresented])
		ifTrue:	['<yes>view by name']
		ifFalse:	['<no>view by name']
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'sw 10/23/2000 19:14'!
viewingBySizeString
	"Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by size or not"

	^ (self showingListView and: [(self valueOfProperty: #sortOrder ifAbsent: [nil]) == #reportableSize])
		ifTrue:	['<yes>view by size']
		ifFalse:	['<no>view by size']
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 18:14'!
viewingNonOverlappingString
	"Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by non-overlapping-icon (aka auto-line-layout)"

	^ (self showingListView or: [self autoLineLayout ~~ true])
		ifFalse:	['<yes>view with line layout']
		ifTrue:	['<no>view with line layout']
! !

!PasteUpMorph methodsFor: 'viewing' stamp: 'ar 11/8/2000 18:13'!
viewingNormally
	"Answer whether the receiver is being viewed normally, viz not in list-view or auto-line-layout"

	^ (self showingListView or: [self autoLineLayout == true]) not
! !


!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/10/2000 15:22'!
handlesKeyboard: evt
	^self isWorldMorph or:[evt keyCharacter == Character tab and:[self hasProperty: #tabAmongFields]]! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/3/2000 22:46'!
handlesMouseDown: evt
	^true! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/8/2000 23:03'!
morphToGrab: event
	"Return the morph to grab from a mouse down event. If none, return nil."
	self submorphsDo:[:m|
		(m isLocked not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m].
	].
	^nil! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'RAA 12/18/2000 16:12'!
mouseDown: evt
	"Handle a mouse down event."
	| grabbedMorph handHadHalos |
	grabbedMorph _ self morphToGrab: evt.
	grabbedMorph ifNotNil:[
		grabbedMorph isSticky ifTrue:[^self].
		self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph].
		grabbedMorph _ grabbedMorph partRepresented duplicate.
		grabbedMorph restoreSuspendedEventHandler.
		(grabbedMorph fullBounds containsPoint: evt position) 
			ifFalse:[grabbedMorph position: evt position].
		"Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead"
		^evt hand grabMorph: grabbedMorph from: self].

	(super handlesMouseDown: evt)
		ifTrue:[^super mouseDown: evt].
	handHadHalos _ evt hand halo notNil.
	evt hand halo: nil. "shake off halos"
	evt hand releaseKeyboardFocus. "shake of keyboard foci"
	evt shiftPressed ifTrue:[
		^evt hand 
			waitForClicksOrDrag: self 
			event: evt 
			selectors: { #findWindow:. nil. #dragThroughOnDesktop:}
			threshold: 5].
	self isWorldMorph ifTrue: [
		handHadHalos ifTrue: [^self addAlarm: #invokeWorldMenu: with: evt after: 200].
		^self invokeWorldMenu: evt
	].
	"otherwise, explicitly ignore the event if we're not the world,
	so that we could be picked up if need be"
	self isWorldMorph ifFalse:[evt wasHandled: false].
! !

!PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:04'!
mouseUp: evt
	self isWorldMorph ifTrue:[self removeAlarm: #invokeWorldMenu:].
	super mouseUp: evt.! !


!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:34'!
addUndoItemsTo: aWorldMenu
	"Add undo-related items to the given menu.  Will add zero, one or two items, depending on the settings of the #useUndo and #infiniteUndo preferences"

	Preferences useUndo ifFalse: [^ self].
	Preferences infiniteUndo
		ifFalse:
			[aWorldMenu addUpdating: #undoOrRedoMenuWording target: self commandHistory action: #undoOrRedoCommand]
		ifTrue:
			[aWorldMenu addUpdating: #undoMenuWording target: self commandHistory  action: #undoLastCommand.
			aWorldMenu addUpdating: #redoMenuWording target: self commandHistory action: #redoNextCommand.
			self flag: #deferred.  "The following feature to be unblocked in due course"
			"aWorldMenu add: 'undo to...' target: self commandHistory action: #undoTo"].
	aWorldMenu addLine! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/30/2001 20:37'!
bringWindowsFullOnscreen
	"Make ever SystemWindow on the desktop be totally on-screen, whenever possible."
	
	(SystemWindow windowsIn: self satisfying: [:w | true]) do:
		[:aWindow | 
			aWindow right: (aWindow right min: bounds right).
			aWindow bottom: (aWindow bottom min: bounds bottom).
			aWindow left: (aWindow left max: bounds left).
			aWindow top: (aWindow top max: bounds top)]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:27'!
buildWorldMenu: evt
	^(TheWorldMenu new
		world: self
		project: (self project ifNil: [Project current])       "mvc??"
		hand: evt hand) buildWorldMenu.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:26'!
closeUnchangedWindows
	"Present a menu of window titles for all windows with changes,
	and activate the one that gets chosen."
	(SelectionMenu confirm:
'Do you really want to close all windows
except those with unaccepted edits?')
		ifFalse: [^ self].

	(SystemWindow windowsIn: self satisfying: [:w | w model canDiscardEdits])
		do: [:w | w delete]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:27'!
collapseAll
	"Collapse all windows"
	(SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld].
	self collapseNonWindows! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:27'!
collapseNonWindows
	self allNonFlapRelatedSubmorphs do:
		[:m | m collapse]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:03'!
connectRemoteUser
	
	^self
		connectRemoteUserWithName: nil 
		picture: nil 
		andIPAddress: nil
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 15:59'!
connectRemoteUserWithName: nameStringOrNil picture: aFormOrNil andIPAddress: aStringOrNil
	"Prompt for the initials to be used to identify the cursor of a remote user, then create a cursor for that user and wait for a connection."

	| initials addr h |
	initials _ nameStringOrNil.
	initials isEmptyOrNil ifTrue: [
		initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.
	].
	initials isEmpty ifTrue: [^ self].  "abort"
	addr _ 0.
	aStringOrNil isEmptyOrNil ifFalse: [
		addr _ NetNameResolver addressForName: aStringOrNil timeout: 30
	].
	addr = 0 ifTrue: [
		addr _ NetNameResolver promptUserForHostAddress.
	].
	addr = 0 ifTrue: [^ self].  "abort"

	Socket ensureNetworkConnected.
	h _ RemoteHandMorph new userInitials: initials andPicture: aFormOrNil.
	self addHand: h.
	h changed.
	h startListening.
	h startTransmittingEventsTo: addr.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:28'!
deleteNonWindows
	(SelectionMenu confirm:
'Do you really want to discard all objects
that are not in windows?')
		ifFalse: [^ self].

	self allNonFlapRelatedSubmorphs do:
		[:m | m delete]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:29'!
detachableScriptingSpace
	ScriptingSystem newScriptingSpace openInWorld: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:07'!
disconnectAllRemoteUsers
	"Disconnect all remote hands and stop transmitting events."
	self world handsDo: [:h |
		(h isKindOf: RemoteHandMorph) 
			ifTrue: [h withdrawFromWorld]].! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:09'!
disconnectRemoteUser
	"Prompt for the initials of the remote user, then remove the remote hand with those initials, breaking its connection."

	"select hand to remove"
	| initials handToRemove |
	initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'.
	initials isEmpty ifTrue: [^ self].  "abort"
	handToRemove _ nil.
	self handsDo: [:h |
		h userInitials = initials ifTrue: [handToRemove _ h]].
	handToRemove ifNil: [^ self].  "no hand with those initials"
	handToRemove withdrawFromWorld.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:11'!
drawingClass

	^ SketchMorph! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:33'!
expandAll
	"Expand all windows"
	(SystemWindow windowsIn: self satisfying: [:w | w isCollapsed])
		reverseDo: [:w | w collapseOrExpand.  self displayWorld]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/11/2001 12:57'!
findAChangeSorter: evt
	"Locate a change sorter, open it, and bring it to the front.  Create one if necessary.  Only works in morphic, initially, probably"

	| aWindow |
	submorphs do:
		[:aMorph | (((aWindow _ aMorph renderedMorph) isKindOf: SystemWindow) and:
			[aWindow model isKindOf: ChangeSorter orOf: DualChangeSorter])
				ifTrue:
					[aWindow isCollapsed ifTrue: [aWindow expand].
					aWindow activateAndForceLabelToShow.
					^ self]].
	"None found, so create one"
	DualChangeSorter open! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 12/6/2000 20:28'!
findATranscript: evt
	"Locate a transcript, open it, and bring it to the front.  Create one if necessary"

	| aWindow |
	submorphs do:
		[:aMorph | (((aWindow _ aMorph renderedMorph) isKindOf: SystemWindow) and:
			[aWindow model == Transcript])
				ifTrue:
					[aWindow isCollapsed ifTrue: [aWindow expand].
					aWindow activateAndForceLabelToShow.
					^ self]].
	"None found, so create one"
	(Transcript openAsMorphLabel: 'Transcript') openInWorld: evt hand world! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:34'!
findDirtyBrowsers: evt
	"Present a menu of window titles for browsers with changes,
	and activate the one that gets chosen."
	| menu |
	menu _ MenuMorph new.
	(SystemWindow windowsIn: self
		satisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]])
		do: [:w | menu add: w label target: w action: #activate].
	menu submorphs size > 0 ifTrue:
		[menu popUpEvent: evt in: self]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:35'!
findDirtyWindows: evt
	"Present a menu of window titles for all windows with changes,
	and activate the one that gets chosen."
	| menu |
	menu _ MenuMorph new.
	(SystemWindow windowsIn: self
		satisfying: [:w | w model canDiscardEdits not])
		do: [:w | menu add: w label target: w action: #activate].

	menu submorphs size > 0 ifTrue:
		[menu popUpEvent: evt in: self]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:36'!
findWindow: evt
	"Present a menu names of windows and naked morphs, and activate the one that gets chosen.  Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo."
	| menu expanded collapsed nakedMorphs |
	menu _ MenuMorph new.
	expanded _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not].
	collapsed _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed].
	nakedMorphs _ self submorphsSatisfying:
		[:m | ((m isKindOf: SystemWindow) not and: [(m isKindOf: StickySketchMorph) not]) and:
			[(m isFlapTab) not]].
	(expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ self beep].
	(expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do:
		[:w | menu add: w label target: w action: #activateAndForceLabelToShow.
			w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	(expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine].
	(collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: 
		[:w | menu add: w label target: w action: #collapseOrExpand.
		w model canDiscardEdits ifFalse: [menu lastItem color: Color red]].
	nakedMorphs isEmpty ifFalse: [menu addLine].
	(nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do:
		[:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo].
	menu addTitle: 'find window'.
	
	menu popUpEvent: evt in: self.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:09'!
getWorldMenu: aSymbol
	^(TheWorldMenu new
		world: self
		project: (self project ifNil: [Project current])       "mvc??"
		hand: self primaryHand) perform: aSymbol! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:12'!
grabDrawingFromScreen: evt
	"Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand."
	| m |
	m _ self drawingClass new form: Form fromUser.
	evt hand attachMorph: m.! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/10/2000 18:49'!
invokeWorldMenu: evt
	| menu |
	Utilities bringFlapsToFront.
	evt isMouse ifTrue:[
		evt yellowButtonPressed
			ifTrue: [^ self yellowButtonClickOnDesktopWithEvent: evt].
		evt shiftPressed ifTrue:[^self findWindow: evt]].
	"put put screen menu"
	menu _ self buildWorldMenu: evt.
	menu addTitle: Preferences desktopMenuTitle.
	menu popUpEvent: evt in: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/25/2001 15:22'!
keystrokeInWorld: evt
	"A keystroke was hit when no keyboard focus was in set, so it is sent here to the world instead.  This current implementation is regrettably hard-coded; until someone cleans this up, you may be tempted to edit this method to suit your personal taste in interpreting cmd-keys issued to the desktop."

	|  aChar isCmd |
	aChar _ evt keyCharacter.
	isCmd _ evt commandKeyPressed and: [Preferences cmdKeysInText].
	isCmd ifTrue:
		[(aChar == $z) ifTrue: [^ self commandHistory undoOrRedoCommand].
		(aChar == $w) ifTrue: [^ SystemWindow closeTopWindow].
		(aChar == $\) ifTrue: [^ SystemWindow sendTopWindowToBack].

		(aChar == $t) ifTrue: [^ self findATranscript: evt].
		(aChar == $b) ifTrue: [^ Browser openBrowser].
		(aChar == $k) ifTrue: [^ Workspace open].

		(aChar == $C) ifTrue: [^ self findAChangeSorter: evt].
		(aChar == $R) ifTrue: [^ self openRecentSubmissionsBrowser: evt].

		(aChar == $r) ifTrue: [^ Display restoreMorphicDisplay].

		(aChar == $W) ifTrue: [^ self invokeWorldMenu: evt]]
			"This last item is a weirdo feature requested by the Open School in Fall of 2000 as a keyhole to the world menu in systems that normally do not offer a world menu"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'RAA 2/1/2001 18:21'!
makeNewDrawing: evt
	| w newSketch newPlayer sketchEditor aPaintBox aPalette tfx whereToPresent rect ownerBeforeHack |
	w _ self world.
	w assureNotPaintingElse: [^ self].
	rect _ self paintingBoundsAround: evt position.
	aPalette _ self standardPalette.
	aPalette ifNotNil: [aPalette showNoPalette; layoutChanged].
	w stopRunningAll; abandonAllHalos.
	newSketch _ self drawingClass new player: (newPlayer _ UnscriptedPlayer newUserInstance).
	newPlayer costume: newSketch.
	newSketch form: (Form extent: rect extent depth: w assuredCanvas depth).
	newSketch bounds: rect.
	sketchEditor _ SketchEditorMorph new.
	w addMorphFront: sketchEditor.
	sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			whereToPresent _ self presenter.
			newSketch form: aForm.
			tfx _ self transformFrom: w.
			newSketch position: (tfx globalPointToLocal: aRect origin).
			newSketch rotationStyle: sketchEditor rotationStyle.
			newSketch forwardDirection: sketchEditor forwardDirection.

			ownerBeforeHack _ newSketch owner.	"about to break the invariant!!!!"
			newSketch privateOwner: self. "temp for halo access"
			newPlayer setHeading: sketchEditor forwardDirection.
			"Includes  newSketch rotationDegrees: sketchEditor forwardDirection."
			newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain"

			self addMorphFront: newPlayer costume.
			w startSteppingSubmorphsOf: newSketch.
			whereToPresent drawingJustCompleted: newSketch]
		 ifNoBits:
			[(aPaintBox _ w paintBox) ifNotNil:
				[aPaintBox delete].
			aPalette ifNotNil: [aPalette showNoPalette].]! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 17:40'!
newDrawingFromMenu: evt
	self assureNotPaintingElse: [^ self].
	evt hand attachMorph: PaintInvokingMorph new markAsPartsDonor! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/25/2001 15:19'!
openRecentSubmissionsBrowser: evt
	"Locate a recent-submissions browser, open it, and bring it to the front.  Create one if necessary.  Only works in morphic"

	| aWindow |
	submorphs do:
		[:aMorph | (((aWindow _ aMorph renderedMorph) isKindOf: SystemWindow) and:
			[aWindow model isKindOf: RecentMessageSet])
				ifTrue:
					[aWindow isCollapsed ifTrue: [aWindow expand].
					aWindow activateAndForceLabelToShow.
					^ self]].
	"None found, so create one"
	Utilities browseRecentSubmissions! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 19:00'!
openScrapsBook: evt
	evt hand attachMorph: Utilities scrapsBook! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/12/2001 20:02'!
printScriptSummary
	"Put up a window with summaries of all scripts in the world"

	self presenter reportPlayersAndScripts

"self currentWorld printScriptSummary"! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:31'!
putUpDesktopMenu: evt
	"Put up the desktop menu"
	^ ((self buildWorldMenu: evt) addTitle: Preferences desktopMenuTitle) popUpAt: evt position forHand: evt hand in: self! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/24/2000 14:40'!
reportLocalAddress
	"Report the local host address of this computer."

	| addrString m s |
	Socket initializeNetwork.
	addrString _ NetNameResolver localAddressString.
	m _ RectangleMorph new
		color: (Color r: 0.6 g: 0.8 b: 0.6);
		extent: 118@36;
		borderWidth: 1.
	s _ StringMorph contents: 'Local Host Address:'.
	s position: m position + (5@4).
	m addMorph: s.
	s _ StringMorph contents: addrString.
	s position: m position + (5@19).
	m addMorph: s.
	self primaryHand attachMorph: m.
! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'sw 1/14/2001 03:04'!
showStatusOfAllScripts
	"Put up a window that shows, and allows you to change, the status of all scripts"

	self presenter toolToViewScriptInstantiations! !

!PasteUpMorph methodsFor: 'world menu' stamp: 'ar 10/5/2000 18:28'!
yellowButtonClickOnDesktopWithEvent: evt
	"Put up either the personalized menu or the world menu when the user clicks on the morphic desktop with the yellow button.  The preference 'personalizedWorldMenu' governs which one is used"
	| aMenu |
	Preferences personalizedWorldMenu ifFalse:[
		aMenu _ self buildWorldMenu: evt.
		aMenu addTitle: 'World'.
	] ifTrue:[
		aMenu _ MenuMorph new defaultTarget: self.
		Preferences personalizeUserMenu: aMenu.
		aMenu addLine.
		aMenu add: 'personalize...' target: Preferences action: #letUserPersonalizeMenu].
	aMenu popUpEvent: evt in: self
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PasteUpMorph class
	instanceVariableNames: ''!

!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 10/23/2000 16:47'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ # (

(playfield (
(command initiatePainting 'Initiate painting of a new object in the standard playfield.')
(slot mouseX 'The x coordinate of the mouse pointer' number readWrite player getMouseX  unused unused)
(slot mouseY 'The y coordinate of the mouse pointer' number readWrite player getMouseY  unused unused)
(command roundUpStrays 'Bring all out-of-container subparts back into view.')
(slot numberAtCursor 'the number at the cursor' number readWrite player getNumberAtCursor player setNumberAtCursor: )
(slot playerAtCursor 'the object currently at the cursor' player readWrite player getValueAtCursor  unused unused)
(command unhideHiddenObjects 'Unhide all hidden objects.')))

(collections (
(slot cursor 'The index of the chosen element' number readWrite player getCursor player setCursorWrapped:)
(slot playerAtCursor 'the object currently at the cursor' player readWrite player getValueAtCursor  unused unused)
(slot firstElement  'The first object in my contents' player  readWrite player getFirstElement  player  setFirstElement:)
(slot numberAtCursor 'the number at the cursor' number readWrite player getNumberAtCursor player setNumberAtCursor: )
(command removeAll 'Remove all elements from the playfield')
(command shuffleContents 'Shuffle the contents of the playfield')
(command append: 'Add the object to my content' player)))

(#'stack navigation' (
(command goToNextCardInStack 'Go to the next card')
(command goToPreviousCardInStack  'Go to the previous card')
(command goToFirstCardInBackground 'Go to the first card of the current background')
(command goToFirstCardOfStack 'Go to the first card of the entire stack')
(command goToLastCardInBackground 'Go to the last card of the current background')
(command goToLastCardOfStack 'Go to the last card of the entire stack')
(command deleteCard 'Delete the current card')
(command insertCard 'Create a new card')))

(viewing (
(slot viewingNormally 'whether contents are viewed normally' boolean readWrite player getViewingByIcon player setViewingByIcon: )))


(#'pen trails' (
(command liftAllPens 'Lift the pens on all the objects in my interior.')
(command lowerAllPens  'Lower the pens on all the objects in my interior.')
(command clearTurtleTrails 'Clear all the pen trails in the interior.'))))
! !

!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 3/4/1999 15:05'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| proto |
	proto _ self new markAsPartsDonor.
	proto color: Color green muchLighter;  extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161).
	proto extent: 300 @ 240.
	proto beSticky.
	^ proto! !

!PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 5/3/1998 14:25'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'playfield'! !


!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'!
MinCycleLapse: milliseconds
	"set the minimum amount of time that may transpire between two calls to doOneCycle"
	MinCycleLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:26'!
disableDeferredUpdates

	^DisableDeferredUpdates ifNil: [DisableDeferredUpdates _ false]
! !

!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'!
disableDeferredUpdates: aBoolean
	"If the argument is true, disable deferred screen updating."
	"Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas  and then copied to the hardware display buffer."

	DisableDeferredUpdates _ aBoolean.
! !

!PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'!
initialize
	"WorldMorph initialize"
	self MinCycleLapse: 20.		"allows 50 frames per second..."! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/25/2000 15:15'!
newWorldForProject: projectOrNil 
	"Return a new pasteUpMorph configured as a world (ie project notNil).
	projectOrNil is no longer used."

	^ self new initForProject: WorldState new! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 5/26/2000 10:07'!
newWorldTesting

	| world ex |

	ex _ 500@500.
	world _ PasteUpMorph newWorldForProject: nil.
	world extent: ex; color: Color orange.
	world openInWorld.
	world viewBox: (0@0 extent: ex).
	BouncingAtomsMorph new openInWorld: world.

"-----

	| world window |
	world _ PasteUpMorph newWorldForProject: nil.
	world extent: 300@300; color: Color orange.
	world viewBox: (0@0 extent: 300@300).
	window _ (SystemWindow labelled: 'the new world') model: world.
	window color: Color orange.
	window addMorph: world frame: (0@0 extent: 1.0@1.0).
	window openInWorld.

---"
! !

!PasteUpMorph class methodsFor: 'project' stamp: 'RAA 6/6/2000 17:35'!
startUp
	
	Display restoreMorphicDisplay.! !
DisplayObject subclass: #Path
	instanceVariableNames: 'form collectionOfPoints '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Path commentStamp: '<historical>' prior: 0!
I am the abstract superclass of the Graphic spatial primitives. I represent an ordered sequence of Points. Spatial primitives are used to generate "trajectories" such as lines and circles.!


!Path methodsFor: 'accessing'!
at: index 
	"Answer the point on the receiver's path at position index."

	^collectionOfPoints at: index! !

!Path methodsFor: 'accessing'!
at: index put: aPoint 
	"Store the argument, aPoint, as the point on the receiver's path at position
	index."

	^collectionOfPoints at: index put: aPoint! !

!Path methodsFor: 'accessing'!
first
	"Answer the first point on the receiver's path; included to correspond to 
	OrderedCollection protocol."

	^collectionOfPoints first! !

!Path methodsFor: 'accessing'!
firstPoint
	"Answer the first point on the receiver's path."

	^collectionOfPoints first! !

!Path methodsFor: 'accessing'!
firstPoint: aPoint 
	"Replace the first element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 1 put: aPoint.
	^aPoint! !

!Path methodsFor: 'accessing'!
form
	"Answer the receiver's form, or, if form is nil, then answer a 1 x 1 black 
	form (a black dot)."

	| aForm |
	form == nil
		ifTrue: 
			[aForm _ Form extent: 1 @ 1.
			aForm fillBlack.
			^aForm]
		ifFalse: 
			[^form]! !

!Path methodsFor: 'accessing'!
form: aForm 
	"Make the argument, aForm, be the receiver's form."

	form _ aForm! !

!Path methodsFor: 'accessing'!
last
	"Answer the last point on the receiver's path; included to correspond to 
	OrderedCollection protocol."

	^collectionOfPoints last! !

!Path methodsFor: 'accessing'!
offset
	"There are basically two kinds of display objects in the system: those
	that, when asked to transform themselves, create a new object; and those
	that side effect themselves by maintaining a record of the transformation
	request (typically an offset). Path, like Rectangle and Point, is a display
	object of the first kind."

	self shouldNotImplement! !

!Path methodsFor: 'accessing'!
secondPoint
	"Answer the second element of the receiver."

	^collectionOfPoints at: 2! !

!Path methodsFor: 'accessing'!
secondPoint: aPoint 
	"Replace the second element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 2 put: aPoint.
	^aPoint! !

!Path methodsFor: 'accessing'!
size
	"Answer the length of the receiver."

	^collectionOfPoints size! !

!Path methodsFor: 'accessing'!
thirdPoint
	"Answer the third element of the receiver."

	^collectionOfPoints at: 3! !

!Path methodsFor: 'accessing'!
thirdPoint: aPoint 
	"Replace the third element of the receiver with the new value aPoint. 
	Answer the argument aPoint."

	collectionOfPoints at: 3 put: aPoint.
	^aPoint! !


!Path methodsFor: 'testing'!
isEmpty

	^collectionOfPoints isEmpty! !


!Path methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Display this Path--offset by aPoint, clipped by clipRect and the form 
	associated with this Path will be displayedr according to one of the sixteen 
	functions of two logical variables (rule). Also the source form will be first 
	anded with aForm as a mask. Does not effect the state of the Path"

	collectionOfPoints do: 
		[:element | 
		self form
			displayOn: aDisplayMedium
			at: element + aDisplayPoint
			clippingBox: clipRectangle
			rule: ruleInteger
			fillColor: aForm]! !

!Path methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Displays this path, translated and scaled by aTransformation. Get the
	scaled and translated Path."

	| newPath transformedPath |
	transformedPath _ displayTransformation applyTo: self.
	newPath _ Path new.
	transformedPath do: [:point | newPath add: point].
	newPath form: self form.
	newPath
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm! !


!Path methodsFor: 'display box access'!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	| box |
	box _ Rectangle origin: (self at: 1) extent: 0 @ 0.
	collectionOfPoints do: 
		[:aPoint | box _ box merge: (Rectangle origin: aPoint extent: 0 @ 0)].
	^box! !


!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:26'!
scaleBy: aPoint 
	"Answers a new Path scaled by aPoint. Does not affect the current data in 
	this Path."

	| newPath | 
	newPath _ self species new: self size. 
	newPath form: self form.
	collectionOfPoints do: [:element | newPath add: (element scaleBy: aPoint)].
	^newPath! !

!Path methodsFor: 'transforming' stamp: 'jrm 9/1/1999 21:28'!
translateBy: aPoint 
	"Answers a new Path whose elements are translated by aPoint. Does not
	affect the elements of this Path."

	| newPath |
	newPath _ self species new: self size.
	newPath form: self form.
	collectionOfPoints do: [:element | newPath add: (element translateBy: aPoint)].
	^newPath! !


!Path methodsFor: 'adding'!
add: aPoint 
	"Include aPoint as one of the receiver's elements."

	collectionOfPoints add: aPoint! !


!Path methodsFor: 'removing' stamp: 'di 4/4/2000 12:33'!
removeAllSuchThat: aBlock 
	"Evaluate aBlock for each element of the receiver.
	Remove each element for which aBlock evaluates to true."

	collectionOfPoints removeAllSuchThat: aBlock.
! !


!Path methodsFor: 'enumerating'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect the resulting values into a path that is like the receiver. Answer 
	the new path."

	| newCollection |
	newCollection _ collectionOfPoints collect: aBlock.
	newCollection form: self form.
	^newCollection! !

!Path methodsFor: 'enumerating'!
select: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new path like the receiver only those elements for which 
	aBlock evaluates to true. Answer the new path."

	| newCollection |
	newCollection _ collectionOfPoints select: aBlock.
	newCollection form: self form.
	^newCollection! !


!Path methodsFor: 'private'!
initializeCollectionOfPoints

	collectionOfPoints _ OrderedCollection new! !

!Path methodsFor: 'private'!
initializeCollectionOfPoints: anInteger

	collectionOfPoints _ OrderedCollection new: anInteger! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Path class
	instanceVariableNames: ''!

!Path class methodsFor: 'instance creation'!
new

	^self basicNew initializeCollectionOfPoints! !

!Path class methodsFor: 'instance creation'!
new: anInteger

	^self basicNew initializeCollectionOfPoints: anInteger! !


!Path class methodsFor: 'examples'!
example
	"Creates a Path from mousePoints and displays it several ways on the display screen. Messes up the display. For learning about class Path, just select the code below and execute it to create a path and see it redisplayed in another place on the screen. Each path displays using a different form. A path is indicated by pressing the red mouse button in a sequence; press any other mouse button to terminate. "

	| aPath aForm pl fl flag |
	aForm _ Form extent: 2 @ 40.		"creates a form one inch long"
	aForm fillBlack.							"turns it black"
	aPath _ Path new.
	aPath form: aForm.						"use the long black form for displaying"
	flag _ true.
	[flag]
		whileTrue: 
			[Sensor waitButton.
			Sensor redButtonPressed
				ifTrue: 
					[aPath add: Sensor waitButton.
					Sensor waitNoButton.
					aForm displayOn: Display at: aPath last]
				ifFalse: [flag _ false]].
	Display fillWhite.
	aPath displayOn: Display.			"the original path"
	pl _ aPath translateBy: 0 @ 100.
	fl _ Form extent: 40 @ 40.
	fl fillGray.
	pl form: fl.
	pl displayOn: Display.				"the translated path"
	Sensor waitNoButton

	"Path example"! !
BitBlt subclass: #Pen
	instanceVariableNames: 'location direction penDown '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Pen commentStamp: '<historical>' prior: 0!
My instances can scribble on the screen or some other Form, drawing and printing at any angle. Since I am a BitBlt, the drawing can be done with an arbitary source Form.
!


!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:02'!
defaultNib: widthInteger 
	"Nib is the tip of a pen. This sets up the pen, with a nib of width widthInteger. You can also set the shape of the pen nib using:
		roundNib: widthInteger, or
		squareNib: widthInteger, or
		sourceForm: aForm"
"Example:
	| bic |
	bic _ Pen new sourceForm: Cursor normal.
	bic combinationRule: Form paint; turn: 90.
	10 timesRepeat: [bic down; go: 3; up; go: 10]."

	self color: Color black.
	self squareNib: widthInteger.
! !

!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:03'!
roundNib: diameter
	"Makes this pen draw with a round dot of the given diameter."

	self sourceForm: (Form dotOfSize: diameter).
	combinationRule _ Form paint.
! !

!Pen methodsFor: 'initialize-release' stamp: 'jm 4/28/1998 04:03'!
squareNib: widthInteger 
	"Makes this pen draw with a square nib of the given width."

	self sourceForm: (Form extent: widthInteger @widthInteger) fillBlack.
	self combinationRule: Form over.  "a bit faster than paint mode"
! !


!Pen methodsFor: 'accessing'!
direction
	"Answer the receiver's current direction. 0 is towards the top of the
	screen."

	^direction! !

!Pen methodsFor: 'accessing'!
location
	"Answer where the receiver is currently located."

	^location! !


!Pen methodsFor: 'operations' stamp: 'jm 4/28/1998 03:40'!
color: aColorOrInteger
	"Set the pen to the given color or to a color chosen from a fixed set of colors."

	| count c |
	aColorOrInteger isInteger
		ifTrue: [
			destForm depth = 1 ifTrue: [^ self fillColor: Color black].
			count _ 19.  "number of colors in color wheel"
			c _ (Color red wheel: count) at: ((aColorOrInteger * 7) \\ count) + 1]
		ifFalse: [c _ aColorOrInteger].  "assume aColorOrInteger is a Color"
	self fillColor: c.
! !

!Pen methodsFor: 'operations'!
down
	"Set the state of the receiver's pen to down (drawing)."

	penDown _ true! !

!Pen methodsFor: 'operations' stamp: 'di 6/21/1998 09:37'!
fill: drawBlock color: color
	| region tileForm tilePen shape saveColor recorder |
	drawBlock value: (recorder _ self as: PenPointRecorder).
	region _ Rectangle encompassing: recorder points.
	tileForm _ Form extent: region extent+6.
	tilePen _ Pen newOnForm: tileForm.
	tilePen location: location-(region origin-3)
		direction: direction
		penDown: penDown.
	drawBlock value: tilePen.  "Draw the shape in B/W"
	saveColor _ halftoneForm.
	drawBlock value: self.
	halftoneForm _ saveColor.
	shape _ (tileForm findShapeAroundSeedBlock: [:f | f borderWidth: 1]) reverse.
	shape copy: shape boundingBox from: tileForm to: 0@0 rule: Form erase.
	destForm fillShape: shape fillColor: color at: region origin-3! !

!Pen methodsFor: 'operations'!
go: distance 
	"Move the pen in its current direction a number of bits equal to the 
	argument, distance. If the pen is down, a line will be drawn using the 
	receiver's form source as the shape of the drawing brush."

	self goto: (direction degreeCos @ direction degreeSin) * distance + location! !

!Pen methodsFor: 'operations' stamp: 'di 11/4/97 20:11'!
goto: aPoint 
	"Move the receiver to position aPoint. If the pen is down, a line will be 
	drawn from the current position to the new one using the receiver's 
	form source as the shape of the drawing brush. The receiver's set 
	direction does not change."
	| old |
	old _ location.
	location _ aPoint.
	penDown ifTrue: [self drawFrom: old rounded
								to: location rounded]

	"NOTE:  This should be changed so it does NOT draw the first point, so as
	not to overstrike at line junctions.  At the same time, place should draw
	a single dot if the pen is down, as should down (put-pen-down) if it
	was not down before."! !

!Pen methodsFor: 'operations'!
home
	"Place the receiver at the center of its frame."
	location _ destForm boundingBox center! !

!Pen methodsFor: 'operations'!
north
	"Set the receiver's direction to facing toward the top of the display screen."

	direction _ 270! !

!Pen methodsFor: 'operations'!
place: aPoint 
	"Set the receiver at position aPoint. No lines are drawn."

	location _ aPoint! !

!Pen methodsFor: 'operations' stamp: 'ar 5/28/2000 12:10'!
print: str withFont: font
	"Print the given string in the given font at the current heading"
	| lineStart form charStart rowStart scale wasDown bb pix |
	scale _ sourceForm width.
	wasDown _ penDown.
	lineStart _ location.
	str do:
		[:char |
		char = Character cr ifTrue:
			[self place: lineStart; up; turn: 90; go: font height*scale; turn: -90; down]
		ifFalse:
			[form _ font characterFormAt: char.
			charStart _ location.
wasDown ifTrue: [
			self up; turn: -90; go: font descent*scale; turn: 90; down.
			0 to: form height-1 do:
				[:y |
				rowStart _ location.
				bb _ BitBlt current bitPeekerFromForm: form.
				pix _ RunArray newFrom:
					((0 to: form width-1) collect: [:x | bb pixelAt: x@y]).
				pix runs with: pix values do:
					[:run :value |
					value = 0
						ifTrue: [self up; go: run*scale; down]
						ifFalse: [self go: run*scale]].
				self place: rowStart; up; turn: 90; go: scale; turn: -90; down].
].
			self place: charStart; up; go: form width*scale; down].
			].
	wasDown ifFalse: [self up]
"
Display restoreAfter:
[Pen new squareNib: 2; color: Color red; turn: 45;
	print: 'The owl and the pussycat went to sea
in a beautiful pea green boat.' withFont: TextStyle defaultFont]
"! !

!Pen methodsFor: 'operations'!
turn: degrees 
	"Change the direction that the receiver faces by an amount equal to the 
	argument, degrees."

	direction _ direction + degrees! !

!Pen methodsFor: 'operations'!
up
	"Set the state of the receiver's pen to up (no drawing)."

	penDown _ false! !


!Pen methodsFor: 'geometric designs' stamp: 'di 6/11/1998 22:01'!
dragon: n  "Display restoreAfter: [Display fillWhite. Pen new dragon: 10]."
	"Display restoreAfter: [Display fillWhite. 1 to: 4 do:
				[:i | Pen new color: i; turn: 90*i; dragon: 10]]"
	"Draw a dragon curve of order n in the center of the screen."
	n = 0
		ifTrue: [self go: 5]
		ifFalse: [n > 0
				ifTrue: [self dragon: n - 1; turn: 90; dragon: 1 - n]
				ifFalse: [self dragon: -1 - n; turn: -90; dragon: 1 + n]]
! !

!Pen methodsFor: 'geometric designs' stamp: 'di 6/14/1998 13:42'!
filberts: n side: s   "Display restoreAfter: [Pen new filberts: 4 side: 5]"
	"Two Hilbert curve fragments form a Hilbert tile. Draw four interlocking 
	tiles of order n and sides length s."
	| n2 |
	Display fillWhite.
	n2 _ 1 bitShift: n - 1.
	self up; go: 0 - n2 * s; down.
	1 to: 4 do: 
		[:i | 
		self fill: [:p |
				p hilbert: n side: s.
				p go: s.
				p hilbert: n side: s.
				p go: s.
				p up.
				p go: n2 - 1 * s.
				p turn: -90.
				p go: n2 * s.
				p turn: 180.
				p down]
			color: (Color perform: (#(yellow red green blue) at: i))]! !

!Pen methodsFor: 'geometric designs'!
hilbert: n side: s 
	"Draw an nth level Hilbert curve with side length s in the center of the 
	screen. Write directly into the display's bitmap only. A Hilbert curve is 
	a space-filling curve."

	| a m |
	n = 0 ifTrue: [^self turn: 180].
	n > 0
		ifTrue: 
			[a _ 90.
			m _ n - 1]
		ifFalse: 
			[a _ -90.
			m _ n + 1].
	self turn: a.
	self hilbert: 0 - m side: s.
	self turn: a; go: s.
	self hilbert: m side: s.
	self turn: 0 - a; go: s; turn: 0 - a.
	self hilbert: m side: s.
	self go: s; turn: a.
	self hilbert: 0 - m side: s.
	self turn: a
	" 
	(Pen new) hilbert: 3 side: 8. 
	(Pen new sourceForm: Cursor wait) combinationRule: Form under; 
	hilbert: 3 side: 25.
	"! !

!Pen methodsFor: 'geometric designs'!
hilberts: n   "Display restoreAfter: [Display fillWhite.  Pen new hilberts: 5]"
	"Draws n levels of nested Hilbert curves"
	| s |
	self up; turn: 90; go: 128; down.
	1 to: n do: 
		[:i | 
		s _ 256 bitShift: 0 - i.
		self defaultNib: n - i * 2 + 1.
		self color: i+1.
		self up; go: 0 - s / 2; turn: -90; go: s / 2; turn: 90; down.
		self hilbert: i side: s.
		self go: s.
		self hilbert: i side: s.
		self go: s]! !

!Pen methodsFor: 'geometric designs'!
mandala: npoints
	"Display restoreAfter: [Pen new mandala: 30]"
	"On a circle of diameter d, place npoints number of points. Draw all 	possible connecting lines between the circumferential points."
	| l points d |
	Display fillWhite.
	d _ Display height-50.
	l _ 3.14 * d / npoints.
	self home; up; turn: -90; go: d // 2; turn: 90; go: 0 - l / 2; down.
	points _ Array new: npoints.
	1 to: npoints do: 
		[:i | 
		points at: i put: location rounded.
		self go: l; turn: 360.0 / npoints].
	npoints // 2
		to: 1
		by: -1
		do: 
			[:i | 
			self color: i.
			1 to: npoints do: 
				[:j | 
				self place: (points at: j).
				self goto: (points at: j + i - 1 \\ npoints + 1)]]
! !

!Pen methodsFor: 'geometric designs' stamp: 'jm 5/6/1998 22:26'!
spiral: n angle: a 
	"Draw a double squiral (see Papert, MindStorms), where each design is made
	by moving the receiver a distance of n after turning the amount + or -a."

	1 to: n do: 
		[:i | 
		self color: i * 2.
		self go: i; turn: a]
"
	Display restoreAfter: [
		Display fillWhite. Pen new spiral: 200 angle: 89; home; spiral: 200 angle: -89].
"! !

!Pen methodsFor: 'geometric designs' stamp: 'jm 8/1/97 11:42'!
web   "Display restoreAfter: [Pen new web]"
	"Draw pretty web-like patterns from the mouse movement on the screen.
	Press the mouse button to draw, option-click to exit.
	By Dan Ingalls and Mark Lentczner. "
	| history newPoint ancientPoint lastPoint filter color |
	"self erase."
	color _ 1.
	[ true ] whileTrue:
		[ history _ OrderedCollection new.
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ lastPoint _ Sensor mousePoint.
		20 timesRepeat: [ history addLast: lastPoint ].
		self color: (color _ color + 1).
		[ Sensor redButtonPressed ] whileTrue: 
			[ newPoint _ Sensor mousePoint.
			(newPoint = lastPoint) ifFalse:
				[ ancientPoint _ history removeFirst.
				filter _ filter * 4 + newPoint // 5.
				self place: filter.
				self goto: ancientPoint.
				lastPoint _ newPoint.
				history addLast: filter ] ] ]! !


!Pen methodsFor: 'private' stamp: 'di 6/11/1998 16:09'!
location: aPoint direction: aFloat penDown: aBoolean
	location _ aPoint.
	direction _ aFloat.
	penDown _ aBoolean! !

!Pen methodsFor: 'private'!
sourceForm: aForm
	(aForm depth = 1 and: [destForm depth > 1])
		ifTrue: ["Map 1-bit source to all ones for color mask"
				colorMap _ Bitmap with: 0 with: 16rFFFFFFFF]
		ifFalse: [colorMap _ nil].
	^ super sourceForm: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Pen class
	instanceVariableNames: ''!

!Pen class methodsFor: 'instance creation'!
new
	^ self newOnForm: Display! !

!Pen class methodsFor: 'instance creation'!
newOnForm: aForm
	| pen |
	pen _ super new.
	pen setDestForm: aForm.
	pen sourceOrigin: 0@0.
	pen home.
	pen defaultNib: 1.
	pen north.
	pen down.
	^ pen! !


!Pen class methodsFor: 'examples' stamp: 'jm 5/6/1998 22:28'!
example
	"Draw a spiral with a pen that is 2 pixels wide."
	"Display restoreAfter: [Pen example]"

	| bic |
	bic _ self new.
	bic defaultNib: 2.
	bic color: Color blue.
	bic combinationRule: Form over.
	1 to: 100 do: [:i | bic go: i*4. bic turn: 89].
! !


!Pen class methodsFor: 'tablet drawing examples' stamp: 'ar 5/28/2000 12:12'!
feltTip: width cellSize: cellSize
	"Warning: This example potentially uses a large amount of memory--it creates a Form with cellSize squared bits for every Display pixel."
	"In this example, all drawing is done into a large, monochrome Form and then scaled down onto the Display using smoothing. The larger the cell size, the more possible shades of gray can be generated, and the smoother the resulting line appears. A cell size of 8 yields 64 possible grays, while a cell size of 16 gives 256 levels, which is about the maximum number of grays that the human visual system can distinguish. The width parameter determines the maximum line thickness. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen feltTip: 2.7 cellSize: 8"

	| tabletScale bitForm pen warp p srcR dstR nibSize startP r |
	tabletScale _ self tabletScaleFactor.
	bitForm _ Form extent: Display extent * cellSize depth: 1.
	pen _ Pen newOnForm: bitForm.
	pen color: Color black.
	warp _ (WarpBlt current toForm: Display)
		sourceForm: bitForm;
		colorMap: (bitForm colormapIfNeededForDepth: Display depth);
		cellSize: cellSize;
		combinationRule: Form over.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * cellSize * tabletScale) rounded.
			nibSize _ (Sensor tabletPressure * (cellSize * width)) rounded.
		     nibSize > 0
				ifTrue: [
					pen squareNib: nibSize.
					startP _ pen location.
					pen goto: p.
					r _ startP rect: pen location.
					dstR _ (r origin // cellSize) corner: ((r corner + nibSize + (cellSize - 1)) // cellSize).
					srcR _ (dstR origin * cellSize) corner: (dstR corner * cellSize).
					warp copyQuad: srcR innerCorners toRect: dstR]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:20'!
inkBrush
	"Similar to simplePressurePen, but this example uses the average of the recent pen pressure values. The effect is that of a Japanese ink brush that comes up gradually off the paper as the brush is lifted, causing end (and beginning) of each stroke to taper. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen inkBrush"

	| tabletScale historyMSecs pressureHistory pen now currentPressure sum averagePressure p |
	tabletScale _ self tabletScaleFactor.
	historyMSecs _ 120.
	pressureHistory _ OrderedCollection new.
	pen _ Pen newOnForm: Display.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			"compute the average pressure over last historyMSecs milliseconds"
			now _ Time millisecondClockValue.
			currentPressure _ (20.0 * Sensor tabletPressure) rounded.
			pressureHistory addLast: (Array with: now with: currentPressure).
			[pressureHistory size > 0 and:
			 [(pressureHistory first first + historyMSecs) < now]]
				whileTrue: [pressureHistory removeFirst].  "prune old entries"
			sum _ pressureHistory inject: 0 into: [:t :e | t + e last].
			averagePressure _ sum // pressureHistory size.

			p _ (Sensor tabletPoint * tabletScale) rounded.
		     averagePressure > 0
				ifTrue: [
					pen roundNib: averagePressure.
					pen goto: p]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:13'!
simplePressurePen
	"An example of using a pressure sensitive pen to control the thickness of the pen. This requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." 
	"Pen simplePressurePen"

	| tabletScale pen pressure p |
	tabletScale _ self tabletScaleFactor.
	pen _ Pen newOnForm: Display.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * tabletScale) rounded.
			pressure _ (15.0 * Sensor tabletPressure) rounded.
		     pressure > 0
				ifTrue: [
					pen roundNib: pressure.
					pen goto: p]
				ifFalse: [
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:12'!
tabletScaleFactor
	"Answer a Point that scales tablet coordinates to Display coordinates, where the full extent of the tablet maps to the extent of the entire Display."

	| tabletExtent |
	tabletExtent _ Sensor tabletExtent.
	^ (Display width asFloat / tabletExtent x) @ (Display height asFloat / tabletExtent y)
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/12/1999 12:51'!
testMouseTracking
	"A very simple example of drawing using the mouse. Compare the tracking speed of this example with that of testTabletTracking. Mouse down to draw a stroke, shift-mouse to exit." 
	"Pen testMouseTracking"

	| pen p |
	pen _ Pen newOnForm: Display.
	pen roundNib: 8.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ Sensor cursorPoint.
		     Sensor anyButtonPressed
				ifTrue: [pen goto: p]
				ifFalse: [
					pen color: Color random.
					pen place: p]]].
! !

!Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:21'!
testTabletTracking
	"A very simple example of drawing using the pen of a digitizing tablet such as a Wacom ArtZ tablet. This requires the optional tablet support primitives which may not be supported on all platforms. Compare the tracking speed of this example with that of testMouseTracking. On a Macintosh, the tablet primitives provide roughly 120 samples/second versus only 60 mouse samples/second, and the difference is noticable. Works best in full screen mode. Mouse down to draw a stroke, shift-mouse to exit." 
	"Pen testTabletTracking"

	| tabletScale pen p |
	tabletScale _ self tabletScaleFactor.
	pen _ Pen newOnForm: Display.
	pen roundNib: 8.
	pen color: Color black.
	Display fillColor: Color white.
	Display restoreAfter: [
		[Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [
			p _ (Sensor tabletPoint * tabletScale) rounded.
		     Sensor tabletPressure > 0
				ifTrue: [pen goto: p]
				ifFalse: [
					pen color: Color random.
					pen place: p]]].
! !
Pen subclass: #PenPointRecorder
	instanceVariableNames: 'points '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!PenPointRecorder commentStamp: '<historical>' prior: 0!
This class is a special kind of Pen that instead of actually drawing lines records the destination points for those lines. These points can later be accessed through my accessing method #points.

This can be useful when determining the boundaries of a drawing session.

Example:

| pen |
pen _ PenPointRecorder new.
pen up; goto: 100@100; down; goto: 120@120.
Transcript cr;
	show: 'Bounding box for drawing: ';
	show: (Rectangle encompassing: pen points)

Implementation note: Shouldn't we override #drawFrom:to:withFirstPoint: instead, and what about #drawLoopX:Y:? Aren't we missing those calls?!


!PenPointRecorder methodsFor: 'accessing' stamp: 'di 6/21/1998 09:35'!
points
	^ points! !


!PenPointRecorder methodsFor: 'line drawing' stamp: 'sma 2/26/2000 19:03'!
drawFrom: p1 to: p2.
	"Overridden to skip drawing but track bounds of the region traversed."

	points ifNil: [points _ OrderedCollection with: p1].
	points addLast: p2! !
Object subclass: #Phoneme
	instanceVariableNames: 'name properties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!Phoneme commentStamp: '<historical>' prior: 0!
My instances are phonemes. See also PhonemeSet class.!


!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:33'!
example
	^ self at: #example ifAbsent: []! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:34'!
example: aString
	self at: #example put: aString! !

!Phoneme methodsFor: 'accessing' stamp: 'len 4/9/98 23:13'!
name
	^ name! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:33'!
name: aString
	name _ aString! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:35'!
stress
	"Answer the stress level of the receiver."
	^ self at: #stress ifAbsent: [0]! !

!Phoneme methodsFor: 'accessing' stamp: 'len 6/9/1999 01:38'!
stress: aNumber
	"Set the stress level of the receiver."
	self at: #stress put: aNumber! !


!Phoneme methodsFor: 'comparing' stamp: 'len 6/1/1999 02:13'!
= aPhoneme
	^ self species == aPhoneme species and: [self name = aPhoneme name]! !

!Phoneme methodsFor: 'comparing' stamp: 'len 5/29/1999 04:01'!
hash
	^ self name hash! !


!Phoneme methodsFor: 'copying' stamp: 'len 6/9/1999 02:10'!
copy
	^ super copy properties: properties copy! !


!Phoneme methodsFor: 'testing' stamp: 'len 6/9/1999 01:27'!
hasFeature: aSymbol
	^ self hasProperty: aSymbol! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isAffricate
	"Answer true if the receiver is an affricate phoneme."
	^ self hasFeature: #affricate! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isBackVowel
	"Answer true if the receiver is a back vowel phoneme."
	^ self isVowel and: [self hasFeature: #back]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isConsonant
	"Answer true if the receiver is a consonant phoneme."
	^ self hasFeature: #consonant! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isContinuant
	"Answer true if the receiver is a continuant phoneme."
	^ self hasFeature: #continuant! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isDiphthong
	"Answer true if the receiver is a diphthong phoneme."
	^ self hasFeature: #diphthong! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/10/1999 00:26'!
isFricative
	"Answer true if the receiver is a fricative phoneme."
	^ self hasFeature: #fricative! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isFrontVowel
	"Answer true if the receiver is a front vowel phoneme."
	^ self isVowel and: [self hasFeature: #front]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:02'!
isGlide
	"Answer true if the receiver is a glide phoneme."
	^ self hasFeature: #glide! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isLiquid
	"Answer true if the receiver is a liquid phoneme."
	^ self hasFeature: #liquid! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isMidVowel
	"Answer true if the receiver is a mid vowel phoneme."
	^ self isVowel and: [self hasFeature: #mid]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isNasal
	"Answer true if the receiver is an nasal phoneme."
	^ self hasFeature: #nasal! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 01:29'!
isNonContinuant
	"Answer true if the receiver is a noncontinuant phoneme."
	^ self isContinuant not! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 01:39'!
isObstruent
	"Answer true if the receiver is an obstruent phoneme."
	^ self isStop or: [self isFricative or: [self isAffricate]]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isSemivowel
	"Answer true if the receiver is a semivowel phoneme."
	^ self hasFeature: #semivowel! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/8/1999 01:21'!
isSilence
	"Answer true if the receiver is the silence phoneme."
	^ self hasFeature: #silence! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 01:39'!
isSonorant
	"Answer true if the receiver is a sonorant phoneme."
	^ self isObstruent not! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isStop
	"Answer true if the receiver is a stop phoneme."
	^ self hasFeature: #stop! !

!Phoneme methodsFor: 'testing' stamp: 'len 8/16/1999 00:46'!
isSyllabic
	"Answer true if the receiver is a syllabic consonant (or a vowel)."
	^ self isVowel or: [self isDiphthong]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isUnvoiced
	"Answer true if the receiver is an uvoiced phoneme."
	^ self hasFeature: #unvoiced! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isVoiced
	"Answer true if the receiver is a voiced phoneme."
	^ self hasFeature: #voiced! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/21/1999 19:55'!
isVoicedConsonant
	"Answer true if the receiver is a voiced consonant."
	^ self isVoiced and: [self isConsonant]! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isVowel
	"Answer true if the receiver is a vowel phoneme."
	^ self hasFeature: #vowel! !

!Phoneme methodsFor: 'testing' stamp: 'len 6/2/1999 02:03'!
isWhisper
	"Answer true if the receiver is an whisper phoneme."
	^ self hasFeature: #whisper! !


!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:28'!
addProperty: anObject
	self at: anObject put: #nothing! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:26'!
at: anObject
	^ properties at: anObject! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:45'!
at: anObject ifAbsent: aBlock
	properties isNil ifFalse: [^ properties at: anObject ifAbsent: aBlock].
	^ aBlock value! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:27'!
at: anObject put: anotherObject
	properties isNil ifTrue: [properties _ IdentityDictionary new].
	^ properties at: anObject put: anotherObject! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/10/1999 01:46'!
hasProperty: anObject
	^ properties notNil and: [properties includesKey: anObject]! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:30'!
properties
	^ properties! !

!Phoneme methodsFor: 'properties' stamp: 'len 6/9/1999 01:34'!
properties: anIdentityDictionary
	properties _ anIdentityDictionary! !


!Phoneme methodsFor: 'transforming' stamp: 'len 6/9/1999 01:35'!
stressed: aNumber
	^ self copy stress: aNumber! !


!Phoneme methodsFor: 'printing' stamp: 'len 8/17/1999 01:19'!
printOn: aStream
	name isNil ifTrue: [^ super printOn: aStream].
	aStream nextPutAll: name.
	self stress > 0 ifTrue: [aStream print: self stress]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Phoneme class
	instanceVariableNames: ''!

!Phoneme class methodsFor: 'instance creation' stamp: 'len 5/30/1999 01:17'!
name: aString
	^ self new name: aString! !

!Phoneme class methodsFor: 'instance creation' stamp: 'len 5/29/1999 04:34'!
name: aString example: anotherString
	^ self new name: aString; example: anotherString! !

!Phoneme class methodsFor: 'instance creation' stamp: 'len 6/9/1999 01:32'!
name: aString example: anotherString features: anArray
	| answer |
	answer _ self new name: aString; example: anotherString.
	anArray do: [ :each | answer addProperty: each].
	^ answer! !
AlignmentMorph subclass: #PhonemeRecognizerMorph
	instanceVariableNames: 'soundInput statusLight levelMeter phonemeDisplay phonemeRecords silentPhoneme currentPhoneme '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognizer'!
!PhonemeRecognizerMorph commentStamp: '<historical>' prior: 0!
I am experimental phoneme recognizer. My approach to phoneme recognition is fairly crude, but the goal is not full speech recognition, but merely a close enough approximation to drive the mouth of an animated character from speech input.

How it works:

The phoneme recognizer has a collection of phoneme examples that were recorded in advance. Each of these phomemes has a "features vector" that describes that phoneme. Currently, feature vectors are basically a simplified version of the frequency spectrum measuring the sound energy in about two dozen frequency bands up to around 4000 Hz. The exact parameters are described in the class initialization method of PhonemeRecord and can be tweaked.

To do phoneme recognition, a short window of sound is analyzed via FFT, and its feature vector is extracted. This feature vector is then compared to the feature vectors of all phonemes in the example set. The phoneme that matches most closely is considered the currently sounding phoneme. This phoneme's name is presented in the PhonemeRecognizer display. On a reasonably fast machine, the current phoneme can be watched by a program and used to drive real-time mouth animation . This phoneme matching approach is similar to some of the earliest speech recognition work. However, current speech recognition software is generally driven by features derived from a linear predictive or vocal tract model of speech, rather than the raw spectrum data.

How to Use It

The first step is to plan how many different mouth positions will be used by the animation, and which phonemes map to which mouth positions. Traditional animators might draw four mouth positions for vowels and four to six for consonants.

The person whose speech is to be recognized then records phoneme examples for the phonemes to be recognized. For animation, these phonems might consist of the vowel sounds "eh", "ee", "ah", "o", "u" and the consonants "n", "r", "s", "sh", "th", "z", "l", "r", "w", and "m". In some cases "f" and "v" might also be included. The consonants "b" and "p" are also significant in animation, since these sounds, like "m", bring the lips together. Unfortunately, "b" and "p" are tricky to recognize with the scheme used here because they are actually two things in quick succession: a momentary silence followed by the sound of the released breath. However, if the mouth position for silence is drawn with the mouth closed, then the animation of "b" and "p" will probably look okay.

Each phoneme example is recorded by clicking the "add" button and speaking the phoneme into the microphone. Leading and trailing silence is automatically removed. The user is prompted for the phoneme name and a mouth position index. The name is just a mnemonic for the user. The index can be used to select a costume from a holder during animation. It is handy to list and number the mouth positions before recording the phoneme example set.

A phoneme can be reviewed with the "play phoneme" menu command. If it contains noise, includes slides between several different sounds, or doesn't sound like a representative example of the phoneme, delete it and record it again. English contains a number of "diphthongs"--vowel sounds that are actually slides between two different vowel sounds, as in the words "boy" or "boat". It is best to record each component of a diphthong individually. You can also set the name and mouth position index for the "silence" phoneme, the phoneme that is reported whenever the input sound falls below a certain threshold. A graphical view of the features vector for a given phoneme can be generated by selecting "show phoneme features" from the menu. A phoneme set can be saved to a file and restored later.

Once you have recorded your phoneme examples, you can try them by clicking the "run" button and speaking into the microphone. You should see the phoneme display update to report the current match. The "match sound file" menu command can be used to analyze an entire AIFF or a WAV sound file at once. The resulting phoneme stream is currently reported by opening an inspector on the phoneme list. There is one phoneme in this list for each 1/24th of a second window of sound in the sound file.

To allow use of the phoneme recognizer in tile scripts, the "mouth position tile" menu command creates a tile that reports the current phonemes mouth position index. This can be used to set the cursor of a holder containing the set of mouth position drawings. A two-line tile script can thus drive the mouth of an animated character.
!


!PhonemeRecognizerMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:56'!
initialize

	| r |
	super initialize.
	borderWidth _ 2.
	self listDirection: #topToBottom.
	soundInput _ SoundInputStream new samplingRate: 22050.
	phonemeRecords _ OrderedCollection new.
	silentPhoneme _ PhonemeRecord new initialize name: '...'.
	currentPhoneme _ silentPhoneme.  "the PhonemeRecord of the current match"
	self addTitle.
	self addButtonRows.
	self addLevelSlider.
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: self makeLevelMeter.
	self addMorphBack: r.
	self addPhonemeDisplay.
	self extent: 10@10.  "make minimum size"
! !


!PhonemeRecognizerMorph methodsFor: 'accessing' stamp: 'jm 5/18/2000 18:28'!
currentPhonemeMouthPosition
	"Answer the mouth position index (a position integer) of the currently matching phoneme."

	^ currentPhoneme mouthPosition
! !

!PhonemeRecognizerMorph methodsFor: 'accessing' stamp: 'jm 5/18/2000 18:27'!
currentPhonemeName
	"Answer the name of the currently matching phoneme."

	^ currentPhoneme name
! !

!PhonemeRecognizerMorph methodsFor: 'accessing' stamp: 'jm 5/22/2000 17:32'!
getMouthPosition
	"Answer the mouth position index (a position integer) of the currently matching phoneme. Sent by tile scripts."

	^ currentPhoneme mouthPosition
! !


!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/23/2000 06:06'!
addPhoneme
	"Record and add a new phoneme example to my phoneme set. Prompt the user for its name and mouth position."

	| phoneme |
	Utilities
		informUser: 'Press and hold the mouse button while speaking the phoneme.'
		during: [Sensor waitButton].
	soundInput isRecording ifTrue: [self stop].
	phoneme _ PhonemeRecord new initialize.
	phoneme recordWithLevel: soundInput recordLevel.
	phoneme samples size < 10000 ifTrue: [
		^ self inform: 'Nothing recorded; check the record input source and adjust the level'].

	self promptForDetailsOfPhoneme: phoneme.
	phonemeRecords addLast: phoneme.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/23/2000 05:52'!
changePhonemeDetails
	"Change the name and mouth position index of a phoneme specified by the user."

	| phoneme |
	phoneme _ self selectPhonemeFromMenu.
	phoneme ifNotNil: [self promptForDetailsOfPhoneme: phoneme].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/18/2000 18:20'!
deletePhoneme
	"Delete a phoneme specified by the user."

	| phoneme |
	phoneme _ self selectPhonemeFromMenu.
	phoneme ifNotNil: [
		phonemeRecords remove: phoneme ifAbsent: []].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/23/2000 05:53'!
invokeMenu
	"Invoke the settings menu."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	#(
		('add phoneme'				addPhoneme)
		('play phoneme'				playPhoneme)
		('show phoneme features'	showPhonemeFeatures)
		('change phoneme name'	changePhonemeDetails)
		('set phoneme for silence'	setSilentPhoneme)
		('delete phoneme'			deletePhoneme)
		-
		('mouth position tile'		makeTile)
		('match sound file'			matchSoundFile)
		-
		('save phonemes to file'		savePhonemes)
		('read phoneme from file'	readPhonemes)).
	aMenu invokeOn: self defaultSelection: nil.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/22/2000 17:53'!
makeTile
	"Make a scripting tile to fetch the current phoneme's mouth position. Attach it to the hand, allowing the user to drop it directly into a tile script."

	| tile argTile |
	tile _ PhraseTileMorph new setSlotRefOperator: #mouthPosition type: #number.
	argTile _ TileMorph new
		setObjectRef: nil actualObject: self;
		typeColor: (ScriptingSystem colorForType: #object).
	argTile bePossessive.
	tile firstSubmorph addMorph: argTile.
	tile enforceTileColorPolicy.
	self world firstHand attachMorph: tile.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/23/2000 05:44'!
matchSoundFile
	"Process an AIFF or WAV sound file and generate a sequence of phoneme matches for that file in the Transcript. When done, open an inspector on the resulting collection of phonemes."

	| fileName snd out fftSize samplesPerInterval startIndex buf p |
	self inform: 'Sorry, sound file matching is not yet implemented'.
	fileName _ Utilities
		chooseFileWithSuffixFromList: #('.aif' '.aiff' '.wav')
		withCaption: 'Sound file?'.
	fileName = #none ifTrue: [^ self inform: 'No sound files.'].

	('*aif*' match: fileName) ifTrue:
		[snd _ SampledSound fromAIFFfileNamed: fileName].
	('*wav' match: fileName) ifTrue:
		[snd _ SampledSound fromWaveFileNamed: fileName].

	out _ OrderedCollection new: 1000.
	fftSize _ PhonemeRecord fftSize.
	samplesPerInterval _ snd samplingRate / 24.0.
	1 to: (snd samples size - fftSize) + 1 by: samplesPerInterval do: [:i |
		startIndex _ i truncated.
		buf _ snd samples copyFrom: startIndex to: startIndex + fftSize - 1.
		out addLast: (p _
			self findMatchFor: buf samplingRate: snd samplingRate).
p name asParagraph display.
(SampledSound samples: buf samplingRate: 11025) playAndWaitUntilDone.
].
	out asArray inspect.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/18/2000 18:20'!
playPhoneme
	"Play a phoneme specified by the user."

	| phoneme |
	phoneme _ self selectPhonemeFromMenu.
	phoneme ifNotNil: [phoneme play].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'mdr 9/4/2000 10:47'!
readPhonemes
	"Read a previously saved phoneme set from a file."

	| fname s newPhonemes |
	fname _ Utilities
		chooseFileWithSuffixFromList: #('.pho' '.phonemes')
		withCaption: 'Phoneme file?'.
	fname == nil ifTrue: [^ self].
	fname ifNil: [^ self].

	s _ FileStream readOnlyFileNamed: fname.
	newPhonemes _ s fileInObjectAndCode.
	s close.
	phonemeRecords _ newPhonemes.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/22/2000 17:39'!
savePhonemes
	"Save the current phoneme set in a file."

	| fname refStream |
	fname _ FillInTheBlank request: 'Phoneme file name?'.
	fname isEmpty ifTrue: [^ self].
	((fname endsWith: '.pho') or: [fname endsWith: '.phonemes'])
		ifFalse: [fname _ fname, '.phonemes'].
	refStream _ SmartRefStream fileNamed: fname.
	refStream nextPut: phonemeRecords.
	refStream close.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/23/2000 06:18'!
setSilentPhoneme
	"Prompt the user for the name and mouth position associated with silence."

	self promptForDetailsOfPhoneme: silentPhoneme.
	phonemeDisplay contents: currentPhoneme name.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/22/2000 17:40'!
showPhonemeFeatures
	"Show a graph of the features array for the phoneme selected by the user."

	| phoneme m |
	phoneme _ self selectPhonemeFromMenu.
	phoneme ifNotNil: [
		m _ ImageMorph new image: phoneme featuresGraph.
		self world firstHand attachMorph: m].
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/22/2000 17:37'!
startRecognizing
	"Start recognizing phonemes from the sound input."

	self stopRecognizing.
	soundInput bufferSize: (PhonemeRecord fftSize).
	soundInput startRecording.
! !

!PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'jm 5/18/2000 18:24'!
stopRecognizing
	"Stop listening."

	soundInput stopRecording.
	currentPhoneme _ silentPhoneme.
! !


!PhonemeRecognizerMorph methodsFor: 'stepping' stamp: 'jm 5/23/2000 05:42'!
step
	"Update the record light, level meter, and display."

	| w buf p |
	"update the record light and level meter"
	soundInput isRecording
		ifTrue: [statusLight color: Color yellow]
		ifFalse: [statusLight color: Color gray].
	w _ ((121 * soundInput meterLevel) // 100) max: 1.
	levelMeter width ~= w ifTrue: [levelMeter width: w].

	soundInput isRecording ifTrue: [
		[soundInput bufferCount > 0] whileTrue: [
			"skip to the most recent buffer"
			buf _ soundInput nextBufferOrNil].
		buf ifNotNil: [
			p _ self findMatchFor: buf samplingRate: soundInput samplingRate.
			phonemeDisplay contents: p name]].

! !

!PhonemeRecognizerMorph methodsFor: 'stepping' stamp: 'jm 5/23/2000 05:48'!
stepTime

	^ 30
! !

!PhonemeRecognizerMorph methodsFor: 'stepping' stamp: 'jm 5/10/2000 16:04'!
stopStepping
	"Turn off recording."

	super stopStepping.
	soundInput stopRecording.
! !


!PhonemeRecognizerMorph methodsFor: 'analysis' stamp: 'jm 5/22/2000 23:15'!
findMatchFor: aSoundBuffer samplingRate: samplingRate
	"Find the phoneme whose features most closesly match those of the given sound buffer."

	| unknown bestMatch bestDistance d |
	unknown _ PhonemeRecord new
		samples: aSoundBuffer samplingRate: samplingRate.
	unknown peakLevel > 1500
		ifTrue: [
			unknown computeFeatures.
			bestMatch _ nil.
			bestDistance _ SmallInteger maxVal.
			phonemeRecords do: [:p |
				d _ p featureDistanceFrom: unknown features to: p features.
				d < bestDistance ifTrue: [
					bestMatch _ p.
					bestDistance _ d]]]
		ifFalse: [bestMatch _ silentPhoneme].
	currentPhoneme _ bestMatch.
	^ currentPhoneme
! !


!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/22/2000 17:45'!
addButtonRows
	"Create and add my button row."

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: ((self buttonName: 'Menu' action: #invokeMenu)
		actWhen: #buttonDown).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Add' action: #addPhoneme).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Run' action: #startRecognizing).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' action: #stopRecognizing).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'ar 11/9/2000 21:20'!
addLevelSlider
	"Create and add a slider to set the sound input level. This level is used both when recognizing and adding phonemes."

	| levelSlider r |
	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: soundInput;
		actionSelector: #recordLevel:;
		adjustToValue: soundInput recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'ar 11/9/2000 21:20'!
addPhonemeDisplay
	"Add a display to show the currently matching phoneme."

	| font r |
	font _ StrikeFont familyName: 'Helvetica' size: 36.
	phonemeDisplay _ StringMorph contents: '...' font: font.
	r _ AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #rigid;
		height: 20.
	r addMorphBack: phonemeDisplay.
	self addMorphBack: (Morph new extent: 5@8; color: Color transparent).  "spacer"
	self addMorphBack: r.
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'ar 11/9/2000 21:20'!
addTitle
	"Add a title."

	| font title r |
	font _ StrikeFont familyName: 'ComicBold' size: 20.
	title _ StringMorph contents: 'Phoneme Recognizer' font: font.
	r _ AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #rigid;
		height: 20.
	r addMorphBack: title.
	self addMorphBack: r.
	self addMorphBack: (Morph new extent: 5@8; color: Color transparent).  "spacer"
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/22/2000 17:48'!
buttonName: aString action: aSymbol
	"Create a button of the given name to send myself the given unary message."

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/22/2000 17:50'!
makeLevelMeter
	"Create a recording level meter."

	| outerBox |
	outerBox _ RectangleMorph new extent: 125@14; color: Color lightGray.
	levelMeter _ Morph new extent: 2@10; color: Color yellow.
	levelMeter position: outerBox topLeft + (2@2).
	outerBox addMorph: levelMeter.
	^ outerBox

! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/22/2000 17:50'!
makeStatusLight
	"Create a status light to show when the recognizer is running."

	| s |
	statusLight _ RectangleMorph new extent: 24@19.
	statusLight color: Color gray.
	s _ StringMorph contents: 'On'.
	s position: statusLight center - (s extent // 2).
	statusLight addMorph: s.
	^ statusLight
! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/18/2000 19:36'!
promptForDetailsOfPhoneme: phoneme
	"Prompt the user for the name and mouth position of the given phoneme."

	| response |
	response _ FillInTheBlank
		request: 'Phoneme name?'
		initialAnswer: phoneme name.
	response ifNotNil: [phoneme name: response].

	response _ FillInTheBlank
		request: 'Mouth Position Index?'
		initialAnswer: phoneme mouthPosition printString.
	response ifNotNil: [phoneme mouthPosition: response asNumber asInteger].

! !

!PhonemeRecognizerMorph methodsFor: 'private' stamp: 'jm 5/18/2000 20:31'!
selectPhonemeFromMenu
	"Answer the phone selected by the user from a menu of the current phoneme records. Answer nil if the user does not select any phoneme."

	| aMenu |
	phonemeRecords isEmpty ifTrue: [self inform: 'The phoneme database is empty.'. ^ nil].
	aMenu _ CustomMenu new title: 'Phoneme to delete?'.
	phonemeRecords do: [:phoneme |
		aMenu add: phoneme name action: phoneme].
	^ aMenu startUp
! !
Object subclass: #PhonemeRecord
	instanceVariableNames: 'name mouthPosition samples samplingRate features '
	classVariableNames: 'AverageFeatures CutoffFreq FFTSize FilterBandwidth HighFreqWeight '
	poolDictionaries: ''
	category: 'Speech-Phoneme Recognizer'!
!PhonemeRecord commentStamp: '<historical>' prior: 0!
I represent a single phoneme. I contain the phoneme's name and an integer that represents the mouth position associated with this phoneme. This integer can be used as an index to select the mouth shape for an animated character. I also contain a 'features vector' derived from an analysis of my sound; this 'features vector' is the basis of matching during phoneme recognition. I also retain the original sound from which the features were computed so that it can be re-analyzed to create a new feature vector when the analysis algorithm is changed.
!


!PhonemeRecord methodsFor: 'initialization' stamp: 'jm 5/19/2000 23:13'!
initialize

	name _ ''.
	mouthPosition _ 1.
	samples _ SoundBuffer new.
	samplingRate _ 22050.
	features _ nil.
! !


!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/23/2000 06:13'!
features
	"Answer the features vector for this phoneme, an array of numbers used in the phoneme matching process. Compute the features if necessary."

	features ifNil: [
		AverageFeatures
			ifTrue: [features _ self averageFeatures]
			ifFalse: [features _ self featuresAtCenter]].
	^ features
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/23/2000 05:37'!
features: anObject

	features _ anObject.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/19/2000 23:11'!
mouthPosition
	"Answer the mouth position associated with this phoneme, a positive integer that can be used to index into a collection of frames for an animation."

	^ mouthPosition! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:51'!
mouthPosition: anInteger

	mouthPosition _ anInteger.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:55'!
name
	"Answer the name the user gave this phoneme."

	^ name! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 16:42'!
name: anObject

	name _ anObject.! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:53'!
samples
	"Answer the SoundBuffer containing my sampled sound data."

	^ samples
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/19/2000 23:12'!
samples: aSoundBuffer samplingRate: aNumber
	"Set my samples and sampling rate, and clear my cached features vector."

	samples _ aSoundBuffer.
	samplingRate _ aNumber.
	self clearFeatures.
! !

!PhonemeRecord methodsFor: 'access' stamp: 'jm 5/17/2000 17:55'!
samplingRate
	"Answer the sampling rate used to record my samples."

	^ samplingRate
! !


!PhonemeRecord methodsFor: 'other' stamp: 'jm 5/23/2000 05:39'!
featuresGraph
	"Answer a Form containing a pictorial view of my features vector."

	| labelForm graphHeight barWidth bottom f min max scale x h |
	labelForm _ name asParagraph asForm.
	graphHeight _ 100.
	barWidth _ 5.
	bottom _ graphHeight + 2.  "2 pixel border"
	f _ Form
		extent: (self features size * barWidth) @ (graphHeight + labelForm height + 5)
		depth: 16.
	f fillWhite: f boundingBox.
	f border: f boundingBox width: 2.

	min _ 1.0e30.
	max _ -1.0e30.
	features do: [:v |
		v < min ifTrue: [min _ v].
		v > max ifTrue: [max _ v]].
	scale _ (graphHeight - 1) asFloat / (max - min).
	x _ 2.
	self features do: [:v |
		h _ (scale * (v - min)) asInteger.
		f fill: ((x@(bottom - h)) extent: barWidth@h) fillColor: (Color r: 0.581 g: 0.581 b: 0.0).
		x _ x + barWidth].
	f fillBlack: ((0@bottom) extent: (f width@1)).
	labelForm displayOn: f
		at: ((f width - labelForm width) // 2)@bottom
		rule: Form paint.
	^ f
! !

!PhonemeRecord methodsFor: 'other' stamp: 'jm 5/17/2000 17:58'!
play
	"Playback my samples."

	(SampledSound samples: samples samplingRate: samplingRate) play.
! !

!PhonemeRecord methodsFor: 'other' stamp: 'jm 5/23/2000 06:05'!
recordWithLevel: recordLevel
	"Initialize my sound samples by recording a snippet of sound while the mouse is held down. Trim off leading and trailing silence, and normalize the level of the recording."

	| recorder |
	"record the sound"
	recorder _ SoundRecorder new
		samplingRate: samplingRate;
		recordLevel: recordLevel;
		clearRecordedSound.
	Utilities
		informUser: 'Recording a phoneme. Release the mouse button when done.'
		during: [
			recorder resumeRecording.
			Sensor waitNoButton.
			recorder stopRecording].
	Utilities
		informUser: 'Removing leading/trailing silence...'
		during: [
			samples _ recorder condensedSamples.
			samples size > 0 ifTrue: [
				samples _ self trimAndNormalize: samples]].

	self clearFeatures.
! !

!PhonemeRecord methodsFor: 'other' stamp: 'jm 5/17/2000 20:42'!
trimAndNormalize: aSoundBuffer
	"Trim leading and trailing silence and normalize the sound level of the given samples."

	| lastSampleIndex maxLevel v threshold startI endI adjust count result |
	"skip the sound of the terminating mouse click..."
	lastSampleIndex _ (aSoundBuffer monoSampleCount - (samplingRate // 10)) max: 1.

	"find maximum level"
	maxLevel _ 0.

	1 to: lastSampleIndex do: [:i |
		v _ aSoundBuffer at: i.
		v < 0 ifTrue: [v _ 0 - v].
		v > maxLevel ifTrue: [maxLevel _ v]].

	"find indices of start and end"
	threshold _ (0.1 * maxLevel) asInteger.
	startI _ 1.
	[(aSoundBuffer at: startI) < threshold]
		whileTrue: [startI _ startI + 1].  "scan for starting point"
	endI _ lastSampleIndex.
	[(aSoundBuffer at: endI) < threshold]
		whileTrue: [endI _ endI - 1].  "scan for ending point"

	"extend range by a twentieth of a second on both ends"
	startI _ (startI - (samplingRate // 20)) max: 1.
	endI _ (endI + (samplingRate // 20)) min: aSoundBuffer monoSampleCount.

	adjust _ (10000 * (30000 / maxLevel)) asInteger.  "fixed point constant for speed"
	count _ (endI - startI) + 1.
	result _ SoundBuffer newMonoSampleCount: (endI - startI) + 1.
	1 to: count do: [:i |
		v _ (adjust * (aSoundBuffer at: (startI + i - 1))) // 10000.
		result at: i put: v].

	^ result
! !


!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/17/2000 19:50'!
averageFeatures
	"Compute the average features vector across my sound samples."

	| startI endI featureVectors |
	"skip the first and last bits"
	startI _ (samplingRate // 5).
	endI _ samples monoSampleCount - (samplingRate // 5).
	endI - startI < FFTSize ifTrue: [^ self extractFeaturesAt: endI].

	featureVectors _ (startI to: endI by: FFTSize)
		collect: [:i | (self extractFeaturesAt: i)].
	^ self prunedAverageFeatures: featureVectors
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/17/2000 20:02'!
clearFeatures
	"Clear my features vector cache. This must be done when new sample data is recorded or when the analysis algorithm is changed."

	features _ nil.
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 22:21'!
computeFeatures
	"Compute and record a features vector take from the start of my samples. This method is typically used to analyze a single buffer during recognition."

	self features: (self extractFeaturesAt: 1).
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/21/2000 09:28'!
distanceToPhoneme: otherPhoneme
	"Answer the distance in feature space between this phoneme and the given phoneme."

	^ self featureDistanceFrom: self features to: otherPhoneme features
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 22:46'!
extractFeaturesAt: startIndex
	"Extract a features vector from the given point in my samples."

	| spectrum cutoffIndex binSize s i avg unscaledFeatures total |
	spectrum _ (FFT new: FFTSize)
		transformDataFrom: samples
		startingAt: (startIndex min: (samples monoSampleCount - FFTSize + 1)).

	cutoffIndex _ ((CutoffFreq * spectrum size) / (samplingRate / 2)) rounded.
	binSize _ ((FilterBandwidth * spectrum size) / (samplingRate / 2)) rounded.

	s _ WriteStream on: (Array new: 50).
	i _ 2. "skip first bin of FFT data, which just contains the D.C. component"
	[i < cutoffIndex] whileTrue: [
		avg _ (spectrum copyFrom: i to: i + binSize - 1) sum / binSize.
		s nextPut: avg.
		i _ i + binSize].

	"final entry of feature vector sums all energy above the cutoff frequency"
	s nextPut: HighFreqWeight *
		((spectrum copyFrom: i to: spectrum size) sum / (spectrum size + 1 - i)).

	unscaledFeatures _ s contents.
	total _ unscaledFeatures sum.
	^ unscaledFeatures collect: [:n | (1000.0 * n) // total].
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 23:01'!
featureDistanceFrom: featuresVec1 to: featuresVec2
	"Answer the distance between the given two feature vectors. The lower this value, the closer the phonemes match."

	| sumOfSquares |
	sumOfSquares _ 0.
	1 to: featuresVec1 size do: [:i |
		 sumOfSquares _ sumOfSquares +
			((featuresVec1 at: i) - (featuresVec2 at: i)) squared].
	^ sumOfSquares sqrt
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/17/2000 19:54'!
featuresAtCenter
	"Answer the features vector computed from a single FFT window taken from the center of my samples."

	^ self extractFeaturesAt: (samples monoSampleCount // 2)
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 22:33'!
peakLevel
	"Answer the absolute value of the peak sample value my buffer."

	| maxVal v |
	maxVal _ 0.
	1 to: samples size do: [:i |
		v _ samples at: i.
		v < 0 ifTrue: [v _ 0 - v].
		v > maxVal ifTrue: [maxVal _ v]].
	^ maxVal
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/21/2000 09:28'!
phonemeDistanceTo: otherPhoneme
	"Answer the distance in feature space between this phoneme and the given phoneme."

	^ self featureDistanceFrom: self features to: otherPhoneme features
! !

!PhonemeRecord methodsFor: 'feature analysis' stamp: 'jm 5/18/2000 23:04'!
prunedAverageFeatures: featureVectors
	"Compute the average of the given collection of feature vectors, then discard the outliers and average the remainding feature vectors. The result is an average of the most typical feature vectors in the given collection."

	| centroid sum vectorsWithErrors filtered |
	"compute the average of all the feature vectors"
	centroid _ (1 to: featureVectors first size) collect: [:i |
		sum _ 0.
		1 to: featureVectors size do: [:j | sum _ sum + ((featureVectors at: j) at: i)].
		(sum asFloat / featureVectors size) rounded].

	"sort vectors by their distance from the centroid"
	vectorsWithErrors _ SortedCollection sortBlock: [:e1 :e2 | e1 last < e2 last].
	featureVectors do: [:v |
		vectorsWithErrors add: (Array with: v with: (self featureDistanceFrom: v to: centroid))].

	"reject outlying feature vectors"
	filtered _ (1 to: (0.8 * vectorsWithErrors size) rounded)
		collect: [:i | (vectorsWithErrors at: i) first].

	"answer the average of the remaining feature vectors"
	^ (1 to: filtered first size) collect: [:i |
		sum _ 0.
		1 to: filtered size do: [:j | sum _ sum + ((filtered at: j) at: i)].
		(sum asFloat / filtered size) rounded].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhonemeRecord class
	instanceVariableNames: ''!

!PhonemeRecord class methodsFor: 'class initialization' stamp: 'jm 5/22/2000 17:36'!
fftSize
	"Answer the FFT size for frequency analysis. It must be a power of two."

	^ FFTSize
! !

!PhonemeRecord class methodsFor: 'class initialization' stamp: 'jm 5/23/2000 06:15'!
initialize
	"Initialize the parameter used to extract phoneme features. After changing these parameters, execute 'PhonemeRecord initialize'. The features vectors of any existing phoneme records will be cleared and recomputed as needed."
	"PhonemeRecord initialize"

	FFTSize _ 512.			"size of FFT for analysis; this must be a power of two"
	CutoffFreq _ 4000.		"boundary between fine and coarse ranges"
	FilterBandwidth _ 160.	"bandwidth of each frequency band in the fine range"
	HighFreqWeight _ 5.		"weighting of energy above the cutoff frequency"
	AverageFeatures _ false.
		"If AverageFeatures is true, then average features over the phoneme recording. Otherwise, extract features from the center of the recording."

	"clear all cached feature vectors"
	PhonemeRecord allInstancesDo: [:p | p clearFeatures].
! !
Object subclass: #PhonemeSet
	instanceVariableNames: 'name description phonemes specials '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhonemeSet commentStamp: '<historical>' prior: 0!
My instances are phoneme sets, i.e. phonetic alphabets.
There are several "standard" phoneme sets used among phoneticians. We choosed ARPABET to be the default phoneme set in this system, but other examples are implemented, such as DARPA (radio), MRPA and SAMPA. As well, mappings from those phoneme sets to ARPABET are provided.!


!PhonemeSet methodsFor: 'initialization' stamp: 'len 6/2/1999 02:46'!
initialize
	phonemes _ Dictionary new.
	specials _ Dictionary new! !


!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 01:00'!
add: aPhoneme
	^ phonemes at: aPhoneme name put: aPhoneme! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 03:45'!
at: aString
	^ phonemes at: aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 03:45'!
at: aString ifAbsent: aBlock
	^ phonemes at: aString ifAbsent: aBlock! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
description
	^ description! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
description: aString
	description _ aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
name
	^ name! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/22/1998 00:53'!
name: aString
	name _ aString! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/8/1999 00:55'!
names
	"Answer the names of all the phonemes."
	^ phonemes keys! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/5/1999 01:43'!
pause
	^ self silence! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 5/31/1999 01:00'!
phonemes
	^ phonemes values! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/5/1999 01:43'!
silence
	^ self specials at: #silence! !

!PhonemeSet methodsFor: 'accessing' stamp: 'len 6/2/1999 02:46'!
specials
	^ specials! !


!PhonemeSet methodsFor: 'copying' stamp: 'len 5/31/1999 01:35'!
copy
	^ self class new addAll: self phonemes; yourself! !


!PhonemeSet methodsFor: 'enumerating' stamp: 'len 8/22/1999 18:27'!
do: aBlock
	phonemes do: aBlock! !


!PhonemeSet methodsFor: 'transcribing' stamp: 'len 5/31/1999 03:26'!
transcriptionOf: aString
	^ (aString findTokens: '/ ')
		collect: [ :each |
			each last isDigit
				ifTrue: [(self at: (each copyFrom: 1 to: each size - 1))
							stressed: each last asString asNumber]
				ifFalse: [self at: each]]! !


!PhonemeSet methodsFor: 'printing' stamp: 'len 5/28/1999 02:55'!
printOn: aStream
	name isNil ifTrue: [^ super printOn: aStream].
	aStream nextPutAll: name, ' phoneme set'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhonemeSet class
	instanceVariableNames: 'arpabet '!

!PhonemeSet class methodsFor: 'instance creation' stamp: 'len 6/22/1998 00:55'!
new
	^ super new initialize! !


!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:12'!
arpabet
	"Answer the ARPAbet phoneme set."
	^ arpabet! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 12/24/1999 02:44'!
arpabetToSampa
	"Answer a dictionary with ARPAbet phonemes
	as keys and SAMPA phoneme names as values."

	| answer |
	answer _ Dictionary new.
	self sampaToArpabet associationsDo: [ :each | answer at: each value put: each key].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:12'!
darpa
	"Answer the DARPA phoneme set."
	^ self radio! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 12/20/1999 04:34'!
dectalkToArpabet
	"Answer a dictionary with DECTalk phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer _ Dictionary new.
	self arpabet do: [ :each | answer at: each name put: each].
	#(
		('nx'	'ng')
		('yx'	'jh')
		('lx'		'l')
		('rr'	'r')
		('u'		'uw')
		('hx'	'hh')
		('h'		'hh')
		('_'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 5/31/1999 00:25'!
default
	^ self arpabet! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 9/29/1999 02:27'!
mactalkToArpabet
	"Answer a dictionary with MacTalk phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer _ Dictionary new.
	#(	
		('IY'	'iy')
		('IH'	'ih')
		('EY'	'ey')
		('EH'	'eh')
		('AE'	'ae')
		('AA'	'aa')
		('AO'	'ao')
		('OW'	'ow')
		('UH'	'uh')
		('UW'	'uw')
"		(''	'er')"
		('AX'	'ax')
		('AH'	'ah')
		('AY'	'ay')
		('AW'	'aw')
		('OY'	'oy')
"		(''	'ix')"
		('p'		'p')
		('b'		'b')
		('t'		't')
		('d'		'd')
		('k'		'k')
		('g'		'g')
		('f'		'f')
		('v'		'v')
		('T'		'th')
		('D'		'dh')
		('s'		's')
		('z'		'z')
		('S'		'sh')
		('Z'		'zh')
		('h'		'hh')
		('m'		'm')
		('n'		'n')
		('N'		'ng')
		('l'		'l')
		('w'		'w')
		('y'		'y')
		('r'		'r')
		('C'		'ch')
		('J'		'jh')
		('UX'	'ax')
		('_'		'sil')
		('~'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:11'!
mrpa
	"Answer the MRPA phoneme set."
	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/21/1999 20:46'!
mrpaToArpabet
	"Answer a dictionary with MRPA phoneme names
	as keys and ARPAbet Phonemes as values."

	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/8/1999 01:55'!
radio
	"Answer the radio phoneme set, named after the BU RADIO FM corpus."
	self notYetImplemented! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/10/1999 04:11'!
sampa
	"Answer the sampa phoneme set."
	| answer mapping |
	mapping _ self sampaToArpabet.
	answer _ self new.
	mapping keysDo: [ :each | answer add: ((self arpabet at: (mapping at: each)) copy name: each)].
	^ answer! !

!PhonemeSet class methodsFor: 'examples' stamp: 'len 6/12/1999 04:00'!
sampaToArpabet
	"Answer a dictionary with SAMPA phoneme names
	as keys and ARPAbet phonemes as values."

	| answer |
	answer _ Dictionary new.
	#(	('p'		'p')
		('b'		'b')
		('t'		't')
		('d'		'd')
		('k'		'k')
		('m'		'm')
		('n'		'n')
		('l'		'l')
		('r'		'r')
		('f'		'f')
		('v'		'v')
		('s'		's')
		('z'		'z')
		('h'		'hh')
		('w'		'w')
		('g'		'g')
		('tS'		'ch')
		('dZ'	'jh')
		('N'		'ng')
		('T'		'th')
		('D'		'dh')
		('S'		'sh')
		('Z'		'zh')
		('j'		'y')
		('i:'		'iy')
		('i'		'iy')
		('A:'	'aa')
		('A'		'aa')
		('O:'	'ao')
		('O'		'ao')
		('u:'	'uw')
		('u'		'uw')
		('3:'		'er')
		('r='	'er')
		('I'		'ih')
		('e'		'eh')
		('E'		'eh')
		('{'		'ae')
		('V'		'ah')
		"	('Q'		'oh')"
		('U'		'uh')
		('@'		'ax')
		('eI'		'ey')
		('aI'	'ay')
		('OI'	'oy')
		('@U'	'ow')
		('aU'	'aw')
		('I@'	'ia')
		('e@'	'ea')
		('U@'	'ua')
		('AI'	'ay')
		('EI'		'ey')
		('4'		't')
		('_'		'sil')) do: [ :each | answer at: each first put: (self arpabet at: each last)].
	^ answer! !


!PhonemeSet class methodsFor: 'class initialization' stamp: 'len 12/20/1999 04:30'!
initialize
	"
	PhonemeSet initialize
	"
	arpabet _ self new name: 'ARPAbet'; description: 'This is the ARPAbet phonetic alphabet.'.
	#("Name"	"Example"	"Features"
		('iy'	'heed'		#(continuant vowel front))
		('ih'	'hid'		#(continuant vowel front))
		('ey'	'hayed'		#(continuant vowel front))
		('eh'	'head'		#(continuant vowel front))
		('ae'	'had'		#(continuant vowel front))
		('aa'	'hod'		#(continuant vowel back))
		('ao'	'hawed'		#(continuant vowel back))
		('ow'	'hoed'		#(continuant vowel back))
		('uh'	'hood'		#(continuant vowel back))
		('uw'	'who''d'		#(continuant vowel back))
		('er'	'heard'		#(continuant vowel mid))
		('ax'	'ago'		#(continuant vowel mid))
		('ah'	'mud'		#(continuant vowel mid))
		('ay'	'hide'		#(diphthong))
		('aw'	'how''d'		#(diphthong))
		('oy'	'boy'		#(diphthong))
		('ix'		'roses'		#())
		('p'		'pea'		#(consonant stop unvoiced))
		('b'		'bat'		#(consonant stop voiced))
		('t'		'tea'		#(consonant stop unvoiced))
		('d'		'deep'		#(consonant stop voiced))
		('k'		'kick'		#(consonant stop unvoiced))
		('g'		'go'			#(consonant stop voiced))
		('f'		'five'		#(continuant consonant fricative unvoiced))
		('v'		'vice'		#(continuant consonant fricative voiced))
		('th'	'thing'		#(continuant consonant fricative unvoiced))
		('dh'	'then'		#(continuant consonant fricative voiced))
		('s'		'so'			#(continuant consonant fricative unvoiced))
		('z'		'zebra'		#(continuant consonant fricative voiced))
		('sh'	'show'		#(continuant consonant fricative unvoiced))
		('zh'	'measure'	#(continuant consonant fricative voiced))
		('hh'	'help'		#(continuant consonant whisper))
		('m'		'mom'		#(continuant consonant nasal))
		('n'		'noon'		#(continuant consonant nasal))
		('ng'	'sing'		#(continuant consonant nasal))		"old name: nx"
		('l'		'love'		#(semivowel liquid))
		('el'		'cattle')
		('em'	'some')
		('en'	'son')
		('dx'	'batter')
		('q'		'[glottal stop]')
		('w'		'want'		#(continuant semivowel glide))
		('y'		'yard'		#(continuant semivowel glide))
		('r'		'race'		#(continuant semivowel liquid))
		('ch'	'church'	#(continuant consonant affricate))
		('jh'	'just'		#(continuant consonant affricate))
		('wh'	'when'		#(semivowel liquid))
	"not found in the original:"
		('sil'	'[silence]'	#(silence))
		('ll'		'')	"dark l"
		('ai'	''			#(vowel))	"what is this?"
		('ia'	''			#(vowel))
		('ea'	''			#(vowel))
		('ua'	''			#(vowel))
		('aor'	'')
		('rx'	''			#())
	) do: [ :each |
		arpabet add: (each size > 2
						ifTrue: [Phoneme name: each first example: each second features: each last]
						ifFalse: [Phoneme name: each first example: each last])].
	arpabet specials at: #silence put: (arpabet at: 'sil')! !
VoiceEvent subclass: #PhoneticEvent
	instanceVariableNames: 'phoneme pitchPoints duration loudness '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!
!PhoneticEvent commentStamp: '<historical>' prior: 0!
My instances are events for a Voice.!


!PhoneticEvent methodsFor: 'accessing-private' stamp: 'len 9/27/1999 23:06'!
pitchPoints
	^ pitchPoints! !

!PhoneticEvent methodsFor: 'accessing-private' stamp: 'len 9/27/1999 23:06'!
pitchPoints: p
	pitchPoints _ p isNumber
		ifTrue: [((0.0 to: duration by: 0.035) collect: [ :time | time @ p])]
		ifFalse: [p first isPoint ifTrue: [p] ifFalse: [(p collect: [ :each | each first @ each last])]]! !


!PhoneticEvent methodsFor: 'accessing' stamp: 'len 9/27/1999 23:06'!
averagePitch
	| sum previous |
	self pitchPoints size = 1 ifTrue: [^ self pitchPoints first y].
	sum _ 0.0.
	self pitchPoints do: [ :each |
		previous isNil ifFalse: [sum _ (each y + previous y) / 2.0 * (each x - previous x) + sum].
		previous _ each].
	sum _ previous y * (self duration - previous x) + sum.
	^ sum / self duration! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 23:18'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ duration! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 11/30/1999 04:26'!
duration: aNumber
	"Set the duration of the receiver (in seconds)."
	((pitchPoints isNil or: [duration isNil]) or: [duration = 0])
		ifFalse: [pitchPoints _ pitchPoints collect: [ :each | each x / duration * aNumber @ each y]].
	duration _ aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:36'!
loudness
	^ loudness! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:37'!
loudness: aNumber
	loudness _ aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:36'!
phoneme
	^ phoneme! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 5/28/1999 01:35'!
phoneme: aPhoneme
	phoneme _ aPhoneme! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 9/27/1999 23:03'!
pitch: aNumber
	self pitchPoints: aNumber! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 9/27/1999 23:04'!
pitchAt: time
	"Answer the pitch of the receiver at a given time. (Do linear interpolation.)"
	| xVal count x1 x2 y1 y2 |
	pitchPoints isNil ifTrue: [^ nil].
	xVal _ pitchPoints first x.
	count _ 1.
	[xVal < time]
		whileTrue: [count _ count + 1.
					count > pitchPoints size ifTrue: [^ pitchPoints last y].
					xVal _ (pitchPoints at: count) x].
	xVal = time ifTrue: [^ (pitchPoints at: count) y].
	count = 1 ifTrue: [^ pitchPoints first y].
	x1 _ (pitchPoints at: count - 1) x.
	x2 _ (pitchPoints at: count) x.
	y1 _ (pitchPoints at: count - 1) y.
	y2 _ (pitchPoints at: count) y.
	^ (time - x1) / (x2 - x1) * (y2 - y1) + y1! !

!PhoneticEvent methodsFor: 'accessing' stamp: 'len 9/27/1999 23:07'!
pitchAt: time put: aNumber
	"Set the pitch of the receiver at a given time."
	pitchPoints isNil ifTrue: [pitchPoints _ Array with: time @ aNumber. ^ self].
	pitchPoints _ pitchPoints copyWith: time @ aNumber! !


!PhoneticEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:54'!
playOn: aVoice at: time
	aVoice playPhoneticEvent: self at: time! !


!PhoneticEvent methodsFor: 'converting' stamp: 'len 12/24/1999 02:45'!
asPHOString
	| stream |
	stream _ WriteStream on: String new.
	stream
		nextPutAll: (PhonemeSet arpabetToSampa at: self phoneme); space;
		print: (self duration * 1000) rounded.
	self pitchPoints do: [ :each | stream space; print: (each x * 1000) rounded; space; print: each y rounded].
	^ stream contents! !


!PhoneticEvent methodsFor: 'copying' stamp: 'len 9/27/1999 23:01'!
copy
	^ super copy pitchPoints: self pitchPoints copy! !


!PhoneticEvent methodsFor: 'testing' stamp: 'len 9/27/1999 23:04'!
hasPitch
	"Answer true if there is a pitch contour specified for the receiver."
	^ pitchPoints notNil! !

!PhoneticEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isPhonetic
	^ true! !


!PhoneticEvent methodsFor: 'transforming' stamp: 'len 9/27/1999 23:05'!
pitchApply: aBlock
	"Apply aBlock to the pitch points in the receiver."
	self hasPitch ifFalse: [^ self].
	pitchPoints _ pitchPoints collect: aBlock! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'len 9/27/1999 23:06'!
pitchBy: aNumber
	"Multiply the receiver's pitch contour by aNumber."
	self hasPitch ifFalse: [^ self].
	pitchPoints _ pitchPoints collect: [ :each | each x @ (each y * aNumber)]! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'len 6/5/1999 03:26'!
stretch: aNumber
	self duration: self duration * aNumber! !

!PhoneticEvent methodsFor: 'transforming' stamp: 'len 9/27/1999 23:05'!
transposeBy: aNumber
	"Add the given step to the receiver's pitch."
	pitchPoints _ pitchPoints collect: [ :each | each x @ (each y + aNumber)]! !


!PhoneticEvent methodsFor: 'printing' stamp: 'len 9/27/1999 23:06'!
printOn: aStream
	| first |
	aStream nextPutAll: '#('; print: phoneme; space; print: loudness; space; print: duration.
	self pitchPoints isNil ifTrue: [aStream nextPut: $). ^ self].
	aStream nextPutAll: ' #('.
	first _ true.
	self pitchPoints do: [ :each |
		first ifFalse: [aStream space].
		aStream print: each x; space; print: each y.
		first _ false].
	aStream nextPutAll: '))'! !
Object subclass: #PhoneticRule
	instanceVariableNames: 'left text right phonemes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhoneticRule commentStamp: '<historical>' prior: 0!
My instances are letter-to-sound rules for perform automatic text-to-phonemes transcription. (See the PhoneticTranscriber class comment too.)

Rules are made up of four parts: (1) left context pattern, (2) the text to match, (3) the right context pattern, and (4) the phonemes to substitute for the matched text.

The transcription procedure begins separating each block of letters (apostrophes included) and adding a space on each side. For each unmatched letter in the word, look through the rules where the text to match starts with the letter in the word. If the text to match if found and the right and left contexts patterns also match, output the phonemes for that rule and skip to the next unmatched letter.

Context patterns special characters:
	#	One or more vowels
	:	Zero or more consonants
	^	One consonant
	.	One of B, D, V, G, J, L, M, N, R, W, or Z (voiced consonants)
	%	One of ER, E, ES, ED, ING, ELY (a suffix)	[ONLY FOR RIGHT CONTEXT]
	+	One of E, I or Y (a "front" vowel)
Furthermore, the space character means any separator (space, comma, colon, etc), and any other character means that character it self.

The english example is derived from: "Automatic Translation of English Text to Phonetics by Means of Letter-To-Sound Rules", NRL Report 7948, January 21st, 1976, Naval Research Laboratory, Washington, D.C. Published by the National Technical Information Service as document "AD/A021 929".
!


!PhoneticRule methodsFor: 'accessing' stamp: 'len 5/29/1999 03:59'!
left
	^ left! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/9/98 23:46'!
left: aString
	left _ aString! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/10/98 05:01'!
phonemes
	^ phonemes! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/9/98 23:47'!
phonemes: aCollection
	phonemes _ aCollection! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 5/29/1999 03:59'!
right
	^ right! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/9/98 23:46'!
right: aString
	right _ aString! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/10/98 05:00'!
text
	^ text! !

!PhoneticRule methodsFor: 'accessing' stamp: 'len 4/9/98 23:46'!
text: aString
	text _ aString! !


!PhoneticRule methodsFor: 'testing' stamp: 'len 6/8/1999 00:14'!
matches: aString at: anInteger
	^ (self textMatches: aString at: anInteger)
		and: [(self leftMatches: aString at: anInteger)
			and: [self rightMatches: aString at: anInteger]]! !


!PhoneticRule methodsFor: 'private' stamp: 'len 11/3/1998 06:04'!
leftMatches: aString at: anInteger
	| leftindex textindex pattern |
	left isEmpty ifTrue: [^ true].
	leftindex _ left size.
	textindex _ anInteger - 1.
	[leftindex >= 1 and: [textindex >= 1]] whileTrue: [
		pattern _ left at: leftindex.
		"first check for simple text or apostrophe:"
		(pattern isAlphaNumeric or: [pattern = $'])
			ifTrue: [(aString at: textindex) asLowercase ~= pattern asLowercase
						ifTrue: [^ false].
					textindex _ textindex - 1].
		"space:"
		pattern = Character space
			ifTrue: [((aString at: textindex) isSeparator
						or: ['.,;:' includes: (aString at: textindex)]) ifFalse: [^ false].
					textindex _ textindex - 1].
		"one or more vowels:"
		pattern = $#
			ifTrue: [(aString at: textindex) isVowel ifFalse: [^ false].
					textindex _ textindex - 1.
					[textindex >= 1 and: [(aString at: textindex) isVowel]]
						whileTrue: [textindex _ textindex - 1]].
		"zero or more consonants:"
		pattern = $:
			ifTrue: [[textindex >= 1
						and: ['bcdfghjklmnpqrstvwxyz'
								includes: (aString at: textindex) asLowercase]]
							whileTrue: [textindex _ textindex - 1]].
		"one consonant:"
		pattern = $^
			ifTrue: [('bcdfghjklmnpqrstvwxyz' includes: (aString at: textindex))
						ifFalse: [^ false].
					textindex _ textindex - 1].
		"b, d, v, g, j, l, m, n, r, w, z (voiced consonants):"
		pattern = $.
			ifTrue: [('bdvgjlmnrwz' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex _ textindex - 1].
		"e, i or y (front vowels)"
		pattern = $+
			ifTrue: [('eiy' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex _ textindex - 1].
		leftindex _ leftindex - 1].
	^ true! !

!PhoneticRule methodsFor: 'private' stamp: 'len 11/3/1998 06:04'!
rightMatches: aString at: anInteger
	| rightindex textindex pattern |
	right isEmpty ifTrue: [^ true].
	rightindex _ 1.
	textindex _ anInteger + text size.
	[rightindex <= right size and: [textindex <= aString size]] whileTrue: [
		pattern _ right at: rightindex.
		"first check for simple text or apostrophe:"
		(pattern isAlphaNumeric or: [pattern = $'])
			ifTrue: [(aString at: textindex) asLowercase ~= pattern asLowercase
						ifTrue: [^ false].
					textindex _ textindex + 1].
		"space:"
		pattern = Character space
			ifTrue: [((aString at: textindex) isSeparator
						or: ['.,;:' includes: (aString at: textindex)]) ifFalse: [^ false].
					textindex _ textindex + 1].
		"one or more vowels:"
		pattern = $#
			ifTrue: [(aString at: textindex) isVowel ifFalse: [^ false].
					textindex _ textindex + 1.
					[textindex <= aString size and: [(aString at: textindex) isVowel]]
						whileTrue: [textindex _ textindex + 1]].
		"zero or more consonants:"
		pattern = $:
			ifTrue: [[textindex <= aString size
						and: ['bcdfghjklmnpqrstvwxyz'
								includes: (aString at: textindex) asLowercase]]
							whileTrue: [textindex _ textindex + 1]].
		"one consonant:"
		pattern = $^
			ifTrue: [('bcdfghjklmnpqrstvwxyz' includes: (aString at: textindex))
						ifFalse: [^ false].
					textindex _ textindex + 1].
		"b, d, v, g, j, l, m, n, r, w, z (voiced consonants):"
		pattern = $.
			ifTrue: [('bdvgjlmnrwz' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex _ textindex + 1].
		"e, i or y (front vowels):"
		pattern = $+
			ifTrue: [('eiy' includes: (aString at: textindex) asLowercase)
						ifFalse: [^ false].
					textindex _ textindex + 1].
		"er, e, es, ed, ing, ely (a suffix):"
		pattern = $%
			ifTrue: [(aString at: textindex) asLowercase = $e
						ifTrue: [textindex _ textindex + 1.
								(textindex < aString size and: [(aString at: textindex) asLowercase = $l])
									ifTrue: [textindex _ textindex + 1.
											(textindex < aString size and: [(aString at: textindex) asLowercase = $y])
												ifTrue: [textindex _ textindex + 1]
												ifFalse: [textindex _ textindex - 1]]
									ifFalse: [('rsd' includes: (aString at: textindex) asLowercase)
												ifTrue: [textindex _ textindex + 1]]]
						ifFalse: [(textindex + 2 <= aString size
									and: [(aString at: textindex) asLowercase = $i
										and: [(aString at: textindex + 1) asLowercase = $n
											and: [(aString at: textindex + 2) asLowercase = $g]]])
									ifTrue: [textindex _ textindex + 3]
									ifFalse: [^ false]]].
		rightindex _ rightindex + 1].
	^ true! !

!PhoneticRule methodsFor: 'private' stamp: 'len 4/10/98 23:19'!
textMatches: aString at: anInteger
	text size > (aString size - anInteger + 1) ifTrue: [^ false].
	1 to: text size do: [ :each |
		(text at: each) asLowercase = (aString at: anInteger + each - 1) asLowercase ifFalse: [^ false]].
	^ true! !


!PhoneticRule methodsFor: 'comparing' stamp: 'len 5/29/1999 03:58'!
= anObject
	^ anObject left = self left
		and: [anObject right = self right
			and: [anObject text = self text
				and: [anObject phonemes = self phonemes]]]! !

!PhoneticRule methodsFor: 'comparing' stamp: 'len 5/29/1999 03:58'!
hash
	^ self text hash! !


!PhoneticRule methodsFor: 'printing' stamp: 'len 5/31/1999 00:32'!
printOn: aStream
	aStream
		nextPut: $[; print: left; nextPut: $,; print: text; nextPut: $,; print: right; nextPut: $];
		nextPutAll: ' -> '.
	phonemes isEmpty ifTrue: [aStream nextPutAll: '{}'] ifFalse: [aStream nextPut: $/].
	phonemes do: [ :each | aStream nextPutAll: each name; nextPut: $/]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhoneticRule class
	instanceVariableNames: ''!

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:14'!
english
	"Answer the english phonetic rules."
	| answer |
	answer _ OrderedCollection new.
	#(englishPunctuationRules
		englishARules englishBRules englishCRules englishDRules englishERules
		englishFRules englishGRules englishHRules englishIRules englishJRules
		englishKRules englishLRules englishMRules englishNRules englishORules
		englishPRules englishQRules englishRRules englishSRules englishTRules
		englishURules englishVRules englishWRules englishXRules englishYRules
		englishZRules) do: [ :each | answer addAll: (self perform: each)].
	^ answer asArray! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:54'!
englishARules
	^ #((''		'a'		' '		'ax')
		(' '		'are'	' '		'aa/r')
		(' '		'ar'		'o'		'ax/r')
		(''		'ar'		'#'		'eh/r')
		('^'		'as'		'#'		'ey/s')
		(''		'a'		'wa'	'ax')
		(''		'aw'	''		'ao')
		(' :'		'any'	''		'eh/n/iy')
		(''		'a'		'^+#'	'ey')
		('#:'	'ally'	''		'ax/l/iy')
		(' '		'al'		'#'		'ax/l')
		(''		'again'	''		'ax/g/eh/n')
		('#:'	'ag'		'e'		'ih/jh')
		(''		'a'		'^+:#'	'ae')
		(' :'		'a'		'^+ '	'ey')
		(' '		'arr'	''		'ax/r')
		(''		'arr'	''		'ae/r')
		(' :'		'ar'		' '		'aa/r')
		(''		'ar'		' '		'er')
		(''		'ar'		''		'aa/r')
		(''		'air'	''		'eh/r')
		(''		'ai'		''		'ey')
		(''		'ay'		''		'ey')
		(''		'au'		''		'ao')
		('#:'	'al'		' '		'ax/l')
		('#:'	'als'	' '		'ax/l/z')
		(''		'alk'	''		'ao/k')
		(''		'al'		'^'		'ao/l')
		(' :'		'able'	''		'ey/b/ax/l')
		(''		'able'	''		'ax/b/ax/l')
		(''		'ang'	'+'		'ey/n/jh')
		('^'		'a'		'^#'		'ey')
		(''		'a'		''		'ae')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:58'!
englishBRules
	^ #((' '		'be'		'^#'		'b/ih')
		(''		'being'	''		'b/iy/ih/ng')
		(' '		'both'	''		'b/ow/th')
		(' '		'bus'	'#'		'b/ih/z')
		(''		'buil'	''		'b/ih/l')
		(''		'b'		''		'b')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/30/1999 23:59'!
englishCRules
	^ #((' '		'ch'		'^'		'k')
		('^e'	'ch'		''		'k')
		(''		'ch'		''		'ch')
		(' s'		'ci'		'#'		's/ay')
		(''		'ci'		'a'		'sh')
		(''		'ci'		'o'		'sh')
		(''		'ci'		'en'		'sh')
		(''		'c'		'+'		's')
		(''		'ck'		''		'k')
		(''		'com'	'%'		'k/ah/m')
		(''		'c'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 12/2/1999 02:41'!
englishDRules
	^ #(('#:'	'ded'	' '		'd/ih/d')
		('.e'		'd'		' '		'd')
		('#:^e'	'd'		' '		't')
		(' '		'de'		'^#'		'd/ih')
		(' '		'do'		' '		'd/uw')
		(' '		'does'	''		'd/ah/z')
		(' '		'doing'	''		'd/uw/ih/ng')
		(' '		'dow'	''		'd/aw')
		(''		'du'		'a'		'jh/uw')
		(''		'd'		''		'd')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 12/9/1999 02:27'!
englishERules
	^ #(('#:'	'e'		' '		'')
		(''':^'	'e'		' '		'')
		(' :'		'e'		' '		'iy')
		('#'		'ed'		' '		'd')
		('#:'	'e'		'd'		'')
		(''		'ev'		'er'		'eh/v')
		(''		'e'		'^%'		'iy')
		(''		'eri'	'#'		'iy/r/iy')
		(''		'eri'	''		'eh/r/ih')
		('#:'	'er'		'#'		'er')
		(''		'er'		'#'		'eh/r')
		(''		'er'		''		'er')
		(' '		'even'	''		'iy/v/eh/n')
		('#:'	'e'		'w'		'')
		('t'		'ew'	''		'uw')
		('s'		'ew'	''		'uw')
		('r'		'ew'	''		'uw')
		('d'		'ew'	''		'uw')
		('l'		'ew'	''		'uw')
		('z'		'ew'	''		'uw')
		('n'		'ew'	''		'uw')
		('j'		'ew'	''		'uw')
		('th'	'ew'	''		'uw')
		('ch'	'ew'	''		'uw')
		('sh'	'ew'	''		'uw')
		(''		'ew'	''		'y/uw')
		(''		'e'		'o'		'iy')
		('#:s'	'es'		' '		'ih/z')
		('#:c'	'es'		' '		'ih/z')
		('#:g'	'es'		' '		'ih/z')
		('#:z'	'es'		' '		'ih/z')
		('#:x'	'es'		' '		'ih/z')
		('#:j'	'es'		' '		'ih/z')
		('#:ch'	'es'		' '		'ih/z')
		('#:sh'	'es'		' '		'ih/z')
		('#:'	'e'		's'		'')
		('#:'	'ely'	' '		'l/iy')
		('#:'	'ement'	''		'm/eh/n/t')
		(''		'eful'	''		'f/uh/l')
		(''		'ee'		''		'iy')
		(''		'earn'	''		'er/n')
		(' '		'ear'	'^'		'er')
		(''		'ead'	''		'eh/d')
		('#:'	'ea'		' '		'iy/ax')
		(''		'ea'		'su'		'eh')
		(''		'ea'		''		'iy')
		(''		'eigh'	''		'ey')
		(''		'ei'		''		'iy')
		(' '		'eye'	''		'ay')
		(''		'ey'		''		'iy')
		(''		'eu'		''		'y/uw')
		(''		'e'		''		'eh')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:01'!
englishFRules
	^ #((''		'ful'	''		'f/uh/l')
		(''		'f'		''		'f')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:02'!
englishGRules
	^ #((''		'giv'	''		'g/iy/v')
		(' '		'g'		'i^'		'g')
		(''		'ge'		't'		'g/eh')
		('su'	'gges'	''		'g/jh/eh/s')
		(''		'gg'		''		'g')
		(' b#'	'g'		''		'g')
		(''		'g'		'+'		'jh')
		(''		'great'	''		'g/r/ey/t')
		('#'		'gh'		''		'')
		(''		'g'		''		'g')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 7/20/1999 00:42'!
englishHRules
	^ #((' '		'hav'	''		'hh/ae/v')
		(' '		'here'	''		'hh/iy/r')
		(' '		'hour'	''		'aw/er')
		(''		'how'	''		'hh/aw')
		(''		'h'		'#'		'hh')
		(''		'h'		''		'')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:03'!
englishIRules
	^ #((' '		'in'		''		'ih/n')
		(' '		'i'		' '		'ay')
		(''		'in'		'd'		'ay/n')
		(''		'ier'	''		'iy/er')
		('#:r'	'ied'	''		'iy/d')
		(''		'ied'	' '		'ay/d')
		(''		'ien'	''		'iy/eh/n')
		(''		'ie'		't'		'ay/eh')
		(' :'		'i'		'%'		'ay')
		(''		'i'		'%'		'iy')
		(''		'ie'		''		'iy')
		(''		'i'		'^+:#'	'ih')
		(''		'ir'		'#'		'ay/r')
		(''		'iz'		'%'		'ay/z')
		(''		'is'		'%'		'ay/z')
		(''		'i'		'd%'		'ay')
		('+^'	'i'		'^+'		'ih')
		(''		'i'		't%'		'ay')
		('#:^'	'i'		'^+'		'ih')
		(''		'i'		'^+'		'ay')
		(''		'ir'		''		'er')
		(''		'igh'	''		'ay')
		(''		'ild'		''		'ay/l/d')
		(''		'ign'	' '		'ay/n')
		(''		'ign'	'^'		'ay/n')
		(''		'ign'	'%'		'ay/n')
		(''		'ique'	''		'iy/k')
		(''		'i'		''		'ih')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:03'!
englishJRules
	^ #((''		'j'		''		'jh')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishKRules
	^ #((''		'k'		'n'		'')
		(''		'k'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishLRules
	^ #((''		'lo'		'c#'		'l/ow')
		('l'		'l'		''		'')
		('#:^'	'l'		'%'		'ax/l')
		(''		'lead'	''		'l/iy/d')
		(''		'l'		''		'l')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:04'!
englishMRules
	^ #((''		'mov'	''		'm/uw/v')
		(''		'm'		''		'm')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:05'!
englishNRules
	^ #(('e'		'ng'		'+'		'n/jh')
		(''		'ng'		'r'		'ng/g')
		(''		'ng'		'#'		'ng/g')
		(''		'ngl'	'%'		'ng/g/ax/l')
		(''		'ng'		''		'ng')
		(''		'nk'		''		'ng/k')
		(' '		'now'	' '		'n/aw')
		(''		'n'		''		'n')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:06'!
englishORules
	^ #((''		'of'		' '		'ax/v')
		(''		'orough'	''	'er/ow')
		('#:'	'or'		' '		'er')
		('#:'	'ors'	' '		'er/z')
		(''		'or'		''		'ao/r')
		(' '		'one'	''		'w/ah/n')
		(''		'ow'	''		'ow')
		(' '		'over'	''		'ow/v/er')
		(''		'ov'		''		'ah/v')
		(''		'o'		'^%'		'ow')
		(''		'o'		'^en'	'ow')
		(''		'o'		'^i#'	'ow')
		(''		'ol'		'd'		'ow/l')
		(''		'ought'	''		'ao/t')
		(''		'ough'	''		'ah/f')
		(' '		'ou'		''		'aw')
		('h'		'ou'		's#'		'aw')
		(''		'ous'	''		'ax/s')
		(''		'our'	''		'ao/r')
		(''		'ould'	''		'uh/d')
		('^'		'ou'		'^l'		'ah')
		(''		'oup'	''		'uw/p')
		(''		'ou'		''		'aw')
		(''		'oy'		''		'oy')
		(''		'oing'	''		'ow/ih/ng')
		(''		'oi'		''		'oy')
		(''		'oor'	''		'ao/r')
		(''		'ook'	''		'uh/k')
		(''		'ood'	''		'uh/d')
		(''		'oo'		''		'uw')
		(''		'o'		'e'		'ow')
		(''		'o'		' '		'ow')
		(''		'oa'		''		'ow')
		(' '		'only'	''		'ow/n/l/iy')
		(' '		'once'	''		'w/ah/n/s')
		(''		'on''t'	''		'ow/n/t')
		('c'		'o'		'n'		'aa')
		(''		'o'		'ng'		'ao')
		(' :^'	'o'		'n'		'ah')
		('i'		'on'		''		'ax/n')
		('#:'	'on'		' '		'ax/n')
		('#^'	'on'		''		'ax/n')
		(''		'o'		'st '		'ow')
		(''		'of'		'^'		'ao/f')
		(''		'other'	''		'ah/dh/er')
		(''		'oss'	' '		'ao/s')
		('#:^'	'om'	''		'ah/m')
		(''		'o'		''		'aa')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:06'!
englishPRules
	^ #((''		'ph'		''		'f')
		(''		'peop'	''		'p/iy/p')
		(''		'pow'	''		'p/aw')
		(''		'put'	' '		'p/uh/t')
		(''		'p'		''		'p')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishPunctuationRules
	^ #(('.'		'''s'		''		'z')
		('#:.e'	'''s'		''		'z')
		('#'		'''s'		''		'z')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishQRules
	^ #((''		'quar'	''		'k/w/ao/r')
		(''		'qu'		''		'k/w')
		(''		'q'		''		'k')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishRRules
	^ #((''		're'		'^#'		'r/iy')
		(''		'r'		''		'r')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:07'!
englishSRules
	^ #((''		'sh'		''		'sh')
		('#'		'sion'	''		'zh/ax/n')
		(''		'some'	''		's/ah/m')
		('#'		'sur'	'#'		'zh/er')
		(''		'sur'	'#'		'sh/er')
		('#'		'su'		'#'		'zh/uw')
		('#'		'ssu'	'#'		'sh/uw')
		('#'		'sed'	' '		'z/d')
		('#'		's'		'#'		'z')
		(''		'said'	''		's/eh/d')
		('^'		'sion'	''		'sh/ax/n')
		(''		's'		's'		'')
		('.'		's'		' '		'z')
		('#:.e'	's'		' '		'z')
		('#:^##'	's'		' '		'z')
		('#:^#'	's'		' '		's')
		('u'		's'		' '		's')
		(' :#'	's'		' '		'z')
		(' '		'sch'	''		's/k')
		(''		's'		'c+'		'')
		('#'		'sm'		''		'z/m')
		('#'		'sn'		''''		'z/ax/n')
		(''		's'		''		's')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:08'!
englishTRules
	^ #((' '		'the'	' '		'dh/ax')
		(''		'to'		' '		't/uw')
		(''		'that'	' '		'dh/ae/t')
		(' '		'this'	' '		'dh/ih/s')
		(' '		'they'	''		'dh/ey')
		(' '		'there'	''		'dh/eh/r')
		(''		'ther'	''		'dh/er')
		(''		'their'	''		'dh/eh/r')
		(' '		'than'	' '		'dh/ae/n')
		(' '		'them'	' '		'dh/eh/m')
		(''		'these'	' '		'dh/iy/z')
		(' '		'then'	''		'dh/eh/n')
		(''		'through'	''	'th/r/uw')
		(''		'those'	''		'dh/ow/z')
		(''		'though'	' '	'dh/ow')
		(' '		'thus'	''		'dh/ah/s')
		(''		'th'		''		'th')
		('#:'	'ted'	' '		't/ih/d')
		('s'		'ti'		'#n'	'ch')
		(''		'ti'		'o'		'sh')
		(''		'ti'		'a'		'sh')
		(''		'tien'	''		'sh/ax/n')
		(''		'tur'	'#'		'ch/er')
		(''		'tu'		'a'		'ch/uw')
		(''		'two'	''		't/uw')
		(''		't'		''		't')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:09'!
englishURules
	^ #((' '		'un'	'i'		'y/uw/n')
		(' '		'un'	''		'ah/n')
		(' '		'upon'	''		'ax/p/ao/n')
		('t'		'ur'		'#'		'uh/r')
		('s'		'ur'		'#'		'uh/r')
		('r'		'ur'		'#'		'uh/r')
		('d'		'ur'		'#'		'uh/r')
		('l'		'ur'		'#'		'uh/r')
		('z'		'ur'		'#'		'uh/r')
		('n'		'ur'		'#'		'uh/r')
		('j'		'ur'		'#'		'uh/r')
		('th'	'ur'		'#'		'uh/r')
		('ch'	'ur'		'#'		'uh/r')
		('sh'	'ur'		'#'		'uh/r')
		(''		'ur'		'#'		'y/uh/r')
		(''		'ur'		''		'er')
		(''		'u'		'^'		'ah')
		(''		'u'		'^^'		'ah')
		(''		'uy'	''		'ay')
		(' g'	'u'		'#'		'')
		('g'		'u'		'%'		'')
		('g'		'u'		'#'		'w')
		('#n'	'u'		''		'y/uw')
		('t'		'u'		''		'uw')
		('s'		'u'		''		'uw')
		('r'		'u'		''		'uw')
		('d'		'u'		''		'uw')
		('l'		'u'		''		'uw')
		('z'		'u'		''		'uw')
		('n'		'u'		''		'uw')
		('j'		'u'		''		'uw')
		('th'	'u'		''		'uw')
		('ch'	'u'		''		'uw')
		('sh'	'u'		''		'uw')
		(''		'u'		''		'y/uw')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:09'!
englishVRules
	^ #((''		'view'	''		'v/y/uw')
		(''		'v'		''		'v')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 7/20/1999 00:43'!
englishWRules
	^ #((' '		'were'	''		'w/er')
		(''		'wa'	's'		'w/aa')
		(''		'wa'	't'		'w/aa')
		(''		'where'	''		'wh/eh/r')
		(''		'what'	''		'wh/aa/t')
		(''		'whol'	''		'hh/ow/l')
		(''		'who'	''		'hh/uw')
		(''		'wh'	''		'wh')
		(''		'war'	''		'w/ao/r')
		(''		'wor'	'^'		'w/er')
		(''		'wr'	''		'r')
		(''		'w'		''		'w')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishXRules
	^ #((''		'x'		''		'k/s')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishYRules
	^ #((''		'young'	''		'y/ah/ng')
		(' '		'you'	''		'y/uw')
		(' '		'yes'	''		'y/eh/s')
		(' '		'y'		''		'y')
		('#:^'	'y'		' '		'iy')
		('#:^'	'y'		'i'		'iy')
		(' :'		'y'		''		'ay')
		(' :'		'y'		'#'		'ay')
		(' :'		'y'		'^+:#'	'ih')
		(' :'		'y'		'^#'		'ay')
		(''		'y'		''		'ih')
	) collect: [ :each | self fromArray: each]! !

!PhoneticRule class methodsFor: 'examples-english' stamp: 'len 5/31/1999 00:10'!
englishZRules 
	^ #((''		'z'		''		'z')
	) collect: [ :each | self fromArray: each]! !


!PhoneticRule class methodsFor: 'examples' stamp: 'len 12/8/1999 17:14'!
spanish
	"Answer the spanish phonetic rules."
	| phonemes |
	phonemes _ PhonemeSet spanish.
	^ #(
		(''		'a'		''		'a')
		(''		'b'		''		'b')
		(''		'ch'		''		'ch')
		(''		'c'		'i'		'z')
		(''		'c'		'e'		'z')
		(''		'c'		''		'k')
		(''		'd'		''		'd')
		(''		'e'		''		'e')
		(''		'f'		''		'f')
		(''		'g'		'e'		'j')
		(''		'g'		'i'		'j')
		(''		'gu'		'e'		'g')
		(''		'gu'		'i'		'g')
		(''		'g'		''		'g')
		(''		'h'		''		'')
		(''		'i'		''		'i')
		(''		'j'		''		'j')
		(''		'k'		''		'k')
		(''		'll'		''		'y')
		(''		'l'		''		'l')
		(''		'm'		''		'm')
		(''		'n'		''		'n')
		(''		'o'		''		'o')
		(''		'p'		''		'p')
		(''		'qu'		''		'k')
		(''		'rr'		''		'rx')
		(' '		'r'		''		'rx')
		(''		'r'		''		'r')
		(''		's'		''		's')
		(''		't'		''		't')
		(''		'u'		''		'u')
		(''		'v'		''		'v')
		(''		'w'		''		'w')
		(''		'x'		''		'k/s')
		(''		'y'		' '		'i')
		(''		'y'		''		'y')
		(''		'z'		''		'z')
	) collect: [ :each | self fromArray: each phonemes: phonemes]! !


!PhoneticRule class methodsFor: 'instance creation' stamp: 'len 5/31/1999 00:16'!
fromArray: anArray
	^ self fromArray: anArray phonemes: PhonemeSet arpabet! !

!PhoneticRule class methodsFor: 'instance creation' stamp: 'len 5/31/1999 00:19'!
fromArray: anArray phonemes: aPhonemeSet
	^ self new
		left: (anArray at: 1);
		text: (anArray at: 2);
		right: (anArray at: 3);
		phonemes: (aPhonemeSet transcriptionOf: (anArray at: 4)) asArray! !
Object subclass: #PhoneticTranscriber
	instanceVariableNames: 'phonemes rules lexicon '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Phonetics'!
!PhoneticTranscriber commentStamp: '<historical>' prior: 0!
My instances perform automatic words-to-phonemes transcription. (See the PhoneticRule class comment too.)

Each transcriber must have a collection of PhoneticRules, and optionally a lexicon. When a transcriber is asked for the transcription of a word, it searches for the word in the lexicon first, and if the word is not found then the rules are used.

Rules are made up of four parts: (1) left context pattern, (2) the text to match, (3) the right context pattern, and (4) the phonemes to substitute for the matched text.

The transcription procedure begins when a text is provided to a transcriber. For each unmatched letter in the word, look through the rules where the text to match starts with the letter in the word. If one matching rule is found, then the rule is applied, writing the corresponding phonemes in the output and moving forward to the next unmatched position. If no rule is found for a position in the text, then the unmatched position is logged. At the end of the transcription, the phonemes extracted are provided in a collection and so are the unmatched positions.
!


!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'len 11/29/1999 02:31'!
lexicon: aDictionary
	lexicon _ aDictionary! !

!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'len 6/5/1999 01:56'!
phonemes: aPhonemeSet
	phonemes _ aPhonemeSet! !

!PhoneticTranscriber methodsFor: 'accessing-private' stamp: 'len 4/10/98 05:10'!
rules: aCollection
	rules _ aCollection! !


!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 11/29/1999 02:31'!
lexicon
	^ lexicon! !

!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 6/5/1999 01:56'!
phonemes
	^ phonemes! !

!PhoneticTranscriber methodsFor: 'accessing' stamp: 'len 6/5/1999 01:56'!
rules
	^ rules! !


!PhoneticTranscriber methodsFor: 'computing' stamp: 'len 12/14/1999 03:39'!
transcriptionOf: aString
	"Answer the phonetic transcription of the word in aString."
	| rule string index transcription stressed |
	(transcription _ self tryLexicon: aString) isNil ifFalse: [^ transcription].
	transcription _ OrderedCollection new.
	string _ ' ', aString,' '.
	index _ 2.
	[index < string size] whileTrue: [
		rule _ self rules
			detect: [ :one | one matches: string at: index]
			ifNone: [].
		rule isNil
			ifTrue: ["unmatched character" index _ index+1]
			ifFalse: [index _ index + rule text size.
					transcription addAll: rule phonemes]].
	stressed _ false.
	^ transcription collect: [ :each |
		(stressed not and: [each isVowel or: [each isDiphthong]])
			ifTrue: [stressed _ true. each stressed: 1] ifFalse: [each]]! !


!PhoneticTranscriber methodsFor: 'computing-private' stamp: 'len 11/29/1999 02:31'!
tryLexicon: aWord
	| string |
	self lexicon isNil ifTrue: [^ nil].
	string _ self lexicon at: aWord asUppercase ifAbsent: [^ nil].
	^ self phonemes transcriptionOf: string asLowercase! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhoneticTranscriber class
	instanceVariableNames: ''!

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 4/13/98 16:21'!
default
	^ self english! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 12/14/1999 03:29'!
english
	"Answer an english phonetic transcriber."
	^ self new rules: PhoneticRule english; phonemes: PhonemeSet arpabet; lexicon: self englishLexicon! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 12/14/1999 04:05'!
englishLexicon
	^ Dictionary new
		add: 'HOW' -> 'HH AW1';
		add: 'YOU' -> 'Y UW1';
		add: 'ARE' -> 'AA1 R';
		add: 'DOING' -> 'D UW1 IH0 NG';
		add: 'THIS' -> 'DH IH1 S';
		add: 'IS' -> 'IH1 Z';
		add: 'MY' -> 'M AY1';
		add: 'VOICE' -> 'V OY1 S';
		add: 'FAST' -> 'F AE1 S T';
		add: 'SLOW' -> 'S L OW1';
		add: 'I' -> 'AY1';
		add: 'AM' -> 'AE1 M';
		add: 'A' -> 'AH0';
		add: 'AN' ->  'AE1 N';
		add: 'LOW' -> 'L OW1';
		add: 'SPEAKER' -> 'S P IY1 K ER0';
		add: 'ANSWER' -> 'AE1 N S ER0';
		add: 'RECEIVER' -> 'R AH0 S IY1 V ER0';
		add: 'OBJECT' -> 'AA1 B JH EH0 K T';
		add: 'OBJECTS' -> 'AA1 B JH EH0 K T S';
		add: 'READ' -> 'R IY1 D';
		add: 'WRITE' -> 'R AY1 T';
		add: 'SQUEAK' -> 'S K W IY1 K';
		add: 'SMALLTALK' -> ' S M AO1 L T AO2 K';
		add: 'CLASS' -> 'K L AE1 S';
		add: 'WOMAN' -> 'W UH1 M AH0 N';
		add: 'BICYCLIC' ->  'B AY1 S IH0 K L IH0 K';
		add: 'LISTEN' -> 'L IH1 S AH0 N';
		yourself! !

!PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 12/14/1999 03:29'!
spanish
	"Answer a spanish phonetic transcriber."
	^ self new rules: PhoneticRule spanish; phonemes: PhonemeSet arpabet! !
Object subclass: #Phrase
	instanceVariableNames: 'string words accent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Phrase commentStamp: '<historical>' prior: 0!
My instances are phrases. They can carry a phrase accent ('H-' or 'L-') and a boundary tone ('H%', 'L%', '%H').!


!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:32'!
accent
	^ accent! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:32'!
accent: aString
	accent _ aString! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
accept: anObject
	anObject phrase: self! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:53'!
events
	| answer |
	answer _ CompositeEvent new.
	self words do: [ :each | answer addAll: each events].
	^ answer! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 18:51'!
lastSyllable
	^ self words last lastSyllable! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string
	^ string! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/12/1999 22:22'!
string: aString
	string _ aString! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
words
	^ words! !

!Phrase methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
words: aCollection
	words _ aCollection! !


!Phrase methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:19'!
eventsDo: aBlock
	self words do: [ :word | word eventsDo: aBlock]! !

!Phrase methodsFor: 'enumarating' stamp: 'len 12/13/1999 02:37'!
syllablesDo: aBlock
	self words do: [ :each | each syllables do: aBlock]! !


!Phrase methodsFor: 'printing' stamp: 'len 12/8/1999 18:17'!
printOn: aStream
	self words do: [ :each | aStream print: each; space]! !
TileLikeMorph subclass: #PhraseTileMorph
	instanceVariableNames: 'resultType brightenedOnEnter userScriptSelector justGrabbedFromViewer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!PhraseTileMorph commentStamp: '<historical>' prior: 0!
Phrase Tile World: A single smalltalk expression in tiles.  Like (car forwardBy: number), having 3 tiles.  

type = command
rcvrType = #actor


In the Old Single tile world:  Holder for a phrase of tiles as it came from the viewer and while it is being dragged by the hand.

 !


!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 1/19/2001 14:18'!
initialize
	"Initialize a nascent instance"

	super initialize.
	resultType = #unknown.
	brightenedOnEnter _ false.
	self wrapCentering: #center; cellPositioning: #leftCenter.
	self hResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	self extent: 5@5.  "will grow to fit"
	justGrabbedFromViewer _ true.  "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false"
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 10/29/1998 16:01'!
setAssignmentRoot: opSymbol type: opType rcvrType: rcvrType argType: argType
	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	self addMorphBack: ((AssignmentTileMorph new setRoot: opSymbol asString dataType: argType) typeColor: color).
	self addMorphBack: (TilePadMorph new setType: argType)
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 2/5/1999 14:51'!
setOperator: opSymbol type: opType rcvrType: rcvrType
	self setOperator: opSymbol type: opType rcvrType: rcvrType argType: nil.
! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 2/5/1999 14:54'!
setOperator: opSymbol type: opType rcvrType: rcvrType argType: argType

	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: rcvrType).
	self addMorphBack: ((TileMorph new setOperator: opSymbol asString) typeColor: color).
	opSymbol numArgs = 1 ifTrue:
		[self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#object]))]! !

!PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 10/29/1998 16:01'!
setSlotRefOperator: opSymbol type: opType

	resultType _ opType.
	self color: (ScriptingSystem colorForType: opType).
	self removeAllMorphs.
	self addMorph: (TilePadMorph new setType: #player).
	self addMorphBack: ((TileMorph new setSlotRefOperator: opSymbol asString) typeColor: color)
! !


!PhraseTileMorph methodsFor: 'mouse' stamp: 'ar 11/9/2000 21:05'!
acceptDroppingMorph: aMorph event: evt

	| m |
	m _ self owner.
	[m == nil] whileFalse: [
		self flag: #priorityFix.
		self flag: #arNote. "What the @#$% is this????????"
		((m respondsTo: #orientation) and: [m orientation == #vertical]) ifTrue: [^ m acceptDroppingMorph: aMorph event: evt].
		m _ m owner].

	"| o |
	self prepareToUndoDropOf: aMorph.
	o _ owner.
	self delete.
	aMorph position: o position.
	o addMorph: aMorph."
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'tk 10/10/97 15:10'!
canAccept: aMorph

	"((aMorph isKindOf: PhraseTileMorph) or:
	 [aMorph isKindOf: TileMorph])"  "not allow dropping to replace now"
	(aMorph isKindOf: TileMorph) ifTrue: [
			^ aMorph resultType == resultType]. "This is never used????"
	^ false
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'jm 5/28/1998 19:10'!
catchDivideByZero: aStream indent: tabCount
	"See if I am have divide as my operator. If so, insert a test in the argument to divide."

	(submorphs at: 2) type = #operator ifFalse: [^ false].		"not me"
	(submorphs at: 2) operatorOrExpression == #/ ifFalse: [^ false].	"not me"
	aStream space.
	aStream nextPutAll: '(self beNotZero: '.
	(submorphs at: 3) storeCodeOn: aStream indent: tabCount.
	aStream nextPut: $).
	^ true
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'di 11/12/2000 15:31'!
enclosingEditor
	"Return the next scriptor outward in the containment hierarchy"
	^ self firstOwnerSuchThat:
		[:m | (m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]]! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'di 7/3/1998 14:24'!
handlesDragOver: evt

	^ true
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'ar 10/6/2000 23:38'!
handlesMouseDown: evt
	^true! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'jm 6/26/97 19:53'!
handlesMouseOver: evt

	^ true
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 07:57'!
handlesMouseOverDragging: evt

	^ true
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'sw 1/19/2001 14:20'!
justDroppedInto: newOwner event: evt
	"Phrase tiles only auto-expand if they originate from viewers.  Any phrase tile, once dropped, loses its auto-phrase-expansion thing"

	justGrabbedFromViewer _ false! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'sw 1/29/2001 21:46'!
morphToDropInPasteUp: aPasteUp
	"Answer the morph to drop in aPasteUp, given that the receiver is the putative droppee"

	| actualObject itsSelector aScriptor adjustment handy |

	self isCommand ifFalse: [^ self].
	(actualObject _ self actualObject) ifNil: [^ self].
	self justGrabbedFromViewer ifFalse: [^ self].
	actualObject assureUniClass.
	itsSelector _ self userScriptSelector.
	aScriptor _ itsSelector isEmptyOrNil
		ifFalse:
			[adjustment _ 0@0.
			actualObject scriptEditorFor: itsSelector]
		ifTrue:
			["It's a system-defined selector; construct an anonymous scriptor around it"
			adjustment _ 60 @ 20.
			actualObject newScriptorAround: self].

	handy _ aPasteUp primaryHand.
	aScriptor ifNotNil: [aScriptor position: handy position - adjustment].
	^ aScriptor ifNil: [self]! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'RAA 2/3/2001 16:24'!
mouseDown: evt 
	"Pretend we picked up the tile and then put it down for a trial  
	positioning."
	"The essence of ScriptEditor mouseEnter:"
	| ed ss guyToTake |
	self isPartsDonor ifTrue:[^self duplicateMorph: evt].
	submorphs isEmpty
		ifTrue: [^ self].
	(ed _ self enclosingEditor) ifNil: [^evt hand grabMorph: self].

	guyToTake _ self.
	owner class == TilePadMorph
		ifTrue: ["picking me out of another phrase"
			(ss _ submorphs first) class == TilePadMorph
				ifTrue: [ss _ ss submorphs first].
			guyToTake _  ss fullCopy].
	evt hand grabMorph: guyToTake.
	ed startStepping.
	ed mouseEnterDragging: evt.
	ed setProperty: #justPickedUpPhrase toValue: true.
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'jm 6/26/97 21:58'!
mouseEnter: evt
	"Show drag/drop feedback."

	| h m |
	h _ evt hand.
	h submorphCount ~= 1 ifTrue: [^ self].
	m _ h firstSubmorph.
	(self canAccept: m) ifFalse: [^ self].
	"don't give feedback if I'm not the inner-most phrase that could be replaced"
	(self morphsAt: evt cursorPoint) do: [:subM |
		((subM isKindOf: PhraseTileMorph) and: [subM ~~ self]) ifTrue: [^ self].
		(subM isKindOf: TilePadMorph) ifTrue: [^ self]].

	self brightenTiles.
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'ar 10/25/2000 23:13'!
prepareToUndoDropOf: aMorph

	| m |
	self mouseLeave: MouseMoveEvent new.
	m _ self owner.
	[m == nil] whileFalse: [
		(m isKindOf: ScriptEditorMorph) ifTrue: [^ m prepareToUndoDropOf: aMorph].
		m _ m owner].
! !

!PhraseTileMorph methodsFor: 'mouse' stamp: 'jm 6/26/97 20:57'!
wantsDroppedMorph: aMorph event: evt

	^ self canAccept: aMorph
! !


!PhraseTileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:33'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!PhraseTileMorph methodsFor: 'code generation' stamp: 'jm 5/28/1998 19:10'!
storeCodeOn: aStream indent: tabCount
	"Add in some smarts for division by zero."

	aStream nextPut: $(.
	(submorphs at: 1) storeCodeOn: aStream indent: tabCount.
	aStream space.
	(submorphs at: 2) storeCodeOn: aStream indent: tabCount.
	submorphs size > 2 ifTrue: [
		(self catchDivideByZero: aStream indent: tabCount) ifFalse: [
			aStream space.
			(submorphs at: 3) storeCodeOn: aStream indent: tabCount]].
	aStream nextPut: $).
! !


!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 8/11/1998 16:39'!
actualObject
	"Answer the player that's the object of my attention"

	^ self associatedPlayer! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/25/2001 10:52'!
addAddHandMenuItemsForHalo: aMenu hand: aHand
	"Add additional items to the halo manu"

	super addAddHandMenuItemsForHalo: aMenu hand: aHand.
	aMenu add: 'Sprout a new scriptor around this phrase' target: self action: #sproutNewScriptor! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 8/6/1999 13:59'!
associatedPlayer
	"Answer the player that's the object of my attention"

	| pp |
	pp _ self firstSubmorph.
	[pp isKindOf: PhraseTileMorph] whileTrue: [pp _ pp firstSubmorph].
	^ pp firstSubmorph actualObject! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/8/2000 16:42'!
bePossessive
	"No way for doubly possessive stuff to work at present, so we just catch and swallow this request here."

	self flag: #deferred! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/3/97 16:59'!
booleanOperator
	| op |
	"If the receiver represents a boolean value, return the associated operator; if not, return nil"

	submorphs size < 2 ifTrue: [^ nil].
	(op _ submorphs second) type == #operator ifFalse: [^ nil].
	^ (#(< <= = == ~= > >= ~~) includes: op operatorOrExpression)
		ifTrue:
			[op operatorOrExpression]
		ifFalse:
			[nil]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 10/29/1998 16:00'!
brightenTiles
	brightenedOnEnter _ true.
	self allMorphsDo: [:m |
		(m isKindOf: TileMorph) ifTrue:
			[m color: (ScriptingSystem brightColorFor: m color)]]
! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 4/22/1998 14:59'!
bringUpToDate
	"Nothing here to do in the current architecture"! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 7/28/1999 17:02'!
isCandidateForAutomaticViewing
	^ false! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 15:06'!
justGrabbedFromViewer
	"Answer whether the receiver originated in a Viewer.  Only tiles that originated in a viewer will ever do that infernal sprouting of a new script around them.  The nil branch is only for backward compatibility."

	^ justGrabbedFromViewer ifNil: [justGrabbedFromViewer _ true]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 14:25'!
justGrabbedFromViewer: aBoolean
	"Set the receiver's justGrabbedFromViewer instance variable"

	justGrabbedFromViewer _ aBoolean! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/19/2001 20:26'!
justGrabbedFromViewerOrNil
	"Answer the value of the receiver's justGrabbedFromViewer slot.  Needed only for conversion methods"

	^ justGrabbedFromViewer! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self lastSubmorph lastTile! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/1/2000 08:41'!
operatorTile
	"Answer the submorph which comprises the operator tile of the receiver.  Ouch!!"

	^ submorphs second! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'jm 6/25/97 16:56'!
resultType

	^ resultType! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/25/2001 11:02'!
sproutNewScriptor
	"The receiver, operating as a naked phrase tile, wishes to get iself placed in a nascent script"

	| newScriptor |

	self actualObject assureUniClass.
	newScriptor _ self actualObject newScriptorAround:
		((self ownerThatIsA: Viewer orA: ScriptEditorMorph)
			ifNotNil:
				[self fullCopy]
			ifNil:
				[self]).
	self currentHand attachMorph: newScriptor! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/20/2001 00:30'!
tileRows
	"Answer a list of tile rows -- in this case exactly one row -- representing the receiver.  The fullCopy is deeply problematical here in the presence of the formerOwner property, so it the latter is temporarily set aside"

	^ Array with: (Array with: self fullCopyWithoutFormerOwner)! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 5/13/1998 16:42'!
topEditor
	^ self outermostMorphThat: [:m | (m isKindOf: ScriptEditorMorph) or:
		 [m isKindOf: CompoundTileMorph]]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 5/23/2000 17:53'!
try
	| aPlayer |
	userScriptSelector == nil
		ifFalse:
			[aPlayer _ self objectViewed player.
			aPlayer perform: userScriptSelector]
		ifTrue:
			[Compiler evaluate:
				self codeString
				for: self associatedPlayer
				logged: false]! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 11/9/1998 18:48'!
unbrightenTiles
	brightenedOnEnter ifFalse: [^ self].
	brightenedOnEnter _ false.
	self allMorphsDo: [:m |
		(m isKindOf: TileMorph) ifTrue:
			[m color: (ScriptingSystem unbrightColorFor: m color)]]
! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/29/98 01:49'!
userScriptSelector
	^ userScriptSelector! !

!PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 1/29/98 01:49'!
userScriptSelector: s
	userScriptSelector _ s! !


!PhraseTileMorph methodsFor: 'queries' stamp: 'sw 10/3/97 17:00'!
isBoolean
	^ self booleanOperator ~~ nil! !

!PhraseTileMorph methodsFor: 'queries' stamp: 'nk 7/8/2000 13:35'!
isCommand
	"Answer whether the receiver is a true line of phrase-command. If not,  
	it is a fragment that will not be able to serve as a line of script on its  
	own"
	| rcvrTile pad |
	submorphs isEmpty
		ifTrue: [^ false].
	pad _ submorphs first.
	(pad isKindOf: TilePadMorph)
		ifTrue: [(submorphs second isKindOf: AssignmentTileMorph)
				ifTrue: [^ true].
			(((rcvrTile _ pad submorphs first) isKindOf: TileMorph)
					and: [rcvrTile isPossessive])
				ifTrue: [^ false]].
	^ true! !

!PhraseTileMorph methodsFor: 'queries' stamp: 'di 8/11/1998 13:15'!
isPossessive
	^ false! !

!PhraseTileMorph methodsFor: 'queries' stamp: 'sw 4/21/1998 21:35'!
isTileScriptingElement
	^ true! !


!PhraseTileMorph methodsFor: 'tiles from method' stamp: 'sw 10/26/2000 14:45'!
tilesFrom: msgNode in: aScriptor
	"Construct a single line of tiles from a MessageNode of a parse tree.  For a single message send."

	| tile pm sel instVar suff argNode selType |

	self flag: #noteToTed.  "Ted: this is your code from 8/6/99, which is now broken before it could ever get used.  The method #scriptInfoFor: which it formerly called is gone; I've included its old content at the end in comments as a pointer.  sw 9/8/2000 09:44"
	"latter-day note: sw 10/10/2000 11:25 - this is now reached by the from a menu item in the Scriptor menu, so this is where the capability needs to be revived"
	true ifTrue: [^ self inform: 'Under Construction!!
Not yet released!!.
(sorry)'].

	sel _ msgNode selector key.
	(sel beginsWith: 'assign') ifTrue: [	"assignment"
		instVar _ msgNode arguments first literalValue.
		instVar _ (instVar copyFrom: 4 to: instVar size) withFirstCharacterDownshifted.
		pm _ (CategoryViewer new) scriptedPlayer: aScriptor playerScripted; 
			makeSetter: nil from: aScriptor playerScripted costume 
			forPart: (Array with: instVar with: #number).	"makes a new Phrase"
		suff _ (sel findTokens: ':') first.
		suff _ (suff copyFrom: 7 to: suff size-6), ':'.		": Incr: Decr: Mult:"
		pm submorphs second setAssignmentSuffix: suff.
		pm submorphs third delete.
		tile _ TilePadMorph new tilesFrom: msgNode arguments last in: aScriptor.
		pm addMorphBack: tile.
		^ pm].

	(sel beginsWith: 'get') ifTrue: [	"getter"
		instVar _ (sel copyFrom: 4 to: sel size) withFirstCharacterDownshifted.
		pm _ (CategoryViewer new) scriptedPlayer: aScriptor playerScripted; 
			makeGetter: nil from: aScriptor playerScripted costume 
			forPart: (Array with: instVar with: #number).	"makes a new Phrase"
		^ pm].

	(#(ifTrue:ifFalse: ifFalse: ifTrue:) includes: sel) ifTrue: [
		^ CompoundTileMorph new tilesFrom: msgNode in: aScriptor].

	self addMorphBack: (TilePadMorph new tilesFrom: msgNode receiver in: aScriptor).
	self addMorphBack: (TileMorph new selectorTile: msgNode in: aScriptor).	"selector"
	(aScriptor playerScripted elementTypeFor: sel) == #systemScript ifTrue: [
		selType _ (aScriptor playerScripted phraseSpecFor: 
			(Array with: #command with: sel)) last].
	msgNode arguments size > 0 ifTrue: [
		argNode _ msgNode arguments last.
		tile _ TileMorph new tilesFrom: argNode type: selType in: aScriptor.
		self addMorphBack: tile].


"Old code from Player, now superseded by an entirely new mechanism...
phraseSpecFor: aPair
	| info prefix |
	info _ (prefix _ aPair first) == #slot
		ifTrue:
			[ScriptingSystem slotInfoFor: aPair second]
		ifFalse:
			[ScriptingSystem scriptInfoFor: aPair second].
	^ (Array with: prefix), info"
! !


!PhraseTileMorph methodsFor: 'all' stamp: 'sw 3/1/1999 11:57'!
rowOfRightTypeFor: aLayoutMorph forActor: aPlayer
	| aTemporaryViewer aPhrase |
	aLayoutMorph demandsBoolean ifTrue:
		[self isBoolean ifTrue: [^ self].
		aTemporaryViewer _ CategoryViewer new invisiblySetPlayer: aPlayer.
		aPhrase _ aTemporaryViewer booleanPhraseFromPhrase: self.
		^ aPhrase].
	^ self! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhraseTileMorph class
	instanceVariableNames: ''!

!PhraseTileMorph class methodsFor: 'backward compatibility' stamp: 'sw 1/19/2001 22:25'!
markViewerOrigination
	"For bringing old content forward"

	| hadIt gotIt didntWantIt |
	hadIt _ 0.
	gotIt _ 0.
	didntWantIt _ 0.
	self allSubInstancesDo:
		[:m | (m ownerThatIsA: CategoryViewer)
			ifNil:
				[m justGrabbedFromViewer: false.
				didntWantIt _ didntWantIt + 1]
			ifNotNil:
				[(m justGrabbedFromViewerOrNil == true)
					ifTrue:
						[hadIt _ hadIt + 1]
					ifFalse:
						[m justGrabbedFromViewer: true.
						gotIt _ gotIt + 1]]].
	Transcript cr; show: 'updating phrase tiles -- already ok: '; show: hadIt; show: '  marked as in-viewer: '; show: gotIt; show: '  marked as not-in-viewer: '; show: didntWantIt.

	"PhraseTileMorph markViewerOrigination"! !
AlignmentMorph subclass: #PhraseWrapperMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!PhraseWrapperMorph commentStamp: '<historical>' prior: 0!
An alignment morph designed for use in scripting Viewers; it wraps a set of phrases in a category viewer, and repels attempts to drop phrases upon it.!


!PhraseWrapperMorph methodsFor: 'extraction support' stamp: 'sw 8/12/97 14:16'!
isPartsBin
	^ true! !

!PhraseWrapperMorph methodsFor: 'extraction support' stamp: 'sw 6/1/2000 22:30'!
repelsMorph: aMorph event: ev
	^ (aMorph isKindOf: PhraseTileMorph) or:
		[aMorph hasProperty: #newPermanentScript]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PhraseWrapperMorph class
	instanceVariableNames: ''!

!PhraseWrapperMorph class methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1998 16:16'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
RectangleMorph subclass: #PianoKeyboardMorph
	instanceVariableNames: 'whiteKeyColor blackKeyColor playingKeyColor nOctaves target noteOnSelector noteOffSelector soundPrototype soundPlaying '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 11/22/2000 13:39'!
buildKeyboard
	| wtWid bkWid keyRect octavePt nWhite nBlack |
	self removeAllMorphs.
	wtWid _ 8. bkWid _ 5.
	self extent: 10@10.
	1 to: nOctaves+1 do:
		[:i | i <= nOctaves ifTrue: [nWhite _ 7.  nBlack _ 5]
						ifFalse: [nWhite _ 1.  nBlack _ 0 "High C"].
		octavePt _ self innerBounds topLeft + ((7*wtWid*(i-1)-1)@-1).
		1 to: nWhite do:
			[:j | keyRect _ octavePt + (j-1*wtWid@0) extent: (wtWid+1)@36.
			self addMorph: ((RectangleMorph newBounds: keyRect color: whiteKeyColor)
								borderWidth: 1;
				on: #mouseDown send: #mouseDownEvent:noteMorph:pitch: to: self
								withValue: i-1*12 + (#(1 3 5 6 8 10 12) at: j))].
		1 to: nBlack do:
			[:j | keyRect _ octavePt + ((#(6 15 29 38 47) at: j)@1) extent: bkWid@21.
			self addMorph: ((Morph newBounds: keyRect color: blackKeyColor)
				on: #mouseDown send: #mouseDownEvent:noteMorph:pitch: to: self
								withValue: i-1*12 + (#(2 4 7 9 11) at: j))]].
	self submorphsDo:
		[:m | m on: #mouseMove send: #mouseMoveEvent:noteMorph:pitch: to: self;
				on: #mouseUp send: #mouseUpEvent:noteMorph:pitch: to: self;
				on: #mouseEnterDragging send: #mouseDownEvent:noteMorph:pitch: to: self;
				on: #mouseLeaveDragging send: #mouseUpEvent:noteMorph:pitch: to: self].
	self extent: (self fullBounds extent + borderWidth - 1)! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 6/21/1999 08:40'!
initialize
	super initialize.
	color _ Color veryLightGray.
	whiteKeyColor _ Color gray: 0.95.
	blackKeyColor _ Color black.
	playingKeyColor _ Color red.
	nOctaves _ 6.
	self buildKeyboard.
	soundPrototype _ FMSound brass1 duration: 9.9! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 11/22/2000 13:27'!
mouseDownEvent: event noteMorph: noteMorph pitch: midiKey
	| pitch |
	event hand hasSubmorphs ifTrue: [^ self  "no response if drag something over me"].
	event hand mouseFocus ifNil:
		["If dragged into me, then establish focus so I'll see moves"
		event hand newMouseFocus: noteMorph event: event].
	noteMorph color: playingKeyColor.
	pitch _ AbstractSound pitchForMIDIKey: midiKey + 23.
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
	soundPlaying _ soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3.
	SoundPlayer resumePlaying: soundPlaying quickStart: true.
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 11/22/2000 13:28'!
mouseMoveEvent: event noteMorph: noteMorph pitch: pitch

	(noteMorph containsPoint: event cursorPoint) ifFalse:
		["If drag out of me, zap focus so other morphs can see drag in."
		event hand releaseMouseFocus: noteMorph]
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 11/22/2000 13:26'!
mouseUpEvent: event noteMorph: noteMorph pitch: pitch

	noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12)
					ifTrue: [whiteKeyColor]
					ifFalse: [blackKeyColor]).
	soundPlaying ifNotNil: [soundPlaying stopGracefully].
! !

!PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'di 9/4/1998 12:57'!
soundPrototype: aSound
	soundPrototype _ aSound! !
Morph subclass: #PianoRollNoteMorph
	instanceVariableNames: 'trackIndex indexInTrack hitLoc editMode selected notePlaying '
	classVariableNames: 'SoundPlaying '
	poolDictionaries: ''
	category: 'Sound-Scores'!
!PianoRollNoteMorph commentStamp: '<historical>' prior: 0!
A PianoRollNoteMorph is drawn as a simple mroph, but it carries the necessary state to locate its source sound event via its owner (a PianorRollScoreMorph) and the score therein.  Simple editing of pitch and time placement is provided here.!


!PianoRollNoteMorph methodsFor: 'initialization' stamp: 'di 6/17/1999 10:46'!
trackIndex: ti indexInTrack: i

	trackIndex _ ti.
	indexInTrack _ i.
	selected _ false! !


!PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:17'!
indexInTrack

	^ indexInTrack! !

!PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:16'!
trackIndex

	^ trackIndex! !


!PianoRollNoteMorph methodsFor: 'drawing' stamp: 'di 6/17/1999 10:56'!
drawOn: aCanvas

	selected
		ifTrue: [aCanvas frameAndFillRectangle: self fullBounds fillColor: color borderWidth: 1 borderColor: Color black]
		ifFalse: [aCanvas fillRectangle: self bounds color: color].
! !


!PianoRollNoteMorph methodsFor: 'geometry' stamp: 'di 6/17/1999 10:55'!
fullBounds

	selected
		ifTrue: [^ bounds expandBy: 1]
		ifFalse: [^ bounds]! !


!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/15/1999 14:55'!
handlesMouseDown: evt

	^ owner scorePlayer isPlaying not! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 10:26'!
mouseDown: evt

	hitLoc _ evt cursorPoint.
	editMode _ nil.
	owner submorphsDo:
		[:m | (m isKindOf: PianoRollNoteMorph) ifTrue: [m deselect]].
	selected _ true.
	self changed.
	owner selection: (Array with: trackIndex with: indexInTrack with: indexInTrack).
	self playSound! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/20/1999 12:37'!
mouseMove: evt

	| delta offsetEvt |
	editMode == nil ifTrue:
		["First movement determines edit mode"
		((delta _ evt cursorPoint - hitLoc) dist: 0@0) <= 2 ifTrue:
			[^ self  "No significant movement yet."].
		delta x abs > delta y abs
			ifTrue: [delta x > 0  "Horizontal drag"
						ifTrue: [editMode _ #selectNotes]
						ifFalse: [self playSound: nil.
								offsetEvt _ evt copy setCursorPoint: evt cursorPoint + (20@0).
								self invokeNoteMenu: offsetEvt]]
			ifFalse: [editMode _ #editPitch  "Vertical drag"]].
	editMode == #editPitch ifTrue: [self editPitch: evt].
	editMode == #selectNotes ifTrue: [self selectNotes: evt].

! !

!PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 08:29'!
mouseUp: evt

	self playSound: nil! !


!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/17/1999 11:48'!
noteInScore

	^ (owner score tracks at: trackIndex) at: indexInTrack
! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/17/1999 11:48'!
noteOfDuration: duration

	| note |
	note _ self noteInScore.
	^ (owner scorePlayer instrumentForTrack: trackIndex)
			soundForMidiKey: note midiKey
			dur: duration
			loudness: (note velocity asFloat / 127.0)
! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:19'!
playSound
	"This STARTS a single long sound.  It must be stopped by playing another or nil."

	^ self playSound: (self soundOfDuration: 999.0)! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:13'!
playSound: aSoundOrNil

	SoundPlaying ifNotNil: [SoundPlaying stopGracefully].
	SoundPlaying _ aSoundOrNil.
	SoundPlaying ifNotNil: [SoundPlaying play].! !

!PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:03'!
soundOfDuration: duration

	| sound |
	sound _ MixedSound new.
	sound add: (self noteOfDuration: duration)
		pan: (owner scorePlayer panForTrack: trackIndex)
		volume: owner scorePlayer overallVolume *
				(owner scorePlayer volumeForTrack: trackIndex).
	^ sound
! !


!PianoRollNoteMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:03'!
invokeNoteMenu: evt
	"Invoke the note's edit menu."

	| menu |
	menu _ MenuMorph new defaultTarget: self.
	menu addList:
		#(('grid to next quarter'		gridToNextQuarter)
		('grid to prev quarter'		gridToPrevQuarter)).

	menu popUpEvent: evt in: self world.
! !


!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:16'!
deselect

	selected ifFalse: [^ self].
	self changed.
	selected _ false.
! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:16'!
select

	selected ifTrue: [^ self].
	selected _ true.
	self changed! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:30'!
selectFrom: selection

	(trackIndex = (selection at: 1)
		and: [indexInTrack >= (selection at: 2)
		and: [indexInTrack <= (selection at: 3)]])
		ifTrue: [selected ifFalse: [self select]]
		ifFalse: [selected ifTrue: [self deselect]]! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/19/1999 10:24'!
selectNotes: evt

	| lastMorph oldEnd saveOwner |
	saveOwner _ owner.
	(owner autoScrollForX: evt cursorPoint x) ifTrue:
		["If scroll talkes place I will be deleted and my x-pos will become invalid."
		owner _ saveOwner.
		bounds _ bounds withLeft: (owner xForTime: self noteInScore time)].
	oldEnd _ owner selection last.
	(owner notesInRect: (evt cursorPoint x @ owner top corner: owner bottomRight))
		do: [:m | m trackIndex = trackIndex ifTrue: [m deselect]].
	self select.  lastMorph _ self.
	(owner notesInRect: (self left @ owner top corner: evt cursorPoint x @ owner bottom))
		do: [:m | m trackIndex = trackIndex ifTrue: [m select.  lastMorph _ m]].
	owner selection: (Array with: trackIndex with: indexInTrack with: lastMorph indexInTrack).
	lastMorph indexInTrack ~= oldEnd ifTrue:
		["Play last note as selection grows or shrinks"
		owner ifNotNil: [lastMorph playSound]]
! !

!PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/20/1999 11:44'!
selected

	^ selected! !


!PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/19/1999 08:14'!
editPitch: evt

	| mk note |
	mk _ owner midiKeyForY: evt cursorPoint y.
	note _ (owner score tracks at: trackIndex) at: indexInTrack.
	note midiKey = mk ifTrue: [^ self].
	note midiKey: mk.
	self playSound: (self soundOfDuration: 999.0).
	self position: self position x @ ((owner yForMidiKey: mk) - 1)
! !

!PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'!
gridToNextQuarter

	owner score gridTrack: trackIndex toQuarter: 1 at: indexInTrack.
	owner rebuildFromScore! !

!PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'!
gridToPrevQuarter

	owner score gridTrack: trackIndex toQuarter: -1 at: indexInTrack.
	owner rebuildFromScore! !

RectangleMorph subclass: #PianoRollScoreMorph
	instanceVariableNames: 'scorePlayer score colorForTrack lowestNote leftEdgeTime timeScale indexInTrack lastUpdateTick lastMutedState cursor selection timeSignature beatsPerMeasure notePerBeat showMeasureLines showBeatLines soundsPlaying soundsPlayingMorph movieClipPlayer '
	classVariableNames: 'NotePasteBuffer '
	poolDictionaries: ''
	category: 'Sound-Scores'!
!PianoRollScoreMorph commentStamp: '<historical>' prior: 0!
A PianoRollScoreMorph displays a score such as a MIDIScore, and will scroll through it tracking the porgress of a ScorePlayerMorph (from which it is usually spawned).

timeScale is in pixels per score tick.

Currently the ambient track (for synchronizing thumbnails, eg) is treated specially here and in the score.  This should be cleaned up by adding a trackType or something like it in the score.!


!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 15:10'!
initialize

	super initialize.
	borderWidth _ 1.
	color _ Color white.
	self extent: 400@300.
	showMeasureLines _ true.
	showBeatLines _ false.
	self timeSignature: 4 over: 4.
	self clipSubmorphs: true.! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'di 6/20/1999 00:53'!
on: aScorePlayer

	scorePlayer _ aScorePlayer.
	score _ aScorePlayer score.
	colorForTrack _ Color wheel: score tracks size.
	leftEdgeTime _ 0.
	timeScale _ 0.1.
	indexInTrack _ Array new: score tracks size withAll: 1.
	lastUpdateTick _ -1.

	self updateLowestNote
! !

!PianoRollScoreMorph methodsFor: 'initialization' stamp: 'di 6/20/1999 12:25'!
updateLowestNote
	"find the actual lowest note in the score"

	| n |
	lowestNote _ 128 - (self innerBounds height // 3).
	score tracks do: [:track |
		1 to: track size do: [:i |
			n _ track at: i.
			(n isNoteEvent and: [n midiKey < lowestNote])
				ifTrue: [lowestNote _ n midiKey - 4]]].
! !


!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'!
beatsPerMeasure: n

	^ self timeSignature: n over: notePerBeat! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 10/19/2000 10:07'!
movieClipPlayer

	^ movieClipPlayer! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 10/21/2000 22:06'!
movieClipPlayer: moviePlayer

	movieClipPlayer _ moviePlayer
! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'!
notePerBeat: n

	^ self timeSignature: beatsPerMeasure over: n! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 15:46'!
score

	^ score! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 14:52'!
scorePlayer

	^ scorePlayer! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 01:00'!
selection
	"Returns an array of 3 elements:
		trackIndex
		indexInTrack of first note
		indexInTrack of last note"

	| trackIndex track |
	selection ifNil:  "If no selection, return last event of 1st non-muted track (or nil)"
		[trackIndex _ (1 to: score tracks size)
			detect: [:i | (scorePlayer mutedForTrack: i) not] ifNone: [^ nil].
		track _ score tracks at: trackIndex.
		^ Array with: trackIndex with: track size with: track size].
	(scorePlayer mutedForTrack: selection first)
		ifTrue: [selection _ nil.  ^ self selection].
	^ selection! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:38'!
selection: anArray

	selection _ anArray! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 10/19/2000 21:19'!
timeScale

	^ timeScale  "in pixels per tick"! !

!PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 20:48'!
timeSignature: num over: denom

	beatsPerMeasure _ num.
	notePerBeat _ denom.  "a number like 2, 4, 8"
	self changed! !


!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 10/25/2000 22:27'!
addNotes
	"Recompute the set of morphs that should be visible at the current scroll position."

	| visibleMorphs rightEdge topEdge trackColor i done n nLeft nTop nRight rightEdgeTime |
	visibleMorphs _ OrderedCollection new: 500.
	rightEdge _ self right - borderWidth.
	rightEdgeTime _ self timeForX: rightEdge.
	topEdge _ self top + borderWidth + 1.

	"Add ambient morphs first (they will be front-most)"
	score eventMorphsWithTimeDo:
		[:m :t | m addMorphsTo: visibleMorphs pianoRoll: self eventTime: t
					betweenTime: leftEdgeTime and: rightEdgeTime].

	"Then add note morphs"
	score tracks withIndexDo:
		[:track :trackIndex |
		trackColor _ colorForTrack at: trackIndex.
		i _ indexInTrack at: trackIndex.
		done _ scorePlayer mutedForTrack: trackIndex.
		[done | (i > track size)] whileFalse: [
			n _ track at: i.
			(n isNoteEvent and: [n midiKey >= lowestNote]) ifTrue: [
				n time > rightEdgeTime
					ifTrue: [done _ true]
					ifFalse: [
						nLeft _ self xForTime: n time.
						nTop _ (self yForMidiKey: n midiKey) - 1.
						nTop > topEdge ifTrue: [
							nRight _ nLeft + (n duration * timeScale) truncated - 1.
							visibleMorphs add:
								((PianoRollNoteMorph
									newBounds: (nLeft@nTop corner: nRight@(nTop + 3))
									color: trackColor)
									trackIndex: trackIndex indexInTrack: i)]]].
			i _ i + 1].
			(selection notNil
				and: [trackIndex = selection first
				and: [i >= selection second and: [(indexInTrack at: trackIndex) <= selection third]]])
				ifTrue: [visibleMorphs do:
						[:vm | (vm isKindOf: PianoRollNoteMorph) ifTrue: [vm selectFrom: selection]]]].

	"Add the cursor morph in front of all notes; height and position are set later."
	cursor ifNil: [cursor _ Morph newBounds: (self topLeft extent: 1@1) color: Color red].
	visibleMorphs addFirst: cursor.

	self changed.
	self removeAllMorphs.
	self addAllMorphs: visibleMorphs.
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 10/24/2000 16:17'!
drawMeasureLinesOn: aCanvas

	| ticksPerMeas x measureLineColor inner |
	showBeatLines ifNil: [showBeatLines _ false].
	showMeasureLines ifNil: [showMeasureLines _ true].
	notePerBeat ifNil: [self timeSignature: 4 over: 4].
	showBeatLines ifTrue:
		[measureLineColor _ Color gray: 0.8.
		ticksPerMeas _ score ticksPerQuarterNote.
		inner _ self innerBounds.
		(leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas)
			to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas)
			by: ticksPerMeas
			do: [:tickTime | x _ self xForTime: tickTime.
				aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height)
					color: measureLineColor]].

	showMeasureLines ifTrue:
		[measureLineColor _ Color gray: 0.7.
		ticksPerMeas _ beatsPerMeasure*score ticksPerQuarterNote*4//notePerBeat.
		inner _ self innerBounds.
		(leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas)
			to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas)
			by: ticksPerMeas
			do: [:tickTime | x _ self xForTime: tickTime.
				aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height)
						color: (tickTime = 0 ifTrue: [Color black] ifFalse: [measureLineColor])]].
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'jm 5/30/1999 17:56'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self drawStaffOn: aCanvas.
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 12:24'!
drawStaffOn: aCanvas

	| blackKeyColor l r topEdge y |
	self drawMeasureLinesOn: aCanvas.

	blackKeyColor _ Color gray: 0.5.
	l _ self left + borderWidth.
	r _ self right - borderWidth.
	topEdge _ self top + borderWidth + 3.
	lowestNote to: 127 do: [:k |
		y _ self yForMidiKey: k.
		y <= topEdge ifTrue: [^ self].  "over the top!!"
		(self isBlackKey: k) ifTrue: [
			aCanvas
				fillRectangle: (l@y corner: r@(y + 1))
				color: blackKeyColor]].
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'jm 6/1/1998 07:52'!
isBlackKey: midiKey
	"Answer true if the given MIDI key corresponds to a black key on the piano keyboard."

	| note |
	note _ midiKey \\ 12.
	note = 1 ifTrue: [^ true].
	note = 3 ifTrue: [^ true].
	note = 6 ifTrue: [^ true].
	note = 8 ifTrue: [^ true].
	note = 10 ifTrue: [^ true].
	^ false
! !

!PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 12:23'!
rebuildFromScore
	"Rebuild my submorphs from the score. This method should be invoked after changing the time scale, the color or visibility of a track, the extent of this morph, etc."

	score ifNil: [^ self].
	self addNotes.
! !


!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 5/30/1999 17:28'!
contractTime

	timeScale _ timeScale / 1.5.
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 5/30/1999 17:29'!
expandTime

	timeScale _ timeScale * 1.5.
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/20/1999 15:25'!
extent: aPoint
	"Force rebuild when re-sized."

	super extent: aPoint. 
	score ifNotNil: [self updateLowestNote].
	self rebuildFromScore.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 9/11/1998 09:33'!
fullBounds
	"Overridden to clip submorph hit detection to my bounds."

	fullBounds ifNil: [fullBounds _ bounds].
	^ bounds
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 9/11/1998 09:20'!
layoutChanged
	"Override this to avoid propagating 'layoutChanged' when just adding/removing note objects."

	fullBounds = bounds ifTrue: [^ self].
	super layoutChanged.
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/15/1999 14:48'!
midiKeyForY: y

	^ lowestNote - ((y - (bounds bottom - borderWidth - 4)) // 3)
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 10/12/2000 00:40'!
tickTimeAtCursor
	cursor ifNil: [^ 0].
	^ self timeForX: cursor left! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:35'!
timeForX: aNumber

	^ ((aNumber - bounds left - borderWidth) asFloat / timeScale + leftEdgeTime) asInteger! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:29'!
xForTime: aNumber

	^ ((aNumber - leftEdgeTime) asFloat * timeScale) asInteger + bounds left + borderWidth
! !

!PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 7/10/1998 14:35'!
yForMidiKey: midiKey

	^ (bounds bottom - borderWidth - 4) - (3 * (midiKey - lowestNote))
! !


!PianoRollScoreMorph methodsFor: 'submorphs-add/remove' stamp: 'di 10/23/2000 16:24'!
privateRemoveMorph: aMorph
	| trackSize |
	trackSize _ score ambientTrack size.
	score removeAmbientEventWithMorph: aMorph.
	trackSize = score ambientTrack size ifFalse:
		["Update duration if we removed an event".
		scorePlayer updateDuration].
	^ super privateRemoveMorph: aMorph! !


!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/17/1999 12:40'!
handlesMouseDown: evt

	^ true! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 09:02'!
mouseDown: evt

	| noteMorphs chordRect sound |
	(self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 2@30)) isEmpty
		ifTrue: ["If not near a note, then put up score edit menu"
				^ self invokeScoreMenu: evt].

	"Clicked near (but not on) a note, so play all notes at the cursor time"
	noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height).
	chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1.
	soundsPlayingMorph _ Morph newBounds: chordRect color: Color green.
	self addMorphBack: soundsPlayingMorph.
	
	soundsPlaying _ IdentityDictionary new.
	noteMorphs do:
		[:m | sound _ m soundOfDuration: 999.0.
		soundsPlaying at: m put: sound.
		sound play].

! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 09:02'!
mouseMove: evt

	| noteMorphs chordRect sound |
	soundsPlaying ifNil: [^ self].
	self autoScrollForX: evt cursorPoint x.

	"Play all notes at the cursor time"
	noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height).
	chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1.
	soundsPlayingMorph delete.
	soundsPlayingMorph _ Morph newBounds: chordRect color: Color green.
	self addMorphBack: soundsPlayingMorph.
	
	noteMorphs do:
		[:m |  "Add any new sounds"
		(soundsPlaying includesKey: m)
			ifFalse: [sound _ m soundOfDuration: 999.0.
					soundsPlaying at: m put: sound.
					sound play]].
	soundsPlaying keys do:
		[:m |  "Remove any sounds no longer in selection."
		(noteMorphs includes: m)
			ifFalse: [(soundsPlaying at: m) stopGracefully.
					soundsPlaying removeKey: m]].

! !

!PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/18/1999 08:37'!
mouseUp: evt

	soundsPlayingMorph ifNotNil: [soundsPlayingMorph delete].
	soundsPlaying ifNotNil: [soundsPlaying do: [:s | s stopGracefully]].
	soundsPlayingMorph _ soundsPlaying _ nil
! !


!PianoRollScoreMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 12/11/2000 23:00'!
acceptDroppingMorph: aMorph event: evt
	"In addition to placing this morph in the pianoRoll, add a corresponding
	event to the score so that it will always appear when played, in addition
	to possibly triggering other actions"

	aMorph justDroppedIntoPianoRoll: self event: evt.
	super acceptDroppingMorph: aMorph event: evt.

! !


!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 10/4/2000 16:16'!
addCustomMenuItems: aMenu hand: aHandMorph

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu add: 'expand time' action: #expandTime.
	aMenu add: 'contract time' action: #contractTime.
	aMenu addLine.
	aMenu add: 'add movie clip player' action: #addMovieClipPlayer.
	(self valueOfProperty: #dragNDropEnabled) == true
		ifTrue: [aMenu add: 'close drag and drop' action: #disableDragNDrop]
		ifFalse: [aMenu add: 'open drag and drop' action: #enableDragNDrop].
! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/18/1999 15:55'!
addKeyboard

	(KeyboardMorphForInput new pianoRoll: self) openInWorld! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 10/4/2000 16:40'!
addMovieClipPlayer

	movieClipPlayer _ MoviePlayerMorph new.
	movieClipPlayer pianoRoll: self.  "back link"
	self activeHand attachMorph: movieClipPlayer! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/18/1999 16:04'!
beatLinesOnOff

	showBeatLines _ showBeatLines not.
	self changed! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:03'!
invokeScoreMenu: evt
	"Invoke the score's edit menu."

	| menu subMenu |
	menu _ MenuMorph new defaultTarget: self.
	menu addList:
		#(('cut'		cutSelection)
		('copy'		copySelection)
		('paste'		insertSelection)
		('paste...'	insertTransposed)).
	menu addLine.
	menu addList:
		#(('legato'		selectionBeLegato)
		('staccato'		selectionBeStaccato)
		('normal'		selectionBeNormal)).
	menu addLine.
	menu addList:
		#(('expand time'		expandTime)
		('contract time'		contractTime)).
	menu addLine.
	subMenu _ MenuMorph new defaultTarget: self.
		(2 to: 12) do: [:i | subMenu add: i printString selector: #beatsPerMeasure: argument: i].
		menu add: 'time   ', beatsPerMeasure printString subMenu: subMenu.
	subMenu _ MenuMorph new defaultTarget: self.
		#(2 4 8) do: [:i | subMenu add: i printString selector: #notePerBeat: argument: i].
		menu add: 'sig     ', notePerBeat printString subMenu: subMenu.
	menu addLine.
	showMeasureLines
		ifTrue: [menu add: 'hide measure lines' action: #measureLinesOnOff]
		ifFalse: [menu add: 'show measure lines' action: #measureLinesOnOff].
	showBeatLines
		ifTrue: [menu add: 'hide beat lines' action: #beatLinesOnOff]
		ifFalse: [menu add: 'show beat lines' action: #beatLinesOnOff].

	menu addLine.
	menu add: 'add keyboard' action: #addKeyboard.

	menu popUpEvent: evt in: self world.
! !

!PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/17/1999 22:10'!
measureLinesOnOff

	showMeasureLines _ showMeasureLines not.
	self changed! !


!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 23:16'!
appendEvent: noteEvent fullDuration: fullDuration 

	| sel x |
	score appendEvent: noteEvent fullDuration: fullDuration at: (sel _ self selection).
	noteEvent midiKey = -1 ifFalse:  "Unless it is a rest..."
		["Advance the selection to the note just entered"
		selection _ Array with: sel first with: sel third + 1 with: sel third + 1].

	"This is all horribly inefficient..."
	scorePlayer updateDuration.
	(x _ self xForTime: noteEvent endTime) > (self right - 30) ifTrue:
		[self autoScrollForX: x + (30 + self width // 4)].
	self updateLowestNote.
	self rebuildFromScore! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/17/1999 12:58'!
copySelection

	selection == nil ifTrue: [^ self].
	NotePasteBuffer _ (score tracks at: selection first)
		copyFrom: selection second to: selection third! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 00:25'!
cutSelection

	selection == nil ifTrue: [^ self].
	self copySelection.
	self deleteSelection! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 23:15'!
deleteSelection

	| selMorphs priorEvent x |
	(selection == nil or: [selection second = 0]) ifTrue: [^ self].
	score cutSelection: selection.
	selection second > 1
		ifTrue: [selection at: 2 put: selection second - 1.
				selection at: 3 put: selection second.
				priorEvent _ (score tracks at: selection first) at: selection second.
				(x _ self xForTime: priorEvent time) < (self left + 30) ifTrue:
					[self autoScrollForX: x - (30 + self width // 4)]]
		ifFalse: [selection _ nil].
	scorePlayer updateDuration.
	self rebuildFromScore.
	selMorphs _ self submorphsSatisfying:
						[:m | (m isKindOf: PianoRollNoteMorph) and: [m selected]].
	selMorphs isEmpty ifFalse: [(selMorphs last noteOfDuration: 0.3) play]! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/21/1999 10:49'!
insertSelection

	self selection == nil ifTrue: [^ self].
	score insertEvents: NotePasteBuffer at: self selection.
	scorePlayer updateDuration.
	self rebuildFromScore ! !

!PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 23:37'!
insertTransposed

	| delta transposedNotes |
	(delta _ (SelectionMenu selections: ((12 to: -12 by: -1) collect: [:i | i printString]))
			startUpWithCaption: 'offset...') ifNil: [^ self].
	transposedNotes _ NotePasteBuffer collect: [:note | note copy midiKey: note midiKey + delta].
	selection == nil ifTrue: [^ self].
	score insertEvents: transposedNotes at: self selection.
	scorePlayer updateDuration.
	self rebuildFromScore! !


!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/19/1999 10:56'!
autoScrollForX: x
	"Scroll by the amount x lies outside of my innerBounds.  Return true if this happens."

	| d ticks |
	((d _ x - self innerBounds right) > 0
		or: [(d _ x - self innerBounds left) < 0])
		ifTrue: [ticks _ (self timeForX: self bounds center x + d+1)
						min: score durationInTicks max: 0.
				self moveCursorToTime: ticks.
				scorePlayer ticksSinceStart: ticks.
				^ true].
	^ false
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/19/1999 09:30'!
goToTime: scoreTime

	| track trackSize index newLeftEdgeTime |
	newLeftEdgeTime _ scoreTime asInteger.
	newLeftEdgeTime < leftEdgeTime
		ifTrue: [indexInTrack _ Array new: score tracks size+1 withAll: 1].
	leftEdgeTime _ newLeftEdgeTime.
	1 to: score tracks size do: [:trackIndex |
		track _ score tracks at: trackIndex.
		index _ indexInTrack at: trackIndex.
		trackSize _ track size.
		[(index < trackSize) and:
		 [(track at: index) endTime < leftEdgeTime]]
			whileTrue: [index _ index + 1].
		indexInTrack at: trackIndex put: index].
	self addNotes.
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 10/24/2000 16:14'!
moveCursorToTime: scoreTime

	| cursorOffset desiredCursorHeight |
	scorePlayer isPlaying
		ifTrue:
			[cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger.
			(cursorOffset < 0
				or: [cursorOffset > (self width-20)])
				ifTrue:
				[self goToTime: scoreTime - (20/timeScale).
				cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger]]
		ifFalse:
			[self goToTime: (scoreTime - (self width//2 / timeScale)
							max: (self width//10 / timeScale) negated).
			cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger].

	cursor position: (self left + borderWidth + cursorOffset)@(self top + borderWidth).
	desiredCursorHeight _ self height.
	cursor height ~= desiredCursorHeight ifTrue: [cursor extent: 1@desiredCursorHeight].
! !

!PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/17/1999 09:36'!
notesInRect: timeSlice

	^ self submorphsSatisfying:
		[:m | (timeSlice intersects: m bounds)
				and: [m isKindOf: PianoRollNoteMorph]]! !


!PianoRollScoreMorph methodsFor: 'stepping' stamp: 'jm 5/30/1999 18:01'!
step

	| t |
	score ifNil: [^ self].

	lastMutedState ~= scorePlayer mutedState ifTrue: [
		self rebuildFromScore.
		lastMutedState _ scorePlayer mutedState copy].

	t _ scorePlayer ticksSinceStart.
	t = lastUpdateTick ifFalse: [
		self moveCursorToTime: t.
		lastUpdateTick _ t].
! !

!PianoRollScoreMorph methodsFor: 'stepping' stamp: 'jm 6/1/1998 09:07'!
stepTime

	^ 0
! !
Notification subclass: #PickAFileToWriteNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
ImageMorph subclass: #PinMorph
	instanceVariableNames: 'component pinForm pinSpec wires '
	classVariableNames: 'InputPinForm IoPinForm OutputPinForm '
	poolDictionaries: ''
	category: 'Morphic-Components'!

!PinMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 09:13'!
component: aComponent pinSpec: spec
	component _ aComponent.
	pinSpec _ spec.
	pinSpec isInput ifTrue: [pinForm _ InputPinForm].
	pinSpec isOutput ifTrue: [pinForm _ OutputPinForm].
	pinSpec isInputOutput ifTrue: [pinForm _ IoPinForm].
	self image: pinForm! !

!PinMorph methodsFor: 'initialization' stamp: 'di 5/2/1998 15:37'!
delete
	self unwire.
	^ super delete! !

!PinMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 09:13'!
initialize
	super initialize.
	wires _ OrderedCollection new! !


!PinMorph methodsFor: 'accessing' stamp: 'di 5/1/1998 15:51'!
pinSpec
	^ pinSpec! !


!PinMorph methodsFor: 'geometry' stamp: 'di 1/18/2000 12:31'!
placeFromSpec
	| side corners c1 c2 |
	side _ pinSpec pinLoc asInteger.  "1..4 ccw from left"
	corners _ owner bounds corners.
	c1 _ corners at: side.
	c2 _ corners atWrap: side+1.
	self position: (c1 + (c2 - c1 * pinSpec pinLoc fractionPart)).
	self updateImage.! !

!PinMorph methodsFor: 'geometry' stamp: 'di 1/18/2000 12:28'!
position: p
	| r side p1 corners c1 c2 sideIndex |
	"Adhere to owner bounds, and apply gridding"
	r _ owner bounds.
	side _ r sideNearestTo: p.
	p1 _ r pointNearestTo: p.  "a point on the border"
	(side = # top or: [side = #left])
		ifTrue: [p1 _ r topLeft + (p1 - r topLeft grid: 4@4)]
		ifFalse: [p1 _ r bottomRight + (p1 - r bottomRight grid: 4@4)].

	"Update pin spec(5) = side index + fraction along side"
	corners _ r corners.
	sideIndex _ #(left bottom right top) indexOf: side.
	c1 _ corners at: sideIndex.
	c2 _ corners atWrap: sideIndex+1.
	pinSpec pinLoc: sideIndex + ((p1 dist: c1) / (c2 dist: c1) min: 0.99999).

	"Set new position with appropriate offset."
	side = #top ifTrue: [super position: p1 - (0@8)].
	side = #left ifTrue: [super position: p1 - (8@0)].
	side = #bottom ifTrue: [super position: p1].
	side = #right ifTrue: [super position: p1].

	wires do: [:w | w pinMoved]! !

!PinMorph methodsFor: 'geometry' stamp: 'di 5/6/1998 14:22'!
privateMoveBy: delta
	super privateMoveBy: delta.
! !

!PinMorph methodsFor: 'geometry' stamp: 'di 5/4/1998 09:10'!
updateImage
	"pinForm was made for right side.  Rotate/flip for other sides"

	bounds left < owner bounds left ifTrue:  "left side"
		[^ self image: (pinForm flipBy: #horizontal centerAt: 0@0)].
	bounds bottom > owner bounds bottom ifTrue:  "bottom"
		[^ self image: ((pinForm rotateBy: #left centerAt: 0@0)
								flipBy: #vertical centerAt: 0@0)].
	bounds right > owner bounds right ifTrue:  "right side"
		[^ self image: pinForm].
	bounds top < owner bounds top ifTrue:  "top"
		[^ self image: (pinForm rotateBy: #left centerAt: 0@0)].
self halt: 'uncaught pin geometry case'! !

!PinMorph methodsFor: 'geometry' stamp: 'di 4/30/1998 12:12'!
wiringEndPoint
	| side |
	side _ owner bounds sideNearestTo: bounds center.
	side = #left ifTrue: [^ self position + (0@4)].
	side = #bottom ifTrue: [^ self position + (4@7)].
	side = #right ifTrue: [^ self position + (7@4)].
	side = #top ifTrue: [^ self position + (4@0)]! !


!PinMorph methodsFor: 'events' stamp: 'jm 5/29/1998 14:33'!
handlesMouseDown: evt

	^ (evt yellowButtonPressed | evt blueButtonPressed) not
! !

!PinMorph methodsFor: 'events' stamp: 'di 4/30/1998 22:34'!
mouseDown: event
	"Unshifted action is to move the pin (see mouseMove:)"
	event shiftPressed ifTrue: [self startWiring: event].
! !

!PinMorph methodsFor: 'events' stamp: 'di 4/30/1998 12:30'!
mouseMove: evt
	evt shiftPressed ifTrue: [^ self].
	self position: evt targetPoint.
	self updateImage! !


!PinMorph methodsFor: 'wires' stamp: 'di 4/30/1998 13:25'!
addWire: aWireMorph
	wires add: aWireMorph! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/1/1998 22:25'!
canDockWith: otherPin
	"Later include data type compatibility and circularity as well"
	(pinSpec isInputOnly and: [otherPin pinSpec isInputOnly]) ifTrue: [^ false].
	(pinSpec isOutputOnly and: [otherPin pinSpec isOutputOnly]) ifTrue: [^ false].
	^ true! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/2/1998 17:23'!
connectedPins
	^ wires collect: [:w | w otherPinFrom: self]! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/2/1998 17:24'!
isIsolated
	^ wires isEmpty! !

!PinMorph methodsFor: 'wires' stamp: 'di 4/30/1998 13:25'!
removeWire: aWireMorph
	wires remove: aWireMorph! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/6/1998 14:12'!
startWiring: event
	"Start wiring from this pin"
	| origin handle candidates candidate wiringColor wire |
	origin _ self wiringEndPoint.
	candidates _ OrderedCollection new.
	"Later this could be much faster if we define pinMorphsDo:
		so that it doesn't go too deep and bypasses non-widgets."
	self pasteUpMorph allMorphsDo:
		[:m | ((m isMemberOf: PinMorph) and: [m canDockWith: self])
				 ifTrue: [candidates add: m]].
	handle _ NewHandleMorph new followHand: event hand
		forEachPointDo:
			[:newPoint |
			candidate _ candidates detect: [:m | m containsPoint: newPoint] ifNone: [nil].
			wiringColor _ candidate == nil ifTrue: [Color black] ifFalse: [Color red].
			handle removeAllMorphs;
				 addMorph: (PolygonMorph vertices: (Array with: origin with: newPoint)
						color: Color black borderWidth: 1 borderColor: wiringColor)]
		lastPointDo:
			[:lastPoint | (self wireTo: candidate) ifTrue:
				[wire _ (WireMorph vertices: (Array with: origin with: lastPoint)
						color: Color black borderWidth: 1 borderColor: Color black)
						fromPin: self toPin: candidate.
				self pasteUpMorph addMorph: wire.
				self addWire: wire.
				candidate addWire: wire]].
	event hand world addMorph: handle.
	handle startStepping! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/4/1998 00:15'!
unwire
	"Remove wires one by one.  Not fastest, but by far simplest"

	wires do: [:w | w delete].  "This is where all the work is done"! !

!PinMorph methodsFor: 'wires' stamp: 'di 5/3/1998 23:55'!
wireTo: otherPin
	"Note must return true or false indicating success"
	(otherPin == nil or: [otherPin == self]) ifTrue: [^ false].
	self hasVariable
	ifTrue: [otherPin hasVariable
			ifTrue: [self mergeVariableWith: otherPin]
			ifFalse: [otherPin shareVariableOf: self]]
	ifFalse: [otherPin hasVariable
			ifTrue: [self shareVariableOf: otherPin]
			ifFalse: [self addModelVariable.
					otherPin shareVariableOf: self]].
	component model changed: pinSpec modelReadSelector.
	^ true! !


!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:11'!
addModelVariable
	| accessors |
	accessors _ component model addVariableNamed: component knownName , pinSpec pinName.
	pinSpec modelReadSelector: accessors first modelWriteSelector: accessors second.
	component initFromPinSpecs.
	self connectedPins do: [:connectee | connectee shareVariableOf: self]! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/1/1998 13:21'!
hasVariable
	^ pinSpec hasVariable! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:01'!
mergeVariableWith: otherPin
	"Change all pins with otherPin's selectors to these selectors,
	and then remove the slot and accessors for the old selectors"
	self removeModelVariable.
	self connectedPins do:
		[:connectee | connectee shareVariableOf: otherPin].
	self shareVariableOf: otherPin! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/3/1998 23:58'!
removeModelVariable
	component model removeVariableNamed: pinSpec variableName.
	self removeVariableAccess! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/4/1998 00:18'!
removeVariableAccess
	pinSpec modelReadSelector: nil modelWriteSelector: nil.
	component initFromPinSpecs! !

!PinMorph methodsFor: 'variables' stamp: 'di 5/2/1998 15:55'!
shareVariableOf: otherPin
	pinSpec modelReadSelector: otherPin pinSpec modelReadSelector
			modelWriteSelector: otherPin pinSpec modelWriteSelector.
	component initFromPinSpecs! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PinMorph class
	instanceVariableNames: ''!

!PinMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 10:09'!
includeInNewMorphMenu
	^ false! !

!PinMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/28/1998 10:58'!
initialize  "PinMorph initialize"
	OutputPinForm _ Form extent: 8@8 depth: 1 fromArray:
			#( 0 3221225472 4026531840 4227858432 4278190080 4227858432 4026531840 3221225472)
		offset: 0@0.

	IoPinForm _ Form extent: 8@8 depth: 1 fromArray:
			#( 0 402653184 1006632960 2113929216 4278190080 2113929216 1006632960 402653184)
		offset: 0@0.

	InputPinForm _ OutputPinForm flipBy: #horizontal centerAt: 0@0.
! !
Object subclass: #PinSpec
	instanceVariableNames: 'pinName direction localReadSelector localWriteSelector modelReadSelector modelWriteSelector defaultValue pinLoc '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!PinSpec methodsFor: 'initialization' stamp: 'di 5/1/1998 13:38'!
pinName: a direction: b localReadSelector: c localWriteSelector: d modelReadSelector: e modelWriteSelector: f defaultValue: g pinLoc: h
	pinName _ a.
	direction _ b.
	localReadSelector _ c.
	localWriteSelector _ d.
	modelReadSelector _ e.
	modelWriteSelector _ f.
	defaultValue _ g.
	pinLoc _ h! !


!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
defaultValue
	^ defaultValue! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:38'!
isInput
	direction = #input ifTrue: [^ true].
	direction = #inputOutput ifTrue: [^ true].
	direction = #ioAsInput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 22:25'!
isInputOnly
	direction = #input ifTrue: [^ true].
	direction = #ioAsInput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:42'!
isInputOutput
	^ direction = #inputOutput! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 16:39'!
isOutput
	direction = #output ifTrue: [^ true].
	direction = #inputOutput ifTrue: [^ true].
	direction = #ioAsOutput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 22:26'!
isOutputOnly
	direction = #output ifTrue: [^ true].
	direction = #ioAsOutput ifTrue: [^ true].
	^ false! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:58'!
localReadSelector
	^ localReadSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:58'!
localWriteSelector
	^ localWriteSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
modelReadSelector
	^ modelReadSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 13:36'!
modelReadSelector: a modelWriteSelector: b
	modelReadSelector _ a.
	modelWriteSelector _ b! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 09:59'!
modelWriteSelector
	^ modelWriteSelector! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 10:00'!
pinLoc
	^ pinLoc! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 10:14'!
pinLoc: x
	pinLoc _ x! !

!PinSpec methodsFor: 'accessing' stamp: 'di 5/1/1998 13:39'!
pinName
	^ pinName! !


!PinSpec methodsFor: 'variables' stamp: 'di 5/1/1998 13:26'!
hasVariable
	^ modelReadSelector ~~ nil or: [modelWriteSelector ~~ nil]! !

!PinSpec methodsFor: 'variables' stamp: 'di 5/2/1998 15:47'!
variableName
	^ modelReadSelector! !
AbstractScoreEvent subclass: #PitchBendEvent
	instanceVariableNames: 'bend channel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
bend

	^ bend
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'!
bend: midiPitchBend

	bend _ midiPitchBend.
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'!
bend: midiPitchBend channel: midiChannel

	bend _ midiPitchBend.
	channel _ midiChannel.
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel: midiChannel

	channel _ midiChannel.
! !


!PitchBendEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'!
isPitchBend

	^ true
! !


!PitchBendEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rE0
		channel: channel
		byte: (bend bitAnd: 16r7F)
		byte: (bend bitShift: -7).
! !


!PitchBendEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 09:42'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': bend '.
	bend printOn: aStream.
	aStream nextPut: $).
! !
Envelope subclass: #PitchEnvelope
	instanceVariableNames: 'centerPitch '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 1/31/98 14:46'!
centerPitch

	^ centerPitch
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 1/31/98 14:49'!
centerPitch: aNumber

	centerPitch _ aNumber.
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:30'!
updateSelector
	"Needed by the envelope editor."

	^ #pitch:
! !

!PitchEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 21:11'!
updateTargetAt: mSecs
	"Update the pitch for my target. Answer true if the value changed."
	"Details: Assume envelope range is 0.0..2.0, with 1 being the center pitch. Subtracting one yields the range -1.0..1.0. Raising two to this power yields pitches between half and double the center pitch; i.e. from an octave below to an octave about the center pitch."

	| newValue |
	newValue _ self valueAtMSecs: mSecs.
	newValue ~= lastValue ifTrue: [
		target pitch: (2.0 raisedTo: newValue - (scale / 2.0)) * centerPitch.
		lastValue _ newValue.
		^ true].

	^ false
! !
ArrayedCollection variableWordSubclass: #Pixmap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-FXBlt'!
!Pixmap commentStamp: '<historical>' prior: 0!
A Pixmap is like a Bitmap. The only difference is that it stores the pixels in reverse order. Where a Bitmap stores the left most pixel in the most significant bits of a word, a Pixmap stores its left most pixel in the least significant bits. That's all.

Why do we need Pixmaps?!! They optimize certain drawing routines if it is known that the host OS is itself in Pixmap format. Copy-and-reverse operations of bits (which are supported by FXBlt) are much more expensive than simple copy operations where the bits are already in the same order. !

MorphicModel subclass: #PlayWithMe1
	instanceVariableNames: 'slider1 valuePrinter scrollBar1 listPane1 listPane2 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!

!PlayWithMe1 methodsFor: 'public access'!
slider1Value: x
	valuePrinter contents: x printString.
	scrollBar1 value: x! !


!PlayWithMe1 methodsFor: 'input events'!
listPane1MenuButtonPressed: arg1
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
listPane1NewSelection: t1 
	valuePrinter
		contents: (t1 = 0
				ifTrue: ['-']
				ifFalse: [(listPane1 instVarNamed: 'list')
						at: t1]).
	listPane1 selectionIndex: t1.
	listPane2 selectionIndex: t1! !

!PlayWithMe1 methodsFor: 'input events'!
listPane2MenuButtonPressed: arg1
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
listPane2NewSelection: t1 
	valuePrinter
		contents: (t1 = 0
				ifTrue: ['-']
				ifFalse: [(listPane2 instVarNamed: 'list')
						at: t1]).
	listPane2 selectionIndex: t1.
	listPane1 selectionIndex: t1! !

!PlayWithMe1 methodsFor: 'input events'!
scrollBar1MenuButtonPressed: arg1
	self confirm: 'Do you like menu buttons?'! !

!PlayWithMe1 methodsFor: 'input events'!
scrollBar1Value: arg1
	valuePrinter contents: arg1 printString.
	slider1 value: arg1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayWithMe1 class
	instanceVariableNames: ''!

!PlayWithMe1 class methodsFor: 'as yet unclassified' stamp: 'di 6/22/97 09:14'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
MorphicModel subclass: #PlayWithMe2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!
MorphicModel subclass: #PlayWithMe3
	instanceVariableNames: 'slantedList1 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Models'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayWithMe3 class
	instanceVariableNames: ''!

!PlayWithMe3 class methodsFor: 'as yet unclassified' stamp: 'di 6/22/97 09:14'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Model subclass: #Player
	instanceVariableNames: 'costume costumes '
	classVariableNames: 'BiggestSubclassNumber TimeOfError '
	poolDictionaries: 'References '
	category: 'Morphic-Scripting'!
!Player commentStamp: '<historical>' prior: 0!
The fundamental user-scriptable entity.  Always represented by a user-specific subclass of Player; instance vars and methods relate to user-defined structures.

costume  is a Morph, the primary morph I am currently wearing for graphical display.

Scripts are defined in subclasses of Player.  These are UniClasses.

Messages in scripts are sent to Players.  A Player may delegate to its costume, or to an object the costume suggests.  Or, a Player may designate some other object to receive the script messages it does not understand. (see doesNotUnderstand:) !


!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:07'!
deleteCard
	"Tell the receiver's stack to delete the current card"

	self costume stackDo: [:aStack | aStack deleteCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
firstPage
	self sendMessageToCostume: #firstPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/30/2000 07:12'!
getRoundedCorners
	"Anwer the rounded-corners attribute of my costume"

	^ costume renderedMorph cornerStyle == #rounded! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:12'!
goToCard: aCard
	"Install aCard as the new current card of the stack"

	self stackDo: [:aStack | aStack goToCard: aCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:19'!
goToFirstCardInBackground
	"Send the stack to the first card of the current background"

	costume stackDo: [:aStack | aStack goToFirstCardInBackground]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:19'!
goToFirstCardOfStack
	"Send the stack to the first card of the entire stack"

	costume stackDo: [:aStack | aStack goToFirstCardOfStack]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:17'!
goToLastCardInBackground
	"Send the stack to the final card of the current background"

	costume stackDo: [:aStack | aStack goToLastCardInBackground]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:20'!
goToLastCardOfStack
	"Send the stack to the last card of the entire stack"

	costume stackDo: [:aStack | aStack goToLastCardOfStack]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 14:54'!
goToNextCardInStack
	"Install the next card into the receiver's stack"

	self costume goToNextCardInStack! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:13'!
goToPreviousCardInStack
	"Install the previous card into the receiver's stack"

	self costume goToPreviousCardInStack! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
goto: aPlayer
	self sendMessageToCostume: #goto: with: aPlayer! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/23/2000 16:14'!
insertCard
	"Insert a new card into the stack"

	self costume stackDo: [:aStack | aStack insertCard]! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:56'!
lastPage
	self sendMessageToCostume: #lastPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:55'!
nextPage
	self sendMessageToCostume: #nextPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/26/1998 15:55'!
previousPage
	self sendMessageToCostume: #previousPage! !

!Player methodsFor: 'card/stack commands' stamp: 'sw 10/30/2000 08:34'!
setRoundedCorners: aBoolean
	"Set the rounded-corners attribute as indicated"

	costume renderedMorph cornerStyle: (aBoolean ifTrue: [#rounded] ifFalse: [#square])! !


!Player methodsFor: 'clone' stamp: 'tk 1/8/2001 10:38'!
copyUniClassWith: deepCopier
	"my class is a subclass of Player.  Return another class just like my class.  Share the costume list."
	| newCls |
	newCls _ self class officialClass 
		newUniqueClassInstVars: self class instanceVariablesString 
		classInstVars: self class class instanceVariablesString.
	newCls copyMethodDictionaryFrom: self class.
	newCls class copyMethodDictionaryFrom: self class class.
	newCls scripts: self class privateScripts.	"duplicate this in mapUniClasses"
	newCls slotInfo: (self class privateSlotInfo veryDeepCopyWith: deepCopier).
	newCls copyAddedStateFrom: self class.  "All class inst vars for inter Player refs"
	^ newCls
! !

!Player methodsFor: 'clone' stamp: 'sw 9/15/1998 13:12'!
initializeCostumesFrom: aPlayer
	"Used to copy costume info over from an UnscriptedPlayer to a Player UniClass"
	costume _ aPlayer costume.
	costumes _ aPlayer costumes! !


!Player methodsFor: 'costume' stamp: 'sw 5/13/1998 14:07'!
availableCostumeNames
	"Answer a list of class names (minus trailing ...Morph) to be offered in the thumbnail 'new-Costume' menu in the Viewer"

 	^ #(Book BouncingAtoms Curve Ellipse  Flasher Image Joystick  PasteUp Polygon Rectangle Ruler Sketch Star String Text  )

"  ScrollBar  SimpleButton SimpleSlider SimpleSwitch  UserFrame  "! !

!Player methodsFor: 'costume' stamp: 'sw 4/5/1999 13:48'!
availableCostumesForArrows
	^ costumes ifNil: [Array new]! !

!Player methodsFor: 'costume' stamp: 'sw 12/16/97 11:00'!
costume
	^ costume! !

!Player methodsFor: 'costume' stamp: 'sw 3/22/2000 14:17'!
costume: aMorph
	"Make aMorph be the receiver's current costume"
	| itsBounds |
	costume == aMorph ifTrue: [^ self].
	costume ifNotNil:
		[self rememberCostume: costume renderedMorph.
		itsBounds _ costume bounds.
		(costume ownerThatIsA: HandMorph orA: PasteUpMorph) replaceSubmorph: costume topRendererOrSelf by: aMorph.
		aMorph position: itsBounds origin.
		aMorph actorState: costume actorState.
		aMorph setNameTo: costume externalName].
	aMorph player: self.
	costume _ aMorph.
	aMorph arrangeToStartStepping! !

!Player methodsFor: 'costume' stamp: 'sw 4/7/1999 21:20'!
costumeRespondingTo: aSelector
	"Answer a costume that responds to the given selector, or nil if none"
	| aMorph |
	((aMorph _ self costume renderedMorph) respondsTo: aSelector) ifTrue: [^ aMorph].
	costumes isEmptyOrNil ifFalse:
		[costumes do: [:aCostume | (aCostume respondsTo: aSelector) ifTrue: [^ aCostume]]].
	^ nil "usually an error will result"! !

!Player methodsFor: 'costume' stamp: 'sw 9/15/1998 13:12'!
costumes
	^ costumes! !

!Player methodsFor: 'costume' stamp: 'sw 8/21/1998 17:19'!
costumesDo: aBlock
	"Evaluate aBlock against every real (not flex) costume known to the receiver)"
	aBlock value: costume renderedMorph.
	costumes ifNotNil:
		[(costumes copyWithout: costume) do:
			[:aCostume | aBlock value: aCostume]]! !

!Player methodsFor: 'costume' stamp: 'sw 8/3/2000 10:16'!
forgetOtherCostumes
	self resetCostumeList.
	self updateAllViewers! !

!Player methodsFor: 'costume' stamp: 'sw 8/17/1998 15:39'!
getValueFromCostume: aSelector
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'sw 8/2/1999 17:53'!
hasAnyBorderedCostumes
	"Answer true if any costumes of the receiver are BorderedMorph descendents"

	self costumesDo:
		[:cost | (cost isKindOf: BorderedMorph) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'costume'!
hasCostumeThatIsAWorld
	(costume renderedMorph isWorldMorph) ifTrue: [^ true].
	costumes ifNotNil:
		[costumes do:
			[:aCostume | (aCostume isWorldMorph) ifTrue: [^ true]]].
	^ false! !

!Player methodsFor: 'costume' stamp: 'sw 8/2/1999 17:46'!
hasOnlySketchCostumes
	"Answer true if the only costumes assocaited with this Player are SketchMorph costumes"

	(costume renderedMorph isKindOf: SketchMorph) ifFalse: [^ false].
	costumes ifNotNil: [costumes do:
		[:cost | (cost isKindOf: SketchMorph) ifFalse: [^ false]]].
	^ true! !

!Player methodsFor: 'costume' stamp: 'ar 11/2/2000 22:17'!
knownSketchCostumeWithSameFormAs: aSketchMorph
	| itsForm |
	itsForm _ aSketchMorph form.
	^ costumes ifNotNil: [costumes detect: [:c | (c isKindOf: SketchMorph) and: [c form == itsForm]]
					ifNone: [nil]]! !

!Player methodsFor: 'costume' stamp: 'sw 10/24/1998 21:48'!
newCostume

	| aMenu reply |
	aMenu _ SelectionMenu selections: self availableCostumeNames.
	(reply _ aMenu startUpWithCaption: 'choose a costume') ifNil: [^ self].
	self wearCostumeOfName: reply.
	self updateAllViewers! !

!Player methodsFor: 'costume' stamp: 'sw 8/20/1998 17:35'!
rawCostume: aMorph
	costume _ aMorph! !

!Player methodsFor: 'costume' stamp: 'ar 11/2/2000 22:15'!
recaptureUniqueCostumes
	"Recapture all unique sketch-like costumes. Debugging only."
	| unique |
	costumes ifNil:[^self].
	unique := PluggableSet new 
				equalBlock:[:s1 :s2| s1 form == s2 form];
				hashBlock:[:s| s form identityHash].
	unique addAll: (costumes select:[:c| c isKindOf: SketchMorph]).
	unique := unique asIdentitySet.
	costumes := costumes select:[:c|
		(c isKindOf: SketchMorph) not or:[unique includes: c]].
! !

!Player methodsFor: 'costume' stamp: 'sw 8/20/1998 17:35'!
rememberCostume: aCostume
	"Put aCostume in my remembered-costumes list, as the final element"
	| costumeToRemember existing |
	costumeToRemember _ aCostume renderedMorph.
		"Remember real morphs, not their transformations"
	costumes ifNil: [costumes _ OrderedCollection new].
	existing _ (costumeToRemember isKindOf: SketchMorph)
		ifTrue:
			[self knownSketchCostumeWithSameFormAs: costumeToRemember]
		ifFalse:
			[costumes detect: [:c | c == costumeToRemember] ifNone: [nil]].
	costumes _ costumes copyWithout: existing.
	costumes addLast: costumeToRemember! !

!Player methodsFor: 'costume' stamp: 'sw 1/12/2001 22:38'!
renderedCostume: aMorph
	"Make aMorph be the receiver's rendered costume; if flexing is currently in effect, make the new morph be flexed correspondingly"

	| renderedMorph known anEventHandler w |
	renderedMorph _ costume renderedMorph.
	renderedMorph == aMorph ifTrue: [^ self].
	self rememberCostume: renderedMorph.
	renderedMorph changed.
	w _ renderedMorph world.
	"Copy 'player state' (e.g., state which should be associated with the player but is stored in the morph itself these days) from the old rendered morph the new morph."
	aMorph rotationStyle: renderedMorph rotationStyle.
	aMorph forwardDirection: renderedMorph forwardDirection.
	"Note: referencePosition is *not* state but #moveTo: behavior"
	aMorph referencePosition: renderedMorph referencePosition.
	anEventHandler _ renderedMorph eventHandler.
	costume isFlexMorph
		ifTrue:
			[costume adjustAfter:
				[costume replaceSubmorph: renderedMorph by: aMorph]]
		ifFalse:
			[costume owner ifNotNil: [costume owner replaceSubmorph: costume by: aMorph].
			aMorph player: self.
			aMorph actorState: costume actorState.
			(known _ costume knownName) ifNotNil:
				[aMorph setNameTo: known].
			costume _ aMorph.
			w ifNotNil:
				[w stopStepping: renderedMorph.
				w startStepping: aMorph]].
	aMorph eventHandler: anEventHandler.
	aMorph changed! !

!Player methodsFor: 'costume' stamp: 'sw 8/3/2000 10:16'!
resetCostumeList
	costumes _ nil! !

!Player methodsFor: 'costume' stamp: 'sw 10/26/1998 15:55'!
sendMessageToCostume: aSelector
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'sw 10/26/1998 15:54'!
sendMessageToCostume: aSelector with: arg
	| aCostume |
	(aCostume _ self costumeRespondingTo: aSelector) ifNotNil:
		[^ aCostume perform: aSelector with: arg].
	^ nil! !

!Player methodsFor: 'costume' stamp: 'sw 8/17/1998 15:45'!
setCostumeSlot: setterSelector toValue: aValue
	| aCostume |
	(aCostume _ self costumeRespondingTo: setterSelector) ifNotNil:
		[aCostume perform: setterSelector with: aValue]! !

!Player methodsFor: 'costume' stamp: 'sw 11/28/2000 10:58'!
wearCostumeOf: anotherPlayer
	"Put on a costume similar to the one currently worn by anotherPlayer"

	self renderedCostume: anotherPlayer costume renderedMorph asWearableCostume.
! !

!Player methodsFor: 'costume' stamp: 'sw 12/3/1998 10:05'!
wearCostumeOfClass: aClass
	"Assume that the costume in the library has player = nil"
	| newCostume |
	(costume renderedMorph isKindOf: aClass) ifTrue: [^ self].
	costumes ifNotNil:
		[costumes do:
			[:aCostume | (aCostume class  == aClass)
				ifTrue:
					[^ self renderedCostume: aCostume]]].

	newCostume _ aClass new.
	self renderedCostume: newCostume! !

!Player methodsFor: 'costume' stamp: 'sw 2/20/98 00:32'!
wearCostumeOfName: aName
	| classToUse |
	classToUse _ Smalltalk at: (aName, 'Morph') asSymbol ifAbsent: 
		[Smalltalk at: aName asSymbol].
	self wearCostumeOfClass: classToUse! !


!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headDown

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos @ radians sin abs) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headLeft

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos abs negated @ radians sin) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headRight

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos abs @ radians sin) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !

!Player methodsFor: 'heading' stamp: 'jm 4/24/1998 22:30'!
headUp

	| radians |
	radians _ (self getHeadingUnrounded - 90.0) degreesToRadians.
	self setHeading:
		((radians cos @ radians sin abs negated) theta radiansToDegrees
			roundTo: 0.001) + 90.0.
! !


!Player methodsFor: 'name' stamp: 'sw 1/28/2001 20:17'!
externalName
	"Answer an external name for the receiver.  If it has none, supply a backstop name"

	| aCostume |
	^ (aCostume _ self costume) ifNotNil: [aCostume externalName] ifNil: ['an orphaned Player']! !

!Player methodsFor: 'name' stamp: 'sw 10/24/2000 07:28'!
knownName
	"Answer a name by which the receiver is known, or nil if none"

	^ costume knownName! !

!Player methodsFor: 'name' stamp: 'sw 8/17/1998 17:20'!
renameTo: aName
	self costume topRendererOrSelf renameTo: aName! !

!Player methodsFor: 'name' stamp: 'sw 11/2/2000 22:00'!
tryToRenameTo: aName
	self costume topRendererOrSelf tryToRenameTo: aName! !


!Player methodsFor: 'pen' stamp: 'sw 5/2/1998 15:14'!
addPlayerMenuItemsTo: aMenu hand: aHandMorph
	| subMenu |
	"Note that all these items are now available in another way in an object's Viewer"

	(self slotInfo size > 0) ifTrue:
		[aMenu add: 'change variable type...' target: self action: #changeVariableType].

	subMenu _ MenuMorph new defaultTarget: self.
	self getPenDown
		ifTrue: [subMenu add: 'lift pen' action: #liftPen]
		ifFalse: [subMenu add: 'lower pen' action: #lowerPen].
	subMenu add: 'choose pen size...' action: #choosePenSize.
	subMenu add: 'choose pen color...' action: #choosePenColor:.
	aMenu add: 'pen...' subMenu: subMenu! !

!Player methodsFor: 'pen' stamp: 'ar 10/5/2000 18:53'!
choosePenColor: evt
	self costume changeColorTarget:  self costume  selector: #penColor: originalColor: self getPenColor hand: evt hand! !

!Player methodsFor: 'pen' stamp: 'sw 4/22/1998 13:25'!
choosePenSize
	^ self actorState choosePenSize! !

!Player methodsFor: 'pen' stamp: 'sw 8/3/1998 16:10'!
clearTurtleTrails
	self costume clearTurtleTrails! !

!Player methodsFor: 'pen' stamp: 'sw 8/17/1998 17:12'!
colorUnder
	^ self costume colorUnder! !

!Player methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'!
defaultPenColor
	^ Color blue! !

!Player methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'!
defaultPenSize
	^ 1! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:25'!
getPenColor
	"Answer the current pen color"

	^ self actorState getPenColor! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:26'!
getPenDown
	"Answer a boolean indicating whether the receiver's pen is currently down (true) or up (false)"
	^ self actorState getPenDown! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 07:26'!
getPenSize
	"Answer a number indicating the current pen size"

	^ self actorState getPenSize! !

!Player methodsFor: 'pen' stamp: 'sw 8/3/1998 16:10'!
liftAllPens
	self costume liftAllPens! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
liftPen
	self actorState liftPen! !

!Player methodsFor: 'pen' stamp: 'sw 8/3/1998 16:10'!
lowerAllPens
	self costume lowerAllPens! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
lowerPen
	self actorState lowerPen! !

!Player methodsFor: 'pen' stamp: 'sw 4/13/1998 22:38'!
penColor: aColor
	self actorState penColor: aColor! !

!Player methodsFor: 'pen' stamp: 'sw 11/28/2000 09:03'!
setPenColor: aColor
	"Set the turtle pen color as indicated"

	self actorState setPenColor: aColor! !

!Player methodsFor: 'pen' stamp: 'sw 10/30/2000 17:13'!
uniqueNameForReference
	"Answer a unique name for referring to the receiver"

	| itsReferent |
	self flag: #deferred.  "The once-and-maybe-future ObjectRepresentativeMorph scheme is for the moment disenfranchised"

	"(costume isKindOf: ObjectRepresentativeMorph) ifTrue:
		[((itsReferent _ costume objectRepresented) isKindOf: Class)
			ifTrue:
				[^ itsReferent name].
		itsReferent == Smalltalk ifTrue: [^ #Smalltalk].
		itsReferent == ScriptingSystem ifTrue: [^ #ScriptingSystem]]."

	^  super uniqueNameForReference

! !


!Player methodsFor: 'slots-kernel' stamp: 'ar 1/10/2001 11:52'!
categories
	"Answer a list of categories appropriate to the the receiver and its costumes"

	| aList |
	(self hasCostumeThatIsAWorld)
		ifTrue:	[^ self categoriesForWorld].

	aList _ OrderedCollection new.
	self slotNames size > 0 ifTrue:
		[aList add: #'instance variables'].
	aList addAll: costume categoriesForViewer.
	aList add: #scripts after: aList first.
	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 9/8/2000 17:02'!
categoriesForWorld
	"Answer the list of categories given that the receiver is the Player representing a World"

	| aList |
	aList _ #(#'color & border' #'pen trails' playfield) asOrderedCollection.
	self class scripts size > 0 ifTrue:
		[aList addFirst: #scripts].
	self slotNames size > 0 ifTrue:
		[aList addFirst: #'instance variables'].

	^ aList! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 4/8/98 11:56'!
slotInfo
	^ self class slotInfo! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 2/15/98 13:08'!
slotNames
	^ self class instVarNames  "Could also get it from the slotInfo dictionary"
			! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 10/30/2000 11:18'!
tileForArgType: typeSymbol
	"Anwer a default tile to represent a datum of the given argument type"

	| aColor |
	typeSymbol == #player ifTrue:
		[^ self tileForPlayer:  self presenter standardPlayer].
	aColor _ ScriptingSystem colorForType: typeSymbol.
	typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor].
	typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor].
	typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative].
	typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType: typeSymbol].

	self error: 'Unrecognized type'! !

!Player methodsFor: 'slots-kernel' stamp: 'RAA 12/2/2000 16:10'!
tileForArgType: typeSymbol inViewer: aViewer
	"Answer a tile to represent a value of the given type in the given viewer"

	| aColor aPlayer |
	typeSymbol == #player ifTrue:
		[aPlayer _ self presenter
			ifNotNil:
				[self presenter standardPlayer]
			ifNil:  "It happens, if costume is not currently in a world"
				[self].
		^ (CategoryViewer new) tileForPlayer:  aPlayer].
	aColor _ ScriptingSystem colorForType: typeSymbol.

	typeSymbol == #point ifTrue: [^ TileMorph new setLiteral: 0@0; typeColor: aColor].
	typeSymbol == #number ifTrue: [^ 5 newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #string ifTrue: [^ 'abc' newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #boolean ifTrue: [^ true newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #sound ifTrue: [^ SoundTile new typeColor: aColor].
	typeSymbol == #menu ifTrue: [^ MenuTile new typeColor: aColor].
	typeSymbol == #object ifTrue: [^ nil newTileMorphRepresentative typeColor: aColor].
	typeSymbol == #color ifTrue: [^ Color blue newTileMorphRepresentative].
	typeSymbol == #buttonPhase ifTrue: [^ SymbolListTile new choices: #(buttonDown whilePressed buttonUp) dataType:  typeSymbol].
	typeSymbol == #text ifTrue: [^ ("(TextMorph new contents: 'setup')" 'aborning' newTileMorphRepresentative) typeColor:  aColor].

	self error: 'Unrecognized type'! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 9/8/2000 10:21'!
tilePhrasesSpecsForCategory: aCategory
	"Return an array of slot and script names and info for use in a viewer on the receiver.  These can be of two flavors - command and slot."

	| categorySymbol |
	categorySymbol _ aCategory asSymbol.

	(categorySymbol == #'instance variables') ifTrue:		"user-defined instance variables"
		[^ self tilePhrasesSpecsInstanceVariablesCategory].

	(categorySymbol == #scripts) ifTrue:						"user-defined scripts"
		[^ self tileScriptCommands].

	^ (self usablePhraseSpecsIn: (costume categoryElementsFor: categorySymbol))   "all others"


"The format of the specs is illustrated by:
	(slot heading 'the direction'	number	 readWrite player getHeading player setHeading:)
	(command wearCostumeOf: 'change appearance to look like' player)"

! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 9/8/2000 17:08'!
tilePhrasesSpecsInstanceVariablesCategory
	"Return an array of slot names and info for use in a viewer on the receiver to represent the instance-variables category"

	| nameString |
	^ self slotNames collect: [:aName | nameString _ aName asString capitalized.

		{#slot.				"NB: Brace construct here"
		aName asSymbol.					"name"
		'a user-defined instance variable'.	"balloon help"
		(self typeForSlot: aName asSymbol).	"type"
		#readWrite.							"r/w"
		#player.							"receiver of get  selector"
		('get', nameString) asSymbol.		"get selector"
		#player.							"receiver of set selector"
		('set', nameString, ':') asSymbol}]	"set selector"
! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 10/24/2000 14:47'!
typeForSlot: aSlotName
	"Answer the data type for values of the instance variable of the given name"

	(self slotInfo includesKey: aSlotName) ifTrue: [^ (self slotInfoAt: aSlotName) type].
	^ (ScriptingSystem typeForSystemSlotNamed: aSlotName)
		ifNil:
			[self error: 'no type for slot named ', aSlotName]! !

!Player methodsFor: 'slots-kernel' stamp: 'sw 9/8/2000 11:20'!
usablePhraseSpecsIn: aListOfTuples
	"Filter the list given by aListOfTuples, to remove items inappropriate to the receiver"

	self hasCostumeThatIsAWorld ifTrue:
		[^ aListOfTuples select: [:tuple |
			#(beep doMenuItem color startScript: stopScript: pauseScript: liftAllPens lowerAllPens clearTurtleTrails initiatePainting cursor valueAtCursor mouseX mouseY roundUpStrays unhideHiddenObjects) includes: tuple second]].

	self hasAnyBorderedCostumes ifTrue: [^ aListOfTuples].

	^ self hasOnlySketchCostumes
		ifTrue:
			[aListOfTuples select: [:tuple | (#(color borderColor borderWidth) includes: tuple second) not]]
		ifFalse:
			[aListOfTuples select: [:tuple | (#(borderColor borderWidth) includes: tuple second) not]]
! !


!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 14:48'!
cameraPoint

	^ self costume cameraPoint! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 14:49'!
cameraPoint: pt

	self costume cameraPoint: pt
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:08'!
getActWhen
	"Answer the #actWhen status of my costume, which is expected to be a button with an #actWhen protocol"

	^ costume renderedMorph actWhen! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:11'!
getAllButFirstCharacter 
	"Answer a string consisting of all but the first character in its string"

	^ costume renderedMorph getAllButFirstCharacter! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/24/1998 23:15'!
getAmount
	^ self getValueFromCostume: #amount! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:40'!
getAngle
	^ self getValueFromCostume: #angle! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:31'!
getBorderColor
	"Answer the border color of my costume"

	^ self getValueFromCostume: #borderColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:31'!
getBorderWidth
	"Answer the border width of my costume"

	^ self getValueFromCostume: #borderWidth! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:06'!
getBottom
	"Answer the bottom coordinate, in the cartesian sense (decreases towards bottom of screen)"

	^ self costume cartesianBoundsTopLeft y - self costume height! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getBrightnessUnder
	^ self costume colorUnder brightness * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 15:58'!
getCameraPoint

	^ self costume cameraPoint! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:26'!
getCharacters
	"Answer the characters in my costume, likely a TextMorph"

	^ costume renderedMorph getCharacters! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:31'!
getColor
	"Answer the color of my costume"

	^ self costume renderedMorph color! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:30'!
getColorUnder
	"Answer the color beneath the center of the costume"

	^ self costume colorUnder! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:46'!
getConePosition
	"Note: Performance hacked to allow real-time sound. Assumes costume is a SpeakerMorph."

	^ costume renderedMorph conePosition
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:25'!
getCursor
	"Obtain the cursor setting from the receiver's costume"

	^ costume renderedMorph cursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:25'!
getCursorWrapped
	"maintained for backward compatibility only, for preexisting etoys"

	^ self getCursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/10/2000 13:50'!
getDescending
	^  self getValueFromCostume: #descending! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:26'!
getFirstCharacter
	"Answer a string consisting of the first character in my costume, likely itself a TextMorph"

	^ costume renderedMorph getFirstCharacter! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:12'!
getFirstElement
	"Answer a player representing the receiver's costume's first submorph"

	| itsMorphs |
	^ (itsMorphs _ costume submorphs) size > 0
		ifFalse:
			[self standardPlayer]
		ifTrue:
			[itsMorphs first assuredPlayer]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:09'!
getGetListSelector
	"Answer the selector used by my costume (a list) to obtain a fresh copy of its list"

	^ self costume renderedMorph getListSelector! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 07:21'!
getHeading
	"Answer the heading of the object, always given as a whole number"

	^ self getHeadingUnrounded rounded
! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 9/22/2000 13:42'!
getHeadingUnrounded
	^ self costume heading asSmallAngleDegrees! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:08'!
getHeight
	"Answer the height of the object"

	^ self costume height! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:35'!
getIndexInOwner
	"Answer my costume's index in its owner"

	^ costume getIndexInOwner! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 07:24'!
getIsUnderMouse
	"Answer true or false, depending on whether the object currently is or is not under the mouse"

	costume isInWorld ifFalse: [^ false].
	^ costume containsPoint: (costume pointFromWorld: costume primaryHand lastEvent cursorPoint)! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/7/2000 17:36'!
getKnobColor
	^ self getValueFromCostume: #sliderColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:10'!
getLabel
	"Answer the label of my costume"

	^ self costume renderedMorph label! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/21/1999 11:46'!
getLastValue

	^ self getValueFromCostume: #lastValue
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:09'!
getLeft
	"answer the left coordinate"

	^ self costume cartesianBoundsTopLeft x! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:41'!
getLeftRight
	^ self getValueFromCostume: #leftRight! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getLuminanceUnder
	^ self costume colorUnder luminance * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:11'!
getMaxVal
	^  self getValueFromCostume: #maxVal! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:11'!
getMinVal
	^  self getValueFromCostume: #minVal! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:15'!
getMouseX
	^ self costume mouseX! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:18'!
getMouseY
	^ self costume mouseY! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/3/98 23:36'!
getName
	^ self externalName! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:35'!
getNewClone
	"Answer a new player of the same class as the receiver, with a costume much like mine"

	^ costume usableSiblingInstance player
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:36'!
getNumberAtCursor
	"Answer the number borne by the object at my costume's current cursor position"

	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor getNumericValue]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:39'!
getNumericValue
	"Answer the numeric value contained in my costume"

	^ costume renderedMorph getNumericValue! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:43'!
getOffsetX

	^ self costume offsetX! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:43'!
getOffsetY

	^ self costume offsetY! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 10:10'!
getPlayerAtCursor
	^ self getValueAtCursor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:09'!
getRight
	"Answer the coordinate of the right edge of the object"

	^ self costume cartesianBoundsTopLeft x + self costume width! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/9/1998 17:12'!
getRotationStyle
	^ self getValueFromCostume: #rotationStyle! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:45'!
getSampleAtCursor
	"Note: Performance hacked to allow real-time sound. Assumes costume is a GraphMorph."

	^ costume renderedMorph interpolatedValueAtCursor
! !

!Player methodsFor: 'slot getters/setters' stamp: 'ar 1/15/2001 17:45'!
getSaturationUnder
	^ self costume colorUnder saturation * 100! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:35'!
getScale

	^ self costume scale! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:10'!
getScaleFactor
	"Answer the scale factor of the object"

	| aCostume |
	^ (aCostume _ self costume) isFlexMorph
		ifTrue: [aCostume scale]
		ifFalse: [1.0]
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 2/21/98 23:23'!
getSpeed
	"If user defines a speed slot, it will override this.  This provides a backstop value for use with moveToward:, etc"

	^ 5 ! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:10'!
getTop
	"Answer the coordinate of the topmost point of the object, using cartesian sense"

	^ self costume cartesianBoundsTopLeft y! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/12/2000 11:51'!
getTruncate
	^  self getValueFromCostume: #truncate! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:42'!
getUpDown
	^ self getValueFromCostume: #upDown! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 15:43'!
getValueAtCursor
	| anObject |
	anObject _ self getValueFromCostume: #valueAtCursor.
	^ anObject == 0  "weird return from GraphMorph"
		ifTrue:
			[nil]
		ifFalse:
			[anObject assuredPlayer]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 07:12'!
getViewingByIcon
	"Answer whether my costume is currently viewing by icon"

	^ costume renderedMorph viewingNormally! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:10'!
getWidth
	"Answer the width of the object"

	^ self costume width! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:23'!
getX
		"emergency patch; unclear why not needed in getY; in any case, have
		 removed the getX/getY retrievals from the viewer in 2.0-final anyway"
	| aCostume |
	(aCostume _ self costume) isInWorld ifFalse: [^ 100].
	^ aCostume x! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 07:22'!
getY
	"Answer the y coordinate of the object, relative to its container"

	^ self costume y! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 12:21'!
handTheUserACopy
	"Called from the user-interface: hand the user a copy"

	^ costume currentHand attachMorph: self getNewClone costume! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/13/2000 16:57'!
setActWhen: val
	"Tell the receiver's costume (hopefully a button!!) to set its actWhen parameter as indicated"

	costume actWhen: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:29'!
setAllButFirstCharacter: aString
	"Set my costume's all-but-first characters to be aString"

	costume renderedMorph setAllButFirstCharacter: aString! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:30'!
setBorderColor: aColor
	"Set the border color as requested"

	self setCostumeSlot: #borderColor: toValue: aColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:30'!
setBorderWidth: aWidth
	"Set the border width to the given number"

	self setCostumeSlot: #borderWidth: toValue: aWidth! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:11'!
setBottom: w
	"Set the bottom coordinate (cartesian sense) of the object as requested"

	| topLeftNow |

	topLeftNow _ self costume cartesianBoundsTopLeft.
	^ self costume bottom: self costume top + topLeftNow y - w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 12/2/2000 15:58'!
setCameraPoint: pt

	self costume cameraPoint: pt
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:28'!
setCharacters: amt
	"Set my costume's characters as indicated"

	costume renderedMorph setCharacters: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 12/15/2000 13:29'!
setColor: aColor
	"Set the color of the graphic as requested"

	self costume renderedMorph color: aColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:46'!
setConePosition: aNumber
	"Note: Performance hacked to allow real-time sound. Assumes costume is a SpeakerMorph."

	costume renderedMorph conePosition: aNumber.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 11:16'!
setCursor: aNumber
	"Set my costume's cursor to the given number"

	costume renderedMorph cursorWrapped: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/7/2000 09:29'!
setCursorWrapped: aNumber
	"maintained for backward compatibility with existing etoys"

	^ self setCursor: aNumber
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/10/2000 13:52'!
setDescending: aBoolean
	self setCostumeSlot: #descending: toValue: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/14/2000 11:29'!
setFirstCharacter: aChar
	"Set my costume's first character to the indicated one"

	costume renderedMorph setFirstCharacter: aChar! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:15'!
setFirstElement: aPlayer
	"Caution - this is a replacement operation!!  Replace the receiver's costume's first element with the morph represented by aPlayer"

	| aCostume |
	(aPlayer == self or: [(aCostume _ self costume) submorphs size == 0]) ifTrue: [^ self].
	costume replaceSubmorph: aCostume submorphs first by: aPlayer costume! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 11:18'!
setGetListSelector: sel
	"Set the receiver's get-list-selector as indicated."

	costume renderedMorph getListSelector: sel
	! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 1/6/2001 06:25'!
setHeading: newHeading
	"Set the heading as indicated"

	| aCostume |
	aCostume _ self costume.
	(newHeading closeTo: aCostume heading) ifTrue: [^ self].
	aCostume heading: newHeading.
	aCostume _ self costume. "in case we just got flexed for no apparent reason"
	(aCostume isFlexMorph and:[aCostume hasNoScaleOrRotation]) 
		ifTrue:	[aCostume removeFlexShell]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:12'!
setHeight: w
	"Set the height of the object as indicated"

	^ self costume height: w! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/8/2000 11:18'!
setIndexInOwner: amt
	"Move my costume to a different z-position within its container.  This is primarily in service of auto-line-layout views in which the z-ordering determines the left/right and top/bottom placement."

	costume setIndexInOwner: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/7/2000 17:36'!
setKnobColor: aColor
	self setCostumeSlot: #sliderColor: toValue: aColor! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 08:33'!
setLabel: aLab
	"Set the receiver's costume's label as specified"

	costume renderedMorph label: aLab! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/21/1999 11:46'!
setLastValue: aNumber

	self setCostumeSlot: #lastValue: toValue: aNumber.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:12'!
setLeft: w
	"Set the object's left coordinate as indicated"

	| topLeftNow |
	topLeftNow _ self costume cartesianBoundsTopLeft.
	^ self costume left: self costume left - topLeftNow x + w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:14'!
setMaxVal: aNumber
	self setCostumeSlot: #setMaxVal: toValue: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/6/2000 17:16'!
setMinVal: aNumber
	self setCostumeSlot: #setMinVal: toValue: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:13'!
setName: aName
	^ self costume renameTo: aName! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/1/2000 10:37'!
setNumberAtCursor: aNumber
	"Place the given number into the morph residing at my costume's current cursor position"

	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor setNumericValue: aNumber]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2000 06:12'!
setNumericValue: amt
	"Set the receiver's numeric value to the amount.  This is passed on to the costume"

	costume renderedMorph setNumericValue: amt! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:44'!
setOffsetX: aNumber

	^ self costume offsetX: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:56'!
setOffsetY: aNumber

	^ self costume offsetY: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:08'!
setRight: w
	"Set the right coordinate to the given value"

	| topLeftNow  |
	topLeftNow _ self costume cartesianBoundsTopLeft.
	^ self costume right: self costume left - topLeftNow x + w
! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 9/9/1998 17:12'!
setRotationStyle: aStyle
	self setCostumeSlot: #rotationStyle toValue: aStyle! !

!Player methodsFor: 'slot getters/setters' stamp: 'jm 4/22/1999 15:46'!
setSampleAtCursor: aNumber
	"Note: Performance hacked to allow real-time sound. Assumes costume is a GraphMorph."

	self setCostumeSlot: #valueAtCursor: toValue: aNumber.
! !

!Player methodsFor: 'slot getters/setters' stamp: 'RAA 11/22/2000 08:35'!
setScale: aNumber

	^ self costume scale: aNumber! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:07'!
setScaleFactor: aNumber
	"Set the scale factor to be the given value"

	| aCostume |
	aCostume _ self costume.
	1.0 = aNumber
		ifTrue:
			[0.0 = self getHeading ifTrue:
				[aCostume isFlexMorph ifTrue: [aCostume removeFlexShell].
				^ self]]
		ifFalse:
			[aCostume isFlexMorph ifFalse: [aCostume addFlexShell]].
	costume scale: (aNumber asFloat max: 0.125)! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:07'!
setTop: w
	"Set the top coordinate as indicated, using cartesian sense"

	| topLeftNow |
	topLeftNow _ self costume cartesianBoundsTopLeft.
	^ self costume top: self costume top + topLeftNow y - w! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 3/12/2000 11:52'!
setTruncate: aBoolean
	self setCostumeSlot: #truncate: toValue: aBoolean! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 8/17/1998 17:15'!
setValueAtCursor: aPlayer
	| renderedMorph aCostume |
	aCostume _ self costume.
	((renderedMorph _ aCostume renderedMorph) respondsTo: #valueAtCursor:) ifTrue: [^ renderedMorph valueAtCursor: aPlayer costume].

	(aCostume respondsTo: #valueAtCursor:) ifTrue: [aCostume valueAtCursor: aPlayer costume]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 10/30/2000 08:35'!
setViewingByIcon: aVal
	"Set the user's  costume's view-by-icon attribute as indictated"

	(aVal == false)
		ifTrue:
			["problematical - we always need *some* view"
			costume renderedMorph viewByName]
		ifFalse:
			[costume renderedMorph viewByIcon]! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:06'!
setWidth: w
	"Set the width to the given value"

	^ self costume width: w! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:03'!
setX: val
	"Set the x coordinate as indicated"

	^ self costume x: val! !

!Player methodsFor: 'slot getters/setters' stamp: 'sw 11/28/2000 11:03'!
setY: val
	"Set the y coordinate as indicated"

	^ self costume y: val! !


!Player methodsFor: 'slots-user' stamp: 'sw 9/8/2000 16:43'!
addInstanceVariable
	"Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it"

	| itsName initialValue typeChosen suggestedNames usedNames initialAnswer setterSelector originalString |
	suggestedNames _ #('cargo' 'speed' 'weight' 'mzee' 'friml' 'verp' 'znak').
	usedNames _ self class instVarNames.
	initialAnswer _ suggestedNames detect: [:aName |  (usedNames includes: aName) not] ifNone:
		[Utilities keyLike: 'var1'  satisfying: [:aKey | (usedNames includes: aKey) not]].

	originalString _ FillInTheBlank request: 'name for new inst var: ' initialAnswer: initialAnswer.
	itsName _ ScriptingSystem acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: nil asSlotNameIn: self world: self costume world.

 	itsName size == 0 ifTrue: [^ self].	
	self assureUniClass.
	typeChosen _ self initialTypeForSlotNamed: itsName.
	self slotInfo at: itsName put: (SlotInformation new initialize type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: itsName withValue: initialValue.
	self class compileAccessorsFor: itsName.
	setterSelector _ Utilities setterSelectorFor: itsName.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: #'instance variables'
! !

!Player methodsFor: 'slots-user' stamp: 'sw 9/8/2000 14:47'!
addInstanceVariableNamed: nameSymbol type: typeChosen value: aValue
	"Add an instance variable of the given name and type, and initialize it to have the given value"

	| initialValue setterSelector |
	self assureUniClass.
	self slotInfo at: nameSymbol put: (SlotInformation new initialize type: typeChosen).
	initialValue _ self initialValueForSlotOfType: typeChosen.
	self addInstanceVarNamed: nameSymbol withValue: aValue.
	self class compileAccessorsFor: nameSymbol.
	setterSelector _ Utilities setterSelectorFor: nameSymbol.
	(self class allSubInstances copyWithout: self) do:
		[:anInstance | anInstance perform: setterSelector with: initialValue].
	self updateAllViewersAndForceToShow: #'instance variables'
! !

!Player methodsFor: 'slots-user' stamp: 'tk 11/21/2000 16:25'!
addSpecialSetter: selector
	| instVar code |
	"For the special setters, fooIncreaseBy:, fooDecreaseBy:, fooMultiplyBy:, add a method that does them."

 	self assureUniClass.
	instVar _ (selector allButLast: 11) asLowercase.  "all three are 11 long!!"
	(self respondsTo: ('set', instVar capitalized, ':') asSymbol) ifFalse: [^ false].
	code _ String streamContents: [:strm |
		strm nextPutAll: selector, ' amount'; crtab.
		strm nextPutAll: 'self set', instVar capitalized, ': (self get', instVar capitalized; space.
		(selector endsWith: 'IncreaseBy:') ifTrue: [strm nextPut: $+].
		(selector endsWith: 'DecreaseBy:') ifTrue: [strm nextPut: $-].
		(selector endsWith: 'MultiplyBy:') ifTrue: [strm nextPut: $*].
		strm nextPutAll: ' amount)'].

	self class compileUnlogged: code
		classified: 'access' notifying: nil.
	^ true
! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/24/98 22:59'!
changeVariableType
	| slotName |
	(slotName _ self chooseUserSlot) ifNil: [^ self].
	self chooseSlotTypeFor: slotName asSymbol! !

!Player methodsFor: 'slots-user' stamp: 'tk 6/24/1999 11:38'!
chooseSlotTypeFor: slotName
	| typeChoices typeChosen |
	self flag: #deferred.  "sound should be reinstated but too much difficulty at present"

	typeChoices _ #(number player boolean color string "sound point costume").
	typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: 'Choose the TYPE
for ', slotName.
	typeChosen isEmptyOrNil ifTrue: [^ self].
	(self typeForSlot: slotName) = typeChosen ifTrue: [^ self].

	(self slotInfoAt: slotName) type: typeChosen.
	self class allInstancesDo:   "allSubInstancesDo:"
		[:anInst | anInst instVarNamed: slotName asString put: 
			(anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName)).
		anInst updateAllViewers]
! !

!Player methodsFor: 'slots-user' stamp: 'sw 4/5/1999 13:55'!
chooseUserSlot
	| names aMenu result |
	(names _ self slotNames) size == 1
		ifTrue: [^ names first].
	aMenu _ SelectionMenu selections: names.
	result _ aMenu startUpWithCaption: 'Please choose a variable'.
	result isEmptyOrNil ifTrue: [^ nil].
	^ result! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/12/1999 16:00'!
compileInstVarAccessorsFor: varName
	self class compileInstVarAccessorsFor: varName! !

!Player methodsFor: 'slots-user' stamp: 'tk 11/21/2000 16:17'!
doesNotUnderstand: aMessage 
	 | ours |
"See it the message is a special setter that has not been defined.  Define it and try again."

	ours _ false.
	(aMessage selector endsWith: 'IncreaseBy:') ifTrue: [ours _ true].
	(aMessage selector endsWith: 'DecreaseBy:') ifTrue: [ours _ true].
	(aMessage selector endsWith: 'MultiplyBy:') ifTrue: [ours _ true].
	ours ifFalse: [^ super doesNotUnderstand: aMessage].
	(self addSpecialSetter: aMessage selector) ifFalse: ["not our inst var"
		^ super doesNotUnderstand: aMessage].
	^ aMessage sentTo: self! !

!Player methodsFor: 'slots-user' stamp: 'sw 12/28/1998 15:30'!
hasUserDefinedScripts
	^ self class scripts size > 0! !

!Player methodsFor: 'slots-user' stamp: 'sw 12/28/1998 10:27'!
hasUserDefinedSlots
	^ self class slotInfo size > 0! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/24/98 22:21'!
initialTypeForSlotNamed: aName
	^ #number! !

!Player methodsFor: 'slots-user' stamp: 'sw 10/24/2000 08:07'!
initialValueForSlotOfType: aType
	"Answer the default initial value to ascribe to a slot of the given type"

	aType == #number ifTrue: [^ (1 to: 9) atRandom].
	aType == #boolean ifTrue: [^ true].
	aType == #player ifTrue: [^ self costume presenter standardPlayer].
	aType == #color ifTrue: [^ Color random].
	aType == #string ifTrue: [^ 'abc'].
	aType == #sound ifTrue: [^ 'croak'].
	aType == #point ifTrue: [^ 20 @ 30].
	aType == #buttonPhase ifTrue: [^ #buttonUp].
	^ nil! !

!Player methodsFor: 'slots-user' stamp: 'sw 2/3/1999 09:52'!
removeSlotNamed: aSlotName
	(self okayToRemoveSlotNamed: aSlotName) ifFalse:
		[^ self inform: 'Sorry, ', aSlotName, ' is in
use in a script.'].
	self inform: 
'Caution!!  Any scripts that may reference
this instance variable may now be broken.
You may need to fix them up manually.  
In some future release, we''ll automatically
fix those up, hopefully.'.

	self class removeInstVarName: aSlotName asString.

	self updateAllViewers
! !

!Player methodsFor: 'slots-user' stamp: 'sw 9/6/2000 04:36'!
renameSlot: oldSlotName
	| reply newSlotName |
	reply _   FillInTheBlank request: 'New name for "', oldSlotName, '":' initialAnswer: oldSlotName.
 	reply size == 0 ifTrue: [^ self].
	newSlotName _ ScriptingSystem acceptableSlotNameFrom: reply forSlotCurrentlyNamed:  oldSlotName asSlotNameIn: self world: self costume currentWorld.
	self renameSlot: oldSlotName newSlotName: newSlotName! !

!Player methodsFor: 'slots-user' stamp: 'sw 1/29/1999 16:33'!
renameSlot: oldSlotName newSlotName: newSlotName
	self class renameSilentlyInstVar: oldSlotName to: newSlotName.
	self updateAllViewers.
	self flag: #deferred.
	"Any scripts that formerly sent oldSlotName should now send newSlotName"

	self inform: 
'Caution!!  Any scripts that may reference this
instance variable by its old name may now be
broken -- you may need to fix them up manually.  
In some future release, we''ll automatically
fix those up, hopefully.'.

	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: oldSlotName ofPlayer: self)
			ifTrue:
				[^ aPlayer noteRenameOf: oldSlotName to: newSlotName inPlayer: self]].
	^ true! !

!Player methodsFor: 'slots-user' stamp: 'sw 9/8/1999 22:29'!
setPrecisionFor: slotName
	| aList aMenu reply precision val |
	aList _ #('0' '1' '2' '3' '4' '5').
	aMenu _ SelectionMenu labels: aList selections: aList.
	reply _ aMenu startUpWithCaption: 'How many decimal places?'.
	reply ifNotNil:
		[(self slotInfoAt: slotName) floatPrecision:
			(precision _ #(1 0.1 0.01 0.001 0.0001 0.00001 0.000001) at: (aList indexOf: reply)).
		self class allInstancesDo:   "allSubInstancesDo:"
			[:anInst |
				precision ~= 1 ifTrue:
					[((val _ anInst instVarNamed: slotName asString) isKindOf: Integer)
						ifTrue:
							[anInst instVarNamed: slotName asString put: val asFloat]].
				anInst updateAllViewers]]
! !

!Player methodsFor: 'slots-user' stamp: 'sw 9/8/1999 18:37'!
slotInfoAt: slotName
	| info |
	info _ self slotInfo at: slotName ifAbsent: [nil].
	info ifNil:
		[self slotInfo at: slotName put: (info _ SlotInformation new initialize)].
	(info isKindOf: Symbol) "bkward compat"
		ifTrue:
			[self slotInfo at: slotName put: (info _ SlotInformation new type: info)].
	^ info! !

!Player methodsFor: 'slots-user' stamp: 'ar 11/9/2000 20:42'!
tearOffFancyWatcherFor: aSlotName
	| aWatcher aTile getSel aLine aColor aTower precision |
	aColor _ Color r: 0.387 g: 0.581 b: 1.0.
	aLine _ AlignmentMorph newRow vResizing: #shrinkWrap; color: aColor.
	aLine layoutInset: -1.
	aLine borderWidth: 1; borderColor: aColor darker.
	aLine addMorphBack: (self tileReferringToSelf borderWidth: 0; typeColor: aColor; color: aColor; bePossessive).
	aLine addTransparentSpacerOfSize: (4@0).
	aTower _ AlignmentMorph newColumn color: aColor.
	aTower addTransparentSpacerOfSize: (0 @ 1).
	aTower addMorphBack: (StringMorph contents: aSlotName, ' = ' font: ScriptingSystem fontForTiles).
	aLine addMorphBack: aTower.
	aTile _ NumericReadoutTile new typeColor: aColor.
	aWatcher _ UpdatingStringMorph new.
	(precision _ self defaultFloatPrecisionFor: (getSel _ ScriptingSystem getterSelectorFor: aSlotName)) ~= 1 ifTrue:
		[aWatcher floatPrecision: precision].
	aWatcher growable: true;
		getSelector: getSel;
		putSelector: (ScriptingSystem setterSelectorFor: aSlotName).
	aWatcher target: self.
	aTile addMorphBack: aWatcher.
	aTile addArrows.
	aTile setLiteralTo: (self perform: getSel) width: 30.
	aLine addMorphBack: aTile.
	aWatcher step; fitContents.
	self currentHand attachMorph: aLine! !

!Player methodsFor: 'slots-user' stamp: 'sw 3/11/2000 20:07'!
tearOffWatcherFor: aSlotName
	| aWatcher precision getSel |
	aWatcher _ UpdatingStringMorph new.
	getSel _ ScriptingSystem getterSelectorFor: aSlotName.
	((self typeForSlot: aSlotName) = #number)
		ifFalse:
			[aWatcher useStringFormat]
		ifTrue:
			[precision _ self defaultFloatPrecisionFor: getSel.
			precision ~= 1 ifTrue: [aWatcher floatPrecision: precision]].

	aWatcher growable: true;
		getSelector: getSel;
		putSelector: (ScriptingSystem setterSelectorFor: aSlotName);
		setNameTo: aSlotName.
 	aWatcher target: self.
	aWatcher step.
	aWatcher fitContents.
	self currentHand attachMorph: aWatcher! !

!Player methodsFor: 'slots-user' stamp: 'sw 7/4/1998 18:03'!
valueOfType: aType from: oldValue
	"The user has changed a slot's type to aType; convert its former value, oldValue, to something of the appropriate type.  For now, does not take oldValue into account"
	^ self initialValueForSlotOfType: aType! !


!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:06'!
assignDecrGetter: getterSelector setter: setterSelector amt: aDecrement
	self perform: setterSelector with:
		((self perform: getterSelector) - aDecrement)! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:07'!
assignGetter: getterSelector setter: setterSelector amt: amt
	self perform: setterSelector with: amt! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:07'!
assignIncrGetter: getterSelector setter: setterSelector amt: anIncrement
	self perform: setterSelector with:
		((self perform: getterSelector) + anIncrement)! !

!Player methodsFor: 'slots-assignment' stamp: 'sw 1/31/98 00:06'!
assignMultGetter: getterSelector setter: setterSelector amt: aMultiplier
	self perform: setterSelector with:
		((self perform: getterSelector) * aMultiplier)! !


!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/22/2001 14:26'!
acceptScript: aScriptEditorMorph for: aSelector
	"Accept the code in the script editor as the code for the given selector"

	self class
		compileUnlogged: aScriptEditorMorph methodString
		classified: 'scripts'
		notifying: nil.
	self class atSelector: aSelector putScriptEditor: aScriptEditorMorph! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 4/9/98 21:56'!
allScriptEditors
	"Used presently only an one-shot efforts to update all tile scripts to new styles"

	^ self class tileScriptNames collect: [:n | self scriptEditorFor: n]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/28/2001 23:27'!
"Translate commandSpec into a PhraseTileMorph.  Put appropriate balloon help into the phrase"

commandPhraseFor: commandSpec inViewer: aViewer

	| aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst ut aDocString |
	names _ self class namedTileScriptSelectors.

	resultType _ (commandSpec at: 1).
	cmd _ (commandSpec at: 2).
	(ut _ self isUniversalTiles)
		ifTrue:
			[aPhrase _ (CategoryViewer new) newTilesFor: self command: commandSpec]
		ifFalse: [commandSpec size = 3
			ifTrue:
				[aPhrase _ PhraseTileMorph new setOperator: cmd
					type: resultType
					rcvrType: #player]
			ifFalse: "commandSpec size is four"
				[argType _ commandSpec at: 4.
				aPhrase _ PhraseTileMorph new setOperator: cmd
					type: resultType
					rcvrType: #player
					argType: argType.
				argTile _ self tileForArgType: argType inViewer: aViewer.
				argTile position: aPhrase lastSubmorph position.
				aPhrase lastSubmorph addMorph: argTile]].

	(self slotInfo includesKey: cmd)
		ifTrue: [balloonTextSelector _ #userSlot].

	(self belongsToUniClass and: [self class includesSelector: cmd])
		ifTrue:
			[aDocString _ (self class userScriptForPlayer: self selector: cmd) documentationOrNil.
			aDocString ifNotNil:
					[aPhrase submorphs second setBalloonText: aDocString]
				ifNil:
					[balloonTextSelector _ #userScript]].

	(ut ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]) balloonTextSelector: 
			(balloonTextSelector ifNil: [cmd]).
	aPhrase markAsPartsDonor.
	cmd == #emptyScript ifTrue:
		[aPhrase setProperty: #newPermanentScript toValue: true.
		aPhrase setProperty: #newPermanentPlayer toValue: self.
		aPhrase submorphs second setBalloonText: 
'drag and drop to 
add a new script'].

	ut ifFalse: [
		selfTile _ aViewer tileForSelf.
		selfTile position: aPhrase firstSubmorph position.
		aPhrase firstSubmorph addMorph: selfTile].

	aRow _ ViewerRow newRow borderWidth: 0; color: aViewer color.
	aRow elementSymbol: cmd asSymbol.

	aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase).
	aRow addMorphBack: (Morph new extent: 4@2; beTransparent).
	aRow addMorphBack: (aViewer infoButtonFor: cmd).
	aRow addMorphBack: aPhrase.
	(names includes: cmd) ifTrue:
		[aPhrase userScriptSelector: cmd.
		aPhrase beTransparent.
		aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
		aRow addMorphBack: (stat _ (inst _ self scriptInstantiationForSelector: cmd) statusControlMorph).
		inst updateStatusMorph: stat].

	aRow beSticky; disableDragNDrop.

	^ aRow! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:03'!
elementTypeFor: aStringOrSymbol
	"Answer whether aStringOrSymbol is best characterized as a #systemSlot, #systemScript, #userSlot, or #userScript"

	| aSymbol |
	aSymbol _ aStringOrSymbol asSymbol.
	(ScriptingSystem typeForSystemSlotNamed: aSymbol) ifNotNil: [^ #systemSlot].
	(ScriptingSystem isSystemScriptName: aSymbol) ifTrue: [^ #systemScript].
	(self slotInfo includesKey: aSymbol) ifTrue: [^ #userSlot].
	^ #userScript! !

!Player methodsFor: 'scripts-kernel' stamp: 'ar 1/10/2001 12:10'!
emptyScript
	"The empty script"! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:03'!
expungeEmptyScripts
	"Track down and destroy -- and destroy screen artifacts relating to -- all scripts belonging to the receiver that have no lines of code in them"

	| any |
	any _ false.
	self class namedTileScriptSelectors do:
		[:aSel |
			(self isEmptyTileScript: aSel)
				ifTrue:
					[any _ true.
					self removeScriptWithoutUpdatingViewers: aSel]].
	any ifTrue: [self updateAllViewersAndForceToShow: #scripts]
			
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:04'!
expungeEmptyUnRenamedScripts
	"Track down and destroy -- and destroy screen artifacts relating to -- all scripts belonging to the receiver that have not been named and that have no lines of code in them"

	| any |
	any _ false.
	self class namedTileScriptSelectors do:
		[:aSel |
			(self isExpendableScript: aSel)
				ifTrue:
					[any _ true.
					self removeScriptWithoutUpdatingViewers: aSel]].
	any ifTrue:
		[self updateAllViewersAndForceToShow: #scripts]
			
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 2/21/98 23:32'!
hasScriptInvoking: scriptName ofPlayer: aPlayer
	"Answer whether the receiver bears any script that invokes a script of the given name for  the given player"
	self allScriptEditors do:
		[:anEditor | (anEditor hasScriptInvoking: scriptName ofPlayer: aPlayer) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/16/1999 16:27'!
hasScriptReferencing: slotName ofPlayer: aPlayer
	"Answer whether the receiver bears any script that references a slot of the given name for  the given player"
	self allScriptEditors do:
		[:anEditor | (anEditor hasScriptReferencing: slotName ofPlayer: aPlayer) ifTrue: [^ true]].
	^ false! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/30/2001 14:30'!
infoFor: anElement inViewer: aViewer
	"The user made a gesture asking for info/menu relating"

	| aMenu selector reply elementType |
	elementType _ self elementTypeFor: anElement.
	((elementType = #systemSlot) | (elementType == #userSlot))
		ifTrue:	[^ self slotInfoButtonHitFor: anElement inViewer: aViewer].
	
	self flag: #deferred.  "Use a traditional MenuMorph, and reinstate the pacify thing"
	aMenu _ MVCMenuMorph new.
	aMenu defaultTarget: aMenu.
	(elementType == #userScript)
		ifTrue: 
			[aMenu add: 'destroy "', anElement, '"' selector: #selectMVCItem: argument: #removeScript.
			aMenu add: 'rename  "', anElement, '"' selector: #selectMVCItem: argument:  #renameThisScript.
			aMenu add: 'textual scripting pane'  selector: #selectMVCItem: argument: #makeIsolatedCodePaneFor.
			aMenu add: 'edit balloon help' selector: #selectMVCItem: argument: #editDescription.

			"aMenu add: 'pacify "', anElement, '"' action: #pacifyScript"].
	aMenu items size == 0 ifTrue:
		[aMenu add: 'ok' action: nil].
	aMenu addTitle: anElement asString, ' (', elementType, ')'.
	selector _ anElement asSymbol.
	reply _  aMenu invokeAt: aViewer primaryHand position in: aViewer world.
	reply == nil ifTrue: [^ self].
	reply == #removeScript ifTrue: [^ self removeScript: selector fromWorld: aViewer world].
	reply == #renameThisScript ifTrue: [^ self renameScript:  selector].
	reply == #makeIsolatedCodePaneFor ifTrue: 
		[MethodHolder makeIsolatedCodePaneForClass: self class selector: selector].
	reply == #editDescription ifTrue:
		[(self class userScriptForPlayer: self selector: selector) editDescription.
		self updateAllViewers].
	reply == #pacifyScript ifTrue: [^ self pacifyScript: selector]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 10/24/2000 14:32'!
instantiatedUserScriptsDo: aBlock
	"Evaluate aBlock on behalf of all the instantiated user scripts in the receiver"

	| aState aCostume |
	((aCostume _ self costume) notNil and: [(aState _ aCostume actorState) notNil]) ifTrue:
		[aState instantiatedUserScriptsDictionary do: aBlock]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/29/2001 02:49'!
isEmptyTileScript: aScriptName
	"Answer the script of the given name is an empty tile script"

	| aUserScript |
	aUserScript _ self class userScriptForPlayer: self selector: aScriptName.
	aUserScript isTextuallyCoded ifTrue:
		[^ false].
	^ (aUserScript instantiatedScriptEditorForPlayer: self) isEmpty
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 7/16/1999 16:59'!
isExpendableScript: aScriptName
	^ (self isEmptyTileScript: aScriptName) and:
		[aScriptName beginsWith: 'script']
! !

!Player methodsFor: 'scripts-kernel' stamp: 'tk 1/31/2001 12:43'!
isUniversalTiles
	| ww |
	"Return true if I (my world) uses universal tiles.  This message can be called in places where the current World is not known, such as when writing out a project."

	^ (ww _ costume world)	 "new tiles?"
		ifNil: [ScriptEditorMorph writingUniversalTiles == true
				"only valid during a project write"]
		ifNotNil: [ww valueOfProperty: #universalTiles ifAbsent: [false]]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/23/2001 11:16'!
newScriptEditorFor: aSelector usingPhraseTile: aPhraseTileMorph
	"Sprout a scriptor for aSelector, using aPhraseTileMorph as its initial phrase."

	| aUserScript aScriptEditor |
	(self class selectors includes: aSelector) ifTrue: [self error: 'selector already exists'].

	aUserScript _ self class permanentUserScriptFor: aSelector player: self.
	aScriptEditor _ aUserScript instantiatedScriptEditor.
	aPhraseTileMorph ifNotNil: [aScriptEditor phrase: aPhraseTileMorph].
	aScriptEditor install.
	aPhraseTileMorph ifNil: [aScriptEditor showSourceInScriptor].
	self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUserScript selector].
		"The above assures the presence of a ScriptInstantiation for the new selector in all siblings"

	self updateAllViewersAndForceToShow: #scripts.
	^ aScriptEditor! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/23/2001 18:36'!
newScriptorAround: aPhraseTileMorph
	"Sprout a scriptor around aPhraseTileMorph, thus making a new script"

	| aScriptEditor aUniclassScript ut tw blk |
	aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self.
	aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self.

	ut _ costume world valueOfProperty: #universalTiles ifAbsent: [false].
	ut ifTrue: [aScriptEditor install.	"to get a default script there"
		aScriptEditor useNewTiles.
		aPhraseTileMorph ifNotNil:
			[tw _ aScriptEditor findA: TwoWayScrollPane.
			blk _ tw scroller firstSubmorph "MethodNode" lastSubmorph "BlockNode".
			blk addMorphFront: aPhraseTileMorph.
			"aPhraseTileMorph position: self topLeft + (7@14)"
			aPhraseTileMorph accept]]
		ifFalse:
			[aPhraseTileMorph 
				ifNotNil: [aScriptEditor phrase: aPhraseTileMorph]	"does an install"
				ifNil: [aScriptEditor install]].
	self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector].
		"The above assures the presence of a ScriptInstantiation for the new selector in all siblings"
	self updateAllViewersAndForceToShow: #scripts.
	^ aScriptEditor! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/29/1999 16:31'!
noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer
	"Note that aPlayer has renamed a slot formerly known as oldSlotName to be newSlotName"

	self allScriptEditors do:
		[:anEditor | (anEditor hasScriptReferencing: oldSlotName ofPlayer: aPlayer) ifTrue: 
			[self flag: #deferred.   "Now what?  Just implement the following?!!"
			anEditor replaceReferencesToSlot: oldSlotName inPlayer: aPlayer with: newSlotName]]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/17/1998 17:13'!
okayToDestroyScriptNamed: scriptName
	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptInvoking: scriptName ofPlayer: self)
			ifTrue:
				[^ false]].
	^ true! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/17/1998 17:21'!
okayToRemoveSlotNamed: aSlotName
	self costume world presenter allExtantPlayers do:
		[:aPlayer | (aPlayer hasScriptReferencing: aSlotName ofPlayer: self)
			ifTrue:
				[^ false]].
	^ true! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/19/2001 15:12'!
pacifyScript: aSymbol
	"Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side"

	| editor aHandler aUserScript |
	aUserScript _ self class userScriptForPlayer: self selector: aSymbol.
	aUserScript ifNil: [self flag: #deferred.  ^ self beep].  
	"Maddeningly, without this line here the thing IS nil and the debugger is in a bad state
	(the above note dates from 1/12/99 ?!!"

	editor _ aUserScript instantiatedScriptEditor.
	editor scriptInstantiation status: #normal.
	self class allInstancesDo:
		[:aPlayer | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol.

		(aHandler _ aPlayer costume renderedMorph eventHandler) ifNotNil:
			[aHandler forgetDispatchesTo: aSymbol]]! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:06'!
removeScript: aSymbol fromWorld: aWorld
	"Remove the given script, and get the display right in aWorld"

	self removeScriptWithoutUpdatingViewers: aSymbol fromWorld: aWorld.
	self updateAllViewersAndForceToShow: #scripts
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 7/16/1999 17:06'!
removeScriptWithoutUpdatingViewers: aSymbol
	self pacifyScript: aSymbol.
	self class removeScriptNamed: aSymbol.

	(self scriptorsForSelector: aSymbol inWorld: costume world) do:
		[:s | s privateDelete].
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 8/15/2000 11:57'!
removeScriptWithoutUpdatingViewers: aSymbol fromWorld: aWorld
	self pacifyScript: aSymbol.
	self class removeScriptNamed: aSymbol.

	(self scriptorsForSelector: aSymbol inWorld: aWorld) do:
		[:s | s privateDelete].
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/22/2001 15:19'!
renameScript: oldSelector
	"The user has asked to rename the script formerly known by oldSelector; obtain a new selector from the user, check it out, and if all is well, ascribe the new name as appropriate"

	| reply newSelector aUserScript |
	self flag: #deferred.  "Relax the below, yes?"
	aUserScript _ self class userScriptForPlayer: self selector: oldSelector.
	aUserScript isTextuallyCoded ifTrue:
		[self inform: 'Sorry, for now you can only rename tiled scripts'.
		^ self].

	reply _   FillInTheBlank request: 'Script Name' initialAnswer: oldSelector.
 	reply size == 0 ifTrue: [^ self].
	reply = oldSelector ifTrue:[^ self beep].

	newSelector _ ScriptingSystem acceptableScriptNameFrom: reply  forScriptCurrentlyNamed:  oldSelector asScriptNameIn: self world: costume world.
	(self currentWorld hasProperty: #universalTiles) 
		ifTrue:
			["allow colons"
			(reply copyWithout: $:) = newSelector 
				ifTrue: [newSelector _ reply asSymbol]
				ifFalse: [self inform: 'name will be modified']].	

	self renameScript: oldSelector newSelector: newSelector
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/30/2001 18:53'!
renameScript: oldSelector newSelector: newSelector
	"Rename the given script to have the new selector"

	|  aUserScript aScriptEditor anInstantiation |
	aUserScript _ self class userScriptForPlayer: self selector: oldSelector.
	aScriptEditor _ aUserScript instantiatedScriptEditor.
	aScriptEditor renameScriptTo: newSelector.
	aUserScript bringUpToDate.
	self class removeScriptNamed: oldSelector.
	self class atSelector: newSelector putScriptEditor: aScriptEditor.
	self class allSubInstancesDo:
		[:aPlayer |
			anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector.
			anInstantiation changeSelectorTo: newSelector.
			aPlayer costume actorState instantiatedUserScriptsDictionary
				removeKey: oldSelector;
				at: newSelector put: anInstantiation.
			anInstantiation assureEventHandlerRepresentsStatus].
	
	self updateAllViewersAndForceToShow: 'scripts'
! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 10/5/1999 18:25'!
runScript: aSelector
	"Called from script-activation buttons.  Provides a safe way to run a script that may have changed its name"
	(self respondsTo: aSelector) ifTrue:
		[^ self perform: aSelector].
	self inform: 
'Oops, object "', self externalName, '" no longer has
a script named "', aSelector, '".
It must have been deleted or renamed.'! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/30/2001 18:58'!
scriptEditorFor: aSelector
	"Answer the receiver's script editor for aSelector"

	| aScriptEditor |
	aScriptEditor _ (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditor.
	aScriptEditor updateToPlayer: self.
	aScriptEditor bringUpToDate.
	^ aScriptEditor! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 5/5/1998 00:18'!
scriptEvaluatorFor: aSelector phrase: aPhrase
	| anEvaluator |
	anEvaluator _ ScriptEvaluatorMorph new playerScripted: self.
	anEvaluator initializeFor: aPhrase.
	^ anEvaluator bringUpToDate! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/29/2001 11:57'!
scriptInstantiationForSelector: aSelector
	"Answer a script instantiation for the given selector, creating it at this time if necessary"

	|  entry scriptDict classEntry |
	scriptDict _ self actorState instantiatedUserScriptsDictionary.
	entry _ scriptDict at: aSelector ifAbsent: [nil].
	entry ifNil:
		[classEntry _ self class userScriptForPlayer: self selector: aSelector.
		entry _ ScriptInstantiation new player: self selector: aSelector status: classEntry defaultStatus.
		scriptDict at: aSelector put: entry].
	^ entry! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 1/19/2001 15:15'!
scriptorsForSelector: aSelector inWorld: aWorld
	"Answer, for the purpose of deletion, a list of all scriptor objects for the given selector that are associated with any member of the receiver's uniclass"

	| scriptors |
	aWorld ifNil: [^ OrderedCollection new].
	scriptors _ (aWorld allMorphs select:
		[:m | (((m isKindOf: ScriptEditorMorph) and: [m playerScripted class == self class]) and: [m scriptName == aSelector])] thenCollect: [:m | m topEditor]) asSet.
	^ scriptors asArray! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 9/8/2000 17:07'!
slotInfoButtonHitFor: aSlotName inViewer: aViewer
	"The user made a gesture asking for info/menu relating"

	| aMenu slotSym aType |
	slotSym _ aSlotName asSymbol.
	aType _ self typeForSlot: aSlotName asSymbol.
	aMenu _ MenuMorph new defaultTarget: self.
	(#(colorSees copy getNewClone) includes: slotSym) ifFalse:
		[aMenu add: 'simple watcher' selector: #tearOffWatcherFor: argument: slotSym].
	(#(copy getNewClone) includes: slotSym) ifTrue:
		[aMenu add: 'give me a copy now' action: #handTheUserACopy].

	aType == #number "later others" ifTrue:
		[aMenu add: 'detailed watcher' selector: #tearOffFancyWatcherFor: argument: slotSym].

	(self slotInfo includesKey: slotSym)
		ifTrue:  "User slot"
			[aMenu add: 'change data type' selector: #chooseSlotTypeFor: argument: slotSym.
			aType == #number ifTrue:
				[aMenu add: 'decimal places...' selector: #setPrecisionFor: argument: slotSym].
			aMenu add: 'remove "', aSlotName, '"' selector: #removeSlotNamed: argument: slotSym.
			aMenu add: 'rename  "', aSlotName, '"' selector: #renameSlot: argument: slotSym].
	aMenu items size == 0 ifTrue:
		[aMenu add: 'ok' action: #yourself].
	aMenu addTitle: (aSlotName asString, ' (', aType, ')').
	aMenu popUpForHand: aViewer primaryHand in: aViewer world! !

!Player methodsFor: 'scripts-kernel' stamp: 'sw 11/5/1998 10:33'!
sourceCodeFor: sel
	^ self class sourceCodeAt: sel ifAbsent: 
		[Player sourceCodeAt: sel ifAbsent: ['this space for rent']]
	! !

!Player methodsFor: 'scripts-kernel' stamp: 'ar 1/10/2001 12:02'!
tileScriptCommands
	"Return a list of typed-command arrays of the form:
		#command <selector> <balloon help>"
	self flag: #deferred.  "'need way for user to save own help"
	^(Array with: {#command. #'emptyScript'. 'a new empty script'}),
		(self class namedTileScriptSelectors asSortedArray collect:
			[:sel | Array with: #command with: sel with: 'a user-written script'])! !


!Player methodsFor: 'scripts-execution' stamp: 'sw 5/13/1998 13:10'!
assureEventHandlerRepresentsStatus
	self instantiatedUserScriptsDo:
			[:aScriptInst | aScriptInst assureEventHandlerRepresentsStatus]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 7/3/1998 20:22'!
runAllClosingScripts
	"Run all the receiver's scripts marked as #closing.  Return a boolean indicating whether any such scripts were encountered and run"

	| any |
	any _ false.
	self instantiatedUserScriptsDo:
		[:aScriptInstantiation | aScriptInstantiation runIfClosing ifTrue: [any _ true]].
	^ any! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 7/3/1998 20:21'!
runAllOpeningScripts
	"Run all the receiver's scripts marked as #opening.  Return a boolean indicating whether any such scripts were encountered and run"

	| any |
	any _ false.
	self instantiatedUserScriptsDo:
		[:aScriptInstantiation | aScriptInstantiation runIfOpening ifTrue: [any _ true]].
	^ any! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 4/30/1998 13:58'!
runAllTickingScripts

	self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation runIfTicking]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 1/31/98 01:50'!
scriptPerformer
	^ self! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 12/1/1999 13:12'!
scriptingError: aMessage
	"An error arose, characterized by aMessage, when a script was being run.  For the moment, we report it to the transcript only"
	Transcript cr; show: 'Scripting error for ', self externalName, ': ', aMessage! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 9/14/2000 06:49'!
standardPlayer
	"Answer the standard player for the receiver's costume's presenter"

	^  self presenter standardPlayer costume! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 8/21/1998 16:34'!
startRunning
	self costume arrangeToStartStepping.
	self instantiatedUserScriptsDo:
		[:aScript | aScript startRunningIfPaused]! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 8/21/1998 16:34'!
startRunningScripts
	self startRunning.
	self costume arrangeToStartStepping.  "emergency patch, if not going already"
	self costume presenter startRunningScripts! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 2/12/98 13:46'!
step
	self runAllTickingScripts! !

!Player methodsFor: 'scripts-execution' stamp: 'jm 6/16/1999 14:37'!
stopProgramatically
	"stop running my ticking scripts -- called from running code"
	self instantiatedUserScriptsDo:
		[:aUserScript | aUserScript stopTicking].
	(costume renderedMorph isKindOf: SpeakerMorph)
		ifTrue: [costume renderedMorph stopSound].  "turn off buffered speaker sound"
! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 2/12/98 14:51'!
stopRunning
	self stopProgramatically! !

!Player methodsFor: 'scripts-execution' stamp: 'sw 10/19/1999 08:30'!
wantsSteps
	"UnscriptedPlayer, with no scripts, overrides to false"
	^ true! !


!Player methodsFor: 'scripts-standard' stamp: 'tk 1/16/2001 18:26'!
append: aPlayer
	"Add aPlayer to the list of objects logically 'within' me.  This is visually represented by its morph becoming my costume's last submorph.   Also allow text to be appended."

	| aCostume |
	(aPlayer == nil or: [aPlayer == self]) ifTrue: [^ self].
	(aPlayer class == Text or: [aPlayer class == String]) ifTrue: [
		self costume class == TextFieldMorph 
			ifTrue: [^ self costume append: aPlayer]
			ifFalse: [^ self]].
	(aCostume _ self costume topRendererOrSelf) addMorphNearBack:  aPlayer costume.
	aPlayer costume goHome.  "assure it's in view"
	(aCostume isKindOf: PasteUpMorph) ifTrue:
		[self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 2/15/1999 19:18'!
beep: soundName
	Preferences soundsEnabled
		ifTrue: [self playSoundNamed: soundName]
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 09:01'!
bounce: soundName
	"If the receiver's current bounds obtrude beyond the bounds of its container, then 'bounce' it back within the container, and make the indicated sound while doing so"

	| box bounced aCostume |
	(aCostume _ self costume) ifNil: [^ self].
	(aCostume owner == nil or: [aCostume owner isHandMorph]) ifTrue: [^ self].
	box _ aCostume owner bounds.
	bounced _ false.
	(aCostume left < box left)			ifTrue: [self headRight. bounced _ true].
	(aCostume right > box right)		ifTrue: [self headLeft. bounced _ true].
	(aCostume top < box top)			ifTrue: [self headDown. bounced _ true].
	(aCostume bottom > box bottom)	ifTrue: [self headUp. bounced _ true].
	bounced ifTrue: [^ self makeBounceSound: soundName].
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 4/6/1999 12:49'!
changeScript: scriptName toStatus: statusSymbol
	| aWorld |
	scriptName ifNil: [^ self].
	Symbol hasInterned: scriptName ifTrue:
		[:sym | self instantiatedUserScriptsDo:
			[:aUserScript | aUserScript selector == sym
				ifTrue:
					[aUserScript status: statusSymbol.
					^ (aWorld _ self costume world) ifNotNil:
						[aWorld updateStatusForAllScriptEditors]]]]! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:52'!
clear

	self sendMessageToCostume: #clear.
! !

!Player methodsFor: 'scripts-standard' stamp: 'tk 1/14/2001 06:27'!
contents
	^ costume contents! !

!Player methodsFor: 'scripts-standard' stamp: 'tk 1/14/2001 06:27'!
contents: stuff
	^ costume contents: stuff! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:58'!
doMenuItem: menuString
	"Do the menu item whose wording is provided"

	self costume doMenuItem: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:59'!
followPath
	"If there is a path defined for this object, follow it now"

	self costume followPath! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 07:20'!
forward: dist 
	"Move forward (viz. in the direction of my heading) by the given amount"

	| rho radians delta didStray p aCostume |
	(aCostume _ self costume) isInWorld ifFalse: [^ self].
	aCostume isWorldOrHandMorph ifTrue: [^ self].

	rho _ (aCostume asNumber: dist) asFloat.
	radians _ (self getHeadingUnrounded asFloat - 90.0) degreesToRadians.
	delta _ (radians cos @ radians sin) * rho.

	((aCostume owner isHandMorph not) and:
	 [aCostume owner fenceEnabled]) ifTrue:
		[(aCostume owner bounds containsRect: aCostume bounds) ifFalse:
			["If I stray out of the bounds of my owner, pull me back, but
			 without changing my heading as bounce would. Do nothing if
			 bounce has already corrected the direction."
			didStray _ false.
			((aCostume left < aCostume owner left and: [delta x < 0]) or:
			 [aCostume right > aCostume owner right and: [delta x > 0]]) ifTrue: [
				delta _ delta x negated @ delta y.
				didStray _ true].
			((aCostume top < aCostume owner top and: [delta y < 0]) or:
			 [aCostume bottom > aCostume owner bottom and: [delta y > 0]]) ifTrue: [
				delta _ delta x @ delta y negated.
				didStray _ true].
			didStray ifTrue: [aCostume makeFenceSound]]].

	"use and record the fractional position"
	p _ aCostume referencePosition + delta.
	aCostume referencePosition: p.
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/7/2000 12:52'!
getObtrudes
	"Answer whether the receiver's costume obtrudes beyond the bounds of its container"

	| aCostume |
	(aCostume _ self costume) ifNil: [^ false].
	^ aCostume obtrudesBeyondContainer
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 11:05'!
goToRightOf: aPlayer
	"Place the object so that it lies directly to the right of the given object"

	| hisCostume aCostume |
	(aPlayer == nil or: [aPlayer == self]) ifTrue: [^ self].
	(hisCostume _ aPlayer costume) isInWorld ifFalse: [^ self].
	((aCostume _ self costume) owner == hisCostume owner) ifFalse:
		[hisCostume owner addMorphFront: aCostume].
	aCostume position:
		(hisCostume bounds rightCenter - (0 @ (aCostume height // 2)))! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:57'!
hide
	"Make the object be hidden, as opposed to visible"

	self costume hide! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 8/17/1998 17:18'!
initiatePainting
	(self costume isKindOf: PasteUpMorph) ifTrue:
		[self costume makeNewDrawingWithin]! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:53'!
loadSineWave

	self sendMessageToCostume: #loadSineWave.
! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:53'!
loadSound: soundName

	| snd |
	snd _ SampledSound soundNamed: soundName.
	snd ifNotNil: [self sendMessageToCostume: #loadSound: with: snd].
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 1/12/1999 16:01'!
makeNewDrawingIn: paintPlacePlayer
	| paintPlace |
	((paintPlacePlayer == nil or: [((paintPlace _ paintPlacePlayer costume) isKindOf: PasteUpMorph) not])
		or: [paintPlace isInWorld not])
			ifTrue:
				[^ self inform: 'Error: not a plausible
place in which to make
a new drawing'].
	paintPlace makeNewDrawingWithin
	
	! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/22/1999 11:50'!
menuItemAfter: menuString
	^ self costume menuItemAfter: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/22/1999 11:55'!
menuItemBefore: menuString
	^ self costume menuItemBefore: menuString! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 11:04'!
moveToward: aPlayer
	"Move a standard amount in the direction of the given player.  If the object has an instance variable named 'speed', the speed of the motion will be governed by that value"

	| angle aCostume |
	(aPlayer == nil or: [aPlayer == self]) ifTrue: [^ self].
	((aCostume _ self costume) bounds intersects: aPlayer costume bounds) ifTrue: [^ self].
	angle _ aCostume referencePosition bearingToPoint: aPlayer costume referencePosition.
	self setHeading: angle.
	self forward: self getSpeed! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:57'!
pauseScript: scriptName
	"Change the status of my script of the given name to be #paused"

	self changeScript: scriptName toStatus: #paused! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:52'!
play

	self sendMessageToCostume: #playOnce.
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/8/2000 17:05'!
removeAll
	"Remove all the elements from my companion morph's collection.  This is destructive!!"

	costume ifNotNil: [costume removeAllMorphs]! !

!Player methodsFor: 'scripts-standard' stamp: 'jm 4/22/1999 15:52'!
reverse

	self sendMessageToCostume: #reverse.
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 09:03'!
setPenDown: penDown
	"Set the penDown state as indicated, to true or false"

	| morph trailMorph tfm |
	self actorState setPenDown: penDown.
	((morph _ self costume) notNil and: [(trailMorph _ morph trailMorph) notNil])
		ifTrue:
		[tfm _ morph owner transformFrom: trailMorph.
		trailMorph notePenDown: penDown forPlayer: self
					at: (tfm localPointToGlobal: morph referencePosition)]
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 09:03'!
setPenSize: aSize
	"Set the pen size as indicated"

	self actorState setPenSize: aSize! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
show
	"Make the object be visible, as opposed to hidden"

	self costume show! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 9/8/2000 18:39'!
shuffleContents
	"Tell my costume to rearrange its submorphs randomly"

	costume shuffleSubmorphs! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
startScript: scriptName
	"Change the status of my script of the given name to be #ticking"

	self changeScript: scriptName toStatus: #ticking! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 10:56'!
stopScript: scriptName
	"Change the status of my script of the given name to be #normal"

	self changeScript: scriptName toStatus: #normal! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 1/28/2001 16:52'!
tellAllSiblings: aMessageSelector
	"Send the given message selector to all my sibling instances, but not to myself"

	self belongsToUniClass ifTrue:
		[(self class allSubInstances copyWithout: self) do:
			[:anInstance | anInstance perform: aMessageSelector]]! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 1/6/2001 06:24'!
turn: degrees
	"Rotate the heading of the object by the given number of degrees"

	degrees ifNil: [^ self].
	degrees = 0 ifTrue: [^ self].
	self setHeading: (self getHeading + degrees asFloat) \\ 360.0
! !

!Player methodsFor: 'scripts-standard' stamp: 'sw 11/28/2000 11:02'!
wrap
	"If the object has gone outside the bounds of its container, zap it over to the opposite edge of the container, providing a 'wrapping' impression "

	self costume wrap! !


!Player methodsFor: 'misc' stamp: 'sw 8/17/1998 17:17'!
actorState
	^ self costume actorState! !

!Player methodsFor: 'misc' stamp: 'sw 9/5/2000 20:13'!
allOpenViewers
	"Answer a list of all the viewers open on the receiver.  Include viewers in closed flaps"

	| aWorld all |
	(aWorld _ self costume world) ifNil: [^ #()].
	all _ aWorld allMorphs.
	aWorld closedViewerFlapTabs do:
		[:aTab | all addAll: aTab referent allMorphs].
	^ all select:
		[:m | (m isKindOf: StandardViewer) and: [m scriptedPlayer == self]]! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 15:28'!
allOpenViewersOnReceiverAndSiblings
	"Answer a list of all the viewers open on the receiver and any of its sibling instances.  Include viewers in closed flaps"

	| aWorld all |
	(aWorld _ self costume world) ifNil: [^ #()].
	all _ aWorld allMorphs.
	aWorld closedViewerFlapTabs do:
		[:aTab | all addAll: aTab referent allMorphs].
	^ all select:
		[:m | (m isKindOf: StandardViewer) and: [m scriptedPlayer class == self class]]! !

!Player methodsFor: 'misc' stamp: 'sw 9/15/1998 13:19'!
assureUniClass
	"If I am not currently a member of a UniClass, become one now"! !

!Player methodsFor: 'misc' stamp: 'sw 4/25/1998 12:51'!
basicType
	"number string boolean player collection sound color etc"
	^ #player! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/98 01:29'!
beNotZero: aNumber
	"This is a runtime check if the arg to divide in a script is zero.  If it is, put up a message from M. Mouse.  Return 0.001 instead of 0.  Note the time.  If fails again within 1 min., don't tell the user again."

	aNumber = 0 ifFalse: [^ aNumber].	"normal case"
	"We have a problem"
	TimeOfError 
		ifNil: [TimeOfError _ Time totalSeconds]
		ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [
			TimeOfError _ Time totalSeconds.	"in case user interrupt and reenter"
			PopUpMenu inform: 
'Dividing by zero makes a number too 
large for even a Sorcerer to handle.  
Please change your script.  
					-- M. Mouse'.
			TimeOfError _ Time totalSeconds]].
	^ 0.001! !

!Player methodsFor: 'misc' stamp: 'sw 1/12/1999 16:00'!
belongsToUniClass
	"UnscriptedPlayer reimplements to false"
	^ true! !

!Player methodsFor: 'misc' stamp: 'sw 1/12/1999 16:00'!
browsePlayerClass
	Browser newOnClass: self class label: 'Compiled scripts for ', self externalName! !

!Player methodsFor: 'misc' stamp: 'sw 10/24/2000 14:29'!
categoriesForViewer: aViewer
	"Answer a list of category symbols to offer as alternatives in the viewer"

	^ self categories! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/98 02:36'!
color
	^ self costume color! !

!Player methodsFor: 'misc' stamp: 'sw 8/17/1998 17:13'!
color: myColor sees: externalColor
	^ self costume color: myColor sees: externalColor! !

!Player methodsFor: 'misc' stamp: 'sw 9/8/2000 21:42'!
defaultFloatPrecisionFor: aGetSelector
	"Answer the float position to use in conjunction with a readout for aGetSelector"

	| aSlotName |
	(#(getCursor getNumericValue getNumberAtCursor getCursorWrapped) includes: aGetSelector)
		ifTrue:
			[^ 0.01].
	aSlotName _ Utilities inherentSelectorForGetter: aGetSelector.
	((self elementTypeFor: aSlotName) == #userSlot)
		ifTrue:
			[^ (self slotInfoAt: aSlotName) floatPrecision].

	^ 1! !

!Player methodsFor: 'misc' stamp: 'tk 1/3/2001 09:37'!
defaultLabelForInspector
	"Answer the default label to be used for an Inspector window on the receiver."
	^ self knownName ifNil: ['An unaffiliated Player'] ifNotNil: [self knownName]! !

!Player methodsFor: 'misc' stamp: 'sw 11/28/2000 07:25'!
dummy
	"this space for rent"! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/1999 14:04'!
getIsOverColor: aColor
	^ self seesColor: aColor! !

!Player methodsFor: 'misc' stamp: 'sw 8/17/1998 17:17'!
grabPlayerIn: aWorld
	aWorld primaryHand attachMorph: self costume
	
	! !

!Player methodsFor: 'misc' stamp: 'sw 1/29/2001 21:57'!
grabScriptorForSelector: itsSelector in: aWorld
	"Grab the scriptor for the given selector and place it in the hand"

	aWorld currentHand attachMorph: (self scriptEditorFor: itsSelector) ! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 17:55'!
isFlagshipForClass
	"Answer whether the receiver is the so-called flagshipInstance for the uniclass.  A dying thing"

	self flag: #noteToTed.
	"SyntaxMorph has the only remaining call to this; once that's been converted over, this method, and #flagshipInstance as well, can be remobved"
	^ self class flagshipInstance == self! !

!Player methodsFor: 'misc' stamp: 'sw 2/15/1999 19:18'!
makeBounceSound: soundName

	Preferences soundsEnabled
		ifTrue: [self playSoundNamed: soundName].
! !

!Player methodsFor: 'misc' stamp: 'sw 10/25/2000 23:16'!
nameForViewer
	"Answer the name to be used for the receiver in its Viewer"

	^ self getName! !

!Player methodsFor: 'misc' stamp: 'sw 7/28/1999 15:54'!
noteDeletionOf: aMorph fromWorld: aWorld
	"aMorph, while pointing to me as its costumee, has been deleted"
	"This may be too aggressive because deletion of a morph may not really mean deletion of its associated player -- in light of hoped-for multiple viewing"

	| viewers scriptors viewerFlaps |
	viewers _ OrderedCollection new.
	viewerFlaps _ OrderedCollection new.
	scriptors _ OrderedCollection new.
	aWorld allMorphs do:
		[:m | m isAViewer ifTrue: [viewers add: m].
			((m isKindOf: ViewerFlapTab) and: [m scriptedPlayer == self])
				ifTrue:
					[viewerFlaps add: m].
			((m isKindOf: ScriptEditorMorph) and: [m myMorph == aMorph])
				ifTrue: [scriptors add: m]].

	viewers do: [:v |  v noteDeletionOf: aMorph].
	viewerFlaps do: [:v  | v dismissViaHalo].
	scriptors do: [:s | s privateDelete] ! !

!Player methodsFor: 'misc' stamp: 'sw 10/25/2000 18:12'!
offerViewerMenuFor: aViewer event: evt
	"Put up the Viewer menu on behalf of the receiver."

	| aMenu aWorld  |
	aWorld _ aViewer world.
	aMenu _ MenuMorph new defaultTarget: self.
	costumes ifNotNil:
		[(costumes size > 1 or: [costumes size == 1 and: [costumes first ~~ costume renderedMorph]])
			ifTrue:
				[aMenu add: 'forget other costumes' target: self selector: #forgetOtherCostumes]].
	aMenu addLine.
	aMenu add: 'add a new instance variable' target: self action: #addInstanceVariable.
	aMenu add: 'add a new script' target: aViewer action: #newPermanentScript.
	aMenu add: 'expunge empty scripts' target: self action: #expungeEmptyScripts.
	aMenu addLine.
	aMenu add: 'tile representing me' action: #tearOffTileForSelf.
	aMenu add: 'reveal me' target: self selector: #revealPlayerIn: argument: aWorld.
	aMenu add: 'grab me' target: self selector: #grabPlayerIn: argument: aWorld.
	aMenu addLine.
	aMenu add: 'inspect morph' target: costume selector: #inspect.
	aMenu add: 'inspect player' target: self selector: #inspect.
	self belongsToUniClass ifTrue:
		[aMenu add: 'browse class' target: self action: #browsePlayerClass.
		aMenu add: 'inspect class' target: self class action: #inspect].

	aMenu popUpEvent: evt in: aWorld
! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 17:44'!
openUnderlyingScriptorFor: aSelector
	"Open the underlying scriptor for the given selector"

	self grabScriptorForSelector: aSelector in: self currentWorld! !

!Player methodsFor: 'misc' stamp: 'sw 10/27/2000 06:38'!
ordinalNumber
	"Answer a number indicating the relative position of the receiver in its stack, if any, else 1"

	| aStack |
	^ (aStack _ self stack) ifNotNil: [aStack cardIndexOf: self] ifNil: [nil]! !

!Player methodsFor: 'misc' stamp: 'sw 8/17/1998 17:21'!
presenter
	"Convenience for calling from user scripts"
	^ self costume presenter! !

!Player methodsFor: 'misc' stamp: 'sw 8/17/1998 17:14'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: (' (', self asOop printString, ')').
	self costume ifNil: [aStream nextPutAll: ' (with nil costume)'.  ^ self].
	aStream nextPutAll: ' named ', self externalName! !

!Player methodsFor: 'misc' stamp: 'sw 6/25/1998 08:42'!
revealPlayerIn: aWorld
	| aMorph |
	(aMorph _ self costume) isInWorld ifTrue: [^ aMorph goHome].

	"It's hidden somewhere; search for it"
	aWorld submorphs do:
		[:m | (m succeededInRevealing: self) ifTrue: [^ self]].

	self inform: 
'Sorry.  Unaccountably, this object
seems to be irretrievably lost'

	
	
	! !

!Player methodsFor: 'misc' stamp: 'sw 9/15/1998 14:39'!
revertToUnscriptedPlayerIfAppropriate
	| anInstance |
	((self class selectors size > 0) or: [self class instVarNames size > 0]) ifTrue: [^ self].
	anInstance _ UnscriptedPlayer new.
	anInstance initializeCostumesFrom: self.
	self become: anInstance! !

!Player methodsFor: 'misc' stamp: 'sw 1/1/1999 22:28'!
roundUpStrays
	self sendMessageToCostume: #roundUpStrays! !

!Player methodsFor: 'misc' stamp: 'sw 10/26/1998 15:45'!
seesColor: aColor
	costume isInWorld ifFalse: [^ false].
	^ costume touchesColor: aColor! !

!Player methodsFor: 'misc' stamp: 'sw 10/27/2000 06:37'!
stack
	"Answer the stack to which the receiver belongs.  This only searches via the costume's parent pointer, so there is no guarantee that the stack that is found actually contains the receiver in its card list"

	^ costume ifNotNil: [costume stack]! !

!Player methodsFor: 'misc' stamp: 'sw 1/6/1999 17:44'!
stringForReadout
	^ self externalName! !

!Player methodsFor: 'misc' stamp: 'tk 1/22/2001 14:07'!
tearOffTileForSelf
	| tiles |
	self currentHand attachMorph: (tiles _ self tileReferringToSelf).
	(tiles respondsTo: #cursorBaseOffset) ifTrue: [
		tiles align: tiles topLeft 
			 with: self currentHand position + tiles cursorBaseOffset].
! !

!Player methodsFor: 'misc' stamp: 'sw 11/6/2000 12:25'!
thumbnailMenuEvt: anEvent forMorph: aMorph
	"The mouse went down in the thumbnail of a Viewer for the receiver"

	^ self offerViewerMenuForEvt: anEvent morph: aMorph! !

!Player methodsFor: 'misc' stamp: 'tk 1/13/2001 21:37'!
tileReferringToSelf
	| aTile ww nn tile |

	"universal tiles"
	ww _ costume bestGuessOfCurrentWorld.
	(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifTrue: [
		nn _ self externalName. 	"name it, if necessary, and put in References"
		(References includesKey: nn asSymbol) ifFalse: [
			 References at: nn asSymbol put: self].
		tile _ SyntaxMorph new parseNode: 
			(VariableNode new name: nn key: nn code: nil).
		tile layoutInset: 1; addMorph: (tile addString: nn).
		tile color: (SyntaxMorph translateColor: #variable).
		tile extent: tile firstSubmorph extent + (2@2).
		^ tile].

	aTile _ TileMorph new
		setObjectRef: nil "disused parm" actualObject: self;
		typeColor: (ScriptingSystem colorForType: #player).
	aTile enforceTileColorPolicy.
	^ aTile! !

!Player methodsFor: 'misc' stamp: 'RAA 1/16/2001 17:22'!
touchesA: aPrototypicalPlayer

	| envelope myBounds trueNeighbor trueGoal trueSelf |

	aPrototypicalPlayer ifNil: [^false].
	envelope _ costume owner ifNil: [^false].
	myBounds _ costume bounds.
	trueSelf _ costume renderedMorph.
	trueGoal _ aPrototypicalPlayer costume renderedMorph.
	envelope submorphs do: [ :each |
		trueNeighbor _ each renderedMorph.
		(trueNeighbor == trueGoal or: [trueNeighbor == trueSelf]) ifFalse: [
			(myBounds intersects: each bounds) ifTrue: [
				(trueGoal appearsToBeSameCostumeAs: trueNeighbor) ifTrue: [ ^true].
			].
		].
	].
	^false
! !

!Player methodsFor: 'misc' stamp: 'sw 1/1/1999 22:27'!
unhideHiddenObjects
	self sendMessageToCostume: #unhideHiddenObjects! !

!Player methodsFor: 'misc' stamp: 'sw 11/14/2000 11:20'!
uninstallFrom: aPlayfield
	"The receiver is about to be supplanted by another instance which is about to be installed as the current 'card' in the playfield.  Exit gracefully"

	self runAllClosingScripts.
	self commitCardPlayerDataFrom: aPlayfield! !

!Player methodsFor: 'misc' stamp: 'sw 1/12/1999 16:02'!
unusedScriptName
	"answer a name of the form 'scriptN', where N is one higher than the highest-numbered similarly-named script"
	| highestThus aPair |
	highestThus _ 0.
	self class tileScriptNames do:
		[:aName |
			aPair _ aName stemAndNumericSuffix.
			aPair first = 'script' ifTrue: [highestThus _ highestThus max: aPair last]].
	^ ('script', (highestThus + 1) printString) asSymbol! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 15:35'!
updateAllViewers
	"The receiver's structure has changed, so viewers on it and its siblings need to be reconstituted."

	| aPresenter |
	(aPresenter _ self costume presenter) ifNil: [^ self].
	self allOpenViewersOnReceiverAndSiblings do:
		[:aViewer | aPresenter updateViewer: aViewer]! !

!Player methodsFor: 'misc' stamp: 'sw 1/19/2001 15:36'!
updateAllViewersAndForceToShow: aCategory
	"The receiver's structure has changed, so viewers on it and all its siblings need to be reconstituted."

	| aPresenter |
	(aPresenter _ self costume presenter) ifNil: [^ self].
	self allOpenViewersOnReceiverAndSiblings do:
		[:aViewer | aPresenter updateViewer: aViewer forceToShow: aCategory]! !

!Player methodsFor: 'misc' stamp: 'ccn 12/15/2000 19:03'!
viewerFlapTab
	"If a viewer in a flap exists for me, return it."

	(costume world ifNil: [self currentWorld])
		submorphsDo: [:mm |
			(mm isKindOf: ViewerFlapTab)
				ifTrue:
					[mm scriptedPlayer == self
						ifTrue: [^mm]]].
	^nil! !

!Player methodsFor: 'misc' stamp: 'sw 2/1/98 02:36'!
width
	^ self costume width! !



!Player methodsFor: 'fileIn/Out' stamp: 'tk 8/6/1999 17:18'!
releaseCachedState
	"release all non-showing scriptors"

	self class userScriptsDo: [:userScript | userScript releaseCachedState].! !

!Player methodsFor: 'fileIn/Out' stamp: 'tk 8/6/1999 17:14'!
storeDataOn: aDataStream
	"Discard all non-showing script editors"

	self releaseCachedState.
	super storeDataOn: aDataStream.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Player class
	instanceVariableNames: 'scripts slotInfo '!


!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 1/23/2001 11:08'!
addDocumentationForScriptsTo: aStream
	"Add documentation for every script in the receiver to the stream"

	self scripts do:
		[:aScript |
			aScript selector ifNotNil:
				[aStream cr; cr.
				self printMethodChunk: aScript selector withPreamble: false on: aStream moveSource: false toFile: nil.
				aStream position: (aStream position - 2)]].
	self scripts size == 0 ifTrue:
		[aStream cr; tab; nextPutAll: 'has no scripts']! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 10/30/2000 07:04'!
baseUniclass
	"Answer the uniclass that new instances should be instances of; this protocol allows for individual cards of a background to have their own class"

	| curr |
	curr _ self.
	[curr theNonMetaClass superclass name endsWithDigit]
		whileTrue:
			[curr _ curr superclass].
	^ curr

"CardPlayer100 baseUniclass 
CardPlayer100X baseUniclass
"! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 5/6/1998 12:27'!
flagshipInstance
	^ self someInstance  "The first one created is the real deal"! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 5/6/1998 12:16'!
initialInstance
	self == Player ifTrue: [self error: 'must not instantiate naked Player'].
	^ super initialInstance! !

!Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 8/2/1998 22:52'!
tileScriptNames
	scripts ifNil: [^ OrderedCollection new].
	"The following is an emergency workaround for damaged script dictionaries occurring in Alan's demo image 8/2/98; no selector should be nil but somehow some is, so here we filter such damaging things out"
	^ scripts collect: [:aScript | aScript selector] thenSelect: [:n | n ~~ nil]! !


!Player class methodsFor: 'slots' stamp: 'sw 12/18/1998 21:08'!
compileAccessorsFor: varName
	^ self compileInstVarAccessorsFor: varName! !

!Player class methodsFor: 'slots' stamp: 'sw 12/18/1998 21:09'!
compileInstVarAccessorsFor: varName
	| nameString |

	nameString _ varName asString capitalized.
	self compileUnlogged: ('get', nameString, '
	^ ', varName)
		classified: 'access' notifying: nil.
	self compileUnlogged: ('set', nameString, ': val
	', varName, ' _ val')
		classified: 'access' notifying: nil! !

!Player class methodsFor: 'slots' stamp: 'tk 8/31/1998 15:45'!
privateSlotInfo
	"for copying"
	^ slotInfo! !

!Player class methodsFor: 'slots' stamp: 'sw 12/17/1998 20:30'!
removeAccessorsFor: varName
	^ self removeInstVarAccessorsFor: varName! !

!Player class methodsFor: 'slots' stamp: 'sw 12/17/1998 20:31'!
removeInstVarAccessorsFor: varName
	| nameString |

	nameString _ varName asString capitalized.
	self removeSelector: ('get', nameString) asSymbol.
	self removeSelector: ('set', nameString, ':') asSymbol! !

!Player class methodsFor: 'slots' stamp: 'di 1/19/2000 17:18'!
removeInstVarName: aName
	self removeInstVarAccessorsFor: aName.
	super removeInstVarName: aName.
	self slotInfo removeKey: aName asSymbol ifAbsent: []! !

!Player class methodsFor: 'slots' stamp: 'sw 5/19/2000 16:37'!
renameSilentlyInstVar: oldName to: newName
	(instanceVariables includes: oldName asString) ifFalse:
		[self error: oldName , ' is not defined in ', self name].
	self removeAccessorsFor: oldName.

	super renameSilentlyInstVar: oldName to: newName.
	self compileAccessorsFor: newName.
	slotInfo at: newName asSymbol put: (slotInfo at: oldName).
	slotInfo removeKey: oldName! !

!Player class methodsFor: 'slots' stamp: 'sw 4/8/98 11:58'!
slotInfo
	slotInfo ifNil: [slotInfo _ IdentityDictionary new].
	^ slotInfo! !

!Player class methodsFor: 'slots' stamp: 'tk 8/31/1998 15:44'!
slotInfo: aDict
	"for copying"
	slotInfo _ aDict! !


!Player class methodsFor: 'other' stamp: 'tk 6/26/1998 18:21'!
chooseUniqueClassName
	| ii className |
	ii _ BiggestSubclassNumber ifNil: [1] ifNotNil: [BiggestSubclassNumber+1].
	[className _ (self name , ii printString) asSymbol.
	 Smalltalk includesKey: className]
		whileTrue: [ii _ ii + 1].
	BiggestSubclassNumber _ ii.
	^ className	

! !

!Player class methodsFor: 'other' stamp: 'sw 8/17/1998 07:33'!
isSystemDefined
	^ name endsWithDigit not! !

!Player class methodsFor: 'other' stamp: 'tk 3/15/98 20:23'!
officialClass
	"We want to make a new instance of the receiver, which is a subclass of Player.  Answer who to make a new subclass of.  Also used to tell if a given class is a UniClass, existing only for its single instance."
	^ Player! !

!Player class methodsFor: 'other' stamp: 'sw 10/13/2000 16:44'!
wantsChangeSetLogging
	"Log changes for Player itself, but not for automatically-created subclasses like Player1, Player2, but *do* log it for uniclasses that have been manually renamed."

	^ self == Player or:
		[(self name beginsWith: 'Player') not]! !

!Player class methodsFor: 'other' stamp: 'sw 7/31/2000 12:57'!
wantsRecompilationProgressReported
	"Report progress for Player itself, but not for automatically-created subclasses like Player1, Player2"

	^ self == Player or:
		[(self class name beginsWith: 'Player') not]! !


!Player class methodsFor: 'scripts' stamp: 'sw 1/23/2001 18:46'!
atSelector: aSelector putScriptEditor: aScriptEditor
	"Place the given script editor in my directory of script editors, at the given selector"

	| selSym  aUniclassScript |
	selSym _ aSelector asSymbol.
	scripts ifNil: [scripts _ IdentityDictionary new].
	aUniclassScript _ scripts at: selSym ifAbsent: [nil].
	aUniclassScript ifNil:
		[aUniclassScript _ UniclassScript new playerClass: aScriptEditor playerScripted class selector: selSym.
		scripts at: selSym put: aUniclassScript].
	aUniclassScript currentScriptEditor: aScriptEditor! !

!Player class methodsFor: 'scripts' stamp: 'sw 4/9/98 21:55'!
jettisonScripts
	scripts _ IdentityDictionary new! !

!Player class methodsFor: 'scripts' stamp: 'sw 1/25/2001 16:24'!
namedTileScriptSelectors
	"Answer a list of all the selectors of named tile scripts"

	scripts ifNil: [^ OrderedCollection new].
	^ scripts select: [:aScript | aScript selector ~~ nil] 
		thenCollect: [:aScript | aScript selector]! !

!Player class methodsFor: 'scripts' stamp: 'sw 1/23/2001 18:31'!
permanentUserScriptFor: aSelector player: aPlayer
	"Create and answer a UserScript object for the given player (an instance of the receiver) and selector.  Save that UniclassScript in my (i.e. the class's) directory of scripts"

	|  entry |
	scripts ifNil: [scripts _ IdentityDictionary new].
	entry _ UniclassScript new playerClass: aPlayer class selector: aSelector.
	scripts at: aSelector put: entry.
	^ entry! !

!Player class methodsFor: 'scripts' stamp: 'tk 8/31/1998 15:42'!
privateScripts
	"for copying"
	^ scripts! !

!Player class methodsFor: 'scripts' stamp: 'sw 12/28/1998 14:22'!
removeScriptNamed: aScriptName
	aScriptName ifNotNil:
		[scripts removeKey: aScriptName.
		self removeSelectorUnlogged: aScriptName]! !

!Player class methodsFor: 'scripts' stamp: 'sw 5/19/1998 09:44'!
scripts
	scripts ifNil: [scripts _ IdentityDictionary new].
	^ scripts! !

!Player class methodsFor: 'scripts' stamp: 'tk 8/31/1998 15:41'!
scripts: aDict
	"for copying"
	scripts _ aDict! !

!Player class methodsFor: 'scripts' stamp: 'tk 1/22/2001 14:54'!
tilesFrom: aString
	| code tree syn block phrase |
	"Construct SyntaxMorph tiles for the String."

	"This is really cheating!!  Make a true parse tree later. -tk"
	code _ String streamContents: [:strm | 
		strm nextPutAll: 'doIt'; cr; tab.
		strm nextPutAll: aString].
	"decompile to tiles"
	tree _ Compiler new 
		parse: code 
		in: self
		notifying: nil.
	syn _ tree asMorphicSyntaxUsing: SyntaxMorph.
	block _ syn submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == BlockNode] ifFalse: [false]].
	phrase _ block submorphs detect: [:mm | 
		(mm respondsTo: #parseNode) ifTrue: [
			mm parseNode class == MessageNode] ifFalse: [false]].
	^ phrase

! !

!Player class methodsFor: 'scripts' stamp: 'sw 1/25/2001 10:29'!
userScriptForPlayer: aPlayer selector: aSelector
	"Answer the user script for the player (one copy for all instances of the uniclass) and selector"

	|  entry existingEntry |
	scripts ifNil: [scripts _ IdentityDictionary new].
	existingEntry _ scripts at: aSelector ifAbsent: [nil].
	(existingEntry isKindOf: UniclassScript)
		ifFalse:
			[entry _ UniclassScript new playerClass: aPlayer class selector: aSelector.
			scripts at: aSelector put: entry.
			existingEntry ifNotNil: "means it is a grandfathered UserScript that needs conversion"
				[entry convertFromUserScript: existingEntry]]
		ifTrue:
			[entry _ existingEntry].
	^ entry! !

!Player class methodsFor: 'scripts' stamp: 'sw 4/14/1998 01:16'!
userScriptsDo: aBlock
	self scripts do:
		[:aUserScript | aBlock value: aUserScript]! !


!Player class methodsFor: 'namespace' stamp: 'sw 10/27/2000 06:59'!
compileReferenceAccessorFor: varName
	"Compile reference accessors for the given variable.  If the #capitalizedReferences preference is true, then nothing is done here"

	Preferences capitalizedReferences ifTrue: [^ self].

	self class compileUnlogged: ((self referenceAccessorSelectorFor: varName), '
	^ ', varName)
		classified: 'reference' notifying: nil! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/27/1998 23:42'!
makeReferenceFor: anObject

	| stem otherNames i partName |
	stem _ anObject class name.
	(stem size > 5 and: [stem endsWith: 'Morph'])
		ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
	stem _ stem first asLowercase asString, stem allButFirst.
	otherNames _ self class allInstVarNames.
	i _ 1.
	[otherNames includes: (partName _ stem, i printString)]
		whileTrue: [i _ i + 1].
	self class addInstVarName: partName.
	self instVarAt: self class instSize put: anObject.  "assumes added as last field"

	self compileReferenceAccessorFor: partName.
	^ self referenceAccessorSelectorFor: partName! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/27/1998 23:38'!
referenceAccessorSelectorFor: varName
	^ 'ref', (varName asString capitalized)! !

!Player class methodsFor: 'namespace' stamp: 'sw 4/28/1998 00:03'!
referenceSelectorFor: anObject
	self class instVarNames do:  "Just those added in the unique subclass"
		[:aName | (self instVarNamed: aName) == anObject
			ifTrue:
				[^ self referenceAccessorSelectorFor: aName]].
	^ self makeReferenceFor: anObject! !


!Player class methodsFor: 'housekeeping' stamp: 'ls 10/10/1999 13:42'!
abandonUnnecessaryUniclasses
	"Player abandonUnnecessaryUniclasses"
	| oldCount oldFree newFree newCount report |
	oldCount _ self subclasses size - 1.
	oldFree _ Smalltalk garbageCollect.
	self allSubInstances do:
		[:aPlayer | aPlayer revertToUnscriptedPlayerIfAppropriate.  
		"encourage last one to get garbage-collected"
		aPlayer _ nil ].

	ScriptingSystem spaceReclaimed.
	newFree _ Smalltalk garbageCollect.
	newCount _ self subclasses size - 1.
	report _ 'Before: ', oldCount printString, ' uniclasses, ', oldFree
printString, ' bytes free
After:  ', newCount printString, ' uniclasses, ', newFree printString, '
bytes free'.
	Transcript cr; show: 'abandonUnnecessaryUniclasses:'; cr; show: report.
	^ report
	! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 5/19/2000 16:26'!
cleanseSlotInfo
	| newInfo |
	slotInfo ifNotNil:
		[newInfo _ IdentityDictionary new.
		slotInfo associationsDo:
			[:assoc | newInfo at: assoc key asSymbol put: assoc value].
		slotInfo _ newInfo]
! !

!Player class methodsFor: 'housekeeping' stamp: 'ls 10/10/1999 13:41'!
freeUnreferencedSubclasses
	"Player classes may hold in their class instance variables references
to instances of themselves that are housekeepingwise unreachable. This
method allows such loops to be garbage collected. This is done in three
steps:
	1. Remove user-created subclasses from the 'subclasses' set and from
Smalltalk. Only remove classes whose name begins with 'Player' and which
have no references.
	2. Do a full garbage collection.
	3. Enumerate all Metaclasses and find those whose soleInstance's
superclass is this class. Reset the subclasses set to this set of
classes, and add back to Smalltalk."
	"Player freeUnreferencedSubclasses"

	| oldFree candidatesForRemoval class |
	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _ self subclasses asOrderedCollection select:
		[:aClass | (aClass name beginsWith: 'Player') and: [aClass name
endsWithDigit]].

	"Break all system links and then perform garbage collection."
	candidatesForRemoval do:
		[:c | self removeSubclass: c.  "Break downward subclass pointers."
		Smalltalk removeKey: c name ifAbsent: [].  "Break binding of global
name"].
	candidatesForRemoval _ nil.
	Smalltalk garbageCollect.  "Now this should reclaim all unused
subclasses"

	"Now reconstruct system links to subclasses with valid references."
	"First restore any global references via associations"
	(Association allSubInstances select:
			[:assn | (assn key isMemberOf: Symbol)
					and: [(assn key beginsWith: 'Player')
					and: [assn key endsWithDigit]]])
		do: [:assn | class _ assn value.
			(class isKindOf: self class) ifTrue:
				[self addSubclass: class.
				Smalltalk add: assn]].
	"Then restore any further direct references, creating new
associations."
	(Metaclass allInstances select:
			[:m | (m soleInstance name beginsWith: 'Player')
					and: [m soleInstance name endsWithDigit]])
		do: [:m | class _ m soleInstance.
			((class isKindOf: self class) and: [(Smalltalk includesKey: class
name) not]) ifTrue:
				[self addSubclass: class.
				Smalltalk at: class name put: class]].
	SystemOrganization removeMissingClasses.
	^ Smalltalk garbageCollect - oldFree
! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 10/23/1999 22:50'!
isUniClass
	"UnscriptedPlayer reimplements to false"
	^ true! !

!Player class methodsFor: 'housekeeping' stamp: 'tk 8/12/1999 15:45'!
playersWithUnnecessarySubclasses
	"Return a list of all players whose scripts dictionaries contain entries with nil selectors"
	"Player playersWithUnnecessarySubclasses size"
	^ self class allSubInstances select:
		[:p | p class isSystemDefined not and: [p scripts size == 0 and: [p instVarNames size == 0]]] ! !

!Player class methodsFor: 'housekeeping' stamp: 'sw 8/11/1998 13:23'!
removeUninstantiatedSubclassesSilently
	"Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
	"Player removeUninstantiatedSubclassesSilently"

	| candidatesForRemoval  oldFree |

	oldFree _ Smalltalk garbageCollect.
	candidatesForRemoval _
		self subclasses select: [:c |
			(c instanceCount = 0) and: [c subclasses size = 0]].
	candidatesForRemoval _ candidatesForRemoval select:
		[:aClass | aClass isSystemDefined not].
	candidatesForRemoval do: [:c | c removeFromSystemUnlogged].
	^ Smalltalk garbageCollect - oldFree! !
Player subclass: #Player1
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-UserObjects'!

!Player1 methodsFor: 'access'!
getIndex
	^ index! !

!Player1 methodsFor: 'access'!
setIndex: t1 
	index _ t1! !
Player subclass: #Player2
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-UserObjects'!

!Player2 methodsFor: 'access'!
getIndex
	^ index! !

!Player2 methodsFor: 'access'!
setIndex: t1 
	index _ t1! !
Player subclass: #Player3
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-UserObjects'!

!Player3 methodsFor: 'access'!
getIndex
	^ index! !

!Player3 methodsFor: 'access'!
setIndex: t1 
	index _ t1! !
Player subclass: #Player4
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-UserObjects'!

!Player4 methodsFor: 'access'!
getIndex
	^ index! !

!Player4 methodsFor: 'access'!
setIndex: t1 
	index _ t1! !
ThumbnailMorph subclass: #PlayerReferenceReadout
	instanceVariableNames: 'putSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!
!PlayerReferenceReadout commentStamp: '<historical>' prior: 0!
A thumbnail that serves as the value readout for a player-valued slot in a Viewer.  Clicking on it allows the user to select a new object for the slot to point to. !


!PlayerReferenceReadout methodsFor: 'as yet unclassified' stamp: 'sw 4/26/1998 02:02'!
handlesMouseDown: evt
	"Allow the user to respecify this by direct clicking"
	^ true! !

!PlayerReferenceReadout methodsFor: 'as yet unclassified' stamp: 'sw 8/11/1998 16:47'!
mouseDown: evt
	"Allow the user to respecify this by direct clicking"
	| aMorph |
	putSelector == #unused ifTrue: [^ self].

	Sensor waitNoButton.
	aMorph _ self world chooseClickTarget.
	aMorph ifNil: [^ self].
	objectToView perform: putSelector with: aMorph assuredPlayer.
	self changed! !

!PlayerReferenceReadout methodsFor: 'as yet unclassified' stamp: 'sw 4/26/1998 02:07'!
objectToView: objectOrNil viewSelector: aSelector putSelector: aPutSelector
	self objectToView: objectOrNil viewSelector: aSelector.
	putSelector _ aPutSelector! !
Object subclass: #PlayingCard
	instanceVariableNames: 'cardNo suit suitNo cardForm '
	classVariableNames: 'ASpadesLoc CachedBlank CachedDepth CardSize FaceForms FaceLoc FaceSuitLoc MidSpotLocs NumberForms NumberLoc SuitForms SuitLoc TopSpotLocs '
	poolDictionaries: ''
	category: 'Morphic-Games'!
!PlayingCard commentStamp: '<historical>' prior: 0!
This class assembles card images from their parts.  The images are broken down so that the image data is very compact, and the code is written to display properly at all color depths.  The method imageData may be removed after initialization to save space, but must be re-built prior to fileOut if you wish to retain the images.

To use in morphic, one can simply put these forms into ImageMorphs (see example in buildImage).  However it should be possible to define a subclass of ImageMorph that simply creates playingCard instances on the fly whenever the image form is needed.  This would avoid storing all the images.!


!PlayingCard methodsFor: 'all' stamp: 'di 10/18/1999 23:38'!
blankCard 

	CachedDepth = Display depth ifFalse:
		[CachedDepth _ Display depth.
		CachedBlank _ Form extent: CardSize depth: CachedDepth.
		CachedBlank fillWhite; border: CachedBlank boundingBox width: 1.
		CachedBlank fill: (0@0 extent: 2@2) fillColor: Color transparent.  "Round the top corners"
		CachedBlank fill: (1@1 extent: 1@1) fillColor: Color black.
		CachedBlank fill: (CachedBlank width-2@0 extent: 2@2) fillColor: Color transparent.
		CachedBlank fill: (CachedBlank width-2@1 extent: 1@1) fillColor: Color black].
	^ CachedBlank! !

!PlayingCard methodsFor: 'all' stamp: 'ar 5/28/2000 12:10'!
buildImage     "(PlayingCard the: 12 of: #hearts) cardForm display"
	"World addMorph: (ImageMorph new image: (PlayingCard the: 12 of: #hearts) cardForm)"
	"PlayingCard test"
	| blt numForm suitForm spot face ace sloc colorMap fillColor |
	
	"Set up blt to copy in color for 1-bit forms"
	blt _ BitBlt current toForm: cardForm.
	fillColor _ self color.
	colorMap _ (((Array with: Color white with: fillColor)
				collect: [:c | c pixelWordForDepth: cardForm depth])
					 as: Bitmap).

	blt copy: cardForm boundingBox from: 0@0 in: self blankCard.  "Start with a blank card image"
	numForm _ NumberForms at: cardNo.  "Put number in topLeft"
	blt copyForm: numForm to: NumberLoc rule: Form over colorMap: colorMap.

	suitForm _ SuitForms at: suitNo*3-2.   "Put small suit just below number"
	sloc _ SuitLoc.
	cardNo > 10 ifTrue:
		[suitForm _ SuitForms at: suitNo*3-1.   "Smaller for face cards"
		sloc _ SuitLoc - (1@0)].
	blt copyForm: suitForm to: sloc rule: Form over colorMap: colorMap.

	cardNo <= 10
	ifTrue:
		["Copy top-half spots to the number cards"
		spot _ SuitForms at: suitNo*3.   "Large suit spots"
		(TopSpotLocs at: cardNo) do:
			[:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]]
	ifFalse:
		["Copy top half of face cards"
		face _ FaceForms at: suitNo-1*3 + 14-cardNo.
		blt colorMap: self faceColorMap;
			copy: (FaceLoc extent: face extent) from: 0@0 in: face].

	"Now copy top half to bottom"
	self copyTopToBottomHalf.

	cardNo <= 10 ifTrue:
		["Copy middle spots to the number cards"
		(MidSpotLocs at: cardNo) do:
			[:loc | blt copyForm: spot to: loc rule: Form over colorMap: colorMap]].
	(cardNo = 1 and: [suitNo = 4]) ifTrue:
		["Special treatment for the ace of spades"
		ace _ FaceForms at: 13.
		blt colorMap: self faceColorMap;
			copy: (ASpadesLoc extent: ace extent) from: 0@0 in: ace]
	! !

!PlayingCard methodsFor: 'all' stamp: 'di 10/18/1999 23:31'!
cardForm

	^ cardForm! !

!PlayingCard methodsFor: 'all' stamp: 'di 10/15/1999 09:12'!
color
	CachedDepth = 1 ifTrue: [^ Color black].
	CachedDepth = 2 ifTrue: [^ Color perform: (#(black gray gray black) at: suitNo)].
	^ Color perform: (#(black red red black) at: suitNo)! !

!PlayingCard methodsFor: 'all' stamp: 'ar 5/28/2000 12:13'!
copyTopToBottomHalf
	"The bottom half is a 180-degree rotation of the top half (except for 7)"
	| topHalf corners |
	topHalf _ 0@0 corner: cardForm width@(cardForm height+1//2).
	corners _ topHalf corners.
	(WarpBlt current toForm: cardForm)
		sourceForm: cardForm;
		combinationRule: 3;
		copyQuad: ((3 to: 6) collect: [:i | corners atWrap: i])
		toRect: (CardSize - topHalf extent corner: CardSize).
	! !

!PlayingCard methodsFor: 'all' stamp: 'di 10/14/1999 20:17'!
faceColorMap
	| map |
	map _ Color colorMapIfNeededFrom: 4 to: Display depth.
	^ map! !

!PlayingCard methodsFor: 'all' stamp: 'di 10/18/1999 23:23'!
setCardNo: c suitNo: s cardForm: f
	cardNo _ c.
	suitNo _ s.
	cardForm _ f.
	self buildImage! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayingCard class
	instanceVariableNames: ''!

!PlayingCard class methodsFor: 'all' stamp: 'di 10/13/1999 17:26'!
imageData ^ 'AgQALwAlAAAAAIDjaN4VEeFDEREREBIiIiIiIiIiIYiBiIGIgYiIiIgSIiIiEBIiIiIREiIiIhgRGBEYERiBiIEiIiIiEBIiIiERESIiIiFEREREREQRGBIiIiIiEBIiIhERERIiIiIRERERERFEQSIiIiISEBIiIhERERIiIiIRERERERERESIiIiEREBIiIhERERIiIiESIiIiISERESIiIhIUEBIiIiERESIiIhISIiIiISEhESIiIhIUEBIiERIREhESIhIRESERESEhISIiIhIUEBIhERERERERIhEREhESESEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIREREREREREhISIhIiISEhISIiIhIUEBIhEREhIRERIhISIREiISEhISIiIhIUEBIiERIKISIREuIfIhEhISEhESIiEhQQEiIiIhESIiIhERIhESIhISEhIhIiEhQQEiIiIRERIiIiEhIiIiIhISISEhEiEhQQEiIiIiIiIiIREhISIhIRISERIRQREhQQEiIiIiIiIiEiEhISEhISESEhIUREEhQQEiIiIiIiIiEhIhISEhIRISIhFIREEhQQEiIiIiIiEREiISEhQSEiFBEUSIREEhQQEiIiIiERERERERQURBQRREQURESBEhQQEiIiERRBiBEhGBFERERERBFIREQSEhQQEiIhREREGIEREYERREREERSIRIEiEhQQEiEUJCQkIYgRIYGBEUQRGBRERBIhEhQQEhEURERERBiBERgYERERgUREgSIREhQQFBESQkJCQkGIERgYgREYgUhEQSEREhQQFBEUREREREEYQRGBGBGBFIhEEiEREhQQFBEUJCQkJCERhBGBiIiIFERIEhFBEhQQFBEUREQREUEUGBEYERQRFEREEhEREhQQEYgRQkEiIhEREYEYGIiIFISBIhFBEhQQGIiBRBIhEiEUQYEYERQRSIRBIREREhQQEYgRFBIUQSERERgRgYiBRESBIRERERQQERERERIUQSEURBgRgRQRRERBIREiEiEQEUQRERIhEiERERGBgYiBRISBIRIiIREQEREREREiIhERERERERERSIRBIRIRIiEQESISIREREUQSIiFEQRERFESBIRIiEREQBAAvACUAAAAAgONk3hURExERERAYiIiIiIQRQhISESEJIuNPIiIiEBGIiIiIhBFCESEhESIiIiIiIhESIiIiEBIYiIgRhBFCEiESESIiIiIiIRERIiIiEBIhiIgYRBFCEhIhISIiIiIiEREREiIiEBIhiIiEQRRCESIiERIiIiIiEREREiIiEBIiGIiEQRQiEiIiIRIiIiIiEREREiIiEBIiGBGEERQiERIREUEiIiIiIRERIiIiEBIiGBhEEUQhIRIhEUEiIiIREhESERIiEBIhiIRBEUIhIiEiIRQSIiEREREREREiEBIhiIRBFEISIiEiIRQSIhERERERERESEBIYEUQRRCISIiEiIRFBIhERERERERESEBGIFEERQiEiIhESIUFEEhERERERERESEBIRRBEUQiEiIiIiIUQUQSERESEhEREiEBIiERFEIhQSIhESERQRRBIREiEiERIiEBIiIRFCIhFBIiEiERFBFEEiIhESIiIiEBIiERRCIRgREiIhgREUEUQSIRERIiIiEBIhEUQhFISBgREYFIhBRBFBIiIiIiIiEBIRFEISIUhEgYGESIQSFEEUEiIRIiIiEBERQRERERSIRERIiEEREUQUEiFEESIiEBEUiIERESEUiIiIRBISGBQUEhQRRBIiEBGIGIgSISIRFBEUESIRgYFBIUREQSIiEBiIgYGBISERIURBIREYiBESIhEUEhESEBRERBiIEREhIUhBISGBgRGBIiIhIYiBEBREREGIGBEhIURBIRiIFBGBEhESGIESEBREREQRiIgRERQREYGBRBGBEYiBEREiEBgYGBREEYGIiBEYiIERhBGBGIgSEiISEBGBgYGBRBEYiIiIgRERhEEYERESIRESEBgYEREREUSBERERERgRhEERRBQRISISEBGBGIiIiBFEgREYEYEYREQUIkERERESEBgYiBERGIgUQRERgYEYREGBQkQUEiISEBGIERgYERiBSBERGBEYRBiBFERBEREiEBQRGBgYGBGIFBERgYEYRBgYgUIkFBIiEBRBGBEREYgYFIEYERgYQYgRERQkQREiEBQkEUREQREYgUGBEREYQYGIFEFERBQSEBQiQUIiRBiBgRERGIEREYERFCIUIkEREBFERBIRJBERgURBREQYgYGIFCEhQkQUEAQALwAlAAAAAIDjaN4VEeE/EREREBIiIiEUFEFEQUFEFBREFBIiIiIiIiIiEBEiIiIRQUQUQUFEFBRBQSIiIhESIiIiEBQSIiIhFBRBEUERFBEUEiIiIRERIiIiEBRBIiIiFERERERERERBEiIiEREREiIiEBREEiIiERERERERERERIiIiEREREiIiEBERESIiGBIiIiIhgYGBIiIiEREREiIiEBiIEiIiGBIiIiIhgYGBIiIiIRERIiIiEBGIEiIiGBERIREhgYGBIiIREhESERIiEBiIEiIiGBESERIRgYGBIiEREREREREiEBGIEiIiGBIiEiIhgYGBIhERERERERESEBiIEiIhGBIiEiIhgYGBIhERERERERESEBGIEiIYGBIiEiIhgYGBIhERERERERESEBiIEiIYGBIhESIhgYGBEiERESEhEREiEAoRGBIi4iMiIiGBgRiBIhESISIREiIQGIgSIYgYISERIiGBEYgRIiIiERIiIiIQERgSIYGIESIiIhGBiBERESIhEREiIiIQGIgSIYiBFBIiIUGBGBESEhIiIiIiIiIQGIgRIhEUFEERFEQYiBEhEkESIiIiIiEQEYEiEUFBFERBFEQREREYEkRBEiIiIhgQEhIiIRQUFIhBEUESIRIYEkSEIRIiIYgQERERIUFBFERBIREiESGIEkiIQhERGIgQEiESIRQUFIhBIhIhEhiIEohIghERGIgQERgSIUFBFERBEiIRIYgREkiIQhERGIgQEhgSIRQUFIhBESESQYiIEkSEQhERGIgQEYgSIUFBFERBIREkGIEREkREQhERGIgQEhgSFBQRFIhBEhIRiIiIEkSEQhERGIgQEYgREUERFERBQSFBgYEREkiIQhERGIgQGIgRERERSIQYFBQYiIiIEohIghERGIgQGIgRIREhREQRgUGBgREREkiIQRFEGIgQGIgSIhIhSIQYiBiIiIiIEkSEQUSIGIgQGIgSEiIRREQREYgYEREREhERREREGIgQGIgRISEhSIQYiIiIiIiIESIUSIREGIgQGIgSEhIRREQRhBgRGBSBIiFEREQRGIgQGIgRISEkiEGIgUEiIUESIiFIhEESGIgQGIgSEhIUREEYiBIREhIiIhRERBISGIgQGIgRISEUiEGBESFEQSEiIRSIQSEhGIgQBAAvACUAAAAAgONg3hUR4dsREREQEiIiIiIiIhiIgYiBiIiIiIiIgSIiIiIQEiIiIkIiIiGIERgRGIGIiIiIEiIREiEQEiIiJEQiIiIURERESBEYgYiBIiGBIhQQEiIiRERCIiIRERERFERIERgRIhiBIhQQEiIpRERJIiIhEREREREUREQSIhiBIhQQEiKUREREkiIhIiIiESERERESIYgSEREQEiKUREREkiIhIRIiEhIRERESIYEiQkIQEiRERERERCIhESEiEhISEhISIRIiQkIQEkREREREREImIiIiEhISEhISIYEiEhIQEiRERERERCISIiIiEhISEhISIYgSEREQEiKUREREkiEiIiIiEhISEhISIhiBIhQQEiKUREREkiEWIiIiISEhISEhIhiBIhQQEiIpRERJIiIhERISISEhISEhIiGBIhQQEiIiRERCIiIhIhESIhISEhISEiIREhQQEiIiJEQiIiIiESIiIiEhISEhISIiIhQQEiIiIkIiIiIhIiIiERIhISEhISIiIhQQEiERIiIiIiIhEiIhIiEhISEhISIiIhQQEhISERIiIhEhIiIhIRIhISEhISIiIhQQEhEhISEiISESIiIhEiISEhISEiIiIhQQERISEhISISIiIiIiCRFbIiIUEBEhISIiIRgSIiIRERERiBIiGIEiEREREBISEiIhERGBEREREREhGIEhEYgSIYgSEBIhIhERFEEYERRBERIRIYgREhiBIRiBEBIiEUEYFEERgUFEEQkR4ScRIYIQEhFEREGBEhGBRBQRiIiIiIiIiBEREREQEUREQRgYEUQRFEESEhISEhISIYEREREQFERBGIiBgUQYERIiIiIiIiIiGBRBEiEQFEEYiIERGBEYEiIRERERERIhgYFEESEQFBiIgRERGBIYEhGIiIiIiBIYEUgUQREQEYiBEREhGBEYEYgRERERgSGBiBSBRBEQGIgRESIhEYERGBERREQYEiGBGIFIFEEQGIFEERIiEYERgRFEREQYEhgREYEREREQGBQUQREiEYERgRERERGBIhgRERSBSBQQEYhBRBESERgRgUREREGBIYERGBSBSBQQEUiEFEERIRgRgRERERgSIYEUSBQREREQFEFIhBERERERGBIiIhgRERERERSIQUQQBAAvACUAAAAAgONo3hUR4bsREREQEhiIiIiIFEEiEhIRgSIiIiIiIiIiIiIQEiGIiIEYFEEhISEhiBIiIiIiIkIiIiIQEiGIiIiIFEEiIRIRGBIiIiIiJEQiIiIQEiIYiIEYFEEiEiEhEYEiIiIiRERCIiIQEiIYiIiBFBIRIiIRERgSIiIpRERJIiIQEiIYiBGBRBEiIiIhQRgSIiKUREREkiIQEiIYiIgRQSIREhERQRGBIiKUREREkiIQEiIYgRgUQSEhESERRBGBIiRERERERCIQEiIYiIEUESIiISIhRBEYEkREREREREIQEiGIEYFEEhIiISIhREEYEiRERERERCIQEiGIiBFBISEiISIhREEYEiKUREREkiIQEhiBgRRBIRIiERIhREEYEiKUREREkiIQEiGIEUQSISIiIiIhREQRgSIpRERJIiIQEiIRFEEiFBIiERIYFEQRgSIiRERCIiIQEiIhRBIiEUEiISIYEUQRgSIiJEQiIiIQEiIUQSIhiBESIiGIEhQRgSIiIkIiIiIQEiFEERESGIgRERGIEhERgSIiIiIiIiIQEhRBEhERIREYiIERIRERgSIiIhESIiIQEUQRIQohERIi4acREhGBIiIRiBEiIhAUQSESERERESIiIhESERgRIiIYEYgSEhAUGBIRESESEREREREhIRGBIiGIiIEiERAREYEhEREhIRESERESERIYEiIRGBIhgRARGBgSEREhISEhISERESGIESIiIRIYgRARgRGBIhESEREhIREREhiBERIiIhGBEhAYEUEYESERERESERESIYGBEhEiIRERIhARFBGBiBEYERERERIhGBGBIRESEiIREhARQRgUEYgRESIiIiEYgRGBIRERIhESEhAUEYERQhGIgRERERiBEUGBIREYEiEhEhARGBFBFCERGIiIiIEYEUGBEhGIESISEhARgRgUEUJBgRERERiIEUIYERiBERISEhAYERgRQSQhGBERGIEYEUIYgYgSEhEhIhASEhGBQUJCGBJBGIiIEUJBiIERERESIhARERGBQSQhGBJBGBEYEUEUGBESEhIRIhASEhIYEUJCGBJBGIiIERRBgRgREREREhAREREYFCQhGBERERERREhBgUGBEhISERASEhIRgUJCGBREREREiIQYESQYERERERAEAC8AJQAAAACA42neFRHjZxERERASIiIiIhQkRCRCRCRCRCQRIiIiIiIiIhASIiIiIiFCRCRCRCRCQkESIiIiQiIiIhASIiIiIiIUIiRCIiRCJBEiIiIkRCIiIhARIiIiIiIhRERERERERBIiIiJEREIiIhAREiIiIiIhERERERERERIiIilEREkiIhARgSIiIiIhERGBIiIiIhEiIpRERESSIhARgSIiIiIhEYGBIiIiIhEiIpRERESSIhARgSIiIiIhgYGBIREhERgSJEREREREIhARgSIiEiIhgYGBEhESERgSREREREREQhARgSIhEiIhgYGBIiISIhgSJEREREREIhARgSEYEiIhgYGBIiISIhgSIpRERESSIhARERiBIiIhgYGBIiISIhgSIpRERESSIhAUiIERIiIhgYGBIiERIhgSIilEREkiIhARgRESIiIhgYGBIiIiIhgREiJEREIiIhAUgRIiIiEYgYGBIiERISgYgSIkRCIiIhARgSIiIhiBgYGBEiIiIRiBgSIiQiIiIhAUgSIiIhgRgRgUISIiEkGIgSIiIiIiIRARgSIiIhiIGIFERBERREQRERIiIiIiFBAUgSIiIhERERFEREREREESGBESIiIhgRARgSIiEUERIRERREREQRERGBIREiIhhBAUgSIRGBQRESEREREREREhGBEYgRIhgRARgREREYFBEREhERERESERGBIYgUERhBAUgRERERgUERERISEhIRFBGBERgURBgRARgRFBERGBQREREREREUFBGIEhiBFBhBARESEUEREYFBFBQUFBQUFBIYERGIgRgRASISGBQRERgUEUhISEhISBIYgSERiBhBARESEYFBERGBQRQUFBQUFBIRiBEhERgRASIRGBgUEREYFBEUFBQUFBIRGIgREhhBAREUQYERgRERgUEUFBQUFBIRIRiIERgRASESQYGIFBERGBQRSEhISBIRISEYiBhBARgURBgRFIEREYFBFBQUFBIRIRgRERgRARgSJBgYFIQRERgUERQUFBIRIREYFBhBAUgURBgRFISBEhGBQRQUFBIRIYgYEhgRARgSJBgYFIQRERFIFBFISBERIRGBRBhBAUgURBgRFIESERhEgUEUFBERGIGBQhgRARgSJBgYFBEREUGESBQRQRIRERgURBhBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIiIhgYiBiIGIgYiIiBIiIiIhASIkRJIilEQiERgRGBEYERgRgSIiIiIhASJEREkpRERCIYiIiIiIiBiBEiESIiIhASREREQkREREIhREREREiIiBIhiBIiIhASREREREREREIhERERERRERBIhiBESIhASREREREREREIhIiIiIhERERERgSIRIhASREREREREREIhIiIiIhISEhIhgSIYEhASlERERERERJIRERIRERISEhEYgREYEhASKURERERESSEhESERIRISEhEYgRIhIhASKURERERESSEhIiEiIhISEhIYgSIhIhASIpREREREQiEhIiEiIhISEhIhERERIhASIiREREREIiEhIiEiIhISEiEiFERBIhASIiJERERCIhISIhESIiEhISEhEREREhASIiIkREQiIhISIiIiIiEiEhIRQUFBQRASIiIiREIiIiESEhESIiISEhIUREREERASIiIiJCIhEREiEiIiISEhISIRRERBIhASIiIiIiERQRIhISIhISEhIiEiERQSRBASIiIiERERFBESISEhIREiIRISIhEUQRASIiIRFBIhFEEhEiEhIhIREiIiEUERERASIhEiFBIiEUQRIhEhEhiBIhIhQUGBERASERISFBISIRRBEYESEYiBISIUgUERgRARiEEhIUEhIhRBGBgRiIgSIiFIFBERGBAYREESIUEiIhFEEYEYiIgRIiGEFBgRERAUQRERIhQSEiFEQRGIiIgSIhhBQRSIERAUEREUEhRBISEUQRiIiIEiEhQUQREYgRARgRFEQSFEEiIURBiIiBEhIhFEERFEiBAYRIERRBIURBIRQYiIgUEiIRRBERRESBAUSIhBEREhFEESEYiIgRIhFEEREUSEGBAUiIFIgRESIREREREREREUQRERFEREiBAYiBQRGBEREiIiRERERERBERERRIQYgRAYiBSIiBgSIiQRERERERESEREURESIgRAYiBQRGBgSIiIiIhREQSIiERFEhBiIERAYiBSIiBgSIiIiERJEQSEhERSERIiBERARiIFIgRERERERIRERQRIREREUGIgRFBARGIiBERERESIhGIiIESIREUQYiIERQRAUEYEREYiIgSIhGBQYEiEhiIiIiBERRBAEAC8AJQAAAACA42neFRHjZxERERASIiIiIiIRISEiERSIiIEiIiIiIiIiIhASIiIiIiESEhISERSBiBIiREkiKURCIhASIiIiIhERIRIiERSIiBIkRESSlEREIhASIiIiIhgSEiEiIRSBgSJERERCREREQhASIiIiIRgRIiIRIRRIgSJEREREREREQhASIiIiIYQSIiIiERFIgSJEREREREREQhASIiIiEYQRESERIRFEiBJEREREREREQhASIiIiGEQREhESEREUSBKUREREREREkhASIiIhGEQSIhIiISERQSIpRERERERJIhASIiIhhEgSIhIiISEREiIpRERERERJIhASIiIhhEgSIhIiISIRESIiRERERESSIhASIiIhhEgSIREiIhIRERIiJEREREQiIhASIiIYRIgSIiIiIhIhEREiIkREREIiIhASIiIYRIERIREiIYEiERESIiRERCIiIhASIiIYRBGBIhIiGIEiIREREiJEQiIiIhASIiIYQYEYEiIhiBESIhERERIkIiIiIhASIiIYEoERgREYgRGBIiERERIiIiIiIhASIiIRghgRGIiBERgSEiIRESIiESESIhASIiEYGEKBEREREYQoERIiEiIhiBiBIhASIhiIgYIYgREYiBKBEREREiIhhEQSIhASIRGBGBhCGIiBJIgRESIiISIiGEiBIhASGIiIiIGIhCFIiBEhEiEhIRIREYgSEhARERgRGIERGIiBERgRISIiFEGIgRGBEhAYiIiIiBEiEREYERgRIiIRRBiIEiEYEhAREYERGBISERERgYESEhFEERERIiGIEhAYiIiIgRIRESIRgYESIURBiIEhERGBIhARgYERgREhEiEhGBEhIUQYREEhQSESIhAYiIiIgSEhQRIhGBEiFEGESEESESESIhARGBgRgREhhEEiGBISFEGERBESEhIhIhAYiIiIgRIRiEQSERIhRBhEhBEhEhIhIhARgREYESEYGIQRERIhRBhERBIREiERIhAYiIiIESEYEYQRiBERRBhIRBISEiIUEhARgRiBESEYQYhBEYiBFBhEERIREhFEQRAYiIgUERIYQYRBgREYgRERRBEhEURERBAREYFEEhIYEYhBgYiBGIFESBISFEREQRAYiBREESEYGIQYGERIERRIiBESFERBGBAEAC8AJQAAAACA42jeFRHiZxERERASIiIiIhRCREJCRCQkRCQSIiIiIiIiIhARIhESIiFEJEJCRCQkQkEiREkiKURCIhAUEiGBIiIUQiJCIiQiJBEkRESSlEREIhAUEiGIEiIUREREREREQRJERERCREREQhAUEiGIEiIRERERERERERJEREREREREQhARERIYgSIhgYGBgSIiISJEREREREREQhASQkIhgSIhgYGBgSIRISJEREREREREQhASQkIiESIYGBgYEhEhISKUREREREREkhASEhIhgSIYGBgYEiIiJiIpRERERERJIhARERIYgSIYGBgYEiIiIhIpRERERERJIhAUEiGIEiIYGBgYEiIiIiEiRERERESSIhAUEiGIEiIYGBgYEiIRJhEiJEREREQiIhAUEiGBIiIYGBgYEhESISIiIkREREIiIhAUEhESIhEYGBgYEiIiISIiIiRERCIiIhAUEiIiIYiBGBgYEiIhESIiIiJEQiISIhAUEiIiGIGBgYEYEiIiISIiIiIkIhFBEhAUEiIiGBiBgYGBREIiIREREiIiIhREEhAUEiIiGIEYgYEUREQRGIGIgSIiIiFBIhAUEiIiIYiIGBFEREREQYgRgSIiERFBIhAUEiIiIREREYgRREREQRiIgSIhIiFBIhAUEiIhFCQYiIiIERERiIGIESISIiIREhAUEiERERQhGIiIiIiIiIgRJBESIRISEhAUERIkQREUIRGIiIiIgREkRBERIhEREhAUFEIiJEERFCQRERERFCREERFEEiEiEhARERRCIiRBERQkJCQkJEQREUQiIREREhAYiBEUQiIkQQoRFBER4PtEIiJBESEiEBiBiIEUQiIkQRFBIiFBEUQiIkQRIhEiEBgYiBiBFEIiJEEUEhQRRCIiRBGBISESEBERgYhBERRCIiQRQUEUIiJEEYiBIiIREBIiGIQRiIEUQiJBFBFCIiQRiIiBISEREBEiIUEYiIiBRCIkERQiJEGIiIiBIiIREBIhIRGBEREREUIiQUIiQRERERGBISEREBEiIhiBIiIiIUQiERIkQSIiIiGBIiIREBESEhiBIRERIRRBIiFEESERESGBISEREBESIiGBIYgRESESERIRIREYgSGBIiIREBERISGBIYgRIhEhREEhEiEYgSGBISEREAQALwAlAAAAAIDjad4VEeNnEREREBIiIiIiIiIiGIiIiIiIiIiIiIEiIiIiEBIiIiIhIiIiIYiIiIGBgYGBgRIiIiIiEBIiIiIREiIiIhGBgYFBQUFBQSIiIiIiEBIiIiERESIiIkFBQUREREREEiIiIiIhEBIiIhERERIiIiFEREEREREREiIiIiIREBIiIREREREiIiEREREiIiIiESIiIiGBEBIiERERERESIiEhISEiIiIiEhIiIiGBEBIhERERERERIiEhISERESEREhIiIiGBEBIhERERERERIiEhISESERIRESIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIREREREREREiEhISEiIhIiEhIiIiGBEBIREREhIREREiEhISEiIREiEhIiIiGBEBIhERIhIhERIiEhISEhEiISEhIiIiGBEBIiIiIREiIiIREhISEhIREiESESIiGBEBIiIiERESIiEiEhISEiIiIiEhIhIiGBEBIiIiIiIiIhISEhISEiEiISEhIhIiGBEBIiIiIiIiERIRIhISESEhISEiEYESGBEBIiIiIiIRGBEiISISEiEhESIRGBEhGBEBIiIiIhGBSBEREhEhIhISGBQRgRIUGBEBIiIiERGBEYEYERERESEhGBEYESERGBEBIiIRgYEYEYFBGBgYERERgUGBEhREGBEBIhFEEREYFBgUQRERGBgRgRGBEhQRGBEBIUiBGBEYERgURIiIEREYFBgRIUREGBEBGEQRERgRgRgURIERiEQYERgRIUERGBEBSIQRgYGBgUGBRIiIiEQYEYESFEREGBEBRIEREYERgRGBERERERGBQYESFBEREREBhEEYGBiIGBGBEiISIhGBEYESFBiIgREBiEERGBgRGBGBIhIiEiGBGBEhQYERiIEBSIEYGBiIGBQYEhISEiGBGBEhQYgSGIEBRIERGBgRGBEYEiISIhgUGBERRBERIREBhEEYGBiIgYEYEhIiEhgRGBgRFEREEREBSEERGBgREYEYERERERgRgRERERERIiEBRIEYEYGIgYEYGIiIiIgRgRERERIiEREBEUEREYGBEYEYERERERgRgYgRGBEhIiEBIhIRgRgYgYFIERREERgRgRGIEREiEREAQALwAlAAAAAIDjWd4VEeMnEREREBIiIiIiIRIRISEkGBGIiBIiIiIiIiIiEBIhIiIiERESEhEkGIGIgSIiIiEiIiIiEBIhIiIiESEhEiEkGIiIgSIiIhESIiIiEBIhIiIiERISISIUGBGIEiIiIRERIiIiEBIYEiIiEhEiIhIUGIGIEiIiEREREiIiEBIYEiIhEhIiIiEUQYiIgSIhERERESIiEBIYEiIhQhERIREUQYEYgSIRERERERIiEBIYEiIhQhESERIURBgYEiEREREREREiEBGIgSIhQhIiEiISRBiBIiEREREREREiEBGBgSIhQhIiEiIhREGBIhERERERERESEBGIgSIUQhIiEiIhJEQRIhERERERERESEBIYEiIUIRIhESIiFEQRIhERERERERESEBIYEiIUIRIiIiIiEkRBIhERESEhERESEBERESISEREhESIhQSREEiEREiEiEREiEBGIgSFCEREiEiIUESREESIiIhESIiIiEBIREiFCERgSIiERgRJEQRIiIRERIiIiEBGIgSFCGBGBERgYGIEkRBEiIiIiIiIiEBGIgSERGIEYGBgRiBESIiESIiIiRCIiEBIREiERGIiBERGIgRERERQRIiJEEUQiEBIUEhESEYGIiIgYERIhFERBgiRBiBRCEBIYEYESEYgYGBiBEiERREIYESJEEUQhEBIYFIgRERiIiIgRIRFERCGBGBEiRCIUEBEYFEgRIRgYGIESERREIhgRGIgSEiGEEBEYFEgRERGIiBEhFERCIYFBEYiBEhEYEBEYFEiBEhGIgRIRREQkQYEREREYEREYEBEYEkSBESERgSEURCJEQYFEQRERIiIYEBEYEUSIERGIEhFEQkRBEYERERESIiIYEBEYEhRIERhEgRREJEEREYgUREEiIiIYEBEYESRIgRhEgURCQREiERgRERIhIhGEEBEYEhFEiBhEgUQkERIiIRGBRBIREREUEBEYESFESIGIFEIRFCIRIhEYEREYEREREBEYEhIURIgRFCERIhEREiERgUGIGBEYEBEYESEhRERERBESIiIiIiIRGBiIGIiBEBEYEhISERERCRETERERiIiBGBARGBEhIURERAlED0REQRERGIEQERgSEg4REhESCxESERiIgREQBAAvACUAAAAAgONM3hUR4dcREREQEiIRIiFBREFBRBQURBRBIiIiIiIiIiIQEiGIEiIUFEFBRBQUQUQSIiIiISIiIiIQEhgUgSIhQRFBERQRFEEiIiIiERIiIiIQEhgUgSIiFEREREREREEiIiIhEREiIiIQEhgUgSIiEREREREREREiIiIRERESIiIQEiGIEiIiEiIiGBgYGBIiIiERERERIiIQEiIRIiIiEhEiGBgYGBIiIhEREREREiIQEiGIEiIiEhIRIYGBgYEiIRERERERESIQEhgUgSIiYiIiIYGBgYEiIRERERERESIQEiGIEiIhIiIiIYGBgYEiERERERERERIQEiIRIiISIiIiIYGBgYEiERERERERERIQEiGIEiIRIhEmIYGBgYEiERERERERERIQEhgUgSIiEiEWIYGBgYEiERERISERERIQEhgUgSIiEiIiIYGBgYgRIRESISIRESIQEhgUgSIiERIiGIGBgYiIEiIiERIiIiIQEiGIEiIiEiIiGIGIGBgYgSIhEREiIiIQEhEREiIhEiIiQRgYGBiBgSIiIiIiIiIQEhIiESERFiJERBgRgYEYgSIiIiIiIiIQEiESIRERERRERBGIGBiIESIiIiIiIiIQEhIhERIREREJEeDrESIiIiIiIhASEhESEhEREREREREREREhIREiIiIiIhASERIRESGBgYGBgYGBgYEhESERIiIiIhARQREhISEREREREREREREhISEUESIiIhAUEUEhERIUREREREREREEhESFEQREiERARFBESEhIRSESESESESEEhISFBEUQRgRARQRgSEREhREgYSEgYREEhESERRBGIgRAUEYGBISEhFIGEiISBhEEhISFEEYgRERARGBgRIRERgUhEgYRIREEhESERGIiIERARgYGBEhGBERESERIREhEhISERiBERGBAYGBgRERgRgQkhKxERGIiIgRgQEYGBFBGBGIESERIREhERISERiBgREYEQGIgRJBgREYEJERMRGIiIiBGBEBgRFEGBGIiBCSITIhiBgREYFBARESQYEYERgQlEE0GIiIiBGEQQERRBgRiIiBEJESMRgYEREYFEEBGEGBERgRgRGBEhIiESESEYiIiIGEREEAQAJwAnAAAAAIDi8MMJIg8iISIiIiIiIiIiIiAJIg8iERIiIiIiIiIiIiAJIg8hEREiIiIiIiIiIiAJIuJ7EREREiIiIiIiIiIgIiIiIiIiIiEREhERIiIiIiIiIiAiIiIiIiIiEREhIRESIiIiIiIiICIiIiIiIiEREhESEREiIiIiIiIgIiIiIiIiEREhEREhERIiIiIiIiAiIiIiIiEREhERERIRESIiIiIiICIiIiIiEREhERIRESEREiIiIiIgIiIiIiEREhERISEREhERIiIiIiAiIiIiEREhERIREhERIRESIiIiICIiIiEREhERIRIRIRESEREiIiIgIiIiEREhERIRISESEREhERIiIiAiIiEREhERIRIREhEhERIRESIiICIiEREhERIREhESERIRESEREiIgIiEREhERIRERISERESEREhERIiAiEREhERESERESERESERERIRESICIREhEREREhESEhESERERESERIgIRESERIRERISERISERESERIRESAhESERESESESESESESESERESERICERIRERIRESEhESEhERIRERIREgERIRESIRESERISERIRESIRESERAREhESERESERESERESERESERIREBESERIRESEREREREREhERIREhEQERIREhESERESERIRERIREhESERAREhERIiERESEhISERESIhERIREBESERERERESERIREhEREREREhEQERIRERERESERERERIRERERESERARESERERESERERERESERERESERECERIhEREiEREhESEREiERESIREgIRERIiIhEREiERIhEREiIiERESAiEREREREREiIREiIRERERERESICIhEREREREiIRERIiERERERESIgIiIhERERIiIhEREiIiEREREiIiAJIg8RERESIiIiIiIiIiAJIjcRERESIiIiIiIiIiAiIiIiIiIiIREREREiIiIiIiIiICIiIiIiIiIRERERERIiIiIiIiIgAQALAAsAAAAAgB8LBw4AAAAOHwAAAAduwAAADv/gAAAHdcAAAAoOAAAAAQAJAAoAAAAAgB8KBxwAAAAKPgAAAAddAAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDIPCwOAAAAHwAAADg/gAAAPB8AAADu4AAB//AAADv/+AAATfXwAADk4AAADgAAAB8AAAAEACwALAAAAAIAiCw8IAAAAHAAAAD4AAAAOfwAAAA8+AAAAHAAAAAgAAAAJAAEACQAKAAAAAIAkCg8IAAAAHAAAAD4AAAAOfwAAABM+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDoPEwEAAAADgAAAB8AAAA/gAAAKH/AAAA8/+AAAf/wAAD/4AAAKH/AAABMP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCYLBQALdwAAAPeAAAAO/4AAABd/AAAAPgAAABwAAAAIAAAAAAAAAAEACQAKAAAAAIAkCgt3AAAA94AAAA7/gAAAF38AAAA+AAAAHAAAAAgAAAAAAAAAAQAPAA8AAAAAgDEPDzx4AAB+/AAA/v4AABL//gAACn/8AAAbP/gAAB/wAAAP4AAAB8AAAAOAAAABAAAAAQALAAsAAAAAgCMLBQATCAAAABwAAAA+AAAAfwAAAA7/gAAAB2sAAAAKHAAAAAEACQAKAAAAAIAhChMIAAAAHAAAAD4AAAB/AAAADv+AAAAHawAAAAocAAAAAQAPAA8AAAAAgDUPGwEAAAADgAAAB8AAAA/gAAAf8AAAP/gAAAp//AAADv/+AAAT/X4AAHk8AAADgAAAB8AAAAEADAAMAAAAAIAmDAoCAAAACgcAAAAKDYAAABMYwAAAH8AAAD/gAAAwYAAACnjwAAABAAoADAAAAACALwwrHwAAAD+AAAAxgAAAAYAAAAOAAAAHAAAADgAAABwAAAA5gAAAMYAAAAo/gAAAAQAKAAwAAAAAgC0MCj+AAAAXMwAAAAYAAAAMAAAAHwAAAB+AAAAKAYAAAA8xgAAAP4AAAB8AAAABAAoADAAAAACAKQwbAwAAAAcAAAAPAAAAHwAAADsAAABzAAAACn/AAAAKAwAAAAoHgAAAAQAKAAwAAAAAgCcMCn8AAAAKYAAAAAt+AAAAfwAAAAoDAAAACmMAAAALfwAAAD4AAAABAAoADAAAAACAKAwbDwAAAB8AAAA4AAAAMAAAAD8AAAA/gAAAEjGAAAALP4AAAB8AAAABAAoADAAAAACAGgwKP4AAAAcxgAAACgMAAAAOBgAAABIMAAAAAQAKAAwAAAAAgCYMCx8AAAA/gAAADjGAAAALHwAAAD+AAAAOMYAAAAs/gAAAHwAAAAEACgAMAAAAAIAoDAsfAAAAP4AAABIxgAAAGz+AAAAfgAAAAYAAAAOAAAAfAAAAHgAAAAEACgAMAAAAAIAYDAtngAAAb8AAACJswAAAC2/AAABngAAAAQAKAAwAAAAAgBkMCg8AAAAaBgAAAApmAAAAC34AAAA8AAAAAQAKAA4AAAAAgCAOCz4AAAB/AAAAImMAAAATfwAAAD4AAAAHAAAAAwAAAAEACgAMAAAAAIAsDAr3gAAAI2YAAABsAAAAeAAAAHAAAAB4AAAAbAAAAGYAAABjAAAACveAAAA='! !

!PlayingCard class methodsFor: 'all' stamp: 'di 1/16/2000 10:38'!
includeInNewMorphMenu

	^false! !

!PlayingCard class methodsFor: 'all' stamp: 'di 10/18/1999 11:01'!
initialize  "PlayingCard initialize"
	| forms f |
	"Read the stored forms from mime-encoded data in imageData."
	f _ Base64MimeConverter mimeDecodeToBytes: (ReadStream on: self imageData).
	forms _ OrderedCollection new.
	f next = 2 ifFalse: [self error: 'corrupted imageData'].
	[f atEnd] whileFalse: [forms add: (Form new readFrom: f)].

	"1/2 image of Kc, Qc, Jc, ... d, h, s, and center image of As"
	FaceForms _ forms copyFrom: 1 to: 13.
	"Images of small club, smaller club (for face cards), large club (for 2-10, A),
	followed by 3 more each for diamonds, heardt, spaces, all as 1-bit forms."
	SuitForms _ forms copyFrom: 14 to: 25.
	"Images of A, 2, 3 ... J, Q, K as 1-bit forms"
	NumberForms _ forms copyFrom: 26 to: 38.
	CardSize _ 71@96.
	FaceLoc _ 12@11.
	NumberLoc _ 2@4.
	SuitLoc _ 3@18.
	FaceSuitLoc _ 2@18.
	TopSpotLocs _ {{}.  "A"
				{28@10}.  "2"
				{28@10}.  "3"
				{15@10. 41@10}.  "4"
				{15@10. 41@10}.  "5"
				{14@10. 42@10}.  "6"
				{14@10. 42@10}.  "7"
				{14@10. 28@26. 42@10}.  "8"
				{14@10. 14@30. 42@10. 42@30}.  "9"
				{14@10. 14@30. 42@10. 42@30. 28@21}}.   "10"
	MidSpotLocs _ {{28@40}.  "A"
				{}.  "2"
				{28@40}.  "3"
				{}.  "4"
				{28@40}.  "5"
				{14@40. 42@40}.  "6"
				{14@40. 42@40. 28@26}.  "7"
				{14@40. 42@40}.  "8"
				{28@40}.  "9"
				{}  "10"}.
	ASpadesLoc _ 16@27.
	"self class removeSelector: #imageData"  "Can save space"
"
	NOTE:  If you wish to save this class with new data,
	be sure to execute this doit before fileOut.  It will generate the method, #imageData
	| rws mimeData | 
	rws _ ReadWriteStream on: (ByteArray new: 18000).
	rws nextPut: 2.
	FaceForms , SuitForms , NumberForms do: [:f | f writeOn: rws].
	mimeData _ (Base64MimeConverter mimeEncode: rws) contents.
	PlayingCard class compile: 'imageData ^ ' , mimeData printString classified: 'all'
"! !

!PlayingCard class methodsFor: 'all' stamp: 'di 10/18/1999 23:36'!
test    "Display all cards in the deck"
	"MessageTally spyOn: [20 timesRepeat: [PlayingCard test]]"
	1 to: 13 do: [:i | 1 to: 4 do: [:j |
		(PlayingCard the: i of: (#(clubs diamonds hearts spades) at: j)) cardForm
				displayAt: (i-1*CardSize x)@(j-1*CardSize y)]]! !

!PlayingCard class methodsFor: 'all' stamp: 'di 10/18/1999 23:22'!
the: cardNo of: suitOrNumber

	^ self new setCardNo: cardNo
		suitNo: (suitOrNumber isNumber
				ifTrue: [suitOrNumber]
				ifFalse: [#(clubs diamonds hearts spades) indexOf: suitOrNumber])
		cardForm: (Form extent: CardSize depth: Display depth)! !
AlignmentMorph subclass: #PlayingCardDeck
	instanceVariableNames: 'layout stackingPolicy stackingOrder emptyDropPolicy target acceptCardSelector cardDroppedSelector cardDoubleClickSelector cardDraggedSelector seed '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 01:40'!
acceptCardSelector: aSymbolOrString

	acceptCardSelector _ self nilOrSymbol: aSymbolOrString.! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/15/1999 11:07'!
addCard: aPlayingCard
	self addMorph: aPlayingCard! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 03:13'!
cardDoubleClickSelector: aSymbolOrString

	cardDoubleClickSelector _ self nilOrSymbol: aSymbolOrString.! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 01:39'!
cardDraggedSelector: aSymbolOrString

	cardDraggedSelector _ self nilOrSymbol: aSymbolOrString.! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 17:27'!
cardDroppedSelector: aSymbolOrString

	cardDroppedSelector _ self nilOrSymbol: aSymbolOrString.! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/15/1999 10:46'!
cards

	^submorphs! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 13:18'!
emptyDropPolicy: aSymbol
	"#any #inOrder #anyClub #anyDiamond #anyHeart #anySpade"

	emptyDropPolicy _ aSymbol! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 19:41'!
hasCards

	^self hasSubmorphs! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'ar 11/20/2000 18:43'!
layout: aSymbol
	" #grid #pile #stagger"
	layout _ aSymbol.
	layout == #grid 
		ifTrue:[self maxCellSize: SmallInteger maxVal].
	layout == #pile 
		ifTrue:[self maxCellSize: 0].
	layout == #stagger 
		ifTrue:[self maxCellSize: self staggerOffset].! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/23/1999 22:44'!
newSeed
	seed _ (1 to: 32000) atRandom! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 20:05'!
removeAllCards
	self removeAllMorphs! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/23/1999 22:22'!
seed
	
	^seed! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/23/1999 22:21'!
seed: anInteger
	
	seed _ anInteger! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/15/1999 16:39'!
stackingOrder: aSymbol
	"#ascending #descending"

	stackingOrder _ aSymbol! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 00:08'!
stackingPolicy

	^ stackingPolicy! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 00:08'!
stackingPolicy: aSymbol
	"#straight #altStraight #single #none"

	stackingPolicy _ aSymbol! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/24/1999 20:20'!
subDeckStartingAt: aCard
	| i subDeck |

	i _ submorphs indexOf: aCard ifAbsent: [^ aCard].
	i = 1 ifTrue: [^aCard].
	subDeck _ PlayingCardDeck new.
	(submorphs copyFrom: 1 to: i-1) do:
			[:m | m class = aCard class ifTrue: [subDeck addMorphBack: m]].
	^subDeck.
	! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 17:21'!
target: anObject

	target _ anObject! !

!PlayingCardDeck methodsFor: 'accessing' stamp: 'djp 10/16/1999 19:24'!
topCard

	^self firstSubmorph! !


!PlayingCardDeck methodsFor: 'events' stamp: 'djp 10/24/1999 03:29'!
doubleClickOnCard: aCard

	(target ~~ nil and: [cardDoubleClickSelector ~~ nil]) 
		ifTrue: [^ target perform: cardDoubleClickSelector with: self with: aCard]! !


!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'th 12/10/1999 16:07'!
acceptCard: aCard default: aBoolean 
	"if target and acceptCardSelector are both not nil, send to target, if not  
	nil answer  
	else answer aBoolean"
	"Rewrote this a little (SmallLint calls this 'intention revealing')-th"
	^ (target isNil or: [acceptCardSelector isNil])
		ifTrue: [aBoolean]
		ifFalse: [(target
				perform: acceptCardSelector
				with: aCard
				with: self)
				ifNil: [aBoolean]]! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 13:13'!
acceptDroppingMorph: aMorph event: evt

	target rememberUndoableAction:
			[target inAutoMove ifFalse: [target removeProperty: #stateBeforeGrab].
			self addMorph: aMorph.
			aMorph hasSubmorphs ifTrue:
				["Just dropped a sub-deck of cards"
				aMorph submorphs reverseDo: [:m | self addMorphFront: m]].
			(target ~~ nil and: [cardDroppedSelector ~~ nil])
				ifTrue: [target perform: cardDroppedSelector]]
		named: 'move card'! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/16/1999 13:14'!
emptyDropNotOk: aPlayingCard

	^(self emptyDropOk: aPlayingCard) not! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/16/1999 13:15'!
emptyDropOk: aPlayingCard

	emptyDropPolicy = #any 			ifTrue: [^true].
	emptyDropPolicy = #inOrder			ifTrue: [^self inStackingOrder: aPlayingCard].
	emptyDropPolicy = #anyClub 		ifTrue: [^aPlayingCard suit = #club].
	emptyDropPolicy = #anyDiamond		ifTrue: [^aPlayingCard suit = #diamond].
	emptyDropPolicy = #anyHeart		ifTrue: [^aPlayingCard suit = #heart].
	emptyDropPolicy = #anySpade		ifTrue: [^aPlayingCard suit = #spade].! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/16/1999 13:10'!
ifEmpty: aBlock

	self hasSubmorphs not ifTrue: [^aBlock value]! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/24/1999 02:17'!
ifEmpty: aBlock1 ifNotEmpty: aBlock2

	self hasSubmorphs not 
		ifTrue: [^aBlock1 value]
		ifFalse: [^aBlock2 value]! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/16/1999 21:54'!
inStackingOrder: aPlayingCard

	^self inStackingOrder: aPlayingCard event: nil! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'di 10/19/1999 15:45'!
inStackingOrder: aCard event: evt

	self hasSubmorphs 
		ifTrue: [^ self inStackingOrder: aCard onTopOf: self topCard]
		ifFalse: [stackingOrder = #ascending ifTrue: [^ aCard cardNumber = 1].
				stackingOrder = #descending ifTrue: [^ aCard cardNumber = 13]].
	^ false.! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'di 10/21/1999 22:03'!
inStackingOrder: aCard onTopOf: cardBelow
	| diff |
	(stackingPolicy = #altStraight and: [aCard suitColor = cardBelow suitColor]) ifTrue: [^ false].
	(stackingPolicy = #straight and: [aCard suit ~= cardBelow suit]) ifTrue: [^ false].
	diff _ aCard cardNumber - cardBelow cardNumber.
	stackingOrder = #ascending 	ifTrue: [^ diff = 1].
	stackingOrder = #descending	ifTrue: [^ diff = -1].
	^ false.! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/15/1999 12:43'!
insertionIndexFor: aMorph
	"Return the index at which the given morph should be inserted into the submorphs of the receiver."

	^1! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'th 12/10/1999 18:34'!
repelCard: aCard 
	stackingPolicy = #none ifTrue: [^ self repelCard: aCard default: true].
	stackingPolicy = #single ifTrue: [^ self ifEmpty: [self repelCard: aCard default: false]
			ifNotEmpty: [true]].
	(stackingPolicy = #altStraight or: [stackingPolicy = #straight])
		ifTrue: [self ifEmpty: [^ self repelCard: aCard default: (self emptyDropNotOk: aCard)]
				ifNotEmpty: [(self inStackingOrder: aCard onTopOf: self topCard)
						ifFalse: [^ self repelCard: aCard default: true]]].
	^ false! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/24/1999 04:09'!
repelCard: aCard default: aBoolean
	
	^(self acceptCard: aCard default: aBoolean not) not! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/24/1999 02:20'!
repelsMorph: aMorph event: evt

	(aMorph isKindOf: PlayingCardMorph) 
		ifTrue: [^self repelCard: aMorph]
		ifFalse: [^true]! !

!PlayingCardDeck methodsFor: 'dropping/grabbing' stamp: 'djp 10/24/1999 20:34'!
rootForGrabOf: aCard

	self hasSubmorphs ifFalse: [^ nil].
	(target ~~ nil and: [cardDraggedSelector ~~ nil]) 
		ifTrue: [^target perform: cardDraggedSelector with: aCard with: self]
		ifFalse: [^self firstSubmorph]! !


!PlayingCardDeck methodsFor: 'layout' stamp: 'djp 10/15/1999 11:25'!
staggerOffset
	^18! !


!PlayingCardDeck methodsFor: 'initialization' stamp: 'ar 11/20/2000 19:11'!
initialize
	super initialize.
	self cellPositioning: #topLeft.
	self reverseTableCells: true.
	self layout: #grid.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	borderWidth _ 0.
	self layoutInset: 0.
	stackingPolicy _ #stagger.
	stackingOrder _ #ascending.
	emptyDropPolicy _ #any.
	self newSeed.
	^self! !

!PlayingCardDeck methodsFor: 'initialization' stamp: 'djp 10/17/1999 18:25'!
newDeck
	| cards |
	cards := OrderedCollection new: 52.
	PlayingCardMorph suits 
		do: [:suit | 1 to: 13
			do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)]].
	self addAllMorphs: cards.
	^self! !

!PlayingCardDeck methodsFor: 'initialization' stamp: 'djp 10/17/1999 18:25'!
newSuit: suit
	| cards |
	cards := OrderedCollection new: 13.
	1 to: 13 do: [:cardNo | cards add: (PlayingCardMorph the: cardNo of: suit)].
	self addAllMorphs: cards.
	^self! !


!PlayingCardDeck methodsFor: 'shuffling/dealing' stamp: 'di 10/19/1999 15:44'!
deal
	| card |
	self cards size > 0 
		ifTrue: [
			card _ self topCard.
			card delete.
			^card]
		ifFalse: [^nil]! !

!PlayingCardDeck methodsFor: 'shuffling/dealing' stamp: 'djp 10/10/1999 18:48'!
deal: anInteger

	^(1 to: anInteger) collect: [:i | self deal]! !

!PlayingCardDeck methodsFor: 'shuffling/dealing' stamp: 'ar 11/12/2000 22:40'!
reverse
	self invalidRect: self fullBounds.
	submorphs _ submorphs reversed.
	self layoutChanged.! !

!PlayingCardDeck methodsFor: 'shuffling/dealing' stamp: 'ar 11/12/2000 22:40'!
shuffle
	self invalidRect: self fullBounds.
	submorphs _ submorphs shuffledBy: (Random new seed: seed).
	self layoutChanged.! !


!PlayingCardDeck methodsFor: 'printing' stamp: 'djp 10/15/1999 10:47'!
printOn: aStream
	| cards |
	cards _ self cards.
	aStream nextPutAll: 'aCardDeck('.
	cards size > 1 
		ifTrue: [
			cards allButLast do: [:card |
				aStream
					print: card;
					nextPutAll: ', ']].
	cards size > 0 ifTrue: [aStream print: cards last].
	aStream nextPut: $).! !


!PlayingCardDeck methodsFor: 'private' stamp: 'djp 10/16/1999 17:27'!
nilOrSymbol: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^nil]
		ifFalse: [^aSymbolOrString asSymbol]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayingCardDeck class
	instanceVariableNames: ''!

!PlayingCardDeck class methodsFor: 'symbols' stamp: 'djp 10/10/1999 18:06'!
suits

	^{#Clubs. #Diamonds. #Hearts. #Spades}! !

!PlayingCardDeck class methodsFor: 'symbols' stamp: 'djp 10/17/1999 18:05'!
values

	^#(Ace),((2 to: 9) collect: [:i | i printString asSymbol]), #(Jack Queen King)! !


!PlayingCardDeck class methodsFor: 'instance creation' stamp: 'di 1/16/2000 10:38'!
includeInNewMorphMenu

	^false! !

!PlayingCardDeck class methodsFor: 'instance creation' stamp: 'djp 10/15/1999 11:01'!
newDeck
	^self new newDeck! !

!PlayingCardDeck class methodsFor: 'instance creation' stamp: 'djp 10/15/1999 09:53'!
newSuit: suit
	^self new newSuit: suit! !
ImageMorph subclass: #PlayingCardMorph
	instanceVariableNames: 'cardNumber suitNumber '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!PlayingCardMorph commentStamp: '<historical>' prior: 0!
This class displays images from the PlayingCard class as morphs.  It attempts to be space-efficient by only producing its images on demand.!


!PlayingCardMorph methodsFor: 'printing' stamp: 'djp 10/17/1999 20:27'!
printOn: aStream

	aStream
		print: cardNumber;
		nextPutAll: ' of ';
		print: (self class suits at: suitNumber).! !


!PlayingCardMorph methodsFor: 'access' stamp: 'di 10/21/1999 21:41'!
board

	^ owner owner owner! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/24/1999 03:11'!
cardDeck

	^self owner! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/17/1999 18:37'!
cardNumber
	^cardNumber! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/17/1999 18:37'!
cardNumber: c suitNumber: s
	cardNumber _ c.
	suitNumber _ s.! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/17/1999 18:37'!
suit
	^self class suits at: suitNumber! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/17/1999 18:37'!
suitColor
	^#(black red red black) at: suitNumber! !

!PlayingCardMorph methodsFor: 'access' stamp: 'djp 10/17/1999 18:37'!
suitNumber

	^suitNumber! !


!PlayingCardMorph methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 11:47'!
aboutToBeGrabbedBy: aHand
	"I'm about to be grabbed by the hand.  If other cards are above me in a deck,
	then move them from the deck to being submorphs of me"
	| i |
	super aboutToBeGrabbedBy: aHand.
	self removeProperty: #undoGrabCommand.  "So it won't interfere with overall move"
	self board captureStateBeforeGrab.
	i _ owner submorphs indexOf: self ifAbsent: [^ self].
	i = 1 ifTrue: [^ self].
	(owner submorphs copyFrom: 1 to: i-1) do:
		[:m | m class = self class ifTrue: [self addMorphBack: m]].
! !

!PlayingCardMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:05'!
justDroppedInto: newOwner event: evt

	(newOwner isKindOf: PlayingCardDeck)
		ifFalse: ["Can't drop a card anywhere but on a deck"
				self rejectDropMorphEvent: evt].
	^super justDroppedInto: newOwner event: evt! !

!PlayingCardMorph methodsFor: 'dropping/grabbing' stamp: 'di 12/12/2000 14:52'!
slideBackToFormerSituation: evt

	super slideBackToFormerSituation: evt.
	self board removeProperty: #stateBeforeGrab.
	self hasSubmorphs ifTrue:
		["Just cancelled a drop of multiple cards -- have to unload submorphs"
		self submorphs reverseDo: [:m | owner addMorphFront: m]].
! !


!PlayingCardMorph methodsFor: 'events' stamp: 'ar 10/8/2000 13:50'!
click: evt
	| root popUp |
	root _ owner rootForGrabOf: self.
	root == nil
		ifTrue: ["Display hidden card in front"
				popUp _ self copy.
				self board owner owner addMorphFront: popUp.
				self world displayWorld.
				(Delay forMilliseconds: 750) wait.
				popUp delete]
		ifFalse: [evt hand grabMorph: root]! !

!PlayingCardMorph methodsFor: 'events' stamp: 'djp 10/24/1999 03:12'!
doubleClick: evt

	^self cardDeck doubleClickOnCard: self! !

!PlayingCardMorph methodsFor: 'events' stamp: 'di 10/19/1999 00:01'!
handlesMouseDown: evt

	^ true! !

!PlayingCardMorph methodsFor: 'events' stamp: 'ar 10/8/2000 14:24'!
mouseDown: evt
	"Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched"

	evt hand waitForClicksOrDrag: self event: evt selectors: { #click:. #doubleClick:. nil} threshold: 5! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PlayingCardMorph class
	instanceVariableNames: ''!

!PlayingCardMorph class methodsFor: 'initialize-release' stamp: 'di 1/16/2000 10:40'!
includeInNewMorphMenu

	^false! !

!PlayingCardMorph class methodsFor: 'initialize-release' stamp: 'di 10/18/1999 23:45'!
the: cardNumber of: suit

	^ self new 
		image: (PlayingCard the: cardNumber of: suit) cardForm;
		cardNumber: cardNumber suitNumber: (self suits indexOf: suit)! !


!PlayingCardMorph class methodsFor: 'access' stamp: 'djp 10/17/1999 18:39'!
cardSize
	" a real hack, but I don't want to muck with Dan's class "
	^71@96.! !

!PlayingCardMorph class methodsFor: 'access' stamp: 'djp 10/17/1999 18:32'!
height
	^self cardSize y! !

!PlayingCardMorph class methodsFor: 'access' stamp: 'djp 10/15/1999 07:14'!
suits
	^ #(clubs diamonds hearts spades)! !

!PlayingCardMorph class methodsFor: 'access' stamp: 'djp 10/17/1999 18:32'!
width
	^self cardSize x! !


!PlayingCardMorph class methodsFor: 'testing' stamp: 'djp 10/17/1999 18:24'!
test    "Display all cards in the deck"
	"MessageTally spyOn: [20 timesRepeat: [PlayingCardMorph test]]"
	| table row |
	table _ AlignmentMorph newColumn.
	self suits do: [:suit | 
		row _ AlignmentMorph newRow.
		table addMorph: row.
		1 to: 13 do: [:cn |
			row addMorph: 
			(PlayingCardMorph the: cn of: suit)]].
	table openInWorld.! !
AbstractSound subclass: #PluckedSound
	instanceVariableNames: 'initialCount count ring scaledIndex scaledIndexIncr scaledIndexLimit '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!PluckedSound commentStamp: '<historical>' prior: 0!
The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. Fractional indexing is used to allow precise tuning; without this, the pitch would be rounded to the pitch corresponding to the nearest buffer size.
!


!PluckedSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'!
setPitch: pitchNameOrNumber dur: d loudness: vol

	| p sz |
	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	initialCount _ (d * self samplingRate asFloat) asInteger.
	ring _ SoundBuffer newMonoSampleCount:
		(((2.0 * self samplingRate) / p) asInteger max: 2).
	sz _ ring monoSampleCount.
	scaledIndexLimit _ (sz + 1) * ScaleFactor.
	scaledIndexIncr _ (p * sz * ScaleFactor) // (2.0 * self samplingRate).
	self reset.
! !


!PluckedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate
! !

!PluckedSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:40'!
duration: seconds

	super duration: seconds.
	count _ initialCount _ (seconds * self samplingRate) rounded.
! !


!PluckedSound methodsFor: 'sound generation' stamp: 'ar 2/3/2001 15:23'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string."
	"(PluckedSound pitch: 220.0 dur: 6.0 loudness: 0.8) play"

	| lastIndex scaledThisIndex scaledNextIndex average sample i s |
	<primitive:'primitiveMixPluckedSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #ring declareC: 'short int *ring'.

	lastIndex _ (startIndex + n) - 1.
	scaledThisIndex _ scaledNextIndex _ scaledIndex.
	startIndex to: lastIndex do: [:sliceIndex |
		scaledNextIndex _ scaledThisIndex + scaledIndexIncr.
		scaledNextIndex >= scaledIndexLimit
			ifTrue: [scaledNextIndex _ ScaleFactor + (scaledNextIndex - scaledIndexLimit)].
		average _
			((ring at: scaledThisIndex // ScaleFactor) +
			 (ring at: scaledNextIndex // ScaleFactor)) // 2.
		ring at: scaledThisIndex // ScaleFactor put: average.
		sample _ (average * scaledVol) // ScaleFactor.  "scale by volume"
		scaledThisIndex _ scaledNextIndex.

		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].

		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]]].

	scaledIndex _ scaledNextIndex.
	count _ count - n.
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 21:35'!
reset
	"Fill the ring with random noise."

	| seed n |
	super reset.
	seed _ 17.
	n _ ring monoSampleCount.
	1 to: n do: [:i |
		seed _ ((seed * 1309) + 13849) bitAnd: 65535.
		ring at: i put: seed - 32768].
	count _ initialCount.
	scaledIndex _ ScaleFactor.
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'jm 11/26/97 10:51'!
samplesRemaining

	^ count
! !

!PluckedSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:58'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count _ (mSecs * self samplingRate) // 1000.
! !


!PluckedSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy

	^ super copy copyRing
! !

!PluckedSound methodsFor: 'copying' stamp: 'jm 11/4/97 08:25'!
copyRing
	"Private!! Support for copying"

	ring _ ring copy.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluckedSound class
	instanceVariableNames: ''!

!PluckedSound class methodsFor: 'instruments' stamp: 'jm 1/31/98 16:32'!
default
	"PluckedSound default play"
	"(AbstractSound majorScaleOn: PluckedSound default) play"

	| snd p env |
	snd _ PluckedSound new.
	p _ OrderedCollection new.
	p add: 0@1.0; add: 10@1.0; add: 20@0.0.
	env _ VolumeEnvelope points: p loopStart: 2 loopEnd: 2.
	env target: snd; scale: 0.3.
	^ snd
		addEnvelope: env;
		setPitch: 220 dur: 3.0 loudness: 0.3
! !
Controller subclass: #PluggableButtonController
	instanceVariableNames: 'selector arguments shownAsComplemented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableButtonController commentStamp: '<historical>' prior: 0!
The controller for Buttons.  Not meant to be used with buttons that have mouseOver feeback when the button is not pressed.  Use mouseEnter/mouseLeave for that. !


!PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:49'!
controlInitialize 
	"Provide feedback indicating that button has been entered with the mouse down. If triggerOnMouseDown is true, then do the button action on mouse down--and don't bother with the feedback since the action happens immediately."

	sensor anyButtonPressed ifFalse: [^ self].
	view triggerOnMouseDown
		ifTrue: [sensor yellowButtonPressed 
			ifTrue: [self yellowButtonActivity]
			ifFalse: [view performAction]]
		ifFalse: [view toggleMouseOverFeedback.
				 shownAsComplemented _ true]! !

!PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:44'!
controlTerminate 
	"Reverse the feedback displayed by controlInitialize, if any. Perform the button action if necessary."

	view ifNotNil:
		[view triggerOnMouseDown
			ifFalse:
				[shownAsComplemented ifTrue: [view toggleMouseOverFeedback].
				self viewHasCursor ifTrue: [view performAction]]]! !


!PluggableButtonController methodsFor: 'control defaults' stamp: 'sma 5/28/2000 16:29'!
controlActivity 

	shownAsComplemented ifNil: [^ self].
	shownAsComplemented = self viewHasCursor
		ifFalse:
			[view ifNotNil: [view toggleMouseOverFeedback]. 
			shownAsComplemented _ shownAsComplemented not]! !

!PluggableButtonController methodsFor: 'control defaults' stamp: 'acg 3/13/2000 08:26'!
isControlActive 

	^ sensor anyButtonPressed! !

!PluggableButtonController methodsFor: 'control defaults' stamp: 'tk 4/29/1998 10:47'!
isControlWanted

	"sensor flushKeyboard."
	self viewHasCursor & sensor anyButtonPressed ifFalse: [^ false].
	view askBeforeChanging
		ifTrue: [^ model okToChange]  "ask before changing"
		ifFalse: [^ true].
! !


!PluggableButtonController methodsFor: 'button activity' stamp: 'di 9/7/1999 08:44'!
yellowButtonActivity
	"Invoke the model's menu.  This is option-click, NOT the normal button press."
	| menu |
	menu _ view getMenu: false.
	menu == nil
		ifTrue: [sensor waitNoButton]
		ifFalse: [self terminateAndInitializeAround: [menu invokeOn: model]].
! !
AlignmentMorph subclass: #PluggableButtonMorph
	instanceVariableNames: 'model label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!PluggableButtonMorph commentStamp: '<historical>' prior: 0!
A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:

		getStateSelector		fetch a boolean value from the model
		actionSelector		invoke this button's action on the model
		getLabelSelector		fetch this button's lable from the model
		getMenuSelector		fetch a pop-up menu for this button from the model

Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.

The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.

Options:
	askBeforeChanging		have model ask user before allowing a change that could lose edits
	triggerOnMouseDown	do this button's action on mouse down (vs. up) transition
	shortcutCharacter		a place to record an optional shortcut key
!


!PluggableButtonMorph methodsFor: 'initialize-release' stamp: 'RAA 1/17/2001 14:16'!
initialize

 	super initialize.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.	"<--so naked buttons work right"
	self vResizing: #shrinkWrap.
	self wrapCentering: #center; cellPositioning: #topCenter.
	borderWidth _ 1.
	model _ nil.
	label _ nil.
	getStateSelector _ nil.
	actionSelector _ nil.
	getLabelSelector _ nil.
	getMenuSelector _ nil.
	shortcutCharacter _ nil.
	askBeforeChanging _ false.
	triggerOnMouseDown _ false.
	color _ Color lightGreen.
	onColor _ color darker.
	offColor _ color.
	feedbackColor _ Color red.
	showSelectionFeedback _ false.
	allButtons _ nil.
	self extent: 20@15.
! !

!PluggableButtonMorph methodsFor: 'initialize-release' stamp: 'jm 5/4/1998 17:53'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	self initialize.
	self model: anObject.
	getStateSelector _ getStateSel.
	actionSelector _ actionSel.
	getLabelSelector _ labelSel.
	getMenuSelector _ menuSel.
	self update: labelSel.
! !


!PluggableButtonMorph methodsFor: 'accessing'!
action: aSymbol 
	"Set actionSelector to be the action defined by aSymbol."

	actionSelector _ aSymbol.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:17'!
actionSelector
	"Answer the receiver's actionSelector"

	^ actionSelector! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'!
askBeforeChanging

	^ askBeforeChanging
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'!
askBeforeChanging: aBoolean
	"If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost."

	askBeforeChanging _ aBoolean.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 17:47'!
feedbackColor: aColor
	"Set the color of this button's selection feedback border."

	feedbackColor _ aColor.
	self changed.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'!
label
	"Answer the DisplayObject used as this button's label."

	^ label
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'ar 11/9/2000 21:21'!
label: aStringOrTextOrMorph
	"Label this button with the given string or morph."

	| r |
	self removeAllMorphs.
	"nest label in a row for centering"
	r _ AlignmentMorph newRow
		borderWidth: 0;
		layoutInset: 0;
		color: Color transparent;
		hResizing: #shrinkWrap;
		vResizing: #spaceFill;
		wrapCentering: #center; cellPositioning: #leftCenter.
	aStringOrTextOrMorph isMorph
		ifTrue: [
			label _ aStringOrTextOrMorph.
			r addMorph: aStringOrTextOrMorph]
		ifFalse: [
			label _ aStringOrTextOrMorph asString.
			r addMorph: (StringMorph contents: label)].
	self addMorph: r.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:52'!
model: anObject
	"Set my model and make me me a dependent of the given object."

	model ifNotNil: [model removeDependent: self].
	anObject ifNotNil: [anObject addDependent: self].
	model _ anObject.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 10/25/1999 14:36'!
offColor
	^ offColor
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 12/28/2000 16:19'!
offColor: colorWhenOff
	"Set the fill colors to be used when this button is off."

	self onColor: onColor offColor: colorWhenOff
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 5/4/1998 16:29'!
onColor: colorWhenOn offColor: colorWhenOff
	"Set the fill colors to be used when this button is on/off."

	onColor _ colorWhenOn.
	offColor _ colorWhenOff.
	self update: nil.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter
	"Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut."

	^ shortcutCharacter
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter: aCharacter 
	"Set the character to be used as a keyboard shortcut for turning on this switch."

	shortcutCharacter _ aCharacter.
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'!
triggerOnMouseDown

	^ triggerOnMouseDown
! !

!PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'!
triggerOnMouseDown: aBoolean
	"If this preference is turned on, then trigger my action immediately when the mouse goes down."

	triggerOnMouseDown _ aBoolean.
! !


!PluggableButtonMorph methodsFor: 'drawing' stamp: 'jm 5/4/1998 17:46'!
drawOn: aCanvas 

	super drawOn: aCanvas.
	showSelectionFeedback ifTrue: [
		aCanvas frameRectangle: self innerBounds width: 2 color: feedbackColor].
! !


!PluggableButtonMorph methodsFor: 'events' stamp: 'jm 5/4/1998 16:57'!
handlesMouseDown: evt

	^ true
! !

!PluggableButtonMorph methodsFor: 'events' stamp: 'jm 5/20/1998 11:49'!
mouseDown: evt
	"Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph."

	allButtons _ nil.
	evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt].
	triggerOnMouseDown
		ifTrue: [self performAction]
		ifFalse: [
			allButtons _ owner submorphs select: [:m | m class = self class].
			self updateFeedbackForEvt: evt].
! !

!PluggableButtonMorph methodsFor: 'events' stamp: 'jm 5/4/1998 17:30'!
mouseMove: evt

	allButtons ifNil: [^ self].
	allButtons do: [:m | m updateFeedbackForEvt: evt].
! !

!PluggableButtonMorph methodsFor: 'events' stamp: 'jm 5/4/1998 17:33'!
mouseUp: evt

	showSelectionFeedback _ false.
	allButtons ifNil: [^ self].
	allButtons do: [:m |
		(m containsPoint: evt cursorPoint) ifTrue: [m performAction]].
	allButtons _ nil.
	self changed.
! !

!PluggableButtonMorph methodsFor: 'events' stamp: 'jm 5/4/1998 17:22'!
updateFeedbackForEvt: evt

	| newState |
	newState _ self containsPoint: evt cursorPoint.
	newState = showSelectionFeedback ifFalse: [
		showSelectionFeedback _ newState.
		self changed].
! !


!PluggableButtonMorph methodsFor: 'updating' stamp: 'jm 5/4/1998 17:53'!
update: aParameter 

	getLabelSelector ifNotNil: [
		aParameter == getLabelSelector ifTrue: [
			self label: (model perform: getLabelSelector)]].
	self getModelState
		ifTrue: [self color: onColor]
		ifFalse: [self color: offColor].
! !


!PluggableButtonMorph methodsFor: 'private' stamp: 'di 6/26/1998 09:40'!
getMenu: shiftPressed
	"Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ MenuMorph new defaultTarget: model.
	getMenuSelector numArgs = 1 ifTrue:
		[^ model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2 ifTrue:
		[^ model perform: getMenuSelector with: menu with: shiftPressed].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'
! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'jm 4/4/98 20:50'!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	getStateSelector == nil
		ifTrue: [^ false]
		ifFalse: [^ model perform: getStateSelector].
! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'RAA 6/12/2000 09:04'!
invokeMenu: evt
	"Invoke my menu in response to the given event."
	| menu |
	menu _ self getMenu: evt shiftPressed.
	menu ifNotNil: [menu popUpEvent: evt in: self world]! !

!PluggableButtonMorph methodsFor: 'private' stamp: 'tk 10/30/1999 08:31'!
performAction
	"Inform the model that this button has been pressed. Sent by the controller when this button is pressed."

	askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]].
	actionSelector ifNotNil: [model perform: actionSelector].
! !


!PluggableButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:53'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
model _ deepCopier references at: model ifAbsent: [model].
! !

!PluggableButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:53'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"model _ model.		Weakly copied"
label _ label veryDeepCopyWith: deepCopier.
"getStateSelector _ getStateSelector.		a Symbol"
"actionSelector _ actionSelector.		a Symbol"
"getLabelSelector _ getLabelSelector.		a Symbol"
"getMenuSelector _ getMenuSelector.		a Symbol"
shortcutCharacter _ shortcutCharacter veryDeepCopyWith: deepCopier.
askBeforeChanging _ askBeforeChanging veryDeepCopyWith: deepCopier.
triggerOnMouseDown _ triggerOnMouseDown veryDeepCopyWith: deepCopier.
offColor _ offColor veryDeepCopyWith: deepCopier.
onColor _ onColor veryDeepCopyWith: deepCopier.
feedbackColor _ feedbackColor veryDeepCopyWith: deepCopier.
showSelectionFeedback _ showSelectionFeedback veryDeepCopyWith: deepCopier.
allButtons _ nil.		"a cache"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableButtonMorph class
	instanceVariableNames: ''!

!PluggableButtonMorph class methodsFor: 'instance creation'!
on: anObject

	^ self on: anObject getState: #isOn action: #switch
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'!
on: anObject getState: getStateSel action: actionSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: nil
		menu: nil
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:28'!
on: anObject getState: getStateSel action: actionSel label: labelSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: nil
! !

!PluggableButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 15:29'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: menuSel
! !


!PluggableButtonMorph class methodsFor: 'example' stamp: 'RAA 1/17/2001 14:32'!
example
	"PluggableButtonMorph example openInWorld"

	| s1 s2 s3 b1 b2 b3 row |
	s1 _ Switch new.
	s2 _ Switch new turnOn.
	s3 _ Switch new.
	s2 onAction: [s3 turnOff].
	s3 onAction: [s2 turnOff].
	b1 _ (PluggableButtonMorph on: s1 getState: #isOn action: #switch) label: 'S1'.
	b2 _ (PluggableButtonMorph on: s2 getState: #isOn action: #turnOn) label: 'S2'.
	b3 _ (PluggableButtonMorph on: s3 getState: #isOn action: #turnOn) label: 'S3'.
	b1
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	b2
		hResizing: #spaceFill;
		vResizing: #spaceFill.
	b3
		hResizing: #spaceFill;
		vResizing: #spaceFill.

	row _ AlignmentMorph newRow
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		addAllMorphs: (Array with: b1 with: b2 with: b3);
		extent: 120@35.
	^ row
! !
View subclass: #PluggableButtonView
	instanceVariableNames: 'label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown complemented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableButtonView commentStamp: '<historical>' prior: 0!
A PluggableButtonView is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:

		getStateSelector		fetch a boolean value from the model
		actionSelector		invoke this button's action on the model

Either of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.

The model informs a pluggable view of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.

Options:
	askBeforeChanging		have model ask user before allowing change that could lose edits
	triggerOnMouseDown	do button action on mouse down (vs. up) transition
	shortcutCharacter		a place to record an optional shortcut key

!


!PluggableButtonView methodsFor: 'initialize-release' stamp: 'jm 5/2/1998 15:20'!
initialize

 	super initialize.
	label _ nil.
	getStateSelector _ nil.
	actionSelector _ nil.
	getLabelSelector _ nil.
	getMenuSelector _ nil.
	shortcutCharacter _ nil.
	askBeforeChanging _ false.
	triggerOnMouseDown _ false.
	complemented _ false.
! !

!PluggableButtonView methodsFor: 'initialize-release' stamp: 'tk 4/29/1998 11:18'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	self initialize.
	self model: anObject.
	getStateSelector _ getStateSel.
	actionSelector _ actionSel.
	getLabelSelector _ labelSel.
	getMenuSelector _ menuSel.! !


!PluggableButtonView methodsFor: 'accessing' stamp: 'jrm 6/1/1998 21:53'!
action: aSymbol 
	"Set actionSelector to be the action defined by aSymbol."

	actionSelector _ aSymbol
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'!
askBeforeChanging

	^ askBeforeChanging
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/7/98 19:17'!
askBeforeChanging: aBoolean
	"If this preference is turned on, then give the model an opportunity to ask the user before accepting a change that might cause unaccepted edits to be lost."

	askBeforeChanging _ aBoolean.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:38'!
label
	"Answer the DisplayObject used as this button's label."

	^ label
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'di 5/10/1999 17:51'!
label: aStringOrDisplayObject 
	"Label this button with the given String or DisplayObject."

	((aStringOrDisplayObject isKindOf: Paragraph)
	or: [aStringOrDisplayObject isKindOf: Form])
		ifTrue: [label _ aStringOrDisplayObject]
		ifFalse: [label _ aStringOrDisplayObject asParagraph].
	self centerLabel.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter
	"Return the Character to be used as a shortcut to turn on this switch, or nil if this switch doesn't have a keyboard shortcut."

	^ shortcutCharacter
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 17:43'!
shortcutCharacter: aCharacter 
	"Set the character to be used as a keyboard shortcut for turning on this switch."

	shortcutCharacter _ aCharacter.
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'!
triggerOnMouseDown

	^ triggerOnMouseDown
! !

!PluggableButtonView methodsFor: 'accessing' stamp: 'jm 4/7/98 19:16'!
triggerOnMouseDown: aBoolean
	"If this preference is turned on, then trigger my action immediately when the mouse goes down."

	triggerOnMouseDown _ aBoolean.
! !


!PluggableButtonView methodsFor: 'controller access' stamp: 'jm 4/2/98 17:39'!
defaultControllerClass 

	^ PluggableButtonController
! !


!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/2/98 18:49'!
deEmphasizeView 

	self getModelState ifTrue: [self displayNormal].
! !

!PluggableButtonView methodsFor: 'displaying'!
display
	"Sets the PluggableButtonView mode to 'normal', displays the border, displays the inside and, if its model is 'on', complements the inside."

	self displayBorder.
	self displayView.
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/4/98 20:49'!
displayComplemented
	"Complement the receiver if it isn't already."

	complemented ifFalse: [
		complemented _ true.
		Display reverse: self insetDisplayBox].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/2/98 18:43'!
displayNormal
	"Complement the receiver if its mode is 'complemented'."

	complemented ifTrue: [
		complemented _ false.
		Display reverse: self insetDisplayBox].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'acg 2/23/2000 00:18'!
displayView

	"Displays this switch and its label, if any."

	self clearInside.
	label ifNotNil: [
		(label isKindOf: Paragraph) ifTrue: [
			label foregroundColor: self foregroundColor
				 backgroundColor: self backgroundColor].
		label displayOn: Display
				at: label boundingBox topLeft
				clippingBox: self insetDisplayBox].
	complemented _ false.! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/4/98 20:41'!
emphasizeView 

	self getModelState ifTrue: [self displayComplemented].
! !

!PluggableButtonView methodsFor: 'displaying' stamp: 'jm 4/5/98 12:54'!
toggleMouseOverFeedback
	"Complement the label (or a portion of the displayBox if no label is defined) to show that the mouse is over this button. This feedback can be removed by a second call to this method."

	Display reverse: self insetDisplayBox fillColor: Color gray.
	Display reverse: (self insetDisplayBox insetBy: 2) fillColor: Color gray.
! !


!PluggableButtonView methodsFor: 'other' stamp: 'jm 4/7/98 19:12'!
defaultWindow
	"Return a rectangle large enough to contain this button's label. If this button is label-less, just return the standard View default window."

	label == nil
		ifTrue: [^ super defaultWindow]
		ifFalse: [^ label boundingBox expandBy: 6].
! !

!PluggableButtonView methodsFor: 'other' stamp: 'jm 4/2/98 19:50'!
performAction
	"Inform the model that this button has been pressed. Sent by the controller when this button is pressed."

	actionSelector ifNotNil: [model perform: actionSelector].
! !

!PluggableButtonView methodsFor: 'other' stamp: 'tk 4/27/1998 21:23'!
update: aParameter 

	aParameter == getLabelSelector ifTrue: [
		getLabelSelector ifNotNil: [
			self label: (model perform: getLabelSelector).
			self displayView]].
	self getModelState 
		ifTrue: [self displayComplemented]
		ifFalse: [self displayNormal].
! !

!PluggableButtonView methodsFor: 'other' stamp: 'jm 4/7/98 19:12'!
window: aWindow
	"Center my label when my window changes."

	super window: aWindow.
	self centerLabel.
! !


!PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:16'!
centerAlignLabelWith: aPoint
	"Align the center of the label with aPoint."

	| alignPt |
	alignPt _ label boundingBox center.
	(label isKindOf: Paragraph) ifTrue: 
		[alignPt _ alignPt + (0@(label textStyle leading))]. 
	label align: alignPt with: aPoint
! !

!PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:10'!
centerLabel
	"If there is a label, align its center with the center of the insetDisplayBox"

	label ifNotNil: 
		[self centerAlignLabelWith: self insetDisplayBox center].
! !

!PluggableButtonView methodsFor: 'private' stamp: 'di 6/26/1998 11:04'!
getMenu: shiftKeyDown
	"Answer the menu for this view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue: [^ model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2
		ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'
! !

!PluggableButtonView methodsFor: 'private' stamp: 'jm 4/4/98 20:50'!
getModelState
	"Answer the result of sending the receiver's model the getStateSelector message."

	getStateSelector == nil
		ifTrue: [^ false]
		ifFalse: [^ model perform: getStateSelector].
! !

!PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:09'!
insetDisplayBox
	"Answer the receiver's inset display box. The inset display box is the 
	intersection of the receiver's window, tranformed to display coordinates, 
	and the inset display box of the superView, inset by the border width. 
	The inset display box represents the region of the display screen in 
	which the inside of the receiver (all except the border) is displayed. If 
	the receiver is totally clipped by the display screen and its superView, 
	the resulting Rectangle will be invalid."

	insetDisplayBox ifNil: 
		[insetDisplayBox _ self computeInsetDisplayBox.
		 self centerLabel].
	^insetDisplayBox! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableButtonView class
	instanceVariableNames: ''!

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'jm 8/14/1998 16:19'!
on: anObject

	^ self on: anObject getState: #isOn action: #switch
! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:19'!
on: anObject getState: getStateSel action: actionSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: nil
		menu: nil! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:19'!
on: anObject getState: getStateSel action: actionSel label: labelSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: nil! !

!PluggableButtonView class methodsFor: 'instance creation' stamp: 'tk 4/29/1998 11:18'!
on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel

	^ self new
		on: anObject
		getState: getStateSel
		action: actionSel
		label: labelSel
		menu: menuSel! !


!PluggableButtonView class methodsFor: 'example' stamp: 'jm 4/7/98 19:55'!
example
	"PluggableButtonView example"

	| s1 s2 s3 b1 b2 b3 topView |
	s1 _ Switch new.
	s2 _ Switch new turnOn.
	s3 _ Switch new.
	s2 onAction: [s3 turnOff].
	s3 onAction: [s2 turnOff].
	b1 _ (PluggableButtonView on: s1 getState: #isOn action: #switch) label: 'S1'.
	b2 _ (PluggableButtonView on: s2 getState: #isOn action: #turnOn) label: 'S2'.
	b3 _ (PluggableButtonView on: s3 getState: #isOn action: #turnOn) label: 'S3'.
	b1 borderWidth: 1.
	b2 borderWidth: 1.
	b3 borderWidth: 1.
	topView _ StandardSystemView new
		label: 'Switch Test';
		addSubView: b1;
		addSubView: b2 toRightOf: b1;
		addSubView: b3 toRightOf: b2.
	topView controller open.
! !
Canvas subclass: #PluggableCanvas
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!PluggableCanvas commentStamp: '<historical>' prior: 0!
An abstract canvas which modifies the behavior of an underlying canvas in some way.  Subclasses should implement apply:, which takes a one argument block and an actual canvas to draw on.  See apply: for the specific definition.!


!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 11/6/2000 16:33'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self apply: [ :c | 
		c balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/28/2000 06:52'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 19:59'!
clipBy: newClipRect during: aBlock
	self apply: [ :c |
		c clipBy: newClipRect during: aBlock ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:02'!
clipRect
	| innerClipRect |
	self apply: [ :c |
		innerClipRect := c clipRect ].
	^innerClipRect! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/26/2000 13:57'!
contentsOfArea: aRectangle into: aForm
	self apply: [ :c |
		c contentsOfArea: aRectangle into: aForm ].
	^aForm! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:01'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self apply: [ :c |
		c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/13/2000 18:56'!
extent

	self apply: [ :c | ^c extent ].
! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:03'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	self apply: [ :clippedCanvas |
		clippedCanvas fillOval: r color: c borderWidth: borderWidth borderColor: borderColor ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 11/6/2000 16:32'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."
	self shadowColor ifNotNil:
		[^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/25/2000 14:40'!
fillRectangle: aRectangle fillStyle: aFillStyle

	| pattern |

	self shadowColor ifNotNil: [^self fillRectangle: aRectangle color: self shadowColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	aFillStyle isSolidFill ifTrue:[ ^self fillRectangle: aRectangle color: aFillStyle asColor].

	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.
! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:16'!
flush
	self apply: [ :c |
		c flush ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:16'!
flushDisplay
	self apply: [ :c |
		c flushDisplay ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 7/20/2000 16:49'!
forceToScreen: rect

	self apply: [ :c |
		c forceToScreen: rect ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:04'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	self apply: [ :c |
		c frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:30'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	self apply:  [ :c |
		c image: aForm at: aPoint sourceRect: sourceRect rule: rule ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/25/2000 13:34'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self apply: [ :c | c infiniteFillRectangle: aRectangle fillStyle: aFillStyle ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:31'!
line: pt1 to: pt2 brushForm: brush
	self apply: [ :c |
		c line: pt1 to: pt2 brushForm: brush ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:31'!
line: pt1 to: pt2 width: w color: c
	self apply: [ :clippedCanvas |
		clippedCanvas line: pt1 to: pt2 width: w color: c ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'RAA 8/13/2000 18:57'!
origin

	self apply: [ :c | ^c origin ].
! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:32'!
paintImage: aForm at: aPoint
	self apply: [ :c |
		c paintImage: aForm at: aPoint ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:32'!
paintImage: aForm at: aPoint sourceRect: sourceRect
	self apply: [ :c |
		c paintImage: aForm at: aPoint sourceRect: sourceRect ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:33'!
paragraph: paragraph bounds: bounds color: color
	self apply: [ :c |
		c paragraph: paragraph bounds: bounds color: color ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:34'!
render: anObject
	self apply: [ :c |
		c render: anObject ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ar 11/1/2000 22:21'!
roundCornersOf: aMorph during: aBlock
	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: aMorph bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self
		displayBlock: aBlock
		borderWidth: aMorph borderWidth
		corners: aMorph roundedCorners! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 21:14'!
shadowColor: color
	self apply: [ :c |
		c shadowColor: color ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/25/2000 15:53'!
showAt: pt invalidRects: updateRects
	self apply: [ :c |
		c showAt: pt invalidRects: updateRects ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:35'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	self apply: [ :c |
		c stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:35'!
text: s bounds: boundsRect font: fontOrNil color: c
	self apply: [ :clippedCanvas |
		clippedCanvas text: s bounds: boundsRect font: fontOrNil color: c ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:35'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	self apply: [ :clippedCanvas |
		clippedCanvas transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:37'!
translateBy: aPoint clippingTo: aRect during: aBlock
	self apply: [ :clippedCanvas |
		clippedCanvas translateBy: aPoint clippingTo: aRect during: aBlock ]! !

!PluggableCanvas methodsFor: 'canvas methods' stamp: 'ls 3/20/2000 20:37'!
translateBy: delta during: aBlock
	self apply: [ :clippedCanvas |
		 clippedCanvas translateBy: delta during: aBlock ]! !


!PluggableCanvas methodsFor: 'private' stamp: 'ls 3/20/2000 20:46'!
apply: aBlock
	"evaluate aBlock with a canvas to do a drawing command on.  See implementors for examples"! !
CCodeGenerator subclass: #PluggableCodeGenerator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!
!PluggableCodeGenerator commentStamp: '<historical>' prior: 0!
I generate code that can be loaded dynamically from external libraries (e.g., DSOs on Unix or DLLs on Windows)!


!PluggableCodeGenerator methodsFor: 'testing' stamp: 'ar 10/7/1998 17:54'!
isGeneratingPluginCode
	^true! !


!PluggableCodeGenerator methodsFor: 'C code generator' stamp: 'ar 2/3/2001 18:36'!
emitCHeaderForPrimitivesOn: aStream
	"Write a C file header for compiled primitives onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */'; cr; cr.

	aStream nextPutAll: 
'#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

/* Default EXPORT macro that does nothing (see comment in sq.h): */
#define EXPORT(returnType) returnType

/* Do not include the entire sq.h file but just those parts needed. */
/*  The virtual machine proxy definition */
#include "sqVirtualMachine.h"
/* Configuration options */
#include "sqConfig.h"
/* Platform specific definitions */
#include "sqPlatformSpecific.h"

#define true 1
#define false 0
#define null 0  /* using ''null'' because nil is predefined in Think C */
'; cr; cr.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].

	aStream nextPutAll: '
/* Memory Access Macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

/*** Proxy Functions ***/
#define stackValue(i) (interpreterProxy->stackValue(i))
#define stackIntegerValue(i) (interpreterProxy->stackIntegerValue(i))
#define successFlag (!!interpreterProxy->failed())
#define success(bool) (interpreterProxy->success(bool))
#define arrayValueOf(oop) (interpreterProxy->arrayValueOf(oop))
#define checkedIntegerValueOf(oop) (interpreterProxy->checkedIntegerValueOf(oop))
#define fetchArrayofObject(idx,oop) (interpreterProxy->fetchArrayofObject(idx,oop))
#define fetchFloatofObject(idx,oop) (interpreterProxy->fetchFloatofObject(idx,oop))
#define fetchIntegerofObject(idx,oop) (interpreterProxy->fetchIntegerofObject(idx,oop))
#define floatValueOf(oop) (interpreterProxy->floatValueOf(oop))
#define pop(n) (interpreterProxy->pop(n))
#define pushInteger(n) (interpreterProxy->pushInteger(n))
#define sizeOfSTArrayFromCPrimitive(cPtr) (interpreterProxy->sizeOfSTArrayFromCPrimitive(cPtr))
#define storeIntegerofObjectwithValue(idx,oop,value) (interpreterProxy->storeIntegerofObjectwithValue(idx,oop,value))

/* allows accessing Strings in both C and Smalltalk */
#define asciiValue(c) c

'.
	aStream cr.! !

!PluggableCodeGenerator methodsFor: 'C code generator' stamp: 'ar 2/14/1999 01:13'!
emitCHeaderOn: aStream
	"Write a C file header onto the given stream."

	aStream nextPutAll: '/* Automatically generated from Squeak on '.
	aStream nextPutAll: Time dateAndTimeNow printString.
	aStream nextPutAll: ' */';cr.

	aStream nextPutAll:'
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

/* Default EXPORT macro that does nothing (see comment in sq.h): */
#define EXPORT(returnType) returnType

/* Do not include the entire sq.h file but just those parts needed. */
/*  The virtual machine proxy definition */
#include "sqVirtualMachine.h"
/* Configuration options */
#include "sqConfig.h"
/* Platform specific definitions */
#include "sqPlatformSpecific.h"

#define true 1
#define false 0
#define null 0  /* using ''null'' because nil is predefined in Think C */
'.

	"Additional header files"
	headerFiles do:[:hdr|
		aStream nextPutAll:'#include '; nextPutAll: hdr; cr].


	aStream nextPutAll: '
/* memory access macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)
'.
	aStream cr.! !


!PluggableCodeGenerator methodsFor: 'private' stamp: 'ar 10/7/1998 20:31'!
storeVirtualMachineProxyHeader: categoryList on: fileName
	"Store the interpreter definitions on the given file"
	| stream |
	stream _ FileStream newFileNamed: fileName.
	stream nextPutAll:
'#ifndef _SqueakVM_H
#define _SqueakVM_H

/* Increment the following number if you change the order of
   functions listed or if you remove functions */
#define VM_PROXY_MAJOR 1

/* Increment the following number if you add functions at the end */
#define VM_PROXY_MINOR 0

typedef struct VirtualMachine {
	int (*minorVersion) (void);
	int (*majorVersion) (void);
'.

	categoryList do:[:assoc|
		stream cr; crtab; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; cr; crtab.
		assoc value asSortedCollection do:[:sel|
			(methods at: sel) emitProxyFunctionPrototype: stream generator: self.
			stream nextPutAll: ';'; crtab]].

	stream nextPutAll:'
} VirtualMachine;

#endif /* _SqueakVM_H */
'.
	stream close.! !

!PluggableCodeGenerator methodsFor: 'private' stamp: 'ar 10/11/1998 00:52'!
storeVirtualMachineProxyImplementation: categoryList on: fileName
	"Store the interpreter definitions on the given file"
	| stream |
	stream _ FileStream newFileNamed: fileName.
	stream nextPutAll:'
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include "sqVirtualMachine.h"'; cr;cr.
	stream nextPutAll:'/*** Function prototypes ***/'.

	categoryList do:[:assoc|
		stream cr; cr; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; cr.
		assoc value asSortedCollection do:[:sel|
			(methods at: sel) emitCFunctionPrototype: stream generator: self.
			stream nextPutAll: ';'; cr]].

	stream cr; nextPutAll:'struct VirtualMachine *VM = NULL;'; cr.
	stream cr; nextPutAll:
'static int majorVersion(void) {
	return VM_PROXY_MAJOR;
}

static int minorVersion(void) {
	return VM_PROXY_MINOR;
}

struct VirtualMachine* sqGetInterpreterProxy(void)
{
	if(VM) return VM;
	VM = (struct VirtualMachine *) calloc(1, sizeof(VirtualMachine));
	/* Initialize Function pointers */
	VM->majorVersion = majorVersion;
	VM->minorVersion = minorVersion;
'.
	categoryList do:[:assoc|
		stream cr; crtab; nextPutAll:'/* InterpreterProxy methodsFor: ''',assoc key, ''' */'; crtab.
		assoc value asSortedCollection do:[:sel|
		stream nextPutAll:'VM->';
			nextPutAll: (self cFunctionNameFor: sel);
			nextPutAll:' = ';
			nextPutAll: (self cFunctionNameFor: sel);
			nextPutAll:';';
			crtab]].

	stream cr; crtab; nextPutAll:'return VM;'; cr; nextPutAll:'}'; cr.
	stream close.! !


!PluggableCodeGenerator methodsFor: 'public' stamp: 'ar 2/3/2001 18:29'!
codeStringForPrimitives: classAndSelectorList 
	self addClass: InterpreterPlugin.
	InterpreterPlugin declareCVarsIn: self.
	^super codeStringForPrimitives: classAndSelectorList ! !
Dictionary subclass: #PluggableDictionary
	instanceVariableNames: 'hashBlock equalBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!PluggableDictionary commentStamp: '<historical>' prior: 0!
Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example.

Instance variables:
	hashBlock	<BlockContext>	A one argument block used for hashing the elements.
	equalBlock	<BlockContext>	A two argument block used for comparing the elements.
!


!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'!
equalBlock: aBlock
	"Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise"
	equalBlock _ aBlock.! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
hashBlock
	"Return the block used for hashing the elements in the receiver."
	^hashBlock! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'!
hashBlock: aBlock
	"Set a new hash block. The block must accept one argument and must return the hash value of the given argument."
	hashBlock _ aBlock.! !

!PluggableDictionary methodsFor: 'accessing' stamp: 'dvf 6/10/2000
19:34'!
keys
	"Answer a Set containing the receiver's keys."
	| aSet |
	aSet _ PluggableSet new: self size.
	self equalBlock ifNotNil: [aSet equalBlock: self equalBlock fixTemps].
	self hashBlock ifNotNil: [aSet hashBlock: self hashBlock fixTemps].
	self keysDo: [:key | aSet add: key].
	^ aSet! !


!PluggableDictionary methodsFor: 'copying' stamp: 'ar 11/12/1998 18:48'!
copy
	^super copy postCopyBlocks! !

!PluggableDictionary methodsFor: 'copying' stamp: 'dvf 6/10/2000 19:35'!
postCopyBlocks
	hashBlock _ hashBlock copy.
	equalBlock _ equalBlock copy.
	"Fix temps in case we're referring to outside stuff"
	hashBlock ifNotNil: [hashBlock fixTemps].
	equalBlock ifNotNil: [equalBlock fixTemps]! !


!PluggableDictionary methodsFor: 'private' stamp: 'dvf 6/11/2000 01:33'!
scanFor: anObject 
	"Scan the key array for the first slot containing either a nil
(indicating 
	  an empty slot) or an element that matches anObject. Answer the index 
	  
	of that slot or zero if no slot is found. This  method will be
overridden   
	in various subclasses that have different interpretations for matching 
 
	elements."
	| element start finish |
	start _ (hashBlock ifNil: [anObject hash]
				ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element key = anObject]
				ifNotNil: [equalBlock value: element key value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableDictionary class
	instanceVariableNames: ''!

!PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'dvf
6/10/2000 18:13'!
integerDictionary
	^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !
FileList subclass: #PluggableFileList
	instanceVariableNames: 'accepted fileFilterBlock canAcceptBlock validateBlock newFiles prompt resultBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!PluggableFileList commentStamp: '<historical>' prior: 0!
I am a model for a modal dialog akin to "Standard File Services" on various modern GUI operating systems.  My protocol includes some methods to maintain upward compatibility with StandardFileMenu, which I hope to replace.

Sample doIts:

	"StandardFileDialog getFolder"-- ask user to select folder, answer corresponding FileDirectory
	"StandardFileDialog getFile"	-- ask user to select file, answer corresponding FileStream
	"StandardFileDialog putFile"	-- ask user to create new file, answer FileStream

  In addition to the instance variables inhereted from FileList, of which I am a subclass, I am pluggable via the following instance variables:

prompt			<String>
	Display a prompt between the buttons.

resultBlock		<BlockContext>
	Passed a file directory and a file name, answer the result to be answered by the dialog.	

canAcceptBlock	<BlockContext>	
	Answer whether the accept button should be "active"

fileFilterBlock	<BlockContext>	
	Passed a file directory entry, answer whether the entry should be added to the list.  The list can be further filtered (but not expanded) by the user through the pattern.

validateBlock	<BlockContent>
	Passed a file directory entry, a file name and a collection of newly created files, answer whether the dialog selection is valid.  validateBlock is checked after the user has pressed accept, for example to ask if the user really meant to delete a file.

newFiles		<OrderedCollection>

	newFiles is an OrderedCollection of fileNames of files added by the user to the current directory since the user last entered same!


!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/12/2000 21:44'!
defaultBackgroundColor

	^Color lightYellow! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/12/2000 14:52'!
initialize

	prompt _ 'Select File'.
	directory _ FileDirectory default.
	newFiles _ OrderedCollection new.
	fileFilterBlock _ PluggableFileList allFilesAndFoldersFileFilter.
	canAcceptBlock _ PluggableFileList fileNameSelectedAcceptBlock.
	resultBlock _ PluggableFileList pathNameResultBlock.
	validateBlock _ PluggableFileList checkExistingFileValidateBlock.
! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/9/2000 01:28'!
open

	^self openLabel: directory pathName! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'RAA 1/17/2001 14:32'!
openAsMorphLabel: aString inWorld: aWorld
	"Open a view of an instance of me."
	"PluggableFileList new openAsMorphLabel: 'foo' inWorld: World"
	| windowMorph volListMorph templateMorph fileListMorph leftButtonMorph middleButtonMorph rightButtonMorph |
	
	self directory: directory.
	windowMorph _ (SystemWindow labelled: aString) model: self.

	volListMorph _ PluggableListMorph on: self
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListMorph autoDeselect: false.
	windowMorph addMorph: volListMorph frame: (0@0 corner: 0.4@0.5625).

	templateMorph _ PluggableTextMorph on: self
		text: #pattern
		accept: #pattern:.
	templateMorph askBeforeDiscardingEdits: false.
	windowMorph addMorph: templateMorph frame: (0@0.5625 corner: 0.4@0.75).

	fileListMorph _ PluggableListMorph on: self
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.

	windowMorph addMorph: fileListMorph frame: (0.4@0 corner: 1.0@0.75).

	leftButtonMorph _ PluggableButtonMorph 
		on: self
		getState: #leftButtonState
		action: #leftButtonPressed.
	leftButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'Cancel';
		onColor: Color red offColor: Color red;
		feedbackColor: Color orange;
		borderWidth: 3.

	middleButtonMorph _ PluggableButtonMorph
		on: self
		getState: nil
		action: nil.
	middleButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: prompt;
		onColor: Color lightYellow offColor: Color lightYellow;
		feedbackColor: Color lightYellow;
		borderWidth: 1.

	rightButtonMorph _ PluggableButtonMorph
		on: self
		getState: #rightButtonState
		action: #rightButtonPressed.
	rightButtonMorph
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		label: 'Accept';
		onColor: Color green offColor: Color lightYellow;
		feedbackColor: Color black;
		borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]).
	"self canAccept ifFalse: [rightButtonMorph controller: NoController new]."

	windowMorph
		addMorph: leftButtonMorph frame: (0@0.75 corner: 0.25@1.0);
		addMorph: middleButtonMorph frame: (0.25@0.75 corner: 0.75@1.0);
		addMorph: rightButtonMorph frame: (0.75@0.75 corner: 1.0@1.0).

	self changed: #getSelectionSel.

	windowMorph openInWorld
! !

!PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 01:10'!
openLabel: aString
	"Open a view of an instance of me."
	"StandardFileDialog new open"
	| topView volListView templateView fileListView fileStringView leftButtonView middleButtonView rightButtonView |
	
	self directory: directory.
	topView _ (PluggableFileListView new)
		model: self.

	volListView _ PluggableListView on: self
		list: #volumeList
		selected: #volumeListIndex
		changeSelected: #volumeListIndex:
		menu: #volumeMenu:.
	volListView autoDeselect: false.
	volListView window: (0@0 extent: 80@45).
	topView addSubView: volListView.

	templateView _ PluggableTextView on: self
		text: #pattern
		accept: #pattern:.
	templateView askBeforeDiscardingEdits: false.
	templateView window: (0@0 extent: 80@15).
	topView addSubView: templateView below: volListView.

	fileListView _ PluggableListView on: self
		list: #fileList
		selected: #fileListIndex
		changeSelected: #fileListIndex:
		menu: #fileListMenu:.
	fileListView window: (0@0 extent: 120@60).

	topView addSubView: fileListView toRightOf: volListView.

	fileListView controller terminateDuringSelect: true.  "Pane to left may change under scrollbar"

	"fileStringView _ PluggableTextView on: self
		text: #fileString
		accept: #fileString:.
	fileStringView askBeforeDiscardingEdits: false.
	fileStringView window: (0@0 extent: 200@15).
	topView addSubView: fileStringView below: templateView."
	fileStringView _ templateView.


	leftButtonView _ PluggableButtonView 
		on: self
		getState: nil
		action: #leftButtonPressed.
	leftButtonView
		label: 'Cancel';
		backgroundColor: Color red;
		borderWidth: 3;
		window: (0@0 extent: 50@15).

	middleButtonView _ PluggableButtonView
		on: self
		getState: nil
		action: nil.
	middleButtonView
		label: prompt;
		window: (0@0 extent: 100@15);
		borderWidth: 1;
		controller: NoController new.

	rightButtonView _ PluggableButtonView
		on: self
		getState: nil
		action: #rightButtonPressed.
	rightButtonView
		label: 'Accept';
		backgroundColor: (self canAccept ifTrue: [Color green] ifFalse: [Color lightYellow]);
		borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]);
		window: (0@0 extent: 50@15).
	self canAccept ifFalse: [rightButtonView controller: NoController new].

	topView acceptButtonView: rightButtonView.

	topView
		addSubView: leftButtonView below: fileStringView;
		addSubView: middleButtonView toRightOf: leftButtonView;
		addSubView: rightButtonView toRightOf: middleButtonView.

	self changed: #getSelectionSel.
	topView doModalDialog.
	
	^self result
! !


!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:33'!
beAccepted

	^accepted _ true! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 09:10'!
canAccept

	^canAcceptBlock value: directory value: fileName! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:52'!
canAcceptBlock: aBlock

	^canAcceptBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 07:33'!
fileFilterBlock: aBlock

	^fileFilterBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'!
fileListIndex

	self changed: #fileString.
	^super fileListIndex! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'!
fileVolumeIndex

	self changed: #fileString.
	^super fileVolumeIndex! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:28'!
prompt: aString

	 prompt _ aString! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:31'!
resultBlock: aBlock

	^resultBlock _ aBlock! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:28'!
validate

	^validateBlock value: directory value: fileName value: newFiles! !

!PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/10/2000 08:02'!
validateBlock: aBlock

	^validateBlock _ aBlock! !


!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 01:05'!
leftButtonPressed

	accepted _ false.
	self changed: #close.
! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:40'!
leftButtonState

	^true! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 00:38'!
result

	accepted ifFalse: [^nil].
	^resultBlock value: directory value: fileName! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/10/2000 07:58'!
rightButtonPressed

	(canAcceptBlock value: directory value: fileName) ifFalse: [^nil].
	(validateBlock value: directory value: fileName value: newFiles) ifFalse: [^nil].
	accepted _ true.
	self changed: #close! !

!PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:43'!
rightButtonState

	^self canAccept! !


!PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/10/2000 07:47'!
addNew: aString byEvaluating: aBlock
	"A parameterization of earlier versions of #addNewDirectory and
	#addNewFile.  Fixes the bug in each that pushing the cancel button
	in the FillInTheBlank dialog gave a walkback."

	| response newName index ending |
	self okToChange ifFalse: [^ self].
	(response _ FillInTheBlank request: 'New ',aString,' Name?'
 					initialAnswer: aString,'Name')
		isEmpty ifTrue: [^ self].
	newName _ response asFileName.
	Cursor wait showWhile: [
		aBlock value: newName].
	self updateFileList.
	index _ list indexOf: newName.
	index = 0 ifTrue: [ending _ ') ',newName.
		index _ list findFirst: [:line | line endsWith: ending]].
	self fileListIndex: index.
	newFiles add: newName
! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:57'!
fileSelectedMenu: aMenu
	| firstItems secondItems thirdItems n1 n2 n3 |
	firstItems _ self itemsForFileEnding: self fileNameSuffix asLowercase.
	secondItems _ self itemsForAnyFile.
	thirdItems _ self itemsForNoFile.
	n1 _ firstItems first size.
	n2 _ n1 + secondItems first size.
	n3 _ n2 + thirdItems first size.
	^ aMenu
		labels: firstItems first , secondItems first , thirdItems first
		lines: firstItems second
				, (Array with: n1 with: n2)
				, (thirdItems second collect: [:n | n + n2])
				, (Array with: n3)
		selections: firstItems third , secondItems third , thirdItems third! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:49'!
itemsForFileEnding: suffix
	| labels lines selectors |
	labels _ OrderedCollection new.
	lines _ OrderedCollection new.
	selectors _ OrderedCollection new.
	^ Array with: labels with: lines with: selectors! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:50'!
itemsForNoFile
	^ #(
		('sort by name' 'sort by size' 'sort by date'
		'add new file' 'add new directory')
		(3)
		(sortByName sortBySize sortByDate
		addNewFile addNewDirectory)
		)! !

!PluggableFileList methodsFor: 'file list menu' stamp: 'sma 11/11/2000 18:14'!
listForPattern: pat
	"Make the list be those file names which match the pattern."
	| entries sizePad newList allFiles |
	entries _ directory entries select: fileFilterBlock.
	sizePad _ (entries inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
					asStringWithCommas size - 1.

	newList _ (SortedCollection new: 30) sortBlock: self sortBlock.

	allFiles _ pat = '*'.
	entries do:
		[:entry | "<dirflag><name><creationTime><modificationTime><fileSize>"
		(allFiles or: [entry isDirectory or: [pat match: entry first]]) ifTrue:
			[newList add: entry]].

	newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].

	volList size = 1 ifTrue:
		["Include known servers along with other desktop volumes" 
		^ newList asArray ,
		(ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
	newFiles _ OrderedCollection new.
	^ newList asArray.! !


!PluggableFileList methodsFor: 'file string' stamp: 'acg 2/18/2000 21:23'!
fileString

	fileName ifNil: [^directory pathName].
	^directory fullNameFor: fileName! !

!PluggableFileList methodsFor: 'file string' stamp: 'acg 2/19/2000 01:02'!
fileString: aString

	"| textName index ending |
	textName _ aString asString.
	(FileDirectory default fileExists: textName) ifTrue:
		[self directory: (FileDirectory forFileName: textName).
		 index _ list indexOf: (FileDirectory localNameFor: textName).
		 index = 0 ifTrue: 
			[ending _ ') ', (FileDirectory localNameFor: textName).
		  	 index _ list findFirst: [:line | line endsWith: ending]].
		 self fileListIndex: index].
	(FileDirectory default directoryExists: textName) ifTrue:
		[self directory: (FileDirectory on: textName)]."
	self changed: #fileString.
	self changed: #contents.
	^true! !


!PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'RAA 5/25/2000 09:29'!
startUpWithCaption: captionOrNil
	"Display the menu, slightly offset from the cursor,
	so that a slight tweak is required to confirm any action."

	^ self startUpWithCaption: captionOrNil at: Display lastKnownCursorPoint! !

!PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:35'!
startUpWithCaption: aString at: location

	self prompt: aString.
	^self open! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableFileList class
	instanceVariableNames: ''!

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFilePathNameDialog

	^(self new)
		validateBlock: PluggableFileList alwaysValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFilePathNameDialogWithExistenceCheck

	^(self new)
		prompt: 'Select New File:';
		validateBlock: PluggableFileList checkExistingFileValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'!
getFolderDialog

	^(self new)
		prompt: 'Select a Folder';
		fileFilterBlock: PluggableFileList allFoldersFileFilter;
		canAcceptBlock: PluggableFileList alwaysAcceptBlock;
		resultBlock: PluggableFileList directoryResultBlock;
		validateBlock: PluggableFileList alwaysValidateBlock;
		yourself! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/9/2000 00:35'!
new

	^super new initialize! !

!PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/9/2000 00:34'!
open

	^self new open! !


!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:24'!
getFile

	| result |
	result _ self getFilePathName.
	^result ifNotNil: [FileStream oldFileNamed: result]! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:31'!
getFilePathName

	^self getFilePathNameDialog open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'!
getFilePathNameWithExistenceCheck

	^self getFilePathNameDialogWithExistenceCheck open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/9/2000 01:16'!
getFolder

	^self getFolderDialog open! !

!PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'!
putFile

	| result |
	result _ self getFilePathNameWithExistenceCheck.
	^result ifNotNil: 
		[FileDirectory deleteFilePath: result.
		 FileStream newFileNamed: result]! !


!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:19'!
directoryResultBlock

	^[:theDirectory :theFileName | theDirectory]! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'!
fileNameResultBlock

	^[:theDirectory :theFileName | theFileName]! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'!
pathNameResultBlock

	^[:theDirectory :theFileName | 
		theFileName 
			ifNil: [theDirectory pathName]
			ifNotNil: [theDirectory fullNameFor: theFileName]].
! !

!PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/12/2000 15:08'!
sfmResultBlock

	^[:theDirectory :theFileName | 
		StandardFileMenuResult directory: theDirectory name: theFileName]! !


!PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:18'!
alwaysAcceptBlock

	^[:theDirectory :theFileName | true]! !

!PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:10'!
fileNameSelectedAcceptBlock

	^[:theDirectory :theFileName | theFileName isNil not]! !


!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 08:27'!
alwaysValidateBlock

	^[:theDirectory :theFileName :theNewFiles | true].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'!
checkExistingFileValidateBlock

	^[:theDirectory :theFileName :theNewFiles | 
		(theNewFiles includes: theFileName) or:
			[(PluggableFileList okToOverwrite: theFileName)]].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'!
existingFileValidateBlock

	^[:theDirectory :theFileName :theNewFiles | 
		(theNewFiles includes: theFileName) or:
			[(PluggableFileList okToOverwrite: theFileName)]].! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 08:05'!
okToOpen: aFileNameString without: aSuffixString

	"Answer whether user confirms that it is ok to overwrite the file named in aString"
	^ 1 = ((PopUpMenu
		labels:
'overwrite that file
select another file')
		startUpWithCaption: aFileNameString, '
already exists.')
! !

!PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 07:55'!
okToOverwrite: aString

	"Answer whether user confirms that it is ok to overwrite the file named in aString"
	^ 1 = ((PopUpMenu
		labels:
'overwrite that file
select another file')
		startUpWithCaption: aString, '
already exists.')
! !


!PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:16'!
allFilesAndFoldersFileFilter

	^[:each | true]! !

!PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:17'!
allFoldersFileFilter

	^[:each | each isDirectory]! !


!PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:10'!
newFileMenu: aDirectory

	"For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult"
	^(self getFilePathNameDialogWithExistenceCheck)
		resultBlock: self sfmResultBlock;
		yourself! !

!PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:11'!
oldFileMenu: aDirectory

	"For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult"
	^(self getFilePathNameDialog)
		resultBlock: self sfmResultBlock;
		yourself! !
ModalSystemWindowView subclass: #PluggableFileListView
	instanceVariableNames: 'acceptButtonView '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!PluggableFileListView commentStamp: '<historical>' prior: 0!
I provide aview for PluggableFileList!


!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:57'!
acceptButtonView: aView

	^acceptButtonView _ aView! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/18/2000 20:52'!
label: aString

	super label: aString.
	self noLabel! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:55'!
update: aSymbol
	(aSymbol = #volumeListIndex or: [aSymbol = #fileListIndex])
		ifTrue: [self updateAcceptButton].
	^super update: aSymbol! !

!PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 09:40'!
updateAcceptButton

	self model canAccept
		ifTrue:
			[acceptButtonView
				backgroundColor: Color green;
				borderWidth: 3;
				controller: acceptButtonView defaultController]
		ifFalse:
			[acceptButtonView
				backgroundColor: Color lightYellow;
				borderWidth: 1;
				controller: NoController new].
	acceptButtonView display.! !
ListController subclass: #PluggableListController
	instanceVariableNames: 'terminateDuringSelect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListController methodsFor: 'initialization' stamp: 'di 5/25/1998 10:15'!
initialize
	super initialize.
	self terminateDuringSelect: false! !


!PluggableListController methodsFor: 'control defaults' stamp: 'tk 4/1/98 09:40'!
redButtonActivity
	model okToChange   "Don't change selection if model refuses to unlock"
		ifTrue: [^ super redButtonActivity]! !


!PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:20'!
changeModelSelection: anInteger
	"Let the view handle this."

	terminateDuringSelect ifTrue: [self controlTerminate].
	view changeModelSelection: anInteger.
	terminateDuringSelect ifTrue: [self controlInitialize].! !

!PluggableListController methodsFor: 'private' stamp: 'sma 3/11/2000 15:38'!
processKeyboard
	sensor keyboardPressed
		ifTrue: [view handleKeystroke: sensor keyboard]
		ifFalse: [super processKeyboard]! !

!PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:14'!
terminateDuringSelect: trueOrFalse
	terminateDuringSelect _ trueOrFalse! !


PluggableListController subclass: #PluggableListControllerOfMany
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListControllerOfMany methodsFor: 'control defaults' stamp: 'tk 4/8/98 11:08'!
redButtonActivity
	| selection firstHit turningOn lastSelection pt scrollFlag |
	model okToChange ifFalse: [^ self].
		"Don't change selection if model refuses to unlock"
	firstHit _ true.
	scrollFlag _ false.
	lastSelection _ 0.
	[sensor redButtonPressed] whileTrue: 
		[selection _ view findSelection: (pt _ sensor cursorPoint).
		selection == nil ifTrue:  "Maybe out of box - check for auto-scroll"
			[pt y < view insetDisplayBox top ifTrue:
				[self scrollView: view list lineGrid.
				scrollFlag _ true.
				selection _ view firstShown].
			pt y > view insetDisplayBox bottom ifTrue:
				[self scrollView: view list lineGrid negated.
				scrollFlag _ true.
				selection _ view lastShown]].
		(selection == nil or: [selection = lastSelection]) ifFalse: 
			[firstHit ifTrue:
				[firstHit _ false.
				turningOn _ (model listSelectionAt: selection) not].
			view selection: selection.
			(model listSelectionAt: selection) == turningOn ifFalse:
				[view displaySelectionBox.
				model listSelectionAt: selection put: turningOn].
			lastSelection _ selection]].
	selection notNil ifTrue:
		["Normal protocol delivers change, so unchange first (ugh)"
		model listSelectionAt: selection put: (model listSelectionAt: selection) not.
		self changeModelSelection: selection].
	scrollFlag ifTrue: [self moveMarker]! !


!PluggableListControllerOfMany methodsFor: 'scrolling' stamp: 'tk 4/8/98 11:09'!
scrollView: anInteger 
	"Need to minimize the selections which get recomputed"
	| oldLimit |
	oldLimit _ anInteger > 0
		ifTrue: [view firstShown]
		ifFalse: [view lastShown].
	(view scrollBy: anInteger)
		ifTrue: [anInteger > 0  "Highlight selections brought into view"
					ifTrue: [view highlightFrom: view firstShown
								to: (oldLimit-1 min: view lastShown)]
					ifFalse: [view highlightFrom: (oldLimit+1 max: view firstShown)
								to: view lastShown].
				^ true]
		ifFalse: [^ false]! !
ScrollPane subclass: #PluggableListMorph
	instanceVariableNames: 'list selectedMorph selection getListSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect font lastKeystrokeTime lastKeystrokes lastClickTime doubleClickSelector potentialDropMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!PluggableListMorph commentStamp: '<historical>' prior: 0!
...

When a PluggableListMorph is in focus, type in a letter (or several
letters quickly) to go to the next item that begins with that letter.
Special keys (up, down, home, etc.) are also supported.!


!PluggableListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/12/2000 16:22'!
doubleClickSelector: aSymbol
	doubleClickSelector _ aSymbol! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'jm 9/20/1998 17:28'!
font

	^ font
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'jm 9/20/1998 19:48'!
font: aFontOrNil

	font _ aFontOrNil.
	self list: self getList.  "update display"
! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 10/30/2000 11:17'!
getListSelector: sel
	"Set the receiver's getListSelector as indicated, and trigger a recomputation of the list"

	getListSelector _ sel.
	self changed! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 10/11/1999 08:45'!
initForKeystrokes
	lastKeystrokeTime _ 0.
	lastKeystrokes _ ''! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 5/6/1998 21:19'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/18/2001 13:08'!
keystrokeActionSelector: keyActionSel
	"Set the keystroke action selector as specified"

	keystrokeActionSelector _ keyActionSel! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'ar 1/31/2001 19:22'!
list: listOfStrings 
	| morphList h loc index |
	scroller removeAllMorphs.
	list _ listOfStrings ifNil: [Array new].
	list isEmpty ifTrue: [self setScrollDeltas.  ^ self selectedMorph: nil].
	"NOTE: we will want a quick StringMorph init message, possibly even
		combined with event install and positioning"
	font ifNil: [font _ Preferences standardListFont].
	morphList _ list collect:
		[:item | item isText
			ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)]
			ifFalse: [StringMorph contents: item font: font]].

	self highlightSelector ifNotNil:[
		model perform: self highlightSelector with: list with: morphList.
	].

	"Lay items out vertically and install them in the scroller"
	h _ morphList first height "self listItemHeight".
	loc _ 0@0.
	morphList do: [:m | m bounds: (loc extent: 9999@h).  loc _ loc + (0@h)].
	scroller addAllMorphs: morphList.
	self installEventHandlerOn: morphList.

	index _ self getCurrentSelectionIndex.
	self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]).
	self setScrollDeltas.
	scrollBar setValue: 0.0! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!PluggableListMorph methodsFor: 'initialization' stamp: 'di 10/11/1999 08:45'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel 
	self model: anObject.
	getListSelector _ getListSel.
	getIndexSelector _ getSelectionSel.
	setIndexSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self list: self getList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !


!PluggableListMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:21'!
highlightSelector
	^self valueOfProperty: #highlightSelector! !

!PluggableListMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:38'!
highlightSelector: aSelector
	self setProperty: #highlightSelector toValue: aSelector.
	self list: self getList.! !


!PluggableListMorph methodsFor: 'drawing' stamp: 'RAA 1/29/2001 15:14'!
drawOn: aCanvas
	| colorToFillWith areaToFill next |

	super drawOn: aCanvas.
	selectedMorph ifNil: [^self].
	colorToFillWith _ color.
	next _ self.
	[colorToFillWith isTransparent and: [(next _ next owner) notNil]] whileTrue: [
		colorToFillWith _ next color.
	].
	colorToFillWith _ colorToFillWith luminance < 0.5 ifTrue: [
		colorToFillWith muchLighter
	] ifFalse: [
		colorToFillWith darker
	].

	areaToFill _ ((scroller transformFrom: self) localBoundsToGlobal: selectedMorph bounds)
					intersect: scroller bounds.
	aCanvas fillRectangle: areaToFill color: colorToFillWith.
! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'sr 4/23/2000 01:26'!
highlightSelection
	selectedMorph ifNotNil: [selectedMorph color: Color red; changed]! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'sbw 12/1/2000 12:12'!
superDrawOn: aCanvas 
	super drawOn: aCanvas.
! !

!PluggableListMorph methodsFor: 'drawing' stamp: 'sr 4/23/2000 01:27'!
unhighlightSelection
	selectedMorph ifNotNil: [selectedMorph color: Color black; changed]! !


!PluggableListMorph methodsFor: 'events' stamp: 'LC 5/20/2000 19:41'!
doubleClick: event onItem: aMorph
	doubleClickSelector isNil ifTrue: [^ self].
	selectedMorph ifNil: [self setSelectedMorph: aMorph].
	^ self model perform: doubleClickSelector! !

!PluggableListMorph methodsFor: 'events' stamp: 'jlm 10/4/1999 23:11'!
handlesBasicKeys
	" if ya don't want the list to automatically handle non-modifier key 
	(excluding shift key) input, return false"
	^ true! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/15/2000 22:57'!
handlesKeyboard: evt
	^true! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/14/2000 19:16'!
keyStroke: event 
	"Process keys 
	specialKeys are things like up, down, etc. ALWAYS HANDLED 
	modifierKeys are regular characters either 1) accompanied with ctrl, 
	cmd or 2) any character if the list doesn't want to handle basic 
	keys (handlesBasicKeys returns false) 
	basicKeys are any characters"
	| aChar aSpecialKey |
	(self scrollByKeyboard: event) ifTrue: [^self].
	aChar _ event keyCharacter.
	aSpecialKey _ aChar asciiValue.
	aSpecialKey < 32 ifTrue: [^ self specialKeyPressed: aSpecialKey].
	(event anyModifierKeyPressed or: [self handlesBasicKeys not])
		ifTrue: [^ self modifierKeyPressed: aChar].
	^ self basicKeyPressed: aChar! !

!PluggableListMorph methodsFor: 'events' stamp: 'LC 5/29/2000 22:12'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed]! !

!PluggableListMorph methodsFor: 'events' stamp: 'RAA 12/18/2000 19:51'!
mouseDown: event onItem: aMorph

	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	aMorph ifNotNil: [
		self dragEnabled ifTrue: [aMorph highlightForMouseDown]
	]! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/15/2000 23:04'!
mouseEnter: event
	super mouseEnter: event.
	self flag: #arNote. "remove this - keyboard input automatically goes right"
	event hand newKeyboardFocus: self. ! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/18/2000 22:18'!
mouseEnterDragging: anEvent onItem: aMorph 
	anEvent hand hasSubmorphs ifFalse: ["no d&d"
		^ self].
	(self wantsDroppedMorph: anEvent hand firstSubmorph event: anEvent )
		ifTrue: 
			[self potentialDropMorph: aMorph]! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/15/2000 23:30'!
mouseLeave: event
	super mouseLeave: event.
	event hand releaseKeyboardFocus: self.! !

!PluggableListMorph methodsFor: 'events' stamp: 'panda 4/28/2000 11:50'!
mouseLeaveDragging: anEvent onItem: aMorph 
	anEvent hand hasSubmorphs ifFalse: ["no d&d"
		^ self].
	(self wantsDroppedMorph: anEvent hand firstSubmorph event: anEvent )
		ifTrue: 
			[self resetPotentialDropMorph]! !

!PluggableListMorph methodsFor: 'events' stamp: 'LC 5/29/2000 22:26'!
mouseUp: evt
	"do nothing but fix the nobody land bug"! !

!PluggableListMorph methodsFor: 'events' stamp: 'ar 9/14/2000 21:35'!
mouseUp: event onItem: aMorph 
	aMorph ifNotNil: [aMorph highlightForMouseDown: false].
	model okToChange ifFalse: [
		^ self].
	"No change if model is locked"
	((autoDeselect == nil or: [autoDeselect]) and: [aMorph == selectedMorph])
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
	Cursor normal show.
! !

!PluggableListMorph methodsFor: 'events' stamp: 'sw 7/21/1999 12:19'!
wantsKeyboardFocusFor: aMorph
	^ false! !

!PluggableListMorph methodsFor: 'events' stamp: 'di 9/24/2000 12:51'!
worldMorphsDo: aBlock  "No worlds hiding here"

	^ self! !


!PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'!
getListSelector
	^ getListSelector! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:21'!
maximumSelection
	^ list size! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'!
minimumSelection
	^ 1! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:32'!
numSelectionsInView
	^ self height // self listItemHeight! !

!PluggableListMorph methodsFor: 'selection'!
selectedMorph: aMorph
	self unhighlightSelection.
	selectedMorph _ aMorph.
	selection _ aMorph ifNil: [nil] ifNotNil: [aMorph contents].
	self highlightSelection! !

!PluggableListMorph methodsFor: 'selection'!
selection 
	^ selection! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 11:03'!
selection: item
	"Called from outside to request setting a new selection.
	Assumes scroller submorphs is exactly our list.
	Note: won't work right if list includes repeated items"

	self selectionIndex: (scroller submorphs findFirst: [:m | m contents = item])! !

!PluggableListMorph methodsFor: 'selection' stamp: 'sw 10/30/1999 23:00'!
selectionIndex: index
	"Called internally to select the index-th item."
	| theMorph range |
	(index isNil or: [index > scroller submorphs size]) ifTrue: [^ self].
	(theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: 
index])
		ifNotNil:
		[((theMorph bounds top - scroller offset y) >= 0
			and: [(theMorph bounds bottom - scroller offset y) <= bounds height]) 
ifFalse:
			["Scroll into view -- should be elsewhere"
			range _ self leftoverScrollRange.
			scrollBar value: (range > 0
				ifTrue: [((index-1 * theMorph height) / self leftoverScrollRange)
									truncateTo: scrollBar scrollDelta]
				ifFalse: [0]).
			scroller offset: -3 @ (range * scrollBar value)]].
	self selectedMorph: theMorph! !

!PluggableListMorph methodsFor: 'selection' stamp: 'sw 10/30/2000 11:16'!
setGetListSelector: sel
	"Set the the receiver's getListSelector as indicated.  For access via scripting"

	getListSelector _ sel! !

!PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 21:20'!
setSelectedMorph: aMorph
	self changeModelSelection: (scroller submorphs indexOf: aMorph)! !


!PluggableListMorph methodsFor: 'model access' stamp: 'JLM 10/8/1999 03:49'!
basicKeyPressed: aChar 
	| oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText |
	nextSelection _ oldSelection _ self getCurrentSelectionIndex.
	max _ self maximumSelection.
	milliSeconds _ Time millisecondClockValue.
	milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting"
		lastKeystrokes _ ''].
	lastKeystrokes _ lastKeystrokes , aChar asLowercase asString.
	lastKeystrokeTime _ milliSeconds.
	nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max).
	nextSelectionList addAll: (list copyFrom: 1 to: oldSelection).
	"Get rid of blanks and style used in some lists"
	nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes]
				ifNone: [^ self flash"match not found"].
	model okToChange ifFalse: [^ self].
	nextSelection _ list findFirst: [:a | a == nextSelectionText].
	"No change if model is locked"
	oldSelection == nextSelection ifTrue: [^ self flash].
	^ self changeModelSelection: nextSelection! !

!PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."

	setIndexSelector ifNotNil:
		[model perform: setIndexSelector with: anInteger].! !

!PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getIndexSelector == nil ifTrue: [^ 0].
	^ model perform: getIndexSelector! !

!PluggableListMorph methodsFor: 'model access' stamp: 'jlm 10/4/1999 23:45'!
getList
	"Answer the list to be displayed."
	| lst |
	getListSelector == nil ifTrue: [^ #()].
	lst _ model perform: getListSelector.
	lst == nil ifTrue: [^ #()].
	^ lst! !

!PluggableListMorph methodsFor: 'model access' stamp: 'jlm 10/4/1999 23:39'!
modifierKeyPressed: aChar 
	| args |
	keystrokeActionSelector == nil ifTrue: [^ nil].
	args _ keystrokeActionSelector numArgs.
	args = 1 ifTrue: [^ model perform: keystrokeActionSelector with: aChar].
	args = 2 ifTrue: [^ model
			perform: keystrokeActionSelector
			with: aChar
			with: self].
	^ self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!PluggableListMorph methodsFor: 'model access' stamp: 'JLM 10/8/1999 03:50'!
specialKeyPressed: asciiValue 
	| oldSelection nextSelection max howManyItemsShowing |
	nextSelection _ oldSelection _ self getCurrentSelectionIndex.
	max _ self maximumSelection.
	asciiValue == 31
		ifTrue: 
			[" down arrow"
			nextSelection _ oldSelection + 1.
			nextSelection > max ifTrue: [nextSelection _ 1]].
	asciiValue == 30
		ifTrue: 
			[" up arrow"
			nextSelection _ oldSelection - 1.
			nextSelection < 1 ifTrue: [nextSelection _ max]].
	asciiValue == 1 ifTrue: [" home"
		nextSelection _ 1].
	asciiValue == 4 ifTrue: [" end"
		nextSelection _ max].
	howManyItemsShowing _ self numSelectionsInView.
	asciiValue == 11 ifTrue: [" page up"
		nextSelection _ 1 max: oldSelection - howManyItemsShowing].
	asciiValue == 12 ifTrue: [" page down"
		nextSelection _ oldSelection + howManyItemsShowing min: max].
	model okToChange ifFalse: [^ self].
	"No change if model is locked"
	oldSelection == nextSelection ifTrue: [^ self flash].
	^ self changeModelSelection: nextSelection! !


!PluggableListMorph methodsFor: 'updating' stamp: 'di 5/6/1998 21:21'!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == getListSelector ifTrue: 
		[self list: self getList.
		^ self].
	aSymbol == getIndexSelector ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self].
! !

!PluggableListMorph methodsFor: 'updating' stamp: 'sw 10/30/1999 23:00'!
verifyContents
	| newList existingSelection anIndex |
	"Called periodically, or at least on window reactivation to react to possible structural changes.  Update contents if necessary."
	newList _ self getList.
	((list == newList) "fastest" or: [list = newList]) ifTrue: [^ self].
	self flash.  "list has changed beneath us; could get annoying, but hell"
	existingSelection _ selection.
	self list: newList.
	(anIndex _ newList indexOf: existingSelection ifAbsent: [nil])
		ifNotNil:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifNil:
			[self changeModelSelection: 0]
! !



!PluggableListMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:09'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled."
	^ scroller firstSubmorph height
! !


!PluggableListMorph methodsFor: 'drag and drop' stamp: 'mir 6/5/2000 16:24'!
acceptDroppingMorph: aMorph event: evt 
	"This message is sent when a morph is dropped onto a morph that has     
	agreed to accept the dropped morph by responding 'true' to the     
	wantsDroppedMorph:Event: message. The default implementation just     
	adds the given morph to the receiver."
	"Here we let the model do its work."

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropMorph.
	Cursor normal show.
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:40'!
enableDragNDrop: aBoolean
	super enableDragNDrop: aBoolean.
	aBoolean ifTrue: [self installEventHandlerOn: scroller submorphs]! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'RAA 12/18/2000 19:51'!
installEventHandlerOn: morphList

	| handler |

	handler _ EventHandler new.
	handler
		on: #mouseDown send: #mouseDown:onItem: to: self;
		on: #mouseUp send: #mouseUp:onItem: to: self.
	doubleClickSelector ifNotNil: [
		handler on: #doubleClick send: #doubleClick:onItem: to: self.
	].
	self dragEnabled
		ifTrue: [handler
				on: #startDrag
				send: #startDrag:onItem:
				to: self].
	self dropEnabled
		ifTrue: 
			[handler
				on: #mouseEnterDragging
				send: #mouseEnterDragging:onItem:
				to: self.
			handler
				on: #mouseLeaveDragging
				send: #mouseLeaveDragging:onItem:
				to: self].

	morphList do: [:m | m eventHandler: handler].
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 16:11'!
potentialDropMorph
	^potentialDropMorph! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 18:22'!
potentialDropMorph: aMorph
	potentialDropMorph _ aMorph.
	aMorph highlightForDrop! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 12:01'!
resetPotentialDropMorph
	potentialDropMorph ifNotNil: [
		potentialDropMorph resetHighlightForDrop.
		potentialDropMorph _ nil]
! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'ar 10/6/2000 23:26'!
startDrag: evt onItem: itemMorph 
	| ddm |
	evt hand hasSubmorphs
		ifTrue: [^self].

	itemMorph ifNotNil: [itemMorph highlightForMouseDown: false].
	model okToChange ifFalse: [
		Cursor normal show.
		^ self].  "No change if model is locked"
	"itemMorph ~= self selection ifTrue: [self setSelectedMorph: itemMorph]."
	ddm _ TransferMorph withPassenger: (self model dragPassengerFor: itemMorph inMorph: self) from: self.
	ddm dragTransferType: (self model dragTransferTypeForMorph: self).
	Preferences dragNDropWithAnimation
			ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
	evt hand grabMorph: ddm.! !

!PluggableListMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 18:26'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListMorph class
	instanceVariableNames: ''!

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"! !

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"
! !

!PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/6/1998 21:45'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !

PluggableListMorph subclass: #PluggableListMorphByItem
	instanceVariableNames: 'itemList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'jm
 8/20/1998 09:44'!
changeModelSelection: anInteger
	"Change the model's selected item to be the one at the given index."

	| item |
	setIndexSelector ifNotNil: [
		item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
		model perform: setIndexSelector with: item].
	self update: getIndexSelector.
! !

!PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'tk 5/12/1998 10:01'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil ifTrue: [^ 0].
	item _ model perform: getIndexSelector.
	^ itemList findFirst: [ :x | x = item]
! !

!PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'tk 5/12/1998 11:34'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.
	 The instance variable 'list' is a paragraph constructed from
	 this list."

	itemList _ arrayOfStrings.
	^ super list: arrayOfStrings! !

PluggableListMorph subclass: #PluggableListMorphOfMany
	instanceVariableNames: 'dragOnOrOff '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'ar 11/15/1998 23:45'!
drawOn: aCanvas
	| onMorph |
	super drawOn: aCanvas.
	1 to: list size do:  "NOTE: should be optimized to only visible morphs"
		[:index |
		(model listSelectionAt: index) ifTrue:
			[onMorph _ scroller submorphs at: index.
			aCanvas fillRectangle:
				(((scroller transformFrom: self) localBoundsToGlobal: onMorph bounds)
						intersect: scroller bounds)
				color: color darker]]! !

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 14:46'!
list: listOfStrings
	scroller removeAllMorphs.
	list _ listOfStrings ifNil: [Array new].
	list isEmpty ifTrue: [^ self selectedMorph: nil].
	super list: listOfStrings.

	"At this point first morph is sensitized, and all morphs share same handler."
	scroller firstSubmorph on: #mouseEnterDragging
						send: #mouseEnterDragging:onItem:
						to: self.
	scroller firstSubmorph on: #mouseUp
						send: #mouseUp:onItem:
						to: self.
	"This should add this behavior to the shared event handler thus affecting all items"! !

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'ar 11/7/2000 18:57'!
mouseDown: event onItem: aMorph
	| index oldIndex oldVal |
	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	model okToChange ifFalse: [^ self].  "No change if model is locked"

	index _ scroller submorphs indexOf: aMorph.
	index = 0 ifTrue: [^ self  "minimize chance of selecting with a pane border drag"].

	"Set meaning for subsequent dragging of selection"
	dragOnOrOff _ (model listSelectionAt: index) not.
	oldIndex _ self getCurrentSelectionIndex.
	oldIndex ~= 0 ifTrue: [oldVal _ model listSelectionAt: oldIndex].

	"Set or clear new primary selection (listIndex)"
	dragOnOrOff
		ifTrue: [self setSelectedMorph: aMorph]
		ifFalse: [self setSelectedMorph: nil].

	"Need to restore the old one, due to how model works, and set new one."
	oldIndex ~= 0 ifTrue: [model listSelectionAt: oldIndex put: oldVal].
	model listSelectionAt: index put: dragOnOrOff.
	event hand releaseMouseFocus: aMorph.
	aMorph changed! !

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 1/15/1999 00:49'!
mouseEnterDragging: event onItem: aMorph
	| index oldIndex oldVal |
	dragOnOrOff ifNil: [^ self "spurious drag did not start with mouseDown"].
	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	model okToChange ifFalse: [^ self].  "No change if model is locked"

	oldIndex _ self getCurrentSelectionIndex.
	oldIndex ~= 0 ifTrue: [oldVal _ model listSelectionAt: oldIndex].

	index _ scroller submorphs indexOf: aMorph.
	dragOnOrOff ifTrue: [self setSelectedMorph: aMorph].
	oldIndex ~= 0 ifTrue: [model listSelectionAt: oldIndex put: oldVal].

	"Extend the selection with the current state of dragOnOrOff"
	model listSelectionAt: index put: dragOnOrOff.
	aMorph changed! !

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 14:47'!
mouseUp: event onItem: aMorph

	dragOnOrOff _ nil.  "So improperly started drags will have not effect"! !

!PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 14:44'!
update: aSymbol 
	aSymbol == #allSelections ifTrue:
		[self selectionIndex: self getCurrentSelectionIndex.
		^ self changed].
	^ super update: aSymbol! !
ListView subclass: #PluggableListView
	instanceVariableNames: 'getListSelector getSelectionSelector setSelectionSelector getMenuSelector getMenuTitleSelector keystrokeActionSelector autoDeselect items '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableListView commentStamp: '<historical>' prior: 0!
A pluggable list view gets its content from the model. This allows the same kind of view to be used in different situations, thus avoiding a proliferation of gratuitous view and controller classes. Selector usage is:

		getListSel		fetch the list of items (strings) to be displayed
		getSelectionSel	get the currently selected item
		setSelectionSel	set the currently selected item (takes an argument)
		getMenuSel		get the pane-specific, 'yellow-button' menu
		keyActionSel	process a keystroke typed in this pane (takes an argument)

	Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. However, if getListSel is nil, the default behavior just provides an empty list, which makes for a rather dull list view!!

	The model informs a pluggable view of changes by sending #changed: to itself with getListSel or getSelectionSel as a parameter. The view informs the model of selection changes by sending setSelectionSel to it with the newly selected item as a parameter, and invokes menu and keyboard actions on the model via getMenuSel and keyActionSel.

	Pluggability allows a single model object to have pluggable list views on multiple aspects of itself. For example, an object representing one personal music library might be organized as a three-level hierarchy: the types of music, the titles within a given type, and the songs on a given title. Pluggability allows one to easily build a multipane browser for this object with separate list views for the music type, title, and song.

	AutoDeselect is a feature, normally set to true, that will tell the model that there is no selection if you click on an item that is currently selected.  If autoDeselect is false, then the model will simply be told to select the same item again.!


!PluggableListView methodsFor: 'initialization' stamp: 'di 4/10/98 09:56'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!PluggableListView methodsFor: 'initialization' stamp: 'jm 9/20/1998 19:48'!
font: aFontOrNil

	super font: aFontOrNil.
	self list: self getList.  "update display"
! !

!PluggableListView methodsFor: 'initialization' stamp: 'sw 12/9/1999 18:06'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings
	The instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list."

	((items == arrayOfStrings) "fastest" or: [items = arrayOfStrings]) ifTrue: [^ self].
	items _ arrayOfStrings.
	isEmpty _ arrayOfStrings isEmpty.

	"add top and bottom delimiters"
	list _ ListParagraph
		withArray:
			(Array streamContents: [:s |
				s nextPut: topDelimiter.
				arrayOfStrings do: [:item | item == nil ifFalse: [s nextPut: item]].
				s nextPut: bottomDelimiter])
		 style: self assuredTextStyle.

	selection _ self getCurrentSelectionIndex.
	self positionList.! !

!PluggableListView methodsFor: 'initialization' stamp: 'tk 4/12/1998 08:25'!
menu: getMenuSel

	getMenuSelector _ getMenuSel! !

!PluggableListView methodsFor: 'initialization' stamp: 'sw 8/18/1998 12:04'!
menuTitleSelector: getMenuTitleSel
	getMenuTitleSelector _ getMenuTitleSel! !

!PluggableListView methodsFor: 'initialization' stamp: 'di 4/10/98 09:55'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel

	self model: anObject.
	getListSelector _ getListSel.
	getSelectionSelector _ getSelectionSel.
	setSelectionSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self list: self getList.! !


!PluggableListView methodsFor: 'model access' stamp: 'di 5/6/1998 20:52'!
changeModelSelection: anInteger
	"Change the model's selected item index to be anInteger."
	| newIndex |
	newIndex _ anInteger.
	(autoDeselect == nil or: [autoDeselect]) ifTrue:
		[getSelectionSelector ifNotNil:
			[(model perform: getSelectionSelector) = anInteger ifTrue:
				["Click on existing selection deselects"
				newIndex _ 0]]].

	setSelectionSelector ifNotNil:
		[model perform: setSelectionSelector with: newIndex].! !

!PluggableListView methodsFor: 'model access' stamp: 'di 5/6/1998 20:52'!
getCurrentSelectionIndex
	"Answer the index of the current selection."

	getSelectionSelector == nil ifTrue: [^ 0].
	^ model perform: getSelectionSelector! !

!PluggableListView methodsFor: 'model access'!
getList 
	"Answer the list to be displayed."

	| lst |
	getListSelector == nil ifTrue: [^ #()].
	lst _ model perform: getListSelector.
	lst == nil ifTrue: [^ #()].
	^ lst! !

!PluggableListView methodsFor: 'model access' stamp: 'tk 4/2/98 13:36'!
getListSelector
	^ getListSelector! !

!PluggableListView methodsFor: 'model access' stamp: 'sw 8/18/1998 12:07'!
getMenu: shiftKeyDown
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
	| menu aMenu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue:
			[aMenu _ model perform: getMenuSelector with: menu.
			getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)].
			^ aMenu].
	getMenuSelector numArgs = 2
		ifTrue: [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyDown.
				getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)].
				^ aMenu].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableListView methodsFor: 'model access' stamp: 'tk 4/21/1998 08:26'!
handleKeystroke: aCharacter
	"Answer the menu for this list view."

	| args |
	keystrokeActionSelector == nil ifTrue: [^ nil].
	controller controlTerminate.
	(args _ keystrokeActionSelector numArgs) = 1
		ifTrue: [model perform: keystrokeActionSelector with: aCharacter.
				^ controller controlInitialize].
	args = 2
		ifTrue: [model perform: keystrokeActionSelector with: aCharacter with: self.
				^ controller controlInitialize].
	^ self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! !

!PluggableListView methodsFor: 'model access' stamp: 'sw 10/9/1998 08:24'!
setSelectionSelectorIs: aSelector
	^ aSelector == setSelectionSelector! !


!PluggableListView methodsFor: 'controller access' stamp: 'jm 3/11/98 17:17'!
defaultControllerClass 

	^ PluggableListController
! !


!PluggableListView methodsFor: 'updating' stamp: 'di 5/25/1998 10:24'!
update: aSymbol 
	"Refer to the comment in View|update:."
	aSymbol == getListSelector ifTrue:
		[self list: self getList.
		self displayView.
		self displaySelectionBox.
		^self].
	aSymbol == getSelectionSelector ifTrue:
		[^ self moveSelectionBox: self getCurrentSelectionIndex].
! !

!PluggableListView methodsFor: 'updating' stamp: 'sw 10/31/1999 00:04'!
verifyContents
	| newItems existingSelection anIndex |
	"Called on window reactivation to react to possible structural changes.  Update contents if necessary."

	newItems _ self getList.
	((items == newItems) "fastest" or: [items = newItems]) ifTrue: [^ self].
	self flash.  "list has changed beneath us; could get annoying, but hell"
	existingSelection _ list stringAtLineNumber: (selection + 1).  "account for cursed ------ row"
	self list: newItems.
	(newItems size > 0 and: [newItems first isKindOf: Symbol]) ifTrue:
		[existingSelection _ existingSelection asSymbol].
	(anIndex _ newItems indexOf: existingSelection ifAbsent: [nil])
		ifNotNil:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self update: getSelectionSelector.
			self topView displayEmphasized]
		ifNil:
			[self changeModelSelection: 0]
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableListView class
	instanceVariableNames: ''!

!PluggableListView class methodsFor: 'instance creation' stamp: 'tk 4/17/1998 20:41'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"
! !

!PluggableListView class methodsFor: 'instance creation' stamp: 'tk 4/17/1998 20:41'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"

! !

!PluggableListView class methodsFor: 'instance creation'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
PluggableListView subclass: #PluggableListViewByItem
	instanceVariableNames: 'itemList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 16:28'!
changeModelSelection: anInteger
	"Change the model's selected item to be the one at the given index."
	| item |
	setSelectionSelector ifNotNil: [
		item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]).
		model perform: setSelectionSelector with: item].
! !

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 16:27'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getSelectionSelector == nil ifTrue: [^ 0].
	item _ model perform: getSelectionSelector.
	^ itemList findFirst: [ :x | x = item]
! !

!PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'sw 12/9/1999 18:07'!
list: arrayOfStrings
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.
	 The instance variable 'list' is a paragraph constructed from
	 this list."

	itemList _ arrayOfStrings.
	isEmpty _ arrayOfStrings isEmpty.

	"add top and bottom delimiters"
	list _ ListParagraph
		withArray:
			(Array streamContents: [:s |
				s nextPut: topDelimiter.
				arrayOfStrings do: [:item | item == nil ifFalse: [s nextPut: item]].
				s nextPut: bottomDelimiter])
		 style: self assuredTextStyle.

	selection _ self getCurrentSelectionIndex.
	self positionList.! !
PluggableListView subclass: #PluggableListViewOfMany
	instanceVariableNames: 'selections '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tk 4/6/98 15:42'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	selection _ 0.
	1 to: self maximumSelection do:
		[:i | selection _ i.
		(model listSelectionAt: i) ifTrue: [self deEmphasizeSelectionBox]].
	selection _ 0! !

!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tk 4/6/98 15:42'!
highlightFrom: start to: stop
	(start == nil or: [stop == nil]) ifTrue: [^ self displayView].
	start to: stop do:
		[:i | selection _ i.
		(model listSelectionAt: selection) ifTrue: [self displaySelectionBox]].
	selection _ 0! !

!PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tk 4/6/98 20:42'!
scrollBy: anInteger
	"This is a possible way to intercept what ListOfManyController did to get multiple selections to show.  Feel to replace this."

	| ans |
	ans _ super scrollBy: anInteger.
"	self displaySelectionBox."
	^ ans! !


!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tk 4/6/98 15:43'!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."
	selection ~= anInteger
		ifTrue: 
			[selection _ anInteger.
			self displaySelectionBox]! !

!PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tk 4/6/98 15:43'!
selection
	"Have to override normal controller smarts about deselection"
	^ 0! !


!PluggableListViewOfMany methodsFor: 'updating' stamp: 'tk 4/8/98 13:12'!
update: aSymbol 
	aSymbol == getListSelector
		ifTrue: [self list: self getList.
			^ self displayView; emphasizeView].
	aSymbol == getSelectionSelector
		ifTrue: [^ self displayView; emphasizeView].
	aSymbol == #allSelections
		ifTrue: [^ self displayView; emphasizeView].
	^ super update: aSymbol! !


!PluggableListViewOfMany methodsFor: 'controller access' stamp: 'di 5/17/1998 22:48'!
defaultControllerClass 

	^ PluggableListControllerOfMany
! !
PluggableListMorph subclass: #PluggableMessageCategoryListMorph
	instanceVariableNames: 'getRawListSelector priorRawList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!PluggableMessageCategoryListMorph commentStamp: '<historical>' prior: 0!
A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes.  In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).!


!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/18/1999 11:59'!
getList
	"Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser.  This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method"

	getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList _ nil.  ^ #()].
	model classListIndex = 0 ifTrue: [^ priorRawList _ Array new].
	priorRawList _ model perform: getRawListSelector.
	^ (Array with: ClassOrganizer allCategory), priorRawList! !

!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/16/1999 22:32'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel.
	self model: anObject.
	getListSelector _ getListSel.
	getIndexSelector _ getSelectionSel.
	setIndexSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	getRawListSelector _ getRawSel.
	self list: self getList.
	self selectionIndex: self getCurrentSelectionIndex.
	self initForKeystrokes! !

!PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/1999 23:02'!
verifyContents
	
	| newList existingSelection anIndex newRawList |
	(model editSelection == #editComment) ifTrue: [^ self].
	model classListIndex = 0 ifTrue: [^ self].
	newRawList _ model perform: getRawListSelector.
	newRawList == priorRawList ifTrue: [^ self].  "The usual case; very fast"
	priorRawList _ newRawList.
	newList _ (Array with: ClassOrganizer allCategory), priorRawList.
	list = newList ifTrue: [^ self].
	self flash.  "could get annoying, but hell"
	existingSelection _ selection.
	self list: newList.
	(anIndex _ newList indexOf: existingSelection ifAbsent: [nil])
		ifNotNil:
			[model noteSelectionIndex: anIndex for: getListSelector.
			self selectionIndex: anIndex]
		ifNil:
			[self changeModelSelection: 0]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableMessageCategoryListMorph class
	instanceVariableNames: ''!

!PluggableMessageCategoryListMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/16/1999 22:39'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel.
	^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! !
PluggableListMorph subclass: #PluggableMultiColumnListMorph
	instanceVariableNames: 'lists selectedIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!PluggableMultiColumnListMorph commentStamp: '<historical>' prior: 0!
This morph can be used to show a list having multiple columns,  The columns are self width sized to make the largest entry in each list fit.  In some cases the pane may then be too narrow.

Use it like a regular PluggableListMorph except pass in an array of lists instead of a single list.

There are base assumptions made here that each list in the array of lists is the same size.

Also, the highlight color for the selection is easy to modify in the #highlightSelection method.  I used blue
when testing just to see it work.!


!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:37'!
calculateColumnOffsetsFrom: maxWidths
	| offsets previous current |
	offsets _ Array new: maxWidths size.
	1
		to: offsets size
		do: [:indx | offsets at: indx put: (maxWidths at: indx)
					+ 10].
	2
		to: offsets size
		do: [:indx | 
			previous _ offsets at: indx - 1.
			current _ offsets at: indx.
			current _ previous + current.
			offsets at: indx put: current].
	^offsets
! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:36'!
calculateColumnWidthsFrom: arrayOfMorphs 
	| maxWidths |
	maxWidths _ Array new: arrayOfMorphs size - 1.
	1
		to: maxWidths size
		do: [:idx | maxWidths at: idx put: 0].
	1
		to: maxWidths size
		do: [:idx | (arrayOfMorphs at: idx)
				do: [:mitem | mitem width
							> (maxWidths at: idx)
						ifTrue: [maxWidths at: idx put: mitem width]]].
	^maxWidths! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/1/2000 13:44'!
createMorphicListsFrom: arrayOfLists 
	| array |
	font
		ifNil: [font _ Preferences standardListFont].
	array _ Array new: arrayOfLists size.
	1 to: arrayOfLists size do: [:arrayIndex |
		array at: arrayIndex put: (
			(arrayOfLists at: arrayIndex) collect: [:item | item isText
						ifTrue: [StringMorph
								contents: item
								font: font
								emphasis: (item emphasisAt: 1)]
						ifFalse: [StringMorph contents: item font: font]])
		].
	^array! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/2/2000 08:38'!
layoutMorphicLists: arrayOfMorphs 
	| maxWidths offsets locs h |
	maxWidths _ self calculateColumnWidthsFrom: arrayOfMorphs.
	offsets _ self calculateColumnOffsetsFrom: maxWidths.
	locs _ Array new: arrayOfMorphs size.
	locs at: 1 put: 0 @ 0.
	2
		to: locs size
		do: [:indx | locs at: indx put: (offsets at: indx - 1)
					@ 0].
	h _ arrayOfMorphs first first height.
	1
		to: arrayOfMorphs size
		do: [:indx | (arrayOfMorphs at: indx)
				do: [:morphItem | 
					morphItem
						bounds: ((locs at: indx)
								extent: 9999 @ h).
					locs at: indx put: (locs at: indx)
							+ (0 @ h)]]! !

!PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'sbw 12/4/2000 20:28'!
list: arrayOfLists 
	| listOfStrings arrayOfMorphs index |
	lists _ arrayOfLists.
	scroller removeAllMorphs.
	listOfStrings _ arrayOfLists == nil
				ifTrue: [Array new]
				ifFalse: [
					arrayOfLists isEmpty ifFalse: [
					arrayOfLists at: 1]].
	list _ listOfStrings
				ifNil: [Array new].
	list isEmpty
		ifTrue: [self setScrollDeltas.
			^ self selectedMorph: nil].
	arrayOfMorphs _ self createMorphicListsFrom: arrayOfLists.
	self layoutMorphicLists: arrayOfMorphs.
	arrayOfMorphs
		do: [:morphList | scroller addAllMorphs: morphList].
	self
		installEventHandlerOn: (arrayOfMorphs at: 1).
	index _ self getCurrentSelectionIndex.
	self
		selectedMorph: ((index = 0
					or: [index > (arrayOfMorphs at: 1) size])
				ifFalse: [(arrayOfMorphs at: 1)
						at: index]).
	self setScrollDeltas.
	scrollBar setValue: 0.0! !


!PluggableMultiColumnListMorph methodsFor: 'drawing' stamp: 'sbw 12/2/2000 08:41'!
drawOn: aCanvas 
	"Only modification here is to bypass the #drawOn: method in our superclass."

	super superDrawOn: aCanvas.
	selectedMorph
		ifNotNil: [aCanvas
				fillRectangle: (((scroller transformFrom: self)
						localBoundsToGlobal: selectedMorph bounds)
						intersect: scroller bounds)
				color: color darker]! !


!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'sbw 2/1/2001 12:17'!
highlightSelection
	| highlightColor columnLength localIndex m properSelectedIndex |
	highlightColor _ Color red.
	"<-- Change the highlight color here."
	selectedMorph
		ifNotNil: [selectedMorph color: highlightColor;
				 changed.
			properSelectedIndex _ scroller submorphs
						findFirst: [:mp | mp contents = selectedMorph contents].
			selectedIndex = properSelectedIndex ifFalse: [selectedIndex _ properSelectedIndex].
			columnLength _ lists first size.
			2
				to: lists size
				do: [:columnIndex | 
					localIndex _ selectedIndex + (columnLength * (columnIndex - 1)).
					m _ scroller submorphs asArray at: localIndex.
					m color: highlightColor;
						 changed]]! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'sbw 2/1/2001 12:14'!
selectionIndex: index 
	"Called internally to select the index-th item."
	| theMorph range |
	(index isNil
			or: [index > scroller submorphs size])
		ifTrue: [^ self].
	(theMorph _ index = 0
				ifFalse: [scroller submorphs at: index])
		ifNotNil: [(theMorph bounds top - scroller offset y >= 0
					and: [theMorph bounds bottom - scroller offset y <= bounds height])
				ifFalse: ["Scroll into view -- should be elsewhere"
					range _ self leftoverScrollRange.
					scrollBar
						value: (range > 0
								ifTrue: [index - 1 * theMorph height / self leftoverScrollRange truncateTo: scrollBar scrollDelta]
								ifFalse: [0]).
					scroller offset: -3 @ (range * scrollBar value)]].
	"Save the selection index to make it easy to do the highlighting work  
	later."
	selectedIndex _ index.
	self selectedMorph: theMorph! !

!PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'sbw 1/21/2001 19:41'!
unhighlightSelection
	| unhighlightColor columnLength localIndex m previousSelectedIndex |
	unhighlightColor _ Color black.
	selectedMorph
		ifNotNil: [selectedMorph color: unhighlightColor;
				 changed.
			previousSelectedIndex _ scroller submorphs
						findFirst: [:mp | mp contents = selectedMorph contents].
			columnLength _ lists first size.
			2
				to: lists size
				do: [:columnIndex | 
					localIndex _ previousSelectedIndex + (columnLength * (columnIndex - 1)).
					localIndex = 0 ifFalse: [
						m _ scroller submorphs asArray at: localIndex.
						m color: unhighlightColor;
						 	changed]]]!
]style[(20 3 65 4 16 3 5 9 13 14 13 8 16 19 21 3 8 29 4 2 2 12 13 15 12 3 5 16 1 9 5 15 13 8 10 3 21 4 12 4 11 3 1 41 1 3 8 23 10 8 1 8 16 20)f1b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !
PluggableMultiColumnListMorph subclass: #PluggableMultiColumnListMorphByItem
	instanceVariableNames: 'itemList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PluggableMultiColumnListMorphByItem methodsFor: 'as yet unclassified' stamp: 'sbw 12/25/2000 21:30'!
changeModelSelection: anInteger 
	"Change the model's selected item to be the one at the given index."
	| item |
	setIndexSelector
		ifNotNil: [item _ anInteger = 0
						ifFalse: [itemList at: anInteger].
			model perform: setIndexSelector with: item].
	self update: getIndexSelector! !

!PluggableMultiColumnListMorphByItem methodsFor: 'as yet unclassified' stamp: 'sbw 2/1/2001 12:15'!
getCurrentSelectionIndex
	"Answer the index of the current selection."
	| item |
	getIndexSelector == nil
		ifTrue: [^ 0].
	item _ model perform: getIndexSelector.
	^ itemList
		findFirst: [:x | x = item]! !

!PluggableMultiColumnListMorphByItem methodsFor: 'as yet unclassified' stamp: 'sbw 12/25/2000 20:52'!
list: arrayOfStrings 
	"Set the receivers items to be the given list of strings."
	"Note: the instance variable 'items' holds the original list.  
	The instance variable 'list' is a paragraph constructed from  
	this list."
	itemList _ arrayOfStrings first.
	^ super list: arrayOfStrings! !
ServerAction subclass: #PluggableServerAction
	instanceVariableNames: 'processBlock returnBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!PluggableServerAction commentStamp: '<historical>' prior: 0!
A PluggableServerAction instance has two blocks in instance variables. The processBlock is executed with the web request to do any input processing that is needed. The returnBlock is executed with the web request, and its return value is sent as the output of the CGI processing.
!


!PluggableServerAction methodsFor: 'accessing' stamp: 'mjg 11/10/97 08:58'!
processBlock: aBlock
	processBlock := aBlock.
! !

!PluggableServerAction methodsFor: 'accessing' stamp: 'mjg 11/10/97 08:59'!
returnBlock: aBlock
	returnBlock := aBlock.
! !


!PluggableServerAction methodsFor: 'URL processing' stamp: 'tk 1/31/98 14:40'!
process: request
	processBlock value: request.
	request reply: PWS success; reply: PWS contentHTML, PWS crlf.
	request reply: (returnBlock value: request).
! !
Set subclass: #PluggableSet
	instanceVariableNames: 'hashBlock equalBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
!PluggableSet commentStamp: '<historical>' prior: 0!
PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries.

Instance variables:
	hashBlock	<BlockContext>	A one argument block used for hashing the elements.
	equalBlock	<BlockContext>	A two argument block used for comparing the elements.

Example: Adding 1000 integer points in the range (0@0) to: (100@100) to a set.

	| rnd set max pt |
	set _ Set new: 1000.
	rnd _ Random new.
	max _ 100.
	Time millisecondsToRun:[
		1 to: 1000 do:[:i|
			pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
			set add: pt.
		].
	].

The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function:

	| rnd set max pt |
	set _ PluggableSet new: 1000.
	set hashBlock:[:item| (item x bitShift: 16) + item y].
	rnd _ Random new.
	max _ 100.
	Time millisecondsToRun:[
		1 to: 1000 do:[:i|
			pt _ (rnd next * max) truncated @ (rnd next * max) truncated.
			set add: pt.
		].
	].
!


!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'!
equalBlock
	"Return the block used for comparing the elements in the receiver."
	^equalBlock! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'!
equalBlock: aBlock
	"Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise"
	equalBlock _ aBlock.! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'!
hashBlock
	"Return the block used for hashing the elements in the receiver."
	^hashBlock! !

!PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 19:02'!
hashBlock: aBlock
	"Set a new hash block. The block must accept one argument and return the hash value of the given argument."
	hashBlock _ aBlock.! !


!PluggableSet methodsFor: 'copying' stamp: 'ar 11/12/1998 18:47'!
copy
	^super copy postCopyBlocks! !

!PluggableSet methodsFor: 'copying' stamp: 'dvf 6/10/2000 19:34'!
postCopyBlocks
	hashBlock _ hashBlock copy.
	equalBlock _ equalBlock copy.
	"Fix temps in case we're referring to outside stuff"
	hashBlock ifNotNil: [hashBlock fixTemps].
	equalBlock ifNotNil: [equalBlock fixTemps]! !


!PluggableSet methodsFor: 'private' stamp: 'dvf 6/11/2000 00:54'!
scanFor: anObject 
	"Scan the key array for the first slot containing either a nil
(indicating 
	  an empty slot) or an element that matches anObject. Answer the index 
	  
	of that slot or zero if no slot is found. This  method will be
overridden   
	in various subclasses that have different interpretations for matching 
 
	elements."
	| element start finish |
	start _ (hashBlock ifNil: [anObject hash]
				ifNotNil: [hashBlock value: anObject])
				\\ array size + 1.
	finish _ array size.
	"Search from (hash mod size) to the end."
	start to: finish do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	"Search from 1 to where we started."
	1 to: start - 1 do: [:index | ((element _ array at: index) == nil or:
[equalBlock ifNil: [element = anObject]
				ifNotNil: [equalBlock value: element value: anObject]])
			ifTrue: [^ index]].
	^ 0"No match AND no empty slot"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableSet class
	instanceVariableNames: ''!

!PluggableSet class methodsFor: 'as yet unclassified' stamp: 'dvf
6/10/2000 18:13'!
integerSet
	^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! !
Object subclass: #PluggableTest
	instanceVariableNames: 'musicTypeList musicTypeIndex artistList artistIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableTest commentStamp: '<historical>' prior: 0!
This class demonstrates how to use PluggableListViews.
!


!PluggableTest methodsFor: 'initialization' stamp: 'jm 5/3/1998 16:20'!
initialize

	musicTypeList _ #('reggae' 'classical' 'early').
	artistList _ #(
		('alpha blondy' 'black uhuru' 'bob marley' 'burning spear')
		('bach' 'beethoven' 'josquin' 'morley' 'mozart' 'telemann')
		('josquin' 'morley' 'telemann')).
	musicTypeIndex _ 0.
	artistIndex _ 0.
! !


!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artist

	^ artistIndex
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artist: anInteger

	artistIndex _ anInteger.
	self changed: #artist.
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:14'!
artistKeystroke: aCharacter

	self artistList doWithIndex: [:artist :i |
		(artist first asLowercase = aCharacter asLowercase) ifTrue: [
			self artist: i]].
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:21'!
artistList

	((musicTypeIndex ~= nil) and:
	 [musicTypeIndex between: 1 and: artistList size])
		ifTrue: [^ artistList at: musicTypeIndex]
		ifFalse: [^ #()].
! !

!PluggableTest methodsFor: 'artist pane' stamp: 'jm 5/3/1998 16:20'!
artistName
	"Answer the name of the currently selected artist, or nil if no artist is selected."

	| artistsForCurrentType |
	artistsForCurrentType _ self artistList.
	(artistIndex between: 1 and: artistsForCurrentType size)
		ifTrue: [^ artistsForCurrentType at: artistIndex]
		ifFalse: [^ nil].
! !


!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicType

	^ musicTypeIndex
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicType: anInteger

	| oldArtist |
	oldArtist _ self artistName.
	musicTypeIndex _ anInteger.  "this changes artists list"
	artistIndex _ self artistList indexOf: oldArtist.
	self changed: #musicType.
	self changed: #artistList.
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/2/1998 15:18'!
musicTypeKeystroke: aCharacter

	musicTypeList doWithIndex: [:type :i |
		(type first asLowercase = aCharacter asLowercase)
			ifTrue: [self musicType: i]].
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:11'!
musicTypeList

	^ musicTypeList
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'sw 8/18/1998 12:31'!
musicTypeListTitle
	^ 'Choose a command'! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:00'!
musicTypeMenu: aMenu

	^ aMenu addList: #(
		(reggae reggaeCmd)
		(early earlyCmd)
		(grunge grungeCmd)
		-
		(flash flashCmd))
! !

!PluggableTest methodsFor: 'music type pane' stamp: 'jm 5/3/1998 16:21'!
musicTypeName
	"Answer the name of the currently selected music type, or nil if no music type is selected."

	(musicTypeIndex between: 1 and: musicTypeList size)
		ifTrue: [^ musicTypeList at: musicTypeIndex]
		ifFalse: [^ nil].
! !


!PluggableTest methodsFor: 'menu commands' stamp: 'jm 5/3/1998 16:00'!
earlyCmd

	self musicType: (musicTypeList indexOf: 'early').
! !

!PluggableTest methodsFor: 'menu commands'!
flashCmd

	Display reverse; reverse.! !

!PluggableTest methodsFor: 'menu commands'!
grungeCmd

	SelectionMenu confirm:
		'You mean, like those strange bands from Seattle?'! !

!PluggableTest methodsFor: 'menu commands' stamp: 'sw 8/18/1998 12:29'!
perform: sel orSendTo: otherObject
	(self respondsTo: sel) ifTrue: [self perform: sel] ifFalse: [otherObject perform: sel]! !

!PluggableTest methodsFor: 'menu commands' stamp: 'jm 5/3/1998 15:59'!
reggaeCmd

	self musicType: (musicTypeList indexOf: 'reggae').
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTest class
	instanceVariableNames: ''!

!PluggableTest class methodsFor: 'example' stamp: 'sw 8/18/1998 12:25'!
open
	"PluggableTest open"

	| model listView1 topView listView2 |
	model _ self new initialize.
	listView1 _
		PluggableListView on: model
			list: #musicTypeList
			selected: #musicType
			changeSelected: #musicType:
			menu: #musicTypeMenu:
			keystroke: #musicTypeKeystroke:.
	listView1  menuTitleSelector: #musicTypeListTitle.
	listView2 _
		PluggableListView on: model
			list: #artistList
			selected: #artist
			changeSelected: #artist:
			menu: nil
			keystroke: #artistKeystroke:.

	topView _ StandardSystemView new
		label: 'Pluggable Test';
		minimumSize: 300@200;
		borderWidth: 1;
		addSubView: listView1;
		addSubView: listView2 toRightOf: listView1.
	topView borderWidth: 1.
	topView controller open.! !
StringHolderController subclass: #PluggableTextController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:46'!
appendEntry
	"Append the text in the model's writeStream to the editable text. "
	self deselect.
	paragraph text size > model characterLimit ifTrue:
		["Knock off first half of text"
		self selectInvisiblyFrom: 1 to: paragraph text size // 2.
		self replaceSelectionWith: Text new].
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size.
	self replaceSelectionWith: model contents asText.
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size! !

!PluggableTextController methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:39'!
bsText
	self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 5/13/1998 14:16'!
changeText: aText
	"The paragraph to be edited is changed to aText."
	paragraph text: aText.
	self resetState.
	self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size.
	self selectAndScroll.
	self deselect! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:42'!
doOccluded: actionBlock
	| paneRect rectSet bottomStrip |
	paneRect _ paragraph clippingRectangle.
	paragraph withClippingRectangle: (paneRect withHeight: 0)
		do: [actionBlock value.
			self scrollIn: paneRect].
	view topView isCollapsed ifTrue: [^ self].
	rectSet _ self visibleAreas.
	bottomStrip _ paneRect withTop: paragraph compositionRectangle bottom + 1.
	rectSet do:
		[:rect |
		(bottomStrip intersects: rect) ifTrue:
			["The subsequent displayOn should clear this strip but it doesnt"
			Display fill: (bottomStrip intersect: rect)
					fillColor: paragraph backgroundColor].
		paragraph withClippingRectangle: rect
				do: [paragraph displayOn: Display]]! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 5/7/1998 22:26'!
scrollIn: scrollRect
	"Altered from selectAndScroll so can use with null clipRect"
	"Scroll until the selection is in the view and then highlight it."
	| deltaY |
	deltaY _ stopBlock top - scrollRect top.
	deltaY >= 0 
		ifTrue: [deltaY _ stopBlock bottom - scrollRect bottom max: 0].
						"check if stopIndex below bottom of scrollRect"
	deltaY ~= 0 
		ifTrue: [self scrollBy: (deltaY abs + paragraph lineGrid - 1) * deltaY sign]! !

!PluggableTextController methodsFor: 'transcript' stamp: 'di 5/7/1998 22:23'!
visibleAreas
	"Transcript dependents last controller visibleAreas"
	| visibleAreas rect remnants myTopController |
	myTopController _ self view topView controller.
	visibleAreas _ Array with: view insetDisplayBox.
	myTopController view uncacheBits.
	ScheduledControllers scheduledWindowControllers do:
		[:c | c == myTopController ifTrue: [^ visibleAreas].
		rect _ c view windowBox.
		remnants _ OrderedCollection new.
		visibleAreas do: [:a | remnants addAll: (a areasOutside: rect)].
		visibleAreas _ remnants].
	^ visibleAreas! !


!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'sw 9/6/2000 04:58'!
accept 
	view hasUnacceptedEdits ifFalse: [^ view flash].
	view hasEditingConflicts ifTrue:
		[(self confirm: 
'Caution!! This method may have been
changed elsewhere since you started
editing it here.  Accept anyway?') ifFalse: [^ self flash]].

	(view setText: paragraph text from: self) ifTrue:
		[initialText _ paragraph text copy.
		view ifNotNil: [view hasUnacceptedEdits: false]]    .
! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'sbw 10/12/1999 16:46'!
selectForTopFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse:
		[view superView ifNotNil: [self deselect].
		self selectInvisiblyFrom: start to: stop].
	view superView ifNotNil: [self selectAndScrollToTop]! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'tk 4/6/98 10:41'!
selectFrom: start to: stop
	"Deselect, then select the specified characters inclusive.
	 Be sure the selection is in view."

	(start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse:
		[view superView ifNotNil: [self deselect].
		self selectInvisiblyFrom: start to: stop].
	view superView ifNotNil: [self selectAndScroll]! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'tk 3/31/98 20:49'!
userHasEdited
	"Note that the user has edited my text."

	view hasUnacceptedEdits: true! !

!PluggableTextController methodsFor: 'as yet unclassified' stamp: 'tk 3/31/98 20:49'!
userHasNotEdited
	"Note that my text is free of user edits."

	view hasUnacceptedEdits: false! !
ScrollPane subclass: #PluggableTextMorph
	instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits askBeforeDiscardingEdits selectionInterval hasEditingConflicts '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 9/11/1998 15:46'!
acceptOnCR: trueOrFalse
	textMorph acceptOnCR: trueOrFalse! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 5/4/1998 15:55'!
editString: aString 
	"Jam some text in.  This is treated as clean text by default."

	self setText: aString asText! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'dew 2/21/1999 03:07'!
extent: newExtent
	super extent: (newExtent max: 36@16).
	textMorph ifNotNil:
		[textMorph extent: (self innerBounds width-6)@self height].
	self setScrollDeltas! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'bolot 11/2/1999 03:18'!
font: aFont
	textMorph beAllFont: aFont! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'sw 10/10/1999 23:01'!
initialize
	super initialize.
	hasUnacceptedEdits _ false.
	hasEditingConflicts _ false.
	askBeforeDiscardingEdits _ true! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 5/3/1998 12:45'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !

!PluggableTextMorph methodsFor: 'initialization' stamp: 'di 4/9/98 16:25'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	self model: anObject.
	getTextSelector _ getTextSel.
	setTextSelector _ setTextSel.
	getSelectionSelector _ getSelectionSel.
	getMenuSelector _ getMenuSel.
	self borderWidth: 1.
	self setText: self getText.
	self setSelection: self getSelection.! !


!PluggableTextMorph methodsFor: 'model access' stamp: 'RAA 11/5/2000 14:10'!
eToyGetMainFont

	^ textMorph textStyle! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 4/7/98 16:15'!
getSelection
	"Answer the model's selection interval."

	getSelectionSelector == nil ifTrue: [^ 1 to: 0].  "null selection"
	^ model perform: getSelectionSelector
! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 1/29/2000 14:34'!
getText 
	"Retrieve the current model text"

	| newText |
	getTextSelector == nil ifTrue: [^ Text new].
	newText _ model perform: getTextSelector.
	newText ifNil: [^Text new].
	^ newText shallowCopy! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'sw 10/30/2000 13:31'!
releaseCachedState
	"Release cached state of the receiver"

	(model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue:
		[model releaseCachedState].	"CodeHolder let go of CompiledMethod"! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 6/22/1998 01:32'!
selectionInterval: sel
	selectionInterval _ sel! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'wod 5/26/1998 17:03'!
setSelection: sel
	selectionInterval _ sel.
	textMorph editor selectFrom: sel first to: sel last.
	self scrollSelectionIntoView ifFalse: [scroller changed].! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'ls 7/20/1998 22:50'!
setText: aText
	scrollBar setValue: 0.0.
	textMorph
		ifNil: [textMorph _ TextMorphForEditView new
						contents: aText wrappedTo: self innerBounds width-6.
				textMorph setEditView: self.
				scroller addMorph: textMorph]
		ifNotNil: [textMorph newContents: aText].
	self hasUnacceptedEdits: false.
	self setScrollDeltas.! !

!PluggableTextMorph methodsFor: 'model access' stamp: 'di 4/20/1998 07:59'!
text
	^ textMorph contents! !


!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/6/2000 04:57'!
accept 
	"Inform the model of text to be accepted, and return true if OK."

	| textToAccept ok |
	self canDiscardEdits ifTrue: [^ self flash].
	self hasEditingConflicts ifTrue:
		[(self confirm: 
'Caution!! This method may have been
changed elsewhere since you started
editing it here.  Accept anyway?') ifFalse: [^ self flash]].
	textToAccept _ textMorph asText.
	ok _ (setTextSelector == nil) or:
		[setTextSelector numArgs = 2
			ifTrue: [model perform: setTextSelector with: textToAccept with: self]
			ifFalse: [model perform: setTextSelector with: textToAccept]].
	ok ifTrue:
		[self setText: self getText.
		self hasUnacceptedEdits: false.
		(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) doIfNotNil:
			[:aPane | model changed: #annotation]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
again
	self handleEdit: [textMorph editor again]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'!
browseIt
	self handleEdit: [textMorph editor browseIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/6/2000 04:56'!
cancel
	self setText: self getText.
	self setSelection: self getSelection.
	getTextSelector == #annotation ifFalse:
		[(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) doIfNotNil:
			[:aPane | model changed: #annotation]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
changeStyle
	self handleEdit: [textMorph editor changeStyle]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/27/1999 11:57'!
chooseAlignment
	self handleEdit: [textMorph editor changeAlignment]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:04'!
copySelection
	self handleEdit: [textMorph editor copySelection]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
cut
	self handleEdit: [textMorph editor cut]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:04'!
doIt
	self handleEdit: [textMorph editor evaluateSelection]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:41'!
explain
	self handleEdit: [textMorph editor explain]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'!
fileItIn
	self handleEdit: [textMorph editor fileItIn]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'!
find
	self handleEdit: [textMorph editor find]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:42'!
findAgain
	self handleEdit: [textMorph editor findAgain]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'!
implementorsOfIt
	self handleEdit: [textMorph editor implementorsOfIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 22:07'!
inspectIt
	| result |
	self handleEdit:
		[result _ textMorph editor evaluateSelection.
		((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [self flash]
			ifFalse: [result inspect]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/12/2000 22:49'!
languagePrefs
	self handleEdit: [textMorph editor languagePrefs]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodNamesContainingIt
	self handleEdit: [textMorph editor methodNamesContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodSourceContainingIt
	self handleEdit: [textMorph editor methodSourceContainingIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'!
methodStringsContainingit
	self handleEdit: [textMorph editor methodStringsContainingit]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'!
offerFontMenu
	self handleEdit: [textMorph editor offerFontMenu]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'!
paste
	self handleEdit: [textMorph editor paste]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 1/15/2001 18:36'!
pasteRecent
	"Paste an item chosen from RecentClippings."

	| clipping |
	(clipping _ Clipboard chooseRecentClipping) ifNil: [^ self].
	Clipboard clipboardText: clipping.
	^ self handleEdit: [textMorph editor paste]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:44'!
presentSpecialMenu
	self handleEdit: [textMorph editor presentSpecialMenu]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'!
prettyPrint
	self handleEdit: [textMorph editor prettyPrint]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'!
prettyPrintWithColor
	self handleEdit: [textMorph editor prettyPrintWithColor]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:07'!
printIt
	| result oldEditor |

	textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
						model: model.  "For, eg, evaluateSelection"
	textMorph handleEdit: [result _ (oldEditor _ textMorph editor) evaluateSelection].
	((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [^self flash].
	selectionInterval _ oldEditor selectionInterval.
	textMorph installEditorToReplace: oldEditor.
	textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString].
	selectionInterval _ oldEditor selectionInterval.
	
	textMorph editor selectFrom: selectionInterval first to: selectionInterval last.
	self scrollSelectionIntoView.

! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:10'!
printerSetup
	self handleEdit: [textMorph editor printerSetup]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/10/1998 12:45'!
recognizeCharacters
	self handleEdit: [textMorph editor recognizeCharacters]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:59'!
referencesToIt
	self handleEdit: [textMorph editor referencesToIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:15'!
saveContentsInFile
	self handleEdit: [textMorph editor saveContentsInFile]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'RAA 6/12/2000 09:02'!
scrollBarMenuButtonPressed: event
	| menu |
	(menu _ self getMenu: event shiftPressed) ifNotNil:
		["Set up to use perform:orSendTo: for model/view dispatch"
		menu setInvokingView: self.
		menu popUpEvent: event in: self world]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 1/22/2001 14:59'!
selectionAsTiles
	self handleEdit: [textMorph editor selectionAsTiles]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 20:09'!
sendContentsToPrinter
	self handleEdit: [textMorph editor sendContentsToPrinter]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:31'!
sendersOfIt
	self handleEdit: [textMorph editor sendersOfIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:09'!
setSearchString
	self handleEdit: [textMorph editor setSearchString]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 5/20/1998 23:11'!
spawn
	self handleEdit: [textMorph editor spawn].
	self cancel! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 10/30/2000 11:16'!
tileForIt
	"Return a tile referring to the object resulting form evaluating my current selection.  Not currently threaded in, but useful in earlier demos and possibly still of value."

	| result |
	self handleEdit:
		[result _ textMorph editor evaluateSelection.
		((result isKindOf: FakeClassPool) or: [result == #failedDoit])
			ifTrue: [self flash]
			ifFalse: [self currentHand attachMorph: result tileToRefer]]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'RAA 2/2/2001 05:45'!
toggleAnnotationPaneSize

	| handle origin aHand siblings newHeight lf prevBottom m ht |

	self flag: #bob.		"CRUDE HACK to enable changing the size of the annotations pane"

	owner ifNil: [^self].
	siblings _ owner submorphs.
	siblings size > 3 ifTrue: [^self].
	siblings size < 2 ifTrue: [^self].

	aHand _ self primaryHand.
	origin _ aHand position.
	handle _ HandleMorph new
		forEachPointDo: [:newPoint |
			handle removeAllMorphs.
			newHeight _ (newPoint - origin) y asInteger min: owner height - 50 max: 16.
			lf _ siblings last layoutFrame.
			lf bottomOffset: newHeight.
			prevBottom _ newHeight.
			siblings size - 1 to: 1 by: -1 do: [ :index |
				m _ siblings at: index.
				lf _ m layoutFrame.
				ht _ lf bottomOffset - lf topOffset.
				lf topOffset: prevBottom.
				lf bottomOffset = 0 ifFalse: [
					lf bottomOffset: (prevBottom + ht).
				].
				prevBottom _ prevBottom + ht.
			].
			owner layoutChanged.

		]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo doIfNotNil: [:halo | halo addHandles].
		].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor farther from
this point to increase pane.
Click when done.' hand: aHand.
	handle startStepping

! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/12/2000 22:50'!
translateIt
	self handleEdit: [textMorph editor translateIt]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/13/2000 20:13'!
undo
	self handleEdit: [textMorph editor undo]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/12/2000 22:49'!
verifyWordSpelling
	self handleEdit: [textMorph editor verifyWordSpelling]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 7/12/2000 22:49'!
wordDefinition
	self handleEdit: [textMorph editor wordDefinition]! !

!PluggableTextMorph methodsFor: 'menu commands' stamp: 'RAA 6/12/2000 09:02'!
yellowButtonActivity
	"Called when the shifted-menu's 'more' item is chosen"
	| menu |
	(menu _ self getMenu: false) ifNotNil:
		["Set up to use perform:orSendTo: for model/view dispatch"
		menu setInvokingView: self.
		menu popUpEvent: self currentEvent in: self world]! !


!PluggableTextMorph methodsFor: 'updating' stamp: 'dew 6/11/2000 02:21'!
update: aSymbol
	aSymbol ifNil: [^ self].
	aSymbol == #flash ifTrue: [^ self flash].
	aSymbol == getTextSelector ifTrue:
			[self setText: self getText.
			^ self setSelection: self getSelection].
	aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection].
	(aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue:
			[self handleEdit:
				[textMorph editor setSearch: model autoSelectString;
							againOrSame: true]].
	aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false].
	aSymbol == #wantToChange ifTrue:
			[self canDiscardEdits ifFalse: [^ self promptForCancel].
			^ self].
	aSymbol == #appendEntry ifTrue:
			[self handleEdit: [self appendEntry].
			^ self refreshWorld].
	aSymbol == #clearText ifTrue:
			[self handleEdit: [self changeText: Text new].
			^ self refreshWorld].
	aSymbol == #bs ifTrue:
			[self handleEdit: [self bsText].
			^ self refreshWorld].
	aSymbol == #codeChangedElsewhere ifTrue:
			[self hasEditingConflicts: true.
			^ self changed]! !


!PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 1/19/2001 01:17'!
drawOn: aCanvas 
	"Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame"

	super drawOn: aCanvas. 
	self wantsFrameAdornments ifTrue:
		[self hasEditingConflicts
			ifTrue:
				[aCanvas frameRectangle: self innerBounds width: 3 color: Color red] 
			ifFalse:
				[self hasUnacceptedEdits
					ifTrue:
						[model showDiffs
							ifTrue:
								[aCanvas frameRectangle: self innerBounds width: 3 color: Color green]
							ifFalse:
								[aCanvas frameRectangle: self innerBounds width: 1 color: Color red]]
					ifFalse:
						[model showDiffs
							ifTrue:
								[aCanvas frameRectangle: self innerBounds width: 1 color: Color green]]]]! !

!PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 1/18/2001 13:49'!
wantsFrameAdornments
	"Answer whether the receiver wishes to have red borders, etc., used to show editing state"

	"An unsavory way to get the desired effect, sorry"

	^ getTextSelector ~~ #annotation! !


!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/20/1998 18:53'!
askBeforeDiscardingEdits: aBoolean
	"Set the flag that determines whether the user should be asked before discarding unaccepted edits."

	askBeforeDiscardingEdits _ aBoolean! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/20/1998 18:52'!
canDiscardEdits
	"Return true if this view either has no text changes or does not care."

	^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not
! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'!
hasEditingConflicts
	"Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited"

	^ hasEditingConflicts == true! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'!
hasEditingConflicts: aBoolean

	hasEditingConflicts _ aBoolean! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/20/1998 18:56'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ hasUnacceptedEdits! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 23:06'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value. "
	aBoolean == hasUnacceptedEdits ifFalse:
		[hasUnacceptedEdits _ aBoolean.
		self changed].
	aBoolean ifFalse: [hasEditingConflicts _ false]! !

!PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'di 4/21/1998 14:00'!
promptForCancel
	"Ask if it is OK to cancel changes to text"
	(self confirm:
'Changes have not been saved.
Is it OK to cancel those changes?')
		ifTrue: [model clearUserEditFlag].
! !


!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 6/22/1998 15:15'!
correctFrom: start to: stop with: aString
	^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'jcg 11/5/2000 22:25'!
correctSelectionWithString: aString
	| result newPosition |

	"I can't tell if this is a hack or if it's the right thing to do."
	self setSelection: selectionInterval. 

	result _ self correctFrom: selectionInterval first to: selectionInterval last with: aString.
	newPosition _ selectionInterval first + aString size.
	self setSelection: (newPosition to: newPosition - 1).
	^ result! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:16'!
deselect
	^ textMorph editor deselect! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:26'!
nextTokenFrom: start direction: dir
	^ textMorph editor nextTokenFrom: start direction: dir! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/20/1998 08:32'!
notify: aString at: anInteger in: aStream
	^ textMorph editor notify: aString at: anInteger in: aStream! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:59'!
select
	^ textMorph editor select! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:58'!
selectFrom: start to: stop
	^ textMorph editor selectFrom: start to: stop! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 15:18'!
selectInvisiblyFrom: start to: stop
	^ textMorph editor selectInvisiblyFrom: start to: stop! !

!PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 5/6/1998 14:56'!
selectionInterval
	^ textMorph editor selectionInterval! !


!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 11/2/1998 15:57'!
handleEdit: editBlock
	| result |
	textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
						model: model.  "For, eg, evaluateSelection"
	textMorph handleEdit: [result _ editBlock value].   "Update selection after edit"
	self scrollSelectionIntoView.
	^ result! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'di 5/22/1998 12:35'!
scrollSelectionIntoView
	"Scroll my text into view if necessary and return true, else return false"
	^ self scrollSelectionIntoView: nil! !

!PluggableTextMorph methodsFor: 'editor access' stamp: 'ar 9/14/2000 17:48'!
scrollSelectionIntoView: event 
	"Scroll my text into view if necessary and return true, else return false"
	| selRects delta selRect rectToTest transform cpHere |
	selectionInterval _ textMorph editor selectionInterval.
	selRects _ textMorph paragraph selectionRects.
	selRects isEmpty ifTrue: [^ false].
	rectToTest _ selRects first merge: selRects last.
	transform _ scroller transformFrom: self.
	(event notNil and: [event anyButtonPressed]) ifTrue:  "Check for autoscroll"
		[cpHere _ transform localPointToGlobal: event cursorPoint.
		cpHere y <= self top
			ifTrue: [rectToTest _ selRects first topLeft extent: 2@2]
			ifFalse: [cpHere y >= self bottom
					ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2]
					ifFalse: [^ false]]].
	selRect _ transform localBoundsToGlobal: rectToTest.
	selRect height > bounds height
		ifTrue: [^ false].  "Would not fit, even if we tried to scroll"
	(delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue:
		["Scroll end of selection into view if necessary"
		self scrollBy: 0@delta y.
		^ true].
	^ false! !


!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/13/1998 14:29'!
appendEntry
	"Append the text in the model's writeStream to the editable text. "
	textMorph asText size > model characterLimit ifTrue:
		["Knock off first half of text"
		self selectInvisiblyFrom: 1 to: textMorph asText size // 2.
		self replaceSelectionWith: Text new].
	self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size.
	self replaceSelectionWith: model contents asText.
	self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'RAA 7/11/2000 06:27'!
appendTextEtoy: moreText
	"Append the text in the model's writeStream to the editable text. "

	self 
		selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size;
		replaceSelectionWith: moreText;
		selectFrom: textMorph asText size + 1 to: textMorph asText size;
		hasUnacceptedEdits: false;
		scrollSelectionIntoView;
		changed! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:40'!
bsText
	self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/8/1998 21:22'!
changeText: aText
	"The paragraph to be edited is changed to aText."
	self setText: aText! !

!PluggableTextMorph methodsFor: 'transcript' stamp: 'di 5/9/1998 21:40'!
replaceSelectionWith: aText
	^ textMorph editor replaceSelectionWith: aText! !


!PluggableTextMorph methodsFor: 'pane events' stamp: 'ar 9/15/2000 23:21'!
handlesKeyboard: evt
	^true! !

!PluggableTextMorph methodsFor: 'pane events' stamp: 'ar 9/15/2000 23:22'!
keyStroke: evt
	textMorph keyStroke: evt! !

!PluggableTextMorph methodsFor: 'pane events' stamp: 'ar 9/15/2000 23:05'!
mouseEnter: event
	super mouseEnter: event.
	selectionInterval ifNotNil:
		[textMorph handleEdit: [textMorph editor selectInterval: selectionInterval.
			textMorph editor setEmphasisHere]].
	event hand newKeyboardFocus: textMorph! !

!PluggableTextMorph methodsFor: 'pane events' stamp: 'ar 9/15/2000 23:30'!
mouseLeave: event

	textMorph ifNotNil: [selectionInterval _ textMorph editor selectionInterval].
	super mouseLeave: event.
	event hand releaseKeyboardFocus: textMorph.! !


!PluggableTextMorph methodsFor: 'geometry' stamp: 'kfr 6/8/2000 22:38'!
resetExtent
	"Reset the extent while maintaining the current selection.  Needed when resizing while the editor is active (when inside the pane)."
	| tempSelection |
	textMorph notNil ifTrue:
		["the current selection gets munged by resetting the extent, so store it"
		tempSelection _ self selectionInterval.
		
		"don't reset it if it's not active"
		tempSelection = (Interval from: 1 to: 0) 
						ifTrue: [retractableScrollBar
							ifTrue:[ ^ self]].
		self extent: self extent.
		self setSelection: tempSelection]! !

!PluggableTextMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled."
	^ scroller firstSubmorph defaultLineHeight
! !



!PluggableTextMorph methodsFor: 'accessing' stamp: 'sr 4/25/2000 07:21'!
getTextSelector
	^getTextSelector! !


!PluggableTextMorph methodsFor: 'drag and drop' stamp: 'jcg 7/7/2000 11:08'!
acceptDroppingMorph: aMorph event: evt 
	"This message is sent when a morph is dropped onto a morph that has     
	agreed to accept the dropped morph by responding 'true' to the     
	wantsDroppedMorph:Event: message. The default implementation just     
	adds the given morph to the receiver."
	"Here we let the model do its work."

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.

! !

!PluggableTextMorph methodsFor: 'drag and drop' stamp: 'jcg 7/7/2000 11:13'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextMorph class
	instanceVariableNames: ''!

!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'!
on: anObject text: getTextSel accept: setTextSel

	^ self on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: nil
		menu: nil! !

!PluggableTextMorph class methodsFor: 'as yet unclassified' stamp: 'di 4/7/98 16:03'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel! !
PluggableTextMorph subclass: #PluggableTextMorphWithModel
	instanceVariableNames: 'myContents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PluggableTextMorphWithModel methodsFor: 'initialization' stamp: 'mjg 12/3/1999 11:59'!
initialize
	super initialize.
	self on: self
		text: #getMyText
		accept: #setMyText:
		readSelection: nil
		menu: nil.
! !


!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:57'!
getMyText
	^myContents! !

!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'sw 10/26/2000 14:37'!
newTextContents: stringOrText
	"Accept new text contents."

	| newText aStack setter myText |
	"Just underway; trying to make this work like TextMorph does, but not quite there yet."

	newText _ stringOrText asText.
	(myText _ textMorph text) = newText ifTrue: [^ self].  "No substantive change"

	(self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil])
		ifTrue:
			[setter _ self valueOfProperty: #setterSelector.
			setter ifNotNil:
				[(self valueOfProperty: #cardInstance) perform: setter with: newText]].

	self world ifNotNil:
		[self world startSteppingSubmorphsOf: self ].
! !

!PluggableTextMorphWithModel methodsFor: 'contents' stamp: 'mjg 12/3/1999 11:59'!
setMyText: someText
	myContents _ someText.
	^true.! !


!PluggableTextMorphWithModel methodsFor: 'deletion' stamp: 'sw 10/26/2000 14:39'!
delete
	"Delete the receiver.  Since I have myself as a dependent, I need to remove it. which is odd in itself.  Also, the release of dependents will seemingly not be done if the *container* of the receiver is deleted rather than the receiver itself, a further problem"

	self removeDependent: self.
	super delete! !



!PluggableTextMorphWithModel methodsFor: 'data dockup' stamp: 'sw 10/24/2000 14:52'!
couldHoldSeparateDataForEachInstance
	"Answer whethre the receiver is structurally capable of holding uniqe data for each ard instance"

	^ true! !

!PluggableTextMorphWithModel methodsFor: 'data dockup' stamp: 'sw 10/30/2000 11:14'!
currentDataValue
	"Answer the current data value of the receiver"

	^ myContents! !

!PluggableTextMorphWithModel methodsFor: 'data dockup' stamp: 'sw 10/25/2000 07:00'!
variableDocks
	"Answer a list of VariableDocks that will handle the interface between me and instance data stored on my behalf on a card"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #getMyText morphPutSelector: #setMyText:)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextMorphWithModel class
	instanceVariableNames: ''!

!PluggableTextMorphWithModel class methodsFor: 'authoring prototype' stamp: 'sw 10/30/2000 11:14'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin"

	| proto |
	proto _ super authoringPrototype.
	proto color: (Color r: 0.972 g: 0.972 b: 0.662).
	^ proto! !
StringHolderView subclass: #PluggableTextView
	instanceVariableNames: 'getTextSelector setTextSelector getSelectionSelector getMenuSelector hasEditingConflicts '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!
!PluggableTextView commentStamp: '<historical>' prior: 0!
A PluggableTextView gets its content from the model. This allows the same kind of view to be used in different situations, thus avoiding a proliferation of gratuitous view and controller classes. See the class comment for PluggableListView.

Selectors are:

		getTextSel		fetch the original text from the model
		setTextSel		submit new text to the model when user "accepts"
		getSelectionSel	get the current text selection range
		getMenuSel		get the pane-specific, 'yellow-button' menu

	Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if setTextSel is nil then this view is consider read-only.

	The model informs a pluggable view of changes by sending #changed: to itself with getTextSel as a parameter. The view informs the model of selection changes by sending setTextSel to it with the newly selected item as a parameter, and invokes menu actions on the model via getMenuSel.
!


!PluggableTextView methodsFor: 'initialization' stamp: 'jm 3/29/98 07:24'!
defaultControllerClass 

	^ PluggableTextController
! !

!PluggableTextView methodsFor: 'initialization' stamp: 'sw 10/29/1999 21:02'!
initialize 
	super initialize.
	hasEditingConflicts _ false! !

!PluggableTextView methodsFor: 'initialization' stamp: 'tk 4/6/98 10:51'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	self model: anObject.
	getTextSelector _ getTextSel.
	setTextSelector _ setTextSel.
	getSelectionSelector _ getSelectionSel.
	getMenuSelector _ getMenuSel.
	self borderWidth: 1.
	self editString: self getText.
	self setSelection: self getSelection.

! !

!PluggableTextView methodsFor: 'initialization' stamp: 'jm 3/29/98 07:25'!
setSelection: sel

	controller selectFrom: sel first to: sel last.
! !


!PluggableTextView methodsFor: 'model access' stamp: 'di 6/26/1998 11:06'!
getMenu: shiftKeyDown
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."

	| menu |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ CustomMenu new.
	getMenuSelector numArgs = 1
		ifTrue: [^ model perform: getMenuSelector with: menu].
	getMenuSelector numArgs = 2
		ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!PluggableTextView methodsFor: 'model access' stamp: 'sw 1/16/1999 14:31'!
getSelection
	"Answer the model's selection interval."

	getSelectionSelector == nil ifTrue: [^ 1 to: 0].  "null selection"
	^ getSelectionSelector ifNotNil: [model perform: getSelectionSelector]
! !

!PluggableTextView methodsFor: 'model access' stamp: 'tk 4/1/98 08:32'!
getText 
	"Answer the list to be displayed."
	| txt |
	getTextSelector == nil ifTrue: [^ Text new].
	txt _ model perform: getTextSelector.
	txt == nil ifTrue: [^ Text new].
	self hasUnacceptedEdits: false.	"clean now"
	^ txt! !

!PluggableTextView methodsFor: 'model access' stamp: 'tk 3/31/98 15:58'!
getTextSelector
	"This is sent to the model to find out what text to display"

	^ getTextSelector! !

!PluggableTextView methodsFor: 'model access' stamp: 'jm 5/3/1998 19:29'!
isReadOnlyView

	^ setTextSelector == nil
! !

!PluggableTextView methodsFor: 'model access' stamp: 'jm
 8/20/1998 11:55'!
model: aLockedModel 
	"Refer to the comment in View|model:."
 
	self model: aLockedModel controller: controller.
	self editString: self getText.
! !

!PluggableTextView methodsFor: 'model access' stamp: 'di 3/10/98 13:51'!
setText: textToAccept from: ctlr
	"Inform the model of text to be accepted, and return true if OK.
	Any errors should be reported to the controller, ctlr."
	setTextSelector == nil ifTrue: [^ true].
	setTextSelector numArgs = 2
		ifTrue: [^ model perform: setTextSelector with: textToAccept with: ctlr]
		ifFalse: [^ model perform: setTextSelector with: textToAccept]! !

!PluggableTextView methodsFor: 'model access' stamp: 'di 4/27/1998 12:46'!
updateDisplayContents

	self editString: self getText.
	self displayView.
	self setSelection: self getSelection.
! !


!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:03'!
hasEditingConflicts
	"Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited"

	^ hasEditingConflicts == true! !

!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'!
hasEditingConflicts: aBoolean
	hasEditingConflicts _ aBoolean! !

!PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'!
hasUnacceptedEdits: aBoolean
	super hasUnacceptedEdits: aBoolean.
	aBoolean ifFalse: [hasEditingConflicts _ false]! !

!PluggableTextView methodsFor: 'updating' stamp: 'sma 3/15/2000 21:39'!
update: aSymbol
	"Refer to the comment in View|update:. Do nothing if the given symbol does not match any action. "

	aSymbol == #wantToChange ifTrue:
			[self canDiscardEdits ifFalse: [self promptForCancel].  ^ self].
	aSymbol == #flash ifTrue: [^ controller flash].
	aSymbol == getTextSelector ifTrue: [^ self updateDisplayContents].
	aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection].
	aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false].
	(aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue:
			[^ controller setSearch: model autoSelectString;
					againOrSame: true].
	aSymbol == #appendEntry ifTrue:
			[^ controller doOccluded: [controller appendEntry]].
	aSymbol == #clearText ifTrue:
			[^ controller doOccluded:
				[controller changeText: Text new]].
	aSymbol == #bs ifTrue:
			[^ controller doOccluded:
				[controller bsText]].
	aSymbol == #codeChangedElsewhere ifTrue:
			[^ self hasEditingConflicts: true]

! !


!PluggableTextView methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	hasEditingConflicts ifNil: [hasEditingConflicts _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PluggableTextView class
	instanceVariableNames: ''!

!PluggableTextView class methodsFor: 'instance creation' stamp: 'jm 3/29/98 07:24'!
on: anObject text: getTextSel accept: setTextSel

	^ self on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: nil
		menu: nil
! !

!PluggableTextView class methodsFor: 'instance creation' stamp: 'jm 3/29/98 07:24'!
on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel

	^ self new on: anObject
		text: getTextSel
		accept: setTextSel
		readSelection: getSelectionSel
		menu: getMenuSel
! !
CodeLoader subclass: #PluginCodeLoader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!
!PluginCodeLoader commentStamp: '<historical>' prior: 0!
PluginCodeLoader provides a simple facility for loading code from the network with integrated code signing.

Examples:
	| loader |
	loader _ PluginCodeLoader new.
	loader baseURL:'http://isgwww.cs.uni-magdeburg.de/~raab/test/'.
	"Sources and segments can be loaded in parallel"
	loader loadSourceFiles: #('file1.st' 'file2.st.gz').
	loader loadSegments: #('is1.extseg' 'is2.extseg.gz').
	"Install sources first - will wait until the files are actually loaded"
	loader installSourceFiles.
	"And then the segments"
	loader installSegments.!


!PluginCodeLoader methodsFor: 'private' stamp: 'mir 1/6/2000 21:15'!
httpRequestClass
	^PluginHTTPRequest
! !
HTTPRequest subclass: #PluginHTTPRequest
	instanceVariableNames: 'fileStream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!
!PluginHTTPRequest commentStamp: '<historical>' prior: 0!
HTTPBrowserRequest attempts to fetch the contents through a Webbrowser. This works transparently if Squeak is not running in the browser.!


!PluginHTTPRequest methodsFor: 'accessing' stamp: 'mir 1/20/2000 13:33'!
contentStream
	semaphore wait.
	fileStream == nil ifFalse:[^fileStream].
	^content == nil
		ifTrue:[nil]
		ifFalse:[
			(content isKindOf: String)
				ifTrue: [self error: 'Error loading ' , self url printString]
				ifFalse: [content contentStream]]! !

!PluginHTTPRequest methodsFor: 'accessing' stamp: 'mir 2/23/2000 12:41'!
contents
	| |
	semaphore wait.
	(content isNil and:[fileStream notNil]) ifTrue:[
"		pos _ fileStream position."
		fileStream position: 0.
		content _ MIMEDocument content: fileStream upToEnd.
		(fileStream respondsTo: #close) ifTrue:[fileStream close].
	].
	^content! !

!PluginHTTPRequest methodsFor: 'accessing' stamp: 'ar 12/21/1999 16:36'!
maxAttempts
	"Return the number of attempts to retry before giving up"
	^3! !

!PluginHTTPRequest methodsFor: 'accessing' stamp: 'mir 2/23/2000 12:40'!
signalAbort
	fileStream ifNotNil: [
		(fileStream respondsTo: #close) ifTrue:[fileStream close]].
	fileStream _ nil.
	super signalAbort.! !

!PluginHTTPRequest methodsFor: 'accessing' stamp: 'mir 1/11/2000 11:36'!
startRetrieval
	| attempts |
	attempts _ self maxAttempts.
	"Note: Only the first request may fail due to not running in a browser"
	url first = $/
		ifTrue: [url _ url copyFrom: 2 to: url size].
	fileStream _ FileStream requestURLStream: url ifError:[^super startRetrieval].
	[fileStream == nil] whileTrue:[
		attempts _ attempts - 1.
		attempts = 0 ifTrue:[^self content:'Error downloading file'].
		fileStream _ FileStream requestURLStream: url].
	semaphore signal.! !
AbstractLauncher subclass: #PluginLauncher
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Framework-Download'!

!PluginLauncher methodsFor: 'running' stamp: 'ar 1/19/2001 16:29'!
startUp
	| scriptName loader |

	World ifNotNil: [World install].
	StandardFileStream isRunningAsBrowserPlugin
		ifFalse: [^self].
	scriptName _ self parameterAt: 'src'.
	scriptName isEmpty ifTrue:[^self].
	CodeLoader defaultBaseURL: (self parameterAt: 'Base').

	loader _ PluginCodeLoader new.
	loader loadSourceFiles: (Array with: scriptName).
	(scriptName asLowercase endsWith: '.pr') 
		ifTrue:[loader installProject]
		ifFalse:[loader installSourceFiles].! !
Object subclass: #Point
	instanceVariableNames: 'x y '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Point commentStamp: '<historical>' prior: 0!
I represent an x-y pair of numbers usually designating a location on the screen.!


!Point methodsFor: 'accessing'!
x
	"Answer the x coordinate."

	^x! !

!Point methodsFor: 'accessing'!
y
	"Answer the y coordinate."

	^y! !


!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'!
* arg 
	"Answer a Point that is the product of the receiver and arg."

	arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)].
	^ arg adaptToPoint: self andSend: #*! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'!
+ arg 
	"Answer a Point that is the sum of the receiver and arg."

	arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)].
	^ arg adaptToPoint: self andSend: #+! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
- arg 
	"Answer a Point that is the difference of the receiver and arg."

	arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)].
	^ arg adaptToPoint: self andSend: #-! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
/ arg 
	"Answer a Point that is the quotient of the receiver and arg."

	arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)].
	^ arg adaptToPoint: self andSend: #/! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
// arg 
	"Answer a Point that is the quotient of the receiver and arg."

	arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)].
	^ arg adaptToPoint: self andSend: #//! !

!Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'!
\\ arg 
	"Answer a Point that is the mod of the receiver and arg."

	arg isPoint ifTrue: [^ (x \\ arg x) @ (y \\ arg y)].
	^ arg adaptToPoint: self andSend: #\\! !

!Point methodsFor: 'arithmetic'!
abs
	"Answer a Point whose x and y are the absolute values of the receiver's x 
	and y."

	^ x abs @ y abs! !


!Point methodsFor: 'comparing'!
< aPoint 
	"Answer whether the receiver is above and to the left of aPoint."

	^x < aPoint x and: [y < aPoint y]! !

!Point methodsFor: 'comparing'!
<= aPoint 
	"Answer whether the receiver is neither below nor to the right of aPoint."

	^x <= aPoint x and: [y <= aPoint y]! !

!Point methodsFor: 'comparing'!
= aPoint

	self species = aPoint species
		ifTrue: [^x = aPoint 
	"Refer to the comment in Object|=." x and: [y = aPoint y]]
		ifFalse: [^false]! !

!Point methodsFor: 'comparing'!
> aPoint 
	"Answer whether the receiver is below and to the right of aPoint."

	^x > aPoint x and: [y > aPoint y]! !

!Point methodsFor: 'comparing'!
>= aPoint 
	"Answer whether the receiver is neither above nor to the left of aPoint."

	^x >= aPoint x and: [y >= aPoint y]! !

!Point methodsFor: 'comparing' stamp: 'SqR 11/3/2000 17:08'!
hash
	"Hash is reimplemented because = is implemented."

	^(x hash hashMultiply + y hash) hashMultiply! !

!Point methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!Point methodsFor: 'comparing'!
max: aPoint 
	"Answer the lower right corner of the rectangle uniquely defined by the 
	receiver and the argument, aPoint."

	^ (x max: aPoint x) @ (y max: aPoint y)! !

!Point methodsFor: 'comparing'!
min: aPoint 
	"Answer the upper left corner of the rectangle uniquely defined by the 
	receiver and the argument, aPoint."

	^ (x min: aPoint x) @ (y min: aPoint y)! !

!Point methodsFor: 'comparing'!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !


!Point methodsFor: 'converting'!
@ aNumber
	^B3DVector3 x: x y: y z: aNumber! !

!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:45'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a Collection, return a Collection of
	the results of each element combined with me in that expression."

	^ rcvr collect: [:element | element perform: selector with: self]! !

!Point methodsFor: 'converting' stamp: 'di 11/9/1998 12:44'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with an Integer, convert it to a Point."
	^ rcvr@rcvr perform: selector with: self! !

!Point methodsFor: 'converting' stamp: 'di 11/6/1998 13:47'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a String, convert it to a Number."
	^ rcvr asNumber perform: selector with: self! !

!Point methodsFor: 'converting'!
asFloatPoint
	^ x asFloat @ y asFloat! !

!Point methodsFor: 'converting'!
asIntegerPoint
	^ x asInteger @ y asInteger! !

!Point methodsFor: 'converting'!
asPoint
	"Answer the receiver itself."

	^self! !

!Point methodsFor: 'converting'!
corner: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose corner is 
	aPoint. This is one of the infix ways of expressing the creation of a 
	rectangle."

	^Rectangle origin: self corner: aPoint! !

!Point methodsFor: 'converting'!
extent: aPoint 
	"Answer a Rectangle whose origin is the receiver and whose extent is 
	aPoint. This is one of the infix ways of expressing the creation of a 
	rectangle."

	^Rectangle origin: self extent: aPoint! !

!Point methodsFor: 'converting' stamp: 'di 11/6/1998 07:45'!
isPoint
	^ true! !

!Point methodsFor: 'converting' stamp: 'di 12/3/97 19:00'!
rect: aPoint 
	"Answer a Rectangle that encompasses the receiver and aPoint.
	This is the most general infix way to create a rectangle."

	^ Rectangle 
		origin: (self min: aPoint)
		corner: (self max: aPoint)! !


!Point methodsFor: 'copying'!
deepCopy
	"Implemented here for better performance."

	^x deepCopy @ y deepCopy! !

!Point methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Point methodsFor: 'geometry' stamp: 'laza 1/24/2000 03:44'!
isInsideCircle: a with: b with: c 
	"Returns TRUE if self is inside the circle defined by the     
	points a, b, c. See Guibas and Stolfi (1985) p.107"
	^ (a dotProduct: a)
		* (b triangleArea: c with: self) - ((b dotProduct: b)
			* (a triangleArea: c with: self)) + ((c dotProduct: c)
			* (a triangleArea: b with: self)) - ((self dotProduct: self)
			* (a triangleArea: b with: c)) > 0.0! !

!Point methodsFor: 'geometry' stamp: 'laza 1/6/2000 10:30'!
sideOf: otherPoint 
	"Returns #left, #right or #center if the otherPoint lies to the left, right 
	or on the line given by the vector from 0@0 to self"
	| side |
	side _ (self crossProduct: otherPoint) sign.
	^ {#right. #center. #left} at: side + 2
! !

!Point methodsFor: 'geometry' stamp: 'ar 4/6/2000 18:37'!
to: end1 intersects: start2 to: end2 
	"Returns true if the linesegment from start1 (=self) to end1 intersects      
	    with the segment from start2 to end2, otherwise false."
	| start1 sideStart sideEnd |
	start1 _ self.
	(((start1 = start2 or: [end1 = end2])
		or: [start1 = end2])
		or: [start2 = end1])
		ifTrue: [^ true].
	sideStart _ start1 to: end1 sideOf: start2.
	sideEnd _ start1 to: end1 sideOf: end2.
	sideStart = sideEnd ifTrue: [^ false].
	sideStart _ start2 to: end2 sideOf: start1.
	sideEnd _ start2 to: end2 sideOf: end1.
	sideStart = sideEnd ifTrue: [^ false].
	^ true! !

!Point methodsFor: 'geometry' stamp: 'laza 1/5/2000 11:50'!
to: end sideOf: otherPoint 
	"Returns #left, #right, #center if the otherPoint lies to the left, right or on the line given by the vector from self to end"
	^ end - self sideOf: otherPoint - self! !

!Point methodsFor: 'geometry' stamp: 'laza 1/17/2000 15:47'!
triangleArea: b with: c
	"Returns twice the area of the oriented triangle (a, b, c), i.e., the   
	area is positive if the triangle is oriented counterclockwise"
	^ b x - self x * (c y - self y) - (b y - self y * (c x - self x))! !


!Point methodsFor: 'interpolating' stamp: 'jsp 3/22/1999 16:31'!
interpolateTo: end at: amountDone
	"Interpolate between the instance and end after the specified amount has been done (0 - 1)."

	^ self + ((end - self) * amountDone).! !


!Point methodsFor: 'point functions' stamp: 'sw 2/15/98 02:27'!
bearingToPoint: anotherPoint
    "Return the bearing, in degrees, from the receiver to anotherPoint.
     Adapted from Playground, where the ultimate provenance of the algorithm was a wild earlier method of Jay Fenton's which I never checked carefully, but the thing has always seemed to work"

    | deltaX deltaY  |
    deltaX := anotherPoint x -  x.
    deltaY := anotherPoint y - y.

    deltaX abs < 0.001
        ifTrue:
            [^ deltaY > 0 ifTrue: [180] ifFalse: [0]].

    ^ ((deltaX >= 0 ifTrue: [90] ifFalse: [270])
            - ((deltaY / deltaX) arcTan negated * 57.2957795131)) rounded
! !

!Point methodsFor: 'point functions' stamp: 'ar 10/30/1998 03:05'!
crossProduct: aPoint 
	"Answer a number that is the cross product of the receiver and the 
	argument, aPoint."

	^ (x * aPoint y) - (y * aPoint x)! !

!Point methodsFor: 'point functions'!
dist: aPoint 
	"Answer the distance between aPoint and the receiver."

	^(aPoint - self) r! !

!Point methodsFor: 'point functions' stamp: 'di 9/11/1998 16:22'!
dotProduct: aPoint 
	"Answer a number that is the dot product of the receiver and the 
	argument, aPoint. That is, the two points are multipled and the 
	coordinates of the result summed."

	^ (x * aPoint x) + (y * aPoint y)! !

!Point methodsFor: 'point functions'!
eightNeighbors
	^ (Array with: self + (1@0)
		with: self + (1@1)
		with: self + (0@1)
		with: self + (-1@1)) ,
	(Array with: self + (-1@0)
		with: self + (-1@-1)
		with: self + (0@-1)
		with: self + (1@-1))
! !

!Point methodsFor: 'point functions' stamp: 'di 6/11/97 16:08'!
flipBy: direction centerAt: c
	"Answer a Point which is flipped according to the direction about the point c.
	Direction must be #vertical or #horizontal."
	direction == #vertical ifTrue: [^ x @ (c y * 2 - y)].
	direction == #horizontal ifTrue: [^ (c x * 2 - x) @ y].
	self error: 'unrecognizable direction'! !

!Point methodsFor: 'point functions'!
fourNeighbors
	^ Array with: self + (1@0)
		with: self + (0@1)
		with: self + (-1@0)
		with: self + (0@-1)
! !

!Point methodsFor: 'point functions'!
grid: aPoint 
	"Answer a Point to the nearest rounded grid modules specified by aPoint."

	| newX newY |
	newX _ x + (aPoint x // 2) truncateTo: aPoint x.
	newY _ y + (aPoint y // 2) truncateTo: aPoint y.
	^newX @ newY! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:37'!
nearestPointAlongLineFrom: p1 to: p2
	"Note this will give points beyond the endpoints.
	Streamlined by Gerardo Richarte 11/3/97"
	| x21 y21 t x1 y1 |
	p1 x = p2 x ifTrue: [^ p1 x @ y].
	p1 y = p2 y ifTrue: [^ x @ p1 y].
	x1 _ p1 x asFloat.
	y1 _ p1 y asFloat.
	x21 _ p2 x asFloat - x1.
	y21 _ p2 y asFloat - y1.
	t _ ((y asFloat - y1 / x21) + (x asFloat - x1 / y21))
			/ ((x21 / y21) + (y21 / x21)).
	^ (x1 + (t * x21)) @ (y1 + (t * y21))
"
	| old new |
	Pen new place: 200@100; goto: (old _ 500@300).
	Display reverse: (old extent: 10@10).
	[Sensor anyButtonPressed] whileFalse:
		[(new _ (Sensor cursorPoint nearestPointAlongLineFrom: 200@100 to: 500@300) )
			= old ifFalse:
				[Display reverse: (old extent: 10@10).
				Display reverse: ((old _ new) extent: 10@10)]]
"
! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:40'!
nearestPointOnLineFrom: p1 to: p2
	"This will not give points beyond the endpoints"
	^ (self nearestPointAlongLineFrom: p1 to: p2)
		adhereTo: (p1 rect: p2)! !

!Point methodsFor: 'point functions'!
normal
	"Answer a Point representing the unit vector rotated 90 deg clockwise."

	| n |
	n _ y negated @ x.
	^n / (n x * n x + (n y * n y)) sqrt! !

!Point methodsFor: 'point functions' stamp: 'ar 2/11/1999 17:11'!
normalized
	^self / self r! !

!Point methodsFor: 'point functions' stamp: 'laza 12/13/1999 11:43'!
octantOf: otherPoint 
	"Return 1..8 indicating relative direction to otherPoint.  
	1=ESE, 2=SSE, ... etc. clockwise to 8=ENE"
	"[Sensor anyButtonPressed] whileFalse: [(Display boundingBox center 
	octantOf: Sensor cursorPoint) printString displayAt: 0@0]"
	| quad moreHoriz |
	(x = otherPoint x and: [y > otherPoint y])
		ifTrue: [^ 6].
	"special case"
	(y = otherPoint y and: [x < otherPoint x])
		ifTrue: [^ 8].
	quad _ self quadrantOf: otherPoint.
	moreHoriz _ (x - otherPoint x) abs >= (y - otherPoint y) abs.
	(quad even eqv: moreHoriz)
		ifTrue: [^ quad * 2]
		ifFalse: [^ quad * 2 - 1]! !

!Point methodsFor: 'point functions' stamp: 'di 12/1/97 12:12'!
onLineFrom: p1 to: p2
	^ self onLineFrom: p1 to: p2 within: 2! !

!Point methodsFor: 'point functions' stamp: 'jm 2/24/98 08:34'!
onLineFrom: p1 to: p2 within: epsilon
	"Answer true if the receiver lies on the given line segment between p1 and p2 within a small epsilon."

	"is this point within the box spanning p1 and p2 expanded by epsilon? (optimized)"
	p1 x < p2 x
		ifTrue: [
			((x < (p1 x - epsilon)) or: [x > (p2 x + epsilon)]) ifTrue: [^ false]]
		ifFalse: [
			((x < (p2 x - epsilon)) or: [x > (p1 x + epsilon)]) ifTrue: [^ false]].
	p1 y < p2 y
		ifTrue: [
			((y < (p1 y - epsilon)) or: [y > (p2 y + epsilon)]) ifTrue: [^ false]]
		ifFalse: [
			((y < (p2 y - epsilon)) or: [y > (p1 y + epsilon)]) ifTrue: [^ false]].

	"it's in the box; is it on the line?"
	^ (self dist: (self nearestPointAlongLineFrom: p1 to: p2)) <= epsilon! !

!Point methodsFor: 'point functions' stamp: '6/9/97 14:51 di'!
quadrantOf: otherPoint
	"Return 1..4 indicating relative direction to otherPoint.
	1 is downRight, 2=downLeft, 3=upLeft, 4=upRight"
	^ x <= otherPoint x
		ifTrue: [y < otherPoint y ifTrue: [1] ifFalse: [4]]
		ifFalse: [y <= otherPoint y ifTrue: [2] ifFalse: [3]]
"
[Sensor anyButtonPressed] whileFalse:
	[(Display boundingBox center quadrantOf: Sensor cursorPoint) printString displayAt: 0@0]
"! !

!Point methodsFor: 'point functions' stamp: 'di 6/11/97 15:12'!
rotateBy: direction centerAt: c
	"Answer a Point which is rotated according to direction, about the point c.
	Direction must be one of #right (CW), #left (CCW) or #pi (180 degrees)."
	| offset |
	offset _ self - c.
	direction == #right ifTrue: [^ (offset y negated @ offset x) + c].
	direction == #left ifTrue: [^ (offset y @ offset x negated) + c].
	direction == #pi ifTrue: [^ c - offset].
	self error: 'unrecognizable direction'! !

!Point methodsFor: 'point functions' stamp: 'ar 4/18/1999 05:17'!
sortsBefore: otherPoint
	"Return true if the receiver sorts before the other point"
	^y = otherPoint y
		ifTrue:[x <= otherPoint x]
		ifFalse:[y <= otherPoint y]! !

!Point methodsFor: 'point functions' stamp: 'ar 11/12/1998 01:44'!
transposed
	^y@x! !


!Point methodsFor: 'polar coordinates' stamp: 'di 6/12/97 12:18'!
degrees
	"Answer the angle the receiver makes with origin in degrees. right is 0; down is 90."
	| tan theta |
	x = 0
		ifTrue: [y >= 0
				ifTrue: [^ 90.0]
				ifFalse: [^ 270.0]]
		ifFalse: 
			[tan _ y asFloat / x asFloat.
			theta _ tan arcTan.
			x >= 0
				ifTrue: [y >= 0
						ifTrue: [^ theta radiansToDegrees]
						ifFalse: [^ 360.0 + theta radiansToDegrees]]
				ifFalse: [^ 180.0 + theta radiansToDegrees]]! !

!Point methodsFor: 'polar coordinates'!
r
	"Answer the receiver's radius in polar coordinate system."

	^(self dotProduct: self) sqrt! !

!Point methodsFor: 'polar coordinates'!
theta
	"Answer the angle the receiver makes with origin in radians. right is 0; 
	down is 90."

	| tan theta |
	x = 0
		ifTrue: [y >= 0
				ifTrue: [^1.5708"90.0 degreesToRadians"]
				ifFalse: [^4.71239"270.0 degreesToRadians"]]
		ifFalse: 
			[tan _ y asFloat / x asFloat.
			theta _ tan arcTan.
			x >= 0
				ifTrue: [y >= 0
						ifTrue: [^theta]
						ifFalse: [^360.0 degreesToRadians + theta]]
				ifFalse: [^180.0 degreesToRadians + theta]]! !


!Point methodsFor: 'printing' stamp: 'sw 4/25/1998 12:53'!
basicType
	^ #point! !

!Point methodsFor: 'printing'!
encodePostscriptOn:aStream 
	aStream writePoint:self.! !

!Point methodsFor: 'printing'!
printOn: aStream 
	"The receiver prints on aStream in terms of infix notation."

	x printOn: aStream.
	aStream nextPut: $@.
	y printOn: aStream! !

!Point methodsFor: 'printing'!
storeOn: aStream 
	"x@y printed form is good for storing too"
	self printOn: aStream! !


!Point methodsFor: 'private' stamp: 'ar 4/4/1999 00:40'!
bitShiftPoint: bits
	x _ x bitShift: bits.
	y _ y bitShift: bits.! !

!Point methodsFor: 'private' stamp: 'di 5/16/2000 22:05'!
setR: rho degrees: theta 

	| radians |
	radians _ theta asFloat degreesToRadians.
	x _ rho asFloat * radians cos.
	y _ rho asFloat * radians sin.! !

!Point methodsFor: 'private' stamp: 'sw 3/21/2000 13:24'!
setX: xValue setY: yValue

	x _ xValue.
	y _ yValue! !


!Point methodsFor: 'transforming' stamp: 'di 4/30/1998 11:16'!
adhereTo: aRectangle
	"If the receiver lies outside aRectangle, return the nearest point on the boundary of the rectangle, otherwise return self."

	(aRectangle containsPoint: self) ifTrue: [^ self].
	^ ((x max: aRectangle left) min: aRectangle right)
		@ ((y max: aRectangle top) min: aRectangle bottom)! !

!Point methodsFor: 'transforming'!
negated
	"Answer a point whose x and y coordinates are the negatives of those of the receiver.  6/6/96 sw"

	^ x negated @ y negated! !

!Point methodsFor: 'transforming'!
rotateBy: angle about: center
	"Even though Point.theta is measured CW, this rotates with the more conventional CCW interpretateion of angle."

	| p r theta |
	p _ self - center.
	r _ p r.
	theta _ angle asFloat - p theta.
	^ (center x asFloat + (r * theta cos)) @
	  (center y asFloat - (r * theta sin))! !

!Point methodsFor: 'transforming'!
scaleBy: factor 
	"Answer a Point scaled by factor (an instance of Point)."

	^(factor x * x) @ (factor y * y)! !

!Point methodsFor: 'transforming' stamp: 'di 12/4/97 14:34'!
scaleFrom: rect1 to: rect2
	"Produce a point stretched according to the stretch from rect1 to rect2"
	^ rect2 topLeft + (((x-rect1 left) * rect2 width // rect1 width)
					@ ((y-rect1 top) * rect2 height // rect1 height))! !

!Point methodsFor: 'transforming'!
translateBy: delta 
	"Answer a Point translated by delta (an instance of Point)."

	^(delta x + x) @ (delta y + y)! !


!Point methodsFor: 'truncation and round off' stamp: 'jm 6/3/1998 12:21'!
rounded
	"Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x rounded @ y rounded
! !

!Point methodsFor: 'truncation and round off'!
truncateTo: grid
	"Answer a Point that is the receiver's x and y truncated to grid x and 
	grid y."
	| gridPoint |
	gridPoint _ grid asPoint.
	^(x truncateTo: gridPoint x) @ (y truncateTo: gridPoint y)! !

!Point methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'!
truncated
	"Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral."

	(x isInteger and: [y isInteger]) ifTrue: [^ self].
	^ x truncated @ y truncated
! !


!Point methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 17:27'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 3 count:  1.
	encoded := String new: 8.
	encoded putInteger32: x asInteger at: 1.
	encoded putInteger32: y asInteger at: 5.
	^encoded! !


!Point methodsFor: 'testing' stamp: 'ar 10/29/2000 19:02'!
isZero
	^x isZero and:[y isZero]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Point class
	instanceVariableNames: ''!

!Point class methodsFor: 'instance creation' stamp: 'sw 9/20/97 15:34'!
fromUser
	Sensor waitNoButton.
	Cursor crossHair show.
	Sensor waitButton.
	Cursor normal show.
	^ Sensor cursorPoint

"Point fromUser"! !

!Point class methodsFor: 'instance creation'!
r: rho degrees: theta
	"Answer an instance of me with polar coordinates rho and theta."

	^self new setR: rho degrees: theta! !

!Point class methodsFor: 'instance creation'!
x: xInteger y: yInteger 
	"Answer an instance of me with coordinates xInteger and yInteger."

	^self new setX: xInteger setY: yInteger! !
IntegerArray variableWordSubclass: #PointArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!PointArray commentStamp: '<historical>' prior: 0!
This class stores 32bit Integer points in place. It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!


!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
at: index
	"Return the element (e.g., point) at the given index"
	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
at: index put: aPoint
	"Store the argument aPoint at the given index"
	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'!
bounds
	| min max |
	min _ max _ self at: 1.
	self do:[:pt|
		min _ min min: pt.
		max _ max max: pt].
	^min corner: max
		! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0@0! !

!PointArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:21'!
size
	"Return the number of elements in the receiver"
	^super size // 2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PointArray class
	instanceVariableNames: ''!

!PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'!
new: n
	^super new: n*2! !
Model subclass: #PointerFinder
	instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!PointerFinder commentStamp: '<historical>' prior: 0!
I can search for reasons why a certain object isn't garbage collected.  I'm a quick port of a VisualWorks program written by Hans-Martin Mosner.  Call me as shown below.  I'll search for a path from a global variable to the given object, presenting it in a small morphic UI.

Examples:
	PointerFinder on: self currentHand
	PointerFinder on: StandardSystemView someInstance

Now, let's see why this image contains more HandMorphs as expected...

HandMorph allInstancesDo: [:e | PointerFinder on: e]!


!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 18:58'!
buildList
	| list obj parent object key |
	list := OrderedCollection new.
	obj := goal.
	
	[list addFirst: obj.
	obj := parents at: obj ifAbsent: [].
	obj == nil] whileFalse.
	list removeFirst.
	parent := Smalltalk.
	objectList := OrderedCollection new.
	pointerList := OrderedCollection new.
	[list isEmpty]
		whileFalse: 
			[object := list removeFirst.
			key := nil.
			(parent isKindOf: Dictionary)
				ifTrue: [list size >= 2
						ifTrue: 
							[key := parent keyAtValue: list second ifAbsent: [].
							key == nil
								ifFalse: 
									[object := list removeFirst; removeFirst.
									pointerList add: key printString , ' -> ' , object class name]]].
			key == nil
				ifTrue: 
					[parent class == object ifTrue: [key := 'CLASS'].
					key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
									== object ifTrue: [key := parent class allInstVarNames at: i]]]].
					key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
									== object ifTrue: [key := i printString]]]].
					key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
					key == nil ifTrue: [key := '???'].
					pointerList add: key , ': ' , object class name].
			objectList add: object.
			parent := object]! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 23:08'!
follow: anObject from: parentObject
	anObject == goal
		ifTrue: 
			[parents at: anObject put: parentObject.
			^ true].
	anObject isLiteral ifTrue: [^ false].
	anObject class isPointers ifFalse: [^ false].
	anObject class isWeak ifTrue: [^ false].
	(parents includesKey: anObject)
		ifTrue: [^ false].
	parents at: anObject put: parentObject.
	toDoNext add: anObject.
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 10:01'!
followObject: anObject
	(self follow: anObject class from: anObject)
		ifTrue: [^ true].
	1 to: anObject class instSize do:
		[:i |
		(self follow: (anObject instVarAt: i) from: anObject)
			ifTrue: [^ true]].
	1 to: anObject basicSize do:
		[:i |
		(self follow: (anObject basicAt: i) from: anObject)
			ifTrue: [^ true]].
	^ false! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 09:52'!
goal: anObject
	goal _ anObject! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'!
initialize
	parents _ IdentityDictionary new: 20000.
	parents at: Smalltalk put: nil.
	parents at: Processor put: nil.
	parents at: self put: nil.

	toDo _ OrderedCollection new: 5000.
	toDo add: Smalltalk.
	toDoNext _ OrderedCollection new: 5000! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'!
isLiteral
	"Horrible hack to omit other Pointer Finders from scanning."

	^ true! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:17'!
search
	Smalltalk garbageCollect.

	self initialize.
	
	Cursor wait showWhile: [
		[[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse.
		toDo isEmpty and: [toDoNext isEmpty not]]
			whileTrue: 
				[toDo _ toDoNext.
				toDoNext _ OrderedCollection new: 5000]].

	self buildList! !

!PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 19:10'!
update
	('done: ' , parents size asString , ' todo: ' , toDo size asString , '   ') displayAt: 0@0! !


!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:23'!
arrowKey: key from: aController
	key = $i ifTrue: [^ self inspectObject].
	^ super arrowKey: key from: aController! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:48'!
initialExtent
	^ 300 @ 300! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:26'!
inspectObject
	pointerListIndex = 0 ifTrue: [^ self beep].
	(objectList at: pointerListIndex) inspect! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:09'!
menu: aMenu shifted: shifted
	^ MenuMorph new
		defaultTarget: self;
		add: 'Inspect (i)' action: #inspectObject;
		balloonTextForLastItem: 'Live long and prosper!!';
		addLine;
		add: 'Search again' action: #searchAgain;
		balloonTextForLastItem: 'Search again\for the same object' withCRs;
		yourself! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'RAA 1/7/2001 12:47'!
open
	| window list |
	window _ (SystemWindow labelled: 'Pointer Finder')
		model: self.
	list _ PluggableListMorph new
		doubleClickSelector: #inspectObject;

		on: self
		list: #pointerList
		selected: #pointerListIndex
		changeSelected: #pointerListIndex:
		menu: #menu:shifted:
		keystroke: #arrowKey:from:.
	window addMorph: list frame: (0@0 extent: 1@1).
	list color: Color lightMagenta.
	window openInWorld! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:15'!
perform: selector orSendTo: otherTarget
	selector == #inspectObject ifTrue: [^ self inspectObject].
	selector == #searchAgain ifTrue: [^ self searchAgain].
	^ super perform: selector orSendTo: otherTarget! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:49'!
pointerList
	^ pointerList asArray! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:27'!
pointerListIndex
	^ pointerListIndex ifNil: [0]! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:51'!
pointerListIndex: anInteger
	pointerListIndex _ anInteger.
	self changed: #pointerListIndex! !

!PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:16'!
searchAgain
	self pointerListIndex: 0.
	self search.
	self changed: #pointerList! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PointerFinder class
	instanceVariableNames: ''!

!PointerFinder class methodsFor: 'instance creation' stamp: 'sma 6/6/2000 23:52'!
on: anObject
	^ self new goal: anObject; search; open! !
BorderedMorph subclass: #PolygonMorph
	instanceVariableNames: 'vertices closed filledForm arrows arrowForms smoothCurve curveState borderDashSpec handles borderForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!PolygonMorph commentStamp: '<historical>' prior: 0!
This class combines the old Polygon and Curve classes.

The 1-bit fillForm to make display and containment tests reasonably fast.  However, this functionality is in the process of being supplanted by balloon capabilities, which should eventually provide anti-aliasing as well.!


!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:44'!
beSmoothCurve

	smoothCurve == true ifFalse:
		[smoothCurve _ true.
		self computeBounds]! !

!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:45'!
beStraightSegments

	smoothCurve == false ifFalse:
		[smoothCurve _ false.
		self computeBounds]! !

!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/7/2000 15:46'!
initialize
	super initialize.
	vertices _ Array with: 20@20 with: 40@30 with: 20@40.
	borderWidth _ 2.
	borderColor _ Color magenta.
	closed _ true.
	smoothCurve _ false.
	arrows _ #none.
	self computeBounds.
! !

!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/26/97 10:33'!
installModelIn: aWorld
	aWorld isWorldMorph ifTrue: [self addHandles]! !

!PolygonMorph methodsFor: 'initialization' stamp: 'di 9/7/2000 13:28'!
vertices: verts color: c borderWidth: bw borderColor: bc
	super initialize.
	vertices _ verts.
	color _ c.
	borderWidth _ bw.
	borderColor _ bc.
	closed _ vertices size > 2.
	arrows _ #none.
	self computeBounds.
! !


!PolygonMorph methodsFor: 'access' stamp: 'di 2/10/1999 21:13'!
borderColor: aColor
	(borderColor isColor and: [borderColor isTranslucentColor])
		== (aColor isColor and: [aColor isTranslucentColor])
		ifTrue: [super borderColor: aColor]
		ifFalse: ["Need to recompute fillForm and borderForm
					if translucency of border changes."
				super borderColor: aColor.
				self releaseCachedState]! !

!PolygonMorph methodsFor: 'access' stamp: '6/8/97 15:43 di'!
borderWidth: anInteger

	borderColor ifNil: [borderColor _ Color black].
	borderWidth _ anInteger.
	self computeBounds! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 8/25/2000 22:37'!
isClosed
	^ closed! !

!PolygonMorph methodsFor: 'access' stamp: 'di 9/7/2000 16:18'!
isCurve
	^ smoothCurve! !

!PolygonMorph methodsFor: 'access' stamp: 'jm 11/19/97 18:55'!
isOpen
	^ closed not! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 8/23/2000 16:16'!
makeOpenOrClosed
	"toggle the open/closed status of the receiver"
	closed ifTrue: [self makeOpen] ifFalse: [self makeClosed]! !

!PolygonMorph methodsFor: 'access' stamp: 'di 9/7/2000 16:53'!
openOrClosePhrase
	| curveName |
	curveName _ self isCurve ifTrue: ['curve'] ifFalse: ['polygon'].
	^ closed
		ifTrue: ['make open ' , curveName]
		ifFalse: ['make closed ' , curveName]! !

!PolygonMorph methodsFor: 'access' stamp: 'sw 9/14/97 18:22'!
vertices
	^ vertices! !


!PolygonMorph methodsFor: 'geometry' stamp: 'di 12/1/97 12:44'!
closestPointTo: aPoint
	| curvePoint closestPoint dist minDist |
	closestPoint _ minDist _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | 
		curvePoint _ aPoint nearestPointOnLineFrom: p1 to: p2.
		dist _ curvePoint dist: aPoint.
		(closestPoint == nil or: [dist < minDist])
			ifTrue: [closestPoint _ curvePoint.
					minDist _ dist]].
	^ closestPoint! !

!PolygonMorph methodsFor: 'geometry' stamp: 'di 8/20/2000 14:33'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^ false].

	closed & color isTransparent not ifTrue:
		[^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0].

	self lineSegmentsDo:
		[:p1 :p2 |
		(aPoint onLineFrom: p1 to: p2 within: (3 max: borderWidth+1//2) asFloat)
				ifTrue: [^ true]].

	self arrowForms do:
		[:f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]].

	^ false! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 11/24/1999 14:57'!
couldHaveRoundedCorners
	^ false! !

!PolygonMorph methodsFor: 'geometry' stamp: 'di 9/24/2000 08:44'!
extent: newExtent 
	"Not really advisable, but we can preserve most of the geometry if we don't
	shrink things too small."
	| safeExtent center |
	center _ self referencePosition.
	safeExtent _ newExtent max: 20@20.
	self setVertices: (vertices collect:
		[:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + center])! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
flipHAroundX: centerX
	"Flip me horizontally around the center.  If centerX is nil, compute my center of gravity."

	| cent |
	cent _ centerX 
		ifNil: [bounds center x
			"cent _ 0.
			vertices do: [:each | cent _ cent + each x].
			cent asFloat / vertices size"]		"average is the center"
		ifNotNil: [centerX].
	self setVertices: (vertices collect: [:vv |
			(vv x - cent) * -1 + cent @ vv y]) reversed.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
flipVAroundY: centerY
	"Flip me vertically around the center.  If centerY is nil, compute my center of gravity."

	| cent |
	cent _ centerY 
		ifNil: [bounds center y
			"cent _ 0.
			vertices do: [:each | cent _ cent + each y].
			cent asFloat / vertices size"]		"average is the center"
		ifNotNil: [centerY].
	self setVertices: (vertices collect: [:vv |
			vv x @ ((vv y - cent) * -1 + cent)]) reversed.! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
inset: amt
	"Only works if I am made of rectangles (every segment of me is horizontal or vertical).  Inset each vertex by amt.  Uses containsPoint."

	| delta four cnt offset |
	delta _ amt asPoint.
	four _ {delta.  -1@1 * delta.  -1@-1 * delta.  1@-1 * delta}.
	self setVertices: (vertices collect: [:vv | 
		cnt _ 0.
		offset _ four detectSum: [:del | 
			(self containsPoint: del+vv) ifTrue: [cnt _ cnt + 1. del] ifFalse: [0@0]].
		cnt = 2 ifTrue: [offset _ offset // 2].
		vv + offset]).! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
merge: aPolygon
	"Expand myself to enclose the other polygon.  (Later merge overlapping or disjoint in a smart way.)  For now, the two polygons must share at least two vertices.  Shared vertices must come one after the other in each polygon.  Polygons must not overlap."

	| shared mv vv hv xx |
	shared _ vertices select: [:mine | 
		(aPolygon vertices includes: mine)].
	shared size < 2 ifTrue: [^ nil].	"not sharing a segment"
	mv _ vertices asOrderedCollection.
	[shared includes: mv first] whileFalse: ["rotate them"
		vv _ mv removeFirst.
		mv addLast: vv].
	hv _ aPolygon vertices asOrderedCollection.
	[mv first = hv first] whileFalse: ["rotate him until same shared vertex is first"
		vv _ hv removeFirst.
		hv addLast: vv].
	[shared size > 2] whileTrue: [
		shared _ shared asOrderedCollection.
		(self mergeDropThird: mv in: hv from: shared) ifNil: [^ nil]].
		"works by side effect on the lists"
	(mv at: 2) = hv last ifTrue: [mv removeFirst; removeFirst.
		^ self setVertices: (hv, mv) asArray].
	(hv at: 2) = mv last ifTrue: [hv removeFirst; removeFirst.
		^ self setVertices: (mv, hv) asArray].
	(mv at: 2) = (hv at: 2) ifTrue: [hv removeFirst.  mv remove: (mv at: 2).
		xx _ mv removeFirst.
		^ self setVertices: (hv, (Array with: xx), mv reversed) asArray].
	mv last = hv last ifTrue: [mv removeLast.  hv removeFirst.
		^ self setVertices: (mv, hv reversed) asArray].
	^ nil
! !

!PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'!
mergeDropThird: mv in: hv from: shared
	"We are merging two polygons.  In this case, they have at least three identical shared vertices.  Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared.  First vertices on lists are identical already."

	"know (mv first = hv first)"
	| mdrop vv |
	(shared includes: (mv at: mv size - 2)) 
		ifTrue: [(shared includes: (mv last)) ifTrue: [mdrop _ mv last]]
		ifFalse: [(shared includes: (mv last)) ifTrue: [
			(shared includes: (mv at: 2)) ifTrue: [mdrop _ mv first]]].
	(shared includes: (mv at: 3)) ifTrue: [
		(shared includes: (mv at: 2)) ifTrue: [mdrop _ mv at: 2]].
	mdrop ifNil: [^ nil].
	mv remove: mdrop.
	hv remove: mdrop.
	shared remove: mdrop.
	[shared includes: mv first] whileFalse: ["rotate them"
		vv _ mv removeFirst.
		mv addLast: vv].
	[mv first = hv first] whileFalse: ["rotate him until same shared vertex is first"
		vv _ hv removeFirst.
		hv addLast: vv].
! !


!PolygonMorph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:36'!
areasRemainingToFill: aRectangle
	"Could be improved by quick check of inner rectangle"

	^ Array with: aRectangle! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:09'!
drawArrowOn: aCanvas at: endPoint from: priorPoint 
	"Draw a triangle oriented along the line from priorPoint to  
	endPoint. Answer the wingBase."
	| pts spec wingBase |
	pts _ self arrowBoundsAt: endPoint from: priorPoint.
	wingBase _ pts size = 4 ifTrue: [ pts at: 3 ]
		ifFalse: [ (pts copyFrom: 2 to: 3) average ].
	spec _ self
				valueOfProperty: #arrowSpec
				ifAbsent: [5 @ 4].
	spec x sign = spec y sign
		ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor]
		ifFalse: [aCanvas
				drawPolygon: pts
				fillStyle: Color transparent
				borderWidth: borderWidth + 1 // 2
				borderColor: borderColor].
	^wingBase! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:00'!
drawArrowsOn: aCanvas 
	"Answer (possibly modified) endpoints for border drawing"
	"ArrowForms are computed only upon demand"
	| array |
	(closed
			or: [arrows == #none
					or: [vertices size < 2]])
		ifTrue: [^ self].
	"Nothing to do"
	borderColor isColor
		ifFalse: [^ self].
	array _ Array new: 2.
	"Prevent crashes for #raised or #inset borders"
	array at: 2 put: ((arrows == #forward
			or: [arrows == #both])
		ifTrue: [ self
				drawArrowOn: aCanvas
				at: vertices last
				from: self nextToLastPoint]
		ifFalse: [ vertices last ]).
	array at: 1 put: ((arrows == #back
			or: [arrows == #both])
		ifTrue: [self
				drawArrowOn: aCanvas
				at: vertices first
				from: self nextToFirstPoint]
		ifFalse: [ vertices first ]).
	^array! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:22'!
drawBorderOn: aCanvas 
	self
		drawBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 13:01'!
drawBorderOn: aCanvas usingEnds: anArray 
	"Display my border on the canvas."
	"NOTE: Much of this code is also copied in drawDashedBorderOn:  
	(should be factored)"
	| lineColor bevel topLeftColor bottomRightColor bigClipRect brush p1i p2i |
	borderDashSpec
		ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray].
	(borderColor == nil
			or: [borderColor isColor
					and: [borderColor isTransparent]])
		ifTrue: [^ self].
	lineColor _ borderColor.
	bevel _ false.
	"Border colors for bevelled effects depend on CW ordering of  
	vertices"
	borderColor == #raised
		ifTrue: [topLeftColor _ color lighter.
			bottomRightColor _ color darker.
			bevel _ true].
	borderColor == #inset
		ifTrue: [topLeftColor _ owner colorForInsets darker.
			bottomRightColor _ owner colorForInsets lighter.
			bevel _ true].
	bigClipRect _ aCanvas clipRect expandBy: self borderWidth + 1 // 2.
	brush _ nil.
	self
		lineSegmentsDo: [:p1 :p2 | 
			p1i _ p1 asIntegerPoint.
			p2i _ p2 asIntegerPoint.
			(arrows ~= #none
					and: [closed not])
				ifTrue: ["Shorten line ends so as not to interfere with tip  
					of arrow."
					((arrows == #back
								or: [arrows == #both])
							and: [p1 = vertices first])
						ifTrue: [p1i _ anArray first asIntegerPoint].
					((arrows == #forward
								or: [arrows == #both])
							and: [p2 = vertices last])
						ifTrue: [p2i _ anArray last asIntegerPoint]].
			(closed
					or: ["bigClipRect intersects: (p1i rect: p2i) optimized:"
						((p1i min: p2i)
							max: bigClipRect origin)
							<= ((p1i max: p2i)
									min: bigClipRect corner)])
				ifTrue: [bevel
						ifTrue: [(p1i quadrantOf: p2i)
									> 2
								ifTrue: [lineColor _ topLeftColor]
								ifFalse: [lineColor _ bottomRightColor]].
					(borderWidth > 3
							and: [borderColor isColor])
						ifTrue: [brush == nil
								ifTrue: [brush _ (ColorForm dotOfSize: borderWidth)
												colors: (Array with: Color transparent with: borderColor)].
							aCanvas
								line: p1i
								to: p2i
								brushForm: brush]
						ifFalse: [aCanvas
								line: p1i
								to: p2i
								width: borderWidth
								color: lineColor]]]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:23'!
drawDashedBorderOn: aCanvas 
	self
		drawDashedBorderOn: aCanvas
		usingEnds: (Array with: vertices first with: vertices last)! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:36'!
drawDashedBorderOn: aCanvas usingEnds: anArray 
	"Display my border on the canvas. NOTE: mostly copied from  
	drawBorderOn:"
	| lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset |
	(borderColor == nil
			or: [borderColor isColor
					and: [borderColor isTransparent]])
		ifTrue: [^ self].
	lineColor _ borderColor.
	bevel _ false.
	"Border colors for bevelled effects depend on CW ordering of  
	vertices"
	borderColor == #raised
		ifTrue: [topLeftColor _ color lighter.
			bottomRightColor _ color darker.
			bevel _ true].
	borderColor == #inset
		ifTrue: [topLeftColor _ owner colorForInsets darker.
			bottomRightColor _ owner colorForInsets lighter.
			bevel _ true].
	bigClipRect _ aCanvas clipRect expandBy: self borderWidth + 1 // 2.
	segmentOffset _ self borderDashOffset.
	self
		lineSegmentsDo: [:p1 :p2 | 
			p1i _ p1 asIntegerPoint.
			p2i _ p2 asIntegerPoint.
			(arrows ~= #none
					and: [closed not])
				ifTrue: ["Shorten line ends so as not to interfere with tip  
					of arrow."
					((arrows == #back
								or: [arrows == #both])
							and: [p1 = vertices first])
						ifTrue: [p1i _ anArray first asIntegerPoint].
					((arrows == #forward
								or: [arrows == #both])
							and: [p2 = vertices last])
						ifTrue: [p2i _ anArray last asIntegerPoint]].
			(closed
					or: ["bigClipRect intersects: (p1i rect: p2i) optimized:"
						((p1i min: p2i)
							max: bigClipRect origin)
							<= ((p1i max: p2i)
									min: bigClipRect corner)])
				ifTrue: [bevel
						ifTrue: [(p1i quadrantOf: p2i)
									> 2
								ifTrue: [lineColor _ topLeftColor]
								ifFalse: [lineColor _ bottomRightColor]].
					segmentOffset _ aCanvas
								line: p1i
								to: p2i
								width: borderWidth
								color: lineColor
								dashLength: borderDashSpec first
								secondColor: borderDashSpec third
								secondDashLength: borderDashSpec second
								startingOffset: segmentOffset]]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:07'!
drawOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	| array |
	vertices size < 1
		ifTrue: [self error: 'a polygon must have at least one point'].
	closed
		ifTrue: [aCanvas drawPolygon: self getVertices fillStyle: self fillStyle].
	array _ self drawArrowsOn: aCanvas.
	self drawBorderOn: aCanvas usingEnds: array.
! !

!PolygonMorph methodsFor: 'drawing'!
drawOnFormCanvas: aCanvas 
	"Display the receiver, a spline curve, approximated by straight line segments."

	| |
	vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point'].
	closed & color isTransparent not
		ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color].
	(borderColor isColor and: [borderColor isTranslucentColor])
		ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft
						color: borderColor]
		ifFalse: [self drawBorderOn: aCanvas].
	self arrowForms do:
		[:f | aCanvas stencil: f at: f offset
			color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! !

!PolygonMorph methodsFor: 'drawing' stamp: 'nk 10/4/2000 12:22'!
drawPostscriptOn: aCanvas 
	"Display the receiver, a spline curve, approximated by straight 
	line segments."
	| array |
	vertices size < 1
		ifTrue: [self error: 'a polygon must have at least one point'].
	array _ self drawArrowsOn: aCanvas.
	closed
		ifTrue: [aCanvas
				drawPolygon: self getVertices
				color: self color
				borderWidth: self borderWidth
				borderColor: self borderColor]
		ifFalse: [self drawBorderOn: aCanvas usingEnds: array].
! !


!PolygonMorph methodsFor: 'editing' stamp: 'ar 10/25/2000 17:50'!
addHandles
	| handle newVert tri |
	self removeHandles.
	handles _ OrderedCollection new.
	tri _ Array with: 0@-4 with: 4@3 with: -3@3.
	vertices withIndexDo:
		[:vertPt :vertIndex |
		handle _ EllipseMorph newBounds: (Rectangle center: vertPt extent: 8@8)
				color: Color yellow.
		handle on: #mouseMove send: #dragVertex:fromHandle:vertIndex:
				to: self withValue: vertIndex.
		handle on: #mouseUp send: #dropVertex:fromHandle:vertIndex:
				to: self withValue: vertIndex.
		self addMorph: handle.
		handles addLast: handle.
		(closed or: [vertIndex < vertices size]) ifTrue:
			[newVert _ PolygonMorph
					vertices: (tri collect: [:p | p + (vertPt + (vertices atWrap: vertIndex+1) // 2)])
					color: Color green borderWidth: 1 borderColor: Color black.
			newVert on: #mouseDown send: #newVertex:fromHandle:afterVert:
					to: self withValue: vertIndex.
			self addMorph: newVert.
			handles addLast: newVert]].
	smoothCurve ifTrue: [self updateHandles; layoutChanged].
	self changed! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:40'!
dragVertex: evt fromHandle: handle vertIndex: ix
	| p |
	p _ self isCurve
		ifTrue: [evt cursorPoint]
		ifFalse: [self griddedPoint: evt cursorPoint].
	handle position: p - (handle extent//2).
	self verticesAt: ix put: p.
! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 8/28/2000 15:08'!
dropVertex: evt fromHandle: handle vertIndex: ix
	| p |
	p _ vertices at: ix.
	(((vertices atWrap: ix-1) dist: p) < 3 or:
		[((vertices atWrap: ix+1) dist: p) < 3])
		ifTrue: ["Drag a vertex onto its neighbor means delete"
				self setVertices: (vertices copyReplaceFrom: ix to: ix with: Array new)].
	evt shiftPressed
		ifTrue: [self removeHandles]
		ifFalse: [self addHandles "remove then add to recreate"]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/19/2000 22:00'!
fillStyle

	self isOpen
		ifTrue: [^ self borderColor  "easy access to line color from halo"]
		ifFalse: [^ super fillStyle]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/19/2000 22:00'!
fillStyle: newColor

	self isOpen
		ifTrue: [^ self borderColor: newColor  "easy access to line color from halo"]
		ifFalse: [^ super fillStyle: newColor]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 8/20/2000 14:29'!
handlesMouseDown: evt

	^ (super handlesMouseDown: evt) or: [evt shiftPressed]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 09:56'!
justDroppedInto: newOwner event: evt

	| delta |
	(newOwner isKindOf: PasteUpMorph) ifTrue:
		["Compensate for border width so that gridded drop
			is consistent with gridded drag of handles."
		delta _ borderWidth+1//2.
		self position: (newOwner gridPoint: self position + delta) - delta].
	^ super justDroppedInto: newOwner event: evt! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 8/31/2000 17:58'!
mouseDown: evt

	^ evt shiftPressed
		ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self])
					ifTrue: ["Prevent insertion handles from getting edited"
							^ super mouseDown: evt].
				self toggleHandles.
				handles ifNil: [^ self].
				vertices withIndexDo:  "Check for click-to-drag at handle site"
					[:vertPt :vertIndex |
					((handles at: vertIndex*2-1) containsPoint: evt cursorPoint) ifTrue:
						["If clicked near a vertex, jump into drag-vertex action"
						evt hand newMouseFocus: (handles at: vertIndex*2-1)]]]
		ifFalse: [super mouseDown: evt]! !

!PolygonMorph methodsFor: 'editing' stamp: 'jm 6/3/1998 14:29'!
newVertex: evt fromHandle: handle afterVert: ix
	"Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events."

	| pt |
	pt _ evt cursorPoint.
	self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)).
	evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1).
! !

!PolygonMorph methodsFor: 'editing' stamp: 'nk 10/4/2000 12:56'!
updateHandles
	| newVert oldVert midPts nextVertIx tweens |
	smoothCurve
		ifTrue: [
			handles first center: vertices first.
			handles last center: vertices last.
			midPts _ OrderedCollection new.
			nextVertIx _ 2.
			tweens _ OrderedCollection new.
			self
				lineSegmentsDo: [:p1 :p2 | 
					tweens addLast: p2 asIntegerPoint.
					p2
							= (vertices atWrap: nextVertIx)
						ifTrue: ["Found endPoint."
							midPts addLast: (tweens at: tweens size // 2)
									+ (tweens at: tweens size + 1 // 2) // 2.
							tweens _ OrderedCollection new.
							nextVertIx _ nextVertIx + 1]].
			midPts
				withIndexDo: [:midPt :vertIndex | (closed
							or: [vertIndex < vertices size])
						ifTrue: [newVert _ handles at: vertIndex * 2.
							newVert position: midPt - (newVert extent // 2)]]]
		ifFalse: [vertices
				withIndexDo: [:vertPt :vertIndex | 
					oldVert _ handles at: vertIndex * 2 - 1.
					oldVert position: vertPt - (oldVert extent // 2).
					(closed
							or: [vertIndex < vertices size])
						ifTrue: [newVert _ handles at: vertIndex * 2.
							newVert position: vertPt
									+ (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]! !

!PolygonMorph methodsFor: 'editing' stamp: 'di 9/8/2000 10:39'!
verticesAt: ix put: newPoint
	vertices at: ix put: newPoint.
	self computeBounds! !


!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:17'!
addCustomMenuItems: aMenu hand: aHandMorph
	| lineName |
	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles.
	vertices size > 2 ifTrue:
		[aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed.
		lineName _ closed ifTrue: ['outline'] ifFalse: ['line'].
		self isCurve
			ifTrue: [aMenu add: 'make segmented ', lineName action: #toggleSmoothing]
			ifFalse: [aMenu add: 'make smooth ', lineName action: #toggleSmoothing]]. 
	aMenu add: 'specify dashed line' action:  #specifyDashedLine.

	self isOpen ifTrue:
		[aMenu addLine.
		aMenu addWithLabel: '---' enablement: [self isOpen and: [arrows ~~ #none]] action:  #makeNoArrows.
		aMenu addWithLabel: '-->' enablement: [self isOpen and: [arrows ~~ #forward]] action:  #makeForwardArrow.
		aMenu addWithLabel: '<--' enablement: [self isOpen and: [arrows ~~ #back]] action:  #makeBackArrow.
		aMenu addWithLabel: '<->' enablement: [self isOpen and: [arrows ~~ #both]] action:  #makeBothArrows.
		aMenu add: 'customize arrows' action: #customizeArrows:.
		(self hasProperty: #arrowSpec)
			ifTrue: [aMenu add: 'standard arrows' action: #standardArrows]].! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 09:09'!
arrowSpec: specPt
	"Specify a custom arrow for this line.
	specPt x abs gives the length of the arrow (point to base) in terms of borderWidth.
	If specPt x is negative, then the base of the arrow will be concave.
	specPt y abs gives the width of the arrow.
	The standard arrow is equivalent to arrowSpec: 5@4.
	See arrowBoundsAt:From: for details."

	self setProperty: #arrowSpec toValue: specPt.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'ar 10/3/2000 17:06'!
customizeArrows: evt
	| handle origin aHand |
	aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
	origin _ aHand position.
	handle _ HandleMorph new
		forEachPointDo:
			[:newPoint | handle removeAllMorphs.
			handle addMorph:
				(LineMorph from: origin to: newPoint color: Color black width: 1).
			self arrowSpec: (newPoint - origin) / 5.0]
		lastPointDo:
			[:newPoint | handle deleteBalloon.
			self halo doIfNotNil: [:halo | halo addHandles].].
	aHand attachMorph: handle.
	handle setProperty: #helpAtCenter toValue: true.
	handle showBalloon:
'Move cursor left and right
to change arrow length and style.
Move it up and down to change width.
Click when done.' hand: evt hand.
	handle startStepping! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'!
handlesShowingPhrase
	^ self showingHandles
		ifTrue:
			['hide handles']
		ifFalse:
			['show handles']! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeBackArrow
	arrows _ #back.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeBothArrows
	arrows _ #both.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'!
makeClosed
	closed _ true.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeForwardArrow
	arrows _ #forward.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'!
makeNoArrows
	arrows _ #none.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'!
makeOpen
	closed _ false.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 13:10'!
quickFill: ignored! !

!PolygonMorph methodsFor: 'menu' stamp: 'tk 9/2/97 16:04'!
removeHandles
	"tk 9/2/97 allow it to be called twice (when nil already)"

	handles ifNotNil: [
		handles do: [:h | h delete].
		handles _ nil].! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:16'!
showOrHideHandles
	self showingHandles
		ifTrue:	[self removeHandles]
		ifFalse:	[self addHandles]! !

!PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'!
showingHandles
	^ handles notNil! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/9/2000 11:38'!
specifyDashedLine

	| executableSpec newSpec |
	executableSpec _ FillInTheBlank
		request:
'Enter a dash specification as
{ major dash length. minor dash length. minor dash color }
The major dash will have the normal border color.
A blank response will remove the dash specification.
[Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3}
where the 4th ityem is zero, and the 5th is the number of pixels
by which the dashes will move in each step of animation]'
		initialAnswer: '{ 10. 5. Color red }'.
	executableSpec isEmpty ifTrue:
		[^ self stopStepping; dashedBorder: nil].
	newSpec _ [Compiler evaluate: executableSpec] ifError:
		[^ self stopStepping; dashedBorder: nil].
	newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse:
		[^ self stopStepping; dashedBorder: nil].
	newSpec size = 3 ifTrue:
		[^ self stopStepping; dashedBorder: newSpec].
	(newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue:
		[^ self dashedBorder: newSpec; startStepping].
! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:12'!
standardArrows

	self removeProperty: #arrowSpec.
	self computeBounds! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:31'!
toggleHandles

	handles ifNil: [self addHandles] ifNotNil: [self removeHandles].

! !

!PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 15:43'!
toggleSmoothing

	smoothCurve _ smoothCurve not.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !


!PolygonMorph methodsFor: 'private' stamp: 'di 10/3/2000 09:02'!
arrowBoundsAt: endPoint from: priorPoint 
	"Answer a triangle oriented along the line from priorPoint to endPoint."
	| d v angle wingBase arrowSpec length width |
	v _ endPoint - priorPoint.
	angle _ v degrees.
	d _ borderWidth max: 1.
	arrowSpec _ self valueOfProperty: #arrowSpec ifAbsent: [5@4].
	length _ arrowSpec x abs.  width _ arrowSpec y abs.
	wingBase _ endPoint + (Point r: d * length degrees: angle + 180.0).
	arrowSpec x >= 0
		ifTrue: [^ {	endPoint.
					wingBase + (Point r: d * width degrees: angle + 125.0).
					wingBase + (Point r: d * width degrees: angle - 125.0) }]
		ifFalse: ["Negative length means concave base."
				^ {	endPoint.
					wingBase + (Point r: d * width degrees: angle + 125.0).
					wingBase.
					wingBase + (Point r: d * width degrees: angle - 125.0) }]! !

!PolygonMorph methodsFor: 'private' stamp: 'di 12/17/1998 12:31'!
arrowForms
	"ArrowForms are computed only upon demand"
	arrowForms ifNotNil: [^ arrowForms].

	arrowForms _ Array new.
	(closed or: [arrows == #none or: [vertices size < 2]]) ifTrue:
		[^ arrowForms].
	(arrows == #forward or: [arrows == #both]) ifTrue:
		[arrowForms _ arrowForms copyWith:
			(self computeArrowFormAt: vertices last from: self nextToLastPoint)].
	(arrows == #back or: [arrows == #both]) ifTrue:
		[arrowForms _ arrowForms copyWith:
			(self computeArrowFormAt: vertices first from: self nextToFirstPoint)].
	^ arrowForms! !

!PolygonMorph methodsFor: 'private' stamp: 'ar 5/25/2000 18:04'!
borderForm
	"A form must be created for drawing the border whenever the borderColor is translucent."

	| borderCanvas |
	borderForm ifNotNil: [^ borderForm].
	borderCanvas _ (Display defaultCanvasClass extent: bounds extent depth: 1)
		shadowColor: Color black.
	borderCanvas translateBy: bounds topLeft negated
		during:[:tempCanvas| self drawBorderOn: tempCanvas].
	borderForm _ borderCanvas form.
	self arrowForms do:
		[:f |  "Eliminate overlap between line and arrowheads if transparent."
		borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase].
	^ borderForm! !

!PolygonMorph methodsFor: 'private' stamp: 'nk 9/2/2000 11:09'!
computeArrowFormAt: endPoint from: priorPoint 
	"Compute a triangle oriented along the line from priorPoint to  
	endPoint. Then draw those lines in a form and return that  
	form, with appropriate offset"
	| p1 pts box arrowForm bb origin  |
	pts _ self arrowBoundsAt: endPoint from: priorPoint.
	box _ ((pts first rect: pts last)
				encompass: (pts at: 2))
				expandBy: 1.
	arrowForm _ Form extent: box extent asIntegerPoint.
	bb _ (BitBlt current toForm: arrowForm) sourceForm: nil;
				 fillColor: Color black;
				 combinationRule: Form over;
				 width: 1;
				 height: 1.
	origin _ box topLeft.
	p1 _ pts last - origin.
	pts
		do: [:p | 
			bb drawFrom: p1 to: p - origin.
			p1 _ p - origin].
	arrowForm convexShapeFill: Color black.
	^ arrowForm offset: box topLeft! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/8/2000 09:44'!
computeBounds
	vertices ifNil: [^ self].
	self changed.
	self releaseCachedState.
	bounds _ self curveBounds.
	self arrowForms do:
		[:f | bounds _ bounds merge: (f offset extent: f extent)].
	handles ifNotNil: [self updateHandles].
	self layoutChanged.
	self changed! !

!PolygonMorph methodsFor: 'private' stamp: 'sw 9/14/97 18:22'!
copyRecordingIn: dict
	"Copy the vertices array.  Give each one its own handles, and in the handles array."

	| new hadHandles |
	hadHandles _ handles ifNil: [false] ifNotNil: [self removeHandles. true].
	new _ super copyRecordingIn: dict.
	new setVertices: vertices copy.
	hadHandles ifTrue: [self addHandles.  new addHandles].
	^ new! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/9/2000 13:07'!
curveBounds

	| curveBounds pointAfterFirst pointBeforeLast |
	smoothCurve ifFalse: [^ (Rectangle encompassing: vertices) expandBy: borderWidth+1//2].

	"Compute the bounds from actual curve traversal, with leeway for borderWidth.
	Also note the next-to-first and next-to-last points for arrow directions."

	curveState _ nil.  "Force recomputation"
	curveBounds _ vertices first corner: vertices last.
	pointAfterFirst _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | pointAfterFirst == nil ifTrue: [pointAfterFirst _ p2 asIntegerPoint].
		curveBounds _ curveBounds encompass: p2 asIntegerPoint.
		pointBeforeLast _ p1 asIntegerPoint].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast.
	^ curveBounds expandBy: borderWidth+1//2! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 13:30'!
filledForm
	"Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form.  This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside.  Computation of the filled form is done only on demand."
	| bb origin |
	closed ifFalse: [^ filledForm _ nil].
	filledForm ifNotNil: [^ filledForm].
	filledForm _ Form extent: bounds extent+2.

	"Draw the border..."
	bb _ (BitBlt current toForm: filledForm) sourceForm: nil; fillColor: Color black;
			combinationRule: Form over; width: 1; height: 1.
	origin _ bounds topLeft asIntegerPoint-1.
	self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 asIntegerPoint-origin
										to: p2 asIntegerPoint-origin].

	"Fill it in..."
	filledForm convexShapeFill: Color black.

	(borderColor isColor and: [borderColor isTranslucentColor]) ifTrue:
		["If border is stored as a form, then erase any overlap now."
		filledForm copy: self borderForm boundingBox from: self borderForm
			to: 1@1 rule: Form erase].

	^ filledForm! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/7/2000 16:17'!
getVertices

	smoothCurve ifFalse: [^ vertices].

	"For curves, enumerate the full set of interpolated points"
	^ Array streamContents:
		[:s | self lineSegmentsDo: [:pt1 :pt2 | s nextPut: pt1]]! !

!PolygonMorph methodsFor: 'private' stamp: 'di 8/31/2000 13:46'!
includesHandle: aMorph

	handles ifNil: [^ false].
	^ handles includes: aMorph! !

!PolygonMorph methodsFor: 'private' stamp: 'di 11/21/97 21:29'!
lineSegments
	| lineSegments |
	lineSegments _ OrderedCollection new.
	self lineSegmentsDo: [:p1 :p2 | lineSegments addLast: (Array with: p1 with: p2)].
	^ lineSegments! !

!PolygonMorph methodsFor: 'private' stamp: 'di 11/13/97 15:16'!
loadCachedState
	"Prepare for fast response -- next page of a book?"
	self filledForm.
	self arrowForms! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/24/2000 08:38'!
privateMoveBy: delta
	super privateMoveBy: delta.
	vertices _ vertices collect: [:p | p + delta].
	self arrowForms do: [:f | f offset: f offset + delta].
	curveState _ nil.  "Force recomputation"
	(self valueOfProperty: #referencePosition) doIfNotNil:
		[:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/4/2000 13:36'!
releaseCachedState
	super releaseCachedState.
	filledForm _ nil.
	arrowForms _ nil.
	borderForm _ nil.
	curveState _ nil.
	(self hasProperty: #flex) ifTrue:
		[self removeProperty: #unflexedVertices;
			removeProperty: #flex].
! !

!PolygonMorph methodsFor: 'private' stamp: 'di 9/8/2000 10:36'!
setVertices: newVertices
	vertices _ newVertices.
	handles ifNotNil: [self removeHandles; addHandles].
	self computeBounds! !


!PolygonMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:48'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	smoothCurve ifNil: [smoothCurve _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!PolygonMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:18'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^true! !

!PolygonMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:17'!
defaultColor
	"Return the default fill style for the receiver"
	^Color orange! !


!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/9/2000 13:24'!
coefficients
	"Compute an array for the coefficients.  This is copied from Flegal's old
	code in the Spline class."
	| length extras verts coefficients |
	curveState ifNotNil: [^ curveState at: 1].
	verts _ closed ifTrue: [vertices copyWith: vertices first]
				ifFalse: [vertices].
	length _ verts size.
	extras _ 0.
	coefficients _ Array new: 8.
	1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)].
	1 to: 5 by: 4 do: 
		[:k | 
		1 to: length do:
			[:i | (coefficients at: k)
					at: i put: (k = 1
						ifTrue: [(verts at: i) x asFloat]
						ifFalse: [(verts at: i) y asFloat])].
			1 to: extras do: [:i | (coefficients at: k)
					at: length + i put: ((coefficients at: k)
						at: i + 1)].
			self derivs: (coefficients at: k)
				first: (coefficients at: k + 1)
				second: (coefficients at: k + 2)
				third: (coefficients at: k + 3)].
	extras > 0 
		ifTrue: [1 to: 8 do: 
					[:i | 
					coefficients at: i put: ((coefficients at: i)
											copyFrom: 2 to: length + 1)]].
	curveState _ {coefficients. nil. nil}.
	self computeNextToEndPoints.
	^ coefficients
! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/9/2000 13:23'!
computeNextToEndPoints

	| pointAfterFirst pointBeforeLast |
	pointAfterFirst _ nil.
	self lineSegmentsDo:
		[:p1 :p2 | pointAfterFirst == nil ifTrue: [pointAfterFirst _ p2 asIntegerPoint].
		pointBeforeLast _ p1 asIntegerPoint].
	curveState at: 2 put: pointAfterFirst.
	curveState at: 3 put: pointBeforeLast.
! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/7/2000 16:14'!
derivs: a first: point1 second: point2 third: point3
	"Compute the first, second and third derivitives (in coeffs) from
	the Points in this Path (coeffs at: 1 and coeffs at: 5)."
	| len v anArray |
	len _ a size.
	len < 2 ifTrue: [^self].
	len > 2 ifTrue:
		[v _ Array new: len.
		 v  at: 1 put: 4.0.
		 anArray _ Array new: len.
		 anArray at: 1 put: (6.0 * ((a at: 1) - ((a at: 2) * 2.0) + (a at: 3))).
		 2 to: len - 2 do:
			[:i | 
			v  at: i put: (4.0 - (1.0 / (v at: i-1))).
			anArray at: i 
				put: (6.0 * ((a at: i) - ((a at: i+1) * 2.0) + (a at: i+2))
						- ((anArray at: i-1) / (v at: i-1)))].
		 point2 at: len-1 put: ((anArray at: len-2) / (v at: len-2)).
		 len - 2 to: 2 by: 0-1 do: 
			[:i | 
			point2 at: i 
				put: ((anArray at: i-1) - (point2 at: i+1) / (v at: i-1))]].
	point2 at: 1 put: (point2 at: len put: 0.0).
	1 to: len - 1 do:
		[:i | point1 at: i 
				put: ((a at: i+1) - (a at: i) - 
						((point2 at: i) * 2.0 + (point2 at: i+1) / 6.0)).
		      point3 at: i put: ((point2 at: i+1) - (point2 at: i))]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/7/2000 16:43'!
lineSegmentsDo: endPointsBlock
	"Emit a sequence of segment endpoints into endPointsBlock."
	| n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint cs |
	smoothCurve ifFalse:
		[beginPoint _ nil.
		vertices do:
			[:vert | beginPoint ifNotNil:
				[endPointsBlock value: beginPoint
								value: vert].
			beginPoint _ vert].
		(closed or: [vertices size = 1])
			ifTrue: [endPointsBlock value: beginPoint
									value: vertices first].
		^ self].

	"For curves we include all the interpolated sub segments."
	vertices size < 1 ifTrue: [^ self].
	cs _ self coefficients.
	beginPoint _ (x _ (cs at: 1) at: 1) @ (y _ (cs at: 5) at: 1).
	1 to: (cs at: 1) size - 1 do: 
		[:i |  "taylor series coefficients"
		x1 _ (cs at: 2) at: i.
		y1 _ (cs at: 6) at: i.
		x2 _ ((cs at: 3) at: i) / 2.0.
		y2 _ ((cs at: 7) at: i) / 2.0.
		x3 _ ((cs at: 4) at: i) / 6.0.
		y3 _ ((cs at: 8) at: i) / 6.0.
		"guess n"
		n _ 5 max: (x2 abs + y2 abs * 2.0 + ((cs at: 3) at: i+1) abs
									+ ((cs at: 7) at: i+1) abs / 100.0) rounded.
		1 to: n - 1 do: 
			[:j | 
			t _ j asFloat / n.
			endPoint _ (x3 * t + x2 * t + x1 * t + x) @ (y3 * t + y2 * t + y1 * t + y).
			endPointsBlock value: beginPoint
							value: endPoint.
			beginPoint _ endPoint].
		endPoint _ (x _ (cs at: 1) at: i+1) @ (y _ (cs at: 5) at: i+1).
		endPointsBlock value: beginPoint
						value: endPoint.
		beginPoint _ endPoint]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/9/2000 13:25'!
nextToFirstPoint  "For arrow direction"
	smoothCurve
		ifTrue: [curveState ifNil: [self coefficients].
				^ curveState at: 2]
		ifFalse: [^ vertices at: 2]! !

!PolygonMorph methodsFor: 'smoothing' stamp: 'di 9/9/2000 13:24'!
nextToLastPoint  "For arrow direction"
	smoothCurve
		ifTrue: [curveState ifNil: [self coefficients].
				^ curveState at: 3]
		ifFalse: [^ vertices at: vertices size - 1]! !


!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:22'!
borderDashOffset

	borderDashSpec size < 4 ifTrue: [^ 0.0].
	^ (borderDashSpec at: 4) asFloat! !

!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:20'!
dashedBorder: dashSpec
	"A dash spec is a 3- or 5-element array with
		{ length of normal border color.
		length of alternate border color.
		alternate border color.
		starting offset.
		amount to add to offset at each step }
	Starting offset is usually = 0, but changing it moves the dashes along the curve."

	borderDashSpec _ dashSpec.
	self changed! !

!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/25/2000 11:26'!
step

	borderDashSpec ifNil: [^ super step].
	borderDashSpec size < 5 ifTrue: [^ super step].

	"Only for dashed lines with creep"
	borderDashSpec at: 4 put: (borderDashSpec at: 4) + (borderDashSpec at: 5).
	self changed.
	^ super step! !

!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/9/2000 09:24'!
stepTime

	^ 100! !

!PolygonMorph methodsFor: 'dashes' stamp: 'di 9/11/2000 12:32'!
wantsSteps

	super wantsSteps ifTrue: [^ true].

	"For crawling ants effect of dashed line."
	borderDashSpec ifNil: [^ false].
	^ borderDashSpec size = 5 and: [(borderDashSpec at: 5) > 0]! !


!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/23/2000 16:53'!
addFlexShell

	^ self
! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:35'!
heading
	"Return the receiver's heading (in eToy terms)"
	^ self forwardDirection! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:36'!
heading: newHeading
	"Set the receiver's heading (in eToy terms).
	Note that polygons never use flex shells."
	self rotationDegrees: newHeading.! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 08:38'!
referencePosition 
	"Return the current reference position of the receiver"
	^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition]
! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:21'!
rotationCenter
	"Return the rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| refPos |
	refPos _ self valueOfProperty: #referencePosition
		ifAbsent: [^ 0.5@0.5].
	^ (refPos - self bounds origin) / self bounds extent asFloatPoint! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:31'!
rotationCenter: aPointOrNil
	"Set the new rotation center of the receiver. The rotation center defines the relative offset inside the receiver's bounds for locating the reference position."
	| box |
	aPointOrNil isNil
		ifTrue: [self removeProperty: #referencePosition]
		ifFalse: [box _ self bounds.
				self setProperty: #referencePosition
					toValue: box origin + (aPointOrNil * box extent)]
! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 08:42'!
rotationDegrees

	^ self forwardDirection! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:42'!
rotationDegrees: degrees 
	| flex center |
	(center _ self valueOfProperty: #referencePosition) ifNil:
		[self setProperty: #referencePosition toValue: (center _ self bounds center)].
	flex _ (MorphicTransform offset: center negated)
			withAngle: (degrees - self forwardDirection) degreesToRadians.
	self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]).
	self forwardDirection: degrees.

! !

!PolygonMorph methodsFor: 'halo control' stamp: 'di 9/24/2000 09:25'!
setRotationCenterFrom: aPoint
	"Polygons store their referencePosition."
	self setProperty: #referencePosition toValue: aPoint! !

!PolygonMorph methodsFor: 'halo control' stamp: 'ar 10/6/2000 15:40'!
transformedBy: aTransform
	self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PolygonMorph class
	instanceVariableNames: ''!

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/9/2000 11:41'!
shapeFromPen: penBlock color: c borderWidth: bw borderColor: bc
	"World addMorph: (PolygonMorph
		shapeFromPen: [:p | p hilbert: 4 side: 5. p go: 5.
						p hilbert: 4 side: 5. p go: 5]
		color: Color red borderWidth: 1 borderColor: Color black)"

	| pen |
	penBlock value: (pen _ PenPointRecorder new).
	^ (self vertices: pen points asArray color: c borderWidth: bw borderColor: bc)
		quickFill: false! !

!PolygonMorph class methodsFor: 'instance creation' stamp: 'di 9/7/2000 17:05'!
vertices: verts color: c borderWidth: bw borderColor: bc
	^ self basicNew beStraightSegments vertices: verts color: c borderWidth: bw borderColor: bc! !
StringMorph subclass: #PopUpChoiceMorph
	instanceVariableNames: 'target actionSelector arguments getItemsSelector getItemsArgs choiceSelector choiceArgs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!PopUpChoiceMorph methodsFor: 'copying' stamp: 'di 3/24/1999 09:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
getItemsArgs _ getItemsArgs collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
choiceArgs ifNotNil: [choiceArgs _ choiceArgs collect: [:each |
	deepCopier references at: each ifAbsent: [each]]].! !

!PopUpChoiceMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:43'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
"getItemsSelector _ getItemsSelector.		a Symbol"
"getItemsArgs _ getItemsArgs.		All weakly copied"
"choiceSelector _ choiceSelector.		a Symbol"
choiceArgs _ choiceArgs.		"All weakly copied"
     ! !


!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
actionSelector

	^ actionSelector
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
arguments

	^ arguments
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'!
getItemsArgs

	^ getItemsArgs
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:33'!
getItemsArgs: aCollection

	getItemsArgs _ aCollection asArray copy.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'!
getItemsSelector

	^ getItemsSelector
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:32'!
getItemsSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ getItemsSelector _ nil].

	getItemsSelector _ aSymbolOrString asSymbol.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:20'!
handlesMouseDown: evt

	^ true
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:23'!
initialize

	super initialize.
	self contents: 'PopUpChoice of Colors'.
	target _ Color.
	actionSelector _ nil.
	arguments _ EmptyArray.
	getItemsSelector _ #colorNames.
	getItemsArgs _ EmptyArray.
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'di 2/3/98 19:36'!
mouseDown: evt

	| items menu selectedItem |
	(target == nil or: [getItemsSelector == nil]) ifTrue: [^ self].
	items _ target perform: getItemsSelector withArguments: getItemsArgs.
	menu _ CustomMenu new.
	items do: [:item | menu add: item action: item].
	selectedItem _ menu startUp.
	selectedItem ifNil: [^ self].
	self contentsClipped: selectedItem.  "Client can override this if necess"
	actionSelector ifNotNil: [
		target
			perform: actionSelector
			withArguments: (arguments copyWith: selectedItem)].
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
target

	^ target
! !

!PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/2/98 00:05'!
target: anObject

	target _ anObject
! !
Object subclass: #PopUpMenu
	instanceVariableNames: 'labelString font lineArray frame form marker selection '
	classVariableNames: 'CacheMenuForms MenuStyle '
	poolDictionaries: ''
	category: 'Tools-Menus'!
!PopUpMenu commentStamp: '<historical>' prior: 0!
I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.!


!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:44'!
center
	"Answer the point at the center of the receiver's rectangular area."

	^ frame center! !

!PopUpMenu methodsFor: 'accessing' stamp: 'di 4/20/1999 14:33'!
frameHeight
	"Designed to avoid the entire frame computation (includes MVC form),
	since the menu may well end up being displayed in Morphic anyway."
	| nItems |
	frame ifNotNil: [^ frame height].
	nItems _ 1 + (labelString occurrencesOf: Character cr).
	^ (nItems * MenuStyle lineGrid) + 4 "border width"! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'!
labelString
	^ labelString! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'!
lineArray
	^ lineArray! !

!PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 12:32'!
nItems
	^ (labelString occurrencesOf: Character cr) + 1! !


!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 13:04'!
controlActivity
	"Do whatever a menu must do - now with keyboard support."

	| didNotMove downPos |
	didNotMove _ true.
	Sensor anyButtonPressed
		ifFalse:
			[didNotMove _ false.
			Sensor waitButtonOrKeyboard]. 
	
	Sensor keyboardPressed ifFalse: [self manageMarker].
	(didNotMove and: [selection = 0])
		ifTrue:
			[downPos _ Sensor cursorPoint.
			[didNotMove and: [Sensor anyButtonPressed]]
				whileTrue:
					[(downPos dist: Sensor cursorPoint) < 2 ifFalse: [didNotMove _ false]].
			didNotMove ifTrue: [Sensor waitButtonOrKeyboard]].

	[Sensor keyboardPressed] whileTrue:
		[self readKeyboard ifTrue: [^ self].
		Sensor waitButtonOrKeyboard].

	[Sensor anyButtonPressed] whileTrue: [self manageMarker]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 10:55'!
readKeyboard
	"Keyboard support for menus. ESC will abort the menu, Space or CR
	will select an item. Cursor up and cursor down will change the
	selection. Any other key will either select an item whose label starts
	with that character or select the next matching label.
	Answer true if the menu should be closed and false otherwise."

	| ch labels occurences |
	ch _ Sensor keyboard asciiValue.
	(ch = 13 or: [ch = 32]) ifTrue: [^ true].
	ch = 27 ifTrue: [self setSelection: 0. ^ true].
	ch = 30
		ifTrue:
			[self setSelection: (selection <= 1
				ifTrue: [self nItems]
				ifFalse: [selection - 1])].
	ch = 31 ifTrue: [self setSelection: selection \\ self nItems + 1].
	ch _ ch asCharacter asLowercase.
	labels _ labelString findTokens: Character cr asString.
	occurences _ 0.
	1 + selection to: selection + labels size do:
		[:index |
		| i | i _ index - 1 \\ labels size + 1.
		(labels at: i) withBlanksTrimmed first asLowercase = ch
			ifTrue: [(occurences _ occurences + 1) = 1 ifTrue: [self setSelection: i]]].
	^ occurences = 1! !

!PopUpMenu methodsFor: 'basic control sequence'!
startUp
	"Display and make a selection from the receiver as long as the button 
	is pressed. Answer the current selection."
	
	^ self startUpWithCaption: nil! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'RAA 5/25/2000 09:29'!
startUpCenteredWithCaption: captionOrNil
	"Differs from startUpWithCaption: by appearing with cursor in the menu,
	and thus ready to act on mouseUp, without requiring user tweak to confirm"

	| cursorPoint |
	cursorPoint _ Display lastKnownCursorPoint.
	^ self startUpWithCaption: captionOrNil at: cursorPoint - (20@0)! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'JDD 8/8/1999
13:05'!
startUpSegmented: segmentHeight withCaption: captionOrNil at: location
	"This menu is too big to fit comfortably on the screen.
	Break it up into smaller chunks, and manage the relative indices.
	Inspired by a special-case solution by Reinier van Loon."
"
(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
		lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
"
	| nLines nLinesPer allLabels from to subset subLines index |
	frame ifNil: [self computeForm].
	allLabels := labelString findTokens: Character cr asString.
	nLines _ allLabels size.
	lineArray ifNil: [lineArray _ Array new].
	nLinesPer _ segmentHeight // marker height - 3.
	from := 1.
	[ true ] whileTrue:
		[to := (from + nLinesPer) min: nLines.
		subset := allLabels copyFrom: from to: to.
		subset add: (to = nLines ifTrue: ['start over...'] ifFalse: ['more...'])
			before: subset first.
		subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
		subLines _ (Array with: 1) , subLines.
		index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
					startUpWithCaption: captionOrNil at: location.
		index = 1
			ifTrue: [from := to + 1.
					from > nLines ifTrue: [ from := 1 ]]
			ifFalse: [index = 0 ifTrue: [^ 0].
					^ from + index - 2]]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'RAA 5/25/2000 09:29'!
startUpWithCaption: captionOrNil
	"Display the menu, slightly offset from the cursor,
	so that a slight tweak is required to confirm any action."

	^ self startUpWithCaption: captionOrNil at: Display lastKnownCursorPoint! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'RAA 6/6/2000 17:38'!
startUpWithCaption: captionOrNil at: location
	"Display the menu, with caption if supplied. Wait for the mouse button to go down,
	then track the selection as long as the button is pressed. When the button is released, 
	answer the index of the current selection, or zero if the mouse is not released over 
	any menu item. Location specifies the desired topLeft of the menu body rectangle."

	| maxHeight |
	maxHeight _ Display height*3//4.
	self frameHeight > maxHeight ifTrue:
		[^ self
			startUpSegmented: maxHeight
			withCaption: captionOrNil
			at: location].

	Smalltalk isMorphic
		ifTrue:
			[selection _ Cursor normal showWhile:
				[(MVCMenuMorph from: self title: captionOrNil) 
					invokeAt: location 
					in: (Display morphicWorldAt: location)].
			^ selection].

	frame ifNil: [self computeForm].
	Cursor normal showWhile:
		[self
			displayAt: location
			withCaption: captionOrNil
			during: [self controlActivity]].
	^ selection! !


!PopUpMenu methodsFor: 'displaying' stamp: 'sw 12/10/1999 09:55'!
displayAt: aPoint withCaption: captionOrNil during: aBlock
	"Display the receiver just to the right of aPoint while aBlock is evaluated.  If the receiver is forced off screen, display it just to the right."
	| delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox |
	marker ifNil: [self computeForm].
	frame _ frame align: marker leftCenter with: aPoint + (2@0).
	outerFrame _ frame.
	captionOrNil notNil ifTrue:
		[captionText _ (DisplayText
				text: captionOrNil asText
				textStyle: MenuStyle copy centered)
					foregroundColor: Color black
					backgroundColor: Color white.
		tFrame _ captionText boundingBox insetBy: -2.
		outerFrame _ frame merge: (tFrame align: tFrame bottomCenter
					with: frame topCenter + (0@2))].
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	frame right > Display boundingBox right
		ifTrue: [delta _ 0 - frame width @ delta y].
	frame _ frame translateBy: delta.
	captionOrNil notNil ifTrue:
		[captionForm _ captionText form.
		captionBox _ captionForm boundingBox expandBy: 4.
		captionBox _ captionBox align: captionBox bottomCenter
								with: frame topCenter + (0@2).
		captionSave _ Form fromDisplay: captionBox.
		Display border: captionBox width: 4 fillColor: Color white.
		Display border: captionBox width: 2 fillColor: Color black.
		captionForm displayAt: captionBox topLeft + 4].
	marker _ marker align: marker leftCenter with: aPoint + delta +  (2@0).
	savedArea _ Form fromDisplay: frame.
	self menuForm displayOn: Display at: (frameSaveLoc _ frame topLeft).
	selection ~= 0 ifTrue: [Display reverse: marker].
	Cursor normal showWhile: [aBlock value].
	savedArea displayOn: Display at: frameSaveLoc.
	captionOrNil notNil ifTrue:
		[captionSave displayOn: Display at: captionBox topLeft]! !


!PopUpMenu methodsFor: 'marker adjustment' stamp: 'di 4/13/1999 17:42'!
manageMarker
	"If the cursor is inside the receiver's frame, then highlight the marked 
	item. Otherwise no item is to be marked."
	| pt |
	"Don't let pt get far from display box, so scrolling will go all the way"
	pt _ Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1).
	(frame inside containsPoint: pt)
		ifTrue: ["Need to cache the form for reasonable scrolling performance"
				((Display boundingBox insetBy: 0@3) containsPoint: pt)
					ifFalse: [pt _ pt - (self scrollIntoView: pt)].
				self markerOn: pt]
		ifFalse: [self markerOff]! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 5/28/2000 15:27'!
markerOff
	"No item is selected. Reverse the highlight if any item has been marked 
	as selected."

	self setSelection: 0! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 6/1/2000 13:01'!
markerOn: aPoint 
	"The item whose bounding area contains aPoint should be marked as 
	selected. Highlight its area and set the selection to its index."

	selection = 0 | (marker containsPoint: aPoint) not 
		ifTrue: [selection = 0 & (marker containsPoint: aPoint)
					ifTrue: [Display reverse: marker]
					ifFalse: 
						[selection > 0 ifTrue: [Display reverse: marker].
						marker _ 
							marker 
								align: marker topLeft 
								with: marker left @ (self markerTop: aPoint).
						Display reverse: marker]].
	selection _ marker top - frame top // marker height + 1! !

!PopUpMenu methodsFor: 'marker adjustment'!
markerTop: aPoint 
	"Answer aPoint, gridded to lines in the receiver."

	^(aPoint y - frame inside top truncateTo: font height) + frame inside top! !

!PopUpMenu methodsFor: 'marker adjustment' stamp: 'di 3/9/98 19:46'!
scrollIntoView: cursorLoc
	| dy |
	dy _ 0.
	cursorLoc y < 2 ifTrue: [dy _ font height].
	cursorLoc y > (Display height-3) ifTrue: [dy _ font height negated].
	dy = 0 ifTrue: [^ 0@0].
	self markerOff.
	frame _ frame translateBy: 0@dy.
	marker _ marker translateBy: 0@dy.
	self menuForm displayOn: Display at: frame topLeft.
	^ 0@dy! !


!PopUpMenu methodsFor: 'private' stamp: 'sma 6/1/2000 12:59'!
computeForm
	"Compute and answer a Form to be displayed for this menu."

	| borderInset paraForm menuForm inside |
	borderInset _ 4@4.
	paraForm _ (DisplayText text: labelString asText textStyle: MenuStyle) form.
	menuForm _ Form extent: paraForm extent + (borderInset * 2).
	menuForm borderWidth: 2.
	paraForm displayOn: menuForm at: borderInset.
	lineArray == nil ifFalse:
		[lineArray do:
			[ :line |
			menuForm fillBlack: (4 @ ((line * font height) + borderInset y)
				extent: (menuForm width - 8 @ 1))]].

	frame _ Quadrangle new.
	frame region: menuForm boundingBox.
	frame borderWidth: 4.
	inside _ frame inside.
	marker _ inside topLeft extent: (inside width @ MenuStyle lineGrid).
	selection _ 1.

	^ form _ menuForm
! !

!PopUpMenu methodsFor: 'private'!
computeLabelParagraph
	"Answer a Paragraph containing this menu's labels, one per line and centered."

	^ Paragraph withText: labelString asText style: MenuStyle! !

!PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 16:21'!
labels: aString font: aFont lines: anArray

	labelString _ aString.
	font _ aFont.
	lineArray _ anArray.
! !

!PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 17:51'!
menuForm
	"Answer a Form to be displayed for this menu."

	form == nil ifTrue: [self computeForm].
	^ form! !

!PopUpMenu methodsFor: 'private' stamp: 'sma 2/5/2000 11:56'!
rescan
	"Cause my form to be recomputed after a font change."

	labelString == nil ifTrue: [labelString _ 'NoText!!'].
	self labels: labelString font: (MenuStyle fontAt: 1) lines: lineArray.
	frame _ marker _ form _ nil.

	"PopUpMenu allSubInstancesDo: [:m | m rescan]"! !


!PopUpMenu methodsFor: 'selecting' stamp: 'sma 5/28/2000 12:27'!
selection
	"Answer the current selection."

	^ selection! !

!PopUpMenu methodsFor: 'selecting' stamp: 'sma 6/1/2000 11:01'!
setSelection: index
	| newSelection |
	selection = index ifTrue: [^ self].
	newSelection _ (0 max: index) min: frame height // marker height.
	selection > 0 ifTrue: [Display reverse: marker].
	marker _ marker translateBy: 0 @ (newSelection - selection * marker height).
	selection _ newSelection.
	selection > 0 ifTrue: [Display reverse: marker]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PopUpMenu class
	instanceVariableNames: ''!

!PopUpMenu class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 13:08'!
initialize  "PopUpMenu initialize"
	(MenuStyle _ TextStyle default copy)
		gridForFont: TextStyle default defaultFontIndex withLead: 0;
		centered.
	PopUpMenu allSubInstancesDo: [:m | m rescan]! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'sw 12/10/1999 11:38'!
setMenuFontTo: aFont
	MenuStyle _ aFont textStyle copy consistOnlyOf: aFont.
	MenuStyle 
		gridForFont: 1 withLead: 0;
		centered.
	self allSubInstancesDo: [:m | m rescan].
	Utilities replaceMenuFlap! !


!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:44'!
labelArray: labelArray
	"Answer an instance of me whose items are in labelArray."

	^ self labelArray: labelArray lines: nil! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:43'!
labelArray: labelArray lines: lineArray
	"Answer an instance of me whose items are in labelArray, with lines 
	drawn after each item indexed by anArray. 2/1/96 sw"

	labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size'].
	^ self
		labels: (String streamContents: 
			[:stream |
			labelArray do: [:each | stream nextPutAll: each; cr].
			stream skip: -1 "remove last CR"])
		lines: lineArray

"Example:
	(PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:36'!
labels: aString
	"Answer an instance of me whose items are in aString."

	^ self labels: aString lines: nil! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 17:55'!
labels: aString lines: anArray
	"Answer an instance of me whose items are in aString, with lines drawn 
	after each item indexed by anArray."

	^ self new
		labels: aString
		font: MenuStyle defaultFont
		lines: anArray! !

!PopUpMenu class methodsFor: 'instance creation' stamp: 'tk 7/12/2000 17:29'!
withCaption: cap chooseFrom: labels
	"Simply put up a menu.  Get the args in the right order with the caption first.  labels may be either an array of items or a string with CRs in it.  May use backslashes for returns."

	(labels isKindOf: String) 
		ifTrue: [^ (self labels: labels withCRs lines: nil) startUpWithCaption: cap withCRs]
		ifFalse: [^ (self labelArray: labels lines: nil) startUpWithCaption: cap withCRs]! !


!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:48'!
confirm: queryString
	"Put up a yes/no menu with caption queryString. Answer true if the 
	response is yes, false if no. This is a modal question--the user must 
	respond yes or no."

	"PopUpMenu confirm: 'Are you hungry?'"

	^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No'! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 6/5/2000 09:11'!
confirm: queryString orCancel: cancelBlock
	"Put up a yes/no/cancel menu with caption aString. Answer true if  
	the response is yes, false if no. If cancel is chosen, evaluate  
	cancelBlock. This is a modal question--the user must respond yes or no."

	"PopUpMenu confirm: 'Reboot universe' orCancel: [^'Nevermind']"

	| menu choice |
	menu _ PopUpMenu labelArray: {'Yes'. 'No'. 'Cancel'}.
	choice _ menu startUpWithCaption: queryString.
	choice = 1 ifTrue: [^ true].
	choice = 2 ifTrue: [^ false].
	^ cancelBlock value! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 6/5/2000 09:12'!
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice
	"Put up a yes/no menu with caption queryString. The actual wording 
	for the two choices will be as provided in the trueChoice and 
	falseChoice parameters. Answer true if the response is the true-choice, 
	false if it's the false-choice.
	This is a modal question -- the user must respond one way or the other."

	"PopUpMenu 
		confirm: 'Are you hungry?'
		trueChoice: 'yes, I''m famished'
		falseChoice: 'no, I just ate'"

	| menu choice |
	menu _ PopUpMenu labelArray: {trueChoice. falseChoice}.
	[(choice _ menu startUpWithCaption: queryString) isNil] whileTrue.
	^ choice = 1! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'!
inform: aString
	"PopUpMenu inform: 'I like Squeak'"

	(PopUpMenu labels: ' OK ') startUpWithCaption: aString! !

!PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'!
notify: message
	"Deprecated. Use #inform: instead."

	self inform: message! !
WordNet subclass: #PortugueseLexiconServer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-TelNet WordNet'!
!PortugueseLexiconServer commentStamp: '<historical>' prior: 0!
Provide a standard interface for the Portuguese language dictionary at http://www.priberam.pt/.
The "choose language" item on the shift-menu lets you select a language (and its server).  (Preferences setPreference: #myLanguage toValue: #Portuguese).  To get the definition of a word, select any word in any text pane, and choose "definition of word" from the shift menu.  Also used for the "verify spelling of word" menu item.

PortugueseLexiconServer openScamperOn: 'palavra'.

See class WordNet.
Converts an input string from Apple character encoding to the encoding used on this server.
  'partic’pio' -> 'particípio'

Not yet completed:
** Better parse of the definition page, so it can be used by a program.!
]style[(591 17 104)f1,f1cblack;,f1!


!PortugueseLexiconServer methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 14:48'!
definition: theWord
	"look this word up in the basic way.  Return nil if there is trouble accessing the web site."
	| doc |

	word _ theWord.
	doc _ HTTPSocket 
		httpGetDocument: 'http://www.priberam.pt/scripts/dlpouniv.dll' 
		args: 'search_value=', (self class decodeAccents: word).
	replyHTML _ (doc isKindOf: MIMEDocument)
		ifTrue: [doc content]
		ifFalse: [nil].
	"self parseReply."

	^ replyHTML! !

!PortugueseLexiconServer methodsFor: 'as yet unclassified' stamp: 'tk 6/30/2000 12:02'!
parts
	| divider |
	"return the parts of speech this word can be.  Keep the streams for each"
	parts _ OrderedCollection new.
	partStreams _ OrderedCollection new.
	rwStream ifNil: [self stream].
	rwStream reset.
	rwStream match: 'Palavra desconhecida pelo Dicionário.'.
	rwStream atEnd ifFalse: [^ #()].	"not in dictionary"

	rwStream reset.
	rwStream match: (divider _ '<li>').	"stemming a complex word"
	rwStream atEnd ifTrue: [rwStream reset.
		rwStream match: (divider _ '<dd>')].	"base word in dict"
	[rwStream atEnd] whileFalse: [
		partStreams add: (ReadStream on: (rwStream upToAll: divider))].
	partStreams do: [:pp |
		parts add: (pp upToAll: '</b>')].
	parts size = 0 ifTrue: [^ parts].
	parts last = '' ifTrue: [parts removeLast.  partStreams removeLast].
		"May want to remove all after </dl>"
	^ parts ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PortugueseLexiconServer class
	instanceVariableNames: ''!

!PortugueseLexiconServer class methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 14:48'!
decodeAccents: appleLikeString
	"change characters like ’, to the form used in Portuguese"
	| encodedStream rem |
	encodedStream _ WriteStream on: (String new).
	
	appleLikeString do: [ :c |
		rem _ encodedStream position.
		c == $’ ifTrue: [encodedStream nextPut: (Character value: 237)].
		c == $‡ ifTrue: [encodedStream nextPut: (Character value: 225)].
		c == $Ž ifTrue: [encodedStream nextPut: (Character value: 233)].
		c == $� ifTrue: [encodedStream nextPut: (Character value: 231)].
		c == $‹ ifTrue: [encodedStream nextPut: (Character value: 227)].
		c == $— ifTrue: [encodedStream nextPut: (Character value: 243)].
		c == $� ifTrue: [encodedStream nextPut: (Character value: 234)].
		"and more, such as e with a backwards accent"

		rem = encodedStream position ifTrue: [
			encodedStream nextPut: c].
		].
	^encodedStream contents. ! !

!PortugueseLexiconServer class methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 14:48'!
openScamperOn: aWord
	| aUrl scamperWindow |
	"Open a Scamper web browser on the web dictionary entry for this word.  If Scamper is already pointing at it, use the same browser.  Special code for this server."

	aUrl _ 'http://www.priberam.pt/scripts/dlpouniv.dll', 
		'?search_value=', (self decodeAccents: aWord).
	scamperWindow _ Scamper newOrExistingOn: aUrl.
	scamperWindow model jumpToUrl: aUrl asUrl.
	scamperWindow activate.
! !
Stream subclass: #PositionableStream
	instanceVariableNames: 'collection position readLimit '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!PositionableStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.!


!PositionableStream methodsFor: 'accessing'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	^collection copyFrom: 1 to: readLimit! !

!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'!
contentsOfEntireFile
	"For non-file streams"
	^ self contents! !

!PositionableStream methodsFor: 'accessing'!
last
	"Return the final element in the receiver.  Put in at Alan's request.  2/2/96 sw"

	^ collection at: (position - 1)! !

!PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'!
next: anInteger 
	"Answer the next anInteger elements of my collection. Must override 
	because default uses self contents species, which might involve a large 
	collection."

	| newArray |
	newArray _ collection species new: anInteger.
	1 to: anInteger do: [:index | newArray at: index put: self next].
	^newArray! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:58'!
next: n into: aCollection
	"Read n objects into the given collection.
	Return aCollection or a partial copy if less than
	n elements have been read."
	^self next: n into: aCollection startingAt: 1! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:54'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| obj |
	0 to: n-1 do:[:i|
		(obj _ self next) == nil ifTrue:[^aCollection copyFrom: 1 to: startIndex+i-1].
		aCollection at: startIndex+i put: obj].
	^aCollection! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'!
next: anInteger putAll: aCollection
	"Store the next anInteger elements from the given collection."
	^self next: anInteger putAll: aCollection startingAt: 1! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'!
next: anInteger putAll: aCollection startingAt: startIndex
	"Store the next anInteger elements from the given collection."
	0 to: anInteger-1 do:[:i|
		self nextPut: (aCollection at: startIndex + i).
	].
	^aCollection! !

!PositionableStream methodsFor: 'accessing' stamp: 'tk 3/27/98 08:44'!
nextDelimited: terminator
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character.  For example: 'this '' was a quote'. Start postioned before the initial terminator."

	| out ch |
	out _ WriteStream on: (String new: 1000).
	self atEnd ifTrue: [^ ''].
	self next == terminator ifFalse: [self skip: -1].	"absorb initial terminator"
	[(ch _ self next) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peek == terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:53'!
nextInto: aCollection
	"Read the next elements of the receiver into aCollection.
	Return aCollection or a partial copy if less than aCollection
	size elements have been read."
	^self next: aCollection size into: aCollection startingAt: 1.! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:59'!
nextInto: aCollection startingAt: startIndex
	"Read the next elements of the receiver into aCollection.
	Return aCollection or a partial copy if less than aCollection
	size elements have been read."
	^self next: (aCollection size - startIndex+1) into: aCollection startingAt: startIndex.! !

!PositionableStream methodsFor: 'accessing' stamp: 'bf 11/24/1998 13:35'!
nextLine
	"Answer next line (may be empty), or nil if at end"

	self atEnd ifTrue: [^nil].
	^self upTo: Character cr! !

!PositionableStream methodsFor: 'accessing' stamp: 'ar 5/28/2000 12:11'!
nextWordsInto: aBitmap 
	| blt pos mainX mainY frontX frontY little source |
	"Fill the word based buffer from my collection.  Stored on stream as Little Endian.  Optimized for speed."

	(collection class isBytes) ifTrue:
		["1 to: aBitmap size do: [:index | aBitmap at: index put: (self nextNumber: 4)]."
		little _ Smalltalk endianness == #little.
		collection basicSize \\ 4 = 0 
			ifTrue: [source _ collection.  
					pos _ self position.
					self skip: aBitmap size * aBitmap bytesPerElement "1, 2, or 4"]
			ifFalse: [source _ self next: aBitmap size * aBitmap bytesPerElement.
						"forced to copy it into a buffer"
					pos _ 0].
		mainX _ pos \\ 4.   mainY _ pos // 4.	"two Blts required if not word aligned"
		frontX _ 0.  frontY _ mainY + 1.
		blt _ (BitBlt current toForm: (Form new hackBits: aBitmap)) 
					sourceForm: (Form new hackBits: source).
		blt combinationRule: Form over.  "store"
		blt sourceX: mainX; sourceY: mainY; height: aBitmap basicSize; width: 4-mainX.
		blt destX: 0; destY: 0.
		little ifTrue: [blt sourceX: 0; destX: mainX].	"just happens to be this way!!"
		blt copyBits.
		mainX = 0 ifTrue: [^ aBitmap].

		"second piece when not word aligned"
		blt sourceX: frontX; sourceY: frontY; height: aBitmap size; width: mainX.
		blt destX: 4-mainX; destY: 0.
		little ifTrue: [blt sourceX: 4-mainX; destX: frontX].	"draw picture to understand this"
		blt copyBits.
		^ aBitmap].
	^ self next: aBitmap size into: aBitmap startingAt: 1.
! !

!PositionableStream methodsFor: 'accessing'!
originalContents
	"Answer the receiver's actual contents collection, NOT a copy.  1/29/96 sw"

	^ collection! !

!PositionableStream methodsFor: 'accessing'!
peek
	"Answer what would be returned if the message next were sent to the 
	receiver. If the receiver is at the end, answer nil."

	| nextObject |
	self atEnd ifTrue: [^nil].
	nextObject _ self next.
	position _ position - 1.
	^nextObject! !

!PositionableStream methodsFor: 'accessing'!
peekFor: anObject 
	"Answer false and do not move over the next element if it is not equal to 
	the argument, anObject, or if the receiver is at the end. Answer true 
	and increment the position for accessing elements, if the next element is 
	equal to anObject."

	| nextObject |
	self atEnd ifTrue: [^false].
	nextObject _ self next.
	"peek for matching element"
	anObject = nextObject ifTrue: [^true].
	"gobble it if found"
	position _ position - 1.
	^false! !

!PositionableStream methodsFor: 'accessing'!
upTo: anObject 
	"Answer a subcollection from the current access position to the 
	occurrence (if any, but not inclusive) of anObject in the receiver. If 
	anObject is not in the collection, answer the entire rest of the receiver."
	| newStream element |
	newStream _ WriteStream on: (collection species new: 100).
	[self atEnd or: [(element _ self next) = anObject]]
		whileFalse: [newStream nextPut: element].
	^newStream contents! !

!PositionableStream methodsFor: 'accessing' stamp: 'tk 7/18/1999 17:10'!
upToAll: aCollection
	"Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream."

	| startPos endMatch result |
	startPos _ self position.
	(self match: aCollection) 
		ifTrue: [endMatch _ self position.
			self position: startPos.
			result _ self next: endMatch - startPos - aCollection size.
			self position: endMatch.
			^ result]
		ifFalse: [self position: startPos.
			^ self upToEnd]! !

!PositionableStream methodsFor: 'accessing'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream el |
	newStream _ WriteStream on: (collection species new: 100).
	[(el _ self next) == nil] whileFalse: [ newStream nextPut: el ].
	^ newStream contents! !


!PositionableStream methodsFor: 'testing'!
atEnd
	"Primitive. Answer whether the receiver can access any more objects.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 67>
	^position >= readLimit! !

!PositionableStream methodsFor: 'testing' stamp: 'ar 1/2/2000 17:24'!
isBinary
	"Return true if the receiver is a binary byte stream"
	^collection class == ByteArray! !

!PositionableStream methodsFor: 'testing'!
isEmpty
	"Answer whether the receiver's contents has no elements."

	^position = 0! !


!PositionableStream methodsFor: 'positioning' stamp: 'hmm 10/22/1999 21:18'!
match: subCollection
	"Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found.  No wildcards, and case does matter."

	| pattern startMatch |
	pattern _ ReadStream on: subCollection.
	startMatch _ nil.
	[pattern atEnd] whileFalse: 
		[self atEnd ifTrue: [^ false].
		(self next) = (pattern next) 
			ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]]
			ifFalse: [pattern position: 0.
					startMatch ifNotNil: [
						self position: startMatch.
						startMatch _ nil]]].
	^ true

! !

!PositionableStream methodsFor: 'positioning' stamp: 'di 2/15/98 14:41'!
padTo: nBytes put: aCharacter 
	"Pad using the argument, aCharacter, to the next boundary of nBytes characters."
	| rem |
	rem _ nBytes - (self position \\ nBytes).
	rem = nBytes ifTrue: [^ 0].
	self next: rem put: aCharacter.! !

!PositionableStream methodsFor: 'positioning' stamp: 'di 5/25/1998 15:16'!
padToNextLongPut: char 
	"Make position be on long word boundary, writing the padding 
	character, char, if necessary."
	[self position \\ 4 = 0]
		whileFalse: [self nextPut: char]! !

!PositionableStream methodsFor: 'positioning'!
position
	"Answer the current position of accessing the sequence of objects."

	^position! !

!PositionableStream methodsFor: 'positioning'!
position: anInteger 
	"Set the current position for accessing the objects to be anInteger, as long 
	as anInteger is within the bounds of the receiver's contents. If it is not, 
	create an error notification."

	anInteger >= 0 & (anInteger <= readLimit)
		ifTrue: [position _ anInteger]
		ifFalse: [self positionError]! !

!PositionableStream methodsFor: 'positioning'!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	position _ 0! !

!PositionableStream methodsFor: 'positioning' stamp: 'sw 3/10/98 13:55'!
resetContents
	"Set the position and limits to 0."

	position _ 0.
	readLimit _ 0! !

!PositionableStream methodsFor: 'positioning'!
setToEnd
	"Set the position of the receiver to the end of the sequence of objects."

	position _ readLimit! !

!PositionableStream methodsFor: 'positioning'!
skip: anInteger 
	"Set the receiver's position to be the current position+anInteger. A 
	subclass might choose to be more helpful and select the minimum of the 
	receiver's size and position+anInteger, or the maximum of 1 and 
	position+anInteger for the repositioning."

	self position: position + anInteger! !

!PositionableStream methodsFor: 'positioning'!
skipTo: anObject 
	"Set the access position of the receiver to be past the next occurrence of 
	anObject. Answer whether anObject is found."

	[self atEnd]
		whileFalse: [self next = anObject ifTrue: [^true]].
	^false! !


!PositionableStream methodsFor: 'fileIn/Out'!
checkForPreamble: chunk
	((chunk beginsWith: '"Change Set:') and: [Smalltalk changes preambleString == nil])
		ifTrue: [Smalltalk changes preambleString: chunk].
	((chunk beginsWith: '"Postscript:') and: [Smalltalk changes postscriptString == nil])
		ifTrue: [Smalltalk changes postscriptString: chunk].
							
! !

!PositionableStream methodsFor: 'fileIn/Out'!
command: aString
	"Overridden by HtmlFileStream to append commands directly without translation.  4/5/96 tk"
	"We ignore any HTML commands.  Do nothing"! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 2/3/98 14:44'!
copyMethodChunkFrom: aStream
	"Copy the next chunk from aStream (must be different from the receiver)."
	| chunk |
	chunk _ aStream nextChunkText.
	chunk runs values size = 1 "Optimize for unembellished text"
		ifTrue: [self nextChunkPut: chunk asString]
		ifFalse: [self nextChunkPutWithStyle: chunk]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 08:49'!
copyMethodWithPreamble: preamble from: aStream
	| newFilePosition |
	"First copy the preamble if any."
	self copyPreamble: preamble from: aStream.

	"Then copy the method chunk"
	newFilePosition _ self position.
	self copyMethodChunkFrom: aStream.
	self nextChunkPut: ' '.
	^ newFilePosition! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:16'!
copyPreamble: preamble from: aStream
	"Look for a changeStamp for this method by peeking backward.
	Write a method preamble, with that stamp if found."
	| terminator methodPos p last50 stamp i |
	terminator _ $!!.

	"Look back to find stamp in old preamble, such as...
	Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! "
	methodPos _ aStream position.
	aStream position: (p _ 0 max: methodPos-50).
	last50 _ aStream next: methodPos - p.
	stamp _ String new.
	(i _ last50 findString: 'stamp:' startingAt: 1) > 0 ifTrue:
		[stamp _ (last50 copyFrom: i+8 to: last50 size) copyUpTo: $'].

	"Write the new preamble, with old stamp if any."
	self cr; nextPut: terminator.
	self nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: preamble.
		stamp size > 0 ifTrue:
			[strm nextPutAll: ' stamp: '; print: stamp]]).
	self cr! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 13:36'!
decodeStyle: runsObjData version: styleVersion
	"Decode the runs array from the ReferenceStream it is stored in."
	"Verify that the class mentioned have the same inst vars as we have now"

	| structureInfo |
	styleVersion = RemoteString currentTextAttVersion ifTrue: [
		"Matches our classes, no need for checking"
		^ (ReferenceStream on: runsObjData) next].
	structureInfo _ RemoteString structureAt: styleVersion.	"or nil"
		"See SmartRefStream instVarInfo: for dfn"
	^ SmartRefStream read: runsObjData withClasses: structureInfo! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'mir 7/26/2000 13:28'!
fileIn
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation."

	^ self fileInAnnouncing: 'Reading ' , self name! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'mir 7/26/2000 13:30'!
fileInAnnouncing: announcement
	"This is special for reading expressions from text that has been formatted 
	with exclamation delimitors. The expressions are read and passed to the 
	Compiler. Answer the result of compilation.  Put up a progress report with
     the given announcement as the title."
	| val chunk |
	announcement displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during:
		[:bar |
		[self atEnd]
			whileFalse: 
				[bar value: self position.
				self skipSeparators.
				val _ (self peekFor: $!!)
					ifTrue: [(Compiler evaluate: self nextChunk logged: false)
								scanFrom: self]
					ifFalse: [chunk _ self nextChunk.
							self checkForPreamble: chunk.
							Compiler evaluate: chunk logged: true].
				self skipStyleChunk].
		self close].
	^ val! !

!PositionableStream methodsFor: 'fileIn/Out'!
header
	"If the stream requires a standard header, override this message.  See HtmlFileStream"! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 2/3/98 14:29'!
nextChunk
	"Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character."
	| terminator out ch |
	terminator _ $!!.
	out _ WriteStream on: (String new: 1000).
	self skipSeparators.
	[(ch _ self next) == nil] whileFalse: [
		(ch == terminator) ifTrue: [
			self peek == terminator ifTrue: [
				self next.  "skip doubled terminator"
			] ifFalse: [
				^ out contents  "terminator is not doubled; we're done!!"
			].
		].
		out nextPut: ch.
	].
	^ out contents! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:54'!
nextChunkText
	"Deliver the next chunk as a Text.  Decode the following ]style[ chunk if present.  Position at start of next real chunk."
	| string runsRaw strm runs peek |
	"Read the plain text"
	string _ self nextChunk.
	
	"Test for ]style[ tag"
	peek _ self skipSeparatorsAndPeekNext.
	peek = $] ifFalse: [^ string asText].  "no tag"
	(self upTo: $[) = ']style' ifFalse: [^ string asText].  "different tag"

	"Read and decode the style chunk"
	runsRaw _ self nextChunk.	"style encoding"
	strm _ ReadStream on: runsRaw from: 1 to: runsRaw size.
	runs _ RunArray scanFrom: strm.

	^ Text basicNew setString: string setRunsChecking: runs.
! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 12:00'!
skipSeparators
	[self atEnd]
		whileFalse:
		[self next isSeparator ifFalse: [^ self position: self position-1]]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:08'!
skipSeparatorsAndPeekNext
	"A special function to make nextChunk fast"
	| peek |
	[self atEnd]
		whileFalse:
		[(peek _ self next) isSeparator
			ifFalse: [self position: self position-1. ^ peek]]! !

!PositionableStream methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 12:37'!
skipStyleChunk
	"Get to the start of the next chunk that is not a style for the previous chunk"

	| pos |
	pos _ self position.
	self skipSeparators.
	self peek == $] 
		ifTrue: [(self upTo: $[) = ']text' 	"old -- no longer needed"
				"now positioned past the open bracket"
			ifFalse: [self nextChunk]]	"absorb ]style[ and its whole chunk"
				
		ifFalse: [self position: pos]	"leave untouched"
! !

!PositionableStream methodsFor: 'fileIn/Out'!
trailer
	"If the stream requires a standard trailer, override this message.  See HtmlFileStream"! !

!PositionableStream methodsFor: 'fileIn/Out'!
unCommand
	"If this read stream is at a <, then skip up to just after the next >.  For removing html commands."
	| char |
	[self peek = $<] whileTrue: ["begin a block"
		[self atEnd == false and: [self next ~= $>]] whileTrue.
		"absorb characters"
		].
 ! !

!PositionableStream methodsFor: 'fileIn/Out'!
verbatim: aString
	"Do not attempt to translate the characters.  Use to override nextPutAll:"
	^ self nextPutAll: aString! !


!PositionableStream methodsFor: 'private'!
on: aCollection

	collection _ aCollection.
	readLimit _ aCollection size.
	position _ 0.
	self reset! !

!PositionableStream methodsFor: 'private'!
positionError
	"Since I am not necessarily writable, it is up to my subclasses to override 
	position: if expanding the collection is preferrable to giving this error."

	self error: 'Attempt to set the position of a PositionableStream out of bounds'! !

!PositionableStream methodsFor: 'private'!
setFrom: newStart to: newStop

	position _ newStart - 1.
	readLimit _ newStop! !


!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextInt32
	"Read a 32-bit signed integer from the next 4 bytes"
	| s |
	s _ 0.
	1 to: 4 do: [:i | s _ (s bitShift: 8) + self next].
	(s bitAnd: 16r80000000) = 0
		ifTrue: [^ s]
		ifFalse: [^ -1 - s bitInvert32]! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextInt32Put: int32
	"Write a signed integer to the next 4 bytes"
	| pos |
	pos _ int32 < 0
		ifTrue: [(0-int32) bitInvert32 + 1]
		ifFalse: [int32].
	1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)].
	^ int32! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'jm 4/9/98 21:36'!
nextLittleEndianNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."

	| bytes s |
	bytes _ self next: n.
	s _ 0.
	n to: 1 by: -1 do: [:i | s _ (s bitShift: 8) bitOr: (bytes at: i)].
	^ s
! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'di 12/6/1999 10:13'!
nextLittleEndianNumber: n put: value
	"Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant."
	| bytes |
	bytes _ ByteArray new: n.
	1 to: n do: [: i | bytes at: i put: (value digitAt: i)].
	self nextPutAll: bytes! !

!PositionableStream methodsFor: 'nonhomogeneous accessing'!
nextNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger."
	| s |
	s _ 0.
	1 to: n do: 
		[:i | s _ (s bitShift: 8) bitOr: self next asInteger].
	^ s normalize! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextNumber: n put: v 
	"Append to the receiver the argument, v, which is a positive 
	SmallInteger or a LargePositiveInteger, as the next n bytes.
	Possibly pad with leading zeros."

	1 to: n do: [:i | self nextPut: (v digitAt: n+1-i)].
	^ v
! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'ls 9/14/1998 22:46'!
nextString
	"Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length.  I expect to be in ascii mode when called (caller puts back to binary)."

	| aString length |

	"read the length in binary mode"
	self binary.
	length _ self next.		"first byte."
	length >= 192 ifTrue: [length _ length - 192.
		1 to: 3 do: [:ii | length _ length * 256 + self next]].
	aString _ String new: length.

	"read the characters in ASCII mode"
	self ascii.
	self nextInto: aString.
	^aString! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'tk 6/8/1998 21:01'!
nextStringOld
	"Read a string from the receiver. The first byte is the length of the 
	string, unless it is greater than 192, in which case the first *two* bytes 
	encode the length.  Max size 16K. "

	| aString length |
	length _ self next.		"first byte."
	length >= 192 ifTrue: [length _ (length - 192) * 256 + self next].
	aString _ String new: length.
	1 to: length do: [:ii | aString at: ii put: self next asCharacter].
	^aString! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'tk 5/29/1998 09:41'!
nextStringPut: s 
	"Append the string, s, to the receiver.  Only used by DataStream.  Max size of 64*256*256*256."

	| length |
	(length _ s size) < 192
		ifTrue: [self nextPut: length]
		ifFalse: 
			[self nextPut: (length digitAt: 4)+192.
			self nextPut: (length digitAt: 3).
			self nextPut: (length digitAt: 2).
			self nextPut: (length digitAt: 1)].
	self nextPutAll: s.
	^s! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextWord
	"Answer the next two bytes from the receiver as an Integer."

	| high low |
	high _ self next.
		high==nil ifTrue: [^false].
	low _ self next.
		low==nil ifTrue: [^false].
	^(high asInteger bitShift: 8) + low asInteger! !

!PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'sw 3/10/98 13:55'!
nextWordPut: aWord 
	"Append to the receiver an Integer as the next two bytes."

	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	self nextPut: (aWord bitAnd: 255).
	^aWord! !


!PositionableStream methodsFor: 'converting' stamp: 'tk 2/7/2000 11:08'!
asBinaryOrTextStream
	"Convert to a stream that can switch between bytes and characters"

	^ (RWBinaryOrTextStream with: self contentsOfEntireFile) reset! !

!PositionableStream methodsFor: 'converting' stamp: 'ar 1/2/2000 15:32'!
asZLibReadStream
	^ZLibReadStream on: collection from: position+1 to: readLimit! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PositionableStream class
	instanceVariableNames: ''!

!PositionableStream class methodsFor: 'instance creation'!
on: aCollection 
	"Answer an instance of me, streaming over the elements of aCollection."

	^self basicNew on: aCollection! !

!PositionableStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me, streaming over the elements of aCollection 
	starting with the element at firstIndex and ending with the one at 
	lastIndex."

	^self basicNew on: (aCollection copyFrom: firstIndex to: lastIndex)! !
Canvas subclass: #PostscriptCanvas
	instanceVariableNames: 'origin clipRect currentColor currentFont morphLevel gstateStack fontMap usedFonts psBounds topLevelMorph initialScale savedMorphExtent currentTransformation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!PostscriptCanvas commentStamp: '<historical>' prior: 0!
I am a canvas that converts Morphic drawing messages into Postscript.  The canvas itself does not actually generate the Postscript code, but rather sends messages corresponding 1:1 to the Postscript imaging model to its target (default: PostscriptEncoder), which has the job of generating actual drawing commands.

PostscriptCharacterScanner and PostscriptDummyWarp are helper classes that simulate effects currently implemented via BitBlt-specific mechanisms during Postscript generation.  They should be going away as Morphic becomes fully device independent.

!


!PostscriptCanvas methodsFor: 'printing'!
printContentsOn: aStream 
	^ aStream nextPutAll: target contents! !

!PostscriptCanvas methodsFor: 'printing'!
psSize
	^ target size! !


!PostscriptCanvas methodsFor: 'initialization' stamp: 'mpw 8/7/2000 09:09'!
bounds:newBounds
	psBounds _ newBounds.
! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'di 8/12/2000 15:04'!
doesRoundedCorners 

	^ false! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 9/18/2000 18:36'!
initializeFontMap
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	fontMap _ Dictionary new: 5.
	pairs _ #(
		'Palatino'  'Palatino-Roman'
		'NewYork' 'Helvetica'
		'NewYork-Bold' 'Helvetica-Bold'
		'ComicBold' 'Helvetica-Narrow-Bold'
	).

	1 to: pairs size by: 2 do: [:i |
		fontMap at: (pairs at: i) put: (pairs at: i + 1)].
! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 9/20/2000 11:32'!
reset
	super reset.
	origin _ 0@0.							"origin of the top-left corner of this cavas"
	clipRect _ (0@0 corner: 10000@10000).		"default clipping rectangle"
	currentTransformation _ nil.
	morphLevel _ 0.
	gstateStack _ OrderedCollection new.
	self initializeFontMap.
	usedFonts _ Set new.
     initialScale _ 1.0! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'di 9/22/1999 08:16'!
resetContentRotated: rotateFlag
	target _ self class defaultTarget.
	self writeHeaderRotated: rotateFlag.
     ^self.! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'di 9/22/1999 08:15'!
writeHeaderRotated: rotateFlag
	self writePSIdentifierRotated: rotateFlag.
	self writeProcset.


! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'di 9/22/1999 08:24'!
writePSIdentifierRotated: rotateFlag
	"NB: rotation not yet supported"

	target print:'%!!'; cr.! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'mpw 11/15/1999 08:57'!
writeProcset
	target print:'

%%BeginProcset: Squeak-Level2-Emulation
/level1 /languagelevel where { 
	pop  languagelevel 2 lt
} {true } ifelse def
level1
{
	/rectclip {
		4 2 roll moveto
		1 index 0 rlineto
		 0 exch rlineto
		neg 0 rlineto closepath
		clip newpath
	} bind def
	/setcolorspace { pop } bind def
	/makeDict {
		counttomark 2 idiv dup dict begin
		{  def } repeat
		currentdict end exch pop
	} bind def
	/defaultDict [ /MultipleDataSources  false makeDict def
	/image {
		dup type /dicttype eq {
			defaultDict begin
			begin
				Width
				Height
				BitsPerComponent
				ImageMatrix 
				/DataSource load MultipleDataSources { aload pop } if				MultipleDataSources
				Decode length 2 idiv
			end
			end
		} if
		colorimage 
		currentfile ( ) readstring pop pop
	} bind def

	/_imagemask /imagemask load def
	/imagemask {
		dup type /dicttype eq {
			begin
				Width
				Height
				Decode 0 get 1 eq
				ImageMatrix
				/DataSource load
			end
		} if
		_imagemask 
		currentfile ( ) readstring pop pop
	} bind def
	/transparentimage {
		pop image
	} bind def

} {
	/makeDict { >> } bind def
	/transparentimage {
	  gsave
	  32 dict begin
	  /tinteger exch def
	  /transparent 1 string def
	  transparent 0 tinteger put
	  /olddict exch def
	  olddict /DataSource get dup type /filetype ne {
	    olddict /DataSource 3 -1 roll 0 () /SubFileDecode filter put
	  } {
	    pop
	  } ifelse
	  /newdict olddict maxlength dict def
	  olddict newdict copy pop
	  /w newdict /Width get def
	  /str w string def
	  /substrlen 2 w log 2 log div floor exp cvi def
	  /substrs [
	  {
	     substrlen string
	     0 1 substrlen 1 sub {
	       1 index exch tinteger put
	     } for
	     /substrlen substrlen 2 idiv def
	     substrlen 0 eq {exit} if
	  } loop
	  ] def
	  /h newdict /Height get def
	  1 w div 1 h div matrix scale
	  olddict /ImageMatrix get exch matrix concatmatrix
	  matrix invertmatrix concat
	  newdict /Height 1 put
	  newdict /DataSource str put
	  /mat [w 0 0 h 0 0] def
	  newdict /ImageMatrix mat put
	  0 1 h 1 sub {
	    mat 5 3 -1 roll neg put
	    olddict /DataSource get str readstring pop pop
	    /tail str def
	    /x 0 def
	    {
	      tail transparent search dup /done exch not def
	      {exch pop exch pop} if
	      /w1 1 index length def
	      w1 0 ne {
	        newdict /DataSource 3 -1 roll put
	        newdict /Width w1 put
	        mat 4 x neg put
	        /x x w1 add def
	        newdict image
	        /tail tail w1 tail length w1 sub getinterval def
	      } if
	      done {exit} if
	      tail substrs {
	        anchorsearch {pop} if
	      } forall
	      /tail exch def
	      tail length 0 eq {exit} if
	      /x w tail length sub def
	    } loop
	  } for
	  end
	  grestore
	} bind def
} ifelse

%%EndProcset
%%BeginProcset: Squeak-Printing
/_showpageSqueak /showpage load def
/showpage { gsave _showpageSqueak grestore } bind def
/countspaces {
	[ exch { dup 32 ne { pop } if  } forall ] length 
} bind def
/jshow { 
	10 dict begin
	/width exch def
	/str exch def
	str length 0 gt {
		str dup length 1 sub get 32 eq { /str str dup length 1 sub 0 exch getinterval def } if
		/strw str stringwidth pop def
		/diffwidth width strw sub def
		/numspaces str countspaces def
		numspaces 0 eq { /numspaces 1 def } if
		/adjspace width strw sub numspaces div def
		/adjchar 0 def
		diffwidth 0 lt {
			/adjspace adjspace 0.2 mul def
			/adjchar diffwidth str length div 0.8 mul def
		} if
		adjspace 0 32 adjchar 0 str awidthshow

	} if
	end
} bind def

/copydict {
	dup length dict begin 
		 { 1 index /FID eq 2 index /UniqueID eq and {pop pop} {  def  } ifelse } forall
	currentdict end
} bind def
/getSymbolcharproc {
	1 dict begin 
		/charstring exch def 
	 [ 550 0 0 0 650 600 /setcachedevice cvx 50 100 /translate cvx  /pop cvx 
		1 dict begin /setbbox { pop pop pop } bind def currentdict end /begin cvx   

		gsave  /Symbol 600 selectfont 0 0 moveto charstring false charpath false upath grestore

	 /exec cvx /fill cvx /end cvx ] cvx bind 
	end
} bind def
/adjustFontForSqueak		% converts _ to left-arrow, ^to upArrow and tab -> 4 spaces
{ 
	gsave dup 1000 selectfont
	dup dup findfont copydict
	begin
	CharStrings 
	/CharStrings exch copydict
	dup /leftarrow (\254) getSymbolcharproc  put
	dup /uparrow (\255) getSymbolcharproc  put
	dup /tab [ /pop cvx ( ) stringwidth pop 6 mul 0 0 0 0 0  /setcachedevice cvx ] cvx bind  put
	def
	/Encoding Encoding dup length array copy 
	dup 94 /uparrow put
	dup 95 /leftarrow put
	dup 9 /tab put
	def
	currentdict end definefont pop pop
	grestore
} bind def

%%EndProcset
'.
! !

!PostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 9/17/2000 16:08'!
writeSetupForRect:aRect
	target print:'% psBounds origin'; cr.
	target translate: psBounds origin.
	target print:'% flip'; cr.
	target translate: 0 @ 
		(aRect extent y * (EPSCanvas bobsPostScriptHacks ifTrue: [initialScale] ifFalse: [1]));
		scale:initialScale @ initialScale negated;
		print:' [ {true setstrokeadjust} stopped ] pop
[ currenttransfer /exec cvx 1.2 /exp cvx ] cvx bind  settransfer'; cr.



! !


!PostscriptCanvas methodsFor: 'morph drawing' stamp: 'mpw 8/10/1930 05:44'!
drawPage:aMorph
	self fullDrawMorph:aMorph.
	target showpage.
! !

!PostscriptCanvas methodsFor: 'morph drawing'!
drawPages:collectionOfPages
	| currentPage |
	currentPage _ 0.
	collectionOfPages do:[ :page |
		currentPage _ currentPage + 1.
		target print:'%%Page: '; write:currentPage; space; write:currentPage; cr.
		self drawPage:page.
	].
	target print:'%%Pages: '; write:currentPage; cr.
! !

!PostscriptCanvas methodsFor: 'morph drawing' stamp: 'mpw 8/10/1930 05:42'!
fullDrawBookMorph:aBookMorph
	^aBookMorph fullDrawOn:self.
! !

!PostscriptCanvas methodsFor: 'morph drawing'!
setupGStateForMorph:aMorph.
! !


!PostscriptCanvas methodsFor: 'misc canvas'!
asBalloonCanvas
     ^self.! !

!PostscriptCanvas methodsFor: 'misc canvas' stamp: 'mpw 8/6/2000 13:36'!
contentsOfArea: aRectangle into: aForm
	"not supported for PS canvas"
! !

!PostscriptCanvas methodsFor: 'misc canvas' stamp: 'RAA 9/20/2000 11:33'!
preserveStateDuring: aBlock
	| retval saveClip saveTransform |
	target preserveStateDuring: [ :innerTarget |
		saveClip _ clipRect.
		saveTransform _ currentTransformation.
		gstateStack addLast: currentFont.
		gstateStack addLast: currentColor.
		retval _ aBlock value: self.
		currentColor _ gstateStack removeLast.
		currentFont _ gstateStack removeLast.
		clipRect _ saveClip.
		currentTransformation _ saveTransform.
	].
	^ retval
! !

!PostscriptCanvas methodsFor: 'misc canvas'!
setOrigin: aPoint clipRect: aRectangle
	self comment:'new origin: ' with:aPoint.
	target rectclip:aRectangle.
	self translate:aPoint - origin.

"	self grestore; gsave.

	self write:aRectangle.
	target print:' textclip'; cr.
	target print:'% new offset '.
	target write:aPoint.
	target cr.
"	super setOrigin: aPoint clipRect: aRectangle.
! !

!PostscriptCanvas methodsFor: 'misc canvas' stamp: 'di 8/9/2000 21:28'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."

	| result |
	self translate: delta.
	result _ aBlock value: self.
	self translate: delta negated.
	^ result
! !

!PostscriptCanvas methodsFor: 'misc canvas' stamp: 'mpw 8/4/1930 20:11'!
warpFrom: sourceQuad toRect: innerRect
	"^PostscriptDummyWarp canvas:self."! !


!PostscriptCanvas methodsFor: 'drawing-general' stamp: 'mpw 8/10/1930 05:23'!
draw: anObject
	^anObject drawPostscriptOn: self! !

!PostscriptCanvas methodsFor: 'drawing-general' stamp: 'di 8/12/2000 09:46'!
fullDraw: aMorph

	self comment: 'level: ' with: morphLevel.
	morphLevel _ morphLevel+1.
	self preserveStateDuring:
		[:inner | inner setupGStateForMorph: aMorph.
		aMorph fullDrawPostscriptOn: inner].
	morphLevel _ morphLevel-1.
	self comment: 'end morph: ' with: aMorph.
	self comment: 'level: ' with: morphLevel.	! !


!PostscriptCanvas methodsFor: 'drawing support'!
clip	
	^target clip.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 6/22/1930 22:37'!
clipBy: aRectangle during: aBlock
	^self translateBy: 0@0 clippingTo: aRectangle during: aBlock.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 8/3/1930 08:39'!
closepath
	^target closepath.


              ! !

!PostscriptCanvas methodsFor: 'drawing support'!
comment:aString
	target comment:aString.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 9/12/1999 21:25'!
comment:aString with:anObject
"	target comment:aString with:anObject.
"! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'sw 12/6/1999 13:10'!
defaultFont
	^ TextStyle defaultFont! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'RAA 9/20/2000 15:39'!
defineFont: aFont

	| psNameFor alreadyRemapped |

	(usedFonts includes: aFont) ifFalse:[
		psNameFor _ self postscriptFontNameForFont: aFont.
		alreadyRemapped _ usedFonts anySatisfy: [ :each | 
			(self postscriptFontNameForFont: each) = psNameFor
		].
		usedFonts add:aFont.
		" here: define as Type-3 unless we think its available "
		" or, just remap"

		" I had some problems if same font remapped twice"
		alreadyRemapped ifFalse: [target remapFontForSqueak: psNameFor].
	].! !

!PostscriptCanvas methodsFor: 'drawing support'!
drawGradient:fillColor
	 self comment:'not-solid fill ' with:fillColor.
	 self comment:' origin ' with:fillColor origin.
	 self comment:' direction ' with:fillColor direction.
	self fill:fillColor asColor.


              ! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'di 8/12/2000 09:42'!
drawPostscriptContext: subCanvas
	| contents |
	(contents _ subCanvas contents) ifNil: [^ self].
	^ target comment: ' sub-canvas start';
		preserveStateDuring: [:inner | inner print: contents];
		comment: ' sub-canvas stop'.	

! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'di 8/12/2000 09:43'!
fill: fillColor
	fillColor isSolidFill
		ifTrue: [self paint: fillColor asColor operation: #fill]
		ifFalse: [self preserveStateDuring: [:inner | inner clip; drawGradient: fillColor]]! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'di 8/12/2000 09:44'!
fill: fillColor andStroke: strokeColor
	self preserveStateDuring: [:inner | inner fill: fillColor];
		stroke: strokeColor.
! !

!PostscriptCanvas methodsFor: 'drawing support'!
lineto:aPoint
	^target lineto:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'drawing support'!
mapFontName:fontName
	^ fontMap at:fontName ifAbsent:[fontName].
! !

!PostscriptCanvas methodsFor: 'drawing support'!
moveto:aPoint
	^target moveto:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 9/12/1999 22:13'!
outlinePolygon:vertices
	target moveto:(vertices at:1).
	2 to:vertices size  do:[ :i |
		target lineto:(vertices at:i)	
	].
	target closepath.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 9/13/1999 21:01'!
outlineQuardraticBezierShape:vertices
	target moveto:(vertices at:1).
	3 to:vertices size by:3 do:[ :i |
		target curvetoQuadratic:(vertices at:i) from:(vertices at:i-2) via:(vertices at:i-1)	
	].
	target closepath.
! !

!PostscriptCanvas methodsFor: 'drawing support'!
oval:aPoint
	^target oval:aPoint.! !

!PostscriptCanvas methodsFor: 'drawing support'!
paint:color operation:operation
	self setColor:color.
	currentColor isTransparent ifFalse:[target perform:operation] ifTrue:[target newpath].

              ! !

!PostscriptCanvas methodsFor: 'drawing support'!
postscriptFontNameForFont:font
	| fontName |
	fontName _ font familyName asString.
	font emphasis == 1 ifTrue:[
		fontName _ fontName,'-Bold'.
	].
	^self mapFontName:fontName.

! !

!PostscriptCanvas methodsFor: 'drawing support'!
rect:aRect
	^target rect:aRect.
! !

!PostscriptCanvas methodsFor: 'drawing support'!
setColor: color 
     currentColor ~= color ifTrue:[
          target write:color asColor.
		currentColor _ color.
	].
! !

!PostscriptCanvas methodsFor: 'drawing support'!
setFont:aFont
	aFont ~= currentFont ifTrue:[
		currentFont _ aFont.
		self defineFont:aFont.
		target selectflippedfont:(self postscriptFontNameForFont:aFont) size:aFont height * 0.9 ascent:aFont ascent.
				" the 0.9 is obviously a fudge factor.  I have to figure out how
 				  to figure out the actual font-size to request, neither #ascent nor #height
				  are correct." 
	]
! !

!PostscriptCanvas methodsFor: 'drawing support'!
setLinewidth: width 
	target setLinewidth: width.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'RAA 2/2/2001 10:09'!
stroke: strokeColor
	strokeColor ifNil: [^ self].

	(strokeColor isKindOf: Symbol) ifTrue: [
		^self paint: Color gray operation: #stroke	"punt"
	].
	strokeColor isSolidFill ifTrue: [
		^self paint: strokeColor asColor operation: #stroke
	].
	self preserveStateDuring: [:inner | inner strokepath; fill: strokeColor].! !

!PostscriptCanvas methodsFor: 'drawing support'!
strokepath
	^target strokepath.


              ! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 8/4/1930 12:13'!
transformBy:aMatrix
	("aMatrix isPureTranslation" false) ifTrue:[
		target translate:aMatrix offset negated.
	] ifFalse:[
		target  concat:aMatrix.
	].
	^self.
! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'RAA 9/20/2000 14:52'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	| retval |
	self comment: 'drawing clipped ' with: aClipRect.
	self comment: 'drawing transformed ' with: aDisplayTransform.
     self preserveStateDuring: [ :inner | 
		currentTransformation ifNil: [
			currentTransformation _ aDisplayTransform
		] ifNotNil: [
			currentTransformation _ currentTransformation composedWithLocal: aDisplayTransform
		].
		aClipRect ifNotNil: [
			clipRect _ aDisplayTransform globalBoundsToLocal: (clipRect intersect: aClipRect) .
			inner rect: aClipRect; clip.
		].
		inner transformBy: aDisplayTransform.
		retval _ aBlock value: inner
	].	
	self comment: 'end of drawing clipped ' with: aClipRect.
	^ retval
! !

!PostscriptCanvas methodsFor: 'drawing support'!
translate:aPoint
	^target translate:aPoint.


              ! !

!PostscriptCanvas methodsFor: 'drawing support' stamp: 'mpw 8/4/1930 12:07'!
translateBy: delta clippingTo: aRect during: aBlock
	self comment:'translateBy: ' with:delta.
	^self transformBy:(MatrixTransform2x3 withOffset:delta) clippingTo:aRect during:aBlock.

! !


!PostscriptCanvas methodsFor: 'drawing' stamp: 'mpw 9/13/1999 21:02'!
drawGeneralBezierShape: shapeArray
					color: color 
					borderWidth: borderWidth 
					borderColor: borderColor
	shapeArray do:[ :shape | self outlineQuardraticBezierShape:shape ].
	self setLinewidth:borderWidth;
		fill:color andStroke:borderColor.

! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'di 8/9/2000 21:36'!
drawOval: r color: c borderWidth: borderWidth borderColor: borderColor

	^ self fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	

		
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 2/2/2001 10:06'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self outlinePolygon:vertices;
	     setLinewidth:bw;
	     fill:aColor andStroke: ((bc isKindOf: Symbol) ifTrue: [Color gray] ifFalse: [bc]).

! !

!PostscriptCanvas methodsFor: 'drawing'!
drawRectangle: r
		color: color
		borderWidth: borderWidth
		borderColor: borderColor.
	^self frameAndFillRectangle: r fillColor: color borderWidth: borderWidth borderColor: borderColor .
! !

!PostscriptCanvas methodsFor: 'drawing'!
fillColor:aColor
	self rect:clipRect; fill:aColor.
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'di 8/12/2000 19:45'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor 
	self preserveStateDuring:
		[:inner |
		inner oval: r;
		setLinewidth: borderWidth;
		fill: c andStroke: borderColor].

	

		
! !

!PostscriptCanvas methodsFor: 'drawing'!
fillRectangle: r color: c
	self rect:r; fill:c.! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 2/2/2001 09:54'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	aFillStyle isSolidFill ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].

	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].

	"Use a BalloonCanvas instead PROBABLY won't work here"
	"self balloonFillRectangle: aRectangle fillStyle: aFillStyle."

	^self fillRectangle: aRectangle color: aFillStyle asColor! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 9/20/2000 09:44'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor 

	"since postscript strokes on the line and squeak strokes inside, we need to adjust inwards"
	self 
		setLinewidth: borderWidth; 
	 	rect: (r insetBy: borderWidth / 2);
		fill: fillColor andStroke: borderColor.
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 9/16/2000 16:57'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor 
 	self setLinewidth:borderWidth; 
	 	rect:r;
		fill:fillColor andStroke:topLeftColor.
	"Now draw bottom right border.
	Note: Must inset this manually!!"
	self comment:'draw inset border'.
	self setLinewidth:0.
	0 to: borderWidth-1 do:[ :offset |
		target comment:'drawing inset: ' with:offset.
		EPSCanvas bobsPostScriptHacks ifTrue: [target newpath].
		self moveto:r topRight + ( offset negated @ offset ); 
			lineto:r bottomRight + ( offset negated @ offset negated );
			lineto:r bottomLeft + ( offset @ offset negated ).
		self stroke:bottomRightColor
	]
! !

!PostscriptCanvas methodsFor: 'drawing'!
frameRectangle: r width: w color: c 
	self rect:r; stroke:c.

! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'di 8/12/2000 10:06'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule 
	self preserveStateDuring:
		[:inner | inner translate: aPoint + self origin.
		target write: aForm]
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 9/20/2000 16:16'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self flag: #bob.		"need to fix this"

	"^aFillStyle 
		displayOnPort: (port clippedBy: aRectangle) 
		at: aRectangle origin - origin"
! !

!PostscriptCanvas methodsFor: 'drawing'!
line: pt1 to: pt2 brushForm: brush 
	" to do: set brushform "
	self moveto:pt1; lineto:pt2; stroke:currentColor.
 
! !

!PostscriptCanvas methodsFor: 'drawing'!
line: pt1 to: pt2 width: w color: c 
	self setLinewidth:w; moveto:pt1; lineto:pt2; stroke:c. 	
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'di 8/13/2000 12:27'!
paragraph: para bounds: bounds color: c 
	| displayablePara |
	self comment:'paragraph with bounds: ' with:bounds.
	displayablePara _ para asParagraphForPostscript.
	self preserveStateDuring:
		[:inner |
		displayablePara displayOn: inner
			using: (PostscriptCharacterScanner
					scannerWithCanvas: self paragraph: displayablePara bounds: bounds)
			at: bounds topLeft]
! !

!PostscriptCanvas methodsFor: 'drawing'!
point: p color: c 
	"Noop here; overridden by non-trivial canvases."
	^ self! !

!PostscriptCanvas methodsFor: 'drawing'!
stencil: stencilForm at: aPoint color: aColor
	target comment:' imagemask'.
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 10/2/2000 20:20'!
text: s at:point font: fontOrNil color: c justified:justify parwidth:parwidth

	self flag: #bob.		"deprecated in favor of #textStyled......."







	self setFont:(fontOrNil ifNil:[self defaultFont]).
	self comment:' text color: ',c printString.
	self setColor:c.
	self comment:'  origin ',  origin printString.
     self moveto: point.
	target print:' (';
     	 print:s asPostscript; print:') '.
		justify ifTrue:[
			target write:parwidth; print:' jshow'; cr.
		] ifFalse:[
			target print:'show'.
		].
		target cr.
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'mpw 9/17/1999 22:14'!
text: s at:point font: fontOrNil color: c spacePad:pad
	self setFont:(fontOrNil ifNil:[self defaultFont]).
	self comment:' text color: ',c printString.
	self setColor:c.
	self comment:'  origin ',  origin printString.
     self moveto: point.
	
	target write:pad; print:' 0 32 (';
     	 print:s asPostscript; print:') widthshow'; cr.
! !

!PostscriptCanvas methodsFor: 'drawing'!
text: s bounds: boundsRect font: fontOrNil color: c 
	self setFont:(fontOrNil ifNil:[self defaultFont]).
	self comment:' text color: ',c printString.
	self setColor:c.
	self comment:' boundsrect origin ', boundsRect origin printString.
	self comment:'  origin ',  origin printString.
     self moveto: (boundsRect origin ).
	target print:' (';
     	 print:s asPostscript;
		print:') show';
		 cr.
! !

!PostscriptCanvas methodsFor: 'drawing' stamp: 'RAA 10/2/2000 20:38'!
textStyled: s at: ignored0 font: ignored1 color: c justified: justify parwidth: parwidth

	self comment: ' text color: ',c printString.
	self setColor: c.
	self comment:'  origin ',  origin printString.
     "self moveto: point."		"now done by sender"
	target 
		print:' (';
		print: s asPostscript;
		print:') '.
	justify ifTrue: [
		target write: parwidth; print:' jshow'; cr.
	] ifFalse:[
		target print: 'show'.
	].
	target cr.

! !


!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 8/3/1930 07:36'!
clipRect
	^clipRect.
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 8/3/1930 07:35'!
origin
	^origin.
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 9/14/1999 06:58'!
topLevelMorph
	^topLevelMorph
! !

!PostscriptCanvas methodsFor: 'accessing' stamp: 'mpw 9/14/1999 06:58'!
topLevelMorph:newMorph
	topLevelMorph _ newMorph.
! !


!PostscriptCanvas methodsFor: 'ballon compatibility' stamp: 'mpw 9/13/1999 20:57'!
aaLevel:newLevel
	"ignore "! !

!PostscriptCanvas methodsFor: 'ballon compatibility' stamp: 'mpw 9/13/1999 21:05'!
transformBy:aTransform during:aBlock
	^self transformBy:aTransform clippingTo: nil during:aBlock! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptCanvas class
	instanceVariableNames: ''!

!PostscriptCanvas class methodsFor: 'testing' stamp: 'mpw 9/18/1999 11:02'!
morphAsPostscript:aMorph
	^self morphAsPostscript:aMorph rotated:false offsetBy:self baseOffset.
! !

!PostscriptCanvas class methodsFor: 'testing' stamp: 'di 9/22/1999 09:31'!
morphAsPostscript: aMorph rotated: rotateFlag

	^ self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: self baseOffset.
! !

!PostscriptCanvas class methodsFor: 'testing' stamp: 'di 9/22/1999 08:16'!
morphAsPostscript:aMorph rotated:rotateFlag offsetBy:offset
 | psCanvas |
  psCanvas _ self new.
  psCanvas reset.
  psCanvas bounds:(offset extent:aMorph bounds extent).
  psCanvas topLevelMorph:aMorph.
  psCanvas resetContentRotated: rotateFlag.
  psCanvas fullDrawMorph: aMorph .
  ^psCanvas contents.
! !


!PostscriptCanvas class methodsFor: 'configuring' stamp: 'mpw 9/18/1999 11:04'!
baseOffset
	^0@0.
! !

!PostscriptCanvas class methodsFor: 'configuring' stamp: 'RAA 2/1/2001 15:50'!
defaultCanvasType

	^Preferences postscriptStoredAsEPS ifTrue: [EPSCanvas] ifFalse: [DSCPostscriptCanvas]! !

!PostscriptCanvas class methodsFor: 'configuring'!
defaultTarget
	^PostscriptEncoder stream.
! !

!PostscriptCanvas class methodsFor: 'configuring'!
filterSelector
	^#fullDrawPostscriptOn:.
! !

Object subclass: #PostscriptCharacterScanner
	instanceVariableNames: 'canvas paragraph bounds curPos font foregroundColor emphasis '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!PostscriptCharacterScanner commentStamp: '<historical>' prior: 0!
I am a simple character scanner that forwards text-drawing commands to my canvas.  Despite the name, it should also work with other Canvases that actually implement the text-drawing commands (which the basic FormCanvas does not).

Style text support currently includes color, centering, fonts and emphasis.  Not yet supported are embedded objects, full justification and probably some others as well.

Tabs aren't supported properly, but rather hacked in the Postscript Header provided by PostscriptCanvas to be equivalent to 4 space.

mpw.
!


!PostscriptCharacterScanner methodsFor: 'accessing'!
bounds:newBounds
    bounds_newBounds.
    curPos_newBounds origin.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
canvas
	^canvas.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
canvas:newCanvas
    canvas_newCanvas.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:10'!
defaultFont
	^ TextStyle defaultFont! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
font
	^ font ifNil:[self defaultFont].! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
paragraph
	^paragraph.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
paragraph:newPara
    paragraph_newPara.

	! !

!PostscriptCharacterScanner methodsFor: 'accessing' stamp: 'mpw 8/4/1930 09:09'!
setDestForm:destForm
	"dummy"
! !

!PostscriptCharacterScanner methodsFor: 'accessing'!
textStyle
	^paragraph textStyle.
! !


!PostscriptCharacterScanner methodsFor: 'displaying' stamp: 'RAA 10/2/2000 21:00'!
displayLine: line offset: baseOffset leftInRun: leftInRun
	| drawFont offset aText string s doJustified |

	self setTextStylesForOffset: ((line first) + 1).	" sets up various instance vars from text styles "
	drawFont _ self font.
	offset _ baseOffset.
	offset _ offset + (line left @ (line top + line baseline - drawFont ascent )). 
	offset _ offset + ((self textStyle alignment caseOf:{
		[2] -> [ line paddingWidth /2 ].
		[1] -> [ line paddingWidth ] } otherwise:[0]) @ 0).

	canvas moveto: offset.

	aText _ paragraph text copyFrom: line first to: line last.
	doJustified _ (paragraph textStyle alignment = 3)
						and: [ (paragraph text at:line last) ~= Character cr
						and: [aText runs runs size = 1]].
	string _ aText string.
	aText runs withStartStopAndValueDo: [:start :stop :attributes |
		self setTextStylesForOffset: (start + line first - 1).	" sets up inst vars from text styles "
		s _ string copyFrom: start to: stop.
		drawFont _ self font.
		canvas setFont: drawFont.
		canvas 
			textStyled: s
			at: offset 		"<--now ignored"
			font: drawFont 		"<--now ignored"
			color: foregroundColor
			justified: doJustified		"<-can't do this now for multi-styles" 
			parwidth: line right - line left.
	].
! !


!PostscriptCharacterScanner methodsFor: 'textstyle support'!
addEmphasis: emphasisCode
	emphasis _ emphasisCode.! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
addKern: kern
	" canvas comment:'kern now: ',kern printString. "
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
indentationLevel: amount
	" canvas comment:'indentation level ',amount printString. "
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
placeEmbeddedObject: anchoredMorph
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
setActualFont: newFont
	font _ newFont.! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
setFont: fontNumber
	self setActualFont:(self textStyle fontAt:fontNumber).
! !

!PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'sw 12/7/1999 12:28'!
setTextStylesForOffset:offset
	" default text style "
	font _ self textStyle defaultFont.
	emphasis _ 0.
	foregroundColor _ Color black.

	" set text styles defined at this point, these methods will set instance vars of myself "
	(paragraph text attributesAt: offset forStyle: paragraph textStyle) do: 
		[:att | att emphasizeScanner: self].

	" post-processing of 'emphasis' "
	self setActualFont: (font emphasized: emphasis)! !

!PostscriptCharacterScanner methodsFor: 'textstyle support'!
textColor: aColor
	foregroundColor _ aColor.
! !


!PostscriptCharacterScanner methodsFor: 'as yet unclassified' stamp: 'RAA 9/15/2000 14:39'!
setYFor: anchoredMorph
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptCharacterScanner class
	instanceVariableNames: ''!

!PostscriptCharacterScanner class methodsFor: 'as yet unclassified'!
scannerWithCanvas:aCanvas paragraph:aParagraph bounds:newBounds
    ^self new canvas:aCanvas; paragraph:aParagraph; bounds:newBounds.
 ! !
Object subclass: #PostscriptDummyWarp
	instanceVariableNames: 'canvas subCanvas transform '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!PostscriptDummyWarp commentStamp: '<historical>' prior: 0!
I simulate the effects of having a WarpBlit done in Postscript, by simply adjusting the coordinate system.
!


!PostscriptDummyWarp methodsFor: 'dummy'!
canvas
	^canvas
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:19'!
canvas:newCanvas
	canvas _ newCanvas.
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
cellSize:newCellSize
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:09'!
colorMap:aMap
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
combinationRule:newRule
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:12'!
drawPostscriptContext:aCanvas
	canvas drawPostscriptContext:aCanvas.


! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'di 8/12/2000 10:01'!
preserveStateDuring: aBlock

	^ canvas preserveStateDuring:
		"Note block arg must be self so various things get overridden properly"
		[:inner | aBlock value: self]

! !

!PostscriptDummyWarp methodsFor: 'dummy'!
sourceForm:newForm
	^self.! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:10'!
sourceQuad:aQuad destRect:aRect
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/10/1930 21:02'!
subCanvas:patchRect
	subCanvas ifNil:
		[ subCanvas _ PostscriptCanvas new reset setOrigin:patchRect topLeft clipRect:(-10000@-10000 extent:20000@20000)].
	^subCanvas.

! !

!PostscriptDummyWarp methodsFor: 'dummy'!
transform
	^transform.
! !

!PostscriptDummyWarp methodsFor: 'dummy'!
transform:newTransform
	transform _ newTransform.
	^self.
! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'mpw 8/4/1930 09:11'!
transformBy:aTransform
	canvas transformBy:aTransform.


! !

!PostscriptDummyWarp methodsFor: 'dummy' stamp: 'di 8/12/2000 10:13'!
warpBits
	canvas preserveStateDuring:
		[:inner | 
		transform ifNotNil: [inner transformBy: transform].
		inner drawPostscriptContext:subCanvas].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptDummyWarp class
	instanceVariableNames: ''!

!PostscriptDummyWarp class methodsFor: 'as yet unclassified' stamp: 'mpw 8/4/1930 09:18'!
canvas:aCanvas
	^self new canvas:aCanvas.! !
PrintableEncoder subclass: #PostscriptEncoder
	instanceVariableNames: ''
	classVariableNames: 'MacToPSCharacterMappings '
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!
!PostscriptEncoder commentStamp: '<historical>' prior: 0!
I translate the message protocol generated by PostscriptCanvas that represents the Postscript imaging model into an actual stream of ASCII-encoded Postscript Level 2.

Alternative implementations might provide binary representations, Level I or Level III or even PDF.


!


!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 8/10/1930 21:34'!
clip
	self print:'clip newpath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
closepath
	self print:'closepath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
comment:aString
	self print:'%'; print:aString; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
comment:aString with:anObject
	self print:'%'; print:aString; print:' '; write:anObject; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
concat:aMatrix
	self write:aMatrix asMatrixTransform2x3; print:' concat'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 9/12/1999 22:11'!
curvetoQuadratic:targetPoint from:sourcePoint via:offPoint
	self write:(sourcePoint + offPoint) / 2; print:' ';
		 write:(offPoint + targetPoint) / 2; print:' ';
		 write:targetPoint;
		 print:' curveto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
fill
	self print:'fill'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
lineto:aPoint
	self write:aPoint; print:' lineto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
moveto:aPoint
	self write:aPoint; print:' moveto'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
newpath
	self print:'newpath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'di 8/12/2000 19:45'!
oval: aPoint
	self print: 'matrix currentmatrix'; cr;
		write: (aPoint extent // 2); space;
		write: aPoint topLeft;
		print: ' newpath translate scale 1 1 1 0 360 arc setmatrix'; cr
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'di 8/12/2000 10:22'!
preserveStateDuring: aBlock
	"Note that this method supplies self, and encoder, to the block"
	| retval |
	self print: 'gsave'; cr.
	retval _ aBlock value: self.
	self print: 'grestore'; cr.
	^ retval
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'RAA 9/16/2000 16:57'!
rect: aRect

	EPSCanvas bobsPostScriptHacks ifTrue: [self newpath].
	self
		moveto:aRect topLeft;
		lineto:aRect topRight x @ aRect topRight y;
		lineto:aRect bottomRight x @ aRect bottomRight y;
		lineto:aRect bottomLeft x @ aRect bottomLeft y;
		closepath.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
rectclip:aRect
	self write:aRect; print:' rectclip'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
rectfill:aRect
	self write:aRect; print:' rectfill'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
remapFontForSqueak:aFontName
	self print:'/'; print:aFontName; print:' adjustFontForSqueak'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
safeGrestore
	self print:'{ grestore } stopped pop'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
scale:aPoint
	self write:aPoint; print:' scale'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectflippedfont:fontname size:size
	self selectflippedfont:fontname size:size ascent:size.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectflippedfont:fontname size:size ascent:ascent
	self print:'/'; print:fontname; space; 
		print:'[ '; write:size; print:' 0 0 ';write:size negated; print:' 0 '; write:ascent; print:'] selectfont'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
selectfont:fontname size:size
	self print:'/'; print:fontname; space; write:size; print:' selectfont'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
setLinewidth:width
	self write:width; print:' setlinewidth';cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
setrgbcolor:aColor
	self write:aColor red; space;
		 write:aColor green; space;
		write:aColor blue; 
		print:' setrgbcolor'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 8/10/1930 21:34'!
showpage
	self print:'showpage'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
stroke
	self print:'stroke'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 8/10/1930 21:34'!
strokepath
	self print:'strokepath'; cr.
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
translate:aPoint
	self write:aPoint; print:' translate'; cr.

! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
writeMatrix:m
	self print:'[';
		write:m a11; print:' ';
		write:m a21; print:' ';
		write:m a12; print:' ';
		write:m a22; print:' ';
		write:m a13; print:' ';
		write:m a23; print:'] '.

! !

!PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'mpw 11/12/1999 00:46'!
writeNumber:aNumber
	super writeNumber:(aNumber isInteger ifTrue:[aNumber] ifFalse:[aNumber roundTo:0.001]).
! !

!PostscriptEncoder methodsFor: 'Postscript generation'!
writePoint:aPoint
	self write:aPoint x; space; write:aPoint y.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptEncoder class
	instanceVariableNames: ''!

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 23:07'!
clearCharacterMappings

	MacToPSCharacterMappings _ nil.! !

!PostscriptEncoder class methodsFor: 'configuring'!
filterSelector
	^#encodePostscriptOn:.! !

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 23:06'!
macToPSCharacterChart
	"mac char code, PS char code"
	^#(
		(128 999)  "€"
		(129 999)  "�"
		(130 999)  "‚"
		(131 999)  "ƒ"
		(132 999)  "„"
		(133 999)  "…"
		(134 999)  "†"
		(135 999)  "‡"
		(136 999)  "ˆ"
		(137 999)  "‰"
		(138 999)  "Š"
		(139 999)  "‹"
		(140 999)  "Œ"
		(141 999)  "�"
		(142 999)  "Ž"
		(143 999)  "�"
		(144 999)  "�"
		(145 999)  "‘"
		(146 999)  "’"
		(147 999)  "“"
		(148 999)  "”"
		(149 999)  "•"
		(150 999)  "–"
		(151 999)  "—"
		(152 999)  "˜"
		(153 999)  "™"
		(154 999)  "š"
		(155 999)  "›"
		(156 999)  "œ"
		(157 999)  "�"
		(158 999)  "ž"
		(159 999)  "Ÿ"
		(160 999)  " "
		(161 202)  "¡"
		(162 162)  "¢"
		(163 163)  "£"
		(164 167)  "¤"
		(165 183)  "¥"
		(166 182)  "¦"
		(167 251)  "§"
		(168 999)  "¨"
		(169 999)  "©"
		(170 999)  "ª"
		(171 999)  "«"
		(172 999)  "¬"
		(173 999)  "­"
		(174 225)  "®"
		(175 999)  "¯"
		(176 999)  "°"
		(177 999)  "±"
		(178 999)  "²"
		(179 999)  "³"
		(180 165)  "´"
		(181 999)  "µ"
		(182 999)  "¶"
		(183 999)  "·"
		(184 999)  "¸"
		(185 999)  "¹"
		(186 999)  "º"
		(187 227)  "»"
		(188 235)  "¼"
		(189 999)  "½"
		(190 241)  "¾"
		(191 999)  "¿"
		(192 191)  "À"
		(193 166)  "Á"
		(194 999)  "Â"
		(195 999)  "Ã"
		(196 999)  "Ä"
		(197 999)  "Å"
		(198 999)  "Æ"
		(199 171)  "Ç"
		(200 187)  "È"
		(201 188)  "É"
		(202 999)  "Ê"
		(203 999)  "Ë"
		(204 999)  "Ì"
		(205 999)  "Í"
		(206 234)  "Î"
		(207 250)  "Ï"
		(208 999)  "Ð"
		(209 999)  "Ñ"
		(210 999)  "Ò"
		(211 999)  "Ó"
		(212 999)  "Ô"
		(213 999)  "Õ"
		(214 999)  "Ö"
		(215 999)  "×"
		(216 999)  "Ø"
		(217 999)  "Ù"
		(218 999)  "Ú"
		(219 999)  "Û"
		(220 999)  "Ü"
		(221 999)  "Ý"
		(222 999)  "Þ"
		(223 999)  "ß"
		(224 999)  "à"
		(225 999)  "á"
		(226 999)  "â"
		(227 999)  "ã"
		(228 999)  "ä"
		(229 999)  "å"
		(230 999)  "æ"
		(231 999)  "ç"
		(232 999)  "è"
		(233 999)  "é"
		(234 999)  "ê"
		(235 999)  "ë"
		(236 999)  "ì"
		(237 999)  "í"
		(238 999)  "î"
		(239 999)  "ï"
		(240 999)  "ð"
		(241 999)  "ñ"
		(242 999)  "ò"
		(243 999)  "ó"
		(244 999)  "ô"
		(245 999)  "õ"
		(246 999)  "ö"
		(247 999)  "÷"
		(248 999)  "ø"
		(249 999)  "ù"
		(250 999)  "ú"
		(251 999)  "û"
		(252 999)  "ü"
		(253 999)  "ý"
		(254 999)  "þ"
		(255 999)  "ÿ"
	)! !

!PostscriptEncoder class methodsFor: 'configuring' stamp: 'RAA 9/19/2000 18:05'!
mapMacStringToPS: aString

	| copy val newVal |
	MacToPSCharacterMappings ifNil: [
		MacToPSCharacterMappings _ Array new: 256.
		self macToPSCharacterChart do: [ :pair |
			pair second = 999 ifFalse: [MacToPSCharacterMappings at: pair first put: pair second]
		].
	].
	copy _ aString copy.
	copy withIndexDo: [ :ch :index |
		(val _ ch asciiValue) > 127 ifTrue: [
			(newVal _ MacToPSCharacterMappings at: val) ifNotNil: [
				copy at: index put: newVal asCharacter
			].
		].
	].
	^copy! !
PostscriptEncoder subclass: #PostscriptEncoderToDisk
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Canvases'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PostscriptEncoderToDisk class
	instanceVariableNames: ''!

!PostscriptEncoderToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 10/12/2000 09:32'!
stream

	^self new initWithTarget: PickAFileToWriteNotification signal
! !
Object subclass: #PowerManagement
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!PowerManagement commentStamp: '<historical>' prior: 0!
This class is used to restore the VM's view of the power manage option. On the macintosh in a 3.x VM  you can  turn the power manager on or off. This may make your iBook run faster, and will prevents your macintosh from sleeping. This does consume more power so your battery life will be degraded. 

Usually you can turn processor cycling off in the control panel, but this class ensures it's off if you set the preference to turn power management off!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PowerManagement class
	instanceVariableNames: ''!

!PowerManagement class methodsFor: 'startup logic' stamp: 'JMM 2/2/2001 13:10'!
deinstall
	"PowerManagement deinstall"

	Smalltalk removeFromStartUpList: self.
! !

!PowerManagement class methodsFor: 'startup logic' stamp: 'JMM 2/2/2001 13:26'!
startUp
	[Preferences turnOffPowerManager
		ifTrue: [Smalltalk disablePowerManager]] ifError: []! !


!PowerManagement class methodsFor: 'class initialization' stamp: 'JMM 2/2/2001 13:09'!
initialize
	"PowerManagement initialize"

	Smalltalk addToStartUpList: self! !
SystemWindow subclass: #PreDebugWindow
	instanceVariableNames: 'proceedButton debugButton '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:37'!
adjustBookControls
	| inner |
	proceedButton ifNil: [^ self].
	proceedButton align: proceedButton topLeft with: (inner _ self innerBounds) topLeft + (35@-4).
	debugButton align: debugButton topRight with: inner topRight - (16@4).! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'!
debug
	model debug! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/4/1998 09:50'!
extent: newExtent
	super extent: (newExtent max: 100 @ 50).
	self adjustBookControls! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 18:06'!
initialize
	| aFont proceedLabel debugLabel aWidth |
	super initialize.
	true "Preferences optionalMorphicButtons" ifFalse:
		[(aWidth _ self widthOfFullLabelText) > 280 ifTrue: [^ self].   "No proceed/debug buttons if title too long"
		aWidth > 210
			ifTrue: "Abbreviated buttons if title pretty long"
				[proceedLabel _ 'p'.
				debugLabel _ 'd']
			ifFalse: "Full buttons if title short enough"
				[proceedLabel _ 'proceed'.
				debugLabel _ 'debug'].
		aFont _  Preferences standardButtonFont.
		self addMorph: (proceedButton _ SimpleButtonMorph new borderWidth: 0;
				label: proceedLabel font: aFont; color: Color transparent;
				actionSelector: #proceed; target: self).
		proceedButton setBalloonText: 'continue execution'.
		self addMorph: (debugButton _ SimpleButtonMorph new borderWidth: 0;
				label: debugLabel font: aFont; color: Color transparent;
				actionSelector: #debug; target: self).
		debugButton setBalloonText: 'bring up a debugger'.

		proceedButton submorphs first color: Color blue.
		debugButton submorphs first color: Color red].

	self adjustBookControls! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'!
proceed
	model proceed! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 8/14/2000 13:20'!
setBalloonTextForCloseBox
	closeBox ifNotNil:
		[closeBox setBalloonText: 'abandon this execution by closing this window'].
! !

!PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'tk 1/3/2000 12:54'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ (Smalltalk isMorphic | Preferences optionalButtons)
		ifTrue:
			[super setLabelWidgetAllowance]
		ifFalse:
			[180]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PreDebugWindow class
	instanceVariableNames: ''!

!PreDebugWindow class methodsFor: 'as yet unclassified' stamp: 'sw 11/4/1998 09:20'!
includeInNewMorphMenu
	^ false! !
Object subclass: #Preferences
	instanceVariableNames: ''
	classVariableNames: 'CategoryInfo DesktopColor FlagDictionary HelpDictionary Parameters SyntaxColorsAndStyles '
	poolDictionaries: ''
	category: 'System-Support'!
!Preferences commentStamp: '<historical>' prior: 0!
A general mechanism to store preference choices.  The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false.  It is also possible to store non-boolean data in the preference table.  sw 8/91
	To open the control panel:		Preferences openFactoredPanel

All messages are to the class.
	Preferences logDebuggerStackToFile
You can make up a new preference any time.  Do not define a new message in Preferences class.  When Preferences does not understand a selector, it looks in the flags dictionary.  It calls:
	Preferences valueOfFlag: #logDebuggerStackToFile

To set a preference,
	Preferences setPreference: #logDebuggerStackToFile toValue: false.
Or,
	Preferences disable: #logDebuggerStackToFile.
Or to turn it on,
	Preferences enable: #logDebuggerStackToFile.
!


!Preferences methodsFor: 'look in class' stamp: 'di 12/4/1999 15:11'!
seeClassSide
	"All the code for Preferences is on the class side"! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Preferences class
	instanceVariableNames: ''!

!Preferences class methodsFor: 'initialization' stamp: 'sw 2/15/2000 18:40'!
absorbAdditions
	"Preferences absorbAdditions"
	self initializeAddedPreferences.
	self initializeHelpMessages.
	self resetCategoryInfo! !

!Preferences class methodsFor: 'initialization' stamp: 'sbw 1/30/2001 19:57'!
addPreferenceForOptionalCelesteStatusPane
	"Preferences addPreferenceForOptionalCelesteStatusPane"
	(FlagDictionary includesKey: #celesteHasStatusPane)
		ifFalse: [self
				addPreference: #celesteHasStatusPane
				category: #general
				default: false
				balloonHelp: 'If true, Celeste (e-mail reader) includes a status pane.'
			"Because Lex doesn't like it the default is false :)"]! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 1/12/2000 22:34'!
allPreferenceInitializationSpecs
	"Preferences allPreferenceInitializationSpecs"
	| aList additions |
	aList _ OrderedCollection new.
	(self class organization listAtCategoryNamed: 'initial values' asSymbol) do:
		[:aSelector | aSelector numArgs = 0 ifTrue:
			[additions _ self perform: aSelector.
			(additions isKindOf: Collection) ifFalse: [self error: 'method in "initial values" categories must return collections'].
			aList addAll: additions]].
	^ aList
			! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:03'!
callHelpMessageInitializers
	| listOfPairs |
	"Preferences callHelpMessageInitializers"
	(self class organization listAtCategoryNamed: #help) do:
		[:aSelector | aSelector numArgs = 0 ifTrue:
			[((listOfPairs _ self perform: aSelector) isKindOf: Collection)
				ifTrue:
					[listOfPairs do:
						[:pair | HelpDictionary at: pair first put: 
					(pair first, ':
		', pair last)]]]]! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:17'!
chooseInitialSettings
	"Restore the default choices for Preferences."
	"Preferences chooseInitialSettings"

	self allPreferenceInitializationSpecs do:
		[:aSpec |
			aSpec second == #true
				ifTrue:
					[self enable: aSpec first]
				ifFalse:
					[self disable: aSpec first]].
	self resetCategoryInfo

! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 7/1/1999 23:17'!
compileAccessMethodFor: prefSymbol
	self class compileProgrammatically: (prefSymbol, '
	^ self valueOfFlag: #', prefSymbol) classified: 'standard preferences'! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 9/19/1998 22:47'!
initialize
	"Preferences initialize"
	"Sometimes placed in a change-set even though unchanged, to trigger reinitialization upon update."

	FlagDictionary _ Dictionary new.
	self chooseInitialSettings.
! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:16'!
initializeAddedPreferences
	"Initialize any preference not yet known to the prefs dictionary as per descriptions in the 'initial values' category, but don't change the setting of any existing preference.
	Also, compile accessor methods for retrieving any preference that lacks one"

	"Preferences initializeAddedPreferences"

	| sym |
	self allPreferenceInitializationSpecs do:
		[:triplet |
			(self class selectors includes: (sym _ triplet first))
				ifFalse:
					[self compileAccessMethodFor: sym].
			(FlagDictionary includesKey: sym) ifFalse:
				[triplet second == #true
					ifTrue:
						[self enable: sym]
					ifFalse:
						[self disable: sym]]].
	self resetCategoryInfo

! !

!Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 13:49'!
initializeHelpMessages
	"Preferences initializeHelpMessages"
  	HelpDictionary _ Dictionary new.
	self callHelpMessageInitializers! !


!Preferences class methodsFor: 'parameters' stamp: 'sw 2/24/1999 12:26'!
acceptAnnotationsFrom: aSystemWindow
	"This intricate extraction is based on the precise structure of the annotation-request window.  Kindly avert your eyes."
	| aList |
	aList _ aSystemWindow paneMorphs first firstSubmorph submorphs collect:
		[:m |  m contents asSymbol].
	self defaultAnnotationRequests: aList
	! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 1/4/2001 10:25'!
annotationInfo 
	"Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help"

	^ #(

		(timeStamp			'The time stamp of the last submission of the method.')
		(firstComment		'The first comment in the method, if any.')
		(messageCategory	'Which method category the method lies in')
		(sendersCount		'A report of how many senders there of the message.')
		(implementorsCount	'A report of how many implementors there are of the message.')
		(recentChangeSet	'The most recent change set bearing the method.')
		(allChangeSets		'A list of all change sets bearing the method.')
		(priorVersionsCount	'A report of how many previous versions there are of the method' )
		(priorTimeStamp		'The time stamp of the penultimate submission of the method, if any'))! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/15/1999 19:44'!
borderColorWhenRunning
	^ Color green! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/15/1999 19:45'!
borderColorWhenStopped
	^ Color red! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:40'!
defaultAnnotationRequests
	^ Parameters at: #MethodAnnotations ifAbsent:
		[self setDefaultAnnotationInfo]
	"Preferences annotationInfo"! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/8/1999 10:14'!
defaultAnnotationRequests: newList
	^ Parameters at: #MethodAnnotations put: newList! !

!Preferences class methodsFor: 'parameters' stamp: 'sma 6/1/2000 12:08'!
defaultAuthorName
	"Answer the author name to be planted, by default, in a changeset-preamble template.  You can hard-code this to hold your name, thus saving you time when writing the preambles of subsequent changesets"

	^ Utilities authorName! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/1/2000 14:05'!
defaultPaintingExtent
	"Answer the preferred size for the onion-skin paint area when launching a new painting within a paste-up morph.  Feel free to change the parameters to suit your configuration."

	^ 800 @ 600! !

!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'!
desktopColor
	"Answer the desktop color. Initialize it if necessary."
	
	DesktopColor == nil ifTrue: [DesktopColor _ Color gray].
	^ DesktopColor
! !

!Preferences class methodsFor: 'parameters' stamp: 'jhm 10/15/97 17:31'!
desktopColor: aColor
	"Record a new desktop color preference."

	DesktopColor _ aColor.
! !

!Preferences class methodsFor: 'parameters' stamp: 'mir 1/4/2001 11:07'!
editAnnotations
	"Preferences editAnnotations"
	| aPanel ins outs current aMorph aWindow aButton info pair |
	Smalltalk isMorphic
		ifFalse:
			[^ self inform: 
'Sorry, you must be in a morphic
project to use this feature.'].
	aPanel _ AlignmentMorph newRow extent: 300 @ 100.
	ins _ AlignmentMorph newColumn extent: 150 @ 100.
	ins enableDrop: true; beSticky.
	ins color: Color green muchLighter.
	outs _ ins fullCopy.
	outs color: Color red muchLighter.
	aPanel addMorph: outs; addMorphFront: ins.
	outs position: (ins position + (200 @ 0)).
	current _ self defaultAnnotationRequests.
	info _ self annotationInfo.
	current do:
		[:sym | pair _ info detect: [:aPair | aPair first == sym].
		aMorph _ StringMorph new contents: pair first.
		aMorph setBalloonText: pair last.
		aMorph enableDrag: true.
		aMorph
			on: #startDrag
			send: #startDrag:with:
			to: aMorph.
		ins addMorphBack: aMorph].
	info do:
		[:aPair | 
			(current includes: aPair first) 
				ifFalse:
					[aMorph _ StringMorph new contents: aPair first.
					aMorph setBalloonText: aPair last.
					aMorph enableDrag: true.
					aMorph
						on: #startDrag
						send: #startDrag:with:
						to: aMorph.
					outs addMorph: aMorph]].
	aPanel layoutChanged.
	aWindow _ SystemWindowWithButton new setLabel: 'Annotations'.
	aButton _ SimpleButtonMorph new target: Preferences;
		actionSelector: #acceptAnnotationsFrom:; arguments: (Array with: aWindow); label: 'apply'; borderWidth: 0; borderColor: Color transparent; color: Color transparent.
	aButton submorphs first color: Color blue.
	aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'.
	aWindow buttonInTitle: aButton; adjustExtraButton.
	self currentHand attachMorph: (aPanel wrappedInWindow: aWindow)
! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 9/7/1999 12:45'!
initializeParameters
	"Preferences initializeParameters"
	Parameters _ IdentityDictionary new.
	self restoreDefaultMenuParameters.
	Parameters at: #maxBalloonHelpLineLength put: 28.
	self initializeTextHighlightingParameters! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 1/24/2001 21:44'!
inspectParameters
	"Open up an inspector on the Parameters of Preferences.  This is crude!!"

	Parameters inspectWithLabel: 'Parameters'! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 11/5/1998 16:49'!
maxBalloonHelpLineLength
	^ Parameters at: #maxBalloonHelpLineLength! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 1/27/2000 23:02'!
parameterAt: aKey
	^ Parameters at: aKey ifAbsent: [nil]! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 3/28/2000 13:38'!
parameterAt: aKey default: defaultValueBlock
	"Return the Parameter setting at the given key.  If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value"

	^ Parameters at: aKey ifAbsent: [Parameters at: aKey put: defaultValueBlock value]! !

!Preferences class methodsFor: 'parameters'!
scrollBarColor
	"Answer the preferred color for scroll bar elevators."

	^ Color gray! !

!Preferences class methodsFor: 'parameters'!
scrollBarWidth
	"Answer the preferred width for scroll bars."

	^ 8! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/17/1999 00:41'!
setDefaultAnnotationInfo
	"Preferences setDefaultAnnotationInfo"
	^ Parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount allChangeSets)! !

!Preferences class methodsFor: 'parameters' stamp: 'stp 01/13/2000 13:29'!
setParameter: paramName to: paramValue
	"Set the given field in the parameters dictionary."

	Parameters at: paramName put: paramValue! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/8/1999 09:37'!
viewerEditingPaneHeight
	^ 60! !

!Preferences class methodsFor: 'parameters' stamp: 'sw 2/8/1999 09:38'!
viewerEditingPaneWidth
	^ 400! !


!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 14:11'!
deletePreference: preferenceNameSymbol

	FlagDictionary removeKey: preferenceNameSymbol ifAbsent: [^ self].
	self resetCategoryInfo
! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 10/8/1998 12:46'!
deletePreferenceIfFalse: aSymbol
	"If aSymbol is currently in the FlagDictionary and the corresponding value is currently false, then remove that element from the dictionary.  The result is that the preference will remain false when interrogated from the outside, but it will not show up in a Preferences control panel.  This keeps obscure preferences from distracting the user"

	| val |
	val _ FlagDictionary at: aSymbol ifAbsent: [^ self].
	val == false ifTrue: [self deletePreference: aSymbol]! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:52'!
disable: preferenceNameSymbol
	"Shorthand access"
	self setPreference: preferenceNameSymbol toValue: false.
	self resetCategoryInfo "in case this call introduced a new pref"! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:51'!
disableGently: preferenceNameSymbol
	"Unlike #disable:, this on does not reset the CategoryInfo cache"
	self setPreference: preferenceNameSymbol toValue: false! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 11/11/1998 11:40'!
doesNotUnderstand: aMessage
	"Look up the message selector as a flag."
	aMessage arguments size > 0 ifTrue: [^ super doesNotUnderstand: aMessage].
	^ self valueOfFlag: aMessage selector
! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:53'!
enable: preferenceNameSymbol
	"Shorthand access"
	self setPreference: preferenceNameSymbol toValue: true.
	self resetCategoryInfo  "in case this call introduced a new pref"! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:53'!
enableGently: preferenceNameSymbol
	"Unlike #enable:, this one does not reset the CategoryInfo cache"
	self setPreference: preferenceNameSymbol toValue: true! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 8/12/2000 01:26'!
enableOrDisable: preferenceNameSymbol asPer: aBoolean
	"either enable or disable the given Preference, depending on the value of aBoolean"

	aBoolean ifTrue: [self enable: preferenceNameSymbol] ifFalse: [self disable: preferenceNameSymbol]! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 10/5/1998 13:09'!
inspectPreferences
	"Open a window on the current preferences dictionary, allowing the user to inspect and change the current preference settings.  This is fallen back upon if Morphic is not present"
	"Preferences inspectPreferences"

	FlagDictionary inspectWithLabel: 'Preferences'
! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/30/2001 19:58'!
noteThatFlag: prefSymbol justChangedTo: aBoolean
	"Provides a hook so that a user's toggling of a preference might precipitate some immediate action"
	| keep |
	prefSymbol == #useGlobalFlaps ifTrue:
		[aBoolean
			ifFalse:		"Turning off use of flaps"
				[keep _ self confirm:
'Do you want to preserve the existing
global flaps for future use?'.
				Utilities globalFlapTabsIfAny do:
					[:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: keep.
					aFlapTab isInWorld ifTrue: [self error: 'Flap problem']].
				keep ifFalse: [Utilities clobberFlapTabList]]

			ifTrue:		"Turning on use of flaps"
				[Smalltalk isMorphic ifTrue:
					[self currentWorld addGlobalFlaps]]].

	prefSymbol == #roundedWindowCorners ifTrue: [Display repaintMorphicDisplay].

	prefSymbol == #optionalButtons ifTrue:
		[Utilities replacePartSatisfying: [:el | (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isKindOf: FileList]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  FileList openAsMorph applyModelExtent].

	(prefSymbol == #optionalButtons  or: [prefSymbol == #annotationPanes]) ifTrue:
		[Utilities replaceBrowserInToolsFlap].

	(prefSymbol == #smartUpdating) ifTrue:
		[SystemWindow allSubInstancesDo:
			[:aWindow | aWindow amendSteppingStatus]].

	(prefSymbol == #eToyFriendly) ifTrue:
		[ScriptingSystem customizeForEToyUsers: aBoolean].

	((prefSymbol == #infiniteUndo) and: [aBoolean not]) ifTrue:
		[CommandHistory resetCommandHistory]! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 10/5/1998 13:10'!
openPreferencesInspector
	"Open a window on the current set of preferences choices, allowing the user to view and change their settings"
	
	Smalltalk hasMorphic
		ifFalse:	[self inspectPreferences]
		ifTrue:	[self openPreferencesControlPanel]! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/13/2000 12:28'!
orphanedHelpEntries
	"Answer a list of all the keys in the help dictionary that are not represented by actual preferences"

	^ HelpDictionary keys asSortedArray copyWithoutAll: self allPreferenceFlagKeys

"Preferences orphanedHelpEntries"! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/13/2000 11:12'!
preferencesLackingHelp
	^ self allPreferenceFlagKeys select:
		[:aKey | (self helpMessageOrNilForPreference: aKey) == nil]

"Preferences preferencesLackingHelp"! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/13/2000 11:49'!
preferencesLackingInitializers
	^ self allPreferenceFlagKeys copyWithoutAll: (self allPreferenceInitializationSpecs collect: [:info | info first])

"Preferences preferencesLackingInitializers"! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/12/2000 18:33'!
rawSetPreference: prefSymbol toValue: aBoolean
	"Set the given preference to the given value, without further ado"
	FlagDictionary at: prefSymbol put: aBoolean
! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'tk 6/30/2000 08:21'!
setPreference: prefSymbol toValue: aBoolean
	(FlagDictionary at: prefSymbol ifAbsent: [nil]) == aBoolean
		ifFalse:
			[FlagDictionary at: prefSymbol put: aBoolean.
			self noteThatFlag: prefSymbol justChangedTo: aBoolean].
	^ aBoolean! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'jhm 10/15/97 17:12'!
valueOfFlag: aFlagName

	^ FlagDictionary at: aFlagName ifAbsent: [false]
! !

!Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 8/29/2000 16:12'!
wantsChangeSetLogging
	"Answer whether method changes in the receiver should be logged to current change set.  This circumlocution avoids such logging for programmatically-compiled methods in Preferences, removing an annoyance"

	^ Utilities authorInitialsPerSe  ~= 'programmatic'! !


!Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/13/2000 11:07'!
helpMessageForPreference: aSymbol
	^ (self helpMessageOrNilForPreference: aSymbol) ifNil:
		['No help available for ', aSymbol]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/13/2000 11:07'!
helpMessageOrNilForPreference: aSymbol
	"If the HelpDictionary has a help message prepared for aSymbol, return it, else return nil"
	HelpDictionary ifNil: [self initializeHelpMessages].
	^ HelpDictionary at: aSymbol ifAbsent: [nil]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 9/15/1999 09:15'!
initialExtent
	^ (Preferences inboardScrollbars and: [Smalltalk isMorphic])
		ifFalse:
       		[219 @ 309]
		ifTrue:
			[232 @ 309]! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/19/2000 15:15'!
openPreferencesControlPanel
	"Preferences openPreferencesControlPanel"
	| aPanel aWindow aRow wrapper but aList odd aColor w width1 width2 spacer |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self beep].
	true ifTrue: [^ self openFactoredPanel].

	"What follows below is the former (pre-2.8alpha) implementation of the prefs panel"

	aPanel _ AlignmentMorph newColumn.
	aPanel beSticky.
	aList _ OrderedCollection new.
	FlagDictionary associationsDo: [:assoc | aList add: (Array
				with: assoc key
				with: assoc value
				with: (self helpMessageForPreference: assoc key))].
	odd _ false.
	width1 _ 172.
	spacer _ 4.
	width2 _ 14.
	(aList asSortedCollection: [:a :b | a first < b first])
		do: 
			[:triplet | 
			aPanel addMorphBack: (aRow _ AlignmentMorph newRow).
			aRow color: (aColor _ odd
							ifTrue: [Color green muchLighter]
							ifFalse: [Color red veryMuchLighter]).
			odd _ odd not.
			aRow addMorph: (wrapper _ Morph new color: aColor).
			wrapper setBalloonText: triplet third.
			wrapper extent: width1 @ 15.
			wrapper addMorph: (StringMorph new contents: triplet first).
			aRow addMorphBack: (Morph new color: aColor; extent: (spacer @ 15)).
			aRow addMorphBack: (wrapper _ Morph new color: aColor).
			wrapper extent: width2 @ 15.
			wrapper addMorphBack: (but _ UpdatingBooleanStringMorph new contents: triplet second printString).
			but getSelector: triplet first;
			putSelector: #setPreference:toValue:;
			stepTime: 1800;
			 target: self].
		wrapper _ ScrollPane new.
		wrapper scroller addMorph: aPanel.
	Smalltalk isMorphic
		ifTrue:
			[aWindow _ SystemWindow new model: self.
			aWindow addMorph: wrapper frame: (0 @ 0 extent: 1 @ 1).
			aWindow setLabel: 'Preferences'.
			aWindow openInWorld] 
		ifFalse:
			[(w _ MVCWiWPasteUpMorph newWorldForProject: nil)
						addMorph: wrapper.
			wrapper
				retractable: false;
				extent: self initialExtent + (wrapper scrollbarWidth @ 0).
			w startSteppingSubmorphsOf: wrapper.
			MorphWorldView openOn: w
				label: 'Preferences'
				extent: w fullBounds extent]
! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 10/1/1998 16:55'!
scriptPerformer
	^ self! !

!Preferences class methodsFor: 'preferences panel' stamp: 'sw 11/11/1998 16:39'!
setHelpFor: prefName toString: aString
	HelpDictionary ifNil: [self initializeHelpMessages].
	HelpDictionary at: prefName put: aString! !


!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:16'!
menuBorderColor
	Display depth <= 2 ifTrue: [^ Color black].
	^ Parameters at: #menuBorderColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'!
menuBorderWidth
	^ Parameters at: #menuBorderWidth! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:17'!
menuColor
	Display depth <= 2 ifTrue: [^ Color white].
	^ Parameters at: #menuColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:37'!
menuLineLowerColor
	^ Parameters at: #menuLineLowerColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:36'!
menuLineUpperColor
	^ Parameters at: #menuLineUpperColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:19'!
menuTitleBorderColor
	Display depth <= 2 ifTrue: [^ Color black].
	^ Parameters at: #menuTitleBorderColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'!
menuTitleBorderWidth
	^ Parameters at: #menuTitleBorderWidth! !

!Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:18'!
menuTitleColor
	Display depth = 1 ifTrue: [^ Color white].
	Display depth = 2 ifTrue: [^ Color gray].
	^ Parameters at: #menuTitleColor! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:33'!
restoreDefaultMenuParameters
	"Preferences restoreDefaultMenuParameters"
	"Restore the four color choices of the original implementors of MorphicMenus"

	Parameters at: #menuColor put: (Color r: 0.8 g: 0.8 b: 0.8).
	Parameters at: #menuBorderColor put: #raised.
	Parameters at: #menuBorderWidth put: 2.

	Parameters at: #menuTitleColor put: (Color r: 0.5 g: 1 b: 0.75).
	Parameters at: #menuTitleBorderColor put: #inset.
	Parameters at: #menuTitleBorderWidth put: 1.

	Parameters at: #menuLineUpperColor put: (Color r: 0.667 g: 0.667 b: 0.667).
	Parameters at: #menuLineLowerColor put: (Color r: 0.833 g: 0.833 b: 0.833).! !

!Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:38'!
setAltMenuChoices
	"Preferences setAltMenuChoices"
	Parameters at: #menuTitleColor put: (Color r: 0.4 g: 0.8 b: 0.9).
	Parameters at: #menuColor put: (Color r: 0.97 g: 0.97 b: 0.97).
	Parameters at: #menuTitleBorderColor put: Color blue muchLighter.
	Parameters at: #menuBorderColor put: Color blue lighter.

	Parameters at: #menuLineUpperColor put: Color blue lighter.
	Parameters at: #menuLineLowerColor put: (Color r: 0.97 g: 0.97 b: 0.97)! !


!Preferences class methodsFor: 'hard-coded prefs' stamp: 'ar 1/31/2001 17:06'!
browseToolClass
	^ Preferences browserShowsPackagePane
		ifTrue:
			[PackagePaneBrowser]
		ifFalse:
			[Browser]! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'di 4/5/2000 08:36'!
browseWithPrettyPrint
	^ self printAlternateSyntax or: [self valueOfFlag: #browseWithPrettyPrint]! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'!
cmdGesturesEnabled
	"compiled programatically -- return hard-coded preference value"
	^ true! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'!
cmdKeysInText
	"compiled programatically -- return hard-coded preference value"
	^ true! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 2/15/1999 19:36'!
colorTilesEnabled
	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 12/1/1999 13:04'!
debugMenuItemsInvokableFromScripts
	"If true, then items occurring in an object's debug menu will be included in the alternatives offered as arguments to a doMenuItem: tile in the scripting system"
	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 9/6/2000 05:26'!
desktopMenuTitle
	"Answer the title to be used for the 'meta menu'.  For now, you can hard-code this, later someone should make this be a parameter the user can easily change.  sw 9/6/2000"

	^ 'World'    "This is what it has always been"

	"^ 'Desktop'
	^ 'Squeak'
	^ 'Mike''s Control Panel'"! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 4/25/2000 14:07'!
isFlagship
	"Manually change this to return true if you wish your system to be marked as a 'flagship'.  The intent here is to allow an update to query this flag before undertaking some radical do-it that might clobber important content is such an image."

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/18/2000 13:26'!
metaMenuDisabled
	"If true, then click/cmd-click on the desktop will not bring up the World menu.  Can be changed manually right here, and can be programattically changed via a call of the following form:

	Preferences compileHardCodedPref: #metaMenuDisabled enable: true"

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/29/2000 15:01'!
preserveCommandExcursions
	"An architecture is in place for storing command excursions to which access is otherwise cut off by having taken a variant branch, but it is not accessible unless you hand-code this preference to true -- which I suggest you do only with fingers crossed."

	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 2/16/1999 11:24'!
useCategoryListsInViewers
	"Temporarily hard-coded pending viewer work underway"
	^ false! !

!Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 2/16/1999 11:24'!
useScrollingInPartsLists
	"Temporarily hard-coded pending viewer work underway"
	^ false "true"! !


!Preferences class methodsFor: 'pref buttons' stamp: 'sw 2/7/2000 11:30'!
buttonRepresenting: prefSymbol wording: aString color: aColor
	"self currentHand attachMorph: (Preferences buttonRepresenting: #balloonHelpEnabled wording: 'Balloon Help' color: nil)"
	"Return a button that controls the setting of prefSymbol.  It will keep up to date even if the preference value is changed in a different place"
	| outerButton aButton str aHelp miniWrapper |
	(FlagDictionary includesKey: prefSymbol) ifFalse: [self error: 'Unknown preference: ', prefSymbol printString].
	outerButton _ AlignmentMorph newRow height: 24.
	outerButton color:  (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]).
	outerButton hResizing: #spaceFill; vResizing: #shrinkWrap.
	outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox).
	aButton
		target: self;
		actionSelector: #togglePreference:;
		arguments: (Array with: prefSymbol);
		target: Preferences;
		getSelector: prefSymbol.

	outerButton addTransparentSpacerOfSize: (2 @ 0).
	str _ StringMorph contents: aString font: (StrikeFont familyName: 'NewYork' size: 12).
	miniWrapper _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	miniWrapper beTransparent addMorphBack: str lock.
	outerButton addMorphBack: miniWrapper.
	aButton setBalloonText: (aHelp _ Preferences helpMessageForPreference: prefSymbol).
	miniWrapper setBalloonText: aHelp; setProperty: #balloonTarget toValue: aButton.

	^ outerButton! !

!Preferences class methodsFor: 'pref buttons' stamp: 'sw 7/13/1999 18:55'!
togglePreference: prefSymbol
	| curr |
	curr _ (FlagDictionary at: prefSymbol ifAbsent: [^ self error: 'unknown pref: ', prefSymbol printString]).
	self setPreference: prefSymbol toValue: (curr == true) not

! !


!Preferences class methodsFor: 'misc' stamp: 'sw 10/6/1999 15:20'!
addModelItemsToWindowMenu: aMenu
	aMenu addLine.
	aMenu add: 'restore default preference settings' target: self action: #chooseInitialSettings.
	aMenu add: 'restore default text highlighting' target: self action: #initializeTextHighlightingParameters! !

!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'!
menuColorString
	^ (self valueOfFlag: #menuColorFromWorld)
		ifFalse:
			['start menu-color-from-world']
		ifTrue:
			['stop menu-color-from-world']! !

!Preferences class methodsFor: 'misc' stamp: 'sw 11/30/1999 22:23'!
roundedCornersString
	^ ((self valueOfFlag: #roundedWindowCorners)
		ifFalse:
			['start']
		ifTrue:
			['stop']), ' rounding window corners'! !

!Preferences class methodsFor: 'misc' stamp: 'sw 1/4/2001 06:56'!
setFlag: prefSymbol toValue: aBoolean during: aBlock
	"Set the flag to the given value for the duration of aBlock"

	| existing |
	existing _ self valueOfFlag: prefSymbol.
	existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: aBoolean].
	aBlock value.
	existing == aBoolean ifFalse: [self setPreference: prefSymbol toValue: existing]! !

!Preferences class methodsFor: 'misc' stamp: 'sw 1/12/2000 22:41'!
soundEnablingString
	^ self soundsEnabled
		ifFalse:
			['turn sound on']
		ifTrue:
			['turn sound off']! !

!Preferences class methodsFor: 'misc' stamp: 'sw 9/21/2000 22:53'!
staggerPolicyString
	"Answer the string to be shown in a menu to represent the stagger-policy status"

	^ (self valueOfFlag: #reverseWindowStagger)
		ifTrue: ['<yes>stagger windows']
		ifFalse: ['<no>stagger windows']! !

!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:51'!
toggleMenuColorPolicy
	self togglePreference: #menuColorFromWorld! !

!Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'!
toggleRoundedCorners
	self togglePreference: #roundedWindowCorners! !

!Preferences class methodsFor: 'misc' stamp: 'ssa 2/9/2000 11:01'!
toggleSoundEnabling
     self togglePreference: #soundsEnabled! !

!Preferences class methodsFor: 'misc' stamp: 'sw 6/11/1999 20:49'!
toggleWindowPolicy
	self togglePreference: #reverseWindowStagger! !


!Preferences class methodsFor: 'personalization' stamp: 'sw 7/1/1999 23:07'!
compileHardCodedPref: prefName enable: aBoolean
	"Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message"

	self class compileProgrammatically: (prefName asString, '
	"compiled programatically -- return hard-coded preference value"
	^ ', aBoolean storeString) classified: 'hard-coded prefs'.
	
"Preferences compileHardCodedPref: #testing enable: false"! !

!Preferences class methodsFor: 'personalization' stamp: 'sw 6/29/1999 13:53'!
disableProgrammerFacilities
	"Warning: do not call this lightly!!  It disables all access to menus, debuggers, halos.  There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. 

     You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method.

	To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities.  To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu:

         Preferences disableProgrammerFacilities.

You will be prompted for a new image name under which to save the resulting image."

	self beep.
	(self confirm: 'CAUTION!!!!
This is a drastic step!!
Do you really want to do this?')
		ifFalse:
			[self beep.  ^ self inform: 'whew!!'].

	self disable: #cmdDotEnabled.       "No user-interrupt-into-debugger"

	self compileHardCodedPref: #cmdGesturesEnabled enable: false.  "No halos, etc."

	self compileHardCodedPref: #cmdKeysInText enable: false.    "No user commands invokable via cmd-key combos in text editor"

	self enable: #noviceMode.           "No control-menu"
	self disable: #warnIfNoSourcesFile.
	self disable: #warnIfNoChangesFile.
	Smalltalk saveAs! !

!Preferences class methodsFor: 'personalization' stamp: 'sw 6/29/1999 13:55'!
enableProgrammerFacilities
	"Meant as a one-touch recovery from a #disableProgrammerFacilities call."
	"Preferences enableProgrammerFacilities"

	self enable: #cmdDotEnabled.
	self compileHardCodedPref: #cmdGesturesEnabled enable: true. 
	self compileHardCodedPref: #cmdKeysInText enable: true.
	self disable: #noviceMode.
	self enable: #warnIfNoSourcesFile.
	self enable: #warnIfNoChangesFile.! !

!Preferences class methodsFor: 'personalization' stamp: 'bf 9/22/1999 13:22'!
letUserPersonalizeMenu
	"Invoked from menu, opens up a single-msg browser on the message that user is invited to customize for rapid morphic access via option-click on morphic desktop"

	Browser openMessageBrowserForClass: Preferences class 
		selector: #personalizeUserMenu: editString: nil! !

!Preferences class methodsFor: 'personalization' stamp: 'bf 9/22/1999 14:05'!
personalizeUserMenu: aMenu
	"The user has clicked on the morphic desktop with the yellow mouse button (option+click on the Mac); a menu is being constructed to present to the user in response; its default target is the current world.  In this method, you are invited to add items to the menu as per personal preferences.
	The default implementation, for illustrative purposes, sets the menu title to 'personal', and adds items for go-to-previous-project, show/hide flaps, and load code updates"
	
	aMenu addTitle: 'personal'.  "Remove or modify this as per personal choice"

	aMenu add: 'previous project' action: #goBack.
	aMenu addUpdating: #suppressFlapsString target: Utilities action: #toggleFlapSuppressionInProject.
	aMenu add: 'load latest code updates' target: Utilities action: #updateFromServer! !


!Preferences class methodsFor: 'help' stamp: 'sw 1/14/2000 16:06'!
helpMsgsAThroughF
	"This, and the other methodds in this category, are automatically called whenever you call

   	Preferences initializeHelpMessages
		or
	Preferences callHelpMessageInitializers
"

	^ #( 
(autoAccessors
	'If true, an attempt to call a message which is not understood by an object but whose selector is the same as an inst var of the object will result in automatic compilation of an accessor method for that object''s class')

(automaticViewerPlacement
	'If true, new viewers are automatically positioned near the objects they view; if false, new viewers are attached to the hand, from whence you much choose a destination for them')

(annotationPanes
	'If true, a thin horizontal annotation pane is used in browsers.')

(balloonHelpEnabled
	'Whether balloon help should be offered when the cursor lingers over certain objects.')

(browserShowsPackagePane
	'If true, then the various ''browse full'' and ''browse it'' commands (usually invoked via cmd-b) will open a Package Browser rather than a System Browser.  The Package Browser includes a package pane which groups system categories into packages based on the initial portion of their category name.')

(browseWithPrettyPrint
	'If true, browsers will automatically format their contents')

(cautionBeforeClosing 
	'If true, Morphic windows seen in an mvc project will put up a warning before allowing themselves to be dismissed')

(caseSensitiveFinds
	'If true, then the "find" command in text will always make its searches in a case-sensitive fashion')

(changeSetVersionNumbers
	'If true, version-number extensions will be used when constructing names for change-set fileouts.  If false, timestamp extensions are used.')

(checkForSlips 
	'If true, then whenever you file out a change set, it is checked for ''slips'' and if any are found, you are so informed and given a chance to open a browser on them')

(clickOnLabelToEdit
	'If true, a click on the label of a system window lets you edit it; if false, allow dragging of system windows when clicking on the label')

(cmdDotEnabled
	'If true, cmd-dot brings up a debugger;
if false, the cmd-dot interrupt is disabled')

(colorWhenPrettyPrinting
	'If true, then when browseWithPrettyPrint is in effect, the pretty-printing will be presented in color')

(compressFlashImages
	'If true, flash images will automatically be reduced to 8-bit color depth upon being read')

(confirmFirstUseOfStyle
'If true, the first attempt to submit a method with non-standard style will bring up a confirmation dialog')

(conversionMethodsAtFileOut
	'Governs whether at fileout time you should be prompted to define conversion methods where deemed appropriate.')

(debugHaloHandle 
'If true, a special debugging halo handle is displayed at the right of the halo; if false, no such handle is shown.')

(diffsInChangeList
	'If true, changeList browsers and Versions browsers will open up by default showing diffs, i.e. revealing the differences between successive versions or between the in-memory code and the code on disk')

(editPlayerScriptsInPlace 
	'If true, textual player scripts are edited in place in Scriptors (still imperfectly implemented)')

(eToyScheme
	'If true, new scripting spaces place the Playfield to the left and the the palette to the right of the window; if false, the opposite is true.')

(extractFlashInHighQuality
	'Whether flash graphics should be extracted in high quality.')
(extractFlashInHighestQuality
	'Whether flash graphics should be extracted in highest possible quality.')

(fastDragWindowForMorphic
	'If true, morphic window drag will be done by dragging an outline of the window.')

(fenceEnabled
	'Whether an object obeying motion scripts should stop moving when it reaches the edge of its container.')

) 
! !

!Preferences class methodsFor: 'help' stamp: 'mir 5/16/2000 16:32'!
helpMsgsAddition4sr
	^ #(
(browseWithDragNDrop
	'If true, drag&drop browsing is enabled, new Browser are opened with drag&drop functionality (only in Morphic).')
)

! !

!Preferences class methodsFor: 'help' stamp: 'sw 2/15/2000 18:39'!
helpMsgsAdditionA
	"This, and the other methodds in this category, are automatically called whenever you call

   	Preferences initializeHelpMessages
		or
	Preferences callHelpMessageInitializers
"

	^ #( 
(simpleMenus
	'If true, simpler menus are presented.')
)
	"Preferences resetCategoryInfo"


! !

!Preferences class methodsFor: 'help' stamp: 'mir 5/16/2000 11:51'!
helpMsgsAdditionDnd
	^ #(
(dragNDropWithAnimation
	'If true, drag&drop is animated.')
)

! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 6/13/2000 11:52'!
helpMsgsAdditionbrowsingalternativeBrowseIt
	^ #((alternativeBrowseIt 'if true, then the "browse it" (cmd-b) feature in the text editor will offer you a list of class names matching the selection, if appropriate' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:17'!
helpMsgsAdditionbrowsingdecorateBrowserButtons
	^ #((decorateBrowserButtons 'Governs whether certain buttons, such as the Inheritance button, should bear colors that provide user feedback on their applicability' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:13'!
helpMsgsAdditionbrowsingdiffsWithPrettyPrint
	^ #((diffsWithPrettyPrint 'if true, displays of source code differences will be pretty-printed first' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:16'!
helpMsgsAdditionbrowsingsourceCommentToggleInBrowsers
	^ #((sourceCommentToggleInBrowsers 'If true, then optional button panes in code browsers in morphic will exhibit a checkbox labeled "source" which allows the user to toggle between viewing source code and just viewing method comments' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:14'!
helpMsgsAdditiondebugdebugShowDamage
	^ #((debugShowDamage 'If true, every changed region of the morphic display will be flashed black before updating.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/4/2001 01:05'!
helpMsgsAdditiongeneralautomaticPlatformSettings
	^ #((automaticPlatformSettings 'If true, certain preferences are automatically set according to the current platform.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/4/2001 01:05'!
helpMsgsAdditiongeneralcelesteHasStatusPane
	^ #((celesteHasStatusPane 'If true, Celeste (e-mail reader) includes a status pane.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:53'!
helpMsgsAdditiongeneralcheckForUnsavedProjects
	^ #((checkForUnsavedProjects 'If enabled, then ask before quitting Squeak if there are unsaved projects (the definition of unsaved is fuzzy at the moment and this preference may not be honored everywhere)' ) )! !

!Preferences class methodsFor: 'help' stamp: 'di 12/12/2000 13:32'!
helpMsgsAdditiongeneralinfiniteUndo
	^ #((infiniteUndo 'if true, then where supported you will be able to roll back to prior states via repeated uses of undo.  Undo history will be purged at save/quit' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:47'!
helpMsgsAdditiongeneralmodalColorPickers
	^ #((modalColorPickers 'If true, color choices in Morphic will be made via color-pickers that take control of the mouse and immediately return the color selected upon mouseup' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:58'!
helpMsgsAdditiongeneralprojectViewsInWindows
	^ #((projectViewsInWindows 'New Project view are created in a system window.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:47'!
helpMsgsAdditiongeneraluseUndo
	^ #((useUndo 'if true, then undo will generally be available in morphic' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:14'!
helpMsgsAdditionhalosshowBoundsInHalo
	^ #((showBoundsInHalo 'If true, halos will include a fine rectangle around the bounds of the target morph.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:52'!
helpMsgsAdditionhalosshowDirectionForSketches
	^ #((showDirectionForSketches 'If enabled, direction handles are always shown for SketchMorphs.  If disabled, direction handles can be shown by the ''show direction handles'' command in the red menu.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:52'!
helpMsgsAdditionhalosshowDirectionHandles
	^ #((showDirectionHandles 'If enabled, direction handles are always shown with halos.  If disabled, direction handles can be shown by the ''show direction handles'' command in the red menu.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:45'!
helpMsgsAdditionhalosuniqueNamesInHalos
	^ #((uniqueNamesInHalos 'if true, then when you put up a halo for any morph, it is assigned a unique name (if it doesn''t already have one) which will stick with it.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/4/2001 01:05'!
helpMsgsAdditionmediasoundStopWhenDone
	^ #((soundStopWhenDone 'If true, the sound player is shut down after playing finished.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 6/13/2000 11:52'!
helpMsgsAdditionmorphicokToReinitializeFlaps
	^ #((okToReinitializeFlaps 'if true, then then code in updates will feel free to reinitialize the global flaps; if false, flaps will never be reinitialized by updates -- thus, set it to false if you have a serious investment in the content of the global flaps in your configuration, strong enough that you don''t want your flaps modernized when advances would otherwise indicate a need to' ) )! !

!Preferences class methodsFor: 'help'!
helpMsgsAdditionmorphicshowProjectNavigator
	^ #((showProjectNavigator 'If true, then show a nifty project navigator control in the world''s bottom left corner.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'RAA 1/30/2001 14:52'!
helpMsgsAdditionperformancehigherPerformance
	^ #((higherPerformance 'May offer higer performance at the expense of other applications on your computer. See the comment in EventSensor>>higherPerformanceNotes for more details. NOT advised when running in MVC!!' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/4/2001 01:06'!
helpMsgsAdditionperformanceturnOffPowerManager
	^ #((turnOffPowerManager 'May offer higer performance at the expense of the life of your Battery (macintosh only in 3.VM)' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/4/2001 01:04'!
helpMsgsAdditionprintingpostscriptStoredAsEPS
	^ #((postscriptStoredAsEPS 'When printing a morph as PostScript, offers the choice of (true) an EPS file suitable for incorporating in a larger job or (false) a DSC file that is a standalone file' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:56'!
helpMsgsAdditionpublishingshowFlapsWhenPublishing
	^ #((showFlapsWhenPublishing 'If true, show global flaps and project navigator -- otherwise suppress both to give the illusion that we are still in the same project' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 6/13/2000 12:03'!
helpMsgsAdditionscriptingbatchPenTrails
	^ #((batchPenTrails 'Ignores the detailed movement of pens between display updates.  Thus multiple line segments drawn within a script may not be seen individually.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:01'!
helpMsgsAdditionscriptingcapitalizedReferences
	^ #((capitalizedReferences 'if true, then object references in scripts will appear as capitalized names, a scheme which makes scripts look ''right'' but which still requires some engineering' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 13:15'!
helpMsgsAdditionscriptingcompactViewerFlaps
	^ #((compactViewerFlaps 'Determines whether a viewer flap should fit tightly around the viewer' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:44'!
helpMsgsAdditionscriptingeToyFriendly
	^ #((eToyFriendly 'If true, then the system is configured in ways suitable for etoy users' ) )! !

!Preferences class methodsFor: 'help'!
helpMsgsAdditionscrollinghiddenScrollBars
	^ #((hiddenScrollBars 'If true, then scrollbars will only be shown if a pane''s contents are too large to fit inside the pane.' ) )! !

!Preferences class methodsFor: 'help' stamp: 'programmatic 2/1/2001 12:52'!
helpMsgsAdditionwindowsdismissAllOnOptionClose
	^ #((dismissAllOnOptionClose 'Mac-specific: if true, then a click on a morphic SystemWindow''s close-box while the mac option is held down will result in a dismissal of all unchanged windows' ) )! !

!Preferences class methodsFor: 'help' stamp: 'zL 6/21/2000 12:32'!
helpMsgsAdditionwindowsfullScreenLeavesDeskMargins
	^ #(#(#fullScreenLeavesDeskMargins 'If true, a Full Screen request to a Window to will leave margins around it. 
If false, the Window will fill the Screen unless the Global Flaps are showing.') )"Preferences initializeHelpMessages"! !

!Preferences class methodsFor: 'help' stamp: 'sw 1/27/2000 17:11'!
helpMsgsGThroughP
		^ #(

(ignoreStyleIfOnlyBold
	'If true, then any method submission in which the only style change is for bolding will be treated as a method with no style specifications')

(inboardScrollbars
	'If true, then ScrollPane will place scrollbars inside on the right and will not hide them on exit')

(logDebuggerStackToFile
	'If true, whenever you fall into a debugger a summary of its stack will be written to a file named
''SqueakDebug.log''')

(menuColorFromWorld
	'Governs whether the colors used in morphic menus should be derived from the color of the world background.')

(mvcProjectsAllowed
	'If true, the open... menu will offer you the chance to open an mvc project.')

(noviceMode 
	'If true, certain novice-mode accommodations are made.')

(oneViewerFlapAtATime
	'If true, opening up one viewer flap will close all other such flaps.')

(optionalButtons
	'If true, then optional buttons will be used in certain standard tools, including browsers, message lists, fileLists, changeLists, and debuggers')

(personalizedWorldMenu
	'If true, then a right-click (Mac option-click) on the morphic desktop will bring up the customizable "personalized" menu; if false, then it will bring up the standard world menu.')

(preserveTrash
	'Whether morphs dismissed via halo or dragged into the Trash should be preserved in the TrashCan for possible future retrieval.  If false, they are not preserved.')

(printAlternateSyntax
	'If true, then
prettyPrint using experimental syntax.
Otherwise use normal ST-80 syntax.')

(projectsSentToDisk
	'If true, entering a new project swaps it in and swaps out other projects as appropriate. Projects are swapped in and out as ImageSegments, stored as files on disk in an image segment folder associated with the current image.')

(projectZoom
	'If true, then show a zoom effect when entering or leaving projects.  This can be costly of memory (at least an extra screen buffer) so dont use it in low space situations.  But it is cool.')

(promptForUpdateServer
	'If false, the prompt for server choice when updating code from the server is suppressed.  Set this to false to leave the server choice unchanged from update to update.')

			) 
! !

!Preferences class methodsFor: 'help' stamp: 'sw 9/8/2000 11:21'!
helpMsgsQThroughZ
	"Answer a list of <symbol> <string> pairs that give the balloon help corresponding to various symbols"

	^ #(	
(reverseWindowStagger
	'If true, a reverse-stagger strategy  is used for determining where newly launched windows will be placed; if false, a direct- stagger strategy is used.')

(roundedMenuCorners
	'Whether morphic menus should have rounded corners')

(roundedWindowCorners
	'Governs whether morphic system windows should have rounded corners')

(scrollBarsNarrow
		'If true, morphic scrollbars will be narrow.')
(scrollBarsOnRight
		'If true, morphic scrollbars in subsequently opened windows will appear on the right side of their pane.')
(scrollBarsWithoutMenuButton
		'If true, morphic scrollbars in subsequently opened windows will not include a menu button.')

(smartUpdating
	'If true, then morphic tools such as browsers and inspectors will keep their contents up to date automatically, so that if something changes anywhere, the change will be reflected everywhere.')

(soundQuickStart
	'If true, attempt to start playing sounds using optional "quick start"')

(soundsEnabled
	'If false, all sound playing is disabled')

(systemWindowEmbedOK
	'Determines whether, in Morphic, when a SystemWindow is dropped onto a willing receptor it should be deposited into that receptor.')

(timeStampsInMenuTitles
	'If true, then the author''s timestamp is displayed as the menu title of any message list; if false, no author''s timestamps are shown')

(thoroughSenders
	'If true, then ''senders'' browsers will dive inside structured literals in their search')

(twentyFourHourFileStamps
	'If #changeSetVersionNumbers is false, this preference determines whether the date/time suffix used with changeset fileouts is based on a 24-hr clock or a 12-hr clock.')

(uniformWindowColors
	'If true, then all standard windows are given the same color rather than their customized window-type-specific colors')

(unlimitedPaintArea
	'If true, the painting area for a new drawing will not be limited in size; if false, a reasonable
limit will be applied, in an attempt to hold down memory and time price.')

(updateRemoveSequenceNum
	'If true, then remove the leading sequence number from the filename before automatically saving a local copy of any update loaded.')

(updateSavesFile
	'If true, then when an update is loaded from the server, a copy of it will automatically be saved on a local file as well.')

(useGlobalFlaps
	'If true, then flaps are shown along the edges of Morphic projects.')

(viewersInFlaps
	'If true, viewers are projected into flaps along the right edge of the screen')

(warnIfNoChangesFile
	'If true, then you will be warned, whenever you start up, if no changes file
can be found')

(warnIfNoSourcesFile 
	'If true, then you will be warned, whenever you start up, if no sources file can be found')


			) 
! !

!Preferences class methodsFor: 'help' stamp: 'RAA 8/7/2000 19:24'!
helpMsgsRecordWhilePlaying
	^ #(
(canRecordWhilePlaying
	'If true, recording and playing sounds concurrently are permitted (platform dependent).')
)

! !

!Preferences class methodsFor: 'help' stamp: 'sw 5/9/2000 03:12'!
moreHelpA

	^ #(	
(systemWindowEmbedOK
	'Determines whether, in Morphic, when a SystemWindow or MenuMorph is dropped onto a willing receptor, it should be deposited into that receptor.')

			) 
! !


!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/13/2000 11:52'!
alternativeBrowseIt
	^ self valueOfFlag: #alternativeBrowseIt! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
annotationPanes
	^ self valueOfFlag: #annotationPanes! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'!
autoAccessors
	^ self valueOfFlag: #autoAccessors! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/4/2001 01:05'!
automaticPlatformSettings
	^ self valueOfFlag: #automaticPlatformSettings! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 20:48'!
automaticViewerPlacement
	^ self valueOfFlag: #automaticViewerPlacement! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'!
balloonHelpEnabled
	^ self valueOfFlag: #balloonHelpEnabled! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/13/2000 12:03'!
batchPenTrails
	^ self valueOfFlag: #batchPenTrails! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 5/5/2000 03:26'!
browseWithDragNDrop
	^ self valueOfFlag: #browseWithDragNDrop! !

!Preferences class methodsFor: 'standard preferences'!
browserShowsPackagePane
	^ self valueOfFlag: #browserShowsPackagePane! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 8/7/2000 19:21'!
canRecordWhilePlaying
	^ self valueOfFlag: #canRecordWhilePlaying! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:01'!
capitalizedReferences
	^ self valueOfFlag: #capitalizedReferences! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/1/1999 20:55'!
caseSensitiveFinds
	^ self valueOfFlag: #caseSensitiveFinds! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
cautionBeforeClosing
	^ self valueOfFlag: #cautionBeforeClosing! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/4/2001 01:05'!
celesteHasStatusPane
	^ self valueOfFlag: #celesteHasStatusPane! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/13/1999 22:52'!
changeSetVersionNumbers
	^ self valueOfFlag: #changeSetVersionNumbers! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 12:21'!
checkForSlips
	^ self valueOfFlag: #checkForSlips! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:53'!
checkForUnsavedProjects
	^ self valueOfFlag: #checkForUnsavedProjects! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
clickOnLabelToEdit
	^ self valueOfFlag: #clickOnLabelToEdit! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'!
cmdDotEnabled
	^ self valueOfFlag: #cmdDotEnabled! !

!Preferences class methodsFor: 'standard preferences' stamp: 'di 6/7/2000 10:53'!
colorWhenPrettyPrinting
	^ self printAlternateSyntax or: [self valueOfFlag: #colorWhenPrettyPrinting]! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:15'!
compactViewerFlaps
	^ self valueOfFlag: #compactViewerFlaps! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'!
compressFlashImages
	^ self valueOfFlag: #compressFlashImages! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'!
confirmFirstUseOfStyle
	^ self valueOfFlag: #confirmFirstUseOfStyle! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 7/1/1999 23:28'!
conversionMethodsAtFileOut
	^ self valueOfFlag: #conversionMethodsAtFileOut! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
debugHaloHandle
	^ self valueOfFlag: #debugHaloHandle! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:14'!
debugShowDamage
	^ self valueOfFlag: #debugShowDamage! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:17'!
decorateBrowserButtons
	^ self valueOfFlag: #decorateBrowserButtons! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
diffsInChangeList
	^ self valueOfFlag: #diffsInChangeList! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:13'!
diffsWithPrettyPrint
	^ self valueOfFlag: #diffsWithPrettyPrint! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:52'!
dismissAllOnOptionClose
	^ self valueOfFlag: #dismissAllOnOptionClose! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 5/5/2000 15:19'!
dragNDropWithAnimation
	^ self valueOfFlag: #dragNDropWithAnimation! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:44'!
eToyFriendly
	^ self valueOfFlag: #eToyFriendly! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'!
extractFlashInHighQuality
	^ self valueOfFlag: #extractFlashInHighQuality! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'!
extractFlashInHighestQuality
	^ self valueOfFlag: #extractFlashInHighestQuality! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'!
fastDragWindowForMorphic
	^ self valueOfFlag: #fastDragWindowForMorphic! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'!
fenceEnabled
	^ self valueOfFlag: #fenceEnabled! !

!Preferences class methodsFor: 'standard preferences' stamp: 'zL 6/21/2000 12:34'!
fullScreenLeavesDeskMargins
	"Preferences fullScreenLeavesDeskMargins  
	Leave desktop space with margins set in SystemWindow #fullScreen"
	^ self valueOfFlag: #fullScreenLeavesDeskMargins! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/1/2000 16:56'!
hiddenScrollBars
	^ self valueOfFlag: #hiddenScrollBars! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:12'!
higherPerformance
	^ self valueOfFlag: #higherPerformance! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'!
ignoreStyleIfOnlyBold
	^ self valueOfFlag: #ignoreStyleIfOnlyBold! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'!
inboardScrollbars
	^ self valueOfFlag: #inboardScrollbars! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:47'!
infiniteUndo
	^ self valueOfFlag: #infiniteUndo! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'!
logDebuggerStackToFile
	^ self valueOfFlag: #logDebuggerStackToFile! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 7/1/1999 22:32'!
menuColorFromWorld
	^ self valueOfFlag: #menuColorFromWorld! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:47'!
modalColorPickers
	^ self valueOfFlag: #modalColorPickers! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 7/1/1999 23:28'!
mouseOverHaloseEnabled
	^ self valueOfFlag: #mouseOverHaloseEnabled! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
mvcProjectsAllowed
	^ self valueOfFlag: #mvcProjectsAllowed! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'!
noviceMode
	^ self valueOfFlag: #noviceMode! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/13/2000 11:52'!
okToReinitializeFlaps
	^ self valueOfFlag: #okToReinitializeFlaps! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 7/1/1999 22:31'!
oneViewerFlapAtATime
	^ self valueOfFlag: #oneViewerFlapAtATime! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 12/13/1999 10:51'!
optionalButtons
	^ self valueOfFlag: #optionalButtons! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 4/17/2000 12:53'!
personalizedWorldMenu
	^ self valueOfFlag: #personalizedWorldMenu! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/4/2001 01:04'!
postscriptStoredAsEPS
	^ self valueOfFlag: #postscriptStoredAsEPS! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 9/1/1999 10:34'!
preserveTrash
	^ self valueOfFlag: #preserveTrash! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 20:50'!
printAlternateSyntax
	^ self valueOfFlag: #printAlternateSyntax! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:58'!
projectViewsInWindows
	^ self valueOfFlag: #projectViewsInWindows! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
projectZoom
	^ self valueOfFlag: #projectZoom! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
projectsSentToDisk
	^ self valueOfFlag: #projectsSentToDisk! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
promptForUpdateServer
	^ self valueOfFlag: #promptForUpdateServer! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'!
reverseWindowStagger
	^ self valueOfFlag: #reverseWindowStagger! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/26/1999 11:42'!
roundedMenuCorners
	^ self valueOfFlag: #roundedMenuCorners! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 7/1/1999 22:32'!
roundedWindowCorners
	^ self valueOfFlag: #roundedWindowCorners! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
scrollBarsNarrow
	^ self valueOfFlag: #scrollBarsNarrow! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
scrollBarsOnRight
	^ self valueOfFlag: #scrollBarsOnRight! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
scrollBarsWithoutMenuButton
	^ self valueOfFlag: #scrollBarsWithoutMenuButton! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:14'!
showBoundsInHalo
	^ self valueOfFlag: #showBoundsInHalo! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:52'!
showDirectionForSketches
	^ self valueOfFlag: #showDirectionForSketches! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:52'!
showDirectionHandles
	^ self valueOfFlag: #showDirectionHandles! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:56'!
showFlapsWhenPublishing
	^ self valueOfFlag: #showFlapsWhenPublishing! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/25/2000 15:56'!
showProjectNavigator
	^ self valueOfFlag: #showProjectNavigator! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/15/2000 18:46'!
simpleMenus
	^ self valueOfFlag: #simpleMenus! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/20/1999 12:22'!
smartUpdating
	^ self valueOfFlag: #smartUpdating! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
soundQuickStart
	^ self valueOfFlag: #soundQuickStart! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/4/2001 01:05'!
soundStopWhenDone
	^ self valueOfFlag: #soundStopWhenDone! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 1/12/2000 22:40'!
soundsEnabled
	^ self valueOfFlag: #soundsEnabled! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 13:17'!
sourceCommentToggleInBrowsers
	^ self valueOfFlag: #sourceCommentToggleInBrowsers! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'!
systemWindowEmbedOK
	^ self valueOfFlag: #systemWindowEmbedOK! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:29'!
thoroughSenders
	^ self valueOfFlag: #thoroughSenders! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 12:21'!
timeStampsInMenuTitles
	^ self valueOfFlag: #timeStampsInMenuTitles! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/4/2001 01:06'!
turnOffPowerManager
	^ self valueOfFlag: #turnOffPowerManager! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/13/1999 22:52'!
twentyFourHourFileStamps
	^ self valueOfFlag: #twentyFourHourFileStamps! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:45'!
uniqueNamesInHalos
	^ self valueOfFlag: #uniqueNamesInHalos! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'!
unlimitedPaintArea
	^ self valueOfFlag: #unlimitedPaintArea! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'!
updateSavesFile
	^ self valueOfFlag: #updateSavesFile! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 1/12/2000 22:56'!
useAnnotationPanes
	"Because of so any senders, this wording retained here though we defer to the renamed flag"

	^ self valueOfFlag: #annotationPanes! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'!
useGlobalFlaps
	^ self valueOfFlag: #useGlobalFlaps! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/1/2001 12:47'!
useUndo
	^ self valueOfFlag: #useUndo! !

!Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 7/1/1999 23:28'!
viewersInFlaps
	^ self valueOfFlag: #viewersInFlaps! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'!
warnIfNoChangesFile
	^ self valueOfFlag: #warnIfNoChangesFile! !

!Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'!
warnIfNoSourcesFile
	^ self valueOfFlag: #warnIfNoSourcesFile! !


!Preferences class methodsFor: 'initial values' stamp: 'sw 1/27/2000 23:28'!
initialValuesAToM
	"CategoryInfo _ nil"
	"Preferences openFactoredPanel"
	^#(
		(annotationPanes					false	(browsing))
		(autoAccessors						false	(general))
		(automaticViewerPlacement			true	(scripting))
		(balloonHelpEnabled					true	(morphic))
		(browserShowsPackagePane			false	(browsing))
		(browseWithPrettyPrint				false	(browsing))
		(caseSensitiveFinds					false	(general))
		(cautionBeforeClosing				false	(windows))
		(changeSetVersionNumbers			true	(fileout))
		(checkForSlips						true	(fileout))
		(clickOnLabelToEdit					true	(windows))
		(cmdDotEnabled						true	(debug))
		(colorWhenPrettyPrinting			false	(browsing))
		(compressFlashImages				false	(media))
		(confirmFirstUseOfStyle				true	(browsing))
		(conversionMethodsAtFileOut			false	(fileout))
		(debugHaloHandle					true	(debug halos))
		(diffsInChangeList					true	(browsing))
		(extractFlashInHighQuality			true	(media))
		(extractFlashInHighestQuality		false	(media))
		(fastDragWindowForMorphic			false	(windows))
		(fenceEnabled						true	(scripting))
		(ignoreStyleIfOnlyBold				true	(browsing))
		(inboardScrollbars					false	(scrolling))
		(logDebuggerStackToFile				true	(debug))
		(menuColorFromWorld				false	(menus))
		(mvcProjectsAllowed					false	(general))
)
! !

!Preferences class methodsFor: 'initial values' stamp: 'mir 5/16/2000 16:33'!
initialValuesAddition4sr
	^ #((browseWithDragNDrop true (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'sw 2/15/2000 18:37'!
initialValuesAdditionA
	"Another lot of initial values for prefs.  Simply placing methods of this sort in the 'initial values' category will assure that the initial values provided are ascribed to the preference when prefs are initialized"

	^ #(	
		(simpleMenus						false	(menus))
)
	"Preferences resetCategoryInfo"


! !

!Preferences class methodsFor: 'initial values' stamp: 'mir 5/16/2000 11:52'!
initialValuesAdditionDnd
	^ #( (dragNDropWithAnimation false (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 6/13/2000 11:52'!
initialValuesAdditionbrowsingalternativeBrowseIt
	^ #((alternativeBrowseIt false (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:17'!
initialValuesAdditionbrowsingdecorateBrowserButtons
	^ #((decorateBrowserButtons true (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:13'!
initialValuesAdditionbrowsingdiffsWithPrettyPrint
	^ #((diffsWithPrettyPrint false (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:16'!
initialValuesAdditionbrowsingsourceCommentToggleInBrowsers
	^ #((sourceCommentToggleInBrowsers false (browsing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:14'!
initialValuesAdditiondebugdebugShowDamage
	^ #((debugShowDamage false (debug ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/4/2001 01:05'!
initialValuesAdditiongeneralautomaticPlatformSettings
	^ #((automaticPlatformSettings true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/4/2001 01:05'!
initialValuesAdditiongeneralcelesteHasStatusPane
	^ #((celesteHasStatusPane false (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:53'!
initialValuesAdditiongeneralcheckForUnsavedProjects
	^ #((checkForUnsavedProjects true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:47'!
initialValuesAdditiongeneralinfiniteUndo
	^ #((infiniteUndo true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:47'!
initialValuesAdditiongeneralmodalColorPickers
	^ #((modalColorPickers true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:58'!
initialValuesAdditiongeneralprojectViewsInWindows
	^ #((projectViewsInWindows true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:47'!
initialValuesAdditiongeneraluseUndo
	^ #((useUndo true (general ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:14'!
initialValuesAdditionhalosshowBoundsInHalo
	^ #((showBoundsInHalo false (halos ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:52'!
initialValuesAdditionhalosshowDirectionForSketches
	^ #((showDirectionForSketches false (halos ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:52'!
initialValuesAdditionhalosshowDirectionHandles
	^ #((showDirectionHandles false (halos ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:45'!
initialValuesAdditionhalosuniqueNamesInHalos
	^ #((uniqueNamesInHalos false (halos ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/4/2001 01:05'!
initialValuesAdditionmediasoundStopWhenDone
	^ #((soundStopWhenDone false (media ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 6/13/2000 11:52'!
initialValuesAdditionmorphicokToReinitializeFlaps
	^ #((okToReinitializeFlaps true (morphic ) ) )! !

!Preferences class methodsFor: 'initial values'!
initialValuesAdditionmorphicshowProjectNavigator
	^ #((showProjectNavigator true (morphic ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:12'!
initialValuesAdditionperformancehigherPerformance
	^ #((higherPerformance false (performance ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/4/2001 01:06'!
initialValuesAdditionperformanceturnOffPowerManager
	^ #((turnOffPowerManager false (performance ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/4/2001 01:04'!
initialValuesAdditionprintingpostscriptStoredAsEPS
	^ #((postscriptStoredAsEPS false (printing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:56'!
initialValuesAdditionpublishingshowFlapsWhenPublishing
	^ #((showFlapsWhenPublishing false (publishing ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 6/13/2000 12:03'!
initialValuesAdditionscriptingbatchPenTrails
	^ #((batchPenTrails false (scripting ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:01'!
initialValuesAdditionscriptingcapitalizedReferences
	^ #((capitalizedReferences false (scripting ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 13:15'!
initialValuesAdditionscriptingcompactViewerFlaps
	^ #((compactViewerFlaps false (scripting ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:44'!
initialValuesAdditionscriptingeToyFriendly
	^ #((eToyFriendly false (scripting ) ) )! !

!Preferences class methodsFor: 'initial values'!
initialValuesAdditionscrollinghiddenScrollBars
	^ #((hiddenScrollBars false (scrolling ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'programmatic 2/1/2001 12:52'!
initialValuesAdditionwindowsdismissAllOnOptionClose
	^ #((dismissAllOnOptionClose false (windows ) ) )! !

!Preferences class methodsFor: 'initial values' stamp: 'zL 6/21/2000 12:32'!
initialValuesAdditionwindowsfullScreenLeavesDeskMargins
	^ #(#(#fullScreenLeavesDeskMargins #true #(#windows)) )"Preferences initializeAddedPreferences"! !

!Preferences class methodsFor: 'initial values' stamp: 'sw 1/28/2000 10:00'!
initialValuesNToZ
	"Another lot of initial values for prefs.  Simply placing methods of this sort in the 'initial values' category will assure that the initial values provided are ascribed to the preference when prefs are initialized"

	^ #(	
		(noviceMode							false	(general))
		(oneViewerFlapAtATime				true	(scripting))
		(optionalButtons						false	(general))
		(personalizedWorldMenu				true	(menus))
		(preserveTrash						true	(morphic))
		(printAlternateSyntax				false	(browsing))
		(projectsSentToDisk					false	(general))
		(projectZoom							false	(general))
		(promptForUpdateServer				true	(updates))
		(reverseWindowStagger				true	(windows))
		(roundedMenuCorners				true	(menus))
		(roundedWindowCorners				false	(windows))
		(scrollBarsNarrow					false	(scrolling))
		(scrollBarsOnRight					false	(scrolling))
		(scrollBarsWithoutMenuButton		false	(menus scrolling))
		(smartUpdating						true	(browsing))
		(soundsEnabled						false	(media))
		(soundQuickStart					false	(media))
		(systemWindowEmbedOK				false	(windows))
		(thoroughSenders					true	(general))
		(timeStampsInMenuTitles				false	(menus))
		(twentyFourHourFileStamps			true	(fileout)) 
		(unlimitedPaintArea					false	(morphic))
		(updateSavesFile						false	(updates))
		(useGlobalFlaps						true	(morphic))
		(viewersInFlaps						true	(scripting))
		(warnIfNoChangesFile				true	(general))
		(warnIfNoSourcesFile				true	(general))

)
	"Preferences resetCategoryInfo"


! !

!Preferences class methodsFor: 'initial values' stamp: 'RAA 8/7/2000 19:15'!
initialValuesRecordWhilePlaying
	^ #((canRecordWhilePlaying false (media ) ) )! !


!Preferences class methodsFor: 'window colors' stamp: 'sw 3/28/2000 13:39'!
darkerWindows
	"Preferences darkerWindows"
	| windowColorDict |
	windowColorDict _ self parameterAt: #windowColors default: [IdentityDictionary new].

	windowColorDict associationsDo:
		[:assoc | windowColorDict at: assoc key put: assoc value darker]
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/12/1999 17:41'!
installBrightWindowColors
	"Preferences installBrightWindowColors"
	| windowColorDict |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new].
	windowColorDict _ Parameters at: #windowColors.

	#(	(Browser				lightGreen)
		(ChangeList				lightBlue)
		(ChangeSorter			lightBlue)
		(Debugger				lightRed)
		(DualChangeSorter		lightBlue)
		(FileContentsBrowser		tan)
		(FileList					lightMagenta)
		(MessageSet				lightBlue)
		(Object					white)
		(SelectorBrowser			lightCyan)
		(StringHolder			lightYellow)
		(TranscriptStream		lightOrange))

	do:
			[:pair |
				windowColorDict at: pair first put: (Color perform: pair last)]
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/12/1999 17:41'!
installPastelWindowColors
	"Preferences installPastelWindowColors"
	| windowColorDict |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new].
	windowColorDict _ Parameters at: #windowColors.

	#(	(Browser				paleGreen)
		(ChangeList				paleBlue)
		(ChangeSorter			paleBlue)
		(Debugger				veryPaleRed)
		(DualChangeSorter		paleBlue)
		(FileContentsBrowser		paleTan)
		(FileList					paleMagenta)
		(MessageSet				paleBlue)
		(Object					white)
		(SelectorBrowser			palePeach)
		(StringHolder			paleYellow)
		(TranscriptStream		paleOrange))

	do:
			[:pair |
				windowColorDict at: pair first put: (Color perform: pair last)]
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 15:12'!
installUniformWindowColors
	"Preferences installUniformWindowColors"
	| windowColorDict |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new].
	windowColorDict _ Parameters at: #windowColors.

	#(	(Browser				white)
		(ChangeList				white)
		(ChangeSorter			white)
		(Debugger				white)
		(DualChangeSorter		white)
		(FileContentsBrowser		white)
		(FileList					white)
		(MessageSet				white)
		(Object					white)
		(SelectorBrowser			white)
		(StringHolder			white)
		(TranscriptStream		white))

	do:
			[:pair |
				windowColorDict at: pair first put: (Color perform: pair last)]
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 16:38'!
lighterWindows
	"Preferences lighterWindows"
	| windowColorDict |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new].
	windowColorDict _ Parameters at: #windowColors.

	windowColorDict associationsDo:
		[:assoc | windowColorDict at: assoc key put: assoc value lighter]
! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 10/27/1999 11:34'!
setWindowColorFor: modelSymbol to: incomingColor
	| aColor |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new.
		self installBrightWindowColors].
	aColor _ incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self].
	^ (Parameters at: #windowColors) at: modelSymbol put: aColor
	! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 16:31'!
windowColorClasses
	^ #(Browser	 ChangeList	 ChangeSorter Debugger	 DualChangeSorter FileContentsBrowser	 FileList	MessageSet SelectorBrowser StringHolder TranscriptStream)! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 16:03'!
windowColorFor: aModelClassName
	| classToCheck windowColors |
	(Parameters includesKey: #windowColors) ifFalse:
		[Parameters at: #windowColors put: IdentityDictionary new.
		self installBrightWindowColors].
	classToCheck _ Smalltalk at: aModelClassName.
	windowColors _ Parameters at: #windowColors.
	[windowColors includesKey: classToCheck name]
		whileFalse:
			[classToCheck _ classToCheck superclass].
	^ windowColors at: classToCheck name ifAbsent: [Color white]
	! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 20:10'!
windowColorHelp
	"The 'Window Colors' panel lets you select colors for the standard Squeak windows.

The three buttons entitled 'Bright', 'Pastel', and 'White' let you install three different standard color schemes.

The rows of color swatches and tool names indicate what the color for each tool is currently set to be.  You can change the color for any tool by clicking on its swatch, then choosing a new color in the ensuing color-picker.

'TranscriptStream' governs the color of Transcripts.
'MessageSet' governs the color of message-list browsers.
'ChangeList' governs the color of change-list browsers *and* versions browsers.
'StringHolder' governs the color of Workspaces.

Any time you request a new window (browser, file-list, etc.), the current window-color setting for that kind of window will determine what color is used.

But note that if in Morphic, the 'Tools' flap and the 'Standard Parts Bin' both contain pre-allocated window prototypes, and these will not automatically change when you edit the standard window colors.  To get the Tools flap to reflect your latest color choices, hit the 'Update Tools Flap' button.  To get the standard parts bin to reflect your latest color choices, evaluate 'ScriptingSystem resetStandardPartsBin'"

	(StringHolder new contents: (self class firstCommentAt: #windowColorHelp))
		openLabel: 'About Window Colors'

	"Preferences windowColorHelp"! !

!Preferences class methodsFor: 'window colors' stamp: 'sw 12/7/1999 18:22'!
windowSpecificationPanel
	"Preferences windowSpecificationPanel"
	| aPanel buttonRow aButton aRow aSwatch aColor aWindow aMiniWorld |
	aPanel _ AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap.

	aPanel addMorph: (buttonRow _ AlignmentMorph newRow color: (aColor _ Color tan lighter)).
	
	aButton _ SimpleButtonMorph new target: self.
	buttonRow addTransparentSpacerOfSize: 2@0.
	buttonRow addMorphBack: (SimpleButtonMorph new label: '?'; target: self; actionSelector: #windowColorHelp; setBalloonText: 'Click for an explanation of this panel'; color: Color veryVeryLightGray; yourself).
	buttonRow addTransparentSpacerOfSize: 8@0.
	#(	('Bright' 	installBrightWindowColors	yellow
					'Use standard bright colors for all windows.')
		('Pastel'		installPastelWindowColors	paleMagenta
					'Use standard pastel colors for all windows.')
		('White'	installUniformWindowColors		white
					'Use white backgrounds for all standard windows.')) do:

		[:quad |
			aButton _ aButton fullCopy
				label: quad first;
				actionSelector: quad second;
				color: (Color colorFrom: quad third);
				setBalloonText: quad fourth;
				yourself.
			buttonRow addMorphBack: aButton.
			buttonRow addTransparentSpacerOfSize: 10@0].

	self windowColorClasses do:
		[:aClassName | 
			aRow _ AlignmentMorph newRow color: aColor.
			aSwatch _ ColorSwatch new
				target: self;
				getSelector: #windowColorFor:;
				putSelector: #setWindowColorFor:to:;
				argument: aClassName;
				extent: (40 @ 20);
				yourself.
			aRow addMorphFront: aSwatch.
			aRow addTransparentSpacerOfSize: (12 @ 1).
			aRow addMorphBack: (StringMorph contents: aClassName font: TextStyle defaultFont).
			aPanel addMorphBack: aRow].

	 Smalltalk isMorphic
                ifTrue:
                        [buttonRow _ buttonRow fullCopy removeAllMorphs.
					buttonRow addTransparentSpacerOfSize: 25@0.
					aButton _ aButton fullCopy color: Color tan muchLighter.
					aButton label: 'Update Tools Flap'; target: Utilities; actionSelector: #replaceToolsFlap.
					buttonRow addMorphBack: aButton.
					aButton setBalloonText: 'Press here to place tools which use the above window-color choices  into the Tools flap.'.
					aPanel addMorphBack: buttonRow.

					aWindow _ aPanel wrappedInWindowWithTitle: 'Window Colors'.
                        self currentHand attachMorph: aWindow.
					aWindow world startSteppingSubmorphsOf: aPanel.]
                ifFalse:
                        [(aMiniWorld _ MVCWiWPasteUpMorph newWorldForProject: nil)
						addMorph: aPanel.
                           aMiniWorld startSteppingSubmorphsOf: aPanel.
                        MorphWorldView openOn: aMiniWorld
                                label: 'Window Colors'
                                extent: aMiniWorld fullBounds extent]! !


!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/6/2000 18:45'!
chooseInsertionPointColor
	"Let the user indicate what color he wishes to have used for insertion points in text"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self currentHand;
		target: self;
		selector: #insertionPointColor:;
		originalColor: self insertionPointColor;
		putUpFor: self currentHand near: self currentHand cursorBounds! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/6/2000 18:45'!
chooseTextHighlightColor
	"Let the user choose the text-highlight color"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self currentHand;
		target: self;
		selector: #textHighlightColor:;
		originalColor: self textHighlightColor;
		putUpFor: self currentHand near: self currentHand cursorBounds! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 13:07'!
initializeTextHighlightingParameters
	"Preferences initializeTextHighlightingParameters"
	Parameters at: #insertionPointColor put: (Color r: 0.4 g: 1.0 b: 0).
	Parameters at: #textHighlightColor put: (Color r: 0.4 g: 1.0 b: 0).! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'!
insertionPointColor
	^ Parameters at: #insertionPointColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'!
insertionPointColor: aColor
	Parameters at: #insertionPointColor put: aColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'!
textHighlightColor
	^ Parameters at: #textHighlightColor! !

!Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'!
textHighlightColor: aColor
	Parameters at: #textHighlightColor put: aColor! !


!Preferences class methodsFor: 'pretty-printing' stamp: 'sw 11/17/1999 15:09'!
initializeSyntaxColorsAndStyles
	| specs |
	"To change the color choices, you can simply edit this method, and then evaluate the following line:

		Preferences initializeSyntaxColorsAndStyles

	Later, people may wish to produce interactive editors for modifying the choices"

	SyntaxColorsAndStyles _ IdentityDictionary new.
	# (	(temporaryVariable		(magenta		bold))
		(methodArgument		(magenta		italic))
		(blockArgument			(magenta		italic))

		(comment				(red				normal))

		(variable				(blue			bold))

		(literal					(brown			normal))

		(keyword				(black	 		normal)))

	do:
		[:nameAndSpecs |
			specs _ nameAndSpecs second.
			SyntaxColorsAndStyles at:  nameAndSpecs first put: (SyntaxAttribute color: (Color perform: specs first) emphasis: specs last)]
		! !


!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 08:58'!
chooseCodeFont
	"Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated"

	self chooseFontWithPrompt: 'standard code font' andSendTo: self withSelector: #setCodeFontTo:.! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:08'!
chooseFlapsFont
	self chooseFontWithPrompt: 'flaps font' andSendTo: self withSelector: #setFlapsFontTo:! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 17:03'!
chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector
	Smalltalk isMorphic
		ifFalse:
			[Utilities mvcPromptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector]
		ifTrue:
			[Utilities promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 17:30'!
chooseListFont
	self chooseFontWithPrompt: 'standard list font' andSendTo: self withSelector: #setListFontTo:! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 17:30'!
chooseMenuFont
	self chooseFontWithPrompt: 'standard menu font' andSendTo: self withSelector: #setMenuFontTo:! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:34'!
chooseSystemFont
	self chooseFontWithPrompt: 'Default text font' andSendTo: self withSelector: #setSystemFontTo:! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:39'!
chooseWindowTitleFont
	self chooseFontWithPrompt: 'window title font' andSendTo: self withSelector: #setWindowTitleFontTo:! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 1/31/2000 15:45'!
fontConfigurationMenu
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: Preferences.
	aMenu addTitle: 'Standard System Fonts'.
	aMenu add: 'default text font...' action: #chooseSystemFont.
	aMenu balloonTextForLastItem: 'Choose the default font to be used for code and  in workspaces, transcripts, etc.'.
	aMenu lastItem font: TextStyle defaultFont.
	aMenu add: 'list font...' action: #chooseListFont.
	aMenu lastItem font: Preferences standardListFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in list panes'.
	aMenu add: 'flaps font...' action: #chooseFlapsFont.
	aMenu lastItem font: Preferences standardFlapFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs'.
	aMenu add: 'menu font...' action: #chooseMenuFont.
	aMenu lastItem font: Preferences standardMenuFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in menus'.
	aMenu add: 'window-title font...' action: #chooseWindowTitleFont.
	aMenu lastItem font: Preferences windowTitleFont emphasis: 1.
	aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.'.

	aMenu add: 'balloon-help font...' target: BalloonMorph action: #chooseBalloonFont.
	aMenu lastItem font: BalloonMorph balloonFont.
	aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.'.

	"aMenu add: 'code font...' action: #chooseCodeFont.
	aMenu lastItem font: Preferences standardCodeFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.'."

	aMenu addLine.
	aMenu add: 'restore default font choices' action: #restoreDefaultFonts.
	aMenu balloonTextForLastItem: 'Use the standard system font defaults'.
	^ aMenu
! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 09:39'!
presentMvcFontConfigurationMenu
	| aMenu result |
	aMenu _ CustomMenu new.
	aMenu title: 'Standard System Fonts'.
	aMenu add: 'default text font...' action: #chooseSystemFont.
	aMenu add: 'list font...' action: #chooseListFont.
	aMenu add: 'flaps font...' action: #chooseFlapsFont.
	aMenu add: 'menu font...' action: #chooseMenuFont.
	aMenu add: 'window-title font...' action: #chooseWindowTitleFont.
	"aMenu add: 'code font...' action: #chooseCodeFont."
	aMenu addLine.
	aMenu add: 'restore default font choices' action: #restoreDefaultFonts.

	(result _ aMenu startUp) ifNotNil:
		[self perform: result]
! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 1/31/2000 15:54'!
restoreDefaultFonts
	"Preferences restoreDefaultFonts"
	#(	(setButtonFontTo:		ComicBold		16)
		"(setCodeFontTo:			NewYork		12)"  "Later"
		(setFlapsFontTo:			ComicBold		16)
		(setListFontTo:			NewYork		12)
		(setMenuFontTo:			NewYork		12)
		(setWindowTitleFontTo:	NewYork		15)
		(setSystemFontTo:		NewYork		12)) do:
			[:triplet |
				self perform: triplet first with: (StrikeFont familyName: triplet second size: triplet third)].

	Smalltalk at: #BalloonMorph ifPresent:
		[:thatClass | thatClass setBalloonFontTo: (StrikeFont familyName: #ComicPlain size: 12)].

	"Note:  The standardCodeFont is not currently used -- the default font is instead; later hopefully we can split the code font out as  a separate choice, but only after we're able to have the protocols reorganized such that we can know whether it's code or not when we launch the text object.

	Note:  The standard button font is reset by this code but is not otherwise settable by a public UI (too many things can go afoul) "! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:06'!
setButtonFontTo: aFont
	Parameters at: #standardButtonFont put: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:37'!
setCodeFontTo: aFont
	"Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated"

	Parameters at: #standardCodeFont put: aFont.
	Utilities replaceToolsFlap! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:15'!
setFlapsFontTo: aFont

	Parameters at: #standardFlapFont put: aFont.
	FlapTab allSubInstancesDo:
		[:aFlapTab | aFlapTab reformatTextualTab]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:39'!
setListFontTo: aFont

	Parameters at: #standardListFont put: aFont.
	ListParagraph initialize.
	Utilities replaceToolsFlap! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:04'!
setMenuFontTo: aFont

	Parameters at: #standardMenuFont put: aFont.
	PopUpMenu setMenuFontTo: aFont! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:35'!
setSystemFontTo: aFont
	"Establish the default text font and style"
	| aStyle newDefaultStyle |
	aFont ifNil: [^ self].
	aStyle _ aFont textStyle ifNil: [^ self].
	newDefaultStyle _ aStyle copy.
	newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont).
	TextConstants at: #DefaultTextStyle put: newDefaultStyle.
	Utilities replaceToolsFlap.
	ScriptingSystem resetStandardPartsBin! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:39'!
setWindowTitleFontTo: aFont

	Parameters at: #windowTitleFont put: aFont.
	StandardSystemView setLabelStyle.
	Utilities replaceToolsFlap! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'!
standardButtonFont
	"Answer an attractive font to use for buttons"
	"Answer the font to be used for textual flap tab labels"
	^ Parameters at: #standardButtonFont ifAbsent:
		[Parameters at: #standardButtonFont put: (StrikeFont familyName: #ComicBold size: 16)]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'!
standardCodeFont
	"Answer the font to be used in code"

	 ^ Parameters at: #standardCodeFont ifAbsent:
		[Parameters at: #standardCodeFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'!
standardFlapFont
	"Answer the font to be used for textual flap tab labels"
	^ Parameters at: #standardFlapFont ifAbsent:
		[Parameters at: #standardFlapFont put: self standardButtonFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:09'!
standardListFont
	"Answer the font to be used in lists"

	 ^ Parameters at: #standardListFont ifAbsent:
		[Parameters at: #standardListFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'!
standardMenuFont
	"Answer the font to be used in menus"

	 ^ Parameters at: #standardMenuFont ifAbsent:
		[Parameters at: #standardMenuFont put: TextStyle defaultFont]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:10'!
windowTitleFont
	"Answer the standard font to use for window titles"
	^  Parameters at: #windowTitleFont ifAbsent:
		[Parameters at: #windowTitleFont put: (StrikeFont familyName: #NewYork size: 15)]! !

!Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:18'!
windowTitleStyle
	"Answer the standard style to use for window titles"
	^  self windowTitleFont textStyle! !


!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/11/2000 22:19'!
allHelpStrings
	| aList |
	aList _ OrderedCollection new.
	FlagDictionary keysDo:
		[:aKey  | aList add: (self helpMessageForPreference: aKey)].
	^ aList! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/13/2000 11:04'!
allPreferenceFlagKeys
	"Preferences allPreferenceFlagKeys"
	^ FlagDictionary keys asSortedArray! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/19/2001 03:02'!
factoredCategories
	| prefsWithoutInits extraItem |
	"Preferences factoredCategories"
	"CategoryInfo _ nil"

	CategoryInfo ifNil:
		[CategoryInfo _ self initialCategoryInfo].
	((prefsWithoutInits _ self preferencesLackingInitializers) size > 0)
		ifTrue:
			[extraItem _ (Array with: 'uncategorized' with: prefsWithoutInits asSortedArray)].
	^ (extraItem
		ifNil:
			[CategoryInfo]
		ifNotNil:
			[CategoryInfo, (Array with: extraItem)]) copyWith: {'search results'. OrderedCollection new}! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/19/2000 16:16'!
initialCategoryInfo
	| categories |
	categories _ IdentityDictionary new.
	self allPreferenceInitializationSpecs do:
		[:spec |
			spec size > 2 ifTrue:
				[spec third do:
					[:sym | 
						(categories includesKey: sym) ifFalse:
							[categories at: sym put: OrderedCollection new].
					(categories at: sym) add: spec first]]].
	^ categories keys asSortedArray collect:
		[:aKey | Array with: aKey with: (categories at: aKey) asSortedArray]! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/19/2000 14:51'!
openFactoredPanel
	"Preferences openFactoredPanel"
	self openFactoredPanelWithWidth: 370! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/25/2001 08:51'!
openFactoredPanelWithWidth: aWidth 
	"Open up a preferences panel of the given width"

	"Preferences openFactoredPanelWithWidth: 325"
	| tabbedPalette controlPage window playfield aColor aFont maxEntriesPerCategory tabsMorph anExtent aPanel |
	aFont _ StrikeFont familyName: 'NewYork' size: 19.
	aPanel _ PreferencesPanel new.
	aColor _ aPanel defaultBackgroundColor.
	tabbedPalette _ TabbedPalette newSticky.
	(tabsMorph _ tabbedPalette tabsMorph) color: aColor darker;
		 highlightColor: Color red regularColor: Color brown darker darker.
	maxEntriesPerCategory _ 0.
	"tabbedPalette addTabFor: self helpPaneForFactoredPanel font: aFont.  
	LATER!!"
	self factoredCategories
		do: 
			[:aCat | 
			controlPage _ AlignmentMorph newColumn beSticky color: aColor.
			controlPage borderColor: aColor;
				 layoutInset: 4.
			aCat second
				do: [:aPrefSymbol | controlPage
						addMorphBack: (Preferences
								buttonRepresenting: aPrefSymbol
								wording: aPrefSymbol
								color: nil)].
			controlPage setNameTo: aCat first asString.
			aCat first == #halos
				ifTrue: [aPanel addHaloControlsTo: controlPage].
			tabbedPalette addTabFor: controlPage font: aFont.
			aCat first = 'search results' ifTrue:
				[(tabbedPalette tabNamed: aCat first) setBalloonText:
					'Use cmd-f to find preferences by keyword; the results of your search will show up here'].
			maxEntriesPerCategory _ maxEntriesPerCategory max: aCat second size].
	tabbedPalette selectTabNamed: 'general'.
	tabsMorph rowsNoWiderThan: aWidth.
	playfield _ Morph newSticky.
	anExtent _ aWidth @ (25 + tabsMorph height + (20 * maxEntriesPerCategory)).
	playfield extent: anExtent.
	playfield color: aColor.
	playfield addMorphBack: tabbedPalette.
	self couldOpenInMorphic
		ifTrue: [window _ (SystemWindow labelled: 'Preferences')
						model: aPanel.
			window on: #keyStroke send: #keyStroke: to: aPanel.
			window
				bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)).
			window
				addMorph: playfield
				frame: (0 @ 0 extent: 1 @ 1).
			window updatePaneColors.
			window setProperty: #minimumExtent toValue: anExtent + (2 @ 2).
			window position: 200 @ 20.
			self currentHand attachMorph: window.
			self currentWorld startSteppingSubmorphsOf: window]
		ifFalse:
			[(window _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: playfield.
			window startSteppingSubmorphsOf: playfield.
			MorphWorldView
				openOn: window
				label: 'Preferences'
				extent: playfield extent]! !

!Preferences class methodsFor: 'factored pref panel' stamp: 'sw 1/19/2000 13:43'!
resetCategoryInfo
	"Preferences resetCategoryInfo"

	CategoryInfo _ nil! !


!Preferences class methodsFor: 'halos' stamp: 'sw 8/29/2000 15:33'!
classicHaloSpecs
	"Non-iconic halos with traditional placements"

	"Preferences installClassicHaloSpecs"
	"Preferences resetHaloSpecifications"  "  <-  will result in the standard default halos being reinstalled"
	"NB: listed below in clockwise order"

		^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addMenuHandle:		left			top				(red)							none)
	(addDismissHandle:		leftCenter	top				(red		muchLighter)			'Halo-Dismiss')
	(addGrabHandle:			center		top				(black)							none)
	(addDragHandle:			rightCenter	top				(brown)							none)
	(addDupHandle:			right		top				(green)							none)	
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		none)
	(addPoohHandle:			right		center			(white)							none)
	(addPaintBgdHandle:		right		center			(lightGray)						none)
	(addRepaintHandle:		right		center			(lightGray)						none)
	(addGrowHandle:		right		bottom			(yellow)						none)
	(addScaleHandle:		right		bottom			(lightOrange)					none)
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				none)
	(addFontStyleHandle:		center		bottom			(lightRed)						none)
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						none)

	(addRecolorHandle:		right		bottomCenter	(magenta darker)				none)

	(addRotateHandle:		left			bottom			(blue)							none))

! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:07'!
classicHalosInForce
	^ (self parameterAt: #HaloTheme) == #classicHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'laza 3/24/2000 16:05'!
customHaloSpecs
	"Intended for you to modify to suit your personal preference.  What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc..
	Note that in this example, we include:
			Dismiss handle, at top-left
			Menu handle, at top-right
			Resize handle, at bottom-right
			Rotate handle, at bottom-left
			Drag handle, at top-center
			Recolor handle, at left-center.  (this one is NOT part of the standard formulary --
											it is included here to illustrate how to
 											add non-standard halos)
			Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included"

	^ #(
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addMenuHandle:		right		top				(red)							'Halo-Menu')
	(addDragHandle:			center	top					(brown)							'Halo-Drag')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')

	(addRecolorHandle:		left			center			(green muchLighter lighter)		'Halo-Recolor')

	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				'Halo-FontEmph')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')

	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')


			)

	"  Other useful handles...

  		selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------

	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addFewerHandlesHandle:	left		topCenter		(paleBuff)						'Halo-FewerHandles')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	"
! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:08'!
customHalosInForce
	^ (self parameterAt: #HaloTheme) == #customHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:43'!
editCustomHalos

	Browser openMessageBrowserForClass: Preferences class
		selector: #customHaloSpecs editString: nil! !

!Preferences class methodsFor: 'halos' stamp: 'sw 10/30/2000 13:32'!
haloSpecifications
	"Answer a list of HaloSpecs that describe which halos are to be used, what they should look like, and where they should be situated"

	^ Parameters at: #HaloSpecs ifAbsent:
			[self installHaloTheme: #iconicHaloSpecifications.
			^ Parameters at: #HaloSpecs]

	"Preferences haloSpecifications"
	"Preferences resetHaloSpecifications"
! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/26/2000 19:35'!
haloSpecificationsForWorld
	| desired |
	"Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated"
	"Preferences resetHaloSpecifications"

	desired _ #(addDebugHandle: addMenuHandle: addTileHandle: addViewHandle: addHelpHandle: addScriptHandle:).
	^ self haloSpecifications select:
		[:spec | desired includes: spec addHandleSelector]! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 22:52'!
haloTheme
	^ Parameters at: #HaloTheme ifAbsent: [Parameters at: #HaloTheme put: #iconic]! !

!Preferences class methodsFor: 'halos' stamp: 'sw 10/30/2000 13:32'!
iconicHaloSpecifications
	"Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme"

	"Preferences resetHaloSpecifications"

	^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addCollapseHandle:		left			topCenter		(tan)							'Halo-Collapse')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')
	(addMenuHandle:		leftCenter	top				(red)							'Halo-Menu')
	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')
	(addScriptHandle:		rightCenter	bottom			(green muchLighter)			'Halo-Script')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addViewingHandle:		leftCenter	bottom			(lightGreen lighter)				'Halo-View')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)				'Halo-FontEmph')
	(addRecolorHandle:		right		bottomCenter	(magenta darker)				'Halo-Recolor')
	(addChooseGraphicHandle:	right	bottomCenter	(green muchLighter)			'Halo-ChooseGraphic')
		) ! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:25'!
iconicHalosInForce
	^ (self parameterAt: #HaloTheme) == #iconicHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:35'!
installClassicHaloSpecs
	"Install an alternative set of halos,  rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.."
	"Preferences installClassicHaloSpecs"
	"Preferences resetHaloSpecifications"  "  <-  will result in the standard default halos being reinstalled"
	self installHaloTheme: #classicHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installCustomHaloSpecs
	"Install an alternative set of halos, as customized by the user"
	"Preferences installCustomHaloSpecs"
	self installHaloTheme: #customHaloSpecs! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 16:45'!
installHaloSpecsFromArray: anArray

	| aColor |
	^ Parameters at: #HaloSpecs put: 
		(anArray collect:
			[:quin |
				aColor _ Color.
				quin fourth do: [:sel | aColor _ aColor perform: sel].
				HaloSpec new 
					horizontalPlacement: quin second
					verticalPlacement: quin third 
					color: aColor
					iconSymbol: quin fifth
					addHandleSelector: quin first])! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:15'!
installHaloTheme: themeSymbol
	self installHaloSpecsFromArray: (self perform: themeSymbol).
	self setParameter: #HaloTheme to: themeSymbol
	! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installIconicHaloSpecs
	"Install an alternative set of halos,  rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.."
	"Preferences installIconicHaloSpecs"
	self installHaloTheme: #iconicHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'!
installSimpleHaloSpecs
	"Preferences installSimpleHaloSpecs"
	self installHaloTheme: #simpleFullHaloSpecifications! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/25/2000 20:10'!
resetHaloSpecifications
	"Preferences resetHaloSpecifications"

	^ Parameters removeKey: #HaloSpecs ifAbsent: []! !

!Preferences class methodsFor: 'halos' stamp: 'sw 11/6/2000 10:02'!
showChooseGraphicHaloHandle
	"Hard-coded; reimplement to change behavior.  If this preference is set to true, then a choose-graphic halo handle may appear on the halo of SketchMorphs"

	^ false! !

!Preferences class methodsFor: 'halos' stamp: 'sw 8/29/2000 15:35'!
simpleFullHaloSpecifications
	"This method gives the specs for the 'full' handles variant when simple halos are in effect"

	"Preferences resetHaloSpecifications"

	^ #(
	"  	selector				horiz		vert			color info						icon key
		---------				------		-----------		-------------------------------		---------------"
	(addDebugHandle:		right		topCenter		(blue	veryMuchLighter)		'Halo-Debug')
	(addPoohHandle:			right		center			(white)							'Halo-Pooh')
	(addDismissHandle:		left			top				(red		muchLighter)			'Halo-Dismiss')
	(addRotateHandle:		left			bottom			(blue)							'Halo-Rot')
	(addMenuHandle:		leftCenter	top				(red)							'Halo-Menu')
	(addTileHandle:			left			bottomCenter	(lightBrown)					'Halo-Tile')
	(addViewHandle:			left			center			(cyan)							'Halo-View')
	(addGrabHandle:			center		top				(black)							'Halo-Grab')
	(addDragHandle:			rightCenter	top				(brown)							'Halo-Drag')
	(addDupHandle:			right		top				(green)							'Halo-Dup')	
	(addHelpHandle:			center		bottom			(lightBlue)						'Halo-Help')
	(addGrowHandle:		right		bottom			(yellow)						'Halo-Scale')
	(addScaleHandle:		right		bottom			(lightOrange)					'Halo-Scale')
	(addFewerHandlesHandle:	left		topCenter		(paleBuff)						'Halo-FewerHandles')
	(addScriptHandle:		right		bottomCenter	(green muchLighter)			'Halo-Script')
	(addPaintBgdHandle:		right		center			(lightGray)						'Halo-Paint')
	(addRepaintHandle:		right		center			(lightGray)						'Halo-Paint')
	(addFontSizeHandle:		leftCenter	bottom			(lightGreen)						'Halo-FontSize')
	(addFontStyleHandle:		center		bottom			(lightRed)						'Halo-FontStyle')
	(addFontEmphHandle:	rightCenter	bottom			(lightBrown darker)		  'Halo-FontEmph')
	(addRecolorHandle:		right		bottomCenter	(magenta darker)				'Halo-Recolor')

		) ! !

!Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 09:50'!
simpleHalosInForce
	^ (self parameterAt: #HaloTheme) == #simpleFullHaloSpecifications! !


!Preferences class methodsFor: 'add preferences' stamp: 'sr 4/19/2000
16:54'!
addPreference: prefSymbol category: categorySymbol default: defaultFlag
balloonHelp: helpString 
	self class compileProgrammatically: (#initialValuesAddition ,
categorySymbol , prefSymbol) asString , '
	^ #((' , prefSymbol asSymbol, ' ' , defaultFlag printString , ' (' ,
categorySymbol asSymbol, ' ) ) )' classified: 'initial values'.

	self class compileProgrammatically: (#helpMsgsAddition , categorySymbol
, prefSymbol) asString , '
	^ #((' , prefSymbol, ' ', helpString printString, ' ) )' classified:
'help'.

	self absorbAdditions
! !
Model subclass: #PreferencesPanel
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!PreferencesPanel commentStamp: '<historical>' prior: 0!
I represent a the model of a Preferences window.!


!PreferencesPanel methodsFor: 'initialization' stamp: 'sw 1/24/2001 21:42'!
addModelItemsToWindowMenu: aMenu
	"aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic SystemWindow.  Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."

	aMenu addLine.
	aMenu add: 'find preference... (f)' target: self action: #findPreference:.
	aMenu add: 'inspect parameters' target: Preferences action: #inspectParameters! !

!PreferencesPanel methodsFor: 'initialization' stamp: 'sw 1/10/2001 15:40'!
defaultBackgroundColor 
	"Answer the color of the day for the preferences panel"

	^ Color r: 0.645 g: 1.0 b: 1.0! !


!PreferencesPanel methodsFor: 'category switch' stamp: 'sw 1/9/2001 12:47'!
switchToCategoryNamed: aName event: anEvent
	"Switch the panel so that it looks at the category of the given name"

	| aPalette |
	aPalette _ self containingWindow findDeeplyA: TabbedPalette.
	aPalette ifNil: [^ self].
	aPalette selectTabNamed: aName! !


!PreferencesPanel methodsFor: 'halo pane' stamp: 'sw 1/19/2001 12:46'!
addHaloControlsTo: controlPage
	"Add special controls relating to halo schemes to the page"

	| aButton |
	controlPage addTransparentSpacerOfSize: (0 @ 4).
	controlPage addMorphBack: self haloThemeRadioButtons.
	controlPage addTransparentSpacerOfSize: (0 @ 4).
	aButton _ SimpleButtonMorph new target: self; color: Color transparent; actionSelector: #editCustomHalos; label: 'Edit custom halos'.
	controlPage addMorphBack: aButton.
	aButton setBalloonText: 'Click here to edit the method that defines the custom halos'.
			! !

!PreferencesPanel methodsFor: 'halo pane' stamp: 'sw 1/19/2001 12:48'!
haloThemeRadioButtons
	"Answer a column of butons representing the choices of halo theme"

	| buttonColumn aRow aRadioButton aStringMorph |
	buttonColumn _ AlignmentMorph newColumn beTransparent.
	#(	(iconicHaloSpecifications iconic iconicHalosInForce	'circular halos with icons inside')
		(classicHaloSpecs	classic	classicHalosInForce		'plain circular halos')
		(simpleFullHaloSpecifications		simple	simpleHalosInForce	'fewer, larger halos')
		(customHaloSpecs	custom	customHalosInForce		'customizable halos')) do:

		[:quad |
			aRow _ AlignmentMorph newRow beTransparent.
			aRow addMorph: (aRadioButton _ UpdatingThreePhaseButtonMorph radioButton).
			aRadioButton target: Preferences.
			aRadioButton setBalloonText: quad fourth.
			aRadioButton actionSelector: #installHaloTheme:.
			aRadioButton getSelector: quad third.
			aRadioButton arguments: (Array with: quad first).
			aRow addTransparentSpacerOfSize: (4 @ 0).
			aRow addMorphBack: (aStringMorph _ StringMorph contents: quad second asString).
			aStringMorph setBalloonText: quad fourth.
			buttonColumn addMorphBack: aRow].
	^ buttonColumn

	"self currentHand attachMorph: Preferences haloThemeRadioButtons"! !


!PreferencesPanel methodsFor: 'find' stamp: 'sw 1/19/2001 12:31'!
findPreference: evt
	"Allow the user to submit a selector fragment; search for that among preference names; put up a list of qualifying preferences; if the user selects one of those, redirect the preferences panel to reveal the chosen preference"

	| result aList aPalette controlPage |
	result _ FillInTheBlank request: 'Search for preferences containing:' initialAnswer: 'color'.
	result _ result asLowercase copyWithout: $ .
	result isEmptyOrNil ifTrue: [^ self].

	aList _ Preferences allPreferenceFlagKeys select:
		[:aKey | 
			aKey includesSubstring: result caseSensitive: false].
	aPalette _ self containingWindow findDeeplyA: TabbedPalette.
	aPalette ifNil: [^ self].
	aPalette selectTabNamed:  'search results'.
	aPalette currentPage ifNil: [^ self].  "bkwd compat"
	controlPage _ aPalette currentPage.
	controlPage removeAllMorphs.
	aList do:
		[:aPrefSymbol |
			controlPage addMorphBack: (Preferences
								buttonRepresenting: aPrefSymbol
								wording: aPrefSymbol
								color: nil)].
	aPalette world startSteppingSubmorphsOf: aPalette.
"
	result _ (SelectionMenu selections: aList) startUpWithCaption: 'Choose which Preference you want to find'.
	Preferences factoredCategories do:
		[:aCategoryPair |
			(aCategoryPair second includes: result)
				ifTrue:
					[^ self switchToCategoryNamed: aCategoryPair first event: evt]]"! !

!PreferencesPanel methodsFor: 'find' stamp: 'sw 1/10/2001 15:41'!
keyStroke: anEvent
	"Handle a keystroke event in the panel; we map f into a #findPreference: call here"

	(anEvent keyCharacter == $f) ifTrue:
		[^ self findPreference: anEvent]! !
Object subclass: #Presenter
	instanceVariableNames: 'associatedMorph stopButton stepButton goButton standardPlayer standardPlayfield standardPalette playerList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!Presenter commentStamp: '<historical>' prior: 0!
Optionally associated with a PasteUpMorph, provides presentation services.

Holds control buttons:
	stopButton stepButton goButton.

Holds state flags:
	mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled

Holds a viewerCache 

Holds, optionally three 'standard items' originally providing idiomatic support of ongoing squeak-team internal work, but now extended to more general applicability:

   standardPlayer standardPlayfield standardPalette !


!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'!
associatedMorph
	^ associatedMorph! !

!Presenter methodsFor: 'access' stamp: 'sw 4/17/1998 20:07'!
associatedMorph: aMorph
	associatedMorph _ aMorph! !

!Presenter methodsFor: 'access' stamp: 'sw 4/22/1998 20:05'!
world
	^ associatedMorph world! !


!Presenter methodsFor: 'button creation' stamp: 'sw 5/2/1998 18:02'!
addStopStepGoButtons
	self addStopStepGoButtonsTo: associatedMorph! !

!Presenter methodsFor: 'button creation' stamp: 'sw 11/11/1998 15:06'!
addStopStepGoButtonsTo: aPasteUpMorph
	| controls |
	controls _ ScriptingSystem scriptControlButtons.
	controls setToAdhereToEdge: #bottomLeft.
	aPasteUpMorph addMorphBack: controls.
	stopButton _ controls submorphs first.
	stepButton _ controls submorphs second.
	goButton _ controls submorphs third! !

!Presenter methodsFor: 'button creation' stamp: 'sw 3/7/1999 00:52'!
addTrashCan
	| aPosition aCan |
	(aCan _ associatedMorph findA: TrashCanMorph) ifNotNil: [^ aCan].
	aCan _ TrashCanMorph newSticky.
	aPosition _ associatedMorph positionNear: (associatedMorph bottomRight - aCan extent) forExtent: aCan extent adjustmentSuggestion:  (-10 @ 0).
	aCan position: aPosition.
	associatedMorph addMorph: aCan.
	aCan startStepping.
	aCan setToAdhereToEdge: #bottomRight.
	^ aCan
! !


!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 10/30/2000 18:09'!
classNamesForStandardPartsBin
	"Answer a list of class-name lists for insertion onto pages of a standard parts bin"

	^#(
		(RectangleMorph EllipseMorph StarMorph  CurveMorph PolygonMorph TextMorph ImageMorph PasteUpMorph PaintInvokingMorph  StringMorph)
		(JoystickMorph ClockMorph ScriptableButton SimpleSliderMorph PianoKeyboardMorph RecordingControlsMorph))! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 1/14/1999 01:12'!
createStandardPartsBin
	associatedMorph primaryHand attachMorph: self standardPartsWindow ! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'ar 1/31/2001 17:06'!
customPagesForPartsBin
	| aPage aWindow  pu pageList aClass |
	pageList _ OrderedCollection new.

	pageList add: (aPage _ self newPageForStandardPartsBin).
	aPage addMorphBack: (PasteUpMorph authoringPrototype color: (Color r: 0.96 g: 0.96 b: 0.96)).
	aPage addMorphBack: TabbedPalette authoringPrototype.
	aPage addMorphBack: BookMorph authoringPrototype.
	aPage addMorphBack: ScriptingSystem prototypicalHolder.
	aPage addMorphBack: Morph new previousPageButton markAsPartsDonor.
	aPage addMorphBack: Morph new nextPageButton markAsPartsDonor.

	#(DatumMorph) do:
		[:aName | (aClass _ Smalltalk at: aName ifAbsent: [nil]) ifNotNil:
			[aPage addMorphBack: aClass authoringPrototype]].

	pageList add: (aPage _ self newPageForStandardPartsBin).
	aWindow _ Browser new openAsMorphEditing: nil.
	aWindow setLabel: 'System Browser'.
	aPage addMorphBack: aWindow applyModelExtent.

	aWindow _ PackagePaneBrowser new openAsMorphEditing: nil.
	aWindow setLabel: 'Package Browser'.
	aPage addMorphBack: aWindow applyModelExtent.

	aWindow _ Workspace new embeddedInMorphicWindowLabeled: 'Workspace'.
	aPage addMorphBack: aWindow applyModelExtent.
	aPage addMorphBack: FileList openAsMorph applyModelExtent.

	aPage addMorphBack: DualChangeSorter new morphicWindow applyModelExtent.
	aPage addMorphBack: ChangeSorter new morphicWindow applyModelExtent.

	aWindow _ SelectorBrowser new morphicWindow.
	aWindow setLabel: 'Selector Browser'.
	aPage addMorphBack: aWindow.

	pageList add: (aPage _ self newPageForStandardPartsBin).
	aPage addMorphBack: ScriptingSystem newScriptingSpace.
	aPage addMorphBack: ScriptingSystem scriptControlButtons.
	aPage addMorphBack: TrashCanMorph new.
	aPage addMorphBack: PasteUpMorph authoringPrototype.
	aPage addMorphBack: ((pu _ PasteUpMorph newSticky) embeddedInMorphicWindowLabeled: 'assembly').
	pu color: (Color r: 0.839 g: 1.0 b: 0.935).

	pageList do:[:page | page  replaceTallSubmorphsByThumbnails].

	^ pageList
! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 11/16/1998 08:49'!
launchCustomPartsBin
	| aBin |
	(aBin _ ScriptingSystem customPartsBin) ifNotNil:
		[associatedMorph primaryHand attachMorph: aBin]! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'panda 4/25/2000 15:44'!
newPageForStandardPartsBin
	| aPage |
	aPage _ PasteUpMorph new extent:  361@175.
	aPage color: Color white; padding: 6.
	aPage autoLineLayout: true.
	aPage isPartsBin: true; disableDragNDrop.
	aPage setProperty: #alwaysShowThumbnail toValue: true.
	^ aPage! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'ar 11/8/2000 22:37'!
newStandardPartsBinTitled: aTitle includeControls: includeControls
	| aBook aPage aSize |
	aSize _ 360 @ 190.
	aBook _ BookMorph new color: Color blue veryMuchLighter.
	aBook borderWidth: 0.
	aBook removeEverything.
	aBook disableDragNDrop.
	includeControls ifTrue:
		[aBook addMorphBack: (aBook makeMinimalControlsWithColor: Color transparent title: aTitle)].

	self classNamesForStandardPartsBin do:
		[:aList |
			aPage _ self newPageForStandardPartsBin.
			aList do:
				[:sym | aPage addMorphBack: (Smalltalk at: sym) authoringPrototype].
			aPage replaceTallSubmorphsByThumbnails.
			aBook insertPage: aPage pageSize: aSize].

	self customPagesForPartsBin do:
		[:pg | aBook insertPage: pg pageSize: aSize].

	self tilesPagesForPartsBin do:
		[:pg | aBook insertPage: pg pageSize: aSize].

	aBook goToPage: 1.
	aBook currentPage addMorphBack: RectangleMorph roundRectPrototype.

	^ aBook! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 4/21/1998 22:57'!
ownStandardPalette
	^ standardPalette! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'ar 11/8/2000 22:37'!
pageOfSampleWindowsOfExtent: aPoint
	| aPage aWindow pu |
	aPage _ self newPageForStandardPartsBin.
	aPage extent: aPoint.
	aWindow _ Browser new openAsMorphEditing: nil.
	aWindow setLabel: 'System Browser'.
	aPage addMorphBack: aWindow.
	aWindow _ Workspace new embeddedInMorphicWindowLabeled: 'Workspace'.
	aPage addMorphBack: aWindow.
	aPage addMorphBack: FileList openAsMorph.
	aWindow _ SelectorBrowser new morphicWindow.
	aWindow setLabel: 'Selector Browser'.
	aPage addMorphBack: aWindow.
	aPage addMorphBack: ((pu _ PasteUpMorph newSticky borderInset) embeddedInMorphicWindowLabeled: 'assembly').
	pu color: (Color r: 0.839 g: 1.0 b: 0.935).

	aPage  replaceTallSubmorphsByThumbnails.

	^ aPage! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 6/16/1998 16:17'!
standardPalette: aPalette
	standardPalette _ aPalette! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 7/15/1998 19:44'!
standardPaletteIsAlready: aPalette
	^ standardPalette == aPalette! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'sw 3/2/1999 14:09'!
standardPartsWindow
	| aPartsWindow aWorld |
	aPartsWindow _ ScriptingSystem newStandardPartsBin wrappedInPartsWindowWithTitle: 'Standard Parts'.
	aWorld _ (associatedMorph == nil or: [associatedMorph isInWorld not])
		ifTrue:		[self currentWorld]
		ifFalse:		[associatedMorph world].
	aWorld addMorph: aPartsWindow.  "So that closeEditing won't bomb"
	aPartsWindow closeEditing.  "a bit redundant but gets the last details right"
	^ aPartsWindow! !

!Presenter methodsFor: 'palette & parts bin' stamp: 'ar 11/8/2000 22:37'!
tilesPagesForPartsBin
	| aPage bools aTile aPhrase |
	aPage _ self newPageForStandardPartsBin padding: 30.
	bools _ self booleanTiles.
	aPage addMorphBack: bools first markAsPartsDonor.
	aPage addMorphBack: bools last markAsPartsDonor.
	aPage addMorphBack: self arithmeticTiles first markAsPartsDonor.
	aPage addMorphBack: RandomNumberTile new markAsPartsDonor.

	#(('(Sensor anyButtonPressed)' 'button down?')
	('(Sensor noButtonPressed)' 'button up?')
	"('(Sensor keyboardPressed)' 'key hit?')   sucker doesn't work for some reason") do:
		[:pair |
			aPhrase _ SystemQueryPhrase new.
			aTile _ BooleanTile new.
			aTile setExpression: pair first label: pair second.
			aPhrase addMorph: aTile.
			aPage addMorphBack: aPhrase].

	aPage enforceTileColorPolicy.
	aPage replaceTallSubmorphsByThumbnails.
	^ OrderedCollection with: aPage  "room to grow"! !


!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 10/16/1998 09:17'!
createStandardPlayer
	| aMorph |

	aMorph _ ImageMorph new image: (ScriptingSystem formAtKey: 'standardPlayer').
	associatedMorph addMorphFront: aMorph.
	standardPlayer _ aMorph assuredPlayer renameTo: 'dot'.
	aMorph setBalloonText: '...'.
	self positionStandardPlayer.
	^ standardPlayer! !

!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 7/4/1998 14:29'!
positionStandardPlayer
	standardPlayer costume position: (associatedMorph bottomLeft - (0 @ standardPlayer costume height))! !

!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 6/17/1998 16:05'!
standardPlayer
	standardPlayer ifNil:
		[self createStandardPlayer].
	standardPlayer costume isInWorld ifFalse: [associatedMorph addMorphNearBack: standardPlayer costume].
	^ standardPlayer! !

!Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 4/19/1998 01:03'!
standardPlayer: aPlayer
	standardPlayer _ aPlayer! !


!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/12/1998 15:35'!
goButtonState: newState
	goButton ifNotNil:
		[newState
			ifTrue: [goButton state: #on]
			ifFalse: [goButton state: #off]]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 10/30/1998 15:36'!
goUp: evt with: aMorph
	self startRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 2/15/1999 19:46'!
startRunningScripts

	self stopButtonState: false.
	self stepButtonState: false.
	self goButtonState: true.
	associatedMorph startRunningAll.
	associatedMorph borderColor: Preferences borderColorWhenRunning.

	ThumbnailMorph recursionReset.  "needs to be done once in a while"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 2/15/1999 19:46'!
startRunningScriptsFrom: aGoButton
	(goButton == nil or: [goButton isInWorld not]) ifTrue: [goButton _ aGoButton].

	self stopButtonState: false.
	self stepButtonState: false.
	self goButtonState: true.
	associatedMorph startRunningAll.
	associatedMorph borderColor: Preferences borderColorWhenRunning.

	ThumbnailMorph recursionReset.  "needs to be done once in a while"! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/12/1998 15:35'!
stepButtonState: newState
	stepButton ifNotNil:
		[newState
			ifTrue: [stepButton state: #on]
			ifFalse: [stepButton state: #off]]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/6/1998 10:20'!
stepDown: evt with: aMorph
	self stopRunningScripts! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/23/2000 17:53'!
stepStillDown: dummy with: theButton
	(stepButton == nil or: [stepButton isInWorld not]) ifTrue: [stepButton _ theButton].
	self stepButtonState: true.
	self stopButtonState: false.
	associatedMorph stepAll.
	associatedMorph world displayWorld.
	self stepButtonState: false.
	self stopButtonState: true
! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/11/1998 15:50'!
stepUp: evt with: aMorph
	(stepButton == nil or: [stepButton isInWorld not]) ifTrue: [stepButton _ aMorph].
	stepButton state: #off! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 5/12/1998 15:34'!
stopButtonState: newState
	stopButton ifNotNil:
		[newState
			ifTrue: [stopButton state: #on]
			ifFalse: [stopButton state: #off]]! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 2/15/1999 19:46'!
stopRunningScripts
	self stopButtonState: true.
	self stepButtonState: false.
	self goButtonState: false.
	associatedMorph stopRunningAll.
	associatedMorph borderColor: Preferences borderColorWhenStopped! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 2/15/1999 19:46'!
stopRunningScriptsFrom: aStopButton
	(stopButton == nil or: [stopButton isInWorld not]) ifTrue: [stopButton _ aStopButton].
	self stopButtonState: true.
	self stepButtonState: false.
	self goButtonState: false.
	associatedMorph stopRunningAll.
	associatedMorph borderColor: Preferences borderColorWhenStopped! !

!Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 6/29/1998 17:23'!
stopUp: dummy with: theButton
	self flushPlayerListCache.  "catch guys not in cache but who're running"
	self stopRunningScripts! !


!Presenter methodsFor: 'tile support' stamp: 'sw 5/3/1998 22:42'!
arithmeticTiles
	| list rcvr op arg |
		list _ #(
		(1 + 1)
		(1 - 1)
		(2 * 2)
		(6 / 2)
		(4 max: 3)
		(7 min: 2)).

	^ list collect: [:entry |
		rcvr _ entry first.
		op _ (entry at: 2) asSymbol.
		arg _ entry last.
		self phraseForReceiver: rcvr op: op arg: arg resultType: #number]! !

!Presenter methodsFor: 'tile support' stamp: 'sw 4/27/1998 02:56'!
booleanTiles
	| list rcvr op arg |
	list _ #(
		(0 < 1)
		(0 <= 1)
		(0 = 1)
		(0 ~= 1)
		(0 > 1)
		(0 >= 1)).

	list _ list asOrderedCollection collect: [:entry |
		rcvr _ entry first.
		op _ (entry at: 2) asSymbol.
		arg _ entry last.
		self phraseForReceiver: rcvr op: op arg: arg resultType: #boolean].
	list add: (self phraseForReceiver: Color red op: #= arg: Color red resultType: #boolean).
	^ list "copyWith: CompoundTileMorph new"! !

!Presenter methodsFor: 'tile support' stamp: 'sw 11/9/1998 18:48'!
constantTile: anObject

	(anObject isKindOf: Color) ifTrue:
		[^ ColorTileMorph new typeColor: (ScriptingSystem colorForType: #color)].

	^ anObject newTileMorphRepresentative
		typeColor: (ScriptingSystem colorForType: (self typeForConstant: anObject))! !

!Presenter methodsFor: 'tile support' stamp: 'sw 4/25/1998 13:12'!
listPaddedWithSpacersFrom: aList padExtent: padExtent
	| listWithSpacers spacer |
	listWithSpacers _ OrderedCollection new.
	spacer _ Morph newSticky extent: padExtent; color: Color transparent.
	aList do:
		[:aMorph | listWithSpacers add: aMorph.
		listWithSpacers add: spacer deepCopy].
	listWithSpacers size > 1 ifTrue: [listWithSpacers last delete].
	^ listWithSpacers! !

!Presenter methodsFor: 'tile support' stamp: 'sw 4/25/1998 13:27'!
phraseForReceiver: rcvr op: op arg: arg resultType: resultType

	| m argTile rcvrTile |
	arg == nil
		ifTrue:
			[m _ PhraseTileMorph new setOperator: op
				type: resultType
				rcvrType: (self typeForConstant: rcvr)]
		ifFalse:
			[m _ PhraseTileMorph new setOperator: op
				type: resultType
				rcvrType: (self typeForConstant: rcvr)
				argType: (self typeForConstant: arg).
			argTile _ self constantTile: arg.
			argTile position: m lastSubmorph position.
			m lastSubmorph addMorph: argTile].
	rcvrTile _ self constantTile: rcvr.
"	TilePadMorph makeReceiverColorOfResultType ifTrue: [rcvrTile color: m color]."
	rcvrTile position: m firstSubmorph position.
	m firstSubmorph addMorph: rcvrTile.
	^ m! !

!Presenter methodsFor: 'tile support' stamp: 'sw 4/25/1998 13:28'!
typeForConstant: anObject
	^ anObject basicType! !

!Presenter methodsFor: 'tile support' stamp: 'sw 10/29/1998 16:06'!
valueTiles
	| tiles |
	tiles _ OrderedCollection new.
	tiles add: (5 newTileMorphRepresentative typeColor: (ScriptingSystem colorForType: #number)).
	tiles add: ((4 @ 9) newTileMorphRepresentative typeColor: (ScriptingSystem colorForType: #point)).
	tiles add: (ColorTileMorph new typeColor: (ScriptingSystem colorForType: #color)).
	tiles add: (TileMorph new typeColor: (ScriptingSystem colorForType: #number);
			setExpression: '(180 atRandom)'
			label: 'random').
	tiles add: RandomNumberTile new.
	^ tiles! !


!Presenter methodsFor: 'viewer' stamp: 'sw 1/17/1999 21:51'!
nascentPartsViewer
	^ StandardViewer new! !

!Presenter methodsFor: 'viewer' stamp: 'sw 12/28/1998 22:34'!
updateViewer: aViewer
	self updateViewer: aViewer forceToShow: nil! !

!Presenter methodsFor: 'viewer' stamp: 'ar 11/9/2000 21:06'!
updateViewer: aViewer forceToShow: aCategory
	"Update the given viewer to make sure it is in step with various possible changes in the outside world, and when reshowing it be sure it shows the given category"

	| aPlayer aPosition newViewer oldOwner wasSticky barHeight cats |
	cats _ aViewer categoriesCurrentlyShowing asOrderedCollection.
	aCategory ifNotNil: [(cats includes: aCategory) ifFalse: [cats addFirst: aCategory]].
	aPlayer _ aViewer scriptedPlayer.
	aPosition _ aViewer position.
	wasSticky _ aViewer isSticky.
	newViewer _ aViewer species new visible: false.
	barHeight _ aViewer submorphs first listDirection == #topToBottom
		ifTrue:
			[aViewer submorphs first submorphs first height]
		ifFalse:
			[0].
	newViewer initializeFor: aPlayer barHeight: barHeight includeDismissButton: aViewer hasDismissButton showCategories: cats.
	wasSticky ifTrue: [newViewer beSticky].
	oldOwner _ aViewer owner.
	oldOwner ifNotNil:
		[oldOwner replaceSubmorph: aViewer by: newViewer].
	
	"It has happened that old readouts are still on steplist.  We may see again!!"

	newViewer position: aPosition.
	newViewer enforceTileColorPolicy.
	newViewer visible: true.
	newViewer world doIfNotNil: [:aWorld | aWorld startSteppingSubmorphsOf: newViewer].
	newViewer layoutChanged! !

!Presenter methodsFor: 'viewer' stamp: 'RAA 12/15/2000 19:37'!
viewMorph: aMorph
	| aPlayer aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc |
	Sensor leftShiftDown ifFalse:
		[((aPalette _ aMorph standardPalette) ~~ nil and: [aPalette isInWorld])
			ifTrue:	[^ aPalette viewMorph: aMorph]].

	aPlayer _ (topItem _ aMorph topRendererOrSelf) assuredPlayer.
	aViewer _ self nascentPartsViewer.

	"19 sept 2000 - allow flaps in any paste up"
	flapLoc _ associatedMorph "world".
	Preferences viewersInFlaps ifTrue:
		[aViewer setProperty: #noInteriorThumbnail toValue: true.
		aViewer initializeFor: aPlayer barHeight: 0.
		aViewer enforceTileColorPolicy.
		aViewer fullBounds. "force layout"
		"associatedMorph addMorph: aViewer."		"why???"
		flapLoc hideViewerFlapsOtherThanFor: aPlayer.
		aFlapTab _ flapLoc viewerFlapTabFor: topItem.
		aFlapTab referent submorphs do: 
			[:m | (m isKindOf: Viewer) ifTrue: [m delete]].

		aViewer visible: true.
		aFlapTab applyThickness: aViewer width + 25.
		aFlapTab spanWorld.
		aFlapTab showFlap. 
		aViewer position: aFlapTab referent position.
		aFlapTab referent addMorph: aViewer beSticky.		"moved"
		flapLoc startSteppingSubmorphsOf: aFlapTab.
		flapLoc startSteppingSubmorphsOf: aViewer.
		^ aFlapTab].
		
	aViewer initializeFor: aPlayer barHeight: 6.
	aViewer enforceTileColorPolicy.
	aViewer fullBounds. "force layout"
	Preferences automaticViewerPlacement ifTrue:
		[aPoint _ aMorph bounds right @ 
			(aMorph center y - ((nominalHeight _ aViewer initialHeightToAllow) // 2)).
		aRect _ (aPoint extent: (aViewer width @ nominalHeight)) translatedToBeWithin: flapLoc bounds.
		aViewer position: aRect topLeft.
		aViewer visible: true.
		associatedMorph addMorph: aViewer.
		flapLoc startSteppingSubmorphsOf: aViewer.
		"it's already in the world, somewhat coincidentally"
		^ aViewer].
	aMorph primaryHand attachMorph: (aViewer visible: true).
	^ aViewer! !

!Presenter methodsFor: 'viewer' stamp: 'sw 10/30/2000 15:51'!
viewObject: anObject
	"Open up a viewer on the given object"

	|  aViewer aRect aPoint nominalHeight aFlapTab flapLoc |
	anObject isMorph ifTrue: [^ self viewMorph: anObject].  "historic morph/player implementation"

	associatedMorph addMorph: (aViewer _ self nascentPartsViewer).

	"19 sept 2000 - allow flaps in any paste up"
	flapLoc _ associatedMorph "world".
	Preferences viewersInFlaps ifTrue:
		[aViewer setProperty: #noInteriorThumbnail toValue: true.
		aViewer initializeFor: anObject barHeight: 0.
		aViewer enforceTileColorPolicy.
		flapLoc hideViewerFlapsOtherThanFor: anObject.
		aFlapTab _ flapLoc viewerFlapTabFor: anObject.
		aFlapTab referent submorphs do: 
			[:m | (m isKindOf: Viewer) ifTrue: [m delete]].
		aFlapTab referent addMorph: aViewer beSticky.
		aViewer visible: true.
		aFlapTab applyThickness: aViewer width + 25.
		aFlapTab spanWorld.
		aFlapTab showFlap. 
		aViewer position: aFlapTab referent position.
		flapLoc startSteppingSubmorphsOf: aFlapTab.
		^ flapLoc startSteppingSubmorphsOf: aViewer].
		
	aViewer initializeFor: anObject barHeight: 6.
	aViewer enforceTileColorPolicy.
	Preferences automaticViewerPlacement ifTrue:
		[aPoint _ anObject bounds right @ 
			(anObject center y - ((nominalHeight _ aViewer initialHeightToAllow) // 2)).
		aRect _ (aPoint extent: (aViewer width @ nominalHeight)) translatedToBeWithin: flapLoc bounds.
		aViewer position: aRect topLeft.
		aViewer visible: true.
		flapLoc startSteppingSubmorphsOf: aViewer.
		"it's already in the world, somewhat coincidentally"
		^ self].
	anObject primaryHand attachMorph: (aViewer visible: true)! !


!Presenter methodsFor: 'misc' stamp: 'tk 1/8/2001 10:58'!
currentlyViewing: aPlayer
	"Only detects viewers in tabs"

	aPlayer ifNil: [^ false].
	^ aPlayer viewerFlapTab ~~ nil! !

!Presenter methodsFor: 'misc' stamp: 'sw 4/22/1998 14:31'!
dragAndDropToMakeNewDrawing
	"Triggered by the user's dragging from the paint-brush; wherever the user drops the paintbrush, a new drawing will be started"

	associatedMorph primaryHand attachMorph: PaintInvokingMorph authoringPrototype! !

!Presenter methodsFor: 'misc' stamp: 'sw 6/30/1999 20:25'!
drawingJustCompleted: aSketchMorph
	| aPaintBox aPaintTab aWorld |
	(aPaintTab _ (aWorld _ associatedMorph world) paintingFlapTab)
		ifNotNil:
			[aPaintTab hideFlap]
		ifNil:
			[(aPaintBox _ aWorld paintBox) ifNotNil:
				[aPaintBox delete]].

	(aWorld hasProperty: #automaticFlapViewing)
		ifTrue:
			[^ aWorld presenter viewMorph: aSketchMorph].

	(aSketchMorph pasteUpMorph hasProperty: #automaticViewing)
		ifTrue:
			[self viewMorph: aSketchMorph]! !

!Presenter methodsFor: 'misc' stamp: 'sw 6/30/1999 20:31'!
morph: aMorph droppedIntoPasteUpMorph: aPasteUpMorph
	aPasteUpMorph automaticViewing ifTrue:
		[aMorph isCandidateForAutomaticViewing ifTrue:
			[self viewMorph: aMorph]]! !

!Presenter methodsFor: 'misc' stamp: 'sw 3/3/1999 01:15'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' (', self asOop printString, ')'! !

!Presenter methodsFor: 'misc' stamp: 'sw 4/18/1998 00:32'!
returnToFrontPage
	self inform: 'This would return you
to the front page.'! !

!Presenter methodsFor: 'misc' stamp: 'sw 6/17/1998 10:16'!
standardPlayfield: aPlayfield
	standardPlayfield _ aPlayfield! !

!Presenter methodsFor: 'misc' stamp: 'sw 4/23/1998 18:47'!
tempCommand
	Transcript cr; show: '#tempCommand invoked for Presenter'! !


!Presenter methodsFor: 'playerList' stamp: 'sw 4/21/1999 10:47'!
allExtantPlayers
	"The initial intent here was to produce a list of Player objects associated with any Morph in the tree beneath the receiver's associatedMorph.  whether it is the submorph tree or perhaps off on unseen bookPages.  We have for the moment moved away from that initial intent, and in the current version we only deliver up players associated with the submorph tree only.

Call #flushPlayerListCache to force recomputation."

	playerList ifNotNil:
		[^ playerList].

	^ playerList _ (associatedMorph allMorphs select: 
		[:m | m player ~~ nil] thenCollect: [:m | m player]) asSet asArray! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/12/2001 16:58'!
allPlayersWithUniclasses
	"Answer a list of all players known to the receiver that have uniclasses"

	^ self allExtantPlayers select: [:p | p belongsToUniClass]! !

!Presenter methodsFor: 'playerList' stamp: 'sw 6/29/1998 17:17'!
flushPlayerListCache
	playerList _ nil! !

!Presenter methodsFor: 'playerList' stamp: 'sw 12/30/1998 19:50'!
repairPlayerList
	"Presenter allInstancesDo: [:p | p repairPlayerList]"
	playerList ifNotNil:
		[playerList _ playerList select: [:p | p isKindOf: Player]]! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/23/2001 11:11'!
reportPlayersAndScripts
	"Open a window which contains a report on players and their scripts"

	| aList aString |
	(aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players'].
	aString _ String streamContents:
		[:aStream |
			aList do:
				[:aPair | aStream nextPutAll: aPair first name, ' -- ', aPair second printString, ' instance',
		(aPair second > 1 ifTrue: ['s'] ifFalse: ['']) , ', named '.
					aPair first allInstancesDo: [:inst | aStream space; nextPutAll: inst externalName].
					aStream cr].
			aStream cr.
			aList do:
				[:aPair |
					aStream cr.
					aStream nextPutAll: 
'--------------------------------------------------------------------------------------------'.
					aStream cr; nextPutAll: aPair first name.
					aPair first addDocumentationForScriptsTo: aStream]].

	(StringHolder new contents: aString)
		openLabel: 'All scripts of all players in this world'

"self currentWorld presenter reportPlayersAndScripts"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/30/2001 23:07'!
toolToViewScriptInstantiations
	"Open a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the world"

	AllScriptsTool launchAllScriptsToolFor: self

	"self currentWorld presenter toolToViewScriptInstantiations"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/12/2001 18:10'!
uniclassesAndCounts
	"Answer a list of all players known to the receiver that have uniclasses"

	^ (self allPlayersWithUniclasses collect: [:aPlayer | aPlayer class]) asSet asArray collect:
		[:aClass | Array
			with:	aClass
			with:	aClass instanceCount]


	"self currentWorld presenter uniclassesAndCounts"! !

!Presenter methodsFor: 'playerList' stamp: 'sw 1/31/2001 23:11'!
updateContentsFor: aStatusViewer 
	"Rebuild the contents of the script-statusViewing tool"

	| showingOnlyActiveScripts candidateList firstTwo |

	showingOnlyActiveScripts _ aStatusViewer showingOnlyActiveScripts.
	self flushPlayerListCache.

	firstTwo  _ {aStatusViewer submorphs first.  aStatusViewer submorphs second}.
	aStatusViewer removeAllMorphs; addAllMorphs: firstTwo.
	
	candidateList _ self allExtantPlayers.
	aStatusViewer showingAllInstances "take all instances of all classes"
		ifTrue:
			[candidateList _ self allExtantPlayers]  

		ifFalse:  "include only one exemplar per uniclass.  Try to get one that has some qualifying scripts"
			[candidateList _ Set new.
			self allExtantPlayers do:
				[:aPlayer |
					(candidateList detect: [:plyr | plyr isMemberOf:  aPlayer class] ifNone: [nil]) ifNil:
						[aPlayer instantiatedUserScriptsDo: [:aScriptInstantiation |
							(showingOnlyActiveScripts not or: [#(paused ticking) includes: aScriptInstantiation status]) 								ifTrue:
									[candidateList add: aPlayer]]]]].
	candidateList do:
		[:aPlayer | aPlayer instantiatedUserScriptsDo:
			[:aScriptInstantiation |
				(showingOnlyActiveScripts not or: [#(paused ticking) includes: aScriptInstantiation status]) ifTrue:
					[aStatusViewer addMorphBack: (aScriptInstantiation statusControlRowIn: aStatusViewer)]]].! !

TextDiffBuilder subclass: #PrettyTextDiffBuilder
	instanceVariableNames: 'sourceClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'NK-PrettyDiffs'!

!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:16'!
sourceClass: aClass
	sourceClass _ aClass.! !

!PrettyTextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:20'!
split: aString 
	| formatted |
	formatted _ sourceClass compilerClass new
format: aString
				in: sourceClass
				notifying: nil
				decorated: false.
	^super split: formatted! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrettyTextDiffBuilder class
	instanceVariableNames: ''!

!PrettyTextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:35'!
from: srcString to: dstString inClass: srcClass 
	^ (self new sourceClass: srcClass) from: srcString to: dstString
		!
]style[(6 9 5 9 10 8 6 4 18 8 8 9 5 9 3)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !
TextComponent subclass: #PrintComponent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!PrintComponent methodsFor: 'as yet unclassified' stamp: 'di 4/27/1998 11:49'!
accept
	"Inform the model of text to be accepted, and return true if OK."
	| textToAccept |
	self canDiscardEdits ifTrue: [^ self flash].
	setTextSelector == nil ifTrue: [^ self].
	textToAccept _ textMorph asText.
	model perform: setTextSelector
			with: (Compiler evaluate: textToAccept logged: false).
	self setText: textToAccept.
	self hasUnacceptedEdits: false! !

!PrintComponent methodsFor: 'as yet unclassified' stamp: 'di 4/27/1998 11:35'!
getText 
	"Retrieve the current model text"

	getTextSelector == nil ifTrue: [^ Text new].
	^ (model perform: getTextSelector) printString asText! !

!PrintComponent methodsFor: 'as yet unclassified' stamp: 'di 5/1/1998 13:39'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'value' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
				defaultValue: nil pinLoc: 1.5)! !
PrintableEncoder subclass: #PrintEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrintEncoder class
	instanceVariableNames: ''!

!PrintEncoder class methodsFor: 'configuring' stamp: 'MPW 1/1/1901 01:50'!
filterSelector
	^#printOnStream:! !
Object subclass: #PrintSpecifications
	instanceVariableNames: 'landscapeFlag drawAsBitmapFlag '
	classVariableNames: 'DefaultSpecs '
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:06'!
drawAsBitmapFlag

	^drawAsBitmapFlag ifNil: [false]! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:07'!
drawAsBitmapFlag: aBoolean

	drawAsBitmapFlag _ aBoolean! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:24'!
initialize

	landscapeFlag _ false.
! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 17:06'!
landscapeFlag

	^landscapeFlag ifNil: [false]! !

!PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:24'!
landscapeFlag: aBoolean

	landscapeFlag _ aBoolean! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PrintSpecifications class
	instanceVariableNames: ''!

!PrintSpecifications class methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:29'!
defaultSpecs

	DefaultSpecs ifNil: [DefaultSpecs _ self new].
	^DefaultSpecs copy! !

!PrintSpecifications class methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:29'!
defaultSpecs: aPrintSpecification

	DefaultSpecs _ aPrintSpecification! !

!PrintSpecifications class methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 09:24'!
new

	^super new initialize! !
ByteEncoder subclass: #PrintableEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

!PrintableEncoder methodsFor: 'writing' stamp: 'MPW 1/1/1901 22:50'!
writeNumber:aNumber base:aBase
	aBase ~= self numberDefaultBase ifTrue:[ self write:aBase; print:'r'].
	^super writeNumber:aNumber base:aBase.
! !
Link subclass: #Process
	instanceVariableNames: 'suspendedContext priority myList errorHandler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Process commentStamp: '<historical>' prior: 0!
I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority.

(If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.)!


!Process methodsFor: 'changing process state'!
resume
	"Primitive. Allow the process that the receiver represents to continue. Put 
	the receiver in line to become the activeProcess. Fail if the receiver is 
	already waiting in a queue (in a Semaphore or ProcessScheduler). 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 87>
	self primitiveFailed! !

!Process methodsFor: 'changing process state'!
suspend
	"Primitive. Stop the process that the receiver represents in such a way 
	that it can be restarted at a later time (by sending the receiver the 
	message resume). If the receiver represents the activeProcess, suspend it. 
	Otherwise fail and the code below will remove the receiver from the list 
	of waiting processes. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 88>
	Processor activeProcess == self
		ifTrue: [self primitiveFailed]
		ifFalse: 
			[Processor remove: self ifAbsent: [self error: 'This process was not active'].
			myList _ nil]! !

!Process methodsFor: 'changing process state' stamp: 'tfei 4/1/1999 18:23'!
terminate 
	"Stop the process that the receiver represents forever."

	| context |
	Processor activeProcess == self
		ifTrue: 
			[thisContext unwindTo: nil.
			thisContext sender == nil ifFalse:
				[thisContext sender release].
			thisContext removeSelf suspend]
		ifFalse: 
			[myList == nil
				ifFalse: 
					[myList remove: self ifAbsent: [].
					myList _ nil].
			context _ suspendedContext.
			suspendedContext _ nil.
			context == nil ifFalse: [context unwindTo: nil].
			(context ~~ nil and: [context sender ~~ nil])
				ifTrue: [context sender release]]! !


!Process methodsFor: 'changing suspended state'!
install: aContext 
	"Replace the suspendedContext with aContext."

	self == Processor activeProcess
		ifTrue: [^self error: 'The active process cannot install contexts'].
	suspendedContext _ aContext! !

!Process methodsFor: 'changing suspended state'!
popTo: aContext 
	"Replace the suspendedContext with aContext, releasing all contexts 
	between the currently suspendedContext and it."

	self == Processor activeProcess
		ifTrue: [^self error: 'The active process cannot pop contexts'].
	suspendedContext releaseTo: aContext.
	suspendedContext _ aContext! !


!Process methodsFor: 'accessing' stamp: 'nk 10/28/2000 19:55'!
isSuspended
	^myList isNil! !

!Process methodsFor: 'accessing'!
offList
	"Inform the receiver that it has been taken off a list that it was 
	suspended on. This is to break a backpointer."

	myList _ nil! !

!Process methodsFor: 'accessing'!
priority
	"Answer the priority of the receiver."

	^priority! !

!Process methodsFor: 'accessing'!
priority: anInteger 
	"Set the receiver's priority to anInteger."

	anInteger<=Processor highestPriority
		ifTrue: [priority _ anInteger]
		ifFalse: [self error: 'priority too high']! !

!Process methodsFor: 'accessing'!
suspendedContext
	"Answer the context the receiver has suspended."

	^suspendedContext! !

!Process methodsFor: 'accessing'!
suspendingList
	"Answer the list on which the receiver has been suspended."

	^myList! !


!Process methodsFor: 'printing' stamp: 'nk 10/28/2000 07:33'!
browserPrintString
	^self browserPrintStringWith: suspendedContext! !

!Process methodsFor: 'printing' stamp: 'nk 10/31/2000 09:09'!
browserPrintStringWith: anObject 
	| stream |
	stream _ WriteStream
				on: (String new: 100).
	stream nextPut: $(.
	priority printOn: stream.
	self isSuspended
		ifTrue: [stream nextPut: $s].
	stream nextPutAll: ') '.
	stream
		nextPutAll: ((self respondsTo: #processName)
				ifTrue: [self processName]
				ifFalse: [self hash asString forceTo: 5 paddingStartWith: $ ]).
	stream space.
	stream nextPutAll: anObject asString.
	^ stream contents! !

!Process methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' in '.
	suspendedContext printOn: aStream! !


!Process methodsFor: 'private'!
suspendedContext: aContext

	suspendedContext _ aContext! !


!Process methodsFor: 'error handling'!
errorHandler
    ^ errorHandler! !

!Process methodsFor: 'error handling'!
errorHandler: aBlock
    errorHandler _ aBlock! !


!Process methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'!
objectForDataStream: refStrm
	"I am not allowed to be written on an object file."

	refStrm replace: self with: nil.
	^ nil! !


!Process methodsFor: 'debugging' stamp: 'nk 10/29/2000 13:43'!
debug
	self debugWithTitle: 'Debug'.! !

!Process methodsFor: 'debugging' stamp: 'nk 10/29/2000 13:42'!
debugWithTitle: title
	"Open a debugger on me"
	"Is this the UI process?"
	self == Processor activeProcess
		ifTrue: [Smalltalk isMorphic
				ifTrue: [[Project interruptName: title] fork]
				ifFalse: [[ScheduledControllers interruptName: title] fork].
			^ self].
	myList isNil
		ifTrue: [^ self]
		ifFalse: [myList
				remove: self
				ifAbsent: [].
			self offList].
	Debugger openInterrupt: title onProcess: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Process class
	instanceVariableNames: ''!

!Process class methodsFor: 'instance creation'!
forContext: aContext priority: anInteger 
	"Answer an instance of me that has suspended aContext at priority 
	anInteger."

	| newProcess |
	newProcess _ self new.
	newProcess suspendedContext: aContext.
	newProcess priority: anInteger.
	^newProcess! !
Model subclass: #ProcessBrowser
	instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex sourceMap selectedClass selectedSelector searchString autoUpdateProcess deferredMessageRecipient lastUpdate '
	classVariableNames: 'SuspendedProcesses '
	poolDictionaries: ''
	category: 'NK-Process Browser'!
!ProcessBrowser commentStamp: '<historical>' prior: 0!
Change Set:		ProcessBrowser
Date:			29 October 2000
Author:			Ned Konz

This is a preliminary version
of my Process Browser.

email: ned@bike-nomad.com

This is distributed under the Squeak License.

Added 29 October:
	MVC version
	2.8, 2.7 compatibility
	rearranged menus
	added pointer inspection and chasing
	added suspend/resume
	recognized more well-known processes
	misc. bug fixes

Added 26 October: highlight pc in source code
Added 27 October: added 'signal semaphore'
added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu
added 'find context', 'next context' to process list menu
added 'change priority' and 'debug' choices to process list menu

27 October mods by Bob Arning:

alters process display in Ned's ProcessBrowser to 
- show process priority
- drop 'a Process in' that appears on each line
- show in priority order
- prettier names for known processes
- fix to Utilities to forget update downloading process when it ends (1 less dead
process)
- correct stack dump for the active process
!


!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 09:24'!
exploreProcess
	selectedProcess explore! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 11:53'!
findContext
	| initialProcessIndex initialStackIndex found |
	initialProcessIndex _ self processListIndex.
	initialStackIndex _ self stackListIndex.
	searchString _ FillInTheBlank request: 'Enter a string to search for in the process stack lists' initialAnswer: searchString.
	searchString isEmpty
		ifTrue: [^ false].
	self processListIndex: 1.
	self stackListIndex: 1.
	found _ self nextContext.
	found
		ifFalse: [self processListIndex: initialProcessIndex.
			self stackListIndex: initialStackIndex].
	^ found! !

!ProcessBrowser methodsFor: 'process list'!
inspectProcess
	selectedProcess inspect! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 11:52'!
nextContext
	| initialProcessIndex initialStackIndex found |
	searchString isEmpty ifTrue: [ ^false ].
	initialProcessIndex _ self processListIndex.
	initialStackIndex _ self stackListIndex.
	found _ false.
	initialProcessIndex
		to: self processList size
		do: [:pi | found
				ifFalse: [self processListIndex: pi.
					self stackNameList
						withIndexDo: [:name :si | (found not
									and: [pi ~= initialProcessIndex
											or: [si > initialStackIndex]])
								ifTrue: [(name includesSubString: searchString)
										ifTrue: [self stackListIndex: si.
											found _ true]]]]].
	found
		ifFalse: [self processListIndex: initialProcessIndex.
			self stackListIndex: initialStackIndex].
	^ found! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/28/2000 08:19'!
notify: errorString at: location in: aStream 
	"A syntax error happened when I was trying to highlight my pc. 
	Raise a signal so that it can be ignored."
	Warning signal: 'syntax error'!
]style[(8 11 5 8 5 7 3 107 2 7 23)f1b,f1cblack;b,f1b,f1cblack;b,f1b,f1cblack;b,f1,f1c143041000,f1,f1cblack;,f1! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/28/2000 20:30'!
prettyNameForProcess: aProcess 
	| nameAndRules |
	nameAndRules _ self nameAndRulesFor: aProcess.
	^ aProcess browserPrintStringWith: nameAndRules first! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/29/2000 10:20'!
processListKey: aKey from: aView 
	^ aKey caseOf: {
		[$i] -> [self inspectProcess].
		[$I] -> [self exploreProcess].
		[$c] -> [self chasePointers].
		[$P] -> [self inspectPointers].
		[$t] -> [self terminateProcess].
		[$r] -> [self resumeProcess].
		[$s] -> [self suspendProcess].
		[$d] -> [self debugProcess].
		[$p] -> [self changePriority].
		[$m] -> [self messageTally].
		[$f] -> [self findContext].
		[$g] -> [self nextContext].
		[$a] -> [self toggleAutoUpdate].
		[$u] -> [self updateProcessList].
		[$S] -> [self signalSemaphore].
		[$k] -> [self moreStack]}
		 otherwise: [self arrowKey: aKey from: aView]! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/29/2000 10:22'!
processListMenu: menu 
	selectedProcess
		ifNotNil: [| nameAndRules | 
			nameAndRules _ self nameAndRulesForSelectedProcess.
			menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers.  ].
			nameAndRules second
				ifTrue: [menu add: 'terminate (t)' action: #terminateProcess.
					selectedProcess isSuspended
						ifTrue: [menu add: 'resume (r)' action: #resumeProcess]
						ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]].
			nameAndRules third
				ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}].
			menu addList: {{'profile messages (m)'. #messageTally}}.
			(selectedProcess suspendingList isKindOf: Semaphore)
				ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore].
			menu add: 'full stack (k)' action: #moreStack.
			menu addLine].
	menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}.
	menu addLine.
	menu
		add: (self isAutoUpdating
				ifTrue: ['turn off auto-update (a)']
				ifFalse: ['turn on auto-update (a)'])
		action: #toggleAutoUpdate.
	menu add: 'update list (u)' action: #updateProcessList.
	^ menu! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 18:23'!
processNameList
	"since processList is a WeakArray, we have to strengthen the result"
	^ processList asOrderedCollection
		collect: [:each | self prettyNameForProcess: each] ! !

!ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/30/2000 18:23'!
updateProcessList
	| oldSelectedProcess newIndex now |
	now _ Time millisecondClockValue.
	now - lastUpdate < 500
		ifTrue: [^ self].
	"Don't update too fast"
	lastUpdate _ now.
	oldSelectedProcess _ selectedProcess.
	processList _ selectedProcess _ selectedSelector _ nil.
	Smalltalk garbageCollect.
	"lose defunct processes"

	processList _ Process allSubInstances
				reject: [:each | each suspendedContext isNil].
	processList _ processList
				sortBy: [:a :b | a priority >= b priority].
	processList _ WeakArray withAll: processList.
	newIndex _ processList
				indexOf: oldSelectedProcess
				ifAbsent: [0].
	self changed: #processNameList.
	self processListIndex: newIndex! !


!ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 10/29/2000 10:50'!
initialize
	methodText _ ''.
	stackListIndex _ 0.
	searchString _ ''.
	lastUpdate _ 0.
	self updateProcessList; processListIndex: 1! !

!ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 10/28/2000 20:53'!
perform: selector orSendTo: otherTarget 
	"Selector was just chosen from a menu by a user. If can respond, then  
	perform it on myself. If not, send it to otherTarget, presumably the  
	editPane from which the menu was invoked."
	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ super perform: selector orSendTo: otherTarget]! !


!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:49'!
browseContext
	selectedContext
		ifNil: [^ self].
	Browser newOnClass: self selectedClass selector: self selectedSelector!
]style[(13 30 4 4 7 42 4 17)f1b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'RAA 10/27/2000 15:21'!
changeStackListTo: aCollection 

        stackList _ aCollection.
        self changed: #stackNameList.
        self stackListIndex: 0! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:28'!
exploreContext
	selectedContext explore! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'!
exploreReceiver
	selectedContext ifNotNil: [ selectedContext receiver explore ]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:23'!
inspectContext
	selectedContext inspect! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'!
inspectReceiver
	selectedContext
		ifNotNil: [selectedContext receiver inspect]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/29/2000 14:25'!
messageTally
	| secString secs |
	secString _ FillInTheBlank request: 'Profile for how many seconds?' initialAnswer: '4'.
	secs _ secString asNumber asInteger.
	(secs isNil
			or: [secs isZero])
		ifTrue: [^ self].
	MessageTally spyOnProcess: selectedProcess forMilliseconds: secs * 1000! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 12:13'!
moreStack
	self updateStackList: 2000! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/29/2000 14:18'!
pcRange
	"Answer the indices in the source code for the method corresponding to  
	the selected context's program counter value."
	| i methodNode pc end tempNames |
	methodText isEmptyOrNil
		ifTrue: [^ 1 to: 0].
	sourceMap == nil
		ifTrue: [self selectedClass == #unknown
				ifTrue: [^ 1 to: 0].
			[[methodNode _ self selectedClass compilerClass new
						parse: methodText
						in: self selectedClass
						notifying: self ]
				on: Warning
				do: [:ex | 
					methodText _ ('(syntax error) ' , ex description , String cr , methodText) asText.
					ex return]]
				on: Error
				do: [:ex | 
					methodText _ ('(parse error) ' , ex description , String cr , methodText) asText.
					ex return].
			methodNode
				ifNil: [sourceMap _ nil.
					^ 1 to: 0].
			sourceMap _ methodNode sourceMap.
			tempNames _ methodNode tempNames.
			selectedContext method cacheTempNames: tempNames].
	sourceMap size = 0
		ifTrue: [^ 1 to: 0].
	pc _ selectedContext pc.
	pc
		ifNil: [^ 1 to: 0].
	pc _ pc - 2.
	i _ sourceMap
				indexForInserting: (Association key: pc value: nil).
	i < 1
		ifTrue: [^ 1 to: 0].
	i > sourceMap size
		ifTrue: [end _ sourceMap
						inject: 0
						into: [:prev :this | prev max: this value last].
			^ end + 1 to: end].
	^ (sourceMap at: i) value! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:53'!
stackListMenu: aMenu 
	| menu |
	selectedContext
		ifNil: [^ aMenu].
	menu _ aMenu
				labels: 'inspect context (c)
explore context (C)
inspect receiver (i)
explore receiver (I)
browse (b)'
				lines: #(2 4 )
				selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext ).
	^ menu! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:18'!
stackNameList
	^ stackList
		ifNil: [#()]
		ifNotNil: [stackList
				collect: [:each | each asString]]! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:24'!
updateStackList
	self updateStackList: 20! !

!ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 09:00'!
updateStackList: depth 
	| suspendedContext oldHighlight |
	selectedProcess
		ifNil: [^ self changeStackListTo: nil].
	(stackList notNil and: [ stackListIndex > 0 ])
		ifTrue: [oldHighlight _ stackList at: stackListIndex].
	selectedProcess == Processor activeProcess
		ifTrue: [self
				changeStackListTo: (thisContext stackOfSize: depth)]
		ifFalse: [suspendedContext _ selectedProcess suspendedContext.
			suspendedContext
				ifNil: [self changeStackListTo: nil]
				ifNotNil: [self
						changeStackListTo: (suspendedContext stackOfSize: depth)]].
	self
		stackListIndex: (stackList
				ifNil: [0]
				ifNotNil: [stackList indexOf: oldHighlight])!
]style[(17 5 4 30 4 15 13 4 20 3 29 14 3 4 12 12 3 9 5 14 4 15 4 9 26 4 25 11 14 5 15 16 3 15 22 16 13 4 20 3 17 4 27 16 14 5 6 4 20 9 13 1 17 9 10 12 2)f1b,f1cblack;b,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblack;,f1,f1cblue;,f1,f1cblack;,f1,f1cblack;,f1! !


!ProcessBrowser methodsFor: 'accessing'!
processList
	^ processList! !

!ProcessBrowser methodsFor: 'accessing'!
processListIndex
	^ processListIndex! !

!ProcessBrowser methodsFor: 'accessing'!
processListIndex: index 
	processListIndex _ index.
	selectedProcess _ processList
				at: index
				ifAbsent: [].
	self updateStackList.
	self changed: #processListIndex.! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/26/2000 23:31'!
selectedClass
	"Answer the class in which the currently selected context's method was  
	found."
	^ selectedClass
		ifNil: [selectedClass _ selectedContext receiver
				ifNil: [| who | 
					who _ selectedContext method who.
					selectedSelector _ who last.
					who first]
				ifNotNil: [selectedContext mclass]]! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:30'!
selectedMethod
	^ methodText ifNil: [methodText _ selectedContext
						ifNil: ['']
						ifNotNil: [| pcRange | 
							methodText _ selectedContext sourceCode.
							pcRange _ self pcRange.
							methodText asText
								addAttribute: TextColor red
								from: pcRange first
								to: pcRange last;
								
								addAttribute: TextEmphasis bold
								from: pcRange first
								to: pcRange last]]! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/26/2000 23:31'!
selectedSelector
	"Answer the class in which the currently selected context's method was  
	found."
	^ selectedSelector
		ifNil: [selectedSelector _ selectedContext receiver
				ifNil: [| who | 
					who _ selectedContext method.
					selectedClass _ who first.
					who last]
				ifNotNil: [selectedContext selector]]! !

!ProcessBrowser methodsFor: 'accessing'!
stackList
	^ stackList! !

!ProcessBrowser methodsFor: 'accessing'!
stackListIndex
	^ stackListIndex! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:57'!
stackListIndex: index 
	stackListIndex _ index.
	selectedContext _ nil.
	(stackList notNil
			and: [index > 0])
		ifTrue: [selectedContext _ stackList
						at: index
						ifAbsent: []].
	sourceMap _ nil.
	selectedClass _ nil.
	selectedSelector _ nil.
	methodText _ nil.
	self changed: #stackListIndex.
	self changed: #selectedMethod! !

!ProcessBrowser methodsFor: 'accessing' stamp: 'nk 10/28/2000 08:36'!
text
	^methodText! !


!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 11:44'!
hasView
	^self dependents isEmptyOrNil not! !

!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 22:32'!
openAsMVC
	"Create a pluggable version of me, answer a window"
	| window processListView stackListView methodTextView |
	window _ StandardSystemView new model: self controller: (deferredMessageRecipient _ DeferredActionStandardSystemController new).
	window borderWidth: 1.
	processListView _ PluggableListView
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #processListMenu:
				keystroke: #processListKey:from:.
	processListView
		window: (0 @ 0 extent: 300 @ 200).
	window addSubView: processListView.
	stackListView _ PluggableListView
				on: self
				list: #stackNameList
				selected: #stackListIndex
				changeSelected: #stackListIndex:
				menu: #stackListMenu:
				keystroke: #stackListKey:from:.
	stackListView
		window: (300 @ 0 extent: 300 @ 200).
	window addSubView: stackListView toRightOf: processListView.
	methodTextView _ PluggableTextView
				on: self
				text: #selectedMethod
				accept: nil
				readSelection: nil
				menu: nil.
	methodTextView askBeforeDiscardingEdits: false.
	methodTextView
		window: (0 @ 200 corner: 600 @ 400).
	window addSubView: methodTextView below: processListView.
	window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
	window label: 'Process Browser'.
	window minimumSize: 300 @ 200.
	window subViews
		do: [:each | each controller].
	window controller open.
	^ window! !

!ProcessBrowser methodsFor: 'views' stamp: 'RAA 12/1/2000 10:18'!
openAsMorph
	"Create a pluggable version of me, answer a window"
	| window aTextMorph |
	window _ (SystemWindow labelled: 'later')
				model: self.

	deferredMessageRecipient _ WorldState.
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #processNameList
				selected: #processListIndex
				changeSelected: #processListIndex:
				menu: #processListMenu:
				keystroke: #processListKey:from:)
				enableDragNDrop: false)
		frame: (0 @ 0 extent: 0.5 @ 0.5).
	window
		addMorph: ((PluggableListMorph
				on: self
				list: #stackNameList
				selected: #stackListIndex
				changeSelected: #stackListIndex:
				menu: #stackListMenu:
				keystroke: #stackListKey:from:)
				enableDragNDrop: false)
		frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
	aTextMorph _ PluggableTextMorph
				on: self
				text: #selectedMethod
				accept: nil
				readSelection: nil
				menu: nil.
	aTextMorph askBeforeDiscardingEdits: false.
	window
		addMorph: aTextMorph
		frame: (0 @ 0.5 corner: 1 @ 1).
	window setUpdatablePanesFrom: #(#processNameList #stackNameList ).
	(window setLabel: 'Process Browser') openInWorld.
	^ window! !

!ProcessBrowser methodsFor: 'views' stamp: 'nk 10/28/2000 16:53'!
stackListKey: aKey from: aView 
	^ aKey caseOf: {
		[$c] -> [self inspectContext].
		[$C] -> [self exploreContext].
		[$i] -> [self inspectReceiver].
		[$I] -> [self exploreReceiver].
		[$b] -> [self browseContext]}
		 otherwise: [self arrowKey: aKey from: aView]! !


!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 11:44'!
changePriority
	| str newPriority nameAndRules |
	nameAndRules _ self nameAndRulesForSelectedProcess.
	nameAndRules third
		ifFalse: [PopUpMenu inform: 'Nope, won''t change priority of ' , nameAndRules first.
			^ self].
	str _ FillInTheBlank request: 'New priority' initialAnswer: selectedProcess priority asString.
	newPriority _ str asNumber asInteger.
	newPriority
		ifNil: [^ self].
	(newPriority < 1
			or: [newPriority > Processor highestPriority])
		ifTrue: [PopUpMenu inform: 'Bad priority'.
			^ self].
	selectedProcess priority: newPriority.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 10:18'!
chasePointers
	| saved |
	selectedProcess
		ifNil: [^ self].
	saved _ selectedProcess.
	[selectedProcess _ nil.
	(Smalltalk includesKey: #PointerFinder)
		ifTrue: [PointerFinder on: saved]
		ifFalse: [self inspectPointers]]
		ensure: [selectedProcess _ saved]! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 13:43'!
debugProcess
	| nameAndRules |
	nameAndRules _ self nameAndRulesForSelectedProcess.
	nameAndRules third
		ifFalse: [PopUpMenu inform: 'Nope, won''t debug ' , nameAndRules first.
			^ self].
	selectedProcess debugWithTitle: 'Interrupted from the Process Browser'.
! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 10:17'!
inspectPointers
	| tc pointers |
	selectedProcess
		ifNil: [^ self].
	tc _ thisContext.
			pointers _ Smalltalk pointersTo: selectedProcess except: {self processList. tc. self}.
			pointers isEmpty
				ifTrue: [^ self].
			OrderedCollectionInspector
				openOn: pointers
				withEvalPane: false
				withLabel: 'Objects pointing to ' , selectedProcess browserPrintString
! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 08:38'!
nameAndRulesFor: aProcess 
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	(aProcess priority = Processor timingPriority
			and: [aProcess suspendedContext receiver == Delay])
		ifTrue: [^ {'the timer interrupt watcher'. false. false}].
	^ aProcess caseOf: {
		[] -> [{'no process'. false. false}].
		[autoUpdateProcess] -> [{'my auto-update process'. true. true}].
		[Smalltalk lowSpaceWatcherProcess] -> [{'the low space watcher'. false. false}].
		[WeakArray runningFinalizationProcess] -> [{'the WeakArray finalization process'. false. false}].
		[Processor activeProcess] -> [{'the UI process'. false. true}].
		[Processor backgroundProcess] -> [{'the idle process'. false. false}].
		[Sensor inputProcess] -> [{'the I/O process'. false. false}].
		[Sensor interruptWatcherProcess] -> [{'the user interrupt watcher'. false. false}].
		[Project uiProcess] -> [{'the inactive Morphic UI process'. false. false}].
		[ScheduledControllers activeControllerProcess] -> [{'the inactive MVC controller process'. false. true}]}
		 otherwise: [{aProcess suspendedContext asString. true. true}]! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/28/2000 20:31'!
nameAndRulesForSelectedProcess
	"Answer a nickname and two flags: allow-stop, and allow-debug"
	^self nameAndRulesFor: selectedProcess! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:42'!
resumeProcess
	| priority |
	selectedProcess
		ifNil: [^ self].
	priority _ self class suspendedProcesses
				removeKey: selectedProcess
				ifAbsent: [selectedProcess priority].
	selectedProcess priority: priority.
	selectedProcess resume.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:58'!
signalSemaphore
	(selectedProcess suspendingList isKindOf: Semaphore)
		ifFalse: [^ self].
	[selectedProcess suspendingList signal] fork.
	(Delay forMilliseconds: 300) wait.
	"Hate to make the UI wait, but it's convenient..."
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:57'!
suspendProcess
	| nameAndRules priority |
	selectedProcess isSuspended
		ifTrue: [^ self].
	nameAndRules _ self nameAndRulesForSelectedProcess.
	nameAndRules second
		ifFalse: [PopUpMenu inform: 'Nope, won''t suspend ' , nameAndRules first.
			^ self].
	priority _ selectedProcess priority.
	self class suspendedProcesses at: selectedProcess put: priority.
	"Need to take the priority down below mine so that I can keep control after signaling the Semaphore"
	(selectedProcess suspendingList isKindOf: Semaphore)
		ifTrue: [selectedProcess priority: 1.
			selectedProcess suspendingList signal].
	[selectedProcess suspend]
		on: Error
		do: [:ex | self class suspendedProcesses removeKey: selectedProcess].
	selectedProcess priority: priority.
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 09:10'!
terminateProcess
	| nameAndRules |
	nameAndRules _ self nameAndRulesForSelectedProcess.
	nameAndRules second
		ifFalse: [PopUpMenu inform: 'Nope, won''t kill ' , nameAndRules first.
			^ self].
	selectedProcess
		ifNotNil: [self class suspendedProcesses
		removeKey: selectedProcess
		ifAbsent: [].selectedProcess terminate].
	
	self updateProcessList! !

!ProcessBrowser methodsFor: 'process actions' stamp: 'nk 10/29/2000 08:56'!
wasProcessSuspendedByProcessBrowser: aProcess
	^self class suspendedProcesses includesKey: aProcess! !


!ProcessBrowser methodsFor: 'global actions' stamp: 'nk 10/28/2000 21:48'!
isAutoUpdating
	^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended  not ]! !

!ProcessBrowser methodsFor: 'global actions' stamp: 'nk 10/29/2000 05:24'!
startAutoUpdate
	self isAutoUpdating
		ifFalse: [| delay | 
			delay _ Delay forSeconds: 2.
			autoUpdateProcess _ [[self hasView]
						whileTrue: [delay wait.
							deferredMessageRecipient ifNotNil: [
								deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]]
							ifNil: [ self updateProcessList ]].
					autoUpdateProcess _ nil] fork].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'global actions' stamp: 'nk 10/28/2000 21:49'!
stopAutoUpdate
	self isAutoUpdating
		ifTrue: [autoUpdateProcess terminate.
			autoUpdateProcess _ nil].
	self updateProcessList! !

!ProcessBrowser methodsFor: 'global actions' stamp: 'nk 10/28/2000 21:50'!
toggleAutoUpdate
	self isAutoUpdating
		ifTrue: [ self stopAutoUpdate ]
		ifFalse: [ self startAutoUpdate ].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProcessBrowser class
	instanceVariableNames: ''!

!ProcessBrowser class methodsFor: 'instance creation'!
new
	^super new initialize! !

!ProcessBrowser class methodsFor: 'instance creation' stamp: 'nk 10/28/2000 11:18'!
open
	"ProcessBrowser open"
	"Create and schedule a ProcessBrowser."
	^ Smalltalk isMorphic
		ifTrue: [ self new openAsMorph ]
		ifFalse: [ self new openAsMVC ]! !


!ProcessBrowser class methodsFor: 'accessing' stamp: 'nk 10/29/2000 08:55'!
suspendedProcesses
	"Answer a collection of processes that my instances have suspended.  
	This is so that they don't get garbage collected."
	^ SuspendedProcesses
		ifNil: [SuspendedProcesses _ IdentityDictionary new]! !
Object subclass: #ProcessorScheduler
	instanceVariableNames: 'quiescentProcessLists activeProcess '
	classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority '
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!ProcessorScheduler commentStamp: '<historical>' prior: 0!
My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.!


!ProcessorScheduler methodsFor: 'accessing'!
activePriority
	"Answer the priority level of the currently running Process."

	^activeProcess priority! !

!ProcessorScheduler methodsFor: 'accessing'!
activeProcess
	"Answer the currently running Process."

	^activeProcess! !

!ProcessorScheduler methodsFor: 'accessing' stamp: 'nk 10/27/2000 16:27'!
backgroundProcess
	"Answer the background process"
	^ BackgroundProcess! !

!ProcessorScheduler methodsFor: 'accessing'!
highestPriority
	"Answer the number of priority levels currently available for use."

	^quiescentProcessLists size! !

!ProcessorScheduler methodsFor: 'accessing'!
highestPriority: newHighestPriority
	"Change the number of priority levels currently available for use."

	| continue newProcessLists |
	(quiescentProcessLists size > newHighestPriority
		and: [self anyProcessesAbove: newHighestPriority])
			ifTrue: [self error: 'There are processes with priority higher than '
													,newHighestPriority printString].
	newProcessLists _ Array new: newHighestPriority.
	1 to: ((quiescentProcessLists size) min: (newProcessLists size)) do: 
		[:priority | newProcessLists at: priority put: (quiescentProcessLists at: priority)].
	quiescentProcessLists size to: newProcessLists size do: 
		[:priority | newProcessLists at: priority put: LinkedList new].
	quiescentProcessLists _ newProcessLists! !


!ProcessorScheduler methodsFor: 'removing'!
remove: aProcess ifAbsent: aBlock 
	"Remove aProcess from the list on which it is waiting for the processor 
	and answer aProcess. If it is not waiting, evaluate aBlock."

	(quiescentProcessLists at: aProcess priority)
		remove: aProcess ifAbsent: aBlock.
	^aProcess! !


!ProcessorScheduler methodsFor: 'process state change'!
suspendFirstAt: aPriority 
	"Suspend the first Process that is waiting to run with priority aPriority."

	^self suspendFirstAt: aPriority
		  ifNone: [self error: 'No Process to suspend']! !

!ProcessorScheduler methodsFor: 'process state change'!
suspendFirstAt: aPriority ifNone: noneBlock 
	"Suspend the first Process that is waiting to run with priority aPriority. If 
	no Process is waiting, evaluate the argument, noneBlock."

	| aList |
	aList _ quiescentProcessLists at: aPriority.
	aList isEmpty
		ifTrue: [^noneBlock value]
		ifFalse: [^aList first suspend]! !

!ProcessorScheduler methodsFor: 'process state change'!
terminateActive
	"Terminate the process that is currently running."

	activeProcess terminate! !

!ProcessorScheduler methodsFor: 'process state change'!
yield
	"Give other Processes at the current priority a chance to run."

	| semaphore |
	semaphore _ Semaphore new.
	[semaphore signal] fork.
	semaphore wait! !


!ProcessorScheduler methodsFor: 'priority names'!
highIOPriority
	"Answer the priority at which the most time critical input/output 
	processes should run. An example is the process handling input from a 
	network."

	^HighIOPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
lowIOPriority
	"Answer the priority at which most input/output processes should run. 
	Examples are the process handling input from the user (keyboard, 
	pointing device, etc.) and the process distributing input from a network."

	^LowIOPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
systemBackgroundPriority
	"Answer the priority at which system background processes should run. 
	Examples are an incremental garbage collector or status checker."

	^SystemBackgroundPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
timingPriority
	"Answer the priority at which the system processes keeping track of real 
	time should run."

	^TimingPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userBackgroundPriority
	"Answer the priority at which user background processes should run."

	^UserBackgroundPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userInterruptPriority
	"Answer the priority at which user processes desiring immediate service 
	should run. Processes run at this level will preempt the window 
	scheduler and should, therefore, not consume the processor forever."

	^UserInterruptPriority! !

!ProcessorScheduler methodsFor: 'priority names'!
userSchedulingPriority
	"Answer the priority at which the window scheduler should run."

	^UserSchedulingPriority! !


!ProcessorScheduler methodsFor: 'private' stamp: 'tk 6/24/1999 11:27'!
anyProcessesAbove: highestPriority 
	"Do any instances of Process exist with higher priorities?"

	^(Process allInstances "allSubInstances" select: [:aProcess | 
		aProcess priority > highestPriority]) isEmpty
		"If anyone ever makes a subclass of Process, be sure to use allSubInstances."! !


!ProcessorScheduler methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:46'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	dp _ DiskProxy global: #Processor selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProcessorScheduler class
	instanceVariableNames: ''!

!ProcessorScheduler class methodsFor: 'class initialization'!
initialize
     
	SystemRockBottomPriority _ 1.
	SystemBackgroundPriority _ 2.
	UserBackgroundPriority _ 3.
	UserSchedulingPriority _ 4.
	UserInterruptPriority _ 5.
	LowIOPriority _ 6.
	HighIOPriority _ 7.
	TimingPriority _ 8

	"ProcessorScheduler initialize."! !


!ProcessorScheduler class methodsFor: 'instance creation'!
new
	"New instances of ProcessorScheduler should not be created."

	self error:
'New ProcessSchedulers should not be created since
the integrity of the system depends on a unique scheduler'! !


!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'!
idleProcess
	"A default background process which is invisible."

	[true] whileTrue:
		[self relinquishProcessorForMicroseconds: 1000].
! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/3/97 11:17'!
relinquishProcessorForMicroseconds: anInteger
	"Platform specific. This primitive is used to return processor cycles to the host operating system when Squeak's idle process is running (i.e., when no other Squeak process is runnable). On some platforms, this primitive causes the entire Squeak application to sleep for approximately the given number of microseconds. No Squeak process can run while the Squeak application is sleeping, even if some external event makes it runnable. On the Macintosh, this primitive simply calls GetNextEvent() to give other applications a chance to run. On platforms without a host operating system, it does nothing. This primitive should not be used to add pauses to a Squeak process; use a Delay instead."

	<primitive: 230>
	"don't fail if primitive is not implemented, just do nothing"
! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'di 2/4/1999 08:45'!
startUp
	"Install a background process of the lowest possible priority that is always runnable."
	"Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case."

	Smalltalk installLowSpaceWatcher.
	BackgroundProcess == nil ifFalse: [BackgroundProcess terminate].
	BackgroundProcess _ [self idleProcess] newProcess.
	BackgroundProcess priority: SystemRockBottomPriority.
	BackgroundProcess resume.
! !

!ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:32'!
sweepHandIdleProcess
	"A default background process which shows a sweeping circle of XOR-ed bits on the screen."

	| sweepHand |
	sweepHand _ Pen new.
	sweepHand defaultNib: 2.
	sweepHand combinationRule: 6.
	[true] whileTrue: [
		2 timesRepeat: [
			sweepHand north.
			36 timesRepeat: [
				sweepHand place: Display boundingBox topRight + (-25@25).
				sweepHand go: 20.
				sweepHand turn: 10]].
		self relinquishProcessorForMicroseconds: 10000].
! !
AbstractScoreEvent subclass: #ProgramChangeEvent
	instanceVariableNames: 'program channel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel

	^ channel
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'!
channel: midiChannel

	channel _ midiChannel.
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'!
program

	^ program
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'!
program: midiProgramChange

	program _ midiProgramChange.
! !

!ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'!
program: midiProgramChange channel: midiChannel

	program _ midiProgramChange.
	channel _ midiChannel.
! !


!ProgramChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:46'!
isProgramChange

	^ true
! !


!ProgramChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'!
outputOnMidiPort: aMidiPort
	"Output this event to the given MIDI port."

	aMidiPort
		midiCmd: 16rC0
		channel: channel
		byte: program.
! !


!ProgramChangeEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 08:28'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': prog '.
	program printOn: aStream.
	aStream nextPut: $).
! !
Exception subclass: #ProgressInitiationException
	instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ProgressInitiationException commentStamp: '<historical>' prior: 0!
I provide a way to alter the behavior of the old-style progress notifier in String. See examples in:

ProgressInitiationException testWithout.
ProgressInitiationException testWith.
!


!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:46'!
defaultAction

	| delta savedArea captionText textFrame barFrame outerFrame result range lastW w |
	barFrame _ aPoint - (75@10) corner: aPoint + (75@10).
	captionText _ DisplayText text: progressTitle asText allBold.
	captionText
		foregroundColor: Color black
		backgroundColor: Color white.
	textFrame _ captionText boundingBox insetBy: -4.
	textFrame _ textFrame align: textFrame bottomCenter
					with: barFrame topCenter + (0@2).
	outerFrame _ barFrame merge: textFrame.
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	barFrame _ barFrame translateBy: delta.
	textFrame _ textFrame translateBy: delta.
	outerFrame _ outerFrame translateBy: delta.
	savedArea _ Form fromDisplay: outerFrame.
	Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).
	Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).
	captionText displayOn: Display at: textFrame topLeft + (4@4).
	range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"
	lastW _ 0.
	result _ workBlock value:  "Supply the bar-update block for evaluation in the work block"
		[:barVal |
		w _ ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger.
		w ~= lastW ifTrue: [
			Display fillGray: (barFrame topLeft + (2@2) extent: w@16).
			lastW _ w]].
	savedArea displayOn: Display at: outerFrame topLeft.
	self resume: result! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 11:43'!
display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock

	progressTitle _ argString.
	aPoint _ argPoint.
	minVal _ argMinVal.
	maxVal _ argMaxVal.
	workBlock _ argWorkBlock.
	^self signal! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 12:39'!
isResumable
	
	^true! !

!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'RAA 5/15/2000 12:40'!
sendNotificationsTo: aNewBlock

	self resume: (
		workBlock value: [ :barVal |
			aNewBlock value: minVal value: maxVal value: barVal
		]
	)
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProgressInitiationException class
	instanceVariableNames: ''!

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:46'!
testInnermost

	"test the progress code WITHOUT special handling"

	^'Now here''s some Real Progress'
		displayProgressAt: Sensor cursorPoint
		from: 0 
		to: 10
		during: [ :bar |
			1 to: 10 do: [ :x | 
				bar value: x. (Delay forMilliseconds: 500) wait.
				x = 5 ifTrue: [1/0].	"just to make life interesting"
			].
			'done'
		].

! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:42'!
testWith

	"test progress code WITH special handling of progress notifications"

	^[ self testWithAdditionalInfo ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				Transcript show: min printString,'  ',max printString,'  ',curr printString; cr
			].
		].
! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 12:04'!
testWithAdditionalInfo

	^{'starting'. self testWithout. 'really!!'}! !

!ProgressInitiationException class methodsFor: 'examples and tests' stamp: 'RAA 5/15/2000 15:45'!
testWithout

	"test the progress code WITHOUT special handling"

	^[self testInnermost]
		on: ZeroDivide
		do: [ :ex | ex resume]

! !


!ProgressInitiationException class methodsFor: 'signalling' stamp: 'RAA 5/15/2000 11:44'!
display: aString at: aPoint from: minVal to: maxVal during: workBlock

	^self new
		initialContext: thisContext sender;
		display: aString at: aPoint from: minVal to: maxVal during: workBlock! !
RectangleMorph subclass: #ProgressMorph
	instanceVariableNames: 'labelMorph subLabelMorph progress '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 2/14/2000 17:55'!
done
	^self progress value contents! !

!ProgressMorph methodsFor: 'accessing'!
done: amountDone
	self progress value contents: ((amountDone min: 1.0) max: 0.0).
	self currentWorld displayWorld! !

!ProgressMorph methodsFor: 'accessing' stamp: 'sma 3/3/2000 19:05'!
incrDone: incrDone
	self done: self done + incrDone! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:28'!
label
	^self labelMorph contents! !

!ProgressMorph methodsFor: 'accessing'!
label: aString
	self labelMorph contents: aString.
	self currentWorld displayWorld! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:25'!
progress
	^progress ifNil: [self initProgressMorph]! !

!ProgressMorph methodsFor: 'accessing' stamp: 'mir 1/19/2000 13:27'!
subLabel
	^self subLabelMorph contents! !

!ProgressMorph methodsFor: 'accessing'!
subLabel: aString
	self subLabelMorph contents: aString.
	self currentWorld displayWorld! !


!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'!
initLabelMorph
	^ labelMorph _ StringMorph contents: '' font: (self fontOfPointSize: 14)! !

!ProgressMorph methodsFor: 'initialization' stamp: 'mir 1/19/2000 13:16'!
initProgressMorph
	progress _ FlashProgressMorph new.
	progress borderWidth: 1.
	progress color: Color transparent.
	progress progressColor: Color gray.
	progress extent: (200 @ 15).
! !

!ProgressMorph methodsFor: 'initialization' stamp: 'sma 3/3/2000 19:13'!
initSubLabelMorph
	^ subLabelMorph _ StringMorph contents: '' font: (self fontOfPointSize: 12)! !

!ProgressMorph methodsFor: 'initialization' stamp: 'mir 1/19/2000 13:28'!
initialize
	super initialize.
	self setupMorphs! !

!ProgressMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:21'!
setupMorphs
	| container  |
	self initProgressMorph.
	container _ AlignmentMorph newColumn.
	container
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: Color transparent.

	container addMorphBack: self labelMorph.
	container addMorphBack: self subLabelMorph.
	container addMorphBack: self progress.

	self addMorph: container.
	self borderWidth: 2.
	self borderColor: Color black.

	self extent: container extent.
	self color: Color veryLightGray.
	self align: self fullBounds center with: Display boundingBox center
! !


!ProgressMorph methodsFor: 'private' stamp: 'sma 3/3/2000 19:14'!
fontOfPointSize: size
	^ (TextConstants at: #ComicBold ifAbsent: [TextStyle default]) fontOfPointSize: size! !

!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'!
labelMorph
	^labelMorph ifNil: [self initLabelMorph]! !

!ProgressMorph methodsFor: 'private' stamp: 'mir 1/19/2000 13:25'!
subLabelMorph
	^subLabelMorph ifNil: [self initSubLabelMorph]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProgressMorph class
	instanceVariableNames: ''!

!ProgressMorph class methodsFor: 'instance creation' stamp: 'mir 1/19/2000 13:07'!
label: aString
	^self new label: aString! !


!ProgressMorph class methodsFor: 'example' stamp: 'sma 3/3/2000 19:07'!
example
	"ProgressMorph example"

	| progress |
	progress _ ProgressMorph label: 'Test progress'.
	progress subLabel: 'this is the subheading'.
	progress openInWorld.
	[10 timesRepeat:
		[(Delay forMilliseconds: 200) wait.
		progress incrDone: 0.1].
	progress delete] fork! !
Notification subclass: #ProgressNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ProgressNotification commentStamp: '<historical>' prior: 0!
Used to signal progress without requiring a specific receiver to notify. Caller/callee convention could be to simply count the number of signals caught or to pass more substantive information with #signal:.!

Notification subclass: #ProgressTargetRequestNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ProgressTargetRequestNotification commentStamp: '<historical>' prior: 0!
I am used to allow the ComplexProgressIndicator one last chance at finding an appropriate place to display. If I am unhandled, then the cursor location and a default rectangle are used.!


!ProgressTargetRequestNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/7/2000 12:25'!
defaultAction

	self resume: nil! !
Model subclass: #Project
	instanceVariableNames: 'world changeSet transcript parentProject previousProject displayDepth viewSize thumbnail nextProject guards projectParameters isolatedHead inForce version urlList environment lastDirectory lastSavedAtSeconds '
	classVariableNames: 'AllProjects CurrentProject GoalFreePercent GoalNotMoreThan UIProcess '
	poolDictionaries: ''
	category: 'System-Support'!
!Project commentStamp: '<historical>' prior: 0!
A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet.  A project knows who its parent project is.  When you change projects, whether by entering or exiting, the screen state of the project being exited is saved in that project.

A project is retained by its view in the parent world.  It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project.

As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds.  The distinction is based on whether the variable 'world' contains a WorldMorph or a ControlManager.

Saving and Loading
Projects may be stored on the disk in external format.  (Project named: 'xxx') exportSegment, or choose 'store project on file...'.  
Projects may be loaded from a server and stored back.  Storing on a server never overwrites;  it always makes a new version.  A project remembers the url of where it lives in urlList.  The list is length one, for now.  The url may point to a local disk instead of a server.  All projects that the user looks at, are cached in the Squeaklet folder.  Sorted by server.  The cache holds the most recent version only.  

Isolation
When you accept a method, the entire system feels the change, except projects that are "isolated".  In an isolated project, all new global variables (including new classes) are stored in the project-local environment, and all changes to preexisting classes are revoked when you leave the project.  When you enter another project, that project's changes are invoked.  Invocation and revocation are handled efficiently by swapping pointers.  To make a project be isolated, choose 'isolate changes of this project' from the 'changes...' section of the screen menu.  You can use an isolated project for making dangerous change to a system, and you can get out if it crashes.  A foreign application can have the separate environment it wants.  Also, you can freeze part of the system for a demo that you don't want to disturb.  An isolated project shares methods with all subprojects inside it, unless they are isolated themselves.   Each isolated project is the head of a tree of projects with which it shares all methods.

You may 'assert' all changes ever made in the current project to take effect above this project.  This amounts to exporting all the globals in the current environment, and zapping the revocation lists to that the current state of the world will remain in force upon exit from this project.

[Later: A project may be 'frozen'.  Asserts do not apply to it after that.  (Great for demos.)  You should be informed when an assert was blocked in a frozen project.]

Class definitions are layered by the isolation mechanism.  You are only allowed to change the shape of a class in projects that lie within its isolation scope.  All versions of the methods are recompiled, in all projects.  If you remove an inst var that is in use in an isolated project, it will become an Undeclared global.  It is best not to remove an inst var when it is being used in another isolated project. [If we recompile them all, why can't we diagnose the problem before allowing the change??]

Senders and Implementors do not see versions of a method in isolated projects.  [again, we might want to make this possible at a cost].  When you ask for versions of a method, you will not get the history in other isolated projects.

Moving methods and classes between changeSets, and merging changeSets has no effect on which methods are in force.  But, when you look at a changeSet from a different isolated project, the methods will contain code that is not in force.  A changeSet is just a list of method names, and does not keep separate copies of any code.

When finer grained assertion is needed, use the method (aProject assertClass: aClass from: thisProject warn: warnConflicts).

How isolated changes work: The first time a class changes, store its MethodDictionary object.  Keep parallel arrays of associations to Classes and MethodDictionaries.  Traverse these and install them when you enter an "ioslated project".  When you leave, store this project's own MethodDictionaries there.
	To do an assert, we must discover which methods changed here, and which changed only in the project we are asserting into.  There is one copy of the 'virgin' method dictionaries in the system.  It is always being temporarily stored by the currently inForce isolated project.

isolatedHead - true for the top project, and for each isolated project.  false or nil for any subproject that shares all methods with its parent project.

inForce -  true if my methods are installed now.  false if I am dormant. [is this equivalent to self == Project Current?]

classArray - list of associations to classes 

methodDictArray - the method dictionaries of those classes before we started changing methods.  They hang onto the original compiledMethods.  (If this project is dormant, it contains the method dictionaries of those classes as they will be here, in this project).

orgArray - the class organizations of the classes in classArray.

UsingIsolation (class variable) - No longer used.

When you want to save a project in export format from within that very project, it gets tricky.  We set two flags in parentProject, exit to it, and let parentProject write the project.  ProjectViewMorph in parentProject checks in its step method, does the store, clears the flags, and reenters the subProject.

!


!Project methodsFor: 'initialization' stamp: 'sw 11/12/1998 14:29'!
backgroundColorForMorphicProject
	^ Color lightOrange! !

!Project methodsFor: 'initialization' stamp: 'sw 11/5/1998 21:28'!
backgroundColorForMvcProject
	^ Color r: 1.0 g: 1.0 b: 0.065! !

!Project methodsFor: 'initialization' stamp: 'tk 9/22/1999 18:35'!
defaultBackgroundColor
	^ self isMorphic
		ifTrue: [self backgroundColorForMorphicProject]
		ifFalse: [self backgroundColorForMvcProject]! !

!Project methodsFor: 'initialization' stamp: 'RAA 6/30/2000 11:23'!
initMorphic

	"Written so that Morphic can still be removed."
	Smalltalk verifyMorphicAvailability ifFalse: [^ nil].
	self initialize.
	world _ PasteUpMorph newWorldForProject: self.

! !

!Project methodsFor: 'initialization'!
initialExtent
	^ (Display extent // 6) + (0@17)! !

!Project methodsFor: 'initialization' stamp: 'di 4/14/1999 13:55'!
initialProject
	self saveState.
	parentProject _ self.
	previousProject _ nextProject _ nil! !

!Project methodsFor: 'initialization' stamp: 'di 3/29/2000 14:15'!
initialize

	changeSet _ ChangeSet new initialize.
	transcript _ TranscriptStream new.
	displayDepth _ Display depth.
	parentProject _ CurrentProject.
	isolatedHead _ false.
! !

!Project methodsFor: 'initialization' stamp: 'ar 5/28/2000 23:39'!
installNewDisplay: extent depth: depth
	"When entering a new project, install a new Display if necessary."
	| params newDisplay |
	params _ self rawParameters.
	(params notNil and:[(self parameterAt: #enable3DAcceleration) == true]) ifTrue:[
		Display isB3DDisplayScreen 
			ifTrue:[^Display setExtent: extent depth: depth].
		"Install a B3DDisplayScreen for future hardware acceleration"
		newDisplay _ (Smalltalk at: #B3DDisplayScreen ifAbsent:[^self])
					extent: extent depth: depth.
	] ifFalse:[
		"Otherwise check if the current Display is a DisplayScreen"
		Display isB3DDisplayScreen
			ifFalse:[^Display setExtent: extent depth: depth].		
		"Install a DisplayScreen for future hardware acceleration"
		newDisplay _ (Smalltalk at: #DisplayScreen ifAbsent:[^self])
					extent: extent depth: depth.
	].
	"Copy old contents of display to the (yet to be installed) newDisplay"
	newDisplay class == Display class ifTrue:[
		"A workaround for DisplayScreen <-> DisplayScreen"
		Display displayOn: newDisplay.
	] ifFalse:["*MUST* use FXBlt when switching between Displays"
		(FXBlt toForm: newDisplay) 
			sourceForm: Display; 
			combinationRule: 3; copyBits.
	].
	"And make it Display"
	Display release. "Release it while it's still Display"
	Display _ newDisplay.
	Display beDisplay.! !

!Project methodsFor: 'initialization' stamp: 'di 7/19/1999 15:00'!
installPasteUpAsWorld: pasteUpMorph
	"(ProjectViewMorph newMorphicProjectOn: aPasteUpMorph) openInWorld."

	world _ pasteUpMorph beWorldForProject: self! !

!Project methodsFor: 'initialization' stamp: 'RAA 6/21/2000 22:59'!
setChangeSet: aChangeSet

	isolatedHead == true ifTrue: [^ self].  "ChangeSet of an isolated project cannot be changed"
	changeSet _ aChangeSet
! !

!Project methodsFor: 'initialization' stamp: 'di 3/29/2000 14:16'!
setProjectHolder: aProject

	self initialize.
	world _ ControlManager new.
! !

!Project methodsFor: 'initialization' stamp: 'RAA 10/13/2000 18:21'!
setServer
	"Mark me as a new project.  See if a server is known, remember it."

	self projectParameters at: #exportState put: #nacent.
	urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList].! !

!Project methodsFor: 'initialization' stamp: 'di 6/10/1998 13:54'!
windowActiveOnFirstClick

	^ true! !

!Project methodsFor: 'initialization' stamp: 'di 6/12/1998 15:58'!
windowReqNewLabel: newLabel
	newLabel isEmpty ifTrue: [^ false].
	newLabel = changeSet name ifTrue: [^ true].
	(ChangeSorter changeSetNamed: newLabel) == nil
		ifFalse: [self inform: 'Sorry that name is already used'.
				^ false].
	changeSet name: newLabel.
	^ true! !


!Project methodsFor: 'accessing' stamp: 'ar 4/19/1999 04:26'!
addGuard: anObject
	"Add the given object to the list of objects receiving #okayToEnterProject on Project entry"
	guards ifNil:[guards _ WeakArray with: anObject]
			ifNotNil:[guards _ guards copyWith: anObject].! !

!Project methodsFor: 'accessing' stamp: 'sw 9/7/2000 06:56'!
addSubProjectNamesTo: aStream indentation: anIndentation
	"Add the names of the receiver and all its subprojects, and all *their* subprojects recursively, to aStream, indenting by the specified number of tab stops "

	self isTopProject ifFalse:  "circumvent an annoying cr at the top "
		[aStream cr].  
	aStream tab: anIndentation; nextPutAll: self name.
	self subProjects do:
		[:p |
			p addSubProjectNamesTo: aStream indentation: anIndentation + 1]! !

!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 16:29'!
changeSet
	^ changeSet! !

!Project methodsFor: 'accessing' stamp: 'sw 10/27/2000 05:55'!
currentStack: aStack
	"Set the current stack as indicated; if the parameter supplied is nil, delete any prior memory of the CurrentStack"

	aStack
		ifNil:
			[self removeParameter: #CurrentStack]
		ifNotNil:
			[self projectParameterAt: #CurrentStack put: aStack]! !

!Project methodsFor: 'accessing'!
displayDepth: newDepth
	displayDepth _ newDepth! !

!Project methodsFor: 'accessing' stamp: 'tk 2/24/2000 13:51'!
environment
	^ environment! !

!Project methodsFor: 'accessing' stamp: 'RAA 11/16/2000 12:19'!
findProjectView: projectDescription
	| pName dpName proj |
	"In this world, find the morph that holds onto the project described by projectDescription.  projectDescription can be a project, or the name of a project.  The project may be represented by a DiskProxy.  The holder morph may be at any depth in the world.
	Need to fix this if Projects have subclasses, or if a class other than ProjectViewMorph can officially hold onto a project.  (Buttons, links, etc)
	If parent is an MVC world, return the ProjectController."

	self flag: #bob.		"read the comment"


	pName _ (projectDescription isKindOf: String) 
		ifTrue: [projectDescription]
		ifFalse: [projectDescription name].
	self isMorphic 
		ifTrue: [world allMorphsDo: [:pvm |
				pvm class == ProjectViewMorph ifTrue: [
					(pvm project class == Project and: 
						[pvm project name = pName]) ifTrue: [^ pvm].

					pvm project class == DiskProxy ifTrue: [ 
						dpName _ pvm project constructorArgs first.
						dpName _ (dpName findTokens: '/') last.
						dpName _ (Project parseProjectFileName: dpName) first.
						dpName = pName ifTrue: [^ pvm]]]]]
		ifFalse: [world scheduledControllers do: [:cont |
				(cont isKindOf: ProjectController) ifTrue: [
					((proj _ cont model) class == Project and: 
						[proj name = pName]) ifTrue: [^ cont view].

					proj class == DiskProxy ifTrue: [ 
						dpName _ proj constructorArgs first.
						dpName _ (dpName findTokens: '/') last.
						dpName _ (Project parseProjectFileName: dpName) first.
						dpName = pName ifTrue: [^ cont view]]]]
			].
	^ nil! !

!Project methodsFor: 'accessing' stamp: 'RAA 10/13/2000 18:02'!
forgetExistingURL

	urlList _ nil! !

!Project methodsFor: 'accessing' stamp: 'RAA 6/3/2000 10:23'!
isCurrentProject

	^self == CurrentProject! !

!Project methodsFor: 'accessing' stamp: 'tk 9/22/1999 18:32'!
isMorphic
	"Complexity is because #isMVC is lazily installed"
	^ world isInMemory 
		ifTrue: [world isMorph]
		ifFalse: [(self projectParameters at: #isMVC ifAbsent: [false]) not]! !

!Project methodsFor: 'accessing' stamp: 'di 3/29/2000 15:37'!
isTopProject
	"Return true only if this is the top project (its own parent).
	Also include the test here for malformed project hierarchy."

	parentProject == self ifTrue: [^ true].
	parentProject == nil ifTrue: [self error: 'No project should have a nil parent'].
	^ false! !

!Project methodsFor: 'accessing' stamp: 'tk 6/26/1998 22:17'!
labelString
	^ changeSet name! !

!Project methodsFor: 'accessing' stamp: 'RAA 6/21/2000 19:24'!
lastDirectory: aDirectoryOrNil

	lastDirectory _ aDirectoryOrNil! !

!Project methodsFor: 'accessing' stamp: 'RAA 9/28/2000 18:33'!
lastSavedAtSeconds

	^lastSavedAtSeconds! !

!Project methodsFor: 'accessing' stamp: 'di 7/19/1999 15:06'!
name
	changeSet == nil ifTrue: [^ 'no name'].
	^ changeSet name! !

!Project methodsFor: 'accessing' stamp: 'sw 2/15/1999 12:12'!
nextProject
	^ nextProject
! !

!Project methodsFor: 'accessing' stamp: 'di 3/6/98 10:22'!
parent
	^ parentProject! !

!Project methodsFor: 'accessing' stamp: 'jm 5/20/1998 23:31'!
previousProject
	^ previousProject
! !

!Project methodsFor: 'accessing'!
projectChangeSet
	^ changeSet! !

!Project methodsFor: 'accessing' stamp: 'di 4/14/1999 13:59'!
setParent: newParent

	parentProject _ newParent.
	nextProject _ previousProject _ nil.! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:07'!
setThumbnail: aForm
	thumbnail _ aForm! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'!
setViewSize: aPoint
	viewSize _ aPoint! !

!Project methodsFor: 'accessing' stamp: 'RAA 10/13/2000 18:12'!
storeNewPrimaryURL: aURLString

	urlList isEmptyOrNil ifTrue: [urlList _ Array new: 1].
	urlList at: 1 put: aURLString
! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:07'!
thumbnail
	^ thumbnail! !

!Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 13:57'!
urlList
	^ urlList! !

!Project methodsFor: 'accessing' stamp: 'di 1/21/98 11:06'!
viewSize
	^ viewSize! !

!Project methodsFor: 'accessing'!
world
	^ world! !


!Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'!
enter
	"Enter the new project"
	self enter: (CurrentProject parent == self) revert: false saveForRevert: false.! !

!Project methodsFor: 'menu messages' stamp: 'sw 11/10/1999 10:29'!
enter: returningFlag	
	self enter: returningFlag revert: false saveForRevert: false! !

!Project methodsFor: 'menu messages' stamp: 'RAA 12/26/2000 12:42'!
enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
	"Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
	If saveForRevert is true, save the ImageSegment of the project being left.
	If revertFlag is true, make stubs for the world of the project being left.
	If revertWithoutAsking is true in the project being left, then always revert."

	| showZoom recorderOrNil old forceRevert response seg newProcess |

	(world isKindOf: StringMorph) ifTrue: [
		self inform: 'This project is not all here. I will try to load a complete version.'.
		^self loadFromServer: true	"try to get a fresh copy"
	].
	self isCurrentProject ifTrue: [^ self].
	"Check the guards"
	guards ifNotNil:
		[guards _ guards reject: [:obj | obj isNil].
		guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]].
	forceRevert _ false.
	CurrentProject rawParameters 
		ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to']]
		ifNotNil: [saveForRevert ifFalse: [
				forceRevert _ CurrentProject projectParameters 
								at: #revertWithoutAsking ifAbsent: [false]]].
	forceRevert not & revertFlag ifTrue: [
		response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' withCRs
			trueChoice: 'Revert to saved version' 
			falseChoice: 'Cancel'.
		response ifFalse: [^ self]].

	revertFlag | forceRevert 
		ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [
					^ self inform: 'nothing to revert to']]
		ifFalse: [
			CurrentProject makeThumbnail.
			returningFlag == #specialReturn ifTrue: [
				ProjectHistory forget: CurrentProject.		"this guy is irrelevant"
				Project forget: CurrentProject.
			] ifFalse: [
				ProjectHistory remember: CurrentProject.
			].
		].
	(revertFlag | saveForRevert | forceRevert) ifFalse: [
		(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
			self storeToMakeRoom]].

	Smalltalk isMorphic ifTrue: [Display bestGuessOfCurrentWorld triggerClosingScripts].

	"Update the display depth and make a thumbnail of the current project"
	CurrentProject displayDepth: Display depth.
	old _ CurrentProject.		"for later"

	"Show the project transition.
	Note: The project zoom is run in the context of the old project,
		so that eventual errors can be handled accordingly"
	displayDepth == nil ifTrue: [displayDepth _ Display depth].
	self installNewDisplay: Display extent depth: displayDepth.
	(showZoom _ self showZoom) ifTrue: [
		self displayZoom: CurrentProject parent ~~ self].

	(world isMorph and: [world hasProperty: #letTheMusicPlay])
		ifTrue: [world removeProperty: #letTheMusicPlay]
		ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | 
					playerClass allSubInstancesDo: [:player | player pause]]].

	returningFlag == #specialReturn ifTrue: [
		old removeChangeSetIfPossible.	"keep this stuff from accumulating"
		nextProject _ nil
	] ifFalse: [
		returningFlag
			ifTrue: [nextProject _ CurrentProject]
			ifFalse: [previousProject _ CurrentProject].
	].

	CurrentProject saveState.
	CurrentProject isolationHead == self isolationHead ifFalse:
		[self invokeFrom: CurrentProject].
	CurrentProject _ self.
	Smalltalk newChanges: changeSet.
	TranscriptStream newTranscript: transcript.
	Sensor flushKeyboard.
	Smalltalk isMorphic ifTrue: [recorderOrNil _ Display pauseMorphicEventRecorder].

	ProjectHistory remember: CurrentProject.

	world isMorph
		ifTrue:
			[Display changeMorphicWorldTo: world.  "Signifies Morphic"
			world install.
			world transferRemoteServerFrom: old world.
			"(revertFlag | saveForRevert | forceRevert) ifFalse: [
				(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
					self storeSomeSegment]]."
			recorderOrNil ifNotNil: [recorderOrNil resumeIn: world].
			world triggerOpeningScripts]
		ifFalse:
			[Display changeMorphicWorldTo: nil.  "Signifies MVC"
			Smalltalk at: #ScheduledControllers put: world].

	saveForRevert ifTrue: [
		Smalltalk garbageCollect.	"let go of pointers"
		old storeSegment.
		"result _" old world isInMemory 
			ifTrue: ['Can''t seem to write the project.']
			ifFalse: [old projectParameters at: #revertToMe put: 
					old world xxxSegment clone].
				'Project written.'].
			"original is for coming back in and continuing."

	revertFlag | forceRevert ifTrue: [
		seg clone revert].	"non-cloned one is for reverting again later"
	self removeParameter: #exportState.

	"Complete the enter: by launching a new process"
	world isMorph ifTrue: [
		self finalEnterActions.
		world repairEmbeddedWorlds.
		Project spawnNewProcessAndTerminateOld: true
	] ifFalse: [
		SystemWindow clearTopWindow.	"break external ref to this project"
		newProcess _ [	
			ScheduledControllers resetActiveController.	"in case of walkback in #restore"
			showZoom ifFalse: [ScheduledControllers restore].
			ScheduledControllers searchForActiveController
		] fixTemps newProcess priority: Processor userSchedulingPriority.
		newProcess resume.		"lose the current process and its referenced morphs"
		Processor terminateActive.
	]! !

!Project methodsFor: 'menu messages' stamp: 'RAA 6/11/2000 15:04'!
enterAsActiveSubprojectWithin: enclosingWorld

	"Install my ChangeSet, Transcript, and scheduled views as current globals. 

	If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
	If saveForRevert is true, save the ImageSegment of the project being left.
	If revertFlag is true, make stubs for the world of the project being left.
	If revertWithoutAsking is true in the project being left, then always revert."

	"Experimental mods for initial multi-project work:
		1. assume in morphic (this eliminated need for <showZoom>)
		2. assume <saveForRevert> is false (usual case) - removed <old>
		3. assume <revertFlag> is false
		4. assume <revertWithoutAsking> is false - <forceRevert> now auto false <seg> n.u.
		5. no zooming
		6. assume <projectsSentToDisk> false - could be dangerous here
		7. assume no isolation problems (isolationHead ==)
		8. no closing scripts
	"

	self isCurrentProject ifTrue: [^ self].

	guards ifNotNil: [
		guards _ guards reject: [:obj | obj isNil].
		guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]
	].

		"CurrentProject makeThumbnail."
		"--> Display bestGuessOfCurrentWorld triggerClosingScripts."
	CurrentProject displayDepth: Display depth.

	displayDepth == nil ifTrue: [displayDepth _ Display depth].
		"Display newDepthNoRestore: displayDepth."

		"(world hasProperty: #letTheMusicPlay)
			ifTrue: [world removeProperty: #letTheMusicPlay]
			ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | 
						playerClass allSubInstancesDo: [:player | player pause]]]."

		"returningFlag
			ifTrue: [nextProject _ CurrentProject]
			ifFalse: [previousProject _ CurrentProject]."

		"CurrentProject saveState."
		"CurrentProject _ self."
		"Smalltalk newChanges: changeSet."
		"TranscriptStream newTranscript: transcript."
		"Sensor flushKeyboard."
		"recorderOrNil _ Display pauseMorphicEventRecorder."

		"Display changeMorphicWorldTo: world."  "Signifies Morphic"
	world 
		installAsActiveSubprojectIn: enclosingWorld 
		titled: self name.

		"recorderOrNil ifNotNil: [recorderOrNil resumeIn: world]."
	world triggerOpeningScripts.
	self removeParameter: #exportState.
		"self spawnNewProcessAndTerminateOld: true"! !

!Project methodsFor: 'menu messages' stamp: 'RAA 6/3/2000 18:20'!
enterForEmergencyRecovery
	"This version of enter invokes an absolute minimum of mechanism.
	An unrecoverable error has been detected in an isolated project.
	It is assumed that the old changeSet has already been revoked.
	No new process gets spawned here.  This will happen in the debugger."

	self isCurrentProject ifTrue: [^ self].
	CurrentProject saveState.
	CurrentProject _ self.
	Display newDepthNoRestore: displayDepth.
	Smalltalk newChanges: changeSet.
	TranscriptStream newTranscript: transcript.
	Display pauseMorphicEventRecorder.

	world isMorph
		ifTrue:
			["Entering a Morphic project"
			Display changeMorphicWorldTo: world.
			world install.
			world triggerOpeningScripts]
		ifFalse:
			["Entering an MVC project"
			Display changeMorphicWorldTo: nil.
			Smalltalk at: #ScheduledControllers put: world.
			ScheduledControllers restore].
	UIProcess _ Processor activeProcess.
! !

!Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'!
exit
	"Leave the current project and return to the project in which this one was created."

	self isTopProject ifTrue: [^ PopUpMenu notify: 'Can''t exit the top project'].
	parentProject enter: false revert: false saveForRevert: false.
! !

!Project methodsFor: 'menu messages'!
fileOut
	changeSet fileOut! !

!Project methodsFor: 'menu messages' stamp: 'ar 10/10/2000 17:56'!
finalEnterActions
	| navigator armsLengthCmd navType |

	navType _ ProjectNavigationMorph preferredNavigator.
	armsLengthCmd _ self parameterAt: #armsLengthCmd ifAbsent: [nil].
	navigator _ world findA: navType.
	Preferences showProjectNavigator & navigator isNil ifTrue: [
		(navigator _ navType new)
			bottomLeft: world bottomLeft;
			openInWorld: world.
	].
	navigator notNil & armsLengthCmd notNil ifTrue: [
		navigator color: Color lightBlue
	].
	armsLengthCmd notNil ifTrue: [
		Preferences showFlapsWhenPublishing
			ifFalse:[self flapsSuppressed: true.
					navigator ifNotNil:[navigator visible: false]].
		armsLengthCmd openInWorld: world
	].! !

!Project methodsFor: 'menu messages' stamp: 'RAA 11/1/2000 06:07'!
makeThumbnail
	"Make a thumbnail image of this project from the Display."

	world isMorph ifTrue: [world displayWorldSafely]. "clean pending damage"
	viewSize ifNil: [viewSize _ Display extent // 8].
	thumbnail _ Form extent: viewSize depth: Display depth.
	(WarpBlt current toForm: thumbnail)
			sourceForm: Display;
			cellSize: 2;  "installs a colormap"
			combinationRule: Form over;
			copyQuad: (Display boundingBox) innerCorners
			toRect: (0@0 extent: viewSize).
! !

!Project methodsFor: 'menu messages' stamp: 'RAA 9/27/2000 13:46'!
saveState
	"Save the current state in me prior to leaving this project"

	changeSet _ Smalltalk changes.
	Smalltalk isMorphic
		ifTrue:
			[world _ Display bestGuessOfCurrentWorld.
			world sleep]
		ifFalse:
			[world _ ScheduledControllers.
			ScheduledControllers unCacheWindows].
	Sensor eventQueue: nil. "Will be reinstalled by World>>install"
	transcript _ Transcript.
! !

!Project methodsFor: 'menu messages' stamp: 'RAA 11/8/2000 11:01'!
validateProjectNameIfOK: aBlock

	(self hasBadNameForStoring or: [self name beginsWith: 'Unnamed']) ifFalse: [^aBlock value].
	EToyProjectDetailsMorph
		getFullInfoFor: self 
		ifValid: [
			World displayWorldSafely.
			aBlock value.
		] fixTemps.
! !

!Project methodsFor: 'menu messages' stamp: 'di 9/29/1999 00:09'!
viewLocFor: exitedProject
	"Look for a view of the exitedProject, and return its center"
	| ctlr |
	world isMorph
		ifTrue: [world submorphsDo:
					[:v | ((v isKindOf: SystemWindow) and: [v model == exitedProject])
						ifTrue: [^ v center]]]
		ifFalse: [ctlr _ world controllerWhoseModelSatisfies:
							[:p | p == exitedProject].
				ctlr ifNotNil: [^ ctlr view windowBox center]].

	^ Sensor cursorPoint.  "default result"

! !


!Project methodsFor: 'release' stamp: 'di 9/28/1999 23:46'!
addDependent: aMorph

	"Projects do not keep track of their dependents, lest they point into other projects and thus foul up the tree structure for image segmentation."

	^ self  "Ignore this request"! !

!Project methodsFor: 'release' stamp: 'sw 7/6/1998 11:16'!
canDiscardEdits
	"Don't regard a window of mine as one to be discarded as part of a 'closeUnchangedWindows' sweep"

	^ false! !

!Project methodsFor: 'release' stamp: 'RAA 11/13/2000 17:06'!
deletingProject: aProject
	"Clear my previousProject link if it points at the given Project, which is being deleted."

	self flag: #bob.		"zapping projects"


	previousProject == aProject
		ifTrue: [previousProject _ nil].
	nextProject == aProject
		ifTrue:	[nextProject _ nil]
! !

!Project methodsFor: 'release' stamp: 'RAA 11/16/2000 13:02'!
okToChange
	"Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation"

	| ok is list |
	self subProjects size  >0 ifTrue:
		[PopUpMenu notify: 
'The project ', self name printString, '
contains sub-projects.  You must remove these
explicitly before removing their parent.'.
		^ false].
	ok _ world isMorph not and: [world scheduledControllers size <= 1].
	ok ifFalse: [self isMorphic ifTrue: [
		self parent == CurrentProject 
			ifFalse: [^true]]].  "view from elsewhere.  just delete it."
	ok _ (self confirm:
'Really delete the project
', self name printString, '
and all its windows?').
		
	ok ifFalse: [^ false].

	world isMorph 
		ifTrue: [world submorphs do:   "special release for wonderlands"
						[:m | (m isKindOf: WonderlandCameraMorph)
								and: [m getWonderland release]].
			"Remove Player classes and metaclasses owned by project"
			is _ ImageSegment new arrayOfRoots: (Array with: self).
			(list _ is rootsIncludingPlayers) ifNotNil: [
				list do: [:playerCls | 
					(playerCls respondsTo: #isMeta) ifTrue: [
						playerCls isMeta ifFalse: [
							playerCls removeFromSystemUnlogged]]]]].

	self removeChangeSetIfPossible.
	"do this last since it will render project inaccessible to #allProjects and their ilk"
	Project deletingProject: self.
	^ true
! !

!Project methodsFor: 'release' stamp: 'RAA 6/7/2000 09:24'!
release

	self flag: #bob.	"this can be trouble if Projects are reused before garbage collection"
	world == nil ifFalse:
		[world release.
		world _ nil].
	^ super release! !

!Project methodsFor: 'release' stamp: 'RAA 10/19/2000 13:18'!
removeChangeSetIfPossible

	| itsName |

	changeSet ifNil: [^self].
	changeSet isEmpty ifFalse: [^self].
	(changeSet projectsBelongedTo copyWithout: self) isEmpty ifFalse: [^self].
	itsName _ changeSet name.
	ChangeSorter removeChangeSet: changeSet.
	Transcript cr; show: 'project change set ', itsName, ' deleted.'
! !

!Project methodsFor: 'release' stamp: 'sw 9/7/2000 07:15'!
subProjects
	"Answer a list of all the subprojects  of the receiver.  This is nastily idiosyncratic."

	^ self isMorphic
		ifTrue: 
			[world submorphs
				select:
					[:m | (m isKindOf: SystemWindow)
						and: [m model isKindOf: Project]]
				thenCollect:
					[:m | m model]]
		ifFalse:
			[(world controllersSatisfying:
					[:m | m model isKindOf: Project])
				collect:
					[:c | c model]]
! !



!Project methodsFor: 'printing' stamp: 'jm 5/21/1998 07:40'!
printOn: aStream

	aStream nextPutAll: 'a Project(', self name, ')'.
! !


!Project methodsFor: 'file in/out' stamp: 'RAA 7/29/2000 16:55'!
armsLengthCommand: aCommand withDescription: aString
	| pvm tempProject foolingForm tempCanvas bbox crossHatchColor stride |
	"Set things up so that this aCommand is sent to self as a message
after jumping to the parentProject.  For things that can't be executed
while in this project, such as saveAs, loadFromServer, storeOnServer.  See
ProjectViewMorph step."

	self isMorphic ifTrue: [
		world borderWidth: 0.	"get rid of the silly default border"
		tempProject _ Project newMorphic.
		foolingForm _ world imageForm.		"make them think they never left"
		tempCanvas _ foolingForm getCanvas.
		bbox _ foolingForm boundingBox.
		crossHatchColor _ Color yellow alpha: 0.3.
		stride _ 20.
		10 to: bbox width by: stride do: [ :x |
			tempCanvas fillRectangle: (x@0 extent: 1@bbox height) fillStyle: crossHatchColor.
		].
		10 to: bbox height by: stride do: [ :y |
			tempCanvas fillRectangle: (0@y extent: bbox width@1) fillStyle: crossHatchColor.
		].

		tempProject world color: (InfiniteForm with: foolingForm).
		tempProject projectParameters 
			at: #armsLengthCmd 
			put: (
				DoCommandOnceMorph new
					addText: aString;
					actionBlock: [
						self doArmsLengthCommand: aCommand.
					] fixTemps
			).
		tempProject enter.
	] ifFalse: [
		parentProject ifNil: [^ self inform: 'The top project can''t do that'].
		pvm _ parentProject findProjectView: self.
		pvm armsLengthCommand: {self. aCommand}.
		self exit.
	].
! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'!
assureIntegerVersion
	"For converting the project versions"
	self currentVersionNumber. "Does it for us"! !

!Project methodsFor: 'file in/out' stamp: 'sma 6/16/2000 23:43'!
beep
	(PluckedSound pitch: 261.625*4 dur: 1 loudness: 0.1) play! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:06'!
bumpVersion: versionNumber
	"Make a new version after the previous version number"
	versionNumber ifNil:[^0].
	^versionNumber + 1! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/3/2000 10:25'!
couldBeSwappedOut

	self flag: #bob.		"need a better test in multi-project world"
	^self isCurrentProject not! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:25'!
currentVersionNumber

	version ifNil: [^0].
	version isInteger ifTrue:[^version].
	version _ Base64MimeConverter decodeInteger: version unescapePercents.
	^version! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/20/2000 09:52'!
decideAboutCreatingBlank: otherProjectName

	| resp |

	"20 Oct - just do it"
	true "version isNil" ifFalse: [	"if saved, then maybe don't create"
		resp _ (PopUpMenu labels: 'Yes, make it up\No, skip it' withCRs) 
			startUpWithCaption: (
				'I cannot locate the project\',
				otherProjectName,
				'\Would you like me to create a new project\with that name?'
			) withCRs.
		resp = 1 ifFalse: [^ nil]
	].
	^Project openBlankProjectNamed: otherProjectName! !

!Project methodsFor: 'file in/out' stamp: 'RAA 7/7/2000 13:35'!
doArmsLengthCommand: aCommand

	"We are no longer the active project, so do it"

	self perform: aCommand.
	self enter: #specialReturn.	"re-enter me and forget the temp project"

! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 14:12'!
ensureChangeSetNameUnique

	| myName |

	myName _ self name.
	Project allProjects do: [:pp | 
		pp == self ifFalse: [
			(pp name = myName and: [pp projectChangeSet ~~ changeSet]) ifTrue: [
				(pp parameterAt: #loadingNewerVersion ifAbsent: [false]) ifTrue: [
					pp projectParameters at: #loadingNewerVersion put: false.
				] ifFalse: [
					changeSet ifNil: [^ changeSet _ ChangeSet new].
					^changeSet name: (ChangeSet uniqueNameLike: myName)
				].
			]
		]
	]
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 1/5/2001 10:59'!
exportSegmentFileName: aFileName directory: aDirectory

	| exportChangeSet |

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"

	"Store my project out on the disk as an *exported* ImageSegment.  Put all outPointers in a form that can be resolved in the target image.  Name it <project name>.extSeg.
	Player classes are included automatically."

	exportChangeSet _ nil.
	(changeSet notNil and: [changeSet isEmpty not]) ifTrue: [
		(self confirm: 
'Would you like to include all the changes in the change set
as part of this publishing operation?') ifTrue: [
			exportChangeSet _ changeSet
		].
	].
	^ self 
		exportSegmentWithChangeSet: exportChangeSet
		fileName: aFileName 
		directory: aDirectory
! !

!Project methodsFor: 'file in/out' stamp: 'tk 1/31/2001 10:00'!
exportSegmentWithCatagories: catList classes: classList fileName: aFileName directory: aDirectory
	"Store my project out on the disk as an *exported* ImageSegment.  All outPointers will be in a form that can be resolved in the target image.  Name it <project name>.extSeg.  What do we do about subProjects, especially if they are out as local image segments?  Force them to come in?
	Player classes are included automatically."

| is str ans revertSeg roots holder |
"world == World ifTrue: [^ false]."
	"self inform: 'Can''t send the current world out'."
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ false].	"Only Morphic projects for now"
world ifNil: [^ false].  world presenter ifNil: [^ false].

Utilities emptyScrapsBook.
world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
world currentHand mouseOverHandler initialize.	  "forget about any references here"
	"Display checkCurrentHandForObjectToPaste."
Command initialize.
world clearCommandHistory.
world fullReleaseCachedState; releaseViewers. 
world cleanseStepList.
world localFlapTabs size = world flapTabs size ifFalse: [
	self error: 'Still holding onto Global flaps'].
world releaseSqueakPages.
ScriptEditorMorph writingUniversalTiles: (world valueOfProperty: #universalTiles).
holder _ Project allProjects.	"force them in to outPointers, where DiskProxys are made"

"Just export me, not my previous version"
revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil].
self projectParameters removeKey: #revertToMe ifAbsent: [].

roots _ OrderedCollection new.
roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
roots add: world activeHand; addAll: classList; addAll: (classList collect: [:cls | cls class]).

roots _ roots reject: [ :x | x isNil].	"early saves may not have active hand or thumbnail"

catList do: [:sysCat | 
	(SystemOrganization listAtCategoryNamed: sysCat asSymbol) do: [:symb |
		roots add: (Smalltalk at: symb); add: (Smalltalk at: symb) class]].

is _ ImageSegment new copySmartRootsExport: roots asArray.
	"old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)"

is state = #tooBig ifTrue: [^ false].

str _ ''.
"considered legal to save a project that has never been entered"
(is outPointers includes: world) ifTrue: [
	str _ str, '\Project''s own world is not in the segment.' withCRs].
str isEmpty ifFalse: [
	ans _ (PopUpMenu labels: 'Do not write file
Write file anyway
Debug') startUpWithCaption: str.
	ans = 1 ifTrue: [
		revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
		^ false].
	ans = 3 ifTrue: [self halt: 'Segment not written']].

is writeForExportWithSources: aFileName inDirectory: aDirectory.
revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
holder.
world flapTabs do: [:ft | 
		(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
is arrayOfRoots do: [:obj |
	obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
^ true
! !

!Project methodsFor: 'file in/out' stamp: 'tk 1/31/2001 10:01'!
exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory
	"Store my project out on the disk as an *exported* ImageSegment.  All outPointers will be in a form that can be resolved in the target image.  Name it <project name>.extSeg.  What do we do about subProjects, especially if they are out as local image segments?  Force them to come in?
	Player classes are included automatically."

	| is str ans revertSeg roots holder |

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"



world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ false].	"Only Morphic projects for now"
world ifNil: [^ false].  world presenter ifNil: [^ false].

Utilities emptyScrapsBook.
world currentHand pasteBuffer: nil.	  "don't write the paste buffer."
world currentHand mouseOverHandler initialize.	  "forget about any references here"
	"Display checkCurrentHandForObjectToPaste."
Command initialize.
world clearCommandHistory.
world fullReleaseCachedState; releaseViewers. 
world cleanseStepList.
world localFlapTabs size = world flapTabs size ifFalse: [
	self error: 'Still holding onto Global flaps'].
world releaseSqueakPages.
ScriptEditorMorph writingUniversalTiles: (world valueOfProperty: #universalTiles).
holder _ Project allProjects.	"force them in to outPointers, where DiskProxys are made"

"Just export me, not my previous version"
revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil].
self projectParameters removeKey: #revertToMe ifAbsent: [].

roots _ OrderedCollection new.
roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail.
roots add: world activeHand.

	"; addAll: classList; addAll: (classList collect: [:cls | cls class])"

roots _ roots reject: [ :x | x isNil].	"early saves may not have active hand or thumbnail"

is _ ImageSegment new copySmartRootsExport: roots asArray.
	"old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)"

is state = #tooBig ifTrue: [^ false].

str _ ''.
"considered legal to save a project that has never been entered"
(is outPointers includes: world) ifTrue: [
	str _ str, '\Project''s own world is not in the segment.' withCRs].
str isEmpty ifFalse: [
	ans _ (PopUpMenu labels: 'Do not write file
Write file anyway
Debug') startUpWithCaption: str.
	ans = 1 ifTrue: [
		revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
		^ false].
	ans = 3 ifTrue: [self halt: 'Segment not written']].

is writeForExportWithSources: aFileName inDirectory: aDirectory changeSet: aChangeSetOrNil.
revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg].
holder.
world flapTabs do: [:ft | 
		(ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]].
is arrayOfRoots do: [:obj |
	obj class == ScriptEditorMorph ifTrue: [obj unhibernate]].
^ true
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 7/15/2000 19:23'!
findAFolderToLoadProjectFrom

	self couldOpenInMorphic ifTrue: [
		^FileList2 modalFolderSelectorForProjectLoad
	] ifFalse: [
		^PluggableFileList getFolderDialog openLabel: 'Select a folder on a server:'
	]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/30/2000 11:14'!
findAFolderToStoreProjectIn

	"Alan wants something prettier with a default"

	self couldOpenInMorphic ifTrue: [
		^FileList2 modalFolderSelectorForProject: self
	] ifFalse: [
		^PluggableFileList getFolderDialog openLabel: 'Select a folder on a server:'
	]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 18:07'!
fromMyServerLoad: otherProjectName
	| servers pair pr dirToUse |
	"If a newer version of me is on the server, load it."

	(pr _ Project named: otherProjectName) ifNotNil: ["it appeared"
		^ pr enter
	].
	(servers _ self serverList) ifNil: [
		lastDirectory ifNil: [
			self inform: 'Current project does not know a server either.'.
			^nil
		].
		dirToUse _ lastDirectory.
	] ifNotNil: [
		dirToUse _ servers first.
	].
	pair _ self class mostRecent: otherProjectName onServer: dirToUse.
	pair first ifNil: [^self decideAboutCreatingBlank: otherProjectName].	"nothing to load"
	^ProjectLoading
		installRemoteNamed: pair first
		from: dirToUse
		named: otherProjectName
		in: self

! !

!Project methodsFor: 'file in/out' stamp: 'RAA 9/21/2000 15:30'!
hasBadNameForStoring

	^Project isBadNameForStoring: self name
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/17/2000 18:52'!
loadFromServer
	
	^self loadFromServer: false! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 14:15'!
loadFromServer: newerAutomatically
	"If a newer version of me is on the server, load it."
	| servers pair resp |
	self assureIntegerVersion.

	self isCurrentProject ifTrue: ["exit, then do the command"
		^ self armsLengthCommand: #loadFromServer withDescription: 'Loading'
	].
	servers _ self tryToFindAServerWithMe ifNil: [^ nil].
	pair _ self class mostRecent: self name onServer: servers first.
	pair first ifNil: [^ self inform: 'can''t find file on server for ', self name].
	self currentVersionNumber > pair second ifTrue: [
		^ self inform: 'That server has an older version of the project.'].
	version = (Project parseProjectFileName: pair first) second ifTrue: [
		resp _ (PopUpMenu labels: 'Reload anyway\Cancel' withCRs) startUpWithCaption: 
					'The only changes are the ones you made here.'.
		resp ~= 1 ifTrue: [^ nil]
	] ifFalse: [
		newerAutomatically ifFalse: [
			resp _ (PopUpMenu labels: 'Load it\Cancel' withCRs) startUpWithCaption: 
						'A newer version exists on the server.'.
			resp ~= 1 ifTrue: [^ nil]
		].
	].

	"let's avoid renaming the loaded change set since it will be replacing ours"
	self projectParameters at: #loadingNewerVersion put: true.

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			ProjectLoading
				installRemoteNamed: pair first
				from: servers first
				named: self name
				in: parentProject
		]
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 16:58'!
objectForDataStream: refStrm
	| uu dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	"Use a copy with no parent, previous or next to reduce extra stuff copied"
	refStrm project == self ifTrue: [^ self copy setParent: nil].

	dp _ (uu _ self url) size > 0 ifTrue: [
		DiskProxy global: #Project selector: #namedUrl: args: {uu}.
	] ifFalse: [
		DiskProxy global: #Project selector: #named: args: {self name}
	].
	refStrm replace: self with: dp.
	^ dp
! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:11'!
projectExtension
	^'pr'! !

!Project methodsFor: 'file in/out' stamp: 'tk 12/12/2000 11:00'!
restoreReferences
	| key newKey |
	"I just came in from an exported segment.  Take all my players that were in References, and reinstall them."

	(world valueOfProperty: #References ifAbsent: [#()]) do: [:assoc | "just came in"
		key _ assoc key.
		(References includesKey: key) 
			ifTrue: ["must rename" 
				(References at: key) == assoc value ifTrue: [
					self error: 'why object already present?'].
				newKey _ assoc value uniqueNameForReference.
				References removeKey: newKey.
				assoc key: newKey.
				References add: assoc.	"use the known association"
				assoc value renameTo: newKey.	"Player name and recompile scripts"
				]
			ifFalse: [References add: assoc]].
	world removeProperty: #References.! !

!Project methodsFor: 'file in/out' stamp: 'tk 10/26/1999 14:23'!
revert
	| |
	"Exit this project and do not save it.  Warn user unless in dangerous projectRevertNoAsk mode.  Exit to the parent project.  Do a revert on a clone of the segment, to allow later reverts."

	projectParameters ifNil: [^ self inform: 'nothing to revert to'].
	parentProject enter: false revert: true saveForRevert: false.
	"does not return!!"
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/13/2000 18:03'!
saveAs
	"Forget where stored before, and store.  Will ask user where."

	self forgetExistingURL.
	self storeOnServer.! !

!Project methodsFor: 'file in/out' stamp: 'tk 10/26/1999 14:22'!
saveForRevert
	| |
	"Exit to the parent project.  Do a GC.  Save the project in a segment.  Record the ImageSegment object as the revertToMe in Project parameters"

	self isTopProject ifTrue: [^ PopUpMenu notify: 'Can''t exit the top project'].
	parentProject enter: false revert: false saveForRevert: true.
	"does not return!!"

! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/17/2000 19:14'!
serverList
	| swiki bigHACK |

	"Take my list of server URLs and return a list of ServerDirectories to write on.  Each starts with ftp://"

	self flag: #bob.		"BIG hack to try projects on a swiki"
	bigHACK _ false.

	bigHACK ifTrue: [
		(swiki _ SuperSwikiServer currentSuperSwiki) ifNotNil: [
			^{swiki}
		].
	].
	urlList isEmptyOrNil ifTrue: [^ nil].
	^ urlList collect: [:url | Project serverDirectoryFromURL: url]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/23/2000 11:54'!
squeakletDirectory

	| squeakletDirectoryName |
	squeakletDirectoryName _ 'Squeaklets'.
	(FileDirectory default directoryExists: squeakletDirectoryName) ifFalse: [
		FileDirectory default createDirectory: squeakletDirectoryName
	].
	^FileDirectory default directoryNamed: squeakletDirectoryName! !

!Project methodsFor: 'file in/out' stamp: 'tk 8/21/1999 07:31'!
storeDataOn: aDataStream
	"Write me out.  All references to other projects are weak references.  They only go out if they are written for another reason."
	| cntInstVars cntIndexedVars localInstVars offset |

	cntInstVars _ self class instSize.
	cntIndexedVars _ self basicSize.
	localInstVars _ Project instVarNames.
	offset _ Project superclass instSize.
	aDataStream
		beginInstance: self class
		size: cntInstVars + cntIndexedVars.
	1 to: cntInstVars do:
		[:ii | 
		(ii between: offset+1 and: offset + localInstVars size) 
			ifTrue: [(#('parentProject' 'previousProject' 'nextProject') includes: 
				(localInstVars at: ii-offset)) 
					ifTrue: [aDataStream nextPutWeak: (self instVarAt: ii)]
								"owner only written if in our tree"
					ifFalse: [aDataStream nextPut: (self instVarAt: ii)]]
			ifFalse: [aDataStream nextPut: (self instVarAt: ii)]].

	1 to: cntIndexedVars do:
		[:i | aDataStream nextPut: (self basicAt: i)]! !

!Project methodsFor: 'file in/out' stamp: 'RAA 2/3/2001 16:49'!
storeLocallyInnards
	"Save the project to the local disk only"

	| resp newName localDirectory localVersionPair myVersionNumber warning maxNumber |
	self assureIntegerVersion.

	"Find out what version"

	localDirectory _ FileDirectory default.
	localVersionPair _ self class mostRecent: self name onServer: localDirectory.
	maxNumber _ myVersionNumber _ self currentVersionNumber.
	ProgressNotification signal: '2:versionsDetected'.

	warning _ ''.
	myVersionNumber < localVersionPair second ifTrue: [
		warning _ warning,'\There are newer version(s) in the local directory'.
		maxNumber _ maxNumber max: localVersionPair second.
	].
	"8 Nov 2000 - only check on the first attempt to publish"
	myVersionNumber = 0 ifTrue: [
		warning isEmpty ifFalse: [
			myVersionNumber = 0 ifTrue: [
				warning _ warning,'\THIS PROJECT HAS NEVER BEEN SAVED'
			].
			warning _ 'WARNING', '\Project: ',self name,warning.
			resp _ (PopUpMenu labels: 'Store anyway\Cancel' withCRs) startUpWithCaption: 
				(warning, '\Please cancel, rename this project, and see what is there.') withCRs.
				resp ~= 1 ifTrue: [^ nil]
		].
	].
	version _ self bumpVersion: maxNumber.

	"write locally - now zipped automatically"

	newName _ FillInTheBlank 
			request: 'File name?' 
			initialAnswer: self versionedFileName.
	newName isEmpty ifTrue: [^ self beep].

	lastSavedAtSeconds _ Time totalSeconds.
	self exportSegmentFileName: newName directory: localDirectory.		
	ProgressNotification signal: '4:localSaveComplete'.	"3 is deep in export logic"

	ProgressNotification signal: '9999 save complete'.


! !

!Project methodsFor: 'file in/out' stamp: 'RAA 2/3/2001 16:44'!
storeLocallyOnly
	"Forget where stored before, and store.  Will ask user where."

	self forgetExistingURL.
	self validateProjectNameIfOK: [
		self isCurrentProject ifTrue: ["exit, then do the command"
			^ self 
				armsLengthCommand: #storeLocallyWithProgressInfo
				withDescription: 'Publishing'
		].
		self storeLocallyWithProgressInfo.
	].
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 2/3/2001 16:43'!
storeLocallyWithProgressInfo

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project storing';
		withProgressDo: [self storeLocallyInnards]
	! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/12/2000 17:30'!
storeOnServer

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self validateProjectNameIfOK: [
		self isCurrentProject ifTrue: ["exit, then do the command"
			^ self 
				armsLengthCommand: #storeOnServerAssumingNameValid
				withDescription: 'Publishing'
		].
		self storeOnServerWithProgressInfo.
	].! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/12/2000 17:30'!
storeOnServerAssumingNameValid

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self isCurrentProject ifTrue: ["exit, then do the command"
		^ self 
			armsLengthCommand: #storeOnServerAssumingNameValid
			withDescription: 'Publishing'
	].
	self storeOnServerWithProgressInfo.
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 11/8/2000 10:56'!
storeOnServerInnards
	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	| servers resp newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber |
	self assureIntegerVersion.

	"Find out what version"
	(servers _ self serverList) ifNil: [
		(primaryServerDirectory _ self findAFolderToStoreProjectIn) ifNotNil: [
			servers _ Array with: primaryServerDirectory.
			self storeNewPrimaryURL: primaryServerDirectory realUrl, '/'.
		].
	] ifNotNil: [
		primaryServerDirectory _ servers first.
	].
	localDirectory _ self squeakletDirectory.
	serverVersionPair _ self class mostRecent: self name onServer: primaryServerDirectory.
	localVersionPair _ self class mostRecent: self name onServer: localDirectory.
	maxNumber _ myVersionNumber _ self currentVersionNumber.
	ProgressNotification signal: '2:versionsDetected'.

	warning _ ''.
	myVersionNumber < serverVersionPair second ifTrue: [
		warning _ warning,'\There are newer version(s) on the server'.
		maxNumber _ maxNumber max: serverVersionPair second.
	].
	myVersionNumber < localVersionPair second ifTrue: [
		warning _ warning,'\There are newer version(s) in the local directory'.
		maxNumber _ maxNumber max: localVersionPair second.
	].
	"8 Nov 2000 - only check on the first attempt to publish"
	myVersionNumber = 0 ifTrue: [
		warning isEmpty ifFalse: [
			myVersionNumber = 0 ifTrue: [
				warning _ warning,'\THIS PROJECT HAS NEVER BEEN SAVED'
			].
			warning _ 'WARNING', '\Project: ',self name,warning.
			resp _ (PopUpMenu labels: 'Store anyway\Cancel' withCRs) startUpWithCaption: 
				(warning, '\Please cancel, rename this project, and see what is there.') withCRs.
				resp ~= 1 ifTrue: [^ nil]
		].
	].
	version _ self bumpVersion: maxNumber.

	"write locally - now zipped automatically"
	newName _ self versionedFileName.
	lastSavedAtSeconds _ Time totalSeconds.
	self exportSegmentFileName: newName directory: localDirectory.		
	ProgressNotification signal: '4:localSaveComplete'.	"3 is deep in export logic"

	primaryServerDirectory ifNotNil: [
		self
			writeFileNamed: newName 
			fromDirectory: localDirectory 
			toServer: primaryServerDirectory.
	].
	ProgressNotification signal: '9999 save complete'.

	"Later, store with same name on secondary servers.  Still can be race conditions.  All machines will go through the server list in the same order."
	"2 to: servers size do: [:aServer | aServer putFile: local named: newName]."
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/19/2000 14:10'!
storeOnServerShowProgressOn: aMorphOrNil forgetURL: forget

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	forget ifTrue: [
		self forgetExistingURL.
	] ifFalse: [
		urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy].
	].
	world setProperty: #optimumExtentFromAuthor toValue: world extent.
	self validateProjectNameIfOK: [
		self isCurrentProject ifTrue: ["exit, then do the command"
			^self
				armsLengthCommand: #storeOnServerAssumingNameValid
				withDescription: 'Publishing'
		].
		self storeOnServerWithProgressInfoOn: aMorphOrNil.
	] fixTemps.
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/23/2000 12:56'!
storeOnServerWithProgressInfo

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project storing';
		withProgressDo: [self storeOnServerInnards]
	! !

!Project methodsFor: 'file in/out' stamp: 'RAA 6/30/2000 14:10'!
storeOnServerWithProgressInfoOn: aMorphOrNil

	"Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."

	ComplexProgressIndicator new 
		targetMorph: aMorphOrNil;
		historyCategory: 'project storing';
		withProgressDo: [self storeOnServerInnards]
	! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/25/2000 10:01'!
storeSegment
	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <project name>.seg.  *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***"

| is sizeHint |
(Display isCurrentMorphicWorld: world) ifTrue: [^ false]. 
	"self inform: 'Can''t send the current world out'."
world isInMemory ifFalse: [^ false].  "already done"
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ false].	"Only Morphic projects for now"
world ifNil: [^ false].  world presenter ifNil: [^ false].

Utilities emptyScrapsBook.
Display checkCurrentHandForObjectToPaste.
world releaseSqueakPages.
sizeHint _ self projectParameters at: #segmentSize ifAbsent: [0].

is _ ImageSegment new copyFromRootsLocalFileFor: 
			(Array with: world presenter with: world)	"world, and all Players"
		 sizeHint: sizeHint.

is state = #tooBig ifTrue: [^ false].
is segment size < 2000 ifTrue: ["debugging" 
	Transcript show: self name, ' only ', is segment size printString, 
		'bytes in Segment.'; cr].
self projectParameters at: #segmentSize put: is segment size.
is extract; writeToFile: self name.
^ true
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 5/25/2000 10:28'!
storeSegmentNoFile
	"For testing.  Make an ImageSegment.  Keep the outPointers in memory.  Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)"

| is str |
(Display isCurrentMorphicWorld: world) ifTrue: [^ self].		" inform: 'Can''t send the current world out'."
world isInMemory ifFalse: [^ self].  "already done"
world isMorph ifFalse: [
	self projectParameters at: #isMVC put: true.
	^ self].	"Only Morphic projects for now"
world ifNil: [^ self].  world presenter ifNil: [^ self].

"Do this on project enter"
Display bestGuessOfCurrentWorld flapTabs do: [:ft | ft referent adaptToWorld: Display bestGuessOfCurrentWorld].
	"Hack to keep the Menu flap from pointing at my project"
"Preferences setPreference: #useGlobalFlaps toValue: false."
"Utilities globalFlapTabsIfAny do:
	[:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false].
Utilities clobberFlapTabList.	"
"project world deleteAllFlapArtifacts."
"self currentWorld deleteAllFlapArtifacts.	"
Utilities emptyScrapsBook.
Display checkCurrentHandForObjectToPaste2.

is _ ImageSegment new copyFromRootsLocalFileFor: 
		(Array with: world presenter with: world)	"world, and all Players"
	sizeHint: 0.

is segment size < 800 ifTrue: ["debugging" 
	Transcript show: self name, ' did not get enough objects'; cr.  ^ self beep].
false ifTrue: [
	str _ String streamContents: [:strm |
		strm nextPutAll: 'Only a tiny part of the project got into the segment'.
		strm nextPutAll: '\These are pointed to from the outside:' withCRs.
		is outPointers do: [:out |
			(out class == Presenter) | (out class == ScriptEditorMorph) ifTrue: [
				strm cr. out printOn: strm.
				Smalltalk
					browseAllObjectReferencesTo: out
					except: (Array with: is outPointers)
					ifNone: [:obj | ]].
			(is arrayOfRoots includes: out class) ifTrue: [strm cr. out printOn: strm.
				Smalltalk
					browseAllObjectReferencesTo: out
					except: (Array with: is outPointers)
					ifNone: [:obj | ]]]].
	self inform: str.
	^ is inspect].

is extract.
"is instVarAt: 2 put: is segment clone."		"different memory"
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 9/27/2000 18:55'!
storeSomeSegment
	"Try all projects to see if any is ready to go out.  Send at most three of them.
	Previous one has to wait for a garbage collection before it can go out."

	| cnt pList start proj gain |
	cnt _ 0.  gain _ 0.
	pList _ Project allProjects.
	start _ pList size atRandom.	"start in a random place"
	start to: pList size + start do: [:ii | 
		proj _ pList atWrap: ii.
		proj storeSegment ifTrue: ["Yes, did send its morphs to the disk"
			gain _ gain + (proj projectParameters at: #segmentSize 
						ifAbsent: [0]).	"a guess"
			self beep.
			(cnt _ cnt + 1) >= 2 ifTrue: [^ gain]]].
	self beep.
	^ gain! !

!Project methodsFor: 'file in/out' stamp: 'sma 6/16/2000 23:43'!
storeToMakeRoom
	"Write out enough projects to fulfill the space goals.
	Include the size of the project about to come in."

	| params memoryEnd goalFree cnt gain proj skip tried |
	GoalFreePercent ifNil: [GoalFreePercent _ 33].
	GoalNotMoreThan ifNil: [GoalNotMoreThan _ 20000000].
	params _ Smalltalk getVMParameters.
	memoryEnd	_ params at: 3.
"	youngSpaceEnd	_ params at: 2.
	free _ memoryEnd - youngSpaceEnd.
"
	goalFree _ GoalFreePercent asFloat / 100.0 * memoryEnd.
	goalFree _ goalFree min: GoalNotMoreThan.
	world isInMemory ifFalse: ["enough room to bring it in"
		goalFree _ goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])].
	cnt _ 30.
	gain _ Smalltalk garbageCollectMost.
	"skip a random number of projects that are in memory"
	proj _ self.  skip _ 6 atRandom.
	[proj _ proj nextInstance ifNil: [Project someInstance].
		proj world isInMemory ifTrue: [skip _ skip - 1].
		skip > 0] whileTrue.
	cnt _ 0.  tried _ 0.

	[gain > goalFree] whileFalse: [
		proj _ proj nextInstance ifNil: [Project someInstance].
		proj storeSegment ifTrue: ["Yes, did send its morphs to the disk"
			gain _ gain + (proj projectParameters at: #segmentSize 
						ifAbsent: [20000]).	"a guess"
			self beep.
			(cnt _ cnt + 1) > 5 ifTrue: [^ self]].	"put out 5 at most"
		(tried _ tried + 1) > 23 ifTrue: [^ self]].	"don't get stuck in a loop"! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/26/2000 13:47'!
tryToFindAServerWithMe

	| servers resp primaryServerDirectory |

	urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy].
	[(servers _ self serverList) isNil] whileTrue: [
		resp _ (PopUpMenu labels: 'Try to find a server\Cancel' withCRs) startUpWithCaption: 
					'This project thinks it has never been on a server'.
		resp ~= 1 ifTrue: [^ nil].
		(primaryServerDirectory _ self findAFolderToLoadProjectFrom) ifNil: [^nil].
		self storeNewPrimaryURL: primaryServerDirectory realUrl, '/'.
	].
	^servers
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 12:38'!
url
	| firstURL |
	"compose my url on the server"

	urlList isEmptyOrNil ifTrue: [^''].
	firstURL _ urlList first.
	firstURL last == $/ ifFalse: [firstURL _ firstURL, '/'].
	^ firstURL, self versionedFileName
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 12:36'!
urlForLoading
	| aDir |
	"compose a url that will load me in someone's browser"

	aDir _ (self serverList ifNil: [^nil]) first.
	aDir loaderUrl isEmptyOrNil ifTrue: [^nil].
	^
		aDir loaderUrl,
		'?',
		self versionedFileName encodeForHTTP
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/15/2000 19:10'!
versionFrom: aServerFile
	"Store the version of the file I actually came from.  My stored version was recorded before I knew the latest version number on the server!!"
	| theName serverUrl |

	self flag: #bob.		"this may become unnecessary once we get the version before writing"
	self flag: #bob.		"need to recognize swiki servers"

	serverUrl _ aServerFile directoryUrl.
	theName _ aServerFile localName.
	version _ (Project parseProjectFileName: theName) second.
	(serverUrl beginsWith: 'ftp:') ifTrue: ["update our server location"
		self storeNewPrimaryURL: serverUrl
	].
! !

!Project methodsFor: 'file in/out' stamp: 'ar 10/11/2000 15:11'!
versionedFileName
	"Project current versionedFileName"
	| v |
	^String streamContents:[:s|
		s nextPutAll: self name.
		s nextPutAll: FileDirectory dot.
		v _ self currentVersionNumber printString.
		v size < 3 ifTrue:[v _ '0', v].
		v size < 3 ifTrue:[v _ '0', v].
		s nextPutAll: v.
		s nextPutAll: FileDirectory dot.
		s nextPutAll: self projectExtension.
	]
! !

!Project methodsFor: 'file in/out' stamp: 'RAA 10/19/2000 14:14'!
writeFileNamed: localFileName fromDirectory: localDirectory toServer: primaryServerDirectory

	| local resp gifFileName f |

	local _ localDirectory oldFileNamed: localFileName.
	resp _ primaryServerDirectory putFile: local named: localFileName retry: false.
	local close.
	resp == true ifFalse: [
		self inform: 'the primary server of this project seems to be down (',
							resp printString,')'. 
		^ self
	].

	gifFileName _ self name,'.gif'.
	localDirectory deleteFileNamed: gifFileName ifAbsent: [].
	local _ localDirectory fileNamed: gifFileName.
	thumbnail ifNil: [
		(thumbnail _ Form extent: 100@80) fillColor: Color orange
	] ifNotNil: [
		thumbnail unhibernate.
	].
	f _ thumbnail colorReduced.  "minimize depth"
	f depth > 8 ifTrue: [
		f _ thumbnail asFormOfDepth: 8
	].
	GIFReadWriter putForm: f onStream: local.
	local close.

	local _ localDirectory oldFileNamed: gifFileName.
	resp _ primaryServerDirectory putFile: local named: gifFileName retry: false.
	local close.

	primaryServerDirectory updateProjectInfoFor: self.
	primaryServerDirectory sleep.	"if ftp, close the connection"
! !


!Project methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	isolatedHead ifNil: [isolatedHead _ false].
	inForce ifNil: [inForce _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!Project methodsFor: 'project parameters' stamp: 'sw 11/6/2000 15:22'!
cleanseDisabledGlobalFlapsList
	"Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them"

	| disabledFlaps currentGlobals |
	disabledFlaps _ self parameterAt: #disabledGlobalFlaps ifAbsent: [^ self].
	currentGlobals _ Utilities globalFlapTabsIfAny.
	disabledFlaps _ disabledFlaps select: [:aFlapTab | currentGlobals includes: aFlapTab].
	self projectParameterAt: #disabledGlobalFlaps put: disabledFlaps! !

!Project methodsFor: 'project parameters' stamp: 'sw 10/27/2000 06:46'!
currentStack
	"Answer the current stack of the current project.  Called basically as a bail-out when we can't find the stack in the owner chain of a morph, probably because it is on a background that is not currently installed.  This method will always return a stack that is in the world, or nil if no stack is found in the world.  Of course it would be nice to have multiple stacks concurrently open in the same world, but at the moment that is problematical."

	| aStack curStack |

	curStack _ self projectParameterAt: #CurrentStack.
	curStack ifNotNil: [curStack isInWorld ifTrue: [^ curStack]].

	(aStack _ world findA: StackMorph) ifNotNil:
		[self currentStack: aStack].
	^ aStack! !

!Project methodsFor: 'project parameters' stamp: 'sw 11/6/2000 15:28'!
enableDisableGlobalFlap: aFlapTab
	"Toggle the enable/disable status of the given global flap"

	| disabledFlaps |
	disabledFlaps _ self parameterAt: #disabledGlobalFlaps ifAbsent: [self projectParameterAt: #disabledGlobalFlaps put: Set new].
	aFlapTab hideFlap.  "in case open"
	(disabledFlaps includes: aFlapTab)
		ifTrue:
			[disabledFlaps remove: aFlapTab.
			self currentWorld addGlobalFlaps]
		ifFalse:
			[disabledFlaps add: aFlapTab.
			aFlapTab delete].
	self cleanseDisabledGlobalFlapsList

	! !

!Project methodsFor: 'project parameters' stamp: 'sw 6/14/1999 10:15'!
flapsSuppressed
	^ (self projectParameters at: #globalFlapsEnabledInProject) not! !

!Project methodsFor: 'project parameters' stamp: 'sw 6/14/1999 10:17'!
flapsSuppressed: aBoolean
	self projectParameters at: #globalFlapsEnabledInProject put: aBoolean not.
	aBoolean
		ifTrue:		
			[Utilities globalFlapTabsIfAny do:
				[:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: true]]

		ifFalse:
			[Smalltalk isMorphic  ifTrue:
				[self currentWorld addGlobalFlaps]]! !

!Project methodsFor: 'project parameters' stamp: 'sw 11/6/2000 11:20'!
globalFlapEnabledString: aFlapTab
	"Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project."

	^ (self isFlapEnabled: aFlapTab)
		ifTrue:
			['<on>', aFlapTab wording]
		ifFalse:
			['<off>', aFlapTab wording]! !

!Project methodsFor: 'project parameters' stamp: 'sw 4/22/1999 15:13'!
initializeProjectParameters
	projectParameters _ IdentityDictionary new.
	projectParameters at: #globalFlapsEnabledInProject put: true.
	^ projectParameters! !

!Project methodsFor: 'project parameters' stamp: 'sw 11/6/2000 15:18'!
isFlapEnabled:  aFlapTab
	"Answer whether the given flap tab is enabled in this project"

	| disabledFlaps  |
	disabledFlaps _ self parameterAt: #disabledGlobalFlaps ifAbsent: [^ true].
	^ (disabledFlaps includes: aFlapTab) not! !

!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'!
parameterAt: aSymbol
	^self parameterAt: aSymbol ifAbsent:[nil]! !

!Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'!
parameterAt: aSymbol ifAbsent: aBlock
	projectParameters ifNil:[^aBlock value].
	^projectParameters at: aSymbol ifAbsent: aBlock! !

!Project methodsFor: 'project parameters' stamp: 'sw 10/30/2000 11:14'!
projectParameterAt: aSymbol
	"Answer the project parameter stored at the given symbol, or nil if none"

	^ self projectParameters at: aSymbol ifAbsent: [nil]! !

!Project methodsFor: 'project parameters' stamp: 'sw 10/30/2000 11:13'!
projectParameterAt: aSymbol put: aValue
	"Set the given project parameter to the given value"

	^ self projectParameters at: aSymbol put: aValue! !

!Project methodsFor: 'project parameters' stamp: 'sw 4/22/1999 15:14'!
projectParameters
	^ projectParameters ifNil: [self initializeProjectParameters]! !

!Project methodsFor: 'project parameters' stamp: 'tk 10/26/1999 13:55'!
rawParameters
	^ projectParameters! !

!Project methodsFor: 'project parameters' stamp: 'ar 6/2/1999 05:29'!
removeParameter: aKey
	projectParameters ifNil:[^self].
	projectParameters removeKey: aKey ifAbsent:[].! !


!Project methodsFor: 'displaying' stamp: 'RAA 10/6/2000 15:57'!
createViewIfAppropriate

	ProjectViewOpenNotification signal ifTrue: [
		Preferences projectViewsInWindows ifTrue: [
			(ProjectViewMorph newProjectViewInAWindowFor: self) openInWorld
		] ifFalse: [
			(ProjectViewMorph on: self) openInWorld		"but where??"
		].
	].
! !

!Project methodsFor: 'displaying' stamp: 'ar 5/28/2000 19:43'!
displayZoom: entering
	"Show the project transition when entering a new project"
	| newDisplay vanishingPoint |
	"Play the flash transition if any."
	self projectParameters at: #flashTransition ifPresent:[:dict|
		dict at: CurrentProject ifPresent:[:player| ^player playProjectTransitionFrom: CurrentProject to: self entering: entering]].
	"Show animated zoom to new display"
	newDisplay _ self imageForm.
	entering
		ifTrue: [vanishingPoint _ Sensor cursorPoint]
		ifFalse: [vanishingPoint _ self viewLocFor: CurrentProject].
	Display zoomIn: entering orOutTo: newDisplay at: 0@0
			vanishingPoint: vanishingPoint.! !

!Project methodsFor: 'displaying' stamp: 'ar 6/2/1999 01:58'!
imageForm
	^self imageFormOfSize: Display extent
		depth: (displayDepth ifNil:[Display depth])! !

!Project methodsFor: 'displaying' stamp: 'ar 9/1/2000 14:24'!
imageFormOfSize: extentPoint depth: d
	| newDisplay |
	newDisplay _ DisplayScreen extent: extentPoint depth: d.
	Display replacedBy: newDisplay do:[
		world isMorph 
			ifTrue:[Display getCanvas fullDrawMorph: world] "Morphic"
			ifFalse:[world restore]. "MVC"
	].
	^newDisplay! !

!Project methodsFor: 'displaying' stamp: 'sw 1/12/2000 18:44'!
showZoom
	"Decide if user wants a zoom transition, and if there is enough memory to do it."

	^ Preferences projectZoom and:
		"Only show zoom if there is room for both displays plus a megabyte"
		[Smalltalk garbageCollectMost > 
						(Display boundingBox area*displayDepth //8+1000000)]! !


!Project methodsFor: 'isolation layers' stamp: 'RAA 6/3/2000 10:24'!
beIsolated
	"Establish an isolation layer at this project.
	This requires clearing the current changeSet or installing a new one."

	isolatedHead ifTrue: [^ self error: 'Already isolated'].
	self isCurrentProject ifFalse:
		[^ self inform: 'Must be in this project to isolate it'.].
	changeSet isEmpty ifFalse: [changeSet _ ChangeSorter newChangeSet].
	changeSet beIsolationSetFor: self.
	isolatedHead _ true.
	inForce _ true.
	environment _ Environment new setName: self name outerEnvt: Smalltalk.

! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/1/2000 09:22'!
compileAll: newClass from: oldClass
	"Make sure that shadowed methods in isolation layers get recompiled.
	Traversal is done elsewhere.  This simply handles the current project."

	isolatedHead == true ifFalse: [^ self].   "only isolated projects need to act on this."
	
	changeSet compileAll: newClass from: oldClass! !

!Project methodsFor: 'isolation layers' stamp: 'RAA 9/27/2000 18:53'!
compileAllIsolated: newClass from: oldClass
	"Whenever a recompile is needed in a class, look in other isolated projects for saved methods and recompile them also.
	At the time this method is called, the recompilation has already been done for the project now in force."

	Project allProjects do: [:proj | proj compileAll: newClass from: oldClass].

! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:04'!
invoke
	"Install all methods changed here into method dictionaries.
	Make my versions be the ones that will be called."

	isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.'].
	inForce ifTrue: [^ self error: 'This layer is already in force.'].
	changeSet invoke.	
	inForce _ true.! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:49'!
invokeFrom: otherProject
	"Revoke the changes in force for this project, and then invoke those in force for otherProject.  This method shortens the process to the shortest path up then down through the isolation layers."

	| pathUp pathDown |
	pathUp _ otherProject layersToTop.  "Full paths to top"
	pathDown _ self layersToTop.

	"Shorten paths to nearest common ancestor"
	[pathUp isEmpty not
		and: [pathDown isEmpty not
		and: [pathUp last == pathDown last]]]
		whileTrue: [pathUp removeLast.  pathDown removeLast].

	"Now revoke changes up from otherProject and invoke down to self."
	pathUp do: [:p | p revoke].
	pathDown reverseDo: [:p | p invoke].
! !

!Project methodsFor: 'isolation layers' stamp: 'RAA 6/21/2000 23:01'!
isIsolated

	^ isolatedHead ifNil: [isolatedHead _ false]! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/4/2000 21:10'!
isolationHead
	"Go up the parent chain and find the nearest isolated project."

	isolatedHead == true ifTrue: [^ self].
	self isTopProject ifTrue: [^ nil].
	^ parentProject isolationHead! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 17:00'!
isolationSet

	"Return the changeSet for this isolation layer or nil"
	isolatedHead == true ifTrue: [^ changeSet].
	self isTopProject ifTrue: [^ nil].  "At the top, but not isolated"
	^ parentProject isolationSet

! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 15:40'!
layersToTop
	"Return an OrderedCollection of all the projects that are isolation layers from this one up to the top of the project hierarchy, inclusive."

	| layers |
	self isTopProject
		ifTrue: [layers _ OrderedCollection new]
		ifFalse: [layers _ parentProject layersToTop].
	isolatedHead ifTrue: [layers addFirst: self].
	^ layers
! !

!Project methodsFor: 'isolation layers' stamp: 'di 4/14/2000 09:01'!
propagateChanges
	"Assert these changes in the next higher isolation layer of the system."

	isolatedHead ifFalse: [self error: 'You can only assert changes from isolated projects'].
	self halt: 'Not Yet Implemented'.

"This will be done by installing a new changeSet for this project (initted for isolation).  With the old changeSet no longer in place, no revert will happen when we leave, and those changes will have effectively propagated up a level.  NOTE: for this to work in general, the changes here must be assimilated into the isolationSet for the next layer."! !

!Project methodsFor: 'isolation layers' stamp: 'di 3/29/2000 16:06'!
revoke
	"Take back all methods changed here.
	Install the original method dictionaries and organizations.
	The orignal method versions will now be the ones used."

	isolatedHead ifFalse: [^ self error: 'This isnt an isolation layer.'].
	inForce ifFalse: [^ self error: 'This layer should have been in force.'].
	changeSet revoke.	
	inForce _ false.
! !



!Project methodsFor: 'OBSOLETE' stamp: 'RAA 6/3/2000 19:01'!
obsolete

	self flag: #obsolete.
	"instance variable 
		exitFlag is no longer used
		activeProcess is on the way out
	"! !


!Project methodsFor: 'SuperSwiki' stamp: 'RAA 7/13/2000 11:11'!
tellAFriend

	self tellAFriend: nil
! !

!Project methodsFor: 'SuperSwiki' stamp: 'RAA 9/21/2000 16:00'!
tellAFriend: emailAddressOrNil
	| urlForLoading |
"
Project current tellAFriend
"

	(urlForLoading _ self urlForLoading) ifNil: [
		urlForLoading _ self url		"fallback for dtp servers"
	].
	urlForLoading isEmptyOrNil ifTrue: [
		^self inform: 'Since this project has not been saved yet,
I cannot tell someone where it is.'
	].
	FancyCelesteComposition new
		celeste: nil 
		to: (emailAddressOrNil ifNil: ['RECIPIENT.GOESHERE'])
		subject: 'A Squeak project link you might like'
		initialText: 'This is a link to a Squeak project: '
		theLinkToInclude: 
			'<A HREF="',
			urlForLoading,
			'">',
			self name,
			'</A>';

		open.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Project class
	instanceVariableNames: ''!

!Project class methodsFor: 'class initialization' stamp: 'RAA 6/3/2000 18:50'!
initialize
	"This is the Top Project."   

	CurrentProject ifNil:
		[CurrentProject _ super new initialProject.
		Project spawnNewProcessAndTerminateOld: true].

	"Project initialize"! !


!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'!
new

	| new |

	new _ super new.
	new setProjectHolder: CurrentProject.
	self addingProject: new.
	^new! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:07'!
newMorphic
	| new |
	"ProjectView open: Project newMorphic"

	new _ self basicNew.
	self addingProject: new.
	new initMorphic.
	^new! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 11/16/2000 12:08'!
newMorphicOn: aPasteUpOrNil

	| newProject |

	newProject _ self basicNew initMorphic.
	self addingProject: newProject.
	aPasteUpOrNil ifNotNil: [newProject installPasteUpAsWorld: aPasteUpOrNil].
	newProject createViewIfAppropriate.
	^newProject
! !

!Project class methodsFor: 'instance creation' stamp: 'RAA 9/27/2000 13:41'!
uiProcess

	^ UIProcess! !


!Project class methodsFor: 'utilities' stamp: 'di 6/13/1998 11:29'!
addItem: item toMenu: menu selection: action
	(menu isKindOf: MenuMorph)
		ifTrue: [menu add: item selector: #jumpToSelection: argument: action]
		ifFalse: [menu add: item action: action]! !

!Project class methodsFor: 'utilities' stamp: 'tk 9/22/1999 18:45'!
addItem: item toMenu: menu selection: action project: aProject
	| aColor |
	aColor _ aProject isMorphic 
		ifTrue: [aProject world isInMemory 
			ifTrue: [Color red darker] 
			ifFalse: [Color brown]]
		ifFalse: [aProject world isInMemory 
			ifTrue: [Color veryVeryDarkGray]
			ifFalse: [Color blue]].
	(menu isKindOf: MenuMorph)
		ifTrue:
			[menu add: item selector: #jumpToSelection: argument: action.
			menu items last color: aColor]
		ifFalse:
			[menu add: item action: action]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/16/2000 12:04'!
addingProject: newProject

	(self allProjects includes: newProject) ifTrue: [^self].
	AllProjects _ self allProjects copyWith: newProject.! !

!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'!
advanceToNextProject
	| nextProj |
	(nextProj _ CurrentProject nextProject) ifNotNil:
		 [nextProj enter: true revert: false saveForRevert: false]
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/14/2000 19:14'!
allMorphicProjects

	^ self allProjects select: [:p | p world isMorph]! !

!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'!
allNames
	^ (self allProjects collect: [:p | p name]) asSortedCollection: [:n1 :n2 | n1 asLowercase < n2 asLowercase]! !

!Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'!
allNamesAndProjects
	^ (self allProjects asSortedCollection: [:p1 :p2 | p1 name asLowercase < p2 name asLowercase]) collect:
		[:aProject | Array with: aProject name with: aProject]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:14'!
allProjects

	^AllProjects ifNil: [
		Smalltalk garbageCollect.
		AllProjects _ self allSubInstances select: [:p | p name notNil].
	].! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 10:24'!
buildJumpToMenu: menu
	"Make the supplied menu offer a list of potential projects, consisting of:
		*	The previous-project chain
		*	The next project, if any
		*	The parent project, if any
		*	All projects, alphabetically"

	| prev listed i next  toAdd |
	listed _ OrderedCollection with: CurrentProject.
	i _ 0.
	prev _ CurrentProject previousProject.
	[(prev ~~ nil and: [(listed includes: prev) not])] whileTrue:
		[i _ i + 1.
		listed add: prev.
		self addItem: prev name , ' (back ' , i printString , ')'
					toMenu: menu selection: ('%back' , i printString) project: prev.
				prev _ prev previousProject].
	(((next _ CurrentProject nextProject) ~~ nil) and: [(listed includes: next) not]) ifTrue:
		[self addItem: (next name, ' (forward 1)') toMenu: menu selection: next name project: next]. 
	(i > 0 or: [next ~~ nil]) ifTrue: [menu addLine].

	"Then the parent"
	CurrentProject isTopProject ifFalse: 
		[self addItem: CurrentProject parent name , ' (parent)' toMenu: menu selection: #parent project: CurrentProject parent.
		menu addLine].

	"Finally all the projects, in alphabetical order"
	Project allNamesAndProjects do:
		[:aPair | 
			toAdd _ aPair last isCurrentProject
				ifTrue:
					[aPair first, ' (current)']
				ifFalse:
					[aPair first].
			self addItem: toAdd toMenu: menu selection: aPair first project: aPair last].
	^ menu
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 7/25/2000 10:02'!
canWeLoadAProjectNow

	Smalltalk verifyMorphicAvailability ifFalse: [^ false].

	"starting to see about eliminating the below"
	"Smalltalk isMorphic ifFalse: [
		self inform: 'Later, allow jumping from MVC to Morphic Projects.'.
		^false
	]."

	^true
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/13/2000 17:26'!
deletingProject: outgoingProject

	ImageSegment allSubInstancesDo: [:seg |
		seg ifOutPointer: outgoingProject thenAllObjectsDo: [:obj |
			(obj isKindOf: ProjectViewMorph) ifTrue: [
				obj deletingProject: outgoingProject.  obj abandon].
			obj class == Project ifTrue: [obj deletingProject: outgoingProject]]].
	Project allProjects do: [:p | p deletingProject: outgoingProject].	"ones that are in"
	ProjectViewMorph allSubInstancesDo: [:p | 
		p deletingProject: outgoingProject.
		p project == outgoingProject ifTrue: [p abandon]].

	AllProjects _ self allProjects copyWithout: outgoingProject.! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 09:52'!
enter: aString
	"Enter the project with the given name"
	^ ((self named: aString) ifNil: [^ CurrentProject]) enter! !

!Project class methodsFor: 'utilities' stamp: 'RAA 12/26/2000 12:42'!
forget: aProject

	AllProjects _ self allProjects reject: [ :x | x == aProject].
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 10/26/2000 11:58'!
interruptName: labelString
	"Create a Notifier on the active scheduling process with the given label."
	| suspendingList projectProcess |
	Smalltalk isMorphic ifFalse:
		[^ ScheduledControllers interruptName: labelString].

	World primaryHand ifNotNil: [World primaryHand releaseAllFoci].

	projectProcess _ self uiProcess.	"we still need the accessor for a while"
	(suspendingList _ projectProcess suspendingList) == nil
		ifTrue: [projectProcess == Processor activeProcess
					ifTrue: [projectProcess suspend]]
		ifFalse: [suspendingList remove: projectProcess.
				projectProcess offList].

	Debugger openInterrupt: labelString onProcess: projectProcess
! !

!Project class methodsFor: 'utilities' stamp: 'di 6/13/1998 11:24'!
jumpToProject		"Project jumpToProject"
	"Present a list of potential projects and enter the one selected."

	self jumpToSelection: (self buildJumpToMenu: CustomMenu new) startUp
! !

!Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:09'!
jumpToSelection: selection
	"Enter the project corresponding to this menu selection."
	"Project jumpToProject"
	| nBack prev pr |
	selection ifNil: [^ self].
	(selection beginsWith: '%back') ifTrue:
		[nBack _ (selection copyFrom: 6 to: selection size) asNumber.
		prev _ CurrentProject previousProject.
		1 to: nBack-1 do:
			[:i | prev ifNotNil: [prev _ prev previousProject]].
		prev ifNotNil: [prev enter: true revert: false saveForRevert: false]].
	selection = #parent ifTrue: [
		CurrentProject parent enter: false revert: false saveForRevert: false.
		^ self].
	(pr _ Project named: selection) ifNil: [^ self].
	pr enter: false revert: false saveForRevert: false

! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 19:00'!
maybeForkInterrupt

	Preferences cmdDotEnabled ifFalse: [^self].
	Smalltalk isMorphic
		ifTrue: [[self interruptName: 'User Interrupt'] fork]
		ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]! !

!Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:10'!
named: projName
	"Answer the project with the given name, or nil if there is no project of that given name."
	"(Project named: 'New Changes') enter"

	^ self allProjects
		detect: [:proj | proj name = projName]
		ifNone: [nil]
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 11/11/2000 23:05'!
named: projName in: aListOfProjects
	"Answer the project with the given name, or nil if there is no project of that given name."
	"Use given collection for speed until we get faster #allProjects"

	^ aListOfProjects
		detect: [:proj | proj name = projName]
		ifNone: [nil]
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'!
ofWorld: aPasteUpMorph
	"Find the project of a world."

	"Usually it is the current project"
	CurrentProject world == aPasteUpMorph ifTrue: [^ CurrentProject].

	"Inefficient enumeration if it is not..."
	^ self allProjects detect: [:pr |
		pr world isInMemory 
			ifTrue: [pr world == aPasteUpMorph]
			ifFalse: [false]]
		ifNone: [nil]! !

!Project class methodsFor: 'utilities' stamp: 'sw 9/7/2000 06:42'!
projectHierarchy
	"Answer a string representing all the projects in the system in hierarchical order"

	^ String streamContents:
		[:aStream |
			self topProject addSubProjectNamesTo: aStream indentation: 0] 

"Project projectHierarchy"! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:28'!
resumeProcess: aProcess
	"Adopt aProcess as the project process -- probably because of proceeding from a debugger"

	UIProcess _ aProcess.
	UIProcess resume! !

!Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'!
returnToPreviousProject
	"Return to the project from which this project was entered. Do nothing if the current project has no link to its previous project."

	| prevProj |
	prevProj _ CurrentProject previousProject.
	prevProj ifNotNil: [prevProj enter: true revert: false saveForRevert: false].
! !

!Project class methodsFor: 'utilities' stamp: 'sw 9/7/2000 06:50'!
showProjectHierarchyInWindow
	"Open a window that displays the project hierarchy"

	| hierarchyString numberOfProjects |
	hierarchyString _ self projectHierarchy.
	numberOfProjects _ hierarchyString lineCount.
	((StringHolder new contents: hierarchyString)
		embeddedInMorphicWindowLabeled: 'Projects (', numberOfProjects printString, ') ', Date today printString, ' ', Time now printString)
			setWindowColor:  (Color r: 1.0 g: 0.829 b: 0.909);
			openInWorld: self currentWorld extent: (300 @ (((numberOfProjects * (TextStyle  defaultFont lineGrid + 4) min: (self currentWorld height - 50)))))

"Project showProjectHierarchyInWindow"
! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'!
spawnNewProcess

	UIProcess _ [
		[World doOneCycle.  Processor yield.  false] whileFalse: [].
	] newProcess priority: Processor userSchedulingPriority.
	UIProcess resume! !

!Project class methodsFor: 'utilities' stamp: 'RAA 6/3/2000 18:49'!
spawnNewProcessAndTerminateOld: terminate

	self spawnNewProcess.
	terminate
		ifTrue: [Processor terminateActive]
		ifFalse: [Processor activeProcess suspend]! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 18:52'!
storeAllInSegments
	"Write out all Projects in this Image.
	Project storeAllInSegments.		"

	| all ff ll |
all _ Project allProjects.
Transcript show: 'Initial Space Left: ', (ff _ Smalltalk garbageCollect) printString; cr.
all do: [:proj |
	Transcript show: proj name; cr.
	proj storeSegment  "storeSegmentNoFile"].
Transcript show: 'After writing all: ', (ll _ Smalltalk garbageCollect) printString; cr.
Transcript show: 'Space gained: ', (ll - ff) printString; cr.
"some will come back in"! !

!Project class methodsFor: 'utilities' stamp: 'RAA 9/27/2000 19:00'!
topProject
	"Answer the top project.  There is only one"

	^ self allProjects detect: [:p | p isTopProject]! !


!Project class methodsFor: 'constants'!
current
	"Answer the project that is currently being used."

	^CurrentProject! !


!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 7/4/2000 16:29'!
enterIfThereOrFind: aProjectName

	| newProject |
	newProject _ Project named: aProjectName.
	newProject ifNotNil: [^newProject enter].

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			[
				newProject _ CurrentProject fromMyServerLoad: aProjectName
			] 
				on: ProjectViewOpenNotification
				do: [ :ex | ex resume: false]		
					"we probably don't want a project view morph in this case"
		].

	newProject ifNotNil: [^newProject enter].
	1 beep.! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/17/2000 14:57'!
fromUrl: urlString
	| serverFile pair projName proj num triple serverDir |
	"Load the project, and make a thumbnail to it in the current project.  Replace the old one if necessary.
Project fromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/Squeak_Easy.pr.gz'.
"

	Project canWeLoadAProjectNow ifFalse: [^ self].
	serverFile _ Project serverFileFromURL: urlString.
	serverDir _ serverFile directoryObject.
	triple _ Project parseProjectFileName: serverFile fileName unescapePercents.
	projName _ triple first.
	(proj _ Project named: projName) ifNotNil: ["it appeared" ^ ProjectEntryNotification signal: proj].
	serverDir isTypeHTTP
		ifTrue: [num _ triple second.
			pair _ Array with: serverFile fileName with: num]
		ifFalse: [pair _ self mostRecent: serverFile localName onServer: serverDir].
	"Pair first is name exactly as it is on the server"
	pair first ifNil: [^self openBlankProjectNamed: projName].

	ProjectLoading
		installRemoteNamed: pair first
		from: serverDir
		named: projName
		in: CurrentProject.! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 1/28/2001 08:39'!
isBadNameForStoring: aString

	| badChars |

	"will the name of this project cause problems when stored on an arbitrary file system?"
	badChars _ #( $: $< $> $| $/ $\ $? $* $" $.) asSet.
	^aString size > 24 or: [
		aString anySatisfy: [ :each | 
			each asciiValue < 32 or: [badChars includes: each]
		]
	]
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 10/11/2000 15:00'!
mostRecent: projName onServer: aServerDirectory
	| stem list max goodName triple num stem1 stem2 rawList nothingFound unEscName |
	"Find the exact fileName of the most recent version of project with the stem name of projName.  Names are of the form 'projName|mm.pr' where mm is a mime-encoded integer version number.
	File names may or may not be HTTP escaped, %20 on the server."

	self flag: #bob.		"do we want to handle unversioned projects as well?"

	nothingFound _ {nil. -1}.
	aServerDirectory ifNil: [^nothingFound].
	"23 sept 2000 - some old projects have periods in name so be more careful"
	unEscName _ projName unescapePercents.
	triple _ Project parseProjectFileName: unEscName.
	stem _ triple first.
	rawList _ aServerDirectory fileNames.

	rawList class == String ifTrue: [self inform: 'server is unavailable'. ^nothingFound].
	list _ rawList collect: [:nnn | nnn unescapePercents].
	max _ -1.  goodName _ nil.
	list withIndexDo: [:aName :ind |
		(aName beginsWith: stem) ifTrue: [
			num _ (Project parseProjectFileName: aName) second.
			num > max ifTrue: [max _ num.  goodName _ (rawList at: ind)]]].

	max = -1 ifFalse: [^ Array with: goodName with: max].

	"try with underbar for spaces on server"
	(stem includes: $ ) ifTrue: [
		stem1 _ stem copyReplaceAll: ' ' with: '_'.
		list withIndexDo: [:aName :ind |
			(aName beginsWith: stem1) ifTrue: [
				num _ (Project parseProjectFileName: aName) second.
				num > max ifTrue: [max _ num.  goodName _ (rawList at: ind)]]]].
	max = -1 ifFalse: [^ Array with: goodName with: max].
	
	"try without the marker | "
	stem1 _ stem allButLast, '.pr'.
	stem2 _ stem1 copyReplaceAll: ' ' with: '_'.	"and with spaces replaced"
	list withIndexDo: [:aName :ind |
		(aName beginsWith: stem1) | (aName beginsWith: stem2) ifTrue: [
			(triple _ aName findTokens: '.') size >= 2 ifTrue: [
				max _ 0.  goodName _ (rawList at: ind)]]].	"no other versions"
	max = -1 ifFalse: [^ Array with: goodName with: max].

	^nothingFound		"no matches"
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 9/27/2000 14:11'!
namedUrl: urlString
	| projName |
	"Return project if in, else nil"

	"Ted's fix for unreachable projects"

	projName _ (urlString findTokens: '/') last.
	projName _ (Project parseProjectFileName: projName unescapePercents) first.
	^ Project named: projName
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/6/2000 13:55'!
openBlankProjectNamed: projName

	| proj projViewer |

	proj _ Project newMorphicOn: nil.
	proj changeSet name: projName.
	proj world addMorph: (
		TextMorph new 
			beAllFont: ((TextStyle default fontOfSize: 26) emphasized: 1);
			color: Color red;
			contents: 'Welcome to a new project - ',projName
	).
	CurrentProjectRefactoring currentBeParentTo: proj.
	projViewer _ (CurrentProject findProjectView: projName) ifNil: [^proj].
	(projViewer owner isKindOf: SystemWindow) ifTrue: [
			projViewer owner model: proj].
	^ projViewer project: proj! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 10/11/2000 15:42'!
parseProjectFileName: aString
	"It was formerly possible to have periods in projct names and this messed up some parsing methods. Try to handle that more gracefully and allow for a change in scheme at a later time.
	ar 10/11/2000: Switch to a different version encoding scheme. The new scheme is
		baseName.NNN.ext
	where NNN is at least three digits wide and encodes the version in a human readable form.
	Examples:
		Project parseProjectFileName: 'My Project.007.pr'.
		Project parseProjectFileName: 'My.First.Project.042.prj'.
		Project parseProjectFileName: 'My Project.123456.p r o j e c t'.
	The 'dot' is determined on FileDirectory>>dot to compensate for platforms wishing to use something different from a period. Also allows parsing the former encoding of file using Base64 encoded versions of the form
	Project parseProjectFileName: 'aa.bb.cc|AQ.ss'
	"
	| suffix baseName version versionAndSuffix index tokens |
	"answer an array with: 
		1 = basic project name
		2 = version string
		3 = suffix (pr)"

	"First check for the old style versions"
	index _ aString findLast:[:ch| ch = $|].
	index = 0 ifFalse:["Old style version"
		baseName _ aString copyFrom: 1 to: index-1.
		versionAndSuffix _ aString copyFrom: index+1 to: aString size.
		(versionAndSuffix occurrencesOf: $.) = 0 ifTrue: [^ #('no suffix')].
		version _ versionAndSuffix copyUpTo: $..
		suffix _ versionAndSuffix copyFrom: version size+1 to: versionAndSuffix size.
		"Decode Base64 encoded version"
		version isEmpty
			ifTrue:[version _ 0]
			ifFalse:[version _ Base64MimeConverter decodeInteger: version unescapePercents].
		^{baseName. version. suffix}].
	"New style versions"
	tokens _ aString findTokens: FileDirectory dot.
	tokens size < 2 "Not even a single dot"
		ifTrue:[^{aString. 0. ''}].
	tokens size < 3 ifTrue:["Only one dot"
		self flag: #arNote. "We could allow project file names of the form 'project.001' (e.g., no project extension) or '.001.pr' (without a base name) but I don't think its a good idea."
		^{tokens first. 0. tokens last}].
	suffix _ tokens last.
	version _ tokens at: tokens size - 1.
	(version anySatisfy:[:ch| ch isDigit not]) ifTrue:[
		"Non-digit version??? I don't think so..."
		baseName _ aString copyFrom: 1 to: aString size - suffix size - 1.
		^{baseName. 0. suffix}].
	baseName _ aString copyFrom: 1 to: aString size - suffix size - version size - 2.
	version _ version asInteger.
	^{baseName. version. suffix}! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/17/2000 19:11'!
serverDirectoryFromURL: aURLString

	| dir |
	self flag: #bob.		"need to include swikis in this - hacked for now"

	(aURLString findString: '/SuperSwikiProj/') > 0 ifTrue: [
		dir _ SuperSwikiServer new fullPath: (aURLString copyUpToLast: $/).
		^dir
	].

	^ServerDirectory new fullPath: aURLString! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 10/17/2000 19:11'!
serverFileFromURL: aURLString

	| dir |
	self flag: #bob.		"need to include swikis in this - hacked for now"

	(aURLString findString: '/SuperSwikiProj/') > 0 ifTrue: [
		dir _ SuperSwikiServer new fullPath: (aURLString copyUpToLast: $/).
		^dir readOnlyFileNamed: (aURLString findTokens: '/') last
	].
	^ServerFile new fullPath: aURLString! !

!Project class methodsFor: 'squeaklet on server' stamp: 'RAA 8/8/2000 10:42'!
spawnNewProcessIfThisIsUI: suspendedProcess

	self uiProcess == suspendedProcess ifTrue: [
		self spawnNewProcess.
		^true
	].
	^false		"no new process was created"
! !

!Project class methodsFor: 'squeaklet on server' stamp: 'ar 10/11/2000 15:01'!
sweep: aServerDirectory
	| repository list parts ind entry projectName versions |
	"On the server, move all but the three most recent versions of each Squeaklet to a folder called 'older'"
	"Project sweep: ((ServerDirectory serverNamed: 'DaniOnJumbo') clone 
				directory: '/vol0/people/dani/Squeaklets/2.7')"

	"Ensure the 'older' directory"
	(aServerDirectory includesKey: 'older') 
		ifFalse: [aServerDirectory createDirectory: 'older'].
	repository _ aServerDirectory clone directory: aServerDirectory directory, '/older'.

	"Collect each name, and decide on versions"
	list _ aServerDirectory fileNames.
	list class == String ifTrue: [^ self inform: 'server is unavailable'].
	list _ list asSortedCollection asOrderedCollection.
	parts _ list collect: [:en | Project parseProjectFileName: en].
	parts _ parts select: [:en | en third = 'pr'].
	ind _ 1.
	[entry _ list at: ind.
		projectName _ entry first asLowercase.
		versions _ OrderedCollection new.  versions add: entry.
		[(ind _ ind + 1) > list size 
			ifFalse: [(parts at: ind) first asLowercase = projectName 
				ifTrue: [versions add: (parts at: ind).  true]
				ifFalse: [false]]
			ifTrue: [false]] whileTrue.
		aServerDirectory moveYoungest: 3 in: versions to: repository.
		ind > list size] whileFalse.
! !


!Project class methodsFor: 'as yet unclassified' stamp: 'RAA 12/17/2000 12:37'!
rebuildAllProjects
	"Project rebuildAllProjects"

	AllProjects _ nil.
	self allProjects.! !
StandardSystemController subclass: #ProjectController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!

!ProjectController methodsFor: 'control activity' stamp: 'tk 10/26/1999 14:26'!
redButtonActivity
	| index |
	view isCollapsed ifTrue: [^ super redButtonActivity].
	(view insetDisplayBox containsPoint: Sensor cursorPoint)
		ifFalse: [^ super redButtonActivity].
	index _ (PopUpMenu labelArray: #('enter' 'jump to project...') lines: #()) 
		startUpCenteredWithCaption: nil.
	index = 0 ifTrue: [^ self].

	"save size on enter for thumbnail on exit"
	model setViewSize: view insetDisplayBox extent.
	index = 1 ifTrue: [^ model enter: false revert: false saveForRevert: false].
	index = 2 ifTrue: [Project jumpToProject. ^ self].
! !
Notification subclass: #ProjectEntryNotification
	instanceVariableNames: 'projectToEnter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ProjectEntryNotification commentStamp: '<historical>' prior: 0!
I provide a way to override the style of Project entry (which is buried deep in several different methods). My default is a normal full-screen enter.!


!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:55'!
defaultAction

	self resume: projectToEnter enter! !

!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 19:02'!
projectToEnter

	^projectToEnter! !

!ProjectEntryNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:53'!
projectToEnter: aProject

	projectToEnter _ aProject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectEntryNotification class
	instanceVariableNames: ''!

!ProjectEntryNotification class methodsFor: 'as yet unclassified' stamp: 'RAA 6/6/2000 18:56'!
signal: aProject

	| ex |
	ex := self new.
	ex initialContext: thisContext sender.
	ex projectToEnter: aProject.
	^ex signal: 'Entering ',aProject printString! !
Model subclass: #ProjectHistory
	instanceVariableNames: 'mostRecent '
	classVariableNames: 'ChangeCounter CurrentHistory '
	poolDictionaries: ''
	category: 'System-Support'!

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 15:57'!
changed

	ChangeCounter _ (ChangeCounter ifNil: [0]) + 1.
	super changed.! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 20:49'!
cleanUp

	| proj |

	mostRecent _ mostRecent reject: [ :each |
		proj _ each fourth first.
		proj isNil or: [proj world isNil]
	].
	self changed.
! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 20:27'!
forget: aProject

	| newTuple |
	newTuple _ {
		aProject name.
		aProject thumbnail.
		aProject url.
		WeakArray with: aProject.
	}.
	mostRecent _ mostRecent reject: [ :each |
		each fourth first == aProject or: [
			each fourth first isNil & (each first = newTuple first)
		].
	].
	self changed.
	^newTuple! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 15:27'!
initialize

	mostRecent _ OrderedCollection new.
! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 20:29'!
mostRecentCopy

	self cleanUp.
	^mostRecent copy! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 10:11'!
mostRecentNames

	self cleanUp.
	^mostRecent collect: [ :each |
		each first
	].
! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 11:53'!
mostRecentThread

	| projectNames threadName |
	self cleanUp.
	projectNames _ (mostRecent collect: [ :each | {each first} ]) reversed.

	threadName _ FillInTheBlank 
		request: 'Please name this thread.' 
		initialAnswer: 'Recent projects @ ',Time now printString.
	threadName isEmptyOrNil ifTrue: [^nil].
	InternalThreadNavigationMorph know: projectNames as: threadName.
	^threadName
! !

!ProjectHistory methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:17'!
remember: aProject

	| newTuple |

	newTuple _ self forget: aProject.
	mostRecent addFirst: newTuple.
	mostRecent size > 10 ifTrue: [mostRecent _ mostRecent copyFrom: 1 to: 10].
	self changed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectHistory class
	instanceVariableNames: ''!

!ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 15:56'!
changeCounter

	^ChangeCounter ifNil: [ChangeCounter _ 0].! !

!ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 15:27'!
currentHistory

	^CurrentHistory ifNil: [CurrentHistory _ self new initialize].! !

!ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'RAA 7/12/2000 10:16'!
forget: aProject

	self currentHistory forget: aProject
! !

!ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 15:31'!
remember: aProject

	self currentHistory remember: aProject
! !
Object subclass: #ProjectLoading
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectLoading class
	instanceVariableNames: ''!

!ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:39'!
installRemoteNamed: remoteFileName from: aServer named: otherProjectName in: currentProject

	"Find the current ProjectViewMorph, fetch the project, install in ProjectViewMorph without changing size, and jump into new project."

	ProgressNotification signal: '1:foundMostRecent'.
	^self 
		openFromFile: (aServer oldFileNamed: remoteFileName) 
		fromDirectory: aServer 
		withProjectView: (currentProject findProjectView: otherProjectName).
! !

!ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:56'!
openFromDirectory: aDirectory andFileName: aFileName

	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			ProjectLoading 
				openFromFile: (aDirectory oldFileNamed: aFileName) 
				fromDirectory: aDirectory
				withProjectView: nil.
		]! !

!ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 1/17/2001 17:26'!
openFromFile: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView
	"Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world."
 	| morphOrList proj |

	ProgressNotification signal: '2:fileSizeDetermined ',preStream size printString.
	morphOrList _ preStream asUnZippedStream.
	preStream sleep.		"if ftp, let the connection close"
	ProgressNotification  signal: '3:unzipped'.
	morphOrList _ morphOrList fileInObjectAndCode.
	ProgressNotification  signal: '4:filedIn'.
	ProgressNotification  signal: '9999 about to enter project'.		"the hard part is over"
	(morphOrList isKindOf: ImageSegment) ifTrue: [
		proj _ morphOrList arrayOfRoots 
			detect: [:mm | mm class == Project] 
			ifNone: [^self inform: 'No project found in this file'].
		proj versionFrom: preStream.
		proj lastDirectory: aDirectoryOrNil.
		CurrentProjectRefactoring currentBeParentTo: proj.
		existingView ifNil: [
			Smalltalk isMorphic ifTrue: [
				proj createViewIfAppropriate.
			] ifFalse: [
				ProjectView openAndEnter: proj.
				"Note: in MVC we get no further than the above"
			].
		] ifNotNil: [
			(existingView project isKindOf: DiskProxy) ifFalse: [
				existingView project changeSet name: ChangeSet defaultName
			].
			"proj changeSet name: otherProjectName."	"<<< why would we need this?"
			(existingView owner isKindOf: SystemWindow) ifTrue: [
				existingView owner model: proj
			].
			existingView project: proj.
		].
		^ ProjectEntryNotification signal: proj
	].

	(morphOrList isKindOf: SqueakPage) ifTrue: [
		morphOrList _ morphOrList contentsMorph
	].
	(morphOrList isKindOf: PasteUpMorph) ifFalse: [
		^ self inform: 'This is not a PasteUpMorph or exported Project.'
	].
	(Project newMorphicOn: morphOrList) enter

! !

!ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:56'!
thumbnailFromUrl: urlString

	| fileStream |
	"Load the project, and make a thumbnail to it in the current project.
Project thumbnailFromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/SqueakEasy.extSeg'.
"

	Project canWeLoadAProjectNow ifFalse: [^ self].
	ComplexProgressIndicator new 
		targetMorph: nil;
		historyCategory: 'project loading';
		withProgressDo: [
			fileStream _ (Project serverFileFromURL: urlString) asStream.
			ProjectLoading
				openFromFile: fileStream
				fromDirectory: nil
				withProjectView: nil.
		]

! !
AlignmentMorphBob1 subclass: #ProjectNavigationMorph
	instanceVariableNames: 'mouseInside '
	classVariableNames: 'LastManualPlacement '
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:19'!
addButtons

	self orientedVertically ifTrue: [
		self addAColumn: (
			self makeTheButtons collect: [ :x | self inAColumn: {x}]
		)
	] ifFalse: [
		self addARow: (
			self makeTheButtons collect: [ :x | self inAColumn: {x}]
		)
	].
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:15'!
addCustomMenuItems: aMenu hand: aHandMorph

	"Add further items to the menu as appropriate"

	super addCustomMenuItems: aMenu hand: aHandMorph.
	aMenu 
		addUpdating: #orientationString 
		action: #toggleOrientation.
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/27/2000 17:54'!
amountToShowWhenSmall

	^7	"if no part of the buttons is visible, we chew up fewer cycles"! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/5/2000 16:24'!
color: newColor

	| buttonColor |

	super color: newColor.
	buttonColor _ color darker.
	self submorphsDo: [:m | m submorphsDo: [:n | n color: buttonColor]]! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 18:51'!
colorForButtons

	^color darker! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 07:45'!
currentNavigatorVersion

	^18		"since these guys get saved, we fix them up if they are older versions"! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/26/2000 18:52'!
fontForButtons

	^TextStyle defaultFont! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:11'!
handlesMouseOver: evt

	^true! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/16/2000 08:26'!
inFlapsSuppressedMode

	^(self valueOfProperty: #flapsSuppressedMode) == true! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 00:03'!
inFullScreenMode

	^(self valueOfProperty: #showingFullScreenMode) == true! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/8/2000 11:28'!
initialColor

	^Color orange
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:42'!
initialize

	super initialize.
	self useRoundedCorners.
	self layoutInset: 6.
	color _ Color orange.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	mouseInside _ false.

	self addButtons.
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 07:47'!
justDroppedInto: aMorph event: anEvent

	self setProperty: #stickToTop toValue: nil.
	self positionVertically.
	LastManualPlacement _ {self position. self valueOfProperty: #stickToTop}.
	super justDroppedInto: aMorph event: anEvent.
	self step! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/20/2000 12:28'!
makeButton: aString balloonText: anotherString for: aSymbol

	^SimpleButtonDelayedMenuMorph new 
		target: self;
		borderColor: #raised;
		color: self colorForButtons;
		label: aString font: self fontForButtons;
		setBalloonText: anotherString;
		actionSelector: aSymbol.

! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 07:28'!
makeTheButtons

	^{
		self buttonPrev.
		self buttonNext.
		self buttonPublish.
		self buttonNewer.
		self buttonTell.
		self buttonFind.
		self buttonFullScreen.
		self buttonFlaps.
		self buttonShare.
		self buttonPaint.
	}
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 09:24'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^mouseInside == true ifTrue: [26] ifFalse: [25]

		"Navigators are behind menus and balloons, but in front of most other stuff"! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/30/2000 13:57'!
mouseEnter: evt

	(self worldBounds containsPoint: evt cursorPoint) ifFalse: [^self].
	mouseInside _ true.
	self positionVertically.
	! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/1/2000 07:51'!
mouseLeave: evt

	self world ifNil: [^self].		"can happen after delete from control menu"
	(self worldBounds containsPoint: evt cursorPoint) ifFalse: [^self].
	mouseInside _ false.
	self positionVertically.
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/15/2000 21:43'!
openInWorld: aWorld

	LastManualPlacement ifNotNil: [
		self position: LastManualPlacement first.
		self setProperty: #stickToTop toValue: LastManualPlacement second.
	].
	super openInWorld: aWorld.! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:21'!
orientationString 

	^ self orientedVertically
		ifTrue:	['<yes>vertical orientation']
		ifFalse:	['<no>vertical orientation']! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:18'!
orientedVertically

	^self valueOfProperty: #orientedVertically ifAbsent: [false]
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:26'!
positionVertically

	| wb stickToTop |

	owner == self world ifFalse: [^self].
	wb _ self worldBounds.
	stickToTop _ self valueOfProperty: #stickToTop.
	stickToTop ifNil: [
		stickToTop _ (self top - wb top) abs < (self bottom - wb bottom) abs.
		self setProperty: #stickToTop toValue: stickToTop.
	].
	mouseInside == true ifTrue: [
		stickToTop ifTrue: [
			self top: wb top
		] ifFalse: [
			self bottom: wb bottom
		].
	] ifFalse: [
		stickToTop ifTrue: [
			self bottom: wb top + self amountToShowWhenSmall
		] ifFalse: [
			self top: wb bottom - self amountToShowWhenSmall
		].
	].

! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/2000 19:32'!
showMenuFor: aSymbol event: evt

	aSymbol == #publishProject ifTrue: [
		self doPublishButtonMenuEvent: evt.
		^true		"we did show the menu"
	].
	aSymbol == #findAProject ifTrue: [
		self doFindButtonMenuEvent: evt.
		^true		"we did show the menu"
	].
	^false
! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:26'!
step
	| wb lastScreenMode flapsSuppressed |

	owner ifNil: [^ self].
	(self ownerThatIsA: HandMorph) ifNotNil: [^self].
	lastScreenMode _ ScreenController lastScreenModeSelected ifNil: [false].
	flapsSuppressed _ CurrentProjectRefactoring currentFlapsSuppressed.
	((self valueOfProperty: #currentNavigatorVersion) = self currentNavigatorVersion
			and: [lastScreenMode = self inFullScreenMode
			and: [flapsSuppressed = self inFlapsSuppressedMode]]) ifFalse: [
		self setProperty: #flapsSuppressedMode toValue: flapsSuppressed.
		self setProperty: #showingFullScreenMode toValue: lastScreenMode.
		self setProperty: #currentNavigatorVersion toValue: self currentNavigatorVersion.
		self removeAllMorphs.
		self addButtons.
	].
	owner == self world ifTrue: [
		owner addMorphInLayer: self.
		wb _ self worldBounds.
		self left < wb left ifTrue: [self left: wb left].
		self right > wb right ifTrue: [self right: wb right].
		self positionVertically.
	].! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/18/2000 11:43'!
stepTime

	^1000! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 1/9/2001 08:18'!
toggleOrientation

	self setProperty: #orientedVertically toValue: self orientedVertically not.
	self setProperty: #currentNavigatorVersion toValue: self currentNavigatorVersion - 1.

! !

!ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/18/2000 11:43'!
wantsSteps

	^true! !


!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/20/2000 12:40'!
buttonFind

	^self makeButton: 'FIND' balloonText: 'Find a project' for: #findAProject
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:42'!
buttonFlaps

	^self inFlapsSuppressedMode ifTrue: [
		self makeButton: 'Show tabs' balloonText: 'Show tabs' for: #toggleFlapsSuppressed
	] ifFalse: [
		self makeButton: 'Hide tabs' balloonText: 'Hide tabs' for: #toggleFlapsSuppressed
	].

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:41'!
buttonFullScreen

	^self inFullScreenMode ifTrue: [
		self makeButton: 'Browser Reentry' balloonText: 'Re-enter the browser' for: #fullScreenOff
	] ifFalse: [
		self makeButton: 'Escape Browser' balloonText: 'Use the full screen' for: #fullScreenOn
	]

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:53'!
buttonGoTo

	^self makeButton: 'GO TO' balloonText: 'Go to another project' for: #gotoAnother
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:54'!
buttonNewProject

	^self makeButton: 'NEW PROJECT' balloonText: 'Start a new project' for: #newProject
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:37'!
buttonNewer

	^self makeButton: 'Newer?' balloonText: 'Is there a newer version of this project ?' for: #getNewerVersionIfAvailable! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:04'!
buttonNext

	^self makeButton: 'NEXT >' balloonText: 'Next project' for: #nextProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 11/8/2000 09:53'!
buttonPaint

	| pb oldArgs brush myButton m |

	myButton _ self makeButton: '' balloonText: 'Make a painting' for: #doNewPainting.
	pb _ PaintBoxMorph new submorphNamed: #paint:.
	pb ifNil: [
		(brush _ Form extent: 16@16 depth: 16) fillColor: Color red
	] ifNotNil: [
		oldArgs _ pb arguments.
		brush _ oldArgs third.
		brush _ brush copy: (2@0 extent: 42@38).
		brush _ brush scaledToSize: brush extent // 2.
	].
	myButton addMorph: (m _ brush asMorph lock).
	myButton extent: m extent + (myButton borderWidth + 6).
	m position: myButton center - (m extent // 2).

	^myButton

"brush _ (ScriptingSystem formAtKey: 'Painting')."

! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:04'!
buttonPrev

	^self makeButton: '< PREV' balloonText: 'Previous project' for: #previousProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/20/2000 12:41'!
buttonPublish

	^self makeButton: 'PUBLISH IT!!' balloonText: 'Publish this project. Save it where it came from (server, hard disk, etc.) ' for: #publishProject! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 14:03'!
buttonQuit

	^self makeButton: 'QUIT' balloonText: 'Quit Squeak altogether' for: #quitSqueak
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:43'!
buttonShare

	^self makeButton: 'Share' 
		balloonText: 'Share this project so that others can explore it with you.' 
		for: #shareThisWorld
! !

!ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 9/19/2000 13:38'!
buttonTell

	^self makeButton: 'Tell!!' balloonText: 'Tell a friend about this project' for: #tellAFriend
! !


!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/18/2000 12:30'!
doFindButtonMenuEvent: evt

	| menu selection |

	menu _ CustomMenu new.
	menu 
		add: 'find a project' action: [self findAProject];
		add: 'find any file' action: [self findAnything];
		add: 'search the SuperSwiki' action: [self findSomethingOnSuperSwiki].

	selection _ menu build startUpCenteredWithCaption: 'Find options'.
	selection ifNil: [^self].
	selection value.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 11/9/2000 12:44'!
doNewPainting
	
	| w |

	w _ self world.
	w assureNotPaintingElse: [^ self].
	w makeNewDrawing: (self primaryHand lastEvent copy setPosition: w center)! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 12/24/2000 09:30'!
doPublishButtonMenuEvent: evt

	| menu selection |

	menu _ CustomMenu new.
	menu 
		add: 'publish normally' action: [self publishProject];
		add: 'publish to different server' action: [self publishDifferent];
		add: 'edit project info' action: [self editProjectInfo].
	selection _ menu build startUpCenteredWithCaption: 'Publish options'.
	selection ifNil: [^self].
	selection value.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 12/24/2000 09:33'!
editProjectInfo

	EToyProjectDetailsMorph 
		getFullInfoFor: (self world ifNil: [^self]) project
		ifValid: []
		expandedFormat: true
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 7/13/2000 14:32'!
findAProject

	FileList2 morphicViewProjectLoader2InWorld: self world! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 7/24/2000 19:32'!
findAnything

	FileList2 morphicViewGeneralLoaderInWorld: self world! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/18/2000 12:29'!
findSomethingOnSuperSwiki

	EToyProjectQueryMorph test1: nil! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 8/30/2000 15:32'!
fullScreenOff

	self setProperty: #showingFullScreenMode toValue: false.
	ScreenController new fullScreenOff.
	self removeProperty: #currentNavigatorVersion.
	mouseInside _ false.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 8/30/2000 15:32'!
fullScreenOn

	self setProperty: #showingFullScreenMode toValue: true.
	ScreenController new fullScreenOn.
	self removeProperty: #currentNavigatorVersion.
	mouseInside _ false.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 5/17/2000 18:57'!
getNewerVersionIfAvailable

	(self world ifNil: [^1 beep]) project loadFromServer: true.

! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 9/19/2000 14:12'!
gotoAnother

	EToyProjectHistoryMorph new openInWorld! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/6/2000 13:55'!
newProject

	Project newMorphicOn: nil
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 5/17/2000 18:57'!
nextProject

	Project advanceToNextProject.
	1 beep.! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 6/3/2000 09:45'!
previousProject

	Project returnToPreviousProject.
	CurrentProjectRefactoring exitCurrentProject.	"go to parent if no previous"
	1 beep.! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/19/2000 14:00'!
publishDifferent

	(self world ifNil: [^1 beep]) project storeOnServerShowProgressOn: self forgetURL: true.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 10/19/2000 14:00'!
publishProject

	(self world ifNil: [^1 beep]) project storeOnServerShowProgressOn: self forgetURL: false.
! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 9/19/2000 14:14'!
quitSqueak

	(self confirm: 'REALLY quit Squeak?') ifFalse: [^self].
	Smalltalk snapshot: false andQuit: true.! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 8/4/2000 15:24'!
shareThisWorld

	NebraskaServerMorph serveWorld: self world! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 6/3/2000 10:54'!
tellAFriend

	self world project tellAFriend! !

!ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 7/16/2000 08:31'!
toggleFlapsSuppressed

	CurrentProjectRefactoring currentToggleFlapsSuppressed! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectNavigationMorph class
	instanceVariableNames: ''!

!ProjectNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 14:16'!
preferredNavigator

	Preferences eToyFriendly ifTrue: [^KidNavigationMorph].
	^ProjectNavigationMorph! !
StandardSystemView subclass: #ProjectView
	instanceVariableNames: ''
	classVariableNames: 'ArmsLengthCmd '
	poolDictionaries: ''
	category: 'ST80-Support'!

!ProjectView methodsFor: 'initialization'!
defaultControllerClass
	^ ProjectController! !

!ProjectView methodsFor: 'initialization' stamp: 'sw 8/4/1998 19:15'!
maybeRelabel: newLabel
	"If the change set name given by newLabel is already in use, do nothing; else relabel the view"

	(newLabel isEmpty or: [newLabel = self label])
		ifTrue: [^ self].
	(ChangeSorter changeSetNamed: newLabel) == nil
		ifFalse: [^ self].
	self relabel: newLabel! !

!ProjectView methodsFor: 'initialization' stamp: 'di 5/6/1998 17:03'!
relabel: newLabel
	(newLabel isEmpty or: [newLabel = self label])
		ifTrue: [^ self].
	(ChangeSorter changeSetNamed: newLabel) == nil
		ifFalse: [self inform: 'Sorry that name is already used'.
				^ self].
	model projectChangeSet name: newLabel.
	super relabel: newLabel! !

!ProjectView methodsFor: 'initialization' stamp: 'sw 1/11/2000 15:30'!
uncacheBits
	super uncacheBits.
	self label ~=  model name ifTrue: [self setLabelTo: model name]! !


!ProjectView methodsFor: 'displaying' stamp: 'tk 4/19/2000 17:15'!
armsLengthCommand: aCommand
	"Set up a save to be done after the subproject exits to here.  displayOn: checks it."

	ArmsLengthCmd _ aCommand.! !

!ProjectView methodsFor: 'displaying'!
cacheBitsAsTwoTone
	^ false! !

!ProjectView methodsFor: 'displaying' stamp: 'tk 6/21/2000 16:22'!
displayDeEmphasized
	| cmd |
	"Display this view with emphasis off.  Check for a command that
could not be executed in my subproject.  Once it is done, remove the
trigger."

	super displayDeEmphasized.
	ArmsLengthCmd ifNil: [^ self].
	ArmsLengthCmd first == model ifFalse: [^ self].	"not ours"
	cmd _ ArmsLengthCmd second.
	ArmsLengthCmd _ nil.
	model "project" perform: cmd.
	model "project" enter.
! !

!ProjectView methodsFor: 'displaying' stamp: 'sw 1/11/2000 15:32'!
displayView
	super displayView.
	self label = model name
		ifFalse: [self setLabelTo: model name].
	self isCollapsed ifTrue: [^ self].
	model thumbnail ifNil: [^ self].
	self insetDisplayBox extent = model thumbnail extent
		ifTrue: [model thumbnail displayAt: self insetDisplayBox topLeft]
		ifFalse: [(model thumbnail
					magnify: model thumbnail boundingBox
					by: self insetDisplayBox extent asFloatPoint / model thumbnail extent) 				displayAt: self insetDisplayBox topLeft]
! !

!ProjectView methodsFor: 'displaying' stamp: 'sw 9/14/1998 13:01'!
release
	super release.
	Smalltalk garbageCollect! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectView class
	instanceVariableNames: ''!

!ProjectView class methodsFor: 'as yet unclassified'!
open: aProject 
	"Answer an instance of me for the argument, aProject. It is created on the
	display screen."
	| topView |
	topView _ self new model: aProject.
	topView minimumSize: 50 @ 30.
	topView borderWidth: 2.
	topView controller open! !

!ProjectView class methodsFor: 'as yet unclassified' stamp: 'RAA 7/25/2000 10:35'!
openAndEnter: aProject 
	"Answer an instance of me for the argument, aProject. It is created on 
	the display screen."
	| topView |
	topView _ self new model: aProject.
	topView minimumSize: 50 @ 30.
	topView borderWidth: 2.
	topView window: (RealEstateAgent initialFrameFor: topView world: nil).
	ScheduledControllers schedulePassive: topView controller.
	aProject
		enter: false
		revert: false
		saveForRevert: false! !
ImageMorph subclass: #ProjectViewMorph
	instanceVariableNames: 'project lastProjectThumbnail mouseDownTime '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ProjectViewMorph commentStamp: '<historical>' prior: 0!
I am a Morphic view of a project. I display a scaled version of the project's thumbnail, which itself is a scaled-down snapshot of the screen taken when the project was last exited. When I am displayed, I check to see if the project thumbnail has changed and, if so, I update my own view of that thumbnail.
!


!ProjectViewMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 08:56'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
project _ deepCopier references at: project ifAbsent: [project].
lastProjectThumbnail _ deepCopier references at: lastProjectThumbnail 
				ifAbsent: [lastProjectThumbnail].
! !

!ProjectViewMorph methodsFor: 'copying' stamp: 'RAA 1/26/2001 09:15'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	project _ project.		"Weakly copied"
	lastProjectThumbnail _ lastProjectThumbnail veryDeepCopyWith: deepCopier.
	mouseDownTime _ nil.! !


!ProjectViewMorph methodsFor: 'drawing' stamp: 'jm 5/14/1998 15:47'!
borderWidth: ignored
	"Sent by SystemWindow, but ignored here."
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:10'!
colorAroundName

	^Color gray: 0.8! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/1/2000 22:49'!
drawOn: aCanvas

	| font projectName nameForm rectForName |

	self ensureImageReady.
	super drawOn: aCanvas.
	self isEditingName ifTrue: [^self].

	font _ self fontForName.
	projectName _ self safeProjectName.
	nameForm _ (StringMorph contents: projectName font: font) imageForm.
	nameForm _ nameForm scaledToSize: (self extent - (4@2) min: nameForm extent).
	rectForName _ self bottomLeft + 
			(self width - nameForm width // 2 @ (nameForm height + 2) negated)
				extent: nameForm extent.
	rectForName topLeft eightNeighbors do: [ :pt |
		aCanvas
			stencil: nameForm 
			at: pt
			color: self colorAroundName.
	].
	aCanvas
		stencil: nameForm 
		at: rectForName topLeft 
		color: Color black.


	
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:39'!
ensureImageReady

	self isTheRealProjectPresent ifFalse: [^self].
	project thumbnail ifNil: [
		image fill: image boundingBox rule: Form over 
			fillColor: project defaultBackgroundColor.
		^self
	].
	project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds"
		lastProjectThumbnail _ project thumbnail.
		self updateImageFrom: lastProjectThumbnail.
		image borderWidth: 1
	].


! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 8/30/2000 19:11'!
fontForName

	| pickem |
	pickem _ 3.

	pickem = 1 ifTrue: [
		^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1.
	].
	pickem = 2 ifTrue: [
		^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1.
	].
	^((TextStyle default) fontAt: 1) emphasized: 1
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/1/2000 22:45'!
isEditingName

	| nameMorph |
	nameMorph _ self findA: UpdatingStringMorph.
	nameMorph ifNil: [^false].

	^nameMorph hasFocus
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:38'!
isTheRealProjectPresent

	project ifNil: [^ false].
	project isInMemory ifFalse: [^ false].
	project class == DiskProxy ifTrue: [^ false].
	^true
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:39'!
safeProjectName

	| projectName |
	projectName _ self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
	self isTheRealProjectPresent ifFalse: [^ projectName].
	self setProperty: #SafeProjectName toValue: project name.
	^project name
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:39'!
safeProjectName: aString

	self addProjectNameMorphFiller.
	self isTheRealProjectPresent ifFalse: [^ self].

	aString = project name ifFalse: [project changeSet name: aString].
	self setProperty: #SafeProjectName toValue: project name.
	self updateNamePosition.
	(owner isKindOf: SystemWindow) ifTrue: [owner setLabel: aString].! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 1/26/2001 09:14'!
showBorderAs: aColor

	"image border: image boundingBox width: 1 fillColor: aColor.
	currentBorderColor _ aColor.
	self changed"
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 10/27/2000 10:50'!
updateImageFrom: sourceForm

	(WarpBlt current toForm: image)
		sourceForm: sourceForm;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over;
		copyQuad: (sourceForm boundingBox) innerCorners
		toRect: image boundingBox.
! !

!ProjectViewMorph methodsFor: 'drawing' stamp: 'RAA 11/2/2000 10:11'!
updateNamePosition

	| nameMorph shadowMorph nameFillerMorph |

	(nameMorph _ self findA: UpdatingStringMorph) ifNotNil: [
		nameMorph position:
			(self left + (self width - nameMorph width // 2)) @
			(self bottom - nameMorph height - 2).
	].
	(nameFillerMorph _ self findA: AlignmentMorph) ifNotNil: [
		nameFillerMorph
			position: self bottomLeft - (0@20);
			extent: self width@20.
	].
	(shadowMorph _ self findA: ImageMorph) ifNotNil: [
		shadowMorph delete	"no longer used"
	].

! !


!ProjectViewMorph methodsFor: 'events' stamp: 'tk 12/9/1999 08:03'!
abandon
	"Home ViewMorph of project is going away."

	project _ nil.
	super abandon.

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:39'!
acceptDroppingMorph: morphToDrop event: evt

	| myCopy smallR |

	(self isTheRealProjectPresent) ifFalse: [
		^morphToDrop rejectDropMorphEvent: evt.		"can't handle it right now"
	].
	(morphToDrop isKindOf: NewHandleMorph) ifTrue: [	"don't send these"
		^morphToDrop rejectDropMorphEvent: evt.
	].
	self eToyRejectDropMorph: morphToDrop event: evt.		"we will send a copy"
	myCopy _ morphToDrop veryDeepCopy.	"gradient fills require doing this second"
	smallR _ (morphToDrop bounds scaleBy: image height / Display height) rounded.
	smallR _ smallR squishedWithin: image boundingBox.
	image getCanvas
		paintImage: (morphToDrop imageForm scaledToSize: smallR extent)
		at: smallR topLeft.
	myCopy openInWorld: project world

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:34'!
balloonText
	^ 'Click here to enter the
project named
"', project name, '"'! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/17/2000 11:39'!
checkForNewerVersionAndLoad

	self withProgressDo: [
		project loadFromServer
	] 

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/13/2000 17:06'!
deletingProject: aProject
	"My project is being deleted.  Delete me as well."

	self flag: #bob.		"zapping projects"


	project == aProject ifTrue: [self delete].! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/21/2000 12:33'!
enter
	"Enter my project."
	self world == self outermostWorldMorph ifFalse: [^1 beep]. "can't do this at the moment"
	project class == DiskProxy ifFalse: [
		(project world notNil and: [project world isMorph and:
				[project world outermostWorldMorph == self outermostWorldMorph]]) ifTrue: [
			^1 beep		"project is open in a window already"
		].
	].

	project class == DiskProxy ifTrue: ["When target is not in yet"
		self enterWhenNotPresent.	"will bring it in"
		project class == DiskProxy ifTrue: [^self inform: 'Project not found']].
	(owner isKindOf: SystemWindow)
		ifTrue: [project setViewSize: self extent].
	self showMouseState: 3.
	project enter: false revert: false saveForRevert: false.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/16/2000 14:13'!
enterAsActiveSubproject
	"Enter my project."

	project class == DiskProxy ifTrue: ["When target is not in yet"
		[self enterWhenNotPresent]	"will bring it in"
			on: ProjectEntryNotification
			do: [ :ex | 
				^ex projectToEnter enterAsActiveSubprojectWithin: self world
			].
		project class == DiskProxy ifTrue: [self error: 'Could not find view']].
	(owner isKindOf: SystemWindow)
		ifTrue: [project setViewSize: self extent].
	self showMouseState: 3.
	project enterAsActiveSubprojectWithin: self world.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/17/2000 11:38'!
enterWhenNotPresent

	self withProgressDo: [
		project enter: false revert: false saveForRevert: false.	"will bring it in"
	] 

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 10/27/2000 11:08'!
extent: aPoint
	"Set my image form to the given extent."

	| newExtent scaleP scale |

	((bounds extent = aPoint) and: [image depth = Display depth]) ifFalse: [
		lastProjectThumbnail ifNil: [ lastProjectThumbnail _ image ].
		scaleP _ aPoint / lastProjectThumbnail extent.
		scale _ scaleP "scaleP x asFloat max: scaleP y asFloat".
		newExtent _ (lastProjectThumbnail extent * scale) rounded.
		self image: (Form extent: newExtent depth: Display depth).
		self updateImageFrom: lastProjectThumbnail.
	].
	self updateNamePosition.! !

!ProjectViewMorph methodsFor: 'events' stamp: 'jm 5/4/1998 22:13'!
handlesMouseDown: evt

	^ true
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:41'!
handlesMouseOver: evt
	^ true! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:03'!
handlesMouseOverDragging: evt

	^ true! !

!ProjectViewMorph methodsFor: 'events' stamp: 'ar 10/25/2000 17:37'!
handlesMouseStillDown: evt
	^true! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:14'!
initialize
	super initialize.
	"currentBorderColor _ Color gray."
	self addProjectNameMorphFiller.! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/12/2000 07:44'!
lastProjectThumbnail: aForm
	
	lastProjectThumbnail _ aForm! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:03'!
mouseDown: evt

	"Smalltalk at: #Q put: OrderedCollection new"
	"Q add: {Time millisecondClockValue / 1000.0. self. evt hand mouseFocus. thisContext longStack}."

	evt hand newMouseFocus: self.
	self removeProperty: #wasOpenedAsSubproject.
	self showMouseState: 2.
	mouseDownTime _ Time millisecondClockValue! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/16/2000 14:14'!
mouseEnter: evt

	self showMouseState: 1! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/16/2000 14:13'!
mouseLeave: evt

	self showMouseState: 3.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:03'!
mouseLeaveDragging: evt

	self mouseLeave: evt

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:16'!
mouseStillDown: evt

	(self containsPoint: evt cursorPoint) ifFalse: [
		self showMouseState: 3.
		mouseDownTime _ nil.
		^self
	].
	self showMouseState: 2.
	mouseDownTime ifNil: [
		mouseDownTime _ Time millisecondClockValue.
		^self
	].
	((Time millisecondClockValue - mouseDownTime) > 1100) ifFalse: [^self].
				
	self showMenuForProjectView.

					! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 7/16/2000 14:13'!
mouseUp: evt

	((self containsPoint: evt cursorPoint) and: 
				[(self hasProperty: #wasOpenedAsSubproject) not]) ifTrue:
		[^ self enter].
	self showMouseState: 3.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'!
on: aProject

	project _ aProject.
	self addProjectNameMorphFiller.
	lastProjectThumbnail _ nil.
	project thumbnail
		ifNil: [self extent: 100@80]		"more like screen dimensions?"
		ifNotNil: [self extent: project thumbnail extent].
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 11/2/2000 10:06'!
project: aProject

	project _ aProject.
	self addProjectNameMorphFiller.! !

!ProjectViewMorph methodsFor: 'events' stamp: 'raa 11/2/2000 10:29'!
seeIfNameChanged

	| nameBefore nameNow |

	nameBefore _ self valueOfProperty: #SafeProjectName ifAbsent: ['???'].
	nameNow _ self safeProjectName.
	(submorphs notEmpty and: [nameBefore = nameNow]) ifTrue: [^self].
	self addProjectNameMorphFiller.
! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 10/19/2000 14:00'!
showMenuForProjectView
	| menu selection |
	(menu _ CustomMenu new)
		add: 'enter this project'
		action: [^ self enter];
		
		add: 'ENTER ACTIVE'
		action: [self setProperty: #wasOpenedAsSubproject toValue: true.
			^ self enterAsActiveSubproject];
		
		add: 'PUBLISH (also saves a local copy)'
		action: [^ project storeOnServerShowProgressOn: self forgetURL: false];
		
		add: 'PUBLISH to a different server'
		action: [project forgetExistingURL.
			^ project storeOnServerShowProgressOn: self forgetURL: true];
		
		add: 'see if server version is more recent'
		action: [^ self checkForNewerVersionAndLoad].
	selection _ menu build startUpCenteredWithCaption: 'Project Named
' , '"' , project name , '"'.
	selection
		ifNil: [^ self].
	selection value! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 1/26/2001 09:16'!
showMouseState: anInteger

	anInteger = 1 ifTrue: [		"enter"
		self addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3).
		"self showBorderAs: Color blue"
	].

	anInteger = 2 ifTrue: [		"down"
		self addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7).
		"self showBorderAs: Color red."
	].

	anInteger = 3 ifTrue: [		"leave"
		self deleteAnyMouseActionIndicators.
		"self showBorderAs: Color gray"
	].

! !

!ProjectViewMorph methodsFor: 'events' stamp: 'raa 11/2/2000 10:20'!
step
	| cmd |
	"Check for a command that could not be executed in my subproject.  Once it is done, remove the trigger.  If this is too slow, make armsLengthCmd an inst var."

	self seeIfNameChanged.
	cmd _ self valueOfProperty: #armsLengthCmd.
	cmd ifNil: [^ super step].
	self removeProperty: #armsLengthCmd.
	project perform: cmd.
	project enter.! !

!ProjectViewMorph methodsFor: 'events' stamp: 'raa 11/2/2000 10:21'!
stepTime

	^1000! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 12/12/2000 10:08'!
triggerActionFromPianoRoll

	WorldState addDeferredUIMessage: [
		project world setProperty: #letTheMusicPlay toValue: true.
		self enter.
	]! !

!ProjectViewMorph methodsFor: 'events' stamp: 'RAA 5/23/2000 10:08'!
withProgressDo: aBlock

	ComplexProgressIndicator new 
		targetMorph: self;
		historyCategory: 'project loading';
		withProgressDo: aBlock
! !


!ProjectViewMorph methodsFor: 'fileIn/out' stamp: 'RAA 7/10/2000 23:30'!
eToyStreamedRepresentationNotifying: aWidget

	| safeVariant outData |

	self flag: #bob.		"probably irrelevant"
	safeVariant _ self copy.
	[ outData _ SmartRefStream streamedRepresentationOf: safeVariant ] 
		on: ProgressInitiationException
		do: [ :ex | 
			ex sendNotificationsTo: [ :min :max :curr |
				aWidget ifNotNil: [aWidget flashIndicator: #working].
			].
		].
	^outData
! !

!ProjectViewMorph methodsFor: 'fileIn/out' stamp: 'RAA 10/27/2000 11:08'!
objectForDataStream: refStrm
	
	| copy |

	1 = 1 ifTrue: [^self].		"this didn't really work"

	copy _ self copy lastProjectThumbnail: nil.
	"refStrm replace: self with: copy."
	^copy
! !

!ProjectViewMorph methodsFor: 'fileIn/out' stamp: 'RAA 10/27/2000 10:55'!
releaseCachedState

	"see if we can reduce size of published file, but there may be problems"
	super releaseCachedState.
	lastProjectThumbnail _ image.
! !

!ProjectViewMorph methodsFor: 'fileIn/out' stamp: 'tk 9/8/1999 17:51'!
storeSegment
	"Store my project out on the disk as an ImageSegment.  Keep the outPointers in memory.  Name it <project name>.seg"

	project storeSegment
! !


!ProjectViewMorph methodsFor: 'accessing' stamp: 'tk 8/30/1999 11:48'!
project
	^project! !


!ProjectViewMorph methodsFor: 'object fileIn' stamp: 'RAA 1/26/2001 09:14'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"currentBorderColor ifNil: [currentBorderColor _ Color gray]."

	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 09:56'!
addProjectNameMorph

	| m |

	self removeAllMorphs.
	m _ UpdatingStringMorph contents: self safeProjectName font: self fontForName.
	m target: self; getSelector: #safeProjectName; putSelector: #safeProjectName:.
	m useStringFormat; fitContents.
	self addMorphBack: m.
	self updateNamePosition.
	^m

! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:12'!
addProjectNameMorphFiller

	| m |

	self removeAllMorphs.
	m _ AlignmentMorph newRow color: Color transparent.
	self addMorphBack: m.
	m
		on: #mouseDown send: #editTheName: to: self;
		on: #mouseUp send: #yourself to: self.
	self updateNamePosition.

! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:41'!
editTheName: evt

	self isTheRealProjectPresent ifFalse: [
		^self inform: 'The project is not present and may not be renamed now'
	].
	self addProjectNameMorph launchMiniEditor: evt.! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/2/2000 10:40'!
wantsDroppedMorph: aMorph event: evt

	self isTheRealProjectPresent ifFalse: [^false].
	project isMorphic ifFalse: [^false].
	project world viewBox ifNil: [^false].		"uninitialized"
	^true! !

!ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/20/2000 10:12'!
wantsKeyboardFocusFor: aSubmorph

	^true! !


!ProjectViewMorph methodsFor: 'rounding' stamp: 'ar 9/1/2000 13:50'!
wantsRoundedCorners
	^(Preferences roundedWindowCorners and: [(owner isKindOf: SystemWindow) not])! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProjectViewMorph class
	instanceVariableNames: ''!

!ProjectViewMorph class methodsFor: 'instance creation' stamp: 'jm 5/14/1998 16:19'!
on: aProject

	^ self new on: aProject
! !


!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'di 11/26/1999 10:45'!
newMVCProject
	"Create an instance of me on a new MVC project (in a SystemWindow)."

	| proj window |
	proj _ Project new.
	window _ (SystemWindow labelled: proj name) model: proj.
	window
		addMorph: (self on: proj)
		frame: (0@0 corner: 1.0@1.0).
	proj projectParameters at: #globalFlapsEnabledInProject put: false.
	^ window
! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:46'!
newMorphicProject
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	self flag: #bob.		"No senders???"
	self halt.

	"^self newMorphicProjectOn: nil"! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 15:45'!
newMorphicProjectOn: aPasteUpOrNil
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	self flag: #bob.		"No senders???"
	self halt.

	"^self newProjectViewInAWindowFor: (Project newMorphicOn: aPasteUpOrNil)"
! !

!ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 10/6/2000 14:02'!
newProjectViewInAWindowFor: aProject
	"Return an instance of me on a new Morphic project (in a SystemWindow)."

	| window |

	window _ (SystemWindow labelled: aProject name) model: aProject.
	window
		addMorph: (self on: aProject)
		frame: (0@0 corner: 1.0@1.0).
	^ window
! !
Notification subclass: #ProjectViewOpenNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ProjectViewOpenNotification commentStamp: '<historical>' prior: 0!
ProjectViewOpenNotification is signalled to determine if a ProjectViewMorph is needed for a newly created project. The default answer is yes.!


!ProjectViewOpenNotification methodsFor: 'as yet unclassified' stamp: 'RAA 7/4/2000 16:24'!
defaultAction

	self resume: true! !
PrintableEncoder subclass: #PropertyListEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

!PropertyListEncoder methodsFor: 'as yet unclassified' stamp: 'MPW 1/4/1901 08:22'!
writeArrayedCollection:aCollection
	self print:'/* '; print:aCollection class name; print:'*/'; cr.
	self print:'( '; writeCollectionContents:aCollection separator:','; print:')'.! !

!PropertyListEncoder methodsFor: 'as yet unclassified' stamp: 'MPW 1/4/1901 08:32'!
writeDictionary:aCollection
	self print:'{ '; writeDictionaryContents:aCollection separator:'; '; print:'}'.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PropertyListEncoder class
	instanceVariableNames: ''!

!PropertyListEncoder class methodsFor: 'as yet unclassified' stamp: 'MPW 1/1/1901 00:22'!
filterSelector
	^#propertyListOn:.
! !
LayoutPolicy subclass: #ProportionalLayout
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!ProportionalLayout commentStamp: '<historical>' prior: 0!
I represent a layout that places all children of some morph in their given LayoutFrame.!


!ProportionalLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'!
isProportionalLayout
	^true! !


!ProportionalLayout methodsFor: 'layout' stamp: 'ar 10/29/2000 01:24'!
layout: aMorph in: newBounds
	"Compute the layout for the given morph based on the new bounds"
	aMorph submorphsDo:[:m| m layoutProportionallyIn: newBounds].! !

!ProportionalLayout methodsFor: 'layout' stamp: 'ar 11/4/2000 22:47'!
minExtentOf: aMorph in: newBounds
	"Return the minimal size aMorph's children would require given the new bounds"
	| min extent frame |
	min _ 0@0.
	aMorph submorphsDo:[:m|
		"Map the minimal size of the child through the layout frame.
		Note: This is done here and not in the child because its specific
		for proportional layouts. Perhaps we'll generalize this for table
		layouts but I'm not sure how and when."
		extent _ m minExtent.
		frame _ m layoutFrame.
		frame ifNotNil:[extent _ (frame layout: (0@0 extent: extent) in: newBounds) extent].
		min _ min max: extent].
	^min! !
nil subclass: #ProtoObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!ProtoObject commentStamp: '<historical>' prior: 0!
ProtoObject establishes minimal behavior required of any object in Squeak, even objects that should balk at normal object behavior. Generally these are proxy objects designed to read themselves in from the disk, or to perform some wrapper behavior, before responding to a message. Current examples are ObjectOut and ImageSegmentRootStub, and one could argue that ObjectTracer should also inherit from this class.

ProtoObject has no instance variables, nor should any be added.!


!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:23'!
ifNil: nilBlock
	"Return self, or evaluate the block if I'm == nil (q.v.)"

	^ self! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:25'!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"Evaluate the block, unless I'm == nil (q.v.)"

	^ ifNotNilBlock value! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:25'!
ifNotNil: ifNotNilBlock
	"Evaluate the block, unless I'm == nil (q.v.)"

	^ ifNotNilBlock value! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:25'!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If I got here, I am not nil, so evaluate the block ifNotNilBlock"

	^ ifNotNilBlock value! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:57'!
isInMemory
	"All normal objects are."
	^ true! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:26'!
isNil
	"Coerces nil to true and everything else to false."

	^false! !

!ProtoObject methodsFor: 'testing' stamp: 'md 11/24/1999 19:58'!
pointsTo: anObject
	"This method returns true if self contains a pointer to anObject,
		and returns false otherwise"
	<primitive: 132>
	1 to: self class instSize do:
		[:i | (self instVarAt: i) == anObject ifTrue: [^ true]].
	1 to: self basicSize do:
		[:i | (self basicAt: i) == anObject ifTrue: [^ true]].
	^ false! !


!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
== anObject 
	"Primitive. Answer whether the receiver and the argument are the same 
	object (have the same object pointer). Do not redefine the message == in 
	any other class!! Essential. No Lookup. Do not override in any subclass. 
	See Object documentation whatIsAPrimitive."

	<primitive: 110>
	self primitiveFailed! !

!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
identityHash
	"Answer a SmallInteger whose value is related to the receiver's identity.
	This method must not be overridden, except by SmallInteger.
	Primitive. Fails if the receiver is a SmallInteger. Essential.
	See Object documentation whatIsAPrimitive.

	Do not override."

	<primitive: 75>
	self primitiveFailed! !

!ProtoObject methodsFor: 'comparing' stamp: 'md 11/24/1999 19:27'!
~~ anObject
	"Answer whether the receiver and the argument are not the same object 
	(do not have the same object pointer)."

	self == anObject
		ifTrue: [^ false]
		ifFalse: [^ true]! !


!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:30'!
become: otherObject 
	"Primitive. Swap the object pointers of the receiver and the argument.
	All variables in the entire system that used to point to the 
	receiver now point to the argument, and vice-versa.
	Fails if either object is a SmallInteger"

	(Array with: self)
		elementsExchangeIdentityWith:
			(Array with: otherObject)! !

!ProtoObject methodsFor: 'system primitives' stamp: 'di 2/11/2000 13:34'!
cannotInterpret: aMessage 
	 "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector.  Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose."

"If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent."

	| handler errorString |
	(self class lookupSelector: aMessage selector) == nil ifFalse:
		["Simulated lookup succeeded -- resend the message."
		^ aMessage sentTo: self].

	"Could not recover by simulated lookup -- it's an error"
	errorString _ 'MethodDictionary fault'.
	(handler _ Processor activeProcess errorHandler) notNil
		ifTrue: [handler value: errorString value: self]
		ifFalse: [Debugger openContext: thisContext
					label: errorString
					contents: thisContext shortStack].
	^ aMessage sentTo: self! !

!ProtoObject methodsFor: 'system primitives' stamp: 'di 12/6/1999 10:24'!
doesNotUnderstand: aMessage

	(MessageNotUnderstood new message: aMessage)
		signal! !

!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'!
nextInstance
	"Primitive. Answer the next instance after the receiver in the 
	enumeration of all instances of this class. Fails if all instances have been 
	enumerated. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 78>
	^nil! !

!ProtoObject methodsFor: 'system primitives' stamp: 'md 11/24/1999 19:58'!
nextObject
	"Primitive. Answer the next object after the receiver in the 
	enumeration of all objects. Return 0 when all objects have been 
	enumerated."

	<primitive: 139>
	self primitiveFailed.! !


!ProtoObject methodsFor: 'objects from disk' stamp: 'md 11/24/1999 20:03'!
rehash
	"Do nothing.  Here so sending this to a Set does not have to do a time consuming respondsTo:"! !


!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:29'!
doOnlyOnce: aBlock
	"If the 'one-shot' mechanism is armed, evaluate aBlock once and disarm the one-shot mechanism.  To rearm the mechanism, evaluate  'self rearmOneShot' manually."

	(Smalltalk at: #OneShotArmed ifAbsent: [true])
		ifTrue:
			[Smalltalk at: #OneShotArmed put: false.
			aBlock value]! !

!ProtoObject methodsFor: 'debugging' stamp: 'sw 4/28/2000 14:41'!
flag: aSymbol
	"Send this message, with a relevant symbol as argument, to flag a message for subsequent retrieval.  For example, you might put the following line in a number of messages:
	self flag: #returnHereUrgently
	Then, to retrieve all such messages, browse all senders of #returnHereUrgently."! !

!ProtoObject methodsFor: 'debugging' stamp: 'sw 10/26/2000 14:27'!
rearmOneShot
	"Call this manually to arm the one-shot mechanism; use the mechanism in code by calling
		self doOnlyOnce: <a block>"

	Smalltalk at: #OneShotArmed put: true

	"self rearmOneShot"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtoObject class
	instanceVariableNames: ''!

!ProtoObject class methodsFor: 'as yet unclassified' stamp: 'sw 5/5/2000 09:31'!
initializedInstance
	^ nil! !
MessageSet subclass: #ProtocolBrowser
	instanceVariableNames: 'selectedClass selectedSelector '
	classVariableNames: 'TextMenu '
	poolDictionaries: ''
	category: 'Tools-Browser'!
!ProtocolBrowser commentStamp: '<historical>' prior: 0!
An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.!


!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!
getList
	"Answer the receiver's message list."
	^ messageList! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:33'!
list
	"Answer the receiver's message list."
	^ messageList! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selectedClass
	"Answer the receiver's selected class."
	^ selectedClass! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selectedClass: aClass
	"Set the receiver's selected class to be the argument."
	selectedClass := aClass! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selector
	"Answer the receiver's selected selector."
	^ selectedSelector! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
selector: aString
	"Set the currently selected message selector to be aString."
	selectedSelector := aString.
	self changed: #selector! !

!ProtocolBrowser methodsFor: 'accessing' stamp: 'di 7/13/97 16:35'!
setSelector: aString
	"Set the currently selected message selector to be aString."
	selectedSelector := aString! !


!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:23'!
initListFrom: selectorCollection highlighting: aClass 
	"Make up the messageList with items from aClass in boldface."
	| defClass item |
	messageList := OrderedCollection new.
	selectorCollection do: 
		[:selector |  defClass := aClass whichClassIncludesSelector: selector.
		item _ selector, '     (' , defClass name , ')'.
		messageList add: (defClass == aClass ifTrue:[item asText allBold] ifFalse:[item])]! !

!ProtocolBrowser methodsFor: 'private' stamp: 'di 7/13/97 16:26'!
on: aClass 
	"Initialize with the entire protocol for the class, aClass."
	self initListFrom: aClass allSelectors asSortedCollection
		highlighting: aClass! !

!ProtocolBrowser methodsFor: 'private' stamp: 'di 11/26/1999 19:39'!
onSubProtocolOf: aClass 
	"Initialize with the entire protocol for the class, aClass,
		but excluding those inherited from Object."
	| selectors |
	selectors := Set new.
	aClass withAllSuperclasses do:
		[:each | (each == Object or: [each == ProtoObject]) 
			ifFalse: [selectors addAll: each selectors]].
	self initListFrom: selectors asSortedCollection
		highlighting: aClass! !

!ProtocolBrowser methodsFor: 'private' stamp: 'di 3/31/1999 14:33'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form    <selectorName> (<className> [class])  "

	| i classAndSelString sel |
	sel _ self selection asString.
	i _ sel indexOf: $(.
	"Rearrange to  <className> [class] <selectorName> , and use MessageSet"
	classAndSelString _ (sel copyFrom: i + 1 to: sel size - 1) , ' ' ,
					(sel copyFrom: 1 to: i - 1) withoutTrailingBlanks.
	MessageSet parse: classAndSelString toClassAndSelector: csBlock! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ProtocolBrowser class
	instanceVariableNames: ''!

!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!
openFullProtocolForClass: aClass 
	"Create and schedule a browser for the entire protocol of the class."
	"ProtocolBrowser openFullProtocolForClass: ProtocolBrowser."
	| aPBrowser label |
	aPBrowser := ProtocolBrowser new on: aClass.
	label := 'Entire protocol of: ', aClass name.
	self open: aPBrowser name: label! !

!ProtocolBrowser class methodsFor: 'instance creation' stamp: 'di 7/13/97 15:15'!
openSubProtocolForClass: aClass 
	"Create and schedule a browser for the entire protocol of the class."
	"ProtocolBrowser openSubProtocolForClass: ProtocolBrowser."
	| aPBrowser label |
	aPBrowser := ProtocolBrowser new onSubProtocolOf: aClass.
	label := 'Sub-protocol of: ', aClass name.
	self open: aPBrowser name: label! !
Object subclass: #PseudoClass
	instanceVariableNames: 'name definition organization source metaClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!PseudoClass methodsFor: 'class'!
classComment: aChangeRecord
	self organization classComment: aChangeRecord! !

!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'!
classPool 
	self exists ifFalse: [^ nil].
	^ self realClass classPool! !

!PseudoClass methodsFor: 'class'!
comment
	| rStr |
	rStr := self organization commentRemoteStr.
	^rStr isNil
		ifTrue:[self name,' has not been commented']
		ifFalse:[rStr string]! !

!PseudoClass methodsFor: 'class'!
comment: aString
	self commentString: aString.! !

!PseudoClass methodsFor: 'class' stamp: 'wod 4/15/98 17:21'!
commentString
	^self organization classComment asString! !

!PseudoClass methodsFor: 'class'!
commentString: aString
	self classComment: aString asText. "Just wrap it"! !

!PseudoClass methodsFor: 'class'!
definition
	^definition ifNil:['There is no class definition for this class'].! !

!PseudoClass methodsFor: 'class'!
definition: aString
	definition := aString! !

!PseudoClass methodsFor: 'class'!
metaClass
	^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! !

!PseudoClass methodsFor: 'class'!
renameTo: aString

	self hasDefinition ifTrue:[
		self isMetaClass ifTrue:[
			self definition: (self definition
				copyReplaceAll: name,' class'
				with: aString, ' class').
		] ifFalse:[
			self definition: (self definition 
					copyReplaceAll:'ubclass: #',name
					with:'ubclass: #', aString)]].
	name := aString.
	metaClass ifNotNil:[metaClass renameTo: aString].! !

!PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'!
sharedPools 
	self exists ifFalse: [^ nil].
	^ self realClass sharedPools! !


!PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'!
allInstVarNames
	^#()! !

!PseudoClass methodsFor: 'accessing' stamp: 'sma 2/6/2000 12:30'!
allSuperclasses
	^ self realClass allSuperclasses! !

!PseudoClass methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:24'!
compilerClass
	^ (Smalltalk at: name ifAbsent: [^ Compiler]) compilerClass! !

!PseudoClass methodsFor: 'accessing'!
fullName
	^self name! !

!PseudoClass methodsFor: 'accessing'!
name
	^name! !

!PseudoClass methodsFor: 'accessing'!
name: anObject
	name _ anObject! !

!PseudoClass methodsFor: 'accessing'!
organization
	^organization ifNil:[organization := PseudoClassOrganizer defaultList: SortedCollection new].! !

!PseudoClass methodsFor: 'accessing'!
realClass
	^Smalltalk at: self name asSymbol! !

!PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self! !


!PseudoClass methodsFor: 'removing'!
removeAllUnmodified
	| stClass |
	self exists ifFalse:[^self].
	self removeUnmodifiedMethods: self selectors.
	stClass := self realClass.
	(self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil].
	(self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil].
	metaClass isNil ifFalse:[metaClass removeAllUnmodified].! !

!PseudoClass methodsFor: 'removing'!
removeUnmodifiedMethods: aCollection
	| stClass |
	self exists ifFalse:[^self].
	stClass := self realClass.
	aCollection do:[:sel|
		(self sourceCodeAt: sel) = (stClass sourceCodeAt: sel ifAbsent:['']) asString ifTrue:[
			self removeMethod: sel.
		].
	].
	self organization removeEmptyCategories.! !


!PseudoClass methodsFor: 'private' stamp: 'sma 2/6/2000 12:23'!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level
	^ self realClass allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! !

!PseudoClass methodsFor: 'private'!
confirmRemovalOf: aString
	^self confirm:'Remove ',aString,' ?'! !

!PseudoClass methodsFor: 'private'!
evaluate: aString
	^Compiler evaluate: aString for: nil logged: true! !

!PseudoClass methodsFor: 'private'!
makeSureClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil].
	theClass ifNotNil:[^true].
	^self confirm: aString,' does not exist in the system. Use nil instead?'.! !

!PseudoClass methodsFor: 'private'!
makeSureSuperClassExists: aString
	| theClass |
	theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil].
	theClass ifNotNil:[^true].
	^self confirm: 'The super class ',aString,' does not exist in the system. Use nil instead?'.! !

!PseudoClass methodsFor: 'private'!
parserClass
	^Parser! !


!PseudoClass methodsFor: 'testing'!
exists
	^(Smalltalk at: self name asSymbol ifAbsent:[^false]) isKindOf: Behavior! !

!PseudoClass methodsFor: 'testing'!
hasChanges

	self sourceCode isEmpty ifFalse:[^true].
	self organization hasNoComment ifFalse:[^true].
	definition isNil ifFalse:[^true].
	metaClass isNil ifFalse:[^metaClass hasChanges].
	^false! !

!PseudoClass methodsFor: 'testing'!
hasComment
	^self organization commentRemoteStr notNil! !

!PseudoClass methodsFor: 'testing'!
hasDefinition
	^definition notNil! !

!PseudoClass methodsFor: 'testing'!
hasMetaclass
	^metaClass notNil! !

!PseudoClass methodsFor: 'testing'!
isMetaClass
	^false! !

!PseudoClass methodsFor: 'testing'!
nameExists
	^Smalltalk includesKey: self name asSymbol! !

!PseudoClass methodsFor: 'testing'!
needsInitialize
	^self hasMetaclass and:[
		self metaClass selectors includes: #initialize]! !


!PseudoClass methodsFor: 'fileIn/fileOut'!
fileIn
	"FileIn the receiver"
	self hasDefinition ifTrue:[self fileInDefinition].
	self fileInMethods: self selectors.
	metaClass ifNotNil:[metaClass fileIn].
	self needsInitialize ifTrue:[
		self evaluate: self name,' initialize'.
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInCategory: aCategory
	^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInDefinition
	(self makeSureSuperClassExists: (definition copyUpTo: Character space)) ifFalse:[^self].
	self hasDefinition ifTrue:[
		Transcript cr; show:'Defining ', self name.
		self evaluate: self definition].
	self exists ifFalse:[^self].
	self hasComment ifTrue:[self realClass classComment: self comment].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethod: selector
	^self fileInMethods: (Array with: selector)! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethods
	^self fileInMethods: self selectors! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileInMethods: aCollection
	"FileIn all methods with selectors taken from aCollection"
	| theClass cat |
	self exists ifFalse:[^self classNotDefined].
	theClass := self realClass.
	aCollection do:[:sel|
		cat := self organization categoryOfElement: sel.
		cat = self removedCategoryName ifFalse:[
			theClass 
				compile: (self sourceCodeAt: sel) 
				classified: cat
				withStamp: (self stampAt: sel)
				notifying: nil.
		].
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOut
	| f |
	f := (FileStream newFileNamed: self name,'.st').
	self fileOutOn: f.
	self needsInitialize ifTrue:[
		f cr; nextChunkPut: self name,' initialize'.
	].
	f close! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutCategory: categoryName
	| f |
	f := (FileStream newFileNamed: self name,'-',categoryName,'.st').
	self fileOutMethods: (self organization listAtCategoryNamed: categoryName)
			on: f.
	f close
! !

!PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'hg 9/6/2000 12:45'!
fileOutDefinitionOn: aStream
	self hasDefinition ifFalse:[^self].
	aStream nextChunkPut: self definition; cr.
	self hasComment
		ifTrue:
			[aStream cr.
			self organization commentRemoteStr fileOutOn:
aStream]! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutMethod: selector
	| f |
	f := (FileStream newFileNamed: self name,'-', selector, '.st').
	self fileOutMethods: (Array with: selector)
			on: f.
	f close! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutMethods: aCollection on: aStream
	"FileOut all methods with selectors taken from aCollection"
	| cat categories |
	categories := Dictionary new.
	aCollection do:[:sel|
		cat := self organization categoryOfElement: sel.
		cat = self removedCategoryName ifFalse:[
			(categories includesKey: cat) 
				ifFalse:[categories at: cat put: Set new].
			(categories at: cat) add: sel].
	].
	categories associationsDo:[:assoc|
		cat := assoc key.
		aStream cr; cr; nextPut:$!!; nextChunkPut:(String streamContents:[:s|
			s nextPutAll: self fullName; nextPutAll:' methodsFor: '; print: cat asString]).
		assoc value do:[:sel|
			aStream cr.
			aStream nextChunkPut: (self sourceCodeAt: sel).
		].
		aStream space; nextPut:$!!.
	].! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutMethodsOn: aStream
	^self fileOutMethods: self selectors on: aStream.! !

!PseudoClass methodsFor: 'fileIn/fileOut'!
fileOutOn: aStream
	"FileOut the receiver"
	self fileOutDefinitionOn: aStream.
	metaClass ifNotNil:[metaClass fileOutDefinitionOn: aStream].
	self fileOutMethods: self selectors on: aStream.
	metaClass ifNotNil:[metaClass fileOutMethods: metaClass selectors on: aStream].! !


!PseudoClass methodsFor: 'errors'!
classNotDefined
	^self inform: self name,' is not defined in the system.
You have to define this class first.'.! !


!PseudoClass methodsFor: 'categories'!
removeCategory: selector
	(self organization listAtCategoryNamed: selector) do:[:sel|
		self organization removeElement: sel.
		self sourceCode removeKey: sel.
	].
	self organization removeCategory: selector.! !

!PseudoClass methodsFor: 'categories'!
removedCategoryName
	^'*** removed methods ***' asSymbol! !

!PseudoClass methodsFor: 'categories'!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	^ self organization categoryOfElement: aSelector! !


!PseudoClass methodsFor: 'methods' stamp: 'sma 6/1/2000 14:54'!
addMethodChange: aChangeRecord
	| selector |
	selector _ self parserClass new parseSelector: aChangeRecord string.
	self organization classify: selector under: aChangeRecord category.
	self sourceCodeAt: selector put: aChangeRecord! !

!PseudoClass methodsFor: 'methods'!
methodChange: aChangeRecord
	aChangeRecord isMetaClassChange ifTrue:[
		^self metaClass addMethodChange: aChangeRecord.
	] ifFalse:[
		^self addMethodChange: aChangeRecord.
	].
! !

!PseudoClass methodsFor: 'methods'!
removeMethod: selector
	self organization removeElement: selector.
	self sourceCode removeKey: selector.
! !

!PseudoClass methodsFor: 'methods'!
removeSelector: aSelector
	| catName |
	catName := self removedCategoryName.
	self organization addCategory: catName before: self organization categories first.
	self organization classify: aSelector under: catName.
	self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! !

!PseudoClass methodsFor: 'methods'!
selectors
	^self sourceCode keys! !

!PseudoClass methodsFor: 'methods'!
sourceCode
	^source ifNil:[source := Dictionary new]! !

!PseudoClass methodsFor: 'methods'!
sourceCodeAt: sel
	^(self sourceCode at: sel) string! !

!PseudoClass methodsFor: 'methods'!
sourceCodeAt: sel put: object
	self sourceCode at: sel put: object! !

!PseudoClass methodsFor: 'methods'!
sourceCodeTemplate
	^''! !

!PseudoClass methodsFor: 'methods'!
stampAt: selector
	^(self sourceCode at: selector) stamp! !


!PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'!
literalScannedAs: scannedLiteral notifying: requestor 
	^ scannedLiteral! !


!PseudoClass methodsFor: 'testing method dictionary' stamp: 'sma 6/5/2000 10:26'!
scopeHas: varName ifTrue: assocBlock
	(self exists and: [self realClass scopeHas: varName ifTrue: assocBlock]) ifTrue: [^ true].
	assocBlock value: (Smalltalk 
		associationAt: varName asSymbol
		ifAbsent: [^ false]).
	^ true! !
ClassOrganizer subclass: #PseudoClassOrganizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!PseudoClassOrganizer methodsFor: 'as yet unclassified' stamp: 'wod 4/15/98 17:08'!
classComment
	"Answer the comment associated with the object that refers to the receiver."
	globalComment == nil ifTrue: [^''].
	^globalComment! !

!PseudoClassOrganizer methodsFor: 'as yet unclassified'!
classComment: aChangeRecord
	globalComment := aChangeRecord! !

!PseudoClassOrganizer methodsFor: 'as yet unclassified'!
setDefaultList: aCollection
	super setDefaultList: aCollection.
	self classComment: nil.! !
Object variableSubclass: #PseudoContext
	instanceVariableNames: 'fixed fields never accessed from smalltalk '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
!PseudoContext commentStamp: '<historical>' prior: 0!
I represent cached context state within the virtual machine.  I have the same format as normal method and block contexts, but my fields are never referenced directly from Smalltalk.  Whenever a message is sent to me I will magically transform myself into a real context which will respond to all the usual messages.
	I rely on the fact that block and method contexts have exactly the same number of fixed fields.!


!PseudoContext methodsFor: 'testing' stamp: 'ikp 9/26/97 14:45'!
isPseudoContext
	^true! !


!PseudoContext methodsFor: 'system primitives' stamp: 'ikp 10/20/97 15:36'!
nextObject
	"See Object>>nextObject."

	<primitive: 139>
	self primitiveFailed.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

PseudoContext class
	instanceVariableNames: ''!

!PseudoContext class methodsFor: 'class initialization' stamp: 'ikp 1/10/98 02:33'!
initialize
	"It's tricky to do the necessary stuff with the regular file-in machinery."

	PseudoContext superclass = nil
		ifFalse: [
			(Smalltalk confirm: 'Shall I convert PseudoContext into a compact subclass of nil?
("yes" is almost always the correct response)')
				ifTrue: [
					PseudoContext becomeCompact.
					PseudoContext superclass removeSubclass: PseudoContext.
					PseudoContext superclass: nil]].
	Smalltalk recreateSpecialObjectsArray.
	Smalltalk specialObjectsArray size = 41
		ifFalse: [self error: 'Please check size of special objects array!!']! !


!PseudoContext class methodsFor: 'filing out' stamp: 'ikp 9/26/97 14:45'!
definition
	"Our superclass is really nil, but this causes problems when we try to become compact
	after filing in for the first time.  Fake the superclass as Object, and repair the situation
	during class initialisation."
	| defn |
	defn _ super definition.
	^(defn beginsWith: 'nil ')
		ifTrue: ['Object' , (defn copyFrom: 4 to: defn size)]
		ifFalse: [defn].! !


!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'!
contextCacheDepth
	"Answer the number of entries in the context cache.  This requires a little insider
	knowledge.  Not intended for casual use, which is why it's private protocol."

	^self contextCacheDepth: thisContext yourself! !

!PseudoContext class methodsFor: 'private' stamp: 'ikp 9/26/97 14:45'!
contextCacheDepth: b
	^b isPseudoContext
		ifTrue: [1 + (self contextCacheDepth: b)]
		ifFalse: [1]! !
PseudoClass subclass: #PseudoMetaclass
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!PseudoMetaclass methodsFor: 'accessing'!
fullName
	^self name,' class'! !

!PseudoMetaclass methodsFor: 'accessing'!
realClass
	^super realClass class! !


!PseudoMetaclass methodsFor: 'testing'!
isMetaClass
	^true! !
Rectangle subclass: #Quadrangle
	instanceVariableNames: 'borderWidth borderColor insideColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Quadrangle commentStamp: '<historical>' prior: 0!
I represent a particular kind of Rectangle that has a border and inside color.!


!Quadrangle methodsFor: 'initialize-release'!
initialize
	"Initialize the region to a null Rectangle, the borderWidth to 1, the 
	borderColor to black, and the insideColor to white."

	origin _ 0 @ 0.
	corner _ 0 @ 0.
	borderWidth _ 1.
	borderColor _ Color black.
	insideColor _ Color white.
! !


!Quadrangle methodsFor: 'bordering'!
borderColor
	"Answer the form that is the borderColor of the receiver."

	^borderColor! !

!Quadrangle methodsFor: 'bordering'!
borderColor: aColor 
	"Set the borderColor of the receiver to aColor, a Form."

	borderColor _ aColor! !

!Quadrangle methodsFor: 'bordering'!
borderWidth
	"Answer the borderWidth of the receiver."

	^borderWidth! !

!Quadrangle methodsFor: 'bordering'!
borderWidth: anInteger 
	"Set the borderWidth of the receiver to anInteger."

	borderWidth _ anInteger! !

!Quadrangle methodsFor: 'bordering'!
borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4
	"Set the border width of the receiver to a Rectangle that represents the 
	left, right, top, and bottom border widths."

	borderWidth _ anInteger1 @ anInteger3 corner: anInteger2 @ anInteger4! !

!Quadrangle methodsFor: 'bordering'!
inside
	"Answer a Rectangle that is the receiver inset by the borderWidth."

	^self insetBy: borderWidth! !

!Quadrangle methodsFor: 'bordering'!
insideColor
	"Answer the form that is the insideColor of the receiver."

	^insideColor! !

!Quadrangle methodsFor: 'bordering'!
insideColor: aColor 
	"Set the insideColor of the receiver to aColor, a Form."

	insideColor _ aColor! !

!Quadrangle methodsFor: 'bordering'!
region
	"Answer a Rectangle that defines the area of the receiver."

	^origin corner: corner! !

!Quadrangle methodsFor: 'bordering'!
region: aRectangle 
	"Set the rectangular area of the receiver to aRectangle."

	origin _ aRectangle origin.
	corner _ aRectangle corner! !


!Quadrangle methodsFor: 'rectangle functions'!
intersect: aRectangle 
	"Answer a new Quadrangle whose region is the intersection of the 
	receiver's area and aRectangle.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
	 	region: (super intersect: aRectangle)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !


!Quadrangle methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Answer a new Quadrangle translated by aPoint2 - aPoint1.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: aPoint2 - aPoint1)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
alignedTo: alignPointSelector
	"Return a copy with offset according to alignPointSelector which is one of...
	#(topLeft, topCenter, topRight, leftCenter, center, etc)
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: (0@0) - (self perform: alignPointSelector))
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
scaleBy: aPoint 
	"Answer a new Quadrangle scaled by aPoint.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super scaleBy: aPoint)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !

!Quadrangle methodsFor: 'transforming'!
translateBy: aPoint 
	"Answer a new Quadrangle translated by aPoint.
	 5/24/96 sw: removed hard-coded class name so subclasses can gain same functionality."

	^ self class
		region: (super translateBy: aPoint)
		borderWidth: borderWidth
		borderColor: borderColor
		insideColor: insideColor! !


!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium
	"Display the border and insideRegion of the receiver."

	borderWidth ~~ 0
		ifTrue:	[aDisplayMedium
				border: self region
				widthRectangle: borderWidth
				rule: Form over
				fillColor: borderColor].
	insideColor ~~ nil
		ifTrue:	[aDisplayMedium fill: self inside fillColor: insideColor]! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium align: aPoint1 with: aPoint2 clippingBox: aRectangle
	"Display the border and region of the receiver so that its position at 
	aPoint1 is aligned with position aPoint2. The displayed information 
	should be clipped so that only information with the area determined by 
	aRectangle is displayed."

	| savedRegion |
	savedRegion _ self region.
	self region: ((savedRegion align: aPoint1 with: aPoint2) intersect: aRectangle).
	self displayOn: aDisplayMedium.
	self region: savedRegion! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOn: aDisplayMedium transformation: aWindowingTransformation clippingBox: aRectangle
	"Display the border and region of the receiver so that it is scaled and 
	translated with respect to aWindowingTransformation. The displayed 
	information should be clipped so that only information with the area 
	determined by aRectangle is displayed."

	| screenRectangle |
	screenRectangle _ 
		(aWindowingTransformation applyTo: self) intersect: aRectangle.
	borderWidth ~~ 0 & (insideColor ~~ nil)
		ifTrue: 
			[aDisplayMedium fill: screenRectangle fillColor: Color black "borderColor".
			aDisplayMedium
				fill: (screenRectangle insetBy: borderWidth)
				fillColor: insideColor]! !

!Quadrangle methodsFor: 'displaying-generic'!
displayOnPort: aPort at: p
	"Display the border and insideRegion of the receiver."

	(insideColor == nil or: [borderWidth <= 0])
		ifFalse: [aPort fill: (self region translateBy: p) 
			fillColor: borderColor rule: Form over].
	insideColor == nil
		ifFalse: [aPort fill: (self inside translateBy: p) 
			fillColor: insideColor rule: Form over]! !


!Quadrangle methodsFor: 'displaying-Display'!
display 
	"Display the border and insideRegion of the receiver on the Display."

	self displayOn: Display! !

!Quadrangle methodsFor: 'displaying-Display'!
displayAlign: aPoint1 with: aPoint2 clippingBox: aRectangle 
	"Display the border and region of the receiver on the Display so that its 
	position at aPoint1 is aligned with position aPoint2. The displayed 
	information should be clipped so that only information with the area 
	determined by aRectangle is displayed." 

	self displayOn: Display align: aPoint1 with: aPoint2 clippingBox: aRectangle! !

!Quadrangle methodsFor: 'displaying-Display'!
displayTransformation: aWindowingTransformation clippingBox: aRectangle 
	"Display the border and region of the receiver on the Display so that it 
	is scaled and translated with respect to aWindowingTransformation. The 
	displayed information should be clipped so that only information with 
	the area determined by aRectangle is displayed." 

	self displayOn: Display transformation: aWindowingTransformation clippingBox: aRectangle! !


!Quadrangle methodsFor: 'private'!
setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2

	origin _ aRectangle origin.
	corner _ aRectangle corner.
	borderWidth _ anInteger.
	borderColor _ aMask1.
	insideColor _ aMask2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Quadrangle class
	instanceVariableNames: ''!

!Quadrangle class methodsFor: 'instance creation'!
new
	"Answer an instance of me, initialized to a null Rectangle, 
	with borderWidth of 1, borderColor of black, and insideColor of white."

	^super new initialize! !

!Quadrangle class methodsFor: 'instance creation'!
region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2
	"Answer an instance of me with rectangle, border width and color, and 
	inside color determined by the arguments."

	^super new
		setRegion: aRectangle
		borderWidth: anInteger
		borderColor: aMask1
		insideColor: aMask2! !
AbstractSound subclass: #QueueSound
	instanceVariableNames: 'startTime sounds currentSound done '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Support'!

!QueueSound methodsFor: 'initialization' stamp: 'len 9/26/1999 17:19'!
initialize
	super initialize.
	sounds _ SharedQueue new.
	done _ false.
	startTime _ Time millisecondClockValue! !


!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:52'!
add: aSound
	self sounds nextPut: aSound.
	^ aSound! !

!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 22:06'!
currentSound
	currentSound isNil ifTrue: [currentSound _ self nextSound].
	^ currentSound! !

!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 22:07'!
currentSound: aSound
	currentSound _ aSound! !

!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 22:07'!
done: aBoolean
	done _ aBoolean! !

!QueueSound methodsFor: 'accessing' stamp: 'len 8/29/1999 21:46'!
sounds
	^ sounds! !

!QueueSound methodsFor: 'accessing' stamp: 'len 9/26/1999 17:19'!
startTime
	^ startTime! !

!QueueSound methodsFor: 'accessing' stamp: 'len 9/26/1999 17:19'!
startTime: anInteger
	startTime _ anInteger! !


!QueueSound methodsFor: 'sound generation' stamp: 'len 8/29/1999 22:07'!
doControl
	super doControl.
	self currentSound notNil ifTrue: [self currentSound doControl]! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 9/26/1999 17:29'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."

	| finalIndex i remaining count rate |
	self currentSound isNil ifTrue: [^ self].  "already done"
	self startTime > Time millisecondClockValue ifTrue: [^ self].
	rate _ self samplingRate.
	finalIndex _ (startIndex + n) - 1.
	i _ startIndex.
	[i <= finalIndex] whileTrue: [
		[self currentSound isNil ifTrue: [^ self].
		(remaining _ self currentSound samplesRemaining) <= 0]
			whileTrue: [self currentSound: self nextSound].
		count _ (finalIndex - i) + 1.
		remaining < count ifTrue: [count _ remaining].
		self currentSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i _ i + count]! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 11/30/1999 04:13'!
nextSound
	| answer |
	sounds isEmpty ifTrue: [^ nil].
	answer _ sounds next.
	answer reset.
	^ answer! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 9/13/1999 00:26'!
reset
	super reset.
	self currentSound notNil
		ifTrue: [self currentSound reset]
		ifFalse: [self currentSound: self nextSound]! !

!QueueSound methodsFor: 'sound generation' stamp: 'len 8/29/1999 22:13'!
samplesRemaining
	(done and: [self sounds isEmpty])
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !
MimeConverter subclass: #QuotedPrintableMimeConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!QuotedPrintableMimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2045 "MIME Part One: Format of Internet Message Bodies".

Short version of RFC2045, Sect. 6.7:

	(1) Any octet, except a CR or LF that is part of a CRLF line break of the canonical (standard) form of the data being encoded, may be represented by an "=" followed by a two digit hexadecimal representation of the octet's value. [...]

	(2) Octets with decimal values of 33 through 60 inclusive, and 62 through 126, inclusive, MAY be represented as the US-ASCII characters which correspond to those octets [...].

	(3) Octets with values of 9 and 32 MAY be represented as US-ASCII TAB (HT) and SPACE characters,
 respectively, but MUST NOT be so represented at the end of an encoded line.  [...]

	(4) A line break in a text body, represented as a CRLF sequence in the text canonical form, must be represented by a (RFC 822) line break, which is also a CRLF sequence, in the Quoted-Printable encoding.  [...]

	(5) The Quoted-Printable encoding REQUIRES that encoded lines be no more than 76 characters long.  If longer lines are to be encoded with the Quoted-Printable encoding, "soft" line breaks
 must be used.  An equal sign as the last character on a encoded line indicates such a non-significant ("soft") line break in the encoded text.


--bf 11/27/1998 16:50!


!QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'bf 11/24/1998 20:33'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream"

	| line s c1 v1 c2 v2 |
	[(line _ mimeStream nextLine) isNil] whileFalse: [
		line _ line withoutTrailingBlanks.
		line size = 0
			ifTrue: [dataStream cr]
			ifFalse: [
				s _ ReadStream on: line.
				[dataStream nextPutAll: (s upTo: $=).
				s atEnd] whileFalse: [
					c1 _ s next. v1 _ c1 digitValue.
					((v1 between: 0 and: 15) and: [s atEnd not])
						ifFalse: [dataStream nextPut: $=; nextPut: c1]
						ifTrue: [c2 _ s next. v2 _ c2 digitValue.
							(v2 between: 0 and: 15)
								ifFalse: [dataStream nextPut: $=; nextPut: c1; nextPut: c2]
								ifTrue: [dataStream nextPut: (Character value: v1 * 16 + v2)]]].
				line last = $= ifFalse: [dataStream cr]]].
	^ dataStream! !
QuotedPrintableMimeConverter subclass: #RFC2047MimeConverter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!RFC2047MimeConverter commentStamp: '<historical>' prior: 0!
I do quoted printable MIME decoding as specified in RFC 2047 ""MIME Part Three: Message Header Extensions for Non-ASCII Text". See String>>decodeMimeHeader!


!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 11/27/1998 17:04'!
mimeDecode
	"Do conversion reading from mimeStream writing to dataStream. See String>>decodeMimeHeader"

	| c |
	[mimeStream atEnd] whileFalse: [
		c _ mimeStream next.
		c = $=
			ifTrue: [c _ Character value: mimeStream next digitValue * 16
				+ mimeStream next digitValue]
			ifFalse: [c = $_ ifTrue: [c _ $ ]].
		dataStream nextPut: c].
	^ dataStream! !

!RFC2047MimeConverter methodsFor: 'conversion' stamp: 'bf 3/10/2000 16:06'!
mimeEncode
	"Do conversion reading from dataStream writing to mimeStream. Break long lines and escape non-7bit chars."

	| word pos wasGood isGood max |
	true ifTrue: [mimeStream nextPutAll: dataStream upToEnd].
	pos _ 0.
	max _ 72.
	wasGood _ true.
	[dataStream atEnd] whileFalse: [
		word _ self readWord.
		isGood _ word allSatisfy: [:c | c asciiValue < 128].
		wasGood & isGood ifTrue: [
			pos + word size < max
				ifTrue: [dataStream nextPutAll: word.
					pos _ pos + word size]
				ifFalse: []
		]
	].
	^ mimeStream! !


!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:16'!
encodeChar: aChar to: aStream

	aChar = Character space
		ifTrue: [^ aStream nextPut: $_].
	((aChar asciiValue between: 32 and: 127) and: [('?=_' includes: aChar) not])
		ifTrue: [^ aStream nextPut: aChar].
	aStream nextPut: $=;
		nextPut: (Character digitValue: aChar asciiValue // 16);
		nextPut: (Character digitValue: aChar asciiValue \\ 16)
! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 23:13'!
encodeWord: aString

	(aString allSatisfy: [:c | c asciiValue < 128])
		ifTrue: [^ aString].
	^ String streamContents: [:stream |
		stream nextPutAll: '=?iso-8859-1?Q?'.
		aString do: [:c | self encodeChar: c to: stream].
		stream nextPutAll: '?=']! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/12/2000 14:36'!
isStructuredField: aString

	| fName |
	fName _ aString copyUpTo: $:.
	('Resent' sameAs: (fName copyUpTo: $-))
		ifTrue: [fName _ fName copyFrom: 8 to: fName size].
	^#('Sender' 'From' 'Reply-To' 'To' 'cc' 'bcc') anySatisfy: [:each | fName sameAs: each]! !

!RFC2047MimeConverter methodsFor: 'private-encoding' stamp: 'bf 3/11/2000 22:30'!
readWord

	| strm |
	strm _ WriteStream on: (String new: 20)
	dataStream skipSeparators.
	[dataStream atEnd] whileFalse: 
		[ | c |
		c _ dataStream next.
		strm nextPut: c.
		c isSeparator ifTrue: [^ strm contents]].
	^ strm contents! !
ReadNewsInboxFile subclass: #RNInboxFile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!RNInboxFile commentStamp: '<historical>' prior: 0!
I am a parser for news files in the format output by the Unix 'rn' program.
!


!RNInboxFile methodsFor: 'scanning'!
nextStringOf: aStream equals: aString

	aString do:
		[: c | (c == (aStream next) ) ifFalse: [^false]].
	^true! !

!RNInboxFile methodsFor: 'scanning'!
parse: aStream do: aBlock
	"Parse the given stream into newsgroup articles, invoking the given block once for each article in the stream. The stream is divided into articles by delimiters that includes the newsgroup name. Ignore text before the first article delimiter."

	| done line groupName |
	currentNewsgroup _ nil.  "have not found start of article"
	msgBuffer _ WriteStream on: (String new: 5000).
	done _ false.
	[done] whileFalse:
		[(aStream atEnd) ifTrue:
			["end of stream"
			 self endOfArticleDo: aBlock.
			 done _ true].
		 line _ MailDB readStringLineFrom: aStream.
		 groupName _ self startOfArticle: line.
		 (groupName notNil) ifTrue:
			[self endOfArticleDo: aBlock.
			 currentNewsgroup _ groupName.
			 line _ MailDB readStringLineFrom: aStream].
		 (currentNewsgroup notNil) ifTrue: [self appendLine: line]].! !

!RNInboxFile methodsFor: 'scanning' stamp: 'bf 3/16/2000 19:19'!
startOfArticle: aString
	"Answer the newsgroup name if the given string is the start of a news article, for example:
		Article 2958 of comp.lang.smalltalk:
	Otherwise, answer nil."

	| s name |
	s _ ReadStream on: aString.
	(self nextStringOf: s equals: 'Article ') ifFalse: [^nil].
	[s next isDigit] whileTrue.	"consumes digits plus the following space"
	(self nextStringOf: s equals: 'of ') ifFalse: [^nil].
	name _ s upTo: $:.
	((name size > 1) & (s atEnd)) ifFalse: [^nil].
	^name! !
ReadWriteStream subclass: #RWBinaryOrTextStream
	instanceVariableNames: 'isBinary '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!RWBinaryOrTextStream commentStamp: '<historical>' prior: 0!
A simulation of a FileStream, but living totally in memory.  Hold the contents of a file or web page from the network.  Can then fileIn like a normal FileStream.

Need to be able to switch between binary and text, as a FileStream does, without recopying the whole collection.  Convert to binary upon input and output.  Always keep as text internally.!


!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 2/4/2000 09:15'!
asBinaryOrTextStream

	^ self! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/25/97 13:22'!
ascii
	isBinary _ false! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:46'!
binary
	isBinary _ true! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 12:49'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	| newArray |
	isBinary ifFalse: [^ super contents].	"String"
	readLimit _ readLimit max: position.
	newArray _ ByteArray new: readLimit.
	^ newArray replaceFrom: 1
		to: readLimit
		with: collection
		startingAt: 1.! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'jm 11/4/97 08:25'!
contentsOfEntireFile
	"For compatibility with file streams."

	^ self contents! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'!
isBinary
	^ isBinary! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:07'!
next

	| byte |
	^ isBinary 
			ifTrue: [byte _ super next.
				 byte ifNil: [nil] ifNotNil: [byte asciiValue]]
			ifFalse: [super next].
! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 2/7/2000 15:34'!
next: anInteger 
	"Answer the next anInteger elements of my collection. Must override to get class right."

	| newArray |
	newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [String]) new: anInteger.
	^ self nextInto: newArray! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ls 3/27/2000 22:24'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than n elements have been read."
	"Overriden for efficiency"
	| max |
	max _ (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex+max-1
		with: collection
		startingAt: position+1.
	position _ position + max.
	max = n
		ifTrue:[^aCollection]
		ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 07:38'!
nextPut: charOrByte

	super nextPut: charOrByte asCharacter! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 1/14/1999 20:16'!
padToEndWith: aChar
	"We don't have pages, so we are at the end, and don't need to pad."! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/21/97 13:04'!
reset
	"Set the receiver's position to the beginning of the sequence of objects."

	super reset.
	isBinary ifNil: [isBinary _ false].
	collection class == ByteArray ifTrue: ["Store as String and convert as needed."
		collection _ collection asString.
		isBinary _ true].
! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 10/1/1998 11:54'!
setFileTypeToObject
	"do nothing.  We don't have a file type"! !

!RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 6/20/97 19:47'!
text
	isBinary _ false! !
FormInput subclass: #RadioButtonInput
	instanceVariableNames: 'inputSet state value button '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!

!RadioButtonInput methodsFor: 'access' stamp: 'ls 8/11/1998 19:52'!
valueIfPressed
	^value! !


!RadioButtonInput methodsFor: 'private-initialization' stamp: 'bf 11/4/1999 21:45'!
button: aMorph
	button _ aMorph! !

!RadioButtonInput methodsFor: 'private-initialization' stamp: 'ls 8/11/1998 20:46'!
inputSet: anInputSet  value: aString
	inputSet _ anInputSet.
	value _ aString.
	state _ false.! !


!RadioButtonInput methodsFor: 'button state' stamp: 'ls 8/11/1998 19:51'!
pressed
	^state! !

!RadioButtonInput methodsFor: 'button state' stamp: 'bf 11/4/1999 21:48'!
pressed: aBoolean
	state _ aBoolean.
	self changed: #pressed.
	button ifNotNil: [button step].
	^true! !

!RadioButtonInput methodsFor: 'button state' stamp: 'ls 8/11/1998 20:28'!
toggle
	"my button has been clicked on!!"

	self pressed: self pressed not.
	inputSet  buttonToggled: self.
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RadioButtonInput class
	instanceVariableNames: ''!

!RadioButtonInput class methodsFor: 'instance creation' stamp: 'ls 8/11/1998 20:47'!
inputSet: anInputSet  value: aString
	^self new inputSet: anInputSet  value: aString
! !
FormInput subclass: #RadioButtonSetInput
	instanceVariableNames: 'name buttons defaultButton '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!

!RadioButtonSetInput methodsFor: 'private-initialization' stamp: 'ls 8/11/1998 20:25'!
name: aString
	name _ aString.
	buttons _ OrderedCollection new.! !


!RadioButtonSetInput methodsFor: 'testing' stamp: 'ls 8/11/1998 20:43'!
isRadioButtonSetInput
	^true! !


!RadioButtonSetInput methodsFor: 'access' stamp: 'ls 8/11/1998 20:48'!
addInput: buttonInput
	buttons add: buttonInput! !

!RadioButtonSetInput methodsFor: 'access' stamp: 'ls 8/11/1998 20:30'!
defaultButton: aButton
	"set which button to toggle on after a reset"
	defaultButton _ aButton! !

!RadioButtonSetInput methodsFor: 'access' stamp: 'ls 8/11/1998 20:24'!
name
	^name! !


!RadioButtonSetInput methodsFor: 'input handling' stamp: 'bolot 11/3/1999 20:40'!
active
	"we are active if and only if one of our buttons is pressed"
	self name isNil
		ifTrue: [^false].
	buttons do: [ :b |
		b pressed ifTrue: [ ^true ] ].
	^false! !

!RadioButtonSetInput methodsFor: 'input handling' stamp: 'ls 8/11/1998 20:27'!
buttonToggled: aButton
	"a button was toggled; turn all other buttons off"
	buttons do: [ :b |
		b == aButton ifFalse: [
			b pressed: false  ] ].! !

!RadioButtonSetInput methodsFor: 'input handling' stamp: 'ls 8/11/1998 20:30'!
reset
	buttons do: [ :b |
		b pressed: (b == defaultButton) ].
! !

!RadioButtonSetInput methodsFor: 'input handling' stamp: 'ls 8/11/1998 20:31'!
value
	buttons do: [ :b |
		b pressed ifTrue: [ ^b valueIfPressed ] ].
	self error: 'asked for value when inactive!!'.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RadioButtonSetInput class
	instanceVariableNames: ''!

!RadioButtonSetInput class methodsFor: 'instance creation' stamp: 'ls 8/11/1998 20:29'!
name: aString
	^self new name: aString! !
Object subclass: #Random
	instanceVariableNames: 'seed a m q r '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!Random commentStamp: '<historical>' prior: 0!
This Random Number Generator graciously contributed by David N. Smith.  It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic.!


!Random methodsFor: 'initialization' stamp: 'di 8/6/1999 15:32'!
initialize
	" Set a reasonable Park-Miller starting seed "
	[seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash.
	seed = 0] whileTrue: ["Try again if ever get a seed = 0"].

	a := 16r000041A7 asFloat.    " magic constant =      16807 "
	m := 16r7FFFFFFF asFloat.    " magic constant = 2147483647 "
	q := (m quo: a) asFloat.
	r  := (m \\ a) asFloat.
! !

!Random methodsFor: 'initialization' stamp: 'sma 5/12/2000 12:29'!
seed: anInteger 
	seed _ anInteger! !


!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'!
next
	"Answer a random Float in the interval [0 to 1)."

	^ (seed _ self nextValue) / m! !

!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:45'!
next: anInteger
	^ self next: anInteger into: (Array new: anInteger)! !

!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:46'!
next: anInteger into: anArray
	1 to: anInteger do: [:index | anArray at: index put: self next].
	^ anArray! !

!Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'!
nextInt: anInteger
	"Answer a random integer in the interval [1, anInteger]."

	^ (self next * anInteger) truncated + 1! !


!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'!
check: nDice
	"Roll some dice, WoD-style."

	^ self check: nDice difficulty: 6! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:47'!
check: nAttack against: nDefend
	"Roll some dice, WoD-style."

	^ self check: nAttack against: nDefend difficulty: 6! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:46'!
check: nAttack against: nDefend difficulty: diff
	"Roll some dice, WoD-style."

	| attacks defends |
	attacks _ self check: nAttack difficulty: diff.
	attacks < 0 ifTrue: [^ attacks].
	defends _ self check: nDefend difficulty: diff.
	^ attacks - defends min: 0! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'!
check: nDice difficulty: diff
	"Roll some dice, WoD-style."

	| result die |
	result _ 0.
	nDice timesRepeat: 
		[(die _ self nextInt: 10) = 1
			ifTrue: [result _ result - 1]
			ifFalse: [die >= diff ifTrue: [result _ result + 1]]].
	^ result! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:48'!
diceToken: stream
	"Private. Mini scanner, see #roll:"

	stream atEnd ifTrue: [^ nil].
	stream peek isDigit ifTrue: [^ Number readFrom: stream].
	^ stream next asLowercase! !

!Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:37'!
roll: diceString
	"Roll some dice, DnD-style, according to this mini-grammar:
		dice _ epxr {pm expr}
		pm _ '+' | '-'
		expr _ num | num dD | dD numP | num dD numP
		dD _ 'd' | 'D'
		num _ digit+
		numP _ num | '%'"

	| stream op result dice range res token |
	stream _ diceString readStream.
	result _ 0.
	op _ #+.
	[token _ self diceToken: stream.
	token isNumber
		ifTrue: [dice _ token.
				token _ self diceToken: stream]
		ifFalse: [token == $d
			ifTrue: [dice _ 1]
			ifFalse: [res _ 0]].
	token == $d
		ifTrue: [token _ self diceToken: stream.
				token isNumber
					ifTrue: [range _ token.
							token _ self diceToken: stream]
					ifFalse: [token == $%
						ifTrue: [range _ 100.
								token _ self diceToken: stream]
						ifFalse: [range _ 6]].
				res _ 0.
				dice timesRepeat: [res _ res + (self nextInt: range)]].
	result _ result perform: op with: res.
	token ifNil: [^ result].
	(token == $+ or: [token == $-])
		ifFalse: [self error: 'unknown token ' , token].
	op _ token asSymbol] repeat! !


!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:28'!
nextValue
	"This method generates random instances of Integer 	in the interval
	0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends
	answer the same value.
	The algorithm is described in detail in 'Random Number Generators: 
	Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller 
	(Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988)."

	| lo hi aLoRHi answer |
	hi _ (seed quo: q) asFloat.
	lo _ seed - (hi * q).  " = seed rem: q"  
	aLoRHi _ (a * lo) - (r * hi).
	answer _ (aLoRHi > 0.0)
		ifTrue:  [aLoRHi]
		ifFalse: [aLoRHi + m].
	^ answer! !

!Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:43'!
seed
	^ seed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Random class
	instanceVariableNames: ''!

!Random class methodsFor: 'examples' stamp: 'sma 5/12/2000 12:39'!
example
	"If you just want a quick random integer, use:
		10 atRandom
	Every integer interval can give a random number:
		(6 to: 12) atRandom
	SequenceableCollections can give randomly selected elements:
		'pick one of these letters randomly' atRandom
	SequenceableCollections also respond to shuffled, as in:
		($A to: $Z) shuffled

	The correct way to use class Random is to store one in 
	an instance or class variable:
		myGenerator _ Random new.
	Then use it every time you need another number between 0.0 and 1.0 (excluding)
		myGenerator next
	You can also generate a positive integer
		myGenerator nextInt: 10
"! !


!Random class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 12:36'!
new
	^ super new initialize! !

!Random class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 12:41'!
seed: anInteger
	^ self new initialize seed: anInteger! !


!Random class methodsFor: 'testing'!
bucketTest: randy
	"Execute this:   Random bucketTest: Random new"
	" A quick-and-dirty bucket test. Prints nbuckets values on the
Transcript.
	  Each should be 'near' the value of ntries. Any run with any value
'far' from ntries
	  indicates something is very wrong. Each run generates different
values.
	  For a slightly better test, try values of nbuckets of 200-1000 or
more; go get coffee.
	  This is a poor test; see Knuth.   Some 'OK' runs:
		1000 1023 998 969 997 1018 1030 1019 1054 985 1003
		1011 987 982 980 982 974 968 1044 976
		1029 1011 1025 1016 997 1019 991 954 968 999 991
		978 1035 995 988 1038 1009 988 993 976
"
	| nbuckets buckets ntrys slot |
	nbuckets := 20.
	buckets := Array new: nbuckets.
	buckets atAllPut: 0.
	ntrys :=  100.
	ntrys*nbuckets timesRepeat: [
		slot := (randy next * nbuckets) floor + 1.
		buckets at: slot put: (buckets at: slot) + 1 ].
	Transcript cr.
	1 to: nbuckets do: [ :nb |
		Transcript show: (buckets at: nb) printString, ' ' ]! !

!Random class methodsFor: 'testing'!
theItsCompletelyBrokenTest
	"Random theItsCompletelyBrokenTest"
	"The above should print as...
	(0.149243269650845 0.331633021743797 0.75619644800024 0.393701540023881 0.941783181364547 0.549929193942775 0.659962596213428 0.991354559078512 0.696074432551896 0.922987899707159 )
	If they are not these values (accounting for precision of printing) then something is horribly wrong: DO NOT USE THIS CODE FOR ANYTHING. "
	| rng |
	rng := Random new.
	rng seed: 2345678901.
	^ (1 to: 10) collect: [:i | rng next]! !
Envelope subclass: #RandomEnvelope
	instanceVariableNames: 'rand lowLimit highLimit delta '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RandomEnvelope methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:15'!
initialize

	rand _ Random new.
	lowLimit _ 0.994.
	highLimit _ 1.006.
	delta _ 0.0002.
	currValue _ 1.0.
	scale _ 1.0.
! !


!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:18'!
centerPitch: aNumber
	"If this envelope controls pitch, set its scale to the given number. Otherwise, do nothing."

	updateSelector = #pitch: ifTrue: [self scale: aNumber].
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
delta

	^ delta
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
delta: aNumber

	delta _ aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
highLimit

	^ highLimit
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
highLimit: aNumber

	highLimit _ aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:05'!
lowLimit

	^ lowLimit
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:06'!
lowLimit: aNumber

	lowLimit _ aNumber.
! !

!RandomEnvelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:17'!
volume: aNumber
	"If this envelope controls volume, set its scale to the given number. Otherwise, do nothing."

	updateSelector = #volume: ifTrue: [self scale: aNumber].
! !


!RandomEnvelope methodsFor: 'applying' stamp: 'jm 8/13/1998 18:25'!
updateTargetAt: mSecs
	"Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."

	| r |
	r _ rand next.
	r > 0.5
		ifTrue: [
			currValue _ currValue + delta.
			currValue > highLimit ifTrue: [currValue _ highLimit]]
		ifFalse: [
			currValue _ currValue - delta.
			currValue < lowLimit ifTrue: [currValue _ lowLimit]].
	currValue = lastValue ifTrue: [^ false].
	((target == nil) or: [updateSelector == nil]) ifTrue: [^ false].
	target
		perform: updateSelector
		with: scale * currValue.
	lastValue _ currValue.
	^ true
! !


!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:29'!
duration

	^ 1.0
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:25'!
duration: seconds
	"Do nothing."
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 1/14/1999 13:17'!
name

	^ 'random ', updateSelector
! !

!RandomEnvelope methodsFor: 'envelope compatibility' stamp: 'jm 8/13/1998 17:30'!
sustainEnd: seconds
	"Do nothing."
! !


!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'JMV 1/9/2001 13:03'!
points

	| env |
	points isNil ifTrue: [
		env _ self target envelopes first.
		points _ OrderedCollection new.
		points
			add: 0@(self delta * 5 + 0.5);
			add: (env points at: env loopStartIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points at: env loopEndIndex)x@(self highLimit -1 * 5 + 0.5);
			add: (env points last)x@(self lowLimit -1 * 5 + 0.5).
		loopStartIndex _ 2.
		loopEndIndex _ 3.
	].
	^points! !

!RandomEnvelope methodsFor: 'envelopeEditor compatibility' stamp: 'JMV 1/9/2001 13:08'!
setPoints: pointList loopStart: startIndex loopEnd: endIndex

	self delta: pointList first y - 0.5 / 5.
	self highLimit: (pointList at: startIndex) y - 0.5 / 5 + 1.
	self lowLimit: pointList last y - 0.5 / 5 + 1.
	^super setPoints: pointList loopStart: startIndex loopEnd: endIndex! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RandomEnvelope class
	instanceVariableNames: ''!

!RandomEnvelope class methodsFor: 'instance creation' stamp: 'jm 8/13/1998 18:21'!
for: aSelector
	"Answer a random envelope for the given selector."

	^ self new updateSelector: aSelector
! !

!RandomEnvelope class methodsFor: 'instance creation' stamp: 'jm 8/13/1998 17:09'!
new

	^ super new initialize
! !
TileMorph subclass: #RandomNumberTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!RandomNumberTile methodsFor: 'initialization' stamp: 'sw 3/23/1999 21:19'!
initialize
	| m1 m2 |
	super initialize.
	self typeColor: (ScriptingSystem colorForType: #number).
	self addArrows.
	m1 _ StringMorph contents: 'random' font: ScriptingSystem fontForTiles.
	self addMorph: m1.
	m2 _ UpdatingStringMorph contents: '180' font: ScriptingSystem fontForTiles.
	m2 target: self; getSelector: #literal; putSelector: #literal:.
	m2 position: m1 topRight.
	self addMorphBack: m2.
	literal _ 180.
	self updateLiteralLabel! !

!RandomNumberTile methodsFor: 'initialization' stamp: 'sw 3/24/2000 00:43'!
labelMorph
	^ submorphs detect: [:m | m isKindOf: UpdatingStringMorph] ifNone: [nil].! !


!RandomNumberTile methodsFor: 'code generation' stamp: 'sw 6/25/1998 17:45'!
storeCodeOn: aStream indent: tabCount
	aStream
			nextPut: $(;
			nextPutAll: literal printString;
			nextPutAll: ' atRandom)'.! !


!RandomNumberTile methodsFor: 'value & label' stamp: 'sw 6/25/1998 17:44'!
numericValue
	^ super numericValue atRandom! !

!RandomNumberTile methodsFor: 'value & label' stamp: 'tk 8/14/2000 23:23'!
updateLiteralLabel
	| myReadout |
	(myReadout _ self labelMorph) ifNil: [^ self].
	myReadout contents: literal stringForReadout.
! !
MailDBFile subclass: #ReadNewsInboxFile
	instanceVariableNames: 'currentNewsgroup msgBuffer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!ReadNewsInboxFile commentStamp: '<historical>' prior: 0!
I am a parser for news files in the format output by the Unix 'readnews' program.
!


!ReadNewsInboxFile methodsFor: 'read-write'!
readFrom: aStream
	"This operation is a noop for news inboxes. Use 'messagesDo:' to enumerate the messages in the inbox."! !

!ReadNewsInboxFile methodsFor: 'read-write'!
writeOn: aStream
	"This operation is illegal for news inboxes."

	self error: 'News inboxes are read only!!'! !


!ReadNewsInboxFile methodsFor: 'scanning'!
allDashes: aString
	"Answer true if the given string is not empty and consists entirely of dash characters."

	(aString isEmpty) ifTrue: [^false].
	aString detect: [: ch | ch ~= $-] ifNone: [^true].
	^false	"we must have detected a non-dash"! !

!ReadNewsInboxFile methodsFor: 'scanning'!
appendLine: aString
	"Append the given line to the buffer."

	msgBuffer nextPutAll: aString; cr.! !

!ReadNewsInboxFile methodsFor: 'scanning'!
endOfArticleDo: aBlock
	"We've just hit the end of an article. Evaluate the given block on the article we've been accumulating in the buffer (if any) and reset the buffer for the next article."

	| msgText end |
	"get text and remove trailing separators (blanks, cr's, etc)"
	msgText _ msgBuffer contents.
	end _ msgText size.
	[(end > 0) and: [(msgText at: end) isSeparator]] whileTrue: [end _ end - 1].
	(end > 1) ifTrue:
		[aBlock value: currentNewsgroup value: (msgText copyFrom: 1 to: end)].
	msgBuffer reset.	"reset the buffer for the next message"! !

!ReadNewsInboxFile methodsFor: 'scanning'!
newsMessagesDo: aBlock
	"Invoke the given block for each message in the news inbox file. The block arguments are the newsgroup name and the text of a new message."

	| fileStream stream |
	fileStream _ FileStream fileNamed: filename.
	(fileStream size < 50000)
		ifTrue:
			["for small inboxes, buffer the entire file in memory for speed"
			 stream _ ReadStream on: (fileStream contentsOfEntireFile)]
		ifFalse:
			["otherwise, use the actual file stream, reading from disk"
			 stream _ fileStream].
	self parse: stream do: aBlock.
	fileStream close.! !

!ReadNewsInboxFile methodsFor: 'scanning'!
parse: aStream do: aBlock
	"Parse the given stream into newsgroup articles, invoking the given block once for each article in the stream. The stream is divided into articles by two kinds of delimiters. The first kind indicates the start of a new newsgroup and includes the newsgroup name. The second kind indicates the start of a new article within a newsgroup."

	| done line nextLine |
	currentNewsgroup _ 'unknown newsgroup'.
	msgBuffer _ WriteStream on: (String new: 5000).
	done _ false.
	[done] whileFalse:
		[(aStream atEnd) ifTrue:
			["end of stream"
			 self endOfArticleDo: aBlock.
			 done _ true].
		 line _ MailDB readStringLineFrom: aStream.
		 (self allDashes: line) ifTrue:	"leading line of dashes"
			["could be a newsgroup header"
			 nextLine _ MailDB readStringLineFrom: aStream.
			 ((nextLine size >= 10) and:
			  [(nextLine copyFrom: 1 to: 10) = 'Newsgroup '])
				ifTrue:
					["yep, it is a newsgroup header"
					 self endOfArticleDo: aBlock.
					 self setNewsGroup: nextLine.
					 MailDB skipRestOfLine: aStream.	"skip trailing line of dashes"
					 MailDB skipRestOfLine: aStream.	"skip blank line"
					 MailDB skipRestOfLine: aStream.	"skip next article delimiter"
					 line _ MailDB readStringLineFrom: aStream]
				ifFalse:
					["nope, it's not a newsgroup header"
					 self appendLine: line.
					 line _ nextLine]].
		 (self startOfArticle: line) ifTrue:
			[self endOfArticleDo: aBlock.
			 line _ MailDB readStringLineFrom: aStream].
		 self appendLine: line].	"normal line: append it to the message buffer"! !

!ReadNewsInboxFile methodsFor: 'scanning'!
setNewsGroup: aLine
	"Set the current newsgroup name from the given line of text, which is of the form:
		Newsgroup comp.lang.smalltalk"

	(aLine size > 11)
		ifTrue: [currentNewsgroup _ aLine copyFrom: 11 to: aLine size]
		ifFalse: [currentNewsgroup _ 'unknown newsgroup'].! !

!ReadNewsInboxFile methodsFor: 'scanning'!
startOfArticle: aString
	"Answer true if the given string is the start of a new news article. That is, does it start with the string 'Article ' and end with a period?"

	^((aString size >= 8) and:
	   [((aString copyFrom: 1 to: 8) = 'Article ') & (aString last = $.)])! !
PluggableTextController subclass: #ReadOnlyTextController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Pluggable Views'!

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 13:41'!
accept 
	"Overridden to allow accept of clean text"
	(view setText: paragraph text from: self) ifTrue:
		[initialText _ paragraph text copy.
		view ifNotNil: [view hasUnacceptedEdits: false]].
! !

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 14:02'!
userHasEdited
	"Ignore this -- I stay clean"! !

!ReadOnlyTextController methodsFor: 'as yet unclassified' stamp: 'di 5/7/1998 13:45'!
zapSelectionWith: aText
	view flash  "no edits allowed"! !
PositionableStream subclass: #ReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!ReadStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only read objects from the sequence.!


!ReadStream methodsFor: 'accessing'!
ascii! !

!ReadStream methodsFor: 'accessing'!
binary! !

!ReadStream methodsFor: 'accessing'!
next
	"Primitive. Answer the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 65>
	position >= readLimit
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:46'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |

	endPosition _ position + anInteger  min:  readLimit.
	ans _ collection copyFrom: position+1 to: endPosition.
	position _ endPosition.
	^ans
! !

!ReadStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:01'!
next: n into: aCollection startingAt: startIndex
	"Read n objects into the given collection. 
	Return aCollection or a partial copy if less than
	n elements have been read."
	| max |
	max _ (readLimit - position) min: n.
	aCollection 
		replaceFrom: startIndex 
		to: startIndex+max-1
		with: collection
		startingAt: position+1.
	position _ position + max.
	max = n
		ifTrue:[^aCollection]
		ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! !

!ReadStream methodsFor: 'accessing'!
nextPut: anObject

	self shouldNotImplement! !

!ReadStream methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:20'!
size
	"Compatibility with other streams (e.g., FileStream)"
	^readLimit! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'!
upTo: anObject
	"fast version using indexOf:"
	| start end |

	start _ position+1.
	end _ collection indexOf: anObject startingAt: start ifAbsent: [ 0 ].

	"not present--return rest of the collection"	
	end = 0 ifTrue: [ ^self upToEnd ].

	"skip to the end and return the data passed over"
	position _ end.
	^collection copyFrom: start to: (end-1)! !

!ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'!
upToEnd
	| start |

	start _ position+1.
	position _ collection size.
	^collection copyFrom: start to: position! !


!ReadStream methodsFor: 'private'!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection _ aCollection.
	readLimit _  lastIndex > (len _ collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position _ firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReadStream class
	instanceVariableNames: ''!

!ReadStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer with a new instance streaming over a copy of aCollection from
	firstIndex to lastIndex."

	^self basicNew
		on: aCollection
		from: firstIndex
		to: lastIndex! !
WriteStream subclass: #ReadWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!ReadWriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects. My instances can both read and store objects.!


!ReadWriteStream methodsFor: 'accessing'!
contents
	"Answer with a copy of my collection from 1 to readLimit."

	readLimit _ readLimit max: position.
	^collection copyFrom: 1 to: readLimit! !

!ReadWriteStream methodsFor: 'accessing'!
name
	^ 'a stream'   "for fileIn compatibility"! !

!ReadWriteStream methodsFor: 'accessing'!
next
	"Primitive. Return the next object in the Stream represented by the
	receiver. Fail if the collection of this stream is not an Array or a String.
	Fail if the stream is positioned at its end, or if the position is out of
	bounds in the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 65>
	"treat me as a FIFO"
	position >= readLimit
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]! !

!ReadWriteStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:47'!
next: anInteger 
	"Answer the next anInteger elements of my collection.  overriden for efficiency"

	| ans endPosition |

	endPosition _ position + anInteger  min:  readLimit.
	ans _ collection copyFrom: position+1 to: endPosition.
	position _ endPosition.
	^ans
! !


!ReadWriteStream methodsFor: 'file status'!
close
	"Presumably sets the status of the receiver to be closed. This message does 
	nothing at this level, but is included for FileStream compatibility."

	^self! !

!ReadWriteStream methodsFor: 'file status'!
closed
	"If you have close (for FileStream compatibility), you must respond to closed.  The result in nonsense here.  TK 29 May 96"

	^ false! !


!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'di 7/17/97 16:12'!
fileInObjectAndCode
	"This file may contain:
1) a fileIn of code  
2) just an object in SmartReferenceStream format 
3) both code and an object.
	File it in and return the object.  Note that self must be a FileStream or RWBinaryOrTextStream.  Maybe ReadWriteStream incorporate RWBinaryOrTextStream?"
	| refStream object |
	self text.
	self peek asciiValue = 4
		ifTrue: [  "pure object file"
			refStream _ SmartRefStream on: self.
			object _ refStream nextAndClose]
		ifFalse: [  "objects mixed with a fileIn"
			self fileIn.  "reads code and objects, then closes the file"
			object _ SmartRefStream scannedObject].	"set by side effect of one of the chunks"
	SmartRefStream scannedObject: nil.  "clear scannedObject"
	^ object! !

!ReadWriteStream methodsFor: 'fileIn/Out'!
fileNameEndsWith: aString
	"See comment in FileStream fileNameEndsWith:"

	^false! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'RAA 12/22/2000 11:16'!
fileOutChangeSet: aChangeSetOrNil andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	"An experimental version to fileout a changeSet first so that a project can contain its own classes"


	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self header; timeStamp.

	aChangeSetOrNil ifNotNil: [
		aChangeSetOrNil fileOutOn: self.
	].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"

	"Append the object's raw data"
	(SmartRefStream on: self)
		nextPut: theObject;  "and all subobjects"
		close.		"also closes me"
! !

!ReadWriteStream methodsFor: 'fileIn/Out'!
fileOutChanges
	"Append to the receiver a description of all class changes."
	Cursor write showWhile:
		[self header; timeStamp.
		Smalltalk changes fileOutOn: self.
		self trailer; close]! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'tk 3/11/98 09:40'!
fileOutClass: extraClass andObject: theObject
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically."

	| class srefStream |
	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self header; timeStamp.

	extraClass ifNotNil: [
		class _ extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue:
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: self moveSource: false toFile: 0].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"

	"Append the object's raw data"
	srefStream _ SmartRefStream on: self.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me"
! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'tk 3/13/98 22:25'!
fileOutClass: extraClass andObject: theObject blocking: anIdentDict
	"Write a file that has both the source code for the named class and an object as bits.  Any instance-specific object will get its class written automatically.  Accept a list of objects to map to nil or some other object (blockers).  In addition to teh choices in each class's objectToStoreOnDataStream"

	| class srefStream |
	self setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	self header; timeStamp.

	extraClass ifNotNil: [
		class _ extraClass.	"A specific class the user wants written"
		class sharedPools size > 0 ifTrue:
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: self moveSource: false toFile: 0].
	self trailer.	"Does nothing for normal files.  HTML streams will have trouble with object data"

	"Append the object's raw data"
	srefStream _ SmartRefStream on: self.
	srefStream blockers: anIdentDict.
	srefStream nextPut: theObject.  "and all subobjects"
	srefStream close.		"also closes me"
! !

!ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'di 7/14/97 22:57'!
timeStamp
	"Append the current time to the receiver as a String."
	self nextChunkPut:	"double string quotes and !!s"
		(String streamContents: [:s | Smalltalk timeStamp: s]) printString.
	self cr! !


!ReadWriteStream methodsFor: 'converting' stamp: 'tk 3/22/2000 18:03'!
asUnZippedStream
	| isGZip outputStream first |
	"Decompress this file if needed, and return a stream.  No file is written.  File extension may be .gz or anything else."

	self binary.
	first _ self next.
	isGZip _ (self next * 256 + first) = (GZipConstants at: #GZipMagic).
	self skip: -2.
	isGZip 
		ifTrue: [outputStream _ (RWBinaryOrTextStream with:
					(GZipReadStream on: self) upToEnd) reset.
				self close]
		ifFalse: [outputStream _ self].
	^ outputStream! !
Object subclass: #RealEstateAgent
	instanceVariableNames: ''
	classVariableNames: 'ReverseStaggerOffset StaggerOffset StaggerOrigin StandardSize StandardWindowOrigins '
	poolDictionaries: ''
	category: 'System-Support'!
!RealEstateAgent commentStamp: '<historical>' prior: 0!
Responsible for real-estate management on the screen, which is to say, controlling where new windows appear, with what sizes, etc.  5/20/96 sw!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RealEstateAgent class
	instanceVariableNames: ''!

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 6/14/2000 19:22'!
assignCollapseFrameFor: aSSView 
        "Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames."
        | grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top |
        grid _ 8.
        verticalBorderDistance _ 8.
        aSSView isMorph ifTrue: [
                otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | w ~= aSSView])
                                                collect: [:w | w collapsedFrame]
                                                thenSelect: [:rect | rect notNil].
                        viewBox _ aSSView world viewBox]
                ifFalse: 
                        [otherFrames _ ScheduledControllers scheduledWindowControllers
                                                collect: [:aController | aController view ~= aSSView ifTrue: [aController view collapsedFrame]]
                                                thenSelect: [:rect | rect notNil].
                        viewBox _ Display boundingBox].
        collapsedFrame _ aSSView collapsedFrame.
        extent _ collapsedFrame notNil
                                ifTrue: [collapsedFrame extent]
                                ifFalse: [aSSView isMorph
                                        ifTrue: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)]
                                        ifFalse: [(aSSView labelText extent x + 70) @ aSSView labelHeight
                                                        min: aSSView labelDisplayBox extent
                                        ]
                                ].
        collapsedFrame notNil
                ifTrue: [(otherFrames anySatisfy: [:f | collapsedFrame intersects: f])
                                ifFalse: ["non overlapping"
                                        ^ collapsedFrame]].
        top _ viewBox top + verticalBorderDistance.
        [topLeft _ viewBox left @ top.
        newFrame _ topLeft extent: extent.
        newFrame bottom <= (viewBox height - verticalBorderDistance)]
                whileTrue: 
                        [(otherFrames anySatisfy: [:w | newFrame intersects: w])
                                ifFalse: ["no overlap"
                                        ^ newFrame].
                        top _ top + grid].
        "If all else fails... (really to many wins here)"
        ^ 0 @ 0 extent: extent! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 6/14/2000 19:22'!
assignCollapsePointFor: aSSView
        "Offer up a location along the left edge of the screen for a collapsed SSView.
        Make sure it doesn't overlap any other collapsed frames."
        | grid otherFrames y free topLeft viewBox |
        grid _ 24.  "should be mult of 8, since manual move is gridded by 8"
        aSSView isMorph
                ifTrue: [otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | true])
                                        collect: [:w | w collapsedFrame]
                                        thenSelect: [:rect | rect notNil].
                                viewBox _ aSSView world viewBox]
                ifFalse: [otherFrames _ ScheduledControllers scheduledWindowControllers
                                        collect: [:aController | aController view collapsedFrame]
                                        thenSelect: [:rect | rect notNil].
                                viewBox _ Display boundingBox].
        y _ viewBox top.
        [(y _ y + grid) <= (viewBox height - grid)]
                whileTrue:
                [topLeft _ viewBox left@y.
                free _ true.
                otherFrames do: [:w | free _ free & (topLeft ~= w topLeft)].
                free ifTrue: [^ topLeft]].
        "If all else fails..."
        ^ 0 @ 0! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:17'!
initialFrameFor: aView
	"Find a plausible initial screen area for the supplied view.  See called method."

	self error: 'please use #initialFrameFor:world:'! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:18'!
initialFrameFor: aView initialExtent: initialExtent

	self error: 'please use #initialFrameFor:initialExtent:world:'! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 09:14'!
initialFrameFor: aView initialExtent: initialExtent world: aWorld
	"Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen."

	| allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames |

	Preferences reverseWindowStagger ifTrue:
		[^ self strictlyStaggeredInitialFrameFor: aView initialExtent: initialExtent world: aWorld].

	allowedArea _ self maximumUsableAreaInWorld: aWorld.
	screenRight _ allowedArea right.
	screenBottom _ allowedArea bottom.

	otherFrames _ Smalltalk isMorphic
		ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not])
					collect: [:w | w bounds]]
		ifFalse: [ScheduledControllers scheduledWindowControllers
				select: [:aController | aController view ~~ nil]
				thenCollect: [:aController | aController view isCollapsed
								ifTrue: [aController view expandedFrame]
								ifFalse: [aController view displayBox]]].

	allOrigins _ otherFrames collect: [:f | f origin].
	(self standardPositionsInWorld: aWorld) do:  "First see if one of the standard positions is free"
		[:aPosition | (allOrigins includes: aPosition)
			ifFalse:
				[^ (aPosition extent: initialExtent) squishedWithin: allowedArea]].

	staggerOrigin _ (self standardPositionsInWorld: aWorld) first.  "Fallback: try offsetting from top left"
	putativeOrigin _ staggerOrigin.

	[putativeOrigin _ putativeOrigin + StaggerOffset.
	putativeFrame _ putativeOrigin extent: initialExtent.
	(putativeFrame bottom < screenBottom) and:
					[putativeFrame right < screenRight]]
				whileTrue:
					[(allOrigins includes: putativeOrigin)
						ifFalse:
							[^ (putativeOrigin extent: initialExtent) squishedWithin: allowedArea]].
	^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent) squishedWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:13'!
initialFrameFor: aView world: aWorld
	"Find a plausible initial screen area for the supplied view.  See called method."

	^ self initialFrameFor: aView initialExtent: aView initialExtent world: aWorld! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'tk 11/26/1998 09:34'!
initialize
	"Initialize the class variables in the receiver.  5/22/96 sw"
	"RealEstateAgent initialize"

	StaggerOffset _ 6 @ 20.
	ReverseStaggerOffset _ -6 @ 20.
	StaggerOrigin _ 200 @ 30.
	StandardSize _ 600@400.! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 11:06'!
maximumUsableArea

	| allowedArea |
	allowedArea _ Display usableArea.
	Smalltalk isMorphic ifTrue: [
		allowedArea _ allowedArea intersect: Display getCurrentMorphicWorld viewBox
	].
	^allowedArea
! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:42'!
maximumUsableAreaInWorld: aWorldOrNil

	| allowedArea |
	allowedArea _ Display usableArea.
	aWorldOrNil ifNotNil: [allowedArea _ allowedArea intersect: aWorldOrNil viewBox].
	^allowedArea
! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 9/22/1998 20:58'!
screenTopSetback
	Smalltalk isMorphic
		ifTrue: [^ 0]
		ifFalse: [^ 18]! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 9/22/1998 20:58'!
scrollBarSetback
	Smalltalk isMorphic
		ifTrue: [^ 16-3]  "width = 16; inset from border by 3"
		ifFalse: [^ 24]! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:45'!
standardPositions
	
	self error: 'please use #standardPositionsInWorld:'! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:43'!
standardPositionsInWorld: aWorldOrNil
	"Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen.  "

	| anArea aList  midX midY |

	anArea _ self maximumUsableAreaInWorld: aWorldOrNil.

	midX _ self scrollBarSetback +   ((anArea width - self scrollBarSetback)  // 2).
	midY _ self screenTopSetback + ((anArea height - self screenTopSetback) // 2).
	aList _ OrderedCollection with: (self scrollBarSetback @ self screenTopSetback).
	self windowColumnsDesired > 1
		ifTrue:
			[aList add: (midX @ self screenTopSetback)].
	self windowRowsDesired > 1
		ifTrue:
			[aList add: (self scrollBarSetback @ (midY+self screenTopSetback)).
			self windowColumnsDesired > 1 ifTrue:
				[aList add: (midX @ (midY+self screenTopSetback))]].
	^ aList! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:55'!
standardWindowExtent
	"Answer the standard default extent for new windows.  "

	| effectiveExtent width strips height grid allowedArea maxLevel |
	effectiveExtent _ self maximumUsableArea extent
					- (self scrollBarSetback @ self screenTopSetback).
	Preferences reverseWindowStagger ifTrue:
		["NOTE: following copied from strictlyStaggeredInitialFrameFor:"
		allowedArea _ self maximumUsableArea insetBy: (
			self scrollBarSetback @ self screenTopSetback extent: 0@0
		).
		"Number to be staggered at each corner (less on small screens)"
		maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
		"Amount by which to stagger (less on small screens)"
		grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
		^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: StandardSize "600@400"].
	width _ (strips _ self windowColumnsDesired) > 1
		ifTrue:
			[effectiveExtent x // strips]
		ifFalse:
			[(3 * effectiveExtent x) // 4].
	height _ (strips _ self windowRowsDesired) > 1
		ifTrue:
			[effectiveExtent y // strips]
		ifFalse:
			[(3 * effectiveExtent y) //4].
	^ width @ height

"RealEstateAgent standardWindowExtent"! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 09:15'!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent

	self error: 'please use #strictlyStaggeredInitialFrameFor:initialExtent:world:'! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 09:24'!
strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld
	"This method implements a staggered window placement policy that I like.
	Basically it provides for up to 4 windows, staggered from each of the 4 corners.
	The windows are staggered so that there will always be a corner visible.
	"
	| allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel |

	allowedArea _(self maximumUsableAreaInWorld: aWorld) insetBy: (
		self scrollBarSetback @ self screenTopSetback extent: 0@0
	).
	"Number to be staggered at each corner (less on small screens)"
	maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2].
	"Amount by which to stagger (less on small screens)"
	grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20].
	initialFrame _ 0@0 extent: ((initialExtent
							"min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))))
							min: 600@400")).
	otherFrames _ Smalltalk isMorphic
		ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not])
					collect: [:w | w bounds]]
		ifFalse: [ScheduledControllers scheduledWindowControllers
				select: [:aController | aController view ~~ nil]
				thenCollect: [:aController | aController view isCollapsed
								ifTrue: [aController view expandedFrame]
								ifFalse: [aController view displayBox]]].
	0 to: maxLevel do:
		[:level | 
		1 to: 4 do:
			[:ci | cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: ci.
			corner _ allowedArea perform: cornerSel.
			"The extra grid//2 in delta helps to keep title tabs distinct"
			delta _ (maxLevel-level*grid+(grid//2)) @ (level*grid).
			1 to: ci-1 do: [:i | delta _ delta rotateBy: #right centerAt: 0@0]. "slow way"
			putativeCorner _ corner + delta.
			free _ true.
			otherFrames do:
				[:w |
				free _ free & ((w perform: cornerSel) ~= putativeCorner)].
			free ifTrue:
				[^ (initialFrame align: (initialFrame perform: cornerSel)
								with: putativeCorner)
						 squishedWithin: allowedArea]]].
	"If all else fails..."
	^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent)
		squishedWithin: allowedArea! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:54'!
windowColumnsDesired
	"Answer how many separate vertical columns of windows are wanted.  5/22/96 sw"
	^ Preferences reverseWindowStagger
		ifTrue:
			[1]
		ifFalse:
			[(self maximumUsableArea width > 640)
				ifTrue:
					[2]
				ifFalse:
					[1]]! !

!RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:54'!
windowRowsDesired
	"Answer how many separate horizontal rows of windows are wanted.  5/22/96 sw"
	^ Preferences reverseWindowStagger
		ifTrue:
			[1]
		ifFalse:
			[(self maximumUsableArea height > 480)
				ifTrue:
					[2]
				ifFalse:
					[1]]! !
MessageSet subclass: #RecentMessageSet
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!RecentMessageSet methodsFor: 'contents' stamp: 'sw 10/19/1999 17:33'!
contents: c notifying: n
	| result |
	result _ super contents: c notifying: n.
	result == true ifTrue:
		[self reformulateList].
	^ result! !


!RecentMessageSet methodsFor: 'update' stamp: 'sw 1/28/2001 20:59'!
growable
	"Answer whether the receiver can be changed by manual additions & deletions"

	^ false! !

!RecentMessageSet methodsFor: 'update' stamp: 'sw 1/27/2001 12:25'!
reformulateList
	"Reformulate the receiver's list.  Exclude methods now deleted"

	self initializeMessageList: (MessageSet extantMethodsIn: Utilities recentMethodSubmissions reversed).
	self messageListIndex: (messageList size min: 1).	"0 or 1"
	self changed: #messageList.
	self changed: #messageListIndex! !

!RecentMessageSet methodsFor: 'update' stamp: 'RAA 6/20/2000 13:28'!
updateListsAndCodeIn: aWindow

	| recentFromUtilities |
	"RAA 20 june 2000 - a recent change to how messages were displayed in the list caused them not to match what was stored in Utilities. This caused the recent submissions to be continuously updated. The hack below fixed that problem"

	self canDiscardEdits ifFalse: [^ self].
	recentFromUtilities _ Utilities mostRecentlySubmittedMessage asString,' '.
	(messageList first asString beginsWith: recentFromUtilities)
		ifFalse:
			[self reformulateList]
		ifTrue:
			[self updateCodePaneIfNeeded]! !


!RecentMessageSet methodsFor: 'selection'!
maybeSetSelection
	"After a browser's message list is changed, this message is dispatched to the model, to give it a chance to refigure a selection"	
	self messageListIndex: 1! !
AlignmentMorph subclass: #RecordingControlsMorph
	instanceVariableNames: 'recorder recordingStatusLight recordMeter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!RecordingControlsMorph methodsFor: 'initialization' stamp: 'RAA 12/7/2000 11:30'!
addButtonRows

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.


	r addMorphBack: (self buttonName: 'Morph' action: #makeSoundMorph).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Tile' action: #makeTile).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Trim' action: #trim).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Show' action: #show).
	self addMorphBack: r.

	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: (self buttonName: 'Record' action: #record).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' action: #stop).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Play' action: #playback).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!RecordingControlsMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:58'!
initialize

	| r |
	super initialize.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.
	borderWidth _ 2.
	self listDirection: #topToBottom.
	recorder _ SoundRecorder new.
	self addButtonRows.
	self addRecordLevelSlider.

	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: self makeRecordMeter.
	self addMorphBack: r.
	self extent: 10@10.  "make minimum size"
! !


!RecordingControlsMorph methodsFor: 'accessing' stamp: 'jm 9/13/97 17:20'!
recorder

	^ recorder
! !


!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jhm 10/15/97 15:28'!
done

	recorder stopRecording.
	self makeTile.
	self delete.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'RAA 12/7/2000 11:37'!
makeSoundMorph

	| m |

	recorder pause.
	m _ SoundEventMorph new sound: recorder recordedSound.
	self world firstHand attachMorph: m.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'di 6/7/1999 15:46'!
makeTile

	| newStyleTile sndName tile |
	recorder pause.
	newStyleTile _ true.
	newStyleTile
		ifTrue: [
			sndName _ FillInTheBlank
				request: 'Please enter a name this sound'
				initialAnswer: 'sound'.
			sndName isEmpty ifTrue: [^ self].

			sndName _ SampledSound unusedSoundNameLike: sndName.
			SampledSound
				addLibrarySoundNamed: sndName
				samples: recorder condensedSamples
				samplingRate: recorder samplingRate.
			tile _ SoundTile new literal: sndName]
		ifFalse: [
			tile _ InterimSoundMorph new sound: 
				(SampledSound
					samples: recorder condensedSamples
					samplingRate: recorder samplingRate)].

	self world firstHand attachMorph: tile.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jm 10/18/97 11:41'!
playback

	recorder pause.
	recorder playback.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jhm 10/15/97 14:30'!
record

	recorder clearRecordedSound.
	recorder resumeRecording.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jm 8/17/1998 20:35'!
show
	"Show my samples in a WaveEditor."

	| ed w |
	recorder pause.
	ed _ WaveEditor new.
	ed data: recorder condensedSamples.
	ed samplingRate: recorder samplingRate.
	w _ self world.
	w activeHand
		ifNil: [w addMorph: ed]
		ifNotNil: [w activeHand attachMorph: ed].

! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jhm 10/15/97 14:30'!
stop

	recorder pause.
! !

!RecordingControlsMorph methodsFor: 'button commands' stamp: 'jm 11/17/97 18:58'!
trim
	"Show my samples in a GraphMorph."

	recorder pause.
	recorder trim: 1400 normalizedVolume: 80.0.
! !


!RecordingControlsMorph methodsFor: 'stepping' stamp: 'tk 6/24/1999 11:41'!
startStepping
	"Make the level meter active when dropped into the world. Do nothing if already recording. Note that this will cause other recorders to stop recording..."

	super startStepping.
	recorder isPaused ifTrue: [
		SoundRecorder allSubInstancesDo: [:r | r stopRecording].  "stop all other sound recorders"
		recorder pause].  "meter is updated while paused"
! !

!RecordingControlsMorph methodsFor: 'stepping' stamp: 'jm 10/17/97 15:00'!
step

	recorder isPaused
		ifTrue: [recordingStatusLight color: Color transparent]
		ifFalse: [recordingStatusLight color: Color red].
	recordMeter extent: (recorder meterLevel + 1) @ recordMeter height.
! !

!RecordingControlsMorph methodsFor: 'stepping' stamp: 'jm 8/24/97 21:00'!
stepTime

	^ 50
! !

!RecordingControlsMorph methodsFor: 'stepping' stamp: 'jm 10/17/97 15:13'!
stopStepping
	"Turn off recording."

	super stopStepping.
	recorder stopRecording.
! !


!RecordingControlsMorph methodsFor: 'other' stamp: 'ar 11/9/2000 21:21'!
addRecordLevelSlider

	| levelSlider r |
	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: recorder;
		actionSelector: #recordLevel:;
		adjustToValue: recorder recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jhm 10/15/97 14:30'!
buttonName: aString action: aSymbol

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jm 8/24/97 21:31'!
makeRecordMeter

	| outerBox |
	outerBox _ Morph new extent: 102@18; color: Color gray.
	recordMeter _ Morph new extent: 1@16; color: Color yellow.
	recordMeter position: outerBox topLeft + (1@1).
	outerBox addMorph: recordMeter.
	^ outerBox
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jhm 10/15/97 15:06'!
makeStatusLight

	recordingStatusLight _ Morph new extent: 18@18.
	recordingStatusLight color: Color transparent.
	^ recordingStatusLight
! !

!RecordingControlsMorph methodsFor: 'other' stamp: 'jm 10/17/97 15:17'!
updateReferencesUsing: aDictionary
	"Copy my recorder."

	super updateReferencesUsing: aDictionary.
	recorder _ SoundRecorder new.
! !
Object subclass: #Rectangle
	instanceVariableNames: 'origin corner '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!Rectangle commentStamp: '<historical>' prior: 0!
I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.!


!Rectangle methodsFor: 'accessing' stamp: 'acg 2/23/2000 00:52'!
aboveCenter
	"Answer the point slightly above the center of the receiver."

	^self topLeft + self bottomRight // (2@3)! !

!Rectangle methodsFor: 'accessing'!
area
	"Answer the receiver's area, the product of width and height."
	| w |
	(w _ self width) < 0 ifTrue: [^ 0].
	^ w * self height max: 0! !

!Rectangle methodsFor: 'accessing'!
bottom
	"Answer the position of the receiver's bottom horizontal line."

	^corner y! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
bottom: aNumber
	^origin corner: corner x @ aNumber! !

!Rectangle methodsFor: 'accessing'!
bottomCenter
	"Answer the point at the center of the bottom horizontal line of the 
	receiver."

	^self center x @ self bottom! !

!Rectangle methodsFor: 'accessing'!
bottomLeft
	"Answer the point at the left edge of the bottom horizontal line of the 
	receiver."

	^origin x @ corner y! !

!Rectangle methodsFor: 'accessing'!
bottomRight
	"Answer the point at the right edge of the bottom horizontal line of the 
	receiver."

	^corner! !

!Rectangle methodsFor: 'accessing'!
boundingBox
	^ self! !

!Rectangle methodsFor: 'accessing'!
center
	"Answer the point at the center of the receiver."

	^self topLeft + self bottomRight // 2! !

!Rectangle methodsFor: 'accessing'!
corner
	"Answer the point at the bottom right corner of the receiver."

	^corner! !

!Rectangle methodsFor: 'accessing'!
corners
	"Return an array of corner points in the order of a quadrilateral spec for WarpBlt."

	^ Array
		with: self topLeft
		with: self bottomLeft
		with: self bottomRight
		with: self topRight
! !

!Rectangle methodsFor: 'accessing'!
extent
	"Answer with a rectangle with origin 0@0 and corner the receiver's 
	width @ the receiver's height."

	^corner - origin! !

!Rectangle methodsFor: 'accessing'!
height
	"Answer the height of the receiver."

	^corner y - origin y! !

!Rectangle methodsFor: 'accessing'!
innerCorners
	"Return an array of inner corner points,
	ie, the most extreme pixels included,
	in the order of a quadrilateral spec for WarpBlt"
	| r1 |
	r1 _ self topLeft corner: self bottomRight - (1@1).
	^ Array with: r1 topLeft with: r1 bottomLeft with: r1 bottomRight with: r1 topRight! !

!Rectangle methodsFor: 'accessing'!
left
	"Answer the position of the receiver's left vertical line."

	^origin x! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:16'!
left: aNumber
	^aNumber @ origin y corner: corner! !

!Rectangle methodsFor: 'accessing'!
leftCenter
	"Answer the point at the center of the receiver's left vertical line."

	^self left @ self center y! !

!Rectangle methodsFor: 'accessing'!
origin
	"Answer the point at the top left corner of the receiver."

	^origin! !

!Rectangle methodsFor: 'accessing'!
right
	"Answer the position of the receiver's right vertical line."

	^corner x! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
right: aNumber
	^origin corner: aNumber @ corner y! !

!Rectangle methodsFor: 'accessing'!
rightCenter
	"Answer the point at the center of the receiver's right vertical line."

	^self right @ self center y! !

!Rectangle methodsFor: 'accessing'!
top
	"Answer the position of the receiver's top horizontal line."

	^origin y! !

!Rectangle methodsFor: 'accessing' stamp: 'ar 10/26/2000 22:17'!
top: aNumber
	^origin x @ aNumber corner: corner! !

!Rectangle methodsFor: 'accessing'!
topCenter
	"Answer the point at the center of the receiver's top horizontal line."

	^self center x @ self top! !

!Rectangle methodsFor: 'accessing'!
topLeft
	"Answer the point at the top left corner of the receiver's top horizontal line."

	^origin
! !

!Rectangle methodsFor: 'accessing'!
topRight
	"Answer the point at the top right corner of the receiver's top horizontal 
	line."

	^corner x @ origin y! !

!Rectangle methodsFor: 'accessing'!
width
	"Answer the width of the receiver."

	^corner x - origin x! !


!Rectangle methodsFor: 'comparing'!
= aRectangle 
	"Answer true if the receiver's species, origin and corner match aRectangle's."

	self species = aRectangle species
		ifTrue: [^origin = aRectangle origin and: [corner = aRectangle corner]]
		ifFalse: [^false]! !

!Rectangle methodsFor: 'comparing'!
hash
	"Hash is reimplemented because = is implemented."

	^origin hash bitXor: corner hash! !

!Rectangle methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !


!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/22/1998 16:11'!
adjustTo: newRect along: side 
	"Return a copy adjusted to fit a neighbor that has changed size."
	side = #left ifTrue: [^ self withRight: newRect left].
	side = #right ifTrue: [^ self withLeft: newRect right].
	side = #top ifTrue: [^ self withBottom: newRect top].
	side = #bottom ifTrue: [^ self withTop: newRect bottom].! !

!Rectangle methodsFor: 'rectangle functions'!
amountToTranslateWithin: aRectangle
	"Answer a Point, delta, such that self + delta is forced within aRectangle."
	"Altered so as to prefer to keep self topLeft inside when all of self
	cannot be made to fit 7/27/96 di"
	| dx dy |
	dx _ 0.  dy _ 0.
	self right > aRectangle right ifTrue: [dx _ aRectangle right - self right].
	self bottom > aRectangle bottom ifTrue: [dy _ aRectangle bottom - self bottom].
	(self left + dx) < aRectangle left ifTrue: [dx _ aRectangle left - self left].
	(self top + dy) < aRectangle top ifTrue: [dy _ aRectangle top - self top].
	^ dx@dy! !

!Rectangle methodsFor: 'rectangle functions'!
areasOutside: aRectangle
	"Answer an Array of Rectangles comprising the parts of the receiver not 
	intersecting aRectangle."

	| areas yOrigin yCorner |
	"Make sure the intersection is non-empty"
	(origin <= aRectangle corner and: [aRectangle origin <= corner])
		ifFalse: [^Array with: self].
	areas _ OrderedCollection new.
	aRectangle origin y > origin y
		ifTrue: [areas addLast: (origin corner: corner x @ (yOrigin _ aRectangle origin y))]
		ifFalse: [yOrigin _ origin y].
	aRectangle corner y < corner y
		ifTrue: [areas addLast: (origin x @ (yCorner _ aRectangle corner y) corner: corner)]
		ifFalse: [yCorner _ corner y].
	aRectangle origin x > origin x 
		ifTrue: [areas addLast: (origin x @ yOrigin corner: aRectangle origin x @ yCorner)].
	aRectangle corner x < corner x 
		ifTrue: [areas addLast: (aRectangle corner x @ yOrigin corner: corner x @ yCorner)].
	^areas! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:00'!
bordersOn: her along: herSide 
	(herSide = #right and: [self left = her right])
	| (herSide = #left and: [self right = her left])
		ifTrue:
		[^ (self top max: her top) < (self bottom min: her bottom)].
	(herSide = #bottom and: [self top = her bottom])
	| (herSide = #top and: [self bottom = her top])
		ifTrue:
		[^ (self left max: her left) < (self right min: her right)].
	^ false! !

!Rectangle methodsFor: 'rectangle functions'!
encompass: aPoint 
	"Answer a Rectangle that contains both the receiver and aPoint.  5/30/96 sw"

	^ Rectangle 
		origin: (origin min: aPoint)
		corner: (corner max:  aPoint)! !

!Rectangle methodsFor: 'rectangle functions'!
expandBy: delta 
	"Answer a Rectangle that is outset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isKindOf: Rectangle)
		ifTrue: [^Rectangle 
					origin: origin - delta origin 
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin - delta 
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions'!
extendBy: delta 
	"Answer a Rectangle with the same origin as the receiver, but whose corner is offset by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isKindOf: Rectangle)
		ifTrue: [^Rectangle 
					origin: origin
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:11'!
forPoint: aPoint closestSideDistLen: sideDistLenBlock
	"Evaluate the block with my side (symbol) closest to aPoint,
		the approx distance of aPoint from that side, and
		the length of the side (or 0 if aPoint is beyond the side)"
	| side |
	side _ self sideNearestTo: aPoint.
	side == #right ifTrue:
		[^ sideDistLenBlock value: side value: (self right - aPoint x) abs
			value: ((aPoint y between: self top and: self bottom)
						ifTrue: [self height] ifFalse: [0])].
	side == #left ifTrue:
		[^ sideDistLenBlock value: side value: (self left - aPoint x) abs
			value: ((aPoint y between: self top and: self bottom)
						ifTrue: [self height] ifFalse: [0])].
	side == #bottom ifTrue:
		[^ sideDistLenBlock value: side value: (self bottom - aPoint y) abs
			value: ((aPoint x between: self left and: self right)
						ifTrue: [self width] ifFalse: [0])].
	side == #top ifTrue:
		[^ sideDistLenBlock value: side value: (self top - aPoint y) abs
			value: ((aPoint x between: self left and: self right)
						ifTrue: [self width] ifFalse: [0])].! !

!Rectangle methodsFor: 'rectangle functions'!
insetBy: delta 
	"Answer a Rectangle that is inset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isKindOf: Rectangle)
		ifTrue: [^Rectangle 
					origin: origin + delta origin 
					corner: corner - delta corner]
		ifFalse: [^Rectangle 
					origin: origin + delta 
					corner: corner - delta]! !

!Rectangle methodsFor: 'rectangle functions'!
insetOriginBy: originDeltaPoint cornerBy: cornerDeltaPoint 
	"Answer a Rectangle that is inset from the receiver by a given amount in 
	the origin and corner."

	^Rectangle
		origin: origin + originDeltaPoint
		corner: corner - cornerDeltaPoint! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 11/12/2000 19:10'!
intersect: aRectangle 
	"Answer a Rectangle that is the area in which the receiver overlaps with 
	aRectangle. Optimized for speed; old code read:
		^Rectangle 
			origin: (origin max: aRectangle origin)
			corner: (corner min: aRectangle corner)
	"
	| aPoint left right top bottom |
	aPoint _ aRectangle origin.
	aPoint x > origin x ifTrue:[left _ aPoint x] ifFalse:[left _ origin x].
	aPoint y > origin y ifTrue:[top _ aPoint y] ifFalse:[top _ origin y].
	aPoint _ aRectangle corner.
	aPoint x < corner x ifTrue:[right _ aPoint x] ifFalse:[right _ corner x].
	aPoint y < corner y ifTrue:[bottom _ aPoint y] ifFalse:[bottom _ corner y].
	^Rectangle
		origin: (left@top)
		corner: (right@bottom)
! !

!Rectangle methodsFor: 'rectangle functions'!
merge: aRectangle 
	"Answer a Rectangle that contains both the receiver and aRectangle."

	^Rectangle 
		origin: (origin min: aRectangle origin)
		corner: (corner max: aRectangle corner)! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'ar 10/29/2000 02:41'!
outsetBy: delta 
	"Answer a Rectangle that is outset from the receiver by delta. delta is a 
	Rectangle, Point, or scalar."

	(delta isKindOf: Rectangle)
		ifTrue: [^Rectangle 
					origin: origin - delta origin 
					corner: corner + delta corner]
		ifFalse: [^Rectangle 
					origin: origin - delta 
					corner: corner + delta]! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 4/30/1998 11:22'!
pointNearestTo: aPoint
	"Return the point on my border closest to aPoint"
	| side |
	(self containsPoint: aPoint)
		ifTrue:
			[side _ self sideNearestTo: aPoint.
			side == #right ifTrue: [^ self right @ aPoint y].
			side == #left ifTrue: [^ self left @ aPoint y].
			side == #bottom ifTrue: [^ aPoint x @ self bottom].
			side == #top ifTrue: [^ aPoint x @ self top]]
		ifFalse:
			[^ aPoint adhereTo: self]! !

!Rectangle methodsFor: 'rectangle functions'!
quickMerge: aRectangle 
	"Answer the receiver if it encloses the given rectangle or the merge of the two rectangles if it doesn't. THis method is an optimization to reduce extra rectangle creations."

	| useRcvr rOrigin rCorner minX maxX minY maxY |
	useRcvr _ true.
	rOrigin _ aRectangle topLeft.
	rCorner _ aRectangle bottomRight.
	minX _ rOrigin x < origin x ifTrue: [useRcvr _ false. rOrigin x] ifFalse: [origin x].
	maxX _ rCorner x > corner x ifTrue: [useRcvr _ false. rCorner x] ifFalse: [corner x].
	minY _ rOrigin y < origin y ifTrue: [useRcvr _ false. rOrigin y] ifFalse: [origin y].
	maxY _ rCorner y > corner y ifTrue: [useRcvr _ false. rCorner y] ifFalse: [corner y].

	useRcvr
		ifTrue: [^ self]
		ifFalse: [^ Rectangle origin: minX@minY corner: maxX@maxY].
! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/20/97 23:01'!
rectanglesAt: y height: ht
	(y+ht) > self bottom ifTrue: [^ Array new].
	^ Array with: (origin x @ y corner: corner x @ (y+ht))! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 15:09'!
sideNearestTo: aPoint
	| distToLeft distToRight distToTop distToBottom closest side |
	distToLeft _ aPoint x - self left.
	distToRight _ self right - aPoint x.
	distToTop _ aPoint y - self top.
	distToBottom _ self bottom - aPoint y.
	closest _ distToLeft. side _ #left.
	distToRight < closest ifTrue: [closest _ distToRight. side _ #right].
	distToTop < closest ifTrue: [closest _ distToTop. side _ #top].
	distToBottom < closest ifTrue: [closest _ distToBottom. side _ #bottom].
	^ side
"
 | r | r _ Rectangle fromUser.
Display border: r width: 1.
[Sensor anyButtonPressed] whileFalse:
	[(r sideNearestTo: Sensor cursorPoint) , '      ' displayAt: 0@0]
"! !

!Rectangle methodsFor: 'rectangle functions'!
translatedToBeWithin: aRectangle
	"Answer a copy of the receiver that does not extend beyond aRectangle.  7/8/96 sw"

	^ self translateBy: (self amountToTranslateWithin: aRectangle)! !

!Rectangle methodsFor: 'rectangle functions'!
withBottom: y 
	"Return a copy of me with a different bottom y"
	^ origin x @ origin y corner: corner x @ y! !

!Rectangle methodsFor: 'rectangle functions'!
withHeight: height 
	"Return a copy of me with a different height"
	^ origin corner: corner x @ (origin y + height)! !

!Rectangle methodsFor: 'rectangle functions'!
withLeft: x 
	"Return a copy of me with a different left x"
	^ x @ origin y corner: corner x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withRight: x 
	"Return a copy of me with a different right x"
	^ origin x @ origin y corner: x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withSide: side setTo: value  "return a copy with side set to value"
	^ self perform: (#(withLeft: withRight: withTop: withBottom: )
							at: (#(left right top bottom) indexOf: side))
		with: value! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'di 9/8/1999 21:25'!
withSideOrCorner: side setToPoint: newPoint
	"Return a copy with side set to newPoint"

	^ self withSideOrCorner: side setToPoint: newPoint minExtent: 0@0! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:16'!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
	"Return a copy with side set to newPoint"
	^self withSideOrCorner: side setToPoint: newPoint minExtent: minExtent
		limit: ((#(left top) includes: side) ifTrue: [SmallInteger minVal] ifFalse: [SmallInteger maxVal])! !

!Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:07'!
withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: limit
	"Return a copy with side set to newPoint"
	side = #top ifTrue: [^ self withTop: (newPoint y min: corner y - minExtent y max: limit + minExtent y)].
	side = #bottom ifTrue: [^ self withBottom: (newPoint y min: limit - minExtent y max: origin y + minExtent y)].
	side = #left ifTrue: [^ self withLeft: (newPoint x min: corner x - minExtent x max: limit + minExtent x)].
	side = #right ifTrue: [^ self withRight: (newPoint x min: limit - minExtent x max: origin x + minExtent x)].
	side = #topLeft ifTrue: [^ (newPoint min: corner - minExtent) corner: self bottomRight].
	side = #bottomRight ifTrue: [^ self topLeft corner: (newPoint max: origin + minExtent)].
	side = #bottomLeft ifTrue: [^ self topRight rect: ((newPoint x min: corner x - minExtent x) @ (newPoint y max: origin y + minExtent y))].
	side = #topRight ifTrue: [^ self bottomLeft rect: ((newPoint x max: origin x + minExtent x) @ (newPoint y min: corner y - minExtent y))].! !

!Rectangle methodsFor: 'rectangle functions'!
withTop: y 
	"Return a copy of me with a different top y"
	^ origin x @ y corner: corner x @ corner y! !

!Rectangle methodsFor: 'rectangle functions'!
withWidth: width 
	"Return a copy of me with a different width"
	^ origin corner: (origin x + width) @ corner y! !


!Rectangle methodsFor: 'testing'!
containsPoint: aPoint 
	"Answer whether aPoint is within the receiver."

	^origin <= aPoint and: [aPoint < corner]! !

!Rectangle methodsFor: 'testing'!
containsRect: aRect
	"Answer whether aRect is within the receiver (OK to coincide)."

	^ aRect origin >= origin and: [aRect corner <= corner]
! !

!Rectangle methodsFor: 'testing'!
hasPositiveExtent
	^ (corner x > origin x) and: [corner y > origin y]! !

!Rectangle methodsFor: 'testing' stamp: 'ar 9/10/2000 15:29'!
intersects: aRectangle 
	"Answer whether aRectangle intersects the receiver anywhere."
	"Optimized; old code answered:
		(origin max: aRectangle origin) < (corner min: aRectangle corner)"

	| rOrigin rCorner |
	rOrigin _ aRectangle origin.
	rCorner _ aRectangle corner.
	rCorner x <= origin x	ifTrue: [^ false].
	rCorner y <= origin y	ifTrue: [^ false].
	rOrigin x >= corner x	ifTrue: [^ false].
	rOrigin y >= corner y	ifTrue: [^ false].
	^ true
! !

!Rectangle methodsFor: 'testing'!
isTall
	^ self height > self width! !

!Rectangle methodsFor: 'testing'!
isWide
	^ self width > self height! !

!Rectangle methodsFor: 'testing' stamp: 'ar 10/29/2000 19:03'!
isZero
	^origin isZero and:[corner isZero]! !


!Rectangle methodsFor: 'truncation and round off'!
rounded
	"Answer a Rectangle whose origin and corner are rounded."

	^Rectangle origin: origin rounded corner: corner rounded! !

!Rectangle methodsFor: 'truncation and round off'!
truncateTo: grid
	"Answer a Rectangle whose origin and corner are truncated to grid x and grid y."

	^Rectangle origin: (origin truncateTo: grid)
				corner: (corner truncateTo: grid)! !

!Rectangle methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'!
truncated
	"Answer a Rectangle whose origin and corner have any fractional parts removed. Answer the receiver if its coordinates are already integral."

	(origin x isInteger and:
	[origin y isInteger and:
	[corner x isInteger and:
	[corner y isInteger]]])
		ifTrue: [^ self].

	^ Rectangle origin: origin truncated corner: corner truncated
! !


!Rectangle methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Answer a Rectangle that is a translated by aPoint2 - aPoint1."

	^self translateBy: aPoint2 - aPoint1! !

!Rectangle methodsFor: 'transforming'!
centeredBeneath: aRectangle
	 "Move the reciever so that its top center point coincides with the bottom center point of aRectangle.  5/20/96 sw:"

	^ self align: self topCenter with: aRectangle bottomCenter! !

!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 16:24'!
flipBy: direction centerAt: aPoint 
	"Return a copy flipped #vertical or #horizontal, about aPoint."
	^ (origin flipBy: direction centerAt: aPoint)
		rect: (corner flipBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'transforming' stamp: 'tk 10/3/2000 22:43'!
newRectButtonPressedDo: newRectBlock 
	"Track the outline of a new rectangle until mouse button changes.  newFrameBlock produces each new rectangle from the previous.  Only tracks while mouse is down."
	| rect newRect buttonNow |
	buttonNow _ Sensor anyButtonPressed.
	rect _ self.
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	[buttonNow] whileTrue: 
		[Processor yield.
		buttonNow _ Sensor anyButtonPressed.
		newRect _ newRectBlock value: rect.
		newRect = rect ifFalse:
			[Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
			Display border: newRect width: 2 rule: Form reverse fillColor: Color gray.
			rect _ newRect]].
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	^ rect! !

!Rectangle methodsFor: 'transforming'!
newRectFrom: newRectBlock
	"Track the outline of a new rectangle until mouse button changes.
	newFrameBlock produces each new rectangle from the previous"
	| rect newRect buttonStart buttonNow |
	buttonStart _ buttonNow _ Sensor anyButtonPressed.
	rect _ self.
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	[buttonNow == buttonStart] whileTrue: 
		[Processor yield.
		buttonNow _ Sensor anyButtonPressed.
		newRect _ newRectBlock value: rect.
		newRect = rect ifFalse:
			[Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
			Display border: newRect width: 2 rule: Form reverse fillColor: Color gray.
			rect _ newRect]].
	Display border: rect width: 2 rule: Form reverse fillColor: Color gray.
	^ rect! !

!Rectangle methodsFor: 'transforming' stamp: 'di 6/11/97 15:11'!
rotateBy: direction centerAt: aPoint
	"Return a copy rotated #right, #left, or #pi about aPoint"
	^ (origin rotateBy: direction centerAt: aPoint)
		rect: (corner rotateBy: direction centerAt: aPoint)! !

!Rectangle methodsFor: 'transforming'!
scaleBy: scale 
	"Answer a Rectangle scaled by scale, a Point or a scalar."

	^Rectangle origin: origin * scale corner: corner * scale! !

!Rectangle methodsFor: 'transforming'!
scaleFrom: rect1 to: rect2
	"Produce a rectangle stretched according to the stretch from rect1 to rect2"
	^ (origin scaleFrom: rect1 to: rect2)
		corner: (corner scaleFrom: rect1 to: rect2)! !

!Rectangle methodsFor: 'transforming' stamp: 'sw 5/21/96'!
squishedWithin: aRectangle
	"Return an adjustment of the receiver that fits within aRectangle by reducing its size, not by changing its origin.  "

	^ origin corner: (corner min: aRectangle bottomRight)

"(50 @ 50 corner: 160 @ 100) squishedWithin:  (20 @ 10 corner: 90 @ 85)"
! !

!Rectangle methodsFor: 'transforming'!
translateBy: factor 
	"Answer a Rectangle translated by factor, a Point or a scalar."

	^Rectangle origin: origin + factor corner: corner + factor! !



!Rectangle methodsFor: 'printing' stamp: 'RAA 7/31/2000 17:25'!
encodeForRemoteCanvas

	| encoded |

	CanvasEncoder at: 2 count:  1.
	encoded := String new: 16.
	encoded putInteger32: origin x asInteger at: 1.
	encoded putInteger32: origin y asInteger at: 5.
	encoded putInteger32: corner x asInteger at: 9.
	encoded putInteger32: corner y asInteger at: 13.

	^encoded! !

!Rectangle methodsFor: 'printing' stamp: 'RAA 7/31/2000 16:39'!
encodeForRemoteCanvasB

	| encoded |

	encoded := Bitmap new: 4.
	encoded at: 1 put: origin x asInteger.
	encoded at: 2 put: origin y asInteger.
	encoded at: 3 put: corner x asInteger.
	encoded at: 4 put: corner y asInteger.

	^encoded! !

!Rectangle methodsFor: 'printing' stamp: 'mpw 8/9/1930 08:00'!
encodePostscriptOn:aStream 
	aStream write:self origin; print:' '; write:self extent; print:' '.! !

!Rectangle methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	origin printOn: aStream.
	aStream nextPutAll: ' corner: '.
	corner printOn: aStream! !

!Rectangle methodsFor: 'printing' stamp: 'MPW 1/4/1901 08:18'!
propertyListOn: aStream 
	" {x=a; y=b; width=c; height=d} "
	aStream print:'{ x='; write:origin x;
			print:' y='; write:origin y;
			print:' width='; write:self extent x;
			print:' height='; write:self extent y;
			print:'};'.
! !

!Rectangle methodsFor: 'printing'!
storeOn: aStream 
	"printed form is good for storing too"
	self printOn: aStream! !


!Rectangle methodsFor: 'private'!
setOrigin: topLeft corner: bottomRight
	origin _ topLeft.
	corner _ bottomRight! !


!Rectangle methodsFor: 'FMP' stamp: 'RAA 6/1/1999 17:41'!
deltaToEnsureInOrCentered: r extra: aNumber

	| dX dY halfXDiff halfYDiff |
	dX _ dY _ 0.
	halfXDiff _ (r width - self width * aNumber) truncated.
	halfYDiff _ (r height - self height  * aNumber) truncated.
	self left < r left
		ifTrue: [dX _ self left - r left - halfXDiff]
		ifFalse: [self right > r right ifTrue: [dX _ self right - r right + halfXDiff]].
	self top < r top
		ifTrue: [dY _ self top - r top - halfYDiff]
		ifFalse: [self bottom > r bottom ifTrue: [dY _ self bottom - r bottom + halfYDiff]].
	^dX @ dY
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Rectangle class
	instanceVariableNames: ''!

!Rectangle class methodsFor: 'instance creation' stamp: 'tk 3/9/97'!
center: centerPoint extent: extentPoint 
	"Answer an instance of me whose center is centerPoint and width 
	by height is extentPoint.  "

	^self origin: centerPoint - (extentPoint//2) extent: extentPoint! !

!Rectangle class methodsFor: 'instance creation' stamp: 'di 12/1/97 10:42'!
encompassing: listOfPoints
	"A number of callers of encompass: should use this method."
	| topLeft bottomRight |
	topLeft _ bottomRight _ nil.
	listOfPoints do:
		[:p | topLeft == nil
			ifTrue: [topLeft _ bottomRight _ p]
			ifFalse: [topLeft _ topLeft min: p.
					bottomRight _ bottomRight max: p]].
	^ topLeft corner: bottomRight! !

!Rectangle class methodsFor: 'instance creation'!
fromUser
	"Answer an instance of me that is determined by having the user 
	designate the top left and bottom right corners. The gridding for user 
	selection is 1@1."

	^self fromUser: 1 @ 1! !

!Rectangle class methodsFor: 'instance creation'!
fromUser: gridPoint
	"Answer a Rectangle that is determined by having the user 
	designate the top left and bottom right corners. 
	The cursor reamins linked with the sensor, but
	the outline is kept gridded."
	| originRect |
	originRect _ Cursor origin showWhile: 
		[((Sensor cursorPoint grid: gridPoint) extent: 0@0) newRectFrom:
			[:f | (Sensor cursorPoint grid: gridPoint) extent: 0@0]].
	^ Cursor corner showWhile:
		[originRect newRectFrom:
			[:f | f origin corner: (Sensor cursorPoint grid: gridPoint)]]! !

!Rectangle class methodsFor: 'instance creation'!
left: leftNumber right: rightNumber top: topNumber bottom: bottomNumber 
	"Answer an instance of me whose left, right, top, and bottom coordinates 
	are determined by the arguments."

	^ self new setOrigin: leftNumber @ topNumber corner: rightNumber @ bottomNumber! !

!Rectangle class methodsFor: 'instance creation' stamp: 'di 12/1/97 10:36'!
merging: listOfRects
	"A number of callers of merge: should use this method."
	| topLeft bottomRight |
	topLeft _ bottomRight _ nil.
	listOfRects do:
		[:r | topLeft == nil
			ifTrue: [topLeft _ r topLeft.
					bottomRight _ r bottomRight]
			ifFalse: [topLeft _ topLeft min: r topLeft.
					bottomRight _ bottomRight max: r bottomRight]].
	^ topLeft corner: bottomRight! !

!Rectangle class methodsFor: 'instance creation'!
origin: originPoint corner: cornerPoint 
	"Answer an instance of me whose corners (top left and bottom right) are 
	determined by the arguments."

	^self new setOrigin: originPoint corner: cornerPoint! !

!Rectangle class methodsFor: 'instance creation'!
origin: originPoint extent: extentPoint 
	"Answer an instance of me whose top left corner is originPoint and width 
	by height is extentPoint."

	^self new setOrigin: originPoint corner: originPoint + extentPoint! !

!Rectangle class methodsFor: 'instance creation'!
originFromUser: extentPoint 
	"Answer an instance of me that is determined by having the user 
	designate the top left corner. The width and height are determined by 
	extentPoint. The gridding for user selection is 1@1."

	^self originFromUser: extentPoint grid: 1 @ 1! !

!Rectangle class methodsFor: 'instance creation'!
originFromUser: extentPoint grid: gridPoint 
	"Answer an instance of me that is determined by having the user 
	designate the top left corner. The width and height are determined by 
	extentPoint. The gridding for user selection is scaleFactor. Assumes that 
	the sender has determined an extent that is a proper multiple of 
	scaleFactor."

	^ Cursor origin showWhile: 
		[((Sensor cursorPoint grid: gridPoint) extent: extentPoint) newRectFrom:
			[:f | (Sensor cursorPoint grid: gridPoint) extent: extentPoint]].
! !
BorderedMorph subclass: #RectangleMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!


!RectangleMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:13'!
canHaveFillStyles
	"Return true if the receiver can have general fill styles; not just colors.
	This method is for gradually converting old morphs."
	^self class == RectangleMorph "no subclasses"! !

!RectangleMorph methodsFor: 'visual properties' stamp: 'ar 6/25/1999 11:13'!
defaultColor
	"Return the default fill style for the receiver"
	^Color gray! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RectangleMorph class
	instanceVariableNames: ''!

!RectangleMorph class methodsFor: 'as yet unclassified' stamp: 'sw 11/29/1999 22:03'!
roundRectPrototype
	^ self authoringPrototype useRoundedCorners color: Color green; setNameTo: 'RoundRect'! !
BorderedMorph subclass: #ReferenceMorph
	instanceVariableNames: 'referent isHighlighted '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!ReferenceMorph commentStamp: '<historical>' prior: 0!
Serves as a reference to any arbitrary morph; used, for example, as the tab in a tabbed palette  The wrapper intercepts mouse events and fields them, passing them on to their referent morph.!


!ReferenceMorph methodsFor: 'misc' stamp: 'sw 10/30/2000 11:11'!
borderWidth: aWidth
	"Set the receiver's border width as indicated, and trigger a fresh layout"

	super borderWidth: aWidth.
	self layoutChanged! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 2/11/1999 14:11'!
fitContents
	submorphs size == 1 ifTrue:
		[self extent: submorphs first extent + (2 * self borderWidth).
		submorphs first position: self position + self borderWidth]! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/2/1998 17:21'!
highlight
	| str |
	isHighlighted _ true.
	submorphs size > 0
		ifTrue:
			[((str _ submorphs first) isKindOf: StringMorph)
				ifTrue:
					[str color: self highlightColor]
				ifFalse:
					[self borderWidth: 1; borderColor: self highlightColor]]! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 3/7/1999 00:25'!
initialize
	super initialize.
	isHighlighted _ false.
	borderWidth _ 0.
	self color: Color transparent.
	referent _ nil! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/2/1998 12:38'!
isHighlighted
	^ isHighlighted == true! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 11/24/1998 17:39'!
isInTabSorter
	"Answer whether the receiver is currently inside a tab sorter"
	^ (owner ~~ nil) and: [owner isKindOf: TabSorterMorph]! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/1/1998 13:20'!
layoutChanged
	self fitContents.
	super layoutChanged! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/21/1998 15:50'!
morphToInstall: aMorph
	"Create a new tab consisting of a string holding the morph's name"
	| aLabel nameToUse |
	aLabel _ StringMorph new contents: (nameToUse _ aMorph externalName).
	self addMorph: aLabel.
	aLabel lock.
	self referent: aMorph.
	self setNameTo: nameToUse.
	self fitContents.! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 1/11/2000 10:18'!
morphToInstall: aMorph font: aFont
	"Create a new tab consisting of a string holding the morph's name"
	| aLabel nameToUse |
	aLabel _ StringMorph contents: (nameToUse _ aMorph externalName) font: aFont.
	self addMorph: aLabel.
	aLabel lock.
	self referent: aMorph.
	self setNameTo: nameToUse.
	self fitContents.! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/2/1998 17:49'!
setNameTo: aString
	super setNameTo: aString.
	(submorphs size > 0 and: [submorphs first isKindOf: StringMorph])
		ifTrue:
			[submorphs first contents: aString]! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 12/1/1998 11:59'!
sorterToken
	^ SorterTokenMorph new forMorph: self! !

!ReferenceMorph methodsFor: 'misc' stamp: 'sw 3/3/1999 13:03'!
unHighlight
	| str |
	isHighlighted _ false.
	self borderWidth: 0.
	submorphs size > 0
		ifTrue:
			[((str _ submorphs first) isKindOf: StringMorph orOf: RectangleMorph)
				ifTrue:
					[str color: self regularColor]]! !


!ReferenceMorph methodsFor: 'menu' stamp: 'sw 10/25/2000 11:46'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the menu for the hand"

	| sketch |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	self isCurrentlyTextual
		ifTrue:
			[aCustomMenu add: 'change label wording...' action: #changeTabText.
			aCustomMenu add: 'use graphical label' action: #useGraphicalTab]
		ifFalse:
			[aCustomMenu add: 'use textual label' action: #useTextualTab.
			aCustomMenu add: 'choose graphic...' action: #changeTabGraphic.
			(sketch _ self findA: SketchMorph) ifNotNil:
				[aCustomMenu add: 'repaint' target: sketch action: #editDrawing]]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 12/16/1998 14:02'!
changeTabGraphic
	submorphs first chooseNewGraphicCoexisting: true! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sma 6/18/2000 10:36'!
changeTabText
	| reply |
	reply _ FillInTheBlank
		request: 'new wording for this tab:'
		initialAnswer: submorphs first contents.
	reply isEmptyOrNil ifFalse: [submorphs first contents: reply]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 6/21/1999 11:43'!
existingWording
	^ submorphs first contents asString! !

!ReferenceMorph methodsFor: 'menu' stamp: 'di 2/17/2000 20:32'!
graphicalMorphForTab
	| formToUse |
	formToUse _ self valueOfProperty: #priorGraphic ifAbsent: [ScriptingSystem formAtKey: 'squeakyMouse'].
	^ SketchMorph withForm: formToUse! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 6/17/1999 13:45'!
isCurrentlyTextual
	| first |
	^ ((first _ submorphs first) isKindOf: StringMorph) or: [first isKindOf: TextMorph]
		! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 3/23/2000 10:47'!
preserveDetails
	"The receiver is being switched to use a different format.  Preserve the existing details (e.g. wording if textual, grapheme if graphical) so that if the user reverts back to the current format, the details will be right"

	self isCurrentlyTextual
		ifTrue:
			[self setProperty: #priorWording toValue: self existingWording.
			self setProperty: #priorColor toValue: color.
			self setProperty: #priorBorderWidth toValue: borderWidth]
		ifFalse:
			[self setProperty: #priorGraphic toValue: submorphs first form]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 10/30/2000 11:11'!
setLabelFontTo: aFont
	"Change the receiver's label font to be as indicated"

	| aLabel oldLabel |
	aLabel _ StringMorph contents:  (oldLabel _ self findA: StringMorph) contents font: aFont.
	self replaceSubmorph: oldLabel by: aLabel.
	aLabel position: self position.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[self borderWidth: 0.
		owner laySubpartsOutInOneRow.
		isHighlighted ifTrue:
			[self highlight]]! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 7/7/1999 12:49'!
useGraphicalTab
	| aGraphic |
	self preserveDetails.
	self color: Color transparent.
	aGraphic _ self graphicalMorphForTab.
	self borderWidth: 0.
	self removeAllMorphs.
	self addMorphBack: aGraphic.
	aGraphic position: self position.
	aGraphic lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[owner laySubpartsOutInOneRow.
		isHighlighted ifTrue: [self highlight]].! !

!ReferenceMorph methodsFor: 'menu' stamp: 'sw 10/24/2000 14:39'!
useTextualTab
	"Use a textually-emblazoned tab"

	| aLabel stringToUse font aColor |
	self preserveDetails.
	stringToUse _ self valueOfProperty: #priorWording ifAbsent: [self externalName].
	font _ self valueOfProperty: #priorFont ifAbsent: [Preferences standardButtonFont].
	aColor _ self valueOfProperty: #priorColor ifAbsent: [Color green darker].
	aLabel _ StringMorph contents: stringToUse font: font.
	self replaceSubmorph: submorphs first by: aLabel.
	aLabel position: self position.
	self color: aColor.
	aLabel highlightColor: self highlightColor; regularColor: self regularColor.
	aLabel lock.
	self fitContents.
	self layoutChanged.
	(owner isKindOf: IndexTabs) ifTrue:
		[self borderWidth: 0.
		owner laySubpartsOutInOneRow.
		isHighlighted ifTrue:
			[self highlight]]! !


!ReferenceMorph methodsFor: 'accessing' stamp: 'tk 3/8/2000 17:39'!
allNonSubmorphMorphs
	"we hold extra morphs"

	^ Array with: referent! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 10/30/2000 11:11'!
isCurrentlyGraphical
	"Answer whether the receiver is currently showing a graphical face"

	| first |
	^ submorphs size > 0 and:
		[((first _ submorphs first) isKindOf: ImageMorph) or: [first isKindOf: SketchMorph]]! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:47'!
morphToInstall
	^ referent! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'sw 12/3/1998 10:06'!
referent
	^ referent! !

!ReferenceMorph methodsFor: 'accessing' stamp: 'de 11/30/1998 09:58'!
referent: m
	referent _ m! !


!ReferenceMorph methodsFor: 'events' stamp: 'sw 12/21/1998 14:13'!
doButtonAction
	self tabSelected! !

!ReferenceMorph methodsFor: 'events' stamp: 'sw 11/30/1998 12:46'!
handlesMouseDown: evt
	^ true
! !

!ReferenceMorph methodsFor: 'events' stamp: 'sw 3/7/1999 00:29'!
mouseDown: evt
	self setProperty: #oldColor toValue: color! !

!ReferenceMorph methodsFor: 'events' stamp: 'sw 10/24/2000 14:45'!
mouseMove: evt
	"The mouse moved while the butten was down in the receiver"

	| aForm |
	aForm _ self imageForm.
	(self containsPoint: evt cursorPoint)
		ifTrue:
			[aForm reverse displayOn: Display]
		ifFalse:
			[aForm displayOn: Display]! !

!ReferenceMorph methodsFor: 'events' stamp: 'sw 10/26/2000 14:41'!
mouseUp: evt
	"The mouse came up in the receiver; If the mouse is still within the receiver at this point, do the corresponding action"

	| aColor |
	(aColor _ self valueOfProperty: #oldColor) ifNotNil: [self color: aColor].
	(self containsPoint: evt cursorPoint)
		ifTrue: [self doButtonAction].
	super mouseUp: evt "send to evt handler if any"
! !

!ReferenceMorph methodsFor: 'events' stamp: 'sw 1/6/1999 07:45'!
tabSelected
	"Called when the receiver is hit.  First, bulletproof against someone having taken the structure apart.  My own action basically requires that my grand-owner be a TabbedPalette.  Note that the 'opening' script concept has been left behind here."
	| gramps |
	(owner isKindOf: IndexTabs) ifFalse: [^ self beep].
	((gramps _ owner owner) isKindOf: TabbedPalette)  ifTrue:
		[gramps selectTab: self]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReferenceMorph class
	instanceVariableNames: ''!

!ReferenceMorph class methodsFor: 'scripting' stamp: 'sw 9/8/2000 15:29'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((paintbox ((command makeNewDrawingIn: 'make a new drawing in the specified playfield' player))))



! !

!ReferenceMorph class methodsFor: 'scripting' stamp: 'sw 11/30/1998 12:44'!
defaultNameStemForInstances
	^ 'ref'! !


!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 11/30/1998 14:12'!
forMorph: aMorph
	"Create a new tab consisting of a string holding the morph's name"
	^ self new morphToInstall: aMorph! !

!ReferenceMorph class methodsFor: 'instance creation' stamp: 'sw 1/11/2000 10:19'!
forMorph: aMorph font: aFont
	"Create a new tab consisting of a string holding the morph's name"
	^ self new morphToInstall: aMorph font: aFont! !
DataStream subclass: #ReferenceStream
	instanceVariableNames: 'references objects currentReference fwdRefEnds blockers skipping insideASegment '
	classVariableNames: 'RefTypes '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!ReferenceStream commentStamp: '<historical>' prior: 0!
This is a way of serializing a tree of objects into disk file. A ReferenceStream can store
one or more objects in a persistent form, including sharing and cycles.

Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: 'test.obj'.
	<your object> _ rr next.
	rr close.

ReferenceStreams can now write "weak" references. nextPutWeak:
writes a "weak" reference to an object, which refers to that object
*if* it also gets written to the stream by a normal nextPut:.

A ReferenceStream should be treated as a read-stream *or* as a write-stream, *not* as a read/write-stream. The reference-remembering mechanism would probably do bad things if you tried to read and write from the same ReferenceStream.

[TBD] Should we override "close" to do (self forgetReferences)?

Instance variables
 references -- an IdentityDictionary mapping objects already written
	to their byteStream positions. If asked to write any object a
	second time, we just write a reference to its stream position.
	This handles shared objects and reference cycles between objects.
	To implement "weak references" (for Aliases), the references
	dictionary also maps objects not (yet?) written to a Collection
	of byteStream positions with hopeful weak-references to it. If
	asked to definitely write one of these objects, we'll fixup those
	weak references.
 objects -- an IdentityDictionary mapping relative byte stream positions to
	objects already read in. If asked to follow a reference, we
	return the object already read.
	This handles shared objects and reference cycles between objects.
 currentReference -- the current reference position. Positon relative to the 
	start of object data in this file.  (Allows user to cut and paste smalltalk 
	code from the front of the file without effecting the reference values.)  
	This variable is used to help install each new object in "objects" as soon
	as it's created, **before** we start reading its contents, in
	case any of its content objects reference it.
 fwdRefEnds -- A weak reference can be a forward reference, which
	requires advance-reading the referrent. When we later come to the
	object, we must get its value from "objects" and not re-read it so
	refs to it don't become refs to copies. fwdRefEnds remembers the
	ending byte stream position of advance-read objects.
 skipping -- true if <what?>
 insideASegment -- true if we are being used to collect objects that will be 
	included in an ImageSegment.  If so, UniClasses must be noted and traced.

If the object is referenced before it is done being created, it might get created twice.  Just store the object the moment it is created in the 'objects' dictionary.  If at the end, comeFullyUpOnReload returns a different object, some refs will have the temporary object (this is an unlikely case).  At the moment, no implementor of comeFullyUpOnReload returns a different object except DiskProxy, and that is OK.
!


!ReferenceStream methodsFor: 'writing' stamp: 'tk 10/2/2000 18:16'!
beginInstance: aClass size: anInteger
	"This is for use by storeDataOn: methods.  Cf. Object>>storeDataOn:."
	"Addition of 1 seems to make extra work, since readInstance has to compensate.  Here for historical reasons dating back to Kent Beck's original implementation in late 1988.
	In ReferenceStream, class is just 5 bytes for shared symbol.
	SmartRefStream puts out the names and number of class's instances variables for checking.
6/10/97 16:09 tk: See if we can put on a short header. Type = 16. "

	| short ref |
	short _ true.	"All tests for object header that can be written in 4 bytes"
	anInteger <= 254 ifFalse: [short _ false].	"one byte size"
	ref _ references at: aClass name ifAbsent: [short _ false. nil].
	ref isInteger ifFalse: [short _ false].
	short ifTrue: [short _ (ref < 65536) & (ref > 0) "& (ref ~= self vacantRef)"].  "vacantRef is big"
	short ifTrue: [
		byteStream skip: -1.
		short _ byteStream next = 9.
		byteStream skip: 0].	"ugly workaround"
	short 
		ifTrue: ["passed all the tests!!"
			byteStream skip: -1; nextPut: 16; "type = short header"
				nextPut: anInteger + 1;	"size is short"
				nextNumber: 2 put: ref]
		ifFalse: [
			"default to normal longer object header"
			byteStream nextNumber: 4 put: anInteger + 1.
			self nextPut: aClass name].
	insideASegment ifTrue: [
		aClass isSystemDefined ifFalse: [self nextPut: aClass]].
			"just record it to put it into roots"! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/15/98 19:54'!
blockers

	^ blockers! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/13/98 20:00'!
blockers: anIdentDict
	"maps objects -> nil if they should not be written.  object -> anotherObject if they need substitution."

	anIdentDict class == IdentityDictionary ifFalse: [self error: 'must be IdentityDictionary'].
	blockers _ anIdentDict! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:37'!
insideASegment
	^ insideASegment! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/27/2000 11:36'!
insideASegment: aBoolean
	insideASegment _ aBoolean! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 2/3/2000 21:21'!
isAReferenceType: typeID
	"Return true iff typeID is one of the classes that can be written as a reference to an instance elsewhere in the stream."

	"too bad we can't put Booleans in an Array literal"
	^ (RefTypes at: typeID) == 1
		"NOTE: If you get a bounds error here, the file probably has bad bits in it.  The most common cause is a file unpacking program that puts linefeeds after carriage returns."! !

!ReferenceStream methodsFor: 'writing' stamp: 'jhm 11/15/92'!
nextPutWeak: anObject
    "Write a weak reference to anObject to the receiver stream. Answer anObject.
     If anObject is not a reference type of object, then just put it normally.
     A 'weak' reference means: If anObject gets written this stream via nextPut:,
     then its weak references will become normal references. Otherwise they'll
     read back as nil. -- "
    | typeID referencePosn |

    "Is it a reference type of object? If not, just write it normally."
    typeID _ self typeIDFor: anObject.
    (self isAReferenceType: typeID) ifFalse: [^ self nextPut: anObject].

    "Have we heard of and maybe even written anObject before?"
    referencePosn _ references at: anObject ifAbsent: [
			references at: anObject put: OrderedCollection new].

    "If referencePosn is an Integer, it's the stream position of anObject.
     Else it's a collection of hopeful weak-references to anObject."
    referencePosn isInteger ifFalse:
        [referencePosn add: byteStream position - basePos.		"relative"
        referencePosn _ self vacantRef].
    self outputReference: referencePosn.		"relative"

    ^ anObject! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 09:18'!
objectIfBlocked: anObject
	"See if this object is blocked -- not written out and another object substituted."

	^ blockers at: anObject ifAbsent: [anObject]! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:41'!
project
	"Return the project we are writing or nil"

	(topCall respondsTo: #isCurrentProject) ifTrue: [^ topCall].
	(topCall respondsTo: #do:) ifTrue: [1 to: 5 do: [:ii | 
		((topCall at: ii) respondsTo: #isCurrentProject) ifTrue: [^ topCall at: ii]]].
	^ nil! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/23/2000 08:40'!
projectChangeSet
	| pr |
	"The changeSet of the project we are writing"
	(pr _ self project) ifNil: [^ nil].
	^ pr projectChangeSet! !

!ReferenceStream methodsFor: 'writing'!
references
	^ references! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 9/24/2000 16:44'!
replace: original with: proxy
	"We may wish to remember that in some field, the original object is being replaced by the proxy.  For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced."

	blockers at: original put: proxy! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 8/18/1998 08:38'!
reset
	"PRIVATE -- Reset my internal state.
	   11/15-17/92 jhm: Added transients and fwdRefEnds.
	   7/11/93 sw: Give substantial initial sizes to avoid huge time spent growing.
	   9/3/93 sw: monster version for Sasha"

	super reset.
	references _ IdentityDictionary new: 4096 * 5.
"	objects _ IdentityDictionary new: 4096 * 5.
	fwdRefEnds _ IdentityDictionary new.
"
	blockers ifNil: [blockers _ IdentityDictionary new].
 ! !

!ReferenceStream methodsFor: 'writing' stamp: '6/9/97 08:24 tk'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.  Always a relative position."

    currentReference _ refPosn		"relative position"! !

!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'!
setStream: aStream
	"PRIVATE -- Initialization method."

	super setStream: aStream.
	references _ IdentityDictionary new: 4096 * 5.
	objects _ IdentityDictionary new: 4096 * 5.
	fwdRefEnds _ IdentityDictionary new.
	skipping _ IdentitySet new.
	insideASegment _ false.
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !

!ReferenceStream methodsFor: 'writing' stamp: 'RAA 1/18/2001 11:51'!
setStream: aStream reading: isReading
	"PRIVATE -- Initialization method."

	super setStream: aStream reading: isReading.
	"isReading ifFalse: [  when we are sure"
	references _ IdentityDictionary new: 4096 * 5.
	isReading ifTrue: [
		objects _ IdentityDictionary new: 4096 * 5.
		skipping _ IdentitySet new.
		insideASegment _ false.
		fwdRefEnds _ IdentityDictionary new].
	blockers ifNil: [blockers _ IdentityDictionary new].	"keep blockers we just passed in"
! !

!ReferenceStream methodsFor: 'writing' stamp: 'tk 3/28/2000 22:19'!
tryToPutReference: anObject typeID: typeID
	"PRIVATE -- If we support references for type typeID, and if
	   anObject already appears in my output stream, then put a
	   reference to the place where anObject already appears. If we
	   support references for typeID but didn't already put anObject,
	   then associate the current stream position with anObject in
	   case one wants to nextPut: it again.
	 Return true after putting a reference; false if the object still
	   needs to be put.
	 : Added support for weak refs. Split out outputReference:.
	08:42 tk  references stores relative file positions."
	| referencePosn nextPosn |

	"Is it a reference type of object?"
	(self isAReferenceType: typeID) ifFalse: [^ false].

	"Have we heard of and maybe even written anObject before?"
	referencePosn _ references at: anObject ifAbsent:
			["Nope. Remember it and let the sender write it."
			references at: anObject put: (byteStream position - basePos).	"relative"
			^ false].

	"If referencePosn is an Integer, it's the stream position of anObject."
	referencePosn isInteger ifTrue:
		[self outputReference: referencePosn.	"relative"
		^ true].

	referencePosn == #none ifTrue: ["for DiskProxy"
			references at: anObject put: (byteStream position - basePos).	"relative"
			^ false].


	"Else referencePosn is a collection of positions of weak-references to anObject.
	 Make them full references since we're about to really write anObject."
	references at: anObject put: (nextPosn _ byteStream position) - basePos.	"store relative"
	referencePosn do: [:weakRefPosn |
			byteStream position: weakRefPosn + basePos.		"make absolute"
			self outputReference: nextPosn - basePos].	"make relative"
	byteStream position: nextPosn.		"absolute"
	^ false! !


!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 11:52'!
beginReference: anObject
	"Remember anObject as the object we read at the position recorded by
	 noteCurrentReference:. This must be done after instantiating anObject but
	 before reading any of its contents that might (directly or indirectly) refer to
	 it. (It's ok to do this redundantly, which is convenient for #next.)
	 Answer the reference position."

	objects at: currentReference ifAbsent: [
		objects at: currentReference put: anObject.
		^ currentReference].
	(skipping includes: currentReference) ifFalse: [
		"If reading just to skip it, don't record this copy."
		objects at: currentReference put: anObject
	].
	^ currentReference		"position relative to start of data portion of file"! !

!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 08:26 tk'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.  Always a relative position.  So user can cut and paste the Smalltalk source code at the beginning of the file."

    ^ currentReference	"relative position"! !

!ReferenceStream methodsFor: 'reading' stamp: 'tk 4/8/1999 13:11'!
maybeBeginReference: internalObject
	"See if need to record a reference.  In case in the file twice"

	(self isAReferenceType: (self typeIDFor: internalObject))
			ifTrue: [self beginReference: internalObject].
			"save the final object and give it out next time."
	^ internalObject! !

!ReferenceStream methodsFor: 'reading' stamp: 'RAA 1/18/2001 16:46'!
next
	"Answer the next object in the stream.  If this object was already read, don't re-read it.  File is positioned just before the object."
	| curPosn skipToPosn haveIt theObject wasSkipping |

	haveIt _ true.
	curPosn _ byteStream position - basePos.
	theObject _ objects at: curPosn ifAbsent: [haveIt _ false].
		"probe in objects is done twice when coming from objectAt:.  This is OK."
	skipToPosn _ fwdRefEnds at: curPosn ifAbsent: [nil].
	haveIt ifFalse: [ ^ super next].

	skipToPosn ifNotNil: [
		"Skip over the object and return the already-read-in value."
		byteStream position: skipToPosn + basePos		"make absolute"
	] ifNil: [
		"File is not positioned correctly.  Read object and throw it away."
		wasSkipping _ skipping includes: curPosn.
		skipping add: curPosn.
		"fake _" super next.
		wasSkipping ifFalse: [skipping remove: curPosn ifAbsent: []].
	].
	^ theObject
		! !

!ReferenceStream methodsFor: 'reading' stamp: '6/9/97 09:00 tk'!
noteCurrentReference: typeID
	"PRIVATE -- If we support references for type typeID, remember
	 the current byteStream position so beginReference: can add the
	 next object to the 'objects' dictionary of reference positions,
	 then return true. Else return false."
	| answer |

	(answer _ self isAReferenceType: typeID)
		ifTrue: [self setCurrentReference: (byteStream position - 1) - basePos "relative"
				"subtract 1 because we already read the object's type ID byte"].
	^ answer! !

!ReferenceStream methodsFor: 'reading' stamp: ' 6/9/97'!
objectAt: anInteger
    "PRIVATE -- Read & return the object at a given stream position.
     If we already read it, just get it from the objects dictionary.
     (Reading it again wouldn't work with cycles or sharing.)
     If not, go read it and put it in the objects dictionary.
     NOTE: This resolves a cross-reference in the ReferenceStream:
       1. A backward reference to an object already read (the normal case).
       2. A forward reference which is a sated weak reference (we record where
          the object ends so when we get to it normally we can fetch it from
          'objects' and skip over it).
       3. A backward reference to a 'non-reference type' per the long NOTE in
          nextPut: (we compensate here--seek back to re-read it and add the object
          to 'objects' to avoid seeking back to read it any more times).
       4. While reading a foward weak reference (case 2), we may recursively hit an
          ordinary backward reference to an object that we haven't yet read because
          we temporarily skipped ahead. Such a reference is forward in time so we
          treat it much like case 2.
     11/16-24/92 jhm: Handle forward refs. Cf. class comment and above NOTE.
	08:57 tk   anInteger is a relative position"
    | savedPosn refPosn anObject |

    ^ objects at: anInteger "relative position.  case 1: It's in 'objects'"
        ifAbsent:   "do like super objectAt:, but remember the fwd-ref-end position"
            [savedPosn _ byteStream position.		"absolute"
            refPosn _ self getCurrentReference.	"relative position"

            byteStream position: anInteger + basePos.	"was relative"
            anObject _ self next.

            (self isAReferenceType: (self typeIDFor: anObject))
                ifTrue:  [fwdRefEnds at: anInteger put: byteStream position - basePos] "cases 2, 4"
                ifFalse: [objects at: anInteger put: anObject]. "case 3"

            self setCurrentReference: refPosn.		"relative position"
            byteStream position: savedPosn.		"absolute"
            anObject]! !


!ReferenceStream methodsFor: 'statistics' stamp: 'ls 10/10/1999 13:27'!
statisticsOfRefs
	"Analyze the information in references, the objects being written out"

	| parents n kids nm ownerBags tallies owners objParent |
	parents _ IdentityDictionary new: references size * 2.
	n _ 0.
	'Finding Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:
		[:parent | bar value: (n _ n+1).
		kids _ parent class isFixed
			ifTrue: [(1 to: parent class instSize) collect: [:i | parent
instVarAt: i]]
			ifFalse: [parent class isBits ifTrue: [Array new]
					 ifFalse: [(1 to: parent basicSize) collect: [:i | parent basicAt:
i]]].
		(kids select: [:x | references includesKey: x])
			do: [:child | parents at: child put: parent]]].
	ownerBags _ Dictionary new.
	tallies _ Bag new.
	n _ 0.
	'Tallying Owners...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: references size
	during: [:bar |
	references keysDo:  "For each class of obj, tally a bag of owner
classes"
		[:obj | bar value: (n _ n+1).
		nm _ obj class name.
		tallies add: nm.
		owners _ ownerBags at: nm ifAbsent: [ownerBags at: nm put: Bag new].
		(objParent _ parents at: obj ifAbsent: [nil]) == nil
			ifFalse: [owners add: objParent class name]]].
	^ String streamContents:
		[:strm |  tallies sortedCounts do:
			[:assn | n _ assn key.  nm _ assn value.
			owners _ ownerBags at: nm.
			strm cr; nextPutAll: nm; space; print: n.
			owners size > 0 ifTrue:
				[strm cr; tab; print: owners sortedCounts]]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ReferenceStream class
	instanceVariableNames: ''!

!ReferenceStream class methodsFor: 'as yet unclassified'!
example2
"Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	<your object> _ rr next.
	rr close.
"
"An example and test of DataStream/ReferenceStream.
	 11/19/92 jhm: Use self testWith:."
	"ReferenceStream example2"
	| input sharedPoint |

	"Construct the test data."
	input _ Array new: 9.
	input at: 1 put: nil.
	input at: 2 put: true.
	input at: 3 put: false.
	input at: 4 put: #(-4 -4.0 'four' four).
	input at: 5 put: (Form extent: 63 @ 50 depth: 8).
		(input at: 5) fillWithColor: Color lightOrange.
	input at: 6 put: 1024 @ -2048.
	input at: 7 put: input. "a cycle"
	input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
	input at: 9 put: sharedPoint.

	"Write it out, read it back, and return it for inspection."
	^ self testWith: input
! !

!ReferenceStream class methodsFor: 'as yet unclassified'!
refTypes: oc
	RefTypes _ oc! !

!ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/26/1998 14:51'!
versionCode
    "Answer a number representing the 'version' of the ReferenceStream facility; this is stashed at the beginning of ReferenceStreams, as a secondary versioning mechanism (the primary one is the fileTypeCode).   At present, it serves for information only, and is not checked for compatibility at reload time, but could in future be used to branch to variant code. "

	" 1 = original version 1992"
	" 2 = HyperSqueak.  PathFromHome used for Objs outside the tree.  SqueakSupport SysLibrary for shared globals like Display and StrikeFonts.  File has version number, class structure, then an IncomingObjects manager.  8/16/96 tk.  
	Extended to SmartRefStream.  class structure also keeps superclasse chain.  Does analysis on structure to see when translation methods are needed.  Embedable in file-ins.  (factored out HyperSqueak support)  Feb-May 97 tk"
	" 3 = Reference objects are byte offsets relative to the start of the object portion of the file.  Rectangles with values -2048 to 2047 are encoded compactly."
	" 4 = If UniClasses (subclasses of Player) have class instance variables, append their values in the form (#Class43 (val1 val2 vla3)).  An array of those.  Can still read version 3."
	^ 4! !
Animation subclass: #RelativeAnimation
	instanceVariableNames: 'getReverseStateFunction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!RelativeAnimation commentStamp: '<historical>' prior: 0!
A relative animation is any animation where the final state is relative to the initial state (for example, moving forward 1 meter). To reverse these animations we essentially use the same initial state and just reverse the vector to the final state (ex. we move back one meter).
!


!RelativeAnimation methodsFor: 'management' stamp: 'jsp 2/16/1999 16:36'!
prologue: currentTime
	"Extends the AbstractAnimation prologue by saving the start state of the animation."

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (UndoAnimation new: (self makeUndoVersion)).
					].

	(direction = Forward) ifTrue: [
									startState _ getStartStateFunction value.
									endState _ getEndStateFunction value.
								]
						ifFalse: [
									startState _ getStartStateFunction value.
									endState _ getReverseStateFunction value.
								].


	super prologue: currentTime.
! !


!RelativeAnimation methodsFor: 'initialization' stamp: 'jsp 3/9/1999 15:50'!
object: anObject update: func getStartState: startFunc getEndState: endFunc getReverseState: reverseFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs to run."

	getReverseStateFunction _ reverseFunc.

	super object: anObject update: func getStartState: startFunc getEndState: endFunc style: styleFunc duration: time undoable: canUndo inWonderland: aWonderland.
! !


!RelativeAnimation methodsFor: 'copying' stamp: 'jsp 3/9/1999 15:54'!
copy
	"Creates a copy of the animation"

	| anim |

	anim _ RelativeAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		getReverseState: getReverseStateFunction 
		style: styleFunction
		duration: duration
		undoable: undoable
		inWonderland: myWonderland.

	(direction = Forward) ifFalse: [ anim reverseDirection ].

	^ anim.
! !

!RelativeAnimation methodsFor: 'copying' stamp: 'jsp 3/9/1999 15:54'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim |

	anim _ RelativeAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		getReverseState: getReverseStateFunction 
		style: styleFunction
		duration: 0.5
		undoable: false
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !

!RelativeAnimation methodsFor: 'copying' stamp: 'jsp 4/9/1999 14:21'!
reversed
	"Creates a reversed version of an animation"

	| anim |

	anim _ RelativeAnimation new.

	anim object: animatedObject
		update: updateFunction
		getStartState: getStartStateFunction
		getEndState: getEndStateFunction
		getReverseState: getReverseStateFunction 
		style: styleFunction
		duration: duration
		undoable: true
		inWonderland: myWonderland.

	anim stop.
	(direction = Forward) ifTrue: [ anim reverseDirection ].

	^ anim.
! !
Canvas subclass: #RemoteCanvas
	instanceVariableNames: 'innerClipRect outerClipRect transform connection '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!RemoteCanvas commentStamp: '<historical>' prior: 0!
A canvas which draws to a terminal across the network.  Note that multiple RemoteCanvas's might exist for a single MREncoder, each having different transformations and clipping rectangles.!


!RemoteCanvas methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:00'!
asBufferedCanvas

	| bufferedCanvas |

	bufferedCanvas _ BufferedCanvas new.
	connection cachingEnabled: false.
	bufferedCanvas
		connection: connection
		clipRect: NebraskaServer extremelyBigRectangle
		transform: MorphicTransform identity
		remoteCanvas: self.
	^bufferedCanvas! !

!RemoteCanvas methodsFor: 'initialization' stamp: 'ls 3/19/2000 15:57'!
connection: connection0 clipRect: clipRect0 transform: transform0
	connection _ connection0.
	outerClipRect _ clipRect0.
	transform _ transform0.


	innerClipRect := transform globalBoundsToLocal: outerClipRect. ! !

!RemoteCanvas methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:06'!
purgeOutputQueue

	connection purgeOutputQueue.! !


!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 11/6/2000 15:26'!
balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc

	self drawCommand: [ :executor |
		executor balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 7/28/2000 07:41'!
balloonFillRectangle: aRectangle fillStyle: aFillStyle

	self drawCommand: [ :executor |
		executor balloonFillRectangle: aRectangle fillStyle: aFillStyle
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 3/25/2000 22:44'!
drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc
	self drawCommand: [ :c |
		c drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc ]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 10/9/1999 18:36'!
fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	self drawCommand: [ :executor |
		executor fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 11/6/2000 15:25'!
fillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc
	"Fill the given oval."
	self shadowColor ifNotNil: [
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
	].
	(aFillStyle isBitmapFill and:[aFillStyle isKindOf: InfiniteForm]) ifTrue:[
		self flag: #fixThis.
		^self fillOval: aRectangle color: aFillStyle borderWidth: bw borderColor: bc
	].
	(aFillStyle isSolidFill) ifTrue:[
		^self fillOval: aRectangle color: aFillStyle asColor borderWidth: bw borderColor: bc
	].
	"Use a BalloonCanvas instead"
	self balloonFillOval: aRectangle fillStyle: aFillStyle borderWidth: bw borderColor: bc! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 8/25/2000 14:49'!
fillRectangle: aRectangle fillStyle: aFillStyle
	"Fill the given rectangle."
	| pattern |
	self shadowColor ifNotNil:
		[^self fillRectangle: aRectangle color: self shadowColor].

	(aFillStyle isKindOf: InfiniteForm) ifTrue: [
		^self infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	].

	(aFillStyle isSolidFill) 
		ifTrue:[^self fillRectangle: aRectangle color: aFillStyle asColor].
	"We have a very special case for filling with infinite forms"
	(aFillStyle isBitmapFill and:[aFillStyle origin = (0@0)]) ifTrue:[
		pattern _ aFillStyle form.
		(aFillStyle direction = (pattern width @ 0) 
			and:[aFillStyle normal = (0@pattern height)]) ifTrue:[
				"Can use an InfiniteForm"
				^self fillRectangle: aRectangle color: (InfiniteForm with: pattern)].
	].
	"Use a BalloonCanvas instead"
	self balloonFillRectangle: aRectangle fillStyle: aFillStyle.! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 8/25/2000 13:13'!
frameAndFillRectangle: bounds fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"

	self drawCommand: [ :executor |
		executor 
			frameAndFillRectangle: bounds 
			fillColor: fillColor 
			borderWidth: borderWidth 
			borderColor: borderColor
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 10/9/1999 18:38'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form."
	self drawCommand: [ :executor |
		executor image: aForm at: aPoint sourceRect: sourceRect rule: rule
	].! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'RAA 8/25/2000 14:49'!
infiniteFillRectangle: aRectangle fillStyle: aFillStyle

	self drawCommand: [ :c |
		c infiniteFillRectangle: aRectangle fillStyle: aFillStyle
	]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 10/9/1999 18:25'!
line: point1 to: point2 width: width color: color
	"Draw a line using the given width and color"
	self drawCommand: [ :executor |
		executor line: point1 to: point2 width: width color: color ]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 3/26/2000 13:25'!
stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor
	"Flood this canvas with aColor wherever stencilForm has non-zero pixels"
	self drawCommand: [ :executor |
		executor stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor ]! !

!RemoteCanvas methodsFor: 'drawing' stamp: 'ls 3/27/2000 18:53'!
text: text bounds: boundsRect font: fontOrNil color: color
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
	"(innerClipRect intersects: (transform transformBoundsRect: boundsRect)) ifFalse: [ ^self ]."
		"clip rectangles seem to be all screwed up...."
	text isAllSeparators ifTrue: [ ^self ].   "is this correct??  it sure does speed things up!!"
	self drawCommand: [ :executor |
		executor text: text bounds: boundsRect font: fontOrNil color: color ]! !


!RemoteCanvas methodsFor: 'private' stamp: 'ls 3/27/2000 18:50'!
drawCommand: aBlock
	"set up the connection for a drawing command, and then execute aBlock with the connection as an argument"
	connection updateTransform: transform andClipRect: outerClipRect.
	aBlock value: connection! !


!RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 12/14/2000 13:47'!
clipBy: aRectangle during: aBlock
	| newCanvas newR |
	"Set a clipping rectangle active only during the execution of aBlock."

	newR _ transform localBoundsToGlobal: aRectangle.

	newCanvas _ RemoteCanvas 
		connection: connection 
		clipRect: (outerClipRect intersect: newR) 
		transform: transform.
	aBlock value: newCanvas! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 7/20/2000 17:47'!
forceToScreen: rect

		self drawCommand: [ :exec |
			exec forceToScreen: rect ]! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'ls 3/26/2000 00:07'!
showAt: pt invalidRects: updateRects
	updateRects do: [ :rect |
		self drawCommand: [ :exec |
			exec forceToScreen: rect ] ]! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 12/11/2000 12:30'!
transform2By: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize

	(aDisplayTransform isPureTranslation) ifTrue: [
		^self 
			transformBy: aDisplayTransform 
			clippingTo: aClipRect 
			during: aBlock 
			smoothing: cellSize
	].
	^super 
		transform2By: aDisplayTransform 
		clippingTo: aClipRect 
		during: aBlock 
		smoothing: cellSize
! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 7/26/2000 10:03'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
	| newCanvas |

	self flag: #bob.		"do tranform and clip work together properly?"
	newCanvas := RemoteCanvas 
		connection: connection 
		clipRect: (aClipRect intersect: outerClipRect)
		transform: (transform composedWith: aDisplayTransform).
	aBlock value: newCanvas.! !

!RemoteCanvas methodsFor: 'drawing-support' stamp: 'ls 3/26/2000 20:26'!
translateBy: delta during: aBlock
	self transformBy: (MorphicTransform offset: delta negated) clippingTo: outerClipRect during: aBlock smoothing: 1! !


!RemoteCanvas methodsFor: 'misc' stamp: 'ls 3/21/2000 23:22'!
flush
	connection ifNotNil: [ connection flush ]! !

!RemoteCanvas methodsFor: 'misc' stamp: 'ls 2/28/2000 00:16'!
processIO
	connection processIO! !


!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 3/19/2000 15:56'!
clipRect
	^innerClipRect! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 11/6/2000 14:17'!
contentsOfArea: aRectangle into: aForm
	"this should never be called; normally, RemoteCanvas's are used in conjunction with a CachingCanvas"

	self flag: #roundedRudeness.	

	"aForm fillWhite.
	^aForm"

	^Display getCanvas contentsOfArea: aRectangle into: aForm! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:33'!
extent
	self flag: #hack.
	^1500@1500! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:33'!
origin
	^0@0! !

!RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 11/6/2000 14:17'!
roundCornersOf: aMorph during: aBlock

	self flag: #roundedRudeness.	

	aMorph wantsRoundedCorners ifFalse:[^aBlock value].
	(self seesNothingOutside: (CornerRounder rectWithinCornersOf: aMorph bounds))
		ifTrue: ["Don't bother with corner logic if the region is inside them"
				^ aBlock value].
	CornerRounder roundCornersOf: aMorph on: self
		displayBlock: aBlock
		borderWidth: aMorph borderWidth
		corners: aMorph roundedCorners! !


!RemoteCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 08:17'!
apply: ignored

	"added for the convenience of BufferedCanvas"! !

!RemoteCanvas methodsFor: 'as yet unclassified' stamp: 'RAA 7/22/2000 09:59'!
paragraph: paragraph bounds: bounds color: c

	self flag: #bob.		"we need to fill this in"
	self paragraph2: paragraph bounds: bounds color: c.! !


!RemoteCanvas methodsFor: 'nil' stamp: 'RAA 8/1/2000 00:13'!
backlog

	^connection backlog! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteCanvas class
	instanceVariableNames: ''!

!RemoteCanvas class methodsFor: 'instance creation' stamp: 'ls 10/20/1999 21:14'!
connection: connection  clipRect: clipRect  transform: transform
	^self new connection: connection clipRect: clipRect transform: transform! !
HandMorph subclass: #RemoteControlledHandMorph
	instanceVariableNames: 'eventDecoder viewExtent nebraskaClient '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Remote'!
!RemoteControlledHandMorph commentStamp: '<historical>' prior: 0!
Used as part of the Nebraska system.  It is controlled by commands sent through a socket.  The encoding is interpreted via a MorphicEventDecoder.!


!RemoteControlledHandMorph methodsFor: 'events' stamp: 'RAA 11/8/2000 15:15'!
convertRemoteClientToBuffered

	self world convertRemoteClientToBuffered: nebraskaClient! !

!RemoteControlledHandMorph methodsFor: 'events' stamp: 'ls 3/25/2000 16:51'!
processEvents
	| |
	eventDecoder processIO.
	eventDecoder applyMessagesTo: self.
! !

!RemoteControlledHandMorph methodsFor: 'events' stamp: 'ar 10/25/2000 23:29'!
queueEvent: anEvent
	"add an event to be handled"

	anEvent setHand: self.
	self handleEvent: anEvent resetHandlerFields.! !

!RemoteControlledHandMorph methodsFor: 'events' stamp: 'ls 3/25/2000 16:44'!
setViewExtent: newExtent
	"set the extent of this hand's view of the world"
	viewExtent := newExtent! !


!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'ls 3/24/2000 21:53'!
decoder: aDecoder
	eventDecoder := aDecoder! !

!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'ls 3/25/2000 16:44'!
initialize
	super initialize.
	viewExtent := 100@100.! !

!RemoteControlledHandMorph methodsFor: 'initialization' stamp: 'RAA 11/8/2000 15:13'!
nebraskaClient: aNebraskaClient

	nebraskaClient _ aNebraskaClient! !


!RemoteControlledHandMorph methodsFor: 'queries' stamp: 'ls 3/25/2000 16:44'!
worldBounds
	^0@0 extent: viewExtent! !


!RemoteControlledHandMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteControlledHandMorph class
	instanceVariableNames: ''!

!RemoteControlledHandMorph class methodsFor: 'instance creation' stamp: 'ls 3/24/2000 21:53'!
on: aDecoder
	^super new initialize decoder: aDecoder! !
RWBinaryOrTextStream subclass: #RemoteFileStream
	instanceVariableNames: 'remoteFile localDataValid '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!RemoteFileStream commentStamp: '<historical>' prior: 0!
An in-memory stream that can be used to fileIn code from the network.  Knows its ServerFile, and thus its name, path, etc.

localDataValid -- false when have never read the file from the server.  Set to true after reading, when my contents has the true data.  When creating a remote file, set localDataValid to true so it will write to server.!


!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:50'!
close
	"Write if we have data to write.  FTP files are always binary to preserve the data exactly.  The binary/text (ascii) flag is just for tell how the bits are delivered from a read."

	remoteFile writable ifTrue: [
			remoteFile putFile: self named: remoteFile fileName]! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:47'!
contentsOfEntireFile
	"Fetch the data off the server and store it in me.  But not if I already have it."

	readLimit _ readLimit max: position.
	localDataValid ifTrue: [^ super contentsOfEntireFile].
	collection size = 0 ifTrue: [self on: (String new: 2000)].
	remoteFile getFileNamed: remoteFile fileName into: self.	"sets localDataValid _ true"
	^ super contentsOfEntireFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:45'!
dataIsValid

	localDataValid _ true.! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:19'!
directory
	^ remoteFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:51'!
directoryUrl
	^ remoteFile directoryUrl! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:30'!
localName
	^ remoteFile fileName! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:48'!
openReadOnly
	"If we have data, don't reread."

	self readOnly.
	readLimit _ readLimit max: position.
	localDataValid ifFalse: [remoteFile getFileNamed: remoteFile fileName into: self].
		"sets localDataValid _ true"! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 22:43'!
padToEndWith: aChar
	"On the Mac, files do not truncate, so pad it with a harmless character.  But Remote FTP files always replace, so no need to pad."

	self atEnd ifFalse: [self inform: 'Why is this stream not at its end?'].! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 14:32'!
readOnly
	^ remoteFile readOnly! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 09:18'!
remoteFile
	^ remoteFile! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/13/2000 21:39'!
remoteFile: aServerFile
	remoteFile _ aServerFile.
	localDataValid _ false.	"need to read from the server"! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:13'!
sleep
	"If we are done, then let the server know"

	self close.
	remoteFile sleep.! !

!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 1/25/1999 15:16'!
url
	^ remoteFile url! !
HandMorph subclass: #RemoteHandMorph
	instanceVariableNames: 'remoteWorldExtent remoteAddress sendSocket sendBuffer sendState socket waitingForConnection receiveBuffer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!RemoteHandMorph methodsFor: 'initialization' stamp: 'ar 10/24/2000 14:38'!
initialize

	super initialize.
	remoteWorldExtent _ 100@100.  "initial guess"
	socket _ nil.
	waitingForConnection _ false.
	receiveBuffer _ ''.
	sendState _ #unconnected.! !



!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastEventTransmitted
	^self valueOfProperty: #lastEventTransmitted! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastEventTransmitted: anEvent
	^self setProperty: #lastEventTransmitted toValue: anEvent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastWorldExtent
	^self valueOfProperty: #lastWorldExtent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:10'!
lastWorldExtent: extent
	^self setProperty: #lastWorldExtent toValue: extent! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 16:50'!
readyToTransmit
	"Return true if the receiver is ready to send."

	(sendState == #connected) ifTrue:[
		 sendSocket sendDone ifFalse:[^false].
		^true].

	sendState == #opening ifTrue:[
		sendSocket isConnected ifTrue:[^true].
		sendSocket isWaitingForConnection ifFalse:[
			Transcript show: 'trying connection again...'; cr.
			sendSocket destroy.
			sendSocket _ Socket new.
			sendSocket connectTo: self remoteHostAddress port: 54323]].

	sendState == #closing ifTrue:[
		sendSocket isUnconnectedOrInvalid ifTrue:[
			sendSocket destroy.
			sendState _ #unconnected]].

	^false! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 15:59'!
remoteHostAddress
	"Return the address of the remote host or zero if not connected."
	^remoteAddress ifNil:[0]! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'RAA 7/12/2000 11:46'!
startListening
	"Create a socket and start listening for a connection."

	self stopListening.
	Transcript show: 'My address is ', NetNameResolver localAddressString; cr.
	Transcript show: 'Remote hand ', self userInitials, ' waiting for a connection...'; cr.
	socket _ Socket new.
	socket listenOn: 54323.
	waitingForConnection _ true.
! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 15:57'!
startTransmittingEvents
	"Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer."
	(sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self].
	Transcript
		show: 'Connecting to remote WorldMorph at ';
		show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr.
	sendSocket _ SimpleClientSocket new.
	sendSocket connectTo: self remoteHostAddress port: 54323.
	sendState _ #opening.
	owner primaryHand addEventListener: self.! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 15:59'!
startTransmittingEventsTo: remoteAddr
	"Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer."
	remoteAddress _ remoteAddr.
	(sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self].
	Transcript
		show: 'Connecting to remote WorldMorph at ';
		show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr.
	sendSocket _ SimpleClientSocket new.
	sendSocket connectTo: self remoteHostAddress port: 54323.
	sendState _ #opening.
	owner primaryHand addEventListener: self.! !

!RemoteHandMorph methodsFor: 'connections'!
stopListening
	"Destroy the socket, if any, terminating the connection."

	socket ifNotNil: [
		socket destroy.
		socket _ nil].
! !

!RemoteHandMorph methodsFor: 'connections' stamp: 'ar 10/24/2000 14:34'!
stopTransmittingEvents
	"Stop broadcasting events from this world's cursor to a remote cursor on the host with the given address. This method issues a 'close' but does not destroy the socket; it will be destroyed when the other end reads the last data and closes the connection."
	(sendSocket isUnconnectedOrInvalid) ifFalse:[
		sendSocket close.
		sendState _ #closing].
	owner primaryHand removeEventListener: self.! !


!RemoteHandMorph methodsFor: 'other' stamp: 'ar 2/12/2000 18:07'!
drawOn: aCanvas
	"For remote cursors, always draw the hand itself (i.e., the cursor)."

	super drawOn: aCanvas.
	aCanvas paintImage: NormalCursor at: self position.
! !

!RemoteHandMorph methodsFor: 'other' stamp: 'ar 10/24/2000 14:34'!
withdrawFromWorld
	"Close the socket, if any, and remove this hand from the world."
	| addr |
	addr _ self remoteHostAddress.
	addr = 0 ifFalse: [self stopTransmittingEvents].
	self stopListening.
	Transcript show: 'Remote hand ', self userInitials, ' closed'; cr.
	owner ifNotNil: [owner removeHand: self].
! !

!RemoteHandMorph methodsFor: 'other' stamp: 'jm 11/4/97 07:15'!
worldBounds

	^ 0@0 extent: remoteWorldExtent
! !


!RemoteHandMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
appendNewDataToReceiveBuffer
	"Append all available raw data to my receive buffer. Assume that my socket is not nil."

	| newData tempBuf bytesRead |
	socket dataAvailable ifTrue: [
		"get all the data currently available"
		newData _ WriteStream on: (String new: receiveBuffer size + 1000).
		newData nextPutAll: receiveBuffer.
		tempBuf _ String new: 1000.
		[socket dataAvailable] whileTrue: [
			bytesRead _ socket receiveDataInto: tempBuf.
			1 to: bytesRead do: [:i | newData nextPut: (tempBuf at: i)]].
		receiveBuffer _ newData contents].
! !

!RemoteHandMorph methodsFor: 'private' stamp: 'ar 10/26/2000 01:55'!
getNextRemoteEvent
	"Return the next remote event, or nil if the receive buffer does not contain a full event record. An event record is the storeString for a MorphicEvent terminated by a <CR> character."

	| i s evt |
	self receiveData.
	receiveBuffer isEmpty ifTrue: [^ nil].

	i _ receiveBuffer indexOf: Character cr ifAbsent: [^ nil].
	s _ receiveBuffer copyFrom: 1 to: i - 1.
	receiveBuffer _ receiveBuffer copyFrom: i + 1 to: receiveBuffer size.
	evt _ (MorphicEvent readFromString: s).
	evt ifNil:[^nil].
	evt setHand: self.
	evt isKeyboard ifTrue:[evt setPosition: self position].
	^evt resetHandlerFields! !

!RemoteHandMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
receiveData
	"Check my connection status and withdraw from the world if the connection has been broken. Append any data that has arrived to receiveBuffer. "

	socket ifNotNil: [
		socket isConnected
			ifTrue: [  "connected"
				waitingForConnection ifTrue: [
					Transcript show: 'Remote hand ', userInitials, ' connected'; cr.
					waitingForConnection _ false].
				self appendNewDataToReceiveBuffer]
			ifFalse: [  "not connected"
				waitingForConnection ifFalse: [
					"connection was established, then broken"
					self withdrawFromWorld.
					receiveBuffer _ '']]].
! !


!RemoteHandMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 01:12'!
handleListenEvent: anEvent
	"Transmit the event to interested listeners"
	| currentExtent |
	currentExtent _ self worldBounds extent.
	self lastWorldExtent ~= currentExtent ifTrue: [
		self transmitEvent: (MorphicUnknownEvent new setType: #worldExtent argument: currentExtent).
		self lastWorldExtent: currentExtent].
	self transmitEvent: anEvent.! !

!RemoteHandMorph methodsFor: 'event handling' stamp: 'RAA 12/12/2000 14:45'!
needsToBeDrawn

	^true! !

!RemoteHandMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 20:00'!
processEvents
	"Process user input events from the remote input devices."

	| evt |
	evt _ self getNextRemoteEvent.
	[evt ~~ nil] whileTrue: [
		evt type == #worldExtent ifTrue: [
			remoteWorldExtent _ evt argument.
			^ self].
		self handleEvent: evt.
		evt _ self getNextRemoteEvent]
! !

!RemoteHandMorph methodsFor: 'event handling' stamp: 'ar 10/26/2000 00:50'!
transmitEvent: aMorphicEvent
	"Transmit the given event to all remote connections."
	| firstEvt |
	self readyToTransmit ifFalse: [^ self].
	self lastEventTransmitted = aMorphicEvent ifTrue: [^ self].
	sendBuffer ifNil: [sendBuffer _ WriteStream on: (String new: 10000)].
	sendBuffer nextPutAll: aMorphicEvent storeString; cr.
	self lastEventTransmitted: aMorphicEvent.

	sendSocket isConnected ifTrue:[
		sendState = #opening ifTrue: [
			"connection established; disable TCP delays on sends"
			sendSocket setOption: 'TCP_NODELAY' value: true.
			"send worldExtent as first event"
			firstEvt _ MorphicUnknownEvent type: #worldBounds argument: self worldBounds extent.
			sendSocket sendData: firstEvt storeString, (String with: Character cr).
			Transcript
				show: 'Connection established with remote WorldMorph at ';
				show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr.
			sendState _ #connected].
		sendSocket sendData: sendBuffer contents.
	] ifFalse: [
		owner primaryHand removeEventListener: self.
		sendState = #connected ifTrue: [
			"other end has closed; close our end"
			Transcript
				show: 'Closing connection with remote WorldMorph at ';
				show: (NetNameResolver stringFromAddress: sendSocket remoteAddress); cr.
			sendSocket close.
		sendState _ #closing]].

	sendBuffer reset.
! !
Object subclass: #RemoteString
	instanceVariableNames: 'sourceFileNumber filePositionHi '
	classVariableNames: 'CurrentTextAttStructure CurrentTextAttVersion TextAttributeStructureVersions '
	poolDictionaries: ''
	category: 'System-Files'!
!RemoteString commentStamp: '<historical>' prior: 0!
My instances provide an external file reference to a piece of text.  It may be the sourceCode of a method, or the class comments of a class.

The changes file or file-in file usually has a chunk that is just the source string of a method:

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!

I can return either a String or a Text.  Some a chunk is followed by a second chunk (beginning with ]style[) containing style information.  The encoding is like this:

max: aNumber
	^ self > aNumber ifTrue: [self] ifFalse: [aNumber]!!
]style[(14 50 312)f1,f1b,f1LInteger +;i!!

Allowed TextAttributes are TextFontChange, TextEmphasis, TextColor, TextDoIt, TextKern, TextLink, TextURL.  TextFontReference and TextAnchor are not supported.

See PositionableStream nextChunkText and RunArray class scanFrom:.!
]style[(748 32 5 24 1)f1,f1LPositionableStream nextChunkText;,f1,f1LRunArray class scanFrom:;,f1!


!RemoteString methodsFor: 'accessing'!
position 
	"Answer the location of the string on a file."

	^ filePositionHi! !

!RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:28'!
setSourcePointer: aSourcePointer
	sourceFileNumber _ SourceFiles fileIndexFromSourcePointer: aSourcePointer.
	filePositionHi _ SourceFiles filePositionFromSourcePointer: aSourcePointer! !

!RemoteString methodsFor: 'accessing'!
sourceFileNumber
	"Answer the index of the file on which the string is stored."

	^sourceFileNumber! !

!RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 20:47'!
sourcePointer
	sourceFileNumber ifNil: [^ 0].
	^SourceFiles sourcePointerFromFileIndex: sourceFileNumber andPosition: filePositionHi! !

!RemoteString methodsFor: 'accessing' stamp: 'di 1/13/98 16:57'!
string 
	"Answer the receiver's string if remote files are enabled."
	| theFile |
	(sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^''].
	theFile _ SourceFiles at: sourceFileNumber.
	theFile position: filePositionHi.
	^ theFile nextChunk! !

!RemoteString methodsFor: 'accessing' stamp: 'tk 1/21/95 17:55'!
text 
	"Answer the receiver's string asText if remote files are enabled."
	| theFile |
	(sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil].
	theFile _ SourceFiles at: sourceFileNumber.
	theFile position: filePositionHi.
	^ theFile nextChunkText! !


!RemoteString methodsFor: 'private' stamp: 'tk 12/11/97 10:33'!
checkSum: aString
	"Construct a checksum of the string.  A three byte number represented as Base64 characters."

| sum shift bytes ss bb |
sum _ aString size.
shift _ 0.
aString do: [:char |
	(shift _ shift + 7) > 16 ifTrue: [shift _ shift - 17].
		"shift by 7 to keep a change of adjacent chars from xoring to same value"
	sum _ sum bitXor: (char asInteger bitShift: shift)].
bytes _ ByteArray new: 3.
sum _ sum + 16r10000000000.
1 to: 3 do: [:ind | bytes at: ind put: (sum digitAt: ind)].
ss _ ReadWriteStream on: (ByteArray new: 3).
ss nextPutAll: bytes.
bb _ Base64MimeConverter mimeEncode: ss.
^ bb contents! !

!RemoteString methodsFor: 'private'!
fileNumber: fileNumber position: position 

	sourceFileNumber _ fileNumber.
	filePositionHi _ position! !

!RemoteString methodsFor: 'private' stamp: 'tk 12/11/97 10:31'!
makeNewTextAttVersion
	"Create a new TextAttributes version because some inst var has changed.  If no change, don't make a new one."
	"Don't delete this method even though it has no callers!!!!!!!!!!"

| obj cls struct tag |
"Note that TextFontReference and TextAnchor are forbidden."
obj _ #(RunArray TextDoIt TextLink TextURL TextColor TextEmphasis TextFontChange TextKern TextLinkToImplementors 3 'a string') collect: [:each | 
		cls _ Smalltalk at: each ifAbsent: [nil].
		cls ifNil: [each] ifNotNil: [cls new]].
struct _ (SmartRefStream on: (RWBinaryOrTextStream on: String new)) instVarInfo: obj.
tag _ self checkSum: struct printString.
TextAttributeStructureVersions ifNil: [TextAttributeStructureVersions _ Dictionary new].
(struct = CurrentTextAttStructure) & (tag = CurrentTextAttVersion) 
	ifTrue: [^ false].
CurrentTextAttStructure _ struct.
CurrentTextAttVersion _ tag.
TextAttributeStructureVersions at: tag put: struct.
^ true! !

!RemoteString methodsFor: 'private'!
string: aString onFileNumber: fileNumber
	"Store this as my string if source files exist."
	| theFile |
	(SourceFiles at: fileNumber) == nil ifFalse: 
		[theFile _ SourceFiles at: fileNumber.
		theFile setToEnd; cr.
		self string: aString onFileNumber: fileNumber toFile: theFile]! !

!RemoteString methodsFor: 'private' stamp: 'tk 12/12/97 10:41'!
string: aStringOrText onFileNumber: fileNumber toFile: aFileStream 
	"Store this as the receiver's text if source files exist. If aStringOrText is a Text, store a marker with the string part, and then store the runs of TextAttributes in the next chunk."

	| position |
	position _ aFileStream position.
	self fileNumber: fileNumber position: position.
	aFileStream nextChunkPutWithStyle: aStringOrText
	"^ self		(important)"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RemoteString class
	instanceVariableNames: ''!

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:46'!
currentTextAttVersion
	"The current configuration of the TextAttributes classes has a structures array describing the inst vars of the classes (SmartRefStream instVarInfo:).  Return tag that indexes the TextAttributeStructureVersions dictionary (4 random characters)."

	^ CurrentTextAttVersion
	"Be sure to run makeNewTextAttVersion when any TextAttributes class changes inst vars"! !

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/11/97 10:35'!
initialize
	"Derive the current TextAttributes classes object structure"

	self new makeNewTextAttVersion! !

!RemoteString class methodsFor: 'as yet unclassified'!
newFileNumber: sourceIndex position: anInteger 
	"Answer an instance of me fora file indexed by sourceIndex, at the 
	position anInteger. Assume that the string is already stored on the file 
	and the instance will be used to access it."

	^self new fileNumber: sourceIndex position: anInteger! !

!RemoteString class methodsFor: 'as yet unclassified'!
newString: aString onFileNumber: sourceIndex 
	"Answer an instance of me for string, aString, on file indexed by 
	sourceIndex. Put the string on the file and create the remote reference."

	^self new string: aString onFileNumber: sourceIndex! !

!RemoteString class methodsFor: 'as yet unclassified'!
newString: aString onFileNumber: sourceIndex toFile: aFileStream
	"Answer an instance of me for string, aString, on file indexed by 
	sourceIndex. Put the string on the file, aFileStream, and create the 
	remote reference. Assume that the index corresponds properly to 
	aFileStream."

	^self new string: aString onFileNumber: sourceIndex toFile: aFileStream! !

!RemoteString class methodsFor: 'as yet unclassified' stamp: 'tk 12/13/97 13:36'!
structureAt: styleVersion

	^ TextAttributeStructureVersions at: styleVersion ifAbsent: [nil]! !
ClassCategoryReader subclass: #RenamedClassSourceReader
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!

!RenamedClassSourceReader methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 15:14'!
scanFrom: aStream

	self flag: #bob. 	"should this ever happen?"
	self halt.! !

!RenamedClassSourceReader methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 16:28'!
scanFromNoCompile: aStream

	self flag: #bob. 	"should this ever happen?"
	self halt.! !

!RenamedClassSourceReader methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 16:35'!
scanFromNoCompile: aStream forSegment: anImageSegment
	"Just move the source code for the methods from aStream."
	| methodText d |

	[
		(methodText _ aStream nextChunkText) size > 0
	] whileTrue: [
		(SourceFiles at: 2) ifNotNil: [
			d _ Dictionary new.
			d
				at: #oldClassName put: class;		"may be 'Player1' or 'Player1 class'"
				at: #methodText put: methodText;
				at: #changeStamp put: changeStamp;
				at: #category put: category.
			anImageSegment acceptSingleMethodSource: d.
		]
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RenamedClassSourceReader class
	instanceVariableNames: ''!

!RenamedClassSourceReader class methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 15:35'!
formerClassName: formerClassName methodsFor: aCategory stamp: aString

	^self new
		setClass: formerClassName 
		category: aCategory 
		changeStamp: aString! !

!RenamedClassSourceReader class methodsFor: 'as yet unclassified' stamp: 'RAA 6/22/2000 15:18'!
scanner

	^self new! !
RendererSwikiAction subclass: #RenderedSwikiAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!RenderedSwikiAction commentStamp: '<historical>' prior: 0!
Used for creating the right HTML links for Rendered Files!


!RenderedSwikiAction methodsFor: 'as yet unclassified' stamp: 'BJP 9/9/1998
21:35'!
pageURL: aPage
	"make the url suited to rendered aPage"
	^aPage coreID! !
RenderingSwikiAction subclass: #RendererSwikiAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!RendererSwikiAction commentStamp: '<historical>' prior: 0!
This class only exists to provide a different pageURL for the rendered pages

Here's how to set them up:

For FTP rendering:
| sd auth |
sd _ ServerDirectory new.
sd directory: '/net/www/fac/mark.guzdial/testSwiki'; server:
'cleon.cc.gatech.edu';
	user: 'fred'; password: 'flintstone'.
RenderingSwikiAction setUp: 'testSwiki'.
(PWS actions at: 'testswiki') serverDirectory: sd.
auth _ Authorizer new mapName: 'user' password: 'testSwiki' to: 'user'.
(PWS actions at: 'testswiki') authorizer: auth.

For local rendering:
| sd auth |
sd _ 'Guz 7600:WebSTAR 2.0:testSwiki:'.
RenderingSwikiAction setUp: 'testSwiki'.
(PWS actions at: 'testswiki') serverDirectory: sd.
auth _ Authorizer new mapName: 'user' password: 'testSwiki' to: 'user'.
(PWS actions at: 'testswiki') authorizer: auth.
!


!RendererSwikiAction methodsFor: 'as yet unclassified' stamp: 'BJP 9/9/1998
21:35'!
pageURL: aPage
	"make the url suited to rendered aPage"
	^aPage coreID,'.html'! !
AuthorizedSwikiAction subclass: #RenderingSwikiAction
	instanceVariableNames: 'serverDirectory '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!RenderingSwikiAction commentStamp: '<historical>' prior: 0!
An authorized Swiki that can generate cached pages with no link back to the
Swiki

Examples of setting them up:

Here's one that renders to an external, FTP-accessible website:
| sd auth |
sd _ ServerDirectory new.
sd directory: '/net/www/fac/mark.guzdial/testSwiki'; server: 'flintstone.com';
	user: 'fred'; password: 'flintstone'.
RenderingSwikiAction new restore: 'testSwiki'.
(PWS actions at: 'testswiki') serverDirectory: sd.
auth _ Authorizer new mapName: 'user' password: 'testSwiki' to: 'user'.
(PWS actions at: 'testswiki') authorizer: auth.

Here's one that renders to a local directory accessible from a webserver:
| sd auth |
sd _ 'Guz 7600:WebSTAR 2.0:testSwiki:'.
RenderingSwikiAction setUp: 'testSwiki'.
(PWS actions at: 'testswiki') serverDirectory: sd.
auth _ Authorizer new mapName: 'user' password: 'testSwiki' to: 'user'.
(PWS actions at: 'testswiki') authorizer: auth.
!


!RenderingSwikiAction methodsFor: 'accessing' stamp: 'mjg 8/31/1998 14:40'!
serverDirectory: anObject
	serverDirectory _ anObject. "Should be an instance of
ServerDirectory, or a path string."! !


!RenderingSwikiAction methodsFor: 'process and generate' stamp: 'mjg
8/31/1998 12:57'!
browse: pageRef from: request
	"Just reply with a page in HTML format -- use the rendering page
template rpage.html"

	| formattedPage htmlForUser |
	formattedPage _ pageRef copy.

	"Make a copy, then format the text."
	formattedPage formatted: (formatter swikify: pageRef text
			linkhandler: [:link | urlmap
					linkFor: link
					from: request peerName
					storingTo: OrderedCollection new
					page: formattedPage]).

	"format using the cached formatter"
	htmlForUser _ ((self formatterFor: 'rpage') format: formattedPage).
	htmlForUser size = 0 ifTrue: [self error: 'template file
''rpage.html'' not found'].
	request reply: htmlForUser.
! !

!RenderingSwikiAction methodsFor: 'process and generate' stamp: 'mjg
9/23/1998 09:14'!
generate: pageRef
	"Generate the page to the serverDirectory. Use the render.html page as a template"

	| formattedPage renderedFile newmap file|
	"Make a copy, then format the text."
	formattedPage _ pageRef copy.
	newmap _ urlmap copy.		" Create a new action with different action for cached form."
	newmap action: (RendererSwikiAction new).
	newmap action name: '.'.
	formattedPage formatted: (formatter swikify: pageRef text
			linkhandler: [:link | newmap
					linkFor: link
					from: 'Nowhere'
					storingTo: OrderedCollection new]).
	(serverDirectory isKindOf: String)
	ifTrue: [ "Just save the file into the directory"
		renderedFile _ (serverDirectory),(pageRef coreID),'.html'.
		(StandardFileStream isAFileNamed: renderedFile)
			ifTrue: [FileDirectory deleteFilePath: renderedFile].
		file _ FileStream fileNamed: renderedFile.
		file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source ,'render.html')
								with: formattedPage).
		file close.]
	ifFalse: [ "Assume it's FTP and send it off"
		renderedFile _ (pageRef coreID),'.html'.
		(StandardFileStream isAFileNamed: renderedFile)
			ifTrue: [FileDirectory deleteFilePath: renderedFile].
		file _ FileStream fileNamed: renderedFile.
		file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source ,'render.html')
								with: formattedPage).
		file close.
		serverDirectory putFile: (FileStream fileNamed: renderedFile) named: renderedFile.
		"FileDirectory deleteFilePath: renderedFile"]! !

!RenderingSwikiAction methodsFor: 'process and generate' stamp: 'BJP
9/9/1998 21:35'!
pageURL: aPage
	"make the URL suited to aPage"
	^(self name),'.',aPage coreID! !

!RenderingSwikiAction methodsFor: 'process and generate' stamp: 'mjg
9/9/1998 14:24'!
process: request
	"Handle requests of the form {swikiname}.{coreRef}.render"
	(request message size > 2) ifTrue: [
		((request message at: 3) = 'render') ifTrue:
		[ self generate: (urlmap atID: (request message at: 2)).
		request reply: (PWS success) ; reply: (PWS contentHTML).
		^self browse: (urlmap atID: (request message at: 2)) from:
request].
		((request message at: 3) = 'html') ifTrue: "Handle 1.html refs"
		[^self browse: (urlmap atID: (request message at: 2)) from:
request]].
	super process: request.
! !
AbstractSound subclass: #RepeatingSound
	instanceVariableNames: 'sound iterationCount iteration samplesPerIteration '
	classVariableNames: 'CarMotorSamples '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 15:54'!
setPitch: p dur: d loudness: l

	self error: 'RepeatingSounds do not support playing notes'.
! !

!RepeatingSound methodsFor: 'initialization' stamp: 'jm 9/12/97 16:39'!
setSound: aSound iterations: anIntegerOrSymbol
	"Initialize the receiver to play the given sound the given number of times. If iteration count is the symbol #forever, then repeat indefinitely."
	"(RepeatingSound repeat: AbstractSound scaleTest count: 2) play"
	"(RepeatingSound repeatForever: PluckedSound lowMajorScale) play"

	super initialize.
	sound _ aSound.
	iterationCount _ anIntegerOrSymbol.
	self reset.
! !


!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'!
iterationCount

	^ iterationCount
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'!
iterationCount: aNumber

	iterationCount _ aNumber.
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'jm 11/17/97 18:48'!
sound

	^ sound
! !

!RepeatingSound methodsFor: 'accessing' stamp: 'jm 12/15/97 22:39'!
sound: aSound

	sound _ aSound.
! !


!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:40'!
doControl

	super doControl.
	sound doControl.
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:05'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."
	"(RepeatingSound new
		setSound: FMSound majorScale
		iterations: 2) play"

	| i count samplesNeeded |
	iteration <= 0 ifTrue: [^ self].
	i _ startIndex.
	samplesNeeded _ n.
	[samplesNeeded > 0] whileTrue: [
		count _ sound samplesRemaining min: samplesNeeded.
		count = 0 ifTrue: [
			iterationCount == #forever
				ifFalse: [
					iteration _ iteration - 1.
					iteration <= 0 ifTrue: [^ self]].  "done"
			sound reset.
			count _ sound samplesRemaining min: samplesNeeded.
			count = 0 ifTrue: [^ self]].  "zero length sound"
		sound mixSampleCount: count
			into: aSoundBuffer
			startingAt: i
			leftVol: leftVol
			rightVol: rightVol.
		i _ i + count.
		samplesNeeded _ samplesNeeded - count].
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 6/30/1998 18:28'!
reset

	super reset.
	sound reset.
	samplesPerIteration _ sound samplesRemaining.
	iterationCount == #forever
		ifTrue: [iteration _ 1]
		ifFalse: [iteration _ iterationCount].
! !

!RepeatingSound methodsFor: 'sound generation' stamp: 'jm 1/18/1999 10:31'!
samplesRemaining

	iterationCount == #forever ifTrue: [^ 1000000].
	iteration > 0
		ifTrue: [^ sound samplesRemaining + ((iteration - 1) * samplesPerIteration)]
		ifFalse: [^ 0].
! !


!RepeatingSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sound."

	^ super copy copySound
! !

!RepeatingSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:34'!
copySound
	"Private!! Support for copying. Copy my component sound."

	sound _ sound copy.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RepeatingSound class
	instanceVariableNames: ''!

!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:14'!
repeat: aSound count: anInteger
	"Return a RepeatingSound that will repeat the given sound for the given number of iterations."

	^ self new setSound: aSound iterations: anInteger
! !

!RepeatingSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 16:13'!
repeatForever: aSound
	"Return a RepeatingSound that will repeat the given sound forever."

	^ self new setSound: aSound iterations: #forever
! !


!RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 10:01'!
carMotorSound
	"Return a repeating sound for the sound of a car engine."
	"RepeatingSound carMotorSound play"

	^ self carMotorSound: 10.0! !

!RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 09:32'!
carMotorSound: speed
	"Return a repeating sound for the sound of a car engine running at the given speed."
	"(RepeatingSound carMotorSound: 2.0) play"

	CarMotorSamples ifNil: [self initializeCarMotor].
	^ RepeatingSound repeatForever:
		((LoopedSampledSound
			unloopedSamples: CarMotorSamples
			pitch: 20.0
			samplingRate: 22050)
				setPitch: speed dur: 100.0 loudness: 1.0)
! !

!RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 11/16/97 11:29'!
initializeCarMotor
	"Initialize the samples array for the sound of a car engine."

	CarMotorSamples _ SoundBuffer fromArray: #(
36 199 190 508 332 167 253 302 788 884 1233 1145 977 904 991 1371 1361 1495 1253 1346 1696 1454 1631 1784 1752 1826 1389 1234 1202 1152 1188 1000 1048 898 724 937 1145 1537 2023 2079 2371 2156 2098 1855 1843 2208 2126 2218 1664 1457 1389 1454 1481 1458 1661 1400 1548 1499 1949 2055 2130 2220 2038 1904 1750 1993 2114 2272 2418 2101 1976 1791 2161 2690 2958 3013 2888 2798 2792 2875 3207 3627 3732 3842 3791 3836 3964 4082 4351 4550 4755 4746 4851 5180 5507 6100 6491 6533 6133 5394 4627 3886 3133 2209 1073 -368 -1876 -3170 -4067 -4641 -4963 -5049 -4922 -4634 -4147 -3544 -2805 -1962 -1219 -592 -326 -374 -627 -901 -1075 -1159 -1252 -1312 -1444 -1397 -1338 -1142 -748 -541 -350 -314 -265 -143 52 464 653 927 1269 1617 2048 2365 2654 2924 3306 3669 3855 3799 3160 2372 1629 1289 1635 1841 1838 1557 987 630 557 857 1005 868 435 -309 -1083 -1765 -2025 -2055 -2219 -2388 -2409 -2438 -2314 -2002 -1687 -1477 -1533 -1641 -1878 -1885 -1776 -1580 -1005 -525 -164 -84 396 768 1160 1788 2219 2365 1836 1435 1097 988 1326 1423 2106 2191 1965 1829 1578 1835 1429 1570 1596 1301 1357 1233 1634 2386 2597 3037 3225 3406 3339 3049 2935 2611 2428 2340 2728 2621 2994 2599 2591 3010 3341 3922 3992 3824 2982 2128 1376 1455 1437 2022 1927 1730 1841 1832 2334 2942 3183 3124 3362 3342 3549 3322 3474 3686 4164 4550 4051 3701 2742 2656 3210 4011 4641 4416 3697 2998 3382 3715 3729 3687 3375 3521 3932 4273 4172 3970 3598 3675 4879 5887 6320 5794 4623 4179 4453 5626 6412 6353 5563 4689 4683 5058 5905 6270 6218 6134 5704 5297 4087 2627 1221 -181 -1351 -2616 -4341 -6598 -8702 -9888 -10087 -9286 -8357 -7568 -6878 -6063 -4839 -3540 -2281 -1176 -315 248 409 337 -353 -1326 -2135 -2392 -2324 -2288 -2486 -3272 -3618 -3573 -2804 -1503 -604 267 808 1389 2069 2643 3328 3964 4706 5502 6136 6163 5665 4956 4491 4507 4409 4042 3132 1996 998 330 -116 -475 -877 -1370 -1250 -1048 -851 -740 -1207 -1166 -1040 -395 405 441 342 -281 -763 -799 -774 -447 -319 -190 -120 115 182 91 207 387 959 1462 1811 1767 1335 972 730 979 1157 1338 1347 807 591 232 417 696 664 1406 1512 2065 2416 2374 2539 2395 2483 2677 2674 2585 2299 1134 320 -336 -65 676 743 538 16 -374 -515 138 463 1043 1533 1786 2332 2258 2566 2663 2961 3599 3498 3518 2952 2309 2045 1667 1571 1504 1213 1118 1029 874 843 710 977 1377 1816 2236 2114 1989 1698 1618 1672 1682 1602 1382 1044 689 364 55 -24 4 322 669 948 1148 1193 1280 1463 1873 2261 2578 2654 2543 2312 1976 1772 1738 1763 1855 1834 1664 1469 1312 1399 1484 1732 1880 2004 2124 2090 2056 2000 2048 2227 2464 2670 2721 2511 2234 2056 2081 2263 2522 2737 2768 2728 2693 2711 2768 2891 3068 3182 3126 2913 2545 2171 1950 1820 1765 1710 1538 1319 1020 764 600 538 607 742 808 710 517 307 162 62 17 -8 -205 -486 -858 -1288 -1581 -1720 -1795 -1834 -1863 -1906 -1966 -1895 -1855 -1651 -1350 -1049 -721 -464 -265 -65 75 189 306 412 472 458 374 222 113 101 178 309 481 568 576 516 497 582 724 844 964 914 774 662 509 472 576 610 572 554 517 605 785 1008 1312 1555 1786 1957 2044 2081 2118 2193 2264 2328 2335 2277 2205 2098 2002 1981 1982 2017 1972 1912 1788 1611 1519 1428 1393 1367 1209 1045 842 624 564 509 465 398 172 11 -157 -264 -259 -269 -248 -249 -222 -266 -355 -372 -288 -158 -55 1 71 91 102 228 420 619 798 829 930 1012 1047 1210 1359 1531 1676 1702 1787 1809 1729 1668 1653 1721 1808 1793 1747 1616 1485 1476 1516 1751 1961 2029 2057 2006 1955 1893 1904 1960 1967 1975 1934 1827 1814 1749 1809 1947 2037 2098 2067 1970 1754 1627 1667 1759 1904 1890 1819 1747 1644 1698 1746 1834 1959 1922 1887 1864 1712 1734 1770 1895 2029 2062 2153 2132 2203 2206 2202 2194 2075 2019 1889 1923 1930 2090 2250 2335 2372 2209 2085 1902 1805 1826 1843 1804 1761 1605 1580 1680 1713 1825 1904 2097 2269 2373 2384 2235 2351 2445 2530 2610 2560 2618 2511 2445 2374 2111 1959 1760 1602 1474 1208 1021 786 688 654 573 526 409 452 566 694 746 831 914 1008 1043 821 513 214 -45 -242 -453 -723 -898 -1103 -1078 -1081 -1087 -1015 -1073 -869 -884 -720 -555 -329 -24 -63 14 -96 5 260 412 636 623 611 785 788 1001 1025 989 1162 1215 1404 1408 1305 1311 1120 1076 956 785 740 371 389 164 202 522 478 770 483 259 250 79 497 987 1288 1453 1283 1350 1436 1441 1804 1861 2059 2156 1969 2142 2148 2384 2652 2470 2383 1883 1739 1618 1475 1523 1134 1167 1031 816 674 274 251 162 301 387 23 -176 -345 -333 -198 -356 -363 -444 -421 -192 -226 -230 -239 -326 10 106 195 132 95 202 79 -68 -222 -45 429 788 954 1256 1426 1521 1704 1729 2053 1867 1581 1434 1367 1554 1386 1221 1165 1253 1571 1394 1425 1390 948 1288 999 1421 1568 1292 1478 1019 1053 591 693 520 302 314 116 847 1340 1792 1883 1582 1474 1821 2140 2486 2651 2167 1728 1380 1345 1811 1993 2052 2325 2231 2148 2271 2450 2831 2866 2908 2721 2623 2252 2025 2393 2667 3015 2817 2668 2588 2540 2736 2761 3275 3232 3252 3168 3112 3284 3138 3458 3716 3876 3928 3824 3928 4040 4330 4923 5226 5205 5183 5172 5510 5926 6225 6306 6020 5433 4448 3261 2118 959 -239 -1741 -3208 -4507 -5623 -6134 -6133 -5617 -4931 -4192 -3378 -2817 -2219 -1588 -817 -110 199 281 -5 -417 -652 -749 -679 -890 -1261 -1549 -1905 -1928 -2002 -1885 -1552 -1185 -655 -235 222 793 1424 1992 2599 2940 3081 2982 2695 2667 2771 2919 2980 2662 2146 1537 1215 1217 1374 1337 1061 790 376 250 -97 -111 5 -149 -243 -733 -936 -1395 -1810 -1781 -1762 -1500 -1716 -2039 -2318 -2398 -1907 -1592 -1422 -1900 -2619 -3034 -3024 -2335 -1429 -557 323 1051 1587 2021 2282 2438 2207 1843 1789 1482 1392 1056 742 1220 1294 1464 1641 1731 1847 1291 1682 1970 2097 2253 1624 1474 1312 1312 1873 2315 2523 2486 2323 2385 2924 3638 4341 4431 4045 3644 2945 2939 2935 2867 3411 2886 2731 2211 1405 1001 640 1077 1430 1688 1803 1857 2036 2447 3394 3628 3702 3468 3361 3782 3668 3672 4050 3895 4188 4564 4217 3965 2693 1946 1878 2245 3152 3267 3120 2670 2675 3308 4567 5358 5556 5114 3953 3653 3658 4111 4688 4262 3819 3732 4224 4771 5579 5622 5585 5613 5501 5593 5452 5570 5632 6094 5985 5579 4982 4206 3878 3683 3274 2172 698 -1224 -2821 -3890 -4742 -5518 -6463 -7297 -7730 -8054 -7991 -7508 -6683 -5163 -3562 -2162 -1401 -1000 -650 -255 344 643 475 -347 -1530 -2545 -3189 -3506 -3525 -3563 -3239 -2710 -1975 -1174 -649 117 1250 2603 3929 4750 4920 4876 4692 4897 5263 5455 5008 4285 3535 2650 2480 2198 1908 1831 1412 1060 602 80 -281 -245 -37 518 694 559 449 134 264 395 501 454 294 14 -188 -258 -603 -471 -526 -212 202 413 643 447 674 1151 2015 2779 2830 2783 2349 2213 2223 1805 1467 750 640 762 709 685 202 48 360 1103 1707 1935 1604 992 986 883 1293 1285 840 880 25 72 -201 -568 -194 -266 416 698 748 1106 930 1391 2268 2672 3350 3207 3010 3183 2888 3077 3048 2737 2684 2102 1594 1047 146 -39 -397 -420 -237 -520 -465 -526 -247 398 929 1605 2176 2568 2979 3102 3165 3206 3205 3315 3167 2841 2330 1660 1172 909 881 992 1021 1063 1098 1184 1407 1681 1927 2245 2498 2652 2755 2740 2720 2600 2599 2547 2529 2425 2327 2216 1983 1798 1578 1501 1596 1707 1778 1775 1794 1832 1945 2157 2368 2534 2679 2726 2647 2546 2482 2500 2613 2715 2858 2909 2875 2798 2847 3002 3238 3544 3763 3906 3870 3762 3684 3570 3510 3375 3115 2665 2099 1534 1114 848 744 650 462 329 147 161 282 430 614 681 701 635 505 263 -31 -284 -523 -787 -1040 -1310 -1530 -1694 -1726 -1660 -1541 -1319 -1101 -872 -661 -468 -289 -53 235 439 581 607 542 488 496 442 476 539 528 480 404 353 383 409 514 643 801 911 1039 1099 1060 1002 1008 1079 1079 1088 1043 998 953 947 1077 1232 1417 1630 1737 1807 1861 1947 2139 2352 2521 2494 2388 2251 2163 2142 2183 2246 2312 2333 2215 2167 2080 1954 1856 1767 1725 1685 1560 1366 1157 915 754 677 570 434 268 50 -48 -106 -80 23 -6 3 -105 -143 -106 -86 -10 15 72 129 151 224 269 377 540 615 755 802 841 986 1126 1263 1430 1501 1565 1592 1629 1704 1769 1780 1815 1868 1875 1853 1767 1657 1676 1777 1954 2063 2033 2006 1997 2052 2132 2218 2192 2163 2068 1935 1832 1731 1692 1644 1603 1587 1656 1704 1735 1707 1693 1778 1855 1886 1808 1854 1866 2020 2082 2051 2063 1922 1994 2055 1979 1867 1654 1725 1958 2103 2250 2210 2181 2136 1990 1769 1538 1555 1690 1847 1927 1833 1861 1845 1916 1901 1878 1827 1965 2079 2011 1813 1442 1294 1314 1438 1527 1471 1351 1346 1433 1541 1742 1882 2055 2187 2137 2094 2026 2216 2547 2788 2910 2700 2476 2276 2271 2219 2140 2106 1948 1839 1563 1271 991 871 785 695 490 237 93 101 302 452 541 637 735 773 731 667 554 479 381 262 -30 -313 -571 -871 -940 -1094 -1156 -946 -946 -789 -822 -1016 -846 -729 -380 -130 -174 -291 -393 -459 -370 -385 -488 -235 -189 -29 66 20 251 506 931 1376 1399 1348 1192 940 1022 839 916 1173 1247 1303 1207 950 888 944 1151 1385 1216 1012 762 741 964 995 1072 1129 1201 1243 1189 1214 1209 1090 1188 1226 962 840 480 309 201 8 -27 -108 19 120 122 175 188 247 298 326 490 659 638 530 299 294 391 561 749 632 677 592 520 445 175 452 195 476 279 54 216 -444 -153 -497 -42 65 -76 89 -307 613 424 736 729 692 1203 923 1051 761 782 993 912 1361 971 671 640 713 1230 870 821 292 243 774 1172 1686 1286 1348 1303 1523 1622 1578 1833 1810 1913 1658 1535 1352 1375 1673 2156 2537 2408 2275 2078 2090 2117 2030 2120 2227 2296 2388 2667 2966 3152 3134 2987 2799 2665 2686 2666 2584 2637 2572 2631 2836 3106 3325 3066 2882 2869 3046 3325 3369 3339 3398 3350 3293 3457 3587 3759 3999 4191 4413 4437 4477 4519 4628 4905 5061 5239 5014 4922 5179 5616 6008 6053 5515 4650 3634 2615 2101 1403 430 -981 -2592 -4097 -5331 -6002 -6365 -6339 -5996 -5552 -4825 -4058 -3378 -2538 -1678 -858 -70 377 250 -342 -1019 -1354 -1355 -1196 -1361 -1521 -1624 -1862 -1561 -1109 -638 -510 -705 -845 -1026 -585 -35 768 1668 2308 2850 3002 3103 3216 3453 3876 4335 4501 4065 3249 2233 1669 1518 1717 1688 1115 370 -493 -662 -599 -225 85 -153 -466 -954 -1270 -1132 -935 -978 -1481 -2039 -2683 -3353 -3678 -3673 -3362 -2780 -2386 -2281 -2137 -2034 -1498 -801 -239 351 480 608 886 1176 1592 1788 2106 2205 2010 1893 1582 1539 1597 1795 1990 2158 2092 1255 800 1029 1404 1884 2085 1537 1103 919 870 2111 3220 3367 3480 2671 2319 2914 3620 4073 3498 2841 2067 1810 2225 2669 3168 2603 1347 499 729 1563 2063 1953 1175 432 458 1393 2521 3149 3279 2822 2467 2697 3005 3756 4386 4418 4555 3662 3241 3320 3520 3914 4087 3923 2896 2532 1732 1807 2221 2972 3933 3101 2464 1657 1615 2639 3948 4718 5026 4305 3909 3815 3811 4014 3853 4090 4153 4670 4783 4527 4113 4296 4866 5695 6258 6024 5748 5089 5020 5101 4974 4353 3499 2056 779 -738 -2628 -4028 -5515 -6213 -6815 -7376 -7953 -8558 -8565 -7680 -6158 -4573 -3152 -2390 -1579 -792 -128 414 470 360 165 -390 -1164 -2225 -3460 -4085 -4255 -3862 -3277 -2975 -2731 -2390 -1656 -387 1008 2146 3014 3428 3832 4526 4822 4875 4472 3941 3954 3945 3710 2856 1848 931 619 1054 1206 877 318 -270 -412 34 160 399 532 402 655 568 472 246 -92 356 716 776 540 -331 -730 -548 -242 338 202 -72 4 -6 637 885 1005 1330 1619 2174 2350 2069 1709 1412 1476 1747 1558 1230 711 321 398 293 313 92 81 454 659 806 581 346 351 585 870 851 436 -76 -479 -756 -907 -1190 -1414 -1586 -1628 -1483 -1389 -1238 -816 -177 556 1249 1735 2074 2385 2710 3065 3264 3285 3143 2928 2692 2297 1832 1387 1022 955 1088 1101 1028 872 870 1090 1475 1976 2316 2578 2716 2705 2557 2467 2367 2328 2364 2301 2073 1686 1366 1175 1116 1199 1196 1109 962 920 934 983 1051 1258 1536 1752 1836 1770 1680 1643 1800 1954 2082 2111 1986 1885 1813 1824 1898 2088 2236 2353 2399 2340 2255 2213 2244 2350 2365 2326 2266 2154 2072 2068 2093 2130 2223 2295 2394 2515 2449 2426 2527 2778 3021 3240 3286 3216 3108 3004 3042 3106 3147 2990 2690 2282 1902 1641 1457 1359 1172 825 473 189 106 166 377 569 634 551 403 364 415 437 366 107 -242 -524 -723 -824 -959 -1100 -1264 -1381 -1408 -1252 -1072 -932 -889 -819 -581 -341 -107 56 128 156 158 185 260 284 270 324 376 391 423 449 446 429 521 569 566 584 546 589 624 594 594 584 607 725 876 976 1004 1046 1082 1193 1341 1372 1434 1446 1409 1528 1618 1747 1911 1985 2090 2092 2110 2170 2230 2360 2411 2433 2402 2317 2280 2227 2126 2017 1878 1729 1564 1406 1237 1073 957 906 841 788 706 548 437 429 449 554 653 664 582 500 486 511 519 430 339 318 294 287 265 288 299 429 605 681 822 808 887 950 1042 1240 1348 1547 1638 1752 1787 1765 1864 1949 2025 2058 1990 1921 1818 1707 1755 1810 2007 2069 2017 1840 1623 1633 1646 1803 1962 2002 1985 1838 1694 1588 1493 1551 1685 1756 1784 1604 1458 1532 1660 1898 1986 1737 1551 1457 1665 1890 2078 2066 2082 2181 2156 2167 2174 2290 2341 2314 2302 2134 2114 2054 2020 2109 1974 1916 1841 1628 1718 1718 1860 1951 1774 1893 1745 1701 1769 1541 1733 1542 1509 1547 1370 1640 1572 1480 1679 1501 1747 1697 1748 1973 1763 1949 1795 2000 2185 2249 2600 2532 2713 2672 2558 2572 2506 2691 2760 2797 2680 2299 1992 1796 1558 1444 1055 663 489 6 -197 -508 -713 -632 -763 -579 -532 -472 -253 -174 -66 75 -39 72 208 312 339 87 16 -170 -198 -166 -227 -270 -498 -495 -406 -544 -569 -766 -656 -500 -344 -121 -161 -67 -60 97 96 47 31 -76 163 173 417 465 257 332 5 48 -14 -135 124 -51 17 -190 -361 -127 -23 352 410 491 632 489 608 746 1100 1463 1473 1668 1380 1289 1319 1575 1979 1935 1824 1385 1265 1351 1528 1675 1429 1018 548 133 -254 -466 -736 -796 -815 -994 -916 -948 -584 -366 -196 -132 -119 -108 -165 12 -235 -107 -353 -349 -579 -765 -953 -1235 -888 -764 -286 -769 -804 -787 -508 255 127 169 -177 -373 -111).
! !
Notification subclass: #RequestAlternateSyntaxSetting
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!RequestAlternateSyntaxSetting commentStamp: '<historical>' prior: 0!
I provide a way to override the current setting of the alternate syntax preference. I am used when filing in code to insure that the Smalltalk-80 preference is used regardless of what the user likes to see in her browsers.!


!RequestAlternateSyntaxSetting methodsFor: 'as yet unclassified' stamp: 'RAA 6/14/2000 13:41'!
defaultAction

        self resume: Preferences printAlternateSyntax! !
Notification subclass: #RequestCurrentWorldNotification
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!RequestCurrentWorldNotification commentStamp: '<historical>' prior: 0!
I provide a way to alter the "currentWorld" in which non-specific things happen. Code which says:

	aMorph openInWorld

for example, will try to open in this "currentWorld" (whose precise definition is still a bit fuzzy). By writing something like:

	[
		someAnonymousStuff happen
	]
		on: RequestCurrentWorldNotification
		do: [ :ex | ex resume: aParticularWorld ]

you can ensure that <aParticularWorld> is used for any non-specific world request during the execution of the block.!


!RequestCurrentWorldNotification methodsFor: 'as yet unclassified' stamp: 'RAA 6/14/2000 17:03'!
defaultAction

        self resume: nil! !
AbstractSound subclass: #RestSound
	instanceVariableNames: 'initialCount count '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!RestSound methodsFor: 'initialization' stamp: 'jm 1/28/98 13:08'!
setDur: d
	"Set rest duration in seconds."

	initialCount _ (d * self samplingRate asFloat) rounded.
	count _ initialCount.
	self reset.
! !


!RestSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'!
duration
	"Answer the duration of this sound in seconds."

	^ initialCount asFloat / self samplingRate
! !

!RestSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:42'!
duration: seconds

	super duration: seconds.
	count _ initialCount _ (seconds * self samplingRate) rounded.
! !

!RestSound methodsFor: 'accessing' stamp: 'di 2/17/1999 21:09'!
samples
	^ SoundBuffer newMonoSampleCount: initialCount! !


!RestSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:04'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play silence for a given duration."
	"(RestSound dur: 1.0) play"

	count _ count - n.
! !

!RestSound methodsFor: 'sound generation'!
reset

	super reset.
	count _ initialCount.
! !

!RestSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:37'!
samplesRemaining

	^ count
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RestSound class
	instanceVariableNames: ''!

!RestSound class methodsFor: 'instance creation' stamp: 'jm 3/31/1999 21:05'!
dur: d
	"Return a rest of the given duration."

	^ self new setDur: d
! !

!RestSound class methodsFor: 'instance creation' stamp: 'jm 12/15/97 22:38'!
pitch: p dur: d loudness: l
	"Return a rest of the given duration."
	"Note: This message allows one to silence one or more voices of a multi-voice piece by using RestSound as their instrument."

	^ self new setDur: d
! !
ValueSpecification subclass: #ResultSpecification
	instanceVariableNames: 'companionSetterSelector refetchFrequency '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!

!ResultSpecification methodsFor: 'companion setter' stamp: 'sw 12/11/2000 14:34'!
companionSetterSelector: aSetterSelector
	"Set the receiver's companionSetterSelector as indicated"

	companionSetterSelector _ aSetterSelector! !


!ResultSpecification methodsFor: 'result type' stamp: 'sw 1/30/2001 20:14'!
resultType: aType
	"Set the receiver's resultType as specified"

	protocol _ aType! !
ParseNode subclass: #ReturnNode
	instanceVariableNames: 'expr pc '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!ReturnNode commentStamp: '<historical>' prior: 0!
I represent an expression of the form ^expr.!


!ReturnNode methodsFor: 'initialize-release'!
expr: e

	expr _ e! !

!ReturnNode methodsFor: 'initialize-release'!
expr: e encoder: encoder sourceRange: range

	expr _ e.
	encoder noteSourceRange: range forNode: self! !


!ReturnNode methodsFor: 'converting'!
asReturnNode! !


!ReturnNode methodsFor: 'testing'!
isReturnSelf

	^expr == NodeSelf! !

!ReturnNode methodsFor: 'testing'!
isSpecialConstant

	^expr isSpecialConstant! !

!ReturnNode methodsFor: 'testing'!
isVariableReference

	^expr isVariableReference! !


!ReturnNode methodsFor: 'code generation'!
code

	^expr code! !

!ReturnNode methodsFor: 'code generation'!
emitForReturn: stack on: strm

	expr emitForReturn: stack on: strm.
	pc _ strm position! !

!ReturnNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	expr emitForReturn: stack on: strm.
	pc _ strm position! !

!ReturnNode methodsFor: 'code generation'!
pc
	"Used by encoder source mapping."

	^pc! !

!ReturnNode methodsFor: 'code generation'!
sizeForReturn: encoder

	^expr sizeForReturn: encoder! !

!ReturnNode methodsFor: 'code generation'!
sizeForValue: encoder

	^expr sizeForReturn: encoder! !


!ReturnNode methodsFor: 'printing' stamp: 'di 6/11/2000 15:28'!
printOn: aStream indent: level

	aStream dialect = #SQ00
		ifTrue: ["Add prefix keyword"
				aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Answer '].
				expr printOn: aStream indent: level]
		ifFalse: [aStream nextPutAll: '^ '.
				expr printOn: aStream indent: level].
	expr printCommentOn: aStream indent: level.
! !


!ReturnNode methodsFor: 'C translation' stamp: 'hg 8/14/2000 15:34'!
asTranslatorNode
	^TReturnNode new 
		setExpression: expr asTranslatorNode;
		comment: comment! !


!ReturnNode methodsFor: 'tiles' stamp: 'di 11/20/2000 15:53'!
asMorphicSyntaxIn: parent

	| row |
	row _ parent addRow: #return on: self.
	row addToken: '^ ' type: #assignment on: self.
	expr asMorphicSyntaxIn: row.
	expr addCommentToMorph: row.
	^row
! !

!ReturnNode methodsFor: 'tiles' stamp: 'RAA 8/15/1999 19:31'!
explanation

	^'Exit this method returning the value of ',expr explanation
! !
AbstractSound subclass: #ReverbSound
	instanceVariableNames: 'sound tapDelays tapGains tapCount bufferSize bufferIndex leftBuffer rightBuffer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/7/98 22:41'!
sound

	^ sound
! !

!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/7/98 22:42'!
sound: aSound

	sound _ aSound.
! !

!ReverbSound methodsFor: 'accessing' stamp: 'jm 1/27/98 19:10'!
tapDelays: delayList gains: gainList
	"ReverbSound new tapDelays: #(537 691 1191) gains: #(0.07 0.07 0.07)"

	| maxDelay gain d |
	delayList size = gainList size
		ifFalse: [self error: 'tap delay and gains lists must be the same size'].
	tapCount _ delayList size.
	tapDelays _ Bitmap new: tapCount.
	tapGains _ Bitmap new: tapCount.

	maxDelay _ 0.
	1 to: tapGains size do: [:i |
		tapDelays at: i put: (delayList at: i) asInteger.
		gain _ gainList at: i.
		gain >= 1.0 ifTrue: [self error: 'reverb tap gains must be under 1.0'].
		tapGains at: i put: (gain * ScaleFactor) asInteger.
		d _ tapDelays at: i.
		d > maxDelay ifTrue: [maxDelay _ d]].
	bufferSize _ maxDelay.
	leftBuffer _ SoundBuffer newMonoSampleCount: maxDelay.
	rightBuffer _ SoundBuffer newMonoSampleCount: maxDelay.
	bufferIndex _ 1.
! !


!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 14:32'!
doControl

	super doControl.
	sound doControl.
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 15:00'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play my sound with reberberation."

	sound mixSampleCount: n
		into: aSoundBuffer
		startingAt: startIndex
		leftVol: leftVol
		rightVol: rightVol.
	self applyReverbTo: aSoundBuffer startingAt: startIndex count: n.
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 16:47'!
reset

	super reset.
	sound reset.
	1 to: bufferSize do: [:i |
		leftBuffer at: i put: 0.
		rightBuffer at: i put: 0].
! !

!ReverbSound methodsFor: 'sound generation' stamp: 'jm 1/21/98 17:02'!
samplesRemaining

	^ sound samplesRemaining
! !


!ReverbSound methodsFor: 'copying' stamp: 'jm 1/21/98 14:29'!
copy
	"Copy my component sound."

	^ super copy copySound
! !

!ReverbSound methodsFor: 'copying' stamp: 'jm 1/21/98 16:18'!
copySound
	"Private!! Support for copying. Copy my component sound."

	sound _ sound copy.
	leftBuffer _ leftBuffer clone.
	rightBuffer _ rightBuffer clone.
! !


!ReverbSound methodsFor: 'private' stamp: 'ar 2/3/2001 15:55'!
applyReverbTo: aSoundBuffer startingAt: startIndex count: n

	| delayedLeft delayedRight i tapGain j out |
	<primitive: 'primitiveApplyReverb' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #tapDelays declareC: 'int *tapDelays'.
	self var: #tapGains declareC: 'int *tapGains'.
	self var: #leftBuffer declareC: 'short int *leftBuffer'.
	self var: #rightBuffer declareC: 'short int *rightBuffer'.

	startIndex to: ((startIndex + n) - 1) do: [:sliceIndex |
		delayedLeft _ delayedRight _ 0.
		1 to: tapCount do: [:tapIndex |
			i _ bufferIndex - (tapDelays at: tapIndex).
			i < 1 ifTrue: [i _ i + bufferSize].  "wrap"
			tapGain _ tapGains at: tapIndex.
			delayedLeft _ delayedLeft + (tapGain * (leftBuffer at: i)).
			delayedRight _ delayedRight + (tapGain * (rightBuffer at: i))].

		"left channel"
		j _ (2 * sliceIndex) - 1.
		out _ (aSoundBuffer at: j) + (delayedLeft // ScaleFactor).
		out >  32767 ifTrue: [out _  32767].  "clipping!!"
		out < -32767 ifTrue: [out _ -32767].  "clipping!!"
		aSoundBuffer at: j put: out.
		leftBuffer at: bufferIndex put: out.

		"right channel"
		j _ j + 1.
		out _ (aSoundBuffer at: j) + (delayedRight // ScaleFactor).
		out >  32767 ifTrue: [out _  32767].  "clipping!!"
		out < -32767 ifTrue: [out _ -32767].  "clipping!!"
		aSoundBuffer at: j put: out.
		rightBuffer at: bufferIndex put: out.

		bufferIndex _ (bufferIndex \\ bufferSize) + 1].
! !
RectangleMorph subclass: #RulerMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!RulerMorph methodsFor: 'as yet unclassified'!
drawOn: aCanvas

	| s |
	super drawOn: aCanvas.
	s _ self width printString, 'x', self height printString.
	aCanvas text: s bounds: (bounds insetBy: borderWidth + 5) font: nil color: Color red.
! !

!RulerMorph methodsFor: 'as yet unclassified'!
initialize

	super initialize.
	self color: (Color r: 0.8 g: 1.0 b: 1.0).
	self borderWidth: 1.
! !
ArrayedCollection subclass: #RunArray
	instanceVariableNames: 'runs values lastIndex lastRun lastOffset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!RunArray commentStamp: '<historical>' prior: 0!
My instances provide space-efficient storage of data which tends to be constant over long runs of the possible indices. Essentially repeated values are stored singly and then associated with a "run" length that denotes the number of consecutive occurrences of the value.

My two important variables are
	runs	An array of how many elements are in each run
	values	An array of what the value is over those elements

The variables lastIndex, lastRun and lastOffset cache the last access
so that streaming through RunArrays is not an N-squared process.

Many complexities of access can be bypassed by using the method
	RunArray withStartStopAndValueDo:!
]style[(615 33)f1,f1LRunArray withStartStopAndValueDo:;!


!RunArray methodsFor: 'accessing' stamp: 'di 1/15/1999 00:04'!
= otherArray 
	"Test if all my elements are equal to those of otherArray"

	(otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray].

	"Faster test between two RunArrays"
 	^ (runs hasEqualElements: otherArray runs)
		and: [values hasEqualElements: otherArray values]! !

!RunArray methodsFor: 'accessing'!
at: index

	self at: index setRunOffsetAndValue: [:run :offset :value | ^value]! !

!RunArray methodsFor: 'accessing'!
runLengthAt: index 
	"Answer the length remaining in run beginning at index."

	self at: index 
		setRunOffsetAndValue: [:run :offset :value | ^(runs at: run) - offset]! !

!RunArray methodsFor: 'accessing'!
size
	| size |
	size _ 0.
	1 to: runs size do: [:i | size _ size + (runs at: i)].
	^size! !

!RunArray methodsFor: 'accessing' stamp: 'di 11/10/97 13:34'!
withStartStopAndValueDo: aBlock
	| start stop |
	start _ 1.
	runs with: values do:
		[:len : val | stop _ start + len - 1.
		aBlock value: start value: stop value: val.
		start _ stop + 1]
		! !


!RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:16'!
addFirst: value
	"Add value as the first element of the receiver."
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values first ~= value])
	  ifTrue:
		[runs addFirst: 1.
		values addFirst: value]
	  ifFalse:
		[runs at: 1 put: runs first+1]! !

!RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'!
addLast: value
	"Add value as the last element of the receiver."
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values last ~= value])
	  ifTrue:
		[runs addLast: 1.
		values addLast: value]
	  ifFalse:
		[runs at: runs size put: runs last+1]! !

!RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'!
addLast: value  times: times
	"Add value as the last element of the receiver, the given number of times"
	times = 0 ifTrue: [ ^self ].
	lastIndex _ nil.  "flush access cache"
	(runs size=0 or: [values last ~= value])
	  ifTrue:
		[runs add: times.
		values add: value]
	  ifFalse:
		[runs at: runs size put: runs last+times]! !

!RunArray methodsFor: 'adding' stamp: 'tk 1/28/98 09:28'!
coalesce
	"Try to combine adjacent runs"
	| ind |
	ind _ 2.
	[ind > values size] whileFalse: [
		(values at: ind-1) = (values at: ind) 
			ifFalse: [ind _ ind + 1]
			ifTrue: ["two are the same, combine them"
				values _ values copyReplaceFrom: ind to: ind with: #().
				runs at: ind-1 put: (runs at: ind-1) + (runs at: ind).
				runs _ runs copyReplaceFrom: ind to: ind with: #().
				"self error: 'needed to combine runs' "]].
			! !

!RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'!
repeatLast: times  ifEmpty: defaultBlock
	"add the last value back again, the given number of times.  If we are empty, add (defaultBlock value)"
	times = 0 ifTrue: [^self ].
	lastIndex _ nil.  "flush access cache"
	(runs size=0)
	  ifTrue:
		[runs addLast: times.
		values addLast: defaultBlock value]
	  ifFalse:
		[runs at: runs size put: runs last+times] ! !

!RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'!
repeatLastIfEmpty: defaultBlock
	"add the last value back again.  If we are empty, add (defaultBlock value)"
	lastIndex _ nil.  "flush access cache"
	(runs size=0)
	  ifTrue:[
		 runs addLast: 1.
		values addLast: defaultBlock value]
	  ifFalse:
		[runs at: runs size put: runs last+1]! !


!RunArray methodsFor: 'copying'!
, aRunArray 
	"Answer a new RunArray that is a concatenation of the receiver and
	aRunArray."

	| new newRuns |
	(aRunArray isMemberOf: RunArray)
		ifFalse: 
			[new _ self copy.
			"attempt to be sociable"
			aRunArray do: [:each | new addLast: each].
			^new].
	runs size = 0 ifTrue: [^aRunArray copy].
	aRunArray runs size = 0 ifTrue: [^self copy].
	values last ~= aRunArray first
		ifTrue: [^RunArray
					runs: runs , aRunArray runs
					values: values , aRunArray values].
	newRuns _ runs
					copyReplaceFrom: runs size
					to: runs size
					with: aRunArray runs.
	newRuns at: runs size put: runs last + aRunArray runs first.
	^RunArray
		runs: newRuns
		values: 
			(values
				copyReplaceFrom: values size
				to: values size
				with: aRunArray values)! !

!RunArray methodsFor: 'copying' stamp: 'ls 10/10/1999 13:15'!
copyFrom: start to: stop
	| newRuns run1 run2 offset1 offset2 | 
	stop < start ifTrue: [^RunArray new].
	self at: start setRunOffsetAndValue: [:r :o :value1 | run1 _ r. offset1
_ o.  value1].
	self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 _ r. offset2
_ o. value2].
	run1 = run2
		ifTrue: 
			[newRuns _ Array with: offset2 - offset1 + 1]
		ifFalse: 
			[newRuns _ runs copyFrom: run1 to: run2.
			newRuns at: 1 put: (newRuns at: 1) - offset1.
			newRuns at: newRuns size put: offset2 + 1].
	^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! !

!RunArray methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: replacement

	^(self copyFrom: 1 to: start - 1)
		, replacement 
		, (self copyFrom: stop + 1 to: self size)! !


!RunArray methodsFor: 'printing' stamp: 'sma 6/1/2000 09:47'!
printOn: aStream
	self printNameOn: aStream.
	aStream
		nextPutAll: ' runs: ';
		print: runs;
		nextPutAll: ' values: ';
		print: values! !

!RunArray methodsFor: 'printing'!
storeOn: aStream

	aStream nextPut: $(.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' runs: '.
	runs storeOn: aStream.
	aStream nextPutAll: ' values: '.
	values storeOn: aStream.
	aStream nextPut: $)! !

!RunArray methodsFor: 'printing'!
writeOn: aStream

	aStream nextWordPut: runs size.
	1 to: runs size do:
		[:x |
		aStream nextWordPut: (runs at: x).
		aStream nextWordPut: (values at: x)]! !

!RunArray methodsFor: 'printing' stamp: 'tk 12/16/97 09:18'!
writeScanOn: strm
	"Write out the format used for text runs in source files. (14 50 312)f1,f1b,f1LInteger +;i"

	strm nextPut: $(.
	runs do: [:rr | rr printOn: strm.  strm space].
	strm skip: -1; nextPut: $).
	values do: [:vv |
		vv do: [:att | att writeScanOn: strm].
		strm nextPut: $,].
	strm skip: -1.  "trailing comma"! !


!RunArray methodsFor: 'private'!
at: index setRunOffsetAndValue: aBlock 
	"Supply all run information to aBlock."
	"Tolerates index=0 and index=size+1 for copyReplace: "
	| run limit offset |
	limit _ runs size.
	(lastIndex == nil or: [index < lastIndex])
		ifTrue:  "cache not loaded, or beyond index - start over"
			[run _ 1.
			offset _ index-1]
		ifFalse:  "cache loaded and before index - start at cache"
			[run _ lastRun.
			offset _ lastOffset + (index-lastIndex)].
	[run <= limit and: [offset >= (runs at: run)]]
		whileTrue: 
			[offset _ offset - (runs at: run).
			run _ run + 1].
	lastIndex _ index.  "Load cache for next access"
	lastRun _ run.
	lastOffset _ offset.
	run > limit
		ifTrue: 
			["adjustment for size+1"
			run _ run - 1.
			offset _ offset + (runs at: run)].
	^aBlock
		value: run	"an index into runs and values"
		value: offset	"zero-based offset from beginning of this run"
		value: (values at: run)	"value for this run"! !

!RunArray methodsFor: 'private'!
mapValues: mapBlock
	"NOTE: only meaningful to an entire set of runs"
	values _ values collect: [:val | mapBlock value: val]! !

!RunArray methodsFor: 'private'!
runs

	^runs! !

!RunArray methodsFor: 'private'!
setRuns: newRuns setValues: newValues
	lastIndex _ nil.  "flush access cache"
	runs _ newRuns.
	values _ newValues! !

!RunArray methodsFor: 'private'!
values
	"Answer the values in the receiver."

	^values! !


!RunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:43'!
runsAndValuesDo: aBlock
	"Evaluate aBlock with run lengths and values from the receiver"
	^runs with: values do: aBlock.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

RunArray class
	instanceVariableNames: ''!

!RunArray class methodsFor: 'instance creation' stamp: 'ls 8/20/1998 10:12'!
new

	^self runs: OrderedCollection new values: OrderedCollection new! !

!RunArray class methodsFor: 'instance creation' stamp: 'ls 8/20/1998 10:12'!
new: size withAll: value 
	"Answer a new instance of me, whose every element is equal to the
	argument, value."

	size = 0 ifTrue: [^self new].
	^self runs: (OrderedCollection with: size) values: (OrderedCollection with: value)! !

!RunArray class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newCollection |
	newCollection _ self new.
	aCollection do: [:x | newCollection addLast: x].
	^newCollection

"	RunArray newFrom: {1. 2. 2. 3}
	{1. $a. $a. 3} as: RunArray
	({1. $a. $a. 3} as: RunArray) values
"! !

!RunArray class methodsFor: 'instance creation'!
readFrom: aStream
	"Answer an instance of me as described on the stream, aStream."

	| size runs values |
	size _ aStream nextWord.
	runs _ Array new: size.
	values _ Array new: size.
	1 to: size do:
		[:x |
		runs at: x put: aStream nextWord.
		values at: x put: aStream nextWord].
	^ self runs: runs values: values! !

!RunArray class methodsFor: 'instance creation'!
runs: newRuns values: newValues 
	"Answer an instance of me with runs and values specified by the 
	arguments."

	| instance |
	instance _ self basicNew.
	instance setRuns: newRuns setValues: newValues.
	^instance! !

!RunArray class methodsFor: 'instance creation' stamp: 'RAA 10/19/2000 16:28'!
scanFrom: strm
	"Read the style section of a fileOut or sources file.  nextChunk has already been done.  We need to return a RunArray of TextAttributes of various kinds."
	| rr vv aa this |
	(strm peekFor: $( ) ifFalse: [^ nil].
	rr _ OrderedCollection new.
	[strm skipSeparators.
	 strm peekFor: $)] whileFalse: 
		[rr add: (Number readFrom: strm)].
	vv _ OrderedCollection new.	"Value array"
	aa _ OrderedCollection new.	"Attributes list"
	[(this _ strm next) == nil] whileFalse: [
		this == $, ifTrue: [vv add: aa asArray.  aa _ OrderedCollection new].
		this == $f ifTrue: [aa add: 
			(TextFontChange new fontNumber: (Number readFrom: strm))].
		this == $b ifTrue: [aa add: (TextEmphasis bold)].
		this == $i ifTrue: [aa add: (TextEmphasis italic)].
		this == $u ifTrue: [aa add: (TextEmphasis underlined)].
		this == $= ifTrue: [aa add: (TextEmphasis struckOut)].
		this == $n ifTrue: [aa add: (TextEmphasis normal)].
		this == $- ifTrue: [aa add: (TextKern kern: -1)].
		this == $+ ifTrue: [aa add: (TextKern kern: 1)].
		this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color"
		this == $L ifTrue: [aa add: (TextLink scanFrom: strm)].	"L not look like 1"
		this == $R ifTrue: [aa add: (TextURL scanFrom: strm)].
				"R capitalized so it can follow a number"
		this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)].
		this == $p ifTrue: [aa add: (TextSqkProjectLink scanFrom: strm)].
		this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)].
		"space, cr do nothing"
		].
	aa size > 0 ifTrue: [vv add: aa asArray].
	^ self runs: rr asArray values: vv asArray
"
RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i')
"! !
SimpleClientSocket subclass: #SMTPSocket
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Protocols'!
!SMTPSocket commentStamp: '<historical>' prior: 0!
This class implements the SMTP (mail sending) protocol specified in RFC 821.

Note that it does not look up DNS MX records when sending to the specified host, so it will not work correctly to send directly to large structured domain names like "intel.com" or "microsoft.com", but it will work fine for talking with your local mail server which will then pass along the mail to the real destination.

Note also that the error reporting is done with error: and so an exception handler must be wrapped around the sending call in case it fails.!


!SMTPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/14/1998 12:52'!
connectToSMTPServer: serverName
	"connect to the given server on the SMTP port"
	| addr |
	Socket initializeNetwork.
	addr _ NetNameResolver addressForName: serverName.
	addr ifNil: [self error: 'Could not find host address'].

	Transcript show: 'connecting to ', serverName, '...'.
	self connectTo: addr  port: 25.
	self waitForConnectionUntil: Socket standardDeadline.
	self isConnected ifFalse: [
		^false ].

	self checkSMTPResponse.

	self sendCommand: 'HELO aSqueakSystem'.
	self checkSMTPResponse.

	^true! !

!SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:38'!
data: messageData
	"send the data of a message"
	| cookedLine |

	"inform the server we are sending the message data"
	self sendCommand: 'DATA'.
	self checkSMTPResponse.

	"process the data one line at a time"
	messageData linesDo:  [ :messageLine |
		cookedLine _ messageLine.
		(cookedLine beginsWith: '.') ifTrue: [ 
			"lines beginning with a dot must have the dot doubled"
			cookedLine _ '.', cookedLine ].
		self sendCommand: cookedLine ].

	"inform the server the entire message text has arrived"
	self sendCommand: '.'.
	self checkSMTPResponse.! !

!SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:13'!
getSMTPResponse
	"wait for an SMTP response, and return the number of the response"
	| line |
	[ line _ self getResponse.
	Transcript show: line.
	(line at: 4) = $- ] whileTrue.

	^(line copyFrom: 1 to: 3) asNumber! !

!SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:21'!
mailFrom: fromAddress
	self sendCommand: 'MAIL FROM: <', fromAddress, '>'.
	self checkSMTPResponse.! !

!SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:31'!
quit
	"send a QUIT command.  This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT"
	self sendCommand: 'QUIT'.
	self checkSMTPResponse.! !

!SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:20'!
recipient: aRecipient
	"specify a recipient for the message.  aRecipient should be a bare email address"
	self sendCommand: 'RCPT TO: <', aRecipient, '>'.
	self checkSMTPResponse.! !


!SMTPSocket methodsFor: 'private' stamp: 'ls 9/10/1998 22:37'!
checkSMTPResponse
	"get an SMTP response, and check that it's in the 200's or 300's.  If it's not, close the socket and issue an error:"
	(#(2 3) includes: self getSMTPResponse // 100) ifFalse: [
		self close.
		self error: 'server responded with an error' ].! !


!SMTPSocket methodsFor: 'public protocol' stamp: 'mdr 10/12/1998 14:41'!
mailFrom: sender to: recipientList text: messageText
	"deliver this mail to a list of users.  NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff"

	self mailFrom: sender.
	recipientList do: [ :recipient |
		self recipient: recipient ].
	self data: messageText.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SMTPSocket class
	instanceVariableNames: ''!

!SMTPSocket class methodsFor: 'sending mail' stamp: 'mdr 1/28/1999 16:42'!
deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName
	"Deliver a single email to a list of users and then close the connection.  For delivering multiple messages, it is best to create a single connection and send all mail over it.  NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff"

	| sock |
	sock _ self usingServer: serverName.
	sock mailFrom: fromAddress to: recipientList text: messageText.
	sock quit.
	sock close.
	^true
! !


!SMTPSocket class methodsFor: 'examples' stamp: 'ls 9/10/1998 22:40'!
example
	"SMTPSocket example"
	"send a message over SMTP"

	self deliverMailFrom: 'lex@cc.gatech.edu' to: #(root src) text:
'From: test
To: "not listed"
Subject: this is a test

Hello from Squeak!!
'	usingServer: 'localhost'.
! !

!SMTPSocket class methodsFor: 'examples' stamp: 'ls 9/10/1998 22:36'!
example2
	"SMTPSocket example2"
	"send a message using the low-level protocol methods.  Normally one would just use the high-level class message"

	| sock |
	sock _ self new.
	sock connectToSMTPServer: 'localhost'.
	sock mailFrom: 'lex@cc.gatech.edu'.
	sock recipient: 'lex@localhost'.
	sock recipient: 'root'.
	sock data:
'From: test
To: "not listed"
Subject: this is a test

Hi, this is a test message.
'.
	sock quit.
	sock close.! !


!SMTPSocket class methodsFor: 'instance creation' stamp: 'mdr 1/29/1999 18:59'!
usingServer: serverName
	"Create a SMTP socket to the specified server for sending one or more mail messages"

	| sock |
	Socket initializeNetwork.
	sock _ self new.
	sock connectToSMTPServer: serverName.
	^sock! !
AlignmentMorph subclass: #SameGame
	instanceVariableNames: 'board scoreDisplay selectionDisplay helpText '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!SameGame commentStamp: '<historical>' prior: 0!
See SameGame>>helpString for an explanation of how to play!


!SameGame methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:21'!
buildButton: aButton target: aTarget label: aLabel selector: aSelector
	"wrap a button or switch in an alignmentMorph to allow a row of buttons to fill space"

	| a |
	aButton 
		target: aTarget;
		label: aLabel;
		actionSelector: aSelector;
		borderColor: #raised;
		borderWidth: 2;
		color: color.
	a _ AlignmentMorph newColumn
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap;
		color: color.
	a addMorph: aButton.
	^ a

! !

!SameGame methodsFor: 'initialization' stamp: 'ar 11/20/2000 19:48'!
initialize
	super initialize.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	self layoutInset: 3.
	color _ Color lightGray.
	self addMorph: self makeControls.
	self addMorph: self board.
	helpText _ nil.
	self newGame.! !

!SameGame methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:22'!
makeControls

	| row |
	row _ AlignmentMorph newRow
		color: color;
		borderWidth: 0;
		layoutInset: 3.
	row hResizing: #spaceFill; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; extent: 5@5.
	row addMorph:
		(self
			buildButton: SimpleSwitchMorph new
			target: self
			label: 'Help'
			selector: #help:).
	row addMorph:
		(self
			buildButton: SimpleButtonMorph new
			target: self
			label: 'Quit'
			selector: #delete).
	row addMorph:
		(self
			buildButton: SimpleButtonMorph new
			target: self board
			label: 'Hint'
			selector: #hint).
	row addMorph:
		(self
			buildButton: SimpleButtonMorph new
			target: self
			label: 'New game'
			selector: #newGame).
	selectionDisplay _ LedMorph new
		digits: 2;
		extent: (2*10@15).
	row addMorph: (self wrapPanel: selectionDisplay label: 'Selection:').
	scoreDisplay _ LedMorph new
		digits: 4;
		extent: (4*10@15).
	row addMorph: (self wrapPanel: scoreDisplay label: 'Score:').
	^ row! !

!SameGame methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:22'!
wrapPanel: anLedPanel label: aLabel
	"wrap an LED panel in an alignmentMorph with a label to its left"

	| a |
	a _ AlignmentMorph newRow
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 0;
		layoutInset: 3;
		color: color lighter.
	a addMorph: anLedPanel.
	a addMorph: (StringMorph contents: aLabel). 
	^ a

! !


!SameGame methodsFor: 'access' stamp: 'tao 5/18/1998 18:07'!
board

	board ifNil:
		[board _ SameGameBoard new
			target: self;
			actionSelector: #selection].
	^ board! !

!SameGame methodsFor: 'access' stamp: 'tao 5/18/1998 16:19'!
board: aSameGameBoard

	board _ aSameGameBoard! !

!SameGame methodsFor: 'access' stamp: 'tao 5/23/1998 10:32'!
helpString

^ 'The object of SameGame is to maximize your score by removing tiles from the board.  Tiles are selected and removed by clicking on a tile that has at least one adjacent tile of the same color (where adjacent is defined as up, down, left, or right).

The first click selects a group of adjacent tiles, a second click in that group will remove it from the board, sliding tiles down and right to fill the space of the removed group.  If you wish to select a different group, simply click on it instead.

The score increases by "(selection - 2) squared", so you want to maximize the selection size as much as possible.  However, making small strategic selections may allow you to increase the size of a later selection.

If you are having a hard time finding a group, the "Hint" button will find one and select it for you (although it is likely not the best group to select!!).

When there are no more groups available, the score display will flash with your final score.  Your final score is reduced by 1 for each tile remaining on the board.  If you manage to remove all tiles, your final score is increased by a bonus of 5 times the number of tiles on a full board.

Come on, you can beat that last score!!  Click "New game"  ;-)

SameGame was originally written by Eiji Fukumoto for UNIX and X; this version is based upon the same game concept, but was rewritten from scratch.'
! !

!SameGame methodsFor: 'access' stamp: 'tao 5/18/1998 19:43'!
helpText

	helpText ifNil:
		[helpText _ PluggableTextMorph new
			width: board width;
			editString: self helpString].
	^ helpText! !

!SameGame methodsFor: 'access' stamp: 'di 9/12/2000 08:07'!
scoreDisplay

	^ scoreDisplay! !


!SameGame methodsFor: 'actions' stamp: 'tao 5/18/1998 19:45'!
help: helpState

	helpState
		ifTrue: [self addMorphBack: self helpText]
		ifFalse: [helpText delete]! !

!SameGame methodsFor: 'actions' stamp: 'tao 5/18/1998 18:35'!
newGame

	scoreDisplay value: 0; flash: false.
	selectionDisplay value: 0.
	self board resetBoard.! !

!SameGame methodsFor: 'actions' stamp: 'tao 5/23/1998 10:51'!
selection
	"a selection was made on the board; get its count and update the displays"

	| count score |
	count _ self board selectionCount.
	count = 0 ifTrue:
		[score _ scoreDisplay value + (selectionDisplay value - 2) squared.
		board findSelection ifNil:
			[count _ board tilesRemaining.
			count = 0
				ifTrue: [score _ score + (5 * board rows * board columns)]
				ifFalse: [score _ score - count].
			scoreDisplay flash: true].
		scoreDisplay value: score].
	selectionDisplay value: count.! !
AlignmentMorph subclass: #SameGameBoard
	instanceVariableNames: 'protoTile rows columns palette selection selectionColor flashColor flash target actionSelector arguments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!SameGameBoard commentStamp: '<historical>' prior: 0!
I am an MxN array of SameGameTiles, and implement most of the logic to play the SameGame, including adjacent tile selection and removal.!


!SameGameBoard methodsFor: 'initialization' stamp: 'ar 11/20/2000 19:44'!
initialize
	super initialize.
	target _ nil.
	actionSelector _ #selection.
	arguments _ #().
	self layoutPolicy: nil.
	self hResizing: #rigid.
	self vResizing: #rigid.
	borderWidth _ 2.
	borderColor _ Color black.
	rows _ self preferredRows.
	columns _ self preferredColumns.
	color _ Color gray.
	palette _ (Color wheel: self preferredTileTypes + 1) asOrderedCollection.
	flashColor _ palette removeLast.
	flash _ false.
	self extent: self protoTile extent * (columns @ rows).
	self resetBoard.! !

!SameGameBoard methodsFor: 'initialization' stamp: 'di 12/12/2000 15:03'!
resetBoard
	Collection initialize.  "randomize"
	selection _ nil.
	self purgeAllCommands.
	self submorphsDo:
		[:m |
		m disabled: false.
		m setSwitchState: false.
		m color: palette atRandom].

! !


!SameGameBoard methodsFor: 'preferences' stamp: 'tao 5/17/1998 09:24'!
preferredColumns

	^ 20! !

!SameGameBoard methodsFor: 'preferences' stamp: 'tao 5/17/1998 09:24'!
preferredRows

	^ 10! !

!SameGameBoard methodsFor: 'preferences' stamp: 'tao 5/17/1998 09:34'!
preferredTileTypes

	^ 5! !


!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 16:59'!
actionSelector

	^ actionSelector! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 17:00'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:45'!
columns

	^ columns! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:57'!
columns: newColumns

	self extent: self protoTile extent * (newColumns @ rows)! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:57'!
columns: newColumns rows: newRows

	self extent: self protoTile extent * (newColumns @ newRows)! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:47'!
protoTile

	protoTile ifNil: [protoTile _ SameGameTile new].
	^ protoTile! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:48'!
protoTile: aTile

	protoTile _ aTile! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:45'!
rows

	^ rows! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/15/1998 12:57'!
rows: newRows

	self extent: self protoTile extent * (columns @ newRows)! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 16:56'!
selectionCount

	^ selection isNil
		ifTrue: [0]
		ifFalse: [selection size]! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 16:59'!
target

	^ target! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 16:59'!
target: anObject

	target _ anObject! !

!SameGameBoard methodsFor: 'accessing' stamp: 'tao 5/17/1998 10:31'!
tileAt: aPoint

	^ submorphs at: (aPoint x + (aPoint y * columns) + 1)! !


!SameGameBoard methodsFor: 'geometry' stamp: 'ar 11/20/2000 19:28'!
extent: aPoint
	"constrain the extent to be a multiple of the protoTile size during resizing"
	super extent: (aPoint truncateTo: protoTile extent).
	self adjustTiles.! !


!SameGameBoard methodsFor: 'dropping/grabbing' stamp: 'tao 5/15/1998 14:15'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to set the protoTile just by dropping it on this morph."

	self protoTile: aMorph.
	self removeAllMorphs.
! !


!SameGameBoard methodsFor: 'stepping' stamp: 'tao 5/17/1998 11:38'!
step

	| newColor |
	selection ifNotNil:
		[newColor _ flash
			ifTrue: [selectionColor]
			ifFalse: [flashColor].
		selection do: [:loc | (self tileAt: loc) color: newColor].
		flash _ flash not]
! !

!SameGameBoard methodsFor: 'stepping' stamp: 'tao 5/18/1998 11:16'!
stepTime

	^ 500! !


!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/17/1998 12:01'!
collapseColumn: col fromRow: row

	| targetTile sourceTile |
	(targetTile _ self tileAt: col@row) disabled ifTrue:
		[row - 1 to: 0 by: -1 do:
			[:r |
			(sourceTile _ self tileAt: col@r) disabled ifFalse:
				[targetTile color: sourceTile color.
				targetTile disabled: false.
				sourceTile disabled: true.
				^ true]]].
	^ false
! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/18/1998 18:47'!
collapseColumns: columnsToCollapse

	| columnsToRemove |
	columnsToRemove _ OrderedCollection new.
	columnsToCollapse do:
		[:c |
		rows - 1 to: 0 by: -1 do: [:r | self collapseColumn: c fromRow: r].
		(self tileAt: c@(rows-1)) disabled ifTrue: [columnsToRemove add: c]].
	self world displayWorld.
	columnsToRemove reverseDo: [:c | self removeColumn: c].
! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/17/1998 11:38'!
deselectSelection

	selection ifNotNil:
		[selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
		selection _ nil.
		flash _ false]! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/18/1998 18:52'!
findSelection
	"find a possible selection and return it, or nil if no selection"

	| tile k testTile |
	0 to: rows-1 do:
		[:r |
		0 to: columns-1 do:
			[:c |
			tile _ self tileAt: c@r.
			tile disabled  ifFalse:
				[k _ tile color.
				c+1 < columns ifTrue:
					[testTile _ self tileAt: (c+1)@r.
					(testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]].
				r+1 < rows ifTrue:
					[testTile _ self tileAt: c@(r+1).
					(testTile disabled not and: [testTile color = k]) ifTrue: [^ tile]]]]].
	 ^ nil
			! !

!SameGameBoard methodsFor: 'actions' stamp: 'ar 10/25/2000 23:13'!
hint
	"find a possible selection and select it"

	| tile |
	self deselectSelection.
	tile _ self findSelection.
	tile ifNotNil: [tile mouseDown: MouseButtonEvent new]! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/17/1998 15:54'!
removeColumn: column

	| sourceTile |
	column+1 to: columns-1 do:
		[:c |
		0 to: rows-1 do:
			[:r |
			sourceTile _ self tileAt: c@r.
			(self tileAt: c-1@r)
				color: sourceTile color;
				disabled: sourceTile disabled]].
	0 to: rows-1 do:
		[:r | (self tileAt: columns-1@r) disabled: true]! !

!SameGameBoard methodsFor: 'actions' stamp: 'di 9/11/2000 20:55'!
removeSelection

	selection ifNil: [^ self].
	self rememberUndoableAction: 
			[selection do: [:loc | (self tileAt: loc) disabled: true; setSwitchState: false].
			self collapseColumns: (selection collect: [:loc | loc x]) asSet asSortedCollection.
			selection _ nil.
			flash _ false.
			(target ~~ nil and: [actionSelector ~~ nil])
				ifTrue: [target perform: actionSelector withArguments: arguments]]
		named: 'remove selection'
! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/17/1998 11:37'!
selectTilesAdjacentTo: location

	| al at |
	{-1@0. 0@-1. 1@0. 0@1} do:
		[:offsetPoint |
		al _ location + offsetPoint.
		((al x between: 0 and: columns - 1) and: [al y between: 0 and: rows - 1]) ifTrue:
			[at _ self tileAt: al.
			(at color = selectionColor and: [at switchState not and: [at disabled not]]) ifTrue:
				[selection add: al.
				at setSwitchState: true.
				self selectTilesAdjacentTo: al]]]
! !

!SameGameBoard methodsFor: 'actions' stamp: 'tao 5/18/1998 20:20'!
tileClickedAt: location newSelection: isNewSelection

	| tile |
	isNewSelection
		ifTrue:
			[self deselectSelection.
			tile _ self tileAt: location.
			selectionColor _ tile color.
			selection _ OrderedCollection with: location.
			self selectTilesAdjacentTo: location.
			selection size = 1
				ifTrue: [self deselectSelection]
				ifFalse:
					[(target ~~ nil and: [actionSelector ~~ nil])
					ifTrue: [target perform: actionSelector withArguments: arguments]]]
		ifFalse:
			[self removeSelection].! !


!SameGameBoard methodsFor: 'private' stamp: 'ar 11/20/2000 19:26'!
adjustTiles
	"add or remove new protoTile submorphs to fill out my new bounds"

	| newSubmorphs requiredSubmorphs count r c |
	columns _ self width // protoTile width.
	rows _ self height // protoTile height.
	requiredSubmorphs _ rows * columns.
	newSubmorphs _ OrderedCollection new.
	r _ 0.
	c _ 0.
	self submorphCount > requiredSubmorphs
		ifTrue: "resized smaller -- delete rows or columns"
			[count _ 0.
			submorphs do:
				[:m | 
				count < requiredSubmorphs
					ifTrue:
						[m position: self position + (protoTile extent * (c @ r)).
						m arguments: (Array with: c @ r).
						newSubmorphs add: m]
					ifFalse: [m privateOwner: nil].
				count _ count + 1.
				c _ c + 1.
				c >= columns ifTrue: [c _ 0. r _ r + 1]]]
		ifFalse: "resized larger -- add rows or columns"
			[submorphs do:
				[:m |
				m position: self position + (self protoTile extent * (c @ r)).
				m arguments: (Array with: c @ r).
				newSubmorphs add: m.
				c _ c + 1.
				c >= columns ifTrue: [c _ 0. r _ r + 1]].
			1 to: (requiredSubmorphs - self submorphCount) do:
				[:m |
				newSubmorphs add:
					(protoTile copy
						position: self position + (self protoTile extent * (c @ r));
						actionSelector: #tileClickedAt:newSelection:;
						arguments: (Array with: c @ r);
						target: self;
						privateOwner: self).
				c _ c + 1.
				c >= columns ifTrue: [c _ 0. r _ r + 1]]].
	submorphs _ newSubmorphs asArray.
! !

!SameGameBoard methodsFor: 'private' stamp: 'di 12/12/2000 18:44'!
capturedState
	"Note the state stored in the second element is an array of associations
	from submorph index to a shallowCopy of the morph, but only for those
	morphs that change.  Therefore the capturedState record *first* delivers
	all the morphs, and *then* computes the difference and stores this back.
	In the end, both undo and redo records follow this format."

	| prior state oldMorphs priorChanges newChanges |
	(prior _ self valueOfProperty: #priorState) == nil
		ifTrue: [state _ {self shallowCopy.  "selection, etc."
						self submorphs collect: [:m | m shallowCopy].  "state of all tiles"
						owner scoreDisplay flash.  "score display"
						owner scoreDisplay value }.
				self setProperty: #priorState toValue: state.
				^ state].
	oldMorphs _ prior second.
	priorChanges _ OrderedCollection new.
	newChanges _ OrderedCollection new.
	1 to: oldMorphs size do: [:i |
		(oldMorphs at: i) color = (submorphs at: i) color ifFalse:
			[priorChanges addLast: i -> (oldMorphs at: i).
			newChanges addLast: i -> (submorphs at: i) shallowCopy]].
	self removeProperty: #priorState.
	prior at: 2 put: priorChanges asArray.  "Store back into undo state.2"

	^ {	self shallowCopy.  "selection, etc."
		newChanges asArray.  "state of tiles that changed"
		owner scoreDisplay flash.  "score display"
		owner scoreDisplay value }! !

!SameGameBoard methodsFor: 'private' stamp: 'di 7/1/1998 00:04'!
tilesRemaining

	^ (submorphs reject: [:m | m disabled]) size
! !

!SameGameBoard methodsFor: 'private' stamp: 'di 12/12/2000 16:44'!
undoFromCapturedState: st 

	self copyFrom: st first.
	st second do: [:assn | (submorphs at: assn key) copyFrom: assn value].
	selection ifNotNil:
		[selection do: [:loc | (self tileAt: loc) setSwitchState: false; color: selectionColor].
		selection _ nil].
	owner scoreDisplay flash: st third.  "score display"
	owner scoreDisplay value: st fourth.
	self changed.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SameGameBoard class
	instanceVariableNames: ''!

!SameGameBoard class methodsFor: 'as yet unclassified' stamp: 'di 1/16/2000 10:37'!
includeInNewMorphMenu

	^false! !
SimpleSwitchMorph subclass: #SameGameTile
	instanceVariableNames: 'switchState disabled oldSwitchState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!SameGameTile commentStamp: '<historical>' prior: 0!
I am a single tile for the SameGame.  I act much like a switch.!


!SameGameTile methodsFor: 'initialization' stamp: 'sw 11/30/1999 08:21'!
initialize

	super initialize.
	self label: ''.
	self borderWidth: 2.
	bounds _ 0@0 corner: 16@16.
	offColor _ Color gray.
	onColor _ Color gray.
	switchState _ false.
	oldSwitchState _ false.
	disabled _ false.
	self useSquareCorners
	! !


!SameGameTile methodsFor: 'accessing' stamp: 'tao 5/18/1998 20:51'!
color: aColor

	color _ aColor.
	onColor _ aColor.
	offColor _ aColor.
	self changed.
! !

!SameGameTile methodsFor: 'accessing' stamp: 'tao 5/15/1998 08:46'!
disabled

	^ disabled! !

!SameGameTile methodsFor: 'accessing' stamp: 'tao 5/15/1998 09:21'!
disabled: aBoolean

	disabled _ aBoolean.
	disabled
		ifTrue:
			[self color: owner color.
			self borderColor: owner color]
		ifFalse:
			[self setSwitchState: self switchState]! !

!SameGameTile methodsFor: 'accessing' stamp: 'tao 5/15/1998 09:21'!
setSwitchState: aBoolean

	switchState _ aBoolean.
	disabled ifFalse:
		[switchState
			ifTrue:
				[self borderColor: #inset.
				self color: onColor]
			ifFalse:
				[self borderColor: #raised.
				self color: offColor]]! !

!SameGameTile methodsFor: 'accessing' stamp: 'tao 5/15/1998 09:19'!
switchState

	^ switchState! !


!SameGameTile methodsFor: 'drawing' stamp: 'tao 5/15/1998 12:31'!
drawOn: aCanvas 
	"Draw a rectangle with a solid, inset, or raised border.
	Note: the raised border color *and* the inset border color are generated
	from the receiver's own color, instead of having the inset border color
	generated from the owner's color, as in BorderedMorph."

	borderWidth = 0 ifTrue: [  "no border"
		aCanvas fillRectangle: bounds color: color.
		^ self].

	borderColor == #raised ifTrue: [
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: color
			borderWidth: borderWidth
			topLeftColor: color lighter
			bottomRightColor: color darker].

	borderColor == #inset ifTrue: [
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: color
			borderWidth: borderWidth
			topLeftColor: color darker
			bottomRightColor: color lighter].

	"solid color border"
	aCanvas frameAndFillRectangle: bounds
		fillColor: color
		borderWidth: borderWidth
		borderColor: borderColor.! !


!SameGameTile methodsFor: 'events' stamp: 'tao 5/17/1998 09:53'!
doButtonAction
	"Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."

	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		target
			perform: actionSelector
			withArguments: (arguments copyWith: switchState)].
! !

!SameGameTile methodsFor: 'events' stamp: 'tao 5/18/1998 17:43'!
mouseDown: evt

	disabled ifFalse:
		[oldSwitchState _ switchState.
		self setSwitchState: (oldSwitchState = false).
		self doButtonAction].
! !

!SameGameTile methodsFor: 'events' stamp: 'tao 5/18/1998 17:43'!
mouseMove: evt

	"don't do anything, here"! !

!SameGameTile methodsFor: 'events' stamp: 'tao 5/18/1998 17:42'!
mouseUp: evt

	"don't do anything, here"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SameGameTile class
	instanceVariableNames: ''!

!SameGameTile class methodsFor: 'as yet unclassified' stamp: 'di 1/16/2000 10:37'!
includeInNewMorphMenu

	^false! !
Object subclass: #SampledInstrument
	instanceVariableNames: 'sustainedSoft sustainedLoud staccatoSoft staccatoLoud sustainedThreshold loudThreshold '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SampledInstrument commentStamp: '<historical>' prior: 0!
I represent a collection of individual notes at different pitches, volumes, and articulations. On request, I can select the best note to use for a given pitch, duration, and volume. I currently only support two volumes, loud and soft, and two articulations, normal and staccato, but I can easily be extended to include more. The main barrier to keeping more variations is simply the memory space (assuming my component notes are sampled sounds).
!


!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:30'!
allSampleSets: sortedNotes

	| keyMap |
	keyMap _ self midiKeyMapFor: sortedNotes.
	sustainedSoft _ keyMap.
	sustainedLoud _ keyMap.
	staccatoSoft _ keyMap.
	staccatoLoud _ keyMap.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 19:04'!
initialize

	sustainedThreshold _ 0.15.
	loudThreshold _ 0.5.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'!
loudThreshold

	^ loudThreshold
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'!
loudThreshold: aNumber

	loudThreshold _ aNumber asFloat.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:02'!
staccatoLoudAndSoftSampleSet: sortedNotes

	staccatoLoud _ self midiKeyMapFor: sortedNotes.
	staccatoSoft _ staccatoLoud.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'!
staccatoLoudSampleSet: sortedNotes

	staccatoLoud _ self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'!
staccatoSoftSampleSet: sortedNotes

	staccatoSoft _ self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'!
sustainedLoudSampleSet: sortedNotes

	sustainedLoud _ self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'!
sustainedSoftSampleSet: sortedNotes

	sustainedSoft _ self midiKeyMapFor: sortedNotes.
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'!
sustainedThreshold

	^ sustainedThreshold
! !

!SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'!
sustainedThreshold: aNumber

	sustainedThreshold _ aNumber asFloat.
! !


!SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 18:53'!
soundForMidiKey: midiKey dur: d loudness: l
	"Answer an initialized sound object that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."

	| keymap note |
	l >= loudThreshold
		ifTrue: [
			d >= sustainedThreshold
				ifTrue: [keymap _ sustainedLoud]
				ifFalse: [keymap _ staccatoLoud]]
		ifFalse: [
			d >= sustainedThreshold
				ifTrue: [keymap _ sustainedSoft]
				ifFalse: [keymap _ staccatoSoft]].
	keymap ifNil: [keymap _ sustainedLoud].
	note _ (keymap at: midiKey) copy.
	^ note
		setPitch: (AbstractSound pitchForMIDIKey: midiKey)
		dur: d
		loudness: (l * note gain)
! !

!SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 16:53'!
soundForPitch: pitchNameOrNumber dur: d loudness: l
	"Answer an initialized sound object that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."
	"Note:  Generally, SampledInstruments are expected to be played via MIDI key numbers rather than by pitches, since finding the MIDI key for a given pitch is expensive."

	^ self soundForMidiKey: (AbstractSound midiKeyForPitch: pitchNameOrNumber)
		dur: d
		loudness: l
! !


!SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 12:39'!
allNotes
	"Answer a collection containing of all the unique sampled sounds used by this instrument."

	| r |
	r _ IdentitySet new.
	r addAll: sustainedLoud.
	sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft].
	staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud].
	staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft].
	^ (r asSortedCollection: [:n1 :n2 | n1 pitch < n2 pitch]) asArray
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/2/1998 12:55'!
chooseSamplesForPitch: pitchInHz from: sortedNotes
	"From the given collection of LoopedSampledSounds, choose the best one to be pitch-shifted to produce the given pitch."
	"Assume: the given collection is sorted in ascending pitch order."

	| i lower higher |
	i _ 1.
	[(i < sortedNotes size) and: [(sortedNotes at: i) pitch < pitchInHz]]
		whileTrue: [i _ i + 1].
	i = 1 ifTrue: [^ sortedNotes at: 1].
	lower _ sortedNotes at: i - 1.
	higher _ sortedNotes at: i.
	"note: give slight preference for down-shifting a higher-pitched sample set"
	(pitchInHz / lower pitch) < ((0.95 * higher pitch) / pitchInHz)
		ifTrue: [^ lower]
		ifFalse: [^ higher].
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 9/8/1998 16:24'!
memorySpace
	"Answer the number of bytes required to store the samples for this instrument."

	| total |
	total _ 0.
	self allNotes do: [:n |
		total _ total + (n leftSamples monoSampleCount * 2).
		n isStereo ifTrue: [total _ total + (n leftSamples monoSampleCount * 2)]].
	^ total
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/3/1998 16:42'!
midiKeyMapFor: sortedNotes
	"Return a 128 element array that maps each MIDI key number to the sampled note from the given set with the closests pitch. A precise match isn't necessary because the selected note will be pitch shifted to play at the correct pitch."

	^ (0 to: 127) collect: [:k |
		self
			chooseSamplesForPitch: (AbstractSound pitchForMIDIKey: k)
			from: sortedNotes].
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/18/1998 10:57'!
playChromaticRunFrom: startPitch to: endPitch

	(AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 15:52'!
pruneNoteList: aNoteList notesPerOctave: notesPerOctave
	"Return a pruned version of the given note list with only the given number of notes per octave. Assume the given notelist is in sorted order."

	| r interval lastPitch |
	r _ OrderedCollection new: aNoteList size.
	interval _ (2.0 raisedTo: (1.0 / notesPerOctave)) * 0.995.
	lastPitch _ 0.0.
	aNoteList do: [:n |
		n pitch > (lastPitch * interval) ifTrue: [
			r addLast: n.
			lastPitch _ n pitch]].
	^ r
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/6/1998 00:39'!
pruneToNotesPerOctave: notesPerOctave
	"Prune all my keymaps to the given number of notes per octave."

	sustainedLoud _ self midiKeyMapFor:
		(self pruneNoteList: sustainedLoud notesPerOctave: notesPerOctave).
	sustainedSoft _ self midiKeyMapFor:
		(self pruneNoteList: sustainedSoft notesPerOctave: notesPerOctave).
	staccatoLoud _ self midiKeyMapFor:
		(self pruneNoteList: staccatoLoud notesPerOctave: notesPerOctave).
	staccatoSoft _ self midiKeyMapFor:
		(self pruneNoteList: staccatoSoft notesPerOctave: notesPerOctave).
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 14:44'!
pruneToSingleNote: aNote
	"Fill all my keymaps with the given note."

	| oneNoteMap |
	oneNoteMap _ Array new: 128 withAll: aNote.
	sustainedLoud _ oneNoteMap.
	sustainedSoft _ oneNoteMap.
	staccatoLoud _ oneNoteMap.
	staccatoSoft _ oneNoteMap.
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/4/1998 18:22'!
readSampleSetFrom: dirName
	"Answer a collection of sounds read from AIFF files in the given directory and sorted in ascending pitch order."

	| all dir fullName snd |
	all _ SortedCollection sortBlock: [:s1 :s2 | s1 pitch < s2 pitch].
	dir _ FileDirectory default on: dirName.
	dir fileNames do: [:n |
		fullName _ dir fullNameFor: n.
		Utilities
			informUser: 'Reading AIFF file ', n
			during:
				[snd _ LoopedSampledSound new
					fromAIFFFileNamed: fullName
					mergeIfStereo: true].
		all add: snd].
	^ all asArray
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/2/1998 20:32'!
readSampleSetInfoFrom: dirName
	"MessageTally spyOn: [SampledInstrument new readSampleSetFrom: 'Tosh:Desktop Folder:AAA Squeak2.0 Beta:Organ Samples:Flute8'] timeToRun"

	| all dir fullName info |
	all _ OrderedCollection new.
	dir _ FileDirectory default on: dirName.
	dir fileNames do: [:n |
		fullName _ dir fullNameFor: n.
		info _ AIFFFileReader new readFromFile: fullName
			mergeIfStereo: false
			skipDataChunk: true.
		all add: n -> info].
	^ all
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/4/1998 23:13'!
testAtPitch: aPitch
	"SampledInstrument testAtPitch: 'c4'"

	| pattern |
	pattern _ (#(
		(c4 0.64 100) 
		(c4 0.64 200) 
		(c4 0.64 400) 
		(c4 0.64 600) 
		(c4 0.64 800) 
		(c4 1.28 1000) 
		(c4 1.28 400) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.32 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.16 500) 
		(c4 0.08 500) 
		(c4 0.08 500) 
		(c4 0.16 500) 
		(c4 0.08 500) 
		(c4 0.08 500) 
		(c4 0.64 500))
			collect: [:triple | triple copy at: 1 put: aPitch; yourself]).
	(AbstractSound noteSequenceOn: self from: pattern) play.
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 15:16'!
trimAttackOf: sampleBuffer threshold: threshold
	"Trim 'silence' off the initial attacks of the given sound buffer."

	(sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
		snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
		snd isStereo ifTrue: [
			snd rightSamples:
				(self trimAttackOf: snd rightSamples threshold: threshold)]].
! !

!SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 11:07'!
trimAttacks: threshold
	"Trim 'silence' off the initial attacks all my samples."

	(sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
		snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
		snd isStereo ifTrue: [
			snd rightSamples:
				(self trimAttackOf: snd rightSamples threshold: threshold)]].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SampledInstrument class
	instanceVariableNames: ''!

!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 6/7/1999 11:26'!
buildSmallOrchestra
	"Example of how to build a skeleton orchestra that uses less memory (about 14 MBytes)."
	"SampledInstrument buildSmallOrchestra"

	| dir |
	AbstractSound unloadSampledTimbres.
	dir _ 'Tosh:Not Backed Up:Sample Library:Orchestra'.
	#(clarinet oboe bassoon trombone tympani) do: [:instName |
		SampledInstrument
			readSimpleInstrument: instName
			fromDirectory: dir.
		(AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 1].
	#(flute bass) do: [:instName |
		SampledInstrument
			readSimpleInstrument: instName
			fromDirectory: dir.
		(AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 2].

	(AbstractSound soundNamed: 'bass-f') allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 2500)].

	(AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n |
		n beUnlooped.
		n firstSample: (n findStartPointForThreshold: 0)].

	(AbstractSound soundNamed: 'trombone-f') allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1800)].

	AbstractSound soundNamed: 'trumpet-f' put: (AbstractSound soundNamed: 'trombone-f').
	AbstractSound soundNamed: 'horn-f' put: (AbstractSound soundNamed: 'trombone-f').
	AbstractSound soundNamed: 'violin-f' put: (AbstractSound soundNamed: 'bass-f').
	AbstractSound soundNamed: 'viola-f' put: (AbstractSound soundNamed: 'bass-f').
	AbstractSound soundNamed: 'cello-f' put: (AbstractSound soundNamed: 'bass-f').

	(AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped].

! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/3/1998 17:27'!
new

	^ super new initialize
! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/19/1998 09:29'!
readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readLoudAndStaccatoInstrument: 'oboe'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter loud short snd |
	sampleSetDir _ orchestraDir, ':', instName.
	memBefore _ Smalltalk garbageCollect.
	loud _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'.
	short _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'.
	memAfter _ Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-f&stacc' put:
		(snd _ SampledInstrument new
			allSampleSets: loud;
			staccatoLoudAndSoftSampleSet: short).
	"fix slow attacks"
	snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)].

	AbstractSound soundNamed: instName, '-f' put:
		(snd _ SampledInstrument new
			allSampleSets: loud).
	"fix slow attacks"
	snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)].
! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/19/1998 09:29'!
readPizzInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readPizzInstrument: 'violin'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter sampleSet snd |
	sampleSetDir _ orchestraDir, ':', instName, ' pizz'.
	memBefore _ Smalltalk garbageCollect.
	sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir.
	memAfter _ Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-pizz' put:
		(snd _ SampledInstrument new allSampleSets: sampleSet).

	"fix slow attacks"
	snd allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1000)].

	^ snd
! !

!SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/17/1998 18:06'!
readSimpleInstrument: instName fromDirectory: orchestraDir
	"SampledInstrument
		readSimpleInstrument: 'oboe'
		fromDirectory: 'Tosh:Sample Library:Orchestra'"

	| sampleSetDir memBefore memAfter sampleSet snd |
	sampleSetDir _ orchestraDir, ':', instName, ' f'.
	memBefore _ Smalltalk garbageCollect.
	sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir.
	memAfter _ Smalltalk garbageCollect.
	Transcript show:
		instName, ': ', (memBefore - memAfter) printString,
		' bytes; ', memAfter printString, ' bytes left'; cr.
	AbstractSound soundNamed: instName, '-f' put:
		(snd _ SampledInstrument new allSampleSets: sampleSet).

	"fix slow attacks"
	snd allNotes do: [:n |
		n firstSample: (n findStartPointForThreshold: 1000)].

	^ snd
! !
AbstractSound subclass: #SampledSound
	instanceVariableNames: 'initialCount count samples originalSamplingRate samplesSize scaledIndex indexHighBits scaledIncrement '
	classVariableNames: 'CoffeeCupClink DefaultSampleTable IncrementFractionBits IncrementScaleFactor NominalSamplePitch ScaledIndexOverflow SoundLibrary '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SampledSound methodsFor: 'initialization' stamp: 'jm 1/18/1999 06:42'!
pitch: pitchNameOrNumber

	| p |
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	originalSamplingRate _
		((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
	self reset.
! !

!SampledSound methodsFor: 'initialization' stamp: 'jm 3/24/1999 12:01'!
setPitch: pitchNameOrNumber dur: d loudness: vol
	"Used to play scores using the default sample table."
	"(SampledSound pitch: 880.0 dur: 1.5 loudness: 0.6) play"

	| p |
	super setPitch: pitchNameOrNumber dur: d loudness: vol.
	p _ self nameOrNumberToPitch: pitchNameOrNumber.
	samples _ DefaultSampleTable.
	samplesSize _ samples size.
	initialCount _ (d * self samplingRate asFloat) rounded.
	originalSamplingRate _
		((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
	self loudness: vol.
	self reset.
! !

!SampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 19:23'!
setSamples: anArray samplingRate: rate
	"Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows the sampled sound to be played back at different pitches."
	"Note: There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSampleTable:)."
	"Assume: anArray is either a SoundBuffer or a collection of signed 16-bit sample values."
	"(SampledSound
		samples: SampledSound coffeeCupClink
		samplingRate: 5000) play"

	"copy the array into a SoundBuffer if necessary"
	anArray class isWords
		ifTrue: [samples _ anArray]
		ifFalse: [samples _ SoundBuffer fromArray: anArray].

	samplesSize _ samples size.
	samplesSize >= SmallInteger maxVal ifTrue: [  "this is unlikely..."
		self error: 'sample count must be under ',  SmallInteger maxVal printString].
	originalSamplingRate _ rate.
	initialCount _ (samplesSize * self samplingRate) // originalSamplingRate.
	self loudness: 1.0.
	self reset.
! !


!SampledSound methodsFor: 'accessing' stamp: 'di 12/7/2000 16:04'!
compressWith: codecClass
	^ codecClass new compressSound: self! !

!SampledSound methodsFor: 'accessing' stamp: 'RAA 12/24/2000 08:49'!
compressWith: codecClass atRate: aSamplingRate

	^ codecClass new compressSound: self atRate: aSamplingRate! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 3/28/98 05:46'!
duration

	^ initialCount asFloat / self samplingRate asFloat
! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:39'!
duration: seconds

	super duration: seconds.
	count _ initialCount _ (seconds * self samplingRate) rounded.
! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 12/15/97 22:51'!
originalSamplingRate

	^ originalSamplingRate
! !

!SampledSound methodsFor: 'accessing' stamp: 'jm 9/12/97 16:46'!
samples

	^ samples
! !


!SampledSound methodsFor: 'playing' stamp: 'di 10/28/2000 17:08'!
endGracefully
	"See stopGracefully, which affects initialCOunt, and I don't think it should (di)."

	| decayInMs env |
	envelopes isEmpty
		ifTrue: [
			self adjustVolumeTo: 0 overMSecs: 10.
			decayInMs _ 10]
		ifFalse: [
			env _ envelopes first.
			decayInMs _ env attackTime + env decayTime].
	count _ decayInMs * self samplingRate // 1000.
! !

!SampledSound methodsFor: 'playing' stamp: 'ar 2/3/2001 15:23'!
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."

	| lastIndex outIndex sampleIndex sample i s overflow |
	<primitive:'primitiveMixSampledSound' module:'SoundGenerationPlugin'>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #samples declareC: 'short int *samples'.

	lastIndex _ (startIndex + n) - 1.
	outIndex _ startIndex.    "index of next stereo output sample pair"
	sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits).
	[(sampleIndex <= samplesSize) and: [outIndex <= lastIndex]] whileTrue: [
		sample _ ((samples at: sampleIndex) * scaledVol) // ScaleFactor.
		leftVol > 0 ifTrue: [
			i _ (2 * outIndex) - 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 * outIndex.
			s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
			s >  32767 ifTrue: [s _  32767].  "clipping!!"
			s < -32767 ifTrue: [s _ -32767].  "clipping!!"
			aSoundBuffer at: i put: s].

		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]].

		scaledIndex _ scaledIndex + scaledIncrement.
		scaledIndex >= ScaledIndexOverflow ifTrue: [
			overflow _ scaledIndex >> IncrementFractionBits.
			indexHighBits _ indexHighBits + overflow.
			scaledIndex _ scaledIndex - (overflow << IncrementFractionBits)].

		sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits).
		outIndex _ outIndex + 1].
	count _ count - n.
! !

!SampledSound methodsFor: 'playing' stamp: 'di 10/28/2000 22:31'!
playSilentlyUntil: startTime
	"Used to fast foward to a particular starting time.
	Overridden to be instant for sampled sounds."

"true ifTrue: [^ super playSilentlyUntil: startTime]."
	indexHighBits _ (startTime * originalSamplingRate) asInteger.
	scaledIndex _ IncrementScaleFactor.
	count _ initialCount - (startTime * self samplingRate).
	mSecsSinceStart _ (startTime * 1000) asInteger.

! !

!SampledSound methodsFor: 'playing' stamp: 'jm 7/9/1999 18:29'!
reset
	"Details: The sample index and increment are scaled to allow fractional increments without having to do floating point arithmetic in the inner loop."

	super reset.
	scaledIncrement _
		((originalSamplingRate asFloat / self samplingRate) * IncrementScaleFactor) rounded.
	count _ initialCount.
	scaledIndex _ IncrementScaleFactor.  "index of the first sample, scaled"
	indexHighBits _ 0.
! !

!SampledSound methodsFor: 'playing' stamp: 'jm 9/13/97 19:07'!
samplesRemaining

	^ count
! !

!SampledSound methodsFor: 'playing' stamp: 'RAA 8/12/2000 15:11'!
setScaledIncrement: aNumber

	scaledIncrement _ (aNumber * IncrementScaleFactor) rounded.

! !

!SampledSound methodsFor: 'playing' stamp: 'jm 9/9/1998 21:58'!
stopAfterMSecs: mSecs
	"Terminate this sound this note after the given number of milliseconds."

	count _ (mSecs * self samplingRate) // 1000.
! !


!SampledSound methodsFor: 'sound tracks' stamp: 'di 9/6/2000 20:48'!
sonogramMorph: height from: start to: stop nPoints: nPoints
	"FYI:  It is very cool that we can do this, but for sound tracks on a movie,
	simple volume is easier to read, easier to scale, and way faster to compute.
	Code preserved here just in case it makes a useful example."
	"In an inspector of a samplesSound...
		self currentWorld addMorph: (self sonogramMorph: 32 from: 1 to: 50000 nPoints: 256)
	"
	| fft sonogramMorph data width |
	fft _ FFT new: nPoints.
	width _ stop-start//nPoints.
	sonogramMorph _ Sonogram new
			extent: width@height
			minVal: 0.0
			maxVal: 1.0
			scrollDelta: width.
	start to: stop-nPoints by: nPoints do:
		[:i |
		data _ fft transformDataFrom: samples startingAt: i.
		data _ data collect: [:v | v sqrt].  "square root compresses dynamic range"
		data /= 200.0.
		sonogramMorph plotColumn: data].
	^ sonogramMorph
	
! !

!SampledSound methodsFor: 'sound tracks' stamp: 'di 10/22/2000 11:12'!
volumeForm: height from: start to: stop nSamplesPerPixel: nPerPixel
	"Note: nPerPixel can be Integer or Float for pixel-perfect alignment."
	"In an inspector of a samplesSound...
		self currentWorld addMorph: (ImageMorph new image:
			(self volumeForm: 32 from: 1 to: samples size nSamplesPerPixel: 225))
	"
	| volPlot width sample min max vol |
	width _ stop-start//nPerPixel.
	volPlot _ Form extent: width@height.
	(start max: 1) to: (stop min: samples size)-nPerPixel by: nPerPixel do:
		[:i | min_ max_ 0.
		i asInteger to: (i+nPerPixel-1) asInteger by: 4 do:  "by: 4 makes it faster yet looks the same"
			[:j | sample _ samples at: j.
			sample < min ifTrue: [min _ sample].
			sample > max ifTrue: [max _ sample]].
		vol _ (max - min) * height // 65536.
		volPlot fillBlack: ((i-start//nPerPixel) @ (height-vol//2) extent: 1@(vol+1))].
	^ volPlot
	
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SampledSound class
	instanceVariableNames: ''!

!SampledSound class methodsFor: 'class initialization' stamp: 'jm 7/9/1999 19:07'!
initialize
	"SampledSound initialize"

	IncrementFractionBits _ 16.
	IncrementScaleFactor _ 2 raisedTo: IncrementFractionBits.
	ScaledIndexOverflow _ 2 raisedTo: 29.  "handle overflow before needing LargePositiveIntegers"
	self useCoffeeCupClink.
	SoundLibrary ifNil: [SoundLibrary _ Dictionary new].
! !


!SampledSound class methodsFor: 'instance creation'!
fromAIFFStream: fileStream

	| aiffFileReader |
	aiffFileReader _ AIFFFileReader new.
	aiffFileReader readFrom: fileStream
		mergeIfStereo: true
		skipDataChunk: false.
	^ self
		samples: (aiffFileReader channelData at: 1)
		samplingRate: aiffFileReader samplingRate
! !

!SampledSound class methodsFor: 'instance creation' stamp: 'jm 1/14/1999 10:34'!
fromAIFFfileNamed: fileName
	"Read a SampledSound from the AIFF file of the given name, merging stereo to mono if necessary."
	"(SampledSound fromAIFFfileNamed: '1.aif') play"
	"| snd |
	 FileDirectory default fileNames do: [:n |
		(n endsWith: '.aif')
			ifTrue: [
				snd _ SampledSound fromAIFFfileNamed: n.
				snd play.
				SoundPlayer waitUntilDonePlaying: snd]]."

	| aiffFileReader |
	aiffFileReader _ AIFFFileReader new.
	aiffFileReader readFromFile: fileName
		mergeIfStereo: true
		skipDataChunk: false.
	^ self
		samples: (aiffFileReader channelData at: 1)
		samplingRate: aiffFileReader samplingRate
! !

!SampledSound class methodsFor: 'instance creation'!
fromWaveFileNamed: fileName
	"(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play"
	"| snd fd |
	fd := FileDirectory on:'c:\windows\media\'.
	fd fileNames do: [:n |
		(n asLowercase endsWith: '.wav')
			ifTrue: [
				snd _ SampledSound fromWaveFileNamed: (fd pathName,n).
				snd play.
				SoundPlayer waitUntilDonePlaying: snd]]."

	^self fromWaveStream: (FileStream oldFileNamed: fileName)
! !

!SampledSound class methodsFor: 'instance creation'!
fromWaveStream: fileStream

	| stream header data type channels samplingRate blockAlign bitsPerSample leftAndRight |
	header _ self readWaveChunk: 'fmt ' inRIFF: fileStream.
	data _ self readWaveChunk: 'data' inRIFF: fileStream.
	fileStream close.
	stream _ ReadStream on: header.
	type _ self next16BitWord: false from: stream.
	type = 1 ifFalse: [^ self error:'Unexpected wave format'].
	channels _ self next16BitWord: false from: stream.
	(channels < 1 or: [channels > 2])
		ifTrue: [^ self error: 'Unexpected number of wave channels'].
	samplingRate _ self next32BitWord: false from: stream.
	stream skip: 4. "skip average bytes per second"
	blockAlign _ self next16BitWord: false from: stream.
	bitsPerSample _ self next16BitWord: false from: stream.
	(bitsPerSample = 8 or: [bitsPerSample = 16])
		ifFalse: [  "recompute bits per sample"
			bitsPerSample _ (blockAlign // channels) * 8].

	bitsPerSample = 8
		ifTrue: [data _ self convert8bitUnsignedTo16Bit: data]
		ifFalse: [data _ self convertBytesTo16BitSamples: data mostSignificantByteFirst: false].

	channels = 2 ifTrue: [
		leftAndRight _ data splitStereo.
		^ MixedSound new
			add: (self samples: leftAndRight first samplingRate: samplingRate) pan: 0.0;
			add: (self samples: leftAndRight last samplingRate: samplingRate) pan: 1.0;
			yourself].

	^ self samples: data samplingRate: samplingRate
! !

!SampledSound class methodsFor: 'instance creation' stamp: 'jm 9/12/97 19:20'!
samples: anArrayOf16BitSamples samplingRate: samplesPerSecond
	"Return a SampledSound with the given samples array and sampling rate."

	^ self new setSamples: anArrayOf16BitSamples samplingRate: samplesPerSecond
! !


!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 12:49'!
defaultSampleTable: anArray
	"Set the sample table to be used as the default waveform for playing a score such as the Bach fugue. Array is assumed to contain monaural signed 16-bit sample values."

	DefaultSampleTable _ SoundBuffer fromArray: anArray.
! !

!SampledSound class methodsFor: 'default sound' stamp: 'jm 9/17/97 13:10'!
defaultSamples: anArray repeated: n

	| data |
	data _ WriteStream on: (SoundBuffer newMonoSampleCount: anArray size * n).
	n timesRepeat: [
		anArray do: [:sample | data nextPut: sample truncated]].
	DefaultSampleTable _ data contents.
! !

!SampledSound class methodsFor: 'default sound'!
nominalSamplePitch: aNumber
	"Record an estimate of the normal pitch of the sampled sound."

	NominalSamplePitch _ aNumber.
! !

!SampledSound class methodsFor: 'default sound' stamp: 'jm 5/8/1998 18:53'!
useCoffeeCupClink
	"Set the sample table to be used as the default waveform to the sound of a coffee cup being tapped with a spoon."
	"SampledSound useCoffeeCupClink bachFugue play"

	DefaultSampleTable _ self coffeeCupClink.
	NominalSamplePitch _ 400.
! !


!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 8/23/97 22:25'!
coffeeCupClink
	"Return the samples array for the sound of a spoon being tapped against a coffee cup."

	CoffeeCupClink ifNil: [self initializeCoffeeCupClink].
	^ CoffeeCupClink
! !

!SampledSound class methodsFor: 'coffee cup clink' stamp: 'jm 9/17/97 12:50'!
initializeCoffeeCupClink
	"Initialize the samples array for the sound of a spoon being tapped against a coffee cup."
	"SampledSound initializeCoffeeCupClink"

	| samples |
	samples _ #(768 1024 -256 2304 -13312 26624 32512 19200 6400 -256 5888 32512 28928 32512 -32768 32512 -32768 18688 26368 -26112 32512 32512 2304 32512 5632 2816 10240 -4608 -1792 32512 32512 -5376 10752 32512 32512 32512 8192 15872 32512 -3584 -32768 -23296 -24832 -32768 -32768 -32768 -2304 32512 32512 -32768 32512 -15360 6400 8448 -18176 -32768 -256 -32768 -29440 9472 20992 17920 32512 32512 -256 32512 -32768 -32768 -23040 -32768 -25088 -32768 -27648 -1536 24320 -32768 32512 20480 27904 22016 16384 -32768 32512 -27648 -32768 -7168 28160 -6400 5376 32512 -256 32512 -7168 -11776 -19456 -27392 -24576 -32768 -24064 -19456 12800 32512 27136 2048 25344 15616 8192 -4608 -28672 -32768 -30464 -2560 17664 256 -8192 8448 32512 27648 -6144 -512 -7424 -18688 7936 -256 -22272 -14080 2048 27648 15616 -12288 -768 5376 3328 5632 3072 -6656 -20480 10240 27136 -10752 -11008 -768 -2048 6144 -7168 -3584 -1024 -7680 19712 26112 1024 -11008 3072 16384 -8960 -14848 -4864 -23808 -11264 12288 8192 7168 4864 23040 32512 512 -11776 -5632 -16896 -21504 -12800 -6144 -16896 -4352 32512 32512 23296 21760 5632 2816 -9472 -20992 -11264 -29440 -32768 -3584 7680 8448 15360 32512 32512 15616 15104 -2048 -27904 -27904 -25600 -12288 -12032 -13568 17152 22272 15360 30208 28160 7680 -5632 -8192 -16384 -31744 -25856 -10752 -3840 6656 13056 24320 26368 12800 20736 12288 -19200 -20992 -16640 -21504 -17920 -6912 8448 11264 14080 23040 18176 8192 -1024 0 256 -20992 -19712 -4608 -11264 -2048 14080 12032 8192 6912 13056 9216 -5632 -5376 -3840 -6656 -9984 -5632 4864 -3584 -1280 17408 7680 -1280 4096 2816 -1024 -4864 3328 8448 -768 -5888 -2048 5120 0 3072 11008 -7680 -15360 2560 6656 -3840 0 11776 7680 2816 1536 -1280 -3840 -8704 -1536 3584 -9728 -9728 11776 18688 7680 6656 6400 -4864 -3840 -256 -6912 -13312 -11264 2304 9728 1792 3328 18944 18432 6912 6144 -1536 -17664 -14336 -2304 -10496 -15616 -4096 9728 17152 14848 13312 11520 2304 -1024 2560 -8704 -26624 -18688 -256 -256 2816 14080 13824 12544 14080 9728 -512 -12032 -8960 -3328 -9984 -15872 -5120 8192 3584 10496 20224 7936 4608 6144 1280 -8704 -12800 -7424 -8448 -8960 -3840 7424 13056 8704 13312 13056 -2304 -4864 -768 -7168 -10496 -4608 -1536 -3072 -1280 6144 13312 11008 4864 4864 1536 -8960 -7680 1792 -4864 -7680 2816 5632 3328 2560 5376 7936 3584 -512 512 -4608 -9728 0 9216 768 -4096 7680 7168 256 4608 -768 -8704 -6400 2048 6144 -3072 -3328 6400 9472 3840 -768 1792 -3840 -5120 6144 768 -9984 -4352 5120 9472 6912 2816 1792 1280 768 512 -2816 -9728 -6912 6912 6912 -3328 -768 8448 11776 10752 3328 -6912 -10752 -8704 -1536 0 -6912 -3328 9984 13568 7424 6144 6656 256 0 256 -12032 -17920 -8192 3584 8960 4096 5632 12032 8704 6912 5632 -3584 -10496 -7936 -2048 -9216 -11776 2304 9472 15104 14848 5888 512 -2816 1024 2560 -9984 -13312 -5120 768 1792 768 8448 12032 11264 12800 -256 -11264 -9728 -2304 3072 -4352 -6912 256 2304 5376 9984 8192 2816 1280 3584 -2048 -11008 -8448 -2048 3072 4864 2304 3072 3072 3072 7168 3328 -5376 -4864 512 512 -1792 -1792 1792 5376 5888 5888 512 -5888 -3584 4096 3584 -6400 -4864 4608 3072 3840 5376 1024 768 2816 5888 -768 -12288 -7936 2304 5888 3328 2048 6144 3072 3072 6400 -3328 -7168 256 4096 -512 -9472 -6656 3328 6912 9216 8704 3840 -2560 -256 6656 -2560 -11264 -4608 -768 -1280 1536 3072 4096 5120 9984 11264 1024 -8192 -6144 -1024 -3840 -5632 -512 1024 2304 9728 9728 1280 512 4096 2816 -3584 -9984 -6912 -2304 512 5632 7680 3584 1024 5632 5888 -1280 -3584 -2304 -2560 -1536 -1024 -1792 -512 1536 7680 9984 2048 -2048 2048 3328 -1280 -4096 -3328 -4608 -1280 4352 3328 1280 1792 5120 6912 1024 -2560 0 -768 -1024 1280 -256 -4608 -1280 6400 5120 768 1792 2560 2048 0 -1536 -1280 -2304 1024 5376 2560 -2560 -512 4096 2048 512 768 -1280 -256 2560 2560 -256 -1024 768 3584 1280 -3328 -1536 1792 2816 3328 2304 -256 256 2816 2304 -1280 -3328 -1536 2304 2304 -256 -256 1024 1536 3840 5120 1024 -2048 0 1536 -768 -2560 -1792 256 2304 2048 1536 256 768 5888 6656 256 -3840 -2304 -1280 -1536 256 0 -512 2304 4352 3840 768 0 2304 3072 256 -3072 -2560 -2560 256 4608 2560 256 1536 3072 3072 1792 256 256 512 -256 -768 -1280 -1536 768 4352 2816 -512 768 2560 2560 2304 -256 -1792 -768 768 1792 256 -2304 -256 3328 3840 2304 2304 1536 256 2048 1024 -1536 -1792 -1024 512 256 -512 0 2304 4864 5120 4352 1024 -1280 0 -768 -2816 -2304 -512 1024 2048 2304 2048 3072 3840 2816 2048 -512 -3072 -1792 -1536 -1280 768 1280 1536 2304 2816 2048 1536 2048 1536 1536 -768 -3840 -2048 0 1280 2816 1792 1536 2560 3584 2816 1024 256 -768 -768 -1280 -2816 -768 1792 3328 5120 3072 1280 1536 1792 768 -1024 -1280 -1536 -768 512 256 1536 2560 2560 3328 1280 0 768 1536 768 -256 -512 -1536 -1280 768 1280 2304 2560 2560 2560 1024 -256 -512 0 1280 1536 768 -1280 -512 2048 1536 2048 1280 -256 256 512 768 768 1280 2304 1792 512 -1280 -1024 768 1536 1536 256 -768 1536 3584 3072 1792 -256 -1536 -512 256 -512 -512 768 2048 2048 1792 1280 1280 3072 2816 768 -1024 -2304 -1024 256 256 1280 1792 2304 2816 2304 1280 512 1024 768 -768 -1280 -1280 -512 1536 2560 2816 2048 512 1024 1792 1280 768 0 -768 -768 0 256 256 1280 2560 2304 2304 1536 512 512 1024 1280 0 -1792 -1536 -512 1280 3072 2816 1792 512 1024 1536 256 -256 768 768 256 256 -256 512 1280 1280 1536 768 1024 1792 1536 1024 0 256 -512 -256 1024 512 256 768 1792 2304 1280 256 768 1024 1280 1792 768 -768 -768 768 512 256 1024 1792 1536 1280 1536 1792 1280 768 512 -512 -1792 -512 512 768 2304 2816 1792 768 1536 2304 1536 0 -256 -256 -768 -768 256 1536 1536 2304 2048 256 768 2048 2304 1280 0 -256 -1024 -1024 0 1024 1792 2304 2304 1280 512 1280 2048 1280 256 -512 -1792 -1536 256 1536 1792 2048 2048 2048 1536 512 512 768 256 -256 0 -512 -1024 768 2048 2304 2304 1280 1280 1024 1024 1024 0 -512 256 768 0 -256 1536 2304 1792 2304 1280 -512 -256 768 1536 1024 256 512 512 1024 1792 1792 1536 1024 1280 0 -1280 256 2048 2560 2048 1024 -256 -256 1024 1280 1536 1024 0 0 256 768 1792 2304 2048 1280 1024 0 -512 -256 256 1024 1024 512 768 768 1280 2048 1792 1024 768 768 -256 -1024 0 256 1024 1536 1024 1280 1536 1792 1792 1024 512 512 0 -512 -256 512 768 1280 1280 1024 1280 1792 1792 1280 512 -256 -256 256 512 1280 1024 1280 1280 1024 1024 768 1024 1024 1024 1280 256 256 768 768 1024 512 256 768 1280 2560 2560 1280 512 -256 -512 -256 1024 1536 768 1024 1280 768 1024 1536 1536 1024 256 0 0 0 768 768 512 1280 1536 1280 1280 1280 1280 768 768 256 -256 768 768 256 768 1280 1792 1536 1536 1536 256 512 1024 0 -768 -256 768 512 1024 2048 1536 1024 1536 1536 768 0 0 -256).

	CoffeeCupClink _ SoundBuffer fromArray: samples.
! !


!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:59'!
addLibrarySoundNamed: aString fromAIFFfileNamed: fileName
	"Add a sound from the given AIFF file to the library."
	"SampledSound
		addLibrarySoundNamed: 'shutterClick'
		fromAIFFfileNamed: '7.aif'"
	"Add all .aif files in the current directory to the sound library:
	| fileNames |
	fileNames _ FileDirectory default fileNamesMatching: '*.aif'.
	fileNames do: [:fName |
		SampledSound
			addLibrarySoundNamed: (fName copyUpTo: $.)
			fromAIFFfileNamed: fName]"

	| snd |
	snd _ self fromAIFFfileNamed: fileName.
	self addLibrarySoundNamed: aString
		samples: snd samples
		samplingRate: snd originalSamplingRate.
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:41'!
addLibrarySoundNamed: aString samples: sampleData samplingRate: samplesPerSecond
	"Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples. If the latter, it is taken to be 16 bit signed samples."

	SoundLibrary
		at: aString
		put: (Array with: sampleData with: samplesPerSecond).
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:04'!
playSoundNamed: aString
	"Play the sound with given name. Do nothing if there is no sound of that name in the library."
	"SampledSound playSoundNamed: 'croak'"

	| snd |
	snd _ self soundNamed: aString.
	snd ifNotNil: [snd play].
	^ snd
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:40'!
putCoffeeCupClinkInSoundLibrary
	"SampledSound putCoffeeCupClinkInSoundLibrary"

	self addLibrarySoundNamed: 'clink'
		samples: self coffeeCupClink
		samplingRate: 11025! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 9/12/97 19:46'!
removeSoundNamed: aString
	"Remove the sound with the given name from the sound library."

	SoundLibrary removeKey: aString ifAbsent: [].
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:06'!
soundLibrary
	"Answer the sound library dictionary."

	^ SoundLibrary
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:07'!
soundNamed: aString
	"Answer the sound of the given name, or nil if there is no sound of that name."
	"(SampledSound soundNamed: 'shutterClick') play"

	| entry samples |
	entry _ SoundLibrary
		at: aString
		ifAbsent:
			[self inform: aString, ' not found in the Sound Library'.
			^ nil].
	entry ifNil: [^ nil].
	samples _ entry at: 1.
	samples class isBytes ifTrue: [samples _ self convert8bitSignedTo16Bit: samples].
	^ self samples: samples samplingRate: (entry at: 2)
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:08'!
soundNames
	"Answer a list of sound names for the sounds stored in the sound library."
	"| s |
	 SampledSound soundNames asSortedCollection do: [:n |
		n asParagraph display.
		s _ SampledSound soundNamed: n.
		s ifNotNil: [s playAndWaitUntilDone]]"

	^ SoundLibrary keys asArray
! !

!SampledSound class methodsFor: 'sound library' stamp: 'jhm 10/15/97 14:57'!
unusedSoundNameLike: desiredName
	"Pick an unused sound name based on the given string. If necessary, append digits to avoid name conflicts with existing sounds."
	"SampledSound unusedSoundNameLike: 'chirp'"

	| newName i |
	newName _ desiredName.
	i _ 2.
	[SoundLibrary includesKey: newName] whileTrue: [
		newName _ desiredName, i printString.
		i _ i + 1].
	^ newName
! !


!SampledSound class methodsFor: 'utilities' stamp: 'ar 2/3/2001 16:14'!
convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer
	"Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples."

	| n s |
	<primitive: 'primitiveConvert8BitSigned' module: 'MiscPrimitivePlugin'>
	self var: #aByteArray declareC: 'unsigned char *aByteArray'.
	self var: #aSoundBuffer declareC: 'unsigned short *aSoundBuffer'.
	n _ aByteArray size.
	1 to: n do: [:i |
		s _ aByteArray at: i.
		s > 127
			ifTrue: [aSoundBuffer at: i put: ((s - 256) bitShift: 8)]
			ifFalse: [aSoundBuffer at: i put: (s bitShift: 8)]].
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 2/15/98 18:13'!
convert8bitSignedTo16Bit: aByteArray
	"Convert the given array of samples--assumed to be 8-bit signed, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed AIFF sound data."

	| result |
	result _ SoundBuffer newMonoSampleCount: aByteArray size.
	self convert8bitSignedFrom: aByteArray to16Bit: result.
	^ result
! !

!SampledSound class methodsFor: 'utilities' stamp: 'ar 1/27/98 23:11'!
convert8bitUnsignedTo16Bit: anArray
	"Convert the given array of samples--assumed to be 8-bit unsigned, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed WAVE sound data."

	| n samples s |
	n _ anArray size.
	samples _ SoundBuffer newMonoSampleCount: n.
	1 to: n do: [:i |
		s _ anArray at: i.
		samples at: i put: (s - 128 * 256)].
	^ samples
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 3/17/98 21:07'!
convertBytesTo16BitSamples: aByteArray mostSignificantByteFirst: msbFirst
	"Convert the given ByteArray (with the given byte ordering) into 16-bit sample buffer."

	| n data src b1 b2 w |
	n _ aByteArray size // 2.
	data _ SoundBuffer newMonoSampleCount: n.
	src _ 1.
	1 to: n do: [:i |
		b1 _ aByteArray at: src.
		b2 _ aByteArray at: src + 1.
		msbFirst
			ifTrue: [w _ (b1 bitShift: 8) + b2]
			ifFalse: [w _ (b2 bitShift: 8) + b1].
		w > 32767 ifTrue: [w _ w - 65536].
		data at: i put: w.
		src _ src + 2].
	^ data
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/17/97 13:11'!
uLawDecode: aByteArray
	"Convert the given array of uLaw-encoded 8-bit samples into a SoundBuffer of 16-bit signed samples."

	| n out decodingTable |
	n _ aByteArray size.
	out _ SoundBuffer newMonoSampleCount: n.
	decodingTable _ self uLawDecodeTable.
	1 to: n do: [:i | out at: i put: (decodingTable at: (aByteArray at: i) + 1)].
	^ out
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 16:41'!
uLawDecodeTable
	"Return a 256 entry table to be used to decode 8-bit uLaw-encoded samples."
	"Details: This table was computed as follows:
		| d encoded lastEncodedPos lastEncodedNeg |
		d _ Array new: 256.
		lastEncodedPos _ nil.
		lastEncodedNeg _ nil.
		4095 to: 0 by: -1 do: [:s |
			encoded _ SampledSound uLawEncodeSample: s.
			lastEncodedPos = encoded
				ifFalse: [
					d at: (encoded + 1) put: (s bitShift: 3).
					lastEncodedPos _ encoded].
			encoded _ encoded bitOr: 16r80.
			lastEncodedNeg = encoded
				ifFalse: [
					d at: (encoded + 1) put: (s bitShift: 3) negated.
					lastEncodedNeg _ encoded]].
		d "

	^ #(32760 31608 30584 29560 28536 27512 26488 25464 24440 23416 22392 21368 20344 19320 18296 17272 16248 15736 15224 14712 14200 13688 13176 12664 12152 11640 11128 10616 10104 9592 9080 8568 8056 7800 7544 7288 7032 6776 6520 6264 6008 5752 5496 5240 4984 4728 4472 4216 3960 3832 3704 3576 3448 3320 3192 3064 2936 2808 2680 2552 2424 2296 2168 2040 1912 1848 1784 1720 1656 1592 1528 1464 1400 1336 1272 1208 1144 1080 1016 952 888 856 824 792 760 728 696 664 632 600 568 536 504 472 440 408 376 360 344 328 312 296 280 264 248 232 216 200 184 168 152 136 120 112 104 96 88 80 72 64 56 48 40 32 24 16 8 0 -32760 -31608 -30584 -29560 -28536 -27512 -26488 -25464 -24440 -23416 -22392 -21368 -20344 -19320 -18296 -17272 -16248 -15736 -15224 -14712 -14200 -13688 -13176 -12664 -12152 -11640 -11128 -10616 -10104 -9592 -9080 -8568 -8056 -7800 -7544 -7288 -7032 -6776 -6520 -6264 -6008 -5752 -5496 -5240 -4984 -4728 -4472 -4216 -3960 -3832 -3704 -3576 -3448 -3320 -3192 -3064 -2936 -2808 -2680 -2552 -2424 -2296 -2168 -2040 -1912 -1848 -1784 -1720 -1656 -1592 -1528 -1464 -1400 -1336 -1272 -1208 -1144 -1080 -1016 -952 -888 -856 -824 -792 -760 -728 -696 -664 -632 -600 -568 -536 -504 -472 -440 -408 -376 -360 -344 -328 -312 -296 -280 -264 -248 -232 -216 -200 -184 -168 -152 -136 -120 -112 -104 -96 -88 -80 -72 -64 -56 -48 -40 -32 -24 -16 -8 0)
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:52'!
uLawEncode: anArray
	"Convert the given array of 16-bit signed samples into a ByteArray of uLaw-encoded 8-bit samples."

	| n out s |
	n _ anArray size.
	out _ ByteArray new: n.
	1 to: n do: [:i |
		s _ anArray at: i.
		s _ s bitShift: -3.  "drop 4 least significant bits"
		s < 0
			ifTrue: [s _ (self uLawEncodeSample: s negated) bitOr: 16r80]
			ifFalse: [s _ (self uLawEncodeSample: s)].
		out at: i put: s].
	^ out
! !

!SampledSound class methodsFor: 'utilities' stamp: 'jm 9/13/97 15:40'!
uLawEncodeSample: s
	"Encode the given 16-bit signed sample using the uLaw 8-bit encoding."

	s < 496 ifTrue: [
		s < 112 ifTrue: [
			s < 48 ifTrue: [
				s < 16
					ifTrue: [^ 16r70 bitOr: (15 - s)]
					ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
			^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
		s < 240
			ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
			ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].

	s < 2032 ifTrue: [
		s < 1008
			ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
			ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].

	s < 4080
		ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
		ifFalse: [^ 0].
! !


!SampledSound class methodsFor: 'WAV reading' stamp: 'ar 1/27/98 23:06'!
next16BitWord: msbFirst from: stream
	"Read a 16-bit positive integer from the input stream."
	"Assume: Stream has at least two bytes left."

	| n |
	n _ stream next: 2.
	^msbFirst
		ifTrue:[(n at: 1) * 256 + (n at: 2)]
		ifFalse:[(n at: 2) * 256 + (n at: 1)]
! !

!SampledSound class methodsFor: 'WAV reading' stamp: 'ar 1/27/98 23:06'!
next32BitWord: msbFirst from: stream
	"Read a 32-bit positive integer from the input stream."
	"Assume: Stream has at least four bytes left."

	| n |
	n _ stream next: 4.
	^msbFirst
		ifTrue:[(n at: 1) * 256 + (n at: 2) * 256 + (n at: 3) * 256 + (n at: 4)]
		ifFalse:[(n at: 4) * 256 + (n at: 3) * 256 + (n at: 2) * 256 + (n at: 1)]
! !

!SampledSound class methodsFor: 'WAV reading' stamp: 'jm 3/17/98 21:03'!
readWaveChunk: chunkType inRIFF: stream
	"Search the stream for a format chunk of the given type and return its contents."

	| id count |
	stream reset; binary.
	stream skip: 8.  "skip 'RIFF' and total length"
	id _ (stream next: 4) asString.  "contents type"
	id = 'WAVE' ifFalse: [^ ''].     "content type must be WAVE"

	"search for a chunk of the given type"
	[id _ (stream next: 4) asString.
	 count _ self next32BitWord: false from: stream.
	 id = chunkType] whileFalse: [
		"skip this chunk, rounding length up to a word boundary"
		stream skip: (count + 1 bitAnd: 16rFFFFFFFE).
		stream atEnd ifTrue: [^ '']].

	^ stream next: count  "return raw chunk data"
! !
RectangleMorph subclass: #ScaleMorph
	instanceVariableNames: 'caption start stop minorTick minorTickLength majorTick majorTickLength tickPrintBlock labelsAbove captionAbove '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!ScaleMorph commentStamp: '<historical>' prior: 0!
Rewrite of ScaleMorph - March 2000 (Russell Swan). Added accessors. Added two Booleans, labelsAbove and captionAbove. Determines where the labels and captions print, if they exist. Tick marks can either go up or down. For ticks going up, put in majorTickLength > 0. Negative value will make ticks go down. Examples on Class side.!


!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 00:43'!
initialize
	super initialize.
	borderWidth _ 0.
	color _ Color lightGreen.
	start _ 0.
	stop _ 100.
	minorTick _ 1.
	majorTick _ 10.
	minorTickLength _ 3.
	majorTickLength _ 10.
	caption _ nil.
	tickPrintBlock _ [:v | v printString].
	labelsAbove _ true.
	captionAbove _ true! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 14:55'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen

	self start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: nil tickPrintBlock: nil
	! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 14:54'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk 
	self start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk labelsAbove: true captionAbove: true.
	! !

!ScaleMorph methodsFor: 'initialization' stamp: 'RCS 3/16/2000 15:09'!
start: strt stop: stp minorTick: mnt minorTickLength: mntLen majorTick: mjt majorTickLength: mjtLen caption: cap tickPrintBlock: blk labelsAbove: aBoolean captionAbove: notherBoolean 
	start _ strt.
	stop _ stp.
	minorTick _ mnt.
	minorTickLength _ mntLen.
	majorTick _ mjt.
	majorTickLength _ mjtLen.
	caption _ cap.
	tickPrintBlock _ blk.
	labelsAbove _ aBoolean.
	captionAbove _ notherBoolean.
	self buildLabels! !


!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/15/2000 23:01'!
buildLabels
	| scale x1 y1 y2 x captionMorph tickMorph loopStart offset |
	((majorTickLength * minorTickLength) < 0) ifTrue: [minorTickLength _ 0 - minorTickLength].
	self removeAllMorphs.
	caption
		ifNotNil: 
			[captionMorph _ StringMorph contents: caption.
			captionAbove
				ifTrue: [offset _ majorTickLength abs + captionMorph height + 7]
				ifFalse: [offset _ 2].
			captionMorph align: captionMorph bounds bottomCenter with: self bounds bottomCenter - (0 @ offset).
			self addMorph: captionMorph].
	tickPrintBlock
		ifNotNil: 
			["Calculate the offset for the labels, depending on whether or not 
			  1) there's a caption   
			below, 2) the labels are above or below the ticks, and 3) the   
			ticks go up or down"
			labelsAbove
				ifTrue: [offset _ majorTickLength abs + minorTickLength abs + 2]
				ifFalse: [offset _ 2].
			caption
				ifNotNil: [captionAbove ifFalse: [offset _ offset + captionMorph height + 2]].
			scale _ self innerBounds width - 1 / (stop - start) asFloat.
			x1 _ self innerBounds left.
			y1 _ self innerBounds bottom.
			y2 _ y1 - offset.
			"Start loop on multiple of majorTick"
			loopStart _ (start / majorTick) ceiling * majorTick.
			loopStart
				to: stop
				by: majorTick
				do: 
					[:v | 
					x _ x1 + (scale * (v - start)).
					tickMorph _ StringMorph contents: (tickPrintBlock value: v).
					tickMorph align: tickMorph bounds bottomCenter with: x @ y2.
					tickMorph left < self left ifTrue: [tickMorph position: self left @ tickMorph top].
					tickMorph right > self right ifTrue: [tickMorph position: self right - tickMorph width @ tickMorph top].
					self addMorph: tickMorph]]! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/16/2000 14:18'!
drawMajorTicksOn: aCanvas 
	| scale x1 y1 y2 x y3 even yy loopStart checkStart yoffset randomLabel |
	scale _ self innerBounds width - 1 / (stop - start) asFloat.
	majorTickLength < 0
		ifTrue: [yoffset _ majorTickLength abs + 1]
		ifFalse: [yoffset _ 1].
	caption
		ifNotNil: [captionAbove
				ifFalse: 
					[randomLabel _ StringMorph contents: 'Foo'.
					yoffset _ yoffset + randomLabel height + 2]].
	tickPrintBlock
		ifNotNil: [labelsAbove
				ifFalse: 
					[randomLabel _ StringMorph contents: '50'.
					yoffset _ yoffset + randomLabel height + 2]].
	x1 _ self innerBounds left.
	y1 _ self innerBounds bottom - yoffset.
	y2 _ y1 - majorTickLength.
	y3 _ y1 - (minorTickLength + majorTickLength // 2).
	even _ true.
	"Make sure major ticks start drawing on a multiple of majorTick"
	loopStart _ (start / majorTick) ceiling * majorTick.
	checkStart _ (start / (majorTick / 2.0)) ceiling * majorTick.
	"Check to see if semimajor tick should be drawn before majorTick"
	checkStart = (loopStart * 2)
		ifFalse: 
			[loopStart _ checkStart / 2.0.
			even _ false].
	loopStart
		to: stop
		by: majorTick / 2.0
		do: 
			[:v | 
			x _ x1 + (scale * (v - start)).
			yy _ even
						ifTrue: [y2]
						ifFalse: [y3].
			aCanvas
				line: x @ y1
				to: x @ yy
				width: 1
				color: Color black.
			even _ even not]! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/16/2000 14:16'!
drawMinorTicksOn: aCanvas 
	| scale x1 y1 y2 x loopStart yoffset randomLabel |
	scale _ self innerBounds width - 1 / (stop - start) asFloat.
	majorTickLength < 0
		ifTrue: [yoffset _ majorTickLength abs + 1]
		ifFalse: [yoffset _ 1].
	caption
		ifNotNil: [captionAbove
				ifFalse: 
					[randomLabel _ StringMorph contents: 'Foo'.
					yoffset _ yoffset + randomLabel height + 2]].
	tickPrintBlock
		ifNotNil: [labelsAbove
				ifFalse: 
					[randomLabel _ StringMorph contents: '50'.
					yoffset _ yoffset + randomLabel height + 2]].
	x1 _ self innerBounds left.
	y1 _ self innerBounds bottom - yoffset.
	y2 _ y1 - minorTickLength.
	loopStart _ (start / minorTick) ceiling * minorTick.
	loopStart
		to: stop
		by: minorTick
		do: 
			[:v | 
			x _ x1 + (scale * (v - start)).
			aCanvas
				line: x @ y1
				to: x @ y2
				width: 1
				color: Color black].
	! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/15/2000 21:36'!
drawOn: aCanvas 
	| |
	super drawOn: aCanvas.
	
	self drawTicksOn: aCanvas.! !

!ScaleMorph methodsFor: 'drawing' stamp: 'RCS 3/16/2000 14:19'!
drawTicksOn: aCanvas 
	self drawMajorTicksOn: aCanvas.
	self drawMinorTicksOn: aCanvas! !


!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:41'!
caption
	^ caption.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:42'!
caption: aString
	caption _ aString.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/16/2000 00:38'!
captionAbove: aBoolean 
	captionAbove _ aBoolean! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/16/2000 00:38'!
labelsAbove: aBoolean
	labelsAbove _ aBoolean.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:46'!
majorTickLength: anInteger 
	majorTickLength _ anInteger! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:46'!
minorTickLength: anInteger
	minorTickLength _ anInteger.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:43'!
start
	^ start! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:43'!
start: aNumber
	start _ aNumber.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:43'!
stop
	^ stop! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:44'!
stop: aNumber
	stop _ aNumber.! !

!ScaleMorph methodsFor: 'accessing' stamp: 'RCS 3/15/2000 21:47'!
tickPrintBlock: aBlock
	tickPrintBlock _ aBlock.! !


!ScaleMorph methodsFor: 'geometry' stamp: 'RCS 3/16/2000 13:58'!
checkExtent: newExtent 
	| pixPerTick newWidth |
	pixPerTick _ newExtent x - (self borderWidth * 2) - 1 / ((stop - start) asFloat / minorTick).
	pixPerTick _ pixPerTick
				detentBy: 0.1
				atMultiplesOf: 1.0
				snap: false.
	newWidth _ pixPerTick * ((stop - start) asFloat / minorTick) + (self borderWidth * 2) + 1.
	^ (newWidth @ newExtent y).! !

!ScaleMorph methodsFor: 'geometry' stamp: 'RCS 3/16/2000 13:59'!
extent: newExtent 
	| modExtent |
	modExtent _ self checkExtent: newExtent.
	super extent: modExtent.
	self buildLabels! !


!ScaleMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	labelsAbove ifNil: [labelsAbove _ true].
	captionAbove ifNil: [captionAbove _ true].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScaleMorph class
	instanceVariableNames: ''!

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:09'!
example1
	"Example 1 captions and labels above, ticks point up"
	^ (self new
		start: 0
		stop: 150
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: 10
		caption: 'Example 1'
		tickPrintBlock: [:v | v printString];
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:09'!
example2
	"Example 2 captions and labels above, ticks point down"
	^ (self new
		start: 0
		stop: 150
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: -10
		caption: 'Example 2'
		tickPrintBlock: [:v | v printString];
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:11'!
example3
	"Example 3 caption above, labels below, ticks point down"
	^ (self new
		start: -23
		stop: 47
		minorTick: 1
		minorTickLength: 2
		majorTick: 10
		majorTickLength: -10
		caption: 'Example 3'
		tickPrintBlock: [:v | v printString]
		labelsAbove: false
		captionAbove: true;
		color: Color lightBlue;
		width: 300) openInWorld! !

!ScaleMorph class methodsFor: 'examples' stamp: 'sma 3/24/2000 12:10'!
example4
	"Example 4 caption below, labels above, ticks point up"
	^ (self new
		start: 100000
		stop: 300000
		minorTick: 5000
		minorTickLength: 2
		majorTick: 50000
		majorTickLength: 10
		caption: 'Example 4'
		tickPrintBlock: [:v | '$' , v printString]
		labelsAbove: true
		captionAbove: false;
		color: Color lightOrange;
		width: 300) openInWorld! !
Model subclass: #Scamper
	instanceVariableNames: 'status currentUrl pageSource document formattedPage downloadingProcess documentQueue recentDocuments currentAnchorLocation currentUrlIndex backgroundColor bookmark bookDir '
	classVariableNames: 'StartUrl '
	poolDictionaries: ''
	category: 'Network-Web Browser'!
!Scamper commentStamp: '<historical>' prior: 0!
a basic web browser.

It downloads things in a background thread; the background thread puts downloaded objects onto downloadQueue as they arrive.  The queue is checked in the step method.

A custom start page is provided for.  It's not as convenient as bookmarks are, but it does have a lot of flexibility--the user can put anything on the start page that is desired.

There is a hook for displaying the "lint" of a page; currently it's not a very effective linter.!


!Scamper methodsFor: 'access' stamp: 'bolot 2/27/2000 20:59'!
backgroundColor
	^backgroundColor ifNil:
		[self defaultBackgroundColor]! !

!Scamper methodsFor: 'access' stamp: 'AK 6/19/2000 15:39'!
bookmark: aDictionary
	bookmark := aDictionary.! !

!Scamper methodsFor: 'access' stamp: 'ls 7/14/1998 03:18'!
currentUrl
	^currentUrl! !

!Scamper methodsFor: 'access' stamp: 'bolot 2/27/2000 20:59'!
defaultBackgroundColor
	^Color white! !

!Scamper methodsFor: 'access' stamp: 'ls 7/14/1998 02:47'!
document
	"return the current parsed HTML document, or nil if we aren't viewing a page"
	^document! !

!Scamper methodsFor: 'access' stamp: 'ls 7/21/1998 01:16'!
formattedPage
	"format the current page and return it as a Text"
 	^formattedPage ifNil: [ ^Text new ].
	! !

!Scamper methodsFor: 'access' stamp: 'ls 9/10/1998 03:38'!
formattedPageSelection
	currentAnchorLocation ifNil: [ ^0 to: -1 ].
	^currentAnchorLocation to: currentAnchorLocation! !

!Scamper methodsFor: 'access' stamp: 'dvf 7/9/2000 01:46'!
labelString
	"return the title of the current page, or nil if there is none"
	document == nil
		ifTrue: [ ^'Scamper' ]
		ifFalse: [ ^'Scamper: ' , (self document head title ifNil: ['(untitled)']) ]! !

!Scamper methodsFor: 'access' stamp: 'ls 7/16/1998 22:18'!
status
	^status! !

!Scamper methodsFor: 'access' stamp: 'ls 7/16/1998 22:18'!
status: aSymbol
	status _ aSymbol.
	self changed: #status.! !


!Scamper methodsFor: 'browser urls' stamp: 'ls 8/12/1998 01:23'!
browserUrlContents: aRequest
	aRequest = 'start' ifTrue: [ 
		^MIMEDocument contentType: 'text/html' content: self startPage ].

	^ nil! !


!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 20:36'!
backButtonText

	^'Go back to previous URL in history'! !

!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 20:43'!
forwardButtonText

	^'Go forward to next URL in history'! !

!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 21:08'!
historyButtonText

	^'Return to a recent URL in history'! !

!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 20:48'!
homeButtonText

	^'Go to start page'! !

!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 20:45'!
reloadButtonText

	^'Reload page'! !

!Scamper methodsFor: 'button text' stamp: 'ccn 6/28/2000 20:48'!
stopButtonText

	^'Stop loading page'! !


!Scamper methodsFor: 'change/update' stamp: 'ar 11/19/1998 21:37'!
changeAll: aspects
	"We have changed all of the aspects in the given array"
	aspects do:[:symbol| self changed: symbol].! !

!Scamper methodsFor: 'change/update' stamp: 'bolot 2/27/2000 21:05'!
invalidateLayout
	self changeAll: #( backgroundColor formattedPage formattedPageSelection ).! !


!Scamper methodsFor: 'changing page' stamp: 'AM 4/18/1999 13:58'!
jumpToAbsoluteUrl: urlText
	"start downloading a new page.  The page source is downloaded in a background thread"
	|  newUrl newSource |

	self stopEverything.

	"get the new url"
	newUrl _ urlText asUrl.


	"if it fundamentally doesn't fit the pages-and-contents model used internally, spawn off an external viewer for it"
	newUrl hasContents ifFalse: [ newUrl activate.  ^true ].

	"fork a Process to do the actual downloading, parsing, and formatting.  It's results will be picked up in #step"
	self status: 'downloading ', newUrl toText, '...'.

	downloadingProcess _ [ 
	  	newSource _ [ newUrl retrieveContentsForBrowser: self ] ifError: [ :msg :ctx |
			MIMEDocument contentType: 'text/plain' content: msg ].

		newSource 
			ifNil: [ newSource _ MIMEDocument contentType: 'text/plain' content: 'Error retrieving this URL' ].

			newSource url ifNil: [
				newSource _ MIMEDocument contentType: newSource contentType  content: newSource content  url: newUrl ].

			documentQueue nextPut: newSource.
			downloadingProcess _ nil.
	] newProcess.

	downloadingProcess resume.

	[recentDocuments size > currentUrlIndex] whileTrue: [
		"delete all elements in recentDocuments after currentUrlIndex"
		recentDocuments removeLast.
	].
	currentUrlIndex _ currentUrlIndex + 1.

	^true! !

!Scamper methodsFor: 'changing page' stamp: 'ls 8/20/1998 08:56'!
jumpToNewUrl
	"change to a new, user-specified page"
	| newUrl |
	newUrl _ FillInTheBlank request: 'url to visit' initialAnswer: currentUrl toText.
	(newUrl isNil or: [ newUrl isEmpty ]) ifTrue: [ ^self ].
	self jumpToAbsoluteUrl: newUrl! !

!Scamper methodsFor: 'changing page' stamp: 'ls 8/20/1998 11:22'!
jumpToUrl: urlText
	"start downloading a new page.  The page source is downloaded in a background thread"
	self jumpToAbsoluteUrl: (urlText asUrlRelativeTo: currentUrl)
! !

!Scamper methodsFor: 'changing page' stamp: 'ar 11/19/1998 23:12'!
startDownloadingMorphState: morphs
	downloadingProcess _ [
		morphs do: [ :m | m downloadStateIn: self].
	] newProcess.
	downloadingProcess resume.! !

!Scamper methodsFor: 'changing page' stamp: 'ls 8/12/1998 00:56'!
startDownloadingStateIn: aDocument  url: aUrl
	"download the state for the given document in a background thread.  signal the foreground when the data has arrived"
	downloadingProcess _ [	
		aDocument allSubentitiesDo: [ :e |
			e downloadState: aUrl ].
		documentQueue nextPut: #stateDownloaded.
		downloadingProcess _ nil. ] newProcess.
	downloadingProcess resume.! !

!Scamper methodsFor: 'changing page' stamp: 'ls 7/24/1998 01:28'!
stopEverything
	"stop all background threads and empty queues for communicating with them; bring this Scamper to a sane state before embarking on something new"
	
	downloadingProcess ifNotNil: [
		downloadingProcess terminate.
		downloadingProcess _ nil. ].

	[ documentQueue isEmpty ] whileFalse: [ documentQueue next ].

	self status: 'sittin'.! !

!Scamper methodsFor: 'changing page' stamp: 'tk 9/22/1998 20:26'!
submitFormWithInputs: inputs  url: url  method: method
	| newUrl newSource | 
	self stopEverything.

	(method asLowercase ~= 'get' and: [ method asLowercase ~= 'post' ]) ifTrue: [
		self notify: 'unkown FORM method: ', method.
		^false ].

	newUrl _ url asUrlRelativeTo: currentUrl.	

	newUrl schemeName ~= 'http' ifTrue: [
		self notify: 'I can only submit forms via HTTP'.
		^false ].

	self status: 'submitting form...'.

	downloadingProcess _ [
			method asLowercase = 'get' 
				ifTrue: [newSource _ newUrl retrieveContentsArgs: inputs] 
				ifFalse: [newSource _ newUrl postFormArgs: inputs].
			documentQueue nextPut:  newSource.

			downloadingProcess _ nil.
		] newProcess.

		downloadingProcess resume.
		^true
! !

!Scamper methodsFor: 'changing page' stamp: 'bolot 11/3/1999 03:08'!
submitFormWithInputs: inputs url: url method: method encoding: encoding
	| newUrl newSource | 
	self stopEverything.

	(method asLowercase ~= 'get' and: [ method asLowercase ~= 'post' ]) ifTrue: [
		self notify: 'unkown FORM method: ', method.
		^false ].

	newUrl _ url asUrlRelativeTo: currentUrl.	

	newUrl schemeName ~= 'http' ifTrue: [
		self notify: 'I can only submit forms via HTTP'.
		^false ].

	self status: 'submitting form...'.

	downloadingProcess _ [
		method asLowercase = 'get' 
			ifTrue: [newSource _ newUrl retrieveContentsArgs: inputs] 
			ifFalse: [
				encoding = MIMEDocument contentTypeMultipart
					ifTrue: [newSource _ newUrl postMultipartFormArgs: inputs]
					ifFalse: [newSource _ newUrl postFormArgs: inputs]].
		documentQueue nextPut:  newSource.

		downloadingProcess _ nil.
	] newProcess.

	downloadingProcess resume.
	^true
! !


!Scamper methodsFor: 'creation' stamp: 'ccn 6/28/2000 19:52'!
openAsMorph

	^self morphicWindow openInWorld
! !


!Scamper methodsFor: 'document handling' stamp: 'AM 4/18/1999 14:27'!
displayDocument: mimeDocument
	"switch to viewing the given MIMEDocument"
	|  handled  urlString |
	handled _ false.

	"add it to the history"
"	recentDocuments removeAllSuchThat: [ :d | d url = mimeDocument url ]."
	currentUrlIndex > recentDocuments size
		ifTrue: [recentDocuments addLast: mimeDocument].
"		ifFalse: [recentDocuments removeAt: currentUrlIndex]."
	recentDocuments size > 20 ifTrue: [ recentDocuments removeFirst ].
		
	mimeDocument mainType = 'image' 
		ifTrue: [handled _ self displayImagePage: mimeDocument].

	mimeDocument contentType = 'text/html' 
		ifTrue: [handled _ self displayTextHtmlPage: mimeDocument].

	mimeDocument contentType = 'x-application/shockwave-flash'
		ifTrue:[handled _ self displayFlashPage: mimeDocument].

	(#('audio/midi' 'audio/x-midi') includes: mimeDocument contentType) 
		ifTrue: [handled _ self processMidiPage: mimeDocument].

	"Before we display plain text files we should look at the extension of the URL"
	(handled not and:[ mimeDocument mainType = 'text']) ifTrue:[
		urlString _ mimeDocument url toText.
		(urlString endsWithAnyOf: #('.gif' '.jpg' '.pcx')) 
			ifTrue:[handled _ self displayImagePage: mimeDocument].
		(handled not and:[urlString endsWithAnyOf: #('.mid' '.midi')])
			ifTrue:[handled _ self processMidiPage: mimeDocument].
		(handled not and:[urlString endsWith: '.swf'])
			ifTrue:[handled _ self displayFlashPage: mimeDocument].
	].

	(handled not and: [ mimeDocument mainType = 'text']) ifTrue: [
		self displayPlainTextPage: mimeDocument.
		handled _ true].


	handled ifFalse: [self processUnhandledPage: mimeDocument].! !

!Scamper methodsFor: 'document handling' stamp: 'md 5/11/2000 19:12'!
displayFlashPage: newSource
	"A shockwave flash document -- embed it in a text"
	| attrib stream player |
	stream _ (RWBinaryOrTextStream with: newSource content) binary reset.
	(FlashFileReader canRead: stream) ifFalse:[^false]. "Not a flash file"
	player _ (FlashMorphReader on: stream) processFileAsync.
	player sourceUrl: newSource url.
	player startPlaying.
	attrib _ TextAnchor new anchoredMorph: player.
	formattedPage _ ' * ' asText.
	backgroundColor _ self defaultBackgroundColor.
	formattedPage addAttribute: attrib from: 2 to: 2.

	currentUrl _ newSource url.
	pageSource _ newSource content.

	"remove it from the history--these thigns are too big!!"
	"ideally, there would be a smarter history mechanism that can do things like remove items when memory consumption gets too high...."
"	recentDocuments removeLast."

	self changeAll: 	#(currentUrl relabel hasLint lint backgroundColor formattedPage formattedPageSelection).
	self status: 'sittin'.
	^true! !

!Scamper methodsFor: 'document handling' stamp: 'md 5/11/2000 19:14'!
displayImagePage: newSource
	"an image--embed it in a text"
	| image imageMorph attrib text handled |
	handled _ true.
	backgroundColor _ self defaultBackgroundColor.
	formattedPage _ [
		image _ ImageReadWriter formFromStream: (RWBinaryOrTextStream with: newSource content) binary reset.
		imageMorph _ ImageMorph new image: image.
		attrib _ TextAnchor new anchoredMorph: imageMorph.
		text _ ' * ' asText.
		text addAttribute: attrib from: 2 to: 2.
		text] ifError: [ :msg :ctx | handled _ false ].

	currentUrl _ newSource url.
	pageSource _ newSource content.

	"remove it from the history--these thigns are too big!!"
	"ideally, there would be a smarter history mechanism that can do things like remove items when memory consumption gets too high...."
"	recentDocuments removeLast."

	self changeAll: 	#(currentUrl relabel hasLint lint backgroundColor formattedPage formattedPageSelection).
	self status: 'sittin'.
	^handled! !

!Scamper methodsFor: 'document handling' stamp: 'md 5/11/2000 19:15'!
displayPlainTextPage: newSource
	"treat as plain text"
	pageSource _ newSource content.
	document _ nil.
	formattedPage _ pageSource withSqueakLineEndings.
	backgroundColor _ self defaultBackgroundColor.
	currentUrl _ newSource url.

	self status: 'sittin'.
	self changeAll: 	#(currentUrl relabel hasLint lint formattedPage formattedPage
formattedPageSelection).
	^true! !

!Scamper methodsFor: 'document handling' stamp: 'tk 7/9/2000 23:10'!
displayTextHtmlPage: newSource
	"HTML page--format it"
	| formatter bgimageUrl bgimageDoc bgimage |
	currentUrl _ newSource url.
	pageSource _ newSource content isoToSqueak.
	self status: 'parsing...'.
	document _ (HtmlParser parse: (ReadStream on: pageSource)).
	self status: 'laying out...'.
	formatter _ HtmlFormatter preferredFormatterClass new.
	formatter browser: self.
	formatter baseUrl: currentUrl.
	document addToFormatter: formatter.

	formattedPage _ formatter text.
	(bgimageUrl _ document body background)
		ifNotNil:
			[bgimageDoc _ (bgimageUrl asUrlRelativeTo: currentUrl) retrieveContents.
			[bgimage _ ImageReadWriter formFromStream: bgimageDoc contentStream binary]
				ifError: [:err :rcvr | "ignore" bgimage _ nil]].
	bgimage
		ifNotNil: [backgroundColor _ bgimage]
		ifNil: [backgroundColor _ Color fromString: document body bgcolor].
	currentUrl fragment
		ifNil: [ currentAnchorLocation _ nil ]
		ifNotNil: [ currentAnchorLocation _
				formatter anchorLocations 
					at: currentUrl fragment asLowercase
					ifAbsent: [ nil ] ].

	self startDownloadingMorphState: (formatter incompleteMorphs).

	self changeAll: 	#(currentUrl relabel hasLint lint backgroundColor formattedPage formattedPageSelection).
	self status: 'done.'.
	"pardon this horrible hack...(tk)"
	(currentUrl authority beginsWith: 'ets.freetranslation.com') ifTrue: [
		self status: 'done.
**** Please Scroll Down To See Your Results ****'].
	^true! !

!Scamper methodsFor: 'document handling' stamp: 'ar 11/19/1998 22:00'!
processMidiPage: newSource
	Smalltalk at: #MIDIFileReader ifPresent:
		[:reader |
		reader playStream: (RWBinaryOrTextStream with: newSource content) reset binary.
		self status: 'sittin'.
		^true].
	^false! !

!Scamper methodsFor: 'document handling' stamp: 'RAA 1/14/2001 15:50'!
processUnhandledPage: newSource
	"offer to save it to a file"
	| fileName file |
	self status: 'sittin'.

	(newSource url toText endsWith: '.pr') ifTrue: [
		(self confirm: 'Looks like a Squeak project - do you want to load it as such?') ifTrue: [
			^ProjectLoading thumbnailFromUrl: newSource url toText
		].
	].

	(self confirm: 'unkown content-type ', newSource contentType,'--
Would you like to save to a file?') ifFalse: [ ^false ].

	fileName _ ''.
	[
		fileName _ FillInTheBlank request: 'file to save in' initialAnswer: fileName.
		fileName isEmpty ifTrue: [ ^self ].
		file _ FileStream fileNamed: fileName.
		file == nil
	] whileTrue.

	file reset.
	file binary.
	file nextPutAll: newSource content.
	file close.
	^true! !


!Scamper methodsFor: 'initialization' stamp: 'AK 6/19/2000 13:29'!
initialize
	documentQueue _ SharedQueue new.
	recentDocuments _ OrderedCollection new.
	bookmark := Dictionary new.
	currentUrlIndex _ 0.
	currentUrl _ ''.
	pageSource _ ''.
	document _ HtmlParser parse: (ReadStream on: '').
	self status: 'sittin'! !


!Scamper methodsFor: 'lint' stamp: 'ls 8/1/1998 03:10'!
hasLint
	"whether the current page has any questionable HTML in it"
	document ifNil: [ ^false ].
	^document lint ~= ''! !

!Scamper methodsFor: 'lint' stamp: 'ls 9/14/1998 20:38'!
lint
	"return a string describing any questionable HTML that was noticed in the current page"
	"(not currently very comprehensive)"
	document ifNil: [ ^'' ].
	^document lint! !

!Scamper methodsFor: 'lint' stamp: 'ls 7/29/1998 00:07'!
showLint
	(StringHolder new contents: self lint) openLabel: 'lint for ', self currentUrl printString.! !


!Scamper methodsFor: 'menus' stamp: 'AK 6/20/2000 15:00'!
addNewSubMenu: aDictionary 
	| subMenu url sub |
	subMenu _ MenuMorph new.
	aDictionary
		keysAndValuesDo: 
			[:name :value | 
			url _ value.
			(url isKindOf: Dictionary)
				ifTrue: 
					[sub _ self addNewSubMenu: url.
					subMenu add: name subMenu: sub]
				ifFalse: [subMenu
						add: name
						target: self
						selector: #jumpToUrl:
						argument: url]].
	^ subMenu! !

!Scamper methodsFor: 'menus' stamp: 'AK 6/22/2000 13:25'!
addToBookmark
	| key value file filename |
	key _ self document head title ifNil: ['Untitled'].
	value _ self currentUrl.
	filename _ key,'.lin'.
	bookDir deleteFileNamed: filename. 
	file _ StandardFileStream fileNamed: (bookDir fullNameFor: filename).
	file ifNil:[self error: 'could not save file'].
	file nextPutAll: value asString. 
	file close.
	bookmark add: (Association key: key value: value).
	! !

!Scamper methodsFor: 'menus' stamp: 'AM 4/18/1999 14:27'!
back
	"this method is added to Scamper: Aibek 4/18/99"
	currentUrlIndex > 1
		ifTrue: [
			currentUrlIndex _ currentUrlIndex - 1.
			self displayDocument: (recentDocuments at: currentUrlIndex).
		]
		ifFalse: [^ self].
! !

!Scamper methodsFor: 'menus' stamp: 'ar 10/5/2000 19:32'!
bookmark
	| menu sub url |
	menu _ (MenuMorph entitled: ' Bookmark ')
				defaultTarget: self.
	menu addStayUpItem.
	menu addLine.
	menu
		add: 'add to bookmark'
		target: self
		selector: #addToBookmark.
	menu add: 'Import...' target: self selector: #importBookmark. 
	menu addLine.
	bookmark
		keysAndValuesDo: 
			[:name :value | 
			url _ value.
			(url isKindOf: Dictionary)
				ifTrue: 
					[sub _ self addNewSubMenu: url.
					menu add: name subMenu: sub]
				ifFalse: [menu
						add: name
						selector: #jumpToUrl:
						argument: url]].
	menu popUpInWorld: self currentWorld! !

!Scamper methodsFor: 'menus' stamp: 'AK 6/29/2000 13:24'!
createBookmarkFiles: aDirectory dict: aDictionary dirname: aName
	| dir file filename |
	(aDirectory directoryExists: aName) ifFalse:[aDirectory createDirectory: aName]. 
	dir _ aDirectory directoryNamed: aName.
	aDictionary keysAndValuesDo:[:k :v |
				(v isKindOf: Dictionary)
					ifTrue:[self createBookmarkFiles: dir dict: v dirname: k]
					ifFalse:[filename _ k, '.lin'.
							dir deleteFileNamed: filename.
							file _ StandardFileStream fileNamed: (dir fullNameFor: filename).
							file ifNil:[self error: 'could not save file'].
							file nextPutAll: v asString.
							file close]
				].! !

!Scamper methodsFor: 'menus' stamp: 'ar 10/5/2000 19:32'!
displayHistory
	"Let the user selecet a previous page to view."

	| menu |
	menu _ MenuMorph entitled: 'Recent URLs'.
	menu defaultTarget: self.
	menu addStayUpItem.
	menu addLine.
	recentDocuments reverseDo:
		[:doc |
		menu add: doc url toText selector: #displayDocument: argument: doc].
	menu popUpInWorld: self currentWorld! !

!Scamper methodsFor: 'menus' stamp: 'kfr 6/11/2000 13:33'!
editStartPage
	| win textMorph |
	Smalltalk isMorphic ifFalse: [^ self inform: 'only works for morphic currently'].

	win _ SystemWindow labelled: 'edit Bookmark page'.
	win model: self.
	textMorph _ PluggableTextMorph on: self text: #startPage  accept: #startPage:.
	win addMorph: textMorph frame: (0@0 extent: 1@1).
	win openInWorld.
	^ true! !

!Scamper methodsFor: 'menus' stamp: 'AM 4/18/1999 14:28'!
forward
	"this method is added to Scamper: Aibek 4/18/99"
	currentUrlIndex >= recentDocuments size
		ifTrue: [^self]
		ifFalse: [
			currentUrlIndex _ currentUrlIndex + 1.
			self displayDocument: (recentDocuments at: currentUrlIndex).
		]
! !

!Scamper methodsFor: 'menus' stamp: 'AK 6/29/2000 13:32'!
importBookmark
	| newDirectory importLinks filename file |
	newDirectory _ FillInTheBlank request: 'Directory to import' initialAnswer: bookDir pathName.
	(newDirectory isNil or: [ newDirectory isEmpty ]) ifTrue: [ ^self ].
	(FileDirectory new directoryExists: newDirectory)
		ifTrue:[importLinks _ self makeBookmark: (FileDirectory on: newDirectory).
				importLinks isEmpty 
					ifFalse:[importLinks associationsDo:[:ass | bookmark add: ass.
							(ass value isKindOf: Dictionary)
								ifTrue:[self createBookmarkFiles: bookDir dict: ass value dirname: ass key]
								ifFalse:[filename _ ass key,'.lin'.
										bookDir deleteFileNamed: filename.
										file _ StandardFileStream fileNamed: (bookDir fullNameFor: filename).
										file ifNil:[self error: 'could not save file'].
										file nextPutAll: ass value asString. 
										file close]
								]
							].
				]
		ifFalse:[self importBookmark].! !

!Scamper methodsFor: 'menus' stamp: 'AK 6/28/2000 17:34'!
importUrl: aFile
	| oldFile url strings position |
	oldFile _ FileStream oldFileOrNoneNamed: aFile.
	oldFile isBinary 
		ifTrue:[ self error: 'not url file']
		ifFalse:[ strings _ (oldFile contentsOfEntireFile) substrings.
				strings do:[:sub |
				( sub includesSubString: 'URL=')
					ifTrue:[ position := sub findString: 'http://'.
							position > 0 ifTrue:[url := sub copyFrom: position to: sub size]
										ifFalse:[ position := sub findString: 'ftp://'.
												position > 0 ifTrue:[url := sub copyFrom: position to: sub size].
												]
							]	
					].
				]. 
	url =='' ifTrue:[ self error: 'blank file: url not exist'].
	^url asUrl.! !

!Scamper methodsFor: 'menus' stamp: 'ls 7/14/1998 17:54'!
inspectParseTree
	"inspect a parse tree of the current page's source"
	document ifNotNil: [ document inspect ]! !

!Scamper methodsFor: 'menus' stamp: 'AK 6/19/2000 15:37'!
menu: menu shifted: shifted 
	"added 'back' and 'forward' menu options: Aibek 4/18/99"
	| lines selections linePositions |
	lines _ 'back
forward
new URL
history
view source
inspect parse tree
go to start page
edit start page
bookmark'.
	linePositions _ #(2 4 6 ).
	selections _ #(#back #forward #jumpToNewUrl #displayHistory #viewSource #inspectParseTree #visitStartPage #editStartPage #bookmark ).
	downloadingProcess
		ifNotNil: 
			[lines _ lines , String cr , 'stop downloading'.
			linePositions _ linePositions , selections size asOrderedCollection.
			selections _ selections , #(#stopEverything )].
	menu
		labels: lines
		lines: linePositions
		selections: selections.
	^ menu! !

!Scamper methodsFor: 'menus' stamp: 'ls 7/14/1998 02:28'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!Scamper methodsFor: 'menus' stamp: 'kfr 6/11/2000 13:24'!
reload
	self stopEverything.
	self jumpToUrl: currentUrl
	
! !

!Scamper methodsFor: 'menus' stamp: 'ls 7/27/1998 23:16'!
viewSource
	"view the source HTML of this page"
	(StringHolder new contents: (pageSource withSqueakLineEndings)) openLabel: 'source for ',currentUrl printString.! !

!Scamper methodsFor: 'menus' stamp: 'ls 8/12/1998 02:01'!
visitStartPage
	self jumpToAbsoluteUrl: 'browser:start'.
	^true! !


!Scamper methodsFor: 'not yet categorized' stamp: 'ls 9/14/1998 20:15'!
doItContext
	^nil! !

!Scamper methodsFor: 'not yet categorized' stamp: 'ls 9/14/1998 20:15'!
doItReceiver
	^nil! !

!Scamper methodsFor: 'not yet categorized' stamp: 'ls 7/29/1998 03:28'!
release
	self stopEverything.
	super release.! !


!Scamper methodsFor: 'start page' stamp: 'ls 8/8/1998 04:01'!
startPage
	"return the contents of the user's personal start page"
	| file |
	file _ FileStream oldFileOrNoneNamed: 'StartPage.html'.
	file 
		ifNil: [ ^'<title>Personal Start Page</title>\<h1>Personal Start Page</h1>\This space is empty' withCRs ]
		ifNotNil: [ ^file contentsOfEntireFile ]! !

!Scamper methodsFor: 'start page' stamp: 'ccn 6/28/2000 21:24'!
startPage: newPage
	"fill in the contents of the user's personal start page"

	| file |
	FileDirectory default deleteFileNamed: 'StartPage.html'.
	[file _ FileStream fileNamed: 'StartPage.html'.
	file ifNil: [self error: 'could not save file'].
	file nextPutAll: newPage asString.
	] ensure: [file close].
	self changed: #startPage.
	^true! !


!Scamper methodsFor: 'stepping' stamp: 'bolot 2/27/2000 21:06'!
step
	"check if a new document has arrived"
	| results |
	[documentQueue isEmpty] whileFalse: [
		results _ documentQueue next.

		results == #stateDownloaded ifTrue: [ 
			"images and such have been downloaded; update the page"
			self status: 'reformatting page...'.
			formattedPage _ document formattedTextForBrowser: self defaultBaseUrl: currentUrl.
			backgroundColor _ Color fromString: document body bgcolor.
			self changeAll: #(backgroundColor formattedPage).
			self status: 'sittin'. ]
		 ifFalse: [		
			self displayDocument: results 	
		] ]! !

!Scamper methodsFor: 'stepping' stamp: 'di 1/14/1999 09:00'!
wantsSteps
	^ true! !


!Scamper methodsFor: 'testing' stamp: 'ls 7/14/1998 21:44'!
isWebBrowser
	^true! !


!Scamper methodsFor: 'window definition' stamp: 'ar 11/9/2000 21:22'!
buttonRowPane
	"Create and return a pane of navigation buttons."

	| buttonRow |
	buttonRow _ AlignmentMorph new
		borderWidth: 0;
		layoutInset: 0;
		hResizing: #spaceFill;
		wrapCentering: #center; cellPositioning: #leftCenter;
		clipSubmorphs: true;
		addTransparentSpacerOfSize: (5@0).
	
	buttonRow 
		addMorphBack: (self simpleButtonNamed: 'Back' action: #back text: self backButtonText); 
		addTransparentSpacerOfSize: (5@0);
		addMorphBack: (self simpleButtonNamed: 'Forward' action: #forward text: self forwardButtonText); 
		addTransparentSpacerOfSize: (5@0);
		addMorphBack: (self simpleButtonNamed: 'History' action: #displayHistory text: self historyButtonText); 
		addTransparentSpacerOfSize: (5@0);
		addMorphBack: (self simpleButtonNamed: 'Reload' action: #reload text: self reloadButtonText); 
		addTransparentSpacerOfSize: (5@0);
		addMorphBack: (self simpleButtonNamed: 'Home' action: #visitStartPage text: self homeButtonText); 
		addTransparentSpacerOfSize: (5@0);
		addMorphBack: (self simpleButtonNamed: 'Stop!!' action: #stopEverything text: self stopButtonText); 
		addTransparentSpacerOfSize: (5@0).

	^buttonRow! !

!Scamper methodsFor: 'window definition' stamp: 'ccn 6/28/2000 20:10'!
morphicWindow
	"Create and return a Morphic window for Scamper."

	^(SystemWindow labelled: 'Scamper')
		model: self;
		setProperty: #webBrowserView toValue: true;
		addMorph: self buttonRowPane frame: (0@0 extent: 1@0.07);		"Navigation buttons"
		addMorph: self urlEditPane frame: (0@0.07 extent: 1@0.06);		"URL edit pane"
		addMorph: self webContentsPane frame: (0@0.13 extent: 1@0.81);	"The web page pane"
		addMorph: self statusPane frame: (0@0.94 extent: 1.0@0.06).		"Status pane"! !

!Scamper methodsFor: 'window definition' stamp: 'ccn 6/28/2000 20:53'!
simpleButtonNamed: buttonLabel action: selector text: balloonText
	"Create and return a simple button with Scamper as the target."

	^SimpleButtonMorph new
		label: buttonLabel;
		target: self;
		color: Color transparent;
		cornerStyle: #rounded;
		borderColor: Color black;
		actionSelector: selector;
		actWhen: #buttonUp;
		setBalloonText: balloonText;
		yourself
! !

!Scamper methodsFor: 'window definition' stamp: 'ccn 6/28/2000 21:01'!
statusPane
	"Create and return the browser status pane."

	^PluggableTextMorph on: self text: #status accept: nil! !

!Scamper methodsFor: 'window definition' stamp: 'ccn 6/28/2000 20:58'!
urlEditPane
	"Create and return the URL edit pane."

	^(PluggableTextMorph on: self text: #currentUrl accept: #jumpToAbsoluteUrl:)
		acceptOnCR: true;
		yourself! !

!Scamper methodsFor: 'window definition' stamp: 'ccn 6/28/2000 21:00'!
webContentsPane
	"Create and return the web page pane."

	^WebPageMorph
		on: self 
		bg: #backgroundColor 
		text: #formattedPage 
		readSelection: #formattedPageSelection 
		menu: #menu:shifted:! !


!Scamper methodsFor: 'user interface' stamp: 'AK 6/21/2000 17:12'!
loadBookmark
	| directory favorite |
	favorite := 'Bookmark'.
	directory := FileDirectory default.
	(directory directoryExists: favorite)
			ifTrue:[bookDir := directory directoryNamed: favorite.
					self bookmark: (self makeBookmark: bookDir)
					]
			ifFalse:[directory createDirectory: favorite.
					bookDir := directory directoryNamed: favorite.
					self bookmark: Dictionary new ].
	! !

!Scamper methodsFor: 'user interface' stamp: 'AK 6/23/2000 14:32'!
makeBookmark: aDirectory
	| directories dir book extension extension1|
	extension := '*.lin'.
	extension1 := '*.url'. " for IE favorite files"
	book := Dictionary new.
	directories := aDirectory directoryNames.
	directories isEmpty
		ifFalse:[directories do:[:dn |
					dir := aDirectory directoryNamed: dn.
					book add: ( Association key: dn value: ( self makeBookmark: dir))
					]].
	aDirectory fileNames do:
	[:fn | (extension match: fn)
				ifTrue:[ book add: (Association key: (fn truncateTo: (fn size - 4))
							value: (self readUrlFromFile: (aDirectory fullNameFor: fn)))].
		  (extension1 match: fn)
				ifTrue:[ book add: (Association key: (fn truncateTo: (fn size - 4))
							value: ( self importUrl: (aDirectory fullNameFor: fn)))].
	].
	^book
	
		! !

!Scamper methodsFor: 'user interface' stamp: 'AK 6/22/2000 13:20'!
readUrlFromFile: aFile
	| oldFile url |
	oldFile _ FileStream oldFileOrNoneNamed: aFile.
	oldFile isBinary 
		ifTrue:[ self error: 'not url file']
		ifFalse:[url _ (oldFile contentsOfEntireFile) withBlanksTrimmed.
				url =='' ifTrue:[ self error: 'blank file: url not exist'].
				^url asUrl].
	! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Scamper class
	instanceVariableNames: ''!

!Scamper class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 11:33'!
new
	^ super new initialize! !

!Scamper class methodsFor: 'instance creation' stamp: 'tk 7/14/2000 15:20'!
newOrExistingOn: aStringOrUrl
	| aUrl siteStr |
	"If a Scamper is open on the same site, return its SystemWindow, else return a new Scamper."

aUrl _ aStringOrUrl asUrl.
siteStr _ aUrl schemeName, '://', aUrl authority.

Smalltalk isMorphic ifTrue: [
	World submorphsDo: [:m | 
		((m isKindOf: SystemWindow) and: [m model isKindOf: Scamper]) ifTrue: [
			(m model currentUrl asString beginsWith: siteStr) ifTrue: [
					m expand.
					^ m]]]].

^ self new openAsMorph
! !

!Scamper class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 11:48'!
open
	"Scamper open"

	^ self openOnUrl: StartUrl! !

!Scamper class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 11:48'!
openAsMorph
	"Deprecated. Use open instead."

	^ self open! !

!Scamper class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 11:49'!
openOnUrl: aStringOrUrl
	"Open Scamper browser on specified url.
		Scamper openOnUrl: 'www.squeak.org'
		Scamper openOnUrl: 'file://C%3A/test.htm'
	"

	^ self new
		jumpToUrl: aStringOrUrl asUrl;
		openAsMorph! !


!Scamper class methodsFor: 'initialization' stamp: 'sma 4/30/2000 11:39'!
StartUrl: aStringOrUrl
	"Specify the default URL to start from."

	StartUrl _ aStringOrUrl asUrl! !

!Scamper class methodsFor: 'initialization' stamp: 'AK 6/21/2000 15:10'!
initialize
	self StartUrl: 'http://minnow.cc.gatech.edu/squeak.1'.
	! !
Object subclass: #Scanner
	instanceVariableNames: 'source mark hereChar aheadChar token tokenType currentComment buffer typeTable '
	classVariableNames: 'TypeTable '
	poolDictionaries: ''
	category: 'System-Compiler'!
!Scanner commentStamp: '<historical>' prior: 0!
I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.!


!Scanner methodsFor: 'initialize-release'!
initScanner

	buffer _ WriteStream on: (String new: 40).
	typeTable _ TypeTable! !

!Scanner methodsFor: 'initialize-release'!
scan: inputStream 
	"Bind the input stream, fill the character buffers and first token buffer."

	source _ inputStream.
	self step.
	self step.
	self scanToken! !


!Scanner methodsFor: 'public access'!
scanFieldNames: stringOrArray
	"Answer an Array of Strings that are the identifiers in the input string, 
	stringOrArray. If passed an Array, just answer with that Array, i.e., 
	assume it has already been scanned."

	| strm |
	(stringOrArray isMemberOf: Array)
		ifTrue: [^stringOrArray].
	self scan: (ReadStream on: stringOrArray asString).
	strm _ WriteStream on: (Array new: 10).
	[tokenType = #doIt]
		whileFalse: 
			[tokenType = #word ifTrue: [strm nextPut: token].
			self scanToken].
	^strm contents

	"Scanner new scanFieldNames: 'abc  def ghi' ('abc' 'def' 'ghi' )"! !

!Scanner methodsFor: 'public access'!
scanStringStruct: textOrString 
	"The input is a string whose elements are identifiers and parenthesized
	 groups of identifiers.  Answer an array reflecting that structure, representing
	 each identifier by an uninterned string."

	self scan: (ReadStream on: textOrString asString).
	self scanStringStruct.
	^token

	"Scanner new scanStringStruct: 'a b (c d) (e f g)'"! !

!Scanner methodsFor: 'public access'!
scanTokens: textOrString 
	"Answer an Array that has been tokenized as though the input text, 
	textOrString, had appeared between the array delimitors #( and ) in a 
	Smalltalk literal expression."

	self scan: (ReadStream on: textOrString asString).
	self scanLitVec.
	^token

	"Scanner new scanTokens: 'identifier keyword: 8r31 ''string'' .'"! !


!Scanner methodsFor: 'expression types'!
advance

	| prevToken |
	prevToken _ token.
	self scanToken.
	^prevToken! !

!Scanner methodsFor: 'expression types' stamp: 'di 4/23/2000 22:15'!
checkpoint
	"Return a copy of all changeable state.  See revertToCheckpoint:"

	^ {self clone. source clone. currentComment copy}! !

!Scanner methodsFor: 'expression types'!
nextLiteral
	"Same as advance, but -4 comes back as a number instead of two tokens"

	| prevToken |
	prevToken _ self advance.
	(prevToken == #- and: [token isKindOf: Number])
		ifTrue: 
			[^self advance negated].
	^prevToken! !

!Scanner methodsFor: 'expression types' stamp: 'di 4/23/2000 22:11'!
revertToCheckpoint: checkpoint
	"Revert to the state when checkpoint was made."

	| myCopy |
	myCopy _ checkpoint first.
	1 to: self class instSize do:
		[:i | self instVarAt: i put: (myCopy instVarAt: i)].
	source _ checkpoint second.
	currentComment _ checkpoint third! !

!Scanner methodsFor: 'expression types' stamp: 'di 6/2/2000 08:41'!
scanLitVec

	| s |
	s _ WriteStream on: (Array new: 16).
	[tokenType = #rightParenthesis or: [tokenType = #doIt]]
		whileFalse: 
			[tokenType = #leftParenthesis
				ifTrue: 
					[self scanToken; scanLitVec]
				ifFalse: 
					[tokenType = #word | (tokenType = #keyword) | (tokenType = #colon)
						ifTrue: 
							[self scanLitWord]
						ifFalse:
							[(token == #- 
									and: [(typeTable at: hereChar asciiValue) = #xDigit])
								ifTrue: 
									[self scanToken.
									token _ token negated]]].
			s nextPut: token.
			self scanToken].
	token _ s contents! !

!Scanner methodsFor: 'expression types'!
scanLitWord
	"Accumulate keywords and asSymbol the result."

	| t |
	[(typeTable at: hereChar asciiValue) = #xLetter]
		whileTrue: 
			[t _ token.
			self xLetter.
			token _ t , token].
	token _ token asSymbol! !

!Scanner methodsFor: 'expression types'!
scanStringStruct

	| s |
	s _ WriteStream on: (Array new: 16).
	[tokenType = #rightParenthesis or: [tokenType = #doIt]]
		whileFalse: 
			[tokenType = #leftParenthesis
				ifTrue: 
					[self scanToken; scanStringStruct]
				ifFalse: 
					[tokenType = #word ifFalse:
						[^self error: 'only words and parens allowed']].
			s nextPut: token.
			self scanToken].
	token _ s contents! !

!Scanner methodsFor: 'expression types'!
scanToken

	[(tokenType _ typeTable at: hereChar asciiValue) == #xDelimiter]
		whileTrue: [self step].  "Skip delimiters fast, there almost always is one."
	mark _ source position - 1.
	(tokenType at: 1) = $x "x as first letter"
		ifTrue: [self perform: tokenType "means perform to compute token & type"]
		ifFalse: [token _ self step asSymbol "else just unique the first char"].
	^token! !

!Scanner methodsFor: 'expression types'!
step

	| c |
	c _ hereChar.
	hereChar _ aheadChar.
	source atEnd
		ifTrue: [aheadChar _ 30 asCharacter "doit"]
		ifFalse: [aheadChar _ source next].
	^c! !


!Scanner methodsFor: 'multi-character scans' stamp: 'SqR 8/23/2000 16:20'!
xBinary

	tokenType _ #binary.
	token _ self step asSymbol.
	[(typeTable at: hereChar asciiValue) = #xBinary and: [hereChar ~= $-]]
		whileTrue: [token _ (token , (String with: self step)) asSymbol]! !

!Scanner methodsFor: 'multi-character scans'!
xColon		"Allow := for assignment by converting to #_ "
	aheadChar = $= ifTrue:
		[self step.
		tokenType _ #leftArrow.
		self step.
		^ token _ #_].
	"Otherwise, just do what normal scan of colon would do"
	tokenType _ #colon.
	^ token _ self step asSymbol! !

!Scanner methodsFor: 'multi-character scans'!
xDelimiter
	"Ignore blanks, etc."

	self scanToken! !

!Scanner methodsFor: 'multi-character scans' stamp: 'tao 4/23/98 12:55'!
xDigit
	"Form a number."

	tokenType _ #number.
	(aheadChar = 30 asCharacter and: [source atEnd
			and:  [source skip: -1. source next ~= 30 asCharacter]])
		ifTrue: [source skip: -1 "Read off the end last time"]
		ifFalse: [source skip: -2].
	token _ [Number readFrom: source] ifError: [:err :rcvr | self offEnd: err].
	self step; step! !

!Scanner methodsFor: 'multi-character scans'!
xDollar
	"Form a Character literal."

	self step. "pass over $"
	token _ self step.
	tokenType _ #number "really should be Char, but rest of compiler doesn't know"! !

!Scanner methodsFor: 'multi-character scans' stamp: 'wod 1/10/98 00:43'!
xDoubleQuote
    "Collect a comment."
    "wod 1/10/98: Allow 'empty' comments by testing the first character
for $"" rather than blindly adding it to the comment being collected."
    | aStream stopChar |
    stopChar _ 30 asCharacter.
    aStream _ WriteStream on: (String new: 200).
    self step.
    [hereChar == $"]
        whileFalse:
            [(hereChar == stopChar and: [source atEnd])
                ifTrue: [^self offEnd: 'Unmatched comment quote'].
            aStream nextPut: self step.].
    self step.
    currentComment == nil
        ifTrue: [currentComment _ OrderedCollection with: aStream
contents]
        ifFalse: [currentComment add: aStream contents].
    self scanToken! !

!Scanner methodsFor: 'multi-character scans' stamp: 'di 4/22/2000 16:36'!
xLetter
	"Form a word or keyword."

	| type |
	buffer reset.
	[(type _ typeTable at: hereChar asciiValue) == #xLetter or: [type == #xDigit]]
		whileTrue:
			["open code step for speed"
			buffer nextPut: hereChar.
			hereChar _ aheadChar.
			source atEnd
				ifTrue: [aheadChar _ 30 asCharacter "doit"]
				ifFalse: [aheadChar _ source next]].
	(type == #colon or: [type == #xColon and: [aheadChar ~= $=]])
		ifTrue: 
			[buffer nextPut: self step.
			["Allow any number of embedded colons in literal symbols"
			(typeTable at: hereChar asciiValue) == #xColon]
				whileTrue: [buffer nextPut: self step].
			tokenType _ #keyword]
		ifFalse: 
			[tokenType _ #word].
	token _ buffer contents! !

!Scanner methodsFor: 'multi-character scans' stamp: 'di 10/10/1999 23:43'!
xLitQuote
	"Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'."

	| start |
	self step. "litQuote"
	self scanToken.
	tokenType = #leftParenthesis
		ifTrue: 
			[start _ mark.
			self scanToken; scanLitVec.
			tokenType == #doIt
				ifTrue: [mark _ start.
						self offEnd: 'Unmatched parenthesis']]
		ifFalse: 
			[(#(word keyword colon ) includes: tokenType) 
				ifTrue:
					[self scanLitWord]
				ifFalse:
					[(tokenType==#literal)
						ifTrue:
							[(token isMemberOf: Symbol)
								ifTrue: "##word"
									[token _ token "May want to move toward ANSI here"]]
						ifFalse:
							[tokenType==#string ifTrue: [token _ token asSymbol]]]].
	tokenType _ #literal

"	#(Pen)
	#Pen
	#'Pen'
	##Pen
	###Pen
"! !

!Scanner methodsFor: 'multi-character scans'!
xSingleQuote
	"String."

	self step.
	buffer reset.
	[hereChar = $' 
		and: [aheadChar = $' 
				ifTrue: [self step. false]
				ifFalse: [true]]]
		whileFalse: 
			[buffer nextPut: self step.
			(hereChar = 30 asCharacter and: [source atEnd])
				ifTrue: [^self offEnd: 'Unmatched string quote']].
	self step.
	token _ buffer contents.
	tokenType _ #string! !


!Scanner methodsFor: 'error handling'!
notify: string 
	"Refer to the comment in Object|notify:." 
	self error: string! !

!Scanner methodsFor: 'error handling'!
offEnd: aString 
	"Parser overrides this"

	^self notify: aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Scanner class
	instanceVariableNames: ''!

!Scanner class methodsFor: 'class initialization'!
initialize
	| newTable |
	newTable _ Array new: 256 withAll: #xBinary. "default"
	newTable atAll: #(9 10 12 13 32 ) put: #xDelimiter. "tab lf ff cr space"
	newTable atAll: ($0 asciiValue to: $9 asciiValue) put: #xDigit.
	newTable atAll: ($A asciiValue to: $Z asciiValue) put: #xLetter.
	newTable atAll: ($a asciiValue to: $z asciiValue) put: #xLetter.
	newTable at: 30 put: #doIt.
	newTable at: $" asciiValue put: #xDoubleQuote.
	newTable at: $# asciiValue put: #xLitQuote.
	newTable at: $$ asciiValue put: #xDollar.
	newTable at: $' asciiValue put: #xSingleQuote.
	newTable at: $: asciiValue put: #xColon.
	newTable at: $( asciiValue put: #leftParenthesis.
	newTable at: $) asciiValue put: #rightParenthesis.
	newTable at: $. asciiValue put: #period.
	newTable at: $; asciiValue put: #semicolon.
	newTable at: $[ asciiValue put: #leftBracket.
	newTable at: $] asciiValue put: #rightBracket.
	newTable at: ${ asciiValue put: #leftBrace.
	newTable at: $} asciiValue put: #rightBrace.
	newTable at: $^ asciiValue put: #upArrow.
	newTable at: $_ asciiValue put: #leftArrow.
	newTable at: $| asciiValue put: #verticalBar.
	TypeTable _ newTable "bon voyage!!"

	"Scanner initialize"! !


!Scanner class methodsFor: 'instance creation'!
new

	^super new initScanner! !


!Scanner class methodsFor: 'testing' stamp: 'bf 4/27/2000 12:56'!
isLiteralSymbol: aSymbol 
	"Test whether a symbol can be stored as # followed by its characters.  
	Symbols created internally with asSymbol may not have this property, 
	e.g. '3' asSymbol."
	| i ascii type |
	i _ aSymbol size.
	i = 0 ifTrue: [^ false].
	i = 1 ifTrue: [('$''"()#0123456789' includes: (aSymbol at: 1))
		ifTrue: [^ false] ifFalse: [^ true]].
	ascii _ (aSymbol at: 1) asciiValue.
	"TypeTable should have been origined at 0 rather than 1 ..."
	ascii = 0 ifTrue: [^ false].
	type _ TypeTable at: ascii.
	(type == #xColon or: [type == #verticalBar]) ifTrue: [^ i = 1].
	type == #xBinary ifTrue: 
			[[i > 1]
				whileTrue: 
					[ascii _ (aSymbol at: i) asciiValue.
					ascii = 0 ifTrue: [^ false].
					(TypeTable at: ascii) == #xBinary ifFalse: [^ false].
					i _ i - 1].
			^ true].
	type == #xLetter ifTrue: 
			[[i > 1]
				whileTrue: 
					[ascii _ (aSymbol at: i) asciiValue.
					ascii = 0 ifTrue: [^ false].
					type _ TypeTable at: ascii.
					(type == #xLetter or: [type == #xDigit or: [type == #xColon]])
						ifFalse: [^ false].
					i _ i - 1].
			^ true].
	^ false! !
Object subclass: #Scheduler
	instanceVariableNames: 'currentTime elapsedTime speed alarmList actionList animationList lastSystemTime isRunning schedulerProcess '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!Scheduler commentStamp: '<historical>' prior: 0!
The Scheduler manages time for a Wonderland. As part of this responsibility, it manages active alarms, actions, and animations in the Wonderland.!


!Scheduler methodsFor: 'initialize-release' stamp: 'jsp 3/23/1999 15:08'!
initialize

	"Initializes the scheduler: sets Wonderland time to 0, creates empty lists for actions, alarms, and animations"

	currentTime _ 0.
	speed _ 1.
	isRunning _ true.
	alarmList _ OrderedCollection new.
	actionList _ OrderedCollection new.
	animationList _ OrderedCollection new.

	lastSystemTime _ Time millisecondClockValue / 1000.0.

	
! !

!Scheduler methodsFor: 'initialize-release' stamp: 'jsp 3/30/1999 15:43'!
reset
	"Clears the animation, action, and alarm lists and resets the Wonderland time to 0"

	currentTime _ 0.
	speed _ 1.
	isRunning _ true.
	lastSystemTime _ (Time millisecondClockValue) / 1000.0.

	alarmList _ OrderedCollection new.
	actionList _ OrderedCollection new.
	animationList _ OrderedCollection new.! !


!Scheduler methodsFor: 'ticking' stamp: 'jsp 3/8/1999 11:47'!
getElapsedTime

	"Returns the time that elapsed in the last Scheduler tick"

	^ elapsedTime.
! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 3/10/1999 15:35'!
getFPS

	"Returns the instantaneous frames per second (1 / elapsedTime)"

	^ (1.0 / elapsedTime).
! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/1/1999 14:18'!
getTime

	"Returns the current scheduler time"

	^ currentTime.
! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/1/1999 14:25'!
incrementBy: amount
	"This method allows animations to be stepped through; the user pauses the Scheduler and then repeatedly issues incrementBy messages with the desired increment"

	currentTime _ currentTime + amount.
	lastSystemTime _ lastSystemTime + amount.
	
	self processActions.
	self processAlarms.
	self processAnimations.! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/8/1999 16:38'!
pause
	"Pause the scheduler. All alarms, actions, and animations pause and time stops passing in the Wonderland, but any active cameras continue to render."

	isRunning _ false.
! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/1/1999 16:33'!
processActions
	"This method executes every active action and removes any that done"

	actionList do: [:action | action execute.
							(action isDone) ifTrue: [self removeAction: action]
				].
! !

!Scheduler methodsFor: 'ticking' stamp: 'ar 11/6/2000 23:31'!
processAlarms
	"This method checks all the alarms and processes any that have gone off"
	alarmList do: [:alarm | 
		((alarm checkTime) < currentTime) ifTrue:[
			self removeAlarm: alarm.
			alarm execute]]! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/3/1999 14:23'!
processAnimations
	"This method processes any active Animations and removes any that are completed."

	animationList do: [:anim | anim update: currentTime.
							(anim isDone) ifTrue: [self removeAnimation: anim]
				].
! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/8/1999 16:38'!
resume
	"If the scheduler was paused, resume it."

	isRunning ifFalse: 	[ isRunning _ true.
						  lastSystemTime _ (Time millisecondClockValue) / 1000.0.
						].

! !

!Scheduler methodsFor: 'ticking' stamp: 'jsp 2/1/1999 14:34'!
setSpeed: newSpeed
	"This method sets the speed for the Scheduler. 1 is a 1:1 mapping with clock time, 2 is a 2:1 mapping, etc."

	(speed > 0) ifTrue: [speed _ newSpeed] ifFalse: [self error: 'Scheduler speed must be greater than 0.'].

! !

!Scheduler methodsFor: 'ticking' stamp: 'ar 9/1/2000 10:24'!
tick
	"Figure out how much time has elapsed since the last Scheduler tick and update all our actions, alarms, and animations"
	| deltaTime |
	isRunning ifTrue: [
		deltaTime _ (Time millisecondClockValue / 1000.0) - lastSystemTime.
		"See if the clock rolled over or the scheduler has been put to sleep for too long"
		(deltaTime < 0.0 or:[deltaTime > 2.0]) ifTrue:[
			"adjust for extra time"
			lastSystemTime _ (Time millisecondClockValue - 1) / 1000.0.
			deltaTime _ 1.0 / 1000.0].
		elapsedTime _ deltaTime * speed.
		currentTime _ currentTime + elapsedTime.
		lastSystemTime _ lastSystemTime + elapsedTime.
	
		self processAlarms.
		self processAnimations.
		self processActions.
	].
! !


!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:16'!
addAction: anAction
	"Add an action to the Scheduler's list of actions"

	actionList addLast: anAction.! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:16'!
addAlarm: anAlarm
	"Add an alarm to the Scheduler's list of alarms"

	alarmList addLast: anAlarm.
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:16'!
addAnimation: anAnimation
	"Add an animation to the Scheduler's list of animations"

	animationList addLast: anAnimation.
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:24'!
getActions
	"Returns a copy of the Scheduler's list of actions"

	^ actionList copy.
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:24'!
getAlarms
	"Returns a copy of the Scheduler's list of alarms"

	^ alarmList copy.
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:25'!
getAnimations
	"Returns a copy of the Scheduler's list of animations"

	^ animationList copy.
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:19'!
removeAction: anAction
	"Remove an action from the Scheduler's list of actions"

	actionList remove: anAction ifAbsent: [].
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:18'!
removeAlarm: anAlarm
	"Remove an alarm from the Scheduler's list of alarms"

	alarmList remove: anAlarm ifAbsent: [].
! !

!Scheduler methodsFor: 'lists maintenance' stamp: 'jsp 1/29/1999 14:20'!
removeAnimation: anAnimation
	"Remove an animation from the Scheduler's list of animations"

	animationList remove: anAnimation ifAbsent: [].
! !


!Scheduler methodsFor: 'animated object' stamp: 'jsp 3/9/1999 16:07'!
getActionsFor: anObject
	"Return the animations that list anObject as the object they're affecting"

	| aList |
	aList _ OrderedCollection new.

	actionList do: [:action | ((action getAffectedObject) = anObject)
								ifTrue: [ aList addLast: action ] ].

	^ aList.
! !

!Scheduler methodsFor: 'animated object' stamp: 'jsp 3/9/1999 16:05'!
getAnimationsFor: anObject
	"Return the animations that list anObject as the object they're affecting"

	| animList |
	animList _ OrderedCollection new.

	animationList do: [:anim | ((anim getAnimatedObject) = anObject)
								ifTrue: [ animList addLast: anim ] ].

	^ animList.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Scheduler class
	instanceVariableNames: ''!

!Scheduler class methodsFor: 'initialize' stamp: 'jsp 2/3/1999 17:31'!
new
	"Creates a new Scheduler and make sure it gets initialized."

	| newScheduler |
	newScheduler _ super new.
	newScheduler initialize.
	^ newScheduler.
! !
AbstractSound subclass: #ScorePlayer
	instanceVariableNames: 'score instruments overallVolume leftVols rightVols muted rate tempo secsPerTick done repeat ticksSinceStart ticksClockIncr trackEventIndex tempoMapIndex activeSounds activeMIDINotes midiPort midiPlayerProcess durationInTicks '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!ScorePlayer commentStamp: '<historical>' prior: 0!
This is a real-time player for MIDI scores (i.e., scores read from MIDI files). Score can be played using either the internal sound synthesis or an external MIDI synthesizer on platforms that support MIDI output.
!


!ScorePlayer methodsFor: 'initialization' stamp: 'di 6/15/1999 11:17'!
initialize

	super initialize.
	score _ MIDIScore new initialize.
	instruments _ Array new.
	overallVolume _ 0.5.
	leftVols _ Array new.
	rightVols _ Array new.
	muted _ Array new.
	rate _ 1.0.
	repeat _ false.
	durationInTicks _ 100.! !

!ScorePlayer methodsFor: 'initialization' stamp: 'di 6/15/1999 11:18'!
onScore: aMIDIScore

	| trackCount totalVol incr curr pan |
	score _ aMIDIScore.
	trackCount _ score tracks size.
	durationInTicks _ score durationInTicks.
	instruments _ (1 to: trackCount) collect: [:i | FMSound oboe1].
	leftVols _ Array new: trackCount.
	rightVols _ Array new: trackCount.
	muted  _ Array new: trackCount withAll: false.
	rate _ 1.0.
	repeat _ false.
	tempo _ 120.0.

	trackCount = 0 ifTrue: [^ self].
	1 to: trackCount do: [:i |
		leftVols at: i put: ScaleFactor // 4.
		rightVols at: i put: ScaleFactor // 4].

	"distribute inital panning of tracks left-to-right"
	totalVol _ 1.0.
	incr _ totalVol / (((trackCount // 2) + 1) * 2).
	curr _ 0.
	1 to: trackCount do: [:t |
		t even
			ifTrue: [pan _ curr]
			ifFalse: [
				curr _ curr + incr.
				pan _ totalVol - curr].
		self panForTrack: t put: pan].

! !

!ScorePlayer methodsFor: 'initialization' stamp: 'di 6/20/1999 00:46'!
updateDuration

	durationInTicks _ score durationInTicks.
! !


!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 19:07'!
doControl

	super doControl.
	1 to: activeSounds size do: [:i | (activeSounds at: i) first doControl].
	ticksSinceStart _ ticksSinceStart + ticksClockIncr.
	self processAllAtTick: ticksSinceStart asInteger.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 10/21/2000 13:47'!
isDone

	| track |
	activeSounds size > 0 ifTrue: [^ false].
	activeMIDINotes size > 0 ifTrue: [^ false].
	1 to: score tracks size do: [:i |
		track _ score tracks at: i.
		(trackEventIndex at: i) <= track size ifTrue: [^ false]].
	(trackEventIndex last) <= score ambientTrack size ifTrue: [^ false].
	^ true
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 8/5/1998 23:07'!
isPlaying
	^ SoundPlayer isPlaying: self! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 10/22/2000 17:19'!
jumpToTick: startTick

	| |
	self reset.
	self processTempoMapAtTick: startTick.
	self skipNoteEventsThruTick: startTick.
	self skipAmbientEventsThruTick: startTick.
	ticksSinceStart _ startTick.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 7/4/1998 08:21'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."

	| myLeftVol myRightVol someSoundIsDone pair snd trk left right |
	myLeftVol _ (leftVol * overallVolume) asInteger.
	myRightVol _ (rightVol * overallVolume) asInteger.
	someSoundIsDone _ false.
	1 to: activeSounds size do: [:i |
		pair _ activeSounds at: i.
		snd _ pair at: 1.
		trk _ pair at: 2.
		left _ (myLeftVol * (leftVols at: trk)) // ScaleFactor.
		right _ (myRightVol * (rightVols at: trk)) // ScaleFactor.
		snd samplesRemaining > 0
			ifTrue: [
				snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
			ifFalse: [someSoundIsDone _ true]].

	someSoundIsDone ifTrue: [
		activeSounds _ activeSounds select: [:p | p first samplesRemaining > 0]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 19:06'!
processAllAtTick: scoreTick

	self processTempoMapAtTick: scoreTick.
	midiPort
		ifNil: [self processNoteEventsAtTick: scoreTick]
		ifNotNil: [self processMIDIEventsAtTick: scoreTick].
	self processAmbientEventsAtTick: scoreTick.
	self isDone ifTrue: [
		repeat
			ifTrue: [self reset]
			ifFalse: [done _ true]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 17:50'!
processAmbientEventsAtTick: scoreTick
	"Process ambient events through the given tick."

	| i evt |
	i _ trackEventIndex at: trackEventIndex size.
	[evt _ score ambientEventAfter: i ticks: scoreTick.
	 evt ~~ nil] whileTrue: [
		i _ i + 1.
		evt occurAtTime: scoreTick inScorePlayer: self atIndex: i inEventTrack: score ambientTrack secsPerTick: secsPerTick].
	trackEventIndex at: trackEventIndex size put: i.
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 17:49'!
processNoteEventsAtTick: scoreTick
	"Process note events through the given score tick using internal Squeak sound synthesis."

	| instr j evt snd |
	1 to: score tracks size do: [:i |
		instr _ instruments at: i.
		j _ trackEventIndex at: i.
		[evt _ score eventForTrack: i after: j ticks: scoreTick.
		 evt ~~ nil] whileTrue: [
			(evt isNoteEvent and: [(muted at: i) not]) ifTrue: [
				snd _ instr
					soundForMidiKey: evt midiKey
					dur: secsPerTick * evt duration
					loudness: evt velocity asFloat / 127.0.
				activeSounds add: (Array with: snd with: i)].
			j _ j + 1.
			trackEventIndex at: i put: j]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 21:04'!
processTempoMapAtTick: scoreTick
	"Process tempo changes through the given score tick."

	| map tempoChanged |
	map _ score tempoMap.
	map ifNil: [^ self].
	tempoChanged _ false.
	[(tempoMapIndex <= map size) and:
	 [(map at: tempoMapIndex) time <= scoreTick]] whileTrue: [
		tempoChanged _ true.
		tempoMapIndex _ tempoMapIndex + 1].

	tempoChanged ifTrue: [
		tempo _ (120.0 * (500000.0 / (map at: tempoMapIndex - 1) tempo)) roundTo: 0.01.
		self tempoOrRateChanged].

! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 16:58'!
reset

	super reset.
	tempo _ 120.0.
	self tempoOrRateChanged.
	done _ false.
	ticksSinceStart _ 0.
	"one index for each sound track, plus one for the ambient track..."
	trackEventIndex _ Array new: score tracks size+1 withAll: 1.
	tempoMapIndex _ 1.
	activeSounds _ OrderedCollection new.
	activeMIDINotes _ OrderedCollection new.
	score resetFrom: self.
	overallVolume ifNil: [overallVolume _ 0.5].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 12/30/97 17:38'!
samplesRemaining

	done
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'di 10/22/2000 17:19'!
skipAmbientEventsThruTick: startTick
	"Skip ambient events through the given score tick."

	score ambientTrack withIndexDo:
		[:evt :i | evt time > startTick ifTrue:
			[^ trackEventIndex at: trackEventIndex size put: i]].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:56'!
skipNoteEventsThruTick: startTick
	"Skip note events through the given score tick using internal Squeak sound synthesis."

	| j evt |
	1 to: score tracks size do: [:i |
		j _ trackEventIndex at: i.
		[evt _ score eventForTrack: i after: j ticks: startTick.
		 evt == nil] whileFalse: [
			evt isNoteEvent
				ifTrue: [
					(((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [
						self startNote: evt forStartTick: startTick trackIndex: i]]
				ifFalse: [
					midiPort == nil ifFalse: [evt outputOnMidiPort: midiPort]].
			j _ j + 1].
		trackEventIndex at: i put: j].
! !

!ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:30'!
startNote: noteEvent forStartTick: startTick trackIndex: trackIndex
	"Prepare a note to begin playing at the given tick. Used to start playing at an arbitrary point in the score. Handle both MIDI and built-in synthesis cases."

	| snd |
	midiPort
		ifNil: [
			snd _ (instruments at: trackIndex)
				soundForMidiKey: noteEvent midiKey
				dur: secsPerTick * (noteEvent endTime - startTick)
				loudness: noteEvent velocity asFloat / 127.0.
			activeSounds add: (Array with: snd with: trackIndex)]
		ifNotNil: [
			noteEvent startNoteOnMidiPort: midiPort.
			activeMIDINotes add: (Array with: noteEvent with: trackIndex)].
! !


!ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 17:13'!
closeMIDIPort
	"Stop using MIDI for output. Music will be played using the built-in sound synthesis."

	self pause.
	midiPort _ nil.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/24/1998 22:33'!
midiPlayLoop

	| mSecsPerStep tStart mSecs |
	mSecsPerStep _ 5.
	[done] whileFalse: [
		tStart _ Time millisecondClockValue.
		self processAllAtTick: ticksSinceStart asInteger.
		(Delay forMilliseconds: mSecsPerStep) wait.
		mSecs _ Time millisecondClockValue - tStart.
		mSecs < 0 ifTrue: [mSecs _ mSecsPerStep].  "clock wrap"
		ticksSinceStart _ ticksSinceStart + (mSecs asFloat / (1000.0 * secsPerTick))].
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 15:56'!
openMIDIPort: portNum
	"Open the given MIDI port. Music will be played as MIDI commands to the given MIDI port."

	midiPort _ SimpleMIDIPort openOnPortNumber: portNum.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 18:31'!
processMIDIEventsAtTick: scoreTick
	"Process note events through the given score tick using MIDI."

	| j evt |
	1 to: score tracks size do: [:i |
		j _ trackEventIndex at: i.
		[evt _ score eventForTrack: i after: j ticks: scoreTick.
		 evt ~~ nil] whileTrue: [
			evt isNoteEvent
				ifTrue: [
					(muted at: i) ifFalse: [
						evt startNoteOnMidiPort: midiPort.
						activeMIDINotes add: (Array with: evt with: i)]]
				ifFalse: [evt outputOnMidiPort: midiPort].
			j _ j + 1.
			trackEventIndex at: i put: j]].
	self turnOffActiveMIDINotesAt: scoreTick.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 20:45'!
startMIDIPlaying
	"Start up a process to play this score via MIDI."

	midiPort ensureOpen.
	midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
	midiPlayerProcess _ [self midiPlayLoop] newProcess.
	midiPlayerProcess
		priority: Processor userInterruptPriority;
		resume.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 20:44'!
stopMIDIPlaying
	"Terminate the MIDI player process and turn off any active notes."

	midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
	midiPlayerProcess _ nil.
	activeMIDINotes do: [:pair | pair first endNoteOnMidiPort: midiPort].
	activeMIDINotes _ activeMIDINotes species new.
! !

!ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 17:48'!
turnOffActiveMIDINotesAt: scoreTick
	"Turn off any active MIDI notes that should be turned off at the given score tick."

	| evt someNoteEnded |
	midiPort ifNil: [^ self].
	someNoteEnded _ false. 
	activeMIDINotes do: [:pair |
		evt _ pair first.
		evt endTime <= scoreTick ifTrue: [
			evt endNoteOnMidiPort: midiPort.
			someNoteEnded _ true]].

	someNoteEnded ifTrue: [
		activeMIDINotes _ activeMIDINotes select: [:p | p first endTime > scoreTick]].
! !


!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/15/1999 11:37'!
durationInTicks

	durationInTicks == nil ifTrue: [^ 1000].
	^ durationInTicks! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/3/98 12:14'!
infoForTrack: i
	"Return the info string for the given track."
	"Note: MIDI files follow varying conventions on their use of comment strings. Often, the first string in the track suggests the role of that track in the score, such as 'flute 1' or 'soprano'."

	^ score trackInfo at: i
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:37'!
instrumentForTrack: trackIndex

	^ instruments at: trackIndex
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 20:33'!
instrumentForTrack: trackIndex put: aSoundProto

	trackIndex > instruments size ifTrue: [^ self].
	instruments at: trackIndex put: aSoundProto.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:58'!
midiPort

	^ midiPort
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 5/30/1999 12:46'!
millisecondsSinceStart
	"Answer the approximate number of milliseconds of real time since the beginning of the score. Since this calculation uses the current tempo, which can change throughout the piece, it is safer to use ticksSinceStart for synchronization."

	^ (secsPerTick * ticksSinceStart * 1000) asInteger
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/29/98 18:33'!
mutedForTrack: trackIndex

	^ muted at: trackIndex
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 20:33'!
mutedForTrack: trackIndex put: aBoolean

	trackIndex > muted size ifTrue: [^ self].
	muted at: trackIndex put: aBoolean.
	aBoolean ifFalse: [^ self].

	"silence any currently sounding notes for this track"
	activeSounds do: [:pair |
		pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: []]].
	midiPort ifNotNil: [
		activeMIDINotes do: [:pair |
			pair last = trackIndex ifTrue: [
				pair first endNoteOnMidiPort: midiPort.
				activeMIDINotes remove: pair ifAbsent: []]]].
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 5/30/1999 17:16'!
mutedState

	^ muted
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:17'!
overallVolume

	^ overallVolume
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:18'!
overallVolume: aNumber
	"Set the overally playback volume to a value between 0.0 (off) and 1.0 (full blast)."

	overallVolume _ (aNumber asFloat min: 1.0) max: 0.0.

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:32'!
panForTrack: i

	| left right fullVol pan |
	left _ leftVols at: i.
	right _ rightVols at: i.
	left = right ifTrue: [^ 0.5].  "centered"
	fullVol _ left max: right.
	left < fullVol
		ifTrue: [pan _ left asFloat / (2.0 * fullVol)]
		ifFalse: [pan _ 1.0 - (right asFloat / (2.0 * fullVol))].
	^ pan roundTo: 0.001

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/2/1999 13:33'!
panForTrack: trackIndex put: aNumber
	"Set the left-right pan for this track to a value in the range [0.0..1.0], where 0.0 means full-left."

	| fullVol pan left right |
	trackIndex > leftVols size ifTrue: [^ self].
	fullVol _ (leftVols at: trackIndex) max: (rightVols at: trackIndex).
	pan _ (aNumber asFloat min: 1.0) max: 0.0.
	pan <= 0.5
		ifTrue: [  "attenuate right channel"
			left _ fullVol.
			right _ 2.0 * pan * fullVol]
		ifFalse: [  "attenuate left channel"
			left _ 2.0 * (1.0 - pan) * fullVol.
			right _ fullVol].
	rightVols at: trackIndex put: right asInteger.
	leftVols at: trackIndex put: left asInteger.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/20/1999 00:42'!
positionInScore

	^ self ticksSinceStart asFloat / (self durationInTicks max: 1)! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 6/16/1999 22:50'!
positionInScore: pos

	self isPlaying ifTrue: [^ self "ignore rude intrusion"].
	ticksSinceStart _ pos * durationInTicks.
	done _ false.

! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'!
rate

	^ rate
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/4/98 10:07'!
rate: aNumber
	"Set the playback rate. For example, a rate of 2.0 will playback at twice normal speed."

	rate _ aNumber asFloat.
	self tempoOrRateChanged.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/4/98 09:30'!
repeat
	"Return true if this player will repeat when it gets to the end of the score, false otherwise."

	^ repeat
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 3/4/98 09:31'!
repeat: aBoolean
	"Turn repeat mode on or off."

	repeat _ aBoolean.
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:33'!
score

	^ score
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 10/19/2000 21:12'!
secsPerTick

	^ secsPerTick! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/1/1999 14:33'!
settingsString

	| s |
	s _ WriteStream on: (String new: 1000).
	s nextPutAll: 'player'; cr.
	s tab; nextPutAll: 'rate: ', self rate printString, ';'; cr.
	s tab; nextPutAll: 'overallVolume: ', self overallVolume printString, ';'; cr.
	1 to: self trackCount do: [:t |
		s tab; nextPutAll: 'instrumentForTrack: ', t printString,
			' put: (AbstractSound soundNamed: #default);'; cr.
		s tab; nextPutAll: 'mutedForTrack: ', t printString,
			' put: ', (self mutedForTrack: t) printString, ';'; cr.
		s tab; nextPutAll: 'volumeForTrack: ', t printString,
			' put: ', (self volumeForTrack: t) printString, ';'; cr.
		s tab; nextPutAll: 'panForTrack: ', t printString,
			' put: ', (self panForTrack: t) printString, ';'; cr].
	s tab; nextPutAll: 'repeat: ', self repeat printString, '.'; cr.
	^ s contents
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/4/98 10:10'!
tempo
	"Return the current tempo in beats (quarter notes) per minute. The tempo at any given moment is defined by the score and cannot be changed by the client. To change the playback speed, the client may change the rate parameter."

	^ tempo
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/22/1998 09:32'!
ticksForMSecs: mSecs

	^ (mSecs asFloat / (1000.0 * secsPerTick)) rounded
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/10/1998 20:48'!
ticksSinceStart
	"Answer the number of score ticks that have elapsed since this piece started playing. The duration of a tick is determined by the MIDI score."

	^ ticksSinceStart
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'di 6/19/1999 10:45'!
ticksSinceStart: newTicks
	"Adjust ticks to folow, eg, piano roll autoscrolling"

	self isPlaying ifFalse: [ticksSinceStart _ newTicks]
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 1/3/98 09:35'!
trackCount

	^ score tracks size
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:16'!
volumeForTrack: i

	| vol |
	vol _ (leftVols at: i) max: (rightVols at: i).
	^ (vol asFloat / ScaleFactor) roundTo: 0.0001
! !

!ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/2/1999 13:34'!
volumeForTrack: trackIndex put: aNumber

	| newVol oldLeft oldRight oldFullVol left right |
	trackIndex > leftVols size ifTrue: [^ self].
	newVol _ ((aNumber asFloat max: 0.0) min: 1.0) * ScaleFactor.
	oldLeft _ leftVols at: trackIndex.
	oldRight _ rightVols at: trackIndex.
	oldFullVol _ oldLeft max: oldRight.
	oldFullVol = 0 ifTrue: [oldFullVol _ 1.0].
	oldLeft < oldFullVol
		ifTrue: [
			left _ newVol * oldLeft / oldFullVol.
			right _ newVol]
		ifFalse: [
			left _ newVol.
			right _ newVol * oldRight / oldFullVol].
	leftVols at: trackIndex put: left asInteger.
	rightVols at: trackIndex put: right asInteger.
! !


!ScorePlayer methodsFor: 'operating' stamp: 'jm 1/30/98 14:03'!
disableReverb: aBoolean

	aBoolean
		ifTrue: [SoundPlayer stopReverb]
		ifFalse: [SoundPlayer startReverb].
! !

!ScorePlayer methodsFor: 'operating' stamp: 'jm 9/10/1998 20:46'!
pause
	"Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."

	score pauseFrom: self.
	super pause.
	activeSounds _ activeSounds species new.
	midiPort ifNotNil: [self stopMIDIPlaying].
! !

!ScorePlayer methodsFor: 'operating' stamp: 'jm 6/16/1999 22:45'!
resumePlaying
	"Resume playing. Start over if done."

	done ifTrue: [self reset].
	self jumpToTick: ticksSinceStart.  "Play up to here in case we got scrolled to new position."
	score resumeFrom: self.
	midiPort
		ifNil: [super resumePlaying]  "let the sound player drive sound generation" 
		ifNotNil: [self startMIDIPlaying].  "start a process to drive MIDI output"
! !

!ScorePlayer methodsFor: 'operating' stamp: 'jm 9/10/1998 20:56'!
tempoOrRateChanged
	"This method should be called after changing the tempo or rate."

	secsPerTick _ 60.0 / (tempo * rate * score ticksPerQuarterNote).
	ticksClockIncr _ (1.0 / self controlRate) / secsPerTick.
! !


!ScorePlayer methodsFor: 'copying' stamp: 'jm 12/15/97 19:13'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!ScorePlayer methodsFor: 'copying' stamp: 'jm 1/29/98 18:32'!
copySounds
	"Private!! Support for copying."

	instruments _ instruments copy.
	leftVols _ leftVols copy.
	rightVols _ rightVols copy.
	muted _ muted copy.
	self reset.
! !


!ScorePlayer methodsFor: 'volume' stamp: 'mir 11/10/2000 08:39'!
adjustVolumeTo: vol overMSecs: mSecs
	| normalizedVolume incr block |
	normalizedVolume _ (vol asFloat min: 1.0) max: 0.0.
	incr _ (self overallVolume - normalizedVolume) / mSecs * 50.0.
	block _ normalizedVolume > 0.0
		ifTrue: [
			[[(normalizedVolume - self overallVolume) abs > 0.01] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]]]
		ifFalse: [
			[[self overallVolume > 0.0] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]. self pause]].
	block fixTemps; fork
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScorePlayer class
	instanceVariableNames: ''!

!ScorePlayer class methodsFor: 'instance creation' stamp: 'jm 1/29/98 18:18'!
onScore: aMIDIScore

	^ self new onScore: aMIDIScore
! !
AlignmentMorph subclass: #ScorePlayerMorph
	instanceVariableNames: 'scorePlayer trackInstNames instrumentSelector scrollSlider '
	classVariableNames: 'LastMIDIPort '
	poolDictionaries: ''
	category: 'Sound-Scores'!
!ScorePlayerMorph commentStamp: '<historical>' prior: 0!
A ScorePlayerMorph mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer.

It provides control over volume, tempo, instrumentation, and location in the score.!


!ScorePlayerMorph methodsFor: 'initialization' stamp: 'jm 10/12/1998 17:14'!
closeMIDIPort

	scorePlayer closeMIDIPort.
	LastMIDIPort _ nil.
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'ar 11/15/2000 15:16'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self layoutInset: 3.
	color _ Color veryLightGray.
	self borderWidth: 2.
	self onScorePlayer: (ScorePlayer new initialize) title: ' '.
	self extent: 20@20.
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:43'!
onScorePlayer: aScorePlayer title: scoreName
	| divider col r |
	scorePlayer _ aScorePlayer.
	scorePlayer ifNotNil:
		[scorePlayer  reset.
		instrumentSelector _ Array new: scorePlayer score tracks size].
	divider _ AlignmentMorph new
		extent: 10@1;
		borderWidth: 1;
		layoutInset: 0;
		borderColor: #raised;
		color: color;
		hResizing: #spaceFill;
		vResizing: #rigid.

	self removeAllMorphs.
	self addMorphBack: self makeControls.
	scorePlayer ifNil: [^ self].

	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: self rateControl;
		addMorphBack: (Morph newBounds: (0@0 extent: 20@0) color: Color transparent);
		addMorphBack: self volumeControl.
	self addMorphBack: r.
	self addMorphBack: self scrollControl.

	col _ AlignmentMorph newColumn color: color; layoutInset: 0.
	self addMorphBack: col.
	1 to: scorePlayer trackCount do: [:trackIndex |
		col addMorphBack: divider fullCopy.
		col addMorphBack: (self trackControlsFor: trackIndex)].

	LastMIDIPort ifNotNil: [
		"use the most recently set MIDI port"
		scorePlayer openMIDIPort: LastMIDIPort].
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'di 10/14/1998 15:46'!
openMIDIFile
	"Open a MIDI score and re-init controls..."
	| score fileName f player |
	fileName _ Utilities chooseFileWithSuffixFromList: #('.mid' '.midi')
					withCaption: 'Choose a MIDI file to open'.
	fileName ifNil: [^ self].
	f _ FileStream readOnlyFileNamed: fileName.
	score _ (MIDIFileReader new readMIDIFrom: f binary) asScore.
	f close.
	player _ ScorePlayer onScore: score.
	self onScorePlayer: player title: fileName! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'jm 10/12/1998 18:00'!
openMIDIPort

	| portNum |
	portNum _ SimpleMIDIPort outputPortNumFromUser.
	portNum ifNil: [^ self].
	scorePlayer openMIDIPort: portNum.
	LastMIDIPort _ portNum.
! !

!ScorePlayerMorph methodsFor: 'initialization' stamp: 'di 10/22/2000 23:42'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!ScorePlayerMorph methodsFor: 'accessing' stamp: 'jm 6/1/1998 09:10'!
scorePlayer

	^ scorePlayer
! !


!ScorePlayerMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 20:43'!
makeControls

	| b r reverbSwitch repeatSwitch |
	b _ SimpleButtonMorph new
		target: self;
		borderColor: #raised;
		borderWidth: 2;
		color: color.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (b fullCopy label: '<>'; actWhen: #buttonDown;
														actionSelector: #invokeMenu).
	r addMorphBack: (b fullCopy label: 'Piano Roll';		actionSelector: #makePianoRoll).
	r addMorphBack: (b fullCopy label: 'Rewind';		actionSelector: #rewind).
	b target: scorePlayer.
	r addMorphBack: (b fullCopy label: 'Play';			actionSelector: #resumePlaying).
	r addMorphBack: (b fullCopy label: 'Pause';			actionSelector: #pause).
	reverbSwitch _ SimpleSwitchMorph new
		offColor: color;
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		borderWidth: 2;
		label: 'Reverb Disable';
		actionSelector: #disableReverb:;
		target: scorePlayer;
		setSwitchState: SoundPlayer isReverbOn not.
	r addMorphBack: reverbSwitch.
	scorePlayer ifNotNil:
		[repeatSwitch _ SimpleSwitchMorph new
			offColor: color;
			onColor: (Color r: 1.0 g: 0.6 b: 0.6);
			borderWidth: 2;
			label: 'Repeat';
			actionSelector: #repeat:;
			target: scorePlayer;
			setSwitchState: scorePlayer repeat.
		r addMorphBack: repeatSwitch].
	b target: self.
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 9/28/1998 23:05'!
makeMIDIController: evt

	self world activeHand attachMorph:
		(MIDIControllerMorph new midiPort: scorePlayer midiPort).
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'panda 4/25/2000 15:42'!
makePianoRoll
	"Create a piano roll viewer for this score player."

	| pianoRoll hand |
	pianoRoll _ PianoRollScoreMorph new on: scorePlayer.
	hand _ self world activeHand.
	hand ifNil: [self world addMorph: pianoRoll]
		ifNotNil: [hand attachMorph: pianoRoll.
				hand lastEvent shiftPressed ifTrue:
					["Special case for NOBM demo"
					pianoRoll contractTime; contractTime; enableDragNDrop]].
	pianoRoll startStepping.
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 21:23'!
makeRow

	^ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 21:23'!
panAndVolControlsFor: trackIndex

	| volSlider panSlider c r middleLine pianoRollColor |
	pianoRollColor _ (Color wheel: scorePlayer score tracks size) at: trackIndex.
	volSlider _ SimpleSliderMorph new
		color: color;
		sliderColor: pianoRollColor;
		extent: 101@2;
		target: scorePlayer;
		arguments: (Array with: trackIndex);
		actionSelector: #volumeForTrack:put:;
		minVal: 0.0;
		maxVal: 1.0;
		adjustToValue: (scorePlayer volumeForTrack: trackIndex).
	panSlider _ volSlider fullCopy
		actionSelector: #panForTrack:put:;
		minVal: 0.0;
		maxVal: 1.0;		
		adjustToValue: (scorePlayer panForTrack: trackIndex).
	c _ AlignmentMorph newColumn
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #topCenter;
		hResizing: #spaceFill;
		vResizing: #shrinkWrap.
	middleLine _ Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(panSlider height - 4);
		position: panSlider center x@(panSlider top + 2).
	panSlider addMorphBack: middleLine.
	r _ self makeRow.
	r addMorphBack: (StringMorph contents: '0').
	r addMorphBack: volSlider.
	r addMorphBack: (StringMorph contents: '10').
	c addMorphBack: r.
	r _ self makeRow.
	r addMorphBack: (StringMorph contents: 'L').
	r addMorphBack: panSlider.
	r addMorphBack: (StringMorph contents: 'R').
	c addMorphBack: r.
	^ c
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'!
rateControl

	| rateSlider middleLine r |
	rateSlider _ SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 180@2;
		target: self;
		actionSelector: #setLogRate:;
		minVal: -1.0;
		maxVal: 1.0;
		adjustToValue: 0.0.
	middleLine _ Morph new  "center indicator for pan slider"
		color: (Color r: 0.4 g: 0.4 b: 0.4);
		extent: 1@(rateSlider height - 4);
		position: rateSlider center x@(rateSlider top + 2).
	rateSlider addMorphBack: middleLine.
	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'slow ').
	r addMorphBack: rateSlider.
	r addMorphBack: (StringMorph contents: ' fast').
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'!
scrollControl

	| r |
	scrollSlider _ SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 360@2;
		target: scorePlayer;
		actionSelector: #positionInScore:;
		adjustToValue: scorePlayer positionInScore.
	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'start ').
	r addMorphBack: scrollSlider.
	r addMorphBack: (StringMorph contents: ' end').
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'RAA 12/13/2000 16:15'!
showResumeButtonInTheWorld

	| w |

	WorldState addDeferredUIMessage: [
		w _ self world ifNil: [^self].
		w addMorphFront: (self standaloneResumeButton position: (w right - 100) @ (w top + 10)).
		scorePlayer pause.
	]
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'RAA 12/13/2000 15:35'!
standaloneResumeButton

	| r |

	r _ AlignmentMorph newRow.
	r color: Color red; borderWidth: 0; layoutInset: 6; useRoundedCorners.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (
		SimpleButtonMorph new
			target: [
				scorePlayer resumePlaying.
				r delete
			];
			borderColor: #raised;
			borderWidth: 2;
			color: Color green;
			label: 'Continue';
			actionSelector: #value
	).
	r setBalloonText: 'Continue playing a paused presentation'.
	^r


! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 1/30/98 14:52'!
trackControlsFor: trackIndex

	| r |
	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	r addMorphBack: (self trackNumAndMuteButtonFor: trackIndex).
	r addMorphBack: (Morph new extent: 10@5; color: color).  "spacer"
	r addMorphBack: (self panAndVolControlsFor: trackIndex).
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 4/20/1999 10:59'!
trackNumAndMuteButtonFor: trackIndex

	| muteButton instSelector pianoRollColor r |
	muteButton _ SimpleSwitchMorph new
		onColor: (Color r: 1.0 g: 0.6 b: 0.6);
		offColor: color;
		color: color;
		label: 'Mute';
		target: scorePlayer;
		actionSelector: #mutedForTrack:put:;
		arguments: (Array with: trackIndex).
	instSelector _ PopUpChoiceMorph new
		extent: 95@14;
		contentsClipped: 'oboe1';
		target: self;
		actionSelector: #atTrack:from:selectInstrument:;
		getItemsSelector: #instrumentChoicesForTrack:;
		getItemsArgs: (Array with: trackIndex).
	instSelector arguments:
		(Array with: trackIndex with: instSelector).
	instrumentSelector at: trackIndex put: instSelector.

	"select track color using same color list as PianoRollScoreMorph"
	pianoRollColor _ (Color wheel: scorePlayer score tracks size) at: trackIndex.

	r _ self makeRow
		hResizing: #rigid;
		vResizing: #spaceFill;
		extent: 70@10.
	r addMorphBack:
		((StringMorph
			contents: trackIndex printString
			font: (TextStyle default fontOfSize: 24)) color: pianoRollColor).
	trackIndex < 10
		ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)]  "spacer"
		ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)].  "spacer"
	r addMorphBack:
		(StringMorph new
			extent: 140@14;
			contentsClipped: (scorePlayer infoForTrack: trackIndex)).
	r addMorphBack: (Morph new color: color; extent: 8@8).  "spacer"
	r addMorphBack: instSelector.
	r addMorphBack: (AlignmentMorph newRow color: color).  "spacer"
	r addMorphBack: muteButton.
	^ r
! !

!ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'!
volumeControl

	| volumeSlider r |
	volumeSlider _ SimpleSliderMorph new
		color: color;
		sliderColor: Color gray;
		extent: 80@2;
		target: scorePlayer;
		actionSelector: #overallVolume:;
		adjustToValue: scorePlayer overallVolume.
	r _ self makeRow
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: 'soft  ').
	r addMorphBack: volumeSlider.
	r addMorphBack: (StringMorph contents: ' loud').
	^ r
! !


!ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 10/14/1998 15:53'!
atTrack: trackIndex from: aPopUpChoice selectInstrument: selection

	| oldSnd name snd |
	oldSnd _ scorePlayer instrumentForTrack: trackIndex.
	(selection beginsWith: 'edit ') ifTrue: [
		name _ selection copyFrom: 6 to: selection size.
		aPopUpChoice contentsClipped: name.
		(oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) ifTrue: [
			EnvelopeEditorMorph openOn: oldSnd title: name].
		(oldSnd isKindOf: SampledInstrument) ifTrue: [
			EnvelopeEditorMorph openOn: oldSnd allNotes first title: name].
		^ self].

	snd _ nil.
	1 to: instrumentSelector size do: [:i |
		((trackIndex ~= i) and:
		 [selection = (instrumentSelector at: i) contents])
			ifTrue: [snd _ scorePlayer instrumentForTrack: i]].  "use existing instrument prototype"

	snd ifNil: [
		selection = 'clink'
			ifTrue: [
				snd _ (SampledSound
					samples: SampledSound coffeeCupClink
					samplingRate: 11025) copy]
			ifFalse: [snd _ (AbstractSound soundNamed: selection) copy]].

	scorePlayer instrumentForTrack: trackIndex put: snd.
	(instrumentSelector at: trackIndex) contentsClipped: selection.
! !

!ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 10/12/1998 17:18'!
rewind

	scorePlayer pause; reset.
! !

!ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 1/30/98 15:23'!
setLogRate: logOfRate

	scorePlayer rate: (3.5 raisedTo: logOfRate).
! !


!ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 9/12/1998 22:14'!
instrumentChoicesForTrack: trackIndex
	| names inst |

	names _ AbstractSound soundNames asOrderedCollection.
	names _ names collect: [:n |
		inst _ AbstractSound soundNamed: n.
		(inst isKindOf: UnloadedSound)
			ifTrue: [n, '(out)']
			ifFalse: [n]].
	names add: 'clink'.
	names add: 'edit ', (instrumentSelector at: trackIndex) contents.
	^ names asArray
! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'RAA 12/13/2000 16:24'!
invokeMenu
	"Invoke a menu of additonal functions for this WaveEditor."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'reload instruments' target: AbstractSound selector: #updateScorePlayers.
	aMenu add: 'open a MIDI file' action: #openMIDIFile.
	scorePlayer midiPort
		ifNil: [
			aMenu add: 'play via MIDI' action: #openMIDIPort]
		ifNotNil: [
			aMenu add: 'play via built in synth' action: #closeMIDIPort.
			aMenu add: 'new MIDI controller' action: #makeMIDIController:].
	aMenu addLine.
	aMenu add: 'make a pause marker' action: #makeAPauseEvent:.

	aMenu popUpInWorld: self world.! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'RAA 12/13/2000 15:01'!
makeAPauseEvent: evt

	| newWidget |

	newWidget _ AlignmentMorph newRow.
	newWidget 
		color: Color orange; 
		borderWidth: 0; 
		layoutInset: 0;
		hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap; 
		extent: 5@5;
		addMorph: (StringMorph contents: '[pause]') lock;
		addMouseUpActionWith: (
			MessageSend receiver: self selector: #showResumeButtonInTheWorld
		).

	evt hand attachMorph: newWidget.! !

!ScorePlayerMorph methodsFor: 'menu' stamp: 'di 11/7/2000 12:42'!
updateInstrumentsFromLibraryExcept: soundsBeingEdited
	"The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype."

	"soundsBeingEdited is a collection of sounds being edited (by an EnvelopeEditor).  If any of my instruments share one of these, then they will be left alone so as not to disturb that dynamic linkage."

	| unloadPostfix myInstruments name displaysAsUnloaded isUnloaded |
	unloadPostfix _ '(out)'.
	myInstruments _ Dictionary new.
	1 to: instrumentSelector size do: [:i |
		name _ (instrumentSelector at: i) contents.
		displaysAsUnloaded _ name endsWith: unloadPostfix.
		displaysAsUnloaded ifTrue: [
			name _ name copyFrom: 1 to: name size - unloadPostfix size].
		(myInstruments includesKey: name) ifFalse: [
			myInstruments at: name put:
				(name = 'clink'
					ifTrue: [
						(SampledSound
							samples: SampledSound coffeeCupClink
							samplingRate: 11025) copy]
					ifFalse: [
						(AbstractSound
							soundNamed: name
							ifAbsent: [
								(instrumentSelector at: i) contentsClipped: 'default'.
								FMSound default]) copy])].
		(soundsBeingEdited includes: (scorePlayer instrumentForTrack: i)) ifFalse:
			["Do not update any instrument that is currently being edited"
			scorePlayer instrumentForTrack: i put: (myInstruments at: name)].

		"update loaded/unloaded status in instrumentSelector if necessary"
		isUnloaded _ (myInstruments at: name) isKindOf: UnloadedSound.
		(displaysAsUnloaded and: [isUnloaded not])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name].
		(displaysAsUnloaded not and: [isUnloaded])
			ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]].
! !


!ScorePlayerMorph methodsFor: 'stepping' stamp: 'di 6/15/1999 11:48'!
step

	scrollSlider adjustToValue: scorePlayer positionInScore.

! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScorePlayerMorph class
	instanceVariableNames: ''!

!ScorePlayerMorph class methodsFor: 'as yet unclassified' stamp: 'jm 3/3/98 11:48'!
onMIDIFileNamed: fileName
	"Return a ScorePlayerMorph on the score from the MIDI file of the given name."

	| score player |
	score _ MIDIFileReader scoreFromFileNamed: fileName	.
	player _ ScorePlayer onScore: score.
	^ self new onScorePlayer: player title: fileName
! !

!ScorePlayerMorph class methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 16:29'!
openOn: aScore title: aString

	| player |
	player _ ScorePlayer onScore: aScore.
	(self new onScorePlayer: player title: aString) openInWorld.
! !
Controller subclass: #ScreenController
	instanceVariableNames: ''
	classVariableNames: 'LastScreenModeSelected '
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!ScreenController commentStamp: '<historical>' prior: 0!
I am the controller for the parts of the display screen that have no view on them. I only provide a standard yellow button menu. I view (a FormView of) an infinite gray form.  (ScheduledControllers screenController) is the way to find me.!


!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:21'!
controlActivity
	"Any button opens the screen's menu.
	If the shift key is down, do find window."

	sensor leftShiftDown ifTrue: [^ self findWindow].
	(self projectScreenMenu invokeOn: self) ifNil: [super controlActivity]! !

!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:06'!
isControlActive
	^ self isControlWanted! !

!ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:05'!
isControlWanted
	^ self viewHasCursor and: [sensor anyButtonPressed]! !


!ScreenController methodsFor: 'menu messages' stamp: 'sw 2/15/1999 16:18'!
aboutThisSystem 
	Smalltalk aboutThisSystem! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 10/13/1998 16:03'!
absorbUpdatesFromServer 
	Utilities updateFromServer! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 6/3/2000 11:00'!
beIsolated
	"Establish this project as an isolation layer.
	Further method changes made here will be revoked when you leave the project."

	CurrentProjectRefactoring currentBeIsolated! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:25'!
bitCachingString
	^ StandardSystemView cachingBits
		ifTrue: ['don''t save bits (compact)']
		ifFalse: ['save bits (fast)']! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 8/5/1998 18:40'!
browseChangedMessages
	Smalltalk browseChangedMessages! !

!ScreenController methodsFor: 'menu messages'!
browseRecentLog
	"Open a changelist browser on changes submitted since the last snapshot.  1/17/96 sw"

	ChangeList browseRecentLog! !

!ScreenController methodsFor: 'menu messages'!
browseRecentSubmissions
	"Open a method-list browser on recently-submitted methods.  5/16/96 sw"

	Utilities browseRecentSubmissions! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:50'!
changeWindowPolicy
	Preferences toggleWindowPolicy! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:12'!
chooseDirtyBrowser
	"Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any."
	"ScheduledControllers screenController chooseDirtyBrowser"

	ScheduledControllers findWindowSatisfying:
		[:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]].
 ! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:13'!
chooseDirtyWindow
	"Put up a list of windows with unaccepted edits and let the user chose one to activate."
	"ScheduledControllers screenController chooseDirtyWindow"

	ScheduledControllers findWindowSatisfying:
		[:c | c model canDiscardEdits not].
! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:13'!
closeUnchangedWindows
	"Close any window that doesn't have unaccepted input."

	| clean |
	(SelectionMenu confirm:
'Do you really want to close all windows
except those with unaccepted edits?')
		ifFalse: [^ self].

	clean _ ScheduledControllers scheduledControllers select:
		[:c | c model canDiscardEdits and: [(c isKindOf: ScreenController) not]].
	clean do: [:c | c closeAndUnscheduleNoTerminate].
	self restoreDisplay.
! !

!ScreenController methodsFor: 'menu messages'!
collapseAll
	"Collapses all open windows"
	ScheduledControllers scheduledControllers do:
		[:controller | controller == self ifFalse:
			[controller view isCollapsed ifFalse:
					[controller collapse.
					controller view deEmphasize]]]! !

!ScreenController methodsFor: 'menu messages'!
commonRequests 
	"Put up a popup of common requests, and perform whatever the user request.  2/1/96 sw"
	Utilities offerCommonRequests! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 12/10/1999 11:29'!
configureFonts
	Preferences presentMvcFontConfigurationMenu! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/22/1998 15:09'!
durableChangesMenu 
	Utilities windowFromMenu: self changesMenu target: self title: 'Changes'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:01'!
durableHelpMenu 
	| aMenu selectionList labelList targetList i wordingList colorPattern |
	aMenu _ self helpMenu.
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | self].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	colorPattern _ #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange).

	wordingList _ selectionList collect:
		[:aSelection |
			(aSelection == #soundOnOrOff) ifTrue: [#soundEnablingString] ifFalse: [nil]].
	^ Utilities windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: 'Help'

! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 11/25/1998 12:21'!
durableOpenMenu 
	| colorPattern |
	colorPattern _ #(blue lightGreen lightYellow lightMagenta  lightOrange lightCyan) asOrderedCollection.
	colorPattern add: Project someInstance backgroundColorForMvcProject.
	colorPattern add: Project someInstance backgroundColorForMorphicProject.
	colorPattern add: #orange.
	Utilities windowFromMenu: self openMenu target: self title: 'Openers'
		colorPattern: colorPattern! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/22/1998 14:36'!
durableScreenMenu 
	Utilities windowFromMenu: self projectScreenMenu target: self title: 'Squeak'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:28'!
durableWindowMenu 
	| aMenu selectionList labelList targetList i wordingList colorPattern |
	aMenu _ self windowMenu.
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | self].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	colorPattern _ #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange).

	wordingList _ selectionList collect:
		[:aSelection |
			(#(fastWindows changeWindowPolicy) includes: aSelection)
				ifFalse:
					[nil]
				ifTrue:
					[aSelection == #fastWindows
						ifFalse:
							[#staggerPolicyString]
						ifTrue:
							[#bitCachingString]]].
	^ Utilities windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: 'windows'

! !

!ScreenController methodsFor: 'menu messages'!
editPreferences
	"Open up a Preferences inspector.  2/7/96 sw"

	Preferences openPreferencesInspector! !

!ScreenController methodsFor: 'menu messages'!
emergencyCollapse
	"Emergency collapse of a selected window"
	| controller |
	(controller _ ScheduledControllers windowFromUser) notNil
		ifTrue:
			[controller collapse.
			controller view deEmphasize]! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 6/3/2000 09:44'!
exitProject 
	"Leave the current Project and enter the Project in which the receiver's 
	view is scheduled."

	CurrentProjectRefactoring exitCurrentProject! !

!ScreenController methodsFor: 'menu messages'!
expandAll
	"Reopens all collapsed windows"
	ScheduledControllers scheduledControllers reverseDo:
		[:controller | controller == self ifFalse:
			[controller view isCollapsed
				ifTrue:  [controller view expand]
				ifFalse: [controller view displayDeEmphasized]]]! !

!ScreenController methodsFor: 'menu messages'!
fastWindows
	StandardSystemView cachingBits
		ifTrue: [StandardSystemView dontCacheBits]
		ifFalse: [StandardSystemView doCacheBits]! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 2/3/2000 16:23'!
fileForRecentLog
	Smalltalk writeRecentToFile! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 2/15/1999 12:25'!
fileOutChanges
	Utilities fileOutChanges! !

!ScreenController methodsFor: 'menu messages'!
findWindow
	"Put up a menu of all windows on the screen, and let the user select one.
	 1/18/96 sw: the real work devolved to ControlManager>>findWindowSatisfying:"

	ScheduledControllers findWindowSatisfying: [:c | true]! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/23/1998 02:06'!
fontSizeSummary
	Utilities fontSizeSummary! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 7/15/2000 00:01'!
fullScreenOff

	Smalltalk fullScreenMode: (LastScreenModeSelected _ false).
	self restoreDisplay.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 7/15/2000 00:01'!
fullScreenOn

	Smalltalk fullScreenMode: (LastScreenModeSelected _ true).
	self restoreDisplay.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 12/12/2000 13:55'!
garbageCollect
	"Do a garbage collection, and report results to the user."

	| cc |
	Smalltalk at: #Command ifPresent:
		[:cmdClass |
		(cc _ cmdClass instanceCount) > 0 ifTrue:
			[(self confirm: 'There are ' , cc printString , ' undo records in your system.
would you like to purge them prior to measuring space left?')
				ifTrue: [CommandHistory resetAllHistory]]].
	self inform: (Smalltalk bytesLeft asStringWithCommas, ' bytes available').
! !

!ScreenController methodsFor: 'menu messages' stamp: 'jm 5/20/1998 23:28'!
jumpToProject

	Project jumpToProject.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 10/27/1998 14:27'!
lookForSlips
	Smalltalk changes lookForSlips! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 7/18/1999 20:54'!
lookUpDefinition
	Utilities lookUpDefinition! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 9/4/1998 10:17'!
newChangeSet
	ChangeSorter newChangeSet! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 4/6/98 23:14'!
openBrowser 
	"Create and schedule a Browser view for browsing code."

	Browser openBrowser! !

!ScreenController methodsFor: 'menu messages'!
openChangeManager
	"Open a dual change sorter.  For looking at two change sets at once."
	DualChangeSorter new open! !

!ScreenController methodsFor: 'menu messages'!
openCommandKeyHelp
	"1/18/96 sw Open a window that explains command-keys"

	Utilities openCommandKeyHelp! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/9/1999 12:30'!
openFile
	FileList openFileDirectly! !

!ScreenController methodsFor: 'menu messages'!
openFileList
	"Create and schedule a FileList view for specifying files to access."

	FileList open! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 7/19/1999 14:56'!
openMorphicProject

	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	ProjectView open: Project newMorphic.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 11/26/1999 08:56'!
openMorphicWorld 
	"Create and schedule a StringHolderView for use as a workspace."
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	MorphWorldView openWorld.
! !

!ScreenController methodsFor: 'menu messages' stamp: 'ar 1/31/2001 17:06'!
openPackageBrowser 
	"Create and schedule a Browser view for browsing code."

	PackagePaneBrowser openBrowser! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 11/26/1999 10:49'!
openProject 
	"Create and schedule a Project."
	| proj |
	Smalltalk at: #ProjectView ifPresent:
		[:c | proj _ Project new.
		proj projectParameters at: #globalFlapsEnabledInProject put: false.
		c open: proj].
! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 8/31/1998 16:18'!
openSelectorBrowser
	"Create and schedule a selector fragment window."

	SelectorBrowser new open! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 7/6/1998 18:59'!
openSimpleChangeSorter
	ChangeSorter new open! !

!ScreenController methodsFor: 'menu messages'!
openStandardWorkspace
	"Open a standard, throwaway window chock full of useful expressions.  1/17/96 sw"

	Utilities openStandardWorkspace! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 5/8/1998 12:49'!
openTranscript 
	"Create and schedule the System Transcript."
	Transcript open! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 5/4/1998 17:25'!
openWorkspace 
	"Create and schedule workspace."

	Workspace open! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 6/3/2000 11:01'!
propagateChanges.
	"The changes made in this isolated project will be propagated to projects above."

	CurrentProjectRefactoring currentPropagateChanges! !

!ScreenController methodsFor: 'menu messages'!
quit
	Smalltalk
		snapshot:
			(self confirm: 'Save changes before quitting?'
				orCancel: [^ self])
		andQuit: true! !

!ScreenController methodsFor: 'menu messages' stamp: 'RAA 5/25/2000 09:41'!
restoreDisplay 
	"Clear the screen to gray and then redisplay all the scheduled views."

	Smalltalk isMorphic ifTrue: [^ Display restoreMorphicDisplay].

	Display extent = DisplayScreen actualScreenSize
		ifFalse:
			[DisplayScreen startUp.
			ScheduledControllers unCacheWindows].
	ScheduledControllers restore! !

!ScreenController methodsFor: 'menu messages' stamp: 'jm 5/22/1998 06:45'!
returnToPreviousProject

	Project returnToPreviousProject.
! !

!ScreenController methodsFor: 'menu messages'!
saveAs
	^ Smalltalk saveAs! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 5/10/96'!
setAuthorInitials
	"Put up a dialog allowing the user to specify the author's initials.  "
	Utilities setAuthorInitials! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 11/26/96'!
setDesktopColor
	"Let the user choose a new color for the desktop.   Based on an idea by Georg Gollmann.   "

	Preferences desktopColor: Color fromUser.
	ScheduledControllers updateGray; restore! !

!ScreenController methodsFor: 'menu messages' stamp: 'bf 9/18/1999 20:01'!
setDisplayDepth
	"Let the user choose a new depth for the display. "
	| result |
	(result _ (SelectionMenu selections: Display supportedDisplayDepths) startUpWithCaption: 'Choose a display depth
(it is currently ' , Display depth printString , ')') == nil ifFalse:
		[Display newDepth: result]! !

!ScreenController methodsFor: 'menu messages'!
snapshot
	Smalltalk snapshot: true andQuit: false! !

!ScreenController methodsFor: 'menu messages'!
snapshotAndQuit
	"Snapshot and quit without bother the user further.  2/4/96 sw"

	Smalltalk
		snapshot: true
		andQuit: true! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:01'!
soundEnablingString
	^ Preferences soundEnablingString! !

!ScreenController methodsFor: 'menu messages' stamp: 'bf 3/16/2000 18:26'!
soundOnOrOff
	Preferences setPreference: #soundsEnabled
		toValue: Preferences soundsEnabled not! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:23'!
staggerPolicyString
	^ Preferences staggerPolicyString! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 5/29/2000 00:26'!
standardGraphicsLibrary
	"Open a standard, throwaway window chock full of useful expressions.  1/17/96 sw"

	ScriptingSystem inspectFormDictionary! !

!ScreenController methodsFor: 'menu messages' stamp: 'di 9/14/1998 10:14'!
viewImageImports
	"Open an inspector on forms imported from Image files."

	Smalltalk viewImageImports! !

!ScreenController methodsFor: 'menu messages' stamp: 'tk 5/4/1998 17:33'!
vmStatistics
	"Open a string view on a report of vm statistics"

	(StringHolder new contents: Utilities vmStatisticsReportString)
		openLabel: 'VM Statistics'! !

!ScreenController methodsFor: 'menu messages' stamp: 'sw 7/13/1999 20:19'!
windowSpecificationPanel
	Smalltalk hasMorphic ifFalse:
		[^ self inform: 'Sorry, this feature requires the presence of Morphic.'].
	Preferences windowSpecificationPanel! !


!ScreenController methodsFor: 'cursor'!
centerCursorInView
	"Override so this doesn't happen when taking control"! !


!ScreenController methodsFor: 'nested menus' stamp: 'sw 12/10/1999 11:29'!
appearanceMenu 
	"Answer the appearance menu to be put up as a screen submenu"

	^ SelectionMenu labelList:
		#(	'window colors...'
			'system fonts...'
			'full screen on'
			'full screen off'
			'set display depth...'
			'set desktop color...' ) 

		lines: #(2 4)
		selections: #(windowSpecificationPanel configureFonts
fullScreenOn fullScreenOff setDisplayDepth setDesktopColor)
"
ScreenController new appearanceMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/4/2000 23:47'!
changesMenu
	"Answer a menu for changes-related items"
	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'simple change sorter'
			'dual change sorter'

			'file out current change set'
			'create new change set...'
			'browse changed methods'
			'check change set for slips'

			'isolate methods of this project'
			'propagate changes above'

			'browse recent submissions'
			'recently logged changes...'
			'recent log file...'
			)
		lines: #(1 3 7 9)
		selections: #(durableChangesMenu
openSimpleChangeSorter openChangeManager
fileOutChanges newChangeSet browseChangedMessages lookForSlips
beIsolated propagateChanges
browseRecentSubmissions browseRecentLog fileForRecentLog)
"
ScreenController new changesMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 5/29/2000 00:25'!
helpMenu 
	"Answer the help menu to be put up as a screen submenu"

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'about this system'
			'update code from server'
			'edit preferences...'

			'command-key help'
			'font size summary'
			'useful expressions'
			'view graphical imports'
			'standard graphics library'),

			(Array with: (Preferences soundsEnabled
							ifFalse: ['turn sound on']
							ifTrue: ['turn sound off'])) ,

		#(	'definition for...'
			'set author initials...'
			'vm statistics'
			'space left')
		lines: #(1 4 6 11)
		selections: #(durableHelpMenu aboutThisSystem absorbUpdatesFromServer
editPreferences  openCommandKeyHelp fontSizeSummary openStandardWorkspace viewImageImports
standardGraphicsLibrary soundOnOrOff  lookUpDefinition setAuthorInitials vmStatistics garbageCollect)
"
ScreenController new helpMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/5/2000 17:21'!
openMenu
	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'browser'
			'package browser'
			'method finder'
			'workspace'
			'file list'
			'file...'
			'transcript'
			'morphic world'

			'simple change sorter'
			'dual change sorter'

			'mvc project'
			'morphic project'
			)
		lines: #(1 9 11)
		selections: #(durableOpenMenu
openBrowser openPackageBrowser openSelectorBrowser openWorkspace openFileList openFile openTranscript openMorphicWorld
openSimpleChangeSorter openChangeManager
openProject  openMorphicProject  )
"
ScreenController  new openMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sma 3/11/2000 12:23'!
popUpMenuFor: aSymbol
	(self perform: aSymbol) invokeOn: self! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/13/1999 18:07'!
presentAppearanceMenu
	self popUpMenuFor: #appearanceMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:14'!
presentChangesMenu
	self popUpMenuFor: #changesMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'!
presentHelpMenu
	self popUpMenuFor: #helpMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'!
presentOpenMenu
	self popUpMenuFor: #openMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:16'!
presentWindowMenu
	self popUpMenuFor: #windowMenu! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 7/13/1999 18:07'!
projectScreenMenu
	"Answer the project screen menu."

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'previous project'
			'jump to project...'
			'restore display'

			'open...'
			'windows...'
			'changes...'
			'help...'
			'appearance...'
			'do...'

			'save'
			'save as...'
			'save and quit'
			'quit')
		lines: #(1 4 10)
		selections: #(durableScreenMenu
returnToPreviousProject jumpToProject restoreDisplay
presentOpenMenu presentWindowMenu presentChangesMenu presentHelpMenu presentAppearanceMenu commonRequests
snapshot saveAs snapshotAndQuit quit )
"
ScreenController new projectScreenMenu startUp
"! !

!ScreenController methodsFor: 'nested menus' stamp: 'sw 6/11/1999 20:25'!
windowMenu
	"Answer a menu for windows-related items.  "

	^ SelectionMenu labelList:
		#(	'keep this menu up'

			'find window...'
			'find changed browsers...'
			'find changed windows...'

			'collapse all windows'
			'expand all windows'
			'close unchanged windows' ) , 
			(Array
				with: self bitCachingString
				with: self staggerPolicyString)
		lines: #(1 4 7)
		selections: #(durableWindowMenu
findWindow chooseDirtyBrowser chooseDirtyWindow
collapseAll expandAll closeUnchangedWindows
fastWindows changeWindowPolicy)
"
ScreenController new windowMenu startUp
"! !


!ScreenController methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:47'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

	dp _ DiskProxy global: #ScheduledControllers selector: #screenController args: #().
	refStrm replace: self with: dp.
	^ dp! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScreenController class
	instanceVariableNames: ''!

!ScreenController class methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/2000 09:28'!
lastScreenModeSelected

	^LastScreenModeSelected! !
FullVocabulary subclass: #ScreenedVocabulary
	instanceVariableNames: 'methodScreeningBlock categoryScreeningBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!

!ScreenedVocabulary methodsFor: 'enumeration' stamp: 'sw 1/5/2001 06:55'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the vocabulary which are in the given category, on behalf of the given class and object"

	^ (super allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass) select:
		[:aSelector | self includesSelector: aSelector]! !

!ScreenedVocabulary methodsFor: 'enumeration' stamp: 'sw 12/14/2000 14:03'!
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given object/class, considering only code implemented in mostGenericClass and lower"

	^ (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass) select:
		[:aCategory | categoryScreeningBlock value: aCategory]! !


!ScreenedVocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 14:06'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ methodScreeningBlock value: aSelector! !

!ScreenedVocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 06:01'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given object, only considering method implementations in mostGenericClass and lower"

	^ (super includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass) and:
		[self includesSelector: aSelector]! !


!ScreenedVocabulary methodsFor: 'initialization' stamp: 'sw 12/14/2000 13:58'!
categoryScreeningBlock: aBlock
	"Set the receiver's categoryScreeningBlock to the block provided"

	categoryScreeningBlock _ aBlock! !

!ScreenedVocabulary methodsFor: 'initialization' stamp: 'sw 12/4/2000 04:40'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	vocabularyName _  #Public.
	self documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'! !

!ScreenedVocabulary methodsFor: 'initialization' stamp: 'sw 12/14/2000 13:57'!
methodScreeningBlock: aBlock
	"Set the receiver's methodScreeningBlock to the block provided"

	methodScreeningBlock _ aBlock! !
Morph subclass: #ScreeningMorph
	instanceVariableNames: 'screenForm displayMode passingColor passElseBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!ScreeningMorph commentStamp: '<historical>' prior: 0!
ScreeningMorph uses its first submorph as a screen, and its second submorph as a source.  It also wants you to choose (when showing only the screen) the passing color in the screen.  It then makes up a 1-bit mask which clips the source, and displays transparently outside it.!


!ScreeningMorph methodsFor: 'initialization' stamp: 'di 6/4/1999 08:25'!
addMorph: aMorph

	| f |
	super addMorph: aMorph.
	submorphs size <= 2 ifTrue:
		[self bounds: submorphs last bounds].
	submorphs size = 2 ifTrue:
		["The screenMorph has just been added.
		Choose as the passingColor the center color of that morph"
		f _ self screenMorph imageForm.
		passingColor _ f colorAt: f boundingBox center.
		passElseBlock _ true]! !

!ScreeningMorph methodsFor: 'initialization' stamp: 'panda 4/25/2000 15:42'!
initialize
	super initialize.
	passingColor _ Color black.
	passElseBlock _ true.
	displayMode _ #showScreened.
	self enableDragNDrop! !

!ScreeningMorph methodsFor: 'initialization' stamp: 'di 6/4/1999 08:27'!
privateRemoveMorph: aMorph

	super privateRemoveMorph: aMorph.
	submorphs size = 1 ifTrue:
		[self bounds: submorphs first bounds]! !


!ScreeningMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:03'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	submorphs size = 0 ifTrue:
		[^ aCustomMenu add: '*Please add a source morph*' action: #itself].
	submorphs size = 1 ifTrue:
		[^ aCustomMenu add: '*Please add a screen morph*' action: #itself].
	submorphs size > 2 ifTrue:
		[^ aCustomMenu add: '*I have too many submorphs*' action: #itself].
	aCustomMenu add: 'show screen only' action: #showScreenOnly.
	aCustomMenu add: 'show source only' action: #showSourceOnly.
	aCustomMenu add: 'show screen over source' action: #showScreenOverSource.
	aCustomMenu add: 'show source screened' action: #showScreened.
	aCustomMenu add: 'exchange source and screen' action: #exchange.
	displayMode == #showScreenOnly ifTrue:
		[aCustomMenu add: 'choose passing color' action: #choosePassingColor.
		aCustomMenu add: 'choose blocking color' action: #chooseBlockingColor].
! !

!ScreeningMorph methodsFor: 'menu' stamp: 'di 6/3/1999 16:41'!
chooseBlockingColor
	passingColor _ Color fromUser.
	passElseBlock _ false.
	self layoutChanged! !

!ScreeningMorph methodsFor: 'menu' stamp: 'di 6/3/1999 16:41'!
choosePassingColor
	passingColor _ Color fromUser.
	passElseBlock _ true.
	self layoutChanged! !

!ScreeningMorph methodsFor: 'menu'!
exchange
	submorphs swap: 1 with: 2.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreenOnly
	displayMode _ #showScreenOnly.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreenOverSource
	displayMode _ #showScreenOverSource.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showScreened
	displayMode _ #showScreened.
	self changed! !

!ScreeningMorph methodsFor: 'menu'!
showSourceOnly
	displayMode _ #showSourceOnly.
	self changed! !


!ScreeningMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 12:11'!
fullDrawOn: aCanvas
	| mergeForm |
	submorphs size = 0 ifTrue: [^ super fullDrawOn: aCanvas].
	(submorphs size = 1 or: [displayMode == #showScreenOnly]) ifTrue:
		[^ aCanvas fullDrawMorph: self screenMorph].
	displayMode == #showSourceOnly ifTrue:
		[^ aCanvas fullDrawMorph: self sourceMorph].
	displayMode == #showScreenOverSource ifTrue:
		[aCanvas fullDrawMorph: self sourceMorph.
		^ aCanvas fullDrawMorph: self screenMorph].
	displayMode == #showScreened ifTrue:
		[aCanvas fullDrawMorph: self screenMorph.
		self flag: #fixCanvas. "There should be a more general way than this"
		mergeForm _ self sourceMorph imageFormForRectangle: self screenMorph bounds.
		(BitBlt current toForm: mergeForm) copyForm: self screenForm to: 0@0 rule: Form and
			colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
		aCanvas paintImage: mergeForm at: self screenMorph position]! !


!ScreeningMorph methodsFor: 'geometry'!
containsPoint: aPoint
	submorphs size = 2 ifFalse: [^ super containsPoint: aPoint].
	^ self screenMorph containsPoint: aPoint! !

!ScreeningMorph methodsFor: 'geometry' stamp: 'panda 4/25/2000 15:43'!
layoutChanged

	screenForm _ nil.
	submorphs size >= 2
		ifTrue: [self disableDragNDrop]
		ifFalse: [self enableDragNDrop].
	submorphs size = 2 ifTrue:
		[bounds _ ((self sourceMorph bounds merge: self screenMorph bounds) expandBy: 4)].
	^ super layoutChanged! !


!ScreeningMorph methodsFor: 'private' stamp: 'di 6/3/1999 19:31'!
screenForm

	| screenImage colorMap pickValue elseValue |
	screenForm ifNotNil: [^ screenForm].
	passElseBlock ifNil: [passElseBlock _ true].
	passingColor ifNil: [passingColor _ Color black].
	passElseBlock
		ifTrue: [pickValue _ 16rFFFFFFFF.  elseValue _ 0]
		ifFalse: [pickValue _ 0.  elseValue _ 16rFFFFFFFF].
	screenImage _ self screenMorph imageFormForRectangle: self screenMorph bounds.
	colorMap _ screenImage newColorMap atAllPut: elseValue.
	colorMap at: (passingColor indexInMap: colorMap) put: pickValue.
	screenForm _ Form extent: screenImage extent.
	screenForm copyBits: screenForm boundingBox
			from: screenImage at: 0@0 colorMap: colorMap.
	^ screenForm! !

!ScreeningMorph methodsFor: 'private'!
screenMorph
	^ submorphs at: 1! !

!ScreeningMorph methodsFor: 'private'!
sourceMorph
	^ submorphs at: 2! !
ServerAction subclass: #ScreenshotAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!ScreenshotAction methodsFor: 'URL processing' stamp: 'tk 2/4/98 12:31'!
process: request
	FileDirectory default deleteFileNamed: 'screenshot.GIF'.
	GIFReadWriter putForm: Display onFileNamed: 'screenshot.GIF'.
	request reply: (PWS success), (PWS content: 'image/gif'), PWS crlf.
	request reply: (FileStream fileNamed: 'screenshot.GIF') contentsOfEntireFile.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScreenshotAction class
	instanceVariableNames: ''!

!ScreenshotAction class methodsFor: 'setupForPWS' stamp: 'mjg 12/31/97 08:19'!
setUp
	PWS link: 'screenshot' to: ScreenshotAction new.
! !
SimpleButtonMorph subclass: #ScriptActivationButton
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ScriptActivationButton methodsFor: 'as yet unclassified' stamp: 'sw 1/19/2001 18:27'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand.  To avoid a nasty inheritance problem, this method does NOT call super"

	aCustomMenu addUpdating: #hasDragAndDropEnabledString action: #changeDragAndDrop.

	aCustomMenu add: 'put in a window' action: #embedInWindow.
	aCustomMenu addUpdating: #stickinessString target: self action: #toggleStickiness.
	aCustomMenu add: 'adhere to edge...' action: #adhereToEdge.

	aCustomMenu addList: 
			#(('border color...' changeBorderColor:)
			('border width...' changeBorderWidth:)).
	aCustomMenu addUpdating: #roundedCornersString target: self action: #toggleCornerRounding.

	borderColor == #raised ifFalse: [aCustomMenu add: 'raised bevel' action: #borderRaised].
	borderColor == #inset ifFalse: [aCustomMenu add: 'inset bevel' action: #borderInset].
	self addLabelItemsTo: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'open underlying scriptor' target: target selector: #openUnderlyingScriptorFor: argument: arguments first

! !

!ScriptActivationButton methodsFor: 'as yet unclassified' stamp: 'sw 10/1/1999 21:42'!
bringUpToDate
	self establishLabelWording! !

!ScriptActivationButton methodsFor: 'as yet unclassified' stamp: 'sw 10/5/1999 18:10'!
establishLabelWording
	| itsName |
	self label: ((itsName _ target externalName), ' ', arguments first).
	self setBalloonText: 'click to run the script "', arguments first, '" in player named "', itsName, '"'! !

!ScriptActivationButton methodsFor: 'as yet unclassified' stamp: 'sw 10/1/1999 21:42'!
isTileScriptingElement
	^ true! !
AlignmentMorph subclass: #ScriptEditorMorph
	instanceVariableNames: 'scriptName firstTileRow timeStamp playerScripted handWithTile showingMethodPane '
	classVariableNames: 'WritingUniversalTiles '
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!ScriptEditorMorph commentStamp: '<historical>' prior: 0!
Presents an EToy script to the user on the screen.  Has in it:

a Morph with the controls for the script.
a Morph with the tiles.  Either PhraseMorphs and TileMorphs, 
	or a TwoWayScroller with SyntaxMorphs in it.

WritingUniversalTiles -- only vlaid while a project is being written out.  
		True if using UniversalTiles in that project.!


!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 1/23/2001 11:27'!
bringUpToDate
	"Make certain that the script name and the names of players within are up to date"

	| currentName titleMorph |
	playerScripted ifNil: ["likely a naked test/yes/no fragment!!" ^ self].

	currentName _ playerScripted externalName.
	submorphs size = 0 ifTrue: [^ self].
	self firstSubmorph "align" submorphsDo: [:m | "try quick way"
				m knownName = 'title' ifTrue: [titleMorph _ m]].
	titleMorph ifNil: [
		titleMorph _ self firstSubmorph findDeepSubmorphThat: [:m | m knownName = 'title'] 
								ifAbsent: [nil]].
	titleMorph ifNotNil:
		[titleMorph label: currentName, ' ', self scriptName font: ScriptingSystem fontForTiles]! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 22:04'!
initialize

	super initialize.
	color _ ScriptingSystem colorBehindTiles.
	self listDirection: #topToBottom.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.

	self setDefaultBorderCharacteristics.
	firstTileRow _ 1.  "index of first tile-carrying submorph"
	self addNewRow.
	showingMethodPane _ false.! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 1/12/1999 16:03'!
phrase: aPhraseTileMorph
	"Make the receiver be an anonymous editor around aPhraseTileMorph"
	firstTileRow _ 2.
	self addMorphBack: (AlignmentMorph newRow addMorphBack: aPhraseTileMorph).
	self install! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 2/4/98 00:45'!
playerScripted: aPlayer
	playerScripted _ aPlayer ! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'di 5/6/1998 21:09'!
scriptName: aScriptName phrase: aPhraseTileMorph
	"Make the receiver be an anonymous editor around aPhraseTileMorph"
	scriptName _ aScriptName.
	self addMorphFront: self buttonRowForEditor.
	self updateStatus.
	firstTileRow _ 2.
	self addMorphBack: (AlignmentMorph newRow addMorphBack: aPhraseTileMorph).
	self install! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:43'!
setDefaultBorderCharacteristics	
	borderWidth _ 1.
	borderColor _ Color black.
	self layoutInset: 2.
	self useRoundedCorners
! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 8/11/1998 16:58'!
setMorph: anActorMorph
	"Not really the way to do this any more"
	playerScripted _ anActorMorph player
! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 2/13/98 16:35'!
setMorph: anActorMorph scriptName: aString
	"Create a script editor for editing a named script."

	self setMorph: anActorMorph.
	scriptName _ aString.
	self addMorphFront: self buttonRowForEditor.
	self updateStatus.
	firstTileRow _ 2
! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 5/6/1998 16:36'!
startOutEmptyForScriptName: aScriptName
	"Make the receiver be an anonymous editor around initially empty content"
	scriptName _ aScriptName.
	self addMorphFront: self buttonRowForEditor.
	self updateStatus.
	firstTileRow _ 2.
	self install! !

!ScriptEditorMorph methodsFor: 'initialization' stamp: 'sw 1/19/2001 18:13'!
updateToPlayer: newPlayer
	"Make certain that the script name and the names of actors within are up to date"

	| currentName titleMorph |
	playerScripted ifNil: ["likely a naked test/yes/no fragment!!" ^ self].

	newPlayer == playerScripted ifTrue: [^ self].  "Already points to him"
	self allMorphs do:
		[:m | (m isKindOf: TileMorph) ifTrue:
			[m retargetFrom: playerScripted to: newPlayer.
			m bringUpToDate]].
	playerScripted _ newPlayer.

	currentName _ playerScripted externalName.
	submorphs size = 0 ifTrue: [^ self].
	self firstSubmorph "align" submorphsDo: [:m | "try quick way"
				m knownName = 'title' ifTrue: [titleMorph _ m]].
	titleMorph ifNil:
		[titleMorph _ self firstSubmorph findDeepSubmorphThat: [:m | m knownName = 'title'] 
								ifAbsent: [nil]].
	titleMorph ifNotNil:
		[titleMorph label: currentName, ' ', self scriptName font: ScriptingSystem fontForTiles]! !


!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 2/16/98 02:03'!
morph
	^ self playerScripted costume! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 11/3/1998 17:20'!
myMorph
	"Answer the morph that serves as the costume of my associated player.  If for some reason I have no associated player, answer nil"

	| aPlayer |
	^ (aPlayer _ self playerScripted) ifNotNil: [aPlayer costume]! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 12/4/1998 15:46'!
objectViewed
	^ self playerScripted costume! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 4/30/1998 14:34'!
scriptInstantiation
	^ playerScripted scriptInstantiationForSelector: scriptName! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 1/12/1999 16:04'!
scriptName: newName
	"Smash in a changed script name, with no side effects"
	scriptName _ newName! !

!ScriptEditorMorph methodsFor: 'access' stamp: 'sw 2/25/98 00:32'!
titleMorph
	^ self firstSubmorph submorphs third! !


!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 1/28/2001 02:43'!
acceptDroppingMorph: aMorph event: evt
	"Allow the user to add tiles and program fragments just by dropping them on this morph."

	| i slideMorph p1 p2 |

	self prepareToUndoDropOf: aMorph.
	"Find where it will go, and prepare to animate the move..."
	i _ self rowInsertionIndexFor: aMorph fullBounds center.
	slideMorph _ aMorph imageForm offset: 0@0.
	p1 _ aMorph screenRectangle topLeft.
	aMorph delete.
	self stopStepping.
	self world displayWorld.  "Clear old image prior to animation"

	(aMorph isKindOf: PhraseTileMorph) ifTrue:
		[aMorph unbrightenTiles.
		aMorph justGrabbedFromViewer: false].
	aMorph tileRows do: [:tileList |
		self insertTileRow: (Array with:
				(tileList first rowOfRightTypeFor: owner forActor: aMorph associatedPlayer))
			after: i.
		i _ i + 1].
	self removeSpaces.
	self enforceTileColorPolicy.
	self layoutChanged.
	self fullBounds. "force layout"

	"Now animate the move, before next Morphic update.
		NOTE: This probably should use ZoomMorph instead"
	p2 _ (self submorphs atPin: (i-1 max: firstTileRow)) screenRectangle topLeft.
	slideMorph slideFrom: p1 to: p2 nSteps: 5 delay: 50 andStay: true.
	self playSoundNamed: 'scritch'.
	self topEditor install  "Keep me for editing, a copy goes into lastAcceptedScript"! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 17:07'!
dismissViaHalo
	"The user has clicked in the delete halo-handle.  This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."

	self destroyScript! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 7/3/1998 14:25'!
handlesDragOver: evt

	^ true
! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'tk 9/30/97 14:15'!
handlesMouseOver: evt

	^ true
! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt

	^ true
! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 10/20/97 08:22'!
indexOfMorphAbove: aPoint
	"Return index of lowest morph whose bottom is above aPoint.
	Will return 0 if the first morph is not above aPoint"
	submorphs doWithIndex:
		[:m :i | m fullBounds bottom >= aPoint y ifTrue:
					[^ (i max: firstTileRow) - 1]].
	^ submorphs size! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 7/28/1999 17:02'!
isCandidateForAutomaticViewing
	^ false! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/8/2000 14:53'!
mouseEnter: evt
	| hand tile |

	self flag: #bob.		"needed renderedMorph due to transformations"
	hand _ evt hand.
	hand submorphs size = 1 ifFalse: [^self].
	evt "hand lastEvent" redButtonPressed ifFalse: [^self].
	tile _ hand firstSubmorph renderedMorph.
	(self wantsDroppedMorph: tile event: evt) ifFalse: [^self].
	(tile isKindOf: PhraseTileMorph) ifTrue: [tile brightenTiles]. 
	handWithTile _ hand.
	self startStepping! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/8/2000 14:54'!
mouseLeave: evt
	| hand tile |
	owner ifNil: [^ self].	"left by being removed, not by mouse movement"
	(self hasProperty: #justPickedUpPhrase) ifTrue:[
		self removeProperty: #justPickedUpPhrase.
		^self].
	self stopStepping.
	handWithTile _ nil.
	self removeSpaces.
	hand _ evt hand.
	(hand submorphs size = 1) & (hand lastEvent redButtonPressed) ifTrue:
		[tile _ hand firstSubmorph.
		(tile isKindOf: PhraseTileMorph) ifTrue: [tile unbrightenTiles]].
! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/24/98 17:28'!
prepareToUndoDropOf: aMorph
	"No longer functional"! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/14/97 12:28'!
removeSpaces
	self submorphsDo:
		[:m | (m isMemberOf: Morph) ifTrue: [m delete]].
	self removeEmptyRows! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'RAA 1/13/2001 08:08'!
repelsMorph: aMorph event: ev

	(showingMethodPane == true and: 
		[self world valueOfProperty: #universalTiles ifAbsent: [false]]) ifTrue: [
			^ (aMorph respondsTo: #parseNode) not].

	^ aMorph isTileLike not! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'ar 9/14/2000 16:46'!
step

	| hand insertion i space1 d space2 insHt nxtHt prevBot ht2 c1 c2 ii where |

	hand _ handWithTile ifNil: [self primaryHand].
	(hand lastEvent redButtonPressed and: [(self hasOwner: hand) not]) ifTrue: [
		hand submorphCount > 0 ifTrue: [
			insertion _ hand firstSubmorph renderedMorph.
			insHt _ insertion height.
			self removeSpaces.
			where _ self globalPointToLocal: hand position"insertion fullBounds topLeft".
			i _ (ii _ self indexOfMorphAbove: where) min: submorphs size-1.
			prevBot _ i <= 0 ifTrue: [(self innerBounds) top]
							ifFalse: [(self submorphs at: i) bottom].
			nxtHt _ (submorphs isEmpty
				ifTrue: [insertion]
				ifFalse: [self submorphs at: i+1]) height.
			d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
					ifFalse: [0 max: (where y - prevBot min: nxtHt)].

			"Top and bottom spacer heights cause continuous motion..."
			c1 _ Color green.  c2 _ Color transparent.
			ht2 _ d*insHt//nxtHt.
			space1 _ Morph newBounds: (0@0 extent: 30@(insHt-ht2))
                                        color: ((insHt-ht2) > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
			self privateAddMorph: space1 atIndex: (i+1 max: 1).
			space2 _ Morph newBounds: (0@0 extent: 30@ht2)
                                        color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]).
			self privateAddMorph: space2 atIndex: (i+3 min: submorphs size+1).
		]
	] ifFalse: [
		self stopStepping.
		self removeSpaces.
		self allMorphsDo: [:m |
			(m isKindOf: TileMorph) ifTrue: [
				m color: (ScriptingSystem unbrightColorFor: m color)
			]
		]
	]! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'tk 9/30/97 14:09'!
stepTime

	^ 0! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'tk 11/8/2000 17:28'!
wantsDroppedMorph: aMorph event: evt

	aMorph isTileLike ifFalse: [^false].
	aMorph resultType == #command ifFalse: [^false].
	self isTextuallyCoded ifTrue: [^false].
	^true

! !

!ScriptEditorMorph methodsFor: 'dropping/grabbing' stamp: 'sw 8/15/2000 16:58'!
willingToBeDiscarded
	"Resist the drag-into-trash gesture"

	^ false! !


!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 9/8/2000 17:09'!
actuallyDestroyScript
	"Carry out the actual destruction of the associated script."

	| aHandler |
	self delete.
	playerScripted class removeScriptNamed: scriptName.
	playerScripted actorState instantiatedUserScriptsDictionary removeKey: scriptName.
		"not quite enough yet in the multiple-instance case..."
	(aHandler _ playerScripted costume renderedMorph eventHandler) ifNotNil:
		[aHandler forgetDispatchesTo: scriptName].
	playerScripted updateAllViewersAndForceToShow: #scripts! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 8/7/2000 17:40'!
addDestroyButtonTo: aRowMorph
	aRowMorph addMorphBack:
		((SimpleButtonMorph new label: 'X' font: Preferences standardButtonFont)
			target: self;
			color:  Color lightRed;
			actionSelector: #destroyScript;
			setBalloonText: 
'Destroy this script
(CAUTION!!!!)').
	^ aRowMorph! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 8/8/2000 13:35'!
addDismissButtonTo: aRowMorph
	aRowMorph addMorphBack:
		((SimpleButtonMorph new label: 'O' font: Preferences standardButtonFont)
			target: self;
			color:  Color tan;
			actionSelector: #dismiss;
			setBalloonText: 
'Remove this script
from the screen
(you can open it
again from a Viewer)').
	^ aRowMorph! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'tk 11/16/2000 20:43'!
addYesNoToHand

	| ms messageNodeMorph |
	(self world valueOfProperty: #universalTiles ifAbsent: [false])
		ifTrue: [ms _ MessageSend receiver: true selector: #ifTrue:ifFalse: 
						arguments: {['do nothing']. ['do nothing']}.
			messageNodeMorph _ ms asTilesIn: playerScripted class.
			"messageNodeMorph setProperty: #whoIsSelf toValue: playerScripted."
			self primaryHand attachMorph: messageNodeMorph]
		ifFalse: [self primaryHand attachMorph: CompoundTileMorph new].! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/23/2001 11:27'!
buttonRowForEditor
	"Answer a row of buttons that comprise the header at the top of the Scriptor"

	| aRow aString aButtonMorph buttonFont aStatusMorph aButton aColumn |
	buttonFont _ Preferences standardButtonFont.
	aRow _ AlignmentMorph newRow color: Color transparent; layoutInset: 0.
	aRow hResizing: #shrinkWrap.
	aRow vResizing: #shrinkWrap.

	aRow addMorphFront:
		(SimpleButtonMorph new
			label: '!!' font: (StrikeFont familyName: #ComicBold size: 16);
			target: self;
			color: Color yellow;
			borderWidth: 0;
			actWhen: #whilePressed;
			actionSelector: #tryMe;
			balloonTextSelector: #tryMe).
	aRow addTransparentSpacerOfSize: 6@10.
	self addDismissButtonTo: aRow.
	aRow addTransparentSpacerOfSize: 6@1.
	aColumn _ AlignmentMorph newColumn beTransparent.
	aColumn addTransparentSpacerOfSize: 0@4.
	aButton _ UpdatingThreePhaseButtonMorph checkBox.
	aButton
		target: self;
		actionSelector: #toggleWhetherShowingTiles;
		getSelector: #showingMethodPane.
	aButton setBalloonText: 'toggle between showing tiles and showing textual code'.
	aColumn addMorphBack: aButton.
	aRow addMorphBack: aColumn.

	aRow addTransparentSpacerOfSize: 6@10.

	aString _ playerScripted externalName, ' ', self scriptTitle.
	aRow addMorphBack:
		(aButtonMorph _ SimpleButtonMorph new useSquareCorners label: aString font: buttonFont; target: self; setNameTo: 'title').
	aButtonMorph actWhen: #buttonDown; actionSelector: #offerScriptorMenu.
	aButtonMorph borderColor: (Color fromRgbTriplet: #(0.065 0.258 1.0)).
	aButtonMorph color: ScriptingSystem uniformTileInteriorColor.
	aButtonMorph balloonTextSelector: #offerScriptorMenu.
	aRow addMorphBack: (aStatusMorph _ self scriptInstantiation statusControlMorph).

	aRow addTransparentSpacerOfSize: 6@1.

	aRow addMorphBack:
		(IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: 'AddTest'); color: Color transparent; 
			actWhen: #buttonDown;
			target: self;
			actionSelector: #addYesNoToHand;
			shedSelvedge;
			balloonTextSelector: #addYesNoToHand).
	aRow addTransparentSpacerOfSize: 12@10.
	self addDestroyButtonTo: aRow.
	self scriptInstantiation updateStatusMorph: aStatusMorph.
	^ aRow! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'RAA 6/12/2000 09:02'!
chooseFrequency
	| currentFrequency aMenu |
	currentFrequency _ self scriptInstantiation frequency.
	currentFrequency = 0 ifTrue: [currentFrequency _ 1].
	aMenu _ MenuMorph new defaultTarget: self.
	#(1 2 5 10 25 50 100 1000 5000 10000) do:
		[:i | aMenu add: i printString selector: #setFrequencyTo: argument: i].
	
	aMenu add: 'other...' action: #typeInFrequency.
	aMenu addTitle: 'Choose frequency (current: ', currentFrequency printString, ')'.
	aMenu  popUpEvent: self currentEvent in: self world! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/23/2001 10:53'!
chooseTrigger
	"NB; the keyStroke branch commented out temporarily until keystrokes can actually be passed along to the user's scripting code"
	
	self presentScriptStatusPopUp! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/25/2001 09:22'!
destroyScript
	"At user request, and only after confirmation, destroy the script, thus removing it from the uniclass's method dictionary and removing its instantiations from all instances of uniclass, etc."

	(self confirm: 'Caution -- this destroys this script
permanently; are you sure you want to do this?') ifFalse: [^ self].
	true ifTrue: [^ playerScripted removeScript: scriptName fromWorld: self world].

	self flag: #deferred.  "revisit"
	(playerScripted okayToDestroyScriptNamed: scriptName)
		ifFalse:
			[^ self inform: 'Sorry, this script is being called
from another script.'].

	self actuallyDestroyScript! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/25/2001 16:25'!
dismiss
	"Dismiss the scriptor, usually nondestructively"

	owner ifNil: [^ self].
	scriptName ifNil: [^ self delete].  "ad hoc fixup for bkwrd compat"
	(playerScripted isExpendableScript: scriptName) ifTrue: [playerScripted removeScript: scriptName  fromWorld: self world].
	self delete! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/30/2001 14:29'!
editMethodDescription
	"Edit the balloon help associated with the script"

	self userScriptObject editDescription! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 10/8/1998 09:19'!
editScriptTextually
	| newBrowser |
	self becomeTextuallyCoded.
	(newBrowser _ Browser new) setClass: playerScripted class selector: scriptName.
	(Preferences valueOfFlag: #editPlayerScriptsInPlace)
		ifTrue:
			[self addTextualScript: newBrowser]
		ifFalse:
			[Browser openBrowserView: (newBrowser openMessageEditString: nil) label: ('textual script for "', scriptName, '" in ', playerScripted externalName)]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/12/98 13:24'!
install
	"Keep me for editing"

	self removeSpaces.
	scriptName ifNotNil:
		[playerScripted acceptScript: self topEditor for:  scriptName asSymbol]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/12/98 13:25'!
installWithNewLiteral

	self removeSpaces.
	scriptName ifNotNil:
		[playerScripted ifNotNil: [playerScripted acceptScript: self topEditor for:  scriptName]]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 10/21/1999 12:34'!
makeIsolatedCodePane
	MethodHolder makeIsolatedCodePaneForClass: playerScripted class selector: scriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 18:30'!
playerScripted
	^ playerScripted! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'RAA 9/24/2000 17:50'!
replaceRow1

	submorphs first delete.  "the button row"
	self addMorphFront: self buttonRowForEditor.  "up to date"
! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 03:26'!
scriptName
	^ scriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 2/2/1999 10:51'!
scriptTitle
	^ scriptName! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 1/29/98 18:37'!
scriptee
	| editor |
	playerScripted ifNotNil: [^ playerScripted].
	(editor _ self topEditor) == self ifTrue: [self error: 'unattached script editor'. ^ nil].
	^ editor scriptee! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'tk 1/31/2001 10:06'!
showSourceInScriptor
	"Remove tile panes, if any, and show textual source instead"

	| aCodePane |

	self isTextuallyCoded ifFalse: [self becomeTextuallyCoded].
		"Mostly to fix up grandfathered ScriptEditors"

	self submorphs allButFirst do: [:m | m delete].

	aCodePane _ MethodHolder 
		isolatedCodePaneForClass: playerScripted class 
		selector: scriptName.

	aCodePane
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		minHeight: 100.
	self 
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	self addMorphBack: aCodePane.
	self fullBounds.
	self 
		listDirection: #topToBottom;
		hResizing: #rigid;
		vResizing: #rigid;
		rubberBandCells: true;
		minWidth: self width.

	showingMethodPane _ true.
	(playerScripted isUniversalTiles) ifTrue: [self useNewTilesNow].
			"grab aCodePane, get model, and remove it" 

	self currentWorld startSteppingSubmorphsOf: self! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 10/30/2000 11:10'!
tryMe
	"Evaluate the given script on behalf of the scripted object"

	self playerScripted perform: scriptName asSymbol

! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'RAA 9/24/2000 17:50'!
updateStatus
	"Update that status in the receiver's header"

	(self topEditor == self) ifTrue: [
		(self firstSubmorph findA: ScriptStatusControl) ifNil: [self replaceRow1].
		self updateStatusMorph: (self firstSubmorph findA: ScriptStatusControl)
	]! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'sw 9/18/2000 16:53'!
updateStatusMorph: statusMorph
	"my status button may need to reflect an externally-induced change in status"

	self scriptInstantiation updateStatusMorph: statusMorph.! !

!ScriptEditorMorph methodsFor: 'buttons' stamp: 'di 1/31/2001 11:37'!
useNewTiles
	| ww |
	"At the next request for textual script, use new tiles instead.  Make that request."

	ww _ self bestGuessOfCurrentWorld.
	(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifFalse: [
		ww setProperty: #universalTiles toValue: true.
	 		"for all scriptors and viewers in this world"
		"force viewers to be recreated"
		ww flapTabs do: [:ff | (ff isMemberOf: ViewerFlapTab) ifTrue: [
							ff referent delete.  ff delete]].
		Utilities clobberFlapTabList].
	Preferences enable: #capitalizedReferences.
	self showSourceInScriptor.   "**This does way more than necess, AND kills the shrinkWrap..."
	self hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellPositioning: #topLeft.
! !


!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'RAA 1/16/2001 01:34'!
revertToTileVersion
	"The receiver, currently showing textual code,  is asked to revert to the last-saved tile version"

	| aUserScript |

	self 
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	aUserScript _ playerScripted class userScriptForPlayer: playerScripted selector: scriptName.
	aUserScript revertToLastSavedTileVersionFor: self.
	self currentWorld startSteppingSubmorphsOf: self! !

!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'sw 5/19/1998 14:12'!
saveScriptVersion
	self userScriptObject saveScriptVersion: self setTimeStamp! !

!ScriptEditorMorph methodsFor: 'save & revert' stamp: 'sw 1/30/2001 12:18'!
savedTileVersionsCount
	"Answer the number of saved tile versions that currently exist for this script"

	^ self userScriptObject savedTileVersionsCount! !


!ScriptEditorMorph methodsFor: 'other' stamp: 'tk 2/1/2001 22:37'!
adaptToWorld: aWorld

	self unhibernate	"for universal tiles"! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 10/14/97 12:32'!
appendTileRows: tileRows
	"Append the given rows of tiles to my script."

	tileRows do: [:r | self insertTileRow: r after: submorphs size].
	self removeSpaces.
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 13:34'!
becomeTextuallyCoded
	"If the receiver is not currently textually coded, make it become so now, and show its source in place in the Scriptor"

	self isTextuallyCoded ifTrue: [^ self].
	self saveScriptVersion.
	self userScriptObject becomeTextuallyCoded.
	(submorphs copyFrom: 2 to: submorphs size) do: [:m | m delete]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/11/98 18:03'!
browseScripts
	 Browser newOnClass: playerScripted class label: 'Compiled scripts for ', playerScripted externalName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 9/2/1999 15:16'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 5/2/1998 15:03'!
colorWhenRunning
	^ ScriptingSystem colorBehindTiles! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 12/28/1998 11:34'!
explainStatusAlternatives
 	(StringHolder new contents: ScriptingSystem statusHelpString)
		openLabel: 'Script Status'! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/23/98 01:07'!
hasScriptInvoking: aScriptName ofPlayer: aPlayer
	"Answer whether the receiver has any tiles in it which invoke the given script of the given player.  Place-holder for now, needs to be implemented"
	^ false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/29/1999 16:34'!
hasScriptReferencing: aSlotName ofPlayer: aPlayer
	"Answer whether the receiver has any tiles in it which reference the given slot of the given player.  Place-holder for now, needs to be implemented"

	self flag: #deferred.  "a feature whose time has now just about come?!!"
	^ false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/1/2001 23:02'!
hibernate
	"Possibly delete the tiles."

	| ww |
	(ww _ self world) 
		ifNil: [(playerScripted == nil or: [playerScripted isUniversalTiles]) ifFalse: [^ self]]
		ifNotNil:
			[(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifFalse: [^ self]].

	submorphs size > 1 ifTrue: [submorphs second delete].! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 7/16/1999 16:35'!
isEmpty
	^ submorphs size < firstTileRow! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 8/3/1998 15:08'!
isTextuallyCoded
	(self topEditor isKindOf: ScriptEditorMorph) ifFalse: [^ false].  "workaround for the case where the receiver is embedded in a free-standing CompoundTileMorph.  Yecch!!"
	^ self userScriptObject isTextuallyCoded! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 4/21/1998 21:34'!
isTileScriptingElement
	^ true! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/12/98 13:37'!
markEdited
	"A hook called in several places in the UI when something has been dragged & dropped into or out of the script."

	self install.
	"self stopScript"! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 9/2/1999 15:15'!
methodString
	^ String streamContents:
		[:aStream |
			aStream nextPutAll: scriptName; cr; cr; tab.
			aStream nextPutAll: self codeString]
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'ar 11/9/2000 18:46'!
minWidth

	^160! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 12:15'!
modernize
	"If the receiver appears to date from the past, try to fix it up"
	
	(self isTextuallyCoded and: [self showingMethodPane not]) ifTrue:
		["Fix up old guys that  are not showing the code in place"
		self showSourceInScriptor]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 2/2/1999 11:20'!
modernizeScript
	"Invoked at user menu request to fix up an anonymous script editor"
	| oldSelector newSelector oldStatus aPosition oldOwner |
	oldSelector _ self scriptName.
	newSelector _ (oldSelector asString copyReplaceAll: 'xxxS' with: 's') asSymbol.

	oldStatus _ self scriptInstantiation status.
	scriptName _ newSelector.
	playerScripted class atSelector: scriptName putScriptEditor: self.
	self scriptInstantiation status: oldStatus.
	playerScripted class removeScriptNamed: oldSelector.
	playerScripted actorState instantiatedUserScriptsDictionary removeKey: oldSelector.
	submorphs first delete.  "the button row"
	self addMorphFront: self buttonRowForEditor.  "up to date"
	self install.
	aPosition _ self position.
	oldOwner _ self topRendererOrSelf owner.
	self delete
	playerScripted costume viewAfreshIn: oldOwner showingScript: scriptName at: aPosition! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 18:23'!
offerScriptorMenu
	"Put up a menu in response to the user's clicking in the menu-request area of the scriptor's heaer"

	| aMenu  count |

	self modernize.
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: scriptName asString.
	count _ self savedTileVersionsCount.

	self showingMethodPane
		ifFalse:				"currently showing tiles"
			[aMenu add: 'show code textually' action: #showSourceInScriptor.
			count > 0 ifTrue: 
				[aMenu add: 'revert to tile version...' action:	 #revertScriptVersion].
			aMenu add: 'save this version'	action: #saveScriptVersion]

		ifTrue:				"current showing textual source"
			[count >= 1 ifTrue:
				[aMenu add: 'revert to tile version' action: #revertToTileVersion].
			aMenu add: 'make tiles from this code' action: #recreateTileVersion].
	Preferences noviceMode ifFalse: ["just for now, not for kids"
		aMenu add: 'use new universal tiles' action: #useNewTiles].
			

	aMenu addList: #(
		-
		('destroy this script'					destroyScript)
		('rename this script'					renameScript)
		-
		('fires per tick...'					chooseFrequency)
		('explain status alternatives' 		explainStatusAlternatives)
		('hand me a tile for self'			tileForSelf)
		('edit balloon help for this script'	editMethodDescription)
		('button to fire this script'			tearOfButtonToFireScript)
		 ).

	aMenu popUpInWorld: self currentWorld.

	"		('add parameter to this script'	addParameter)"
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 18:56'!
reinsertSavedTiles: savedTiles
	"Revert the scriptor to show the saved tiles"

	self submorphs doWithIndex: [:m :i | i > 1 ifTrue: [m delete]].
	self addAllMorphs: savedTiles.
	self allMorphsDo: [:m | m isTileScriptingElement ifTrue: [m bringUpToDate]].
	self install.
	self showingMethodPane: false! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'tk 1/30/2001 23:21'!
releaseCachedState

	super releaseCachedState.
	self hibernate.! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/22/2001 15:22'!
renameScript
	"Rename the current script.  Invoked at user menu request"

	playerScripted renameScript: self scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/22/2001 15:45'!
renameScriptTo: newSelector
	"Rename the receiver's script so that it has given new selector"

	| labelButton |
	scriptName _ newSelector.
	labelButton _ self firstSubmorph submorphs seventh.
	labelButton label: (playerScripted externalName, ' ', self scriptTitle) font: Preferences standardButtonFont.
	self install! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 4/30/1998 13:46'!
revertScriptVersion
	| aUserScript |
	aUserScript _ playerScripted class userScriptForPlayer: playerScripted selector: scriptName.
	aUserScript revertScriptVersionFrom: self! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 12/31/1998 17:54'!
setTimeStamp
	timeStamp _ Date today mmddyyyy, ' ', (Time now print24 copyFrom: 1 to: 8).
	^ timeStamp! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'jm 5/29/1998 10:43'!
storeCodeOn: aStream indent: tabCount

	| lastOwner |
	lastOwner _ nil.
	self tileRows do: [:r |
		r do: [:m |
			((m isKindOf: TileMorph) or:
			 [(m isKindOf: CompoundTileMorph) or:
			 [m isKindOf: PhraseTileMorph]]) ifTrue: [
				tabCount timesRepeat: [aStream tab].
				((m owner ~= lastOwner) and: [lastOwner ~= nil])
					ifTrue:
						[aStream nextPut: $.; cr; tab.
						m storeCodeOn: aStream indent: tabCount]
					ifFalse:
						[(lastOwner ~= nil) ifTrue: [aStream space].
						m storeCodeOn: aStream indent: tabCount].
				lastOwner _ m owner]]].
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 10/5/1999 18:07'!
tearOfButtonToFireScript
	| aButton |
	aButton _ ScriptActivationButton new target: playerScripted.
	aButton actionSelector: #runScript:.
	aButton arguments: (Array with: scriptName).
	aButton establishLabelWording.
	self currentHand attachMorph: aButton! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/30/2001 18:27'!
tileForSelf
	"Return a tile representing the player who is current the 'self' of this script"

	| aTileMorph |
	aTileMorph _ TileMorph new
		setObjectRef: nil "disused parm" actualObject: playerScripted;
		typeColor: (ScriptingSystem colorForType: #player); yourself.
	aTileMorph enforceTileColorPolicy.
	aTileMorph openInHand! !

!ScriptEditorMorph methodsFor: 'other'!
tileRows
	"Return an collection of arrays of Tiles in which each array is one line of tiles."

	| rows r |
	rows _ OrderedCollection new.
	firstTileRow to: submorphs size do: [:i |
		r _ submorphs at: i.
		r submorphCount > 0 ifTrue: [rows addLast: r submorphs]].
	^ rows
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 1/29/98 18:02'!
timeStamp
	^ timeStamp! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 10/18/2000 10:13'!
toggleWhetherShowingTiles
	"Toggle between showing the method pane and showing the tiles pane"

	self showingMethodPane
		ifFalse:				"currently showing tiles"
			[self showSourceInScriptor]
		ifTrue:				"current showing textual source"
			[self savedTileVersionsCount >= 1
				ifTrue:
					[self revertToTileVersion]
				ifFalse:
					[self beep]]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'sw 10/13/97 08:54'!
topEditor
	| editor |
	editor _ self outermostMorphThat: [:m | (m isKindOf: ScriptEditorMorph) or:
		 [m isKindOf: CompoundTileMorph]].
	^ editor ifNil: [self] ifNotNil: [editor]! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'tk 2/1/2001 22:02'!
unhibernate
	| ww |
	"Recreate my tiles from my method.  If I have new universal tiles."

	(ww _ self world) 
		ifNil: [playerScripted ifNil: [^ self].
			playerScripted isUniversalTiles ifFalse: [^ self]]
		ifNotNil: [
			(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifFalse: [^ self]].

	self showSourceInScriptor. 
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'di 1/31/2001 10:13'!
useNewTilesNow
	| mp source aSelector aClass tree syn widget |
	"First make it show source with a method pane, then substitute tiles!!"

	(mp _ self findA: MethodMorph) ifNil: [^ self].	"code pane must be present"
	aSelector _ mp model selectedMessageName.
	aClass _ mp model selectedClassOrMetaClass.
	source _ aClass sourceCodeAt: aSelector.    
	tree _ Compiler new 
		parse: source 
		in: aClass 
		notifying: nil.
	(syn _ tree asMorphicSyntaxUsing: SyntaxMorph)
		parsedInClass: aClass.
	widget _ syn inAScrollPane.
	widget color: Color transparent;
		setProperty: #hideUnneededScrollbars toValue: true;
		setProperty: #maxAutoFitSize toValue: 300@200.
	mp delete.
	self addMorphBack: widget.
	widget extent: (self width - 10 @ 150).
! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'jm 5/28/1998 17:40'!
userScriptObject
	^ self topEditor playerScripted class userScriptForPlayer: playerScripted selector: scriptName! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'di 9/24/2000 12:54'!
worldMorphsDo: aBlock  "No worlds hiding here"

	^ self! !

!ScriptEditorMorph methodsFor: 'other' stamp: 'ar 11/9/2000 20:36'!
xxxminHeight

	| extra |
	extra _ 2 * (self layoutInset + borderWidth).
	^ (super minHeight - extra max: TileMorph defaultH) + extra
! !


!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 11/9/2000 20:43'!
addNewRow

	| row |
	row _ AlignmentMorph newRow
		vResizing: #spaceFill;
		layoutInset: 0;
		borderWidth: 0;
		extent: (bounds width)@(TileMorph defaultH);
		color: Color transparent.
	self addMorphBack: row.
	^ row
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'di 11/12/2000 15:32'!
enclosingEditor
	"Return the next scriptor outward in the containment hierarchy"
	^ self firstOwnerSuchThat:
		[:m | (m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]]! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 11/9/2000 20:43'!
insertTileRow: tileList after: index
	"Return a row to be used to insert an entire row of tiles."

	| row |
	row _ AlignmentMorph newRow
		vResizing: #spaceFill;
		layoutInset: 0;
		extent: (bounds width)@(TileMorph defaultH);
		color: Color transparent.
	row addAllMorphs: tileList.
	self privateAddMorph: row atIndex: index + 1.
! !

!ScriptEditorMorph methodsFor: 'private'!
labelForButton

	self tileRows do: [:r |
		r do: [:t |
			t type = #operator ifTrue: [^ t operatorOrExpression]]].
	^ 'button'
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'ar 1/27/2001 14:44'!
removeEmptyRows
	submorphs copy do: [:m |
		(m isAlignmentMorph and: [m submorphCount = 0])
			ifTrue: [m delete]].
self flag: #arNote. "code below lead to large and unnecessary recomputations of layouts; without it things just fly"
"	self fullBounds.
	self layoutChanged."

	self flag: #noteToJohn.  "Screws up when we have nested IFs.  got broken in 11/97 when you made some emergency fixes for some other reason, and has never worked since...  Would be nice to have a more robust reaction to this!!"
"
	self removeEmptyLayoutMorphs.

	spacer _ LayoutMorph new extent: 10@12.
	spacer vResizing: #rigid.
	self privateAddMorph: spacer atIndex: self indexForLeadingSpacer.

	spacer _ LayoutMorph new  extent: 10@12.
	spacer vResizing: #rigid.
	self privateAddMorph: spacer atIndex: (submorphs size + 1).

	self fullBounds; layoutChanged."
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'sw 2/13/98 15:44'!
rowInsertionIndexFor: aPoint
	"Return the row into which the given morph should be inserted."

	| m |
	firstTileRow to: submorphs size do: [:i |
		m _ submorphs at: i.
		((m top <= aPoint y) and: [m bottom >= aPoint y]) ifTrue:
			[(aPoint y > m center y)
				ifTrue: [^ i]
				ifFalse: [^ (i - 1) max: firstTileRow]]].
	^ firstTileRow > submorphs size
		ifTrue:
			[submorphs size]
		ifFalse:
			[(submorphs at: firstTileRow) top > aPoint y 
				ifTrue: [firstTileRow - 1]
				ifFalse: [submorphs size]]
! !

!ScriptEditorMorph methodsFor: 'private' stamp: 'sw 10/12/97 21:48'!
scriptEdited

	| anEditor |
	(anEditor _ self topEditor) ifNotNil: [anEditor markEdited]! !


!ScriptEditorMorph methodsFor: 'textually-coded scripts' stamp: 'tk 11/2/2000 11:50'!
addTextualScript: aBrowser
	"Put a message browser right into the header alignment morph"

	| window aMorph codePane |
	submorphs last class == PluggableTextMorph ifTrue: [^ self].
	window _ self.
	aMorph _ PluggableListMorph on: aBrowser list: #messageListSingleton
			selected: #indexIsOne changeSelected: #indexIsOne:
			menu: #messageListMenu:shifted:.
	aMorph bounds: (window topLeft extent: 200@12).	"will get moved"
	window addMorphBack: aMorph.
	aMorph borderWidth: 1;
		color: (Color colorFrom: aBrowser defaultBackgroundColor).

	codePane _ PluggableTextMorph on: aBrowser text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	"editString ifNotNil: [codePane editString: editString.
					codePane hasUnacceptedEdits: true]."
	codePane bounds: (window topLeft extent: 200@120).	"will get moved"
	window addMorphBack: codePane.
	codePane borderWidth: 1; retractableOrNot; "make it stay"
		color: aBrowser defaultBackgroundColor.


"	self addMorph: aMorph.
	aMorph borderWidth: 1;
		color: (Color perform: aBrowser defaultBackgroundColor);
		bounds: 
"! !

!ScriptEditorMorph methodsFor: 'textually-coded scripts' stamp: 'sw 10/30/2000 11:09'!
showingMethodPane
	"Answer whether the receiver is currently showing the textual method pane"

	^ showingMethodPane ifNil: [showingMethodPane _ false]! !

!ScriptEditorMorph methodsFor: 'textually-coded scripts' stamp: 'tk 11/14/2000 13:54'!
showingMethodPane: val
	"Whether the receiver will show the textual method pane"

	showingMethodPane _ val! !


!ScriptEditorMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 16:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
playerScripted _ deepCopier references at: playerScripted ifAbsent: [playerScripted].
! !

!ScriptEditorMorph methodsFor: 'copying' stamp: 'tk 11/2/2000 11:42'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	scriptName _ scriptName veryDeepCopyWith: deepCopier.
	firstTileRow _ firstTileRow veryDeepCopyWith: deepCopier.
	timeStamp _ timeStamp veryDeepCopyWith: deepCopier.
	playerScripted _ playerScripted.		"Weakly copied"
	handWithTile _ handWithTile.  "Just a cache"
	showingMethodPane _ showingMethodPane.	"boolean"
! !


!ScriptEditorMorph methodsFor: 'frequency' stamp: 'sw 4/21/1999 09:12'!
setFrequencyTo: aNumber
	self scriptInstantiation frequency: aNumber! !

!ScriptEditorMorph methodsFor: 'frequency' stamp: 'sw 4/21/1999 11:14'!
typeInFrequency
	| reply aNumber |
	reply _ FillInTheBlank request: 'Number of firings per tick: ' initialAnswer: self scriptInstantiation frequency printString.

	reply ifNotNil:
		[aNumber _ reply asNumber.
		aNumber > 0 ifTrue:
			[self setFrequencyTo: aNumber]]! !


!ScriptEditorMorph methodsFor: 'tiles from method' stamp: 'tk 8/3/1999 12:45'!
fromExistingMethod: aSelector forPlayer: aPlayer 
	"Create tiles for this method.  "

	| parseTree |
	self initialize.
	playerScripted _ aPlayer.
	self setMorph: aPlayer costume scriptName: aSelector.
	parseTree _ (Decompiler new) decompile: aSelector
		in: aPlayer class 
		method: (aPlayer class compiledMethodAt: aSelector).
	self tilesFrom: parseTree.
	self install.! !

!ScriptEditorMorph methodsFor: 'tiles from method' stamp: 'sw 10/26/2000 14:47'!
recreateTileVersion
	"The receiver, currently showing textual code, is asked to create fresh tiles by decompiling the code of the textual script."

	| parseTree |

	true ifTrue: [^ self inform: 'No, this is really Under Construction!!
Not yet available'].

	parseTree _ Decompiler new decompile: scriptName
		in: playerScripted class 
		method: (playerScripted class compiledMethodAt: scriptName).
	self tilesFrom: parseTree.

	self flag: #noteToTed.   "Ted, see my notes in #tilesFrom:"
	self install.! !

!ScriptEditorMorph methodsFor: 'tiles from method' stamp: 'tk 8/6/1999 14:13'!
tilesFrom: parseTree
	"Fill myself with tiles to corresponding to an existing method.  parseTree is the MethodNode that is the top of a parse tree.  Or a BlockNode or MessageNode for ifTrue:ifFalse:."
	"ignore the method's arguments for now"

	| lineOfTiles list ignore ind | 
	list _ (parseTree isKindOf: MessageNode)
		ifFalse: [parseTree block statements]	"normal MethodNode or BlockNode"
		ifTrue: [Array with: parseTree].
	ind _ 0.
	list do: [:msgNode |
		ignore _ msgNode isKindOf: ReturnNode.	"^ self  Will have to allow this someday"
		(msgNode isKindOf: VariableNode) ifTrue: [
			msgNode key = 'nil' ifTrue: [ignore _ true]]. 
		ignore ifFalse: ["for now ignore the (^ self) statement"
			lineOfTiles _ Array with: (PhraseTileMorph new tilesFrom: msgNode in: self).
			self insertTileRow: lineOfTiles after: (ind _ ind + 1)
			]].! !


!ScriptEditorMorph methodsFor: 'drawing' stamp: 'tk 2/3/2001 02:31'!
drawOn: aCanvas
	| ww |
	"need to unhibernate"

	(ww _ self world) ifNotNil: ["don't hunt agressively for a world"
		(ww valueOfProperty: #universalTiles ifAbsent: [false]) ifTrue: [
			self submorphs size < 2 ifTrue: [
				WorldState addDeferredUIMessage: [self unhibernate] fixTemps]]].
	^ super drawOn: aCanvas! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptEditorMorph class
	instanceVariableNames: ''!

!ScriptEditorMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !

!ScriptEditorMorph class methodsFor: 'instance creation' stamp: 'tk 1/31/2001 09:48'!
writingUniversalTiles
	"Only valid during the write of a Project."

	^ WritingUniversalTiles! !

!ScriptEditorMorph class methodsFor: 'instance creation' stamp: 'tk 1/31/2001 09:48'!
writingUniversalTiles: boolean

	WritingUniversalTiles _ boolean! !
ScriptEditorMorph subclass: #ScriptEvaluatorMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ScriptEvaluatorMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:43'!
initializeFor: aPhraseTileMorph
	| lm aStatus |
	self playerScripted: aPhraseTileMorph actualObject.
	scriptName _ aPhraseTileMorph userScriptSelector.
	self removeAllMorphs.
	self addMorphFront: (lm _ AlignmentMorph newRow).
	lm color: Color transparent; layoutInset: 0.
	lm vResizing: #shrinkWrap.
	lm addMorphBack: (ScriptingSystem tryButtonFor: aPhraseTileMorph).
	lm addTransparentSpacerOfSize: 6@1.
	lm addMorphBack: aPhraseTileMorph beSticky.
	lm addTransparentSpacerOfSize: 4@1.
	
	aStatus _ (playerScripted scriptInstantiationForSelector: scriptName) status.
	lm addMorphBack:
			(SimpleButtonMorph new label: aStatus font: Preferences standardButtonFont;
				setNameTo: 'trigger';
				target: self;
				actWhen: #buttonDown;
				actionSelector: #chooseTrigger).
	lm addTransparentSpacerOfSize: 4@1.
	self addDismissButtonTo: lm.
	self disableDragNDrop.
	lm enableDragNDrop! !


!ScriptEvaluatorMorph methodsFor: 'drag and drop' stamp: 'sw 2/5/98 00:02'!
acceptDroppingMorph: aMorph event: evt
	(aMorph isKindOf: PhraseTileMorph) ifTrue: [^ self].
	^ super acceptDroppingMorph: aMorph event: evt! !

!ScriptEvaluatorMorph methodsFor: 'drag and drop' stamp: 'sw 5/18/1998 16:08'!
insertTileRow: tileList after: index
	"Return a row to be used to insert an entire row of tiles."

	self isThisEverCalled.   "an error if so.... evaluator can't add or delete rows"! !

!ScriptEvaluatorMorph methodsFor: 'drag and drop' stamp: 'sw 2/16/98 04:31'!
rowInsertionIndexFor: aPoint
	^ nil
! !

!ScriptEvaluatorMorph methodsFor: 'drag and drop' stamp: 'panda 4/25/2000 14:15'!
wantsDroppedMorph: aMorph event: evt
	^ false   "though later we could drop onto formal args in the header"! !


!ScriptEvaluatorMorph methodsFor: 'display' stamp: 'ar 11/9/2000 20:43'!
setDefaultBorderCharacteristics	
	borderWidth _ 2.
	borderColor _ Color blue.
	self layoutInset: 2.
	self useRoundedCorners

! !


!ScriptEvaluatorMorph methodsFor: 'stepping' stamp: 'sw 2/4/98 01:04'!
step
	"Don't do what ScriptEditors do about playing footsie with PhraseTileMorphs"! !
Object subclass: #ScriptInstantiation
	instanceVariableNames: 'player selector status frequency anonymous '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!ScriptInstantiation commentStamp: '<historical>' prior: 0!
One of these is associated with each user-defined script for each Player.   Holds the state that defines when the script should be run automatically by the system.

	player				The player whose script this is.
	selector				The message to send my player to activate this script
	status				#ticking, #paused, #normal, #mouseDown, #mouseStillDown, #mouseUp,
							#mouseEnter, #mouseLeave, #keyStroke
	frequency			For ticking scripts, their frequency.  Place-holder: not implemented yet
	anonymous			If true, the script has is unnamed -- in this case, the selector is private to the implementation!


!ScriptInstantiation methodsFor: 'anonymity' stamp: 'sw 10/30/2000 11:08'!
initializePermanentScriptFor: aPlayer selector: aSelector
	"Initialize the receiver on behalf of the player, setting its status to #normal and giving it the given selector"

	player _ aPlayer.
	status _ #normal.
	selector _ aSelector! !


!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 1/28/2001 16:06'!
changeSelectorTo: aNewSelector
	"Change the selector associated with the receiver to the new one provided"

	selector _ aNewSelector! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 4/30/1998 14:06'!
player
	^ player! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 5/13/1998 10:43'!
player: p
	"Needed for making duplicate players, otherwise private"
	player _ p! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 5/1/1998 21:33'!
player: p selector: s
	self player: p selector: s status: #normal! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 5/1/1998 21:33'!
player: p selector: s status: st
	frequency _ 0.
	status _ st.
	player _ p.
	selector _ s! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 4/30/1998 14:07'!
selector
	^ selector! !

!ScriptInstantiation methodsFor: 'player & selector access' stamp: 'sw 4/30/1998 14:07'!
selector: sel
	selector _ sel! !


!ScriptInstantiation methodsFor: 'running' stamp: 'sw 7/3/1998 20:20'!
runIfClosing
	| result |
	(result _ status == #closing) ifTrue:
		[player perform: selector].
	^ result! !

!ScriptInstantiation methodsFor: 'running' stamp: 'sw 7/3/1998 20:19'!
runIfOpening
	| result |
	(result _ status == #opening) ifTrue:
		[player perform: selector].
	^ result! !

!ScriptInstantiation methodsFor: 'running' stamp: 'sw 4/21/1999 09:26'!
runIfTicking
	status == #ticking ifTrue:
		[1 to: self frequency do:
			[:i | player perform: selector]]! !

!ScriptInstantiation methodsFor: 'running' stamp: 'sw 9/21/2000 10:38'!
startRunningIfPaused
	"If the receiver is paused, start it ticking"

	status == #paused ifTrue:
		[status _ #ticking.
		self updateAllStatusMorphs]! !

!ScriptInstantiation methodsFor: 'running' stamp: 'sw 9/18/2000 19:43'!
stopTicking
	"If I'm ticking stop, else do nothing"

	status == #ticking ifTrue:
		[status _ #paused.
		self updateAllStatusMorphs]! !


!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/15/2001 01:28'!
assignStatusToAllSiblings
	"Let all sibling instances of my player have the same status that I do"

	(player class allInstances copyWithout: player) do:
		[:aPlayer |
			(aPlayer scriptInstantiationForSelector: selector) status: status]! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/15/2001 01:58'!
assignStatusToAllSiblingsIn: aStatusViewer
	"Let all sibling instances of my player have the same status that I do"

	self assignStatusToAllSiblings.
	self currentWorld presenter updateContentsFor: aStatusViewer ! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 5/13/1998 13:06'!
assureEventHandlerRepresentsStatus
	self status: self status! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 5/2/1998 02:05'!
copyWithPlayerObliterated
	| holdPlayer copy |
	holdPlayer _ player.
	player _ nil.
	copy _ self deepCopy.
	player _ holdPlayer.
	^ copy ! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/19/2001 02:32'!
offerMenuIn: aStatusViewer
	"Put up a menu."

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	(player class instanceCount > 1) ifTrue:
		[aMenu add: 'propagate status to siblings' selector: #assignStatusToAllSiblingsIn: argument: aStatusViewer.
		aMenu balloonTextForLastItem: 'Make the status of this script in all of my sibling instances be the same as the status you see here'].
	aMenu add: 'grab this object' target: player selector: #grabPlayerIn: argument: self currentWorld.
	aMenu add: 'open this script''s scriptor' target: player selector: #grabScriptorForSelector:in: argumentList: {selector. aStatusViewer world}.
	aMenu popUpInWorld: self currentWorld! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/19/2001 17:45'!
playersExternalName
	"Answer the external name of my player"

	^ player externalName! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/29/2001 02:51'!
printOn: aStream
	"Print the receiver on aStream"

	super printOn: aStream.
	aStream nextPutAll: ' for #', selector asString! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 1/15/2001 19:33'!
statusControlRowIn: aStatusViewer
	"Answer a row morph that reports my status and lets the user change it"

	| aRow aMorph buttonWithPlayerName |
	aRow _ AlignmentMorph newRow beTransparent.
	buttonWithPlayerName _ UpdatingSimpleButtonMorph new.
	buttonWithPlayerName target: self; wordingSelector: #playersExternalName; actionSelector: #offerMenuIn:; arguments: {aStatusViewer}; beTransparent; actWhen: #buttonDown.
	buttonWithPlayerName setBalloonText: 'This is the name of the player to which this script belongs; if you click here, you will get a menu of interesting options pertaining to this player and script'.
	aRow addMorphBack: buttonWithPlayerName.
	aRow addTransparentSpacerOfSize: 10@0.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.

	aMorph _ UpdatingStringMorph on: self selector: #selector.
	aMorph color: Color brown lighter; useStringFormat.
	aMorph setBalloonText: 'This is the name of a script'.
	aRow addMorphBack: aMorph.
	aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer.
	aRow addTransparentSpacerOfSize: 10@0.

	aRow addMorphBack: self statusControlMorph.
	aRow submorphsDo: [:m | m wantsSteps ifTrue: [m step]].
	^ aRow! !

!ScriptInstantiation methodsFor: 'misc' stamp: 'sw 4/30/1998 13:47'!
userScriptObject
	"Answer the UserScript object in the receiver's class that holds on to the editing state for this script"

	^ player class userScriptForPlayer: player selector: selector! !


!ScriptInstantiation methodsFor: 'frequency' stamp: 'sw 4/21/1999 09:13'!
frequency
	(frequency == nil or: [frequency = 0]) ifTrue: [frequency _ 1].
	^ frequency! !

!ScriptInstantiation methodsFor: 'frequency' stamp: 'sw 4/21/1999 09:13'!
frequency: aNumber
	frequency _ aNumber! !


!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 1/31/2001 19:16'!
chooseTriggerFrom: ignored
	"Backward compatibility for old scriptors"

	^ self presentScriptStatusPopUp! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/18/2000 16:54'!
explainStatusAlternatives
	"Open a little window that explains the various status alternatives"

 	(StringHolder new contents: ScriptingSystem statusHelpString)
		openLabel: 'Script Status'! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 1/23/2001 10:59'!
presentScriptStatusPopUp
	"Put up a menu of status alternatives and carry out the request"

	| aMenu reply standardStati  m |
	"NB; the keyStroke branch commented out temporarily until keystrokes can actually be passed along to the user's scripting code"

	standardStati _ #(normal paused ticking mouseDown mouseStillDown mouseUp mouseEnter mouseLeave mouseEnterDragging mouseLeaveDragging opening closing "keyStroke").
	aMenu _ SelectionMenu labelList:  #(
		'normal'		" -- run when called"		
		'paused' 		"ready to run all the time"
		'ticking'		"run all the time"
		'mouseDown'	"run when mouse goes down on me"
		'mouseStillDown'	"while mouse still down"
		'mouseUp'		"when mouse comes back up"
		'mouseEnter'	"when mouse enters my bounds, button up"
		'mouseLeave'	"when mouse exits my bounds, button up"
		'mouseEnterDragging'	"when mouse enters my bounds, button down"
		'mouseLeaveDragging'	"when mouse exits my bounds, button down"
		'opening'	"when I am being opened"
		'closing'	"when I am being closed"
	"	'keyStroke'	run when user hits a key"
		'what do these mean?'
		'apply my status to all siblings'
		)
		lines: #(1 3 6 10 12 13)
		selections: (standardStati, #(explainStatusAlternatives assignStatusToAllSiblings)).

	reply _ aMenu startUpWithCaption: 'When should this script run?'.
	(reply == #keyStroke) ifTrue: [^ self inform: 'user-scripted fielding
of keystrokes is not
yet available.'].

	reply == #explainStatusAlternatives ifTrue: [^ self explainStatusAlternatives].
	reply == #assignStatusToAllSiblings ifTrue: [^ self assignStatusToAllSiblings].
	reply ifNotNil: 
		[self status: reply.  "Gets event handlers fixed up"
		reply == #paused ifTrue:
			[m _ player costume.
			(m isKindOf: SpeakerMorph) ifTrue: [m stopSound]].
		self updateAllStatusMorphs]! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 4/30/1998 14:10'!
status
	status ifNil: [status _ #normal].
	^ status! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'ar 10/25/2000 18:26'!
status: newStatus
	| stati actualMorph |
	actualMorph _ player costume renderedMorph.
	stati _ ScriptingSystem standardEventStati.
	(stati includes: status) ifTrue:[
		actualMorph on: status send: nil to: nil.  			"remove old link in event handler"
		status == #mouseStillDown ifTrue:[actualMorph on: #mouseDown send: nil to: nil]].
	(stati includes: newStatus) ifTrue:[
		actualMorph on: newStatus send: selector to: player.  "establish new link in evt handler"
		newStatus == #mouseStillDown ifTrue:[actualMorph on: #mouseDown send: selector to: player]].
	status _ newStatus.
	self flag: #arNote.
	self flag: #workaround. "Code below was in #chooseTriggerFrom: which did not reflect status changes from other places (e.g., the stepping/pause buttons). It is not clear why this is necessary though - theoretically, any morph should step when it has a player but alas!! something is broken and I have no idea why and where."
	status == #ticking ifTrue: [player costume arrangeToStartStepping].
! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/21/2000 10:38'!
statusControlMorph
	"Answer a control that will serve to reflect (and allow the user to change) the status of the receiver"

	^ ScriptStatusControl new initializeFor: self
! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/21/2000 10:37'!
updateAllStatusMorphs
	"Update all status morphs bound to the receiver.  Done with a sledge-hammer at present."

	(self currentWorld allMorphs select: [:m | (m isKindOf: ScriptStatusControl) and:
			[m scriptInstantiation == self]]) do:
		[:aStatusControl | self updateStatusMorph: aStatusControl]! !

!ScriptInstantiation methodsFor: 'status control' stamp: 'sw 9/18/2000 16:54'!
updateStatusMorph: statusControlMorph
	"the status control may need to reflect an externally-induced change in status"

	|  statusSymbol colorSelector statusReadoutButton |

	statusControlMorph ifNil: [^ self].
	statusSymbol _ self status.

	(#(paused ticking) includes: statusSymbol)
		ifTrue:
			[statusControlMorph assurePauseTickControlsShow]
		ifFalse:
			[statusControlMorph maybeRemovePauseTickControls].
	statusReadoutButton _ statusControlMorph submorphs last.
	colorSelector _ ScriptingSystem statusColorSymbolFor: statusSymbol.
	statusReadoutButton color: (Color perform: colorSelector) muchLighter.
	statusReadoutButton label: statusSymbol asString font: Preferences standardButtonFont! !
AlignmentMorph subclass: #ScriptStatusControl
	instanceVariableNames: 'tickPauseWrapper tickPauseButtonsShowing scriptInstantiation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ScriptStatusControl methodsFor: 'initialization' stamp: 'sw 9/20/2000 17:03'!
assurePauseTickControlsShow
	"Add two little buttons that allow the user quickly to toggle between paused and ticking state"

	| aButton |
	tickPauseButtonsShowing ifTrue: [^ self].
	self beTransparent.
	aButton _  UpdatingThreePhaseButtonMorph new.
	aButton image:  (ScriptingSystem formAtKey: 'PausedPicOn');
			offImage: (ScriptingSystem formAtKey: 'PausedPicOff');
			pressedImage: (ScriptingSystem formAtKey: 'PausedPicPressed');
			actionSelector: #pausedUp:with:; 
			arguments: (Array with: nil with: aButton);
			getSelector: #scriptIsPaused;
			actWhen: #buttonUp;
			target: self;
			setBalloonText:
'Pause this script for this object'.
	submorphs first "the script button wrapper" addMorphBack: aButton;
		addTransparentSpacerOfSize: (0 @ 3).
	aButton _  UpdatingThreePhaseButtonMorph new.
	aButton image:  (ScriptingSystem formAtKey: 'TickingPicOn');
			offImage: (ScriptingSystem formAtKey: 'TickingPicOff');
			pressedImage: (ScriptingSystem formAtKey: 'TickingPicPressed');
			actionSelector: #tickingUp:with:; 
			arguments: (Array with: nil with: aButton);
			actWhen: #buttonUp;
			getSelector: #scriptIsTicking;
			target: self;
			setBalloonText:
'Set this script for this object to tick'.
	submorphs first "the script button wrapper" addMorphBack: aButton.
	self currentWorld startSteppingSubmorphsOf: self.
	tickPauseButtonsShowing _ true! !

!ScriptStatusControl methodsFor: 'initialization' stamp: 'sw 1/23/2001 10:54'!
initializeFor: aScriptInstantiation
	"Answer a control that will serve to reflect and allow the user to change the status of the receiver"

	|  statusReadout |
	self hResizing: #shrinkWrap.
	scriptInstantiation _ aScriptInstantiation.
	tickPauseButtonsShowing _ false.
	tickPauseWrapper _ AlignmentMorph newColumn beTransparent; yourself.
	self addMorphBack: tickPauseWrapper.
	self addMorphBack: (statusReadout _ UpdatingSimpleButtonMorph new).
	statusReadout setNameTo: 'trigger'.
	statusReadout target: aScriptInstantiation; wordingSelector: #status; actionSelector: #presentScriptStatusPopUp.
	statusReadout setBalloonText: 'when this script should run'.
	statusReadout actWhen: #buttonDown.

	self assurePauseTickControlsShow.
	aScriptInstantiation updateStatusMorph: self! !

!ScriptStatusControl methodsFor: 'initialization' stamp: 'sw 9/21/2000 10:40'!
maybeRemovePauseTickControls
	"If we're in the business of removing pauseTick controls when we're neither paused nor ticking, then do it now.  The present take is not to remove these controls, which explains why the body of this method is currently commented out."

	"tickPauseWrapper removeAllMorphs.
	tickPauseButtonsShowing _ false"
! !


!ScriptStatusControl methodsFor: 'access' stamp: 'sw 9/21/2000 10:41'!
scriptInstantiation
	"Answer the scriptInstantiation object with which the receiver is associated"

	^ scriptInstantiation! !


!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'sw 9/18/2000 19:42'!
pausedUp: ignored with: alsoIgnored
	"The paused button was hit -- respond to it"

	(scriptInstantiation status == #paused)
		ifFalse:
			[scriptInstantiation status: #paused; updateAllStatusMorphs]
! !

!ScriptStatusControl methodsFor: 'mouse gestures' stamp: 'sw 9/18/2000 19:42'!
tickingUp: ignored with: alsoIgnored
	"The user hit the ticking control; make the status become one of ticking"

	scriptInstantiation status == #ticking
		ifFalse:
			[scriptInstantiation status: #ticking; updateAllStatusMorphs]
! !


!ScriptStatusControl methodsFor: 'script status' stamp: 'sw 9/18/2000 16:55'!
scriptIsPaused
	"Answer whether the script is paused"

	^ scriptInstantiation status == #paused! !

!ScriptStatusControl methodsFor: 'script status' stamp: 'sw 9/18/2000 16:55'!
scriptIsTicking
	"Answer whether the script is ticking"

	^ scriptInstantiation status == #ticking! !
UpdatingSimpleButtonMorph subclass: #ScriptableButton
	instanceVariableNames: 'scriptSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!ScriptableButton commentStamp: '<historical>' prior: 0!
A button intended for use with the card architecture and the user-scripting system.!


!ScriptableButton methodsFor: 'label' stamp: 'sw 10/30/2000 11:02'!
label
	"Answer a string representing the label of the receiver, returning an empty string if necessary"

	| aStringMorph |
	^ (aStringMorph _ self findA: StringMorph)
		ifNil:		['']
		ifNotNil:	[aStringMorph contents]! !

!ScriptableButton methodsFor: 'label' stamp: 'sw 10/30/2000 10:59'!
label: aString
	"Set the receiver's label as indicated"

	| aLabel |
	(aLabel _ self findA: StringMorph)
		ifNotNil:
			[aLabel contents: aString]
		ifNil:
			[aLabel _ StringMorph contents: aString font: TextStyle defaultFont.
			self addMorph: aLabel].

	self extent: aLabel extent + (borderWidth + 6).
	aLabel position: self center - (aLabel extent // 2).

	aLabel lock! !

!ScriptableButton methodsFor: 'label' stamp: 'sw 10/30/2000 10:56'!
label: aString font: aFontOrNil
	"Set the receiver's label and font as indicated"

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [Preferences standardButtonFont].
	m _ StringMorph contents: aString font: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!ScriptableButton methodsFor: 'label' stamp: 'sw 10/30/2000 11:02'!
setLabel
	"Invoked from a menu, let the user change the label of the button"

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Enter a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel font: nil].
! !


!ScriptableButton methodsFor: 'script' stamp: 'sw 10/26/2000 08:52'!
editButtonsScript
	"The user has touched my Scriptor halo-handle.  Bring up a Scriptor on the script of the button."

	| cardsPasteUp cardsPlayer anEditor |
	cardsPasteUp _ self pasteUpMorph.
	(cardsPlayer _ cardsPasteUp assuredPlayer) assureUniClass.
	anEditor _ scriptSelector
			ifNil:
				[scriptSelector _ cardsPasteUp scriptSelectorToTriggerFor: self.
				cardsPlayer newScriptEditorFor: scriptSelector usingPhraseTile: nil]
			ifNotNil:
				[(cardsPlayer class selectors includes: scriptSelector)
					ifTrue:
						[cardsPlayer scriptEditorFor: scriptSelector]
					ifFalse:
						["Method somehow got removed; I guess we start aftresh"
						scriptSelector _ nil.
						^ self editButtonsScript]].
	self currentHand attachMorph: anEditor.
! !

!ScriptableButton methodsFor: 'script' stamp: 'sw 10/10/2000 08:09'!
wantsScriptorHaloHandle
	"Answer whether the receiver would like to have a Scriptor halo handle put up on its behalf.  Initially, only the ScriptableButton says yes"

	^ true! !


!ScriptableButton methodsFor: 'miscellaneous' stamp: 'sw 10/30/2000 16:07'!
demandsThumbnailing
	"Answer whether the receiver, if in a thumbnailable parts bin, wants to be thumbnailed whether or not size requires it.  This is set to true here because the recent event rework somehow made it possible for a scriptable button to be draggable from a parts bin otherwise, maddeningly"

	^ true! !


!ScriptableButton methodsFor: 'action' stamp: 'sw 10/9/2000 06:28'!
doButtonAction
	"The user has pressed the button.  Dispatch to the actual user script, if any."

	scriptSelector ifNil: [^ super doButtonAction].
	self pasteUpMorph player perform: scriptSelector! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScriptableButton class
	instanceVariableNames: ''!

!ScriptableButton class methodsFor: 'viewer' stamp: 'sw 10/24/2000 07:59'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((button (
			(slot label 'The wording on the button' string readWrite player getLabel player setLabel:)
			(slot color 'The color of the object' color readWrite player getColor  player  setColor:)
			(slot height  'The height' number readWrite player getHeight  player  setHeight:) 
			(slot borderColor 'The color of the object''s border' color readWrite player getBorderColor player  setBorderColor:)
			(slot borderWidth 'The width of the object''s border' number readWrite player getBorderWidth player setBorderWidth:)
			(slot  height  'The height' number readWrite player getHeight  player  setHeight:)
			(slot roundedCorners 'Whether corners should be rounded' boolean readWrite player getRoundedCorners player setRoundedCorners:) 
			(slot actWhen 'When the script should fire' buttonPhase  readWrite player getActWhen player setActWhen: ))))


! !


!ScriptableButton class methodsFor: 'name' stamp: 'sw 10/30/2000 10:29'!
defaultNameStemForInstances
	"Answer the default name stem to use for instances of the receiver"

	^ 'button'! !


!ScriptableButton class methodsFor: 'authoring prototype' stamp: 'sw 10/30/2000 16:06'!
authoringPrototype
	"Answer a scriptable button that can serve as a prototype for a parts bin"

	^ super authoringPrototype
		borderWidth: 1;
		borderColor: Color black;
		useRoundedCorners;
		color: Color yellow;
		label: 'Press me';
		setNameTo: 'script1';
		yourself

"ScriptableButton authoringPrototype openInHand"! !
Model subclass: #ScriptingDomain
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!ScriptingDomain methodsFor: 'as yet unclassified' stamp: 'sw 10/5/1998 14:47'!
addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph 
	super addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph.  "nominally nothing"
	aCustomMenu add: 'take out of window' action: #takeOutOfWindow

	! !

!ScriptingDomain methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 11:39'!
defaultBackgroundColor
	^ Color r: 0.91 g: 0.91 b: 0.91! !

!ScriptingDomain methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1998 13:00'!
initialExtent
	^ 640 @ 480! !
Slider subclass: #ScrollBar
	instanceVariableNames: 'menuButton upButton downButton pagingArea scrollDelta pageDelta interval menuSelector timeOfMouseDown timeOfLastScroll nextPageDirection currentScrollDelay '
	classVariableNames: 'CachedImages UpArrow UpArrow8Bit '
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ScrollBar commentStamp: '<historical>' prior: 0!
Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic.  With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior.

Once we have this working, put in logic for horizontal operation as well.

CachedImages was added to reduce the number of forms created and thrown away. This will be helpful for Nebraska and others as well.!


!ScrollBar methodsFor: 'initialize'!
initialize
	super initialize.
	scrollDelta _ 0.02.
	pageDelta _ 0.2! !

!ScrollBar methodsFor: 'initialize' stamp: 'ar 10/7/2000 15:06'!
initializeDownButton
	downButton := RectangleMorph
		newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent)
		color: Color lightGray.
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	downButton addMorphCentered: (ImageMorph new image: 
		(self 
			cachedImageAt: (bounds isWide ifTrue: ['right'] ifFalse: ['down']) 
			ifAbsentPut: [
				self upArrow8Bit
					rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi])
					centerAt: 0@0
			]
		)
	).
	downButton setBorderWidth: 1 borderColor: #raised.
	self addMorph: downButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'di 12/6/1999 08:41'!
initializeMenuButton
	"Preferences disable: #scrollBarsWithoutMenuButton"
	"Preferences enable: #scrollBarsWithoutMenuButton"

	(Preferences valueOfFlag: #scrollBarsWithoutMenuButton) ifTrue: [^self].
	menuButton := RectangleMorph
			newBounds: (self innerBounds topLeft extent: self buttonExtent)
			color: Color lightGray.
	menuButton on: #mouseEnter send: #menuButtonMouseEnter: to: self.
	menuButton on: #mouseDown send: #menuButtonMouseDown: to: self.
	menuButton on: #mouseLeave send: #menuButtonMouseLeave: to: self.
	menuButton addMorphCentered:
		(RectangleMorph newBounds: (0@0 extent: 4@2) color: Color black).
	menuButton setBorderWidth: 1 borderColor: #raised.
	self addMorph: menuButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'ar 10/7/2000 15:07'!
initializePagingArea
	pagingArea := RectangleMorph newBounds: self totalSliderArea
								color: (Color r: 0.6 g: 0.6 b: 0.8).
	pagingArea borderWidth: 0.
	pagingArea on: #mouseDown send: #scrollPageInit: to: self.
	pagingArea on: #mouseUp send: #finishedScrolling to: self.
	self addMorph: pagingArea! !

!ScrollBar methodsFor: 'initialize'!
initializeSlider
	self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea.
	super initializeSlider! !

!ScrollBar methodsFor: 'initialize' stamp: 'ar 10/7/2000 15:06'!
initializeUpButton
	upButton := RectangleMorph
		newBounds: ((menuButton ifNil: [self innerBounds topLeft]
				ifNotNil: [bounds isWide ifTrue: [menuButton bounds topRight]
									ifFalse: [menuButton bounds bottomLeft]])
					extent: self buttonExtent)
		color: Color lightGray.
	upButton on: #mouseDown send: #scrollUpInit to: self.
	upButton on: #mouseUp send: #finishedScrolling to: self.
	upButton addMorphCentered: (ImageMorph new image:
		(self 
			cachedImageAt: (bounds isWide ifTrue: ['left'] ifFalse: ['up'])
			ifAbsentPut: [
				bounds isWide ifTrue: [
					self upArrow8Bit rotateBy: #left centerAt: 0@0
				] ifFalse: [
					self upArrow8Bit
				]
			]
		)
	).
	upButton setBorderWidth: 1 borderColor: #raised.
	self addMorph: upButton! !

!ScrollBar methodsFor: 'initialize' stamp: 'RAA 7/28/2000 10:12'!
upArrow8Bit

	"convert to 8-bit and convert white to transparent to avoid gratuitous conversion every time we put one in an ImageMorph"

	^UpArrow8Bit ifNil: [
		UpArrow8Bit _ (ColorForm mappingWhiteToTransparentFrom: UpArrow) asFormOfDepth: 8
	]! !


!ScrollBar methodsFor: 'access' stamp: 'dew 2/21/1999 03:08'!
interval: d
	"Supply an optional floating fraction so slider can expand to indicate range"
	interval _ d min: 1.0.
	self expandSlider.
	self computeSlider.! !

!ScrollBar methodsFor: 'access' stamp: 'dew 2/15/1999 18:25'!
pagingArea
	^pagingArea! !

!ScrollBar methodsFor: 'access'!
scrollDelta
	^ scrollDelta! !

!ScrollBar methodsFor: 'access'!
scrollDelta: d1 pageDelta: d2
	"Supply optional increments for better scrolling of, eg, text"
	scrollDelta _ d1.
	pageDelta _ d2.! !


!ScrollBar methodsFor: 'geometry' stamp: 'dew 6/9/1999 02:02'!
buttonExtent
	^ bounds isWide
		ifTrue: [11 @ self innerBounds height]
		ifFalse: [self innerBounds width @ 11]! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'!
computeSlider
	"interval ifNotNil: [self expandSlider]."
	super computeSlider.

! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/27/1999 18:22'!
expandSlider
	"Compute the new size of the slider (use the old sliderThickness as a minimum)."
	| r |
	r _ self totalSliderArea.
	slider extent: (bounds isWide
		ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height]
		ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 7/22/1999 19:03'!
extent: p
        p x > p y
                ifTrue: [super extent: (p max: 42@8)]
                ifFalse: [super extent: (p max: 8@42)]! !

!ScrollBar methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'!
sliderExtent
	"The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass."
	^slider extent! !

!ScrollBar methodsFor: 'geometry'!
totalSliderArea
	^ bounds isWide
		ifTrue: [upButton bounds topRight corner: downButton bounds bottomLeft]
		ifFalse: [upButton bounds bottomLeft corner: downButton bounds topRight]! !


!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:13'!
doScrollByPage
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
	nextPageDirection
		ifTrue: [self setValue: (value + pageDelta min: 1.0)]
		ifFalse: [self setValue: (value - pageDelta max: 0.0)]
! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:13'!
doScrollDown
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 50) ifFalse: [^ self].
	self setValue: (value + scrollDelta + 0.000001 min: 1.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:14'!
doScrollUp
	"Scroll automatically while mouse is down"
	(self waitForDelay1: 300 delay2: 50) ifFalse: [^ self].
	self setValue: (value - scrollDelta - 0.000001 max: 0.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:06'!
finishedScrolling
	self stopStepping.
	self scrollBarAction: nil.
	downButton borderRaised.
	upButton borderRaised.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'!
scrollBarAction
	^self valueOfProperty: #scrollBarAction! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 14:56'!
scrollBarAction: aSymbol
	self setProperty: #scrollBarAction toValue: aSymbol! !

!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:57'!
scrollByPage: event

	self flag: #bob.	"this would appear to be obsolete now"

	nextPageDirection == nil ifTrue: [self setNextDirectionFromEvent: event].
	(self waitForDelay1: 300 delay2: 100) ifFalse: [^ self].
	nextPageDirection
		ifTrue: [self setValue: (value + pageDelta min: 1.0)]
		ifFalse: [self setValue: (value - pageDelta max: 0.0)]
! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:12'!
scrollDown
	self flag: #obsolete.
	downButton eventHandler: nil.
	downButton on: #mouseDown send: #scrollDownInit to: self.
	downButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollDownInit! !

!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'!
scrollDown: count
	self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:05'!
scrollDownInit
	downButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollDown.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:56'!
scrollPageInit: evt
	self resetTimer.
	self setNextDirectionFromEvent: evt.
	self scrollBarAction: #doScrollByPage.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:11'!
scrollUp
	self flag: #obsolete.
	upButton eventHandler: nil.
	upButton on: #mouseDown send: #scrollUpInit to: self.
	upButton on: #mouseUp send: #finishedScrolling to: self.
	^self scrollUpInit! !

!ScrollBar methodsFor: 'scrolling' stamp: 'bf 4/14/1999 12:03'!
scrollUp: count
	self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! !

!ScrollBar methodsFor: 'scrolling' stamp: 'ar 10/7/2000 15:05'!
scrollUpInit
	upButton borderInset.
	self resetTimer.
	self scrollBarAction: #doScrollUp.
	self startStepping.! !

!ScrollBar methodsFor: 'scrolling' stamp: 'RAA 12/29/2000 11:56'!
setNextDirectionFromEvent: event

	nextPageDirection _ bounds isWide ifTrue: [
		event cursorPoint x >= slider center x
	]
	ifFalse: [
		event cursorPoint y >= slider center y
	]

! !

!ScrollBar methodsFor: 'scrolling' stamp: 'dew 2/21/1999 03:08'!
setValue: newValue
	"Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown."
	^ super setValue: (newValue roundTo: scrollDelta)! !


!ScrollBar methodsFor: 'other events'!
menuButtonMouseDown: event
	event hand showTemporaryCursor: nil.
	self use: menuSelector orMakeModelSelectorFor: 'MenuButtonPressed:'
		in: [:sel | menuSelector _ sel.  model perform: sel with: event]! !

!ScrollBar methodsFor: 'other events'!
menuButtonMouseEnter: event
	event hand showTemporaryCursor: Cursor menu! !

!ScrollBar methodsFor: 'other events'!
menuButtonMouseLeave: event
	event hand showTemporaryCursor: nil! !

!ScrollBar methodsFor: 'other events' stamp: 'dew 10/17/1999 19:41'!
mouseDownInSlider: event
	interval = 1.0 ifTrue:
		["make the entire scrollable area visible if a full scrollbar is clicked on"
		self setValue: 0.
		self model hideOrShowScrollBar].
	super mouseDownInSlider: event! !


!ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:22'!
resetTimer
	timeOfMouseDown _ Time millisecondClockValue.
	timeOfLastScroll _ timeOfMouseDown - 1000 max: 0.
	nextPageDirection _ nil.
	currentScrollDelay _ nil! !

!ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:38'!
waitForDelay1: delay1 delay2: delay2
	"Return true if an appropriate delay has passed since the last scroll operation.
	The delay decreases exponentially from delay1 to delay2."
	| now scrollDelay |
	timeOfLastScroll == nil ifTrue: [self resetTimer]. "Only needed for old instances"
	now _ Time millisecondClockValue.
	now < timeOfLastScroll ifTrue: [self resetTimer  "rare clock rollover"].
	(scrollDelay _ currentScrollDelay) == nil ifTrue: [scrollDelay _ delay1  "initial delay"].
	now > (timeOfLastScroll + scrollDelay) ifFalse: [^ false  "not time yet"].
	currentScrollDelay _ scrollDelay*9//10 max: delay2.  "decrease the delay"
	timeOfLastScroll _ now.
	^ true! !


!ScrollBar methodsFor: 'as yet unclassified' stamp: 'RAA 7/28/2000 09:40'!
cachedImageAt: aKey ifAbsentPut: aBlock

	CachedImages ifNil: [CachedImages _ Dictionary new].
	^CachedImages at: aKey ifAbsentPut: aBlock! !


!ScrollBar methodsFor: 'stepping' stamp: 'ar 10/7/2000 15:02'!
step
	| action |
	action _ self scrollBarAction.
	action ifNotNil:[self perform: action].! !

!ScrollBar methodsFor: 'stepping' stamp: 'ar 10/7/2000 15:02'!
stepTime
	^25! !

!ScrollBar methodsFor: 'stepping' stamp: 'ar 10/7/2000 15:02'!
wantsSteps
	^self scrollBarAction notNil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScrollBar class
	instanceVariableNames: ''!

!ScrollBar class methodsFor: 'class initialization'!
initialize "ScrollBar initialize"

	UpArrow _ Form
		extent: 6@3
		fromArray: #(2r11e28 2r1111e27 2r111111e26)
		offset: 0@0.! !
MouseMenuController subclass: #ScrollController
	instanceVariableNames: 'scrollBar marker savedArea menuBar savedMenuBarArea '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!ScrollController commentStamp: '<historical>' prior: 0!
I represent control for scrolling using a scrollBar. I am a MouseMenuController that creates a scrollBar, rather than menus. My subclasses add the button menus. I keep control as long as the cursor is inside the view or the scrollBar area.
	
A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the cursor is to the right of the inner rectangle, the window onto the visible information moves upward, if the cursor is to the left, the window moves downward, and if the cursor is inside, the inner rectangle is grabbed and moved to a desired position.!


!ScrollController methodsFor: 'initialize-release'!
initialize
	super initialize.
	scrollBar _ Quadrangle new.
	scrollBar borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	marker _ Quadrangle new.
	marker insideColor: Preferences scrollBarColor.
	menuBar _ Quadrangle new.
	menuBar borderWidthLeft:  2 right: 0 top: 2 bottom: 2.! !


!ScrollController methodsFor: 'basic control sequence'!
controlInitialize
	"Recompute scroll bars.  Save underlying image unless it is already saved."
	| |
	super controlInitialize.
	scrollBar region: (0 @ 0 extent: 24 @ view apparentDisplayBox height).
	scrollBar insideColor: view backgroundColor.
	marker region: self computeMarkerRegion.
	scrollBar _ scrollBar align: scrollBar topRight with: view apparentDisplayBox topLeft.
	marker _ marker align: marker topCenter with: self upDownLine @ (scrollBar top + 2).
	savedArea isNil ifTrue: [savedArea _ Form fromDisplay: scrollBar].
	scrollBar displayOn: Display.

	"Show a border around yellow-button (menu) region"
"
	yellowBar _ Rectangle left: self yellowLine right: scrollBar right + 1
		top: scrollBar top bottom: scrollBar bottom.
	Display border: yellowBar width: 1 mask: Form veryLightGray.
"
	self moveMarker
! !

!ScrollController methodsFor: 'basic control sequence'!
controlTerminate

	super controlTerminate.
	savedArea notNil 	
		ifTrue: 
			[savedArea displayOn: Display at: scrollBar topLeft.
			savedArea _ nil].! !


!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:17'!
controlActivity
	self scrollByKeyboard ifTrue: [^ self].
	self scrollBarContainsCursor
		ifTrue: [self scroll]
		ifFalse: [self normalActivity]! !

!ScrollController methodsFor: 'control defaults' stamp: 'ar 3/24/2000 00:45'!
isControlActive 
	super isControlActive ifTrue: [^ true].
	sensor blueButtonPressed ifTrue: [^ false].
	^ (scrollBar inside merge: view insetDisplayBox) containsPoint: sensor cursorPoint! !

!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:31'!
isControlWanted
	^ self viewHasCursor! !

!ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:16'!
normalActivity
	super controlActivity! !


!ScrollController methodsFor: 'scrolling'!
anyButtonActivity
	"deal with red button down in scrollBar beyond yellowLine"

	self yellowButtonActivity! !

!ScrollController methodsFor: 'scrolling'!
downLine
	"if cursor before downLine, display down cursor and scroll down on button down"

	^scrollBar left + 6 ! !

!ScrollController methodsFor: 'scrolling' stamp: 'ls 7/11/1998 06:33'!
scroll
	"Check to see whether the user wishes to jump, scroll up, or scroll down."
	| savedCursor |
	savedCursor _ sensor currentCursor.
			[self scrollBarContainsCursor]
				whileTrue: 
					[self interActivityPause.
					sensor cursorPoint x <= self downLine
								ifTrue: [self scrollDown]
								ifFalse: [sensor cursorPoint x <= self upLine
										ifTrue: [self scrollAbsolute]
										ifFalse: [sensor cursorPoint x <= self yellowLine
												ifTrue: [self scrollUp]
												ifFalse: [sensor cursorPoint x <= scrollBar right
														ifTrue: "Might not be, with touch pen"
														[self changeCursor: Cursor menu.
														sensor anyButtonPressed 
														ifTrue: [self changeCursor: savedCursor. 
																self anyButtonActivity]]]]]].
	savedCursor show! !

!ScrollController methodsFor: 'scrolling'!
scrollAmount
	"Answer the number of bits of y-coordinate should be scrolled. This is a 
	default determination based on the view's preset display transformation."

	^((view inverseDisplayTransform: sensor cursorPoint)
		- (view inverseDisplayTransform: scrollBar inside topCenter)) y! !

!ScrollController methodsFor: 'scrolling' stamp: 'th 12/11/1999 16:57'!
scrollByKeyboard
	| keyEvent |
	keyEvent _ sensor keyboardPeek.
	keyEvent ifNil: [^ false].
	(sensor controlKeyPressed or:[sensor commandKeyPressed]) ifFalse: [^ false].
	keyEvent asciiValue = 30
		ifTrue: 
			[sensor keyboard.
			self scrollViewDown ifTrue: [self moveMarker].
			^ true].
	keyEvent asciiValue = 31
		ifTrue: 
			[sensor keyboard.
			self scrollViewUp ifTrue: [self moveMarker].
			^ true].
	^ false! !

!ScrollController methodsFor: 'scrolling'!
scrollView
	"The scroll bar jump method was used so that the view should be 
	updated to correspond to the location of the scroll bar gray area.
	Return true only if scrolling took place."
	^ self scrollView: self viewDelta! !

!ScrollController methodsFor: 'scrolling'!
scrollView: anInteger 
	"Tell the reciever's view to scroll by anInteger amount.
	Return true only if scrolling actually resulted."
	(view scrollBy: 0 @ 
				((anInteger min: view window top - view boundingBox top)
						max: view window top - view boundingBox bottom))
		ifTrue: [view clearInside; display.  ^ true]
		ifFalse: [^ false]! !

!ScrollController methodsFor: 'scrolling'!
scrollViewDown
	"Scroll the receiver's view down the default amount.
	Return true only if scrolling actually took place."
	^ self scrollView: self scrollAmount! !

!ScrollController methodsFor: 'scrolling'!
scrollViewUp
	"Scroll the receiver's view up the default amount.
	Return true only if scrolling actually took place."
	^ self scrollView: self scrollAmount negated! !

!ScrollController methodsFor: 'scrolling'!
upDownLine
	"Check to see whether the user wishes to jump, scroll up, or scroll down."

	^scrollBar left + 12! !

!ScrollController methodsFor: 'scrolling'!
upLine
	"if cursor beyond upLine, display up cursor and scroll up on button down"

	^scrollBar left + 12! !

!ScrollController methodsFor: 'scrolling'!
viewDelta
	"Answer an integer that indicates how much the view should be scrolled. 
	The scroll bar has been moved and now the view must be so the amount 
	to scroll is computed as a ratio of the current scroll bar position."

	^view window top - view boundingBox top -
		((marker top - scrollBar inside top) asFloat /
			scrollBar inside height asFloat *
				view boundingBox height asFloat) rounded! !

!ScrollController methodsFor: 'scrolling'!
yellowLine
	"Check to see whether the user wishes to jump, scroll up, or scroll down."

	^scrollBar left + 16! !


!ScrollController methodsFor: 'cursor'!
changeCursor: aCursor 
	"The current cursor should be set to be aCursor."

	sensor currentCursor ~~ aCursor ifTrue: [aCursor show]! !

!ScrollController methodsFor: 'cursor'!
markerContainsCursor
	"Answer whether the gray area inside the scroll bar area contains the 
	cursor."

	^marker inside containsPoint: sensor cursorPoint! !

!ScrollController methodsFor: 'cursor'!
menuBarContainsCursor
	"Answer whether the cursor is anywhere within the menu bar area."

	^ menuBar notNil and:
			[menuBar containsPoint: sensor cursorPoint]! !

!ScrollController methodsFor: 'cursor'!
scrollBarContainsCursor
	"Answer whether the cursor is anywhere within the scroll bar area."

	^scrollBar containsPoint: sensor cursorPoint! !


!ScrollController methodsFor: 'marker adjustment'!
computeMarkerRegion
	"Answer the rectangular area in which the gray area of the scroll bar 
	should be displayed."

	^0@0 extent: Preferences scrollBarWidth @
			((view window height asFloat /
						view boundingBox height *
							scrollBar inside height)
				 rounded min: scrollBar inside height)! !

!ScrollController methodsFor: 'marker adjustment'!
markerDelta
	^ marker top 
		- scrollBar inside top  
		- ((view window top - view boundingBox top) asFloat 
			/ view boundingBox height asFloat *
				scrollBar inside height asFloat) rounded! !

!ScrollController methodsFor: 'marker adjustment'!
markerRegion: aRectangle 
	"Set the area defined by aRectangle as the marker. Fill it with gray tone."

	Display fill: marker fillColor: scrollBar insideColor.
	marker region: aRectangle.
	marker _ marker align: marker topCenter 
			with: self upDownLine @ (scrollBar top + 2) ! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarker
	"The view window has changed. Update the marker."

	self moveMarker: self markerDelta negated anchorMarker: nil! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarker: anInteger anchorMarker: anchorMarker
	"Update the marker so that is is translated by an amount corresponding to 
	a distance of anInteger, constrained within the boundaries of the scroll 
	bar.  If anchorMarker ~= nil, display the border around the area where the
	marker first went down."

	Display fill: marker fillColor: scrollBar insideColor.
	anchorMarker = nil
		ifFalse: [Display border: anchorMarker width: 1 fillColor: Color gray].
	marker _ marker translateBy: 0 @
				((anInteger min: scrollBar inside bottom - marker bottom) max:
					scrollBar inside top - marker top).
	marker displayOn: Display! !

!ScrollController methodsFor: 'marker adjustment'!
moveMarkerTo: aRectangle 
	"Same as markerRegion: aRectangle; moveMarker, except a no-op if the marker
	 would not move."

	(aRectangle height = marker height and: [self viewDelta = 0]) ifFalse:
		[self markerRegion: aRectangle.
		self moveMarker]! !


!ScrollController methodsFor: 'private'!
scrollAbsolute
	| markerOutline oldY markerForm |
	self changeCursor: Cursor rightArrow.

	oldY _ -1.
	sensor anyButtonPressed ifTrue: 
	  [markerOutline _ marker deepCopy.
	  markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  Display border: markerOutline width: 1 fillColor: Color gray.
	  markerForm 
		follow: 
			[oldY ~= sensor cursorPoint y
				ifTrue: 
					[oldY _ sensor cursorPoint y.
					marker _ marker translateBy: 
					  0 @ ((oldY - marker center y 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
					self scrollView].
				marker origin] 
		while: [sensor anyButtonPressed].

	  Display fill: markerOutline fillColor: scrollBar insideColor.
	  self moveMarker]! !

!ScrollController methodsFor: 'private'!
scrollDown
	| markerForm firstTime |
	self changeCursor: Cursor down.
	sensor anyButtonPressed ifTrue:
	  [markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  firstTime _ true.
	  markerForm 
		follow: 
			[self scrollViewDown ifTrue:
				[marker _ marker translateBy: 0 @
					((self markerDelta negated 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
				firstTime
					ifTrue: [
						"pause before scrolling repeatedly"
						(Delay forMilliseconds: 250) wait.
						firstTime _ false.
					] ifFalse: [
						(Delay forMilliseconds: 50) wait.
					].
				].
			marker origin] 
		while: [sensor anyButtonPressed].
	  self moveMarker.]! !

!ScrollController methodsFor: 'private'!
scrollUp
	| markerForm firstTime |
	self changeCursor: Cursor up.
	sensor anyButtonPressed ifTrue:
	  [markerForm _ Form fromDisplay: marker.
	  Display fill: marker fillColor: scrollBar insideColor.
	  firstTime _ true.
	  markerForm 
		follow: 
			[self scrollViewUp ifTrue:
				[marker _ marker translateBy: 0 @
					((self markerDelta negated 
						min: scrollBar inside bottom - marker bottom) 
						max: scrollBar inside top - marker top).
				firstTime
					ifTrue: [
						"pause before scrolling repeatedly"
						(Delay forMilliseconds: 250) wait.
						firstTime _ false.
					] ifFalse: [
						(Delay forMilliseconds: 50) wait.
					].
				].
			marker origin] 
		while: [sensor anyButtonPressed].
	  self moveMarker.]! !
ComponentLikeModel subclass: #ScrollPane
	instanceVariableNames: 'scrollBar scroller retractableScrollBar scrollBarOnLeft getMenuSelector getMenuTitleSelector scrollBarHidden hasFocus '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!ScrollPane commentStamp: '<historical>' prior: 0!
The scroller (a transform) of a scrollPane is driven by the scrollBar.  The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane.  The total distance to achieve this range is called the totalScrollRange.!


!ScrollPane methodsFor: 'initialization' stamp: 'tk 8/13/1998 13:05'!
fullCopy
	| copy |
	self mouseEnter: nil.		 "Make sure scrollBar is in morphic structure"
	copy _ super fullCopy.		"So that references are updated properly"
		"Will fail of any Players with scripts are in the ScrollPane"
	self mouseLeave: nil.
	^ copy mouseLeave: nil
! !

!ScrollPane methodsFor: 'initialization' stamp: 'ar 11/12/2000 12:22'!
initialize
	retractableScrollBar _ (Preferences valueOfFlag: #inboardScrollbars) not.
	scrollBarOnLeft _ (Preferences valueOfFlag: #scrollBarsOnRight) not.
	super initialize.
	hasFocus _ false.
	borderWidth _ 2.
	borderColor _ Color black.

	scrollBar := ScrollBar new model: self slotName: 'scrollBar'.
	scrollBar borderWidth: 1; borderColor: Color black.

	scroller := TransformMorph new color: Color transparent.
	scroller offset: -3@0.
	self addMorph: scroller.

	retractableScrollBar ifFalse: [self addMorph: scrollBar].

	self on: #mouseEnter send: #mouseEnter: to: self.
	self on: #mouseLeave send: #mouseLeave: to: self.
	self extent: 150@120! !

!ScrollPane methodsFor: 'initialization' stamp: 'dew 11/5/2000 00:22'!
setScrollDeltas
	"Set the ScrollBar deltas, value and interval, based on the current scroll pane size, offset and range."
	| range delta |
	self hideOrShowScrollBar.
	scroller hasSubmorphs ifFalse: [scrollBar interval: 1.0.  ^ self].
	range _ self leftoverScrollRange.
	delta _ self scrollDeltaHeight.
	range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0].

	"Set up for one line (for arrow scrolling), or a full pane less one line (for paging)."
	scrollBar scrollDelta: (delta / range) asFloat 
			pageDelta: ((self innerBounds height - delta) / range) asFloat.
	scrollBar interval: ((self innerBounds height - delta) / self totalScrollRange) asFloat.
	scrollBar value: (scroller offset y / self leftoverScrollRange) asFloat.! !


!ScrollPane methodsFor: 'access' stamp: 'sw 2/12/98 00:30'!
colorForInsets
	"My submorphs use the surrounding color"
	| aColor |
	(aColor _ owner color) ifKindOf: Color thenDo: [:c | ^ aColor].
	"This workaround relates to cases where the scrollPane's color is not a true color but rather an InfiniteForm, which is not happy to be returned here"
	^ Color white! !

!ScrollPane methodsFor: 'access' stamp: 'dew 10/17/1999 19:40'!
hasFocus
	"hasFocus is currently set by mouse enter/leave events.
	This inst var should probably be moved up to a higher superclass."

	^ hasFocus ifNil: [false]! !

!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'!
retractableScrollBar
	^ retractableScrollBar! !

!ScrollPane methodsFor: 'access' stamp: 'LC 6/12/2000 09:28'!
scrollBarOnLeft
	^ scrollBarOnLeft! !

!ScrollPane methodsFor: 'access'!
scroller
	^ scroller! !

!ScrollPane methodsFor: 'access' stamp: 'ar 5/19/1999 18:06'!
scroller: aTransformMorph
	scroller ifNotNil:[scroller delete].
	scroller _ aTransformMorph.
	self addMorph: scroller.
	self resizeScroller.! !

!ScrollPane methodsFor: 'access' stamp: '6/7/97 10:42 di'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!ScrollPane methodsFor: 'geometry'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifTrue: [^ true].
	"Also include scrollbar when it is extended..."
	^ (retractableScrollBar and: [submorphs includes: scrollBar]) and:
		[scrollBar containsPoint: aPoint]! !

!ScrollPane methodsFor: 'geometry' stamp: 'go 4/26/1999 10:06'!
extent: newExtent
        super extent: (newExtent max: (self scrollbarWidth + 20)@16).
        self resizeScrollBar; resizeScroller; setScrollDeltas! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'!
innerBounds
	| inner w |
	inner _ super innerBounds.
	w _ self scrollbarWidth.
	retractableScrollBar | (submorphs includes: scrollBar) not
		ifTrue: [^ inner]
		ifFalse: [^ (scrollBarOnLeft
					ifTrue: [inner topLeft + ((w-1)@0) corner: inner bottomRight]
					ifFalse: [inner topLeft corner: inner bottomRight - ((w-2)@0)])]! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 18:46'!
leftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	^ self totalScrollRange - (bounds height * 3 // 4) max: 0
! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'!
resetExtent
	"Reset the extent. (may be overridden by subclasses which need to do more than this)"
	self resizeScroller! !

!ScrollPane methodsFor: 'geometry' stamp: 'JW 2/3/2001 09:53'!
resizeScrollBar
	| w topLeft |
	w _ self scrollbarWidth.
	topLeft _ scrollBarOnLeft
		ifTrue: [retractableScrollBar ifTrue: [bounds topLeft - (w-borderWidth@0)]
									ifFalse: [bounds topLeft + (borderWidth-1@0)]]
		ifFalse: [retractableScrollBar ifTrue: [bounds topRight - (borderWidth@0)]
									ifFalse: [bounds topRight - (w+borderWidth-1@0)]].
	scrollBar bounds: (topLeft extent: w @ bounds height)! !

!ScrollPane methodsFor: 'geometry' stamp: 'di 11/11/1998 09:48'!
resizeScroller

	scroller bounds: self innerBounds! !

!ScrollPane methodsFor: 'geometry' stamp: 'di 8/16/1998 01:09'!
scrollBarFills: aRectangle
	"Return true if a flop-out scrollbar fills the rectangle"
	^ (retractableScrollBar and: [submorphs includes: scrollBar]) and:
		[scrollBar bounds containsRect: aRectangle]! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 18:49'!
scrollBy: delta
	"Move the contents in the direction delta."
	"For now, delta is assumed to have a zero x-component"
	| newYoffset r |
	newYoffset _ scroller offset y - delta y max: 0.
	scroller offset: scroller offset x @ newYoffset.
	(r _ self leftoverScrollRange) = 0
		ifTrue: [scrollBar value: 0.0]
		ifFalse: [scrollBar value: newYoffset asFloat / r]! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'!
scrollDeltaHeight
	"Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)."
	^ 12
! !

!ScrollPane methodsFor: 'geometry' stamp: 'di 12/6/1999 08:35'!
scrollbarWidth  "Includes border"
	(Preferences valueOfFlag: #scrollBarsNarrow)
		ifTrue: [^ 12]
		ifFalse: [^ 16]! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 20:24'!
totalScrollRange
	"Return the entire scrolling range."
	^ (scroller submorphBounds encompass: 0@0) height
! !

!ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'!
unadjustedScrollRange
	"Return the difference between the height extent of the receiver's submorphs and its own height extent (plus an extra 1/2 line height)."
	scroller submorphBounds ifNil: [^ 0].
	^ self totalScrollRange - bounds height + (self scrollDeltaHeight / 2) max: 0! !



!ScrollPane methodsFor: 'pane events' stamp: 'di 5/7/1998 09:52'!
handlesMouseDown: evt
	^ true! !

!ScrollPane methodsFor: 'pane events' stamp: 'ar 9/18/2000 22:11'!
handlesMouseOver: evt
	"Could just ^ true, but this ensures that scroll bars won't flop out
	if you mouse-over appendages such as connecting pins."
	self flag: #arNote. "I have no idea how the code below could've ever worked. If the receiver does not handle mouse over events then it should not receive any #mouseLeave if the mouse leaves the receiver for real. This is because 'evt cursorPoint' describes the *end* point of the movement and considering that the code would return false if the move ends outside the receiver the scroll bars should never pop back in again. Which is exactly what happens with the new event logic if you don't just ^true. I'm leaving the code in for reference - perhaps somebody can make sense from it; I sure cannot."
	^true
"
	| cp |
	cp _ evt cursorPoint.
	(bounds containsPoint: cp)
		ifTrue: [^ true]			
		ifFalse: [self submorphsDo:
					[:m | (m containsPoint: cp) ifTrue:
							[m == scrollBar
								ifTrue: [^ true]
								ifFalse: [^ false]]].
				^ false]
"! !

!ScrollPane methodsFor: 'pane events' stamp: 'bf 4/14/1999 12:39'!
keyStroke: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	(self scrollByKeyboard: evt) ifTrue: [^self].
	scroller submorphs last keyStroke: evt! !

!ScrollPane methodsFor: 'pane events' stamp: 'di 6/30/1998 08:48'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'pane events' stamp: 'ar 10/10/2000 23:01'!
mouseMove: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)."
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'pane events' stamp: 'di 5/7/1998 11:46'!
mouseUp: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! !

!ScrollPane methodsFor: 'pane events' stamp: 'th 12/11/1999 17:21'!
scrollByKeyboard: event 
	"If event is ctrl+up/down then scroll and answer true"
	(event controlKeyPressed or:[event commandKeyPressed]) ifFalse: [^ false].
	event keyValue = 30
		ifTrue: 
			[scrollBar scrollUp: 3.
			^ true].
	event keyValue = 31
		ifTrue: 
			[scrollBar scrollDown: 3.
			^ true].
	^ false! !


!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
scrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'dew 2/19/1999 18:48'!
scrollBarValue: scrollValue
	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: -3 @ (self leftoverScrollRange * scrollValue)! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
shiftedYellowButtonActivity
	^ self yellowButtonActivity: true! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'!
unshiftedYellowButtonActivity
	^ self yellowButtonActivity: false! !

!ScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 6/12/2000 09:02'!
yellowButtonActivity: shiftKeyState
	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu popUpEvent: self activeHand lastEvent in: self world]! !


!ScrollPane methodsFor: 'menu' stamp: 'di 11/14/97 09:07'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	retractableScrollBar
		ifTrue: [aCustomMenu add: 'make scrollbar inboard' action: #retractableOrNot]
		ifFalse: [aCustomMenu add: 'make scrollbar retractable' action: #retractableOrNot].
	scrollBarOnLeft
		ifTrue: [aCustomMenu add: 'scroll bar on right' action: #leftOrRight]
		ifFalse: [aCustomMenu add: 'scroll bar on left' action: #leftOrRight]! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 9/23/1998 08:47'!
getMenu: shiftKeyState
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
	| menu aMenu aTitle |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ MenuMorph new defaultTarget: model.
	aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
	getMenuSelector numArgs = 1 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	getMenuSelector numArgs = 2 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!ScrollPane methodsFor: 'menu' stamp: 'di 11/14/97 09:09'!
leftOrRight  "Change scroll bar location"
	scrollBarOnLeft _ scrollBarOnLeft not.
	self extent: self extent! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'!
menuTitleSelector: aSelector
	getMenuTitleSelector _ aSelector! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 11/5/1998 14:14'!
retractable: aBoolean
	retractableScrollBar == aBoolean ifFalse: [self retractableOrNot "toggles it"]! !

!ScrollPane methodsFor: 'menu' stamp: 'di 11/14/97 09:14'!
retractableOrNot  "Change scroll bar operation"
	retractableScrollBar _ retractableScrollBar not.
	retractableScrollBar
		ifTrue: [self privateRemoveMorph: scrollBar]
		ifFalse: [(submorphs includes: scrollBar) 
					ifFalse: [self privateAddMorph: scrollBar atIndex: 1]].
	self extent: self extent! !

!ScrollPane methodsFor: 'menu' stamp: 'sw 1/13/98 21:27'!
scrollBarOnLeft: aBoolean
	scrollBarOnLeft _ aBoolean.
	self extent: self extent! !


!ScrollPane methodsFor: 'scrolling' stamp: 'JW 2/3/2001 10:22'!
hideOrShowScrollBar
	"Hide or show the scrollbar depending on if the pane is scrolled/scrollable."

	"Don't do anything with the retractable scrollbar unless we have focus"
	retractableScrollBar & self hasFocus not ifTrue: [^self].
	"Don't show it if we were told not to."
	(self valueOfProperty: #noScrollBarPlease ifAbsent: [false]) ifTrue: [^self].

	self isScrollable not & self isScrolledFromTop not ifTrue: [self hideScrollBar].
	self isScrollable | self isScrolledFromTop ifTrue: [self showScrollBar].
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'RAA 6/8/2000 12:34'!
hideScrollBar
	(submorphs includes: scrollBar) ifFalse: [^self].
	self privateRemoveMorph: scrollBar.
	scrollBar privateOwner: nil.
	retractableScrollBar ifFalse: [self resetExtent].! !

!ScrollPane methodsFor: 'scrolling' stamp: 'JW 2/3/2001 10:19'!
hideScrollBarIndefinitely
	"Get rid of scroll bar for short panes that don't want it shown."

	self setProperty: #noScrollBarPlease toValue: true.
	self hideScrollBar.

! !

!ScrollPane methodsFor: 'scrolling' stamp: 'ar 11/8/2000 21:11'!
isRetractableScrollbarShowing
	"Return true if a retractable scroll bar is currently showing"
	retractableScrollBar ifFalse:[^false].
	^submorphs includes: scrollBar! !

!ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 16:28'!
isScrollable
	(Preferences valueOfFlag: #hiddenScrollBars) ifFalse: [^ true].

	"If the contents of the pane are too small to scroll, return false."
	^ self unadjustedScrollRange > 0
		"treat a single line as non-scrollable"
		and: [self totalScrollRange > (self scrollDeltaHeight * 3/2)]! !

!ScrollPane methodsFor: 'scrolling' stamp: 'ar 11/10/2000 12:46'!
isScrollbarShowing
	"Return true if a retractable scroll bar is currently showing"
	retractableScrollBar ifFalse:[^true].
	^submorphs includes: scrollBar! !

!ScrollPane methodsFor: 'scrolling' stamp: 'dew 10/17/1999 19:41'!
isScrolled
	"If the scroller is not set to y = 0, then the pane has been scrolled."
	^scroller offset y > 0
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 15:17'!
isScrolledFromTop
	"Have the contents of the pane been scrolled, so that the top of the contents are not visible?"
	^scroller offset y > 0
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 15:55'!
mouseEnter: event
	hasFocus _ true.
	(owner isKindOf: SystemWindow)
		ifTrue: [owner paneTransition: event].
	self hideOrShowScrollBar.
! !

!ScrollPane methodsFor: 'scrolling' stamp: 'dew 10/17/1999 19:41'!
mouseLeave: event
	hasFocus _ false.
	retractableScrollBar
		ifTrue: [self hideScrollBar].
	(owner isKindOf: SystemWindow)
		ifTrue: [owner paneTransition: event]! !

!ScrollPane methodsFor: 'scrolling' stamp: 'RAA 12/18/2000 17:15'!
showScrollBar
	(submorphs includes: scrollBar) ifTrue: [^self].
	self resizeScrollBar.
	self privateAddMorph: scrollBar atIndex: 1.
	"scrollBar changed."
	retractableScrollBar ifFalse: [self resetExtent].! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ScrollPane class
	instanceVariableNames: ''!

!ScrollPane class methodsFor: 'as yet unclassified' stamp: 'di 2/21/98 11:02'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
Object subclass: #ScrollingToolHolder
	instanceVariableNames: 'pickupButtons stampButtons stamps thumbnailPics start '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!ScrollingToolHolder commentStamp: '<historical>' prior: 0!
Used to hold stamp images in the PaintBox. Displays a small number of the available stamps and allows scrolling to access the others. One stamp is always kept blank as a way to create new stamps.

Note:
	stamps are the full size Forms
	thumbnailPics are the shrunken ones
	nil in both lists means no stamp yet, so user can create one
!


!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 15:00'!
clear
	"wipe out all existing stamps"

	stamps _ OrderedCollection new: 16.
	thumbnailPics _ OrderedCollection new: 16.
	stampButtons do: [:each | 
		stamps addLast: nil.	"hold a space"
		thumbnailPics addLast: nil].
	start _ 1.
	self normalize.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 3/9/98 13:17'!
normalize
	"Correspondence between buttons and stamp forms has changed.  Make all thumbnails show up right."

	| shrunkForm button trans |
	1 to: stampButtons size do: [:ind |
		shrunkForm _ thumbnailPics atWrap: ind+start-1.
		button _ stampButtons at: ind.
		shrunkForm 
			ifNil: [trans _ Form extent: button extent depth: 8.
				trans fill: trans boundingBox fillColor: Color transparent.
				button onImage: trans]
			ifNotNil: [button onImage: shrunkForm].
		button offImage: shrunkForm; pressedImage: shrunkForm.	"later modify them"
		].! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 11:46'!
otherButtonFor: aButton
	"Find the corresponding button for either a pickup or a stamp button"

	| ii |
	(ii _ pickupButtons indexOf: aButton) > 0 ifTrue: [^ stampButtons at: ii].
	(ii _ stampButtons indexOf: aButton) > 0 ifTrue: [^ pickupButtons at: ii].
	self error: 'stamp button not found'.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/16/97 19:22'!
pickupButtons

	^ pickupButtons! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 10:51'!
pickupButtons: anArray
	"Save the list of buttons that are for making a new stamp.  Left to right"

	pickupButtons _ anArray! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 10/11/97 17:04'!
remove: tool
	"Remove a stamp.  Make this stamp blank.  OK to have a bunch of blank ones."

	| which |
	which _ stampButtons indexOf: tool ifAbsent: [
				pickupButtons indexOf: tool ifAbsent: [^ self]].
	stamps atWrap: which+start-1 put: nil.
	thumbnailPics atWrap: which+start-1 put: nil.
	self normalize.	"show them"! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 14:37'!
scroll: amt
	"Move the stamps over"

	start _ start - 1 + amt \\ stamps size + 1.
	self normalize.	"show them"! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/16/97 19:22'!
stampButtons

	^ stampButtons! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 10/11/97 10:21'!
stampButtons: anArray
	"Pop in a new list of buttons that are the tools for stamping.  Left to right"

	stampButtons _ anArray.
	self clear.! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/17/97 09:59'!
stampForm: stampForm for: aPickupButton
	"Install this form to stamp. Find its index.  Make a thumbnail."

	| which scale shrunkForm stampBtn mini |
	which _ pickupButtons indexOf: aPickupButton.
	which = 0 ifTrue: [which _ stampButtons indexOf: aPickupButton].
	stamps atWrap: which+start-1 put: stampForm.

	"Create the thumbnail"
	stampBtn _ stampButtons at: which.
	scale _ stampBtn width / (stampForm extent x max: stampForm extent y).
	scale _ scale min: 1.0.	"do not expand it"
	mini _ stampForm magnify: stampForm boundingBox by: scale smoothing: 1.
	shrunkForm _ mini class extent: stampBtn extent depth: stampForm depth.
	mini displayOn: shrunkForm at: (stampBtn extent - mini extent)//2.
	thumbnailPics atWrap: which+start-1 put: shrunkForm.
	stampBtn offImage: shrunkForm; onImage: shrunkForm; pressedImage: shrunkForm.
		"Emphasis is done by border of enclosing layoutMorph, not modifying image"

	(stamps indexOf: nil) = 0 ifTrue: ["Add an extra blank place"
		"Keep stamp we just installed in the same location!!"
		start+which-1 > stamps size ifTrue: [start _ start + 1].
		stamps addLast: nil.
		thumbnailPics addLast: nil.
		self normalize].
! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'tk 7/2/97 14:04'!
stampFormFor: aButton

	| which |
	which _ stampButtons indexOf: aButton ifAbsent: [1].
	^ stamps atWrap: which+start-1! !

!ScrollingToolHolder methodsFor: 'as yet unclassified' stamp: 'jm 7/28/97 11:54'!
updateReferencesUsing: aDictionary
	"Fix up the Morphs I own"
	"Note: Update this method when adding new inst vars that could contain Morphs."

	stampButtons _ stampButtons collect:
		[:old | aDictionary at: old ifAbsent: [old]].
	pickupButtons _ pickupButtons collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !
Object subclass: #SecureHashAlgorithm
	instanceVariableNames: 'totalA totalB totalC totalD totalE totals '
	classVariableNames: 'K1 K2 K3 K4 '
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!SecureHashAlgorithm commentStamp: '<historical>' prior: 0!
This class implements the Secure Hash Algorithm (SHA) described in the U.S. government's Secure Hash Standard (SHS). This standard is described in FIPS PUB 180-1, "SECURE HASH STANDARD", April 17, 1995.

The Secure Hash Algorithm is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996.

See the comment in class DigitalSignatureAlgorithm for details on its use.

Implementation notes:
The secure hash standard was created with 32-bit hardware in mind. All arithmetic in the hash computation must be done modulo 2^32. This implementation uses ThirtyTwoBitRegister objects to simulate hardware registers; this implementation is about six times faster than using LargePositiveIntegers (measured on a Macintosh G3 Powerbook). Implementing a primitive to process each 64-byte buffer would probably speed up the computation by a factor of 20 or more.
!


!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:56'!
hashInteger: aPositiveInteger
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in key generation."

	| buffer dstIndex |
	self initializeTotals.

	"pad integer with zeros"
	aPositiveInteger highBit <= 512
		ifFalse: [self error: 'integer cannot exceed 512 bits'].
	buffer _ ByteArray new: 64.
	dstIndex _ 0.
	aPositiveInteger digitLength to: 1 by: -1 do: [:i |
		buffer at: (dstIndex _ dstIndex + 1) put: (aPositiveInteger digitAt: i)].

	"process that one block"
	self processBuffer: buffer.

	^ self finalHash
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/21/1999 19:39'!
hashInteger: aPositiveInteger seed: seedInteger
	"Hash the given positive integer. The integer to be hashed should have 512 or fewer bits. This entry point is used in the production of random numbers"

	| buffer dstIndex |
	"Initialize totalA through totalE to their seed values."
	totalA _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: - 128) bitAnd: 16rFFFFFFFF).
	totalB _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: - 96) bitAnd: 16rFFFFFFFF).
	totalC _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: - 64) bitAnd: 16rFFFFFFFF).
	totalD _ ThirtyTwoBitRegister new
		load: ((seedInteger bitShift: - 32) bitAnd: 16rFFFFFFFF).
	totalE _ ThirtyTwoBitRegister new
		load: (seedInteger bitAnd: 16rFFFFFFFF).
	self initializeTotalsArray.

	"pad integer with zeros"
	buffer _ ByteArray new: 64.
	dstIndex _ 0.
	aPositiveInteger digitLength to: 1 by: -1 do: [:i |
		buffer at: (dstIndex _ dstIndex + 1) put: (aPositiveInteger digitAt: i)].

	"process that one block"
	self processBuffer: buffer.

	^ self finalHash
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:28'!
hashMessage: aStringOrByteArray
	"Hash the given message using the Secure Hash Algorithm."

	^ self hashStream: (ReadStream on: aStringOrByteArray asByteArray)
! !

!SecureHashAlgorithm methodsFor: 'public' stamp: 'jm 12/14/1999 11:41'!
hashStream: aPositionableStream
	"Hash the contents of the given stream from the current position to the end using the Secure Hash Algorithm. The SHA algorithm is defined in FIPS PUB 180-1. It is also described on p. 442 of 'Applied Cryptography: Protocols, Algorithms, and Source Code in C' by Bruce Scheier, Wiley, 1996."
	"SecureHashAlgorithm new hashStream: (ReadStream on: 'foo')"

	| startPosition buf bitLength |
	self initializeTotals.

	aPositionableStream atEnd ifTrue: [self error: 'empty stream'].

	startPosition _ aPositionableStream position.
	[aPositionableStream atEnd] whileFalse: [
		buf _ aPositionableStream next: 64.
		(aPositionableStream atEnd not and: [buf size = 64])
			ifTrue: [self processBuffer: buf]
			ifFalse: [
				bitLength _ (aPositionableStream position - startPosition) * 8.
				self processFinalBuffer: buf bitLength: bitLength]].

	^ self finalHash
! !


!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:11'!
primExpandBlock: aByteArray into: wordBitmap
	"Expand the given 64-byte buffer into the given Bitmap of length 80."

	<primitive: 'primitiveExpandBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !

!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 22:58'!
primHasSecureHashPrimitive
	"Answer true if this platform has primitive support for the Secure Hash Algorithm."

	<primitive: 'primitiveHasSecureHashPrimitive' module: 'DSAPrims'>
	^ false
! !

!SecureHashAlgorithm methodsFor: 'primitives' stamp: 'jm 12/21/1999 20:13'!
primHashBlock: blockBitmap using: workingTotalsBitmap
	"Hash the given block (a Bitmap) of 80 32-bit words, using the given workingTotals."

	<primitive: 'primitiveHashBlock' module: 'DSAPrims'>
	^ self primitiveFailed
! !


!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 23:25'!
constantForStep: i
	"Answer the constant for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."

	i <= 20 ifTrue: [^ K1].
	i <= 40 ifTrue: [^ K2].
	i <= 60 ifTrue: [^ K3].
	^ K4
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:06'!
expandedBlock: aByteArray
	"Convert the given 64 byte buffer into 80 32-bit registers and answer the result." 
	| out src v |
	out _ Array new: 80.
	src _ 1.
	1 to: 16 do: [:i |
		out at: i put: (ThirtyTwoBitRegister new loadFrom: aByteArray at: src).
		src _ src + 4].

	17 to: 80 do: [:i |
		v _ (out at: i - 3) copy.
		v	bitXor: (out at: i - 8);
			bitXor: (out at: i - 14);
			bitXor: (out at: i - 16);
			leftRotateBy: 1.
		out at: i put: v].
	^ out
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 20:02'!
finalHash
	"Concatenate the final totals to build the 160-bit integer result."
	"Details: If the primitives are supported, the results are in the totals array. Otherwise, they are in the instance variables totalA through totalE."

	| r |
	totals ifNil: [  "compute final hash when not using primitives"
		^ (totalA asInteger bitShift: 128) +
		  (totalB asInteger bitShift:  96) +
		  (totalC asInteger bitShift:  64) +
		  (totalD asInteger bitShift:  32) +
		  (totalE asInteger)].

	"compute final hash when using primitives"
	r _ 0.
	1 to: 5 do: [:i |
		r _ r bitOr: ((totals at: i) bitShift: (32 * (5 - i)))].
	^ r
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/7/1999 22:15'!
hashFunction: i of: x with: y with: z
	"Compute the hash function for the i-th step of the block hash loop. We number our steps 1-80, versus the 0-79 of the standard."
	"Details: There are four functions, one for each 20 iterations. The second and fourth are the same."

	i <= 20 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z)].
	i <= 40 ifTrue: [^ x copy bitXor: y; bitXor: z].
	i <= 60 ifTrue: [^ x copy bitAnd: y; bitOr: (x copy bitAnd: z); bitOr: (y copy bitAnd: z)].
	^ x copy bitXor: y; bitXor: z
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'!
initializeTotals
	"Initialize totalA through totalE to their seed values."

	"total registers for use when primitives are absent"
	totalA _ ThirtyTwoBitRegister new load: 16r67452301.
	totalB _ ThirtyTwoBitRegister new load: 16rEFCDAB89.
	totalC _ ThirtyTwoBitRegister new load: 16r98BADCFE.
	totalD _ ThirtyTwoBitRegister new load: 16r10325476.
	totalE _ ThirtyTwoBitRegister new load: 16rC3D2E1F0.
	self initializeTotalsArray.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:38'!
initializeTotalsArray
	"Initialize the totals array from the registers for use with the primitives."

	totals _ Bitmap new: 5.
	totals at: 1 put: totalA asInteger.
	totals at: 2 put: totalB asInteger.
	totals at: 3 put: totalC asInteger.
	totals at: 4 put: totalD asInteger.
	totals at: 5 put: totalE asInteger.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 19:43'!
processBuffer: aByteArray
	"Process given 64-byte buffer, accumulating the results in totalA through totalE."

	| a b c d e w tmp |
	self primHasSecureHashPrimitive
		ifTrue: [^ self processBufferUsingPrimitives: aByteArray]
		ifFalse: [totals _ nil].

	"initialize registers a through e from the current totals" 
	a _ totalA copy.
	b _ totalB copy.
	c _ totalC copy.
	d _ totalD copy.
	e _ totalE copy.

	"expand and process the buffer"
	w _ self expandedBlock: aByteArray.
	1 to: 80 do: [:i |
		tmp _ (a copy leftRotateBy: 5)
			+= (self hashFunction: i of: b with: c with: d);
			+= e;
			+= (w at: i);
			+= (self constantForStep: i).
		e _ d.
		d _ c.
		c _ b copy leftRotateBy: 30.
		b _ a.
		a _ tmp].

	"add a through e into total accumulators"
	totalA += a.
	totalB += b.
	totalC += c.
	totalD += d.
	totalE += e.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/21/1999 23:32'!
processBufferUsingPrimitives: aByteArray
	"Process given 64-byte buffer using the primitives, accumulating the results in totals."

	| w |
	"expand and process the buffer"
	w _ Bitmap new: 80.
	self primExpandBlock: aByteArray into: w.
	self primHashBlock: w using: totals.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:40'!
processFinalBuffer: buffer bitLength: bitLength
	"Process given buffer, whose length may be <= 64 bytes, accumulating the results in totalA through totalE. Also process the final padding bits and length."

	| out |
	out _ ByteArray new: 64.
	out replaceFrom: 1 to: buffer size with: buffer startingAt: 1.
	buffer size < 56 ifTrue: [  "padding and length fit in last data block"
		out at: buffer size + 1 put: 128.  "trailing one bit"
		self storeLength: bitLength in: out.  "end with length"
		self processBuffer: out.
		^ self].

	"process the final data block"
	buffer size < 64 ifTrue: [
		out at: buffer size + 1 put: 128].  "trailing one bit"
	self processBuffer: out.

	"process one additional block of padding ending with the length"
	out _ ByteArray new: 64.  "filled with zeros"
	buffer size = 64 ifTrue: [
		"add trailing one bit that didn't fit in final data block"
		out at: 1 put: 128].
	self storeLength: bitLength in: out.
	self processBuffer: out.
! !

!SecureHashAlgorithm methodsFor: 'private' stamp: 'jm 12/14/1999 11:10'!
storeLength: bitLength in: aByteArray
	"Fill in the final 8 bytes of the given ByteArray with a 64-bit big-endian representation of the original message length in bits."

	| n i |
	n _ bitLength.
	i _ aByteArray size.
	[n > 0] whileTrue: [
		aByteArray at: i put: (n bitAnd: 16rFF).
		n _ n bitShift: -8.
		i _ i - 1].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SecureHashAlgorithm class
	instanceVariableNames: ''!

!SecureHashAlgorithm class methodsFor: 'class initialization' stamp: 'jm 12/7/1999 23:25'!
initialize
	"SecureHashAlgorithm initialize"
	"For the curious, here's where these constants come from:
	  #(2 3 5 10) collect: [:x | ((x sqrt / 4.0) * (2.0 raisedTo: 32)) truncated hex]"

	K1 _ ThirtyTwoBitRegister new load: 16r5A827999.
	K2 _ ThirtyTwoBitRegister new load: 16r6ED9EBA1.
	K3 _ ThirtyTwoBitRegister new load: 16r8F1BBCDC.
	K4 _ ThirtyTwoBitRegister new load: 16rCA62C1D6.
! !


!SecureHashAlgorithm class methodsFor: 'examples' stamp: 'jm 12/7/1999 23:26'!
example
	"Here are the first two examples from the specification document (FIPS PUB 180-1)."
	"SecureHashAlgorithm example"

	| hash |
	hash _ SecureHashAlgorithm new hashMessage: 'abc'.
	hash = 16rA9993E364706816ABA3E25717850C26C9CD0D89D
		ifTrue: [self inform: 'Passed Test #1']
		ifFalse: [self error: 'Test #1 failed!!'].

	hash _ SecureHashAlgorithm new hashMessage:
		'abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'.
	hash = 16r84983E441C3BD26EBAAE4AA1F95129E5E54670F1 
		ifTrue: [self inform: 'Passed Test #2']
		ifFalse: [self error: 'Test #2 failed!!'].
! !

!SecureHashAlgorithm class methodsFor: 'examples' stamp: 'jm 12/14/1999 11:45'!
example2
	"Here is the third example from the specification document (FIPS PUB 180-1). This example may take several minutes."
	"SecureHashAlgorithm example2"

	| hash |
	hash _ SecureHashAlgorithm new hashMessage: (String new: 1000000 withAll: $a).
	hash = 16r34AA973CD4C4DAA4F61EEB2BDBAD27316534016F
		ifTrue: [self inform: 'Passed Test #3']
		ifFalse: [self error: 'Test #3 failed!!'].
! !
CompositionScanner subclass: #SegmentScanner
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!

!SegmentScanner methodsFor: 'as yet unclassified' stamp: 'ar 5/18/2000 16:48'!
setFont
	super setFont.
	"Make a local copy of stop conditions so we don't modify the default"
	stopConditions == DefaultStopConditions 
		ifTrue:[stopConditions _ stopConditions copy].
	stopConditions at: Space asciiValue + 1 put: nil.! !
FormInput subclass: #SelectionInput
	instanceVariableNames: 'name defaultValue listMorph values '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!SelectionInput commentStamp: '<historical>' prior: 0!
allows a user to select from a number of options!


!SelectionInput methodsFor: 'handling input' stamp: 'bolot 11/3/1999 20:40'!
active
	^self name isNil not and: [listMorph getCurrentSelectionIndex > 0]! !

!SelectionInput methodsFor: 'handling input' stamp: 'ls 8/5/1998 07:15'!
name
	^name! !

!SelectionInput methodsFor: 'handling input' stamp: 'ls 8/5/1998 07:16'!
reset
	listMorph selection: defaultValue! !

!SelectionInput methodsFor: 'handling input' stamp: 'ls 8/11/1998 21:39'!
value
	^values at: listMorph getCurrentSelectionIndex! !


!SelectionInput methodsFor: 'private-initialization' stamp: 'ls 8/5/1998 07:55'!
name: name0  defaultValue: defaultValue0  list: list0 values: values0
	name _ name0.
	defaultValue _ defaultValue0.
	listMorph _ list0.
	values _ values0.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectionInput class
	instanceVariableNames: ''!

!SelectionInput class methodsFor: 'instance creation' stamp: 'ls 8/5/1998 07:55'!
name: name0  defaultValue: defaultValue  list: list  values: values
	^self new name: name0  defaultValue: defaultValue  list: list  values: values! !
PopUpMenu subclass: #SelectionMenu
	instanceVariableNames: 'selections '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!

!SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'!
selections
	^ selections! !

!SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'!
selections: selectionArray
	selections _ selectionArray! !


!SelectionMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 15:28'!
invokeOn: targetObject
	"Pop up this menu and return the result of sending to the target object 
	the selector corresponding to the menu item selected by the user. Return 
	nil if no item is selected."

	| sel |
	sel _ self startUp.
	sel = nil ifFalse: [^ targetObject perform: sel].
	^ nil

"Example:
	(SelectionMenu labels: 'sin
cos
neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! !

!SelectionMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 15:28'!
startUpWithCaption: captionOrNil at: location
	"Overridden to return value returned by manageMarker."

	| index |
	index _ super startUpWithCaption: captionOrNil at: location.
	(selections = nil or: [(index between: 1 and: selections size) not])
		ifTrue: [^ nil].
	^ selections at: index! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SelectionMenu class
	instanceVariableNames: ''!

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sw 11/8/1999 17:52'!
fromArray: anArray
	"Construct a menu from anArray.  The elements of anArray must be either:
	*  A pair of the form: <label> <selector>
or	*  The 'dash' (or 'minus sign') symbol

	Refer to the example at the bottom of the method"

	| labelList lines selections anIndex |
	labelList _ OrderedCollection new.
	lines _ OrderedCollection new.
	selections _ OrderedCollection new.
	anIndex _ 0.
	anArray do:
		[:anElement |
			anElement size == 1
				ifTrue:
					[(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor'].
					lines add: anIndex]
				ifFalse:
					[anElement size == 2 ifFalse: [self error: 'badly-formed menu constructor'].
					anIndex _ anIndex + 1.
					labelList add: anElement first.
					selections add: anElement second]].
	^ self labelList: labelList lines: lines selections: selections

"(SelectionMenu fromArray:
	#(	('first label'		moja)
		('second label'	mbili)
		-
		('third label' 	tatu)
		-
		('fourth label'	nne)
		('fifth label'	tano))) startUp"! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList
	^ self labelArray: labelList! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList lines: lines
	^ self labelArray: lines lines: lines! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList lines: lines selections: selections
	^ (self labelArray: labelList lines: lines) selections: selections! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'!
labelList: labelList selections: selections
	^ self
		labelList: labelList
		lines: #()
		selections: selections! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:09'!
labels: labels lines: linesArray
	"Answer an instance of me whose items are in labels, with lines drawn  
	after each item indexed by linesArray. Labels can be either a string 
	with embedded CRs, or a collection of strings."

	(labels isKindOf: String)
		ifTrue: [^ super labels: labels lines: linesArray]
		ifFalse: [^ super labelArray: labels lines: linesArray]! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:09'!
labels: labels lines: linesArray selections: selectionsArray
	"Answer an instance of me whose items are in labels, with lines drawn  
	after each item indexed by linesArray. Labels can be either a string  
	with embedded CRs, or a collection of strings. Record the given array of 
	selections corresponding to the items in labels."

	^ (self labels: labels lines: linesArray) selections: selectionsArray! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
labels: labels selections: selectionsArray
	"Answer an instance of me whose items are in labels, recording 
	the given array of selections corresponding to the items in labels."

	^ self
		labels: labels
		lines: #()
		selections: selectionsArray! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
selections: selectionsArray
	"Answer an instance of me whose labels and selections are identical."

	^ self selections: selectionsArray lines: nil! !

!SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'!
selections: selectionsArray lines: linesArray
	"Answer an instance of me whose labels and selections are identical."

	^ self
		labelList: (selectionsArray collect: [:each | each asString])
		lines: linesArray
		selections: selectionsArray! !
BorderedMorph subclass: #SelectionMorph
	instanceVariableNames: 'selectedItems slippage dupLoc dupDelta itemsAlreadySelected otherSelection undoProperties '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!
!SelectionMorph commentStamp: '<historical>' prior: 0!
A selectionMorph supports the selection of multiple objects in a morphic world or pasteUp.

Structure:
	selectedItems	an OrderedCollection of Morphs
					These are the morphs that have been selected
	slippage		a Point
					Keeps track of actual movement between the 
					steps of gridded movement
	dupLoc		a Point
					Notes the position when first duplicate request occurs from halo
	dupDelta	a Point
					Holds the final delta of the first duplicate plus subsequent moves.
!


!SelectionMorph methodsFor: 'initialization' stamp: 'di 8/31/2000 21:40'!
extendByHand: aHand
	"Assumes selection has just been created and added to some pasteUp or world"
	| startPoint handle |
	startPoint _ self position.
	handle _ NewHandleMorph new followHand: aHand
		forEachPointDo: [:newPoint | self bounds: (startPoint rect: newPoint)]
		lastPointDo: [:newPoint | selectedItems isEmpty ifTrue: [self delete]
												ifFalse: [self doneExtending]].
	aHand attachMorph: handle.
	handle startStepping.! !

!SelectionMorph methodsFor: 'initialization' stamp: 'RAA 9/7/2000 12:20'!
extendByHandPlus: aHand
	"Assumes selection has just been created and added to some pasteUp or world"
	| startPoint handle localPt |
	startPoint _ self position.
	handle _ NewHandleMorph new 
		followHand: aHand
		forEachPointDo: [ :newPoint | 
			localPt _ (self transformFrom: self world) globalPointToLocal: newPoint.
			self bounds: (startPoint rect: localPt)
		]
		lastPointDo: [ :newPoint | 
			selectedItems isEmpty ifTrue: [self delete] ifFalse: [self doneExtending]
		].
	aHand attachMorph: handle.
	handle startStepping.! !

!SelectionMorph methodsFor: 'initialization' stamp: 'ar 10/10/2000 15:10'!
hasHalo: aBool
	super hasHalo: aBool.
	aBool ifFalse:[self delete].! !

!SelectionMorph methodsFor: 'initialization' stamp: 'di 8/31/2000 19:56'!
initialize

	super initialize.
	color _ Color transparent.
	borderWidth _ 1.
	borderColor _ Color blue.
	selectedItems _ OrderedCollection new.
	itemsAlreadySelected _ OrderedCollection new.
	slippage _ 0@0.! !


!SelectionMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 21:40'!
bounds: newBounds

	selectedItems _ OrderedCollection new.  "Avoid repostioning items during super position:"
	super bounds: newBounds! !

!SelectionMorph methodsFor: 'geometry' stamp: 'di 8/31/2000 18:39'!
extent: newExtent

	super extent: newExtent.
	self selectSubmorphsOf: self pasteUpMorph! !

!SelectionMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 22:10'!
privateFullMoveBy: delta

	| griddedDelta griddingMorph |
	selectedItems isEmpty ifTrue: [^ super privateFullMoveBy: delta].
	griddingMorph _ self pasteUpMorph.
	griddingMorph ifNil: [^ super privateFullMoveBy: delta].
	griddedDelta _ (griddingMorph gridPoint: self position + delta + slippage) -
					(griddingMorph gridPoint: self position).
	slippage _ slippage + (delta - griddedDelta).  "keep track of how we lag the true movement."
	griddedDelta = (0@0) ifTrue: [^ self].
	super privateFullMoveBy: griddedDelta.
	selectedItems do:
		[:m | m privateFullMoveBy: griddedDelta]
! !


!SelectionMorph methodsFor: 'drawing' stamp: 'ar 9/1/2000 14:25'!
drawOn: aCanvas

	| canvas form1 form2 box |
	super drawOn: aCanvas.
	box _ self bounds.
	selectedItems do: [:m | box _ box merge: m fullBounds].
	box _ box expandBy: 1.
	canvas _ Display defaultCanvasClass extent: box extent depth: 8.
	canvas translateBy: box topLeft negated
		during: [:tempCanvas | selectedItems do: [:m | tempCanvas fullDrawMorph: m]].
	form1 _ (Form extent: box extent) copyBits: (0@0 extent: box extent) from: canvas form at: 0@0 colorMap: (Color maskingMap: 8).
	form2 _ Form extent: box extent.
	(0@0) fourNeighbors do: [:d | form1 displayOn: form2 at: d rule: Form under].
	form1 displayOn: form2 at: 0@0 rule: Form erase.
	aCanvas stencil: form2
		at: box topLeft
		sourceRect: form2 boundingBox
		color: self borderColor
! !


!SelectionMorph methodsFor: 'drag and drop' stamp: 'ar 10/10/2000 15:02'!
aboutToBeGrabbedBy: aHand
	slippage _ 0@0.
	^ super aboutToBeGrabbedBy: aHand
! !

!SelectionMorph methodsFor: 'drag and drop' stamp: 'ar 10/10/2000 15:01'!
justDroppedInto: newOwner event: evt

	selectedItems isEmpty ifTrue:
		["Hand just clicked down to draw out a new selection"
		^ self extendByHand: evt hand].
	dupLoc ifNotNil: [dupDelta _ self position - dupLoc].
	selectedItems reverseDo: [:m | newOwner addMorphFront: m].
	^ super justDroppedInto: newOwner event: evt! !


!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/31/2000 21:13'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

	aMenu addLine.
	aMenu add: 'add or remove items' target: self selector: #addOrRemoveItems: argument: aHandMorph.
	^ super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/31/2000 22:29'!
addHandlesTo: aHaloMorph box: box
	| onlyThese |
	aHaloMorph haloBox: box.
	onlyThese _ #(addDismissHandle: addMenuHandle: addGrabHandle: addDragHandle: addDupHandle: addHelpHandle: addGrowHandle: addFontSizeHandle: addFontStyleHandle: addFontEmphHandle: addRecolorHandle:).
	Preferences haloSpecifications do:
		[:aSpec | (onlyThese includes: aSpec addHandleSelector) ifTrue:
				[aHaloMorph perform: aSpec addHandleSelector with: aSpec]].
	aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/31/2000 22:59'!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: box leftCenter color: Color blue icon: nil
		on: #mouseUp send: #addOrRemoveItems: to: self.! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 9/1/2000 08:58'!
addOrRemoveItems: handOrEvent
	"Make a new selection extending the current one."

	| oldOwner hand |
	hand _ (handOrEvent isKindOf: HandMorph)
			ifTrue: [handOrEvent]
			ifFalse: [handOrEvent hand].
	hand addMorphBack: ((SelectionMorph newBounds: (hand lastEvent cursorPoint extent: 16@16))
							setOtherSelection: self).
	oldOwner _ owner.
	self world abandonAllHalos.  "Will delete me"
	oldOwner addMorph: self.! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/31/2000 22:59'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #addOrRemoveItems:
		ifTrue: [^'Add items to, or remove them from, this selection.'].
	^ super balloonHelpTextForHandle: aHandle! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 9/19/2000 18:25'!
borderColor: aColor

	| bordered |
	bordered _ selectedItems select: [:m | m isKindOf: BorderedMorph].
	undoProperties ifNil: [undoProperties _ bordered collect: [:m | m borderColor]].
	bordered do: [:m | m borderColor: aColor]! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 9/19/2000 18:25'!
borderWidth: aWidth

	| bordered |
	bordered _ selectedItems select: [:m | m isKindOf: BorderedMorph].
	undoProperties ifNil: [undoProperties _ bordered collect: [:m | m borderWidth]].
	bordered do: [:m | m borderWidth: aWidth]! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/23/2000 17:06'!
dismissViaHalo

	super dismissViaHalo.
	selectedItems do: [:m | m dismissViaHalo]! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/29/2000 22:08'!
doDup: evt fromHalo: halo handle: dupHandle.

	selectedItems _ selectedItems collect: [:m | m duplicate].
	selectedItems do: [:m | self owner addMorph: m].
	dupDelta == nil
		ifTrue: ["First duplicate operation -- note starting location"
				dupLoc _ self position.
				evt hand grabMorph: self.
				halo removeAllHandlesBut: dupHandle]
		ifFalse: ["Subsequent duplicate does not grab, but only moves me and my morphs"
				dupLoc _ nil.
				self position: self position + dupDelta]
! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 9/19/2000 21:53'!
fillStyle: aColor
	undoProperties ifNil: [undoProperties _ selectedItems collect: [:m | m fillStyle]].
	selectedItems do: [:m | m fillStyle: aColor]! !

!SelectionMorph methodsFor: 'halo commands' stamp: 'di 8/31/2000 20:50'!
maybeAddCollapseItemTo: aMenu
	"... don't "! !


!SelectionMorph methodsFor: 'private' stamp: 'di 9/1/2000 08:48'!
doneExtending

	otherSelection ifNotNil:
		[selectedItems _ otherSelection selectedItems , selectedItems.
		otherSelection delete.
		self setOtherSelection: nil].
	self changed; layoutChanged.
	super privateBounds:
		((Rectangle merging: (selectedItems collect: [:m | m bounds]))
			expandBy: 8).
	self changed.
	self addHalo.! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 22:12'!
selectSubmorphsOf: aMorph

	| newItems removals |
	newItems _ aMorph submorphs select:
		[:m | (bounds containsRect: m fullBounds) 
					and: [m~~self
					and: [(m isKindOf: HaloMorph) not]]].
	otherSelection ifNil: [^ selectedItems _ newItems].

	removals _ newItems intersection: itemsAlreadySelected.
	otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals).
	selectedItems _ (newItems copyWithoutAll: removals).
! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:36'!
selectedItems

	^ selectedItems! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 22:02'!
setOtherSelection: otherOrNil

	otherSelection _ otherOrNil.
	otherOrNil == nil
		ifTrue: [super borderColor: Color blue]
		ifFalse: [itemsAlreadySelected _ otherSelection selectedItems.
				super borderColor: Color green]! !

!SelectionMorph methodsFor: 'private' stamp: 'di 8/31/2000 21:45'!
setSelectedItems: items

	selectedItems _ items.
	self changed! !


!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:24'!
borderColorForItems: colorCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: colorCollection
		do: [:m :c | m borderColor: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 8/31/2000 00:26'!
borderWidthForItems: widthCollection

	(selectedItems select: [:m | m isKindOf: BorderedMorph])
		with: widthCollection
		do: [:m :c | m borderWidth: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:53'!
fillStyleForItems: fillStyleCollection

	selectedItems with: fillStyleCollection do: [:m :c | m fillStyle: c]! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 9/19/2000 21:52'!
refineUndoTarget: target selector: selector arguments: arguments in: refineBlock
	"Any morph can override this method to refine its undo specification"
	selector == #fillStyle: ifTrue:
		[refineBlock value: target value: #fillStyleForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #borderColor: ifTrue:
		[refineBlock value: target value: #borderColorForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #borderWidth: ifTrue:
		[refineBlock value: target value: #borderWidthForItems: value: {undoProperties}.
		^ undoProperties _ nil].
	selector == #undoMove:redo:owner:bounds:predecessor: ifTrue:
		["This is the biggy.  Need to gather parameters for all selected items"
		refineBlock value: target
			value: #undoMove:redo:owner:bounds:predecessor:
			value: {arguments first.
					arguments second.
					selectedItems collect: [:m | m owner].
					selectedItems collect: [:m | m bounds].
					selectedItems collect: [:m | m owner morphPreceding: m]}].
	refineBlock value: target value: selector value: arguments! !

!SelectionMorph methodsFor: 'undo' stamp: 'di 8/30/2000 23:44'!
undoMove: cmd redo: redo owner: oldOwners bounds: oldBoundses predecessor: oldPredecessors
	| item |
	"Handle undo and redo of move commands in morphic"
	redo ifFalse:
		["undo sets up the redo state first"
		cmd redoTarget: self
			selector: #undoMove:redo:owner:bounds:predecessor:
			arguments: {cmd. true.
						selectedItems collect: [:m | m owner].
						selectedItems collect: [:m | m bounds].
						selectedItems collect: [:m | m owner morphPreceding: m]}].
	(redo ifTrue: [1 to: selectedItems size]
			ifFalse: [1 to: selectedItems size]) do:
		[:i | item _ selectedItems at: i.
		(oldOwners at: i) ifNotNil:
			[(oldPredecessors at: i)
				ifNil: [(oldOwners at: i) addMorphFront: item]
				ifNotNil: [(oldOwners at: i) addMorph: item after: (oldPredecessors at: i)]].
		item bounds: (oldBoundses at: i).
		(item isKindOf: SystemWindow) ifTrue: [item activate]]! !
StringHolder subclass: #SelectorBrowser
	instanceVariableNames: 'selectorIndex selectorList classListIndex classList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Browser'!

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 12/1/2000 10:38'!
byExample
	"The comment in the bottom pane"

	false ifTrue: [MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10)].
		"to keep the method methodFor: from being removed from the system"

	^ 'Type a fragment of a selector in the top pane.  Accept it.

Or, use an example to find a method in the system.  Type receiver, args, and answer in the top pane with periods between the items.  3. 4. 7

Or, in this pane, use examples to find a method in the system.  Select the line of code and choose "print it".  

	MethodFinder methodFor: #( (4 3) 7  (0 5) 5  (5 5) 10).
This will discover (data1 + data2).

You supply inputs and answers and the system will find the method.  Each inner array is a list of inputs.  It contains the receiver and zero or more arguments.  For Booleans and any computed arguments, use brace notation.

	MethodFinder methodFor: { {1. 3}. true.  {20. 10}. false}.
This will discover the expressions (data1 < data2), (data2 > data1), and many others.

	MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''.  
		{''30 Apr 1999'' asDate}. ''Friday'' }.
This will discover the expression (data1 weekday)

Receiver and arguments do not have to be in the right order.
See MethodFinder.verify for more examples.'! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 3/29/1999 22:12'!
byExample: newText
	"Don't save it"
	^ true! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:20'!
classList
	^ classList! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:23'!
classListIndex
	^ classListIndex! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sw 10/9/1998 08:26'!
classListIndex: anInteger

	classListIndex _ anInteger.
	classListIndex > 0 ifTrue:
		[self dependents do:
			[:dep | ((dep isKindOf: PluggableListView) and:
				[dep setSelectionSelectorIs: #classListIndex:])
					ifTrue: [dep controller controlTerminate]].
		Browser fullOnClass: self selectedClass selector: self selectedMessageName.
		"classListIndex _ 0"]
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:33'!
classListSelectorTitle
	^ 'Class List Menu'! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'bf 10/13/1999 08:32'!
contents: aString notifying: aController
	"Take what the user typed and find all selectors containing it"

	| tokens |
	contents _ aString.
	classList _ #().  classListIndex _ 0.
	selectorIndex _ 0.
	tokens _ contents asString findTokens: ' .'.
	selectorList _ Cursor wait showWhile: [
		tokens size = 1 
			ifTrue: [(Symbol selectorsContaining: contents asString) asSortedArray]
			ifFalse: [self quickList]].	"find selectors from a single example of data"
	self changed: #messageList.
	self changed: #classList.
	^ true! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sw 9/2/1998 16:35'!
implementors
	| aSelector |
	(aSelector _ self selectedMessageName) ifNotNil:
		[Smalltalk browseAllImplementorsOf: aSelector]! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/9/1999 10:07'!
initialExtent

	^ 350@250
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 1/8/2001 18:21'!
listFromResult: resultOC
	"ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array."

	(resultOC first beginsWith: 'no single method') ifTrue: [^ #()].
	^ resultOC sortBy: [:a :b | 
		(a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)].

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'dew 4/29/2000 13:04'!
markMatchingClasses
	"If an example is used, mark classes matching the example instance with an asterisk."

	| unmarkedClassList firstPartOfSelector receiverString receiver |

	"Only 'example' queries can be marked."
	(contents asString includes: $.) ifFalse: [^ self].

	unmarkedClassList _ classList copy.

	"Get the receiver object of the selected statement in the message list."
	firstPartOfSelector _ (Scanner new scanTokens: (selectorList at: selectorIndex)) second.
	receiverString _ (ReadStream on: (selectorList at: selectorIndex))
						upToAll: firstPartOfSelector.
	receiver _ Compiler evaluate: receiverString.

	unmarkedClassList do:
		[:classAndMethod | | class |
		class _ Compiler evaluate:
				((ReadStream on: classAndMethod) upToAll: firstPartOfSelector).
		(receiver isKindOf: class) ifTrue:
			[classList add: '*', classAndMethod.
			classList remove: classAndMethod]].
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 14:19'!
messageList
	"Find all the selectors containing what the user typed in."

	^ selectorList! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/26/1998 10:58'!
messageListIndex
	"Answer the index of the selected message selector."

	^ selectorIndex! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'dew 4/25/2000 18:36'!
messageListIndex: anInteger 
	"Set the selected message selector to be the one indexed by anInteger.  Find all classes it is in."

	selectorIndex _ anInteger.
	selectorIndex = 0 ifTrue: [^ self].

	classList _ Smalltalk allImplementorsOf: self selectedMessageName.
	self markMatchingClasses.
	classListIndex _ 0.
	self changed: #messageListIndex.		"update my selection"
	self changed: #classList.! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sma 2/6/2000 11:42'!
messageListKey: aChar from: view
	"Respond to a command key. Handle (m) and (n) here,
	else defer to the StringHolder behaviour."

	aChar == $m ifTrue: [^ self implementors].
	aChar == $n ifTrue: [^ self senders].
	super messageListKey: aChar from: view
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/9/1999 10:02'!
morphicWindow
	"Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it.  Answer the window
	SelectorBrowser new open "

	| window typeInView selectorListView classListView |
	window _ (SystemWindow labelled: 'later') model: self.
	window setStripeColorsFrom: self defaultBackgroundColor.
	selectorIndex _ classListIndex _ 0.

	typeInView _ PluggableTextMorph on: self 
		text: #contents accept: #contents:notifying:
		readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	typeInView acceptOnCR: true.
	window addMorph: typeInView frame: (0@0 corner: 0.5@0.14).

	selectorListView _ PluggableListMorph on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #selectorMenu:
		keystroke: #messageListKey:from:.
	selectorListView menuTitleSelector: #selectorMenuTitle.
	window addMorph: selectorListView frame: (0@0.14 corner: 0.5@0.6).

	classListView _ PluggableListMorph on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: nil
		keystroke: #arrowKey:from:.
	classListView menuTitleSelector: #classListSelectorTitle.
	window addMorph: classListView frame: (0.5@0 corner: 1@0.6).
	window addMorph: ((PluggableTextMorph on: self text: #byExample 
				accept: #byExample:
				readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
					askBeforeDiscardingEdits: false)
		frame: (0@0.6 corner: 1@1).

	window setLabel: 'Method Finder'.
	^ window! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'hg 9/6/2000 12:18'!
open
	"Create a Browser that lets you type part of a selector, shows a list of selectors,
	shows the classes of the one you chose, and spwns a full browser on it.
		SelectorBrowser new open
	"

	| selectorListView typeInView topView classListView exampleView |
	Smalltalk isMorphic ifTrue: [^ self openAsMorph].

	selectorIndex _ classListIndex _ 0.
	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
		"label and minSize taken care of by caller"

	typeInView _ PluggableTextView on: self 
			text: #contents accept: #contents:notifying:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	typeInView window: (0@0 extent: 50@14);
		askBeforeDiscardingEdits: false.
	topView addSubView: typeInView.

	selectorListView _ PluggableListView on: self
		list: #messageList
		selected: #messageListIndex
		changeSelected: #messageListIndex:
		menu: #selectorMenu:
		keystroke: #messageListKey:from:.
	selectorListView menuTitleSelector: #selectorMenuTitle.
	selectorListView window: (0 @ 0 extent: 50 @ 46).
	topView addSubView: selectorListView below: typeInView.

	classListView _ PluggableListView on: self
		list: #classList
		selected: #classListIndex
		changeSelected: #classListIndex:
		menu: nil	"never anything selected"
		keystroke: #arrowKey:from:.
	classListView menuTitleSelector: #classListSelectorTitle.
	classListView window: (0 @ 0 extent: 50 @ 60).
	topView addSubView: classListView toRightOf: typeInView.

	exampleView _ PluggableTextView on: self 
			text: #byExample accept: #byExample:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	exampleView window: (0@0 extent: 100@40);
		askBeforeDiscardingEdits: false.
	topView addSubView: exampleView below: selectorListView.


	topView label: 'Method Finder'.
	"topView minimumSize: 350@250; maximumSize: 350@250."
	topView subViews do: [:each | each controller].
	topView controller open.

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'di 11/4/1999 13:55'!
openAsMorph
	"Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spwns a full browser on it.
	SelectorBrowser new open   "
	^ self morphicWindow openInWorld! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 1/8/2001 18:37'!
quickList
	"Compute the selectors for the single example of receiver and args, in the very top pane" 

	| data result resultArray newExp dataStrings mf dataObjects aa |
	data _ contents asString.
	"delete trailing period. This should be fixed in the Parser!!"
 	[data last isSeparator] whileTrue: [data _ data allButLast]. 
	data last = $. ifTrue: [data _ data allButLast]. 	"Eval"
	mf _ MethodFinder new.
	data _ mf cleanInputs: data.	"remove common mistakes"
	dataObjects _ Compiler evaluate: '{', data, '}'. "#( data1 data2 result )"
 	dataStrings _ (Compiler new parse: 'zort ' , data in: Object notifying: nil)
				block statements allButLast collect:
				[:node | String streamContents:
					[:strm | (node isKindOf: MessageNode) ifTrue: [strm nextPut: $(].
					node printOn: strm indent: 0.
					(node isKindOf: MessageNode) ifTrue: [strm nextPut: $)].]].
	dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()].
 	dataObjects _ Array with: dataObjects allButLast with: dataObjects last. "#( (data1 data2) result )" 
	result _ mf load: dataObjects; findMessage.
	(result first beginsWith: 'no single method') ifFalse: [
		aa _ self testObjects: dataObjects strings: dataStrings.
		dataObjects _ aa second.  dataStrings _ aa third].
	resultArray _ self listFromResult: result. 
	resultArray isEmpty ifTrue: [self inform: result first].

	dataStrings size = (dataObjects first size + 1) ifTrue:
		[resultArray _ resultArray collect: [:expression |
		newExp _ expression.
		dataObjects first withIndexDo: [:lit :i |
			newExp _ newExp copyReplaceAll: 'data', i printString
							with: (dataStrings at: i)].
		newExp, ' --> ', dataStrings last]].

 	^ resultArray! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'bf 10/13/1999 11:58'!
searchResult: anExternalSearchResult

	self contents: ''.
	classList _ #(). classListIndex _ 0.
	selectorIndex _ 0.
	selectorList _ self listFromResult: anExternalSearchResult.
 	self changed: #messageList.
	self changed: #classList.
	Smalltalk isMorphic ifTrue: [self changed: #contents.]. 
! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'dew 4/19/2000 18:51'!
selectedClass
	"Answer the currently selected class."

	| pairString |
	classListIndex = 0 ifTrue: [^nil].
	pairString _ classList at: classListIndex.
	(pairString includes: $*) ifTrue: [pairString _ pairString allButFirst].
	MessageSet parse: pairString
		toClassAndSelector: [:cls :sel | ^ cls].! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 8/27/1998 17:48'!
selectedClassName
	"Answer the name of the currently selected class."

	classListIndex = 0 ifTrue: [^nil].
	^ self selectedClass name! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 1/18/2001 22:49'!
selectedMessageName
	"Answer the name of the currently selected message."

	| example tokens |
	selectorIndex = 0 ifTrue: [^nil].
	example _ selectorList at: selectorIndex.
	tokens _ Scanner new scanTokens: example.
	tokens size = 1 ifTrue: [^ tokens first].
	tokens first == #^ ifTrue: [^ nil].
	(tokens second includes: $:) ifTrue: [^ example findSelector].
	Symbol hasInterned: tokens second ifTrue: [:aSymbol | ^ aSymbol].
	^ nil! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'mjg 8/19/1999 12:30'!
selectorList: anExternalList

	self contents: ''.
	classList _ #(). classListIndex _ 0.
	selectorIndex _ 0.
	selectorList _ anExternalList.
	self changed: #messageList.
	self changed: #classList.
	Smalltalk isMorphic ifTrue: [self changed: #contents.]. 

! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'hh 1/20/2000 00:15'!
selectorMenu: aMenu
	^ aMenu labels:
'senders (n)
implementors (m)
copy selector to clipboard'
	lines: #()
	selections: #(senders implementors copyName)! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sw 9/2/1998 16:37'!
selectorMenuTitle
	^ self selectedMessageName ifNil: ['<no selection>']! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'sw 9/2/1998 16:35'!
senders
	| aSelector |
	(aSelector _ self selectedMessageName) ifNotNil:
		[Smalltalk browseAllCallsOn: aSelector]! !

!SelectorBrowser methodsFor: 'as yet unclassified' stamp: 'tk 1/18/2001 23:15'!
testObjects: dataObjects strings: dataStrings
	| dataObjs dataStrs selectors classes didUnmodifiedAnswer answerMod do ds result ddo dds |
	"Try to make substitutions in the user's inputs and search for the selector again.
1 no change to answer.
2 answer Array -> OrderedCollection.
2 answer Character -> String
4 answer Symbol or String of len 1 -> Character
	For each of these, try straight, and try converting args:
Character -> String
Symbol or String of len 1 -> Character
	Return array with result, dataObjects, dataStrings.  Don't ever do a find on the same set of data twice."

dataObjs _ dataObjects.  dataStrs _ dataStrings.
selectors _ {#asString. #first. #asOrderedCollection}.
classes _ {Character. String. Array}.
didUnmodifiedAnswer _ false.
selectors withIndexDo: [:ansSel :ansInd | "Modify the answer object"
	answerMod _ false.
	do _ dataObjs copyTwoLevel.  ds _ dataStrs copy.
	(dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [
		((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [
			do at: do size put: (do last perform: ansSel).	"asString"
			ds at: ds size put: ds last, ' ', ansSel.
			result _ MethodFinder new load: do; findMessage.
			(result first beginsWith: 'no single method') ifFalse: [
				"found a selector!!"
				^ Array with: result first with: do with: ds].	
			answerMod _ true]].

	selectors allButLast withIndexDo: [:argSel :argInd | "Modify an argument object"
			"for args, no reason to do Array -> OrderedCollection.  Identical protocol."
		didUnmodifiedAnswer not | answerMod ifTrue: [
		ddo _ do copyTwoLevel.  dds _ ds copy.
		dataObjs first withIndexDo: [:arg :ind |
			(arg isKindOf: (classes at: argInd))  ifTrue: [
				((argSel ~~ #first) or: [arg size = 1]) ifTrue: [
					ddo first at: ind put: ((ddo first at: ind) perform: argSel).	"asString"
					dds at: ind put: (dds at: ind), ' ', argSel.
					result _ MethodFinder new load: ddo; findMessage.
					(result first beginsWith: 'no single method') ifFalse: [
						"found a selector!!"
						^ Array with: result first with: ddo with: dds]	.	
					didUnmodifiedAnswer not & answerMod not ifTrue: [
						didUnmodifiedAnswer _ true].
					]]]]].
	].
^ Array with: 'no single method does that function' with: dataObjs with: dataStrs! !
LeafNode subclass: #SelectorNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!SelectorNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a selector.!


!SelectorNode methodsFor: 'code generation'!
emit: stack args: nArgs on: strm

	self emit: stack
		args: nArgs
		on: strm
		super: false! !

!SelectorNode methodsFor: 'code generation'!
emit: stack args: nArgs on: aStream super: supered
	| index |
	stack pop: nArgs.
	(supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue:
		["short send"
		code < Send
			ifTrue: [^ aStream nextPut: code "special"]
			ifFalse: [^ aStream nextPut: nArgs * 16 + code]].
	index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
	(index <= 31 and: [nArgs <= 7]) ifTrue: 
		["extended (2-byte) send [131 and 133]"
		aStream nextPut: SendLong + (supered ifTrue: [2] ifFalse: [0]).
		^ aStream nextPut: nArgs * 32 + index].
	(supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue:
		["new extended (2-byte) send [134]"
		aStream nextPut: SendLong2.
		^ aStream nextPut: nArgs * 64 + index].
	"long (3-byte) send"
	aStream nextPut: DblExtDoAll.
	aStream nextPut: nArgs + (supered ifTrue: [32] ifFalse: [0]).
	aStream nextPut: index! !

!SelectorNode methodsFor: 'code generation' stamp: 'di 1/7/2000 12:32'!
size: encoder args: nArgs super: supered
	| index |
	self reserve: encoder.
	(supered not and: [code - Send < SendLimit and: [nArgs < 3]])
		ifTrue: [^1]. "short send"
	(supered and: [code < Send]) ifTrue: 
		["super special:"
		code _ self code: (encoder sharableLitIndex: key) type: 5].
	index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256].
	(index <= 31 and: [nArgs <= 7])
		ifTrue: [^ 2]. "medium send"
	(supered not and: [index <= 63 and: [nArgs <= 3]])
		ifTrue: [^ 2]. "new medium send"
	^ 3 "long send"! !


!SelectorNode methodsFor: 'printing' stamp: 'di 11/8/2000 10:04'!
printOn: aStream indent: level 
	aStream withStyleFor: #keyword
		do: [key == nil
				ifTrue: [aStream nextPutAll: '<key==nil>']
				ifFalse: [aStream nextPutAll: key]]! !


!SelectorNode methodsFor: 'inappropriate'!
emitForEffect: stack on: strm

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
emitForValue: stack on: strm

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
sizeForEffect: encoder

	self shouldNotImplement! !

!SelectorNode methodsFor: 'inappropriate'!
sizeForValue: encoder

	self shouldNotImplement! !


!SelectorNode methodsFor: 'testing'!
isPvtSelector
	"Answer if this selector node is a private message selector."

	^key isPvtSelector! !
LinkedList subclass: #Semaphore
	instanceVariableNames: 'excessSignals '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
!Semaphore commentStamp: '<historical>' prior: 0!
I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.!


!Semaphore methodsFor: 'initialize-release'!
initSignals
	"Consume any excess signals the receiver may have accumulated."

	excessSignals _ 0.! !

!Semaphore methodsFor: 'initialize-release'!
terminateProcess
	"Terminate the process waiting on this semaphore, if any."

	self isEmpty ifFalse: [ self removeFirst terminate ].! !


!Semaphore methodsFor: 'communication'!
signal
	"Primitive. Send a signal through the receiver. If one or more processes 
	have been suspended trying to receive a signal, allow the first one to 
	proceed. If no process is waiting, remember the excess signal. Essential. 
	See Object documentation whatIsAPrimitive."

	<primitive: 85>
	self primitiveFailed

	"self isEmpty    
		ifTrue: [excessSignals _ excessSignals+1]    
		ifFalse: [Processor resume: self removeFirstLink]"

! !

!Semaphore methodsFor: 'communication'!
wait
	"Primitive. The active Process must receive a signal through the receiver 
	before proceeding. If no signal has been sent, the active Process will be 
	suspended until one is sent. Essential. See Object documentation 
	whatIsAPrimitive."

	<primitive: 86>
	self primitiveFailed

	"excessSignals>0  
		ifTrue: [excessSignals _ excessSignals-1]  
		ifFalse: [self addLastLink: Processor activeProcess suspend]"
! !

!Semaphore methodsFor: 'communication' stamp: 'jm 9/15/97 17:11'!
waitTimeoutMSecs: anInteger
	"Wait on this semaphore for up to the given number of milliseconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."

	| d |
	d _ Delay timeoutSemaphore: self afterMSecs: (anInteger max: 0).
	self wait.
	d unschedule.
! !

!Semaphore methodsFor: 'communication' stamp: 'jm 9/12/97 11:39'!
waitTimeoutSeconds: anInteger
	"Wait on this semaphore for up to the given number of seconds, then timeout. It is up to the sender to determine the difference between the expected event and a timeout."

	self waitTimeoutMSecs: anInteger * 1000.
! !


!Semaphore methodsFor: 'mutual exclusion'!
critical: mutuallyExcludedBlock 
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."

	| blockValue |
	self wait.
	blockValue _ mutuallyExcludedBlock value.
	self signal.
	^blockValue! !

!Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/8/1998 11:16'!
critical: mutuallyExcludedBlock ifError: errorBlock
	"Evaluate mutuallyExcludedBlock only if the receiver is not currently in 
	the process of running the critical: message. If the receiver is, evaluate 
	mutuallyExcludedBlock after the other critical: message is finished."

	| blockValue hasError errMsg errRcvr |
	self wait.
	hasError _ false.
	blockValue _ [mutuallyExcludedBlock value] ifError:[:msg :rcvr|
		hasError _ true.
		errMsg _ msg.
		errRcvr _ rcvr].
	hasError ifTrue:[
		self signal.
		^errorBlock value: errMsg value: errRcvr].
	self signal.
	^blockValue! !


!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'!
= anObject
	^ self == anObject! !

!Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'!
hash
	^ self identityHash! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Semaphore class
	instanceVariableNames: ''!

!Semaphore class methodsFor: 'instance creation'!
forMutualExclusion
	"Answer an instance of me that contains a single signal. This new 
	instance can now be used for mutual exclusion (see the critical: message 
	to Semaphore)."

	^self new signal! !

!Semaphore class methodsFor: 'instance creation'!
new
	"Answer a new instance of Semaphore that contains no signals."

	^self basicNew initSignals! !
Collection subclass: #SequenceableCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
!SequenceableCollection commentStamp: '<historical>' prior: 0!
I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.!


!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:00'!
after: target
	"Answer the element after target.  Raise an error if target is not
	in the receiver, or if there are no elements after it."

	^ self after: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:02'!
after: target ifAbsent: exceptionBlock
	"Answer the element after target.  Answer the result of evaluation
	the exceptionBlock if target is not in the receiver, or if there are 
	no elements after it."

	| index |
	index _ self indexOf: target.
	^ index == 0
		ifTrue: [exceptionBlock value]
		ifFalse: [index = self size 
			ifTrue: [self errorLastObject: target]
			ifFalse: [self at: index + 1]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:34'!
allButFirst
	"Answer a copy of the receiver containing all but the first
	element. Raise an error if there are not enough elements."

	^ self allButFirst: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButFirst: n
	"Answer a copy of the receiver containing all but the first n
	elements. Raise an error if there are not enough elements."

	^ self copyFrom: n + 1 to: self size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButLast
	"Answer a copy of the receiver containing all but the last
	element. Raise an error if there are not enough elements."

	^ self allButLast: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'!
allButLast: n
	"Answer a copy of the receiver containing all but the last n
	elements. Raise an error if there are not enough elements."

	^ self copyFrom: 1 to: self size - n! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:33'!
anyOne
	^ self first! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:11'!
at: index ifAbsent: exceptionBlock 
	"Answer the element at my position index. If I do not contain an element 
	at index, answer the result of evaluating the argument, exceptionBlock."

	(index between: 1 and: self size) ifTrue: [^ self at: index].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'apb 11/4/2000 22:51'!
atAll: indexArray
	"Answer a new collection like the receiver which contains all elements
	of the receiver at the indices of indexArray."
	"#('one' 'two' 'three' 'four') atAll: #(3 2 4)"

	| newCollection |
	newCollection _ self species ofSize: indexArray size.
	1 to: indexArray size do:
		[:index |
		newCollection at: index put: (self at: (indexArray at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:17'!
atAll: aCollection put: anObject 
	"Put anObject at every index specified by the elements of aCollection."

	aCollection do: [:index | self at: index put: anObject].
	^ anObject! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:18'!
atAll: indexArray putAll: valueArray
	"Store the elements of valueArray into the slots
	of this collection selected by indexArray."

	indexArray with: valueArray do: [:index :value | self at: index put: value].
	^ valueArray! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:45'!
atAllPut: anObject 
	"Put anObject at every one of the receiver's indices."

	| size |
	(size _ self size) > 26 "first method faster from 27 accesses and on"
		ifTrue: [self from: 1 to: size put: anObject]
		ifFalse: [1 to: size do: [:index | self at: index put: anObject]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'di 11/6/1998 14:32'!
atPin: index 
	"Return the index'th element of me if possible.
	Return the first or last element if index is out of bounds."

	index < 1 ifTrue: [^ self first].
	index > self size ifTrue: [^ self last].
	^ self at: index! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:36'!
atRandom
	"Answer a random element of the receiver.  Uses a shared random 
	number generator owned by class Collection.  If you use this a lot, 
	define your own instance of Random and use #atRandom:.  Causes 
	an error if self has no elements."

	^ self atRandom: Collection randomForPicking

"Examples:
	#('one' 'or' 'the' 'other') atRandom
	(1 to: 10) atRandom
	'Just pick one of these letters at random' atRandom
"! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:50'!
atRandom: aGenerator
	"Answer a random element of the receiver.  Uses aGenerator which
	should be kept by the user in a variable and used every time. Use
	this instead of #atRandom for better uniformity of random numbers 
	because only you use the generator.  Causes an error if self has no 
	elements."

	^ self at: (aGenerator nextInt: self size)! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:51'!
atWrap: index 
	"Answer the index'th element of the receiver.  If index is out of bounds,
	let it wrap around from the end to the beginning until it is in bounds."

	^ self at: index - 1 \\ self size + 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:52'!
atWrap: index put: value
	"Store value into the index'th element of the receiver.  If index is out
	of bounds, let it wrap around from the end to the beginning until it 
	is in bounds. Answer value."

	^ self at: index  - 1 \\ self size + 1 put: value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:04'!
before: target
	"Answer the receiver's element immediately before target. Raise an
	error if target is not an element of the receiver, or if there are no 
	elements before it (i.e. it is the first element)."

	^ self before: target ifAbsent: [self errorNotFound: target]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 18:06'!
before: target ifAbsent: exceptionBlock
	"Answer the receiver's element immediately before target. Answer
	the result of evaluating the exceptionBlock if target is not an element
	of the receiver, or if there are no elements before it."

	| index |
	index _ self indexOf: target.
	^ index == 0
		ifTrue: [exceptionBlock value]
		ifFalse: [index == 1 
			ifTrue: [self errorFirstObject: target]
			ifFalse: [self at: index - 1]]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sw 9/8/2000 11:23'!
eighth
	"Answer the eighth element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 8! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:57'!
fifth
	"Answer the fifth element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 5! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'di 6/2/2000 09:16'!
first
	"Answer the first element of the receiver.
	Raise an error if the collection is empty."

	self size = 0 ifTrue: [self errorEmptyCollection].
	^ self at: 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:31'!
first: n
	"Answer the first n elements of the receiver.
	Raise an error if there are not enough elements."

	^ self copyFrom: 1 to: n! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:58'!
fourth
	"Answer the fourth element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 4! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'SqR 10/30/2000 22:06'!
from: startIndex to: endIndex put: anObject
	"Put anObject in all indexes between startIndex 
	and endIndex. Very fast. Faster than to:do: for
	more than 26 positions. Answer anObject"

	| written toWrite thisWrite |

	startIndex > endIndex ifTrue: [^self].
	self at: startIndex put: anObject.
	written _ 1.
	toWrite _ endIndex - startIndex + 1.
	[written < toWrite] whileTrue:
		[
			thisWrite _ written min: toWrite - written.
			self 
				replaceFrom: startIndex + written
				to: startIndex + written + thisWrite - 1
				with: self startingAt: startIndex.
			written _ written + thisWrite
		].
	^anObject! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:20'!
identityIndexOf: anElement 
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer 0."

	^self identityIndexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:21'!
identityIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of anElement within the receiver. If the receiver does 
	not contain anElement, answer the result of evaluating the argument, 
	exceptionBlock."
	1 to: self size do:
		[:i | (self at: i) == anElement ifTrue: [^ i]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:46'!
indexOf: anElement
	"Answer the index of the first occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer 0."

	^ self indexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'!
indexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the first occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the 
	result of evaluating the argument, exceptionBlock."

	^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'!
indexOf: anElement startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the first occurence of anElement after start
	within the receiver. If the receiver does not contain anElement, 
	answer the 	result of evaluating the argument, exceptionBlock."

	start to: self size do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing'!
indexOfSubCollection: aSubCollection startingAt: anIndex 
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of aSubCollection, and the next elements equal 
	the rest of the elements of aSubCollection. Begin the search at element 
	anIndex of the receiver. If no such match is found, answer 0."

	^self
		indexOfSubCollection: aSubCollection
		startingAt: anIndex
		ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing'!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	"Answer the index of the receiver's first element, such that that element 
	equals the first element of sub, and the next elements equal 
	the rest of the elements of sub. Begin the search at element 
	start of the receiver. If no such match is found, answer the result of 
	evaluating argument, exceptionBlock."
	| first index |
	sub isEmpty ifTrue: [^ exceptionBlock value].
	first _ sub first.
	start to: self size - sub size + 1 do:
		[:startIndex |
		(self at: startIndex) = first ifTrue:
			[index _ 1.
			[(self at: startIndex+index-1) = (sub at: index)]
				whileTrue:
				[index = sub size ifTrue: [^startIndex].
				index _ index+1]]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'di 6/2/2000 09:15'!
last
	"Answer the last element of the receiver.
	Raise an error if the collection is empty."

	| size |
	(size _ self size) = 0 ifTrue: [self errorEmptyCollection].
	^ self at: size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:30'!
last: n
	"Answer the last n elements of the receiver.  
	Raise an error if there are not enough elements."

	| size |
	size _ self size.
	^ self copyFrom: size - n + 1 to: size! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:43'!
lastIndexOf: anElement
	"Answer the index of the last occurence of anElement within the 
	receiver. If the receiver does not contain anElement, answer 0."

	^ self lastIndexOf: anElement ifAbsent: [0]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:45'!
lastIndexOf: anElement ifAbsent: exceptionBlock
	"Answer the index of the last occurence of anElement within the  
	receiver. If the receiver does not contain anElement, answer the
	result of evaluating the argument, exceptionBlock."

	self size to: 1 by: -1 do:
		[:index |
		(self at: index) = anElement ifTrue: [^ index]].
	^ exceptionBlock value! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'bf 10/13/1999 10:01'!
middle
	"Answer the middle element of the receiver."
	self emptyCheck.
	^ self at: self size // 2 + 1! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sw 9/7/2000 18:10'!
ninth
	"Answer the ninth element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 9! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'ar 1/20/98 16:22'!
replaceAll: oldObject with: newObject 
	"Replace all occurences of oldObject with newObject"
	| index |
	index _ self
				indexOf: oldObject
				startingAt: 1
				ifAbsent: [0].
	[index = 0]
		whileFalse: 
			[self at: index put: newObject.
			index _ self
						indexOf: oldObject
						startingAt: index + 1
						ifAbsent: [0]]! !

!SequenceableCollection methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement 
	"This destructively replaces elements from start to stop in the receiver. 
	Answer the receiver itself. Use copyReplaceFrom:to:with: for 
	insertion/deletion which may alter the size of the result."

	replacement size = (stop - start + 1)
		ifFalse: [self error: 'Size of replacement doesnt match'].
	^self replaceFrom: start to: stop with: replacement startingAt: 1! !

!SequenceableCollection methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"This destructively replaces elements from start to stop in the receiver 
	starting at index, repStart, in the sequenceable collection, 
	replacementCollection. Answer the receiver. No range checks are 
	performed."

	| index repOff |
	repOff _ repStart - start.
	index _ start - 1.
	[(index _ index + 1) <= stop]
		whileTrue: [self at: index put: (replacement at: repOff + index)]! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:58'!
second
	"Answer the second element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 2! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sw 9/7/2000 18:11'!
seventh
	"Answer the seventh element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 7! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:59'!
sixth
	"Answer the sixth element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 6! !

!SequenceableCollection methodsFor: 'accessing'!
swap: oneIndex with: anotherIndex 
	"Move the element at oneIndex to anotherIndex, and vice-versa."

	| element |
	element _ self at: oneIndex.
	self at: oneIndex put: (self at: anotherIndex).
	self at: anotherIndex put: element! !

!SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:58'!
third
	"Answer the third element of the receiver.
	Raise an error if there are not enough elements."

	^ self checkedAt: 3! !


!SequenceableCollection methodsFor: 'comparing' stamp: 'sma 5/12/2000 14:04'!
= otherCollection 
	"Answer true if the receiver is equivalent to the otherCollection.
	First test for identity, then rule out different species and sizes of
	collections. As a last resort, examine each element of the receiver
	and the otherCollection."

	self == otherCollection ifTrue: [^ true].
	self species == otherCollection species ifFalse: [^ false].
	^ self hasEqualElements: otherCollection! !

!SequenceableCollection methodsFor: 'comparing' stamp: 'tk 12/6/2000 11:39'!
hasEqualElements: otherCollection
	"Answer whether the receiver's size is the same as otherCollection's
	size, and each of the receiver's elements equal the corresponding 
	element of otherCollection.
	This should probably replace the current definition of #= ."

	| size |
	(otherCollection isKindOf: SequenceableCollection) ifFalse: [^ false].
	(size _ self size) = otherCollection size ifFalse: [^ false].
	1 to: size do:
		[:index |
		(self at: index) = (otherCollection at: index) ifFalse: [^ false]].
	^ true! !

!SequenceableCollection methodsFor: 'comparing' stamp: 'SqR 8/3/2000 13:39'!
hash
	| hash |

	hash _ self species hash.
	1 to: self size do: [:i | hash _ (hash + (self at: i) hash) hashMultiply].
	^hash! !


!SequenceableCollection methodsFor: 'converting' stamp: 'TAG 11/6/1998 15:55'!
@ aCollection 
	^ self with: aCollection collect: [:a :b | a @ b]! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'!
asArray
	"Answer an Array whose elements are the elements of the receiver."

	^ Array withAll: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:36'!
asByteArray
	"Answer a ByteArray whose elements are the elements of the receiver."

	^ ByteArray withAll: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 9/14/1998 23:47'!
asFloatArray
	"Answer a FloatArray whose elements are the elements of the receiver, in 
	the same order."

	| floatArray |
	floatArray _ FloatArray new: self size.
	1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ].
	^floatArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:19'!
asIntegerArray
	"Answer an IntegerArray whose elements are the elements of the receiver, in 
	the same order."

	| intArray |
	intArray _ IntegerArray new: self size.
	1 to: self size do:[:i| intArray at: i put: (self at: i)].
	^intArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'djm 11/20/1998 05:44'!
asStringWithCr
	"Convert to a string with returns between items.  Elements are
usually strings.
	 Useful for labels for PopUpMenus."
	| labelStream |
	labelStream _ WriteStream on: (String new: 200).
	self do: [:each |
		(each isKindOf: String)
			ifTrue: [labelStream nextPutAll: each; cr]
			ifFalse: [each printOn: labelStream. labelStream cr]].
	self size > 0 ifTrue: [labelStream skip: -1].
	^ labelStream contents! !

!SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:20'!
asWordArray
	"Answer a WordArray whose elements are the elements of the receiver, in 
	the same order."

	| wordArray |
	wordArray _ WordArray new: self size.
	1 to: self size do:[:i| wordArray at: i put: (self at: i)].
	^wordArray! !

!SequenceableCollection methodsFor: 'converting' stamp: 'di 11/6/1998 09:35'!
isSequenceable
	^ true! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:51'!
readStream
	^ ReadStream on: self! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:56'!
reverse
	^ self reversed! !

!SequenceableCollection methodsFor: 'converting' stamp: 'jm 4/27/98 04:09'!
reversed
	"Answer a copy of the receiver with element order reversed."
	"Example: 'frog' reversed"

	| n result src |
	n _ self size.
	result _ self species new: n.
	src _ n + 1.
	1 to: n do: [:i | result at: i put: (self at: (src _ src - 1))].
	^ result
! !

!SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 12:52'!
writeStream
	^ WriteStream on: self! !


!SequenceableCollection methodsFor: 'copying' stamp: 'di 1/16/98 16:40'!
, otherCollection 
	"Concatenate two Strings or Collections."
	
	^ self copyReplaceFrom: self size + 1
		  to: self size
		  with: otherCollection
"
#(2 4 6 8) , #(who do we appreciate)
((2989 printStringBase: 16) copyFrom: 4 to: 6) , ' boy!!'
"! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'!
copyAfter: anElement
	"Answer a copy of the receiver from after the first occurence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self indexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:05'!
copyAfterLast: anElement
	"Answer a copy of the receiver from after the last occurence
	of anElement up to the end. If no such element exists, answer 
	an empty copy."

	^ self allButFirst: (self lastIndexOf: anElement ifAbsent: [^ self copyEmpty])! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:07'!
copyEmpty
	^ self species new: 0! !

!SequenceableCollection methodsFor: 'copying'!
copyFrom: start to: stop 
	"Answer a copy of a subset of the receiver, starting from element at 
	index start until element at index stop."

	| newSize |
	newSize _ stop - start + 1.
	^(self species new: newSize)
		replaceFrom: 1
		to: newSize
		with: self
		startingAt: start! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:06'!
copyLast: num
	"Deprecated. Use #last:"

	^ self last: num! !

!SequenceableCollection methodsFor: 'copying'!
copyReplaceAll: oldSubstring with: newSubstring 
	"Default is not to do token matching.
	See also String copyReplaceTokens:with:"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: false
	"'How now brown cow?' copyReplaceAll: 'ow' with: 'ello'"
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Pile'"! !

!SequenceableCollection methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: replacementCollection 
	"Answer a copy of the receiver satisfying the following conditions: If 
	stop is less than start, then this is an insertion; stop should be exactly 
	start-1, start = 1 means insert before the first character, start = size+1 
	means append after last character. Otherwise, this is a replacement; start 
	and stop have to be within the receiver's bounds."

	| newSequenceableCollection newSize endReplacement |
	newSize _ self size - (stop - start + 1) + replacementCollection size.
	endReplacement _ start - 1 + replacementCollection size.
	newSequenceableCollection _ self species new: newSize.
	newSequenceableCollection
		replaceFrom: 1
		to: start - 1
		with: self
		startingAt: 1.
	newSequenceableCollection
		replaceFrom: start
		to: endReplacement
		with: replacementCollection
		startingAt: 1.
	newSequenceableCollection
		replaceFrom: endReplacement + 1
		to: newSize
		with: self
		startingAt: stop + 1.
	^newSequenceableCollection! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:00'!
copyUpTo: anElement 
	"Answer all elements up to but not including anObject. If there
	is no such object, answer a copy of the receiver."

	^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:02'!
copyUpToLast: anElement
	"Answer a copy of the receiver from index 1 to the last occurrence of 
	anElement, not including anElement."

	^ self first: (self lastIndexOf: anElement ifAbsent: [^ self copy]) - 1! !

!SequenceableCollection methodsFor: 'copying'!
copyWith: newElement 
	"Answer a copy of the receiver that is 1 bigger than the receiver and has 
	newElement at the last element."

	| newIC |
	newIC _ self species new: self size + 1.
	newIC 
		replaceFrom: 1
		to: self size
		with: self
		startingAt: 1.
	newIC at: newIC size put: newElement.
	^newIC! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 15:38'!
copyWithoutFirst
	"Deprecatd. Return a copy of the receiver which doesn't include
	the first element."

	^ self allButFirst! !

!SequenceableCollection methodsFor: 'copying' stamp: 'ls 6/20/2000 10:59'!
copyWithoutIndex: index
	| copy |
	"return a copy containing all elements except the index-th"
	copy := self species new: self size - 1.
	copy replaceFrom: 1 to: index-1 with: self startingAt: 1.
	copy replaceFrom: index to: copy size with: self startingAt: index+1.
	^copy! !

!SequenceableCollection methodsFor: 'copying' stamp: 'nk 10/31/2000 09:13'!
forceTo: length paddingStartWith: elem 
	"Force the length of the collection to length, padding  
	the beginning of the result if necessary with elem.  
	Note that this makes a copy."
	| newCollection padLen |
	newCollection _ self species new: length.
	padLen _ length - self size max: 0.
	newCollection
		from: 1
		to: padLen
		put: elem.
	newCollection
		replaceFrom: padLen + 1
		to: padLen + self size
		with: self
		startingAt:  1.
	^ newCollection! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/22/2000 18:01'!
forceTo: length paddingWith: elem
	"Force the length of the collection to length, padding
	if necessary with elem.  Note that this makes a copy."

	| newCollection copyLen |
	newCollection _ self species new: length.
	copyLen _ self size min: length.
	newCollection replaceFrom: 1 to: copyLen with: self startingAt: 1.
	newCollection from: copyLen + 1 to: length put: elem.
	^ newCollection! !

!SequenceableCollection methodsFor: 'copying'!
shallowCopy

	^self copyFrom: 1 to: self size! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 5/12/2000 12:36'!
shuffled
	^ self shuffledBy: Collection randomForPicking

"Examples:
	($A to: $Z) shuffled
"! !

!SequenceableCollection methodsFor: 'copying' stamp: 'djp 10/23/1999 22:12'!
shuffledBy: aRandom
	| copy | 
	copy _ self shallowCopy.
	copy size to: 1 by: -1 do: 
		[:i | copy swap: i with: ((1 to: i) atRandom: aRandom)].
	^ copy! !

!SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/28/2000 18:34'!
sortBy: aBlock
	"Create a copy that is sorted.  Sort criteria is the block that accepts two arguments.
	When the block is true, the first arg goes first ([:a :b | a > b] sorts in descending
	order)."

	^ (self asSortedCollection: aBlock) asOrderedCollection! !


!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:41'!
asDigitsToPower: anInteger do: aBlock
	"Repeatedly value aBlock with a single Array.  Adjust the collection
	so that aBlock is presented all (self size raisedTo: anInteger) possible 
	combinations of the receiver's elements taken as digits of an anInteger long number."
	"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"

	| aCollection |
	aCollection _ Array new: anInteger.
	self asDigitsAt: 1 in: aCollection do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:46'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newCollection |
	newCollection _ self species new: self size.
	1 to: self size do:
		[:index |
		newCollection at: index put: (aBlock value: (self at: index))].
	^ newCollection! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 11:47'!
collect: aBlock from: firstIndex to: lastIndex
	"Refer to the comment in Collection|collect:."

	| size result j |
	size _ lastIndex - firstIndex + 1.
	result _ self species new: size.
	j _ firstIndex.
	1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j _ j + 1].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:44'!
collectWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming"
	^ self withIndexCollect: elementAndIndexBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 7/30/97 12:52'!
combinations: kk atATimeDo: aBlock
	"Take the items in the receiver, kk at a time, and evaluate the block for each combination.  Hand in an array of elements of self as the block argument.  Each combination only occurs once, and order of the elements does not matter.  There are (self size take: kk) combinations."
	" 'abcde' combinations: 3 atATimeDo: [:each | Transcript cr; show: each printString]"

	| aCollection |
	aCollection _ Array new: kk.
	self combinationsAt: 1 in: aCollection after: 0 do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:56'!
do: elementBlock separatedBy: separatorBlock
	"Evaluate the elementBlock for all elements in the receiver,
	and evaluate the separatorBlock between."

	1 to: self size do:
		[:index |
		index = 1 ifFalse: [separatorBlock value].
		elementBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 5/1/1999 05:01'!
do: aBlock without: anItem
	"Enumerate all elements in the receiver.
	Execute aBlock for those elements that are not equal to the given item"
	"Refer to the comment in Collection|do:."
	1 to: self size do:
		[:index | anItem = (self at: index) ifFalse:[aBlock value: (self at: index)]]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:43'!
doWithIndex: elementAndIndexBlock
	"Use the new version with consistent naming"
	^ self withIndexDo: elementAndIndexBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:53'!
findBinary: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error.
	Examples:
		#(1 3 5 7 11 15 23) findBinary:[:arg| 11 - arg]
	"
	^self findBinary: aBlock ifNone: [self errorNotFound: aBlock]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:52'!
findBinary: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock."
	| index low high test item |
	low _ 1.
	high _ self size.
	[index _ high + low // 2.
	low > high] whileFalse:[
		test _ aBlock value: (item _ self at: index).
		test = 0 
			ifTrue:[^item]
			ifFalse:[test > 0
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]]].
	^exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'!
findBinaryIndex: aBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, raise an error.
	Examples:
		#(1 3 5 7 11 15 23) findBinaryIndex:[:arg| 11 - arg]
	"
	^self findBinaryIndex: aBlock ifNone: [self errorNotFound: aBlock]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'!
findBinaryIndex: aBlock ifNone: exceptionBlock
	"Search for an element in the receiver using binary search.
	The argument aBlock is a one-element block returning
		0 	- if the element is the one searched for
		<0	- if the search should continue in the first half
		>0	- if the search should continue in the second half
	If no matching element is found, evaluate exceptionBlock."
	| index low high test |
	low _ 1.
	high _ self size.
	[index _ high + low // 2.
	low > high] whileFalse:[
		test _ aBlock value: (self at: index).
		test = 0 
			ifTrue:[^index]
			ifFalse:[test > 0
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]]].
	^exceptionBlock value! !

!SequenceableCollection methodsFor: 'enumerating'!
findFirst: aBlock
	"Return the index of my first element for which aBlock evaluates as true."

	| index |
	index _ 0.
	[(index _ index + 1) <= self size] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating'!
findLast: aBlock
	"Return the index of my last element for which aBlock evaluates as true."

	| index |
	index _ self size + 1.
	[(index _ index - 1) >= 1] whileTrue:
		[(aBlock value: (self at: index)) ifTrue: [^index]].
	^ 0! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:11'!
from: start to: stop do: aBlock
	"Evaluate aBlock for all elements between start and stop (inclusive)."

	start to: stop do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:13'!
keysAndValuesDo: aBlock 
	"Enumerate the receiver with all the keys (aka indices) and values."

	1 to: self size do: [:index | aBlock value: index value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'!
pairsCollect: aBlock 
	"Evaluate aBlock with my elements taken two at a time, and return an Array with the results"

	^ (1 to: self size // 2) collect:
		[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsCollect:
	[:a :b | b, ' is number ', a printString]
"! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'!
pairsDo: aBlock 
	"Evaluate aBlock with my elements taken two at a time.  If there's an odd number of items, ignore the last one.  Allows use of a flattened array for things that naturally group into pairs.  See also pairsCollect:"

	1 to: self size // 2 do:
		[:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)]
"
#(1 'fred' 2 'charlie' 3 'elmer') pairsDo:
	[:a :b | Transcript cr; show: b, ' is number ', a printString]
"! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'ward 7/28/97 09:41'!
permutationsDo: aBlock
	"Repeatly value aBlock with a single copy of the receiver. Reorder the copy
	so that aBlock is presented all (self size factorial) possible permutations."
	"(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]"

	self shallowCopy permutationsStartingAt: 1 do: aBlock! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'tk 12/27/2000 09:53'!
polynomialEval: thisX
	| sum valToPower |
	"Treat myself as the coeficients of a polynomial in X.  Evaluate it with thisX.  First element is the constant and last is the coeficient for the highest power."
	"  #(1 2 3) polynomialEval: 2   "   "is 3*X^2 + 2*X + 1 with X = 2"

	sum _ self first.
	valToPower _ thisX.
	2 to: self size do: [:ind | 
		sum _ sum + ((self at: ind) * valToPower).
		valToPower _ valToPower * thisX].
	^ sum! !

!SequenceableCollection methodsFor: 'enumerating'!
reverseDo: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument, 
	starting with the last element and taking each in sequence up to the 
	first. For SequenceableCollections, this is the reverse of the enumeration 
	for do:."

	self size to: 1 by: -1 do: [:index | aBlock value: (self at: index)]! !

!SequenceableCollection methodsFor: 'enumerating'!
reverseWith: aSequenceableCollection do: aBlock 
	"Evaluate aBlock with each of the receiver's elements, in reverse order, 
	along with the  
	corresponding element, also in reverse order, from 
	aSequencableCollection. "

	self size ~= aSequenceableCollection size ifTrue: [^ self errorNoMatch].
	self size
		to: 1
		by: -1
		do: [:index | aBlock value: (self at: index)
				value: (aSequenceableCollection at: index)]! !

!SequenceableCollection methodsFor: 'enumerating'!
select: aBlock 
	"Refer to the comment in Collection|select:."
	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	1 to: self size do: 
		[:index |
		(aBlock value: (self at: index))
			ifTrue: [aStream nextPut: (self at: index)]].
	^ aStream contents! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 16:00'!
upTo: anObject
	"Deprecated. Use copyUpTo:"

	^ self copyUpTo: anObject! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'!
with: otherCollection collect: twoArgBlock 
	"Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection."
	| result |
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	result _ self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(twoArgBlock
			value: (self at: index)
			value: (otherCollection at: index))].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/3/1999 15:26'!
with: otherCollection do: twoArgBlock 
	"Evaluate twoArgBlock with corresponding elements from this collection and otherCollection."
	otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size'].
	1 to: self size do:
		[:index |
		twoArgBlock value: (self at: index)
				value: (otherCollection at: index)]! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 5/17/1998 13:34'!
withIndexCollect: elementAndIndexBlock 
	"Just like with:collect: except that the iteration index supplies the second argument to the block."
	| result |
	result _ self species new: self size.
	1 to: self size do:
		[:index | result at: index put:
		(elementAndIndexBlock
			value: (self at: index)
			value: index)].
	^ result! !

!SequenceableCollection methodsFor: 'enumerating' stamp: 'di 7/13/97 09:35'!
withIndexDo: elementAndIndexBlock 
	"Just like with:do: except that the iteration index supplies the second argument to the block."
	1 to: self size do:
		[:index |
		elementAndIndexBlock
			value: (self at: index)
			value: index]! !


!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'!
asDigitsAt: anInteger in: aCollection do: aBlock
	"(0 to: 1) asDigitsToPower: 4 do: [:each | Transcript cr; show: each printString]"

	self do: 
		[:each | 
		aCollection at: anInteger put: each.
		anInteger = aCollection size 
			ifTrue: [aBlock value: aCollection]
			ifFalse: [self asDigitsAt: anInteger + 1 in: aCollection do: aBlock]].! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 13:57'!
checkedAt: index
	index > self size ifTrue: [self error: 'not enough elements'].
	^ self at: index! !

!SequenceableCollection methodsFor: 'private' stamp: 'tk 7/30/97 12:42'!
combinationsAt: jj in: aCollection after: nn do: aBlock
	"Choose k of N items and put in aCollection.  jj-1 already chosen.  Indexes of items are in numerical order, to avoid the same combo being used twice.  In this slot, we are allowed to use items in self indexed by nn+1 to self size.  nn is the index used for position jj-1."
	"(1 to: 6) combinationsSize: 3 do: [:each | Transcript cr; show: each printString]"

nn+1 to: self size do: [:index | 
		aCollection at: jj put: (self at: index).
		jj = aCollection size 
			ifTrue: [aBlock value: aCollection]
			ifFalse: [self combinationsAt: jj + 1 in: aCollection after: index do: aBlock]].! !

!SequenceableCollection methodsFor: 'private' stamp: 'tk 1/7/98 10:57'!
copyReplaceAll: oldSubstring with: newSubstring asTokens: ifTokens
	"Answer a copy of the receiver in which all occurrences of
	oldSubstring have been replaced by newSubstring.
	ifTokens (valid for Strings only) specifies that the characters
	surrounding the recplacement must not be alphanumeric.
		Bruce Simth,  must be incremented by 1 and not 
	newSubstring if ifTokens is true.  See example below. "

	| aString startSearch currentIndex endIndex |
	(ifTokens and: [(self isKindOf: String) not])
		ifTrue: [(self isKindOf: Text) ifFalse: [
			self error: 'Token replacement only valid for Strings']].
	aString _ self.
	startSearch _ 1.
	[(currentIndex _ aString indexOfSubCollection: oldSubstring startingAt: startSearch)
			 > 0]
		whileTrue: 
		[endIndex _ currentIndex + oldSubstring size - 1.
		(ifTokens not
			or: [(currentIndex = 1
					or: [(aString at: currentIndex-1) isAlphaNumeric not])
				and: [endIndex = aString size
					or: [(aString at: endIndex+1) isAlphaNumeric not]]])
			ifTrue: [aString _ aString
					copyReplaceFrom: currentIndex
					to: endIndex
					with: newSubstring.
				startSearch _ currentIndex + newSubstring size]
			ifFalse: [
				ifTokens 
					ifTrue: [startSearch _ currentIndex + 1]
					ifFalse: [startSearch _ currentIndex + newSubstring size]]].
	^ aString

"Test case:
	'test te string' copyReplaceAll: 'te' with: 'longone' asTokens: true   "
! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:06'!
errorFirstObject: anObject
	self error: 'specified object is first object'! !

!SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 18:03'!
errorLastObject: anObject
	self error: 'specified object is last object'! !

!SequenceableCollection methodsFor: 'private'!
errorOutOfBounds

	self error: 'indices are out of bounds'! !

!SequenceableCollection methodsFor: 'private' stamp: 'ward 7/28/97 09:38'!
permutationsStartingAt: anInteger do: aBlock
	"#(1 2 3 4) permutationsDo: [:each | Transcript cr; show: each printString]"

	anInteger > self size ifTrue: [^self].
	anInteger = self size ifTrue: [^aBlock value: self].
	anInteger to: self size do:
		[:i | self swap: anInteger with: i.
		self permutationsStartingAt: anInteger + 1 do: aBlock.
		self swap: anInteger with: i]! !


!SequenceableCollection methodsFor: 'removing'!
remove: oldObject ifAbsent: anExceptionBlock 
	"SequencableCollections cannot implement removing."

	self shouldNotImplement! !


!SequenceableCollection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:08'!
includes: anObject
	"Answer whether anObject is one of the receiver's elements."

	^ (self indexOf: anObject) ~= 0! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SequenceableCollection class
	instanceVariableNames: ''!

!SequenceableCollection class methodsFor: 'stream creation'!
streamContents: blockWithArg
	| stream |
	stream _ WriteStream on: (self new: 100).
	blockWithArg value: stream.
	^stream contents! !

!SequenceableCollection class methodsFor: 'stream creation' stamp: 'di 6/20/97 09:07'!
streamContents: blockWithArg limitedTo: sizeLimit
	| stream |
	stream _ LimitedWriteStream on: (self new: (100 min: sizeLimit)).
	stream setLimit: sizeLimit limitBlock: [^ stream contents].
	blockWithArg value: stream.
	^ stream contents
"
String streamContents: [:s | 1000 timesRepeat: [s nextPutAll: 'Junk']] limitedTo: 25
 'JunkJunkJunkJunkJunkJunkJ'
"! !
CompositeAnimation subclass: #SequentialAnimation
	instanceVariableNames: 'index '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Time'!
!SequentialAnimation commentStamp: '<historical>' prior: 0!
This class extends CompositeAnimation for composite animations (an animation built of 2 or more animations) that run one after another in sequence.
!


!SequentialAnimation methodsFor: 'management' stamp: 'jsp 2/26/1999 12:27'!
prologue: currentTime
	"Overrides the Animation prologue: message to set the index of the current animation to 1"

	super prologue: currentTime.

	undoable ifTrue: [
						(myWonderland getUndoStack)
								push: (UndoAnimation new: (self makeUndoVersion)).
					].

	index _ 1.
	((children size) > 0) ifTrue: [(children at: index) prologue: currentTime.]
						ifFalse: [ state _ Finished. ].
! !

!SequentialAnimation methodsFor: 'management' stamp: 'jsp 2/14/1999 18:00'!
update: currentTime
	"This method updates the sequential animation based on the current time."

	| child notDone |

	"Do the prologue to this animation"
	(state = Waiting) ifTrue: [self prologue: currentTime].

	"Finish right away if there are no component animations"
	((children size) = 0) ifTrue: [ state _ Finished].

	"Update the current animation segment.  When it finishes, move on to the next non-zero duration animation. If there aren't any more, then the sequential animation is done."
	(state = Running) ifTrue: [
				child _ children at: index.
				child update: currentTime.
				notDone _ (child getState) = Stopped.
				[ notDone ] whileTrue: [
						index _ index + 1.
						(index <= (children size)) ifTrue: [ child _ children at: index.
														  child prologue: currentTime.
														  child update: currentTime.
														  notDone _ (child getState) = Stopped.
														]
												ifFalse: [ state _ Finished.
														  notDone _ false.
														].
											]

							  ].

	"After the animation finishes run the epilogue."
	(state = Finished) ifTrue: [self epilogue: currentTime].
! !


!SequentialAnimation methodsFor: 'initialization' stamp: 'jsp 2/26/1999 14:27'!
children: childCollection undoable: canUndo inWonderland: aWonderland
	"This method initializes the Animation with all the information that it needs run."

	undoable _ canUndo.
	myWonderland _ aWonderland.
	myScheduler _ aWonderland getScheduler.
	loopCount _ 1.
	direction _ Forward.

	super initialize.

	"Add children"
	childCollection do: [:child | self append: child. child setUndoable: false ].

	"Calculate duration"
	duration _ 0.
	children do: [:child | duration _ duration + ((child getDuration) * (child getLoopCount)) ].

	state _ Waiting.
	myScheduler addAnimation: self.
! !


!SequentialAnimation methodsFor: 'reversing' stamp: 'jsp 3/12/1999 15:09'!
reverseDirection
	"Changes the direction an animation runs in (forward or in reverse)"

	super reverseDirection.

	children _ children reversed.
	childLoopCounts _ childLoopCounts reversed.


! !


!SequentialAnimation methodsFor: 'copying' stamp: 'jsp 3/3/1999 12:30'!
copy
	"Creates a copy of the animation"

	| anim copyOfChildren copyOfChild i |

	anim _ SequentialAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: false
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].

	^ anim.
! !

!SequentialAnimation methodsFor: 'copying' stamp: 'jsp 2/26/1999 14:30'!
makeUndoVersion
	"Creates the undo version of an animation"

	| anim copyOfChildren copyOfChild i |

	anim _ SequentialAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: false
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].
	anim reverseDirection.

	"Undoing a sequential animation takes 2 seconds"	
	anim scaleDuration: (2 / duration).
	anim stop.

	^ anim.
! !

!SequentialAnimation methodsFor: 'copying' stamp: 'jsp 4/9/1999 14:21'!
reversed
	"Creates a reversed version of an animation"

	| anim copyOfChildren copyOfChild i |

	anim _ SequentialAnimation new.

	i _ 1.
	copyOfChildren _ OrderedCollection new.
	children do: [:child | copyOfChild _ child copy.
						 copyOfChild setLoopCount: (childLoopCounts at: i).
						 copyOfChildren addLast: copyOfChild.
						 i _ i + 1 ].

	anim children: copyOfChildren
		undoable: true
		inWonderland: myWonderland.

	(direction = Reverse) ifTrue: [ anim setDirection: Reverse ].
	anim reverseDirection.

	anim stop.

	^ anim.
! !
AbstractSound subclass: #SequentialSound
	instanceVariableNames: 'sounds currentIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SequentialSound methodsFor: 'initialization' stamp: 'jm 2/4/98 10:00'!
initialize

	super initialize.
	sounds _ Array new.
	currentIndex _ 0.
! !


!SequentialSound methodsFor: 'accessing' stamp: 'RAA 12/7/2000 17:24'!
duration
	"Answer the duration of this sound in seconds."

	"7 dec 2000 - handle compressed sounds. better way??"

	| dur |
	dur _ 0.
	sounds do: [:snd | dur _ dur + snd asSound duration].
	^ dur
! !

!SequentialSound methodsFor: 'accessing' stamp: 'jm 2/4/98 13:36'!
sounds

	^ sounds
! !


!SequentialSound methodsFor: 'sound generation' stamp: 'jm 11/25/97 13:41'!
doControl

	super doControl.
	currentIndex > 0
		ifTrue: [(sounds at: currentIndex) doControl].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:16'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Play a collection of sounds in sequence."
	"PluckedSound chromaticScale play"

	| finalIndex i snd remaining count |
	currentIndex = 0 ifTrue: [^ self].  "already done"
	finalIndex _ (startIndex + n) - 1.
	i _ startIndex.
	[i <= finalIndex] whileTrue: [
		snd _ (sounds at: currentIndex).
		[(remaining _ snd samplesRemaining) <= 0] whileTrue: [
			"find next undone sound"
			currentIndex < sounds size
				ifTrue: [
					currentIndex _ currentIndex + 1.
					snd _ (sounds at: currentIndex)]
				ifFalse: [
					currentIndex _ 0.
					^ self]].  "no more sounds"
		count _ (finalIndex - i) + 1.
		remaining < count ifTrue: [count _ remaining].
		snd mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i _ i + count].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:47'!
reset

	super reset.
	sounds do: [:snd | snd reset].
	sounds size > 0 ifTrue: [currentIndex _ 1].
! !

!SequentialSound methodsFor: 'sound generation' stamp: 'jm 12/15/97 22:47'!
samplesRemaining

	currentIndex = 0
		ifTrue: [^ 0]
		ifFalse: [^ 1000000].
! !


!SequentialSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:10'!
copy
	"Copy my component sounds."

	^ super copy copySounds
! !

!SequentialSound methodsFor: 'copying' stamp: 'jm 12/15/97 22:48'!
copySounds
	"Private!! Support for copying. Copy my component sounds."

	sounds _ sounds collect: [:s | s copy].
! !

!SequentialSound methodsFor: 'copying' stamp: 'di 12/7/2000 15:46'!
transformSounds: tfmBlock
	"Private!! Support for copying. Copy my component sounds."

	sounds _ sounds collect: [:s | tfmBlock value: s].
! !


!SequentialSound methodsFor: 'composition'!
, aSound
	"Return the concatenation of the receiver and the argument sound."

	^ self add: aSound
! !

!SequentialSound methodsFor: 'composition' stamp: 'jm 12/15/97 22:48'!
add: aSound

	sounds _ sounds copyWith: aSound.
! !

!SequentialSound methodsFor: 'composition' stamp: 'di 12/7/2000 16:03'!
compressWith: codecClass
	^ self copy transformSounds: [:s | s compressWith: codecClass]! !

!SequentialSound methodsFor: 'composition' stamp: 'RAA 12/24/2000 08:42'!
compressWith: codecClass atRate: aSamplingRate
	^ self copy transformSounds: [:s | s compressWith: codecClass atRate: aSamplingRate]! !

!SequentialSound methodsFor: 'composition' stamp: 'jm 4/14/1999 10:05'!
pruneFinishedSounds
	"Remove any sounds that have been completely played."

	| newSnds |
	(currentIndex > 1 and: [currentIndex < sounds size]) ifFalse: [^ self].
	newSnds _ sounds copyFrom: currentIndex to: sounds size.
	currentIndex _ 1.
	sounds _ newSnds.
! !

!SequentialSound methodsFor: 'composition' stamp: 'RAA 8/9/2000 16:27'!
removeFirstCompleteSoundOrNil
	"Remove the first sound if it has been completely recorded."

	| firstSound |

	sounds size > 0 ifFalse: [^ nil].
	firstSound _ sounds first.
	sounds _ sounds copyFrom: 2 to: sounds size.
	^firstSound
! !
TestInterpreterPlugin subclass: #SerialPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!SerialPlugin commentStamp: '<historical>' prior: 0!
Implement the serial port primitives.!


!SerialPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:53'!
initialiseModule
	self export: true.
	^self cCode: 'serialPortInit()' inSmalltalk:[true]! !

!SerialPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:55'!
shutdownModule
	self export: true.
	^self cCode: 'serialPortShutdown()' inSmalltalk:[true]! !


!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 2/17/2000 18:16'!
primitiveSerialPortClose: portNum

	self primitive: 'primitiveSerialPortClose'
		parameters: #(SmallInteger).
	self serialPortClose: portNum! !

!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 2/11/2000 16:08'!
primitiveSerialPortOpen: portNum baudRate: baudRate stopBitsType: stopBitsType parityType: parityType dataBits: dataBits inFlowControlType: inFlowControl outFlowControlType: outFlowControl xOnByte: xOnChar xOffByte: xOffChar

	self primitive: 'primitiveSerialPortOpen'
		parameters: #(SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger ).

	self cCode: 'serialPortOpen(
			portNum, baudRate, stopBitsType, parityType, dataBits,
			inFlowControl, outFlowControl, xOnChar, xOffChar)'! !

!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 17:00'!
primitiveSerialPortRead: portNum into: array startingAt: startIndex count: count 
	| bytesRead arrayPtr |
	self primitive: 'primitiveSerialPortRead'
		parameters: #(SmallInteger ByteArray SmallInteger SmallInteger ).

	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	arrayPtr _ array asInteger + startIndex - 1.
	bytesRead _ self cCode: 'serialPortReadInto( portNum, count, arrayPtr)'.
	"adjust for zero-origin indexing"
	^ bytesRead asSmallIntegerObj! !

!SerialPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 17:00'!
primitiveSerialPortWrite: portNum from: array startingAt: startIndex count: count 
	| bytesWritten arrayPtr |
	self primitive: 'primitiveSerialPortWrite'
		parameters: #(SmallInteger ByteArray SmallInteger SmallInteger ).

	interpreterProxy success: (startIndex >= 1 and: [startIndex + count - 1 <= (interpreterProxy byteSizeOf: array cPtrAsOop)]).
	interpreterProxy failed
		ifFalse: [arrayPtr _ array asInteger + startIndex - 1.
			bytesWritten _ self
						serialPort: portNum
						Write: count
						From: arrayPtr].
	^ bytesWritten asSmallIntegerObj! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SerialPlugin class
	instanceVariableNames: ''!

!SerialPlugin class methodsFor: 'translation' stamp: 'ar 5/11/2000 22:22'!
headerFile
^'/* serial port primitives */

/* module initialization/shutdown */
int serialPortInit(void);
int serialPortShutdown(void);

int serialPortClose(int portNum);
int serialPortOpen(
  int portNum, int baudRate, int stopBitsType, int parityType, int dataBits,
  int inFlowCtrl, int outFlowCtrl, int xOnChar, int xOffChar);
int serialPortReadInto(int portNum, int count, int bufferPtr);
int serialPortWriteFrom(int portNum, int count, int bufferPtr);
'! !
Object subclass: #SerialPort
	instanceVariableNames: 'port baudRate stopBitsType parityType dataBits outputFlowControlType inputFlowControlType xOnByte xOffByte '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Serial Port'!
!SerialPort commentStamp: '<historical>' prior: 0!
This class supports a simple interface to the serial ports of the underlying platform, if it supports serial ports. The mapping of port numbers to hardware ports is platform specific, but typically follows platform ordering conventions. For example, on the Macintosh, port 0 is the modem port and port 1 is the printer port, since in the programmers documentation these ports are referred to as ports A and B.
!


!SerialPort methodsFor: 'initialization' stamp: 'jm 5/5/1998 15:49'!
initialize
	"Default port settings."

	port _ nil.					"set when opened"
	baudRate _ 9600.			"9600 baud"
	stopBitsType _ 1.				"one stop bit"
	parityType _ 0.				"no parity"
	dataBits _ 8.					"8 bits"
	outputFlowControlType _ 0.	"none"
	inputFlowControlType _ 0.	"none"
	xOnByte _ 19.				"ctrl-S"
	xOffByte _ 24.				"ctrl-X"
! !


!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
baudRate

	^ baudRate
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
baudRate: anInteger
	"Set the baud rate for this serial port."

	baudRate _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
dataBits

	^ dataBits
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
dataBits: anInteger
	"Set the number of data bits for this serial port to 5, 6, 7, or 8."

	dataBits _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:21'!
inputFlowControlType

	^ inputFlowControlType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'!
inputFlowControlType: anInteger
	"Set the type of input flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	inputFlowControlType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
outputFlowControlType

	^ outputFlowControlType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:38'!
outputFlowControlType: anInteger
	"Set the type of output flow control, where:
		0 - none
		1 - XOn/XOff
		2 - hardware handshaking"

	outputFlowControlType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
parityType

	^ parityType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:29'!
parityType: anInteger
	"Set the parity type for this serial port, where:
		0 - no parity
		1 - odd parity
		2 - even parity"

	parityType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:19'!
stopBitsType

	^ stopBitsType
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 18:02'!
stopBitsType: anInteger
	"Set the stop bits type for this serial port, where:
		0 - 1.5 stop bits
		1 - one stop bit
		2 - two stop bits"

	stopBitsType _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'!
xOffByte

	^ xOffByte
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'!
xOffByte: anInteger
	"Set the value of the XOff byte to be used if XOn/XOff flow control is enabled."

	xOffByte _ anInteger.
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:20'!
xOnByte

	^ xOnByte
! !

!SerialPort methodsFor: 'settings' stamp: 'jm 5/1/1998 17:28'!
xOnByte: anInteger
	"Set the value of the XOn byte to be used if XOn/XOff flow control is enabled."

	xOnByte _ anInteger.
! !


!SerialPort methodsFor: 'open/close' stamp: 'jm 5/18/1998 15:40'!
close
	"Close the serial port. Do nothing if the port is not open."

	port ifNotNil: [self primClosePort: port].
	port _ nil.
! !

!SerialPort methodsFor: 'open/close' stamp: 'dns 6/27/2000 19:49'!
openPort: portNumber
	"Open the given serial port, using the settings specified by my instance variables. If the port cannot be opened, such as when it is alreay in use, answer nil."  "(DNS)"

	self close.
	(self primClosePort: portNumber) isNil ifTrue: [
		^ nil ].
	(self primOpenPort: portNumber
		baudRate: baudRate
		stopBitsType: stopBitsType
		parityType: parityType
		dataBits: dataBits
		inFlowControlType: inputFlowControlType
		outFlowControlType: outputFlowControlType
		xOnByte: xOnByte
		xOffByte: xOffByte) isNil ifTrue: [
			^ nil ].
	port _ portNumber
! !


!SerialPort methodsFor: 'input/output' stamp: 'yo 2/2/2001 15:13'!
nextPutAll: aStringOrByteArray
	"Send the given bytes out this serial port. The port must be open."

	^ self primWritePort: port
		from: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size.
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:44'!
readByteArray
	"Answer a ByteArray read from this serial port. Answer an empty ByteArray if no data is available. The port must be open."

	| buf count |
	buf _ ByteArray new: 1000.
	count _ self primReadPort: port into: buf startingAt: 1 count: buf size.
	^ buf copyFrom: 1 to: count
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:46'!
readInto: aStringOrByteArray startingAt: index
	"Read data into the given String or ByteArray object starting at the given index, and answer the number of bytes read. Does not go past the end of the given String or ByteArray."

	^ self primReadPort: port
		into: aStringOrByteArray
		startingAt: index
		count: (aStringOrByteArray size - index) + 1.
! !

!SerialPort methodsFor: 'input/output' stamp: 'jm 5/18/1998 15:43'!
readString
	"Answer a String read from this serial port. Answer the empty String if no data is available. The port must be open."

	| buf count |
	buf _ String new: 1000.
	count _ self primReadPort: port into: buf startingAt: 1 count: buf size.
	^ buf copyFrom: 1 to: count
! !


!SerialPort methodsFor: 'printing' stamp: 'jm 5/1/1998 18:02'!
printOn: aStream

	aStream
		nextPutAll: 'SerialPort(';
		nextPutAll:
			(port ifNil: ['closed'] ifNotNil: ['#', port printString]);
		nextPutAll: ', ';
		print: baudRate; nextPutAll: ' baud, ';
		print: dataBits; nextPutAll: ' bits, ';
		nextPutAll: (#('1.5' '1' '2') at: stopBitsType + 1); nextPutAll: ' stopbits, ';
		nextPutAll: (#('no' 'odd' 'even') at: parityType + 1); nextPutAll: ' parity)'.
! !


!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClosePort: portNumber

	<primitive: 'primitiveSerialPortClose' module: 'SerialPlugin'>
	^ nil  "(DNS)"
	"self primitiveFailed."
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpenPort: portNumber baudRate: baud stopBitsType: stop
	parityType: parity dataBits: numDataBits
	inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl
	xOnByte: xOn xOffByte: xOff

	<primitive: 'primitiveSerialPortOpen' module: 'SerialPlugin'>
	^ nil  "(DNS)"
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primReadPort: portNumber into: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortRead' module: 'SerialPlugin'>
	self primitiveFailed.
! !

!SerialPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWritePort: portNumber from: byteArray startingAt: startIndex count: count

	<primitive: 'primitiveSerialPortWrite' module: 'SerialPlugin'>
	self primitiveFailed.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SerialPort class
	instanceVariableNames: ''!

!SerialPort class methodsFor: 'instance creation' stamp: 'jm 5/1/1998 17:39'!
new

	^ super new initialize
! !
Object subclass: #ServerAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!ServerAction commentStamp: '<historical>' prior: 0!
The ServerAction class is the default ServerAction (if the first token in the URL does not match any in the PWS ActionTable). Instances of ServerAction act like Mac Web servers -- they parse the URL into a Mac file path (including use of default.html if no final filename is provided), then return the contents of that file as the reply. 

All ServerActions get asked to process: a PWS request. This ServerAction does the processing by asking itself to checkAuthorization, to parse the request, to log the parsed request, and then to reply to the request.  Other ServerActions (like EmbeddedServerAction) can override one or more of those requests.

The ServerAction class provides a ServerDirectory service.!


!ServerAction methodsFor: 'file input/output' stamp: 'mjg 11/17/97 14:06'!
fileContents: serverFileRef
	^(FileStream fileNamed: (ServerAction serverDirectory) , serverFileRef)
	 contentsOfEntireFile! !

!ServerAction methodsFor: 'file input/output' stamp: 'mjg 11/25/97 14:17'!
subdirectory: named
	^named, (ServerAction pathSeparator)! !


!ServerAction methodsFor: 'URL processing' stamp: 'mjg 11/4/97 16:37'!
checkAuthorization: request
	^self! !

!ServerAction methodsFor: 'URL processing' stamp: 'mjg 10/25/97 15:02'!
log: pieces to: request
	| tab |
	tab := String with: Character tab.
	request log: ((Time now printString), tab, (Date today printString), tab, (pieces printString),
	Character cr asString).

! !

!ServerAction methodsFor: 'URL processing' stamp: 'mjg 11/19/97 09:00'!
parse: request
	| filename |
	filename := (ServerAction serverDirectory) , ((request url) allButFirst copyReplaceAll: '/' with: 
		(ServerAction pathSeparator)).
	(filename endsWith: (ServerAction pathSeparator)) ifTrue: [filename _ filename , (ServerAction defaultFile)].
	^filename
! !

!ServerAction methodsFor: 'URL processing' stamp: 'mjg 11/4/97 16:37'!
process: request
	| pieces |
	self checkAuthorization: request.
	pieces _ self parse: request.
	self log: pieces to: request.
	self replyTo: pieces from: request.
! !

!ServerAction methodsFor: 'URL processing' stamp: 'mdr 9/4/2000 10:52'!
process: request MIMEtype: imageGif
	"See if there is a .gif file on my disk of this name, and send it out."

	| fName |
	fName _ ServerAction serverDirectory, (request message at: 1),
		(ServerAction pathSeparator), (request message at: 2).
	3 to: request message size do: [:part |
		fName _ fName, '.', (request message at: part)].
	Transcript show: fName; cr.
	(FileDirectory default fileExists: fName)
		ifTrue: ["maybe send out content-length?"
			request reply: (PWS success),(PWS content: imageGif), PWS crlf.
			request reply: (FileStream readOnlyFileNamed: fName) contentsOfEntireFile]
		ifFalse: [
			request reply: ( 'HTTP/1.0 400 Bad Request', PWS crlfcrlf, 'file not found')].
! !

!ServerAction methodsFor: 'URL processing' stamp: 'mjg 4/21/2000 14:10'!
replyTo: pieces from: request

	"Transcript show: 'Reply: ', pieces; cr."
	(StandardFileStream isAFileNamed: pieces) 
		ifTrue: [
			request reply: PWS success; 
				reply: (PWS content: (MIMEDocument guessTypeFromName: pieces)),
					 PWS crlf.
			request reply: (FileStream fileNamed: pieces) contentsOfEntireFile]
		ifFalse: [
			request error: PWS notFound].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServerAction class
	instanceVariableNames: ''!

!ServerAction class methodsFor: 'System Services' stamp: 'mjg 11/17/97 11:17'!
defaultFile
	^'default.html'! !

!ServerAction class methodsFor: 'System Services' stamp: 'mjg 11/20/97 10:12'!
pathSeparator
  ^String with: FileDirectory pathNameDelimiter
! !

!ServerAction class methodsFor: 'System Services' stamp: 'tk 1/19/98 12:52'!
serverDirectory
	^ 'Home Plate:Valentine II:Server:'
! !
Object subclass: #ServerDirectory
	instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject socket loaderUrl '
	classVariableNames: 'Servers '
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ServerDirectory commentStamp: '<historical>' prior: 0!
Holds all the information needed to read or write on a directory of an internet server.  I am used for FTP and HTTP (and STMP?  NNTP?).  The password policy is: unless it is a public password (like annomyous), clear all passwords before any snapshot.  There is a way to store passwords on the disk.

server 		'www.disney.com'  or '123.34.56.08' or the ServerDirectory above me 
			(if I am a subdirectory sharing the info in a master directory)
directory 	'ftp/pubs/'  name of my directory within the server or superdirectory.
			(for file://, directory is converted to local delimiters.)
type 		#ftp	what you can do in this directory
user 		'Jones45'
password 	an instance of Password.  
group 		an Association ('group name' -> an array of ServerDirectorys)
			If this first one is down, try the next one.  Store on all of them.  I am in the list.
moniker 	'Main Squeak Directory'  Description of this directory.
altURL		When a FTP server holds some web pages, the altURL of those pages is often
			different from the FTP directory.  Put the altURL here.  If the directory is 
			'public_html/Squeak/', the altURL might be 'www.webPage.com/~kaehler2/
			Squeak/'.
urlObject	An instance of a subclass of Url.  It is very good at parsing complex urls.
			Relative references.  file:// uses this.  Use this in the future instead of 
			server and directory inst vars.
socket		nil or an FTPSocket.  Only non-nil if the connection is being kept open
			for multiple stores or retrievals.  
loaderUrl	a partial url that is ised to invoke squeak in a browser and load a project.

A normal call on some command like (aServer getFileNamed: 'foo') does not set 'socket'.  Socket being nil tells it to close the connection and destroy the socket after this one transcation.  If the caller stores into 'socket', then the same command does NOT close the 
connection.  
	Call 'openKeepFTP' or 'openGroup' to store into socket and keep the connection open.  It is up to the user to call 'quit' or 'closeGroup' later.

DD openKeepFTP.
Transcript cr; show: ((DD getFileNamed: '1198misc-tkKG.cs') next: 100).
Transcript cr; show: ((DD getFileNamed: '1192multFinder-tkKF.cs') next: 100).
DD quit.!
]style[(677 8 1493)f1,f1LPassword Comment;,f1!


!ServerDirectory methodsFor: 'do ftp' stamp: 'RAA 6/23/2000 09:47'!
fileExists: fileName
	"Does the file exist on this server directory?  fileName must be simple with no / or references to other directories."

	self isTypeFile ifTrue: [^ self fileNames includes: fileName].
	self isTypeHTTP ifTrue: [^ (self readOnlyFileNamed: fileName) class ~~ String].
	"ftp"
	^ (self getFileList contentsOfEntireFile findTokens: FTPSocket crLf) includes: fileName! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 5/11/1999 16:43'!
getDirectory
	"Return a stream with a listing of the current server directory.  (Later -- Use a proxy server if one has been registered.)"

	| so dd resp rr |
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'LIST'.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'getting directory LIST'; cr.
	"Transcript show: 'retrieve from port ', dd portNum printString; cr."
	resp _ dd getAllDataWhileWatching: so.	"Later use the length to pre-allocate the buffer"
	(resp == #error:) ifTrue: [socket _ nil.  ^ resp].
	dd close.

	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"150 Opening binary conn on foo (3113 bytes)"
	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"226 Transfer complete."
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
	dd destroy.

	^ resp	"RWStream with just the data"! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 5/11/1999 16:43'!
getFileList
	"Return a stream with a list of files in the current server directory.  (Later -- Use a proxy server if one has been registered.)"

	| so dd resp rr |
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'NLST'.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'getting file list NLST'; cr.
	"Transcript show: 'retrieve from port ', dd portNum printString; cr."
	resp _ dd getAllDataWhileWatching: so.	"Later use the length to pre-allocate the buffer"
	(resp == #error:) ifTrue: [socket _ nil.  ^ resp].
	dd close.

	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"150 Opening binary conn on foo (3113 bytes)"
	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"226 Transfer complete."
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
	dd destroy.

	^ resp	"RWStream with just the data"! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 3/23/2000 22:56'!
getFileNamed: fileNameOnServer
	"Just FTP a file from a server.  Return a stream.  (Later -- Use a proxy server if one has been registered.)"

	| so dd resp rr |
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'RETR ', fileNameOnServer.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'retrieving file ', fileNameOnServer; cr.
	"Transcript show: 'retrieve from port ', dd portNum printString; space;
		show: fileNameOnServer; cr."
	resp _ dd getAllDataWhileWatching: so.	"Later use the length to pre-allocate the buffer"
	(resp == #error:) ifTrue: [socket _ nil.  ^ resp].
	dd close.

	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"150 Opening binary conn on foo (3113 bytes)"
	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"226 Transfer complete."
	socket ifNil: ["normally leave connection open.  Don't quit"
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
	dd destroy.

	^ resp	"a RWBinaryOrTextStream"! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'RAA 6/23/2000 09:47'!
getFileNamed: fileNameOnServer into: dataStream
	"Just FTP a file from a server.  Return a stream.  (Later -- Use a proxy server if one has been registered.)"

	| so dd resp rr |
	self isTypeFile ifTrue: [
		dataStream nextPutAll: 
			(resp _ FileStream oldFileNamed: server,(self serverDelimiter asString), 
				self bareDirectory, (self serverDelimiter asString),
				fileNameOnServer) contentsOfEntireFile.
		dataStream dataIsValid.
		^ resp].
	self isTypeHTTP ifTrue: [
		resp _ HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 
				accept: 'application/octet-stream'.
		resp class == String ifTrue: [^ dataStream].	"error, no data"
		dataStream copyFrom: resp.
		dataStream dataIsValid.
		^ dataStream].
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'RETR ', fileNameOnServer.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'retrieving file ', fileNameOnServer; cr.
	"Transcript show: 'retrieve from port ', dd portNum printString; cr."
	resp _ dd getDataTo: dataStream whileWatching: so.
		"Later use the length to pre-allocate the buffer"
	(resp == #error:) ifTrue: [socket _ nil.  ^ resp].
	dd close.

	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"150 Opening binary conn on foo (3113 bytes)"
	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"226 Transfer complete."
	socket ifNil: ["normally leave connection open.  Don't quit"
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
	dd destroy.

	dataStream dataIsValid.
	^ resp	"String with just the data"! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 3/24/2000 11:05'!
getOnlyBuffer: buffer from: fileNameOnServer
	"Open ftp, fill the buffer, and close the connection.  Only first part of a very long file."
	| so dd resp rr |

	"type == #ftp"
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'RETR ', fileNameOnServer.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'retrieving beginning of file ', fileNameOnServer; cr.
	resp _ dd getOnlyBuffer: buffer whileWatching: so.
	(resp == #error:) ifTrue: [socket _ nil.  ^ resp].

	(rr _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"150 Opening binary conn on foo (3113 bytes)"
	dd destroy.
	so sendCommand: 'ABOR'.
	socket _ nil.
	so destroy.	"Just be as rude as possible"

	^ resp	"String with just the data"! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 5/11/1999 17:35'!
openFTP
	"Open a connection to the directory and server I hold.  Return a FTPSocket.  It has opened passive, and has a dataPort number assigned to a data FTPSocket.  But the data connection is not open.  When you are done, be sure to tell the socket to QUIT, and then destroy it."

| so resp portInfo list dataPort dd rr |
	(so _ self openNoDataFTP) class == String ifTrue: [^ so].
	so sendCommand: 'TYPE L 8'.
	(rr _ so lookFor: '200 ') == true ifFalse: [socket _ nil.  ^ rr].	"200 Type set to L"

	so sendCommand: 'PASV'.
	resp _ (so getResponseUpTo: FTPSocket crLf) first.
		"Tells which port on server to use for data"
	"Transcript show: resp; cr."
	(resp beginsWith: '227 ') ifFalse: [ "Check for Entering Passive Mode"
		so sendCommand: 'QUIT'.
		so destroy. socket _ nil.
		^ self error: 'can''t get into passive mode'].
	portInfo _ (resp findTokens: '()') at: 2.
	list _ portInfo findTokens: ','.
	dataPort _ (list at: 5) asNumber * 256 + (list at: 6) asNumber.
	dd _ FTPSocket new.
	dd portNum: dataPort.
	so dataSocket: dd.	"save it, not opened yet"
	^ so! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'RAA 9/14/2000 13:42'!
openNoDataFTP
	"Open a connection to the directory and server I hold.  Return a FTPSocket.  No dataPort is opened.  When you are all done, be sure to tell the socket to QUIT, and then destroy it."

	| so rr serverIP what |
	Socket initializeNetwork.
	socket ifNotNil: [socket isValid 
			ifTrue: [^ socket]	"already open"
			ifFalse: [socket _ nil]].

	Cursor wait showWhile: [
		FTPSocket retry: [serverIP _ NetNameResolver addressForName: server timeout: 20.
					serverIP ~~ nil] 
			asking: 'Trouble resolving server name.  Keep trying?'
			ifGiveUp: [^ 'Could not resolve the server named: ', server].
		so _ FTPSocket new.
		so portNum: 21.
		so connectTo: serverIP port: 21.  "21 is for the control connection"
		so waitForConnectionUntil: FTPSocket standardDeadline.
		].

	Transcript cr; show: 'ftp: ', server; cr.
	(rr _ so lookFor: '220 ') == true ifFalse: [^ rr].	"220 para1 Microsoft FTP Service"
	[	"repeat both USER and PASS since some servers require it"
		so sendCommand: 'USER ', user.
		(rr _ so lookFor: '331 ') == true ifFalse: [^ rr].	"331 Password required"
		so sendCommand: 'PASS ', self password.		"will ask user, if needed"
		 (rr _ so lookSoftlyFor: '230 ') == true
	] 	"230 User logged in"
		whileFalse: [
			rr first == $5 ifFalse: [^ rr].	"timeout"
			passwordHolder _ nil.
			what _ (PopUpMenu labels: 'enter password\give up' withCRs) 
				startUpWithCaption: 'Would you like to try another password?'.
			what = 1 ifFalse: [so destroy.  ^ rr]].
	directory isEmpty ifFalse: [
		so sendCommand: 'CWD ', directory.
		(rr _ so lookFor: '250 ') == true ifFalse: [^ rr].	"250 CWD successful"
	].
	"Need to ask for name of directory to make sure?"
	"socket _ so".	"If user wants to keep connnection open, he must store socket"
	^ so! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 5/11/1999 16:45'!
putFile: fileStream named: fileNameOnServer
	"Just FTP a local fileStream to the server.  (Later -- Use a proxy server if one has been registered.)"

	| so dd resp rr |
	so _ self openFTP.	"Open passive.  Do everything up to RETR or STOR"
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'STOR ', fileNameOnServer.
	dd _ so dataSocket.

	dd connectTo: so remoteAddress port: dd portNum.
	dd waitForConnectionUntil: FTPSocket standardDeadline.
	Transcript show: 'storing file ', fileNameOnServer; cr.
	"Transcript show: 'store via port ', dd portNum printString; cr."
	dd sendData: fileStream contentsOfEntireFile.
	dd close.

	(rr _ so responseOK) == true ifFalse: [
		(rr beginsWith: '426 ') ifTrue: [socket _ nil.  ^ rr, ' (Server may be full.)'].
			"Connection closed, transfer aborted"
		socket _ nil.  ^ rr].	"150 Opening BINARY mode data connection"
	(resp _ so responseOK) == true ifFalse: [
		socket _ nil.  ^ rr].	"226 Transfer complete."
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
	dd destroy.

	^ resp	"226 Transfer complete."! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'RAA 6/23/2000 09:43'!
putFile: fileStream named: fileNameOnServer retry: aBool
	"ar 11/24/1998 Do the usual putFile:named: operation but retry if some error occurs and aBool is set. Added due to having severe transmission problems on shell.webpage.com."
	| resp |
	self isTypeFile ifTrue: [
		^ (FileDirectory on: urlObject pathForDirectory)
			putFile: fileStream named: fileNameOnServer].

	[[resp _ self putFile: fileStream named: fileNameOnServer] 
		ifError:[:err :rcvr| resp _ '5xx ',err]. "Report as error"
	aBool and:[((resp isKindOf: String) and: [resp size > 0]) and:[resp first ~= $2]]] whileTrue:[
		(self confirm:('Error storing ',fileNameOnServer,' on the server.\(',resp,',)\Retry operation?') withCRs) ifFalse:[^resp].
	].
	^resp! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 5/12/1999 11:30'!
quit
	"break the connection"

	| rr so |
	(so _ socket) ifNil: [^ self].	"already done"
	socket _ nil.
	so isValid ifFalse: [^ self].
	so sendCommand: 'QUIT'.
	(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
	so destroy.	"Always OK to destroy"
	Transcript cr; show: 'ftp closing: ', server.! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'tk 1/2/2000 11:46'!
sleep
	"If still connected, break the connection"

	self quit! !

!ServerDirectory methodsFor: 'do ftp' stamp: 'di 2/11/2000 22:36'!
wakeUp
	"Open for FTP and keep the connection open"

	| so |
	(so _ self openNoDataFTP) class == String ifTrue: [^ so].
	^ socket _ so! !


!ServerDirectory methodsFor: 'updates' stamp: 'tk 1/7/2001 11:58'!
checkNames: list
	"Look at these names for update and see if they are OK"

list do: [:local |
	(local count: [:char | char == $.]) > 1 ifTrue: [
		self inform: 'File name ',local,'
may not have more than one period'.
	^ false].
	local size > 26 ifTrue: ["allows for 5 digit update numbers"
		self inform: 'File name ',local,'
is too long.  Please rename it.'.
	^ false].
	(local at: 1) isDigit ifTrue: [
		self inform: 'File name ',local,'
may not begin with a number'.
	^ false].
	(local findDelimiters: '%/* ' startingAt: 1) <= local size ifTrue: [
		self inform: 'File name ',local,'
may not contain % / * or space'.
	^ false]].
^ true
! !

!ServerDirectory methodsFor: 'updates' stamp: 'tk 9/25/2000 11:58'!
checkServers
	"Check that all servers are up and have the latest Updates.list.
Warn user when can't write to a server that can still be read."

	| final fileSize this serverList theUpdates decided myUpdates abort |
	serverList _ group
			ifNil: [Array with: self]
			ifNotNil: [group value].
	final _ OrderedCollection new.
	fileSize _ 0.  theUpdates _ ''.	"list of updates"
	abort _ false.
	serverList do: [:aServer |
		decided _ false.
		this _ aServer getFileNamed: 'updates.list'.
		(this = #error:) ifTrue: [^'' "Not found"].
		this class == String ifTrue: ["no ftp"
			(PopUpMenu labels: 'Cancel entire update' withCRs)
				startUpWithCaption: 'Server ', aServer moniker,
				' is unavailable.\Please consider phoning the administator.\' withCRs, this.
			abort _ true.
			decided _ true].
		decided not & (this size > fileSize) ifTrue: ["new has a longer update.list"
			fileSize _ this size.
			final do: [:each | abort _ self outOfDate: each].
			(final _ OrderedCollection new) add: aServer.
			theUpdates _ this contentsOfEntireFile.
			decided _ true].
		decided not & (this size < fileSize) ifTrue: [
			abort _ self outOfDate: aServer.  decided _ true].
		decided not ifTrue: [myUpdates _ this contentsOfEntireFile.
			myUpdates = theUpdates
				ifTrue: [final add: aServer]
				ifFalse: [abort _ self outOfDate: aServer]].
		abort ifTrue: [^ Array new].
		].
	^ final

! !

!ServerDirectory methodsFor: 'updates' stamp: 'tk 5/1/1998 15:03'!
outOfDate: aServer
	"Inform the user that this server does not have a current version of 'Updates.list'  Return true if the user does not want any updates to happen."

| response |
response _ (PopUpMenu labels: 'Install on others\Cancel entire update' withCRs)
		startUpWithCaption: 'The server ', aServer moniker, ' is not up to date.
Please store the missing updates maually.'.
^ response ~= 1! !

!ServerDirectory methodsFor: 'updates' stamp: 'tk 7/8/2000 11:44'!
putUpdate: fileStrm 
	"Put this file out as an Update on the servers of my group.  Each version of the system has its own set of update files.  'updates.list' holds the master list.  Each update is a fileIn whose name begins with a number.  See Utilities class readServerUpdatesThrough:saveLocally:updateImage:."

	| myServers updateStrm sequence newName myName response local restOfText seq fileContents |
"	(ScheduledControllers scheduledControllers detect: [:each |
		each model == Transcript] ifNone: [nil]) ifNil: [
			^ self inform: 'Please open a Transcript window, and 
then start putting out this update again.'].
"
	local _ fileStrm localName.
	fileStrm size = 0
		ifTrue: [^ self inform: 'That file has zero bytes!!  May have a new name.'].
	fileContents _ fileStrm contentsOfEntireFile.
	(fileContents includes: Character linefeed)
		ifTrue: [self notify: 'That file contains linefeeds.
Proceed if you know that this is okay (e.g. the file contains raw binary data).'].
	fileStrm reset.
	(self checkNames: (Array with: local)) ifFalse: [^ nil].	"illegal characters"
	myName _ group ifNil: [self moniker] ifNotNil: [group key].
	response _ (PopUpMenu labels: 'Install update\Cancel update' withCRs)
		startUpWithCaption: 'Do you really want to broadcast the file ', local, 
			'\to every Squeak user who updates from ' withCRs, myName, '?'.
	response = 1 ifFalse: [^ nil].	"abort"

	self openGroup.
	(myServers _ self checkServers) size = 0 ifTrue: [self closeGroup.  ^ self].
	updateStrm _ myServers first getFileNamed: 'updates.list'.
	sequence _ Utilities lastUpdateNum: updateStrm.
	restOfText _ Utilities position: updateStrm 	"sets the postion!!!!"
			atVersion: (Smalltalk at: #EToySystem) version.
	restOfText size > 0 ifTrue: [
		response _ (PopUpMenu labels: 'Make update for my older version\Cancel update' withCRs)
			startUpWithCaption: 'This system, ', (Smalltalk at: #EToySystem) version,
				' is not the latest version'.
		response = 1 ifFalse: [self closeGroup.  ^ nil].	"abort"
		sequence _ Utilities olderVersNum: restOfText from: updateStrm default: sequence.
		].
	"get last number and add 1"
	seq _ (sequence+1) printString.
	seq size = 1 ifTrue: [seq _ '00', seq].
	seq size = 2 ifTrue: [seq _ '0', seq].
	newName _ seq, local.
	"append name to updates"
	(updateStrm skip: -1; next) == Character cr ifFalse: [
		updateStrm nextPut: Character cr].
	updateStrm nextPutAll: newName; nextPut: Character cr; nextPutAll: restOfText.

	myServers do: [:aServer |
		fileStrm reset.	"reopen"
		aServer putFile: fileStrm named: newName retry: true.
		updateStrm reset.
		aServer putFile: updateStrm named: 'updates.list' retry: true.
		Transcript cr; show: 'Update succeeded on server ', aServer moniker].
	self closeGroup.
		
	Transcript cr; show: 'Be sure to test your new update!!'; cr.
	"rename the file locally (may fail)"
	fileStrm directory rename: local toBe: newName.
! !

!ServerDirectory methodsFor: 'updates' stamp: 'di 5/16/2000 13:47'!
putUpdateMulti: list fromDirectory: updateDirectory
	"Put these files out as an Update on the servers of my group.  List is an array of local file names without number prefixes.  Each version of the system has its own set of update files.  'updates.list' holds the master list.  Each update is a fileIn whose name begins with a number.  See Utilities class absorbUpdatesFromServer."

	| myServers updateStrm sequence myName response restOfText seq add newNames file |
	(self checkNames: list) ifFalse: [^ nil].
	myName _ group ifNil: [self moniker] ifNotNil: [group key].
	response _ (PopUpMenu labels: 'Install update\Cancel update' withCRs)
		startUpWithCaption: 'Do you really want to broadcast ', list size printString, ' updates',
			'\to every Squeak user who updates from ' withCRs, myName, '?'.
	response = 1 ifFalse: [^ nil].	"abort"

	self openGroup.
	(myServers _ self checkServers) size = 0 ifTrue: [self closeGroup.  ^ self].
	updateStrm _ myServers first getFileNamed: 'updates.list'.
	"get last number and add 1"
	sequence _ Utilities lastUpdateNum: updateStrm.
	add _ WriteStream on: (String new: 200).
	newNames _ list collect: [:each | 
		seq _ (sequence _ sequence+1) printString.
		seq size = 1 ifTrue: [seq _ '00', seq].
		seq size = 2 ifTrue: [seq _ '0', seq].
		add nextPutAll: seq; nextPutAll: each; cr.
		seq, each].
	restOfText _ Utilities position: updateStrm 	"sets the postion!!!!"
			atVersion: (Smalltalk at: #EToySystem) version.
	restOfText size > 0 ifTrue: [
		response _ (PopUpMenu labels: 'Make update for my older version\Cancel update' withCRs)
			startUpWithCaption: 'This system, ', (Smalltalk at: #EToySystem) version,
				' is not the latest version'.
		response = 1 ifFalse: [self closeGroup.  ^ nil].	"abort"
		].
	"append name to updates"
	(updateStrm skip: -1; next) == Character cr ifFalse: [
		updateStrm nextPut: Character cr].
	updateStrm nextPutAll: add contents; nextPutAll: restOfText.

	myServers do: [:aServer |
		list doWithIndex: [:local :ind |
			file _ updateDirectory oldFileNamed: local.
			aServer putFile: file named: (newNames at: ind) retry: true.
			file close].
		updateStrm reset.
		aServer putFile: updateStrm named: 'updates.list' retry: true.
		Transcript cr; show: 'Updates succeeded on server ', aServer moniker].
	self closeGroup.
	
	Transcript cr; show: 'Be sure to test your new update!!'; cr.
	"rename the file locally"
	list with: newNames do:
		[:local :newName | updateDirectory rename: local toBe: newName].
! !

!ServerDirectory methodsFor: 'updates' stamp: 'tk 1/13/1999 12:37'!
updateInstallVersion: newVersion
	"For each server group, ask whether we want to put the new version marker (#Squeak2.3) at the end of the file.  Current version of Squeak must be the old one when this is done.
	ServerDirectory new updateInstallVersion: 'Squeak2.3'      "

	| myServers updateStrm names choice |
[names _ ServerDirectory groupNames asSortedArray.
choice _ (SelectionMenu labelList: names selections: names) startUp.
choice == nil] whileFalse: [
	myServers _ (ServerDirectory groupNamed: choice) checkServers.
	myServers size = 0 ifTrue: [self inform: 'checkServers failed on one of those'].
	updateStrm _ myServers first getFileNamed: 'updates.list'.

	Utilities position: updateStrm 	"checks for current OLD version"
			atVersion: (Smalltalk at: #EToySystem) version.	
	
	"append name to updates"
	updateStrm setToEnd.
	(updateStrm skip: -1; next) == Character cr ifFalse: [
		updateStrm nextPut: Character cr].
	updateStrm nextPutAll: '#', newVersion; nextPut: Character cr.

	myServers do: [:aServer |
		updateStrm reset.
		aServer putFile: updateStrm named: 'updates.list' retry: true.
		Transcript cr; show: 'Update.list written on server ', aServer moniker].
		
	]! !


!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 21:01'!
altUrl
	"When a ftp server also has http access, use this to store the http url"
	^ altURL! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/14/1999 20:56'!
altUrl: aString
	altURL _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:24'!
bareDirectory

	^ directory first == $/ 
		ifTrue: [directory copyFrom: 2 to: directory size]
		ifFalse: [directory]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/19/1998 18:54'!
copy

	| new |
	new _ self clone.
	new urlObject: urlObject copy.
	^ new! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 15:00'!
directory
	"String of part of url that is the directory. Has slashes as separators"

	urlObject ifNotNil: [^ urlObject pathDirString].
	^ directory! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
directory: anObject
	directory _ anObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 10/17/2000 14:57'!
directoryObject

	^self! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:26'!
fullPath: serverAndDirectory
	"Parse and save a full path.  Convention:  if ftp://user@server/dir, then dir is relative to user's directory.  dir has no slash at beginning.  If ftp://server/dir, then dir is absolute to top of machine, give dir a slash at the beginning."

	| start bare sz userAndServer both slash score match best sd |
	bare _ serverAndDirectory.
	sz _ serverAndDirectory size.
	bare size > 0 ifTrue: [ 
		start _ (bare copyFrom: 1 to: (8 min: sz)) asLowercase.
		((start beginsWith: 'ftp:') or: [start beginsWith: 'nil:']) "fix bad urls"
			ifTrue: [type _ #ftp.
				bare _ bare copyFrom: (7 min: sz) to: bare size].
		(start beginsWith: 'http:') 
			ifTrue: [type _ #http.
				bare _ bare copyFrom: (8 min: sz) to: serverAndDirectory size].
		((start beginsWith: 'file:') or: [type == #file])
			ifTrue: [type _ #file.
				urlObject _ FileUrl absoluteFromText: serverAndDirectory.
				^ self]].
	userAndServer _ bare copyUpTo: self pathNameDelimiter.
	both _ userAndServer findTokens: '@'.
	slash _ both size.	"absolute = 1, relative = 2"
	server _ both last.
	both size > 1 ifTrue: [user _ both at: 1].
	bare size > (userAndServer size + 1) 
		ifTrue: [directory _ bare copyFrom: userAndServer size + slash to: bare size]
		ifFalse: [directory _ ''].

	"If this server is already known, copy in its userName and password"
	type == #ftp ifFalse: [^ self].
	score _ -1.
	ServerDirectory serverNames do: [:name |
		sd _ ServerDirectory serverNamed: name.
		server = sd server ifTrue: [
			match _ directory asLowercase charactersExactlyMatching: sd directory asLowercase.
			match > score ifTrue: [score _ match.  best _ sd]]].
	best ifNil: [
		self fromUser
	] ifNotNil: [
		user _ best user.
		altURL _ best altUrl.
		loaderUrl _ best loaderUrl.
		self password: best password
	].
! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/5/98 22:20'!
groupName

	group ifNotNil: [^ group key].
	^ self moniker! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:40'!
isTypeFTP

	^self typeWithDefault == #ftp! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:41'!
isTypeFile

	^self typeWithDefault == #file! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:46'!
isTypeHTTP

	^self typeWithDefault == #http! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:22'!
loaderUrl

	^loaderUrl! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 9/14/2000 13:24'!
loaderUrl: aString

	loaderUrl _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 12/14/1998 19:45'!
moniker
	"a plain language name for this directory"

	moniker ifNotNil: [^ moniker].
	directory ifNotNil: [^ self server].
	urlObject ifNotNil: [^ urlObject toText].
	^ ''! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/20/1998 12:26'!
moniker: nickName
	"a plain language name for this directory"

	moniker _ nickName! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 20:44'!
password

	passwordHolder ifNil: [passwordHolder _ Password new].
	^ passwordHolder passwordFor: self	"may ask the user"! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/5/98 21:55'!
password: pp

	passwordHolder _ Password new.
	pp class == String 
		ifTrue: [passwordHolder cache: pp. ^ self].
	pp isInteger 
		ifTrue: [passwordHolder sequence: pp]
		ifFalse: [passwordHolder _ pp].! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 5/23/1998 09:41'!
printOn: aStrm
	aStrm nextPutAll: self class name; nextPut: $<.
	aStrm nextPutAll: self moniker.
	aStrm nextPut: $>.
! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:44'!
realUrl
	"a fully expanded version of the url we represent.  Prefix the path with http: or ftp: or file:"

	self isTypeFile ifTrue: [
		self fileNameRelativeTo: self.
		^ urlObject toText
	].
	^ self typeWithDefault asString, '://', self pathName
	! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 1/18/2001 19:51'!
secondsForDay: dayToken month: monthToken yearOrTime: ytToken 
thisMonth: thisMonth thisYear: thisYear

	| ftpDay ftpMonth pickAYear jDateToday trialJulianDate |

	ftpDay _ dayToken asNumber.
	ftpMonth _ Date indexOfMonth: monthToken.
	(ytToken includes: $:) ifFalse: [
		^(Date newDay: ftpDay month: ftpMonth year: ytToken asNumber) asSeconds
	].
	jDateToday _ Date today dayOfYear.
	trialJulianDate _ (Date newDay: ftpDay month: ftpMonth year: thisYear) dayOfYear.
	
	"Date has no year if within six months (do we need to check the day, too?)"

	"Well it appear to be pickier than that... it isn't just 6 months or 6 months and the day of the month, put perhaps the julian date AND the time as well. I don't know what the precise standard is, but this seems to produce better results"

	pickAYear _ (jDateToday - trialJulianDate) > 182 ifTrue: [
		thisYear + 1	"his clock could be ahead of ours??"
	] ifFalse: [
		pickAYear _ (trialJulianDate - jDateToday) > 182 ifTrue: [
			thisYear - 1
		] ifFalse: [
			thisYear
		].
	].
	^(Date newDay: ftpDay month: ftpMonth year: pickAYear) asSeconds +
		(Time readFrom: (ReadStream on: ytToken)) asSeconds

! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 18:18'!
server
	^ server! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
server: anObject
	server _ anObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/18/1998 23:22'!
slashDirectory

	^ directory first == $/ 
		ifTrue: [directory]
		ifFalse: ['/', directory]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 2/14/1999 21:44'!
type: aSymbol
	type _ aSymbol! !

!ServerDirectory methodsFor: 'accessing' stamp: 'RAA 6/23/2000 09:30'!
typeWithDefault

	^ type ifNil: [type _ #ftp]! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/25/1999 15:12'!
url
	"This was mis-named at the beginning.  Eventually convert over to altUrl and use this for the real url."
	^ self realUrl! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/5/1998 17:20'!
url: aString
	altURL _ aString! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/6/1998 00:44'!
urlObject
	^ urlObject! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 9/8/1998 11:56'!
urlObject: aUrl

	urlObject _ aUrl! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 11/24/1998 22:16'!
user
	^ user! !

!ServerDirectory methodsFor: 'accessing' stamp: 'tk 1/3/98 21:36'!
user: anObject
	user _ anObject! !


!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'!
asServerFileNamed: aName

	| rFile |
	rFile _ self as: ServerFile.
	(aName includes: self pathNameDelimiter)
		ifTrue: [rFile fullPath: aName]
			"sets server, directory(path), fileName.  If relative, merge with self."
		ifFalse: [rFile fileName: aName].	"JUST a single NAME, already have the rest"
			"Mac files that include / in name, must encode it as %2F "
	^rFile
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:41'!
createDirectory: localName
	"Create a new sub directory within the current one"

	| so rr |
	self isTypeFile ifTrue: [
		^FileDirectory createDirectory: localName
	].

	so _ self openNoDataFTP.
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'MKD ', localName.
	(rr _ so responseOK) == true ifFalse: [socket _ nil.  ^ rr].	""
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:42'!
deleteDirectory: localName
	"Delete the sub directory within the current one.  Call needs to ask user to confirm."

	| so rr |
	self isTypeFile ifTrue: [
		^FileDirectory deleteFileNamed: localName
	].
		"Is this the right command???"

	so _ self openNoDataFTP.
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'RMD ', localName.
	(rr _ so responseOK) == true ifFalse: [socket _ nil.  ^ rr].	""
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:31'!
deleteFileNamed: fullName
	"Detete a remote file.  fullName is directory path, and does include name of the server.  Or it can just be a fileName."
	| file so rr |
	file _ self asServerFileNamed: fullName.
	file isTypeFile ifTrue: [
		^ (FileDirectory forFileName: (file fileNameRelativeTo: self)) 
			deleteFileNamed: file fileName
	].
	
	so _ file openNoDataFTP.
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'DELE ', file fileName.
	(rr _ so responseOK) == true ifFalse: [socket _ nil.  ^ rr].	""
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/19/1998 18:58'!
directoryNamed: localFileName
	"Return a copy of me pointing at this directory below me"

	| new |
	new _ self copy.
	urlObject ifNotNil: [
		new urlObject path: (new urlObject path) copy.
		(new urlObject path) removeLast; addLast: localFileName; addLast: ''.
		^ new].
	new directory: directory, self pathNameDelimiter asString, localFileName.
	^ new! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 2/22/2000 19:51'!
directoryNames
	"Return a collection of names for the subdirectories of this directory."
	"(ServerDirectory serverNamed: 'UIUCArchive') directoryNames"

	^ (self entries select: [:entry | entry at: 4])
		collect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 9/30/2000 17:02'!
entries 
	"Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (<name> <creationTime> <modificationTime> <dirFlag> <fileSize>)."
	| dir ftpEntries thisYear tokens dateInSeconds longy thisMonth |
	"We start with ftp directory entries of the form...
d---------   1 owner    group               0 Apr 27 22:01 blasttest
----------   1 owner    group           93812 Jul 21  1997 COMMAND.COM
    1        2   3           4                 5    6  7    8       9   -- token index"
	self isTypeFile ifTrue: [
		urlObject isAbsolute ifFalse: [urlObject default].
		^ (FileDirectory on: urlObject pathForDirectory) entries
	].

	dir _ self getDirectory.
	(dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()].
	ftpEntries _ dir contentsOfEntireFile findTokens: FTPSocket crLf.
"ftpEntries inspect."
	thisYear _ Date today year.
	thisMonth _ Date today monthIndex.
	^ ftpEntries collect:
		[:ftpEntry | tokens _ ftpEntry findTokens: ' '.
		tokens size >= 9
		ifTrue:
		[tokens size > 9 ifTrue:
			[longy _ tokens at: 9.
			10 to: tokens size do: [:i | longy _ longy , ' ' , (tokens at: i)].
			tokens at: 9 put: longy].
		dateInSeconds _ self
			secondsForDay: (tokens at: 7) 
			month: (tokens at: 6) 
			yearOrTime: (tokens at: 8) 
			thisMonth: thisMonth 
			thisYear: thisYear.
		DirectoryEntry name: (tokens at: 9)  "file name"
			creationTime: dateInSeconds "creation date"
			modificationTime: dateInSeconds "modification time"
			isDirectory: tokens first first = $d "is-a-directory flag"
			fileSize: tokens fifth asNumber "file size"]
		ifFalse:
		[nil]]
		thenSelect: [:entry | entry notNil]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 2/13/1999 14:00'!
exists
	"It is difficult to tell if a directory exists.  This is ugly, but it works for writable directories.  (tested only for file://)"

	| probe |
	self entries size > 0 ifTrue: [^ true].
	(probe _ self newFileNamed: 'withNoName23') ifNil: [^ false].
	probe close.
	probe directory deleteFileNamed: probe localName.
	^ true! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'!
fileAndDirectoryNames
	"FileDirectory default fileAndDirectoryNames"

	^ self entries collect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:31'!
fileNamed: fullName
	"Create a RemoteFileStream for writing.  If the file exists, do not complain.  fullName is directory path, and does include name of the server.  Or it can just be a fileName.  Only write the data upon close."

	| file remoteStrm |
	file _ self asServerFileNamed: fullName.
	file readWrite.
	file isTypeFile ifTrue: [
		^ FileStream fileNamed: (file fileNameRelativeTo: self)
	].

	remoteStrm _ RemoteFileStream on: (String new: 2000).
	remoteStrm remoteFile: file.
	^ remoteStrm	"no actual writing till close"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:46'!
fileNames
	"Return a collection of names for the files (but not directories) in this directory."
	"(ServerDirectory serverNamed: 'UIUCArchive') fileNames"

	self isTypeFTP | self isTypeFile ifFalse: [
		^ self error: 'To see a directory, use file:// or ftp://'
	].
	^ (self entries select: [:entry | (entry at: 4) not])
		collect: [:entry | entry first]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/19/1998 19:29'!
fullNameFor: aFileName
	"Convention: 
	If it is an absolute path, directory stored with a leading slash, and url has no user@.
	If relative path, directory stored with no leading slash, and url begins user@.
	Should we include ftp:// on the front?"

	urlObject ifNotNil: [^ urlObject pathString, aFileName].
	(aFileName includes: self pathNameDelimiter)
		ifTrue: [^ aFileName].
	directory isEmpty ifTrue: [^ server, 
		self pathNameDelimiter asString, aFileName].
	^ (directory first == $/ ifTrue: [''] ifFalse: [user,'@']), 
		server, self slashDirectory, 
		self pathNameDelimiter asString, aFileName! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:47'!
getOnly: nnn from: fileNameOnServer
	| file ff resp |
	"Use FTP to just capture the first nnn characters of the file.  Break the connection after that.  Goes faster for long files.  Return the contents, not a stream."

	self isTypeFile ifTrue: [
		file _ self as: ServerFile.
		file fileName: fileNameOnServer.
		ff _ FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self).
		^ ff next: nnn].
	self isTypeHTTP ifTrue: [
		resp _ HTTPSocket httpGet: (self fullNameFor: fileNameOnServer) 
				accept: 'application/octet-stream'.
			"For now, get the whole file.  This branch not used often."
		^ resp truncateTo: nnn].
	
	^ self getOnlyBuffer: (String new: nnn) from: fileNameOnServer! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 11/20/1998 12:28'!
includesKey: localName
	"Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names."

	^ self fileAndDirectoryNames includes: localName
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'!
localNameFor: fullName
	"Return the local part the given name."

	self
		splitName: fullName
		to: [:dirPath :localName | ^ localName]
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:32'!
newFileNamed: fullName
	"Create a RemoteFileStream.  If the file exists, and complain.  fullName is directory path, and does include name of the server.  Or it can just be a fileName.  Only write the data upon close."

	| file remoteStrm selection |

	file _ self asServerFileNamed: fullName.
	file readWrite.
	file isTypeFile ifTrue: [
		^ FileStream newFileNamed: (file fileNameRelativeTo: self)].
	file exists 
		ifTrue: [
			selection _ (PopUpMenu labels: 'overwrite that file
choose another name
cancel')
				startUpWithCaption: (file fullNameFor: file fileName) , '
already exists.']
		ifFalse: [selection _ 1].

	selection = 1 ifTrue:
		[remoteStrm _ RemoteFileStream on: (String new: 2000).
		remoteStrm remoteFile: file.
		remoteStrm dataIsValid.	"empty stream is the real contents!!"
		^ remoteStrm].	"no actual writing till close"
	selection = 2 ifTrue: [
		^ self newFileNamed:
			(FillInTheBlank request: 'Enter a new file name'
				initialAnswer: file fileName)].
	^ nil	"cancel"! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:10'!
oldFileNamed: aName
	"If the file exists, answer a read-only RemoteFileStream on it.  aName is directory path, and does include name of the server.  Or it can just be a fileName.  For now, pre-read the file."

	| rFile |

	rFile _ self asServerFileNamed: aName.
	rFile readOnly.
	rFile isTypeFile ifTrue: [
		^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)].

	^self streamOnBeginningOf: rFile
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:09'!
oldFileOrNoneNamed: fullName
	"If the file exists, answer a read-only RemoteFileStream on it. If it doesn't, answer nil.  fullName is directory path, and does include name of the server.  Or just a simple fileName.  Do prefetch the data."

	| file |

	Cursor wait showWhile: [
		file _ self asServerFileNamed: fullName.
		file readOnly.
		file isTypeFile ifTrue: [
			^ FileStream oldFileOrNoneNamed: (file fileNameRelativeTo: self)].
		"file exists ifFalse: [^ nil]."		"on the server"

		^self streamOnBeginningOf: file
	].
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/19/1998 18:59'!
on: fullName
	"Answer another ServerDirectory on the partial path name.  fullName is directory path, and does include the name of the server."

	| new |
	new _ self copy.
	new fullPath: fullName.		"sets server, directory(path)"
	^ new! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 1/14/1999 20:54'!
pathName
	"Path name as used in reading the file.  with slashes for ftp, with local file delimiter (:) for a file: url"

	urlObject ifNotNil: [^ urlObject pathForFile].
	directory size = 0 ifTrue: [^ server].
	^ (directory at: 1) = self pathNameDelimiter
		ifTrue: [server, directory]
		ifFalse: [user, '@', server, self pathNameDelimiter asString, directory]! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/3/1998 12:34'!
pathNameDelimiter
	"the separator that is used in URLs"

	^ $/! !

!ServerDirectory methodsFor: 'file directory' stamp: 'tk 9/8/1998 12:12'!
pathParts
	"Return the path from the root of the file system to this directory as an array of directory names.  On a remote server."

	urlObject ifNotNil: [^ (urlObject path copy) removeLast; yourself].
	^ (OrderedCollection with: server) addAll: 
		(directory findTokens: self pathNameDelimiter asString);
			yourself.
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:08'!
readOnlyFileNamed: aName
	"If the file exists, answer a read-only RemoteFileStream on it.  aName is directory path, and does include name of the server.  Or it can just be a fileName.  For now, pre-read the file."

	| rFile |

	rFile _ self asServerFileNamed: aName.
	rFile readOnly.
	rFile isTypeFile ifTrue: [
		^ FileStream oldFileNamed: (rFile fileNameRelativeTo: self)].

	^self streamOnBeginningOf: rFile! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:11'!
rename: fullName toBe: newName
	"Rename a remote file.  fullName is just be a fileName, or can be directory path that includes name of the server.  newName is just a fileName"
	| file so rr |

	file _ self asServerFileNamed: fullName.
	file isTypeFile ifTrue: [
		(FileDirectory forFileName: (file fileNameRelativeTo: self)) 
			rename: file fileName toBe: newName
	].
	
	so _ file openNoDataFTP.
	so class == String ifTrue: ["error, was reported" ^ so].
	so sendCommand: 'RNFR ', file fileName.
	(rr _ so responseOK) == true ifFalse: [socket _ nil.  ^ rr].	""
	so sendCommand: 'RNTO ', newName.
	(rr _ so responseOK) == true ifFalse: [socket _ nil.  ^ rr].	""
	socket ifNil: [
		so sendCommand: 'QUIT'.
		(rr _ so responseOK) == true ifFalse: [^ rr].	"221"
		so destroy].	"Always OK to destroy"
! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 6/23/2000 09:45'!
serverDelimiter
	"the separator that is used in the place where the file actually is.  ftp server or local disk."

	^ self isTypeFile 
		ifTrue: [FileDirectory default pathNameDelimiter]
		ifFalse: [$/]	"for ftp, http"! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/28/2000 13:46'!
splitName: fullName to: pathAndNameBlock
	"Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: <dirPath><delimiter><localName>, where <dirPath><delimiter> is optional. The <dirPath> part may contain delimiters."

	| delimiter i dirName localName |
	delimiter _ self pathNameDelimiter.
	(i _ fullName findLast: [:c | c = delimiter]) = 0
		ifTrue:
			[dirName _ String new.
			localName _ fullName]
		ifFalse:
			[dirName _ fullName copyFrom: 1 to: (i - 1 max: 1).
			localName _ fullName copyFrom: i + 1 to: fullName size].

	^ pathAndNameBlock value: dirName value: localName! !

!ServerDirectory methodsFor: 'file directory' stamp: 'RAA 7/4/2000 10:03'!
streamOnBeginningOf: serverFile

	| remoteStrm |
	remoteStrm _ RemoteFileStream on: (String new: 2000).
	remoteStrm remoteFile: serverFile.
	serverFile getFileNamed: serverFile fileName into: remoteStrm.	"prefetch data"
	^ remoteStrm! !


!ServerDirectory methodsFor: 'server groups' stamp: 'tk 5/11/1999 17:54'!
closeGroup
	"Close connection with all servers in the group."

	(group
		ifNil: [Array with: self]
		ifNotNil: [group value]) do: [:aDir | aDir quit].
! !

!ServerDirectory methodsFor: 'server groups' stamp: 'di 5/24/1998 15:50'!
group
	"NOTE: This is an association whose key is the anme of the group, and
	whose value is an array of serverDirectories, the first of which is
	deemed to be the group directory."

	^ group! !

!ServerDirectory methodsFor: 'server groups' stamp: 'di 5/24/1998 15:50'!
group: anObject
	group _ anObject! !

!ServerDirectory methodsFor: 'server groups' stamp: 'di 2/11/2000 22:34'!
openGroup
	"Open all servers in the group.  Don't forget to close later."

	(group
		ifNil: [Array with: self]
		ifNotNil: [group value]) do: [:aDir | aDir wakeUp].
! !

!ServerDirectory methodsFor: 'server groups' stamp: 'di 5/24/1998 15:54'!
removeFromGroup
	"Allowable if not in a group presently"
	group ifNotNil:
		["Group is an association shared by all members.
		Therefore all will feel this removal"
		group value: (group value copyWithout: self).
		group _ nil  "...and I'm outa here"]! !


!ServerDirectory methodsFor: 'initialize' stamp: 'tk 11/26/1998 09:50'!
fromUser
	"Ask the user for all data on a new server.  Save it in a named server."  ! !


!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 2/2/2001 08:29'!
directoryWrapperClass

	^FileDirectoryWrapper! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'tk 2/20/2000 18:34'!
moveAllButYoungest: young in: versions to: repository
	| all fName aVers bVers |
	"Specialized to files with names of the form 'aName_vvv.ext'.  Where vvv is a mime-encoded base 64 version number.  Versions is an array of file names tokenized into three parts (aName vvv ext).  Move the files by renaming them on the server."

	versions size <= young ifTrue: [^ self].
	all _ SortedCollection sortBlock: [:aa :bb | 
		aVers _ Base64MimeConverter decodeInteger: aa second unescapePercents.
		bVers _ Base64MimeConverter decodeInteger: bb second unescapePercents.
		aVers < bVers].
	all addAll: versions.
	young timesRepeat: [all removeLast].	"ones we keep"
	all do: [:vv |
		fName _ vv first, '_', vv second, '.', vv third.
		repository rename: self fullName,fName toBe: fName].
! !

!ServerDirectory methodsFor: 'squeaklets' stamp: 'RAA 10/12/2000 17:17'!
updateProjectInfoFor: aProject

	"only swiki servers for now"! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ServerDirectory class
	instanceVariableNames: ''!

!ServerDirectory class methodsFor: 'misc' stamp: 'tk 12/29/1998 22:46'!
defaultStemUrl
	"For writing on an FTP directory.  Users should insert their own server url here."
"ftp://jumbo.rd.wdi.disney.com/raid1/people/dani/Books/Grp/Grp"
"	ServerDirectory defaultStemUrl	"

| rand dir |
rand _ String new: 4.
1 to: rand size do: [:ii |
	rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)].
dir _ self serverNamed: 'DaniOnJumbo'.
^ 'ftp://', dir server, dir slashDirectory, '/BK', rand! !

!ServerDirectory class methodsFor: 'misc' stamp: 'tk 9/8/1998 11:57'!
newFrom: aSimilarObject
	"Must copy the urlObject, so they won't be shared"

	| inst |
	inst _ super newFrom: aSimilarObject.
	inst urlObject: aSimilarObject urlObject copy.
	^ inst! !


!ServerDirectory class methodsFor: 'available servers' stamp: 'di 5/24/1998 16:01'!
addGroup: serverArray named: nameString
	| groupAssn |
	serverArray do: [:server | server removeFromGroup].
	groupAssn _ nameString -> serverArray asArray copy.
	serverArray do: [:server | server group: groupAssn].! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'di 5/24/1998 15:24'!
addServer: server named: nameString
	Servers at: nameString put: server! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'di 5/24/1998 15:15'!
groupNamed: nameString
	"Return the first server in the group of this name."
	| grp server |
	Servers associationsDo: [:assn |
		server _ assn value.
		grp _ server group.  "Note: this is an association"
		(grp == nil or: [server == grp value first])
			ifTrue: [nameString = server groupName
						ifTrue: [^ server]]].
	^ self error: 'Server name not found'
! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'di 5/24/1998 15:03'!
groupNames
	"Return the names of all registered groups of servers, including individual servers not in any group.  Note: A serverDirectory that is a member of a group will return an array of the servers in its group.  The first server in that array represents the group, and its name is the name of the goup."
	| grp names server |
	names _ OrderedCollection new.
	Servers associationsDo: [:assn |
		server _ assn value.
		grp _ server group.  "Note: this is an association"
		(grp == nil or: [server == grp value first])
			ifTrue: [names add: server groupName]].
	^ names asSortedArray
! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'di 9/22/1999 15:48'!
removeServerNamed: nameString
	(self serverNamed: nameString) removeFromGroup.
	Servers removeKey: nameString! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'tk 12/10/1998 12:29'!
serverNamed: nameString
	^ Servers at: nameString asString
		ifAbsent: [self error: 'Server name not found']! !

!ServerDirectory class methodsFor: 'available servers' stamp: 'di 5/24/1998 13:30'!
serverNames
	^ Servers keys asSortedArray! !
ServerDirectory subclass: #ServerFile
	instanceVariableNames: 'fileName rwmode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!
!ServerFile commentStamp: '<historical>' prior: 0!
Represents the non-data part of a file on a server on the internet.  I am owned by a RemoteFileStream, who has the data.

Since FileStream is a Stream and I am not, use this to always get a stream:
	xxx isStream ifFalse: [^ xxx asStream].

!


!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 2/23/2000 19:16'!
asStream
	"Return a RemoteFileStream (subclass of RWBinaryOrTextStream) on the contents of the remote file I represent.  For reading only.  This method is probably misnamed.  Maybe call it makeStream"

	^ self readOnlyFileNamed: self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 3/13/2000 16:53'!
directoryUrl
	| ru |
	"A url to the directory this file is in"

	ru _ self realUrl.
	^ ru copyFrom: 1 to: (ru size - fileName size)! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:12'!
exists
	"Return true if the file exists on the server already"

	^ self fileExists: fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 15:01'!
fileName
	"should this be local or as in a url?"

	urlObject ifNotNil: [^ urlObject path last].	"path last encodeForHTTP ?"
	^ fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/24/1998 14:45'!
fileName: aString

urlObject ~~ nil  "type == #file" 
	ifTrue: [urlObject path at: urlObject path size put: aString]
	ifFalse: [fileName _ aString]! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 11/23/1998 17:24'!
fileNameRelativeTo: aServerDir
	"Produce an absolute fileName from me and an absolute directory"
	urlObject isAbsolute ifFalse: [
		(aServerDir urlObject ~~ nil and: [aServerDir urlObject isAbsolute]) 
			ifTrue: [urlObject 
				privateInitializeFromText: urlObject pathString 
				relativeTo: aServerDir urlObject]
			ifFalse: [urlObject default]].	"relative to Squeak directory"
	^ urlObject pathForDirectory, self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:45'!
fullPath: serverAndDirectory
	"Parse and save a full path.  Separate out fileName at the end."

	| delim ii |
	super fullPath: serverAndDirectory.		"set server and directory"
	self isTypeFile ifTrue: [
		fileName _  ''.
		^ self
	].
	delim _ self pathNameDelimiter.
	ii _ directory findLast: [:c | c = delim].
	ii = 0
		ifTrue: [self error: 'expecting directory and fileName']
		ifFalse: [fileName _ directory copyFrom: ii+1 to: directory size.
			directory _ (directory copyFrom: 1 to: directory size - fileName size - 1)].! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 4/13/2000 17:12'!
localName

	^ self fileName! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/18/1998 16:42'!
readOnly
	"Set the receiver to be read-only"

	rwmode _ false! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'!
readWrite
	"Set the receiver to be writable"

	rwmode _ true! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'RAA 6/23/2000 09:45'!
realUrl
	"a fully expanded version of the url we represent.  Prefix the path with http: or ftp: or file:"

	self isTypeFile ifTrue: [
		self fileNameRelativeTo: self.
		^ urlObject toText
	].
	^ self typeWithDefault asString, '://', self pathName, '/', fileName	"note difference!!"
	! !

!ServerFile methodsFor: 'as yet unclassified' stamp: 'tk 5/19/1998 13:35'!
writable
	^ rwmode! !
Object subclass: #Session
	instanceVariableNames: 'lastAccess data '
	classVariableNames: 'Sessions '
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!Session commentStamp: '<historical>' prior: 0!
A Session can provide server-side storage of state/data between HTML pages. After creating a new session (which can be manipulated using at: and at:put:), it can be saved on the Sessions list by asking the Session class to store: the session. A random integer is returned as a key to the session, and the key can be stored in an HTML page in a hidden field.

A session can be retrieved by ID by asking Session to recall: an ID. A session can be retired when it is no longer useful.

Each recall: or use at:/at:put: "touches" (updates) the Session's last use time. A Session that is older than a certain period (default 30 minutes, in viableTime instance method) will generate an error. Every hour, the PWS, as part of its backup procedures, will clear out old sessions.
!


!Session methodsFor: 'access' stamp: 'mjg 11/4/97 14:12'!
at: key
	self touch.
	^data at: key ifAbsent: [self error: 'Internal key error. Please alert administrator about key',key printString].
! !

!Session methodsFor: 'access' stamp: 'mjg 11/4/97 14:12'!
at: key put: value
	self touch.
	^data at: key put: value.
! !

!Session methodsFor: 'access' stamp: 'mjg 11/4/97 14:07'!
isViable
	^ (Time now subtractTime: lastAccess) asSeconds > self viableTime! !

!Session methodsFor: 'access' stamp: 'mjg 11/4/97 14:06'!
touch
	lastAccess := Time now.
! !

!Session methodsFor: 'access' stamp: 'mjg 11/4/97 14:07'!
viableTime
	"In seconds"
	^60*30

! !


!Session methodsFor: 'initialize' stamp: 'tk 1/26/98 08:55'!
initialize
	data := Dictionary new.
	lastAccess := Time now.
	"PWS addToBackupJob: [Session user]."  "not implemented??"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Session class
	instanceVariableNames: ''!

!Session class methodsFor: 'store/recall' stamp: 'mjg 12/2/97 10:06'!
clearOld
	| aSession |
	Sessions keys do: [:s |
	aSession := Sessions at: s ifAbsent: [nil].
	aSession isNil ifFalse:
		[aSession isViable ifFalse: [self retire: s].]]! !

!Session class methodsFor: 'store/recall' stamp: 'mjg 11/4/97 14:09'!
recall: id
	| aSession |
	aSession := Sessions at: id ifAbsent: [self error: 'Non-existent session'].
	aSession isViable ifFalse: [self error: 'Your session data has expired. Please restart the operation.'].
	aSession touch.
	^aSession

! !

!Session class methodsFor: 'store/recall' stamp: 'mjg 11/4/97 14:11'!
retire: id
	Sessions removeKey: id.
! !

!Session class methodsFor: 'store/recall' stamp: 'mjg 11/4/97 14:04'!
store: aSession
	| newID |
	[	newID := SmallInteger maxVal atRandom.
		Sessions includesKey: newID ] whileTrue.
	Sessions at: newID put: aSession.
	^newID! !


!Session class methodsFor: 'initialization' stamp: 'mjg 11/4/97 16:43'!
initialize
	Sessions := Dictionary new.
	PWS addToBackupJob: [Session clearOld].

! !

!Session class methodsFor: 'initialization' stamp: 'mjg 11/4/97 13:54'!
new
	^super new initialize
! !
Collection subclass: #Set
	instanceVariableNames: 'tally array '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'!
capacity
	"Answer the current capacity of the receiver."

	^ array size! !

!Set methodsFor: 'accessing' stamp: 'SqR 8/23/2000 13:51'!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties"

	| index |

	^(index _ self scanFor: anObject) = 0
		ifFalse: [array at: index]! !

!Set methodsFor: 'accessing'!
size
	^ tally! !

!Set methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:34'!
someElement
	"Deprecated. Use anyOne."

	^ self anyOne! !


!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:28'!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject."

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: newObject.
	(array at: index) ifNil: [self atNewIndex: index put: newObject].
	^ newObject! !

!Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:29'!
add: newObject withOccurrences: anInteger
	^ self add: newObject! !


!Set methodsFor: 'converting' stamp: 'ar 11/20/1998 16:34'!
asSet
	^self! !


!Set methodsFor: 'copying' stamp: 'sma 5/12/2000 14:54'!
copy
	^ self shallowCopy withArray: array shallowCopy! !


!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:49'!
collect: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument.  
	Collect the resulting values into a collection like the receiver. Answer  
	the new collection."

	| newSet |
	newSet _ Set new: self size.
	array do: [:each | each ifNotNil: [newSet add: (aBlock value: each)]].
	^ newSet! !

!Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 14:36'!
do: aBlock 
	tally = 0 ifTrue: [^ self].
	1 to: array size do:
		[:index |
		| each |
		(each _ array at: index) ifNotNil: [aBlock value: each]]! !

!Set methodsFor: 'enumerating'!
doWithIndex: aBlock2
	"Support Set enumeration with a counter, even though not ordered"
	| index |
	index _ 0.
	self do: [:item | aBlock2 value: item value: (index _ index+1)]! !


!Set methodsFor: 'objects from disk' stamp: 'tk 4/8/1999 13:05'!
comeFullyUpOnReload: smartRefStream
	"Symbols have new hashes in this image."

	self rehash.
	"^ self"
! !


!Set methodsFor: 'private'!
array
	^ array! !

!Set methodsFor: 'private'!
atNewIndex: index put: anObject
	array at: index put: anObject.
	tally _ tally + 1.
	self fullCheck! !

!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:39'!
findElementOrNil: anObject
	"Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found."

	| index |

	index _ self scanFor: anObject.
	index > 0 ifTrue: [^index].

	"Bad scene.  Neither have we found a matching element
	nor even an empty slot.  No hashed set is ever supposed to get
	completely full."
	self error: 'There is no free space in this set!!'.! !

!Set methodsFor: 'private' stamp: 'SqR 8/23/2000 14:28'!
fixCollisionsFrom: index
	"The element at index has been removed and replaced by nil.
	This method moves forward from there, relocating any entries
	that had been placed below due to collisions with this one"

	| length oldIndex newIndex element |

	oldIndex _ index.
	length _ array size.
	[oldIndex = length
			ifTrue: [oldIndex _ 1]
			ifFalse: [oldIndex _ oldIndex + 1].
	(element _ self keyAt: oldIndex) == nil]
		whileFalse: 
			[newIndex _ self findElementOrNil: element.
			oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! !

!Set methodsFor: 'private' stamp: 'di 11/4/97 20:11'!
fullCheck
	"Keep array at least 1/4 free for decent hash behavior"
	array size - tally < (array size // 4 max: 1)
		ifTrue: [self grow]! !

!Set methodsFor: 'private'!
grow
	"Grow the elements array and reinsert the old elements"
	| oldElements |
	oldElements _ array.
	array _ Array new: array size + self growSize.
	tally _ 0.
	oldElements do:
		[:each | each == nil ifFalse: [self noCheckAdd: each]]! !

!Set methodsFor: 'private'!
growSize
	^ array size max: 2! !

!Set methodsFor: 'private'!
init: n
	"Initialize array to an array size of n"
	array _ Array new: n.
	tally _ 0! !

!Set methodsFor: 'private'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	^ array at: index! !

!Set methodsFor: 'private'!
noCheckAdd: anObject
	array at: (self findElementOrNil: anObject) put: anObject.
	tally _ tally + 1! !

!Set methodsFor: 'private'!
rehash
	| newSelf |
	newSelf _ self species new: self size.
	self do: [:each | newSelf noCheckAdd: each].
	array _ newSelf array! !

!Set methodsFor: 'private'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!Set methodsFor: 'private'!
swap: oneIndex with: otherIndex
	"May be overridden by subclasses so that fixCollisions will work"

	array swap: oneIndex with: otherIndex
! !

!Set methodsFor: 'private'!
withArray: anArray
	"private -- for use only in copy"
	array _ anArray! !


!Set methodsFor: 'removing' stamp: 'sma 5/12/2000 14:45'!
copyWithout: oldElement 
	"Answer a copy of the receiver that does not contain any
	elements equal to oldElement."

	^ self copy
		remove: oldElement ifAbsent: [];
		yourself! !

!Set methodsFor: 'removing'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: oldObject.
	(array at: index) == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ oldObject! !


!Set methodsFor: 'testing'!
= aSet
	(aSet isKindOf: Set) ifFalse: [^ false].
	self size = aSet size ifFalse: [^ false].
	self do: [:each | (aSet includes: each) ifFalse: [^ false]].
	^ true! !

!Set methodsFor: 'testing' stamp: 'bf 3/16/2000 18:06'!
hasContentsInExplorer

	^self isEmpty not! !

!Set methodsFor: 'testing'!
includes: anObject 
	^ (array at: (self findElementOrNil: anObject)) ~~ nil! !

!Set methodsFor: 'testing' stamp: 'sma 5/12/2000 14:46'!
occurrencesOf: anObject 
	^ (self includes: anObject) ifTrue: [1] ifFalse: [0]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Set class
	instanceVariableNames: ''!

!Set class methodsFor: 'instance creation'!
new
	^ self new: 4! !

!Set class methodsFor: 'instance creation'!
new: nElements
	"Create a Set large enough to hold nElements without growing"
	^ super new init: (self sizeFor: nElements)! !

!Set class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	| newCollection |
	newCollection _ self new: aCollection size.
	newCollection addAll: aCollection.
	^ newCollection
"
	Set newFrom: {1. 2. 3}
	{1. 2. 3} as: Set
"! !

!Set class methodsFor: 'instance creation'!
sizeFor: nElements
	"Large enough size to hold nElements with some slop (see fullCheck)"
	nElements <= 0 ifTrue: [^ 1].
	^ nElements+1*4//3! !


!Set class methodsFor: 'initialization' stamp: 'SqR 8/3/2000 13:19'!
quickRehashAllSets  "Set rehashAllSets"
	| insts |
	self withAllSubclassesDo:
		[:c |
			insts _ c allInstances.
			(insts isEmpty or: [c = MethodDictionary]) ifFalse:
			['Rehashing instances of ' , c name
				displayProgressAt: Sensor cursorPoint
				from: 1 to: insts size
				during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]]
			]
		]! !

!Set class methodsFor: 'initialization' stamp: 'SqR 8/3/2000 13:18'!
rehashAllSets  "Set rehashAllSets"
	| insts |
	self withAllSubclassesDo:
		[:c |
			insts _ c allInstances.
			insts isEmpty ifFalse:
			['Rehashing instances of ' , c name
				displayProgressAt: Sensor cursorPoint
				from: 1 to: insts size
				during: [:bar | 1 to: insts size do: [:x | bar value: x. (insts at: x) rehash]]
			]
		]! !
Canvas subclass: #ShadowDrawingCanvas
	instanceVariableNames: 'myCanvas shadowColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!ShadowDrawingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:24'!
flush
	myCanvas flush.! !

!ShadowDrawingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 17:38'!
on: aCanvas
	myCanvas _ aCanvas.
	shadowColor _ Color black.! !

!ShadowDrawingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:23'!
reset
	myCanvas reset.! !


!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:40'!
clipRect
	^myCanvas clipRect! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
depth
	^myCanvas depth! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
extent
	^myCanvas extent! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/24/1999 17:54'!
form
	^myCanvas form! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
origin
	^myCanvas origin! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:38'!
shadowColor
	^shadowColor! !

!ShadowDrawingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'!
shadowColor: aColor
	shadowColor _ aColor! !


!ShadowDrawingCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 19:03'!
isShadowDrawing
	"Always"
	^true! !


!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 17:59'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
	"Fill the given oval."
	myCanvas
		fillOval: r
		color: (self mapColor: c)
		borderWidth: borderWidth
		borderColor: (self mapColor: borderColor)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 17:59'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
	"Draw the rectangle using the given attributes"
	myCanvas
		frameAndFillRectangle: r
		fillColor: (self mapColor: fillColor)
		borderWidth: borderWidth
		borderColor: (self mapColor: borderColor)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:01'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
	"Draw the rectangle using the given attributes"
	myCanvas
		frameAndFillRectangle: r 
		fillColor: (self mapColor: fillColor) 
		borderWidth: borderWidth 
		topLeftColor: (self mapColor: topLeftColor)
		bottomRightColor: (self mapColor: bottomRightColor)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:15'!
line: pt1 to: pt2 width: w color: c
	"Draw a line using the given width and color"
	myCanvas
		line: pt1
		to: pt2
		width: w
		color: (self mapColor: c).! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:16'!
paragraph: paragraph bounds: bounds color: c
	"Draw the given paragraph"
	myCanvas
		paragraph: paragraph
		bounds: bounds
		color: (self mapColor: c)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/24/1999 18:26'!
stencil: aForm at: aPoint color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		color: (self mapColor: aColor)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/24/1999 18:26'!
stencil: aForm at: aPoint sourceRect: aRect color: aColor
	myCanvas
		stencil: aForm
		at: aPoint
		sourceRect: aRect
		color: (self mapColor: aColor)! !

!ShadowDrawingCanvas methodsFor: 'drawing' stamp: 'ar 6/22/1999 18:16'!
text: s bounds: boundsRect font: fontOrNil color: c
	"Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used."
	myCanvas
		text: s
		bounds: boundsRect
		font: fontOrNil
		color: (self mapColor: c)! !


!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'!
clipBy: aRectangle during: aBlock
	"Set a clipping rectangle active only during the execution of aBlock.
	Note: In the future we may want to have more general clip shapes - not just rectangles"
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas clipBy: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas! !

!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:19'!
preserveStateDuring: aBlock
	"Preserve the full canvas state during the execution of aBlock"
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas preserveStateDuring:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !

!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'di 10/16/1999 16:01'!
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock	 smoothing: cellSize

	"Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas transformBy: aDisplayTransform
		clippingTo: aClipRect
		during: [:newCanvas |
				myCanvas _ newCanvas.
				aBlock value: self]
		smoothing: cellSize.
	myCanvas _ oldCanvas.! !

!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:21'!
translateBy: delta clippingTo: aRectangle during: aBlock
	"Set a translation and clipping rectangle only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateBy: delta clippingTo: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !

!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'!
translateBy: delta during: aBlock
	"Set a translation only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateBy: delta during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !

!ShadowDrawingCanvas methodsFor: 'drawing-support' stamp: 'ar 6/22/1999 18:22'!
translateTo: newOrigin clippingTo: aRectangle during: aBlock
	"Set a new origin and clipping rectangle only during the execution of aBlock."
	| oldCanvas |
	oldCanvas _ myCanvas.
	myCanvas translateTo: newOrigin clippingTo: aRectangle during:[:newCanvas|
		myCanvas _ newCanvas.
		aBlock value: self].
	myCanvas _ oldCanvas.! !


!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:13'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
	"Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle."
	rule = Form paint ifTrue:[
		^myCanvas
			stencil: aForm
			at: aPoint
			sourceRect: sourceRect
			color: shadowColor
	] ifFalse:[
		^myCanvas
			fillRectangle: (sourceRect translateBy: aPoint)
			color: shadowColor
	].! !

!ShadowDrawingCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 18:36'!
mapColor: aColor
	aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..."
	^aColor isTransparent
		ifTrue:[aColor]
		ifFalse:[shadowColor]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShadowDrawingCanvas class
	instanceVariableNames: ''!

!ShadowDrawingCanvas class methodsFor: 'instance creation' stamp: 'ar 6/22/1999 18:23'!
on: aCanvas
	^self new on: aCanvas! !
Object subclass: #SharedQueue
	instanceVariableNames: 'contentsArray readPosition writePosition accessProtect readSynch '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!SharedQueue commentStamp: '<historical>' prior: 0!
I provide synchronized communication of arbitrary objects between Processes. An object is sent by sending the message nextPut: and received by sending the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent.!


!SharedQueue methodsFor: 'accessing'!
next
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone. If no object has been sent, suspend the 
	requesting process until one is."

	| value |
	readSynch wait.
	accessProtect
		critical: [readPosition = writePosition
					ifTrue: 
						[self error: 'Error in SharedQueue synchronization'.
						 value _ nil]
					ifFalse: 
						[value _ contentsArray at: readPosition.
						 contentsArray at: readPosition put: nil.
						 readPosition _ readPosition + 1]].
	^value! !

!SharedQueue methodsFor: 'accessing' stamp: 'RAA 12/14/2000 10:25'!
nextOrNil
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone. If no object has been sent, answer <nil>."

	| value |

	accessProtect critical: [
		readPosition >= writePosition ifTrue: [
			value _ nil
		] ifFalse: [
			value _ contentsArray at: readPosition.
			contentsArray at: readPosition put: nil.
			readPosition _ readPosition + 1
		].
		readPosition >= writePosition ifTrue: [readSynch initSignals].
	].
	^value! !

!SharedQueue methodsFor: 'accessing'!
nextPut: value 
	"Send value through the receiver. If a Process has been suspended 
	waiting to receive a value through the receiver, allow it to proceed."

	accessProtect
		critical: [writePosition > contentsArray size
						ifTrue: [self makeRoomAtEnd].
				 contentsArray at: writePosition put: value.
				 writePosition _ writePosition + 1].
	readSynch signal.
	^value! !

!SharedQueue methodsFor: 'accessing'!
peek
	"Answer the object that was sent through the receiver first and has not 
	yet been received by anyone but do not remove it from the receiver. If 
	no object has been sent, suspend the requesting process until one is."

	| value |
	accessProtect
		critical: [readPosition >= writePosition
					ifTrue: [readPosition _ 1.
							writePosition _ 1.
							value _ nil]
					ifFalse: [value _ contentsArray at: readPosition]].
	^value! !

!SharedQueue methodsFor: 'accessing'!
size
	"Answer the number of objects that have been sent through the
	receiver and not yet received by anyone."

	^writePosition - readPosition! !


!SharedQueue methodsFor: 'testing'!
isEmpty
	"Answer whether any objects have been sent through the receiver and 
	not yet received by anyone."

	^readPosition = writePosition! !


!SharedQueue methodsFor: 'private'!
init: size

	contentsArray _ Array new: size.
	readPosition _ 1.
	writePosition _ 1.
	accessProtect _ Semaphore forMutualExclusion.
	readSynch _ Semaphore new! !

!SharedQueue methodsFor: 'private' stamp: 'sma 4/22/2000 18:04'!
makeRoomAtEnd
	| contentsSize |
	readPosition = 1
		ifTrue: [contentsArray _ contentsArray , (Array new: 10)]
		ifFalse: 
			[contentsSize _ writePosition - readPosition.
			"BLT direction ok for this. Lots faster!!!!!!!!!!!! SqR!!!! 4/10/2000 10:47"
			contentsArray
				replaceFrom: 1
				to: contentsSize
				with: contentsArray
				startingAt: readPosition.
			readPosition _ 1.
			writePosition _ contentsSize + 1]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SharedQueue class
	instanceVariableNames: ''!

!SharedQueue class methodsFor: 'instance creation'!
new
	"Answer a new instance of SharedQueue that has 10 elements."

	^self new: 10! !

!SharedQueue class methodsFor: 'instance creation'!
new: anInteger 
	^super new init: anInteger! !
ArrayedCollection variableWordSubclass: #ShortIntegerArray
	instanceVariableNames: ''
	classVariableNames: 'LastSaveOrder '
	poolDictionaries: ''
	category: 'Balloon-Collections'!

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
at: index
	"Return the 16-bit integer value at the given index of the receiver."

	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
at: index put: value
	"Store the given 16-bit integer at the given index in the receiver."

	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
defaultElement
	^0! !

!ShortIntegerArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:41'!
size
	^super size * 2! !


!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'!
pvtAt: index
	"Private -- for swapping only"
	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:35'!
pvtAt: index put: value
	"Private -- for swapping only"
	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortIntegerArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:37'!
swapShortObjects
	"Private -- swap all the short quantities in the receiver"
	| tmp |
	1 to: self basicSize do:[:i|
		tmp _ (self pvtAt: i * 2).
		self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
		self pvtAt: i * 2 - 1 put: tmp.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortIntegerArray class
	instanceVariableNames: ''!

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:16'!
initialize
	"ShortIntegerArray initialize"
	Smalltalk addToStartUpList: self.
	LastSaveOrder _ self new: 2.
	LastSaveOrder at: 1 put: 42.
	LastSaveOrder at: 2 put: 13.! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:33'!
startUp
	"Check if the word order has changed from the last save"
	((LastSaveOrder at: 1) = 42 and:[(LastSaveOrder at: 2) = 13]) 
		ifTrue:[^self]. "Okay"
	((LastSaveOrder at: 2) = 42 and:[(LastSaveOrder at: 1) = 13]) 
		ifTrue:[^self swapShortObjects]. "Reverse guys"
	^self error:'This must never happen'! !

!ShortIntegerArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:40'!
swapShortObjects
	self allSubInstancesDo:[:inst| inst swapShortObjects]! !


!ShortIntegerArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:28'!
new: n
	^super new: n + 1 // 2! !
ShortIntegerArray variableWordSubclass: #ShortPointArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!ShortPointArray commentStamp: '<historical>' prior: 0!
This class stores points that are in short integer range (e.g., -32767 <= value <= 32768). It is used to pass data efficiently to the primitive level during high-bandwidth 2D graphics operations.!


!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
at: index
	"Return the element (e.g., point) at the given index"
	^(super at: index * 2 - 1) @ (super at: index * 2)! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
at: index put: aPoint
	"Store the argument aPoint at the given index"
	super at: index * 2 - 1 put: aPoint x asInteger.
	super at: index * 2 put: aPoint y asInteger.
	^aPoint! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/10/1998 19:41'!
bounds
	| min max |
	min _ max _ self at: 1.
	self do:[:pt|
		min _ min min: pt.
		max _ max max: pt].
	^min corner: max
		! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
defaultElement
	"Return the default element of the receiver"
	^0@0! !

!ShortPointArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 15:43'!
size
	^self basicSize! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortPointArray class
	instanceVariableNames: ''!

!ShortPointArray class methodsFor: 'instance creation' stamp: 'ar 1/15/1999 17:40'!
new: n
	^super new: n * 2! !
ArrayedCollection variableWordSubclass: #ShortRunArray
	instanceVariableNames: ''
	classVariableNames: 'LastSaveOrder '
	poolDictionaries: ''
	category: 'Balloon-Collections'!
!ShortRunArray commentStamp: '<historical>' prior: 0!
This class is run-length encoded representation of short integer (e.g., 16bit signed integer values)!


!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:26'!
at: index
	"Return the short value at the given index"
	| rlIndex |
	index < 1 ifTrue:[^self errorSubscriptBounds: index].
	rlIndex _ index.
	self lengthsAndValuesDo:[:runLength :runValue|
		rlIndex <= runLength ifTrue:[^runValue].
		rlIndex _ rlIndex - runLength].
	"Not found. Must be out of range"
	^self errorSubscriptBounds: index! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:18'!
at: index put: value
	"ShortRunArrays are read-only"
	^self shouldNotImplement.! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:39'!
compressionRatio
	"Return the compression ratio.
	The compression ratio is computed based
	on how much space would be needed to
	store the receiver in a ShortIntegerArray"
	^(self size asFloat * 0.5) "Would need only half of the amount in ShortIntegerArray"
		/ (self runSize max: 1)! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:21'!
lengthAtRun: index
	"Return the length of the run starting at the given index"
	^(self basicAt: index) bitShift: -16! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'!
runSize
	"Return the number of runs in the receiver"
	^self basicSize! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:28'!
size
	"Return the number of elements stored in the receiver"
	| n |
	n _ 0.
	"Note: The following loop is open-coded for speed"
	1 to: self basicSize do:[:i|
		n _ n + ((self basicAt: i) bitShift: -16).
	].
	^n! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:29'!
species
	"Answer the preferred class for reconstructing the receiver."
	^ShortIntegerArray! !

!ShortRunArray methodsFor: 'accessing' stamp: 'ar 11/3/1998 17:22'!
valueAtRun: index
	"Return the value of the run starting at the given index"
	| uShort |
	uShort _ (self basicAt: index) bitAnd: 16rFFFF.
	^(uShort bitAnd: 16r7FFF) - (uShort bitAnd: 16r8000)! !


!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 17:31'!
do: aBlock
	"Evaluate aBlock with all elements of the receiver"
	self lengthsAndValuesDo:[:runLength :runValue|
		"Use to:do: instead of timesRepeat: for compiler optimization"
		1 to: runLength do:[:i|
			aBlock value: runValue.
		].
	].! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'!
lengthsAndValuesDo: aBlock
	"Evaluate aBlock with the length and value of each run in the receiver"
	^self runsAndValuesDo: aBlock! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:44'!
runsAndValuesDo: aBlock
	"Evaluate aBlock with the length and value of each run in the receiver"
	| basicValue length value |
	1 to: self basicSize do:[:i|
		basicValue _ self basicAt: i.
		length _ basicValue bitShift: -16.
		value _ basicValue bitAnd: 16rFFFF.
		value _ (value bitAnd: 16r7FFF) - (value bitAnd: 16r8000).
		aBlock value: length value: value.
	].! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/3/1998 21:05'!
valuesCollect: aBlock
	"Evaluate aBlock with each of the receiver's values as the argument. 
	Collect the resulting values into a collection like the receiver. Answer 
	the new collection."
	| newArray newValue |
	newArray _ self class basicNew: self basicSize.
	1 to: self runSize do:[:i|
		newValue _ aBlock value: (self valueAtRun: i).
		newArray setRunAt: i toLength: (self lengthAtRun: i) value: newValue.
	].
	^newArray! !

!ShortRunArray methodsFor: 'enumerating' stamp: 'ar 11/15/1998 17:22'!
valuesDo: aBlock
	self lengthsAndValuesDo:[:runLength :runValue| aBlock value: runValue]! !


!ShortRunArray methodsFor: 'printing' stamp: 'ar 11/3/1998 17:41'!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll:' ( '.
	self lengthsAndValuesDo:[:runLength :runValue |
		aStream
			nextPutAll:' (';
			print: runLength;
			space;
			print: runValue;
			nextPut:$).
	].
	aStream nextPutAll:' )'.! !


!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'!
pvtAt: index
	"Private -- for swapping only"
	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:47'!
pvtAt: index put: value
	"Private -- for swapping only"
	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:02'!
setRunAt: i toLength: runLength value: value
	(value < -16r7FFF or:[value > 16r8000]) ifTrue:[^self errorImproperStore].
	(runLength < 0 or:[runLength > 16rFFFF]) ifTrue:[^self errorImproperStore].
	self basicAt: i put: (runLength bitShift: 16) + 
		((value bitAnd: 16r7FFF) - (value bitAnd: -16r8000)).! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 11/3/1998 21:00'!
setRuns: runArray values: valueArray
	| runLength value |
	1 to: runArray size do:[:i|
		runLength _ runArray at: i.
		value _ valueArray at: i.
		self setRunAt: i toLength: runLength value: value.
	].! !

!ShortRunArray methodsFor: 'private' stamp: 'ar 1/15/1999 17:48'!
swapRuns
	"Private -- swap length/value pairs in the receiver"
	| tmp |
	1 to: self basicSize do:[:i|
		tmp _ (self pvtAt: i * 2).
		self pvtAt: i * 2 put: (self pvtAt: i * 2 - 1).
		self pvtAt: i * 2 - 1 put: tmp.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ShortRunArray class
	instanceVariableNames: ''!

!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'!
new: n
	"ShortRunArrays must be created with either
		someCollection as: ShortRunArray
	or by using
		ShortRunArray runs: runCollection values: valueCollection.
	"
	^self shouldNotImplement! !

!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:35'!
newFrom: aCollection
	"Compress aCollection into a ShortRunArray"
	| lastValue lastRun runs values |
	aCollection isEmpty ifTrue:[^self runs:#() values: #()].
	runs _ WriteStream on: (WordArray new: 100).
	values _ WriteStream on: (ShortIntegerArray new: 100).
	lastValue _ aCollection first.
	lastRun _ 0.
	aCollection do:[:item|
		(item = lastValue and:[lastRun < 16r8000]) ifTrue:[
			lastRun _ lastRun + 1.
		] ifFalse:[
			runs nextPut: lastRun.
			values nextPut: lastValue.
			lastRun _ 1.
			lastValue _ item.
		].
	].
	runs nextPut: lastRun.
	values nextPut: lastValue.
	^self runs: runs contents values: values contents! !

!ShortRunArray class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 17:12'!
runs: runCollection values: valueCollection
	^(self basicNew: runCollection size) setRuns: runCollection values: valueCollection! !


!ShortRunArray class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:17'!
initialize
	"ShortRunArray initialize"
	Smalltalk addToStartUpList: self.
	LastSaveOrder _ #(42 42 42) as: self.! !

!ShortRunArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:46'!
startUp
	"Check if the word order has changed from the last save"
	((LastSaveOrder valueAtRun: 1) = 42 and:[(LastSaveOrder lengthAtRun: 1) = 3]) 
		ifTrue:[^self]. "Okay"
	((LastSaveOrder lengthAtRun: 1) = 42 and:[(LastSaveOrder valueAtRun: 1) = 3]) 
		ifTrue:[^self swapRuns]. "Reverse guys"
	^self error:'This must never happen'! !

!ShortRunArray class methodsFor: 'class initialization' stamp: 'ar 1/15/1999 17:47'!
swapRuns
	self allSubInstancesDo:[:inst| inst swapRuns]! !
SimpleButtonMorph subclass: #SimpleButtonDelayedMenuMorph
	instanceVariableNames: 'didMenu mouseDownTime '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SimpleButtonDelayedMenuMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/5/2000 16:21'!
color: x

	super color: x.
! !

!SimpleButtonDelayedMenuMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/26/2000 12:19'!
handlesMouseStillDown: evt

	^true! !

!SimpleButtonDelayedMenuMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/5/2000 16:00'!
mouseDown: evt

	didMenu _ nil.
	mouseDownTime _ Time millisecondClockValue.
	super mouseDown: evt.
! !

!SimpleButtonDelayedMenuMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/25/2000 18:08'!
mouseStillDown: evt
	(mouseDownTime isNil or: [(Time millisecondClockValue - mouseDownTime) abs < 1000]) ifTrue: [
		^super mouseStillDown: evt
	].
	didMenu ifNotNil: [^super mouseStillDown: evt].
	self color: oldColor.		"in case menu never returns"
	didMenu _ target showMenuFor: actionSelector event: evt.
! !

!SimpleButtonDelayedMenuMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/5/2000 16:50'!
mouseUp: evt

	didMenu == true ifFalse: [^super mouseUp: evt].
	oldColor ifNotNil: [
		self color: oldColor.
		oldColor _ nil
	].! !
RectangleMorph subclass: #SimpleButtonMorph
	instanceVariableNames: 'target actionSelector arguments actWhen oldColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'sma 3/24/2000 11:49'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target isMorph
		ifTrue:
			[target isWorldMorph ifTrue: [self target: aWorld].
			target isHandMorph ifTrue: [self target: aWorld primaryHand]]
		ifFalse: [(target isKindOf: Presenter) ifTrue: [self target: aWorld presenter]]! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:08'!
initialize

	self initializeAllButLabel; setDefaultLabel! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:07'!
initializeAllButLabel

	super initialize.
	self borderWidth: 1.
	self cornerStyle: #rounded.
	self color: (Color r: 0.4 g: 0.8 b: 0.6).
	self borderColor: self color darker.
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp
! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:09'!
initializeWithLabel: labelString

	self initializeAllButLabel; label: labelString
! !

!SimpleButtonMorph methodsFor: 'initialization' stamp: 'sw 9/28/1999 14:05'!
setDefaultLabel
	self label: 'Flash'.
! !


!SimpleButtonMorph methodsFor: 'menu' stamp: 'sw 9/28/1999 20:42'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	self addLabelItemsTo: aCustomMenu hand: aHandMorph.
	(target isKindOf: BookMorph)
		ifTrue:
			[aCustomMenu add: 'set page sound' action: #setPageSound:.
			aCustomMenu add: 'set page visual' action: #setPageVisual:]
		ifFalse:
			[aCustomMenu add: 'change action selector' action: #setActionSelector.
			aCustomMenu add: 'change arguments' action: #setArguments.
			aCustomMenu add: 'change when to act' action: #setActWhen.
			((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue:
				[aCustomMenu add: 'set target' action: #setTarget:]].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'sw 9/28/1999 20:41'!
addLabelItemsTo: aCustomMenu hand: aHandMorph
	aCustomMenu add: 'change label' action: #setLabel
! !

!SimpleButtonMorph methodsFor: 'menu'!
setActWhen
	actWhen _ (SelectionMenu selections: #(buttonDown buttonUp whilePressed))
		startUpWithCaption: 'Choose one of the following conditions'
! !

!SimpleButtonMorph methodsFor: 'menu'!
setActionSelector

	| newSel |
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this button is pressed'
		initialAnswer: actionSelector.
	newSel isEmpty ifFalse: [self actionSelector: newSel].
! !

!SimpleButtonMorph methodsFor: 'menu'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods'
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!SimpleButtonMorph methodsFor: 'menu'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel].
! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageSound: event

	^ target menuPageSoundFor: self event: event! !

!SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'!
setPageVisual: event

	^ target menuPageVisualFor: self event: event! !

!SimpleButtonMorph methodsFor: 'menu'!
setTarget: evt

	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1
		ifTrue: [target _ rootMorphs at: 2]
		ifFalse: [target _ nil. ^ self].
! !


!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 10/8/2000 08:14'!
actWhen
	"acceptable symbols:  #buttonDown, #buttonUp, and #whilePressed"

	^ actWhen! !

!SimpleButtonMorph methodsFor: 'accessing'!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed"
	actWhen _ condition! !

!SimpleButtonMorph methodsFor: 'accessing'!
actionSelector

	^ actionSelector
! !

!SimpleButtonMorph methodsFor: 'accessing'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!SimpleButtonMorph methodsFor: 'accessing'!
arguments

	^ arguments
! !

!SimpleButtonMorph methodsFor: 'accessing'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: '6/7/97 10:53 di'!
extent: newExtent
	| label |
	super extent: newExtent.
	submorphs size = 1 ifTrue:
		["keep the label centered"
		"NOTE: may want to test more that it IS a label..."
		label _ self firstSubmorph.
		label position: self center - (label extent // 2)]! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 6/11/1999 18:45'!
fitContents
	| aMorph aCenter |
	aCenter _ self center.
	submorphs size = 0 ifTrue: [^ self].
	aMorph _ submorphs first.
	self extent: aMorph extent + (borderWidth + 6).
	self center: aCenter.
	aMorph position: aCenter - (aMorph extent // 2)
! !

!SimpleButtonMorph methodsFor: 'accessing'!
label

	| s |
	s _ ''.
	self allMorphsDo: [:m | (m isKindOf: StringMorph) ifTrue: [s _ m contents]].
	^ s! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/7/1999 18:11'!
label: aString

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: TextStyle defaultFont.
	self extent: m extent + (borderWidth + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 12/10/1999 09:06'!
label: aString font: aFont

	| oldLabel m |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	m _ StringMorph contents: aString font: (aFont ifNil: [Preferences standardButtonFont]).
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 6/11/1999 18:40'!
labelString: aString

	| existingLabel |
	(existingLabel _ self findA: StringMorph)
		ifNil:
			[self label: aString]
		ifNotNil:
			[existingLabel contents: aString.
			self fitContents]
! !

!SimpleButtonMorph methodsFor: 'accessing'!
target

	^ target
! !

!SimpleButtonMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject
! !


!SimpleButtonMorph methodsFor: 'events'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionSelector withArguments: arguments]].
! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'sw 8/16/97 22:10'!
handlesMouseDown: evt
	^  self isPartsDonor not
! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:15'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:10'!
mouseDown: evt

	| now dt |
	now _ Time millisecondClockValue.
	oldColor _ color. 
	actWhen == #buttonDown
		ifTrue: [self doButtonAction]
		ifFalse: [	self updateVisualState: evt; refreshWorld].
	dt _ Time millisecondClockValue - now max: 0.  "Time it took to do"
	dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait].
	self mouseStillDown: evt.! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:10'!
mouseMove: evt
	actWhen == #buttonDown ifTrue: [^ self].
	self updateVisualState: evt.! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:15'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!SimpleButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:12'!
mouseUp: evt
	oldColor ifNotNil:
		["if oldColor nil, it signals that mouse had not gone DOWN
		inside me, e.g. because of a cmd-drag; in this case we want
		to avoid triggering the action!!"
		self color: oldColor.
		oldColor _ nil.
		(actWhen == #buttonUp and: [self containsPoint: evt cursorPoint])
			ifTrue: [self doButtonAction]].
! !


!SimpleButtonMorph methodsFor: 'copying' stamp: 'sw 2/15/98 03:49'!
recolor: c
	self color: c.
	oldColor _ c! !

!SimpleButtonMorph methodsFor: 'copying' stamp: 'jm 7/28/97 11:52'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then point at the new copy.  And also copies the array, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!SimpleButtonMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!SimpleButtonMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:35'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
actWhen _ actWhen veryDeepCopyWith: deepCopier.
oldColor _ oldColor veryDeepCopyWith: deepCopier.! !


!SimpleButtonMorph methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:49'!
objectForDataStream: refStrm
	"I am about to be written on an object file.  If I send a message to a BookMorph, it would be bad to write that object out.  Create and write out a URLMorph instead."

	| bb thatPage um stem ind sqPg |
	(actionSelector == #goToPageMorph:fromBookmark:) | 
		(actionSelector == #goToPageMorph:) ifFalse: [
			^ super objectForDataStream: refStrm].	"normal case"

	target url ifNil: ["Later force target book to get a url."
		bb _ SimpleButtonMorph new.	"write out a dummy"
		bb label: self label.
		bb bounds: bounds.
		refStrm replace: self with: bb.
		^ bb].

	(thatPage _ arguments first) url ifNil: [
			"Need to assign a url to a page that will be written later.
			It might have bookmarks too.  Don't want to recurse deeply.  
			Have that page write out a dummy morph to save its url on the server."
		stem _ target getStemUrl.	"know it has one"
		ind _ target pages identityIndexOf: thatPage.
		thatPage reserveUrl: stem,(ind printString),'.sp'].
	um _ URLMorph newForURL: thatPage url.
	sqPg _ thatPage sqkPage clone.
	sqPg contentsMorph: nil.
	um setURL: thatPage url page: sqPg.
	(SqueakPage stemUrl: target url) = (SqueakPage stemUrl: thatPage url) 
		ifTrue: [um book: true]
		ifFalse: [um book: target url].  	"remember which book"
	um privateOwner: owner.
	um bounds: bounds.
	um isBookmark: true; label: self label.
	um borderWidth: borderWidth; borderColor: borderColor.
	um color: color.
	refStrm replace: self with: um.
	^ um! !


!SimpleButtonMorph methodsFor: 'visual properties' stamp: 'hg 6/27/2000 13:58'!
updateVisualState: evt
	
	oldColor ifNotNil: [
		 self color: 
			((self containsPoint: evt cursorPoint)
				ifTrue: [oldColor mixed: 1/2 with: Color white]
				ifFalse: [oldColor])]
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleButtonMorph class
	instanceVariableNames: ''!

!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'sw 5/6/1998 14:07'!
authoringPrototype
	^ super authoringPrototype label: 'Button'! !

!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'sw 2/16/98 01:31'!
defaultNameStemForInstances
	^ 'button'! !

!SimpleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:42'!
newWithLabel: labelString

	^ self basicNew initializeWithLabel: labelString
! !
Socket subclass: #SimpleClientSocket
	instanceVariableNames: 'buffer bufferPos '
	classVariableNames: 'CR CrLf LF '
	poolDictionaries: ''
	category: 'Network-Kernel'!
!SimpleClientSocket commentStamp: '<historical>' prior: 0!
This class supports client for simple network protocols based on sending textual commands and responses. Examples of such protocols include POP3 (mail retrieval), SMTP (mail posting), HTTP (web browsing), and NTTP (network news). Some simple examples are presented as class methods, but a full-service client of some service should be implemented as a subclass.

The basic services provided by this class are:
	sendCommand:			-- sends a command line terminate with <CR><LF>
	getResponse				-- gets a single-line response to a command
	getMultilineResponse	-- gets a multiple line response terminated by a period
							-- on a line by itself

There are variants of the getResponse commands that display lines on the screen as they are being received. Linefeeds are stripped out of all responses.

The 'get' commands above make use of an internal buffer.  So intermixing these two commands and regular Socket recieve commands can cause problems.!


!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'di 4/13/1999 14:43'!
displayString: aString
	"Display the given string on the Display. Used for testing."

	| s |
	aString isEmpty ifTrue: [^ self].
	aString size > 60
		ifTrue: [s _ aString copyFrom: 1 to: 60]  "limit to 60 characters"
		ifFalse: [s _ aString].

	s displayOn: Display.
! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/15/97 15:43'!
getMultilineResponse
	"Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character."

	^ self getMultilineResponseShowing: false.
! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:34'!
getMultilineResponseShowing: showFlag
	"Get a multiple line response to the last command. A multiple line response ends with a line containing only a single period (.) character. Linefeed characters are filtered out. If showFlag is true, each line is shown in the upper-left corner of the Display as it is received."

	| response done chunk |
	response _ WriteStream on: ''.
	done _ false.
	[done] whileFalse: [
		showFlag
			ifTrue: [chunk _ self getResponseShowing: true]
			ifFalse: [chunk _ self getResponse].
		(chunk beginsWith: '.')
			ifTrue: [ response nextPutAll: (chunk copyFrom: 2 to: chunk size) ]
			ifFalse: [ response nextPutAll: chunk ].
		done _ (chunk = ('.', String cr)) ].

	^ response contents
! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 02:10'!
getResponse
	"Get a one-line response from the server.  The final LF is removed from the line, but the CR is left, so that the line is in Squeak's text format"

	^ self getResponseShowing: false
! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:27'!
getResponseShowing: showFlag

	| line idx |
	line _ WriteStream on: String new.

	buffer ifNil: [
		buffer _ String new.
		bufferPos _ 0 ].

	[
		"look for a LF in the buffer"
		idx _ buffer indexOf: Character lf startingAt: bufferPos+1 ifAbsent: [ 0 ].
		idx > 0 ifTrue: [
			"found it!! we have a line"
			line nextPutAll: (buffer copyFrom: bufferPos+1 to: idx-1).
			bufferPos _ idx.
			^line contents ].
		
		"didn't find it.  add the whole buffer to the line, and retrieve some more data"
		line nextPutAll: (buffer copyFrom: bufferPos+1 to: buffer size).
		bufferPos _ 0.
		buffer _ String new.
		self waitForDataQueryingUserEvery: 30.
		buffer _ self getData.

		true
	] whileTrue.! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/17/97 16:00'!
sendCommand: commandString
	"Send the given command as a single line followed by a <CR><LF> terminator."

	self sendData: commandString, CrLf.
! !

!SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/16/1998 14:37'!
waitForDataQueryingUserEvery: seconds
	"Wait for data to arrive, asking the user periodically if they wish to keep waiting. If they don't wish to keep waiting, destroy the socket and raise an error."

	| gotData |
	gotData _ false.
	[gotData]
		whileFalse: [
			gotData _ self waitForDataUntil: (Socket deadlineSecs: seconds).
			gotData ifFalse: [
				self isConnected ifFalse: [
					self destroy.
					self error: 'server closed connection'].
				(self confirm: 'server not responding; keep trying?')
					ifFalse: [
						self destroy.
						self error: 'no response from server']]].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleClientSocket class
	instanceVariableNames: ''!

!SimpleClientSocket class methodsFor: 'class initialization' stamp: 'jm 9/15/97 11:42'!
initialize
	"SimpleClientSocket initialize"

	CR _ Character cr.
	LF _ Character linefeed.

	"string for command line termination:"
	CrLf _ String with: CR with: LF.
! !


!SimpleClientSocket class methodsFor: 'net news example' stamp: 'tk 5/4/1998 17:36'!
nntpTest
	"SimpleClientSocket nntpTest"

	| addr s headers msgs header allNewsGroups |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ SimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 119.  "119 is the NNTP port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s sendCommand: 'group comp.lang.smalltalk'.
	Transcript show: s getResponse.

	"get all the message headers for the current newsgroup"
	s sendCommand: 'xover 1-1000000'.
	headers _ s getMultilineResponseShowing: true.

	"print the headers of the first 10 messages of comp.lang.smalltalk"
	s sendCommand: 'listgroup comp.lang.smalltalk'.
	msgs _ self parseIntegerList: s getMultilineResponse.
	msgs ifNotNil: [
		1 to: 5 do: [:i |
			s sendCommand: 'head ', (msgs at: i) printString.
			header _ s getMultilineResponse.
			Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr]].

	"get a full list of usenet newsgroups"
	s sendCommand: 'newgroups 010101 000000'.
	allNewsGroups _ s getMultilineResponse.
	Transcript show: allNewsGroups size printString, ' bytes in full newsgroup list'; cr.

	Transcript show: 'Sending quit...'; cr.
	s sendCommand: 'QUIT'.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.

	(headers ~~ nil and:
	 [self confirm: 'show article headers from comp.lang.smalltalk?'])
		ifTrue: [
			(StringHolder new contents: (self parseHeaderList: headers))
				openLabel: 'Newsgroup Headers'].

	(allNewsGroups ~~ nil and:
	 [self confirm: 'show list of all newsgroups available on your server?'])
		ifTrue: [
			(StringHolder new contents: allNewsGroups)
				openLabel: 'All Usenet Newsgroups'].
! !

!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:25'!
parseHeaderList: aString
	"Parse a list of newsgroup headers."

	| results s lineStart |
	results _ WriteStream on: (String new: aString size).
	s _ ReadStream on: aString.
	[s atEnd]
		whileFalse: [
			lineStart _ s position + 1.
			3 timesRepeat: [s skipTo: Character tab].  "find fourth tab"
			lineStart to: s position - 1 do: [:i | results nextPut: (aString at: i)].
			results cr.
			s skipTo: Character cr].
	^ results contents
! !

!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!
parseIntegerList: aString
	"Parse a list of integers, each on a line by itself."

	| s out |
	s _ ReadStream on: aString.
	s skipTo: Character cr.  "skip the first line"
	out _ OrderedCollection new.
	[s atEnd]
		whileFalse: [
			out addLast: (Integer readFrom: s).
			s skipTo: Character cr].
	^ out asArray
! !

!SimpleClientSocket class methodsFor: 'net news example' stamp: 'jm 9/15/97 13:26'!
parseNTTPMsgList: aString
	"Parse a list of integers, each on a line by itself."

	| s out |
	s _ ReadStream on: aString.
	s skipTo: Character cr.  "skip the first line"
	out _ OrderedCollection new.
	[s atEnd]
		whileFalse: [
			out addLast: (Integer readFrom: s).
			s skipTo: Character cr].
	^ out asArray
! !


!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/15/97 14:47'!
extractDateFromAndSubjectFromHeader: headerString

	| date from subject s lineBuf c line i |
	date _ from _ subject _ ''.
	s _ ReadStream on: headerString.
	lineBuf _ WriteStream on: ''.
	[s atEnd] whileFalse: [
		c _ s next.
		c = CR
			ifTrue: [
				line _ lineBuf contents.
				(line beginsWith: 'Date: ')	ifTrue: [date _ line copyFrom: 7 to: line size].
				(line beginsWith: 'From: ')	ifTrue: [from _ line copyFrom: 7 to: line size].
				(line beginsWith: 'Subject: ')	ifTrue: [subject _ line copyFrom: 10 to: line size].
				lineBuf _ WriteStream on: '']
			ifFalse: [lineBuf nextPut: c]].

	i _ date indexOf: $' ifAbsent: [0].
	date _ date copyFrom: i + 1 to: date size.
	^ (self simpleDateString: date), ', ', from, ':
  ', subject
! !

!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'jm 9/17/97 14:24'!
popTest
	"SimpleClientSocket popTest"

	| addr userName userPassword s msgs header |
	addr _ NetNameResolver promptUserForHostAddress.
	userName _ FillInTheBlank
		request: 'What is your email name?'
		initialAnswer: 'johnm'.
	userPassword _ FillInTheBlank
		request: 'What is your email password?'.

	s _ SimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 110.  "110 is the POP3 port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s sendCommand: 'USER ', userName.
	Transcript show: s getResponse.
	s sendCommand: 'PASS ', userPassword.
	Transcript show: s getResponse.
	s sendCommand: 'LIST'.

	"the following should be tweaked to handle an empy mailbox:"
	msgs _ self parseIntegerList: s getMultilineResponse.

	1 to: (msgs size min: 5) do: [ :i |
		s sendCommand: 'TOP ', (msgs at: i) printString, ' 0'.
		header _ s getMultilineResponse.
		Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr].

	msgs size > 0 ifTrue: [
		"get the first message"
		s sendCommand: 'RETR 1'.
		Transcript show: s getMultilineResponse].

	Transcript show: 'closing connection'; cr.
	s sendCommand: 'QUIT'.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !

!SimpleClientSocket class methodsFor: 'POP mail example' stamp: 'tk 4/10/1998 06:47'!
simpleDateString: dateString

	| s |
	s _ ReadStream on: dateString.
	s skipTo: $,.  "scan thru first comma"
	s atEnd ifTrue: [s reset].  "no comma found; reset s"
	s skipSeparators.
	^ (Date readFrom: s) mmddyyyy
! !


!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/17/97 14:25'!
forkingRemoteCursorSender
	"This is the client side of a test that sends samples of the local input sensor state to the server, which may be running on a local or remote host. This method opens the connection, then forks a process to send the cursor data. Data is sent continuously until the user clicks in a 20x20 pixel square at the top-left corner of the display. The server should be started first. Note the server's address, since this method will prompt you for it."
	"SimpleClientSocket forkingRemoteCursorSender"

	| sock addr stopRect |
	Transcript show: 'starting remote cursor sender'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	addr _ NetNameResolver promptUserForHostAddress.
	Transcript show: 'opening connection'; cr.
	sock _ SimpleClientSocket new.
	sock connectTo: addr port: 54323.
	sock waitForConnectionUntil: self standardDeadline.
	(sock isConnected) ifFalse: [self error: 'sock not connected'].
	Transcript show: 'connection established'; cr.

	stopRect _ 0@0 corner: 20@20.  "click in this rectangle to stop sending"
	Display reverse: stopRect.
	["the sending process"
		[(stopRect containsPoint: Sensor cursorPoint) and:
		 [Sensor anyButtonPressed]]
			whileFalse: [
				sock sendCommand: self sensorStateString.
				(Delay forMilliseconds: 20) wait].

		sock waitForSendDoneUntil: self standardDeadline.
		sock destroy.
		Transcript show: 'remote cursor sender done'; cr.
		Display reverse: stopRect.
	] fork.
! !

!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 14:49'!
parseSensorStateString: aString
	"Parse the given sensor stat string and return an array whose first element is the cursor point and whose second is the cursor button state."
	"SimpleClientSocket parseSensorStateString: SimpleClientSocket sensorStateString"

	| s buttons x y |
	s _ ReadStream on: aString.
	x _ Integer readFrom: s.
	s skipSeparators.
	y _ Integer readFrom: s.
	s skipSeparators.
	buttons _ Integer readFrom: s.
	^ Array with: x@y with: buttons
! !

!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'di 4/13/1999 14:42'!
remoteCursorReceiver
	"Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it."
	"[SimpleClientSocket remoteCursorReceiver] fork"

	| sock response |
	Transcript show: 'starting remote cursor receiver'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	Transcript show: 'my address is ', NetNameResolver localAddressString; cr.
	Transcript show: 'opening connection'; cr.
	sock _ SimpleClientSocket new.
	sock listenOn: 54323.
	sock waitForConnectionUntil: (Socket deadlineSecs: 60).
	sock isConnected
		ifFalse: [
			 sock destroy.
			Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'.
			^ self].
	Transcript show: 'connection established'; cr.

	[sock isConnected]
		whileTrue: [
			sock dataAvailable
				ifTrue: [
					response _ sock getResponse.
					response displayOn: Display at: 10@10]
				ifFalse: [
					"if no data available, let other processes run for a while"
					(Delay forMilliseconds: 20) wait]].

	sock destroy.
	Transcript show: 'remote cursor receiver done'; cr.
! !

!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'di 4/13/1999 14:43'!
remoteCursorTest
	"This version of the remote cursor test runs both the client and the server code in the same loop."
	"SimpleClientSocket remoteCursorTest"

	| sock1 sock2 samplesToSend samplesSent done t |
	Transcript show: 'starting remote cursor test'; cr.
	Transcript show: 'initializing network'; cr.
	Socket initializeNetwork.
	Transcript show: 'opening connection'; cr.
	sock1 _ SimpleClientSocket new.
	sock2 _ SimpleClientSocket new.
	sock1 listenOn: 54321.
	sock2 connectTo: (NetNameResolver localHostAddress) port: 54321.
	sock1 waitForConnectionUntil: self standardDeadline.
	sock2 waitForConnectionUntil: self standardDeadline.
	(sock1 isConnected) ifFalse: [self error: 'sock1 not connected'].
	(sock2 isConnected) ifFalse: [self error: 'sock2 not connected'].
	Transcript show: 'connection established'; cr.

	samplesToSend _ 100.
	t _ Time millisecondsToRun: [
		samplesSent _ 0.
		done _ false.
		[done]
			whileFalse: [
				(sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [
					sock1 sendCommand: self sensorStateString.
					samplesSent _ samplesSent + 1].
				sock2 dataAvailable ifTrue: [
					sock2 getResponse displayOn: Display at: 10@10].
				done _ samplesSent = samplesToSend]].
	sock1 destroy.
	sock2 destroy.
	Transcript show: 'remote cursor test done'; cr.
	Transcript show:
		samplesSent printString, ' samples sent in ',
		t printString, ' milliseconds'; cr.
	Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr.
! !

!SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'jm 9/15/97 13:11'!
sensorStateString
	"SimpleClientSocket sensorStateString"

	| pt buttons s |
	pt _ Sensor cursorPoint.
	buttons _ Sensor primMouseButtons.
	s _ WriteStream on: (String new: 100).
	s nextPutAll: pt x printString.
	s space.
	s nextPutAll: pt y printString.
	s space.
	s nextPutAll: buttons printString.
	^ s contents
! !


!SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 9/17/97 14:27'!
finger: userName
	"SimpleClientSocket finger: 'stp'"

	| addr s |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ SimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 79.  "finger port number"
	s waitForConnectionUntil: self standardDeadline.
	s sendCommand: userName.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !

!SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 6/8/1998 16:05'!
httpTestHost: hostName port: port url: url
	"This test fetches a URL from the given host and port."
	"SimpleClientSocket httpTestHost: 'www.disney.com' port: 80 url: '/'"
	"Tests URL fetch through a local HTTP proxie server:
		(SimpleClientSocket
			httpTestHost: '127.0.0.1'
			port: 8080
			url: 'HTTP://www.exploratorium.edu/index.html')"

	| hostAddr s result buf bytes totalBytes t |
	Transcript cr; show: 'starting http test'; cr.
	Socket initializeNetwork.
	hostAddr _ NetNameResolver addressForName: hostName timeout: 10.
	hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName].

	s _ SimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: hostAddr port: port.
	s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 10).
	(s isConnected) ifFalse: [
		s destroy.
		^ self inform: 'could not connect'].
	Transcript show: 'connection open; waiting for data'; cr.

	s sendCommand: 'GET ', url, ' HTTP/1.0'.
	s sendCommand: 'User-Agent: Squeak 1.19'.
	s sendCommand: 'ACCEPT: text/html'.	"always accept plain text"
	s sendCommand: 'ACCEPT: application/octet-stream'.  "also accept binary data"
	s sendCommand: ''.  "blank line"

	result _ WriteStream on: (String new: 10000).
	buf _ String new: 10000.
	totalBytes _ 0.
	t _ Time millisecondsToRun: [
		[s isConnected] whileTrue: [
			s waitForDataUntil: (Socket deadlineSecs: 5).
			bytes _ s receiveDataInto: buf.
			1 to: bytes do: [:i | result nextPut: (buf at: i)].
			totalBytes _ totalBytes + bytes.
			Transcript show: totalBytes printString, ' bytes received'; cr]].

	s destroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
	Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '.
	Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr.
	Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr.
	Transcript endEntry.
	(StringHolder new contents: (result contents))
		openLabel: 'HTTP Test Result: URL Contents'.
! !

!SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 9/17/97 14:22'!
timeTest
	"SimpleClientSocket timeTest"

	| addr s |
	addr _ NetNameResolver promptUserForHostAddress.
	s _ SimpleClientSocket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: addr port: 13.  "time port number"
	s waitForConnectionUntil: self standardDeadline.
	Transcript show: s getResponse.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr; endEntry.
! !


!SimpleClientSocket class methodsFor: 'queries' stamp: 'jm 2/26/98 09:50'!
crLf

	^ CrLf
! !
ScrollPane subclass: #SimpleHierarchicalListMorph
	instanceVariableNames: 'selectedMorph getListSelector keystrokeActionSelector autoDeselect expandedForm notExpandedForm columns sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!SimpleHierarchicalListMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
Don't blame him if it's not perfect.  We wanted to get it out for people to play with.!


!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 4/10/98 16:20'!
autoDeselect: trueOrFalse
	"Enable/disable autoDeselect (see class comment)"
	autoDeselect _ trueOrFalse.! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 3/30/1999 22:29'!
currentlyExpanded

	^(scroller submorphs select: [ :each | each isExpanded]) collect: [ :each |
		each complexContents
	].
	! !

!SimpleHierarchicalListMorph methodsFor: 'initialization'!
extent: newExtent
	super extent: newExtent.
	self setScrollDeltas ! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'ar 10/25/2000 17:50'!
initialize
	super initialize.
	self on: #mouseMove send: #mouseStillDown:onItem: to: self! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 5/6/1998 21:19'!
installModelIn: aWorld
	"No special inits for new components"
	^ self! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 7/30/2000 19:46'!
list: aCollection

	| wereExpanded morphList |
	wereExpanded _ self currentlyExpanded.
	scroller removeAllMorphs.
	(aCollection isNil or: [aCollection isEmpty]) ifTrue: [^ self selectedMorph: nil].
	morphList _ OrderedCollection new.
	self 
		addMorphsTo: morphList
		from: aCollection 
		allowSorting: false
		withExpandedItems: wereExpanded
		atLevel: 0.
	self insertNewMorphs: morphList.
	self installEventHandlerOn: morphList! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'di 5/22/1998 00:32'!
listItemHeight
	"This should be cleaned up.  The list should get spaced by this parameter."
	^ 12! !

!SimpleHierarchicalListMorph methodsFor: 'initialization' stamp: 'RAA 8/1/1998 00:19'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel

	self model: anObject.
	getListSelector _ getListSel.
	getSelectionSelector _ getSelectionSel.
	setSelectionSelector _ setSelectionSel.
	getMenuSelector _ getMenuSel.
	keystrokeActionSelector _ keyActionSel.
	autoDeselect _ true.
	self borderWidth: 1.
	self list: self getList.! !


!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 3/30/1999 17:44'!
drawOn: aCanvas
	super drawOn: aCanvas.
	selectedMorph ifNotNil:
		[aCanvas fillRectangle:
			(((scroller transformFrom: self) invertBoundsRect: selectedMorph bounds)
						intersect: scroller bounds)
				color: color darker]! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'!
highlightSelection

	selectedMorph ifNotNil: [selectedMorph highlight]! !

!SimpleHierarchicalListMorph methodsFor: 'drawing' stamp: 'RAA 8/3/1999 09:44'!
unhighlightSelection
	selectedMorph ifNotNil: [selectedMorph unhighlight]! !


!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'panda 4/28/2000 15:33'!
expand: aMorph to: level
	| allChildren |
	aMorph toggleExpandedState.
	allChildren _ OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		((each canExpand
			and: [each isExpanded not])
			and: [level > 0])
			ifTrue: [self expand: each to: level-1]].
	self installEventHandlerOn: allChildren! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'panda 4/28/2000 15:33'!
expandAll: aMorph except: aBlock
	| allChildren |
	(aBlock value: aMorph complexContents)
		ifFalse: [^self].
	aMorph toggleExpandedState.
	allChildren _ OrderedCollection new: 10.
	aMorph recursiveAddTo: allChildren.
	allChildren do: [:each | 
		(each canExpand
			and: [each isExpanded not])
			ifTrue: [self expandAll: each except: aBlock]].
	self installEventHandlerOn: allChildren! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 9/15/2000 22:58'!
handlesKeyboard: evt
	^true! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'mir 6/1/2000 14:32'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed]! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'panda 4/28/2000 15:34'!
mouseDown: event onItem: aMorph

	| oldState |
	(aMorph inToggleArea: event) ifTrue: [
		"self setSelectedMorph: aMorph."
		event yellowButtonPressed ifTrue: [
			oldState _ aMorph isExpanded.
			scroller submorphs copy do: [ :each |
				(each canExpand and: [each isExpanded = oldState]) ifTrue: [
					each toggleExpandedState.
					self installEventHandlerOn: each children.
				].
			].
		] ifFalse: [
			aMorph toggleExpandedState.
			self installEventHandlerOn: aMorph children.
		].
		self adjustSubmorphPositions.
		^self
	].
	event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
	model okToChange ifFalse: [^ self].  "No change if model is locked"
	((autoDeselect == nil or: [autoDeselect]) and: [aMorph == selectedMorph])
		ifTrue: [self setSelectedMorph: nil]
		ifFalse: [self setSelectedMorph: aMorph].
! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'ar 9/15/2000 23:05'!
mouseEnter: event
	super mouseEnter: event.
	event hand newKeyboardFocus: self! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'mir 5/8/2000 17:16'!
mouseEnterDragging: anEvent onItem: aMorph 
	anEvent hand hasSubmorphs ifFalse: ["no d&d"
		^ self].
	(self wantsDroppedMorph: anEvent hand firstSubmorph event: anEvent )
		ifTrue: 
			[self potentialDropMorph: aMorph]! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'panda 4/28/2000 11:50'!
mouseLeaveDragging: anEvent onItem: aMorph 
	anEvent hand hasSubmorphs ifFalse: ["no d&d"
		^ self].
	(self wantsDroppedMorph: anEvent hand firstSubmorph event: anEvent )
		ifTrue: 
			[self resetPotentialDropMorph]! !

!SimpleHierarchicalListMorph methodsFor: 'events' stamp: 'mir 6/1/2000 14:32'!
mouseUp: evt
	"do nothing but fix the nobody land bug"! !


!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 7/31/1998 00:25'!
maximumSelection

	^ scroller submorphs size
! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'!
minimumSelection
	^ 1! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:32'!
numSelectionsInView
	^ self height // self listItemHeight! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'panda 4/25/2000 18:56'!
selectedMorph
	^selectedMorph! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/1/1998 00:13'!
selectedMorph: aMorph

	self unhighlightSelection.
	selectedMorph _ aMorph.
	self highlightSelection! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 8/31/1999 08:36'!
selection: item
	"Called from outside to request setting a new selection.
	Assumes scroller submorphs is exactly our list.
	Note: MAY NOT work right if list includes repeated items"

	| i |
	item ifNil: [^self selectionIndex: 0].
	i _ scroller submorphs findFirst: [:m | m complexContents == item].
	i > 0 ifTrue: [^self selectionIndex: i].
	i _ scroller submorphs findFirst: [:m | m withoutListWrapper = item withoutListWrapper].
	self selectionIndex: i! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 11:02'!
selectionIndex: index
	"Called internally to select the index-th item."
	| theMorph range |
	index ifNil: [^ self].
	(theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index])
		ifNotNil:
		[((theMorph bounds top - scroller offset y) >= 0
			and: [(theMorph bounds bottom - scroller offset y) <= bounds height]) ifFalse:
			["Scroll into view -- should be elsewhere"
			range _ self totalScrollRange.
			scrollBar value: (range > 0
				ifTrue: [((index-1 * theMorph height) / self totalScrollRange)
									truncateTo: scrollBar scrollDelta]
				ifFalse: [0]).
			scroller offset: -3 @ (range * scrollBar value)]].
	self selectedMorph: theMorph! !

!SimpleHierarchicalListMorph methodsFor: 'selection' stamp: 'RAA 3/31/1999 21:28'!
setSelectedMorph: aMorph

	model 
		perform: (setSelectionSelector ifNil: [^self]) 
		with: aMorph complexContents	"leave last wrapper in place"

 ! !


!SimpleHierarchicalListMorph methodsFor: 'model access' stamp: 'RAA 8/1/1998 00:10'!
getList 
	"Answer the list to be displayed."

	^(model perform: (getListSelector ifNil: [^#()])) ifNil: [#()]

! !

!SimpleHierarchicalListMorph methodsFor: 'model access' stamp: 'th 12/11/1999 17:35'!
keyStroke: event 
	"Process potential command keys"
	| args aCharacter |
	(self scrollByKeyboard: event)
		ifTrue: [^ self].
	keystrokeActionSelector == nil ifTrue: [^ nil].
	aCharacter _ event keyCharacter.
	(args _ keystrokeActionSelector numArgs) = 1 ifTrue: [^ model perform: keystrokeActionSelector with: aCharacter].
	args = 2 ifTrue: [^ model
			perform: keystrokeActionSelector
			with: aCharacter
			with: self].
	^ self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! !


!SimpleHierarchicalListMorph methodsFor: 'updating' stamp: 'RAA 8/4/1999 17:39'!
update: aSymbol 

	aSymbol == getSelectionSelector ifTrue:
		[self selection: self getCurrentSelectionItem.
		^ self].
	aSymbol == getListSelector ifTrue: 
		[self list: self getList.
		^ self].
	((aSymbol isKindOf: Array) and: [aSymbol size > 0 and: [aSymbol first == #openPath]]) ifTrue: [
		^(scroller submorphs at: 1 ifAbsent: [^self]) openPath: aSymbol allButFirst
	].

! !


!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:49'!
addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent

	| priorMorph newCollection firstAddition |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	firstAddition _ nil.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: newIndent.
		firstAddition ifNil: [firstAddition _ priorMorph].
		morphList add: priorMorph.
		((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
			priorMorph isExpanded: true.
			priorMorph 
				addChildrenForList: self 
				addingTo: morphList
				withExpandedItems: expandedItems.
		].
	].
	^firstAddition
	
! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 19:15'!
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean

	| priorMorph morphList newCollection |
	priorMorph _ nil.
	newCollection _ (sortBoolean and: [sortingSelector notNil]) ifTrue: [
		(aCollection asSortedCollection: [ :a :b | 
			(a perform: sortingSelector) <= (b perform: sortingSelector)]) asOrderedCollection
	] ifFalse: [
		aCollection
	].
	morphList _ OrderedCollection new.
	newCollection do: [:item | 
		priorMorph _ self indentingItemClass basicNew 
			initWithContents: item 
			prior: priorMorph 
			forList: self
			indentLevel: parentMorph indentLevel + 1.
		morphList add: priorMorph.
	].
	scroller addAllMorphs: morphList after: parentMorph.
	^morphList
	
! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 11:25'!
adjustSubmorphPositions

	| p h |

	p _ 0@0.
	scroller submorphsDo: [ :each |
		h _ each height.
		each privateBounds: (p extent: 9999@h).
		p _ p + (0@h)
	].
	self 
		changed;
		layoutChanged;
		setScrollDeltas.
! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/24/1998 22:52'!
columns

	^columns! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/18/1998 23:18'!
columns: anArray

	columns _ anArray! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'dew 1/21/2001 16:32'!
expandedForm

	^expandedForm ifNil: [expandedForm _ 
			(Form
				extent: 10@9
				depth: 8
				fromArray: #( 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760)
				offset: 0@0) asFormOfDepth: Display depth.
		expandedForm replaceColor: Color white withColor: Color transparent.
		expandedForm
	].
! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/1998 00:19'!
getCurrentSelectionItem

	^model perform: (getSelectionSelector ifNil: [^nil])
	! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 22:15'!
indentingItemClass
	
	^IndentingListItemMorph! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 4/2/1999 15:33'!
insertNewMorphs: morphList

	scroller addAllMorphs: morphList.
	self adjustSubmorphPositions.
	self selection: self getCurrentSelectionItem.
	self setScrollDeltas.
! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'dew 1/21/2001 16:33'!
notExpandedForm

	^notExpandedForm ifNil: [notExpandedForm _ 
			(Form
				extent: 10@9
				depth: 8
				fromArray: #( 4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760)
				offset: 0@0) asFormOfDepth: Display depth.
		notExpandedForm replaceColor: Color white withColor: Color transparent.
		notExpandedForm
	].! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/2/1999 12:42'!
noteRemovalOfAll: aCollection

	scroller removeAllMorphsIn: aCollection.
	(aCollection includes: selectedMorph) ifTrue: [self setSelectedMorph: nil].! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'dew 11/5/2000 00:15'!
scrollDeltaHeight
	^ scroller firstSubmorph height! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:15'!
selectionOneOf: aListOfItems
	"Set the selection to the first item in the list which is represented by one of my submorphs"

	| index |
	aListOfItems do: [ :item |
		index _ scroller submorphs findFirst: [:m | 
			m withoutListWrapper = item withoutListWrapper
		].
		index > 0 ifTrue: [^self selectionIndex: index].
	].
	self selectionIndex: 0.! !

!SimpleHierarchicalListMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/20/1998 12:09'!
sortingSelector: s

	sortingSelector _ s! !


!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 17:22'!
acceptDroppingMorph: aMorph event: evt

	self model
		acceptDroppingMorph: aMorph
		event: evt
		inMorph: self.
	self resetPotentialDropMorph! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 16:36'!
enableDragNDrop: aBoolean
	super enableDragNDrop: aBoolean.
	aBoolean ifTrue: [self installEventHandlerOn: scroller submorphs]! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:49'!
enableDrop: aBoolean
	super enableDrop: aBoolean.
	aBoolean ifTrue: [self installEventHandlerOn: scroller submorphs]! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/25/2000 17:51'!
installEventHandlerOn: morphList
	| handler |
	handler _ EventHandler new.
	handler on: #mouseDown send: #mouseDown:onItem: to: self.
	self dragEnabled
		ifTrue: [handler
				on: #mouseMove
				send: #mouseStillDown:onItem:
				to: self].
	self dropEnabled
		ifTrue: 
			[handler
				on: #mouseEnterDragging
				send: #mouseEnterDragging:onItem:
				to: self.
			handler
				on: #mouseLeaveDragging
				send: #mouseLeaveDragging:onItem:
				to: self].

	morphList do: [:m | m eventHandler: handler].
! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:39'!
potentialDropMorph
	^potentialDropMorph! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:37'!
potentialDropMorph: aMorph
	potentialDropMorph _ aMorph.
	aMorph highlightForDrop! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/8/2000 15:38'!
resetPotentialDropMorph
	potentialDropMorph ifNotNil: [
		potentialDropMorph resetHighlightForDrop.
		potentialDropMorph _ nil]
! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'mir 5/25/2000 12:58'!
startDrag: evt onItem: itemMorph 
	| ddm |
	evt hand hasSubmorphs
		ifTrue: [^self].

	itemMorph ~= self selectedMorph ifTrue: [self setSelectedMorph: itemMorph].
	ddm _ TransferMorph withPassenger: (self model dragPassengerFor: itemMorph inMorph: self) from: self.
	ddm dragTransferType: (self model dragTransferTypeForMorph: self).
	Preferences dragNDropWithAnimation
			ifTrue: [self model dragAnimationFor: itemMorph transferMorph: ddm].
	evt hand grabMorph: ddm! !

!SimpleHierarchicalListMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 17:38'!
wantsDroppedMorph: aMorph event: anEvent 
	^ self model wantsDroppedMorph: aMorph event: anEvent inMorph: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleHierarchicalListMorph class
	instanceVariableNames: ''!

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: nil
		keystroke: #arrowKey:from:		"default"! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: #arrowKey:from:		"default"
! !

!SimpleHierarchicalListMorph class methodsFor: 'instance creation' stamp: 'di 5/6/1998 21:45'!
on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
	"Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment."

	^ self new
		on: anObject
		list: getListSel
		selected: getSelectionSel
		changeSelected: setSelectionSel
		menu: getMenuSel
		keystroke: keyActionSel
! !
Object subclass: #SimpleMIDIPort
	instanceVariableNames: 'portNumber accessSema lastCommandByteOut '
	classVariableNames: 'DefaultPortNumber InterfaceClockRate '
	poolDictionaries: ''
	category: 'Sound-Scores'!
!SimpleMIDIPort commentStamp: '<historical>' prior: 0!
This is a first cut at a simple MIDI output port.
!


!SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:10'!
close
	"Close this MIDI port."

	portNumber ifNotNil: [self primMIDIClosePort: portNumber].
	accessSema _ nil.
	lastCommandByteOut _ nil.
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:23'!
ensureOpen
	"Make sure this MIDI port is open. It is good to call this before starting to use a port in case an intervening image save/restore has caused the underlying hardware port to get closed."

	portNumber ifNil: [^ self error: 'Use "openOn:" to open a MIDI port initially'].
	self primMIDIClosePort: portNumber.
	self primMIDIOpenPort: portNumber readSemaIndex: 0 interfaceClockRate: InterfaceClockRate.
	accessSema _ Semaphore forMutualExclusion.
	lastCommandByteOut _ Array new: 16 withAll: 0.  "clear running status"
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:09'!
openOnPortNumber: portNum
	"Open this MIDI port on the given port number."

	self close.
	portNumber _ portNum.
	accessSema _ Semaphore forMutualExclusion.
	self ensureOpen.
! !

!SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 10/12/1998 15:48'!
portNumber
	"Answer my port number."

	^ portNumber
! !


!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiCmd: cmd channel: channel byte: dataByte
	"Immediately output the given MIDI command with the given channel and argument byte to this MIDI port. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber
			from: (ByteArray
					with: (cmd bitOr: channel)
					with: dataByte)
			at: 0].
! !

!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiCmd: cmd channel: channel byte: dataByte1 byte: dataByte2
	"Immediately output the given MIDI command with the given channel and argument bytes to this MIDI port. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber
			from: (ByteArray
					with: (cmd bitOr: channel)
					with: dataByte1
					with: dataByte2)
			at: 0].
! !

!SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'!
midiOutput: aByteArray
	"Output the given bytes to this MIDI port immediately. Assume that the port is open."

	accessSema critical: [
		self primMIDIWritePort: portNumber from: aByteArray at: 0].
! !


!SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/8/1998 19:47'!
bufferTimeStampFrom: aByteArray
	"Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long."

	^ ((aByteArray at: 1) bitShift: 24) +
	  ((aByteArray at: 2) bitShift: 16) +
	  ((aByteArray at: 3) bitShift: 8) +
	   (aByteArray at: 4)
! !

!SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/8/1998 19:53'!
flushInput
	"Read any lingering MIDI data from this port's input buffer."

	| buf |
	buf _ ByteArray new: 1000.
	[(self readInto: buf) > 0] whileTrue.
! !

!SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/12/1998 15:49'!
readInto: aByteArray
	"Read any data from this port into the given buffer."

	^ self primMIDIReadPort: portNumber into: aByteArray
! !


!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIClosePort: portNum
	"Close the given MIDI port. Don't fail if port is already closed."

	<primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'>
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate
	"Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms."

	<primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIReadPort: portNum into: byteArray
	"Read any available MIDI data into the given buffer (up to the size of the buffer) and answer the number of bytes read."

	<primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primMIDIWritePort: portNum from: byteArray at: midiClockValue
	"Queue the given data to be sent through the given MIDI port at the given time. If midiClockValue is zero, send the data immediately."

	<primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleMIDIPort class
	instanceVariableNames: ''!

!SimpleMIDIPort class methodsFor: 'class initialization' stamp: 'jm 9/10/1998 15:33'!
initialize
	"SimpleMIDIPort initialize"

	InterfaceClockRate _ 1000000.
	DefaultPortNumber _ 0.
! !


!SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'jm 9/10/1998 18:36'!
openDefault
	"Answer a new instance of me opened on the default MIDI port."

	^ self openOnPortNumber: DefaultPortNumber
! !

!SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'tk 6/24/1999 11:42'!
openOnPortNumber: portNum
	"Answer a new instance of me for the given MIDI port number."
	"Details: All clients of a particular MIDI port should share the same instance of me. This allows accesses to the port to be serialized and shared port-related state state to be maintained."

	SimpleMIDIPort allSubInstancesDo: [:p |
		p portNumber = portNum ifTrue: [
			"share the existing port object for this port number"
			^ p]].

	^ super new openOnPortNumber: portNum
! !


!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 1/13/1999 08:11'!
closeAllPorts
	"Close all MIDI ports."
	"SimpleMIDIPort closeAllPorts"

	| lastPortNum |
	lastPortNum _ self primPortCount - 1.
	0 to: lastPortNum do: [:portNum | self basicNew primMIDIClosePort: portNum].
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:57'!
inputPortNumFromUser
	"Prompt the user for a MIDI input port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
	"SimpleMIDIPort inputPortNumFromUser"

	| portCount aMenu dir |
	portCount _ self primPortCount.
	portCount = 0 ifTrue: [^ nil].
	aMenu _ CustomMenu new title: 'MIDI port for input:'.
	0 to: portCount - 1 do:[:i |
		dir _ self primPortDirectionalityOf: i.
		(dir = 1) | (dir = 3) ifTrue:[
			aMenu add: (self portDescription: i) action: i]].
	 ^ aMenu startUp
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 18:10'!
midiIsSupported
	"Answer true if this platform supports MIDI."

	^ self primPortCount > 0
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:58'!
outputPortNumFromUser
	"Prompt the user for a MIDI output port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
	"SimpleMIDIPort outputPortNumFromUser"

	| portCount aMenu dir |
	portCount _ self primPortCount.
	portCount = 0 ifTrue: [^ nil].
	aMenu _ CustomMenu new title: 'MIDI port for output:'.
	0 to: portCount - 1 do:[:i |
		dir _ self primPortDirectionalityOf: i.
		(dir = 2) | (dir = 3) ifTrue:[
			aMenu add: (self portDescription: i) action: i]].
	 ^ aMenu startUp
! !

!SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:46'!
portDescription: portNum
	"Answer a string indicating the directionality of the given MIDI port."
	"(0 to: SimpleMIDIPort primPortCount - 1) collect:
		[:i | SimpleMIDIPort portDescription: i]"

	| portName dir |
	portName _ self primPortNameOf: portNum.
	dir _ self primPortDirectionalityOf: portNum.
	dir = 1 ifTrue: [^ portName, ' (in)'].
	dir = 2 ifTrue: [^ portName, ' (out)'].
	dir = 3 ifTrue: [^ portName, ' (in/out)'].
	^ self error: 'unknown MIDI port directionality'
! !


!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortCount
	"Answer the number of MIDI ports supported by this platform, or zero if this primitive is not implemented."

	<primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'>
	^ 0
! !

!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortDirectionalityOf: portNum
	"Answer the platform-specific name for the given MIDI port."

	<primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'>
	self primitiveFailed.
! !

!SimpleMIDIPort class methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primPortNameOf: portNum
	"Answer the platform-specific name for the given MIDI port."

	<primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'>
	self primitiveFailed.
! !
Slider subclass: #SimpleSliderMorph
	instanceVariableNames: 'target arguments minVal maxVal truncate '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SimpleSliderMorph methodsFor: 'initialization' stamp: 'jm 1/29/98 16:16'!
initialize

	super initialize.
	target _ nil.
	arguments _ EmptyArray.
	minVal _ 0.0.
	maxVal _ 1.0.
	truncate _ false.
! !


!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:17'!
actionSelector

	^ setValueSelector
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:17'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ setValueSelector _ nil].

	setValueSelector _ aSymbolOrString asSymbol.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 16:17'!
arguments

	^ arguments
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 16:16'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
maxVal

	^ maxVal
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
maxVal: aNumber

	maxVal _ aNumber.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:40'!
minVal

	^ minVal
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/30/98 12:41'!
minVal: aNumber

	minVal _ aNumber.
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:09'!
target

	^ target
! !

!SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 1/29/98 14:09'!
target: anObject

	target _ anObject
! !


!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:39'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'set action selector' action: #setActionSelector.
	aCustomMenu add: 'change arguments' action: #setArguments.
	aCustomMenu add: 'set minimum value' action: #setMinVal.
	aCustomMenu add: 'set maximum value' action: #setMaxVal.
	aCustomMenu addUpdating: #descendingString action: #toggleDescending.
	aCustomMenu addUpdating: #truncateString action: #toggleTruncate.
	((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [
		aCustomMenu add: 'set target' action: #setTarget:].
	target ifNotNil: [
		aCustomMenu add: 'clear target' action: #clearTarget].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:08'!
clearTarget

	target _ nil.
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:38'!
descendingString
	^ self descending
		ifTrue:
			['switch to ascending']
		ifFalse:
			['switch to descending']! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:24'!
setActionSelector

	| oldSel newSel |
	setValueSelector == nil
		ifTrue: [oldSel _ '']
		ifFalse: [oldSel _ setValueSelector].
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this slider is changed'
		initialAnswer: oldSel.
	newSel isEmpty
		ifFalse: [self actionSelector: newSel].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 16:18'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods'
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:05'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please a new label for this button'
		initialAnswer: self label.
	newLabel isEmpty ifFalse: [self label: newLabel].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:41'!
setMaxVal

	| newMaxVal |
	newMaxVal _ FillInTheBlank
		request: 'Maximum value?'
		initialAnswer: maxVal printString.
	newMaxVal isEmpty ifFalse: [
		maxVal _ newMaxVal asNumber.
		minVal _ minVal min: maxVal].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:42'!
setMinVal

	| newMinVal |
	newMinVal _ FillInTheBlank
		request: 'Minimum value?'
		initialAnswer: minVal printString.
	newMinVal isEmpty ifFalse: [
		minVal _ newMinVal asNumber.
		maxVal _ maxVal max: minVal].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/6/2000 17:13'!
setMinVal: newMinVal
	minVal _ newMinVal asNumber.
	maxVal _ maxVal max: minVal
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:07'!
setTarget: evt

	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1
		ifTrue: [target _ rootMorphs at: 2]
		ifFalse: [target _ nil].
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:40'!
toggleDescending

	descending _ self descending not
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'jm 1/29/98 14:46'!
toggleTruncate

	truncate _ truncate not.
! !

!SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 18:37'!
truncateString
	^ truncate
		ifTrue:
			['turn off truncation']
		ifFalse:
			['turn on truncation']! !


!SimpleSliderMorph methodsFor: 'private' stamp: 'jm 1/30/98 13:17'!
adjustToValue: aNumber
	"Adjust the position of this slider to correspond to the given value in the range minVal..maxVal."
	"Details: Internal values are normalized to the range 0..1."

	self value:
		(aNumber - minVal) asFloat / (maxVal - minVal).
! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 9/1/2000 10:38'!
getNumericValue
	"Answer the numeric value of the receiver"

	^ self getScaledValue! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:48'!
getScaledValue
	| aValue |
	aValue _ (value * (maxVal - minVal)) + minVal.
	^ truncate ifTrue: [aValue truncated] ifFalse: [aValue]! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/6/2000 17:19'!
setMaxVal: newMaxVal
	maxVal _ newMaxVal asNumber.
	minVal _ maxVal min: minVal
! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 9/1/2000 10:38'!
setNumericValue: aValue
	"Set the numeric value of the receiver to be as indicated"

	^ self setScaledValue: aValue! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/8/2000 16:22'!
setScaledValue: aNumber
	| denom |
	(denom _ maxVal - minVal) > 0
		ifTrue:
			[self setValue: (aNumber - minVal) / denom]
		ifFalse:
			[self setValue: maxVal]
	"If minVal = maxVal, that value is the only one this (rather unuseful!!) slider can bear"! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'jm 1/29/98 16:18'!
setValue: newValue
	"Update the target with this sliders new value."

	| scaledValue |
	self value: newValue.
	scaledValue _ (newValue * (maxVal - minVal)) + minVal.
	truncate ifTrue: [scaledValue _ scaledValue truncated].
	(target ~~ nil and: [setValueSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target
				perform: setValueSelector
				withArguments: (arguments copyWith: scaledValue)]].
! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:54'!
truncate
	^ truncate == true! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:53'!
truncate: aBoolean
	truncate _ aBoolean! !

!SimpleSliderMorph methodsFor: 'private' stamp: 'jm 1/29/98 16:18'!
updateReferencesUsing: aDictionary
	"Copy and update references in the arguments array during copying."

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !


!SimpleSliderMorph methodsFor: 'copying' stamp: 'tk 1/6/1999 19:24'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!SimpleSliderMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:35'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"arguments _ arguments.		All weakly copied"
minVal _ minVal veryDeepCopyWith: deepCopier.		"will be fast if integer"
maxVal _ maxVal veryDeepCopyWith: deepCopier.
truncate _ truncate veryDeepCopyWith: deepCopier.
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SimpleSliderMorph class
	instanceVariableNames: ''!

!SimpleSliderMorph class methodsFor: 'scripting' stamp: 'sw 9/8/2000 15:29'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
(slider (

(slot numericValue 'A number representing the current position of the knob.' number readWrite player getNumericValue player setNumericValue:)

(slot minVal	 'The number represented when the knob is at the left or top of the slider; the smallest value returned by the slider.' number readWrite	player getMinVal player setMinVal:)

(slot maxVal 'The number represented when the knob is at the right or bottom of the slider; the largest value returned by the slider.' number readWrite	player getMaxVal player setMaxVal:)

(slot descending 'Tells whether the smallest value is at the top/left (descending = false) or at the bottom/right (descending = true)' boolean readWrite player getDescending player setDescending:)

(slot truncate 'If true, only whole numbers are used as values; if false, fractional values are allowed.' boolean readWrite	player getTruncate player setTruncate:)

(slot color 'The color of the slider' color readWrite player getColor  player  setColor:)

(slot knobColor 'The color of the slider' color readWrite player getKnobColor player setKnobColor:)
(slot  width  'The width' number readWrite player getWidth  player  setWidth:)
(slot  height  'The height' number readWrite player getRight  player  setHeight:)))

(basic	(
(slot numericValue 'A number representing the current position of the knob.' number readWrite player getNumericValue player setNumericValue:))))

! !

!SimpleSliderMorph class methodsFor: 'scripting' stamp: 'sw 3/10/2000 13:45'!
authoringPrototype
	| aSlider nominalColor |
	"self currentHand attachMorph: SimpleSliderMorph authoringPrototype"

	aSlider _ super authoringPrototype beSticky.
	aSlider extent: 14@120.
	nominalColor _ Color r: 0.4 g: 0.86 b: 0.7.
	aSlider color: nominalColor.
	aSlider sliderColor: nominalColor muchLighter.
	aSlider descending: true.
	aSlider setScaledValue: 0.3.
	^ aSlider! !

!SimpleSliderMorph class methodsFor: 'scripting' stamp: 'sw 3/8/2000 12:56'!
defaultNameStemForInstances
	"Answer a basis for names of default instances of the receiver"
	^ 'Slider'! !
SimpleButtonMorph subclass: #SimpleSwitchMorph
	instanceVariableNames: 'onColor offColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/30/98 14:01'!
doButtonAction
	"Perform the action of this button. The last argument of the message sent to the target is the new state of this switch."

	| newState |
	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		newState _ color = onColor.
		target
			perform: actionSelector
			withArguments: (arguments copyWith: newState)].
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:44'!
initialize

	^ self initializeWithLabel: 'Toggle'
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:43'!
initializeWithLabel: labelString

	super initializeWithLabel: labelString.
	self borderWidth: 3.
	self extent: self extent + 2.
	onColor _ Color r: 1.0 g: 0.6 b: 0.6.
	offColor _ Color lightGray.
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/30/98 13:58'!
mouseDown: evt

	oldColor _ color.
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/30/98 13:55'!
mouseMove: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [self setSwitchState: (oldColor = offColor)]
		ifFalse: [self setSwitchState: (oldColor = onColor)].
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/30/98 13:58'!
mouseUp: evt

	(self containsPoint: evt cursorPoint)
		ifTrue: [  "toggle and do action"
			self setSwitchState: (oldColor = offColor).
			self doButtonAction]
		ifFalse: [  "restore old appearance"
			self setSwitchState: (oldColor = onColor)].
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/29/98 20:18'!
offColor

	^ offColor
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/29/98 20:18'!
offColor: aColor

	offColor _ aColor.
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/29/98 20:18'!
onColor

	^ onColor
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/29/98 20:18'!
onColor: aColor

	onColor _ aColor.
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/30/98 13:51'!
setSwitchState: aBoolean

	aBoolean
		ifTrue: [
			self borderColor: #inset.
			self color: onColor]
		ifFalse: [
			self borderColor: #raised.
			self color: offColor].
! !

!SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/29/98 16:15'!
updateReferencesUsing: aDictionary
	"Copy and update references in the arguments array during copying."

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !
TextContainer subclass: #SimplerTextContainer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Outliner'!

!SimplerTextContainer methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 13:09'!
bottom

	^textMorph owner bottom! !

!SimplerTextContainer methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:45'!
left 
	^ textMorph owner textMorphLeft! !

!SimplerTextContainer methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 14:46'!
rectanglesAt: lineY height: lineHeight
	"Return a list of rectangles that are at least minWidth wide
	in the specified horizontal strip of the shadowForm.
	Cache the results for later retrieval if the owner does not change."
	| rects |

	lineY > textMorph owner bottom ifTrue: [^#()].
	rects _ Array with: (self left@lineY extent: textMorph width@lineHeight).
	"rects _ rects collect: [:r | r insetBy: OuterMargin@0]."
	^ rects! !

!SimplerTextContainer methodsFor: 'as yet unclassified' stamp: 'RAA 7/30/2000 13:09'!
top

	^textMorph owner top! !
ServerAction subclass: #SinglePlugServerAction
	instanceVariableNames: 'processBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!SinglePlugServerAction commentStamp: '<historical>' prior: 0!
When asked to process: a Web request, this ServerAction simply executes its processBlock -- the simplest possible server action. It is the responsibility of the block to send a reply: to the request.!


!SinglePlugServerAction methodsFor: 'URL processing' stamp: 'mjg 11/10/97 09:00'!
process: request
	processBlock value: request.! !


!SinglePlugServerAction methodsFor: 'accessing' stamp: 'mjg 11/10/97 09:00'!
processBlock: aBlock
	processBlock := aBlock.
! !
Morph subclass: #SketchEditorMorph
	instanceVariableNames: 'hostView palette ticksToDwell rotationCenter registrationPoint newPicBlock emptyPicBlock paintingForm dimForm formCanvas rotationButton scaleButton cumRot cumMag undoBuffer enclosingPasteUpMorph forEachHand '
	classVariableNames: 'SketchTimes '
	poolDictionaries: ''
	category: 'Morphic-Support'!
!SketchEditorMorph commentStamp: '<historical>' prior: 0!
Inst vars (converting to morphic events)
hostView -- SketchMorph we are working on.
stampForm -- Stamp is stored here.
canvasRectangle -- later use bounds
palette -- the PaintBox interface Morph
dirty -- not used
currentColor 
ticksToDwell rotationCenter registrationPoint 
newPicBlock -- do this after painting
action -- selector of painting action
paintingForm -- our copy
composite -- now paintArea origin.  world relative.  stop using it.
dimForm -- SketchMorph of the dimmed background.  Opaque.  
		installed behind the editor morph.
buff 
brush -- 1-bit Form of the brush, 
paintingFormPen 
formCanvas -- Aim it at paintingForm to allow it to draw ovals, rectangles, lines, etc.
picToComp dimToComp compToDisplay -- used to composite -- obsolete
picToBuff brushToBuff buffToBuff buffToPic 
rotationButton scaleButton -- submorphs, handles to do these actions.
strokeOrigin -- During Pickup, origin of rect. 
cumRot cumMag -- cumulative for multiple operations from same original
undoBuffer 
lastEvent 
currentNib -- 1 bit deep form.


For now, we do not carry the SketchMorph's registration point, rotation center, or ticksToDwell.

New -- using transform morphs to rotate the finished player.  How get it rotated back and the rotationDegrees to be right?  We cancel out rotationDegrees, so how remember it?

Registration point convention:  
In a GraphicFrame, reg point is relative to this image's origin.
During painting, it is relative to canvasRectangle origin, and thus us absolute within the canvas.  To convert back, subract newBox origin.

Be sure to convert back and forth correctly.  In deliverPainting. initializeFromFrame:inView: !


!SketchEditorMorph methodsFor: 'initialization' stamp: 'RAA 8/31/2000 13:51'!
initialize

	super initialize.
	color _ Color white alpha: 0.5.! !

!SketchEditorMorph methodsFor: 'initialization' stamp: 'tk 8/21/2000 14:54'!
initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph
	| aPaintBox newPaintBoxBounds worldBounds requiredWidth newOrigin aPosition aPal aTab paintBoxFullBounds |
	(aTab _ self world paintingFlapTab) ifNotNil:
		[aTab showFlap.
		^ self initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: nil].

	aPaintBox _ self world paintBox.
	worldBounds _ self world bounds.
	requiredWidth _ aPaintBox width.

	aPosition _ (aPal _ aPasteUpMorph standardPalette)
		ifNotNil:
			[aPal showNoPalette.
			aPal topRight + (aPaintBox width negated @ 0 "aPal tabsMorph height")]
		ifNil:
			[boundsToUse topRight].

	newOrigin _ ((aPosition x  + requiredWidth <= worldBounds right) or: [Preferences unlimitedPaintArea])
			ifTrue:  "will fit to right of aPasteUpMorph"
				[aPosition]
			ifFalse:  "won't fit to right, try left"
				[boundsToUse topLeft - (requiredWidth @ 0)].
	paintBoxFullBounds _ aPaintBox maxBounds.
	paintBoxFullBounds _ (newOrigin - aPaintBox offsetFromMaxBounds) extent: 
					paintBoxFullBounds extent.
	newPaintBoxBounds _ paintBoxFullBounds translatedToBeWithin: worldBounds.
	

	self initializeFor: aSketchMorph inBounds: boundsToUse 
		pasteUpMorph: aPasteUpMorph 
		paintBoxPosition: newPaintBoxBounds origin + aPaintBox offsetFromMaxBounds.! !

!SketchEditorMorph methodsFor: 'initialization' stamp: 'jcg 11/19/2000 18:00'!
initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: aPosition
	"NB: if aPosition is nil, then it's assumed that the paintbox is obtained from a flap or some such, so do nothing special regarding a palette in this case.  The palette needs already to be in the world for this to work."
	| w  |
	(w _ aPasteUpMorph world) addMorphFront: self.
	enclosingPasteUpMorph _ aPasteUpMorph.
	hostView _ aSketchMorph.  "may be ownerless"
	self bounds: boundsToUse.
	palette _ w paintBox focusMorph: self.
	palette beStatic.		"give Nebraska whatever help we can"
	palette fixupButtons.
	palette addWeakDependent: self.
	aPosition ifNotNil:
		[w addMorphFront: palette.  "bring to front"
		palette position: aPosition].
	paintingForm _ Form extent: bounds extent depth: w assuredCanvas depth.
	self dimTheWindow.
	self addRotationScaleHandles.
	aSketchMorph ifNotNil:
		[
		aSketchMorph form
			displayOn: paintingForm
			at: (hostView boundsInWorld origin - bounds origin - hostView form offset)
			clippingBox: (0@0 extent: paintingForm extent)
			rule: Form over
			fillColor: nil.  "assume they are the same depth"
		rotationCenter _ aSketchMorph rotationCenter]! !


!SketchEditorMorph methodsFor: 'morphic' stamp: 'RAA 8/31/2000 13:49'!
drawOn: aCanvas
	"Put the painting on the display"

	color isTransparent ifFalse: [
		aCanvas fillRectangle: bounds color: color
	].
	paintingForm ifNotNil: [
		aCanvas paintImage: paintingForm at: bounds origin].

 ! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'jm 7/28/97 11:49'!
handlesMouseDown: evt

	^ true
! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'ar 10/29/2000 21:13'!
mouseDown: evt
	"Start a new stroke.  Check if any palette setting have changed.  6/11/97 20:30 tk"
	| cur pfPen myAction |
	"verify that we are in a good state"
	self verifyState: evt.		"includes prepareToPaint and #scalingOrRotate"
	pfPen _ self get: #paintingFormPen for: evt.
	undoBuffer _ paintingForm deepCopy.	"know we will draw something"
	pfPen place: (evt cursorPoint - bounds origin).
	myAction _ self getActionFor: evt.
	myAction == #paint: ifTrue:[
		palette recentColor: (self getColorFor: evt)].
	self set: #strokeOrigin for: evt to: evt cursorPoint.
		"origin point for pickup: rect: ellispe: polygon: line: star:.  Always take it."
	myAction == #pickup: ifTrue: [
		cur _ Cursor corner clone.
		cur offset: 0@0  "cur offset abs".
		evt hand showTemporaryCursor: cur].
	myAction == #polygon: ifTrue: [self polyNew: evt].	"a mode lets you drag vertices"
	self mouseMove: evt.! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'ar 10/5/2000 16:07'!
mouseEnter: evt
	"Set the cursor.  Reread colors if embedded editable polygon needs it."

	| poly cColor |
	super mouseEnter: evt.
	self flag: #arNote. "What is that code below doing???"
	(self get: #action for: evt) == #scaleOrRotate ifTrue: [
		self set: #action for: evt to: (self get: #priorAction for: evt).
	].
	evt hand showTemporaryCursor: (self getCursorFor: evt).
	palette getSpecial == #polygon: ifFalse: [^self].
	(poly _ self valueOfProperty: #polygon) ifNil: [^ self].
	cColor _ self getColorFor: evt.
	poly color: cColor; borderWidth: 1.
	poly changed.! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'di 9/14/1998 08:07'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'jm 5/22/1998 10:15'!
mouseLeave: evt
	"Revert to the normal hand cursor."

	super mouseLeave: evt.
	evt hand showTemporaryCursor: nil.  "back to normal"
	"If this is modified to close down the SketchEditorMorph in any way, watch out for how it is called when entering a rotationButton and a scaleButton."
! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'ar 12/19/2000 00:20'!
mouseMove: evt
	"In the middle of drawing a stroke.  6/11/97 19:51 tk"

	| pt priorEvt |

	WorldState canSurrenderToOS: false.		"we want maximum responsiveness"
	pt _ evt cursorPoint.
	priorEvt _ self get: #lastEvent for: evt.
	(priorEvt ~~ nil and: [pt = priorEvt cursorPoint]) ifTrue: [^ self].
	self perform: (self getActionFor: evt) with: evt.
		"Each action must do invalidRect:"
	self set: #lastEvent for: evt to: evt.
	false ifTrue: ["So senders will find the things performed here"
		self paint: nil; fill: nil; erase: nil; pickup: nil; stamp: nil.
		self rect: nil; ellipse: nil; polygon: nil; line: nil; star: nil].! !

!SketchEditorMorph methodsFor: 'morphic' stamp: 'ar 12/19/2000 00:20'!
mouseUp: evt
	| myAction |
	"Do nothing except those that work on mouseUp."

	myAction _ self getActionFor: evt.
	myAction == #fill: ifTrue: [
		self perform: myAction with: evt.
		"Each action must do invalidRect:"
		].
	myAction == #pickup: ifTrue: [
		self pickupMouseUp: evt].
	myAction == #polygon: ifTrue: [self polyEdit: evt].	"a mode lets you drag vertices"
	self set: #lastEvent for: evt to: nil.
! !


!SketchEditorMorph methodsFor: 'access' stamp: 'sw 9/2/1999 11:03'!
enclosingPasteUpMorph
	^ enclosingPasteUpMorph! !

!SketchEditorMorph methodsFor: 'access' stamp: 'ar 9/22/2000 20:35'!
forwardDirection
	"The direction object will go when issued a sent forward:.  Up is
zero.  Clockwise like a compass.  From the arrow control."
	^ hostView forwardDirection! !

!SketchEditorMorph methodsFor: 'access'!
hostView
	^ hostView! !

!SketchEditorMorph methodsFor: 'access'!
painting
	^ paintingForm! !

!SketchEditorMorph methodsFor: 'access'!
palette
	^palette! !

!SketchEditorMorph methodsFor: 'access'!
registrationPoint
	^ registrationPoint! !

!SketchEditorMorph methodsFor: 'access'!
registrationPoint: aPoint
	registrationPoint _ aPoint! !

!SketchEditorMorph methodsFor: 'access' stamp: 'tk 9/3/97 17:12'!
rotationStyle

^ (self valueOfProperty: #rotationStyle) ifNil: [#normal]! !

!SketchEditorMorph methodsFor: 'access'!
ticksToDwell
	ticksToDwell == nil ifTrue: [ticksToDwell _ 1].
	^ ticksToDwell! !

!SketchEditorMorph methodsFor: 'access'!
ticksToDwell: t
	ticksToDwell _ t! !


!SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 10/25/2000 17:51'!
addRotationScaleHandles

	"Rotation and scaling handles"

	rotationButton _ SketchMorph withForm: (palette rotationTabForm).
	rotationButton position: bounds topCenter - (6@0).
	rotationButton on: #mouseDown send: #rotateScalePrep: to: self.
	rotationButton on: #mouseMove send: #rotateBy: to: self.
	rotationButton on: #mouseUp send: #rotateDone: to: self.
	rotationButton on: #mouseEnter send: #mouseLeave: to: self.
	"Put cursor back"
	rotationButton on: #mouseLeave send: #mouseEnter: to: self.
	self addMorph: rotationButton.
	rotationButton setBalloonText: 'Drag me sideways to\rotate your
picture.' withCRs.

	scaleButton _ SketchMorph withForm: (palette scaleTabForm).
	scaleButton position: bounds rightCenter - ((scaleButton width)@6).
	scaleButton on: #mouseDown send: #rotateScalePrep: to: self.
	scaleButton on: #mouseMove send: #scaleBy: to: self.
	scaleButton on: #mouseEnter send: #mouseLeave: to: self.
	"Put cursor back"
	scaleButton on: #mouseLeave send: #mouseEnter: to: self.
	self addMorph: scaleButton.
	scaleButton setBalloonText: 'Drag me up and down to change\the size
of your picture.' withCRs.

"REMOVED:
	fwdButton _ PolygonMorph new.
	pt _ bounds topCenter.
	fwdButton borderWidth: 2; makeOpen; makeBackArrow; borderColor:
(Color r: 0 g: 0.8 b: 0).
	fwdButton removeHandles; setVertices: (Array with: pt+(0@7) with:
pt+(0@22)).
	fwdButton on: #mouseMove send: #forward:direction: to: self.
	fwdButton on: #mouseEnter send: #mouseLeave: to: self.	
	fwdButton on: #mouseLeave send: #mouseEnter: to: self.
	self setProperty: #fwdButton toValue: fwdButton.
	self addMorph: fwdButton.
	fwdButton setBalloonText: 'Drag me around to point\in the direction
I go forward.' withCRs.

	toggle _ EllipseMorph
		newBounds: (Rectangle center: fwdButton vertices last +
(-4@4) extent: 8@8)
		color: Color gray.
	toggle on: #mouseUp send: #toggleDirType:in: to: self.
	toggle on: #mouseEnter send: #mouseLeave: to: self.
	toggle on: #mouseLeave send: #mouseEnter: to: self.
	self setProperty: #fwdToggle toValue: toggle.
	fwdButton addMorph: toggle.
	toggle setBalloonText: 'When your object turns,\how should its
picture change?\It can rotate, face left or right,\face up or down, or not
change.' withCRs.
	"
	self setProperty: #rotationStyle toValue: hostView rotationStyle.
"	self forward: hostView setupAngle direction: fwdButton.	"
	"Set to its current value"

! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 10/28/97 15:31'!
afterNewPicDo: goodBlock ifNoBits: badBlock
	"If the user said 'Save' at the end of drawing, do this block to save the picture.
goodBlock takes 2 args, the painted form and the bounding rectangle of its bits.
badBlock takes no args.  "

	newPicBlock _ goodBlock.
	emptyPicBlock _ badBlock.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 01:46'!
cancel: evt
	"Palette is telling us that the use wants to end the painting session.  "

	Cursor blank show.
	self deliverPainting: #cancel evt: evt.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 9/2/1999 12:54'!
cancelOutOfPainting
	self deleteSelfAndSubordinates.
	emptyPicBlock ifNotNil: [emptyPicBlock value].	"note no args to block!!"
	hostView ifNotNil: [hostView changed].
	^ nil! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 9/2/1999 12:54'!
deleteSelfAndSubordinates
	"Delete the receiver and, if it has one, its subordinate dimForm"
	self delete.
	dimForm ifNotNil: [dimForm delete]! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 12/19/2000 00:20'!
deliverPainting: result evt: evt
	"Done painting.  May come from resume, or from original call.  Execute user's post painting instructions in the block.  Always use this standard one.  4/21/97 tk"

	| newBox newForm ans |
	palette ifNotNil: "nil happens" [palette setAction: #paint: evt: evt].	"Get out of odd modes"
	"rot _ palette getRotations."	"rotate with heading, or turn to and fro"
	"palette setRotation: #normal."
	result == #cancel ifTrue: [
		ans _ PopUpMenu withCaption: 'Do you really want to throw away 
what you just painted?' 
				chooseFrom: 'throw it away\keep painting it'.
		^ ans = 1 ifTrue: [self cancelOutOfPainting]
				ifFalse: [nil]].	"for Morphic"

	"hostView rotationStyle: rot."		"rotate with heading, or turn to and fro"
	newBox _ paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	registrationPoint ifNotNil:
		[registrationPoint _ registrationPoint - newBox origin]. "relative to newForm origin"
	newForm _ 	Form extent: newBox extent depth: paintingForm depth.
	newForm copyBits: newBox from: paintingForm at: 0@0 
		clippingBox: newForm boundingBox rule: Form over fillColor: nil.
	newForm isAllWhite ifTrue: [
		(self valueOfProperty: #background) == true 
			ifFalse: [^ self cancelOutOfPainting]].

	self delete.	"so won't find me again"
	dimForm ifNotNil: [dimForm delete].
	newPicBlock value: newForm value: (newBox copy translateBy: bounds origin).
! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'di 7/3/1998 14:25'!
handlesDragOver: evt
	^true! !

!SketchEditorMorph methodsFor: 'start & finish'!
handlesMouseOver: evt
	^true! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt
	^true! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:28'!
prepareToPaint: evt
	"Figure out what the current brush, fill, etc is.  Return an action to take every mouseMove.  Set up instance variable and pens.  Prep for normal painting is inlined here.  tk 6/14/97 21:11"

	| specialMode pfPen cColor cNib myBrush |
	"Install the brush, color, (replace mode), and cursor."
	specialMode _ self getActionFor: evt.
 	cColor  _ self getColorFor: evt.
	cNib _ self getNibFor: evt.
	self set: #brush for: evt to: (myBrush _ cNib).
	self set: #paintingFormPen for: evt to: (pfPen _ Pen newOnForm: paintingForm).
	self set: #stampForm for: evt to: nil.	"let go of stamp"
	formCanvas _ paintingForm getCanvas.	"remember to change when undo"
	formCanvas _ formCanvas
		copyOrigin: self topLeft negated
		clipRect: (0@0 extent: bounds extent).

	specialMode == #paint: ifTrue: [
		"get it to one bit depth.  For speed, instead of going through a colorMap every time ."
		self set: #brush for: evt to: (myBrush _ Form extent: myBrush extent depth: 1).
		myBrush offset: (0@0) - (myBrush extent // 2).
		cNib displayOn: myBrush at: (0@0 - cNib offset).

		pfPen sourceForm: myBrush.
		pfPen combinationRule: Form paint.
		pfPen color: cColor.
		cColor isTransparent ifTrue: [
			pfPen combinationRule: Form erase1bitShape.
			pfPen color: Color black].
		^ #paint:].

	specialMode == #erase: ifTrue: [
		self erasePrep: evt.
		^ #erase:].
	specialMode == #stamp: ifTrue: [
		self set: #stampForm for: evt to: palette stampForm.	"keep it"
		^ #stamp:].

	(self respondsTo: specialMode) 
		ifTrue: [^ specialMode]	"fill: areaFill: pickup: (in mouseUp:) 
				rect: ellipse: line: polygon: star:"
		ifFalse: ["Don't recognise the command"
			palette setAction: #paint: evt: evt.	"set it to Paint"
			^ self prepareToPaint: evt].! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:14'!
save: evt
	"Palette is telling us that the use wants to end the painting session.  "

	Cursor blank show.
	(self getActionFor: evt) == #polygon: ifTrue: [self polyFreeze].		"end polygon mode"
	^ self deliverPainting: #okay evt: evt.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'tk 4/3/97'!
setRotations: num
	"Tell the palette what number of rotations (or background) to show.  "

	| key |
	key _ 'ItTurns'.	"default and value for num > 1"
	num == 1 ifTrue: [key _ 'JustAsIs'].
	num == 18 ifTrue: [key _ 'ItTurns'].
	num == 99 ifTrue: [key _ 'ToAndFro'].
	num == #Background ifTrue: [key _ 'Background'].
	num == #Repeated ifTrue: [key _ 'Repeated'].
	palette setRotations: (palette contentsAtKey: key).! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'RAA 8/16/2000 11:18'!
undo: evt
	"revert to a previous state.  "

	| temp poly |

	self flag: #bob.		"what is undo in multihand environment?"
	undoBuffer ifNil: [^ self beep].	"nothing to go back to"
	(poly _ self valueOfProperty: #polygon) ifNotNil:
		[poly delete.
		self setProperty: #polygon toValue: nil.
		^ self].
	temp _ paintingForm.
	paintingForm _ undoBuffer.
	undoBuffer _ temp.		"can get back to what you had by undoing again"
	(self get: #paintingFormPen for: evt) setDestForm: paintingForm.
	formCanvas _ paintingForm getCanvas.	"used for lines, ovals, etc."
	formCanvas _ formCanvas
		copyOrigin: self topLeft negated
		clipRect: (0@0 extent: bounds extent).
	self render: bounds.! !

!SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 10/10/2000 16:47'!
verifyState: evt
	| myAction |
	"We are sure we will make a mark now.  Make sure the palette has not changed state while we were away.  If so, end this action and start another one.  6/11/97 19:52 tk  action, currentColor, brush"

	"Install the brush, color, (replace mode), and cursor."
	palette isInWorld ifFalse:
		[self world addMorphFront: palette].  "It happens.  might want to position it also"
	myAction _ self getActionFor: evt.
	(self get: #changed for: evt) == false ifFalse: [
		self set: #changed for: evt to: false.
		self invalidRect: rotationButton bounds.	"snap these back"
		rotationButton position: bounds topCenter - (6@0).		"later adjust by button width?"
		self invalidRect: rotationButton bounds.
		self invalidRect: scaleButton bounds.
		scaleButton position: bounds rightCenter - ((scaleButton width)@6).
		self invalidRect: scaleButton bounds.
		myAction == #polygon: ifFalse: [self polyFreeze].		"end polygon mode"
		^ self set: #action for: evt to: (self prepareToPaint: evt)].

! !


!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 10/21/97 16:32'!
clear
	"wipe out all the paint"

	self polyFreeze.		"end polygon mode"
	paintingForm fillWithColor: Color transparent.
	self invalidRect: bounds.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:55'!
ellipse: evt
	"Draw an ellipse from the center. "

	| rect oldRect ww ext oldExt cColor sOrigin priorEvt |

	sOrigin _ self get: #strokeOrigin for: evt.
	cColor _ self getColorFor: evt.
	ext _ (sOrigin - evt cursorPoint) abs * 2.
	evt shiftPressed ifTrue: [ext _ ext r].
	rect _ Rectangle center: sOrigin extent: ext.
	ww _ (self getNibFor: evt) width.
	(priorEvt _ self get: #lastEvent for: evt) ifNotNil: [
		oldExt _ (sOrigin - priorEvt cursorPoint) abs + ww * 2.
		priorEvt shiftPressed ifTrue: [oldExt _ oldExt r].
		(oldExt < ext) ifFalse: ["Last draw sticks out, must erase the area"
			oldRect _ Rectangle center: sOrigin extent: oldExt.
			self restoreRect: oldRect]].
	cColor == Color transparent
	ifFalse:[
	formCanvas fillOval: rect color: cColor 
		borderWidth: 0 borderColor: Color transparent.]
	ifTrue:[
	formCanvas fillOval: rect color: cColor 
		borderWidth: ww borderColor: Color black].
	self invalidRect: rect.

! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 7/2/97 09:02'!
erase: evt
	"Pen is set up to draw transparent squares"
	self paint: evt
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:30'!
erasePrep: evt
	"Transparent paint, square brush.  Be careful not to let this be undone by asking palette for brush and color."

	| size pfPen myBrush |

	pfPen _ self get: #paintingFormPen for: evt.
	size _ (self getNibFor: evt) width.
	self set: #brush for: evt to: (myBrush _ Form extent: size@size depth: 1).
	myBrush offset: (0@0) - (myBrush extent // 2).
	myBrush fillWithColor: Color black.
	pfPen sourceForm: myBrush.
	"transparent"
	pfPen combinationRule: Form erase1bitShape.
	pfPen color: Color black.
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 12/19/2000 19:53'!
fill: evt 
	"Find the area that is the same color as where you clicked. Fill it with 
	the current paint color."
	| box |
	evt isMouseUp
		ifFalse: [^ self].
	"Only fill upon mouseUp"
	"would like to only invalidate the area changed, but can't find out what it is."
	Cursor execute
		showWhile: [
			box _ paintingForm
				floodFill: (self getColorFor: evt)
				at: evt cursorPoint - bounds origin.
			self render: (box translateBy: bounds origin)]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
flipHoriz: evt 
	"Flip the image"
	| temp myBuff |

	myBuff _ self get: #buff for: evt.
	temp _ myBuff deepCopy flipBy: #horizontal centerAt: myBuff center.
	temp offset: 0 @ 0.
	paintingForm fillWithColor: Color transparent.
	temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
flipVert: evt 
	"Flip the image"
	| temp myBuff |

	myBuff _ self get: #buff for: evt.
	temp _ myBuff deepCopy flipBy: #vertical centerAt: myBuff center.
	temp offset: 0 @ 0.
	paintingForm fillWithColor: Color transparent.
	temp displayOn: paintingForm at: paintingForm center - myBuff center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 7/30/1998 17:30'!
forward: evt direction: button
	"Move the forward direction arrow of this painting.  When the user
says forward:, the object moves in the direction of the arrow.  evt may be
an Event (from the user moving the arrow), or an initial number ofdegrees."

	| center dir ww ff |
	center _ bounds center "+ (rotationButton width - 6 @ 0)".
	evt isNumber ifTrue: [dir _ Point r: 100 degrees: evt - 90.0
"convert to 0 on X axis"]
		ifFalse: [dir _ evt cursorPoint - center].
	ww _ (bounds height min: bounds width)//2 - 7.
	button setVertices: (Array
		with: (center + (Point r: ww degrees: dir degrees))
		with: (center + (Point r: ww-15 degrees: dir degrees))).
	(ff _ self valueOfProperty: #fwdToggle) position:
		(center + (Point r: ww-7 degrees: dir degrees + 6.5)) - (ff
extent // 2).
	self showDirType.
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:54'!
line: evt 
	"Draw a line on the paintingForm using formCanvas aimed at it."
	| rect oldRect ww now diff cor cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	rect _ sOrigin rect: (now _ evt cursorPoint).
	evt shiftPressed
		ifTrue: [diff _ evt cursorPoint - sOrigin.
			now _ sOrigin
						+ (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45).
			rect _ sOrigin rect: now].
	ww _ (self getNibFor: evt) width.
	(priorEvt _ self get: #lastEvent for: evt)
		ifNotNil: [oldRect _ sOrigin rect: priorEvt cursorPoint.
			priorEvt shiftPressed
				ifTrue: [diff _ priorEvt cursorPoint - sOrigin.
					cor _ sOrigin
								+ (Point r: diff r degrees: diff degrees + 22.5 // 45 * 45).
					oldRect _ sOrigin rect: cor].
			oldRect _ oldRect expandBy: ww @ ww.
			"Last draw will always stick out, must erase the area"
			self restoreRect: oldRect].
	cColor _ self getColorFor: evt.
	formCanvas
		line: sOrigin
		to: now
		width: ww
		color: cColor.
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps'!
notes
	"
Singleton costumes.
Registration points
"! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:22'!
paint: evt
	"While the mouse is down, lay down paint, but only within window bounds.
	 11/28/96 sw: no longer stop painting when pen strays out of window; once it comes back in, resume painting rather than waiting for a mouse up"

	|  mousePoint startRect endRect startToEnd pfPen myBrush |

	pfPen _ self get: #paintingFormPen for: evt.
	myBrush _ self getBrushFor: evt.
	mousePoint _ evt cursorPoint.
	startRect _ pfPen location + myBrush offset extent: myBrush extent.
	pfPen goto: mousePoint - bounds origin.
	endRect _ pfPen location + myBrush offset extent: myBrush extent.
	"self render: (startRect merge: endRect).	Show the user what happened"
	startToEnd _ startRect merge: endRect.
	self invalidRect: (startToEnd translateBy: bounds origin).
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:57'!
pickup: evt
	"Grab a part of the picture (or screen) and store it in a known place.  Note where we started.  Use a rubberband rectangle to show what is being selected."

	| rect oldRect sOrigin priorEvt |

	sOrigin _ self get: #strokeOrigin for: evt.
	rect _ sOrigin rect: evt cursorPoint + (14@14).
	(priorEvt _ self get: #lastEvent for: evt) == nil ifFalse: [
			"Last draw will stick out, must erase the area"
			oldRect _ sOrigin rect: priorEvt cursorPoint + (14@14).
			self restoreRect: (oldRect insetBy: -2)].
	formCanvas frameAndFillRectangle: (rect insetBy: -2) fillColor: Color transparent
		borderWidth: 2 borderColor: Color gray.
	self invalidRect: (rect insetBy: -2).! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/17/2000 15:00'!
pickupMouseUp: evt
	"Grab a part of the picture (or screen) and store it in a known place. Like Copy on the Mac menu. Then switch to the stamp tool."

	| rr pForm ii oldRect sOrigin priorEvt |

	sOrigin _ self get: #strokeOrigin for: evt.
	(priorEvt _ self get: #lastEvent for: evt) == nil ifFalse: [
			"Last draw will stick out, must erase the area"
			oldRect _ sOrigin rect: priorEvt cursorPoint + (14@14).
			self restoreRect: (oldRect insetBy: -2)].
	self primaryHand showTemporaryCursor: nil.	"later get rid of this"	
	rr _ sOrigin rect: evt cursorPoint + (14@14).
	ii _ rr translateBy: (0@0) - bounds origin.
	(rr intersects: bounds) ifTrue: [
		pForm _ paintingForm copy: ii.
		pForm isAllWhite "means transparent" 
			ifFalse: []	"normal case.  Can be transparent in parts"
			ifTrue: [pForm _ nil.
			"Get an un-dimmed picture of other objects on the playfield"
			"don't know how yet"]].
	pForm ifNil: [pForm _ Form fromDisplay: rr].		"Anywhere on the screen"
	palette pickupForm: pForm evt: evt.
	evt hand showTemporaryCursor: (self getCursorFor: evt).
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:40'!
polyEdit: evt
	"Add handles and let user drag'em around"
	| poly |
	poly _ self valueOfProperty: #polygon.
	poly ifNil:[^self].
	poly addHandles.
	self polyEditing: true.
	self setProperty: #polyCursor toValue: palette plainCursor.
	palette plainCursor: Cursor normal event: evt.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'!
polyEditing
	^self valueOfProperty: #polyEditing ifAbsent:[false]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:28'!
polyEditing: aBool
	aBool
		ifTrue:[self setProperty: #polyEditing toValue: aBool]
		ifFalse:[self removeProperty: #polyEditing]! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:29'!
polyFreeze
	"A live polygon is on the painting.  Draw it into the painting and
delete it."

	| poly |
	self polyEditing ifFalse:[^self].
	(poly _ self valueOfProperty: #polygon) ifNil: [^ self].
	poly drawOn: formCanvas.
	poly delete.
	self setProperty: #polygon toValue: nil.
	self polyEditing: false.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:42'!
polyNew: evt
	"Create a new polygon.  Add it to the sketch, and let the user drag
its vertices around!!  Freeze it into the painting when the user chooses
another tool."

	| poly cColor |
	self polyEditing ifTrue:[
		self polyFreeze.
		(self hasProperty: #polyCursor)
			ifTrue:[palette plainCursor: (self valueOfProperty: #polyCursor) event: evt.
					self removeProperty: #polyCursor].
		^self].
	cColor _ self getColorFor: evt.
	self polyFreeze.		"any old one we were working on"
	poly _ PolygonMorph new "addHandles".
	poly referencePosition: poly bounds origin.
	poly align: poly bounds center with: evt cursorPoint.
 	cColor == Color transparent
	ifFalse:[
	poly color: cColor; borderWidth: 0;
	borderColor: Color transparent]
	ifTrue:[
	poly color: cColor; borderWidth: 1;     "still some problems with brushsize !!!!"
	borderColor: Color black].
	self addMorph: poly.
	poly changed.
	self setProperty: #polygon toValue: poly.! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 10/10/2000 16:22'!
polygon: evt
	| poly |
	poly _ self valueOfProperty: #polygon.
	poly ifNil:[^self].
	evt cursorPoint > poly bounds origin ifTrue:[
		poly extent: ((evt cursorPoint - poly bounds origin) max: 5@5)].! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:57'!
rect: evt 
	"While moving corner, just write on the canvas. When done, write 
	on the paintingForm"
	| rect within oldRect now diff cor cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	rect _ sOrigin rect: (now _ evt cursorPoint).
	cColor _ self getColorFor: evt.
	evt shiftPressed
		ifTrue: [diff _ evt cursorPoint - sOrigin.
			now _ sOrigin
						+ (Point r: (diff x abs min: diff y abs)
									* 2 degrees: diff degrees // 90 * 90 + 45).
			rect _ sOrigin rect: now].
	(priorEvt _ self get: #lastEvent for: evt) == nil
		ifFalse: [oldRect _ sOrigin rect: priorEvt cursorPoint.
			priorEvt shiftPressed
				ifTrue: [diff _ priorEvt cursorPoint - sOrigin.
					cor _ sOrigin
								+ (Point r: (diff x abs min: diff y abs)
											* 2 degrees: diff degrees // 90 * 90 + 45).
					oldRect _ sOrigin rect: cor].
			within _ rect containsRect: oldRect.
			within & cColor isTransparent not
				ifFalse: ["Last draw will stick out, must erase the area"
					self restoreRect: oldRect]].
	cColor == Color transparent
		ifTrue: [formCanvas
				frameAndFillRectangle: rect
				fillColor: cColor
				borderWidth: (self getNibFor: evt) width
				borderColor: Color black]
		ifFalse: [formCanvas
				frameAndFillRectangle: rect
				fillColor: cColor
				borderWidth: 0
				borderColor: Color transparent].
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:13'!
render: damageRect
	"Compose the damaged area again and store on the display.  damageRect is relative to paintingForm origin.  3/19/97 tk"

	self invalidRect: damageRect.	"Now in same coords as self bounds"
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 6/16/97 15:38'!
replaceOnly: initialMousePoint
	"Paint replacing only one color!!  Call this each stroke.  Also works for replacing all but one color.  "

! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 2/12/2000 18:35'!
restoreRect: oldRect
	"Restore the given rectangular area of the painting Form from the undo buffer."

	formCanvas drawImage: undoBuffer
		at: oldRect origin
		sourceRect: (oldRect translateBy: self topLeft negated).
	self invalidRect: oldRect.
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:07'!
rotateBy: evt 
	"Left-right is rotation. 3/26/97 tk Slider at top of window. 4/3/97 tk"
	| pt temp amt smooth myBuff |

	myBuff _ self get: #buff for: evt.
	evt cursorPoint x - self left < 20
		ifTrue: [^ self flipHoriz: evt].
	"at left end flip horizontal"
	evt cursorPoint x - self right > -20
		ifTrue: [^ self flipVert: evt].
	"at right end flip vertical"
	pt _ evt cursorPoint - bounds center.
	smooth _ 2.
	"paintingForm depth > 8 ifTrue: [2] ifFalse: [1]."
	"Could go back to 1 for speed"
	amt _ pt x abs < 12
				ifTrue: ["detent"
					0]
				ifFalse: [pt x - (12 * pt x abs // pt x)].
	amt _ amt * 1.8.
	temp _ myBuff
				rotateBy: amt
				magnify: cumMag
				smoothing: smooth.
	temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset.
	rotationButton position: evt cursorPoint x - 6 @ rotationButton position y.
	self render: bounds.
	cumRot _ amt! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: '6/13/97 17:55 '!
rotateDone: evt
	"MouseUp, snap box back to center."

"
self render: rotationButton bounds.
rotationButton position: (canvasRectangle width // 2 + composite x) @ rotationButton position y.
self render: rotationButton bounds.
"		"Not snap back..."! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/29/2000 10:01'!
rotateScalePrep: evt
	"Make a source that is the paintingForm.  Work from that.  3/26/97 tk"

	| newBox myBuff |

	(self getActionFor: evt) == #scaleOrRotate ifTrue: [^ self].	"Already doing it"
	paintingForm width > 120 
		ifTrue: [newBox _ paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent.
			"minimum size"
			newBox _ newBox insetBy: 
				((18 - newBox width max: 0)//2) @ ((18 - newBox height max: 0)//2) * -1]
		ifFalse: [newBox _ paintingForm boundingBox].
	newBox _ newBox expandBy: 1.
	self set: #buff for: evt to: (myBuff _ Form extent: newBox extent depth: paintingForm depth).
	myBuff offset: newBox center - paintingForm center.
	myBuff copyBits: newBox from: paintingForm at: 0@0 
		clippingBox: myBuff boundingBox rule: Form over fillColor: nil.
	"Could just run up owner chain asking colorUsed, but may not be embedded"
	cumRot _ 0.0.  cumMag _ 1.0.	"start over"
	self set: #changed for: evt to: true.
	self set: #action for: evt to: #scaleOrRotate.
		"Only changed by mouseDown with tool in paint area"! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 20:06'!
scaleBy: evt 
	"up-down is scale. 3/26/97 tk Now a slider on the right."
	| pt temp cy oldRect amt myBuff |

	myBuff _ self get: #buff for: evt.
	pt _ evt cursorPoint - bounds center.
	cy _ bounds height * 0.5.
	oldRect _ myBuff boundingBox expandBy: myBuff extent * cumMag / 2.
	amt _ pt y abs < 12
				ifTrue: ["detent"
					1.0]
				ifFalse: [pt y - (12 * pt y abs // pt x)].
	amt _ amt asFloat / cy + 1.0.
	temp _ myBuff
				rotateBy: cumRot
				magnify: amt
				smoothing: 2.
	cumMag > amt
		ifTrue: ["shrinking"
			oldRect _ oldRect translateBy: paintingForm center - oldRect center + myBuff offset.
			paintingForm
				fill: (oldRect expandBy: 1 @ 1)
				rule: Form over
				fillColor: Color transparent].
	temp displayOn: paintingForm at: paintingForm center - temp center + myBuff offset.
	scaleButton position: scaleButton position x @ (evt cursorPoint y - 6).
	self render: bounds.
	cumMag _ amt! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:11'!
showDirType
	"Display the proper symbol for this direction type.  rotationStyle
is one of #(normal leftRight upDown none)."

| rr poly |
rr _ self rotationStyle.
poly _ self valueOfProperty: #fwdButton.
rr == #normal ifTrue: [^ poly makeBackArrow].
rr == #leftRight ifTrue: [
	poly makeBothArrows.
	^ poly setVertices: (Array with: poly center - (7@0) with:  poly
center + (7@0))].
rr == #upDown ifTrue: [
	poly makeBothArrows.
	^ poly setVertices: (Array with: poly center - (0@7) with:  poly
center + (0@7))].
rr == #none ifTrue: [
	poly makeNoArrows.
	^ poly setVertices: (Array with: poly center - (7@0) with:  poly
center + (7@0)
		 with: poly center with: poly center - (0@7) with:  poly
center + (0@7))].
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/15/2000 17:43'!
stamp: evt
	"plop one copy of the user's chosen Form down."

	"Check depths"
	| pt sForm |

	sForm _ self get: #stampForm for: evt.
	pt _ evt cursorPoint - (sForm extent // 2).
	sForm displayOn: paintingForm 
		at: pt - bounds origin
		clippingBox: paintingForm boundingBox
		rule: Form paint
		fillColor: nil.
	self render: (pt extent: sForm extent).
! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'RAA 8/16/2000 11:55'!
star: evt 
	"Draw an star from the center."
	| poly ext ww rect oldExt oldRect oldR verts pt cColor sOrigin priorEvt |
	sOrigin _ self get: #strokeOrigin for: evt.
	cColor _ self getColorFor: evt.
	ww _ (self getNibFor: evt) width.
	ext _ (pt _ sOrigin - evt cursorPoint) r + ww * 2.
	rect _ Rectangle center: sOrigin extent: ext.
	(priorEvt _ self get: #lastEvent for: evt)
		ifNotNil: [oldExt _ (sOrigin - priorEvt cursorPoint) r + ww * 2.
			"Last draw sticks out, must erase the area"
			oldRect _ Rectangle center: sOrigin extent: oldExt.
			self restoreRect: oldRect].
	ext _ pt r.
	oldR _ ext.
	verts _ (0 to: 350 by: 36)
				collect: [:angle | (Point r: (oldR _ oldR = ext
									ifTrue: [ext * 5 // 12]
									ifFalse: [ext]) degrees: angle + pt degrees)
						+ sOrigin].
	poly _ PolygonMorph new addHandles.
	cColor == Color transparent
		ifTrue: [poly color: cColor;
				 borderWidth: 1;
				 borderColor: Color black]
		ifFalse: [poly color: cColor;
				 borderWidth: 0;
				 borderColor: Color transparent].
	"can't handle thick brushes"
	self invalidRect: rect.
	"self addMorph: poly."
	poly privateOwner: self.
	poly
		bounds: (sOrigin extent: ext).
	poly setVertices: verts.
	poly drawOn: formCanvas.
	"poly delete."
	self invalidRect: rect! !

!SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 9/3/97 21:17'!
toggleDirType: evt in: handle
	"Toggle from 'rotate' to 'to and fro' to 'up and down' to 'none'
for the kind of rotation the object does.  An actor's rotationStyle is one
of #(normal leftRight upDown none)."

| rr ii |
"Clear the indicator"

"Find new style, store it, install the indicator"
rr _ self rotationStyle.
ii _ #(normal leftRight upDown none) indexOf: rr.
self setProperty: #rotationStyle toValue:
	(#(leftRight upDown none normal) at: ii).
ii = 4 ifTrue: ["normal" self forward: self forwardDirection
			direction: (self valueOfProperty: #fwdButton)]
	ifFalse: [self showDirType.].! !


!SketchEditorMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:24'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
hostView _ deepCopier references at: hostView ifAbsent: [hostView].
enclosingPasteUpMorph _ deepCopier references at: enclosingPasteUpMorph 
			ifAbsent: [enclosingPasteUpMorph].! !

!SketchEditorMorph methodsFor: 'copying' stamp: 'RAA 8/16/2000 12:29'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"hostView _ hostView.		Weakly copied"
	"stampForm _ stampForm veryDeepCopyWith: deepCopier."
	"canvasRectangle _ canvasRectangle veryDeepCopyWith: deepCopier."
palette _ palette veryDeepCopyWith: deepCopier.
	"currentColor _ currentColor veryDeepCopyWith: deepCopier."
ticksToDwell _ ticksToDwell veryDeepCopyWith: deepCopier.
rotationCenter _ rotationCenter veryDeepCopyWith: deepCopier.
registrationPoint _ registrationPoint veryDeepCopyWith: deepCopier.
newPicBlock _ newPicBlock veryDeepCopyWith: deepCopier.
emptyPicBlock _ emptyPicBlock veryDeepCopyWith: deepCopier.
	"action _ action veryDeepCopyWith: deepCopier."
paintingForm _ paintingForm veryDeepCopyWith: deepCopier.
dimForm _ dimForm veryDeepCopyWith: deepCopier.
	"buff _ buff veryDeepCopyWith: deepCopier."
	"brush _ brush veryDeepCopyWith: deepCopier."
	"paintingFormPen _ paintingFormPen veryDeepCopyWith: deepCopier."
formCanvas _ formCanvas veryDeepCopyWith: deepCopier.
	"picToBuff _ picToBuff veryDeepCopyWith: deepCopier."
	"brushToBuff _ brushToBuff veryDeepCopyWith: deepCopier."
	"buffToBuff _ buffToBuff veryDeepCopyWith: deepCopier."
	"buffToPic _ buffToPic veryDeepCopyWith: deepCopier."
rotationButton _ rotationButton veryDeepCopyWith: deepCopier.
scaleButton _ scaleButton veryDeepCopyWith: deepCopier.
	"strokeOrigin _ strokeOrigin veryDeepCopyWith: deepCopier."
cumRot _ cumRot veryDeepCopyWith: deepCopier.
cumMag _ cumMag veryDeepCopyWith: deepCopier.
undoBuffer _ undoBuffer veryDeepCopyWith: deepCopier.
	"lastEvent _ lastEvent veryDeepCopyWith: deepCopier."
	"currentNib _ currentNib veryDeepCopyWith: deepCopier."
enclosingPasteUpMorph _ enclosingPasteUpMorph.	"weakly copied"
forEachHand _ nil.	"hmm..."                              ! !


!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:47'!
cancelPainting: aPaintBoxMorph evt: evt
	"Undo the operation after user issued #cancel in aPaintBoxMorph"
	^self cancel: evt! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:25'!
clearPainting: aPaintBoxMorph
	"Clear the image after user issued #clear in aPaintBoxMorph"
	^self clear! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/31/2000 14:03'!
dimTheWindow

	"Updated to use TranslucentColor by kfr 10/5 00"
	"Do not call twice!! Installs a morph with an 'onion-skinned' copy of the pixels behind me." 

	"create an 'onion-skinned' version of the stuff on the screen"
	owner outermostMorphThat: [:morph | morph resumeAfterDrawError. false].

	"an experiment for Nebraska to see if opaque background speeds things up"

"----- now using the color variable to control background
	bgColor _ false ifTrue: [TranslucentColor r:1.0 g:1.0 b:1.0 alpha:0.5] ifFalse: [Color white].
	dimForm _ (RectangleMorph new color: bgColor; bounds: self bounds; borderWidth: 0).
	dimForm position: self position.
	owner
		privateAddMorph: dimForm
		atIndex: (owner submorphs indexOf: self) + 1.
-----"
! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/15/2000 18:02'!
paintBoxChanged: arguments

	self set: arguments first for: arguments second to: arguments third.
! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:37'!
paletteAttached: aPaintBoxMorph
	"A new palette has been attached to the receiver.
	Don't know what to do here..."! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:33'!
paletteDetached: aPaintBoxMorph
	"The palette has been detached to the receiver.
	Don't know what to do here...."! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 01:48'!
savePainting: aPaintBoxMorph evt: evt
	"Save the image after user issued #keep in aPaintBoxMorph"
	^self save: evt! !

!SketchEditorMorph methodsFor: 'palette handling' stamp: 'RAA 8/16/2000 11:17'!
undoPainting: aPaintBoxMorph evt: evt
	"Undo the operation after user issued #undo in aPaintBoxMorph"
	^self undo: evt! !


!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 15:13'!
get: aSymbol for: anEventOrHand

	| valuesForHand |

	valuesForHand _ self valuesForHand: anEventOrHand.
	^valuesForHand at: aSymbol ifAbsent: [nil].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 11:14'!
getActionFor: anEventOrHand

	^(self get: #action for: anEventOrHand) ifNil: [
		self set: #action for: anEventOrHand to: palette action
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 17:56'!
getBrushFor: anEventOrHand

	^(self get: #brush for: anEventOrHand) ifNil: [
		self set: #brush for: anEventOrHand to: palette getNib
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 11:20'!
getColorFor: anEventOrHand

	^(self get: #currentColor for: anEventOrHand) ifNil: [
		self set: #currentColor for: anEventOrHand to: palette getColor
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/16/2000 13:40'!
getCursorFor: anEventOrHand

	| plainCursor |
	plainCursor _ (self get: #currentCursor for: anEventOrHand) ifNil: [
		self set: #currentCursor for: anEventOrHand to: palette plainCursor
	].
	^palette
		cursorFor: (self getActionFor: anEventOrHand) 
		oldCursor: plainCursor 
		currentNib: (self getNibFor: anEventOrHand) 
		color: (self getColorFor: anEventOrHand)

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 17:16'!
getNibFor: anEventOrHand

	^(self get: #currentNib for: anEventOrHand) ifNil: [
		self set: #currentNib for: anEventOrHand to: palette getNib
	].

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'ar 10/10/2000 17:30'!
set: aSymbol for: anEventOrHand to: anObject

	| valuesForHand |

	valuesForHand _ self valuesForHand: anEventOrHand.
	aSymbol == #action ifTrue: [
		valuesForHand at: #priorAction put: (valuesForHand at: #action ifAbsent: [#paint:]).
		(anObject ~~ #polygon: and:[self polyEditing]) ifTrue:[self polyFreeze].
	].
	valuesForHand at: aSymbol put: anObject.
	^anObject

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 15:12'!
valuesForHand: anEventOrHand

	| hand valuesForHand |
	forEachHand ifNil: [forEachHand _ IdentityDictionary new].
	hand _ (anEventOrHand isKindOf: HandMorph) 
				ifTrue: [anEventOrHand] ifFalse: [anEventOrHand hand].
	valuesForHand _ forEachHand at: hand ifAbsentPut: [Dictionary new].
	^valuesForHand

! !

!SketchEditorMorph methodsFor: 'Nebraska support' stamp: 'RAA 8/15/2000 18:01'!
valuesForHandIfPresent: anEventOrHand

	| hand |
	forEachHand ifNil: [forEachHand _ IdentityDictionary new].
	hand _ (anEventOrHand isKindOf: HandMorph) 
				ifTrue: [anEventOrHand] ifFalse: [anEventOrHand hand].
	^forEachHand at: hand ifAbsent: [nil].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SketchEditorMorph class
	instanceVariableNames: ''!

!SketchEditorMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
Morph subclass: #SketchMorph
	instanceVariableNames: 'originalForm rotationStyle scalePoint framesToDwell rotatedForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!SketchMorph commentStamp: '<historical>' prior: 0!
The morph that results when the user draws a color bitmap using the PaintBox (SketchEditorMorph and PaintBoxMorph).  

forwardDirection is the angle at which the object will go forward.  When the rotationStyle is not #normal, then forwardDirection is any angle, while the rotation is highly restricted.  If flexed, this is remembered by the Transform morph.  For non-normal rotationStyle, it is rotationDegrees.

setupAngle (a property) is where the user put the green arrow to indicate which direction on the picture is forward.  When #normal, draw the morph initially at (0.0 - setupAngle).  The enclosing TransformationMorph then rotates it to the true angle.
 
rotationDegrees  In a #normal object, rotationDegrees is constant an equal to setupAngle.
	For non-normal, it is the direction the object is going.

When repainting, set it back to its original state. The green arrow is set to setupAngle, and the sketch is shown as drawn originally (rotationDegrees = 0). 

rotationStyle = normal (turns), leftRight, upDown, fixed.  
When leftRight upDown or fixed, bit map has severe restrictions.
!


!SketchMorph methodsFor: 'initialization' stamp: 'di 2/17/2000 20:14'!
initialize

	^ self initializeWith: (ScriptingSystem formAtKey: 'Painting') deepCopy.

! !

!SketchMorph methodsFor: 'initialization' stamp: 'ar 9/22/2000 20:38'!
initializeWith: aForm

	super initialize.
	originalForm _ aForm.
	self rotationCenter: 0.5@0.5.		"relative to the top-left corner of the Form"
	rotationStyle _ #normal.		"styles: #normal, #leftRight, #upDown, or #none"
	scalePoint _ 1.0@1.0.
	framesToDwell _ 1.
	rotatedForm _ originalForm.	"cached rotation of originalForm"
	self extent: originalForm extent.
! !


!SketchMorph methodsFor: 'accessing'!
form

	^ originalForm
! !

!SketchMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 20:33'!
form: aForm

	originalForm _ aForm.
	self rotationCenter: 0.5@0.5.
	self layoutChanged.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 22:31'!
forwardDirection: degrees
	"If not rotating normally, update my rotatedForm"
	super forwardDirection: degrees.
	rotationStyle == #normal ifFalse:[self layoutChanged].! !

!SketchMorph methodsFor: 'accessing'!
framesToDwell

	^ framesToDwell
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
framesToDwell: anInteger

	framesToDwell _ anInteger.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 21:19'!
heading: newHeading
	"If not rotating normally, change forward direction rather than heading"
	rotationStyle == #normal ifTrue:[^super heading: newHeading].
	self isFlexed
		ifTrue:[self forwardDirection: newHeading - owner rotationDegrees]
		ifFalse:[self forwardDirection: newHeading].
	self layoutChanged! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 9/9/1998 13:15'!
originalForm: aForm
	originalForm _ aForm! !

!SketchMorph methodsFor: 'accessing'!
rotatedForm

	rotatedForm ifNil: [self layoutChanged].
	^ rotatedForm
! !

!SketchMorph methodsFor: 'accessing'!
rotationStyle

	^ rotationStyle
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
rotationStyle: aSymbol
	"Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean:
		#normal		-- continuous 360 degree rotation
		#leftRight		-- quantize angle to left or right facing
		#upDown		-- quantize angle to up or down facing
		#none			-- do not rotate"

	rotationStyle _ aSymbol.
	self layoutChanged.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
scalePoint

	scalePoint ifNil: [scalePoint _ 1.0@1.0].
	^ scalePoint
! !

!SketchMorph methodsFor: 'accessing' stamp: 'jm 7/24/97 15:06'!
scalePoint: aPoint

	scalePoint _ aPoint.
	self layoutChanged.
! !

!SketchMorph methodsFor: 'accessing' stamp: 'sw 10/24/2000 05:55'!
setNewFormFrom: formOrNil
	"Set the receiver's form as indicated.   If nil is provided, then a default form will be used, possibly retrieved from the receiver's defaultValue property"

	| defaultImage |
	formOrNil ifNotNil: [^ self form: formOrNil].
	defaultImage _ self defaultValueOrNil ifNil: [ScriptingSystem squeakyMouseForm].
	self form: defaultImage
! !


!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 12:53'!
canBeEnlargedWithB3D

	| answer |

	^self 
		valueOfProperty: #canBeEnlargedWithB3D
		ifAbsent: [
			answer _ self rotatedForm colorsUsed allSatisfy: [ :c | c isTranslucent not].
			self setProperty: #canBeEnlargedWithB3D toValue: answer.
			answer
		]! !

!SketchMorph methodsFor: 'drawing' stamp: 'RAA 12/17/2000 14:24'!
drawHighResolutionOn: aCanvas in: aRectangle

	| r finalClipRect scale sourceOrigin sourceExtent sourceRect biggerSource biggerDestExtent interForm offsetInBigger |

	r _ aRectangle translateBy: aCanvas origin.
	finalClipRect _ r intersect: (aCanvas clipRect translateBy: aCanvas origin).
	self canBeEnlargedWithB3D ifTrue: [
		(WarpBlt toForm: aCanvas form)
			clipRect: finalClipRect;
			sourceForm: originalForm;
			cellSize: 2;  "installs a colormap"
			combinationRule: Form paint;

			copyQuad: originalForm boundingBox innerCorners 
			toRect: r.
		^self
	].
	scale _ aRectangle extent / originalForm extent.
	sourceOrigin _ originalForm offset + (aCanvas clipRect origin - aRectangle origin / scale).
	sourceExtent _ aCanvas clipRect extent / scale.
	sourceRect _ sourceOrigin rounded extent: sourceExtent rounded.
	biggerSource _ sourceRect expandBy: 1.
	biggerDestExtent _ (biggerSource extent * scale) rounded.
	offsetInBigger _ (sourceOrigin - biggerSource origin * scale) rounded.

	interForm _ Form extent: biggerDestExtent depth: aCanvas depth.
	(originalForm copy: biggerSource)
		displayInterpolatedIn: interForm boundingBox
		on: interForm.
	aCanvas 
		drawImage: interForm 
		at: aCanvas clipRect origin 
		sourceRect: (offsetInBigger extent: aCanvas clipRect extent).


! !

!SketchMorph methodsFor: 'drawing' stamp: 'ar 9/1/2000 13:51'!
drawOn: aCanvas
	aCanvas paintImage: self rotatedForm at: bounds origin
! !

!SketchMorph methodsFor: 'drawing' stamp: 'RAA 9/22/2000 15:14'!
drawPostscriptOn: aCanvas

	| top f2 c2 tfx clrs |

	tfx _ self transformFrom: self world.
	tfx angle = 0.0 ifFalse: [^super drawPostscriptOn: aCanvas].	"can't do rotated yet"
	clrs _ self rotatedForm colorsUsed.
	(clrs includes: Color transparent) 
		ifFalse: [^super drawPostscriptOn: aCanvas].		"no need for this, then"

"Smalltalk at: #Q put: OrderedCollection new"
"Q add: {self. tfx. clrs}."
"(self hasProperty: #BOB) ifTrue: [self halt]."

	top _ aCanvas topLevelMorph.
	f2 _ Form extent: self extent depth: self rotatedForm depth.
	c2 _ f2 getCanvas.
	c2 fillColor: Color white.
	c2 translateBy: bounds origin negated clippingTo: f2 boundingBox during: [ :c |
		top fullDrawOn: c
	].
	aCanvas paintImage: f2 at: bounds origin

! !

!SketchMorph methodsFor: 'drawing' stamp: 'ar 9/22/2000 20:25'!
generateRotatedForm
	"Compute my rotatedForm and offsetWhenRotated."
	| scalePt smoothPix pair |
	scalePoint ifNil:[scalePoint _ 1@1].
	scalePt _ scalePoint x abs @ scalePoint y abs.
	rotationStyle == #none ifTrue:[scalePt _ 1@1].
	((scalePt x < 1.0) or: [scalePt y < 1.0])
		ifTrue: [smoothPix _ 2]
		ifFalse: [smoothPix _ 1].
	rotationStyle = #leftRight ifTrue:[
		self heading asSmallAngleDegrees < 0.0 
			ifTrue:[scalePt _ scalePt x negated @ scalePt y]].
	rotationStyle = #upDown ifTrue:[
		self heading asSmallAngleDegrees abs > 90.0
			ifTrue:[scalePt _ scalePt x @ scalePt y negated]].
	scalePt = (1@1) ifTrue:[
		rotatedForm _ originalForm.
	] ifFalse:[
		pair _ WarpBlt current
			rotate: originalForm
			degrees: 0
			center: originalForm boundingBox center
			scaleBy: scalePt
			smoothing: smoothPix.
		rotatedForm _ pair first.
	].! !

!SketchMorph methodsFor: 'drawing' stamp: 'di 8/12/2000 14:39'!
wantsRoundedCorners

	^ self hasProperty: #roundedCorners! !


!SketchMorph methodsFor: 'geometry'!
containsPoint: aPoint

	^ (self bounds containsPoint: aPoint) and:
	  [(self rotatedForm isTransparentAt: aPoint - bounds origin) not]
! !

!SketchMorph methodsFor: 'geometry' stamp: 'ar 9/22/2000 21:23'!
extent: newExtent
	"Change my scale to fit myself into the given extent."
	self extent = newExtent ifTrue:[^self].
	scalePoint _ newExtent asFloatPoint / originalForm extent.
	self layoutChanged.
! !


!SketchMorph methodsFor: 'menu' stamp: 'di 8/12/2000 14:53'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'choose new graphic...' target: self action: #chooseNewGraphic.
	aCustomMenu add: 'set as background' target: rotatedForm action: #setAsBackground.
	aCustomMenu addUpdating: #roundedCornersString target: self action: #toggleCornerRounding.
	self addPaintingItemsTo: aCustomMenu hand: aHandMorph! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 6/18/1999 06:40'!
addFillStyleMenuItems: aMenu hand: aHand
	"Do nothing here - we do not allow changing the fill style of a SketchMorph yet."! !

!SketchMorph methodsFor: 'menu' stamp: 'RAA 11/14/2000 13:44'!
collapse
	
	| priorPosition w collapsedVersion a |

	(w _ self world) ifNil: [^self].
	collapsedVersion _ (self imageForm scaledToSize: 50@50) asMorph.
	collapsedVersion setProperty: #uncollapsedMorph toValue: self.
	collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion.
	collapsedVersion setBalloonText: 'A collapsed version of ',self name.
			
	self delete.
	w addMorphFront: (
		a _ AlignmentMorph newRow
			hResizing: #shrinkWrap;
			vResizing: #shrinkWrap;
			borderWidth: 4;
			borderColor: Color white;
			addMorph: collapsedVersion
	).
	collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.

	(priorPosition _ self valueOfProperty: #collapsedPosition ifAbsent: [nil])
	ifNotNil:
		[a position: priorPosition].
! !

!SketchMorph methodsFor: 'menu' stamp: 'tk 7/6/1998 15:31'!
editDrawing
	self flag: #deferred.  "Don't allow this if the user is already in paint mode, because it creates a very strange situation."
	"costumee ifNotNil: [self forwardDirection: costumee direction]."  "how say this?"
	self editDrawingIn: self pasteUpMorph forBackground: false
! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 12/4/2000 10:45'!
editDrawingIn: aPasteUpMorph forBackground: forBackground

	| w bnds sketchEditor pal aPaintTab aWorld aPaintBox tfx |
	self world assureNotPaintingElse: [^ self].

	w _ aPasteUpMorph world.
	w stopRunningAll; abandonAllHalos.
	w displayWorld.
	self visible: false.
	forBackground
		ifTrue:
			[bnds _ aPasteUpMorph boundsInWorld]
		ifFalse:
			[bnds _ (self boundsInWorld expandBy: (60 @ 60)) intersect: self world bounds.
			bnds _ (aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds].
	sketchEditor _ SketchEditorMorph new.
	forBackground ifTrue: [sketchEditor setProperty: #background toValue: true].
	w addMorphFront: sketchEditor.
	sketchEditor initializeFor: self inBounds: bnds pasteUpMorph: aPasteUpMorph.
	sketchEditor
		afterNewPicDo: [:aForm :aRect |
			self visible: true.
			self form: aForm.
			tfx _ aPasteUpMorph transformFrom: aPasteUpMorph world.
			self topRendererOrSelf position: (tfx globalPointToLocal: aRect origin).
			self rotationStyle: sketchEditor rotationStyle.
			self forwardDirection: sketchEditor forwardDirection.
			self presenter drawingJustCompleted: self.
			forBackground ifTrue: [self goBehind]]  "shouldn't be necessary"
		ifNoBits: ["If no bits drawn.  Must keep old pic.  Can't have no picture"
			self visible: true.
			aWorld _ self currentWorld.
				"sometimes by now I'm no longer in a world myself, but we still need
				 to get ahold of the world so that we can deal with the palette"
			((pal _ aPasteUpMorph standardPalette) notNil and: [pal isInWorld])
				ifTrue:
					[(aPaintBox _ aWorld paintBox) ifNotNil: [aPaintBox delete].
					pal viewMorph: self]
				ifFalse:
					[(aPaintTab _ aWorld paintingFlapTab)
						ifNotNil:
							[aPaintTab hideFlap]
						ifNil:
							[(aPaintBox _ aWorld paintBox) ifNotNil: [aPaintBox delete]]]].
! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:53'!
erasePixelsOfColor: evt
	"Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure"

	| c r |
	self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand.   "color to erase"
	c _ self rememberedColor ifNil: [Color red].
	originalForm mapColor: c to: Color transparent.
	r _ originalForm rectangleEnclosingPixelsNotOfColor: Color transparent.
	self form: (originalForm copy: r).

! !

!SketchMorph methodsFor: 'menu' stamp: 'sw 4/2/98 15:47'!
insertIntoMovie: evt

	| movies aTarget |
	movies _
		(self world rootMorphsAt: evt hand targetOffset)
			select: [:m | ((m isKindOf: MovieMorph) or:
						 [m isKindOf: SketchMorph]) and: [m ~= self]].
	movies isEmpty ifTrue: [^ self].
	aTarget _ movies first.
	(aTarget isKindOf: SketchMorph) ifTrue: [
		aTarget _ aTarget replaceSelfWithMovie].
	aTarget insertFrames: (Array with: self).
	self delete.
! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 10/5/2000 18:53'!
recolorPixelsOfColor: evt
	"Let the user select a color to be remapped, and then a color to map that color to, then carry it out."

	| c d newForm map newC |
	self inform: 'choose the color you want to replace'.
	self changeColorTarget: self selector: #rememberedColor: originalColor: nil hand: evt hand.   "color to replace"
	c _ self rememberedColor ifNil: [Color red].
	self inform: 'now choose the color you want to replace it with'.
	self changeColorTarget: self selector:  #rememberedColor: originalColor: c hand: evt hand.  "new color"
	newC _ self rememberedColor ifNil: [Color blue].
	d _ originalForm depth.
	newForm _ Form extent: originalForm extent depth: d.
	map _ (Color cachedColormapFrom: d to: d) copy.
	map at: (c indexInMap: map) put: (newC pixelValueForDepth: d).
	newForm copyBits: newForm boundingBox
		from: originalForm at: 0@0
		colorMap: map.
	self form: newForm.
! !

!SketchMorph methodsFor: 'menu' stamp: 'ar 9/22/2000 21:13'!
setRotationStyle
	| selections labels sel reply |
	selections _ #(normal leftRight upDown none).
	labels _ #('rotate smoothly' 'left-right flip only' 'top-down flip only' 'don''t rotate').
	sel _ labels at: (selections indexOf: self rotationStyle ifAbsent:[1]).
	labels _ labels collect:[:lbl| sel = lbl ifTrue:['<on>',lbl] ifFalse:['<off>',lbl]].
	reply _ (SelectionMenu labelList: labels selections: selections) startUp.
	reply ifNotNil: [self rotationStyle: reply].
! !

!SketchMorph methodsFor: 'menu' stamp: 'di 9/26/2000 09:36'!
wantsDirectionHandles

	^ super wantsDirectionHandles or: [Preferences showDirectionForSketches] ! !


!SketchMorph methodsFor: 'change reporting' stamp: 'ar 9/22/2000 14:00'!
layoutChanged
	"Update rotatedForm and compute new bounds."
	self changed.
	self generateRotatedForm.
	bounds _ bounds origin extent: rotatedForm extent.
	super layoutChanged.
	self changed.
! !


!SketchMorph methodsFor: 'other' stamp: 'RAA 12/4/2000 10:56'!
canDrawAtHigherResolution
	
	| pt |
	pt _ self scalePoint.
	^pt x < 1.0 or: [pt y < 1.0]! !

!SketchMorph methodsFor: 'other' stamp: 'sw 1/27/2000 19:19'!
canSetColor
	"Answer true iff the receiver can meaningfully have its color changed"
	^ false! !

!SketchMorph methodsFor: 'other' stamp: 'sw 10/30/2000 10:29'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')  SketchMorphs answer true, because they can serve as 'picture-holding' fields"

	^ true! !

!SketchMorph methodsFor: 'other' stamp: 'sw 10/30/2000 10:28'!
currentDataValue
	"Answer the object which bears the current datum for the receiver"

	^ originalForm! !

!SketchMorph methodsFor: 'other' stamp: 'sw 7/3/1999 20:06'!
isLikelyRecipientForMouseOverHalos
	^ true! !

!SketchMorph methodsFor: 'other' stamp: 'sw 12/1/1998 18:16'!
newForm: aForm
	self originalForm: aForm.
	self layoutChanged! !

!SketchMorph methodsFor: 'other' stamp: 'di 3/2/98 14:14'!
releaseCachedState
	"Clear cache of rotated, scaled Form."

	super releaseCachedState.
	rotatedForm _ nil.
	originalForm hibernate! !

!SketchMorph methodsFor: 'other' stamp: 'jm 7/24/97 15:06'!
replaceSelfWithMovie
	"Replace this SketchMorph in its owner with a MovieMorph containing this sketch as its only frame. This allows a SketchMorph to be turned into a MovieMorph by just insering additional frames."

	| o movie |
	self changed.
	o _ self owner.
	movie _ MovieMorph new position: self referencePosition.
	movie insertFrames: (Array with: self).
	o ifNil: [^ movie].
	o addMorphFront: movie.
	^ movie
! !

!SketchMorph methodsFor: 'other' stamp: 'sw 10/25/2000 07:01'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName  type: #form definingMorph: self morphGetSelector: #form morphPutSelector: #setNewFormFrom:)! !


!SketchMorph methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	scalePoint ifNil: [scalePoint _ 1.0@1.0].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 17:14'!
clearExtent: aPoint fillColor: aColor
	"Make this sketch have the given pixel dimensions and fill it with given color. Its previous contents are replaced."

	self form:
		((Form extent: aPoint depth: Display depth) fillColor: aColor).
! !

!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:26'!
penOnMyForm
	"Support for experiments with drawing under program control. To get started, make a new SketchMorph in a morphic world. In an inspector, give it the desired pixel dimensions with clearExtent:fillColor:. Then use this method to get a pen to which you can send normal pen commands. Reveal the resulting drawing with revealPenStrokes."

	^ Pen newOnForm: originalForm
! !

!SketchMorph methodsFor: 'pen support' stamp: 'jm 4/22/1998 09:08'!
revealPenStrokes
	"This message must be sent after a sequence of pen strokes to make the resulting changes visible."

	rotatedForm _ nil.
	self changed.
! !


!SketchMorph methodsFor: 'e-toy support' stamp: 'RAA 1/13/2001 11:38'!
appearsToBeSameCostumeAs: aMorph

	(aMorph isKindOf: self class) ifFalse: [^false].
	^originalForm == aMorph form or: [
		originalForm appearsToBeSameCostumeAs: aMorph form
	]! !

!SketchMorph methodsFor: 'e-toy support' stamp: 'ar 9/26/2000 14:12'!
asWearableCostume
	"Return a wearable costume for some player"
	^(SketchMorph withForm: originalForm) copyCostumeStateFrom: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SketchMorph class
	instanceVariableNames: ''!

!SketchMorph class methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1998 17:15'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !

!SketchMorph class methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:21'!
withForm: aForm
	"Note: 'SketchMorph withForm: zz' is MUCH faster
	than 'SketchMorph new form: zz'."

	^ self basicNew initializeWith: aForm! !
MorphicModel subclass: #Slider
	instanceVariableNames: 'slider value setValueSelector sliderShadow sliderColor descending '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!Slider methodsFor: 'initialize' stamp: 'sw 3/10/2000 13:05'!
initialize
	super initialize.
	bounds := 0@0 corner: 16@100.
	color := Color gray.
	borderWidth := 1.
	borderColor := #inset.
	value _ 0.0.
	descending _ false.
	self initializeSlider! !

!Slider methodsFor: 'initialize' stamp: 'ar 10/25/2000 17:51'!
initializeSlider
	slider := RectangleMorph newBounds: self totalSliderArea color: self sliderColor.
	sliderShadow := RectangleMorph newBounds: self totalSliderArea
						color: self pagingArea color.
	slider on: #mouseMove send: #scrollAbsolute: to: self.
	slider on: #mouseDown send: #mouseDownInSlider: to: self.
	slider on: #mouseUp send: #mouseUpInSlider: to: self.
	slider setBorderWidth: 1 borderColor: #raised.
	sliderShadow setBorderWidth: 1 borderColor: #inset.
	"(the shadow must have the pagingArea as its owner to highlight properly)"
	self pagingArea addMorph: sliderShadow.
	sliderShadow hide.
	self addMorph: slider.
	self computeSlider.
! !


!Slider methodsFor: 'access' stamp: 'sw 3/10/2000 13:05'!
descending
	^ descending == true! !

!Slider methodsFor: 'access' stamp: 'sw 3/12/2000 11:57'!
descending: aBoolean
	descending _ aBoolean.
	self value: value! !

!Slider methodsFor: 'access' stamp: 'dew 2/15/1999 18:24'!
pagingArea
	^self! !

!Slider methodsFor: 'access' stamp: 'di 11/9/1999 13:25'!
sliderColor

	sliderColor ifNil: [^ Color veryLightGray].
	^ sliderColor! !

!Slider methodsFor: 'access' stamp: 'sw 3/7/2000 15:39'!
sliderColor: newColor

	sliderColor _ newColor.
	slider ifNotNil: [slider color: sliderColor]! !

!Slider methodsFor: 'access'!
value
	^ value! !

!Slider methodsFor: 'access' stamp: '6/7/97 10:42 di'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!Slider methodsFor: 'geometry' stamp: 'sw 3/10/2000 13:44'!
computeSlider
	| r |
	r _ self roomToMove.
	self descending
		ifFalse:
			[slider position: (bounds isWide
				ifTrue: [r topLeft + ((r width * value) asInteger @ 0)]
				ifFalse: [r topLeft + (0 @ (r height * value)  asInteger)])]
		ifTrue:
			[slider position: (bounds isWide
				ifTrue:	[r bottomRight - ((r width * value) asInteger @ 0)]
				ifFalse:	[r bottomRight - ((0 @ (r height * value) asInteger))])].
	slider extent: self sliderExtent! !

!Slider methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'!
extent: newExtent
	newExtent = bounds extent ifTrue: [^ self].
	bounds isWide
		ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y]
		ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)].
	self removeAllMorphs; initializeSlider! !

!Slider methodsFor: 'geometry'!
roomToMove
	^ self totalSliderArea insetBy: (0@0 extent: self sliderExtent)! !

!Slider methodsFor: 'geometry'!
sliderExtent
	^ bounds isWide
		ifTrue: [self sliderThickness @ self innerBounds height]
		ifFalse: [self innerBounds width @ self sliderThickness]! !

!Slider methodsFor: 'geometry' stamp: 'jm 1/30/98 13:31'!
sliderThickness
	^ 7
! !

!Slider methodsFor: 'geometry'!
totalSliderArea
	^ self innerBounds! !


!Slider methodsFor: 'scrolling' stamp: 'sw 3/10/2000 13:37'!
scrollAbsolute: event
	| r p |
	r _ self roomToMove.
	bounds isWide
		ifTrue: [r width = 0 ifTrue: [^ self]]
		ifFalse: [r height = 0 ifTrue: [^ self]].
	p _ event targetPoint adhereTo: r.
	self descending
		ifFalse:
			[self setValue: (bounds isWide 
				ifTrue: [(p x - r left) asFloat / r width]
				ifFalse: [(p y - r top) asFloat / r height])]
		ifTrue:
			[self setValue: (bounds isWide
				ifTrue: [(r right - p x) asFloat / r width]
				ifFalse:	[(r bottom - p y) asFloat / r height])]! !


!Slider methodsFor: 'model access'!
setValue: newValue
	"Called internally for propagation to model"
	self value: newValue.
	self use: setValueSelector orMakeModelSelectorFor: 'Value:'
		in: [:sel | setValueSelector _ sel.  model perform: sel with: value]! !

!Slider methodsFor: 'model access'!
value: newValue
	"Drive the slider position externally..."
	value _ newValue min: 1.0 max: 0.0.
	self computeSlider! !


!Slider methodsFor: 'other events' stamp: 'di 11/9/1999 13:35'!
mouseDownInSlider: event
	slider color: self sliderColor lighter.
	sliderShadow bounds: slider bounds.
	sliderShadow show.! !

!Slider methodsFor: 'other events' stamp: 'di 11/9/1999 13:33'!
mouseUpInSlider: event
	slider color: self sliderColor.
	sliderShadow hide.! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Slider class
	instanceVariableNames: ''!

!Slider class methodsFor: 'as yet unclassified' stamp: 'di 2/21/98 11:03'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
Object subclass: #SlotInformation
	instanceVariableNames: 'type documentation floatPrecision variableDock variableDefinition '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!SlotInformation commentStamp: '<historical>' prior: 0!
Holds information about user-defined instance variables in Players.!


!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1998 14:09'!
documentation
	documentation ifNil: [documentation _ 'This is an instance variable defined by you.  Please edit this into your own meaningful documentation.'].
	^ documentation! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 11/6/1998 10:33'!
documentation: d
	documentation _ d! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 9/8/1999 22:24'!
floatPrecision
	^ floatPrecision ifNil: [floatPrecision _ 1]! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 9/8/1999 18:31'!
floatPrecision: prec
	floatPrecision _ prec! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 9/8/1999 18:37'!
initialize
	documentation _ 'as yet undocumented'.
	type _ #number.
	floatPrecision _ 0.1.! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 9/8/1999 22:11'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' precision: ', floatPrecision asString, ' ; type = ', type asString! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 11/6/1998 10:31'!
type
	type ifNil: [type _ #number].
	^ type! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 11/6/1998 10:31'!
type: aType
	type _ aType! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:15'!
variableDock
	"Answer the variable dock associated with the receiver, or nil if none"

	^ variableDock! !

!SlotInformation methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:16'!
variableDock: vd
	"Set the receiver's variableDock as indicated"

	variableDock _ vd! !

Integer subclass: #SmallInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Numbers'!
!SmallInteger commentStamp: '<historical>' prior: 0!
My instances are 30-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal).!


!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:29'!
* aNumber 
	"Primitive. Multiply the receiver by the argument and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 9>
	^ super * aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:31'!
+ aNumber 
	"Primitive. Add the receiver to the argument and answer with the result
	if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger  Essential  No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 1>
	^ super + aNumber! !

!SmallInteger methodsFor: 'arithmetic'!
- aNumber 
	"Primitive. Subtract the argument from the receiver and answer with the
	result if it is a SmallInteger. Fail if the argument or the result is not a
	SmallInteger. Essential. No Lookup. See Object documentation
	whatIsAPrimitive."

	<primitive: 2>
	^super - aNumber! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'tfei 4/12/1999 12:45'!
/ aNumber 
	"Primitive. This primitive (for /) divides the receiver by the argument
	and returns the result if the division is exact. Fail if the result is not a
	whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 10>
	aNumber = 0 ifTrue: [^(ZeroDivide dividend: self) signal].
	(aNumber isMemberOf: SmallInteger)
		ifTrue: [^(Fraction numerator: self denominator: aNumber) reduced]
		ifFalse: [^super / aNumber]! !

!SmallInteger methodsFor: 'arithmetic'!
// aNumber 
	"Primitive. Divide the receiver by the argument and answer with the
	result. Round the result down towards negative infinity to make it a
	whole integer. Fail if the argument is 0 or is not a SmallInteger.
	Essential. No Lookup. See Object documentation whatIsAPrimitive. "

	<primitive: 12>
	^super // aNumber"Do with quo: if primitive fails"! !

!SmallInteger methodsFor: 'arithmetic'!
\\ aNumber 
	"Primitive. Take the receiver modulo the argument. The result is the
	remainder rounded towards negative infinity, of the receiver divided by
	the argument Fail if the argument is 0 or is not a SmallInteger. Optional.
	No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 11>
	^super \\ aNumber"Do with // if primitive fails"! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'LC 4/22/1998 14:21'!
gcd: anInteger 
	"See SmallInteger (Integer) | gcd:"
	| n m |
	n _ self.
	m _ anInteger.
	[n = 0]
		whileFalse: 
			[n _ m \\ (m _ n)].
	^ m abs! !

!SmallInteger methodsFor: 'arithmetic' stamp: 'sr 5/28/2000 04:41'!
quo: aNumber 
	"Primitive. Divide the receiver by the argument and answer with the 
	result. Round the result down towards zero to make it a whole integer. 
	Fail if the argument is 0 or is not a SmallInteger. Optional. See Object 
	documentation whatIsAPrimitive."
	<primitive: 13>
	aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal].
	(aNumber isMemberOf: SmallInteger)
		ifFalse: [^ super quo: aNumber].
	(aNumber == -1 and: [self == self class minVal])
		ifTrue: ["result is aLargeInteger" ^ self negated].
	self primitiveFailed! !


!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitAnd: arg 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 14>
	self >= 0 ifTrue: [^ arg bitAnd: self].
	^ (self bitInvert bitOr: arg bitInvert) bitInvert! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:33'!
bitOr: arg 
	"Primitive. Answer an Integer whose bits are the logical OR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 15>
	self >= 0 ifTrue: [^ arg bitOr: self].
	^ arg < 0
		ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert]
		ifFalse: [(self bitInvert bitClear: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitShift: arg 
	"Primitive. Answer an Integer whose value is the receiver's value shifted
	left by the number of bits indicated by the argument. Negative arguments
	shift right. The receiver is interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 17>
	self >= 0 ifTrue: [^ super bitShift: arg].
	^ arg >= 0
		ifTrue: [(self negated bitShift: arg) negated]
		ifFalse: [(self bitInvert bitShift: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'!
bitXor: arg 
	"Primitive. Answer an Integer whose bits are the logical XOR of the
	receiver's bits and those of the argument, arg.
	Numbers are interpreted as having 2's-complement representation.
	Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 16>
	self >= 0 ifTrue: [^ arg bitXor: self].
	^ arg < 0
		ifTrue: [self bitInvert bitXor: arg bitInvert]
		ifFalse: [(self bitInvert bitXor: arg) bitInvert]! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'SqR 8/3/2000 13:29'!
hashMultiply
	| low |

	low _ self bitAnd: 16383.
	^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384))
			bitAnd: 16r0FFFFFFF! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:07'!
highBit
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. Raise an error if the receiver is negative, since  
	negative integers are defined to have an infinite number of leading 1's 
	in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to 
	get the highest bit of the magnitude."
	self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers'].
	^ self highBitOfPositiveReceiver! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:08'!
highBitOfMagnitude
	"Answer the index of the high order bit of the receiver, or zero if the  
	receiver is zero. This method is used for negative SmallIntegers as well,  
	since Squeak's LargeIntegers are sign/magnitude."
	^ self abs highBitOfPositiveReceiver! !

!SmallInteger methodsFor: 'bit manipulation' stamp: 'jm 2/19/98 12:11'!
lowBit
	" Answer the index of the low order one bit.
		2r00101000 lowBit       (Answers: 4)
		2r-00101000 lowBit      (Answers: 4)
	  First we skip bits in groups of 4, then single bits.
	  While not optimal, this is a good tradeoff; long
	  integer #lowBit always invokes us with bytes."
	| n result |
	n := self.
	n = 0 ifTrue: [ ^ 0 ].
	result := 1.
	[ (n bitAnd: 16rF) = 0 ]
		whileTrue: [
			result := result + 4.
			n := n bitShift: -4 ].
	[ (n bitAnd: 1) = 0 ]
		whileTrue: [
			result := result + 1.
			n := n bitShift: -1 ].
	^ result! !


!SmallInteger methodsFor: 'testing'!
even

	^(self bitAnd: 1) = 0! !

!SmallInteger methodsFor: 'testing'!
odd

	^(self bitAnd: 1) = 1! !


!SmallInteger methodsFor: 'comparing'!
< aNumber 
	"Primitive. Compare the receiver with the argument and answer with
	true if the receiver is less than the argument. Otherwise answer false.
	Fail if the argument is not a SmallInteger. Essential. No Lookup. See
	Object documentation whatIsAPrimitive."

	<primitive: 3>
	^super < aNumber! !

!SmallInteger methodsFor: 'comparing'!
<= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
	See Object documentation whatIsAPrimitive. "

	<primitive: 5>
	^super <= aNumber! !

!SmallInteger methodsFor: 'comparing'!
= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is equal to the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive. "

	<primitive: 7>
	^super = aNumber! !

!SmallInteger methodsFor: 'comparing'!
> aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 4>
	^super > aNumber! !

!SmallInteger methodsFor: 'comparing'!
>= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is greater than or equal to the argument. Otherwise answer
	false. Fail if the argument is not a SmallInteger. Optional. No Lookup.
	See Object documentation whatIsAPrimitive."

	<primitive: 6>
	^super >= aNumber! !

!SmallInteger methodsFor: 'comparing'!
hash

	^self! !

!SmallInteger methodsFor: 'comparing'!
identityHash

	^self! !

!SmallInteger methodsFor: 'comparing' stamp: 'di 9/27/97 20:32'!
identityHashMappedBy: map

	^ self! !

!SmallInteger methodsFor: 'comparing'!
~= aNumber 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is not equal to the argument. Otherwise answer false. Fail if
	the argument is not a SmallInteger. Essential. No Lookup. See Object
	documentation whatIsAPrimitive."

	<primitive: 8>
	^super ~= aNumber! !


!SmallInteger methodsFor: 'copying' stamp: 'tk 6/26/1998 11:34'!
clone
! !

!SmallInteger methodsFor: 'copying'!
deepCopy! !

!SmallInteger methodsFor: 'copying'!
shallowCopy! !

!SmallInteger methodsFor: 'copying' stamp: 'tk 8/19/1998 16:04'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!SmallInteger methodsFor: 'converting'!
asFloat
	"Primitive. Answer a Float that represents the value of the receiver.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 40>
	self primitiveFailed! !


!SmallInteger methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:15'!
destinationBuffer:digitLength
  ^ LargePositiveInteger new: digitLength.! !

!SmallInteger methodsFor: 'printing'!
printOn: aStream base: b
	"Refer to the comment in Integer|printOn:base:."
	"SmallInteger maxVal printStringBase: 2"

	| digitsInReverse x i |
	self < 0 ifTrue: [
		aStream nextPut: $-.
		^ self negated printOn: aStream base: b.
	].

	b = 10 ifFalse: [aStream print: b; nextPut: $r].
	digitsInReverse _ Array new: 32.
	x _ self.
	i _ 0.
	[x >= b] whileTrue: [
		digitsInReverse at: (i _ i + 1) put: x \\ b.
		x _ x // b.
	].
	digitsInReverse at: (i _ i + 1) put: x.
	[i > 0] whileTrue: [
		aStream nextPut: (Character digitValue: (digitsInReverse at: i)).
		i _ i - 1.
	].! !

!SmallInteger methodsFor: 'printing' stamp: 'sw 10/26/2000 09:01'!
uniqueNameForReference
	"Answer a nice name by which the receiver can be referred to by other objects.   For SmallIntegers, we can actually just use the receiver's own printString, though this is pretty strange in some ways."

	^ self asString! !


!SmallInteger methodsFor: 'system primitives'!
asOop
	"Answer an object pointer as an integer, return negative number for SmallInteger"

	^ self! !

!SmallInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'!
digitAt: n 
	"Answer the value of an indexable field in the receiver.  LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256.  Fail if the argument (the index) is not an Integer or is out of bounds."
	n>4 ifTrue: [^ 0].
	self < 0
		ifTrue: 
			[self = SmallInteger minVal ifTrue:
				["Can't negate minVal -- treat specially"
				^ #(0 0 0 64) at: n].
			^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF]
		ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! !

!SmallInteger methodsFor: 'system primitives'!
digitAt: n put: value 
	"Fails. The digits of a small integer can not be modified."

	self error: 'You cant store in a SmallInteger'! !

!SmallInteger methodsFor: 'system primitives'!
digitLength
	"Answer the number of indexable fields in the receiver. This value is the 
	same as the largest legal subscript. Included so that a SmallInteger can 
	behave like a LargePositiveInteger or LargeNegativeInteger."

	(self < 16r100 and: [self > -16r100]) ifTrue: [^ 1].
	(self < 16r10000 and: [self > -16r10000]) ifTrue: [^ 2].
	(self < 16r1000000 and: [self > -16r1000000]) ifTrue: [^ 3].
	^ 4! !

!SmallInteger methodsFor: 'system primitives'!
instVarAt: i 
	"Small integer has to be specially handled."

	i = 1 ifTrue: [^self].
	self error: 'argument too big for small integer instVarAt:'! !

!SmallInteger methodsFor: 'system primitives' stamp: 'tk 5/14/1999 20:54'!
nextInstance
	"SmallIntegers can't be enumerated this way.  There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with:
	(SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>].
	"

	self shouldNotImplement ! !


!SmallInteger methodsFor: 'private'!
fromString: str radix: radix

	| maxdigit c val |
	maxdigit _ 
		radix + (radix > 10
					ifTrue: [55 - 1]
					ifFalse: [48 - 1]).
	val _ 0.
	1 to: str size do: 
		[:i | 
		c _ str at: i.
		(c < 48 ifFalse: [c > maxdigit])
			ifTrue: [^false].
		val _ val * radix + (c <= 57
							ifTrue: [c - 48]
							ifFalse: 
								[c < 65 ifTrue: [^false].
								c - 55])].
	^val! !

!SmallInteger methodsFor: 'private' stamp: 'sr 6/8/2000 01:14'!
highBitOfPositiveReceiver
	| shifted bitNo |
	"Answer the index of the high order bit of the receiver, or zero if the 
	receiver is zero. Receiver has to be positive!!"
	shifted _ self.
	bitNo _ 0.
	[shifted < 16]
		whileFalse: 
			[shifted _ shifted bitShift: -4.
			bitNo _ bitNo + 4].
	[shifted = 0]
		whileFalse: 
			[shifted _ shifted bitShift: -1.
			bitNo _ bitNo + 1].
	^ bitNo! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmallInteger class
	instanceVariableNames: ''!

!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:17'!
basicNew

	self error: 'SmallIntegers can only be created by performing arithmetic'! !

!SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'!
new

	self basicNew	"generates an error"! !


!SmallInteger class methodsFor: 'constants'!
maxVal
	"Answer the maximum value for a SmallInteger."
	^ 16r3FFFFFFF! !

!SmallInteger class methodsFor: 'constants'!
minVal
	"Answer the minimum value for a SmallInteger."
	^ -16r40000000! !


!SmallInteger class methodsFor: 'documentation'!
guideToDivision
	"Handy guide to the kinds of Integer division: 
	/  exact division, returns a fraction if result is not a whole integer. 
	//  returns an Integer, rounded towards negative infinity. 
	\\ is modulo rounded towards negative infinity. 
	quo:  truncated division, rounded towards zero."! !


!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:04'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToSmallIntegerObjectFrom: aNode on: aStream! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 10/5/1999 06:11'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToSmallIntegerValueFrom: aNode on: aStream! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:09'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger! !

!SmallInteger class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 11:20'!
ccgCanConvertFrom: anObject

	^anObject class == self! !
Environment subclass: #SmalltalkEnvironment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Environments'!
ReferenceStream subclass: #SmartRefStream
	instanceVariableNames: 'structures steady reshaped renamed renamedConv superclasses progressBar objCount classInstVars '
	classVariableNames: 'ScannedObject '
	poolDictionaries: ''
	category: 'System-Object Storage'!
!SmartRefStream commentStamp: '<historical>' prior: 0!
Ordinary ReferenceStreams assume that the layout of instance variables in an object on the disk is the same as the layout of that class in memory now.  And it assumes that the class has the same name as before.  SmartRefStream allows one to bring in objects whose instance variables or class name have changed.  1/13/97 tk

>>>>See SmartRefStream.aComment for an example.<<<< 

The basic principle is that object conversion to a new version needs to be done after the fact.  SmartRefStream records the names of the instance variables of all outgoing classes.  Adjustments are done later when the file is read in.

* Allows incoming object to have fewer instance variables than the current class.
* Works best with only one (large) tree of objects per file.  Can nextPut: more than once, but each gets its own class structure description, which is big.  
* Writes triplets of (version, class structure array, object) on the file.

-- 2 Feb 2001 --- conversion methods are now different - see SmartRefStream.aComment
* Version of a class is indicated by the first letters of all instance varaibles followed by a class version number.  Form has inst vars "bits width height depth offset", so version 2 of it has version tag #bwhdo2.
* Methods to convert versions of objects are named 
	Form new convertbwhdo2: aDictionary bwhdo3: aSmartRefStream.
		Note that aDictionary has (old inst var name -> value) 
* Prompts the user to write (or file in) a conversion method when needed.
--------

* Allows a change of instance vars in a superclass to be handled by just one conversion method.  Figures out what to do to the subclasses.
* Allows mixing cole for filing in, and raw objects.  The file can start out in the normal fileOut format.  Definitions of new classes on the front and an object are at the end.

structures 	Dictionary of (#Rectangle -> #(<classVersionInteger> 'origin' 'corner')).  Inst 
				var names are strings.
steady 		Set of Classes who have the same structure now as on the incoming file.
				Includes classes with same inst vars except for new ones added on the end.
reshaped 	Dictionary of Classes who have a different structure now from the incoming file.  
				Includes those with same inst vars but new version number.
				(old class name -> method selector to fill in data for version to version)
renamed	Dictionary of Classes who have a different name.  Make an instance of the new
			class, and send it the conversion call.
				(old class name symbol -> new class name).  
renamedConv	Dictionary of conversion selector for Classes who have a different name.
				(old class name symbol -> conversion selector).  
topCall		Tells if next or nextPut: are working on the top object in the tree.  
			nil if outside, the top object if deep inside.

>>>>> See DataStream.typeIDFor: for where the tangle of objects is clipped, so the whole system will not be written on the file.

No object that is written on the file is ever a class.  All class definitions are filed in.  A class may be stored inside an ImageSegment that is stored by me.

UniClasses are classes for the instance specific behavior of just one instance.  Subclasses of Player are an example.  When a UniClass is read in, and a class of the same name already exists, the incoming one is renamed.  ObjectScanner converts the filed in code.

Values in instance variables of UniClasses are stored in the array that tells the class structure.  It is the fourth of the four top level objects.  #(version (class-structure) the-object ((#Player25 scripts slotInfo costumeDictionary) (#Player26 scripts slotInfo costumeDictionary))).

There is a separate subclass for doing veryDeepCopy (in memory).  Currently, any object that has objectToStoreOnDataStream return an object other than self, does this:  The new object (a DiskProxy) is traced.  When it comes time to go through the fields of the old object, they are not found as keys in references (DiskProxies are there instead).  So the old field value is left in the new object.  That is OK for StrikeFont, Class, MetaClass, DisplayScreen.  But the DiskProxies are evaluated, which takes a lot of time.

Some metaclasses are put into the structures table.  This is for when a block has a receiver that is a class.  See checkFatalReshape:.

ImageSegments:
	A ReferenceStream is used to enumerate objects to put inside an ImageSegment.  If an instance of a UniClass is seen, the class is put in also.
	A SmartRefStream is used to store the ImageSegment.  Roots are nil, and the segment is a wordArray.  We are encoding the outPointers.  Structures contains all classes from both places.  Must filter out UniClasses for some things, and do include them for putting source code at end of file.  Do not write any class inst vars in file.

Future:
* Someday will prompt for a new version number when there are new inst vars with same initials, and tell how to make conversion work when some files have already been written.

!
]style[(930 555 3463)f1,f1cblue;,f1!


!SmartRefStream methodsFor: 'read write' stamp: 'RAA 2/2/2001 06:28'!
aComment
"SmartRefStream implements the 'Seeds' object storage system.  Please see the class comment.
--- new changes 2 Feb 2001 ---
These changes have actually been in for a little over a month, so it's time to say something about them. In the previous implementation (described further down), there needed to be a separate method of the form #convertxxxxx:yyyyyy: for each conceivable old version (xxxxx) that might be encountered. Additionally, when the current version (yyyyyy) changed, all existing methods were rendered obsolete. The new implementation requires just one method (per class, of course) of the form #convertToCurrentVersion:refStream:. This method is expected to convert any old version to the current version. Determining which old version is represented by the incoming object can be done in several ways: noticing that a current inst var is nil when it should have data, noticing that there is an older inst var name in the variable dictionary (first argument), checking kinds of objects in one or more inst vars or retrieving the classVersion of the incoming object from the ref stream. Note: ChangeSet>>checkForConversionMethods still prompts (if the preference is set) you to write/modify conversion methods when they might be needed, but its ability to do so and the need for such methods is reduced by the new single method format. For now, take the message it produces as a warning and make any conversion method changes by hand (which was mostly what you did in the past, anywat).

--- older documentation ---
Headlines:
	To bring in an instance of a class whose instance variables have changed, you need only define one conversion method.  The method is named
	convertxxxxx: aDictionary yyyyyy: aSmartRefStream.
Where xxxxxx is the first letters of all the instance variables in the old instance, and yyyyy are the first letters of all instance variables in the current version of the class.  A Form has inst vars 'bits width height depth offset', so version 2 of it has version tag #bwhdo2.  If the old instance had variables 'bitMap extent depth offsetPoint textDescription', its code would be #bedot0.
	Form new convertbedot0: aDictionary bwhdo3: aSmartRefStream.
All you have to do is to write the method.  aDictionary has entries (old inst var name -> value), so you can fetch the old vars by name.  See SmartRefStream.catalogValues:size:.  aSmartRefStream is available so you can get at 'structures' which tells the inst vars of other old classes in this file.

In the Squeak Goodies Folder, we provide an example.
	Suppose there once was a file named ArrayTwoDee.  If it like Array2D in this system, but is implemented differently.  ArrayTwoDee was defined like this: (Array variableSubclass: #ArrayTwoDee instanceVariableNames: 'height '...) so it is a variable class with the array values directly in the instance.  
	Array2D uses an instance var for 'contents' instead.   It has width varying most quickly, whereas the old ArrayTwoDee had height varying first.  The order of the elements must be changed.
	File in the file ConvArrayTwoDee2.st.
It defines SmartRefStream.arrayTwoDeeh2 to return Array2D, so we know what class to convert to.
It defines Array2D.converth2:wc0: to do the actual conversion.  Look at the method.  The method 'test' has the code for actually doing the conversion:
	| new2D ss |
	ss _ SmartRefStream fileNamed: 'ArrayTwoDee.test.obj'.
	new2D _ ss next.
	ss close.
	new2D class == Array2D ifFalse: [self error: 'Class conversion failed'].
	(new2D atCol: 1) = #(1 2 3 4) ifFalse: [self error: 'not flipped properly'].
	^ new2D

	The file ArrayTwoDee.test.obj has the object data in it, and is the actual file we converted.  Note that we never had to file in the old class ArrayTwoDee.  It is never needs to be defined in our system.  
	If ArrayTwoDee held an instance variable of another old class, say WeirdNumber, what form would it be in when converth2:wc0: gets run?  All objects get assigned instances in the current system before they are put into the value dictionary.  Generally, leaves of the object tree get converted first, so the values in an instance variable should be fully functioning objects in the current system.
"!
]style[(8 94 30 213 20 255 34 474 25 359 27 2659)f1b,f1,f1cblue;,f1,f1b,f1,f1b,f1,f1b,f1,f1cblue;,f1! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/15/98 20:28'!
appendClassDefns
	"Make this a fileOut format file.  For each UniClass mentioned, prepend its source code to the file.  Class name conflicts during reading will be resolved then.  Assume instVarInfo: has already been done."

byteStream ascii.
byteStream position = 0 ifTrue: [
	byteStream setFileTypeToObject.
		"Type and Creator not to be text, so can attach correctly to an email msg"
	byteStream header; timeStamp].

byteStream cr; nextPutAll: '!!ObjectScanner new initialize!!'; cr; cr.
self uniClasesDo: [:class | class
		class sharedPools size > 0 ifTrue:  "This never happens"
			[class shouldFileOutPools
				ifTrue: [class fileOutSharedPoolsOn: self]].
		class fileOutOn: byteStream moveSource: false toFile: 0].	
		"UniClasses are filed out normally, no special format."

	byteStream trailer.	"Does nothing for normal files.  
		HTML streams will have trouble with object data"

	"Append the object's raw data"
	byteStream cr; cr; nextPutAll: '!!self smartRefStream!!'.
	byteStream binary.		"get ready for objects"
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/19/2000 21:22'!
checkCrLf
	| save isCrLf cc prev loneLf |
	"Watch for a file that has had all of its Cr's converted to CrLf's.  Some unpacking programs like Stuffit 5.0 do this by default!!"

	save _ byteStream position.
	isCrLf _ false.  loneLf _ false.
	cc _ 0.
	350 timesRepeat: [
		prev _ cc.
		(cc _ byteStream next) = 16r0A "Lf" ifTrue: [
			prev = 16r0D "Cr" ifTrue: [isCrLf _ true] ifFalse: [loneLf _ true]].
		].
	isCrLf & (loneLf not) ifTrue: [
		self inform: 'Carriage Returns in this file were converted to CrLfs 
by an evil unpacking utility.  Please set the preferences in 
StuffIt Expander to "do not convert file formats"'].
	byteStream position: save.
! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 17:13'!
initShapeDicts
	"Initialize me. "

	self flag: #bobconv.	

	"These must stay constant.  When structures read in, then things can change."
	steady _ {Array. Dictionary. Association. String. SmallInteger} asSet.

	renamed ifNil: [
		renamed _ Dictionary new.  "(old class name symbol -> new class name)"
		renamedConv _ Dictionary new "(oldClassNameSymbol -> conversionSelectorInNewClass)"
	].
				
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 10/4/2000 15:45'!
instVarInfo: anObject
	"Return the object to write on the outgoing file that contains the structure of each class we are about to write out.  Must be an Array whose first element is 'class structure'.  Its second element is a Dictionary of pairs of the form #Rectangle -> #(<classVersion> 'origin' 'corner').  "

	"Make a pass through the objects, not writing, but recording the classes.  Construct a database of their inst vars and any version info (classVersion)."

	| dummy refs cls newSupers |
	structures _ Dictionary new.
	superclasses _ Dictionary new.
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	refs _ dummy references.
	objCount _ refs size.		"for progress bar"
		"Note that Dictionary must not change its implementation!!  If it does, how do we read this reading information?"
	(refs includesKey: #AnImageSegment) 
		ifFalse: [
			self uniClassInstVarsRefs: dummy.	"catalog the extra objects in UniClass inst vars"
			refs keysDo: [:each | 
				cls _ each class.
				"cls isObsolete ifTrue: [self error: 'Trying to write ', cls name]."
				(cls class ~~ Metaclass) & (cls isObsolete not) ifTrue: [
					structures at: cls name put: false]]]
		ifTrue: [self recordImageSegment: refs].
	"Save work by only computing inst vars once for each class"
	newSupers _ Set new.
	structures at: #Point put: false.	"writeRectangle: does not put out class pointer"
	structures at: #Rectangle put: false.
	structures keysDo: [:nm | 
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		cls allSuperclasses do: [:aSuper |
			structures at: aSuper name ifAbsent: [newSupers add: aSuper name]]].
			"Don't modify structures during iteration"
	newSupers do: [:nm | structures at: nm put: 3].	"Get all superclasses into list"
	structures keysDo: [:nm | "Nothing added to classes during loop"
		cls _ (nm endsWith: ' class') 
			ifFalse: [Smalltalk at: nm]
			ifTrue: [(Smalltalk at: nm substrings first asSymbol) class].
		structures at: nm put: 
			((Array with: cls classVersion), (cls allInstVarNames)).
		superclasses at: nm ifAbsent: [
				superclasses at: nm put: cls superclass name]].
	(refs includesKey: #AnImageSegment) 
		ifTrue: [classInstVars _ #()]
		ifFalse: [self saveClassInstVars].	"of UniClassses"
	^ (Array with: 'class structure' with: structures with: 'superclasses' with: superclasses)! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 17:17'!
mapClass: incoming
	"See if the old class named nm exists.  If so, return it.  If not, map it to a new class, and save the mapping in renamed.  "

	| cls oldVer sel nm |

	self flag: #bobconv.	


	nm _ renamed at: incoming ifAbsent: [incoming].	"allow pre-mapping around collisions"
	(nm endsWith: ' class') 
		ifFalse: [cls _ Smalltalk at: nm ifAbsent: [nil].
			cls ifNotNil: [^ cls]]  	"Known class.  It will know how to translate the instance."
		ifTrue: [cls _ Smalltalk at: nm substrings first asSymbol ifAbsent: [nil].
			cls ifNotNil: [^ cls class]]. 	"Known class.  It will know how to translate the instance."
	oldVer _ self versionSymbol: (structures at: nm).
	sel _ nm asString.
	sel at: 1 put: (sel at: 1) asLowercase.
	sel _ sel, oldVer.	"i.e. #rectangleoc4"
	Symbol hasInterned: sel ifTrue: [:symb | 
		(self class canUnderstand: sel asSymbol) ifTrue: [
			cls _ self perform: sel asSymbol]].	"This class will take responsibility"
	cls ifNil: [cls _ self writeClassRenameMethod: sel was: nm
					fromInstVars: (structures at: nm).
			   cls class == String ifTrue: [cls _ nil]].
	cls ifNotNil: [renamed at: nm put: cls name].
	^ cls
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 5/26/1998 15:09'!
moreObjects
	"Return true if there appears to be another object following this one on the file."

	| byte |
	byteStream atEnd ifTrue: [^ false].	"off end of file"
	(byte _ byteStream peek) ifNil: [^ false].	"off end of file"
	byte = 33 "$!! asciiValue" ifTrue: [^ false].
	byte = 0 ifTrue: [^ false].
	^ byte <= RefTypes size		"between 1 and 16"! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/19/2000 17:06'!
next
	"Really write three objects: (version, class structure, object). But only when called from the outside.  "

	| version ss object |
	^ topCall == nil 
		ifTrue: 
			[topCall _ #marked.
			version _ super next.
			version class == SmallInteger ifFalse: [^ version].	
				"version number, else just a regular object, not in our format, "
			self checkCrLf.
			ss _ super next.
			ss class == Array ifFalse: [^ ss].  "just a regular object"
			(ss at: 1) = 'class structure' ifFalse: [^ ss].
			structures _ ss at: 2.
			superclasses _ (ss size > 3 and: [(ss at: 3) = 'superclasses']) 
				ifTrue: [ss at: 4]		"class name -> superclass name"
				ifFalse: [Dictionary new].
			(self verifyStructure = 'conversion method needed') ifTrue: [^ nil].
			object _ super next.	"all the action here"
			self restoreClassInstVars.		"for UniClasses. version 4"

			topCall _ nil.	"reset it"
			object]
		ifFalse:
			[super next]
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/4/1998 19:47'!
nextPut: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  If any instance-specific classes are present, prepend their source code.  byteStream will be in fileOut format.
	You can see an analysis of which objects are written out by doing: 
	(SmartRefStream statsOfSubObjects: anObject)
	(SmartRefStream tallyOfSubObjects: anObject)
	(SmartRefStream subObjects: anObject ofClass: aClass)"

| info |
topCall == nil 
	ifTrue:
		[topCall _ anObject.
		'Please wait while objects are counted' 
			displayProgressAt: Sensor cursorPoint
			from: 0 to: 10
			during: [:bar | info _ self instVarInfo: anObject].
		self appendClassDefns.	"For instance-specific classes"
		'Writing an object file' displayProgressAt: Sensor cursorPoint
			from: 0 to: objCount*4	"estimate"
			during: [:bar |
				objCount _ 0.
				progressBar _ bar.
				self setStream: byteStream reading: false.
					"set basePos, but keep any class renames"
				super nextPut: ReferenceStream versionCode.
				super nextPut: info.
				super nextPut: anObject.		"<- the real writing"
				classInstVars size > 0 ifTrue: [super nextPut: classInstVars]].
					"Note: the terminator, $!!, is not doubled inside object data"
		"references is an IDict of every object that got written"
		byteStream ascii.
		byteStream nextPutAll: '!!'; cr; cr.
		byteStream padToEndWith: $ .	"really want to truncate file, but can't"
		topCall _ progressBar _ nil]	"reset it"
	ifFalse:
		[super nextPut: anObject.
		progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:00'!
nextPutObjOnly: anObject
	"Really write three objects: (version, class structure, object).  But only when called from the outside.  Not in fileOut format.  No class definitions will be written for instance-specific classes.  Error if find one.  (Use nextPut: instead)"

	| info |
	topCall == nil 
		ifTrue:
			[topCall _ anObject.
			super nextPut: ReferenceStream versionCode.
			'Please wait while objects are counted' displayProgressAt: Sensor cursorPoint
				from: 0 to: 10
				during: [:bar |
					info _ self instVarInfo: anObject].
			self uniClasesDo: [:cls | cls error: 'Class defn not written out.  Proceed?'].
			'Writing an object file' displayProgressAt: Sensor cursorPoint
				from: 0 to: objCount*4	"estimate"
				during: [:bar |
					objCount _ 0.
					progressBar _ bar.
					super nextPut: info.
					super nextPut: anObject.	"<- the real writing"
					"Class inst vars not written here!!"].
			"references is an IDict of every object that got written
			(in case you want to take statistics)"
			"Transcript cr; show: structures keys printString."		"debug"
			topCall _ progressBar _ nil]	"reset it"
		ifFalse:
			[super nextPut: anObject.
			progressBar ifNotNil: [progressBar value: (objCount _ objCount + 1)]].! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 6/23/1998 11:13'!
noHeader
	"Signal that we've already dealt with the version and structure array, and are now reading objects."

	topCall _ #marked.
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 17:59'!
readInstance
	"Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
Three cases for files from older versions of the system:
1) Class has not changed shape, read it straight.
2) Class has changed instance variables (or needs fixup).  Call a particular method to do it.
3) There is a new class instead.  Find it, call a particular method to read.
	All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!!  See setStream:"
	| instSize className refPosn |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	className _ self next asSymbol.
	^ self readInstanceSize: instSize clsname: className refPosn: refPosn
! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 17:16'!
readInstanceSize: instSize clsname: className refPosn: refPosn
	"The common code to read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next.
Three cases for files from older versions of the system:
1) Class has not changed shape, read it straight.
2) Class has changed instance variables (or needs fixup).  Call a particular method to do it.
3) There is a new class instead.  Find it, call a particular method to read.
	All classes used to construct the structures dictionary *itself* need to be in 'steady' and they must not change!!  See setStream:"
	| anObject newName newClass dict oldInstVars |

	self flag: #bobconv.	

	self setCurrentReference: refPosn.  "remember pos before readDataFrom:size:"
	newName _ renamed at: className ifAbsent: [className].
	newClass _ Smalltalk at: newName.
	(steady includes: newClass) & (newName == className) ifTrue: [
	 	anObject _ newClass isVariable "Create it here"
			ifFalse: [newClass basicNew]
			ifTrue: [newClass basicNew: instSize - (newClass instSize)].
		anObject _ anObject readDataFrom: self size: instSize.
		self setCurrentReference: refPosn.  "before returning to next"
		^ anObject].
	oldInstVars _ structures at: className ifAbsent: [
			self error: 'class is not in structures list'].	"Missing in object file"
	anObject _ newClass createFrom: self size: instSize version: oldInstVars.
		"only create the instance"
	self beginReference: anObject.
	dict _ self catalogValues: oldInstVars size: instSize.
		"indexed vars as (1 -> val) etc."
	dict at: #ClassName put: className.	"so conversion method can know it"

	"Give each superclass a chance to make its changes"
	self storeInstVarsIn: anObject from: dict.	"ones with the same names"

	anObject _ self applyConversionMethodsTo: anObject className: className varMap: dict.

	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 11/3/2000 18:04'!
readShortInst
	"Instance has just one byte of size.  Class symbol is encoded in two bytes of file position.  See readInstance."
	| instSize className refPosn |

	instSize _ (byteStream next) - 1.	"one byte of size"
	refPosn _ self getCurrentReference.
	className _ self readShortRef.	"class symbol in two bytes of file pos"
	^ self readInstanceSize: instSize clsname: className refPosn: refPosn
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 10/10/2000 13:36'!
recordImageSegment: refs
	"Besides the objects being written out, record the structure of instances inside the image segment we are writing out."

	| cls list |
	"Do not record Player class inst vars.  They are in the segement."
	refs keysDo: [:each | 
		cls _ each class.
		cls isObsolete ifTrue: [self error: 'Trying to write ', cls name].
		cls class == Metaclass 
			ifFalse: [structures at: cls name put: false.
				(each isKindOf: ImageSegment) ifTrue: [
					each outPointers do: [:out |
						(out isKindOf: Class) ifTrue: [
							structures at: out theNonMetaClass name put: false].
						out class == DiskProxy ifTrue: [
							out simpleGlobalOrNil ifNotNil: [
								(out simpleGlobalOrNil isKindOf: Class) ifTrue: [
									structures at: out simpleGlobalOrNil name put: false]]]].
					"each arrayOfRoots do: [:rr | (rr isKindOf: Class) ifTrue: [
							structures at: rr theNonMetaClass name put: false]]."
					 	"all classes in roots are local to seg"]]].
	list _ refs at: #BlockReceiverClasses ifAbsent: [^ self].
	list do: [:meta | structures at: meta name put: false].
		"Just the metaclasses whose instances are block receivers.  Otherwise metaclasses are not allowed."! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:08'!
renamed

	self flag: #bobconv.	


	^ renamed! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 11:10'!
renamedConv
	self flag: #bobconv.	


	^ renamedConv! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/22/2000 15:14'!
restoreClassInstVars
	"Install the values of the class instance variables of UniClasses
(i.e. scripts slotInfo).  classInstVars is ((#Player25 scripts slotInfo)
...).  Thank you Mark Wai for the bug fix."

	| normal aName newName newCls trans rList start |

	self flag: #bobconv.	


	self moreObjects ifFalse: [^ self]. 	"are no UniClasses with class inst vars"
	classInstVars _ super next.	"Array of arrays"
	normal _ Object class instSize.	"might give trouble if Player class superclass changes size"
	(structures at: #Player ifAbsent: [#()]) = #(0 'dependents' 'costume') ifTrue:
		[trans _ 1].	"now (0 costume costumes).  Do the conversion of Player class
			inst vars in Update 509."
	classInstVars do: [:list |
		aName _ (list at: 1) asSymbol.
		rList _ list.
		newName _ renamed at: aName ifAbsent: [aName].
		newCls _ Smalltalk at: newName
				ifAbsent: [self error: 'UniClass definition missing'].
		("old conversion" trans == 1 and: [newCls inheritsFrom: Player]) ifTrue: [
			"remove costumeDictionary from Player class inst vars"
			rList _ rList asOrderedCollection.
			rList removeAt: 4].	"costumeDictionary's value"
		start _ list second = 'Update to read classPool' ifTrue: [4] ifFalse: [2].
		newCls class instSize = (normal + (rList size) - start + 1) ifFalse:
			[self error: 'UniClass superclass class has changed size'].
			"Need to install a conversion method mechanism"
		start = 4 ifTrue: [newCls instVarAt: normal - 1 "classPool" put: (list at: 3)].
		start to: rList size do: [:ii |
			newCls instVarAt: normal + ii - start + 1 put: (rList at: ii)]].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 18:17'!
saveClassInstVars
	"Install the values of the instance variables of UniClasses.
classInstVars is an array of arrays (#Player3 (Player3 class's inst var
scripts) (Player3 class's inst var slotInfo) ...) "

	| normal mySize list clsPoolIndex |
	classInstVars _ OrderedCollection new: 100.
	normal _ Object class instSize.
	clsPoolIndex _ Object class allInstVarNames indexOf: 'classPool'.
	self uniClasesDo: [:aUniClass |
		list _ OrderedCollection new.
		mySize _ aUniClass class instSize.
		mySize = normal ifFalse:
			[list add: aUniClass name.	"a symbol"
			list add: 'Update to read classPool'.	"new
convention for saving the classPool"
			list add: (aUniClass instVarAt: clsPoolIndex)
"classPool".
						"write actual value of nil
instead of Dictionary()"
			normal + 1 to: mySize do: [:ii |
				list addLast: (aUniClass instVarAt: ii)].
			classInstVars add: list asArray]].
	classInstVars _ classInstVars asArray.
	! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 8/18/1998 09:02'!
scanFrom: aByteStream
	"During a code fileIn, we need to read in an object, and stash it in ScannedObject.  "

	self setStream: aByteStream reading: true.
	ScannedObject _ self next.
	byteStream ascii.
	byteStream next == $!! ifFalse: [
		byteStream close.
		self error: 'Object did not end correctly']. 
	"caller will close the byteStream"
	"HandMorph.readMorphFile will retrieve the ScannedObject"! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'!
setStream: aStream
	"Initialize me. "

	self flag: #bobconv.	

	super setStream: aStream.
	self initShapeDicts.

! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 16:57'!
setStream: aStream reading: isReading
	"Initialize me. "

	self flag: #bobconv.	

	super setStream: aStream reading: isReading.
	isReading ifFalse: [^ false].
	self initShapeDicts.

! !

!SmartRefStream methodsFor: 'read write'!
structures
	^ structures! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 9/28/97 11:17'!
superclasses
	^superclasses! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 3/6/2000 17:15'!
uniClasesDo: aBlock
	"Examine structures and execute the block with each instance-specific class"

	| cls |
	structures keysDo: [:clsName | 
		(clsName endsWith: ' class') ifFalse: [
			(cls _ Smalltalk at: clsName) isSystemDefined ifFalse: [
					aBlock value: cls]]]! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/18/2001 15:54'!
uniClassInstVarsRefs: dummy
	"If some of the objects seen so far are instances UniClasses, check the UniClasses for extra class inst vars, and send them to the steam also.  The new objects get added to (dummy references), where they will be noticed by the caller.  They will wind up in the structures array and will be written on the disk by class.
	Return all classes seen." 
| uniClasses normal more aUniClass mySize allClasses |

"Note: Any classes used in the structure of classInstVars must be written out also!!"
uniClasses _ Set new.
allClasses _ IdentitySet new.
normal _ Object class instSize.
more _ true.
[more] whileTrue: [
	more _ false.
	dummy references keysDo: [:each | "any faster way to do this?"
		(aUniClass _ each class) isSystemDefined ifFalse: [
			(uniClasses includes: aUniClass name) ifFalse: [
				mySize _ aUniClass class instSize.
				normal+1 to: mySize do: [:ii | 
					more _ true.
					dummy nextPut: (aUniClass instVarAt: ii)].
				uniClasses add: aUniClass name]].
		each class class isMeta ifFalse: ["it is a class" allClasses add: each]]].
"References dictionary is modified as the loop proceeds, but we will catch any we missed on the next cycle."

^ allClasses! !

!SmartRefStream methodsFor: 'read write' stamp: 'RAA 12/20/2000 17:13'!
verifyStructure
	"Compare the incoming inst var name lists with the existing classes.  Prepare tables that will help to restructure those who need it (renamed, reshaped, steady).    If all superclasses are recorded in the file, only compare inst vars of this class, not of superclasses.  They will get their turn.  "


	| newClass newList oldList converting |

	self flag: #bobconv.	

	converting _ OrderedCollection new.
	structures keysDo: [:nm "an old className (symbol)" |
		"For missing classes, there needs to be a method in SmartRefStream like 
			#rectangleoc2 that returns the new class."
		newClass _ self mapClass: nm.	   "does (renamed at: nm put: newClass name)"
		newClass class == String ifTrue: [^ newClass].  "error, fileIn needed"
		newList _ (Array with: newClass classVersion), (newClass allInstVarNames).
		oldList _ structures at: nm.
		newList = oldList 
			ifTrue: [steady add: newClass]  "read it in as written"
			ifFalse: [converting add: newClass name]
	].
	false & converting isEmpty not ifTrue: ["debug" 
			self inform: 'These classes are being converted from existing methods:\' withCRs,
				converting asArray printString].
! !

!SmartRefStream methodsFor: 'read write' stamp: 'tk 1/7/97'!
versionSymbol: instVarList
	"Create the symbolic code (like a version number) for this class in some older version.  First initials of all the inst vars, followed by the class version number.  Returns a string, caller makes it into a compound selector.  "

	| str |
	str _ instVarList size = 1 ifFalse: [''] ifTrue: ['x'].		"at least one letter"
	2 to: instVarList size do: [:ind |
		str _ str, (instVarList at: ind) first asString].
	str _ str, instVarList first printString.	"the number"
	^ str

" | list | list _ (Array with: Paragraph classVersion), (Paragraph alistInstVarNames).
(SmartRefStream  on: (DummyStream on: nil)) versionSymbol: list
"! !


!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 1/7/97'!
catalogValues: instVarList size: varsOnDisk
	"Create a dictionary of (name -> value) for the inst vars of this reshaped object.  Indexed vars as (1 -> val) etc.  "

	| dict sz |
	dict _ Dictionary new.
	2 to: instVarList size do: [:ind |
		dict at: (instVarList at: ind) put: self next].
	sz _ varsOnDisk - (instVarList size - 1).
	1 to: sz do: [:ii | 
		dict at: ii put: self next].
	"Total number read MUST be equal to varsOnDisk!!"
	sz > 0 ifTrue: [dict at: #SizeOfVariablePart put: sz].
	^ dict! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'tk 5/26/97'!
storeInstVarsIn: anObject from: dict
	"For instance variables with the same names, store them in the new instance.  Values in variable-length part also.  This is NOT the normal inst var transfer!!  See Object.readDataFrom:size:.  This is for when inst var names have changed and some additional conversion is needed.  Here we handle the unchanged vars.  "

	(anObject class allInstVarNames) doWithIndex: [:varName :index |
		(dict includesKey: varName) ifTrue: [
			anObject instVarAt: index put: (dict at: varName)]].
	"variable part"
	(dict includesKey: #SizeOfVariablePart) ifFalse: [^ anObject].
	1 to: (dict at: #SizeOfVariablePart) do: [:index | 
		anObject basicAt: index put: (dict at: index)].
	^ anObject! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'RAA 12/20/2000 11:09'!
writeClassRenameMethod: sel was: oldName fromInstVars: oldList
	"The class coming is unknown.  Ask the user for the existing class it maps to.  If got one, write a method, and restart the obj fileIn.  If none, write a dummy method and get the user to complete it later.  "

| tell choice  newName answ code oldVer newList newVer instSel |

	self flag: #bobconv.	


tell _ 'Reading an instance of ', oldName, '.
Which modern class should it translate to?'.
answ _ (PopUpMenu labels: 'Let me type the name now
Let me think about it
Let me find a conversion file on the disk') startUpWithCaption: tell. 

answ = 1 ifTrue: [
	tell _ 'Name of the modern class that ', oldName, 's should it translate to:'.
	choice _ FillInTheBlank request: tell.		"class name"
	(choice size = 0) 
		ifTrue: [answ _ 'conversion method needed']
		ifFalse: [newName _ choice.
			answ _ Smalltalk at: newName asSymbol 
				ifAbsent: ['conversion method needed'].
			answ class == String ifFalse: [renamed at: oldName asSymbol put: answ name]]].
(answ = 3) | (answ = 0) ifTrue: [self close.
		^ 'conversion method needed'].
answ = 2 ifTrue: [answ _ 'conversion method needed'].
answ = 'conversion method needed' ifTrue: [
		self close.  
		newName _ 'PutNewClassHere'].

answ class == String ifFalse: [
	oldVer _ self versionSymbol: (structures at: oldName).
	newList _ (Array with: answ classVersion), (answ allInstVarNames).
	newVer _ self versionSymbol: newList.
	instSel _ 'convert',oldVer,':',newVer, ':'. 
	].

code _ WriteStream on: (String new: 500).
code nextPutAll: sel; cr.
answ class == String ifFalse: [
	code cr; tab; nextPutAll: 'reshaped at: #', oldName, ' put: #', instSel, '.'.
	code cr; tab; tab; nextPutAll: '"Be sure to define that conversion method in class ', answ name, '"'].
code cr; tab; nextPutAll: '^ ', newName.	"Return new class"

self class compile: code contents classified: 'conversion'.

newName = 'PutNewClassHere' ifTrue: [
	PopUpMenu notify: 'Please complete the following method and 
then read-in the object file again.'.
	Smalltalk browseAllImplementorsOf: sel asSymbol]. 

	"The class version number only needs to change under one specific circumstance.  That is when the first letters of the instance variables have stayed the same, but their meaning has changed.  A conversion method is needed, but this system does not know it.  
	If this is true for class Foo, define classVersion in Foo class.  
	Beware of previous object fileouts already written after the change in meaning, but before bumping the version number.  They have the old (wrong) version number, say 2.  If this is true, your method must be able to test the data and successfully read files that say version 2 but are really 3."

	^ answ! !

!SmartRefStream methodsFor: 'class changed shape' stamp: 'RAA 12/20/2000 11:58'!
writeConversionMethod: sel class: newClass was: oldName fromInstVars: oldList to: newList
	"No method sel was found in newClass.  Writing a default conversion method."

	| code keywords newOthers oldOthers copied |

	self flag: #bobconv.	

	code _ WriteStream on: (String new: 500).
	keywords _ sel keywords.
	code nextPutAll: (keywords at: 1); nextPutAll: ' varDict '; 
			nextPutAll: (keywords at: 2); nextPutAll: ' smartRefStrm'; cr; tab.
	newOthers _ newList asOrderedCollection "copy".
	oldOthers _ oldList asOrderedCollection "copy".
	copied _ OrderedCollection new.
	newList do: [:instVar |
		(oldList includes: instVar) ifTrue: [
			instVar isInteger ifFalse: [copied add: instVar].
			newOthers remove: instVar.
			oldOthers remove: instVar]].
	code nextPutAll: '"These variables are automatically stored into the new instance '.
	code nextPutAll: copied asArray printString; nextPut: $. .
	code cr; tab; nextPutAll: 'This method is for additional changes.'; 
		nextPutAll: ' Use statements like (foo _ varDict at: ''foo'')."'; cr; cr; tab.
	(newOthers size = 0) & (oldOthers size = 0) 
		ifTrue: [code nextPutAll: '"Instance variables are the same.  Only the order changed.  This method should work as written."'].
	(newOthers size > 0) ifTrue: [code nextPutAll: '"New variables: ', newOthers asArray printString, '  If a non-nil value is needed, please assign it."\' withCRs].
	(oldOthers size > 0) ifTrue: [code nextPutAll: '	"These are going away ', oldOthers asArray printString, '.  Possibly store their info in another variable?"'].

	newClass compile: code contents classified: 'object fileIn'.


	"If you write a conversion method beware that the class may need a version number change.  This only happens when two conversion methods in the same class have the same selector name.  (A) The inst var lists of the new and old versions intials as some older set of new and old inst var lists.  or (B) Twice in a row, the class needs a conversion method, but the inst vars stay the same the whole time.  (For an internal format change.)
	If either is the case, fileouts already written with the old (wrong) version number, say 2.  Your method must be able to read files that say version 2 but are really 3, until you expunge the erroneous version 2 files from the universe."

 ! !


!SmartRefStream methodsFor: 'conversion' stamp: 'jm 5/21/1998 06:44'!
bookPageMorphbosfcepcbbfgcc0
	"BookPageMorph->PasteUpMorph. For reading in old BookMorphs."

	^ PasteUpMorph
! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/22/1998 15:03'!
clippingMorphbosfcep0
	^ PasteUpMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'jm 5/21/1998 06:44'!
clippingMorphbosfcepc0
	"ClippingMorph->PasteUpMorph. For reading in old BookMorphs."

	^ PasteUpMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 11/3/2000 18:47'!
dropShadowMorphbosfces0

	^ Morph ! !

!SmartRefStream methodsFor: 'conversion' stamp: 'jm 11/13/97 10:32'!
gradientFillbosfcepbbfgcc0
	^ GradientFillMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 5/21/1998 19:24'!
layoutMorphbosfcepbbochvimol0
	^ AlignmentMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 5/12/1998 16:18'!
layoutMorphbosfcepcbbochvimol0
	^ AlignmentMorph! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 01:55'!
morphicEventtcbks0
	^ MorphicEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'ar 10/26/2000 00:48'!
morphicSoundEventtcbkss0
	^ MorphicUnknownEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'RAA 10/26/2000 09:43'!
newMorphicEventts0

	^ MorphicEvent! !

!SmartRefStream methodsFor: 'conversion' stamp: 'tk 1/14/1999 13:16'!
transparentColorrcc0
	^ TranslucentColor! !

!SmartRefStream methodsFor: 'conversion' stamp: 'di 8/16/2000 16:37'!
worldMorphbosfcebbfgccpmcpbttloiairfidcuwhavcdsll0
	^ 'PutNewClassHere'  " <-- Replace this by a class name (no string quotes)"! !


!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 17:01'!
applyConversionMethodsTo: objectIn className: className varMap: varMap

	| anObject prevObject |

	self flag: #bobconv.	

	anObject _ objectIn.
	[
		prevObject _ anObject.
		anObject _ anObject convertToCurrentVersion: varMap refStream: self.
		prevObject == anObject
	] whileFalse.
	^anObject
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:08'!
checkFatalReshape: setOfClasses
	| suspects oldInstVars newInstVars bad className |
	"Inform the user if any of these classes were reshaped.  A block has a method from the old system whose receiver is of this class.  The method's inst var references might be wrong.  OK if inst vars were only added."

	self flag: #bobconv.	

	setOfClasses isEmpty ifTrue: [^ self].
	suspects _ OrderedCollection new.
	setOfClasses do: [:aClass |
		className _ renamed keyAtValue: aClass name ifAbsent: [aClass name].
		oldInstVars _ (structures at: className ifAbsent: [#(0)]) allButFirst.		"should be there"
		newInstVars _ aClass allInstVarNames.
		oldInstVars size > newInstVars size ifTrue: [bad _ true].
		oldInstVars size = newInstVars size ifTrue: [
			bad _ oldInstVars ~= newInstVars].
		oldInstVars size < newInstVars size ifTrue: [
			bad _ oldInstVars ~= (newInstVars copyFrom: 1 to: oldInstVars size)].
		bad ifTrue: [suspects add: aClass]].

	suspects isEmpty ifFalse: [
		self inform: ('Imported foreign methods will run on instances of:\',
			suspects asArray printString, 
			'\whose shape has changed.  Errors may occur.') withCRs].! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:06'!
convert1: misShapenInst to: goodClass allVarMaps: allVarMaps
	"Go through the normal instance conversion process and return a modern object."

	| className oldInstVars anObject varMap |

	self flag: #bobconv.	

	goodClass isVariable ifTrue: [
		goodClass error: 'shape change for variable class not implemented yet'
	].
	(misShapenInst class name beginsWith: 'Fake37') ifFalse: [self error: 'why mapping?'].
	className _ (misShapenInst class name allButFirst: 6) asSymbol.
	oldInstVars _ structures at: className.
	anObject _ goodClass basicNew.

	varMap _ Dictionary new.	"later, indexed vars as (1 -> val) etc."
	2 to: oldInstVars size do: [:ind |
		varMap at: (oldInstVars at: ind) put: (misShapenInst instVarAt: ind-1)].
	varMap at: #ClassName put: className.	"original"
	varMap at: #NewClassName put: goodClass name.	"new"
	self storeInstVarsIn: anObject from: varMap. 	"ones with the same names"
	allVarMaps at: misShapenInst put: varMap.
	^ anObject
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 17:15'!
convert2: partiallyCorrectInst allVarMaps: allVarMaps
	"Go through the normal instance conversion process and return a modern object."

	| className varMap |

	self flag: #bobconv.	

	varMap _ allVarMaps at: partiallyCorrectInst.
	className _ varMap at: #ClassName.	"original"
	^self applyConversionMethodsTo: partiallyCorrectInst className: className varMap: varMap.

! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'tk 11/7/2000 11:24'!
mapClass: newClass origName: originalName
	"See if instances changed shape.  If so, make a fake class for the old shape and return it.  Remember the original class name."

	| newName oldInstVars fakeClass |
	newClass isMeta ifTrue: [^ newClass].
	newName _ newClass name.
	(steady includes: newClass) & (newName == originalName) ifTrue: [^ newClass].
		"instances in the segment have the right shape"
	oldInstVars _ structures at: originalName ifAbsent: [
			self error: 'class is not in structures list'].	"Missing in object file"
	fakeClass _ Object subclass: ('Fake37', originalName) asSymbol
		instanceVariableNames: oldInstVars allButFirst
		classVariableNames: ''
		poolDictionaries: ''
		category: 'Obsolete'.
	Smalltalk changes removeClassChanges: fakeClass name.	"reduce clutter"
	^ fakeClass
! !

!SmartRefStream methodsFor: 'import image segment' stamp: 'RAA 12/20/2000 11:09'!
reshapedClassesIn: outPointers
	"Look for classes in the outPointer array that have changed shape.  Make a fake class for the old shape.  Return a dictionary mapping Fake classes to Real classes.  Substitute fake classes for real ones in outPointers."

	| mapFakeClassesToReal fakeCls originalName |

	self flag: #bobconv.	


	mapFakeClassesToReal _ IdentityDictionary new.
	outPointers withIndexDo: [:outp :ind | 
		outp isBehavior ifTrue: [
			originalName _ renamedConv at: ind ifAbsent: [outp name].
				"in DiskProxy>>comeFullyUpOnReload: we saved the name at the index"
			fakeCls _ self mapClass: outp origName: originalName.
			fakeCls == outp ifFalse: [
				mapFakeClassesToReal at: fakeCls put: outp.
				outPointers at: ind put: fakeCls]]].
	^ mapFakeClassesToReal! !


!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'!
structures: anObject
	structures _ anObject! !

!SmartRefStream methodsFor: 'accessing' stamp: 'tk 5/19/1999 15:47'!
superclasses: anObject
	superclasses _ anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SmartRefStream class
	instanceVariableNames: ''!

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'RAA 12/20/2000 14:32'!
analyzeConversionMethods
"
SmartRefStream analyzeConversionMethods
"
	| prelim syms good notImps temp impClassName impClass impSignature classesFound tokens goodImps badImps correct answer classBucket goodChanges badChanges impSelector |

	prelim _ Symbol allInstances select: [ :x | 
		(x beginsWith: 'convert') and: [x numArgs = 2]
	].
	syms _ prelim select: [ :x |
		good _ true.
		2 to: x size do: [ :i | good _ good and: [(x at: i) ~~ $: or: [(x at: i - 1) isDigit]]].
		good
	].
	classesFound _ IdentityDictionary new.
	notImps _ OrderedCollection new.
	goodImps _ OrderedCollection new.
	badImps _ OrderedCollection new.
	goodChanges _ ChangeSorter existingOrNewChangeSetNamed: 'valid converters'.
	badChanges _ ChangeSorter existingOrNewChangeSetNamed: 'stale converters'.
	syms do: [ :x | 
		temp _ (Smalltalk allImplementorsOf: x).
		temp size = 0 ifTrue: [
			notImps add: x.
		] ifFalse: [
			temp do: [ :imp |
				tokens _ imp findTokens: ' '.
				impClassName _ tokens first asSymbol.
				impSelector _ tokens second asSymbol.
				impClass _ Smalltalk at: impClassName.
				impSignature _ 
					(String withAll: (impClass allInstVarNames collect: [ :ivn | ivn first])),
					impClass classVersion printString.
				correct _ impSelector endsWith: ':',impSignature,':'.
				(correct ifTrue: [goodImps] ifFalse: [badImps]) add: imp.
				classBucket _ (classesFound 
					at: impClassName 
					ifAbsentPut: [{OrderedCollection new. OrderedCollection new. impClassName}]).
				(correct ifTrue: [classBucket first] ifFalse: [classBucket second]) add: impSelector.
				(correct ifTrue: [goodChanges] ifFalse: [badChanges])
					noteNewMethod: (impClass compiledMethodAt: impSelector) 
					forClass: impClass
					selector: impSelector 
					priorMethod: nil.

			].
		].
		"{temp size. x. temp. impSignature}"
	].
	{syms. notImps. classesFound. goodImps. badImps} explore.
	answer _ WriteStream on: String new.
"=====
	answer cr; nextPutAll: '-- NOT IMPLEMENTED --'; cr; cr.
	notImps asSortedCollection do: [ :x | answer nextPutAll: x; cr].
====="

	answer cr; nextPutAll: '-- STALE IMPLEMENTATIONS --'; cr; cr.
	badImps asSortedCollection do: [ :x | answer nextPutAll: x; cr].
	answer cr; nextPutAll: '-- GOOD IMPLEMENTATIONS --'; cr; cr.
	goodImps asSortedCollection do: [ :x | answer nextPutAll: x; cr].
	answer cr; nextPutAll: '-- CLASS TALLIES --'; cr; cr.
	(classesFound values asSortedCollection: [ :a :b |
		a first size > b first size or: [a first size = b first size and: [a second size > b second size]]
	]) do: [ :each |
		answer nextPutAll: each first size printString,' - ',
			each second size printString,'  ',each third; cr
	]. 

	StringHolder new contents: answer contents; openLabel: 'conversion methods'.
! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 2/23/2000 23:44'!
cleanUpCategories
	| list valid removed newList newVers |
	"Look for all conversion methods that can't be used any longer.  Delete them."
	" SmartRefStream cleanUpCategories "

	"Two part selectors that begin with convert and end with a digit."
	"convertasossfe0: varDict asossfeu0: smartRefStrm"
	list _ Symbol selectorsContaining: 'convert'.
	list _ list select: [:symb | (symb beginsWith: 'convert') & (symb allButLast last isDigit)
				ifTrue: [(symb numArgs = 2)]
				ifFalse: [false]].
	valid _ 0.  removed _ 0.
	list do: [:symb |
		(Smalltalk allClassesImplementing: symb) do: [:newClass |
			newList _ (Array with: newClass classVersion), (newClass allInstVarNames).
			newVers _ self new versionSymbol: newList.
			(symb endsWith: (':',newVers,':')) 
				ifFalse: [
					"method is useless because can't convert to current shape"
					newClass removeSelector: symb.	"get rid of it"
					removed _ removed + 1]
				ifTrue: [valid _ valid + 1]]].
	Transcript cr; show: 'Removed: '; print: removed; 
		show: '		Kept: '; print: valid; show: ' '.! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 05:48'!
objectFromStreamedRepresentation: someBytes

	| file |

	file _ RWBinaryOrTextStream with: someBytes.
	file reset.
	^file fileInObjectAndCode! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 21:31'!
read: aByteStream withClasses: structureArray
	"Read an object off the stream, but first check structureArray against the current system."

	| me |
	me _ self on: aByteStream.
	me noHeader.
	me structures: (structureArray at: 2).
	me superclasses: (structureArray at: 4).
	(me verifyStructure = 'conversion method needed') ifTrue: [^ nil].
	^ super next
! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/20/97'!
scanFrom: aByteStream
	"During a code fileIn, we need to read in an object, and stash it in ScannedObject.  "

	| me |
	me _ self on: aByteStream.
	ScannedObject _ me next.
	aByteStream ascii.
	aByteStream next == $!! ifFalse: [
		aByteStream close.
		self error: 'Object did not end correctly']. 
	"caller will close the byteStream"
	"HandMorph.readMorphFile will retrieve the ScannedObject"! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/20/97'!
scannedObject
	"The most recently read in object.  Watch out for read-in that is interrupted and resumed.  May want to make this a dictionary?  "

	^ ScannedObject! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/20/97'!
scannedObject: objOrNil
	"Used to free up the last object stashed here.  "

	ScannedObject _ objOrNil! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/4/1998 17:34'!
statsOfSubObjects: anObject
	"Open a window with statistics on what objects would be written out with anObject.  Does not actually write on the disk.  Stats in the form:
	ScriptEditorMorph 51
		SortedCollection (21->LayoutMorph 15->SimpleButtonMorph 9->Array 4->CompoundTileMorph 2->StringMorph )"

	| dummy printOut |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	"(dummy references) is the raw data"
	printOut _ dummy statisticsOfRefs.
	(StringHolder new contents: printOut) 
		openLabel: 'ReferenceStream statistics'.! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'RAA 7/9/2000 05:35'!
streamedRepresentationOf: anObject

	| file |
	file _ (RWBinaryOrTextStream on: (ByteArray new: 5000)).
	file binary.
	(self on: file) nextPut: anObject.
	file close.
	^file contents! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 3/11/98 09:45'!
subObjects: anObject ofClass: aClass
	"Return a collection of all instances of aClass that would be written out with anObject.  Does not actually write on the disk.  Inspect the result and ask for 'references to this object'."

	| dummy coll |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	coll _ OrderedCollection new.
	dummy references keysDo: [:each |
		each class == aClass ifTrue: [coll add: each]].
	^ coll! !

!SmartRefStream class methodsFor: 'as yet unclassified' stamp: 'tk 5/4/1998 17:34'!
tallyOfSubObjects: anObject
	"Open a window with statistics on what objects would be written out with anObject.  Does not actually write on the disk.  Stats are simply the number of instances of each class:
	1450->Point   835->Rectangle   549->Array   300->String"

	| dummy bag |
	dummy _ ReferenceStream on: (DummyStream on: nil).
		"Write to a fake Stream, not a file"
	"Collect all objects"
	dummy rootObject: anObject.	"inform him about the root"
	dummy nextPut: anObject.
	bag _ Bag new.
	dummy references keysDo: [:key | bag add: key class name].
	"(bag sortedCounts) is the SortedCollection"
	(StringHolder new contents: bag sortedCounts printString) 
		openLabel: 'ReferenceStream statistics'.! !
Object subclass: #Socket
	instanceVariableNames: 'semaphore socketHandle readSemaphore writeSemaphore primitiveOnlySupportsOneSemaphore '
	classVariableNames: 'Connected DeadServer InvalidSocket OtherEndClosed Registry TCPSocketType ThisEndClosed UDPSocketType Unconnected WaitingForConnection '
	poolDictionaries: ''
	category: 'Network-Kernel'!
!Socket commentStamp: '<historical>' prior: 0!
A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols

Subclasses of socket provide support for network protocols such as POP, NNTP, HTTP, and FTP. Sockets also allow you to implement your own custom services and may be used to support Remote Procedure Call or Remote Method Invocation some day.

JMM June 2nd 2000 Macintosh UDP support was added if you run open transport.
!
]style[(196 4 6 3 228)f1,f1LHTTPSocket Comment;,f1,f1LFTPSocket Comment;,f1!


!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:47'!
acceptFrom: aSocket
	"Initialize a new socket handle from an accept call"
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _ self primAcceptFrom: aSocket socketHandle
						receiveBufferSize: 8000
						sendBufSize: 8000
						semaIndex: semaIndex
						readSemaIndex: readSemaIndex
						writeSemaIndex: writeSemaIndex.
	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !

!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:54'!
destroy
	"Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil ifFalse: 
		[self isValid ifTrue: [self primSocketDestroy: socketHandle].
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		socketHandle _ nil.
		readSemaphore _ writeSemaphore _ semaphore _ nil.
		self unregister].
! !

!Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 23:04'!
initialize: socketType
	"Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil."
	| semaIndex readSemaIndex writeSemaIndex |

	primitiveOnlySupportsOneSemaphore _ false.
	semaphore _ Semaphore new.
	readSemaphore _ Semaphore new.
	writeSemaphore _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: semaphore.
	readSemaIndex _ Smalltalk registerExternalObject: readSemaphore.
	writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore.
	socketHandle _
		self primSocketCreateNetwork: 0
			type: socketType
			receiveBufferSize: 8000
			sendBufSize: 8000
			semaIndex: semaIndex
			readSemaIndex: readSemaIndex
			writeSemaIndex: writeSemaIndex.

	socketHandle = nil ifTrue: [  "socket creation failed"
		Smalltalk unregisterExternalObject: semaphore.
		Smalltalk unregisterExternalObject: readSemaphore.
		Smalltalk unregisterExternalObject: writeSemaphore.
		readSemaphore _ writeSemaphore _ semaphore _ nil
	] ifFalse:[self register].
! !


!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
address
	"Shortcut"
	^self localAddress! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/10/2000 14:37'!
localAddress
	self waitForConnectionUntil: Socket standardDeadline.
	self isConnected ifFalse: [^ByteArray new: 4].
	^ self primSocketLocalAddress: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/10/2000 14:31'!
localPort
	self waitForConnectionUntil: Socket standardDeadline.
	self isConnected ifFalse: [^0 ].
	^ self primSocketLocalPort: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'jm 3/13/98 12:11'!
peerName
	"Return the name of the host I'm connected to, or nil if its name isn't known to the domain name server or the request times out."
	"Note: Slow. Calls the domain name server, taking up to 20 seconds to time out. Even when sucessful, delays of up to 13 seconds have been observed during periods of high network load." 

	^ NetNameResolver
		nameForAddress: self remoteAddress
		timeout: 20
! !

!Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'!
port
	"Shortcut"
	^self localPort! !

!Socket methodsFor: 'accessing' stamp: 'JMM 6/5/2000 10:12'!
primitiveOnlySupportsOneSemaphore
	^primitiveOnlySupportsOneSemaphore! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
readSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^readSemaphore! !

!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remoteAddress

	^ self primSocketRemoteAddress: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'jm 9/17/97 14:34'!
remotePort

	^ self primSocketRemotePort: socketHandle
! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/9/2000 15:32'!
semaphore
	^semaphore! !

!Socket methodsFor: 'accessing' stamp: 'ar 7/16/1999 17:22'!
socketHandle
	^socketHandle! !

!Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'!
writeSemaphore
	primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore].
	^writeSemaphore! !


!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
dataAvailable
	"Return true if this socket has unread received data."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketReceiveDataAvailable: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'!
isConnected
	"Return true if this socket is connected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Connected
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:15'!
isOtherEndClosed
	"Return true if this socket had the other end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:17'!
isThisEndClosed
	"Return true if this socket had the this end closed."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnected
	"Return true if this socket's state is Unconnected."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == Unconnected
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isUnconnectedOrInvalid
	"Return true if this socket is completely disconnected or is invalid."

	| status |
	socketHandle == nil ifTrue: [^ true].
	status _ self primSocketConnectionStatus: socketHandle.
	^ (status = Unconnected) | (status = InvalidSocket)
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:51'!
isValid
	"Return true if this socket contains a valid, non-nil socket handle."

	| status |
	socketHandle == nil ifTrue: [^ false].
	status _ self primSocketConnectionStatus: socketHandle.
	^ status ~= InvalidSocket
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
isWaitingForConnection
	"Return true if this socket is waiting for a connection."

	socketHandle == nil ifTrue: [^ false].
	^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection
! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'!
sendDone
	"Return true if the most recent send operation on this socket has completed."

	socketHandle == nil ifTrue: [^ false].
	^ self primSocketSendDone: socketHandle
! !

!Socket methodsFor: 'queries' stamp: 'JMM 5/8/2000 23:24'!
socketError
	^self primSocketError: socketHandle! !

!Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:56'!
statusString
	"Return a string describing the status of this socket."

	| status |
	socketHandle == nil ifTrue: [^ 'destroyed'].
	status _ self primSocketConnectionStatus: socketHandle.
	status = InvalidSocket ifTrue: [^ 'invalidSocketHandle'].
	status = Unconnected ifTrue: [^ 'unconnected'].
	status = WaitingForConnection ifTrue: [^ 'waitingForConnection'].
	status = Connected ifTrue: [^ 'connected'].
	status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd'].
	status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd'].
	^ 'unknown socket status'
! !


!Socket methodsFor: 'connection open/close' stamp: 'bolot 7/16/1999 14:36'!
accept
	"Accept a connection from the receiver socket.
	Return a new socket that is connected to the client"
	^Socket acceptFrom: self.! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 9/11/97 20:29'!
close
	"Close this connection gracefully. For TCP, this sends a close request, but the stream remains open until the other side also closes it."

	self primSocketCloseConnection: socketHandle.  "close this end"
! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 11/4/97 07:15'!
closeAndDestroy
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	self closeAndDestroy: 20.

! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 3/9/98 19:09'!
closeAndDestroy: timeoutSeconds
	"First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)."

	socketHandle = nil
		ifFalse: [
			self isConnected ifTrue: [
				self close.  "close this end"
				(self waitForDisconnectionUntil: (Socket deadlineSecs: timeoutSeconds))
					ifFalse: [
						"if the other end doesn't close soon, just abort the connection"
						self primSocketAbortConnection: socketHandle]].
			self destroy].
! !

!Socket methodsFor: 'connection open/close'!
connectTo: hostAddress port: port
	"Initiate a connection to the given port at the given host address. This operation will return immediately; follow it with waitForConnectionUntil: to wait until the connection is established."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before opening a new connection'].

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!Socket methodsFor: 'connection open/close' stamp: 'jm 3/10/98 11:56'!
disconnect
	"Break this connection, no matter what state it is in. Data that has been sent but not received will be lost."

	self primSocketAbortConnection: socketHandle.
! !

!Socket methodsFor: 'connection open/close'!
listenOn: port
	"Listen for a connection on the given port. This operation will return immediately; follow it with waitForConnectionUntil: to wait until a connection is established."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].

	self primSocket: socketHandle listenOn: port.
! !

!Socket methodsFor: 'connection open/close' stamp: 'ar 7/16/1999 18:26'!
listenOn: portNumber backlogSize: backlog
	"Listen for a connection on the given port.
	If this method succeeds, #accept may be used to establish a new connection"
	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	(status == Unconnected)
		ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection'].
	self primSocket: socketHandle listenOn: portNumber backlogSize: backlog.
! !


!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:22'!
discardReceivedData
	"Discard any data received up until now, and return the number of bytes discarded."

	| buf totalBytesDiscarded |
	buf _ String new: 10000.
	totalBytesDiscarded _ 0.
	[self isConnected and: [self dataAvailable]] whileTrue: [
		totalBytesDiscarded _
			totalBytesDiscarded + (self receiveDataInto: buf)].
	^ totalBytesDiscarded
! !

!Socket methodsFor: 'sending-receiving' stamp: 'JMM 6/3/2000 21:48'!
getData
	"Get some data"

	| buf bytesRead |
	(self waitForDataUntil: Socket standardDeadline) ifFalse: [self error: 'getData timeout'].
	buf _ String new: 4000.
	bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size.
	^ buf copyFrom: 1 to: bytesRead! !

!Socket methodsFor: 'sending-receiving'!
readInto: aStringOrByteArray startingAt: aNumber
	"Read data into the given buffer starting at the given index and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	(self waitForDataUntil: Socket standardDeadline) ifFalse: [self error: 'receive timeout'].
	^ self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: aNumber
		count: aStringOrByteArray size - aNumber + 1
! !

!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/15/97 12:21'!
receiveDataInto: aStringOrByteArray
	"Receive data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	^ self primSocket: socketHandle
		receiveDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size
! !

!Socket methodsFor: 'sending-receiving' stamp: 'jm 9/17/97 16:00'!
sendData: aStringOrByteArray
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent."

	| bytesSent bytesToSend count |
	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneUntil: (Socket deadlineSecs: 20))
			ifFalse: [self error: 'send data timeout; data not sent'].
		count _ self primSocket: socketHandle
			sendData: aStringOrByteArray
			startIndex: bytesSent + 1
			count: bytesToSend - bytesSent.
		bytesSent _ bytesSent + count].

	^ bytesSent
! !

!Socket methodsFor: 'sending-receiving' stamp: 'ar 7/20/1999 17:23'!
sendData: buffer count: n
	"Send the amount of data from the given buffer"
	| sent |
	sent _ 0.
	[sent < n] whileTrue:[
		sent _ sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! !

!Socket methodsFor: 'sending-receiving' stamp: 'ls 1/5/1999 15:05'!
sendSomeData: aStringOrByteArray
	"Send as much of the given data as possible and answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: 1
		count: aStringOrByteArray size! !

!Socket methodsFor: 'sending-receiving' stamp: 'ls 3/3/1999 18:59'!
sendSomeData: aStringOrByteArray startIndex: startIndex
	"Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	^ self
		sendSomeData: aStringOrByteArray
		startIndex: startIndex
		count: (aStringOrByteArray size - startIndex + 1)! !

!Socket methodsFor: 'sending-receiving' stamp: 'ls 1/5/1999 15:05'!
sendSomeData: aStringOrByteArray startIndex: startIndex count: count
	"Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent."
	"Note: This operation may have to be repeated multiple times to send a large amount of data."

	| bytesSent |
	(self waitForSendDoneUntil: (Socket deadlineSecs: 20))
		ifTrue: [
			bytesSent _ self primSocket: socketHandle
				sendData: aStringOrByteArray
				startIndex: startIndex
				count: count]
		ifFalse: [self error: 'send data timeout; data not sent'].
	^ bytesSent
! !


!Socket methodsFor: 'waiting' stamp: 'ar 7/20/1999 17:21'!
waitForAcceptUntil: deadLine
	"Wait and accept an incoming connection"
	self waitForConnectionUntil: deadLine.
	^self isConnected
		ifTrue:[self accept]
		ifFalse:[nil]! !

!Socket methodsFor: 'waiting' stamp: 'jm 3/2/98 18:15'!
waitForConnectionUntil: deadline
	"Wait up until the given deadline for a connection to be established. Return true if it is established by the deadline, false if not."

	| status |
	status _ self primSocketConnectionStatus: socketHandle.
	[(status = WaitingForConnection) and: [Time millisecondClockValue < deadline]]
		whileTrue: [
			semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
			status _ self primSocketConnectionStatus: socketHandle].

	^ status = Connected
! !

!Socket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:04'!
waitForDataUntil: deadline
	"Wait up until the given deadline for data to arrive. Return true if data arrives by the deadline, false if not."

	| dataArrived |
	[self isConnected & 
	 (dataArrived _ self primSocketReceiveDataAvailable: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	^ dataArrived
! !

!Socket methodsFor: 'waiting' stamp: 'JMM 5/17/2000 14:52'!
waitForDisconnectionUntil: deadline
	"Wait up until the given deadline for the the connection to be broken. Return true if it is broken by the deadline, false if not."
	"Note: The client should know the the connect is really going to be closed (e.g., because he has called 'close' to send a close request to the other end) before calling this method.
JMM 00/5/17 note that other end can close which will terminate wait"

	| extraBytes status |
	extraBytes _ 0.
	status _ self primSocketConnectionStatus: socketHandle.
	[((status = Connected) or: [(status = ThisEndClosed)]) and:
	 [Time millisecondClockValue < deadline]] whileTrue: [
		self dataAvailable
			ifTrue: [extraBytes _ extraBytes + self discardReceivedData].
		semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue).
		status _ self primSocketConnectionStatus: socketHandle].

	extraBytes > 0
		ifTrue: [self inform: 'Discarded ', extraBytes printString, ' bytes while closing connection.'].

	^ status ~= Connected
! !

!Socket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:05'!
waitForSendDoneUntil: deadline
	"Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."

	| sendDone |
	[self isConnected & (sendDone _ self primSocketSendDone: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	^ sendDone! !


!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept' module: 'SocketPlugin'>
	^self primitiveFailed! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:55'!
primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"Create and return a new socket handle based on accepting the connection from the given listening socket"
	<primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^self primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex ! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID connectTo: hostAddress port: port
	"Attempt to establish a connection to the given port of the given host. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketConnectToPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 21:48'!
primSocket: socketID getOption: aString 
	"Get some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the option value"

	<primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID listenOn: port
	"Listen for a connection on the given port. This is an asynchronous call; query the socket status to discover if and when the connection is actually completed."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: aHandle listenOn: portNumber backlogSize: backlog
	"Primitive. Set up the socket to listen on the given port.
	Will be used in conjunction with #accept only."
	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self destroy. "Accept not supported so clean up"! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available."

	<primitive: 'primitiveSocketReceiveDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/24/2000 17:19'!
primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count
	"Receive data from the given socket into the given array starting at the given index. 
	Return an Array containing the amount read, the host address byte array, the host port, and the more flag"

	<primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID sendData: aStringOrByteArray startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive: 'primitiveSocketSendDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:08'!
primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress  port: portNumber startIndex: startIndex count: count
	"Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed."
	"Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created."

	<primitive:  'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'>
	self primitiveFailed

! !

!Socket methodsFor: 'primitives' stamp: 'ar 7/18/2000 11:42'!
primSocket: socketID setOption: aString value: aStringValue
	"Set some option information on this socket. Refer to the UNIX 
	man pages for valid SO, TCP, IP, UDP options. In case of doubt
	refer to the source code.
	TCP_NODELAY, SO_KEEPALIVE are valid options for example
	returns an array containing the error code and the negotiated value"

	<primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'>
	^nil! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocket: socketID setPort: port
	"Set the local port associated with a UDP socket.
	Note: this primitive is overloaded.  The primitive will not fail on a TCP socket, but
	the effects will not be what was desired.  Best solution would be to split Socket into
	two subclasses, TCPSocket and UDPSocket."

	<primitive: 'primitiveSocketListenWithOrWithoutBacklog' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketAbortConnection: socketID
	"Terminate the connection on the given port immediately without going through the normal close sequence. This is an asynchronous call; query the socket status to discover if and when the connection is actually terminated."

	<primitive: 'primitiveSocketAbortConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCloseConnection: socketID
	"Close the connection on the given port. The remote end is informed that this end has closed and will do no further sends. This is an asynchronous call; query the socket status to discover if and when the connection is actually closed."

	<primitive: 'primitiveSocketCloseConnection' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketConnectionStatus: socketID
	"Return an integer reflecting the connection status of this socket. For a list of possible values, see the comment in the 'initialize' method of this class. If the primitive fails, return a status indicating that the socket handle is no longer valid, perhaps because the Squeak image was saved and restored since the socket was created. (Sockets do not survive snapshots.)"

	<primitive: 'primitiveSocketConnectionStatus' module: 'SocketPlugin'>
	^ InvalidSocket
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex
	"Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails.
	The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface.
	The socketType parameter specifies:
		0	reliable stream socket (TCP if the protocol is IP)
		1	unreliable datagram socket (UDP if the protocol is IP)
	The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing.
 	If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed."

	<primitive: 'primitiveSocketCreate' module: 'SocketPlugin'>
	^ nil  "socket creation failed"
! !

!Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:48'!
primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	"See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations
	ignore the buffer size and this interface supports three semaphores,  one for open/close/listen and the other two for
	reading and writing"

	<primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'>
	primitiveOnlySupportsOneSemaphore _ true.
	^ self primSocketCreateNetwork: netType
			type: socketType
			receiveBufferSize: rcvBufSize
			sendBufSize: sendBufSize
			semaIndex: semaIndex! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroy: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketDestroyGently: socketID
	"Release the resources associated with this socket. If a connection is open, it is aborted.
	Do not fail if the receiver is already closed."

	<primitive: 'primitiveSocketDestroy' module: 'SocketPlugin'>
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketError: socketID
	"Return an integer encoding the most recent error on this socket. Zero means no error."

	<primitive: 'primitiveSocketError' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalAddress: socketID
	"Return the local host address for this socket."

	<primitive: 'primitiveSocketLocalAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketLocalPort: socketID
	"Return the local port for this socket, or zero if no port has yet been assigned."

	<primitive: 'primitiveSocketLocalPort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketReceiveDataAvailable: socketID
	"Return true if data may be available for reading from the current socket."

	<primitive: 'primitiveSocketReceiveDataAvailable' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemoteAddress: socketID
	"Return the remote host address for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemoteAddress' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketRemotePort: socketID
	"Return the remote port for this socket, or zero if no connection has been made."

	<primitive: 'primitiveSocketRemotePort' module: 'SocketPlugin'>
	self primitiveFailed
! !

!Socket methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSocketSendDone: socketID
	"Return true if there is no send in progress on the current socket."

	<primitive: 'primitiveSocketSendDone' module: 'SocketPlugin'>
	self primitiveFailed
! !


!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:40'!
register
	^self class register: self! !

!Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:41'!
unregister
	^self class unregister: self! !


!Socket methodsFor: 'finalization' stamp: 'JMM 5/22/2000 22:52'!
finalize
	self primSocketDestroyGently: socketHandle.
	Smalltalk unregisterExternalObject: semaphore.
	Smalltalk unregisterExternalObject: readSemaphore.
	Smalltalk unregisterExternalObject: writeSemaphore.
! !


!Socket methodsFor: 'printing' stamp: 'jm 11/23/1998 11:57'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '[', self statusString, ']'.
! !


!Socket methodsFor: 'datagrams' stamp: 'JMM 6/7/2000 14:58'!
receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber
	| datagram |
	"Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self receiveDataInto: aStringOrByteArray].
	[true] whileTrue: 
		[datagram _ self receiveUDPDataInto: aStringOrByteArray.
		((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) 
			ifTrue: [^datagram at: 1]
			ifFalse: [^0]]! !

!Socket methodsFor: 'datagrams' stamp: 'JMM 6/3/2000 21:54'!
receiveUDPDataInto: aStringOrByteArray
	"Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading"

	^ self primSocket: socketHandle
		receiveUDPDataInto: aStringOrByteArray
		startingAt: 1
		count: aStringOrByteArray size
! !

!Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:05'!
sendData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."

	primitiveOnlySupportsOneSemaphore ifTrue:
		[self setPeer: hostAddress port: portNumber.
		^self sendData: aStringOrByteArray].
	^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! !

!Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:07'!
sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber
	"Send a UDP packet containing the given data to the specified host/port."
	| bytesToSend bytesSent count |

	bytesToSend _ aStringOrByteArray size.
	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		(self waitForSendDoneUntil: (Socket deadlineSecs: 20))
			ifFalse: [self error: 'send data timeout; data not sent'].
		count _ self primSocket: socketHandle
			sendUDPData: aStringOrByteArray
			toHost: hostAddress
			port: portNumber
			startIndex: bytesSent + 1
			count: bytesToSend - bytesSent.
		bytesSent _ bytesSent + count].

	^ bytesSent
! !

!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPeer: hostAddress port: port
	"Set the default send/recv address."

	self primSocket: socketHandle connectTo: hostAddress port: port.
! !

!Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'!
setPort: port
	"Associate a local port number with a UDP socket.  Not applicable to TCP sockets."

	self primSocket: socketHandle setPort: port.
! !


!Socket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'!
getOption: aName 
	"Get options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is an status number (0 ok, -1 read only option)
	element two is the resulting of the requested option"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [self error: 'Socket status must valid before getting an option'].
	^self primSocket: socketHandle getOption: aName

"| foo options |
Socket initializeNetwork.
foo _ Socket newTCP.
foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80.
foo waitForConnectionUntil: (Socket standardDeadline).

options _ {
'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'.
'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'.
'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'.
'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'.
'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'.
'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'.
'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. 
'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'.
'TCP_URGENT_PTR_TYPE'}.

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].

foo _ Socket newUDP.
foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7.
foo waitForConnectionUntil: (Socket standardDeadline).

1 to: options size do: [:i | | fum |
	fum _foo getOption: (options at: i).
	Transcript show: (options at: i),fum printString;cr].
"! !

!Socket methodsFor: 'other' stamp: 'ar 4/30/1999 06:00'!
getResponseNoLF
	"Get the response to the last command."

	| buf response bytesRead c lf |
	(self waitForDataUntil: (Socket deadlineSecs: 20)) ifFalse: [
		self error: 'getResponse timeout'].
	lf _ Character lf.
	buf _ String new: 1000.
	response _ WriteStream on: ''.
	[self dataAvailable] whileTrue: [
		bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size.
		1 to: bytesRead do: [ :i |
			(c _ buf at: i) ~= lf ifTrue: [response nextPut: c]]].

	^ response contents
! !

!Socket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'!
setOption: aName value: aValue 
	| value |
	"setup options on this socket, see Unix man pages for values for 
	sockets, IP, TCP, UDP. IE SO_KEEPALIVE
	returns an array, element one is the error number
	element two is the resulting of the negotiated value.
	See getOption for list of keys"

	(socketHandle == nil or: [self isValid not])
		ifTrue: [self error: 'Socket status must valid before setting an option'].
	value _ aValue asString.
	aValue == true ifTrue: [value _ '1'].
	aValue == false ifTrue: [value _ '0'].
	^ self primSocket: socketHandle setOption: aName value: value! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Socket class
	instanceVariableNames: ''!

!Socket class methodsFor: 'class initialization' stamp: 'ar 4/30/1999 04:12'!
initialize
	"Socket initialize"

	"Socket Types"
	TCPSocketType _ 0.
	UDPSocketType _ 1.

	"Socket Status Values"
	InvalidSocket _ -1.
	Unconnected _ 0.
	WaitingForConnection _ 1.
	Connected _ 2.
	OtherEndClosed _ 3.
	ThisEndClosed _ 4.
! !


!Socket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:45'!
acceptFrom: aSocket
	^[ super new acceptFrom: aSocket ]
		repeatWithGCIf: [ :sock | sock isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:15'!
createIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."
	"Note: The default creates a TCP socket"
	^self tcpCreateIfFail: failBlock! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:13'!
new
	"Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release."
	"Note: The default creates a TCP socket - this is also backward compatibility."
	^self newTCP! !

!Socket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 10:19'!
newTCP
	"Create a socket and initialise it for TCP"
	^[ super new initialize: TCPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'ls 9/24/1999 09:44'!
newUDP
	"Create a socket and initialise it for UDP"
	^[ super new initialize: UDPSocketType ]
		repeatWithGCIf: [ :socket | socket isValid not ]! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'!
tcpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	sock _ super new initialize: TCPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !

!Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'!
udpCreateIfFail: failBlock
	"Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket."

	| sock |
	sock _ super new initialize: UDPSocketType.
	sock isValid ifFalse: [^ failBlock value].
	^ sock
! !


!Socket class methodsFor: 'network initialization' stamp: 'jm 3/9/98 13:13'!
ensureNetworkConnected
	"Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection."
	"Socket ensureNetworkConnected"

	Socket initializeNetwork.
	Utilities
		informUser: 'Contacting domain name server...'
		during: [
			NetNameResolver
				addressForName: 'bogusNameToForceDNSToBeConsulted.org'
				timeout: 30].
! !

!Socket class methodsFor: 'network initialization' stamp: 'jm 3/9/98 13:13'!
initializeNetwork
	"Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized."
	"Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. "

	NetNameResolver initializeNetworkIfFail:
		[self error: 'Cannot open network; is it connected?'].
! !

!Socket class methodsFor: 'network initialization' stamp: 'jm 3/9/98 13:15'!
initializeNetworkIfFail: failBlock
	"Initialize the network drivers. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails, perhaps because this computer isn't currently connected to a network."

	NetNameResolver initializeNetworkIfFail: failBlock.
! !


!Socket class methodsFor: 'tests' stamp: 'JMM 5/19/2000 22:13'!
loopbackTest
	"Send data from one socket to another on the local machine. Tests most of the socket primitives."
	"100 timesRepeat: [Socket loopbackTest]"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead |
	Transcript cr; show: 'starting loopback test'; cr.

	Transcript show: '---------- Connecting ----------'; cr.
	Socket initializeNetwork.
	sock1 _ Socket new.
	sock2 _ Socket new.
	sock1 listenOn: 54321.
	sock2 connectTo: (NetNameResolver localHostAddress) port: 54321.
	sock1 waitForConnectionUntil: self standardDeadline.
	sock2 waitForConnectionUntil: self standardDeadline.
	(sock1 isConnected) ifFalse: [self error: 'sock1 not connected'].
	(sock2 isConnected) ifFalse: [self error: 'sock2 not connected'].
	Transcript show: 'connection established'; cr.

	bytesToSend _ 5000000.
	sendBuf _ String new: 5000 withAll: $x.
	receiveBuf _ String new: 50000.
	done _ false.
	packetsSent _ packetsRead _ bytesSent _ bytesReceived _ 0.
	t _ Time millisecondsToRun: [
		[done] whileFalse: [
			(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [
				packetsSent _ packetsSent + 1.
				bytesSent _ bytesSent + (sock1 sendSomeData: sendBuf)].
			sock2 dataAvailable ifTrue: [
				packetsRead _ packetsRead + 1.
				bytesReceived _ bytesReceived +
					(sock2 receiveDataInto: receiveBuf)].
			done _ (bytesSent >= bytesToSend) and: [bytesReceived = bytesSent]]].
	
	Transcript show: 'closing connection'; cr.
	sock1 waitForSendDoneUntil: self standardDeadline.
	sock1 close.
	sock2 waitForDisconnectionUntil: self standardDeadline.
	extraBytes _ sock2 discardReceivedData.
	extraBytes > 0 ifTrue: [
		Transcript show: ' *** received ', extraBytes size printString, ' extra bytes ***'; cr.
	].
	sock2 close.
	sock1 waitForDisconnectionUntil: self standardDeadline.
	(sock1 isUnconnectedOrInvalid) ifFalse: [self error: 'sock1 not closed'].
	(sock2 isUnconnectedOrInvalid) ifFalse: [self error: 'sock2 not closed'].
	Transcript show: '---------- Connection Closed ----------'; cr.

	sock1 destroy.
	sock2 destroy.
	Transcript show: 'loopback test done; time = ', t printString; cr.
	Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' 1000Bytes/sec'; cr.
	Transcript endEntry.
! !

!Socket class methodsFor: 'tests' stamp: 'RAA 7/16/2000 10:03'!
newAcceptCheck
"
Socket newAcceptCheck
"
	| socket |

	self initializeNetwork.
	socket _ self newTCP.
	socket listenOn: 44444 backlogSize: 4.
	socket isValid ifTrue: [
		self inform: 'Everything looks OK for the BSD style accept()'
	] ifFalse: [
		self inform: 'It appears that you DO NOT have support for the BSD style accept()'
	].
	socket destroy.
! !

!Socket class methodsFor: 'tests' stamp: 'JMM 5/22/2000 23:06'!
sendTest
	"Send data to the 'discard' socket of the given host. Tests the speed of one-way data transfers across the network to the given host. Note that many host hosts do not run a discard server."
	"Socket sendTest"

	| sock bytesToSend sendBuf bytesSent t serverName serverAddr |
	Transcript cr; show: 'starting send test'; cr.
	Socket initializeNetwork.
	serverName _ FillInTheBlank
		request: 'What is the destination server?'
		initialAnswer: 'create.ucsb.edu'.
	serverAddr _ NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', serverName].

	sock _ Socket new.
	Transcript show: '---------- Connecting ----------'; cr.
	sock connectTo: serverAddr port: 9.
	sock waitForConnectionUntil: self standardDeadline.
	(sock isConnected) ifFalse: [
		sock destroy.
		^ self inform: 'could not connect'].
	Transcript show: 'connection established; sending data'; cr.

	bytesToSend _ 1000000.
	sendBuf _ String new: 64*1024 withAll: $x.
	bytesSent _ 0.
	t _ Time millisecondsToRun: [
		[bytesSent < bytesToSend] whileTrue: [
			sock sendDone ifTrue: [
				bytesSent _ bytesSent + (sock sendSomeData: sendBuf)]]].
	sock waitForSendDoneUntil: self standardDeadline.
	sock destroy.
	Transcript show: '---------- Connection Closed ----------'; cr.
	Transcript show: 'send test done; time = ', t printString; cr.
	Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' 1000Bytes/sec'; cr.
	Transcript endEntry.
! !


!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:54'!
deadServer

	^ DeadServer! !

!Socket class methodsFor: 'utilities' stamp: 'tk 4/9/98 15:56'!
deadServer: aStringOrNil
	"Keep the machine name of the most recently encoutered non-responding machine.  Next time the user can move it to the last in a list of servers to try."

	DeadServer _ aStringOrNil! !

!Socket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!
deadlineSecs: secs
	"Return a deadline time the given number of seconds from now."

	^ Time millisecondClockValue + (secs * 1000)
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 12:13'!
nameForWellKnownTCPPort: portNum
	"Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known."

	| portList entry |
	portList _ #(
		(7 'echo') (9 'discard') (13 'time') (19 'characterGenerator')
		(21 'ftp') (23 'telnet') (25 'smtp')
		(80 'http') (110 'pop3') (119 'nntp')).
	entry _ portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString].
	^ entry last
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 11/23/1998 17:19'!
ping: hostName
	"Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server."
	"Socket ping: 'squeak.cs.uiuc.edu'"

	| tcpPort sock serverAddr startTime echoTime |
	tcpPort _ 7.  "7 = echo port, 13 = time port, 19 = character generator port"
	Socket initializeNetwork.
	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil ifTrue: [
		^ self inform: 'Could not find an address for ', hostName].

	sock _ Socket new.
	sock connectTo: serverAddr port: tcpPort.
	[sock waitForConnectionUntil: (Socket deadlineSecs: 10).
	 sock isConnected] whileFalse: [
		(self confirm: 'Continue to wait for connection to ', hostName, '?') ifFalse: [
			sock destroy.
			^ self]].

	sock sendData: 'echo!!'.
	startTime _ Time millisecondClockValue.
	[sock waitForDataUntil: (Socket deadlineSecs: 15).
	 sock dataAvailable] whileFalse: [
		(self confirm: 'Packet sent but no echo yet; keep waiting?') ifFalse: [
			sock destroy.
			^ self]].
	echoTime _ Time millisecondClockValue - startTime.

	sock destroy.
	self inform: hostName, ' responded in ', echoTime printString, ' milliseconds'.
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:24'!
pingPorts: portList on: hostName timeOutSecs: timeOutSecs
	"Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports."
	"Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15"

	| serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result |
	Socket initializeNetwork.
	serverAddr _ NetNameResolver addressForName: hostName timeout: 10.
	serverAddr = nil ifTrue: [
		self inform: 'Could not find an address for ', hostName.
		^ #()].

	sockets _ portList collect: [:portNum |
		sock _ Socket new.
		sock connectTo: serverAddr port: portNum].

	deadline _ self deadlineSecs: timeOutSecs.
	done _ false.
	[done] whileFalse: [
		unconnectedCount _ 0.
		connectedCount _ 0.
		waitingCount _ 0.
		sockets do: [:s |
			s isUnconnectedOrInvalid
				ifTrue: [unconnectedCount _ unconnectedCount + 1]
				ifFalse: [
					s isConnected ifTrue: [connectedCount _ connectedCount + 1].
					s isWaitingForConnection ifTrue: [waitingCount _ waitingCount + 1]]].
		waitingCount = 0 ifTrue: [done _ true].
		connectedCount = sockets size ifTrue: [done _ true].
		Time millisecondClockValue > deadline ifTrue: [done _ true]].

	result _ (sockets select: [:s | s isConnected])
		collect: [:s | self nameForWellKnownTCPPort: s remotePort].
	sockets do: [:s | s destroy].
	^ result
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:25'!
pingPortsOn: hostName
	"Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports."
	"Socket pingPortsOn: 'www.disney.com'"

	^ Socket
		pingPorts: #(7 13 19 21 23 25 80 110 119)
		on: hostName
		timeOutSecs: 20
! !

!Socket class methodsFor: 'utilities' stamp: 'jm 9/15/97 06:56'!
standardDeadline
	"Return a default deadline time some seconds into the future."

	^ self deadlineSecs: 45
! !

!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardAddress
	"Answer a don't-care address for use with UDP sockets."

	^ByteArray new: 4		"0.0.0.0"! !

!Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'!
wildcardPort
	"Answer a don't-care port for use with UDP sockets.  (The system will allocate an
	unused port number to the socket.)"

	^0! !


!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:22'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !


!Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 21:38'!
clientServerTestUDP
	"Socket clientServerTestUDP"

	"Performa 6400/200, Linux-PPC 2.1.24:
		client/server UDP test done; time = 2820
		2500 packets, 10000000 bytes sent (3546 kBytes/sec)
		2500 packets, 10000000 bytes received (3546 kBytes/sec)
		4000 bytes/packet, 886 packets/sec, 0 packets dropped"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t |
	Transcript show: 'starting client/server UDP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	Transcript show: 'creating endpoints'; cr.
	sock1 _ Socket newUDP.	"the sender"
	sock2 _ Socket newUDP.	"the recipient"
	sock2 setPort: 54321.
	sock1 setPeer: (NetNameResolver localHostAddress) port: (sock2 port).
	Transcript show: 'endpoints created'; cr.

	bytesToSend _ 10000000.
	sendBuf _ String new: 4000 withAll: $x.
	receiveBuf _ String new: 50000.
	done _ false.
	bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0.
	t _ Time millisecondsToRun: [
		[done] whileFalse: [
			(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [
				packetsSent _ packetsSent + 1.
				bytesSent _ bytesSent + (sock1 sendData: sendBuf)].
			sock2 dataAvailable ifTrue: [
				packetsReceived _ packetsReceived + 1.
				bytesReceived _ bytesReceived +
					(sock2 receiveDataInto: receiveBuf)].
			done _ (bytesSent >= bytesToSend)].
		sock1 waitForSendDoneUntil: self standardDeadline.
		bytesReceived _ bytesReceived + sock2 discardReceivedData].

	Transcript show: 'closing endpoints'; cr.
	sock1 close.
	sock2 close.
	sock1 destroy.
	sock2 destroy.
	Transcript show: 'client/server UDP test done; time = ', t printString; cr.
	Transcript show: packetsSent printString, ' packets, ',
						bytesSent printString, ' bytes sent (',
						(bytesSent * 1000 // t) printString, ' Bytes/sec)'; cr.
	Transcript show: packetsReceived printString, ' packets, ',
						bytesReceived printString, ' bytes received (',
						(bytesReceived * 1000 // t) printString, ' Bytes/sec)'; cr.
	Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ',
						(packetsReceived * 1000 // t) printString, ' packets/sec, ',
						(packetsSent - packetsReceived) printString, ' packets dropped'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/28/2000 23:18'!
clientServerTestUDP2
	"Socket clientServerTestUDP2"

	| sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t datagramInfo |
	Transcript show: 'starting client/server UDP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	Transcript show: 'creating endpoints'; cr.
	sock1 _ Socket newUDP.	"the sender"
	sock2 _ Socket newUDP.	"the recipient"
	sock2 setPort: 54321.
	Transcript show: 'endpoints created'; cr.

	bytesToSend _ 100000000.
	sendBuf _ String new: 4000 withAll: $x.
	receiveBuf _ String new: 2000.
	done _ false.
	bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0.
	t _ Time millisecondsToRun: [
		[done] whileFalse: [
			(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [
				packetsSent _ packetsSent + 1.
				bytesSent _ bytesSent + (sock1 sendData: sendBuf toHost: (NetNameResolver localHostAddress) port: (sock2 port))].	
			sock2 dataAvailable ifTrue: [
				packetsReceived _ packetsReceived + 1.
				datagramInfo _ sock2 receiveUDPDataInto: receiveBuf.
				bytesReceived _ bytesReceived + (datagramInfo at: 1)].
			done _ (bytesSent >= bytesToSend)].
		sock1 waitForSendDoneUntil: self standardDeadline.
		bytesReceived _ bytesReceived + sock2 discardReceivedData].

	Transcript show: 'closing endpoints'; cr.
	sock1 close.
	sock2 close.
	sock1 destroy.
	sock2 destroy.
	Transcript show: 'client/server UDP test done; time = ', t printString; cr.
	Transcript show: packetsSent printString, ' packets, ',
						bytesSent printString, ' bytes sent (',
						(bytesSent * 1000 // t) printString, ' Bytes/sec)'; cr.
	Transcript show: packetsReceived printString, ' packets, ',
						bytesReceived printString, ' bytes received (',
						(bytesReceived * 1000 // t) printString, ' Bytes/sec)'; cr.
	Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ',
						(packetsReceived * 1000 // t) printString, ' packets/sec, ',
						(packetsSent - packetsReceived) printString, ' packets dropped'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 21:41'!
remoteTestClientTCP
	"FIRST start up another image, and execute: Socket remoteTestServerTCP.
	THEN come back to this image and execute:"
			"Socket remoteTestClientTCP"

	"Performa 6400/200, Linux-PPC 2.1.24, both images on same CPU:
		remoteClient TCP test done; time = 5680
		250 packets, 1000000 bytes sent (176 kBytes/sec)
		60 packets, 1000000 bytes received (176 kBytes/sec)"

	| socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName |
	Transcript show: 'starting client/server TCP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	socket _ Socket newTCP.
	serverName _ FillInTheBlank
		request: 'What is your remote Test Server?'
		initialAnswer: ''.
	socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321.
	socket waitForConnectionUntil: Socket standardDeadline.
	Transcript show: 'client endpoint created'; cr.
	bytesToSend _ 1000000.
	sendBuf _ String new: 4000 withAll: $x.
	receiveBuf _ String new: 50000.
	done _ false.
	bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0.
	t _ Time millisecondsToRun: [
		[done] whileFalse:
			[(socket sendDone and: [bytesSent < bytesToSend]) ifTrue:
				[packetsSent _ packetsSent + 1.
				bytesSent _ bytesSent + (socket sendData: sendBuf)].
			socket dataAvailable ifTrue:
				[packetsReceived _ packetsReceived + 1.
				bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)].
			done _ (bytesSent >= bytesToSend)].
		[bytesReceived < bytesToSend] whileTrue:
			[socket dataAvailable ifTrue:
				[packetsReceived _ packetsReceived + 1.
				bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]]].
	socket closeAndDestroy.
	Transcript show: 'remoteClient TCP test done; time = ', t printString; cr.
	Transcript show: packetsSent printString, ' packets, ',
						bytesSent printString, ' bytes sent (',
						(bytesSent * 1000 // t) printString, ' bytes/sec)'; cr.
	Transcript show: packetsReceived printString, ' packets, ',
						bytesReceived printString, ' bytes received (',
						(bytesReceived * 1000 // t) printString, ' bytes/sec)'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:08'!
remoteTestClientTCPOpenClose1000
	"Socket remoteTestClientTCPOpenClose1000"
	| number t1 socket serverName |
	Transcript show: 'starting client/server TCP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	number _ 1000.
	serverName _ FillInTheBlank
		request: 'What is your remote Test Server?'
		initialAnswer: ''.
	t1 _ Time millisecondsToRun: 
		[number timesRepeat: 
		[socket _ Socket newTCP.
		socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321.
		socket waitForConnectionUntil: Socket standardDeadline.
		socket closeAndDestroy]].
	Transcript cr;show: 'connects/close per second ', ((number/t1*1000.0) printString); cr.

! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/21/2000 14:13'!
remoteTestClientTCPOpenClosePutGet
	"Socket remoteTestClientTCPOpenClosePutGet"

	| checkLength number bytesExpected sendBuf receiveBuf t1 socket bytesReceived serverName | 

	Transcript show: 'starting client/server TCP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your remote Test Server?'
		initialAnswer: ''.
	number _ 1000.	
	bytesExpected _ 20000.
	sendBuf _ String new: 80 withAll: $x.
	receiveBuf _ String new: 50000.
	t1 _ Time millisecondsToRun: 
		[number timesRepeat: 
		[socket _ Socket newTCP.
		socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321.
		socket waitForConnectionUntil: Socket standardDeadline.
		socket sendData: sendBuf.
		socket waitForSendDoneUntil: (Socket deadlineSecs: 5).
		socket waitForDataUntil: (Socket deadlineSecs: 5).
		bytesReceived _ 0.
		[bytesReceived < bytesExpected] whileTrue:
			[checkLength _ socket receiveDataInto: receiveBuf.
			bytesReceived _ bytesReceived + checkLength].
		socket closeAndDestroy]].
	Transcript cr;show: 'connects/get/put/close per second ', ((number/t1*1000.0) printString); cr.

! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 14:38'!
remoteTestClientUDP
	"FIRST start up another image, and execute: Socket remoteTestServerUDP.
	THEN come back to this image and execute:"
			"Socket remoteTestClientUDP"

	"Performa 6400/200, Linux-PPC 2.1.24:
		remoteClient UDP test done; time = 4580
		2500 packets, 10000000 bytes sent (2183 kBytes/sec)
		180 packets, 720000 bytes received (157 kBytes/sec)
		4000 bytes/packet, 39 packets/sec, 2320 packets dropped"

	| socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName |
	Transcript show: 'starting client/server UDP test'; cr.
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your remote Test Server?'
		initialAnswer: ''.
	socket _ Socket newUDP.
	socket setPeer: (NetNameResolver addressFromString: serverName) port: 54321.
	Transcript show: 'client endpoint created'; cr.
	bytesToSend _ 10000000.
	sendBuf _ String new: 4000 withAll: $x.
	receiveBuf _ String new: 4000.
	done _ false.
	bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0.
	t _ Time millisecondsToRun: [
		[done] whileFalse:
			[(socket sendDone and: [bytesSent < bytesToSend]) ifTrue:
				[packetsSent _ packetsSent + 1.
				bytesSent _ bytesSent + (socket sendData: sendBuf)].
			socket dataAvailable ifTrue:
				[packetsReceived _ packetsReceived + 1.
				bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)].
			done _ (bytesSent >= bytesToSend)].
	[socket waitForDataUntil: (Socket deadlineSecs: 1).
	socket dataAvailable] whileTrue:
		[packetsReceived _ packetsReceived + 1.
		bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]].
	socket closeAndDestroy.
	Transcript show: 'remoteClient UDP test done; time = ', t printString; cr.
	Transcript show: packetsSent printString, ' packets, ',
						bytesSent printString, ' bytes sent (',
						(bytesSent * 1000 // t) printString, ' bytes/sec)'; cr.
	Transcript show: packetsReceived printString, ' packets, ',
						bytesReceived printString, ' bytes received (',
						(bytesReceived * 1000 // t) printString, ' bytes/sec)'; cr.
	Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ',
						(packetsReceived * 1000 // t) printString, ' packets/sec, ',
						(packetsSent - packetsReceived) printString, ' packets dropped'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:04'!
remoteTestServerTCP
	"See remoteTestClientTCP for instructions on running this method."
	"Socket remoteTestServerTCP"

	| socket buffer n |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	socket _ Socket newTCP.
	socket listenOn: 54321.
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	buffer _ String new: 4000.
	socket waitForConnectionUntil: self standardDeadline.
	[socket isConnected] whileTrue: [
		socket dataAvailable ifTrue:
			[n _ socket	receiveDataInto: buffer.
			socket sendData: buffer count: n]].
	socket closeAndDestroy.
	Transcript cr; show: 'server endpoint destroyed'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:12'!
remoteTestServerTCPOpenClose1000
	"The version of #remoteTestServerTCPOpenClose1000 using the BSD style accept() mechanism."
	"Socket remoteTestServerTCPOpenClose1000"

	| socket server |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	server _ Socket newTCP.
	server listenOn: 54321 backlogSize: 20.
	server isValid ifFalse:[self error:'Accept() is not supported'].
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	1000 timesRepeat: 
		[socket _ server waitForAcceptUntil: (Socket deadlineSecs: 300).
		socket closeAndDestroy].
	server closeAndDestroy.
	Transcript cr; show: 'server endpoint destroyed'; cr.
! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:12'!
remoteTestServerTCPOpenClosePutGet	
	"The version of #remoteTestServerTCPOpenClosePutGet using the BSD style accept() mechanism."
	"Socket remoteTestServerTCPOpenClosePutGet"

	| socket server bytesIWantToSend bytesExpected receiveBuf sendBuf checkLength |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	server _ Socket newTCP.
	server listenOn: 54321 backlogSize: 20.
	server isValid ifFalse:[self error:'Accept() is not supported'].
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	bytesIWantToSend _ 20000.
	bytesExpected _ 80.
	receiveBuf _ String new: 40000.
	sendBuf _ String new: bytesIWantToSend withAll: $x.
	1000 timesRepeat: 
		[socket _ server waitForAcceptUntil: (Socket deadlineSecs: 300).
		socket waitForDataUntil: (Socket deadlineSecs: 5).
		checkLength _ socket receiveDataInto: receiveBuf.
		(checkLength ~= bytesExpected) ifTrue: [self halt].
		socket sendData: sendBuf.
		socket waitForSendDoneUntil: (Socket deadlineSecs: 5).		
		socket closeAndDestroy].
	server closeAndDestroy.
	Transcript cr; show: 'server endpoint destroyed'; cr.
! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:09'!
remoteTestServerTCPUsingAccept
	"The version of #remoteTestServer using the BSD style accept() mechanism."
	"Socket remoteTestServerTCPUsingAccept"

	| socket buffer n server |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	server _ Socket newTCP.
	server listenOn: 54321 backlogSize: 4.
	server isValid ifFalse:[self error:'Accept() is not supported'].
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	buffer _ String new: 40000.
	10 timesRepeat: 
		[socket _ server waitForAcceptUntil: (self deadlineSecs: 300).
		[socket isConnected] whileTrue: [ 
			socket dataAvailable ifTrue:
				[n _ socket	receiveDataInto: buffer.
				socket sendData: buffer count: n]]].
	socket closeAndDestroy.
	server closeAndDestroy.
	Transcript cr; show: 'server endpoint destroyed'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:25'!
remoteTestServerUDP
	"See remoteTestClientUDP for instructions on running this method."
	"Socket remoteTestServerUDP"

	| socket buffer n |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	socket _ Socket newUDP.
	socket setPort: 54321.
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	buffer _ String new: 4000.
	[true] whileTrue: [
		socket dataAvailable ifTrue:
			[n _ socket	receiveDataInto: buffer.
				socket sendData: buffer count: n]].
! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/24/2000 21:55'!
remoteTestServerUDP2
	"See remoteTestClientUDP for instructions on running this method."
	"Socket remoteTestServerUDP2"

	| socket buffer datagramInfo |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	socket _ Socket newUDP.
	socket setPort: 54321.
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	buffer _ String new: 65000.
	[true] whileTrue: [
		socket dataAvailable ifTrue:
			[datagramInfo _ socket receiveUDPDataInto: buffer. 
			Transcript show: datagramInfo printString;cr.
				socket sendData: buffer count: (datagramInfo at: 1)]].
! !

!Socket class methodsFor: 'examples' stamp: 'JMM 5/17/2000 19:54'!
remoteTestSinkTCP
	"See sendTest for instructions on running this method."
	"Socket remoteTestSinkTCP"

	| socket buffer n |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	socket _ Socket newTCP.
	socket listenOn: 9.
	Transcript show: 'server endpoint created -- run client test in other image'; cr.
	buffer _ String new: 64000.
	socket waitForConnectionUntil: self standardDeadline.
	[socket isConnected] whileTrue: [
		socket dataAvailable ifTrue:
			[n _ socket	receiveDataInto: buffer]].
	socket closeAndDestroy.
	Transcript cr; show: 'sink endpoint destroyed'; cr.! !

!Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:57'!
timeTest
	"Socket timeTest"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your time server?'
		initialAnswer: 'localhost'.
	serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr].
	serverAddr _ NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName].

	s _ Socket new.
	Transcript show: '---------- Connecting ----------'; cr.
	s connectTo: serverAddr port: 13.  "13 is the 'daytime' port number"
	s waitForConnectionUntil: (self deadlineSecs: 1).
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript show: '---------- Connection Closed ----------'; cr.
! !

!Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:57'!
timeTestUDP
	"Socket timeTestUDP"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your time server?'
		initialAnswer: 'localhost'.
	serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr].
	serverAddr _ NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName].

	s _ Socket newUDP.		"a 'random' port number will be allocated by the system"
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr.
	s sendData: '!!' toHost: serverAddr port: 13.	"13 is the daytime service"
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript show: '---------- Socket closed ----------'; cr.
! !

!Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:58'!
timeTestUDP2
	"Socket timeTestUDP2"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your time server?'
		initialAnswer: 'localhost'.
	serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr].
	serverAddr _ NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName].

	s _ Socket newUDP.
	"The following associates a port with the UDP socket, but does NOT create a connectable endpoint"
	s setPort: 54321.
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr.
	s sendData: '!!' toHost: serverAddr port: 13.
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript show: '---------- Socket closed ----------'; cr.
! !

!Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:59'!
timeTestUDP3
	"Socket timeTestUDP3"

	| serverName serverAddr s |
	Transcript show: 'initializing network ... '.
	Socket initializeNetworkIfFail: [^Transcript show:'failed'].
	Transcript show:'ok';cr.
	serverName _ FillInTheBlank
		request: 'What is your time server?'
		initialAnswer: 'localhost'.
	serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr].
	serverAddr _ NetNameResolver addressForName: serverName timeout: 10.
	serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName].

	s _ Socket newUDP.
	"The following associates a port with the UDP socket, but does NOT create a connectable endpoint"
	s setPort: (Socket wildcardPort).		"explicitly request a default port number"
	"Send a packet to the daytime port and it will reply with the current date."
	Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr.
	s sendData: '!!' toHost: serverAddr port: 13.
	Transcript show: 'the time server reports: ' , s getResponseNoLF.
	s closeAndDestroy.
	Transcript show: '---------- Socket closed ----------'; cr.
! !
TestInterpreterPlugin subclass: #SocketPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!SocketPlugin commentStamp: '<historical>' prior: 0!
Implement the socket and resolver primitives.

I really think it wouldbe worth a minor rewrite to avoid the sq{plat}Socket.c files refering directly back t the VM -- TPR !


!SocketPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:53'!
initialiseModule
	self export: true.
	^self cCode: 'socketInit()' inSmalltalk:[true]! !

!SocketPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:55'!
shutdownModule
	self export: true.
	^self cCode: 'socketShutdown()' inSmalltalk:[true]! !


!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 4/25/2000 14:21'!
intToNetAddress: addr
	"Convert the given 32-bit integer into an internet network address represented as a four-byte ByteArray."

	| netAddressOop naPtr|
	self var: #naPtr declareC: 'char * naPtr'.

	netAddressOop _
		interpreterProxy instantiateClass: interpreterProxy classByteArray
			indexableSize: 4.
	naPtr _ netAddressOop asCharPtr.
	naPtr at: 0 put: (self cCoerce: ((addr >> 24) bitAnd: 16rFF) to: 'char').
	naPtr at: 1 put: (self cCoerce: ((addr >> 16) bitAnd: 16rFF) to: 'char').
	naPtr at: 2 put: (self cCoerce: ((addr >> 8) bitAnd: 16rFF) to: 'char').
	naPtr at: 3 put: (self cCoerce: (addr bitAnd: 16rFF) to: 'char').
	^ netAddressOop! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 4/24/2000 17:18'!
netAddressToInt: ptrToByteArray
	"Convert the given internet network address (represented as a four-byte ByteArray) into a 32-bit integer. Fail if the given ptrToByteArray does not appear to point to a four-byte ByteArray."

	| sz |
	self var: #ptrToByteArray declareC: 'unsigned char * ptrToByteArray'.
	sz _ interpreterProxy byteSizeOf: ptrToByteArray cPtrAsOop.
	sz = 4 ifFalse: [^ interpreterProxy primitiveFail].
	^ (ptrToByteArray at: 3	) +
		((ptrToByteArray at: 2) <<8) +
		((ptrToByteArray at: 1) <<16) +
		((ptrToByteArray at: 0) <<24)! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:39'!
primitiveInitializeNetwork: resolverSemaIndex

	| err |
	self primitive: 'primitiveInitializeNetwork'
		parameters: #(SmallInteger).
	err _ self sqNetworkInit: resolverSemaIndex.
	interpreterProxy success: err = 0! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 11:47'!
primitiveResolverAbortLookup

	self primitive: 'primitiveResolverAbortLookup'.

	self sqResolverAbort! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:47'!
primitiveResolverAddressLookupResult
	| sz s |
	self primitive: 'primitiveResolverAddressLookupResult'.
	sz _ self sqResolverAddrLookupResultSize.

	interpreterProxy failed
		ifFalse: [s _ interpreterProxy instantiateClass: interpreterProxy classString indexableSize: sz.
			self sqResolverAddrLookup: s asCharPtr Result: sz].
	^ s! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:10'!
primitiveResolverError

	self primitive: 'primitiveResolverError'.
	^ self sqResolverError asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:10'!
primitiveResolverLocalAddress

	| addr |
	self primitive: 'primitiveResolverLocalAddress'.
	addr _ self sqResolverLocalAddress.
	^self intToNetAddress: addr! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:11'!
primitiveResolverNameLookupResult

	| addr |
	self primitive: 'primitiveResolverNameLookupResult'.
	addr _ self sqResolverNameLookupResult.
	^self intToNetAddress: addr! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 4/25/2000 14:42'!
primitiveResolverStartAddressLookup: address

	| addr |
	self primitive: 'primitiveResolverStartAddressLookup'
		parameters: #(ByteArray).
	addr _ self netAddressToInt: (self cCoerce: address to: 'unsigned char *').
	interpreterProxy failed ifFalse: [
		self sqResolverStartAddrLookup: addr]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:19'!
primitiveResolverStartNameLookup: name

	| sz |
	self primitive: 'primitiveResolverStartNameLookup'
		parameters: #(String).
	interpreterProxy failed ifFalse:  [
		sz _ interpreterProxy byteSizeOf: name cPtrAsOop.
		self sqResolverStartName: name Lookup: sz]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:20'!
primitiveResolverStatus

	| status |
	self primitive: 'primitiveResolverStatus'.
	status _ self sqResolverStatus.
	^status asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 4/25/2000 14:42'!
primitiveSocket: socket connectTo: address port: port

	| addr s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketConnectToPort'
		parameters: #(Oop ByteArray SmallInteger).

	addr _ self netAddressToInt: (self cCoerce: address to: 'unsigned char *').
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocket: s ConnectTo: addr Port: port]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/30/2000 17:05'!
primitiveSocket: socket getOptions: optionName

	| s optionNameStart optionNameSize returnedValue errorCode results |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketGetOptions'
		parameters: #(Oop Oop).

	s _ self socketValueOf: socket.
	interpreterProxy success: (interpreterProxy isBytes: optionName).
	optionNameStart _ self cCoerce: (interpreterProxy firstIndexableField: optionName) to: 'int'.
	optionNameSize _ interpreterProxy slotSizeOf: optionName.

	interpreterProxy failed ifTrue: [^nil].
	returnedValue _ 0.

	errorCode _ self sqSocketGetOptions: s 
			optionNameStart: optionNameStart 
			optionNameSize: optionNameSize
			returnedValue: (self cCode: '&returnedValue').

	interpreterProxy pushRemappableOop: returnedValue asSmallIntegerObj.
	interpreterProxy pushRemappableOop: errorCode asSmallIntegerObj.
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:34'!
primitiveSocket: socket listenOnPort: port
"one part of the wierdass dual prim primitiveSocketListenOnPort which was warped by some demented evil person determined to twist the very nature of reality"
	| s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketListenOnPort'
		parameters: #(Oop SmallInteger).
	s _ self socketValueOf: socket.
	self sqSocket: s ListenOnPort: port.! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:35'!
primitiveSocket: socket listenOnPort: port backlogSize: backlog
"second part of the wierdass dual prim primitiveSocketListenOnPort which was warped by some demented evil person determined to twist the very nature of reality"
	| s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketListenOnPortBacklog'
		parameters: #(Oop SmallInteger SmallInteger).
	s _ self socketValueOf: socket.
	self sqSocket: s ListenOnPort: port BacklogSize: backlog.! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:53'!
primitiveSocket: socket receiveDataBuf: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesReceived |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketReceiveDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s _ self socketValueOf: socket.

	"buffer can be any indexable words or bytes object"
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize _ 4]
		ifFalse: [byteSize _ 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase _ self cCoerce: (interpreterProxy firstIndexableField: array)
						to: 'int'.
			bufStart _ arrayBase + (startIndex - 1 * byteSize).
			bytesReceived _ self
						sqSocket: s
						ReceiveDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesReceived // byteSize) asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:57'!
primitiveSocket: socket receiveUDPDataBuf: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesReceived results address port moreFlag |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketReceiveUDPDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s _ self socketValueOf: socket.

	"buffer can be any indexable words or bytes object"
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize _ 4]
		ifFalse: [byteSize _ 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase _ self cCoerce: (interpreterProxy firstIndexableField: array)
						to: 'int'.
			bufStart _ arrayBase + (startIndex - 1 * byteSize).
			"allocate storage for results, remapping newly allocated
			 oops in case GC happens during allocation"
			address		  _ 0.
			port			  _ 0.
			moreFlag	  _ 0.
			bytesReceived _ self
						sqSocket: s
						ReceiveUDPDataBuf: bufStart
						Count: count * byteSize
						address: (self cCode: '&address')
						port: (self cCode: '&port')
						moreFlag: (self cCode: '&moreFlag').
				
			interpreterProxy pushRemappableOop: port asSmallIntegerObj.
			interpreterProxy pushRemappableOop: (self intToNetAddress: address).
			interpreterProxy pushRemappableOop: (bytesReceived // byteSize) asSmallIntegerObj.
			interpreterProxy pushRemappableOop:
				(interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 4).
			results         _ interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
			interpreterProxy storePointer: 2 ofObject: results withValue: interpreterProxy popRemappableOop.
			moreFlag
				ifTrue: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy trueObject ]
				ifFalse: [ interpreterProxy storePointer: 3 ofObject: results withValue: interpreterProxy falseObject ].
			].
	^ results! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:54'!
primitiveSocket: socket sendData: array start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesSent |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketSendDataBufCount'
		parameters: #(Oop Oop SmallInteger SmallInteger ).
	s _ self socketValueOf: socket.

	"buffer can be any indexable words or bytes object except CompiledMethod "
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize _ 4]
		ifFalse: [byteSize _ 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase _ self cCoerce: (interpreterProxy firstIndexableField: array)
						to: 'int'.
			bufStart _ arrayBase + (startIndex - 1 * byteSize).
			bytesSent _ self
						sqSocket: s
						SendDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesSent // byteSize) asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:22'!
primitiveSocket: socket sendUDPData: array toHost: hostAddress  port: portNumber start: startIndex count: count 
	| s byteSize arrayBase bufStart bytesSent address |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketSendUDPDataBufCount'
		parameters: #(Oop Oop ByteArray SmallInteger SmallInteger SmallInteger ).
	s _ self socketValueOf: socket.

	"buffer can be any indexable words or bytes object except CompiledMethod "
	interpreterProxy success: (interpreterProxy isWordsOrBytes: array).
	(interpreterProxy isWords: array)
		ifTrue: [byteSize _ 4]
		ifFalse: [byteSize _ 1].
	interpreterProxy success: (startIndex >= 1
			and: [count >= 0 and: [startIndex + count - 1 <= (interpreterProxy slotSizeOf: array)]]).
	interpreterProxy failed
		ifFalse: ["Note: adjust bufStart for zero-origin indexing"
			arrayBase _ self cCoerce: (interpreterProxy firstIndexableField: array)
						to: 'int'.
			bufStart _ arrayBase + (startIndex - 1 * byteSize).
			address _ self netAddressToInt: (self cCoerce: hostAddress to: 'unsigned char *').
			bytesSent _ self
						sqSocket: s
						toHost: address
						port: portNumber
						SendDataBuf: bufStart
						Count: count * byteSize].
	^ (bytesSent // byteSize) asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/30/2000 17:05'!
primitiveSocket: socket setOptions: optionName value: optionValue

	| s optionNameStart optionNameSize optionValueStart optionValueSize returnedValue errorCode results |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketSetOptions'
		parameters: #(Oop Oop Oop).

	s _ self socketValueOf: socket.
	interpreterProxy success: (interpreterProxy isBytes: optionName).
	optionNameStart _ self cCoerce: (interpreterProxy firstIndexableField: optionName) to: 'int'.
	optionNameSize _ interpreterProxy slotSizeOf: optionName.
	interpreterProxy success: (interpreterProxy isBytes: optionValue).
	optionValueStart_ self cCoerce: (interpreterProxy firstIndexableField: optionValue) to: 'int'.
	optionValueSize _ interpreterProxy slotSizeOf: optionValue.

	interpreterProxy failed ifTrue: [^nil].
	returnedValue _ 0.

	errorCode _ self sqSocketSetOptions: s 
			optionNameStart: optionNameStart 
			optionNameSize: optionNameSize
			optionValueStart: optionValueStart
			optionValueSize: optionValueSize
			returnedValue: (self cCode: '&returnedValue').

	interpreterProxy pushRemappableOop: returnedValue asSmallIntegerObj.
	interpreterProxy pushRemappableOop: errorCode asSmallIntegerObj.
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:21'!
primitiveSocketAbortConnection: socket

	| s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketAbortConnection'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketAbortConnection: s]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:54'!
primitiveSocketAcceptFrom: sockHandle rcvBufferSize: recvBufSize sndBufSize: sendBufSize semaIndex: semaIndex 
	| socketOop s serverSocket |
	self var: #s declareC: 'SocketPtr s'.
	self var: #serverSocket declareC: 'SocketPtr serverSocket'.
	self primitive: 'primitiveSocketAccept'
		parameters: #(Oop SmallInteger SmallInteger SmallInteger ).
	serverSocket _ self socketValueOf: sockHandle.

	interpreterProxy failed
		ifFalse: [socketOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
			s _ self socketValueOf: socketOop.
			self
				sqSocket: s
				AcceptFrom: serverSocket
				RecvBytes: recvBufSize
				SendBytes: sendBufSize
				SemaID: semaIndex].
	^ socketOop! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/23/2000 22:46'!
primitiveSocketAcceptFrom: sockHandle rcvBufferSize: recvBufSize sndBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema
	| socketOop s serverSocket |
	self var: #s declareC: 'SocketPtr s'.
	self var: #serverSocket declareC: 'SocketPtr serverSocket'.
	self primitive: 'primitiveSocketAccept3Semaphores'
		parameters: #(Oop SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).
	serverSocket _ self socketValueOf: sockHandle.

	interpreterProxy failed
		ifFalse: [socketOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self socketRecordSize.
			s _ self socketValueOf: socketOop.
			self
				sqSocket: s
				AcceptFrom: serverSocket
				RecvBytes: recvBufSize
				SendBytes: sendBufSize
				SemaID: semaIndex
				ReadSemaID: aReadSema
				WriteSemaID: aWriteSema].
	^ socketOop! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:24'!
primitiveSocketCloseConnection: socket

	| s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketCloseConnection'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketCloseConnection: s]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 10:30'!
primitiveSocketConnectionStatus: socket

	| s status |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketConnectionStatus'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		status _ self sqSocketConnectionStatus: s].
	^ status asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:55'!
primitiveSocketCreateNetwork: netType type: socketType receiveBufferSize: recvBufSize sendBufSize: sendBufSize semaIndex: semaIndex


	| socketOop s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketCreate'
		parameters: #(SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).

	socketOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray
					indexableSize: self socketRecordSize.
	s _ self socketValueOf: socketOop.
	self sqSocket: s CreateNetType: netType SocketType: socketType
		RecvBytes: recvBufSize SendBytes: sendBufSize SemaID: semaIndex.
	^socketOop! !

!SocketPlugin methodsFor: 'primitives' stamp: 'JMM 5/23/2000 22:54'!
primitiveSocketCreateNetwork: netType type: socketType receiveBufferSize: recvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema


	| socketOop s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketCreate3Semaphores'
		parameters: #(SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger SmallInteger).

	socketOop _ interpreterProxy instantiateClass: interpreterProxy classByteArray
					indexableSize: self socketRecordSize.
	s _ self socketValueOf: socketOop.
	self sqSocket: s CreateNetType: netType SocketType: socketType
		RecvBytes: recvBufSize SendBytes: sendBufSize SemaID: semaIndex ReadSemaID: aReadSema WriteSemaID: aWriteSema.
	^socketOop! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 12:09'!
primitiveSocketDestroy: socket

	| s |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketDestroy'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		self sqSocketDestroy: s]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/18/2000 12:11'!
primitiveSocketError: socket

	| s err |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketError'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	interpreterProxy failed ifFalse: [
		err _ self sqSocketError: s].
	^err asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'ar 5/24/2000 13:38'!
primitiveSocketListenWithOrWithoutBacklog
	"Backward compatibility"
	self export: true.
	interpreterProxy methodArgumentCount = 2
		ifTrue:[^self primitiveSocketListenOnPort]
		ifFalse:[^self primitiveSocketListenOnPortBacklog]
! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:37'!
primitiveSocketLocalAddress: socket

	| s addr |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketLocalAddress'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	addr _ self sqSocketLocalAddress: s.
	^self intToNetAddress: addr! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:39'!
primitiveSocketLocalPort: socket

	| s port |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketLocalPort'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	port _ self sqSocketLocalPort: s.
	^port asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:42'!
primitiveSocketReceiveDataAvailable: socket

	| s dataIsAvailable |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketReceiveDataAvailable'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	dataIsAvailable _ self sqSocketReceiveDataAvailable: s.
	^dataIsAvailable asBooleanObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:52'!
primitiveSocketRemoteAddress: socket

	| s addr |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketRemoteAddress'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	addr _ self sqSocketRemoteAddress: s.
	^self intToNetAddress: addr! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 11:54'!
primitiveSocketRemotePort: socket

	| s port |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketRemotePort'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	port _ self sqSocketRemotePort: s.
	^port asSmallIntegerObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 17:20'!
primitiveSocketSendDone: socket

	| s done |
	self var: #s declareC: 'SocketPtr s'.
	self primitive: 'primitiveSocketSendDone'
		parameters: #(Oop).
	s _ self socketValueOf: socket.
	done _ self sqSocketSendDone: s.
	^done asBooleanObj! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 2/22/2000 17:26'!
socketRecordSize
	"Return the size of a Smalltalk socket record in bytes."

	^ self cCode: 'sizeof(SQSocket)' inSmalltalk: [12]! !

!SocketPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:55'!
socketValueOf: socketOop 
	"Return a pointer to the first byte of of the socket record within the  
	given Smalltalk object, or nil if socketOop is not a socket record."
	| socketIndex |
	self returnTypeC: 'SQSocket *'.
	interpreterProxy success: ((interpreterProxy isBytes: socketOop)
			and: [(interpreterProxy byteSizeOf: socketOop)
					= self socketRecordSize]).
	interpreterProxy failed
		ifTrue: [^ nil]
		ifFalse: [socketIndex _ self cCoerce: (interpreterProxy firstIndexableField: socketOop)
						to: 'int'.
			^ self cCode: '(SQSocket *) socketIndex']! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SocketPlugin class
	instanceVariableNames: ''!

!SocketPlugin class methodsFor: 'translation' stamp: 'JMM 5/30/2000 17:12'!
headerFile
^'/* squeak socket record; see sqMacNetwork.c for details */

/* module initialization/shutdown */
int socketInit(void);
int socketShutdown(void);

typedef struct {
	int		sessionID;
	int		socketType;  /* 0 = TCP, 1 = UDP */
	void	*privateSocketPtr;
}  SQSocket, *SocketPtr;

/* networking primitives */
int		sqNetworkInit(int resolverSemaIndex);
void	sqNetworkShutdown(void);
void	sqResolverAbort(void);
void	sqResolverAddrLookupResult(char *nameForAddress, int nameSize);
int		sqResolverAddrLookupResultSize(void);
int		sqResolverError(void);
int		sqResolverLocalAddress(void);
int		sqResolverNameLookupResult(void);
void	sqResolverStartAddrLookup(int address);
void	sqResolverStartNameLookup(char *hostName, int nameSize);
int		sqResolverStatus(void);
void	sqSocketAbortConnection(SocketPtr s);
void	sqSocketCloseConnection(SocketPtr s);
int		sqSocketConnectionStatus(SocketPtr s);
void	sqSocketConnectToPort(SocketPtr s, int addr, int port);
void	sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID(
			SocketPtr s, int netType, int socketType,
			int recvBufSize, int sendBufSize, int semaIndex);
void	sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
			SocketPtr s, int netType, int socketType,
			int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex);
void	sqSocketDestroy(SocketPtr s);
int		sqSocketError(SocketPtr s);
void	sqSocketListenOnPort(SocketPtr s, int port);
int		sqSocketLocalAddress(SocketPtr s);
int		sqSocketLocalPort(SocketPtr s);
int		sqSocketReceiveDataAvailable(SocketPtr s);
int		sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize);
int		sqSocketRemoteAddress(SocketPtr s);
int		sqSocketRemotePort(SocketPtr s);
int		sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize);
int		sqSocketSendDone(SocketPtr s);
/* 	ar 7/16/1999: New primitives for accept().
	Note: If accept() calls are not supported simply make the calls fail
	and the old connection style will be used */
void	sqSocketListenOnPortBacklogSize(SocketPtr s, int port, int backlogSize);
void	sqSocketAcceptFromRecvBytesSendBytesSemaID(
			SocketPtr s, SocketPtr serverSocket,
			int recvBufSize, int sendBufSize, int semaIndex);
void	sqSocketAcceptFromRecvBytesSendBytesSemaIDReadSemaIDWriteSemaID(
			SocketPtr s, SocketPtr serverSocket,
			int recvBufSize, int sendBufSize, int semaIndex, int readSemaIndex, int writeSemaIndex);
int 		sqSocketReceiveUDPDataBufCountaddressportmoreFlag(SocketPtr s, int buf, int bufSize,  int *address,  int *port, int *moreFlag);
int		sqSockettoHostportSendDataBufCount(SocketPtr s, int address, int port, int buf, int bufSize);
int     	sqSocketSetOptionsoptionNameStartoptionNameSizeoptionValueStartoptionValueSizereturnedValue(
			SocketPtr s,int optionName, int optionNameSize, int optionValue, int optionValueSize, int *result);
int     	sqSocketGetOptionsoptionNameStartoptionNameSizereturnedValue(
			SocketPtr s,int optionName, int optionNameSize, int *result);
'! !
FillStyle subclass: #SolidFillStyle
	instanceVariableNames: 'color pixelValue32 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-Fills'!

!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:24'!
color: aColor
	color _ aColor.
	pixelValue32 _ aColor scaledPixelValue32! !

!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 03:29'!
display
	^color display! !

!SolidFillStyle methodsFor: 'accessing' stamp: 'ar 1/14/1999 15:25'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	^pixelValue32! !


!SolidFillStyle methodsFor: 'testing' stamp: 'ar 11/8/1998 18:34'!
isSolidFill
	^true! !

!SolidFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:30'!
isTranslucent
	^color isTranslucent! !

!SolidFillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:25'!
isTransparent
	^color isTransparent! !


!SolidFillStyle methodsFor: 'converting' stamp: 'ar 11/9/1998 13:55'!
asColor
	^color! !


!SolidFillStyle methodsFor: 'printing' stamp: 'ar 11/17/1998 00:29'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(; print: color; nextPut:$).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SolidFillStyle class
	instanceVariableNames: ''!

!SolidFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/8/1998 18:31'!
color: aColor
	^self new color: aColor! !
ImageMorph subclass: #Sonogram
	instanceVariableNames: 'lastX scrollDelta columnForm minVal maxVal pixValMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!Sonogram commentStamp: '<historical>' prior: 0!
Sonograms are imageMorphs that will repeatedly plot arrays of values as black on white columns moving to the right in time and scrolling left as necessary.!


!Sonogram methodsFor: 'all' stamp: 'di 8/26/1999 08:59'!
extent: newExtent
	super image: (Form extent: newExtent depth: Display depth).
	lastX _ -1.
	columnForm _ Form extent: (32//image depth)@(image height) depth: image depth.
	pixValMap _ ((1 to: 256) collect:
			[:i | (Color gray: (256-i)/255.0) pixelValueForDepth: columnForm depth])
		as: Bitmap.
! !

!Sonogram methodsFor: 'all' stamp: 'di 8/26/1999 09:01'!
extent: extent minVal: min maxVal: max scrollDelta: d
	minVal _ min.
	maxVal _ max.
	scrollDelta _ d.
	self extent: extent.

" try following with scrolldelta = 1, 20, 200
	| s data |
	s _ Sonogram new extent: 200@50
				minVal: 0.0 maxVal: 1.0 scrollDelta: 20.
	World addMorph: s.
	data _ (1 to: 133) collect: [:i | 0.0].
	1 to: 300 do:
		[:i | data at: (i\\133)+1 put: 1.0.
		s plotColumn: data.
		data at: (i\\133)+1 put: 0.0.
		World doOneCycleNow].
	s delete	
"! !

!Sonogram methodsFor: 'all' stamp: 'jhm 9/16/1999 14:41'!
plotColumn: dataArray

	| chm1 i normVal r |
	columnForm unhibernate.
	chm1 _ columnForm height - 1.
	0 to: chm1 do:
		[:y | 
		i _ y*(dataArray size-1)//chm1 + 1.
		normVal _ ((dataArray at: i) - minVal) / (maxVal - minVal).
		normVal < 0.0 ifTrue: [normVal _ 0.0].
		normVal > 1.0 ifTrue: [normVal _ 1.0].
		columnForm bits at: chm1-y+1 put: (pixValMap at: (normVal * 255.0) truncated + 1)].
	(lastX _ lastX + 1) > (image width - 1) ifTrue:
		[self scroll].
	image copy: (r _ (lastX@0 extent: 1@image height))
			from: (32//image depth-1)@0
			in: columnForm rule: Form over.
	"self changed."
	self invalidRect: (r translateBy: self position)! !

!Sonogram methodsFor: 'all' stamp: 'di 8/26/1999 00:40'!
scroll
	image copy: (scrollDelta@0 extent: (image width-scrollDelta)@image height)
			from: image to: 0@0 rule: Form over.
	lastX _ lastX - scrollDelta.
	self changed! !
OrderedCollection subclass: #SortedCollection
	instanceVariableNames: 'sortBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
!SortedCollection commentStamp: '<historical>' prior: 0!
I represent a collection of objects ordered by some property of the objects themselves. The ordering is specified in a BlockContext.!


!SortedCollection methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:47'!
at: anInteger put: anObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'accessing' stamp: 'tk 3/28/1999 22:55'!
median
	"Return the middle element, or as close as we can get."

	^ self at: self size + 1 // 2! !

!SortedCollection methodsFor: 'accessing'!
sortBlock
	"Answer the blockContext which is the criterion for sorting elements of 
	the receiver."

	^sortBlock! !

!SortedCollection methodsFor: 'accessing' stamp: 'stp 12/05/1999 07:09'!
sortBlock: aBlock 
	"Make the argument, aBlock, be the criterion for ordering elements of the 
	receiver."

	aBlock
		ifNotNil: [sortBlock := aBlock fixTemps]
		ifNil: [sortBlock := aBlock].
	"The sortBlock must copy its home context, so as to avoid circularities!!"
	"Therefore sortBlocks with side effects may not work right"
	self size > 0 ifTrue: [self reSort]! !


!SortedCollection methodsFor: 'adding' stamp: 'go 4/27/2000 13:19'!
add: newObject
	^ super insert: newObject before: (self indexForInserting: newObject)! !

!SortedCollection methodsFor: 'adding' stamp: 'sma 4/28/2000 18:35'!
addAll: aCollection
	aCollection size > (self size // 3)
		ifTrue:
			[aCollection do: [:each | self addLast: each].
			self reSort]
		ifFalse: [aCollection do: [:each | self add: each]].
	^ aCollection! !

!SortedCollection methodsFor: 'adding' stamp: 'go 4/26/2000 17:26'!
addFirst: newObject
	self shouldNotImplement! !

!SortedCollection methodsFor: 'adding' stamp: 'MPH 10/23/2000 13:31'!
copyEmpty
	"Answer a copy of the receiver without any of the receiver's elements."

	^self species sortBlock: sortBlock! !


!SortedCollection methodsFor: 'comparing'!
= aSortedCollection
	"Answer true if my and aSortedCollection's species are the same,
	and if our blocks are the same, and if our elements are the same."

	self species = aSortedCollection species ifFalse: [^ false].
	sortBlock = aSortedCollection sortBlock
		ifTrue: [^ super = aSortedCollection]
		ifFalse: [^ false]! !


!SortedCollection methodsFor: 'copying'!
copy

	| newCollection |
	newCollection _ self species sortBlock: sortBlock.
	newCollection addAll: self.
	^newCollection! !


!SortedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'!
collect: aBlock 
	"Evaluate aBlock with each of my elements as the argument. Collect the 
	resulting values into an OrderedCollection. Answer the new collection. 
	Override the superclass in order to produce an OrderedCollection instead
	of a SortedCollection."

	| newCollection | 
	newCollection _ OrderedCollection new: self size.
	self do: [:each | newCollection addLast: (aBlock value: each)].
	^ newCollection! !


!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:32'!
defaultSort: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."	"Assume the default sort block ([:x :y | x <= y])."

	| di dij dj tt ij k l n |
	"The prefix d means the data at that index."
	(n _ j + 1  - i) <= 1 ifTrue: [^self].	"Nothing to sort." 
	 "Sort di,dj."
	di _ array at: i.
	dj _ array at: j.
	(di <= dj) "i.e., should di precede dj?"
		ifFalse: 
			[array swap: i with: j.
			 tt _ di.
			 di _ dj.
			 dj _ tt].
	n > 2
		ifTrue:  "More than two elements."
			[ij _ (i + j) // 2.  "ij is the midpoint of i and j."
			 dij _ array at: ij.  "Sort di,dij,dj.  Make dij be their median."
			 (di <= dij) "i.e. should di precede dij?"
			   ifTrue: 
				[(dij <= dj) "i.e., should dij precede dj?"
				  ifFalse: 
					[array swap: j with: ij.
					 dij _ dj]]
			   ifFalse:  "i.e. di should come after dij"
				[array swap: i with: ij.
				 dij _ di].
			n > 3
			  ifTrue:  "More than three elements."
				["Find k>i and l<j such that dk,dij,dl are in reverse order.
				Swap k and l.  Repeat this procedure until k and l pass each other."
				 k _ i.
				 l _ j.
				 [[l _ l - 1.  k <= l and: [dij <= (array at: l)]]
				   whileTrue.  "i.e. while dl succeeds dij"
				  [k _ k + 1.  k <= l and: [(array at: k) <= dij]]
				   whileTrue.  "i.e. while dij succeeds dk"
				  k <= l]
				   whileTrue:
					[array swap: k with: l]. 
	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
				self defaultSort: i to: l.
				self defaultSort: k to: j]]! !

!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:36'!
indexForInserting: newObject

	| index low high |
	low _ firstIndex.
	high _ lastIndex.
	sortBlock isNil
		ifTrue: [[index _ high + low // 2.  low > high]
			whileFalse: 
				[((array at: index) <= newObject)
					ifTrue: [low _ index + 1]
					ifFalse: [high _ index - 1]]]
		ifFalse: [[index _ high + low // 2.  low > high]
			whileFalse: 
				[(sortBlock value: (array at: index) value: newObject)
					ifTrue: [low _ index + 1]
					ifFalse: [high _ index - 1]]].
	^low! !

!SortedCollection methodsFor: 'private' stamp: 'go 4/26/2000 17:17'!
insert: anObject before: spot
	self shouldNotImplement! !

!SortedCollection methodsFor: 'private' stamp: 'sma 4/28/2000 17:46'!
reSort
	self sort: firstIndex to: lastIndex! !

!SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:33'!
sort: i to: j 
	"Sort elements i through j of self to be nondescending according to
	sortBlock."

	| di dij dj tt ij k l n |
	sortBlock ifNil: [^self defaultSort: i to: j].
	"The prefix d means the data at that index."
	(n _ j + 1  - i) <= 1 ifTrue: [^self].	"Nothing to sort." 
	 "Sort di,dj."
	di _ array at: i.
	dj _ array at: j.
	(sortBlock value: di value: dj) "i.e., should di precede dj?"
		ifFalse: 
			[array swap: i with: j.
			 tt _ di.
			 di _ dj.
			 dj _ tt].
	n > 2
		ifTrue:  "More than two elements."
			[ij _ (i + j) // 2.  "ij is the midpoint of i and j."
			 dij _ array at: ij.  "Sort di,dij,dj.  Make dij be their median."
			 (sortBlock value: di value: dij) "i.e. should di precede dij?"
			   ifTrue: 
				[(sortBlock value: dij value: dj) "i.e., should dij precede dj?"
				  ifFalse: 
					[array swap: j with: ij.
					 dij _ dj]]
			   ifFalse:  "i.e. di should come after dij"
				[array swap: i with: ij.
				 dij _ di].
			n > 3
			  ifTrue:  "More than three elements."
				["Find k>i and l<j such that dk,dij,dl are in reverse order.
				Swap k and l.  Repeat this procedure until k and l pass each other."
				 k _ i.
				 l _ j.
				 [[l _ l - 1.  k <= l and: [sortBlock value: dij value: (array at: l)]]
				   whileTrue.  "i.e. while dl succeeds dij"
				  [k _ k + 1.  k <= l and: [sortBlock value: (array at: k) value: dij]]
				   whileTrue.  "i.e. while dij succeeds dk"
				  k <= l]
				   whileTrue:
					[array swap: k with: l]. 
	"Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk
	through dj.  Sort those two segments."
				self sort: i to: l.
				self sort: k to: j]]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SortedCollection class
	instanceVariableNames: ''!

!SortedCollection class methodsFor: 'instance creation' stamp: 'stp 04/23/1999 05:34'!
new: anInteger 
	"The default sorting function is a <= comparison on elements."

	^(super new: anInteger) "sortBlock: [:x :y | x <= y]" 		"nil sortBlock OK"! !

!SortedCollection class methodsFor: 'instance creation'!
sortBlock: aBlock 
	"Answer an instance of me such that its elements are sorted according to 
	the criterion specified in aBlock."

	^(super new: 10) sortBlock: aBlock! !
BorderedMorph subclass: #SorterTokenMorph
	instanceVariableNames: 'morphRepresented '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 12:38'!
fitContents
	submorphs size == 1 ifTrue: [self bounds: (submorphs first bounds insetBy: (-1 @ -1))]! !

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 12:38'!
forMorph: aMorph
	| it |
	morphRepresented _ aMorph.
	aMorph submorphs size > 0 ifTrue:
		[self addMorphBack: (it _ aMorph submorphs first fullCopy).
		it position: self position + (1@1).
		it lock].
	self fitContents! !

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 12:31'!
initialize
	super initialize.
	color _ Color transparent.
	borderWidth _ 1.
	borderColor _ Color blue! !

!SorterTokenMorph methodsFor: 'as yet unclassified' stamp: 'sw 12/1/1998 12:27'!
morphRepresented
	^ morphRepresented! !
ArrayedCollection variableWordSubclass: #SoundBuffer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundBuffer commentStamp: '<historical>' prior: 0!
SoundBuffers store 16 bit unsigned quantities.  !


!SoundBuffer methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 2! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:00'!
monoSampleCount
	"Return the number of monaural 16-bit samples that fit into this SoundBuffer."

	^ super size * 2
! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:28'!
size
	"Return the number of 16-bit sound samples that fit in this sound buffer. To avoid confusion, it is better to get the size of SoundBuffer using monoSampleCount or stereoSampleCount."

	^ self monoSampleCount
! !

!SoundBuffer methodsFor: 'accessing' stamp: 'jm 9/17/97 13:01'!
stereoSampleCount
	"Return the number of stereo slices that fit into this SoundBuffer. A stereo 'slice' consists of two 16-bit samples, one for each channel."

	^ super size
! !


!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!
at: index
	"Return the 16-bit integer value at the given index of the receiver."

	<primitive: 143>
	index isInteger ifTrue: [self errorSubscriptBounds: index].
	index isNumber ifTrue: [^ self at: index truncated].
	self errorNonIntegerIndex.
! !

!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/17/97 13:03'!
at: index put: value
	"Store the given 16-bit integer at the given index in the receiver."

	<primitive: 144>
	index isInteger
		ifTrue: [
			(index >= 1 and: [index <= self size])
				ifTrue: [self errorImproperStore]
				ifFalse: [self errorSubscriptBounds: index]].
	index isNumber ifTrue: [^ self at: index truncated put: value].
	self errorNonIntegerIndex.
! !

!SoundBuffer methodsFor: 'primitives' stamp: 'jm 9/2/97 16:07'!
primFill: aPositiveInteger
	"Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."
	"Note: Since 16-bit word arrays are not built into the virtual machine, this primitive fills by 32-bit words."

	<primitive: 145>
	self errorImproperStore.
! !


!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/15/1998 13:03'!
asByteArray
	"Answer a ByteArray containing my sample data serialized in most-significant byte first order."

	| sampleCount bytes dst s |
	sampleCount _ self monoSampleCount.
	bytes _ ByteArray new: 2 * sampleCount.
	dst _ 0.
	1 to: sampleCount do: [:src |
		s _ self at: src.
		bytes at: (dst _ dst + 1) put: ((s bitShift: -8) bitAnd: 255).
		bytes at: (dst _ dst + 1) put: (s bitAnd: 255)].
	^ bytes

	! !

!SoundBuffer methodsFor: 'utilities' stamp: 'RAA 12/30/2000 18:26'!
averageEvery: nSamples from: anotherBuffer upTo: inCount

	| fromIndex sum |

	fromIndex _ 1.
	1 to: inCount // nSamples do: [ :i |
		sum _ 0.
		nSamples timesRepeat: [
			sum _ sum + (anotherBuffer at: fromIndex).
			fromIndex _ fromIndex + 1.
		].
		self at: i put: sum // nSamples.
	].
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:49'!
downSampledLowPassFiltering: doFiltering
	"Answer a new SoundBuffer half the size of the receiver consisting of every other sample. If doFiltering is true, a simple low-pass filter is applied to avoid aliasing of high frequencies. Assume that receiver is monophonic."
	"Details: The simple low-pass filter in the current implementation could be improved, at some additional cost."

	| n resultBuf j |
	n _ self monoSampleCount.
	resultBuf _ SoundBuffer newMonoSampleCount: n // 2.
	j _ 0.
	doFiltering
		ifTrue: [
			1 to: n by: 2 do: [:i |
				resultBuf at: (j _ j + 1) put:
					(((self at: i) + (self at: i + 1)) bitShift: -1)]]
		ifFalse: [
			1 to: n by: 2 do: [:i |
				resultBuf at: (j _ j + 1) put: (self at: i)]].

	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:52'!
extractLeftChannel
	"Answer a new SoundBuffer half the size of the receiver consisting of only the left channel of the receiver, which is assumed to contain stereo sound data."

	| n resultBuf j |
	n _ self monoSampleCount.
	resultBuf _ SoundBuffer newMonoSampleCount: n // 2.
	j _ 0.
	1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)].
	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:53'!
extractRightChannel
	"Answer a new SoundBuffer half the size of the receiver consisting of only the right channel of the receiver, which is assumed to contain stereo sound data."

	| n resultBuf j |
	n _ self monoSampleCount.
	resultBuf _ SoundBuffer newMonoSampleCount: n // 2.
	j _ 0.
	2 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)].
	^ resultBuf! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
indexOfFirstSampleOver: threshold
	"Return the index of the first sample whose absolute value is over the given threshold value. Return an index one greater than my size if no sample is over the threshold."

	1 to: self size do: [:i |
		(self at: i) abs > threshold ifTrue: [^ i]].
	^ self size + 1! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
indexOfLastSampleOver: threshold
	"Return the index of the last sample whose absolute value is over the given threshold value. Return zero if no sample is over the threshold."

	self size to: 1 by: -1 do: [:i |
		(self at: i) abs > threshold ifTrue: [^ i]].
	^ 0
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
normalized: percentOfFullVolume
	"Increase my amplitudes so that the highest peak is the given percent of full volume. For example 's normalized: 50' would normalize to half of full volume."

	| peak s mult |
	peak _ 0.
	1 to: self size do: [:i |
		s _ (self at: i) abs.
		s > peak ifTrue: [peak _ s]].
	mult _ (32767.0 * percentOfFullVolume) / (100.0 * peak).
	1 to: self size do: [:i | self at: i put: (mult * (self at: i)) asInteger].
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jm 3/28/1999 07:23'!
splitStereo
	"Answer an array of two SoundBuffers half the size of the receiver consisting of the left and right channels of the receiver (which is assumed to contain stereo sound data)."

	| n leftBuf rightBuf leftIndex rightIndex |
	n _ self monoSampleCount.
	leftBuf _ SoundBuffer newMonoSampleCount: n // 2.
	rightBuf _ SoundBuffer newMonoSampleCount: n // 2.
	leftIndex _ rightIndex _ 0.
	1 to: n by: 2 do: [:i |
		leftBuf at: (leftIndex _ leftIndex + 1) put: (self at: i).
		rightBuf at: (rightIndex _ rightIndex + 1) put: (self at: i + 1)].
	^ Array with: leftBuf with: rightBuf
! !

!SoundBuffer methodsFor: 'utilities' stamp: 'jhm 10/15/97 15:13'!
trimmedThreshold: threshold

	| start end |
	start _ self indexOfFirstSampleOver: threshold.
	end _  self indexOfLastSampleOver: threshold.
	start > end ifTrue: [^ SoundBuffer new].
	start _ (start - 200) max: 1.
	end _ (end + 200) min: self size.
	^ self copyFrom: start to: end
! !


!SoundBuffer methodsFor: 'objects from disk' stamp: 'tk 2/3/2000 20:32'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
	Why is this the right thing to do?  We are using memory as a byteStream.  High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory.  Different from a Bitmap."

	| hack blt |
	Smalltalk endianness == #little ifTrue: [
		"The implementation is a hack, but fast for large ranges"
		hack _ Form new hackBits: self.
		blt _ (BitBlt toForm: hack) sourceForm: hack.
		blt combinationRule: Form reverse.  "XOR"
		blt sourceY: 0; destY: 0; height: self size; width: 1.
		blt sourceX: 0; destX: 1; copyBits.  "Exchange bytes 0 and 1"
		blt sourceX: 1; destX: 0; copyBits.
		blt sourceX: 0; destX: 1; copyBits.
		blt sourceX: 2; destX: 3; copyBits.  "Exchange bytes 2 and 3"
		blt sourceX: 3; destX: 2; copyBits.
		blt sourceX: 2; destX: 3; copyBits].

! !

!SoundBuffer methodsFor: 'objects from disk' stamp: 'tk 2/5/2000 16:15'!
swapHalves
		"A normal switch in endianness (byte order in words) reverses the order of 4 bytes.  That is not correct for SoundBuffers, which use 2-bytes units.  If a normal switch has be done, this method corrects it further by swapping the two halves of the long word."

	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: 0; destY: 0; height: self size; width: 2.
	blt sourceX: 0; destX: 2; copyBits.  "Exchange bytes 0&1 with 2&3"
	blt sourceX: 2; destX: 0; copyBits.
	blt sourceX: 0; destX: 2; copyBits.

! !

!SoundBuffer methodsFor: 'objects from disk' stamp: 'RAA 7/11/2000 11:38'!
writeOn: aStream 
	| reversed convertToBytes |
	"Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed).  Always store in Big Endian (Mac) byte order.  Do the writing at BitBlt speeds."

	self flag: #bob.		"clean up the first part of this"
	convertToBytes _ aStream originalContents "collection" class isBytes.
	((aStream isKindOf: FileStream) or: 
		[aStream isKindOf: GZipSurrogateStream]) ifTrue: [convertToBytes _ false].	"knows how"

	aStream nextInt32Put: self size.
	Smalltalk endianness == #big 
		ifTrue: ["no change"
			convertToBytes ifTrue: [self do: [:vv | aStream nextNumber: 4 put: vv]]
					"Later define (aStream nextPutWordsAll:) that uses BitBlt to 
					 put words on a non-file byteStream quickly" 
				ifFalse: [aStream nextPutAll: self]]	"files use this"
		ifFalse: [
			reversed _ self clone.
			reversed restoreEndianness.	"swap an extra time to get to big endian format"
			convertToBytes ifTrue: [reversed do: [:vv | aStream nextNumber: 4 put: vv]]
				ifFalse: [aStream nextPutAll: reversed]]
! !


!SoundBuffer methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 11:31'!
writeOnGZIPByteStream: aStream 
	
	aStream nextPutAllWordArray: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundBuffer class
	instanceVariableNames: ''!

!SoundBuffer class methodsFor: 'instance creation' stamp: 'RAA 12/30/2000 18:20'!
averageEvery: nSamples from: anotherBuffer upTo: inCount

	^(self newMonoSampleCount: inCount // nSamples)
		averageEvery: nSamples 
		from: anotherBuffer 
		upTo: inCount! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:39'!
fromArray: anArray
	"Return a new SoundBuffer whose contents are copied from the given Array or ByteArray."

	| new |
	new _ SoundBuffer newMonoSampleCount: anArray size.
	1 to: anArray size do: [:i | new at: i put: (anArray at: i)].
	^ new
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 8/15/1998 14:35'!
fromByteArray: aByteArray
	"Convert the given ByteArray (stored with the most significant byte first) into 16-bit sample buffer."

	| n buf src w |
	n _ aByteArray size // 2.
	buf _ SoundBuffer newMonoSampleCount: n.
	src _ 1.
	1 to: n do: [:i |
		w _ ((aByteArray at: src) bitShift: 8) + (aByteArray at: src + 1).
		w > 32767 ifTrue: [w _ w - 65536].
		buf at: i put: w.
		src _ src + 2].
	^ buf
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 13:25'!
new: anInteger
	"See the comment in newMonoSampleCount:. To avoid confusion, it is best to create new instances using newMonoSampleCount: or newStereoSampleCount:."

	^ self newMonoSampleCount: anInteger
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'tk 2/5/2000 22:00'!
newFromStream: s

	| len |
	len _ s nextInt32.
	^ s nextWordsInto: (self new: len)! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:44'!
newMonoSampleCount: anInteger
	"Return a SoundBuffer large enough to hold the given number of monaural samples (i.e., 16-bit words)."
	"Details: The size is rounded up to an even number, since the underlying representation is in terms of 32-bit words."

	^ self basicNew: (anInteger + 1) // 2
! !

!SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 9/17/97 12:52'!
newStereoSampleCount: anInteger
	"Return a SoundBuffer large enough to hold the given number of stereo slices. A stereo 'slice' consists of two 16-bit samples, one for each channel."

	^ self basicNew: anInteger
! !
Object subclass: #SoundCodec
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundCodec commentStamp: '<historical>' prior: 0!
I am an abstract class that describes the protocol for sound codecs. Each codec (the name stems from "COder/DECoder") describes a particular algorithm for compressing and decompressing sound data. Most sound codecs are called 'lossy' because they lose information; the decompressed sound data is not exactly the same as the original data.
!


!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'!
compressAndDecompress: aSound
	"Compress and decompress the given sound. Useful for testing."
	"(MuLawCodec new compressAndDecompress: (SampledSound soundNamed: 'camera')) play"

	^ (self compressSound: aSound) asSound
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'!
compressSound: aSound
	"Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."

	| compressed channels |
	compressed _ CompressedSoundData new
		codecName: self class name;
		soundClassName: aSound class name.
	(aSound isKindOf: SampledSound) ifTrue: [
		channels _ Array new: 1.
		channels at: 1 put: (self encodeSoundBuffer: aSound samples).
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: 1;
			loopEnd: aSound samples size;
			loopLength: 0.0;
			perceivedPitch: 100.0;
			gain: aSound loudness.
		^ compressed].
	(aSound isKindOf: LoopedSampledSound) ifTrue: [
		aSound isStereo
			ifTrue: [
				channels _ Array new: 2.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
				channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
			ifFalse: [
				channels _ Array new: 1.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: aSound firstSample;
			loopEnd: aSound loopEnd;
			loopLength: aSound loopLength;
			perceivedPitch: aSound perceivedPitch;
			gain: aSound gain.
		^ compressed].
	self error: 'you can only compress sampled sounds'.
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'RAA 1/2/2001 10:17'!
compressSound: aSound atRate: desiredSampleRate
	"Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."

	| compressed channels samples newRate ratio buffer |

	compressed _ CompressedSoundData new
		codecName: self class name;
		soundClassName: aSound class name.
	(aSound isKindOf: SampledSound) ifTrue: [
		(desiredSampleRate isNil or: 
				[(ratio _ aSound originalSamplingRate // desiredSampleRate) <= 1]) ifTrue: [
			samples _ aSound samples.
			newRate _ aSound originalSamplingRate.
		] ifFalse: [
			buffer _ aSound samples.
			samples _ SoundBuffer 
				averageEvery: ratio 
				from: buffer 
				upTo: buffer monoSampleCount.
			newRate _ aSound originalSamplingRate / ratio.
		].

		channels _ Array new: 1.
		channels at: 1 put: (self encodeSoundBuffer: samples).
		compressed
			channels: channels;
			samplingRate: newRate;
			firstSample: 1;
			loopEnd: samples size;
			loopLength: 0.0;
			perceivedPitch: 100.0;
			gain: aSound loudness.
		^ compressed].
	(aSound isKindOf: LoopedSampledSound) ifTrue: [
		aSound isStereo
			ifTrue: [
				channels _ Array new: 2.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
				channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
			ifFalse: [
				channels _ Array new: 1.
				channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
		compressed
			channels: channels;
			samplingRate: aSound originalSamplingRate;
			firstSample: aSound firstSample;
			loopEnd: aSound loopEnd;
			loopLength: aSound loopLength;
			perceivedPitch: aSound perceivedPitch;
			gain: aSound gain.
		^ compressed].
	self error: 'you can only compress sampled sounds'.
! !

!SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 3/30/1999 08:03'!
decompressSound: aCompressedSound
	"Decompress the entirety of the given compressed sound with this codec and answer the resulting sound."

	| channels sound |
	channels _ aCompressedSound channels
		collect: [:compressed | self decodeCompressedData: compressed].
	'SampledSound' = aCompressedSound soundClassName ifTrue: [
		sound _ SampledSound
			samples: channels first
			samplingRate: (aCompressedSound samplingRate).
		sound loudness: aCompressedSound gain.
		^ sound].
	'LoopedSampledSound' = aCompressedSound soundClassName ifTrue: [
		aCompressedSound loopLength = 0
			ifTrue: [
				sound _ LoopedSampledSound
					unloopedSamples: channels first
					pitch: aCompressedSound perceivedPitch
					samplingRate: aCompressedSound samplingRate]
			ifFalse: [
				sound _ LoopedSampledSound
					samples: channels first
					loopEnd: aCompressedSound loopEnd
					loopLength: aCompressedSound loopLength
					pitch: aCompressedSound perceivedPitch
					samplingRate: aCompressedSound samplingRate].
		channels size > 1 ifTrue: [sound rightSamples: channels last].
		sound
			firstSample: aCompressedSound firstSample;
			gain: aCompressedSound gain.
		sound
			setPitch: 100.0
			dur: (channels first size / aCompressedSound samplingRate)
			loudness: 1.0.
		^ sound].
	self error: 'unknown sound class'.
! !


!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:23'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:38'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:39'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	self subclassResponsibility.
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:30'!
reset
	"Reset my encoding and decoding state. Optional. This default implementation does nothing."
! !

!SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:45'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	self subclassResponsibility.
! !


!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:53'!
decodeCompressedData: aByteArray
	"Decode the entirety of the given encoded data buffer with this codec. Answer a monophonic SoundBuffer containing the uncompressed samples."

	| frameCount result increments |
	frameCount _ self frameCount: aByteArray.
	result _ SoundBuffer newMonoSampleCount: frameCount * self samplesPerFrame.
	self reset.
	increments _ self decodeFrames: frameCount from: aByteArray at: 1 into: result at: 1.
	((increments first = aByteArray size) and: [increments last = result size]) ifFalse: [
		self error: 'implementation problem; increment sizes should match buffer sizes'].
	^ result
! !

!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 14:20'!
encodeSoundBuffer: aSoundBuffer
	"Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data."

	| codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs |
	frameSize _ self samplesPerFrame.
	fullFrameCount _ aSoundBuffer monoSampleCount // frameSize.
	lastFrameSamples _ aSoundBuffer monoSampleCount - (fullFrameCount * frameSize).
	codeFrameSize _ self bytesPerEncodedFrame.
	codeFrameSize = 0 ifTrue:
		["Allow room for 1 byte per sample for variable-length compression"
		codeFrameSize _ frameSize].
	lastFrameSamples > 0
		ifTrue: [result _ ByteArray new: (fullFrameCount + 1) * codeFrameSize]
		ifFalse: [result _ ByteArray new: fullFrameCount * codeFrameSize].
	self reset.
	increments _ self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1.
	lastFrameSamples > 0 ifTrue: [
		finalFrame _ SoundBuffer newMonoSampleCount: frameSize.
		i _ fullFrameCount * frameSize.
		1 to: lastFrameSamples do: [:j |
			finalFrame at: j put: (aSoundBuffer at: (i _ i + 1))].
		lastIncs _ self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second.
		increments _ Array with: increments first + lastIncs first
							with: increments second + lastIncs second].
	increments second < result size
		ifTrue: [^ result copyFrom: 1 to: increments second]
		ifFalse: [^ result]
! !

!SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:54'!
frameCount: aByteArray
	"Compute the frame count for this byteArray.  This default computation will have to be overridden by codecs with variable frame sizes."

	| codeFrameSize |
	codeFrameSize _ self bytesPerEncodedFrame.
	(aByteArray size \\ codeFrameSize) = 0 ifFalse:
		[self error: 'encoded buffer is not an even multiple of the encoded frame size'].
	^ aByteArray size // codeFrameSize! !
InterpreterPlugin subclass: #SoundCodecPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!

!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'jm 2/4/1999 08:38'!
primitiveGSMDecode

	| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
	self export: true.
	dstIndex _ interpreterProxy stackIntegerValue: 0.
	dst _ interpreterProxy stackObjectValue: 1.
	srcIndex _ interpreterProxy stackIntegerValue: 2.
	src _ interpreterProxy stackObjectValue: 3.
	frameCount _ interpreterProxy stackIntegerValue: 4.
	state _ interpreterProxy stackObjectValue: 5.
	interpreterProxy success: (interpreterProxy isWords: dst).
	interpreterProxy success: (interpreterProxy isBytes: src).
	interpreterProxy success: (interpreterProxy isBytes: state).
	interpreterProxy failed ifTrue:[^ nil].
	srcSize _ interpreterProxy slotSizeOf: src.
	dstSize _ (interpreterProxy slotSizeOf: dst) * 2.
	self cCode: 'gsmDecode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
	interpreterProxy failed ifTrue:[^ nil].
	result _ interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
	interpreterProxy failed ifTrue:[^ nil].
	interpreterProxy pop: 6.
	interpreterProxy push: result.
! !

!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'jm 2/4/1999 08:37'!
primitiveGSMEncode

	| dstIndex dst srcIndex src frameCount state srcSize dstSize result srcDelta dstDelta |
	self export: true.
	dstIndex _ interpreterProxy stackIntegerValue: 0.
	dst _ interpreterProxy stackObjectValue: 1.
	srcIndex _ interpreterProxy stackIntegerValue: 2.
	src _ interpreterProxy stackObjectValue: 3.
	frameCount _ interpreterProxy stackIntegerValue: 4.
	state _ interpreterProxy stackObjectValue: 5.
	interpreterProxy success: (interpreterProxy isBytes: dst).
	interpreterProxy success: (interpreterProxy isWords: src).
	interpreterProxy success: (interpreterProxy isBytes: state).
	interpreterProxy failed ifTrue:[^ nil].
	srcSize _ (interpreterProxy slotSizeOf: src) * 2.
	dstSize _ interpreterProxy slotSizeOf: dst.
	self cCode: 'gsmEncode(state + 4, frameCount, src, srcIndex, srcSize, dst, dstIndex, dstSize, &srcDelta, &dstDelta)'.
	interpreterProxy failed ifTrue:[^ nil].
	result _ interpreterProxy makePointwithxValue: srcDelta yValue: dstDelta.
	interpreterProxy failed ifTrue:[^ nil].
	interpreterProxy pop: 6.
	interpreterProxy push: result.
! !

!SoundCodecPlugin methodsFor: 'gsm 6.10 codec' stamp: 'jm 2/4/1999 08:37'!
primitiveGSMNewState

	| stateBytes state |
	self export: true.
	stateBytes _ self cCode: 'gsmStateBytes()'.
	state _ interpreterProxy
		instantiateClass: interpreterProxy classByteArray
		indexableSize: stateBytes.
	self cCode: 'gsmInitState(state + 4)'.
	interpreterProxy push: state.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundCodecPlugin class
	instanceVariableNames: ''!

!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'JMM 8/16/2000 13:13'!
headerFile
	^'/* SoundCodec Plugin */
/* prototypes */
void gsmEncode(
	int state, int frameCount,
	int src, int srcIndex, int srcSize,
	int dst, int dstIndex, int dstSize,
	int *srcDelta, int *dstDelta);
	
void gsmDecode(
	int state, int frameCount,
	int src, int srcIndex, int srcSize,
	int dst, int dstIndex, int dstSize,
	int *srcDelta, int *dstDelta);
	
void gsmInitState(int state);

int gsmStateBytes(void);
'! !

!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'ar 5/15/2000 23:41'!
moduleName
	"Time millisecondsToRun: [
		SoundCodecPlugin translateDoInlining: true]"

	^ 'SoundCodecPrims' "Needs to be the name used for module specification..."
! !

!SoundCodecPlugin class methodsFor: 'accessing' stamp: 'ar 2/3/2001 16:28'!
sourceFile

	^ '/*
 * Copyright 1992 by Jutta Degener and Carsten Bormann, Technische
 * Universitaet Berlin.  See the accompanying file "COPYRIGHT" for
 * details.  THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
 */

/* This file was created by concatenating a number of separate header
   and source files from Jutta Degener and Carsten Bormann implementation,
   patch level 10. This was done to simplify Squeak source code maintenance.
 */

#include <assert.h>
#include <stdio.h>
#include <string.h>

/****** begin "gsm.h" *****/

#ifdef __cplusplus
#	define	NeedFunctionPrototypes	1
#endif

#if __STDC__
#	define	NeedFunctionPrototypes	1
#endif

#ifdef _NO_PROTO
#	undef	NeedFunctionPrototypes
#endif

#ifdef NeedFunctionPrototypes
#   include	<stdio.h>		/* for FILE * 	*/
#endif

#undef GSM_P
#if NeedFunctionPrototypes
#	define	GSM_P( protos )	protos
#else
#	define  GSM_P( protos )	( /* protos */ )
#endif

/*
 *	Interface
 */

typedef struct gsm_state * 	gsm;
typedef short		   	gsm_signal;		/* signed 16 bit */
typedef unsigned char		gsm_byte;
typedef gsm_byte 		gsm_frame[33];		/* 33 * 8 bits	 */

#define	GSM_MAGIC		0xD		  	/* 13 kbit/s RPE-LTP */

#define	GSM_PATCHLEVEL		10
#define	GSM_MINOR		0
#define	GSM_MAJOR		1

#define	GSM_OPT_VERBOSE		1
#define	GSM_OPT_FAST		2
#define	GSM_OPT_LTP_CUT		3
#define	GSM_OPT_WAV49		4
#define	GSM_OPT_FRAME_INDEX	5
#define	GSM_OPT_FRAME_CHAIN	6

extern gsm  gsm_create 	GSM_P((void));
extern void gsm_destroy GSM_P((gsm));	

extern int  gsm_print   GSM_P((FILE *, gsm, gsm_byte  *));
extern int  gsm_option  GSM_P((gsm, int, int *));

extern void gsm_encode  GSM_P((gsm, gsm_signal *, gsm_byte  *));
extern int  gsm_decode  GSM_P((gsm, gsm_byte   *, gsm_signal *));

extern int  gsm_explode GSM_P((gsm, gsm_byte   *, gsm_signal *));
extern void gsm_implode GSM_P((gsm, gsm_signal *, gsm_byte   *));

/****** begin "proto.h" *****/

#if __cplusplus
#	define	NeedFunctionPrototypes	1
#endif

#if __STDC__
#	define	NeedFunctionPrototypes	1
#endif

#ifdef	_NO_PROTO
#	undef	NeedFunctionPrototypes
#endif

#undef	P	/* gnu stdio.h actually defines this... 	*/
#undef	P0
#undef	P1
#undef	P2
#undef	P3
#undef	P4
#undef	P5
#undef	P6
#undef	P7
#undef	P8

#if NeedFunctionPrototypes

#	define	P( protos )	protos

#	define	P0()				(void)
#	define	P1(x, a)			(a)
#	define	P2(x, a, b)			(a, b)
#	define	P3(x, a, b, c)			(a, b, c)
#	define	P4(x, a, b, c, d)		(a, b, c, d)	
#	define	P5(x, a, b, c, d, e)		(a, b, c, d, e)
#	define	P6(x, a, b, c, d, e, f)		(a, b, c, d, e, f)
#	define	P7(x, a, b, c, d, e, f, g)	(a, b, c, d, e, f, g)
#	define	P8(x, a, b, c, d, e, f, g, h)	(a, b, c, d, e, f, g, h)

#else /* !!NeedFunctionPrototypes */

#	define	P( protos )	( /* protos */ )

#	define	P0()				()
#	define	P1(x, a)			x a;
#	define	P2(x, a, b)			x a; b;
#	define	P3(x, a, b, c)			x a; b; c;
#	define	P4(x, a, b, c, d)		x a; b; c; d;
#	define	P5(x, a, b, c, d, e)		x a; b; c; d; e;
#	define	P6(x, a, b, c, d, e, f)		x a; b; c; d; e; f;
#	define	P7(x, a, b, c, d, e, f, g)	x a; b; c; d; e; f; g;
#	define	P8(x, a, b, c, d, e, f, g, h)	x a; b; c; d; e; f; g; h;

#endif  /* !!NeedFunctionPrototypes */

/****** begin "private.h" *****/

typedef short			word;		/* 16 bit signed int	*/
typedef long			longword;	/* 32 bit signed int	*/

typedef unsigned short		uword;		/* unsigned word	*/
typedef unsigned long		ulongword;	/* unsigned longword	*/

struct gsm_state {

	word		dp0[ 280 ];

	word		z1;		/* preprocessing.c, Offset_com. */
	longword	L_z2;		/*                  Offset_com. */
	int		mp;		/*                  Preemphasis	*/

	word		u[8];		/* short_term_aly_filter.c	*/
	word		LARpp[2][8]; 	/*                              */
	word		j;		/*                              */

	word            ltp_cut;        /* long_term.c, LTP crosscorr.  */
	word		nrp; /* 40 */	/* long_term.c, synthesis	*/
	word		v[9];		/* short_term.c, synthesis	*/
	word		msr;		/* decoder.c,	Postprocessing	*/

	char		verbose;	/* only used if !!NDEBUG		*/
	char		fast;		/* only used if FAST		*/

	char		wav_fmt;	/* only used if WAV49 defined	*/
	unsigned char	frame_index;	/*            odd/even chaining	*/
	unsigned char	frame_chain;	/*   half-byte to carry forward	*/
};


#define	MIN_WORD	(-32767 - 1)
#define	MAX_WORD	  32767

#define	MIN_LONGWORD	(-2147483647 - 1)
#define	MAX_LONGWORD	  2147483647

#ifdef	SASR		/* flag: >> is a signed arithmetic shift right */
#undef	SASR
#define	SASR(x, by)	((x) >> (by))
#else
#define	SASR(x, by)	((x) >= 0 ? (x) >> (by) : (~(-((x) + 1) >> (by))))
#endif	/* SASR */

//#include "proto.h"

/*
 *	Prototypes from add.c
 */
extern word	gsm_mult 	P((word a, word b));
extern longword gsm_L_mult 	P((word a, word b));
extern word	gsm_mult_r	P((word a, word b));

extern word	gsm_div  	P((word num, word denum));

extern word	gsm_add 	P(( word a, word b ));
extern longword gsm_L_add 	P(( longword a, longword b ));

extern word	gsm_sub 	P((word a, word b));
extern longword gsm_L_sub 	P((longword a, longword b));

extern word	gsm_abs 	P((word a));

extern word	gsm_norm 	P(( longword a ));

extern longword gsm_L_asl  	P((longword a, int n));
extern word	gsm_asl 	P((word a, int n));

extern longword gsm_L_asr  	P((longword a, int n));
extern word	gsm_asr  	P((word a, int n));

/*
 *  Inlined functions from add.h 
 */

/* 
 * #define GSM_MULT_R(a, b) (* word a, word b, !!(a == b == MIN_WORD) *)	\
 *	(0x0FFFF & SASR(((longword)(a) * (longword)(b) + 16384), 15))
 */
#define GSM_MULT_R(a, b) /* word a, word b, !!(a == b == MIN_WORD) */	\
	(SASR( ((longword)(a) * (longword)(b) + 16384), 15 ))

# define GSM_MULT(a,b)	 /* word a, word b, !!(a == b == MIN_WORD) */	\
	(SASR( ((longword)(a) * (longword)(b)), 15 ))

# define GSM_L_MULT(a, b) /* word a, word b */	\
	(((longword)(a) * (longword)(b)) << 1)

# define GSM_L_ADD(a, b)	\
	( (a) <  0 ? ( (b) >= 0 ? (a) + (b)	\
		 : (utmp = (ulongword)-((a) + 1) + (ulongword)-((b) + 1)) \
		   >= MAX_LONGWORD ? MIN_LONGWORD : -(longword)utmp-2 )   \
	: ((b) <= 0 ? (a) + (b)   \
	          : (utmp = (ulongword)(a) + (ulongword)(b)) >= MAX_LONGWORD \
		    ? MAX_LONGWORD : utmp))

/*
 * # define GSM_ADD(a, b)	\
 * 	((ltmp = (longword)(a) + (longword)(b)) >= MAX_WORD \
 * 	? MAX_WORD : ltmp <= MIN_WORD ? MIN_WORD : ltmp)
 */
/* Nonportable, but faster: */

#define	GSM_ADD(a, b)	\
	((ulongword)((ltmp = (longword)(a) + (longword)(b)) - MIN_WORD) > \
		MAX_WORD - MIN_WORD ? (ltmp > 0 ? MAX_WORD : MIN_WORD) : ltmp)

# define GSM_SUB(a, b)	\
	((ltmp = (longword)(a) - (longword)(b)) >= MAX_WORD \
	? MAX_WORD : ltmp <= MIN_WORD ? MIN_WORD : ltmp)

# define GSM_ABS(a)	((a) < 0 ? ((a) == MIN_WORD ? MAX_WORD : -(a)) : (a))

/* Use these if necessary:

# define GSM_MULT_R(a, b)	gsm_mult_r(a, b)
# define GSM_MULT(a, b)		gsm_mult(a, b)
# define GSM_L_MULT(a, b)	gsm_L_mult(a, b)

# define GSM_L_ADD(a, b)	gsm_L_add(a, b)
# define GSM_ADD(a, b)		gsm_add(a, b)
# define GSM_SUB(a, b)		gsm_sub(a, b)

# define GSM_ABS(a)		gsm_abs(a)

*/

/*
 *  More prototypes from implementations..
 */
extern void Gsm_Coder P((
		struct gsm_state	* S,
		word	* s,	/* [0..159] samples		IN	*/
		word	* LARc,	/* [0..7] LAR coefficients	OUT	*/
		word	* Nc,	/* [0..3] LTP lag		OUT 	*/
		word	* bc,	/* [0..3] coded LTP gain	OUT 	*/
		word	* Mc,	/* [0..3] RPE grid selection	OUT     */
		word	* xmaxc,/* [0..3] Coded maximum amplitude OUT	*/
		word	* xMc	/* [13*4] normalized RPE samples OUT	*/));

extern void Gsm_Long_Term_Predictor P((		/* 4x for 160 samples */
		struct gsm_state * S,
		word	* d,	/* [0..39]   residual signal	IN	*/
		word	* dp,	/* [-120..-1] d''		IN	*/
		word	* e,	/* [0..40] 			OUT	*/
		word	* dpp,	/* [0..40] 			OUT	*/
		word	* Nc,	/* correlation lag		OUT	*/
		word	* bc	/* gain factor			OUT	*/));

extern void Gsm_LPC_Analysis P((
		struct gsm_state * S,
		word * s,	 /* 0..159 signals	IN/OUT	*/
	        word * LARc));   /* 0..7   LARc''s	OUT	*/

extern void Gsm_Preprocess P((
		struct gsm_state * S,
		word * s, word * so));

extern void Gsm_Encoding P((
		struct gsm_state * S,
		word	* e,	
		word	* ep,	
		word	* xmaxc,
		word	* Mc,	
		word	* xMc));

extern void Gsm_Short_Term_Analysis_Filter P((
		struct gsm_state * S,
		word	* LARc,	/* coded log area ratio [0..7]  IN	*/
		word	* d	/* st res. signal [0..159]	IN/OUT	*/));

extern void Gsm_Decoder P((
		struct gsm_state * S,
		word	* LARcr,	/* [0..7]		IN	*/
		word	* Ncr,		/* [0..3] 		IN 	*/
		word	* bcr,		/* [0..3]		IN	*/
		word	* Mcr,		/* [0..3] 		IN 	*/
		word	* xmaxcr,	/* [0..3]		IN 	*/
		word	* xMcr,		/* [0..13*4]		IN	*/
		word	* s));		/* [0..159]		OUT 	*/

extern void Gsm_Decoding P((
		struct gsm_state * S,
		word 	xmaxcr,
		word	Mcr,
		word	* xMcr,  	/* [0..12]		IN	*/
		word	* erp)); 	/* [0..39]		OUT 	*/

extern void Gsm_Long_Term_Synthesis_Filtering P((
		struct gsm_state* S,
		word	Ncr,
		word	bcr,
		word	* erp,		/* [0..39]		  IN 	*/
		word	* drp)); 	/* [-120..-1] IN, [0..40] OUT 	*/

void Gsm_RPE_Decoding P((
	struct gsm_state *S,
		word xmaxcr,
		word Mcr,
		word * xMcr,  /* [0..12], 3 bits             IN      */
		word * erp)); /* [0..39]                     OUT     */

void Gsm_RPE_Encoding P((
		struct gsm_state * S,
		word    * e,            /* -5..-1][0..39][40..44     IN/OUT  */
		word    * xmaxc,        /*                              OUT */
		word    * Mc,           /*                              OUT */
		word    * xMc));        /* [0..12]                      OUT */

extern void Gsm_Short_Term_Synthesis_Filter P((
		struct gsm_state * S,
		word	* LARcr, 	/* log area ratios [0..7]  IN	*/
		word	* drp,		/* received d [0...39]	   IN	*/
		word	* s));		/* signal   s [0..159]	  OUT	*/

extern void Gsm_Update_of_reconstructed_short_time_residual_signal P((
		word	* dpp,		/* [0...39]	IN	*/
		word	* ep,		/* [0...39]	IN	*/
		word	* dp));		/* [-120...-1]  IN/OUT 	*/

/*
 *  Tables from table.c
 */
#ifndef	GSM_TABLE_C

extern word gsm_A[8], gsm_B[8], gsm_MIC[8], gsm_MAC[8];
extern word gsm_INVA[8];
extern word gsm_DLB[4], gsm_QLB[4];
extern word gsm_H[11];
extern word gsm_NRFAC[8];
extern word gsm_FAC[8];

#endif	/* GSM_TABLE_C */

/*
 *  Debugging
 */
#ifdef NDEBUG

#	define	gsm_debug_words(a, b, c, d)		/* nil */
#	define	gsm_debug_longwords(a, b, c, d)		/* nil */
#	define	gsm_debug_word(a, b)			/* nil */
#	define	gsm_debug_longword(a, b)		/* nil */

#else	/* !!NDEBUG => DEBUG */

	extern void  gsm_debug_words     P((char * name, int, int, word *));
	extern void  gsm_debug_longwords P((char * name, int, int, longword *));
	extern void  gsm_debug_longword  P((char * name, longword));
	extern void  gsm_debug_word      P((char * name, word));

#endif /* !!NDEBUG */


/****** begin "add.c" *****/


#define	saturate(x) 	\
	((x) < MIN_WORD ? MIN_WORD : (x) > MAX_WORD ? MAX_WORD: (x))

word gsm_add P2((a,b), word a, word b)
{
	longword sum = (longword)a + (longword)b;
	return saturate(sum);
}

word gsm_sub P2((a,b), word a, word b)
{
	longword diff = (longword)a - (longword)b;
	return saturate(diff);
}

word gsm_mult P2((a,b), word a, word b)
{
	if (a == MIN_WORD && b == MIN_WORD) return MAX_WORD;
	else return SASR( (longword)a * (longword)b, 15 );
}

word gsm_mult_r P2((a,b), word a, word b)
{
	if (b == MIN_WORD && a == MIN_WORD) return MAX_WORD;
	else {
		longword prod = (longword)a * (longword)b + 16384;
		prod >>= 15;
		return prod & 0xFFFF;
	}
}

word gsm_abs P1((a), word a)
{
	return a < 0 ? (a == MIN_WORD ? MAX_WORD : -a) : a;
}

longword gsm_L_mult P2((a,b),word a, word b)
{
	assert( a !!= MIN_WORD || b !!= MIN_WORD );
	return ((longword)a * (longword)b) << 1;
}

longword gsm_L_add P2((a,b), longword a, longword b)
{
	if (a < 0) {
		if (b >= 0) return a + b;
		else {
			ulongword A = (ulongword)-(a + 1) + (ulongword)-(b + 1);
			return A >= MAX_LONGWORD ? MIN_LONGWORD :-(longword)A-2;
		}
	}
	else if (b <= 0) return a + b;
	else {
		ulongword A = (ulongword)a + (ulongword)b;
		return A > MAX_LONGWORD ? MAX_LONGWORD : A;
	}
}

longword gsm_L_sub P2((a,b), longword a, longword b)
{
	if (a >= 0) {
		if (b >= 0) return a - b;
		else {
			/* a>=0, b<0 */

			ulongword A = (ulongword)a + -(b + 1);
			return A >= MAX_LONGWORD ? MAX_LONGWORD : (A + 1);
		}
	}
	else if (b <= 0) return a - b;
	else {
		/* a<0, b>0 */  

		ulongword A = (ulongword)-(a + 1) + b;
		return A >= MAX_LONGWORD ? MIN_LONGWORD : -(longword)A - 1;
	}
}

static unsigned char const bitoff[ 256 ] = {
	 8, 7, 6, 6, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4,
	 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
	 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};

word gsm_norm P1((a), longword a )
/*
 * the number of left shifts needed to normalize the 32 bit
 * variable L_var1 for positive values on the interval
 *
 * with minimum of
 * minimum of 1073741824  (01000000000000000000000000000000) and 
 * maximum of 2147483647  (01111111111111111111111111111111)
 *
 *
 * and for negative values on the interval with
 * minimum of -2147483648 (-10000000000000000000000000000000) and
 * maximum of -1073741824 ( -1000000000000000000000000000000).
 *
 * in order to normalize the result, the following
 * operation must be done: L_norm_var1 = L_var1 << norm( L_var1 );
 *
 * (That''s ''ffs'', only from the left, not the right..)
 */
{
	assert(a !!= 0);

	if (a < 0) {
		if (a <= -1073741824) return 0;
		a = ~a;
	}

	return    a & 0xffff0000 
		? ( a & 0xff000000
		  ?  -1 + bitoff[ 0xFF & (a >> 24) ]
		  :   7 + bitoff[ 0xFF & (a >> 16) ] )
		: ( a & 0xff00
		  ?  15 + bitoff[ 0xFF & (a >> 8) ]
		  :  23 + bitoff[ 0xFF & a ] );
}

longword gsm_L_asl P2((a,n), longword a, int n)
{
	if (n >= 32) return 0;
	if (n <= -32) return -(a < 0);
	if (n < 0) return gsm_L_asr(a, -n);
	return a << n;
}

word gsm_asl P2((a,n), word a, int n)
{
	if (n >= 16) return 0;
	if (n <= -16) return -(a < 0);
	if (n < 0) return gsm_asr(a, -n);
	return a << n;
}

longword gsm_L_asr P2((a,n), longword a, int n)
{
	if (n >= 32) return -(a < 0);
	if (n <= -32) return 0;
	if (n < 0) return a << -n;

#	ifdef	SASR
		return a >> n;
#	else
		if (a >= 0) return a >> n;
		else return -(longword)( -(ulongword)a >> n );
#	endif
}

word gsm_asr P2((a,n), word a, int n)
{
	if (n >= 16) return -(a < 0);
	if (n <= -16) return 0;
	if (n < 0) return a << -n;

#	ifdef	SASR
		return a >> n;
#	else
		if (a >= 0) return a >> n;
		else return -(word)( -(uword)a >> n );
#	endif
}

/* 
 *  (From p. 46, end of section 4.2.5)
 *
 *  NOTE: The following lines gives [sic] one correct implementation
 *  	  of the div(num, denum) arithmetic operation.  Compute div
 *        which is the integer division of num by denum: with denum
 *	  >= num > 0
 */

word gsm_div P2((num,denum), word num, word denum)
{
	longword	L_num   = num;
	longword	L_denum = denum;
	word		div 	= 0;
	int		k 	= 15;

	/* The parameter num sometimes becomes zero.
	 * Although this is explicitly guarded against in 4.2.5,
	 * we assume that the result should then be zero as well.
	 */

	/* assert(num !!= 0); */

	assert(num >= 0 && denum >= num);
	if (num == 0)
	    return 0;

	while (k--) {
		div   <<= 1;
		L_num <<= 1;

		if (L_num >= L_denum) {
			L_num -= L_denum;
			div++;
		}
	}

	return div;
}

/****** begin "code.c" *****/

/* 
 *  4.2 FIXED POINT IMPLEMENTATION OF THE RPE-LTP CODER 
 */

void Gsm_Coder P8((S,s,LARc,Nc,bc,Mc,xmaxc,xMc),

	struct gsm_state	* S,

	word	* s,	/* [0..159] samples		  	IN	*/

/*
 * The RPE-LTD coder works on a frame by frame basis.  The length of
 * the frame is equal to 160 samples.  Some computations are done
 * once per frame to produce at the output of the coder the
 * LARc[1..8] parameters which are the coded LAR coefficients and 
 * also to realize the inverse filtering operation for the entire
 * frame (160 samples of signal d[0..159]).  These parts produce at
 * the output of the coder:
 */

	word	* LARc,	/* [0..7] LAR coefficients		OUT	*/

/*
 * Procedure 4.2.11 to 4.2.18 are to be executed four times per
 * frame.  That means once for each sub-segment RPE-LTP analysis of
 * 40 samples.  These parts produce at the output of the coder:
 */

	word	* Nc,	/* [0..3] LTP lag			OUT 	*/
	word	* bc,	/* [0..3] coded LTP gain		OUT 	*/
	word	* Mc,	/* [0..3] RPE grid selection		OUT     */
	word	* xmaxc,/* [0..3] Coded maximum amplitude	OUT	*/
	word	* xMc	/* [13*4] normalized RPE samples	OUT	*/
)
{
	int	k;
	word	* dp  = S->dp0 + 120;	/* [ -120...-1 ] */
	word	* dpp = dp;		/* [ 0...39 ]	 */

	static word e[50];

	word	so[160];

	Gsm_Preprocess			(S, s, so);
	Gsm_LPC_Analysis		(S, so, LARc);
	Gsm_Short_Term_Analysis_Filter	(S, LARc, so);

	for (k = 0; k <= 3; k++, xMc += 13) {

		Gsm_Long_Term_Predictor	( S,
					 so+k*40, /* d      [0..39] IN	*/
					 dp,	  /* dp  [-120..-1] IN	*/
					e + 5,	  /* e      [0..39] OUT	*/
					dpp,	  /* dpp    [0..39] OUT */
					 Nc++,
					 bc++);

		Gsm_RPE_Encoding	( S,
					e + 5,	/* e	  ][0..39][ IN/OUT */
					  xmaxc++, Mc++, xMc );
		/*
		 * Gsm_Update_of_reconstructed_short_time_residual_signal
		 *			( dpp, e + 5, dp );
		 */

		{ register int i;
		  register longword ltmp;
		  for (i = 0; i <= 39; i++)
			dp[ i ] = GSM_ADD( e[5 + i], dpp[i] );
		}
		dp  += 40;
		dpp += 40;

	}
	(void)memcpy( (char *)S->dp0, (char *)(S->dp0 + 160),
		120 * sizeof(*S->dp0) );
}

/****** begin "decode.c" *****/

/*
 *  4.3 FIXED POINT IMPLEMENTATION OF THE RPE-LTP DECODER
 */

static void Postprocessing P2((S,s),
	struct gsm_state	* S,
	register word 		* s)
{
	register int		k;
	register word		msr = S->msr;
	register longword	ltmp;	/* for GSM_ADD */
	register word		tmp;

	for (k = 160; k--; s++) {
		tmp = GSM_MULT_R( msr, 28180 );
		msr = GSM_ADD(*s, tmp);  	   /* Deemphasis 	     */
		*s  = GSM_ADD(msr, msr) & 0xFFF8;  /* Truncation & Upscaling */
	}
	S->msr = msr;
}

void Gsm_Decoder P8((S,LARcr, Ncr,bcr,Mcr,xmaxcr,xMcr,s),
	struct gsm_state	* S,

	word		* LARcr,	/* [0..7]		IN	*/

	word		* Ncr,		/* [0..3] 		IN 	*/
	word		* bcr,		/* [0..3]		IN	*/
	word		* Mcr,		/* [0..3] 		IN 	*/
	word		* xmaxcr,	/* [0..3]		IN 	*/
	word		* xMcr,		/* [0..13*4]		IN	*/

	word		* s)		/* [0..159]		OUT 	*/
{
	int		j, k;
	word		erp[40], wt[160];
	word		* drp = S->dp0 + 120;

	for (j=0; j <= 3; j++, xmaxcr++, bcr++, Ncr++, Mcr++, xMcr += 13) {

		Gsm_RPE_Decoding( S, *xmaxcr, *Mcr, xMcr, erp );
		Gsm_Long_Term_Synthesis_Filtering( S, *Ncr, *bcr, erp, drp );

		for (k = 0; k <= 39; k++) wt[ j * 40 + k ] =  drp[ k ];
	}

	Gsm_Short_Term_Synthesis_Filter( S, LARcr, wt, s );
	Postprocessing(S, s);
}

/****** begin "gsm_decode.c" *****/

int gsm_decode P3((s, c, target), gsm s, gsm_byte * c, gsm_signal * target)
{
	word  	LARc[8], Nc[4], Mc[4], bc[4], xmaxc[4], xmc[13*4];

#ifdef WAV49
	if (s->wav_fmt) {

		uword sr = 0;

		s->frame_index = !!s->frame_index;
		if (s->frame_index) {

			sr = *c++;
			LARc[0] = sr & 0x3f;  sr >>= 6;
			sr |= (uword)*c++ << 2;
			LARc[1] = sr & 0x3f;  sr >>= 6;
			sr |= (uword)*c++ << 4;
			LARc[2] = sr & 0x1f;  sr >>= 5;
			LARc[3] = sr & 0x1f;  sr >>= 5;
			sr |= (uword)*c++ << 2;
			LARc[4] = sr & 0xf;  sr >>= 4;
			LARc[5] = sr & 0xf;  sr >>= 4;
			sr |= (uword)*c++ << 2;			/* 5 */
			LARc[6] = sr & 0x7;  sr >>= 3;
			LARc[7] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 4;
			Nc[0] = sr & 0x7f;  sr >>= 7;
			bc[0] = sr & 0x3;  sr >>= 2;
			Mc[0] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 1;
			xmaxc[0] = sr & 0x3f;  sr >>= 6;
			xmc[0] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[1] = sr & 0x7;  sr >>= 3;
			xmc[2] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[3] = sr & 0x7;  sr >>= 3;
			xmc[4] = sr & 0x7;  sr >>= 3;
			xmc[5] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;			/* 10 */
			xmc[6] = sr & 0x7;  sr >>= 3;
			xmc[7] = sr & 0x7;  sr >>= 3;
			xmc[8] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[9] = sr & 0x7;  sr >>= 3;
			xmc[10] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[11] = sr & 0x7;  sr >>= 3;
			xmc[12] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 4;
			Nc[1] = sr & 0x7f;  sr >>= 7;
			bc[1] = sr & 0x3;  sr >>= 2;
			Mc[1] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 1;
			xmaxc[1] = sr & 0x3f;  sr >>= 6;
			xmc[13] = sr & 0x7;  sr >>= 3;
			sr = *c++;				/* 15 */
			xmc[14] = sr & 0x7;  sr >>= 3;
			xmc[15] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[16] = sr & 0x7;  sr >>= 3;
			xmc[17] = sr & 0x7;  sr >>= 3;
			xmc[18] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[19] = sr & 0x7;  sr >>= 3;
			xmc[20] = sr & 0x7;  sr >>= 3;
			xmc[21] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[22] = sr & 0x7;  sr >>= 3;
			xmc[23] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[24] = sr & 0x7;  sr >>= 3;
			xmc[25] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 4;			/* 20 */
			Nc[2] = sr & 0x7f;  sr >>= 7;
			bc[2] = sr & 0x3;  sr >>= 2;
			Mc[2] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 1;
			xmaxc[2] = sr & 0x3f;  sr >>= 6;
			xmc[26] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[27] = sr & 0x7;  sr >>= 3;
			xmc[28] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[29] = sr & 0x7;  sr >>= 3;
			xmc[30] = sr & 0x7;  sr >>= 3;
			xmc[31] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[32] = sr & 0x7;  sr >>= 3;
			xmc[33] = sr & 0x7;  sr >>= 3;
			xmc[34] = sr & 0x7;  sr >>= 3;
			sr = *c++;				/* 25 */
			xmc[35] = sr & 0x7;  sr >>= 3;
			xmc[36] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[37] = sr & 0x7;  sr >>= 3;
			xmc[38] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 4;
			Nc[3] = sr & 0x7f;  sr >>= 7;
			bc[3] = sr & 0x3;  sr >>= 2;
			Mc[3] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 1;
			xmaxc[3] = sr & 0x3f;  sr >>= 6;
			xmc[39] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[40] = sr & 0x7;  sr >>= 3;
			xmc[41] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;			/* 30 */
			xmc[42] = sr & 0x7;  sr >>= 3;
			xmc[43] = sr & 0x7;  sr >>= 3;
			xmc[44] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[45] = sr & 0x7;  sr >>= 3;
			xmc[46] = sr & 0x7;  sr >>= 3;
			xmc[47] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[48] = sr & 0x7;  sr >>= 3;
			xmc[49] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[50] = sr & 0x7;  sr >>= 3;
			xmc[51] = sr & 0x7;  sr >>= 3;

			s->frame_chain = sr & 0xf;
		}
		else {
			sr = s->frame_chain;
			sr |= (uword)*c++ << 4;			/* 1 */
			LARc[0] = sr & 0x3f;  sr >>= 6;
			LARc[1] = sr & 0x3f;  sr >>= 6;
			sr = *c++;
			LARc[2] = sr & 0x1f;  sr >>= 5;
			sr |= (uword)*c++ << 3;
			LARc[3] = sr & 0x1f;  sr >>= 5;
			LARc[4] = sr & 0xf;  sr >>= 4;
			sr |= (uword)*c++ << 2;
			LARc[5] = sr & 0xf;  sr >>= 4;
			LARc[6] = sr & 0x7;  sr >>= 3;
			LARc[7] = sr & 0x7;  sr >>= 3;
			sr = *c++;				/* 5 */
			Nc[0] = sr & 0x7f;  sr >>= 7;
			sr |= (uword)*c++ << 1;
			bc[0] = sr & 0x3;  sr >>= 2;
			Mc[0] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 5;
			xmaxc[0] = sr & 0x3f;  sr >>= 6;
			xmc[0] = sr & 0x7;  sr >>= 3;
			xmc[1] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[2] = sr & 0x7;  sr >>= 3;
			xmc[3] = sr & 0x7;  sr >>= 3;
			xmc[4] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[5] = sr & 0x7;  sr >>= 3;
			xmc[6] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;			/* 10 */
			xmc[7] = sr & 0x7;  sr >>= 3;
			xmc[8] = sr & 0x7;  sr >>= 3;
			xmc[9] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[10] = sr & 0x7;  sr >>= 3;
			xmc[11] = sr & 0x7;  sr >>= 3;
			xmc[12] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			Nc[1] = sr & 0x7f;  sr >>= 7;
			sr |= (uword)*c++ << 1;
			bc[1] = sr & 0x3;  sr >>= 2;
			Mc[1] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 5;
			xmaxc[1] = sr & 0x3f;  sr >>= 6;
			xmc[13] = sr & 0x7;  sr >>= 3;
			xmc[14] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;			/* 15 */
			xmc[15] = sr & 0x7;  sr >>= 3;
			xmc[16] = sr & 0x7;  sr >>= 3;
			xmc[17] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[18] = sr & 0x7;  sr >>= 3;
			xmc[19] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[20] = sr & 0x7;  sr >>= 3;
			xmc[21] = sr & 0x7;  sr >>= 3;
			xmc[22] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[23] = sr & 0x7;  sr >>= 3;
			xmc[24] = sr & 0x7;  sr >>= 3;
			xmc[25] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			Nc[2] = sr & 0x7f;  sr >>= 7;
			sr |= (uword)*c++ << 1;			/* 20 */
			bc[2] = sr & 0x3;  sr >>= 2;
			Mc[2] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 5;
			xmaxc[2] = sr & 0x3f;  sr >>= 6;
			xmc[26] = sr & 0x7;  sr >>= 3;
			xmc[27] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;	
			xmc[28] = sr & 0x7;  sr >>= 3;
			xmc[29] = sr & 0x7;  sr >>= 3;
			xmc[30] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			xmc[31] = sr & 0x7;  sr >>= 3;
			xmc[32] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[33] = sr & 0x7;  sr >>= 3;
			xmc[34] = sr & 0x7;  sr >>= 3;
			xmc[35] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;			/* 25 */
			xmc[36] = sr & 0x7;  sr >>= 3;
			xmc[37] = sr & 0x7;  sr >>= 3;
			xmc[38] = sr & 0x7;  sr >>= 3;
			sr = *c++;
			Nc[3] = sr & 0x7f;  sr >>= 7;
			sr |= (uword)*c++ << 1;		
			bc[3] = sr & 0x3;  sr >>= 2;
			Mc[3] = sr & 0x3;  sr >>= 2;
			sr |= (uword)*c++ << 5;
			xmaxc[3] = sr & 0x3f;  sr >>= 6;
			xmc[39] = sr & 0x7;  sr >>= 3;
			xmc[40] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[41] = sr & 0x7;  sr >>= 3;
			xmc[42] = sr & 0x7;  sr >>= 3;
			xmc[43] = sr & 0x7;  sr >>= 3;
			sr = *c++;				/* 30 */
			xmc[44] = sr & 0x7;  sr >>= 3;
			xmc[45] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 2;
			xmc[46] = sr & 0x7;  sr >>= 3;
			xmc[47] = sr & 0x7;  sr >>= 3;
			xmc[48] = sr & 0x7;  sr >>= 3;
			sr |= (uword)*c++ << 1;
			xmc[49] = sr & 0x7;  sr >>= 3;
			xmc[50] = sr & 0x7;  sr >>= 3;
			xmc[51] = sr & 0x7;  sr >>= 3;
		}
	}
	else
#endif
	{
		/* GSM_MAGIC  = (*c >> 4) & 0xF; */

		if (((*c >> 4) & 0x0F) !!= GSM_MAGIC) return -1;

		LARc[0]  = (*c++ & 0xF) << 2;		/* 1 */
		LARc[0] |= (*c >> 6) & 0x3;
		LARc[1]  = *c++ & 0x3F;
		LARc[2]  = (*c >> 3) & 0x1F;
		LARc[3]  = (*c++ & 0x7) << 2;
		LARc[3] |= (*c >> 6) & 0x3;
		LARc[4]  = (*c >> 2) & 0xF;
		LARc[5]  = (*c++ & 0x3) << 2;
		LARc[5] |= (*c >> 6) & 0x3;
		LARc[6]  = (*c >> 3) & 0x7;
		LARc[7]  = *c++ & 0x7;
		Nc[0]  = (*c >> 1) & 0x7F;
		bc[0]  = (*c++ & 0x1) << 1;
		bc[0] |= (*c >> 7) & 0x1;
		Mc[0]  = (*c >> 5) & 0x3;
		xmaxc[0]  = (*c++ & 0x1F) << 1;
		xmaxc[0] |= (*c >> 7) & 0x1;
		xmc[0]  = (*c >> 4) & 0x7;
		xmc[1]  = (*c >> 1) & 0x7;
		xmc[2]  = (*c++ & 0x1) << 2;
		xmc[2] |= (*c >> 6) & 0x3;
		xmc[3]  = (*c >> 3) & 0x7;
		xmc[4]  = *c++ & 0x7;
		xmc[5]  = (*c >> 5) & 0x7;
		xmc[6]  = (*c >> 2) & 0x7;
		xmc[7]  = (*c++ & 0x3) << 1;		/* 10 */
		xmc[7] |= (*c >> 7) & 0x1;
		xmc[8]  = (*c >> 4) & 0x7;
		xmc[9]  = (*c >> 1) & 0x7;
		xmc[10]  = (*c++ & 0x1) << 2;
		xmc[10] |= (*c >> 6) & 0x3;
		xmc[11]  = (*c >> 3) & 0x7;
		xmc[12]  = *c++ & 0x7;
		Nc[1]  = (*c >> 1) & 0x7F;
		bc[1]  = (*c++ & 0x1) << 1;
		bc[1] |= (*c >> 7) & 0x1;
		Mc[1]  = (*c >> 5) & 0x3;
		xmaxc[1]  = (*c++ & 0x1F) << 1;
		xmaxc[1] |= (*c >> 7) & 0x1;
		xmc[13]  = (*c >> 4) & 0x7;
		xmc[14]  = (*c >> 1) & 0x7;
		xmc[15]  = (*c++ & 0x1) << 2;
		xmc[15] |= (*c >> 6) & 0x3;
		xmc[16]  = (*c >> 3) & 0x7;
		xmc[17]  = *c++ & 0x7;
		xmc[18]  = (*c >> 5) & 0x7;
		xmc[19]  = (*c >> 2) & 0x7;
		xmc[20]  = (*c++ & 0x3) << 1;
		xmc[20] |= (*c >> 7) & 0x1;
		xmc[21]  = (*c >> 4) & 0x7;
		xmc[22]  = (*c >> 1) & 0x7;
		xmc[23]  = (*c++ & 0x1) << 2;
		xmc[23] |= (*c >> 6) & 0x3;
		xmc[24]  = (*c >> 3) & 0x7;
		xmc[25]  = *c++ & 0x7;
		Nc[2]  = (*c >> 1) & 0x7F;
		bc[2]  = (*c++ & 0x1) << 1;		/* 20 */
		bc[2] |= (*c >> 7) & 0x1;
		Mc[2]  = (*c >> 5) & 0x3;
		xmaxc[2]  = (*c++ & 0x1F) << 1;
		xmaxc[2] |= (*c >> 7) & 0x1;
		xmc[26]  = (*c >> 4) & 0x7;
		xmc[27]  = (*c >> 1) & 0x7;
		xmc[28]  = (*c++ & 0x1) << 2;
		xmc[28] |= (*c >> 6) & 0x3;
		xmc[29]  = (*c >> 3) & 0x7;
		xmc[30]  = *c++ & 0x7;
		xmc[31]  = (*c >> 5) & 0x7;
		xmc[32]  = (*c >> 2) & 0x7;
		xmc[33]  = (*c++ & 0x3) << 1;
		xmc[33] |= (*c >> 7) & 0x1;
		xmc[34]  = (*c >> 4) & 0x7;
		xmc[35]  = (*c >> 1) & 0x7;
		xmc[36]  = (*c++ & 0x1) << 2;
		xmc[36] |= (*c >> 6) & 0x3;
		xmc[37]  = (*c >> 3) & 0x7;
		xmc[38]  = *c++ & 0x7;
		Nc[3]  = (*c >> 1) & 0x7F;
		bc[3]  = (*c++ & 0x1) << 1;
		bc[3] |= (*c >> 7) & 0x1;
		Mc[3]  = (*c >> 5) & 0x3;
		xmaxc[3]  = (*c++ & 0x1F) << 1;
		xmaxc[3] |= (*c >> 7) & 0x1;
		xmc[39]  = (*c >> 4) & 0x7;
		xmc[40]  = (*c >> 1) & 0x7;
		xmc[41]  = (*c++ & 0x1) << 2;
		xmc[41] |= (*c >> 6) & 0x3;
		xmc[42]  = (*c >> 3) & 0x7;
		xmc[43]  = *c++ & 0x7;			/* 30  */
		xmc[44]  = (*c >> 5) & 0x7;
		xmc[45]  = (*c >> 2) & 0x7;
		xmc[46]  = (*c++ & 0x3) << 1;
		xmc[46] |= (*c >> 7) & 0x1;
		xmc[47]  = (*c >> 4) & 0x7;
		xmc[48]  = (*c >> 1) & 0x7;
		xmc[49]  = (*c++ & 0x1) << 2;
		xmc[49] |= (*c >> 6) & 0x3;
		xmc[50]  = (*c >> 3) & 0x7;
		xmc[51]  = *c & 0x7;			/* 33 */
	}

	Gsm_Decoder(s, LARc, Nc, bc, Mc, xmaxc, xmc, target);

	return 0;
}

/****** begin "gsm_encode.c" *****/

void gsm_encode P3((s, source, c), gsm s, gsm_signal * source, gsm_byte * c)
{
	word	 	LARc[8], Nc[4], Mc[4], bc[4], xmaxc[4], xmc[13*4];

	Gsm_Coder(s, source, LARc, Nc, bc, Mc, xmaxc, xmc);


	/*	variable	size

		GSM_MAGIC	4

		LARc[0]		6
		LARc[1]		6
		LARc[2]		5
		LARc[3]		5
		LARc[4]		4
		LARc[5]		4
		LARc[6]		3
		LARc[7]		3

		Nc[0]		7
		bc[0]		2
		Mc[0]		2
		xmaxc[0]	6
		xmc[0]		3
		xmc[1]		3
		xmc[2]		3
		xmc[3]		3
		xmc[4]		3
		xmc[5]		3
		xmc[6]		3
		xmc[7]		3
		xmc[8]		3
		xmc[9]		3
		xmc[10]		3
		xmc[11]		3
		xmc[12]		3

		Nc[1]		7
		bc[1]		2
		Mc[1]		2
		xmaxc[1]	6
		xmc[13]		3
		xmc[14]		3
		xmc[15]		3
		xmc[16]		3
		xmc[17]		3
		xmc[18]		3
		xmc[19]		3
		xmc[20]		3
		xmc[21]		3
		xmc[22]		3
		xmc[23]		3
		xmc[24]		3
		xmc[25]		3

		Nc[2]		7
		bc[2]		2
		Mc[2]		2
		xmaxc[2]	6
		xmc[26]		3
		xmc[27]		3
		xmc[28]		3
		xmc[29]		3
		xmc[30]		3
		xmc[31]		3
		xmc[32]		3
		xmc[33]		3
		xmc[34]		3
		xmc[35]		3
		xmc[36]		3
		xmc[37]		3
		xmc[38]		3

		Nc[3]		7
		bc[3]		2
		Mc[3]		2
		xmaxc[3]	6
		xmc[39]		3
		xmc[40]		3
		xmc[41]		3
		xmc[42]		3
		xmc[43]		3
		xmc[44]		3
		xmc[45]		3
		xmc[46]		3
		xmc[47]		3
		xmc[48]		3
		xmc[49]		3
		xmc[50]		3
		xmc[51]		3
	*/

#ifdef WAV49

	if (s->wav_fmt) {
		s->frame_index = !!s->frame_index;
		if (s->frame_index) {

			uword sr;

			sr = 0;
			sr = sr >> 6 | LARc[0] << 10;
			sr = sr >> 6 | LARc[1] << 10;
			*c++ = sr >> 4;
			sr = sr >> 5 | LARc[2] << 11;
			*c++ = sr >> 7;
			sr = sr >> 5 | LARc[3] << 11;
			sr = sr >> 4 | LARc[4] << 12;
			*c++ = sr >> 6;
			sr = sr >> 4 | LARc[5] << 12;
			sr = sr >> 3 | LARc[6] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | LARc[7] << 13;
			sr = sr >> 7 | Nc[0] << 9;
			*c++ = sr >> 5;
			sr = sr >> 2 | bc[0] << 14;
			sr = sr >> 2 | Mc[0] << 14;
			sr = sr >> 6 | xmaxc[0] << 10;
			*c++ = sr >> 3;
			sr = sr >> 3 | xmc[0] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[1] << 13;
			sr = sr >> 3 | xmc[2] << 13;
			sr = sr >> 3 | xmc[3] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[4] << 13;
			sr = sr >> 3 | xmc[5] << 13;
			sr = sr >> 3 | xmc[6] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[7] << 13;
			sr = sr >> 3 | xmc[8] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[9] << 13;
			sr = sr >> 3 | xmc[10] << 13;
			sr = sr >> 3 | xmc[11] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[12] << 13;
			sr = sr >> 7 | Nc[1] << 9;
			*c++ = sr >> 5;
			sr = sr >> 2 | bc[1] << 14;
			sr = sr >> 2 | Mc[1] << 14;
			sr = sr >> 6 | xmaxc[1] << 10;
			*c++ = sr >> 3;
			sr = sr >> 3 | xmc[13] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[14] << 13;
			sr = sr >> 3 | xmc[15] << 13;
			sr = sr >> 3 | xmc[16] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[17] << 13;
			sr = sr >> 3 | xmc[18] << 13;
			sr = sr >> 3 | xmc[19] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[20] << 13;
			sr = sr >> 3 | xmc[21] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[22] << 13;
			sr = sr >> 3 | xmc[23] << 13;
			sr = sr >> 3 | xmc[24] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[25] << 13;
			sr = sr >> 7 | Nc[2] << 9;
			*c++ = sr >> 5;
			sr = sr >> 2 | bc[2] << 14;
			sr = sr >> 2 | Mc[2] << 14;
			sr = sr >> 6 | xmaxc[2] << 10;
			*c++ = sr >> 3;
			sr = sr >> 3 | xmc[26] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[27] << 13;
			sr = sr >> 3 | xmc[28] << 13;
			sr = sr >> 3 | xmc[29] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[30] << 13;
			sr = sr >> 3 | xmc[31] << 13;
			sr = sr >> 3 | xmc[32] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[33] << 13;
			sr = sr >> 3 | xmc[34] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[35] << 13;
			sr = sr >> 3 | xmc[36] << 13;
			sr = sr >> 3 | xmc[37] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[38] << 13;
			sr = sr >> 7 | Nc[3] << 9;
			*c++ = sr >> 5;
			sr = sr >> 2 | bc[3] << 14;
			sr = sr >> 2 | Mc[3] << 14;
			sr = sr >> 6 | xmaxc[3] << 10;
			*c++ = sr >> 3;
			sr = sr >> 3 | xmc[39] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[40] << 13;
			sr = sr >> 3 | xmc[41] << 13;
			sr = sr >> 3 | xmc[42] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[43] << 13;
			sr = sr >> 3 | xmc[44] << 13;
			sr = sr >> 3 | xmc[45] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[46] << 13;
			sr = sr >> 3 | xmc[47] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[48] << 13;
			sr = sr >> 3 | xmc[49] << 13;
			sr = sr >> 3 | xmc[50] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[51] << 13;
			sr = sr >> 4;
			*c = sr >> 8;
			s->frame_chain = *c;
		}
		else {
			uword sr;

			sr = 0;
			sr = sr >> 4 | s->frame_chain << 12;
			sr = sr >> 6 | LARc[0] << 10;
			*c++ = sr >> 6;
			sr = sr >> 6 | LARc[1] << 10;
			*c++ = sr >> 8;
			sr = sr >> 5 | LARc[2] << 11;
			sr = sr >> 5 | LARc[3] << 11;
			*c++ = sr >> 6;
			sr = sr >> 4 | LARc[4] << 12;
			sr = sr >> 4 | LARc[5] << 12;
			*c++ = sr >> 6;
			sr = sr >> 3 | LARc[6] << 13;
			sr = sr >> 3 | LARc[7] << 13;
			*c++ = sr >> 8;
			sr = sr >> 7 | Nc[0] << 9;
			sr = sr >> 2 | bc[0] << 14;
			*c++ = sr >> 7;
			sr = sr >> 2 | Mc[0] << 14;
			sr = sr >> 6 | xmaxc[0] << 10;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[0] << 13;
			sr = sr >> 3 | xmc[1] << 13;
			sr = sr >> 3 | xmc[2] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[3] << 13;
			sr = sr >> 3 | xmc[4] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[5] << 13;
			sr = sr >> 3 | xmc[6] << 13;
			sr = sr >> 3 | xmc[7] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[8] << 13;
			sr = sr >> 3 | xmc[9] << 13;
			sr = sr >> 3 | xmc[10] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[11] << 13;
			sr = sr >> 3 | xmc[12] << 13;
			*c++ = sr >> 8;
			sr = sr >> 7 | Nc[1] << 9;
			sr = sr >> 2 | bc[1] << 14;
			*c++ = sr >> 7;
			sr = sr >> 2 | Mc[1] << 14;
			sr = sr >> 6 | xmaxc[1] << 10;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[13] << 13;
			sr = sr >> 3 | xmc[14] << 13;
			sr = sr >> 3 | xmc[15] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[16] << 13;
			sr = sr >> 3 | xmc[17] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[18] << 13;
			sr = sr >> 3 | xmc[19] << 13;
			sr = sr >> 3 | xmc[20] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[21] << 13;
			sr = sr >> 3 | xmc[22] << 13;
			sr = sr >> 3 | xmc[23] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[24] << 13;
			sr = sr >> 3 | xmc[25] << 13;
			*c++ = sr >> 8;
			sr = sr >> 7 | Nc[2] << 9;
			sr = sr >> 2 | bc[2] << 14;
			*c++ = sr >> 7;
			sr = sr >> 2 | Mc[2] << 14;
			sr = sr >> 6 | xmaxc[2] << 10;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[26] << 13;
			sr = sr >> 3 | xmc[27] << 13;
			sr = sr >> 3 | xmc[28] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[29] << 13;
			sr = sr >> 3 | xmc[30] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[31] << 13;
			sr = sr >> 3 | xmc[32] << 13;
			sr = sr >> 3 | xmc[33] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[34] << 13;
			sr = sr >> 3 | xmc[35] << 13;
			sr = sr >> 3 | xmc[36] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[37] << 13;
			sr = sr >> 3 | xmc[38] << 13;
			*c++ = sr >> 8;
			sr = sr >> 7 | Nc[3] << 9;
			sr = sr >> 2 | bc[3] << 14;
			*c++ = sr >> 7;
			sr = sr >> 2 | Mc[3] << 14;
			sr = sr >> 6 | xmaxc[3] << 10;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[39] << 13;
			sr = sr >> 3 | xmc[40] << 13;
			sr = sr >> 3 | xmc[41] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[42] << 13;
			sr = sr >> 3 | xmc[43] << 13;
			*c++ = sr >> 8;
			sr = sr >> 3 | xmc[44] << 13;
			sr = sr >> 3 | xmc[45] << 13;
			sr = sr >> 3 | xmc[46] << 13;
			*c++ = sr >> 7;
			sr = sr >> 3 | xmc[47] << 13;
			sr = sr >> 3 | xmc[48] << 13;
			sr = sr >> 3 | xmc[49] << 13;
			*c++ = sr >> 6;
			sr = sr >> 3 | xmc[50] << 13;
			sr = sr >> 3 | xmc[51] << 13;
			*c++ = sr >> 8;
		}
	}

	else

#endif	/* WAV49 */
	{

		*c++ =   ((GSM_MAGIC & 0xF) << 4)		/* 1 */
		       | ((LARc[0] >> 2) & 0xF);
		*c++ =   ((LARc[0] & 0x3) << 6)
		       | (LARc[1] & 0x3F);
		*c++ =   ((LARc[2] & 0x1F) << 3)
		       | ((LARc[3] >> 2) & 0x7);
		*c++ =   ((LARc[3] & 0x3) << 6)
		       | ((LARc[4] & 0xF) << 2)
		       | ((LARc[5] >> 2) & 0x3);
		*c++ =   ((LARc[5] & 0x3) << 6)
		       | ((LARc[6] & 0x7) << 3)
		       | (LARc[7] & 0x7);
		*c++ =   ((Nc[0] & 0x7F) << 1)
		       | ((bc[0] >> 1) & 0x1);
		*c++ =   ((bc[0] & 0x1) << 7)
		       | ((Mc[0] & 0x3) << 5)
		       | ((xmaxc[0] >> 1) & 0x1F);
		*c++ =   ((xmaxc[0] & 0x1) << 7)
		       | ((xmc[0] & 0x7) << 4)
		       | ((xmc[1] & 0x7) << 1)
		       | ((xmc[2] >> 2) & 0x1);
		*c++ =   ((xmc[2] & 0x3) << 6)
		       | ((xmc[3] & 0x7) << 3)
		       | (xmc[4] & 0x7);
		*c++ =   ((xmc[5] & 0x7) << 5)			/* 10 */
		       | ((xmc[6] & 0x7) << 2)
		       | ((xmc[7] >> 1) & 0x3);
		*c++ =   ((xmc[7] & 0x1) << 7)
		       | ((xmc[8] & 0x7) << 4)
		       | ((xmc[9] & 0x7) << 1)
		       | ((xmc[10] >> 2) & 0x1);
		*c++ =   ((xmc[10] & 0x3) << 6)
		       | ((xmc[11] & 0x7) << 3)
		       | (xmc[12] & 0x7);
		*c++ =   ((Nc[1] & 0x7F) << 1)
		       | ((bc[1] >> 1) & 0x1);
		*c++ =   ((bc[1] & 0x1) << 7)
		       | ((Mc[1] & 0x3) << 5)
		       | ((xmaxc[1] >> 1) & 0x1F);
		*c++ =   ((xmaxc[1] & 0x1) << 7)
		       | ((xmc[13] & 0x7) << 4)
		       | ((xmc[14] & 0x7) << 1)
		       | ((xmc[15] >> 2) & 0x1);
		*c++ =   ((xmc[15] & 0x3) << 6)
		       | ((xmc[16] & 0x7) << 3)
		       | (xmc[17] & 0x7);
		*c++ =   ((xmc[18] & 0x7) << 5)
		       | ((xmc[19] & 0x7) << 2)
		       | ((xmc[20] >> 1) & 0x3);
		*c++ =   ((xmc[20] & 0x1) << 7)
		       | ((xmc[21] & 0x7) << 4)
		       | ((xmc[22] & 0x7) << 1)
		       | ((xmc[23] >> 2) & 0x1);
		*c++ =   ((xmc[23] & 0x3) << 6)
		       | ((xmc[24] & 0x7) << 3)
		       | (xmc[25] & 0x7);
		*c++ =   ((Nc[2] & 0x7F) << 1)			/* 20 */
		       | ((bc[2] >> 1) & 0x1);
		*c++ =   ((bc[2] & 0x1) << 7)
		       | ((Mc[2] & 0x3) << 5)
		       | ((xmaxc[2] >> 1) & 0x1F);
		*c++ =   ((xmaxc[2] & 0x1) << 7)
		       | ((xmc[26] & 0x7) << 4)
		       | ((xmc[27] & 0x7) << 1)
		       | ((xmc[28] >> 2) & 0x1);
		*c++ =   ((xmc[28] & 0x3) << 6)
		       | ((xmc[29] & 0x7) << 3)
		       | (xmc[30] & 0x7);
		*c++ =   ((xmc[31] & 0x7) << 5)
		       | ((xmc[32] & 0x7) << 2)
		       | ((xmc[33] >> 1) & 0x3);
		*c++ =   ((xmc[33] & 0x1) << 7)
		       | ((xmc[34] & 0x7) << 4)
		       | ((xmc[35] & 0x7) << 1)
		       | ((xmc[36] >> 2) & 0x1);
		*c++ =   ((xmc[36] & 0x3) << 6)
		       | ((xmc[37] & 0x7) << 3)
		       | (xmc[38] & 0x7);
		*c++ =   ((Nc[3] & 0x7F) << 1)
		       | ((bc[3] >> 1) & 0x1);
		*c++ =   ((bc[3] & 0x1) << 7)
		       | ((Mc[3] & 0x3) << 5)
		       | ((xmaxc[3] >> 1) & 0x1F);
		*c++ =   ((xmaxc[3] & 0x1) << 7)
		       | ((xmc[39] & 0x7) << 4)
		       | ((xmc[40] & 0x7) << 1)
		       | ((xmc[41] >> 2) & 0x1);
		*c++ =   ((xmc[41] & 0x3) << 6)			/* 30 */
		       | ((xmc[42] & 0x7) << 3)
		       | (xmc[43] & 0x7);
		*c++ =   ((xmc[44] & 0x7) << 5)
		       | ((xmc[45] & 0x7) << 2)
		       | ((xmc[46] >> 1) & 0x3);
		*c++ =   ((xmc[46] & 0x1) << 7)
		       | ((xmc[47] & 0x7) << 4)
		       | ((xmc[48] & 0x7) << 1)
		       | ((xmc[49] >> 2) & 0x1);
		*c++ =   ((xmc[49] & 0x3) << 6)
		       | ((xmc[50] & 0x7) << 3)
		       | (xmc[51] & 0x7);

	}
}

/****** begin "long_term.c" *****/

/*
 *  4.2.11 .. 4.2.12 LONG TERM PREDICTOR (LTP) SECTION
 */


/*
 * This module computes the LTP gain (bc) and the LTP lag (Nc)
 * for the long term analysis filter.   This is done by calculating a
 * maximum of the cross-correlation function between the current
 * sub-segment short term residual signal d[0..39] (output of
 * the short term analysis filter; for simplification the index
 * of this array begins at 0 and ends at 39 for each sub-segment of the
 * RPE-LTP analysis) and the previous reconstructed short term
 * residual signal dp[ -120 .. -1 ].  A dynamic scaling must be
 * performed to avoid overflow.
 */

 /* The next procedure exists in six versions.  First two integer
  * version (if USE_FLOAT_MUL is not defined); then four floating
  * point versions, twice with proper scaling (USE_FLOAT_MUL defined),
  * once without (USE_FLOAT_MUL and FAST defined, and fast run-time
  * option used).  Every pair has first a Cut version (see the -C
  * option to toast or the LTP_CUT option to gsm_option()), then the
  * uncut one.  (For a detailed explanation of why this is altogether
  * a bad idea, see Henry Spencer and Geoff Collyer, ``#ifdef Considered
  * Harmful''''.)
  */

#ifndef  USE_FLOAT_MUL

#ifdef	LTP_CUT

static void Cut_Calculation_of_the_LTP_parameters P5((st, d,dp,bc_out,Nc_out),

	struct gsm_state * st,

	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	word		Nc, bc;
	word		wt[40];

	longword	L_result;
	longword	L_max, L_power;
	word		R, S, dmax, scal, best_k;
	word		ltp_cut;

	register word	temp, wt_k;

	/*  Search of the optimum scaling of d[0..39].
	 */
	dmax = 0;
	for (k = 0; k <= 39; k++) {
		temp = d[k];
		temp = GSM_ABS( temp );
		if (temp > dmax) {
			dmax = temp;
			best_k = k;
		}
	}
	temp = 0;
	if (dmax == 0) scal = 0;
	else {
		assert(dmax > 0);
		temp = gsm_norm( (longword)dmax << 16 );
	}
	if (temp > 6) scal = 0;
	else scal = 6 - temp;
	assert(scal >= 0);

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */
	wt_k  = SASR(d[best_k], scal);

	for (lambda = 40; lambda <= 120; lambda++) {
		L_result = (longword)wt_k * dp[best_k - lambda];
		if (L_result > L_max) {
			Nc    = lambda;
			L_max = L_result;
		}
	}
	*Nc_out = Nc;
	L_max <<= 1;

	/*  Rescaling of L_max
	 */
	assert(scal <= 100 && scal >= -100);
	L_max = L_max >> (6 - scal);	/* sub(6, scal) */

	assert( Nc <= 120 && Nc >= 40);

	/*   Compute the power of the reconstructed short term residual
	 *   signal dp[..]
	 */
	L_power = 0;
	for (k = 0; k <= 39; k++) {

		register longword L_temp;

		L_temp   = SASR( dp[k - Nc], 3 );
		L_power += L_temp * L_temp;
	}
	L_power <<= 1;	/* from L_MULT */

	/*  Normalization of L_max and L_power
	 */

	if (L_max <= 0)  {
		*bc_out = 0;
		return;
	}
	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	temp = gsm_norm( L_power );

	R = SASR( L_max   << temp, 16 );
	S = SASR( L_power << temp, 16 );

	/*  Coding of the LTP gain
	 */

	/*  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	for (bc = 0; bc <= 2; bc++) if (R <= gsm_mult(S, gsm_DLB[bc])) break;
	*bc_out = bc;
}

#endif 	/* LTP_CUT */

static void Calculation_of_the_LTP_parameters P4((d,dp,bc_out,Nc_out),
	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	word		Nc, bc;
	word		wt[40];

	longword	L_max, L_power;
	word		R, S, dmax, scal;
	register word	temp;

	/*  Search of the optimum scaling of d[0..39].
	 */
	dmax = 0;

	for (k = 0; k <= 39; k++) {
		temp = d[k];
		temp = GSM_ABS( temp );
		if (temp > dmax) dmax = temp;
	}

	temp = 0;
	if (dmax == 0) scal = 0;
	else {
		assert(dmax > 0);
		temp = gsm_norm( (longword)dmax << 16 );
	}

	if (temp > 6) scal = 0;
	else scal = 6 - temp;

	assert(scal >= 0);

	/*  Initialization of a working array wt
	 */

	for (k = 0; k <= 39; k++) wt[k] = SASR( d[k], scal );

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */

	for (lambda = 40; lambda <= 120; lambda++) {

# undef STEP
#		define STEP(k) 	(longword)wt[k] * dp[k - lambda]

		register longword L_result;

		L_result  = STEP(0)  ; L_result += STEP(1) ;
		L_result += STEP(2)  ; L_result += STEP(3) ;
		L_result += STEP(4)  ; L_result += STEP(5)  ;
		L_result += STEP(6)  ; L_result += STEP(7)  ;
		L_result += STEP(8)  ; L_result += STEP(9)  ;
		L_result += STEP(10) ; L_result += STEP(11) ;
		L_result += STEP(12) ; L_result += STEP(13) ;
		L_result += STEP(14) ; L_result += STEP(15) ;
		L_result += STEP(16) ; L_result += STEP(17) ;
		L_result += STEP(18) ; L_result += STEP(19) ;
		L_result += STEP(20) ; L_result += STEP(21) ;
		L_result += STEP(22) ; L_result += STEP(23) ;
		L_result += STEP(24) ; L_result += STEP(25) ;
		L_result += STEP(26) ; L_result += STEP(27) ;
		L_result += STEP(28) ; L_result += STEP(29) ;
		L_result += STEP(30) ; L_result += STEP(31) ;
		L_result += STEP(32) ; L_result += STEP(33) ;
		L_result += STEP(34) ; L_result += STEP(35) ;
		L_result += STEP(36) ; L_result += STEP(37) ;
		L_result += STEP(38) ; L_result += STEP(39) ;

		if (L_result > L_max) {

			Nc    = lambda;
			L_max = L_result;
		}
	}

	*Nc_out = Nc;

	L_max <<= 1;

	/*  Rescaling of L_max
	 */
	assert(scal <= 100 && scal >=  -100);
	L_max = L_max >> (6 - scal);	/* sub(6, scal) */

	assert( Nc <= 120 && Nc >= 40);

	/*   Compute the power of the reconstructed short term residual
	 *   signal dp[..]
	 */
	L_power = 0;
	for (k = 0; k <= 39; k++) {

		register longword L_temp;

		L_temp   = SASR( dp[k - Nc], 3 );
		L_power += L_temp * L_temp;
	}
	L_power <<= 1;	/* from L_MULT */

	/*  Normalization of L_max and L_power
	 */

	if (L_max <= 0)  {
		*bc_out = 0;
		return;
	}
	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	temp = gsm_norm( L_power );

	R = SASR( L_max   << temp, 16 );
	S = SASR( L_power << temp, 16 );

	/*  Coding of the LTP gain
	 */

	/*  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	for (bc = 0; bc <= 2; bc++) if (R <= gsm_mult(S, gsm_DLB[bc])) break;
	*bc_out = bc;
}

#else	/* USE_FLOAT_MUL */

#ifdef	LTP_CUT

static void Cut_Calculation_of_the_LTP_parameters P5((st, d,dp,bc_out,Nc_out),
	struct gsm_state * st,		/*              IN 	*/
	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	word		Nc, bc;
	word		ltp_cut;

	float		wt_float[40];
	float		dp_float_base[120], * dp_float = dp_float_base + 120;

	longword	L_max, L_power;
	word		R, S, dmax, scal;
	register word	temp;

	/*  Search of the optimum scaling of d[0..39].
	 */
	dmax = 0;

	for (k = 0; k <= 39; k++) {
		temp = d[k];
		temp = GSM_ABS( temp );
		if (temp > dmax) dmax = temp;
	}

	temp = 0;
	if (dmax == 0) scal = 0;
	else {
		assert(dmax > 0);
		temp = gsm_norm( (longword)dmax << 16 );
	}

	if (temp > 6) scal = 0;
	else scal = 6 - temp;

	assert(scal >= 0);
	ltp_cut = (longword)SASR(dmax, scal) * st->ltp_cut / 100; 


	/*  Initialization of a working array wt
	 */

	for (k = 0; k < 40; k++) {
		register word w = SASR( d[k], scal );
		if (w < 0 ? w > -ltp_cut : w < ltp_cut) {
			wt_float[k] = 0.0;
		}
		else {
			wt_float[k] =  w;
		}
	}
	for (k = -120; k <  0; k++) dp_float[k] =  dp[k];

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */

	for (lambda = 40; lambda <= 120; lambda += 9) {

		/*  Calculate L_result for l = lambda .. lambda + 9.
		 */
		register float *lp = dp_float - lambda;

		register float	W;
		register float	a = lp[-8], b = lp[-7], c = lp[-6],
				d = lp[-5], e = lp[-4], f = lp[-3],
				g = lp[-2], h = lp[-1];
		register float  E; 
		register float  S0 = 0, S1 = 0, S2 = 0, S3 = 0, S4 = 0,
				S5 = 0, S6 = 0, S7 = 0, S8 = 0;

#		undef STEP
#		define	STEP(K, a, b, c, d, e, f, g, h) \
			if ((W = wt_float[K]) !!= 0.0) {	\
			E = W * a; S8 += E;		\
			E = W * b; S7 += E;		\
			E = W * c; S6 += E;		\
			E = W * d; S5 += E;		\
			E = W * e; S4 += E;		\
			E = W * f; S3 += E;		\
			E = W * g; S2 += E;		\
			E = W * h; S1 += E;		\
			a  = lp[K];			\
			E = W * a; S0 += E; } else (a = lp[K])

#		define	STEP_A(K)	STEP(K, a, b, c, d, e, f, g, h)
#		define	STEP_B(K)	STEP(K, b, c, d, e, f, g, h, a)
#		define	STEP_C(K)	STEP(K, c, d, e, f, g, h, a, b)
#		define	STEP_D(K)	STEP(K, d, e, f, g, h, a, b, c)
#		define	STEP_E(K)	STEP(K, e, f, g, h, a, b, c, d)
#		define	STEP_F(K)	STEP(K, f, g, h, a, b, c, d, e)
#		define	STEP_G(K)	STEP(K, g, h, a, b, c, d, e, f)
#		define	STEP_H(K)	STEP(K, h, a, b, c, d, e, f, g)

		STEP_A( 0); STEP_B( 1); STEP_C( 2); STEP_D( 3);
		STEP_E( 4); STEP_F( 5); STEP_G( 6); STEP_H( 7);

		STEP_A( 8); STEP_B( 9); STEP_C(10); STEP_D(11);
		STEP_E(12); STEP_F(13); STEP_G(14); STEP_H(15);

		STEP_A(16); STEP_B(17); STEP_C(18); STEP_D(19);
		STEP_E(20); STEP_F(21); STEP_G(22); STEP_H(23);

		STEP_A(24); STEP_B(25); STEP_C(26); STEP_D(27);
		STEP_E(28); STEP_F(29); STEP_G(30); STEP_H(31);

		STEP_A(32); STEP_B(33); STEP_C(34); STEP_D(35);
		STEP_E(36); STEP_F(37); STEP_G(38); STEP_H(39);

		if (S0 > L_max) { L_max = S0; Nc = lambda;     }
		if (S1 > L_max) { L_max = S1; Nc = lambda + 1; }
		if (S2 > L_max) { L_max = S2; Nc = lambda + 2; }
		if (S3 > L_max) { L_max = S3; Nc = lambda + 3; }
		if (S4 > L_max) { L_max = S4; Nc = lambda + 4; }
		if (S5 > L_max) { L_max = S5; Nc = lambda + 5; }
		if (S6 > L_max) { L_max = S6; Nc = lambda + 6; }
		if (S7 > L_max) { L_max = S7; Nc = lambda + 7; }
		if (S8 > L_max) { L_max = S8; Nc = lambda + 8; }

	}
	*Nc_out = Nc;

	L_max <<= 1;

	/*  Rescaling of L_max
	 */
	assert(scal <= 100 && scal >=  -100);
	L_max = L_max >> (6 - scal);	/* sub(6, scal) */

	assert( Nc <= 120 && Nc >= 40);

	/*   Compute the power of the reconstructed short term residual
	 *   signal dp[..]
	 */
	L_power = 0;
	for (k = 0; k <= 39; k++) {

		register longword L_temp;

		L_temp   = SASR( dp[k - Nc], 3 );
		L_power += L_temp * L_temp;
	}
	L_power <<= 1;	/* from L_MULT */

	/*  Normalization of L_max and L_power
	 */

	if (L_max <= 0)  {
		*bc_out = 0;
		return;
	}
	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	temp = gsm_norm( L_power );

	R = SASR( L_max   << temp, 16 );
	S = SASR( L_power << temp, 16 );

	/*  Coding of the LTP gain
	 */

	/*  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	for (bc = 0; bc <= 2; bc++) if (R <= gsm_mult(S, gsm_DLB[bc])) break;
	*bc_out = bc;
}

#endif /* LTP_CUT */

static void Calculation_of_the_LTP_parameters P4((d,dp,bc_out,Nc_out),
	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	word		Nc, bc;

	float		wt_float[40];
	float		dp_float_base[120], * dp_float = dp_float_base + 120;

	longword	L_max, L_power;
	word		R, S, dmax, scal;
	register word	temp;

	/*  Search of the optimum scaling of d[0..39].
	 */
	dmax = 0;

	for (k = 0; k <= 39; k++) {
		temp = d[k];
		temp = GSM_ABS( temp );
		if (temp > dmax) dmax = temp;
	}

	temp = 0;
	if (dmax == 0) scal = 0;
	else {
		assert(dmax > 0);
		temp = gsm_norm( (longword)dmax << 16 );
	}

	if (temp > 6) scal = 0;
	else scal = 6 - temp;

	assert(scal >= 0);

	/*  Initialization of a working array wt
	 */

	for (k =    0; k < 40; k++) wt_float[k] =  SASR( d[k], scal );
	for (k = -120; k <  0; k++) dp_float[k] =  dp[k];

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */

	for (lambda = 40; lambda <= 120; lambda += 9) {

		/*  Calculate L_result for l = lambda .. lambda + 9.
		 */
		register float *lp = dp_float - lambda;

		register float	W;
		register float	a = lp[-8], b = lp[-7], c = lp[-6],
				d = lp[-5], e = lp[-4], f = lp[-3],
				g = lp[-2], h = lp[-1];
		register float  E; 
		register float  S0 = 0, S1 = 0, S2 = 0, S3 = 0, S4 = 0,
				S5 = 0, S6 = 0, S7 = 0, S8 = 0;

#		undef STEP
#		define	STEP(K, a, b, c, d, e, f, g, h) \
			W = wt_float[K];		\
			E = W * a; S8 += E;		\
			E = W * b; S7 += E;		\
			E = W * c; S6 += E;		\
			E = W * d; S5 += E;		\
			E = W * e; S4 += E;		\
			E = W * f; S3 += E;		\
			E = W * g; S2 += E;		\
			E = W * h; S1 += E;		\
			a  = lp[K];			\
			E = W * a; S0 += E

#		define	STEP_A(K)	STEP(K, a, b, c, d, e, f, g, h)
#		define	STEP_B(K)	STEP(K, b, c, d, e, f, g, h, a)
#		define	STEP_C(K)	STEP(K, c, d, e, f, g, h, a, b)
#		define	STEP_D(K)	STEP(K, d, e, f, g, h, a, b, c)
#		define	STEP_E(K)	STEP(K, e, f, g, h, a, b, c, d)
#		define	STEP_F(K)	STEP(K, f, g, h, a, b, c, d, e)
#		define	STEP_G(K)	STEP(K, g, h, a, b, c, d, e, f)
#		define	STEP_H(K)	STEP(K, h, a, b, c, d, e, f, g)

		STEP_A( 0); STEP_B( 1); STEP_C( 2); STEP_D( 3);
		STEP_E( 4); STEP_F( 5); STEP_G( 6); STEP_H( 7);

		STEP_A( 8); STEP_B( 9); STEP_C(10); STEP_D(11);
		STEP_E(12); STEP_F(13); STEP_G(14); STEP_H(15);

		STEP_A(16); STEP_B(17); STEP_C(18); STEP_D(19);
		STEP_E(20); STEP_F(21); STEP_G(22); STEP_H(23);

		STEP_A(24); STEP_B(25); STEP_C(26); STEP_D(27);
		STEP_E(28); STEP_F(29); STEP_G(30); STEP_H(31);

		STEP_A(32); STEP_B(33); STEP_C(34); STEP_D(35);
		STEP_E(36); STEP_F(37); STEP_G(38); STEP_H(39);

		if (S0 > L_max) { L_max = S0; Nc = lambda;     }
		if (S1 > L_max) { L_max = S1; Nc = lambda + 1; }
		if (S2 > L_max) { L_max = S2; Nc = lambda + 2; }
		if (S3 > L_max) { L_max = S3; Nc = lambda + 3; }
		if (S4 > L_max) { L_max = S4; Nc = lambda + 4; }
		if (S5 > L_max) { L_max = S5; Nc = lambda + 5; }
		if (S6 > L_max) { L_max = S6; Nc = lambda + 6; }
		if (S7 > L_max) { L_max = S7; Nc = lambda + 7; }
		if (S8 > L_max) { L_max = S8; Nc = lambda + 8; }
	}
	*Nc_out = Nc;

	L_max <<= 1;

	/*  Rescaling of L_max
	 */
	assert(scal <= 100 && scal >=  -100);
	L_max = L_max >> (6 - scal);	/* sub(6, scal) */

	assert( Nc <= 120 && Nc >= 40);

	/*   Compute the power of the reconstructed short term residual
	 *   signal dp[..]
	 */
	L_power = 0;
	for (k = 0; k <= 39; k++) {

		register longword L_temp;

		L_temp   = SASR( dp[k - Nc], 3 );
		L_power += L_temp * L_temp;
	}
	L_power <<= 1;	/* from L_MULT */

	/*  Normalization of L_max and L_power
	 */

	if (L_max <= 0)  {
		*bc_out = 0;
		return;
	}
	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	temp = gsm_norm( L_power );

	R = SASR( L_max   << temp, 16 );
	S = SASR( L_power << temp, 16 );

	/*  Coding of the LTP gain
	 */

	/*  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	for (bc = 0; bc <= 2; bc++) if (R <= gsm_mult(S, gsm_DLB[bc])) break;
	*bc_out = bc;
}

#ifdef	FAST
#ifdef	LTP_CUT

static void Cut_Fast_Calculation_of_the_LTP_parameters P5((st,
							d,dp,bc_out,Nc_out),
	struct gsm_state * st,		/*              IN	*/
	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	register float	wt_float;
	word		Nc, bc;
	word		wt_max, best_k, ltp_cut;

	float		dp_float_base[120], * dp_float = dp_float_base + 120;

	register float	L_result, L_max, L_power;

	wt_max = 0;

	for (k = 0; k < 40; ++k) {
		if      ( d[k] > wt_max) wt_max =  d[best_k = k];
		else if (-d[k] > wt_max) wt_max = -d[best_k = k];
	}

	assert(wt_max >= 0);
	wt_float = (float)wt_max;

	for (k = -120; k < 0; ++k) dp_float[k] = (float)dp[k];

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */

	for (lambda = 40; lambda <= 120; lambda++) {
		L_result = wt_float * dp_float[best_k - lambda];
		if (L_result > L_max) {
			Nc    = lambda;
			L_max = L_result;
		}
	}

	*Nc_out = Nc;
	if (L_max <= 0.)  {
		*bc_out = 0;
		return;
	}

	/*  Compute the power of the reconstructed short term residual
	 *  signal dp[..]
	 */
	dp_float -= Nc;
	L_power = 0;
	for (k = 0; k < 40; ++k) {
		register float f = dp_float[k];
		L_power += f * f;
	}

	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	/*  Coding of the LTP gain
	 *  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	lambda = L_max / L_power * 32768.;
	for (bc = 0; bc <= 2; ++bc) if (lambda <= gsm_DLB[bc]) break;
	*bc_out = bc;
}

#endif /* LTP_CUT */

static void Fast_Calculation_of_the_LTP_parameters P4((d,dp,bc_out,Nc_out),
	register word	* d,		/* [0..39]	IN	*/
	register word	* dp,		/* [-120..-1]	IN	*/
	word		* bc_out,	/* 		OUT	*/
	word		* Nc_out	/* 		OUT	*/
)
{
	register int  	k, lambda;
	word		Nc, bc;

	float		wt_float[40];
	float		dp_float_base[120], * dp_float = dp_float_base + 120;

	register float	L_max, L_power;

	for (k = 0; k < 40; ++k) wt_float[k] = (float)d[k];
	for (k = -120; k < 0; ++k) dp_float[k] = (float)dp[k];

	/* Search for the maximum cross-correlation and coding of the LTP lag
	 */
	L_max = 0;
	Nc    = 40;	/* index for the maximum cross-correlation */

	for (lambda = 40; lambda <= 120; lambda += 9) {

		/*  Calculate L_result for l = lambda .. lambda + 9.
		 */
		register float *lp = dp_float - lambda;

		register float	W;
		register float	a = lp[-8], b = lp[-7], c = lp[-6],
				d = lp[-5], e = lp[-4], f = lp[-3],
				g = lp[-2], h = lp[-1];
		register float  E; 
		register float  S0 = 0, S1 = 0, S2 = 0, S3 = 0, S4 = 0,
				S5 = 0, S6 = 0, S7 = 0, S8 = 0;

#		undef STEP
#		define	STEP(K, a, b, c, d, e, f, g, h) \
			W = wt_float[K];		\
			E = W * a; S8 += E;		\
			E = W * b; S7 += E;		\
			E = W * c; S6 += E;		\
			E = W * d; S5 += E;		\
			E = W * e; S4 += E;		\
			E = W * f; S3 += E;		\
			E = W * g; S2 += E;		\
			E = W * h; S1 += E;		\
			a  = lp[K];			\
			E = W * a; S0 += E

#		define	STEP_A(K)	STEP(K, a, b, c, d, e, f, g, h)
#		define	STEP_B(K)	STEP(K, b, c, d, e, f, g, h, a)
#		define	STEP_C(K)	STEP(K, c, d, e, f, g, h, a, b)
#		define	STEP_D(K)	STEP(K, d, e, f, g, h, a, b, c)
#		define	STEP_E(K)	STEP(K, e, f, g, h, a, b, c, d)
#		define	STEP_F(K)	STEP(K, f, g, h, a, b, c, d, e)
#		define	STEP_G(K)	STEP(K, g, h, a, b, c, d, e, f)
#		define	STEP_H(K)	STEP(K, h, a, b, c, d, e, f, g)

		STEP_A( 0); STEP_B( 1); STEP_C( 2); STEP_D( 3);
		STEP_E( 4); STEP_F( 5); STEP_G( 6); STEP_H( 7);

		STEP_A( 8); STEP_B( 9); STEP_C(10); STEP_D(11);
		STEP_E(12); STEP_F(13); STEP_G(14); STEP_H(15);

		STEP_A(16); STEP_B(17); STEP_C(18); STEP_D(19);
		STEP_E(20); STEP_F(21); STEP_G(22); STEP_H(23);

		STEP_A(24); STEP_B(25); STEP_C(26); STEP_D(27);
		STEP_E(28); STEP_F(29); STEP_G(30); STEP_H(31);

		STEP_A(32); STEP_B(33); STEP_C(34); STEP_D(35);
		STEP_E(36); STEP_F(37); STEP_G(38); STEP_H(39);

		if (S0 > L_max) { L_max = S0; Nc = lambda;     }
		if (S1 > L_max) { L_max = S1; Nc = lambda + 1; }
		if (S2 > L_max) { L_max = S2; Nc = lambda + 2; }
		if (S3 > L_max) { L_max = S3; Nc = lambda + 3; }
		if (S4 > L_max) { L_max = S4; Nc = lambda + 4; }
		if (S5 > L_max) { L_max = S5; Nc = lambda + 5; }
		if (S6 > L_max) { L_max = S6; Nc = lambda + 6; }
		if (S7 > L_max) { L_max = S7; Nc = lambda + 7; }
		if (S8 > L_max) { L_max = S8; Nc = lambda + 8; }
	}
	*Nc_out = Nc;

	if (L_max <= 0.)  {
		*bc_out = 0;
		return;
	}

	/*  Compute the power of the reconstructed short term residual
	 *  signal dp[..]
	 */
	dp_float -= Nc;
	L_power = 0;
	for (k = 0; k < 40; ++k) {
		register float f = dp_float[k];
		L_power += f * f;
	}

	if (L_max >= L_power) {
		*bc_out = 3;
		return;
	}

	/*  Coding of the LTP gain
	 *  Table 4.3a must be used to obtain the level DLB[i] for the
	 *  quantization of the LTP gain b to get the coded version bc.
	 */
	lambda = L_max / L_power * 32768.;
	for (bc = 0; bc <= 2; ++bc) if (lambda <= gsm_DLB[bc]) break;
	*bc_out = bc;
}

#endif	/* FAST 	 */
#endif	/* USE_FLOAT_MUL */


/* 4.2.12 */

static void Long_term_analysis_filtering P6((bc,Nc,dp,d,dpp,e),
	word		bc,	/* 					IN  */
	word		Nc,	/* 					IN  */
	register word	* dp,	/* previous d	[-120..-1]		IN  */
	register word	* d,	/* d		[0..39]			IN  */
	register word	* dpp,	/* estimate	[0..39]			OUT */
	register word	* e	/* long term res. signal [0..39]	OUT */
)
/*
 *  In this part, we have to decode the bc parameter to compute
 *  the samples of the estimate dpp[0..39].  The decoding of bc needs the
 *  use of table 4.3b.  The long term residual signal e[0..39]
 *  is then calculated to be fed to the RPE encoding section.
 */
{
	register int      k;
	register longword ltmp;

#	undef STEP
#	define STEP(BP)					\
	for (k = 0; k <= 39; k++) {			\
		dpp[k]  = GSM_MULT_R( BP, dp[k - Nc]);	\
		e[k]	= GSM_SUB( d[k], dpp[k] );	\
	}

	switch (bc) {
	case 0:	STEP(  3277 ); break;
	case 1:	STEP( 11469 ); break;
	case 2: STEP( 21299 ); break;
	case 3: STEP( 32767 ); break; 
	}
}

void Gsm_Long_Term_Predictor P7((S,d,dp,e,dpp,Nc,bc), 	/* 4x for 160 samples */

	struct gsm_state	* S,

	word	* d,	/* [0..39]   residual signal	IN	*/
	word	* dp,	/* [-120..-1] d''		IN	*/

	word	* e,	/* [0..39] 			OUT	*/
	word	* dpp,	/* [0..39] 			OUT	*/
	word	* Nc,	/* correlation lag		OUT	*/
	word	* bc	/* gain factor			OUT	*/
)
{
	assert( d  ); assert( dp ); assert( e  );
	assert( dpp); assert( Nc ); assert( bc );

#if defined(FAST) && defined(USE_FLOAT_MUL)
	if (S->fast) 
#if   defined (LTP_CUT)
		if (S->ltp_cut)
			Cut_Fast_Calculation_of_the_LTP_parameters(S,
				d, dp, bc, Nc);
		else
#endif /* LTP_CUT */
			Fast_Calculation_of_the_LTP_parameters(d, dp, bc, Nc );
	else 
#endif /* FAST & USE_FLOAT_MUL */
#ifdef LTP_CUT
		if (S->ltp_cut)
			Cut_Calculation_of_the_LTP_parameters(S, d, dp, bc, Nc);
		else
#endif
			Calculation_of_the_LTP_parameters(d, dp, bc, Nc);

	Long_term_analysis_filtering( *bc, *Nc, dp, d, dpp, e );
}

/* 4.3.2 */
void Gsm_Long_Term_Synthesis_Filtering P5((S,Ncr,bcr,erp,drp),
	struct gsm_state	* S,

	word			Ncr,
	word			bcr,
	register word		* erp,	   /* [0..39]		  	 IN */
	register word		* drp	   /* [-120..-1] IN, [-120..40] OUT */
)
/*
 *  This procedure uses the bcr and Ncr parameter to realize the
 *  long term synthesis filtering.  The decoding of bcr needs
 *  table 4.3b.
 */
{
	register longword	ltmp;	/* for ADD */
	register int 		k;
	word			brp, drpp, Nr;

	/*  Check the limits of Nr.
	 */
	Nr = Ncr < 40 || Ncr > 120 ? S->nrp : Ncr;
	S->nrp = Nr;
	assert(Nr >= 40 && Nr <= 120);

	/*  Decoding of the LTP gain bcr
	 */
	brp = gsm_QLB[ bcr ];

	/*  Computation of the reconstructed short term residual 
	 *  signal drp[0..39]
	 */
	assert(brp !!= MIN_WORD);

	for (k = 0; k <= 39; k++) {
		drpp   = GSM_MULT_R( brp, drp[ k - Nr ] );
		drp[k] = GSM_ADD( erp[k], drpp );
	}

	/*
	 *  Update of the reconstructed short term residual signal
	 *  drp[ -1..-120 ]
	 */

	for (k = 0; k <= 119; k++) drp[ -120 + k ] = drp[ -80 + k ];
}

/****** begin "lpc.c" *****/

#undef STEP
#undef	P

/*
 *  4.2.4 .. 4.2.7 LPC ANALYSIS SECTION
 */

/* 4.2.4 */


static void Autocorrelation P2((s, L_ACF),
	word     * s,		/* [0..159]	IN/OUT  */
 	longword * L_ACF)	/* [0..8]	OUT     */
/*
 *  The goal is to compute the array L_ACF[k].  The signal s[i] must
 *  be scaled in order to avoid an overflow situation.
 */
{
	register int	k, i;

	word		temp, smax, scalauto;

#ifdef	USE_FLOAT_MUL
	float		float_s[160];
#endif

	/*  Dynamic scaling of the array  s[0..159]
	 */

	/*  Search for the maximum.
	 */
	smax = 0;
	for (k = 0; k <= 159; k++) {
		temp = GSM_ABS( s[k] );
		if (temp > smax) smax = temp;
	}

	/*  Computation of the scaling factor.
	 */
	if (smax == 0) scalauto = 0;
	else {
		assert(smax > 0);
		scalauto = 4 - gsm_norm( (longword)smax << 16 );/* sub(4,..) */
	}

	/*  Scaling of the array s[0...159]
	 */

	if (scalauto > 0) {

# ifdef USE_FLOAT_MUL
#   define SCALE(n)	\
	case n: for (k = 0; k <= 159; k++) \
			float_s[k] = (float)	\
				(s[k] = GSM_MULT_R(s[k], 16384 >> (n-1)));\
		break;
# else 
#   define SCALE(n)	\
	case n: for (k = 0; k <= 159; k++) \
			s[k] = GSM_MULT_R( s[k], 16384 >> (n-1) );\
		break;
# endif /* USE_FLOAT_MUL */

		switch (scalauto) {
		SCALE(1)
		SCALE(2)
		SCALE(3)
		SCALE(4)
		}
# undef	SCALE
	}
# ifdef	USE_FLOAT_MUL
	else for (k = 0; k <= 159; k++) float_s[k] = (float) s[k];
# endif

	/*  Compute the L_ACF[..].
	 */
	{
# ifdef	USE_FLOAT_MUL
		register float * sp = float_s;
		register float   sl = *sp;

#		define STEP(k)	 L_ACF[k] += (longword)(sl * sp[ -(k) ]);
# else
		word  * sp = s;
		word    sl = *sp;

#		define STEP(k)	 L_ACF[k] += ((longword)sl * sp[ -(k) ]);
# endif

#	define NEXTI	 sl = *++sp


	for (k = 9; k--; L_ACF[k] = 0) ;

	STEP (0);
	NEXTI;
	STEP(0); STEP(1);
	NEXTI;
	STEP(0); STEP(1); STEP(2);
	NEXTI;
	STEP(0); STEP(1); STEP(2); STEP(3);
	NEXTI;
	STEP(0); STEP(1); STEP(2); STEP(3); STEP(4);
	NEXTI;
	STEP(0); STEP(1); STEP(2); STEP(3); STEP(4); STEP(5);
	NEXTI;
	STEP(0); STEP(1); STEP(2); STEP(3); STEP(4); STEP(5); STEP(6);
	NEXTI;
	STEP(0); STEP(1); STEP(2); STEP(3); STEP(4); STEP(5); STEP(6); STEP(7);

	for (i = 8; i <= 159; i++) {

		NEXTI;

		STEP(0);
		STEP(1); STEP(2); STEP(3); STEP(4);
		STEP(5); STEP(6); STEP(7); STEP(8);
	}

	for (k = 9; k--; L_ACF[k] <<= 1) ; 

	}
	/*   Rescaling of the array s[0..159]
	 */
	if (scalauto > 0) {
		assert(scalauto <= 4); 
		for (k = 160; k--; *s++ <<= scalauto) ;
	}
}

#if defined(USE_FLOAT_MUL) && defined(FAST)

static void Fast_Autocorrelation P2((s, L_ACF),
	word * s,		/* [0..159]	IN/OUT  */
 	longword * L_ACF)	/* [0..8]	OUT     */
{
	register int	k, i;
	float f_L_ACF[9];
	float scale;

	float          s_f[160];
	register float *sf = s_f;

	for (i = 0; i < 160; ++i) sf[i] = s[i];
	for (k = 0; k <= 8; k++) {
		register float L_temp2 = 0;
		register float *sfl = sf - k;
		for (i = k; i < 160; ++i) L_temp2 += sf[i] * sfl[i];
		f_L_ACF[k] = L_temp2;
	}
	scale = MAX_LONGWORD / f_L_ACF[0];

	for (k = 0; k <= 8; k++) {
		L_ACF[k] = f_L_ACF[k] * scale;
	}
}
#endif	/* defined (USE_FLOAT_MUL) && defined (FAST) */

/* 4.2.5 */

static void Reflection_coefficients P2( (L_ACF, r),
	longword	* L_ACF,		/* 0...8	IN	*/
	register word	* r			/* 0...7	OUT 	*/
)
{
	register int	i, m, n;
	register word	temp;
	register longword ltmp;
	word		ACF[9];	/* 0..8 */
	word		P[  9];	/* 0..8 */
	word		K[  9]; /* 2..8 */

	/*  Schur recursion with 16 bits arithmetic.
	 */

	if (L_ACF[0] == 0) {
		for (i = 8; i--; *r++ = 0) ;
		return;
	}

	assert( L_ACF[0] !!= 0 );
	temp = gsm_norm( L_ACF[0] );

	assert(temp >= 0 && temp < 32);

	/* ? overflow ? */
	for (i = 0; i <= 8; i++) ACF[i] = SASR( L_ACF[i] << temp, 16 );

	/*   Initialize array P[..] and K[..] for the recursion.
	 */

	for (i = 1; i <= 7; i++) K[ i ] = ACF[ i ];
	for (i = 0; i <= 8; i++) P[ i ] = ACF[ i ];

	/*   Compute reflection coefficients
	 */
	for (n = 1; n <= 8; n++, r++) {

		temp = P[1];
		temp = GSM_ABS(temp);
		if (P[0] < temp) {
			for (i = n; i <= 8; i++) *r++ = 0;
			return;
		}

		*r = gsm_div( temp, P[0] );

		assert(*r >= 0);
		if (P[1] > 0) *r = -*r;		/* r[n] = sub(0, r[n]) */
		assert (*r !!= MIN_WORD);
		if (n == 8) return; 

		/*  Schur recursion
		 */
		temp = GSM_MULT_R( P[1], *r );
		P[0] = GSM_ADD( P[0], temp );

		for (m = 1; m <= 8 - n; m++) {
			temp     = GSM_MULT_R( K[ m   ],    *r );
			P[m]     = GSM_ADD(    P[ m+1 ],  temp );

			temp     = GSM_MULT_R( P[ m+1 ],    *r );
			K[m]     = GSM_ADD(    K[ m   ],  temp );
		}
	}
}

/* 4.2.6 */

static void Transformation_to_Log_Area_Ratios P1((r),
	register word	* r 			/* 0..7	   IN/OUT */
)
/*
 *  The following scaling for r[..] and LAR[..] has been used:
 *
 *  r[..]   = integer( real_r[..]*32768. ); -1 <= real_r < 1.
 *  LAR[..] = integer( real_LAR[..] * 16384 );
 *  with -1.625 <= real_LAR <= 1.625
 */
{
	register word	temp;
	register int	i;


	/* Computation of the LAR[0..7] from the r[0..7]
	 */
	for (i = 1; i <= 8; i++, r++) {

		temp = *r;
		temp = GSM_ABS(temp);
		assert(temp >= 0);

		if (temp < 22118) {
			temp >>= 1;
		} else if (temp < 31130) {
			assert( temp >= 11059 );
			temp -= 11059;
		} else {
			assert( temp >= 26112 );
			temp -= 26112;
			temp <<= 2;
		}

		*r = *r < 0 ? -temp : temp;
		assert( *r !!= MIN_WORD );
	}
}

/* 4.2.7 */

static void Quantization_and_coding P1((LAR),
	register word * LAR    	/* [0..7]	IN/OUT	*/
)
{
	register word	temp;
	longword	ltmp;


	/*  This procedure needs four tables; the following equations
	 *  give the optimum scaling for the constants:
	 *  
	 *  A[0..7] = integer( real_A[0..7] * 1024 )
	 *  B[0..7] = integer( real_B[0..7] *  512 )
	 *  MAC[0..7] = maximum of the LARc[0..7]
	 *  MIC[0..7] = minimum of the LARc[0..7]
	 */

#	undef STEP
#	define	STEP( A, B, MAC, MIC )		\
		temp = GSM_MULT( A,   *LAR );	\
		temp = GSM_ADD(  temp,   B );	\
		temp = GSM_ADD(  temp, 256 );	\
		temp = SASR(     temp,   9 );	\
		*LAR  =  temp>MAC ? MAC - MIC : (temp<MIC ? 0 : temp - MIC); \
		LAR++;

	STEP(  20480,     0,  31, -32 );
	STEP(  20480,     0,  31, -32 );
	STEP(  20480,  2048,  15, -16 );
	STEP(  20480, -2560,  15, -16 );

	STEP(  13964,    94,   7,  -8 );
	STEP(  15360, -1792,   7,  -8 );
	STEP(   8534,  -341,   3,  -4 );
	STEP(   9036, -1144,   3,  -4 );

#	undef	STEP
}

void Gsm_LPC_Analysis P3((S, s,LARc),
	struct gsm_state *S,
	word 		 * s,		/* 0..159 signals	IN/OUT	*/
        word 		 * LARc)	/* 0..7   LARc''s	OUT	*/
{
	longword	L_ACF[9];

#if defined(USE_FLOAT_MUL) && defined(FAST)
	if (S->fast) Fast_Autocorrelation (s,	  L_ACF );
	else
#endif
	Autocorrelation			  (s,	  L_ACF	);
	Reflection_coefficients		  (L_ACF, LARc	);
	Transformation_to_Log_Area_Ratios (LARc);
	Quantization_and_coding		  (LARc);
}

/****** begin "preprocess.c" *****/

/*	4.2.0 .. 4.2.3	PREPROCESSING SECTION
 *  
 *  	After A-law to linear conversion (or directly from the
 *   	Ato D converter) the following scaling is assumed for
 * 	input to the RPE-LTP algorithm:
 *
 *      in:  0.1.....................12
 *	     S.v.v.v.v.v.v.v.v.v.v.v.v.*.*.*
 *
 *	Where S is the sign bit, v a valid bit, and * a "don''t care" bit.
 * 	The original signal is called sop[..]
 *
 *      out:   0.1................... 12 
 *	     S.S.v.v.v.v.v.v.v.v.v.v.v.v.0.0
 */


void Gsm_Preprocess P3((S, s, so),
	struct gsm_state * S,
	word		 * s,
	word 		 * so )		/* [0..159] 	IN/OUT	*/
{

	word       z1 = S->z1;
	longword L_z2 = S->L_z2;
	word 	   mp = S->mp;

	word 	   	s1;
	longword      L_s2;

	longword      L_temp;

	word		msp, lsp;
	word		SO;

	longword	ltmp;		/* for   ADD */
	ulongword	utmp;		/* for L_ADD */

	register int		k = 160;

	while (k--) {

	/*  4.2.1   Downscaling of the input signal
	 */
		SO = SASR( *s, 3 ) << 2;
		s++;

		assert (SO >= -0x4000);	/* downscaled by     */
		assert (SO <=  0x3FFC);	/* previous routine. */


	/*  4.2.2   Offset compensation
	 * 
	 *  This part implements a high-pass filter and requires extended
	 *  arithmetic precision for the recursive part of this filter.
	 *  The input of this procedure is the array so[0...159] and the
	 *  output the array sof[ 0...159 ].
	 */
		/*   Compute the non-recursive part
		 */

		s1 = SO - z1;			/* s1 = gsm_sub( *so, z1 ); */
		z1 = SO;

		assert(s1 !!= MIN_WORD);

		/*   Compute the recursive part
		 */
		L_s2 = s1;
		L_s2 <<= 15;

		/*   Execution of a 31 bv 16 bits multiplication
		 */

		msp = SASR( L_z2, 15 );
		lsp = L_z2-((longword)msp<<15); /* gsm_L_sub(L_z2,(msp<<15)); */

		L_s2  += GSM_MULT_R( lsp, 32735 );
		L_temp = (longword)msp * 32735; /* GSM_L_MULT(msp,32735) >> 1;*/
		L_z2   = GSM_L_ADD( L_temp, L_s2 );

		/*    Compute sof[k] with rounding
		 */
		L_temp = GSM_L_ADD( L_z2, 16384 );

	/*   4.2.3  Preemphasis
	 */

		msp   = GSM_MULT_R( mp, -28180 );
		mp    = SASR( L_temp, 15 );
		*so++ = GSM_ADD( mp, msp );
	}

	S->z1   = z1;
	S->L_z2 = L_z2;
	S->mp   = mp;
}

/****** begin "rpe.c" *****/

/*  4.2.13 .. 4.2.17  RPE ENCODING SECTION
 */

/* 4.2.13 */

static void Weighting_filter P2((e, x),
	register word	* e,		/* signal [-5..0.39.44]	IN  */
	word		* x		/* signal [0..39]	OUT */
)
/*
 *  The coefficients of the weighting filter are stored in a table
 *  (see table 4.4).  The following scaling is used:
 *
 *	H[0..10] = integer( real_H[ 0..10] * 8192 ); 
 */
{
	/* word			wt[ 50 ]; */

	register longword	L_result;
	register int		k /* , i */ ;

	/*  Initialization of a temporary working array wt[0...49]
	 */

	/* for (k =  0; k <=  4; k++) wt[k] = 0;
	 * for (k =  5; k <= 44; k++) wt[k] = *e++;
	 * for (k = 45; k <= 49; k++) wt[k] = 0;
	 *
	 *  (e[-5..-1] and e[40..44] are allocated by the caller,
	 *  are initially zero and are not written anywhere.)
	 */
	e -= 5;

	/*  Compute the signal x[0..39]
	 */ 
	for (k = 0; k <= 39; k++) {

		L_result = 8192 >> 1;

		/* for (i = 0; i <= 10; i++) {
		 *	L_temp   = GSM_L_MULT( wt[k+i], gsm_H[i] );
		 *	L_result = GSM_L_ADD( L_result, L_temp );
		 * }
		 */

#undef	STEP
#define	STEP( i, H )	(e[ k + i ] * (longword)H)

		/*  Every one of these multiplications is done twice --
		 *  but I don''t see an elegant way to optimize this. 
		 *  Do you?
		 */

#ifdef	STUPID_COMPILER
		L_result += STEP(	0, 	-134 ) ;
		L_result += STEP(	1, 	-374 )  ;
	               /* + STEP(	2, 	0    )  */
		L_result += STEP(	3, 	2054 ) ;
		L_result += STEP(	4, 	5741 ) ;
		L_result += STEP(	5, 	8192 ) ;
		L_result += STEP(	6, 	5741 ) ;
		L_result += STEP(	7, 	2054 ) ;
	 	       /* + STEP(	8, 	0    )  */
		L_result += STEP(	9, 	-374 ) ;
		L_result += STEP(	10, 	-134 ) ;
#else
		L_result +=
		  STEP(	0, 	-134 ) 
		+ STEP(	1, 	-374 ) 
	     /* + STEP(	2, 	0    )  */
		+ STEP(	3, 	2054 ) 
		+ STEP(	4, 	5741 ) 
		+ STEP(	5, 	8192 ) 
		+ STEP(	6, 	5741 ) 
		+ STEP(	7, 	2054 ) 
	     /* + STEP(	8, 	0    )  */
		+ STEP(	9, 	-374 ) 
		+ STEP(10, 	-134 )
		;
#endif

		/* L_result = GSM_L_ADD( L_result, L_result ); (* scaling(x2) *)
		 * L_result = GSM_L_ADD( L_result, L_result ); (* scaling(x4) *)
		 *
		 * x[k] = SASR( L_result, 16 );
		 */

		/* 2 adds vs. >>16 => 14, minus one shift to compensate for
		 * those we lost when replacing L_MULT by ''*''.
		 */

		L_result = SASR( L_result, 13 );
		x[k] =  (  L_result < MIN_WORD ? MIN_WORD
			: (L_result > MAX_WORD ? MAX_WORD : L_result ));
	}
}

/* 4.2.14 */

static void RPE_grid_selection P3((x,xM,Mc_out),
	word		* x,		/* [0..39]		IN  */ 
	word		* xM,		/* [0..12]		OUT */
	word		* Mc_out	/*			OUT */
)
/*
 *  The signal x[0..39] is used to select the RPE grid which is
 *  represented by Mc.
 */
{
	/* register word	temp1;	*/
	register int		/* m, */  i;
	register longword	L_result, L_temp;
	longword		EM;	/* xxx should be L_EM? */
	word			Mc;

	longword		L_common_0_3;

	EM = 0;
	Mc = 0;

	/* for (m = 0; m <= 3; m++) {
	 *	L_result = 0;
	 *
	 *
	 *	for (i = 0; i <= 12; i++) {
	 *
	 *		temp1    = SASR( x[m + 3*i], 2 );
	 *
	 *		assert(temp1 !!= MIN_WORD);
	 *
	 *		L_temp   = GSM_L_MULT( temp1, temp1 );
	 *		L_result = GSM_L_ADD( L_temp, L_result );
	 *	}
	 * 
	 *	if (L_result > EM) {
	 *		Mc = m;
	 *		EM = L_result;
	 *	}
	 * }
	 */

#undef	STEP
#define	STEP( m, i )		L_temp = SASR( x[m + 3 * i], 2 );	\
				L_result += L_temp * L_temp;

	/* common part of 0 and 3 */

	L_result = 0;
	STEP( 0, 1 ); STEP( 0, 2 ); STEP( 0, 3 ); STEP( 0, 4 );
	STEP( 0, 5 ); STEP( 0, 6 ); STEP( 0, 7 ); STEP( 0, 8 );
	STEP( 0, 9 ); STEP( 0, 10); STEP( 0, 11); STEP( 0, 12);
	L_common_0_3 = L_result;

	/* i = 0 */

	STEP( 0, 0 );
	L_result <<= 1;	/* implicit in L_MULT */
	EM = L_result;

	/* i = 1 */

	L_result = 0;
	STEP( 1, 0 );
	STEP( 1, 1 ); STEP( 1, 2 ); STEP( 1, 3 ); STEP( 1, 4 );
	STEP( 1, 5 ); STEP( 1, 6 ); STEP( 1, 7 ); STEP( 1, 8 );
	STEP( 1, 9 ); STEP( 1, 10); STEP( 1, 11); STEP( 1, 12);
	L_result <<= 1;
	if (L_result > EM) {
		Mc = 1;
	 	EM = L_result;
	}

	/* i = 2 */

	L_result = 0;
	STEP( 2, 0 );
	STEP( 2, 1 ); STEP( 2, 2 ); STEP( 2, 3 ); STEP( 2, 4 );
	STEP( 2, 5 ); STEP( 2, 6 ); STEP( 2, 7 ); STEP( 2, 8 );
	STEP( 2, 9 ); STEP( 2, 10); STEP( 2, 11); STEP( 2, 12);
	L_result <<= 1;
	if (L_result > EM) {
		Mc = 2;
	 	EM = L_result;
	}

	/* i = 3 */

	L_result = L_common_0_3;
	STEP( 3, 12 );
	L_result <<= 1;
	if (L_result > EM) {
		Mc = 3;
	 	EM = L_result;
	}

	/**/

	/*  Down-sampling by a factor 3 to get the selected xM[0..12]
	 *  RPE sequence.
	 */
	for (i = 0; i <= 12; i ++) xM[i] = x[Mc + 3*i];
	*Mc_out = Mc;
}

/* 4.12.15 */

static void APCM_quantization_xmaxc_to_exp_mant P3((xmaxc,exp_out,mant_out),
	word		xmaxc,		/* IN 	*/
	word		* exp_out,	/* OUT	*/
	word		* mant_out )	/* OUT  */
{
	word	exp, mant;

	/* Compute exponent and mantissa of the decoded version of xmaxc
	 */

	exp = 0;
	if (xmaxc > 15) exp = SASR(xmaxc, 3) - 1;
	mant = xmaxc - (exp << 3);

	if (mant == 0) {
		exp  = -4;
		mant = 7;
	}
	else {
		while (mant <= 7) {
			mant = mant << 1 | 1;
			exp--;
		}
		mant -= 8;
	}

	assert( exp  >= -4 && exp <= 6 );
	assert( mant >= 0 && mant <= 7 );

	*exp_out  = exp;
	*mant_out = mant;
}

static void APCM_quantization P5((xM,xMc,mant_out,exp_out,xmaxc_out),
	word		* xM,		/* [0..12]		IN	*/

	word		* xMc,		/* [0..12]		OUT	*/
	word		* mant_out,	/* 			OUT	*/
	word		* exp_out,	/*			OUT	*/
	word		* xmaxc_out	/*			OUT	*/
)
{
	int	i, itest;

	word	xmax, xmaxc, temp, temp1, temp2;
	word	exp, mant;


	/*  Find the maximum absolute value xmax of xM[0..12].
	 */

	xmax = 0;
	for (i = 0; i <= 12; i++) {
		temp = xM[i];
		temp = GSM_ABS(temp);
		if (temp > xmax) xmax = temp;
	}

	/*  Qantizing and coding of xmax to get xmaxc.
	 */

	exp   = 0;
	temp  = SASR( xmax, 9 );
	itest = 0;

	for (i = 0; i <= 5; i++) {

		itest |= (temp <= 0);
		temp = SASR( temp, 1 );

		assert(exp <= 5);
		if (itest == 0) exp++;		/* exp = add (exp, 1) */
	}

	assert(exp <= 6 && exp >= 0);
	temp = exp + 5;

	assert(temp <= 11 && temp >= 0);
	xmaxc = gsm_add( SASR(xmax, temp), exp << 3 );

	/*   Quantizing and coding of the xM[0..12] RPE sequence
	 *   to get the xMc[0..12]
	 */

	APCM_quantization_xmaxc_to_exp_mant( xmaxc, &exp, &mant );

	/*  This computation uses the fact that the decoded version of xmaxc
	 *  can be calculated by using the exponent and the mantissa part of
	 *  xmaxc (logarithmic table).
	 *  So, this method avoids any division and uses only a scaling
	 *  of the RPE samples by a function of the exponent.  A direct 
	 *  multiplication by the inverse of the mantissa (NRFAC[0..7]
	 *  found in table 4.5) gives the 3 bit coded version xMc[0..12]
	 *  of the RPE samples.
	 */


	/* Direct computation of xMc[0..12] using table 4.5
	 */

	assert( exp <= 4096 && exp >= -4096);
	assert( mant >= 0 && mant <= 7 ); 

	temp1 = 6 - exp;		/* normalization by the exponent */
	temp2 = gsm_NRFAC[ mant ];  	/* inverse mantissa 		 */

	for (i = 0; i <= 12; i++) {

		assert(temp1 >= 0 && temp1 < 16);

		temp = xM[i] << temp1;
		temp = GSM_MULT( temp, temp2 );
		temp = SASR(temp, 12);
		xMc[i] = temp + 4;		/* see note below */
	}

	/*  NOTE: This equation is used to make all the xMc[i] positive.
	 */

	*mant_out  = mant;
	*exp_out   = exp;
	*xmaxc_out = xmaxc;
}

/* 4.2.16 */

static void APCM_inverse_quantization P4((xMc,mant,exp,xMp),
	register word	* xMc,	/* [0..12]			IN 	*/
	word		mant,
	word		exp,
	register word	* xMp)	/* [0..12]			OUT 	*/
/* 
 *  This part is for decoding the RPE sequence of coded xMc[0..12]
 *  samples to obtain the xMp[0..12] array.  Table 4.6 is used to get
 *  the mantissa of xmaxc (FAC[0..7]).
 */
{
	int	i;
	word	temp, temp1, temp2, temp3;
	longword	ltmp;

	assert( mant >= 0 && mant <= 7 ); 

	temp1 = gsm_FAC[ mant ];	/* see 4.2-15 for mant */
	temp2 = gsm_sub( 6, exp );	/* see 4.2-15 for exp  */
	temp3 = gsm_asl( 1, gsm_sub( temp2, 1 ));

	for (i = 13; i--;) {

		assert( *xMc <= 7 && *xMc >= 0 ); 	/* 3 bit unsigned */

		/* temp = gsm_sub( *xMc++ << 1, 7 ); */
		temp = (*xMc++ << 1) - 7;	        /* restore sign   */
		assert( temp <= 7 && temp >= -7 ); 	/* 4 bit signed   */

		temp <<= 12;				/* 16 bit signed  */
		temp = GSM_MULT_R( temp1, temp );
		temp = GSM_ADD( temp, temp3 );
		*xMp++ = gsm_asr( temp, temp2 );
	}
}

/* 4.2.17 */

static void RPE_grid_positioning P3((Mc,xMp,ep),
	word		Mc,		/* grid position	IN	*/
	register word	* xMp,		/* [0..12]		IN	*/
	register word	* ep		/* [0..39]		OUT	*/
)
/*
 *  This procedure computes the reconstructed long term residual signal
 *  ep[0..39] for the LTP analysis filter.  The inputs are the Mc
 *  which is the grid position selection and the xMp[0..12] decoded
 *  RPE samples which are upsampled by a factor of 3 by inserting zero
 *  values.
 */
{
	int	i = 13;

	assert(0 <= Mc && Mc <= 3);

        switch (Mc) {
                case 3: *ep++ = 0;
                case 2:  do {
                                *ep++ = 0;
                case 1:         *ep++ = 0;
                case 0:         *ep++ = *xMp++;
                         } while (--i);
        }
        while (++Mc < 4) *ep++ = 0;

	/*

	int i, k;
	for (k = 0; k <= 39; k++) ep[k] = 0;
	for (i = 0; i <= 12; i++) {
		ep[ Mc + (3*i) ] = xMp[i];
	}
	*/
}

/* 4.2.18 */

/*  This procedure adds the reconstructed long term residual signal
 *  ep[0..39] to the estimated signal dpp[0..39] from the long term
 *  analysis filter to compute the reconstructed short term residual
 *  signal dp[-40..-1]; also the reconstructed short term residual
 *  array dp[-120..-41] is updated.
 */

#if 0	/* Has been inlined in code.c */
void Gsm_Update_of_reconstructed_short_time_residual_signal P3((dpp, ep, dp),
	word	* dpp,		/* [0...39]	IN	*/
	word	* ep,		/* [0...39]	IN	*/
	word	* dp)		/* [-120...-1]  IN/OUT 	*/
{
	int 		k;

	for (k = 0; k <= 79; k++) 
		dp[ -120 + k ] = dp[ -80 + k ];

	for (k = 0; k <= 39; k++)
		dp[ -40 + k ] = gsm_add( ep[k], dpp[k] );
}
#endif	/* Has been inlined in code.c */

void Gsm_RPE_Encoding P5((S,e,xmaxc,Mc,xMc),

	struct gsm_state * S,

	word	* e,		/* -5..-1][0..39][40..44	IN/OUT  */
	word	* xmaxc,	/* 				OUT */
	word	* Mc,		/* 			  	OUT */
	word	* xMc)		/* [0..12]			OUT */
{
	word	x[40];
	word	xM[13], xMp[13];
	word	mant, exp;

	Weighting_filter(e, x);
	RPE_grid_selection(x, xM, Mc);

	APCM_quantization(	xM, xMc, &mant, &exp, xmaxc);
	APCM_inverse_quantization(  xMc,  mant,  exp, xMp);

	RPE_grid_positioning( *Mc, xMp, e );

}

void Gsm_RPE_Decoding P5((S, xmaxcr, Mcr, xMcr, erp),
	struct gsm_state	* S,

	word 		xmaxcr,
	word		Mcr,
	word		* xMcr,  /* [0..12], 3 bits 		IN	*/
	word		* erp	 /* [0..39]			OUT 	*/
)
{
	word	exp, mant;
	word	xMp[ 13 ];

	APCM_quantization_xmaxc_to_exp_mant( xmaxcr, &exp, &mant );
	APCM_inverse_quantization( xMcr, mant, exp, xMp );
	RPE_grid_positioning( Mcr, xMp, erp );

}

/****** begin "short_term.c" *****/

/*
 *  SHORT TERM ANALYSIS FILTERING SECTION
 */

/* 4.2.8 */

static void Decoding_of_the_coded_Log_Area_Ratios P2((LARc,LARpp),
	word 	* LARc,		/* coded log area ratio	[0..7] 	IN	*/
	word	* LARpp)	/* out: decoded ..			*/
{
	register word	temp1 /* , temp2 */;
	register long	ltmp;	/* for GSM_ADD */

	/*  This procedure requires for efficient implementation
	 *  two tables.
 	 *
	 *  INVA[1..8] = integer( (32768 * 8) / real_A[1..8])
	 *  MIC[1..8]  = minimum value of the LARc[1..8]
	 */

	/*  Compute the LARpp[1..8]
	 */

	/* 	for (i = 1; i <= 8; i++, B++, MIC++, INVA++, LARc++, LARpp++) {
	 *
	 *		temp1  = GSM_ADD( *LARc, *MIC ) << 10;
	 *		temp2  = *B << 1;
	 *		temp1  = GSM_SUB( temp1, temp2 );
	 *
	 *		assert(*INVA !!= MIN_WORD);
	 *
	 *		temp1  = GSM_MULT_R( *INVA, temp1 );
	 *		*LARpp = GSM_ADD( temp1, temp1 );
	 *	}
	 */

#undef	STEP
#define	STEP( B, MIC, INVA )	\
		temp1    = GSM_ADD( *LARc++, MIC ) << 10;	\
		temp1    = GSM_SUB( temp1, B << 1 );		\
		temp1    = GSM_MULT_R( INVA, temp1 );		\
		*LARpp++ = GSM_ADD( temp1, temp1 );

	STEP(      0,  -32,  13107 );
	STEP(      0,  -32,  13107 );
	STEP(   2048,  -16,  13107 );
	STEP(  -2560,  -16,  13107 );

	STEP(     94,   -8,  19223 );
	STEP(  -1792,   -8,  17476 );
	STEP(   -341,   -4,  31454 );
	STEP(  -1144,   -4,  29708 );

	/* NOTE: the addition of *MIC is used to restore
	 * 	 the sign of *LARc.
	 */
}

/* 4.2.9 */
/* Computation of the quantized reflection coefficients 
 */

/* 4.2.9.1  Interpolation of the LARpp[1..8] to get the LARp[1..8]
 */

/*
 *  Within each frame of 160 analyzed speech samples the short term
 *  analysis and synthesis filters operate with four different sets of
 *  coefficients, derived from the previous set of decoded LARs(LARpp(j-1))
 *  and the actual set of decoded LARs (LARpp(j))
 *
 * (Initial value: LARpp(j-1)[1..8] = 0.)
 */

static void Coefficients_0_12 P3((LARpp_j_1, LARpp_j, LARp),
	register word * LARpp_j_1,
	register word * LARpp_j,
	register word * LARp)
{
	register int 	i;
	register longword ltmp;

	for (i = 1; i <= 8; i++, LARp++, LARpp_j_1++, LARpp_j++) {
		*LARp = GSM_ADD( SASR( *LARpp_j_1, 2 ), SASR( *LARpp_j, 2 ));
		*LARp = GSM_ADD( *LARp,  SASR( *LARpp_j_1, 1));
	}
}

static void Coefficients_13_26 P3((LARpp_j_1, LARpp_j, LARp),
	register word * LARpp_j_1,
	register word * LARpp_j,
	register word * LARp)
{
	register int i;
	register longword ltmp;
	for (i = 1; i <= 8; i++, LARpp_j_1++, LARpp_j++, LARp++) {
		*LARp = GSM_ADD( SASR( *LARpp_j_1, 1), SASR( *LARpp_j, 1 ));
	}
}

static void Coefficients_27_39 P3((LARpp_j_1, LARpp_j, LARp),
	register word * LARpp_j_1,
	register word * LARpp_j,
	register word * LARp)
{
	register int i;
	register longword ltmp;

	for (i = 1; i <= 8; i++, LARpp_j_1++, LARpp_j++, LARp++) {
		*LARp = GSM_ADD( SASR( *LARpp_j_1, 2 ), SASR( *LARpp_j, 2 ));
		*LARp = GSM_ADD( *LARp, SASR( *LARpp_j, 1 ));
	}
}


static void Coefficients_40_159 P2((LARpp_j, LARp),
	register word * LARpp_j,
	register word * LARp)
{
	register int i;

	for (i = 1; i <= 8; i++, LARp++, LARpp_j++)
		*LARp = *LARpp_j;
}

/* 4.2.9.2 */

static void LARp_to_rp P1((LARp),
	register word * LARp)	/* [0..7] IN/OUT  */
/*
 *  The input of this procedure is the interpolated LARp[0..7] array.
 *  The reflection coefficients, rp[i], are used in the analysis
 *  filter and in the synthesis filter.
 */
{
	register int 		i;
	register word		temp;
	register longword	ltmp;

	for (i = 1; i <= 8; i++, LARp++) {

		/* temp = GSM_ABS( *LARp );
	         *
		 * if (temp < 11059) temp <<= 1;
		 * else if (temp < 20070) temp += 11059;
		 * else temp = GSM_ADD( temp >> 2, 26112 );
		 *
		 * *LARp = *LARp < 0 ? -temp : temp;
		 */

		if (*LARp < 0) {
			temp = *LARp == MIN_WORD ? MAX_WORD : -(*LARp);
			*LARp = - ((temp < 11059) ? temp << 1
				: ((temp < 20070) ? temp + 11059
				:  GSM_ADD( temp >> 2, 26112 )));
		} else {
			temp  = *LARp;
			*LARp =    (temp < 11059) ? temp << 1
				: ((temp < 20070) ? temp + 11059
				:  GSM_ADD( temp >> 2, 26112 ));
		}
	}
}


/* 4.2.10 */
static void Short_term_analysis_filtering P4((S,rp,k_n,s),
	struct gsm_state * S,
	register word	* rp,	/* [0..7]	IN	*/
	register int 	k_n, 	/*   k_end - k_start	*/
	register word	* s	/* [0..n-1]	IN/OUT	*/
)
/*
 *  This procedure computes the short term residual signal d[..] to be fed
 *  to the RPE-LTP loop from the s[..] signal and from the local rp[..]
 *  array (quantized reflection coefficients).  As the call of this
 *  procedure can be done in many ways (see the interpolation of the LAR
 *  coefficient), it is assumed that the computation begins with index
 *  k_start (for arrays d[..] and s[..]) and stops with index k_end
 *  (k_start and k_end are defined in 4.2.9.1).  This procedure also
 *  needs to keep the array u[0..7] in memory for each call.
 */
{
	register word		* u = S->u;
	register int		i;
	register word		di, zzz, ui, sav, rpi;
	register longword 	ltmp;

	for (; k_n--; s++) {

		di = sav = *s;

		for (i = 0; i < 8; i++) {		/* YYY */

			ui    = u[i];
			rpi   = rp[i];
			u[i]  = sav;

			zzz   = GSM_MULT_R(rpi, di);
			sav   = GSM_ADD(   ui,  zzz);

			zzz   = GSM_MULT_R(rpi, ui);
			di    = GSM_ADD(   di,  zzz );
		}

		*s = di;
	}
}

#if defined(USE_FLOAT_MUL) && defined(FAST)

static void Fast_Short_term_analysis_filtering P4((S,rp,k_n,s),
	struct gsm_state * S,
	register word	* rp,	/* [0..7]	IN	*/
	register int 	k_n, 	/*   k_end - k_start	*/
	register word	* s	/* [0..n-1]	IN/OUT	*/
)
{
	register word		* u = S->u;
	register int		i;

	float 	  uf[8],
		 rpf[8];

	register float scalef = 3.0517578125e-5;
	register float		sav, di, temp;

	for (i = 0; i < 8; ++i) {
		uf[i]  = u[i];
		rpf[i] = rp[i] * scalef;
	}
	for (; k_n--; s++) {
		sav = di = *s;
		for (i = 0; i < 8; ++i) {
			register float rpfi = rpf[i];
			register float ufi  = uf[i];

			uf[i] = sav;
			temp  = rpfi * di + ufi;
			di   += rpfi * ufi;
			sav   = temp;
		}
		*s = di;
	}
	for (i = 0; i < 8; ++i) u[i] = uf[i];
}
#endif /* !! (defined (USE_FLOAT_MUL) && defined (FAST)) */

static void Short_term_synthesis_filtering P5((S,rrp,k,wt,sr),
	struct gsm_state * S,
	register word	* rrp,	/* [0..7]	IN	*/
	register int	k,	/* k_end - k_start	*/
	register word	* wt,	/* [0..k-1]	IN	*/
	register word	* sr	/* [0..k-1]	OUT	*/
)
{
	register word		* v = S->v;
	register int		i;
	register word		sri, tmp1, tmp2;
	register longword	ltmp;	/* for GSM_ADD  & GSM_SUB */

	while (k--) {
		sri = *wt++;
		for (i = 8; i--;) {

			/* sri = GSM_SUB( sri, gsm_mult_r( rrp[i], v[i] ) );
			 */
			tmp1 = rrp[i];
			tmp2 = v[i];
			tmp2 =  ( tmp1 == MIN_WORD && tmp2 == MIN_WORD
				? MAX_WORD
				: 0x0FFFF & (( (longword)tmp1 * (longword)tmp2
					     + 16384) >> 15)) ;

			sri  = GSM_SUB( sri, tmp2 );

			/* v[i+1] = GSM_ADD( v[i], gsm_mult_r( rrp[i], sri ) );
			 */
			tmp1  = ( tmp1 == MIN_WORD && sri == MIN_WORD
				? MAX_WORD
				: 0x0FFFF & (( (longword)tmp1 * (longword)sri
					     + 16384) >> 15)) ;

			v[i+1] = GSM_ADD( v[i], tmp1);
		}
		*sr++ = v[0] = sri;
	}
}


#if defined(FAST) && defined(USE_FLOAT_MUL)

static void Fast_Short_term_synthesis_filtering P5((S,rrp,k,wt,sr),
	struct gsm_state * S,
	register word	* rrp,	/* [0..7]	IN	*/
	register int	k,	/* k_end - k_start	*/
	register word	* wt,	/* [0..k-1]	IN	*/
	register word	* sr	/* [0..k-1]	OUT	*/
)
{
	register word		* v = S->v;
	register int		i;

	float va[9], rrpa[8];
	register float scalef = 3.0517578125e-5, temp;

	for (i = 0; i < 8; ++i) {
		va[i]   = v[i];
		rrpa[i] = (float)rrp[i] * scalef;
	}
	while (k--) {
		register float sri = *wt++;
		for (i = 8; i--;) {
			sri -= rrpa[i] * va[i];
			if     (sri < -32768.) sri = -32768.;
			else if (sri > 32767.) sri =  32767.;

			temp = va[i] + rrpa[i] * sri;
			if     (temp < -32768.) temp = -32768.;
			else if (temp > 32767.) temp =  32767.;
			va[i+1] = temp;
		}
		*sr++ = va[0] = sri;
	}
	for (i = 0; i < 9; ++i) v[i] = va[i];
}

#endif /* defined(FAST) && defined(USE_FLOAT_MUL) */

void Gsm_Short_Term_Analysis_Filter P3((S,LARc,s),

	struct gsm_state * S,

	word	* LARc,		/* coded log area ratio [0..7]  IN	*/
	word	* s		/* signal [0..159]		IN/OUT	*/
)
{
	word		* LARpp_j	= S->LARpp[ S->j      ];
	word		* LARpp_j_1	= S->LARpp[ S->j ^= 1 ];

	word		LARp[8];

#undef	FILTER
#if 	defined(FAST) && defined(USE_FLOAT_MUL)
# 	define	FILTER 	(* (S->fast			\
			   ? Fast_Short_term_analysis_filtering	\
		    	   : Short_term_analysis_filtering	))

#else
# 	define	FILTER	Short_term_analysis_filtering
#endif

	Decoding_of_the_coded_Log_Area_Ratios( LARc, LARpp_j );

	Coefficients_0_12(  LARpp_j_1, LARpp_j, LARp );
	LARp_to_rp( LARp );
	FILTER( S, LARp, 13, s);

	Coefficients_13_26( LARpp_j_1, LARpp_j, LARp);
	LARp_to_rp( LARp );
	FILTER( S, LARp, 14, s + 13);

	Coefficients_27_39( LARpp_j_1, LARpp_j, LARp);
	LARp_to_rp( LARp );
	FILTER( S, LARp, 13, s + 27);

	Coefficients_40_159( LARpp_j, LARp);
	LARp_to_rp( LARp );
	FILTER( S, LARp, 120, s + 40);
}

void Gsm_Short_Term_Synthesis_Filter P4((S, LARcr, wt, s),
	struct gsm_state * S,

	word	* LARcr,	/* received log area ratios [0..7] IN  */
	word	* wt,		/* received d [0..159]		   IN  */

	word	* s		/* signal   s [0..159]		  OUT  */
)
{
	word		* LARpp_j	= S->LARpp[ S->j     ];
	word		* LARpp_j_1	= S->LARpp[ S->j ^=1 ];

	word		LARp[8];

#undef	FILTER
#if 	defined(FAST) && defined(USE_FLOAT_MUL)

# 	define	FILTER 	(* (S->fast			\
			   ? Fast_Short_term_synthesis_filtering	\
		    	   : Short_term_synthesis_filtering	))
#else
#	define	FILTER	Short_term_synthesis_filtering
#endif

	Decoding_of_the_coded_Log_Area_Ratios( LARcr, LARpp_j );

	Coefficients_0_12( LARpp_j_1, LARpp_j, LARp );
	LARp_to_rp( LARp );
	FILTER( S, LARp, 13, wt, s );

	Coefficients_13_26( LARpp_j_1, LARpp_j, LARp);
	LARp_to_rp( LARp );
	FILTER( S, LARp, 14, wt + 13, s + 13 );

	Coefficients_27_39( LARpp_j_1, LARpp_j, LARp);
	LARp_to_rp( LARp );
	FILTER( S, LARp, 13, wt + 27, s + 27 );

	Coefficients_40_159( LARpp_j, LARp );
	LARp_to_rp( LARp );
	FILTER(S, LARp, 120, wt + 40, s + 40);
}

/****** begin "table.c" *****/

/*  Most of these tables are inlined at their point of use.
 */

/*  4.4 TABLES USED IN THE FIXED POINT IMPLEMENTATION OF THE RPE-LTP
 *      CODER AND DECODER
 *
 *	(Most of them inlined, so watch out.)
 */

/*  Table 4.1  Quantization of the Log.-Area Ratios
 */
/* i 		     1      2      3        4      5      6        7       8 */
word gsm_A[8]   = {20480, 20480, 20480,  20480,  13964,  15360,   8534,  9036};
word gsm_B[8]   = {    0,     0,  2048,  -2560,     94,  -1792,   -341, -1144};
word gsm_MIC[8] = { -32,   -32,   -16,    -16,     -8,     -8,     -4,    -4 };
word gsm_MAC[8] = {  31,    31,    15,     15,      7,      7,      3,     3 };


/*  Table 4.2  Tabulation  of 1/A[1..8]
 */
word gsm_INVA[8]={ 13107, 13107,  13107, 13107,  19223, 17476,  31454, 29708 };


/*   Table 4.3a  Decision level of the LTP gain quantizer
 */
/*  bc		      0	        1	  2	     3			*/
word gsm_DLB[4] = {  6554,    16384,	26214,	   32767	};


/*   Table 4.3b   Quantization levels of the LTP gain quantizer
 */
/* bc		      0          1        2          3			*/
word gsm_QLB[4] = {  3277,    11469,	21299,	   32767	};


/*   Table 4.4	 Coefficients of the weighting filter
 */
/* i		    0      1   2    3   4      5      6     7   8   9    10  */
word gsm_H[11] = {-134, -374, 0, 2054, 5741, 8192, 5741, 2054, 0, -374, -134 };


/*   Table 4.5 	 Normalized inverse mantissa used to compute xM/xmax 
 */
/* i		 	0        1    2      3      4      5     6      7   */
word gsm_NRFAC[8] = { 29128, 26215, 23832, 21846, 20165, 18725, 17476, 16384 };


/*   Table 4.6	 Normalized direct mantissa used to compute xM/xmax
 */
/* i                  0      1       2      3      4      5      6      7   */
word gsm_FAC[8]	= { 18431, 20479, 22527, 24575, 26623, 28671, 30719, 32767 };


/***** Squeak Interface Code Starts Here *****/

/* prototypes */
void gsmEncode(
	int state, int frameCount,
	int src, int srcIndex, int srcSize,
	int dst, int dstIndex, int dstSize,
	int *srcDelta, int *dstDelta);
	
void gsmDecode(
	int state, int frameCount,
	int src, int srcIndex, int srcSize,
	int dst, int dstIndex, int dstSize,
	int *srcDelta, int *dstDelta);
	
void gsmInitState(int state);

int gsmStateBytes(void);

/* glue functions */

void gsmEncode(
  int state, int frameCount,
  int src, int srcIndex, int srcSize,
  int dst, int dstIndex, int dstSize,
  int *srcDelta, int *dstDelta) {
  	int maxSrcFrames, maxDstFrames, srcPtr, dstPtr, i;

	maxSrcFrames = (srcSize + 1 - srcIndex) / 160;
	maxDstFrames = (dstSize + 1 - dstIndex) / 33;
	if (frameCount > maxSrcFrames) frameCount = maxSrcFrames;
	if (frameCount > maxDstFrames) frameCount = maxDstFrames;

	srcPtr = src + 4 + ((srcIndex - 1) * 2);
	dstPtr = dst + 4 + (dstIndex - 1);
	for (i = 1; i <= frameCount; i++) {
		gsm_encode((gsm) state, (short *) srcPtr, (unsigned char *) dstPtr);
		srcPtr += 160 * 2;
		dstPtr += 33;
	}
	*srcDelta = frameCount * 160;
	*dstDelta = frameCount * 33;
}

void gsmDecode(
  int state, int frameCount,
  int src, int srcIndex, int srcSize,
  int dst, int dstIndex, int dstSize,
  int *srcDelta, int *dstDelta) {
  	int maxSrcFrames, maxDstFrames, srcPtr, dstPtr, i;

	maxSrcFrames = (srcSize + 1 - srcIndex) / 33;
	maxDstFrames = (dstSize + 1 - dstIndex) / 160;
	if (frameCount > maxSrcFrames) frameCount = maxSrcFrames;
	if (frameCount > maxDstFrames) frameCount = maxDstFrames;

	srcPtr = src + 4 + (srcIndex - 1);
	dstPtr = dst + 4 + ((dstIndex - 1) * 2);
	for (i = 1; i <= frameCount; i++) {
		gsm_decode((gsm) state, (unsigned char *) srcPtr, (short *) dstPtr);
		srcPtr += 33;
		dstPtr += 160 * 2;
	}
	*srcDelta = frameCount * 33;
	*dstDelta = frameCount * 160;
}

void gsmInitState(int state) {
	/* Initialize the given GSM state record. */
	memset((char *) state, 0, sizeof(struct gsm_state));
	((gsm) state)->nrp = 40;
}

int gsmStateBytes(void) {
	/* Return the size of a GSM state record in bytes. */
	return sizeof(struct gsm_state);
}
'.! !


!SoundCodecPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 16:49'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"do the actual translation"
	| fd |
	super translateOn: cg inlining: inlineFlag to: fullName local: localFlag.
	fd _ FileDirectory on: (FileDirectory dirPathFor: fullName).
	(CrLfFileStream newFileNamed: (fd fullNameFor: 'sqGSMCodecPlugin.c'))
		nextPutAll: self sourceFile;
		close.
! !
AlignmentMorph subclass: #SoundDemoMorph
	instanceVariableNames: 'soundColumn '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:23'!
initialize

	super initialize.
	self listDirection: #topToBottom.
	self wrapCentering: #center; cellPositioning: #topCenter.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
	self layoutInset: 3.
	color _ Color lightGray.
	self borderWidth: 2.
	self addMorph: self makeControls.
	soundColumn _ AlignmentMorph newColumn.
	soundColumn enableDragNDrop.
	self addMorphBack: soundColumn.
	self extent: 118@150.

! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:43'!
makeControls

	| b r |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r addMorphBack: (b fullCopy label: 'V1';			actionSelector: #playV1).
	r addMorphBack: (b fullCopy label: 'V2';			actionSelector: #playV2).
	r addMorphBack: (b fullCopy label: 'V3';			actionSelector: #playV3).
	r addMorphBack: (b fullCopy label: 'All';			actionSelector: #playAll).
	r addMorphBack: (b fullCopy label: 'Stop';		actionSelector: #stopSound).
	^ r
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 12/17/97 17:13'!
playAll

	| snd |
	soundColumn submorphs size < 1 ifTrue: [^ self].
	self setTimbreFromTile: (soundColumn submorphs at: 1).
	snd _ SampledSound bachFugueVoice1On: SampledSound new.

	soundColumn submorphs size >= 2 ifTrue: [
		self setTimbreFromTile: (soundColumn submorphs at: 2).
		snd _ snd + (AbstractSound bachFugueVoice2On: SampledSound new)].

	soundColumn submorphs size >= 3 ifTrue: [
		self setTimbreFromTile: (soundColumn submorphs at: 3).
		snd _ snd + (AbstractSound bachFugueVoice3On: SampledSound new)].

	snd play.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/19/98 15:53'!
playV1

	soundColumn submorphs size < 1 ifTrue: [^ self].
	self setTimbreFromTile: (soundColumn submorphs at: 1).
	(SampledSound bachFugueVoice1On: SampledSound new) play.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/19/98 15:54'!
playV2

	soundColumn submorphs size < 2 ifTrue: [^ self].
	self setTimbreFromTile: (soundColumn submorphs at: 2).
	(SampledSound bachFugueVoice2On: SampledSound new)
		playSilentlyUntil: 4.8;
		resumePlaying.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/19/98 15:55'!
playV3

	soundColumn submorphs size < 3 ifTrue: [^ self].
	self setTimbreFromTile: (soundColumn submorphs at: 3).
	(AbstractSound bachFugueVoice3On: SampledSound new)
		playSilentlyUntil: 14.4;
		resumePlaying.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:09'!
setTimbreFromTile: aSoundTile

	SampledSound defaultSampleTable: aSoundTile sound samples.
	SampledSound nominalSamplePitch: 400.
! !

!SoundDemoMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:09'!
stopSound

	SoundPlayer shutDown.
! !
AbstractMediaEventMorph subclass: #SoundEventMorph
	instanceVariableNames: 'sound '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 12:36'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX lengthInTicks endX |

	startTimeInScore > rightTime ifTrue: [^ self].  
	lengthInTicks _ pianoRoll scorePlayer ticksForMSecs: sound duration * 1000.0.
	startTimeInScore + lengthInTicks < leftTime ifTrue: [^ self].
	startX _ pianoRoll xForTime: startTimeInScore.
	endX _ pianoRoll xForTime: startTimeInScore + lengthInTicks.
	morphList add: 
		(self left: startX; width: endX - startX).

! !

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 12:29'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	"hack... since we are called from within the SoundPlayer loop, the Semaphore will
	block attempts to play directly from here"
	WorldState addDeferredUIMessage: [sound play].! !

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 12:59'!
initialize

	super initialize.
	self height: 10.
	color _ Color lightGreen.! !

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/9/2000 18:48'!
justDroppedIntoPianoRoll: newOwner event: evt
	
	| startX lengthInTicks endX |

	super justDroppedIntoPianoRoll: newOwner event: evt.

	startTimeInScore _ newOwner timeForX: self left.
	lengthInTicks _ newOwner scorePlayer ticksForMSecs: sound duration * 1000.0.
	endTimeInScore _ startTimeInScore + lengthInTicks.

	endTimeInScore > newOwner scorePlayer durationInTicks ifTrue:
		[newOwner scorePlayer updateDuration].

	startX _ newOwner xForTime: startTimeInScore.
	endX _ newOwner xForTime: endTimeInScore.
	self width: endX - startX.

! !

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 09:52'!
releaseCachedState

	super releaseCachedState.
	sound _ sound compressWith: GSMCodec.
! !

!SoundEventMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 13:01'!
sound: aSound

	sound _ aSound.
	self setBalloonText: 'a sound of duration ',(sound duration roundTo: 0.1) printString,' seconds'.! !
InterpreterPlugin subclass: #SoundGenerationPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!SoundGenerationPlugin commentStamp: '<historical>' prior: 0!
This class is a stub for the directly generated primitives in AbstractSound and subclasses.!


!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar 2/3/2001 15:58'!
primitiveFMSoundMix
	self export: true.
	^self primFMSoundmixSampleCountintostartingAtpan! !

!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar 2/3/2001 15:59'!
primitiveOldSampledSoundMix
	self export: true.
	^self oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol! !

!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar 2/3/2001 15:58'!
primitivePluckedSoundMix
	self export: true.
	^self primPluckedSoundmixSampleCountintostartingAtpan! !

!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar 2/3/2001 15:58'!
primitiveSampledSoundMix
	self export: true.
	^self primSampledSoundmixSampleCountintostartingAtpan! !

!SoundGenerationPlugin methodsFor: 'obsolete primitives' stamp: 'ar 2/3/2001 15:57'!
primitiveWaveTableSoundMix
	self export: true.
	^self primWaveTableSoundmixSampleCountintostartingAtpan! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundGenerationPlugin class
	instanceVariableNames: ''!

!SoundGenerationPlugin class methodsFor: 'accessing' stamp: 'ar 2/3/2001 17:58'!
headerFile
	"For the oldSourceFile primitives"
	^'/* obsolete primitives for backward compatibility */
int primFMSoundmixSampleCountintostartingAtpan(void);
int oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol(void);
int primPluckedSoundmixSampleCountintostartingAtpan(void);
int primSampledSoundmixSampleCountintostartingAtpan(void);
int primWaveTableSoundmixSampleCountintostartingAtpan(void);
'! !

!SoundGenerationPlugin class methodsFor: 'accessing' stamp: 'ar 2/3/2001 16:32'!
oldSourceFile
	^ '/* Automatically generated from Squeak on (4 January 1998 3:05:25 am ) */

#include "sq.h"


/* Memory Access Macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

/*** Imported Functions/Variables ***/
extern int stackValue(int);
extern int successFlag;

/*** Variables ***/

/*** Function Prototypes ***/
int primFMSoundmixSampleCountintostartingAtpan(void);
int primPluckedSoundmixSampleCountintostartingAtpan(void);
int primSampledSoundmixSampleCountintostartingAtpan(void);
int primWaveTableSoundmixSampleCountintostartingAtpan(void);
int oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol(void);

int primFMSoundmixSampleCountintostartingAtpan(void) {
    int rcvr;
    int n;
    short int *aSoundBuffer;
    int startIndex;
    int pan;
    int mySample;
    int sample;
    int lastIndex;
    int channelIndex;
    int i;
    short int *waveTable;
    int waveTableSize;
    int count;
    int amplitude;
    int increment;
    int index;
    int modulation;
    int offsetIncrement;
    int offsetIndex;

	rcvr = stackValue(4);
	n = checkedIntegerValueOf(stackValue(3));
	aSoundBuffer = arrayValueOf(stackValue(2));
	startIndex = checkedIntegerValueOf(stackValue(1));
	pan = checkedIntegerValueOf(stackValue(0));
	waveTable = fetchArrayofObject(1, rcvr);
	waveTableSize = fetchIntegerofObject(2, rcvr);
	count = fetchIntegerofObject(4, rcvr);
	amplitude = fetchIntegerofObject(6, rcvr);
	increment = fetchIntegerofObject(8, rcvr);
	index = fetchIntegerofObject(9, rcvr);
	modulation = fetchIntegerofObject(11, rcvr);
	offsetIncrement = fetchIntegerofObject(14, rcvr);
	offsetIndex = fetchIntegerofObject(15, rcvr);
	if (!!(successFlag)) {
		return null;
	}
	lastIndex = (startIndex + n) - 1;
	for (i = startIndex; i <= lastIndex; i += 1) {
		mySample = (amplitude * (waveTable[index - 1])) / 1000;
		if (pan > 0) {
			channelIndex = 2 * i;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * pan) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		if (pan < 1000) {
			channelIndex = (2 * i) - 1;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * (1000 - pan)) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		index = (index + increment) + ((modulation * (waveTable[offsetIndex - 1])) / 1000000);
		if (index > waveTableSize) {
			index -= waveTableSize;
		}
		if (index < 1) {
			index += waveTableSize;
		}
		offsetIndex += offsetIncrement;
		if (offsetIndex > waveTableSize) {
			offsetIndex -= waveTableSize;
		}
	}
	count -= n;
	storeIntegerofObjectwithValue(4, rcvr, count);
	storeIntegerofObjectwithValue(9, rcvr, index);
	storeIntegerofObjectwithValue(15, rcvr, offsetIndex);
	pop(4);
}

int primPluckedSoundmixSampleCountintostartingAtpan(void) {
    int rcvr;
    int n;
    short int *aSoundBuffer;
    int startIndex;
    int pan;
    int lastIndex;
    int channelIndex;
    int i;
    int sample;
    int mySample;
    int thisIndex;
    int nextIndex;
    int count;
    short int *ring;
    int ringSize;
    int ringIndx;

	rcvr = stackValue(4);
	n = checkedIntegerValueOf(stackValue(3));
	aSoundBuffer = arrayValueOf(stackValue(2));
	startIndex = checkedIntegerValueOf(stackValue(1));
	pan = checkedIntegerValueOf(stackValue(0));
	count = fetchIntegerofObject(2, rcvr);
	ring = fetchArrayofObject(4, rcvr);
	ringSize = fetchIntegerofObject(5, rcvr);
	ringIndx = fetchIntegerofObject(6, rcvr);
	if (!!(successFlag)) {
		return null;
	}
	lastIndex = (startIndex + n) - 1;
	thisIndex = ringIndx;
	for (i = startIndex; i <= lastIndex; i += 1) {
		nextIndex = (thisIndex % ringSize) + 1;
		mySample = ((ring[thisIndex - 1]) + (ring[nextIndex - 1])) / 2;
		ring[thisIndex - 1] = mySample;
		thisIndex = nextIndex;
		if (pan > 0) {
			channelIndex = 2 * i;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * pan) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		if (pan < 1000) {
			channelIndex = (2 * i) - 1;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * (1000 - pan)) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
	}
	ringIndx = nextIndex;
	count -= n;
	storeIntegerofObjectwithValue(2, rcvr, count);
	storeIntegerofObjectwithValue(6, rcvr, ringIndx);
	pop(4);
}

int primSampledSoundmixSampleCountintostartingAtpan(void) {
    int rcvr;
    int n;
    short int *aSoundBuffer;
    int startIndex;
    int pan;
    int lastIndex;
    int i;
    int channelIndex;
    int sample;
    int sampleIndex;
    int thisSample;
    short int *samples;
    int samplesSize;
    int incrementTimes1000;
    int count;
    int indexTimes1000;

	rcvr = stackValue(4);
	n = checkedIntegerValueOf(stackValue(3));
	aSoundBuffer = arrayValueOf(stackValue(2));
	startIndex = checkedIntegerValueOf(stackValue(1));
	pan = checkedIntegerValueOf(stackValue(0));
	samples = fetchArrayofObject(1, rcvr);
	samplesSize = fetchIntegerofObject(2, rcvr);
	incrementTimes1000 = fetchIntegerofObject(3, rcvr);
	count = fetchIntegerofObject(5, rcvr);
	indexTimes1000 = fetchIntegerofObject(6, rcvr);
	if (!!(successFlag)) {
		return null;
	}
	lastIndex = (startIndex + n) - 1;
	i = startIndex;
	sampleIndex = indexTimes1000 / 1000;
	while ((sampleIndex <= samplesSize) && (i <= lastIndex)) {
		thisSample = samples[sampleIndex - 1];
		if (pan > 0) {
			channelIndex = 2 * i;
			sample = (aSoundBuffer[channelIndex - 1]) + ((thisSample * pan) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		if (pan < 1000) {
			channelIndex = (2 * i) - 1;
			sample = (aSoundBuffer[channelIndex - 1]) + ((thisSample * (1000 - pan)) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		indexTimes1000 += incrementTimes1000;
		sampleIndex = indexTimes1000 / 1000;
		i += 1;
	}
	count -= n;
	storeIntegerofObjectwithValue(5, rcvr, count);
	storeIntegerofObjectwithValue(6, rcvr, indexTimes1000);
	pop(4);
}

int primWaveTableSoundmixSampleCountintostartingAtpan(void) {
    int rcvr;
    int n;
    short int *aSoundBuffer;
    int startIndex;
    int pan;
    int lastIndex;
    int channelIndex;
    int i;
    int mySample;
    int sample;
    short int *waveTable;
    int waveTableSize;
    int count;
    int amplitude;
    int increment;
    int index;

	rcvr = stackValue(4);
	n = checkedIntegerValueOf(stackValue(3));
	aSoundBuffer = arrayValueOf(stackValue(2));
	startIndex = checkedIntegerValueOf(stackValue(1));
	pan = checkedIntegerValueOf(stackValue(0));
	waveTable = fetchArrayofObject(1, rcvr);
	waveTableSize = fetchIntegerofObject(2, rcvr);
	count = fetchIntegerofObject(4, rcvr);
	amplitude = fetchIntegerofObject(6, rcvr);
	increment = fetchIntegerofObject(8, rcvr);
	index = fetchIntegerofObject(9, rcvr);
	if (!!(successFlag)) {
		return null;
	}
	lastIndex = (startIndex + n) - 1;
	for (i = startIndex; i <= lastIndex; i += 1) {
		mySample = (amplitude * (waveTable[index - 1])) / 1000;
		if (pan > 0) {
			channelIndex = 2 * i;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * pan) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		if (pan < 1000) {
			channelIndex = (2 * i) - 1;
			sample = (aSoundBuffer[channelIndex - 1]) + ((mySample * (1000 - pan)) / 1000);
			if (sample > 32767) {
				sample = 32767;
			}
			if (sample < -32767) {
				sample = -32767;
			}
			aSoundBuffer[channelIndex - 1] = sample;
		}
		index += increment;
		if (index > waveTableSize) {
			index -= waveTableSize;
		}
	}
	count -= n;
	storeIntegerofObjectwithValue(4, rcvr, count);
	storeIntegerofObjectwithValue(9, rcvr, index);
	pop(4);
}

int oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol(void) {
    int rcvr;
    int n;
    short int *aSoundBuffer;
    int startIndex;
    int leftVol;
    int rightVol;
    int sliceIndex;
    int sampleIndex;
    int sample;
    int s;
    int lastIndex;
    int i;
    int scaledVol;
    int scaledVolIncr;
    int scaledVolLimit;
    int count;
    short int *samples;
    int samplesSize;
    int incrementTimes1000;
    int indexTimes1000;

	rcvr = stackValue(5);
	n = checkedIntegerValueOf(stackValue(4));
	aSoundBuffer = arrayValueOf(stackValue(3));
	aSoundBuffer -= 1;
	startIndex = checkedIntegerValueOf(stackValue(2));
	leftVol = checkedIntegerValueOf(stackValue(1));
	rightVol = checkedIntegerValueOf(stackValue(0));
	scaledVol = fetchIntegerofObject(3, rcvr);
	scaledVolIncr = fetchIntegerofObject(4, rcvr);
	scaledVolLimit = fetchIntegerofObject(5, rcvr);
	count = fetchIntegerofObject(7, rcvr);
	samples = fetchArrayofObject(8, rcvr);
	samples -= 1;
	samplesSize = fetchIntegerofObject(10, rcvr);
	incrementTimes1000 = fetchIntegerofObject(11, rcvr);
	indexTimes1000 = fetchIntegerofObject(12, rcvr);
	if (!!(successFlag)) {
		return null;
	}
	lastIndex = (startIndex + n) - 1;
	sliceIndex = startIndex;
	sampleIndex = indexTimes1000 / 1000;
	while ((sampleIndex <= samplesSize) && (sliceIndex <= lastIndex)) {
		sample = ((int) ((samples[sampleIndex]) * scaledVol) >> 15);
		if (leftVol > 0) {
			i = (2 * sliceIndex) - 1;
			s = (aSoundBuffer[i]) + (((int) (sample * leftVol) >> 15));
			if (s > 32767) {
				s = 32767;
			}
			if (s < -32767) {
				s = -32767;
			}
			aSoundBuffer[i] = s;
		}
		if (rightVol > 0) {
			i = 2 * sliceIndex;
			s = (aSoundBuffer[i]) + (((int) (sample * rightVol) >> 15));
			if (s > 32767) {
				s = 32767;
			}
			if (s < -32767) {
				s = -32767;
			}
			aSoundBuffer[i] = s;
		}
		if (scaledVolIncr !!= 0) {
			scaledVol += scaledVolIncr;
			if (((scaledVolIncr > 0) && (scaledVol >= scaledVolLimit)) || ((scaledVolIncr < 0) && (scaledVol <= scaledVolLimit))) {
				scaledVol = scaledVolLimit;
				scaledVolIncr = 0;
			}
		}
		indexTimes1000 += incrementTimes1000;
		sampleIndex = indexTimes1000 / 1000;
		sliceIndex += 1;
	}
	count -= n;
	if (!!(successFlag)) {
		return null;
	}
	storeIntegerofObjectwithValue(3, rcvr, scaledVol);
	storeIntegerofObjectwithValue(4, rcvr, scaledVolIncr);
	storeIntegerofObjectwithValue(7, rcvr, count);
	storeIntegerofObjectwithValue(12, rcvr, indexTimes1000);
	pop(5);
}
'! !


!SoundGenerationPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 18:16'!
declareCVarsIn: cg
	cg addHeaderFile: '"SoundGenerationPlugin.h"'.! !

!SoundGenerationPlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 18:16'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"SoundGenerationPlugin translateLocally"
	| code fd theClass |
	theClass _ self.
	[theClass == Object] whileFalse:[
		cg addClass: theClass.
		theClass declareCVarsIn: cg.
		theClass _ theClass superclass].

	cg addMethodsForPrimitives: AbstractSound translatedPrimitives.
	code _ cg generateCodeStringForPrimitives.
	self storeString: code onFileNamed: fullName.
	fd _ FileDirectory on: (FileDirectory dirPathFor: fullName).
	(CrLfFileStream newFileNamed: (fd fullNameFor: 'sqOldSoundPrims.c'))
		nextPutAll: self oldSourceFile;
		close.! !
SoundRecorder subclass: #SoundInputStream
	instanceVariableNames: 'bufferSize mutex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!SoundInputStream commentStamp: '<historical>' prior: 0!
This subclass of SoundRecorder supports real-time processing of incoming sound data. The sound input process queues raw sound buffers, allowing them to be read and processed by the client as they become available. A semaphore is used to synchronize between the record process and the client process. Since sound data is buffered, the client process may lag behind the input process without losing data.
!


!SoundInputStream methodsFor: 'initialization' stamp: 'jm 9/8/1999 15:22'!
initialize

	super initialize.
	bufferSize _ 1024.
	mutex _ nil.
! !


!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'!
bufferCount
	"Answer the number of sound buffers that have been queued."

	| n |
	mutex ifNil: [^ 0].  "not recording"
	mutex critical: [n _ recordedBuffers size].
	^ n
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:36'!
bufferSize

	^ bufferSize
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'!
bufferSize: aNumber
	"Set the sound buffer size. Buffers of this size will be queued for the client to process."

	bufferSize _ aNumber truncated.
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:23'!
isRecording
	"Answer true if the sound input process is running."

	^ recordProcess ~~ nil
! !

!SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:32'!
nextBufferOrNil
	"Answer the next input buffer or nil if no buffer is available."

	| result |
	mutex ifNil: [^ nil].  "not recording"
	mutex critical: [
		recordedBuffers size > 0
			ifTrue: [result _ recordedBuffers removeFirst]
			ifFalse: [result _ nil]].
	^ result
! !


!SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'!
startRecording
	"Start the sound input process."

	recordProcess ifNotNil: [self stopRecording].
	recordedBuffers _ OrderedCollection new: 100.
	mutex _ Semaphore forMutualExclusion.
	super startRecording.
	paused _ false.
! !

!SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'!
stopRecording
	"Turn off the sound input process and close the driver."

	super stopRecording.
	recordedBuffers _ nil.
	mutex _ nil.
! !


!SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'!
allocateBuffer
	"Allocate a new buffer and reset nextIndex. This message is sent by the sound input process."

	currentBuffer _ SoundBuffer newMonoSampleCount: bufferSize.
	nextIndex _ 1.
! !

!SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'!
emitBuffer: buffer
	"Queue a buffer for later processing. This message is sent by the sound input process."

	mutex critical: [recordedBuffers addLast: buffer].
! !
RectangleMorph subclass: #SoundLoopMorph
	instanceVariableNames: 'samplesUntilNextControl seqSound cursor controlIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
controlRate
	"Answer the number of control changes per second."

	^ 32
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
doControl

	seqSound doControl.
	controlIndex _ controlIndex + 1.
	controlIndex >= (self controlRate * (self innerBounds width // 128))
		ifTrue: [controlIndex _ 0].
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 1/5/98 13:40'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
	"Repeatedly play my sounds."

	| i count samplesNeeded |
	i _ startIndex.
	samplesNeeded _ n.
	[samplesNeeded > 0] whileTrue: [
		count _ seqSound samplesRemaining min: samplesNeeded.
		count = 0 ifTrue: [
			self reset.
			count _ seqSound samplesRemaining min: samplesNeeded.
			count = 0 ifTrue: [^ self]].  "zero length sound"
		seqSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
		i _ i + count.
		samplesNeeded _ samplesNeeded - count].
! !

!SoundLoopMorph 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].
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
positionCursor
	| x |
	x _ controlIndex * 128 // self controlRate.
	cursor position: self innerBounds topLeft + (x@0)
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
reset
	"Reset my internal state for a replay."

	seqSound _ self buildSound reset.
	samplesUntilNextControl _ (self samplingRate // self controlRate).
	controlIndex _ 0.
	self positionCursor! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:11'!
samplesRemaining

	^ 1000000
! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:11'!
samplingRate
	"Answer the sampling rate in samples per second."

	^ SoundPlayer samplingRate! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
step
	self positionCursor! !

!SoundLoopMorph methodsFor: 'playing' stamp: 'jm 11/14/97 11:21'!
stepTime

	^ 50
! !


!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
addCursorMorph
	self addMorph:
		(cursor _ (RectangleMorph
				newBounds: (self innerBounds topLeft extent: 1@self innerBounds height)
				color: Color red)
						borderWidth: 0)! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
allowSubmorphExtraction

	^ true! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 1/5/98 17:31'!
buildSound
	"Build a compound sound for the next iteration of the loop."

	| mixer soundMorphs startTime pan |
	mixer _ MixedSound new.
	mixer add: (RestSound dur: (self width - (2 * borderWidth)) / 128.0).
	soundMorphs _ self submorphs select: [:m | m respondsTo: #sound].
	soundMorphs do: [:m |
		startTime _ (m position x - (self left + borderWidth)) / 128.0.
		pan _ (m position y - (self top + borderWidth)) asFloat / (self height - (2 * borderWidth) - m height).
		mixer add: ((RestSound dur: startTime), m sound copy) pan: pan].
	^ mixer
! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
extent: newExtent
	super extent: (newExtent truncateTo: 128@128) + (self borderWidth*2)! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
initialize
	super initialize.
	borderWidth _ 1.
	bounds _ 0@0 corner: (128@128) + (borderWidth*2).
	color _ Color lightBlue.
	controlIndex _ 0.
	self addCursorMorph! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
play
	"Play this sound to the sound ouput port in real time."

	self reset.
	SoundPlayer playSound: self.
! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
stop
	"Stop playing this sound."

	SoundPlayer pauseSound: self.
! !

!SoundLoopMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:11'!
wantsDroppedMorph: aMorph event: evt

	^ aMorph respondsTo: #sound
! !
ImageMorph subclass: #SoundMorph
	instanceVariableNames: 'sound '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!
!SoundMorph commentStamp: '<historical>' prior: 0!
Note: as of December 2000, this does not work. SoundMorph>>buildImage requires the sound to implement #volumeEnvelopeScaledTo: and as yet, no one does.!


!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
buildImage
	| scale env h imageColor |
	owner ifNil: [scale _ 128@128]  "Default is 128 pix/second, 128 pix fullscale"
		ifNotNil: [scale _ owner soundScale].
	env _ sound volumeEnvelopeScaledTo: scale.
	self image: (ColorForm extent: env size @ env max).
	1 to: image width do:
		[:x | h _ env at: x.
		image fillBlack: ((x-1)@(image height-h//2) extent: 1@h)].
	imageColor _ #(black red orange green blue) atPin:
						(sound pitch / 110.0) rounded highBit.
	image colors: (Array with: Color transparent with: (Color perform: imageColor)).
! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 12/17/97 22:43'!
initialize

	super initialize.
	self sound: (FMSound pitch: 880.0 dur: 0.2 loudness: 0.8).
! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 20:05'!
justDroppedInto: aMorph event: anEvent
	| relPosition |
	relPosition _ self position - aMorph innerBounds topLeft.
	relPosition _ (relPosition x roundTo: 8) @ relPosition y.
	self position: aMorph innerBounds topLeft + relPosition.
	sound copy play.
	^super justDroppedInto: aMorph event: anEvent! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
reset
	sound reset! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
sound
	^ sound! !

!SoundMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
sound: aSound
	sound _ aSound copy.
	sound reset.
	self buildImage! !
Object subclass: #SoundPlayer
	instanceVariableNames: ''
	classVariableNames: 'ActiveSounds Buffer BufferIndex BufferMSecs PlayerProcess PlayerSemaphore ReadyForBuffer ReverbState SamplingRate SoundJustStarted SoundSupported Stereo UseReadySemaphore UseReverb '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundPlayer class
	instanceVariableNames: ''!

!SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:13'!
initialize
	"SoundPlayer initialize; shutDown; startUp"
	"Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothly, especially during long-running primitives such as large BitBlts. If BufferMSecs is too high, there will be a long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. BufferMSecs is typically in the range 50-200."

	SamplingRate _ 22050.
	BufferMSecs _ 120.
	Stereo _ true.
	UseReverb ifNil: [UseReverb _ true].
! !

!SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:14'!
useShortBuffer
	"Experimental support for real-time MIDI input. This only works on platforms whose hardware allows very short buffer sizes. It has been tested on a Macintosh Powerbook G3."
	"SoundPlayer useShortBuffer"

	self shutDown.
	BufferMSecs _ 15.
	SoundPlayer
		startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
		rate: SamplingRate
		stereo: Stereo.
! !


!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 8/13/1998 15:00'!
bufferMSecs

	^ BufferMSecs
! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'jm 1/27/98 09:28'!
reverbState

	^ ReverbState! !

!SoundPlayer class methodsFor: 'accessing'!
samplingRate

	^ SamplingRate! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:16'!
setVolumeLeft: aLeftVolume volumeRight: aRightVolume
	"Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or  higher to overdrive sound channel "
	self primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume! !

!SoundPlayer class methodsFor: 'accessing' stamp: 'JMM 11/6/2000 10:17'!
soundVolume
	"Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
	^self primSoundGetVolume! !

!SoundPlayer class methodsFor: 'accessing'!
stereo

	^ Stereo
! !


!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 5/8/1998 18:48'!
shutDown
	"Stop player process, for example before snapshotting."

	self stopPlayerProcess.
	ReverbState _ nil.
! !

!SoundPlayer class methodsFor: 'snapshotting' stamp: 'jm 7/11/97 12:17'!
startUp
	"Start up the player process."

	SoundPlayer initialize.
	SoundPlayer
		startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
		rate: SamplingRate
		stereo: Stereo.
! !


!SoundPlayer class methodsFor: 'playing' stamp: 'ar 2/1/2001 15:20'!
canStartPlayer
	"Some platforms do no support simultaneous record and play. If this is one of those platforms, return false if there is a running SoundRecorder."

	Preferences canRecordWhilePlaying ifTrue: [^ true].
	SoundRecorder anyActive ifTrue:[^false].
	^ true
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'di 8/5/1998 23:08'!
isPlaying: aSound
	^ ActiveSounds includes: aSound! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 8/23/97 20:38'!
pauseSound: aSound
	"Stop playing the given sound. Playing can be resumed from this point later."

	PlayerSemaphore critical: [
		ActiveSounds remove: aSound ifAbsent: []].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:47'!
playSound: aSound
	"Reset and start playing the given sound from its beginning."

	aSound reset.
	self resumePlaying: aSound.
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/8/1998 17:54'!
resumePlaying: aSound
	"Start playing the given sound without resetting it; it will resume playing from where it last stopped."
	"Implementation detail: On virtual machines that don't support the quickstart primitive, you may need to edit this method to pass false to resumePlaying:quickStart:."

	self resumePlaying: aSound quickStart: true.
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'sw 1/12/2000 22:43'!
resumePlaying: aSound quickStart: quickStart
	"Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately."

	| doQuickStart |
	Preferences soundsEnabled ifFalse: [^ self].
	doQuickStart _ quickStart.
	Preferences soundQuickStart ifFalse: [doQuickStart _ false].
	PlayerProcess == nil ifTrue: [
		self canStartPlayer ifFalse: [^ self].
		self startUp.
		"Check if startup was successful"
		SoundSupported ifFalse:[^self].
		doQuickStart _ false].

	PlayerSemaphore critical: [
		(ActiveSounds includes: aSound)
			ifTrue: [doQuickStart _ false]
			ifFalse: [
				doQuickStart ifFalse: [ActiveSounds add: aSound]]].

	"quick-start the given sound, unless the sound player has just started"
	doQuickStart ifTrue: [self startPlayingImmediately: aSound].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 1/27/98 09:47'!
stopPlayingAll
	"Stop playing all sounds."

	PlayerSemaphore critical: [
		ActiveSounds _ ActiveSounds species new].
! !

!SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/13/97 19:49'!
waitUntilDonePlaying: aSound
	"Wait until the given sound is no longer playing."

	[PlayerSemaphore critical: [ActiveSounds includes: aSound]]
		whileTrue: [(Delay forMilliseconds: 100) wait].
! !


!SoundPlayer class methodsFor: 'player process' stamp: 'jm 1/29/98 18:56'!
isReverbOn

	^ ReverbState ~~ nil
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'jm 1/26/98 22:23'!
oldStylePlayLoop
	"This version of the play loop is used if the VM does not yet support sound primitives that signal a semaphore when a sound buffer becomes available."

	| bytesPerSlice count |
	bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count _ self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [(Delay forMilliseconds: 1) wait].

		count _ count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			Buffer primFill: 0.
			SoundJustStarted _ nil]].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'ar 2/2/2001 13:58'!
playLoop
	"The sound player process loop."

	| bytesPerSlice count willStop mayStop |
	mayStop _ Preferences soundStopWhenDone.
	bytesPerSlice _ Stereo ifTrue: [4] ifFalse: [2].
	[true] whileTrue: [
		[(count _ self primSoundAvailableBytes // bytesPerSlice) > 100]
			whileFalse: [ReadyForBuffer wait].

		count _ count min: Buffer stereoSampleCount.
		PlayerSemaphore critical: [
			ActiveSounds _ ActiveSounds select: [:snd | snd samplesRemaining > 0].
			ActiveSounds do: [:snd |
				snd ~~ SoundJustStarted ifTrue: [
					snd playSampleCount: count into: Buffer startingAt: 1]].
			ReverbState == nil ifFalse: [
				ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
			self primSoundPlaySamples: count from: Buffer startingAt: 1.
			willStop _ mayStop and:[
						(ActiveSounds size = 0) and:[
							self isAllSilence: Buffer size: count]].
			willStop
				ifTrue:[self shutDown. PlayerProcess _ nil]
				ifFalse:[Buffer primFill: 0].
			SoundJustStarted _ nil].
		willStop ifTrue:[^self].
	].
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'ar 12/5/1998 16:37'!
startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
	"Start the sound player process. Terminate the old process, if any."
	"SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"

	self stopPlayerProcess.
	ActiveSounds _ OrderedCollection new.
	Buffer _ SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4.
	PlayerSemaphore _ Semaphore forMutualExclusion.
	SamplingRate _ samplesPerSecond.
	Stereo _ stereoFlag.
	ReadyForBuffer _ Semaphore new.
	SoundSupported _ true. "Assume so"
	UseReadySemaphore _ true.  "set to false if ready semaphore not supported by VM"
	self primSoundStartBufferSize: Buffer stereoSampleCount
		rate: samplesPerSecond
		stereo: Stereo
		semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer).
	"Check if sound start prim was successful"
	SoundSupported ifFalse:[^self].
	UseReadySemaphore
		ifTrue: [PlayerProcess _ [SoundPlayer playLoop] newProcess]
		ifFalse: [PlayerProcess _ [SoundPlayer oldStylePlayLoop] newProcess].
	UseReverb ifTrue: [self startReverb].

	PlayerProcess priority: Processor userInterruptPriority.
	PlayerProcess resume.! !

!SoundPlayer class methodsFor: 'player process' stamp: 'jm 6/7/1999 10:40'!
startReverb
	"Start a delay-line style reverb with the given tap delays and gains. Tap delays are given in samples and should be prime integers; the following comment gives an expression that generates primes."
	"Integer primesUpTo: 22050"

	UseReverb _ true.
	ReverbState _ ReverbSound new
		tapDelays: #(1601 7919) gains: #(0.12 0.07).
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'ar 1/31/2001 01:13'!
stopPlayerProcess
	"Stop the sound player process."
	"SoundPlayer stopPlayerProcess"

	(PlayerProcess == nil or:[PlayerProcess == Processor activeProcess]) 
		ifFalse:[PlayerProcess terminate].
	PlayerProcess _ nil.
	self primSoundStop.
	ActiveSounds _ OrderedCollection new.
	Buffer _ nil.
	PlayerSemaphore _ Semaphore forMutualExclusion.
	ReadyForBuffer ifNotNil:
		[Smalltalk unregisterExternalObject: ReadyForBuffer].
	ReadyForBuffer _ nil.
! !

!SoundPlayer class methodsFor: 'player process' stamp: 'jm 1/27/98 09:43'!
stopReverb

	UseReverb _ false.
	ReverbState _ nil.
! !


!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/13/97 20:01'!
boinkPitch: p dur: d loudness: l waveTable: waveTable pan: pan
	"Play a decaying note on the given stream using the given wave table. Used for testing only."

	| decay tableSize amplitude increment cycles i |
	decay _ 0.96.
	tableSize _ waveTable size.
	amplitude _ l asInteger min: 1000.
	increment _ ((p asFloat * tableSize asFloat) / SamplingRate asFloat) asInteger.
	increment _ (increment max: 1) min: (tableSize // 2).
	cycles _ (d * SamplingRate asFloat) asInteger.

	i _ 1.
	1 to: cycles do: [:cycle |
		(cycle \\ 100) = 0
			ifTrue: [amplitude _ (decay * amplitude asFloat) asInteger].
		i _ (((i - 1) + increment) \\ tableSize) + 1.
		self playTestSample: (amplitude * (waveTable at: i)) // 1000 pan: pan].
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 1/5/98 17:56'!
boinkScale
	"Tests the sound output primitives by playing a scale."
	"SoundPlayer boinkScale"

	| sineTable pan |
	self shutDown.
	SamplingRate _ 11025.
	Stereo _ true.
	sineTable _ self sineTable: 1000.
	Buffer _ SoundBuffer newStereoSampleCount: 1000.
	BufferIndex _ 1.
	self primSoundStartBufferSize: Buffer stereoSampleCount
		rate: SamplingRate
		stereo: Stereo.
	pan _ 0.
	#(261.626 293.665 329.628 349.229 391.996 440.001 493.884 523.252) do: [:p |
		self boinkPitch: p dur: 0.3 loudness: 300 waveTable: sineTable pan: pan.
		pan _ pan + 125].

	self boinkPitch: 261.626 dur: 1.0 loudness: 300 waveTable: sineTable pan: 500.
	self primSoundStop.
	self shutDown.
	SoundPlayer initialize.  "reset sampling rate, buffer size, and stereo flag"
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 12:55'!
playTestSample: s pan: pan
	"Append the given sample in the range [-32767..32767] to the output buffer, playing the output buffer when it is full. Used for testing only."

	| sample leftSample |
	BufferIndex >= Buffer size
		ifTrue: [
			"current buffer is full; play it"
			[self primSoundAvailableBytes > 0]
				whileFalse. "wait for space to be available"
			self primSoundPlaySamples: Buffer stereoSampleCount from: Buffer startingAt: 1.
			Buffer primFill: 0.
			BufferIndex _ 1].

	sample _ s.
	sample >  32767 ifTrue: [ sample _  32767 ]. 
	sample < -32767 ifTrue: [ sample _ -32767 ].

	Stereo
		ifTrue: [
			leftSample _ (sample * pan) // 1000.
			Buffer at: BufferIndex		put: sample - leftSample.
			Buffer at: BufferIndex + 1	put: leftSample]
		ifFalse: [
			Buffer at: BufferIndex + 1 put: sample].
	BufferIndex _ BufferIndex + 2.
! !

!SoundPlayer class methodsFor: 'primitive test' stamp: 'jm 9/17/97 20:06'!
sineTable: size
	"Compute a sine table of the given size. Used for testing only."

	| radiansPerStep table |
	table _ Array new: size.
	radiansPerStep _ (2.0 * Float pi) / table size asFloat.
	1 to: table size do: [:i |
		table at: i put:
			(32767.0 * (radiansPerStep * i) sin) asInteger].

	^ table
! !


!SoundPlayer class methodsFor: 'private' stamp: 'ar 1/31/2001 01:32'!
isAllSilence: buffer size: count
	"return true if the buffer is all silence after reverb has ended"
	| value |
	value _ buffer at: 1.
	2 to: count do:[:i| (buffer at: i) = value ifFalse:[^false]].
	^true! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundAvailableBytes
	"Return the number of bytes of available space in the sound output buffer."
	"Note: Squeak always uses buffers containing 4-bytes per sample (2 channels at 2 bytes per channel) regardless of the state of the Stereo flag."

	<primitive: 'primitiveSoundAvailableSpace' module: 'SoundPlugin'>
	^ self primitiveFailed
! !

!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:17'!
primSoundGetVolume
	"Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
	<primitive: 'primitiveSoundGetVolume' module: 'SoundPlugin'>
	^Array with: 1.0 with: 1.0! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundInsertSamples: count from: aSoundBuffer samplesOfLeadTime: anInteger
	"Mix the given number of sample frames from the given sound buffer into the queue of samples that has already been submitted to the sound driver. This primitive is used to start a sound playing with minimum latency, even if large sound output buffers are being used to ensure smooth sound output. Returns the number of samples consumed, or zero if the primitive is not implemented or fails."

	<primitive: 'primitiveSoundInsertSamples' module: 'SoundPlugin'>
	^ 0
! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundPlaySamples: count from: aSampleBuffer startingAt: index
	"Copy count bytes into the current sound output buffer from the given sample buffer starting at the given index."

	<primitive: 'primitiveSoundPlaySamples' module: 'SoundPlugin'>
	^ self primitiveFailed
! !

!SoundPlayer class methodsFor: 'private' stamp: 'JMM 11/6/2000 10:14'!
primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume
	"Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or  higher to overdrive sound channel "
	<primitive: 'primitiveSoundSetLeftVolume' module: 'SoundPlugin'>
! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
	"Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)."
	"ar 12/5/1998 Turn off the sound if not supported"
	<primitive: 'primitiveSoundStart' module: 'SoundPlugin'>
	SoundSupported _ false.! !

!SoundPlayer class methodsFor: 'private' stamp: 'ar 2/2/2001 15:09'!
primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag semaIndex: anInteger
	"Start double-buffered sound output with the given buffer size and sampling rate. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled when the sound driver is ready to accept another buffer of samples."
	"Details: If this primitive fails, this method tries to use the older version instead."

	<primitive: 'primitiveSoundStartWithSemaphore' module: 'SoundPlugin'>
	UseReadySemaphore _ false.
	self primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag.
! !

!SoundPlayer class methodsFor: 'private' stamp: 'tpr 2/2/2001 19:46'!
primSoundStop
	"Stop double-buffered sound output. Must not raise an error because it is used inside error handling and at system shutdown"

	<primitive: 'primitiveSoundStop' module: 'SoundPlugin'>! !

!SoundPlayer class methodsFor: 'private' stamp: 'jm 6/7/1999 10:35'!
startPlayingImmediately: aSound
	"Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver."

	| totalSamples buf n leftover src rest |
	"first, fill a double-size buffer with samples"
	"Note: The code below assumes that totalSamples contains two
	 buffers worth of samples, and the insertSamples primitive is
	 expected to consume at least one buffer's worth of these
	 samples. The remaining samples are guaranteed to fit into
	 a single buffer."
	totalSamples _ Buffer stereoSampleCount * 2.  "two buffer's worth"
	buf _ SoundBuffer newStereoSampleCount: totalSamples.
	aSound playSampleCount: totalSamples into: buf startingAt: 1.
	ReverbState == nil ifFalse: [
		ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples].

	PlayerSemaphore critical: [
		"insert as many samples as possible into the sound driver's buffers"
		n _ self primSoundInsertSamples: totalSamples
			from: buf
			samplesOfLeadTime: 1024.
		leftover _ totalSamples - n.

		"copy the remainder of buf into Buffer"
		"Note: the following loop iterates over 16-bit words, not two-word stereo slices"
		"assert: 0 < leftover <= Buffer stereoSampleCount"
		src _ 2 * n.
		1 to: 2 * leftover do:
			[:dst | Buffer at: dst put: (buf at: (src _ src + 1))].

		"generate enough additional samples to finish filling Buffer"
		rest _ Buffer stereoSampleCount - leftover.
		aSound playSampleCount: rest into: Buffer startingAt: leftover + 1.
		ReverbState == nil ifFalse: [
			ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest].

		"record the fact that this sound has already been played into Buffer so that we don't process it again this time around"
		SoundJustStarted _ aSound.

		ActiveSounds add: aSound].
! !
TestInterpreterPlugin subclass: #SoundPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!SoundPlugin commentStamp: '<historical>' prior: 0!
Implements the main sound related primiives. 

NB: I really think it would be a good cleanup to mildly rewrite the sq{plat}Sound.c files to NOT refer directly back to the VM -- TPR.!


!SoundPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:54'!
initialiseModule
	self export: true.
	^self cCode: 'soundInit()' inSmalltalk:[true]! !

!SoundPlugin methodsFor: 'initialize-release' stamp: 'ar 5/12/2000 16:55'!
shutdownModule
	self export: true.
	^self cCode: 'soundShutdown()' inSmalltalk:[true]! !


!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:30'!
primitiveSoundAvailableSpace
	"Returns the number of sample frames of available sound output buffer space."

	| frames |
	self primitive: 'primitiveSoundAvailableSpace'.
	frames _ self cCode: 'snd_AvailableSpace()'.  "-1 if sound output not started"
	interpreterProxy success: frames >= 0.
	^frames asPositiveIntegerObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/24/2000 18:18'!
primitiveSoundGetRecordingSampleRate
	"Return a float representing the actual sampling rate during recording. Fail if not currently recording."

	| rate |
	self var: #rate declareC: 'double rate'.
	self primitive: 'primitiveSoundGetRecordingSampleRate'.
	rate _ self cCode: 'snd_GetRecordingSampleRate()'.  "fail if not recording"
	^rate asFloatObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'JMM 11/6/2000 11:21'!
primitiveSoundGetVolume
	"Set the sound input recording level."
	| left right results | 
	self primitive: 'primitiveSoundGetVolume'
		parameters: #( ).
	self var: #left declareC: 'double left'.
	self var: #right declareC: 'double right'.
	left _ 0.
	right _ 0.
	self cCode: 'snd_Volume((double *) &left,(double *) &right)'.
	interpreterProxy pushRemappableOop: (right asOop: Float).
	interpreterProxy pushRemappableOop: (left asOop: Float).
	interpreterProxy pushRemappableOop: (interpreterProxy instantiateClass: (interpreterProxy classArray) indexableSize: 2).
	results _ interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 0 ofObject: results withValue: interpreterProxy popRemappableOop.
	interpreterProxy storePointer: 1 ofObject: results withValue: interpreterProxy popRemappableOop.
	^ results! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:30'!
primitiveSoundInsertSamples: frameCount from: buf leadTime: leadTime 
	"Insert a buffer's worth of sound samples into the currently playing  
	buffer. Used to make a sound start playing as quickly as possible. The  
	new sound is mixed with the previously buffered sampled."
	"Details: Unlike primitiveSoundPlaySamples, this primitive always starts  
	with the first sample the given sample buffer. Its third argument  
	specifies the number of samples past the estimated sound output buffer  
	position the inserted sound should start. If successful, it returns the  
	number of samples inserted."
	| framesPlayed |
	self primitive: 'primitiveSoundInsertSamples'
		parameters: #(SmallInteger WordArray SmallInteger ).
	interpreterProxy success: frameCount <= (interpreterProxy slotSizeOf: buf cPtrAsOop).

	interpreterProxy failed
		ifFalse: [framesPlayed _ self cCode: 'snd_InsertSamplesFromLeadTime(frameCount, (int)buf, leadTime)'.
			interpreterProxy success: framesPlayed >= 0].
	^ framesPlayed asPositiveIntegerObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:31'!
primitiveSoundPlaySamples: frameCount from: buf startingAt: startIndex 
	"Output a buffer's worth of sound samples."
	| framesPlayed |
	self primitive: 'primitiveSoundPlaySamples'
		parameters: #(SmallInteger WordArray SmallInteger ).
	interpreterProxy success: (startIndex >= 1 and: [startIndex + frameCount - 1 <= (interpreterProxy slotSizeOf: buf cPtrAsOop)]).

	interpreterProxy failed
		ifFalse: [framesPlayed _ self cCode: 'snd_PlaySamplesFromAtLength(frameCount, (int)buf, startIndex - 1)'.
			interpreterProxy success: framesPlayed >= 0].
	^ framesPlayed asPositiveIntegerObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:31'!
primitiveSoundPlaySilence
	"Output a buffer's worth of silence. Returns the number of sample frames played."

	| framesPlayed |
	self primitive: 'primitiveSoundPlaySilence'.
	framesPlayed _ self cCode: 'snd_PlaySilence()'.  "-1 if sound output not started"
	interpreterProxy success: framesPlayed >= 0.
	^framesPlayed asPositiveIntegerObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/24/2000 18:31'!
primitiveSoundRecordSamplesInto: buf startingAt: startWordIndex 
	"Record a buffer's worth of 16-bit sound samples."
	| bufSizeInBytes samplesRecorded |
	self primitive: 'primitiveSoundRecordSamples'
		parameters: #(WordArray SmallInteger ).

	interpreterProxy failed
		ifFalse: [bufSizeInBytes _ (interpreterProxy slotSizeOf: buf cPtrAsOop) * 4.
			interpreterProxy success: (startWordIndex >= 1 and: [startWordIndex - 1 * 2 < bufSizeInBytes])].

	interpreterProxy failed ifFalse: [samplesRecorded _ self cCode: 'snd_RecordSamplesIntoAtLength((int)buf, startWordIndex - 1, bufSizeInBytes)'].
	^ samplesRecorded asPositiveIntegerObj! !

!SoundPlugin methodsFor: 'primitives' stamp: 'JMM 11/6/2000 11:06'!
primitiveSoundSetLeftVolume: aLeftVolume rightVolume: aRightVolume
	"Set the sound input recording level."

	self primitive: 'primitiveSoundSetLeftVolume'
		parameters: #(Float Float).
	interpreterProxy failed ifFalse: [self cCode: 'snd_SetVolume(aLeftVolume,aRightVolume)'].
! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 3/21/2000 16:39'!
primitiveSoundSetRecordLevel: level 
	"Set the sound input recording level."
	self primitive: 'primitiveSoundSetRecordLevel'
		parameters: #(SmallInteger ).
	interpreterProxy failed ifFalse: [self cCode: 'snd_SetRecordLevel(level)']! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 14:58'!
primitiveSoundStartBufferSize: bufFrames rate: samplesPerSec stereo: stereoFlag
	"Start the double-buffered sound output with the given buffer size, sample rate, and stereo flag."

	self primitive: 'primitiveSoundStart'
		parameters: #(SmallInteger SmallInteger Boolean).
	interpreterProxy success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, 0)')! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:57'!
primitiveSoundStartBufferSize: bufFrames rate: samplesPerSec stereo: stereoFlag semaIndex: semaIndex
	"Start the double-buffered sound output with the given buffer size, sample rate, stereo flag, and semaphore index."

	self primitive: 'primitiveSoundStartWithSemaphore'
		parameters: #(SmallInteger SmallInteger Boolean SmallInteger).
	interpreterProxy success: (self cCode: 'snd_Start(bufFrames, samplesPerSec, stereoFlag, semaIndex)')! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:55'!
primitiveSoundStartRecordingDesiredSampleRate: desiredSamplesPerSec stereo: stereoFlag semaIndex: semaIndex
	"Start recording sound with the given parameters."

	self primitive: 'primitiveSoundStartRecording'
		parameters: #(SmallInteger Boolean SmallInteger).
	self cCode: 'snd_StartRecording(desiredSamplesPerSec, stereoFlag, semaIndex)'! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:58'!
primitiveSoundStop
	"Stop double-buffered sound output."

	self primitive: 'primitiveSoundStop'.

	self cCode: 'snd_Stop()'.  "leave rcvr on stack"! !

!SoundPlugin methodsFor: 'primitives' stamp: 'TPR 2/25/2000 12:58'!
primitiveSoundStopRecording
	"Stop recording sound."

	self primitive: 'primitiveSoundStopRecording'.
	self cCode: 'snd_StopRecording()'.  "leave rcvr on stack"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundPlugin class
	instanceVariableNames: ''!

!SoundPlugin class methodsFor: 'translation' stamp: 'JMM 11/6/2000 11:08'!
headerFile
^'/* SoundPlugin.h - header for Sound Plugins :-) tim@sumeru.stanford.edu */

/* module initialization/shutdown */
int soundInit(void);
int soundShutdown(void);

/* sound output */
int snd_AvailableSpace(void);
int snd_InsertSamplesFromLeadTime(int frameCount, int srcBufPtr, int samplesOfLeadTime);
int snd_PlaySamplesFromAtLength(int frameCount, int arrayIndex, int startIndex);
int snd_PlaySilence(void);
int snd_Start(int frameCount, int samplesPerSec, int stereo, int semaIndex);
int snd_Stop(void);

/* sound input */
int snd_SetRecordLevel(int level);
int snd_StartRecording(int desiredSamplesPerSec, int stereo, int semaIndex);
int snd_StopRecording(void);
double snd_GetRecordingSampleRate(void);
int snd_RecordSamplesIntoAtLength(int buf, int startSliceIndex, int bufferSizeInBytes);
void snd_Volume(double *left, double *right); //johnmci@smalltalkconsulting.com Nov 6th 2000
void snd_SetVolume(double left, double right);//johnmci@smalltalkconsulting.com Nov 6th 2000
'! !
StringReadoutTile subclass: #SoundReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!SoundReadoutTile methodsFor: 'as yet unclassified' stamp: 'sw 1/17/1999 21:51'!
setLiteralTo: anObject width: w
	| soundChoices index |
	self flag: #deferrred.  "This is still in process, and until it's worked through, #sound as a data type for user-added slots will continue to be disallowed"

	soundChoices _ #('silence').  "default, if no SampledSound class"
	Smalltalk at: #SampledSound ifPresent:
		[:sampledSound | soundChoices _ sampledSound soundNames].
	index _ soundChoices indexOf: anObject.
	self setLiteral: (soundChoices atWrap: index)! !
Object subclass: #SoundRecorder
	instanceVariableNames: 'stereo samplingRate recordLevel recordedBuffers recordedSound recordProcess bufferAvailableSema paused meteringBuffer meterLevel soundPlaying currentBuffer nextIndex codec desiredSampleRate '
	classVariableNames: 'CanRecordWhilePlaying RecorderActive '
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!SoundRecorder methodsFor: 'initialization' stamp: 'jm 4/22/1999 14:30'!
initialize
	"SoundRecorder new"

	stereo _ false.
	samplingRate _ 11025.
	recordLevel _ 0.5.
	self initializeRecordingState.
! !

!SoundRecorder methodsFor: 'initialization' stamp: 'jhm 10/15/97 14:30'!
initializeRecordingState

	recordProcess _ nil.
	bufferAvailableSema _ nil.
	paused _ true.
	meteringBuffer _ nil.
	meterLevel _ 0.
	soundPlaying _ nil.
	currentBuffer _ nil.
	nextIndex _ 1.
! !


!SoundRecorder methodsFor: 'accessing' stamp: 'di 2/17/1999 11:08'!
codec: aSoundCodec

	codec _ aSoundCodec! !

!SoundRecorder methodsFor: 'accessing' stamp: 'RAA 12/30/2000 10:28'!
desiredSampleRate: newRate

	"use of this method indicates a strong desire for the specified rate, even if
	the OS/hardware are not cooperative"

	desiredSampleRate _ samplingRate _ newRate  "Best are 44100 22050 11025"
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jj 10/20/97 15:30'!
isActive
	"Return true if I have a recordProcess running."

	^ recordProcess ~~ nil
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/2/97 16:16'!
isPaused
	"Return true if recording is paused."

	^ paused
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 9/18/97 19:19'!
meterLevel
	"Return the meter level, an integer in the range [0..100] where zero is silence and 100 represents the maximum signal level possible without clipping."

	^ (100 * meterLevel) // 32768
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:03'!
recordLevel

	^ recordLevel
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:04'!
recordLevel: level
	"Set the desired recording level to the given value in the range 0.0 to 1.0, where 0.0 is the lowest recording level and 1.0 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."
	"Details: On the Macintosh, the lowest possible record level attenuates the input signal, but does not silence it entirely." 

	recordLevel _ (level asFloat min: 1.0) max: 0.0.
	recordProcess ifNotNil: [
		self primSetRecordLevel: (1000.0 * recordLevel) asInteger].
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'jm 12/15/97 14:28'!
samplingRate

	^ samplingRate
! !

!SoundRecorder methodsFor: 'accessing' stamp: 'di 2/16/1999 09:58'!
samplingRate: newRate

	samplingRate _ newRate  "Best are 44100 22050 11025"
! !


!SoundRecorder methodsFor: 'recording controls' stamp: 'di 2/17/1999 10:54'!
clearRecordedSound
	"Clear the sound recorded thus far. Go into pause mode if currently recording."

	paused _ true.
	recordedSound _ SequentialSound new.
	self allocateBuffer.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'RAA 8/13/2000 11:37'!
pause
	"Go into pause mode. The record level continues to be updated, but no sound is recorded."

	paused _ true.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer.
				self allocateBuffer].

	soundPlaying ifNotNil: [
		soundPlaying pause.
		soundPlaying _ nil].
	"Note: there can be problems if canRecordWhilePlaying is true. Recorders which only pause will inhibit other recorders from recording. I chose to make #stopPlaying unconditional in a subclass. The same might be appropriate here at the expense of making recorders resumable"

	Preferences canRecordWhilePlaying ifFalse: [self stopRecording].
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'jm 10/17/97 14:53'!
playback
	"Playback the sound that has been recorded."

	self pause.
	soundPlaying _ self recordedSound.
	soundPlaying play.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'RAA 8/13/2000 11:41'!
resumeRecording
	"Continue recording from the point at which it was last paused."

	self flag: #bob.
	"Note: If canRecordWhilePlaying is true, then recordings may never get started (at least by this method). One possibility, used in a subclass, is to make the #startPlaying unconditional. Another would be to use #startPlaying instead of #resumePlaying in appropriate cases"

	Preferences canRecordWhilePlaying ifFalse: [self startRecording].
	paused _ false.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'ar 2/1/2001 15:19'!
startRecording
	"Turn of the sound input driver and start the recording process. Initially, recording is paused."

	| semaIndex |
	recordLevel ifNil: [recordLevel _ 0.5].  "lazy initialization"
	Preferences canRecordWhilePlaying ifFalse: [SoundPlayer shutDown].
	recordProcess ifNotNil: [self stopRecording].
	paused _ true.
	meteringBuffer _ SoundBuffer newMonoSampleCount: 1024.
	meterLevel _ 0.
	self allocateBuffer.
	bufferAvailableSema _ Semaphore new.
	semaIndex _ Smalltalk registerExternalObject: bufferAvailableSema.
	self primStartRecordingDesiredSampleRate: samplingRate asInteger
		stereo: stereo
		semaIndex: semaIndex.
	RecorderActive _ true.
	samplingRate _ self primGetActualRecordingSampleRate.
	self primSetRecordLevel: (1000.0 * recordLevel) asInteger.
	recordProcess _ [self recordLoop] newProcess.
	recordProcess priority: Processor userInterruptPriority.
	recordProcess resume.
! !

!SoundRecorder methodsFor: 'recording controls' stamp: 'ar 2/1/2001 15:19'!
stopRecording
	"Stop the recording process and turn of the sound input driver."

	recordProcess ifNotNil: [recordProcess terminate].
	recordProcess _ nil.
	self primStopRecording.
	RecorderActive _ false.
	Smalltalk unregisterExternalObject: bufferAvailableSema.
	((currentBuffer ~~ nil) and: [nextIndex > 1])
		ifTrue: [self emitPartialBuffer].
	self initializeRecordingState.
! !


!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/17/97 17:43'!
copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset
	"Return a new SoundBuffer containing the samples in the given range."

	| startBufIndex startSampleIndex endBufIndex endSampleIndex
	 count resultBuf j buf firstInBuf n |
	startBufIndex _ startPlace at: 1.
	startSampleIndex _ startPlace at: 2.
	endBufIndex _ endPlace at: 1.
	endSampleIndex _ endPlace at: 2.

	startBufIndex = endBufIndex
		ifTrue: [count _ endSampleIndex + 1 - startSampleIndex]
		ifFalse: [
			count _ ((recordedBuffers at: startBufIndex) size + 1 - startSampleIndex).  "first buffer"
			count _ count + endSampleIndex.  "last buffer"
			startBufIndex + 1 to: endBufIndex - 1 do:
				[:i | count _ count + (recordedBuffers at: i) size]].  "middle buffers"
	resultBuf _ SoundBuffer newMonoSampleCount: count.

	j _ 1.  "next destination index in resultBuf"
	startBufIndex to: endBufIndex do: [:i |
		buf _ recordedBuffers at: i.
		firstInBuf _ 1.
	 	n _ buf size.
		i = startBufIndex ifTrue: [
			n _ (recordedBuffers at: startBufIndex) size + 1 - startSampleIndex.
			firstInBuf _ startSampleIndex].
		i = endBufIndex ifTrue: [
			i = startBufIndex
				ifTrue: [n _ endSampleIndex + 1 - startSampleIndex]
				ifFalse: [n _ endSampleIndex]].
		self copyTo: resultBuf from: j to: (j + n - 1)
			from: buf startingAt: firstInBuf
			normalize: nFactor dcOffset: dcOffset.
		j _ j + n].
	^ resultBuf
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/18/97 11:23'!
copyTo: resultBuf from: startIndex to: endIndex from: buf startingAt: firstInBuf normalize: nFactor dcOffset: dcOffset
	"Copy samples from buf to resultBuf removing the DC offset and normalizing their volume in the process."

	| indexOffset |
	indexOffset _ firstInBuf - startIndex.
	startIndex to: endIndex do: [:i |
		resultBuf at: i put: (((buf at: (i + indexOffset)) - dcOffset) * nFactor) // 1000].
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'!
endPlace

	^ Array with: recordedBuffers size with: recordedBuffers last size! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'!
firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace
	"Beginning at startPlace, this routine will return the first place at which a sample exceeds the given threshold."

	| buf s iStart jStart nThreshold |
	nThreshold _ threshold negated.
	iStart _ startPlace first.
	jStart _ startPlace second.
	iStart to: recordedBuffers size do:
		[:i | buf _ recordedBuffers at: i.
		jStart to: buf size do:
			[:j | s _ (buf at: j) - dcOffset.
			(s < nThreshold or: [s > threshold]) ifTrue:
				["found a sample over threshold"
				^ Array with: i with: j]].
		jStart _ 1].
	^ self endPlace! !

!SoundRecorder methodsFor: 'trimming' stamp: 'jm 10/18/97 11:22'!
normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset
	"Return a normalization factor for the range of sample values and DC offset. A normalization factor is a fixed-point number that will be divided by 1000 after multiplication with each sample value."

	| peak factor |
	peak _ (max - dcOffset) max: (min - dcOffset) negated.
	peak = 0 ifTrue: [^ 1000].
	factor _ (32767.0 * percentOfMaxVolume) / (100.0 * peak).
	^ (factor * 1000.0) asInteger
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:01'!
place: startPlace plus: nSamples
	"Return the place that is nSamples (may be negative) beyond thisPlace."

	| i j remaining buf |
	i _ startPlace first.
	j _ startPlace second.
	nSamples >= 0
	ifTrue: [remaining _ nSamples.
			[buf _ recordedBuffers at: i.
			(j + remaining) <= buf size ifTrue: [^ Array with: i with: j + remaining].
			i < recordedBuffers size]
				whileTrue: [remaining _ remaining - (buf size - j + 1).
							i _ i+1.  j _ 1].
			^ self endPlace]
	ifFalse: [remaining _ nSamples negated.
			[buf _ recordedBuffers at: i.
			(j - remaining) >= 1 ifTrue: [^ Array with: i with: j - remaining].
			i > 1]
				whileTrue: [remaining _ remaining - j.
							i _ i-1.  j _ (recordedBuffers at: i) size].
			^ #(1 1)]! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:19'!
scanForEndThreshold: threshold dcOffset: dcOffset minLull: lull startingAt: startPlace
	"Beginning at startPlace, this routine will find the last sound that exceeds threshold, such that if you look lull samples later you will not find another sound over threshold within the following block of lull samples.
	Return the place that is lull samples beyond to that last sound.
	If no end of sound is found, return endPlace."

	| buf s iStart jStart nThreshold n |
	nThreshold _ threshold negated.
	iStart _ startPlace first.
	jStart _ startPlace second.
	n _ 0.
	iStart to: recordedBuffers size do:
		[:i | buf _ recordedBuffers at: i.
		jStart to: buf size do:
			[:j | s _ (buf at: j) - dcOffset.
			(s < nThreshold or: [s > threshold])
				ifTrue: ["found a sample over threshold"
						n _ 0]
				ifFalse: ["still not over threshold"
						n _ n + 1.
						n >= lull ifTrue: [^ Array with: i with: j]]].
		jStart _ 1].
	^ self endPlace! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 22:13'!
scanForStartThreshold: threshold dcOffset: dcOffset minDur: duration startingAt: startPlace
	"Beginning at startPlace, this routine will find the first sound that exceeds threshold, such that if you look duration samples later you will find another sound over threshold within the following block of duration samples.
	Return the place that is duration samples prior to that first sound.
	If no sound is found, return endPlace."

	| soundPlace lookPlace nextSoundPlace thirdPlace |
	soundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset
					startingAt: startPlace.
	[soundPlace = self endPlace ifTrue: [^ soundPlace].
	"Found a sound -- look duration later"
	lookPlace _ self place: soundPlace plus: duration.
	nextSoundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset
					startingAt: lookPlace.
	thirdPlace _ self place: lookPlace plus: duration.
	nextSoundPlace first < thirdPlace first
		or: [nextSoundPlace first = thirdPlace first
			and: [nextSoundPlace second < thirdPlace second]]]
		whileFalse: [soundPlace _ nextSoundPlace].

	"Yes, there is sound in the next interval as well"
	^ self place: soundPlace plus: 0-duration
! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 21:26'!
segmentsAbove: threshold normalizedVolume: percentOfMaxVolume
	"Break the current recording up into a sequence of sound segments separated by silences."

	| max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize |
	stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
	paused ifFalse: [self error: 'must stop recording before trimming'].
	(recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self].
	"Reconstruct buffers so old trimming code will work"
	recordedBuffers _ recordedSound sounds collect: [:snd | snd samples].
	soundSize _ restSize _ 0.

	max _ min _ sum _ totalSamples _ 0.
	recordedBuffers do: [:buf |
		bufSize _ buf size.
		totalSamples _ totalSamples + buf size.
		1 to: bufSize do: [:i |
			s _ buf at: i.
			s > max ifTrue: [max _ s].
			s < min ifTrue: [min _ s].
			sum _ sum + s]].
	dcOffset _ sum // totalSamples.

	minDur _ (samplingRate/20.0) asInteger.  " 1/20 second "
	minLull _ (samplingRate/4.0) asInteger.  " 1/2 second "
	segments _ SequentialSound new.
	endPlace _ self endPlace.
	lastPlace _ #(1 1).
	[firstPlace _ self scanForStartThreshold: threshold
						dcOffset: dcOffset
						minDur: minDur
						startingAt: lastPlace.
	firstPlace = endPlace]
		whileFalse:
		[firstPlace = lastPlace ifFalse:
			["Add a silence equal to the gap size"
			"Wasteful but simple way to get gap size..."
			gapSize _ (self copyFrom: lastPlace to: firstPlace
						normalize: 1000 dcOffset: dcOffset) size - 2.
			"... -2 makes up for overlap of one sample on either end"
			segments add: (RestSound dur: gapSize asFloat / samplingRate).
			restSize _ restSize + gapSize.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'."
			].
		lastPlace _ self scanForEndThreshold: threshold
						dcOffset: dcOffset
						minLull: minLull + minDur
						startingAt: firstPlace.
		"Allow room for lead time of next sound"
		lastPlace _ self place: lastPlace plus: minDur negated.
		nFactor _ self normalizeFactorFor: percentOfMaxVolume
						min: min max: max dcOffset: dcOffset.
		resultBuf _ self copyFrom: firstPlace to: lastPlace
						normalize: nFactor dcOffset: dcOffset.
		soundSize _ soundSize + resultBuf size.
"Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'."
		segments add: (codec == nil
			ifTrue: [SampledSound new setSamples: resultBuf samplingRate: samplingRate]
			ifFalse: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])].

	"Final gap for consistency"
	gapSize _ (self copyFrom: lastPlace to: self endPlace
				normalize: 1000 dcOffset: dcOffset) size - 1.
	segments add: (RestSound dur: gapSize asFloat / samplingRate).
	restSize _ restSize + gapSize.
	PopUpMenu notify: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString.
	recordedBuffers _ nil.
	^ segments! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 2/17/1999 20:38'!
suppressSilence

	recordedSound _ self soundSegments! !

!SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 22:52'!
trim: threshold normalizedVolume: percentOfMaxVolume
	"Remove the leading and trailing parts of this recording that are below the given threshold. Remove any DC offset and scale the recording so that its peaks are the given percent of the maximum volume."

	| max min sum totalSamples bufSize s dcOffset startPlace endPlace resultBuf nFactor |
	stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
	paused ifFalse: [self error: 'must stop recording before trimming'].
	recordedBuffers _ recordedSound sounds collect: [:snd | snd samples].
	recordedBuffers isEmpty ifTrue: [^ self].

	max _ min _ sum _ totalSamples _ 0.
	recordedBuffers do: [:buf |
		bufSize _ buf size.
		totalSamples _ totalSamples + buf size.
		1 to: bufSize do: [:i |
			s _ buf at: i.
			s > max ifTrue: [max _ s].
			s < min ifTrue: [min _ s].
			sum _ sum + s]].
	dcOffset _ sum // totalSamples.

	"a place is an array of <buffer index><index of sample in buffer>"
	startPlace _ self scanForStartThreshold: threshold
					dcOffset: dcOffset
					minDur: (samplingRate/60.0) asInteger "at least 1/60th of a second"
					startingAt: #(1 1).
	startPlace = self endPlace ifTrue:
		["no samples above threshold"
		recordedBuffers _ nil.  ^ self].

	endPlace _ self scanForEndThreshold: threshold
					dcOffset: dcOffset
					minLull: (samplingRate/5) asInteger
					startingAt: startPlace.
	nFactor _ self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset.
	resultBuf _ self copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset.
	recordedSound _ SampledSound new setSamples: resultBuf samplingRate: samplingRate.
	recordedBuffers _ nil
! !


!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'!
allocateBuffer
	"Allocate a new buffer and reset nextIndex."

	| bufferTime |
	bufferTime _ stereo  "Buffer time = 1/2 second"
		ifTrue: [self samplingRate asInteger]
		ifFalse: [self samplingRate asInteger // 2].
	currentBuffer _ SoundBuffer newMonoSampleCount:
		"Multiple of samplesPerFrame that is approx. bufferTime long"
		(bufferTime truncateTo: self samplesPerFrame).
	nextIndex _ 1.
! !

!SoundRecorder methodsFor: 'private' stamp: 'RAA 1/2/2001 10:17'!
emitBuffer: buffer

	| sound ratio resultBuf |

	"since some sound recording devices cannot (or will not) record below a certain sample rate,
	trim the samples down if the user really wanted fewer samples"

	(desiredSampleRate isNil or: [(ratio _ samplingRate // desiredSampleRate) <= 1]) ifTrue: [
		sound _ SampledSound new setSamples: buffer samplingRate: samplingRate.
	] ifFalse: [
		resultBuf _ SoundBuffer 
			averageEvery: ratio 
			from: buffer 
			upTo: buffer monoSampleCount.
		sound _ SampledSound new setSamples: resultBuf samplingRate: samplingRate / ratio.
	].

	recordedSound add: (codec ifNil: [sound] ifNotNil: [codec compressSound: sound])! !

!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'!
emitPartialBuffer
	| s |
	s _ self samplesPerFrame.
	self emitBuffer: (currentBuffer copyFrom: 1 to: ((nextIndex-1) +( s-1) truncateTo: s))! !

!SoundRecorder methodsFor: 'private' stamp: 'jm 9/2/97 16:16'!
meterFrom: start count: count in: buffer
	"Update the meter level with the maximum signal level in the given range of the given buffer."

	| last max sample |
	count = 0 ifTrue: [^ self].  "no new samples"
	last _ start + count - 1.
	max _ 0.
	start to: last do: [:i |
		sample _ buffer at: i.
		sample < 0 ifTrue: [sample _ sample negated].
		sample > max ifTrue: [max _ sample]].
	meterLevel _ max.
! !

!SoundRecorder methodsFor: 'private' stamp: 'di 2/16/1999 08:55'!
recordLoop
	"Record process loop that records samples."

	| n sampleCount |
	n _ 0.
	[true] whileTrue: [
		n = 0 ifTrue: [bufferAvailableSema wait].
		paused
			ifTrue: [
				n _ self primRecordSamplesInto: meteringBuffer startingAt: 1.
				self meterFrom: 1 count: n in: meteringBuffer]
			ifFalse: [
				n _ self primRecordSamplesInto: currentBuffer startingAt: nextIndex.
				self meterFrom: nextIndex count: n in: currentBuffer.
				nextIndex _ nextIndex + n.
				stereo
					ifTrue: [sampleCount _ currentBuffer stereoSampleCount]
					ifFalse: [sampleCount _ currentBuffer monoSampleCount].
				nextIndex > sampleCount
					ifTrue: [
						self emitBuffer: currentBuffer.
						self allocateBuffer]]].
! !

!SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 10:39'!
samplesPerFrame
	"Can be overridden to quantize buffer size for, eg, fixed-frame codecs"

	codec == nil
		ifTrue: [^ 1]
		ifFalse: [^ codec samplesPerFrame]! !


!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primGetActualRecordingSampleRate
	"Return the actual sample rate being used for recording. This primitive fails unless sound recording is currently in progress."

	<primitive: 'primitiveSoundGetRecordingSampleRate' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primRecordSamplesInto: aWordArray startingAt: index
	"Record a sequence of 16-bit sound samples into the given array starting at the given sample index. Return the number of samples recorded, which may be zero if no samples are currently available."

	<primitive: 'primitiveSoundRecordSamples' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSetRecordLevel: anInteger
	"Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."

	<primitive: 'primitiveSoundSetRecordLevel' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger
	"Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled."

	<primitive: 'primitiveSoundStartRecording' module: 'SoundPlugin'>
	self primitiveFailed
! !

!SoundRecorder methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primStopRecording
	"Stop sound recording. Does nothing if recording is not currently in progress."

	<primitive: 'primitiveSoundStopRecording' module: 'SoundPlugin'>
	self primitiveFailed
! !



!SoundRecorder methodsFor: 'results' stamp: 'di 3/4/1999 21:40'!
condensedSamples
	"Return a single SoundBuffer that is the contatenation of all my recorded buffers."

	| sz newBuf i |
	recordedBuffers _ recordedSound sounds collect: [:snd | snd samples].
	recordedBuffers isEmpty ifTrue: [^ SoundBuffer new: 0].
	recordedBuffers size = 1 ifTrue: [^ recordedBuffers first copy].
	sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
	newBuf _ SoundBuffer newMonoSampleCount: sz.
	i _ 1.
	recordedBuffers do: [:b |
		1 to: b size do: [:j |
			newBuf at: i put: (b at: j).
			i _ i + 1]].
	recordedBuffers _ nil.
	^ newBuf
! !

!SoundRecorder methodsFor: 'results' stamp: 'di 2/16/1999 20:49'!
condensedStereoSound
	"Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers."

	| sz leftBuf rightBuf leftI rightI left |
	sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
	leftBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2.
	rightBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2.
	leftI _ rightI _ 1.
	left _ true.
	recordedBuffers do: [:b |
		1 to: b size do: [:j |
			left
				ifTrue: [leftBuf at: leftI put: (b at: j). leftI _ leftI + 1. left _ false]
				ifFalse: [rightBuf at: rightI put: (b at: j). rightI _ rightI + 1. left _ true]]].
	^ MixedSound new
		add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0.0;
		add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1.0
! !

!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 11:07'!
recordedSound
	"Return the sound that was recorded."

	^ recordedSound
! !

!SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 21:24'!
soundSegments

	^ self segmentsAbove: 1000 normalizedVolume: 80.0
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SoundRecorder class
	instanceVariableNames: ''!

!SoundRecorder class methodsFor: 'class initialization' stamp: 'RAA 8/7/2000 19:23'!
initialize
	"SoundRecorder initialize"
	"Details: Some computers cannot record and playback sound at the same time. If CanRecordWhilePlaying is false, then the SoundRecorder alternates between recording and playing. If it is true, sounds can be playing during recording."

	CanRecordWhilePlaying _ #ignoredNowInPreferences.
! !


!SoundRecorder class methodsFor: 'instance creation' stamp: 'jm 8/24/97 01:20'!
new

	^ super new initialize
! !


!SoundRecorder class methodsFor: 'accessing' stamp: 'ar 2/1/2001 15:20'!
anyActive
	"Return true if any sound recorder is actively recording"
	^RecorderActive == true! !

!SoundRecorder class methodsFor: 'accessing' stamp: 'RAA 8/7/2000 19:23'!
canRecordWhilePlaying
	"Return true if this platform supports simultaneous sound recording and playback."

	^Preferences canRecordWhilePlaying.		"now in preferences"
! !
RectangleMorph subclass: #SoundSequencerMorph
	instanceVariableNames: 'controlPanel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
initialize
	super initialize.
	self extent: 550@350.
	self makeControlPanel.
	self addMorph: controlPanel.
	self addMorph: ((SoundLoopMorph newBounds: (10@40 extent: 128@128)) extent: 128@128).
	self addMorph: ((SoundLoopMorph newBounds: (10@200 extent: 512@128)) extent: 512@128).! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 20:43'!
makeControlPanel
	| b |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	controlPanel _ AlignmentMorph newRow.
	controlPanel color: b color; borderWidth: 0; layoutInset: 0.
	controlPanel hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	controlPanel addMorphBack: (b fullCopy label: 'reset';	actionSelector: #reset).
	controlPanel addMorphBack: (b fullCopy label: 'stop';		actionSelector: #stop).
	controlPanel addMorphBack: (b fullCopy label: 'play';	actionSelector: #play).
! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
play
	self submorphsDo: [:m | m == controlPanel ifFalse: [m play]]! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:08'!
reset
	self submorphsDo: [:m | m == controlPanel ifFalse: [m reset]]! !

!SoundSequencerMorph methodsFor: 'as yet unclassified' stamp: 'jm 11/14/97 11:21'!
stop
	self submorphsDo: [:m | m == controlPanel ifFalse: [m stop]].
	SoundPlayer shutDown! !
TileMorph subclass: #SoundTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!SoundTile methodsFor: 'initialization' stamp: 'tk 8/14/2000 22:37'!
initialize
	super initialize.
	self addArrows; setLiteral: 'croak'.
	self labelMorph useStringFormat! !


!SoundTile methodsFor: 'user interface' stamp: 'ar 10/25/2000 18:05'!
mouseDown: evt

	| aPoint index isUp soundChoices adjustment |
	upArrow ifNotNil: [((isUp _ upArrow containsPoint: (aPoint _ evt cursorPoint)) or:
			[downArrow containsPoint: aPoint]) ifTrue: [
		soundChoices _ #('silence').  "default, if no SampledSound class"
		Smalltalk at: #SampledSound ifPresent:
			[:sampledSound | soundChoices _ sampledSound soundNames].
		index _ soundChoices indexOf: literal.
		index > 0 ifTrue:
			[adjustment _ isUp ifTrue: [1] ifFalse: [-1].
			self literal: (soundChoices atWrap: (index + adjustment))].
		self playSoundNamed: literal].
		^ self].

	super mouseStillDown: evt.
! !

!SoundTile methodsFor: 'user interface' stamp: 'sw 11/2/97 02:08'!
mouseMove: evt
	"overridden so as NOT to keep scrolling"! !

!SoundTile methodsFor: 'user interface' stamp: 'sw 11/3/97 02:11'!
wantsKeyboardFocusFor: aSubmorph
	^ false! !


!SoundTile methodsFor: 'type' stamp: 'sw 10/12/97 21:48'!
resultType

	^ #sound! !


!SoundTile methodsFor: 'access' stamp: 'jm 2/4/1999 12:02'!
sound

	^ SampledSound soundNamed: literal
! !
SequenceableCollection subclass: #SourceFileArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!SourceFileArray commentStamp: '<historical>' prior: 0!
This class is an abstract superclass for source code access mechanisms. It defines the messages that need to be understood by those subclasses that store and retrieve source chunks on files, over the network or in databases.
The first concrete subclass, StandardSourceFileArray, supports access to the traditional sources and changes files. Other subclasses might implement multiple source files for different applications, or access to a network source server.!
]style[(254 23 184)f1,f1LStandardSourceFileArray Comment;,f1!


!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:42'!
at: index
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'!
at: index put: aFileStream
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:28'!
collect: aBlock
	| copy |
	copy _ self species new: self size.
	1 to: self size do:[:i| copy at: i put: (aBlock value: (self at: i))].
	^copy! !

!SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'!
size
	self subclassResponsibility! !


!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'!
fileIndexFromSourcePointer: anInteger
	"Return the index of a source file corresponding to the given source pointer."
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'!
filePositionFromSourcePointer: anInteger
	"Return the position within a source file for the given source pointer."
	self subclassResponsibility! !

!SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:01'!
sourcePointerFromFileIndex: index andPosition: position
	"Return a sourcePointer encoding the given file index and position"
	self subclassResponsibility! !
Object subclass: #Speaker
	instanceVariableNames: 'pitch range loudness speed transcriber voice visitors '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!Speaker methodsFor: 'initialization' stamp: 'len 11/27/2000 09:59'!
initialize
	self pitch: 100.0; range: 0.3; loudness: 1.0; speed: 0.6; "normalizer: TextNormalizer new;" transcriber: PhoneticTranscriber default; visitors: {IntonationVisitor default. DurationsVisitor default. F0RenderingVisitor default}! !


!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
loudness
	^ loudness! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
loudness: aNumber
	loudness _ aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/13/1999 03:02'!
phonemes
	"Answer the phoneme set of the receiver."
	^ self transcriber phonemes! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:18'!
pitch
	"Answer the average pitch."
	^ pitch! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:18'!
pitch: aNumber
	"Set the average pitch."
	pitch _ aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:18'!
range
	"Answer the pitch range (variation)."
	^ range! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/13/1999 01:14'!
range: aNumber
	"Set the pitch range (variation)."
	range _ aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
speed
	^ speed! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:33'!
speed: aNumber
	speed _ aNumber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:31'!
transcriber
	^ transcriber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:31'!
transcriber: aPhoneticTranscriber
	transcriber _ aPhoneticTranscriber! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:02'!
visitors
	^ visitors! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/12/1999 23:02'!
visitors: aCollection
	visitors _ aCollection! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:32'!
voice
	^ voice! !

!Speaker methodsFor: 'accessing' stamp: 'len 12/8/1999 16:32'!
voice: aVoice
	voice _ aVoice! !


!Speaker methodsFor: 'parsing' stamp: 'len 12/14/1999 02:13'!
clauseFromString: aString
	^ Clause new
		string: aString;
		phrases: ((aString findTokens: '!!?.,;()') collect: [ :each | self phraseFromString: each])! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/22/1999 03:46'!
eventsFromString: aString
	| clause |
	clause _ self clauseFromString: aString.
	clause phrases do: [ :each | each lastSyllable events add: (PhoneticEvent new phoneme: self phonemes silence; duration: 0.1)].
	clause lastSyllable events last duration: 0.5.
	visitors do: [ :each | each speaker: self. clause accept: each].
	clause eventsDo: [ :each | each loudness: self loudness].
	^ clause events! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/13/1999 03:19'!
phraseFromString: aString
	^ Phrase new
		string: aString;
		words: ((aString findTokens: ' !!?.,;()') collect: [ :each | self wordFromString: each])! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/8/1999 17:08'!
syllabizationOf: phonemes
	| syllable stream last answer |
	answer _ OrderedCollection new.
	syllable _ Syllable new phonemes: (OrderedCollection new: 4).
	stream _ ReadStream on: phonemes.
	[stream atEnd]
		whileFalse: [syllable phonemes add: (last _ stream next).
					(stream atEnd not and: [last isConsonant not and: [stream peek isConsonant]])
						ifTrue: [answer add: syllable. syllable _ Syllable new phonemes: (OrderedCollection new: 4)]].
	syllable phonemes isEmpty ifFalse: [answer add: syllable].
	^ answer! !

!Speaker methodsFor: 'parsing' stamp: 'len 12/8/1999 18:24'!
wordFromString: aString
	^ Word new
		string: aString;
		syllables: (self syllabizationOf: (self transcriber transcriptionOf: aString))! !


!Speaker methodsFor: 'playing' stamp: 'len 12/22/1999 03:41'!
say: aString
	| events stream string |
	events _ CompositeEvent new.
	stream _ ReadStream on: (aString findTokens: '?' keep: '?').
	[stream atEnd]
		whileFalse: [string _ stream next.
					stream atEnd ifFalse: [string _ string, stream next].
					events addAll: (self eventsFromString: string)].
	events playOn: self voice delayed: events duration * 1000.
	self voice flush! !


!Speaker methodsFor: 'editing' stamp: 'ar 11/9/2000 20:57'!
edit
	| answer buttons |
	answer _ (self findAVoice: KlattVoice) editor.
	buttons _ AlignmentMorph new listDirection: #leftToRight; color: answer color.
	buttons
		addMorphFront: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #newHead; labelString: 'new head');
		addMorphFront: (SimpleButtonMorph new target: self; actWhen: #buttonDown; actionSelector:  #saySomething; labelString: 'test').
	answer
		addSliderForParameter: #speed target: self min: 0.1 max: 2.0 description: 'Speed';
		addSliderForParameter: #loudness target: self min: 0.0 max: 1.0 description: 'Loudness';
		addSliderForParameter: #range target: self min: 0.0 max: 1.0 description: 'Pitch Range';
		addSliderForParameter: #pitch target: self min: 20.0 max: 800.0 description: 'Pitch';
		addMorphFront: buttons;
		openInWorld! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:19'!
findAVoice: aClass
	(self voice isKindOf: aClass) ifTrue: [^ self voice].
	(self voice isKindOf: CompositeVoice)
		ifTrue: [self voice do: [ :each | (each isKindOf: aClass) ifTrue: [^ each]]].
	^ nil! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:27'!
makeGestural
	(self findAVoice: GesturalVoice) isNil ifFalse: [^ self].
	self voice: self voice + GesturalVoice new! !

!Speaker methodsFor: 'editing' stamp: 'len 12/2/1999 03:27'!
newHead
	self makeGestural.
	(self findAVoice: GesturalVoice) newHead! !

!Speaker methodsFor: 'editing' stamp: 'len 12/14/1999 05:24'!
saySomething
	self say: #('This is my voice.' 'I am speaking.' 'Do you like my voice?' 'Listen to my voice.' 'Hello.' 'Hay. What are you doing?' 'How are you?' 'Is this my voice?' 'Are you there?' 'Help, please.' 'Howdy.' 'Ha ha he he hi.') atRandom! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Speaker class
	instanceVariableNames: ''!

!Speaker class methodsFor: 'instance creation' stamp: 'len 12/12/1999 23:06'!
new
	^ super new initialize! !


!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:17'!
bicyclic
	"
	Speaker bicyclic say: 'This is my voice. I am a woman with bicyclic voice.'
	"

	^ self new
		pitch: 200.0;
		voice: (KlattVoice new diplophonia: 0.4; tract: 14.4)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:56'!
bigMan
	"
	Speaker bigMan say: 'I am the child? No. I am the big man speaking.'
	"

	^ self new
		pitch: 90.0;
		range: 0.5;
		voice: (KlattVoice new tract: 20)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:19'!
breathy
	"
	Speaker breathy say: 'This is my breathy voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.6; turbulence: 70)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:07'!
child
	"
	Speaker child say: 'Hello. I am a child speaking.'
	"

	^ self new
		pitch: 320.0;
		voice: (KlattVoice new tract: 12)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:21'!
creaky
	"
	Speaker creaky say: 'This is my creaky voice with hight jitter and shimmer.'
	"

	^ self new
		pitch: 90.0;
		speed: 0.5;
		voice: (KlattVoice new jitter: 0.5; shimmer: 0.5)! !

!Speaker class methodsFor: 'examples' stamp: 'len 11/27/2000 10:01'!
default
	"
	Speaker default say: 'This is the default voice.'
	"

	^ self new voice: KlattVoice new! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:13'!
exorsist
	"
	Speaker exorsist say: 'This is an scary voice. Boo.'
	"

	^ self new
		pitch: 40.0;
		speed: 0.5;
		voice: (KlattVoice new tract: 10; diplophonia: 0.4; jitter: 0.3; shimmer: 0.5; turbulence: 50)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:13'!
fly
	"
	Speaker fly say: 'Haaaaaalp.'
	"

	^ self new
		pitch: 650.0;
		loudness: 0.5;
		speed: 0.8;
		voice: (KlattVoice new flutter: 1.0; tract: 1)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:01'!
kid
	"
	Speaker kid say: 'Do you like my voice? I am the kid speaking.'
	"

	^ self new
		pitch: 170.0;
		range: 0.4;
		voice: (KlattVoice new tract: 16)! !

!Speaker class methodsFor: 'examples' stamp: 'len 11/27/2000 10:01'!
man
	"
	Speaker man say: 'Listen to my voice. I am a man speaking.'
	"

	^ self default pitch: 90.0! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:26'!
notPressed
	"
	Speaker notPressed say: 'This is a non pressed voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.9)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:26'!
pressed
	"
	Speaker pressed say: 'This is a pressed voice.'
	"

	^ self new
		pitch: 100.0;
		voice: (KlattVoice new ro: 0.1)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 03:27'!
whispery
	"
	Speaker whispery say: 'This is my whispery voice.'
	"

	^ self new
		voice: (KlattVoice new breathiness: 1.0)! !

!Speaker class methodsFor: 'examples' stamp: 'len 12/14/1999 04:10'!
woman
	"
	Speaker woman say: 'Do you listen? I am a woman speaking.'
	"

	^ self new
		pitch: 230.0;
		range: 0.5;
		speed: 0.7;
		voice: (KlattVoice new flutter: 0.5; ro: 0.3; ra: 0.003; tract: 14.4)! !


!Speaker class methodsFor: 'examples-others' stamp: 'len 12/2/1999 03:46'!
manWithEditor
	"
	Speaker manWithEditor say: 'With this editor you can change my voice.'
	"

	^ self man edit! !

!Speaker class methodsFor: 'examples-others' stamp: 'len 12/14/1999 05:10'!
manWithHead
	"
	Speaker manWithHead say: 'This is my voice. Can you see my lips?'
	"

	^ self man newHead! !
Morph subclass: #SpeakerMorph
	instanceVariableNames: 'bufferSize buffer lastConePosition sound '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!

!SpeakerMorph methodsFor: 'initialization' stamp: 'di 2/17/2000 20:33'!
addGraphic

	| graphic |
	graphic _ SketchMorph withForm: self speakerGraphic.
	graphic position: bounds center - (graphic extent // 2).
	self addMorph: graphic.
! !

!SpeakerMorph methodsFor: 'initialization' stamp: 'jm 4/22/1999 23:00'!
initialize

	super initialize.
	self addGraphic.
	self color: (Color r: 1.0 g: 0.484 b: 0.258).
	bufferSize _ 5000.
	buffer _ WriteStream on: (SoundBuffer newMonoSampleCount: bufferSize).
	lastConePosition _ 0.
	sound _ SequentialSound new.
! !

!SpeakerMorph methodsFor: 'initialization' stamp: 'jm 4/22/1999 22:58'!
speakerGraphic

	^ Form
		extent: 19@18
		depth: 8
		fromArray: #(0 0 1493172224 2816 0 0 0 1493172224 11 0 0 138 1493172224 184549376 184549376 0 35509 2315255808 720896 720896 0 9090522 2315255808 2816 720896 0 2327173887 2315255819 2816 720896 138 3051028442 2315255819 2816 2816 1505080590 4294957786 2315255808 184549387 2816 3053453311 4292532917 1493172224 184549387 2816 1505080714 3048584629 1493172224 184549387 2816 9079434 3048584629 1493172224 184549387 2816 138 2327164341 1493172235 2816 2816 0 2324346293 1493172235 2816 720896 0 9079477 1493172224 2816 720896 0 35466 1493172224 720896 720896 0 138 0 184549376 184549376 0 0 0 11 0 0 0 0 2816 0)
		offset: 0@0
! !



!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 16:45'!
appendSample: aFloat
	"Append the given sample, a number between -100.0 and 100.0, to my buffer. Flush the buffer if it is full."

	lastConePosition _ aFloat.
	lastConePosition > 100.0 ifTrue: [lastConePosition _ 100.0].
	lastConePosition < -100.0 ifTrue: [lastConePosition _ -100.0].
	buffer nextPut: (327.67 * lastConePosition) truncated.
	buffer position >= bufferSize ifTrue: [self flushBuffer].
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/21/1999 10:18'!
conePosition

	^ lastConePosition
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 16:46'!
conePosition: aNumber

	self appendSample: aNumber asFloat.  "sets lastConePosition"
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 13:29'!
flushBuffer

	| buf |
	buf _ buffer contents.
	buffer resetContents.
	sound isPlaying ifFalse: [sound _ SequentialSound new].
	sound add: (SampledSound samples: buf samplingRate: 11025).
	sound isPlaying
		ifTrue: [sound pruneFinishedSounds]
		ifFalse: [sound play].
! !

!SpeakerMorph methodsFor: 'speaker' stamp: 'jm 4/22/1999 15:33'!
stopSound

	sound pause.
	buffer resetContents.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SpeakerMorph class
	instanceVariableNames: ''!

!SpeakerMorph class methodsFor: 'scripting' stamp: 'sw 9/18/2000 09:58'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^  #((speaker

((slot conePosition  'the position of the speaker cone' number readWrite player getConePosition player setConePosition:))))



! !
AlignmentMorph subclass: #SpectrumAnalyzerMorph
	instanceVariableNames: 'soundInput statusLight levelMeter graphMorph sonogramMorph fft displayType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!
!SpectrumAnalyzerMorph commentStamp: '<historical>' prior: 0!
I am a tool for analyzing sound data from a microphone, CD, or other input source in real time. I have several display modes:

	signal		snapshots of the raw signal data as it arrives
	spectrum	frequency spectrum of the signal data as it arrives
	sonogram	scrolling plot of the frequency spectrum over time,
			      where the vertical axis is frequency, the horizontal
				  axis is time, and amount of energy at a given
				  frequency is shown as a grayscale value with
				  larger values being darker

To use this tool, be sure that you have selected the proper sound source using you host OS facilities. Set the desired sampling rate and FFT size (try 22050 samples/sec and an FFT size of 512) then click on the 'start' button. Use the slider to adjust the level so that the yellow level indicator peaks somewhere between the middle and the right edge at the maximum signal level.

Note that if the level meter peaks hit the right edge, you will get 'clipping', which creates a bunch of spurious high frequency noise in the frequency spectrum. If the display is set to 'signal' mode, you can actually see the tops and bottoms of the waveform being cut off when clipping occurs.

Many machines may not be able to perform spectrum analysis in real time, especially at higher sampling rates and larger FFT sizes. In both 'signal' and 'spectrum' modes, this tool will skip data to try to keep up with real time. However, in 'sonogram' mode it always processes all the data, even if it falls behind. This allows you to get a complete sonogram without dropouts even on a slower machine. However, as the sonogram display falls behind there will be a larger and larger time lag between when a sound is input and when it appears on the display.

The smaller the FFT size, the less frequency resolution you get. The lower the sampling rate, the less total frequency range you get. For an FFT size of N and a sampling rate of R, each of the N/2 'bins' of the frequency spectrum has a frequency resolution of R / N. For example, at a sampleing rate of 22050 samples/second, the total frequency range is 0 to 11025 Hz and an FFT of size 256 would divide this range into 128 bins (the output of an FFT of size N has N/2 bins), each of which covers a frequency band about 86 Hz wide.

To increase time resolution, increase the sampling rate and decrease the FFT size.
!


!SpectrumAnalyzerMorph methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:58'!
initialize

	super initialize.
	borderWidth _ 2.
	self listDirection: #topToBottom.
	soundInput _ SoundInputStream new samplingRate: 22050.
	fft _ FFT new: 512.
	displayType _ 'sonogram'.

	self addButtonRow.
	self addLevelSlider.
	self addMorphBack: self makeLevelMeter.
	self addMorphBack: (Morph new extent: 10@10; color: Color transparent).  "spacer"
	self resetDisplay.  "adds the display morph"
! !


!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:11'!
invokeMenu
	"Invoke the settings menu."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	#(
		('set sampling rate'		setSamplingRate)
		('set FFT size'			setFFTSize)
		('set display type'		setDisplayType)).
	aMenu invokeOn: self defaultSelection: nil.
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 12:52'!
resetDisplay
	"Recreate my display after changing some parameter such as FFT size."

	displayType = 'signal' ifTrue: [self showSignal].
	displayType = 'spectrum' ifTrue: [self showSpectrum].
	displayType = 'sonogram' ifTrue: [self showSonogram].
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'!
setDisplayType
	"Set the display type."

	| aMenu choice on |
	aMenu _ CustomMenu new title: 'display type (currently ', displayType, ')'.
	aMenu addList:	#(
		('signal'	'signal')
		('spectrum'	'spectrum')
		('sonogram'	'sonogram')).
	choice _ aMenu startUp.
	choice ifNil: [^ self].

	on _ soundInput isRecording.
	self stop.
	displayType _ choice.
	self resetDisplay.
	on ifTrue: [self start].

! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 19:38'!
setFFTSize
	"Set the size of the FFT used for frequency analysis."

	| aMenu sz on |
	aMenu _ CustomMenu new title: 'FFT size (currently ', fft n printString, ')'.
	((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r].
	sz _ aMenu startUp.
	sz ifNil: [^ self].
	on _ soundInput isRecording.
	self stop.
	fft _ FFT new: sz.
	self resetDisplay.
	on ifTrue: [self start].
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'!
setSamplingRate
	"Set the sampling rate to be used for incoming sound data."

	| aMenu rate on |
	aMenu _ CustomMenu new title:
		'Sampling rate (currently ', soundInput samplingRate printString, ')'.
	#(11025 22050 44100) do:[:r | aMenu add: r printString action: r].
	rate _ aMenu startUp.
	rate ifNil: [^ self].
	on _ soundInput isRecording.
	self stop.
	soundInput samplingRate: rate.
	self resetDisplay.
	on ifTrue: [self start].

! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'!
start
	"Start displaying sound data."

	displayType = 'signal'
		ifTrue: [soundInput bufferSize: graphMorph width - (2 * graphMorph borderWidth)]
		ifFalse: [soundInput bufferSize: fft n].
	soundInput startRecording.
! !

!SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'!
stop
	"Stop displaying sound data."

	soundInput stopRecording.
! !


!SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/8/1999 19:05'!
step
	"Update the record light, level meter, and display."

	| w |
	"update the record light and level meter"
	soundInput isRecording
		ifTrue: [statusLight color: Color yellow]
		ifFalse: [statusLight color: Color gray].
	w _ ((121 * soundInput meterLevel) // 100) max: 1.
	levelMeter width ~= w ifTrue: [levelMeter width: w].

	"update the display if any data is available"
	self updateDisplay.
! !

!SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/7/1999 22:26'!
stepTime

	^ 0
! !

!SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/6/1999 12:12'!
stopStepping
	"Turn off recording."

	super stopStepping.
	soundInput stopRecording.
! !


!SpectrumAnalyzerMorph methodsFor: 'deletion' stamp: 'jm 9/6/1999 14:40'!
delete
	"Turn off recording when this morph is deleted."

	super delete.
	soundInput stopRecording.
! !


!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 12:44'!
addButtonRow

	| r |
	r _ AlignmentMorph newRow vResizing: #shrinkWrap.
	r addMorphBack: (self buttonName: 'Menu' action: #invokeMenu).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Start' action: #start).
	r addMorphBack: (Morph new extent: 4@1; color: Color transparent).
	r addMorphBack: (self buttonName: 'Stop' action: #stop).
	r addMorphBack: (Morph new extent: 12@1; color: Color transparent).
	r addMorphBack: self makeStatusLight.
	self addMorphBack: r.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'ar 11/9/2000 21:23'!
addLevelSlider

	| levelSlider r |
	levelSlider _ SimpleSliderMorph new
		color: color;
		extent: 100@2;
		target: soundInput;
		actionSelector: #recordLevel:;
		adjustToValue: soundInput recordLevel.
	r _ AlignmentMorph newRow
		color: color;
		layoutInset: 0;
		wrapCentering: #center; cellPositioning: #leftCenter;
		hResizing: #shrinkWrap;
		vResizing: #rigid;
		height: 24.
	r addMorphBack: (StringMorph contents: '0 ').
	r addMorphBack: levelSlider.
	r addMorphBack: (StringMorph contents: ' 10').
	self addMorphBack: r.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jhm 10/15/97 14:30'!
buttonName: aString action: aSymbol

	^ SimpleButtonMorph new
		target: self;
		label: aString;
		actionSelector: aSymbol
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 13:27'!
makeLevelMeter

	| outerBox |
	outerBox _ RectangleMorph new extent: 125@14; color: Color lightGray.
	levelMeter _ Morph new extent: 2@10; color: Color yellow.
	levelMeter position: outerBox topLeft + (2@2).
	outerBox addMorph: levelMeter.
	^ outerBox
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 13:02'!
makeStatusLight

	| s |
	statusLight _ RectangleMorph new extent: 24@19.
	statusLight color: Color gray.
	s _ StringMorph contents: 'On'.
	s position: statusLight center - (s extent // 2).
	statusLight addMorph: s.
	^ statusLight
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 18:41'!
processBuffer: buf
	"Analyze one buffer of data."

	| data |
	displayType = 'signal'
		ifTrue: [data _ buf]
		ifFalse: [data _ fft transformDataFrom: buf startingAt: 1].
	graphMorph ifNotNil: [graphMorph data: data; changed].
	sonogramMorph ifNotNil: [
		data _ data collect: [:v | v sqrt].  "square root compresses dynamic range"
		data /= 400.0.
		sonogramMorph plotColumn: (data copyFrom: 1 to: data size // 1)].
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 12:49'!
removeAllDisplays
	"Remove all currently showing displays."

	sonogramMorph ifNotNil: [sonogramMorph delete].
	graphMorph ifNotNil: [graphMorph delete].
	sonogramMorph _ graphMorph _ nil.
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:56'!
showSignal
	"Display the actual signal waveform."

	displayType _ 'signal'.
	self removeAllDisplays.
	graphMorph _ GraphMorph new.
	graphMorph extent: (400 + (2 * graphMorph borderWidth))@128.
	graphMorph data: (Array new: 100 withAll: 0).
	graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0).
	self addMorphBack: graphMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:43'!
showSonogram
	"Display a sonogram showing the frequency spectrum versus time."

	| zeros h w |
	displayType _ 'sonogram'.
	self removeAllDisplays.
	h _ fft n // 2.
	h _ h min: 512 max: 64.
	w _ 400.
	sonogramMorph _
		Sonogram new
			extent: w@h
			minVal: 0.0
			maxVal: 1.0
			scrollDelta: w.
	zeros _ Array new: sonogramMorph height withAll: 0.
	sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros].
	self addMorphBack: sonogramMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 15:10'!
showSpectrum
	"Display the frequency spectrum."

	displayType _ 'spectrum'.
	self removeAllDisplays.
	graphMorph _ GraphMorph new.
	graphMorph extent: ((fft n // 2) + (2 * graphMorph borderWidth))@128.
	graphMorph data: (Array new: fft n // 2 withAll: 0).
	self addMorphBack: graphMorph.
	self extent: 10@10.  "shrink to minimum size"
! !

!SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:39'!
updateDisplay
	"Update the display if any data is available."

	| buf bufCount |
	soundInput bufferCount = 0 ifTrue: [^ self].

	graphMorph ifNotNil: [
		[soundInput bufferCount > 0] whileTrue: [
			"skip to the most recent buffer"
			buf _ soundInput nextBufferOrNil].
		^ self processBuffer: buf].

	sonogramMorph ifNotNil: [
		"at small buffer sizes we have to update the sonogram in
		 batches or we may get behind; shoot for 8 updates/second"
		bufCount _ (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1.
		[bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [
			self processBuffer: (soundInput nextBufferOrNil)]].
! !
Path subclass: #Spline
	instanceVariableNames: 'coefficients '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Paths'!
!Spline commentStamp: '<historical>' prior: 0!
I represent a collection of Points through which a cubic spline curve is fitted.!


!Spline methodsFor: 'accessing'!
coefficients
	"Answer an eight-element Array of Arrays each of which is the length 
	of the receiver. The first four arrays are the values, first, second and 
	third derivatives, respectively, for the parametric spline in x. The last 
	four elements are for y."

	^coefficients! !


!Spline methodsFor: 'displaying'!
computeCurve
	"Compute an array for the coefficients."

	| length extras |
	length _ self size.
	extras _ 0.
	coefficients _ Array new: 8.
	1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)].
	1 to: 5 by: 4 do: 
		[:k | 
		1 to: length do:
			[:i | (coefficients at: k)
					at: i put: (k = 1
						ifTrue: [(self at: i) x asFloat]
						ifFalse: [(self at: i) y asFloat])].
			1 to: extras do: [:i | (coefficients at: k)
					at: length + i put: ((coefficients at: k)
						at: i + 1)].
			self derivs: (coefficients at: k)
				first: (coefficients at: k + 1)
				second: (coefficients at: k + 2)
				third: (coefficients at: k + 3)].
	extras > 0 
		ifTrue: [1 to: 8 do: 
					[:i | 
					coefficients at: i put: ((coefficients at: i)
											copyFrom: 2 to: length + 1)]]! !

!Spline methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the receiver, a spline curve, approximated by straight line
	segments."

	| n line t x y x1 x2 x3 y1 y2 y3 |
	collectionOfPoints size < 1 ifTrue: [self error: 'a spline must have at least one point'].
	line _ Line new.
	line form: self form.
	line beginPoint: 
		(x _ (coefficients at: 1) at: 1) rounded @ (y _ (coefficients at: 5) at: 1) rounded.
	1 to: (coefficients at: 1) size - 1 do: 
		[:i | 
		"taylor series coefficients"
		x1 _ (coefficients at: 2) at: i.
		y1 _ (coefficients at: 6) at: i.
		x2 _ ((coefficients at: 3) at: i) / 2.0.
		y2 _ ((coefficients at: 7) at: i) / 2.0.
		x3 _ ((coefficients at: 4) at: i) / 6.0.
		y3 _ ((coefficients at: 8) at: i) / 6.0.
		"guess n"
		n _ 5 max: (x2 abs + y2 abs * 2.0 + ((coefficients at: 3)
							at: i + 1) abs + ((coefficients at: 7)
							at: i + 1) abs / 100.0) rounded.
		1 to: n - 1 do: 
			[:j | 
			t _ j asFloat / n.
			line endPoint: 
				(x3 * t + x2 * t + x1 * t + x) rounded 
							@ (y3 * t + y2 * t + y1 * t + y) rounded.
			line
				displayOn: aDisplayMedium
				at: aPoint
				clippingBox: clipRect
				rule: anInteger
				fillColor: aForm.
			line beginPoint: line endPoint].
		line beginPoint: 
				(x _ (coefficients at: 1) at: i + 1) rounded 
					@ (y _ (coefficients at: 5) at: i + 1) rounded.
		line
			displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!Spline methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Get the scaled and translated path of newKnots."

	| newKnots newSpline |
	newKnots _ aTransformation applyTo: self.
	newSpline _ Spline new.
	newKnots do: [:knot | newSpline add: knot].
	newSpline form: self form.
	newSpline
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !


!Spline methodsFor: 'private'!
derivs: a first: point1 second: point2 third: point3
	"Compute the first, second and third derivitives (in coefficients) from
	the Points in this Path (coefficients at: 1 and coefficients at: 5)."

	| l v anArray |
	l _ a size.
	l < 2 ifTrue: [^self].
	l > 2
	  ifTrue:
		[v _ Array new: l.
		 v  at:  1 put: 4.0.
		 anArray _ Array new: l.
		 anArray  at:  1 put: (6.0 * ((a  at:  1) - ((a  at:  2) * 2.0) + (a  at:  3))).
		 2 to: l - 2 do:
			[:i | 
			v  at:  i put: (4.0 - (1.0 / (v  at:  (i - 1)))).
			anArray
				at:  i 
				put: (6.0 * ((a  at:  i) - ((a  at:  (i + 1)) * 2.0) + (a  at:  (i + 2)))
						- ((anArray  at:  (i - 1)) / (v  at:  (i - 1))))].
		 point2  at: (l - 1) put: ((anArray  at:  (l - 2)) / (v  at:  (l - 2))).
		 l - 2 to: 2 by: 0-1 do: 
			[:i | 
			point2 
				at: i 
				put: ((anArray  at:  (i - 1)) - (point2  at:  (i + 1)) / (v  at:  (i - 1)))]].
	point2 at: 1 put: (point2  at:  l put: 0.0).
	1 to: l - 1 do:
		[:i | point1 
				at: i 
				put: ((a at: (i + 1)) - (a  at:  i) - 
						((point2  at:  i) * 2.0 + (point2  at:  (i + 1)) / 6.0)).
		      point3 at: i put: ((point2  at:  (i + 1)) - (point2  at:  i))]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Spline class
	instanceVariableNames: ''!

!Spline class methodsFor: 'examples' stamp: '6/8/97 13:55 di'!
example
	"Designate points on the Path by clicking the red button. Terminate by
	pressing any other button. A curve will be displayed, through the
	selected points, using a long black form."

	| splineCurve aForm flag|
	aForm _ Form extent: 2@2.
	aForm  fillBlack.
	splineCurve _ Spline new.
	splineCurve form: aForm.
	flag _ true.
	[flag] whileTrue:
		[Sensor waitButton.
		 Sensor redButtonPressed
			ifTrue: 
				[splineCurve add: Sensor waitButton. 
				 Sensor waitNoButton.
				 aForm displayOn: Display at: splineCurve last]
			ifFalse: [flag_false]].
	splineCurve computeCurve.
	splineCurve isEmpty 
		ifFalse: [splineCurve displayOn: Display.
				Sensor waitNoButton].
 
	"Spline example"! !
Object subclass: #SqueakPage
	instanceVariableNames: 'url title comment thumbnail contentsMorph creationTime creationAuthor lastChangeTime lastChangeAuthor policy dirty '
	classVariableNames: 'MaxThumbnailWidthOrHeight RecentMaxNum RecentStem '
	poolDictionaries: ''
	category: 'Network-SqueakPage'!
!SqueakPage commentStamp: '<historical>' prior: 0!
A SqueakPage is holder for a page of morphs that live on the disk or on a server.
A URLMorph is a thumbnail sized stand-in for the page.  Clicking on it gets the page.
An ObjectOut is a fake object that stands for an object that is out on the disk.  (Like ObjectTracer or ObjectViewer.)
A MorphObjectOut is a subclass that stands for a Morph that is out on the disk.

To find out how to make the pages of any BookMorph go out to the disk (or a server), see 	http://minnow.cc.gatech.edu/SqueakDoc.1 then go to 'SqueakPages'.

A SqueakPage is always in-memory.  Its contentsMorph will be 'become-ed' to a MorphObjectOut tombstone when it goes out.  (A page may or may not be in the cache.  First put it in, then ask it for the data.)  Sending any message to the contentsMorph triggers the fetch.  Many URLMorphs may hold onto one page.  A page has a thumbnail.  A URLMorph points at its page object.

States of a SqueakPage, and the transitions to another state:
1) have a url as a string.  Then: (URLMorph grabURL: 'file://Ted''s/books/tryThis/p1').  
	Drop it into any morph.
2) have a URLMorph, with page==nil.     Click it.  (makes an empty page, installs 
	it in the global page cache)
3) have a URLMorph with a SqueakPage, with contentsMorph==nil, 
	but page is not in the cache (this is a rare case).  ask page contentsMorph.
4) OUT: have a URLMorph with a SqueakPage, with contentsMorph being a MorphObjectOut, 
	and its page is in the cache.  Sending the contentsMorph any message brings it in and
	becomes it to the morph.  (fix up morph's pointer to the page.)
5) Totally IN:  a morph, owned by a SqueakPage, has a page in the cache.  
	The morph is clean.   
	Whenever someone triggers a purge (when?), contentsMorph is becomed
	to a MorphObjectOut. (go to 4)
	Causing the morph to execute layoutChanged marks the morph as dirty.
	(morph's property #pageDirty is set to true) (go to 6)
6) Totally IN and dirty.  
	Whenever any other page is fetched from the disk or the net, all other 
	dirty pages are written and marked clean.  (go to 5)

Note that the entire tree of submorphs goes out -- hundreds of objects.  Bringing the object back in brings in the SqueakPage, installs it in the cache.  Classes other than PasteUpMorph can easily be made to send their contents out if there is any need.

Note that every book is now automatically a WebBook.  We simply give a page a url and tell it to purge.

url		a string
title		
comment		
thumbnail		
contentsMorph		(1) a pasteUpMorph with other morphs in it.
					(2) a MorphObjectOut.  Sending any message brings it in. 
					(3) nil if the page has never been in this image.
creationTime		
creationAuthor		
lastChangeTime		
lastChangeAuthor 
policy		#alwaysWrite, #neverWrite, #ask.  (cache can override with a global policy)
			(Explicit writing by user has policy #neverWrite)
dirty 		(Morph>>layoutChanged sends changed: #SqueakPage. If policy==#check, 
				then the page sets dirty_true.)
			(If policy==#alwaysWrite, then set dirty when the page is retrieved from the cache.)

Class MorphObjectOut has an instance variable called page.
All messages to an MorphObjectOut cause it to be brought in.  Except the messages needed to write the MorphObjectOut on the disk as part of a parent's being sent out.  (size, class, instSize, instVar:at:.  Can rename these and call from its own version of the writing routine.)
	To purge, go through the clean pages, and any that have world not equal to this world, entomb them.  
	(If an object in the subtree is held by an object outside the tree, it will remain,  And will be duplicated when the tree comes back in.  This is a problem already in normal uses of SmartRefStream.)


!
]style[(458 39 3184)f1,f1Rhttp://minnow.cc.gatech.edu/SqueakDoc.1;,f1!


!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/5/1999 16:47'!
asMorph
	^ self fetchContents! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 13:47'!
comment

	comment ifNil: [^ ''] ifNotNil: [^ comment].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:12'!
comment: aString

	aString isEmpty
		ifTrue: [comment _ nil]
		ifFalse: [comment _ aString].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/2/1998 11:27'!
contentsMorph
	"Return what it is now.  If the morph is out on the disk, return nil.  Use fetchContents to get the data for sure."

	^ contentsMorph
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 11/11/1998 12:54'!
contentsMorph: aPasteUpMorph

	contentsMorph _ aPasteUpMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/23/1999 14:39'!
copyForSaving
	"Make a copy and configure me to be put out on the disk.  When it is brought in and touched, it will turn into the object at the url."

	| forDisk holder |
	forDisk _ self clone.
	holder _ MorphObjectOut new xxxSetUrl: url page: forDisk.
	forDisk contentsMorph: holder.
	^ holder		"directly representing the object"! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/30/1998 15:08'!
fetchContents
	"Make every effort to get contentsMorph."

	self isContentsInMemory ifTrue: [^ contentsMorph].
	^ self fetchInformIfError! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/2/1998 11:48'!
fetchContentsIfAbsent: failBlock
	"Make every effort to get contentsMorph.  Assume I am in the cache already."
	| strm page temp temp2 |
	SqueakPageCache write.		"sorry about the pause"
	Cursor wait showWhile: [
		strm _ (ServerFile new fullPath: url) asStream].
	strm class == String ifTrue: [^ failBlock value].		
	page _ strm fileInObjectAndCode.
	page isMorph ifTrue: [contentsMorph _ page].	"may be a bare morph"
	"copy over the state"
	temp _ url.
	temp2 _ policy.
	self copyAddedStateFrom: page.
	url _ temp.	"don't care what it says"
	temp2 ifNotNil: [policy _ temp2].		"use mine"
	contentsMorph setProperty: #pageDirty toValue: nil.
	self dirty: false.
	^ contentsMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 12/10/1998 11:46'!
fetchInformIfError
	"Make every effort to get contentsMorph.  Put up a good notice if can't get it.  Assume page is in the cache already.  Overwrite the contentsMorph no matter what."
	| strm page temp temp2 |

	SqueakPageCache write.		"sorry about the pause"
	Cursor wait showWhile: [
		strm _ (ServerFile new fullPath: url) asStream].
	strm class == String ifTrue: [self inform: 'Sorry, ',strm. ^ nil].	"<<<<< Note Diff"
	(url beginsWith: 'file:') ifTrue: [Transcript show: 'Fetching  ', url; cr].	
	page _ strm fileInObjectAndCode.
	page isMorph 
		ifTrue: [contentsMorph _ page]	"may be a bare morph"
		ifFalse: ["copy over the state"
			temp _ url.
			temp2 _ policy.
			self copyFrom: page.	"including contentsMorph"
			url _ temp.	"I know best!!"
			temp2 ifNotNil: [policy _ temp2]].		"use mine"
	contentsMorph setProperty: #pageDirty toValue: nil.
	contentsMorph setProperty: #SqueakPage toValue: self.
	self dirty: false.
	^ contentsMorph! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 10/30/1998 15:08'!
isContentsInMemory
	"Is my contentsMorph in memory, or is it an ObjectOut tombstone?  Be careful not to send it any message."

	^ (contentsMorph xxxClass inheritsFrom: Object) and: [(contentsMorph == nil) not]! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 12/4/1998 01:00'!
lastChangeTime
	^ lastChangeTime! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 2/24/1999 12:06'!
saveMorph: aMorph author: authorString
	"Save the given morph as this page's contents. Update its thumbnail and inform references to this URL that the page has changed."
	"Details: updateThumbnail releases the cached state of the saved page contents after computing the thumbnail."

	| n |
	contentsMorph _ aMorph.
	n _ aMorph knownName.
	n ifNotNil: [self title: n].
	creationAuthor ifNil: [
		creationAuthor _ authorString.
		creationTime _ Time totalSeconds].
"	lastChangeAuthor _ authorString.
	lastChangeTime _ Time totalSeconds.	do it when actually write"
	self computeThumbnail.
	self postChangeNotification.
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 17:45'!
thumbnail

	^ thumbnail
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 13:47'!
title

	title ifNil: [^ ''] ifNotNil: [^ title].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:12'!
title: aString

	aString isEmpty
		ifTrue: [title _ nil]
		ifFalse: [title _ aString].
! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 11/4/1998 20:34'!
url

	^ url! !

!SqueakPage methodsFor: 'accessing' stamp: 'tk 1/14/1999 23:50'!
url: aString

	| sd |
	aString isEmpty ifTrue: [url _ nil. ^ self].

	"Expand ./ and store as an absolute url"
	sd _ ServerFile new.
	sd fullPath: aString.
	url _ sd realUrl.! !


!SqueakPage methodsFor: 'private' stamp: 'tk 2/25/1999 09:13'!
computeThumbnail
	"Make a thumbnail from my morph."

	(contentsMorph isKindOf: PasteUpMorph) 
		ifTrue: [thumbnail _ contentsMorph smallThumbnailForPageSorter]
		ifFalse: [self updateThumbnail]! !

!SqueakPage methodsFor: 'private' stamp: 'tk 6/24/1999 11:42'!
postChangeNotification
	"Inform all thumbnails and books that this page has been updated."

	URLMorph allSubInstancesDo: [:m | m pageHasChanged: self].
! !

!SqueakPage methodsFor: 'private' stamp: 'jm 6/18/1998 11:31'!
updateThumbnail
	"Update my thumbnail from my morph."

	| f scale scaleX scaleY shrunkF |
	contentsMorph ifNil: [thumbnail _ nil. ^ self].
	f _ contentsMorph imageForm.
	scaleX _ MaxThumbnailWidthOrHeight asFloat / f height.
	scaleY _ MaxThumbnailWidthOrHeight asFloat/ f width.
	scale _ scaleX min: scaleY.  "choose scale that maintains aspect ratio"
	shrunkF _ (f magnify: f boundingBox by: scale@scale smoothing: 2).
	thumbnail _ Form extent: shrunkF extent depth: 8.  "force depth to be 8"
	shrunkF displayOn: thumbnail.
	contentsMorph allMorphsDo: [:m | m releaseCachedState].
! !


!SqueakPage methodsFor: 'saving' stamp: 'tk 9/30/1998 22:40'!
dirty: aBool
	dirty _ aBool! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 10/8/1998 13:18'!
policy
	^ policy! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 9/30/1998 22:39'!
policy: aSymbol
	policy _ aSymbol! !

!SqueakPage methodsFor: 'saving' stamp: 'RAA 5/25/2000 10:28'!
prePurge
	"Return self if ready to be purged, or nil if not"

	self isContentsInMemory ifFalse: [^ nil].
	contentsMorph ifNil: [^ nil].  "out already"
	url ifNil: [^ nil].	"just to be safe"
	^ (Display bestGuessOfCurrentWorld ~~ nil and: [contentsMorph world == Display bestGuessOfCurrentWorld]) 
		ifTrue: [nil "showing now"] ifFalse: [self]! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 12/16/1998 08:24'!
purge
	"Replace my morph with a tombstone, if I am not in a world that is being shown."

	(self prePurge) ifNotNil: [
		contentsMorph become: (MorphObjectOut new xxxSetUrl: url page: self)].
		"Simple, isn't it!!"! !

!SqueakPage methodsFor: 'saving' stamp: 'tk 1/23/1999 13:19'!
urlNoOverwrite: suggested
	"Look in the directory.  If there is a file of this name, create a new name.  Keep track of highest numbers used as a hint."

	| dir ll stem num local trial suffix |
	(suggested endsWith: '.sp') ifTrue: [suffix _ '.sp'].
	(suggested endsWith: '.bo') ifTrue: [suffix _ '.bo'].
	suffix ifNil: [self error: 'unknown suffix'].
	dir _ ServerFile new fullPath: suggested.
	(dir includesKey: dir fileName) ifFalse: [^ url _ suggested].
	"File already exists!!  Create a new name"
	"Find the stem file name"
	stem _ SqueakPage stemUrl: suggested.
	num _ stem = RecentStem ifTrue: [RecentMaxNum+1] ifFalse: [1].

	local _ dir fileName.	"ugh, take stem again..."
	ll _ local findLast: [:char | char == $.].
	ll = 0 ifFalse: [local _ local copyFrom: 1 to: ll-1].	"remove .sp"
	local _ (local splitInteger) at: 1.		"remove trailing number"
	local last == $x ifFalse: [local _ local , 'x'].
	[trial _ local, num printString, suffix.
		dir includesKey: trial] whileTrue: [num _ num + 1].
	RecentStem _ stem.  RecentMaxNum _ num.
	^ url _ stem, 'x', num printString, suffix! !

!SqueakPage methodsFor: 'saving' stamp: 'RAA 8/30/2000 11:43'!
write
	"Decide whether to write this page on the disk."
	| sf remoteFile |
	policy == #neverWrite ifTrue: [^ self].
		"demo mode, or write only when user explicitly orders it"

	"All other policies do write:   #now"
	contentsMorph ifNil: [^ self].
	dirty _ dirty | ((contentsMorph valueOfProperty: #pageDirty) == true).
		"set by layoutChanged"
	dirty == true ifTrue: [ 
		sf _ ServerDirectory new fullPath: url.
		"check for shared password"
		"contentsMorph allMorphsDo: [:m | m prepareToBeSaved].
				done in objectToStoreOnDataStream"
		lastChangeAuthor _ Utilities authorInitialsPerSe ifNil: ['*'].
		lastChangeTime _ Time totalSeconds.
		Cursor wait showWhile: [
			remoteFile _ sf fileNamed: url.	"no notification when overwriting"
			remoteFile dataIsValid.
			remoteFile fileOutClass: nil andObject: self.
			"remoteFile close"].
		contentsMorph setProperty: #pageDirty toValue: nil.
		dirty _ false].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SqueakPage class
	instanceVariableNames: ''!

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'jm 6/18/1998 11:15'!
initialize
	"SqueakPage initialize"

	MaxThumbnailWidthOrHeight _ 60.
! !

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 11:49'!
newURLAndPageFor: aMorph
	"Create a new SqueakPage whose contents is the given morph. Assign a URL for that page, record it in the page cache, and answer its URL."

	| pg newURL stamp |
	pg _ self new.
	stamp _ Utilities authorInitialsPerSe ifNil: ['*'].
	pg saveMorph: aMorph author: stamp.
	newURL _ SqueakPageCache generateURL.
	SqueakPageCache atURL: newURL put: pg.
	^ newURL 
! !

!SqueakPage class methodsFor: 'as yet unclassified' stamp: 'tk 1/15/1999 08:13'!
stemUrl: aUrlString
	"Peel off the 'x5.sp'  or '.bo' from the end of a url of a SqueakPage or a BookMorph index file"

	| ll aUrl |
	ll _ aUrlString findLast: [:char | char == $.].
	ll = 0 
		ifTrue: [aUrl _ aUrlString]
		ifFalse: [aUrl _ aUrlString copyFrom: 1 to: ll-1].	"remove .sp"
	aUrl _ (aUrl stemAndNumericSuffix) at: 1.
			"remove trailing number"
	aUrl size = 0 ifTrue: [^ aUrl].	"empty"
	[aUrl last == $x] whileTrue: [aUrl _ aUrl allButLast].
	^ aUrl! !
Object subclass: #SqueakPageCache
	instanceVariableNames: ''
	classVariableNames: 'GlobalPolicy PageCache '
	poolDictionaries: ''
	category: 'Network-SqueakPage'!
!SqueakPageCache commentStamp: '<historical>' prior: 0!
A global cache of web pages known to this Squeak image.  Since there is a single, global page cache, it is implemented entirely as class methods.

Once a page has an entry, keep it.  (url string -> A SqueakPage)  The SqueakPage has a thumbnail and other info, but may not have the contentsMorph.  The morph is purged when space is needed, and fetched from the server as needed.

See SqueakPage's comment for the stages of in/out.!
]style[(383 10 36)f1,f1LSqueakPage Comment;,f1!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SqueakPageCache class
	instanceVariableNames: ''!

!SqueakPageCache class methodsFor: 'class initialization' stamp: 'tk 11/24/1998 14:53'!
initialize
	"SqueakPageCache initialize"

	GlobalPolicy _ #neverWrite.
	PageCache _ Dictionary new: 100.
		"forgets urls of pages, but ObjectOuts still remember them"
! !


!SqueakPageCache class methodsFor: 'cache access' stamp: 'jm 6/25/1998 11:06'!
allURLs
	"Answer a collection of URLs for all pages in the cache."

	^ PageCache keys

! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/2/1998 12:07'!
atURL: aURLString
	"Answer the page corresponding to this URL. Evaluate the given block if there is no entry for the given URL."

	| pg |
	^ PageCache at: aURLString ifAbsent: [
		pg _ SqueakPage new.
		"stamp _ Utilities authorInitialsPerSe ifNil: ['*']."
		"pg author: stamp."
		"Need to deal with inst vars if we turn out to be new!!"
		"pg url: aURLString. 	done by atURL:put:"
		self atURL: aURLString put: pg.
		pg]
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/2/1998 12:06'!
atURL: aURLString ifAbsent: failBlock
	"Answer the page corresponding to this URL. Evaluate the given block if there is no entry for the given URL."

	self halt.  "use atURL:"
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/20/1998 15:51'!
atURL: aURLString oldPage: aPage
	"Bring in page and return the object.  First try looking up my url in the pageCache.  Then try the page (and install it, under its url).  Then start from scratch with the url."

	| myPage |
	(myPage _ PageCache at: aURLString ifAbsent: [nil]) ifNotNil: [
		^ myPage].
	aPage url: aURLString.	"for consistancy"
	PageCache at: aPage url put: aPage.
	^ aPage! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 12/8/1998 21:51'!
atURL: aURLString put: aSqueakPage
	"Store the given page in the cache entry for the given URL."

	aSqueakPage url: aURLString.
	aSqueakPage contentsMorph isInMemory ifTrue: [
		aSqueakPage contentsMorph ifNotNil: [
			aSqueakPage contentsMorph setProperty: #SqueakPage 
				toValue: aSqueakPage]].
	PageCache at: aURLString put: aSqueakPage.
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/30/1998 15:08'!
doPagesInMemory: aBlock
	"Evaluate aBlock for each page whose contentsMorph is in-memory.  Don't add or remove pages while in this loop."

	PageCache do: [:sqkPage |
		sqkPage isContentsInMemory ifTrue: [aBlock value: sqkPage]].! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 11/24/1998 14:52'!
generateURL
	"Generate an unused URL for an in-memory page."
	"SqueakPageCache generateURL"

	| sd |
	sd _ ServerFile new on: 'file:./'.
	sd fileName: 'page1.sp'.
	^ SqueakPage new urlNoOverwrite: sd pathForFile
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/1/1998 13:02'!
includesMorph: aPasteUp

	PageCache do: [:squeakPage |
		squeakPage contentsMorph == aPasteUp ifTrue: [^ true]].
	^ false! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/20/1998 15:11'!
pageCache

	^ PageCache! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/1/1998 13:04'!
pageForMorph: aPasteUp

	PageCache do: [:squeakPage |
		squeakPage contentsMorph == aPasteUp ifTrue: [^ squeakPage]].
	^ nil! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 12/16/1998 08:30'!
purge
	"Replace morphs with tombstones in all pages that are clean and not being shown.  Write any dirty ones first, if allowed to."

	| list |
	list _ OrderedCollection new.
	GlobalPolicy == #neverWrite 
		ifTrue: [PageCache doPagesInMemory: [:aPage | list add: aPage prePurge]]
			"Writing only done by user's command"
		ifFalse: [
			PageCache doPagesInMemory: [:aPage | aPage write
					 list add: aPage prePurge]].
	list _ list select: [:each | each notNil].
	"do bulk become:"
	(list collect: [:each | each contentsMorph])
		elementsExchangeIdentityWith:
			(list collect: [:pg | MorphObjectOut new xxxSetUrl: pg url page: pg])
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/21/1998 13:28'!
purge: megs
	"Replace morphs with tombstones in all pages that are clean and not being shown.  Do this until megs of new memory have been recovered.  Write any dirty ones first, if allowed to."

	| goal |
	goal _ Smalltalk garbageCollect + (megs * 1000000) asInteger.
	PageCache doPagesInMemory: [:aPage | 
		GlobalPolicy == #neverWrite ifFalse: [aPage write].
		aPage purge.
		Smalltalk garbageCollect > goal ifTrue: [^ true]].	"got enough"
	^ false	"caller may want to tell the user to write out more pages"! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'jm 6/16/1998 18:12'!
removeURL: aURLString
	"Remove the cache entry for the given URL. Do nothing if it has no cache entry."

	PageCache removeKey: aURLString ifAbsent: [].
! !

!SqueakPageCache class methodsFor: 'cache access' stamp: 'tk 10/22/1998 11:07'!
write
	"Write out all dirty pages"
	GlobalPolicy == #neverWrite ifTrue: [^ self].
	self doPagesInMemory: [:aPage | aPage write].! !


!SqueakPageCache class methodsFor: 'housekeeping' stamp: 'tk 6/24/1999 11:42'!
deleteUnreferencedPages
	"Remove any pages that are not current referred to by any book or URL morph."
	"Details: Since unreferenced pages could refer to other pages, this process is iterated until no unreferenced pages can be found. It currently does not collect cycles."
	"SqueakPageCache deleteUnreferencedPages"

	| unreferenced |
	[true] whileTrue: [
		Smalltalk garbageCollect.
		unreferenced _ PageCache keys.
		URLMorph allSubInstancesDo: [:m | unreferenced remove: m url ifAbsent: []].
		MorphObjectOut allInstancesDo: [:ticklish |
			unreferenced remove: ticklish url ifAbsent: []].
		unreferenced size = 0 ifTrue: [^ self].
		unreferenced do: [:url | PageCache removeKey: url ifAbsent: []]].
! !

!SqueakPageCache class methodsFor: 'housekeeping' stamp: 'jm 6/25/1998 13:00'!
releaseCachedStateOfPages
	"Note: This shouldn't be necessary if we are doing a good job of releasing cached state as we go. If running this doesn't do very much, we're doing well!!"
	"SqueakPageCache releaseCachedStateOfPages"

	| memBytes |
	memBytes _ Smalltalk garbageCollect.
	PageCache do: [:pg |
		pg contentsMorph allMorphsDo: [:m | m releaseCachedState]].
	^ (Smalltalk garbageCollect - memBytes) printString, ' bytes recovered'
! !
Morph subclass: #SquishedNameMorph
	instanceVariableNames: 'target getSelector setSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:19'!
colorAroundName

	^Color gray: 0.8! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:17'!
drawOn: aCanvas

	| font stringToShow nameForm rectForName |

	super drawOn: aCanvas.
	self isEditingName ifTrue: [^self].

	font _ self fontForName.
	stringToShow _ self stringToShow.
	nameForm _ (StringMorph contents: stringToShow font: font) imageForm.
	nameForm _ nameForm scaledToSize: (self extent - (4@2) min: nameForm extent).
	rectForName _ self bottomLeft + 
			(self width - nameForm width // 2 @ (nameForm height + 2) negated)
				extent: nameForm extent.
	rectForName topLeft eightNeighbors do: [ :pt |
		aCanvas
			stencil: nameForm 
			at: pt
			color: self colorAroundName.
	].
	aCanvas
		stencil: nameForm 
		at: rectForName topLeft 
		color: Color black.


	
! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:18'!
fontForName

	| pickem |
	pickem _ 3.

	pickem = 1 ifTrue: [
		^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1.
	].
	pickem = 2 ifTrue: [
		^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1.
	].
	^((TextStyle default) fontAt: 1) emphasized: 1
! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:17'!
isEditingName

	^((self findA: UpdatingStringMorph) ifNil: [^false]) hasFocus
! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:32'!
stringToShow

	(target isNil or: [getSelector isNil]) ifTrue: [^'????'].
	^target perform: getSelector! !

!SquishedNameMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/11/2000 23:31'!
target: aTarget getSelector: symbol1 setSelector: symbol2

	target _ aTarget.
	getSelector _ symbol1.
	setSelector _ symbol2.! !
BookMorph subclass: #StackMorph
	instanceVariableNames: 'cards '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Stacks'!
!StackMorph commentStamp: '<historical>' prior: 0!
The instance variables of interest here -- some are presently inherited from PasteupMoprh --


dataInstances            this is the stack's entire data-base
backgrounds
currentDataInstance    Points to an element of dataInstances

userFrameRectangle



The primary abstraction here iis the Background and its instances.  I'd like to call this thing, which is kind of a Stack and a kind of database, 

The Background definition is the Playfield
We swap playfields in a Book.  Therefore, a Stack is like a book and a Playfield is like a background.!


!StackMorph methodsFor: 'initialization' stamp: 'sw 10/30/2000 16:16'!
initialize
	"Initialize the stack"

	| initialBackground |
	super initialize.
	initialBackground _ self findA: PasteUpMorph.  "yuk"
	initialBackground extent: (640@480); beSticky.
	initialBackground beAStackBackground.
	self beUnsticky.
	self setProperty: #controlsAtBottom toValue: true.

	cards _ OrderedCollection with: initialBackground currentDataInstance.

"self currentHand attachMorph: StackMorph authoringPrototype"! !


!StackMorph methodsFor: 'menu' stamp: 'sw 10/30/2000 10:11'!
addBookMenuItemsTo: aMenu hand: aHandMorph
	"Add book-related items to the given menu"

	| controlsShowing subMenu |
	subMenu _ MenuMorph new defaultTarget: self.
	subMenu add: 'previous card' action: #goToPreviousCardInStack.
	subMenu add: 'next card' action: #goToNextCardInStack.
	subMenu add: 'go to card...' action: #goToCard.
	subMenu add: 'insert a card' action: #insertCard.
	subMenu add: 'delete this card' action: #deleteCard.

	controlsShowing _ self hasSubmorphWithProperty: #pageControl.
	controlsShowing
		ifTrue:
			[subMenu add: 'hide card controls' action: #hidePageControls.
			subMenu add: 'fewer card controls' action: #fewerPageControls]
		ifFalse:
			[subMenu add: 'show card controls' action: #showPageControls].

	subMenu addLine.
	subMenu add: 'sound effect for all backgrounds' action: #menuPageSoundForAll:.
	subMenu add: 'sound effect this background only' action: #menuPageSoundForThisPage:.
	subMenu add: 'visual effect for all backgrounds' action: #menuPageVisualForAll:.
	subMenu add: 'visual effect this background only' action: #menuPageVisualForThisPage:.

	subMenu addLine.
	subMenu add: 'sort pages' action: #sortPages:.
	subMenu add: 'uncache page sorter' action: #uncachePageSorter.
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [subMenu add: 'wrap after last page' selector: #setWrapPages: argument: true]
		ifFalse: [subMenu add: 'stop at last page' selector: #setWrapPages: argument: false].

	subMenu addLine.
	subMenu add: 'search for text' action: #textSearch.
	(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[subMenu add: 'paste book page'	action: #pasteBookPage].

	subMenu add: 'send all pages to server' action: #savePagesOnURL.
	subMenu add: 'send this page to server' action: #saveOneOnURL.
	subMenu add: 'reload all from server' action: #reload.
	subMenu add: 'copy page url to clipboard' action: #copyUrl.
	subMenu add: 'keep in one file' action: #keepTogether.
	subMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil:
		[subMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	aMenu add: 'book...' subMenu: subMenu
! !

!StackMorph methodsFor: 'menu' stamp: 'sw 10/23/2000 16:43'!
invokeBookMenu
	"Invoke the book's control panel menu."
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack'.
	aMenu addStayUpItem.
	aMenu addList: #(
		('find...'								textSearch)
		('show designations' 					showDesignationsOfObjects)
		('explain designations'					explainDesignations)
		('look inside'							openInsideLook)
		-
		('previous card' 						goToPreviousCardInStack)
		('next card' 							goToNextCardInStack)
		('first card' 							goToFirstCardOfStack)
		('last card' 								goToLastCardOfStack)
		('go to card...' 							goToCard)
		-
		('add a card of this background' 		insertCard)
		('add a card of background...'		 	insertCardOfBackground)
		('make a new background...' 			makeNewBackground)
		-
		('delete this card' 						deleteCard)
		-
		('scripts for this background'			browseCardClass)
		-
		('debug...'								offerStackDebugMenu)
		('bookish items...' 						offerBookishMenu)).
	aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls.

	aMenu popUpEvent: self world activeHand lastEvent in: self world


! !

!StackMorph methodsFor: 'menu' stamp: 'sw 10/30/2000 10:03'!
offerBookishMenu
	"Offer a menu with book-related items in it"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack / Book'.
	aMenu addStayUpItem.
	aMenu addList:
		#(('sort pages'			sortPages)
		('uncache page sorter'	uncachePageSorter)).
	(self hasProperty: #dontWrapAtEnd)
		ifTrue: [aMenu add: 'wrap after last page' selector: #setWrapPages: argument: true]
		ifFalse: [aMenu add: 'stop at last page' selector: #setWrapPages: argument: false].
	aMenu addList:
		#(('make bookmark'		bookmarkForThisPage)
		('make thumbnail'		thumbnailForThisPage)).

	aMenu addLine.
	aMenu add: 'sound effect for all pages' action: #menuPageSoundForAll:.
	aMenu add: 'sound effect this page only' action: #menuPageSoundForThisPage:.
	aMenu add: 'visual effect for all pages' action: #menuPageVisualForAll:.
	aMenu add: 'visual effect this page only' action: #menuPageVisualForThisPage:.

	aMenu addLine.
	(self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue:
		[aMenu add: 'paste book page'   action: #pasteBookPage].

	aMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
	newPagePrototype ifNotNil: [
		aMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

	aMenu add: (self dragNDropEnabled ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
			action: #toggleDragNDrop.
	aMenu add: 'make all pages this size' action: #makeUniformPageSize.
	aMenu add: 'send all pages to server' action: #savePagesOnURL.
	aMenu add: 'send this page to server' action: #saveOneOnURL.
	aMenu add: 'reload all from server' action: #reload.
	aMenu add: 'copy page url to clipboard' action: #copyUrl.
	aMenu add: 'keep in one file' action: #keepTogether.

	aMenu addLine.
	aMenu add: 'load PPT images from slide #1' action: #loadImagesIntoBook.
	aMenu add: 'background color for all pages...' action: #setPageColor.

	aMenu popUpEvent: self world activeHand lastEvent in: self world


! !

!StackMorph methodsFor: 'menu' stamp: 'sw 10/30/2000 10:06'!
offerStackDebugMenu
	"Put up a menu offering debugging items for the stack"

	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu addTitle: 'Stack debugging'.
	aMenu addStayUpItem.
	aMenu addList: #(
		('reassess'								reassessBackgroundShape)
		('relax grip on variable names'			relaxGripOnVariableNames)
		('commit card data'						commitCardData)
		-
		('browse card uniclass'					browseCardClass)
		('inspect card'							inspectCurrentCard)
		('inspect background'					inspectCurrentBackground)
		('inspect stack'							inspectCurrentStack)).
	aMenu popUpInWorld: (self world ifNil: [self currentWorld])
! !


!StackMorph methodsFor: 'background' stamp: 'sw 10/26/2000 14:41'!
backgroundWithCard: aCard
	"Answer the background which contains aCard."

	^ self backgrounds detect:
		[:aBackground | aBackground containsCard: aCard] ifNone: [nil]! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/30/2000 10:04'!
backgrounds
	"Answer the list of backgrounds available in the receiver"

	^ self pages! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/30/2000 10:07'!
makeNewBackground
	"Make a new background for the stack.  Obtain a name for it from the user.  It starts out life empty"

	| aName aColor newPage |
	aName _ FillInTheBlank request: 'What should we call this new background?' initialAnswer: 'alternateBackground'.
	aName isEmptyOrNil ifTrue: [^ self].
	aColor _ self color muchLighter.
	newPage _ PasteUpMorph newSticky extent: currentPage extent; color: aColor.
	newPage beAStackBackground.
	newPage borderWidth: currentPage borderWidth; borderColor: currentPage borderColor.
	newPage setNameTo: aName.
	newPage resizeToFit: false.
	pages isEmpty
		ifTrue: [pages add: newPage]
		ifFalse: [pages add: newPage after: currentPage].
	cards add: newPage currentDataInstance after: currentPage currentDataInstance.
	self nextPage.
! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/30/2000 10:13'!
reassessBackgroundShape
	"Have the current page reconsider its cards' instance structure"

	^ self currentPage reassessBackgroundShape 
! !

!StackMorph methodsFor: 'background' stamp: 'sw 10/30/2000 10:15'!
reshapeBackground
	"Abandon any memory of variable-name preferences for the current background, and reassess its instance structure"

	^ self currentPage reshapeBackground 
! !


!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:24'!
browseCardClass
	"Browse the class of the current card"

	| suffix |
	suffix _ self currentCard class name numericSuffix.
	HierarchyBrowser newFor: self currentCard class labeled: 'Background ', suffix asString
! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:26'!
cardIndexOf: aCard
	"Answer the ordinal position of aCard in the receiver's list"

	^ cards indexOf: aCard ifAbsent: [nil]! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:26'!
cards
	"Answer a list of the cards of the receiver, in order"

	^ cards copy! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:27'!
currentCard
	"Answer the current card of the current background of the receiver"

	^ currentPage currentDataInstance! !

!StackMorph methodsFor: 'card access' stamp: 'tk 1/8/2001 12:56'!
deleteCard
	"Delete the current card from the stack"

	| aCard |
	aCard _ self currentCard.
	cards size = 1 ifTrue: [^ self beep].
	(self confirm: 'Really delete this card and all of its data?') ifTrue: [
		self goToNextCardInStack.
		cards remove: aCard].! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:10'!
deleteCard: aCard
	"Delete the current card from the stack."

	cards size = 1 ifTrue: [^ self beep].
	(aCard == self currentCard) ifTrue: [^ self deleteCard].

	cards remove: aCard ifAbsent: []! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:50'!
goToCard
	"prompt the user for an ordinal number, and use that as a basis for choosing a new card to install in the receiver"

	| reply index |
	reply _ FillInTheBlank request: 'Which card number? ' initialAnswer: '1'.
	reply isEmptyOrNil ifTrue: [^ self].
	((index _ reply asNumber) > 0 and: [index <= cards size])
		ifFalse: [^ self inform: 'no such card'].
	self goToCard: (cards at: index)! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/26/2000 09:11'!
goToCard: destinationCard
	"Install the indicated destinationCard as the current card in the receiver.  Any viewer currently open on the current card will get retargeted to look at the new one."

	| aBackground existingCard oldViewers |
	aBackground _ self backgroundWithCard: destinationCard.
	existingCard _ aBackground currentDataInstance.
	oldViewers _ existingCard ifNil: [#()] ifNotNil: [existingCard allOpenViewers].

	aBackground installAsCurrent: destinationCard.

	aBackground ~~ currentPage ifTrue:
		["concern that need to run opening/closing scripts even when we're not going to a different background"
		self goToPageMorph: aBackground].

	oldViewers do: [:aViewer | aViewer retargetFrom: existingCard to: destinationCard]! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:49'!
goToCardNumber: aCardNumber
	"Install the card whose ordinal number is provided as the current card in the stack"

	self goToCard: (cards at: aCardNumber)! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/30/2000 16:15'!
goToFirstCardInBackground
	"Install the initial card in the current background as the current card in the stack"

	| kind |
	kind _ currentPage player class baseUniclass.
	self goToCard: (cards detect: [:aCard | aCard isKindOf: kind] ifNone: [^ self beep])! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:44'!
goToFirstCardOfStack
	"Install the initial card in the stack as the current card"

	self goToCard: cards first! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/30/2000 16:15'!
goToLastCardInBackground
	"Install the final card in the current background as the current card"

	| kind |
	kind _ currentPage player class baseUniclass.
	self goToCard: (cards reversed detect: [:aCard | aCard isKindOf: kind] ifNone: [^ self beep])! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 17:03'!
goToLastCardOfStack
	"Install the final card in the stack as the current card"

	self goToCard: cards last! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 14:45'!
goToNextCardInStack
	"Make the card *after* the current card become the current card"

	| anIndex newCard |
	anIndex _ cards indexOf: currentPage currentDataInstance.
	newCard _ cards atWrap: anIndex + 1.
	self goToCard: newCard! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 15:01'!
goToPreviousCardInStack
	"Install the previous card as my current one"

	| anIndex newCard |
	anIndex _ cards indexOf: currentPage currentDataInstance.
	newCard _ cards atWrap: anIndex - 1.
	self goToCard: newCard! !

!StackMorph methodsFor: 'card access' stamp: 'sw 10/23/2000 16:02'!
insertCard
	"Create a new card of the current background and make it become the current card"

	self insertCardOfBackground: currentPage! !


!StackMorph methodsFor: 'controls' stamp: 'sw 10/30/2000 10:05'!
fullControlSpecs
	"Answer specifications for the long form of iconic stack/book controls"

	^ #(
		spacer
		variableSpacer
		('-'			deleteCard					'Delete this card')
		spacer
		( 'Ç'		goToFirstCardOfStack			'First card')
		spacer
		( '<' 		goToPreviousCardInStack		'Previous card')
		spacer
		('¥'			invokeBookMenu 			'Click here to get a menu of options for this stack.')
		spacer

		('¦'			reshapeBackground  		'Reshape')
		spacer
		('¤'			showDesignationsOfObjects 	'Show designations')
		spacer
		('>'			goToNextCardInStack			'Next card')
		spacer
		( 'È'		goToLastCardOfStack			'Final card')
		spacer
		('+'			insertCard					'Add a new card after this one')
		variableSpacer
		('×'			fewerPageControls			'Fewer controls
(if shift key pressed,
deletes controls)')
)! !

!StackMorph methodsFor: 'controls' stamp: 'sw 10/30/2000 16:31'!
pageControlsMorphFrom: controlSpecs
	"Answer a controls morph derived from the spec supplied"

	| controls |
	controls _ super pageControlsMorphFrom: controlSpecs.
	controls eventHandler: nil.  "not grabbable"
	^ controls! !

!StackMorph methodsFor: 'controls' stamp: 'sw 10/30/2000 10:09'!
shortControlSpecs
	"Answer specficiations for the shorter form of stack controls"

	^ #(
		spacer
		variableSpacer
		( '<'		goToPreviousCardInStack		'Previous card')
		spacer
		('¥'		invokeBookMenu 			'Click here to get a menu for this stack.')
		spacer
		('>'		goToNextCardInStack			'Next card')
		variableSpacer
		('×'	showMoreControls				'More controls
(if shift key pressed,
deletes controls)'))! !


!StackMorph methodsFor: 'debugging' stamp: 'sw 10/30/2000 10:13'!
inspectCurrentBackground
	"Open an inspector on the corrent background.  Ideally should put include the background name in the inspector's title."

	^ self currentPage inspectWithLabel: 'A Background'
! !

!StackMorph methodsFor: 'debugging' stamp: 'sw 10/23/2000 16:37'!
inspectCurrentCard
	"For debugging: open an Inspector on the receiver's current card"

	^ self currentCard inspectWithLabel: 'A Card'
! !

!StackMorph methodsFor: 'debugging' stamp: 'sw 10/30/2000 10:09'!
inspectCurrentStack
	"Triggered from the stack-debug menu, open an Inspector on the receiver"

	^ self inspectWithLabel: 'A Stack'
! !


!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 16:27'!
commitCardData
	"Make certain that the player data are written back to the player instance"

	^ self currentCard commitCardPlayerData 
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:10'!
defaultNameStemForNewPages
	"Answer the stem to use as the default for names of cards in the stack"

	^ 'card'
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:03'!
explainDesignations
	"Give the user an explanation of what the designations mean"

	self currentPage explainDesignations
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 16:49'!
insertCardOfBackground
	"Prompt the user for choice of a background, and insert a new card of that background"

	| bgs aMenu aBackground |
	(bgs _ self backgrounds) size == 1 ifTrue:
		[self inform: 
'At this time, there IS only one kind of
background in this stack, so that''s
what you''ll get'.
		^ self insertCard].
	aMenu _ SelectionMenu
		labels: 		(bgs collect: [:bg | bg externalName])
		selections: 	bgs.
	(aBackground _ aMenu startUp) ifNotNil:
		[self insertCardOfBackground: aBackground]! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 16:00'!
insertCardOfBackground: aBackground
	"Insert a new card of the given background and have it become the current card"

	| newCard |
	newCard _  aBackground newCard.
	cards add: newCard after: self currentCard.
	self goToCard: newCard! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:08'!
openInsideLook
	"Open an inside-look at the current page.  This is a previously-demoed feature not presently incorporated in released code,"

	true ifTrue: [self notYetImplemented] ifFalse: [self currentPage openInsideLook]
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:04'!
relaxGripOnVariableNames
	"Have the current background relax its grip on existing variable name"

	^ self currentPage relaxGripOnVariableNames 
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 10:10'!
showDesignationsOfObjects
	"Momentarily show which objects on the current card belong to which designation category"

	self currentPage showDesignationsOfObjects
! !

!StackMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/23/2000 17:37'!
stackDo: aBlock
	"Evaluate aBlock on behalf of the receiver stack"

	^ aBlock value: self! !


!StackMorph methodsFor: 'submorphs-accessing' stamp: 'tk 1/30/2001 23:44'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy.  Especially the non-showing pages in BookMorphs."
	| coll |

	coll _ OrderedCollection new.
	cards do: [:cd | 
		cd privateMorphs ifNotNil: [coll addAll: cd privateMorphs]].
	^ coll! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StackMorph class
	instanceVariableNames: ''!

!StackMorph class methodsFor: 'viewer' stamp: 'sw 10/30/2000 16:13'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((#'stack navigation'
			((command goToNextCardInStack 'Go to the next card')
			(command goToPreviousCardInStack  'Go to the previous card')
			(command goToFirstCardInBackground 'Go to the first card of the current background')
			(command goToFirstCardOfStack 'Go to the first card of the entire stack')
			(command goToLastCardInBackground 'Go to the last card of the current background')
			(command goToLastCardOfStack 'Go to the last card of the entire stack')
			(command deleteCard 'Delete the current card')
			(command insertCard 'Create a new card'))))! !


!StackMorph class methodsFor: 'authoring prototype' stamp: 'sw 10/9/2000 07:43'!
authoringPrototype
	"Answer an instance of the receiver suitable for placing in a parts bin for authors"
	
	| book |
	book _ self new markAsPartsDonor.
	book pageSize: (480 @ 320); color: (Color gray: 0.7).
	book borderWidth: 1; borderColor: Color black.
	book currentPage extent: book pageSize.
	book showPageControls: book fullControlSpecs.
	^ book

"self currentHand attachMorph: StackMorph authoringPrototype"! !

!StackMorph class methodsFor: 'authoring prototype' stamp: 'ar 11/9/2000 20:43'!
designationsExplainer
	"Answer a morph that contains designation explanation"

	| aMorph aSwatch aTextMorph |
	aMorph _ AlignmentMorph newColumn color: Color black; layoutInset: 1.
	#((green		
'Shared items on
Background.
Exact same item
shared by every card')
	(orange
'Data items on
Background
Each card has its
own data')
	(red
'Instance-specific
items
unique
to this card')) do:

	[:aPair |
		aSwatch _ AlignmentMorph new extent: 132 @80; color: (Color perform: aPair first); lock.
		aSwatch hResizing: #rigid; vResizing: #rigid; layoutInset: 0.
		aSwatch borderColor: Color black.
		aTextMorph _ TextMorph new string: aPair second fontName: 'ComicBold' size: 18.
		aTextMorph width: 130.
		aTextMorph centered.
		aSwatch addMorphBack: aTextMorph.
		aMorph addMorphBack: aSwatch].

	^ aMorph

	"StackMorph designationsExplainer openInHand"
! !


!StackMorph class methodsFor: 'navigation buttons' stamp: 'sw 10/27/2000 10:53'!
nextCardButton
	"Answer a button that advances the user to the next card in the stack"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #goToNextCardInStack; label: '>'; color: Color yellow; borderWidth: 0.
	aButton setNameTo: 'next'.
	^ aButton! !

!StackMorph class methodsFor: 'navigation buttons' stamp: 'sw 10/27/2000 10:53'!
previousCardButton
	"Answer a button that will take the user to the preceding card in the stack"

	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aButton; actionSelector: #goToPreviousCardInStack; label: '<'; color: Color yellow ; borderWidth: 0.
	aButton setNameTo: 'previous'.
	^ aButton! !
SelectionMenu subclass: #StandardFileMenu
	instanceVariableNames: 'canTypeFileName pattern '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!
!StandardFileMenu commentStamp: '<historical>' prior: 0!
I represent a SelectionMenu which operates like a modal dialog for selecting files, somewhat similar to the StandardFile dialogs in MacOS and Java Swing.

Try for example, the following:

	StandardFileMenu oldFile inspect

	StandardFileMenu oldFileStream inspect

	StandardFileMenu newFile inspect

	StandardFileMenu newFileStream inspect!


!StandardFileMenu methodsFor: 'menu building' stamp: 'di 5/12/2000 10:31'!
directoryNamesString: aDirectory
"Answer a string concatenating the directory name strings in aDirectory, each string followed by a '[...]' indicator, and followed by a cr."

	^ String streamContents:
		[:s | aDirectory directoryNames do: 
				[:dn | s nextPutAll: dn withBlanksTrimmed , ' [...]'; cr]]

! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'tk 2/14/2000 14:58'!
fileNamesString: aDirectory
"Answer a string concatenating the file name strings in aDirectory, each string followed by a cr."

	^String streamContents:
		[:s | 
			aDirectory fileNames do: 
				[:fn |
					(pattern match: fn) ifTrue: [
						s nextPutAll: fn withBlanksTrimmed; cr]]]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'tk 2/14/2000 14:25'!
makeFileMenuFor: aDirectory
"Initialize an instance of me to operate on aDirectory"

	| theMenu |
	pattern ifNil: [pattern _ '*'].
	Cursor wait showWhile: 
		[self 
			labels: 	(self menuLabelsString: aDirectory)
			font: 	(MenuStyle fontAt: 1) 
			lines: 	(self menuLinesArray: aDirectory).
		theMenu _ self selections: (self menuSelectionsArray: aDirectory)].
	^theMenu! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:57'!
menuLabelsString: aDirectory
"Answer a menu labels object corresponding to aDirectory"

	^ String streamContents: 
		[:s | 
			canTypeFileName ifTrue: 
				[s nextPutAll: 'Enter File Name...'; cr].
			s nextPutAll: (self pathPartsString: aDirectory).
			s nextPutAll: (self directoryNamesString: aDirectory).
			s nextPutAll: (self fileNamesString: aDirectory).
			s skip: -1]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'ti 5/10/2000 11:18'!
menuLinesArray: aDirectory
"Answer a menu lines object corresponding to aDirectory"

	| typeCount nameCnt |
	typeCount _ canTypeFileName 
		ifTrue: [1] 
		ifFalse: [0].
	nameCnt _ aDirectory directoryNames size.
	^Array streamContents: [:s |
		canTypeFileName ifTrue: [s nextPut: 1].
		s nextPut: aDirectory pathParts size + typeCount + 1.
		s nextPut: aDirectory pathParts size + 
					nameCnt + typeCount + 1]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'di 5/12/2000 11:01'!
menuSelectionsArray: aDirectory
"Answer a menu selections object corresponding to aDirectory.  The object is an array corresponding to each item, each element itself constituting a two-element array, the first element of which contains a selector to operate on and the second element of which contains the parameters for that selector."

	|dirSize|
	dirSize _ aDirectory pathParts size.
	^Array streamContents: [:s |
		canTypeFileName ifTrue:
			[s nextPut: (StandardFileMenuResult
				directory: aDirectory
				name: nil)].
		s nextPut: (StandardFileMenuResult
			directory: (FileDirectory root)
			name: '').
		aDirectory pathParts doWithIndex: 
			[:d :i | s nextPut: (StandardFileMenuResult
					directory: (self 
						advance: dirSize - i
						containingDirectoriesFrom: aDirectory)
					name: '')].
		aDirectory directoryNames do: 
			[:dn |  s nextPut: (StandardFileMenuResult
						directory: (FileDirectory on: (aDirectory fullNameFor: dn))
						name: '')].
		aDirectory fileNames do: 
			[:fn | (pattern match: fn) ifTrue: [
					s nextPut: (StandardFileMenuResult
						directory: aDirectory
						name: fn)]]]! !

!StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:03'!
pathPartsString: aDirectory
"Answer a string concatenating the path parts strings in aDirectory, each string followed by a cr."

	^String streamContents:
		[:s | 
			s nextPutAll: '[]'; cr.
			aDirectory pathParts asArray doWithIndex: 
				[:part :i |
					s next: i put: $ .
					s nextPutAll: part withBlanksTrimmed; cr]]! !


!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 4/15/1999 21:52'!
confirmExistingFiles: aResult

	|choice|
	(aResult directory fileExists: aResult name) ifFalse: [^aResult].
	
	choice _ (PopUpMenu
		labels:
'overwrite that file
choose another name
cancel')
		startUpWithCaption: aResult name, '
already exists.'.

	choice = 1 ifTrue: [
		aResult directory 
			deleteFileNamed: aResult name
			ifAbsent: 
				[^self startUpWithCaption: 
'Can''t delete ', aResult name, '
Select another file'].
		^aResult].
	choice = 2 ifTrue: [^self startUpWithCaption: 'Select Another File'].
	^nil
 ! !

!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 4/15/1999 22:32'!
getTypedFileName: aResult

	| name |
	name _ FillInTheBlank 
		request: 'Enter a new file name' 
		initialAnswer: ''.
	name = '' ifTrue: [^self startUpWithCaption: 'Select a File:'].
	name _ aResult directory fullNameFor: name.
	^ StandardFileMenuResult
			directory: (FileDirectory forFileName: name)
			name: (FileDirectory localNameFor: name)
! !

!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 9/28/1999 23:34'!
startUpWithCaption: aString at: location

	|result|
	result _ super startUpWithCaption: aString at: location.
	result ifNil: [^nil].
	result isDirectory ifTrue:
		[self makeFileMenuFor: result directory.
		 self computeForm.
		 ^self startUpWithCaption: aString at: location].
	result isCommand ifTrue: 
		[result _ self getTypedFileName: result.
		result ifNil: [^nil]].
	canTypeFileName ifTrue: [^self confirmExistingFiles: result].
	^result
	! !


!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 00:32'!
advance: anInteger containingDirectoriesFrom: aDirectory

	| theDirectory |
	theDirectory _ aDirectory.
	1 to: anInteger do: [:i | theDirectory _ theDirectory containingDirectory].
	^theDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 20:50'!
computeLabelParagraph
	"Answer a Paragraph containing this menu's labels, one per line and centered."

	^ Paragraph withText: labelString asText style: (MenuStyle leftFlush)! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'!
newFileFrom: aDirectory

	canTypeFileName _ true.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'!
oldFileFrom: aDirectory

	canTypeFileName _ false.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private'!
oldFileFrom: aDirectory withPattern: aPattern

	canTypeFileName _ false.
	pattern _ aPattern.
	^self makeFileMenuFor: aDirectory! !

!StandardFileMenu methodsFor: 'private' stamp: 'tk 2/14/2000 14:24'!
pattern: patString
	" * for all files, or '*.cs' for changeSets, etc.  Just like fileLists"

	pattern _ patString! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileMenu class
	instanceVariableNames: ''!

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:14'!
newFileMenu: aDirectory
	Smalltalk isMorphic ifFalse: [^ PluggableFileList newFileMenu: aDirectory].
	^ super new newFileFrom: aDirectory! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'!
oldFileMenu: aDirectory
	Smalltalk isMorphic ifFalse: [^ PluggableFileList oldFileMenu: aDirectory].
	^ super new oldFileFrom: aDirectory! !

!StandardFileMenu class methodsFor: 'instance creation' stamp: 'RAA 5/25/2000 09:30'!
oldFileMenu: aDirectory withPattern: aPattern

	Smalltalk isMorphic ifFalse: [^PluggableFileList oldFileMenu: aDirectory].
	^super new oldFileFrom: aDirectory withPattern: aPattern! !


!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
newFile

	^self newFileFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:07'!
newFileFrom: aDirectory

	^(self newFileMenu: aDirectory)
		startUpWithCaption: 'Select a File:'! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:18'!
newFileStream

	^self newFileStreamFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
newFileStreamFrom: aDirectory

	| sfmResult fileStream |
	sfmResult _ self newFileFrom: aDirectory.
	sfmResult ifNil: [^nil].
	fileStream _ sfmResult directory newFileNamed: sfmResult name.
	[fileStream isNil] whileTrue:
		[sfmResult _ self newFileFrom: aDirectory.
		sfmResult ifNil: [^nil].
		fileStream _ sfmResult directory newFileNamed: sfmResult name].
	^fileStream
! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:28'!
oldFile

	^self oldFileFrom: (FileDirectory default)! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 00:50'!
oldFileFrom: aDirectory

	^(self oldFileMenu: aDirectory)
		startUpWithCaption: 'Select a File:'! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'acg 4/15/1999 22:17'!
oldFileStream

	^self oldFileStreamFrom: (FileDirectory default)
! !

!StandardFileMenu class methodsFor: 'standard file operations' stamp: 'tk 2/14/2000 14:27'!
oldFileStreamFrom: aDirectory

	| sfmResult fileStream |
	sfmResult _ self oldFileFrom: aDirectory.
	sfmResult ifNil: [^nil].
	fileStream _ sfmResult directory oldFileNamed: sfmResult name.
	[fileStream isNil] whileTrue:
		[sfmResult _ self oldFileFrom: aDirectory.
		sfmResult ifNil: [^nil].
		fileStream _ sfmResult directory oldFileNamed: sfmResult name].
	^fileStream
! !
Object subclass: #StandardFileMenuResult
	instanceVariableNames: 'directory name '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-FileList'!

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
directory

	^directory! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
directory: aDirectory

	^directory _ aDirectory! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
name

	^name! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'acg 4/15/1999 08:43'!
name: aString

	^name _ aString! !

!StandardFileMenuResult methodsFor: 'accessing' stamp: 'sw 6/9/1999 11:50'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' with directory: '.
	directory printOn: aStream.
	aStream nextPutAll: ' name: '.
	name printOn: aStream

"StandardFileMenu oldFile"! !


!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 09:05'!
isCommand

	^name isNil! !

!StandardFileMenuResult methodsFor: 'testing' stamp: 'acg 4/15/1999 20:57'!
isDirectory

	^name = ''! !


!StandardFileMenuResult methodsFor: 'private' stamp: 'acg 4/15/1999 08:42'!
directory: aDirectory name: aString

	directory _ aDirectory.
	name _ aString.
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileMenuResult class
	instanceVariableNames: ''!

!StandardFileMenuResult class methodsFor: 'instance creation' stamp: 'acg 4/15/1999 08:42'!
directory: aDirectory name: aString

	^super new directory: aDirectory name: aString! !
FileStream subclass: #StandardFileStream
	instanceVariableNames: 'name fileID buffer1 '
	classVariableNames: 'Registry '
	poolDictionaries: ''
	category: 'System-Files'!
!StandardFileStream commentStamp: '<historical>' prior: 0!
Provides a simple, platform-independent, interface to a file system.  This initial version ignores issues of Directories etc.  The instance-variable fallbackStream at the moment holds an instance of HFSMacFileStream, to bridge us to the new world while in the old.  The instance variable rwmode, inherited from class PositionableStream, here is used to hold a Boolean -- true means opened for read-write, false means opened for read-only.  2/12/96 sw!


!StandardFileStream methodsFor: 'open/close' stamp: 'ar 10/7/1998 14:43'!
close
	"Close this file."

	fileID ifNotNil: [
		self primClose: fileID.
		self unregister.
		fileID _ nil].
! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/19/1998 17:01'!
closed
	"Answer true if this file is closed."

	^ fileID isNil
! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 16:20'!
ensureOpen
	"Make sure that this file really is open."

	self closed ifTrue: [^ self reopen].
	(self primSizeNoError: fileID) ifNotNil: [^ self].
	self reopen.
! !

!StandardFileStream methodsFor: 'open/close'!
open
	"For compatibility with a few existing things.  2/14/96 sw"

	^ self reopen! !

!StandardFileStream methodsFor: 'open/close' stamp: 'ar 10/7/1998 14:44'!
open: fileName forWrite: writeMode 
	"Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode."
	"Changed to do a GC and retry before failing ar 3/21/98 17:25"
	fileID _ self retryWithGC:[self primOpen: fileName writable: writeMode] until:[:id| id notNil].
	fileID ifNil: [^ nil].  "allows sender to detect failure"
	self register.
	name _ fileName.
	rwmode _ writeMode.
	buffer1 _ String new: 1.
! !

!StandardFileStream methodsFor: 'open/close'!
openReadOnly
	"Open the receiver as a read-only file.  1/31/96 sw"

	^ self open: name forWrite: false! !

!StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 13:58'!
reopen
	"Close and reopen this file. The file position is reset to zero."
	"Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened."

	fileID ifNotNil: [self primCloseNoError: fileID].
	self open: name forWrite: rwmode.
! !


!StandardFileStream methodsFor: 'properties-setting'!
asHtml
	"Convert me in to an HtmlFileStream. 4/11/96 tk"

	^ self as: HtmlFileStream 
! !

!StandardFileStream methodsFor: 'properties-setting'!
ascii
	"opposite of binary"
	buffer1 _ String new: 1! !

!StandardFileStream methodsFor: 'properties-setting'!
binary
	buffer1 _ ByteArray new: 1! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'JMM 1/28/2001 18:44'!
getFileType
	"On the Macintosh, get the file type and creator of this file. On other platforms, do nothing."

	^FileDirectory default
		getMacFileTypeAndCreator: self fullName
		
! !

!StandardFileStream methodsFor: 'properties-setting'!
insertLineFeeds
	"(FileStream oldFileNamed: 'BBfix2.st') insertLineFeeds"
	| s crLf f |
	crLf _ String with: Character cr with: (Character value: 10).
	s _ ReadStream on: (self next: self size).
	self close.
	f _ FileStream newFileNamed: self name.
	[s atEnd] whileFalse: 
		[f nextPutAll: (s upTo: Character cr); nextPutAll: crLf].
	f close! !

!StandardFileStream methodsFor: 'properties-setting'!
isBinary
	^ buffer1 class == ByteArray! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'tk 11/4/1998 19:17'!
isReadOnly

	^ rwmode not
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 9/21/1998 13:56'!
readOnly
	"Make this file read-only."

	rwmode _ false.
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 9/21/1998 13:56'!
readWrite
	"Make this file writable."

	rwmode _ true.
! !

!StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 12/5/97 15:14'!
setFileTypeToObject
	"On the Macintosh, set the file type and creator of this file to be a Squeak object file. On other platforms, do nothing. Setting the file type allows Squeak object files to be sent as email attachments and launched by double-clicking. On other platforms, similar behavior is achieved by creating the file with the '.sqo' file name extension."

	FileDirectory default
		setMacFileNamed: self fullName
		type: 'SOBJ'
		creator: 'FAST'.
! !


!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:16'!
directory
	"Return the directory containing this file."

	^ FileDirectory forFileName: self fullName
! !

!StandardFileStream methodsFor: 'access' stamp: 'tk 3/14/2000 23:31'!
directoryUrl

	^ self directory url! !

!StandardFileStream methodsFor: 'access'!
file
	"Answer the object representing the receiver's file.  Need for compatibility with some calls -- check senders.  2/14/96 sw"

	^ self! !

!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'!
fullName
	"Answer this file's full path name."

	^ name
! !

!StandardFileStream methodsFor: 'access'!
isDirectory
	"Answer whether the receiver represents a directory.  For the post-transition case, uncertain what to do.  2/14/96 sw"
	^ false! !

!StandardFileStream methodsFor: 'access' stamp: 'ar 11/24/1998 14:00'!
localName
	^ name ifNotNil: [(name findTokens: FileDirectory pathNameDelimiter asString) last]! !

!StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'!
name
	"Answer this file's full path name."

	^ name
! !

!StandardFileStream methodsFor: 'access' stamp: 'di 6/27/97 12:18'!
peekFor: item 
	"Answer false and do not advance if the next element is not equal to item, or if this stream is at the end.  If the next element is equal to item, then advance over it and return true"
	| next |
	"self atEnd ifTrue: [^ false]. -- SFStream will give nil"
	(next _ self next) == nil ifTrue: [^ false].
	item = next ifTrue: [^ true].
	self skip: -1.
	^ false! !

!StandardFileStream methodsFor: 'access'!
printOn: aStream
	"Put a printed version of the receiver onto aStream.  1/31/96 sw"

	aStream nextPutAll: self class name; nextPutAll: ': '; print: name! !

!StandardFileStream methodsFor: 'access'!
reset
	^ self reopen! !

!StandardFileStream methodsFor: 'access'!
size
	"Answer the size of the file in characters.  2/12/96 sw"

	^ self primSize: fileID! !


!StandardFileStream methodsFor: 'read, write, position' stamp: 'sw 2/12/96'!
atEnd
	"Answer whether the receiver is at its end.  "
	^ self primAtEnd: fileID! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'!
basicNext
	"Answer the next byte from this file, or nil if at the end of the file."

	| count |
	count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1.
	count = 1
		ifTrue: [^ buffer1 at: 1]
		ifFalse: [^ nil].
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 3/15/2000 10:31'!
compressFile
	"Write a new file that has the data in me compressed in GZip format."
	| zipped buffer |

	self readOnly; binary.
	zipped _ self directory newFileNamed: (self name, FileDirectory dot, 'gz').
	zipped binary; setFileTypeToObject.
		"Type and Creator not to be text, so can be enclosed in an email"
	zipped _ GZipWriteStream on: zipped.
	buffer _ ByteArray new: 50000.
	'Compressing ', self fullName displayProgressAt: Sensor cursorPoint
		from: 0 to: self size
		during: [:bar |
			[self atEnd] whileFalse: [
				bar value: self position.
				zipped nextPutAll: (self nextInto: buffer)].
			zipped close.
			self close].
! !

!StandardFileStream methodsFor: 'read, write, position'!
flush
	"In some OS's seeking to 0 and back will do a flush"
	| p |
	p _ self position.
	self position: 0; position: p! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'!
next
	"Answer the next byte from this file, or nil if at the end of the file."

	^ self basicNext! !

!StandardFileStream methodsFor: 'read, write, position'!
next: n
	"Return a string with the next n characters of the filestream in it.  1/31/96 sw"
	^ self nextInto: (buffer1 class new: n)! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 12/23/1999 15:02'!
next: n into: aString startingAt: startIndex
	"Read n bytes into the given string.
	Return aString or a partial copy if less than
	n elements have been read."
	| count |
	count _ self primRead: fileID into: aString
				startingAt: startIndex count: n.
	count = n
		ifTrue:[^aString]
		ifFalse:[^aString copyFrom: 1 to: startIndex+count-1]! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 1/2/2000 15:33'!
next: anInteger putAll: aString startingAt: startIndex
	"Store the next anInteger elements from the given collection."
	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	self primWrite: fileID from: aString startingAt: startIndex count: anInteger.
	^aString! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:55'!
nextPut: char
	"Write the given character to this file."

	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	buffer1 at: 1 put: char.
	self primWrite: fileID from: buffer1 startingAt: 1 count: 1.
	^ char
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:43'!
nextPutAll: aString
	"Write all the characters of the given string to this file."

	rwmode ifFalse: [^ self error: 'Cannot write a read-only file'].
	self primWrite: fileID from: aString startingAt: 1 count: aString basicSize.
	^ aString
! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:58'!
nextWordsInto: aBitmap
	"Note: The file primitives automatically adjust for word based objects."

	self next: aBitmap basicSize into: aBitmap startingAt: 1.
	aBitmap restoreEndianness.
	^ aBitmap! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 10/15/1998 09:30'!
padToEndWith: aChar
	"On the Mac, files do not truncate.  One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?).  This is a sad compromise.  Just let the file be the same length but pad it with a harmless character."

	| pad |
	self atEnd ifTrue: [^ self].
	pad _ self isBinary 
		ifTrue: [aChar asCharacter asciiValue]	"ok for char or number"
		ifFalse: [aChar asCharacter].
	self nextPutAll: (buffer1 class new: ((self size - self position) min: 20000) 
							withAll: pad).! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'!
peek
	"Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil.  "
	| next |
	self atEnd ifTrue: [^ nil].
	next _ self basicNext.
	self position: self position - 1.
	^ next! !

!StandardFileStream methodsFor: 'read, write, position'!
position
	"Return the receiver's current file position.  2/12/96 sw"

	^ self primGetPosition: fileID! !

!StandardFileStream methodsFor: 'read, write, position'!
position: pos
	"Set the receiver's position as indicated.  2/12/96 sw"

	^ self primSetPosition: fileID to: pos! !

!StandardFileStream methodsFor: 'read, write, position'!
readInto: byteArray startingAt: startIndex count: count
	"Read into the given array as specified, and return the count
	actually transferred.  index and count are in units of bytes or
	longs depending on whether the array is Bitmap, String or ByteArray"
	^ self primRead: fileID into: byteArray
			startingAt: startIndex count: count
! !

!StandardFileStream methodsFor: 'read, write, position'!
readOnlyCopy
	^ StandardFileStream readOnlyFileNamed: self name! !

!StandardFileStream methodsFor: 'read, write, position'!
setToEnd
	"Set the position of the receiver to the end of file.  1/31/96 sw"

	self position: self size! !

!StandardFileStream methodsFor: 'read, write, position'!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file.  1/31/96 sw"

	self position: self position + n! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'di 7/14/97 23:15'!
upTo: delim 
	"Fast version to speed up nextChunk"
	| pos buffer count |
	pos _ self position.
	buffer _ self next: 2000.
	(count _ buffer indexOf: delim) > 0 ifTrue: 
		["Found the delimiter part way into buffer"
		self position: pos + count.
		^ buffer copyFrom: 1 to: count - 1].
	self atEnd ifTrue:
		["Never found it, and hit end of file"
		^ buffer].
	"Never found it, but there's more..."
	^ buffer , (self upTo: delim)! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 12/22/1999 15:40'!
upToEnd
	"Answer a subcollection from the current access position through the last element of the receiver."

	| newStream buffer |
	buffer _ buffer1 species new: 1000.
	newStream _ WriteStream on: (buffer1 species new: 100).
	[self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)].
	^ newStream contents! !

!StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:56'!
verbatim: aString
	"A version of nextPutAll that can be called knowing it won't call nextPut: "

	^ self nextPutAll: aString
! !


!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primAtEnd: id
	"Answer true if the file position is at the end of the file."

	<primitive: 'primitiveFileAtEnd' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primClose: id
	"Close this file."

	<primitive: 'primitiveFileClose' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primCloseNoError: id
	"Close this file. Don't raise an error if the primitive fails."

	<primitive: 'primitiveFileClose' module: 'FilePlugin'>
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primGetPosition: id
	"Get this files current position."

	<primitive: 'primitiveFileGetPosition' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primOpen: fileName writable: writableFlag
	"Open a file of the given name, and return the file ID obtained.
	If writableFlag is true, then
		if there is none with this name, then create one
		else prepare to overwrite the existing from the beginning
	otherwise
		if the file exists, open it read-only
		else return nil"

	<primitive: 'primitiveFileOpen' module: 'FilePlugin'>
	^ nil
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primRead: id into: byteArray startingAt: startIndex count: count
	"Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read."

	<primitive: 'primitiveFileRead' module: 'FilePlugin'>
	self closed ifTrue: [^ self error: 'File is closed'].
	self error: 'File read failed'.
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSetPosition: id to: anInteger
	"Set this file to the given position."

	<primitive: 'primitiveFileSetPosition' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSize: id
	"Answer the size of this file."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	self primitiveFailed
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primSizeNoError: id
	"Answer the size of this file. Answer nil if the primitive fails; this indicates that the file handle has become stale."

	<primitive: 'primitiveFileSize' module: 'FilePlugin'>
	^ nil
! !

!StandardFileStream methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
primWrite: id from: stringOrByteArray startingAt: startIndex count: count
	"Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written."

	<primitive: 'primitiveFileWrite' module: 'FilePlugin'>
	self closed ifTrue: [^ self error: 'File is closed'].
	self error: 'File write failed'.
! !


!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'!
register
	^self class register: self! !

!StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'!
unregister
	^self class unregister: self! !


!StandardFileStream methodsFor: 'finalization' stamp: 'ar 3/21/98 18:16'!
actAsExecutor
	super actAsExecutor.
	name := nil.! !

!StandardFileStream methodsFor: 'finalization' stamp: 'ar 10/7/1998 15:44'!
finalize
	self primCloseNoError: fileID.! !


!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:44'!
defaultBrowserReadyWait
	^5000! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'ar 3/2/2000 17:47'!
post: data url: url ifError: errorBlock
	"Post data to the given URL. The returned file stream contains the reply of the server.
	If Squeak is not running in a browser evaluate errorBlock"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLPost: url data: data semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result _ self primURLRequestState: request.
		result == nil] whileTrue.
		result ifTrue:[fileID _ self primURLRequestFileHandle: request].
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:38'!
primBrowserReady
	<primitive:'primitivePluginBrowserReady'>
	self primitiveFailed! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'ar 3/2/2000 17:45'!
primURLPost: url data: contents semaIndex: index
	"Post the data (url might be 'mailto:' etc)"
	<primitive:'primitivePluginPostURL'>
	^nil
 ! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequest: url semaIndex: index
	<primitive:'primitivePluginRequestURLStream'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/29/2000 11:22'!
primURLRequest: url target: target semaIndex: index
	"target - String (frame, also '_top', '_parent' etc)"
	<primitive:'primitivePluginRequestURL'>
	^nil
 ! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestDestroy: request
	<primitive:'primitivePluginDestroyRequest'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestFileHandle: request
	<primitive: 'primitivePluginRequestFileHandle'>
	^nil! !

!StandardFileStream methodsFor: 'browser requests'!
primURLRequestState: request
	<primitive:'primitivePluginRequestState'>
	^false! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/29/2000 11:22'!
requestURL: url target: target
	^self requestURL: url target: target ifError: [nil]! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 2/29/2000 11:24'!
requestURL: url target: target ifError: errorBlock
	"Request to go to the target for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"

	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLRequest: url target: target semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result _ self primURLRequestState: request.
		result == nil] whileTrue.
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.! !

!StandardFileStream methodsFor: 'browser requests'!
requestURLStream: url
	"FileStream requestURLStream:'http://www.squeak.org'"
	^self requestURLStream: url ifError:[nil]! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:43'!
requestURLStream: url ifError: errorBlock
	"Request a FileStream for the given URL.
	If Squeak is not running in a browser evaluate errorBlock"
	"FileStream requestURLStream:'http://www.squeak.org'"
	| sema index request result |
	self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value].
	sema _ Semaphore new.
	index _ Smalltalk registerExternalObject: sema.
	request _ self primURLRequest: url semaIndex: index.
	request == nil ifTrue:[
	
	Smalltalk unregisterExternalObject: sema.
		^errorBlock value.
	] ifFalse:[
		[sema wait. "until something happens"
		result _ self primURLRequestState: request.
		result == nil] whileTrue.
		result ifTrue:[fileID _ self primURLRequestFileHandle: request].
		self primURLRequestDestroy: request.
	].
	Smalltalk unregisterExternalObject: sema.
	fileID == nil ifTrue:[^nil].
	self register.
	name _ url.
	rwmode _ false.
	buffer1 _ String new: 1.! !

!StandardFileStream methodsFor: 'browser requests' stamp: 'mir 1/11/2000 10:55'!
waitBrowserReadyFor: timeout ifFail: errorBlock
	| startTime delay |
	self primBrowserReady
		ifTrue: [^true].
	startTime _ Time millisecondClockValue.
	delay _ Delay forMilliseconds: 100.
	[(Time millisecondsSince: startTime) < timeout]
		whileTrue: [
			delay wait.
			self primBrowserReady
				ifTrue: [^true]].
	^errorBlock value! !


!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'!
primDropRequestFileHandle: dropIndex
	"Primitive. Return the (read-only) file handle for some file that was just dropped onto Squeak.
	Fail if dropIndex is out of range or the primitive is not supported."
	<primitive: 'primitiveDropRequestFileHandle' module:'DropPlugin'>
	^nil! !

!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 20:01'!
primDropRequestFileName: dropIndex
	"Primitive. Return the file name for some file that was just dropped onto Squeak.
	Fail if dropIndex is out of range or the primitive is not supported."
	<primitive: 'primitiveDropRequestFileName' module:'DropPlugin'>
	^nil! !

!StandardFileStream methodsFor: 'dnd requests' stamp: 'ar 1/10/2001 19:41'!
requestDropStream: dropIndex
	"Return a read-only stream for some file the user has just dropped onto Squeak."
	name _ self primDropRequestFileName: dropIndex.
	fileID _ self primDropRequestFileHandle: dropIndex.
	fileID == nil ifTrue:[^nil].
	self register.
	rwmode _ false.
	buffer1 _ String new: 1.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardFileStream class
	instanceVariableNames: ''!

!StandardFileStream class methodsFor: 'file creation' stamp: 'TPR 8/13/1999 21:22'!
fileNamed: fileName
	"Open a file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close."

	^ self new open: (self fullName: fileName) forWrite: true
! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'dew 10/26/2000 02:06'!
forceNewFileNamed: fileName
 	"Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, delete it without asking before creating the new file."

	| dir localName fullName |
	fullName _ self fullName: fileName.
	(self isAFileNamed: fullName)
		ifFalse: [^ self new open: fullName forWrite: true].

	dir _ FileDirectory forFileName: fullName.
	localName _ FileDirectory localNameFor: fullName.
	dir deleteFileNamed: localName
		ifAbsent: [self error: 'Could not delete the old version of that file'].
	^ self new open: fullName forWrite: true.
! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'mpw 9/18/1999 00:05'!
isAFileNamed: fileName
	"Answer true if a file of the given name exists."

	| f |
	f _ self new open: fileName forWrite: false.
	f ifNil: [^ false].
	f close.
	^ true
! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'mir 7/25/2000 16:44'!
newFileNamed: fileName
 	"Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, ask the user what to do."

	| fullName |
	fullName _ self fullName: fileName.

	^(self isAFileNamed: fullName)
		ifTrue: ["file already exists:"
			(FileExistsException fileName: fullName) signal]
		ifFalse: [self new open: fullName forWrite: true]

! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'mir 7/25/2000 16:39'!
oldFileNamed: fileName
	"Open an existing file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close."

	| fullName |
	fullName _ self fullName: fileName.

	^(self isAFileNamed: fullName)
		ifTrue: [self new open: fullName forWrite: true]
		ifFalse: ["File does not exist..."
			(FileDoesNotExistException fileName: fullName) signal]! !

!StandardFileStream class methodsFor: 'file creation' stamp: 'mdr 12/5/2000 19:51'!
readOnlyFileNamed: fileName 
	"Open an existing file with the given name for reading."

	| fullName f |
	fullName _ self fullName: fileName.
	f _ self new open: fullName forWrite: false.
	^ f isNil
		ifFalse: [f]
		ifTrue: ["File does not exist..."
			((FileDoesNotExistException fileName: fullName) readOnly: true) signal].

	"StandardFileStream readOnlyFileNamed: 'kjsd.txt' "! !


!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'!
register: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry add: anObject! !

!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'!
registry
	WeakArray isFinalizationSupported ifFalse:[^nil].
	^Registry isNil
		ifTrue:[Registry := WeakRegistry new]
		ifFalse:[Registry].! !

!StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:23'!
unregister: anObject
	WeakArray isFinalizationSupported ifFalse:[^anObject].
	self registry remove: anObject ifAbsent:[]! !


!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 9/7/2000 16:11'!
isRunningAsBrowserPlugin
	(self privateCheckForBrowserPrimitives ~~ false)
		ifFalse: [^false].
	self new waitBrowserReadyFor: 1000 ifFail: [^false].
	^true! !

!StandardFileStream class methodsFor: 'browser requests' stamp: 'mir 9/7/2000 16:08'!
privateCheckForBrowserPrimitives
	<primitive:'primitivePluginBrowserReady'>
	^false! !


!StandardFileStream class methodsFor: 'error handling' stamp: 'mir 2/28/2000 16:06'!
fileDoesNotExistUserHandling: fullFileName

	| selection newName |
	selection _ (PopUpMenu labels:
'create a new file
choose another name
cancel')
			startUpWithCaption: (FileDirectory localNameFor: fullFileName) , '
does not exist.'.
	selection = 1 ifTrue:
		[^ self new open: fullFileName forWrite: true].
	selection = 2 ifTrue:
		[ newName _ FillInTheBlank request: 'Enter a new file name'
						initialAnswer:  fullFileName.
		^ self oldFileNamed:
			(self fullName: newName)].
	self halt! !

!StandardFileStream class methodsFor: 'error handling' stamp: 'mir 2/28/2000 15:24'!
fileExistsUserHandling: fullFileName
	| dir localName choice newName newFullFileName |
	dir _ FileDirectory forFileName: fullFileName.
	localName _ FileDirectory localNameFor: fullFileName.
	choice _ (PopUpMenu
		labels:
'overwrite that file\choose another name\cancel' withCRs)
		startUpWithCaption: localName, '
already exists.'.

	choice = 1 ifTrue: [
		dir deleteFileNamed: localName
			ifAbsent: [self error: 'Could not delete the old version of that file'].
		^ self new open: fullFileName forWrite: true].

	choice = 2 ifTrue: [
		newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fullFileName.
		newFullFileName _ self fullName: newName.
		^ self newFileNamed: newFullFileName].

	self error: 'Please close this to abort file opening'! !

!StandardFileStream class methodsFor: 'error handling' stamp: 'mir 2/28/2000 16:05'!
readOnlyFileDoesNotExistUserHandling: fullFileName

	| dir files choices selection newName fileName |
	dir _ FileDirectory forFileName: fullFileName.
	files _ dir fileNames.
	fileName _ FileDirectory localNameFor: fullFileName.
	choices _ fileName correctAgainst: files.
	choices add: 'Choose another name'.
	choices add: 'Cancel'.
	selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) )
		startUpWithCaption: (FileDirectory localNameFor: fullFileName), '
does not exist.'.
	selection < (choices size - 1) ifTrue: [
		newName _ (dir pathName , FileDirectory slash , (choices at: selection))].
	selection = (choices size - 1) ifTrue: [
		newName _ FillInTheBlank 
							request: 'Enter a new file name' 
							initialAnswer: fileName].
	newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)].
	^ self error: 'Could not open a file'! !
Object subclass: #StandardScriptingSystem
	instanceVariableNames: ''
	classVariableNames: 'ClassVarNamesInUse CustomPartsBin FormDictionary HelpStrings ReservedScriptNames StandardPartsBin StandardSlotInfo SystemSlotDictionary TypeColorDictionary '
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!StandardScriptingSystem commentStamp: '<historical>' prior: 0!
An instance of this is installed as the value of the global variable "ScriptingSystem".  Client subclasses are invited, such as one used internally by squeak team for ongoing internal work.!


!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 5/2/1998 14:26'!
colorBehindTiles
	^ Color r: 0.903 g: 1.0 b: 0.903! !

!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 5/2/1998 14:28'!
fontForNameEditingInScriptor
	^ StrikeFont familyName: #ComicBold size: 18! !

!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 5/2/1998 14:19'!
fontForTiles
	^ StrikeFont familyName: #ComicBold size: 18! !

!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 10/30/2000 09:07'!
smallBoldFont
	"Answer a small bold font for use in some standard scripting-support structures"

	^ StrikeFont familyName: #ComicBold size: 12! !

!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 9/14/1998 14:41'!
statusColorSymbolFor: statusSymbol
	#(	(normal					green)
		(ticking					blue)
		(paused					red)
		(mouseDown				yellow)
		(mouseStillDown			lightYellow)
		(mouseUp				lightBlue)
		(mouseEnter				lightBrown)
		(mouseLeave			lightRed)
		(mouseEnterDragging	lightGray)
		(mouseLeaveDragging	darkGray)
		(keyStroke				lightGreen)) do:

			[:pair | statusSymbol == pair first ifTrue: [^ pair second]].

		^ #blue! !

!StandardScriptingSystem methodsFor: 'font & color choices' stamp: 'sw 5/2/1998 14:23'!
uniformTileInteriorColor
	^ Color r: 0.806 g: 1.0 b: 0.806! !


!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/6/1999 20:56'!
convertAllKeysToSymbols
	| newDict |
	"ScriptingSystem convertAllKeysToSymbols"
	newDict _ IdentityDictionary new.
	FormDictionary associationsDo:
		[:assoc |
			newDict at: assoc key asSymbol put: assoc value].
	FormDictionary _ newDict

"(FormDictionary keys asArray collect: [:k | k class name]) asBag sortedElements"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 11/26/1999 15:45'!
deletePrivateGraphics
	"ScriptingSystem deletePrivateGraphics"
	self deletePrivateGraphics:
			#(#BadgeMiniPic #BadgePic #Broom #CedarPic #CollagePic #CoverMain #CoverSpiral #CoverTexture #Fred #ImagiPic #KayaPic #StudioPic)
		afterStoringToFileNamed: 'disGraphics'! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'di 2/3/2001 20:10'!
deletePrivateGraphics: nameList afterStoringToFileNamed: aFileName
	"This method is used to strip private graphics from the FormDictionary and store them on a file of the given name"

	|  replacement toRemove aReferenceStream keySymbol |
	toRemove _ Dictionary new.
	replacement _ FormDictionary at: #Gets.

	nameList do:
		[:aKey |
			keySymbol _ aKey asSymbol.
			(toRemove at: keySymbol put: (self formAtKey: keySymbol)).
			FormDictionary at: keySymbol put: replacement].

	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	aReferenceStream nextPut: toRemove.
	aReferenceStream close! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/6/1999 20:57'!
formAtKey: aKey
	"ScriptingSystem saveForm: (TileMorph downPicture) atKey: 'downArrow'"
	^ FormDictionary at: aKey asSymbol ifAbsent: [nil]! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/16/1998 09:21'!
inspectFormDictionary
	"ScriptingSystem inspectFormDictionary"
	FormDictionary inspectFormsWithLabel: 'Standard Graphics'! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 5/12/1999 10:09'!
installSolidMenuForm
	"ScriptingSystem installSolidMenuForm"
	self saveForm:
		(Form extent: 14@16 depth: 16
	fromArray: #( 1 0 0 0 0 0 0 65537 65536 0 0 0 65537 0 65537 65537 65537 65537 65537 65537 65536 65537 65537 65537 65537 65537 1600061441 65536 65537 1600085855 1600085855 1600085855 1600085855 1600061441 65536 65537 1600085855 65537 65537 65537 65537 65536 65537 1600085855 65537 65537 65537 1600061441 65536 65537 1600085855 1600085855 1600085855 1600085855 1600085855 65537 65537 1600085855 65537 65537 65537 1600085855 65537 65537 1600085855 1600061441 65537 65537 89951 65537 65537 1600085855 1600085855 1600085855 1600085855 1600085855 65537 65537 1600085855 1600061441 65537 65537 65537 65537 65537 1600085855 65537 65537 65537 65536 65537 65537 65537 65537 65537 65537 65537 65537 1 65537 65537 65537 65537 65537 65536 0 65536 0 0 0 0 0) offset: 0@0)
		atKey: 'SolidMenu'! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 11/26/1999 15:37'!
mergeGraphicsFrom: aDictionary
	"aDictionary is assumed to hold associations of the form <formName> -> <form>.   Merge the graphics held by that dictionary into the internal FormDictionary, overlaying any existing entries with the ones found in aDictionary"

	aDictionary associationsDo:
		[:assoc | self saveForm: assoc value atKey: assoc key]

		"works ok even if keys in aDictionary are strings rather than symbols"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 11/26/1999 15:43'!
patchInNewStandardPlayerForm
	"ScriptingSystem patchInNewStandardPlayerForm"
	FormDictionary at: #standardPlayer put:
		(Form extent: 3@3
	depth: 16 fromArray: #( 17969 0 1177634353 1177616384 17969 0) offset: 0@0)! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 5/2/1998 14:01'!
readFormsFromFileNamed: aFileName
	"Read the entire FormDictionary in from a designated file on disk"

	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	FormDictionary _ aReferenceStream next.
	aReferenceStream close

	"ScriptingSystem readFormsFromFileNamed: 'EToyForms22Apr'"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 9/14/2000 21:29'!
readFormsFromFileNamed: aFileName andStoreIntoGlobal: globalName
	"Read the a FormDictionary in from a designated file on disk and save it in the designated global"

	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: aFileName.
	Smalltalk at: globalName put: aReferenceStream next.
	aReferenceStream close

	"ScriptingSystem readFormsFromFileNamed: 'SystemFormsFromFwdF.forms' andStoreIntoGlobal: #FormsTemp"

	"ScriptingSystem saveForm:  (FormsTemp at: #StackElementDesignationHelp) atKey: #StackElementDesignationHelp"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 4/23/1999 11:24'!
restorePrivateGraphics
	"ScriptingSystem restorePrivateGraphics"
	| aReferenceStream |
	aReferenceStream _ ReferenceStream fileNamed: 'disGraphics'.
	self mergeGraphicsFrom: aReferenceStream next.
	aReferenceStream close.
! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/6/1999 20:57'!
saveForm: aForm atKey: aKey
	FormDictionary at: aKey asSymbol put: aForm! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 5/6/1998 17:46'!
saveFormsToFileNamed: aFileName
	"Save the current state of form dictionary to disk for possible later retrieval"
  	 (ReferenceStream fileNamed: aFileName) nextPut: FormDictionary; close

	"ScriptingSystem saveFormsToFileNamed: 'SystemForms06May98.forms'"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 10/24/1998 14:12'!
squeakyMouseForm
	^ self formAtKey: 'squeakyMouse'

"
	ScriptingSystem saveForm: (Form
	extent: 30@29
	depth: 16
	fromArray: #( 1811114995 1878286257 2012637171 1811180532 1811180533 1811179508 1811180532 1811179508 1744006133 1878289396 1811180533 1878289396 1744007156 1674736630 1744006132 1811114995 1811181556 1744006131 1811246068 1811180532 1811179508 1811180532 1744071668 1811113972 1811180532 1811180532 1811179507 1878288338 1945529332 1744071668 1743941620 1811112945 1811179506 1811114995 1744006131 1744006130 1744005106 1811048434 1811113969 1743939570 1811179506 1743939571 1676833782 1676765171 1811047410 1744006131 1811048435 1811116020 1811180531 1743939571 1811048435 1743939570 1743939570 1743939570 1743940594 1744005106 1811181556 1811180532 1676766196 1743939570 1878420468 1676963830 1189896082 1811245044 1744137204 1744070644 1811179508 1811113971 1743939571 1811179508 1811246070 1811309524 1811302093 1811310580 1811246068 1674867703 1744049472 1120606594 1118465013 1744137205 1811179508 1811180532 1744071667 1744006132 1811112947 1811247095 1605584589 358761132 289435638 1676830707 1741975543 1462778473 1811312631 702891724 1811310548 1945528308 1811178450 1945528307 1878288372 1878353875 1878421494 1051471335 1809213397 1118524175 1811246068 1945659348 1185698607 1878486005 1672694510 1118531574 1607626741 1878420467 1811180533 1743942645 1744072693 1811301035 1185770487 1878486006 1324239597 1811180533 1811116019 1120623438 1878352818 1945462739 704868339 1878289395 1811049459 1878221808 1878223859 1743876083 1811162563 1945463796 1811181556 1464746666 1811116018 1809019893 1120551562 1945464821 1741844468 1466842760 1878289395 1811048434 1811050483 1811050483 1878223859 1049188174 1741910004 1811181556 1256998634 1811114994 1878289396 1466840647 1744007156 1744006131 1676877216 1743940596 1878222835 1743938545 1878351792 1676833781 358641652 1743940596 1811050484 845566798 1811113970 1811114995 1811163652 1811112913 1878420468 1878282028 1811179506 1607560178 1878289395 1676900342 1878351825 1466853330 1811113971 1811116019 635659217 1811179506 1811245045 1676942754 1744137206 1744201717 1676962806 1676962805 1811310581 1676896245 1744199635 1811376117 1744072695 1744005109 1811244019 499279861 1811310581 1811244020 1811293668 1399943159 1605528567 1744136181 982063522 986342388 1744070645 1744189066 430063308 1744071669 1744070644 1744067504 566519797 1744136181 1744137205 1743999854 912813044 1811311606 1742162607 4195488 283139922 1945531382 1253113857 144710948 1601400791 1811246069 1811167879 1464821747 1744136180 1674799094 1811178482 843473875 1811311606 1878533542 2106790 2080066222 1876193270 696845376 627472380 1185772536 1878355957 1743990309 1744007157 1676898294 1744006132 1811114996 1743941620 1811180533 1809204941 4194368 4217681 1878290421 1252982848 4194336 1670540278 1739811795 1878353906 1744006131 1811179506 1744007157 1744005106 1945462771 1811182582 1811311574 1393641133 1462856629 2012638196 1876382449 1112301394 1742041045 1945596917 1676833781 1811113970 1811179507 1811180532 1672705014 1674735606 1672697648 1945725943 1878551479 1809215479 1811312629 1809216504 1809215479 1809215478 1462853490 1878487029 1744007158 1744005075 1811239726 704979363 495004132 700789287 562372997 631646663 1739998892 4194400 1116497846 698688932 562375109 770124262 633609569 495070758 1257010166 562315916 1809279958 2012894002 1047280171 980237901 910966381 1668677696 4194400 6314867 1047281260 908804749 910968495 1393719290 1809279959 1185750370 1809214455 1878469062 423836236 1532188466 1601592148 1462986647 1672937568 4194368 6319062 1603622706 1601525554 1601522417 1047336194 770206679 1878487031 1878409899 977955830 1809145716 1118586509 980105834 980045584 1811372914 980104778 1605526483 1395605131 910769804 1118651052 1534358520 1809136234 1118596053 1532059506 1878485973 1326456163 1945660374 1742106615 1811311607 1945725942 1742107641 1744072693 1811311605 1744203767 1878551543 564478604 1878553591 1603428242 1811048433 1811049459 1051290611 1744006131 1811049459 1878156273 1743874034 1744007156 1743874033 1811048434 1811113970 1743939571 1743933228 1603301363 1743875059 1811049458 1945461745 1811181556 1811113971 1811049458 1811048434 1811116020 1878287346 1878223857 1743940594 1744006130 1744007157 1945395153 1945400309 1811048434 1743810547 1676765170 1878353906 1811113970 1743874032 1810983921 1743874033 1811113971 1676765169 1743874034 1743940593 1743939569 1811047409 1676765168 1743940595 1810981872 1945397235 1607560179 1743941620 1810982897 1810983921 1811048433 1744007155 1743875059 1811048434 1743875058 1743939568 1676832754 1811116019 1811114994 1811244019 1676962805 1677029367 1811244020 1744005106 1743940594 1811246068 1744070645 1676961781 1744004084 1676897269 1811180533 1878353908 1744004083 1744070645)
	offset: 0@0) atKey: 'squeakyMouse'"! !

!StandardScriptingSystem methodsFor: 'form dictionary' stamp: 'sw 12/7/1998 16:47'!
standardForms
	"ScriptingSystem standardForms"
	^ FormDictionary collect: [:f | f]! !


!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'sw 1/17/1999 09:51'!
helpStringFor: aSymbol
	^ HelpStrings at: aSymbol ifAbsent: ['No help yet available for ', aSymbol]! !

!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'sw 9/8/2000 17:19'!
initReservedScriptNames
	"Initialize the ReservedScriptNames class var, by polling the classes that have defined viewer-category information"

	| additions aSet |
	"ScriptingSystem initReservedScriptNames"
	aSet _ IdentitySet new.
	Morph withAllSubclasses do:
		[:aClass |
			(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
				[additions _ aClass additionsToViewerCategories.
				additions do:
					[:catNameAndInfo |
						catNameAndInfo second do:
							[:spec | (spec first == #command) ifTrue:
								[aSet add: spec second]]]]].

	ReservedScriptNames _ aSet! !

!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'sw 6/15/1999 17:03'!
initializeHelpStrings
	"Initialize the data structure that determines, for the etoy system, help messages for various scripting elements.  The structure is built up by letting every Morph subclass contribute elements simply by implementing method #helpContributions.  Consult implementors of #helpContributions for examples of how this goes."

	"ScriptingSystem initializeHelpStrings"

	| aDictionary |
	aDictionary _ IdentityDictionary new.  
	"For safety, the new copy is built up in this temp first, so that if an error occurs during the creation of the structure, the old version will remain remain in place"

	Morph withAllSubclasses do:
		[:aClass | (aClass class selectors includes: #helpContributions)
			ifTrue:
				[aClass helpContributions do:
					[:pair | aDictionary at: pair first put: pair second]]].

		HelpStrings _ aDictionary! !

!StandardScriptingSystem methodsFor: 'help dictionary' stamp: 'sw 1/12/1999 16:05'!
statusHelpString
	^	'normal -- run when called
paused -- ready to run all the time
ticking -- run all the time
mouseDown -- run when mouse goes down on me
mouseStillDown -- while mouse still down
mouseUp -- when mouse comes back up
mouseEnter -- when mouse enters my bounds, button up
mouseLeave -- when mouse exits my bounds, button up
mouseEnterDragging -- when mouse enters my bounds, button down
mouseLeaveDragging -- when mouse exits my bounds, button down
opening -- when I am being opened
closing -- when I am being closed'
"'keyStroke -- run when user hits a key' "! !


!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 16:33'!
allClassVarNamesInSystem
	"Compute and answer a set of all the class variable names known to the sytem from any class"

	| aList |
	aList _ OrderedCollection new.
	Object withAllSubclasses do:
		[:c | aList addAll: c allClassVarNames].
	^ aList asSet

	"ScriptingSystem allClassVarNamesInSystem"
! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 16:37'!
allKnownClassVariableNames
	"Answer a set of all the knwon class variable names in the system.  This normally retrieves them from a cache, and at present there is no organized mechanism for invalidating the cache.  The idea is to avoid, in the References scheme, names that may create a conflict"

	^ ClassVarNamesInUse ifNil: [ClassVarNamesInUse _ self allClassVarNamesInSystem]

	"ClassVarNamesInUse _ nil.
	Time millisecondsToRun: [ScriptingSystem allKnownClassVariableNames]"
! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/21/2000 22:37'!
arithmeticalOperatorsAndHelpStrings
	"Answer an array consisting of lists of the standard arithmetical operator tiles and of the corresponding balloon help for them"

	^ #((+ - * / // \\ max: min:)
	 	('add' 'subtract' 'multiply' 'divide' 'divide & truncate' 'remainder when divided by' 'larger value' 'smaller value'))! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'tk 8/21/2000 12:59'!
cleanupsForRelease
	"Miscellaneous space cleanups to do before a release."
	"EToySystem cleanupsForRelease"

	Socket deadServer: ''.  "Don't reveal any specific server name"
	HandMorph initialize.  "free cached ColorChart"
	PaintBoxMorph initialize.	"forces Prototype to let go of extra things it might hold"
	Smalltalk removeKey: #AA ifAbsent: [].
	Smalltalk removeKey: #BB ifAbsent: [].
	Smalltalk removeKey: #CC ifAbsent: [].
	Smalltalk removeKey: #DD ifAbsent: [].
	Smalltalk removeKey: #Temp ifAbsent: [].

	ScriptingSystem reclaimSpace.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	Smalltalk forgetDoIts.
	Smalltalk removeEmptyMessageCategories.
	Symbol rehash! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/21/2000 20:29'!
customizeForEToyUsers: aBoolean
	"If aBoolean is true, set things up for etoy users.  If it's false, unset some of those things.  Some things are set when switching into etoy mode but not reversed when switching out of etoy mode"
 
	#(	
		(balloonHelpEnabled			yes		dontReverse)
		(debugHaloHandle			no		reverse)
		(modalColorPickers			yes		dontReverse)
		(uniqueNamesInHalos		yes		reverse)
		(useUndo					yes		dontReverse)
		(infiniteUndo				no		dontReverse)
		(warnIfNoChangesFile		no		reverse)
		(warnIfNoSourcesFile		no		reverse)) do:
			[:trip |
				(aBoolean or: [trip third == #reverse]) ifTrue:
					[Preferences enableOrDisable: trip first asPer:
						((trip second == #yes) & aBoolean) | ((trip second == #no) & aBoolean not)]]! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/7/2000 14:08'!
getterSelectorFor: identifier
	"Some idiosyncratic substitutions here..."

	| aSymbol |
	(aSymbol _ identifier asSymbol) == #isOverColor: ifTrue: [^ #seesColor:].
	aSymbol == #copy ifTrue: [^ #getNewClone].

	^ Utilities getterSelectorFor: aSymbol! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/21/2000 22:38'!
helpStringForOperator: anOperator
	"Answer the help string associated with the given operator"

	| anIndex opsAndHelp |
	(anIndex _ (opsAndHelp _ self arithmeticalOperatorsAndHelpStrings) first indexOf: anOperator) > 0
		ifTrue:	[^ opsAndHelp second at: anIndex].

	(anIndex _ (opsAndHelp _ self numericComparitorsAndHelpStrings) first indexOf: anOperator) > 0
		ifTrue:	[^ opsAndHelp second at: anIndex].

	^ 'And I called my cow, no help now' 
	"This should never be seen, but if it is, we should hear the moo eventually"! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'ar 11/9/2000 20:44'!
holderWithAlphabet
	"Answer a fully instantiated Holder that has submorphs that represent the letters of the uppercase alphabet, with each one having an 'index' slot which bears the letter's index in the alphabet -- 1 for A, 2 for B, etc.   A few special characters are provided as per ack request 10/00; for these the index provided is rather arbitrarily assigned"

	| aMorph aPlayer newMorph oneCharString aContainer aWrapper |

	"ScriptingSystem holderWithAlphabet openInHand"

	aContainer _ self prototypicalHolder useRoundedCorners.
	aContainer borderColor: Color blue lighter.

	aWrapper _ AlignmentMorph new hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0.
	aWrapper addMorphBack: (aMorph _ TextMorph new contents: 'A').
	aMorph beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 24).
	aMorph width: 14; lock.
	aWrapper beTransparent; setNameTo: 'A'.
	aPlayer _ aWrapper assuredPlayer.
	aPlayer addInstanceVariableNamed: #index type: #number value: 1.
	aContainer addMorphBack: aWrapper.
	2 to: 26 do:
		[:anIndex |
			newMorph _ aWrapper usableSiblingInstance.
			newMorph player perform: #setIndex: with: anIndex.
			newMorph firstSubmorph contents: (oneCharString _ ($A asciiValue + anIndex - 1) asCharacter asString).
			newMorph setNameTo: oneCharString.

			aContainer addMorphBack: newMorph].

	#(' ' '.' '#') with: #(27 28 29) do:
		[:aString :anIndex |
			newMorph _ aWrapper usableSiblingInstance.
			newMorph player perform: #setIndex: with: anIndex.
			newMorph firstSubmorph contents: aString.
			aString = ' '
				ifTrue:
					[newMorph setNameTo: 'space'.
					newMorph color: (Color gray alpha: 0.2)]
				ifFalse:
					[newMorph setNameTo: aString].
			aContainer addMorphBack: newMorph].

	aContainer setNameTo: 'alphabet'.
	aContainer isPartsBin: true.
	aContainer enableDrop: false.
	aContainer indicateCursor: false; width: 162.
	aContainer color: (Color r: 0.839 g: 1.0 b: 1.0).  "Color fromUser"
	^ aContainer! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/15/2000 06:24'!
informScriptingUser: aString
	"This provides a hook for logging messages that the user or the developer may wish to see; at present it simply logs the message to the Transcript, with a standard prefix to signal their provenance.  Such messages will fall on the floor if there is no Transcript window open"

	Transcript cr; show: 'SCRIPT NOTE: ', aString! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'RAA 9/19/2000 12:20'!
newScriptingSpace
	"Answer a complete scripting space"

	| aTemplate  palette aPlayfield aWindow itsModel |

	"19 sept 2000 - experiment for Alan"
	1 = 1 ifTrue: [^self newScriptingSpace2].

	aWindow _ (SystemWindow labelled: 'scripting area') model: (itsModel _ ScriptingDomain new).
	aWindow setStripeColorsFrom: itsModel defaultBackgroundColor.
	aWindow extent: 640 @ 480.
	aTemplate _ PasteUpMorph new setNameTo: 'etoy'.
	aTemplate extent: 638 @ 470.
	aWindow addMorph: aTemplate frame: (0@0 corner: 1@1).
	aTemplate setStandardTexture.
	aTemplate impartPrivatePresenter; setProperty: #automaticPhraseExpansion toValue: true; beSticky.
	aTemplate presenter addStopStepGoButtons; addTrashCan.

	palette _ TabbedPalette new pageSize: 200@320.
	palette beSticky; useRoundedCorners.
	aTemplate addMorph: palette.
	palette addMenuTab.
	palette addPartsTab.
	palette addControlsTab.
	palette addTilesTab.
	palette selectTabNamed: 'supplies'.
	palette becomeStandardPalette.
	aPlayfield _ PasteUpMorph new setNameTo: 'playfield'.
	aPlayfield useRoundedCorners.
	(Preferences valueOfFlag: #eToyScheme)  "Not widely advertised"
		ifFalse:	
			[aPlayfield setToAdhereToEdge: #topRight.
			palette setToAdhereToEdge: #topLeft]
		ifTrue:
			[aPlayfield setToAdhereToEdge: #topLeft.
			palette setToAdhereToEdge: #topRight].

	aTemplate addMorph: aPlayfield.
	aPlayfield extent: 340@300; position: aTemplate topRight - (400@0).
	aPlayfield beSticky.
	aPlayfield automaticViewing: true.
	aPlayfield wantsMouseOverHalos: true.
	aTemplate presenter standardPlayfield: aPlayfield.
	
	^ aWindow

! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'RAA 9/20/2000 19:00'!
newScriptingSpace2
	"Answer a complete scripting space"

	| aTemplate  aPlayfield |
	
	(aTemplate _ PasteUpMorph new)
		setNameTo: 'etoy';
		extent: 638 @ 470;
		color: Color white;
		impartPrivatePresenter;
		setProperty: #automaticPhraseExpansion toValue: true;
		beSticky.
	aTemplate presenter addStopStepGoButtons; addTrashCan.

	aTemplate addMorph: (aPlayfield _ PasteUpMorph new).
	aPlayfield
		setNameTo: 'playfield';
		useRoundedCorners;
		setToAdhereToEdge: #topLeft;
		extent: 340@300;
		position: aTemplate topRight - (400@0);
		beSticky;
		automaticViewing: true;
		wantsMouseOverHalos: true.
	aTemplate presenter standardPlayfield: aPlayfield.
	
	^ aTemplate

! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/21/2000 22:39'!
numericComparitorsAndHelpStrings
	"Answer an array whose first element is the list of comparitors, and whose second element is a list of the corresponding help strings"

	^ #((< <= = ~= > >= isDivisibleBy:)
	 	('less than' 'less than or equal' 'equal' 'not equal' 'greater than' 'greater than or equal' 'divisible by' ))! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'di 9/16/1998 00:38'!
prepareForExternalReleaseNamed: aReleaseName
	"ScriptingSystem prepareForExternalReleaseNamed: '2.2Beta'"

	EToySystem stripMethodsForExternalRelease.

	self class compile: 'guessDOLProxy
	"deleted for external release"' classified: 'stripped'.

	ScriptingSystem saveFormsToFileNamed: aReleaseName, '.Dis.Forms'.
	ScriptingSystem stripGraphicsForExternalRelease.
	ScriptingSystem cleanupsForRelease.
	ScreenController initialize.
! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 5/2/1998 14:17'!
reclaimSpace
	"Reclaim space from the scripting system, and report the result in an informer"
	"ScriptingSystem reclaimSpace"

	| reclaimed |
	(reclaimed _ self spaceReclaimed)  > 0
		ifTrue:	[self inform: reclaimed printString, ' bytes reclaimed']
		ifFalse:	[self inform: 'Hmm...  Nothing gained this time.']! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 09:08'!
referenceAt: aSymbol
	"Answer the object referred to by aSymbol in the 'References' scheme of things, or nil if none"

	^ References at: aSymbol ifAbsent: [nil]! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 09:33'!
referenceAt: aSymbol put: anObject
	"Store a reference to anObject at the given symbol in the References directory"

	^ References at: aSymbol put: anObject! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 6/9/2000 18:44'!
reinvigorateThumbnailsInViewerFlapTabs
	"It has happened that the thumbnail in a viewer flap tab will go solid gray because it got associated with some passing and disused player temporarily created during the initial painting process.  This method takes a sledge hammer to repair such thumbnails.   At its genesis, this method is called only from the postscript of its defining fileout."
	| vwr thumbnail |
	ViewerFlapTab allInstancesDo:
		[:aTab | 
			vwr _ aTab referent findA: StandardViewer.
			thumbnail _ aTab findA: ThumbnailMorph.
			(vwr notNil and: [thumbnail notNil]) ifTrue:
				[thumbnail objectToView: vwr scriptedPlayer]]

	"ScriptingSystem reinvigorateThumbnailsInViewerFlapTabs"! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 16:47'!
resetAllScriptingReferences
	"Clear out all the elements in the References directory"
	
	Smalltalk at: #References put: IdentityDictionary new

	"ScriptingSystem resetAllScriptingReferences"! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 16:45'!
resetStaleScriptingReferences
	"Remove all scripting references that are no longer needed"

	References  removeUnreferencedKeys

	"ScriptingSystem resetStaleScriptingReferences"
! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 1/12/1999 16:05'!
setterSelectorFor: aSymbol
	^ Utilities setterSelectorFor: aSymbol! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 5/3/1998 19:14'!
spaceReclaimed
	"Reclaim space from the EToy system, and return the number of bytes reclaimed"
	"ScriptingSystem spaceReclaimed"

	| oldFree  |
	oldFree _ Smalltalk garbageCollect.
	ThumbnailMorph recursionReset.
	MorphicModel removeUninstantiatedSubclassesSilently.
	Player removeUninstantiatedSubclassesSilently.
	Smalltalk cleanOutUndeclared.
	Smalltalk reclaimDependents.
	^ Smalltalk garbageCollect - oldFree.! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/14/1998 14:39'!
standardEventStati
	^ #(mouseDown mouseStillDown mouseUp mouseEnter mouseLeave mouseEnterDragging mouseLeaveDragging keyStroke)! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 11/26/1999 15:44'!
stripGraphicsForExternalRelease
	"ScriptingSystem stripGraphicsForExternalRelease"

	|  replacement |
	replacement _ FormDictionary at: #Gets.

	#('BadgeMiniPic' 'BadgePic' 'Broom' 'CedarPic' 'CollagePic' 'CoverMain' 'CoverSpiral' 'CoverTexture' 'Fred' 'ImagiPic' 'KayaPic' 'StudioPic')
		do:
			[:aKey | FormDictionary at: aKey asSymbol put: replacement]! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 5/18/1998 17:53'!
tryButtonFor: aPhraseTileMorph
	| aButton |
	aButton _ SimpleButtonMorph new.
	aButton target: aPhraseTileMorph; actionSelector: #try; label: '!!' font: (StrikeFont familyName: #ComicBold size: 16); color: Color yellow; borderWidth: 0.
	aButton actWhen: #whilePressed.
	aButton balloonTextSelector: #try.
	^ aButton! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 1/12/1999 16:05'!
typeForSystemSlotNamed: aName
	^ SystemSlotDictionary at: aName ifAbsent: [nil]

"
ScriptingSystem typeForSystemSlotNamed: #colorSees
ScriptingSystem typeForSystemSlotnamed: #frog
"! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 10/30/2000 09:07'!
uniqueNameForReference
	"Answer a more-or-less global name by which the receiver can be referred to in scripts"

	^ #ScriptingSystem! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 1/13/1999 13:14'!
wordingForAssignmentSuffix: aString
	| toTest |

	toTest _ aString asString.
	#(	(':'					'_')
		('Incr:'				'increase by')
		('Decr:'				'decrease by')
		('Mult:'				'multiply by'))
	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].
	^ toTest

	"ScriptingSystem wordingForAssignmentSuffix: 'Incr:'"! !

!StandardScriptingSystem methodsFor: 'utilities' stamp: 'sw 9/1/2000 10:39'!
wordingForOperator: aString
	"Answer the wording to be seen by the user for the given operator symbol/string"

	| toTest |
	"StandardScriptingSystem initialize"
	toTest _ aString asString.
	#(	(append:				'append')
		(beep:					'make sound')
		(bounce:				'bounce')
		(clearTurtleTrails		'clear pen trails')
		(doMenuItem:			'do menu item')
		(forward:				'forward by')
		(moveToward:			'move toward')
		(goToRightOf:			'align after')
		(isDivisibleBy:			'is divisible by')
		(liftAllPens				'lift all pens')
		(lowerAllPens			'lower all pens')
		(pauseScript:			'pause script')
		(max:					'max')
		(min:					'min')
		(seesColor:				'is over color')
		(makeNewDrawingIn:	'start painting in')
		(startScript:				'start script')
		(stopProgramatically	'stop')
		(stopScript:				'stop script')
		(turn:					'turn by')
		(wearCostumeOf:		'look like'))

	do:
		[:pair | toTest = pair first ifTrue: [^ pair second]].

	^ toTest! !


!StandardScriptingSystem methodsFor: 'parts bin' stamp: 'sw 11/16/1998 08:50'!
customPartsBin
	CustomPartsBin ifNil:
		[self inform: 
'There is no custom parts bin yet.
To create one, start with a Standard Parts Bin, 
and modify it as you wish, and then choose
''Save as Custom Parts Bin'' from the
parts-window-controls menu, which
will be found in the halo menu of
any parts-bin window'.
	^ nil].

	^ CustomPartsBin veryDeepCopy! !

!StandardScriptingSystem methodsFor: 'parts bin' stamp: 'sw 5/5/1999 16:03'!
newStandardPartsBin
	"StandardPartsBin _ nil.  self currentWorld presenter createStandardPartsBin"

	StandardPartsBin ifNil:
		[BookMorph turnOffSoundWhile:
			[StandardPartsBin _ Presenter new newStandardPartsBinTitled: 'objects' includeControls: false]].
	^ StandardPartsBin fullCopy! !

!StandardScriptingSystem methodsFor: 'parts bin' stamp: 'sw 5/3/1999 22:40'!
prototypicalHolder
	| aHolder |
	aHolder _ PasteUpMorph authoringPrototype color: Color orange muchLighter; borderColor: Color orange lighter.
	aHolder setNameTo: 'holder'; extent: 160 @ 110.
	^ aHolder behaveLikeHolder.
! !

!StandardScriptingSystem methodsFor: 'parts bin' stamp: 'sw 10/27/1998 13:35'!
resetStandardPartsBin
	"ScriptingSystem resetStandardPartsBin"

	StandardPartsBin _ nil! !

!StandardScriptingSystem methodsFor: 'parts bin' stamp: 'sw 11/16/1998 08:47'!
setCustomPartsBinFrom: aMorph
	"Establish aMorph as the custom parts bin.  Normally triggered by use menu action, but can also be used to reset the custom parts bin to undefined"

	CustomPartsBin _ aMorph

	"ScriptingSystem setCustomPartsBinFrom: nil"
! !


!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 9/8/2000 17:21'!
acceptableScriptNameFrom: originalString forScriptCurrentlyNamed: currentName asScriptNameIn: aPlayer world: aWorld
	"Produce an acceptable script name, derived from the current name, for aPlayer.  This method will always return a valid script name that will be suitable for use in the given situation, though you might not like its beauty sometimes."

	| aString stemAndSuffix proscribed stem suffix putative |
	aString _ originalString asIdentifier: false.  "get an identifier not lowercase"
	stemAndSuffix _ aString stemAndNumericSuffix.
	proscribed _ #(self super thisContext costume costumes dependents true false size).

	stem _ stemAndSuffix first.
	suffix _ stemAndSuffix last.
	putative _ aString asSymbol.

	[(putative ~~ currentName) and: [(proscribed includes: putative)
		or:	[(aPlayer class tileScriptNames includes: putative)
		or: [(aPlayer respondsTo: putative)
		or: [(SystemSlotDictionary includesKey: putative)
		or: [(ReservedScriptNames includes: putative)
		or:	[Smalltalk includesKey: putative]]]]]]]
	whileTrue:
		[suffix _ suffix + 1.
		putative _ (stem, suffix printString) asSymbol].
	^ putative! !

!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 9/8/2000 17:20'!
acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: currentName asSlotNameIn: aPlayer world: aWorld
	"Produce an acceptable slot name, derived from the current name, for aPlayer.  This method will always return a valid slot name that will be suitable for use in the given situation, though you might not like its beauty sometimes."

	| aString stemAndSuffix proscribed stem suffix putative |
	aString _ originalString asIdentifier: false.  "get an identifier not lowercase"
	stemAndSuffix _ aString stemAndNumericSuffix.
	proscribed _ #(self super thisContext costume costumes dependents true false size), aPlayer class allInstVarNames.

	stem _ stemAndSuffix first.
	suffix _ stemAndSuffix last.
	putative _ aString asSymbol.
	
	[(putative ~~ currentName) and: [(proscribed includes: putative)
		or:	[(aPlayer class tileScriptNames includes: putative)
		or: [(aPlayer respondsTo: putative)
		or: [(SystemSlotDictionary includesKey: putative)
		or: [(ReservedScriptNames includes: putative)
		or:	[Smalltalk includesKey: putative]]]]]]]
	whileTrue:
		[suffix _ suffix + 1.
		putative _ (stem, suffix printString) asSymbol].
	^ putative! !

!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 12/30/1998 14:11'!
doesOperatorWantArrows: aSymbol
	^ aSymbol isInfix or: [#(isDivisibleBy:) includes: aSymbol]! !

!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 9/8/2000 17:13'!
initializeSystemSlotDictionary
	"Initialize a structure that gives names and types for all the slots and pseudo-slots defined in the current scripting vocabulary.  The keys to this dictionary are slot-name-symbols, and the values are value-type-symbols"

	| aDictionary additions |
	"ScriptingSystem initializeSystemSlotDictionary"
	aDictionary _ IdentityDictionary new.
	Morph withAllSubclasses do:
		[:aClass |
			(aClass class includesSelector: #additionsToViewerCategories) ifTrue:
				[additions _ aClass additionsToViewerCategories.
				additions do:
					[:catNameAndInfo |
						catNameAndInfo second do:
							[:spec | (spec first == #slot) ifTrue:
								[aDictionary at: spec second put: spec fourth]]]]].

	SystemSlotDictionary _ aDictionary! !

!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 9/8/2000 18:22'!
isAcceptablePlayerSlotName: aSymbol
	"Answer whether the given symbol is a suitable slot name for a player.  It is assumed to be a well-formed inst-var-name already.  No senders at the moment, because the current UI always corrects the input into an acceptable name.  But could return"

	self noOtherSenders: #isAcceptablePlayerSlotName:.  "keeps this from getting mentally garbage-collected"

	(SystemSlotDictionary includesKey: aSymbol) ifTrue: [^ false].
	(ReservedScriptNames includes: aSymbol) ifTrue: [^ false].

	(#(costume costumes dependents true false size) includes: aSymbol) ifTrue: [^ false].
	^ true! !

!StandardScriptingSystem methodsFor: 'universal slots & scripts' stamp: 'sw 9/8/2000 17:10'!
isSystemScriptName: aName
	"Answer whether the given name is a reserved script name"

	^ ReservedScriptNames includes: aName asSymbol! !


!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 3/7/1999 00:53'!
goButton
	| aButton |
	aButton _  ThreePhaseButtonMorph new.
	aButton image:  (ScriptingSystem formAtKey: 'GoPicOn');
			offImage: (ScriptingSystem formAtKey: 'GoPic');
			pressedImage: (ScriptingSystem formAtKey: 'GoPicOn');
			actionSelector: #goUp:with:; 
			arguments: (Array with: nil with: aButton);
			actWhen: #buttonUp;
			target: self;
			setNameTo: 'Go Button';
			setBalloonText:
'Resume running all paused scripts'.
	^ aButton! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 11/11/1998 15:24'!
goUp: evt with: aGoButton
	aGoButton presenter startRunningScriptsFrom: aGoButton! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 1/23/2001 11:39'!
scriptControlButtons
	"Answer a composite object that serves to control the stop/stop/go status of a Presenter"

	| wrapper |
	wrapper _ AlignmentMorph newRow setNameTo: 'script controls'.
	wrapper vResizing: #shrinkWrap.
	wrapper hResizing: #shrinkWrap.
	wrapper addMorph: self stopButton.
	wrapper addMorphBack: self stepButton.
	wrapper addMorphBack: self goButton.
	wrapper beTransparent.
	^ wrapper! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 3/7/1999 00:53'!
stepButton
	| aButton |
	self flag: #deferred.  "ambiguity about recipients"
	aButton _ ThreePhaseButtonMorph new.
		aButton
			image:  (ScriptingSystem formAtKey: 'StepPicOn');
			offImage: (ScriptingSystem formAtKey: 'StepPic');
			pressedImage:  (ScriptingSystem formAtKey: 'StepPicOn');
			arguments: (Array with: nil with: aButton);
		 	actionSelector: #stepStillDown:with:; 
			target: self;
			setNameTo: 'Step Button'; 
			actWhen: #whilePressed;
			on: #mouseDown send: #stepDown:with: to: self;
			on: #mouseStillDown send: #stepStillDown:with: to: self;
			on: #mouseUp send: #stepUp:with: to: self;
			setBalloonText:
'Run every paused script exactly once.  Keep the mouse button down over "Step" and everything will keep running until you release it'.
	^ aButton! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 10/30/1998 15:33'!
stepDown: evt with: aMorph
	aMorph presenter stopRunningScripts! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 10/30/1998 15:35'!
stepStillDown: dummy with: theButton
	theButton presenter stepStillDown: dummy with: theButton! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 10/30/1998 15:35'!
stepUp: evt with: aMorph
	aMorph presenter stepUp: evt with: aMorph! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 3/7/1999 00:53'!
stopButton
	"Answer a new button that can serve as a stop button"
	| aButton |
	aButton _ ThreePhaseButtonMorph new.
	aButton
		image:  (ScriptingSystem formAtKey: 'StopPic');
		offImage: (ScriptingSystem formAtKey: 'StopPic');
		pressedImage:  (ScriptingSystem formAtKey: 'StopPicOn').
		aButton actionSelector: #stopUp:with:; 
		arguments: (Array with: nil with: aButton);
		actWhen: #buttonUp;
		target: self;
		setNameTo: 'Stop Button'; 
		setBalloonText: 'Pause all ticking scripts.'.
	^ aButton! !

!StandardScriptingSystem methodsFor: 'script-control' stamp: 'sw 11/11/1998 15:16'!
stopUp: dummy with: theButton
	| aPresenter |
	(aPresenter _ theButton presenter) flushPlayerListCache.  "catch guys not in cache but who're running"
	aPresenter stopRunningScriptsFrom: theButton! !


!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 10/29/1998 16:30'!
brightColorFor: aColor
	TypeColorDictionary do: [:pair |
		(pair at: 1) = aColor ifTrue: [^ (pair at: 2)]].
	^ aColor
! !

!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 11/10/1998 18:18'!
brightColorForType: typeSymbol
	^ (TypeColorDictionary
		at: typeSymbol asSymbol
		ifAbsent: [^ Color magenta]) at: 2
! !

!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 10/30/2000 09:56'!
colorForType: typeSymbol
	"Answer the color to use to represent the given type symbol"

	^ ((TypeColorDictionary
		at: typeSymbol asSymbol
		ifAbsent: [^ Color magenta muchLighter]) at: 1) lighter
! !

!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 10/29/1998 16:18'!
colorFudge
	^ 0.4! !

!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 10/30/2000 16:38'!
initializeTypeColors
	"Initialize the list of hard-coded type colors.  The list of types is nascent and there are some not-yet-deployed types mentioned.  Think of nothing here as sacred."

	"ScriptingSystem initializeTypeColors"

	TypeColorDictionary _ IdentityDictionary new.

	#((command		(0.065 0.258 1.0)			(0.065 0.258 1.0))
	(number		(0.8 0.4 0.2)				(1.0	0.6 0.2))
	(boolean		(0.94 1.0 0.06)			(0.94 1.0 0.06))  		"some kind of yellowish"
	(player			(1.0  0 0.065)			(1.0  0 0.065)) 
	(string			(0.0 0.0 1.0)				(0.0 0.0 1.0))     	"not in use"
	(color			(1.0  0 0.065)			(0.806 1.0 0.806))  	"some damn dark red"
	(sound			(1.0 0.06 0.84)			(1.0 0.06 0.84))   	"a kind of magenta"
	(buttonPhase	(0.806 1.0 0.806)			(0.806 1.0 0.806))	"arbitrary"
	(menu			(0.4 0.4 0.4)				(0.4 0.4 0.4))		"arbitrary"

	(object			(1.0 0.26 0.98)			(1.0 0.26 0.98))   	"backstop"
	(rotationStyle	(1.0 0.26 0.98)			(1.0 0.26 0.98))   	"future"
	
	(group			(0.0 0.0 1.0)				(0.0 0.0 1.0))		 "not in use"
	(costume		(0.806 1.0 0.806)			(0.806 1.0 0.806))	 "not in use") do:
		[:triplet | TypeColorDictionary at: triplet first put:
			(Array 	with: 	((Color fromRgbTriplet: triplet second) mixed: self colorFudge with: ScriptingSystem uniformTileInteriorColor)
					with:	(Color fromRgbTriplet: triplet third))]! !

!StandardScriptingSystem methodsFor: 'tile colors' stamp: 'sw 10/29/1998 16:01'!
unbrightColorFor: aColor
	TypeColorDictionary do: [:pair |
		(pair at: 2) = aColor ifTrue: [^ (pair at: 1)]].
	^ aColor
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardScriptingSystem class
	instanceVariableNames: ''!

!StandardScriptingSystem class methodsFor: 'class initialization' stamp: 'sw 9/8/2000 17:19'!
initialize
	"Initialize the scripting system.  Sometimes this method is vacuously changed just to get it in a changeset so that its invocation will occur as part of an update"

	(Smalltalk at: #ScriptingSystem ifAbsent: [nil]) ifNil:
		[Smalltalk at: #ScriptingSystem put: self new].

	ScriptingSystem
		initReservedScriptNames;
		initializeSystemSlotDictionary;
		initializeHelpStrings

"StandardScriptingSystem initialize"! !
SourceFileArray subclass: #StandardSourceFileArray
	instanceVariableNames: 'files '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!StandardSourceFileArray commentStamp: '<historical>' prior: 0!
This class implements the source file management behavior of traditional Squeak, with a sources file and a changes file. File positions are mapped such that those files can be up to 32MBytes in size.

Structure:
 files		Array -- storing the actual source files
!


!StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'hmm 4/25/2000 21:20'!
initialize
	files _ Array new: 2.
	files at: 1 put: (SourceFiles at: 1).
	files at: 2 put: (SourceFiles at: 2)! !

!StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'ar 5/17/2000 18:28'!
initialize: nFiles
	files _ Array new: nFiles! !


!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
at: index
	^files at: index! !

!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
at: index put: aFile
	files at: index put: aFile! !

!StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'!
size
	^files size! !


!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:44'!
fileIndexFromSourcePointer: anInteger
	"Return the index of the source file which contains the source chunk addressed by anInteger"
	"This implements the recent 32M source file algorithm"

	| hi |
	hi _ anInteger // 16r1000000.
	^hi < 3
		ifTrue: [hi]
		ifFalse: [hi - 2]! !

!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:44'!
filePositionFromSourcePointer: anInteger
	"Return the position of the source chunk addressed by anInteger"
	"This implements the recent 32M source file algorithm"

	| hi lo |
	hi _ anInteger // 16r1000000.
	lo _ anInteger \\ 16r1000000.
	^hi < 3
		ifTrue: [lo]
		ifFalse: [lo + 16r1000000]! !

!StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:48'!
sourcePointerFromFileIndex: index andPosition: position
	| hi lo |
	"Return a source pointer according to the new 32M algorithm"
	((index between: 1 and: 2) and: [position between: 0 and: 16r1FFFFFF])
		ifFalse: [self error: 'invalid source code pointer'].
	hi _ index.
	lo _ position.
	lo >= 16r1000000 ifTrue: [
		hi _ hi+2.
		lo _ lo - 16r1000000].
	^hi * 16r1000000 + lo! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSourceFileArray class
	instanceVariableNames: ''!

!StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'hmm 4/25/2000 21:19'!
install
	"Replace SourceFiles by an instance of me with the standard sources and changes files.
	This only works if SourceFiles is either an Array or an instance of this class"
	"StandardSourceFileArray install"
	SourceFiles _ self new initialize! !

!StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'ar 5/17/2000 18:27'!
new: nFiles
	^self new initialize: nFiles.! !
MouseMenuController subclass: #StandardSystemController
	instanceVariableNames: 'status '
	classVariableNames: 'HBorderCursor ScheduledBlueButtonMenu ScheduledBlueButtonMessages VBorderCursor '
	poolDictionaries: ''
	category: 'ST80-Support'!
!StandardSystemController commentStamp: '<historical>' prior: 0!
I am a controller for StandardSystemViews, that is, those views that are at the top level of a project in the system user interface. I am a kind of MouseMenuController that creates a blue button menu for moving, framing, collapsing, and closing ScheduledViews, and for selecting views under the view of my instance.!


!StandardSystemController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 11:48'!
initialize
	super initialize.
	status _ #inactive! !


!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:01'!
blueButtonActivity
	ScheduledBlueButtonMenu ifNil: [^ super controlActivity].
	ScheduledBlueButtonMenu invokeOn: self! !

!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:20'!
controlActivity
	self checkForReframe.
	^ super controlActivity! !

!StandardSystemController methodsFor: 'control defaults'!
isControlActive
	status == #active ifFalse: [^ false].
	sensor anyButtonPressed ifFalse: [^ true].
	self viewHasCursor
		ifTrue: [^ true]
		ifFalse: [ScheduledControllers noteNewTop.
				^ false]! !

!StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/15/2000 22:19'!
redButtonActivity
	"If cursor is in label of a window when red button is pushed,
	check for closeBox or growBox, else drag the window frame
	or edit the label."

	| box p |
	p _ sensor cursorPoint.
	self labelHasCursor ifFalse: [super redButtonActivity. ^ self].
	((box _ view closeBoxFrame) containsPoint: p)
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed: [self close. ^ self].
			^ self].
	((box _ view growBoxFrame) containsPoint: p)
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed:
					[Sensor controlKeyPressed ifTrue: [^ self expand; fullScreen].
					^ view isCollapsed
						ifTrue: [self expand]
						ifFalse: [self collapse]].
			^ self].
	(((box _ view labelTextRegion expandBy: 1) containsPoint: p)
			and: [Preferences clickOnLabelToEdit or: [sensor leftShiftDown]])
		ifTrue:
			[Utilities
				awaitMouseUpIn: box
				repeating: []
				ifSucceed: [^ self label].
			^ self].
	self move! !


!StandardSystemController methodsFor: 'basic control sequence' stamp: 'sw 10/20/1999 09:52'!
controlInitialize
	view displayEmphasized.
	view uncacheBits.  "Release cached bitmap while active"
	model windowActiveOnFirstClick ifFalse: [sensor waitNoButton].
	status _ #active.
	view isCollapsed ifFalse: [model modelWakeUpIn: view]! !

!StandardSystemController methodsFor: 'basic control sequence' stamp: 'di 5/11/1999 22:05'!
controlTerminate
	status == #closed
		ifTrue: 
			[view ~~ nil ifTrue: [view release].
			ScheduledControllers unschedule: self.
			^self].
	view deEmphasize; cacheBits.
	view isCollapsed ifFalse: [model modelSleep].! !


!StandardSystemController methodsFor: 'menu messages'!
chooseColor
	"Allow the user to specify a new background color for the receiver's window.  5/6/96 sw.
	 7/31/96 sw: use Color fromUser"

	view backgroundColor: Color fromUser; uncacheBits; display! !

!StandardSystemController methodsFor: 'menu messages'!
close
	"The receiver's view should be removed from the screen and from the 
	collection of scheduled views."

	model okToChange ifFalse: [^self].
	status _ #closed.
	view erase! !

!StandardSystemController methodsFor: 'menu messages'!
collapse
	"Get the receiver's view to change to a collapsed view on the screen."
	view collapseToPoint: view chooseCollapsePoint! !

!StandardSystemController methodsFor: 'menu messages'!
expand
	"The receiver's view was collapsed; open it again and ask the user to 
	designate its rectangular area."
	view expand; emphasize! !

!StandardSystemController methodsFor: 'menu messages' stamp: 'sw 9/30/97 21:42'!
forceClosed
	"The receiver's view should be removed from the screen and from the 
	collection of scheduled views."

	status _ #closed.
	view erase! !

!StandardSystemController methodsFor: 'menu messages' stamp: 'jm 4/28/1998 06:57'!
label

	| newLabel |
	newLabel _ FillInTheBlank
		request: 'Edit the label, then type RETURN'
		initialAnswer: view label.
	newLabel isEmpty ifFalse: [view relabel: newLabel].
! !

!StandardSystemController methodsFor: 'menu messages'!
move
	"Ask the user to designate a new origin position for the receiver's view.
	6/10/96 sw: tell the view that it has moved"

	| oldBox | 
	oldBox _ view windowBox.
	view uncacheBits.
	view align: view windowBox topLeft
		with: view chooseMoveRectangle topLeft.
	view displayEmphasized.
	view moved.  "In case its model wishes to take note."
	(oldBox areasOutside: view windowBox) do:
		[:rect | ScheduledControllers restore: rect]! !

!StandardSystemController methodsFor: 'menu messages'!
reframe
	^ view reframeTo: view getFrame! !

!StandardSystemController methodsFor: 'menu messages'!
toggleTwoTone
	(view isMemberOf: StandardSystemView) ifTrue:
		[^ view become: (view as: ColorSystemView)].
	(view isMemberOf: ColorSystemView) ifTrue:
		[^ view become: (view as: StandardSystemView)].
! !

!StandardSystemController methodsFor: 'menu messages'!
under
	"Deactive the receiver's scheduled view and pass control to any view that 
	might be positioned directly underneath it and the cursor."

	status _ #inactive! !


!StandardSystemController methodsFor: 'scheduling' stamp: 'sw 9/30/97 22:04'!
closeAndUnschedule
	"Erase the receiver's view and remove it from the collection of scheduled 
	views."

	status _ #closed.
	view erase.
	view release.
	ScheduledControllers unschedule: self; searchForActiveController
! !

!StandardSystemController methodsFor: 'scheduling'!
closeAndUnscheduleNoErase
	"Remove the scheduled view from the collection of scheduled views. Set 
	its status to closed but do not erase."

	status _ #closed.
	view release.
	ScheduledControllers unschedule: self! !

!StandardSystemController methodsFor: 'scheduling' stamp: 'jm 3/18/98 19:21'!
closeAndUnscheduleNoTerminate
	"Erase the receiver's view and remove it from the collection of scheduled views, but do not terminate the current process."

	status _ #closed.
	view erase.
	view release.
	ScheduledControllers unschedule: self.
! !

!StandardSystemController methodsFor: 'scheduling'!
open
	"Create an area on the screen in which the receiver's scheduled view can 
	be displayed. Make it the active view."

	view resizeInitially.
	status _ #open.
	ScheduledControllers scheduleActive: self! !

!StandardSystemController methodsFor: 'scheduling'!
openDisplayAt: aPoint 
	"Create an area with origin aPoint in which the receiver's scheduled 
	view can be displayed. Make it the active view."

	view align: view viewport center with: aPoint.
	view translateBy:
		(view displayBox amountToTranslateWithin: Display boundingBox).
	status _ #open.
	ScheduledControllers scheduleActive: self! !

!StandardSystemController methodsFor: 'scheduling' stamp: 'jm 10/22/97 08:16'!
openNoTerminate
	"Create an area in which the receiver's scheduled view can be displayed. 
	Make it the active view. Do not terminate the currently active process."

	view resizeInitially.
	status _ #open.
	ScheduledControllers scheduleActiveNoTerminate: self! !

!StandardSystemController methodsFor: 'scheduling'!
openNoTerminateDisplayAt: aPoint 
	"Create an area with origin aPoint in which the receiver's scheduled 
	view can be displayed. Make it the active view. Do not terminate the 
	currently active process."

	view resizeMinimumCenteredAt: aPoint.
	status _ #open.
	ScheduledControllers scheduleActiveNoTerminate: self! !

!StandardSystemController methodsFor: 'scheduling'!
status: aSymbol
	status _ aSymbol! !


!StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:45'!
adjustPaneBorders 
	| side sub newRect outerFrame |
	outerFrame _ view displayBox.
	side _ #none.
	VBorderCursor showWhile:
		[ [sub _ view subviewWithLongestSide: [:s | side _ s]
						near: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #left) | (side = #right)]]
			whileTrue: [
				self interActivityPause.
				sensor redButtonPressed ifTrue:
				[side = #left ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withLeft: sensor cursorPoint x)
								intersect: outerFrame]
						startingWith: sub displayBox].
				side = #right ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withRight: sensor cursorPoint x)
								intersect: outerFrame]
						startingWith: sub displayBox].
				view reframePanesAdjoining: sub along: side to: newRect]]].
	HBorderCursor showWhile:
		[ [sub _ view subviewWithLongestSide: [:s | side _ s]
						near: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #top) | (side = #bottom)]]
			whileTrue: [
				self interActivityPause.
				sensor redButtonPressed ifTrue:
				[side = #top ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withTop: sensor cursorPoint y)
								intersect: outerFrame]
						startingWith: sub displayBox].
				side = #bottom ifTrue:
					[newRect _ sub stretchFrame:
						[:f | (f withBottom: sensor cursorPoint y)
								intersect: outerFrame]
						startingWith: sub displayBox].
				view reframePanesAdjoining: sub along: side to: newRect]]]! !

!StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:42'!
adjustWindowBorders 
	| side |
	VBorderCursor showWhile:
		[ [side _ view displayBox sideNearestTo: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #left) | (side = #right)]]
			whileTrue:
			[(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue:
				[side = #left ifTrue:
					[view newFrame: [:f | f withLeft: sensor cursorPoint x]].
				side = #right ifTrue:
					[view newFrame: [:f | f withRight: sensor cursorPoint x]]].
			self interActivityPause]. ].
	HBorderCursor showWhile:
		[ [side _ view displayBox sideNearestTo: sensor cursorPoint.
		  self cursorOnBorder and: [(side = #top) | (side = #bottom)]]
			whileTrue:
			[(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue:
				[side = #top ifTrue:
					[view newFrame: [:f | f withTop: sensor cursorPoint y]].
				side = #bottom ifTrue:
					[view newFrame: [:f | f withBottom: sensor cursorPoint y]]].
		  self interActivityPause]]! !

!StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:38'!
adjustWindowCorners 
	| box cornerBox p clicked f2 |
	box _ view windowBox.
	clicked _ false.
	#(topLeft topRight bottomRight bottomLeft)
		do: [:readCorner |
			cornerBox _ ((box insetBy: 2) perform: readCorner) - (10@10) extent: 20@20.
			(cornerBox containsPoint: sensor cursorPoint)
				ifTrue: 
				["Display reverse: cornerBox."
				(Cursor perform: readCorner) showWhile:
					[[(cornerBox containsPoint: (p _ sensor cursorPoint))
						and: [(clicked _ sensor anyButtonPressed) not]]
						whileTrue: [ self interActivityPause ].
				"Display reverse: cornerBox."
				clicked ifTrue:
					[view newFrame:
						[:f | p _ sensor cursorPoint.
						readCorner = #topLeft ifTrue:
							[f2 _ p corner: f bottomRight].
						readCorner = #bottomLeft ifTrue:
							[f2 _ (f withBottom: p y) withLeft: p x].
						readCorner = #bottomRight ifTrue:
							[f2 _ f topLeft corner: p].
						readCorner = #topRight ifTrue:
							[f2 _ (f withTop: p y) withRight: p x].
						f2]]]]].
	^ clicked! !

!StandardSystemController methodsFor: 'borders'!
checkForReframe
	| cp |
	view isCollapsed ifTrue: [^ self].
	cp _ sensor cursorPoint.
	((view closeBoxFrame expandBy: 2) containsPoint: cp)
		| ((view growBoxFrame expandBy: 2) containsPoint: cp)
		ifTrue: [^ self].  "Dont let reframe interfere with close/grow"
	self adjustWindowCorners.
	self cursorOnBorder ifFalse: [^ self].
	((view insetDisplayBox insetBy: 2@2) containsPoint: cp)
		ifFalse: [^ self adjustWindowBorders].
	(view subviewWithLongestSide: [:s | ] near: cp) == nil
		ifFalse: [^ self adjustPaneBorders].! !

!StandardSystemController methodsFor: 'borders'!
cursorOnBorder 
	| cp i box |
	view isCollapsed ifTrue: [^ false].
	cp _ sensor cursorPoint.
	((view labelDisplayBox insetBy: (0@2 corner: 0@-2)) containsPoint: cp)
		ifTrue: [^ false].
	(i _ view subViews findFirst: [:v | v displayBox containsPoint: cp]) = 0
		ifTrue: [box _ view windowBox]
		ifFalse: [box _ (view subViews at: i) insetDisplayBox].
	^ ((box insetBy: 3) containsPoint: cp) not
		and: [(box expandBy: 4) containsPoint: cp]! !

!StandardSystemController methodsFor: 'borders'!
fullScreen
	"Make the receiver's window occupy jes' about the full screen.  6/10/96 sw"

	view fullScreen! !


!StandardSystemController methodsFor: 'cursor'!
labelHasCursor
	"Answer true if the cursor is within the window's label"
	^view labelContainsPoint: sensor cursorPoint! !


!StandardSystemController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:12'!
getPluggableYellowButtonMenu: shiftKeyState
	^ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSystemController class
	instanceVariableNames: ''!

!StandardSystemController class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 11:57'!
initialize
	"StandardSystemController initialize"

	ScheduledBlueButtonMenu _ SelectionMenu
		labels:
'edit label
choose color...
two-tone/full color
move
frame
full screen
collapse
close'
	lines: #(3 7)
	selections: #(label chooseColor toggleTwoTone move reframe fullScreen collapse close).

	VBorderCursor _ Cursor extent: 16@16 fromArray: #(
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010010000100000
		2r1010110000110000
		2r1011111111111000
		2r1010110000110000
		2r1010010000100000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000
		2r1010000000000000)
			offset: 0@0.
	HBorderCursor _ Cursor extent: 16@16 fromArray: #(
		2r1111111111111111
		2r0000000000000000
		2r1111111111111111
		2r0000000100000000
		2r0000001110000000
		2r0000011111000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000011111000000
		2r0000001110000000
		2r0000000100000000
		2r0000000000000000
		2r0000000000000000
		2r0000000000000000)
			offset: 0@0.! !
View subclass: #StandardSystemView
	instanceVariableNames: 'labelFrame labelText isLabelComplemented savedSubViews minimumSize maximumSize collapsedViewport expandedViewport labelBits windowBits bitsValid updatablePanes '
	classVariableNames: 'CacheBits LabelStyle '
	poolDictionaries: ''
	category: 'ST80-Support'!
!StandardSystemView commentStamp: '<historical>' prior: 0!
I represent a view that has a label above its top left corner. The text in the label identifies the kind of view. In addition to a label, I add control over the maximum and minimum size of the display box of my instance. My default controller is StandardSystemController. The elements of ScheduledControllers, the sole instance of ControlManager, are usually controllers for instances of me.!


!StandardSystemView methodsFor: 'initialize-release' stamp: 'sw 10/29/1999 12:58'!
initialize 
	"Refer to the comment in View|initialize."
	super initialize.
	labelFrame _ Quadrangle new.
	labelFrame region: (Rectangle origin: 0 @ 0 extent: 50 @ self labelHeight).
	labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	self label: nil.
	isLabelComplemented _ false.
	minimumSize _ 50 @ 50.
	maximumSize _ Display extent.
	collapsedViewport _ nil.
	expandedViewport _ nil.
	bitsValid _ false.
	updatablePanes _ #()! !

!StandardSystemView methodsFor: 'initialize-release'!
model: aModel
	"Set the receiver's model.  For a Standard System View, we also at this time get the default background color set up.  7/30/96 sw"
	super model: aModel.
	self setDefaultBackgroundColor! !

!StandardSystemView methodsFor: 'initialize-release' stamp: 'jm 8/20/1998 18:29'!
release

	model windowIsClosing.
	self isCollapsed ifTrue: [savedSubViews do: [:v | v release]].
	super release.
! !


!StandardSystemView methodsFor: 'testing'!
containsPoint: aPoint 
	"Refer to the comment in View|containsPoint:."

	^(super containsPoint: aPoint) | (self labelContainsPoint: aPoint)! !

!StandardSystemView methodsFor: 'testing'!
isCollapsed
	"Answer whether the receiver is collapsed (true) or expanded (false)."

	^savedSubViews ~~ nil! !

!StandardSystemView methodsFor: 'testing'!
labelContainsPoint: aPoint 
	"Answer TRUE if aPoint is in the label box."

	^self labelDisplayBox containsPoint: aPoint! !


!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:30'!
closeBoxFrame
	^ Rectangle origin: (self labelDisplayBox leftCenter + (10@-5)) extent: (11@11)! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 6/16/97 12:29'!
growBoxFrame
	^ Rectangle origin: (self labelDisplayBox rightCenter + (-22@-5)) extent: (11@11)! !

!StandardSystemView methodsFor: 'label access'!
label
	"Answer the string that appears in the receiver's label."
	labelText isNil
		ifTrue: [^ 'Untitled' copy]
		ifFalse: [^ labelText asString]! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:44'!
label: aString 
	"Set aString to be the receiver's label."
	labelText _ Paragraph
			withText: (Text string: ((aString == nil or: [aString isEmpty])
								ifTrue: ['Untitled' copy]
								ifFalse: [aString])
							attributes: (Array with: TextEmphasis bold))
			style: LabelStyle.
	insetDisplayBox == nil ifTrue: [^ self].  "wait for further initialization"
	self setLabelRegion! !

!StandardSystemView methodsFor: 'label access'!
labelColor
	"Answer the color to use as the background for the receiver's label.  By default, this is the same as the background color of the window, but need not be.  7/16/96 sw"

	^ self backgroundColor! !

!StandardSystemView methodsFor: 'label access'!
labelDisplayBox
	"Answer the rectangle that borders the visible parts of the receiver's label 
	on the display screen."

	^ labelFrame region
		align: labelFrame topLeft
		with: self windowOrigin! !

!StandardSystemView methodsFor: 'label access'!
labelFrame
	^labelFrame! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:47'!
labelHeight
	^ ((LabelStyle fontAt: 1) height + 4) max: 20! !

!StandardSystemView methodsFor: 'label access'!
labelOffset
	^ 0 @ (self labelHeight-2)! !

!StandardSystemView methodsFor: 'label access' stamp: 'sr 3/26/2000 04:26'!
labelText
	^labelText! !

!StandardSystemView methodsFor: 'label access'!
labelTextRegion
	labelText == nil ifTrue: [^ self labelDisplayBox center extent: 0@0].
	^ (labelText boundingBox
			align: labelText boundingBox center
			with: self labelDisplayBox center)
		intersect: (self labelDisplayBox insetBy: 35@0)! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 10/3/97 14:20'!
noLabel
	"A label of zero height indicates no label"
	labelFrame height > 0
		ifTrue: [labelFrame region: (labelFrame bottomLeft + (0@1) extent: labelFrame width@0).
				labelFrame borderWidth: 0.
				self uncacheBits]! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 6/10/1998 13:18'!
relabel: aString 
	"A new string for the label.  Window is assumed to be active.
	Window will redisplay only if label bar has to grow."
	| oldRegion oldWidth |
	(model windowReqNewLabel: aString) ifFalse: [^ self].
	oldRegion _ self labelTextRegion.
	oldWidth _ self insetDisplayBox width.
	self label: aString.
	Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0)
			fillColor: self labelColor.
	self insetDisplayBox width = oldWidth
		ifTrue: [self displayLabelText; emphasizeLabel]
		ifFalse: [self uncacheBits; displayEmphasized].
! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 1/19/2001 20:13'!
setLabel: aLabel
	"For compatibility with morphic"

	self relabel: aLabel! !

!StandardSystemView methodsFor: 'label access' stamp: 'di 10/3/97 13:35'!
setLabelRegion
	"Always follows view width"

	labelFrame region: (0 @ 0 extent: self displayBox width @ self labelHeight).
	labelFrame borderWidth: 2! !

!StandardSystemView methodsFor: 'label access' stamp: 'sw 1/11/2000 15:27'!
setLabelTo: aString 
	"Force aString to be the new label of the receiver, bypassing any logic about whether it is acceptable and about propagating information about the change."
	| oldRegion oldWidth |
	oldRegion _ self labelTextRegion.
	oldWidth _ self insetDisplayBox width.
	self label: aString.
	Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0)
			fillColor: self labelColor.
	self insetDisplayBox width = oldWidth
		ifTrue: [self displayLabelText; emphasizeLabel]
		ifFalse: [self uncacheBits; displayEmphasized].
! !


!StandardSystemView methodsFor: 'size'!
maximumSize
	"Answer a point representing the maximum width and height of the 
	receiver."

	^maximumSize! !

!StandardSystemView methodsFor: 'size'!
maximumSize: aPoint 
	"Set the argument, aPoint, to be the maximum width and height of the 
	receiver."

	maximumSize _ aPoint! !

!StandardSystemView methodsFor: 'size'!
minimumSize
	"Answer a point representing the minimum width and height of the 
	receiver."

	^minimumSize! !

!StandardSystemView methodsFor: 'size'!
minimumSize: aPoint 
	"Set the argument, aPoint, to be the minimum width and height of the 
	receiver."

	minimumSize _ aPoint! !


!StandardSystemView methodsFor: 'framing' stamp: 'sr 3/26/2000 03:47'!
chooseCollapsePoint
	"Answer the point at which to place the collapsed window."
	| pt labelForm beenDown offset |
	labelForm _ Form fromDisplay: self labelDisplayBox.
	self uncacheBits.
	self erase.
	beenDown _ Sensor anyButtonPressed.
	self isCollapsed ifTrue:
		[offset _ self labelDisplayBox topLeft - self growBoxFrame topLeft.
		labelForm follow: [pt _ (Sensor cursorPoint + offset max: 0@0) truncateTo: 8]
				while: [Sensor anyButtonPressed
							ifTrue: [beenDown _ true]
							ifFalse: [beenDown not]].
		^ pt].
	^ (RealEstateAgent assignCollapseFrameFor: self) origin.
! !

!StandardSystemView methodsFor: 'framing'!
chooseFrame
	"Answer a new frame, depending on whether the view is currently 
	collapsed or not."
	| labelForm f |
	self isCollapsed & expandedViewport notNil
		ifTrue:
			[labelForm _ bitsValid
				ifTrue: [windowBits]
				ifFalse: [Form fromDisplay: self labelDisplayBox].
			bitsValid _ false.
			self erase.
			labelForm slideFrom: self labelDisplayBox origin
					to: expandedViewport origin-self labelOffset
					nSteps: 10.
			^ expandedViewport]
		ifFalse:
			[f _ self getFrame.
			bitsValid _ false.
			self erase.
			^ f topLeft + self labelOffset extent: f extent]! !

!StandardSystemView methodsFor: 'framing'!
chooseMoveRectangle
	"Ask the user to designate a new window rectangle."
	| offset p |
	offset _ Sensor anyButtonPressed "Offset if draggin, eg, label"
		ifTrue: [self windowBox topLeft - Sensor cursorPoint]
		ifFalse: [0@0].
	self isCollapsed
		ifTrue: [^ self labelDisplayBox newRectFrom:
					[:f | p _ Sensor cursorPoint + offset.
					p _ (p max: 0@0) truncateTo: 8.
					p extent: f extent]]
		ifFalse: [^ self windowBox newRectFrom:
					[:f | p _ Sensor cursorPoint + offset.
					self constrainFrame: (p extent: f extent)]]! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 5/11/1999 22:09'!
collapse
	"If the receiver is not already collapsed, change its view to be that of its 
	label only."

	self isCollapsed ifFalse:
			[model modelSleep.
			(subViews ~~ nil and: [subViews size = 1 and: [subViews first isKindOf: MorphWorldView]])
				ifTrue: [subViews first deEmphasizeView].
			expandedViewport _ self viewport.
			savedSubViews _ subViews.
			self resetSubViews.
			labelText isNil ifTrue: [self label: nil.  bitsValid _ false.].
			self window: (self inverseDisplayTransform:
					((self labelDisplayBox topLeft extent: (labelText extent x + 70) @ self labelHeight)
						 intersect: self labelDisplayBox))]! !

!StandardSystemView methodsFor: 'framing'!
collapseToPoint: collapsePoint
	self collapse.
	self align: self displayBox topLeft with: collapsePoint.
	collapsedViewport _ self viewport.
	self displayEmphasized! !

!StandardSystemView methodsFor: 'framing'!
collapsedFrame
	"Answer the rectangle occupied by this window when collapsed."
	^ collapsedViewport  "NOTE may be nil"! !

!StandardSystemView methodsFor: 'framing'!
constrainFrame: aRectangle
	"Constrain aRectangle, to the minimum and maximum size
	for this window"

	^ aRectangle origin extent:
		((aRectangle extent max: minimumSize) min: maximumSize)! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 10/20/1999 09:46'!
expand
	"If the receiver is collapsed, change its view to be that of all of its subviews, not its label alone."
	| newFrame |
	self isCollapsed
		ifTrue:
			[newFrame _ self chooseFrame expandBy: borderWidth.
			collapsedViewport _ self viewport.
			subViews _ savedSubViews.
			labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
			savedSubViews _ nil.
			self setWindow: nil.
			self resizeTo: newFrame.
			self displayDeEmphasized.
			model modelWakeUpIn: self]! !

!StandardSystemView methodsFor: 'framing'!
expandedFrame
	"Answer the rectangle occupied by this window when expanded."
	^ expandedViewport  "NOTE may be nil"! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 8/15/97 17:18'!
fullScreen
	"Expand the receiver to fill the screen.  Let the model decide how big is full -- allows for flop-out scrollbar on left if desired"

	self isCollapsed ifFalse:
		[self reframeTo: model fullScreenSize]! !

!StandardSystemView methodsFor: 'framing'!
getFrame
	"Ask the user to designate a rectangular area in which
	the receiver should be displayed."
	| minFrame |
	minFrame _ Cursor origin showWhile: 
		[(Sensor cursorPoint extent: self minimumSize) newRectFrom:
			[:f | Sensor cursorPoint extent: self minimumSize]].
	self maximumSize <= self minimumSize ifTrue: [^ minFrame].
	^ Cursor corner showWhile:
		[minFrame newRectFrom:
			[:f | self constrainFrame: (f origin corner: Sensor cursorPoint)]]! !

!StandardSystemView methodsFor: 'framing' stamp: 'sw 1/22/96'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  "

	^ model initialExtent min: maximumSize max: minimumSize! !

!StandardSystemView methodsFor: 'framing' stamp: 'RAA 6/14/2000 17:27'!
initialFrame
        "Find a plausible initial screen area for the receiver, taking into account user preference, the size needed, and other windows currently on the screen.  5/22/96 sw: let RealEstateAgent do it for us"

        ^ RealEstateAgent initialFrameFor: self world: nil! !

!StandardSystemView methodsFor: 'framing'!
moved
	"The user has moved the receiver; after a new view rectangle is chosen, this method is called to allow certain views to take note of the change.  6/10/96 sw" ! !

!StandardSystemView methodsFor: 'framing'!
newFrame: frameChangeBlock
	self reframeTo: (self windowBox newRectFrom:
		[:f | self constrainFrame: (frameChangeBlock value: f)])! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 10/22/1998 16:15'!
reframePanesAdjoining: subView along: side to: aDisplayBox 
	| newBox delta newRect minDim theMin |
	newRect _ aDisplayBox.
	theMin _ 16.
	"First check that this won't make any pane smaller than theMin screen dots"
	minDim _ ((subViews select: [:sub | sub displayBox bordersOn: subView displayBox along: side])
		collect: [:sub | sub displayBox adjustTo: newRect along: side])
			inject: 999 into: [:was :rect | (was min: rect width) min: rect height].
	"If so, amend newRect as required"
	minDim < theMin ifTrue:
		[delta _ minDim - theMin.
		newRect _ newRect withSide: side setTo: 
				((newRect perform: side) > (subView displayBox perform: side)
					ifTrue: [(newRect perform: side) + delta]
					ifFalse: [(newRect perform: side) - delta])].
	"Now adjust all adjoining panes for real"
	subViews do:
		[:sub | (sub displayBox bordersOn: subView displayBox along: side) ifTrue:
			[newBox _ sub displayBox adjustTo: newRect along: side.
			sub window: sub window viewport:
				(sub transform: (sub inverseDisplayTransform: newBox)) rounded]].
	"And adjust the growing pane itself"
	subView window: subView window viewport:
			(subView transform: (subView inverseDisplayTransform: newRect)) rounded.

	"Finally force a recomposition of the whole window"
	viewport _ nil.
	self resizeTo: self viewport.
	self uncacheBits; displayEmphasized! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 4/6/98 15:12'!
reframeTo: newFrame
	"Reframe the receiver to the given screen rectangle.  
	Repaint difference after the change.  "
	| oldBox newBox portRect |
	self uncacheBits.
	oldBox _ self windowBox.
	portRect _ newFrame topLeft + self labelOffset
				corner: newFrame corner.
	self resizeTo: portRect.
	self setLabelRegion.
	newBox _ self windowBox.
	(oldBox areasOutside: newBox) do:
		[:rect | ScheduledControllers restore: rect].
	self displayEmphasized! !

!StandardSystemView methodsFor: 'framing'!
resize
	"Determine the rectangular area for the receiver, adjusted to the 
	minimum and maximum sizes."
	| f |
	f _ self getFrame.
	self resizeTo: (f topLeft + self labelOffset extent: f extent)
! !

!StandardSystemView methodsFor: 'framing'!
resizeInitially
	"Determine the rectangular area for the receiver, adjusted to the 
	minimum and maximum sizes."
	self resizeTo: self initialFrame
! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 4/6/98 15:12'!
resizeMinimumCenteredAt: aPoint 
	"Determine the rectangular area for the receiver, adjusted so that it is 
	centered a position, aPoint."
	| aRectangle |
	aRectangle _ 0 @ 0 extent: self minimumSize.
	aRectangle _ aRectangle align: aRectangle center with: aPoint.
	self resizeTo: aRectangle! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 4/6/98 15:29'!
resizeTo: aRectangle
	"Resize this view to aRectangle"

	"First get scaling right inside borders"
	self window: (self window insetBy: borderWidth)
		viewport: (aRectangle insetBy: borderWidth).

	"Then ensure window maps to aRectangle"
	window _ transformation applyInverseTo: aRectangle! !

!StandardSystemView methodsFor: 'framing'!
standardWindowOffset
	^ Preferences standardWindowOffset! !

!StandardSystemView methodsFor: 'framing'!
windowBox
	^ self displayBox merge: self labelDisplayBox! !

!StandardSystemView methodsFor: 'framing' stamp: 'di 10/3/97 14:19'!
windowOrigin
	^ (self isCollapsed or: [labelFrame height = 0  "no label"])
		ifTrue: [self displayBox topLeft]
		ifFalse: [self displayBox topLeft - self labelOffset]! !


!StandardSystemView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^StandardSystemController! !


!StandardSystemView methodsFor: 'displaying'!
cacheBits
	| oldLabelState |
	CacheBits ifFalse: [^ self uncacheBits].
	(oldLabelState _ isLabelComplemented) ifTrue: [ self deEmphasize ].
	self cacheBitsAsIs.
	(isLabelComplemented _ oldLabelState) ifTrue: [ self emphasize ].
! !

!StandardSystemView methodsFor: 'displaying'!
cacheBitsAsIs
	CacheBits ifFalse: [^ self uncacheBits].
	windowBits _ (self cacheBitsAsTwoTone and: [Display depth > 1])
		ifTrue: [ColorForm
					twoToneFromDisplay: self windowBox
					using: windowBits
					backgroundColor: self backgroundColor]
		ifFalse: [Form fromDisplay: self windowBox using: windowBits].
	bitsValid _ true.
! !

!StandardSystemView methodsFor: 'displaying'!
cacheBitsAsTwoTone
	^ true! !

!StandardSystemView methodsFor: 'displaying'!
deEmphasizeForDebugger
	"Carefully de-emphasis this window because a debugger is being opened. Care must be taken to avoid invoking potentially buggy window display code that could cause a recursive chain of errors eventually resulting in a virtual machine crash. In particular, do not de-emphasize the subviews."

	self deEmphasizeView.  "de-emphasize this top-level view"
	self uncacheBits.
	Smalltalk garbageCollectMost > 1000000 ifTrue: [
		"if there is enough space, cache current window screen bits"
		self cacheBitsAsIs].
! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:18'!
deEmphasizeLabel
	"Un-Highlight the label."
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayLabelBackground: false.
	self displayLabelText.! !

!StandardSystemView methodsFor: 'displaying'!
display
	isLabelComplemented
		ifTrue: [self displayEmphasized]
		ifFalse: [self displayDeEmphasized]! !

!StandardSystemView methodsFor: 'displaying' stamp: 'hmm 7/21/1999 07:37'!
displayDeEmphasized 
	"Display this view with emphasis off.
	If windowBits is not nil, then simply BLT if possible,
		but force full display for top window so color is preserved."
	(bitsValid and: [controller ~~ ScheduledControllers activeController])
		ifTrue: [self lock.
				windowBits displayAt: self windowOrigin]
		ifFalse: [Display deferUpdates: true.
				super display.
				Display deferUpdates: false; forceToScreen: self windowBox.
				CacheBits ifTrue: [self cacheBitsAsIs]]
! !

!StandardSystemView methodsFor: 'displaying'!
displayEmphasized
	"Display with label highlighted to indicate that it is active."

	self displayDeEmphasized; emphasize.
	isLabelComplemented _ true! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 5/15/1998 21:55'!
displayLabelBackground: emphasized
	"Clear or emphasize the inner region of the label"
	| r1 r2 r3 c3 c2 c1 |
	emphasized ifFalse:
		["Just clear the label if not emphasized"
		^ Display fill: (self labelDisplayBox insetBy: 2) fillColor: self labelColor].
	r1 _ self labelDisplayBox insetBy: 2.
	r2 _ r1 insetBy: 0@2.
	r3 _ r2 insetBy: 0@3.
	c3 _ self labelColor.
	c2 _ c3 dansDarker.
	c1 _ c2 dansDarker.
	Display fill: r1 fillColor: c1.
	Display fill: r2 fillColor: c2.
	Display fill: r3 fillColor: c3.
 
"	Here is the Mac racing stripe code
	stripes _ Bitmap with: (self labelColor pixelWordForDepth: Display depth)
					with: (Form black pixelWordForDepth: Display depth).
	self windowOrigin y even ifTrue: [stripes swap: 1 with: 2].
	Display fill: (self labelDisplayBox insetBy: 3) fillColor: stripes.
"! !

!StandardSystemView methodsFor: 'displaying'!
displayLabelBoxes
	"closeBox, growBox."
	| aRect smallRect backColor |
	aRect _ self closeBoxFrame.
	backColor _ self labelColor.
	Display fill: (aRect insetBy: -2) fillColor: backColor.
	Display fillBlack: aRect.
	Display fill: (aRect insetBy: 1) fillColor: backColor.

	aRect _ self growBoxFrame.
	smallRect _ aRect origin extent: 7@7.
	Display fill: (aRect insetBy: -2) fillColor: backColor.
	aRect _ aRect insetOriginBy: 2@2 cornerBy: 0@0.
	Display fillBlack: aRect.
	Display fill: (aRect insetBy: 1) fillColor: backColor.
	Display fillBlack: smallRect.
	Display fill: (smallRect insetBy: 1) fillColor: backColor! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 9/10/1998 09:43'!
displayLabelText
	"The label goes in the center of the window"
	| labelRect |
	labelText foregroundColor: self foregroundColor
			backgroundColor: self labelColor.
	labelRect _ self labelTextRegion.
	Display fill: (labelRect expandBy: 3@0) fillColor: self labelColor.
	labelText displayOn: Display at: labelRect topLeft clippingBox: labelRect
			rule: labelText rule fillColor: labelText fillColor.
	labelText destinationForm: nil! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/29/97 18:57'!
displayOn: aPort
	bitsValid ifFalse:
		[^ Display clippingTo: aPort clipRect do: [super display]].
	windowBits displayOnPort: aPort at: self windowOrigin! !

!StandardSystemView methodsFor: 'displaying'!
displayRacingStripes
	"Display Racing Stripes in the label"
	| labelDisplayBox stripes top bottom left box right |
	labelDisplayBox _ self labelDisplayBox.
	top _ labelDisplayBox top + 3.
	bottom _ labelDisplayBox bottom - 3.
	stripes _ Bitmap with: (self labelColor pixelWordForDepth: Display depth)
			with: (Color black pixelWordForDepth: Display depth).
	top even ifFalse: [stripes swap: 1 with: 2].

	left _ labelDisplayBox left + 3.

	box _ self closeBoxFrame.
	right _ box left - 2.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	box _ self labelTextRegion.
	right _ box left - 3.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	box _ self growBoxFrame.
	right _ box left - 2.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
	left _ box right + 2.

	right _ labelDisplayBox right - 3.
	Display fill: (Rectangle left: left right: right top: top bottom: bottom)
			fillColor: stripes.
! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:14'!
displayView
	"Refer to the comment in View|displayView. "
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayBox width = labelFrame width ifFalse:
		["recompute label width when window changes size"
		self setLabelRegion].
	(labelFrame align: labelFrame topLeft with: self windowOrigin)
		insideColor: self labelColor;
		displayOn: Display.
	self displayLabelText! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 10/3/97 13:18'!
emphasizeLabel
	"Highlight the label."
	labelFrame height = 0 ifTrue: [^ self].  "no label"
	self displayLabelBackground: true.
	self displayLabelBoxes.
	self displayLabelText.! !

!StandardSystemView methodsFor: 'displaying' stamp: 'di 8/30/97 11:07'!
erase
	"Clear the display box of the receiver to be gray, as the screen background."
	| oldValid |
	CacheBits
		ifTrue:
			[oldValid _ bitsValid.
			bitsValid _ false.
			ScheduledControllers restore: self windowBox without: self.
			bitsValid _ oldValid]
		ifFalse:
			[ScheduledControllers restore: self windowBox without: self]! !

!StandardSystemView methodsFor: 'displaying' stamp: 'RAA 6/14/2000 17:27'!
makeMeVisible

        | newLoc portRect |
        ((Display boundingBox insetBy: (0@0 corner: self labelHeight asPoint))
                containsPoint: self displayBox topLeft) ifTrue: [^ self "OK -- my top left is visible"].

        "window not on screen (probably due to reframe) -- move it now"
        newLoc _ self isCollapsed
                ifTrue: [RealEstateAgent assignCollapsePointFor: self]
                ifFalse: [(RealEstateAgent initialFrameFor: self world: nil) topLeft].
        portRect _ newLoc + self labelOffset
                                extent: self windowBox extent - self labelOffset.
        self resizeTo: portRect.
        self setLabelRegion.
! !

!StandardSystemView methodsFor: 'displaying'!
uncacheBits
	windowBits _ nil.
	bitsValid _ false.! !

!StandardSystemView methodsFor: 'displaying'!
windowBits
	^ windowBits! !


!StandardSystemView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	isLabelComplemented ifTrue:
		[self deEmphasizeLabel.
		isLabelComplemented _ false]! !

!StandardSystemView methodsFor: 'deEmphasizing'!
emphasizeView 
	"Refer to the comment in View|emphasizeView."

	self emphasizeLabel! !


!StandardSystemView methodsFor: 'clipping box access'!
clippingBox
	"Answer the rectangular area in which the receiver can show its label."

	^self isTopView
		ifTrue: [self labelDisplayBox]
		ifFalse: [super insetDisplayBox]! !


!StandardSystemView methodsFor: 'private'!
setTransformation: aTransformation 
	"Override to support label size changes "
	super setTransformation: aTransformation.
	self label: self label! !

!StandardSystemView methodsFor: 'private' stamp: 'di 10/21/1998 16:12'!
subviewWithLongestSide: sideBlock near: aPoint 
	| theSub theSide theLen box |
	theLen _ 0.
	subViews do:
		[:sub | box _ sub insetDisplayBox.
		box forPoint: aPoint closestSideDistLen:
			[:side :dist :len |
			(dist <= 5 and: [len > theLen]) ifTrue:
				[theSub _ sub.
				theSide _ side.
				theLen _ len]]].
	sideBlock value: theSide.
	^ theSub! !


!StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 12:57'!
setUpdatablePanesFrom: getSelectors
	| aList aPane |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"

	aList _ OrderedCollection new.
	getSelectors do:
		[:sel | aPane _ self subViewSatisfying:
				[:pane | (pane isKindOf: PluggableListView) and: [pane getListSelector == sel]].
			aPane
				ifNotNil:
					[aList add: aPane]
				ifNil:
					[Transcript cr; show: 'Warning: view ', sel, ' not found.']].
	updatablePanes _ aList asArray! !

!StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:20'!
updatablePanes
	"Answer the list of panes, in order, which might be sent the #verifyContents message upon window activation or expansion."
	^ updatablePanes ifNil: [updatablePanes _ #()]! !

!StandardSystemView methodsFor: 'updating' stamp: 'sw 1/11/2000 15:30'!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ self setLabelTo: model labelString].
	^ super update: aSymbol! !


!StandardSystemView methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:49'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	updatablePanes ifNil: [updatablePanes _ #()].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StandardSystemView class
	instanceVariableNames: ''!

!StandardSystemView class methodsFor: 'class initialization'!
cachingBits
	^ CacheBits! !

!StandardSystemView class methodsFor: 'class initialization'!
doCacheBits
	"StandardSystemView doCacheBits - Enable fast window repaint feature"
	CacheBits _ true.
	ScheduledControllers unCacheWindows.
	ScheduledControllers restore! !

!StandardSystemView class methodsFor: 'class initialization'!
dontCacheBits
	"StandardSystemView dontCacheBits - Disable fast window repaint feature.
	Return true iff bits were cached, ie if space was been recovered"
	CacheBits ifFalse: [^ false].
	CacheBits _ false.
	ScheduledControllers unCacheWindows.
	^ true! !

!StandardSystemView class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 23:42'!
initialize		"StandardSystemView initialize"
	self doCacheBits.
	self setLabelStyle! !

!StandardSystemView class methodsFor: 'class initialization' stamp: 'sw 12/9/1999 17:43'!
setLabelStyle
	| aFont |
	"StandardSystemView setLabelStyle"
	aFont _ Preferences windowTitleFont.
	LabelStyle _ aFont textStyle copy consistOnlyOf: aFont.
	LabelStyle gridForFont: 1 withLead: 0! !
Viewer subclass: #StandardViewer
	instanceVariableNames: 'firstPanel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!StandardViewer methodsFor: 'categories' stamp: 'sw 12/28/1998 15:22'!
addCategoryViewer	
	self addCategoryViewerFor: self likelyCategoryToShow! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 10/27/1998 21:19'!
addCategoryViewerFor: aStartingCategory
	| aViewer |
	self addMorphBack: (aViewer _ CategoryViewer new initializeFor: scriptedPlayer categoryChoice: aStartingCategory).
	self world ifNotNil: [self world startSteppingSubmorphsOf: aViewer]! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 11/18/1999 16:00'!
categoriesCurrentlyShowing
	^ self categoryMorphs collect: [:m | m currentCategory]! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 10/30/1998 18:38'!
categoryMorphs
	^ self submorphsSatisfying: [:m | m isKindOf: CategoryViewer]! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 10/30/2000 09:05'!
filteringScheme
	"Answer the filtering scheme to be used in the receiver.  This architecture, rather fully prototyped earlier, is not yet really incorporated in the current corpus of released code, but will kick in later hopefully"

	| schemeToUse what |
	schemeToUse _
		self valueOfProperty: #filteringScheme ifAbsent: 
			[what _ Preferences defaultUserLevel == 1
				ifTrue:	[#minimal]
				ifFalse:	[#most].
			self setProperty: #filteringScheme toValue: what.
			what].

	^ schemeToUse! !

!StandardViewer methodsFor: 'categories' stamp: 'sw 10/5/2000 09:27'!
likelyCategoryToShow
	"Choose a category to show based on what's already showing and on some predefined heuristics"

	| possible |
	possible _ (scriptedPlayer categoriesForViewer: self) asOrderedCollection.
	self categoryMorphs do:
		[:m | possible remove: m currentCategory ifAbsent: []].

	((possible includes: #'instance variables') and: [scriptedPlayer hasUserDefinedSlots])
		ifTrue:	[^ #'instance variables'].

	((possible includes: #scripts) and: [scriptedPlayer hasUserDefinedScripts])
		ifTrue:	[^ #'scripts'].

	#(basic #'color & border') do:
		[:preferred | (possible includes: preferred) ifTrue: [^ preferred]].
	^ possible size > 0
		ifTrue:
			[possible first]
		ifFalse:
			[#basic]! !


!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/25/1999 22:08'!
dismiss
	| aFlapTab |
	"User hit the dismiss button."
	(owner isKindOf: TabbedPalette)
		ifTrue:
			[^ owner showNoPalette].
	(aFlapTab _ self pasteUpMorph correspondingFlapTab) ifNotNil:
		[^ aFlapTab dismissViaHalo].
	self topRendererOrSelf delete! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/24/1998 14:34'!
downArrowHit
	self nextCostume! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/26/1999 01:07'!
hasDismissButton
	submorphs isEmptyOrNil ifTrue: [^ false].
	^ (submorphs first allMorphs detect:
		[:possible |  (possible isKindOf: SimpleButtonMorph) and: [possible actionSelector == #dismiss]]
			ifNone: [nil]) notNil! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 12/23/1998 22:45'!
standardViewerColor
	 ^ Color r: 0.572 g: 0.883 b: 0.572! !

!StandardViewer methodsFor: 'user interface' stamp: 'sw 10/24/1998 14:33'!
upArrowHit
	self previousCostume! !


!StandardViewer methodsFor: 'initialization' stamp: 'sw 6/25/1999 23:02'!
addHeaderMorphWithBarHeight: anInteger
	^ self addHeaderMorphWithBarHeight: anInteger includeDismissButton: true! !

!StandardViewer methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:23'!
addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean
	"Add the header morph to the receiver, using anInteger as a guide for its height, and if aBoolean is true, include a dismiss buton for it"

	| header aFont aButton aTextMorph nail wrpr costs headWrapper inner |
	header _ AlignmentMorph newRow color: self color muchLighter; wrapCentering: #center; cellPositioning: #leftCenter.
	aFont _ Preferences standardButtonFont.
	aBoolean ifTrue:
		[header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont).
		aButton target: self;
				color:  Color tan;
				actionSelector: #dismiss;
				setBalloonText: 'remove this entire Viewer from the screen
don''t worry -- nothing will be lost!!.'.
		header addTransparentSpacerOfSize: 4@1].

	aButton _ IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: #AddCategoryViewer); color: Color transparent; 
			actWhen: #buttonDown;
			target: self;
			actionSelector: #addCategoryViewer;
			setBalloonText: 'click here to add
another category pane';
			shedSelvedge.
	header addMorphBack: aButton.
	header addTransparentSpacerOfSize: 4@1.

	costs _ scriptedPlayer costumes.
	costs ifNotNil:
	[(costs size > 1 or: [costs size = 1 and: [costs first ~~ scriptedPlayer costume]]) ifTrue:
		[header addUpDownArrowsFor: self.
		(wrpr _ header submorphs last) submorphs second setBalloonText: 'switch to previous costume'.	
		wrpr submorphs first  setBalloonText: 'switch to next costume']].	

	(self hasProperty: #noInteriorThumbnail)
		ifFalse:
			[nail _ ThumbnailMorph new objectToView: scriptedPlayer viewSelector: #costume]
		ifTrue:
			[inner _ ImageMorph new image: (ScriptingSystem formAtKey: 'Menu').
			nail _ RectangleMorph new beTransparent extent: inner extent.
			nail addMorph: inner lock].
	nail on: #mouseDown send: #offerViewerMenuForEvt:morph: to: scriptedPlayer.
	header addMorphBack: nail.
	nail setBalloonText: 'click here to get a menu
that will allow you to
add an instance variable,,
tear off a tile, etc..'.
	(self hasProperty: #noInteriorThumbnail)
		ifFalse:
			[nail borderWidth: 3; borderColor: #raised].

	header addTransparentSpacerOfSize: 5@5.

"	aButton _ SimpleButtonMorph new target: self; actionSelector: #newEmptyScript; label: 'S' font: (aFont _ StrikeFont familyName: #ComicBold size: 16);  color: Color transparent; borderWidth: 0; actWhen: #buttonDown.
	aButton setBalloonText: 'drag from here to
create a new script
for this object'.	
	header addMorphBack: aButton.

	header addTransparentSpacerOfSize: 8@5.

	aButton _ SimpleButtonMorph new target: scriptedPlayer; actionSelector: #addInstanceVariable; label: 'I' font: aFont;  color: Color transparent; borderWidth: 0; actWhen: #buttonUp.
	aButton setBalloonText: 'click here to add
an instance variable
to this object.'.
	header addMorphBack: aButton.

	header addTransparentSpacerOfSize: 5@5."
	self viewsMorph ifTrue: [scriptedPlayer costume assureExternalName].
	aTextMorph _ UpdatingStringMorph new
		useStringFormat;
		target:  scriptedPlayer;
		getSelector: #nameForViewer;
		setNameTo: 'name';
		font: ScriptingSystem fontForNameEditingInScriptor.
	self viewsMorph ifTrue:
		[aTextMorph putSelector: #setName:.
		aTextMorph setProperty: #okToTextEdit toValue: true].
	aTextMorph step.
	header  addMorphBack: aTextMorph.
	aTextMorph setBalloonText: 'Click here to edit the player''s name.'.	

	header beSticky.
	anInteger > 0
		ifTrue:
			[headWrapper _ AlignmentMorph newColumn color: self color.
			headWrapper addTransparentSpacerOfSize: (0 @ anInteger).
			headWrapper addMorphBack: header.
			self addMorph: headWrapper]
		ifFalse:
			[self addMorph: header]! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 10/25/2000 23:30'!
affordsUniclass
	"Answer true iff the receiver operates on behalf of an object that is, or could become, a member of a Uniclass"

	| viewee |
	^ (viewee _ self objectViewed) belongsToUniClass or: 
			[((viewee isKindOf: Integer) not and: 
				[(viewee isKindOf: Behavior) not]) and:
					[self userLevel > 0]]! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 12/23/1998 23:26'!
initialHeightToAllow
	^ 300! !

!StandardViewer methodsFor: 'initialization' stamp: 'ar 11/9/2000 22:02'!
initializeFlapVersionFor: aPlayer
	scriptedPlayer _ aPlayer.
	self listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 1.
	self color: self standardViewerColor.
	self addHeaderMorphWithBarHeight: 0 includeDismissButton: false.

	self addCategoryViewer.    "#1"
	self addCategoryViewer.    "#2"! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 6/25/1999 23:04'!
initializeFor: aPlayer barHeight: anInteger
	^ self initializeFor: aPlayer barHeight: anInteger includeDismissButton: true! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 8/4/2000 13:02'!
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean
	self initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: nil! !

!StandardViewer methodsFor: 'initialization' stamp: 'ar 11/9/2000 22:02'!
initializeFor: aPlayer barHeight: anInteger includeDismissButton: aBoolean showCategories: cats
	scriptedPlayer _ aPlayer.
	self listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		borderWidth: 1.
	self color: self standardViewerColor.
	self addHeaderMorphWithBarHeight: anInteger includeDismissButton: aBoolean.

	cats isEmptyOrNil
		ifFalse:
			[cats do:
				[:aCat | self addCategoryViewerFor: aCat]]
		ifTrue:
			[self addCategoryViewer.
			self addCategoryViewer].! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 10/26/2000 09:42'!
userLevel
	"Answer the user level for this viewer, which can be used in figuring out what to display in the viewer.  Initially, we make little use of this, but in past prototypes, and in future deployments, it may be handy."

	^ self valueOfProperty: #userLevel ifAbsent: [1]! !

!StandardViewer methodsFor: 'initialization' stamp: 'sw 11/3/2000 06:25'!
viewsMorph
	"Answer whether the receiver views a morph.  Traditional viewers up until late 2000 *all* viewed morphs (as per the morph/player architecture), but viewers on non-morph/players have now become possible"

	^ scriptedPlayer isKindOf: Player! !

PolygonMorph subclass: #StarMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!StarMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/25/2000 17:52'!
addHandles
	| handle strokeOrigin p |
	handles ifNotNil: [handles do: [:hh | hh delete]].
	strokeOrigin _ 0@0.
	vertices do: [:each | strokeOrigin _ strokeOrigin + each].
	strokeOrigin _ strokeOrigin // vertices size.	"average is the center"
	handles _ Array new: 2.
		handle _ EllipseMorph newBounds: (Rectangle center: strokeOrigin extent: 8@8)
				color: Color yellow.
		handle on: #mouseMove send: #dragVertex:fromHandle:vertIndex:
				to: self withValue: #center.
		self addMorph: handle.
	handles at: 1 put: handle.	"The center one!!!!"
		p _ vertices at: 2.	"an outside one"
		handle _ EllipseMorph newBounds: (Rectangle center: p + (borderWidth//2) extent: 8@8)
				color: Color yellow.
		handle on: #mouseMove send: #dragVertex:fromHandle:vertIndex:
				to: self withValue: #outside.
		self addMorph: handle.
	handles at: 2 put: handle.	"The outside one!!!!"
	self changed! !

!StarMorph methodsFor: 'as yet unclassified' stamp: 'sw 8/11/97 22:44'!
authoringPrototype
	^ super authoringPrototype removeHandles! !

!StarMorph methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:18'!
defaultColor
	"Return the default fill style for the receiver"
	^Color lightBlue! !

!StarMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/23/97 18:19'!
dragVertex: evt fromHandle: handle vertIndex: label

	| ext oldR pt strokeOrigin offset |
label == #center ifTrue: [
	offset _ evt cursorPoint - (handles at: 1) bounds center.
	self position: self position + offset.
	].

label == #outside ifTrue: [
	strokeOrigin _ (handles at: 1) bounds center.
	pt _ strokeOrigin - evt cursorPoint - ((handles at: 2) extent // 2).
	ext _ pt r.
	oldR _ ext.
	vertices _ (0 to: 359 by: (360//vertices size)) collect: [:angle |
		(Point r: (oldR _ oldR = ext ifTrue: [ext*5//12] ifFalse: [ext]) degrees: angle + pt degrees)
			+ strokeOrigin].
	(handles at: 2) position: evt cursorPoint.
	].
self computeBounds.
! !

!StarMorph methodsFor: 'as yet unclassified' stamp: 'ar 6/25/1999 11:19'!
initialize

	| pt ext oldR points |
	super initialize.
	borderWidth _ 1.
	borderColor _ Color black.
	pt _ 10@10.
	ext _ pt r.
	oldR _ ext.
	points _ 5.
	vertices _ (0 to: 359 by: (360//points//2)) collect: [:angle |
		(Point r: (oldR _ oldR = ext ifTrue: [ext*5//12] ifFalse:
[ext]) degrees: angle + pt degrees)
			+ (45@45)].
	self computeBounds! !

!StarMorph methodsFor: 'as yet unclassified' stamp: 'di 9/26/97 11:11'!
updateHandles! !
Form subclass: #StaticForm
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
!StaticForm commentStamp: '<historical>' prior: 0!
An optimization for Nebraska - a StaticForm does not change once created so it may be cached on the remote end.!


!StaticForm methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 09:59'!
isStatic

	^true! !
MorphicAlarm subclass: #StepMessage
	instanceVariableNames: 'stepTime '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Events'!

!StepMessage methodsFor: 'accessing' stamp: 'ar 10/22/2000 16:56'!
stepTime
	"Return the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	^stepTime! !

!StepMessage methodsFor: 'accessing' stamp: 'ar 10/22/2000 16:56'!
stepTime: aNumber
	"Set the step time for this message. If nil, the receiver of the message will be asked for its #stepTime."
	stepTime _ aNumber! !


!StepMessage methodsFor: 'printing' stamp: 'ar 10/22/2000 15:59'!
printOn: aStream
	super printOn: aStream.
	aStream 
		nextPut: $(;
		print: receiver;
		space;
		print: selector;
		space;
		print: scheduledTime;
		nextPut: $).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StepMessage class
	instanceVariableNames: ''!

!StepMessage class methodsFor: 'instance creation' stamp: 'ar 10/22/2000 15:48'!
scheduledAt: scheduledTime stepTime: stepTime receiver: aTarget selector: aSelector arguments: argArray
	^(self receiver: aTarget selector: aSelector arguments: argArray)
		scheduledTime: scheduledTime;
		stepTime: stepTime! !
SketchMorph subclass: #StickySketchMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!

!StickySketchMorph methodsFor: 'as yet unclassified' stamp: 'sw 4/16/1998 13:44'!
mustBeBackmost
	^ true! !

!StickySketchMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1999 11:32'!
permitsThumbnailing
	^ false! !

!StickySketchMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/18/97 15:37'!
wantsHalo
	^ false! !
PrintableEncoder subclass: #StoreEncoder
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Postscript Filters'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StoreEncoder class
	instanceVariableNames: ''!

!StoreEncoder class methodsFor: 'as yet unclassified' stamp: 'MPW 1/1/1901 01:52'!
filterSelector
    ^#storeOnStream:.
! !
BookMorph subclass: #StoryboardBookMorph
	instanceVariableNames: 'alansSliders panAndTiltFactor zoomFactor zoomController '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Books'!
!StoryboardBookMorph commentStamp: '<historical>' prior: 0!
A BookMorph variant whose pages are instances of ZoomAndScrollMorph. I have a control area where the user may pan, tilt and zoom over the image shown in the page.

- drag up and down to zoom in and out
- drag left and right to pan
- shift-drag up and down to tilt.!


!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:37'!
changeTiltFactor: x

	currentPage changeTiltFactor: x.
	panAndTiltFactor _ x.

! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:37'!
changeZoomFactor: x

	currentPage changeZoomFactor: x.
	zoomFactor _ x.! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:38'!
getTiltFactor

	^panAndTiltFactor ifNil: [panAndTiltFactor _ 0.5].! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:38'!
getZoomFactor

	^zoomFactor ifNil: [zoomFactor _ 0.5]! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:22'!
initialize

	newPagePrototype _ ZoomAndScrollMorph new extent: Display extent // 3.
	zoomController _ ZoomAndScrollControllerMorph new
			setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.

	super initialize.

	self addMorphBack: zoomController.

	alansSliders _ {
		{#changeTiltFactor: . #getTiltFactor . 'Pan and tilt sensitivity'}.
		{#changeZoomFactor: . #getZoomFactor . 'Zoom sensitivity'}.
	} collect: [ :sData |
		{
			SimpleSliderMorph new
				extent: 150@10;
				color: Color orange;
				sliderColor: Color gray;
				target: self; 
				actionSelector: sData first;
				setBalloonText: sData third;
				adjustToValue: (self perform: sData second).
			sData second
		}
	].
	alansSliders do: [ :each | self addMorphBack: each first]
! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:20'!
insertPageMorphInCorrectSpot: aPageMorph

	self addMorph: (currentPage _ aPageMorph) behind: submorphs second.
	self changeTiltFactor: self getTiltFactor.
	self changeZoomFactor: self getZoomFactor.
	zoomController target: currentPage.

! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetX

	^currentPage offsetX! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetX: aNumber

	currentPage offsetX: aNumber! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetY

	^currentPage offsetY! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:41'!
offsetY: aNumber

	currentPage offsetY: aNumber! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:35'!
scale

	^currentPage scale! !

!StoryboardBookMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:26'!
scale: aValue

	currentPage scale: aValue! !
Object subclass: #Stream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Stream commentStamp: '<historical>' prior: 0!
I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".!


!Stream methodsFor: 'accessing'!
contents
	"Answer all of the contents of the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:07'!
flush
	"Do nothing by default"! !

!Stream methodsFor: 'accessing'!
next
	"Answer the next object accessible by the receiver."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing'!
next: anInteger 
	"Answer the next anInteger number of objects accessible by the receiver."

	| aCollection |
	aCollection _ OrderedCollection new.
	anInteger timesRepeat: [aCollection addLast: self next].
	^aCollection! !

!Stream methodsFor: 'accessing'!
next: anInteger put: anObject 
	"Make anObject be the next anInteger number of objects accessible by the 
	receiver. Answer anObject."

	anInteger timesRepeat: [self nextPut: anObject].
	^anObject! !

!Stream methodsFor: 'accessing'!
nextMatchAll: aColl
    "Answer true if next N objects are the ones in aColl,
     else false.  Advance stream of true, leave as was if false."
    | save |
    save _ self position.
    aColl do: [:each |
       (self next) = each ifFalse: [
            self position: save.
            ^ false]
        ].
    ^ true! !

!Stream methodsFor: 'accessing'!
nextMatchFor: anObject 
	"Gobble the next object and answer whether it is equal to the argument, 
	anObject."

	^anObject = self next! !

!Stream methodsFor: 'accessing'!
nextPut: anObject 
	"Insert the argument, anObject, as the next object accessible by the 
	receiver. Answer anObject."

	self subclassResponsibility! !

!Stream methodsFor: 'accessing'!
nextPutAll: aCollection 
	"Append the elements of aCollection to the sequence of objects accessible 
	by the receiver. Answer aCollection."

	aCollection do: [:v | self nextPut: v].
	^aCollection! !

!Stream methodsFor: 'accessing' stamp: 'ls 9/12/1998 20:55'!
upToEnd
	"answer the remaining elements in the string"
	| elements |
	elements _ OrderedCollection new.
	[ self atEnd ] whileFalse: [ 
		elements add: self next ].
	^elements! !


!Stream methodsFor: 'testing'!
atEnd
	"Answer whether the receiver can access any more objects."

	self subclassResponsibility! !

!Stream methodsFor: 'testing'!
closed
	^true! !

!Stream methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'!
isStream
	"Return true if the receiver responds to the stream protocol"
	^true! !


!Stream methodsFor: 'enumerating'!
do: aBlock 
	"Evaluate aBlock for each of the objects accessible by receiver."

	[self atEnd]
		whileFalse: [aBlock value: self next]! !


!Stream methodsFor: 'printing' stamp: 'sma 6/1/2000 09:56'!
print: anObject
	"Have anObject print itself on the receiver."

	anObject printOn: self! !

!Stream methodsFor: 'printing' stamp: 'djp 7/21/1998 17:13'!
printHtml: anObject
	anObject printHtmlOn: self! !


!Stream methodsFor: 'converting' stamp: 'ar 3/12/98 18:18'!
asVRMLStream
	^VRMLStream on: self! !


!Stream methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:48'!
write:encodedObject
	^encodedObject putOn:self.
! !


!Stream methodsFor: 'alternate syntax' stamp: 'RAA 6/20/2000 12:52'!
dialect

	^#ST80		"in case a regular stream is used to print parse nodes"! !

!Stream methodsFor: 'alternate syntax' stamp: 'RAA 6/20/2000 12:54'!
withStyleFor: elementType do: aBlock

	^aBlock value		"in case a regular stream is used to print parse nodes"
">>
(Compiler new compile: 'blah ^self' in: String notifying: nil ifFail: []) printString
<<"! !


!Stream methodsFor: 'as yet unclassified' stamp: 'RAA 9/11/2000 19:12'!
sleep

	"an FTP-based stream might close the connection here"! !


!Stream methodsFor: 'file open/close' stamp: 'mir 8/10/1999 12:04'!
close! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Stream class
	instanceVariableNames: ''!

!Stream class methodsFor: 'instance creation'!
new

	self error: 'Streams are created with on: and with:'! !
AlignmentMorphBob1 subclass: #StretchyImageMorph
	instanceVariableNames: 'form cache '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Experimental'!
!StretchyImageMorph commentStamp: '<historical>' prior: 0!
I draw a form to fill whatever bounds I have.!


!StretchyImageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 17:33'!
drawOn: aCanvas
| t |
"
Smalltalk at: #Q4 put: OrderedCollection new.
"
	form ifNil: [form _ (Form extent: 32@32 depth: 8) fillColor: Color green].
	(cache isNil or: [cache extent ~= bounds extent]) ifTrue: [
		t _ [cache _ Form extent: bounds extent depth: aCanvas depth.
		form displayInterpolatedIn: cache boundingBox on: cache] timeToRun.
		"Q4 add: {t. form. cache}."
	].
	aCanvas paintImage: cache at: bounds origin.
! !

!StretchyImageMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/10/2000 16:20'!
form: aForm

	form _ aForm! !

!StretchyImageMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/30/2000 15:31'!
initialize

	super initialize.
	self hResizing: #spaceFill.
	self vResizing: #spaceFill.
! !
AbstractFont subclass: #StrikeFont
	instanceVariableNames: 'characterToGlyphMap xTable glyphs name type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster subscript superscript emphasis derivativeFonts pointSize '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!StrikeFont commentStamp: '<historical>' prior: 0!
I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the glyphs. Characters are mapped to glyphs by using the characterToGyphMap.

Subclasses can have non-trivial mapping rules as well as different representations for glyphs sizes (e.g., not using an xTable). If so, these classes should return nil when queried for xTable and/or the characterToGlyphMap. This will cause the CharacterScanner primitive to fail and query the font for the width of a character (so that a more programatical approach can be implemented).

For display, fonts need to implement two messages:
	#installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
This method installs the receiver (a font) on the given DisplayContext (which may be an instance of BitBlt or Canvas (or any of it's subclasses). The font should take the appropriate action to initialize the display context so that further display operations can be optimized.
	#displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta
This method is called for each subsequent run of characters in aString which is to be displayed with the (previously installed) settings.
!


!StrikeFont methodsFor: 'accessing'!
ascent
	"Answer the receiver's maximum extent of characters above the baseline."

	^ascent! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'!
ascentKern
	"Return the kern delta for ascenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self ascent-5+4)//4 max: 0  "See makeItalicGlyphs"

! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/1/2000 17:17'!
baseKern
	"Return the base kern value to be used for all characters."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ ((self height-1-self ascent+4)//4 max: 0)  "See makeItalicGlyphs"
		+ (((self ascent-5+4)//4 max: 0))
! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 5/23/2000 12:52'!
characterToGlyphMap
	^characterToGlyphMap ifNil:[characterToGlyphMap _ self createCharacterToGlyphMap].! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 5/23/2000 12:52'!
characterToGlyphMap: anArray
	characterToGlyphMap _ anArray.! !

!StrikeFont methodsFor: 'accessing'!
descent
	"Answer the receiver's maximum extent of characters below the baseline."

	^descent! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 9/2/2000 13:06'!
descentKern
	"Return the kern delta for descenders."
	(emphasis noMask: 2) ifTrue: [^ 0].
	^ (self height-1-self ascent+4)//4 max: 0  "See makeItalicGlyphs"

! !

!StrikeFont methodsFor: 'accessing'!
familyName
	^self name withoutTrailingDigits.

! !

!StrikeFont methodsFor: 'accessing' stamp: 'tk 6/26/1998 16:45'!
familySizeFace
	"Answer an array with familyName, a String, pointSize, an Integer, and
	faceCode, an Integer."

	^Array with: name
		with: self height
		with: emphasis

	"(1 to: 12) collect: [:x | (TextStyle default fontAt: x) familySizeFace]"! !

!StrikeFont methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'!
fontNameWithPointSize
	^self name withoutTrailingDigits, ' ', self pointSize printString! !

!StrikeFont methodsFor: 'accessing'!
glyphs
	"Answer a Form containing the bits representing the characters of the 
	receiver."

	^glyphs! !

!StrikeFont methodsFor: 'accessing'!
height
	"Answer the height of the receiver, total of maximum extents of 
	characters above and below the baseline."

	^self ascent + self descent! !

!StrikeFont methodsFor: 'accessing'!
lineGrid
	^ ascent + descent! !

!StrikeFont methodsFor: 'accessing'!
maxAscii
	"Answer the integer that is the last Ascii character value of the receiver."

	^maxAscii! !

!StrikeFont methodsFor: 'accessing'!
maxWidth
	"Answer the integer that is the width of the receiver's widest character."

	^maxWidth! !

!StrikeFont methodsFor: 'accessing'!
minAscii
	"Answer the integer that is the first Ascii character value of the receiver."

	^minAscii! !

!StrikeFont methodsFor: 'accessing' stamp: 'ls 3/27/2000 19:54'!
name
	"Answer the receiver's name."

	^name ifNil: ['(unnamed)']! !

!StrikeFont methodsFor: 'accessing'!
name: aString
	"Set the receiver's name."

	name _ aString! !

!StrikeFont methodsFor: 'accessing' stamp: 'sw 1/18/2000 20:54'!
pointSize
	^ pointSize! !

!StrikeFont methodsFor: 'accessing' stamp: 'sma 5/5/2000 14:21'!
pointSize: anInteger
	pointSize _ anInteger! !

!StrikeFont methodsFor: 'accessing'!
raster
	"Answer an integer that specifies the layout of the glyphs' form."

	^raster! !

!StrikeFont methodsFor: 'accessing'!
setGlyphs: newGlyphs
	"Replace the glyphs form.  Used to make a synthetic bold or italic font quickly."

	glyphs _ newGlyphs! !

!StrikeFont methodsFor: 'accessing'!
subscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as subscripts."

	^subscript! !

!StrikeFont methodsFor: 'accessing'!
superscript
	"Answer an integer that is the further vertical offset relative to the 
	baseline for positioning characters as superscripts."

	^superscript! !

!StrikeFont methodsFor: 'accessing' stamp: 'sw 10/5/1998 16:38'!
textStyle
	^ Utilities actualTextStyles detect:
		[:aStyle | aStyle fontArray includes: self] ifNone: [nil]! !

!StrikeFont methodsFor: 'accessing' stamp: 'di 3/27/2000 14:49'!
widthOf: aCharacter 
	"Answer the width of the argument as a character in the receiver."

	| ascii |
	ascii _ aCharacter asciiValue.
	(ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1].
	^ (xTable at: ascii + 2) - (xTable at: ascii + 1)
! !

!StrikeFont methodsFor: 'accessing'!
xTable
	"Answer an Array of the left x-coordinate of characters in glyphs."

	^xTable! !


!StrikeFont methodsFor: 'testing'!
checkCharacter: character 
	"Answer a Character that is within the ascii range of the receiver--either 
	character or the last character in the receiver."

	| ascii |  
	ascii _ character asciiValue.
	((ascii < minAscii) or: [ascii > maxAscii])
			ifTrue: [^maxAscii asCharacter]
			ifFalse:	[^character]
! !


!StrikeFont methodsFor: 'displaying' stamp: 'ar 5/28/2000 12:11'!
characters: anInterval in: sourceString displayAt: aPoint 
	clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm 	"Simple, slow, primitive method for displaying a line of characters.
	No wrap-around is provided."
	| ascii destPoint bb leftX rightX sourceRect |
	destPoint _ aPoint.
	bb _ BitBlt current toForm: Display.
	anInterval do: 
		[:i | 
		ascii _ (sourceString at: i) asciiValue.
		(ascii < minAscii or: [ascii > maxAscii])
			ifTrue: [ascii _ maxAscii].
		leftX _ xTable at: ascii + 1.
		rightX _ xTable at: ascii + 2.
		sourceRect _ leftX@0 extent: (rightX-leftX) @ self height.
		bb copyFrom: sourceRect in: glyphs to: destPoint.
		destPoint _ destPoint + ((rightX-leftX)@0)].
	^ destPoint! !

!StrikeFont methodsFor: 'displaying'!
composeWord: aTextLineInterval in: sourceString beginningAt: xInteger 
	"Non-primitive composition of a word--add up widths of characters, add 
	sum to beginning x and answer the resulting x. Similar to performance 
	of scanning primitive, but without stop conditions."

	| character resultX |
	resultX _ xInteger.
	aTextLineInterval do: 
		[:i | 
		character _ sourceString at: i.
		resultX _ resultX + (self widthOf: character)].
	^resultX! !

!StrikeFont methodsFor: 'displaying'!
displayLine: aString at: aPoint 
	"Display the characters in aString, starting at position aPoint."

	self characters: (1 to: aString size)
		in: aString
		displayAt: aPoint
		clippedBy: Display boundingBox
		rule: Form over
		fillColor: nil! !

!StrikeFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 15:09'!
displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta
	"Draw the given string from startIndex to stopIndex 
	at aPoint on the (already prepared) BitBlt."
	aBitBlt displayString: aString 
			from: startIndex 
			to: stopIndex 
			at: aPoint 
			strikeFont: self
			kern: kernDelta.! !

!StrikeFont methodsFor: 'displaying' stamp: 'sma 2/10/2000 22:56'!
fontDisplay
	"TextStyle default defaultFont fontDisplay."

	Display restoreAfter:
		[(Form extent: 440@400) displayAt: 90@90.
		 0 to: 15 do:
			[:i |
			i hex displayAt: 100 @ (20 * i + 100).
			0 to: 15 do:
				[:j |
				((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue:
					[(self characterFormAt: (16 * i + j) asCharacter)
						displayAt: (20 * j + 150) @ (20 * i + 100)]]].
			'Click to continue...' asDisplayText displayAt: 100@450]! !

!StrikeFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 15:08'!
installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor
	^aDisplayContext 
		installStrikeFont: self
		foregroundColor: foregroundColor 
		backgroundColor: backgroundColor! !

!StrikeFont methodsFor: 'displaying' stamp: 'di 4/13/1999 20:21'!
widthOfString: aString

	^ self composeWord: (1 to: aString size) in: aString beginningAt: 0
"
	TextStyle default defaultFont widthOfString: 'zort' 21
"! !


!StrikeFont methodsFor: 'emphasis' stamp: 'ar 5/28/2000 12:11'!
bonk: glyphForm with: bonkForm
	"Bonking means to run through the glyphs clearing out black pixels
	between characters to prevent them from straying into an adjacent
	character as a result of, eg, bolding or italicizing"
	"Uses the bonkForm to erase at every character boundary in glyphs."
	| bb offset |
	offset _ bonkForm offset x.
	bb _ BitBlt current toForm: glyphForm.
	bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox;
		combinationRule: Form erase; destY: 0.
	1 to: xTable size-1 do: [:i | bb destX: (xTable at: i) + offset; copyBits].
! !

!StrikeFont methodsFor: 'emphasis'!
emphasis
	"Answer the integer code for synthetic bold, italic, underline, and 
	strike-out."

	^emphasis! !

!StrikeFont methodsFor: 'emphasis'!
emphasis: code 
	"Set the integer code for synthetic bold, itallic, underline, and strike-out, 
	where bold=1, italic=2, underlined=4, and struck out=8."

	emphasis _ code! !

!StrikeFont methodsFor: 'emphasis' stamp: 'di 9/3/2000 13:22'!
emphasized: code 
	"Answer a copy of the receiver with emphasis set to include code."
	| derivative addedEmphasis base safeCode |
	code = 0 ifTrue: [^ self].
	(derivativeFonts == nil or: [derivativeFonts size = 0]) ifTrue: [^ self].
	derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size).
	derivative == nil ifFalse: [^ derivative].  "Already have this style"

	"Dont have it -- derive from another with one with less emphasis"
	addedEmphasis _ 1 bitShift: safeCode highBit - 1.
	base _ self emphasized: safeCode - addedEmphasis.  "Order is Bold, Ital, Under, Narrow"
	addedEmphasis = 1 ifTrue:   "Compute synthetic bold version of the font"
		[derivative _ (base copy ensureCleanBold name: base name , 'B') makeBoldGlyphs].
	addedEmphasis = 2 ifTrue:   "Compute synthetic italic version of the font"
		[ derivative _ (base copy name: base name , 'I') makeItalicGlyphs].
	addedEmphasis = 4 ifTrue:   "Compute underlined version of the font"
		[derivative _ (base copy name: base name , 'U') makeUnderlinedGlyphs].
	addedEmphasis = 8 ifTrue:   "Compute narrow version of the font"
		[derivative _ (base copy name: base name , 'N') makeCondensedGlyphs].
	addedEmphasis = 16 ifTrue:   "Compute struck-out version of the font"
		[derivative _ (base copy name: base name , 'X') makeStruckOutGlyphs].
	derivative emphasis: safeCode.
	derivativeFonts at: safeCode put: derivative.
	^ derivative! !

!StrikeFont methodsFor: 'emphasis'!
makeBoldGlyphs
	"Make a bold set of glyphs with same widths by ORing 1 bit to the right
		(requires at least 1 pixel of intercharacter space)"
	| g bonkForm |
	g _ glyphs deepCopy.
	bonkForm _ (Form extent: 1@16) fillBlack offset: -1@0.
	self bonk: g with: bonkForm.
	g copyBits: g boundingBox from: g at: (1@0)
		clippingBox: g boundingBox rule: Form under fillColor: nil.
	glyphs _ g! !

!StrikeFont methodsFor: 'emphasis' stamp: 'di 10/31/97 13:18'!
makeCondensedGlyphs
	"Make a condensed set of glyphs with same widths.
	NOTE: this has been superceded by kerning -- should not get called"
	| g newXTable x x1 w |
	g _ glyphs deepCopy.
	newXTable _ Array new: xTable size.
	newXTable at: 1 put: (x _ xTable at: 1).
	1 to: xTable size-1 do:
		[:i | x1 _ xTable at: i.  w _ (xTable at: i+1) - x1.
		w > 1 ifTrue: [w _ w-1].  "Shrink every character wider than 1"
		g copy: (x@0 extent: w@g height) from: x1@0 in: glyphs rule: Form over.
		newXTable at: i+1 put: (x _ x + w)].
	xTable _ newXTable.
	glyphs _ g
"
(TextStyle default fontAt: 1) copy makeCondensedGlyphs
	displayLine: 'The quick brown fox jumps over the lazy dog'
	at: Sensor cursorPoint
"! !

!StrikeFont methodsFor: 'emphasis' stamp: 'di 9/1/2000 17:12'!
makeItalicGlyphs
	"Make an italic set of glyphs with same widths by skewing left and right.
	In the process, characters would overlap, so we widen them all first.
	"
	| extraWidth newGlyphs newXTable x newX w extraOnLeft |
	extraOnLeft _ (self height-1-self ascent+4)//4 max: 0.
	extraWidth _ ((self ascent-5+4)//4 max: 0) + extraOnLeft.
	newGlyphs _ Form extent: (glyphs width + extraWidth) @ glyphs height.
	newXTable _ xTable copy.

	"Copy glyphs into newGlyphs with room on left and right for overlap."
	minAscii to: maxAscii+1 do:
		[:ascii | x _ xTable at: ascii+1.  w _ (xTable at: ascii+2) - x.
		newX _ newXTable at: ascii+1.
		newGlyphs copy: ((newX + extraOnLeft) @ 0 extent: w @ glyphs height)
			from: x @ 0 in: glyphs rule: Form over.
		newXTable at: ascii+2 put: newX + w + extraWidth].		
	glyphs _ newGlyphs. 
	xTable _ newXTable.

	"Slide the bitmaps left and right for synthetic italic effect."
	4 to: self ascent-1 by: 4 do:
		[:y | 		"Slide ascenders right..."
		glyphs copy: (1@0 extent: glyphs width @ (self ascent - y))
			from: 0@0 in: glyphs rule: Form over].
	self ascent to: self height-1 by: 4 do:
		[:y | 		"Slide descenders left..."
		glyphs copy: (0@y extent: glyphs width @ glyphs height)
			from: 1@y in: glyphs rule: Form over].

! !

!StrikeFont methodsFor: 'emphasis'!
makeStruckOutGlyphs
	"Make a struck-out set of glyphs with same widths"
	| g |
	g _ glyphs deepCopy.
	g fillBlack: (0 @ (self ascent - (self ascent//3)) extent: g width @ 1).
	glyphs _ g
! !

!StrikeFont methodsFor: 'emphasis'!
makeUnderlinedGlyphs
	"Make an underlined set of glyphs with same widths"
	| g |
	g _ glyphs deepCopy.
	g fillBlack: (0 @ (self ascent+1) extent: g width @ 1).
	glyphs _ g
! !

!StrikeFont methodsFor: 'emphasis' stamp: 'sma 12/30/1999 15:02'!
reset
	"Reset the cache of derivative emphasized fonts"

	| style font |
	derivativeFonts _ Array new: 32.
	#('B' 'I' 'BI') doWithIndex:
		[:tag :index | 
		(style _ TextStyle named: self familyName) ifNotNil:
			[(font _ style fontArray
				detect: [:each | each name = (self name , tag)]
				ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]]! !


!StrikeFont methodsFor: 'Mac reader'!
aComment
	"To read Mac font resources.  
1) Use ResEdit in the Fonts folder in the System Folder.  Open the file of the Font you want.  (A screen font, not a TrueType outline font).
2) Open the FOND resource and scroll down to the list of sizes and resource numbers. Note the resource number of the size you want.
3) Open the NFNT resource.  Click on the number you have noted.
4) Choose 'Open Using Hex Editor' from the resource editor.
5) Copy all of the hex numbers and paste into a text editor.  Save the file into the Smalltalk folder under the name 'FontName 12 hex' (or other size).
6) Enter the fileName below and execute: 

TextStyle default fontAt: 8 put: (StrikeFont new readMacFontHex: 'fileName').

Select text and type Command-7 to change it to your new font.

(There is some problem in the ParagraphEditor with the large size of Cairo 18.  Its line heights are not the right.)
	"! !

!StrikeFont methodsFor: 'Mac reader'!
fixKerning: extraWidth
	"Insert one pixel (extraWidth) between each character.  And add the bits for the space character"
	"Create a space character Form.  Estimate width by ascent / 2 - 1"
	| characterForm char leftX |
	characterForm _ Form extent: (ascent//2 - 1) @ self height.
	self characterFormAt: $  put: characterForm.

	"Put one pixel of space after every character.  Mac fonts have no space in the bitmap."
	extraWidth <= 0 ifTrue: [^ self].
	minAscii to: maxAscii do: [:ascii |
		char _ Character value: ascii.
		leftX _ xTable at: ascii + 1.
		characterForm _ Form extent: 
			((self widthOf: char) + extraWidth) @ self height.
		characterForm 
			copy: (characterForm boundingBox extendBy: 
				(0-extraWidth@0))
			from: leftX@0 in: glyphs rule: Form over.
		self characterFormAt: char put: characterForm.
		].	! !

!StrikeFont methodsFor: 'Mac reader' stamp: 'ar 5/23/2000 12:49'!
readMacFontHex: fileName
	"Read the hex version of a Mac FONT type resource.  See the method aComment for how to prepare the input file. 4/26/96 tk"
	| file hh fRectWidth |
	name _ fileName.	"Palatino 12"
	file _ FileStream readOnlyFileNamed: fileName, ' hex'.

	"See Inside Macintosh page IV-42 for this record"
	"FontType _ " Number readFrom: (file next: 4) base: 16.
	emphasis		_		0.
	minAscii _ Number readFrom: (file next: 4) base: 16.
	maxAscii _ Number readFrom: (file next: 4) base: 16.
	maxWidth		_ Number readFrom: (file next: 4) base: 16.
	"kernMax _ " Number readFrom: (file next: 4) base: 16.
	"NDescent _ " Number readFrom: (file next: 4) base: 16.
	fRectWidth _  Number readFrom: (file next: 4) base: 16.
	hh _  Number readFrom: (file next: 4) base: 16.
	"OWTLoc _ " Number readFrom: (file next: 4) base: 16.
	ascent			_ Number readFrom: (file next: 4) base: 16.
	descent			_ Number readFrom: (file next: 4) base: 16.
	"leading _ " Number readFrom: (file next: 4) base: 16.
	xOffset			_		0. 	
	raster			_ Number readFrom: (file next: 4) base: 16.

	strikeLength	_		raster*16.
	superscript		_		ascent - descent // 3.	
	subscript		_		descent - ascent // 3.	
	self strikeFromHex: file width: raster height: hh.
	self xTableFromHex: file.
	file close.

	"Insert one pixel between each character.  And add space character."
	self fixKerning: (fRectWidth - maxWidth).	

	"Recompute character to glyph mapping"
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'Mac reader'!
strikeFromHex: file width: w height: h
	"read in just the raw strike bits from a hex file.  No spaces or returns.  W is in words (2 bytes), h in pixels." 
	| newForm theBits offsetX offsetY str num cnt |
	offsetX  _ 0.
	offsetY _ 0.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536]. "stored two's-complement"
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536]. "stored two's-complement"
	newForm _ Form extent: strikeLength @ h offset: offsetX @ offsetY.
	theBits _ newForm bits.
	cnt _ 0.		"raster may be 16 bits, but theBits width is 32" 
	1 to: theBits size do: [:i | 
		(cnt _ cnt + 32) > strikeLength 
		  ifTrue: [cnt _ 0.
			num _ Number readFrom: (str _ file next: 4) base: 16]
		  ifFalse: [
			cnt = strikeLength ifTrue: [cnt _ 0].
			num _ Number readFrom: (str _ file next: 8) base: 16].
		theBits at: i put: num].
	glyphs _ newForm.! !

!StrikeFont methodsFor: 'Mac reader'!
xTableFromHex: file

	| strike num str wid |
	strike _ file.
	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | 
			num _ Number readFrom: (str _ strike next: 4) base: 16. 
			xTable at: index put: num].

	1 to: xTable size - 1 do: [:ind |
		wid _ (xTable at: ind+1) - (xTable at: ind).
		(wid < 0) | (wid > 40) ifTrue: [
			file close.
			self error: 'illegal character width']].
! !


!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:50'!
buildfontNamed: nm fromForms: forms startingAtAscii: startAscii
	ascent: a descent: d maxWid: m
	"This builds a StrikeFont instance from existing forms."

	| lastAscii width ascii charForm missingForm tempGlyphs |
	name _ nm.
	ascent _ 11.
	descent _ 3.
	maxWidth _ 16.
	pointSize _ 8.
	name _ (name copyWithout: Character space) ,
				(pointSize < 10
					ifTrue: ['0' , pointSize printString]
					ifFalse: [pointSize printString]).
	minAscii _ 258.
	maxAscii _ 0.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	type _ 0.  "ignored for now"

	tempGlyphs _ Form extent: (maxWidth*257) @ self height.
	xTable _ (Array new: 258) atAllPut: 0.
	xTable at: 1 put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii _ -1.
	1 to: forms size do:
		[:i | charForm _ forms at: i. width _ charForm width.
		ascii _ startAscii-1+i.
		self displayChar: ascii form: charForm.
		ascii = 256
			ifTrue: [missingForm _ charForm deepCopy]
			ifFalse:
			[minAscii _ minAscii min: ascii.
			maxAscii _ maxAscii max: ascii.
			lastAscii+1 to: ascii-1 do: [:as | xTable at: as+2 put: (xTable at: as+1)].
			tempGlyphs copy: ((xTable at: ascii+1)@0
									extent: charForm extent)
						from: 0@0 in: charForm rule: Form over.
			xTable at: ascii+2 put: (xTable at: ascii+1) + width.
			lastAscii _ ascii]].
	lastAscii+1 to: maxAscii+1 do: [:as | xTable at: as+2 put: (xTable at: as+1)].
	missingForm == nil ifFalse:
		[tempGlyphs copy: missingForm boundingBox from: missingForm
				to: (xTable at: maxAscii+2)@0 rule: Form over.
		xTable at: maxAscii+3 put: (xTable at: maxAscii+2) + missingForm width].
	glyphs _ Form extent: (xTable at: maxAscii+3) @ self height.
	glyphs copy: glyphs boundingBox from: 0@0 in: tempGlyphs rule: Form over.
	xTable _ xTable copyFrom: 1 to: maxAscii+3.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out'!
displayChar: ascii form: charForm
	"Convenience utility used during conversion of BitFont files"
	| m bigForm |
	Display fillBlack: (0@0 extent: 20@14).
	ascii printString displayAt: 0@2.
	charForm width > 0 ifTrue:
		[m _ 5.
		bigForm _ charForm magnify: charForm boundingBox by: m@m.
		Display border: ((bigForm boundingBox expandBy: m) translateBy: 50@2) width: m.
		bigForm displayAt: 50@2.
		Display fillBlack: ((50@2)+((m*charForm width)@0) extent: 1@(m*self height))].! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ls 3/27/2000 17:45'!
encodedForRemoteCanvas
	| stream |
	stream := RWBinaryOrTextStream on: ''.
	self writeAsStrike2On: stream.
	^stream contents asString! !

!StrikeFont methodsFor: 'file in/out' stamp: 'mdr 9/4/2000 10:56'!
newFromStrike: fileName
	"Build an instance from the strike font file name. The '.strike' extension
	is optional."

	| strike startName raster16 |
	name _ fileName copyUpTo: $..	"assumes extension (if any) is '.strike'".
	strike _ FileStream readOnlyFileNamed: name, '.strike.'.
	strike binary.

	"strip off direcory name if any"
	startName _ name size.
	[startName > 0 and: [((name at: startName) ~= $>) & ((name at: startName) ~= $])]]
		whileTrue: [startName _ startName - 1].
	name _ name copyFrom: startName+1 to: name size.

	type			_		strike nextWord.		"type is ignored now -- simplest
												assumed.  Kept here to make
												writing and consistency more
												straightforward."
	minAscii		_		strike nextWord.
	maxAscii		_		strike nextWord.
	maxWidth		_		strike nextWord.
	strikeLength	_		strike nextWord.
	ascent			_		strike nextWord.
	descent			_		strike nextWord.
	"xOffset			_"		strike nextWord. 	
	raster16			_		strike nextWord.	
	superscript		_		ascent - descent // 3.	
	subscript		_		descent - ascent // 3.	
	emphasis		_		0.
	glyphs			_	Form extent: (raster16 * 16) @ (self height)  
							offset: 0@0.
		glyphs bits fromByteStream: strike.

	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | xTable at: index put: strike nextWord].

	"Set up space character"
	((xTable at: (Space asciiValue + 2))  = 0 or:
			[(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])
		ifTrue:	[(Space asciiValue + 2) to: xTable size do:
					[:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].
	strike close.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to a known Font in the other system instead.  "

	"A path to me"
	(TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self].
		"special case for saving the default fonts on the disk.  See collectionFromFileNamed:"

	dp _ DiskProxy global: #StrikeFont selector: #familyName:size:emphasized:
			args: (Array with: self familyName   with: self height
					with: self emphasis).
	refStrm replace: self with: dp.
	^ dp! !

!StrikeFont methodsFor: 'file in/out' stamp: 'sma 6/1/2000 09:32'!
printOn: aStream
	super printOn: aStream.
	aStream
		nextPut: $(;
		nextPutAll: self name;
		space;
		print: self height;
		nextPut: $)! !

!StrikeFont methodsFor: 'file in/out'!
readBFHeaderFrom: f
	name _ self restOfLine: 'Font name = ' from: f.
	ascent _ (self restOfLine: 'Ascent = ' from: f) asNumber.
	descent _ (self restOfLine: 'Descent = ' from: f) asNumber.
	maxWidth _ (self restOfLine: 'Maximum width = ' from: f) asNumber.
	pointSize _ (self restOfLine: 'Font size = ' from: f) asNumber.
	name _ (name copyWithout: Character space) ,
				(pointSize < 10
					ifTrue: ['0' , pointSize printString]
					ifFalse: [pointSize printString]).
	minAscii _ 258.
	maxAscii _ 0.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ 0.
	type _ 0.  "ignored for now"
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:50'!
readFromBitFont: fileName
	"This builds a StrikeFont instance by reading the data file format
	produced by BitFont, a widely available font conversion utility
	written by Peter DiCamillo at Brown University"
	"StrikeFont new readFromBitFont: 'Palatino10.BF' "
	| f lastAscii charLine width ascii charForm line missingForm tempGlyphs iRect p rectLine left tokens right |
	f _ FileStream readOnlyFileNamed: fileName.
	self readBFHeaderFrom: f.

	"NOTE: if font has been scaled (and in any case),
	the REAL bitmap dimensions come after the header."
	self restOfLine: 'Extent information for entire font' from: f.
	"Parse the following line (including mispelling!!)"
	"Image rectange: left = -2, right = 8, bottom = -2, top = 7"
	tokens _ (f upTo: Character cr)  findTokens: ' '.
	iRect _ Rectangle left: (tokens at: 5) asNumber right: (tokens at: 8) asNumber
				top: (tokens at: 14) asNumber bottom: (tokens at: 11) asNumber.
	ascent _ iRect top.
	descent _ iRect bottom negated.
	
	tempGlyphs _ Form extent: (maxWidth*257) @ self height.
	xTable _ (Array new: 258) atAllPut: 0.
	xTable at: 1 put: 0.

	"Read character forms and blt into tempGlyphs"
	lastAscii _ -1.
	[charLine _ self restOfLine: 'Character: ' from: f.
	charLine == nil ifFalse:
		[p _ f position.
		rectLine _ f upTo: Character cr.
		(rectLine beginsWith: 'Image rectange: left = ')
			ifTrue: [tokens _ rectLine findTokens: ' '.
					left _ (tokens at: 5) asNumber. right _ (tokens at: 8) asNumber]
			ifFalse: [left _ right _ 0. f position: p].
		width_ (self restOfLine: 'Width (final pen position) = ' from: f) asNumber - left
					max: (right-left+1).
		(charLine beginsWith: 'Missing character') ifTrue: [ascii _ 256].
		('x''*' match: charLine) ifTrue:
			[ascii _ Number readFrom: (charLine copyFrom: 3 to: 4) asUppercase base: 16].
		charForm _ Form extent: width@self height.
		('*[all blank]' match: charLine) ifFalse:
			[self restOfLine: '  +' from: f.
			1 to: self height do:
				[:y | line _ f upTo: Character cr.
				4 to: (width + 3 min: line size + iRect left - left) do:
					[:x | (line at: x - iRect left + left) = $*
						ifTrue: [charForm pixelValueAt: (x-4)@(y-1) put: 1]]]]].
	charLine == nil]
		whileFalse:
			[self displayChar: ascii form: charForm.
			ascii = 256
				ifTrue: [missingForm _ charForm deepCopy]
				ifFalse:
				[minAscii _ minAscii min: ascii.
				maxAscii _ maxAscii max: ascii.
				lastAscii+1 to: ascii-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].
				tempGlyphs copy: ((xTable at: ascii+1)@0
										extent: charForm extent)
							from: 0@0 in: charForm rule: Form over.
				xTable at: ascii+2 put: (xTable at: ascii+1) + width.
				lastAscii _ ascii]].
	f close.
	lastAscii+1 to: maxAscii+1 do: [:a | xTable at: a+2 put: (xTable at: a+1)].
	missingForm == nil ifFalse:
		[tempGlyphs copy: missingForm boundingBox from: missingForm
				to: (xTable at: maxAscii+2)@0 rule: Form over.
		xTable at: maxAscii+3 put: (xTable at: maxAscii+2) + missingForm width].
	glyphs _ Form extent: (xTable at: maxAscii+3) @ self height.
	glyphs copy: glyphs boundingBox from: 0@0 in: tempGlyphs rule: Form over.
	xTable _ xTable copyFrom: 1 to: maxAscii+3.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out' stamp: 'sma 12/30/1999 14:20'!
readFromStrike2: fileName  "StrikeFont new readFromStrike2: 'Palatino14.sf2'"
	"Build an instance from the strike font stored in strike2 format.
	fileName is of the form: <family name><pointSize>.sf2"
	| file |
	('*.sf2' match: fileName) ifFalse: [self halt.  "likely incompatible"].
	name _ fileName copyUpTo: $. .  "Drop filename extension"
	file _ FileStream readOnlyFileNamed: fileName.
	file binary.
	[self readFromStrike2Stream: file] ensure: [file close]! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ar 5/23/2000 12:53'!
readFromStrike2Stream: file 
	"Build an instance from the supplied binary stream on data in strike2 format"
	type _ file nextInt32.  type = 2 ifFalse: [file close. self error: 'not strike2 format'].
	minAscii _ file nextInt32.
	maxAscii _ file nextInt32.
	maxWidth _ file nextInt32.
	ascent _ file nextInt32.
	descent _ file nextInt32.
	pointSize _ file nextInt32.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	emphasis _ file nextInt32.
	xTable _ (Array new: maxAscii + 3) atAllPut: 0.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | xTable at: index put: file nextInt32].
	glyphs _ Form new readFrom: file.

	"Set up space character"
	((xTable at: (Space asciiValue + 2))  = 0 or:
			[(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))])
		ifTrue:	[(Space asciiValue + 2) to: xTable size do:
					[:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]].
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'file in/out'!
restOfLine: leadString from: file
	"Utility method to assist reading of BitFont data files"
	| line |
	[line _ file upTo: Character cr.
	line size < leadString size or: [leadString ~= (line copyFrom: 1 to: leadString size)]]
	whileTrue: [file atEnd ifTrue: [^ nil]].
	^ line copyFrom: leadString size+1 to: line size! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ls 3/27/2000 17:43'!
writeAsStrike2On: file
	"Write me onto a file in strike2 format.
	fileName should be of the form: <family name><pointSize>.sf2"
	file binary.
	file nextInt32Put: 2.
	file nextInt32Put: minAscii.
	file nextInt32Put: maxAscii.
	file nextInt32Put: maxWidth.
	file nextInt32Put: ascent.
	file nextInt32Put: descent.
	file nextInt32Put: pointSize.
	superscript _ ascent - descent // 3.	
	subscript _ descent - ascent // 3.	
	file nextInt32Put: emphasis.
	(minAscii + 1 to: maxAscii + 3) do:
		[:index | file nextInt32Put: (xTable at: index)].
	glyphs writeOn: file.
	file close.
! !

!StrikeFont methodsFor: 'file in/out' stamp: 'ls 4/11/2000 18:57'!
writeAsStrike2named: fileName
	"Write me onto a file in strike2 format.
	fileName should be of the form: <family name><pointSize>.sf2"
	| file |
	file _ FileStream fileNamed: fileName.
	self writeAsStrike2On: file.
	file close.! !


!StrikeFont methodsFor: 'character shapes'!
alter: char formBlock: formBlock
	self characterFormAt: char 
		put: (formBlock value: (self characterFormAt: char))! !

!StrikeFont methodsFor: 'character shapes'!
characterForm: char pixelValueAt: pt put: val
	| f |
	f _ self characterFormAt: char.
	f pixelAt: pt put: val.
	self characterFormAt: char put: val! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 3/27/2000 14:25'!
characterFormAt: character 
	"Answer a Form copied out of the glyphs for the argument, character."
	| ascii leftX rightX |
	ascii _ character asciiValue.
	(ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1].
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 8/30/2000 10:00'!
characterFormAt: character put: characterForm
	"Copy characterForm over the glyph for the argument, character."
	| ascii leftX rightX widthDif newGlyphs |
	ascii _ character asciiValue.
	ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii'].
	ascii > maxAscii ifTrue:
		[(self confirm:
'This font does not accomodate ascii values higher than ' , maxAscii printString , '.
Do you wish to extend it permanently to handle values up to ' , ascii printString)
			ifTrue: [self extendMaxAsciiTo: ascii]
			ifFalse: [^ self error: 'No change made']].
	leftX _ xTable at: ascii + 1.
	rightX _ xTable at: ascii + 2.
	widthDif _ characterForm width - (rightX - leftX).
	widthDif ~= 0 ifTrue:
		["Make new glyphs with more or less space for this char"
		newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height.
		newGlyphs copy: (0@0 corner: leftX@glyphs height)
			from: 0@0 in: glyphs rule: Form over.
		newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height)
			from: rightX@0 in: glyphs rule: Form over.
		glyphs _ newGlyphs.
		"adjust further entries on xTable"
		xTable _ xTable copy.
		ascii+2 to: xTable size
			do: [:i | xTable at: i put: (xTable at: i) + widthDif]].
	glyphs copy: (leftX @ 0 extent: characterForm extent)
		from: 0@0 in: characterForm rule: Form over
"
| f |  f _ TextStyle defaultFont.
f characterFormAt: $  put: (Form extent: (f widthOf: $ )+10@f height)
"! !

!StrikeFont methodsFor: 'character shapes' stamp: 'sma 3/11/2000 11:28'!
edit: character		"(TextStyle default fontAt: 1) edit: $_"
	"Open a Bit Editor on the given character.  Note that you must do an accept
	(in the option menu of the bit editor) if you want this work.
	Accepted edits will not take effect in the font until you leave or close the bit editor.
	Also note that unaccepted edits will be lost when you leave or close."
	| charForm editRect scaleFactor bitEditor savedForm r |
	charForm _ self characterFormAt: character.
	editRect _ BitEditor locateMagnifiedView: charForm
	                                        scale: (scaleFactor _ 8@8).
	bitEditor _ BitEditor bitEdit: charForm at: editRect topLeft
			scale: scaleFactor remoteView: nil.
	savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).
	bitEditor controller startUp.
	bitEditor release.
	savedForm displayOn: Display at: r topLeft.
	self characterFormAt: character put: charForm! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 8/30/2000 10:15'!
ensureCleanBold 
	"This ensures that all character glyphs have at least one pixel of white space on the right
	so as not to cause artifacts in neighboring characters in bold or italic."

	| wider glyph |
	emphasis = 0 ifFalse: [^ self].
	minAscii to: maxAscii do:
		[:i | glyph _ self characterFormAt: (Character value: i).
		(glyph copy: (glyph boundingBox topRight - (1@0)
					corner: glyph boundingBox bottomRight)) isAllWhite ifFalse:
			[wider _ Form extent: (glyph width + 1)@glyph height.
			glyph displayOn: wider.
			self characterFormAt: (Character value: i) put: wider]].
"
StrikeFont allInstancesDo: [:f | f ensureCleanBold].
(StrikeFont familyName: 'NewYork' size: 21) ensureCleanBold.
StrikeFont shutDown.  'Flush synthetic fonts'.
"
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'ar 5/23/2000 12:48'!
extendMaxAsciiTo: newMax
	"Extend the range of this font so that it can display glyphs up to newMax."

	(newMax+3) <= xTable size ifTrue: [^ self].  "No need to extend."
	xTable size = (maxAscii+3) ifFalse:
		[^ self error: 'This font is not well-formed.'].

	"Insert a bunch of zero-width characters..."
	xTable _ (xTable copyFrom: 1 to: maxAscii+2) ,
			((maxAscii+1 to: newMax) collect: [:i | xTable at: maxAscii+2]) ,
			{ xTable at: maxAscii+3 }.
	maxAscii _ newMax.
	self fillZeroWidthSlots.
	characterToGlyphMap _ nil.! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 3/27/2000 16:10'!
fillZeroWidthSlots
	| nullGlyph |
	"Note: this is slow because it copies the font once for every replacement."

	nullGlyph _ (Form extent: 1@glyphs height) fillGray.
	"Now fill the empty slots with narrow box characters."
	minAscii to: maxAscii do:
		[:i | (self widthOf: (Character value: i)) = 0 ifTrue:
			[self characterFormAt: (Character value: i) put: nullGlyph]].
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'di 4/28/2000 16:10'!
fixOneWideChars 
	"This fixes all 1-wide characters to be 2 wide with blank on the right
	so as not to cause artifacts in neighboring characters in bold or italic."
	| twoWide |
	minAscii to: maxAscii do:
		[:i | (self widthOf: (Character value: i)) = 1 ifTrue:
			[twoWide _ Form extent: 2@glyphs height.
			(self characterFormAt: (Character value: i)) displayOn: twoWide at: 0@0.
			self characterFormAt: (Character value: i) put: twoWide]].
"
StrikeFont allInstancesDo: [:f | f fixOneWideChars].
StrikeFont shutDown.  'Flush synthetic fonts'.
"
! !

!StrikeFont methodsFor: 'character shapes' stamp: 'RAA 7/6/2000 16:50'!
makeCarriageReturnsWhite
	| crForm |
	"Some larger fonts have a gray carriage return (from the zero wide fixup) make it white so it doesn't show"

	crForm _ self characterFormAt: 13 asCharacter.
	crForm fillWhite.
	self characterFormAt: 13 asCharacter put: crForm.
! !

!StrikeFont methodsFor: 'character shapes'!
widen: char by: delta
	| newForm |
	^ self alter: char formBlock:  "Make a new form, wider or narrower..."
		[:charForm | newForm _ Form extent: charForm extent + (delta@0).
		charForm displayOn: newForm.  "Copy this image into it"
		newForm]    "and substitute it in the font"! !


!StrikeFont methodsFor: 'copying' stamp: 'tk 8/19/1998 16:15'!
veryDeepCopyWith: deepCopier
	"Return self.  I am shared.  Do not record me."! !


!StrikeFont methodsFor: 'private' stamp: 'ar 5/18/2000 18:13'!
createCharacterToGlyphMap
	"Private. Create the character to glyph mapping for a font that didn't have any before. This is basically equivalent to what the former setStopCondition did, only based on indexes."
	| map |
	map _ Array new: 256.
	0 to: minAscii - 1 do:[:i| map at: i + 1 put: maxAscii + 1].
	minAscii to: maxAscii do:[:i| map at: i + 1 put: i].
	maxAscii + 1 to: 255 do:[:i| map at: i + 1 put: maxAscii + 1].
	^map! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StrikeFont class
	instanceVariableNames: ''!

!StrikeFont class methodsFor: 'instance creation' stamp: 'ls 3/27/2000 17:49'!
decodedFromRemoteCanvas: aString
	| stream |
	stream := RWBinaryOrTextStream with: aString.
	stream reset.
	stream binary.
	^self new readFromStrike2Stream: stream! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'tk 1/28/1999 11:31'!
familyName: aName size: aSize emphasized: emphasisCode
	"Create the font with this emphasis"

	^ (self familyName: aName size: aSize) emphasized: emphasisCode! !

!StrikeFont class methodsFor: 'instance creation'!
fromStrike: fileName 
	"Read a font from disk in the old ST-80 'strike' format.
	Note: this is an old format; use strike2 format instead"

	^self new newFromStrike: fileName! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'bolot 11/2/1999 02:53'!
passwordFontSize: aSize
	| aFont newXTable newGlyphs |
	aFont _ (StrikeFont familyName: #NewYork10 size: aSize) copy.
	newXTable _ aFont xTable copy.
	newGlyphs _ aFont glyphs copy.
	aFont instVarNamed: 'xTable' put: newXTable.
	aFont instVarNamed: 'glyphs' put: newGlyphs.
	aFont minAscii to: aFont maxAscii do: [:ascii |
		aFont characterFormAt: ascii asCharacter put: (aFont characterFormAt: $*)].
	^aFont! !


!StrikeFont class methodsFor: 'examples'!
convertFontsNamed: familyName  " StrikeFont convertFontsNamed: 'NewYork' "
	"This utility is for use after you have used BitFont to produce data files 
	for the fonts you wish to use.  It will read the BitFont files and then 
	write them out in strike2 (*.sf2) format which is much more compact,
	and which can be read in again very quickly."
	"For this utility to work as is, the BitFont data files must be named
	'familyNN.BF', and must reside in the same directory as the image."
	| f |
	(FileDirectory default fileNamesMatching: familyName , '*.BF') do:
		[:fname | Transcript cr; show: fname.
		f _ StrikeFont new readFromBitFont: fname.
		f writeAsStrike2named: f name , '.sf2']! !

!StrikeFont class methodsFor: 'examples'!
example
	"Displays a line of text on the display screen at the location of the cursor.
	Example depends on the strike font file, 'TimesRoman10.strike'. existing."

	(StrikeFont new readFromStrike2: 'NewYork12.sf2')
		displayLine: 'A line of 12-pt text in New York style' at: Sensor cursorPoint
	 
	"StrikeFont example."! !


!StrikeFont class methodsFor: 'derivative font caching' stamp: 'tk 6/24/1999 11:45'!
shutDown  "StrikeFont shutDown"
	"Deallocate synthetically derived copies of base fonts to save space"
	self allSubInstancesDo: [:sf | sf reset]! !


!StrikeFont class methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:53'!
familyName: aName size: aSize
	"Answer a font (or the default font if the name is unknown) in the specified size."

	^ ((TextStyle named: aName asSymbol) ifNil: [TextStyle default]) fontOfSize: aSize! !

!StrikeFont class methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:48'!
familyNames
	^ (TextConstants select: [:each | each isKindOf: TextStyle]) keys asSortedCollection! !
ArrayedCollection variableByteSubclass: #String
	instanceVariableNames: ''
	classVariableNames: 'AsciiOrder CSLineEnders CSNonSeparators CSSeparators CaseInsensitiveOrder CaseSensitiveOrder HtmlEntities LowercasingTable Tokenish UppercasingTable '
	poolDictionaries: ''
	category: 'Collections-Text'!
!String commentStamp: '<historical>' prior: 0!
A String is an indexed collection of Characters, compactly encoded as 8-bit bytes.

String support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code.

Here are a few useful methods to look at...
	String match:
	String contractTo:

String also inherits many useful methods from its hierarchy, such as
	SequenceableCollection ,
	SequenceableCollection copyReplaceAll:with:!
]style[(269 13 2 18 72 24 2 43)f1,f1LString match:;,f1,f1LString contractTo:;,f1,f1LSequenceableCollection ,;,f1,f1LSequenceableCollection copyReplaceAll:with:;!


!String methodsFor: 'accessing'!
at: index 
	"Primitive. Answer the Character stored in the field of the receiver
	indexed by the argument. Fail if the index argument is not an Integer or
	is out of bounds. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 63>
	^Character value: (super at: index)! !

!String methodsFor: 'accessing' stamp: 'wod 6/16/1998 15:24'!
at: index put: aCharacter 
	"Primitive. Store the Character in the field of the receiver indicated by
	the index. Fail if the index is not an Integer or is out of bounds, or if
	the argument is not a Character. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 64>
	(aCharacter isKindOf: Character)
		ifTrue: [	
			index isInteger
				ifTrue: [self errorSubscriptBounds: index]
				ifFalse: [self errorNonIntegerIndex]]
		ifFalse: [self error: 'Strings only store Characters']! !

!String methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'!
byteAt: index
	<primitive: 60>
	^(self at: index) asciiValue! !

!String methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'!
byteAt: index put: value
	<primitive: 61>
	self at: index put: value asCharacter.
	^value! !

!String methodsFor: 'accessing'!
endsWithDigit
	"Answer whether the receiver's final character represents a digit.  3/11/96 sw"

	^ self size > 0 and: [self last isDigit]! !

!String methodsFor: 'accessing' stamp: 'tk 12/26/97 11:09'!
findAnySubStr: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters.  delimiters is an Array of Strings (Characters are permitted also).  If the receiver does not contain any of the delimiters, answer size + 1."

	| min ind |
	min _ self size + 1.
	delimiters do: [:delim |	"May be a char, a string of length 1, or a substring"
		delim class == Character 
			ifTrue: [ind _ self indexOfSubCollection: (String with: delim) 
						startingAt: start ifAbsent: [min]]
			ifFalse: [ind _ self indexOfSubCollection: delim 
						startingAt: start ifAbsent: [min]].
			min _ min min: ind].
	^ min! !

!String methodsFor: 'accessing' stamp: 'dew 11/15/2000 15:02'!
findBetweenSubStrs: delimiters
	"Answer the collection of String tokens that result from parsing self.  Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters.  Several delimiters in a row are considered as just one separation."

	| tokens keyStart keyStop |
	tokens _ OrderedCollection new.
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipAnySubStr: delimiters startingAt: keyStop.
		keyStop _ self findAnySubStr: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'ls 3/19/2000 16:43'!
findCloseParenthesisFor: startIndex
	"assume (self at: startIndex) is $(.  Find the matching $), allowing parentheses to nest."
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 "
	" '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 "
	| pos nestLevel |
	pos := startIndex+1.
	nestLevel := 1.
	[ pos <= self size ] whileTrue: [
		(self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ].
		(self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ].
		nestLevel = 0 ifTrue: [ ^pos ].
		pos := pos + 1.
	].
	^self size + 1! !

!String methodsFor: 'accessing'!
findDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1."

	start to: self size do: [:i |
		delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: 'ar 4/11/1999 22:15'!
findString: subString
	"Answer the index of subString within the receiver, starting at start. If 
	the receiver does not contain subString, answer 0."
	^self findString: subString startingAt: 1.! !

!String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:43'!
findString: subString startingAt: start 
	"Answer the index of subString within the receiver, starting at start. If 
	the receiver does not contain subString, answer 0."

	^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder! !

!String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:45'!
findString: key startingAt: start caseSensitive: caseSensitive
	"Answer the index in this String at which the substring key first occurs, at or beyond start.  The match can be case-sensitive or not.  If no match is found, zero will be returned."

	caseSensitive
	ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder]
	ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]! !

!String methodsFor: 'accessing' stamp: 'tk 8/10/2000 09:14'!
findTokens: delimiters
	"Answer the collection of tokens that result from parsing self.  Return strings between the delimiters.  Any character in the Collection delimiters marks a border.  Several delimiters in a row are considered as just one separation.  Also, allow delimiters to be a single character."

	| tokens keyStart keyStop separators |

	tokens _ OrderedCollection new.
	separators _ delimiters class == Character 
		ifTrue: [Array with: delimiters]
		ifFalse: [delimiters].
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipDelimiters: separators startingAt: keyStop.
		keyStop _ self findDelimiters: separators startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'tk 12/26/97 09:50'!
findTokens: delimiters includes: subString
	"Divide self into pieces using delimiters.  Return the piece that includes subString anywhere in it.  Is case sensitive (say asLowercase to everything beforehand to make insensitive)."

^ (self findTokens: delimiters) 
	detect: [:str | (str includesSubString: subString)] 
	ifNone: [nil]! !

!String methodsFor: 'accessing' stamp: 'tk 6/19/97 10:05'!
findTokens: delimiters keep: keepers
	"Answer the collection of tokens that result from parsing self.  The tokens are seperated by delimiters, any of a string of characters.  If a delimiter is also in keepers, make a token for it.  (Very useful for carriage return.  A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)"

	| tokens keyStart keyStop |
	tokens _ OrderedCollection new.
	keyStop _ 1.
	[keyStop <= self size] whileTrue:
		[keyStart _ self skipDelimiters: delimiters startingAt: keyStop.
		keyStop to: keyStart-1 do: [:ii | 
			(keepers includes: (self at: ii)) ifTrue: [
				tokens add: (self copyFrom: ii to: ii)]].	"Make this keeper be a token"
		keyStop _ self findDelimiters: delimiters startingAt: keyStart.
		keyStart < keyStop
			ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]].
	^tokens! !

!String methodsFor: 'accessing' stamp: 'sw 8/12/97 12:37'!
includesSubString: subString
	^ (self findString: subString startingAt: 1) > 0! !

!String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:53'!
includesSubstring: aString caseSensitive: caseSensitive
	
	^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! !

!String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'!
indexOf: aCharacter

	(aCharacter class == Character) ifFalse: [^ 0].
	^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: 1! !

!String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'!
indexOf: aCharacter  startingAt: start

	(aCharacter class == Character) ifFalse: [^ 0].
	^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start! !

!String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'!
indexOf: aCharacter  startingAt: start  ifAbsent: aBlock
	| ans |
	(aCharacter class == Character) ifFalse: [ ^ aBlock value ].
	ans _ String indexOfAscii: aCharacter asciiValue inString: self  startingAt: start.
	ans = 0
		ifTrue: [ ^ aBlock value ]
		ifFalse: [ ^ ans ]! !

!String methodsFor: 'accessing' stamp: 'ls 8/20/1998 05:20'!
indexOfAnyOf: aCharacterSet
	"returns the index of the first character in the given set.  Returns 0 if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: 1! !

!String methodsFor: 'accessing' stamp: 'ls 8/20/1998 05:19'!
indexOfAnyOf: aCharacterSet  ifAbsent: aBlock
	"returns the index of the first character in the given set.  Returns the evaluation of aBlock if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: 1  ifAbsent: aBlock! !

!String methodsFor: 'accessing' stamp: 'ls 8/20/1998 05:19'!
indexOfAnyOf: aCharacterSet  startingAt: start
	"returns the index of the first character in the given set, starting from start.  Returns 0 if none are found"
	^self indexOfAnyOf: aCharacterSet  startingAt: start  ifAbsent: [ 0 ]! !

!String methodsFor: 'accessing' stamp: 'ls 8/18/1998 00:27'!
indexOfAnyOf: aCharacterSet  startingAt: start ifAbsent: aBlock
	"returns the index of the first character in the given set, starting from start"

	| ans |
	ans _ String findFirstInString: self  inSet: aCharacterSet byteArrayMap startingAt: start.

	ans = 0 
		ifTrue: [ ^aBlock value ]
		ifFalse: [ ^ans ]! !

!String methodsFor: 'accessing' stamp: 'di 11/15/1998 17:02'!
indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock
	| index |
	index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder.
	index = 0 ifTrue: [^ exceptionBlock value].
	^ index! !

!String methodsFor: 'accessing'!
lineCorrespondingToIndex: anIndex
	"Answer a string containing the line at the given character position.  1/15/96 sw:  Inefficient first stab at this"

	| cr aChar answer |
	cr _ Character cr.
	answer _ ''.
	1 to: self size do:
		[:i | 
			aChar _ self at: i.
			aChar == cr
				ifTrue:
					[i > anIndex
						ifTrue:
							[^ answer]
						ifFalse:
							[answer _ '']]
				ifFalse:
					[answer _ answer copyWith: aChar]].
	^ answer! !

!String methodsFor: 'accessing'!
lineCount
	"Answer the number of lines represented by the receiver, where every cr adds one line.  5/10/96 sw"

	| cr count |
	cr _ Character cr.
	count _ 1  min: self size..
	1 to: self size do:
		[:i | (self at: i) == cr ifTrue: [count _ count + 1]].
	^ count

"
'Fred
the
Bear' lineCount
"! !

!String methodsFor: 'accessing'!
lineNumber: anIndex
	"Answer a string containing the characters in the given line number.  5/10/96 sw"

	| crString pos finalPos |
	crString _ String with: Character cr.
	pos _ 0.
	1 to: anIndex - 1 do:
		[:i | pos _ self findString: crString startingAt: pos + 1.
			pos == 0 ifTrue: [^ nil]].
	finalPos _ self findString: crString startingAt: pos + 1.
	finalPos == 0 ifTrue: [finalPos _ self size + 1].
	^ self copyFrom: pos + 1 to: finalPos - 1

"
'Fred
the
Bear' lineNumber: 3
"! !

!String methodsFor: 'accessing' stamp: 'ls 9/10/1998 22:27'!
linesDo: aBlock
	"execute aBlock with each line in this string.  The terminating CR's are not included in what is passed to aBlock"
	| start end |
	start _ 1.
	[ start <= self size ] whileTrue: [
		end _ self indexOf: Character cr  startingAt: start  ifAbsent: [ self size + 1 ].
		end _ end - 1.

		aBlock value: (self copyFrom: start  to: end).
		start _ end + 2. ].! !

!String methodsFor: 'accessing' stamp: 'BJP 6/12/2000 18:53'!
skipAnySubStr: delimiters startingAt: start 
	"Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed).  If the receiver is all delimiters, answer size + 1."
	| any this ind ii |
	ii _ start-1.
	[(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match"
		any _ false.
		delimiters do: [:delim |
			delim class == Character 
				ifTrue: [(self at: ii) == delim ifTrue: [any _ true]]
				ifFalse: ["a substring"
					delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was."
						[ind _ 0.
						this _ true.
						delim do: [:dd | 
							dd == (self at: ii+ind) ifFalse: [this _ false].
							ind _ ind + 1].
						this ifTrue: [ii _ ii + delim size - 1.  any _ true]]
							ifTrue: [any _ false] "if the delim is too big, it can't match"]].
		any ifFalse: [^ ii]].
	^ self size + 1! !

!String methodsFor: 'accessing'!
skipDelimiters: delimiters startingAt: start 
	"Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1.  Assumes the delimiters to be a non-empty string."

	start to: self size do: [:i |
		delimiters detect: [:delim | delim = (self at: i)]
				ifNone: [^ i]].
	^ self size + 1! !

!String methodsFor: 'accessing' stamp: 'sw 4/23/1998 10:53'!
startsWithDigit
	"Answer whether the receiver's first character represents a digit"

	^ self size > 0 and: [self first isDigit]! !


!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:16'!
< aString 
	"Answer whether the receiver sorts before aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) = 1! !

!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:17'!
<= aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) <= 2! !

!String methodsFor: 'comparing' stamp: 'di 9/14/1998 16:29'!
= aString 
	"Answer whether the receiver sorts equally as aString.
	The collation order is simple ascii (with case differences)."

	aString species == String ifFalse: [^ false].

	^ (self compare: self with: aString collated: AsciiOrder) = 2! !

!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:17'!
> aString 
	"Answer whether the receiver sorts after aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) = 3! !

!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:18'!
>= aString 
	"Answer whether the receiver sorts after or equal to aString.
	The collation order is simple ascii (with case differences)."

	^ (self compare: self with: aString collated: AsciiOrder) >= 2! !

!String methodsFor: 'comparing'!
alike: aString 
	"Answer some indication of how alike the receiver is to the argument,  0 is no match, twice aString size is best score.  Case is ignored."

	| i j k minSize bonus |
	minSize _ (j _ self size) min: (k _ aString size).
	bonus _ (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ].
	i _ 1.
	[(i <= minSize) and: [((super at: i) bitAnd: 16rDF)  = ((aString at: i) asciiValue bitAnd: 16rDF)]]
		whileTrue: [ i _ i + 1 ].
	[(j > 0) and: [(k > 0) and:
		[((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]]
			whileTrue: [ j _ j - 1.  k _ k - 1. ].
	^ i - 1 + self size - j + bonus. ! !

!String methodsFor: 'comparing' stamp: 'di 11/15/1998 17:25'!
beginsWith: prefix
	"Answer whether the receiver begins with the given prefix string.
	The comparison is case-sensitive."

	self size < prefix size ifTrue: [^ false].
	^ (self findSubstring: prefix in: self startingAt: 1
			matchTable: CaseSensitiveOrder) = 1
! !

!String methodsFor: 'comparing' stamp: 'sw 4/19/1999 12:11'!
caseInsensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case insensitive."

	^ (self compare: self with: aString collated: CaseInsensitiveOrder) <= 2! !

!String methodsFor: 'comparing' stamp: 'di 9/20/1998 14:33'!
caseSensitiveLessOrEqual: aString 
	"Answer whether the receiver sorts before or equal to aString.
	The collation order is case sensitive."

	^ (self compare: self with: aString collated: CaseSensitiveOrder) <= 2! !

!String methodsFor: 'comparing' stamp: 'tk 9/5/2000 10:42'!
charactersExactlyMatching: aString
	"Do a character-by-character comparison between the receiver and aString.  Return the index of the final character that matched exactly."

	| count |
	count _ self size min: aString size.
	1 to: count do: [:i | 
		(self at: i) == (aString at: i) ifFalse: [
			^ i - 1]].
	^ count! !

!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:41'!
compare: aString 
	"Answer a comparison code telling how the receiver sorts relative to aString:
		1 - before
		2 - equal
		3 - after.
	The collation sequence is ascii with case differences ignored.
	To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2."

	^ self compare: self with: aString collated: CaseInsensitiveOrder! !

!String methodsFor: 'comparing' stamp: 'go 2/11/98 14:59'!
crc16
	"Compute a 16 bit cyclic redundancy check."

	| crc |
	crc := 0.
	self do: [:c |
		crc := (crc bitShift: -8) bitXor: (
		 #(	16r0000	16rC0C1	16rC181	16r0140	16rC301	16r03C0	16r0280	16rC241
			16rC601	16r06C0	16r0780	16rC741	16r0500	16rC5C1	16rC481	16r0440
			16rCC01	16r0CC0	16r0D80	16rCD41	16r0F00	16rCFC1	16rCE81	16r0E40
			16r0A00	16rCAC1	16rCB81	16r0B40	16rC901	16r09C0	16r0880	16rC841
			16rD801	16r18C0	16r1980	16rD941	16r1B00	16rDBC1	16rDA81	16r1A40
			16r1E00	16rDEC1	16rDF81	16r1F40	16rDD01	16r1DC0	16r1C80	16rDC41
			16r1400	16rD4C1	16rD581	16r1540	16rD701	16r17C0	16r1680	16rD641
			16rD201	16r12C0	16r1380	16rD341	16r1100	16rD1C1	16rD081	16r1040
			16rF001	16r30C0	16r3180	16rF141	16r3300	16rF3C1	16rF281	16r3240
			16r3600	16rF6C1	16rF781	16r3740	16rF501	16r35C0	16r3480	16rF441
			16r3C00	16rFCC1	16rFD81	16r3D40	16rFF01	16r3FC0	16r3E80	16rFE41
			16rFA01	16r3AC0	16r3B80	16rFB41	16r3900	16rF9C1	16rF881	16r3840
			16r2800	16rE8C1	16rE981	16r2940	16rEB01	16r2BC0	16r2A80	16rEA41
			16rEE01	16r2EC0	16r2F80	16rEF41	16r2D00	16rEDC1	16rEC81	16r2C40
			16rE401	16r24C0	16r2580	16rE541	16r2700	16rE7C1	16rE681	16r2640
			16r2200	16rE2C1	16rE381	16r2340	16rE101	16r21C0	16r2080	16rE041
			16rA001	16r60C0	16r6180	16rA141	16r6300	16rA3C1	16rA281	16r6240
			16r6600	16rA6C1	16rA781	16r6740	16rA501	16r65C0	16r6480	16rA441
			16r6C00	16rACC1	16rAD81	16r6D40	16rAF01	16r6FC0	16r6E80	16rAE41
			16rAA01	16r6AC0	16r6B80	16rAB41	16r6900	16rA9C1	16rA881	16r6840
			16r7800	16rB8C1	16rB981	16r7940	16rBB01	16r7BC0	16r7A80	16rBA41
			16rBE01	16r7EC0	16r7F80	16rBF41	16r7D00	16rBDC1	16rBC81	16r7C40
			16rB401	16r74C0	16r7580	16rB541	16r7700	16rB7C1	16rB681	16r7640
			16r7200	16rB2C1	16rB381	16r7340	16rB101	16r71C0	16r7080	16rB041
			16r5000	16r90C1	16r9181	16r5140	16r9301	16r53C0	16r5280	16r9241
			16r9601	16r56C0	16r5780	16r9741	16r5500	16r95C1	16r9481	16r5440
			16r9C01	16r5CC0	16r5D80	16r9D41	16r5F00	16r9FC1	16r9E81	16r5E40
			16r5A00	16r9AC1	16r9B81	16r5B40	16r9901	16r59C0	16r5880	16r9841
			16r8801	16r48C0	16r4980	16r8941	16r4B00	16r8BC1	16r8A81	16r4A40
			16r4E00	16r8EC1	16r8F81	16r4F40	16r8D01	16r4DC0	16r4C80	16r8C41
			16r4400	16r84C1	16r8581	16r4540	16r8701	16r47C0	16r4680	16r8641
			16r8201	16r42C0	16r4380	16r8341	16r4100	16r81C1	16r8081	16r4040)
			 at: ((crc bitXor: c asciiValue) bitAnd: 16rFF) + 1) ].
	^crc! !

!String methodsFor: 'comparing' stamp: 'di 11/15/1998 17:25'!
endsWith: suffix
	"Answer whether the tail end of the receiver is the same as suffix.
	The comparison is case-sensitive."
	| extra |
	(extra _ self size - suffix size) < 0 ifTrue: [^ false].
	^ (self findSubstring: suffix in: self startingAt: extra + 1
			matchTable: CaseSensitiveOrder) > 0
"
  'Elvis' endsWith: 'vis'
"! !

!String methodsFor: 'comparing' stamp: 'ar 11/19/1998 21:48'!
endsWithAnyOf: aCollection
	aCollection do:[:suffix|
		(self endsWith: suffix) ifTrue:[^true].
	].
	^false! !

!String methodsFor: 'comparing'!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!String methodsFor: 'comparing' stamp: 'tk 9/5/2000 10:48'!
howManyMatch: aString
	"Count the number of characters that match up in self and aString."

| count shorterLength |
count _ 0.
shorterLength _ self size min: aString size.
1 to: shorterLength do: [:index | 
	(self at: index) = (aString at: index) ifTrue: [
		count _ count + 1]].
^ count! !

!String methodsFor: 'comparing' stamp: 'di 11/19/1998 13:37'!
match: text
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."

	^ self startingAt: 1 match: text startingAt: 1
"
	'*'			match: 'zort' true
	'*baz'		match: 'mobaz' true
	'*baz'		match: 'mobazo' false
	'*baz*'		match: 'mobazo' true
	'*baz*'		match: 'mozo' false
	'foo*'		match: 'foozo' true
	'foo*'		match: 'bozo' false
	'foo*baz'	match: 'foo23baz' true
	'foo*baz'	match: 'foobaz' true
	'foo*baz'	match: 'foo23bazo' false
	'foo'		match: 'Foo' true
	'foo*baz*zort' match: 'foobazort' false
	'foo*baz*zort' match: 'foobazzort' false
	'*foo#zort'	match: 'afoo3zortthenfoo3zort' true
	'*foo*zort'	match: 'afoodezortorfoo3zort' true
"! !

!String methodsFor: 'comparing' stamp: 'di 2/27/98 12:19'!
sameAs: aString 
	"Answer whether the receiver sorts equal to aString. The 
	collation sequence is ascii with case differences ignored."

	^ (self compare: self with: aString collated: CaseInsensitiveOrder) = 2! !

!String methodsFor: 'comparing' stamp: 'di 11/19/1998 13:28'!
startingAt: keyStart match: text startingAt: textStart
	"Answer whether text matches the pattern in this string.
	Matching ignores upper/lower case differences.
	Where this string contains #, text may contain any character.
	Where this string contains *, text may contain any sequence of characters."
	| anyMatch matchStart matchEnd i matchStr j ii jj |
	i _ keyStart.
	j _ textStart.

	"Check for any #'s"
	[i > self size ifTrue: [^ j > text size "Empty key matches only empty string"].
	(self at: i) = $#] whileTrue:
		["# consumes one char of key and one char of text"
		j > text size ifTrue: [^ false "no more text"].
		i _ i+1.  j _ j+1].

	"Then check for *"
	(self at: i) = $*
		ifTrue: [i = self size ifTrue:
					[^ true "Terminal * matches all"].
				"* means next match string can occur anywhere"
				anyMatch _ true.
				matchStart _ i + 1]
		ifFalse: ["Otherwise match string must occur immediately"
				anyMatch _ false.
				matchStart _ i].

	"Now determine the match string"
	matchEnd _ self size.
	(ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue:
		[ii = 1 ifTrue: [self error: '** not valid -- use * instead'].
		matchEnd _ ii-1].
	(ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue:
		[ii = 1 ifTrue: [self error: '*# not valid -- use #* instead'].
		matchEnd _ matchEnd min: ii-1].
	matchStr _ self copyFrom: matchStart to: matchEnd.

	"Now look for the match string"
	[jj _ text findString: matchStr startingAt: j caseSensitive: false.
	anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]]
		whileTrue:
		["Found matchStr at jj.  See if the rest matches..."
		(self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue:
			[^ true "the rest matches -- success"].
		"The rest did not match."
		anyMatch ifFalse: [^ false].
		"Preceded by * -- try for a later match"
		j _ j+1].
	^ false "Failed to find the match string"! !


!String methodsFor: 'copying'!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded
	by non-alphanumeric characters"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! !

!String methodsFor: 'copying'!
deepCopy
	"DeepCopy would otherwise mean make a copy of the character;  since 
	characters are unique, just return a shallowCopy."

	^self shallowCopy! !

!String methodsFor: 'copying' stamp: 'di 2/15/98 22:54'!
padded: leftOrRight to: length with: char
	leftOrRight = #left ifTrue:
		[^ (String new: (length - self size max: 0) withAll: char) , self].
	leftOrRight = #right ifTrue:
		[^ self , (String new: (length - self size max: 0) withAll: char)].! !


!String methodsFor: 'converting' stamp: 'di 11/6/1998 13:47'!
adaptToCollection: rcvr andSend: selector
	"If I am involved in arithmetic with a collection, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'di 11/9/1998 12:17'!
adaptToNumber: rcvr andSend: selector
	"If I am involved in arithmetic with a number, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'di 11/6/1998 13:49'!
adaptToPoint: rcvr andSend: selector
	"If I am involved in arithmetic with a point, convert me to a number."

	^ rcvr perform: selector with: self asNumber! !

!String methodsFor: 'converting' stamp: 'di 11/6/1998 13:49'!
adaptToString: rcvr andSend: selector
	"If I am involved in arithmetic with a string, convert us both to
	numbers, and return the printString of the result."

	^ (rcvr asNumber perform: selector with: self asNumber) printString! !

!String methodsFor: 'converting' stamp: 'sw 9/1/2000 10:39'!
asCharacter
	"Answer the receiver's first character, or '¥' if none.  Idiosyncratic, provisional."

	^ self size > 0 ifTrue: [self first] ifFalse: [$¥]! !

!String methodsFor: 'converting' stamp: 'tk 1/24/98 11:22'!
asDate
	"Many allowed forms, see Date.readFrom:"
	^ Date readFrom: (ReadStream on: self)! !

!String methodsFor: 'converting'!
asDisplayText
	"Answer a DisplayText whose text string is the receiver."

	^DisplayText text: self asText! !

!String methodsFor: 'converting'!
asFileName
	"Answer a String made up from the receiver that is an acceptable file 
	name."

	^FileDirectory checkName: self fixErrors: true! !

!String methodsFor: 'converting' stamp: 'acg 9/11/1999 15:43'!
asFourCode

	|result|
	self size = 4 ifFalse: [^self error: 'must be exactly four characters'].
	result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue].
	(result bitAnd: 16r80000000) = 0 
		ifFalse: [self error: 'cannot resolve fourcode'].
	(result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000].
	^result! !

!String methodsFor: 'converting' stamp: 'sma 3/11/2000 17:25'!
asHtml
	"Do the basic character conversion for HTML.  Leave all original return 
	and tabs in place, so can conver back by simply removing bracked 
	things. 4/4/96 tk"
	| temp |
	temp _ self copyReplaceAll: '&' with: '&amp;'.
	HtmlEntities keysAndValuesDo:
		[:entity :char |
		char = $& ifFalse:
			[temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']].
	temp _ temp copyReplaceAll: '	' with: '	<IMG SRC="tab.gif" ALT="    ">'.
	temp _ temp copyReplaceAll: '
' with: '
<BR>'.
	^ temp

"
	'A<&>B' asHtml
"! !

!String methodsFor: 'converting' stamp: 'ls 9/5/1998 01:19'!
asIRCLowercase
	"Answer a String made up from the receiver whose characters are all 
	lowercase, where 'lowercase' is by IRC's definition"

	^self collect: [ :c | c asIRCLowercase ]! !

!String methodsFor: 'converting' stamp: 'sw 9/5/2000 09:03'!
asIdentifier: shouldBeCapitalized
	"Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case.  This will always return a legal identifier, even for an empty string"

	| aString firstChar firstLetterPosition |
	aString _ self select: [:el | el isAlphaNumeric].
	firstLetterPosition _ aString findFirst: [:ch | ch isLetter].
	aString _ firstLetterPosition == 0
		ifFalse:
			[aString copyFrom: firstLetterPosition to: aString size]
		ifTrue:
			['a', aString].
	firstChar _ shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase].

	^ firstChar asString, (aString copyFrom: 2 to: aString size)
"
'234Fred987' asIdentifier: false
'235Fred987' asIdentifier: true
'' asIdentifier: true
'()87234' asIdentifier: false
'())z>=PPve889  U >' asIdentifier: false

"! !

!String methodsFor: 'converting' stamp: 'sw 9/1/2000 10:40'!
asInteger 
	"Answer the Integer created by interpreting the receiver as the string representation of an integer.  Answer nil if no digits, else find the first digit and then all consecutive digits after that"

	| startPosition tail endPosition |
	startPosition _ self findFirst: [:ch | ch isDigit].
	startPosition == 0 ifTrue: [^ nil].
	tail _ self copyFrom: startPosition to: self size.
	endPosition _ tail findFirst: [:ch | ch isDigit not].
	endPosition == 0 ifTrue: [endPosition _ tail size + 1].
	^ Number readFromString: (tail copyFrom: 1 to: endPosition - 1)

"
'1796exportFixes-tkMX' asInteger
'1848recentLogFile-sw'  asInteger
'donald' asInteger
'abc234def567' asInteger
"! !

!String methodsFor: 'converting' stamp: 'sw 5/3/1998 23:19'!
asLegalSelector
	| toUse |
	toUse _ ''.
	self do:
		[:char | char isAlphaNumeric ifTrue: [toUse _ toUse copyWith: char]].
	(self size == 0 or: [self first isLetter not])
		ifTrue:		[toUse _ 'v', toUse].

	^ toUse withFirstCharacterDownshifted

"'234znak 43 ) 2' asLegalSelector"! !

!String methodsFor: 'converting' stamp: 'sma 6/12/2000 11:40'!
asLowercase
	"Answer a String made up from the receiver whose characters are all 
	lowercase."

	^ self copy asString translateToLowercase! !

!String methodsFor: 'converting'!
asNumber 
	"Answer the Number created by interpreting the receiver as the string 
	representation of a number."

	^Number readFromString: self! !

!String methodsFor: 'converting'!
asPacked
	"Convert to a longinteger that describes the string"
	^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! !

!String methodsFor: 'converting'!
asParagraph
	"Answer a Paragraph whose text string is the receiver."

	^Paragraph withText: self asText! !

!String methodsFor: 'converting' stamp: 'RAA 9/19/2000 17:00'!
asPostscript

	| temp |
	temp _ self asString copyReplaceAll: '(' with: '\('.
	temp _ temp copyReplaceAll: ')' with: '\)'.
	temp _ temp copyReplaceAll: '
' 
			with: ''.
	^ PostscriptEncoder mapMacStringToPS: temp! !

!String methodsFor: 'converting' stamp: 'jm 5/14/1998 10:40'!
asString
	"Answer this string."

	^ self
! !

!String methodsFor: 'converting'!
asSymbol
	"Answer the unique Symbol whose characters are the characters of the 
	string."

	^Symbol intern: self! !

!String methodsFor: 'converting'!
asText
	"Answer a Text whose string is the receiver."

	^Text fromString: self! !

!String methodsFor: 'converting' stamp: 'tk 1/24/98 11:27'!
asTime
	"Many allowed forms, see Time.readFrom:"
	^ Time readFrom: (ReadStream on: self)! !

!String methodsFor: 'converting' stamp: 'di 9/2/1999 08:42'!
asUnHtml
	"Strip out all Html stuff (commands in angle brackets <>) and convert
the characters &<> back to their real value.  Leave actual cr and tab as
they were in text."
	| in out char rest did |
	in _ ReadStream on: self.
	out _ WriteStream on: (String new: self size).
	[in atEnd] whileFalse:
		[in peek = $<
			ifTrue: [in unCommand] 	"Absorb <...><...>"
			ifFalse: [(char _ in next) = $&
						ifTrue: [rest _ in upTo: $;.
								did _ out position.
								rest = 'lt' ifTrue: [out nextPut: $<].
								rest = 'gt' ifTrue: [out nextPut: $>].
								rest = 'amp' ifTrue: [out nextPut: $&].
								did = out position ifTrue: [
									self error: 'new HTML char encoding'.
									"Please add it to this code"]]
						ifFalse: [out nextPut: char]].
		].
	^ out contents! !

!String methodsFor: 'converting' stamp: 'SqR 6/13/2000 20:10'!
asUppercase
	"Answer a String made up from the receiver whose characters are all 
	uppercase."

	^self copy asString translateToUppercase! !

!String methodsFor: 'converting' stamp: 'ls 6/29/1998 00:35'!
asUrl
	"convert to a Url"
	"'http://www.cc.gatech.edu/' asUrl"
	"msw://chaos.resnet.gatech.edu:9000/' asUrl"
	^Url absoluteFromText: self! !

!String methodsFor: 'converting' stamp: 'ls 7/15/1998 18:40'!
asUrlRelativeTo: aUrl
	^aUrl newFromRelativeText: self! !

!String methodsFor: 'converting' stamp: 'di 2/2/98 12:59'!
askIfAddStyle: priorMethod req: requestor
	^ self   "we are a string with no text style"! !

!String methodsFor: 'converting' stamp: 'ls 9/10/1998 08:48'!
capitalized
	"Return a copy with the first letter capitalized"
	| cap |
	self isEmpty ifTrue: [ ^self copy ].
	cap _ self copy.
	cap at: 1 put: (cap at: 1) asUppercase.
	^ cap! !

!String methodsFor: 'converting'!
compressWithTable: tokens
	"Return a string with all substrings that occur in tokens replaced
	by a character with ascii code = 127 + token index.
	This will work best if tokens are sorted by size.
	Assumes this string contains no characters > 127, or that they
	are intentionally there and will not interfere with this process."
	| str null finalSize start result ri c ts |
	null _ Character value: 0.
	str _ self copyFrom: 1 to: self size.  "Working string will get altered"
	finalSize _ str size.
	tokens doWithIndex:
		[:token :tIndex |
		start _ 1.
		[(start _ str findString: token startingAt: start) > 0]
			whileTrue:
			[ts _ token size.
			((start + ts) <= str size
				and: [(str at: start + ts) = $  and: [tIndex*2 <= 128]])
				ifTrue: [ts _ token size + 1.  "include training blank"
						str at: start put: (Character value: tIndex*2 + 127)]
				ifFalse: [str at: start put: (Character value: tIndex + 127)].
			str at: start put: (Character value: tIndex + 127).
			1 to: ts-1 do: [:i | str at: start+i put: null].
			finalSize _ finalSize - (ts - 1).
			start _ start + ts]].
	result _ String new: finalSize.
	ri _ 0.
	1 to: str size do:
		[:i | (c _ str at: i) = null ifFalse: [result at: (ri _ ri+1) put: c]].
	^ result! !

!String methodsFor: 'converting' stamp: 'di 1/16/98 16:33'!
contractTo: smallSize
	"return myself or a copy shortened by ellipsis to smallSize"
	| leftSize |
	self size <= smallSize
		ifTrue: [^ self].  "short enough"
	smallSize < 5
		ifTrue: [^ self copyFrom: 1 to: smallSize].    "First N characters"
	leftSize _ smallSize-2//2.
	^ self copyReplaceFrom: leftSize+1		"First N/2 ... last N/2"
		to: self size - (smallSize - leftSize - 3)
		with: '...'
"
	'A clear but rather long-winded summary' contractTo: 18
"! !

!String methodsFor: 'converting'!
correctAgainst: wordList
	"Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList.  Depends on the scoring scheme of alike:"
	| results |
	results _ self correctAgainst: wordList continuedFrom: nil.
	results _ self correctAgainst: nil continuedFrom: results.
	^ results! !

!String methodsFor: 'converting' stamp: 'ar 5/1/1999 05:01'!
correctAgainst: wordList continuedFrom: oldCollection
	"Like correctAgainst:.  Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList."

	^ wordList isNil
		ifTrue: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil]
					continuedFrom: oldCollection ]! !

!String methodsFor: 'converting'!
correctAgainstDictionary: wordDict continuedFrom: oldCollection
	"Like correctAgainst:continuedFrom:.  Use when you want to correct against a dictionary."

	^ wordDict isNil
		ifTrue: [ self correctAgainstEnumerator: nil
					continuedFrom: oldCollection ]
		ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ]
					continuedFrom: oldCollection ]! !

!String methodsFor: 'converting' stamp: 'ls 8/12/1998 23:31'!
encodeForHTTP
	"change dangerous characters to their %XX form, for use in HTTP transactions"
	| encodedStream |
	encodedStream _ WriteStream on: (String new).
	
	self do: [ :c |
		c isSafeForHTTP ifTrue: [ encodedStream nextPut: c ] ifFalse: [
			encodedStream nextPut: $%.
			encodedStream nextPut: (c asciiValue // 16) asHexDigit.
			encodedStream nextPut: (c asciiValue \\ 16) asHexDigit.
		]
	].
	^encodedStream contents. ! !

!String methodsFor: 'converting' stamp: 'bf 10/13/1999 09:26'!
findSelector
	"Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it."
	| sel possibleParens level n |
	sel _ self withBlanksTrimmed.
	(sel includes: $:) ifTrue:
		[possibleParens _ sel findTokens: Character separators.
		sel _ String streamContents:
			[:s | level _ 0.
			possibleParens do:
				[:token |
				(level = 0 and: [token endsWith: ':'])
					ifTrue: [s nextPutAll: token]
					ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n].
							(n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n].
							(n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]].

	sel isEmpty ifTrue: [^ nil].
	Symbol hasInterned: sel ifTrue:
		[:aSymbol | ^ aSymbol].
	^ nil! !

!String methodsFor: 'converting' stamp: 'sw 8/20/1999 10:23'!
initialIntegerOrNil
	"Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit"
	| firstNonDigit |
	(self size == 0 or: [self first isDigit not]) ifTrue: [^ nil].
	firstNonDigit _ (self findFirst: [:m | m isDigit not]).
	firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1].
	^ (self copyFrom: 1  to: (firstNonDigit - 1)) asNumber
"
'234Whoopie' initialIntegerOrNil
'wimpy' initialIntegerOrNil
'234' initialIntegerOrNil
'2N' initialIntegerOrNil
'2' initialIntegerOrNil
'  89Ten ' initialIntegerOrNil
'78 92' initialIntegerOrNil
"
! !

!String methodsFor: 'converting' stamp: 'di 4/22/2000 16:05'!
keywords
	"Answer an array of the keywords that compose the receiver."
	| kwd char keywords |
	keywords _ Array streamContents:
		[:kwds | kwd _ WriteStream on: (String new: 16).
		1 to: self size do:
			[:i |
			kwd nextPut: (char _ self at: i).
			char = $: ifTrue: 
					[kwds nextPut: kwd contents.
					kwd reset]].
		kwd isEmpty ifFalse: [kwds nextPut: kwd contents]].
	(keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue:
		["Has an initial keyword, as in #:if:then:else:"
		keywords _ keywords allButFirst].
	(keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue:
		["Has a final keyword, as in #nextPut::andCR"
		keywords _ keywords copyReplaceFrom: keywords size - 1
								to: keywords size with: {':' , keywords last}].
	^ keywords! !

!String methodsFor: 'converting' stamp: 'sw 5/30/2000 14:58'!
numericSuffix
	^ self stemAndNumericSuffix last

"
'abc98' numericSuffix
'98abc' numericSuffix
"! !

!String methodsFor: 'converting' stamp: 'sma 5/20/2000 17:17'!
romanNumber
	| value v1 v2 |
	value _ v1 _ v2 _ 0.
	self reverseDo:
		[:each |
		v1 _ #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each).
		v1 >= v2
			ifTrue: [value _ value + v1]
			ifFalse: [value _ value - v1].
		v2 _ v1].
	^ value! !

!String methodsFor: 'converting'!
sansPeriodSuffix
	"Return a copy of the receiver up to, but not including, the first period.  If the receiver's *first* character is a period, then just return the entire receiver. "

	| likely |
	likely _ self copyUpTo: $..
	^ likely size == 0
		ifTrue:	[self]
		ifFalse:	[likely]! !

!String methodsFor: 'converting' stamp: 'di 9/24/1999 12:31'!
splitInteger
	"Answer an array that is a splitting of self into a string and an integer.
	'43Sam' ==> #(43 'Sam').  'Try90' ==> #('Try' 90)
	BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90)  ie, (<string> <integer>)."

	| pos |
	(pos _ self findFirst: [:d | d isDigit not]) == 0 ifTrue: [^ Array with: '' with: self asNumber].
	self first isDigit ifTrue: [
		^ Array with: (self copyFrom: 1 to: pos - 1) asNumber 
				with: (self copyFrom: pos to: self size)].
	(pos _ self findFirst: [:d | d isDigit]) == 0 ifTrue: [^ Array with: self with: 0].
	^ Array with: (self copyFrom: 1 to: pos - 1)
			with: (self copyFrom: pos to: self size) asNumber! !

!String methodsFor: 'converting'!
stemAndNumericSuffix
	"Parse the receiver into a string-valued stem and a numeric-valued suffix.  6/7/96 sw"

	| stem suffix position |

	stem _ self.
	suffix _ 0.
	position _ 1.
	[stem endsWithDigit and: [stem size > 1]] whileTrue:
		[suffix _  stem last digitValue * position + suffix.
		position _ position * 10.
		stem _ stem copyFrom: 1 to: stem size - 1].
	^ Array with: stem with: suffix

"'Fred2305' stemAndNumericSuffix"! !

!String methodsFor: 'converting' stamp: 'ls 1/3/1999 13:36'!
substrings
	"Answer an array of the substrings that compose the receiver."
	| result end beginning |

	result _ WriteStream on: (Array new: 10).



	end _ 0.
	"find one substring each time through this loop"
	[ 
		"find the beginning of the next substring"
		beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ].
		beginning ~~ nil ] 
	whileTrue: [
		"find the end"
		end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ].
		end _ end - 1.

		result nextPut: (self copyFrom: beginning to: end).

	].


	^result contents! !

!String methodsFor: 'converting' stamp: 'sw 11/25/96'!
surroundedBySingleQuotes
	"Answer the receiver with leading and trailing quotes.  "

	^ $' asString, self, $' asString! !

!String methodsFor: 'converting' stamp: 'ls 8/15/1998 10:31'!
translateFrom: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	String translate: self  from: start to: stop table: table! !

!String methodsFor: 'converting' stamp: 'ls 8/18/1998 07:44'!
translateToLowercase
	"Translate all characters to lowercase, in place"

	self translateWith: LowercasingTable! !

!String methodsFor: 'converting' stamp: 'SqR 6/13/2000 20:10'!
translateToUppercase
	"Translate all characters to lowercase, in place"

	self translateWith: UppercasingTable! !

!String methodsFor: 'converting' stamp: 'ls 8/15/1998 08:30'!
translateWith: table
	"translate the characters in the string by the given table, in place"
	^self translateFrom: 1 to: self size table: table! !

!String methodsFor: 'converting'!
truncateTo: smallSize
	"return myself or a copy shortened to smallSize.  1/18/96 sw"

	^ self size <= smallSize
		ifTrue:
			[self]
		ifFalse:
			[self copyFrom: 1 to: smallSize]! !

!String methodsFor: 'converting' stamp: 'sw 9/2/1998 17:09'!
truncateWithElipsisTo: maxLength
	"Return myself or a copy suitably shortened but with elipsis added"

	^ self size <= maxLength
		ifTrue:
			[self]
		ifFalse:
			[(self copyFrom: 1 to: (maxLength - 3)), '...']


	"'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! !

!String methodsFor: 'converting' stamp: 'sw 10/26/2000 10:00'!
unparenthetically
	"If the receiver starts with (..( and ends with matching )..), strip them"

	| curr |
	curr _ self.
	[((curr first == $() and: [curr last == $)])] whileTrue:
		[curr _ curr copyFrom: 2 to: (curr size - 1)].

	^ curr

"

'((fred the bear))' unparenthetically

"
		! !

!String methodsFor: 'converting' stamp: 'mir 12/22/1999 13:58'!
unzipped
	| magic1 magic2 |
	magic1 _ (self at: 1) asInteger.
	magic2 _ (self at: 2) asInteger.
	(magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self].
	^(GZipReadStream on: self) upToEnd! !

!String methodsFor: 'converting' stamp: 'bolot 11/3/1999 17:35'!
withBlanksCondensed
	"Return a copy of the receiver with leading/trailing blanks removed
	 and consecutive white spaces condensed."

	| trimmed lastBlank |
	trimmed _ self withBlanksTrimmed.
	^String streamContents: [:stream |
		lastBlank _ false.
		trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c].
			lastBlank _ c isSeparator]].

	" ' abc  d   ' withBlanksCondensed"
! !

!String methodsFor: 'converting' stamp: 'jm 5/14/1998 10:26'!
withBlanksTrimmed
	"Return a copy of the receiver from which leading and trailing blanks have been trimmed."

	| first |
	first _ self findFirst: [:c | c isSeparator not].
	first = 0 ifTrue: [^ ''].  "no non-separator character"
	^ self
		copyFrom: first
		to: (self findLast: [:c | c isSeparator not])

	" ' abc  d   ' withBlanksTrimmed"
! !

!String methodsFor: 'converting' stamp: 'sw 10/6/2000 08:19'!
withFirstCharacterDownshifted
	"Answer an object like the receiver but with first character downshifted if necesary"

	"'MElViN' withFirstCharacterDownshifted"
	"#Will withFirstCharacterDownshifted"

	| answer |

	answer _ self asString.
	answer at: 1 put:
		(answer at: 1) asLowercase.
	^ answer as: self class! !

!String methodsFor: 'converting' stamp: 'tk 3/28/1999 22:44'!
withNoLineLongerThan: aNumber
	"Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number"
	| listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition |
	aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow'].
	listOfLines _ OrderedCollection new.
	currentLast _ 0.
	[currentLast < self size] whileTrue:
		[currentStart _ currentLast + 1.
		putativeLast _ (currentStart + aNumber - 1) min: self size.
		putativeLine _ self copyFrom: currentStart to: putativeLast.
		(crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue:
			[putativeLast _ currentStart + crPosition - 1.
			putativeLine _ self copyFrom: currentStart to: putativeLast].
		currentLast _ putativeLast == self size
			ifTrue:
				[putativeLast]
			ifFalse:
				[currentStart + putativeLine lastSpacePosition - 1].
		currentLast <= currentStart ifTrue:
			["line has NO spaces; baleout!!"
			currentLast _ putativeLast].
		listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed].

	listOfLines size > 0 ifFalse: [^ ''].
	resultString _ listOfLines first.
	2 to: listOfLines size do:
		[:i | resultString _ resultString, String cr, (listOfLines at: i)].
	^ resultString

"#(5 7 20) collect:
	[:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! !

!String methodsFor: 'converting' stamp: 'ls 8/20/1998 10:43'!
withSeparatorsCompacted
	"replace each sequences of whitespace by a single space character"
	| out pos textEnd |

	self isEmpty ifTrue: [ ^self ].

	out _ WriteStream on: (String new: self size).
	pos _ 1.   "current position in a scan through aString"


	"handle the case of initial separators"
	self first isSeparator ifTrue: [
		out nextPut: Character space.
		pos _ self indexOfAnyOf: CSNonSeparators ifAbsent: [ self size + 1 ] ].


	"central loop: handle a segment of text, followed possibly by a segment of whitespace"
	[ pos <= self size ] whileTrue: [ 
		"handle a segment of text..."

		textEnd _ self 
			indexOfAnyOf: CSSeparators
			startingAt: pos 
			ifAbsent: [ self size + 1 ].

		textEnd _ textEnd - 1.
		out nextPutAll: (self copyFrom: pos to: textEnd).
		pos _ textEnd + 1.

		pos <= self size ifTrue: [
			pos _ self 
				indexOfAnyOf: CSNonSeparators
				startingAt: pos
				ifAbsent: [ self size + 1 ].

			out nextPut: Character space  ] ].

	^out contents! !

!String methodsFor: 'converting' stamp: 'sw 1/8/1999 14:45'!
withoutLeadingDigits
	"Answer the portion of the receiver that follows any leading series of digits and blanks.  If the receiver consists entirely of digits and blanks, return an empty string"
	| firstNonDigit |
	firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~~ $ ]]).
	^ firstNonDigit > 0
		ifTrue:
			[self copyFrom: firstNonDigit  to: self size]
		ifFalse:
			['']

"
'234Whoopie' withoutLeadingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
'  89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
! !

!String methodsFor: 'converting' stamp: 'bf 11/24/1998 19:58'!
withoutTrailingBlanks
	"Return a copy of the receiver from which trailing blanks have been trimmed."

	| last |
	last _ self findLast: [:c | c isSeparator not].
	last = 0 ifTrue: [^ ''].  "no non-separator character"
	^ self copyFrom: 1 to: last

	" ' abc  d   ' withoutTrailingBlanks"
! !

!String methodsFor: 'converting'!
withoutTrailingDigits
	"Answer the portion of the receiver that precedes any trailing series of digits and blanks.  If the receiver consists entirely of digits and blanks, return an empty string"
	| firstDigit |
	firstDigit _ (self findFirst: [:m | m isDigit or: [m == $ ]]).
	^ firstDigit > 0
		ifTrue:
			[self copyFrom: 1   to: firstDigit-1]
		ifFalse:
			[self]

"
'Whoopie234' withoutTrailingDigits
' 4321 BlastOff!!' withoutLeadingDigits
'wimpy' withoutLeadingDigits
'  89Ten ' withoutLeadingDigits
'78 92' withoutLeadingDigits
"
! !


!String methodsFor: 'displaying' stamp: 'di 5/28/1998 13:25'!
displayAt: aPoint 
	"Display the receiver as a DisplayText at aPoint on the display screen."

	self displayOn: Display at: aPoint! !

!String methodsFor: 'displaying'!
displayOn: aDisplayMedium
	"Display the receiver on the given DisplayMedium.  5/16/96 sw"

	self displayOn: aDisplayMedium at: 0 @ 0! !

!String methodsFor: 'displaying' stamp: 'di 5/28/1998 13:25'!
displayOn: aDisplayMedium at: aPoint 
	"Show a representation of the receiver as a DisplayText at location
	aPoint on aDisplayMedium."

	(self asDisplayText foregroundColor: Color black backgroundColor: Color white)
		displayOn: aDisplayMedium at: aPoint! !

!String methodsFor: 'displaying' stamp: 'RAA 5/15/2000 11:00'!
displayProgressAt: aPoint from: minVal to: maxVal during: workBlock 
	"Display this string as a caption over a progress bar while workBlock is evaluated.

EXAMPLE (Select next 6 lines and Do It)
'Now here''s some Real Progress'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: 10
	during: [:bar |
	1 to: 10 do: [:x | bar value: x.
			(Delay forMilliseconds: 500) wait]].

HOW IT WORKS (Try this in any other language :-)
Since your code (the last 2 lines in the above example) is in a block,
this method gets control to display its heading before, and clean up 
the screen after, its execution.
The key, though, is that the block is supplied with an argument,
named 'bar' in the example, which will update the bar image every 
it is sent the message value: x, where x is in the from:to: range.
"
	^ProgressInitiationException 
		display: self
		at: aPoint 
		from: minVal 
		to: maxVal 
		during: workBlock! !

!String methodsFor: 'displaying' stamp: 'sw 7/3/1998 18:31'!
newTileMorphRepresentative
	^ TileMorph new setLiteral: self! !


!String methodsFor: 'printing' stamp: 'sw 4/25/1998 12:52'!
basicType
	"number string boolean player collection sound color etc"
	^ #string! !

!String methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:22'!
encodeDoublingQuoteOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
	| x |
	aStream print: $'.
	1 to: self size do:
		[:i |
		aStream print: (x _ self at: i).
		x == $' ifTrue: [aStream print: x]].
	aStream print: $'! !

!String methodsFor: 'printing'!
isLiteral

	^true! !

!String methodsFor: 'printing' stamp: 'sma 6/1/2000 09:48'!
printOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."

	self storeOn: aStream! !

!String methodsFor: 'printing'!
storeOn: aStream 
	"Print inside string quotes, doubling inbedded quotes."
	| x |
	aStream nextPut: $'.
	1 to: self size do:
		[:i |
		aStream nextPut: (x _ self at: i).
		x == $' ifTrue: [aStream nextPut: x]].
	aStream nextPut: $'! !

!String methodsFor: 'printing'!
stringRepresentation
	"Answer a string that represents the receiver.  For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes.  6/12/96 sw"

	^ self ! !


!String methodsFor: 'private' stamp: 'di 12/1/2000 14:55'!
correctAgainstEnumerator: wordBlock continuedFrom: oldCollection
	"The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it."

	| choices scoreMin results score maxChoices |
	scoreMin _ self size // 2 min: 3.
	maxChoices _ 10.
	oldCollection isNil
		ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ]
		ifFalse: [ choices _ oldCollection ].
	wordBlock isNil
		ifTrue:
			[ results _ OrderedCollection new.
			1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ]
		ifFalse:
			[ wordBlock value: [ :word |
				(score _ self alike: word) >= scoreMin ifTrue:
					[ choices add: (Association key: word value: score).
						(choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ].
			results _ choices ].
	^ results! !

!String 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! !

!String methodsFor: 'private'!
stringhash
	^self hash! !


!String methodsFor: 'system primitives' stamp: 'ar 2/3/2001 16:12'!
compare: string1 with: string2 collated: order
	"Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."

	| len1 len2 c1 c2 |
	<primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
	self var: #string1 declareC: 'unsigned char *string1'.
	self var: #string2 declareC: 'unsigned char *string2'.
	self var: #order declareC: 'unsigned char *order'.

	len1 _ string1 size.
	len2 _ string2 size.
	1 to: (len1 min: len2) do:
		[:i |
		c1 _ order at: (string1 basicAt: i) + 1.
		c2 _ order at: (string2 basicAt: i) + 1.
		c1 = c2 ifFalse: 
			[c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]].
	len1 = len2 ifTrue: [^ 2].
	len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3].
! !

!String methodsFor: 'system primitives' stamp: 'ar 2/3/2001 16:13'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned.

	The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter."
	| index |
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	self var: #key declareC: 'unsigned char *key'.
	self var: #body declareC: 'unsigned char *body'.
	self var: #matchTable declareC: 'unsigned char *matchTable'.

	key size = 0 ifTrue: [^ 0].
	start to: body size - key size + 1 do:
		[:startIndex |
		index _ 1.
			[(matchTable at: (body at: startIndex+index-1) asciiValue + 1)
				= (matchTable at: (key at: index) asciiValue + 1)]
				whileTrue:
				[index = key size ifTrue: [^ startIndex].
				index _ index+1]].
	^ 0
"
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7
' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0
' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7
"! !

!String methodsFor: 'system primitives' stamp: 'di 12/3/2000 09:34'!
numArgs 
	"Answer either the number of arguments that the receiver would take if considered a selector.  Answer -1 if it couldn't be a selector.  Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors.  It is intended mostly for the assistance of spelling correction."

	| firstChar numColons excess start ix |
	self size = 0 ifTrue: [^ -1].
	firstChar _ self at: 1.
	(firstChar isLetter or: [firstChar = $:]) ifTrue:
		["Fast reject if any chars are non-alphanumeric"
		(self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1].
		"Fast colon count"
		numColons _ 0.  start _ 1.
		[(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0]
			whileTrue:
				[numColons _ numColons + 1.
				start _ ix + 1].
		numColons = 0 ifTrue: [^ 0].
		firstChar = $:
			ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"]
			ifFalse: [excess _ 0].
		self last = $:
			ifTrue: [^ numColons - excess]
			ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]].
	firstChar isSpecial ifTrue:
		[self size = 1 ifTrue: [^ 1].
		2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]].
		^ 1].
	^ -1.! !


!String methodsFor: 'Celeste' stamp: 'dvf 7/1/2000 14:16'!
normalizedSubject
	| res |
	res _ self.
	(res asLowercase beginsWith: 're:')
		ifTrue: [res _ res copyFrom: 4 to: res size].
	^ res withBlanksCondensed! !

!String methodsFor: 'Celeste'!
withCRs
	"Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns."

	^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! !


!String methodsFor: 'internet' stamp: 'bf 11/30/1998 16:09'!
decodeMimeHeader
	"See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII Text.
	Text containing non-ASCII characters is encoded by the sequence
		=?character-set?encoding?encoded-text?=
	Encoding is Q (quoted printable) or B (Base64), handled by Base64MimeConverter / RFC2047MimeConverter. The character-set (usually iso-8859-1) is ignored"

	| input output temp decoder encoding pos | 
	input _ ReadStream on: self.
	output _ WriteStream on: String new.

	[output nextPutAll: (input upTo: $=).	"ASCII Text"
	input atEnd] whileFalse: [
		(temp _ input next) = $?
			ifFalse: [output nextPut: $=; nextPut: temp]
			ifTrue: [
				input skipTo: $?. "Skip charset"
				encoding _ (input upTo: $?) asUppercase.
				temp _ input upTo: $?.
				input next.	"Skip final ="
				decoder _ encoding = 'B'
					ifTrue: [Base64MimeConverter new]
					ifFalse: [RFC2047MimeConverter new].
				decoder
					mimeStream: (ReadStream on: temp);
					dataStream: output;
					mimeDecode.
				pos _ input position.
				input skipSeparators.	"Delete spaces if followed by ="
				input peek = $= ifFalse: [input position: pos]]].
	^output contents! !

!String methodsFor: 'internet' stamp: 'ls 1/5/1999 17:47'!
decodeQuotedPrintable
	"Assume receiver is in MIME 'quoted-printable' encoding, and decode it."
  
	| input answer c asciiText ascii |
	input _ ReadStream on: self.
	answer _ WriteStream on: (String new: self size).
	[input atEnd] whileFalse: [
		c _ input next.
		c = $=
			ifTrue: [  "quoted character"
				input peek = Character cr
					ifTrue: [  "ignore the '=' at the end of a line"
						input next]
					ifFalse: [  "character encoding"
						asciiText _ input next: 2.
						ascii _ Integer readFrom: (ReadStream on: asciiText) base: 16.
						answer nextPut: (Character value: ascii)]]
			ifFalse: [  "ordinary character"
				answer nextPut: c]].
	^ answer contents
! !

!String methodsFor: 'internet' stamp: 'sma 3/11/2000 20:40'!
isoToSqueak
	^ self collect: [:each | each isoToSqueak]! !

!String methodsFor: 'internet' stamp: 'bf 11/4/1999 23:15'!
replaceHtmlCharRefs

        | pos ampIndex scIndex special specialValue outString outPos newOutPos |

        outString _ String new: self size.
        outPos _ 0.

        pos _ 1.
        
        [ pos <= self size ] whileTrue: [ 
                "read up to the next ampersand"
                ampIndex _ self indexOf: $& startingAt: pos ifAbsent: [0].
                
                ampIndex = 0 ifTrue: [
                        pos = 1 ifTrue: [ ^self ] ifFalse: [ ampIndex _ self size+1 ] ].

                newOutPos _ outPos + ampIndex - pos.
                outString
                        replaceFrom: outPos + 1
                        to: newOutPos
                        with: self
                        startingAt: pos.
                outPos _ newOutPos.
                pos _ ampIndex.

                ampIndex <= self size ifTrue: [
                        "find the $;"
                        scIndex _ self indexOf: $; startingAt: ampIndex ifAbsent: [ self size + 1 ].

                        special _ self copyFrom: ampIndex+1 to: scIndex-1.       
                        specialValue _ HtmlEntity valueOfHtmlEntity: special. 

                        specialValue
                                ifNil: [
                                        "not a recognized entity.  wite it back"
								  scIndex > self size ifTrue: [ scIndex _ self size ].

                                        newOutPos _ outPos + scIndex - ampIndex + 1.
                                        outString
                                                replaceFrom: outPos+1
                                                to: newOutPos
                                                with: self
                                                startingAt: ampIndex.
                                        outPos _ newOutPos.]
                                ifNotNil: [
                                        outPos _ outPos + 1.
                                        outString at: outPos put: specialValue.].
                        
                        pos _ scIndex + 1. ]. ].


        ^outString copyFrom: 1 to: outPos! !

!String methodsFor: 'internet' stamp: 'bf 3/9/2000 16:46'!
squeakToIso
	^self collect: [:c | c squeakToIso ]! !

!String methodsFor: 'internet' stamp: 'sma 6/3/2000 20:26'!
unescapePercents
	"change each %XY substring to the character with ASCII value XY in hex.  This is the opposite of #encodeForHTTP"
	| ans c asciiVal pos oldPos specialChars |
	ans _ WriteStream on: String new.
	oldPos _ 1.
	specialChars _ '+%' asCharacterSet.

	[pos _ self indexOfAnyOf: specialChars startingAt: oldPos. pos > 0]
	whileTrue: [
		ans nextPutAll: (self copyFrom: oldPos to: pos - 1).
		c _ self at: pos.
		c = $+ ifTrue: [ans nextPut: $ ] ifFalse: [
			(c = $% and: [pos + 2 <= self size]) ifTrue: [
				asciiVal _ (self at: pos+1) asUppercase digitValue * 16 +
					(self at: pos+2) asUppercase digitValue.
				pos _ pos + 2.
				ans nextPut: (Character value: asciiVal)]
			ifFalse: [ans nextPut: c]].
		oldPos _ pos+1].
	ans nextPutAll: (self copyFrom: oldPos to: self size).
	^ ans contents! !

!String methodsFor: 'internet' stamp: 'ls 7/27/1998 23:17'!
withInternetLineEndings
	"change line endings from CR's to CRLF's.  This is probably in
prepration for sending a string over the Internet"
	| cr lf |
	cr _ Character cr.
	lf _ Character linefeed.
	^self class streamContents: [ :stream |
		self do: [ :c |
			stream nextPut: c.
			c = cr ifTrue:[ stream nextPut: lf ]. ] ].! !

!String methodsFor: 'internet' stamp: 'ls 10/27/1998 00:52'!
withSqueakLineEndings
	"assume the string is textual, and that CR, LF, and CRLF are all 
	valid line endings.  Replace each occurence with a single CR"
	| cr lf input c crlf inPos outPos outString lineEndPos newOutPos |
	cr _ Character cr.
	lf _ Character linefeed.
	crlf _ CharacterSet new.
	crlf add: cr; add: lf.

	inPos _ 1.
	outPos _ 1.
	outString _
 String new: self size.

	[ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0].
		lineEndPos ~= 0 ] whileTrue: [
			newOutPos _ outPos + (lineEndPos - inPos + 1).
			outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos.
			outString at: newOutPos-1 put: cr.
			outPos _ newOutPos.

			((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [
				"CRLF ending"
				inPos _ lineEndPos + 2 ]
			ifFalse: [ 
				"CR or LF ending"
				inPos _ lineEndPos + 1 ]. ].

	"no more line endings.  copy the rest"
	newOutPos _ outPos + (self size - inPos + 1).
	outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos.

	^outString copyFrom: 1 to: newOutPos-1
	! !

!String methodsFor: 'internet' stamp: 'ls 7/1/1998 02:26'!
withoutQuoting
	"remove the initial and final quote marks, if present"
	"'''h''' withoutQuoting"
	| quote |
	self size < 2 ifTrue: [ ^self ].
	quote _ self first.
	(quote = $' or: [ quote = $" ])
		ifTrue: [ ^self copyFrom: 2 to: self size - 1 ]
		ifFalse: [ ^self ].! !


!String methodsFor: 'testing' stamp: 'RAA 6/21/1999 11:28'!
hasContentsInExplorer

	^false! !

!String methodsFor: 'testing' stamp: 'djp 10/26/1999 21:25'!
isAllDigits
	"whether the receiver is composed entirely of digits"
	self do: [:c | c isDigit ifFalse: [^ false]].
	^ true! !

!String methodsFor: 'testing' stamp: 'ls 7/4/1998 19:17'!
isAllSeparators
	"whether the receiver is composed entirely of separators"
	self do: [ :c | c isSeparator ifFalse: [ ^false ] ].
	^true! !

!String methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'!
isString
	^ true! !

!String methodsFor: 'testing' stamp: 'sw 11/5/1998 17:41'!
lastSpacePosition
	"Answer the character position of the final space or other separator character in the receiver, and 0 if none"
	self size to: 1 by: -1 do:
		[:i | ((self at: i) isSeparator) ifTrue: [^ i]].
	^ 0

"
'fred the bear' lastSpacePosition
'ziggie' lastSpacePosition
'elvis ' lastSpacePosition
'wimpy  ' lastSpacePosition
'' lastSpacePosition
"! !


!String methodsFor: 'paragraph support' stamp: 'RAA 8/30/1998 15:20'!
indentationIfBlank: aBlock
	"Answer the number of leading tabs in the receiver.  If there are
	 no visible characters, pass the number of tabs to aBlock and return its value."

	| reader leadingTabs lastSeparator cr tab ch |
	cr _ Character cr.
	tab _ Character tab.
	reader _ ReadStream on: self.
	leadingTabs _ 0.
	[reader atEnd not and: [(ch _ reader next) == tab]]
		whileTrue: [leadingTabs _ leadingTabs + 1].
	lastSeparator _ leadingTabs + 1.
	[reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]]
		whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next].
	lastSeparator = self size | (ch == cr)
		ifTrue: [^aBlock value: leadingTabs].
	^leadingTabs! !


!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
* arg

	^ arg adaptToString: self andSend: #*! !

!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
+ arg

	^ arg adaptToString: self andSend: #+! !

!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
- arg

	^ arg adaptToString: self andSend: #-! !

!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
/ arg

	^ arg adaptToString: self andSend: #/! !

!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
// arg

	^ arg adaptToString: self andSend: #//! !

!String methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:03'!
\\ arg

	^ arg adaptToString: self andSend: #\\! !


!String methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 01:17'!
byteEncode:aStream
	^aStream writeString:self.! !

!String methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 23:02'!
putOn:aStream
	^aStream nextPutAll:self.
! !


!String methodsFor: 'encoding' stamp: 'RAA 7/22/2000 08:52'!
getInteger32: location
	| integer |
	<primitive: 'getInteger' module: 'IntegerPokerPlugin'>
	"^IntegerPokerPlugin doPrimitive: #getInteger"

	"the following is about 7x faster than interpreting the plugin if not compiled"

	integer := 
		((self byteAt: location) bitShift: 24) +
		((self byteAt: location+1) bitShift: 16) +
		((self byteAt: location+2) bitShift: 8) +
		(self byteAt: location+3).

	integer > 1073741824 ifTrue: [
		^1073741824 - integer ].
	^integer
! !

!String methodsFor: 'encoding' stamp: 'RAA 7/22/2000 08:42'!
primGetInteger32: location
	<primitive: 'getInteger' module: 'IntegerPokerPlugin'>
	^IntegerPokerPlugin doPrimitive: #getInteger! !

!String methodsFor: 'encoding' stamp: 'RAA 7/22/2000 08:30'!
primPutInteger32: anInteger at: location
	| |
	<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
	IntegerPokerPlugin doPrimitive: #putInteger

! !

!String methodsFor: 'encoding' stamp: 'RAA 7/31/2000 16:06'!
putInteger32: anInteger at: location
	| integer |
	<primitive: 'putInteger' module: 'IntegerPokerPlugin'>
	"IntegerPokerPlugin doPrimitive: #putInteger"

	"the following is close to 20x faster than the above if the primitive is not compiled"
	"PUTCOUNTER _ PUTCOUNTER + 1."
	integer _ anInteger.
	integer < 0 ifTrue: [integer :=  1073741824 - integer. ].
	self byteAt: location+3 put: (integer \\ 256).
	self byteAt: location+2 put: (integer bitShift: -8) \\ 256.
	self byteAt: location+1 put: (integer bitShift: -16) \\ 256.
	self byteAt: location put: (integer bitShift: -24) \\ 256.

"Smalltalk at: #PUTCOUNTER put: 0"! !


!String methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:44'!
asExplorerString
	^ self asString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

String class
	instanceVariableNames: ''!

!String class methodsFor: 'instance creation' stamp: 'jm 5/6/1998 18:39'!
cr
	"Answer a string containing a single carriage return character."

	^ self with: Character cr
! !

!String class methodsFor: 'instance creation' stamp: 'ls 9/10/1998 22:29'!
crlf
	"Answer a string containing a carriage return and a linefeed."

	^ self with: Character cr with: Character lf
! !

!String class methodsFor: 'instance creation'!
fromPacked: aLong
	"Convert from a longinteger to a String of length 4."

	| s |
	s _ self new: 4.
	s at: 1 put: (aLong digitAt: 4) asCharacter.
	s at: 2 put: (aLong digitAt: 3) asCharacter.
	s at: 3 put: (aLong digitAt: 2) asCharacter.
	s at: 4 put: (aLong digitAt: 1) asCharacter.
	^s

"String fromPacked: 'TEXT' asPacked"
! !

!String class methodsFor: 'instance creation' stamp: 'di 1/14/98 10:26'!
fromString: aString 
	"Answer an instance of me that is a copy of the argument, aString."
	
	^ aString copyFrom: 1 to: aString size! !

!String class methodsFor: 'instance creation'!
readFrom: inStream
	"Answer an instance of me that is determined by reading the stream, 
	inStream. Embedded double quotes become the quote Character."

	| outStream char done |
	outStream _ WriteStream on: (String new: 16).
	"go to first quote"
	inStream skipTo: $'.
	done _ false.
	[done or: [inStream atEnd]]
		whileFalse: 
			[char _ inStream next.
			char = $'
				ifTrue: 
					[char _ inStream next.
					char = $'
						ifTrue: [outStream nextPut: char]
						ifFalse: [done _ true]]
				ifFalse: [outStream nextPut: char]].
	^outStream contents! !

!String class methodsFor: 'instance creation' stamp: 'sw 6/15/1999 22:59'!
tab
	"Answer a string containing a single tab character."

	^ self with: Character tab
! !


!String class methodsFor: 'examples'!
example
	"To see the string displayed at the cursor point, execute this expression
	and select a point by pressing a mouse button."

	'this is some text' displayOn: Display at: Sensor waitButton! !


!String class methodsFor: 'initialization' stamp: 'di 12/3/2000 09:06'!
initialize   "String initialize"

	| order |
	AsciiOrder _ (0 to: 255) as: ByteArray.

	CaseInsensitiveOrder _ AsciiOrder copy.
	($a to: $z) do:
		[:c | CaseInsensitiveOrder at: c asciiValue + 1
				put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)].

	"Case-sensitive compare sorts space, digits, letters, all the rest..."
	CaseSensitiveOrder _ ByteArray new: 256 withAll: 255.
	order _ -1.
	' 0123456789' do:  "0..10"
		[:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	($a to: $z) do:     "11-64"
		[:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1).
		CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)].
	1 to: CaseSensitiveOrder size do:
		[:i | (CaseSensitiveOrder at: i) = 255 ifTrue:
			[CaseSensitiveOrder at: i put: (order _ order+1)]].
	order = 255 ifFalse: [self error: 'order problem'].

	"a table for translating to lower case"
	LowercasingTable _ String withAll: (Character allCharacters collect: [:c | c asLowercase]).

	"a table for translating to upper case"
	UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]).

	"a table for testing tokenish (for fast numArgs)"
	Tokenish _ String withAll: (Character allCharacters collect:
									[:c | c tokenish ifTrue: [c] ifFalse: [$~]]).

	"CR and LF--characters that terminate a line"
	CSLineEnders _ CharacterSet empty.
	CSLineEnders add: Character cr.
	CSLineEnders add: Character lf.

 	"separators and non-separators"
	CSSeparators _ CharacterSet separators.
	CSNonSeparators _ CSSeparators complement.! !

!String class methodsFor: 'initialization' stamp: 'sma 3/11/2000 20:43'!
initializeHtmlEntities
	"String initializeHtmlEntities"

	HtmlEntities _ (Dictionary new: 128)
		at: 'amp'	put: $&;
		at: 'lt'		put: $<;
		at: 'gt'		put: $>;
		at: 'quot'	put: $";
		at: 'euro'	put: Character euro;
		yourself.
	#('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter isoToSqueak]! !


!String class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'!
findFirstInString: aString  inSet: inclusionMap  startingAt: start
	| i stringSize |
	<primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
	self var: #aString declareC: 'unsigned char *aString'.
	self var: #inclusionMap  declareC: 'char *inclusionMap'.

	inclusionMap size ~= 256 ifTrue: [ ^0 ].

	i _ start.
	stringSize _ aString size.
	[ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [ 
		i _ i + 1 ].

	i > stringSize ifTrue: [ ^0 ].
	^i! !

!String class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:13'!
indexOfAscii: anInteger inString: aString startingAt: start

	| stringSize |
	<primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>

	self var: #aCharacter declareC: 'int anInteger'.
	self var: #aString declareC: 'unsigned char *aString'.

	stringSize _ aString size.
	start to: stringSize do: [:pos |
		(aString at: pos) asciiValue = anInteger ifTrue: [^ pos]].

	^ 0
! !

!String class methodsFor: 'primitives' stamp: 'ar 2/3/2001 16:12'!
translate: aString from: start  to: stop  table: table
	"translate the characters in the string by the given table, in place"
	<primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
	self var: #table  declareC: 'unsigned char *table'.
	self var: #aString  declareC: 'unsigned char *aString'.

	start to: stop do: [ :i |
		aString at: i put: (table at: (aString at: i) asciiValue+1) ]! !



!String class methodsFor: 'plugin generation' stamp: 'acg 9/19/1999 00:21'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asCharPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isBytes')! !

!String class methodsFor: 'plugin generation' stamp: 'acg 9/18/1999 17:10'!
ccgDeclareCForVar: aSymbolOrString

	^'char *', aSymbolOrString! !
StringMorph subclass: #StringButtonMorph
	instanceVariableNames: 'target actionSelector arguments actWhen oldColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!StringButtonMorph methodsFor: 'initialization' stamp: 'sma 3/24/2000 11:49'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target isMorph
		ifTrue:
			[target isWorldMorph ifTrue: [self target: aWorld].
			target isHandMorph ifTrue: [self target: aWorld primaryHand]]
		ifFalse: [(target isKindOf: Presenter) ifTrue: [self target: aWorld presenter]]! !

!StringButtonMorph methodsFor: 'initialization'!
initialize

	super initialize.
	self color: Color black.
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp.
	self contents: 'Flash'.
! !


!StringButtonMorph methodsFor: 'menu'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change label' action: #setLabel.
	aCustomMenu add: 'change action selector' action: #setActionSelector.
	aCustomMenu add: 'change arguments' action: #setArguments.
	aCustomMenu add: 'change when to act' action: #setActWhen.
	((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [
		aCustomMenu add: 'set target' action: #setTarget:].
! !

!StringButtonMorph methodsFor: 'menu'!
setActWhen
	actWhen _ (SelectionMenu selections: #(buttonDown buttonUp whilePressed))
		startUpWithCaption: 'Choose one of the following conditions'
! !

!StringButtonMorph methodsFor: 'menu'!
setActionSelector

	| newSel |
	newSel _ FillInTheBlank
		request:
'Please type the selector to be sent to
the target when this button is pressed'
		initialAnswer: actionSelector.
	newSel isEmpty ifFalse: [self actionSelector: newSel].
! !

!StringButtonMorph methodsFor: 'menu'!
setArguments

	| s newArgs newArgsArray |
	s _ WriteStream on: ''.
	arguments do: [:arg | arg printOn: s. s nextPutAll: '. '].
	newArgs _ FillInTheBlank
		request:
'Please type the arguments to be sent to the target
when this button is pressed separated by periods'
		initialAnswer: s contents.
	newArgs isEmpty ifFalse: [
		newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false.
		self arguments: newArgsArray].
! !

!StringButtonMorph methodsFor: 'menu'!
setLabel

	| newLabel |
	newLabel _ FillInTheBlank
		request:
'Please type a new label for this button'
		initialAnswer: self contents.
	newLabel isEmpty ifFalse: [self contents: newLabel].
! !

!StringButtonMorph methodsFor: 'menu'!
setTarget: evt

	| rootMorphs |
	rootMorphs _ self world rootMorphsAt: evt hand targetOffset.
	rootMorphs size > 1
		ifTrue: [target _ rootMorphs at: 2]
		ifFalse: [target _ nil. ^ self].
! !


!StringButtonMorph methodsFor: 'accessing'!
actWhen: aSymbol
	"Set the condition under which to invoke my action to one of: #buttonDown, #buttonUp, and #whilePressed."

	actWhen _ aSymbol.
! !

!StringButtonMorph methodsFor: 'accessing'!
actionSelector

	^ actionSelector
! !

!StringButtonMorph methodsFor: 'accessing'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!StringButtonMorph methodsFor: 'accessing'!
arguments

	^ arguments
! !

!StringButtonMorph methodsFor: 'accessing'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!StringButtonMorph methodsFor: 'accessing'!
target

	^ target
! !

!StringButtonMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject
! !


!StringButtonMorph methodsFor: 'events'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionSelector withArguments: arguments]].
! !

!StringButtonMorph methodsFor: 'events'!
handlesMouseDown: evt

	^ true
! !

!StringButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:14'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!StringButtonMorph methodsFor: 'events'!
mouseDown: evt

	oldColor _ color.
	actWhen == #buttonDown
		ifTrue: [self doButtonAction].
! !

!StringButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:15'!
mouseMove: evt
	actWhen == #buttonDown ifTrue: [^ self].
	(self containsPoint: evt cursorPoint)
		ifTrue:[self color: (oldColor alphaMixed: 1/2 with: Color white)]
		ifFalse: [self color: oldColor].
! !

!StringButtonMorph methodsFor: 'events' stamp: 'ar 10/25/2000 18:15'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse: [^ self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!StringButtonMorph methodsFor: 'events'!
mouseUp: evt

	self color: oldColor.
	(actWhen == #buttonUp and: [self containsPoint: evt cursorPoint])
		ifTrue: [self doButtonAction].
! !


!StringButtonMorph methodsFor: 'copying' stamp: 'jm 7/28/97 11:55'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then point at the new copy.  And also copies the array, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!StringButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:47'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!StringButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:46'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		a Symbol"
"arguments _ arguments.		All weakly copied"
actWhen _ actWhen veryDeepCopyWith: deepCopier.
oldColor _ oldColor veryDeepCopyWith: deepCopier.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringButtonMorph class
	instanceVariableNames: ''!

!StringButtonMorph class methodsFor: 'as yet unclassified' stamp: 'sw 2/16/98 03:02'!
defaultNameStemForInstances
	^ 'SButton'! !
Model subclass: #StringHolder
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!
!StringHolder commentStamp: '<historical>' prior: 0!
I am a kind of Model that includes a piece of text.  In some cases, the text can be edited, and in some the text is a method.

Categories 'code pane menu' and 'message list menu' are messages that may be called by my menus when the text is a method, and when some pane is a list of methods.  Other of my subclasses may ignore these two catagories altogether.!


!StringHolder methodsFor: 'initialize-release'!
defaultContents

	^''! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:36'!
embeddedInMorphicWindowLabeled: labelString
	| window |
	window _ (SystemWindow labelled: labelString) model: self.
	window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0 corner: 1@1).
	^ window! !

!StringHolder methodsFor: 'initialize-release' stamp: 'jm 3/24/98 17:56'!
initialize
	"Initialize the state of the receiver with its default contents."

	contents _ self defaultContents.
! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:37'!
openAsMorphLabel: labelString 
	"Workspace new openAsMorphLabel: 'Workspace'"
	(self embeddedInMorphicWindowLabeled: labelString) openInWorld! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 8/4/1998 18:21'!
openAsMorphLabel: labelString  inWorld: aWorld
	"Workspace new openAsMorphLabel: 'Workspace'"
	| window |
	window _ (SystemWindow labelled: labelString) model: self.

	window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0 corner: 1@1).

	window openInWorld: aWorld! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sw 12/22/1998 00:16'!
openLabel: aString 
	"Create a standard system view of the model, me, a StringHolder and open it.  If in mvc, terminate the active controller so that the new window will immediately be activated."
	self openLabel: aString andTerminate: true! !

!StringHolder methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 10:15'!
openLabel: aString andTerminate: terminateBoolean
	"Create a standard system view of the model, me, a StringHolder and open it.; do not terminate the active process if in mvc"
	| topView codeView |

	Smalltalk isMorphic ifTrue: [^ self openAsMorphLabel: aString].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
	topView label: aString.
	topView minimumSize: 100 @ 50.

	codeView _ PluggableTextView on: self 
			text: #contents accept: #acceptContents:
			readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
	codeView window: (0@0 extent: 200@200).
	topView addSubView: codeView.
	"self contents size > 0 ifTrue: [
			codeView hasUnacceptedEdits: true].  Is it already saved or not??"
	terminateBoolean
		ifTrue:
			[topView controller open]
		ifFalse:
			[topView controller openNoTerminate]! !


!StringHolder methodsFor: 'accessing' stamp: 'di 5/19/1998 15:34'!
acceptContents: aString 
	"Set aString to be the contents of the receiver.  Return true cuz happy"

	self contents: aString.
	^ true! !

!StringHolder methodsFor: 'accessing'!
contents
	"Answer the contents that the receiver is holding--presumably a string."

	^contents! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 1/12/1999 11:47'!
contents: textOrString 
	"Set textOrString to be the contents of the receiver."

	contents _ textOrString "asString"! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 9/27/1999 14:16'!
contentsChanged
	self changed: #contents! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/3/98 22:50'!
contentsSelection
	"Return the interval of text in the code pane to select when I set the pane's contents"

	^ 1 to: 0  "null selection"! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/9/2000 23:59'!
noteAcceptanceOfCodeFor: aSelector
	"A method has possibly been submitted for the receiver with aSelector as its selector; If the receiver wishes to take soem action here is a chance for it to do so"
! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/1/2000 11:04'!
reformulateList
	"If the receiver has a way of reformulating its message list, here is a chance for it to do so"! !

!StringHolder methodsFor: 'accessing' stamp: 'sw 12/6/2000 17:48'!
reformulateListNoting: newSelector
	"A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so"

	^ self reformulateList! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 14:59'!
selectedClassName
	"I may know what class is currently selected"

	self selectedClass ifNotNil: [^ self selectedClass name].
	^ nil! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:01'!
selectedClassOrMetaClass

	^ self selectedClass	"I don't know any better"! !

!StringHolder methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:22'!
selectedMessageName

	^ nil! !

!StringHolder methodsFor: 'accessing' stamp: 'di 11/23/1998 15:21'!
textContents: aStringOrText 
	"Set aStringOrText to be the contents of the receiver."

	contents _ aStringOrText! !


!StringHolder methodsFor: 'evaluation'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	^nil! !

!StringHolder methodsFor: 'evaluation'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a 
	text selection."

	^nil! !


!StringHolder methodsFor: 'user edits' stamp: 'di 4/21/1998 11:30'!
clearUserEditFlag
	"Clear the hasUnacceptedEdits flag in all my dependent views."

	self changed: #clearUserEdits! !

!StringHolder methodsFor: 'user edits' stamp: 'tk 4/13/1998 23:07'!
okToChange

	self canDiscardEdits ifTrue: [^ true].
	self changed: #wantToChange.  "Solicit cancel from view"
	^ self canDiscardEdits
! !


!StringHolder methodsFor: 'code pane menu' stamp: 'sw 11/8/1999 17:56'!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items in a text pane"
	| donorMenu |
	donorMenu _ shifted
		ifTrue:
			[ParagraphEditor shiftedYellowButtonMenu]
		ifFalse:
			[ParagraphEditor yellowButtonMenu].
	^ aMenu labels: donorMenu labelString lines: donorMenu lineArray selections: donorMenu selections! !

!StringHolder methodsFor: 'code pane menu' stamp: 'wod 5/29/1998 16:35'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!StringHolder methodsFor: 'code pane menu' stamp: 'tk 4/6/98 11:43'!
showBytecodes
	"We don't know how to do this"

	^ self changed: #flash! !

!StringHolder methodsFor: 'code pane menu' stamp: 'di 9/7/1999 11:27'!
spawn: contentsString

	(Workspace new contents: contentsString) openLabel: 'Workspace'
! !


!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/21/1998 08:38'!
browseAllMessages
	"Create and schedule a message set browser on all implementors of all the messages sent by the current method."

	| aClass aName method filteredList |
	(aName _ self selectedMessageName) ifNotNil: [
		method _ (aClass _ self selectedClassOrMetaClass) compiledMethodAt: aName.
		filteredList _ method messages reject: 
			[:each | #(new initialize = ) includes: each].
		Smalltalk browseAllImplementorsOfList: filteredList asSortedCollection
			 title: 'All messages sent in ', aClass name, '.', aName]
! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 16:11'!
browseClass
	"Open an class browser on this class and method"

	self selectedClassOrMetaClass ifNotNil: [
		Browser newOnClass: self selectedClassOrMetaClass 
			selector: self selectedMessageName]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 16:32'!
browseClassRefs

	| cls |
	(cls _ self selectedClass) ifNotNil: [
		Smalltalk browseAllCallsOn: (Smalltalk associationAt: cls theNonMetaClass name)]
! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 15:02'!
browseClassVarRefs
	"1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"

	| cls |
	(cls _ self selectedClass) ifNotNil: [cls browseClassVarRefs]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 15:02'!
browseClassVariables
	"Browse the class varialbes of the selected class.  2/5/96 sw"

	| cls |
	(cls _ self selectedClass) ifNotNil: [cls browseClassVariables]! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/11/2001 13:28'!
browseFullProtocol
	"Open up a protocol-category browser on the value of the receiver's current selection.    If in mvc, an old-style protocol browser is opened instead.  Someone who still uses mvc might wish to make the protocol-category-browser work there too, thanks.  The temporary circumlocution regarding the presence/absence of ProtocolCategoryBrowser is of course quite temporary."

	| aClass |
	(Smalltalk isMorphic and: [Smalltalk includesKey: #ProtocolCategoryBrowser]) ifFalse: [^ self spawnFullProtocol].
	(aClass _ self selectedClassOrMetaClass) ifNotNil:
		[(Smalltalk at: #ProtocolCategoryBrowser) new openOnClass: aClass targetObject: nil inWorld: self currentWorld showingSelector: self selectedMessageName]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 15:02'!
browseInstVarDefs 

	| cls |
	(cls _ self selectedClassOrMetaClass) ifNotNil: [cls browseInstVarDefs]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 15:02'!
browseInstVarRefs 
	"1/26/96 sw: real work moved to class, so it can be shared"

	| cls |
	(cls _ self selectedClassOrMetaClass) ifNotNil: [cls browseInstVarRefs]! !

!StringHolder methodsFor: 'message list menu' stamp: 'wod 5/15/1998 00:54'!
browseMessages
	"Present a menu of all messages sent by the currently selected message. 
	Open a message set browser of all implementors of the message chosen.
	Do nothing if no message is chosen."

	self selectMessageAndEvaluate: [:selector | Smalltalk browseAllImplementorsOf: selector]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/28/1998 09:28'!
browseMethodFull
	"Create and schedule a full Browser and then select the current class and message."

	| myClass |
	(myClass _ self selectedClassOrMetaClass) ifNotNil:
		[Browser fullOnClass: myClass selector: self selectedMessageName]! !

!StringHolder methodsFor: 'message list menu' stamp: 'wod 5/15/1998 00:54'!
browseSendersOfMessages
	"Present a menu of the currently selected message, as well as all
	messages sent by it.  Open a message set browser of all implementors
	of the message chosen."

	self selectMessageAndEvaluate: [:selector | Smalltalk browseAllCallsOn: selector]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 15:03'!
browseUnusedMethods
	| classes unsent messageList cls |

	(cls _ self selectedClass) ifNil: [^ self].
	classes _ Array with: cls with: cls class.
	unsent _ Set new.
	classes do: [:c | unsent addAll: c selectors].
	unsent _ Smalltalk allUnSentMessagesIn: unsent.
	messageList _ OrderedCollection new.
	classes do: [:c | (c selectors select: [:s | unsent includes: s]) asSortedCollection
					do: [:sel | messageList add: c name , ' ' , sel]].
	Smalltalk browseMessageList: messageList name: 'Unsent Methods in ', cls name! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 10/12/1999 17:42'!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	| class selector |
	(selector _ self selectedMessageName) ifNotNil:
		[class _ self selectedClassOrMetaClass.
		VersionsBrowser
			browseVersionsOf: (class compiledMethodAt: selector)
			class: self selectedClass
			meta: class isMeta
			category: self selectedMessageCategoryName
			selector: selector]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/28/1998 19:14'!
buildMessageBrowser
	"Create and schedule a message browser."

	self selectedMessageName ifNil: [^ self].
	Browser openMessageBrowserForClass: self selectedClassOrMetaClass 
		selector: self selectedMessageName editString: nil! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/18/1998 16:06'!
classHierarchy
	"Create and schedule a class list browser on the receiver's hierarchy."

	Utilities spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil"
		selector: self selectedMessageName
! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 5/8/2000 02:16'!
classListKey: aChar from: view 
	"Respond to a Command key.  I am a model with a list of classes and a 
	code pane, and I also have a listView that has a list of methods.  The 
	view knows how to get the list and selection."

	aChar == $f ifTrue: [^ self findMethod].
	aChar == $r ifTrue: [^ self recent].
	aChar == $h ifTrue: [^ self spawnHierarchy].
	aChar == $x ifTrue: [^ self removeClass].
	^ self messageListKey: aChar from: view! !

!StringHolder methodsFor: 'message list menu' stamp: 'ar 1/15/2001 18:39'!
copyName
	"Copy the current selector to the clipboard"
	| selector |
	(selector _ self selectedMessageName) ifNotNil:
		[Clipboard clipboardText: selector asString asText]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 2/9/1999 20:56'!
fetchDocPane
	"Look on servers to see if there is documentation pane for the selected message. Take into account the current update number.  If not, ask the user if she wants to create one."

	DocLibrary external fetchDocSel: self selectedMessageName 
		class: self selectedClassName! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/28/1998 18:15'!
fileOutMessage
	"Put a description of the selected message on a file"

	self selectedMessageName ifNotNil: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]! !

!StringHolder methodsFor: 'message list menu' stamp: 'di 5/6/1998 17:03'!
findMethodInChangeSets
	"Find and open a changeSet containing the current method."

	| aName |
	(aName _ self selectedMessageName) ifNotNil: [
		ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass
					selector: aName]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/21/1998 09:23'!
inspectInstances
	"Inspect all instances of the selected class."

	| myClass |
	(myClass _ self selectedClassOrMetaClass) ifNotNil:
		[myClass theNonMetaClass inspectAllInstances]. 
! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/21/1998 09:00'!
inspectSubInstances
	"Inspect all instances of the selected class and all its subclasses"

	| aClass |
	(aClass _ self selectedClassOrMetaClass) ifNotNil: [
		aClass theNonMetaClass inspectSubInstances].
! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 10/21/1999 13:33'!
makeIsolatedCodePane
	| msgName |

	(msgName _ self selectedMessageName) ifNil: [^ self beep].
	MethodHolder makeIsolatedCodePaneForClass: self selectedClassOrMetaClass selector: msgName! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/25/2001 07:28'!
messageListKey: aChar from: view
	"Respond to a Command key.  I am a model with a code pane, and I also
	have a listView that has a list of methods.  The view knows how to get
	the list and selection."

	| sel class |
	aChar == $D ifTrue: [^ self toggleDiffing].
	(class _ self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
	sel _ self selectedMessageName.
	aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel].
	aChar == $N ifTrue: [^ self browseClassRefs].
	aChar == $i ifTrue: [^ self methodHierarchy].
	aChar == $h ifTrue: [^ self classHierarchy].
	aChar == $p ifTrue: [^ self browseFullProtocol].


	sel ifNotNil: 
		[aChar == $m ifTrue: [^ Smalltalk browseAllImplementorsOf: sel].
		aChar == $n ifTrue: [^ Smalltalk browseAllCallsOn: sel].
		aChar == $v ifTrue: [^ self browseVersions].
		aChar == $O ifTrue: [^ self openSingleMessageBrowser].
		aChar == $x ifTrue: [^ self removeMessage]].

	^ self arrowKey: aChar from: view! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 12/28/2000 11:49'!
messageListSelectorTitle
	| selector aString aStamp aSize |

	(selector _ self selectedMessageName)
		ifNil:
			[aSize _ self messageList size.
			^ (aSize == 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize == 1 ifTrue: [''] ifFalse: ['s'])]
		ifNotNil:
			[Preferences timeStampsInMenuTitles
				ifFalse:	[^ nil].
			aString _ selector truncateWithElipsisTo: 28.
			^ (aStamp _ self timeStamp) size > 0
				ifTrue:
					[aString, String cr, aStamp]
				ifFalse:
					[aString]]! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/21/1998 07:57'!
methodHierarchy
	"Create and schedule a method browser on the hierarchy of implementors."

	Utilities methodHierarchyBrowserForClass: self selectedClassOrMetaClass 
			selector: self selectedMessageName
! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 9/21/1999 11:35'!
openSingleMessageBrowser
	| msgName title |
	"Create and schedule a message list browser populated only by the currently selected message"

	(msgName _ self selectedMessageName) ifNil: [^ self].
	Smalltalk browseMessageList: (Array with: (title _ self selectedClassOrMetaClass name, ' ', msgName))
		name: title autoSelect: nil! !

!StringHolder methodsFor: 'message list menu' stamp: 'RAA 12/10/1999 09:36'!
packageListKey: aChar from: view
	"Respond to a Command key in the package pane in the PackageBrowser"
	aChar == $f ifTrue: [^ self findClass].
	^ self classListKey: aChar from: view
! !

!StringHolder methodsFor: 'message list menu' stamp: 'tk 4/28/1998 18:16'!
printOutMessage
	"Write a file with the text of the selected message, for printing by a web browser"

	self selectedMessageName ifNotNil: [
		self selectedClassOrMetaClass fileOutMethod: self selectedMessageName
							asHtml: true]! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/25/2001 17:04'!
removeFromCurrentChanges
	"Tell the changes mgr to forget that the current msg was changed."

	Smalltalk changes removeSelectorChanges: self selectedMessageName 
			class: self selectedClassOrMetaClass.
	self changed: #annotation! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/28/1999 12:34'!
revertAndForget
	"Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed.  Danger!!  Use only if you really know what you're doing!!"

	self okToChange ifFalse: [^ self].
	self revertToPreviousVersion.
	self removeFromCurrentChanges.
	self contentsChanged
! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 10/10/1999 22:05'!
revertToPreviousVersion
	"Revert to the previous version of the current method"
	| aClass aSelector  changeRecords |
	self okToChange ifFalse: [^ self].
	aClass _ self selectedClassOrMetaClass.
	aClass ifNil: [^ self changed: #flash].
	aSelector _ self selectedMessageName.
	changeRecords _ aClass changeRecordsAt: aSelector.
	(changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash.  ^ self beep].
	changeRecords second fileIn.
	self contentsChanged
! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/28/2001 02:48'!
selectMessageAndEvaluate: aBlock
	"Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector.  If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"

	| selector method messages |
	(selector _ self selectedMessageName) ifNil: [^ self].
	method _ (self selectedClassOrMetaClass ifNil: [^ self])
		compiledMethodAt: selector
		ifAbsent: [].
	(method isNil or: [(messages _ method messages) size == 0])
		 ifTrue: [^ aBlock value: selector].
	(messages size == 1 and: [messages includes: selector])
		ifTrue:
			[^ aBlock value: selector].  "If only one item, there is no choice"

	Smalltalk 
		showMenuOf: messages
		withFirstItem: selector
		ifChosenDo: [:sel | aBlock value: sel]! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 1/26/1999 09:18'!
systemCatListKey: aChar from: view
	"Respond to a Command key.  I am a model with a code pane, and I also have a listView that has a list of methods.  The view knows how to get the list and selection."
	aChar == $f ifTrue: [^ self findClass].
	^ self classListKey: aChar from: view! !

!StringHolder methodsFor: 'message list menu' stamp: 'sw 12/6/2000 21:01'!
timeStamp
	"Answer the time stamp for the chosen class and method, if any, else an empty string"

	|  selector  aMethod |
	(selector _ self selectedMessageName) ifNotNil:
		[self selectedClassOrMetaClass 
			ifNil:
				[^ String new]
			ifNotNil:
				[aMethod _ self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil].
				aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]].
	^ String new! !


!StringHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/18/2001 13:38'!
showDiffs
	"Answer whether the receiver is showing differences.  When it is, pluggableTextMorphs will show a green border"

	^ false
! !

!StringHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/24/2001 21:25'!
wantsAnnotationPane
	"Answer whether the receiver, seen in some browser window, would like to have the so-called  annotationpane included.  By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."

	^ Preferences annotationPanes! !

!StringHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/24/2001 18:57'!
wantsOptionalButtons
	"Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included.  By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."

	^ Preferences optionalButtons! !


!StringHolder methodsFor: 'tiles' stamp: 'di 11/4/2000 11:07'!
openSyntaxView
	"Open a syntax view on the current method"

	| class selector |

	(selector _ self selectedMessageName) ifNotNil: [
		class _ self selectedClassOrMetaClass.
		SyntaxMorph testClass: class andMethod: selector.
	]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringHolder class
	instanceVariableNames: ''!

!StringHolder class methodsFor: 'class initialization'!
initialize
	"The class variables were initialized once, and subsequently filled with
	information. Re-executing this method is therefore dangerous." 
	 
	"workSpace _ StringHolder new"

	"StringHolder initialize"! !


!StringHolder class methodsFor: 'instance creation'!
new

	^super new initialize! !

!StringHolder class methodsFor: 'instance creation' stamp: 'tk 5/4/1998 17:32'!
open
	(Smalltalk at: #Workspace) new openLabel: 'Workspace'
		"Not to be confused with our own class var 'Workspace'"! !

!StringHolder class methodsFor: 'instance creation' stamp: 'tk 5/4/1998 16:41'!
openLabel: aString

	self new openLabel: aString! !
ParagraphEditor subclass: #StringHolderController
	instanceVariableNames: ''
	classVariableNames: 'CodeYellowButtonMenu CodeYellowButtonMessages '
	poolDictionaries: ''
	category: 'ST80-Support'!
!StringHolderController commentStamp: '<historical>' prior: 0!
I represent a ParagraphEditor for a single paragraph of text, omitting alignment commands. I provide items in the yellow button menu so that the text selection can be evaluated and so that the contents of the model can be stored or restored.
	doIt	evaluate the text selection as an expression
	printIt	same as doIt but insert a description of the result after the selection
	accept	store the contents of the StringHolder into the model
	cancel	store the contents of the model into the StringHolder!


!StringHolderController methodsFor: 'accessing'!
model: aModel

	super model: aModel.
	view displayContents == nil
		ifFalse: [self changeParagraph: view displayContents]! !


!StringHolderController methodsFor: 'edit flag' stamp: 'di 10/9/1998 15:41'!
hasUnacceptedEdits: aBoolean
	^ view hasUnacceptedEdits: aBoolean! !

!StringHolderController methodsFor: 'edit flag' stamp: 'tk 4/13/1998 23:09'!
userHasEdited
	"Note that the user has edited my text."

	view hasUnacceptedEdits: true
! !

!StringHolderController methodsFor: 'edit flag' stamp: 'tk 4/13/1998 23:08'!
userHasNotEdited
	"Note that my text is free of user edits."

	model clearUserEditFlag
! !


!StringHolderController methodsFor: 'menu messages' stamp: 'jm 3/18/98 20:53'!
accept 
	"Refer to the comment in ParagraphEditor|accept."

	super accept.
	model contents: paragraph string.
	self userHasNotEdited.
! !

!StringHolderController methodsFor: 'menu messages' stamp: 'jm 3/18/98 20:54'!
cancel 
	"Refer to the comment in ParagraphEditor|cancel."

	super cancel.
	self userHasNotEdited.
! !

!StringHolderController methodsFor: 'menu messages' stamp: 'sw 9/27/96'!
objectsReferencingIt
	"Open a list inspector on all objects that reference the object that results when the current selection is evaluated.  "

	| result |
	self controlTerminate.
	result _ self evaluateSelection.
	((result isKindOf: FakeClassPool) or:
	 [result == #failedDoit]) ifFalse: [
		Smalltalk
			browseAllObjectReferencesTo: result
			except: #()
			ifNone: [:obj | view topView flash. self controlInitialize]].
! !

!StringHolderController methodsFor: 'menu messages' stamp: 'tk 4/13/1998 23:14'!
performMenuMessage: aSelector
	"Intercept #again so the model does not get locked by keying the search text."

	| hadEdits |
	hadEdits _ view canDiscardEdits not.
	super performMenuMessage: aSelector.
	(hadEdits not and:
	 [aSelector == #again and:
	 [(UndoMessage sends: #undoAgain:andReselect:typedKey:) and:
	 [UndoMessage arguments at: 3]]])
		ifTrue: [self userHasNotEdited].
! !


!StringHolderController methodsFor: 'compiler access'!
bindingOf: aString
	^model bindingOf: aString! !



!StringHolderController methodsFor: 'private' stamp: 'jm 3/18/98 20:43'!
closeTypeIn
	"Note edit if something actually was typed."

	beginTypeInBlock ~~ nil ifTrue: [self userHasEdited].
	super closeTypeIn.
! !

!StringHolderController methodsFor: 'private' stamp: 'jm 3/18/98 20:45'!
zapSelectionWith: aText
	"Note edit except during typeIn, which notes edits at close."

	super zapSelectionWith: aText.
	beginTypeInBlock == nil ifTrue: [self userHasEdited].
! !
View subclass: #StringHolderView
	instanceVariableNames: 'displayContents hasUnacceptedEdits askBeforeDiscardingEdits '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Support'!
!StringHolderView commentStamp: '<historical>' prior: 0!
I am a View of a String that is an aspect of a more structured object. This String should not be changed by any editing unless the user issues the accept command. Thus my instances provide a working copy of the String. This copy is edited. When the user issues the accept command, the String is copied from the working version; or if the user issues the cancel command, the working version is restored from the String. StringHolderController is my default controller. It is initialized specially by passing the string viewed which is then converted to a Paragraph for editing.!


!StringHolderView methodsFor: 'initialize-release' stamp: 'jm 3/24/98 14:39'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	displayContents _ '' asParagraph.
	hasUnacceptedEdits _ false.
	askBeforeDiscardingEdits _ true.
! !


!StringHolderView methodsFor: 'updating' stamp: 'jm 3/24/98 14:38'!
askBeforeDiscardingEdits: aBoolean
	"Set the flag that determines whether the user should be asked before discarding unaccepted edits."

	askBeforeDiscardingEdits _ aBoolean.
! !

!StringHolderView methodsFor: 'updating' stamp: 'tk 4/13/1998 22:58'!
canDiscardEdits
	"Return true if this view either has no text changes or does not care."

	^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not
! !

!StringHolderView methodsFor: 'updating' stamp: 'jm 3/24/98 17:49'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ hasUnacceptedEdits
! !

!StringHolderView methodsFor: 'updating' stamp: 'tk 4/13/1998 17:17'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag to the given value."

	hasUnacceptedEdits _ aBoolean.
! !

!StringHolderView methodsFor: 'updating' stamp: 'ar 5/25/2000 19:52'!
promptForCancel
	"Ask if it is OK to cancel changes to text"
	| okToCancel stripes |
	self topView isCollapsed ifTrue:
		[(self confirm: 'Changes have not been saved.
Is it OK to cancel those changes?') ifTrue: [model clearUserEditFlag].
		^ self].
	stripes _ (Form extent: 16@16 fromStipple: 16r36C9) bits.
	Display border: self insetDisplayBox width: 4
			rule: Form reverse fillColor: stripes.
	okToCancel _ self confirm: 'Changes have not been saved.
Is it OK to cancel those changes?'.
	Display border: self insetDisplayBox width: 4
			rule: Form reverse fillColor: stripes.
	okToCancel ifTrue:
		[self updateDisplayContents.
		model clearUserEditFlag].
! !

!StringHolderView methodsFor: 'updating' stamp: 'di 4/21/1998 11:30'!
update: aSymbol
	"Refer to the comment in View|update:."
	aSymbol == #wantToChange ifTrue: [^ self promptForCancel].
	aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false].
	aSymbol == #flash ifTrue: [^ controller flash].
	self updateDisplayContents! !

!StringHolderView methodsFor: 'updating'!
updateDisplayContents
	"Make the text that is displayed be the contents of the receiver's model."

	self editString: model contents.
	self displayView! !


!StringHolderView methodsFor: 'controller access'!
defaultController 
	"Refer to the comment in View|defaultController."

	^self defaultControllerClass newParagraph: displayContents! !

!StringHolderView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^StringHolderController! !

!StringHolderView methodsFor: 'controller access'!
displayContents

	^displayContents! !


!StringHolderView methodsFor: 'displaying'!
display 
	"Refer to the comment in View.display."
	(self isUnlocked and: [self insetDisplayBox ~= displayContents clippingRectangle])
		ifTrue:  "Recompose the text if the window changed"
				[self positionDisplayContents. 
				(self controller isKindOf: ParagraphEditor)
					ifTrue: [controller recomputeSelection]].
	super display! !

!StringHolderView methodsFor: 'displaying'!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	(self controller isKindOf: ParagraphEditor)
		ifTrue: [controller display]
		ifFalse: [displayContents display]! !

!StringHolderView methodsFor: 'displaying'!
lock
	"Refer to the comment in view|lock.  Must do at least what display would do to lock the view."
	(self isUnlocked and: [self insetDisplayBox ~= displayContents clippingRectangle])
		ifTrue:  "Recompose the text if the window changed"
				[self positionDisplayContents. 
				(self controller isKindOf: ParagraphEditor)
					ifTrue: [controller recomputeSelection]].
	super lock! !

!StringHolderView methodsFor: 'displaying'!
positionDisplayContents
	"Presumably the text being displayed changed so that the wrapping box 
	and clipping box should be reset."

	displayContents 
		wrappingBox: (self insetDisplayBox insetBy: 6 @ 0)
		clippingBox: self insetDisplayBox! !


!StringHolderView methodsFor: 'model access'!
editString: aString 
	"The paragraph to be displayed is created from the characters in aString."

	displayContents _ Paragraph withText: aString asText
		style: TextStyle default copy
		compositionRectangle: (self insetDisplayBox insetBy: 6 @ 0)
		clippingRectangle: self insetDisplayBox
		foreColor: self foregroundColor backColor: self backgroundColor.
	(self controller isKindOf: ParagraphEditor)
		ifTrue: [controller changeParagraph: displayContents]! !

!StringHolderView methodsFor: 'model access' stamp: 'sma 5/28/2000 23:25'!
getMenu: shiftKeyState
	^ nil! !

!StringHolderView methodsFor: 'model access'!
model: aLockedModel 
	"Refer to the comment in View|model:."
 
	super model: aLockedModel.
	self editString: model contents! !


!StringHolderView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	(self controller isKindOf: ParagraphEditor)
	 	ifTrue: [controller deselect]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringHolderView class
	instanceVariableNames: ''!

!StringHolderView class methodsFor: 'instance creation'!
container
	"Answer an instance of me with a new instance of StringHolder as the 
	model."

	^self container: StringHolder new! !

!StringHolderView class methodsFor: 'instance creation'!
container: aContainer 
	"Answer an instance of me whose model is aContainer. Give it a 2-dot 
	border."

	| aCodeView |
	aCodeView _ self new model: aContainer.
	aCodeView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	^aCodeView! !

!StringHolderView class methodsFor: 'instance creation'!
open
	"Create a standard system view of a workspace on the screen."

	self open: Workspace new label: 'Workspace'! !

!StringHolderView class methodsFor: 'instance creation'!
open: aStringHolder 
	"Create a standard system view of the argument, aStringHolder, as viewed 
	by an instance of me. The view has label 'StringHolder'."

	self open: aStringHolder label: 'StringHolder'! !

!StringHolderView class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'!
open: aStringHolder label: labelString 
	"NOTE this should be in the model class, and all senders so redirected,
	in order that the view class can be discarded in a morphic world."

	"Create a standard system view of the model, aStringHolder, as viewed by 
	an instance of me. The label of the view is aString."
	| aStringHolderView topView |

	Smalltalk isMorphic ifTrue: [^ aStringHolder openAsMorphLabel: labelString].

	aStringHolderView _ self container: aStringHolder.
	topView _ StandardSystemView new.
	topView model: aStringHolderView model.
	topView addSubView: aStringHolderView.
	topView label: labelString.
	topView minimumSize: 100 @ 50.
	topView controller open! !
Morph subclass: #StringMorph
	instanceVariableNames: 'font emphasis contents hasFocus '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!

!StringMorph methodsFor: 'initialization' stamp: 'sw 6/15/1998 15:34'!
addOptionalHandlesTo: aHalo box: box
	self flag: #deferred.

	"Eventually...
	self addFontHandlesTo: aHalo box: box"! !

!StringMorph methodsFor: 'initialization' stamp: 'di 4/1/1999 17:14'!
initWithContents: aString font: aFont emphasis: emphasisCode
	super initialize.
	color _ Color black.
	font _ aFont.
	emphasis _ emphasisCode.
	hasFocus _ false.
	self contents: aString.! !

!StringMorph methodsFor: 'initialization' stamp: 'di 4/1/1999 17:12'!
initialize

	super initialize.
	color _ Color black.
	font _ nil.
	emphasis _ 0.
	hasFocus _ false.
	self contents: 'StringMorph'.! !


!StringMorph methodsFor: 'accessing'!
contents

	^ contents! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/17/1999 16:29'!
contents: newContents

	newContents isText
		ifTrue: [emphasis _ newContents emphasisAt: 1.
				contents _ newContents string]
		ifFalse: [contents = newContents ifTrue: [^ self].  "no substantive change"
				contents _ newContents].
	self fitContents.
	self changed

! !

!StringMorph methodsFor: 'accessing'!
contentsClipped: aString
	"Change my text, but do not change my size as a result"
	contents = aString ifTrue: [^ self].  "No substantive change"
	contents _ aString.
	self changed! !

!StringMorph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'!
fitContents

	| scanner |
	scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse.
	self extent: (((scanner stringWidth: contents) max: self minimumWidth)  @ scanner lineHeight).
	self changed! !

!StringMorph methodsFor: 'accessing' stamp: 'ar 1/31/2001 19:33'!
font
	"who came up with #fontToUse rather than font?!!"
	^self fontToUse! !

!StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:12'!
font: aFont

	^ self font: aFont emphasis: 0! !

!StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:11'!
font: aFont emphasis: emphasisCode
	font _ aFont.
	emphasis _ emphasisCode.
	self fitContents.
"
in inspector say,
	 self font: (TextStyle default fontAt: 2) emphasis: 1
"! !

!StringMorph methodsFor: 'accessing' stamp: 'tk 8/28/2000 13:59'!
fontName: fontName size: fontSize

	^ self font: (StrikeFont familyName: fontName size: fontSize) 
			emphasis: 0! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:15'!
fontToUse

	| fontToUse |
	fontToUse _ font == nil
		ifTrue: [TextStyle defaultFont]
		ifFalse: [font].
	(emphasis == nil or: [emphasis = 0])
		ifTrue: [^ fontToUse]
		ifFalse: [^ fontToUse emphasized: emphasis]! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/9/1999 18:09'!
handsWithMeForKeyboardFocus
	| foc |
	"Answer the hands that have me as their keyboard focus"

	hasFocus ifFalse: [^ #()].
	^ self currentWorld hands select:
		[:aHand | (foc _ aHand keyboardFocus) notNil and: [foc owner == self]]! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:26'!
hasFocus
	^ hasFocus! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:10'!
interimContents: aString
	"The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned"

	self contents: aString! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 13:44'!
minimumWidth
	"Answer the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	^ 3! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:16'!
setWidth: width

	self extent: width @ (font ifNil: [TextStyle defaultFont]) height! !

!StringMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:55'!
userString
	"Do I have a text string to be searched on?"

	^ contents! !

!StringMorph methodsFor: 'accessing' stamp: 'sw 9/16/1999 22:57'!
valueFromContents
	"Return a new value from the current contents string."
	^ contents! !


!StringMorph methodsFor: 'drawing' stamp: 'di 9/6/1999 22:43'!
drawOn: aCanvas

	aCanvas text: contents bounds: bounds font: self fontToUse color: color.! !


!StringMorph methodsFor: 'editing'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."
! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 17:04'!
acceptValue: aValue
	| val |
	self contents: (val _ aValue asString).
	^ val! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/17/1999 13:27'!
cancelEdits

	self doneWithEdits! !

!StringMorph methodsFor: 'editing' stamp: 'di 9/6/1999 22:44'!
doneWithEdits

	hasFocus _ false! !

!StringMorph methodsFor: 'editing' stamp: 'ar 10/6/2000 00:16'!
handlesMouseDown: evt
	^ (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
		ifTrue: [true]
		ifFalse: [super handlesMouseDown: evt].
! !

!StringMorph methodsFor: 'editing' stamp: 'ar 9/15/2000 23:06'!
launchMiniEditor: evt

	| textMorph |
	hasFocus _ true.  "Really only means edit in progress for this morph"
	textMorph _ StringMorphEditor new contentsAsIs: contents.
	textMorph beAllFont: self fontToUse.
	textMorph bounds: (self bounds expandBy: 0@2).
	self addMorphFront: textMorph.
	evt hand newMouseFocus: textMorph. self flag: #arNote. "Why???"
	evt hand newKeyboardFocus: textMorph.
	textMorph editor selectFrom: 1 to: textMorph paragraph text string size! !

!StringMorph methodsFor: 'editing' stamp: 'sw 9/8/1999 10:42'!
lostFocusWithoutAccepting
	"The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."

	self acceptContents! !

!StringMorph methodsFor: 'editing' stamp: 'di 9/5/1999 17:25'!
mouseDown: evt
	"If the shift key is pressed, make this string the keyboard input focus."

	(evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick])
		ifTrue: [self launchMiniEditor: evt]
		ifFalse: [super mouseDown: evt].
! !

!StringMorph methodsFor: 'editing' stamp: 'sw 7/21/1999 14:59'!
wantsKeyboardFocusOnShiftClick
	^ owner topRendererOrSelf wantsKeyboardFocusFor: self
! !

!StringMorph methodsFor: 'editing' stamp: 'sw 5/6/1998 15:45'!
wouldAcceptKeyboardFocus
	^ self isLocked not! !


!StringMorph methodsFor: 'printing'!
fullPrintOn: aStream

	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') contents: '; print: contents! !

!StringMorph methodsFor: 'printing' stamp: 'jm 11/3/97 16:52'!
printOn: aStream

	super printOn: aStream.
	aStream print: contents.
! !



!StringMorph methodsFor: 'layout' stamp: 'ar 11/9/2000 18:46'!
minHeight
	^self fontToUse height! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringMorph class
	instanceVariableNames: ''!

!StringMorph class methodsFor: 'instance creation' stamp: 'sw 5/6/1998 14:00'!
authoringPrototype
	^ super authoringPrototype contents: 'String'! !

!StringMorph class methodsFor: 'instance creation' stamp: 'sw 8/22/97 22:19'!
contents: aString
	" 'StringMorph contents: str' is faster than 'StringMorph new contents: str' "
	^ self contents: aString font: nil! !

!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'!
contents: aString font: aFont
	^ self basicNew initWithContents: aString font: aFont emphasis: 0! !

!StringMorph class methodsFor: 'instance creation' stamp: 'di 4/1/1999 17:15'!
contents: aString font: aFont emphasis: emphasisCode
	^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode! !


!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:07'!
test
	"Return a morph with lots of strings for testing display speed."
	| c |
	c _ AlignmentMorph newColumn.
	SystemOrganization categories do:
		[:cat | c addMorph: (StringMorph new contents: cat)].
	^ c! !

!StringMorph class methodsFor: 'testing' stamp: 'di 5/6/1998 21:08'!
test2
	"Return a morph with lots of strings for testing display speed."
	| c r |
	c _ AlignmentMorph newColumn.
	SystemOrganization categories reverseDo:
		[:cat | c addMorph: (StringMorph new contents: cat)].
	r _ RectangleMorph new extent: c fullBounds extent.
	c submorphsDo: [:m | r addMorph: m].
	^ r
! !
TextMorph subclass: #StringMorphEditor
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!StringMorphEditor commentStamp: '<historical>' prior: 0!
I am a textMorph used as a pop-up editor for StringMorphs.  I present a yellow background and I go away when a CR is typed or when the user clicks elsewhere.!


!StringMorphEditor methodsFor: 'all' stamp: 'sw 9/7/1999 16:22'!
drawOn: aCanvas

	aCanvas fillRectangle: self bounds color: Color yellow muchLighter.
	^ super drawOn: aCanvas! !

!StringMorphEditor methodsFor: 'all' stamp: 'ar 9/15/2000 23:06'!
handlesKeyboard: evt
	^true! !

!StringMorphEditor methodsFor: 'all' stamp: 'tk 11/29/2000 13:54'!
keyStroke: evt
	"This is hugely inefficient, but it seems to work, and it's unlikely it will ever need
	to be any more efficient -- it's only intended to edit single-line strings."

	| char priorEditor oldSel newSel |
	(((char _ evt keyCharacter) = Character enter) or: [(char = Character cr)
			or: [char = $s and: [evt commandKeyPressed]]])
				ifTrue: [owner doneWithEdits; acceptContents.
	self flag: #arNote. "Probably unnecessary"
						evt hand releaseKeyboardFocus.
						^ self delete].
	
	(char = $l and: [evt commandKeyPressed]) ifTrue:   "cancel"
		[owner cancelEdits.
		evt hand releaseKeyboardFocus.
		^ self delete].

	oldSel _ self editor selectionInterval.
	super keyStroke: evt.
	owner interimContents: self contents asString.
	newSel _ self editor selectionInterval.

	priorEditor _ self editor.  "Save editor state"
	self releaseParagraph.  "Release paragraph so it will grow with selection."
	self paragraph.      "Re-instantiate to set new bounds"
	self installEditorToReplace: priorEditor.  "restore editor state"

	oldSel = newSel ifTrue:
		["There is a bug that causes characters to be misplaced when the second
		character typed is wider than the first.  This fixes it (ugh)."
		self editor selectFrom: newSel first + 1 to: newSel last + 1].

! !

!StringMorphEditor methodsFor: 'all' stamp: 'sw 9/10/1999 15:58'!
keyboardFocusChange: aBoolean
	| hadFocus |
	hadFocus _ owner hasFocus.
	super keyboardFocusChange: aBoolean.
	aBoolean ifFalse:
		[hadFocus ifTrue:
			[owner lostFocusWithoutAccepting; doneWithEdits].
		^ self delete]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringMorphEditor class
	instanceVariableNames: ''!

!StringMorphEditor class methodsFor: 'as yet unclassified' stamp: 'kfr 5/1/2000 13:41'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
TileMorph subclass: #StringReadoutTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!StringReadoutTile methodsFor: 'literal' stamp: 'sw 9/17/1999 08:01'!
basicWidth
	^ 26! !

!StringReadoutTile methodsFor: 'literal' stamp: 'sw 11/1/97 13:15'!
literal: anObject
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last informTarget! !

!StringReadoutTile methodsFor: 'literal' stamp: 'sw 9/15/1999 15:14'!
setLiteralTo: anObject width: w
	"like literal:width: but does not inform the target"
	literal _ anObject.
	self updateLiteralLabel.
	submorphs last setWidth: w.
	self updateLiteralLabel! !
ObjectSocket subclass: #StringSocket
	instanceVariableNames: 'numStringsInNextArray stringsForNextArray nextStringSize files startTime stringCounter socketWriterProcess outputQueue bytesInOutputQueue extraUnsentBytes transmissionError '
	classVariableNames: 'MaxRatesSeen RecentSendHistory RunningSendCount '
	poolDictionaries: ''
	category: 'Network-ObjectSocket'!

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:14'!
addToInBuf: aString

	| newAlloc |
	newAlloc _ aString size * 2 max: 8000.
	inBuf ifNil: [
		inBuf _ String new: newAlloc.
		inBufIndex _ 1.
		inBufLastIndex _ 0.
	].
	aString size > (inBuf size - inBufLastIndex) ifTrue: [
		inBuf _ inBuf , (String new: newAlloc)
	].
	inBuf 
		replaceFrom: inBufLastIndex + 1 
		to: inBufLastIndex + aString size
		with: aString 
		startingAt: 1.
	inBufLastIndex _ inBufLastIndex + aString size.
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/31/2000 17:24'!
addToOutBuf: arrayToWrite

	| size newAlloc |
	size _ self spaceToEncode: arrayToWrite.
	newAlloc _ size * 2 max: 8000.	"gives us room to grow"
	outBuf ifNil: [
		outBuf _ String new: newAlloc.
		outBufIndex _ 1.
	].
	outBuf size - outBufIndex + 1 < size ifTrue: [
		outBuf _ outBuf , (String new: newAlloc).
	].
	CanvasEncoder at: 1 count: arrayToWrite size + 1.
	outBuf putInteger32: arrayToWrite size at: outBufIndex.
	outBufIndex _ outBufIndex + 4.
	arrayToWrite do: [ :each |
		outBuf putInteger32: each size at: outBufIndex.
		outBufIndex _ outBufIndex + 4.
		outBuf 
			replaceFrom: outBufIndex 
			to: outBufIndex + each size - 1 
			with: each 
			startingAt: 1.
		outBufIndex _ outBufIndex + each size.
	].
	^size! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/13/2000 08:29'!
backlog

	^bytesInOutputQueue + extraUnsentBytes! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/21/2000 09:51'!
barf

	self halt.
	! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:11'!
gotSomething

	numStringsInNextArray ifNil: [^self tryForNumStringsInNextArray ].
	nextStringSize ifNil: [^ self tryForNextStringSize ].
	^self tryForString
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/20/2000 15:55'!
inBufNext: anInteger
	
	| answer |
	answer _ inBuf copyFrom: inBufIndex to: inBufIndex + anInteger - 1.
	inBufIndex _ inBufIndex + anInteger.
	^answer! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/20/2000 15:55'!
inBufSize

	inBuf ifNil: [^0].
	^inBufLastIndex - inBufIndex + 1! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:54'!
isConnected

	^super isConnected and: [socketWriterProcess notNil]! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:52'!
nextPut: anObject

	socketWriterProcess ifNil: [^self].
	outObjects addLast: anObject! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:46'!
processIO
	"do some as much network IO as possible"

	socketWriterProcess ifNil: [^self].
	self processOutput.
	self processInput.! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/29/2000 13:05'!
processInput
	| totalReceived chunkOfData |
	"do as much input as possible"

	self flag: #XXX.  "should have resource limits here--no more than X objects and Y bytes"

	totalReceived _ 0.
	[ self isConnected and: [ socket dataAvailable ]] whileTrue: [
		chunkOfData _ socket getData.
		self addToInBuf: chunkOfData.
		totalReceived _ totalReceived + chunkOfData size.
	].
	totalReceived > 0 ifTrue: [
		NebraskaDebug at: #SendReceiveStats add: {'GET'. totalReceived}.
	].

	[ self gotSomething ] whileTrue: [].		"decode as many string arrays as possible"

	self shrinkInBuf.! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 8/14/2000 14:00'!
processOutput

	| arrayToWrite size bytesSent timeStartSending t itemsSent now timeSlot bucketAgeInMS bytesThisSlot |

	outBufIndex _ 1.
	itemsSent _ bytesSent _ 0.
	timeStartSending _ Time millisecondClockValue.
	[outObjects isEmpty not and: [self isConnected]] whileTrue: [
		arrayToWrite _ outObjects removeFirst.
		size _ self addToOutBuf: arrayToWrite.
		bytesSent _ bytesSent + size.
		itemsSent _ itemsSent + 1.
		outBufIndex > 10000 ifTrue: [self queueOutBufContents].
	].
	outBufIndex > 1 ifTrue: [self queueOutBufContents].
	bytesSent > 0 ifTrue: [
		MaxRatesSeen ifNil: [MaxRatesSeen _ Dictionary new].
		now _ Time millisecondClockValue.
		t _ now - timeStartSending.
		timeSlot _ now // 10000.	"ten second buckets"
		bucketAgeInMS _ now \\ 10.
		bytesThisSlot _ (MaxRatesSeen at: timeSlot ifAbsent: [0]) + bytesSent.
		MaxRatesSeen 
			at: timeSlot 
			put: bytesThisSlot.
		NebraskaDebug 
			at: #SendReceiveStats 
			add: {'put'. bytesSent. t. itemsSent. bytesThisSlot // (bucketAgeInMS max: 100)}.
	].
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/12/2000 19:42'!
purgeOutputQueue

	bytesInOutputQueue _ 0.
	[outputQueue nextOrNil notNil] whileTrue.! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/12/2000 19:42'!
queueOutBufContents

	bytesInOutputQueue _ bytesInOutputQueue + outBufIndex - 1.
	outputQueue nextPut: {outBuf. outBufIndex - 1}.
	NebraskaDebug at: #queuedbufferSizes add: {outBufIndex - 1}.
	outBufIndex _ 1.
	outBuf _ String new: 11000.
	
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/13/2000 08:29'!
sendDataCautiously: aStringOrByteArray bytesToSend: bytesToSend
	"Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent. Try not to send too much at once since this seemed to cause problems talking to a port on the same machine"

	| bytesSent count |

	bytesSent _ 0.
	[bytesSent < bytesToSend] whileTrue: [
		extraUnsentBytes _ bytesToSend - bytesSent.
		count _ socket 
			sendSomeData: aStringOrByteArray 
			startIndex: bytesSent + 1  
			count: (bytesToSend - bytesSent min: 6000).
		bytesSent _ bytesSent + count.
		(Delay forMilliseconds: 1) wait.
	].
	extraUnsentBytes _ 0.
	^ bytesSent
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:06'!
shrinkInBuf

	inBuf ifNil: [^self].
	inBufLastIndex < inBufIndex ifTrue: [
		inBufLastIndex _ 0.
		inBufIndex _ 1.
		inBuf size > 20000 ifTrue: [inBuf _ nil].	"if really big, kill it"
		^self
	].
	inBuf _ inBuf copyFrom: inBufIndex to: inBufLastIndex.
	inBufLastIndex _ inBuf size.
	inBufIndex _ 1.

! !

!StringSocket methodsFor: 'private-IO' stamp: 'ls 4/25/2000 18:36'!
spaceToEncode: anArray
	"return the number of characters needed to encode the given string array"
	^anArray inject: 4 into: [ :sum :array |
		sum + (array size + 4) ].! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 12/14/2000 09:42'!
transmitQueueNext

	| bufTuple |

	bufTuple _ outputQueue next.
	bytesInOutputQueue _ bytesInOutputQueue - bufTuple second max: 0.
	[
		self 
			sendDataCautiously: bufTuple first 
			bytesToSend: bufTuple second.
	]
		on: Error
		do: [ :ex |
			transmissionError _ true.
		].
	^transmissionError not

! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:05'!
tryForNextStringSize
	"grab the size of the next string, if it's available"

	self inBufSize >= 4 ifFalse: [^false].

	nextStringSize _ inBuf getInteger32: inBufIndex.
	"nextStringSize > 100000 ifTrue: [self barf]."
	inBufIndex := inBufIndex + 4.
	^true
! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:03'!
tryForNumStringsInNextArray
	"input numStringsInNextARray, if 4 bytes are available"

	self inBufSize >= 4 ifFalse: [^false].

	numStringsInNextArray := inBuf getInteger32: inBufIndex.
	"(numStringsInNextArray > 100 or: [numStringsInNextArray < 1]) ifTrue: [self barf]."
	inBufIndex := inBufIndex + 4.

	stringsForNextArray _ Array new: numStringsInNextArray.
	stringCounter _ 0.
	nextStringSize _ nil. 
	^true! !

!StringSocket methodsFor: 'private-IO' stamp: 'RAA 7/22/2000 09:04'!
tryForString
	"try to grab an actual string"

	self inBufSize >= nextStringSize ifFalse: [^false].

	stringsForNextArray 
		at: (stringCounter _ stringCounter + 1)
		put: (self inBufNext: nextStringSize) asString.

	stringCounter = numStringsInNextArray ifTrue: [	"we have finished another array!!"
		inObjects addLast: stringsForNextArray.
		stringCounter _ stringsForNextArray _ numStringsInNextArray _ nextStringSize _ nil.
	] ifFalse: [	"still need more strings for this array"
		nextStringSize _ nil.
	].

	^true
! !


!StringSocket methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 19:42'!
destroy

	socketWriterProcess ifNotNil: [socketWriterProcess terminate. socketWriterProcess _ nil].
	outputQueue _ nil.
	bytesInOutputQueue _ 0.
	socket ifNotNil: [socket destroy. socket _ nil.].
! !

!StringSocket methodsFor: 'as yet unclassified' stamp: 'RAA 12/14/2000 09:46'!
initialize: aSocket

	transmissionError _ false.
	super initialize: aSocket.
	outputQueue _ SharedQueue new.
	extraUnsentBytes _ bytesInOutputQueue _ 0.
	socketWriterProcess _ [
		[self transmitQueueNext] whileTrue.
		socketWriterProcess _ nil.
		outputQueue _ nil.
		bytesInOutputQueue _ 0.
	] forkAt: Processor lowIOPriority.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

StringSocket class
	instanceVariableNames: ''!

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 14:02'!
clearRatesSeen
"
StringSocket clearRatesSeen
"
	MaxRatesSeen _ nil ! !

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 7/21/2000 09:37'!
compareFiles
"
StringSocket compareFiles
"
	| data1 data2 |

	data1 _ (FileStream fileNamed: 'Macintosh HD:bob:nebraska test:58984048.1')
			contentsOfEntireFile.
	data2 _ (FileStream fileNamed: 'BobsG3:squeak:dsqueak:DSqueak2.7 folder:58795431.3')
			contentsOfEntireFile.
	1 to: (data1 size min: data2 size) do: [ :i |
		(data1 at: i) = (data2 at: i) ifFalse: [self halt].
	].
! !

!StringSocket class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 14:04'!
showRatesSeen
"
StringSocket showRatesSeen
"
	| answer |

	MaxRatesSeen ifNil: [^1 beep].
	answer _ WriteStream on: String new.
	MaxRatesSeen keys asSortedCollection do: [ :key |
		answer nextPutAll: key printString,'  ',((MaxRatesSeen at: key) // 10000) printString; cr
	].
	StringHolder new contents: answer contents; openLabel: 'send rates at 10 second intervals'.! !
Morph subclass: #SubpaneDividerMorph
	instanceVariableNames: 'resizingEdge '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SubpaneDividerMorph commentStamp: '<historical>' prior: 0!
A morph which presents a visible separator between subpanes of a SystemWindow which have zero edgeWidth.  Subpanes are submorphs of a SystemWindow's paneMorphs.

A SubpaneDividerMorph may also initiate reframe handles for the subpanes.  For resizing, it is expected that the main paneMorph has a ProportionalLayout LayoutPolicy, and that the subpanes to be resized have LayoutFrames with equal topFractions and bottomFractions, but different topOffsets and bottomOffsets.  It is the offsets that are changed, and the change is propagated through sibling morphs up to the first resizable morph (with different nominal frame fractions).

The direction of propagation is determined by the value of resizingEdge, which is one of: nil (for non-adjustible subpane divisions), #bottom or #top (which acts a though the divider is the corresponding edge of the subpane directly above or below it).  Does not currently support #left or #right binding, or subpanes in a TableLayout.
!


!SubpaneDividerMorph methodsFor: 'accessing' stamp: 'JW 2/3/2001 09:39'!
resizingEdge

	^resizingEdge
! !


!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:26'!
firstEnter: evt
	"The first time this divider is activated, find its window and redirect further interaction there."
	| window |

	window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:].
	window ifNil: [ self suspendEventHandler. ^ self ]. "not working out"
	window secondaryPaneTransition: evt divider: self.
	self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window.
! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:07'!
horizontal

	self hResizing: #spaceFill.! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:30'!
initialize

	super initialize.
	self extent: 1@1;
		color: Color black.! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:12'!
resizingEdge: edgeSymbol

	(#(top bottom) includes: edgeSymbol) ifFalse:
		[ self error: 'resizingEdge must be #top or #bottom' ].
	resizingEdge := edgeSymbol.
	self on: #mouseEnter send: #firstEnter: to: self.
! !

!SubpaneDividerMorph methodsFor: 'initialization' stamp: 'JW 2/3/2001 09:07'!
vertical

	self vResizing: #spaceFill.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SubpaneDividerMorph class
	instanceVariableNames: ''!

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:35'!
forBottomEdge
	^self new horizontal resizingEdge: #bottom! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:35'!
forTopEdge
	^self new horizontal resizingEdge: #top! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:31'!
horizontal
	^self new horizontal! !

!SubpaneDividerMorph class methodsFor: 'instance creation' stamp: 'JW 2/3/2001 09:31'!
vertical
	^self new vertical! !
FileDirectoryWrapper subclass: #SuperSwikiDirectoryWrapper
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!SuperSwikiDirectoryWrapper commentStamp: '<historical>' prior: 0!
The super swiki does not at present have subdirectories!


!SuperSwikiDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 2/2/2001 08:28'!
contents

	^#()		"we have no sundirectories"! !

!SuperSwikiDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 2/2/2001 08:28'!
hasContents

	^false		"we have no sundirectories"! !
ServerDirectory subclass: #SuperSwikiServer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/17/2000 16:10'!
queryAllProjects

"answer a collection of DirectoryEntry objects for each file on server"

"SuperSwikiServer testOnlySuperSwiki queryAllProjects"

	^self sendToSwikiProjectServer: {
		'action: listallprojects'.
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/17/2000 19:23'!
queryProjectsAndShow
	| result |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	result _ self sendToSwikiProjectServer: {
		'action: findproject'.
		"'projectname: *proj*'."
	}.
	(result beginsWith: 'OK') ifFalse: [^self inform: result printString].
	self showQueryAsPVM: (ReadStream on: result).
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/18/2000 12:23'!
queryProjectsAndShow: thingsToSearchFor
	| result |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	result _ self sendToSwikiProjectServer: {
		'action: findproject'.
	}, thingsToSearchFor.
	(result beginsWith: 'OK') ifFalse: [^self inform: result printString].
	self showQueryAsPVM: (ReadStream on: result).
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 17:01'!
queryPythagoras
"SuperSwikiServer testOnlySuperSwiki queryPythagoras"

	^self sendToSwikiProjectServer: {
		'action: findproject'.
		'projectsubcategory: *geometry*'.
		"'projectname: *pythagoras*'."
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 1/31/2001 14:03'!
showQueryAsPVM: resultStream
	| answer gif whatToShow projectName fileName firstURL wrapper currX currY maxX maxY |
"SuperSwikiServer testOnlySuperSwiki queryProjectsAndShow"

	resultStream reset; nextLine.
	answer _ RectangleMorph new
		useRoundedCorners;
		borderWidth: 0;
		borderColor: Color blue;
		color: Color paleBlue.
	currX _ currY _ maxX _ maxY _ 10.
	[resultStream atEnd] whileFalse: [
		projectName _ resultStream nextLine.
		fileName _ resultStream nextLine.
		gif _ self oldFileOrNoneNamed: projectName,'.gif'.
		gif ifNotNil: [gif _ GIFReadWriter formFromStream: gif].
		currX > 600 ifTrue: [
			currX _ 10.
			currY _ maxY + 10.
		].
		gif ifNil: [
			gif _ AlignmentMorph newColumn
				hResizing: #shrinkWrap;
				vResizing: #shrinkWrap;
				borderWidth: 8;
				borderColor: Color red;
				color: Color lightRed;
				addMorph: (StringMorph contents: 'No GIF for ',projectName);
				fullBounds;
				imageForm
		].
		firstURL _ self url.
		firstURL last == $/ ifFalse: [firstURL _ firstURL, '/'].

		whatToShow _ ProjectViewMorph new
			image: (gif asFormOfDepth: Display depth);
			lastProjectThumbnail: gif;
			setProperty: #SafeProjectName toValue: projectName;
			project: (DiskProxy 
				global: #Project 
				selector: #namedUrl: 
				args: {firstURL,fileName}
			).

		answer addMorphBack: (whatToShow position: currX @ currY).
		currX _ currX + whatToShow width + 10.
		maxX _ maxX max: currX.
		maxY _ maxY max: currY + whatToShow height.
	].
	maxX = 10 ifTrue: [
		^self inform: 'No projects found for your criteria'
	].
	answer extent: (maxX @ maxY) + (0@10).
	wrapper _ ScrollPane new extent: (answer width + 10) @ (answer height min: 400).
	wrapper color: Color white.
	wrapper scroller addMorph: answer.
	wrapper 
		openCenteredInWorld;
		useRoundedCorners;
		setScrollDeltas.! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/25/2000 12:14'!
speedTest1

"SuperSwikiServer testOnlySuperSwiki speedTest1"

	| answer t totalTime |

	totalTime _ [
		answer _ (1 to: 10) collect: [ :x |
			t _ [answer _ self sendToSwikiProjectServer: {
				'action: readnamedfile'.
				'projectname: xyz.002.pr'.
			}] timeToRun.
			{t. answer size}
		].
	] timeToRun.
	^{totalTime. answer}
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/25/2000 12:38'!
speedTest2

"SuperSwikiServer testOnlySuperSwiki speedTest2"

"==observed results
10 forks of 10 reads of 88K in 12.7 seconds
100 * 88110 / 12.7 ===> 693779 bytes per second
---
10 forks of 10 reads of 88K in 10.7 seconds
100 * 88110 / 10.7 ===> 823457 bytes per second
---at priority 5
10 forks of 10 reads of 88K in 9.8 seconds
100 * 88110 / 9.8 ===> 899081 bytes per second
==="

	| answer bigAnswer tRealBegin tRealEnd |

	bigAnswer _ SharedQueue new.
	tRealBegin _ tRealEnd _ Time millisecondClockValue.
	10 timesRepeat: [
		[
			answer _ SuperSwikiServer testOnlySuperSwiki speedTest1.
			tRealEnd _ Time millisecondClockValue.
			bigAnswer nextPut: {
				{tRealBegin. tRealEnd. tRealEnd - tRealBegin}.
				answer
			}.
		] forkAt: 5
	].
	bigAnswer inspect.
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/7/2000 16:12'!
test1

	| localDirectory localFileName local resp |

	localDirectory _ FileDirectory default.
	localFileName _ 'superTest1.07Oct1611.cs'.
	local _ localDirectory oldFileNamed: localFileName.
	resp _ self putFile: local named: localFileName retry: false.
	local close.
	^resp
! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 17:02'!
testPost3
"SuperSwikiServer testOnlySuperSwiki testPost3"

	self updateProject3.
	self updateBioPythagoras.
	self updateSunday1.! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 16:59'!
updateBioPythagoras

	self sendToSwikiProjectServer: {
		'action: updatepage'.
		'projectname: Bio of Pythagoras'.
		'projectdescription: The life and times of Pythagoras are explored'.
		'projectcategory: Educational.'.
		'projectsubcategory: Geometry.'.
		'projectages: 10 and up.'.
		'projectkeywords: triangles Pythagoras moon.'.
		'projectlinks: More Triangles.Geometry Index'.
		'projectimage: sunday1.gif'.
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 17:00'!
updateProject3

	self sendToSwikiProjectServer: {
		'action: updatepage'.
		'projectname: My Project3'.
		'projectdescription: This project explores uses of triangles. Calculating the distance to the moon is one of the exercises.'.
		'projectcategory: Educational.'.
		'projectsubcategory: Geometry.'.
		'projectages: 10 and up.'.
		'projectkeywords: triangles Pythagoras moon.'.
		'projectlinks: More Triangles.Bio of Pythagoras.Geometry Index'.
	}! !

!SuperSwikiServer methodsFor: 'testing' stamp: 'RAA 10/12/2000 17:00'!
updateSunday1

	self sendToSwikiProjectServer: {
		'action: updatepage'.
		'projectname: sunday1'.
		'projectdescription: blah blah blah.'.
		'projectcategory: Educational.'.
		'projectsubcategory: Geometry.'.
		'projectages: 10 and up.'.
		'projectkeywords: triangles Pythagoras moon.'.
		'projectlinks: More Triangles.Bio of Pythagoras.Geometry Index'.
	}! !


!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 2/2/2001 08:29'!
directoryWrapperClass

	^SuperSwikiDirectoryWrapper! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 12:54'!
entries

	| answer c first |

	answer _ self sendToSwikiProjectServer: {
		'action: listallprojects'.
	}.
	(answer beginsWith: 'OK') ifFalse: [^#()].
	c _ OrderedCollection new.
	first _ true.
	answer linesDo: [ :x |
		first ifFalse: [c add: (Compiler evaluate: x)].
		first _ false.
	].
	^c
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/19/2000 16:35'!
fileNames

	^self entries collect: [ :each | each name]! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 12:49'!
getOnly: numberOfBytes from: aName

	| answer |

	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',aName.
		'bytestoread: ',numberOfBytes printString.
	}.
	(answer beginsWith: 'OK') ifFalse: [ ^nil].
	^answer allButFirst: 3
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 14:54'!
oldFileNamed: aName

	| answer |

	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',aName.
	}.
	(answer beginsWith: 'OK') ifFalse: [ ^nil].
	^(SwikiPseudoFileStream with: (answer allButFirst: 3))
		reset;
		directory: self;
		localName: aName;
		yourself
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 14:54'!
oldFileOrNoneNamed: fullName

	| answer aName |

	self flag: #bob.		"fix this up for full names"

	aName _ fullName.
	answer _ self sendToSwikiProjectServer: {
		'action: readnamedfile'.
		'projectname: ',(self localNameFor: aName).
	}.
	(answer beginsWith: 'OK') ifFalse: [^nil].
	^(SwikiPseudoFileStream with: (answer allButFirst: 3))
		reset;
		directory: self;
		localName: aName;
		yourself
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 12:50'!
putFile: fileStream named: fileNameOnServer

	^(
		self sendToSwikiProjectServer: {
			'uploadproject: ',fileNameOnServer.
			fileStream contentsOfEntireFile.
		}
	) beginsWith: 'OK'
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/13/2000 16:53'!
readOnlyFileNamed: aName

	^self oldFileNamed: aName
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 10/17/2000 12:46'!
sendToSwikiProjectServer: anArray

	| argsDict answer buildStream |

	buildStream _ WriteStream on: String new.
	anArray do: [ :each | 
		buildStream 
			nextPutAll: each size printString;
			space;
			nextPutAll: each
	].
	(argsDict _ Dictionary new)
		at: 'swikicommands'
		put: {buildStream contents}.
	answer _ HTTPSocket 
		httpPostMultipartBOB: self url
		args: argsDict
		accept: 'application/octet-stream' 
		request: ''.
	^(answer isKindOf: MIMEDocument) ifTrue: [answer content] ifFalse: [answer]
! !

!SuperSwikiServer methodsFor: 'for real' stamp: 'RAA 1/29/2001 18:41'!
updateProjectInfoFor: aProject

	| data details projectLinks linkString uploader |

	data _ OrderedCollection new.
	data add: 'action: updatepage'.
	data add: 'projectimage: ',aProject name,'.gif'.
	uploader _ Utilities authorNamePerSe.
	uploader isEmptyOrNil ifTrue: [uploader _ Utilities authorInitialsPerSe].
	uploader isEmptyOrNil ifFalse: [
		data add: 'submittedBy: ',uploader.
	].
	projectLinks _ Set new.
	aProject world allMorphsDo: [ :each |
		(each isKindOf: ProjectViewMorph) ifTrue: [
			projectLinks add: each safeProjectName.
		].
	].
	details _ aProject world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new].
	details at: 'projectname' ifAbsentPut: [aProject name].
	projectLinks isEmpty ifTrue: [
		details removeKey: 'projectlinks' ifAbsent: []
	] ifFalse: [
		linkString _ String streamContents: [ :strm |
			projectLinks asSortedCollection do: [ :each |
				strm nextPutAll: each
			] separatedBy: [
				strm nextPut: $.
			].
		].
		details at: 'projectlinks' put: linkString
	].
	details keysAndValuesDo: [ :k :v |
		data add: k , ': ' , v
	].
	^self sendToSwikiProjectServer: data.
! !


!SuperSwikiServer methodsFor: 'not implemented' stamp: 'RAA 10/13/2000 11:54'!
asServerFileNamed: x

	self halt.! !

!SuperSwikiServer methodsFor: 'not implemented' stamp: 'RAA 10/13/2000 11:53'!
fileNamed: fullName

	self flag: #bob.		"finish this"
	self halt.! !

!SuperSwikiServer methodsFor: 'not implemented' stamp: 'RAA 10/13/2000 11:53'!
wakeUp

	"no action required here"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SuperSwikiServer class
	instanceVariableNames: ''!

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/7/2000 17:47'!
currentSuperSwiki

	"make this return nil to disable SuperSwiki hack"

	^self defaultSuperSwiki

! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 19:11'!
defaultSuperSwiki

	^SuperSwikiServer new 
		type: #http;
		server: self defaultSuperSwikiIPAddress;
		directory: '/super/SuperSwikiProj'
	
! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 11:05'!
defaultSuperSwikiIPAddress

	^'209.143.91.36'
! !

!SuperSwikiServer class methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 19:11'!
testOnlySuperSwiki

	^SuperSwikiServer new 
		type: #http;
		server: self defaultSuperSwikiIPAddress;
		directory: '/super/SuperSwikiProj'
	
! !
InterpreterPlugin subclass: #SurfacePlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!SurfacePlugin commentStamp: '<historical>' prior: 0!
This plugin is a fake. It doesn't do anything useful. It's sole purpose is to wrap the C code that's associated with the SurfacePlugin into the main VM generation process. Since the C code isn't easily generated from ST code this is (unfortunately) necessary. But look on the bright side - you don't have to define any weird stuff for the C compiler. Isn't that great?!! (just kidding...) !


!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:33'!
initialiseModule
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioFindSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioGetSurfaceFormat
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioLockSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioRegisterSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioShowSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioUnlockSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:34'!
ioUnregisterSurface
	"Fake entry point"
	self export: true! !

!SurfacePlugin methodsFor: 'fake entry points' stamp: 'ar 5/26/2000 22:33'!
shutdownModule
	"Fake entry point"
	self export: true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SurfacePlugin class
	instanceVariableNames: ''!

!SurfacePlugin class methodsFor: 'translation' stamp: 'ar 5/26/2000 22:32'!
headerFile
^'#ifndef __SQ_DRAW_SURFACE_H
#define __SQ_DRAW_SURFACE_H
/* v1.0 */
#define SQ_SURFACE_MAJOR 1
#define SQ_SURFACE_MINOR 0

/* Plugins creating their own surfaces must register these using
   the following set of functions. The typedefs are for easier casts. */
typedef int (*fn_getSurfaceFormat)(int surfaceHandle, int* width, int* height, int* depth, int* isMSB);
typedef int (*fn_lockSurface)(int surfaceHandle, int *pitch, int x, int y, int w, int h);
typedef int (*fn_unlockSurface)(int surfaceHandle, int x, int y, int w, int h);
typedef int (*fn_showSurface)(int surfaceHandle, int x, int y, int w, int h);

typedef struct sqSurfaceDispatch {
	/* Version information. Must be provided by the client
	   so the surface manager can check if certain operations
	   are supported. */
	int majorVersion;
	int minorVersion;

	/* Version 1.0 */
	fn_getSurfaceFormat getSurfaceFormat;
	fn_lockSurface lockSurface;
	fn_unlockSurface unlockSurface;
	fn_showSurface showSurface;
} sqSurfaceDispatch;

/* The functions for sqSurfaceDispatch are:

	int getSurfaceFormat(int handle, int* width, int* height, int* depth, int* isMSB);
		Return general information about the OS drawing surface.
		Return true if successful, false otherwise.

		The returned values describe the basic properties such as
		width, height, depth and LSB vs. MSB pixels.

	int lockSurface(int handle, int *pitch, int x, int y, int w, int h);
		Lock the bits of the surface.
		Return a pointer to the actual surface bits, or NULL on failure.
		If successful, store the pitch of the surface (e.g., the bytes
		per scan line).

		For equal source/dest handles only one locking operation is performed.
		This is to prevent locking of overlapping areas which does not work with
		certain APIs (e.g., DirectDraw prevents locking of overlapping areas). 
		A special case for non-overlapping but equal source/dest handle would 
		be possible but we would have to transfer this information over to 
		unlockSurfaces somehow (currently, only one unlock operation is 
		performed for equal source and dest handles). Also, this would require
		a change in the notion of ioLockSurface() which is right now interpreted
		as a hint and not as a requirement to lock only the specific portion of
		the surface.

		The arguments in ioLockSurface() provide the implementation with
		an explicit hint what area is affected. It can be very useful to
		know the max. affected area beforehand if getting the bits requires expensive
		copy operations (e.g., like a roundtrip to the X server or a glReadPixel op).
		However, the returned pointer *MUST* point to the virtual origin of the surface
		and not to the beginning of the rectangle. The promise made by BitBlt
		is to never access data outside the given rectangle (aligned to 4byte boundaries!!)
		so it is okay to return a pointer to the virtual origin that is actually outside
		the valid memory area.

		The area provided in ioLockSurface() is already clipped (e.g., it will always
		be inside the source and dest boundingBox) but it is not aligned to word boundaries
		yet. It is up to the support code to compute accurate alignment if necessary.

	int unlockSurface(int handle, int x, int y, int w, int h);
		Unlock the bits of a (possibly modified) surface after BitBlt completed.
		The return value is ignored.

		The arguments provided specify the dirty region of the surface. If the
		surface is unmodified all arguments are set to zero.

	int showSurface(int handle, int x, int y, int w, int h);
		Display the contents of the surface on the actual screen.

		If ioShowSurface() is called the surface in question represents
		a Squeak DisplayScreen.

	FXBlt uses a variant of the above functions which are exported from
	the surface plugin:

	int ioGetSurfaceFormat(int surfaceID, int* width, int* height, int* depth, int* isMSB);
	int ioLockSurface(int surfaceID, int *pitch, int x, int y, int w, int h);
	int ioUnlockSurface(int surfaceID, int x, int y, int w, int h);

	These functions are looked up in the registered surfaces and invoked
	as appropriate. The meaning of all values is exactly the same as for
	the functions specified in sqSurfaceDispatch with the exception that
	the surfaceID represents the ''bits'' handle of the Form that is used
	within FXBlt.

	Interpreter itself uses a separate entry point for updating the display

	int ioShowSurface(int surfaceID, int x, int y, int w, int h);

	since the management of deferred updates is currently an intrinsic
	property of the VM (which is bad - deferred updates should be a
	property of the DisplayScreen in question and not of the VM but
	that''s the way it is...).

*/

/* The following are the entry points for the surface manager:

	int ioRegisterSurface(int surfaceHandle, sqSurfaceDispatch *fn, int *surfaceID);
		Register a new surface with the given handle and
		the set of surface functions. The new ID is returned
		in surfaceID. Returns true if successful, false 
		otherwise.

	int ioUnregisterSurface(int surfaceID);
		Unregister the surface with the given handle.
		Returns true if successful, false otherwise.

	int ioFindSurface(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle);
		Find the surface with the given ID, and, optionally,
		the given set of surface functions. The registered handle
		is returned in surfaceHandle. Return true if successful
		(e.g., the surface has been found), false otherwise.

	The above entry points can be looked up through the interpreter, e.g., using
		interpreterProxy->ioLoadFunctionFrom("ioRegisterSurface","SurfacePlugin");
	The typedefs below are for easier casts.
*/
typedef int (*fn_ioRegisterSurface)(int surfaceHandle, sqSurfaceDispatch *fn, int *surfaceID);
typedef int (*fn_ioUnregisterSurface)(int surfaceID);
typedef int (*fn_ioFindSurface)(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle);

#endif /* __SQ_DRAW_SURFACE_H */
'! !

!SurfacePlugin class methodsFor: 'translation' stamp: 'ar 6/5/2000 17:54'!
sourceCode
^'/*
	This file contains the low-level support code for OS
	surfaces. Since FXBlt may operate on any of these
	some functions must be provided by the client. It is
	crucial that every client creating surfaces for use
	by Squeak registers the surfaces using the functions
	provided here. Other concrete primitives (such as
	creation or destroy) of surfaces can be handled by
	additional support code, querying the surface handle
	from ioFindSurface but the functions provided below
	are critical for any BitBlt operations.
*/

#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

/* Default EXPORT macro that does nothing (see comment in sq.h): */
#define EXPORT(returnType) returnType

#include "sqVirtualMachine.h"
#include "sqConfig.h"
#include "sqPlatformSpecific.h"
#include "SurfacePlugin.h"

/* The definition below will be replaced by 0/1 when the file is generated */
#if $$SURFACE_PLUGIN_STANDALONE$$
# define XNAME(string) string
#else
# define XNAME(string) SurfacePlugin_##string
#endif

typedef struct SqueakSurface {
	int handle; /* client supplied handle */
	sqSurfaceDispatch *dispatch;
} SqueakSurface;

static SqueakSurface *surfaceArray = NULL;
static int numSurfaces = 0;
static int maxSurfaces = 0;

static const char *moduleName = "SurfacePlugin";
static VirtualMachine *interpreterProxy;
#define FAIL { interpreterProxy->primitiveFail(); return 0; }

#pragma export on
/* module initialization/shutdown */
EXPORT(int) XNAME(setInterpreter)(struct VirtualMachine *interpreterProxy);
EXPORT(const char*) XNAME(getModuleName)(void);
EXPORT(int) XNAME(initialiseModule)(void);
EXPORT(int) XNAME(shutdownModule)(void);

/* critical FXBlt entry points */
EXPORT(int) XNAME(ioGetSurfaceFormat) (int surfaceID, int* width, int* height, int* depth, int* isMSB);
EXPORT(int) XNAME(ioLockSurface) (int surfaceID, int *pitch, int x, int y, int w, int h);
EXPORT(int) XNAME(ioUnlockSurface)(int surfaceID, int x, int y, int w, int h);

/* interpreter entry point */
EXPORT(int) XNAME(ioShowSurface)(int surfaceID, int x, int y, int w, int h);

/* client entry points */
EXPORT(int) XNAME(ioRegisterSurface)(int surfaceHandle, sqSurfaceDispatch *fn, int *surfaceID);
EXPORT(int) XNAME(ioUnregisterSurface)(int surfaceID);
EXPORT(int) XNAME(ioFindSurface)(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle);
#pragma export off

/* ioGetSurfaceFormat:
	Return information describing the given surface.
	Return true if successful, false otherwise. */
EXPORT(int) XNAME(ioGetSurfaceFormat) (int surfaceID, int* width, int* height, int* depth, int* isMSB)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) FAIL;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) FAIL;
	if(!!surface->dispatch->getSurfaceFormat) FAIL;
	return surface->dispatch->getSurfaceFormat(surface->handle, width, height, depth, isMSB);
}

/* ioLockSurface:
	Lock the bits of the surface. 
	Return a pointer to the actual surface bits,
	or NULL on failure. */
EXPORT(int) XNAME(ioLockSurface) (int surfaceID, int *pitch, int x, int y, int w, int h)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) FAIL;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) FAIL;
	if(!!surface->dispatch->lockSurface) FAIL;
	return surface->dispatch->lockSurface(surface->handle, pitch, x, y, w, h);
}

/* ioUnlockSurface:
	Unlock the bits of the surface. 
	The return value is ignored. */
EXPORT(int) XNAME(ioUnlockSurface)(int surfaceID, int x, int y, int w, int h)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) FAIL;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) FAIL;
	if(!!surface->dispatch->unlockSurface) FAIL;
	return surface->dispatch->unlockSurface(surface->handle, x, y, w, h);
}

/* ioShowSurface:
	Transfer the bits of a surface to the screen. */
EXPORT(int) XNAME(ioShowSurface)(int surfaceID, int x, int y, int w, int h)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) FAIL;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) FAIL;
	if(!!surface->dispatch->showSurface) FAIL;
	return surface->dispatch->showSurface(surface->handle, x, y, w, h);
}

/* ioRegisterSurface:
	Register a new surface with the given handle and
	the set of surface functions. The new ID is returned
	in surfaceID. Returns true if successful, false 
	otherwise. */
EXPORT(int) XNAME(ioRegisterSurface)(int surfaceHandle, sqSurfaceDispatch *fn, int *surfaceID)
{
	int index;

	if(!!fn) return 0;
	if(fn->majorVersion !!= 1 && fn->minorVersion !!= 0) return 0;
	if(numSurfaces == maxSurfaces) {
		maxSurfaces = maxSurfaces * 2 + 10;
		surfaceArray = realloc(surfaceArray, sizeof(SqueakSurface) * maxSurfaces);
		for(index = numSurfaces; index < maxSurfaces; index++){
			surfaceArray[index].handle = 0;
			surfaceArray[index].dispatch = NULL;
		}
		index = numSurfaces;
	} else {
		for(index = 0; index < maxSurfaces; index++)
			if(surfaceArray[index].dispatch == NULL)
				break;
	}
	if(index >= maxSurfaces) return 0; /* should not happen */
	surfaceArray[index].handle = surfaceHandle;
	surfaceArray[index].dispatch = fn;
	*surfaceID = index;
	numSurfaces++;
	return 1;
}

/* ioUnregisterSurface:
	Unregister the surface with the given handle.
	Returns true if successful, false otherwise. */
EXPORT(int) XNAME(ioUnregisterSurface)(int surfaceID)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) return 0;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) return 0;
	surface->handle = 0;
	surface->dispatch = NULL;
	numSurfaces--;
	return 1;
}

/* ioFindSurface:
	Find the surface with the given ID, and, optionally,
	the given set of surface functions. The registered handle
	is returned in surfaceHandle. Return true if successful
	(e.g., the surface has been found), false otherwise. */
EXPORT(int) XNAME(ioFindSurface)(int surfaceID, sqSurfaceDispatch *fn, int *surfaceHandle)
{
	SqueakSurface *surface;
	if(surfaceID < 0 || surfaceID >= maxSurfaces) return 0;
	surface = surfaceArray + surfaceID;
	if(surface->dispatch == NULL) return 0;
	if(fn && fn !!= surface->dispatch) return 0;
	*surfaceHandle = surface->handle;
	return 1;
}

EXPORT(int) XNAME(setInterpreter)(struct VirtualMachine* anInterpreter) {
    int ok;

	interpreterProxy = anInterpreter;
	ok = interpreterProxy->majorVersion() == VM_PROXY_MAJOR;
	if (ok == 0) {
		return 0;
	}
	ok = interpreterProxy->minorVersion() >= VM_PROXY_MINOR;
	return ok;
}
EXPORT(const char*) XNAME(getModuleName)(void) {
	return moduleName;
}

EXPORT(int) XNAME(initialiseModule)() {
	surfaceArray = NULL;
	numSurfaces = 0;
	maxSurfaces = 0;
	return 1;
}

EXPORT(int) XNAME(shutdownModule)() {
	/* This module can only be shut down if no surfaces are registered */
	if(numSurfaces !!= 0) return 0;
	free(surfaceArray);
	return 1;
}
'! !

!SurfacePlugin class methodsFor: 'translation' stamp: 'ar 2/3/2001 16:44'!
translateOn: cg inlining: inlineFlag to: fullName local: localFlag
	"do the actual translation"
	| theClass fd |
	theClass _ self.
	[theClass == Object] whileFalse:[
		cg addClass: theClass.
		theClass declareCVarsIn: cg.
		theClass _ theClass superclass].
	"cg storeCodeOnFile: fullName doInlining: inlineFlag."
	fd _ FileDirectory on: (FileDirectory dirPathFor: fullName).
	(CrLfFileStream newFileNamed: (fd fullNameFor: self moduleName,'.c'))
		nextPutAll: 
			(self sourceCode 
				copyReplaceAll:'$$SURFACE_PLUGIN_STANDALONE$$'
				with: (localFlag ifTrue:['0'] ifFalse:['1']));
		close.
! !
ServerAction subclass: #SwikiAction
	instanceVariableNames: 'urlmap source name formatters formatter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!
!SwikiAction commentStamp: '<historical>' prior: 0!
SwikiAction is the action to implement a Swiki, a collaborative website.
This is a web server in Squeak.  Each page served has an "Edit this Page"
link.  The syntax rules for editing pages (from any web browser) are in the
file FormattingRules.

The pages may be viewed from any web browser, and the URL is
http://thisMachine:80/OurOwnArea.1  ('OurOwnArea' is the name of the Swiki
area.)  See http://guzdial.cc.gatech.edu:8080/myswiki for an example
focused on discussing Swikis.

Swiki is based on the Wiki Server, designed and implemented by Ward
Cunningham.  See the original Wiki at http://c2.com/cgi-bin/wiki, or the
Squeak-focused one at http://c2.com:8080/

See PWS class howToStart.

Modified by Ted Kaehler to have all state on the disk at all times.  Do not
snapshot the image during normal server operation.  Restart the server by
loading all state from the disk.

Each separate Wiki is a folder inside the Server folder.  The name of the
folder is the name of the Wiki.  Each page is a file.  (Inefficient on Macs
because of large minimum page size, but that's an OS problem.)  All
versions of all pages are kept.  Each page contains chunks, just like a
changes file.  Each chunk is one version of one page:

self name: 'Ted''s Page' date: '1/28/1998' time: '12:47:21' by: 'tk' text:
'Here is the body of the page' back: 116!!

The last item is number of bytes in the chunk.  It is the number of bytes
from the start of the chunk to just in front of the number.  This allows
back-chaining to old versions.  On startup, the chunk is executed
explicitly using evaluate:for:logged:.  It supplies the page name to a
SwikiPage and installs it in the URLmap.  By doing this for all files in
the folder, the map (url->page) is built.  During operation, the chunk is
not executed.  Instead, take the file directly, look at 'back:' at the end,
jump back to the start of the chunk, scan for 'text:' and read the text.

The looks of the pages served are controlled by templates.  They live in
the 'swiki' folder in the 'Server' folder.  See page.html for how to change
the look of a served page.  Beware that templates are cached by
HTMLformatter.  If you change a template, you will not see the effect until
you reload the Swiki.

A symbol *append here* may be added anywhere in the page.  Clicking on it
will bring up a page with a text editing form.  The what you type will be
inserted just before the *append here* marker.  This allows append-only
pages, or multiple questions with places to add to the answer.

!


!SwikiAction methodsFor: 'accessing' stamp: 'mjg 8/28/1998 20:58'!
formatter
	^formatter! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 8/28/1998 20:58'!
formatter: anHTMLformatter
	formatter _ anHTMLformatter! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
map
	"Answer the receiver's 'urlmap'."

	^urlmap! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:23'!
map: anObject
	"Set the receiver's instance variable 'urlmap' to be anObject."

	urlmap := anObject! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
name
	"Answer the receiver's 'name'."

	^name! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
name: anObject
	"Set the receiver's instance variable 'name' to be anObject."

	name := anObject! !

!SwikiAction methodsFor: 'accessing' stamp: 'tk 1/15/98 13:38'!
path
	"A complete file path name to the directory where my page data is stored"
	^ (ServerAction serverDirectory) , name, (ServerAction pathSeparator)! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
source
	"Answer the receiver's 'source'."

	^source! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
source: anObject
	"Set the receiver's instance variable 'source' to be anObject."

	source := anObject! !

!SwikiAction methodsFor: 'accessing' stamp: 'TPR 7/21/1998 18:06'!
url
	"Answer the receiver's 'name'."

	^name! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
urlmap
	"Answer the receiver's 'urlmap'."

	^urlmap! !

!SwikiAction methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:22'!
urlmap: anObject
	"Set the receiver's instance variable 'urlmap' to be anObject."

	urlmap := anObject! !


!SwikiAction methodsFor: 'save and restore' stamp: 'mdr 9/4/2000 10:56'!
convert
	"Make all my pages obey the new format -- all versions in one file, file name is just a single number."

	| old new nn |
	urlmap pages do: [:page |
		old _ page file.   nn _ old size.
		(old at: nn) isDigit & ((old at: nn-1) == $.)
			ifFalse: [self error: 'May not be an old style page']
			ifTrue: [new _ old copyFrom: 1 to: nn-2.	"knock off .4"
				page file: new.
				page text: (FileStream readOnlyFileNamed: old) contentsOfEntireFile]].
	! !

!SwikiAction methodsFor: 'save and restore' stamp: 'ls 7/27/1998 23:26'!
fixAllLineEndings
	"for each page in the swiki, fixes line endings to be CR only.
This is used to bring older Swikis up to date with the newer convention.
If a page has no LF's, then it is left alone"
	| origText newText pagesDone |
	pagesDone _ 0.
	'updating pages...' displayProgressAt: Sensor cursorPoint from: 0
to: urlmap pages size during: [ :bar |
		urlmap pages do: [ :page |
			origText _ page text.
			newText _ origText withSqueakLineEndings.
			origText = newText ifFalse: [ page text: newText ].

			pagesDone _ pagesDone + 1.
			bar value: pagesDone. ] ]! !

!SwikiAction methodsFor: 'save and restore' stamp: 'mjg 10/9/1998 13:05'!
restore: nameOfSwiki
	"Read all files in the directory 'nameOfSwiki'.  Reconstruct the
url map."

	| map page folder dir rep templateFolder |
	map _ self class mapClass new.
	self map: map.
	self formatter: (HTMLformatter new initialize).
	self formatter specialCharacter: $*.
	self name: nameOfSwiki.
	templateFolder _ 'swiki'.
	self source: templateFolder,(ServerAction pathSeparator).
	map action: self.
	map pages: (Dictionary new).
	map directory: nameOfSwiki. "This is where the pages are."
	folder _ (ServerAction serverDirectory), nameOfSwiki.
	dir _ FileDirectory on: folder.
	dir fileNames do: [:fName |
		rep _ fName detect: [:char | char isDigit not] ifNone: [$3].
		rep isDigit ifTrue: ["all are digits"
			page _ self class pageClass new.
			page fromFileNamed: folder,
				(ServerAction pathSeparator),fName action: self.
			(page time isNil) ifTrue: [page time: Time now].
			map at: page name put: page]].
	PWS link: nameOfSwiki to: self.
! !

!SwikiAction methodsFor: 'save and restore' stamp: 'mjg 12/23/97 09:32'!
restoreFrom: filename
	|f|
	f _ ReferenceStream fileNamed: filename.
	self map: f next.
	self map action: self.
	f close.! !

!SwikiAction methodsFor: 'save and restore' stamp: 'tk 1/28/98 15:17'!
rollBack: aDate at: aTime
	"Roll back the entire server to a previous state.  This does not erase data, just moves an older page to the end."

	| folder dir rep page |
	folder _ (ServerAction serverDirectory), name.
	dir _ FileDirectory on: folder.
	dir fileNames do: [:fName |
		rep _ fName detect: [:char | char isDigit not] ifNone: [$3].
		rep isDigit ifTrue: ["all are digits"
			page _ urlmap atID: fName.
			page rollBack: aDate at: aTime]].
! !

!SwikiAction methodsFor: 'save and restore' stamp: 'mjg 11/28/97 10:33'!
saveTo: filename
	|f|
	f _ ReferenceStream fileNamed: filename.
	f nextPut: self map.
	f close.! !


!SwikiAction methodsFor: 'URL processing' stamp: 'mjg 8/28/1998 20:59'!
browse: pageRef from: request
	"Just reply with a page in HTML format"

	| formattedPage htmlForUser |
	formattedPage _ pageRef copy.

	"Make a copy, then format the text."
	formattedPage formatted: (formatter swikify: pageRef text
			linkhandler: [:link | urlmap
					linkFor: link
					from: request peerName
					storingTo: OrderedCollection new
					page: formattedPage]).

	"format using the cached formatter"
	htmlForUser _ ((self formatterFor: 'page') format: formattedPage).
	htmlForUser size = 0 ifTrue: [self error: 'template file
''page.html'' not found'].
	request reply: htmlForUser.
! !

!SwikiAction methodsFor: 'URL processing' stamp: 'mjg 8/31/1998 15:32'!
edit: pageRef from: request
	request reply: (HTMLformatter evalEmbedded:
							(self fileContents:
source , 'edit.html')
						with: pageRef).
	pageRef noteEditRequest.
	^ self! !

!SwikiAction methodsFor: 'URL processing' stamp: 'mjg 9/10/1998 15:31'!
inputFrom: request
	"Take user's input and respond with a searchresult or store the edit"
"	{swikiname}.{coreID}  {with a field named 'text'}  store an edited page
	{swikiname}.{coreID}  {with a field named 'text-placeID'}  store text
in a specific place
	{swikiname}.searchresult  {with a field named 'searchFor'} conducts the
search for that text and sends back the result
"
	| coreRef page theText |
	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,
			((self formatterFor: 'recent') format: (urlmap
searchFor:
						(request fields at:
'searchFor' ifAbsent:
['nothing']))).
		^ #return].
	(theText _ request fields at: 'text' ifAbsent: [nil]) ifNotNil: [
		"It's a response from an edit, so store the page"
		page _ urlmap atID: coreRef.
		page user: request peerName.  "Address is machine, user only if
logged in"
		 page pageStatus = #new ifTrue: [page pageStatus: #standard].
		page _ urlmap
			storeID: coreRef
			text: theText withSqueakLineEndings
			from: request peerName.
		^ self].	"return self means do serve the edited page
afterwards"
	request fields keys do: [:aTag |
		(aTag beginsWith: 'text-') ifTrue: [
			urlmap
				storeID: coreRef
				text: (request fields at: aTag)
withSqueakLineEndings
				insertAt: (aTag copyFrom: 6 to: aTag size).
	"string"
			^ self]].
	"oops, a new kind!!"
	Transcript show: 'Unknown data from client. '; show: request fields
printString; cr.! !

!SwikiAction methodsFor: 'URL processing' stamp: 'mjg 1/12/98 15:35'!
log: request
	| logfile |
	logfile _ FileStream fileNamed: name , '-log.txt'.
	logfile isNil
		ifTrue: [request log: 'Failed logging on ' , name]
		ifFalse:
			[logfile setToEnd.
			request peerName isNil
			ifTrue: [logfile nextPutAll: 'UnknownPeer' , '-' ,
				request url , '-' , Time now printString , '-' ,
				Date today printString.]
			ifFalse: [logfile nextPutAll: request peerName , '-' ,
				request url , '-' , Time now printString , '-' ,
				Date today printString.].
			logfile nextPut: Character cr.
			logfile close]! !

!SwikiAction methodsFor: 'URL processing' stamp: 'BJP 9/7/1998 00:55'!
pageURL: aPage
	"make the URL suited to aPage in this Action"
	^(self name),'.',aPage coreID! !

!SwikiAction methodsFor: 'URL processing' stamp: 'tk 9/16/1998 15:58'!
process: request
	"URLs are of the form:
	{swikiname} 		browse Front Page
	{swikiname}.{coreID} browse the page number coreID
	{swikiname}.{coreID}.edit  request to edit the page
	{swikiname}.{coreID}.versions show the last three versions of the page
	{swikiname}.{coreID}  {with a field named 'text'}  store an edited page
	{swikiname}.{coreID}.insert.{placeID}  request to insert text in a
specific place in a page
	{swikiname}.{coreID}  {with a field named 'text-placeID'}  store
text in a specific place
	-------
	{swikiname}.{coreID}.all  displays the page and all its references
	{swikiname}.searchresult  conducts the search and displays the result
	{swikiname}.recent  to bring up the recent changes list
	{swikiname}.{coreID}.searchresult  returns a search for references
to coreID's key
	{swikiname}.{picName}.gif   or .jpeg, .jpg, .jpe, .html (upper or
lower case) return
	the picture or static page stored in the {swikiname} folder."

	| coreRef pageRef command formattedPage theLast pvtPageRef htmlForUser |
	self log: request.
	theLast _ request message last asLowercase.
	theLast = 'gif' ifTrue: [^ self process: request MIMEtype: 'image/gif'].
	theLast = 'jpeg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'jpg' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'jpe' ifTrue: [^ self process: request MIMEtype: 'image/jpeg'].
	theLast = 'html' ifTrue: [^ self process: request MIMEtype: 'text/html'].
	request reply: PWS success;
		reply: PWS contentHTML.
	Transcript show: 'In process: ' , request message printString; cr.
	request message size < 2
		ifTrue: [coreRef _ '1']
		ifFalse: [coreRef _ request message at: 2].
	request fields ifNotNil: ["Are there input fields?"
			(self inputFrom: request) == #return ifTrue: [^ self]].
	coreRef = 'recent' ifTrue:
			[request reply: PWS crlf , ((self formatterFor: 'recent')
						format: urlmap recent).
			^ self].
	request reply: PWS crlf.
	"End of header.  Move this when we want to report more header"
	"At this point, coreRef is a page reference"
	pageRef _ urlmap atID: coreRef.
	request message size > 2 ifTrue:
			["SearchResult, All, Versions, or Edit"
			command _ request message at: 3.
			command = 'edit' ifTrue:
					[request reply: ((self formatterFor: 'edit') format: pageRef).
					pageRef noteEditRequest.
					^ self].
			command = 'versions' ifTrue:
					[request reply: ((self formatterFor: 'versions') format: pageRef).
					^self].
			command = 'insert' ifTrue:
					[pvtPageRef _ pageRef clone.
					pvtPageRef placeID: (request message at: 4).	"so <?request placeID?> can get it"
					htmlForUser _ ((self formatterFor: 'insert') format: pvtPageRef).
					htmlForUser size = 0 ifTrue: [
						self error: 'template file ''insert.html'' not found'].
					request reply: htmlForUser.
					pageRef noteEditRequest.
					^ self].
			command = 'searchresult' ifTrue:
					[request reply: ((self formatterFor: 'results')
						format: (urlmap searchFor: pageRef name)).
					^ self].
			command = 'all' ifTrue:
					[formattedPage _ urlmap allPagesFrom: pageRef for: request.
					request reply: ((self formatterFor: 'page') format: formattedPage).
					^ self].
			(request message at: 1) = (request message at: 2) ifTrue: [
				request reply: '<h1>Your original url has a slash after it.  Please remove it.</h1>'.
				request message: (request message copyFrom: 2 to: request message size).
				^ self process: request].	"(success and contentHTML will be sent twice!!)"
			Transcript show: 'Unknown command: ' , command; cr.
			^ self].
	"Just a browse"
	^ self browse: pageRef from: request! !

!SwikiAction methodsFor: 'URL processing' stamp: 'mdr 9/4/2000 10:57'!
process: request MIMEtype: imageGif
	"See if there is a .gif file on my disk of this name, and send it out."

	| fName |
	fName _ ServerAction serverDirectory, (request message at: 1), 
		(ServerAction pathSeparator), (request message at: 2).
	3 to: request message size do: [:part |
		fName _ fName, '.', (request message at: part)].
	Transcript show: fName; cr.
	(FileDirectory default fileExists: fName) 
		ifTrue: ["maybe send out content-length?"
			request reply: (PWS success),(PWS content: imageGif), PWS crlf.
			request reply: (FileStream readOnlyFileNamed: fName) contentsOfEntireFile]
		ifFalse: [
			request reply: ( 'HTTP/1.0 400 Bad Request', PWS crlfcrlf, 'file not found')].
! !

!SwikiAction methodsFor: 'URL processing' stamp: 'ls 4/18/98 18:09'!
smtlk: request
	"Return Smalltalk sourcecode.  URL =
machine:80/myswiki.smtlk.Point|at;  included are:  Point|at:
Point|Comment   Point|Hierarchy  Point|Definition   Point|class|x;y;  NOTE:
use ; instead of : in selector names!!!!!!"

	| classAndMethod set |

	classAndMethod _ request message atPin: 3.
	classAndMethod _
classAndMethod copyReplaceAll: '|' with: ' '.
	classAndMethod _
classAndMethod copyReplaceAll: ';' with: ':'.
	set _ LinkedMessageSet
messageList: (Array with: classAndMethod).

	request reply: PWS crlf,
((self formatterFor: 'smtlk') format: set).! !


!SwikiAction methodsFor: 'formatters' stamp: 'ls 5/5/98 17:20'!
clearFormatterCache
	"remove all formatters"
	formatters _ nil.! !

!SwikiAction methodsFor: 'formatters' stamp: 'ls 5/7/98 22:04'!
formatterFor: formatterName
	"get the formatter for the given name.
uses lazy initialization.  Could eventually check whether the on-disk file
has been updated."
	| fileName fileModTime |
	
	"first,
create the dictionary of formatters if it isn't already"
	formatters
== nil ifTrue: [
		formatters _ Dictionary new. ].


	"get the filename for the template source"
	fileName _
formatterName, '.html'.

	"get its modification time"
	fileModTime
_ ((FileDirectory on: ServerAction serverDirectory, source) entryAt:
fileName) at: 3.

	"create the formatter if necessary"

	((formatters includesKey: formatterName) not or: [

	((formatters at: formatterName) at: 2) < fileModTime ])

	ifTrue: [
		Transcript show: '(recompiling formatter ',
formatterName, ')'; cr.
		formatters at: formatterName put:
(Array with:
			(HTMLformatter forEvaluatingEmbedded: (self
fileContents: (source, formatterName, '.html')))

	with: fileModTime)
	].

	"return the formatter"

	^(formatters at: formatterName) at: 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SwikiAction class
	instanceVariableNames: ''!

!SwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:52'!
mapClass
	"The class of my pages"
	^ URLmap! !

!SwikiAction class methodsFor: 'initialization' stamp: 'tk 5/14/1998 18:22'!
pageClass
	"The class of my pages"
	^ SwikiPage! !

!SwikiAction class methodsFor: 'initialization' stamp: 'tk 2/3/98 15:45'!
restore: actionName from: filename
	"Obsolete.  For old format pages only!!!!!!  Get all the info about a Swiki from its folder."

	| action |
	action _ SwikiAction new.
	action name: actionName.
	action source: 'swiki:'.
	action restoreFrom: filename.
	action map pages do: [:each |
		each file: (ServerAction serverDirectory),actionName,(ServerAction
pathSeparator),
			((each file findTokens: (ServerAction pathSeparator)) last)].
	PWS link: actionName to: action.
! !

!SwikiAction class methodsFor: 'initialization' stamp: 'mjg 11/25/97 16:35'!
setUp
	self setUp: 'myswiki'
! !

!SwikiAction class methodsFor: 'initialization' stamp: 'BJP 9/9/1998 21:41'!
setUp: actionName
	"Set up a named Swiki"
	| action map page dir |
	action _ self new.
	map _ self mapClass new.	"URLmap or PURLmap"
	action formatter: (HTMLformatter new initialize).
	action formatter specialCharacter: $*.
	action map: map.
	action name: actionName.
	action source: 'swiki',(ServerAction pathSeparator).
	map action: action.
	map pages: (Dictionary new).
	map directory: actionName.
	dir _ FileDirectory on: (ServerAction serverDirectory).
	(dir directoryNames includes: actionName) ifFalse: [
		^ self inform: 'You need to create a folder in Server called ',
actionName].
		"A directory in the ServerDirectory for storing pages."
	page _ map newpage: actionName,': Front Page' from: 'Beginning'.
	page pageStatus: #standard.
	page text: (HTMLformatter evalEmbedded:
			((FileStream fileNamed: (ServerAction
serverDirectory),'swiki',
				(ServerAction pathSeparator),'FrontPage')
contentsOfEntireFile) with:
actionName).
	page _ map newpage: 'Formatting Rules' from: 'Beginning'.
	page pageStatus: #standard.
	page text: (HTMLformatter evalEmbedded:
			((FileStream fileNamed: (ServerAction
serverDirectory),'swiki',
				(ServerAction pathSeparator),'FormattingRules')
contentsOfEntireFile)
with: actionName).
	PWS link: actionName to: action.
	^action
! !
Object subclass: #SwikiPage
	instanceVariableNames: 'url map formatted address file date time coreID name user editReqDate editReqTime temp pageStatus '
	classVariableNames: 'OutputFormat '
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
address
	"Answer the receiver's 'address'."

	^address! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
address: anObject
	"Set the receiver's instance variable 'address' to be anObject."

	address := anObject! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/3/1998 21:32'!
by
	| who |
	who _ user class == String
					ifFalse: [address]
					ifTrue: [user].
		who ifNil: [who _ 'unknown user'].
	^who.
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 9/10/1998 15:26'!
by: who

	self address: who.! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
coreID
	"Answer the receiver's 'coreID'."

	^coreID! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
coreID: anObject
	"Set the receiver's instance variable 'coreID' to be anObject."

	coreID := anObject! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
date
	"Answer the receiver's 'date'."

	^date! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/8/1998 18:34'!
date: anObject
	"Set the receiver's instance variable 'date' to be anObject."

		(anObject isKindOf: String)
			ifTrue: [date _ anObject asDate]
			ifFalse: [date := anObject]! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
file
	"Answer the receiver's 'file'."

	^file! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
file: anObject
	"Set the receiver's instance variable 'file' to be anObject."

	file := anObject! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:01'!
formatted
	^formatted
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:01'!
formatted: aString
	"Never set this except on a copy"
	formatted _ aString
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 4/29/98 10:26'!
lastEditTime
	"Describe when this page was edited last"
	| timeOfAccept tt timeOfReq |
	timeOfAccept _ (tt _ self timeOfAccept) asSeconds + date asSeconds.
	editReqDate ifNotNil: [
		timeOfReq _ editReqTime asSeconds + editReqDate asSeconds.
		(timeOfAccept < timeOfReq) ifTrue: [
			(Time now asSeconds + Date today asSeconds - (60*60)) < timeOfReq ifTrue: [
				^ '<b>Someone is editing this page!!</b>  They started ', 
					(Time now subtractTime: editReqTime) intervalString, ' ago']]].
	^ 'Last edited: ', date printString, ' at ', tt printString
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
map
	"Answer the receiver's 'map'."

	^map! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
map: anObject
	"Set the receiver's instance variable 'map' to be anObject."

	map := anObject! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
name
	"Answer the receiver's 'name'."

	^name! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 9/1/1998 09:58'!
name: anObject
	"Set the receiver's instance variable 'name' to be anObject."

	name := anObject.
	^''! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 1/27/98 18:44'!
noteEditRequest
	editReqDate _ Date today.
	editReqTime _ Time now.! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/10/1998 14:14'!
outputFormat
	^self class outputFormat! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/8/1998 19:41'!
pageStatus
	"The basic stati ;) are #new and #standard. If the pageStatus is nil,
we make make the page #standard, as that is the old behavior. You could add
other types to get e.g., different kinds of URLs, or to exclude pages from
a search, or alter the formatter, or..."
	pageStatus ifNil: [pageStatus _ #standard].
	^pageStatus! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/3/1998 13:55'!
pageStatus: aSymbol
	"While I'm trying to be careful about default behavior if the type is
unknown, one should still be careful to check all the places that pageType
is used."

	pageStatus _ aSymbol.! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 7/12/1998 22:50'!
placeID
	"Temporarily hold onto the placeID value.  For putting into the
FORM in insert.html"
	^ temp! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 7/12/1998 22:50'!
placeID: idNum
	"Temporarily hold onto the placeID value.  For putting into the
FORM in insert.html"
	temp _ idNum! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 2/3/98 18:13'!
text

	| theFile theText real bb gotTo |
	theFile _ FileStream oldFileNamed: file.
	theFile setToEnd.
	bb _ self backupAChunk: theFile.
	bb _ bb - 7.		"before the back:"
	"Be careful about occurances of 'text:' in the name or other field"
	[theFile match: 'text:'.
	gotTo _ theFile position.
	theFile upTo: $'; skip: -1.	
	theText _ theFile nextDelimited: $'.
	real _ (ReadStream on: theText) nextDelimited: $!!.	"Remove double !!"
	theFile skipSeparators.
	theFile position >= bb] whileFalse: [theFile position: gotTo].

	theFile close.
	^ real! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 7/13/1998 12:37'!
text: aString
	"Add onto the end of the file"

	| this aFile start end realString |
	realString _ self uniqueInsertionPoints: aString.
	this _ String streamContents: [:ss |
		ss nextPutAll: self chunk1.
		realString storeOn: ss.
		ss nextPutAll: ' back: '].
	(aFile _ FileStream fileNamed: file) setToEnd.
	start _ aFile position.
	aFile nextChunkPut: this; skip: -1.	"undo the !! at end"
	end _ aFile position.
	aFile nextPutAll: (end - start) printString; nextPut: $!!; cr; close.
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 10/5/1998 16:22'!
textVersion: steps
	"One step back gets the original"
	| theFile theText real bb gotTo count |
	theFile _ FileStream oldFileNamed: file.
	theFile setToEnd.
	bb _ 1. count _ steps.
	[count > 0 and: [bb > 0]] whileTrue: [
		bb _ self backupAChunk: theFile. count := count - 1.].
	bb = 0 ifTrue: ["Went back beyond beginning"
		theFile close.
		^'<Too Far Back>'.].
	bb _ bb - 7.		"before the back:"
	"Be careful about occurances of 'text:' in the name or other field"
	[theFile match: 'text:'.
	gotTo _ theFile position.
	theFile upTo: $'; skip: -1.
	theText _ theFile nextDelimited: $'.
	real _ (ReadStream on: theText) nextDelimited: $!!.	"Remove double !!"
	theFile skipSeparators.
	theFile position >= bb] whileFalse: [theFile position: gotTo].

	theFile close.
	^ real! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 8/28/1998 19:41'!
time
	"Answer the receiver's 'time'."

	^time! !

!SwikiPage methodsFor: 'accessing' stamp: 'BJP 9/8/1998 18:29'!
time: anObject
	"Set the receiver's instance variable 'time' to be anObject."
	(anObject isKindOf: String)
		ifTrue: [time _ anObject asTime]
		ifFalse: [time := anObject]! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 4/29/98 10:26'!
timeOfAccept
	"return the Time when the text was written on the file"

	| theFile pp theReturn |
	theFile _ FileStream oldFileNamed: file.
	theFile setToEnd.
	pp _ self backupAChunk: theFile.
	pp _ pp - 5.		"before the back:"
	theFile upTo: $'; skip: -1.		"name"
	theFile nextDelimited: $'.
	theFile upTo: $'; skip: -1.		"date"
	theFile nextDelimited: $'.
	theFile upTo: $'; skip: -1.		"time"
	theReturn := (theFile nextDelimited: $') asTime.
	theFile close.
	^theReturn
! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
url
	"Answer the receiver's 'url'."

	^url! !

!SwikiPage methodsFor: 'accessing' stamp: 'mjg 11/25/97 15:02'!
url: anObject
	"Set the receiver's instance variable 'url' to be anObject."

	url := anObject! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 1/27/98 18:28'!
user
	^ user! !

!SwikiPage methodsFor: 'accessing' stamp: 'tk 1/27/98 18:30'!
user: aString

	aString class == String 
		ifFalse: [user _ aString printString]
		ifTrue: [user _ aString]! !


!SwikiPage methodsFor: 'save & restore' stamp: 'mjg 8/28/1998 20:36'!
backupAChunk: aFile
	"We are positioned at the end of a chunk.  Read the size of this
chunk from its end.  Back up one chunk.  Return the position of the space
before the back number."

	| back pp aPiece isDigitFlag |
	aFile skip: -2.
	isDigitFlag _ false.
	[isDigitFlag] whileFalse:
	[aPiece := aFile next. aPiece isNil ifTrue: [^0].
	aPiece isDigit ifFalse: [aFile skip: -2] ifTrue: [isDigitFlag _
true].].
	"[aFile next isDigit] whileFalse: [aFile skip: -2]." "This was
Ted's elegant version.
									The
uglier one above is to be able to test backing up too far."
	aFile skip: -2.
	[pp _ aFile position + 1. aFile next isDigit] whileTrue: [
		aFile skip: -2].
	back  _ (aFile upTo: $!!) asNumber.
	aFile position: pp; skip: 0-back.
	^ pp "now positioned at the end"! !

!SwikiPage methodsFor: 'save & restore' stamp: 'BJP 9/7/1998 11:30'!
chunk1
	^self formatForOutput
	"| who |
	^ String streamContents: [:ss |
		ss nextPutAll: 'self name: '; nextPutAll: name printString;
		nextPutAll: ' date: '''; nextPutAll: date mmddyyyy.
		ss nextPutAll: ''' time: '''.  time print24: true on: ss.
		who _ user class == String ifFalse: [address] ifTrue: [user].
		who ifNil: [who _ 'unknown user'].
		ss nextPutAll: ''' by: '; nextPutAll: who printString.
		ss nextPutAll: ' text: ']"! !

!SwikiPage methodsFor: 'save & restore' stamp: 'tk 1/28/98 15:09'!
condenseChanges
	"Save only the most recent version of this page"

	| theFile recentChunk newFile |
	theFile _ FileStream oldFileNamed: file.
	theFile setToEnd.
	self backupAChunk: theFile.
	recentChunk _ theFile nextChunk.
	theFile close. 
	FileDirectory deleteFilePath: file.
	newFile _ FileStream newFileNamed: file.
	newFile nextChunkPut: recentChunk; cr; close.! !

!SwikiPage methodsFor: 'save & restore' stamp: 'BJP 9/10/1998 14:16'!
formatForOutput
	^ String streamContents: [:ss |
		ss nextPutAll: 'self '.
		self outputFormat do: [:block |
							ss nextPutAll:
(block value: self)
					"ifError: [:msg :rec |
							 ss nextPutAll:
'*** ', rec asString, ': ', msg
asString ]"].
		ss nextPutAll: 'text: '].

"		   nextPutAll: name printString;
		   nextPutAll: ' date: ''';
		   nextPutAll: date mmddyyyy.
		ss nextPutAll: ''' time: '''.
		     Time now print24: true on: ss.
		who _ user class == String
					ifFalse: [address]
					ifTrue: [user].
		who ifNil: [who _ 'unknown user'].
		ss nextPutAll: ''' by: ';
		   nextPutAll: who printString.
		ss nextPutAll: ' text: ']"! !

!SwikiPage methodsFor: 'save & restore' stamp: 'mjg 8/28/1998 20:15'!
fromFileNamed: filePath action: aSwikiAction
	"Fill in all parts of this page from the info in its file"

	| theFile |
	map _ aSwikiAction urlmap.
	file _ filePath.
	theFile _ FileStream oldFileNamed: file.
	coreID _ theFile localName.
	url _ aSwikiAction name, '.', coreID.
	self scanFrom: theFile.	"name, date"
! !

!SwikiPage methodsFor: 'save & restore' stamp: 'mjg 8/28/1998 19:43'!
name: pageName date: dateString time: timeString by: who text: theString
back: bytes
	"Record the name of this page during startup.  When reading the
page in order to serve it, this is NOT executed.  The text is read from the
file explicitly."

	name _ pageName.
	date _ dateString asDate.
	time _ timeString asTime.
	address _ who! !

!SwikiPage methodsFor: 'save & restore' stamp: 'tk 1/28/98 18:03'!
rollBack: aDate at: aTime
	"Roll back tthis page to a previous state.  This does not erase data, just moves an older version to the end."

	| theFile pp dd tt recentChunk page |
	theFile _ FileStream oldFileNamed: file.
	theFile setToEnd.
	[theFile position < 8 "beginning"] whileFalse: [
		self backupAChunk: theFile.
		pp _ theFile position.
		theFile upTo: $'; skip: -1.		"name"
		theFile nextDelimited: $'.
		theFile upTo: $'; skip: -1.		"date"
		dd _ (theFile nextDelimited: $') asDate.
		theFile upTo: $'; skip: -1.		"time"
		tt _ theFile nextDelimited: $'.
		theFile position: pp.
		(dd < aDate) | ((dd = aDate) & (tt asTime < aTime)) ifTrue: [
			recentChunk _ theFile nextChunk.
			theFile setToEnd.
			theFile nextChunkPut: recentChunk; cr; close.
			date _ dd.	"That's my date now"
			^ self]].
	"none that early, store out a blank page"
	theFile close.
	page _ map
		storeID: coreID
		text: 'blank text (but prevous versions do exist)'
		from: self peerName.
	page user: 'unknown user' "oldPage userID".
! !

!SwikiPage methodsFor: 'save & restore' stamp: 'mjg 2/9/98 11:27'!
scanFrom: aFile
	"Read my name off the file for this page.  Other pages contain a ref to me like *myName* "

	aFile setToEnd.
	self backupAChunk: aFile.
	"extract the name"
	Compiler evaluate: (aFile nextChunk) for: self logged: false.
	map at: name asLowercase put: self.
	aFile close.! !

!SwikiPage methodsFor: 'save & restore' stamp: 'BJP 9/8/1998 18:08'!
text: theString back: bytes
	"Record the name of this page during startup.  When reading the page in
order to serve it, this is NOT executed.  The text is read from the file
explicitly."

"Which means that you'd better not cascade text & back or you're royally
screwed ;) BJP"! !


!SwikiPage methodsFor: 'insertion points' stamp: 'tk 7/13/1998 13:33'!
unique: aTag in: aSet
	"If aTag is not in aSet, put it in and return aTag.  If it's there,
make up a new tag, insert it, and return it.  For keeping insertion points
in text unique, so can tell where to put incoming text."

	| base new |
	((aSet includes: aTag) not and: [aTag size > 0]) ifTrue: [aSet add:
aTag.  ^ aTag].
	base _ 0.
	[new _ (100 atRandom + base) printString.
		aSet includes: new] whileTrue:
			[base _ base + 50].
	aSet add: new.
	^ new! !

!SwikiPage methodsFor: 'insertion points' stamp: 'tk 7/14/1998 20:52'!
uniqueInsertionPoints: aString
	"Find all occurances of '*append here'.  Make them lower case.  If
they don't have a number after them, assign one.  Don't use the same number
twice in this page.  Place ID can actually be any string."

| sourceStream targetStream ids char pos inside rest |
sourceStream := ReadStream on: aString.
targetStream := WriteStream on: String new.
ids _ Set new.	"id numbers that have been used"
[sourceStream atEnd	] whileFalse: [
	targetStream nextPut: (char _ sourceStream next).
	char == $* ifTrue: [
		pos _ sourceStream position.
		inside _ sourceStream upTo: $*.
		(inside asLowercase beginsWith: 'append here')
			ifFalse: [sourceStream position: pos.	"ignore"
				((inside = '') and: [sourceStream atEnd
not]) ifTrue: [
					targetStream nextPut: (char _
sourceStream next)]]	"Honor **"
			ifTrue: ["See if it has a number"
				targetStream nextPutAll: 'append here '.
				rest _ inside copyFrom: (13 min: inside
size +1) to: inside size.
				targetStream nextPutAll: (self unique: rest
in: ids); nextPut: $*]]].
^ targetStream contents

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SwikiPage class
	instanceVariableNames: ''!

!SwikiPage class methodsFor: 'initialization' stamp: 'BJP 9/7/1998 12:23'!
initialize
	"SwikiPage initialize"

	OutputFormat _ OrderedCollection new.
	OutputFormat
		add: [:thePage | 'name: ', thePage name printString, '; '];
		add: [:thePage | 'date: ', thePage date mmddyyyy
printString, '; '];
		add: [:thePage | 'time: ''', thePage time asString, '''; '];
		add: [:thePage | 'by: ', thePage by printString, '; '];
		add: [:thePage | 'pageStatus: #', thePage pageStatus, '; ']";
		add: [:thePage | 'text: ']."! !


!SwikiPage class methodsFor: 'accessing' stamp: 'BJP 9/7/1998 11:32'!
outputFormat

	^OutputFormat! !
RWBinaryOrTextStream subclass: #SwikiPseudoFileStream
	instanceVariableNames: 'directoryUrl localName directory '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Kernel'!

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'!
directory

	^directory url! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:53'!
directory: x

	directory _ x! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'!
directoryObject

	^directory! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 15:00'!
directoryUrl

	^directory url! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
directoryUrl: x

	directoryUrl _ x! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 13:59'!
fileName

	^localName! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/17/2000 14:01'!
isTypeHTTP

	^true! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
localName

	^localName! !

!SwikiPseudoFileStream methodsFor: 'as yet unclassified' stamp: 'RAA 10/13/2000 11:50'!
localName: x

	localName _ x! !
Model subclass: #Switch
	instanceVariableNames: 'on onAction offAction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Menus'!
!Switch commentStamp: '<historical>' prior: 0!
I represent a selection setting and actions to take depending on a change in the setting. An instance has three attributes: state, which is either on or off; on action; and off action. The on and off actions are blocks of code that execute whenever the instance changes state. I am typically used as a menu item in conjunction with a SwitchView and a SwitchController.
1/24/96 sw: made this a subclass of Model, for faster dependents handling!


!Switch methodsFor: 'state'!
clear
	"Set the state of the receiver to 'off'. If the state of the receiver was 
	previously 'on', then 'self change' is sent. The receiver's off action is 
	NOT executed."

	self isOn
		ifTrue: 
			[on _ false.
			self changed]! !

!Switch methodsFor: 'state'!
isOff
	"Answer whether the receiver is set off or not."

	^on not! !

!Switch methodsFor: 'state'!
isOn
	"Answer whether the receiver is set on or not."

	^on! !

!Switch methodsFor: 'state'!
set
	"Set the state of the receiver to 'on'. If the state of the receiver was 
	previously 'off', then 'self change' is sent. The receiver's on action is 
	NOT executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed]! !

!Switch methodsFor: 'state'!
switch
	"Change the state of the receiver from 'on' to 'off' or from 'off' to 'on' (see 
	Switch|turnOn, Switch|turnOff)."

	self isOn
		ifTrue: [self turnOff]
		ifFalse: [self turnOn]! !

!Switch methodsFor: 'state'!
turnOff
	"Set the state of the receiver to 'off'. If the state of the receiver was 
	previously 'on', then 'self change' is sent and the receiver's off action is 
	executed."

	self isOn
		ifTrue: 
			[on _ false.
			self changed.
			self doAction: offAction]! !

!Switch methodsFor: 'state'!
turnOn
	"Set the state of the receiver to 'on'. If the state of the receiver was 
	previously 'off', then 'self change' is sent and the receiver's on action is 
	executed."

	self isOff
		ifTrue: 
			[on _ true.
			self changed.
			self doAction: onAction]! !


!Switch methodsFor: 'action'!
doAction: anAction 
	"Execute anAction if it is non-nil."

	anAction == nil ifFalse: [anAction value]! !

!Switch methodsFor: 'action'!
offAction: anAction 
	"Set the off action of the receiver to anAction."

	offAction _ anAction fixTemps! !

!Switch methodsFor: 'action'!
onAction: anAction 
	"Set the on action of the receiver to anAction."

	onAction _ anAction fixTemps! !


!Switch methodsFor: 'private'!
initializeOff

	on _ false. 
	onAction _ nil.
	offAction _ nil! !

!Switch methodsFor: 'private'!
initializeOn

	on _ true. 
	onAction _ nil.
	offAction _ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Switch class
	instanceVariableNames: ''!

!Switch class methodsFor: 'instance creation'!
new
	"Answer an instance of me such that the on and off actions are set to nil
	('no action'), and the state is set to 'off'."

	^self newOff! !

!Switch class methodsFor: 'instance creation'!
newOff
	"Answer an instance of me such that the on and off actions are set to nil 
	('no action'), and the state is set to 'off'."

	^super new initializeOff! !

!Switch class methodsFor: 'instance creation'!
newOn
	"Answer an instance of me such that the on and off actions are set to nil 
	('no action'), and the state is set to 'on'."

	^super new initializeOn! !
Object subclass: #Syllable
	instanceVariableNames: 'phonemes accent events '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!
!Syllable commentStamp: '<historical>' prior: 0!
My instances are syllables. They can carry a pitch accent: 'H*', 'L*', etc.!


!Syllable methodsFor: 'accessing' stamp: 'len 12/11/1999 13:03'!
accent
	^ accent! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/11/1999 13:04'!
accent: aString
	accent _ aString! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
accept: anObject
	anObject syllable: self! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/13/1999 02:39'!
events
	^ events ifNil: [events _ CompositeEvent new addAll: (self phonemes collect: [ :each | PhoneticEvent new phoneme: each; duration: 0.080]); yourself]! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 02:55'!
phonemes
	^ phonemes! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 02:55'!
phonemes: aCollection
	phonemes _ aCollection! !

!Syllable methodsFor: 'accessing' stamp: 'len 12/8/1999 02:54'!
stress
	self phonemes do: [ :each | each stress > 0 ifTrue: [^ each stress]].
	^ 0! !


!Syllable methodsFor: 'enumarating' stamp: 'len 12/13/1999 01:20'!
eventsDo: aBlock
	self events do: aBlock! !


!Syllable methodsFor: 'testing' stamp: 'len 12/8/1999 19:03'!
hasPrimaryStress
	^ self stress = 1! !

!Syllable methodsFor: 'testing' stamp: 'len 12/8/1999 19:03'!
hasSecondaryStress
	^ self stress = 2! !

!Syllable methodsFor: 'testing' stamp: 'len 12/11/1999 13:11'!
isAccented
	^ self accent notNil! !


!Syllable methodsFor: 'printing' stamp: 'len 12/8/1999 02:57'!
printOn: aStream
	| first |
	aStream nextPut: $[.
	first _ true.
	self phonemes do: [ :each |
		first ifFalse: [aStream space].
		aStream print: each.
		first _ false].
	aStream nextPut: $]! !
String variableByteSubclass: #Symbol
	instanceVariableNames: ''
	classVariableNames: 'SymbolTable '
	poolDictionaries: ''
	category: 'Collections-Text'!
!Symbol commentStamp: '<historical>' prior: 0!
I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.!


!Symbol methodsFor: 'accessing'!
at: anInteger put: anObject 
	"You cannot modify the receiver."

	self errorNoModification! !

!Symbol methodsFor: 'accessing' stamp: 'sma 2/5/2000 12:32'!
precedence
	"Answer the receiver's precedence, assuming it is a valid Smalltalk
	message selector or 0 otherwise.  The numbers are 1 for unary,
	2 for binary and 3 for keyword selectors."

	self size = 0 ifTrue: [^ 0].
	self first isLetter ifFalse: [^ 2].
	self last = $: ifTrue: [^ 3].
	^ 1! !

!Symbol methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart

	self errorNoModification! !


!Symbol methodsFor: 'comparing' stamp: 'di 4/11/2000 16:18'!
= another

	"Use == between two symbols..."
	self == another ifTrue: [^ true].  "Was == "
	another class == Symbol ifTrue: [^ false].  "Was not == "

	"Otherwise use string =..."
	^ super = another! !

!Symbol methodsFor: 'comparing' stamp: 'pm 9/23/97 09:36'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^map newHashFor: self! !


!Symbol methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'!
clone
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying'!
copy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying'!
shallowCopy
	"Answer with the receiver, because Symbols are unique."! !

!Symbol methodsFor: 'copying' stamp: 'tk 8/19/1998 16:05'!
veryDeepCopyWith: deepCopier
	"Return self.  I am immutable in the Morphic world.  Do not record me."! !


!Symbol methodsFor: 'converting'!
asString 
	"Refer to the comment in String|asString."

	| newString |
	newString _ String new: self size.
	1 to: self size do: [:index | newString at: index put: (self at: index)].
	^newString! !

!Symbol methodsFor: 'converting'!
asSymbol 
	"Refer to the comment in String|asSymbol."! !

!Symbol methodsFor: 'converting' stamp: 'sw 1/28/98 18:18'!
capitalized
	^ self asString capitalized asSymbol! !


!Symbol methodsFor: 'printing' stamp: 'sw 8/19/1999 11:30'!
isOrientedFill
	"Needs to be implemented here because symbols can occupy 'color' slots of morphs."

	^ false! !

!Symbol methodsFor: 'printing' stamp: 'di 4/25/2000 12:32'!
storeOn: aStream 

	aStream nextPut: $#.
	(Scanner isLiteralSymbol: self)
		ifTrue: [aStream nextPutAll: self]
		ifFalse: [super storeOn: aStream]! !


!Symbol methodsFor: 'system primitives' stamp: 'di 1/2/1999 17:00'!
flushCache
	"Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one.  This primitive must be called whenever a method is defined or removed.
	NOTE:  Only one of the two selective flush methods needs to be used.
	Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)."

	<primitive: 119>
! !


!Symbol methodsFor: 'private'!
errorNoModification

	self error: 'symbols can not be modified.'! !

!Symbol methodsFor: 'private'!
species

	^String! !

!Symbol methodsFor: 'private'!
string: aString

	1 to: aString size do: [:j | super at: j put: (aString at: j)].
	^self  ! !

!Symbol methodsFor: 'private'!
stringhash

	^super hash! !


!Symbol methodsFor: 'filter streaming' stamp: 'mpw 1/1/1901 00:20'!
byteEncode:aStream
	^aStream writeSymbol:self.
! !


!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:32'!
isInfix
	"Answer whether the receiver is an infix message selector."

	^ self precedence == 2! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'!
isKeyword
	"Answer whether the receiver is a message keyword."

	^ self precedence == 3! !

!Symbol methodsFor: 'testing' stamp: 'di 4/25/2000 12:32'!
isLiteral
	"Answer whether the receiver is a valid Smalltalk literal."

	^ true! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:13'!
isPvtSelector
	"Answer whether the receiver is a private message selector, that is,
	begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash."

	^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]! !

!Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'!
isUnary
	"Answer whether the receiver is an unary message selector."

	^ self precedence == 1! !


!Symbol methodsFor: 'user interface' stamp: 'sma 11/12/2000 11:46'!
asExplorerString
	^ self printString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Symbol class
	instanceVariableNames: ''!

!Symbol class methodsFor: 'access' stamp: 'SqR 8/30/2000 13:14'!
selectorsContaining: aString
	"Answer a list of selectors that contain aString within them. Case-insensitive"

	| size selectorList ascii |

	selectorList _ OrderedCollection new.
	(size _ aString size) = 0 ifTrue: [^selectorList].

	aString size = 1 ifTrue:
		[
			ascii _ aString first asciiValue.
			ascii < 128 ifTrue: [selectorList add: (SymbolTable like: aString)]
		].

	aString first isLetter ifFalse:
		[
			aString size == 2 ifTrue: 
				[Symbol hasInterned: aString ifTrue:
					[:s | selectorList add: s]].
			^selectorList
		].

	selectorList _ selectorList copyFrom: 2 to: selectorList size.

	SymbolTable do:
		[:each |
			each size >= size ifTrue:
				[
					((each at: 1) isLowercase and:
						[((each findString: aString startingAt: 1 caseSensitive: false) > 0)])
							ifTrue: [selectorList add: each]
				]
		].

	^selectorList

"Symbol selectorsContaining: 'scon'"! !

!Symbol class methodsFor: 'access' stamp: 'SqR 8/30/2000 13:34'!
thatStarts: leadingCharacters skipping: skipSym
	"Answer a selector symbol that starts with leadingCharacters.
	Symbols beginning with a lower-case letter handled directly here.
	Ignore case after first char.
	If skipSym is not nil, it is a previous answer; start searching after it.
	If no symbols are found, answer nil.
	Used by Alt-q (Command-q) routines"

	| size firstMatch key |

	size _ leadingCharacters size.
	size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]].

	firstMatch _ leadingCharacters at: 1.
	size > 1 ifTrue: [key _ leadingCharacters copyFrom: 2 to: size].

	SymbolTable do:
		[:each |
			each size >= size ifTrue:
				[
					((each at: 1) == firstMatch and:
						[key == nil or:
							[(each findString: key startingAt: 2 caseSensitive: false) = 2]])
								ifTrue: [^each]
				]
		] after: skipSym.

	^nil

"Symbol thatStarts: 'sf' skipping: nil"
"Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:"
"Symbol thatStarts: 'candidate' skipping: nil"
! !


!Symbol class methodsFor: 'class initialization' stamp: 'RAA 12/17/2000 18:05'!
compactSymbolTable
	"Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)"

	| oldSize |

	Smalltalk garbageCollect.
	oldSize _ SymbolTable array size.
	SymbolTable growTo: SymbolTable size * 4 // 3 + 100.
	^oldSize printString,'  ',(oldSize - SymbolTable array size) printString, ' slot(s) reclaimed'! !

!Symbol class methodsFor: 'class initialization' stamp: 'SqR 8/23/2000 16:15'!
initialize
	"Symbol initialize"

	SymbolTable _ WeakSet withAll: self allInstances! !

!Symbol class methodsFor: 'class initialization' stamp: 'SqR 8/30/2000 17:01'!
useHardSymbolTable
	SymbolTable _ Set withAll: self allInstances! !

!Symbol class methodsFor: 'class initialization' stamp: 'SqR 8/30/2000 17:00'!
useWeakSymbolTable
	self initialize! !


!Symbol class methodsFor: 'instance creation' stamp: 'SqR 8/23/2000 16:22'!
intern: aStringOrSymbol
	^(SymbolTable like: aStringOrSymbol)
		ifNil:
			[
				SymbolTable add:
					((aStringOrSymbol isKindOf: Symbol)
						ifTrue: [aStringOrSymbol]
						ifFalse: [(self new: aStringOrSymbol size) string: aStringOrSymbol])
			]! !

!Symbol class methodsFor: 'instance creation'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ (aCollection as: String) asSymbol

"	Symbol newFrom: {$P. $e. $n}
	{$P. $e. $n} as: Symbol
"! !

!Symbol class methodsFor: 'instance creation' stamp: 'di 10/11/1999 00:02'!
readFrom: strm  "Symbol readFromString: '#abc'"

	strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #'].
	^ (Scanner new scan: strm) advance  "Just do what the code scanner does"! !


!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:33'!
fastRehash		"Symbol fastRehash"
	"Rebuild the hash table, reclaiming unreferenced Symbols"

	| oldSize |

	oldSize _ SymbolTable size.
	Smalltalk garbageCollect.
	self rehash.
	^(oldSize - SymbolTable size) printString, ' symbols reclaimed'! !

!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:30'!
hasInterned: aString ifTrue: symBlock 
	"Answer with false if aString hasnt been interned (into a Symbol), 
	otherwise supply the symbol to symBlock and return true."

	| symbol |

	^(symbol _ SymbolTable like: aString)
		ifNil: [false]
		ifNotNil: [symBlock value: symbol. true]
! !

!Symbol class methodsFor: 'private' stamp: 'di 12/3/2000 09:21'!
possibleSelectorsFor: misspelled 
	"Answer an ordered collection of possible corrections
	for the misspelled selector in order of likelyhood"

	| numArgs candidates lookupString best binary short long first ss |
	lookupString _ misspelled asLowercase. "correct uppercase selectors to lowercase"
	numArgs _ lookupString numArgs.
	(numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0].
	first _ lookupString first.
	short _ lookupString size - (lookupString size // 4 max: 3) max: 2.
	long _ lookupString size + (lookupString size // 4 max: 3).

	"First assemble candidates for detailed scoring"
	candidates _ OrderedCollection new.
	SymbolTable do:
		[:s | (((ss _ s size) >= short	"not too short"
			and: [ss <= long			"not too long"
					or: [(s at: 1) = first]])	"well, any length OK if starts w/same letter"
			and: [s numArgs = numArgs])	"and numArgs is the same"
			ifTrue: [candidates add: s]].

	"Then further prune these by correctAgainst:"
	best _ lookupString correctAgainst: candidates.
	((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [
		binary _ misspelled, ':'.		"try for missing colon"
		Symbol hasInterned: binary ifTrue: [:him | best addFirst: him]].
	^ best! !

!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:32'!
rehash		"Symbol rehash"
	"Rebuild the hash table, reclaiming unreferenced Symbols."

	SymbolTable _ SymbolTable class withAll: self allInstances! !

!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:27'!
slowRehash		"Symbol slowRehash"
	"Rebuild the hash table, reclaiming unreferenced Symbols."

	^self fastRehash! !

!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:31'!
useArrayTables	"Symbol useArrayTables"
	"Use a non weak set for referencing the symbols"

	SymbolTable _ Set withAll: self allInstances! !

!Symbol class methodsFor: 'private' stamp: 'SqR 8/23/2000 16:31'!
useWeakArrayTables "Symbol useWeakArrayTables"
	"Use a weak set for referencing the symbols"

	self initialize! !

TileMorph subclass: #SymbolListTile
	instanceVariableNames: 'choices dataType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!SymbolListTile methodsFor: 'initialization' stamp: 'sw 10/30/2000 09:04'!
choices: choiceList dataType: aDataType
	"Initialize the receiver with the given choice-list and data type"

	choices _ choiceList.
	dataType _ aDataType.
	literal _ choiceList first! !


!SymbolListTile methodsFor: 'user interface' stamp: 'sw 10/24/2000 10:52'!
arrowAction: delta
	"Do what is appropriate when an arrow on the tile is pressed; delta will be +1 or -1"

	| index |
	owner ifNil: [^ self].

	literal ifNotNil:
		[(index _ choices indexOf: literal) > 0
			ifTrue:
				[self literal: (choices atWrap: index + delta).
				self labelMorph setBalloonText: (ScriptingSystem helpStringForOperator: literal).
				self acceptNewLiteral.
				self labelMorph informTarget]]! !

!SymbolListTile methodsFor: 'user interface' stamp: 'sw 10/24/2000 10:15'!
literal: anObject
	"Set the receiver's literal as indicated"

	literal _ anObject.
	self updateLiteralLabel.
	self labelMorph informTarget! !
Object subclass: #SyntaxAttribute
	instanceVariableNames: 'color emphasis attributeList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!SyntaxAttribute commentStamp: '<historical>' prior: 0!
Represents a color and possibly a style attribute to be applied to a syntactic element for pretty-printing.  The attributeList inst var is a cache.!


!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/17/1999 15:04'!
attributeList
	"Answer a list of text attributes that characterize the receiver"
	attributeList ifNil:
		[attributeList _ OrderedCollection new: 2.
		color ifNotNil: [attributeList add: (TextColor color: color)].
		emphasis ifNotNil: [attributeList add: (TextEmphasis perform: emphasis)]].
	^ attributeList! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'!
color

	^ color! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:21'!
color: aTextColor
	color _ aTextColor.
	attributeList _ nil! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'!
emphasis

	^ emphasis! !

!SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:22'!
emphasis: aTextEmphasis
	emphasis _ aTextEmphasis.
	attributeList _ nil! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxAttribute class
	instanceVariableNames: ''!

!SyntaxAttribute class methodsFor: 'as yet unclassified' stamp: 'sw 11/16/1999 12:01'!
color: aColor emphasis: anEmphasis
	^ self new color: aColor; emphasis: anEmphasis; yourself! !
StringHolder subclass: #SyntaxError
	instanceVariableNames: 'class selector category debugger doitFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!SyntaxError commentStamp: '<historical>' prior: 0!
I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error.

The user may fix the error and accept the method to continue the fileIn.
!


!SyntaxError methodsFor: 'initialization' stamp: 'jm 5/3/1998 14:36'!
category: aSymbol
	"Record the message category of method being compiled. This is used when the user corrects the error and accepts."

	category _ aSymbol.
! !

!SyntaxError methodsFor: 'initialization' stamp: 'tk 5/6/1999 13:28'!
setClass: aClass code: aString debugger: aDebugger doitFlag: flag

	| types printables badChar |
	class _ aClass.
	debugger _ aDebugger.
	selector _ aClass parserClass new parseSelector: aString.
	types _ Scanner classPool at: #TypeTable.	"dictionary"
	printables _ '!!@#$%&*-_=+<>{}?/\,¥£¢¤¦»¼ÐÑÒÔÓÕÉò¾òøùÀÇÈ`~`' asSet.
	badChar _ aString detect: [:aChar | (types at: aChar asciiValue) == #xBinary and: [
			(printables includes: aChar) not]] ifNone: [nil].
	contents _ badChar 
		ifNil: [aString]
		ifNotNil: ['<<<This string contains a character (ascii value ', 
			badChar asciiValue printString,
			') that is not normally used in code>>> ', aString].
	category ifNil: [category _ aClass organization categoryOfElement: selector].
	category ifNil: [category _ ClassOrganizer default].
	doitFlag _ flag! !


!SyntaxError methodsFor: 'message list' stamp: 'tk 4/19/1999 08:08'!
list
	"Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."

	selector ifNil: [^ Array with: (class name, '  ', category, '  ', '<none>')].
	^ Array with: (class name, '  ', category, '  ', selector)
! !

!SyntaxError methodsFor: 'message list' stamp: 'jm 5/3/1998 13:48'!
listIndex
	"There is always exactly one element in my list and it is always selected."

	^ 1
! !


!SyntaxError methodsFor: 'menu' stamp: 'RAA 12/1/2000 14:24'!
debug
	"Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn."

	debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'.
	Smalltalk isMorphic ifFalse: [Processor terminateActive].
! !

!SyntaxError methodsFor: 'menu' stamp: 'jm 5/3/1998 14:22'!
listMenu: aMenu

	^ aMenu labels:
'proceed
debug calling process
browse full'
	lines: #()
	selections: #(proceed debug browseMethodFull)
! !

!SyntaxError methodsFor: 'menu' stamp: 'di 5/5/1998 00:06'!
proceed
	"The user has has edited and presumably fixed the syntax error and the filein can now proceed."

	debugger proceed: self topView.
! !


!SyntaxError methodsFor: 'other' stamp: 'di 10/9/1998 16:36'!
contents: aString notifying: aController
	"Compile the code in aString and notify aController of any errors. If there are no errors, then automatically proceed."

	doitFlag
	ifTrue: [Compiler new evaluate: aString in: nil to: nil
						notifying: aController ifFail: [^ false]]
	ifFalse: [(class compile: aString classified: category
						notifying: aController) ifNil: [^ false]].

	aController hasUnacceptedEdits: false.
	self proceed! !

!SyntaxError methodsFor: 'other' stamp: 'di 10/9/1998 16:51'!
notify: error at: location in: source
	"Open a syntax error view, inserting the given error message into the given source at the given location. This message is sent to the 'requestor' when the parser or compiler finds a syntax error."

	| aClass aString |
	aClass _ thisContext sender receiver encoder classEncoding.
	aString _
		source contents
			copyReplaceFrom: location
			to: location - 1
			with: error.
	self setClass: aClass
		code: aString
		debugger: (Debugger context: thisContext)
		doitFlag: false.
	self class open: self.
! !


!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:15'!
selectedClass
	"Answer the class in which the syntax error occurred."

	^ class
! !

!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:33'!
selectedClassOrMetaClass
	"Answer the class of the method being compiled."

	^ class
! !

!SyntaxError methodsFor: 'text menu support' stamp: 'jm 5/3/1998 14:17'!
selectedMessageName
	"Answer the selector of the method being compiled."

	^ selector
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxError class
	instanceVariableNames: ''!

!SyntaxError class methodsFor: 'instance creation' stamp: 'di 5/6/1998 20:58'!
buildMVCViewOn: aSyntaxError
	"Answer an MVC view on the given SyntaxError."

	| topView aListView aCodeView |
	topView _ StandardSystemView new
		model: aSyntaxError;
		label: 'Syntax Error';
		minimumSize: 380@220.

	aListView _ PluggableListView on: aSyntaxError
		list: #list
		selected: #listIndex
		changeSelected: nil
		menu: #listMenu:.
	aListView window: (0@0 extent: 380@20).
	topView addSubView: aListView.

	aCodeView _ PluggableTextView on: aSyntaxError
		text: #contents
		accept: #contents:notifying:
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	aCodeView window: (0@0 extent: 380@200).
	topView addSubView: aCodeView below: aListView.

	^ topView
! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'di 8/17/1998 10:22'!
buildMorphicViewOn: aSyntaxError
	"Answer an Morphic view on the given SyntaxError."
	| window |
	window _ (SystemWindow labelled: 'Syntax Error') model: aSyntaxError.

	window addMorph: (PluggableListMorph on: aSyntaxError list: #list
			selected: #listIndex changeSelected: nil menu: #listMenu:)
		frame: (0@0 corner: 1@0.15).

	window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents
			accept: #contents:notifying: readSelection: #contentsSelection
			menu: #codePaneMenu:shifted:)
		frame: (0@0.15 corner: 1@1).

	^ window openInWorldExtent: 380@220! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'di 10/9/1998 16:18'!
errorInClass: aClass withCode: codeString doitFlag: doit
	"Open a view whose model is a syntax error. The error occurred when trying to add the given method code to the given class."

	self open:
		(self new setClass: aClass
			code: codeString
			debugger: (Debugger context: thisContext)
			doitFlag: doit).
! !

!SyntaxError class methodsFor: 'instance creation' stamp: 'RAA 6/3/2000 09:12'!
open: aSyntaxError
	"Answer a standard system view whose model is an instance of me."
	| topView |
	<primitive: 19> "Simulation guard"
	Smalltalk isMorphic
		ifTrue:
			[self buildMorphicViewOn: aSyntaxError.
			CurrentProjectRefactoring newProcessIfUI: Processor activeProcess.
			^ Processor activeProcess suspend].
	topView _ self buildMVCViewOn: aSyntaxError.
	topView controller openNoTerminateDisplayAt: Display extent // 2.
	Cursor normal show.
	Processor activeProcess suspend.
! !
AlignmentMorph subclass: #SyntaxMorph
	instanceVariableNames: 'parseNode markerMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Tile Scriptors'!
!SyntaxMorph commentStamp: '<historical>' prior: 0!
A single class of morph that holds any piece of Smalltalk, and allows it to be a tile.  Tiles can be dragged in or out of a method. 

In the message list pane of a Browser, choose 'tile scriptor'.  Bring up a second one to steal parts from.  

Clicking multiple times selects enclosing phrases of code.  Dragging lets you take away a copy.  Any tile may be replaced by dropping on it.  Shift-click to edit the text of any tile.  Change variable and message names, but do not change the part-of-speech (objects to selector).

Each SyntaxMorph holds a ParseNode.  After editing, the parseNode is only good as a part-of-speech indicator.  Only the classes of the parseNodes are important.  It's state is not kept up to date with the tile edits (but maybe it should be).

The correspondence between SyntaxMorphs and parseNodes in the real parse tree is not one-to-one.  Several extra levels of SyntaxMorph were added as aligners to make the horizontal and vertical layout right.  These sometimes have nil for the parseNode.

When accept the method, we pass over the tree of SyntaxMorphs, gathering their printStrings and inserting punctuation.  See (SyntaxMorph>>printOn:indent:).  We send the result to the compiler.  (We do not use the parse tree we already have.)
!


!SyntaxMorph methodsFor: 'initialization' stamp: 'tk 1/15/2001 22:47'!
aJunkMethod: aMorph event: evt 
	"For the moment, you edited 1 have to drop it the right place. We do not 	look at enclosing morphs"
	| itNoun |
	
	itNoun  _  (aMorph isNoun ) .
	(self withAllOwnersDo: [:m |
		 (((m isSyntaxMorph ) and: [(m isBlockNode ).
			]  ) ifTrue: [((m stopStepping ) hideCaret ).
			]    ).
		] ).
	(1 abs  ; + itNoun  ).
	((6 + 5  ; - 6  ) abs  ; - 5  ).
	^  self 
	
	! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'di 1/31/2001 10:12'!
inAScrollPane

	| widget |

	widget _ TwoWayScrollPane new.
	widget extent: 10@10;
		borderWidth: 0.
	widget scroller addMorph: self.
	widget setScrollDeltas.
	^widget

! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'di 1/31/2001 10:14'!
openInWindow

	| window widget sel |
	sel _ ''.
	self firstSubmorph allMorphs do: [:rr | 
			(rr isKindOf: StringMorph) ifTrue: [sel _ sel, rr contents]].
	window _ (SystemWindow labelled: 'Tiles for ', self parsedInClass printString, '>>',sel).
	widget _ self inAScrollPane.
	widget color: Color paleOrange.
	window
		addMorph: widget
		frame: (0@0 extent: 1.0@1.0).
	window openInWorldExtent: (
		self extent + (20@40) min: (Display boundingBox extent * 0.8) rounded
	)

! !

!SyntaxMorph methodsFor: 'initialization' stamp: 'tk 1/19/2001 13:29'!
sample: arg1
"a comment"
| temp1 |
temp1 _ 5.
temp1 yourself.
temp1 min: arg1.! !


!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 1/26/2001 12:38'!
actualObject
	| sub |
	"Who is self in these tiles?  Usually a Player."

	(self nodeClassIs: VariableNode) ifTrue: [
		(sub _ self findA: StringMorph) ifNil: [^ nil].
		^ References at: sub contents asSymbol ifAbsent: [nil]].

	(self nodeClassIs: LiteralNode) ifTrue: [
		(sub _ self findA: StringMorph) ifNil: [^ nil].
		^ Compiler evaluate: sub contents
				for: nil
				logged: false].

	(sub _ self findA: SyntaxMorph) ifNil: [^ nil].
	^ sub actualObject	"receiver"! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/24/1999 12:14'!
color: aColorOrSymbol

	^super color: (self class translateColor: aColorOrSymbol)! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 10/20/2000 07:58'!
externalName

	parseNode ifNil: [^ 'Syntax -- (extra layer)'].
	^ self parseNode class printString! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/24/1999 13:08'!
getCurrentValue

	parseNode ifNil: [^nil].
	^parseNode currentValueIn: self hostContext! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/15/1999 16:23'!
parseNode
	
	^parseNode
		
	! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'RAA 8/15/1999 16:11'!
parseNode: x
	
	parseNode _ x
		
	! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'di 11/17/2000 08:07'!
parsedInClass

	^ self rootTile parseNode encoder classEncoding! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/15/2000 14:39'!
parsedInClass: x

	self parsedInClass == x ifFalse: [self error: 'inconsistent value']! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 1/13/2001 20:08'!
rename: newSelector
	| keywords mainSel list last |
	"Attempt to change the name as listed in my tiles.  Can change the number of argumtents.  MethodNode (SelectorNode (SelectorNode (string))) or MethodNode (SelectorNode (SelectorNode (string) TempVarNode() SelectorNode (string) TempVarNode()))"

	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile rename: newSelector  "always do at the root"].

	keywords _ newSelector keywords.
	mainSel _ self findA: SelectorNode.
	list _ mainSel submorphs select: [:mm | 
		mm isSyntaxMorph and: [mm parseNode class == SelectorNode]].
	1 to: (list size min: keywords size) do: [:ind |
		((list at: ind) findA: UpdatingStringMorph) contents: (keywords at: ind)].
	keywords size + 1 to: list size do: [:ind | "removing keywords"
		[last _ mainSel submorphs last.
		 (last isSyntaxMorph and: [last parseNode class == TempVariableNode])] whileFalse: [
				last delete].
		[last _ mainSel submorphs last.
		 (last isSyntaxMorph and: [last parseNode class == SelectorNode])] whileFalse: [
				last delete].	"the TempVariableNode and others"
		mainSel submorphs last delete.	"the SelectorNode"
		].
	list size + 1 to: keywords size do: [:ind | "adding keywords"
		"add a SelectorNode, add a spacer, add a TempVarNode"
		mainSel addToken: (keywords at: ind) type: #keyword1 
			on: (SelectorNode new key: (keywords at: ind) code: nil).
		mainSel addMorphBack: (mainSel transparentSpacerOfSize: 4@4).
		(TempVariableNode new name: 'arg', ind printString index: ind type: nil scope: nil)
			 asMorphicSyntaxIn: mainSel].! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 1/1/1904 00:33'!
selector
	"Find the SyntaxMorph that is a selectorNode within in me.  My parseNode is a MessageNode."

	^ submorphs detect: [:mm | 
			(mm isSyntaxMorph and: [mm nodeClassIs: SelectorNode])] 
		ifNone: [nil].! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/12/2000 14:42'!
userScriptSelector
	"user wrote this script"

	^ self valueOfProperty: #userScriptSelector! !

!SyntaxMorph methodsFor: 'accessing' stamp: 'tk 11/12/2000 14:41'!
userScriptSelector: sel
	"user wrote this script"

	self setProperty: #userScriptSelector toValue: sel.! !


!SyntaxMorph methodsFor: 'node types' stamp: 'tk 1/13/2001 20:41'!
findA: aClass
	| ans |
	"Allow finding on the class of the parseNode"

	(ans _ super findA: aClass) ifNotNil: [^ ans].
	submorphs do: [:ss | 
		ss isSyntaxMorph ifTrue: [
			ss parseNode class == aClass ifTrue: [^ ss]]].
	^ nil! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/17/2000 08:31'!
isBlockNode
	^ parseNode class == BlockNode! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 1/16/2001 12:08'!
isCascadePart 

	^ parseNode isMessage: nil receiver: [:r | r == nil] arguments: nil! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/17/2000 08:31'!
isMethodNode
	^ parseNode class == MethodNode! !

!SyntaxMorph methodsFor: 'node types' stamp: 'tk 1/15/2001 11:04'!
isNoun
	"Consider these to be nouns:  TempVariableNode, LiteralNode, VariableNode, (MessageNode or CascadeNode with receiver), AssignmentNode"

	(#(TempVariableNode LiteralNode VariableNode AssignmentNode) includes:
		(parseNode class name)) ifTrue: [^ true].

	(self nodeClassIs: MessageNode) ifTrue: [^ parseNode receiver notNil].
	(self nodeClassIs: CascadeNode) ifTrue: [^ parseNode receiver notNil].

	^ false! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/2/2000 13:25'!
isSyntaxMorph
	^ true! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/6/2000 15:26'!
nodeClassIs: aParseNodeClass
	"Test the class of my parseNode"

	^ parseNode class == aParseNodeClass! !

!SyntaxMorph methodsFor: 'node types' stamp: 'di 11/17/2000 08:55'!
rootTile
	^ self orOwnerSuchThat:
		[:m | m owner == nil or: [m owner isSyntaxMorph not]]! !


!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/8/2000 22:05'!
cursorBaseOffset

	^ 7@14
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/6/2000 16:20'!
handlesKeyboard: evt
	^ evt keyCharacter = Character backspace! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/17/2000 08:21'!
handlesMouseDown: evt

	evt yellowButtonPressed ifTrue: [^ true].
	parseNode == nil ifTrue: [^ false].
	owner isSyntaxMorph ifTrue:
		[(owner isMethodNode and: [self isBlockNode not])
			ifTrue: [^ false]].	"Can only take block out of a MethodNode"
	^ true! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 10/26/2000 16:58'!
handlesMouseOver: evt
	"Am I a tile that could be picked up?"

	^ true! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/6/2000 08:21'!
handlesMouseOverDragging: evt

	^ evt hand hasSubmorphs
		and: [evt hand firstSubmorph isSyntaxMorph]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/17/2000 08:21'!
keyStroke: evt
	"Handle a keystroke event."
	| spacer |
	evt keyCharacter = Character backspace ifTrue:
		[(owner notNil and: [owner isSyntaxMorph]) ifTrue:
			[owner isBlockNode ifTrue:
				["Delete a statement."
				(spacer _ self submorphAfter) class == AlignmentMorph
						ifTrue: [spacer delete].
				self delete].
			]].
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 12/14/2000 13:14'!
mouseDown: evt 
	| dup rootTile |
	evt yellowButtonPressed ifTrue: [^ self showMenu: evt].
	(rootTile _ self rootTile) isMethodNode ifTrue:
		[self currentSelectionDo:
			[:innerMorph :mouseDownLoc :outerMorph |
			(outerMorph notNil and: [self == innerMorph])
				ifTrue: ["Click on prior selection -- record click point."
						self setSelection: {self. evt cursorPoint. outerMorph}]
				ifFalse: ["A new selection sequence."
						self setSelection: {self. evt cursorPoint. nil}]].
		^ self].

	"Out in the world -- treat as a unit"
	rootTile isPartsDonor 
		ifTrue: [dup _ rootTile duplicate.
				dup setProperty: #beScript toValue: true]
		ifFalse: [dup _ rootTile].
	evt hand attachMorph: dup.
	^ dup align: dup topLeft with: evt hand position + self cursorBaseOffset.
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 12/11/2000 13:43'!
mouseEnter: evt
	"Highlight this level as a potential grab target"

"Transcript cr; print: self; show: ' enter'."
	self unhighlightOwner.
	self highlightForGrab: evt.
	evt hand newKeyboardFocus: self.
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 1/29/2001 16:14'!
mouseEnterDragging: evt
	"Highlight this level as a potential drop target"

"Transcript cr; print: self; show: ' enterDragging'."
	evt hand hasSubmorphs ifFalse: [^ self].  "Don't react to empty hand"
	self unhighlightOwner.
	self highlightForDrop: evt.

	self isBlockNode ifTrue:
		[(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
			ifNotNilDo: [:m | "Suspend outer block."
						m stopStepping; removeDropZones].
		self startStepping]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 12/11/2000 13:46'!
mouseLeave: evt
	"Move grab highlight back out a level"

"Transcript cr; print: self; show: ' leave'."
	self unhighlight.
	(owner ~~ nil and: [owner isSyntaxMorph])
		ifTrue: [owner highlightForGrab: evt].

! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 1/29/2001 16:13'!
mouseLeaveDragging: evt

"Transcript cr; print: self; show: ' leaveDragging'."
	self isBlockNode ifTrue:
		[self stopStepping; removeDropZones.
		(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
			ifNotNilDo: [:m | "Activate outer block."
						m startStepping]].

	"Move drop highlight back out a level"
	self unhighlight.
	(owner ~~ nil and: [owner isSyntaxMorph])
		ifTrue: [owner highlightForDrop: evt].

! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'tk 1/24/2001 12:30'!
mouseMove: evt
	| dup selection |
	owner isSyntaxMorph ifFalse: [^ self].
	self currentSelectionDo:
		[:innerMorph :mouseDownLoc :outerMorph |
		mouseDownLoc ifNotNil: [
			(evt cursorPoint dist: mouseDownLoc) > 4 ifTrue:
				["If drag 5 pixels, then tear off a copy of outer selection."
				selection _ outerMorph ifNil: [self].
				evt hand attachMorph: (dup _ selection duplicate).
				dup align: dup topLeft with: evt hand position + self cursorBaseOffset.
				self setSelection: nil.	"Why doesn't this deselect?"
				(self firstOwnerSuchThat: [:m | m isSyntaxMorph and: [m isBlockNode]])
					ifNotNilDo: [:m | "Activate enclosing block."
								m startStepping]]]].
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/17/2000 08:13'!
mouseUp: evt
	| newSel |
	self rootTile isMethodNode ifFalse: [^ self].
	self currentSelectionDo:
		[:innerMorph :mouseDownLoc :outerMorph |
		newSel _ outerMorph
			ifNil: [self "first click"]
			ifNotNil: [(outerMorph firstOwnerSuchThat:
							[:m | m isSyntaxMorph and: [m isSelectable]]) ifNil: [self]].
		newSel isMethodNode ifTrue: [^ self setSelection: nil].
		self setSelection: {self. nil. newSel}]
! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 1/30/2001 09:31'!
step
	self isBlockNode ifTrue: [self trackDropZones].
	super step! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 11/3/2000 08:03'!
stepTime

	^ 50! !

!SyntaxMorph methodsFor: 'event handling' stamp: 'di 1/30/2001 11:22'!
wantsSteps
	"Only step this morph if we explicitly send startStepping"

	^ false! !


!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 1/29/2001 16:32'!
acceptDroppingMorph: aMorph event: evt
	| itNoun old |
	"For the moment, you have to drop it the right place.  We do not look at enclosing morphs"
	"Two ways to do this:  Must always destroy old node, then drag in new one.
		Or, drop replaces what you drop on.  Nasty with blocks.  see wantsDroppedMorph:event:"
	"We know it is acceptable.  Just a matter of which case"

	itNoun _ aMorph isNoun.
	self withAllOwnersDo:
		[:m | (m isSyntaxMorph and: [m isBlockNode])
			ifTrue: [m stopStepping; removeDropZones]].
	self isBlockNode & itNoun
		ifTrue:
			[(aMorph nodeClassIs: TempVariableNode) ifTrue:
				["If I am a BlockNode, and it is a TempVariableNode, add it into list"
				^ (self addBlockArg: aMorph) ifFalse:
					["if already declared, start new line of code with it"
					self addToBlock: aMorph event: evt]]	
		ifFalse:
			[^ self addToBlock: aMorph event: evt]].

	"If I am a BlockNode and it is a noun add it as a new line"
	self isBlockNode ifTrue: [
		 (aMorph nodeClassIs: ReturnNode) ifTrue: [^ self addToBlock: aMorph event: evt]].

	"Later add args and keywords.  later allow comments to be dropped"

	"Can't put statement, literal, assignment, or cascade into left side of assignment"
	(owner isSyntaxMorph) ifTrue:
		[(owner nodeClassIs: AssignmentNode) ifTrue:
			[(owner submorphIndexOf: self) = 1 ifTrue:
				[((aMorph nodeClassIs: TempVariableNode)
				or: [aMorph nodeClassIs: VariableNode])  ifFalse: [ ^ self]]]].

	aMorph deselect.
	(old _ owner) replaceSubmorph: self by: aMorph.	"do the normal replacement"
	old cleanupAfterItDroppedOnMe.	"now owned by no one"
! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 1/29/2001 16:23'!
cleanupAfterItDroppedOnMe
	"A tile just dropped into me.  Clean up"

	self layoutChanged.  "** Isn't this already implied by the addMorph: ?"
	"Auto-accept on drop if in a scriptor"
	self acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'tk 11/12/2000 16:32'!
justDroppedInto: aMorph event: evt
	aMorph isSyntaxMorph ifFalse:
		["Drop my topLeft at the tip of the cursor if not in a scriptor."
		self align: self topLeft with: self topLeft - self cursorBaseOffset].
	self removeProperty: #beScript.
	^ super justDroppedInto: aMorph event: evt! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 1/31/2001 09:56'!
morphToDropInPasteUp: aPasteUp
	"If property #beScript is true, create a scriptor around me."

	| actualObject itsSelector aScriptor adjustment handy tw blk |
	self flag: #noteToTed.  "I changed PhraseTileMorph's version of this method to eliminate the flagshipInstance annoyance, and the below needs to be changed accordingly -- look at my method and notice diffs.  Besides eliminating the flagshipInstance test, one needs to be sure that the thing dropped is adjusted to reflect which instance of the uniclass is at hand.  sw 1/19/2001 02:30"

	(self valueOfProperty: #beScript ifAbsent: [false]) ifFalse: [^ self].
	self removeProperty: #beScript.

	(actualObject _ self actualObject) ifNil: [^ self].
	actualObject assureUniClass.

	itsSelector _ self userScriptSelector.
	aScriptor _ itsSelector isEmptyOrNil
		ifFalse:
			[adjustment _ 0@0.
			actualObject scriptEditorFor: itsSelector]
		ifTrue:
			["It's a system-defined selector; construct an anonymous scriptor around it"
			adjustment _ 60 @ 20.
			actualObject newScriptorAround: self].

	handy _ aPasteUp primaryHand.
	aScriptor ifNotNil: [
		aScriptor position: handy position - adjustment.
		aPasteUp addMorphFront: aScriptor.	"do this early so can find World"
		(tw _ aScriptor findA: TwoWayScrollPane) ifNil: [
			aScriptor useNewTiles.
			itsSelector ifNil: ["blank script"
				tw _ aScriptor findA: TwoWayScrollPane.
				blk _ tw scroller firstSubmorph "MethodNode" lastSubmorph "BlockNode".
				blk addMorphFront: self.
				"self position: self topLeft + (7@14)"]]].
	aScriptor showSourceInScriptor.  "**This destroys most of the work done before**"
	aScriptor hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellPositioning: #topLeft.
	(aScriptor isKindOf: ScriptEditorMorph) ifTrue:
		[aScriptor playerScripted expungeEmptyUnRenamedScripts].
	^ aScriptor ifNil: [self]
! !

!SyntaxMorph methodsFor: 'dropping/grabbing' stamp: 'di 11/17/2000 08:26'!
wantsDroppedMorph: aMorph event: evt
	"For the moment, you have to drop it the right place.  We do not look at enclosing morphs"
	"Two ways to do this:  Must always destroy old node, then drag in new one.
		Or, drop replaces what you drop on.  Nasty with blocks."

	| meNoun itNoun |
	(aMorph isKindOf: SyntaxMorph) ifFalse: [^ false].

	"If nodes are of equal class, replace me with new one."
	(self nodeClassIs: MessageNode) ifFalse: [
		(self nodeClassIs: aMorph parseNode class) ifTrue: [^ true]].

	meNoun _ self isNoun.
	itNoun _ aMorph isNoun.

	"Consider these nouns to be equal:  TempVariableNode, LiteralNode, VariableNode, (MessageNode with receiver), CascadeNode, AssignmentNode"
	meNoun & itNoun ifTrue: [^ true].
	meNoun & aMorph isBlockNode ifTrue: [^ true].

	"If I am a BlockNode, and it is a TempVariableNode, add it into list"
	"If I am a BlockNode, and it is a noun, add it as a new line"
	self isBlockNode ifTrue:
		[itNoun ifTrue: [^ true].
		(aMorph nodeClassIs: ReturnNode) ifTrue:
			[^ (self submorphs
				detect: [:mm | ((mm isSyntaxMorph) and: [mm nodeClassIs: ReturnNode])]
				ifNone: [nil]) isNil]].	"none already in this block"
				"If I am a BlockNode, and it is a ReturnNode, add to end"

	(self isMethodNode) ifTrue: [^ false].	"Later add args and keywords"
		"Later allow comments to be dropped in"
		"Add MethodTemps by dropping into the main block"

	^ false "otherwise reject"
! !


!SyntaxMorph methodsFor: 'drawing' stamp: 'tk 1/24/2001 12:39'!
drawOn: aCanvas

	super drawOn: aCanvas.
	self isBlockNode ifTrue:
		[((owner respondsTo: #isMethodNode) and: [owner isMethodNode])
		ifTrue:
			[aCanvas fillRectangle: (self topLeft + (0@-1) extent: self width@1) color: Color gray]
		ifFalse:
			[aCanvas fillRectangle: (self topLeft + (1@1) extent: 2@(self height-2)) color: Color gray.
			aCanvas fillRectangle: (self topLeft + (1@1) extent: 4@1) color: Color gray.
			aCanvas fillRectangle: (self bottomLeft + (1@-1) extent: 4@1) color: Color gray].
		]! !


!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 12/13/2000 15:25'!
borderColor: colorOrSymbolOrNil

	borderColor = colorOrSymbolOrNil ifFalse: [
		borderColor _ colorOrSymbolOrNil.
		self bounds area < 40000
			ifTrue: [self invalidRect: self bounds]
			ifFalse: [(self bounds areasOutside: (self bounds insetBy: self borderWidth))
						do: [:r | self invalidRect: r]]].
! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/5/2000 07:26'!
dropColor
	^ Color green darker! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/5/2000 07:26'!
grabColor
	^ Color paleOrange mixed: 0.5 with: Color brown! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/6/2000 09:22'!
highlightForDrop: evt

	(self wantsDroppedMorph: evt hand firstSubmorph event: evt)
		ifTrue: [self borderColor: self dropColor].! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/6/2000 09:22'!
highlightForGrab: evt

	self borderColor: self grabColor.! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/13/2000 21:12'!
stdBorderColor 

	"several choices of how to do the border"
	self class noTileColor
		ifTrue: [^ "color" Color transparent]
		ifFalse: [^ "color darker" Color transparent]! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/15/2000 22:47'!
unhighlight

	self currentSelectionDo:
		[:innerMorph :mouseDownLoc :outerMorph |
		(self == outerMorph or: [owner notNil and: [owner isSyntaxMorph not]])
			ifTrue: [self borderColor: #raised]
			ifFalse: [self borderColor: self stdBorderColor]]! !

!SyntaxMorph methodsFor: 'highlighting' stamp: 'di 11/6/2000 12:24'!
unhighlightOwner
	"Unhighlight my owner"

	(owner ~~ nil and: [owner isSyntaxMorph])
		ifTrue: [owner unhighlight]! !


!SyntaxMorph methodsFor: 'selection' stamp: 'di 11/17/2000 08:10'!
currentSelectionDo: blockForSelection
	| rootTile |
	(rootTile _ self rootTile) isMethodNode ifFalse:
		 [^ blockForSelection value: nil value: nil value: nil].
	rootTile valueOfProperty: #selectionSpec ifPresentDo:
		[:selectionSpec | ^ blockForSelection
							value: selectionSpec first
							value: selectionSpec second
							value: selectionSpec third].
	^ blockForSelection value: nil value: nil value: nil! !

!SyntaxMorph methodsFor: 'selection' stamp: 'di 12/13/2000 13:04'!
deselect
	self allMorphsDo:
		[:m | m isSyntaxMorph ifTrue: [m color: Color transparent; borderColor: Color transparent]].

	"Note following is wasteful because we do a deselect before each select, and it is often the same morph."
	self deletePopup! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 1/17/2001 15:07'!
isSelectable
	| ss |
	"Spacer morphs enclose other morphs with the same parseNode"
	self submorphs size > 1 ifTrue: [
		ss _ self submorphs second.
		ss isSyntaxMorph ifTrue: [
			ss parseNode == parseNode ifTrue: [
				^ self submorphs first class ~~ Morph]]].
		
"	(self nodeClassIs: SelectorNode) ifTrue: [^ false].
	(self nodeClassIs: KeyWordNode) ifTrue: [^ false].
"
	self isMethodNode ifTrue: [^ false].
	parseNode ifNil: [^ false].
	^ true! !

!SyntaxMorph methodsFor: 'selection' stamp: 'di 12/11/2000 13:44'!
select
	self deselect.
	self color: Color lightBrown.
	self borderColor: #raised.
	self offerPopUp.! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 1/24/2001 12:30'!
setSelection: newSpec
	"A selectionSpec is {Inner morph.  Where clicked.  Outer morph}.
	First mouseDown starts a selection (with outerMorph == nil).
	Dragging more than 4 pixels means to grab a copy of the current outer selection.
		The current selection is the outerMorph, or the inner if it is nil.
	Each mouseUp extends the selection to the next outer morph that is selectable.
		Except if this is the first click."
	| rootTile |
	(rootTile _ self rootTile) valueOfProperty: #selectionSpec ifPresentDo:
		[:oldSpec | oldSpec third ifNotNilDo: [:m | m deselect]].
	(newSpec == nil or: [newSpec third == nil and: [self isMethodNode]])
		ifTrue: [self deselect.
			^ rootTile removeProperty: #selectionSpec].

	"Select outer morph of the new selection"
	newSpec third == nil
		ifTrue: [self select  "first click down"]
		ifFalse: [newSpec third select  "subsequent clicks"].
	rootTile setProperty: #selectionSpec toValue: newSpec! !

!SyntaxMorph methodsFor: 'selection' stamp: 'tk 12/1/2000 15:42'!
wantsKeyboardFocusFor: aSubmorph
	| doEdit |
	"only let strings edit on shift-click.  Editing on ordinary click defeats the brown selection and tile dragging."

	doEdit _ self world primaryHand lastEvent shiftPressed.
	doEdit ifTrue: ["remove the arrows during editing"
		self valueOfProperty: #myPopup ifPresentDo: [:panel |
			panel delete. self removeProperty: #myPopup]].
	^ doEdit! !


!SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'di 1/29/2001 16:11'!
hideCaret
	"For backward compat -- remove when there are no senders"

	self removeDropZones
! !

!SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'di 1/30/2001 21:00'!
removeDropZones
	"Remove the insertion drop-zone morphs."

	self submorphsDo:
		[:mm | (mm isMemberOf: BorderedMorph) ifTrue: [mm delete]].
! !

!SyntaxMorph methodsFor: 'insertion drop zones' stamp: 'di 1/31/2001 09:14'!
trackDropZones
	| hand i localPt insertion insHt ii prevBot nxtHt d c1 c2 ht2 spacer1 spacer2 wid ht1 |
	hand _ self primaryHand.
	(hand lastEvent redButtonPressed & hand hasSubmorphs
		and: [(self hasOwner: hand) not]) ifFalse: [^ self].

	insertion _ hand firstSubmorph renderedMorph.
	insertion isNoun ifFalse: [^ self].
	localPt _ self globalPointToLocal: hand position.
	insHt _ insertion height.  "**just use standard line height here"
	self removeDropZones.  "Maybe first check if in right place, then just tweak heights."
	i _ (ii _ self indexOfMorphAbove: localPt) min: submorphs size-1.
	prevBot _ i <= 0 ifTrue: [(self innerBounds) top]
					ifFalse: [(self submorphs at: i) bottom].
	nxtHt _ (submorphs isEmpty
		ifTrue: [insertion]
		ifFalse: [self submorphs at: i+1]) height.
	d _ ii > i ifTrue: [nxtHt "for consistent behavior at bottom"]
			ifFalse: [0 max: (localPt y - prevBot min: nxtHt)].

	"Top and bottom spacer heights cause continuous motion..."
	c1 _ Color yellow lighter.  c2 _ Color transparent.
	ht2 _ d*insHt//nxtHt.  ht1 _ insHt - ht2.
	wid _ 100 min: owner width - 10.
	(spacer1 _ BorderedMorph newBounds: (0@0 extent: wid@ht1)
					color: (ht1 > (insHt//2) ifTrue: [c1] ifFalse: [c2]))
					borderWidth: 1; borderColor: spacer1 color.
	self privateAddMorph: spacer1 atIndex: (i+1 max: 1).
	(spacer2 _ BorderedMorph newBounds: (0@0 extent: wid@ht2)
					color: (ht2 > (insHt//2+1) ifTrue: [c1] ifFalse: [c2]))
					borderWidth: 1; borderColor: spacer2 color.
	self privateAddMorph: spacer2 atIndex: (i+3 min: submorphs size+1).
	self fullBounds.  "Force layout prior to testing for cursor containment"

	"Maintain the drop target highlight -- highlight spacer if hand is in it."
	{spacer1. spacer2} do:
		[:spacer | (spacer containsPoint: localPt) ifTrue:
			[spacer borderColor: self dropColor.
			self borderColor = self dropColor
				ifTrue: [self borderColor: self stdBorderColor]]].
	"If no submorph (incl spacers) highlighted, then re-highlight the block."
	((self wantsDroppedMorph: insertion event: hand lastEvent) and:
		[(self submorphs anySatisfy: [:m | m containsPoint: localPt]) not])
		ifTrue: [self borderColor: self dropColor]
! !


!SyntaxMorph methodsFor: 'layout' stamp: 'tk 11/28/2000 20:19'!
addBlockArg: aMorph
	"Add a temporary to a block or the method.  Return true if succeed"
	"(aMorph nodeClassIs: TempVariableNode) is known to be true."
	"***NOTE: This method should be combined with addTempVar:"

	| tempHolder tt var nn |
	owner isMethodNode ifTrue: [
		^ (self addTempVar: aMorph)].	"Node for them is not inside the block"
		"If exists, drop the temp in this block and let use extend it."
	tt _ self firstSubmorph.
	tempHolder _ tt firstSubmorph isSyntaxMorph 
				ifTrue: [(tt nodeClassIs: BlockArgsNode) 
							ifTrue: [tt] ifFalse: [nil]]
				ifFalse: [nil].
	nn _ aMorph parseNode key.	"name"

	tempHolder ifNil: ["make whole row"
		tempHolder _ self addRow: #blockarg1 on: (BlockArgsNode new).
		self addMorphFront: tempHolder.
		aMorph parseNode name: nn key: nn code: nil.
		var _ tempHolder addColumn: #tempVariable on: aMorph parseNode.
		var layoutInset: 1.
		var addMorphBack: (self addString: nn).
		self cleanupAfterItDroppedOnMe.
		^ true].

	tempHolder submorphsDo:
		[:m | "if present. caller adds the temp as a new line of code to be extended"
		m isSyntaxMorph and: [m parseNode key = nn ifTrue: [^ false]]].
		
	"If this variable is not present, add it"
	aMorph parseNode name: nn key: nn code: nil.
	tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4).
	var _ tempHolder addColumn: #tempVariable on: aMorph parseNode.
	var layoutInset: 1.
	var addMorphBack: (StringMorph contents: nn).
	var cleanupAfterItDroppedOnMe.
	^ true
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'di 11/10/2000 12:53'!
addColumn: aColorOrSymbol on: aNode
	| col |
	self addMorphBack: (col _ self class column: aColorOrSymbol on: aNode).
	^ col
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'RAA 8/24/1999 12:12'!
addRow: aColorOrSymbol on: aNode

	| row |
	self addMorphBack: (row _ self class row: aColorOrSymbol on: aNode).
	^row
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'di 12/13/2000 14:22'!
addString: literalOrVarName
	| sMorph |
	"Create and return an UpdatingStringMorph containing the value.  Use an UpdatingStringMorph, so it can inform its owner when it has been edited."

	sMorph _ UpdatingStringMorph contents: literalOrVarName.
	sMorph target: self; putSelector: #acceptIgnoring:; useStringFormat.
	"keep the getSelector being nil"
	^ sMorph! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 11/28/2000 20:21'!
addTempVar: aMorph 
	"know we are a block inside a MethodNode" 
	"(aMorph nodeClassIs: TempVariableNode) is known to be true."
	| tempHolder ii tt var nn |
	tempHolder _ (ii _ owner submorphIndexOf: self) = 1
				ifFalse: [tt _ owner submorphs at: ii - 1.
						(tt isSyntaxMorph and: [tt nodeClassIs: MethodTempsNode])
					 		ifTrue: [tt] ifFalse: [nil]]
				ifTrue: [nil].
	nn _ aMorph parseNode key.	"name"

	tempHolder ifNil: [
		tempHolder _ owner addRow: #tempVariable on: MethodTempsNode new.
		owner addMorph: tempHolder inFrontOf: self.
		aMorph parseNode name: nn key: nn code: nil.
		aMorph parseNode asMorphicSyntaxIn: tempHolder.
		tempHolder cleanupAfterItDroppedOnMe.
		^ true].

	tempHolder submorphsDo:
		[:m | m isSyntaxMorph and: [m parseNode key = nn ifTrue: [^ false]]].
	aMorph parseNode name: nn key: nn code: nil.
	tempHolder addMorphBack: (tempHolder transparentSpacerOfSize: 4@4).
	var _ tempHolder addColumn: #tempVariable on: aMorph parseNode.
	var layoutInset: 1.
	var addMorphBack: (self addString: nn).
	var cleanupAfterItDroppedOnMe.
	^ true! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 11/28/2000 20:22'!
addTextRow: aStringLikeItem

	| row |
	(row _ self class row: #text on: nil) borderWidth: 1.
	row addMorph: (self addString: (aStringLikeItem copyWithout: Character cr)).
	self addMorphBack: row.
	^row! !

!SyntaxMorph methodsFor: 'layout' stamp: 'di 11/16/2000 11:21'!
addToBlock: aMorph event: evt
	"Insert a new line of code"

	| whereDropped dropBefore |
	whereDropped _ "self pointFromWorld:" evt cursorPoint.
	dropBefore _ self submorphs 
		detect: [:each | each isSyntaxMorph and: [whereDropped y < each center y]] 
		ifNone: [nil].
	(aMorph nodeClassIs: ReturnNode) ifTrue: [dropBefore _ nil].
		"Returns are always at the end. (Watch out for comments)"

	dropBefore 
		ifNil: [self addMorphBack: aMorph]
		ifNotNil: [self addMorph: aMorph inFrontOf: dropBefore].
	self cleanupAfterItDroppedOnMe.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 11/28/2000 20:22'!
addToken: aString type: aColorOrSymbol on: aNode

	^ (self addColumn: aColorOrSymbol on: aNode)
		layoutInset: 1;
		addMorphBack: (self addString: aString)
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 1/15/2001 11:15'!
foldMessage
	"I am a message whose receiver is wide, and whose message part is a column.
	Rearrange me so that the message part appears indented under the receiver part."
	| messageRow node2 |
	node2 _ parseNode copy receiver: nil.
	messageRow _ SyntaxMorph row: #keyword1 on: node2.
	messageRow addMorph: (self transparentSpacerOfSize: 20@10);
			addMorphBack: submorphs second.
	self listDirection: #topToBottom;
		wrapCentering: #topLeft;
		addMorphBack: messageRow.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 1/15/2001 11:15'!
foldMessageOneArg
	"I am a message that is wide, a row with receiver and a row with selector and arg.
	Rearrange me so that the message part appears indented under the receiver part."
	| messageRow node2 |
	node2 _ parseNode copy receiver: nil.
	messageRow _ SyntaxMorph row: #keyword1 on: node2.
	messageRow addMorph: (self transparentSpacerOfSize: 20@10);
			addMorphBack: submorphs second;
			addMorphBack: submorphs second.  "was the third"
	self listDirection: #topToBottom;
		wrapCentering: #topLeft;
		addMorphBack: messageRow.
! !

!SyntaxMorph methodsFor: 'layout' stamp: 'tk 1/26/2001 12:44'!
try
	"Evaluate me once"

	(parseNode class == MessageNode) | (parseNode class == LiteralNode) ifFalse: [^ self].
	^ Compiler evaluate: self decompile
				for: self actualObject
				logged: false.	"should do something to the player"! !

!SyntaxMorph methodsFor: 'layout' stamp: 'di 11/10/2000 23:52'!
unfoldMessage
	"I am a message whose message part is a column.
	Rearrange me so that the entire message is one row."
	| messageRow |
	messageRow _ self submorphs last.
	self privateRemoveMorph: messageRow.
	messageRow submorphs do: [:m | self addMorphBack: m].

! !


!SyntaxMorph methodsFor: 'printing' stamp: 'tk 10/22/2000 20:43'!
printOn: strm

	super printOn: strm.
	strm space; nextPutAll: parseNode class name.! !

!SyntaxMorph methodsFor: 'printing' stamp: 'tk 1/30/2001 13:45'!
printOn: strm indent: level
	| lev nodeClass parens cnt |
	"Tree walk and produce text of the code.  #ST80.  Just do it in one big ugly method."

	lev _ level.
	(nodeClass _ parseNode class) == BlockNode ifTrue: [
		owner isSyntaxMorph ifTrue: [
			owner isMethodNode ifFalse: [strm nextPut: $[.  lev _ lev+1]]].
				"normal block has []"
	nodeClass == VariableNode ifTrue: ["nil out any old association"
		parseNode key class == Association ifTrue: [
			parseNode name: (parseNode name) key: nil code: (parseNode code)]].
	(nodeClass == MessageNode or: [nodeClass == CascadeNode]) ifTrue: [
		parseNode receiver ifNotNil: [parens _ true.  strm nextPut: $( ]].
	"has a receiver"
	nodeClass == MethodTempsNode ifTrue: [strm nextPut: $|; space].
	cnt _ 0.
	submorphs do: [:sub |
		sub isSyntaxMorph ifTrue: [cnt _ cnt + 1.
			(nodeClass == CascadeNode "and: [sub isCascadePart]") ifTrue:
				[cnt > 2 ifTrue: [strm nextPutAll: '; ']].
			nodeClass == BlockArgsNode ifTrue: [strm nextPut: $:].
			sub printOn: strm indent: lev.	"<<<<### install the subnode"
			(nodeClass == BlockNode) & (sub parseNode class == BlockArgsNode) not	&
				(sub parseNode class == ReturnNode) not
					ifTrue: [strm nextPut: $.].
			(nodeClass == BlockNode) & (sub parseNode class == BlockArgsNode) not
				ifTrue: [strm crtab: lev]
				ifFalse: [self isMethodNode ifTrue: [strm crtab: lev] ifFalse: [strm space]].
			].
		(sub isKindOf: StringMorph) ifTrue: [strm nextPutAll: sub contents].
		"return indent for ifTrue: ifFalse:"].
	parens == true ifTrue: [strm nextPut: $) ].
	"has a receiver"
	nodeClass  == BlockNode ifTrue: [
		owner isSyntaxMorph ifTrue: [
			owner isMethodNode ifFalse: [strm nextPut: $] ]]].
				"normal block has []"
	nodeClass == BlockArgsNode ifTrue: [strm nextPut: $|; crtab: lev].
	nodeClass == MethodTempsNode ifTrue: [strm nextPut: $|; crtab: lev].
	nodeClass == MethodNode ifTrue: [
		strm contents last "ugh!!" == $. ifTrue: [strm skip: -1]].
	"erase last period"! !

!SyntaxMorph methodsFor: 'printing' stamp: 'di 11/13/2000 07:43'!
structure
	"Print my structure from inner to outer."
	^ String streamContents: [:s |
		self withAllOwnersDo:
			[:m | m isSyntaxMorph ifTrue:
				[s cr; print: m parseNode class.
				((m nodeClassIs: MessageNode) or: [m nodeClassIs: TileMessageNode]) ifTrue:
					[s space; nextPutAll: m parseNode selector key]]]]! !


!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 11/28/2000 19:55'!
changeSound: upDown
	| ind arg st soundChoices index it current |
	"move in the list of sounds.  Adjust arg tile after me"

	ind _ owner submorphs indexOf: self.
	arg _ owner submorphs atWrap: ind+1.
	arg isSyntaxMorph ifFalse: [^ self].
	st _ arg submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	soundChoices _ #('silence').  "default, if no SampledSound class"
	Smalltalk at: #SampledSound ifPresent:
		[:sampledSound | soundChoices _ sampledSound soundNames].
	current _ st contents copyFrom: 2 to: st contents size-1.	"remove string quotes"
	index _ soundChoices indexOf: current.
	index > 0 ifTrue:
		[st contents: (it _ soundChoices atWrap: index + upDown) printString.
		self playSoundNamed: it].
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 11/17/2000 15:01'!
colorPatch
	"Return a color patch button that lets the user choose a color and modifies the code"
	| msg cc patch ss |
	
	(self nodeClassIs: KeyWordNode) ifTrue: [
		msg _ self firstOwnerSuchThat: [:oo | 
			(oo isSyntaxMorph and: [oo nodeClassIs: MessageNode]) 
				ifTrue: [ss _ oo submorphs select: [:mm | mm isSyntaxMorph].
					ss size > 1 ifTrue: [ss second printString = 'r:g:b:']
							ifFalse: [false]]
				ifFalse: [false]]].
	"Later test for SelectorNode with a standard color name"
	(self nodeClassIs: VariableNode) ifTrue: [
		self printString = 'Color' ifTrue: [
			owner isSyntaxMorph ifTrue: [msg _ owner]]].

	msg ifNil: [^ nil].
	(cc _ msg try) class == Color ifFalse: [^ nil].
	patch _ RectangleMorph new color: cc; borderWidth: 1.
	patch on: #mouseDown send: #chooseColor to: msg.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 12/13/2000 13:05'!
deletePopup

	self valueOfProperty: #myPopup ifPresentDo:
		[:panel | panel delete. self removeProperty: #myPopup]! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 2/3/2001 02:52'!
event: evt arrow: arrowMorph upDown: delta

	| st aList index now want instVar |
	st _ submorphs detect: [:mm | mm isKindOf: StringMorph] ifNone: [^ self].
	(self nodeClassIs: LiteralNode) ifTrue: [ "+/- 1"
		st contents: (self decompile asNumber + delta) printString.
		^ self acceptSilently.	"maybe set parseNode's key"].
	(self nodeClassIs: VariableNode) ifTrue: [ "true/false"
		st contents: (self decompile asString = 'true') not printString.
		^ self acceptSilently.	"maybe set parseNode's key"].

	(self nodeClassIs: SelectorNode) ifTrue: [
		aList _ #(+ - * / // \\ min: max:).
		index _ aList indexOf: self decompile asString.
		index  > 0 ifTrue: [
			self setBalloonText:
				(ScriptingSystem helpStringForOperator: (aList atWrap: index + delta)).
			st contents: (aList atWrap: index + delta).
			^ self acceptSilently].

		aList _ #(= ~= > >= isDivisibleBy: < <=).
		index _ aList indexOf: self decompile asString.
		index  > 0 ifTrue: [
			self setBalloonText:
				(ScriptingSystem helpStringForOperator: (aList atWrap: index + delta)).
			st contents: (aList atWrap: index + 1).
			^ self acceptSilently].

		aList _ #(== ~~).
		index _ aList indexOf: self decompile asString.
		index  > 0 ifTrue: [
			self setBalloonText:
				(ScriptingSystem helpStringForOperator: (aList atWrap: index + delta)).
			st contents: (aList atWrap: index + delta).
			^ self acceptSilently].

		'beep:' = self decompile asString ifTrue: ["replace sound arg"
			self changeSound: delta.
			^ self acceptSilently].
		].
	(self nodeClassIs: SelectorNode) ifTrue: ["kinds of assignment"
		((now _ self decompile asString) beginsWith: 'set') ifTrue:
			["a setX: 3"
			want _ 1+delta.  instVar _ (now allButFirst: 3) allButLast].
		(now endsWith: 'IncreaseBy:') ifTrue: ["a xIncreaseBy: 3 a setX: (a getX +3)."
			want _ 2+delta.  instVar _ now allButLast: 11].
		(now endsWith: 'DecreaseBy:') ifTrue: ["a xDecreaseBy: 3 a setX: (a getX -3)."
			want _ 3+delta.  instVar _ now allButLast: 11].
		(now endsWith: 'MultiplyBy:') ifTrue: ["a xMultiplyBy: 3 a setX: (a getX *3)."
			want _ 4+delta.  instVar _ now allButLast: 11].
		want ifNil: [^ self].
		instVar _ instVar asLowercase.
		want _ #(1 2 3 4) atWrap: want.
		want = 1 ifTrue: [st contents: 'set', instVar capitalized, ':'].	"setter method is present"
		want = 2 ifTrue: [st contents: instVar, 'IncreaseBy:'].
			"notUnderstood will create the method if needed"
		want = 3 ifTrue: [st contents: instVar, 'DecreaseBy:'].
			"notUnderstood will create the method if needed"
		want = 4 ifTrue: [st contents: instVar, 'MultiplyBy:'].
			"notUnderstood will create the method if needed"

		^ self acceptSilently].

! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 12/13/2000 15:30'!
extend
	| messageNodeMorph first |
	"replace this arg with a new message like (arg + 1)."

	"Later do evaluation of self to see what type and offer right selector"
	self deselect.
	messageNodeMorph _ (MessageSend receiver: 1 selector: #+ arguments: #(1))
								asTilesIn: Player.
	owner replaceSubmorph: self by: messageNodeMorph.
	first _ messageNodeMorph submorphs detect: [:mm | mm isSyntaxMorph].
	messageNodeMorph replaceSubmorph: first by: self.
	self acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 11/17/2000 15:25'!
extendArrow
	"Return the extend arrow button.  It replaces the argument with a new message.
	I am a number or getter messageNode."
	| patch ok sel ss |
	
	ok _ false.
	(self nodeClassIs: LiteralNode) ifTrue: [
		[self decompile asString asNumber] ifError: [:msg :rcvr | ^ nil].
		ok _ true].
	(self nodeClassIs: MessageNode) ifTrue: [
		ss _ submorphs select: [:mm | mm isSyntaxMorph].
		ss size > 1 ifTrue: [
			(ss second nodeClassIs: SelectorNode) ifTrue: [
				((sel _ ss second decompile asString) beginsWith: 'get') ifTrue: [
					ok _ (sel atWrap: 4) isUppercase ]]]].	"a getter -- hope it is a number"

	ok ifFalse: [^ nil].
	patch _ (ImageMorph new image: (TileMorph classPool at: #SuffixPicture)).
	patch on: #mouseDown send: #extend to: self.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'tk 1/15/2001 11:02'!
offerPopUp
	"Put up a halo to allow user to change
		Literals (Integer, true),
		Selector (beep: sound, +,-,*,//,\\, r:g:b:, setX: incX: decX: for any X,),
		Variable (Color),
		not AssignmentNode (_ inc dec),
	Extend arrows on each literal, variable, and message, (block that is by itself).
	Retract arrows on each literal or variable, or message or block that is an argument.
	Any literal can be changed by Shift-clicking and typing."

	| panel any upDown retract extend colorPatch edge outside |
	(self hasProperty: #myPopup) ifTrue: [^ self].  "already has one"
	((outside _ self rootTile owner) isKindOf: AlignmentMorph) ifTrue: [^ self].
	  "can't put panel in right place"
	any _ false.
	(upDown _ self upDownArrows) ifNotNil: [any _ true].
	(retract _ self retractArrow) ifNotNil: [any _ true].
	(extend _ self extendArrow) ifNotNil: [any _ true].
	(colorPatch _ self colorPatch) ifNotNil: [any _ true].
	any ifFalse: [^ self].
	"Transcript cr; print: parseNode class; space; 
		print: (self hasProperty: #myPopup); endEntry."

	panel _ RectangleMorph new color: Color transparent; borderWidth: 0.
	upDown ifNotNil: [
		panel addMorphBack: upDown first.
		upDown first align: upDown first topLeft with: panel topLeft.
		panel addMorphBack: upDown second.
		upDown second align: upDown second topLeft with: upDown first bottomLeft].
	colorPatch ifNotNil: [
		panel addMorphBack: colorPatch.
		colorPatch align: colorPatch topLeft 
					with: panel topLeft].
	retract ifNotNil: [
		edge _ panel submorphs size = 0 
			ifTrue: [panel left] 
			ifFalse: [panel submorphs last right].
		panel addMorphBack: retract.
		retract align: retract topLeft with: (edge+2) @ (panel top + 3)].
	extend ifNotNil: [
		edge _ panel submorphs size = 0 
			ifTrue: [panel left] 
			ifFalse: [panel submorphs last right].
		panel addMorphBack: extend.
		extend align: extend topLeft with: (edge+2) @ (panel top + 3)].

	panel align: panel topLeft with: self topRight.
	panel extent: panel submorphs last bottomRight - panel topLeft.
	self setProperty: #myPopup toValue: panel.
	outside addMorphFront: panel.
! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 1/15/2001 15:41'!
retract
	"replace this message with its receiver.  I am the message node."
	| rec cascade |
	self isCascadePart ifTrue:
		["This is a piece of a cascaded message -- just delete it"
		self deletePopup.
		cascade _ owner.
		self delete.
		cascade setSelection: {cascade. nil. cascade}.
		^ cascade acceptIfInScriptor].
	rec _ submorphs detect: [:m | m isSyntaxMorph and: [m parseNode == parseNode receiver]].
	self deletePopup.
	owner replaceSubmorph: self by: rec.
	rec setSelection: {rec. nil. rec}.
	rec acceptIfInScriptor.! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 12/13/2000 12:57'!
retractArrow
	"Return the retract arrow button.  It replaces the current message with its receiver.
	I am in a MessageNode whose first subnode is not a MessagePartNode.  I did not encounter a block on the way up to it.  I am the last subnode in every owner up to it."
	| patch |

	(self nodeClassIs: MessageNode) ifFalse: [^ nil].
	(owner isSyntaxMorph and: [owner parseNode == parseNode]) ifTrue: [^ nil].

	patch _ (ImageMorph new image: (TileMorph classPool at: #RetractPicture)).
	patch on: #mouseDown send: #retract to: self.
	^ patch! !

!SyntaxMorph methodsFor: 'pop ups' stamp: 'di 1/9/2001 08:29'!
upDownArrows
	"Return an array of two up/down arrow buttons.
	It replaces the selector or arg with a new one.
	I am a number or boolean or a selector (beep:, +,-,*,//,\\, or setX: incX: decX: for any X."
	| patch sel any ok |
	any _ (self nodeClassIs: LiteralNode) and: [parseNode key isNumber].
	any _ any or: [(self nodeClassIs: VariableNode) and:
						[(#('true' 'false') includes: self decompile asString)]].
	any _ any or: [(self nodeClassIs: SelectorNode) and:
				[ok _ #(beep: + - * // \\) includes: (sel _ parseNode key).
				ok _ ok or: [(sel beginsWith: 'set') and: [(sel atWrap: 4) isUppercase]].
				ok _ ok or: [sel size > 11 and:
						[#('IncreaseBy:' 'DecreaseBy:' 'MultiplyBy:') includes: (sel last: 11)]].
				ok]].
	any _ any or: [(self nodeClassIs: SelectorNode) and:
				[ok _ #(= ~= == ~~) includes: (sel _ parseNode key).
				ok]].
	any ifFalse: [^ nil].

	patch _ {(ImageMorph new image: TileMorph upPicture)
				on: #mouseDown send: #event:arrow:upDown: to: self withValue: 1.
			(ImageMorph new image: TileMorph downPicture)
				on: #mouseDown send: #event:arrow:upDown: to: self withValue: -1}.
	^ patch! !


!SyntaxMorph methodsFor: 'menus' stamp: 'tk 1/30/2001 12:10'!
accept
	"Turn my current state into the text of a method.  Compile it in my class."
	| cls sc |
	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile accept  "always accept at the root"].
	(cls _ self parsedInClass) ifNil: [^ self].
	cls compile: self decompile notifying: nil.
	(sc _ self firstOwnerSuchThat: [:mm | mm class == ScriptEditorMorph]) 
		ifNotNil: [sc hibernate; unhibernate].	"rebuild the tiles"
! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 11/21/2000 16:35'!
acceptIfInScriptor
	| root |
	"If I am in a ScriptEditorMorph, tell my root to accept the new changes."

	(self ownerThatIsA: ScriptEditorMorph) ifNotNil: [
		root _ self rootTile.
		root ifNotNil: [root accept]]. ! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 11/28/2000 20:09'!
acceptIgnoring: aString
	"If I am inside a ScriptEditorMorph, tell my root to accept the new changes.  Ignore the argument, which is the string whose conents just changed."

	self acceptIfInScriptor! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 2/3/2001 02:52'!
acceptSilently
	"Turn my current state into the text of a method.  Compile it in my class.  Don't rebuild the tiles."
	| cls |

	self isMethodNode ifFalse: [
		self rootTile == self ifTrue: [^ self].  "not in a script"
		^ self rootTile acceptSilently  "always accept at the root"].
	(self ownerThatIsA: ScriptEditorMorph) ifNil: [^ self].
	(cls _ self parsedInClass) ifNil: [^ self].
	cls compile: self decompile notifying: nil.

! !

!SyntaxMorph methodsFor: 'menus' stamp: 'tk 10/21/2000 23:44'!
decompile
	| stream |
	"Produce Smalltalk code.  We have a tree of SyntaxMorphs, but not a tree of ParseNodes.  The user has dragged in many SyntaxMorphs, each with its own parseNode, but those nodes are not sewn together in a tree.  The only data we get from a ParseNode is its class.
	We produce really ugly code.  But we compile it and decompile (prettyPrint) again for user to see."

	stream _ DialectStream on: (Text new: 400).
	stream setDialect: #ST80.
	self printOn: stream indent: 1.	"Tree walk and produce text of the code"
	^ stream contents! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 11/13/2000 20:23'!
getMenuBlock

	^ nil! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 11/17/2000 09:00'!
showCode
	"Turn my current state into the text of a method.  Put it in a window."

	(Workspace new contents: self rootTile decompile) openLabel: self printString,' code'

	
! !

!SyntaxMorph methodsFor: 'menus' stamp: 'di 11/17/2000 08:49'!
showMenu: evt
	| menu |
	menu _ MenuMorph new.
	menu add: 'show code' target: self selector: #showCode.
	menu add: 'try out' target: self selector: #try.
	self rootTile isMethodNode ifTrue:
		[menu addLine.
		menu add: 'accept method' target: self selector: #accept].
	menu popUpAt: evt hand position forHand: evt hand in: World.



! !


!SyntaxMorph methodsFor: 'debugging' stamp: 'RAA 8/24/1999 17:57'!
balloonText

	^(('Value: ',(self getCurrentValue ifNil: [^nil])) 
		withNoLineLongerThan: 35) truncateWithElipsisTo: 300! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'di 11/17/2000 07:59'!
debugger

	^ self rootTile valueOfProperty: #debugger! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'di 11/17/2000 07:59'!
debugger: x

	self rootTile setProperty: #debugger toValue: x! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'RAA 8/24/1999 12:35'!
hostContext

	^nil		"we don't have one"! !

!SyntaxMorph methodsFor: 'debugging' stamp: 'di 11/13/2000 20:30'!
update: aSymbol

	| bingo saveOwner newMorph db |

	(db _ self debugger) ifNil: [^super update: aSymbol].
	aSymbol == #contents ifTrue: [
		saveOwner _ owner.
		db removeDependent: self.
		markerMorph ifNotNil: [markerMorph delete. markerMorph _ nil].
		newMorph _ db createSyntaxMorph.
		self delete.
		saveOwner addMorph: newMorph.
		saveOwner owner setScrollDeltas.
		newMorph update: #contentsSelection.
	].
	aSymbol == #contentsSelection ifTrue: [
		markerMorph ifNil: [
			markerMorph _ RectangleMorph new.
			markerMorph
				color: Color transparent;
				borderWidth: 2;
				borderColor: Color red;
				lock.
			owner addMorphFront: markerMorph.
		].
		bingo _ parseNode rawSourceRanges keyAtValue: db pcRange ifAbsent: [nil].
		self testForNode: bingo andDo: [ :foundMorph | 
			markerMorph
				position: foundMorph position;
				extent: foundMorph extent.
			owner owner scrollIntoView: foundMorph bounds extra: 0.5.
			^self
		].
	].
	super update: aSymbol! !


!SyntaxMorph methodsFor: 'tests' stamp: 'di 12/13/2000 15:06'!
changed
	"(self bounds area > 40000 and: [(self activeHand position dist: 293@289) < 50])
		ifTrue: [self halt]."
	^ super changed! !

!SyntaxMorph methodsFor: 'tests' stamp: 'di 11/6/2000 10:47'!
test
	3 > 4 ifTrue: [].
	^ self! !

!SyntaxMorph methodsFor: 'tests' stamp: 'RAA 8/21/1999 07:39'!
testForNode: targetNode andDo: aBlock

	targetNode == parseNode ifTrue: [aBlock value: self].
	self submorphsDo: [ :each | 
		(each isKindOf: SyntaxMorph) ifTrue: [
			each testForNode: targetNode andDo: aBlock
		].
	].! !

!SyntaxMorph methodsFor: 'tests' stamp: 'di 11/14/2000 14:54'!
toDo
"
Biggies...
[ ]	Integrate with EToy scriptors
	releaseCachedState can discard all morphic structure.

[ ]	Options:
	Show / hide syntax markers (like [], (), ., :, ;, etc)
	No color / color-in-focus / full color
	Tiles / textiles / text

[ ]	ParsedTextMorph -- looks like text but has all same substructure

[ ]	Introduce notion of an UnParsedNode -- maybe a flag in ParseNode
	Text -> UnParsed -> Parsed -> CodeGen

[ ]	Need DnD evaluator, or some sort of '!!' button on any entity (halo?)
	Also inspector / browser

[ ]	All the type help we can get

Details ...
[ ]	Open up the parse of BraceNodes

[ ]	Verify that all pastes are OK

[ ]	Colors not yet right for colored version.

[ ]	Start work on show / hide of syntax markers -- (), [], etc.

[ ]	Start work on textiles (grabable entites in 'normal' text)

[ ]	Need autoscroll during drag for drop

[ ]	Use, eg, shift-drag to move, del to delete

[ ]	What about invalid drops -- stick on cursor?

System...
[ ]	Only keep history 7 deep; option to clear on quit
	clear command above spaceLeft

[ ]	Compute each page of prefs viewer on demand instead of as now.

[ ]	Offer a search command that will gather up all preferences that match a given string (name or help string)

Preferences enable: #noTileColor.
Preferences disable: #noTileColor.
Smalltalk browseAllSelect: [:cm | cm size > 600]
SyntaxMorph testAll
"! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SyntaxMorph class
	instanceVariableNames: ''!

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 08:35'!
column: aColor on: aParseNode

	| c color |
	color _ self translateColor: aColor.
	(c _ self newColumn)
		parseNode: aParseNode;
		layoutInset: self standardInset;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: color;
		borderWidth: 1;
		borderColor: c stdBorderColor;
		wrapCentering: #topLeft;
		cellPositioning: #topLeft.
	^c
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 11/13/2000 21:12'!
noTileColor

	^ true! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 11/10/2000 17:38'!
row: aColor on: aParseNode

	| r color |
	color _ self translateColor: aColor.
	(r _ self newRow)
		parseNode: aParseNode;
		layoutInset: self standardInset;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		color: color;
		borderWidth: 1;
		borderColor: r stdBorderColor;
		wrapCentering: #topLeft;
		cellPositioning: #topLeft.
	^r! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 11/11/2000 10:26'!
standardInset

	^ -1@-1
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/24/1999 11:59'!
test

"
SyntaxMorph test
"
	self testClass: MessageNode andMethod: #asMorphicSyntaxIn:.
	"self testClass: MethodNode andMethod: #asMorphicSyntaxIn:."

! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 8/24/1999 12:23'!
testAll

	| source tree total count |
"
SyntaxMorph testAll
"
	count _ total _ 0.
	Smalltalk allBehaviorsDo: [ :aClass | total _ total + 1].
'Testing all behaviors'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: total
	during: [ :bar |
		Smalltalk allBehaviorsDo: [ :aClass |
			bar value: (count _ count + 1).
			aClass selectors do: [ :aSelector |
				source _ (aClass compiledMethodAt: aSelector) getSourceFromFile.
				tree _ Compiler new 
					parse: source 
					in: aClass 
					notifying: nil.
				tree asMorphicSyntaxUsing: SyntaxMorph.
			].
		].	].


! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 11/15/2000 22:19'!
testAllMethodsOver: methodSize  "MessageTally spyOn: [SyntaxMorph testAllMethodsOver: 600]" 
	"Add up the total layout area for syntax morphs representing all methods
	over the given size.  This is a stress-test for SyntaxMorph layout.
	A small value for the total area is also a figure of merit in the presentation
	of Squeak source code in general."
"Results:
	#(69 600 180820874 103700)  11/4
	70% build morphs, 12% get source, 9% layout, 8% parse, 1% roundoff
Folded wide receivers, don't center keywords any more.
	#(68 600 160033784 127727)  11/9
	76% build morphs, 8% get source, 8% layout, 8% parse, 0% roundoff
Folded more messages, dropped extra vertical spacing in blocks.
	#(68 600 109141704 137308)  11/10
	79% build morphs, 6% get source, 8% layout, 7% parse
Folded more messages, dropped extra horizontal spacing.
	#(68 600 106912968 132171)  11/10
	80% build morphs, ??% get source, 11% layout, 7% parse
Unfolded keyword messages that will fit on one line.
	#(68 600 96497372 132153)  11/10
	81% build morphs, ??% get source, 8% layout, 8% parse
After alignment rewrite...
	#(74 600 101082316 244799)  11/12
	76% build morphs, 4% get source, 15% layout, 5% parse
After alignment rewrite...
	#(74 600 101250620 204972)  11/15
	74% build morphs, 6% get source, 13% layout, 7% parse
"
	| tree source biggies morph stats time area |
	biggies _ Smalltalk allSelect: [:cm | cm size > methodSize].
	stats _ OrderedCollection new.
'Laying out all ' , biggies size printString , ' methods over ' , methodSize printString , ' bytes...'
	displayProgressAt: Sensor cursorPoint
	from: 1 to: biggies size
	during:
		[:bar |
		biggies withIndexDo:
			[:methodRef :i | bar value: i.
			Utilities setClassAndSelectorFrom: methodRef in: 
				[:aClass :aSelector |
				source _ (aClass compiledMethodAt: aSelector) getSourceFromFile.
				time _ Time millisecondsToRun:
					[tree _ Compiler new 
						parse: source 
						in: aClass 
						notifying: nil.
					morph _ tree asMorphicSyntaxUsing: SyntaxMorph.
					area _ morph fullBounds area]].
			stats add: {methodRef. area. time}]
		].
	^ {{biggies size.  methodSize. stats detectSum: [:a | a second]. stats detectSum: [:a | a third]}.
		(stats asSortedCollection: [:x :y | x third >= y third]) asArray}
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 11/13/2000 20:11'!
testClass: aClass andMethod: aSelector

	| tree source |

	source _ (aClass compiledMethodAt: aSelector) getSourceFromFile.
	tree _ Compiler new 
		parse: source 
		in: aClass 
		notifying: nil.
	(tree asMorphicSyntaxUsing: SyntaxMorph)
		openInWindow.
! !

!SyntaxMorph class methodsFor: 'as yet unclassified' stamp: 'di 1/31/2001 10:39'!
translateColor: aColorOrSymbol

	aColorOrSymbol == #comment  ifTrue: [^ Color blue lighter].
	aColorOrSymbol == #block  ifTrue: [^ Color transparent].
	aColorOrSymbol == #text  ifTrue: [^ Color transparent].
	aColorOrSymbol isColor  ifTrue: [^ aColorOrSymbol].

	self noTileColor ifTrue: [^ Color transparent].	"override"
	aColorOrSymbol == #assignment  ifTrue: [^ Color paleGreen].
	aColorOrSymbol == #keyword1  ifTrue: [^ Color paleBuff].	"binary"
	aColorOrSymbol == #keyword2  ifTrue: [^ Color paleBuff lighter].	"multipart" 
	aColorOrSymbol == #cascade  ifTrue: [^ Color paleYellow darker].	"has receiver"
	aColorOrSymbol == #cascade2  ifTrue: [^ Color paleOrange].	"one send in the cascade"
	aColorOrSymbol == #literal  ifTrue: [^ Color paleMagenta].
	aColorOrSymbol == #message  ifTrue: [^ Color paleYellow].
	aColorOrSymbol == #method  ifTrue: [^ Color white].
	aColorOrSymbol == #error  ifTrue: [^ Color red].
	aColorOrSymbol == #return  ifTrue: [^ Color lightGray].
	aColorOrSymbol == #variable  ifTrue: [^ Color paleTan].
	aColorOrSymbol == #brace  ifTrue: [^ Color paleOrange].
	aColorOrSymbol == #tempVariable  ifTrue: [^ Color paleYellow mixed: 0.75 with: Color paleGreen
		"Color yellow lighter lighter"].
	aColorOrSymbol == #blockarg2  ifTrue: [
			^ Color paleYellow mixed: 0.75 with: Color paleGreen].	"arg itself"
	aColorOrSymbol == #blockarg1  ifTrue: [^ Color paleRed].	"container"
		"yellow mixed: 0.5 with: Color white"

	^aColorOrSymbol! !
IdentityDictionary subclass: #SystemDictionary
	instanceVariableNames: 'cachedClassNames '
	classVariableNames: 'LastImageName LastQuitLogPosition LowSpaceProcess LowSpaceSemaphore MemoryHogs ShutDownList SpecialSelectors StartUpList StartupStamp SystemChanges VersionString '
	poolDictionaries: ''
	category: 'System-Support'!
!SystemDictionary commentStamp: '<historical>' prior: 0!
I represent a special dictionary that supports protocol for asking questions about the structure of the system. Other than class names, I contain (print this)...
	Smalltalk keys select: [:k | ((Smalltalk at: k) isKindOf: Class) not]
			thenCollect: [:k | k -> (Smalltalk at: k) class]
!


!SystemDictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 21:56'!
organization
	"Return the organizer for the receiver"
	^SystemOrganization! !


!SystemDictionary methodsFor: 'browsing' stamp: 'di 9/5/97 16:05'!
browseAllCallsOn: aLiteral 
	"Create and schedule a message browser on each method that refers to
	aLiteral. For example, Smalltalk browseAllCallsOn: #open:label:."
	(aLiteral isKindOf: LookupKey)
		ifTrue: [self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection
					name: 'Users of ' , aLiteral key
					autoSelect: aLiteral key]
		ifFalse: [self browseMessageList: (self allCallsOn: aLiteral) asSortedCollection
					name: 'Senders of ' , aLiteral
					autoSelect: aLiteral keywords first]! !

!SystemDictionary methodsFor: 'browsing'!
browseAllCallsOn: literal1 and: literal2 
	"Create and schedule a message browser on each method that calls on the 
	two Symbols, literal1 and literal2. For example, Smalltalk 
	browseAllCallsOn: #at: and: #at:put:."

	^self 
		browseMessageList: (self allCallsOn: literal1 and: literal2)
		name: literal1 printString , ' -and- ' , literal2 printString! !

!SystemDictionary methodsFor: 'browsing'!
browseAllImplementorsOf: selector
	"Create and schedule a message browser on each method that implements 
	the message whose selector is the argument, selector. For example, 
	Smalltalk browseAllImplementorsOf: #at:put:."

	^self browseMessageList: (self allImplementorsOf: selector) name: 'Implementors of ' , selector! !

!SystemDictionary methodsFor: 'browsing'!
browseAllImplementorsOfList: selectorList
	"Create and schedule a message browser on each method that implements 
	the message whose selector is in the argument selectorList. For example, 
	Smalltalk browseAllImplementorsOf: #(at:put: size).
	1/16/96 sw: defer to the titled version"

	self browseAllImplementorsOfList: selectorList title: 'Implementors of all'! !

!SystemDictionary methodsFor: 'browsing'!
browseAllImplementorsOfList: selectorList title: aTitle
	"Create and schedule a message browser on each method that implements the message whose selector is in the argument selectorList. For example,  Smalltalk browseAllImplementorsOf: #(at:put: size).
	1/16/96 sw: this variant adds the title argument.
	1/24/96 sw: use a SortedCollection
	2/1/96 sw: show normal cursor"

	| implementorLists flattenedList |

	implementorLists _ selectorList collect: [:each | self allImplementorsOf: each].
	flattenedList _ SortedCollection new.
	implementorLists do: [:each | flattenedList addAll: each].
	Cursor normal show.
	^ self browseMessageList: flattenedList name: aTitle! !

!SystemDictionary methodsFor: 'browsing'!
browseAllMethodsInCategory: category 
	^self browseMessageList: (self allMethodsInCategory: category)
		name: category! !

!SystemDictionary methodsFor: 'browsing' stamp: 'di 5/4/1999 13:52'!
browseAllObjectReferencesTo: anObject except: objectsToExclude ifNone: aBlock
	"Bring up a list inspector on the objects that point to anObject.
	If there are none, then evaluate aBlock on anObject.  "

	| aList shortName |
	aList _ Smalltalk pointersTo: anObject except: objectsToExclude.
	aList size > 0 ifFalse: [^ aBlock value: anObject].
	shortName _ (anObject name ifNil: [anObject printString]) contractTo: 20.
	OrderedCollectionInspector openOn: aList withEvalPane: false
		withLabel: 'Objects pointing to ', shortName.! !

!SystemDictionary methodsFor: 'browsing'!
browseAllSelect: aBlock
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result. For example, 
	Smalltalk browseAllSelect: [:method | method numLiterals > 10]."

	^self browseMessageList: (self allSelect: aBlock) name: 'selected messages'! !

!SystemDictionary methodsFor: 'browsing' stamp: 'sw 8/15/97 15:32'!
browseAllSelect: aBlock name: aName autoSelect: autoSelectString
	"Create and schedule a message browser on each method that, when used 
	as the block argument to aBlock gives a true result.   Do not return an #DoIt traces."

	"Smalltalk browseAllSelect: [:method | method numLiterals > 10] name: 'Methods with more than 10 literals' autoSelect: 'isDigit'"

	^ self browseMessageList: (self allSelectNoDoits: aBlock) name: aName autoSelect: autoSelectString! !

!SystemDictionary methodsFor: 'browsing'!
browseAllUnSentMessages
	"Create and schedule a message browser on each method whose message is 
	not sent in any method in the system."

	^self browseMessageList: self allUnSentMessages name: 'UnSent Messages'! !

!SystemDictionary methodsFor: 'browsing'!
browseAllUnimplementedCalls
	"Create and schedule a message browser on each method that includes a 
	message that is not implemented in any object in the system."

	^self browseMessageList: self allUnimplementedCalls name: 'Unimplemented calls'! !

!SystemDictionary methodsFor: 'browsing' stamp: 'sw 8/5/1998 18:41'!
browseChangedMessages
	"Create and schedule a message browser on each method that has been 
	changed."

	SystemChanges isEmpty ifTrue: [^ self inform: 'There are no changed messages
in the current change set.'].
	ChangedMessageSet openFor: SystemChanges! !

!SystemDictionary methodsFor: 'browsing'!
browseMessageList: messageList name: label 
	"Create and schedule a MessageSet browser on messageList."
	^ self browseMessageList: messageList name: label autoSelect: nil! !

!SystemDictionary methodsFor: 'browsing' stamp: 'sw 9/21/1999 11:38'!
browseMessageList: messageList name: labelString autoSelect: autoSelectString
	| title aSize |
	"Create and schedule a MessageSet browser on the message list."

	messageList size = 0 ifTrue: 
		[^ (PopUpMenu labels: ' OK ')
				startUpWithCaption: 'There are no
' , labelString].

	title _ (aSize _ messageList size) > 1
		ifFalse:	[labelString]
		ifTrue:	[ labelString, ' [', aSize printString, ']'].

	MessageSet openMessageList: messageList name: title autoSelect: autoSelectString! !

!SystemDictionary methodsFor: 'browsing'!
browseMethodsWhoseNamesContain: aString
	"Launch a browser on all methods whose names contain the given string; case-insensitive.  This takes a long time right now.  1/16/96 sw"

	| aList |
	aList _ Symbol selectorsContaining: aString.
	aList size > 0 ifTrue: 
		[self browseAllImplementorsOfList: aList asSortedCollection title: 'Methods whose names contain ''', aString, '''']! !

!SystemDictionary methodsFor: 'browsing' stamp: 'di 11/23/1998 12:05'!
browseMethodsWithSourceString: aString
	"Smalltalk browseMethodsWithSourceString: 'SourceString' "
	"Launch a browser on all methods whose source code contains aString as a substring."

	| caseSensitive suffix |
	(caseSensitive _ Sensor shiftPressed)
		ifTrue: [suffix _ ' (case-sensitive)']
		ifFalse: [suffix _ ' (use shift for case-sensitive)'].
	^ self browseMessageList: (self allMethodsWithSourceString: aString
									matchCase: caseSensitive)
		name: 'Methods containing ' , aString printString , suffix autoSelect: aString! !

!SystemDictionary methodsFor: 'browsing' stamp: 'di 11/23/1998 12:05'!
browseMethodsWithString: aString
	"Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive."

	| caseSensitive suffix |
	(caseSensitive _ Sensor shiftPressed)
		ifTrue: [suffix _ ' (case-sensitive)']
		ifFalse: [suffix _ ' (use shift for case-sensitive)'].
	self browseAllSelect:
			[:method |
				method  hasLiteralSuchThat: [:lit |
					lit class == String and:
					[lit includesSubstring: aString caseSensitive: caseSensitive]]]
		name:  'Methods with string ', aString printString, suffix
		autoSelect: aString.
! !

!SystemDictionary methodsFor: 'browsing' stamp: 'tk 6/24/1999 11:28'!
browseObsoleteReferences   "Smalltalk browseObsoleteReferences"
	| references |
	references _ OrderedCollection new.
	(Association allSubInstances select:
		[:x | ((x value isKindOf: Behavior) and: ['AnOb*' match: x value name]) or:
		['AnOb*' match: x value class name]]) 
		do: [:x | references addAll: (Smalltalk allCallsOn: x)].
	Smalltalk browseMessageList: references name: 'References to Obsolete Classes'! !

!SystemDictionary methodsFor: 'browsing' stamp: 'di 4/15/98 09:41'!
showMenuOf: selectorCollection withFirstItem: firstItem ifChosenDo: choiceBlock
	"Show a sorted menu of the given selectors, preceded by firstItem, and all
	abbreviated to 40 characters.  Evaluate choiceBlock if a message is chosen."
	| index menuLabels sortedList |
	sortedList _ selectorCollection asSortedCollection.
	menuLabels _ String streamContents: 
		[:strm | strm nextPutAll: (firstItem contractTo: 40).
		sortedList do: [:sel | strm cr; nextPutAll: (sel contractTo: 40)]].
	index _ (PopUpMenu labels: menuLabels lines: #(1)) startUp.
	index = 1 ifTrue: [choiceBlock value: firstItem].
	index > 1 ifTrue: [choiceBlock value: (sortedList at: index-1)]! !


!SystemDictionary methodsFor: 'class names' stamp: 'di 3/26/2000 09:06'!
classNamed: className 
	"className is either a class name or a class name followed by ' class'.
	Answer the class or metaclass it names"

	| meta baseName baseClass |
	(className endsWith: ' class')
		ifTrue: [meta _ true.
				baseName _ className copyFrom: 1 to: className size - 6]
		ifFalse: [meta _ false.
				baseName _ className].
	baseClass _ Smalltalk at: baseName asSymbol ifAbsent: [^ nil].
	meta
		ifTrue: [^ baseClass class]
		ifFalse: [^ baseClass]! !

!SystemDictionary methodsFor: 'class names' stamp: 'di 11/16/1999 12:44'!
classNames
	"Answer a SortedCollection of all class names."
	| names |
	cachedClassNames == nil ifTrue:
		[names _ OrderedCollection new: self size.
		self do: 
			[:cl | (cl isInMemory and: [(cl isKindOf: Class) and: [(cl name beginsWith: 'AnObsolete') not]])
				ifTrue: [names add: cl name]].
		cachedClassNames _ names asSortedCollection].
	^ cachedClassNames! !

!SystemDictionary methodsFor: 'class names' stamp: 'di 2/16/2000 10:28'!
flushClassNameCache
	"Smalltalk flushClassNameCache"
	"Forse recomputation of the cached list of class names."

	cachedClassNames _ nil! !

!SystemDictionary methodsFor: 'class names'!
hasClassNamed: aString
	"Answer whether there is a class of the given name, but don't intern aString if it's not alrady interned.  4/29/96 sw"

	Symbol hasInterned: aString ifTrue: 
		[:aSymbol | ^ (self at: aSymbol ifAbsent: [nil]) isKindOf: Class].
	^ false! !

!SystemDictionary methodsFor: 'class names' stamp: 'di 2/3/1999 22:21'!
removeClassFromSystem: aClass
	"Delete the class, aClass, from the system."

	aClass wantsChangeSetLogging ifTrue:
		[SystemChanges noteRemovalOf: aClass].
	aClass acceptsLoggingOfCompilation ifTrue:
		[Smalltalk logChange:  'Smalltalk removeClassNamed: #', aClass name].
	self removeClassFromSystemUnlogged: aClass
! !

!SystemDictionary methodsFor: 'class names' stamp: 'di 4/19/1999 10:29'!
removeClassFromSystemUnlogged: aClass
	"Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log"

	SystemOrganization removeElement: aClass name.
	self removeFromStartUpList: aClass.
	self removeFromShutDownList: aClass.
	self removeKey: aClass name ifAbsent: [].
	self flushClassNameCache
! !

!SystemDictionary methodsFor: 'class names' stamp: 'sw 9/5/97 18:30'!
removeClassNamed: aName
	"Invoked from fileouts:  if there is currently a class in the system named aName, then remove it.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: aName asSymbol ifAbsent: [nil]) == nil
		ifTrue:
			[Transcript cr; show: 'Removal of class named ', aName, ' ignored because ', aName, ' does not exist.'.
			^ self].

	oldClass removeFromSystem! !

!SystemDictionary methodsFor: 'class names' stamp: 'di 2/3/1999 22:33'!
renameClass: aClass as: newName 
	"Rename the class, aClass, to have the title newName."
	| oldref i |
	SystemOrganization classify: newName under: aClass category.
	SystemOrganization removeElement: aClass name.
	SystemChanges renameClass: aClass as: newName.
	oldref _ self associationAt: aClass name.
	self removeKey: aClass name.
	oldref key: newName.
	self add: oldref.  "Old association preserves old refs"
	(Array with: StartUpList with: ShutDownList) do:
		[:list |  i _ list indexOf: aClass name ifAbsent: [0].
		i > 0 ifTrue: [list at: i put: newName]].
	self flushClassNameCache! !

!SystemDictionary methodsFor: 'class names' stamp: 'sw 10/28/96'!
renameClassNamed: oldName as: newName
	"Invoked from fileouts:  if there is currently a class in the system named oldName, then rename it to newName.  If anything untoward happens, report it in the Transcript.  "

	| oldClass |
	(oldClass _ self at: oldName asSymbol ifAbsent: [nil]) == nil
		ifTrue:
			[Transcript cr; show: 'Class-rename for ', oldName, ' ignored because ', oldName, ' does not exist.'.
			^ self].

	oldClass rename: newName! !


!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 12:42'!
associationAtOrAbove: varName ifAbsent: absentBlock 
	"Compatibility with environment protocol."

	^ self associationAt: varName ifAbsent: absentBlock! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'tk 10/3/2000 13:01'!
associationOrUndeclaredAt: key 
	"return an association or install in undeclared.  Used for mating up ImageSegments."

	^ self associationAtOrAbove: key ifAbsent: [
		Undeclared at: key put: nil.
		Undeclared associationAt: key]! !

!SystemDictionary methodsFor: 'dictionary access'!
at: aKey put: anObject 
	"Override from Dictionary to check Undeclared and fix up
	references to undeclared variables."
	| index element |
	(self includesKey: aKey) ifFalse: 
		[self declare: aKey from: Undeclared.
		self flushClassNameCache].
	super at: aKey put: anObject.
	^ anObject! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/21/1999 12:00'!
atOrAbove: key ifAbsent: absentBlock
	"Compatibility with environment protocol."

	^ self at: key ifAbsent: absentBlock! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 13:43'!
atOrBelow: key ifAbsent: absentBlock
	"Compatibility with environment protocol."

	^ self at: key ifAbsent: absentBlock! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 20:36'!
environmentForCategory: catName
	"Default response for non-partitioned systems"

	^ Smalltalk! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/21/1999 12:00'!
includesKeyOrAbove: key
	"Compatibility with environment protocol."

	self atOrAbove: key ifAbsent: [^ false].
	^ true! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 2/16/2000 13:40'!
kernelCategories
	^ #(Kernel Collections Graphics System)! !

!SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/19/1999 21:17'!
scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock
	"Null compatibility with partitioning into environments."

	(self includesKey: varName)
		ifTrue: [^ envtAndPathBlock value: self value: String new]
		ifFalse: [^ nil]! !


!SystemDictionary methodsFor: 'housekeeping'!
cleanOutUndeclared 
	Undeclared removeUnreferencedKeys! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'MPH 10/24/2000 14:33'!
condenseChanges		"Smalltalk condenseChanges"
	"Move all the changes onto a compacted sources file."
	| f oldChanges classCount |
	f _ FileStream fileNamed: 'ST80.temp'.
	f header; timeStamp.
'Condensing Changes File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during:
		[:bar | classCount _ 0.
		Smalltalk allClassesDo:
			[:class | bar value: (classCount _ classCount + 1).
			class moveChangesTo: f.
			class class moveChangesTo: f]].
	LastQuitLogPosition _ f position.
	f trailer; close.
	oldChanges _ SourceFiles at: 2.
	oldChanges close.
	FileDirectory default 
		deleteFileNamed: oldChanges name , '.old';
		rename: oldChanges name toBe: oldChanges name , '.old';
		rename: f name toBe: oldChanges name.
	self setMacFileInfoOn: oldChanges name.
	SourceFiles at: 2
			put: (StandardFileStream oldFileNamed: oldChanges name).! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'MPH 10/24/2000 14:30'!
condenseSources		"Smalltalk condenseSources"
	"Move all the changes onto a compacted sources file."
	| f classCount dir |
	dir _ FileDirectory default.

	"Write all sources with fileIndex 1"
	f _ FileStream newFileNamed: self sourcesName , '.temp'.
	f header; timeStamp.
'Condensing Sources File...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Smalltalk classNames size
	during:
		[:bar | classCount _ 0.
		Smalltalk allClassesDo:
			[:class | bar value: (classCount _ classCount + 1).
			class fileOutOn: f moveSource: true toFile: 1]].
	f trailer; close.

	"Make a new empty changes file"
	self closeSourceFiles.
	dir rename: self changesName
		toBe: self changesName , '.old'.
	(FileStream newFileNamed: self changesName)
		header; timeStamp; close.
	LastQuitLogPosition _ 0.

	dir rename: self sourcesName
		toBe: self sourcesName , '.old'.
	dir rename: self sourcesName , '.temp'
		toBe: self sourcesName.
	self setMacFileInfoOn: self changesName.
	self setMacFileInfoOn: self sourcesName.
	self openSourceFiles.
	SelectionMenu notify: 'Source files have been rewritten!!
Check that all is well,
and then save/quit.'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 7/19/1999 23:00'!
forgetDoIts	"Smalltalk forgetDoIts"
	Smalltalk allBehaviorsDo: "get rid of old DoIt methods"
		[:cl | cl forgetDoIts]

! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 11/29/2000 11:14'!
macroBenchmark1    "Smalltalk macroBenchmark1"
	"Decompiles and prettyPrints the source for every method in the system (or less depending on the *FILTER*, and then compiles that source and verifies that it generates (and decompiles to) identical code.  This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same.  Because it never installs the new method, it should not cause any flusing of the method cache."
	 | methodNode oldMethod newMethod badOnes oldCodeString n classes |
	classes _ Smalltalk allClasses select: [:c | c name < 'B3'].
	badOnes _ OrderedCollection new.
'Decompiling and recompiling...'
displayProgressAt: Sensor cursorPoint
from: 0 to: (classes detectSum: [:c | c selectors size])
during: [:bar | n _ 0.
	classes do:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | bar value: (n _ n+1).
			oldMethod _ cls compiledMethodAt: selector.
			oldCodeString _ (cls decompilerClass new
								decompile: selector in: cls method: oldMethod)
							decompileString.
			methodNode _ cls compilerClass new
						compile: oldCodeString
						in: cls notifying: nil ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldCodeString = (cls decompilerClass new
								decompile: selector in: cls method: newMethod)
							decompileString ifFalse: [badOnes add: cls name , ' ' , selector]]].
].
	^ badOnes size! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 11/29/2000 20:55'!
macroBenchmark2  "Smalltalk macroBenchmark2"
	"Copied from Interpreter class>>translate:doInlining:forBrowserPlugin:"
	| doInlining cg fileName inlineFlag pluginFlag |
	fileName _ 'benchmark2.out'.
	inlineFlag _ true.
	pluginFlag _ false.
	doInlining _ inlineFlag.
	pluginFlag ifTrue: [doInlining _ true].  "must inline when generating browser plugin"
	Interpreter initialize.
	ObjectMemory initialize.
	cg _ CCodeGenerator new initialize.
	cg addClass: Interpreter.
	cg addClass: ObjectMemory.
	Interpreter declareCVarsIn: cg.
	ObjectMemory declareCVarsIn: cg.
	FileDirectory default deleteFileNamed: fileName.
	cg storeCodeOnFile: fileName doInlining: doInlining.
	FileDirectory default deleteFileNamed: fileName.

! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 11/29/2000 11:15'!
macroBenchmark3   "Smalltalk macroBenchmark3"
	| testBlock tallies prev receiver |
	"Runs the stepping simulator with the messageTally tree (like tallySends)."
	testBlock _
		['Running the context step simulator'
			displayProgressAt: Sensor cursorPoint
			from: 0 to: 200
			during:
				[:bar |
				1 to: 200 do:
				[:x | bar value: x.
				Float pi printString.
				15 factorial printString]]].
	tallies _ MessageTally new class: testBlock receiver class
							method: testBlock method.
	receiver _ nil.
	prev _ testBlock.
	thisContext sender
		runSimulated: testBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: 
				["call or return"
				prev sender == nil ifFalse: 
					["call only"
					(receiver == nil or: [current receiver == receiver])
						ifTrue: [tallies tally: current by: 1]].
				prev _ current]].
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 12/4/2000 13:01'!
macroBenchmarks 
	"Reports an array of times taken to run a number of macro operations indicative of typical Squeak activity, each run after a full garbageCollection, and with exactly 10Mb of free space available.  In addition it puts up a window with recent VM statistics local to each test."

	"PLEASE TAKE NOTE: The goal of these benchmarks is to provide a simple basis for A/B performance comparisons with a given Squeak image.  For example JIT vs interpreter, new GC vs old, etc.  However, a number of these benchmarks will 'drift' with evolution of the Squeak image, as, for instance, if the number of methods decompiled in macroBenchmark1 were to change.  Therefore it is essential *never* to make comarisons between macroBenchmarks run from two different images."

	"Smalltalk macroBenchmarks #(43215 53122 81336 26927 8993 12607 9024) 400MHz G3"

	| interp time saveMorphs freeCell report fullReport individualTimes |
	individualTimes _ OrderedCollection new.
	fullReport _ String streamContents:
	[:strm | Smalltalk timeStamp: strm.

	"1:	Decompile, pretty-print, and compile a bunch of methods.
		Does not install in classes, so does not flush cache."
	strm cr; cr; nextPutAll: 'Benchmark #1: ';
		print: (time _ self standardTime: [Smalltalk macroBenchmark1]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"2:	Build morphic tiles for all methods over 800 bytes (;-).
		Does no display."
	strm cr; nextPutAll: 'Benchmark #2: ';
		print: (time _ self standardTime: [SyntaxMorph testAllMethodsOver: 800]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"3:	Translate the interpreter with inlining.
		Does not include any plugins."
	strm cr; nextPutAll: 'Benchmark #3: ';
		print: (time _ self standardTime: [Smalltalk macroBenchmark2]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"4:	Run the context step simulator.
		200 iterations printing pi and 15 factorial."
	strm cr; nextPutAll: 'Benchmark #4: ';
		print: (time _ self standardTime: [Smalltalk macroBenchmark3]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"5:	Run the InterpreterSimulator for 150,000 bytecodes.
		Will only run if you have mini.image in your directory."
	strm cr; nextPutAll: 'Benchmark #5: ';
		print: ((FileDirectory default includesKey: 'mini.image')
		ifTrue: [interp _ InterpreterSimulator new openOn: 'mini.image'.
				time _ self standardTime: [interp runForNBytes: 150000].
				interp close. Display restore.
				time]
		ifFalse: [time _ 0]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"6:	Open 10 browsers and close them.
		Includes browsing to a specific method."
	strm cr; nextPutAll: 'Benchmark #6: ';
		print: (Smalltalk isMorphic
		ifTrue: [saveMorphs _ self currentWorld submorphs.
				self currentWorld removeAllMorphs.  "heh, heh"
				time _ self standardTime:
					[1 to: 10 do: [:i | Browser fullOnClass: SystemDictionary selector: #macroBenchmarks].
					self currentWorld submorphs do:
						[:m | m delete. self currentWorld doOneCycle]].
				self currentWorld addAllMorphs: saveMorphs.
				time]
		ifFalse: [time _ 0]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	"7:	Play a game of FreeCell with display, while running the MessageTally.
		Thanks to Bob Arning for the clever part of this one."
	strm cr; nextPutAll: 'Benchmark #7: ';
		print: (Smalltalk isMorphic
		ifTrue: ["Play a trivial game of FreeCell with MessageTally and report."
				(freeCell _ FreeCell new) openInWorld.
				time _ self standardTime: [freeCell board pickGame: 1].
				(((report _ self currentWorld firstSubmorph) isKindOf: SystemWindow)
					and: [self currentWorld firstSubmorph label = 'Spy Results'])
					ifTrue: [report delete].
				freeCell delete.
				time]
		ifFalse: [time _ 0]);
		nextPutAll: 'ms'; cr; nextPutAll: '---------------------';
		cr; nextPutAll: Utilities vmStatisticsShortString.
	individualTimes addLast: time.

	strm cr; nextPutAll: '---------------------';
		cr; nextPutAll: 'Total time = '; print: individualTimes sum; nextPutAll: ' milliseconds.'; cr].

	StringHolder new textContents: fullReport; openLabel: 'Macro Benchmark Results'.
	^ individualTimes asArray
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 2/3/2001 21:35'!
makeExternalRelease		"Smalltalk makeExternalRelease"
	(self confirm: self version , '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
	"Object classPool at: #DependentsFields"
	Smalltalk reclaimDependents.
	Preferences enable: #allowMVCprojects.
	Preferences enable: #fastDragWindowForMorphic.
	Browser initialize.
	Undeclared isEmpty ifFalse: [self halt].
	ScriptingSystem deletePrivateGraphics.
	#(Helvetica Palatino Courier) do:
		[:n | TextConstants removeKey: n ifAbsent: []].
	(Utilities classPool at: #UpdateUrlLists) copy do:
		[:pair | (pair first includesSubstring: 'Disney' caseSensitive: false) ifTrue: [
			(Utilities classPool at: #UpdateUrlLists) remove: pair]].
	(ServerDirectory serverNames copyWithoutAll: #('UCSBCreateArchive' 'UIUCArchive' 'UpdatesExtUIUC' 'UpdatesExtWebPage'))
		do: [:sn | ServerDirectory removeServerNamed: sn].
	Smalltalk garbageCollect.
	Smalltalk obsoleteClasses isEmpty ifFalse: [self halt].
	Symbol rehash.
	self halt: 'Ready to condense changes or sources'.
	SystemDictionary removeSelector: #makeExternalRelease.! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 9/21/97 01:14'!
makeInternalRelease		"Smalltalk makeInternalRelease"
	(self confirm: self version , '
Is this the correct version designation?
If not, choose no, and fix it.') ifFalse: [^ self].
	(Object classPool at: #DependentsFields) size > 1 ifTrue: [self halt].
	Browser initialize.
	Undeclared isEmpty ifFalse: [self halt].
	Smalltalk garbageCollect.
	self obsoleteClasses isEmpty ifFalse: [self halt].
	Symbol rehash.
	self halt: 'Ready to condense changes'.
	Smalltalk condenseChanges! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 7/15/1999 16:05'!
obsoleteBehaviors   "Smalltalk obsoleteBehaviors inspect"
	"Find all obsolete behaviors including meta classes"
	| obs |
	obs _ OrderedCollection new.
	Smalltalk garbageCollect.
	self allObjectsDo:[:cl|
		(cl isBehavior and:[cl isObsolete]) ifTrue:[obs add: cl]].
	^ obs asArray! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'jm 5/22/1998 11:37'!
obsoleteClasses   "Smalltalk obsoleteClasses inspect"
	"NOTE:  Also try inspecting comments below"
	| obs c |
	obs _ OrderedCollection new.  Smalltalk garbageCollect.
	Metaclass allInstancesDo:
		[:m | c _ m soleInstance.
		(c ~~ nil and: ['AnOb*' match: c name asString])
			ifTrue: [obs add: c]].
	^ obs asArray

"Likely in a ClassDict or Pool...
(Association allInstances select: [:a | (a value isKindOf: Class) and: ['AnOb*' match: a value name]]) asArray
"
"Obsolete class refs or super pointer in last lit of a method...
| n l found |
Smalltalk browseAllSelect:
	[:m | found _ false.
	1 to: m numLiterals do:
		[:i | (((l _ m literalAt: i) isMemberOf: Association)
				and: [(l value isKindOf: Behavior)
				and: ['AnOb*' match: l value name]])
			ifTrue: [found _ true]].
	found]
"! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'tk 6/24/1999 11:47'!
reclaimDependents		"Smalltalk reclaimDependents"
	"Reclaim unused entries in DependentsFields (DF)..."
	"NOTE:  if <object>addDependent: is ever used to add something
		other than a view, this process will fail to reinstate that
		thing after clearing out DependentsFields.  DF was only
		intended to be used as part of the MVC architecture."
	Object classPool at: #DependentsFields  "Remove all entries from DF"
				put: IdentityDictionary new.
	Smalltalk garbageCollect.  "If that was the only reference, they will go away"
	"Now if any views of non-models remain,
		they should be reinstated as dependent views..."
	View allSubInstancesDo:
		[:v | (v model==nil or: [v model isKindOf: Model])
				ifFalse: [v model addDependent: v]].
	SystemWindow allSubInstancesDo:
		[:v | (v model==nil or: [v model isKindOf: Model])
				ifFalse: [v model addDependent: v]].
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 4/24/2000 14:02'!
recompileAllFrom: firstName 
	"Recompile all classes, starting with given name."

	Smalltalk forgetDoIts.
	self allClassesDo: 
		[:class | class name >= firstName
			ifTrue: 
				[Transcript show: class name; cr.
				class compileAll]]

	"Smalltalk recompileAllFrom: 'AAABodyShop'."
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 10/16/1999 20:31'!
removeAllLineFeeds    "Smalltalk removeAllLineFeeds"
	"Scan all methods for source code with lineFeeds.
	Replaces all occurrences of <CR><LF> by <CR>, noted by beep.
	Halts with a message if any other LFs are found."
	 | oldCodeString n crlf cr newCodeString oldStamp oldCategory m |
	crlf _ String with: Character cr with: Character lf.
	cr _ String with: Character cr.
	Smalltalk forgetDoIts.
'Scanning sources for LineFeeds.
This will take a few minutes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0. m _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			oldCodeString _ (cls sourceCodeAt: selector) asString.
			(oldCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue:
				[self beep.
				newCodeString _ oldCodeString copyReplaceAll: crlf with: cr asTokens: false.
				(newCodeString indexOf: Character lf startingAt: 1) > 0
					ifTrue: [(self confirm: cls name , ' ' , (selector contractTo: 30) , '
has an isolated LineFeed (not part of CRLF).
Shall I replace it?') ifFalse: [self halt]].
				oldStamp _ Utilities timeStampForMethod: (cls compiledMethodAt: selector).
				oldCategory _ cls whichCategoryIncludesSelector: selector.
				cls compile: newCodeString classified: oldCategory withStamp: oldStamp notifying: nil.
				m _ m + 1]]].
].
	Transcript cr; show: m printString , ' methods stripped of LFs.'.
! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 6/8/1999 15:47'!
removeEmptyMessageCategories
	"Smalltalk removeEmptyMessageCategories"
	Smalltalk garbageCollect.
	(ClassOrganizer allInstances copyWith: SystemOrganization) do:
		[:org | org removeEmptyCategories]! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'SqR 11/16/2000 13:46'!
sortAllCategories
	ClassOrganizer allInstances do: [:x | x sortCategories]

! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 12/4/2000 13:15'!
standardTime: aBlock
	"Times the execution of aBlock in milliseconds, under the following standard conditions:  exactly 10Mb of free space is available and compacted, and the recent VM statistics are reset immediately before execution."
	| spaceLeft tieDown |
	spaceLeft _ Smalltalk garbageCollect.
	spaceLeft < 1e7 ifTrue: [self error: 'not enough space for standard conditions'].
	tieDown _ ByteArray new: spaceLeft - 1e7.  "Leave exactly 10MB free"
	tieDown _ tieDown.
	Utilities vmStatisticsReportString.  "To reset statistics"
	Smalltalk garbageCollectMost.  "To clear that garbage"
	^ Time millisecondsToRun: aBlock! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'di 8/23/1998 14:35'!
testDecompiler    "Smalltalk testDecompiler"
	"Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code.  This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same."
	 | methodNode oldMethod newMethod badOnes oldCodeString n |
	badOnes _ OrderedCollection new.
	Smalltalk forgetDoIts.
'Decompiling all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			oldMethod _ cls compiledMethodAt: selector.
			oldCodeString _ (cls decompilerClass new
								decompile: selector in: cls method: oldMethod)
							decompileString.
			methodNode _ cls compilerClass new
						compile: oldCodeString
						in: cls notifying: nil ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldCodeString = (cls decompilerClass new
								decompile: selector in: cls method: newMethod)
							decompileString ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector.
											badOnes add: cls name , ' ' , selector]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 11/9/1999 17:56'!
testFormatter    "Smalltalk testFormatter"
	"Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code.   The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting."

	 | newCodeString methodNode oldMethod newMethod badOnes n |
	badOnes _ OrderedCollection new.
	Smalltalk forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			newCodeString _ (cls compilerClass new)
				format: (cls sourceCodeAt: selector)
				in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
			methodNode _ cls compilerClass new
						compile: newCodeString
						in: cls notifying: nil ifFail: [].
			newMethod _ methodNode generate: #(0 0 0 0).
			oldMethod _ cls compiledMethodAt: selector.
			oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector.
											badOnes add: cls name , ' ' , selector]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 11/9/1999 17:56'!
testFormatter2    "Smalltalk testFormatter2"
	"Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged.  The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting."

	 | newCodeString badOnes n oldCodeString oldTokens newTokens |
	badOnes _ OrderedCollection new.
	Smalltalk forgetDoIts.
'Formatting all classes...'
displayProgressAt: Sensor cursorPoint
from: 0 to: CompiledMethod instanceCount
during: [:bar | n _ 0.
	Smalltalk allBehaviorsDo:
		[:cls | 
		"Transcript cr; show: cls name."
		cls selectors do:
			[:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n].
			oldCodeString _ (cls sourceCodeAt: selector) asString.
			newCodeString _ (cls compilerClass new)
				format: oldCodeString
				in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting.
			oldTokens _ oldCodeString findTokens: Character separators.
			newTokens _ newCodeString findTokens: Character separators.
			oldTokens = newTokens ifFalse:
					[Transcript cr; show: '***' , cls name , ' ' , selector.
					badOnes add: cls name , ' ' , selector]]].
].
	Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! !

!SystemDictionary methodsFor: 'housekeeping'!
verifyChanges		"Smalltalk verifyChanges"
	"Recompile all methods in the changes file."
	Smalltalk allBehaviorsDo: [:class | class recompileChanges].
! !


!SystemDictionary methodsFor: 'image, changes name' stamp: 'MPH 10/23/2000 13:31'!
changeImageNameTo: aString
	self imageName: aString.
	LastImageName _ self imageName! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'jm 3/27/98 08:20'!
changesName
	"Answer the local name for the changes file corresponding to the image file name."
	"Smalltalk changesName"

	| imName |
	imName _ FileDirectory baseNameFor:
		(FileDirectory localNameFor: self imageName).
	^ imName, FileDirectory dot, 'changes'
! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'MPH 10/23/2000 10:28'!
fullNameForChangesNamed: aName
	| newName |
	newName _ FileDirectory baseNameFor: aName asFileName.
	^newName , FileDirectory dot, FileDirectory changeSuffix.! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'MPH 10/23/2000 10:28'!
fullNameForImageNamed: aName
	| newName |
	newName _ FileDirectory baseNameFor: aName asFileName.
	^newName , FileDirectory dot, FileDirectory imageSuffix.! !

!SystemDictionary methodsFor: 'image, changes name'!
imageName
	"Answer the full path name for the current image."
	"Smalltalk imageName"

	<primitive: 121>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'image, changes name'!
imageName: newName
	"Set the the full path name for the current image.  All further snapshots will use this."

	<primitive: 121>
	^ self primitiveFailed! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'jm 12/4/97 22:25'!
imagePath
	"Answer the path for the directory containing the image file."
	"Smalltalk imagePath"

	^ FileDirectory dirPathFor: self imageName
! !

!SystemDictionary methodsFor: 'image, changes name' stamp: 'di 5/22/1998 15:51'!
sourcesName
	"Answer the full path to the version-stable source code"
	^ self vmPath , 'SqueakV2' , FileDirectory dot , 'sources'! !

!SystemDictionary methodsFor: 'image, changes name'!
vmPath
	"Answer the path for the directory containing the Smalltalk virtual machine. Return the empty string if this primitive is not implemented."
	"Smalltalk vmPath"

	<primitive: 142>
	^ ''! !


!SystemDictionary methodsFor: 'memory space'!
bytesLeft
	"Answer the number of bytes of space available. Does a full garbage collection."

	^ self garbageCollect
! !

!SystemDictionary methodsFor: 'memory space'!
createStackOverflow
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; createStackOverflow"

	self createStackOverflow.  "infinite recursion"! !

!SystemDictionary methodsFor: 'memory space'!
garbageCollect
	"Primitive. Reclaims all garbage and answers the number of bytes of available space."

	<primitive: 130>
	^ self primBytesLeft! !

!SystemDictionary methodsFor: 'memory space'!
garbageCollectMost
	"Primitive. Reclaims recently created garbage (which is usually most of it) fairly quickly and answers the number of bytes of available space."

	<primitive: 131>
	^ self primBytesLeft! !

!SystemDictionary methodsFor: 'memory space'!
installLowSpaceWatcher
	"Start a process to watch for low-space conditions."
	"Smalltalk installLowSpaceWatcher"

	self primSignalAtBytesLeft: 0.  "disable low-space interrupts"
	LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate].
	LowSpaceProcess _ [self lowSpaceWatcher] newProcess.
	LowSpaceProcess priority: Processor lowIOPriority.
	LowSpaceProcess resume.

! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'!
lowSpaceThreshold 
	"Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image."

	thisContext isPseudoContext
		ifTrue: [^ 400000  "Enough for JIT compiler"]
		ifFalse: [^ 200000  "Enough for interpreter"]! !

!SystemDictionary methodsFor: 'memory space' stamp: 'go 10/3/2000 13:10'!
lowSpaceWatcher
	"Wait until the low space semaphore is signalled, then take appropriate actions."

	| free |
	self garbageCollectMost <= self lowSpaceThreshold ifTrue: [
		self garbageCollect <= self lowSpaceThreshold ifTrue: [
			"free space must be above threshold before starting low space watcher"
			^ self beep]].

	LowSpaceSemaphore _ Semaphore new.
	self primLowSpaceSemaphore: LowSpaceSemaphore.
	self primSignalAtBytesLeft: self lowSpaceThreshold.  "enable low space interrupts"

	LowSpaceSemaphore wait.  "wait for a low space condition..."

	self primSignalAtBytesLeft: 0.  "disable low space interrupts"
	self primLowSpaceSemaphore: nil.
	LowSpaceProcess _ nil.
	"Note: user now unprotected until the low space watcher is re-installed"

	self memoryHogs isEmpty ifFalse: [
		free := self bytesLeft.
		self memoryHogs do: [ :hog | hog freeSomeSpace ].
		self bytesLeft > free ifTrue: [ ^ self installLowSpaceWatcher ]].

	Smalltalk isMorphic
			ifTrue: [CurrentProjectRefactoring currentInterruptName: 'Space is low']
			ifFalse: [ScheduledControllers interruptName: 'Space is low']! !

!SystemDictionary methodsFor: 'memory space' stamp: 'nk 10/28/2000 20:37'!
lowSpaceWatcherProcess
	^LowSpaceProcess! !

!SystemDictionary methodsFor: 'memory space' stamp: 'sma 4/22/2000 19:03'!
memoryHogs
	"Answer the list of objects to notify with #freeSomeSpace if memory gets full."

	^ MemoryHogs ifNil: [MemoryHogs _ OrderedCollection new]! !

!SystemDictionary methodsFor: 'memory space'!
okayToProceedEvenIfSpaceIsLow
	"Return true if either there is enough memory to do so safely or if the user gives permission after being given fair warning."

	self garbageCollectMost > self lowSpaceThreshold ifTrue: [^ true].  "quick"
	self garbageCollect > self lowSpaceThreshold ifTrue: [^ true].  "work harder"

	^ self confirm:
'WARNING: There is not enough space to start the low space watcher.
If you proceed, you will not be warned again, and the system may
run out of memory and crash. If you do proceed, you can start the
low space notifier when more space becomes available simply by
opening and then closing a debugger (e.g., by hitting Cmd-period.)
Do you want to proceed?'
! !

!SystemDictionary methodsFor: 'memory space'!
primBytesLeft
	"Primitive. Answer the number of bytes available for new object data.
	Not accurate unless preceded by
		Smalltalk garbageCollectMost (for reasonable accuracy), or
		Smalltalk garbageCollect (for real accuracy).
	See Object documentation whatIsAPrimitive."

	<primitive: 112>
	^ 0! !

!SystemDictionary methodsFor: 'memory space'!
primLowSpaceSemaphore: aSemaphore
	"Primitive. Register the given Semaphore to be signalled when the
	number of free bytes drops below some threshold. Disable low-space
	interrupts if the argument is nil."

	<primitive: 124>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space'!
primSignalAtBytesLeft: numBytes
	"Tell the interpreter the low-space threshold in bytes. When the free
	space falls below this threshold, the interpreter will signal the low-space
	semaphore, if one has been registered.  Disable low-space interrupts if the
	argument is zero.  Fail if numBytes is not an Integer."

	<primitive: 125>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'memory space'!
signalLowSpace
	"Signal the low-space semaphore to alert the user that space is running low."

	LowSpaceSemaphore signal.! !

!SystemDictionary methodsFor: 'memory space' stamp: 'apb 10/3/2000 16:40'!
useUpMemory
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemory"

	| lst |
	lst _ nil.
	[true] whileTrue: [
		lst _ Link nextLink: lst.
	].! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 21:15'!
useUpMemoryWithArrays 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithArrays"

	| b |  "First use up most of memory."
	b _ String new: self bytesLeft - self lowSpaceThreshold - 100000.
	b _ b.  "Avoid unused value warning"
	(1 to: 10000) collect: [:i | Array new: 10000]! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'!
useUpMemoryWithContexts 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts"

	self useUpMemoryWithContexts! !

!SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:50'!
useUpMemoryWithTinyObjects 
	"For testing the low space handler..."
	"Smalltalk installLowSpaceWatcher; useUpMemoryWithTinyObjects"

	| b |  "First use up most of memory."
	b _ String new: self bytesLeft - self lowSpaceThreshold - 100000.
	b _ b.  "Avoid unused value warning"
	(1 to: 10000) collect: [:i | BitBlt new]! !


!SystemDictionary methodsFor: 'miscellaneous'!
beep
	"Emit a short alert sound."

	<primitive: 140>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'RAA 6/17/2000 11:27'!
compareTallyIn: beforeFileName to: afterFileName

	| answer s beforeDict a afterDict allKeys before after diff |

	beforeDict _ Dictionary new.
	s _ FileDirectory default fileNamed: beforeFileName.
	[s atEnd] whileFalse: [
		a _ Array readFrom: s nextLine.
		beforeDict at: a first put: a allButFirst.
	].
	s close.
	afterDict _ Dictionary new.
	s _ FileDirectory default fileNamed: afterFileName.
	[s atEnd] whileFalse: [
		a _ Array readFrom: s nextLine.
		afterDict at: a first put: a allButFirst.
	].
	s close.
	answer _ WriteStream on: String new.
	allKeys _ (Set new addAll: beforeDict keys; addAll: afterDict keys; yourself) asSortedCollection.
	allKeys do: [ :each |
		before _ beforeDict at: each ifAbsent: [#(0 0 0)].
		after _ afterDict at: each ifAbsent: [#(0 0 0)].
		diff _ before with: after collect: [ :vBefore :vAfter | vAfter - vBefore].
		diff = #(0 0 0) ifFalse: [
			answer nextPutAll: each,'  ',diff printString; cr.
		].
	].
	StringHolder new contents: answer contents; openLabel: 'space diffs'.
	


! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ikp 12/30/1998 05:16'!
compilerDisable
	"Smalltalk compilerDisable"

	<primitive: 'squeakCompilerDisable' module: 'squeakCompiler'>! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ikp 12/30/1998 05:15'!
compilerEnable
	"Smalltalk compilerEnable"

	<primitive: 'squeakCompilerEnable' module: 'squeakCompiler'>! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'JMM 12/6/2000 20:18'!
disablePowerManager
	self disablePowerManager: 1! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 2/2/2001 14:36'!
disablePowerManager: aInteger
	"Disable/Enable the architectures power manager by passing in nonzero or zero"

	<primitive: 'primitiveDisablePowerManager'>! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'JMM 12/6/2000 20:19'!
enablePowerManager
	self disablePowerManager: 0! !

!SystemDictionary methodsFor: 'miscellaneous'!
exitToDebugger
	"Primitive. Enter the machine language debugger, if one exists. Essential.
	See Object documentation whatIsAPrimitive."

	<primitive: 114>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 7/10/1999 08:10'!
extraVMMemory
	"Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details."

	^ Smalltalk vmParameterAt: 23
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 7/10/1999 08:26'!
extraVMMemory: extraBytesToReserve
	"Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter."

	extraBytesToReserve < 0
		ifTrue: [self error: 'VM memory reservation must be non-negative'].
	^ Smalltalk vmParameterAt: 23 put: extraBytesToReserve
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 5/21/1998 23:49'!
forceDisplayUpdate
	"Obsolete. Send this message to Display instead of Smalltalk."

	Display forceDisplayUpdate.
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 3/10/98 21:43'!
fullScreenMode: aBoolean
	"On platforms that support it, set full-screen mode to the value of the argument. (Note: you'll need to restore the Display after calling this primitive."
	"Smalltalk fullScreenMode: true. Display newDepth: Display depth"

	<primitive: 233>
	self primitiveFailed
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'sma 6/25/2000 09:22'!
getSystemAttribute: attributeID 
	"Optional. Answer the string for the system attribute with the given 
	integer ID. Answer nil if the given attribute is not defined on this 
	platform. On platforms that support invoking programs from command 
	lines (e.g., Unix), this mechanism can be used to pass command line 
	arguments to programs written in Squeak.

	By convention, the first command line argument that is not a VM
	configuration option is considered a 'document' to be filed in. Such a
	document can add methods and classes, can contain a serialized object,
	can include code to be executed, or any combination of these.

	Currently defined attributes include: 
	-1000...-1 - command line arguments that specify VM options 
	0 - the full path name for currently executing VM 
	(or, on some platforms, just the path name of the VM's directory) 
	1 - full path name of this image 
	2 - a Squeak document to open, if any 
	3...1000 - command line arguments for Squeak programs 
	1001 - this platform's operating system 
	1002 - operating system version 
	1003 - this platform's processor type
	1004 - vm version"

	<primitive: 149>
	^ nil! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ikp 1/2/98 20:29'!
getVMParameters	"Smalltalk getVMParameters"
	"Answer an Array containing the current values of the VM's internal
	parameter/metric registers.  Each value is stored in the array at the
	index corresponding to its VM register.  (See #vmParameterAt: and
	#vmParameterAt:put:.)"

	<primitive: 254>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous'!
gifReaderClass
	"Answer, if present, a class to handle the importing of GIF files from disk. If none, return nil.   9/18/96 sw"

	| aClass |
	^ ((aClass _ self at: #GIFReadWriter ifAbsent: [nil]) isKindOf: Class)
		ifTrue:
			[aClass]
		ifFalse:
			[nil]! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'RAA 6/3/2000 09:28'!
handleUserInterrupt
	Preferences cmdDotEnabled ifTrue:
		[Smalltalk isMorphic
			ifTrue: [[CurrentProjectRefactoring currentInterruptName: 'User Interrupt'] fork]
			ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]]! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'di 7/19/1999 15:44'!
hasMorphic
	"Answer whether the Morphic classes are available in the system (they may have been stripped, such as by a call to Smalltalk removeMorphic"

	^ ((Smalltalk at: #Morph ifAbsent: [nil]) isKindOf: Class)! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'tao 10/26/97 23:42'!
imageImports
	"Answer the global dictionary of image imports, creating it if necessary.  7/24/96 sw"

	"Smalltalk viewImageImports"
	(self includesKey: #ImageImports)
		ifFalse:
			[self at: #ImageImports put: Dictionary new].
	^ self at: #ImageImports! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'tao 10/26/97 23:26'!
imageReaderClass
	"Answer, if present, a class to handle the importing of various graphic image files
	from disk. If none, return nil.   tao 10/26/97"

	| aClass |
	^ ((aClass _ self at: #ImageReadWriter ifAbsent: [nil]) isKindOf: Class)
		ifTrue:
			[aClass]
		ifFalse:
			[nil]! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 6/7/1999 11:35'!
itsyVoltage
	"On the Itsy, answer the approximate Vcc voltage. The Itsy will shut itself down when this value reaches 2.0 volts. This method allows one to build a readout of the current battery condition."

	| n |
	n _ self getSystemAttribute: 1200.
	n ifNil: [^ 'no voltage attribute'].
	^ ((n asNumber / 150.0) roundTo: 0.01) asString, ' volts'
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'tao 10/26/97 23:23'!
jpegReaderClass
	"Answer, if present, a class to handle the importing of JPEG files from disk. If none, return nil.   9/18/96 sw"

	| aClass |
	^ ((aClass _ self at: #JPEGReadWriter ifAbsent: [nil]) isKindOf: Class)
		ifTrue:
			[aClass]
		ifFalse:
			[nil]! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 5/16/2000 00:54'!
listBuiltinModule: index
	"Return the name of the n-th builtin module.
	This list is not sorted!!"
	<primitive: 572>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 6/5/2000 18:44'!
listBuiltinModules
	"Smalltalk listBuiltinModules"
	"Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded or not. Note that the list returned is not sorted!!"
	| modules index name |
	modules _ WriteStream on: Array new.
	index _ 1.
	[true] whileTrue:[
		name _ self listBuiltinModule: index.
		name ifNil:[^modules contents].
		modules nextPut: name.
		index _ index + 1.
	].! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'TPR 5/16/2000 16:56'!
listLoadedModule: index
	"Return the name of the n-th loaded module.
	This list is not sorted!!"
	<primitive: 573>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 6/5/2000 18:43'!
listLoadedModules
	"Smalltalk listLoadedModules"
	"Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!"
	| modules index name |
	modules _ WriteStream on: Array new.
	index _ 1.
	[true] whileTrue:[
		name _ self listLoadedModule: index.
		name ifNil:[^modules contents].
		modules nextPut: name.
		index _ index + 1.
	].! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'di 12/6/1999 19:54'!
logError: errMsg inContext: aContext to: aFilename
	"Log the error message and a stack trace to the given file."
	| ff ctx |
	FileDirectory default deleteFileNamed: aFilename ifAbsent: [].
	(ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"].
  	ff print: Date today; space; print: Time now; cr.
  	ff nextPutAll: errMsg; cr.
	"Note: The following is an open-coded version of ContextPart>>stackOfSize:
	since this method may be called during a low space condition and we might
	run out of space for allocating the full stack."
	ctx _ aContext.
	[ctx == nil] whileFalse:[
		ff print: ctx; cr.
		ctx _ ctx sender].
	ff close.! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 2/1/2000 15:39'!
platformName
	"Return the name of the platform we're running on"
	^self getSystemAttribute: 1001! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'MPH 10/24/2000 14:27'!
setMacFileInfoOn: aString
	"On Mac, set the file type and creator (noop on other platforms)"
	FileDirectory default
		setMacFileNamed: aString
		type: 'STch'
		creator: 'FAST'.! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 11/1/1998 11:38'!
spaceForInstancesOf: aClass
	"Answer the number of bytes consumed by all instances of the given class, including thier object headers."

	| instCount isCompact instVarBytes bytesPerElement contentBytes headerBytes total |
	instCount _ aClass instanceCount.
	instCount = 0 ifTrue: [^ 0].
	isCompact _ aClass indexIfCompact > 0.
	instVarBytes _ aClass instSize * 4.
	aClass isVariable
		ifTrue: [
			bytesPerElement _ aClass isBytes ifTrue: [1] ifFalse: [4].
			total _ 0.
			aClass allInstancesDo: [:inst |
				contentBytes _ instVarBytes + (inst size * bytesPerElement).
				headerBytes _
					contentBytes > 255
						ifTrue: [12]
						ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
				total _ total + headerBytes + contentBytes].
			^ total]
		ifFalse: [
			headerBytes _
				instVarBytes > 255
					ifTrue: [12]
					ifFalse: [isCompact ifTrue: [4] ifFalse: [8]].
			^ instCount * (headerBytes + instVarBytes)].
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 11/1/1998 11:45'!
spaceTally
	"Answer a collection of tuples representing the memory space (in bytes) consumed by the code and instances of each class in the system. The tuples have the form:
	<class> <code size> <instance count> <space for instances>
Code sizes do not currently report memory consumed by class variables. The arrays used to record these results consume a relatively insignificant amount of space."
	"(Smalltalk spaceTally asSortedCollection: [:a :b | a last > b last]) asArray"

	| results entry c |
	"pre-allocate array of entries for results"
	results _ OrderedCollection new: self size.
	self do: [:cl |
		(cl isKindOf: Class) ifTrue: [
			entry _ Array new: 4.
			entry at: 1 put: cl.
			results add: entry]].
	results _ results asArray.

	Smalltalk garbageCollect.
	1 to: results size do: [:i |
		entry _ results at: i.
		c _ entry at: 1.
		entry at: 2 put: c spaceUsed.
		entry at: 3 put: c instanceCount.
		entry at: 4 put: (self spaceForInstancesOf: c).
		Smalltalk garbageCollectMost].
	^ results
! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'RAA 6/17/2000 11:08'!
spaceTallyTo: aFileName

	| answer s |
	Smalltalk garbageCollect.
	answer _ Smalltalk spaceTally.
	(FileDirectory default fileExists: aFileName) ifTrue: [
		FileDirectory default deleteFileNamed: aFileName
	].
	s _ FileDirectory default fileNamed: aFileName.
	answer do: [ :each | s nextPutAll: each printString; cr].
	s close

! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 3/10/2000 17:32'!
unloadModule: aString
	"Primitive. Unload the given module.
	This primitive is intended for development only since some
	platform do not implement unloading of DLL's accordingly.
	Also, the mechanism for unloading may not be supported
	on all platforms."
	<primitive: 571>
	^self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'sw 9/21/1998 11:03'!
verifyMorphicAvailability
	"If Morphic is available, return true; if not, put up an informer and return false"
	self hasMorphic ifFalse:
		[self beep.
		self inform: 'Sorry, Morphic must
be present to use this feature'.
		^ false].
	^ true! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'sw 5/26/2000 07:25'!
viewImageImports
	| imageImports |
	"Open up a special Form inspector on the dictionary of graphical imports."

	(imageImports _ self imageImports) size == 0 ifTrue:
		[^ self inform: 
'The ImageImports repository is currently empty,
so there is nothing to view at this time.  You can
use a file list to import graphics from external files
into ImageImports, and once you have done that,
you will find this command more interesting.'].

	imageImports inspectFormsWithLabel: 'Graphical Imports'! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ikp 1/2/98 20:29'!
vmParameterAt: parameterIndex
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Answer with the current value of that register.
	Fail if parameterIndex has no corresponding register."

	<primitive: 254>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'ikp 1/2/98 20:29'!
vmParameterAt: parameterIndex put: newValue
	"parameterIndex is a positive integer corresponding to one of the VM's internal
	parameter/metric registers.  Store newValue (a positive integer) into that
	register and answer with the previous value that was stored there.
	Fail if newValue is out of range, if parameterIndex has no corresponding
	register, or if the corresponding register is read-only."

	<primitive: 254>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'miscellaneous' stamp: 'sma 6/25/2000 09:26'!
vmVersion	"Smalltalk vmVersion"
	"Return a string identifying the interpreter version"
	^self getSystemAttribute: 1004! !


!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a reference to Smalltalk instead."

	dp _ DiskProxy global: #Smalltalk selector: #yourself
			args: #().
	refStrm replace: self with: dp.
	^ dp! !

!SystemDictionary methodsFor: 'objects from disk' stamp: 'tk 3/7/2000 18:40'!
storeDataOn: aDataStream
	"I don't get stored.  Use a DiskProxy"

	self error: 'use a DiskProxy to store me'! !


!SystemDictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:53'!
printElementsOn: aStream
	aStream nextPutAll:'(lots of globals)'! !


!SystemDictionary methodsFor: 'profiling'!
clearProfile
	"Clear the profile database."

	<primitive: 250>
! !

!SystemDictionary methodsFor: 'profiling'!
dumpProfile
	"Dump the profile database to a file."

	<primitive: 251>
! !

!SystemDictionary methodsFor: 'profiling'!
profile: aBlock
	"Make a virtual machine profile of the given block."
	"Note: Profiling support is provided so that VM implementors
	 can better understand and improve the efficiency of the virtual
	 machine. To use it, you must be running a version of the
	 virtual machine compiled with profiling enabled (which
	 makes it much slower than normal even when not profiling).
	 You will also need the CodeWarrior profile reader application."

	self stopProfiling.
	self clearProfile.
	self startProfiling.
	aBlock value.
	self stopProfiling.
	self dumpProfile.! !

!SystemDictionary methodsFor: 'profiling'!
startProfiling
	"Start profiling the virtual machine."

	<primitive: 252>
! !

!SystemDictionary methodsFor: 'profiling'!
stopProfiling
	"Stop profiling the virtual machine."

	<primitive: 253>
! !


!SystemDictionary methodsFor: 'retrieving' stamp: 'di 2/9/2000 07:58'!
allBehaviorsDo: aBlock 
	"Evaluate the argument, aBlock, for each kind of Behavior in the system 
	(that is, Object and its subclasses).
	ar 7/15/1999: The code below will not enumerate any obsolete or anonymous
	behaviors for which the following should be executed:

		Smalltalk allObjectsDo:[:obj| obj isBehavior ifTrue:[aBlock value: obj]].

	but what follows is way faster than enumerating all objects."

	aBlock value: ProtoObject.
	ProtoObject allSubclassesDoGently: aBlock.		"don't bring in ImageSegments"

	"Classes outside the ProtoObject hierarchy"
	Class subclassesDo: [:aClass |
		(aClass == ProtoObject class
			or: [aClass isInMemory not
			or: [aClass isMeta not]]) ifFalse:
			["Enumerate the non-meta class and its subclasses"
			aBlock value: aClass soleInstance.
			aClass soleInstance allSubclassesDoGently: aBlock]].! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: aLiteral   "Smalltalk browseAllCallsOn: #open:label:."
	"Answer a Collection of all the methods that call on aLiteral."
	| aCollection special thorough aList byte |

	#(23 48 'fred' (new open:label:)) size.
		"Example above should find #open:label:, though it is deeply embedded
here."
	aCollection _ OrderedCollection new.
	special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _
b ].
	thorough _ (aLiteral isMemberOf: Symbol)
				and: ["Possibly search for symbols imbedded in literal arrays"
					Preferences thoroughSenders].
	Cursor wait showWhile: 
		[self allBehaviorsDo: 
			[:class |
				aList _ thorough
					ifTrue:
			 			[(class thoroughWhichSelectorsReferTo: aLiteral special: special
byte: byte)]
					ifFalse:
						[class whichSelectorsReferTo: aLiteral special: special byte:
byte].
				aList do: 
					[:sel | sel ~~ #DoIt
						ifTrue: [aCollection add: class name , ' ' , sel]]]].
	^ aCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'!
allCallsOn: firstLiteral and: secondLiteral
	"Answer a SortedCollection of all the methods that call on both
aLiteral 
	and secondLiteral."

	| aCollection secondArray firstSpecial secondSpecial firstByte
secondByte |
	aCollection _ SortedCollection new.
	firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b
| firstByte _ b].
	secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte:
[:b | secondByte _ b].
	Cursor wait showWhile:
		[self allBehaviorsDo:
			[:class |
			secondArray _ class whichSelectorsReferTo: secondLiteral special:
secondSpecial byte: secondByte.
			((class whichSelectorsReferTo: firstLiteral special: firstSpecial
byte: firstByte) select:
				[:aSel | (secondArray includes: aSel)]) do:
						[:sel | aCollection add: class name , ' ' , sel]]].
	^aCollection! !

!SystemDictionary methodsFor: 'retrieving'!
allClasses  "Smalltalk allClasses"
	^ self classNames collect: [:name | Smalltalk at: name]! !

!SystemDictionary methodsFor: 'retrieving'!
allClassesDo: aBlock
	"Evaluate the argument, aBlock, for each class in the system."

	(self classNames collect: [:name | Smalltalk at: name]) do: aBlock! !

!SystemDictionary methodsFor: 'retrieving'!
allClassesImplementing: aSelector  
	"Answer an Array of all classes that implement the message aSelector."

	| aCollection |
	aCollection _ ReadWriteStream on: Array new.
	self allBehaviorsDo:
		[:class | (class includesSelector: aSelector)
			ifTrue: [aCollection nextPut: class]].
	^ aCollection contents! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'bf 9/22/1999 16:56'!
allImplementedMessages
	"Answer a Set of all the messages that are sent by a method in the system 
	but are not implemented."

	| aSet |
	aSet _ IdentitySet new: Symbol instanceCount.
	Cursor wait showWhile: 
		[self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | aSet add: aSelector]]].
	^aSet! !

!SystemDictionary methodsFor: 'retrieving'!
allImplementorsOf: aSelector  
	"Answer a SortedCollection of all the methods that implement the message 
	aSelector."

	| aCollection |
	aCollection _ SortedCollection new.
	Cursor wait showWhile:
		[self allBehaviorsDo:
			[:class |
			(class includesSelector: aSelector)
				ifTrue: [aCollection add: class name, ' ', aSelector]]].
	^aCollection! !

!SystemDictionary methodsFor: 'retrieving'!
allMethodsInCategory: category 
	| aCollection |
	aCollection _ SortedCollection new.
	Cursor wait showWhile:
		[self allBehaviorsDo:
			[:x | (x organization listAtCategoryNamed: category) do:
				[:sel | aCollection add: x name , ' ' , sel]]].
	^aCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'di 11/23/1998 12:02'!
allMethodsWithSourceString: aString matchCase: caseSensitive
	"Answer a SortedCollection of all the methods that contain, in source code, aString as a substring.  The search is case-insensitive."
	| list classCount |
	list _ Set new.
'Searching all source code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: Smalltalk classNames size
during:
	[:bar | classCount _ 0.
	Smalltalk allClassesDo:
		[:class | bar value: (classCount _ classCount + 1).
		(Array with: class with: class class) do:
			[:cl | cl selectorsDo:
				[:sel | 
				((cl sourceCodeAt: sel) findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0
					ifTrue:
					[sel == #DoIt ifFalse: [list add: cl name , ' ' , sel]]]]]].
	^ list asSortedCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'sw 8/12/97 20:57'!
allMethodsWithString: aString 
	"Answer a SortedCollection of all the methods that contain, in a string literal, aString as a substring.  2/1/96 sw.  The search is case-sensitive, and does not dive into complex literals, confining itself to string constants.
	5/2/96 sw: fixed so that duplicate occurrences of aString in the same method don't result in duplicated entries in the browser"

	| aStringSize list lits |

	aStringSize _ aString size.
	list _ Set new.

	Cursor wait showWhile: [self allBehaviorsDo: 
		[:class | class selectorsDo:
			[:sel | sel ~~ #DoIt ifTrue:
				[lits _ (class compiledMethodAt: sel) literals.
				lits do:
					[:aLiteral | ((aLiteral isMemberOf: String) and:
						[aLiteral size >= aStringSize])
							ifTrue:
								[(aLiteral findString: aString startingAt: 1)  > 0 ifTrue:
									[list add: class name , ' ' , sel]]]]]]].
	^ list asSortedCollection! !

!SystemDictionary methodsFor: 'retrieving'!
allObjectsDo: aBlock 
	"Evaluate the argument, aBlock, for each object in the system
	 excluding SmallIntegers."

	| object |
	object _ self someObject.
	[0 == object] whileFalse: [
		aBlock value: object.
		object _ object nextObject.
	].! !

!SystemDictionary methodsFor: 'retrieving'!
allPrimitiveMessages
	"Answer an OrderedCollection of all the methods that are implemented by 
	primitives."

	| aColl aSelector method | 
	aColl _ OrderedCollection new: 200.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:class | class selectorsDo: 
				[:sel | 
				method _ class compiledMethodAt: sel.
				method primitive ~= 0
					ifTrue: [aColl addLast: class name , ' ' , sel 
									, ' ' , method primitive printString]]]].
	^aColl! !

!SystemDictionary methodsFor: 'retrieving'!
allPrimitiveMethodsInCategories: aList
	"Answer an OrderedCollection of all the methods that are implemented by primitives in the given categories.  1/26/96 sw"

	| aColl aSelector method | 
	aColl _ OrderedCollection new: 200.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:aClass | (aList includes: (SystemOrganization categoryOfElement: aClass theNonMetaClass name asString) asString)
				ifTrue: [aClass selectorsDo: 
					[:sel | 
						method _ aClass compiledMethodAt: sel.
						method primitive ~= 0
							ifTrue: [aColl addLast: aClass name , ' ' , sel 
									, ' ' , method primitive printString]]]]].
	^ aColl

"Smalltalk allPrimitiveMethodsInCategories: #('Collections-Streams' 'Files-Streams' 'Files-Abstract' 'Files-Macintosh')"! !

!SystemDictionary methodsFor: 'retrieving'!
allSelect: aBlock 
	"Answer a SortedCollection of each method that, when used as the block 
	argument to aBlock, gives a true result."

	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:class | class selectorsDo: 
				[:sel | (aBlock value: (class compiledMethodAt: sel))
					ifTrue: [aCollection add: class name , ' ' , sel]]]].
	^aCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'sw 8/15/97 15:31'!
allSelectNoDoits: aBlock 
	"Like allSelect:, but strip out Doits"

	| aCollection |
	aCollection _ SortedCollection new.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:class | class selectorsDo: 
				[:sel | ((sel ~~ #DoIt) and: [(aBlock value: (class compiledMethodAt: sel))])
					ifTrue: [aCollection add: class name , ' ' , sel]]]].
	^aCollection! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'bf 9/22/1999 16:39'!
allSentMessages
	"Answer the set of selectors which are sent somewhere in the system."
	| sent |
	sent _ IdentitySet new: CompiledMethod instanceCount.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:cl | cl selectorsDo: 
				[:sel | "Include all sels, but not if sent by self"
			(cl compiledMethodAt: sel) literals do: 
				[:m | 
				(m isMemberOf: Symbol) ifTrue:  "might be sent"
					[m == sel ifFalse: [sent add: m]].
				(m isMemberOf: Array) ifTrue:  "might be performed"
					[m do: [:x | (x isMemberOf: Symbol) ifTrue:
						[x == sel ifFalse: [sent add: x]]]]]]].
		"The following may be sent without being in any literal frame"
		1 to: self specialSelectorSize do: 
			[:index | 
			sent add: (self specialSelectorAt: index)]].
	^ sent! !

!SystemDictionary methodsFor: 'retrieving'!
allUnSentMessages   "Smalltalk allUnSentMessages"
	"Answer the set of selectors that are implemented by some object
	in the system but not sent by any."
	| sent unsent |
	sent _ self allSentMessages.
	unsent _ Set new.
	self allImplementedMessages do:
		[:sel | (sent includes: sel) ifFalse: [unsent add: sel]].
	^ unsent
"
 | f cl lastClass |
f _ FileStream newFileNamed: 'UnsentMessages.txt'.
lastClass _ 'xx'.
methods _ SortedCollection new.
Smalltalk allUnSentMessages do:
	[:sel | methods addAll: (Smalltalk allImplementorsOf: sel)].
methods do:
	[:m | cl _ m copyUpTo: $ . 
	cl = lastClass
		ifTrue: [f nextPutAll: (m copyFrom: lastClass size+1 to: m size)]
		ifFalse: [f cr; cr; nextPutAll: m.  lastClass _ cl]].
f close.
"! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'di 12/15/1998 21:47'!
allUnSentMessagesIn: selectorSet
	"Answer the subset of selectorSet which are not sent anywhere in the system.
	Factored out from#allUnSentMessages "
	|  all |
	all _ selectorSet copy.
	Cursor execute showWhile: 
		[self allBehaviorsDo: 
			[:cl | cl selectorsDo: 
				[:sel | 
				(cl compiledMethodAt: sel) literals do: 
					[:lit |
					(lit isMemberOf: Symbol)  "might be sent"
						ifTrue: [all remove: lit ifAbsent: []].
					(lit isMemberOf: Array)  "might be performed"
						ifTrue: [lit do:
								[:elt |
								(elt isMemberOf: Array)
									ifTrue: [elt do: [:e | all remove: e ifAbsent: []]]
									ifFalse: [all remove: elt ifAbsent: []]]].
					]]].
		"The following may be sent without being in any literal frame"
		1 to: self specialSelectorSize do: 
			[:index | 
			all remove: (self specialSelectorAt: index) ifAbsent: []]].
	^ all! !

!SystemDictionary methodsFor: 'retrieving'!
allUnimplementedCalls 
	"Answer an Array of each message that is sent by an expression in a 
	method but is not implemented by any object in the system."

	| aStream secondStream all  |
	all _ self allImplementedMessages.
	aStream _ WriteStream on: (Array new: 50).
	Cursor execute showWhile:
		[self allBehaviorsDo:
			[:cl |
			 cl selectorsDo:
				[:sel |
				 secondStream _ WriteStream on: (String new: 5).
				(cl compiledMethodAt: sel) messages do:
					[:m | (all includes: m) ifFalse: [secondStream nextPutAll: m; space]].
				secondStream position = 0 ifFalse:
					[aStream nextPut: cl name , ' ' , sel , ' calls: ', secondStream contents]]]].
	^aStream contents! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'sw 1/8/2001 11:31'!
numberOfImplementorsOf: aSelector  
	"Answer a count of the implementors of the given selector found in the system"

	| aCount |
	aCount _ 0.
	self allBehaviorsDo:
		[:class |
			(class includesSelector: aSelector)
				ifTrue: [aCount _ aCount + 1]].
	^ aCount
"
Smalltalk numberOfImplementorsOf: #contents.
Smalltalk numberOfImplementorsOf: #nobodyImplementsThis. 
Smalltalk numberOfimplementorsOf: #numberOfImplementorsOf:.
"! !

!SystemDictionary methodsFor: 'retrieving'!
pointersTo: anObject
	"Find all occurrences in the system of pointers to the argument anObject."
	"(Smalltalk pointersTo: Browser) inspect."

	^ self pointersTo: anObject except: #()
! !

!SystemDictionary methodsFor: 'retrieving' stamp: 'tk 9/26/1999 14:54'!
pointersTo: anObject except: objectsToExclude
	"Find all occurrences in the system of pointers to the argument anObject. Remove objects in the exclusion list from the results."

	| results anObj |
	Smalltalk garbageCollect.
	"big collection shouldn't grow, so it's contents array is always the same"
	results _ OrderedCollection new: 1000.

	"allObjectsDo: is expanded inline to keep spurious
	 method and block contexts out of the results"
	anObj _ self someObject.
	[0 == anObj] whileFalse: [
		anObj isInMemory ifTrue: [
			(anObj pointsTo: anObject) ifTrue: [
				"exclude the results collector and contexts in call chain"
				((anObj ~~ results collector) and:
				 [(anObj ~~ objectsToExclude) and:
				 [(anObj ~~ thisContext) and:
				 [(anObj ~~ thisContext sender) and:
				 [anObj ~~ thisContext sender sender]]]])
					 ifTrue: [ results add: anObj ].
			]].
		anObj _ anObj nextObject.
	].
	objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]].

	^ results asArray
! !

!SystemDictionary methodsFor: 'retrieving'!
pointersToItem: index of: anArray
	"Find all occurrences in the system of pointers to the given element of the given array. This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate:

	Smalltalk pointersToItem: 2 of: self

in the inspector."

	^ self pointersTo: (anArray at: index) except: (Array with: anArray)! !


!SystemDictionary methodsFor: 'shrinking' stamp: 'wod 11/3/1998 15:41'!
abandonSources    "Smalltalk abandonSources"
	"Replaces every method by a copy with the 4-byte source pointer 
	replaced by a string of all arg and temp names, followed by its length.
	These names can then be used to inform the decompiler.  See stats below"
	"wod 11/3/1998: zap the organization before rather than after condensing changes."
	 | oldCodeString argsAndTemps bTotal bCount oldMethods newMethods m |
	(self confirm:  '-- CAUTION --
If you have backed up your system and
are prepared to face the consequences of
abandoning source code files, hit Yes.
If you have any doubts, hit No,
to back out with no harm done.')
		==  true ifFalse: [^ self inform: 'Okay - no harm done'].
	Smalltalk forgetDoIts.
	oldMethods _ OrderedCollection new: CompiledMethod instanceCount.
	newMethods _ OrderedCollection new: CompiledMethod instanceCount.
	bTotal _ 0.  bCount _ 0.
	Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1].
'Saving temp names for better decompilation...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: bTotal
	during: [:bar |
	Smalltalk allBehaviorsDo:    "for test:  (Array with: Arc with: Arc class) do: "
		[:cl |  bar value: (bCount _ bCount + 1).
		cl selectors do:
			[:selector |
			m _ cl compiledMethodAt: selector.
			m fileIndex > 0 ifTrue:
			[oldCodeString _ cl sourceCodeAt: selector.
			argsAndTemps _ (cl compilerClass new
				parse: oldCodeString in: cl notifying: nil)
				tempNames.
			oldMethods addLast: m.
			newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	Smalltalk allBehaviorsDo: [: b | b zapOrganization].
	Smalltalk condenseChanges.
	Preferences disable: #warnIfNoSourcesFile.
"
In a system with 7780 methods, we got 83k of temp names, or around 100k with spaces between.  The order of letter frequency was eatrnoislcmdgpSub, with about 60k falling in the first 11.  This suggests that we could encode in 4 bits, with 0-11 beng most common chars, and 12-15 contributing 2 bits to the next nibble for 6 bits, enough to cover all alphaNumeric with upper and lower case.  If we get 3/4 in 4 bits and 1/4 in 8, then we get 5 bits per char, or about 38% savings (=38k in this case).

Summary: about 13 bytes of temp names per method, or 8 with simple compression, plus 1 for the size.  This would be 5 bytes more than the current 4-byte trailer.
"! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'jm 11/1/1998 08:31'!
abandonTempNames
	"Replaces every method by a copy with no source pointer or encoded temp names."
	"Smalltalk abandonTempNames"

	 | continue oldMethods newMethods n m |
	continue _ (self confirm:  '-- CAUTION --
If you have backed up your system and
are prepared to face the consequences of
abandoning all source code, hit Yes.
If you have any doubts, hit No,
to back out with no harm done.').
	continue ifFalse: [^ self inform: 'Okay - no harm done'].

	Smalltalk forgetDoIts; garbageCollect.
	oldMethods _ OrderedCollection new.
	newMethods _ OrderedCollection new.
	n _ 0.
	'Removing temp names to save space...'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: CompiledMethod instanceCount
		during: [:bar |
			Smalltalk allBehaviorsDo: [:cl |
				cl selectors do: [:sel |
					bar value: (n _ n + 1).
					m _ cl compiledMethodAt: sel.
					oldMethods addLast: m.
					newMethods addLast: (m copyWithTrailerBytes: #(0))]]].
	oldMethods asArray elementsExchangeIdentityWith: newMethods asArray.
	Smalltalk closeSourceFiles.
	Preferences disable: #warnIfNoChangesFile.
	Preferences disable: #warnIfNoSourcesFile.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 00:56'!
discard3D
	"Discard 3D Support.
Updated for 2.8 TPR"

	Smalltalk removeKey: #WonderlandConstants ifAbsent: [].
	Smalltalk removeKey: #AliceConstants ifAbsent: [].
	Smalltalk removeKey: #B3DEngineConstants ifAbsent: [].
	SystemOrganization removeCategoriesMatching: 'Morphic-Balloon3D'.
	SystemOrganization removeCategoriesMatching: 'Balloon3D-*'.
	SystemOrganization removeCategoriesMatching: 'Pooh-*'

! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sma 6/18/2000 12:32'!
discardDiscards
	"Discard all discard* methods - including this one."

	(self class selectors select: [:each | each beginsWith: 'discard']) 
		do: [:each | self class removeSelector: each].
	#(lastRemoval majorShrink zapMVCprojects)
		do: [:each | self class removeSelector: each]! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 8/16/2000 12:12'!
discardFFI
	"Discard the complete foreign function interface.
	NOTE: Recreates specialObjectsArray to prevent obsolete references. Has to specially remove external structure hierarchy before ExternalType"

	(ChangeSet superclassOrder: ExternalStructure withAllSubclasses asArray) reverseDo: 
		[:c | c removeFromSystem].
	Smalltalk removeKey: #FFIConstants ifAbsent: [].
	SystemOrganization removeCategoriesMatching: 'FFI-*'.
	Smalltalk recreateSpecialObjectsArray.! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'!
discardFlash
	"Discard Flash support."

	SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*'
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/17/2000 16:50'!
discardMIDI

	"this seems to have gone away"! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 11/13/2000 17:17'!
discardMVC
   "Smalltalk discardMVC"

	| keepers |

	self flag: #bob.		"zapping projects"

	Smalltalk isMorphic ifFalse:
		[PopUpMenu notify: 'You must be in a Morphic project to discard MVC.'.
		^ self].
	"Check that there are no MVC Projects"
	(Project allProjects allSatisfy: [ :proj | proj isMorphic]) ifFalse:
		[(self confirm: 'Would you like a chance to remove your
MVC projects in an orderly manner?')
					ifTrue: [^ self].
		(self confirm: 'If you wish, I can remove all MVC projects,
make this project be the top project, and place
all orphaned sub-projects of MVC parents here.
Would you like be to do this
and proceed to discard all MVC classes?')
					ifTrue: [self zapMVCprojects]
					ifFalse: [^ self]].
	Smalltalk reclaimDependents.

	"Remove old Paragraph classes and View classes."
	(ChangeSet superclassOrder: Paragraph withAllSubclasses asArray) reverseDo: 
		[:c | c removeFromSystem].
	(ChangeSet superclassOrder: View withAllSubclasses asArray) reverseDo: 
		[:c | c removeFromSystem].

	"Get rid of ParagraphEditor's ScrollController dependence"
	#(markerDelta viewDelta scrollAmount scrollBar computeMarkerRegion) do:
			[:sel | ParagraphEditor removeSelector: sel].
	ParagraphEditor compile: 'updateMarker'.
	ParagraphEditor superclass: MouseMenuController .

	"Get rid of all Controller classes not needed by ParagraphEditor and ScreenController"
	keepers _ TextMorphEditor withAllSuperclasses copyWith: ScreenController.
	(ChangeSet superclassOrder: Controller withAllSubclasses asArray) reverseDo: 
		[:c | (keepers includes: c) ifFalse: [c removeFromSystem]].

	SystemOrganization removeCategoriesMatching: 'ST80-Paths'.
	SystemOrganization removeCategoriesMatching: 'ST80-Pluggable Views'.

	Smalltalk removeClassNamed: 'FormButtonCache'.
	Smalltalk removeClassNamed: 'WindowingTransformation'.
	Smalltalk removeClassNamed: 'ControlManager'.
	Smalltalk removeClassNamed: 'DisplayTextView'.

	ScheduledControllers _ nil.
	Undeclared removeUnreferencedKeys.
	SystemOrganization removeEmptyCategories.
	Symbol rehash.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 8/17/2000 16:00'!
discardMorphic
   "Smalltalk discardMorphic"
	"Discard Morphic.
Updated for 2.8 TPR"

	| subs |
	"Check that we are in an MVC Project and that there are no Morphic Projects
		or WorldMorphViews."
	Utilities clobberFlapTabList.
	Smalltalk discardFlash.
	Smalltalk discardTrueType.
	subs _ OrderedCollection new.
	Morph allSubclassesWithLevelDo: [:c :i | subs addFirst: c]
		startingLevel: 0.
	subs do: [:c | c removeFromSystem].
	Smalltalk removeClassNamed: #CornerRounder.
	Smalltalk removeKey: #BalloonEngineConstants ifAbsent: [].
	SystemOrganization removeCategoriesMatching: 'Balloon-*'.
	SystemOrganization removeCategoriesMatching: 'Morphic-*'.
	SystemOrganization removeSystemCategory: 'Graphics-Transformations'.
	SystemOrganization removeSystemCategory: 'ST80-Morphic'.
	ScriptingSystem _ nil.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:48'!
discardNetworking
	"Discard the support for TCP/IP networking."

	Smalltalk discardPluggableWebServer.
	SystemOrganization removeCategoriesMatching: 'Network-*'.

! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 8/16/2000 14:38'!
discardOddsAndEnds
	"This method throws out lots of classes that are not frequently used."
	"Smalltalk discardOddsAndEnds"

	SystemOrganization removeSystemCategory: 'System-Serial Port'.
	SystemOrganization removeSystemCategory: 'ST80-Symbols'.
	SystemOrganization removeSystemCategory: 'Tools-File Contents Browser'.
	SystemOrganization removeSystemCategory: 'System-Compression'.
	SystemOrganization removeSystemCategory: 'Tools-Explorer'.
	SystemOrganization removeSystemCategory: 'System-Digital Signatures'.

	Form removeSelector: #edit.
	Smalltalk at: #FormView ifPresent:
		[:c | c compile: 'defaultControllerClass  ^ NoController'
			classified: 'controller access'].
	Smalltalk removeClassNamed: #FormEditorView.
	Smalltalk removeClassNamed: #FormEditor.
	SystemOrganization removeSystemCategory: 'ST80-Paths'.

	"bit editor (remove Form editor first):"
	Form removeSelector: #bitEdit.
	Form removeSelector: #bitEditAt:scale:.
	StrikeFont removeSelector: #edit:.
	Smalltalk removeClassNamed: #FormButtonCache.
	Smalltalk removeClassNamed: #FormMenuController.
	Smalltalk removeClassNamed: #FormMenuView.
	Smalltalk removeClassNamed: #BitEditor.

	"inspector for Dictionaries of Forms"
	Dictionary removeSelector: #inspectFormsWithLabel:.
	SystemDictionary removeSelector: #viewImageImports.
	ScreenController removeSelector: #viewImageImports.
	Smalltalk removeClassNamed: #FormHolderView.
	Smalltalk removeClassNamed: #FormInspectView.

	"experimental hand-drawn character recoginizer:"
	ParagraphEditor removeSelector: #recognizeCharacters.
	ParagraphEditor removeSelector: #recognizer:.
	ParagraphEditor removeSelector: #recognizeCharactersWhileMouseIn:.
	Smalltalk removeClassNamed: #CharRecog.

	"experimental updating object viewer:"
	Object removeSelector: #evaluate:wheneverChangeIn:.
	Smalltalk removeClassNamed: #ObjectViewer.
	Smalltalk removeClassNamed: #ObjectTracer.

	"miscellaneous classes:"
	Smalltalk removeClassNamed: #Array2D.
	Smalltalk removeClassNamed: #DriveACar.
	Smalltalk removeClassNamed: #EventRecorder.
	Smalltalk removeClassNamed: #FindTheLight.
	Smalltalk removeClassNamed: #PluggableTest.
	Smalltalk removeClassNamed: #SystemMonitor.
	Smalltalk removeClassNamed: #DocLibrary.

	Smalltalk removeClassNamed: #ProtocolBrowser.
	Smalltalk removeClassNamed: #ObjectExplorerWrapper.
	Smalltalk removeClassNamed: #HierarchyBrowser.
	Smalltalk removeClassNamed: #LinkedMessageSet.
	Smalltalk removeClassNamed: #ObjectExplorer.
	Smalltalk removeClassNamed: #PackageBrowser.
	Smalltalk removeClassNamed: #AbstractHierarchicalList.
	Smalltalk removeClassNamed: #ChangeList.
	Smalltalk removeClassNamed: #VersionsBrowser.
	Smalltalk removeClassNamed: #ChangeRecord.
	Smalltalk removeClassNamed: #SelectorBrowser.
	Smalltalk removeClassNamed: #HtmlFileStream.
	Smalltalk removeClassNamed: #CrLfFileStream.
	Smalltalk removeClassNamed: #FXGrafPort.
	Smalltalk removeClassNamed: #FXBlt.

	Smalltalk at: #SampledSound ifPresent: [:c |c initialize].
	#(Helvetica Palatino Courier ComicBold ComicPlain) do:
		[:k | TextConstants removeKey: k ifAbsent: []].

Preferences setButtonFontTo:	(StrikeFont familyName: #NewYork size: 12).
Preferences setFlapsFontTo:	(StrikeFont familyName: #NewYork size: 12).

#(GZipConstants ZipConstants KlattResonatorIndices ) do:
	[:k | Smalltalk removeKey: k ifAbsent: []].
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:43'!
discardPluggableWebServer
	"Discard the Pluggable Web Server."

	SystemOrganization removeCategoriesMatching: 'Network-PluggableWebServer'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sma 6/25/2000 17:57'!
discardSUnit   "Smalltalk discardSUnit"
	| oc |
	oc _ OrderedCollection new.
	(Smalltalk at: #TestCase ifAbsent: [^ self])
		allSubclassesWithLevelDo: [:c :i | oc addFirst: c]
		startingLevel: 0.
	oc do: [:c | c removeFromSystem].

	SystemOrganization removeCategoriesMatching: 'SUnit-*'! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sma 6/18/2000 11:52'!
discardSoundAndSpeech
	"NOTE: This leaves 26 references to obsolete classes, one in SystemDictionary
	class>>initialize, one in ImageSegment>>restoreEndianness, one in DataStream
	class>>initialize and 23 in Morphic and Flash classes."

	SystemOrganization removeCategoriesMatching: 'Sound-*'.
	SystemOrganization removeCategoriesMatching: 'Speech-*'.
	Smalltalk removeClassNamed: #KlattSynthesizerPlugin.
	Smalltalk removeSelector: #(DigitalSignatureAlgorithm randomBitsFromSoundInput:).
	Smalltalk removeSelector: #(Project beep).
	Preferences setPreference: #soundsEnabled toValue: false! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:21'!
discardSoundSynthesis
	"Discard the sound synthesis facilities, and the methods and classes that use it. This also discards MIDI."

	Smalltalk discardMIDI.
	Smalltalk discardSpeech.
	SystemOrganization removeCategoriesMatching: 'Sound-Interface'.
	Smalltalk at: #GraphMorph ifPresent: [:graphMorph |
		#(playOnce readDataFromFile)
			do: [:sel | graphMorph removeSelector: sel]].
	Smalltalk at: #TrashCanMorph ifPresent: [:trashMorph |
		trashMorph class removeSelector: #samplesForDelete.
		trashMorph class removeSelector: #samplesForMouseEnter.
		trashMorph class removeSelector: #samplesForMouseLeave].
	SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'.
	SystemOrganization removeCategoriesMatching: 'Sound-Scores'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:21'!
discardSpeech
	"Discard support for speech synthesis"

	SystemOrganization removeCategoriesMatching: 'Speech*'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'!
discardTrueType
	"Discard TrueType support."

	SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'.

! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 00:55'!
discardVMConstruction
	"Discard the virtual machine construction classes and the Smalltalk-to-C translator. These are only needed by those wishing to build or study the Squeak virtual machine, or by those wishing to construct new primitives via Smalltalk-to-C translation.
Updated to suit 2.8 TPR"

	"remove the code for virtual machines"
	Smalltalk removeKey: #InterpreterLog ifAbsent: [].

	"remove the Smalltalk-to-C translator"
	Smalltalk at: #CCodeGenerator ifPresent: [:codeGen | codeGen removeCompilerMethods].
	SystemOrganization removeCategoriesMatching: 'VMConstruction-*'.
	SystemOrganization removeCategoriesMatching: 'Squeak-Plugins'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/18/2000 07:56'!
lastRemoval			"Smalltalk lastRemoval"

	 | oldDicts newDicts |

	"Some explicit removals - add unwanted methods keeping other methods."
	#(abandonSources printSpaceAnalysis)
		do: [:each | self class removeSelector: each].

	"Get rid of all unsent methods."
	[self removeAllUnSentMessages > 0] whileTrue.

	"Shrink method dictionaries."
	Smalltalk garbageCollect.
	oldDicts _ MethodDictionary allInstances.
	newDicts _ Array new: oldDicts size.
	oldDicts withIndexDo: [:d :index | 
		newDicts at: index put: d rehashWithoutBecome.
	].
	oldDicts elementsExchangeIdentityWith: newDicts.
	oldDicts _ newDicts _ nil.

	Smalltalk allClassesDo: [:c | c zapOrganization].
	SystemOrganization _ nil.

	Smalltalk changes initialize! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/17/2000 18:19'!
majorShrink    

	| oldDicts newDicts |

"Smalltalk majorShrink; abandonSources; lastRemoval"
	"This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC.  majorShrink produces a 999k image in Squeak 2.8"

	Smalltalk isMorphic ifTrue: [^ self error: 'You can only run majorShrink in MVC'].
	Project current isTopProject ifFalse: [^ self error: 'You can only run majorShrink in the top project'].
	(Smalltalk confirm: 'All sub-projects will be deleted from this image.
You should already have made a backup copy,
or you must save with a different name after shrinking.
Shall we proceed to discard most of the content in this image?')
		ifFalse: [^ PopUpMenu notify: 'No changes have been made.'].

	"Remove all projects but the current one.  - saves 522k"
	ProjectView allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate].
	Project current setParent: Project current.
	MorphWorldView allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate].
	Wonderland removeActorPrototypesFromSystem.
	Player freeUnreferencedSubclasses.
	MorphicModel removeUninstantiatedModels.
	Utilities classPool at: #ScrapsBook put: nil.
	Utilities zapUpdateDownloader.
	ProjectHistory currentHistory initialize.
	Project rebuildAllProjects.

	Smalltalk discardVMConstruction.  "755k"
	Smalltalk discardSoundSynthesis.  "544k"
	Smalltalk discardOddsAndEnds.  "227k"
	Smalltalk discardNetworking.  "234k"
	Smalltalk discard3D.  "407k"
	Smalltalk discardFFI.  "33k"
	Smalltalk discardMorphic.  "1372k"
	Symbol rehash.  "40k"
	"Above by itself saves about 4,238k"

	"Remove references to a few classes to be deleted, so that they won't leave obsolete versions around."
	FileList removeSelector: #fileIntoNewChangeSet.
	ChangeSet class compile: 'defaultName
		^ ''Changes'' ' classified: 'initialization'.
	ScreenController removeSelector: #openChangeManager.
	ScreenController removeSelector: #exitProject.
	ScreenController removeSelector: #openProject.
	ScreenController removeSelector: #viewImageImports.

	"Now delete various other classes.."
	SystemOrganization removeSystemCategory: 'Graphics-Files'.
	SystemOrganization removeSystemCategory: 'System-Object Storage'.
	Smalltalk removeClassNamed: #ProjectController.
	Smalltalk removeClassNamed: #ProjectView.
	"Smalltalk removeClassNamed: #Project."
	Smalltalk removeClassNamed: #Environment.
	Smalltalk removeClassNamed: #Component1.

	Smalltalk removeClassNamed: #FormSetFont.
	Smalltalk removeClassNamed: #FontSet.
	Smalltalk removeClassNamed: #InstructionPrinter.
	Smalltalk removeClassNamed: #ChangeSorter.
	Smalltalk removeClassNamed: #DualChangeSorter.
	Smalltalk removeClassNamed: #EmphasizedMenu.
	Smalltalk removeClassNamed: #MessageTally.

	StringHolder class removeSelector: #originalWorkspaceContents.
	CompiledMethod removeSelector: #symbolic.

	RemoteString removeSelector: #makeNewTextAttVersion.
	Utilities class removeSelector: #absorbUpdatesFromServer.
	Smalltalk removeClassNamed: #PenPointRecorder.
	Smalltalk removeClassNamed: #Path.
	Smalltalk removeClassNamed: #Base64MimeConverter.
	"Smalltalk removeClassNamed: #EToySystem. Dont bother - its very small and used for timestamps etc"
	Smalltalk removeClassNamed: #RWBinaryOrTextStream.
	Smalltalk removeClassNamed: #AttributedTextStream.
	Smalltalk removeClassNamed: #WordNet.
	Smalltalk removeClassNamed: #SelectorBrowser.

	TextStyle allSubInstancesDo:
		[:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))].
	ListParagraph initialize.
	PopUpMenu initialize.
	StandardSystemView initialize.

	Smalltalk noChanges.
	ChangeSorter classPool at: #AllChangeSets 
		put: (OrderedCollection with: Smalltalk changes).
	SystemDictionary removeSelector: #majorShrink.

	[Smalltalk removeAllUnSentMessages > 0]
		whileTrue:
		[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]].
	SystemOrganization removeEmptyCategories.
	Smalltalk allClassesDo: [:c | c zapOrganization].
	Smalltalk garbageCollect.

	'Rehashing method dictionaries . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: MethodDictionary instanceCount
		during: [:bar |
			oldDicts _ MethodDictionary allInstances.
			newDicts _ Array new: oldDicts size.
			oldDicts withIndexDo: [:d :index | 
				bar value: index.
				newDicts at: index put: d rehashWithoutBecome.
			].
			oldDicts elementsExchangeIdentityWith: newDicts.
		].
	oldDicts _ newDicts _ nil.
	Project rebuildAllProjects.
	Smalltalk changes initialize.

	"seems to take more than one try to gc all the weak refs in SymbolTable"

	3 timesRepeat: [
		Smalltalk garbageCollect.
		Symbol compactSymbolTable.
	].
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 6/20/1998 12:33'!
printSpaceAnalysis	"Smalltalk printSpaceAnalysis"

	^ Smalltalk printSpaceAnalysis: 0 on: 'STspace.text'
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 9/26/1999 11:32'!
printSpaceAnalysis: threshold on: fileName
	"Smalltalk printSpaceAnalysis: 1000 on: 'STspace.text0'"

	"If threshold > 0, then only those classes with more than that number
	of instances will be shown, and they will be sorted by total instance space.
	If threshold = 0, then all classes will appear, sorted by name."
	| f codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n stats totalPercent percent |
	Smalltalk garbageCollect.
	totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0.
	stats _ OrderedCollection new.
'Taking statistics...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: self classNames size
	during: [:bar |
	self allClassesDo:
		[:cl | codeSpace _ cl spaceUsed.
		bar value: (n _ n+1).
		Smalltalk garbageCollectMost.
		instCount _ cl instanceCount.
		instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers"
		cl isVariable
			ifTrue: [eltSize _ cl isBytes ifTrue: [1] ifFalse: [4].
					cl allInstancesDo: [:x | instSpace _ instSpace + (x basicSize*eltSize)]]
			ifFalse: [instSpace _ instSpace + (cl instSize*instCount*4)].
		stats add: (Array with: cl name with: codeSpace) , (Array with: instCount with: instSpace).
		totalCodeSpace _ totalCodeSpace + codeSpace.
		totalInstCount _ totalInstCount + instCount.
		totalInstSpace _ totalInstSpace + instSpace]].
	totalPercent _ 0.0.

	f _ FileStream newFileNamed: fileName.
	f timeStamp.
	f nextPutAll: ('Class' padded: #right to: 30 with: $ );
			nextPutAll: ('code space' padded: #left to: 12 with: $ );
			nextPutAll: ('# instances' padded: #left to: 12 with: $ );
			nextPutAll: ('inst space' padded: #left to: 12 with: $ );
			nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr.

	threshold > 0 ifTrue:
		["If inst count threshold > 0, then sort by space"
		stats _ (stats select: [:s | s third >= threshold or: [s fourth > (totalInstSpace // 500)]])
				asSortedCollection: [:s :s2 | s fourth > s2 fourth]].

	stats do:
		[:s | f nextPutAll: (s first padded: #right to: 30 with: $ );
			nextPutAll: (s second printString padded: #left to: 12 with: $ );
			nextPutAll: (s third printString padded: #left to: 12 with: $ );
			nextPutAll: (s fourth printString padded: #left to: 14 with: $ ).
		percent _ s fourth*100.0/totalInstSpace roundTo: 0.1.
		totalPercent _ totalPercent + percent.
		percent >= 0.1 ifTrue:
			[f nextPutAll: (percent printString padded: #left to: 8 with: $ )].
		f cr].

	f cr; nextPutAll: ('Total' padded: #right to: 30 with: $ );
		nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ );
		nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ );
		nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ).
	f close! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'mdr 9/4/2000 11:03'!
printSpaceDifferenceFrom: fileName1 to: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'.
			--- do something that uses space here ---
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'.
		Smalltalk printSpaceDifferenceFrom: 'STspace.text1' to: 'STspace.text2'
"
	| f coll1 coll2 item |
	f _ FileStream readOnlyFileNamed: fileName1.
	coll1 _ OrderedCollection new.
	[f atEnd] whileFalse: [coll1 add: (f upTo: Character cr)].
	f close.
	f _ FileStream readOnlyFileNamed: fileName2.
	coll2 _ OrderedCollection new.
	[f atEnd] whileFalse:
		[item _ (f upTo: Character cr).
		((coll1 includes: item) and: [(item endsWith: 'percent') not])
			ifTrue: [coll1 remove: item]
			ifFalse: [coll2 add: item]].
	f close.
	(StringHolder new contents: (String streamContents: 
			[:s | 
			s nextPutAll: fileName1; cr.
			coll1 do: [:x | s nextPutAll: x; cr].
			s cr; cr.
			s nextPutAll: fileName2; cr.
			coll2 do: [:x | s nextPutAll: x; cr]]))
		openLabel: 'Differential Space Analysis'.
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 12/17/2000 17:17'!
removeAllUnSentMessages   "Smalltalk removeAllUnSentMessages"
	"[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem].
		Smalltalk removeAllUnSentMessages > 0] whileTrue." 

	"Remove all implementations of unsent messages."
	| sels n |
	sels _ self allUnSentMessages.

	"The following should be preserved for doIts, etc"
	#(
		rehashWithoutBecome compactSymbolTable rebuildAllProjects	"needed even after #majorShrink is pulled"
			
		browseAllSelect: printSpaceAnalysis lastRemoval
		scrollBarValue: scrollBarMenuButtonPressed: 
		withSelectionFrom:  to: removeClassNamed:
		dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib
		newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses
		removeAllUnSentMessages abandonSources removeUnreferencedKeys
		reclaimDependents zapOrganization condenseChanges browseObsoleteReferences
		subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:
		methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames:
		startTimerInterruptWatcher unusedClasses) do:
		[:sel | sels remove: sel ifAbsent: []].
	"The following may be sent by perform: in dispatchOnChar..."
	(ParagraphEditor classPool at: #CmdActions) asSet do:
		[:sel | sels remove: sel ifAbsent: []].
	(ParagraphEditor classPool at: #ShiftCmdActions) asSet do:
		[:sel | sels remove: sel ifAbsent: []].
	sels size = 0 ifTrue: [^ 0].

	n _ 0. Smalltalk allBehaviorsDo: [:x | n _ n+1].
	'Removing ', sels size printString , ' messages . . .'
		displayProgressAt: Sensor cursorPoint
		from: 0 to: n
		during:
		[:bar |
		n _ 0.
		self allBehaviorsDo:
			[:class | bar value: (n _ n+1).
			sels do:
				[:sel | class removeSelectorSimply: sel]]].
	^ sels size! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'sma 6/18/2000 11:34'!
removeSelector: descriptor
	"Safely remove a selector from a class (or metaclass). If the class
	or the method doesn't exist anymore, never mind and answer nil.
	This method should be used instead of 'Class removeSelector: #method'
	to omit global class references."

	| class sel |
	class _ Smalltalk at: descriptor first ifAbsent: [^ nil].
	(descriptor size > 2 and: [descriptor second == #class])
		ifTrue:
			[class _ class class.
			sel _ descriptor third]
		ifFalse: [sel _ descriptor second].
	^ class removeSelector: sel! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'di 4/20/1999 12:24'!
unusedClasses
	"Warning: Slow!! Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses (b) has instances or (c) is referred to by some method. Obsolete classes are not included in this list."
	"Smalltalk unusedClasses"

	| unused c n |
	unused _ SortedCollection new.

'Scanning for unused classes...'
	displayProgressAt: Sensor cursorPoint
	from: 0 to: Metaclass instanceCount
	during: [:bar | n _ 0.

	Metaclass allInstancesDo: [:meta | bar value: (n _ n+1).
		c _ meta soleInstance.
		((c ~~ nil) and:
		 [('AnOb*' match: c name asString) not]) ifTrue: [
			((c subclasses size = 0) and:
			 [(c inheritsFrom: FileDirectory) not & (c instanceCount = 0) and:
			 [(Smalltalk includesKey: c name) and: [(Smalltalk allCallsOn: (Smalltalk associationAt: c name)) size = 0]]])
				ifTrue: [unused add: c name]]]].

	^ unused asArray
! !

!SystemDictionary methodsFor: 'shrinking' stamp: 'RAA 11/13/2000 17:27'!
zapMVCprojects
	"Smalltalk zapMVCprojects"
	| window |

	self flag: #bob. "zapping projects"

	Smalltalk garbageCollect.
	"So allInstances is precise"
	Project
		allSubInstancesDo: [:proj | proj isTopProject
				ifTrue: [proj isMorphic
						ifFalse: ["Root project is MVC -- we must become the root"
							CurrentProjectRefactoring currentBeParentToCurrent]]
				ifFalse: [proj parent isMorphic
						ifFalse: [proj isMorphic
								ifTrue: ["Remove Morphic projects from MVC 
									views "
									"... and add them back here."
									window _ (SystemWindow labelled: proj name)
												model: proj.
									window
										addMorph: (ProjectViewMorph on: proj)
										frame: (0 @ 0 corner: 1.0 @ 1.0).
									window openInWorld.
									CurrentProjectRefactoring currentBeParentTo: proj]].
					proj isMorphic
						ifFalse: ["Remove MVC projects from Morphic views"
							Project deletingProject: proj]]]! !


!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/19/1999 22:36'!
add: aClass toList: startUpOrShutDownList after: predecessor
	"Add the name of aClass to the startUp or shutDown list.
	Add it after the name of predecessor, or at the end if predecessor is nil."

	| name earlierName |
	name _ aClass name.
	(self at: name ifAbsent: [nil]) == aClass ifFalse:
		[self error: name , ' cannot be found in Smalltalk dictionary.'].
	predecessor == nil
		ifTrue: ["No-op if alredy in the list."
				(startUpOrShutDownList includes: name) ifFalse:
					[startUpOrShutDownList == StartUpList
						ifTrue: ["Add to end of startUp list"
								startUpOrShutDownList addLast: name]
						ifFalse: ["Add to front of shutDown list"
								startUpOrShutDownList addFirst: name]]]
		ifFalse: ["Add after predecessor, moving it if already there."
				earlierName _ predecessor name.
				(self at: earlierName) == predecessor ifFalse:
					[self error: earlierName , ' cannot be found in Smalltalk dictionary.'].
				(startUpOrShutDownList includes: earlierName) ifFalse:
					[self error: earlierName , ' cannot be found in the list.'].
				startUpOrShutDownList remove: name ifAbsent:[].
				startUpOrShutDownList add: name after: earlierName]! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:38'!
addToShutDownList: aClass
	"This will add a ref to this class at the BEGINNING of the shutDown list."

	self addToShutDownList: aClass after: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'!
addToShutDownList: aClass after: predecessor

	self add: aClass toList: ShutDownList after: predecessor! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:37'!
addToStartUpList: aClass
	"This will add a ref to this class at the END of the startUp list."

	self addToStartUpList: aClass after: nil! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'!
addToStartUpList: aClass after: predecessor

	self add: aClass toList: StartUpList after: predecessor! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'MPH 10/23/2000 13:21'!
getFileNameFromUser
	| newName |
	newName _ FillInTheBlank
		request: 'New File Name?'
		initialAnswer: (FileDirectory localNameFor: self imageName).
	newName = '' ifTrue: [^nil].
	((FileDirectory default includesKey: (self fullNameForImageNamed: newName)) or:
	 [FileDirectory default includesKey: (self fullNameForChangesNamed: newName)]) ifTrue: [
		(self confirm: newName, ' already exists. Overwrite?') ifFalse: [^nil]].
	^newName
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'RAA 6/14/2000 17:21'!
isMorphic
        "Answer true if the user interface is running in Morphic rathern than 
        MVC.  By convention the gloabl variable World is set to nil when MVC is 
        running.  ScheduledControllers could be set to nil when Morphic is 
        running, but this symmetry is not yet in effect."

        ^ World ~~ nil "or: [RequestCurrentWorldNotification signal notNil]"! !

!SystemDictionary methodsFor: 'snapshot and quit'!
lastQuitLogPosition
	^ LastQuitLogPosition! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'!
processShutDownList: quitting
	"Send #shutDown to each class that needs to wrap up before a snapshot."

	self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting.
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'!
processStartUpList: resuming
	"Send #startUp to each class that needs to run initialization after a snapshot."

	self send: #startUp: toClassesNamedIn: StartUpList with: resuming.
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sw 10/13/1998 16:06'!
processUpdates
	"Process update files from a well-known update server.  This method is called at system startup time,   Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically"

	| choice |
	(Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue:
		[choice _ (PopUpMenu labels: 'Yes, Update\No, Not now' withCRs)
			startUpWithCaption: 'Shall I look for new code\updates on the server?' withCRs.
		choice = 1 ifTrue: [Utilities updateFromServer]].
! !

!SystemDictionary methodsFor: 'snapshot and quit'!
quitPrimitive
	"Primitive. Exit to another operating system on the host machine, if one
	exists. All state changes in the object space since the last snapshot are lost.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 113>
	self primitiveFailed! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'mdr 9/4/2000 11:04'!
readDocumentFile
	"Process system updates. Read a document file, if one was provided. Start application."

	| fileName object |
	StartupStamp _ '----STARTUP----', Time dateAndTimeNow printString, ' as ', Smalltalk imageName.
	self processUpdates.
	(Preferences valueOfFlag: #readDocumentAtStartup) ifFalse: [^ self].
	fileName _ Smalltalk getSystemAttribute: 2.
	((fileName ~~ nil) and: [fileName size > 0])
		ifTrue: [
			(fileName asLowercase beginsWith: 'http://')
				ifTrue: [
					"fetch remote file"
					HTTPSocket httpFileIn: fileName]
				ifFalse: [
					"read local file"
					object _ (FileStream readOnlyFileNamed: fileName) fileInObjectAndCode.

					"if launching a .sqo document, send open to the final object"
					(fileName endsWith: '.sqo') ifTrue: [object open]]]
		ifFalse: [
			(Preferences valueOfFlag: #startImagineeringStudio)
				ifTrue: [ScriptingSystem openImagineeringStudio]]! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'!
removeFromShutDownList: aClass

	ShutDownList remove: aClass name ifAbsent: []! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'!
removeFromStartUpList: aClass

	StartUpList remove: aClass name ifAbsent: []! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'MPH 10/24/2000 14:47'!
saveAs

	| newName |
	newName _ self getFileNameFromUser.
	newName isNil ifTrue:[^self].
	self
		saveChangesInFileNamed: (self fullNameForChangesNamed: newName);
		saveImageInFileNamed: (self fullNameForImageNamed: newName);
		logChange: '----SAVEAS ', newName, '----', Date dateAndTimeNow printString.


! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'JMM 11/21/2000 20:28'!
saveAsEmbeddedImage

	| dir newName newImageName newImageSegDir oldImageSegDir haveSegs |
	dir _ FileDirectory default.
	newName _ FillInTheBlank
		request: 'Select existing VM file'
		initialAnswer: (FileDirectory localNameFor: '').
	newName = '' ifTrue: [^self].
	newName _ FileDirectory baseNameFor: newName asFileName.

	newImageName _ newName.
	(dir includesKey: newImageName) ifFalse: [
		^ self notify: 'Unable to find name ',newName, ' Please choose another name.'].

	haveSegs _ false.
	Smalltalk at: #ImageSegment ifPresent: [:theClass | 
		(haveSegs _ theClass instanceCount ~= 0) ifTrue: [
			oldImageSegDir _ theClass segmentDirectory]].

	self logChange: '----SAVEAS ', newName, '----', Date dateAndTimeNow printString.
	self imageName: (dir fullNameFor: newImageName).
	LastImageName _ self imageName.
	self closeSourceFiles.
	haveSegs ifTrue: [
		Smalltalk at: #ImageSegment ifPresent: [:theClass |
			newImageSegDir _ theClass segmentDirectory.	"create the folder"
			oldImageSegDir fileNames do: [:theName | "copy all segment files"
				newImageSegDir 
					copyFileNamed: oldImageSegDir pathName, FileDirectory slash, theName 
					toFileNamed: theName]]].
	self snapshot: true andQuit: true embedded: true.
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'MPH 10/24/2000 14:46'!
saveChangesInFileNamed: aString
	FileDirectory default 
		copyFileWithoutOverwriteConfirmationNamed: self changesName 
		toFileNamed: aString.
	self	setMacFileInfoOn: aString.! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'MPH 10/24/2000 14:46'!
saveImageInFileNamed: aString
	self 
		changeImageNameTo: (FileDirectory default fullNameFor: aString);
		closeSourceFiles; openSourceFiles;  "so SNAPSHOT appears in new changes file"
		saveImageSegments;
		snapshot: true andQuit: false.! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'MPH 10/23/2000 10:39'!
saveImageSegments

	| haveSegs oldImageSegDir newImageSegDir |
	haveSegs _ false.
	Smalltalk at: #ImageSegment ifPresent: [:theClass | 
		(haveSegs _ theClass instanceCount ~= 0) ifTrue: [
			oldImageSegDir _ theClass segmentDirectory]].
	haveSegs ifTrue: [
		Smalltalk at: #ImageSegment ifPresent: [:theClass |
			newImageSegDir _ theClass segmentDirectory.	"create the folder"
			oldImageSegDir fileNames do: [:theName | "copy all segment files"
				| imageSegmentName |
				imageSegmentName _ oldImageSegDir pathName, FileDirectory slash, theName.
				newImageSegDir 
					copyFileWithoutOverwriteConfirmationNamed: imageSegmentName
					toFileNamed: theName]]].
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sw 2/8/1999 12:37'!
saveSession
	self snapshot: true andQuit: false! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 12/12/2000 13:36'!
send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument
	"Send the message #startUp: or #shutDown: to each class named in the list.
	The argument indicates if the system is about to quit (for #shutDown:) or if
	the image is resuming (for #startUp:).
	If any name cannot be found, then remove it from the list."

	| removals class |
	removals _ OrderedCollection new.
	startUpOrShutDownList do:
		[:name |
		class _ self at: name ifAbsent: [nil].
		class == nil
			ifTrue: [removals add: name]
			ifFalse: [class perform: startUpOrShutDown with: argument]].

	"Remove any obsolete entries, but after the iteration"
	startUpOrShutDownList removeAll: removals! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 6/7/1999 21:33'!
setGCParameters
	"Adjust the VM's default GC parameters to avoid premature tenuring."

	Smalltalk vmParameterAt: 5 put: 4000.  "do an incremental GC after this many allocations"
	Smalltalk vmParameterAt: 6 put: 2000.  "tenure when more than this many objects survive the GC"
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 2/2/2001 14:08'!
setPlatformPreferences
	"Set some platform specific preferences on system startup"
	| platform specs |
	Preferences automaticPlatformSettings ifFalse:[^self].
	platform _ self platformName.
	specs _ 	#(	
					(soundStopWhenDone false)
					(soundQuickStart false)
			).
	platform = 'Win32' ifTrue:[
		specs _ #(	
					(soundStopWhenDone true)
					(soundQuickStart false)
				)].
	platform = 'Mac OS' ifTrue:[
		specs _ #(	
					(soundStopWhenDone false)
					(soundQuickStart true)
				)].
	specs do:[:tuple|
		Preferences setPreference: tuple first toValue: (tuple last == #true).
	].
! !

!SystemDictionary methodsFor: 'snapshot and quit'!
shutDown
	^ self closeSourceFiles! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:23'!
shutDownSound
	"No longer used in the release, but retained for backward compatibility"

	Smalltalk at: #SoundPlayer ifPresent: [:class | class shutDown].
! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'JMM 11/21/2000 20:18'!
snapshot: save andQuit: quit
	^self snapshot: save andQuit: quit embedded: false! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 2/2/2001 14:08'!
snapshot: save andQuit: quit embedded: embeddedFlag
	"Mark the changes file and close all files. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer shell. The latter part of this method runs when resuming a previously saved image. The resume logic checks for a document file to process when starting up."

	| resuming msg sourceLink |
	save & (SourceFiles at: 2) notNil ifTrue:
		[msg _  (quit
			ifTrue: ['----QUIT----']
			ifFalse: ['----SNAPSHOT----'])
			, Date dateAndTimeNow printString.
		sourceLink _ ' priorSource: ' , LastQuitLogPosition printString.
		self assureStartupStampLogged.
		LastQuitLogPosition _ (SourceFiles at: 2) setToEnd; position.
		self logChange: msg , sourceLink.
		Transcript cr; show: msg].

	self processShutDownList: quit.
	Cursor write show.
	save ifTrue: [resuming _ embeddedFlag 
					ifTrue: [self snapshotEmbeddedPrimitive] 
					ifFalse: [self snapshotPrimitive].  "<-- PC frozen here on image file"
				resuming == false "guard against failure" ifTrue:
					["Time to reclaim segment files is immediately after a save"
					Smalltalk at: #ImageSegment
						ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]]
		ifFalse: [resuming _ false].
	quit & (resuming == false) ifTrue: [self quitPrimitive].
	Cursor normal show.
	self setGCParameters.
	resuming == true ifTrue: [self clearExternalObjects].
	self processStartUpList: resuming == true.
	resuming == true ifTrue:[
		self setPlatformPreferences.
		self readDocumentFile].
	Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup].
	"Now it's time to raise an error"
	resuming == nil ifTrue:[self error:'Failed to write image file (disk full?)'].
	^ resuming! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'JMM 11/21/2000 21:02'!
snapshotEmbeddedPrimitive
	<primitive: 247>
	^nil "indicates error writing embedded image file"! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 7/22/2000 14:34'!
snapshotPrimitive
	"Primitive. Write the current state of the object memory on a file in the
	same format as the Smalltalk-80 release. The file can later be resumed,
	returning you to this exact state. Return normally after writing the file.
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 97>
	^nil "indicates error writing image file"! !

!SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 3/26/2000 16:12'!
unbindExternalPrimitives
	"Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found."
	<primitive: 570>
	"Do nothing if the primitive fails for compatibility with older VMs"! !


!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/15/1999 16:18'!
aboutThisSystem 
	"Identify software version"

	^ self inform: self systemInformationString! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 2/11/2000 17:23'!
assureStartupStampLogged
	"If there is a startup stamp not yet actually logged to disk, do it now."
	| changesFile |
	StartupStamp ifNil: [^ self].
	(SourceFiles isNil or: [(changesFile _ SourceFiles at: 2) == nil]) ifTrue: [^ self].

	changesFile setToEnd; cr; cr.
	changesFile nextChunkPut: StartupStamp asString; cr.
	StartupStamp _ nil.
	self forceChangesToDisk.! !

!SystemDictionary methodsFor: 'sources, change log'!
changes
	"Answer the current system ChangeSet."

	^SystemChanges! !

!SystemDictionary methodsFor: 'sources, change log'!
closeSourceFiles
	"Shut down the source files if appropriate.  1/29/96 sw: changed so that the closing and nilification only take place if the entry was a FileStream, thus allowing stringified sources to remain in the saved image file"

	1 to: 2 do: [:i |
		((SourceFiles at: i) isKindOf: FileStream)
			ifTrue:
				[(SourceFiles at: i) close.
				SourceFiles at: i put: nil]]! !

!SystemDictionary methodsFor: 'sources, change log'!
copyright
	"The Smalltalk copyright."

	^'Copyright (c) Xerox Corp. 1981, 1982 All rights reserved.
Copyright (c) Apple Computer, Inc. 1985-1996 All rights reserved.'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/15/1999 16:32'!
currentChangeSetString
	"Smalltalk currentChangeSetString"
	^ 'Current Change Set: ', self changes name! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 9/10/1999 15:52'!
currentProjectDo: aBlock
	"So that code can work after removal of Projects"
	Smalltalk at: #Project ifPresent:
		[:projClass | aBlock value: projClass current].! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'tk 1/24/2000 23:01'!
endianness
	| bytes word blt |
	"What endian-ness is the current hardware?  The String '1234' will be stored into a machine word.  On BigEndian machines (the Mac), $1 will be the high byte if the word.  On LittleEndian machines (the PC), $4 will be the high byte."
	"Smalltalk endianness"

	bytes _ ByteArray withAll: #(0 0 0 0).  "(1 2 3 4) or (4 3 2 1)"
	word _ WordArray with: 16r01020304.
	blt _ (BitBlt toForm: (Form new hackBits: bytes)) 
				sourceForm: (Form new hackBits: word).
	blt combinationRule: Form over.  "store"
	blt sourceY: 0; destY: 0; height: 1; width: 4.
	blt sourceX: 0; destX: 0.
	blt copyBits.  "paste the word into the bytes"
	bytes first = 1 ifTrue: [^ #big].
	bytes first = 4 ifTrue: [^ #little].
	self error: 'Ted is confused'.! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'MPH 10/24/2000 14:31'!
externalizeSources   
	"Write the sources and changes streams onto external files."
 	"Smalltalk externalizeSources"

	| sourcesName changesName aFile |
	sourcesName _ self sourcesName.
	(FileDirectory default fileExists: sourcesName)
		ifTrue: [^ self inform:
'Sorry, you must first move or remove the
file named ', sourcesName].
	changesName _ self changesName.
	(FileDirectory default fileExists: changesName)
		ifTrue: [^ self inform:
'Sorry, you must first move or remove the
file named ', changesName].

	aFile _  FileStream newFileNamed: sourcesName.
	aFile nextPutAll: SourceFiles first originalContents.
	aFile close.
	self setMacFileInfoOn: sourcesName.
	SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName).

	aFile _ FileStream newFileNamed: self changesName.
	aFile nextPutAll: SourceFiles last contents.
	aFile close.
	"On Mac, set the file type and creator (noop on other platforms)"
	FileDirectory default
		setMacFileNamed: self changesName
		type: 'STch'
		creator: 'FAST'.
	SourceFiles at: 2 put: (FileStream oldFileNamed: changesName).

	self inform: 'Sources successfully externalized'.
! !

!SystemDictionary methodsFor: 'sources, change log'!
forceChangesToDisk
	"Ensure that the changes file has been fully written to disk by closing and re-opening it. This makes the system more robust in the face of a power failure or hard-reboot."

	| changesFile |
	changesFile _ SourceFiles at: 2.
	(changesFile isKindOf: FileStream) ifTrue: [
		changesFile flush.
		changesFile close.
		changesFile open: changesFile name forWrite: true.
		changesFile setToEnd.
	].
! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 12/5/97 15:30'!
internalizeChangeLog    
		"Smalltalk internalizeChangeLog"
	"Bring the changes file into a memory-resident filestream, for faster access and freedom from external file system.  1/31/96 sw"

	| reply aName aFile |
	reply _ self confirm:  'CAUTION -- do not undertake this lightly!!
If you have backed up your system and
are prepared to face the consequences of
the requested internalization of sources,
hit Yes.  If you have any doubts, hit No
to back out with no harm done.'.

	(reply ==  true) ifFalse:
		[^ self inform: 'Okay - abandoned'].

	aName _ self changesName.
	(aFile _ SourceFiles last) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	self inform: 'Okay, changes file internalized'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 12/5/97 15:30'!
internalizeSources    
		"Smalltalk internalizeSources"
	"Bring the sources and changes files into memory-resident filestreams, for faster access and freedom from file-system interface.  1/29/96 sw"

	| reply aName aFile |
	reply _ self confirm:  'CAUTION -- do not undertake this lightly!!
If you have backed up your system and
are prepared to face the consequences of
the requested internalization of sources,
hit Yes.  If you have any doubts, hit No
to back out with no harm done.'.

	(reply ==  true) ifFalse:
		[^ self inform: 'Okay - abandoned'].

	aName _ self sourcesName.
	(aFile _ SourceFiles first) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 1 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	aName _ self changesName.
	(aFile _ SourceFiles last) == nil ifTrue:
		[(FileDirectory default fileExists: aName)
			ifFalse: [^ self halt: 'Cannot locate ', aName, ' so cannot proceed.'].
		aFile _ FileStream readOnlyFileNamed: aName].
	SourceFiles at: 2 put: (ReadWriteStream with: aFile contentsOfEntireFile).

	self inform: 'Okay, sources internalized'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sma 2/12/2000 12:42'!
lastUpdateString
	"Smalltalk lastUpdateString"
	| aNumber |
	aNumber _ (Smalltalk
		at: #ChangeSorter
		ifAbsent: [^ 'Update # unknown']) highestNumberedChangeSet.
	^ (aNumber notNil and: [aNumber > 0])
		ifTrue: ['latest update: #' , aNumber printString]
		ifFalse: ['No updates present.']! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/12/1999 17:18'!
logChange: aStringOrText 
	"Write the argument, aString, onto the changes file."
	| aString changesFile |
	(SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ self].
	self assureStartupStampLogged.

	aStringOrText isText
		ifTrue: [aString _ aStringOrText string]
		ifFalse: [aString _ aStringOrText].
	(aString isMemberOf: String)
		ifFalse: [self error: 'can''t log this change'].
	(aString findFirst: [:char | char isSeparator not]) = 0
		ifTrue: [^ self].  "null doits confuse replay"
	(changesFile _ SourceFiles at: 2) setToEnd; cr; cr.
	changesFile nextChunkPut: aString.
		"If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here"
	self forceChangesToDisk.! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 3/29/2000 14:23'!
newChanges: aChangeSet 
	"Set the system ChangeSet to be the argument, aChangeSet.  Tell the current project that aChangeSet is now its change set.  When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital"

	SystemChanges isolationSet: nil.
	SystemChanges _ aChangeSet.
	Smalltalk currentProjectDo:
		[:proj |
		proj setChangeSet: aChangeSet.
		aChangeSet isolationSet: proj isolationSet]! !

!SystemDictionary methodsFor: 'sources, change log'!
noChanges 
	"Initialize the system ChangeSet."

	SystemChanges initialize! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 4/28/2000 13:01'!
openSourceFiles
	self imageName = LastImageName ifFalse:
		["Reset the author initials to blank when the image gets moved"
		LastImageName _ self imageName.
		Utilities setAuthorInitials: ''].
	FileDirectory
		openSources: self sourcesName
		andChanges: self changesName
		forImage: LastImageName.
	StandardSourceFileArray install! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:59'!
recover: nCharacters
	"Schedule an editable text view on the last n characters of changes."
	self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 8/16/2000 12:33'!
setVersion: aString
	"Set the version of this image."
	"Smalltalk setVersion: EToySystem version , ' of ' , EToySystem versionDate"

	VersionString _ aString! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/15/1999 16:34'!
systemInformationString
	"Identify software version"
	^ self version, String cr, self lastUpdateString, String cr, self currentChangeSetString

"
	(eToySystem _ self at: #EToySystem ifAbsent: [nil]) ifNotNil:
		[aString _ aString, '
Squeak-Central version: ', eToySystem version, ' of ', eToySystem versionDate]."! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 9/27/1999 10:41'!
timeStamp: aStream 
	"Writes system version and current time on stream aStream."

	| dateTime |
	dateTime _ Time dateAndTimeNow.
	aStream nextPutAll: 'From ', Smalltalk version, ' [', Smalltalk lastUpdateString, '] on ', (dateTime at: 1) printString,
						' at ', (dateTime at: 2) printString! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'di 8/16/2000 12:32'!
version
	"Answer the version of this release."

	^ VersionString! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:58'!
writeRecentCharacters: nCharacters toFileNamed: aFilename
	"Schedule an editable text view on the last n characters of changes."
	| changes |
	changes _ SourceFiles at: 2.
	changes setToEnd; skip: nCharacters negated.
	(FileStream newFileNamed: aFilename) nextPutAll: (changes next: nCharacters); close; open; edit! !

!SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 16:17'!
writeRecentToFile
	| numChars aDirectory aFileName |
	"Smalltalk writeRecentToFile"
	aDirectory _ FileDirectory default.
	aFileName _ Utilities keyLike: 'squeak-recent.01' withTrailing: '.log' satisfying:
		[:aKey | (aDirectory includesKey: aKey) not].
	numChars _ ChangeList getRecentLocatorWithPrompt: 'copy logged source as far back as...'.
	numChars ifNotNil:
		[Smalltalk writeRecentCharacters: numChars toFileNamed: aFileName]! !


!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:36'!
clearExternalObjects
	"Clear the array of objects that have been registered for use in non-Smalltalk code."
	"Smalltalk clearExternalObjects"

	ExternalSemaphoreTable clearExternalObjects
! !

!SystemDictionary methodsFor: 'special objects'!
compactClassesArray  "Smalltalk compactClassesArray"
	"Return the array of 31 classes whose instances may be
	represented compactly"
	^ Smalltalk specialObjectsArray at: 29! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 21:01'!
externalObjects
	"Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress."
	"Smalltalk externalObjects"

	^ ExternalSemaphoreTable externalObjects
! !

!SystemDictionary methodsFor: 'special objects'!
hasSpecialSelector: aLiteral ifTrueSetByte: aBlock

	1 to: self specialSelectorSize do:
		[:index | 
		(self specialSelectorAt: index) == aLiteral
			ifTrue: [aBlock value: index + 16rAF. ^true]].
	^false! !

!SystemDictionary methodsFor: 'special objects' stamp: 'ar 12/7/1999 18:12'!
recreateSpecialObjectsArray    "Smalltalk recreateSpecialObjectsArray"
	"The Special Objects Array is an array of object pointers used by the
	Smalltalk virtual machine.  Its contents are critical and unchecked,
	so don't even think of playing here unless you know what you are doing."
	| newArray |
	newArray _ Array new: 48.
	"Nil false and true get used throughout the interpreter"
	newArray at: 1 put: nil.
	newArray at: 2 put: false.
	newArray at: 3 put: true.
	"This association holds the active process (a ProcessScheduler)"
	newArray at: 4 put: (Smalltalk associationAt: #Processor).
	"Numerous classes below used for type checking and instantiation"
	newArray at: 5 put: Bitmap.
	newArray at: 6 put: SmallInteger.
	newArray at: 7 put: String.
	newArray at: 8 put: Array.
	newArray at: 9 put: Smalltalk. 
	newArray at: 10 put: Float.
	newArray at: 11 put: MethodContext.
	newArray at: 12 put: BlockContext.
	newArray at: 13 put: Point.
	newArray at: 14 put: LargePositiveInteger.
	newArray at: 15 put: Display.
	newArray at: 16 put: Message.
	newArray at: 17 put: CompiledMethod.
	newArray at: 18 put: (self specialObjectsArray at: 18)  "(low space Semaphore)".
	newArray at: 19 put: Semaphore.
	newArray at: 20 put: Character.
	newArray at: 21 put: #doesNotUnderstand:.
	newArray at: 22 put: #cannotReturn:.
	newArray at: 23 put: nil.  "*unused*"
	"An array of the 32 selectors that are compiled as special bytecodes,
	paired alternately with the number of arguments each takes."
	newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ).
	"An array of the 255 Characters in ascii order."
	newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]).
	newArray at: 26 put: #mustBeBoolean.
	newArray at: 27 put: ByteArray.
	newArray at: 28 put: Process.
	"An array of up to 31 classes whose instances will have compact headers"
	newArray at: 29 put: self compactClassesArray.
	newArray at: 30 put: (self specialObjectsArray at: 30)   "(delay Semaphore)".
	newArray at: 31 put: (self specialObjectsArray at: 31)   "(user input Semaphore)".

	"Prototype instances that can be copied for fast initialization"
	newArray at: 32 put: (Float new: 2).
	newArray at: 33 put: (LargePositiveInteger new: 4).
	newArray at: 34 put: Point new.
	newArray at: 35 put: #cannotInterpret:.
	"Note: This must be fixed once we start using context prototypes"
	newArray at: 36 put: (self specialObjectsArray at: 36). 
						"(MethodContext new: CompiledMethod fullFrameSize)."
	newArray at: 37 put: nil.
	newArray at: 38 put: (self specialObjectsArray at: 38). 
						"(BlockContext new: CompiledMethod fullFrameSize)."

	newArray at: 39 put: Array new.  "array of objects referred to by external code"

	newArray at: 40 put: PseudoContext.
	newArray at: 41 put: TranslatedMethod.

	"finalization Semaphore"
	newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil:[Semaphore new]).

	newArray at: 43 put: LargeNegativeInteger.

	"External objects for callout.
	Note: Written so that one can actually completely remove the FFI."
	newArray at: 44 put: (Smalltalk at: #ExternalAddress ifAbsent:[nil]).
	newArray at: 45 put: (Smalltalk at: #ExternalStructure ifAbsent:[nil]).
	newArray at: 46 put: (Smalltalk at: #ExternalData ifAbsent:[nil]).
	newArray at: 47 put: (Smalltalk at: #ExternalFunction ifAbsent:[nil]).
	newArray at: 48 put: (Smalltalk at: #ExternalLibrary ifAbsent:[nil]).

	"Now replace the interpreter's reference in one atomic operation"
	self specialObjectsArray become: newArray! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:39'!
registerExternalObject: anObject
	"Register the given object in the external objects array and return its index. If it is already there, just return its index."

	^ExternalSemaphoreTable registerExternalObject: anObject! !

!SystemDictionary methodsFor: 'special objects'!
specialNargsAt: anInteger 
	"Answer the number of arguments for the special selector at: anInteger."

	^ (self specialObjectsArray at: 24) at: anInteger * 2! !

!SystemDictionary methodsFor: 'special objects'!
specialObjectsArray  "Smalltalk specialObjectsArray at: 1"
	<primitive: 129>
	^ self primitiveFailed! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectorAt: anInteger 
	"Answer the special message selector from the interleaved specialSelectors array."

	^ (self specialObjectsArray at: 24) at: anInteger * 2 - 1! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectorSize
	"Answer the number of special selectors in the system."

	^ (self specialObjectsArray at: 24) size // 2! !

!SystemDictionary methodsFor: 'special objects'!
specialSelectors
	"Used by SystemTracer only."

	^SpecialSelectors! !

!SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:40'!
unregisterExternalObject: anObject
	"Unregister the given object in the external objects array. Do nothing if it isn't registered."

	ExternalSemaphoreTable unregisterExternalObject: anObject! !


!SystemDictionary methodsFor: 'copying' stamp: 'tk 10/20/2000 11:35'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemDictionary class
	instanceVariableNames: ''!

!SystemDictionary class methodsFor: 'initialization' stamp: 'tk 9/23/1999 17:47'!
initialize
	"SystemDictionary initialize"

	| oldList |
	oldList _ StartUpList.
	StartUpList _ OrderedCollection new.
	"These get processed from the top down..."
	Smalltalk addToStartUpList: DisplayScreen.
	Smalltalk addToStartUpList: Cursor.
	Smalltalk addToStartUpList: InputSensor.
	Smalltalk addToStartUpList: ProcessorScheduler.  "Starts low space watcher and bkground."
	Smalltalk addToStartUpList: Delay.
	Smalltalk addToStartUpList: FileDirectory.  "Enables file stack dump and opens sources."
	Smalltalk addToStartUpList: ShortIntegerArray.
	Smalltalk addToStartUpList: ShortRunArray.
	Smalltalk addToStartUpList: CrLfFileStream.
	oldList ifNotNil: [oldList do: [:className | Smalltalk at: className
						ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]].
	Smalltalk addToStartUpList: ImageSegment.
	Smalltalk addToStartUpList: PasteUpMorph.
	Smalltalk addToStartUpList: ControlManager.

	oldList _ ShutDownList.
	ShutDownList _ OrderedCollection new.
	"These get processed from the bottom up..."
	Smalltalk addToShutDownList: DisplayScreen.
	Smalltalk addToShutDownList: Form.
	Smalltalk addToShutDownList: ControlManager.
	Smalltalk addToShutDownList: StrikeFont.
	Smalltalk addToShutDownList: Color.
	Smalltalk addToShutDownList: FileDirectory.
	Smalltalk addToShutDownList: Delay.
	Smalltalk addToShutDownList: SoundPlayer.
	Smalltalk addToShutDownList: HttpUrl.
	Smalltalk addToShutDownList: Password.
	Smalltalk addToShutDownList: PWS.
	Smalltalk addToShutDownList: MailDB.
	Smalltalk addToShutDownList: ImageSegment.

	oldList ifNotNil: [oldList reverseDo: [:className | Smalltalk at: className
						ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]].
! !
Object subclass: #SystemMonitor
	instanceVariableNames: 'window labels valSelectors baselineSkip minValues maxValues vmParameters gcLowWaterMark gcHighWaterMark prevAllocCount prevAllocRate prevFullGC prevDeltaFullGC prevIncrGC prevDeltaIncrGC prevMsClock prevMcMiss prevMcHit prevIcHit '
	classVariableNames: 'ActiveClock ActiveMonitor BackgroundColor BarBackgroundColor BarBorderColor BarBorderWidth BarColors BarForegroundColor BarWidth BorderColor BorderWidth DefaultBarHeight ForegroundColor Inset MonitorDelay '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!

!SystemMonitor methodsFor: 'initialize-release' stamp: 'di 11/4/97 20:03'!
labels: labelArray selectors: selectorArray

	| labelHeight labelWidth topLeft bottomRight |
	self readVMParameters.
	minValues _ selectorArray collect: [:str | self perform: (str , 'Min') asSymbol].
	maxValues _ selectorArray collect: [:str | self perform: (str , 'Max') asSymbol].
	valSelectors _ selectorArray collect: [:str | (str , 'Val') asSymbol].

	labels _ labelArray collect: [:str |
		(DisplayText text: str asText)
			foregroundColor: ForegroundColor
			backgroundColor: BackgroundColor].

	baselineSkip _ (labels at: 1) height.
	baselineSkip = 0
		ifTrue:	"empty lables: use a completely undecorated display, flush-bottom/left"
			[baselineSkip _ DefaultBarHeight.
			labelHeight _ baselineSkip * labels size.
			topLeft _ 0@(Display height - labelHeight + BarBorderWidth).
			bottomRight _ BarWidth@(Display height).
			window _ topLeft corner: bottomRight]
		ifFalse:
			[labelHeight _ baselineSkip * labels size.
			labelWidth _ (labels inject: 0 into: [:max :lbl | max max: lbl width]) + (Inset * 2) + BarBorderWidth.
			topLeft _ 0@(Display height - labelHeight - (Inset * 2)).
			bottomRight _ (labelWidth + (2*Inset) + BarWidth)@(Display height).
			window _ (topLeft corner: bottomRight) insetBy: Inset.
			"window _ window translateBy: (BorderWidth negated)@BorderWidth."
			self displayBordersAndLabels]! !


!SystemMonitor methodsFor: 'displaying' stamp: 'di 11/4/97 20:03'!
display
	| barOrigin delta curVal minVal maxVal |
	self readVMParameters.
	barOrigin _ window topRight translateBy: (BarWidth negated - BarBorderWidth)@BarBorderWidth.
	delta _ 0@baselineSkip.
	1 to: valSelectors size do: [:index |
		curVal _ self perform: (valSelectors at: index).
		minVal _ minValues at: index.
		maxVal _ maxValues at: index.
		curVal class == Array
			ifTrue:
				["implicitly trust the system to return sensible values"
				self displayBars: curVal from: minVal to: maxVal
					in: (barOrigin extent: BarWidth@(baselineSkip - (BarBorderWidth * 2)))]
			ifFalse:
				["adjust the bounds if necessary"
				minVal > curVal ifTrue: [minValues at: index put: (minVal _ curVal)].
				maxVal < curVal ifTrue: [maxValues at: index put: (maxVal _ curVal)].
				self displayBar: curVal from: minVal to: maxVal
					in: (barOrigin extent: BarWidth@(baselineSkip - (BarBorderWidth * 2)))].
		barOrigin _ barOrigin translateBy: delta].! !

!SystemMonitor methodsFor: 'displaying' stamp: 'di 11/4/97 20:03'!
displayBar: val from: min to: max in: barRect
	| break |
	break _ barRect left + (((val - min) / (max - min)) * barRect width) asInteger.
	Display fill: (barRect withRight: break) fillColor: (BarColors at: 1).
	Display fill: (barRect withLeft: break) fillColor: BarBackgroundColor.! !

!SystemMonitor methodsFor: 'displaying' stamp: 'di 11/4/97 20:03'!
displayBars: vals from: min to: max in: barRect
	| break prevBreak |
	prevBreak _ barRect left.
	vals doWithIndex: [:val :index |
		break _ barRect left + (((val - min) / (max - min)) * barRect width) asInteger.
		Display fill: ((barRect withLeft: prevBreak) withRight: break) fillColor: (BarColors at: index).
		prevBreak _ break].
	Display fill: (barRect withLeft: prevBreak) fillColor: BarBackgroundColor.! !

!SystemMonitor methodsFor: 'displaying' stamp: 'di 11/4/97 20:03'!
displayBordersAndLabels

	| labelOrigin barOrigin delta |
	Display fill: (window insetBy: Inset negated) fillColor: BorderColor.
	Display fill: (window insetBy: BorderWidth - Inset) fillColor: BackgroundColor.

	barOrigin _ window topRight translateBy: (BarWidth negated - (2 * BarBorderWidth))@0.
	labelOrigin _ barOrigin translateBy: (Inset negated)@"0"(BorderWidth - Inset).
	delta _ 0@baselineSkip.
	1 to: labels size do: [:index |
		(labels at: index) displayOn: Display at: (labelOrigin translateBy: ((labels at: index) width negated)@0).
		Display fill: (barOrigin extent: (BarWidth + (2 * BarBorderWidth))@baselineSkip)
			fillColor: BarBorderColor.
		labelOrigin _ labelOrigin translateBy: delta.
		barOrigin _ barOrigin translateBy: delta].! !


!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
allocationRateMax
	^1! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
allocationRateMin
	prevAllocCount _ 0.
	prevAllocRate _ 0.
	^0! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
allocationRateVal

	| rate allocCount |
	allocCount _ vmParameters at: 4.
	rate _ allocCount < prevAllocCount
		ifTrue: [prevAllocRate]
		ifFalse: [allocCount - prevAllocCount].
	prevAllocCount _ allocCount.
	prevAllocRate _ (prevAllocRate // 2) + (rate // 2).
	^prevAllocRate! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'ikp 1/13/98 00:54'!
cacheMax
	^100! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'ikp 1/13/98 01:00'!
cacheMin
	prevMcMiss _ vmParameters at: 15.
	prevMcHit _ vmParameters at: 16.
	prevIcHit _ vmParameters at: 17.
	^0! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'jm 10/20/1998 11:36'!
cacheVal
	| icHit mcHit mcMiss total deltaMcMiss deltaMcHit deltaIcHit |
	mcMiss _ vmParameters at: 15.
	deltaMcMiss _ mcMiss - prevMcMiss.
	prevMcMiss _ mcMiss.
	mcHit _ vmParameters at: 16.
	deltaMcHit _ mcHit - prevMcHit.
	prevMcHit _ mcHit.
	icHit _ vmParameters at: 17.
	deltaIcHit _ icHit - prevIcHit.
	prevIcHit _ icHit.
	total _ deltaMcMiss + deltaMcHit + deltaIcHit.
	total = 0 ifTrue: [total _ 1].
	deltaMcMiss _ (deltaMcMiss * 100 / total asInteger).
	deltaMcHit _ (deltaMcHit * 100 / total asInteger).
	^Array
		with: deltaMcMiss
		with: deltaMcMiss + deltaMcHit! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'ikp 1/13/98 00:11'!
gcMax
	^100! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'ikp 1/13/98 00:23'!
gcMin
	prevMsClock _ Time millisecondClockValue.
	prevFullGC _ vmParameters at: 8.
	prevDeltaFullGC _ 0.
	prevIncrGC _ vmParameters at: 10.
	prevDeltaIncrGC _ 0.
	^0! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'ikp 1/13/98 00:22'!
gcVal
	| ms fullGC incrGC deltaMs deltaFull deltaIncr max |
	ms _ Time millisecondClockValue.
	fullGC _ (vmParameters at: 8).
	incrGC _ (vmParameters at: 10).
	deltaMs _ ms - prevMsClock.
	deltaFull _ fullGC - prevFullGC.
	deltaIncr _ incrGC - prevIncrGC.
	prevMsClock _ ms.
	prevFullGC _ fullGC.
	prevIncrGC _ incrGC.
	prevDeltaFullGC _ prevDeltaFullGC + deltaFull / 2.
	prevDeltaIncrGC _ prevDeltaIncrGC + deltaIncr / 2.
	max _ deltaMs * 2.
	^Array
		with: (prevDeltaFullGC * 100 / max) asInteger
		with: (prevDeltaIncrGC * 100 / max) asInteger! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
memoryMax
	^vmParameters at: 3! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
memoryMin
	"Setup the gc low/high water marks at the same time"
	gcLowWaterMark _ vmParameters at: 1.
	gcHighWaterMark _ vmParameters at: 1.
	^0! !

!SystemMonitor methodsFor: 'system parameters' stamp: 'di 11/4/97 20:03'!
memoryVal
	"If youngStart is below the highWaterMark then a full collection has happened."
	| youngStart |
	youngStart _ vmParameters at: 1.
	youngStart < gcHighWaterMark ifTrue: [gcLowWaterMark _ gcHighWaterMark _ youngStart].
	youngStart > gcHighWaterMark ifTrue: [gcHighWaterMark _ youngStart].
	^Array
		with: gcLowWaterMark
		with: gcHighWaterMark
		with: (vmParameters at: 2)! !


!SystemMonitor methodsFor: 'private' stamp: 'di 11/4/97 20:03'!
readVMParameters
	vmParameters _ Smalltalk getVMParameters.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemMonitor class
	instanceVariableNames: ''!

!SystemMonitor class methodsFor: 'class initialization' stamp: 'ikp 1/13/98 01:18'!
initialize	"SystemMonitor initialize"

	MonitorDelay _ 1000.								"milliseconds between updates"

	Inset _ 2.										"inset from monitor border (outside) to bars and labels"
	BorderWidth _ 1.									"width of border around entire monitor"
	BorderColor _ Color black.						"colour of border around entire monitor"
	BackgroundColor _ Color gray.		"background colour for monitor area"
	ForegroundColor _ Color black.					"foreground colour for bar labels"

	DefaultBarHeight _ 8.							"height of bar for undecorated display (no labels)"
	BarWidth _ 200.									"horizontal (long-axis) size of each bar"
	BarBorderWidth _ 1.								"width of border around each bar"
	BarBorderColor _ Color black.					"colour of border around each bar"
	BarBackgroundColor _ Color veryLightGray.		"background colour (inactive region) of bar"
	BarColors _ Array
		with: Color darkGray						"colour of first bar segment"
		with: Color lightRed						"colour of second bar segment"
		with: Color lightBlue							"colour of third bar segment"
		with: Color lightGreen.						"colour of fourth bar segment"! !


!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:52'!
cache
	^super new
		labels: #(cache)
		selectors: #(cache).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:53'!
cacheUndecorated
	^super new labels: #('') selectors: #(cache).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:53'!
default
	^super new
		labels: #(cache memory gc)
		selectors: #(cache memory gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:53'!
defaultUndecorated
	^super new labels: #('' '' '') selectors: #(cache memory gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:53'!
full
	^super new
		labels: #('alloc' cache mem gc)
		selectors: #(allocationRate cache memory gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/13/98 00:53'!
fullUndecorated
	^super new
		labels: #('' '' '' '')
		selectors: #(allocationRate cache memory gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/12/98 23:51'!
gc
	^super new
		labels: #(gc)
		selectors: #(gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/12/98 23:51'!
gcUndecorated
	^super new labels: #('') selectors: #(gc).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/14/98 02:25'!
memory
	^super new
		labels: #(memory)
		selectors: #(memory).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'ikp 1/14/98 02:25'!
memoryUndecorated
	^super new
		labels: #('')
		selectors: #(memory).! !

!SystemMonitor class methodsFor: 'instance creation' stamp: 'di 11/4/97 20:03'!
new
	^self default! !


!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
restore		"SystemMonitor restore"

	ActiveMonitor = nil ifFalse: [ActiveMonitor displayBordersAndLabels; display]! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
start		"SystemMonitor start"

	self startDefault! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/13/98 00:54'!
startCache		"SystemMonitor startCache"

	self start: self cache! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/13/98 00:54'!
startCacheUndecorated		"SystemMonitor startCacheUndecorated"

	self start: self cacheUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
startDefault		"SystemMonitor startDefault"

	self start: self default! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
startDefaultUndecorated		"SystemMonitor startDefaultUndecorated"

	self start: self defaultUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
startFull		"SystemMonitor startFull"

	self start: self full! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
startFullUndecorated		"SystemMonitor startFullUndecorated"

	self start: self fullUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/12/98 23:52'!
startGC		"SystemMonitor startGC"

	self start: self gc! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/12/98 23:52'!
startGCUndecorated		"SystemMonitor startGCUndecorated"

	self start: self gcUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/14/98 02:25'!
startMemory		"SystemMonitor startMemory"

	self start: self memory! !

!SystemMonitor class methodsFor: 'public access' stamp: 'ikp 1/14/98 02:26'!
startMemoryUndecorated		"SystemMonitor startMemoryUndecorated"

	self start: self memoryUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
startUndecorated		"SystemMonitor startUndecorated"

	self startDefaultUndecorated! !

!SystemMonitor class methodsFor: 'public access' stamp: 'di 11/4/97 20:03'!
stop		"SystemMonitor stop"

	ActiveClock = nil
		ifFalse:
			[ActiveClock terminate.
			ActiveClock _ nil].
	ActiveMonitor = nil ifFalse: [ActiveMonitor _ nil].! !


!SystemMonitor class methodsFor: 'scheduling' stamp: 'ikp 1/13/98 01:28'!
start: aMonitor
	self stop.
	ActiveMonitor _ aMonitor.
	ActiveClock _
		[[true] whileTrue:
			[ActiveMonitor display.
			(Delay forMilliseconds: MonitorDelay) wait]] newProcess.
	ActiveClock priority: Processor lowIOPriority.
	ActiveClock resume! !
ClassOrganizer subclass: #SystemOrganizer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!
!SystemOrganizer commentStamp: '<historical>' prior: 0!
My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.!


!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 8/16/2000 10:03'!
fileOut  "SystemOrganization fileOut"

	(FileStream newFileNamed:
		(FileDirectory default nextNameFor: 'SystemOrganization' extension: 'st'))
		nextPutAll: 'SystemOrganization changeFromCategorySpecs: #('; cr;
		print: SystemOrganization;  "ends with a cr"
		nextPutAll: ')!!'; cr;
		close.! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 19:01'!
fileOutCategory: category 
	"Store on the file named category (a string) concatenated with '.st' all the 
	classes associated with the category."
	^ self fileOutCategory: category asHtml: false! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:33'!
fileOutCategory: category asHtml: useHtml
	"FileOut all the classes in the named system category."
	| fileStream |
	fileStream _ useHtml
		ifTrue: [(FileStream newFileNamed: category , '.html') asHtml]
		ifFalse: [FileStream newFileNamed: category , '.st'].
	self fileOutCategory: category on: fileStream initializing: true.
	fileStream close! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:28'!
fileOutCategory: category on: aFileStream 
	"Store on the file associated with aFileStream, all the classes associated 
	with the category and any requested shared pools."
	^self fileOutCategory: category on: aFileStream initializing: true! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:28'!
fileOutCategory: category on: aFileStream initializing: aBool
	"Store on the file associated with aFileStream, all the classes associated 
	with the category and any requested shared pools."

	| first poolSet tempClass classes |
	classes _ (self superclassOrder: category).
	poolSet _ Set new.
	classes do: 
		[:class | class sharedPools do: [:eachPool | poolSet add: eachPool]].
	poolSet size > 0 ifTrue:
		[tempClass _ Class new.
		tempClass shouldFileOutPools ifTrue:
			[poolSet _ poolSet select: [:aPool | tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)].
			poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]].
	first _ true.
	classes do: 
		[:class | 
		first
			ifTrue: [first _ false]
			ifFalse: [aFileStream cr; nextPut: Character newPage; cr].
		class
			fileOutOn: aFileStream
			moveSource: false
			toFile: 0
			initializing: false].
	aBool ifTrue:[classes do:[:cls| cls fileOutInitializerOn: aFileStream]].! !

!SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'tk 9/28/2000 15:50'!
objectForDataStream: refStrm
	| dp |
	"I am about to be written on an object file.  Write a path to me in the other system instead."

self == SystemOrganization ifTrue: [
	dp _ DiskProxy global: #SystemOrganization selector: #yourself args: #().
	refStrm replace: self with: dp.
	^ dp].
^ self
! !

!SystemOrganizer methodsFor: 'fileIn/Out'!
superclassOrder: category 
	"Answer an OrderedCollection containing references to the classes in the 
	category whose name is the argument, category (a string). The classes 
	are ordered with superclasses first so they can be filed in."

	| list |
	list _ 
		(self listAtCategoryNamed: category asSymbol) 
			collect: [:title | Smalltalk at: title].
	^ChangeSet superclassOrder: list! !


!SystemOrganizer methodsFor: 'remove' stamp: 'di 1/9/98 12:37'!
removeCategoriesMatching: matchString
	"Remove all matching categories with their classes"
	(self categories select: [:c | matchString match: c]) do:
		[:c | self removeSystemCategory: c]! !

!SystemOrganizer methodsFor: 'remove' stamp: 'jm 5/20/1998 19:38'!
removeMissingClasses
	"Remove any class names that are no longer in the Smalltalk dictionary. Used for cleaning up after garbage collecting user-generated classes."
	"SystemOrganization removeMissingClasses"

	elementArray copy do: [:el |
		(Smalltalk includesKey: el) ifFalse: [self removeElement: el]].
! !

!SystemOrganizer methodsFor: 'remove' stamp: 'di 9/10/1999 09:37'!
removeSystemCategory: category
	"remove all the classes associated with the category"

	(self superclassOrder: category) reverseDo: [:class | class removeFromSystem].
	self removeEmptyCategories! !
PhraseTileMorph subclass: #SystemQueryPhrase
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!SystemQueryPhrase methodsFor: 'initialization' stamp: 'sw 8/3/1998 14:46'!
initialize
	super initialize.
	self removeAllMorphs.
	resultType _ #boolean! !


!SystemQueryPhrase methodsFor: 'access' stamp: 'sw 8/3/1998 14:48'!
actualObject
	^ nil! !

!SystemQueryPhrase methodsFor: 'access' stamp: 'sw 8/11/1998 16:42'!
associatedPlayer
	^ nil! !

!SystemQueryPhrase methodsFor: 'access' stamp: 'sw 8/3/1998 14:50'!
isBoolean
	^ true! !


!SystemQueryPhrase methodsFor: 'code generation' stamp: 'sw 8/3/1998 14:51'!
storeCodeOn: aStream indent: tabCount
	submorphs first storeCodeOn: aStream indent: tabCount! !
Object subclass: #SystemTracer
	instanceVariableNames: 'oopMap map file writeDict maxOop specialObjects initialProcess hashGenerator imageHeaderSize cleaningUp compactClasses replacementClasses '
	classVariableNames: 'Clamped NewNil UnassignedOop '
	poolDictionaries: ''
	category: 'VMConstruction-Interpreter'!
!SystemTracer commentStamp: '<historical>' prior: 0!
NOTE:  The SystemTracer was invented by Ted Kaehler.  It has gone through many variations.  I have simplified it and adapted it to work with Squeak's limited Object hashing.  It has written runnable Mac images on a Mac.  Some changes may be needed for it to produce runnable images on a bigEndian machine.  -- Dan I. 9/29/97

The SystemTracer runs through the system tracing every accessible object, and writing a copy of each object onto a disk image. It does this carefully enough that the resulting clone can be started up and run, just like a snapshot.  Great care must also be taken that the tracer never sees (due to clamping) any of the structures created dynamically while writing the clone.  If this happens an infinite recursion can result.
	
The tracer has built-in support for clamping unwanted (or unneeded) objects out of the system. It also allows fundamental changes to, eg, object header format, compiledMethod format, number formats, etc.  The current version is fairly simple, as it just copies what is already in the system. This version does, however, reassign object hashes in order to illustrate how one must remap all the hashed structures accordingly.

Squeak currently only has 12 bits of object hash.  A normal dictionary, used to map from old oop to new oop, would bog down in a system of, say, 50k objects.  This tracer has a special structure that is optimized for this purpose.  See the comment in initOopMap.  If we ever extend the object hash, this structure could be replaced by a simple IdentityDictionary.

When you first start up the cloned image, you will probably get a "cannotReturn" error, a vestige of the old tracing process.  This can simply be closed (or maybe you can figure out how to fix the tracers so it doens't happen ;-).  

Further comment from Tim Rowledge's message about replacing classes...

The cloner already does a great job of allowing one to leave out classes,
individual instances, change representation of particular objects etc.

However, when doing the ncm stuff I needed a way to build the new class in
the image and test it before cloning. Thus at clone-time I needed to
a) replace each compiled method with a new compiled method
b) replace the class CompiledMethod with  NewCompiledMethod
c) get rid of the now-redundant CompiledMethod class

Doing a) is easy, that is the stock in trade of the cloner.
Doing b) & c) is a little more complicated since I wanted to catch every
reference to CM and write it out as a reference to NCM and also  needed to
'clamp' CM.

To do this we need to make sure that when a ref to CM is found we not only
write out the replacement reference to NCM instead, but that we log both CM
and NCM as having been dealt with by putting _both_ into the oopmap with
the same new-oop. Thus when we find a reference to NCM (for example when
the subclass list of its superclass is scanned) it will already have been
'dealt with'. The system also has to cope with arbitrary order of finding
either of the involved objects; you cannot guarantee that one will be
spotted before the other and rely on that.

Take a look at SystemTracer>replace:withNew:class:length:trace:write: to
see the diferences from the normal #new:class:length:trace:write:. One also
needs to check Associations in order to 'correct' the value instvar if it
refers to a replaced class.!


!SystemTracer methodsFor: 'initialization' stamp: 'di 9/28/97 16:13'!
doit  "SystemTracer writeClone"
	"(StandardFileStream allInstances select:
		[:f | f name endsWith: 'clone.image']) do: [:f | f close]."
	| time1 time2 ctxt n |
	ctxt _ thisContext sender.
	ctxt push: nil.
	self init: ctxt.
	cleaningUp _ false.	"true means rewriting special objects in writeSpecial2"
	Transcript show: 'Tracing . . . '.
	time1 _ Time millisecondClockValue.
	file _ FileStream fileNamed: 'clone.image'.
	file binary.
	n _ self writeImage: (Array with: Smalltalk).
	time2 _ Time millisecondClockValue.
	Transcript cr; show: n printString , ' bytes written in '
			, (time2 - time1 //1000) printString , ' seconds.'.
	"ctxt pop" "So we can resume"! !

!SystemTracer methodsFor: 'initialization' stamp: 'di 9/27/97 22:27'!
init: aContext
	initialProcess _ Process forContext: aContext priority: Processor activePriority.
	self initOopMap.
	hashGenerator _ Random new.
	self clamp: self.
	self clamp: aContext sender.
	self initDict! !

!SystemTracer methodsFor: 'initialization' stamp: 'di 3/14/1999 10:00'!
initCompactClasses 
	| c |
	c _ Array new: 31.	
	"These classes have a short name (their index in this table.  It is not their oop.)
	Thus their instances can use just a single word as their header in memory."
	c at: 1 put: CompiledMethod.  c at: 2 put: Symbol. c at: 3 put: Array.
	c at: 4 put: Float.  c at: 5 put: LargePositiveInteger.  c at: 6 put: String.
	c at: 7 put: MethodDictionary.  c at: 8 put: Association.  c at: 9 put: Point.
	c at: 10 put: Rectangle.  c at: 11 put: ClassOrganizer.  c at: 12 put: TextLineInterval.

	"**NOTE** at present the Squeak VM relies on BlockContext=13 and MethodContext=14"
	c at: 13 put: BlockContext.  c at: 14 put: MethodContext.  c at: 15 put: PseudoContext.

	compactClasses _ c.
	"16 to 31 are available for user defined compact classes."

	"Attempt to correctly write contextCache image.."
	"compactClasses _ Smalltalk compactClassesArray"! !

!SystemTracer methodsFor: 'initialization' stamp: 'TPR 2/8/1999 15:12'!
initDict
	writeDict _ Dictionary new: 256.
	Smalltalk allClassesDo: 
		[:class | 
		class isBits 
			ifTrue: 
			[writeDict at: class put: (class isBytes ifTrue: [#writeBytes:]
												ifFalse: [#writeWords:])]
			ifFalse:
			[writeDict at: class put: #writePointers:.
			(class inheritsFrom: Set) | (class == Set) ifTrue:
				[writeDict at: class put: #writeSet:].
			(class inheritsFrom: IdentitySet) | (class == IdentitySet) ifTrue:
				[writeDict at: class put: #writeIdentitySet:].
			(class inheritsFrom: IdentityDictionary) | (class == IdentityDictionary) ifTrue:
				[writeDict at: class put: #writeIdentitySet:].
			(class inheritsFrom: MethodDictionary) | (class == MethodDictionary) ifTrue:
				[writeDict at: class put: #writeMethodDictionary:]].
				].

"check for Associations of replaced classes"
	writeDict at: Association put: #writeAssociation:.

	Smalltalk allBehaviorsDo: 
		[:class | writeDict at: class class put: #writeBehavior:].
	writeDict at: PseudoContext class put: #writeBehavior:.
	writeDict at: SmallInteger put: #writeClamped:.
	writeDict at: CompiledMethod put: #writeMethod:.
	writeDict at: Process put: #writeProcess:.
	writeDict at: MethodContext put: #writeContext:.
	writeDict at: BlockContext put: #writeContext:.! !

!SystemTracer methodsFor: 'initialization' stamp: 'di 9/8/1998 16:55'!
writeFileHeader
	file position: 0.  "info in header page"
	self write4Bytes: ($A asciiValue *100) + 2.  "version number:  6500+2"
	self write4Bytes: imageHeaderSize.  "File offset (bytes) of start of data"
							"same as base address (byte) of first object"
	self write4Bytes: maxOop.  "Length of data segment in words"
	self write4Bytes: 0.		"what you have to add to an oop to get"
							"an offset in the data portion of this file"
	self write4Bytes: (self mapAt: specialObjects).
	self write4Bytes: (hashGenerator next * 16rFFF asFloat) asInteger.  "next hash"
	self write4Bytes: Display width * 16r10000 + Display height.  "display size"
	file position > imageHeaderSize ifTrue: [self error: 'Header ran over allotted length'].
	file padTo: imageHeaderSize put: 0.  "Pad header page"

	"On Mac, set the file type and creator (noop on other platforms)"
	FileDirectory default
		setMacFileNamed: file fullName
		type: 'STim'
		creator: 'FAST'.
	file close.
! !

!SystemTracer methodsFor: 'initialization' stamp: 'di 10/3/97 16:13'!
writeImage: roots 
	imageHeaderSize _ 64.	"16 longs"
	file position: imageHeaderSize.  "Skip header section"
	maxOop _ 0.  "Starting oop"
	self initCompactClasses.
	specialObjects _ Smalltalk specialObjectsArray copy.
	specialObjects at: 29 put: compactClasses.
	"New oop of nil is needed before we find out from the trace."
	NewNil _ maxOop + ((self headersFor: nil withHash: 0) size-1*4).
	self trace: nil.  "In fact, this traverses the system by the time it's done!!"
	self trace: specialObjects.
	roots do: [:root | self trace: root].
	self writeFileHeader.
	^ Array with: maxOop! !


!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/29/97 08:21'!
clamp: obj
	self mapAt: obj put: Clamped with: nil! !

!SystemTracer methodsFor: 'mapping oops'!
hasClamped: obj
	"See if obj will be a SmallInteger in the new system."
	obj class == SmallInteger ifTrue: [^ true].
	^ (self mapAt: obj) = Clamped! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'TPR 9/11/1998 14:45'!
hasReplacement: obj
	"See if obj will be replaced in the new system."
	obj class == SmallInteger ifTrue: [^ false].
	^ replacementClasses includes: obj ! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'TPR 9/11/1998 14:42'!
initOopMap
	"oopMap is an array 4096 long indexed by basicHash.
	Each element a subarray of object/newOop/hash triplets.
	The subarrrays must be linearly searched.
	Access to an object causes it to be promoted in the subarray,
		so that frequently accessed objects can be found quickly."
	oopMap _ (1 to: 4096) collect: [:i | Array new].

	"replacementClasses is a simple Dictionary to contain pairs of classes (well, globals should work actually) where the key is a class being replaced and the value is the replacement class"
	replacementClasses _ Dictionary new! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/27/97 20:26'!
mapAt: obj
	"Return the new oop for this object"
	| bucket |
	bucket _ oopMap at: obj identityHash+1.
	1 to: bucket size by: 3 do: 
		[:i | obj == (bucket at: i)
			ifTrue: ["Promote this entry for rapid access"
					i > 1 ifTrue: [1 to: 3 do: [:j | bucket swap: j with: i-1+j]].
					^ bucket at: 2]].
	^ UnassignedOop! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'di 9/27/97 20:26'!
mapAt: obj put: oop with: hash
	"Assign the new oop for this object"
	| bucket |
	bucket _ oopMap at: obj identityHash+1.

	"Check for multiple writes (debug only)"
"	1 to: bucket size by: 3 do: 
		[:i | obj == (bucket at: i) ifTrue: [self halt]].
"
	oopMap at: obj identityHash+1 put: (Array with: obj with: oop with: hash) , bucket! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'di 12/15/97 19:31'!
mapHashAt: obj
	"Return the new hash for this object"
	| bucket |
	bucket _ oopMap at: obj identityHash+1.
	1 to: bucket size by: 3 do: 
		[:i | obj == (bucket at: i) ifTrue: [^ bucket at: i+2]].
	self halt! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'TPR 9/11/1998 14:48'!
replaceClass: original by: obj
	"setup the replacement class"
	replacementClasses at: original put: obj ! !

!SystemTracer methodsFor: 'mapping oops' stamp: 'TPR 9/11/1998 14:47'!
replacementFor: obj
	"return the replacement class, if there is one"
	obj class == SmallInteger ifTrue: [^ nil].
	^ replacementClasses at: obj ifAbsent:[nil]! !


!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/29/97 09:05'!
new: obj class: class length: length trace: traceBlock write: writeBlock
	| oop objpos headers type hash |
	"We assign file space for an object.
	Only does something when object has not been assigned a new oop yet.  
	Length is the instance vars and variable portion in longs.
	Class is not included in length.
	Special objects come here for an oop, and do no tracing or writing.
	To trace and write their fields later, do NOT use this method."  
	oop_ self mapAt: obj.
	oop = UnassignedOop ifFalse:
		["Has already been assigned a new oop or clamped."
		^ self].

	"Write header and remember new oop in map"
	hash _ (hashGenerator next * 16rFFF asFloat) asInteger.
	headers _ self headersFor: obj withHash: hash.
	file position: maxOop + imageHeaderSize.
	headers do: [:h | self write4Bytes: h].
	maxOop _ maxOop + (headers size-1*4).		"New oop points at header word"
	self mapAt: obj put: maxOop with: hash.
	objpos _ maxOop + imageHeaderSize.		"file position"
length > 20 ifTrue: [maxOop printString, ' ' displayAt: 0@0].

	"Write blank data, advancing to next object position"
	maxOop _ maxOop + (length+1*4).	"ready for next object"
	file nextPutAll: (ByteArray new: length*4 withAll: 0).

	traceBlock notNil ifTrue: [self trace: class.  traceBlock value].
	(headers size > 1 and: [(headers at: headers size-1) < 0])
		ifTrue: ["rewrite class word if not known before"
				file position: objpos-4.
				type _ (headers at: headers size-1) bitAnd: 3.
				self write4Bytes: (self mapAt: class) + type.
				self write4Bytes: (headers at: headers size) "faster to write than skip"]
		ifFalse: ["Had no class header, or was already valid"
				file position: objpos+4].
	"Now positioned after header, before data..."

	writeBlock value.	"No allocation of new oops is allowed in here!!"

	"Consistency check"
	file position = (objpos + (length+1*4)) ifFalse:
		["writeBlock did not leave us at end of object"
		self halt.
		"Maybe copied an object without putting it in holder,
		so it got freed and became something else of a different size"]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 2/10/1999 08:08'!
replace: original withNew: obj class: class length: length trace: traceBlock write: writeBlock
	| oop objpos headers type hash |
	"We assign file space for an object, replacing original.
	Only does something when original has not been assigned a new oop yet.  
	Length is the instance vars and variable portion in longs.
	Class is not included in length.
	Special objects come here for an oop, and do no tracing or writing.
	To trace and write their fields later, do NOT use this method."  
	oop_ self mapAt: original.
	oop = UnassignedOop ifFalse:
		["Original has already been assigned a new oop or clamped."
		^ self].

	oop_ self mapAt: obj.
	oop = UnassignedOop ifFalse:
		["replacement has already been assigned a new oop or clamped."
		^ self].

	"Write header and remember new oop in map. Headers must be derived from new object, since its class and format affect the values."
	hash _ (hashGenerator next * 16rFFF asFloat) asInteger.
	headers _ self headersFor: obj withHash: hash.
	file position: maxOop + imageHeaderSize.
	headers do: [:h | self write4Bytes: h].
	maxOop _ maxOop + (headers size-1*4).		"New oop points at header word"

	"log thenew object as both the original and itself"
	self mapAt: obj put: maxOop with: hash.
	self mapAt: original put: maxOop with: hash.
	objpos _ maxOop + imageHeaderSize.		"file position"
length > 20 ifTrue: [maxOop printString, ' ' displayAt: 0@0].

	"Write blank data, advancing to next object position"
	maxOop _ maxOop + (length+1*4).	"ready for next object"
	file nextPutAll: (ByteArray new: length*4 withAll: 0).

	"There is a good chance that we might need to substitute the class of the original object with the class of 'obj', so make sure both classes are properly traced"
	traceBlock notNil ifTrue: [self trace: original class. self trace: class.  traceBlock value].
	(headers size > 1 and: [(headers at: headers size-1) < 0])
		ifTrue: ["rewrite class word if not known before"
				file position: objpos-4.
				type _ (headers at: headers size-1) bitAnd: 3.
				self write4Bytes: (self mapAt: class) + type.
				self write4Bytes: (headers at: headers size) "faster to write than skip"]
		ifFalse: ["Had no class header, or was already valid"
				file position: objpos+4].
	"Now positioned after header, before data..."

	writeBlock value.	"No allocation of new oops is allowed in here!!"

	"Consistency check"
	file position = (objpos + (length+1*4)) ifFalse:
		["writeBlock did not leave us at end of object"
		self error: 'reposition error'.
		"Maybe copied an object without putting it in holder,
		so it got freed and became something else of a different size"]! !

!SystemTracer methodsFor: 'tracing and writing'!
trace: obj

	(self hasClamped: obj) ifTrue: [^ self].
	self perform: (writeDict at: obj class ifAbsent: [#writeClamped:])
			"May be some classes not in Smalltalk dict, let them through"
		with: obj.! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'TPR 9/23/1998 21:34'!
writeAssociation: obj
"when handling an Association, we need to check to see if it is one representing a class in the globals dictionary.
If it is, check to see if the class is to be substituted.
If it is, trace & write the substitute instead of the original value"
	|  actualValue |
	actualValue _ self replacementFor: obj value.
	(actualValue notNil and:[Smalltalk includes: obj value])
		ifFalse:[ actualValue _ obj value].
	self new: obj
		class: obj class
		length: (self sizeInWordsOf: obj)
		trace: [self trace: obj key. self trace: actualValue]
		write: [self writePointerField: obj key. self writePointerField: actualValue]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 14:40'!
writeBehavior: obj
	| length |
	self new: obj
		class: obj class
		length: (length _ self sizeInWordsOf: obj)
		trace: [1 to: length do: [:i | self trace: (obj instVarAt: i)]]
		write: [1 to: 2 do: [:i | self writePointerField: (obj instVarAt: i)].
			self writePointerField: (self formatOfCls: obj).
			4 to: length do: [:i | self writePointerField: (obj instVarAt: i)]]! !

!SystemTracer methodsFor: 'tracing and writing'!
writeBytes: obj

	self new: obj
		class: obj class
		length: (self sizeInWordsOf: obj)
		trace: []
		write: 
			[1 to: obj size do: [:i | file nextPut: (obj at: i) asInteger].
			file padToNextLongPut: 0]! !

!SystemTracer methodsFor: 'tracing and writing'!
writeClamped: obj

	^false! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'TPR 2/8/1999 13:38'!
writeContext: aContext
	"Nil out any garbage above the stack pointer to avoid a crash."
	| wordLength length |
	aContext stackPtr == nil ifFalse:
		[aContext stackPtr+1 to: aContext size do: [:ind | aContext at: ind put: nil]].
	"writing out a context is made more complicated as of sq2.3 by the change in the size primitive to return the stackpointer instead of the number of indexable slots.
	Thus the length parameter needs to be 
		BlockContext instSize + CompiledMethod fullFrameSize = 38
	while the trace block must only trace the first (named + sp) slots and the write block must add nulls after the sp."
	wordLength _ self sizeInWordsOf: aContext.
	length _ BlockContext instSize + aContext basicSize.
	self new: aContext
		class: aContext class
		length: wordLength
		trace: [1 to: length do: [:i | self trace: (aContext instVarAt: i)]]
		write: [ 1 to: length do: [:i | self writePointerField: (aContext instVarAt: i)].
			length + 1 to: wordLength do:[:i | self writePointerField: 0] ]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:20'!
writeHashArray: obj permutedBy: perm
	"Elements of a Set's hashed array need to be reordered according to perm."
	| length |
	self new: obj class: obj class length: (length _ self sizeInWordsOf: obj)
		trace:	[1 to: length do:
					[:i | self trace: (obj basicAt: i)]]
		write:	[1 to: length do:
					[:i | self writePointerField: ((perm at: i) == nil
										ifTrue: [nil]
										ifFalse: [obj basicAt: (perm at: i)])]]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:15'!
writeHashArrayPermuted: obj useIdentity: useIdentity
	"Elements of a Set's hashed array need to be reordered according to new oops."
	| length perm |
	self new: obj class: obj class length: (length _ self sizeInWordsOf: obj)
		trace:	[1 to: length do: [:i | self trace: (obj basicAt: i)].
				"Now get permutation based on new oops"
				perm _ self permutationFor: obj useIdentity: useIdentity]
		write:	[1 to: length do:
					[:i | self writePointerField: ((perm at: i) == nil
										ifTrue: [nil]
										ifFalse: [obj basicAt: (perm at: i)])]]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/27/97 20:44'!
writeIdentitySet: obj 
	"Elements of a Set need to be reordered owing to new oops."
	^ self writeSet: obj useIdentity: true! !

!SystemTracer methodsFor: 'tracing and writing'!
writeMethod: obj
	| nptrs |
	nptrs _ obj numLiterals + 1.
	self new: obj
		class: obj class
		length: (self sizeInWordsOf: obj)
		trace: [2 to: nptrs do: [:i | self trace: (obj objectAt: i)]]
		write: 
			[self writePointerField: (self methodHeader: obj).
			2 to: nptrs do: [:i | self writePointerField: (obj objectAt: i)].
			nptrs * 4 + 1 to: obj size do: [:i | file nextPut: (obj at: i)].
			file padToNextLongPut: 0]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:22'!
writeMethodDictionary: obj
	"Elements of a Set need to be reordered according to new oops."
	| perm |
	self new: obj class: obj class length: (self sizeInWordsOf: obj)
		trace:	["First need to map the indexable fields (selectors)"
				1 to: obj basicSize do: [:i | self trace: (obj basicAt: i)].
				"Now get permutation based on new oops"
				perm _ self permutationFor: obj useIdentity: true.
				"Map named inst vars *assuming* 2nd is the hash array"
				1 to: obj class instSize do:
					[:i | i=2 ifTrue: ["Permute the hash array and note its permutation"
									self writeHashArray: (obj instVarAt: i) permutedBy: perm]
							ifFalse: ["Other fields get traced normally"
									self trace: (obj instVarAt: i)]]]
		write:	[1 to: obj class instSize do:
					[:i | self writePointerField: (obj instVarAt: i)].
				1 to: obj basicSize do:
					[:i | self writePointerField: ((perm at: i) == nil
											ifTrue: [nil]
											ifFalse: [obj basicAt: (perm at: i)])]]! !

!SystemTracer methodsFor: 'tracing and writing'!
writePointers: obj
	| length |
	self new: obj
		class: obj class
		length: (length _ self sizeInWordsOf: obj)
		trace: [1 to: length do: [:i | self trace: (obj instVarAt: i)]]
		write: [1 to: length do: [:i | self writePointerField: (obj instVarAt: i)]]! !

!SystemTracer methodsFor: 'tracing and writing'!
writeProcess: obj 
	"Substitute new initialProcess for current."
	| newObj instSize |
	newObj _ obj == Processor activeProcess
			ifTrue: [initialProcess]
			ifFalse: [obj].
	self new: obj
		class: newObj class
		length: (instSize _ newObj class instSize)
		trace: [1 to: instSize do:
				[:i | self trace: (newObj instVarAt: i)]]
		write: [1 to: instSize do:
				[:i | self writePointerField: (newObj instVarAt: i)]]! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/27/97 20:43'!
writeSet: obj 
	"Elements of a Set need to be reordered owing to new oops."
	^ self writeSet: obj useIdentity: false! !

!SystemTracer methodsFor: 'tracing and writing' stamp: 'di 9/28/97 00:01'!
writeSet: obj useIdentity: useIdentity
	"Elements of a Set need to be reordered according to new oops."
	| |
	self basicSize > 0 ifTrue: [self halt. "Not clear how to permute this kind of set"].
	self new: obj class: obj class length: (self sizeInWordsOf: obj)
		trace: 
			["Map named inst vars *assuming* 2nd is the hash array"
			1 to: obj class instSize do:
				[:i | i=2 ifTrue: ["Permute the hash array and note its permutation"
								self writeHashArrayPermuted: (obj instVarAt: i)
											useIdentity: useIdentity]
						ifFalse: ["Other fields get traced normally"
								self trace: (obj instVarAt: i)]]]
		write: 
			[1 to: obj class instSize do:
				[:i | self writePointerField: (obj instVarAt: i)]]! !

!SystemTracer methodsFor: 'tracing and writing'!
writeWords: obj

	self new: obj
		class: obj class
		length: (self sizeInWordsOf: obj)
		trace: []
		write: [1 to: obj basicSize do: [:i | self write4Bytes: (obj instVarAt: i)]]! !


!SystemTracer methodsFor: 'private' stamp: 'ar 3/21/98 00:31'!
formatOf: obj
	"Make the code that tells the format of this object.
	It is like the class's instSpec, but with added low bits for byte size"
"       0=      No pointer fields
        1=      Fixed pointer fields only
        2=      Var pointer fields only
        3=      Fixed and var pointer fields
        4=      both fixed and indexable weak fields

        5=      unused
        6=      var long (bit) fields only
        7=      unused
 
        8-11=   var byte fields only
                low 2 bits are low 2 bits of size **
        12-15   methods -- ie #literals in header, followed by var bytes
                same interpretation of low 2 bits"
	| class spec |
	class _ obj class.
	spec _ class instSpec.    "just use what's there"
	spec < 8 ifTrue: [^ spec]
			ifFalse: ["For byte objects, size = wordSize - spec.lowBits"
					^ spec + (3 - (obj size+3 bitAnd: 3))]! !

!SystemTracer methodsFor: 'private' stamp: 'TPR 2/3/1999 21:40'!
formatOfCls: class
	"Return the full word value that encodes instSize, bits, bytes, and variable."
	"See the comment in Behavior format:variable:words:pointers:
	NB: we must clear the compact class related field and replace it with the value from the cloner's list of compact classes"
	| ccField |
	ccField _ compactClasses indexOf: class.	"0 means need full word for class "
	^ (class format bitClear: (2r11111 bitShift:11)) bitOr: (ccField bitShift:11)! !

!SystemTracer methodsFor: 'private' stamp: 'di 9/29/97 08:48'!
headersFor: obj withHash: hash
	"Create three header words for this object.  Length, class, header bits."
	"Three possibilities:
		Length, class, header bits
		0, class, header bits
		0,0, header bits"
	| header3 header2 header1 cix sizeFld |
	"3 gc bits"
	header1 _ 0.  "Mark, old, dirty"

	header1 _ header1 bitShift: 12.	"next fld is 12 bits"
	header1 _ header1 + (hash bitAnd: 16rFFF).

	header1 _ header1 bitShift: 5.
	sizeFld _ (self sizeInWordsOf: obj) + 1.	"size in long words, incl hdr0"
	cix _ compactClasses indexOf: obj class.	"0 means need full word"
	header2 _ self mapAt: obj class.
	header1 _ header1 + (cix bitAnd: 16r1F).

	header1 _ header1 bitShift: 4.
	header1 _ header1 + (self formatOf: obj).	"Class characteristics"

	header1 _ header1 bitShift: 6.
	sizeFld > 16r3F
		ifTrue: [header3 _ sizeFld bitShift: 2.
				sizeFld _ 0]
		ifFalse: [header3 _ 0].
	header1 _ header1 + sizeFld.

	header1 _ header1 bitShift: 2.

	header3 > 0 ifTrue:
		["3-word: type=0"
		^ Array with: header3+0 with: header2+0 with: header1+0].
	cix = 0 ifTrue:
		[ "2-word: type=1"
		^ Array with: header2+1 with: header1+1].
	"1-word: type=3"
	^ Array with: header1+3! !

!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:45'!
methodHeader: obj
	"Return the integer encoding the attributes of this method"
	"See the comment in CompiledMethod newBytes:nArgs:nTemps:nStack:nLits:primitive:"
	^ obj header  "just use what's there"! !

!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 14:47'!
newHashFor: obj
	"If an object has a hash derived from its value, it will override on the way here.
	This object can use anything as a hash.  Derive one from its oop."

	(self mapAt: obj) = UnassignedOop
		ifTrue: [self halt]
		ifFalse: [^ self mapHashAt: obj]  ! !

!SystemTracer methodsFor: 'private' stamp: 'di 9/27/97 20:40'!
permutationFor: array useIdentity: useIdentity
	"Return an inverse permutation for an array to permute it according to
	the mapped oop values. The keys in array MUST have been mapped."
	| len perm key hash |
	len _ array basicSize.  
	perm _ Array new: len.
	1 to: len do:
		[:i | key _ array basicAt: i.
		(key == nil or: [self hasClamped: key])
		  ifFalse:
			[hash _ useIdentity
					ifTrue: [key identityHashMappedBy: self]
					ifFalse: [key hashMappedBy: self].
			hash _ hash \\ len + 1.
			[(perm at: hash) == nil] 
				whileFalse:
				[hash _ (hash = len ifTrue: [1] ifFalse: [hash + 1])].
			perm at: hash put: i]].
	^ perm! !

!SystemTracer methodsFor: 'private' stamp: 'TPR 2/2/1999 15:56'!
sizeInWordsOf: anObject
"NOTE: This is the new length of the object in LONG WORDS.
		Does not include the class (header) word."
	| class |
	class _ anObject class.
	class isBytes ifTrue: [^ anObject basicSize+3 // 4].
	class isBits ifTrue: [^ anObject basicSize].	"in two byte chunks"
	class isVariable ifTrue: [
		"terrible hack to get around contexts beleiving they are only sized up to the SP"
		(class = BlockContext or: [class = MethodContext])
			ifTrue:[^class instSize + CompiledMethod fullFrameSize].
		 ^ class instSize + anObject basicSize].
	^ class instSize! !

!SystemTracer methodsFor: 'private' stamp: 'di 4/22/1998 14:56'!
write4Bytes: bits 
	"Avoid overhead of large integers and nextWord:put:."
	| posBits bytes |
	bits >= 0
		ifTrue: [posBits _ bits]
		ifFalse: ["Change rep to twos complement."
				posBits _ 16rFFFFFFFF+(bits+1)].
	bytes _ ByteArray new: 4.
	bytes at: 1 put: (posBits digitAt: 4).
	bytes at: 2 put: (posBits digitAt: 3).
	bytes at: 3 put: (posBits digitAt: 2).
	bytes at: 4 put: (posBits digitAt: 1).
	file nextPutAll: bytes! !

!SystemTracer methodsFor: 'private' stamp: 'di 9/28/97 12:03'!
writePointerField: obj 
	| newOop |
	obj class == SmallInteger ifTrue: 
		[obj >= 0 ifTrue: [newOop _ obj * 2 + 1]
				ifFalse: [newOop _ (16r80000000 + obj) * 2 + 1].
		self write4Bytes: newOop.
		^ obj].		

	"normal pointers"
	(newOop _ self mapAt: obj) = Clamped
		ifTrue: ["If object in this field is not being traced, put out nil."
				self write4Bytes: NewNil]
		ifFalse: [self write4Bytes: newOop]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemTracer class
	instanceVariableNames: ''!

!SystemTracer class methodsFor: 'instance creation' stamp: 'di 9/27/97 14:01'!
initialize    "SystemTracer initialize"
	"These consts are negative, so they will not match any oop.
	It is important, though, that UnassignedOop, at least, have
	zero in its low-order 2 bits, (like all oops) so that the use of +
	to merge the header type bits (happens in new:class:...) will
	not do weird things."
	Clamped _ -4.  "Flag clamped objects in oopMap"	
	UnassignedOop _ -8.  "Flag unassigned oops in oopMap"! !

!SystemTracer class methodsFor: 'instance creation' stamp: 'ar 11/16/1999 20:17'!
writeClone  "SystemTracer writeClone"
	| tracer |
	tracer _ self new.
	"Delay shutDown."  "part of Smalltalk processShutDownList."
	tracer doit.   " <-- execution in clone resumes after this send"
	tracer == nil "will be nil in clone, since it is clamped"
		ifTrue: [Smalltalk processStartUpList: true].
	^ tracer! !
MorphicModel subclass: #SystemWindow
	instanceVariableNames: 'labelString stripes label closeBox collapseBox activeOnlyOnTop paneMorphs paneRects collapsedFrame fullFrame isCollapsed menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea '
	classVariableNames: 'TopWindow '
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SystemWindow commentStamp: '<historical>' prior: 0!
SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing.

The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active.  To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.!


!SystemWindow methodsFor: 'initialization' stamp: 'JW 1/30/2001 23:11'!
addCloseBox
	| frame |
	closeBox _ SimpleButtonMorph new borderWidth: 0;
			label: 'X' font: Preferences standardButtonFont; color: Color transparent;
			actionSelector: #closeBoxHit; target: self; extent: 14@14.
	frame _ LayoutFrame new.
	frame leftFraction: 0; leftOffset: 4; topFraction: 0; topOffset: 1.
	closeBox layoutFrame: frame.
	labelArea addMorph: closeBox.! !

!SystemWindow methodsFor: 'initialization' stamp: 'JW 1/31/2001 07:36'!
addLabelArea

	labelArea := (AlignmentMorph newSpacer: Color transparent) vResizing: #shrinkWrap;
			layoutPolicy: ProportionalLayout new.
	self addMorph: labelArea.! !

!SystemWindow methodsFor: 'initialization' stamp: 'JW 1/30/2001 23:11'!
addMenuControl
"NB: for the moment, we always supply balloon help for this control, until people get used to it; eventually, we mays switch to showing this balloon help only in novice mode, as we do for the other standard window controls."
	| frame |
	menuBox _ IconicButton new borderWidth: 0;
			labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu'); color: Color transparent; 
			actWhen: #buttonDown;
			actionSelector: #offerWindowMenu; target: self;
			setBalloonText: 'window menu'.
	frame _ LayoutFrame new.
	frame leftFraction: 0; leftOffset: 19; topFraction: 0; topOffset: 1.
	menuBox layoutFrame: frame.
	labelArea addMorph: menuBox.

! !

!SystemWindow methodsFor: 'initialization' stamp: 'sw 3/6/1999 10:52'!
applyModelExtent
	self extent: model initialExtent! !

!SystemWindow methodsFor: 'initialization' stamp: 'JW 1/31/2001 07:37'!
initialize
	| aFont |
	super initialize.
	allowReframeHandles := true.
	labelString ifNil: [labelString _ 'Untitled Window'].
	isCollapsed _ false.
	activeOnlyOnTop _ true.
	paneMorphs _ Array new.
	borderColor _ #raised.
	borderWidth _ 1.
	color _ Color black.
	self layoutPolicy: ProportionalLayout new.

	label _ StringMorph new contents: labelString;
			font: Preferences windowTitleFont emphasis: 1.

	"Add collapse box so #labelHeight will work"
	aFont _ Preferences standardButtonFont.
	collapseBox _ SimpleButtonMorph new borderWidth: 0;
			label: 'O' font: aFont; color: Color transparent;
			actionSelector: #collapseOrExpand; target: self; extent: 14@14.

	stripes _ Array with: (RectangleMorph newBounds: bounds)  "see extent:"
				with: (RectangleMorph newBounds: bounds).

	self addLabelArea.

	labelArea addMorph: (stripes first borderWidth: 1).
	labelArea addMorph: (stripes second borderWidth: 2).
	self setLabelWidgetAllowance.
	self addCloseBox.
	self addMenuControl.
	labelArea addMorph: label.
	labelArea addMorph: collapseBox.

	self setFramesForLabelArea.

	Preferences noviceMode ifTrue:
		[closeBox ifNotNil: [closeBox setBalloonText: 'close window'].
		menuBox ifNotNil: [menuBox setBalloonText: 'window menu'].
		collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse/expand window']].
	self on: #mouseEnter send: #spawnReframeHandle: to: self.
	self on: #mouseLeave send: #spawnReframeHandle: to: self.
	label on: #mouseDown send: #relabelEvent: to: self.
	self extent: 300@200.
	mustNotClose _ false.
	updatablePanes _ Array new.! !

!SystemWindow methodsFor: 'initialization' stamp: 'JW 2/1/2001 13:35'!
setFramesForLabelArea

	"an aid to converting old instances, but then I found convertAlignment"

	| frame |

	frame _ LayoutFrame new.
	frame leftFraction: 0.5; topFraction: 0; leftOffset: label width negated // 2.
	label layoutFrame: frame.

	frame _ LayoutFrame new.
	frame rightFraction: 1; topFraction: 0; rightOffset: -1; topOffset: 1.
	collapseBox layoutFrame: frame.

	frame _ LayoutFrame new.
	frame leftFraction: 0; topFraction: 0; rightFraction: 1;
			leftOffset: 1; topOffset: 1; rightOffset: -1.
	stripes first layoutFrame: frame.
	stripes first height: self labelHeight - 2.
	stripes first hResizing: #spaceFill.

	frame _ LayoutFrame new.
	frame leftFraction: 0; topFraction: 0; rightFraction: 1;
			leftOffset: 3; topOffset: 3; rightOffset: -3.
	stripes last layoutFrame: frame.
	stripes last height: self labelHeight - 6.
	stripes last hResizing: #spaceFill.

	frame _ LayoutFrame new.
	frame leftFraction: 0; topFraction: 0; rightFraction: 1;
			topOffset: self labelHeight negated.
	labelArea layoutFrame: frame.

! !


!SystemWindow methodsFor: 'geometry' stamp: 'ar 11/14/2000 00:05'!
extent: newExtent 
	isCollapsed
		ifTrue: [super extent: newExtent x @ (self labelHeight + 2)]
		ifFalse: [super extent: newExtent].
	self setStripeColorsFrom: self paneColorToUse.
	label fitContents; setWidth: (label width min: bounds width - self labelWidgetAllowance).
	label layoutFrame leftOffset: label width negated // 2.
	isCollapsed
		ifTrue: [collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds]! !

!SystemWindow methodsFor: 'geometry' stamp: 'ar 10/5/2000 20:05'!
justDroppedInto: aMorph event: anEvent
	isCollapsed
		ifTrue: [self position: ((self position max: 0@0) grid: 8@8).
				collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds.
				TopWindow ~~ self ifTrue: [self activate]].
	^super justDroppedInto: aMorph event: anEvent! !

!SystemWindow methodsFor: 'geometry' stamp: 'di 6/16/1998 07:56'!
labelRect
	^ self innerBounds withHeight: self labelHeight.
! !

!SystemWindow methodsFor: 'geometry' stamp: 'sw 2/16/1999 15:23'!
paneMorphs
	"Nominally private but a need for obtaining this from the outside arose"
	^ paneMorphs copy! !

!SystemWindow methodsFor: 'geometry' stamp: 'sma 2/5/2000 14:09'!
panelRect
	"Answer the area below the title bar which is devoted to panes."

	^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)! !

!SystemWindow methodsFor: 'geometry' stamp: 'di 5/22/1998 13:24'!
position: newPos
	super position: newPos.
	isCollapsed
		ifTrue: [collapsedFrame _ self bounds]
		ifFalse: [fullFrame _ self bounds].
! !

!SystemWindow methodsFor: 'geometry' stamp: 'sw 9/28/1999 11:02'!
removeMenuBox
	menuBox ifNotNil:
		[menuBox delete.
		menuBox _ nil].
! !

!SystemWindow methodsFor: 'geometry' stamp: 'JW 2/1/2001 13:15'!
setPaneRectsFromBounds
	"Reset proportional specs from actual bounds, eg, after reframing panes"
	| layoutBounds box frame left right top bottom |
	layoutBounds _ self layoutBounds.
	paneMorphs do:[:m|
		frame _ m layoutFrame.
		box _ m bounds.
		frame ifNotNil:[
			left _ box left - layoutBounds left - (frame leftOffset ifNil:[0]).
			right _ box right - layoutBounds left - (frame rightOffset ifNil:[0]).
			top _ box top - layoutBounds top - (frame topOffset ifNil:[0]).
			bottom _ box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]).
			frame leftFraction: (left / layoutBounds width asFloat).
			frame rightFraction: (right / layoutBounds width asFloat).
			frame topFraction: (top / layoutBounds height asFloat).
			frame bottomFraction: (bottom / layoutBounds height asFloat).
		].
	].! !


!SystemWindow methodsFor: 'label' stamp: 'sw 11/7/2000 10:24'!
externalName
	"Answer the name by which the receiver is known in the UI"

	^ labelString! !

!SystemWindow methodsFor: 'label' stamp: 'sr 1/14/2000 02:39'!
getRawLabel
	^ label! !

!SystemWindow methodsFor: 'label' stamp: 'di 5/4/1998 23:42'!
label
	^ labelString! !

!SystemWindow methodsFor: 'label' stamp: 'sw 9/28/1999 13:39'!
labelHeight
	^ label height + 1 max: collapseBox height! !

!SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'!
labelWidgetAllowance
	^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]! !

!SystemWindow methodsFor: 'label' stamp: 'di 11/4/1999 13:24'!
relabel
	| newLabel |
	newLabel _ FillInTheBlank 
		request: 'New title for this window'
		initialAnswer: labelString.
	newLabel isEmpty ifTrue: [^self].
	(model windowReqNewLabel: newLabel)
		ifTrue: [self setLabel: newLabel]! !

!SystemWindow methodsFor: 'label' stamp: 'sw 1/12/2000 22:23'!
relabelEvent: evt
	^ Preferences clickOnLabelToEdit
		ifFalse:	[self mouseDown: evt]
		ifTrue:	[self relabel]! !

!SystemWindow methodsFor: 'label' stamp: 'ar 11/14/2000 00:02'!
setLabel: aString
	| frame |
	labelString _ aString.
	label ifNil: [^ self].
	label contents: aString.
	self labelWidgetAllowance.  "Sets it if not already"
	self isCollapsed
		ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)]
		ifFalse: [label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance).
				label align: label bounds topCenter with: bounds topCenter + (0@borderWidth).
				collapsedFrame ifNotNil:
					[collapsedFrame _ collapsedFrame withWidth: label width + labelWidgetAllowance]].
	frame _ LayoutFrame new.
	frame leftFraction: 0.5; topFraction: 0; leftOffset: label width negated // 2.
	label layoutFrame: frame.
! !

!SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ 75! !

!SystemWindow methodsFor: 'label' stamp: 'di 5/18/1998 09:33'!
setStripeColorsFrom: paneColor
	self isActive
		ifTrue: [stripes second color: paneColor;
					borderColor: stripes second color darker.
				stripes first color: stripes second borderColor darker;
					borderColor: stripes first color darker]
		ifFalse: ["This could be much faster"
				stripes second color: paneColor; borderColor: paneColor.
				stripes first color: paneColor; borderColor: paneColor].
! !

!SystemWindow methodsFor: 'label' stamp: 'sw 11/7/2000 10:26'!
tryToRenameTo: aNewName
	"Triggered eg by typing a new name in the halo"

	self setLabel: aNewName! !

!SystemWindow methodsFor: 'label' stamp: 'di 5/17/1998 14:05'!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ self setLabel: model labelString].
! !

!SystemWindow methodsFor: 'label' stamp: 'ar 5/18/2000 18:35'!
widthOfFullLabelText
	^ (DisplayScanner quickPrintOn: Display box: Display boundingBox font: (Preferences windowTitleFont emphasized: 1)) stringWidth: labelString! !


!SystemWindow methodsFor: 'open/close' stamp: 'ar 10/5/2000 17:26'!
closeBoxHit
	"The user clicked on the close-box control in the window title.  For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down."

	Preferences dismissAllOnOptionClose ifTrue:
		[Sensor rawMacOptionKeyPressed ifTrue:
			[^ self world closeUnchangedWindows]].
	self delete
! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 10/28/1999 13:15'!
delete
	| thisWorld sketchEditor aPaintBox |
	self mustNotClose ifTrue: [^ self].
	model okToChange ifFalse: [^ self].
	thisWorld _ self world.
	sketchEditor _ self extantSketchEditor.
	self isFlexed
		ifTrue: [owner delete]
		ifFalse: [super delete].
	model windowIsClosing; release.
	model _ nil.
	sketchEditor ifNotNil:
		[sketchEditor deleteSelfAndSubordinates.
		thisWorld notNil ifTrue:
			[(aPaintBox _ thisWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]]].
		
	SystemWindow noteTopWindowIn: thisWorld.
! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 5/20/1998 09:14'!
initialExtent
	^ model initialExtent! !

!SystemWindow methodsFor: 'open/close' stamp: 'sw 9/28/1999 13:32'!
mustNotClose
	^ mustNotClose == true! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 5/20/1998 09:14'!
openInMVC
	^ self openInMVCExtent: self initialExtent! !

!SystemWindow methodsFor: 'open/close' stamp: 'di 5/13/1998 21:28'!
openInMVCExtent: extent
	Smalltalk isMorphic ifTrue: [^ self openInWorldExtent: extent].
	self bounds: (16@0 extent: extent).  "Room on left for scroll bars"
	MorphWorldView openWorldWith: self labelled: labelString! !

!SystemWindow methodsFor: 'open/close' stamp: 'RAA 6/1/2000 18:44'!
openInWorld: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	self bounds: (RealEstateAgent initialFrameFor: self world: aWorld).
	aWorld addMorph: self.
	self activate.
	aWorld startSteppingSubmorphsOf: self.
! !

!SystemWindow methodsFor: 'open/close' stamp: 'RAA 5/25/2000 08:14'!
openInWorld: aWorld extent: extent
	"This msg and its callees result in the window being activeOnlyOnTop"
	self position: (RealEstateAgent initialFrameFor: self world: aWorld) topLeft; extent: extent.
	aWorld addMorph: self.
	self activate.
	aWorld startSteppingSubmorphsOf: self.! !

!SystemWindow methodsFor: 'open/close' stamp: 'RAA 6/2/2000 10:46'!
openInWorldExtent: extent
	"This msg and its callees result in the window being activeOnlyOnTop"

	Smalltalk isMorphic ifFalse: [^ self openInMVCExtent: extent].
	self openInWorld: self currentWorld extent: extent! !

!SystemWindow methodsFor: 'open/close' stamp: 'sw 10/15/1998 11:13'!
positionSubmorphs
	"Feels like overkill, but effect needed"
	super positionSubmorphs.
	self submorphsDo:
		[:aMorph | aMorph positionSubmorphs]! !


!SystemWindow methodsFor: 'resize/collapse' stamp: 'dns 2/2/2000 14:20'!
allowReframeHandles

	^ allowReframeHandles! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'dns 2/2/2000 14:20'!
allowReframeHandles: aBoolean

	allowReframeHandles := aBoolean! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:19'!
collapse
	self isCollapsed ifFalse:[self collapseOrExpand]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'sw 10/6/2000 14:05'!
collapseOrExpand
	isCollapsed
		ifTrue: 
			["Expand -- restore panes to morphics structure"
			isCollapsed _ false.
			collapsedFrame _ self getBoundsWithFlex.
			"First save latest collapsedFrame"
			self setBoundsWithFlex: fullFrame.
			paneMorphs
				reverseDo: 
					[:m | 
					self addMorph: m.
					self world startSteppingSubmorphsOf: m].
			self activate "-- mainly for findWindow"]
		ifFalse: 
			["Collapse -- remove panes from morphics structure"
			isCollapsed _ true.
			fullFrame _ self getBoundsWithFlex.
			"First save latest fullFrame"
			paneMorphs do: [:m | m delete; releaseCachedState].
			model modelSleep.
			collapsedFrame ifNil:
				[collapsedFrame _ RealEstateAgent assignCollapseFrameFor: self].
			self setBoundsWithFlex: collapsedFrame].
	self layoutChanged! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'!
collapsedFrame
	^ collapsedFrame! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'tk 10/6/2000 14:32'!
doFastWindowReframe: ptName

	| newBounds |
	"For fast display, only higlight the rectangle during loop"
	newBounds _ self bounds newRectButtonPressedDo: [:f | 
		f 
			withSideOrCorner: ptName
			setToPoint: (self pointFromWorld: Sensor cursorPoint)
			minExtent: self minimumExtent].
	self bounds: newBounds! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:20'!
expand
	self isCollapsed ifTrue:[self collapseOrExpand]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 13:21'!
fastFramingOn

	^ Preferences fastDragWindowForMorphic and: [self isFlexed not]! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/20/1998 08:25'!
fullFrame
	^ fullFrame! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:14'!
getBoundsWithFlex
	"Return the lastest bounds rectangle with origin forced to global coordinates"

	self isFlexed
		ifTrue: [^ ((owner transform localPointToGlobal: bounds topLeft)
										extent: bounds extent)]
		ifFalse: [^ self bounds].
! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 5/19/1998 09:34'!
isCollapsed
	^ isCollapsed! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'jm 6/17/1998 11:55'!
mouseLeaveEvent: event fromPane: pane
	"For backward compatibility only.  Not used by any newly created window"
	(pane isKindOf: ScrollPane) ifTrue: [pane mouseLeave: event].
! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/21/1998 16:12'!
paneWithLongestSide: sideBlock near: aPoint 
	| thePane theSide theLen box |
	theLen _ 0.
	paneMorphs do:
		[:pane | box _ pane bounds.
		box forPoint: aPoint closestSideDistLen:
			[:side :dist :len |
			(dist <= 5 and: [len > theLen]) ifTrue:
				[thePane _ pane.
				theSide _ side.
				theLen _ len]]].
	sideBlock value: theSide.
	^ thePane! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/22/1998 22:55'!
reframePanesAdjoining: growingPane along: side to: aDisplayBox 
	| delta newRect minDim theMin horiz |
	growingPane ifNil: [^ self].  "As from click outside"
	newRect _ aDisplayBox.
	horiz _ #(left right) includes: side.
	theMin _ horiz ifTrue: [40] ifFalse: [20].

	"First check that this won't make any pane smaller than theMin screen dots"
	minDim _ (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side])
		collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox)
			inject: 999 into:
				[:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])].
	"If so, amend newRect as required"
	minDim > theMin ifFalse:
		[delta _ minDim - theMin.
		newRect _ newRect withSide: side setTo: 
				((newRect perform: side) > (growingPane bounds perform: side)
					ifTrue: [(newRect perform: side) + delta]
					ifFalse: [(newRect perform: side) - delta])].

	"Now adjust all adjoining panes for real"
	paneMorphs do:
		[:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue:
			[pane bounds: (pane bounds adjustTo: newRect along: side)]].
	"And adjust the growing pane itself"
	growingPane bounds: newRect.

	"Finally force a recomposition of the whole window"
	self setPaneRectsFromBounds.
	self extent: self extent! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/28/1999 14:15'!
setBoundsWithFlex: newFrame
	"Set bounds from newFrame with origin preserved from global coordinates"

	self isFlexed
		ifTrue: [super bounds: ((owner transform globalPointToLocal: newFrame topLeft)
										extent: newFrame extent)]
		ifFalse: [super bounds: newFrame].! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'JW 2/3/2001 08:43'!
spawnOffsetReframeHandle: event divider: divider
	"The mouse has crossed a secondary (fixed-height) pane divider.  Spawn a reframe handle."
	"Only supports vertical adjustments."
	| siblings topAdjustees bottomAdjustees topOnly bottomOnly resizer pt delta minY maxY |
	allowReframeHandles ifFalse: [^ self].
	owner ifNil: [^ self  "Spurious mouseLeave due to delete"].
	(self isActive not or: [self isCollapsed]) ifTrue:  [^ self].
	((self world ifNil: [^ self]) firstSubmorph isKindOf: NewHandleMorph) ifTrue:
		[^ self  "Prevent multiple handles"].
	divider layoutFrame ifNil: [^ self].
	(#(top bottom) includes: divider resizingEdge) ifFalse: [^ self].

	siblings _ divider owner submorphs select: [:m | m layoutFrame notNil ].
	divider resizingEdge = #bottom ifTrue:
		[
		topAdjustees _ siblings select: [:m |
			m layoutFrame topFraction = divider layoutFrame bottomFraction and:
				[m layoutFrame topOffset >= divider layoutFrame topOffset] ].
		bottomAdjustees _ siblings select: [:m |
			m layoutFrame bottomFraction = divider layoutFrame topFraction and:
				[m layoutFrame bottomOffset >= divider layoutFrame topOffset] ].
		].
	divider resizingEdge = #top ifTrue:
		[
		topAdjustees _ siblings select: [:m |
			m layoutFrame topFraction = divider layoutFrame bottomFraction and:
				[m layoutFrame topOffset <= divider layoutFrame bottomOffset] ].
		bottomAdjustees _ siblings select: [:m |
			m layoutFrame bottomFraction = divider layoutFrame topFraction and:
				[m layoutFrame bottomOffset <= divider layoutFrame bottomOffset] ].
		].
	topOnly := topAdjustees copyWithoutAll: bottomAdjustees.
	bottomOnly := bottomAdjustees copyWithoutAll: topAdjustees.
	(topOnly isEmpty or: [bottomOnly isEmpty]) ifTrue: [^self].

	minY := bottomOnly inject: -9999 into: [:y :m | 
		y max: m top + (m minHeight max: 16) + (divider bottom - m bottom)].
	maxY := topOnly inject: 9999 into: [:y :m |
		y min: m bottom - (m minHeight max: 16) - (m top - divider top)].

	pt _ event cursorPoint.
	resizer _ NewHandleMorph new
		followHand: event hand
		forEachPointDo: [:p |
			delta := (p y min: maxY max: minY) - pt y.
			topAdjustees do:
				[:m | m layoutFrame topOffset: m layoutFrame topOffset + delta ].
			bottomAdjustees do:
				[:m | m layoutFrame bottomOffset: m layoutFrame bottomOffset + delta ].
			divider layoutChanged.
			pt := pt + delta.
		]
		lastPointDo: [:p | ].
	event hand world addMorphInLayer: resizer.
	resizer startStepping! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'RAA 1/10/2001 10:10'!
spawnPaneFrameHandle: event
	| resizer localPt side growingPane newBounds adjoiningPanes limit |
	(self world firstSubmorph isKindOf: NewHandleMorph) ifTrue:
		[ ^ self  "Prevent multiple handles"].
	((self innerBounds withHeight: self labelHeight+4) containsPoint: event cursorPoint)
		ifTrue: [^ self "in label or top of top pane"].
	growingPane _ self paneWithLongestSide: [:s | side _ s] near: event cursorPoint.
	growingPane ifNil: [^ self].
	"don't resize pane side coincident with window side - RAA 5 jul 2000"
	(growingPane perform: side) = (self innerBounds perform: side) ifTrue: [^self].
	(side == #top and: [growingPane top = self panelRect top]) ifTrue: [^self].
	adjoiningPanes _ paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side].
	limit _ adjoiningPanes isEmpty
		ifFalse: [ (adjoiningPanes collect: [:pane | pane bounds perform: side])
			perform: ((#(top left) includes: side) ifTrue: [#max] ifFalse: [#min])]
		ifTrue: [self bounds perform: side].

	resizer _ NewHandleMorph new
		followHand: event hand
		forEachPointDo:
			[:p | localPt _ self pointFromWorld: p.
			newBounds _ growingPane bounds withSideOrCorner: side setToPoint: localPt minExtent: 40@20 limit: limit.
			self fastFramingOn 
			ifTrue:
				["For fast display, only higlight the rectangle during loop"
				newBounds _ growingPane bounds
				  newRectButtonPressedDo:
					[:f | growingPane bounds withSideOrCorner: side
							setToPoint: (self pointFromWorld: Sensor cursorPoint)
							minExtent: 40@20 limit: limit].
					self reframePanesAdjoining: growingPane along: side
						to: newBounds]
			ifFalse:
				[self reframePanesAdjoining: growingPane along: side to: newBounds]]
		lastPointDo: [:p | ].
	event hand world addMorphInLayer: resizer.
	resizer startStepping! !

!SystemWindow methodsFor: 'resize/collapse' stamp: 'RAA 1/10/2001 10:12'!
spawnReframeHandle: event
	"The mouse has crossed a pane border.  Spawn a reframe handle."
	| resizer localPt pt ptName newBounds |
	allowReframeHandles ifFalse: [^ self].
	owner ifNil: [^ self  "Spurious mouseLeave due to delete"].
	(self isActive not or: [self isCollapsed]) ifTrue:  [^ self].
	((self world ifNil: [^ self]) firstSubmorph isKindOf: NewHandleMorph) ifTrue:
		[^ self  "Prevent multiple handles"].
	pt _ event cursorPoint.
	self bounds forPoint: pt closestSideDistLen:
		[:side :dist :len |  "Check for window side adjust"
		dist <= 2  ifTrue: [ptName _ side]].
	ptName ifNil:
		["Check for pane border adjust"
		^ self spawnPaneFrameHandle: event].
	#(topLeft bottomRight bottomLeft topRight) do:
		[:corner |  "Check for window corner adjust"
		(pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName _ corner]].

	resizer _ NewHandleMorph new
		followHand: event hand
		forEachPointDo:
			[:p | localPt _ self pointFromWorld: p.
			newBounds _ self bounds
				withSideOrCorner: ptName
				setToPoint: localPt
				minExtent: self minimumExtent.
			self fastFramingOn 
			ifTrue:
				[self doFastWindowReframe: ptName]
			ifFalse:
				[self bounds: newBounds.
				(Preferences roundedWindowCorners
					and: [#(bottom right bottomRight) includes: ptName])
					ifTrue:
					["Complete kluge: causes rounded corners to get painted correctly,
					in spite of not working with top-down displayWorld."
					ptName = #bottom ifFalse:
						[self invalidRect: (self bounds topRight - (6@0) extent: 7@7)].
					ptName = #right ifFalse:
						[self invalidRect: (self bounds bottomLeft - (0@6) extent: 7@7)].
					self invalidRect: (self bounds bottomRight - (6@6) extent: 7@7)]]]
		lastPointDo:
			[:p | ].
	event hand world addMorphInLayer: resizer.
	resizer startStepping! !


!SystemWindow methodsFor: 'top window' stamp: 'RAA 2/2/2001 07:10'!
activate
	"Bring me to the front and make me able to respond to mouse and keyboard"
	| oldTop outerMorph sketchEditor pal |
	outerMorph _ self topRendererOrSelf.
	outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
	oldTop _ TopWindow.
	TopWindow _ self.
	oldTop ifNotNil: [oldTop passivate].
	outerMorph owner firstSubmorph == outerMorph
		ifFalse: ["Bring me (with any flex) to the top if not already"
				outerMorph owner addMorphFront: outerMorph].
	self submorphsDo: [:m | m unlock].
	labelArea submorphsDo: [:m | m unlock].
	self setStripeColorsFrom: self paneColorToUse.
	self isCollapsed ifFalse:
		[model modelWakeUpIn: self.
		self positionSubmorphs].

	(sketchEditor _ self extantSketchEditor) ifNotNil:
		[sketchEditor comeToFront.
		(pal _ self world findA: PaintBoxMorph) ifNotNil:
			[pal comeToFront]].
! !

!SystemWindow methodsFor: 'top window' stamp: 'sw 5/10/1999 15:42'!
activateAndForceLabelToShow
	self activate.
	bounds top < 0 ifTrue:
		[self position: (self position x @ 0)]! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 11:49'!
activeOnlyOnTop
	^ activeOnlyOnTop ifNil: [false]! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 12:38'!
activeOnlyOnTop: trueOrFalse
	activeOnlyOnTop _ trueOrFalse! !

!SystemWindow methodsFor: 'top window' stamp: 'LC 9/28/1999 19:04'!
extantSketchEditor
	"If my world has an extant SketchEditorMorph associated with anything  
	in this window, return that SketchEditor, else return nil"
	| w sketchEditor pasteUp |
	(w _ self world) isNil ifTrue: [^ nil].
	(sketchEditor _ w sketchEditorOrNil) isNil ifTrue: [^ nil].
	(pasteUp _ sketchEditor enclosingPasteUpMorph) isNil ifTrue: [^ nil].
	self findDeepSubmorphThat: [:m | m = pasteUp]
		ifAbsent: [^ nil].
	^ sketchEditor! !

!SystemWindow methodsFor: 'top window' stamp: 'di 5/14/1998 11:55'!
isActive
	self activeOnlyOnTop ifTrue: [^ self == TopWindow].
	^ true! !

!SystemWindow methodsFor: 'top window' stamp: 'RAA 2/2/2001 07:09'!
passivate
	"Make me unable to respond to mouse and keyboard"
	self setStripeColorsFrom: self paneColorToUse.
	model modelSleep.

	"Control boxes remain active, except in novice mode"
	self submorphsDo: [:m |
		m == labelArea ifFalse: [
			m lock
		]
	].
	labelArea submorphsDo: [:m |
		(m == closeBox or: [m == collapseBox]) ifTrue: [
			Preferences noviceMode ifTrue: [m lock]
		] ifFalse: [
			m lock
		]
	].
	self world ifNotNil:  "clean damage now, so dont merge this rect with new top window"
		[self world == Display bestGuessOfCurrentWorld ifTrue: [self world displayWorld]].
! !


!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/8/2001 20:37'!
addMorph: aMorph frame: relFrame
	| frame |
	frame _ LayoutFrame new.
	frame 
		leftFraction: relFrame left; 
		rightFraction: relFrame right; 
		topFraction: relFrame top; 
		bottomFraction: relFrame bottom.
	self addMorph: aMorph fullFrame: frame.

! !

!SystemWindow methodsFor: 'panes' stamp: 'JW 1/30/2001 23:13'!
addMorph: aMorph fullFrame: aLayoutFrame

	super addMorph: aMorph fullFrame: aLayoutFrame.

	paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
	aMorph borderWidth: 1.
	aMorph color: self paneColor.
! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/26/1999 00:23'!
existingPaneColor
	| aColor |
	"Answer the existing pane color for the window, obtaining it from the first paneMorph if any, and fall back on using the second stripe color if necessary."

	paneMorphs isEmptyOrNil
		ifFalse:
			[((aColor _ paneMorphs first color) isKindOf: Color)
				ifTrue:
					[^ aColor]].
	^ stripes second color! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 1/14/1999 10:52'!
holdsTranscript
	"ugh"
	| plug |
	^ paneMorphs size == 1 and: [((plug _ paneMorphs first) isKindOf: PluggableTextMorph) and: [plug model isKindOf: TranscriptStream]]! !

!SystemWindow methodsFor: 'panes' stamp: 'tk 8/13/1999 17:50'!
paneColor
	Display depth > 2 ifTrue:
		[model ifNotNil: [
			model isInMemory ifTrue: [
				^ Color colorFrom: model defaultBackgroundColor]].
		paneMorphs isEmptyOrNil ifFalse: [^ paneMorphs first color]].
	^ Color white! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/26/1999 00:26'!
paneColorToUse
	^ Display depth <= 2
		ifTrue:
			[Color white]
		ifFalse:
			[self existingPaneColor ifNil: [self paneColor]]! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:44'!
paneMorphSatisfying: aBlock
	^ paneMorphs detect: [:aPane | aBlock value: aPane] ifNone: [nil]! !

!SystemWindow methodsFor: 'panes' stamp: 'RAA 6/9/2000 17:22'!
replacePane: oldPane with: newPane

	newPane
		position: oldPane position;
		extent: oldPane extent.
	oldPane visible: false; lock: true; extent: 10@10.
	newPane visible: true; lock: false.
	(submorphs includes: newPane) ifFalse: [self addMorph: newPane].
	paneMorphs _ paneMorphs collect: [ :each |
		each == oldPane ifTrue: [newPane] ifFalse: [each]
	].
	self changed.

! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/26/1999 00:36'!
restoreDefaultPaneColor
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColor.
	paneMorphs do: [:p | p color: self paneColor].
! !

!SystemWindow methodsFor: 'panes' stamp: 'RAA 1/10/2001 19:01'!
setUpdatablePanesFrom: getSelectors
	| aList aPane possibles |
	"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors.  Order is important here!!  Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"

	aList _ OrderedCollection new.
	possibles _ OrderedCollection new.
	self allMorphsDo: [ :pane | 
		(pane isKindOf: PluggableListMorph) ifTrue: [
			possibles add: pane.
		].
	].

	getSelectors do: [:sel | 
		aPane _ possibles detect: [ :pane | pane getListSelector == sel] ifNone: [nil].
		aPane
			ifNotNil:
				[aList add: aPane]
			ifNil:
				[Transcript cr; show: 'Warning: pane ', sel, ' not found.']].
	updatablePanes _ aList asArray! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 12/21/1998 23:24'!
titleAndPaneText
	"If the receiver represents a workspace, return an Association between the title and that text, else return nil"
	(paneMorphs size ~~ 1 or: [(paneMorphs first isKindOf: PluggableTextMorph) not])
		ifTrue: [^ nil].
	^ labelString -> paneMorphs first text

! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:53'!
updatablePanes
	"Answer the list of panes, in order, which should be sent the #verifyContents message"
	^ updatablePanes ifNil: [updatablePanes _ #()]! !

!SystemWindow methodsFor: 'panes' stamp: 'sw 10/25/1999 23:52'!
updatePaneColors
	"Useful when changing from monochrome to color display"

	self setStripeColorsFrom: self paneColorToUse.
	paneMorphs do: [:p | p color: self paneColorToUse].
! !


!SystemWindow methodsFor: 'events' stamp: 'ar 10/25/2000 15:05'!
doFastFrameDrag

	| offset newBounds outerWorldBounds |

	outerWorldBounds _ self boundsIn: nil.
	offset _ outerWorldBounds origin - Sensor cursorPoint.
	newBounds _ outerWorldBounds newRectFrom: [:f | 
		Sensor cursorPoint + offset extent: outerWorldBounds extent
	].
	^ self position: (self globalPointToLocal: newBounds topLeft) ! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:08'!
handleListenEvent: evt
	"Make sure we lock our contents after DnD has finished"
	evt isMouse ifFalse:[^self].
	evt hand hasSubmorphs ifTrue:[^self]. "still dragging"
	self == TopWindow ifFalse:[self submorphsDo:[:m| m lock]].
	evt hand removeMouseListener: self.! !

!SystemWindow methodsFor: 'events' stamp: 'RAA 7/4/2000 17:36'!
handlesMouseDown: evt
	"If I am not the topWindow, then I will only respond to dragging by the title bar.
	Any other click will only bring me to the top"

	self flag: #bob.		"#handlesMouseDown: is in global coords, #mouseDown: is in local"
	(self fastFramingOn 
		and: [self labelRect containsPoint: (self globalPointToLocal: evt cursorPoint)])
		ifTrue: [^ true].
	^ self activeOnlyOnTop and: [self ~~ TopWindow]! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:02'!
handlesMouseOverDragging: evt
	^true! !

!SystemWindow methodsFor: 'events' stamp: 'sw 6/30/1999 20:30'!
isCandidateForAutomaticViewing
	^ false! !

!SystemWindow methodsFor: 'events' stamp: 'ar 9/14/2000 11:26'!
mouseDown: evt
	| cp |
	TopWindow == self ifFalse: [self activate].
	(Sensor redButtonPressed "If mouse is really still down after activate"
			and: [self labelRect containsPoint: evt cursorPoint]) ifTrue:
		[^ self isSticky ifFalse:
			[self fastFramingOn 
				ifTrue: [self doFastFrameDrag]
				ifFalse: [evt hand grabMorph: self topRendererOrSelf]]].
	model windowActiveOnFirstClick ifTrue:
		["Normally window keeps control of first click.
		Need explicit transmission for first-click activity."
		cp _ evt cursorPoint.
		submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseDown: evt]]]

! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:09'!
mouseEnterDragging: evt
	"unlock children for drop operations"
	(self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
		self submorphsDo:[:m| m unlock].
		evt hand addMouseListener: self. "for drop completion on submorph"
	].! !

!SystemWindow methodsFor: 'events' stamp: 'ar 1/31/2001 21:08'!
mouseLeaveDragging: evt
	"lock children after drop operations"
	(self ~~ TopWindow and:[evt hand hasSubmorphs]) ifTrue:[
		self submorphsDo:[:m| m lock].
		evt hand removeMouseListener: self.
	].! !

!SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'!
mouseMove: evt
	| cp |
	model windowActiveOnFirstClick ifTrue:
		["Normally window takes control on first click.
		Need explicit transmission for first-click activity."
		cp _ evt cursorPoint.
		submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseMove: evt]]]! !

!SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'!
mouseUp: evt
	| cp |
	model windowActiveOnFirstClick ifTrue:
		["Normally window takes control on first click.
		Need explicit transmission for first-click activity."
		cp _ evt cursorPoint.
		submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]]! !

!SystemWindow methodsFor: 'events' stamp: 'di 10/23/1998 09:22'!
paneTransition: event
	"Mouse has entered or left a pane"
	^ self spawnReframeHandle: event! !

!SystemWindow methodsFor: 'events' stamp: 'JW 2/2/2001 12:26'!
secondaryPaneTransition: event divider: aMorph
	"Mouse has entered or left a pane"
	^ self spawnOffsetReframeHandle: event divider: aMorph! !

!SystemWindow methodsFor: 'events' stamp: 'sw 12/22/1999 18:31'!
wantsHalo
	^ false! !

!SystemWindow methodsFor: 'events' stamp: 'sw 4/18/2000 09:06'!
wantsHaloFromClick
	^ true! !

!SystemWindow methodsFor: 'events' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! !


!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 09:30'!
amendSteppingStatus
	"Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out"

	self wantsSteps
		ifTrue:
			[self arrangeToStartStepping]
		ifFalse:
			[self stopStepping]! !

!SystemWindow methodsFor: 'stepping' stamp: 'jcg 9/6/2000 23:01'!
step
	"Step the receiver.  Send it to the model, the receiver is open and if it **has* a model"

	isCollapsed ifFalse: [model ifNotNil: [model stepIn: self]]! !

!SystemWindow methodsFor: 'stepping' stamp: 'jcg 9/6/2000 23:01'!
stepAt: millisecondClockValue
	"Step the receiver at the given point in time.  Send it to the model, the receiver is open and if it **has* a model"

	isCollapsed ifFalse: [model ifNotNil: [model stepAt: millisecondClockValue in: self]]! !

!SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:22'!
stepTime
	^ model
		ifNotNil:
			[model stepTimeIn: self]
		ifNil:
			[200] "milliseconds"! !

!SystemWindow methodsFor: 'stepping' stamp: 'jcg 9/6/2000 23:01'!
wantsSteps
	"Return true if the model wants its view to be stepped.  For an open system window, we give the model to offer an opinion"

	self isPartsDonor ifTrue: [^ false].
	self player wantsSteps ifTrue: [^ true].
	^ isCollapsed not and: [model wantsStepsIn: self]! !


!SystemWindow methodsFor: 'drawing' stamp: 'di 8/16/1998 01:14'!
areasRemainingToFill: aRectangle
	| areas |
	(areas _ super areasRemainingToFill: aRectangle) isEmpty
		ifTrue: [^ areas "good news -- complete occlusion"].
	"Check for special case that this is scrollbar damage"
	((bounds topLeft - (14@0) corner: bounds bottomRight) containsRect: aRectangle) ifTrue:
		[paneMorphs do: [:p | ((p isKindOf: ScrollPane) and: [p scrollBarFills: aRectangle])
							ifTrue: [^ Array new]]].
	^ areas! !

!SystemWindow methodsFor: 'drawing' stamp: 'RAA 6/12/2000 18:16'!
makeMeVisible 

	self world extent > (0@0) ifFalse: [^ self].

	((self world bounds insetBy: (0@0 corner: self labelHeight asPoint))
		containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"].

	"window not on screen (probably due to reframe) -- move it now"
	self isCollapsed
		ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)]
		ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent world: self world) topLeft].

! !

!SystemWindow methodsFor: 'drawing' stamp: 'di 3/25/2000 10:55'!
wantsRoundedCorners
	^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! !


!SystemWindow methodsFor: 'menu' stamp: 'di 5/10/1999 23:37'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
"template..."
	aCustomMenu addLine.
	aCustomMenu add: 'edit label...' action: #relabel..
! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 12/22/1999 13:09'!
buildWindowMenu
	| aMenu |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu add: 'change title...' action: #relabel.
	aMenu addLine.
	aMenu add: 'send to back' action: #sendToBack.
	aMenu add: 'make next-to-topmost' action: #makeSecondTopmost.
	aMenu addLine.
	self mustNotClose
		ifFalse:
			[aMenu add: 'make unclosable' action: #makeUnclosable]
		ifTrue:
			[aMenu add: 'make closable' action: #makeClosable].
	aMenu add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) 
		action: #toggleStickiness.
	aMenu addLine.
	aMenu add: 'full screen' action: #fullScreen.
	self isCollapsed ifFalse: [aMenu add: 'window color...' action: #setWindowColor].
	^aMenu! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 10/6/2000 14:01'!
changeColor
	"Change the color of the receiver -- triggered, e.g. from a menu.  This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self color;
		putUpFor: self near: self fullBoundsInWorld! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'!
deleteCloseBox
	closeBox ifNotNil:
		[closeBox delete.
		closeBox _ nil]! !

!SystemWindow methodsFor: 'menu' stamp: 'zL 6/21/2000 12:35'!
fullScreen
	"SystemWindow fullScreen
	Zoom Window to Full World size with possible DeskMargins"
	| left right possibleBounds |
	left _ right _ 0.
	self paneMorphs
		do: [:pane | ((pane isKindOf: ScrollPane)
					and: [pane retractableScrollBar])
				ifTrue: [pane scrollBarOnLeft
						ifTrue: [left _ left max: pane scrollbarWidth]
						ifFalse: [right _ right max: pane scrollbarWidth]]].
	possibleBounds _ self worldBounds
				insetBy: (left @ 0 corner: right @ 0).
	((Preferences useGlobalFlaps
				and: [CurrentProjectRefactoring currentFlapsSuppressed not])
			or: [Preferences fullScreenLeavesDeskMargins])
		ifTrue: [possibleBounds _ possibleBounds insetBy: 22].
	self bounds: possibleBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 9/28/1999 13:53'!
makeClosable
	mustNotClose _ false.
	closeBox ifNil:
		[self addCloseBox.
		self extent: self extent]! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 9/29/1999 10:46'!
makeSecondTopmost
	| aWorld nextWindow |
	aWorld _ self world.
	nextWindow _ aWorld submorphs detect:
		[:m | (m isKindOf: SystemWindow) and:  [m ~~ self]] ifNone: [^ self].
	nextWindow activate.
	aWorld addMorph: self behind: nextWindow
! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 8/7/2000 17:35'!
makeUnclosable
	mustNotClose _ true.
	self deleteCloseBox! !

!SystemWindow methodsFor: 'menu' stamp: 'RAA 6/12/2000 09:01'!
offerWindowMenu
	| aMenu |
	aMenu _ self buildWindowMenu.
	model ifNotNil:
		[model addModelItemsToWindowMenu: aMenu].
	aMenu popUpEvent: self currentEvent in: self world! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 9/29/1999 10:45'!
sendToBack
	| aWorld nextWindow |
	aWorld _ self world.
	nextWindow _ aWorld submorphs detect:
		[:m | (m isKindOf: SystemWindow) and:  [m ~~ self]] ifNone: [^ self].
	nextWindow activate.
	aWorld addMorphNearBack: self
! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 9/6/2000 18:46'!
setWindowColor
	"Allow the user to select a new basic color for the window"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #setWindowColor:;
		originalColor: self paneColorToUse;
		putUpFor: self
			near: self fullBounds! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 10/27/1999 11:28'!
setWindowColor: incomingColor
	| existingColor aColor |
	incomingColor ifNil: [^ self].  "it happens"
	aColor _ incomingColor asNontranslucentColor.
	(aColor = ColorPickerMorph perniciousBorderColor 
		or: [aColor = Color black]) ifTrue: [^ self].
	existingColor _ self paneColorToUse.
	existingColor ifNil: [^ self beep].
	(self allMorphs copyWithout: self) do:
		[:aMorph |
			((aMorph isKindOf: PluggableButtonMorph) and: [aMorph offColor = existingColor])
				ifTrue:
					[aMorph onColor: aColor darker offColor: aColor].
			aMorph color = existingColor
				ifTrue:
					[aMorph color: aColor]].
	self setStripeColorsFrom: aColor
		
! !

!SystemWindow methodsFor: 'menu' stamp: 'sw 10/5/1998 14:56'!
takeOutOfWindow
	"Take the receiver's pane morph out the window and place it, naked, where once the window was"
	| aMorph |
	paneMorphs size == 1 ifFalse: [^ self beep].
	aMorph _ paneMorphs first.
	owner addMorphFront: aMorph.
	self delete! !


!SystemWindow methodsFor: 'object fileIn' stamp: 'JW 1/31/2001 08:57'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	allowReframeHandles ifNil: [allowReframeHandles := true].
	self layoutPolicy ifNil: [self convertAlignment].
	labelArea ifNil: [self convertAlignment].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!SystemWindow methodsFor: 'layout' stamp: 'JW 2/1/2001 13:43'!
convertAlignment
	| frame |
	self layoutPolicy: ProportionalLayout new.
	(paneMorphs == nil or:[paneRects == nil or:[paneMorphs size ~= paneRects size]]) ifFalse:[
		self addLabelArea.
		self putLabelItemsInLabelArea.
		self setFramesForLabelArea.
		paneMorphs with: paneRects do:[:m :r|
			frame _ LayoutFrame new.
			frame leftFraction: r left; rightFraction: r right; topFraction: r top; bottomFraction: r bottom.
			m layoutFrame: frame.
			m hResizing: #spaceFill; vResizing: #spaceFill.
		].
	].
	labelArea ifNil: [
		self addLabelArea.
		self putLabelItemsInLabelArea.
		self setFramesForLabelArea.
		paneMorphs ifNotNil: [
			paneMorphs do: [:m |
				frame := m layoutFrame ifNil: [LayoutFrame new].
				frame topOffset: (frame topOffset ifNil: [0]) - self labelHeight.
				(frame bottomFraction ~= 1.0) ifTrue:
					[ frame bottomOffset: (frame bottomOffset ifNil: [0]) - self labelHeight ].
			].
		].
	].
	label ifNotNil:[
		frame _ LayoutFrame new.
		frame leftFraction: 0.5; topFraction: 0; leftOffset: label width negated // 2.
		label layoutFrame: frame].
	collapseBox ifNotNil:[
		frame _ LayoutFrame new.
		frame rightFraction: 1; topFraction: 0; rightOffset: -1; topOffset: 1.
		collapseBox layoutFrame: frame].
	stripes ifNotNil:[
		frame _ LayoutFrame new.
		frame leftFraction: 0; topFraction: 0; rightFraction: 1;
				leftOffset: 1; topOffset: 1; rightOffset: -1.
		stripes first layoutFrame: frame.
		stripes first height: self labelHeight - 2.
		stripes first hResizing: #spaceFill.
		frame _ LayoutFrame new.
		frame leftFraction: 0; topFraction: 0; rightFraction: 1;
				leftOffset: 3; topOffset: 3; rightOffset: -3.
		stripes last layoutFrame: frame.
		stripes last height: self labelHeight - 6.
		stripes last hResizing: #spaceFill].
	menuBox ifNotNil:[
		frame _ LayoutFrame new.
		frame leftFraction: 0; leftOffset: 19; topFraction: 0; topOffset: 1.
		menuBox layoutFrame: frame].
	closeBox ifNotNil:[
		frame _ LayoutFrame new.
		frame leftFraction: 0; leftOffset: 4; topFraction: 0; topOffset: 1.
		closeBox layoutFrame: frame].
! !

!SystemWindow methodsFor: 'layout' stamp: 'JW 1/30/2001 22:45'!
layoutBounds
	"Bounds of pane area only."
	| box |

	box := super layoutBounds.
	^box withTop: box top + self labelHeight! !

!SystemWindow methodsFor: 'layout' stamp: 'JW 1/31/2001 08:49'!
putLabelItemsInLabelArea

	stripes ifNotNil: [ stripes do: [:stripe | labelArea addMorph: stripe] ].
	closeBox ifNotNil: [ labelArea addMorph: closeBox ].
	menuBox ifNotNil: [ labelArea addMorph: menuBox ].
	collapseBox ifNotNil: [ labelArea addMorph: collapseBox ].
	label ifNotNil: [ labelArea addMorph: label ].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

SystemWindow class
	instanceVariableNames: ''!

!SystemWindow class methodsFor: 'instance creation' stamp: 'di 2/3/98 11:54'!
includeInNewMorphMenu
	"Include my subclasses but not me"
	^ self ~~ SystemWindow! !

!SystemWindow class methodsFor: 'instance creation' stamp: 'di 6/18/97 05:31'!
labelled: labelString
	^ (self basicNew setLabel: labelString) initialize! !


!SystemWindow class methodsFor: 'top window' stamp: 'RAA 7/7/2000 09:34'!
clearTopWindow

	TopWindow _ nil.	"if leaving morphic to export from mvc, this ref could cause problems"! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 20:13'!
closeTopWindow
	"Try to close the top window.  It may of course decline"

	TopWindow ifNotNil:
		[TopWindow delete]! !

!SystemWindow class methodsFor: 'top window' stamp: 'di 9/26/1999 22:48'!
noteTopWindowIn: aWorld
	| newTop |
	"TopWindow must be nil or point to the top window in this project."
	TopWindow _ nil.
	aWorld ifNil: [^ self].
	newTop _ nil.
	aWorld submorphsDo:
		[:m | (m isKindOf: SystemWindow) ifTrue:
			[(newTop == nil and: [m activeOnlyOnTop])
				ifTrue: [newTop _ m].
			(m model isKindOf: Project)
				ifTrue: ["This really belongs in a special ProjWindow class"
						m label ~= m model name ifTrue: [m setLabel: m model name]]]].
	newTop == nil ifFalse: [newTop activate]! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 12/6/2000 19:43'!
sendTopWindowToBack
	"Send the top window of the world to the back, activating the one just beneath it"

	TopWindow ifNotNil:
		[TopWindow sendToBack]! !

!SystemWindow class methodsFor: 'top window' stamp: 'sw 1/4/2000 15:22'!
wakeUpTopWindowUponStartup
	TopWindow ifNotNil:
		[TopWindow isCollapsed ifFalse:
			[TopWindow model ifNotNil:
				[TopWindow model modelWakeUpIn: TopWindow]]]! !

!SystemWindow class methodsFor: 'top window' stamp: 'RAA 6/17/2000 12:28'!
windowsIn: aWorld satisfying: windowBlock
	| windows s |

	windows _ OrderedCollection new.
	aWorld ifNil: [^windows].	"opening MVC in Morphic - WOW!!"
	aWorld submorphs do:
		[:m |
		((m isKindOf: SystemWindow) and: [windowBlock value: m])
			ifTrue: [windows addLast: m]
			ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1])
					ifTrue: [s _ m firstSubmorph.
							((s isKindOf: SystemWindow) and: [windowBlock value: s])
								ifTrue: [windows addLast: s]]]].
	^ windows! !


!SystemWindow class methodsFor: 'fileIn/Out' stamp: 'RAA 12/21/2000 12:01'!
classVersion
	"Changed to 1 for SystemWindow Dec 2000 - see if this helps loading old ones"
	^ 1! !
SystemWindow subclass: #SystemWindowWithButton
	instanceVariableNames: 'buttonInTitle '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!SystemWindowWithButton commentStamp: '<historical>' prior: 0!
A SystemWindow with a single extra button in its title bar.!


!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:31'!
adjustExtraButton
	buttonInTitle ifNil: [^ self].
	buttonInTitle align: buttonInTitle topLeft with:  self innerBounds topRight - (buttonInTitle width + 15 @ 1)! !

!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 2/15/1999 22:41'!
buttonInTitle: aButton
	buttonInTitle _ aButton.
	self addMorphFront: aButton! !

!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:26'!
extent: newExtent
	super extent: (newExtent max: 120 @ 50).
	self adjustExtraButton! !

!SystemWindowWithButton methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:27'!
setLabelWidgetAllowance
	^ labelWidgetAllowance _ 115! !
TParseNode subclass: #TAssignmentNode
	instanceVariableNames: 'variable expression '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TAssignmentNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	variable _ variable bindVariablesIn: aDictionary.
	expression _ expression bindVariablesIn: aDictionary.! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setVariable: variable copyTree
		expression: expression copyTree! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen

	| sel |
	self isVariableUpdatingAssignment ifTrue: [
		variable emitCCodeOn: aStream level: level generator: aCodeGen.
		sel _ expression selector.
		sel = #+
			ifTrue: [aStream nextPutAll: ' += ']
			ifFalse: [aStream nextPutAll: ' -= '].
			expression args first emitCCodeOn: aStream level: level generator: aCodeGen.
	] ifFalse: [
		variable emitCCodeOn: aStream level: level generator: aCodeGen.
		aStream nextPutAll: ' = '.
		expression emitCCodeOn: aStream level: level generator: aCodeGen.
	].! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
expression

	^expression! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	variable inlineMethodsUsing: aDictionary.
	expression inlineMethodsUsing: aDictionary.! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
isAssignment

	^true! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
isVariableUpdatingAssignment
	"Return true if this assignment statement is of one of the forms:
		var = var + ...
		var = var - ...
	Such assignments statements can exploit the C updating assignment operators. For example, 'x += 4' can be generated instead of 'x = x + 4'. This produces better code under some C compilers, most notably the CodeWarrior 68K compiler."

	| sel |
	(expression isSend and: [expression receiver isVariable]) ifFalse: [^ false].
	sel _ expression selector.
	^ (expression receiver name = variable name) and: [(sel = #+) or: [sel = #-]]! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	variable nodesDo: aBlock.
	expression nodesDo: aBlock.
	aBlock value: self.! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	variable printOn: aStream level: level.
	aStream nextPutAll: ' _ '.
	expression printOn: aStream level: level + 2.! !

!TAssignmentNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions

	expression removeAssertions! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		variable _ variable replaceNodesIn: aDictionary.
		expression _ expression replaceNodesIn: aDictionary.
		self]! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
setVariable: varNode expression: expressionNode

	variable _ varNode.
	expression _ expressionNode.! !

!TAssignmentNode methodsFor: 'as yet unclassified'!
variable

	^variable! !


!TAssignmentNode methodsFor: 'inlining' stamp: 'mn 6/30/2000 13:19'!
bindVariableUsesIn: aDictionary
	"Do NOT bind the variable on the left-hand-side of an assignment statement."
	"was bindVariablesIn:"
	expression _ expression bindVariableUsesIn: aDictionary.
! !
TParseNode subclass: #TCaseStmtNode
	instanceVariableNames: 'expression firsts lasts cases '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	expression _ expression bindVariableUsesIn: aDictionary.
	cases _ cases collect: [ :c | c bindVariableUsesIn: aDictionary ].! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	expression _ expression bindVariablesIn: aDictionary.
	cases _ cases collect: [ :c | c bindVariablesIn: aDictionary ].! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
cases

	^cases! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setExpression: expression copyTree
		firsts: firsts copy
		lasts: lasts copy
		cases: (cases collect: [ :case | case copyTree ])! !

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:27'!
customizeCase: caseParseTree forVar: varName from: firstIndex to: lastIndex
	"Return a collection of copies of the given parse tree, each of which has the value of the case index substituted for the given variable."

	| newCases dict newCase |
	newCases _ OrderedCollection new.
	firstIndex to: lastIndex do: [ :caseIndex |
		dict _ Dictionary new.
		dict at: varName put: (TConstantNode new setValue: caseIndex).
		newCase _ caseParseTree copyTree bindVariableUsesIn: dict.
		self fixSharedCodeBlocksForCase: caseIndex in: newCase.
		newCases addLast: newCase.
	].
	^ newCases! !

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'jm 12/11/1998 07:49'!
customizeShortCasesForDispatchVar: varName
	"Make customized versions of a short bytecode methods, substituting a constant having the case index value for the given variable. This produces better code for short bytecodes such as instance variable pushes that encode the index of the instance variable in the bytecode."

	| newFirsts newLasts newCases l f case expanded |
	newFirsts _ OrderedCollection new.
	newLasts _ OrderedCollection new.
	newCases _ OrderedCollection new.
	1 to: cases size do: [ :i |
		l _ lasts at: i.
		f _ firsts at: i.
		case _ cases at: i.
		expanded _ false.
		(l - f) > 1 ifTrue: [  "case code covers multiple cases"
			case nodeCount < 60 ifTrue: [
				newFirsts addAll: (f to: l) asArray.
				newLasts addAll: (f to: l) asArray.
				newCases addAll: (self customizeCase: case forVar: varName from: f to: l).
				expanded _ true.
			].
		].
		expanded ifFalse: [
			self fixSharedCodeBlocksForCase: f in: case.
			newFirsts addLast: f.
			newLasts addLast: l.
			newCases addLast: case.
		].
	].
	firsts _ newFirsts asArray.
	lasts _ newLasts asArray.
	cases _ newCases asArray.
! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen

	| indent |
	indent _ (String new: level) collect: [ :ch | Character tab ].
	aStream nextPutAll: 'switch ('.
	expression emitCCodeOn: aStream level: level generator: aCodeGen.
	aStream nextPutAll: ') {'; cr.
	1 to: cases size do: [ :i |
		(firsts at: i) to: (lasts at: i) do: [ :caseIndex |
			aStream nextPutAll: indent, 'case ', caseIndex printString, ':'; cr.
		].
		(cases at: i) emitCCodeOn: aStream level: level + 1 generator: aCodeGen.
		aStream nextPutAll: indent; tab; nextPutAll: 'break;'.
		aStream cr.
	].
	level timesRepeat: [ aStream tab ].
	aStream nextPutAll: '}'.! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
expression

	^expression! !

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'di 12/14/1998 22:22'!
fixSharedCodeBlocksForCase: caseIndex in: caseParseTree
	"Process 'sharedCode' directives in the given parse tree. The sharedCode directive allows code replicated in different arms of a case statement to be shared. The replicated code must be the final code of the case so that it ends with a break out of the case statement. The replicated code will be generated in exactly one arm of the case statement; other instances of the shared code will be replaced by branches to that single instance of the code."

	"NOTE: I have made this work for the nested case (ie several shared entry points in the same case, but it does not really work for methods with arguments.  A mechanism coud be added that would add a preamble of the form,
	innerSharedTemp = outerTemp;
when they differed.  There should at least be a test here."

	| copying oldStmts newStmts stmt codeBlockName |
	caseParseTree  nodesDo: [ :node |
		node isStmtList ifTrue: [
			copying _ true.
			oldStmts _ node statements asArray.
			newStmts _ nil.  "becomes an OrderedCollection if sharedCode block is found"
			1 to: oldStmts size do: [ :i |
				copying ifTrue: [
					stmt _ oldStmts at: i.
					(stmt isSend and: [stmt selector = #sharedCodeNamed:inCase:]) ifTrue: [
						newStmts == nil 
							ifTrue: [newStmts _ (oldStmts copyFrom: 1 to: i - 1) asOrderedCollection]
							ifFalse: [newStmts removeLast "preserve any prior shared entry points - di"].
						codeBlockName _ stmt args first value.
						(stmt args last value = caseIndex) ifTrue: [
							newStmts add: 
								(TLabeledCommentNode new setLabel: codeBlockName comment: '').
						] ifFalse: [
							newStmts add: (TGoToNode new setLabel: codeBlockName).
							copying _ false.  "don't copy remaining statements"
						].
					] ifFalse: [
						newStmts = nil ifFalse: [newStmts add: stmt].
					].
				] ifFalse: [	"ikp: this permits explicit returns before 'goto aSharedCodeLabel'"
					stmt _ oldStmts at: i.
					(stmt isLabel and: [stmt label ~= nil]) ifTrue: [newStmts add: stmt].
				].
			].
			newStmts = nil ifFalse: [node setStatements: newStmts].
		].
	].! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	expression inlineMethodsUsing: aDictionary.
	cases do: [ :c | c inlineMethodsUsing: aDictionary ].! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
isCaseStmt

	^true! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	expression nodesDo: aBlock.
	cases do: [ :c | c nodesDo: aBlock ].
	aBlock value: self.! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	aStream crtab: level.
	aStream nextPutAll: 'select '.
	expression printOn: aStream level: level.
	aStream nextPutAll: ' in'.
	1 to: cases size do: [ :i |
		(firsts at: i) to: (lasts at: i) do: [ :caseIndex |
			aStream crtab: level.
			aStream nextPutAll: 'case ', caseIndex printString, ':'.
		].
		aStream crtab: level + 1.
		(cases at: i) printOn: aStream level: level + 1.
	].
	aStream crtab: level.
	aStream nextPutAll: 'end select'.! !

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	expression removeAssertions.
	cases do: [ :case | case removeAssertions ].! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		expression _ expression replaceNodesIn: aDictionary.
		cases _ cases collect: [ :c | c replaceNodesIn: aDictionary ].
		self]! !

!TCaseStmtNode methodsFor: 'as yet unclassified'!
setExpression: aNode firsts: firstsList lasts: lastsList cases: caseList

	expression _ aNode.
	firsts _ firstsList.
	lasts _ lastsList.
	cases _ caseList.! !

!TCaseStmtNode methodsFor: 'as yet unclassified' stamp: 'ar 11/18/1999 20:08'!
setExpression: aNode selectors: selectorList arguments: anArray
	"Initialize the node from the given set of selectors."
	"Note: Each case is a statement list with containing one statement, a send to self of a selector from the given selector list. Having statement list nodes makes inlining easier later."

	| selfNode stmt lastSel firstInRun sel |
	expression _ aNode.
	selfNode _ TVariableNode new setName: 'self'.
	firsts _ OrderedCollection new: 400.
	lasts _ OrderedCollection new: 400.
	cases _ OrderedCollection new: 400.
	lastSel _ selectorList first.
	firstInRun _ 0.
	1 to: selectorList size do: [ :i |
		sel _ selectorList at: i.
		sel ~= lastSel ifTrue: [
			firsts add: firstInRun.
			lasts add: i - 2.
			stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray.
			cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).
			lastSel _ sel.
			firstInRun _ i - 1.
		].
	].
	firsts add: firstInRun.
	lasts add: selectorList size - 1.
	stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: anArray.
	cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).! !
TParseNode subclass: #TConstantNode
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TConstantNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setValue: value! !

!TConstantNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C literal."

	aStream nextPutAll: (aCodeGen cLiteralFor: value).! !

!TConstantNode methodsFor: 'as yet unclassified'!
isConstant

	^true! !

!TConstantNode methodsFor: 'as yet unclassified'!
isLeaf

	^true! !

!TConstantNode methodsFor: 'as yet unclassified' stamp: 'acg 12/17/1999 07:19'!
nameOrValue

	^value! !

!TConstantNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	value storeOn: aStream.! !

!TConstantNode methodsFor: 'as yet unclassified'!
setValue: anObject

	value _ anObject.! !

!TConstantNode methodsFor: 'as yet unclassified'!
value

	^value! !
TParseNode subclass: #TGoToNode
	instanceVariableNames: 'label '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TGoToNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new setLabel: label! !

!TGoToNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C goto statement."

	aStream nextPutAll: 'goto '.
	aStream nextPutAll: label.! !

!TGoToNode methodsFor: 'as yet unclassified'!
isGoTo

	^true! !

!TGoToNode methodsFor: 'as yet unclassified'!
label

	^label! !

!TGoToNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	aStream nextPutAll: 'goto '.
	aStream nextPutAll: label.! !

!TGoToNode methodsFor: 'as yet unclassified'!
setLabel: aString

	label _ aString.! !
TestInterpreterPlugin subclass: #TIPTestPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!TIPTestPlugin commentStamp: '<historical>' prior: 0!
"Testbed for TestInterpreterPlugin, TestCodeGenerator and TestTMethod"

TIPTestPlugin translate!


!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/15/1999 07:27'!
primNilReturn

	self primitive: 'primNilReturn'
		parameters: #()
		receiver: #Oop.

	interpreterProxy failed ifTrue: [^nil].
	^ nil! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/15/1999 07:17'!
primTestConstantReturn

	self primitive: 'primTestConstantReturn'
		parameters: #()
		receiver: #Oop.

	1 == 1 ifTrue: [^ 1]. "Smalltalk Oop for zero"
	^1 "Smalltalk Oop for zero"! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/18/1999 11:08'!
primTestExpressionReturn

	self primitive: 'primTestExpressionReturn'
		parameters: #()
		receiver: #Oop.

	1 == 1 ifTrue: [^17 asOop: SmallInteger].
	^ 17 asOop: SmallInteger! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/18/1999 11:08'!
primTestFailureReturn

	self primitive: 'primTestFailureReturn'
		parameters: #()
		receiver: #Oop.

	1 == 1 ifTrue: [^interpreterProxy primitiveFail].
	^ 17 asOop: SmallInteger! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/15/1999 07:21'!
primTestNonSpecificationReturns

	| x y |
	self export: true.
	x _ interpreterProxy stackIntegerValue: 0.
	y _ interpreterProxy stackIntegerValue: 1.
	interpreterProxy pop: 3 thenPush:
		(interpreterProxy integerObjectOf: (x + y)).! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/18/1999 11:12'!
primTestReturnsWithGuards

	| x |
	self primitive: 'primTestReturnsWithGuards'
		parameters: #()
		receiver: #Oop.
	
	1 == 1 ifTrue: [^nil].
	2 == 2 ifTrue: [^123].
	3 == 3 ifTrue: [^123 asOop: SmallInteger].
	4 == 4 ifTrue: [^self].
	x _ 123 asOop: SmallInteger.
	5 == 5 ifTrue: [^x].
	^ x! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/18/1999 11:12'!
primTestReturnsWithoutGuards

	| x |
	self primitive: 'primTestReturnsWithoutGuards'
		parameters: #()
		receiver: #Oop.
	self suppressFailureGuards: true.
	
	1 == 1 ifTrue: [^nil].
	2 == 2 ifTrue: [^123].
	3 == 3 ifTrue: [^123 asOop: SmallInteger].
	4 == 4 ifTrue: [^self].
	x _ 123 asOop: SmallInteger.
	5 == 5 ifTrue: [^x].
	^ x! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/15/1999 07:22'!
primTestSelfReturn

	self primitive: 'primTestSelfReturn'
		parameters: #()
		receiver: #Oop.

	1 == 1 ifTrue: [^self].
	^ self! !

!TIPTestPlugin methodsFor: 'testing returns' stamp: 'acg 12/18/1999 11:08'!
primTestVariableReturn

	| x |
	self primitive: 'primTestVariableReturn'
		parameters: #()
		receiver: #Oop.

	x _ 17 asOop: SmallInteger.
	1 == 1 ifTrue: [^x].
	^ x! !


!TIPTestPlugin methodsFor: 'testing nonprimitives' stamp: 'acg 12/15/1999 08:08'!
collateralProcedure

	1.
	2.
	3.
	^4! !


!TIPTestPlugin methodsFor: 'testing nonspecifications' stamp: 'acg 12/15/1999 08:09'!
primTestNonSpecificationCalls

	self primitive: 'primTestNonSpecificationCalls'
		parameters: #()
		receiver: #Oop.

	^(self collateralProcedure) asOop: #SmallInteger! !
TParseNode subclass: #TLabeledCommentNode
	instanceVariableNames: 'label '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setLabel: label
		comment: comment! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen
	"Emit a C comment with optional label."

	self printOptionalLabelOn: aStream.
	aStream nextPutAll: '/* '.
	aStream nextPutAll: comment.
	aStream nextPutAll: ' */'.! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
isComment
	"Answer true if the receiver is just a comment (i.e., it has no label)."

	^label = nil! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
isLabel

	^true! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
isLeaf

	^true! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
label

	^label! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	self printOptionalLabelOn: aStream.
	aStream nextPut: $".
	aStream nextPutAll: comment.
	aStream nextPut: $".! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
printOptionalLabelOn: aStream

	label ~= nil ifTrue: [
		self unindentOneTab: aStream.
		aStream nextPutAll: label.
		aStream nextPut: $:.
		aStream tab.	
	].! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
setComment: commentString

	label _ nil.
	comment _ commentString.! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
setLabel: labelString

	label _ labelString.! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
setLabel: labelString comment: commentString

	label _ labelString.
	comment _ commentString.! !

!TLabeledCommentNode methodsFor: 'as yet unclassified'!
unindentOneTab: aStream
	"Remove the last tab from the given stream if possible."

	(aStream isKindOf: ReadWriteStream) ifFalse: [ ^self ].
	aStream position > 0 ifTrue: [
		aStream position: aStream position - 1.
		"restore stream position if previous char was not a tab"
		aStream peek = Character tab ifFalse: [ aStream next ].
	].! !
Object subclass: #TMethod
	instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels possibleSideEffectsCache complete export static comment definingClass '
	classVariableNames: 'CaseStatements '
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TMethod methodsFor: 'initialization' stamp: 'ar 5/9/2000 12:22'!
setSelector: sel args: argList locals: localList block: aBlockNode primitive: aNumber
	"Initialize this method using the given information."

	selector _ sel.
	returnType _ 'int'. 	 "assume return type is int for now"
	args _ argList asOrderedCollection collect: [:arg | arg key].
	locals _ localList asOrderedCollection collect: [:arg | arg key].
	declarations _ Dictionary new.
	primitive _ aNumber.
	parseTree _ aBlockNode asTranslatorNode.
	labels _ OrderedCollection new.
	complete _ false.  "set to true when all possible inlining has been done"
	export _ self extractExportDirective.
	static _ self extractStaticDirective.
	self removeFinalSelfReturn.
	self recordDeclarations.
! !

!TMethod methodsFor: 'initialization' stamp: 'jm 2/12/98 11:55'!
setSelector: sel returnType: retType args: argList locals: localList declarations: decls primitive: primNumber parseTree: aNode labels: labelList complete: completeFlag
	"Initialize this method using the given information. Used for copying."

	selector _ sel.
	returnType _ retType.
	args _ argList.
	locals _ localList.
	declarations _ decls.
	primitive _ primNumber.
	parseTree _ aNode.
	labels _ labelList.
	complete _ completeFlag.! !


!TMethod methodsFor: 'accessing'!
args
	"The arguments of this method."

	^args! !

!TMethod methodsFor: 'accessing' stamp: 'hg 8/14/2000 15:57'!
comment: aComment

	comment _ aComment ! !

!TMethod methodsFor: 'accessing'!
declarations
	"The type declaration dictionary of this method."

	^declarations! !

!TMethod methodsFor: 'accessing' stamp: 'ar 2/3/2001 17:29'!
definingClass
	^definingClass! !

!TMethod methodsFor: 'accessing' stamp: 'ar 2/3/2001 17:29'!
definingClass: aClass
	definingClass _ aClass.! !

!TMethod methodsFor: 'accessing' stamp: 'jm 11/24/1998 09:03'!
export

	^ export
! !

!TMethod methodsFor: 'accessing'!
isComplete
	"A method is 'complete' if it does not contain any more inline-able calls."

	^complete! !

!TMethod methodsFor: 'accessing' stamp: 'ar 5/9/2000 12:13'!
isStatic
	^static ifNil:[false].! !

!TMethod methodsFor: 'accessing'!
labels

	^labels! !

!TMethod methodsFor: 'accessing'!
locals
	"The local variables of this method."

	^locals! !

!TMethod methodsFor: 'accessing'!
parseTree
	"The parse tree of this method."

	^parseTree! !

!TMethod methodsFor: 'accessing'!
parseTree: aNode
	"Set the parse tree of this method."

	parseTree _ aNode.! !

!TMethod methodsFor: 'accessing' stamp: 'jm 2/12/98 11:56'!
primitive
	"The primitive number of this method; zero if not a primitive."

	^ primitive
! !

!TMethod methodsFor: 'accessing'!
returnType
	"The type of the values returned by this method. This string will be used in the C declaration of this function."

	^returnType! !

!TMethod methodsFor: 'accessing'!
selector
	"The Smalltalk selector of this method."

	^selector! !

!TMethod methodsFor: 'accessing'!
selector: newSelector

	selector _ newSelector.! !

!TMethod methodsFor: 'accessing'!
statements

	parseTree isStmtList
		ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ].
	((parseTree args = nil) or: [parseTree args isEmpty])
		ifFalse: [ self error: 'expected method parse tree to have no args' ].

	^parseTree statements! !


!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:12'!
argConversionExprFor: varName stackIndex: stackIndex 
	"Return the parse tree for an expression that fetches and converts the 
	primitive argument at the given stack offset."
	| exprList decl stmtList |
	exprList _ OrderedCollection new.
	(declarations includesKey: varName)
		ifTrue: 
			[decl _ declarations at: varName.
			(decl includes: $*)
				ifTrue: 
					["array"
					exprList add: varName , ' _ ', self vmNameString, ' arrayValueOf: (', self vmNameString, ' stackValue: (' , stackIndex printString , '))'.
					exprList add: varName , ' _ ' , varName , ' - 1']
				ifFalse: 
					["must be a double"
					(decl findString: 'double' startingAt: 1)
						= 0 ifTrue: [self error: 'unsupported type declaration in a primitive method'].
					exprList add: varName , ' _ ', self vmNameString, ' stackFloatValue: ' , stackIndex printString]]
		ifFalse: ["undeclared variables are taken to be integer"
			exprList add: varName , ' _ ', self vmNameString, ' stackIntegerValue: ' , stackIndex printString].
	stmtList _ OrderedCollection new.
	exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
	^ stmtList! !

!TMethod methodsFor: 'primitive compilation'!
checkSuccessExpr
	"Return the parse tree for an expression that aborts the primitive if the successFlag is not true."

	| expr |
	expr _ 'successFlag ifFalse: [^ nil ]'.
	^ self statementsFor: expr varName: ''
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 16:48'!
covertToZeroBasedArrayReferences
	"Replace the index expressions in at: and at:put: messages with (<expr> - 1), since C uses zero-based array indexing."
	"Note: Up through release 1.31, generated primitives used the convention that array variables pointed to the first element. That meant that Smalltalk one-based index expressions had to have one subtracted to yield a zero-based index. Later, we decided to adjust the base address by -1 once in the primitive prolog rather on every array access. This resulted in a five percent performance increase for the bitmap compress/decompress primitives. This method is retained as documentation and in case we choose to revert the the previous scheme."

	| oldIndexExpr newIndexExpr |
	parseTree nodesDo: [ :n |
		(n isSend and: [(n selector = #at:) or: [ n selector = #at:put: ]]) ifTrue: [
			oldIndexExpr _ n args first.
			oldIndexExpr isConstant ifTrue: [
				"index expression is a constant: decrement the constant now"
				newIndexExpr _ TConstantNode new setValue: (n args first value - 1).
			] ifFalse: [
				"index expression is complex: build an expression to decrement result at runtime"
				newIndexExpr _ TSendNode new
					setSelector: #-
					receiver: oldIndexExpr
					arguments: (Array with: (TConstantNode new setValue: 1)).
			].
			n args at: 1 put: newIndexExpr.
		].
	].
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:12'!
fetchRcvrExpr
	"Return the parse tree for an expression that fetches the receiver from the stack."

	| expr |
	expr _ 'rcvr _ ', self vmNameString, ' stackValue: (', args size printString, ')'.
	^ self statementsFor: expr varName: ''
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:19'!
fixUpReturns: argCount postlog: postlog
	"Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return."

	| newStmts |
	parseTree nodesDo: [:node |
		node isStmtList ifTrue: [
			newStmts _ OrderedCollection new: 100.
			node statements do: [:stmt |
				stmt isReturn
					ifTrue: [
						(stmt expression isSend and:
						 ['primitiveFail' = stmt expression selector])
							ifTrue: [  "failure return"
								newStmts addLast: stmt expression.
								newStmts addLast: (TReturnNode new
									setExpression: (TVariableNode new setName: 'null'))]
							ifFalse: [  "normal return"
								newStmts addAll: postlog.
								newStmts addAll: (self popArgsExpr: argCount + 1).
								newStmts addLast: (TSendNode new
									setSelector: #pushInteger:
									receiver: (TVariableNode new setName: self vmNameString)
									arguments: (Array with: stmt expression)).
								newStmts addLast: (TReturnNode new
									setExpression: (TVariableNode new setName: 'null'))]]
					ifFalse: [
						newStmts addLast: stmt]].
			node setStatements: newStmts asArray]].
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:12'!
instVarGetExprFor: varName offset: instIndex
	"Return the parse tree for an expression that fetches and converts the value of the instance variable at the given offset."

	| exprList decl stmtList |
	exprList _ OrderedCollection new.
	(declarations includesKey: varName) ifTrue: [
		decl _ declarations at: varName.
		(decl includes: $*) ifTrue: [  "array"
			exprList add:
				(varName, ' _ ', self vmNameString, ' fetchArray: ', instIndex printString, ' ofObject: rcvr').
			exprList add: (varName, ' _ ', varName, ' - 1').
		] ifFalse: [  "must be a double"
			((decl findString: 'double' startingAt: 1) = 0)
				ifTrue: [ self error: 'unsupported type declaration in a primitive method' ].
			exprList add:
				(varName, ' _ ', self vmNameString, ' fetchFloat: ', instIndex printString, ' ofObject: rcvr').
		].
	] ifFalse: [  "undeclared variables are taken to be integer"
		exprList add:
			(varName, ' _ ', self vmNameString, ' fetchInteger: ', instIndex printString, ' ofObject: rcvr').
	].
	stmtList _ OrderedCollection new.
	exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
	^ stmtList
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:13'!
instVarPutExprFor: varName offset: instIndex
	"Return the parse tree for an expression that saves the value of the integer instance variable at the given offset."

	| expr |
	(declarations includesKey: varName) ifTrue: [
		self error: 'a primitive method can only modify integer instance variables'.
	].
	expr _ '', self vmNameString, ' storeInteger: ', instIndex printString, ' ofObject: rcvr withValue: ', varName.
	^ self statementsFor: expr varName: varName
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:13'!
popArgsExpr: argCount
	"Return the parse tree for an expression that pops the given number of arguments from the stack."

	| expr |
	expr _ '', self vmNameString, ' pop: ', argCount printString.
	^ self statementsFor: expr varName: ''
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'ar 2/3/2001 17:33'!
preparePrimitiveName
	"Prepare the selector for this method in translation"
	| aClass |
	aClass _ definingClass.
	primitive = 117 
		ifTrue:[selector _ ((aClass includesSelector: selector)
					ifTrue: [aClass compiledMethodAt: selector]
					ifFalse: [aClass class compiledMethodAt: selector]) literals first at: 2.
				export _ true]
		ifFalse:[selector _ 'prim', aClass name, selector].

! !

!TMethod methodsFor: 'primitive compilation' stamp: 'ar 2/3/2001 17:36'!
preparePrimitivePrologue
	"Add a prolog and postlog to a primitive method. The prolog copies any instance variables referenced by this primitive method into local variables. The postlog copies values of assigned-to variables back into the instance. The names of the new locals are added to the local variables list.

The declarations dictionary defines the types of any non-integer variables (locals, arguments, or instance variables). In particular, it may specify the types:

	int *		-- an array of 32-bit values (e.g., a BitMap)
	short *		-- an array of 16-bit values (e.g., a SoundBuffer)
	char *		-- an array of unsigned bytes (e.g., a String)
	double		-- a double precision floating point number (e.g., 3.14159)

Undeclared variables are taken to be integers and will be converted from Smalltalk to C ints."

"Current restrictions:
	o method must not contain message sends
	o method must not allocate objects
	o method must not manipulate raw oops
	o method cannot access class variables
	o method can only return an integer"

	| prolog postlog instVarsUsed varsAssignedTo instVarList primArgCount varName endsWithReturn aClass |
selector == #setInterpreter: ifTrue:[self halt].
	aClass _ definingClass.
	prolog _ OrderedCollection new.
	postlog _ OrderedCollection new.
	instVarsUsed _ self freeVariableReferences asSet.
	varsAssignedTo _ self variablesAssignedTo asSet.
	instVarList _ aClass allInstVarNames.
	primArgCount _ args size.

	"add receiver fetch and arg conversions to prolog"
	prolog addAll: self fetchRcvrExpr.
	1 to: args size do: [:argIndex |
		varName _ args at: argIndex.
		prolog addAll:
			(self argConversionExprFor: varName stackIndex: args size - argIndex)].

	"add success check to postlog"
	postlog addAll: self checkSuccessExpr.

	"add instance variable fetches to prolog and instance variable stores to postlog"
	1 to: instVarList size do: [:varIndex |
		varName _ instVarList at: varIndex.
		(instVarsUsed includes: varName) ifTrue: [
			locals add: varName.
			prolog addAll: (self instVarGetExprFor: varName offset: varIndex - 1).
			(varsAssignedTo includes: varName) ifTrue: [
				postlog addAll: (self instVarPutExprFor: varName offset: varIndex - 1)]]].
	prolog addAll: self checkSuccessExpr.

	locals addAllFirst: args.
	locals addFirst: 'rcvr'.
	args _ args class new.
	locals asSet size = locals size
		ifFalse: [self error: 'local name conflicts with instance variable name'].
	endsWithReturn _ self endsWithReturn.
	self fixUpReturns: primArgCount postlog: postlog.

	endsWithReturn
		ifTrue: [parseTree setStatements: prolog, parseTree statements]
		ifFalse: [
			postlog addAll: (self popArgsExpr: primArgCount).
			parseTree setStatements: prolog, parseTree statements, postlog].
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 19:08'!
replaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	| argExpr |
	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			argExpr _ TSendNode new
				setSelector: #+
				receiver: n receiver
				arguments: (Array with: (TConstantNode new setValue: 1)).
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: self vmNameString)
				arguments: (Array with: argExpr)]].
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 2/29/2000 18:47'!
statementsFor: sourceText varName: varName
	"Return the parse tree for the given expression. The result is the statements list of the method parsed from the given source text."
	"Details: Various variables are declared as locals to avoid Undeclared warnings from the parser."

	| s |
	s _ WriteStream on: ''.
	s nextPutAll: 'temp'; cr; cr; tab.
	self printTempsAndVar: varName on: s.
	s nextPutAll: sourceText.
	^ ((Compiler new parse: s contents in: Object notifying: nil)
			asTranslationMethodOfClass: self class) statements
! !

!TMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:08'!
vmNameString
	"return the string to use as the vm name in code generated for this method"
	^'self'! !


!TMethod methodsFor: 'transformations'!
bindClassVariablesIn: constantDictionary
	"Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called."

	parseTree _ parseTree bindVariablesIn: constantDictionary.! !

!TMethod methodsFor: 'transformations' stamp: 'ar 11/19/1999 14:40'!
buildCaseStmt: aSendNode
	"Build a case statement node for the given send of dispatchOn:in:."
	"Note: the first argument is the variable to be dispatched on. The second argument is a constant node holding an array of unary selectors, which will be turned into sends to self."

	((aSendNode args size >= 2) and:
	 [aSendNode args second isConstant and:
	 [aSendNode args second value class = Array]]) ifFalse: [
		self error: 'wrong node structure for a case statement'.
	].

	^TCaseStmtNode new
		setExpression: aSendNode args first
		selectors: aSendNode args second value
		arguments: (aSendNode args copyFrom: 3 to: aSendNode args size)! !

!TMethod methodsFor: 'transformations' stamp: 'ar 10/7/1998 18:55'!
extractExportDirective
	"Scan the top-level statements for an inlining directive of the form:

		self export: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or false if there is no export directive."

	| result newStatements |
	result _ false.
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #export:]) ifTrue: [
			result _ stmt args first name = 'true'.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	^ result! !

!TMethod methodsFor: 'transformations' stamp: 'ar 2/20/2000 23:33'!
extractStaticDirective
	"Scan the top-level statements for an inlining directive of the form:

		self static: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or true if there is no static directive."

	| result newStatements |
	result _ true.
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #static:]) ifTrue: [
			result _ stmt args first name ~= 'false'.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	^ result! !

!TMethod methodsFor: 'transformations' stamp: 'ar 11/18/1999 20:09'!
prepareMethodIn: aCodeGen
	"Record sends of builtin operators and replace sends of the special selector dispatchOn:in: with case statement nodes."
	"Note: Only replaces top-level sends of dispatchOn:in:. Case statements must be top-level statements; they cannot appear in expressions."

	| stmts stmt |
	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			"record sends of builtin operators"
			(aCodeGen builtin: node selector) ifTrue: [ node isBuiltinOperator: true ].
		].
		node isStmtList ifTrue: [
			"replace dispatchOn:in: with case statement node"
			stmts _ node statements.
			1 to: stmts size do: [ :i |
				stmt _ stmts at: i.
				(stmt isSend and: [CaseStatements includes: stmt selector]) ifTrue: [
					stmts at: i put: (self buildCaseStmt: stmt).
				].
			].
		].
	].! !

!TMethod methodsFor: 'transformations' stamp: 'ar 3/10/2000 21:18'!
recordDeclarations
	"Record C type declarations of the forms

		self returnTypeC: 'float'.
		self var: #foo declareC: 'float foo'
		self var: #foo type:'float'.

	 and remove the declarations from the method body."

	| newStatements isDeclaration varName varType |
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		isDeclaration _ false.
		stmt isSend ifTrue: [
			stmt selector = #var:declareC: ifTrue: [
				isDeclaration _ true.
				declarations at: stmt args first value asString put: stmt args last value.
			].
			stmt selector = #var:type: ifTrue: [
				isDeclaration _ true.
				varName _ stmt args first value asString.
				varType _ stmt args last value.
				declarations at: varName put: (varType, ' ', varName).
			].
			stmt selector = #returnTypeC: ifTrue: [
				isDeclaration _ true.
				returnType _ stmt args last value.
			].
		].
		isDeclaration ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.! !

!TMethod methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	parseTree removeAssertions! !

!TMethod methodsFor: 'transformations' stamp: 'jm 12/14/1998 08:35'!
removeFinalSelfReturn
	"The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway."

	| stmtList lastStmt |
	stmtList _ parseTree statements asOrderedCollection.
	lastStmt _ stmtList last.

	((lastStmt isReturn) and:
	 [(lastStmt expression isVariable) and:
	 ['self' = lastStmt expression name]]) ifTrue: [
		stmtList removeLast.
		parseTree setStatements: stmtList.
	].! !


!TMethod methodsFor: 'utilities'!
allCalls
	"Answer a collection of selectors for the messages sent by this method."

	^parseTree allCalls! !

!TMethod methodsFor: 'utilities' stamp: 'jm 2/12/98 11:55'!
copy
	"Make a deep copy of this TMethod."

	^ self class basicNew
		setSelector: selector
		returnType: returnType
		args: args copy
		locals: locals copy
		declarations: declarations copy
		primitive: primitive
		parseTree: parseTree copyTree
		labels: labels copy
		complete: complete
! !

!TMethod methodsFor: 'utilities'!
freeVariableReferences
	"Answer a collection of variables referenced this method, excluding locals, arguments, and pseudovariables."

	| refs |
	refs _ Set new.
	parseTree nodesDo: [ :node |
		node isVariable ifTrue: [ refs add: node name asString ].
	].
	args do: [ :var | refs remove: var asString ifAbsent: [] ].
	locals do: [ :var | refs remove: var asString ifAbsent: [] ].
	#('self' 'nil' 'true' 'false') do: [ :var | refs remove: var ifAbsent: [] ].
	^ refs asSortedCollection! !

!TMethod methodsFor: 'utilities'!
hasNoCCode
	"Answer true if the receiver does not use inlined C or C declarations, which are not currently renamed properly by the the inliner."

	declarations isEmpty ifFalse: [ ^ false ].

	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			node selector = #cCode: ifTrue: [ ^ false ].
		].
	].
	^ true! !

!TMethod methodsFor: 'utilities'!
nodeCount
	"Answer the number of nodes in this method's parseTree (a rough measure of its size)."

	| cnt |
	cnt _ 0.
	parseTree nodesDo: [ :n | cnt _ cnt + 1 ].
	^cnt! !

!TMethod methodsFor: 'utilities'!
variablesAssignedTo
	"Answer a collection of variables assigned to by this method."

	| refs |
	refs _ Set new.
	parseTree nodesDo: [ :node |
		node isAssignment ifTrue: [ refs add: node variable name ].
	].
	^ refs! !


!TMethod methodsFor: 'inlining'!
argAssignmentsFor: meth args: argList in: aCodeGen
	"Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method."
	"Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."

	| stmtList substitutionDict |
	stmtList _ OrderedCollection new: 100.
	substitutionDict _ Dictionary new: 100.
	meth args with: argList do: [ :argName :exprNode |
		(self isSubstitutableNode: exprNode intoMethod: meth in: aCodeGen) ifTrue: [
			substitutionDict at: argName put: exprNode.
			locals remove: argName.
		] ifFalse: [
			stmtList add: (TAssignmentNode new
				setVariable: (TVariableNode new setName: argName)
				expression: exprNode copyTree).
		].
	].
	meth parseTree: (meth parseTree bindVariablesIn: substitutionDict).
	^stmtList! !

!TMethod methodsFor: 'inlining'!
checkForCompleteness: stmtLists in: aCodeGen
	"Set the complete flag if none of the given statement list nodes contains further candidates for inlining."

	complete _ true.
	stmtLists do: [ :stmtList |
		stmtList statements do: [ :node |
			(self inlineableSend: node in: aCodeGen) ifTrue: [
				complete _ false.  "more inlining to do"
				^self
			].
		].
	].
	parseTree nodesDo: [ :n |
		(self inlineableFunctionCall: n in: aCodeGen) ifTrue: [
			complete _ false.  "more inlining to do"
			^self
		].
	].! !

!TMethod methodsFor: 'inlining'!
exitVar: exitVar label: exitLabel
	"Replace each return statement in this method with an assignment to the exit variable followed by a goto to the given label. Return true if a goto was generated."
	"Optimization: If exitVar is nil, the return value of the inlined method is not being used, so don't add the assignment statement."

	| newStmts labelUsed |
	labelUsed _ false.
	parseTree nodesDo: [ :node |
		node isStmtList ifTrue: [
			newStmts _ OrderedCollection new: 100.
			node statements do: [ :stmt |
				(stmt isReturn) ifTrue: [
					exitVar = nil ifTrue: [
						stmt expression isLeaf ifFalse: [
							"evaluate return expression even though value isn't used"
							newStmts add: stmt expression.
						].
					] ifFalse: [
						"assign return expression to exit variable"
						newStmts add:
							(TAssignmentNode new
								setVariable: (TVariableNode new setName: exitVar)
								expression: stmt expression).
					].
					(stmt == parseTree statements last) ifFalse: [
						"generate a goto (this return is NOT the last statement in the method)"
						newStmts add: (TGoToNode new setLabel: exitLabel).
						labelUsed _ true.
					].
				] ifFalse: [
					newStmts addLast: stmt.
				].
			].
			node setStatements: newStmts asArray.
		].
	].
	^labelUsed! !

!TMethod methodsFor: 'inlining'!
inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList

	| stmt sel meth newStatements maxTemp usedVars exitLabel v |
	maxTemp _ 0.
	parseTree nodesDo: [ :n |
		n isCaseStmt ifTrue: [
			n cases do: [ :stmtNode |
				stmt _ stmtNode statements first.
				stmt isSend ifTrue: [
					sel _ stmt selector.
					meth _ aCodeGen methodNamed: sel.
					((meth ~= nil) and:
					 [meth hasNoCCode and:
					 [meth args size = 0]]) ifTrue: [
						meth _ meth copy.
						maxTemp _ maxTemp max: (meth renameVarsForCaseStmt).

						meth hasReturn ifTrue: [
							exitLabel _ self unusedLabelForInliningInto: self.
							meth exitVar: nil label: exitLabel.
							labels add: exitLabel.
						] ifFalse: [ exitLabel _ nil ].

						meth renameLabelsForInliningInto: self.
						meth labels do: [ :label | labels add: label ].
						newStatements _ stmtNode statements asOrderedCollection.
						newStatements removeFirst.

						exitLabel ~= nil ifTrue: [
							newStatements addFirst:
								(TLabeledCommentNode new
									setLabel: exitLabel comment: 'end case').
						].

						newStatements addAllFirst: meth statements.
						newStatements addFirst:
							(TLabeledCommentNode new setComment: meth selector).
						stmtNode setStatements: newStatements.
					].
				].
			].
		].
	].
	usedVars _ (locals, args) asSet.
	1 to: maxTemp do: [ :i |
		v _ ('t', i printString).
		(usedVars includes: v) ifTrue: [ self error: 'temp variable name conflicts with an existing local or arg' ].
		locals addLast: v.
	].

	"make local versions of the given globals"
	varsList do: [ :var |
		(usedVars includes: var) ifFalse: [ locals addFirst: var asString ].
	].
! !

!TMethod methodsFor: 'inlining'!
inlineCodeOrNilForStatement: aNode in: aCodeGen
	"If the given statement node can be inlined, answer the statements that replace it. Otherwise, answer nil."

	| stmts |
	aNode isReturn ifTrue: [
		(self inlineableSend: aNode expression in: aCodeGen) ifTrue: [
			stmts _ self inlineSend: aNode expression
				directReturn: true exitVar: nil in: aCodeGen.
			^stmts
		].
	].
	aNode isAssignment ifTrue: [
		(self inlineableSend: aNode expression in: aCodeGen) ifTrue: [
			^self inlineSend: aNode expression
				directReturn: false exitVar: aNode variable name in: aCodeGen
		].
	].
	aNode isSend ifTrue: [
		(self inlineableSend: aNode in: aCodeGen) ifTrue: [
			^self inlineSend: aNode
				directReturn: false exitVar: nil in: aCodeGen
		].
	].
	^nil! !

!TMethod methodsFor: 'inlining'!
inlineFunctionCall: aSendNode in: aCodeGen
	"Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body."
	"Assume caller has established that:
		1. the method arguments are all substitutable nodes, and
		2. the method to be inlined contains no additional embedded returns."

	| sel meth substitutionDict |
	sel _ aSendNode selector.
	meth _ (aCodeGen methodNamed: sel) copy.
	meth renameVarsForInliningInto: self in: aCodeGen.
	meth renameLabelsForInliningInto: self.
	self addVarsDeclarationsAndLabelsOf: meth.
	substitutionDict _ Dictionary new: 100.
	meth args with: aSendNode args do: [ :argName :exprNode |
		substitutionDict at: argName put: exprNode.
		locals remove: argName].
	meth parseTree bindVariablesIn: substitutionDict.
	^ meth statements first expression! !

!TMethod methodsFor: 'inlining'!
inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen
	"Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable."

	| sel meth exitLabel labelUsed inlineStmts |
	sel _ aSendNode selector.
	meth _ (aCodeGen methodNamed: sel) copy.
	meth renameVarsForInliningInto: self in: aCodeGen.
	meth renameLabelsForInliningInto: self.
	self addVarsDeclarationsAndLabelsOf: meth.
	meth hasReturn ifTrue: [
		directReturn ifTrue: [
			"propagate the return type, if necessary"
			returnType = meth returnType ifFalse: [ self halt ].  "caller's return type should be declared by user"
			returnType _ meth returnType.
		] ifFalse: [
			exitLabel _ self unusedLabelForInliningInto: self.
			labelUsed _ meth exitVar: exitVar label: exitLabel.
			labelUsed
				ifTrue: [ labels add: exitLabel ]
				ifFalse: [ exitLabel _ nil ].
		].
		"propagate type info if necessary"
		((exitVar ~= nil) and: [meth returnType ~= 'int']) ifTrue: [
			declarations at: exitVar put: meth returnType, ' ', exitVar.
		].
	].
	inlineStmts _ OrderedCollection new: 100.
	inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel).
	inlineStmts addAll:
		(self argAssignmentsFor: meth args: aSendNode args in: aCodeGen).
	inlineStmts addAll: meth statements.  "method body"
	(directReturn and: [meth endsWithReturn not]) ifTrue: [
		inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')).
	].
	exitLabel ~= nil ifTrue: [
		inlineStmts add:
			(TLabeledCommentNode new
				setLabel: exitLabel comment: 'end ', meth selector).
	].
	^inlineStmts! !

!TMethod methodsFor: 'inlining'!
inlineableFunctionCall: aNode in: aCodeGen
	"Answer true if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted."

	| m |
	aNode isSend ifFalse: [ ^false ].
	m _ aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"
	((m ~= nil) and: [m isFunctional and: [aCodeGen mayInline: m selector]]) ifTrue: [
		aNode args do: [ :a | (self isSubstitutableNode: a intoMethod: m in: aCodeGen) ifFalse: [ ^false ]].
		^true
	] ifFalse: [
		^false
	].! !

!TMethod methodsFor: 'inlining'!
inlineableSend: aNode in: aCodeGen
	"Answer true if the given send node is a call to a method that can be inlined."

	| m |
	aNode isSend ifFalse: [ ^false ].
	m _ aCodeGen methodNamed: aNode selector.  "nil if builtin or external function"
	^(m ~= nil) and: [m isComplete and: [aCodeGen mayInline: m selector]]! !

!TMethod methodsFor: 'inlining'!
isFunctional
	"Answer true if the receiver is a functional method. That is, if it consists of a single return statement of an expression that contains no other returns."

	(parseTree statements size = 1 and:
	 [parseTree statements last isReturn]) ifFalse: [ ^false ].
	parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]].
	^true! !

!TMethod methodsFor: 'inlining'!
isSubstitutableNode: aNode
	"Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."

	aNode isConstant ifTrue: [ ^true ].
	^aNode isVariable and:
		[(locals includes: aNode name) or:
		[args includes: aNode name]]! !

!TMethod methodsFor: 'inlining'!
isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen
	"Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted into methods with possible side effects (i.e., methods that may assign to global variables) because the inlined method might depend on having the value of the global variable captured when it is passed in as an argument."

	| var |
	aNode isConstant ifTrue: [ ^ true ].

	aNode isVariable ifTrue: [
		var _ aNode name.
		((locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ].
		(#(self true false nil) includes: var) ifTrue: [ ^ true ].
		(targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [ ^ true ].
	].

	"scan expression tree; must contain only constants, builtin ops, and inlineable vars"
	aNode nodesDo: [ :node |
		node isSend ifTrue: [
			node isBuiltinOperator ifFalse: [ ^false ].
		].
		node isVariable ifTrue: [
			var _ node name.
			((locals includes: var) or:
			 [(args includes: var) or:
			 [(#(self true false nil) includes: var) or:
			 [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [ ^ false ].
		].
		(node isConstant or: [node isVariable or: [node isSend]]) ifFalse: [ ^false ].
	].

	^ true! !

!TMethod methodsFor: 'inlining' stamp: 'ar 10/27/1999 22:15'!
statementsListsForInlining
	"Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages."

	| stmtLists |
	stmtLists _ OrderedCollection new: 10.
	parseTree nodesDo: [ :node | 
		node isStmtList ifTrue: [ stmtLists add: node ].
	].
	parseTree nodesDo: [ :node | 
		node isSend ifTrue: [
			((node selector = #and:) or: [node selector = #or:]) ifTrue: [
				"Note: the PP 2.3 compiler produces two arg nodes for these selectors"
				stmtLists remove: node args first ifAbsent: [].
				stmtLists remove: node args last ifAbsent: [].
			].
			((node selector = #ifTrue:) or: [node selector = #ifFalse:]) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
			].
			((node selector = #ifTrue:ifFalse:) or: [node selector = #ifFalse:ifTrue:]) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
			].
			((node selector = #whileFalse:) or: [node selector = #whileTrue:]) ifTrue: [
				"Allow inlining if it is a [...] whileTrue/whileFalse.
				This is identified by having more than one statement in the 
				receiver block in which case the C code wouldn't work anyways"
				node receiver statements size = 1
					ifTrue:[stmtLists remove: node receiver ifAbsent: []].
			].
			(node selector = #to:do) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
				stmtLists remove: node args first ifAbsent: [].
			].
			(node selector = #to:do) ifTrue: [
				stmtLists remove: node receiver ifAbsent: [].
				stmtLists remove: node args first ifAbsent: [].
				stmtLists remove: (node args at: 2) ifAbsent: [].
			].
		].
		node isCaseStmt ifTrue: [
			"don't inline cases"
			node cases do: [: case | stmtLists remove: case ifAbsent: [] ].
		].
	].
	^stmtLists! !

!TMethod methodsFor: 'inlining' stamp: 'jm 12/13/1998 10:07'!
tryToInlineMethodsIn: aCodeGen
	"Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined."

	| stmtLists didSomething newStatements inlinedStmts sendsToInline |
	didSomething _ false.

	sendsToInline _ Dictionary new: 100.
	parseTree nodesDo: [ :n |
		(self inlineableFunctionCall: n in: aCodeGen) ifTrue: [
			sendsToInline at: n put: (self inlineFunctionCall: n in: aCodeGen).
		].
	].
	sendsToInline isEmpty ifFalse: [
		didSomething _ true.
		parseTree _ parseTree replaceNodesIn: sendsToInline.
	].

	didSomething ifTrue: [
		possibleSideEffectsCache _ nil.
		^didSomething
	].

	stmtLists _ self statementsListsForInlining.
	stmtLists do: [ :stmtList | 
		newStatements _ OrderedCollection new: 100.
		stmtList statements do: [ :stmt |
			inlinedStmts _ self inlineCodeOrNilForStatement: stmt in: aCodeGen.
			(inlinedStmts = nil) ifTrue: [
				newStatements addLast: stmt.
			] ifFalse: [
				didSomething _ true.
				newStatements addAllLast: inlinedStmts.
			].
		].
		stmtList setStatements: newStatements asArray.
	].

	didSomething ifTrue: [
		possibleSideEffectsCache _ nil.
		^didSomething
	].

	complete ifFalse: [
		self checkForCompleteness: stmtLists in: aCodeGen.
		complete ifTrue: [ didSomething _ true ].  "marking a method complete is progress"
	].
	^didSomething! !

!TMethod methodsFor: 'inlining'!
unusedLabelForInliningInto: targetMethod

	| usedLabels |
	usedLabels _ labels asSet.
	usedLabels addAll: targetMethod labels.
	^self unusedNamePrefixedBy: 'l' avoiding: usedLabels! !


!TMethod methodsFor: 'inlining support'!
addVarsDeclarationsAndLabelsOf: methodToBeInlined
	"Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes."

	methodToBeInlined args, methodToBeInlined locals do: [ :v |
		(locals includes: v) ifFalse: [ locals addLast: v ].
	].
	methodToBeInlined declarations associationsDo: [ :assoc |
		declarations add: assoc.
	].
	methodToBeInlined labels do: [ :label |
		labels add: label.
	].! !

!TMethod methodsFor: 'inlining support'!
computePossibleSideEffectsIn: aCodeGen
	"Answer true if this method may have side effects. It has side effects if it assigns to a global variable. It may have side effects if it calls a non-built-in method."

	parseTree nodesDo: [ :node |
		node isSend ifTrue: [
			node isBuiltinOperator ifFalse: [ ^true ].
		].
	].
	^ false! !

!TMethod methodsFor: 'inlining support'!
endsWithReturn
	"Answer true if the last statement of this method is a return."

	^ parseTree statements last isReturn! !

!TMethod methodsFor: 'inlining support'!
extractInlineDirective
	"Scan the top-level statements for an inlining directive of the form:

		self inline: <boolean>

	 and remove the directive from the method body. Return the argument of the directive or #dontCare if there is no inlining directive."

	| result newStatements |
	result _ #dontCare.
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #inline:]) ifTrue: [
			result _ stmt args first name = 'true'.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	^ result! !

!TMethod methodsFor: 'inlining support'!
hasReturn
	"Answer true if this method contains a return statement."

	parseTree nodesDo: [ :n | n isReturn ifTrue: [ ^ true ]].
	^ false! !

!TMethod methodsFor: 'inlining support' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! !

!TMethod methodsFor: 'inlining support'!
maySubstituteGlobal: globalVar in: aCodeGen
	"Answer true if this method does or may have side effects on the given global variable."

	possibleSideEffectsCache = nil ifTrue: [
		"see if this calls any other method and record the result"
		possibleSideEffectsCache _ self computePossibleSideEffectsIn: aCodeGen.
	].
	possibleSideEffectsCache ifTrue: [ ^ false ].

	parseTree nodesDo: [ :node |
		node isAssignment ifTrue: [
			node variable name = globalVar ifTrue: [ ^ false ].
		].
	].

	"if we get here, receiver calls no other method
	 and does not itself assign to the given global variable"
	^ true! !

!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:06'!
renameLabelsForInliningInto: destMethod
	"Rename any labels that would clash with those of the destination method."

	| destLabels usedLabels labelMap newLabelName |
	destLabels _ destMethod labels asSet.
	usedLabels _ destLabels copy.  "usedLabels keeps track of labels in use"
	usedLabels addAll: labels.
	labelMap _ Dictionary new: 100.
	self labels do: [ :l |
		(destLabels includes: l) ifTrue: [
			newLabelName _ self unusedNamePrefixedBy: 'l' avoiding: usedLabels.
			labelMap at: l put: newLabelName.
		].
	].
	self renameLabelsUsing: labelMap.! !

!TMethod methodsFor: 'inlining support'!
renameLabelsUsing: aDictionary
	"Rename all labels according to the old->new mappings of the given dictionary."

	labels _ labels collect: [ :label |
		(aDictionary includesKey: label) ifTrue: [ aDictionary at: label ] ifFalse: [ label ].
	].

	parseTree nodesDo: [ :node |
		(node isGoTo and: [aDictionary includesKey: node label]) ifTrue: [
			node setLabel: (aDictionary at: node label).
		].
		(node isLabel and: [aDictionary includesKey: node label]) ifTrue: [
			node setLabel: (aDictionary at: node label).
		].
	].! !

!TMethod methodsFor: 'inlining support'!
renameVariablesUsing: aDictionary
	"Rename all variables according to old->new mappings of the given dictionary."

	| newDecls |
	"map args and locals"
	args _ args collect: [ :arg |
		(aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ].
	].
	locals _ locals collect: [ :v |
		(aDictionary includesKey: v) ifTrue: [ aDictionary at: v ] ifFalse: [ v ].
	].

	"map declarations"
	newDecls _ declarations species new.
	declarations associationsDo: [ :assoc |
		(aDictionary includesKey: assoc key)
			ifTrue: [ newDecls at: (aDictionary at: assoc key) put: assoc value ]
			ifFalse: [ newDecls add: assoc ].
	].
	declarations _ newDecls.

	"map variable names in parse tree"
	parseTree nodesDo: [ :node |
		(node isVariable and:
		 [aDictionary includesKey: node name]) ifTrue: [
			node setName: (aDictionary at: node name).
		].
		(node isStmtList and: [node args size > 0]) ifTrue: [
			node setArguments:
				(node args collect: [ :arg |
					(aDictionary includesKey: arg)
						ifTrue: [ aDictionary at: arg ]
						ifFalse: [ arg ].
				]).
		].
	].! !

!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'!
renameVarsForCaseStmt
	"Rename the arguments and locals of this method with names like t1, t2, t3, etc. Return the number of variable names assigned. This is done to allow registers to be shared among the cases."

	| i varMap |
	i _ 1.
	varMap _ Dictionary new: 100.
	args, locals do: [ :v |
		varMap at: v put: ('t', i printString) asSymbol.
		i _ i + 1.
	].
	self renameVariablesUsing: varMap.
	^ i - 1! !

!TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'!
renameVarsForInliningInto: destMethod in: aCodeGen
	"Rename any variables that would clash with those of the destination method."

	| destVars usedVars varMap newVarName |
	destVars _ aCodeGen globalsAsSet copy.
	destVars addAll: destMethod locals.
	destVars addAll: destMethod args.
	usedVars _ destVars copy.  "keeps track of names in use"
	usedVars addAll: args; addAll: locals.
	varMap _ Dictionary new: 100.
	args, locals do: [ :v |
		(destVars includes: v) ifTrue: [
			newVarName _ self unusedNamePrefixedBy: v avoiding: usedVars.
			varMap at: v put: newVarName.
		].
	].
	self renameVariablesUsing: varMap.! !

!TMethod methodsFor: 'inlining support'!
unusedNamePrefixedBy: aString avoiding: usedNames
	"Choose a unique variable or label name with the given string as a prefix, avoiding the names in the given collection. The selected name is added to usedNames."

	| n newVarName |
	n _ 1.
	newVarName _ aString, n printString.
	[usedNames includes: newVarName] whileTrue: [
		n _ n + 1.
		newVarName _ aString, n printString.
	].
	usedNames add: newVarName.
	^ newVarName! !


!TMethod methodsFor: 'C code generation' stamp: 'hg 8/14/2000 15:41'!
emitCCodeOn: aStream generator: aCodeGen
	"Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded."

	self emitCCommentOn: aStream.	"place method comment before function"

	self emitCHeaderOn: aStream generator: aCodeGen.
	parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen.
	aStream nextPutAll: '}'; cr.! !

!TMethod methodsFor: 'C code generation' stamp: 'hg 8/14/2000 16:09'!
emitCCommentOn: aStream
	"Emit the transferred Smalltalk comments as C comments."

	comment ifNotNil: [
		aStream cr;cr.
		1 to: comment size do: [:index | 
			aStream 
				nextPutAll: '/*'; tab;
				nextPutAll: (comment at: index);
				nextPutAll: ' */';
				cr]]! !

!TMethod methodsFor: 'C code generation' stamp: 'ar 5/9/2000 12:13'!
emitCFunctionPrototype: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	| arg |
	export 
		ifTrue:[aStream nextPutAll:'EXPORT('; nextPutAll: returnType; nextPutAll:') ']
		ifFalse:[(aCodeGen isGeneratingPluginCode and:[self isStatic]) 
					ifTrue:[aStream nextPutAll:'static '].
				aStream nextPutAll: returnType; space].
	aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg _ args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'int ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !

!TMethod methodsFor: 'C code generation'!
emitCHeaderOn: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	aStream cr.
	self emitCFunctionPrototype: aStream generator: aCodeGen.
	aStream nextPutAll: ' {'; cr.
	locals do: [ :var |
		aStream nextPutAll: '    '.
		aStream nextPutAll: (declarations at: var ifAbsent: [ 'int ', var]), ';'; cr.
	].
	locals isEmpty ifFalse: [ aStream cr ].! !

!TMethod methodsFor: 'C code generation' stamp: 'ar 9/18/1998 23:25'!
emitProxyFunctionPrototype: aStream generator: aCodeGen
	"Emit an indirect C function header for this method onto the given stream."

	| arg |
	aStream nextPutAll: returnType; space.
	aStream nextPutAll: '(*', (aCodeGen cFunctionNameFor: selector), ')('.
	args isEmpty ifTrue: [ aStream nextPutAll: 'void' ].
	1 to: args size do: [ :i |
		arg _ args at: i.
		(declarations includesKey: arg) ifTrue: [
			aStream nextPutAll: (declarations at: arg).
		] ifFalse: [
			aStream nextPutAll: 'int ', (args at: i).
		].
		i < args size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !


!TMethod methodsFor: 'printing' stamp: 'TPR 3/2/2000 18:36'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' (', selector, ')'.! !


!TMethod methodsFor: 'private' stamp: 'TPR 2/29/2000 18:45'!
printTempsAndVar: varName on: aStream 
	"add the required temps and the varname to the stream"
	aStream nextPutAll: '| rcvr stackPointer successFlag ' , varName , ' |';
	 cr! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TMethod class
	instanceVariableNames: ''!

!TMethod class methodsFor: 'class initialization' stamp: 'ar 11/18/1999 20:06'!
initialize
	"TMethod initialize"	
	CaseStatements _ IdentitySet new: 10.
	CaseStatements addAll: #(dispatchOn:in: dispatchOn:in:with: dispatchOn:in:with:with:).! !
Object subclass: #TParseNode
	instanceVariableNames: 'comment '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TParseNode methodsFor: 'as yet unclassified'!
allCalls
	"Answer a collection of selectors for the messages sent in this parse tree."

	| calls |
	calls _ Set new: 100.
	self nodesDo: [ :node |
		node isSend ifTrue: [ calls add: node selector ].
	].
	^calls! !

!TParseNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:13'!
bindVariableUsesIn: aDictionary
	"Bind uses of all variables in the given dictionary, but do not change variables that appear on the left-hand-side of an assignment statement."

	^ self
! !

!TParseNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	^self! !

!TParseNode methodsFor: 'as yet unclassified'!
hasExplicitReturn

	self nodesDo: [ :node |
		node isReturn ifTrue: [ ^true ].
	].
	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	self! !

!TParseNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isAssignment

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isCaseStmt

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isComment

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isConstant

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isGoTo

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isLabel

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isLeaf
	"Answer true if the receiver is a variable or a constant node."

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isReturn

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isSend

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isStmtList

	^false! !

!TParseNode methodsFor: 'as yet unclassified'!
isVariable

	^false! !

!TParseNode methodsFor: 'as yet unclassified' stamp: 'acg 12/17/1999 07:21'!
nameOrValue

	self error: 'object is neither variable nor constant'! !

!TParseNode methodsFor: 'as yet unclassified'!
nodeCount
	"Answer the number of nodes in this parseTree (a rough measure of its size)."

	| cnt |
	cnt _ 0.
	self nodesDo: [ :n | cnt _ cnt + 1 ].
	^cnt! !

!TParseNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	aBlock value: self.! !

!TParseNode methodsFor: 'as yet unclassified'!
printOn: aStream 
	"Append a description of the receiver onto the given stream."

	self printOn: aStream level: 0.! !

!TParseNode methodsFor: 'as yet unclassified'!
printOn: aStream level: anInteger 
	"Typically overridden. If control actually gets here, avoid recursion loop by sending to super."

	super printOn: aStream.! !

!TParseNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	"default: do nothing"! !

!TParseNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [self]! !


!TParseNode methodsFor: 'emit comments' stamp: 'hg 8/14/2000 15:32'!
comment: aComment

	comment _ aComment ! !

!TParseNode methodsFor: 'emit comments' stamp: 'hg 8/14/2000 16:13'!
emitCCommentOn: aStream level: level
	"Emit the transferred Smalltalk comments as C comments."

	comment ifNotNil: [
		comment isString ifTrue: [^self].	"safety catch"
		aStream cr.
		1 to: comment size do: [:index | 
			aStream 
				tab: level;
				nextPutAll: '/* ';
				nextPutAll: (comment at: index);
				nextPutAll: ' */';
				cr].
		aStream cr]! !
TParseNode subclass: #TReturnNode
	instanceVariableNames: 'expression '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TReturnNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	expression _ expression bindVariableUsesIn: aDictionary.! !

!TReturnNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	expression _ expression bindVariablesIn: aDictionary.! !

!TReturnNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setExpression: expression copyTree! !

!TReturnNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen

	aStream nextPutAll: 'return '.
	expression emitCCodeOn: aStream level: level generator: aCodeGen.! !

!TReturnNode methodsFor: 'as yet unclassified'!
expression

	^expression! !

!TReturnNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	expression _ expression inlineMethodsUsing: aDictionary.! !

!TReturnNode methodsFor: 'as yet unclassified'!
isReturn

	^true! !

!TReturnNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	expression nodesDo: aBlock.
	aBlock value: self.! !

!TReturnNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	aStream nextPut: $^.
	expression printOn: aStream level: level.! !

!TReturnNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	expression removeAssertions! !

!TReturnNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		expression _ expression replaceNodesIn: aDictionary.
		self]! !

!TReturnNode methodsFor: 'as yet unclassified'!
setExpression: aNode

	expression _ aNode.! !
TParseNode subclass: #TSendNode
	instanceVariableNames: 'selector receiver arguments isBuiltinOperator '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TSendNode methodsFor: 'as yet unclassified'!
args

	^arguments! !

!TSendNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	receiver _ receiver bindVariableUsesIn: aDictionary.
	arguments _ arguments collect: [ :a | a bindVariableUsesIn: aDictionary ].! !

!TSendNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	receiver _ receiver bindVariablesIn: aDictionary.
	arguments _ arguments collect: [ :a | a bindVariablesIn: aDictionary ].! !

!TSendNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setSelector: selector
		receiver: receiver copyTree
		arguments: (arguments collect: [ :arg | arg copyTree ])
		isBuiltInOp: isBuiltinOperator! !

!TSendNode methodsFor: 'as yet unclassified' stamp: 'jm 12/14/1998 08:36'!
emitCCodeOn: aStream level: level generator: aCodeGen

	"If the selector is a built-in construct, translate it and return"
	(aCodeGen emitBuiltinConstructFor: self on: aStream level: level) ifTrue: [ ^self ].

	"Special case for pluggable modules. Replace messages to interpreterProxy
	by interpreterProxy->message(..) if the message is not builtin"
	(aCodeGen isGeneratingPluginCode and:[
		receiver isVariable and:[
			'interpreterProxy' = receiver name and:[
				self isBuiltinOperator not]]]) 
		ifTrue:[aStream nextPutAll:'interpreterProxy->'].
	"Translate this message send into a C function call."
	aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('.
	(receiver isVariable and:
	 [('self' = receiver name) or: ['interpreterProxy' = receiver name]]) ifFalse: [
		"self is omitted from the arguments list of the generated call"
		"Note: special case for translated BitBltSimulator--also omit
		 the receiver if this is a send to the variable 'interpreterProxy'"
		receiver emitCCodeOn: aStream level: level generator: aCodeGen.
		arguments isEmpty ifFalse: [ aStream nextPutAll: ', ' ].
	].
	1 to: arguments size do: [ :i |
		(arguments at: i) emitCCodeOn: aStream level: level generator: aCodeGen.
		i < arguments size ifTrue: [ aStream nextPutAll: ', ' ].
	].
	aStream nextPutAll: ')'.! !

!TSendNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	arguments _ arguments collect: [ :arg |
		arg inlineMethodsUsing: aDictionary.
	].
	"xxx inline this message if it is in the dictionary xxx"! !

!TSendNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
isAssertion
	^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! !

!TSendNode methodsFor: 'as yet unclassified'!
isBuiltinOperator

	^ isBuiltinOperator! !

!TSendNode methodsFor: 'as yet unclassified'!
isBuiltinOperator: builtinFlag

	isBuiltinOperator _ builtinFlag.! !

!TSendNode methodsFor: 'as yet unclassified'!
isSend

	^true! !

!TSendNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	receiver nodesDo: aBlock.
	arguments do: [ :arg | arg nodesDo: aBlock ].
	aBlock value: self.! !

!TSendNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	| keywords |
	receiver printOn: aStream level: level.
	arguments size = 0 ifTrue: [
		aStream space; nextPutAll: selector.
		^self
	].
	keywords _ selector keywords.
	1 to: keywords size do: [ :i |
		aStream space.
		aStream nextPutAll: (keywords at: i); space.
		(arguments at: i) printOn: aStream level: level + 1.
	].! !

!TSendNode methodsFor: 'as yet unclassified'!
receiver

	^receiver! !

!TSendNode methodsFor: 'as yet unclassified'!
receiver: aNode

	receiver _ aNode.! !

!TSendNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	receiver removeAssertions.
	arguments do: [:arg | arg removeAssertions].! !

!TSendNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		receiver _ receiver replaceNodesIn: aDictionary.
		arguments _ arguments collect: [ :a | a replaceNodesIn: aDictionary ].
		self]! !

!TSendNode methodsFor: 'as yet unclassified'!
selector

	^selector! !

!TSendNode methodsFor: 'as yet unclassified'!
setSelector: aSymbol receiver: rcvrNode arguments: argList

	selector _ aSymbol.
	receiver _ rcvrNode.
	arguments _ argList asArray.
	isBuiltinOperator _ false.! !

!TSendNode methodsFor: 'as yet unclassified'!
setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: builtinFlag

	selector _ aSymbol.
	receiver _ rcvrNode.
	arguments _ argList asArray.
	isBuiltinOperator _ builtinFlag.! !
TParseNode subclass: #TStmtListNode
	instanceVariableNames: 'arguments statements '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TStmtListNode methodsFor: 'as yet unclassified'!
args

	^arguments! !

!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'jm 12/10/1998 18:26'!
bindVariableUsesIn: aDictionary

	statements _ statements collect: [ :s | s bindVariableUsesIn: aDictionary ].! !

!TStmtListNode methodsFor: 'as yet unclassified'!
bindVariablesIn: aDictionary

	statements _ statements collect: [ :s | s bindVariablesIn: aDictionary ].! !

!TStmtListNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new
		setArguments: arguments copy
		statements: (statements collect: [ :s | s copyTree ])! !

!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'hg 8/14/2000 15:29'!
emitCCodeOn: aStream level: level generator: aCodeGen

	statements do: [:s |
		s emitCCommentOn: aStream level: level.
		aStream tab: level.
		s emitCCodeOn: aStream level: level generator: aCodeGen.
		((self endsWithCloseBracket: aStream) or:
		 [s isComment])
			ifFalse: [aStream nextPut: $;].
		aStream cr].
! !

!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'jm 11/25/1998 16:26'!
endsWithCloseBracket: aStream
	"Answer true if the given stream ends in a $} character."

	| ch pos |
	(pos _ aStream position) > 0 ifTrue: [
		aStream position: pos - 1.
		ch _ aStream next].
	^ ch = $}
! !

!TStmtListNode methodsFor: 'as yet unclassified'!
inlineMethodsUsing: aDictionary

	statements do: [ :s | s inlineMethodsUsing: aDictionary ].! !

!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'acg 12/21/1999 02:25'!
isNilStmtListNode

	|stmt|
	statements size = 1 ifFalse: [^false].
	stmt _ statements at: 1.
	^ stmt isVariable and: [stmt name = 'nil']! !

!TStmtListNode methodsFor: 'as yet unclassified'!
isStmtList

	^true! !

!TStmtListNode methodsFor: 'as yet unclassified'!
nodesDo: aBlock

	statements do: [ :s | s nodesDo: aBlock ].	
	aBlock value: self.! !

!TStmtListNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	aStream nextPut: $[.
	arguments size > 0 ifTrue: [
		arguments do: [ :arg | aStream nextPutAll: ' :', arg ].
		aStream nextPutAll: ' | '.
	].
	self printStatementsOn: aStream level: level.
	aStream nextPut: $].! !

!TStmtListNode methodsFor: 'as yet unclassified'!
printStatementsOn: aStream level: level

	statements size > 1 ifTrue: [ aStream crtab: level + 1 ].
	1 to: statements size do: [ :i |
		(statements at: i) printOn: aStream level: level.
		i = statements size ifTrue: [
			(statements size > 1) ifTrue: [
				aStream crtab: level.
			].
		] ifFalse: [
			aStream nextPut: $.; crtab: level + 1.
		].
	].! !

!TStmtListNode methodsFor: 'as yet unclassified' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
	| newStatements |
	newStatements _ OrderedCollection new: statements size.
	statements do: [ :stmt |
		stmt isAssertion ifFalse: [
			newStatements add: (stmt removeAssertions; yourself).
		]
	].
	self setStatements: newStatements asArray! !

!TStmtListNode methodsFor: 'as yet unclassified'!
replaceNodesIn: aDictionary

	^aDictionary at: self ifAbsent: [
		statements _ statements collect: [ :s | s replaceNodesIn: aDictionary ].
		self]! !

!TStmtListNode methodsFor: 'as yet unclassified'!
setArguments: argList

	arguments _ argList.! !

!TStmtListNode methodsFor: 'as yet unclassified'!
setArguments: argList statements: statementList
	"Initialize this method using the given information."

	arguments _ argList.
	statements _ statementList.! !

!TStmtListNode methodsFor: 'as yet unclassified'!
setStatements: stmtList

	statements _ stmtList asOrderedCollection.! !

!TStmtListNode methodsFor: 'as yet unclassified'!
statements

	^statements! !
TTGlyph subclass: #TTCompositeGlyph
	instanceVariableNames: 'glyphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Fonts'!

!TTCompositeGlyph methodsFor: 'initialize' stamp: 'ar 11/2/1998 01:20'!
initialize
	glyphs _ #().! !


!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:21'!
addGlyph: aGlyph transformation: aMatrix
	glyphs _ glyphs copyWith: (aMatrix -> aGlyph)! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:43'!
contours
	^contours ifNil:[contours _ self computeContours]! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:20'!
glyphs

	^glyphs collect:[:assoc| assoc value].! !

!TTCompositeGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:28'!
glyphsAndTransformationsDo: aBlock
	glyphs do:[:assoc|
		aBlock value: assoc value value: assoc key.
	].! !


!TTCompositeGlyph methodsFor: 'testing'!
isComposite
	^true! !


!TTCompositeGlyph methodsFor: 'private' stamp: 'ar 11/2/1998 01:43'!
computeContours
	| out |
	out _ WriteStream on: (Array new: glyphs size * 4).
	self glyphsAndTransformationsDo:[:glyph :transform|
		glyph contours do:[:ptArray|
			out nextPut: (transform localPointsToGlobal: ptArray).
		].
	].
	^out contents! !

!TTCompositeGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:27'!
flipAroundY
	bounds _ (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	contours _ nil.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTCompositeGlyph class
	instanceVariableNames: ''!

!TTCompositeGlyph class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 01:20'!
new
	^super new initialize! !
Object subclass: #TTContourConstruction
	instanceVariableNames: 'points '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!
!TTContourConstruction commentStamp: '<historical>' prior: 0!
This class represents a temporary contour structure during the construction of a TTGlyph from a TrueType file.

Instance variables:
	points	<Array of: TTPoint>	The points defining this contour!


!TTContourConstruction methodsFor: 'accessing'!
points
	^points! !

!TTContourConstruction methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:34'!
points: anArray
	points _ anArray asArray.! !

!TTContourConstruction methodsFor: 'accessing'!
segments

	| segments |
	segments _ OrderedCollection new.
	self segmentsDo:[:seg| segments add: seg].
	^segments! !


!TTContourConstruction methodsFor: 'enumerating' stamp: 'ar 11/3/1998 14:42'!
segmentsDo: aBlock
	"Evaluate aBlock with the segments of the receiver. This may either be straight line
	segments or quadratic bezier curves. The decision is made upon the type flags
	in TTPoint as follows:
	a) 	To subsequent #OnCurve points define a straight segment
	b) 	A #OnCurve point followed by a #OffCurve point followed 
		by a #TT_ONCURVE point defines a quadratic bezier segment
	c)	Two subsequent #OffCurve points have an implicitely defined 
		#OnCurve point at half the distance between them"
	| last next mid index |
	last _ points first.
	"The first point is _always_ on the curve"
	(last type == #OnCurve) ifFalse:[
		Transcript cr; show:'Bad starting point OffCurve'.
		last type: #OnCurve].
	index _ 2.
	[index <= points size] whileTrue:[
		mid _ points at: index.
		mid type == #OnCurve ifTrue:[
			"Straight segment"
			aBlock value: (LineSegment from: last asPoint to: mid asPoint).
			last _ mid.
		] ifFalse:["Quadratic bezier"
			"Read ahead if the next point is on curve"
			next _ (index < points size) ifTrue:[points at: (index+1)] ifFalse:[points first].
			next type == #OnCurve ifTrue:[
				"We'll continue after the end point"
				index _ index + 1.
			] ifFalse:[ "Calculate center"
				next _ (next asPoint + mid asPoint) // 2].
			aBlock value:(Bezier2Segment from: last asPoint via: mid asPoint to: next asPoint).
			last _ next].
		index _ index + 1].
	(index = (points size + 1)) ifTrue:[
		aBlock value:(LineSegment from: points last asPoint to: points first asPoint)]! !


!TTContourConstruction methodsFor: 'converting' stamp: 'di 11/21/1999 20:19'!
asCompressedPoints
	"Return the receiver compressed into a PointArray.
	All lines will be converted into bezier segments with
	the control point set to the start point"
	| out minPt maxPt fullRange |
	minPt _ -16r7FFF asPoint.
	maxPt _ 16r8000 asPoint.
	"Check if we need full 32bit range"
	fullRange _ points anySatisfy: [:any| any asPoint < minPt or:[any asPoint > maxPt]].
	fullRange ifTrue:[
		out _ WriteStream on: (PointArray new: points size).
	] ifFalse:[
		out _ WriteStream on: (ShortPointArray new: points size).
	].
	self segmentsDo:[:segment|
		out nextPut: segment start.
		segment isBezier2Segment 
			ifTrue:[out nextPut: segment via]
			ifFalse:[out nextPut: segment start].
		out nextPut: segment end.
	].
	^out contents! !


!TTContourConstruction methodsFor: 'printing'!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut:$(;
		print: points size;
		"space;
		print: self type;"
		nextPut:$)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTContourConstruction class
	instanceVariableNames: ''!

!TTContourConstruction class methodsFor: 'instance creation'!
on: points

	^self new points: points! !
Object subclass: #TTFontDescription
	instanceVariableNames: 'glyphTable glyphs kernPairs copyright familyName fullName subfamilyName uniqueName versionName postscriptName trademark bounds unitsPerEm ascender descender lineGap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Fonts'!

!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'!
at: aCharOrInteger
	^glyphTable at: aCharOrInteger asInteger+1! !

!TTFontDescription methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:08'!
at: index put: value
	^self shouldNotImplement! !


!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
ascender
	^ascender! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
bounds
	^bounds! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
descender
	^descender! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:48'!
lineGap
	^lineGap! !

!TTFontDescription methodsFor: 'properties' stamp: 'ar 11/14/1998 23:49'!
unitsPerEm
	^unitsPerEm! !


!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
copyright
	^copyright! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
familyName
	^familyName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
fullName
	^fullName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
postscriptName
	^postscriptName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
subfamilyName
	^subfamilyName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
trademark
	^trademark! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:48'!
uniqueName
	^uniqueName! !

!TTFontDescription methodsFor: 'information' stamp: 'ar 11/14/1998 23:49'!
versionName
	^versionName! !


!TTFontDescription methodsFor: 'converting' stamp: 'ar 11/14/1998 23:47'!
asMorph
	^TTSampleFontMorph font: self! !

!TTFontDescription methodsFor: 'converting' stamp: 'sma 5/5/2000 13:46'!
asStrikeFontScale: scale
	"Generate a StrikeFont (actually a FormSetFont) for this TTF font at a given scale."

	| forms |
	forms _ (0 to: 255) collect:
		[:i |
		(self at: i)
			asFormWithScale: scale
			ascender: ascender
			descender: descender].
	^ FormSetFont new
		fromFormArray: forms
		asciiStart: 0
		ascent: (ascender * scale) rounded! !


!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/14/1998 20:20'!
flipAroundY
	bounds _ (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	glyphs do:[:glyph| glyph flipAroundY]! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'!
setAscender: asc descender: desc lineGap: lgap
	ascender _ asc.
	descender _ desc.
	lineGap _ lgap! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:28'!
setBounds: aRect unitsPerEm: aNumber
	bounds _ aRect.
	unitsPerEm _ aNumber.! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:27'!
setGlyphs: glyphArray mapping: mappingTable
	glyphs _ glyphArray.
	glyphTable _ mappingTable.! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:48'!
setKernPairs: array
	kernPairs _ array! !

!TTFontDescription methodsFor: 'private-initialization' stamp: 'ar 11/2/1998 00:46'!
setStrings: anArray
	copyright _ anArray at: 1.
	familyName _ anArray at: 2.
	subfamilyName _ anArray at: 3.
	uniqueName _ anArray at: 4.
	fullName _ anArray at: 5.
	versionName _ anArray at: 6.
	postscriptName _ anArray at: 7.
	trademark _ anArray at: 8.
! !
Object subclass: #TTFontReader
	instanceVariableNames: 'charMap glyphs nGlyphs kernPairs infoBar fontDescription '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!

!TTFontReader methodsFor: 'public' stamp: 'ar 11/2/1998 23:51'!
readFrom: aStream

	| fontData headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat |

	"Read the raw font byte data"
	(aStream respondsTo: #binary) ifTrue:[aStream binary].
	fontData _ aStream contents asByteArray.
	fontDescription _ TTFontDescription new.

	"Search the tables required to build the font"
	(headerEntry _ self getTableDirEntry: 'head' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a header table'].
	(maxProfileEntry _ self getTableDirEntry: 'maxp' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a maximum profile table'].
	(nameEntry _ self getTableDirEntry: 'name' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a name table'].
	(indexLocEntry _ self getTableDirEntry: 'loca' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a relocation table'].
	(charMapEntry _ self getTableDirEntry: 'cmap' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a character map table'].
	(glyphEntry _ self getTableDirEntry: 'glyf' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a glyph table'].
	(horzHeaderEntry _ self getTableDirEntry: 'hhea' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a horizontal header table'].
	(horzMetricsEntry _ self getTableDirEntry: 'hmtx' from: fontData) == nil ifTrue:[
		^self error:'This font does not have a horizontal metrics table'].
	(kerningEntry _ self getTableDirEntry: 'kern' from: fontData) == nil ifTrue:[
		Transcript cr; show:'This font does not have a kerning table';endEntry].


	"Process the data"
	indexToLocFormat _ self processFontHeaderTable: headerEntry.
	self processMaximumProfileTable: maxProfileEntry.
	self processNamingTable: nameEntry.
	glyphOffset _ self processIndexToLocationTable: indexLocEntry format: indexToLocFormat.
	cmap _ self processCharacterMappingTable: charMapEntry.
	(cmap == nil or:[cmap value == nil])
		ifTrue:[^self error:'This font has no suitable character mappings'].
	self processGlyphDataTable: glyphEntry offsets: glyphOffset.
	numHMetrics _ self processHorizontalHeaderTable: horzHeaderEntry.
	self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics.
	kerningEntry isNil 
		ifTrue:[kernPairs _ #()]
		ifFalse:[self processKerningTable: kerningEntry].
	charMap _ self processCharMap: cmap.
	fontDescription setGlyphs: glyphs mapping: charMap.
	fontDescription setKernPairs: kernPairs.
	^fontDescription! !


!TTFontReader methodsFor: 'processing' stamp: 'sma 3/11/2000 20:30'!
processCharMap: assoc
	"Process the given character map"

	| charTable glyph cmap |
	cmap _ assoc value.
	charTable _ Array new: 256 withAll: glyphs first. "Initialize with default glyph"

	assoc key = 1 ifTrue: "Mac encoded table"
		[1 to: (cmap size min: charTable size) do:
			[:i |
			glyph _ glyphs at: (cmap at: i) + 1.
			charTable at: i put: glyph]].

	assoc key = 3 ifTrue: "Win encoded table"
		[1 to: (cmap size min: charTable size) do:
			[:i |
			glyph _ glyphs at: (cmap at: i) + 1.
			charTable at: (self winToMac: i) put: glyph]].

	^ charTable! !

!TTFontReader methodsFor: 'processing' stamp: 'sma 1/1/2000 17:01'!
processCharacterMappingTable: entry
	"Read the font's character to glyph index mapping table.
	If an appropriate mapping can be found then return an association
	with the format identifier and the contents of the table"
	| copy initialOffset nSubTables pID sID offset cmap assoc |
	initialOffset _ entry offset.
	entry skip: 2. "Skip table version"
	nSubTables _ entry nextUShort.
	1 to: nSubTables do:[:i|
		pID _ entry nextUShort.
		sID _ entry nextUShort.
		offset _ entry nextULong.
		"Check if this is either a Macintosh encoded table
		or a Windows encoded table"
		(pID = 1 or:[pID = 3]) ifTrue:[
			"Go to the beginning of the table"
			copy _ entry copy.
			copy offset: initialOffset + offset.
			cmap _ self decodeCmapFmtTable: copy.
			(pID = 1 and: [cmap notNil]) "Prefer Macintosh encoding over everything else"
				ifTrue: [^ pID -> cmap].
			assoc _ pID -> cmap. "Keep it in case we don't find a Mac encoded table"
		].
	].
	^assoc! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/15/1998 01:00'!
processCompositeGlyph: glyph contours: nContours from: entry
	"Read a composite glyph from the font data. The glyph passed into this method contains some state variables that must be copied into the resulting composite glyph."
	| flags glyphIndex hasInstr cGlyph ofsX ofsY iLen a11 a12 a21 a22 m |
	cGlyph _ TTCompositeGlyph new.
	a11 _ a22 _ 16r4000.	"1.0 in F2Dot14"
	a21 _ a12 _ 0.		"0.0 in F2Dot14"
	"Copy state"
	cGlyph bounds: glyph bounds; glyphIndex: glyph glyphIndex.
	hasInstr _ false.
	[ flags _ entry nextUShort.
	glyphIndex _ entry nextUShort + 1.
	(flags bitAnd: 1) = 1 ifTrue:[
		ofsX _ entry nextShort.
		ofsY _ entry nextShort.
	] ifFalse:[
		(ofsX _ entry nextByte) > 127 ifTrue:[ofsX _ ofsX - 256].
		(ofsY _ entry nextByte) > 127 ifTrue:[ofsY _ ofsY - 256]].
	((flags bitAnd: 2) = 2) ifFalse:[self halt].
	(flags bitAnd: 8) = 8 ifTrue:[
		a11 _ a22 _ entry nextShort].
	(flags bitAnd: 64) = 64 ifTrue:[
		a11 _ entry nextShort.
		a22 _ entry nextShort].
	(flags bitAnd: 128) = 128 ifTrue:[
		"2x2 transformation"
		a11 _ entry nextShort.
		a21 _ entry nextShort.
		a12 _ entry nextShort.
		a22 _ entry nextShort].
	m _ MatrixTransform2x3 new.
	"Convert entries from F2Dot14 to float"
	m a11: (a11 asFloat / 16r4000).
	m a12: (a12 asFloat / 16r4000).
	m a21: (a21 asFloat / 16r4000).
	m a22: (a22 asFloat / 16r4000).
	m a13: ofsX.
	m a23: ofsY.
	cGlyph addGlyph: (glyphs at: glyphIndex) transformation: m.
	hasInstr _ hasInstr or:[ (flags bitAnd: 256) = 256].
	"Continue as long as the MORE_COMPONENTS bit is set"
	(flags bitAnd: 32) = 32] whileTrue.
	hasInstr ifTrue:[
		iLen _ entry nextUShort.
		entry skip: iLen].
	^cGlyph! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:42'!
processFontHeaderTable: entry
"Value				Data Type    Description
unitsPerEm			USHORT      Granularity of the font's em square.
xMax				USHORT      Maximum X-coordinate for the entire font.
xMin				USHORT      Minimum X-coordinate for the entire font.
yMax				USHORT      Maximum Y-coordinate for the entire font.
yMin				USHORT      Minimum Y-coordinate for the entire font.
indexToLocFormat	SHORT       Used when processing the Index To Loc Table."
	| origin corner units indexToLocFormat |
	entry skip: 4. "Skip table version number"
	entry skip: 4. "Skip font revision number"
	entry skip: 4. "Skip check sum adjustment"
	entry skip: 4. "Skip magic number"
	entry skip: 2. "Skip flags"

	units _ entry nextUShort.

	entry skip: 8. "Skip creation date"
	entry skip: 8. "Skip modification date"

	"Get min/max values of all glyphs"
	origin _ entry nextShort @ entry nextShort.
	corner _ entry nextShort @ entry nextShort.

	entry skip: 2. "Skip mac style"
	entry skip: 2. "Skip lowest rec PPEM"
	entry skip: 2. "Skip font direction hint"
	indexToLocFormat _ entry nextShort.

	fontDescription setBounds: (origin corner: corner) unitsPerEm: units.
	^indexToLocFormat! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/3/1998 14:43'!
processGlyphDataTable: entry offsets: offsetArray
	"Read the actual glyph data from the font.
	offsetArray contains the start offsets in the data for each glyph."
	| initialOffset glyph nextOffset glyphLength glyphOffset nContours origin corner |
	initialOffset _ entry offset.
	glyphs _ Array new: nGlyphs.
	1 to: nGlyphs do:[:i | 
		glyphs at: i put: (TTGlyph new glyphIndex: i-1)].
	'Reading glyph data' 
		displayProgressAt: Sensor cursorPoint
		from: 1 to: nGlyphs during:[:bar|

	1 to: nGlyphs do:[:glyphIndex |
		bar value: glyphIndex.
		glyph _ glyphs at: glyphIndex.
		glyphOffset _ offsetArray at: glyphIndex.
		nextOffset _ offsetArray at: glyphIndex+1.
		glyphLength _ nextOffset - glyphOffset.
		glyphLength = 0 ifFalse:[
			entry offset: initialOffset + glyphOffset.
			nContours _ entry nextShort.
			origin _ entry nextShort @ entry nextShort.
			corner _ entry nextShort @ entry nextShort.
			glyph bounds: (origin corner: corner).
			nContours >= 0 ifTrue:[
				self processSimpleGlyph: glyph contours: nContours from: entry
			] ifFalse:[
				glyph _ self processCompositeGlyph: glyph contours: nContours from: entry.
				glyphs at: glyphIndex put: glyph]]]
	].! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'!
processHorizontalHeaderTable: entry
"
ascender           SHORT          Typographic ascent.
descender          SHORT          Typographic descent.
lineGap            SHORT          Typographic lineGap.
numberOfHMetrics   USHORT         Number hMetric entries in the HTMX
                                               Table; may be smaller than the total
                                             number of glyphs.
"
	| asc desc lGap numHMetrics |
	entry skip: 4. "Skip table version"
	asc _ entry nextShort.
	desc _ entry nextShort.
	lGap _ entry nextShort.
	entry skip: 2. "Skip advanceWidthMax"
	entry skip: 2. "Skip minLeftSideBearing"
	entry skip: 2. "Skip minRightSideBearing"
	entry skip: 2. "Skip xMaxExtent"
	entry skip: 2. "Skip caretSlopeRise"
	entry skip: 2. "Skip caretSlopeRun"
	entry skip: 10. "Skip 5 reserved shorts"
	entry skip: 2. "Skip metricDataFormat"

	numHMetrics _ entry nextUShort.

	fontDescription setAscender: asc descender: desc lineGap: lGap.
	^numHMetrics! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:40'!
processHorizontalMetricsTable: entry length: numHMetrics
	"Extract the advance width, left side bearing, and right
	side bearing for each glyph from the Horizontal Metrics Table."
	|  index lastAW glyph |
	index _ 1.
	[index <= numHMetrics] whileTrue:[
		glyph _ glyphs at: index.
		glyph advanceWidth: entry nextUShort.
		glyph leftSideBearing: entry nextShort.
		glyph updateRightSideBearing.
		index _ index + 1].
	index = (nGlyphs +1) ifTrue:[^true].
	lastAW _ (glyphs at: index-1) advanceWidth.

	[index <= nGlyphs] whileTrue:[
		glyph _ glyphs at: index.
		glyph advanceWidth: lastAW.
		glyph leftSideBearing: entry nextShort.
		glyph updateRightSideBearing.
		index _ index + 1].! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:43'!
processIndexToLocationTable: entry format: indexToLocFormat
"glyphOffset    ULONG[numGlyphs]   An array that contains each glyph's
                                 offset into the Glyph Data Table.
"	| glyphOffset offset|
	glyphOffset _ Array new: nGlyphs+1.
	1 to: nGlyphs+1 do:[:i|
		(indexToLocFormat = 0) ifTrue:[ "Format0: offset/2 is stored"
			offset _ entry nextUShort * 2.
		] ifFalse:["Format1: store actual offset"
			offset _ entry nextULong].
		glyphOffset at: i put: offset].
	^glyphOffset! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 23:21'!
processKerningTable: entry
	"Extract the kerning information for pairs of glyphs."
	| covLow covHigh nKernPairs kp |
	entry skip: 2. "Skip table version"
	entry skip: 2. "Skip number of sub tables -- we're using the first one only"
	entry skip: 2. "Skip current subtable number"
	entry skip: 2. "Skip length of subtable"
	covHigh _ entry nextByte.
	covLow _ entry nextByte.

	"Make sure the format is right (kerning table and format type 0)"
	((covLow bitAnd: 2) = 2 or:[ covHigh ~= 0]) ifTrue:[^false].
	nKernPairs _ entry nextUShort.
	entry skip: 2. "Skip search range"
	entry skip: 2. "Skip entry selector"
	entry skip: 2. "Skip range shift"
	kernPairs _ Array new: nKernPairs.
	1 to: nKernPairs do:[:i|
		kp _ TTKernPair new.
		kp left: entry nextUShort.
		kp right: entry nextUShort.
		kp value: entry nextShort.
		kernPairs at: i put: kp].
	^true! !

!TTFontReader methodsFor: 'processing'!
processMaximumProfileTable: entry
"
numGlyphs         USHORT      The number of glyphs in the font.
"
	entry skip: 4. "Skip Table version number"
	nGlyphs _ entry nextUShort.! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/2/1998 00:38'!
processNamingTable: entry
"copyright         CHARPTR     The font's copyright notice.
familyName        CHARPTR     The font's family name.
subfamilyName     CHARPTR     The font's subfamily name.
uniqueName        CHARPTR     A unique identifier for this font.
fullName          CHARPTR     The font's full name (a combination of
                                          familyName and subfamilyName).
versionName       CHARPTR     The font's version string.
"	| nRecords initialOffset storageOffset pID sID lID nID length offset multiBytes string strings |
	strings _ Array new: 8.
	strings atAllPut:''.
	initialOffset _ entry offset.
	entry skip: 2. "Skip format selector"
	"Get the number of name records"
	nRecords _ entry nextUShort.
	"Offset from the beginning of this table"
	storageOffset _ entry nextUShort + initialOffset.
	1 to: nRecords do:[:i|
		pID _ entry nextUShort.
		sID _ entry nextUShort.
		lID _ entry nextUShort.
		nID _ entry nextUShort.
		length _ entry nextUShort.
		offset _ entry nextUShort.
		"Read only Macintosh or Microsoft strings"
		(pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[
			"MS uses Unicode all others single byte"
			multiBytes _ pID = 3.
			string _ entry stringAt: storageOffset + offset length: length multiByte: multiBytes.
			"Put the name at the right location.
			Note: We prefer Macintosh strings about everything else."
			nID < strings size ifTrue:[
				(pID = 1 or:[(strings at: nID+1) = ''])
					ifTrue:[strings at: nID+1 put: string].
			].
		].
	].
	fontDescription setStrings: strings.! !

!TTFontReader methodsFor: 'processing' stamp: 'ar 11/1/1998 22:18'!
processSimpleGlyph: glyph contours: nContours from: entry

	| endPts  nPts iLength flags |
	endPts _ Array new: nContours.
	1 to: nContours do:[:i| endPts at: i put: entry nextUShort].
	glyph initializeContours: nContours with: endPts.
	nPts _ endPts last + 1.
	iLength _ entry nextUShort. "instruction length"
	entry skip: iLength.
	flags _ self getGlyphFlagsFrom: entry size: nPts.
	self readGlyphXCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
	self readGlyphYCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
	glyph buildContours.! !


!TTFontReader methodsFor: 'private' stamp: 'sma 1/1/2000 19:17'!
decodeCmapFmtTable: entry
	| cmapFmt length cmap firstCode entryCount segCount segments offset code |
	cmapFmt _ entry nextUShort.
	length _ entry nextUShort.
	entry skip: 2. "skip version"

	cmapFmt = 0 ifTrue: "byte encoded table"
		[length _ length - 6. 		"should be always 256"
		length <= 0 ifTrue: [^ nil].	"but sometimes, this table is empty"
		cmap _ Array new: length.
		entry nextBytes: length into: cmap startingAt: entry offset.
		^ cmap].

	cmapFmt = 4 ifTrue: "segment mapping to deltavalues"
		[segCount _ entry nextUShort // 2.
		entry skip: 6. "skip searchRange, entrySelector, rangeShift"
		segments _ Array new: segCount.
		segments _ (1 to: segCount) collect: [:e | Array new: 4].
		1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount"
		entry skip: 2. "skip reservedPad"
		1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount"
		1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta"
		offset _ entry offset.
		1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset"
		cmap _ Array new: 256 withAll: 0. "could be larger, but Squeak can't handle that"
		segments withIndexDo:
			[:seg :si |
			seg first to: seg second do:
				[:i |
				i < 256 ifTrue:
					[seg last > 0 ifTrue:
						["offset to glypthIdArray - this is really C-magic!!"
						entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. 
						code _ entry nextUShort.
						code > 0 ifTrue: [code _ code + seg third]]
					ifFalse:
						["simple offset"
						code _ i + seg third].
					cmap at: i + 1 put: code]]].
		^ cmap].

	cmapFmt = 6 ifTrue: "trimmed table"
		[firstCode _ entry nextUShort.
		entryCount _ entry nextUShort.
		cmap _ Array new: entryCount + firstCode withAll: 0.
		entryCount timesRepeat:
			[cmap at: (firstCode _ firstCode + 1) put: entry nextUShort].
		^ cmap].
	^ nil! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'!
getGlyphFlagsFrom: entry size: nPts
	"Read in the flags for this glyph.  The outer loop gathers the flags that
	are actually contained in the table.  If the repeat bit is set in a flag
	then the next byte is read from the table; this is the number of times
	to repeat the last flag.  The inner loop does this, incrementing the
	outer loops index each time."
	| flags index repCount flagBits |
	flags _ ByteArray new: nPts.
	index _ 1.
	[index <= nPts] whileTrue:[
		flagBits _ entry nextByte.
		flags at: index put: flagBits.
		(flagBits bitAnd: 8) = 8 ifTrue:[
			repCount _ entry nextByte.
			repCount timesRepeat:[
				index _ index + 1.
				flags at: index put: flagBits]].
		index _ index + 1].
	^flags! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:33'!
getTableDirEntry: tagString from: fontData
	"Find the table named tagString in fontData and return a table directory entry for it."
	| nTables pos currentTag tag |
	nTables _ fontData shortAt: 5 bigEndian: true.
	tag _ ByteArray new: 4.
	1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger].
	tag _ tag longAt: 1 bigEndian: true.
	pos _ 13.
	1 to: nTables do:[:i|
		currentTag _ fontData longAt: pos bigEndian: true.
		currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos].
		pos _ pos+16].
	^nil! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:36'!
readGlyphXCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
	"Read the x coordinates for the given glyph from the font file."
	| startPoint endPoint flagBits xValue contour ttPoint |
	startPoint _ 1.
	1 to: nContours do:[:i|
		contour _ glyph contours at: i.
		"Get the end point"
		endPoint _ (endPts at: i) + 1.
		"Store number of points"
		startPoint to: endPoint do:[:j|
			ttPoint _ contour points at: (j - startPoint + 1).
			flagBits _ flags at: j.
			"If bit zero in the flag is set then this point is an on-curve
			point, if not, then it is an off-curve point."
			(flagBits bitAnd: 1) = 1 
				ifTrue:[ ttPoint type: #OnCurve]
				ifFalse:[ttPoint type: #OffCurve].
			"First we check to see if bit one is set.  This would indicate that
			the corresponding coordinate data in the table is 1 byte long.
			If the bit is not set, then the coordinate data is 2 bytes long."
			(flagBits bitAnd: 2) = 2 ifTrue:[ "one byte"
				xValue _ entry nextByte.
				xValue _ (flagBits bitAnd: 16)=16 ifTrue:[xValue] ifFalse:[xValue negated].
				ttPoint x: xValue.
			] ifFalse:[ "two byte"
				"If bit four is set, then this coordinate is the same as the
				last one, so the relative offset (of zero) is stored.  If bit
				is not set, then read in two bytes and store it as a signed value."
				(flagBits bitAnd: 16) = 16 ifTrue:[ ttPoint x: 0 ]
				ifFalse:[
					xValue _ entry nextShort.
					ttPoint x: xValue]]].
		startPoint _ endPoint + 1]! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/2/1998 01:37'!
readGlyphYCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
	"Read the y coordinates for the given glyph from the font file."
	| startPoint endPoint flagBits yValue contour ttPoint |
	startPoint _ 1.
	1 to: nContours do:[:i|
		contour _ glyph contours at: i.
		"Get the end point"
		endPoint _ (endPts at: i) + 1.
		"Store number of points"
		startPoint to: endPoint do:[:j|
			ttPoint _ contour points at: (j - startPoint + 1).
			flagBits _ flags at: j.
			"Check if this value one or two byte encoded"
			(flagBits bitAnd: 4) = 4 ifTrue:[ "one byte"
				yValue _ entry nextByte.
				yValue _ (flagBits bitAnd: 32)=32 ifTrue:[yValue] ifFalse:[yValue negated].
				ttPoint y: yValue.
			] ifFalse:[ "two byte"
				(flagBits bitAnd: 32) = 32 ifTrue:[ ttPoint y: 0 ]
				ifFalse:[
					yValue _ entry nextShort.
					ttPoint y: yValue]]].
		startPoint _ endPoint + 1]! !

!TTFontReader methodsFor: 'private' stamp: 'ar 11/1/1998 21:01'!
warn: aString
	Transcript cr; show: aString; endEntry.! !

!TTFontReader methodsFor: 'private' stamp: 'sma 3/11/2000 20:33'!
winToMac: index
	^ (index - 1) asCharacter isoToSqueak asciiValue + 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTFontReader class
	instanceVariableNames: ''!


!TTFontReader class methodsFor: 'instance creation' stamp: 'sma 5/5/2000 14:22'!
installTTF: ttfFileName asTextStyle: textStyleName sizes: sizeArray
	"TTFontReader
		installTTF: 'F:\fonts\amazon__.TTF' 
		asTextStyle: #Amazon
		sizes: #(24 60)"

	| ttf fontArray |
	ttf _ self parseFileNamed: ttfFileName.
	fontArray _ sizeArray collect:
		[:each |
		(ttf asStrikeFontScale: each / ttf unitsPerEm)
			name: textStyleName;
			pointSize: each].
	TextConstants at: textStyleName asSymbol put: (TextStyle fontArray: fontArray)! !

!TTFontReader class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:43'!
parseFileNamed: aString
	"TTFontReader parseFileNamed:'c:\windows\arial.ttf'"
	"TTFontReader parseFileNamed:'c:\windows\times.ttf'"
	| contents |
	contents _ (FileStream readOnlyFileNamed: aString) binary contentsOfEntireFile.
	^self readFrom: (ReadStream on: contents)! !

!TTFontReader class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 00:53'!
readFrom: aStream

	^self new readFrom: aStream! !
Object subclass: #TTFontTableDirEntry
	instanceVariableNames: 'tag fontData offset length checkSum '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!

!TTFontTableDirEntry methodsFor: 'initialize-release'!
on: fd at: index

	fontData _ fd.
	tag _ fontData longAt: index bigEndian: true.
	checkSum _ fontData longAt: index+4 bigEndian: true.
	offset _ (fontData longAt: index+8 bigEndian: true) + 1.
	length _ fontData longAt: index+12 bigEndian: true.! !


!TTFontTableDirEntry methodsFor: 'accessing'!
nextByte

	| value |
	value _ fontData byteAt: offset.
	offset _ offset + 1.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextBytes: numBytes into: array startingAt: byteOffset

	1 to: numBytes do:[:i|
		array at: i put: (fontData byteAt: byteOffset + i - 1)].! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextLong

	| value |
	value _ fontData longAt: offset bigEndian: true.
	offset _ offset + 4.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextShort

	| value |
	value _ fontData shortAt: offset bigEndian: true.
	offset _ offset + 2.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextULong

	| value |
	value _ fontData unsignedLongAt: offset bigEndian: true.
	offset _ offset + 4.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
nextUShort

	| value |
	value _ fontData unsignedShortAt: offset bigEndian: true.
	offset _ offset + 2.
	^value! !

!TTFontTableDirEntry methodsFor: 'accessing'!
offset
	^offset! !

!TTFontTableDirEntry methodsFor: 'accessing'!
offset: newOffset
	offset _ newOffset! !

!TTFontTableDirEntry methodsFor: 'accessing'!
skip: n
	"Skip n bytes"
	offset _ offset + n.! !

!TTFontTableDirEntry methodsFor: 'accessing' stamp: 'ar 11/1/1998 23:37'!
stringAt: stringOffset length: byteLength multiByte: aBoolean

	| string index stringLength |
	aBoolean ifFalse:[
		stringLength _ byteLength.
		string _ String new: stringLength.
		index _ stringOffset.
		1 to: stringLength do:[:i|
			string at: i put: (Character value: (fontData byteAt: index + i - 1))].
		^string
	] ifTrue:[
		stringLength _ byteLength // 2.
		string _ String new: stringLength.
		index _ stringOffset.
		1 to: stringLength do:[:i|
			string at: i put: (Character value: (fontData byteAt: index + 1)).
			index _ index + 2].
		^string]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTFontTableDirEntry class
	instanceVariableNames: ''!

!TTFontTableDirEntry class methodsFor: 'instance creation'!
on: fontData at: index

	^self new on: fontData at: index! !
Object subclass: #TTGlyph
	instanceVariableNames: 'bounds contours advanceWidth leftSideBearing rightSideBearing glyphIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Fonts'!
!TTGlyph commentStamp: '<historical>' prior: 0!
This class represents a glyph of a TrueType font.

Instance variables:
	bounds			<Rectangle>	The receiver's bounds
	contours		<Array of: PointArray> The compressed contours in the receiver
	advanceWidth	<Integer>	advance width of the glyph
	leftSideBearing	<Integer>	left side bearing
	rightSideBearing <Integer>	right side bearing
	glyphIndex 		<Integer>	the original index of the glyph (used for kerning)!


!TTGlyph methodsFor: 'initialize-release' stamp: 'ar 11/1/1998 22:25'!
initialize

	bounds _ 0@0 corner: 0@0.
	contours _ #().
	advanceWidth _ 0.
	leftSideBearing _ 0.
	rightSideBearing _ 0.! !


!TTGlyph methodsFor: 'accessing'!
advanceWidth
	^advanceWidth! !

!TTGlyph methodsFor: 'accessing'!
advanceWidth: aNumber
	advanceWidth _ aNumber.! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'!
bounds
	^bounds! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/1/1998 22:25'!
bounds: aRectangle
	bounds _ aRectangle! !

!TTGlyph methodsFor: 'accessing'!
contours
	^contours! !

!TTGlyph methodsFor: 'accessing'!
contours: aCollection
	contours _ aCollection asArray.! !

!TTGlyph methodsFor: 'accessing'!
glyphIndex
	^glyphIndex! !

!TTGlyph methodsFor: 'accessing'!
glyphIndex: anInteger
	glyphIndex _ anInteger! !

!TTGlyph methodsFor: 'accessing' stamp: 'ar 11/2/1998 01:26'!
glyphsAndTransformationsDo: aBlock
	aBlock value: self value: MatrixTransform2x3 identity! !

!TTGlyph methodsFor: 'accessing'!
leftSideBearing
	^leftSideBearing! !

!TTGlyph methodsFor: 'accessing'!
leftSideBearing: aNumber
	leftSideBearing _ aNumber.! !

!TTGlyph methodsFor: 'accessing'!
rightSideBearing
	^rightSideBearing! !

!TTGlyph methodsFor: 'accessing'!
rightSideBearing: aNumber
	rightSideBearing _ aNumber.! !


!TTGlyph methodsFor: 'testing'!
isComposite
	^false! !


!TTGlyph methodsFor: 'printing' stamp: 'tk 9/13/1999 09:54'!
printOn: aStream

	aStream
		nextPutAll: self class name;
		nextPut:$(;
		print: (contours ifNil: [0] ifNotNil: [contours size]);
		nextPut:$).! !


!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:18'!
buildContours
	"Build the contours in the receiver glyph.
	The contour is constructed by converting the points
	form each contour into an absolute value and then
	compressing the contours into PointArrays."
	| tx ty points |
	tx _ ty _ 0.
	contours _ contours collect:[:contour|
		points _ contour points.
		points do:[:pt|
			pt x: (tx _ tx + pt x).
			pt y: (ty _ ty + pt y)].
		contour asCompressedPoints].! !

!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:42'!
initializeContours: numContours with: endPoints
	"Initialize the contours for creation of the glyph."
	| startPt pts endPt |
	contours _ Array new: numContours.
	startPt _ -1.
	1 to: numContours do:[:i|
		endPt _ endPoints at: i.
		pts _ Array new: endPt - startPt.
		1 to: pts size do:[:j| pts at: j put: TTPoint new].
		contours at: i put: (TTContourConstruction on: pts).
		startPt _ endPt].! !

!TTGlyph methodsFor: 'private-initialization' stamp: 'ar 11/1/1998 22:27'!
updateRightSideBearing
	"Update the right side bearing value"
	"@@: Is the following really correct?!!?!!"
	rightSideBearing _ advanceWidth - leftSideBearing - bounds corner x + bounds origin x! !


!TTGlyph methodsFor: 'private' stamp: 'ar 5/25/2000 18:01'!
display
	| canvas |
	canvas _ Display getCanvas.
	self contours do:[:ptArray|
		1 to: ptArray size by: 3 do:[:i|
			canvas line: (ptArray at: i) // 10
					to: (ptArray at: i+2) // 10
					width: 1 color: Color black.
		].
	].! !

!TTGlyph methodsFor: 'private' stamp: 'ar 11/14/1998 20:22'!
flipAroundY
	bounds _ (bounds origin x @ bounds corner y negated) corner:
				(bounds corner x @ bounds origin y negated).
	contours _ self contours collect:[:contour| contour collect:[:pt| pt x @ pt y negated]].! !


!TTGlyph methodsFor: 'converting' stamp: 'sma 5/5/2000 13:48'!
asFormWithScale: scale ascender: ascender descender: descender
	^ self
		asFormWithScale: scale
		ascender: ascender
		descender: descender
		fgColor: Color black
		bgColor: Color white! !

!TTGlyph methodsFor: 'converting' stamp: 'sma 5/5/2000 13:47'!
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor
	| form canvas |
	form _ Form extent: (advanceWidth @ (ascender - descender) * scale) rounded depth: 8.
	form fillColor: bgColor.
	canvas _ BalloonCanvas on: form.
	canvas aaLevel: 4.
	canvas transformBy: (MatrixTransform2x3 withScale: scale asPoint * (1 @ -1)).
	canvas transformBy: (MatrixTransform2x3 withOffset: 0 @ ascender negated).
	canvas
		drawGeneralBezierShape: self contours
		color: fgColor 
		borderWidth: 0 
		borderColor: fgColor.
	form replaceColor: bgColor withColor: Color transparent.
	^ form! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTGlyph class
	instanceVariableNames: ''!

!TTGlyph class methodsFor: 'instance creation'!
new
	^super new initialize! !
Object subclass: #TTKernPair
	instanceVariableNames: 'left right value mask '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Fonts'!

!TTKernPair methodsFor: 'accessing'!
left
	^left! !

!TTKernPair methodsFor: 'accessing'!
left: aNumber

	left _ aNumber! !

!TTKernPair methodsFor: 'accessing' stamp: 'ar 11/1/1998 20:08'!
mask
	^mask ifNil:[mask _ self class maskFor: left with: right]! !

!TTKernPair methodsFor: 'accessing'!
right
	^right! !

!TTKernPair methodsFor: 'accessing'!
right: aNumber

	right _ aNumber! !

!TTKernPair methodsFor: 'accessing'!
value
	^value! !

!TTKernPair methodsFor: 'accessing'!
value: aNumber

	value _ aNumber! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTKernPair class
	instanceVariableNames: ''!

!TTKernPair class methodsFor: 'accessing'!
maskFor: left with: right
	^(left bitShift: 12) + right! !
Object subclass: #TTPoint
	instanceVariableNames: 'x y type '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!

!TTPoint methodsFor: 'accessing'!
type
	^type! !

!TTPoint methodsFor: 'accessing'!
type: aSymbol

	type _ aSymbol! !

!TTPoint methodsFor: 'accessing'!
x
	^x! !

!TTPoint methodsFor: 'accessing'!
x: aNumber

	x _ aNumber! !

!TTPoint methodsFor: 'accessing'!
y
	^y! !

!TTPoint methodsFor: 'accessing'!
y: aNumber
	y _ aNumber! !


!TTPoint methodsFor: 'printing'!
printOn: aStream

	aStream 
		nextPutAll: self class name;
		nextPut:$(;
		print: x;
		nextPut:$@;
		print: y;
		nextPut:$|;
		print: type;
		nextPut:$)! !


!TTPoint methodsFor: 'converting'!
asPoint
	^x@y! !
BorderedMorph subclass: #TTSampleFontMorph
	instanceVariableNames: 'font transform smoothing '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!

!TTSampleFontMorph methodsFor: 'initialize' stamp: 'ar 11/15/1998 01:26'!
initialize
	super initialize.
	borderWidth _ 1.
	borderColor _ Color black.
	color _ Color black.
	smoothing _ 4.
	self extent: 300@300.! !

!TTSampleFontMorph methodsFor: 'initialize' stamp: 'ar 11/14/1998 23:50'!
open
	Smalltalk isMorphic 
		ifTrue:[self openInWorld]
		ifFalse:[self openInMVC]! !

!TTSampleFontMorph methodsFor: 'initialize' stamp: 'sma 4/30/2000 10:51'!
openInWorld
	Smalltalk isMorphic ifFalse: [^ self openInMVC].
	HandMorph attach: self! !


!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sw 1/27/2000 15:43'!
addOptionalHandlesTo: aHalo box: box
	aHalo addHandleAt: box center color: Color magenta icon: nil on: #mouseDown send: #createSample to: self.! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:39'!
balloonHelpTextForHandle: aHandle
	aHandle eventHandler firstMouseSelector == #createSample
		ifTrue:[^'Create a sample string'].
	^super balloonHelpTextForHandle: aHandle! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:52'!
doesBevels
	^false! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'!
font
	^ font! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 00:31'!
font: aTTFontDescription
	| morph |
	font _ aTTFontDescription.
	morph _ (TTSampleStringMorph font: font).
	morph extent: morph extent * 2.
	morph color: Color magenta.
	self addMorphCentered: morph.
	morph position: morph position x @ (self bounds bottom + 10).
	self privateFullMoveBy: self fullBounds origin negated.! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 22:42'!
newTransformationMorph
	^MatrixTransformMorph new! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 17:53'!
smoothing
	^ smoothing! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'bf 10/18/1999 16:19'!
smoothing: aNumber
	smoothing _ aNumber.
	self changed! !

!TTSampleFontMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 22:53'!
transform
	^transform ifNil:[self computeTransform].! !


!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'!
extent: extentPoint
	super extent: extentPoint.
	transform _ nil.! !

!TTSampleFontMorph methodsFor: 'geometry' stamp: 'ar 11/14/1998 22:53'!
position: pos
	super position: pos.
	transform _ nil.! !


!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 11/14/1998 23:12'!
areasRemainingToFill: aRectangle
	^ Array with: aRectangle! !

!TTSampleFontMorph methodsFor: 'drawing' stamp: 'sma 1/1/2000 17:56'!
drawCharactersOn: aCanvas
	| glyph origin r offset cy m |
	0 to: 255 do:[:i|
		glyph _ font at: i.
		origin _ font bounds extent * ((i \\ 16) @ (i // 16)).
		r _ origin extent: font bounds extent.
		offset _ r center - glyph bounds center.
		cy _ glyph bounds center y.
		m _ MatrixTransform2x3 withOffset: 0@cy.
		m _ m composedWithLocal: (MatrixTransform2x3 withScale: 1@-1).
		m _ m composedWithLocal: (MatrixTransform2x3 withOffset: 0@cy negated).
		m _ m composedWithGlobal: (MatrixTransform2x3 withOffset: offset).
		aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
			balloonCanvas transformBy: m.
			balloonCanvas drawGeneralBezierShape: glyph contours
					color: color
					borderWidth: 0
					borderColor: Color black.
		].
	].! !

!TTSampleFontMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:49'!
drawOn: aCanvas
	| origin extent offset |
	(font isNil) 
		ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
	origin _ self position asIntegerPoint.
	extent _ self extent asIntegerPoint.
	0 to: 16 do:[:i|
		offset _ (extent x * i // 16) @ (extent y * i // 16).
		aCanvas line: origin x @ (origin y + offset y) 
				to: (origin x + extent x) @ (origin y + offset y)
				width: borderWidth color: borderColor.
		aCanvas line: (origin x + offset x) @ origin y 
				to: (origin x + offset x) @ (origin y + extent y)
				width: borderWidth color: borderColor.
	].
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		balloonCanvas aaLevel: self smoothing.
		self drawCharactersOn: balloonCanvas.
	].! !


!TTSampleFontMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:21'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel.! !

!TTSampleFontMorph methodsFor: 'menu' stamp: 'ar 11/14/1998 23:46'!
createSample
	self world primaryHand attachMorph: (TTSampleStringMorph font: font)! !

!TTSampleFontMorph methodsFor: 'menu' stamp: 'ar 6/16/1999 07:20'!
getSmoothingLevel
	"Menu support"
	smoothing = 1 ifTrue:[^'turn on smoothing'].
	smoothing = 2 ifTrue:[^'more smoothing'].
	smoothing = 4 ifTrue:[^'turn off smoothing'].
! !

!TTSampleFontMorph methodsFor: 'menu' stamp: 'sma 1/1/2000 17:51'!
nextSmoothingLevel
	smoothing = 1
		ifTrue: [smoothing _ 2]
		ifFalse: [smoothing = 2
			ifTrue: [smoothing _ 4]
			ifFalse: [smoothing = 4
				ifTrue: [smoothing _ 1]]].
	self changed! !


!TTSampleFontMorph methodsFor: 'private' stamp: 'sma 1/1/2000 17:59'!
changed
	self invalidRect: (self fullBounds expandBy: 1)! !

!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/15/1998 22:48'!
computeTransform
	| fullExtent scale |
	fullExtent _ font bounds extent * 16.
	scale _ self extent asFloatPoint / fullExtent asFloatPoint.
	transform _ MatrixTransform2x3 withScale: scale.
	transform _ transform composedWithGlobal: (MatrixTransform2x3 withOffset: self position).
	^transform! !

!TTSampleFontMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:55'!
privateMoveBy: delta
	super privateMoveBy: delta.
	transform _ nil.! !


!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:20'!
veryDeepFixupWith: deepCopier
	"If fields were weakly copied, fix them here. If they were in the 
	tree being copied, fix them up, otherwise point to the originals!!!!"

	super veryDeepFixupWith: deepCopier.
	font _ deepCopier references at: font ifAbsent: [font]! !

!TTSampleFontMorph methodsFor: 'copying' stamp: 'sma 2/26/2000 19:18'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all,
	but shared. Warning!!!! Every instance variable defined in this class
	must be handled.  We must also implement veryDeepFixupWith:.
	See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	"font _ font"
	transform _ transform veryDeepCopyWith: deepCopier.
	smoothing _ smoothing veryDeepCopyWith: deepCopier! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TTSampleFontMorph class
	instanceVariableNames: ''!

!TTSampleFontMorph class methodsFor: 'instance creation' stamp: 'ar 11/14/1998 23:06'!
font: aTTFontDescription
	^self new font: aTTFontDescription! !
TTSampleFontMorph subclass: #TTSampleStringMorph
	instanceVariableNames: 'string ttBounds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon-TrueType Support'!

!TTSampleStringMorph methodsFor: 'initialize' stamp: 'sma 1/1/2000 18:05'!
initialize
	super initialize.
	borderWidth _ 0.
	borderColor _ Color black.
	color _ {Color magenta. Color yellow. Color orange. Color lightGray} atRandom.
	smoothing _ 4! !

!TTSampleStringMorph methodsFor: 'initialize' stamp: 'sma 1/1/2000 18:08'!
initializeString
	| xStart char glyph |
	(font isNil or: [string isNil]) ifTrue: [^ self].
	xStart _ 0.
	ttBounds _ 0@0 corner: 0@0.
	1 to: string size do:
		[:i |
		char _ string at: i.
		glyph _ font at: char.
		ttBounds _ ttBounds quickMerge: (glyph bounds translateBy: xStart@0).
		xStart _ xStart + glyph advanceWidth.
	].
	self extent: ttBounds extent // 40.
	borderWidth _ ttBounds height // 40! !


!TTSampleStringMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:44'!
addOptionalHandlesTo: aHalo box: box! !

!TTSampleStringMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 00:10'!
font: aTTFontDescription
	font _ aTTFontDescription.
	self string: aTTFontDescription fullName.! !

!TTSampleStringMorph methodsFor: 'accessing' stamp: 'sma 1/1/2000 18:08'!
string
	^ string! !

!TTSampleStringMorph methodsFor: 'accessing' stamp: 'ar 11/14/1998 23:53'!
string: aString
	string _ aString.
	self initializeString.! !


!TTSampleStringMorph methodsFor: 'drawing' stamp: 'ar 12/30/1998 10:51'!
drawOn: aCanvas
	| xStart glyph |
	(font isNil or:[string isNil or:[string isEmpty]]) 
		ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
	xStart _ 0.
	aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
		balloonCanvas transformBy: self transform.
		balloonCanvas aaLevel: self smoothing.
		string do:[:char|
			glyph _ font at: char.
			balloonCanvas preserveStateDuring:[:subCanvas|
				subCanvas transformBy: (MatrixTransform2x3 withOffset: xStart@0).
				subCanvas 
					drawGeneralBezierShape: glyph contours
					color: color 
					borderWidth: borderWidth 
					borderColor: borderColor].
			xStart _ xStart + glyph advanceWidth.
		].
	].! !


!TTSampleStringMorph methodsFor: 'private' stamp: 'ar 11/14/1998 22:04'!
computeTransform
	| cy |
	cy _ bounds origin y + bounds corner y * 0.5.
	transform _ MatrixTransform2x3 
			transformFromLocal: (ttBounds insetBy: borderWidth negated)
			toGlobal: bounds.
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy negated).
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withScale: 1.0@-1.0).
	transform _ transform composedWithGlobal:(MatrixTransform2x3 withOffset: 0@cy).
	^transform! !


!TTSampleStringMorph methodsFor: 'geometry' stamp: 'sma 1/1/2000 18:10'!
containsPoint: aPoint
	"^ super containsPoint: aPoint"  "so much faster..."
	| picker |
	(self bounds containsPoint: aPoint) ifFalse:[^false].
	picker _ BalloonCanvas on: (Form extent: 1@1 depth: 32).
	picker transformBy: (MatrixTransform2x3 withOffset: aPoint negated).
	self drawOn: picker.
	^(picker form bits at: 1) ~= 0
! !
TParseNode subclass: #TVariableNode
	instanceVariableNames: 'name '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TVariableNode methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 16:56'!
bindVariableUsesIn: aDictionary

	^ (aDictionary at: name ifAbsent: [^ self]) copyTree! !

!TVariableNode methodsFor: 'as yet unclassified' stamp: 'sma 5/24/2000 23:42'!
bindVariablesIn: aDictionary 
	^ (aDictionary at: name ifAbsent: [^ self]) copyTree! !

!TVariableNode methodsFor: 'as yet unclassified'!
copyTree

	^self class new setName: name! !

!TVariableNode methodsFor: 'as yet unclassified'!
emitCCodeOn: aStream level: level generator: aCodeGen

	name = 'nil'
		ifTrue: [ aStream nextPutAll: (aCodeGen cLiteralFor: nil) ]
		ifFalse: [ aStream nextPutAll: name ].! !

!TVariableNode methodsFor: 'as yet unclassified'!
isLeaf

	^true! !

!TVariableNode methodsFor: 'as yet unclassified'!
isVariable

	^true! !

!TVariableNode methodsFor: 'as yet unclassified'!
name

	^name! !

!TVariableNode methodsFor: 'as yet unclassified' stamp: 'acg 12/17/1999 07:18'!
nameOrValue

	^name! !

!TVariableNode methodsFor: 'as yet unclassified'!
printOn: aStream level: level

	aStream nextPutAll: name.! !

!TVariableNode methodsFor: 'as yet unclassified'!
setName: aString

	name _ aString.! !
StringButtonMorph subclass: #TabMorph
	instanceVariableNames: 'morphToInstall '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!TabMorph commentStamp: '<historical>' prior: 0!
A tab in a palette.  The contents is the name to be shown.  If it represents a book, that book is pointed to in my morphToInstall.!


!TabMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 10:39'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
morphToInstall _ deepCopier references at: morphToInstall ifAbsent: [morphToInstall].! !

!TabMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 10:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
morphToInstall _ morphToInstall.		"Weakly copied"! !


!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/2/1999 15:55'!
convertToReferenceMorph
	| aMorph |
	aMorph _ ReferenceMorph new referent: morphToInstall.
	aMorph position: self position.
	self become: aMorph.! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/9/1999 20:49'!
isHighlighted
	^ false! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 15:28'!
morphToInstall
	^ morphToInstall! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 15:38'!
morphToInstall: m
	morphToInstall _ m.
	self contents: m externalName.
	self actionSelector: #tabSelected.
	self target: self! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/3/1998 11:42'!
representsBook
	^ morphToInstall ~~ nil! !

!TabMorph methodsFor: 'as yet unclassified' stamp: 'sw 8/11/1998 16:59'!
tabSelected
	"Called when the receiver is hit.  First, bulletproof against someone having taken the structure apart.  My own action basically requires that my grand-owner be a TabbedPalette"
	self player ifNotNil: [self player runAllOpeningScripts ifTrue: [^ self]].
	(owner isKindOf: IndexTabs) ifFalse: [^ self beep].
	(owner owner isKindOf: TabbedPalette) ifFalse: [^ self beep].
	owner owner selectTab: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TabMorph class
	instanceVariableNames: ''!

!TabMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/2/1998 16:48'!
defaultNameStemForInstances
	^ 'tab'! !

!TabMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/3/1998 11:49'!
forBook: aBook
	^ self new morphToInstall: aBook! !
BookPageSorterMorph subclass: #TabSorterMorph
	instanceVariableNames: 'originalTabs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!TabSorterMorph commentStamp: '<historical>' prior: 0!
A sorter for the tabs of a TabbedPalette!


!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/9/1999 23:15'!
acceptSort
	"Reconstitute the palette based on what is found in the sorter"
	| rejects toAdd oldOwner tabsToUse appearanceMorph oldTop aMenu |
	tabsToUse _ OrderedCollection new.
	rejects _ OrderedCollection new.

	pageHolder submorphs doWithIndex: [:m :i |
		toAdd _ nil.
		(m isKindOf: BookMorph) ifTrue:
			[toAdd _ SorterTokenMorph forMorph: m].
		(m isKindOf: SorterTokenMorph) ifTrue:
			[toAdd _ m morphRepresented.
			(toAdd referent isKindOf: MenuMorph) ifTrue:
				[(aMenu _ toAdd referent) setProperty: #paletteMenu toValue: true.
				((aMenu submorphs size > 1) and: [(aMenu submorphs second isKindOf: MenuItemMorph) and: [aMenu submorphs second contents = 'dismiss this menu']])
					ifTrue:
						[aMenu submorphs first delete.   "delete title"
						aMenu submorphs first delete.   "delete stay-up item"
						(aMenu submorphs first isKindOf: MenuLineMorph) ifTrue:
							[aMenu submorphs first delete]]].
			toAdd removeAllMorphs.
			toAdd addMorph: (appearanceMorph _ m submorphs first).
			appearanceMorph position: toAdd position.
			appearanceMorph lock.
			toAdd fitContents].
		toAdd ifNil:
				[rejects add: m]
			ifNotNil:
				[tabsToUse add: toAdd]].
	tabsToUse size == 0 ifTrue: [^ self inform: 'Sorry, must have at least one tab'].
	book newTabs: tabsToUse.
	book tabsMorph color: pageHolder color.
	oldTop _ self topRendererOrSelf.  "in case some maniac has flexed the sorter"
	oldOwner _ oldTop owner.
	oldTop delete.
	oldOwner addMorphFront: book! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 21:24'!
addControls

	| b r |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r wrapCentering: #topLeft.
	r addMorphBack: (b fullCopy label: 'Okay';	actionSelector: #acceptSort).
	r addMorphBack: (b fullCopy label: 'Cancel';	actionSelector: #cancelSort).
	self addMorphFront: r.
! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/3/1998 16:06'!
cancelSort
	| oldOwner |
	oldOwner _ owner.
	self delete.
	oldOwner addMorphFront: book! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/8/2000 22:38'!
initialize
	super initialize.
	self removeAllMorphs.

	self extent: 300@100.
	pageHolder _ PasteUpMorph new.
	pageHolder resizeToFit: true; autoLineLayout: true.
	pageHolder extent: self extent - borderWidth.
	pageHolder padding: 8.
	pageHolder cursor: 0.
	self addControls.
	self addMorphBack: pageHolder! !

!TabSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/2/1999 16:47'!
sortTabsFor: aTabbedPalette
	| actualTabs |
	actualTabs _ aTabbedPalette tabMorphs.
	self book: aTabbedPalette morphsToSort:
		(actualTabs collect: [:aTab | aTab sorterToken]).
	pageHolder color: aTabbedPalette tabsMorph color.
 
	self position: aTabbedPalette position.
	pageHolder extent: self extent.
	self setNameTo: 'Tab Sorter for ', aTabbedPalette externalName.
	aTabbedPalette owner addMorphFront: self! !
BookMorph subclass: #TabbedPalette
	instanceVariableNames: 'tabsMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!
!TabbedPalette commentStamp: '<historical>' prior: 0!
A structure of tabs and associated books.  Pressing a tab brings into focus the associated book.  Some tabs can have simple actions rather than books as their focus -- in this case, the palette is cleared and the action taken. !


!TabbedPalette methodsFor: 'initialization' stamp: 'sw 1/11/2000 11:16'!
addTabFor: aReferent font: aFont
	| aTab |
	aTab _ tabsMorph addTabFor: aReferent font: aFont.
	pages add: aReferent.
	currentPage ifNil: [currentPage _ aReferent].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 7/2/1998 17:52'!
addTabForBook: aBook
	| aTab |
	aTab _ tabsMorph addTabForBook: aBook.
	pages add: aBook.
	currentPage ifNil: [currentPage _ aBook].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 10/29/1998 17:35'!
addTabForBook: aBook withBalloonText: text
	| aTab |
	aTab _ tabsMorph addTabForBook: aBook.
	pages add: aBook.
	currentPage ifNil: [currentPage _ aBook].
	text ifNotNil: [aTab setBalloonText: text].
	^ aTab! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 7/3/1998 18:05'!
defaultPageSize
	^ 156 @ 232! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 12/2/1998 17:18'!
initialize
	super initialize.

	pageSize _ self defaultPageSize.
	self removeEverything.
	color _ Color transparent.
	borderWidth _ 0.
	tabsMorph _ IndexTabs new.
	self addMorph: tabsMorph! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 12/7/1998 17:26'!
newTabs: tabsList
	"Reconstitute the palette based on info in the tabs list"

	| itsBook color1 color2 color3 |
	pages _ pages species new.
	tabsMorph ifNotNil:
		[color1 _ tabsMorph  highlightColor.
		color2 _ tabsMorph regularColor.
		color3 _ tabsMorph color.
		tabsMorph delete].
	tabsMorph _ IndexTabs new.
	self addMorphFront: tabsMorph.
	color1 ifNotNil:
		[tabsMorph highlightColor: color1 regularColor: color2; color: color3].
	currentPage ifNotNil:
		[currentPage delete.
		currentPage _ nil].
	tabsList do:
		[:aTab |
			tabsMorph addTab: aTab.
			aTab unHighlight.
			(itsBook _ aTab morphToInstall) ifNotNil:
					[pages add: itsBook.
					currentPage ifNil: [currentPage _ itsBook]]].
	tabsMorph position: self position + self borderWidth! !

!TabbedPalette methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:44'!
setInitialState
	super setInitialState.
	self layoutInset: 0.
	pageSize _ 156 @ 232! !

!TabbedPalette methodsFor: 'initialization' stamp: 'sw 3/2/1999 15:55'!
undergoMarch99Conversion
	"A one-time conversion to be applied to old instances of TabbedPalette that still have TabMorphs in them instead of the newer ReferenceMorphs.  Return an integer telling how many tabs were changed"

	"TabbedPalette allInstancesDo: [:m | m undergoMarch99Conversion]"

	| count |
	tabsMorph ifNil: [^ 0].
	count _ 0.
	tabsMorph submorphs do:
		[:m | (m isKindOf: TabMorph)
			ifTrue:
				[m convertToReferenceMorph.
				count _ count + 1]].
	^ count! !


!TabbedPalette methodsFor: 'parts & controls tabs' stamp: 'sw 1/27/2000 13:29'!
addControlsTab
	| controlPage |
	controlPage _ AlignmentMorph newColumn beSticky color: Color white.

	controlPage addMorphBack:
		(Preferences buttonRepresenting: #balloonHelpEnabled wording: 'Balloon Help' color: nil).

	controlPage addMorphBack:
		(Preferences buttonRepresenting: #fenceEnabled wording: 'Fence Enabled' color: nil).

	controlPage addMorphBack:
		(Preferences buttonRepresenting: #soundsEnabled wording: 'Sound Enabled' color: nil).

	controlPage setNameTo: 'controls'.
	self addTabForBook: controlPage  withBalloonText:
'controls to turn sound,
balloon help, etc., on and off'! !

!TabbedPalette methodsFor: 'parts & controls tabs' stamp: 'ar 11/8/2000 22:38'!
addPartsTab
	| partsBook aPage |
	partsBook _ BookMorph new pageSize: pageSize; setNameTo: 'supplies'.
	partsBook removeEverything.
	aPage _ self presenter newPageForStandardPartsBin.
	aPage extent: pageSize.
	#(PaintInvokingMorph RectangleMorph EllipseMorph StarMorph  CurveMorph PolygonMorph TextMorph ImageMorph
		PasteUpMorph JoystickMorph SimpleSliderMorph) do:
		[:sym | aPage addMorphBack: (Smalltalk at: sym) authoringPrototype].
	aPage addMorphBack: RectangleMorph roundRectPrototype.
	aPage addMorphBack: ScriptingSystem prototypicalHolder.
	aPage replaceTallSubmorphsByThumbnails.
	aPage setPartsBinStatusTo: true.
	partsBook insertPage: aPage pageSize: pageSize.
	self addTabForBook: partsBook withBalloonText: 'parts bin'! !

!TabbedPalette methodsFor: 'parts & controls tabs' stamp: 'sw 4/7/1999 11:59'!
addTilesTab
	| aPage |
	aPage _ self presenter tilesPagesForPartsBin first.
	aPage extent: pageSize.
	aPage setNameTo: 'tiles'.
	self addTabForBook: aPage withBalloonText: 'useful tiles for scripting'
! !


!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 6/24/1998 18:36'!
hasScrapsTab
	pages detect: [:p | (p hasProperty: #scraps)] ifNone: [^ false].
	^ true! !

!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 6/24/1998 18:42'!
scrapsBook
	^ pages detect: [:p | p hasProperty: #scraps] ifNone: [nil]! !

!TabbedPalette methodsFor: 'scraps tab' stamp: 'sw 3/8/1999 14:56'!
showScrapsTab
	self selectTabOfBook: self scrapsBook! !


!TabbedPalette methodsFor: 'viewer tab' stamp: 'sw 3/3/1999 13:17'!
viewMorph: aMorph
	"The receiver is expected to have a viewer tab; select it, and target it to aMorph"
	| aPlayer aViewer oldOwner |
	((currentPage isKindOf: Viewer) and: [currentPage scriptedPlayer == aMorph player])
		ifTrue:
			[^ self].
	oldOwner _ owner.
	self delete.
	self visible: false.
	aPlayer _ aMorph assuredPlayer.
	self showNoPalette.
	aViewer _  StandardViewer new initializeFor: aPlayer barHeight: 0.
	aViewer enforceTileColorPolicy.
	self showNoPalette.
	currentPage ifNotNil: [currentPage delete].
	self addMorphBack: (currentPage _ aViewer beSticky).
	self snapToEdgeIfAppropriate.
	tabsMorph highlightTab: nil.
	self visible: true.
	oldOwner addMorphFront: self.
	self world startSteppingSubmorphsOf: aViewer.
	self layoutChanged! !


!TabbedPalette methodsFor: 'palette menu' stamp: 'sw 12/27/1998 23:33'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
	aCustomMenu add: 'add palette menu' action: #addMenuTab.
	aCustomMenu add: 'become the Standard palette' action: #becomeStandardPalette! !

!TabbedPalette methodsFor: 'palette menu' stamp: 'di 2/17/2000 20:33'!
addMenuTab
	| aMenu aTab aGraphic sk |
	aMenu _ MenuMorph new defaultTarget: self.
	aMenu stayUp: true.
	aMenu add:  'clear' action: #showNoPalette.
	aMenu add:  'sort tabs' action: #sortTabs:.
	aMenu add:  'choose new colors for tabs' action: #recolorTabs.
	aMenu setProperty: #paletteMenu toValue: true.
	aMenu add:  'make me the Standard palette' action: #becomeStandardPalette.
	aTab _ self addTabForBook: aMenu  withBalloonText: 'a menu of palette-related controls'.
	aTab highlightColor: tabsMorph highlightColor; regularColor: tabsMorph regularColor.
	tabsMorph laySubpartsOutInOneRow; layoutChanged.

	aGraphic _ ScriptingSystem formAtKey: 'Menu'.
	aGraphic ifNotNil:
		[aTab removeAllMorphs.
		aTab addMorph: (sk _ SketchMorph withForm: aGraphic).
		sk position: aTab position.
		sk lock.
		aTab fitContents].
	self layoutChanged! !


!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 6/16/1998 16:17'!
becomeStandardPalette
	self presenter standardPalette: self! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 7/4/1998 14:12'!
recolorTabs
	"Prompt the user for new on and off colors for tabs"

	| onColor offColor |
	self inform: 'Choose the ''on'' color'.
	onColor _ Color fromUser.

	self inform: 
'Okay, now please choose
the ''off'' color'.
	offColor _ Color fromUser.

	tabsMorph highlightColor: onColor regularColor: offColor.
	currentPage ifNotNil:
		[tabsMorph highlightTabFor: currentPage]! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 12/27/1998 23:34'!
showNoPalette
	self showNoPaletteAndHighlightTab: nil! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 3/3/1999 13:06'!
showNoPaletteAndHighlightTab: aTab

	| oldTab morphToInstall aSketchEditor |
	oldTab _ tabsMorph highlightedTab.
	(oldTab notNil and: [(morphToInstall _ oldTab morphToInstall) isKindOf: PaintBoxMorph])
		ifTrue:
			[(aSketchEditor _ self world submorphOfClass: SketchEditorMorph) ifNotNil:
				[aSketchEditor cancelOutOfPainting].
			morphToInstall delete].

	currentPage ifNotNil: [currentPage delete].
	currentPage _ nil.
	submorphs size > 1 ifTrue: "spurious submorphs, yecch"
		[(submorphs copyFrom: 2 to: submorphs size) do: [:m | m delete]].
	tabsMorph highlightTab: aTab! !

!TabbedPalette methodsFor: 'misc menu items' stamp: 'sw 7/3/1998 18:17'!
sortTabs: evt
	TabSorterMorph new sortTabsFor: self.  "it directly replaces me"
	self delete
! !


!TabbedPalette methodsFor: 'user-interface' stamp: 'ar 9/14/2000 16:45'!
defersHaloOnClickTo: aSubMorph
	"If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true"

	^ currentPage notNil and:
		[(aSubMorph hasOwner: currentPage)
			and: [currentPage defersHaloOnClickTo: aSubMorph]]
	! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 12/27/1998 23:28'!
selectTab: aTab
	| currentPalette morphToInstall oldTab aSketchEditor |
	currentPage ifNotNil:
		[self currentPalette currentPlayerDo:
			[:aPlayer | aPlayer runAllClosingScripts]].
	oldTab _ tabsMorph highlightedTab.
	(oldTab notNil and: [(morphToInstall _ oldTab morphToInstall) isKindOf: PaintBoxMorph])
		ifTrue:
			[(aSketchEditor _ self world submorphOfClass: SketchEditorMorph) ifNotNil:
				[aSketchEditor cancelOutOfPainting].
			morphToInstall delete].

	tabsMorph selectTab: aTab.
	morphToInstall _ aTab morphToInstall.

	(morphToInstall isKindOf: PaintBoxMorph) "special case, maybe generalize this need?"
		ifFalse:
			[self goToPageMorph: morphToInstall]
		ifTrue:
			[self showNoPaletteAndHighlightTab: aTab.
			self world addMorphFront: morphToInstall.
			morphToInstall position: ((self left max: 90) "room for the pop-out-to-left panel"
				@ (tabsMorph bottom))].
	
	(currentPalette _ self currentPalette) ifNotNil:
		[currentPalette layoutChanged.
		currentPalette currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]].
	self snapToEdgeIfAppropriate! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 1/19/2001 12:47'!
selectTabNamed: aName
	"If the receiver has a tab with the given name, select it"

	| aTab |
	aTab _ self tabNamed: aName.
	aTab ifNotNil: [self selectTab: aTab]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 7/5/1998 15:40'!
selectTabOfBook: aBook
	self tabMorphs do:
		[:aTab | aTab morphToInstall == aBook ifTrue: [^ self selectTab: aTab]]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 7/5/1998 15:38'!
tabMorphs
	^ tabsMorph tabMorphs! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 1/19/2001 03:23'!
tabNamed: aName
	"Answer the tab of the given name, or nil if none"

	^ self tabMorphs detect: [:m | ((m isKindOf: StringMorph) and: [m contents = aName])
		or: [(m isKindOf: ReferenceMorph) and: [(m firstSubmorph isKindOf: StringMorph) and:
				[m firstSubmorph contents = aName]]]] ifNone: [nil]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 12/22/1998 16:37'!
transitionSpecFor: aMorph
	^ aMorph valueOfProperty: #transitionSpec  " check for special propety"
		ifAbsent: [Array with: 'silence'  " ... otherwise this is the default"
						with: #none
						with: #none]! !

!TabbedPalette methodsFor: 'user-interface' stamp: 'sw 3/2/1999 13:04'!
wantsDroppedMorph: aMorph event: evt
	(tabsMorph bounds containsPoint: (self pointFromWorld: evt cursorPoint)) ifTrue:
		[^ false  "unless it's a book, perhaps, someday"].
	^ currentPage == nil or: [currentPage wantsDroppedMorph: aMorph event: evt]! !


!TabbedPalette methodsFor: 'miscellaneous' stamp: 'sw 6/23/1998 12:31'!
currentPalette
	"A stylistic convenience to reduce confusion caused by the fact that a palette is a book of books"
	^ currentPage! !

!TabbedPalette methodsFor: 'miscellaneous' stamp: 'sw 4/7/1999 12:16'!
replaceSubmorph: oldMorph by: newMorph
	super replaceSubmorph: oldMorph by: newMorph.
	oldMorph == currentPage ifTrue:
		[currentPage _ newMorph]! !

!TabbedPalette methodsFor: 'miscellaneous' stamp: 'sw 7/5/1998 15:40'!
succeededInRevealing: aPlayer
	| result |
	result _ super succeededInRevealing: aPlayer.
	result ifTrue:
		["BookMorph code will have called goToPageNumber:; here, we just need to get the tab selection right here"
		self selectTabOfBook: self currentPalette].
	^ result! !

!TabbedPalette methodsFor: 'miscellaneous' stamp: 'jm 11/16/97 17:59'!
tabsMorph
	^ tabsMorph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TabbedPalette class
	instanceVariableNames: ''!

!TabbedPalette class methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:33'!
authoringPrototype
	| aTabbedPalette aBook aTab |
	aTabbedPalette _ self new markAsPartsDonor.
	aTabbedPalette pageSize: 200 @ 300.
	aTabbedPalette tabsMorph highlightColor: Color red regularColor: Color blue.
	aTabbedPalette addMenuTab.

	aBook _ BookMorph new setNameTo: 'one'; pageSize: aTabbedPalette pageSize.
	aBook color: Color blue muchLighter.
	aBook removeEverything; insertPage; showPageControls.
	aBook currentPage addMorphBack: (SketchMorph withForm: ScriptingSystem squeakyMouseForm).
	aTab _ aTabbedPalette addTabForBook: aBook.

	aBook _ BookMorph new setNameTo: 'two'; pageSize: aTabbedPalette pageSize.
	aBook color: Color red muchLighter.
	aBook removeEverything; insertPage; showPageControls.
	aBook currentPage addMorphBack: CurveMorph authoringPrototype.
	aTabbedPalette addTabForBook: aBook.

	aTabbedPalette selectTab: aTab.

	aTabbedPalette beSticky.
	^ aTabbedPalette! !

!TabbedPalette class methodsFor: 'as yet unclassified' stamp: 'sw 6/3/1998 21:27'!
defaultNameStemForInstances
	^ 'tabbedPalette'! !
LayoutPolicy subclass: #TableLayout
	instanceVariableNames: 'properties minExtentCache '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!
!TableLayout commentStamp: '<historical>' prior: 0!
The layout process:
For computing the new layout for the children of any morph, we start with an initial rectangle which is provided as a reference.

Step 1: The first step of layout computation is to compute the minimum extent each of our children can have. The minimum extent is mapped through both the local layout frame of the morph (for relative positioning) and the global layout frame (for insets, such as cursor indication) to obtain the minimal size required for each cell.

Step 2: Based on the cell sizes, the number of cells we can put into each row and column is computed. For equal spacing, the maximum size of the cells is taken into account here.

Step 3: Based on the row/column sizes, we compute the extra space which should be added to each row/column. For 
	#leftFlush/#topFlush - we add all extra space add the end
	#rightFlush/#bottomFlush - we add all extra space at the start
	#centering - we add 1/2 of the extra space at start and end
	#justified - we distribute the space evenly between the morphs
[NOTE: If any #spaceFill morphs are encountered during this step, #justified is implied and the space is exclusively and equally distributed between those #spaceFill morphs. This is for backward compatibility and should *never* be necessary in the new regime].

Step 4: The morphs are placed in the computed cells and the extra space is distributed as necessary. Placing the submorphs is done by mapping through the global and the local layout frame as requested.

Start point:
=> bounds: new rectangle for the morph.

Compute basic arrangement of morphs:
=> For each submorph compute minExtent
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
=> Compute number of morphs per, width and height of row/column
	- if equal spacing based on max size
=> Compute extra space per row/column
	- if centering = #justified; distribute space equally
	- if centering #leftFlush/#topFlush (-1) add start extra
	- if centering #rightFlush/#bottomFlush (1) add end extra
	- if centering #centered add 1/2 extra to start/end
	<extra space must be float and rounded accordingly!!>
=> Place morphs in appropriate cells
	- if global layout frame inset in global layout frame
	- if local layout frame inset in local layout frame
	<will likely cause #layoutChanged by submorphs>

Distribute morphs in row/column:

=> Compute the max length of each row/column
!


!TableLayout methodsFor: 'testing' stamp: 'ar 10/29/2000 01:29'!
isTableLayout
	^true! !


!TableLayout methodsFor: 'layout' stamp: 'ar 11/13/2000 18:24'!
computeCellArrangement: cellHolder in: newBounds horizontal: aBool target: aMorph
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
	| cells wrap spacing output maxExtent n sum index max cell first last w cellMax maxCell hFill vFill inset |
	maxCell _ cellHolder key.
	cells _ cellHolder value.
	properties wrapDirection == #none 
		ifTrue:[wrap _ SmallInteger maxVal]
		ifFalse:[wrap _ aBool ifTrue:[newBounds width] ifFalse:[newBounds height].
				wrap < maxCell x ifTrue:[wrap _ maxCell x]].
	spacing _ properties cellSpacing.
	(spacing == #globalRect or:[spacing = #globalSquare]) ifTrue:[
		"Globally equal spacing is a very special case here, so get out fast and easy"
		^self computeGlobalCellArrangement: cells 
			in: newBounds horizontal: aBool 
			wrap: wrap spacing: spacing].

	output _ (WriteStream on: Array new).
	inset _ properties cellInset asPoint.
	aBool ifFalse:[inset _ inset transposed].
	first _ last _ nil.
	maxExtent _ 0@0.
	sum _ 0.
	index _ 1.
	n _ 0.
	hFill _ vFill _ false.
	[index <= cells size] whileTrue:[
		w _ sum.
		cell _ cells at: index.
		cellMax _ maxExtent max: cell cellSize. "e.g., minSize"
		(spacing == #localRect or:[spacing == #localSquare]) ifTrue:[
			"Recompute entire size of current row"
			spacing == #localSquare 
				ifTrue:[max _ cellMax x max: cellMax y]
				ifFalse:[max _ cellMax x].
			sum _ (n + 1) * max.
		] ifFalse:[
			sum _ sum + (cell cellSize x).
		].
		((sum + (n * inset x)) > wrap and:[first notNil]) ifTrue:[
			"It doesn't fit and we're not starting a new line"
			(spacing == #localSquare or:[spacing == #localRect]) ifTrue:[
				spacing == #localSquare 
					ifTrue:[maxExtent _ (maxExtent x max: maxExtent y) asPoint].
				first do:[:c| c cellSize: maxExtent]].
			w _ w + ((n - 1) * inset x).
			"redistribute extra space"
			first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]].
			last _ LayoutCell new.
			last cellSize: w @ (maxExtent y).
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			last nextCell: first.
			output position = 0 ifFalse:[last addExtraSpace: 0@inset y].
			output nextPut: last.
			first _ nil.
			maxExtent _ 0@0.
			sum _ 0.
			n _ 0.
			hFill _ vFill _ false.
		] ifFalse:[
			"It did fit; use next item from input"
			first ifNil:[first _ last _ cell] ifNotNil:[last nextCell: cell. last _ cell].
			index _ index+1.
			n _ n + 1.
			maxExtent _ cellMax.
			hFill _ hFill or:[cell hSpaceFill].
			vFill _ vFill or:[cell vSpaceFill].
		].
	].
	first ifNotNil:[
		last _ LayoutCell new.
		sum _ sum + ((n - 1) * inset x).
		first nextCell ifNotNil:[first nextCell do:[:c| c addExtraSpace: inset x@0]].
		last cellSize: sum @ maxExtent y.
		last hSpaceFill: hFill.
		last vSpaceFill: vFill.
		last nextCell: first.
		output position = 0 ifFalse:[last addExtraSpace: 0@inset y].
		output nextPut: last].
	output _ output contents.
	properties listSpacing == #equal ifTrue:[
		"Make all the heights equal"
		max _ output inject: 0 into:[:size :c| size max: c cellSize y].
		output do:[:c| c cellSize: c cellSize x @ max].
	].
	^output! !

!TableLayout methodsFor: 'layout' stamp: 'ar 12/18/2000 13:45'!
computeCellSizes: aMorph in: newBounds horizontal: aBool
	"Step 1: Compute the minimum extent for all the children of aMorph"
	| cells cell size block maxCell minSize maxSize |
	cells _ WriteStream on: (Array new: aMorph submorphCount).
	minSize _ properties minCellSize asPoint.
	maxSize _ properties maxCellSize asPoint.
	aBool ifTrue:[
		minSize _ minSize transposed.
		maxSize _ maxSize transposed].
	maxCell _ 0@0.
	block _ [:m|
		m disableTableLayout ifFalse:[
			size _ m minExtent asIntegerPoint.
			cell _ LayoutCell new target: m.
			aBool ifTrue:[
				cell hSpaceFill: m hResizing == #spaceFill.
				cell vSpaceFill: m vResizing == #spaceFill.
			] ifFalse:[
				cell hSpaceFill: m vResizing == #spaceFill.
				cell vSpaceFill: m hResizing == #spaceFill.
				size _ size transposed.
			].
			size _ (size min: maxSize) max: minSize.
			cell cellSize: size.
			maxCell _ maxCell max: size.
			cells nextPut: cell]].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].
	^maxCell -> cells contents! !

!TableLayout methodsFor: 'layout' stamp: 'ar 11/13/2000 18:24'!
computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph
	"Compute the required extra spacing for laying out the cells"
	| extent extra centering n extraPerCell cell last hFill vFill max amount allow |
	"match newBounds extent with arrangement's orientation"
	extent _ newBounds extent.
	aBool ifFalse:[extent _ extent transposed].

	"figure out if we have any horizontal or vertical space fillers"
	hFill _ vFill _ false.
	max _ 0@0.
	arrangement do:[:c|
		max _ (max x max: c cellSize x) @ (max y + c cellSize y).
		max _ max max: c cellSize.
		hFill _ hFill or:[c hSpaceFill].
		vFill _ vFill or:[c vSpaceFill]].

	"Take client's shrink wrap constraints into account.
	Note: these are only honored when there are no #spaceFill children,
	or when #rubberBandCells is set."
	allow _ properties rubberBandCells not.
	aMorph hResizing == #shrinkWrap ifTrue:[
		aBool 
			ifTrue:[allow & hFill ifFalse:[extent _ max x @ (max y max: extent y)]]
			ifFalse:[allow & vFill ifFalse:[extent _ (max x max: extent x) @ max y]]].
	aMorph vResizing == #shrinkWrap ifTrue:[
		aBool 
			ifFalse:[allow & hFill ifFalse:[extent _ max x @ (max y max: extent y)]]
			ifTrue:[allow & vFill ifFalse:[extent _ (max x max: extent x) @ max y]]].

	"Now compute the extra v space"
	extra _ extent y - (arrangement inject: 0 into:[:sum :c| sum + c cellSize y]).
	extra > 0 ifTrue:[
		"Check if we have any #spaceFillers"
		vFill ifTrue:[ "use only #spaceFillers"
			n _ arrangement inject: 0 into:[:sum :c| 
				c vSpaceFill ifTrue:[sum + 1] ifFalse:[sum]].
			n isZero ifFalse:[extraPerCell _ extra asFloat / n asFloat].
			extra _ last _ 0.
			arrangement do:[:c|
				c vSpaceFill ifTrue:[
					extra _ (last _ extra) + extraPerCell.
					amount _ 0 @ (extra truncated - last truncated).
					c do:[:cc| cc cellSize: cc cellSize + amount]]].
		] ifFalse:[ "no #spaceFillers; distribute regularly"
			centering _ properties wrapCentering.
			"centering == #topLeft ifTrue:[]." "add all extra space to the last cell; e.g., do nothing"
			centering == #bottomRight "add all extra space to the first cell"
				ifTrue:[arrangement first addExtraSpace: 0@extra].
			centering == #center "add 1/2 extra space to the first and last cell"
				ifTrue:[arrangement first addExtraSpace: 0@ (extra // 2)].
			centering == #justified "add extra space equally distributed to each cell"
				ifTrue:[	n _ (arrangement size - 1) max: 1.
						extraPerCell _ extra asFloat / n asFloat.
						extra _ last _ 0.
						arrangement do:[:c|
							c addExtraSpace: 0@(extra truncated - last truncated).
							extra _ (last _ extra) + extraPerCell]].
		].
	].

	"Now compute the extra space for the primary direction"
	centering _ properties listCentering.
	1 to: arrangement size do:[:i|
		cell _ (arrangement at: i).
		extra _ extent x - cell cellSize x.
		extra > 0 ifTrue:[
			"Check if we have any #spaceFillers"
			cell hSpaceFill ifTrue:[ "use only #spaceFillers"
				cell _ cell nextCell.
				n _ cell inject: 0 into:[:sum :c| 
					c hSpaceFill ifTrue:[sum + c target spaceFillWeight] ifFalse:[sum]].
				n isZero ifFalse:[extraPerCell _ extra asFloat / n asFloat].
				extra _ last _ 0.
				cell do:[:c|
					c hSpaceFill ifTrue:[
						extra _ (last _ extra) + (extraPerCell * c target spaceFillWeight).
						amount _ extra truncated - last truncated.
						c cellSize: c cellSize + (amount@0)]].
			] ifFalse:[ "no #spaceFiller; distribute regularly"
				cell _ cell nextCell.
				"centering == #topLeft ifTrue:[]" "add all extra space to the last cell; e.g., do nothing"
				centering == #bottomRight "add all extra space to the first cell"
					ifTrue:[cell addExtraSpace: extra @ 0].
				centering == #center "add 1/2 extra space to the first and last cell"
					ifTrue:[cell addExtraSpace: (extra // 2) @ 0].
				centering == #justified "add extra space equally distributed to each cell"
					ifTrue:[	n _ (cell size - 1) max: 1.
							extraPerCell _ extra asFloat / n asFloat.
							extra _ last _ 0.
							cell do:[:c|
								c addExtraSpace: (extra truncated - last truncated) @ 0.
								extra _ (last _ extra) + extraPerCell]].
			].
		].
	].! !

!TableLayout methodsFor: 'layout' stamp: 'ar 10/31/2000 22:50'!
computeGlobalCellArrangement: cells in: newBounds horizontal: aBool wrap: wrap spacing: spacing
	"Compute number of cells we can put in each row/column. The returned array contains a list of all the cells we can put into the row/column at each level.
	Note: The arrangement is so that the 'x' value of each cell advances along the list direction and the 'y' value along the wrap direction. The returned arrangement has an extra cell at the start describing the width and height of the row."
	| output maxExtent n cell first last hFill vFill |
	output _ (WriteStream on: Array new).
	first _ last _ nil.
	maxExtent _ cells inject: 0@0 into:[:size :c| size max: c cellSize "e.g., minSize"].
	spacing == #globalSquare ifTrue:[maxExtent _ (maxExtent x max: maxExtent y) asPoint].
	n _ (wrap // maxExtent x) max: 1.
	hFill _ vFill _ false.
	1 to: cells size do:[:i|
		cell _ cells at: i.
		hFill _ hFill or:[cell hSpaceFill].
		vFill _ vFill or:[cell vSpaceFill].
		cell cellSize: maxExtent.
		first ifNil:[first _ last _ cell] ifNotNil:[last nextCell: cell. last _ cell].
		(i \\ n) = 0 ifTrue:[
			last _ LayoutCell new.
			last cellSize: (maxExtent x * n) @ (maxExtent y).
			last hSpaceFill: hFill.
			last vSpaceFill: vFill.
			hFill _ vFill _ false.
			last nextCell: first.
			output nextPut: last.
			first _ nil]].
	first ifNotNil:[
		last _ LayoutCell new.
		last cellSize: (maxExtent x * n) @ (maxExtent y). self flag: #arNote."@@@: n is not correct!!"
		last nextCell: first.
		output nextPut: last].
	^output contents
! !

!TableLayout methodsFor: 'layout' stamp: 'ar 1/27/2001 14:40'!
flushLayoutCache
	"Flush any cached information associated with the receiver"
	minExtentCache _ nil.! !

!TableLayout methodsFor: 'layout' stamp: 'ar 11/13/2000 19:42'!
layout: aMorph in: box
	"Compute the layout for the given morph based on the new bounds"
	| cells arrangement horizontal newBounds |
	aMorph hasSubmorphs ifFalse:[^self].
	properties _ aMorph assureTableProperties.
	newBounds _ box origin asIntegerPoint corner: (box corner asIntegerPoint).

	(properties wrapDirection == #none and:[properties cellSpacing == #none]) ifTrue:[
		"get into the fast lane"
		properties listCentering == #justified ifFalse:["can't deal with that"
			properties listDirection == #leftToRight 
				ifTrue:[^self layoutLeftToRight: aMorph in: newBounds].
			properties listDirection == #topToBottom
				ifTrue:[^self layoutTopToBottom: aMorph in: newBounds].
		].
	].

	(properties listDirection == #topToBottom or:[properties listDirection == #bottomToTop])
		ifTrue:[	horizontal _ false]
		ifFalse:[	horizontal _ true].
	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells _ self computeCellSizes: aMorph 
				in: (0@0 corner: newBounds extent) 
				horizontal: horizontal.
	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement _ self computeCellArrangement: cells 
						in: newBounds 
						horizontal: horizontal 
						target: aMorph.
	"Step 3: Compute the extra spacing for each cell"
	self computeExtraSpacing: arrangement 
		in: newBounds 
		horizontal: horizontal 
		target: aMorph.
	"Step 4: Place the children within the cells accordingly"
	self placeCells: arrangement 
		in: newBounds 
		horizontal: horizontal 
		target: aMorph.! !

!TableLayout methodsFor: 'layout' stamp: 'ar 1/27/2001 14:42'!
minExtentOf: aMorph in: box
	"Return the minimal size aMorph's children would require given the new bounds"
	| cells arrangement horizontal newBounds minX minY dir |
	minExtentCache == nil ifFalse:[^minExtentCache].
	aMorph hasSubmorphs ifFalse:[^0@0].
	properties _ aMorph assureTableProperties.

	(properties wrapDirection == #none and:[properties cellSpacing == #none]) ifTrue:[
		"Get into the fast lane"
		dir _ properties listDirection.
		(dir == #leftToRight or:[dir == #rightToLeft])
			ifTrue:[^self minExtentHorizontal: aMorph].
		(dir == #topToBottom or:[dir == #bottomToTop])
			ifTrue:[^self minExtentVertical: aMorph].
	].
	newBounds _ box origin asIntegerPoint corner: (box corner asIntegerPoint).
	(properties listDirection == #topToBottom or:[properties listDirection == #bottomToTop])
		ifTrue:[	horizontal _ false]
		ifFalse:[	horizontal _ true].
	"Step 1: Compute the minimum extent for all the children of aMorph"
	cells _ self computeCellSizes: aMorph 
				in: (0@0 corner: newBounds extent) 
				horizontal: horizontal.
	"Step 2: Compute the arrangement of the cells for each row and column"
	arrangement _ self computeCellArrangement: cells 
						in: newBounds 
						horizontal: horizontal
						target: aMorph.
	"Step 3: Extract the minimum size out of the arrangement"
	minX _ minY _ 0.
	arrangement do:[:cell|
		minX _ minX max: cell cellSize x + cell extraSpace x.
		minY _ minY + cell cellSize y + cell extraSpace y].
	horizontal 
		ifTrue:[minExtentCache _ minX@minY]
		ifFalse:[minExtentCache _ minY@minX].
	^minExtentCache! !

!TableLayout methodsFor: 'layout' stamp: 'ar 11/13/2000 18:25'!
placeCells: arrangement in: newBounds horizontal: aBool target: aMorph
	"Place the morphs within the cells accordingly"
	| xDir yDir anchor yDist place cell xDist cellRect corner inset |
	inset _ properties cellInset.
	(inset isNumber and:[inset isZero]) ifTrue:[inset _ nil].
	aBool ifTrue:["horizontal layout"
		properties listDirection == #rightToLeft ifTrue:[
			xDir _ -1@0.
			properties wrapDirection == #bottomToTop 
				ifTrue:[yDir _ 0@-1. anchor _ newBounds bottomRight]
				ifFalse:[yDir _ 0@1. anchor _ newBounds topRight].
		] ifFalse:[
			xDir _ 1@0.
			properties wrapDirection == #bottomToTop
				ifTrue:[yDir _ 0@-1. anchor _ newBounds bottomLeft]
				ifFalse:[yDir _ 0@1. anchor _ newBounds topLeft]].
	] ifFalse:["vertical layout"
		properties listDirection == #bottomToTop ifTrue:[
			xDir _ 0@-1.
			properties wrapDirection == #rightToLeft
				ifTrue:[yDir _ -1@0. anchor _ newBounds bottomRight]
				ifFalse:[yDir _ 1@0. anchor _ newBounds bottomLeft]
		] ifFalse:[
			xDir _ 0@1.
			properties wrapDirection == #rightToLeft
				ifTrue:[yDir _ -1@0. anchor _ newBounds topRight]
				ifFalse:[yDir _ 1@0. anchor _ newBounds topLeft]].
	].
	1 to: arrangement size do:[:i|
		cell _ arrangement at: i.
		cell extraSpace ifNotNil:[anchor _ anchor + (cell extraSpace y * yDir)].
		yDist _ cell cellSize y * yDir. "secondary advance direction"
		place _ anchor.
		cell _ cell nextCell.
		[cell == nil] whileFalse:[
			cell extraSpace ifNotNil:[place _ place + (cell extraSpace x * xDir)].
			xDist _ cell cellSize x * xDir. "primary advance direction"
			corner _ place + xDist + yDist.
			cellRect _ Rectangle origin: (place min: corner) corner: (place max: corner).
			inset ifNotNil:[cellRect _ cellRect insetBy: inset].
			cell target layoutInBounds: cellRect.
			place _ place + xDist.
			cell _ cell nextCell].
		anchor _ anchor + yDist.
	].
! !


!TableLayout methodsFor: 'utilities' stamp: 'ar 11/1/2000 16:10'!
indexForInserting: aMorph at: aPoint in: owner
	"Return the insertion index based on the layout strategy defined for some morph. Used for drop insertion."
	| horizontal morphList index |
	owner hasSubmorphs ifFalse:[^1].
	aMorph disableTableLayout ifTrue:[^1].
	(owner listDirection == #topToBottom or:[owner listDirection == #bottomToTop])
		ifTrue:[	horizontal _ false]
		ifFalse:[	horizontal _ true].
	morphList _ owner submorphs.
	owner reverseTableCells ifTrue:[morphList _ morphList reversed].
	index _ self indexForInserting: aPoint inList: morphList horizontal: horizontal target: owner.
	owner reverseTableCells ifTrue:[index _ morphList size - index + 2].
	^index ifNil:[1].			! !

!TableLayout methodsFor: 'utilities' stamp: 'ar 11/13/2000 18:26'!
indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph
	| box cmp1 cmp2 cmp3 noWrap |
	properties _ aMorph layoutProperties.
	noWrap _ properties wrapDirection == #none.
	aBool ifTrue:["horizontal"
		properties listDirection == #rightToLeft
			ifTrue:[cmp1 _ [:rect| aPoint x > rect left]]
			ifFalse:[cmp1 _ [:rect| aPoint x < rect right]].
		properties wrapDirection == #bottomToTop 
			ifTrue:[cmp2 _ [:rect| aPoint y > rect top].
					cmp3 _ [:rect| aPoint y > rect bottom]]
			ifFalse:[cmp2 _ [:rect| aPoint y < rect bottom].
					cmp3 _ [:rect| aPoint y < rect top]].
	] ifFalse:["vertical"
		properties listDirection == #bottomToTop 
			ifTrue:[cmp1 _ [:rect| aPoint y > rect top]]
			ifFalse:[cmp1 _ [:rect| aPoint y < rect bottom]].
		properties wrapDirection == #rightToLeft
			ifTrue:[cmp2 _ [:rect| aPoint x > rect left].
					cmp3 _ [:rect| aPoint x > rect right]]
			ifFalse:[cmp2 _ [:rect| aPoint x < rect right].
					cmp3 _ [:rect| aPoint x < rect left]].
	].
	morphList keysAndValuesDo:[:index :m|
		self flag: #arNote. "it is not quite clear if we can really use #fullBounds here..."
		box _ m fullBounds.
		noWrap ifTrue:[
			"Only in one direction"
			(cmp1 value: box) ifTrue:[^index]
		] ifFalse:[
			"Check for inserting before current row"
			(cmp3 value: box) ifTrue:[^index].
			"Check for inserting before current cell"
			((cmp1 value: box) and:[cmp2 value: box]) ifTrue:[^index]]].
	^morphList size + 1! !


!TableLayout methodsFor: 'optimized' stamp: 'ar 11/14/2000 17:10'!
layoutLeftToRight: aMorph in: newBounds
	"An optimized left-to-right list layout"
	| inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
	size _ properties minCellSize asPoint. minX _ size x. minY _ size y.
	size _ properties maxCellSize asPoint. maxX _ size x. maxY _ size y.
	inset _ properties cellInset asPoint x.
	extent _ newBounds extent.
	n _ 0. vFill _ false. sum _ 0.
	width _ height _ 0.
	first _ last _ nil.
	block _ [:m|
		props _ m layoutProperties ifNil:[m].
		props disableTableLayout ifFalse:[
			n _ n + 1.
			cell _ LayoutCell new target: m.
			(props hResizing == #spaceFill) ifTrue:[
				cell hSpaceFill: true.
				extra _ m spaceFillWeight.
				cell extraSpace: extra.
				sum _ sum + extra.
			] ifFalse:[cell hSpaceFill: false].
			(props vResizing == #spaceFill) ifTrue:[vFill _ true].
			size _ m minExtent.
			size _ m minExtent. sizeX _ size x. sizeY _ size y.
			sizeX < minX
				ifTrue:[sizeX _ minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX _ maxX]].
			sizeY < minY
				ifTrue:[sizeY _ minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY _ maxY]].
			cell cellSize: sizeX.
			last ifNil:[first _ cell] ifNotNil:[last nextCell: cell].
			last _ cell.
			width _ width + sizeX.
			sizeY > height ifTrue:[height _ sizeY].
		].
	].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].

	n > 1 ifTrue:[width _ width + (n-1 * inset)].

	(properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]])
		ifTrue:[extent _ width @ (extent y max: height)].
	(properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]])
		ifTrue:[extent _ (extent x max: width) @ height].

	posX _ newBounds left.
	posY _ newBounds top.

	"Compute extra vertical space"
	extra _ extent y - height.
	extra < 0 ifTrue:[extra _ 0].
	extra > 0 ifTrue:[
		vFill ifTrue:[
			height _ extent y.
		] ifFalse:[
			centering _ properties wrapCentering.
			centering == #bottomRight ifTrue:[posY _ posY + extra].
			centering == #center ifTrue:[posY _ posY + (extra // 2)]
		].
	].


	"Compute extra horizontal space"
	extra _ extent x - width.
	extra < 0 ifTrue:[extra _ 0].
	extraPerCell _ 0.
	extra > 0 ifTrue:[
		sum isZero ifTrue:["extra space but no #spaceFillers"
			centering _ properties listCentering.
			centering == #bottomRight ifTrue:[posX _ posX + extra].
			centering == #center ifTrue:[posX _ posX + (extra // 2)].
		] ifFalse:[extraPerCell _ extra asFloat / sum asFloat].
	].

	n _ 0.
	extra _ last _ 0.
	cell _ first.
	[cell == nil] whileFalse:[
		n _ n + 1.
		width _ cell cellSize.
		(extraPerCell > 0 and:[cell hSpaceFill]) ifTrue:[
			extra _ (last _ extra) + (extraPerCell * cell extraSpace).
			amount _ extra truncated - last truncated.
			width _ width + amount.
		].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posX _ posX + width + inset.
		cell _ cell nextCell.
	].
! !

!TableLayout methodsFor: 'optimized' stamp: 'ar 11/14/2000 17:12'!
layoutTopToBottom: aMorph in: newBounds
	"An optimized top-to-bottom list layout"
	| inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
	size _ properties minCellSize asPoint. minX _ size x. minY _ size y.
	size _ properties maxCellSize asPoint. maxX _ size x. maxY _ size y.
	inset _ properties cellInset asPoint y.
	extent _ newBounds extent.
	n _ 0. vFill _ false. sum _ 0.
	width _ height _ 0.
	first _ last _ nil.
	block _ [:m|
		props _ m layoutProperties ifNil:[m].
		props disableTableLayout ifFalse:[
			n _ n + 1.
			cell _ LayoutCell new target: m.
			(props vResizing == #spaceFill) ifTrue:[
				cell vSpaceFill: true.
				extra _ m spaceFillWeight.
				cell extraSpace: extra.
				sum _ sum + extra.
			] ifFalse:[cell vSpaceFill: false].
			(props hResizing == #spaceFill) ifTrue:[vFill _ true].
			size _ m minExtent. sizeX _ size x. sizeY _ size y.
			sizeX < minX
				ifTrue:[sizeX _ minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX _ maxX]].
			sizeY < minY
				ifTrue:[sizeY _ minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY _ maxY]].
			cell cellSize: sizeY.
			first ifNil:[first _ cell] ifNotNil:[last nextCell: cell].
			last _ cell.
			height _ height + sizeY.
			sizeX > width ifTrue:[width _ sizeX].
		].
	].
	properties reverseTableCells
		ifTrue:[aMorph submorphsReverseDo: block]
		ifFalse:[aMorph submorphsDo: block].

	n > 1 ifTrue:[height _ height + (n-1 * inset)].

	(properties vResizing == #shrinkWrap and:[properties rubberBandCells or:[sum isZero]])
		ifTrue:[extent _ (extent x max: width) @ height].
	(properties hResizing == #shrinkWrap and:[properties rubberBandCells or:[vFill not]])
		ifTrue:[extent _ width @ (extent y max: height)].

	posX _ newBounds left.
	posY _ newBounds top.

	"Compute extra horizontal space"
	extra _ extent x - width.
	extra < 0 ifTrue:[extra _ 0].
	extra > 0 ifTrue:[
		vFill ifTrue:[
			width _ extent x.
		] ifFalse:[
			centering _ properties wrapCentering.
			centering == #bottomRight ifTrue:[posX _ posX + extra].
			centering == #center ifTrue:[posX _ posX + (extra // 2)]
		].
	].


	"Compute extra vertical space"
	extra _ extent y - height.
	extra < 0 ifTrue:[extra _ 0].
	extraPerCell _ 0.
	extra > 0 ifTrue:[
		sum isZero ifTrue:["extra space but no #spaceFillers"
			centering _ properties listCentering.
			centering == #bottomRight ifTrue:[posY _ posY + extra].
			centering == #center ifTrue:[posY _ posY + (extra // 2)].
		] ifFalse:[extraPerCell _ extra asFloat / sum asFloat].
	].

	n _ 0.
	extra _ last _ 0.
	cell _ first.
	[cell == nil] whileFalse:[
		n _ n + 1.
		height _ cell cellSize.
		(extraPerCell > 0 and:[cell vSpaceFill]) ifTrue:[
			extra _ (last _ extra) + (extraPerCell * cell extraSpace).
			amount _ extra truncated - last truncated.
			height _ height + amount.
		].
		cell target layoutInBounds: (posX @ posY extent: width @ height).
		posY _ posY + height + inset.
		cell _ cell nextCell.
	].! !

!TableLayout methodsFor: 'optimized' stamp: 'ar 1/27/2001 14:42'!
minExtentHorizontal: aMorph
	"Return the minimal size aMorph's children would require given the new bounds"
	| inset n size width height minX minY maxX maxY sizeX sizeY |
	size _ properties minCellSize asPoint. minX _ size x. minY _ size y.
	size _ properties maxCellSize asPoint. maxX _ size x. maxY _ size y.
	inset _ properties cellInset asPoint.
	n _ 0.
	width _ height _ 0.
	aMorph submorphsDo:[:m|
		m disableTableLayout ifFalse:[
			n _ n + 1.
			size _ m minExtent. sizeX _ size x. sizeY _ size y.
			sizeX < minX
				ifTrue:[sizeX _ minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX _ maxX]].
			sizeY < minY
				ifTrue:[sizeY _ minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY _ maxY]].
			width _ width + sizeX.
			sizeY > height ifTrue:[height _ sizeY].
		].
	].
	n > 1 ifTrue:[width _ width + (n-1 * inset x)].
	^minExtentCache _ width @ height! !

!TableLayout methodsFor: 'optimized' stamp: 'ar 1/27/2001 14:42'!
minExtentVertical: aMorph
	"Return the minimal size aMorph's children would require given the new bounds"
	| inset n size width height minX minY maxX maxY sizeX sizeY |
	size _ properties minCellSize asPoint. minX _ size x. minY _ size y.
	size _ properties maxCellSize asPoint. maxX _ size x. maxY _ size y.
	inset _ properties cellInset asPoint.
	n _ 0.
	width _ height _ 0.
	aMorph submorphsDo:[:m|
		m disableTableLayout ifFalse:[
			n _ n + 1.
			size _ m minExtent. sizeX _ size x. sizeY _ size y.
			sizeX < minX
				ifTrue:[sizeX _ minX]
				ifFalse:[sizeX > maxX ifTrue:[sizeX _ maxX]].
			sizeY < minY
				ifTrue:[sizeY _ minY]
				ifFalse:[sizeY > maxY ifTrue:[sizeY _ maxY]].
			height _ height + sizeY.
			sizeX > width ifTrue:[width _ sizeX].
		].
	].
	n > 1 ifTrue:[height _ height + (n-1 * inset y)].
	^minExtentCache _ width @ height! !
LayoutProperties subclass: #TableLayoutProperties
	instanceVariableNames: 'cellInset cellPositioning cellSpacing layoutInset listCentering listDirection listSpacing reverseTableCells rubberBandCells wrapCentering wrapDirection minCellSize maxCellSize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Layouts'!

!TableLayoutProperties methodsFor: 'initialize' stamp: 'ar 11/14/2000 17:45'!
initialize
	super initialize.
	cellSpacing _ listSpacing _ wrapDirection _ #none.
	cellPositioning _ #center.
	listCentering _ wrapCentering _ #topLeft.
	listDirection _ #topToBottom.
	reverseTableCells _ rubberBandCells _ false.
	layoutInset _ cellInset _ minCellSize _ 0.
	maxCellSize _ 1073741823. "SmallInteger maxVal"
! !


!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:45'!
cellInset
	^cellInset! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'!
cellInset: aNumber
	cellInset _ aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:49'!
cellPositioning
	^cellPositioning! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:49'!
cellPositioning: aSymbol
	cellPositioning _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
cellSpacing
	^cellSpacing! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
cellSpacing: aSymbol
	cellSpacing _ aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 16:37'!
layoutInset
	^layoutInset! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 16:37'!
layoutInset: aNumber
	layoutInset _ aNumber! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listCentering
	^listCentering! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listCentering: aSymbol
	listCentering _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listDirection
	^listDirection! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:46'!
listDirection: aSymbol
	listDirection _ aSymbol.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
listSpacing
	^listSpacing! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
listSpacing: aSymbol
	listSpacing _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
maxCellSize
	^maxCellSize! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:58'!
maxCellSize: aNumber
	maxCellSize _ aNumber.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
minCellSize
	^minCellSize! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/13/2000 17:57'!
minCellSize: aNumber
	minCellSize _ aNumber.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
reverseTableCells
	^reverseTableCells! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
reverseTableCells: aBool
	reverseTableCells _ aBool! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:47'!
rubberBandCells
	^rubberBandCells! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
rubberBandCells: aBool
	rubberBandCells _ aBool.! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapCentering
	^wrapCentering! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapCentering: aSymbol
	wrapCentering _ aSymbol! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapDirection
	^wrapDirection! !

!TableLayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:48'!
wrapDirection: aSymbol
	wrapDirection _ aSymbol! !


!TableLayoutProperties methodsFor: 'testing' stamp: 'ar 11/13/2000 18:34'!
includesTableProperties
	^true! !
GesturalEvent subclass: #TalkGesturalEvent
	instanceVariableNames: 'phoneme '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!

!TalkGesturalEvent methodsFor: 'accessing' stamp: 'len 9/6/1999 00:41'!
phoneme
	^ phoneme! !

!TalkGesturalEvent methodsFor: 'accessing' stamp: 'len 9/6/1999 00:41'!
phoneme: aPhoneme
	phoneme _ aPhoneme! !


!TalkGesturalEvent methodsFor: 'playing' stamp: 'len 9/6/1999 00:44'!
actOn: aHeadMorph
	aHeadMorph face lips articulate: self phoneme! !


!TalkGesturalEvent methodsFor: 'printing' stamp: 'len 9/7/1999 02:27'!
printOn: aStream
	aStream nextPutAll: 'articulate '; print: self phoneme! !
Model subclass: #TelnetMachine
	instanceVariableNames: 'hostname port socket outputBuffer processingCommand commandChar lastInputChar displayLines cursorX cursorY foregroundColor displayMode commandParams requestedRemoteEcho remoteEchoAgreed '
	classVariableNames: 'CSSpecialChars DOChar DONTChar IAC OPTEcho WILLChar WONTChar '
	poolDictionaries: ''
	category: 'Network-TelNet WordNet'!
!TelnetMachine commentStamp: '<historical>' prior: 0!
The beginnings of a telnet terminal, for telnetting to other hosts. 


NOTE - it should separate out the VT100 code to a separate class some time....
!


!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 06:40'!
addBoringStringInNormalMode: aString
	"add a string with no special characters, and assuming we are already in #normal mode"
	|line inPos space amt |

aString do: [ :c | self displayChar: c ].
true ifTrue: [ ^self ].
	line _ displayLines at: cursorY.
	inPos _ 1.

	[ inPos <= aString size ] whileTrue: [
		"copy a line's worth"
		space _ 80 - cursorX + 1.
		amt _ space min: (aString size - inPos + 1).
		line replaceFrom: cursorX to: cursorX+amt-1 with: aString startingAt: inPos.
		line addAttribute: (TextColor color: foregroundColor) from: cursorX to: cursorX+amt-1.
		inPos _ inPos + amt.

		"update cursor"
		cursorX _ cursorX + amt.
		self possiblyWrapCursor.

	].
! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 06:41'!
displayChar: c
	| line |

	displayMode = #sawEscape ifTrue: [ 
		^self displayCharSawEscape: c ].

	displayMode = #gatheringParameters ifTrue: [
		^self displayCharGatheringParameters: c ].

	c = Character escape ifTrue: [
		displayMode _ #sawEscape.
		^self ].

	c = Character cr ifTrue: [
		"go back to the beginning of the line"
		cursorX _ 1.
		^self ].

	c = Character lf ifTrue: [
		"go to the next line"
		cursorY _ cursorY + 1.
		cursorY > 25 ifTrue: [
			self scrollScreenBack: 1.
			cursorY _ 25 ].
		^self ].

	c = Character tab ifTrue: [
		"move to the next tab stop"
		cursorX _ cursorX + 8 // 8 * 8.
		self possiblyWrapCursor.
		^self ].

	"default: display the character"
	line _ displayLines at: cursorY.
	line at: cursorX put: c.
	line addAttribute: (TextColor color: foregroundColor) from: cursorX to: cursorX.
		
	cursorX _ cursorX + 1.
	self possiblyWrapCursor.! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 05:04'!
displayCharGatheringParameters: c
	"display a character from the mode #gatheringParameters"

	| colorName |
	c isDigit  ifTrue: [
		"add a digit to the last parameter"
		commandParams at: commandParams size put:
			(commandParams last * 10 + c digitValue).
		^self ].

	c = $; ifTrue: [
		"end of a parameter; begin another one"
		commandParams add: 0.
		^self ].

	c = $m ifTrue: [
		"change display modes"
		displayMode _ #normal.

		commandParams do: [ :p |
			p = 0 ifTrue: [
				"reset"
				foregroundColor _ Color white ].
			(p >= 30 and: [ p <= 37 ]) ifTrue: [
				"change color"
				colorName _ #(gray red green yellow blue blue cyan white) at: (p - 29).
				foregroundColor _ Color perform: colorName. ] ].

		^self ].


	"unrecognized character"
	displayMode _ #normal.
	^self displayChar: c! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 02:30'!
displayCharSawEscape: c
	"display a character from the mode #sawEscape"

	c = $[ ifTrue: [
		commandParams _ OrderedCollection with: 0.
		displayMode _ #gatheringParameters.
		^self ].
	
	displayMode _ #normal.
	^self displayChar: c! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 06:46'!
displayString: aString
	"add aString to the display"
	|pos specialIdx |

	pos _ 1. 	"pos steps through aString"

	[ pos <= aString size ] whileTrue: [
		displayMode = #normal ifTrue: [
			"try to display a whole hunk of text at once"
			specialIdx _ aString indexOfAnyOf: CSSpecialChars startingAt: pos ifAbsent: [ aString size + 1 ].
			specialIdx > pos ifTrue: [
				self addBoringStringInNormalMode: (aString copyFrom: pos to: specialIdx-1).
				pos _ specialIdx. ] ].

			pos <= aString size ifTrue: [
				"either a special has been seen, or we're in a special mode"
				self displayChar: (aString at: pos).
				pos _ pos + 1. ].
	].

! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 06:39'!
possiblyWrapCursor
	"if the cursor has gone past the right margin, then wrap"

	cursorX > 80 ifTrue: [
		cursorX _ 1.
		cursorY _ cursorY + 1.
		cursorY > 25 ifTrue: [
			cursorY _ 25.
			self scrollScreenBack: 1 ].
	].
! !

!TelnetMachine methodsFor: 'screen management' stamp: 'ls 9/16/1998 02:10'!
scrollScreenBack: numLines
	"scrolls the screen up by the number of lines.  The cursor isn't moved"
	numLines timesRepeat: [ displayLines removeFirst ].
	numLines timesRepeat: [
		displayLines addLast: (Text new: 80 withAll: Character space) ].! !


!TelnetMachine methodsFor: 'sending data' stamp: 'ls 9/26/1998 10:24'!
processTyping: aString
	"process aString as if it were typed"
	outputBuffer nextPutAll: aString asString.
	remoteEchoAgreed ifFalse: [ self displayString: aString asString ].
	^true! !

!TelnetMachine methodsFor: 'sending data' stamp: 'ls 9/2/1999 08:09'!
sendLine: aString
	"send a line, along with a newline"
	self processTyping: aString, String crlf.
	^true! !


!TelnetMachine methodsFor: 'access' stamp: 'ls 9/16/1998 02:12'!
displayBuffer
	"the 'screen' of the terminal"
	^Text streamContents: [ :s |
		displayLines do: [ :line |
			s nextPutAll: line.
			s cr. ] ]! !

!TelnetMachine methodsFor: 'access' stamp: 'ls 9/16/1998 06:36'!
displayBufferSelection
	"where the selection should be in the display buffer.  It should be where the cursor is"
	| pos |
	pos _ cursorY * 81 + cursorX - 82.
	^pos+1 to: pos! !

!TelnetMachine methodsFor: 'access' stamp: 'ls 9/11/1998 04:41'!
isConnected
	"answer whether we are connected to a remote host"
	^socket ~~ nil and: [ socket isValid and: [ socket isConnected ] ]! !

!TelnetMachine methodsFor: 'access' stamp: 'ls 9/11/1998 04:46'!
port: anInteger
	"set which port to connect to"
	port _ anInteger! !

!TelnetMachine methodsFor: 'access' stamp: 'ls 9/11/1998 04:40'!
remoteHost: aString
	"set which host to connect to"
	hostname _ aString! !


!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/26/1998 10:25'!
connect
	"connect to the name host"
	| addr |
	self isConnected ifTrue: [ self disconnect ].

	Socket initializeNetwork.

	addr _ NetNameResolver addressForName: hostname.
	addr ifNil: [ self error: 'could not find address for ', hostname ].

	socket _ Socket new.
	
	socket connectTo: addr port: port.
	(socket waitForConnectionUntil: Socket standardDeadline) ifFalse: [
		self error: 'connection failed' ].

	
	requestedRemoteEcho _ true.
	self do: OPTEcho.! !

!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/11/1998 05:57'!
disconnect
	self isConnected ifTrue: [
		Transcript show: 'disconnecting from ', hostname.
		socket disconnect ].! !

!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/16/1998 05:20'!
processIO
	"should be called periodically--this actually sends and recieves some bytes over the network"
	| amountSent |


	self isConnected ifFalse: [ ^ self ].

	outputBuffer _ outputBuffer contents.	"convert to String for convenience in the loop.  still not as optimal as it could be...."
	[outputBuffer size > 0 and: [ socket sendDone ]] whileTrue: [ 
		"do some output"
		amountSent _ socket sendSomeData: outputBuffer.
		outputBuffer _ outputBuffer copyFrom: amountSent+1 to: outputBuffer size. ].
	outputBuffer _ WriteStream on: outputBuffer.

	"do some input"
	[socket dataAvailable] whileTrue: [
		self processInput: socket getData ].! !

!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/11/1998 05:01'!
release
	self isConnected ifTrue:[ self disconnect ]! !

!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/11/1998 05:03'!
step
	self processIO! !

!TelnetMachine methodsFor: 'IO' stamp: 'ls 9/2/1999 08:08'!
wantsSteps
	^true! !


!TelnetMachine methodsFor: 'menu' stamp: 'ls 9/11/1998 04:58'!
menu: aMenu shifted: shiftState

	aMenu labels: 
'set host name
set port
connect
disconnect' lines: #() selections: #(setHostName setPort connect disconnect).
	^aMenu! !

!TelnetMachine methodsFor: 'menu' stamp: 'ls 9/11/1998 05:02'!
perform: aSelector orSendTo: anObject
	^self perform: aSelector! !

!TelnetMachine methodsFor: 'menu' stamp: 'ls 9/11/1998 05:15'!
setHostName
	| newHostname |
	newHostname _ FillInTheBlank request: 'host to connect to' initialAnswer: hostname.
	newHostname size > 0 ifTrue: [ hostname _ newHostname ].! !

!TelnetMachine methodsFor: 'menu' stamp: 'ls 9/11/1998 05:15'!
setPort
	| portString |
	portString _ port printString.
	portString _ FillInTheBlank request: 'port to connect on' initialAnswer: portString.
	portString _ portString withBlanksTrimmed.
	portString isEmpty ifFalse: [ port _ portString asNumber asInteger ].! !


!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:17'!
do: optionNo
	"request that the remote side does optionNo"
	self sendChar: IAC.
	self sendChar: DOChar.
	self sendChar: optionNo asCharacter! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:17'!
dont: optionNo
	"demand that the remote side doesn't do optionNo"
	self sendChar: IAC.
	self sendChar: DONTChar.
	self sendChar: optionNo asCharacter! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/2/1999 08:08'!
initialize
	outputBuffer _ WriteStream on: String new.
	port _ 23.
	processingCommand _ false.
	displayLines _ (1 to: 25) asOrderedCollection collect: [ :i |
		Text new: 80 withAll: Character space ].
	cursorX _ 1.
	cursorY _ 1.
	foregroundColor _ Color white.
	displayMode _ #normal.
	requestedRemoteEcho _ false.
	remoteEchoAgreed _ false.
	hostname _ ''.! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:20'!
processDo: optionChar
	"we don't do anything"
	self wont: optionChar! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:20'!
processDont: char
	"okay, fine by us, we won't do it..."! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:19'!
processInput: aString
	"process input from the network"
	| newDisplayText |

	(processingCommand not and: [(aString indexOf: IAC) = 0]) ifTrue: [
		"no commands here--display the whole string"
		self displayString: aString.
		self changed: #displayBuffer.
		^self ].

	Transcript show: 'slow.'; cr.

	newDisplayText _ WriteStream on: String new.

	aString do: [ :c |
		processingCommand ifTrue: [
			"an IAC has been seen"
			commandChar
				ifNil: [ 
					"c is the command character.  act immediately if c=IAC, otherwise save it and wait fro the next character"
					commandChar _ c.  
					(commandChar = IAC) ifTrue: [ self displayChar: IAC. processingCommand _ false ] ]
				ifNotNil: [
					commandChar == DOChar ifTrue: [ self processDo: c. ].
					commandChar == DONTChar ifTrue: [ self processDont: c ].
					commandChar == WILLChar ifTrue: [ self processWill: c ].
					commandChar == WONTChar ifTrue: [ self processWont: c ].
					processingCommand _ false.  ] ]
		ifFalse: [
			"normal mode"
			c = IAC ifTrue: [ processingCommand _ true.  commandChar _ nil ] ifFalse: [
			  newDisplayText nextPut: c ] ] ].


	self displayString: newDisplayText contents.

	self changed: #displayBuffer
! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:23'!
processWill: optionChar
	optionChar == OPTEcho ifTrue: [
		requestedRemoteEcho ifTrue: [
			remoteEchoAgreed _ true ]
		ifFalse: [
			"they are offering remote echo, though we haven't asked.  Answer: oh yes."
			self do: OPTEcho.
			requestedRemoteEcho _ true.
			remoteEchoAgreed _ true. ].
	^self  ].
	

	"they've requested an unknown option.  reject it"
	self dont: optionChar.! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:27'!
processWont: optionChar
	optionChar == OPTEcho ifTrue: [
		remoteEchoAgreed _ false.
		requestedRemoteEcho _ false.
	^self  ].
	
! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 10:26'!
sendChar: char
	"queue a character for sending over the network"
	outputBuffer nextPut: char! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 09:56'!
will: optionNo
	"request that we do optionNo"
	self sendChar: IAC.
	self sendChar: WILLChar.
	self sendChar: optionNo asCharacter! !

!TelnetMachine methodsFor: 'private' stamp: 'ls 9/26/1998 09:57'!
wont: optionNo
	"demand that we won't do optionNo"
	self sendChar: IAC.
	self sendChar: WONTChar.
	self sendChar: optionNo asCharacter! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TelnetMachine class
	instanceVariableNames: ''!

!TelnetMachine class methodsFor: 'user interface' stamp: 'ls 9/25/1998 21:00'!
open
	"TelnetMachine open"
	| machine win displayMorph inputMorph |
	Smalltalk isMorphic ifFalse: [ ^self notYetImplemented ].
	
	machine _ self new.

	win _ SystemWindow labelled: 'telnet'.
	win model: machine.

	displayMorph _ PluggableTextMorph on: machine text: #displayBuffer accept: nil readSelection: #displayBufferSelection menu: #menu:shifted:.	
	displayMorph color: Color black.

	inputMorph _ PluggableTextMorph on: machine text: nil accept: #sendLine:.
	inputMorph acceptOnCR: true.

	win addMorph: displayMorph frame: (0@0 extent: 1@0.9).
	win addMorph: inputMorph frame: (0@0.9 extent: 1@0.1).

	displayMorph color: Color black.

	win openInWorld.
! !


!TelnetMachine class methodsFor: 'instance creation' stamp: 'ls 9/11/1998 04:47'!
new
	^super new initialize! !


!TelnetMachine class methodsFor: 'initialization' stamp: 'ls 9/26/1998 10:18'!
initialize
	"TelnetMachine initialize"
	WILLChar _ 251 asCharacter.
	WONTChar _ 252 asCharacter.
	DOChar _ 253 asCharacter.
	DONTChar _ 254 asCharacter.
	IAC _ 255 asCharacter.

	OPTEcho _ 1 asCharacter.


	"set of characters that need special processing"
	CSSpecialChars _ CharacterSet 
		with: Character escape 
		with: Character cr
		with: Character lf
		with: Character tab.
	! !
VariableNode subclass: #TempVariableNode
	instanceVariableNames: 'isAnArg hasRefs hasDefs scope '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!TempVariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a temporary variable!


!TempVariableNode methodsFor: 'initialize-release'!
isArg: aBoolean

	isAnArg _ aBoolean.
	isAnArg ifTrue: [hasDefs _ true]! !

!TempVariableNode methodsFor: 'initialize-release'!
name: varName index: i type: type scope: level
	"Only used for initting temporary variables"
	name _ varName.
	self key: varName
		index: i
		type: type.
	isAnArg _ hasDefs _ hasRefs _ false.
	scope _ level! !

!TempVariableNode methodsFor: 'initialize-release'!
nowHasDef
	hasDefs _ true! !

!TempVariableNode methodsFor: 'initialize-release'!
nowHasRef
	hasRefs _ true! !

!TempVariableNode methodsFor: 'initialize-release'!
scope: level
	"Note scope of temporary variables.
	Currently only the following distinctions are made:
		0	outer level: args and user-declared temps
		1	block args and doLimiT temps
		-1	a block temp that is no longer active
		-2	a block temp that held limit of to:do:"
	scope _ level! !


!TempVariableNode methodsFor: 'testing'!
assignmentCheck: encoder at: location

	isAnArg ifTrue: [^ location]
			ifFalse: [^ -1]! !

!TempVariableNode methodsFor: 'testing'!
isArg
	^ isAnArg! !

!TempVariableNode methodsFor: 'testing'!
isTemp
	^ true! !

!TempVariableNode methodsFor: 'testing'!
isUndefTemp
	^ hasDefs not! !

!TempVariableNode methodsFor: 'testing'!
isUnusedTemp
	^ hasRefs not! !

!TempVariableNode methodsFor: 'testing'!
scope
	^ scope! !


!TempVariableNode methodsFor: 'printing' stamp: 'di 4/5/2000 15:11'!
printOn: aStream indent: level 
	aStream withStyleFor: #temporaryVariable
			do: [aStream nextPutAll: name]! !


!TempVariableNode methodsFor: 'tiles' stamp: 'di 11/10/2000 16:43'!
asMorphicSyntaxIn: parent

	^ parent addToken: name type: #tempVariable on: self! !

!TempVariableNode methodsFor: 'tiles' stamp: 'RAA 8/16/1999 12:34'!
explanation

	^(self isArg ifTrue: ['Method argument'] ifFalse: ['Temporary variable']),' <',name,'>'
! !
AbstractScoreEvent subclass: #TempoEvent
	instanceVariableNames: 'tempo '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Scores'!
!TempoEvent commentStamp: '<historical>' prior: 0!
Represents a tempo change in a MIDI score.
!


!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:10'!
isTempoEvent

	^ true
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 08:37'!
printOn: aStream

	aStream nextPut: $(.
	time printOn: aStream.
	aStream nextPutAll: ': tempo '.
	((120.0 * (500000.0 / tempo)) roundTo: 0.01) printOn: aStream.
	aStream nextPut: $).
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:09'!
tempo

	^ tempo
! !

!TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 12/30/97 10:09'!
tempo: anInteger

	tempo _ anInteger.
! !
Object subclass: #TestCClass1
	instanceVariableNames: 'x y '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TestCClass1 methodsFor: 'as yet unclassified'!
arg1: a arg2: b
	"CCodeGenerator new initialize addClass: TestCClass1"

	| i j k |
	self var: #i declareC: 'char *i'.
	i _ 'abc'.
	j _ 2.
	k _ 3.! !

!TestCClass1 methodsFor: 'as yet unclassified'!
ifTests

	true ifTrue: [
		self print: 'true case'
	].

	true ifFalse: [
		self print: 'false case'
	].

	true ifTrue: [
		self print: 'true case'
	] ifFalse: [
		self print: 'false case'
	].

	true ifFalse: [
		self print: 'false case'
	] ifTrue: [
		self print: 'true case'
	].! !

!TestCClass1 methodsFor: 'as yet unclassified'!
isIntegerValue: intValue
	"Copied from ObjectMemory."

	^ (intValue bitXor: (intValue << 1)) >= 0! !

!TestCClass1 methodsFor: 'as yet unclassified'!
loopTests
	| v |
	v _ 0.
	[v < 10] whileTrue: [ self printNum: v.  v _ v + 1 ].
	self print: ''.
	[v < 1] whileFalse: [ self printNum: v.  v _ v - 1 ].
	self print: ''.
	1 to: 10 do: [ :i | self printNum: i ].
	self print: ''.
	1 to: 10 by: 2 do: [ :i | self printNum: i ].
	self print: ''.! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method1
	"(CCodeGenerator new initialize addClass: TestCClass1) codeString"

	x & y ifTrue: [
		x _ 10.
		y _ 20.
	].
	y _ nil + 3.
	x = nil ifTrue: [ x _ 18 ].
	^nil! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method2

	self method1; method8: 0; setX: 10 Y: 20.! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method3

	x > 0 ifTrue: [ ^x ] ifFalse: [ ^y ].! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method4

	x _ 0.
	y _ 0.
	[x < 100] whileTrue: [
		y _ y + x.
		x _ x + 1.
	].
	^y! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method5

	self inline: true.
	x & y.
	x | y.
	x and: [y].
	x or: [y].
	x not.

	x + y.
	x - y.
	x * y.
	x // y.
	x \\ y.
	x min: y.
	x max: y.

	x bitAnd: y.
	x bitOr: y.
	x bitXor: y.
	x bitInvert32.
	x bitShift: y.
	x >> y.
	x << y.

	x < y.
	x <= y.
	x = y.
	x >= y.
	x > y.
	x ~= y.
	x == y.
	x isNil.
	x notNil.

	[x > y] whileTrue: [ x _ x + 1 ].
	[x > y] whileFalse: [ x _ x + 1 ].

	x > y ifTrue: [ x _ x - 1 ].
	x > y ifFalse: [ x _ x + 1 ].
	x > y ifTrue: [ x _ x - 1 ] ifFalse: [ x _ x + 1 ].
	x > y ifFalse: [ x _ x + 1 ] ifTrue: [ x _ x - 1 ].

	x at: 3.
	x at: 3 put: y.

	self integerValueOf: x.
	self integerObjectOf: x.
	(self isIntegerObject: x) ifTrue: [ x _ x - 1 ].
	(self isIntegerValue: x) ifTrue: [ x _ x - 1 ].
	self cCoerce: x * (y - 1) to: 'int'.

	x _ x + 1.
	x _ x - 1.
	x preDecrement.
	y preIncrement > 0 ifTrue: [ x _ x + 1 ].
! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method6

	self dispatchOn: x in: #(f1 f2 f3 f4 f5).! !

!TestCClass1 methodsFor: 'as yet unclassified'!
method7

	| t1 |
	self method1.
	self method2.
	t1 _ self method3.
	self method4.
	self method5.
! !

!TestCClass1 methodsFor: 'as yet unclassified' stamp: 'jm 2/15/1999 13:14'!
method8: arg

	| a |
	self returnTypeC: 'float'.
	self var: #a    declareC: 'float a = 0'.
	self var: #arg declareC: 'float arg'.
	self cCode: 'a = arg * 3.14159'.
	self cCode: 'a = arg * 2.0' inSmalltalk: [a _ arg * 2.0].
	^ a
! !

!TestCClass1 methodsFor: 'as yet unclassified' stamp: 'jm 11/25/1998 18:09'!
method9
	"Test conditional code generation."

	true ifTrue: [^ 1].
	false ifTrue: [^ 'should not be generated'].

	true ifFalse: [^ 'should not be generated'].
	false ifFalse: [^ 2].

	true ifTrue: [^ 3] ifFalse: [^ 'should not be generated'].
	false ifTrue: [^ 'should not be generated'] ifFalse: [^ 4].

	true ifFalse: [^ 'should not be generated'] ifTrue: [^ 5].
	false ifFalse: [^ 6] ifTrue: [^ 'should not be generated'].
! !

!TestCClass1 methodsFor: 'as yet unclassified'!
print: val

	self cCode: 'printf("%d\n", val)'.! !

!TestCClass1 methodsFor: 'as yet unclassified'!
printNum: i

	self cCode: 'printf("%d ", i)'.! !

!TestCClass1 methodsFor: 'as yet unclassified'!
setX: newX Y: newY

	x _ newX min: newY.
	y _ newY.! !
Object subclass: #TestCClass2
	instanceVariableNames: 'vect '
	classVariableNames: 'VectSize '
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TestCClass2 methodsFor: 'as yet unclassified'!
atAllPut

	| i |
	i _ VectSize.
	[i > 0] whileTrue: [
		vect at: i put: 5.
		i _ i - 1.
	].
	(vect at: 1) ~= 5 ifTrue: [ self error: 'AtAllPutBenchmark' ].! !

!TestCClass2 methodsFor: 'as yet unclassified'!
error: s
	"Print an error message and exit."

	self print: 'Error in %s\n' f: s.
	self exit: -1.! !

!TestCClass2 methodsFor: 'as yet unclassified'!
incrementAll

	| oldVal i |
	oldVal _ vect at: 1.
	i _ VectSize.
	[i > 0] whileTrue: [
		vect at: i put: ((vect at: i) + 1).
		i _ i - 1.
	].
	(vect at: 1) ~= (oldVal + 1) ifTrue: [ self error: 'IncrementAllBenchmark' ].! !

!TestCClass2 methodsFor: 'as yet unclassified'!
initialize

	VectSize _ 10000.
	vect _ Array new: VectSize.! !

!TestCClass2 methodsFor: 'as yet unclassified'!
main

	| startTicks ticks |
	self printf: 'atAllPut: '.
	startTicks _ self clock.
	self atAllPut.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.

	self printf: 'incrementAll: '.
	self incrementAll.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.

	self printf: 'nestedWhileLoop: '.
	self nestedWhileLoop.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.

	self printf: 'sieve: '.
	self sieve.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.

	self printf: 'sumAll: '.
	self sumAll.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.

	self printf: 'sumFromTo: '.
	self sumFromTo.
	ticks _ self clock - startTicks.
	self print: '%ld\n' f: ticks.! !

!TestCClass2 methodsFor: 'as yet unclassified'!
nestedWhileLoop

	| sum i j |
	sum _ 0.
	i _ 1000.
	[i > 0] whileTrue: [
		j _ 100.
		[j > 0] whileTrue: [
			sum _ sum + 1.
			j _ j - 1.
		].
		i _ i - 1.
	].
	sum ~= 100000 ifTrue: [ self error: 'NestedWhileBenchmark' ].! !

!TestCClass2 methodsFor: 'as yet unclassified'!
sieve

	| flagsSize flags primeCount i k |
	flagsSize _ 8190.
	flags _ Array new: flagsSize.
	i _ flagsSize.
	[i > 0] whileTrue: [
		flags at: i put: true.
		i _ i - 1.
	].

	primeCount _ 0.
	i _ 2.
	[i <= flagsSize] whileTrue: [
		(flags at: i) ifTrue: [
			primeCount _ primeCount + 1. "i is a prime"
			k _ i + i.
			[k <= flagsSize] whileTrue: [
				flags at: k put: false. "k is not a prime; it is a multiple of i"
				k _ k + i.
			].
		].
		i _ i + 1.
	].

	primeCount ~= 1027 ifTrue: [ self error: 'SieveBenchmark' ].! !

!TestCClass2 methodsFor: 'as yet unclassified'!
sumAll

	| elementVal sum i |
	elementVal _ vect at: 1.
	sum _ 0.
	i _ VectSize.
	[i > 0] whileTrue: [
		sum _ sum + (vect at: i).
		i _ i - 1.
	].
	sum ~= (VectSize * elementVal) ifTrue: [ self error: 'SumAllBenchmark' ].! !

!TestCClass2 methodsFor: 'as yet unclassified'!
sumFromTo

	| sum i j |
	i _ 10.
	[i > 0] whileTrue: [
		sum _ 0.
		j _ 10000.
		[j > 0] whileTrue: [
			sum _ sum + j.
			j _ j - 1.
		].
		i _ i - 1.
	].
	sum ~= 50005000 ifTrue: [ self error: 'SumFromToBenchmark' ].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestCClass2 class
	instanceVariableNames: ''!

!TestCClass2 class methodsFor: 'testing'!
test
	"TestCClass2 test"
	"(CCodeGenerator new initialize addClass: TestCClass2) codeString"

	| bm |
	bm _ self new initialize.
	Transcript show: 'atAllPut: '.
	Transcript show: (Time millisecondsToRun: [bm atAllPut]) printString; cr.
	Transcript show: 'incrementAll: '.
	Transcript show: (Time millisecondsToRun: [bm incrementAll]) printString; cr.
	Transcript show: 'nestedWhileLoop: '.
	Transcript show: (Time millisecondsToRun: [bm nestedWhileLoop]) printString; cr.
	Transcript show: 'sieve: '.
	Transcript show: (Time millisecondsToRun: [bm sieve]) printString; cr.
	Transcript show: 'sumAll: '.
	Transcript show: (Time millisecondsToRun: [bm sumAll]) printString; cr.
	Transcript show: 'sumFromTo: '.
	Transcript show: (Time millisecondsToRun: [bm sumFromTo]) printString; cr.! !
Object subclass: #TestCClass3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Translation to C'!

!TestCClass3 methodsFor: 'as yet unclassified'!
dispatchOn: currentBytecode in: selectorArray
	"Simulate a case statement via selector table lookup. The given integer must be between 0 and (selectorArray size - 1), inclusive. Send the selector at (currentBytecode + 1) in selectorArray to the receiver. For speed, no extra range test is done, since it is done by the at: operation."
	"Note: Delete this method from the generated code."

	"assert: (currentBytecode >= 0) | (currentBytecode < selectorArray size)"
	self perform: (selectorArray at: (currentBytecode + 1)).! !

!TestCClass3 methodsFor: 'as yet unclassified'!
f1

	| local r |
	local _ self functionWithLabel: 1.
	r _ 7.
	self print: 'f1'.! !

!TestCClass3 methodsFor: 'as yet unclassified'!
f2

	| local i |
	local _ 2.
	i _ self functionWithLabel: -2.
	i > 0 ifTrue: [ ^ -1 ].
	self print: 'f2'.! !

!TestCClass3 methodsFor: 'as yet unclassified'!
f3

	self sharedCodeNamed: 'sharedCode' inCase: 5.
	self print: 'f3'.! !

!TestCClass3 methodsFor: 'as yet unclassified'!
f4

	self sharedCodeNamed: 'sharedCode' inCase: 5.
	self print: 'f4'.! !

!TestCClass3 methodsFor: 'as yet unclassified'!
f5

	self sharedCodeNamed: 'sharedCode' inCase: 5.
	self print: 'f5'.! !

!TestCClass3 methodsFor: 'as yet unclassified'!
functionWithLabel: arg

	arg > 0 ifTrue: [ ^1 ] ifFalse: [ ^-1 ].! !

!TestCClass3 methodsFor: 'as yet unclassified'!
interpret
	"TestCClass3 new main"
	"(CCodeGenerator new initialize addClass: TestCClass3) codeString"

	0 to: 9 do: [ :currentBytecode |
		self dispatchOn: currentBytecode in: #(f1 f2 f2 f3 f3 f3 f4 f4 f5 f2).
	].
! !

!TestCClass3 methodsFor: 'as yet unclassified'!
print: s

	self var: #s declareC: 'char *s'.
	self cCode: 'printf("%s", s)'.! !
Object subclass: #TestCase
	instanceVariableNames: 'testMessage '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Framework'!
!TestCase commentStamp: '<historical>' prior: 0!
Defines the fixture to run multiple tests plus the tests using this fixture. To define a test case

  * implement a subclass of TestCase,
  * define instance variables that store the state of the fixture,
  * initialize the fixture state by overriding TestCase setUp,
  * clean-up after a test by overriding TestCase tearDown, and

Each test runs in its own fixture so there can be no side effects among test runs.

For each test in the context of this fixture set-up,

  * implement a method(s) which interacts with the fixture.

In the test method(s) verify the expected results with assertions specified by calling

  * TestCase assert:
  * TestCase deny:
  * TestCase should:
  * TestCase shouldnt:
  * TestCase value:shouldRaise: or
  * TestCase value:shouldntRaise:

with arguments of the expected type.

Instance Variables:
	testMessage		<Symbol>!
]style[(252 14 42 17 298 16 5 14 5 16 5 18 5 27 8 29 75 6 1)f1,f1LTestCase setUp;,f1,f1LTestCase tearDown;,f1,f1LTestCase assert:;,f1,f1LTestCase deny:;,f1,f1LTestCase should:;,f1,f1LTestCase shouldnt:;,f1,f1LTestCase value:shouldRaise:;,f1,f1LTestCase value:shouldntRaise:;,f1,f1LSymbol Hierarchy;,f1!


!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
assert: aBoolean

	aBoolean
		ifFalse: [TestResult testFailureException signal: 'Assertion failed'].! !

!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
deny: aBoolean

	self assert: aBoolean not.! !

!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
should: aBlockContext

	self assert: aBlockContext value.! !

!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
shouldnt: aBlockContext

	self deny: aBlockContext value.! !

!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
value: aBlockContext shouldRaise: anException

	aBlockContext
		on: anException
		do: [:ex | ^self].
	TestResult testFailureException signal: 'Failed to raise ', anException printString.! !

!TestCase methodsFor: 'asserting' stamp: 'rhi 2/5/2000 12:36'!
value: aBlockContext shouldntRaise: anException

	aBlockContext
		on: anException
		do: [:ex | TestResult testFailureException
			signal: 'Should not raise ', anException printString].! !


!TestCase methodsFor: 'printing' stamp: 'rhi 2/5/2000 12:37'!
printOn: aStream

	aStream
		nextPutAll: self class printString;
		nextPutAll: '>>';
		nextPutAll: self testMessage.! !


!TestCase methodsFor: 'private accessing' stamp: 'rhi 5/22/1999 17:37'!
testMessage

	^testMessage! !

!TestCase methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:38'!
testMessage: aSymbol

	testMessage := aSymbol.! !


!TestCase methodsFor: 'running' stamp: 'rhi 2/5/2000 12:37'!
debug

	self runCase.! !

!TestCase methodsFor: 'running' stamp: 'rhi 5/22/1999 17:32'!
run

	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestCase methodsFor: 'running' stamp: 'rhi 2/5/2000 12:37'!
run: aTestResult

	aTestResult runCase: self.! !

!TestCase methodsFor: 'running' stamp: 'rhi 2/5/2000 12:38'!
runCase

	self setUp.
	[self perform: self testMessage]
		ensure: [self tearDown].! !

!TestCase methodsFor: 'running' stamp: 'rhi 5/24/1999 21:16'!
setUp
	"Sets up the fixture. This method is called before a test is executed."! !

!TestCase methodsFor: 'running' stamp: 'rhi 5/24/1999 21:17'!
tearDown
	"Tears down the fixture. This method is called after a test is executed."! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestCase class
	instanceVariableNames: ''!

!TestCase class methodsFor: 'instance creation' stamp: 'rhi 5/22/1999 17:36'!
selector: aSymbol

	^self new testMessage: aSymbol! !

!TestCase class methodsFor: 'instance creation' stamp: 'rhi 10/23/1999 01:29'!
suite

	| testMethods testSuite |
	testMethods := self selectors select: [:each |
		'test*' match: each].
	testSuite := TestSuite new.
	testMethods do: [:each |
		testSuite addTest: (self selector: each)].
	^testSuite! !


!TestCase class methodsFor: 'processing' stamp: 'rhi 5/22/1999 13:21'!
debug: aSymbol

	^(self selector: aSymbol) debug! !

!TestCase class methodsFor: 'processing' stamp: 'rhi 5/22/1999 13:21'!
run: aSymbol

	^(self selector: aSymbol) run! !
PluggableCodeGenerator subclass: #TestCodeGenerator
	instanceVariableNames: 'debugFlag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!TestCodeGenerator commentStamp: '<historical>' prior: 0!
Subclass of CCodeGenerator, used in connection with TestInterpreterPlugin to generate named primitives with type coercion specifications!


!TestCodeGenerator methodsFor: 'initialize' stamp: 'sr 4/8/2000 00:53'!
initialize
	super initialize.
	debugFlag _ false! !



!TestCodeGenerator methodsFor: 'transforming' stamp: 'ar 3/10/2000 17:59'!
var: varName as: aClass
	"Record the given C declaration for a global variable"

	variableDeclarations at: varName asString put: (aClass ccgDeclareCForVar: varName)! !


!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asBooleanValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: ' = interpreterProxy->booleanValueOf(';
		crtab: 2;
		nextPutAll: 'interpreterProxy->stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asCharPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (char *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asFloatPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (float *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asFloatValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy->stackFloatValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asIntPtrFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = (int *) interpreterProxy->firstIndexableField(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValueOf(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:43'!
emitLoad: aString asIntegerValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy stackIntegerValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:42'!
emitLoad: aString asKindOf: aClass from: anInteger on: aStream

	self emitLoad: aString asNakedOopFrom: anInteger on: aStream.
	aStream
		crtab;
		nextPutAll: 'interpreterProxy->success(interpreterProxy->isKindOf(';
		nextPutAll: aString;
		nextPutAll: 	', ''';
		nextPutAll:	aClass asString;
		nextPutAll: '''))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'bf 3/16/2000 19:20'!
emitLoad: aString asMemberOf: aClass from: anInteger on: aStream

	self emitLoad: aString asNakedOopFrom: anInteger on: aStream.
	aStream
		crtab;
		nextPutAll: 'interpreterProxy->success(interpreterProxy->isMemberOf(';
		nextPutAll: aString;
		nextPutAll: 	', ''';
		nextPutAll:	aClass asString;
		nextPutAll: '''))'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/18/1999 14:23'!
emitLoad: aString asNakedOopFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: ' = interpreterProxy stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:44'!
emitLoad: aString asNonIntegerValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy stackObjectValue(';
		nextPutAll: anInteger asString;
		nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'linking' stamp: 'acg 9/17/1999 01:44'!
emitLoad: aString asUnsignedValueFrom: anInteger on: aStream

	aStream
		nextPutAll: aString;
		nextPutAll: 	' = interpreterProxy->positive32BitValueOf(';
		crtab: 2;
		nextPutAll: 	'interpreterProxy->stackValue(';
		nextPutAll: anInteger asString;
		nextPutAll: '))'! !


!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:32'!
ccgLoad: aBlock expr: aString asBooleanValueFrom: anInteger
	"Answer codestring for boolean coercion (with validating side-effect) of object, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy booleanValueOf:';
		crtab: 2;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	')'])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asCharPtrFrom: anInteger
	"Answer codestring for character pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asCharPtrFrom: anInteger andThen: valBlock
	"Answer codestring for character pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *''']))
	 ! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asFloatValueFrom: anInteger
	"Answer codestring for double precision coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackFloatValue: ';
		nextPutAll: anInteger asString])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntPtrFrom: anInteger
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntPtrFrom: anInteger andThen: valBlock
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *''']))! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asIntegerValueFrom: anInteger
	"Answer codestring for integer coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackIntegerValue: ';
		nextPutAll: anInteger asString])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 20:28'!
ccgLoad: aBlock expr: aString asKindOf: aClass from: anInteger

	^String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy success: (interpreterProxy';
		crtab: 2;
		nextPutAll: 'is: (interpreterProxy stackValue: ';
		nextPutAll: anInteger asString;
		nextPutAll: ')';
		crtab: 2;
		nextPutAll: 	'KindOf: ''';
		nextPutAll:	aClass asString;
		nextPutAll: ''').';
		crtab;
		nextPutAll: (self 
						ccgLoad: aBlock 
						expr: aString 
						asRawOopFrom: anInteger)]! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 20:28'!
ccgLoad: aBlock expr: aString asMemberOf: aClass from: anInteger

	^String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy success: (interpreterProxy';
		crtab: 2;
		nextPutAll: 'is: (interpreterProxy stackValue: ';
		nextPutAll: anInteger asString;
		nextPutAll: ')';
		crtab: 2;
		nextPutAll: 	'MemberOf: ''';
		nextPutAll:	aClass asString;
		nextPutAll: ''').';
		crtab;
		nextPutAll: (self 
						ccgLoad: aBlock 
						expr: aString 
						asRawOopFrom: anInteger)]! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: exprString asNamedPtr: recordString from: anInteger
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''';
		nextPutAll: recordString;
		nextPutAll: ' *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: exprString asNamedPtr: recordString from: anInteger andThen: valBlock
	"Answer codestring for integer pointer to first indexable field of object (without validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''';
		nextPutAll: recordString;
		nextPutAll: ' *''']))! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:29'!
ccgLoad: aBlock expr: aString asNonIntegerValueFrom: anInteger
	"Answer codestring for oop (with validating side effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackObjectValue: ';
		nextPutAll: anInteger asString])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:32'!
ccgLoad: aBlock expr: aString asRawOopFrom: anInteger
	"Answer a string for a Slang expression that will load an oop (without validation) from stack index anInteger.  Apply aBlock, a BlockContext instance that when passed an expression, will return a string assigning the expression to the desired identifier, to the string before answering.  aString is a Slang expression that refers to the stack value, once it has been loaded."

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy stackValue: ';
		nextPutAll: anInteger asString])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asUnsignedPtrFrom: anInteger andThen: valBlock
	"Answer a codestring for integer pointer to first indexable field of object (without validating side-effect unless specified in valBlock), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^(valBlock value: anInteger), '.',
	 (aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy firstIndexableField:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''unsigned *''']))! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asUnsignedValueFrom: anInteger
	"Answer a codestring for positive integer coercion (with validating side-effect) of oop, as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'interpreterProxy positive32BitValueOf:';
		crtab: 2;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	')'])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBCharPtrFrom: anInteger
	"Answer codestring for char pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''char *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBFloatPtrFrom: anInteger
	"Answer codestring for single-precision float pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''float *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 12/17/1999 07:31'!
ccgLoad: aBlock expr: aString asWBIntPtrFrom: anInteger
	"Answer codestring for integer pointer to first indexable field of object (with validating side-effect), as described in comment to ccgLoad:expr:asRawOopFrom:"

	^aBlock value: (String streamContents: [:aStream | aStream
		nextPutAll: 'self cCoerce: (interpreterProxy arrayValueOf:';
		crtab: 4;
		nextPutAll: '(interpreterProxy stackValue:';
		nextPutAll: anInteger asString;
		nextPutAll:	'))';
		crtab: 3;
		nextPutAll: 'to: ''int *'''])! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/18/1999 14:27'!
ccgSetBlock: aString

	^[:expr | aString, ' _ ', expr]! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'acg 9/19/1999 13:05'!
ccgTVarBlock: anInteger

	^[:expr | '(thisContext tempAt: 1) tempAt: ', anInteger asString, ' put: (', expr, ')']! !

!TestCodeGenerator methodsFor: 'coercing' stamp: 'bf 9/24/1999 14:53'!
ccgValBlock: valString

	^[:index | String streamContents:
		[:aStream | aStream
			nextPutAll: 'interpreterProxy success: (interpreterProxy ';
			nextPutAll: valString;
			nextPutAll: ': (interpreterProxy stackValue: ';
			nextPutAll: index asString;
			nextPutAll: '))']] fixTemps! !


!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 12/25/1999 10:00'!
generateCoerceToBooleanObjectFrom: aNode on: aStream

	aStream nextPutAll: '('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: '? interpreterProxy->trueObject(): interpreterProxy->falseObject())'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:07'!
generateCoerceToBooleanValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->booleanValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToFloatObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->floatObjectOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:53'!
generateCoerceToFloatValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->floatValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 9/20/1999 23:44'!
generateCoerceToObjectFromPtr: aNode on: aStream
	"This code assumes no named instance variables"

	aStream nextPutAll: '((int) '.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ') - 4'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:57'!
generateCoerceToPtr: aString fromObject: aNode on: aStream
	"This code assumes no named instance variables"

	aStream 
		nextPutAll: '((';
		nextPutAll: aString;
		nextPutAll: ') interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: '))'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToSmallIntegerObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->integerObjectOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 05:59'!
generateCoerceToSmallIntegerValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->integerValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:03'!
generateCoerceToUnsignedObjectFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->positive32BitIntegerFor('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !

!TestCodeGenerator methodsFor: 'asOop:/asValue:' stamp: 'acg 10/5/1999 06:00'!
generateCoerceToUnsignedValueFrom: aNode on: aStream

	aStream nextPutAll: 'interpreterProxy->positive32BitValueOf('.
	self emitCExpression: aNode on: aStream.
	aStream nextPutAll: ')'! !


!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:08'!
generateAsBooleanObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: '('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: 
		') ? interpreterProxy->trueObject(): interpreterProxy->falseObject()'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCBoolean: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->booleanValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCDouble: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->floatValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 21:53'!
generateAsCInt: aNode on: aStream indent: anInteger

	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ' >> 1'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:09'!
generateAsCUnsigned: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->positive32BitValueOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsCharPtr: aNode on: aStream indent: anInteger

	aStream nextPutAll: '(char *) interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsFloatObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->floatObjectOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:21'!
generateAsIfVar: aNode on: aStream indent: anInteger

	| cName fName class index |
	cName _ String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName _ aNode args second value.
	index _ class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	aStream 
		nextPutAll: 'interpreterProxy->fetchPointerofObject(';
		nextPutAll: (index - 1) asString;
		nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:41'!
generateAsIfVarAsValue: aNode on: aStream indent: anInteger

	| cName fName class index fetchNode |
	cName _ String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName _ aNode args second value.
	index _ class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	fetchNode _ TSendNode new
		setSelector: #fetchPointer:ofObject:
		receiver: (TVariableNode new setName: 'interpreterProxy')
		arguments: (Array
			with: (TConstantNode new setValue: index - 1)
			with: aNode receiver).
	cName _ aNode args third nameOrValue.
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'third arg must identify class'].
	class ccg: self generateCoerceToValueFrom: fetchNode on: aStream
! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 2/25/2000 16:41'!
generateAsIfVarPut: aNode on: aStream indent: anInteger

	| cName fName class index |
	cName _ String streamContents: 
		[:scStr | self emitCExpression: aNode args first on: scStr].
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	fName _ aNode args second value.
	index _ class allInstVarNames
		indexOf: fName
		ifAbsent: [^self error: 'second arg must be instVar'].
	aStream 
		nextPutAll: 'interpreterProxy->storePointerofObjectwithValue(';
		nextPutAll: (index - 1) asString;
		nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args third on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsIntPtr: aNode on: aStream indent: anInteger

	aStream nextPutAll: '(int *) interpreterProxy->firstIndexableField('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/17/1999 07:23'!
generateAsOop: aNode on: aStream indent: anInteger

	| cName class |
	cName _ aNode args first nameOrValue.
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	class ccg: self generateCoerceToOopFrom: aNode receiver on: aStream! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:10'!
generateAsPositiveIntegerObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->positive32BitIntegerFor('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:47'!
generateAsSmallIntegerObj: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->integerObjectOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/17/1999 07:22'!
generateAsValue: aNode on: aStream indent: anInteger

	| cName class |
	cName _ aNode args first nameOrValue.
	class _ Smalltalk 
		at: (cName asSymbol) 
		ifAbsent: [nil].
	(class isNil not and: [class isBehavior]) ifFalse: 
		[^self error: 'first arg must identify class'].
	class ccg: self generateCoerceToValueFrom: aNode receiver on: aStream! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'TPR 4/24/2000 18:33'!
generateCPtrAsOop: aNode on: aStream indent: anInteger

	aStream nextPutAll: '((int) ('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ') -4)'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:11'!
generateClass: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->fetchClassOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'sr 4/8/2000 02:38'!
generateDebugCode: aNode on: aStream indent: level 
	"Generate the C debug code for this message onto the given stream, if  
	compiled in debugMode."
	self generateDebugCode
		ifTrue: 
			[aStream nextPutAll: '/* DebugCode... */';
			 cr.
			aNode args first
				emitCCodeOn: aStream
				level: level
				generator: self.
			aStream tab: level.
			aStream nextPutAll: '/* ...DebugCode */']
		ifFalse: [aStream nextPutAll: '/* missing DebugCode */']! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:11'!
generateField: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->fetchPointerofObject('.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 23:40'!
generateFieldPut: aNode on: aStream indent: anInteger
		
	aStream nextPutAll: 'interpreterProxy->storePointerofObjectwithValue('.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args second on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/16/1999 08:02'!
generateFromStack: aNode on: aStream indent: anInteger

	| idList |
	aNode args first isConstant ifFalse: [^self error: 'arg must be constant'].
	idList _ aNode args first value.
	(1 to: idList size)
		do: [:i | 
			aStream 
				nextPutAll: (idList at: i);
				nextPutAll: ' = interpreterProxy->stackValue(';
				nextPutAll: (idList size - i) asString;
				nextPutAll: ')']
		separatedBy: [aStream nextPut: $;; crtab: anInteger].
! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:50'!
generateIsBytes: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isBytes('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:50'!
generateIsFloat: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isFloatObject('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:49'!
generateIsIndexable: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIndexable('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 20:49'!
generateIsInteger: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerValue('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsIntegerOop: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerObject('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsIntegerValue: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isIntegerValue('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:20'!
generateIsKindOf: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isKindOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','''.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ''')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:20'!
generateIsMemberOf: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isMemberOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','''.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ''')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:14'!
generateIsPointers: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isPointers('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:14'!
generateIsWords: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isWords('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:13'!
generateIsWordsOrBytes: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->isWordsOrBytes('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/19/1999 01:56'!
generateNext: msgNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| varNode |
	varNode _ msgNode receiver.
	varNode isVariable
		ifFalse: [ self error: 'next can only be applied to variables' ].
	aStream nextPutAll: '*'.
	aStream nextPutAll: varNode name.
	aStream nextPutAll: '++'
! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 12/31/1999 16:37'!
generateRemapOopIn: aNode on: aStream indent: level
	"Generate the C code for this message onto the given stream."

	| idList |
	idList _ aNode args first nameOrValue.
	idList class == Array ifFalse: [idList _ Array with: idList].
	idList do:
		[:each | 
		 aStream 
			nextPutAll: 'interpreterProxy->pushRemappableOop(';
			nextPutAll: each asString;
			nextPutAll: ');']
		separatedBy: [aStream crtab: level].
	aStream cr.
	aNode args second emitCCodeOn: aStream level: level generator: self.
	level timesRepeat: [aStream tab].
	idList reversed do:
		[:each |
		 aStream 
			nextPutAll: each asString;
			nextPutAll: ' = interpreterProxy->popRemappableOop()']
		separatedBy: [aStream nextPut: $;; crtab: level].! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:15'!
generateStAt: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stObjectat('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ')'
! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 9/15/1999 22:17'!
generateStAtPut: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stObjectatput('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args first on: aStream.
	aStream nextPutAll: ','.
	self emitCExpression: aNode args second on: aStream.
	aStream nextPutAll: ')'
! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'acg 1/1/2000 22:41'!
generateStSize: aNode on: aStream indent: anInteger

	aStream nextPutAll: 'interpreterProxy->stSizeOf('.
	self emitCExpression: aNode receiver on: aStream.
	aStream nextPutAll: ')'.! !

!TestCodeGenerator methodsFor: 'translating builtins' stamp: 'sr 4/8/2000 00:59'!
initializeCTranslationDictionary 
	"Initialize the dictionary mapping message names to actions for C code generation."

	| pairs |
	super initializeCTranslationDictionary.
	pairs _ #(
		#asCInt						#generateAsCInt:on:indent:
		#asCUnsigned				#generateAsCUnsigned:on:indent:
		#asCBoolean					#generateAsCBoolean:on:indent:
		#asCDouble					#generateAsCDouble

		#asSmallIntegerObj			#generateAsSmallIntegerObj:on:indent:
		#asPositiveIntegerObj		#generateAsPositiveIntegerObj:on:indent:
		#asBooleanObj				#generateAsBooleanObj:on:indent:
		#asFloatObj					#generateAsFloatObj:on:indent:

		#asIf:var:					#generateAsIfVar:on:indent:
		#asIf:var:asValue:			#generateAsIfVarAsValue:on:indent:
		#asIf:var:put:				#generateAsIfVarPut:on:indent:
		#field:						#generateField:on:indent:
		#field:put:					#generateFieldPut:on:indent:
		
		#class						#generateClass:on:indent:

		#stSize						#generateStSize:on:indent:
		#stAt:						#generateStAt:on:indent:
		#stAt:put:					#generateStAtPut:on:indent:

		#asCharPtr					#generateAsCharPtr:on:indent:
		#asIntPtr					#generateAsIntPtr:on:indent:
		#cPtrAsOop					#generateCPtrAsOop:on:indent:
		#next						#generateNext:on:indent:

		#asOop:						#generateAsOop:on:indent:
		#asValue:					#generateAsValue:on:indent:

		#isFloat						#generateIsFloat:on:indent:
		#isIndexable					#generateIsIndexable:on:indent:
		#isIntegerOop				#generateIsIntegerOop:on:indent:
		#isIntegerValue				#generateIsIntegerValue:on:indent:
		#FloatOop					#generateIsFloatValue:on:indent:
		#isWords					#generateIsWords:on:indent:
		#isWordsOrBytes				#generateIsWordsOrBytes:on:indent:
		#isPointers					#generateIsPointers:on:indent:
		#isNil						#generateIsNil:on:indent:
		#isMemberOf:				#generateIsMemberOf:on:indent:
		#isKindOf:					#generateIsKindOf:on:indent:

		#fromStack:					#generateFromStack:on:indent:
		#clone						#generateClone:on:indent
		#new						#generateNew:on:indent
		#new:						#generateNewSize:on:indent
		#superclass					#generateSuperclass:on:indent:
		#remapOop:in:				#generateRemapOopIn:on:indent:
		#debugCode:					#generateDebugCode:on:indent:
	).

	1 to: pairs size by: 2 do: [:i |
		translationDict at: (pairs at: i) put: (pairs at: i + 1)].
! !


!TestCodeGenerator methodsFor: 'debug code' stamp: 'sr 4/8/2000 00:52'!
generateDebugCode
	^ debugFlag! !

!TestCodeGenerator methodsFor: 'debug code' stamp: 'sr 4/8/2000 00:52'!
generateDebugCode: aBool 
	debugFlag _ aBool! !


!TestCodeGenerator methodsFor: 'as yet unclassified' stamp: 'TPR 2/29/2000 18:14'!
translationMethodClass
	"return the class used to produce C translation methods from MethodNodes"
	^TestTMethod! !
Error subclass: #TestFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Framework'!
!TestFailure commentStamp: '<historical>' prior: 0!
Signaled in case of a failed test (failure). The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bounds ...!

Object subclass: #TestFailureErrorList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
!TestFailureErrorList commentStamp: '<historical>' prior: 0!
Represents a collection of test cases that are supposed to generate failures and errors to be able to test the generation of failures and errors to be reported in the user interfaces. If this reporting of failures and errors in the user interfaces has to be tested, TestFailureErrorList must be a subclass of TestCase.!
]style[(266 20 32)f1,f1LTestFailureErrorList Hierarchy;,f1!


!TestFailureErrorList methodsFor: 'running' stamp: 'rhi 10/29/2000 18:34'!
testError

	Error new signal.! !

!TestFailureErrorList methodsFor: 'running' stamp: 'rhi 10/29/2000 18:34'!
testErrorAndFailure

	Error new signal.
	self assert: false.! !

!TestFailureErrorList methodsFor: 'running' stamp: 'rhi 2/5/2000 12:45'!
testFailure

	self assert: false.! !

!TestFailureErrorList methodsFor: 'running' stamp: 'rhi 10/29/2000 18:34'!
testFailureAndError

	self assert: false.
	Error new signal.! !
Model subclass: #TestInterfaceBase
	instanceVariableNames: 'result duration classPattern selectorPattern '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Interface'!
!TestInterfaceBase commentStamp: '<historical>' prior: 0!
ABSTRACT base class for user interfaces to the SUnit framework.

Instance Variables:
	result			<TestResult>
	classPattern		<String>
	selectorPattern	<String>
	duration		<Integer> [ms]!
]style[(47 1 1 3 44 10 18 6 20 6 14 7 6)f1,f1cgreen;b,f1cred;b,f1bcblack;,f1,f1LTestResult Hierarchy;,f1,f1LString Hierarchy;,f1,f1LString Hierarchy;,f1,f1LInteger Hierarchy;,f1!


!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 12/26/1999 11:25'!
classPattern

	^classPattern! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 2/5/2000 12:41'!
classPattern: aString

	classPattern := aString.! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 12/26/1999 11:24'!
duration
	^duration! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 2/5/2000 12:41'!
duration: anInteger

	duration := anInteger.! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 12/26/1999 11:24'!
result

	^result! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 2/5/2000 12:41'!
result: aTestResult

	result := aTestResult.! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 12/26/1999 11:25'!
selectorPattern

	^selectorPattern! !

!TestInterfaceBase methodsFor: 'accessing' stamp: 'rhi 2/5/2000 12:41'!
selectorPattern: aString

	selectorPattern := aString.! !


!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 12/26/1999 11:32'!
classSelectorDelimiters

	^self class classSelectorDelimiters! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 12/26/1999 11:32'!
defaultClassPattern

	^self class defaultClassPattern! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 12/26/1999 11:32'!
defaultClassSelectorDelimiter

	^self class defaultClassSelectorDelimiter! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 12/26/1999 11:32'!
defaultSelectorPattern

	^self class defaultSelectorPattern! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:20'!
failureMessage

	^self class failureMessage! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:22'!
successMessage

	^self class successMessage! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:17'!
version

	^self class version! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:17'!
versionDate

	^self class versionDate! !

!TestInterfaceBase methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:17'!
versionName

	^self class versionName! !


!TestInterfaceBase methodsFor: 'initialize-release' stamp: 'rhi 2/5/2000 12:41'!
initialize

	self
		result: TestResult new;
		classPattern: self defaultClassPattern;
		selectorPattern: self defaultSelectorPattern;
		duration: 0.! !


!TestInterfaceBase methodsFor: 'test patterns' stamp: 'rhi 1/21/2000 21:55'!
classPatternFrom: aString

	| tokens |
	tokens := aString findTokens: self classSelectorDelimiters.
	^tokens isEmpty
		ifTrue: [self defaultClassPattern]
		ifFalse: [
			| newClassPattern |
			newClassPattern := tokens first.
			(self matchingClassesForPattern: newClassPattern) isEmpty
				ifFalse: [newClassPattern]
				ifTrue: [self defaultClassPattern]]! !

!TestInterfaceBase methodsFor: 'test patterns' stamp: 'rhi 12/26/1999 11:29'!
matchingClasses

	^self matchingClassesForPattern: self classPattern! !

!TestInterfaceBase methodsFor: 'test patterns' stamp: 'rhi 12/26/1999 11:29'!
matchingClassesForPattern: aString

	^TestCase allSubclasses select: [:class |
		aString match: class name]! !

!TestInterfaceBase methodsFor: 'test patterns' stamp: 'rhi 1/21/2000 21:55'!
selectorPatternFrom: aString

	| tokens |
	tokens := aString findTokens: self classSelectorDelimiters.
	^(tokens isEmpty not and: [tokens size >= 2])
		ifFalse: [self defaultSelectorPattern]
		ifTrue: [
			| selPattern |
			selPattern := tokens at: 2.
			(self defaultSelectorPattern match: selPattern)
				ifTrue: [selPattern]
				ifFalse: [self defaultSelectorPattern]]! !


!TestInterfaceBase methodsFor: 'test processing' stamp: 'rhi 4/26/2000 08:07'!
runTests

	"Cursor wait showWhile: [
		self duration: (Time millisecondsToRun: [self result: self suite run])].
	self showResult"

	| saveCursor |
	self flag: #exceptionsProblem. "Eventually switch back to Cursor wait showWhile: [...]"
	saveCursor := Cursor currentCursor.
	Cursor wait show.
	self
		duration: (Time millisecondsToRun: [self result: self suite run]);
		showResult.
	saveCursor show.! !

!TestInterfaceBase methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:42'!
showResult

	self subclassResponsibility.! !

!TestInterfaceBase methodsFor: 'test processing' stamp: 'rhi 12/26/1999 11:54'!
suite

	| suite |
	suite := TestSuite new.
	self matchingClasses do: [:class |
		| matchingSelectors |
		matchingSelectors := class selectors select: [:selector |
			self selectorPattern match: selector].
		matchingSelectors do: [:selector |
			suite addTest: (class selector: selector)]].
	^suite! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestInterfaceBase class
	instanceVariableNames: ''!

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:47'!
classSelectorDelimiters

	^'. |' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:47'!
defaultClassPattern

	^'*' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:10'!
defaultClassSelectorDelimiter

	^self classSelectorDelimiters first asString! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:47'!
defaultSelectorPattern

	^'test*' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:47'!
failureMessage

	^'*** FAIL ***' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:48'!
successMessage

	^'*** PASS ***' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:06'!
version
	"printIt: [TestInterfaceBase version]"

	^self versionName, ' ', self versionDate! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 6/14/2000 11:00'!
versionDate

	^'14 June 2000' copy! !

!TestInterfaceBase class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:48'!
versionName

	^'SUnit 2' copy! !


!TestInterfaceBase class methodsFor: 'instance creation' stamp: 'rhi 12/26/1999 11:41'!
new

	^super new initialize! !
InterpreterPlugin subclass: #TestInterpreterPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!TestInterpreterPlugin commentStamp: '<historical>' prior: 0!
Subclass of InterpreterPlugin, used in connection with TestCodeGenerator for named primitives with type coercion specifications!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestInterpreterPlugin class
	instanceVariableNames: ''!

!TestInterpreterPlugin class methodsFor: 'translation' stamp: 'sr 6/9/2000 03:04'!
translate: fileName doInlining: inlineFlag debug: debugFlag 
	^ self translate: fileName doInlining: inlineFlag locally: false debug: debugFlag 
! !

!TestInterpreterPlugin class methodsFor: 'translation' stamp: 'sr 4/8/2000 01:14'!
translateDoInlining: inlineFlag debug: debugFlag 
	^ self
		translate: self moduleName , '.c'
		doInlining: inlineFlag
		debug: debugFlag! !


!TestInterpreterPlugin class methodsFor: 'instance creation' stamp: 'acg 9/19/1999 14:09'!
doPrimitive: primitiveName withArguments: argArray
	| proxy plugin |
	proxy _ InterpreterProxy new.
	proxy loadStackFrom: thisContext sender.
	plugin _ self simulatorClass new.
	plugin setInterpreter: proxy.
	^plugin perform: primitiveName asSymbol withArguments: argArray! !


!TestInterpreterPlugin class methodsFor: 'private' stamp: 'TPR 2/29/2000 18:54'!
codeGeneratorClass
	"return the appropriate class of code generator for this kind ofplugin"

	^TestCodeGenerator! !

!TestInterpreterPlugin class methodsFor: 'private' stamp: 'acg 9/16/1999 19:58'!
generateVMProxyOn: fileName
	| cg proxyClass catList |
	proxyClass _ InterpreterProxy.
	cg _ TestCodeGenerator new initialize.
	cg addClass: proxyClass.
	catList _ proxyClass organization categories copy asOrderedCollection.
	catList remove: 'initialize' ifAbsent:[].
	catList remove: 'private' ifAbsent:[].
	catList _ catList collect:[:cat| cat -> (proxyClass organization listAtCategoryNamed: cat)].
	cg storeVirtualMachineProxyHeader: catList on: (fileName,'.h').
	cg storeVirtualMachineProxyImplementation: catList on: (fileName,'.c').

	"InterpreterProxy generateVMProxyOn:'sqVirtualMachine'"
! !


!TestInterpreterPlugin class methodsFor: 'as yet unclassified' stamp: 'sr 6/9/2000 03:03'!
translate: fileName doInlining: inlineFlag locally: localFlag debug: debugFlag
	"Time millisecondsToRun: [
		FloatArrayPlugin translate: 'SqFloatArray.c' doInlining: true.
		Smalltalk beep]"
	| cg theClass fullName fd |
	fullName _ self baseDirectoryName.
	fd _ FileDirectory on: fullName.
	localFlag ifFalse:[
		(fd directoryExists: self moduleName) 
			ifFalse:[fd createDirectory: self moduleName].
		fd _ fd on: (fd fullNameFor: self moduleName)].
	fullName _ fd fullNameFor: fileName.
	self initialize.
	self headerFile ifNotNil:[
		(CrLfFileStream newFileNamed: (fd fullNameFor: self moduleName,'.h'))
			nextPutAll: self headerFile;
			close].
	cg _ self codeGeneratorClass new initialize.
	cg generateDebugCode: debugFlag.
	localFlag ifTrue:[cg pluginPrefix: self moduleName].
	"Add an extra declaration for module name"
	cg declareModuleName: self moduleNameAndVersion local: localFlag.

	theClass _ self.
	[theClass == Object] whileFalse:[
		cg addClass: theClass.
		theClass declareCVarsIn: cg.
		theClass _ theClass superclass].
	cg storeCodeOnFile: fullName doInlining: inlineFlag.
	^cg! !
TestInterfaceBase subclass: #TestModel
	instanceVariableNames: 'summaryText detailsText failureList errorList patternHistory summaryTextM summaryTextV updateColorSelector patternTextM patternTextV '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Interface'!
!TestModel commentStamp: '<historical>' prior: 0!
A simple graphical user interface to run all the test cases that exist in this image within the SUnit framework by Kent Beck and Erich Gamma (SUnit release 2, November 1998). A window can be opened via TestModel openAsMorph in a morphic environment, or via TestModel open in a MVC environment. A selection pattern history keeps track of all valid patterns used. The pattern history as well as its management operations are accessible via the yellow button menu of the pattern text entry field.

Instance Variables:
	summaryText		<String>
	detailsText			<String>
	failureList			<OrderedCollection of: String>
	errorList			<OrderedCollection of: String>
	patternHistory		<OrderedCollection of: String>
	summaryTextM		<PluggableTextMorph | nil>
	summaryTextV		<PluggableTextView | nil>
	updateColorSelector	<Symbol>
	patternTextM		<PluggableTextMorph | nil>
	patternTextV		<PluggableTextView | nil>!
]style[(96 1 1 3 12 31 58 21 34 14 259 6 18 6 18 17 5 6 16 17 5 6 20 17 5 6 18 18 24 17 30 6 18 18 24 17 7)f1,f1cgreen;b,f1cred;b,f1bcblack;,f1,f1cblack;,f1,f1dTestModel openAsMorph;;,f1,f1dTestModel open;;,f1,f1LString Hierarchy;,f1,f1LString Hierarchy;,f1,f1LOrderedCollection Hierarchy;,f1,f1LString Hierarchy;,f1,f1LOrderedCollection Hierarchy;,f1,f1LString Hierarchy;,f1,f1LOrderedCollection Hierarchy;,f1,f1LString Hierarchy;,f1,f1LPluggableTextMorph Hierarchy;,f1,f1LPluggableTextView Hierarchy;,f1,f1LSymbol Hierarchy;,f1,f1LPluggableTextMorph Hierarchy;,f1,f1LPluggableTextView Hierarchy;,f1!


!TestModel methodsFor: 'accessing' stamp: 'rhi 5/23/1999 22:25'!
detailsText

	^detailsText! !

!TestModel methodsFor: 'accessing' stamp: 'rhi 5/23/1999 23:36'!
errorList

	^errorList! !

!TestModel methodsFor: 'accessing' stamp: 'rhi 5/23/1999 23:36'!
failureList

	^failureList! !

!TestModel methodsFor: 'accessing' stamp: 'rhi 5/23/1999 22:25'!
summaryText

	^summaryText! !


!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:24'!
balloonDetailsText

	^self class balloonDetailsText! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:24'!
balloonErrorList

	^self class balloonErrorList! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:24'!
balloonFailureList

	^self class balloonFailureList! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:25'!
balloonPatternText

	^self class balloonPatternText! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:25'!
balloonRunButton

	^self class balloonRunButton! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:25'!
balloonSummaryText

	^self class balloonSummaryText! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 13:47'!
failureColor

	^self class failureColor! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 13:47'!
runButtonColor

	^self class runButtonColor! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 13:01'!
runButtonLabel

	^self class runButtonLabel! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 13:02'!
runButtonState

	^self class runButtonState! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 13:47'!
successColor

	^self class successColor! !

!TestModel methodsFor: 'constants' stamp: 'rhi 5/24/1999 19:43'!
windowLabel

	^self class windowLabel! !


!TestModel methodsFor: 'derived accessing' stamp: 'rhi 5/24/1999 00:23'!
errorListSelectionIndex

	^0! !

!TestModel methodsFor: 'derived accessing' stamp: 'rhi 2/5/2000 12:42'!
errorListSelectionIndex: anInteger

	(anInteger ~= 0)
		ifTrue: [(self result errors at: anInteger) debug].! !

!TestModel methodsFor: 'derived accessing' stamp: 'rhi 5/24/1999 00:23'!
failureListSelectionIndex

	^0! !

!TestModel methodsFor: 'derived accessing' stamp: 'rhi 2/5/2000 12:42'!
failureListSelectionIndex: anInteger

	(anInteger ~= 0)
		ifTrue: [(self result failures at: anInteger) debug].! !

!TestModel methodsFor: 'derived accessing' stamp: 'rhi 12/26/1999 08:33'!
patternText

	^self classPattern, self defaultClassSelectorDelimiter, self selectorPattern! !

!TestModel methodsFor: 'derived accessing' stamp: 'rhi 5/5/2000 13:26'!
patternText: aTextOrString

	| patternInput |
	patternInput := aTextOrString asString.
	self
		classPattern: (self classPatternFrom: patternInput);
		selectorPattern: (self selectorPatternFrom: patternInput);
		updatePatternHistory;
		changed: #patternText.
	^true! !


!TestModel methodsFor: 'initialize-release' stamp: 'rhi 5/5/2000 13:28'!
initialize

	super initialize.
	self
		summaryText: String new;
		detailsText: String new;
		failureList: OrderedCollection new;
		errorList: OrderedCollection new;
		patternHistory: OrderedCollection new;
		summaryTextM: nil;
		summaryTextV: nil;
		updateColorSelector: nil;
		patternTextM: nil;
		patternTextV: nil.! !


!TestModel methodsFor: 'interface opening' stamp: 'rhi 5/5/2000 13:31'!
open
	"doIt: [TestModel new open]"

	| topWindowV runButtonV detailsTextV failureListV errorListV |

	self updateColorSelector: #updateColorV.

	"=== build the parts ... ==="
	(topWindowV := StandardSystemView new)
		label: self windowLabel;
		model: self.
	self patternTextV: (PluggableTextView
		on: self
		text: #patternText
		accept: #patternText:
		readSelection: nil
		menu: #patternHistoryMenuMVC:).
	runButtonV := PluggableButtonView
		on: self
		getState: #runButtonState
		action: #runTests
		label: #runButtonLabel.
	runButtonV
		label: self runButtonLabel;
		insideColor: self runButtonColor.
	self summaryTextV: (PluggableTextView
		on: self
		text: #summaryText
		accept: nil).
	detailsTextV := PluggableTextView on: self
		text: #detailsText
		accept: nil.
	failureListV := PluggableListView
		on: self
		list: #failureList
		selected: #failureListSelectionIndex
		changeSelected: #failureListSelectionIndex:.
	errorListV := PluggableListView
		on: self
		list: #errorList
		selected: #errorListSelectionIndex
		changeSelected: #errorListSelectionIndex:.

	"=== size the parts ... ==="
	self patternTextV
		borderWidth: 1;
		window: (0@0 corner: 100@10). "(0.0@0.0 extent: 1.0@0.1)"
	runButtonV
		borderWidth: 1;
		window: (0@0 corner: 20@10). "(0.0@0.1 extent: 0.2@0.1)"
	self summaryTextV
		borderWidth: 1;
		window: (0@0 corner: 80@10). "(0.2@0.1 extent: 0.8@0.1)"
	detailsTextV
		borderWidth: 1;
		window: (0@0 corner: 100@10). "(0.0@0.2 extent: 1.0@0.1)"
	failureListV
		borderWidth: 1;
		window: (0@0 corner: 100@35). "(0.0@0.3 extent: 1.0@0.35)"
	errorListV
		borderWidth: 1;
		window: (0@0 corner: 100@35). "(0.0@0.65 extent: 1.0@0.35)"

	"=== assemble the whole ... ==="
	topWindowV
		addSubView: self patternTextV;
		addSubView: runButtonV below: self patternTextV;
		addSubView: self summaryTextV toRightOf: runButtonV;
		addSubView: detailsTextV below: runButtonV;
		addSubView: failureListV below: detailsTextV;
		addSubView: errorListV below: failureListV.

	"=== open it ... ==="
	topWindowV minimumSize: 200@200.
	topWindowV maximumSize: 250@200.
	topWindowV controller open.! !

!TestModel methodsFor: 'interface opening' stamp: 'RAA 1/17/2001 14:33'!
openAsMorph
	"doIt: [TestModel new openAsMorph]"

	| topWindowM runButtonM detailsTextM failureListM errorListM |

	self updateColorSelector: #updateColorM.

	"=== build the parts ... ==="
	(topWindowM := SystemWindow labelled: self windowLabel)
		model: self.
	self patternTextM: (PluggableTextMorph
		on: self
		text: #patternText
		accept: #patternText:
		readSelection: nil
		menu: #patternHistoryMenu:).
	self patternTextM setBalloonText: self balloonPatternText.
	runButtonM := PluggableButtonMorph
		on: self
		getState: #runButtonState
		action: #runTests
		label: #runButtonLabel.
	runButtonM
		hResizing: #spaceFill;
		vResizing: #spaceFill;
		onColor: self runButtonColor
		offColor: self runButtonColor.
	runButtonM setBalloonText: self balloonRunButton.
	self summaryTextM: (PluggableTextMorph
		on: self
		text: #summaryText
		accept: nil).
	self summaryTextM setBalloonText: self balloonSummaryText.
	detailsTextM := PluggableTextMorph
		on: self
		text: #detailsText
		accept: nil.
	detailsTextM setBalloonText: self balloonDetailsText.
	failureListM := PluggableListMorph
		on: self
		list: #failureList
		selected: #failureListSelectionIndex
		changeSelected: #failureListSelectionIndex:.
	failureListM setBalloonText: self balloonFailureList.
	errorListM := PluggableListMorph
		on: self
		list: #errorList
		selected: #errorListSelectionIndex
		changeSelected: #errorListSelectionIndex:.
	errorListM setBalloonText: self balloonErrorList.

	"=== assemble the whole ... ==="
	topWindowM
		addMorph: self patternTextM frame: (0.0@0.0 extent: 1.0@0.1);
		addMorph: runButtonM frame: (0.0@0.1 extent: 0.2@0.1);
		addMorph: self summaryTextM frame: (0.2@0.1 extent: 0.8@0.1);
		addMorph: detailsTextM frame: (0.0@0.2 extent: 1.0@0.1);
		addMorph: failureListM frame: (0.0@0.3 extent: 1.0@0.35);
		addMorph: errorListM frame: (0.0@0.65 extent: 1.0@0.35).

	"=== open it ... ==="
	topWindowM openInWorldExtent: 250@200.
	^topWindowM! !


!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:43'!
detailsText: aString

	(detailsText = aString)
		ifFalse: [
			detailsText := aString.
			self changed: #detailsText].! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
errorList: anOrderedCollection

	(errorList = anOrderedCollection)
		ifFalse: [
			errorList := anOrderedCollection.
			self changed: #errorList].! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
failureList: anOrderedCollection

	(failureList = anOrderedCollection)
		ifFalse: [
			failureList := anOrderedCollection.
			self changed: #failureList].! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 5/5/2000 13:21'!
patternHistory

	^patternHistory! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 5/5/2000 13:22'!
patternHistory: anOrderedCollection
	patternHistory := anOrderedCollection.! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 12/26/1999 07:04'!
patternTextM

	^patternTextM! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
patternTextM: aPluggableTextMorph

	patternTextM := aPluggableTextMorph.! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 12/26/1999 07:06'!
patternTextV

	^patternTextV! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
patternTextV: aPluggableTextView

	patternTextV := aPluggableTextView.! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
summaryText: aString

	(summaryText = aString)
		ifFalse: [
			summaryText := aString.
			self changed: #summaryText].! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 5/24/1999 12:48'!
summaryTextM

	^summaryTextM! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
summaryTextM: aPluggableTextMorph

	summaryTextM := aPluggableTextMorph.! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 5/24/1999 21:36'!
summaryTextV

	^summaryTextV! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
summaryTextV: aPluggableTextView

	summaryTextV := aPluggableTextView.! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 5/24/1999 22:37'!
updateColorSelector

	^updateColorSelector! !

!TestModel methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:44'!
updateColorSelector: aSymbol

	updateColorSelector := aSymbol.! !


!TestModel methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:43'!
showResult

	self
		updateColor;
		updateText;
		updateLists.! !

!TestModel methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:43'!
updateColor

	self perform: self updateColorSelector.! !

!TestModel methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:43'!
updateColorM

	self summaryTextM color: ((self result runCount = self result correctCount)
		ifTrue: [self successColor]
		ifFalse: [self failureColor]).! !

!TestModel methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:43'!
updateColorV

	self summaryTextV insideColor: ((self result runCount = self result correctCount)
		ifTrue: [self successColor]
		ifFalse: [self failureColor]).! !

!TestModel methodsFor: 'test processing' stamp: 'rhi 10/23/1999 01:40'!
updateLists

	self failureList: (self result failures collect: [:failure |
		failure printString]).
	self errorList: (self result errors collect: [:error |
		error printString]).! !

!TestModel methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:43'!
updateText

	self summaryText: ((self result runCount = self result correctCount)
		ifTrue: [self successMessage]
		ifFalse: [self failureMessage]).
	self detailsText:
		self result runCount printString, ' run, ' ,
		self result failureCount printString, ' failed, ',
		self result errorCount printString, ' errors (',
		self duration printString, ' ms)'.! !


!TestModel methodsFor: 'menus' stamp: 'rhi 4/27/2000 11:19'!
perform: selector orSendTo: otherTarget

	(#(	#alphabetizePatternHistory
		#cleanUpPatternHistory
		#emptyPatternHistory
		#acceptNewPattern) includes: selector)
			ifTrue: [self perform: selector]
			ifFalse: [self patternText: selector].! !


!TestModel methodsFor: 'patterns menu' stamp: 'rhi 4/27/2000 09:40'!
patternHistoryMenu: aMenuMorph

	self patternHistory isEmpty
		ifFalse: [
			"aMenuMorph addTitle: 'Selection Patterns'."
			self patternHistory do: [:each |
				aMenuMorph add: each selector: #patternText: argument: each].
			aMenuMorph
				addLine;
				add: 'alphabetize list' selector: #alphabetizePatternHistory argument: nil;
				add: 'clean-up list' selector: #cleanUpPatternHistory argument: nil;
				add: 'empty list' selector: #emptyPatternHistory argument: nil;
				addLine].
	aMenuMorph add: 'accept pattern (s)' selector: #acceptNewPattern argument: nil.
	^aMenuMorph! !

!TestModel methodsFor: 'patterns menu' stamp: 'rhi 4/27/2000 12:28'!
patternHistoryMenuMVC: aCustomMenu

	self patternHistory isEmpty
		ifFalse: [
			"aCustomMenu title: 'Selection Patterns'."
			self patternHistory do: [:each |
				aCustomMenu add: each action: each].
			aCustomMenu
				addLine;
				add: 'alphabetize list' action: #alphabetizePatternHistory;
				add: 'clean-up list' action: #cleanUpPatternHistory;
				add: 'empty list' action: #emptyPatternHistory;
				addLine].
	aCustomMenu add: 'accept pattern (s)' action: #acceptNewPattern.
	^aCustomMenu! !


!TestModel methodsFor: 'test patterns' stamp: 'rhi 4/27/2000 12:13'!
acceptNewPattern

	(Smalltalk isMorphic)
		ifTrue: [self patternTextM accept]
		ifFalse: [self patternTextV controller accept].! !

!TestModel methodsFor: 'test patterns' stamp: 'rhi 2/5/2000 12:45'!
alphabetizePatternHistory

	self patternHistory: self patternHistory asSortedCollection asOrderedCollection.! !

!TestModel methodsFor: 'test patterns' stamp: 'rhi 4/28/2000 03:32'!
cleanUpPatternHistory

	self patternHistory: (self patternHistory select: [:each |
		((self classPatternFrom: each) ~= self defaultClassPattern)
			or: [(self selectorPatternFrom: each) ~= self defaultSelectorPattern]]).! !

!TestModel methodsFor: 'test patterns' stamp: 'rhi 2/5/2000 12:45'!
emptyPatternHistory

	self patternHistory: OrderedCollection new.! !

!TestModel methodsFor: 'test patterns' stamp: 'rhi 2/5/2000 12:45'!
updatePatternHistory

	(self patternHistory includes: self patternText)
		ifFalse: [self patternHistory add: self patternText].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestModel class
	instanceVariableNames: ''!

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:23'!
balloonDetailsText

	^'Detailed summary of tests processed.' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:23'!
balloonErrorList

	^'Tests with unexpected errors. SELECT to debug!!' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:23'!
balloonFailureList

	^'Failed tests. SELECT to debug!!' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:23'!
balloonPatternText

	^'ENTER and ACCEPT test selection pattern!! USE yellow mouse button for pattern history!!' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:23'!
balloonRunButton

	^'START processing of matching tests!!' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/5/2000 13:24'!
balloonSummaryText

	^'Summary of tests processed.' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/24/1999 12:58'!
failureColor

	^Color red! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/24/1999 12:59'!
runButtonColor

	^Color yellow! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 4/26/2000 07:48'!
runButtonLabel

	^'RUN!!' copy! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/24/1999 22:51'!
runButtonState

	^true! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 5/24/1999 12:59'!
successColor

	^Color green! !

!TestModel class methodsFor: 'constants' stamp: 'rhi 1/16/2000 10:08'!
windowLabel

	^self versionName! !


!TestModel class methodsFor: 'documentation' stamp: 'rhi 2/5/2000 12:40'!
testModelUsage
	"Please see the class comment for some documentation.

	Documentation links:
		* TestingFrameworkPaper
		* TestModel
		* TestRunner"

	self error: 'comment only'.!
]style[(14 83 21 5 9 5 10 31)f1b,f1,f1LTestingFrameworkPaper Comment;,f1,f1LTestModel Comment;,f1,f1LTestRunner Comment;,f1! !


!TestModel class methodsFor: 'interface opening' stamp: 'rhi 5/24/1999 21:55'!
open
	"doIt: [TestModel open]"

	^self new open! !

!TestModel class methodsFor: 'interface opening' stamp: 'rhi 5/23/1999 23:27'!
openAsMorph
	"doIt: [TestModel openAsMorph]"

	^self new openAsMorph! !
TestInterpreterPlugin subclass: #TestOSAPlugin
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-Plugins'!
!TestOSAPlugin commentStamp: '<historical>' prior: 0!
I am the Plugin for the Squeak/Applescript Interface.

A new 'TestOSAPlugin.c' file can be created by executing the following doIt:

	TestOSAPlugin translate

The support header files necessary for compiling the plugin can be generated by excecuting the following doIt:

	InterpreterSupportCode writePluginSupportFiles!


!TestOSAPlugin methodsFor: 'Gen''l Mac OS prims' stamp: 'acg 9/20/1999 12:56'!
primGetHandleSize: anIndex

	|rcvr|
	rcvr _ self	primitive: 'primGetHandleSize'
				parameters: #(SmallInteger)
				receiver:	#WordArray.
	^(self
		cCode: 'GetHandleSize((Handle) *(rcvr+anIndex))'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !


!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/23/1999 22:49'!
primAECoerceDesc: typeCode to: result

	|rcvr |
	rcvr _ self 	primitive: 	'primAECoerceDesc'
				parameters:	#(DescType AEDesc)
				receiver:	#AEDesc.
	^(self 
		cCode: 'AECoerceDesc(rcvr,*typeCode,result)'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 12:37'!
primAECreateDesc: typeCode from: aString

	|rcvr size |
	rcvr _ self 	primitive: 	'primAECreateDesc'
				parameters:	#(DescType String)
				receiver:	#AEDesc.
	size _ aString size.
	^(self 
		cCode: 'AECreateDesc(*typeCode, aString, size, rcvr)'
		inSmalltalk: [[rcvr. size]. -1]) asOop: Unsigned
! !

!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 14:16'!
primAEDescToString: aString

	| rcvr size |
	rcvr _ self	primitive: 	'primAEDescToString'
				parameters: #(String)
				receiver: #AEDesc.
	size _ aString size.
	self cCode: 'BlockMove(*(rcvr->dataHandle), aString, size)'
		 inSmalltalk: [rcvr. size].
	^aString asOop: String

! !

!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/20/1999 12:38'!
primAEDisposeDesc
	
	|rcvr|
	rcvr _	self	primitive: 	'primAEDisposeDesc'
				parameters:	#()
				receiver: 	#AEDesc.
	^(self 
		cCode: 'AEDisposeDesc(rcvr)'
		inSmalltalk: [[rcvr]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'AppleEvents prims' stamp: 'acg 9/23/1999 22:37'!
primAEGetKeyPtr: key type: type actual: ignoreDesc to: bytes

	| rcvr size ignoreSize |
	self var: #ignoreSize declareC: 'Size ignoreSize'.
	rcvr _ self	primitive: 	'primAEGetKeyPtr'
				parameters: #(DescType DescType DescType ByteArray)
				receiver: #AEDesc.
	size _ ignoreSize _ bytes size.
	^(self cCode: 'AEGetKeyPtr(rcvr, *key, *type, ignoreDesc, bytes, size, &ignoreSize)'
		 inSmalltalk: [[rcvr. size. ignoreSize]. -1]) asOop: Unsigned! !


!TestOSAPlugin methodsFor: 'Component Mgr prims' stamp: 'acg 9/20/1999 23:42'!
primOpenDefaultConfiguration: type subtype: subtype

	| component |
	component _ self	primitive: 	'primOpenDefaultConfiguration'
						parameters: #(DescType DescType)
						receiver:	#ComponentInstance.
	self	cCode: '*component = OpenDefaultComponent(*type,*subtype)'
		inSmalltalk: [component at: 0 put: 0].
	^component asOop: ComponentInstance! !


!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:08'!
primOSACompile: source mode: mode to: object

	|component|
	component _ self primitive: 	'primOSACompile'
					parameters: #(AEDesc SmallInteger OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSACompile(*component,source,mode,object)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:08'!
primOSADisplay: source as: type mode: mode to: result

	|component|
	component _ self primitive: 	'primOSADisplay'
					parameters: #(OSAID DescType SmallInteger AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSADisplay(*component,*source,*type,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 15:39'!
primOSADispose: anOSAID

	|component|
	component _ self primitive: 	'primOSADispose'
					parameters: #(OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSADispose(*component,*anOSAID)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:09'!
primOSADoScript: source in: context mode: mode resultType: type to: result

	|component|
	component _ self primitive: 	'primOSADoScript'
					parameters: #(AEDesc OSAID SmallInteger DescType AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSADoScript(*component,source,*context,*type,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 16:06'!
primOSAExecute: script in: context mode: mode to: result

	|component|
	component _ self primitive: 	'primOSAExecute'
					parameters: #(OSAID OSAID SmallInteger OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAExecute(*component,*script,*context,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 15:01'!
primOSAGetScriptInfo: aScriptID type: aDescType to: resultData

	|component|
	component _ self	primitive: 	'primOSAGetScriptInfo'
						parameters: #(OSAID DescType IntegerArray)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAGetScriptInfo(*component,*aScriptID,*aDescType, (long *)resultData)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 17:25'!
primOSAGetSource: aScriptID type: aDescType to: resultData

	|component|
	component _ self	primitive: 	'primOSAGetSource'
						parameters: #(OSAID DescType AEDesc)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAGetSource(*component,*aScriptID,*aDescType, resultData)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/22/1999 03:08'!
primOSALoad: source mode: mode to: result

	|component|
	component _ self primitive: 	'primOSALoad'
					parameters: #(AEDesc SmallInteger OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSALoad(*component,source,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/25/1999 22:55'!
primOSAMakeContext: name parent: parent to: result

	|component|
	component _ self primitive: 	#primOSAMakeContext
					parameters: #(AEDesc OSAID OSAID)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAMakeContext(*component,name,*parent,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/23/1999 20:39'!
primOSAScriptError: selector type: type to: result

	|component|
	component _ self primitive: 	'primOSAScriptError'
					parameters: #(DescType DescType AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAScriptError(*component,*selector,*type,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/20/1999 21:53'!
primOSAScriptingComponentNameTo: anAEDesc

	|component|
	component _ self	primitive: 	'primOSAScriptingComponentName'
						parameters: #(AEDesc)
						receiver:	#ComponentInstance.
	
	^(self cCode: 'OSAScriptingComponentName(*component,anAEDesc)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

!TestOSAPlugin methodsFor: 'OSA prims' stamp: 'acg 9/22/1999 07:51'!
primOSAStore: source resultType: type mode: mode to: result

	|component|
	component _ self primitive: 	#primOSAStore
					parameters: #(OSAID DescType SmallInteger AEDesc)
					receiver:	#ComponentInstance.

	^(self cCode: 'OSAStore(*component,*source,*type,mode,result)'
			inSmalltalk: [[component]. -1]) asOop: Unsigned! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestOSAPlugin class
	instanceVariableNames: ''!

!TestOSAPlugin class methodsFor: 'as yet unclassified' stamp: 'acg 9/21/1999 01:29'!
declareCVarsIn: cg

	cg addHeaderFile: '<AppleEvents.h>'.
	cg addHeaderFile: '<AppleScript.h>'.
	cg addHeaderFile: '<OSA.h>'.
	cg addHeaderFile: '<OSAGeneric.h>'.
	cg addHeaderFile: '<Script.h>'.! !
Object subclass: #TestResult
	instanceVariableNames: 'runCount failures errors '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Framework'!
!TestResult commentStamp: '<historical>' prior: 0!
Collects the results of executing a test case. The test framework distinguishes between failures and errors. A failure is anticipated and checked for with assertions. Errors are unanticipated problems like a division by 0 or an index out of bound ...

Instance Variables:
	runCount	<SmallInteger>
	failures		<OrderedCollection of: TestCase>
	errors		<OrderedCollection of: TestCase>!
]style[(283 12 14 17 5 8 12 17 5 8 1)f1,f1LSmallInteger Hierarchy;,f1,f1LOrderedCollection Hierarchy;,f1,f1LTestCase Hierarchy;,f1,f1LOrderedCollection Hierarchy;,f1,f1LTestCase Hierarchy;,f1!


!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:31'!
correctCount

	^self runCount - self failureCount - self errorCount! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:46'!
defects

	^self errors, self failures! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 13:44'!
errorCount

	^self errors size! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:46'!
errors

	^errors! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:42'!
failureCount

	^self failures size! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:46'!
failures

	^failures! !

!TestResult methodsFor: 'accessing' stamp: 'rhi 5/22/1999 13:45'!
runCount

	^runCount! !


!TestResult methodsFor: 'exceptions' stamp: 'rhi 10/23/1999 01:26'!
testFailureException

	^self class testFailureException! !


!TestResult methodsFor: 'initialize-release' stamp: 'rhi 2/5/2000 12:38'!
initialize

	self
		runCount: 0;
		failures: OrderedCollection new;
		errors: OrderedCollection new.! !


!TestResult methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:39'!
errors: anOrderedCollection

	errors := anOrderedCollection.! !

!TestResult methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:39'!
failures: anOrderedCollection

	failures := anOrderedCollection.! !

!TestResult methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:39'!
runCount: aSmallInteger

	runCount := aSmallInteger.! !


!TestResult methodsFor: 'running' stamp: 'rhi 2/5/2000 12:39'!
runCase: aTestCase

	self runCount: self runCount + 1.
	[[aTestCase runCase]		on: self testFailureException do: [:ex |
			self failures add: aTestCase]]
		on: Error do: [:ex |
			self errors add: aTestCase].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestResult class
	instanceVariableNames: ''!

!TestResult class methodsFor: 'exceptions' stamp: 'rhi 10/23/1999 01:09'!
testFailureException

	^TestFailure! !


!TestResult class methodsFor: 'instance creation' stamp: 'rhi 5/22/1999 13:46'!
new

	^super new initialize! !
TestInterfaceBase subclass: #TestRunner
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Interface'!
!TestRunner commentStamp: '<historical>' prior: 0!
A simple text-based user interface to run all the test cases that exist in this image within the SUnit framework by Kent Beck and Erich Gamma (SUnit release 2, November 1998). The tests can be executed via TestRunner runTests or TestRunner runTests: '* test*'. The test results appear in the Transcript window.!
]style[(97 1 1 3 13 33 58 19 4 30 51)f1,f1cgreen;b,f1cred;b,f1bcblack;,f1,f1cblack;,f1,f1dTestRunner runTests;;,f1,f1dTestRunner runTests: '* test*';;,f1!


!TestRunner methodsFor: 'test processing' stamp: 'rhi 4/26/2000 07:51'!
runTests: aString
	"doIt: [TestRunner new runTests: 'Test* test*']"

	self
		classPattern: (self classPatternFrom: aString);
		selectorPattern: (self selectorPatternFrom: aString).
	self runTests.! !

!TestRunner methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:45'!
showResult

	Transcript cr;cr; show: '==== SUnit ======== Start ===='.
	self
		showResultSummary;
		showResultDefects.
	Transcript cr; show: '==== SUnit ========== End ===='; cr.! !

!TestRunner methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:45'!
showResultDefects

	(self result failureCount > 0)
		ifTrue: [
			Transcript cr; show: '---- SUnit ----- Failures ----'.
			self result failures do: [:failure |
				Transcript crtab; show: failure printString]].
	(self result errorCount > 0)
		ifTrue: [
			Transcript cr; show: '---- SUnit ------- Errors ----'.
			self result errors do: [:error |
				Transcript crtab; show: error printString]].! !

!TestRunner methodsFor: 'test processing' stamp: 'rhi 2/5/2000 12:45'!
showResultSummary

	| message summary |
	message := (self result runCount = self result correctCount)
		ifTrue: [self successMessage]
		ifFalse: [self failureMessage].
	Transcript crtab; show: message.
	summary :=
		self result runCount printString, ' run, ',
		self result failureCount printString, ' failed, ',
		self result errorCount printString, ' errors (',
		self duration printString, ' ms)'.
	Transcript crtab; show: summary.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestRunner class
	instanceVariableNames: ''!

!TestRunner class methodsFor: 'documentation' stamp: 'rhi 2/5/2000 12:40'!
testRunnerUsage
	"Please see the class comment for some documentation.

	Documentation links:
		* TestingFrameworkPaper
		* TestModel
		* TestRunner"

	self error: 'comment only'.!
]style[(15 83 21 5 9 5 10 31)f1b,f1,f1LTestingFrameworkPaper Comment;,f1,f1LTestModel Comment;,f1,f1LTestRunner Comment;,f1! !


!TestRunner class methodsFor: 'processing' stamp: 'rhi 2/5/2000 12:40'!
runTests
	"doIt: [TestRunner runTests]"

	TestRunner new runTests.! !

!TestRunner class methodsFor: 'processing' stamp: 'rhi 2/5/2000 12:40'!
runTests: aString
	"doIt: [TestRunner runTests: '* test*']"

	TestRunner new runTests: aString.! !
Object subclass: #TestSuite
	instanceVariableNames: 'tests '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Framework'!
!TestSuite commentStamp: '<historical>' prior: 0!
A Composite of test cases. It runs a collection of test cases.

Instance Variables:
	tests	<OrderedCollection of: TestCase>!
]style[(92 17 5 8 1)f1,f1LOrderedCollection Hierarchy;,f1,f1LTestCase Hierarchy;,f1!


!TestSuite methodsFor: 'accessing' stamp: 'rhi 5/22/1999 17:51'!
tests

	^tests! !


!TestSuite methodsFor: 'adding' stamp: 'rhi 2/5/2000 12:39'!
addTest: aTestCase

	self tests add: aTestCase.! !


!TestSuite methodsFor: 'initialize-release' stamp: 'rhi 2/5/2000 12:39'!
initialize

	self tests: OrderedCollection new.! !


!TestSuite methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:39'!
tests: anOrderedCollection

	tests := anOrderedCollection.! !


!TestSuite methodsFor: 'running' stamp: 'rhi 5/22/1999 13:51'!
run

	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestSuite methodsFor: 'running' stamp: 'rhi 2/5/2000 12:39'!
run: aTestResult

	self tests do: [:each |
		each run: aTestResult].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestSuite class
	instanceVariableNames: ''!

!TestSuite class methodsFor: 'instance creation' stamp: 'rhi 5/22/1999 19:45'!
new

	^super new initialize! !
TMethod subclass: #TestTMethod
	instanceVariableNames: 'isPrimitive suppressingFailureGuards fullSelector fullArgs parmSpecs rcvrSpec '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!TestTMethod commentStamp: '<historical>' prior: 0!
Variation of TMethod node of the Smalltalk C Code Generator, used in conjunction with TestCodeGenerator and TestInterpreterPlugin to generate named primitives with type coercion specifications.!


!TestTMethod methodsFor: 'initializing' stamp: 'acg 9/19/1999 11:46'!
fromContext: aContext primitive: aString parameters: aClassList receiver: aClass

	fullArgs _ args _ aContext tempNames
				copyFrom: 1
				to: aContext method numArgs.
	self 
		primitive: aString
		parameters: aClassList
		receiver: aClass! !

!TestTMethod methodsFor: 'initializing' stamp: 'ar 5/9/2000 12:22'!
setSelector: sel args: argList locals: localList block: aBlockNode primitive: aNumber
	"Initialize this method using the given information."

	selector _ sel.
	returnType _ 'int'. 	 "assume return type is int for now"
	args _ argList asOrderedCollection collect: [:arg | arg key].
	locals _ localList asOrderedCollection collect: [:arg | arg key].
	declarations _ Dictionary new.
	primitive _ aNumber.
	parseTree _ aBlockNode asTranslatorNode.
	labels _ OrderedCollection new.
	complete _ false.  "set to true when all possible inlining has been done"
	export _ self extractExportDirective.
	static _ self extractStaticDirective.
	isPrimitive _ false.  "set to true only if you find a primtive direction."
	suppressingFailureGuards _ self extractSuppressFailureGuardDirective.
	self recordDeclarations.
	self extractPrimitiveDirectives.
! !


!TestTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:19'!
args: anInteger

	^args _ anInteger! !

!TestTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:18'!
parmSpecs

	^parmSpecs! !

!TestTMethod methodsFor: 'accessing' stamp: 'acg 9/19/1999 11:50'!
rcvrSpec

	^rcvrSpec! !


!TestTMethod methodsFor: 'transforming' stamp: 'acg 12/18/1999 10:39'!
extractSuppressFailureGuardDirective
	"Scan the top-level statements for a pragma directive of the form:

		self suppressFailureGuards: <boolean>

	 and remove the directive from the method body. Answer the argument of the directive or false if there is no #supressFailureGuards: directive."

	| result newStatements |
	result _ false.
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: [ :stmt |
		(stmt isSend and: [stmt selector = #suppressFailureGuards:]) ifTrue: [
			result _ stmt args first name = 'true'.
		] ifFalse: [
			newStatements add: stmt.
		].
	].
	parseTree setStatements: newStatements asArray.
	^ result! !

!TestTMethod methodsFor: 'transforming' stamp: 'TPR 3/1/2000 20:21'!
fixUpReturnOneStmt: stmt on: sStream

	stmt isReturn ifFalse: [^sStream nextPut: stmt].
	(stmt expression isSend and: ['primitiveFail' = stmt expression selector]) ifTrue: 
		["failure return"
		 sStream nextPut: stmt expression.
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	(stmt expression isVariable and: ['nil' = stmt expression name]) ifTrue: 
		["^ nil -- this is never right unless automatically generated"
		 sStream nextPut: stmt.
		 ^nil].
	(stmt expression isVariable and: ['self' = stmt expression name]) ifTrue: 
		["^ self"
		 self generateFailureGuardOn: sStream.
		 fullArgs isEmpty ifFalse:[ sStream nextPut: (self popExpr: fullArgs size)].
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	(stmt expression isVariable | stmt expression isConstant | suppressingFailureGuards) ifTrue:
		["^ variable or ^ constant or ^ expr without guardchecking"
		 self generateFailureGuardOn: sStream.
		 sStream nextPut: (self pop: fullArgs size + 1 thenReturnExpr: stmt expression).
		 sStream nextPut: self nullReturnExpr.
		 ^nil].
	"^ expr with guardchecking"
	sStream nextPut: (self assign: (self oopVariable: '_return_value') expression: stmt expression).
	self generateFailureGuardOn: sStream.
	sStream nextPut: (self pop: fullArgs size + 1 thenReturnExpr: (self oopVariable: '_return_value')).
	sStream nextPut: self nullReturnExpr
! !

!TestTMethod methodsFor: 'transforming' stamp: 'acg 9/18/1999 01:49'!
fixUpReturns
	"Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return."

	parseTree nodesDo: [:node |
		node isStmtList ifTrue: [
			node setStatements: (Array streamContents:
				[:sStream |
				 node statements do: 
					[:stmt | self fixUpReturnOneStmt: stmt on: sStream]])]]! !

!TestTMethod methodsFor: 'transforming' stamp: 'ar 3/10/2000 21:18'!
recordDeclarations
	"Record C type declarations of the forms

		self returnTypeC: 'float'.
		self var: #foo declareC: 'float foo'
		self var: #foo as: Class
		self var: #foo type: 'float'.

	 and remove the declarations from the method body."

	| newStatements isDeclaration theClass varName varType |
	newStatements _ OrderedCollection new: parseTree statements size.
	parseTree statements do: 
		[:stmt |
		 isDeclaration _ false.
		 stmt isSend ifTrue: 
			[stmt selector = #var:declareC: ifTrue:
				[isDeclaration _ true.
				declarations at: stmt args first value asString put: stmt args last value].
			stmt selector = #var:type: ifTrue: [
				isDeclaration _ true.
				varName _ stmt args first value asString.
				varType _ stmt args last value.
				declarations at: varName put: (varType, ' ', varName).
			].
			 stmt selector = #var:as: ifTrue:
				[isDeclaration _ true.
				 theClass _ Smalltalk 
					at: stmt args last name asSymbol
					ifAbsent: [^self error: 'declarator must be a Behavior'].
				 (theClass isKindOf: Behavior)
					ifFalse: [^self error: 'declarator must be a Behavior'].
				 declarations 
					at: stmt args first value asString 
					put: (theClass ccgDeclareCForVar: stmt args first value asString)].
			 stmt selector = #returnTypeC: ifTrue: 
				[isDeclaration _ true.
				 returnType _ stmt args last value]].
		 isDeclaration ifFalse: [newStatements add: stmt]].
	parseTree setStatements: newStatements asArray! !

!TestTMethod methodsFor: 'transforming' stamp: 'acg 9/17/1999 18:18'!
removeFinalSelfReturn
	"The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway."

	| stmtList lastStmt |
	stmtList _ parseTree statements asOrderedCollection.
	lastStmt _ stmtList last.

	((lastStmt isReturn) and:
	 [(lastStmt expression isVariable) and:
	 ['self' = lastStmt expression name]]) ifTrue: [
		stmtList removeLast.
		parseTree setStatements: stmtList.
	].! !

!TestTMethod methodsFor: 'transforming' stamp: 'TPR 3/2/2000 19:07'!
replaceArraySizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive. Specialised version for generating primitives outside a plugin"

	super replaceSizeMessages
! !

!TestTMethod methodsFor: 'transforming' stamp: 'acg 9/20/1999 14:04'!
replaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: 'interpreterProxy')
				arguments: (Array with: n receiver)]].
! !


!TestTMethod methodsFor: 'generating C code' stamp: 'acg 9/17/1999 07:51'!
emitCHeaderOn: aStream generator: aCodeGen
	"Emit a C function header for this method onto the given stream."

	aStream cr.
	self emitCFunctionPrototype: aStream generator: aCodeGen.
	aStream nextPutAll: ' {'; cr.
	locals do: [ :var |
		aStream 
			tab; 
			nextPutAll: (declarations 
				at: var 
				ifAbsent: [ 'int ', var]);
			nextPut: $;; 
			cr].
	locals isEmpty ifFalse: [ aStream cr ].! !


!TestTMethod methodsFor: 'specifying primitives' stamp: 'acg 12/15/1999 06:13'!
extractPrimitiveDirectives
	"Save selector in fullSelector and args in fullArgs.  Scan top-level statements for a directive of the form:

		self	
			primitive: 	<string>
or
		self
			primitive:	<string>
			parameters: <list of class names>
or
		self
			primitive:	<string>
			parameters: <list of class names>
			receiver: <class name>

or an assignment of that expression to a local, and manipulate the state and parse tree accordingly."

	parseTree setStatements: (Array streamContents:
		[:sStream |
			parseTree statements do:
				[:stmt |
				 (self primitiveDirectiveWasHandled: stmt on: sStream)
					ifFalse: [sStream nextPut: stmt]]]).
	isPrimitive 
		ifTrue:
			[export _ true.
			 parseTree 
				setStatements: self namedPrimitiveProlog, 
								parseTree statements.
			 self fixUpReturns.
			 self replaceSizeMessages.
			 ^true]
		ifFalse: [self removeFinalSelfReturn].
	^false! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'TPR 3/1/2000 20:14'!
handlePrimitiveDirective: aStmt on: sStream

	isPrimitive _ true.
	fullArgs _ args.
	locals addAll: args.
	args _ OrderedCollection new.
	fullArgs with: parmSpecs do:
		[:argName :spec |
			declarations
				at: argName
				put: (spec ccgDeclareCForVar: argName)].
	aStmt isAssignment ifTrue:
		[declarations
			at: aStmt variable name
			put: (rcvrSpec ccgDeclareCForVar: aStmt variable name).
		 sStream nextPutAll: (self
			statementsFor:
				(rcvrSpec
					ccg:		TestCodeGenerator new
					prolog:  [:expr | aStmt variable name, ' _ ', expr]
					expr: 	aStmt variable name
					index: 	(fullArgs size))
			varName: '')].

	"only add the failure guard if there are args or it is an assignment"
	(fullArgs isEmpty not or:[aStmt isAssignment]) ifTrue:[self generateFailureGuardOn: sStream].
	^true.
! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'TPR 2/10/2000 17:43'!
isPrimitiveDirectiveSend: stmt
	
	stmt isSend ifTrue:
		[stmt selector = #primitive: ifTrue:
			[^self primitive: 	stmt args first value
				   parameters:	(Array new: args size withAll: #Oop)
				   receiver:		#Oop].
		 stmt selector = #primitive:parameters: ifTrue:
			[^self primitive: 	stmt args first value
				   parameters: 	stmt args second value
				   receiver:		#Oop].
		 stmt selector = #primitive:parameters:receiver: ifTrue:
			[^self primitive:		stmt args first value
				   parameters:	stmt args second value
				   receiver:		stmt args third value].
		^false].
	^false.
! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'acg 12/15/1999 06:13'!
namedPrimitiveProlog

	| cg |
	cg _ TestCodeGenerator new.
	^Array streamContents: [:sStream |
		1 to: fullArgs size do:
			[:i |
			 sStream nextPutAll: 
				(self 
					statementsFor: 
						((parmSpecs at: i) 
							ccg: 	cg
							prolog:  [:expr | (fullArgs at: i), ' _ ', expr]
							expr: (fullArgs at: i)
							index: (fullArgs size - i))
					varName: '')]]! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'acg 9/20/1999 13:00'!
primitive: aString parameters: anArray receiver: aClassSymbol

	fullSelector _ selector.
	selector _ aString asSymbol.
	anArray size == args size ifFalse: 
		[^self error: selector, ': incorrect number of parameter specifications'].
	parmSpecs _ anArray collect:
		[:each | Smalltalk at: each ifAbsent:
			[^self error: selector, ': parameter spec must be a Behavior']].
	parmSpecs do: [:each | each isBehavior ifFalse:
		[^self error: selector, ': parameter spec must be a Behavior']].
	rcvrSpec _ Smalltalk at: aClassSymbol asSymbol ifAbsent:
		[^self error: selector, ': receiver spec must be a Behavior'].
	rcvrSpec isBehavior ifFalse:
		[^self error: selector, ': receiver spec must be a Behavior'].
	^true! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'acg 9/17/1999 22:41'!
primitiveDirectiveWasHandled: stmt on: sStream

	(self isPrimitiveDirectiveSend: stmt) ifTrue:
		[^self handlePrimitiveDirective: stmt on: sStream].
	(stmt isAssignment and: 
		[self isPrimitiveDirectiveSend: stmt expression]) ifTrue:
			[^self handlePrimitiveDirective: stmt on: sStream].
	^false.
! !

!TestTMethod methodsFor: 'specifying primitives' stamp: 'acg 9/19/1999 14:06'!
simulatePrologInContext: aContext

	|cg instructions |
	cg _ TestCodeGenerator new.
	parmSpecs keysAndValuesDo: 
		[:index :each |
		 instructions _ ((parmSpecs at: index)
			ccg: cg 
			prolog: (cg ccgTVarBlock: index) 
			expr: '<foo>' 
			index: args size - index).
		 Compiler new 
			evaluate: instructions
			in: aContext 
			to: aContext receiver
			notifying: nil
			ifFail: nil].
	instructions _ (rcvrSpec
		ccg: cg 
		prolog: [:expr | '^', expr]
		expr: '<foo>' 
		index: args size).
	 ^Compiler new 
		evaluate: instructions
		in: aContext 
		to: aContext receiver
		notifying: nil
		ifFail: nil! !


!TestTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 06:31'!
assign: variable expression: expression

	^TAssignmentNode new
		setVariable: variable
		expression: expression! !

!TestTMethod methodsFor: 'private' stamp: 'acg 9/19/1999 20:53'!
checkSuccessExpr
	"Return the parse tree for an expression that aborts the primitive if the successFlag is not true."

	| expr |
	expr _ 'interpreterProxy failed ifTrue: [^nil]'.
	^ self statementsFor: expr varName: ''
! !

!TestTMethod methodsFor: 'private' stamp: 'acg 12/18/1999 10:47'!
generateFailureGuardOn: sStream
	suppressingFailureGuards ifTrue: [^nil].
	sStream nextPutAll: self checkSuccessExpr
! !

!TestTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:50'!
nullReturnExpr

	^ TReturnNode new
		setExpression: (TVariableNode new setName: 'null')! !

!TestTMethod methodsFor: 'private' stamp: 'acg 9/20/1999 14:04'!
oldReplaceSizeMessages
	"Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive."

	| argExpr |
	parseTree nodesDo: [:n |
		(n isSend and: [n selector = #size]) ifTrue: [
			argExpr _ TSendNode new
				setSelector: #+
				receiver: n receiver
				arguments: (Array with: (TConstantNode new setValue: 1)).
			n
				setSelector: #sizeOfSTArrayFromCPrimitive:
				receiver: (TVariableNode new setName: 'interpreterProxy')
				arguments: (Array with: argExpr)]].
! !

!TestTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 06:30'!
oopVariable: aString

	(locals includes: aString) ifFalse:
		[locals add: aString.
		 declarations
			at: aString 
			put: 'int ', aString].
	^TVariableNode new setName: aString! !

!TestTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:55'!
pop: anInteger thenReturnExpr: anExpression

	^TSendNode new
		setSelector: #pop:thenPush:
		receiver: (TVariableNode new setName: 'interpreterProxy')
		arguments: (Array 
			with: (TConstantNode new 
				setValue: anInteger)
			with: anExpression)! !

!TestTMethod methodsFor: 'private' stamp: 'acg 12/15/1999 05:45'!
popExpr: anInteger

	^ TSendNode new
			 setSelector: #pop:
			 receiver: (TVariableNode new setName: 'interpreterProxy')
			 arguments: (Array 
				with: (TConstantNode new 
					setValue: anInteger))! !

!TestTMethod methodsFor: 'private' stamp: 'TPR 3/2/2000 12:39'!
printTempsAndVar: varName on: aStream 
	"add the required temps and the varname to the stream"
	aStream nextPutAll: '| '.
	(#('rcvr' 'stackPointer' 'successFlag' 'interpreterProxy' ) reject: [:each | locals includes: each])
		do: [:each | aStream nextPutAll: each;
			 space].
	(locals reject: [:each | each first = $_])
		do: [:each | aStream nextPutAll: each;
			 space].
"don't add varName twice. Probably a deeper reason for this, but WTH. TPR"
	(locals includes: varName) ifFalse:[aStream nextPutAll: varName].
	aStream nextPutAll: '|';
	 cr! !



!TestTMethod methodsFor: 'primitive compilation' stamp: 'TPR 3/2/2000 16:07'!
vmNameString
	"return the string to use as the vm name in code generated for this method"
	^'interpreterProxy'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TestTMethod class
	instanceVariableNames: ''!

!TestTMethod class methodsFor: 'as yet unclassified' stamp: 'acg 9/19/1999 11:47'!
fromContext: aContext primitive: aString parameters: aClassList receiver: aClass

	^super new 
		fromContext: aContext 
		primitive: aString 
		parameters: aClassList 
		receiver: aClass
! !
TestCase subclass: #TestTest
	instanceVariableNames: 'hasRun hasSetup '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
!TestTest commentStamp: '<historical>' prior: 0!
Test cases testing the testing framework ;)

Instance Variables:
	hasRun		<Boolean>
	hasSetup	<Boolean>!
]style[(75 7 13 7 1)f1,f1LBoolean Hierarchy;,f1,f1LBoolean Hierarchy;,f1!


!TestTest methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:47'!
hasRun: aBoolean

	hasRun := aBoolean.! !

!TestTest methodsFor: 'private accessing' stamp: 'rhi 2/5/2000 12:47'!
hasSetup: aBoolean

	hasSetup := aBoolean.! !


!TestTest methodsFor: 'private running' stamp: 'rhi 10/29/2000 18:31'!
error

	Error new signal.! !

!TestTest methodsFor: 'private running' stamp: 'rhi 2/5/2000 12:47'!
fail

	self assert: false.! !

!TestTest methodsFor: 'private running'!
noop! !

!TestTest methodsFor: 'private running' stamp: 'rhi 2/5/2000 12:47'!
setRun

	self hasRun: true.! !


!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
setUp

	self hasSetup: true.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testAssert

	self assert: true.
	self deny: false.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testDefects

	| result suite error failure |
	suite := TestSuite new.
	suite addTest: (error := TestTest selector: #error).
	suite addTest: (failure := TestTest selector: #fail).
	result := suite run.
	self assert: result defects asArray = (Array with: error with: failure).! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testError

	| case result |
	case := TestTest selector: #error.
	result := case run.
	self assert: result correctCount = 0.
	self assert: result failureCount = 0.
	self assert: result runCount = 1.
	self assert: result errorCount = 1.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testFail

	| case result |
	case := TestTest selector: #fail.
	result := case run.
	self assert: result correctCount = 0.
	self assert: result failureCount = 1.
	self assert: result runCount = 1.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testResult

	| case result |
	case := TestTest selector: #noop.
	result := case run.
	self assert: result runCount = 1.
	self assert: result correctCount = 1.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testRun

	| case |
	case := TestTest selector: #setRun.
	case run.
	self assert: case hasSetup.
	self assert: case hasRun.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testShould

	self should: [true].
	self shouldnt: [false].! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testShouldRaise

	self value: [321/0] shouldRaise: ZeroDivide.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testShouldntRaise

	self value: [432/1] shouldntRaise: ZeroDivide.! !

!TestTest methodsFor: 'running' stamp: 'rhi 2/5/2000 12:46'!
testSuite

	| suite result |
	suite := TestSuite new.
	suite addTest: (TestTest selector: #noop).
	suite addTest: (TestTest selector: #fail).
	result := suite run.
	self assert: result runCount = 2.
	self assert: result correctCount = 1.
	self assert: result failureCount = 1.! !


!TestTest methodsFor: 'testing' stamp: 'rhi 5/22/1999 13:54'!
hasRun

	^hasRun! !

!TestTest methodsFor: 'testing' stamp: 'rhi 5/22/1999 13:54'!
hasSetup

	^hasSetup! !
AlignmentMorph subclass: #Tetris
	instanceVariableNames: 'board scoreDisplay '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!Tetris commentStamp: '<historical>' prior: 0!
This is a port of JTetris.java 1.0.0.

How to start:
choose new morph.../Games/Tetris

How to play:
1) using buttons
2) using keyboard:
	drop - spacebar
	move to left - left arrow
	move to right - right arrow
	rotate clockwise - up arrow
	rotate anticlockwise - down arrow
NOTE: mouse must be over Tetris!



!Tetris methodsFor: 'initialization' stamp: 'RAA 1/8/2000 14:38'!
buildButtonTarget: aTarget label: aLabel selector: aSelector help: aString

	^self rowForButtons
		addMorph: (
			SimpleButtonMorph new 
				target: aTarget;
				label: aLabel;
				actionSelector: aSelector;
				borderColor: #raised;
				borderWidth: 2;
				color: color
		)

! !

!Tetris methodsFor: 'initialization' stamp: 'di 11/25/2000 20:47'!
initialize

	super initialize.
	board _ TetrisBoard new game: self.
	color _ Color lightGray.
	self listDirection: #topToBottom.
	self wrapCentering: #center.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	self layoutInset: 3.
	self 
		addMorphBack: self makeGameControls;
		addMorphBack: self makeMovementControls;
		addMorphBack: self showScoreDisplay;
		addMorphBack: board.
	board newGame.

! !

!Tetris methodsFor: 'initialization' stamp: 'RAA 1/7/2000 22:51'!
makeGameControls

	^self rowForButtons
		addMorph:
			(self
				buildButtonTarget: self
				label: 'Quit'
				selector: #delete
				help: 'quit');
		addMorph:
			(self
				buildButtonTarget: board
				label: 'Pause'
				selector: #pause
				help: 'pause');
		addMorph:
			(self
				buildButtonTarget: board
				label: 'New game'
				selector: #newGame
				help: 'new game')! !

!Tetris methodsFor: 'initialization' stamp: 'RAA 1/8/2000 14:03'!
makeMovementControls

	^self rowForButtons
		addMorph:
			(self
				buildButtonTarget: board
				label: '->'
				selector: #moveRight
				help: 'move to the right');
		addMorph:
			(self
				buildButtonTarget: board
				label: ' ) '
				selector: #rotateClockWise
				help: 'rotate clockwise');
		addMorph:
			(self
				buildButtonTarget: board
				label: ' | '
				selector: #dropAllTheWay
				help: 'drop');
		addMorph:
			(self
				buildButtonTarget: board
				label: ' ( '
				selector: #rotateAntiClockWise
				help: 'rotate anticlockwise');
		addMorph:
			(self
				buildButtonTarget: board
				label: '<-'
				selector: #moveLeft
				help: 'move to the left')! !

!Tetris methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:24'!
rowForButtons

	^AlignmentMorph newRow
		color: color;
		borderWidth: 0;
		layoutInset: 3;
		vResizing: #shrinkWrap;
		wrapCentering: #center
! !

!Tetris methodsFor: 'initialization' stamp: 'di 11/25/2000 20:52'!
showScoreDisplay

	^ self rowForButtons
		hResizing: #shrinkWrap;
		addMorph: (self wrapPanel: ((scoreDisplay _ LedMorph new) digits: 5; extent: (4*10@15)) 
						label: 'Score:')
! !

!Tetris methodsFor: 'initialization' stamp: 'RAA 1/8/2000 14:38'!
wrapPanel: anLedPanel label: aLabel
	"wrap an LED panel in an alignmentMorph with a label to its left"

	^self rowForButtons
		color: color lighter;
		addMorph: anLedPanel;
		addMorph: (StringMorph contents: aLabel)
! !


!Tetris methodsFor: 'events' stamp: 'ar 9/15/2000 22:58'!
handlesKeyboard: evt
	^true! !

!Tetris methodsFor: 'events' stamp: 'am 8/28/1999 14:22'!
handlesMouseOver: evt
	^ true
! !

!Tetris methodsFor: 'events' stamp: 'RAA 1/8/2000 15:42'!
keyStroke: evt

	| charValue |
	charValue _ evt keyCharacter asciiValue.
	charValue = 28 ifTrue: [board moveLeft].
	charValue = 29 ifTrue: [board moveRight].
	charValue = 30 ifTrue: [board rotateClockWise].
	charValue = 31 ifTrue: [board rotateAntiClockWise].
	charValue = 32 ifTrue: [board dropAllTheWay].
! !

!Tetris methodsFor: 'events' stamp: 'ar 9/15/2000 23:07'!
mouseEnter: evt
        evt hand newKeyboardFocus: self! !

!Tetris methodsFor: 'events' stamp: 'RAA 1/7/2000 22:37'!
score: anInteger

	scoreDisplay value: anInteger! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Tetris class
	instanceVariableNames: ''!

!Tetris class methodsFor: 'as yet unclassified' stamp: 'RAA 1/7/2000 23:19'!
colors

	^{
		Color r: 0.5 g: 0 b: 0.
		Color r: 0 g: 0.5 b: 0.
		Color r: 0 g: 0 b: 0.5.
		Color r: 0.5 g: 0.5 b: 0.
		Color r: 0.5 g: 0 b: 0.5.
		Color r: 0 g: 0.5 b: 0.5
	}
! !
Morph subclass: #TetrisBlock
	instanceVariableNames: 'angle shapeInfo board baseCellNumber '
	classVariableNames: 'ShapeChoices '
	poolDictionaries: ''
	category: 'Morphic-Games'!

!TetrisBlock methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 15:58'!
board: theBoard

	board _ theBoard.
	4 timesRepeat: [
		self addMorph: (
			RectangleMorph new
				color: color;
				extent: board cellSize;
				borderRaised
		 )
	].
	self positionCellMorphs.! !

!TetrisBlock methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 12:37'!
dropByOne
 
	^self moveDeltaX: 0 deltaY: 1 deltaAngle: 0! !

!TetrisBlock methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 15:33'!
initialize

	super initialize.
	bounds _ (2@2) negated extent: 1@1.	"keep this puppy out of sight"
	shapeInfo _ self class shapeChoices atRandom.
	baseCellNumber _ (4 atRandom + 2) @ 1.
	angle _ 4 atRandom.
	color _ Tetris colors atRandom.
! !

!TetrisBlock methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 13:56'!
moveDeltaX: deltaX deltaY: deltaY deltaAngle: deltaAngle 

	| delta |

	delta _ deltaX @ deltaY.
	(shapeInfo atWrap: angle + deltaAngle) do: [ :offsetThisCell | 
		(board emptyAt: baseCellNumber + offsetThisCell + delta) ifFalse: [^ false]
	].
	baseCellNumber _ baseCellNumber + delta.
	angle _ angle + deltaAngle - 1 \\ 4 + 1.
	self positionCellMorphs.
	^ true ! !

!TetrisBlock methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 13:41'!
positionCellMorphs

	(shapeInfo atWrap: angle) withIndexDo: [ :each :index |
		(submorphs at: index)
			position: (board originForCell: baseCellNumber + each)
	].
	fullBounds _ nil.
	self changed.
	 
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TetrisBlock class
	instanceVariableNames: ''!

!TetrisBlock class methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 15:29'!
flipShapes: anArray

	^OrderedCollection new 
		add: anArray;
		add: (anArray collect: [ :each | each y negated @ each x]);
		add: (anArray collect: [ :each | each x negated @ each y negated]);
		add: (anArray collect: [ :each | each y @ each x negated]);
		yourself
	
! !

!TetrisBlock class methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 11:55'!
includeInNewMorphMenu

	^false! !

!TetrisBlock class methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 15:32'!
shapeChoices

	^ ShapeChoices ifNil: [
		ShapeChoices _ {
			{ {  0 @ 0 .  1 @ 0 .  0 @ 1 .  1 @ 1  } }.	"square - one is sufficient here"
			self flipShapes: {  0 @  0 . -1 @  0 .  1 @  0 .  0 @ -1  }.	"T"
			{ 
				{  0 @ 0 . -1 @ 0 .  1 @ 0 .  2 @ 0  }.
				{  0 @ 0 .  0 @-1 .  0 @ 1 .  0 @ 2  } 	"long - two are sufficient here"
			}.
			self flipShapes: { 0 @ 0 .  0 @ -1 .  0 @  1 .  1 @  1  }.	"L"
			self flipShapes: { 0 @ 0 .  0 @ -1 .  0 @  1 . -1 @  1  }.	"inverted L"
			self flipShapes: { 0 @ 0 . -1 @  0 .  0 @ -1 .  1 @ -1  }.	"S"
			self flipShapes: {  0 @ 0 .  1 @ 0 .  0 @ -1 . -1 @ -1  } "Z"
		}.
	]
! !
PasteUpMorph subclass: #TetrisBoard
	instanceVariableNames: 'paused gameOver delay score currentBlock game '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!

!TetrisBoard methodsFor: 'initialization' stamp: 'ar 11/8/2000 18:14'!
initialize

	super initialize.
	bounds _ 0@0 extent: (self numColumns @ self numRows) * self cellSize + (1@1).
	color _ Color r: 0.8 g: 1.0 b: 1.0.
! !


!TetrisBoard methodsFor: 'stepping' stamp: 'RAA 1/8/2000 15:59'!
step

	(self ownerThatIsA: HandMorph) ifNotNil: [^self].
	paused ifTrue: [^ self]. 
	currentBlock ifNil: [
		currentBlock _ TetrisBlock new.
		self addMorphFront: currentBlock.
		currentBlock board: self.
	] ifNotNil: [
		currentBlock dropByOne ifFalse: [self storePieceOnBoard]
	].
! !

!TetrisBoard methodsFor: 'stepping' stamp: 'AM 7/26/1999 16:07'!
stepTime

	^ delay! !



!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 14:03'!
dropAllTheWay

	self running ifFalse: [^ self].
	[currentBlock dropByOne] whileTrue: [
		self score: score + 1
	].
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 11:17'!
moveLeft

	self running ifFalse: [^ self].
	currentBlock moveDeltaX: -1 deltaY: 0 deltaAngle: 0.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 11:17'!
moveRight

	self running ifFalse: [^ self].
	currentBlock moveDeltaX: 1 deltaY: 0 deltaAngle: 0.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 13:20'!
newGame

	self removeAllMorphs.
	gameOver _ paused _ false.
	delay _ 500.
	currentBlock _ nil.
	self score: 0.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 11:16'!
pause

	gameOver ifTrue: [^ self].
	paused _ paused not.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 11:17'!
rotateAntiClockWise

	self running ifFalse: [^ self].
	currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: -1.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 1/8/2000 11:17'!
rotateClockWise

	self running ifFalse: [^ self].
	currentBlock moveDeltaX: 0 deltaY: 0 deltaAngle: 1.
! !

!TetrisBoard methodsFor: 'button actions' stamp: 'RAA 8/28/1999 22:31'!
running

	^currentBlock notNil and: [paused not]! !


!TetrisBoard methodsFor: 'other' stamp: 'RAA 1/8/2000 13:20'!
checkForFullRows

	| targetY morphsInRow bonus |
	self numRows to: 2 by: -1 do: [ :row |
		targetY _ (self originForCell: 1@row) y.
		[
			morphsInRow _ self submorphsSatisfying: [ :each | each top = targetY].
			morphsInRow size = self numColumns
		] whileTrue: [
			bonus _ (morphsInRow collect: [:each | each color]) asSet size = 1 
				ifTrue: [1000] 
				ifFalse: [100].
			self score: score + bonus.
			submorphs copy do: [ :each |
				each top = targetY ifTrue: [
					each delete
				].
				each top < targetY ifTrue: [
					each position: each position + (0@self cellSize y)
				].
			].
		].
	].

! !

!TetrisBoard methodsFor: 'other' stamp: 'RAA 1/8/2000 13:59'!
storePieceOnBoard

	currentBlock submorphs do: [ :each |
		self addMorph: each.
		((each top - self top) // self cellSize y) < 3 ifTrue: [
			paused _ gameOver _ true.
		].
	].
	currentBlock delete.
	currentBlock _ nil.
	self checkForFullRows.
	self score: score + 10.
	delay _ delay - 2 max: 80.

! !


!TetrisBoard methodsFor: 'data' stamp: 'RAA 1/8/2000 13:16'!
emptyAt: aPoint

	| cellOrigin |
	(aPoint x between: 1 and: self numColumns) ifFalse: [^ false].
	(aPoint y < 1) ifTrue: [^ true].	"handle early phases"
	(aPoint y <= self numRows) ifFalse: [^ false].
	cellOrigin _ self originForCell: aPoint.
	^(self submorphsSatisfying: [ :each | each topLeft = cellOrigin]) isEmpty

! !

!TetrisBoard methodsFor: 'data' stamp: 'RAA 8/28/1999 23:29'!
numColumns

	^10
	! !

!TetrisBoard methodsFor: 'data' stamp: 'RAA 8/28/1999 23:30'!
numRows

	^27
	! !


!TetrisBoard methodsFor: 'accessing' stamp: 'RAA 1/7/2000 22:34'!
game: aTetris

	game _ aTetris! !

!TetrisBoard methodsFor: 'accessing' stamp: 'RAA 1/7/2000 22:38'!
score: aNumber

	score _ aNumber.
	game score: score.! !


!TetrisBoard methodsFor: 'as yet unclassified' stamp: 'RAA 1/7/2000 23:12'!
cellSize

	^12@12! !

!TetrisBoard methodsFor: 'as yet unclassified' stamp: 'RAA 1/8/2000 13:11'!
originForCell: aPoint

	^aPoint - (1@1) * self cellSize + self position

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TetrisBoard class
	instanceVariableNames: ''!


!TetrisBoard class methodsFor: 'as yet unclassified' stamp: 'RAA 1/7/2000 22:56'!
includeInNewMorphMenu

	^false! !
ArrayedCollection subclass: #Text
	instanceVariableNames: 'string runs '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Collections-Text'!
!Text commentStamp: '<historical>' prior: 0!
I represent a character string that has been marked with abstract changes in character appearance. Actual display is performed in the presence of a TextStyle which indicates, for each abstract code, an actual font to be used.  A Text associates a set of TextAttributes with each character in its character string.  These attributes may be font numbers, emphases such as bold or italic, or hyperling actions.  Font numbers are interpreted relative to whatever textStyle appears, along with the text, in a Paragraph.  Since most characters have the same attributes as their neighbors, the attributes are stored in a RunArray for efficiency.  Each of my instances has
	string		a String
	runs		a RunArray!
]style[(148 9 97 13 237 9 163 6 10 8)f1,f1LTextStyle Comment;,f1,f1LTextAttribute Hierarchy;,f1,f1LParagraph Comment;,f1,f1LString Comment;,f1,f1LRunArray Comment;!


!Text methodsFor: 'accessing' stamp: 'tk 9/4/2000 16:04'!
append: stringOrText

	self replaceFrom: string size + 1
				to: string size with: stringOrText! !

!Text methodsFor: 'accessing'!
at: index

	^string at: index! !

!Text methodsFor: 'accessing'!
at: index put: character

	^string at: index put: character! !

!Text methodsFor: 'accessing' stamp: 'ls 7/29/1998 01:17'!
embeddedMorphs
	"return the list of morphs embedded in me"
	| morphs |
	morphs _ IdentitySet new.
	runs withStartStopAndValueDo: [ :start :stop :attribs | attribs do: [ :attrib |
		(attrib isKindOf: TextAnchor) ifTrue: [  morphs add: attrib anchoredMorph ] ] ].
	^morphs select: [ :m | m isKindOf: Morph ]! !

!Text methodsFor: 'accessing'!
findString: aString startingAt: start 
	"Answer the index of subString within the receiver, starting at index 
	start. If the receiver does not contain subString, answer 0."

	^string findString: aString asString startingAt: start! !

!Text methodsFor: 'accessing' stamp: 'di 11/23/1998 11:53'!
findString: aString startingAt: start caseSensitive: caseSensitive
	"Answer the index of subString within the receiver, starting at index 
	start. If the receiver does not contain subString, answer 0."

	^string findString: aString asString startingAt: start caseSensitive: caseSensitive! !

!Text methodsFor: 'accessing' stamp: 'tk 9/6/2000 12:33'!
lineCount

	^ string lineCount! !

!Text methodsFor: 'accessing' stamp: 'sw 12/7/1999 12:25'!
rangeOf: attribute startingAt: index forStyle: aStyle
	"This is stupid, slow code, but it works"
	| start stop |
	start _ index.
	[start > 1 and: [(self attributesAt: (start - 1) forStyle: aStyle) includes: attribute]]
		whileTrue: [start _ start - 1].
	stop _ index-1.
	[stop < self size and: [(self attributesAt: (stop + 1) forStyle: aStyle) includes: attribute]]
		whileTrue: [stop _ stop + 1].
	^ start to: stop! !

!Text methodsFor: 'accessing' stamp: 'tk 12/30/97 07:17'!
replaceFrom: start to: stop with: aText

	| txt |
	txt _ aText asText.	"might be a string"
	string _ string copyReplaceFrom: start to: stop with: txt string.
	runs _ runs copyReplaceFrom: start to: stop with: txt runs! !

!Text methodsFor: 'accessing'!
size

	^string size! !

!Text methodsFor: 'accessing'!
string
	"Answer the string representation of the receiver."

	^string! !


!Text methodsFor: 'comparing' stamp: 'di 1/29/2000 14:15'!
= other
	| otherRuns |
	^ other isText
		ifTrue:	["This is designed to run fast even for megabytes"
				otherRuns _ other asText runs.
				(string == other string or: [string = other string])
					and: [runs == otherRuns or: [runs = otherRuns]]]
		ifFalse: [false]! !

!Text methodsFor: 'comparing' stamp: 'tk 9/6/2000 11:59'!
howManyMatch: aString

	^ self string howManyMatch: aString! !

!Text methodsFor: 'comparing'!
isText
	^ true! !


!Text methodsFor: 'copying'!
copy

	^ self class new setString: string copy setRuns: runs copy
! !

!Text methodsFor: 'copying'!
copyFrom: start to: stop 
	"Answer a copied subrange of the receiver."

	| realStart realStop |
	stop > self size
		ifTrue: [realStop _ self size]		"handle selection at end of string"
		ifFalse: [realStop _ stop].
	start < 1
		ifTrue: [realStart _ 1]			"handle selection before start of string"
		ifFalse: [realStart _ start].
	^Text 
		string: (string copyFrom: realStart to: realStop)
		runs: (runs copyFrom: realStart to: realStop)! !

!Text methodsFor: 'copying'!
copyReplaceFrom: start to: stop with: aText

	^self shallowCopy replaceFrom: start to: stop with: aText! !

!Text methodsFor: 'copying' stamp: 'tk 1/7/98 10:58'!
copyReplaceTokens: oldSubstring with: newSubstring 
	"Replace all occurrences of oldSubstring that are surrounded
	by non-alphanumeric characters"
	^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true
	"'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! !

!Text methodsFor: 'copying' stamp: 'di 11/9/97 17:13'!
deepCopy

	^ self copy "Both string and runs are assumed to be read-only"! !


!Text methodsFor: 'converting'!
asDisplayText
	"Answer a DisplayText whose text is the receiver."

	^DisplayText text: self! !

!Text methodsFor: 'converting'!
asNumber
	"Answer the number created by interpreting the receiver as the textual 
	representation of a number."

	^string asNumber! !

!Text methodsFor: 'converting'!
asParagraph
	"Answer a Paragraph whose text is the receiver."

	^Paragraph withText: self! !

!Text methodsFor: 'converting'!
asString
	"Answer a String representation of the textual receiver."

	^string! !

!Text methodsFor: 'converting'!
asText	
	"Answer the receiver itself."

	^self! !

!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'!
asUrl
	^self asString asUrl! !

!Text methodsFor: 'converting' stamp: 'ls 7/14/1998 03:20'!
asUrlRelativeTo: aUrl
	^self asString asUrlRelativeTo: aUrl! !

!Text methodsFor: 'converting' stamp: 'bf 3/9/2000 18:25'!
isoToSqueak
	^ self class new setString: string isoToSqueak setRuns: runs copy! !

!Text methodsFor: 'converting' stamp: 'bf 3/9/2000 18:25'!
squeakToIso
	^ self class new setString: string squeakToIso setRuns: runs copy! !


!Text methodsFor: 'emphasis'!
addAttribute: att 
	^ self addAttribute: att from: 1 to: self size! !

!Text methodsFor: 'emphasis'!
addAttribute: att from: start to: stop 
	"Set the attribute for characters in the interval start to stop."
	runs _  runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | Text addAttribute: att toArray: attributes])
! !

!Text methodsFor: 'emphasis'!
allBold 
	"Force this whole text to be bold."
	string size = 0 ifTrue: [^self].
	self makeBoldFrom: 1 to: string size! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 12:30'!
attributesAt: characterIndex 
	"Answer the code for characters in the run beginning at characterIndex."
	"NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this"
	| attributes |
	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)].  "null text tolerates access"
	attributes _ runs at: characterIndex.
	^ attributes! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 11:32'!
attributesAt: characterIndex forStyle: aTextStyle
	"Answer the code for characters in the run beginning at characterIndex."
	| attributes |
	self size = 0
		ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)].  "null text tolerates access"
	attributes _ runs at: characterIndex.
	^ attributes! !

!Text methodsFor: 'emphasis' stamp: 'di 4/1/1999 15:17'!
emphasisAt: characterIndex
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes emph |
	self size = 0 ifTrue: [^ 0].	"null text tolerates access"
	emph _ 0.
	attributes _ runs at: characterIndex.
	attributes do: 
		[:att | emph _ emph bitOr: att emphasisCode].
	^ emph
	! !

!Text methodsFor: 'emphasis' stamp: 'di 11/10/97 13:36'!
find: attribute
	"Return the first interval over which this attribute applies"
	| begin end |
	begin _ 0.
	runs withStartStopAndValueDo:
		[:start :stop :attributes |
		(attributes includes: attribute)
			ifTrue: [begin = 0 ifTrue: [begin _ start].
					end _ stop]
			ifFalse: [begin > 0 ifTrue: [^ begin to: end]]].
	begin > 0 ifTrue: [^ begin to: end].
	^ nil! !

!Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 10:58'!
fontAt: characterIndex withStyle: aTextStyle
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes font |
	self size = 0 ifTrue: [^ aTextStyle defaultFont].	"null text tolerates access"
	attributes _ runs at: characterIndex.
	font _ aTextStyle defaultFont.  "default"
	attributes do: 
		[:att | att forFontInStyle: aTextStyle do: [:f | font _ f]].
	^ font! !

!Text methodsFor: 'emphasis'!
fontNumberAt: characterIndex 
	"Answer the fontNumber for characters in the run beginning at characterIndex."
	| attributes fontNumber |
	self size = 0 ifTrue: [^1].	"null text tolerates access"
	attributes _ runs at: characterIndex.
	fontNumber _ 1.
	attributes do: [:att | (att isMemberOf: TextFontChange) ifTrue: [fontNumber _ att fontNumber]].
	^ fontNumber
	! !

!Text methodsFor: 'emphasis'!
makeBoldFrom: start to: stop

	^ self addAttribute: TextEmphasis bold from: start to: stop! !

!Text methodsFor: 'emphasis' stamp: 'sma 2/5/2000 12:03'!
makeSelectorBoldIn: aClass
	"For formatting Smalltalk source code, set the emphasis of that portion of 
	the receiver's string that parses as a message selector to be bold."

	| parser |
	string size = 0 ifTrue: [^self].
	(parser _ aClass parserClass new) parseSelector: string.
	self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! !

!Text methodsFor: 'emphasis'!
removeAttribute: att from: start to: stop 
	"Remove the attribute over the interval start to stop."
	runs _  runs copyReplaceFrom: start to: stop
			with: ((runs copyFrom: start to: stop)
				mapValues:
				[:attributes | attributes copyWithout: att])
! !

!Text methodsFor: 'emphasis'!
runLengthFor: characterIndex 
	"Answer the count of characters remaining in run beginning with 
	characterIndex."

	^runs runLengthAt: characterIndex! !


!Text methodsFor: 'printing' stamp: 'sma 6/1/2000 09:49'!
printOn: aStream
	self printNameOn: aStream.
	aStream nextPutAll: ' for '; print: string! !

!Text methodsFor: 'printing'!
storeOn: aStream

	aStream nextPutAll: '(Text string: ';
		store: string;
		nextPutAll: ' runs: ';
		store: runs;
		nextPut: $)! !


!Text methodsFor: 'private'!
runs

	^runs! !

!Text methodsFor: 'private'!
setString: aString setRuns: anArray

	string _ aString.
	runs _ anArray! !

!Text methodsFor: 'private' stamp: 'tk 12/16/97 14:14'!
setString: aString setRunsChecking: aRunArray
	"Check runs and do the best you can to make them fit..."

	string _ aString.
	"check the runs"
	aRunArray ifNil: [^ aString asText].
	(aRunArray isKindOf: RunArray) ifFalse: [^ aString asText].
	aRunArray runs size = aRunArray values size ifFalse: [^ aString asText].
	(aRunArray values includes: #()) ifTrue: [^ aString asText].	"not allowed?"
	aRunArray size = aString size ifFalse: [^ aString asText].
	
	runs _ aRunArray.! !


!Text methodsFor: 'attributes' stamp: 'sw 11/9/1999 17:24'!
askIfAddStyle: priorMethod req: requestor
	"Ask the user if we have a complex style (i.e. bold) for the first time"
	| tell answ old |
	(Preferences browseWithPrettyPrint and: [Preferences colorWhenPrettyPrinting])
		ifTrue: [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]].
	self runs coalesce.
	self unembellished ifTrue: [^ self asString].
	priorMethod ifNotNil: [old _ priorMethod getSourceFromFile].
	(old == nil or: [old unembellished])
		ifTrue:
			[tell _ 'This method contains style (e.g. bold) for the first time.
Do you really want to save the style info?'.
			answ _ (PopUpMenu labels: 'Save method with style
Save method simply')
						startUpWithCaption: tell.
			answ = 2 ifTrue: [^ self asString]]! !

!Text methodsFor: 'attributes' stamp: 'sw 11/16/1999 22:33'!
couldDeriveFromPrettyPrinting
	"Return true if the receiver has any TextAttributes that are functional rather than simply appearance-related"
	runs values do:
		[:emphArray | emphArray do:
			[:emph | emph couldDeriveFromPrettyPrinting ifFalse: [^ false]]].
	^ true! !

!Text methodsFor: 'attributes' stamp: 'sw 12/7/1999 12:31'!
unembellished 
	"Return true if the only emphases are the default font and bold"
	| font1 bold |
	font1 _ TextFontChange defaultFontChange.
	bold _ TextEmphasis bold.
	Preferences ignoreStyleIfOnlyBold ifFalse:
		["Ignore font1 only or font1-bold followed by font1-plain"
		^ (runs values = (Array with: (Array with: font1)))
		or: [runs values = (Array with: (Array with: font1 with: bold)
 								with: (Array with: font1))]].

	"If preference is set, then ignore any combo of font1 and bold"
	runs withStartStopAndValueDo:
		[:start :stop :emphArray |
		emphArray do:
			[:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]].
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Text class
	instanceVariableNames: ''!

!Text class methodsFor: 'class initialization'!
initTextConstants 
	"Initialize constants shared by classes associated with text display, e.g., 
	Space, Tab, Cr, Bs, ESC."
		"1/24/96 sw: in exasperation and confusion, changed cmd-g mapping from 231 to 232 to see if I could gain any relief?!!"


	| letter varAndValue tempArray width |
	"CtrlA..CtrlZ, Ctrla..Ctrlz"
	letter _ $A.
 	#(		212 230 228 196 194 226 241 243 214 229 200 217 246 
			245 216 202 210 239 211 240 197 198 209 215 242 231
	 		1 166 228 132 130 12 232 179 150 165 136 153 182 
			14 15 138 17 18 19 11 21 134 145 151 178 167 ) do:
		[:kbd |
		TextConstants at: ('Ctrl', letter asSymbol) asSymbol put: kbd asCharacter.
		letter _ letter == $Z ifTrue: [$a] ifFalse: [(letter asciiValue + 1) asCharacter]].

	varAndValue _ #(
		Space	32
		Tab		9
		CR		13
		Enter	3
		BS		8
		BS2		158
		ESC		160
		Clear 	173
	).

	varAndValue size odd ifTrue: [self notify: 'unpaired text constant'].
	(2 to: varAndValue size by: 2) do:
		[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i) asCharacter].

	varAndValue _ #(
		CtrlDigits 			(159 144 143 128 127 129 131 180 149 135)
		CtrlOpenBrackets	(201 7 218 249 219 15)
			"lparen gottn by ctrl-_ = 201; should be 213 but can't type that on Mac"

			"location of non-character stop conditions"
		EndOfRun	257
		CrossedX	258

			"values for alignment"
		LeftFlush	0
		RightFlush	1
		Centered	2
		Justified	3

			"subscripts for a marginTabsArray tuple"
		LeftMarginTab	1
		RightMarginTab	2

			"font faces"
		Basal	0
		Bold	1
		Italic	2

			"in case font doesn't have a width for space character"
			"some plausible numbers-- are they the right ones?"
		DefaultSpace			4
		DefaultTab				24
		DefaultLineGrid			16
		DefaultBaseline			12
		DefaultFontFamilySize	3	"basal, bold, italic"
	).

	varAndValue size odd ifTrue: [self notify: 'unpaired text constant'].
	(2 to: varAndValue size by: 2) do:
		[:i | TextConstants at: (varAndValue at: i - 1) put: (varAndValue at: i)].

	TextConstants at: #DefaultRule	put: Form over.
	TextConstants at: #DefaultMask	put: Color black.

	width _ Display width max: 720.
	tempArray _ Array new: width // DefaultTab.
	1 to: tempArray size do:
		[:i | tempArray at: i put: DefaultTab * i].
	TextConstants at: #DefaultTabsArray put: tempArray.
	tempArray _ Array new: (width // DefaultTab) // 2.
	1 to: tempArray size do:
		[:i | tempArray at: i put: (Array with: (DefaultTab*i) with: (DefaultTab*i))].
	TextConstants at: #DefaultMarginTabsArray put: tempArray.

"Text initTextConstants "! !

!Text class methodsFor: 'class initialization'!
initialize	"Text initialize"
	"Initialize constants shared by classes associated with text display."

	TextConstants at: #CaretForm put:
				(Form extent: 16@5
					fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
					offset: -3@0).
	self initTextConstants! !


!Text class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 14:14'!
fromString: aString 
	"Answer an instance of me whose characters are those of the argument, aString."

	^ self string: aString attribute: (TextFontChange fontNumber: TextStyle default defaultFontIndex)! !

!Text class methodsFor: 'instance creation' stamp: 'jm 4/28/1998 06:54'!
fromUser
	"Answer an instance of me obtained by requesting the user to type a string."
	"Text fromUser"

	^ self fromString:
		(FillInTheBlank request: 'Enter text followed by carriage return')
! !

!Text class methodsFor: 'instance creation'!
new: stringSize

	^self fromString: (String new: stringSize)! !

!Text class methodsFor: 'instance creation'!
streamContents: blockWithArg 
	| stream |
	stream _ TextStream on: (self new: 400).
	blockWithArg value: stream.
	^ stream contents! !

!Text class methodsFor: 'instance creation'!
string: aString attribute: att
	"Answer an instance of me whose characters are aString.
	att is a TextAttribute."

	^self string: aString attributes: (Array with: att)! !

!Text class methodsFor: 'instance creation'!
string: aString attributes: atts
	"Answer an instance of me whose characters are those of aString.
	atts is an array of TextAttributes."

	^self string: aString runs: (RunArray new: aString size withAll: atts)! !

!Text class methodsFor: 'instance creation'!
string: aString emphasis: emphasis
	"This is an old method that is mainly used by old applications"

	emphasis isNumber ifTrue:
		[self halt: 'Numeric emphasis is not supported in Squeak'.
		"But if you proceed, we will do our best to give you what you want..."
		^ self string: aString runs: (RunArray new: aString size withAll: 
			(Array with: (TextFontChange new fontNumber: emphasis)))].
	^ self string: aString attributes: emphasis! !


!Text class methodsFor: 'private' stamp: 'di 10/31/97 11:22'!
addAttribute: att toArray: others 
	"Add a new text attribute to an existing set"
	"NOTE: The use of reset and set in this code is a specific
	hack for merging TextKerns."
	att reset.
	^ Array streamContents:
		[:strm | others do:
			[:other | (att dominates: other) ifFalse: [strm nextPut: other]].
		att set ifTrue: [strm nextPut: att]]! !

!Text class methodsFor: 'private'!
string: aString runs: anArray
 
	^self basicNew setString: aString setRuns: anArray! !
TextAttribute subclass: #TextAction
	instanceVariableNames: ''
	classVariableNames: 'Purple '
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextAction methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:44'!
analyze: aString
	"Analyze the selected text to find both the parameter to store and the text to emphesize (may be different from original selection).  Does not return self!!.  May be of the form:
3+4
<3+4>
Click Here<3+4>
<3+4>Click Here
"
	"Obtain the showing text and the instructions"
	| b1 b2 trim param show |
	b1 _ aString indexOf: $<.
	b2 _ aString indexOf: $>.
	(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
		param _ self validate: aString.
		^ Array with: param with: (param size = 0 ifTrue: [nil] ifFalse: [param])].
	"Two parts"
	trim _ aString withBlanksTrimmed.
	(trim at: 1) == $< 
		ifTrue: [(trim last) == $>
			ifTrue: ["only instructions" 
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] ifFalse: [param]]
			ifFalse: ["at the front"
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: b2+1 to: aString size]]]
		ifFalse: [(trim last) == $>
			ifTrue: ["at the end"
				param _ self validate: (aString copyFrom: b1+1 to: b2-1).
				show _ param size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: 1 to: b1-1]]
			ifFalse: ["Illegal -- <> has text on both sides"
				show _ nil]].
	^ Array with: param with: show
! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'!
dominatedByCmd0
	"Cmd-0 should turn off active text"
	^ true! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: Purple! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'DSM 3/30/1999 13:15'!
info
	^ 'no hidden info'! !

!TextAction methodsFor: 'as yet unclassified'!
mayActOnClick

	^ true! !

!TextAction methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:48'!
validate: aString
	"any format is OK with me"
	^ aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextAction class
	instanceVariableNames: ''!

!TextAction class methodsFor: 'as yet unclassified' stamp: 'di 1/14/98 09:30'!
initialize   "TextAction initialize"
	Purple _ Color r: 0.4 g: 0 b: 1.0! !
TextAttribute subclass: #TextAnchor
	instanceVariableNames: 'anchoredMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextAnchor commentStamp: '<historical>' prior: 0!
TextAnchors support anchoring of images in text.  A TextAnchor exists as an attribute of text emphasis, and it gets control like a FontReference, through the emphasizeScanner: message.  Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively.  The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:.

In the morphic world, simply embed any morph in text.  In the old world, you can create an image reference using code such as the following.
	ParagraphEditor new clipboardTextPut:
		(Text string: '*'
			attribute: (TextAnchor new anchoredMorph: Form fromUser))
In this case you select a piece of the screen, and it gets anchored to a one-character text in the editor's past buffer.  If you then paste into some other text, you will see the image as an embedded image.!


!TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 7/1/1998 14:35'!
= other 
	^ (other class == self class) 
		and: [other anchoredMorph == anchoredMorph]! !

!TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 13:21'!
anchoredMorph
	^ anchoredMorph! !

!TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 10:47'!
anchoredMorph: aMorph 
	anchoredMorph _ aMorph! !

!TextAnchor methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 14:34'!
emphasizeScanner: scanner

	scanner placeEmbeddedObject: anchoredMorph! !

!TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 14:08'!
mayBeExtended
	"A textAnchor is designed to modify only a single character, and therefore must not be extended by the ParagraphEditor's emphasisHere facility"
	^ false! !
TextAnchor subclass: #TextAnchorPlus
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!TextAnchorPlus methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 17:27'!
emphasizeScanner: scanner

	anchoredMorph ifNil: [^self].
	(anchoredMorph owner isKindOf: TextPlusPasteUpMorph) ifFalse: [^anchoredMorph _ nil].
	scanner setYFor: anchoredMorph

! !
Object subclass: #TextAttribute
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextAttribute commentStamp: '<historical>' prior: 0!
Tells a piece of text to be a certain way.

Select text, press Command-6, choose a attribute.  If selected text is of the form 
	Hi There<Smalltalk beep>
the part in angle brackets is saved for action, and the Hi There appears in the paragraph.  If selection has no angle brackets, use the whole thing as both the text and the action.

TextDoIt  --  eval as a Smalltalk expression (the part in angle brackets)

TextLink -- Show a method, class comment, class hierarchy, or class defintion.
	<Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type.

TextURL -- Show the web page. <www.disney.com>

These attributes of text need to be stored on the disk in a regular file-out.  It is done in this form: 	(ascii 2)<!!do Smalltalk beep(ascii 3)>Hi There(ascii 3)<!!>
	(ascii 2)<!!li Point extent:(ascii 3)>Click here to see the extent: method(ascii 3)<!!>
The brackets are for people to see in fileOuts.  The wierd ascii are for the scanner to pick up easily.  See RunArray class scanFrom: where decoding is done.
!
]style[(993 24 25)f1,f1LRunArray class scanFrom:;,f1!


!TextAttribute methodsFor: 'as yet unclassified'!
actOnClickFor: model
	"Subclasses may override to provide, eg, hot-spot actions"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:25'!
couldDeriveFromPrettyPrinting
	"Answer whether the receiver is a kind of attribute that could have been generated by doing polychrome pretty-printing of a method without functional text attributes."

	^ true! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:09'!
dominatedByCmd0
	"Subclasses may override if cmd-0 should turn them off"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified'!
dominates: another
	"Subclasses may override condense multiple attributes"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 4/1/1999 15:16'!
emphasisCode
	"Subclasses may override to add bold, italic, etc"
	^ 0! !

!TextAttribute methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Subclasses may override to set, eg, font, color, etc"! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'!
forFontInStyle: aTextStyle do: aBlock
	"No action is the default.  Overridden by font specs"! !

!TextAttribute methodsFor: 'as yet unclassified'!
mayActOnClick
	"Subclasses may override to provide, eg, hot-spot actions"
	^ false! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 11/10/97 14:05'!
mayBeExtended
	"A quality that may be overridden by subclasses, such as TextAnchors, that really only apply to a single character"
	^ true! !

!TextAttribute methodsFor: 'as yet unclassified'!
oldEmphasisCode: default
	"Allows running thorugh possibly multiple attributes
	and getting the emphasis out of any that has an emphasis (font number)"
	^ default! !

!TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:03'!
reset
	"Allow subclasses to prepare themselves for merging attributes"! !

!TextAttribute methodsFor: 'as yet unclassified'!
set
	"Respond true to include this attribute (as opposed to, eg, a bold
	emphasizer that is clearing the property"
	^ true! !


!TextAttribute methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'!
isKern
	^false! !
TextAttribute subclass: #TextColor
	instanceVariableNames: 'color '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextColor commentStamp: '<historical>' prior: 0!
A TextColor encodes a text color change applicable over a given range of text.!


!TextColor methodsFor: 'accessing'!
color
	^ color! !

!TextColor methodsFor: 'accessing'!
color: aColor
	color _ aColor! !


!TextColor methodsFor: 'comparing' stamp: 'di 10/31/97 11:19'!
= other 
	^ (other class == self class) 
		and: [other color = color]! !

!TextColor methodsFor: 'comparing' stamp: 'sma 3/24/2000 10:51'!
hash
	^ color hash! !


!TextColor methodsFor: 'printing' stamp: 'sma 3/24/2000 10:51'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' code: '; print: color! !


!TextColor methodsFor: 'scanning' stamp: 'di 10/31/97 11:20'!
dominates: other
	^ other class == self class! !

!TextColor methodsFor: 'scanning'!
emphasizeScanner: scanner
	"Set the emphasis for text display"
	scanner textColor: color! !

!TextColor methodsFor: 'scanning' stamp: 'tk 12/16/97 09:47'!
writeScanOn: strm
	"Two formats.  c125000255 or cblue;"

	| nn str |
	strm nextPut: $c.
	(nn _ color name) ifNotNil: [
		(self class respondsTo: nn) ifTrue: [
			^ strm nextPutAll: nn; nextPut: $;]].
	(Array with: color red with: color green with: color blue) do: [:float |
		str _ '000', (float * 255) asInteger printString.
		strm nextPutAll: (str copyFrom: str size-2 to: str size)]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextColor class
	instanceVariableNames: ''!

!TextColor class methodsFor: 'constants'!
black
	^ self new color: Color black! !

!TextColor class methodsFor: 'constants'!
blue
	^ self new color: Color blue! !

!TextColor class methodsFor: 'constants'!
cyan
	^ self new color: Color cyan! !

!TextColor class methodsFor: 'constants'!
green
	^ self new color: Color green! !

!TextColor class methodsFor: 'constants'!
magenta
	^ self new color: Color magenta! !

!TextColor class methodsFor: 'constants'!
red
	^ self new color: Color red! !

!TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50'!
white 
	^ self new color: Color white! !

!TextColor class methodsFor: 'constants'!
yellow
	^ self new color: Color yellow! !


!TextColor class methodsFor: 'instance creation'!
color: aColor
	^ self new color: aColor! !

!TextColor class methodsFor: 'instance creation' stamp: 'sma 3/24/2000 10:49'!
scanFrom: strm
	"read a color in the funny format used by Text styles on files. c125000255 or cblue;"

	| r g b |
	strm peek isDigit
		ifTrue:
			[r _ (strm next: 3) asNumber.
			g _ (strm next: 3) asNumber.
			b _ (strm next: 3) asNumber.
			^ self color: (Color r: r g: g b: b range: 255)].
	"A name of a color"
	^ self color: (Color perform: (strm upTo: $;) asSymbol)! !
PluggableTextMorph subclass: #TextComponent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Components'!

!TextComponent methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 20:24'!
initComponentIn: aLayout
	super initComponentIn: aLayout.
	self setText: self getText! !

!TextComponent methodsFor: 'as yet unclassified' stamp: 'di 5/1/1998 23:19'!
initFromPinSpecs
	| ioPin |
	ioPin _ pinSpecs first.
	ioPin isInput ifTrue: [getTextSelector _ ioPin modelReadSelector]
					ifFalse: [getTextSelector _ nil].
	ioPin isOutput ifTrue: [setTextSelector _ ioPin modelWriteSelector]
					ifFalse: [setTextSelector _ nil].
! !

!TextComponent methodsFor: 'as yet unclassified' stamp: 'di 5/1/1998 13:39'!
initPinSpecs 
	pinSpecs _ Array
		with: (PinSpec new pinName: 'text' direction: #inputOutput
				localReadSelector: nil localWriteSelector: nil
				modelReadSelector: getTextSelector modelWriteSelector: setTextSelector
				defaultValue: 'some text' pinLoc: 1.5)! !

!TextComponent methodsFor: 'as yet unclassified' stamp: 'kfr 5/1/2000 13:51'!
initialize
	super initialize.
	self extent: 144@42! !
Object subclass: #TextContainer
	instanceVariableNames: 'textMorph shadowForm vertProfile minWidth rectangleCache fillsOwner avoidsOcclusions '
	classVariableNames: 'OuterMargin '
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextContainer commentStamp: '<historical>' prior: 0!
A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text.  It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm.  It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent.  Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.!


!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'!
avoidsOcclusions
	^ avoidsOcclusions ifNil: [false]! !

!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'!
avoidsOcclusions: aBoolean
	avoidsOcclusions _ aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'access' stamp: 'di 11/4/97 14:05'!
fillsOwner
	^ fillsOwner ifNil: [true]! !

!TextContainer methodsFor: 'access' stamp: 'di 11/13/97 14:45'!
fillsOwner: aBoolean
	fillsOwner _ aBoolean.
	self releaseCachedState! !

!TextContainer methodsFor: 'access' stamp: 'jm 11/19/97 19:28'!
paragraphClass
	^ NewParagraph! !

!TextContainer methodsFor: 'access' stamp: 'di 11/16/97 09:39'!
releaseCachedState

	shadowForm _ nil.
	vertProfile _ nil.
	rectangleCache _ Dictionary new.
! !

!TextContainer methodsFor: 'access' stamp: 'tk 8/31/2000 14:50'!
textMorph
	^ textMorph! !


!TextContainer methodsFor: 'container protocol' stamp: 'di 10/27/97 23:09'!
bottom
	"Note we should really check for contiguous pixels here"
	^ (self vertProfile findLast: [:count | count >= minWidth])
		+ shadowForm offset y! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'!
left 
	^ textMorph owner left! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 9/30/1998 23:17'!
rectanglesAt: lineY height: lineHeight
	"Return a list of rectangles that are at least minWidth wide
	in the specified horizontal strip of the shadowForm.
	Cache the results for later retrieval if the owner does not change."
	| hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm |
	pair _ Array with: lineY with: lineHeight.
	rects _ rectangleCache at: pair ifAbsent: [nil].
	rects ifNotNil: [^ rects].

	outerWidth _ minWidth + (2*OuterMargin).
	self shadowForm.  "Compute the shape".
	lineRect _ 0@(lineY - shadowForm offset y)
					extent: shadowForm width@lineHeight.
	lineForm _ shadowForm copy: lineRect.

	"Check for a full line -- frequent case"
	(lineForm tallyPixelValues at: 2) = lineRect area
	ifTrue:
		[rects _ Array with: (shadowForm offset x@lineY extent: lineRect extent)]
	ifFalse:
		["No such luck -- scan the horizontal profile for segments of minWidth"
		hProfile _ lineForm xTallyPixelValue: 1 orNot: false.
		rects _ OrderedCollection new.
		thisWidth _ 0.  thisX _ 0.
		1 to: hProfile size do:
			[:i | count _ hProfile at: i.
			count >= lineHeight ifTrue:
				[thisWidth _ thisWidth + 1]
				ifFalse:
				[thisWidth >= outerWidth ifTrue:
					[rects addLast: ((thisX + shadowForm offset x)@lineY
									extent: thisWidth@lineHeight)].
				thisWidth _ 0. thisX _ i]].
		thisWidth >= outerWidth ifTrue:
				[rects addLast: ((thisX + shadowForm offset x)@lineY
									extent: thisWidth@lineHeight)]].
	rects _ rects collect: [:r | r insetBy: OuterMargin@0].
	rectangleCache at: pair put: rects.
	^ rects! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 11/16/97 09:33'!
top
	"Note we should really check for contiguous pixels here"
	| outerWidth |
	outerWidth _ minWidth + (2*OuterMargin).
	^ (self vertProfile findFirst: [:count | count >= outerWidth]) - 1
		+ shadowForm offset y! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:33'!
topLeft  "for compatibility"
	^ textMorph owner topLeft! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 11/7/97 12:01'!
translateBy: delta
	self releaseCachedState! !

!TextContainer methodsFor: 'container protocol' stamp: 'di 10/28/97 18:32'!
width  "for compatibility"
	^ textMorph owner width! !


!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:04'!
bounds
	| bounds theText |
	self fillsOwner ifFalse: [^ textMorph textBounds].
	theText _ textMorph.
	bounds _ theText owner innerBounds.
	bounds _ bounds insetBy: (textMorph valueOfProperty: #margins ifAbsent: [1@1]).
	theText owner submorphsBehind: theText do:
		[:m | bounds _ bounds merge: m fullBounds].
	^ bounds! !

!TextContainer methodsFor: 'private' stamp: 'ar 10/26/2000 20:05'!
computeShadow
	| canvas back bounds theText |
	bounds _ self bounds.
	theText _ textMorph.
	canvas _ (Display defaultCanvasClass extent: bounds extent depth: 1)
			shadowColor: Color black.
	canvas translateBy: bounds topLeft negated during:[:tempCanvas|
		self fillsOwner
			ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)]
			ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black].
		self avoidsOcclusions ifTrue:
			[back _ tempCanvas form deepCopy.
			tempCanvas form fillWhite.
			theText owner submorphsInFrontOf: theText do:
				[:m | (textMorph isLinkedTo: m)
					ifTrue: []
					ifFalse: [tempCanvas fullDrawMorph: m]].
			back displayOn: tempCanvas form at: 0@0 rule: Form reverse].
	].
	shadowForm _ canvas form offset: bounds topLeft.
	vertProfile _ shadowForm  yTallyPixelValue: 1 orNot: false.
	rectangleCache _ Dictionary new.
	^ shadowForm! !

!TextContainer methodsFor: 'private' stamp: 'di 11/4/97 14:06'!
for: aTextMorph minWidth: wid
	textMorph _ aTextMorph.
	minWidth _ wid.
	fillsOwner _ true.
	avoidsOcclusions _ false.! !

!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:09'!
shadowForm
	shadowForm ifNil: [self computeShadow].
	^ shadowForm! !

!TextContainer methodsFor: 'private' stamp: 'di 10/27/97 23:08'!
vertProfile
	vertProfile ifNil: [self computeShadow].
	^ vertProfile! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextContainer class
	instanceVariableNames: ''!

!TextContainer class methodsFor: 'initialization' stamp: 'di 11/16/97 09:25'!
initialize    "TextContainer initialize"
	OuterMargin _ 2! !
Object subclass: #TextDiffBuilder
	instanceVariableNames: 'realSrc realDst srcMap dstMap srcLines dstLines srcPos dstPos added removed shifted runs matches multipleMatches patchSequence '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-File Contents Browser'!

!TextDiffBuilder methodsFor: 'printing' stamp: 'sma 5/6/2000 18:15'!
printPatchSequence: seq on: aStream 
	seq do: 
		[:assoc | 
		aStream
			withAttribute: (self attributeOf: assoc key)
			do: [aStream nextPutAll: assoc value; cr]]! !


!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'!
destString: aString 
	realDst _ self split: aString asString.
	dstLines _ OrderedCollection new.
	dstMap _ OrderedCollection new.
	realDst
		doWithIndex: [:line :realIndex | 
			dstLines
				add: (self formatLine: line).
			dstMap add: realIndex].
	dstPos _ PluggableDictionary new: dstLines size.
	dstPos hashBlock: self stringHashBlock.
	dstLines
		doWithIndex: [:line :index | (dstPos includesKey: line)
				ifTrue: [(dstPos at: line)
						add: index.
					multipleMatches _ true]
				ifFalse: [dstPos
						at: line
						put: (OrderedCollection with: index)]]! !

!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'!
formatLine: aString
	^aString! !

!TextDiffBuilder methodsFor: 'initialize'!
from: sourceString to: destString
	self sourceString: sourceString.
	self destString: destString.! !

!TextDiffBuilder methodsFor: 'initialize' stamp: 'nk 10/29/2000 12:15'!
sourceString: aString 
	realSrc _ self split: aString asString.
	srcLines _ OrderedCollection new.
	srcMap _ OrderedCollection new.
	realSrc
		doWithIndex: [:line :realIndex | 
			srcLines
				add: (self formatLine: line).
			srcMap add: realIndex].
	srcPos _ PluggableDictionary new: srcLines size.
	srcPos hashBlock: self stringHashBlock.
	srcLines
		doWithIndex: [:line :index | (srcPos includesKey: line)
				ifTrue: [(srcPos at: line)
						add: index.
					multipleMatches _ true]
				ifFalse: [srcPos
						at: line
						put: (OrderedCollection with: index)]]! !

!TextDiffBuilder methodsFor: 'initialize'!
split: aString
	^self split: aString by: self splitCharacter! !


!TextDiffBuilder methodsFor: 'testing'!
hasMultipleMatches
	^multipleMatches == true! !


!TextDiffBuilder methodsFor: 'creating patches'!
buildDisplayPatch
	^Text streamContents:[:stream|
		self printPatchSequence: self buildPatchSequence on: stream.
	]! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:35'!
buildPatchSequence
	"@@ TODO: Das funktioniert noch nicht fŸr n-m matches"
	matches := PluggableDictionary new.
	matches hashBlock: self pointHashBlock.
	self buildReferenceMap.
	runs := self processDiagonals.
	self validateRuns: runs.
	"There may be things which have just been moved around. Find those."
	shifted := self detectShiftedRuns.
	self processShiftedRuns.
	"Now generate a patch sequence"
	patchSequence := self generatePatchSequence.
	^patchSequence! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:57'!
buildReferenceMap
	dstLines doWithIndex:[:line :index|
		(srcPos at: line ifAbsent:[#()]) 
			do:[:index2| matches at: index@index2 put: line]
	].
	srcLines doWithIndex:[:line :index|
		(dstPos at: line ifAbsent:[#()]) 
			do:[:index2| matches at: index2@index put: line]
	].
! !

!TextDiffBuilder methodsFor: 'creating patches'!
collectRunFrom: todo startingWith: startIndex into: run
	| next start |
	start := startIndex.
	self remove: start from: todo.
	run add: (matches at: start).
	"Search downwards"
	next := start.
	[next := next + (1@1).
	todo includes: next] whileTrue:[
		run addLast: (matches at: next).
		self remove: next from: todo].
	"Search upwards"
	next := start.
	[next := next - (1@1).
	todo includes: next] whileTrue:[
		run addFirst: (matches at: next).
		self remove: next from: todo.
		start := next. "To use the first index"
	].
	^start! !

!TextDiffBuilder methodsFor: 'creating patches'!
detectShiftedRuns
	| sortedRuns lastY run shiftedRuns |
	runs size < 2 ifTrue: [^ nil].
	shiftedRuns _ OrderedCollection new.
	sortedRuns _ SortedCollection sortBlock: [:a1 :a2 | a1 key x < a2 key x].
	runs associationsDo: [:assoc | sortedRuns add: assoc].
	lastY _ sortedRuns first key y.
	2 to: sortedRuns size do:[:i | 
		run _ sortedRuns at: i.
		run key y > lastY
			ifTrue: [lastY _ run key y]
			ifFalse: [shiftedRuns add: run]].
	^ shiftedRuns! !

!TextDiffBuilder methodsFor: 'creating patches'!
generatePatchSequence
	| ps |
	ps := OrderedCollection new: srcLines size.
	srcLines size timesRepeat:[ps add: nil].
	self incorporateMatchesInto: ps.
	self incorporateRemovalsInto: ps.
	self incorporateAddsInto: ps.
	^ps! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'di 3/15/1999 14:01'!
incorporateAddsInto: aPatchSequence
	"Incorporate adds"
	| lastMatch lastIndex index |
	added ifNil:[^self].
	added := added sortBy:[:a1 :a2| a1 key < a2 key].
	lastMatch := 1.
	lastIndex := 0.
	1 to: added size do:[:i|
		index := (added at: i) key.
		[index > lastMatch] whileTrue:[
			[lastIndex := lastIndex + 1.
			(aPatchSequence at: lastIndex) key == #match] whileFalse.
			lastMatch := lastMatch + 1.
		].
		aPatchSequence add: #insert->(added at: i) value afterIndex: lastIndex.
		lastIndex := lastIndex + 1.
		lastMatch := lastMatch + 1.
	].! !

!TextDiffBuilder methodsFor: 'creating patches'!
incorporateMatchesInto: aPatchSequence
	"Incorporate matches"
	| index |
	runs associationsDo:[:assoc|
		index := assoc key y.
		assoc value do:[:line|
			self assert:[(aPatchSequence at: index) isNil].
			aPatchSequence at: index put: (#match -> line).
			index := index + 1.
		].
	].
! !

!TextDiffBuilder methodsFor: 'creating patches'!
incorporateRemovalsInto: aPatchSequence
	"Incorporate removals"
	| index |
	removed ifNil:[^self].
	removed do:[:assoc|
		index := assoc key.
		self assert:[(aPatchSequence at: index) isNil].
		aPatchSequence at: index put: #remove -> assoc value.
	].
! !

!TextDiffBuilder methodsFor: 'creating patches'!
processDiagonals

	^self processDiagonalsFrom: matches keys asSet
! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:34'!
processDiagonalsFrom: todoList
	| runList start run todo |
	todo := todoList copy.
	runList := PluggableDictionary new.
	runList hashBlock: self pointHashBlock.
	[todo isEmpty] whileFalse:[
		start := todo detect:[:any| true].
		run := OrderedCollection new.
		start := self 
					collectRunFrom: todo 
					startingWith: start 
					into: run.
		runList at: start put: run.
	].
	"If we have multiple matches we might have chosen a bad sequence.
	There we redo the whole thing recursively"
	self hasMultipleMatches  ifFalse:[^runList].
	runList size < 2 ifTrue:[^runList].

	run := nil.
	start := 0.
	runList associationsDo:[:assoc|
		(run isNil or:[assoc value size > run size]) ifTrue:[
			run := assoc value.
			start := assoc key]].
	"Now found the longest run"
	run := OrderedCollection new.
	start := self
				collectRunFrom: todoList
				startingWith: start
				into: run.
	"Find the diagonals in the remaining set"
	runList := self processDiagonalsFrom: todoList.
	runList at: start put: run.
	^runList! !

!TextDiffBuilder methodsFor: 'creating patches'!
processShiftedRuns
	| key |
	shifted isNil ifTrue:[^self].
	shifted do:[:assoc|
		key := assoc key.
		assoc value doWithIndex:[:line :idx|
			removed add: (key y + idx - 1) -> line.
			added add: (key x + idx - 1) -> line].
		runs removeKey: assoc key.
	].
! !

!TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 17:26'!
validateRuns: runList
	| srcPosCopy dstPosCopy lines srcIndex dstIndex |
	srcPosCopy _ srcPos copy.
	srcPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
	dstPosCopy _ dstPos copy.
	dstPosCopy associationsDo:[:assoc| assoc value: assoc value asSet].
	runList associationsDo:[:assoc|
		srcIndex := assoc key y.
		dstIndex := assoc key x.
		lines := assoc value.
		lines do:[:string|
			(srcPosCopy at: string) remove: srcIndex.
			(dstPosCopy at: string) remove: dstIndex.
			srcIndex := srcIndex + 1.
			dstIndex := dstIndex + 1.
		].
	].
	removed := OrderedCollection new.
	srcPosCopy associationsDo:[:assoc|
		assoc value do:[:index| removed add: (index -> assoc key)].
	].
	removed := removed sortBy:[:a1 :a2| a1 key < a2 key].
	added := OrderedCollection new.
	dstPosCopy associationsDo:[:assoc|
		assoc value do:[:index| added add: (index -> assoc key)].
	].
	added := added sortBy:[:a1 :a2| a1 key < a2 key].
! !


!TextDiffBuilder methodsFor: 'private' stamp: 'sma 5/6/2000 18:13'!
attributeOf: type
	"Private. Answer a TextAttribute that is used to display text of the given type."

	type == #insert ifTrue: [^ TextColor red].
	type == #remove ifTrue: [^ TextEmphasis struckOut].
	^ TextEmphasis normal! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 16:35'!
pointHashBlock
	^[:pt| (pt x bitShift: 12) + pt y] fixTemps! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 16:31'!
remove: pointKey from: aSet
	self hasMultipleMatches ifFalse:[^aSet remove: pointKey].
	aSet copy do:[:obj|
		obj x = pointKey x ifTrue:[
			aSet remove: obj.
		] ifFalse:[
			obj y = pointKey y ifTrue:[
				aSet remove: obj.
			].
		]
	].
! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 17:26'!
split: aString by: splitChar
	| lines index nextIndex |
	lines := OrderedCollection new.
	index _ 1.
	[index <= aString size] whileTrue:[
		nextIndex _ aString 
						indexOf: splitChar 
						startingAt: index 
						ifAbsent:[aString size+1].
		lines add: (aString copyFrom: index to: nextIndex-1).
		index _ nextIndex+1].
	^lines! !

!TextDiffBuilder methodsFor: 'private'!
splitCharacter
	^Character cr! !

!TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/24/1998 13:41'!
stringHashBlock
	"Return a block for use in string hashing"
	| stringSize |
	^[:string| 
		stringSize _ string size.
		stringSize = 0 
			ifTrue:[0]
			ifFalse:[ stringSize < 3 
				ifTrue:[(string at: 1) asInteger +
						((string at: string size) asInteger bitShift: 8)]
				ifFalse:[	(string at: 1) asInteger +
						((string at: stringSize // 3 + 1) asInteger bitShift: 4) +
						((string at: stringSize // 2 + 1) asInteger bitShift: 8) +
						((string at: stringSize * 2 // 3 + 1) asInteger bitShift: 12) +
						((string at: stringSize) asInteger bitShift: 16)]]] fixTemps! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextDiffBuilder class
	instanceVariableNames: ''!

!TextDiffBuilder class methodsFor: 'instance creation'!
buildDisplayPatchFrom: srcString to: dstString
	^(self from: srcString to: dstString) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation' stamp: 'nk 10/29/2000 12:38'!
buildDisplayPatchFrom: srcString to: dstString inClass: srcClass 
	^ ((srcClass notNil and: [ (Preferences valueOfFlag: #diffsWithPrettyPrint) ])
		ifTrue: [PrettyTextDiffBuilder
				from: srcString
				to: dstString
				inClass: srcClass]
		ifFalse: [self from: srcString to: dstString]) buildDisplayPatch! !

!TextDiffBuilder class methodsFor: 'instance creation'!
from: srcString to: dstString
	^self new from: srcString to: dstString! !
TextAction subclass: #TextDoIt
	instanceVariableNames: 'evalString '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'!
actOnClickFor: anObject
	"Note: evalString gets evaluated IN THE CONTEXT OF anObject
	 -- meaning that self and all instVars are accessible"
	Compiler evaluate: evalString for: anObject logged: false.
	^ true ! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:46'!
analyze: aString

	| list |
	list _ super analyze: aString.
	evalString _ list at: 1.
	^ list at: 2! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:01'!
evalString: str
	evalString _ str ! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ evalString! !

!TextDoIt methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:46'!
writeScanOn: strm

	strm nextPut: $d; nextPutAll: evalString; nextPutAll: ';;'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextDoIt class
	instanceVariableNames: ''!

!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/6/97 20:28'!
evalString: str
	^ self new evalString: str! !

!TextDoIt class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:06'!
scanFrom: strm
	"read a doit in the funny format used by Text styles on files. d10 factorial;;  end with two semicolons"

	| pos end doit |
	pos _ strm position.
	[strm skipTo: $;. strm peek == $;] whileFalse.
	end _ strm position - 1.
	strm position: pos.
	doit _ strm next: end-pos.
	strm skip: 2.  ";;"
	^ self evalString: doit! !
TextAttribute subclass: #TextEmphasis
	instanceVariableNames: 'emphasisCode setMode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextEmphasis commentStamp: '<historical>' prior: 0!
A TextEmphasis, encodes a characteristic applicable to all fonts.  The encoding is as follows:
	1	bold
	2	itallic
	4	underlined
	8	narrow
	16	struck out!


!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other emphasisCode = emphasisCode]! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:11'!
dominatedByCmd0
	"Cmd-0 should turn off emphasis"
	^ true! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:13'!
dominates: other
	(emphasisCode = 0 and: [other dominatedByCmd0]) ifTrue: [^ true].
	^ (other class == self class)
		and: [emphasisCode = other emphasisCode]! !

!TextEmphasis methodsFor: 'as yet unclassified'!
emphasisCode
	^ emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified'!
emphasisCode: int
	emphasisCode _ int.
	setMode _ true! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:57'!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner addEmphasis: emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified'!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' code: '; print: emphasisCode! !

!TextEmphasis methodsFor: 'as yet unclassified'!
set
	^ setMode and: [emphasisCode ~= 0]! !

!TextEmphasis methodsFor: 'as yet unclassified'!
turnOff
	setMode _ false! !

!TextEmphasis methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:28'!
writeScanOn: strm

	emphasisCode = 1 ifTrue: [strm nextPut: $b].
	emphasisCode = 2 ifTrue: [strm nextPut: $i].
	emphasisCode = 0 ifTrue: [strm nextPut: $n].
	emphasisCode = 16 ifTrue: [strm nextPut: $=].
	emphasisCode = 4 ifTrue: [strm nextPut: $u].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextEmphasis class
	instanceVariableNames: ''!

!TextEmphasis class methodsFor: 'as yet unclassified'!
bold
	^ self new emphasisCode: 1! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
italic
	^ self new emphasisCode: 2! !

!TextEmphasis class methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:05'!
narrow
	^ TextKern kern: -1! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
normal
	^ self new emphasisCode: 0! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
struckOut
	^ self new emphasisCode: 16! !

!TextEmphasis class methodsFor: 'as yet unclassified'!
underlined
	^ self new emphasisCode: 4! !
RectangleMorph subclass: #TextFieldMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextFieldMorph commentStamp: '<historical>' prior: 0!
Act as a field in a HyperCard-like setting.  Has both properties of a Rectangle, and exposes some proteries of the TextMorph it owns.

!


!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/6/2000 11:03'!
append: stringOrText
	"add to my text"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm contents append: stringOrText.
	tm releaseParagraph; paragraph.


	! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 8/30/2000 14:22'!
contents
	| tm |
	"talk to my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm contents! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/1/2000 14:03'!
contents: textOrString
	"talk to my text"
	| tm newText atts |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	textOrString class == String ifTrue: [
		tm contents ifNotNil: ["Keep previous properties of the field"
			newText _ textOrString asText.
			atts _ tm contents attributesAt: 1.
			atts do: [:each | newText addAttribute: each].
			^ tm contents: newText]].

	^ tm contents: textOrString! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'sw 10/30/2000 09:03'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ self contents! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/4/2000 16:28'!
fit
	"tell my text to recompute its looks"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm releaseParagraph; paragraph.! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 8/30/2000 14:24'!
fontName: fontName size: fontSize
	| tm |
	"talk to my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm fontName: fontName size: fontSize
! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'sw 10/30/2000 16:52'!
initialize
	"set up the field"

	| tm |
	super initialize.
	self color: Color veryLightGray lighter.
	self addMorph: (tm _ TextMorph new).
	tm fillingOnOff.  "filling on"! !

!TextFieldMorph methodsFor: 'just like textMorph' stamp: 'tk 9/6/2000 12:33'!
lineCount
	| tm |
	"how many lines in my text"

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	^ tm contents string lineCount! !


!TextFieldMorph methodsFor: 'card & stack' stamp: 'tk 1/6/2001 14:20'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !

!TextFieldMorph methodsFor: 'card & stack' stamp: 'tk 1/6/2001 14:15'!
setNewContentsFrom: textOrString
	"talk to my text"
	| tm |

	(tm _ self findA: TextMorph) ifNil: [^ nil].
	tm valueOfProperty: #cardInstance ifAbsent: ["move it down"
		tm setProperty: #cardInstance toValue: (self valueOfProperty: #cardInstance)].
	tm valueOfProperty: #holdsSeparateDataForEachInstance ifAbsent: ["move it down"
		tm setProperty: #holdsSeparateDataForEachInstance toValue: 
			(self valueOfProperty: #holdsSeparateDataForEachInstance)].
	^ tm setNewContentsFrom: textOrString! !

!TextFieldMorph methodsFor: 'card & stack' stamp: 'tk 1/6/2001 13:58'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #contents morphPutSelector: #setNewContentsFrom:)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFieldMorph class
	instanceVariableNames: ''!

!TextFieldMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 09:02'!
authoringPrototype 
	"Answer an instance of the receiver that can serve as a prototype for authoring"

	| proto |
	proto _ super authoringPrototype.
	proto setProperty: #shared toValue: true.
	proto extent: 170 @ 30.
	proto color: Color veryLightGray lighter.
	proto contents: 'on a clear day you can...'..
	^ proto
! !
TextAttribute subclass: #TextFontChange
	instanceVariableNames: 'fontNumber '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextFontChange commentStamp: '<historical>' prior: 0!
A TextFontChange encodes a font change applicable over a given range of text.  The font number is interpreted relative to the textStyle governing display of this text.!


!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other fontNumber = fontNumber]! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:20'!
dominates: other
	^ other class == self class! !

!TextFontChange methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Set the font for text display"
	scanner setFont: fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified'!
fontNumber
	^ fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified'!
fontNumber: int
	fontNumber _ int! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:46'!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: (aTextStyle fontAt: fontNumber)! !

!TextFontChange methodsFor: 'as yet unclassified'!
printOn: strm
	super printOn: strm.
	strm nextPutAll: ' font: '; print: fontNumber! !

!TextFontChange methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:22'!
writeScanOn: strm

	strm nextPut: $f.
	fontNumber printOn: strm.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFontChange class
	instanceVariableNames: ''!

!TextFontChange class methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 17:52'!
defaultFontChange
	"Answer a TextFontChange that represents the default font"

	^ self new fontNumber: TextStyle default defaultFontIndex! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font1
	^ self new fontNumber: 1! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font2
	^ self new fontNumber: 2! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font3
	^ self new fontNumber: 3! !

!TextFontChange class methodsFor: 'as yet unclassified'!
font4
	^ self new fontNumber: 4! !

!TextFontChange class methodsFor: 'as yet unclassified'!
fontNumber: n
	^ self new fontNumber: n! !
TextFontChange subclass: #TextFontReference
	instanceVariableNames: 'font '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextFontReference commentStamp: '<historical>' prior: 0!
A TextFontReference encodes a font change applicable over a given range of text.  The font reference is absolute:  unlike a TextFontChange, it is independent of the textStyle governing display of this text.!


!TextFontReference methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:22'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextFontReference methodsFor: 'as yet unclassified'!
emphasizeScanner: scanner
	"Set the actual font for text display"
	scanner setActualFont: font! !

!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 5/10/1999 23:47'!
font

	^ font! !

!TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 11/9/97 17:47'!
forFontInStyle: aTextStyle do: aBlock
	aBlock value: font! !

!TextFontReference methodsFor: 'as yet unclassified'!
toFont: aFont

	font _ aFont! !


!TextFontReference methodsFor: 'comparing' stamp: 'mas 5/7/1999 06:20'!
= other 
	^ (other class == self class) 
		and: [other font == font]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextFontReference class
	instanceVariableNames: ''!

!TextFontReference class methodsFor: 'as yet unclassified'!
toFont: aFont
	^ self new toFont: aFont! !
TextAttribute subclass: #TextIndent
	instanceVariableNames: 'amount '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextIndent commentStamp: '<historical>' prior: 0!
create a hanging indent. !


!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'!
amount
	"number of tab spaces to indent by"
	^amount! !

!TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'!
amount: anInteger
	"change the number of tabs to indent by"
	amount _ anInteger! !


!TextIndent methodsFor: 'printing' stamp: 'ls 6/22/1998 18:03'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' amount: '.
	amount printOn: aStream! !


!TextIndent methodsFor: 'setting indentation' stamp: 'ls 6/22/1998 18:56'!
emphasizeScanner: scanner
	scanner indentationLevel: amount! !


!TextIndent methodsFor: 'condensing' stamp: 'ls 6/22/1998 19:27'!
dominates: anAttribute
	^(self class == anAttribute class)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextIndent class
	instanceVariableNames: ''!

!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:55'!
amount: amount
	"create a TextIndent which will indent by the given amount.  Currently this is a number of tabs, but may change in the futur"
	^super new amount: amount! !

!TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:54'!
tabs: numTabs
	"create an indentation by the given number of tabs"
	^self amount: numTabs! !


!TextIndent class methodsFor: 'example' stamp: 'ls 6/24/1998 18:06'!
example
	"TextIndent example"
	| text pg |

	"create an example text with some indentation"
	text _ 'abcdao euoaeuo aeuo aeuoaeu o aeuoeauefgh bcd efghi'  asText.
	text addAttribute: (TextColor red)  from: 3 to: 8.
	text addAttribute: (TextIndent amount: 1) from: 1 to: 2.
	text addAttribute: (TextIndent amount: 2) from: 20 to: 35.

	"stick it in a paragraph and display it"
	pg _ text asParagraph.
	pg compositionRectangle: (0@0 extent: 100@200).
	pg textStyle alignment: 2.
	pg displayAt: 0@0.
! !
FormInput subclass: #TextInput
	instanceVariableNames: 'name defaultValue textMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!TextInput commentStamp: '<historical>' prior: 0!
a textual input; it takes text input straight from the user via a PluggableText!


!TextInput methodsFor: 'private-initialization' stamp: 'ls 8/5/1998 04:01'!
name: name0  defaultValue: defaultValue0  textMorph: textMorph0
	name _ name0.
	defaultValue _ defaultValue0.
	textMorph _ textMorph0.! !


!TextInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 06:34'!
name
	^name! !

!TextInput methodsFor: 'input handling' stamp: 'ls 8/5/1998 09:02'!
reset
	textMorph setText: defaultValue! !

!TextInput methodsFor: 'input handling' stamp: 'di 3/10/1999 08:45'!
value
	textMorph hasUnacceptedEdits ifTrue: [ textMorph accept ].
	^textMorph getText asString withInternetLineEndings! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextInput class
	instanceVariableNames: ''!

!TextInput class methodsFor: 'instance creation' stamp: 'ls 8/5/1998 06:23'!
name: name0  defaultValue: defaultValue  textMorph: textMorph
	^self new name: name0  defaultValue: defaultValue  textMorph: textMorph
	! !
TextAttribute subclass: #TextKern
	instanceVariableNames: 'kern active '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextKern commentStamp: '<historical>' prior: 0!
A TextKern encodes a kerning change applicable over a given range of text.  Positive values of kern spread letters out, negative kern will cause them to overlap more.  Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. !


!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:15'!
= other 
	^ (other class == self class) 
		and: [other kern = kern]! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'!
couldDeriveFromPrettyPrinting
	^ false! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 13:10'!
dominatedByCmd0
	"Cmd-0 should turn off kerning"
	^ true! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:10'!
dominates: other
	"NOTE: The use of active in this code is specific to its use in the method
		Text class addAttribute: att toArray: others"
	(active and: [other class == self class and: [other kern + kern = 0]])
		ifTrue: [active _ false.  ^ true].  "can only dominate once"
	^ false! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:50'!
emphasizeScanner: scanner
	"Augment (or diminish) the kerning offset for text display"
	scanner addKern: kern! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:12'!
kern
	^ kern! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 09:59'!
kern: kernValue
	kern _ kernValue.
	self reset.! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:04'!
reset
	active _ true! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'di 10/31/97 11:11'!
set
	^ active! !

!TextKern methodsFor: 'as yet unclassified' stamp: 'tk 9/21/1999 15:57'!
writeScanOn: strm

	kern > 0 ifTrue: [
		1 to: kern do: [:kk | strm nextPut: $+]].
	kern < 0 ifTrue: [
		1 to: 0-kern do: [:kk | strm nextPut: $-]].! !


!TextKern methodsFor: 'testing' stamp: 'ar 9/21/2000 14:16'!
isKern
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextKern class
	instanceVariableNames: ''!

!TextKern class methodsFor: 'as yet unclassified' stamp: 'di 10/29/97 11:49'!
kern: kernValue
	^ self new kern: kernValue! !
Object subclass: #TextLine
	instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextLine commentStamp: '<historical>' prior: 0!
A TextLine embodies the layout of a line of composed text.
	left right top bottom		The full line rectangle
	firstIndex lastIndex		Starting and stopping indices in the full text
	internalSpaces		Number of spaces to share paddingWidth
	paddingWidth		Number of pixels of extra space in full line
	baseline				Distance of baseline below the top of the line
	leftMargin			Left margin due to paragraph indentation
TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.!


!TextLine methodsFor: 'accessing'!
baseline
	^ baseline! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
bottom
	^ bottom! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
bottomRight
	^ right@bottom! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:12'!
first
	^ firstIndex! !

!TextLine methodsFor: 'accessing'!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!TextLine methodsFor: 'accessing'!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces _ spacesInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:14'!
last
	^ lastIndex! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
left
	^ left! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'!
leftMargin
	"This has to get fixed -- store during composition"
	^ self left! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:47'!
leftMargin: lm
	leftMargin _ lm! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/26/97 16:03'!
leftMarginForAlignment: alignmentCode
	alignmentCode = 1 ifTrue: [^ self left + paddingWidth].  "right flush"
	alignmentCode = 2 ifTrue: [^ self left + (paddingWidth//2)].  "centered"
	^ self left  "leftFlush and justified"! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
lineHeight
	^ bottom - top! !

!TextLine methodsFor: 'accessing'!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!TextLine methodsFor: 'accessing'!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth _ padWidthInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 20:00'!
rectangle
	^ self topLeft corner: self bottomRight! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:59'!
rectangle: lineRectangle
	left _ lineRectangle left.
	right _ lineRectangle right.
	top _ lineRectangle top.
	bottom _ lineRectangle bottom.
	leftMargin _ left! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
right
	^ right! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/21/97 20:42'!
rightMargin
	"This has to get fixed -- store during composition"
	^ self right! !

!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:18'!
setRight: x
	right _ x! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/20/97 23:27'!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	lastIndex _ stopInteger! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
top
	^ top! !

!TextLine methodsFor: 'accessing' stamp: 'di 10/23/97 19:58'!
topLeft
	^ left @ top! !

!TextLine methodsFor: 'accessing' stamp: 'di 11/26/97 16:58'!
width
	^ right - left! !


!TextLine methodsFor: 'comparing' stamp: 'di 10/20/97 23:24'!
= line

	self species = line species
		ifTrue: [^((firstIndex = line first and: [lastIndex = line last])
				and: [internalSpaces = line internalSpaces])
				and: [paddingWidth = line paddingWidth]]
		ifFalse: [^false]! !


!TextLine methodsFor: 'scanning'!
justifiedPadFor: spaceIndex 
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [^pad + 1]
		ifFalse: [^pad]! !

!TextLine methodsFor: 'scanning'!
justifiedTabDeltaFor: spaceIndex 
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	extraPad _ paddingWidth \\ internalSpaces.
	spaceIndex <= extraPad
		ifTrue: [^spaceIndex * (pad + 1)]
		ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! !


!TextLine methodsFor: 'updating' stamp: 'di 11/7/97 08:32'!
moveBy: delta 
	"Move my rectangle by the given delta"
	left _ left + delta x.
	right _ right + delta x.
	top _ top + delta y.
	bottom _ bottom + delta y.
! !

!TextLine methodsFor: 'updating' stamp: 'di 10/20/97 23:25'!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	firstIndex _ firstIndex + delta.
	lastIndex _ lastIndex + delta! !

!TextLine methodsFor: 'updating' stamp: 'di 4/28/1999 11:12'!
slideIndexBy: delta andMoveTopTo: newTop
	"Relocate my character indices and y-values.
	Used to slide constant text up or down in the wake of a text replacement."

	firstIndex _ firstIndex + delta.
	lastIndex _ lastIndex + delta.
	bottom _ bottom + (newTop - top).
	top _ newTop.
! !


!TextLine methodsFor: 'private' stamp: 'di 10/20/97 23:08'!
firstIndex: firstInteger lastIndex: lastInteger
	firstIndex _ firstInteger.
	lastIndex _ lastInteger! !

!TextLine methodsFor: 'private'!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces _ spacesInteger.
	paddingWidth _ padWidthInteger! !

!TextLine methodsFor: 'private' stamp: 'di 10/23/97 19:57'!
lineHeight: height baseline: ascent
	bottom _ top + height.
	baseline _ ascent! !

!TextLine methodsFor: 'private' stamp: 'di 10/23/97 23:19'!
printOn: aStream
	super printOn: aStream.
	aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLine class
	instanceVariableNames: ''!

!TextLine class methodsFor: 'instance creation' stamp: 'di 10/20/97 23:08'!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	| line |
	line _ self new firstIndex: startInteger lastIndex: stopInteger.
	^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! !
Interval subclass: #TextLineInterval
	instanceVariableNames: 'internalSpaces paddingWidth lineHeight baseline '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!TextLineInterval commentStamp: '<historical>' prior: 0!
My instances specify the starting and stopping points in a String of a composed line. The step is always 1.!


!TextLineInterval methodsFor: 'accessing'!
baseline
	^ baseline! !

!TextLineInterval methodsFor: 'accessing'!
internalSpaces
	"Answer the number of spaces in the line."

	^internalSpaces! !

!TextLineInterval methodsFor: 'accessing'!
internalSpaces: spacesInteger 
	"Set the number of spaces in the line to be spacesInteger."

	internalSpaces _ spacesInteger! !

!TextLineInterval methodsFor: 'accessing'!
lineHeight
	^ lineHeight! !

!TextLineInterval methodsFor: 'accessing'!
paddingWidth
	"Answer the amount of space to be added to the font."

	^paddingWidth! !

!TextLineInterval methodsFor: 'accessing'!
paddingWidth: padWidthInteger 
	"Set the amount of space to be added to the font to be padWidthInteger."

	paddingWidth _ padWidthInteger! !

!TextLineInterval methodsFor: 'accessing'!
stop: stopInteger 
	"Set the stopping point in the string of the line to be stopInteger."

	stop _ stopInteger! !


!TextLineInterval methodsFor: 'comparing'!
= line

	self species = line species
		ifTrue: [^((start = line first and: [stop = line last])
				and: [internalSpaces = line internalSpaces])
				and: [paddingWidth = line paddingWidth]]
		ifFalse: [^false]! !


!TextLineInterval methodsFor: 'scanning'!
justifiedPadFor: spaceIndex 
	"Compute the width of pad for a given space in a line of justified text."

	| pad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	spaceIndex <= (paddingWidth \\ internalSpaces)
		ifTrue: [^pad + 1]
		ifFalse: [^pad]! !

!TextLineInterval methodsFor: 'scanning'!
justifiedTabDeltaFor: spaceIndex 
	"Compute the delta for a tab in a line of justified text, so tab falls 
	somewhere plausible when line is justified."

	| pad extraPad |
	internalSpaces = 0 ifTrue: [^0].
	pad _ paddingWidth // internalSpaces.
	extraPad _ paddingWidth \\ internalSpaces.
	spaceIndex <= extraPad
		ifTrue: [^spaceIndex * (pad + 1)]
		ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! !


!TextLineInterval methodsFor: 'updating'!
slide: delta 
	"Change the starting and stopping points of the line by delta."

	start _ start + delta.
	stop _ stop + delta! !


!TextLineInterval methodsFor: 'private'!
internalSpaces: spacesInteger paddingWidth: padWidthInteger

	internalSpaces _ spacesInteger.
	paddingWidth _ padWidthInteger! !

!TextLineInterval methodsFor: 'private'!
lineHeight: height baseline: ascent

	lineHeight _ height.
	baseline _ ascent! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLineInterval class
	instanceVariableNames: ''!

!TextLineInterval class methodsFor: 'instance creation'!
start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger
	"Answer an instance of me with the arguments as the start, stop points, 
	number of spaces in the line, and width of the padding."
	| newSelf |
	newSelf _ super from: startInteger to: stopInteger by: 1.
	^newSelf internalSpaces: spacesInteger paddingWidth: padWidthInteger! !
TextAction subclass: #TextLink
	instanceVariableNames: 'classAndMethod '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/28/97 23:11'!
actOnClickFor: anObject
	"Open an new LinkedMessageSet and show this method in it.  If anObject is already a LinkedMessageSet, then just add to the end of the list.  (Class method) (Class Comment) (Class Definition) (Class Hierarchy)"

	anObject linkMethod: classAndMethod.
	^ true! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:49'!
analyze: aString

	| list |
	list _ super analyze: aString.
	classAndMethod _ list at: 1.
	^ list at: 2! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/6/97 20:52'!
analyze: aString with: nonMethod
	"Initalize this attribute holder with a piece text the user typed into a paragraph.  Returns the text to emphesize (may be different from selection)  Does not return self!!.  nonMethod is what to show when clicked, i.e. the last part of specifier (Comment, Definition, or Hierarchy).  May be of the form:
Point
<Point>
Click Here<Point>
<Point>Click Here
"
	"Obtain the showing text and the instructions"
	| b1 b2 trim |
	b1 _ aString indexOf: $<.
	b2 _ aString indexOf: $>.
	(b1 < b2) & (b1 > 0) ifFalse: ["only one part"
		classAndMethod _ self validate: aString, ' ', nonMethod.
		^ classAndMethod size = 0 ifTrue: [nil] ifFalse: [aString]].
	"Two parts"
	trim _ aString withBlanksTrimmed.
	(trim at: 1) == $< 
		ifTrue: [(trim last) == $>
			ifTrue: ["only instructions" 
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod size = 0 ifTrue: [nil] ifFalse: [classAndMethod]]
			ifFalse: ["at the front"
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: b2+1 to: aString size]]]
		ifFalse: [(trim last) == $>
			ifTrue: ["at the end"
				classAndMethod _ self validate: (aString copyFrom: b1+1 to: b2-1), ' ', nonMethod.
				^ classAndMethod size = 0 ifTrue: [nil] 
						ifFalse: [aString copyFrom: 1 to: b1-1]]
			ifFalse: ["Illegal -- <> has text on both sides"
				^ nil]]
! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/5/97 17:09'!
classAndMethod: aString
	classAndMethod _ aString! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ classAndMethod! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/6/97 19:28'!
validate: specString
	"Can this string be decoded to be Class space Method (or Comment, Definition, Hierarchy)? If so, return it in valid format, else nil" 

	| list first mid last |
	list _ specString findTokens: ' 	.|'.
	list size > 3 ifTrue: [^ nil].
	list size < 2 ifTrue: [^ nil].
	Symbol hasInterned: list first ifTrue: [:sym | first _ sym].
	first ifNil: [^ nil].
	Smalltalk at: first ifAbsent: [^ nil].
	mid _ list size = 3 
		ifTrue: [(list at: 2) = 'class' ifTrue: ['class '] ifFalse: [^ nil]]
		ifFalse: [''].
	"OK if method name is not interned -- may not be defined yet"
	last _ list last.
	last first isUppercase ifTrue: [
		(#('Comment' 'Definition' 'Hierarchy') includes: last) ifFalse: [^ nil]].
	^ first, ' ', mid, last! !

!TextLink methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:44'!
writeScanOn: strm

	strm nextPut: $L; nextPutAll: classAndMethod; nextPut: $;! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextLink class
	instanceVariableNames: ''!

!TextLink class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:53'!
scanFrom: strm
	"read a link in the funny format used by Text styles on files. LPoint +;LPoint Comment;"

	^ self new classAndMethod: (strm upTo: $;)! !
TextAttribute subclass: #TextMessageLink
	instanceVariableNames: 'message '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Mail Reader'!
!TextMessageLink commentStamp: '<historical>' prior: 0!
A link to a hidden mail message.  Clicking on it allows the message to be viewed or saved to disk.!


!TextMessageLink methodsFor: 'initialization' stamp: 'ls 4/30/2000 18:54'!
initialize: message0
	message := message0! !


!TextMessageLink methodsFor: 'acting' stamp: 'sbw 1/21/2001 19:48'!
actOnClickFor: evt 
	| choice viewMsg |
	viewMsg _ message containsViewableImage
		ifTrue: ['view this image attachment']
		ifFalse: ['view this attachment'].
	choice _ (PopUpMenu labels: viewMsg, '\save this attachment' withCRs) startUp.
	choice = 1
		ifTrue: ["open a new viewer"
			message viewBody].
	choice = 2
		ifTrue: ["save the mesasge"
			message save].
	^ true! !

!TextMessageLink methodsFor: 'acting' stamp: 'ls 4/30/2000 19:03'!
mayActOnClick
	^true! !


!TextMessageLink methodsFor: 'appearance' stamp: 'ls 4/30/2000 20:34'!
emphasizeScanner: scanner
	scanner textColor: Color brown! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMessageLink class
	instanceVariableNames: ''!

!TextMessageLink class methodsFor: 'instance creation' stamp: 'ls 4/30/2000 19:00'!
message: aMessage
	^super new initialize: aMessage! !
Morph subclass: #TextMorph
	instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor '
	classVariableNames: 'CaretForm '
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TextMorph commentStamp: '<historical>' prior: 0!
TextMorphs support display of text with emphasis.  They also support reasonable text-editing capabilities, as well as imbedded hot links, and the (soon to be released) ability to embed submorphs in the text.  If text has been embedded in another object, one can elect to fill the owner's bounds, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs othe than the text).  One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it.  It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape.!


!TextMorph methodsFor: 'initialization' stamp: 'di 12/29/97 14:42'!
beAllFont: aFont

	textStyle _ TextStyle fontArray: (Array with: aFont).
	self releaseCachedState; changed! !

!TextMorph methodsFor: 'initialization' stamp: 'sw 10/2/97 15:16'!
configureForKids
	super configureForKids.
	self lock! !

!TextMorph methodsFor: 'initialization' stamp: 'di 11/12/97 09:31'!
copy
	^ super copy text: text copy textStyle: textStyle copy 
		wrap: wrapFlag color: color
		predecessor: nil successor: nil! !

!TextMorph methodsFor: 'initialization' stamp: 'di 9/30/97 09:25'!
initialize
	super initialize.
	color _ Color black.
	textStyle _ TextStyle default copy.
	wrapFlag _ true.
! !

!TextMorph methodsFor: 'initialization' stamp: 'jm 11/13/97 16:32'!
releaseCachedState

	super releaseCachedState.
	self releaseParagraph.
! !

!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:34'!
string: aString fontName: aName size: aSize

	self string: aString fontName: aName size: aSize wrap: true! !

!TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:35'!
string: aString fontName: aName size: aSize wrap: shouldWrap

	shouldWrap
		ifTrue: [self contentsWrapped: aString]
		ifFalse: [self contents: aString].
	self fontName: aName size: aSize! !


!TextMorph methodsFor: 'accessing' stamp: 'sw 1/12/98 23:40'!
asText
	^ text! !

!TextMorph methodsFor: 'accessing'!
contents

	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 15:48'!
contents: stringOrText
	^ self contentsAsIs: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 4/14/98 08:33'!
contents: stringOrText wrappedTo: width
	"Accept new text contents.  Lay it out, wrapping to width.
	Then fit my height to the result."
	self newContents: ''.
	wrapFlag _ true.
	super extent: width truncated@self height.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 8/31/2000 14:59'!
contentsAsIs: stringOrText
	"Accept new text contents with line breaks only as in the text.
	Fit my width and height to the result."
	wrapFlag _ false.
	container ifNotNil: [container fillsOwner ifTrue: [wrapFlag _ true]].
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 9/30/97 09:51'!
contentsWrapped: stringOrText
	"Accept new text contents.  Lay it out, wrapping within my current width.
	Then fit my height to the result."
	wrapFlag _ true.
	self newContents: stringOrText! !

!TextMorph methodsFor: 'accessing' stamp: 'di 9/29/97 11:47'!
copyRecordingIn: dict
	"Overridden to copy deeper text structure."
	^ (super copyRecordingIn: dict)
		text: text copy textStyle: textStyle copy! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 10/30/2000 09:01'!
currentDataValue
	"Answer the current data value held by the receiver"

	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'di 10/5/1998 13:56'!
editor
	"Return my current editor, or install a new one."
	editor ifNotNil: [^ editor].
	^ self installEditorToReplace: nil! !

!TextMorph methodsFor: 'accessing' stamp: 'mir 8/2/1999 10:33'!
fontName: fontName size: fontSize
	| newTextStyle |
	newTextStyle _ (TextStyle named: fontName asSymbol) copy.
	newTextStyle ifNil: [self halt: 'Error: font ', fontName, ' not found.'].

	textStyle _ newTextStyle.
	text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)).
	paragraph ifNotNil: [paragraph textStyle: newTextStyle]! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 8/28/2000 09:23'!
getCharacters
	"obtain a string value from the receiver"

	^ text string copy! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:43'!
getFirstCharacter
	"obtain the first character from the receiver if it is empty, return a black dot"

	| aString |
	^ (aString _ text string) size > 0 ifTrue: [aString first] ifFalse: ['¥']! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 1/10/2001 14:09'!
newContents: stringOrText 
	"Accept new text contents."
	| newText embeddedMorphs |
	newText _ stringOrText copy asText.	"should be veryDeepCopy?"
	text = newText ifTrue: [^ self].	"No substantive change"
	text ifNotNil: [(embeddedMorphs _ text embeddedMorphs)
			ifNotNil: 
				[self removeAllMorphsIn: embeddedMorphs.
				embeddedMorphs do: [:m | m delete]]].

	text _ newText.

	"add all morphs off the visible region; they'll be moved into the right 
	place when they become visible. (this can make the scrollable area too 
	large, though)"
	newText embeddedMorphs do: 
		[:m | 
		self addMorph: m.
		m position: -1000 @ 0].
	self releaseParagraph.
	"update the paragraph cache"
	self paragraph.
	"re-instantiate to set bounds"
	self world ifNotNil: [self world startSteppingSubmorphsOf: self]! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:43'!
setCharacters: chars
	"obtain a string value from the receiver"

	(self getCharacters = chars) ifFalse:
		[self newContents: chars]! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:43'!
setFirstCharacter: source
	"Set the first character of the receiver as indicated"

	| aChar chars |
	aChar _ source asCharacter.
	(chars _ self getCharacters) size > 0 
		ifFalse:
			[self newContents: (String with: aChar)]
		ifTrue:
			[(chars first = aChar) ifFalse:
				[self newContents: (String streamContents:
					[:aStream |
						aStream nextPut: aChar.
						aStream nextPutAll: (chars copyFrom: 2 to: chars size)])]]! !

!TextMorph methodsFor: 'accessing' stamp: 'sw 9/1/2000 10:44'!
setNumericValue: aValue
	"Set the contents of the receiver to be a string obtained from aValue"

	self newContents: aValue asString! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 1/10/2001 13:52'!
text
	^ text! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 9/1/2000 13:50'!
textStyle
	^textStyle! !

!TextMorph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:58'!
userString
	"Do I have a text string to be searched on?"

	^ text string! !


!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:19'!
centered 
	self paragraph centered.
	self updateFromParagraph ! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
justified 
	self paragraph justified.
	self updateFromParagraph! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
leftFlush 
	self paragraph leftFlush.
	self updateFromParagraph! !

!TextMorph methodsFor: 'alignment' stamp: 'di 10/25/97 19:20'!
rightFlush 
	self paragraph rightFlush.
	self updateFromParagraph! !


!TextMorph methodsFor: 'drawing' stamp: 'di 6/22/1998 10:55'!
drawBoundsOn: aCanvas
	"Shows where line boundaries are"
	self paragraph lines do:
		[:line | aCanvas frameRectangle: line rectangle color: Color brown]
! !

!TextMorph methodsFor: 'drawing' stamp: 'di 6/22/1998 10:39'!
drawNullTextOn: aCanvas
	"make null text frame visible"
	aCanvas fillRectangle: bounds color: Color lightRed
! !

!TextMorph methodsFor: 'drawing' stamp: 'RAA 7/30/2000 12:59'!
drawOn: aCanvas
	self setDefaultContentsIfNil.
	"self drawBoundsOn: aCanvas."  "show line rects for debugging"
	self startingIndex > text size
		ifTrue: [self drawNullTextOn: aCanvas]
		ifFalse: [aCanvas paragraph: self paragraph bounds: bounds color: color].
! !


!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 10:57'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and end editing.
	This default implementation does nothing."
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/22/1998 11:00'!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing.
	This default implementation does nothing."
	self releaseParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseAlignment
	self editor changeAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseEmphasis
	self editor changeEmphasis.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'sw 9/27/1999 12:13'!
chooseEmphasisOrAlignment
	self editor changeEmphasisOrAlignment.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseFont
	self editor offerFontMenu.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'!
chooseStyle
	self editor changeStyle.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'sw 1/12/98 23:34'!
clearTypeIn
	self newContents: ' '! !

!TextMorph methodsFor: 'editing' stamp: 'sw 10/13/2000 17:00'!
cornerStyle: ignored
	"set the receiver's corner style as indicated.  TextMorphs don't know what to make of this, but are gracious enough not to generate an error"! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/12/98 11:36'!
handleEdit: editBlock
	"Ensure that changed areas get suitably redrawn"
	self selectionChanged.  "Note old selection"
		editBlock value.
	self selectionChanged.  "Note new selection"
	self updateFromParagraph  "Propagate changes as necessary"! !

!TextMorph methodsFor: 'editing' stamp: 'RAA 6/15/2000 13:43'!
handleInteraction: interactionBlock fromEvent: evt
        | oldEditor oldParagraph |
        "Perform the changes in interactionBlock, noting any change in selection"

        "Also couple ParagraphEditor to Morphic keyboard events"
        self editor sensor: (KeyboardBuffer new startingEvent: evt).
        oldEditor _ editor.
        oldParagraph _ paragraph.
        self selectionChanged.  "Note old selection"

                interactionBlock value.

        oldParagraph == paragraph ifTrue: [     "this will not work if the paragraph changed"
                editor _ oldEditor.     "since it may have been changed while in block"
        ].
        self selectionChanged.  "Note new selection"! !

!TextMorph methodsFor: 'editing' stamp: 'ar 10/10/2000 15:22'!
handleKeystroke: anEvent
	"System level event handling."
	| pasteUp |
	anEvent wasHandled ifTrue:[^self].
	(self handlesKeyboard: anEvent) ifFalse:[^self].
	anEvent wasHandled: true.
	anEvent keyCharacter = Character tab ifTrue:[
		"Allow passing through text morph inside pasteups"
		pasteUp _ self pasteUpMorph.
		(self wouldAcceptKeyboardFocusUponTab  and:[pasteUp hasProperty: #tabAmongFields])
			ifTrue:[^ pasteUp tabHitWithEvent: anEvent]].
	^self keyStroke: anEvent! !

!TextMorph methodsFor: 'editing' stamp: 'ar 10/4/2000 19:09'!
handlesKeyboard: evt
	^true! !

!TextMorph methodsFor: 'editing' stamp: 'ar 10/6/2000 00:16'!
handlesMouseDown: evt
	self isPartsDonor ifTrue: [^ false].
	^true! !

!TextMorph methodsFor: 'editing' stamp: 'di 9/29/97 11:46'!
hasFocus
	^ editor ~~ nil! !

!TextMorph methodsFor: 'editing' stamp: 'di 4/21/1998 13:22'!
hasUnacceptedEdits: aBoolean
	"Ignored here, but noted in TextMorphForEditView"
! !

!TextMorph methodsFor: 'editing' stamp: 'ar 10/4/2000 18:43'!
keyStroke: evt
	"Handle a keystroke event."
	self handleInteraction: [editor readKeyboard] fromEvent: evt.
	self updateFromParagraph! !

!TextMorph methodsFor: 'editing' stamp: 'di 6/7/1999 15:51'!
keyboardFocusChange: aBoolean
	| w |
	aBoolean
		ifTrue: ["A hand is wanting to send us characters..."
				self hasFocus ifFalse: [self editor "Forces install"]]
		ifFalse: ["A hand has clicked elsewhere..."
				(w _ self world) == nil ifFalse:
					[w handsDo: [:h | h keyboardFocus == self ifTrue: [^ self]].
					"Release control unless some hand is still holding on"
					self releaseEditor]].
! !

!TextMorph methodsFor: 'editing' stamp: 'ar 9/15/2000 23:25'!
mouseDown: evt
	"Make this TextMorph be the keyboard input focus, if it isn't already,
		and repond to the text selection gesture."

	evt hand newKeyboardFocus: self.
	self handleInteraction: [editor mouseDown: evt] fromEvent: evt! !

!TextMorph methodsFor: 'editing' stamp: 'di 12/3/97 20:04'!
mouseMove: evt
	evt redButtonPressed ifFalse: [^ self].
	self handleInteraction: [editor mouseMove: evt] fromEvent: evt! !

!TextMorph methodsFor: 'editing' stamp: 'di 12/3/97 20:04'!
mouseUp: evt
	self handleInteraction: [editor mouseUp: evt] fromEvent: evt! !

!TextMorph methodsFor: 'editing' stamp: 'ar 9/15/2000 23:25'!
passKeyboardFocusTo: otherMorph
	| w |
self flag: #arNote. "Do we need this?!!"
	(w _ self world) == nil ifFalse:
		[w handsDo:
			[:h | h keyboardFocus == self
				ifTrue: [h newKeyboardFocus: otherMorph]]].
! !

!TextMorph methodsFor: 'editing'!
xeqLinkText: sourceString withParameter: param
	self confirm: 'xeqLinkText:
' asText allBold , sourceString asText! !


!TextMorph methodsFor: 'printing'!
fullPrintOn: aStream

	aStream nextPutAll: '('.
	super fullPrintOn: aStream.
	aStream nextPutAll: ') contents: '; print: text! !


!TextMorph methodsFor: 'geometry' stamp: 'di 10/8/1998 23:46'!
bounds
	container ifNil: [^ bounds].
	^ container bounds ifNil: [bounds]! !

!TextMorph methodsFor: 'geometry' stamp: 'di 1/28/1999 09:20'!
container
	"Return the container for composing this text.  There are four cases:
	1.  container is specified as, eg, an arbitrary shape,
	2.  container is specified as the bound rectangle, because
		this morph is linked to others,
	3.  container is nil, and wrap is true -- grow downward as necessary,
	4.  container is nil, and wrap is false -- grow in 2D as nexessary."

	container ifNil:
		[successor ifNotNil: [^ self bounds].
		wrapFlag ifTrue: [^ self bounds withHeight: 9999999].
		^ self position extent: 9999999@9999999].
	^ container! !

!TextMorph methodsFor: 'geometry' stamp: 'di 1/13/1999 14:11'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifFalse: [^false].
	self startingIndex > text size ifTrue:
		["make null text frame visible"
		^ super containsPoint: aPoint].
	^ self paragraph containsPoint: aPoint
! !

!TextMorph methodsFor: 'geometry' stamp: 'di 8/14/1998 15:50'!
defaultLineHeight
	^ textStyle lineGrid! !

!TextMorph methodsFor: 'geometry' stamp: 'di 4/14/98 09:31'!
extent: aPoint 
	self releaseParagraph.  "invalidate the paragraph cache"
	super extent: (aPoint truncated max: 9@(textStyle lineGrid+2)).
	self fit! !

!TextMorph methodsFor: 'geometry' stamp: 'di 11/16/97 16:52'!
goBehind
	"We need to save the container, as it knows about fill and run-around"
	| cont |
	container ifNil: [^ super goBehind].
	self releaseParagraph.  "Cause recomposition"
	cont _ container.  "Save the container"
	super goBehind.  "This will change owner, nilling the container"
	container _ cont.  "Restore the container"
	self changed! !

!TextMorph methodsFor: 'geometry' stamp: 'di 11/12/97 09:33'!
layoutChanged
	self releaseParagraph.
	super layoutChanged! !

!TextMorph methodsFor: 'geometry' stamp: 'di 4/27/2000 10:37'!
privateMoveBy: delta

	editor == nil
		ifTrue: [super privateMoveBy: delta.
				paragraph ifNotNil: [paragraph moveBy: delta]]
		ifFalse: ["When moving text with an active editor, save and restore all state."
				super privateMoveBy: delta.
				paragraph moveBy: delta.
				self installEditorToReplace: editor]
! !

!TextMorph methodsFor: 'geometry' stamp: 'di 3/1/98 11:40'!
textBounds
	^ bounds! !


!TextMorph methodsFor: 'menu' stamp: 'ar 10/26/2000 20:05'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	| outer |
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'add predecessor' action: #addPredecessor:.
	aCustomMenu add: 'add successor' action: #addSuccessor:.
	(Preferences valueOfFlag: #noviceMode) not & 
		(Preferences valueOfFlag: #simpleMenus) not ifTrue: [
			aCustomMenu add: 'code pane menu...' action: #yellowButtonActivity.
			aCustomMenu add: 'code pane shift menu....' action: #shiftedYellowButtonActivity].

	outer _ self owner.
	((outer isKindOf: PolygonMorph) and: [outer isOpen]) ifTrue:
		[container == nil
			ifTrue: [aCustomMenu add: 'follow owner''s curve' action: #followCurve]
			ifFalse: [aCustomMenu add: 'reverse direction' action: #reverseCurveDirection.
					aCustomMenu add: 'set baseline' action: #setCurveBaseline:]]
		ifFalse:
		[(container == nil or: [container fillsOwner not])
			ifTrue: [aCustomMenu add: 'fill owner''s shape' action: #fillingOnOff]
			ifFalse: [aCustomMenu add: 'rectangluar bounds' action: #fillingOnOff].
		(container == nil or: [container avoidsOcclusions not])
			ifTrue: [aCustomMenu add: 'avoid occlusions' action: #occlusionsOnOff]
			ifFalse: [aCustomMenu add: 'ignore occlusions' action: #occlusionsOnOff]].
! !

!TextMorph methodsFor: 'menu' stamp: 'di 10/8/1998 23:40'!
followCurve
	self setContainer: (TextOnCurveContainer new baseline: 0; textDirection: 1).
	self changed! !

!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 09:40'!
reverseCurveDirection
	container textDirection: container textDirection negated.
	self paragraph composeAll! !

!TextMorph methodsFor: 'menu' stamp: 'di 12/3/97 10:25'!
setCurveBaseline: evt
	| handle origin |
	origin _ evt cursorPoint.
	handle _ HandleMorph new forEachPointDo:
		[:newPoint | handle removeAllMorphs.
		handle addMorph:
			(PolygonMorph vertices: (Array with: origin with: newPoint)
				color: Color black borderWidth: 1 borderColor: Color black).
		container baseline: (newPoint - origin) y negated asInteger // 5.
		self paragraph composeAll].
	evt hand attachMorph: handle.
	handle startStepping	! !

!TextMorph methodsFor: 'menu' stamp: 'tk 7/14/2000 12:20'!
shiftedYellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing commands from a menu."

	self editor pluggableYellowButtonActivity: true.
	self changed.
! !

!TextMorph methodsFor: 'menu' stamp: 'tk 7/14/2000 12:17'!
yellowButtonActivity
	"Supply the normal 'code pane' menu to use its text editing commands from a menu."

	self editor pluggableYellowButtonActivity: false.
	self changed.
! !


!TextMorph methodsFor: 'linked frames' stamp: 'di 11/12/97 09:31'!
addPredecessor: evt
	| newMorph |
	newMorph _ TextMorph new text: text textStyle: textStyle wrap: wrapFlag
			color: color predecessor: predecessor successor: self.
	newMorph extent: self width @ 100.
	predecessor ifNotNil: [predecessor setSuccessor: newMorph].
	self setPredecessor: newMorph.
	predecessor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/12/97 09:31'!
addSuccessor: evt
	| newMorph |
	newMorph _ TextMorph new text: text textStyle: textStyle wrap: wrapFlag
			color: color predecessor: self successor: successor.
	newMorph extent: self width @ 100.
	successor ifNotNil: [successor setPredecessor: newMorph].
	self setSuccessor: newMorph.
	successor recomposeChain.
	evt hand attachMorph: newMorph! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/8/97 15:51'!
firstCharacterIndex
	^ self paragraph firstCharacterIndex! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
firstInChain
	"Return the first morph in a chain of textMorphs"
	| first |
	first _ self.  
	[first predecessor == nil]
		whileFalse: [first _ first predecessor].
	^ first! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/16/97 15:15'!
isLinkedTo: aMorph
	self firstInChain withSuccessorsDo:
		[:m | m == aMorph ifTrue: [^ true]].
	^ false! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
lastCharacterIndex
	^ self paragraph lastCharacterIndex! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
predecessor
	^ predecessor! !

!TextMorph methodsFor: 'linked frames' stamp: 'di 11/12/97 09:10'!
recomposeChain
	"Recompose this textMorph and all that follow it."
	self withSuccessorsDo:
		[:m |  m text: text textStyle: textStyle;  "Propagate new style if any"
				releaseParagraph;  "Force recomposition"
				fit  "and propagate the change"]! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
startingIndex
	predecessor == nil ifTrue: [^ 1].
	^ predecessor lastCharacterIndex + 1! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
successor
	^ successor! !

!TextMorph methodsFor: 'linked frames' stamp: 'jm 10/28/97 18:31'!
withSuccessorsDo: aBlock
	"Evaluate aBlock for each morph in my successor chain"
	| each |
	each _ self.
	[each == nil]
		whileFalse: [aBlock value: each.
					each _ each successor]! !


!TextMorph methodsFor: 'private' stamp: 'di 11/8/97 16:02'!
adjustLineIndicesBy: delta
	paragraph ifNotNil: [paragraph adjustLineIndicesBy: delta]! !

!TextMorph methodsFor: 'private' stamp: 'di 8/4/2000 16:06'!
composeToBounds
	"Compose my text to fit my bounds.
	If any text lies outside my bounds, it will be clipped, or
	if I have successors, it will be shown in the successors."
	| |
	self releaseParagraph; paragraph.
	container ifNotNil:
		[self privateBounds: container bounds truncated].
	self paragraph positionWhenComposed: self position.
	successor ifNotNil:
		[successor predecessorChanged].

! !

!TextMorph methodsFor: 'private' stamp: 'di 11/7/97 10:00'!
delete
	predecessor ifNotNil: [predecessor setSuccessor: successor].
	successor ifNotNil: [successor setPredecessor: predecessor.
						successor recomposeChain].
	super delete! !

!TextMorph methodsFor: 'private' stamp: 'RAA 9/25/2000 15:57'!
fit
	"Adjust bounds to fit the text if not in a rigid container."
	| newExtent para cBounds lastOfLines heightOfLast |
	newExtent _ (self paragraph extent max: 9@textStyle lineGrid) + (0@2).
	newExtent ~= bounds extent ifTrue:
		[(container == nil and: [successor == nil]) ifTrue:
			[para _ paragraph.  "Save para (layoutChanged smashes it)"
			super extent: newExtent.
			paragraph _ para]].
	container notNil & successor isNil ifTrue: [
		cBounds _ container bounds truncated.
		"23 sept 2000 - try to allow vertical growth"
		lastOfLines _ self paragraph lines last.
		heightOfLast _ lastOfLines bottom - lastOfLines top.
		(lastOfLines last < text size and: 
				[lastOfLines bottom + heightOfLast >= self bottom]) ifTrue: [
			container releaseCachedState.
			cBounds _ cBounds origin corner: cBounds corner + (0@heightOfLast).
		].
		self privateBounds: cBounds
	].
	self paragraph positionWhenComposed: self position.
	successor ifNotNil:
		[successor predecessorChanged].
	self changed. "Too conservative: only paragraph composition
					should cause invalidation."
! !

!TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 13:53'!
installEditor
	"Install an editor for my paragraph.  This constitutes 'hasFocus'."
	editor ifNotNil: [^ editor].
	^ self installEditorToReplace: nil! !

!TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 17:04'!
installEditorToReplace: priorEditor
	"Install an editor for my paragraph.  This constitutes 'hasFocus'.
	If priorEditor is not nil, then initialize the new editor from its state.
	We may want to rework this so it actually uses the prior editor."

	| stateArray |
	priorEditor ifNotNil: [stateArray _ priorEditor stateArray].
	editor _ TextMorphEditor new morph: self.
	editor changeParagraph: self paragraph.
	priorEditor ifNotNil: [editor stateArrayPut: stateArray].
	self selectionChanged.
	^ editor! !

!TextMorph methodsFor: 'private' stamp: 'di 11/13/97 15:17'!
loadCachedState
	"Prepare for fast response -- next page of a book?"
	self paragraph! !

!TextMorph methodsFor: 'private' stamp: 'ar 10/26/2000 20:05'!
paragraph
	"Paragraph instantiation is lazy -- create it only when needed"
	paragraph ifNotNil: [^ paragraph].
	self setDefaultContentsIfNil.

	"...Code here to recreate the paragraph..."
	paragraph _ (self paragraphClass new textOwner: self owner)
					compose: text style: textStyle copy
					from: self startingIndex in: self container.
	wrapFlag ifFalse:
		["Was given huge container at first... now adjust"
		paragraph adjustRightX].
	self fit.
	^ paragraph! !

!TextMorph methodsFor: 'private' stamp: 'jm 11/19/97 19:30'!
paragraphClass
	container ifNil: [^ NewParagraph].
	^ container paragraphClass! !

!TextMorph methodsFor: 'private' stamp: 'di 11/8/97 15:55'!
predecessorChanged
	| newStart oldStart |
	newStart _ predecessor == nil
		ifTrue: [1]
		ifFalse: [predecessor lastCharacterIndex + 1].
	(self paragraph adjustedFirstCharacterIndex ~= newStart or: [newStart >= text size])
		ifTrue: [paragraph composeAllStartingAt: newStart.
				self fit]
		ifFalse: ["If the offset to end of text has not changed, just slide"
				oldStart _ self firstCharacterIndex.
				self withSuccessorsDo:
					[:m | m adjustLineIndicesBy: newStart - oldStart]].
! !

!TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 16:39'!
releaseEditor 
	"Release the editor for my paragraph.  This morph no longer 'hasFocus'."
	editor ifNotNil:
		[self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor _ nil].! !

!TextMorph methodsFor: 'private' stamp: 'di 11/13/97 14:47'!
releaseParagraph
	"Paragraph instantiation is lazy -- it will be created only when needed"
	self releaseEditor.
	paragraph ifNotNil:
		[paragraph _ nil].
	container ifNotNil:
		[container releaseCachedState]! !

!TextMorph methodsFor: 'private' stamp: 'di 11/30/97 12:13'!
selectionChanged
	self paragraph selectionRects do: [:r | self invalidRect: r]! !

!TextMorph methodsFor: 'private' stamp: 'sw 4/23/1998 22:09'!
setDefaultContentsIfNil
	text ifNil: [text _ 'Text for
Editing' asText allBold]! !

!TextMorph methodsFor: 'private' stamp: 'di 10/25/97 17:11'!
setPredecessor: newPredecessor
	predecessor _ newPredecessor! !

!TextMorph methodsFor: 'private' stamp: 'di 10/25/97 17:10'!
setSuccessor: newSuccessor
	successor _ newSuccessor! !

!TextMorph methodsFor: 'private' stamp: 'di 10/24/97 11:35'!
text: t textStyle: s
	"Private -- for use only in morphic duplication"
	text _ t.
	textStyle _ s.
	paragraph ifNotNil: [paragraph textStyle: s]! !

!TextMorph methodsFor: 'private' stamp: 'di 11/12/97 09:30'!
text: t textStyle: s wrap: wrap color: c
	predecessor: pred successor: succ
	"Private -- for use only in morphic duplication"
	text _ t.
	textStyle _ s.
	wrapFlag _ wrap.
	color _ c.
	paragraph _ editor _ container _ nil.
	predecessor _ pred.
	successor _ succ! !

!TextMorph methodsFor: 'private' stamp: 'di 1/19/2000 15:47'!
updateFromParagraph
	"A change has taken place in my paragraph, as a result of editing and I must be updated.  If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be release, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis."
	| newStyle sel oldLast oldEditor |
	paragraph ifNil: [^ self].
	wrapFlag ifNil: [wrapFlag _ true].
	editor ifNotNil: [oldEditor _ editor.
					sel _ editor selectionInterval.
					editor storeSelectionInParagraph].
	text _ paragraph text.
	paragraph textStyle = textStyle
		ifTrue: [self fit]
		ifFalse: ["Broadcast style changes to all morphs"
				newStyle _ paragraph textStyle.
				(self firstInChain text: text textStyle: newStyle) recomposeChain.
				editor ifNotNil: [self installEditorToReplace: editor]].
	super layoutChanged.
	sel ifNil: [^ self].

	"If selection is in top line, then recompose predecessor for possible ripple-back"
	predecessor ifNotNil:
		[sel first <= (self paragraph lines first last+1) ifTrue:
			[oldLast _ predecessor lastCharacterIndex.
			predecessor paragraph recomposeFrom: oldLast to: text size delta: 0.
			oldLast = predecessor lastCharacterIndex
				ifFalse: [predecessor changed. "really only last line"
						self predecessorChanged]]].

	((predecessor~~nil and: [sel first <= self paragraph firstCharacterIndex])
		or: [successor~~nil and: [sel first > (self paragraph lastCharacterIndex+1)]])
		ifTrue:
		["The selection is no longer inside this paragraph.
		Pass focus to the paragraph that should be in control."
		self firstInChain withSuccessorsDo:
			[:m |  (sel first between: m firstCharacterIndex
								and: m lastCharacterIndex+1)
					ifTrue: [m installEditorToReplace: editor.
							^ self passKeyboardFocusTo: m]].
		self error: 'Inconsistency in text editor' "Must be somewhere in the successor chain"].
	editor ifNil:
		["Reinstate selection after, eg, style change"
		self installEditorToReplace: oldEditor]
! !

!TextMorph methodsFor: 'private' stamp: 'di 11/11/97 20:45'!
updateReferencesUsing: refDict
	| anchors range new |
	super updateReferencesUsing: refDict.
	"Update any anchors in the text of a newly copied morph"
	anchors _ IdentityDictionary new.
	text runs withStartStopAndValueDo:
		[:start :stop :attributes |
		attributes do: [:att | (att isMemberOf: TextAnchor)
							ifTrue: [anchors at: att put: (start to: stop)]]].
	anchors isEmpty ifTrue: [^ self].
	anchors keysDo:
		[:old |  range _ anchors at: old.
		text removeAttribute: old from: range first to: range last.
		new _ TextAnchor new anchoredMorph:
					(refDict at: old anchoredMorph).
		text addAttribute: new from: range first to: range last].
	self layoutChanged "for good measure"! !

!TextMorph methodsFor: 'private' stamp: 'sw 8/29/2000 15:05'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver might accept keyboard focus if tab were hit in some container playfield"

	^ self isLocked not! !



!TextMorph methodsFor: 'containment' stamp: 'di 11/4/97 15:37'!
fillingOnOff
	"Establish a container for this text, with opposite filling status"
	self setContainer:
	(container
		ifNil: [TextContainer new for: self minWidth: textStyle lineGrid*2]
		ifNotNil: [(container fillsOwner and: [container avoidsOcclusions not])
			ifTrue: [nil  "Return to simple rectangular bounds"]
			ifFalse: [container fillsOwner: container fillsOwner not]])! !

!TextMorph methodsFor: 'containment' stamp: 'di 11/4/97 15:37'!
occlusionsOnOff
	"Establish a container for this text, with opposite occlusion avoidance status"
	self setContainer:
	(container
	ifNil: [(TextContainer new for: self minWidth: textStyle lineGrid*2)
							fillsOwner: false; avoidsOcclusions: true]
	ifNotNil: [(container avoidsOcclusions and: [container fillsOwner not])
			ifTrue: [nil  "Return to simple rectangular bounds"]
			ifFalse: [container avoidsOcclusions: container avoidsOcclusions not]])! !

!TextMorph methodsFor: 'containment' stamp: 'sw 6/25/1998 10:44'!
ownerChanged
	super ownerChanged.
	container ifNotNil:
		[self releaseParagraph]! !

!TextMorph methodsFor: 'containment' stamp: 'tk 9/28/1999 16:50'!
privateOwner: newOwner
	"Nil the container when text gets extracted"
	super privateOwner: newOwner.
	container ifNotNil: [
		newOwner ifNotNil: [
			newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]! !

!TextMorph methodsFor: 'containment' stamp: 'sw 12/16/1998 09:09'!
recognizerArena
	"Answer the rectangular area, in world coordinates, that the character recognizer should regard as its tablet"

	| outer |
	^ (outer _ self ownerThatIsA: PluggableTextMorph)
		ifNotNil:
			[outer boundsInWorld]
		ifNil:
			[self boundsInWorld]! !

!TextMorph methodsFor: 'containment' stamp: 'di 11/12/97 09:06'!
setContainer: newContainer
	"Adopt (or abandon) container shape"
	self changed.
	container _ newContainer.
	self releaseParagraph! !


!TextMorph methodsFor: 'anchors' stamp: 'tk 6/30/1998 17:06'!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto me."

	self addMorphFront: aMorph fromWorldPosition: aMorph position.
		"Make a TextAnchor and install it in a run."! !

!TextMorph methodsFor: 'anchors' stamp: 'ar 11/15/1998 23:42'!
addMorphFront: aMorph fromWorldPosition: wp 
	"Overridden for more specific re-layout and positioning"
	| i |
	self addMorphFront: aMorph.
	i _ (self paragraph characterBlockAtPoint: (self transformFromWorld globalPointToLocal: wp))
		stringIndex.
	self paragraph replaceFrom: i to: i-1
		with: (Text string: '*' attribute: (TextAnchor new anchoredMorph: aMorph))
		displaying: false.
	self fit! !

!TextMorph methodsFor: 'anchors' stamp: 'di 2/25/98 20:37'!
privateRemoveMorph: aMorph
	| range |
	range _ text find: (TextAnchor new anchoredMorph: aMorph).
	range ifNotNil:
		[self paragraph replaceFrom: range first to: range last
				with: Text new displaying: false.
		self fit].
	super privateRemoveMorph: aMorph! !


!TextMorph methodsFor: 'copying' stamp: 'sma 2/5/2000 18:13'!
veryDeepFixupWith: deepCopier 
	"If target and arguments fields were weakly copied, fix them here.  If 
	they were in the tree being copied, fix them up, otherwise point to the 
	originals!!"

	super veryDeepFixupWith: deepCopier.
	"Caller beware: it makes no sense to share pointers to existing predecessor and successor"
	predecessor _ deepCopier references at: predecessor ifAbsent: [].
	successor _ deepCopier references at: successor ifAbsent: []! !

!TextMorph methodsFor: 'copying' stamp: 'sma 2/5/2000 18:15'!
veryDeepInner: deepCopier 
	"Copy all of my instance variables. Some need to be not copied at all, but shared.
	Warning!!!! Every instance variable defined in this class must be handled.
	We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

	super veryDeepInner: deepCopier.
	textStyle _ textStyle veryDeepCopyWith: deepCopier.
	text _ text veryDeepCopyWith: deepCopier.
	wrapFlag _ wrapFlag veryDeepCopyWith: deepCopier.
	paragraph _ paragraph veryDeepCopyWith: deepCopier.
	editor _ editor veryDeepCopyWith: deepCopier.
	container _ container veryDeepCopyWith: deepCopier.
	predecessor _ predecessor.
	successor _ successor! !


!TextMorph methodsFor: 'scripting access' stamp: 'sw 9/15/2000 06:14'!
getAllButFirstCharacter
	"Obtain all but the first character from the receiver; if that would be empty, return a black dot"

	| aString |
	^ (aString _ text string) size > 1 ifTrue: [aString copyFrom: 2 to: aString size] ifFalse: ['¥']! !

!TextMorph methodsFor: 'scripting access' stamp: 'sw 9/15/2000 06:14'!
getNumericValue
	"Obtain a numeric value from the receiver; if no digits, return zero"

	| aString |
	^ [(aString _ text string) asNumber] ifError: [:a :b | ^ aString asInteger ifNil: [0]]! !

!TextMorph methodsFor: 'scripting access' stamp: 'sw 9/14/2000 08:55'!
setAllButFirstCharacter: source
	"Set all but the first char of the receiver to the source"

	| aChar chars |
	aChar _ source asCharacter.
	(chars _ self getCharacters) size > 0 
		ifFalse:
			[self newContents: ('¥', source asString)]
		ifTrue:
			[(chars first = aChar) ifFalse:
				[self newContents: (String streamContents:
					[:aStream |
						aStream nextPut: chars first.
						aStream nextPutAll: source])]]! !


!TextMorph methodsFor: 'card & stack' stamp: 'sw 10/30/2000 09:02'!
couldHoldSeparateDataForEachInstance
	"Answer whether this type of morph is inherently capable of holding separate data for each instance ('card data')"

	^ true! !

!TextMorph methodsFor: 'card & stack' stamp: 'sw 5/31/2000 01:18'!
newContents: stringOrText fromCard: aCard
	"Accept new text contents."
	| newText setter |

	newText _ stringOrText asText.
	text = newText ifTrue: [^ self].  "No substantive change"

	text ifNotNil: [
		text embeddedMorphs do: [ :m | m delete ] ].

	text _ newText.

	"add all morphs off the visible region; they'll be moved into the right place when they become visible.  (this can make the scrollable area too large, though)"
	stringOrText asText embeddedMorphs do: [ :m | 
		self addMorph: m. 
		m position: (-1000@0)].

	self releaseParagraph.  "update the paragraph cache"
	self paragraph.  "re-instantiate to set bounds"

	self holdsSeparateDataForEachInstance
		ifTrue:
			[setter _ self valueOfProperty: #setterSelector.
			setter ifNotNil:
				[aCard perform: setter with: newText]].

	self world ifNotNil:
		[self world startSteppingSubmorphsOf: self ].
! !

!TextMorph methodsFor: 'card & stack' stamp: 'tk 1/8/2001 13:14'!
setNewContentsFrom: stringOrTextOrNil
	"Using stringOrTextOrNil as a guide, set the receiver's contents afresh.  If the input parameter is nil, the a default value stored in a property of the receiver, if any, will supply the new initial content.  This method is only called when a VariableDock is attempting to put a new value.  This is still messy and ill-understood and not ready for prime time."

	| defaultValue tt atts |
	stringOrTextOrNil ifNotNil: [^ self newContents: stringOrTextOrNil 
		fromCard: (self valueOfProperty: #cardInstance)].
		   "Well, totally yuk -- emergency measure late on eve of demo"
	defaultValue _ self valueOfProperty: #defaultValue 
					ifAbsent: [atts _ text attributesAt: 1.	"Preserve size, emphasis"
						tt _ text copyReplaceFrom: 1 to: text size
								with: 'blankText'.
						atts do: [:anAtt | tt addAttribute: anAtt].
						tt].
	self contents: defaultValue deepCopy wrappedTo: self width.
! !

!TextMorph methodsFor: 'card & stack' stamp: 'sw 10/25/2000 07:02'!
variableDocks
	"Answer a list of VariableDock objects for docking up my data with an instance held in my containing playfield"

	^ Array with: (VariableDock new variableName: self defaultVariableName type: #text definingMorph: self morphGetSelector: #contents morphPutSelector: #setNewContentsFrom:)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMorph class
	instanceVariableNames: ''!

!TextMorph class methodsFor: 'scripting' stamp: 'sw 9/15/2000 06:16'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #(
(text (
(slot characters	'The characters in my contents' string	readWrite player getCharacters player setCharacters:)
(slot firstCharacter  'The first character in my contents' string  readWrite player getFirstCharacter  player  setFirstCharacter:)
(slot allButFirst 'All my characters except the first one' string readWrite player getAllButFirstCharacter player  setAllButFirstCharacter:)
(slot numericValue 'The number represented by my contents' number readWrite player getNumericValue player  setNumericValue:)))

(basic (
(slot characters	'The characters in my contents' string	readWrite player getCharacters player setCharacters:))))


! !

!TextMorph class methodsFor: 'scripting' stamp: 'sw 8/3/1998 17:16'!
authoringPrototype
	| t |
	t _ super authoringPrototype.
"Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window"

	t paragraph.
	^ t! !


!TextMorph class methodsFor: 'user interface' stamp: 'kfr 5/1/2000 13:42'!
includeInNewMorphMenu
	^ true! !


!TextMorph class methodsFor: 'class initialization' stamp: 'jm 11/5/97 12:26'!
initialize	"TextMorph initialize"
	"Initialize constants shared by classes associated with text display."

	CaretForm _ (ColorForm extent: 16@5
					fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
					offset: -2@0)
					colors: (Array with: Color transparent with: self new selectionColor).
! !
ParagraphEditor subclass: #TextMorphEditor
	instanceVariableNames: 'morph oldInterval pivotBlock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'!
morph
	^ morph! !

!TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'!
morph: aMorph
	"Install a link back to the morph being edited (esp for text links)"
	morph _ aMorph ! !


!TextMorphEditor methodsFor: 'events' stamp: 'RAA 1/26/2001 10:55'!
mouseDown: evt 
	"An attempt to break up the old processRedButton code into threee phases"
	| clickPoint |

	oldInterval _ startBlock stringIndex to: stopBlock stringIndex - 1.
	clickPoint _ evt cursorPoint.
	(paragraph clickAt: clickPoint for: model controller: self) ifTrue: [
		oldInterval _ pivotBlock _ nil.	"don't change selection based on this click"
		evt hand releaseKeyboardFocus: self.
		^ self].
	sensor leftShiftDown
		ifFalse:
			[self closeTypeIn.
			stopBlock _ startBlock _ pivotBlock _
				paragraph characterBlockAtPoint: clickPoint]
		ifTrue:
			[(paragraph characterBlockAtPoint: clickPoint) <= startBlock
				ifTrue: [stopBlock _ startBlock.
						pivotBlock _ stopBlock]
				ifFalse: [startBlock _  stopBlock.
						pivotBlock _ startBlock].
			self closeTypeIn].
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:12'!
mouseMove: evt 
	"Change the selection in response to moue-down drag"
	| dragBlock |
	pivotBlock ifNil: [^ self].  "Patched during clickAt: repair"
	dragBlock _ paragraph characterBlockAtPoint: (evt cursorPoint).
	dragBlock > pivotBlock
		ifTrue: [stopBlock _ dragBlock.  startBlock _ pivotBlock]
		ifFalse: [startBlock _ dragBlock.  stopBlock _ pivotBlock].
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:12'!
mouseUp: evt
	"An attempt to break up the old processRedButton code into threee phases"
	oldInterval ifNil: [^ self].  "Patched during clickAt: repair"
	(startBlock = stopBlock 
		and: [oldInterval = (startBlock stringIndex to: startBlock stringIndex-1)])
		ifTrue: [self selectWord].
	self setEmphasisHere.
	(self isDisjointFrom: oldInterval) ifTrue:
		[otherInterval _ oldInterval].
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:11'!
readKeyboard
	super readKeyboard.
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'events' stamp: 'sw 12/16/1998 08:55'!
recognizeCharacters
	"Recognize hand-written characters and put them into the receiving pane.  Invokes Alan's character recognizer."

	self recognizeCharactersWhileMouseIn: morph recognizerArena! !

!TextMorphEditor methodsFor: 'events' stamp: 'RAA 6/2/2000 10:54'!
recognizeCharactersWhileMouseIn: box
	"Recognize hand-written characters and put them into the receiving TextMorph.  Invokes Alan's character recognizer.  box is in world coordinates."

	| aRecognizer |
	Cursor marker showWhile:
		[aRecognizer _ CharRecog new textMorph: morph.
		aRecognizer recognizeAndDispatch:
			[:char | morph handleInteraction:
				[char == BS
					ifTrue:
						[self simulatedBackspace]
					ifFalse:
						[self simulatedKeystroke: char]] fromEvent: nil.
			morph updateFromParagraph.
			Display doOneCycleMorphic]
		until:
			[(box containsPoint: Sensor cursorPoint) not]]! !


!TextMorphEditor methodsFor: 'menu commands' stamp: 'di 4/21/1998 20:30'!
accept
	"Save the current text of the text being edited as the current acceptable version for purposes of canceling.  Allow my morph to take appropriate action"
	morph acceptContents! !

!TextMorphEditor methodsFor: 'menu commands' stamp: 'di 10/9/1998 16:55'!
cancel
	"Cancel the changes made so far to this text"
	morph cancelEdits! !

!TextMorphEditor methodsFor: 'menu commands' stamp: 'tk 1/13/1999 08:40'!
changeEmphasis: characterStream 
	"Intercept requests to create a link (Cmd-6).  Make them simpler for end-user editing.  SystemWidows use ParagraphEditor's complex commands."

	| keyCode attribute index colors aPageName target book theSelection url newPage labels |
	"Test if it's really the droids we're looking for..."
	keyCode _ ('0123456789-=' indexOf: sensor keyboardPeek ifAbsent: [1]) - 1.
	keyCode ~= 6 ifTrue: [^ super changeEmphasis: characterStream].
		"underline, bold, etc."
	(morph isKindOf: TextMorphForEditView) ifTrue: [
		^ super changeEmphasis: characterStream].	"if in a browser, show all choices"

	sensor keyboard.  "Yes, it is Cmd-6;  consume the command character"
	theSelection _ self selection.
	colors _ #(black magenta red yellow green blue cyan white).
	labels _ colors, #(active).
	(book _ morph ownerThatIsA: BookMorph) ifNotNil: [
		labels _ labels, #('link to')].
	index _ (PopUpMenu labelArray: labels
							lines: (Array with: colors size)) startUp.
	index = 0 ifTrue: [^ true].
	index <= colors size ifTrue:
		[attribute _ TextColor color: (Color perform: (colors at: index))].
	index = (colors size + 1) ifTrue:
		[attribute _ TextDoIt new.
		theSelection _ attribute analyze: self selection asString].
	index = (colors size + 2) ifTrue:	"Link to a new page, possibly create it"
		["target page must be in memory"
		aPageName _ self selection asString.
		target _ book pageNamed: aPageName.	"later don't bring in all pages!!"
		"later offer correction"
		target ifNotNil: [url _ target url.
			url ifNil: [self inform: 'You must send the target page to a server.'.  ^ true].
			attribute _ TextSqkPageLink new. 
			theSelection _ attribute analyze: self selection asString,'<',url,'>'].
		target ifNil: ["add page at end"
			(book valueOfProperty: #keepTogether) 
				ifNotNil: [self inform: 'For now, can''t link in book whose 
pages must be kept together'.  ^ true].
			newPage _ book insertPageSilentlyAtEnd.
			newPage setNameTo: theSelection asString.
			book saveOnUrlPage: newPage.	"write it on the server"
			attribute _ TextSqkPageLink new. 
			theSelection _ attribute analyze: 
				self selection asString,'<', newPage url,'>'].
		].
	self replaceSelectionWith: (theSelection asText addAttribute: attribute).
	^ true! !

!TextMorphEditor methodsFor: 'menu commands' stamp: 'di 10/5/1998 21:48'!
find
	super find.
	morph installEditorToReplace: self! !

!TextMorphEditor methodsFor: 'menu commands' stamp: 'sw 10/18/1998 10:17'!
tempCommand: characterStream 
	"Experimental.  Triggered by Cmd-t; put trial cmd-key commands here to see how they work, before hanging them on their own cmd accelerators."
	Sensor keyboard.
	morph tempCommand.
	^ true! !


!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'tk 11/9/2000 17:05'!
againOrSame: bool

	| bk keys |
	(bk _ morph ownerThatIsA: BookMorph) ifNotNil: [
		(keys _ bk valueOfProperty: #searchKey ifAbsent: [nil]) ifNotNil: [
			keys size > 0 ifTrue: [bk findText: keys]]].

	super againOrSame: bool.
	(morph respondsTo: #editView) ifTrue: [
		morph editView selectionInterval: self selectionInterval].! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'jm 10/28/97 18:31'!
align
	"Align text according to the next greater alignment value,
	cycling among leftFlush, rightFlush, center, and justified."

	paragraph textStyle alignment: paragraph textStyle alignment + 1.
	self recomputeInterval! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/16/1998 11:33'!
controlInitialize
	"No-op for MVC ParagraphEditor compatibility"! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/16/1998 11:33'!
controlTerminate
	"No-op for MVC ParagraphEditor compatibility"! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/22/1998 10:21'!
flash
	^ morph flash! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 10/2/97 11:38'!
mvcRedisplay
	"Ignore mvcRedisplay requests."! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 10/2/97 09:08'!
scrollBy: ignore 
	"Ignore scroll requests."! !

!TextMorphEditor methodsFor: 'mvc compatibility'!
select
	"Ignore selection redraw requests."! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'jm 10/28/97 18:31'!
selectAndScroll
	"Ignore scroll requests."! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 17:06'!
selectAndScrollToTop
	"Scroll until the selection is in the view and then highlight it."

	| lineHeight deltaY rect deltaX |
	lineHeight _ paragraph textStyle lineGrid.
	rect _ morph owner bounds.
	deltaY _ stopBlock top - rect top.
	deltaY ~= 0 ifTrue: [
		deltaX _ 0.
		deltaY _ (deltaY abs + lineHeight - 1 truncateTo: lineHeight) negated.
		morph editView scrollBy: deltaX@deltaY]! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 16:51'!
selectForTopFrom: start to: stop

	self selectFrom: start to: stop.
	morph editView ifNotNil: [self selectAndScrollToTop]! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 6/14/1998 13:12'!
selectFrom: start to: stop
	"Select the specified characters inclusive."
	self selectInvisiblyFrom: start to: stop.
	self closeTypeIn.
	self storeSelectionInParagraph! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 5/12/1998 20:56'!
storeSelectionInParagraph
	paragraph selectionStart: startBlock selectionStop: stopBlock! !

!TextMorphEditor methodsFor: 'mvc compatibility'!
updateMarker
	"Ignore scrollbar redraw requests."
! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/21/1998 14:11'!
userHasEdited
	"Note that my text is free of user edits."

	morph hasUnacceptedEdits: true! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 4/21/1998 13:26'!
userHasNotEdited
	"Note that my text is free of user edits."

	morph hasUnacceptedEdits: false! !

!TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sw 12/7/1999 12:27'!
zapSelectionWith: aText
	"**overridden to inhibit old-style display"
	| start stop |
	self deselect.
	start _ startBlock stringIndex.
	stop _ stopBlock stringIndex.
	(aText isEmpty and: [stop > start]) ifTrue:
		["If deleting, then set emphasisHere from 1st character of the deletion"
		emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle)
					select: [:att | att mayBeExtended]].
	(start = stop and: [aText size = 0]) ifFalse:
		[paragraph replaceFrom: start to: stop - 1
			with: aText displaying: false.  "** was true in super"
		self computeIntervalFrom: start to: start + aText size - 1.
		UndoInterval _ otherInterval _ self selectionInterval].

	self userHasEdited  " -- note text now dirty"! !


!TextMorphEditor methodsFor: 'command keys' stamp: 'tk 5/8/1998 11:08'!
inspectIt: characterStream 
	"Inspect the selection -- invoked via cmd-i.  If there is no current selection, use the current line."

	sensor keyboard.		"flush character"
	self inspectIt.
	^ true! !


!TextMorphEditor methodsFor: 'binding' stamp: 'ls 7/24/1998 21:06'!
bindingOf: aString
	^model bindingOf: aString! !


!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:41'!
totalTextHeight

	^paragraph lines last bottom! !

!TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:43'!
visibleHeight

	^morph owner bounds height! !


!TextMorphEditor methodsFor: 'attributes' stamp: 'ar 9/21/2000 14:19'!
changeEmphasisOrAlignment
	| aList reply  code align menuList |
	self flag: #arNote. "Move this up once we get rid of MVC"
	aList _ #(plain bold italic narrow underlined struckOut leftFlush centered rightFlush justified).	
	align _ paragraph textStyle alignmentSymbol.
	code _ paragraph text emphasisAt: startBlock stringIndex.
	menuList _ WriteStream on: Array new.
	menuList nextPut: (code = 0 ifTrue:['<on>plain'] ifFalse:['<off>plain']).
	menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode)
			ifTrue:['<on>', emph]
			ifFalse:['<off>',emph]]).
	((paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle)
		anySatisfy:[:attr| attr isKern and:[attr kern < 0]]) 
			ifTrue:[menuList nextPut:'<on>narrow']
			ifFalse:[menuList nextPut:'<off>narrow'].
	menuList nextPutAll: (#(leftFlush centered rightFlush justified) collect:[:type|
		align == type
			ifTrue:['<on>',type]
			ifFalse:['<off>',type]]).
	aList _ #(plain bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: menuList contents lines: #(1 6) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue:
				[paragraph perform: reply.
				self recomputeInterval]
			ifFalse:
				[self setEmphasis: reply.
				paragraph composeAll.
				self recomputeSelection.
				self mvcRedisplay]].
	^ true! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'ar 9/21/2000 14:14'!
changeStyle
	"Let user change styles for the current text pane."
	| aList reply style theStyle menuList |
	self flag: #arNote. "Move this up once we get rid of MVC"
	aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection.
	theStyle _ paragraph textStyle.
	menuList _ aList collect:[:styleName|
		"Hack!! use defaultFont for comparison - we have no name that we could use for compare and the style changes with alignment so they're no longer equal."
		(TextConstants at: styleName) defaultFont == theStyle defaultFont
			ifTrue:['<on>', styleName]
			ifFalse:['<off>',styleName]].
	theStyle = TextStyle default
		ifTrue:[menuList addFirst: '<on>DefaultTextStyle']
		ifFalse:[menuList addFirst: '<off>DefaultTextStyle'].
	aList addFirst: 'DefaultTextStyle'.
	reply _ (SelectionMenu labelList: menuList lines: #(1) selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(style _ TextStyle named: reply) ifNil: [self beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection.
		self mvcRedisplay].
	^ true! !

!TextMorphEditor methodsFor: 'attributes' stamp: 'ar 9/21/2000 13:54'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "
	| aList reply curFont menuList |
	self flag: #arNote. "Move this up once we get rid of MVC"
	curFont _ (paragraph text fontAt: startBlock stringIndex withStyle: paragraph textStyle) fontNameWithPointSize.
	aList _ paragraph textStyle fontNamesWithPointSizes.
	menuList _ aList collect:[:fntName|
		fntName = curFont ifTrue:['<on>',fntName] ifFalse:['<off>',fntName]].
	reply _ (SelectionMenu labelList: menuList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[self replaceSelectionWith:
			(Text string: self selection asString 
				attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMorphEditor class
	instanceVariableNames: ''!

!TextMorphEditor class methodsFor: 'as yet unclassified' stamp: 'di 4/13/1999 14:41'!
new
	^ self basicNew initialize! !
TextMorph subclass: #TextMorphForEditView
	instanceVariableNames: 'editView acceptOnCR '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextMorphForEditView methodsFor: 'debugging' stamp: 'sw 11/2/1998 15:51'!
tempCommand
	"Smalltalk browseAllImplementorsOf: #tempCommand"
	"Place your definition for tempCommand for this class here"! !


!TextMorphForEditView methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:50'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	acceptOnCR ifNil: [acceptOnCR _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!TextMorphForEditView methodsFor: 'private' stamp: 'dew 2/21/1999 03:09'!
updateFromParagraph  
	super updateFromParagraph.
	editView setScrollDeltas.! !


!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 4/22/1998 10:57'!
acceptContents
	"The message is sent when the user hits enter or Cmd-S.
	Accept the current contents and end editing."
	self updateFromParagraph.
	editView accept.! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 9/11/1998 15:42'!
acceptOnCR: trueOrFalse
	acceptOnCR _ trueOrFalse! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 4/22/1998 11:03'!
cancelEdits
	"The message is sent when the user hits enter or Cmd-L.
	Cancel the current contents and end editing."
	self releaseParagraph.
	editView cancel! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 6/22/1998 10:44'!
drawNullTextOn: aCanvas
	"Just run the normal code to show selection in a window"
	aCanvas paragraph: self paragraph bounds: bounds color: color
! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 6/22/1998 01:31'!
editView
	^ editView! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 10:13'!
flash
	^ editView flash! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 10/5/1998 14:03'!
handleInteraction: interActionBlock fromEvent: evt
	"Overridden to pass along a model to the editor for, eg, link resolution, doits, etc"

	self editor model: editView model.  "For evaluateSelection, etc"
	^ super handleInteraction: interActionBlock fromEvent: evt! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 4/21/1998 13:23'!
hasUnacceptedEdits: aBoolean
	"Set the hasUnacceptedEdits flag in my view."

	editView hasUnacceptedEdits: aBoolean! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 9/11/1998 15:43'!
initialize
	super initialize.
	acceptOnCR _ false! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 6/30/1998 08:50'!
mouseDown: event

	event yellowButtonPressed ifTrue: [^ editView yellowButtonActivity: event shiftPressed].
	^ super mouseDown: event
! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'di 4/21/1998 13:09'!
setEditView: editPane
	editView _ editPane! !

!TextMorphForEditView methodsFor: 'as yet unclassified' stamp: 'sw 8/29/2000 15:06'!
wouldAcceptKeyboardFocusUponTab
	"Answer whether the receiver would be a happy inheritor of keyboard focus if tab were hit in an enclosing playfield under propitious circumstances.  Does not make sense for this kind of morph, which is encased in a window"

	^ false! !


!TextMorphForEditView methodsFor: 'all' stamp: 'bf 4/14/1999 12:39'!
keyStroke: evt
	| view |
	(editView scrollByKeyboard: evt) ifTrue: [^self].
	self editor model: editView model.  "For evaluateSelection"
	view _ editView.  "Copy into temp for case of a self-mutating doit"
	(acceptOnCR and: [evt keyCharacter = Character cr])
		ifTrue: [^ self editor accept].
	super keyStroke: evt.
	view scrollSelectionIntoView! !


!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 11/8/2000 15:50'!
autoScrollView: evt
	"This is kind of a hack because the PluggableTextMorph expects me to first expand the selection before auto scrolling will work."
	| localEvt |
	localEvt _ evt transformedBy: (self transformedFrom: editView).
	super mouseMove: localEvt.
	editView scrollSelectionIntoView: localEvt.! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 9/15/2000 22:57'!
handlesKeyboard: evt
	^true! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 11/8/2000 15:51'!
mouseMove: evt
	| editEvt |
	super mouseMove: evt.
	editEvt _ evt transformedBy: (self transformedFrom: editView) inverseTransformation.
	(editEvt position y between: editView top and: editView bottom) ifFalse:[
		"Start auto-scrolling"
		self startStepping: #autoScrollView:
			at: Time millisecondClockValue
			arguments: (Array with: editEvt)
			stepTime: 100. "fast enough"
	] ifTrue:[
		self stopSteppingSelector: #autoScrollView:.
	].! !

!TextMorphForEditView methodsFor: 'event handling' stamp: 'ar 11/8/2000 15:10'!
mouseUp: evt
	super mouseUp: evt.
	self stopSteppingSelector: #autoScrollView:.
	editView scrollSelectionIntoView: evt.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextMorphForEditView class
	instanceVariableNames: ''!

!TextMorphForEditView class methodsFor: 'as yet unclassified' stamp: 'kfr 5/1/2000 13:41'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
NewParagraph subclass: #TextOnCurve
	instanceVariableNames: 'lastCharacterIndex curve '
	classVariableNames: 'CachedWarpColor CachedWarpDepth CachedWarpMap '
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextOnCurve commentStamp: '<historical>' prior: 0!
This subclass of Paragraph composes and displays text along a segmented line or curve.  It does this by using all the normal text composition machinery, but just to lay text out for each segment of the curve in question.  The display process is somewhat complicated, as it involves rotating the text for each segment, and then merging it into the destination Form with background, selection highlight, and transparency all handled correctly.

Because TextMorph flushes its paragraph to save space, the enduring specification of curve layout (direction, baseline, and margin) must be stored in the container.!


!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 8/13/2000 12:27'!
asParagraphForPostscript

	^ self as: TextOnCurvePS! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'ar 5/18/2000 18:33'!
characterBlockAtPoint: aPoint 
	"Answer a CharacterBlock for the character in the text at aPoint."
	| sourcePoint cb curvePoint |
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(destRect containsPoint: aPoint) ifTrue:
			["It's in the destRect; now convert to source coords"
			sourcePoint _ self pointInLine: line forDestPoint: aPoint
							segStart: segStart segAngle: segAngle.
			cb _ (CharacterBlockScanner new text: text textStyle: textStyle)
				characterBlockAtPoint: (sourcePoint adhereTo: line rectangle)
				index: nil in: line.
			(sourcePoint x between: line left and: line right) ifTrue:
				["Definitely in this segment"
				^ cb]]].
	"Point is off curve -- try again with closest point on curve"
	curvePoint _ curve closestPointTo: aPoint.
	curvePoint = aPoint ifFalse:
		[^ self characterBlockAtPoint: curvePoint].
	"If all else fails, at least return something acceptable."
	^ cb ifNil: [self defaultCharacterBlock]! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 4/30/1999 08:06'!
composeAll
	self composeLinesFrom: firstCharacterIndex
		withLines: OrderedCollection new
		atY: container top.! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 6/23/1999 10:17'!
composeLinesFrom: start to: stop delta: delta into: newLines priorLines: priorLines
	atY: startingY

	^ self composeLinesFrom: start withLines: newLines atY: startingY! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'ar 5/18/2000 18:35'!
composeLinesFrom: startingIndex withLines: startingLines atY: startingY
	"Here we determine the 'lines' of text that will fit along each segment of the curve. For each line, we determine its rectangle, then the dest wuadrilateral that it willbe rotated to.  Then, we take the outer hull to determine a dest rectangle for WarpBlt.  In addition we need the segment pivot point and angle, from which the source quadrilateral may be computed."
	| charIndex scanner line firstLine curveSegments segIndex pa pb segLen lineRect textSegments segDelta segAngle destRect destQuad i oldBounds |
	(oldBounds _ container bounds) ifNotNil:
		[curve invalidRect: oldBounds].
	charIndex _ startingIndex.
	lines _ startingLines.
	curveSegments _ curve lineSegments.
	container textDirection < 0 ifTrue:
		[curveSegments _ curveSegments reversed collect:
				[:seg | Array with: (seg at: 2) with: (seg at: 1)]].
	textSegments _ OrderedCollection new.
	scanner _ SegmentScanner new text: text textStyle: textStyle.
	segIndex _ 1.  "For curves, segIndex is just an index."
	firstLine _ true.
	pa _ curveSegments first first.
	[charIndex <= text size and: [segIndex <= curveSegments size]]
		whileTrue:
		[curve isCurve ifFalse: [pa _ (curveSegments at: segIndex) first].
		pb _ (curveSegments at: segIndex) last.
		segDelta _ pb - pa.  "Direction of this segment"
		segLen _ segDelta r.
		lineRect _ 0@0 extent: segLen asInteger@textStyle lineGrid.
		line _ scanner composeFrom: charIndex inRectangle: lineRect
						firstLine: firstLine leftSide: true rightSide: true.
		line setRight: scanner rightX.
		line width > 0 ifTrue:
			[lines addLast: line.
			segAngle _ segDelta theta.
			destQuad _ line rectangle corners collect:
						[:p | (p translateBy: pa - (0@(line baseline + container baseline)))
								rotateBy: segAngle negated about: pa].
			destRect _ Rectangle encompassing: destQuad.
			textSegments addLast: (Array with: destRect truncated with: pa with: segAngle).
			pa _ pa + ((pb-pa) * line width / segLen).
			charIndex _ line last + 1].
		segIndex _ segIndex + 1.
		firstLine _ false].
	lines size = 0 ifTrue:
		["No space in container or empty text"
		line _ (TextLine start: startingIndex stop: startingIndex-1
						internalSpaces: 0 paddingWidth: 0)
				rectangle: (0@0 extent: 10@textStyle lineGrid);
				lineHeight: textStyle lineGrid baseline: textStyle baseline.
		lines _ Array with: line.
		textSegments addLast:
			(Array with: (curve vertices first extent: line rectangle extent) 					with: curve vertices first with: 0.0).].
	"end of segments, now attempt word break."
	lines last last < text size ifTrue:
		[[lines size > 1 and: [(text at: (i _ lines last last)+1) ~= Character space]]
			whileTrue:
			[i = lines last first
				ifTrue: [lines removeLast.  textSegments removeLast]
				ifFalse: [lines last stop: i-1]]].
	lines _ lines asArray.
	container textSegments: textSegments asArray.
	curve invalidRect: container bounds.
	^ maxRightX! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:06'!
containsPoint: aPoint
	"Return true if aPoint is in the actual text areas."
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(destRect containsPoint: aPoint) ifTrue:
			["It's in the destRect; now check if really in text area"
			(line rectangle containsPoint:
				(self pointInLine: line forDestPoint: aPoint
					segStart: segStart segAngle: segAngle))
				ifTrue: [^ true]]].
	^ false! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'ar 5/25/2000 18:01'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"
	| maxExtent lineForm leftInRun lineRect warp sourceQuad backgroundColor lineCanvas |
	warp _ nil.
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		false ifTrue:
			["Show the dest rects for debugging..."
			aCanvas frameRectangle: destRect width: 1 color: Color black].
		(aCanvas isVisible: destRect) ifTrue:
			[warp ifNil:
				["Lazy initialization because may hot have to display at all."
				maxExtent _ lines inject: lines first rectangle extent 
					into: [:maxWid :lin | maxWid max: lin rectangle extent].
				lineForm _ Form extent: maxExtent depth: aCanvas depth.
				displayScanner setDestForm: lineForm.
				lineRect _ lineForm boundingBox.
				leftInRun _ 0.
				backgroundColor _ (curve borderWidth > 10
							ifTrue: [curve color]
							ifFalse: [curve owner isHandMorph
									ifTrue: [curve owner owner color]
									ifFalse: [curve owner color]]) dominantColor.
				warp _ (aCanvas warpFrom: lineRect corners toRect: lineRect)
						cellSize: 2;  "installs a colormap if smoothing > 1"
						sourceForm: lineForm.
				warp colorMap: (self warpMapForDepth: aCanvas depth
									withTransparentFor: backgroundColor).
				lineCanvas _ lineForm getCanvas].
			sourceQuad _ destRect innerCorners collect:
				[:p | self pointInLine: line forDestPoint: p
						segStart: segStart segAngle: segAngle].
			lineForm fill: lineForm boundingBox fillColor: backgroundColor.
			self displaySelectionInLine: line on: lineCanvas.
			leftInRun _ displayScanner displayLine: line offset: 0@0 leftInRun: leftInRun.
			warp sourceQuad: sourceQuad destRect: (destRect translateBy: aCanvas origin).
			warp warpBits]].
! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 22:38'!
extent
	^ curve bounds extent! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 11/29/97 20:23'!
moveBy: delta
	positionWhenComposed _ positionWhenComposed + delta.
	container _ container translateBy: delta! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 10:24'!
pointInLine: line forDestPoint: p segStart: segStart segAngle: segAngle
	^ (p rotateBy: segAngle about: segStart)
			translateBy: (0@(line baseline + container baseline)) - segStart! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 11/29/97 20:15'!
releaseCachedState
	super releaseCachedState.
	CachedWarpMap _ CachedWarpDepth _ CachedWarpColor _ nil! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:06'!
selectionRectsFrom: characterBlock1 to: characterBlock2
	"Return an array of rectangles encompassing the area
	between the two character blocks, presumably a selection."
	| rects |
	rects _ OrderedCollection new.
	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		(characterBlock1 stringIndex <= line last
			and: [characterBlock2 stringIndex >= line first]) ifTrue:
			[rects addLast: destRect].
		line first > characterBlock2 stringIndex ifTrue:
			[^ rects]].
	^ rects! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 20:29'!
textOwner: theCurve
	curve _ theCurve! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:10'!
textSegmentsDo: blockForLineDestPivotAngle
	| segments segSpec |
	(segments _ container textSegments) ifNil: [^ self].
	1 to: lines size do:
		[:i | segSpec _ segments at: i.
		blockForLineDestPivotAngle
			value: (lines at: i)
			value: (segSpec at: 1)
			value: (segSpec at: 2)
			value: (segSpec at: 3)]
! !

!TextOnCurve methodsFor: 'as yet unclassified' stamp: 'di 11/29/97 12:20'!
warpMapForDepth: destDepth withTransparentFor: bkgndColor
	(CachedWarpDepth = destDepth and: [CachedWarpColor = bkgndColor])
		ifTrue: ["Map is OK as is -- return it"
				^ CachedWarpMap].
	(CachedWarpMap == nil or: [CachedWarpDepth ~= destDepth])
		ifTrue: ["Have to recreate the map"
				CachedWarpMap _ Color computeColormapFrom: 32 to: destDepth.
				CachedWarpDepth _ destDepth]
		ifFalse: ["Map is OK, if we restore prior color substiution"
				CachedWarpMap at: (CachedWarpColor indexInMap: CachedWarpMap)
					put: (CachedWarpColor pixelValueForDepth: destDepth)].
	"Now map the background color into transparent, and return the new map"
	CachedWarpColor _ bkgndColor.
	CachedWarpMap at: (CachedWarpColor indexInMap: CachedWarpMap)
					put: 0.
	^ CachedWarpMap
! !
Object subclass: #TextOnCurveContainer
	instanceVariableNames: 'baseline inset textDirection textSegments '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!
!TextOnCurveContainer commentStamp: '<historical>' prior: 0!
I am not really a container in the sense of TextContainer.  However, I get stored in the same field of a textMorph.  My baseline specifies the vertical displacement of the character baselines from the curve center (0 means on center, 5 would mean, eg, the character baselines are 5 pixels above the curve center).  This is ssential enduring information.  I also cache temporary layout information, including the locations, angles and bounding boxes of each of the characters as displayed.!


!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 10:22'!
baseline
	baseline ifNil: [^ 0].
	^ baseline! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 19:30'!
baseline: newBaseline
	baseline _ newBaseline! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/4/97 08:32'!
bounds
	textSegments ifNil: [^ nil].
	^ textSegments inject: (textSegments first at: 1)
		into: [:bnd :each | bnd merge: (each at: 1)]! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'jm 11/19/97 19:28'!
paragraphClass
	^ TextOnCurve! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/4/97 08:28'!
releaseCachedState
	textSegments _ nil.! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:16'!
textDirection
	^ textDirection! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/4/97 09:23'!
textDirection: plusOrMinusOne
	textDirection _ plusOrMinusOne! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:29'!
textSegments
	^ textSegments! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 12/3/97 09:29'!
textSegments: segments
	textSegments _ segments! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 11/21/97 21:48'!
top
	^ 1  "for compatibility"! !

!TextOnCurveContainer methodsFor: 'as yet unclassified' stamp: 'di 1/9/98 11:49'!
translateBy: delta
	textSegments == nil ifTrue: [^ self].
	textSegments _ textSegments collect:
		[:ls | Array with: ((ls at: 1) translateBy: delta)
					with: ((ls at: 2) translateBy: delta)
					with: (ls at: 3)]! !
TextOnCurve subclass: #TextOnCurvePS
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Text Support'!

!TextOnCurvePS methodsFor: 'as yet unclassified' stamp: 'di 8/13/2000 12:39'!
displayOn: aCanvas using: displayScanner at: somePosition
	"Send all visible lines to the displayScanner for display"

	self textSegmentsDo:
		[:line :destRect :segStart :segAngle |
		self displaySelectionInLine: line on: aCanvas.
		line first <= line last ifTrue:
			[displayScanner displayLine: line offset: destRect topLeft leftInRun: 999]]

! !
TextAction subclass: #TextPlusJumpEnd
	instanceVariableNames: 'jumpLabel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:33'!
emphasizeScanner: scanner

	"none for me, thanks"! !

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
jumpLabel

	^jumpLabel! !

!TextPlusJumpEnd methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
jumpLabel: aString

	jumpLabel _ aString! !

TextAction subclass: #TextPlusJumpStart
	instanceVariableNames: 'jumpLabel '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 13:06'!
actOnClickFor: model
	"Subclasses may override to provide, eg, hot-spot actions"

	model doJumpTo: jumpLabel.
	^ true! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:34'!
emphasizeScanner: scanner
	"Set the emphasist for text scanning"
	scanner addEmphasis: 4! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:21'!
jumpLabel

	^jumpLabel! !

!TextPlusJumpStart methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:21'!
jumpLabel: aString

	jumpLabel _ aString! !

TextMorph subclass: #TextPlusMorph
	instanceVariableNames: 'scrollerOwner ignoreNextUp '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 16:18'!
addAlansAnchorFor: aMorph

	| ed attribute selRects |

	self removeAlansAnchorFor: aMorph.
	ed _ self editor.
	attribute _ TextAnchorPlus new anchoredMorph: aMorph.
	ed replaceSelectionWith: (ed selection addAttribute: attribute).
	selRects _ self paragraph selectionRects.
	selRects isEmpty ifFalse: [
		aMorph top: selRects first top
	].
	self releaseParagraphReally.
	self layoutChanged.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:01'!
addJumpBeginning

	| ed attribute jumpEnd mySelection a1 ax |

	ed _ self editor.
	(mySelection _ ed selection) isEmpty ifTrue: [^self inform: 'Please select something first'].
	jumpEnd _ self chooseOneJumpEnd.
	jumpEnd isEmptyOrNil ifTrue: [^self].

	attribute _ TextPlusJumpStart new jumpLabel: jumpEnd.
	a1 _ (mySelection attributesAt: 1) reject: [ :each | each isKindOf: TextPlusJumpStart].
	ax _ (mySelection attributesAt: mySelection size) reject: [ :each | each isKindOf: TextPlusJumpStart].
	ed replaceSelectionWith: 
		(Text string: '*' attributes: a1),
		(mySelection addAttribute: attribute),
		(Text string: '*' attributes: ax).
	self releaseParagraphReally.
	self layoutChanged.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:18'!
addJumpEnd

	| ed attribute jumpLabel selectedString |

	ed _ self editor.
	selectedString _ ed selection asString.
	selectedString isEmpty ifTrue: [^self inform: 'Please select something first'].
	jumpLabel _ FillInTheBlank request: 'Name this place' initialAnswer: selectedString.
	jumpLabel isEmpty ifTrue: [^self].
	self removeJumpEndFor: jumpLabel.
	attribute _ TextPlusJumpEnd new jumpLabel: jumpLabel.
	ed replaceSelectionWith: (ed selection addAttribute: attribute).

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 14:41'!
allJumpEndStrings

	| answer |

	answer _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextPlusJumpEnd) ifTrue: [
				(answer includes: att jumpLabel) ifFalse: [answer add: att jumpLabel].
			]
		]
	].
	^answer

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:28'!
chooseOneJumpEnd

	| menu |

	menu _ CustomMenu new.
	self allJumpEndStrings do: [ :each |
		menu 
			add: each 
			action: each
	].
	^menu build startUpCenteredWithCaption: 'Possible jump ends'.
	
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:10'!
doJumpTo: aString

	| myStart myStop |
	myStart _ myStop _ nil.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			((att isMemberOf: TextPlusJumpEnd) and: [att jumpLabel = aString]) ifTrue: [
				myStart 
					ifNil: [myStart _ start. myStop _ stop] 
					ifNotNil: [myStart _ myStart min: start. myStop _ myStop max: stop].
			]
		]
	].
	myStart ifNil: [^self].

	self editor selectFrom: myStart to: myStop.
	ignoreNextUp _ true.
	self changed.
	scrollerOwner ifNil: [^self].
	scrollerOwner scrollSelectionIntoView: nil alignTop: true.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:52'!
doYellowButtonPress: evt

	| menu |

	menu _ CustomMenu new.
	menu 
		add: 'Go to top of document'				action: [self jumpToDocumentTop];
		add: 'Move selection to top of page'		action: [self scrollSelectionToTop];
		add: 'Define as jump start'				action: [self addJumpBeginning];
		add: 'Define as jump end'				action: [self addJumpEnd].

	((menu build startUpCenteredWithCaption: 'Text navigation options') ifNil: [^self]) value.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 15:55'!
extent: aPoint 

	self releaseParagraphReally.
	super extent: aPoint ! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:07'!
handleInteraction: interactionBlock fromEvent: evt
	
	super handleInteraction: interactionBlock fromEvent: evt.
	scrollerOwner ifNil: [^self].
	scrollerOwner scrollSelectionIntoView: nil alignTop: false.! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 16:00'!
jumpToDocumentTop

	self editor selectFrom: 1 to: 0.
	self changed.
	scrollerOwner ifNil: [^self].
	scrollerOwner scrollSelectionIntoView: nil alignTop: true.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/19/2000 16:27'!
linkNewlyDroppedMorph: aMorph

	| ed para lineToUse |

	ed _ self editor.
	para _ self paragraph.
	lineToUse _ para lines detect: [ :each | each bottom > aMorph top] ifNone: [para lines last].
	ed selectFrom: lineToUse first to: lineToUse last.
	self addAlansAnchorFor: aMorph.

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:53'!
mouseDown: evt

	ignoreNextUp _ false.
	evt yellowButtonPressed ifTrue: [
		^self doYellowButtonPress: evt
	].
	^super mouseDown: evt
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:53'!
mouseMove: evt

	ignoreNextUp == true ifTrue: [^self].
	^super mouseMove: evt
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:53'!
mouseUp: evt

	ignoreNextUp == true ifTrue: [ignoreNextUp _ false. ^self].
	^super mouseUp: evt
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 15:50'!
releaseEditor! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 15:49'!
releaseParagraph! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 15:52'!
releaseParagraphReally
	"Paragraph instantiation is lazy -- it will be created only when needed"

	editor ifNotNil: [
		self selectionChanged.
		self paragraph selectionStart: nil selectionStop: nil.
		editor _ nil].
	paragraph ifNotNil: [paragraph _ nil].
	container ifNotNil: [container releaseCachedState]! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/21/2000 17:12'!
removeAlansAnchorFor: aMorph

	| anchors |

	anchors _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextAnchorPlus) ifTrue: [
				(att anchoredMorph isNil or: [
					att anchoredMorph == aMorph or: [att anchoredMorph world isNil]]) ifTrue: [
					anchors add: {att. start. stop}
				]
			]
		]
	].
	anchors do: [ :old |
		text removeAttribute: old first from: old second to: old third.
	].

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 12:08'!
removeJumpEndFor: aString

	| anchors |

	anchors _ OrderedCollection new.
	text runs withStartStopAndValueDo: [:start :stop :attributes |
		attributes do: [:att |
			(att isMemberOf: TextPlusJumpEnd) ifTrue: [
				att jumpLabel == aString ifTrue: [
					anchors add: {att. start. stop}
				]
			]
		]
	].
	anchors do: [ :old |
		text removeAttribute: old first from: old second to: old third.
	].

! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/13/2000 15:36'!
scrollSelectionToTop

	scrollerOwner ifNil: [^self].
	scrollerOwner scrollSelectionIntoView: nil alignTop: true.
! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:50'!
scrollerOwner: x

	scrollerOwner _ x! !

!TextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 16:23'!
textPlusMenuFor: aMorph

	| menu |
	menu _ MenuMorph new.
	menu 
		add: 'Link to text selection' 
		target: [self addAlansAnchorFor: aMorph] fixTemps
		selector: #value;

		add: 'Unlink from text selection' 
		target: [self removeAlansAnchorFor: aMorph] fixTemps
		selector: #value;

		add: 'Delete' 
		target: [
			self removeAlansAnchorFor: aMorph.
			aMorph delete.
		] fixTemps
		selector: #value.
	^menu
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPlusMorph class
	instanceVariableNames: ''!

!TextPlusMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 9/6/2000 16:26'!
includeInNewMorphMenu

	^ false! !
PasteUpMorph subclass: #TextPlusPasteUpMorph
	instanceVariableNames: 'theTextMorph showPageBreaks '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-GeeMail'!

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:21'!
acceptDroppingMorph: aMorph event: evt

	(aMorph isKindOf: NewHandleMorph) ifTrue: [^self].
	(aMorph isKindOf: GeeBookMorph) ifTrue: [^self].	"avoid looping"
	self addMorph: aMorph.
	aMorph allMorphsDo: [ :each | theTextMorph removeAlansAnchorFor: each].
	theTextMorph linkNewlyDroppedMorph: aMorph! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:18'!
disablePageBreaksWhile: aBlock

	| save result |

	save _ showPageBreaks.
	showPageBreaks _ false.
	result _ aBlock value.
	showPageBreaks _ save.
	^result
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/10/2000 12:55'!
dragThroughOnDesktop: evt
	"Draw out a selection rectangle"
	| selection |

	"globalPt _ (self transformFrom: self world) localPointToGlobal: evt cursorPoint."
	selection _ SelectionMorph newBounds: (evt cursorPoint extent: 8@8).
	self addMorph: selection.
	^ selection extendByHandPlus: evt hand
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 15:55'!
drawOn: aCanvas

	| clip rects |
	super drawOn: aCanvas.
	showPageBreaks == false ifTrue: [^self].

	clip _ aCanvas clipRect.
	rects _ self printer pageRectangles.
	rects do: [ :each |
		each bottom > clip bottom ifTrue: [^self].
		aCanvas 
			fillRectangle: (self left @ each bottom corner: self right @ each bottom + 1) 
			color: Color red
	].! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:19'!
fullDrawForPrintingOn: aCanvas

	self disablePageBreaksWhile: [self fullDrawOn: aCanvas].
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 15:54'!
initialize

	super initialize.
	showPageBreaks _ true.! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/18/2000 10:25'!
printer

	^GeePrinter new 
		pasteUp: self;
		printSpecs: self printSpecs! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 16:19'!
textPlusMenuFor: aMorph

	^theTextMorph textPlusMenuFor: aMorph
! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 11:53'!
theTextMorph: x

	self addMorph: (theTextMorph _ x)! !

!TextPlusPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 12:56'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. The default implementation returns false.
NOTE: the event is assumed to be in global (world) coordinates."

	(aMorph isKindOf: NewHandleMorph) ifTrue: [^false].
	(aMorph isKindOf: GeeBookMorph) ifTrue: [^false].	"avoid looping"
	^super wantsDroppedMorph: aMorph event: evt! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPlusPasteUpMorph class
	instanceVariableNames: ''!

!TextPlusPasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 9/7/2000 12:02'!
includeInNewMorphMenu

	^ false! !
Object subclass: #TextPrinter
	instanceVariableNames: 'form para paperSize landscape resolution depth offset columns docTitle noHeader noFooter '
	classVariableNames: 'DefaultPaperSize DefaultTextPrinter '
	poolDictionaries: ''
	category: 'Graphics-Text'!

!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:26'!
defaultPaperSize
	"Return the default paper size (inches) for printing"
	^self class defaultPaperSize! !

!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 15:06'!
defaultResolution
	"Return the default resolution (DPI) for printing"
	^96.0@96.0! !

!TextPrinter methodsFor: 'initialize' stamp: 'ar 4/30/98 19:39'!
initialize
	self paperSize: self defaultPaperSize.
	self resolution: self defaultResolution.
	self blackAndWhite.
	self landscape: false.
	self offsetRect: (1.0@1.0 corner: 1.0@1.0).
	self columns: 1.
	self noHeader: false.
	self noFooter: false.
	self documentTitle: 'Squeak Document (from ', Date today printString,')'.! !


!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
bestColor
	"Set the reproduction quality to true color"
	depth := 32.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
blackAndWhite
	"Set the reproduction quality to black and white"
	depth := 1.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'!
columns
	^columns! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:50'!
columns: aNumber
	columns := aNumber asInteger max: 1.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'!
documentTitle
	^docTitle! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 20:14'!
documentTitle: aString
	docTitle := aString! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
goodColor
	"Set the reproduction quality to 8 bit color depth"
	depth := 8.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
landscape
	^landscape! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
landscape: aBoolean
	landscape := aBoolean! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:23'!
noFooter
	^noFooter! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noFooter: aBoolean
	"Turn off footer printing"
	noFooter := aBoolean.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noHeader
	^noHeader! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:22'!
noHeader: aBoolean
	"Turn off header printing"
	noHeader := aBoolean.! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'!
offsetRect
	^offset! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 19:27'!
offsetRect: aRectangle
	"Set the offset rectangle"
	offset := aRectangle! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
paperSize
	^paperSize! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:42'!
paperSize: aPoint
	paperSize := aPoint! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'!
resolution
	^resolution! !

!TextPrinter methodsFor: 'accessing' stamp: 'ar 4/30/98 18:43'!
resolution: aPoint
	resolution := aPoint! !


!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 20:41'!
flushPage
	"The current page has been set up. Send it to the printer."
	form primPrintHScale: self resolution x vScale: self resolution y landscape: self landscape.
	"Uncomment the following for testing"
	"form displayOn: Display. (Delay forSeconds: 5) wait."
! !

!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 19:19'!
printParagraph
	| pageNum nextIndex |
	para destinationForm: form.
	pageNum := 1.
	nextIndex := 1.
	[form fillColor: Color white.
	self printHeader: pageNum.
	self printFooter: pageNum.
	nextIndex := self formatPage: pageNum startingWith: nextIndex.
	self flushPage.
	nextIndex isNil] whileFalse:[pageNum := pageNum + 1].! !

!TextPrinter methodsFor: 'printing' stamp: 'ar 4/30/98 18:55'!
printText: aText
	"Print aText"
	form isNil ifTrue:[
		form := Form extent: self pixelSize depth: depth.
	].
	para := Paragraph withText: aText asText.
	Cursor wait showWhile:[
		self printParagraph.
	].! !


!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:25'!
columnRect: n
	"Return a rectangle describing the n-th column"
	| area left right |
	area := self textArea.
	left := area left + ((n-1) * self columnWidth).
	left := left + ((n-1) * self columnSkip).
	right := left + self columnWidth.
	^(self in2pix: left @ area top) corner: 
		(self in2pix: right @ area bottom)! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:20'!
columnSkip
	"Return the separating space between two columns in inches"
	^0.2! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:21'!
columnWidth
	^(self textWidth - ((self columns-1) * self columnSkip)) / self columns! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'!
formatColumn: columnNum startingWith: anIndex
	"Format a new column starting at the given string index. Return the string index indicating the start of the next column or nil if no more columns need printing."
	| colRect blk |
	colRect := self columnRect: columnNum.
	anIndex > 1 ifTrue:[para text: (para text copyFrom: anIndex to: para text size)].
	para compositionRectangle: colRect.
	para clippingRectangle: colRect.
	para composeAll.
	para displayOn: form.
	para visibleRectangle corner y <= colRect extent y ifTrue:[^nil].
	"More columns -- find the character block of the last line and adjust clip rect"
	blk := para characterBlockAtPoint: para visibleRectangle bottomLeft.
	para clearVisibleRectangle. "Make sure that the background is clean"
	para clippingRectangle: (colRect topLeft corner: colRect right@blk top).
	para displayOn: form.
	^blk stringIndex.! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:29'!
formatPage: pageNum startingWith: anIndex
	"Format a new page starting at the given string index. Return the string index indicating the start of the next page or nil if no more pages need printing."
	| nextIndex |
	nextIndex := anIndex.
	1 to: self columns do:[:i|
		nextIndex := self formatColumn: i startingWith: nextIndex.
		nextIndex isNil ifTrue:[^nil].
	].
	^nextIndex! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:58'!
textArea
	^(self offsetRect origin + (0.0@self headerHeight)) corner:
		(self realPaperSize - self offsetRect corner - (0.0@self footerHeight))! !

!TextPrinter methodsFor: 'formatting' stamp: 'ar 4/30/98 19:23'!
textWidth
	^self textArea extent x! !


!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'!
headerHeight
	"Return the (additional) height of the header in inches."
	self noHeader ifTrue:[^0.0].
	^(self pix2in: 0@TextStyle default lineGrid) y * 2! !

!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 20:11'!
headerParagraph
	"Return a paragraph for the footer"
	| hPara rect |
	hPara := Paragraph new.
	hPara destinationForm: form.
	rect := (self in2pix: self textArea topLeft - (0.0@self headerHeight)) corner: 
				(self in2pix: self textArea topRight).
	hPara clippingRectangle: rect.
	hPara compositionRectangle: rect.
	^hPara! !

!TextPrinter methodsFor: 'header' stamp: 'ar 4/30/98 19:23'!
printHeader: pageNumber
	"Print the header for the given page number"
	| fPara |
	self noHeader ifTrue:[^self].
	fPara := self headerParagraph.
	fPara centered.
	fPara text: self documentTitle asText.
	fPara displayOn: form.! !


!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:23'!
footerHeight
	"Return the (additional) height of the footer in inches."
	self noFooter ifTrue:[^0.0].
	^(self pix2in: 0@TextStyle default lineGrid) y * 2! !

!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 20:11'!
footerParagraph
	"Return a paragraph for the footer"
	| fPara rect |
	fPara := Paragraph new.
	fPara destinationForm: form.
	rect := (self in2pix: self textArea bottomLeft) corner: 
				(self in2pix: self textArea bottomRight + (0.0@self footerHeight)).
	fPara clippingRectangle: rect.
	fPara compositionRectangle: rect.
	^fPara! !

!TextPrinter methodsFor: 'footer' stamp: 'ar 4/30/98 19:24'!
printFooter: pageNumber
	"Print the footer for the given page number"
	| fPara |
	self noFooter ifTrue:[^self].
	fPara := self footerParagraph.
	fPara centered.
	fPara text: ('Page ', pageNumber printString) asText.
	fPara displayOn: form.! !


!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'!
in2mm: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint * 25.4! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'!
in2pix: aPoint
	"Convert aPoint from inches to actual pixels"
	^(aPoint * self resolution) rounded! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:38'!
mm2in: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint / 25.4! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'!
mm2pix: aPoint
	"Convert aPoint from millimeters to actual pixels"
	^self in2pix: (self mm2in: aPoint)! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:39'!
pix2in: aPoint
	"Convert aPoint from a pixel value to inches"
	^aPoint / self resolution! !

!TextPrinter methodsFor: 'other' stamp: 'ar 4/30/98 18:40'!
pix2mm: aPoint
	"Convert aPoint from a pixel value to millimeters"
	^self in2mm: (self pix2in: aPoint)! !


!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:40'!
pixelSize
	"Return the size of the page in pixels"
	^self in2pix: (self realPaperSize)! !

!TextPrinter methodsFor: 'private' stamp: 'ar 4/30/98 19:39'!
realPaperSize
	^self landscape
		ifTrue:[self paperSize y @ self paperSize x]
		ifFalse:[self paperSize]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextPrinter class
	instanceVariableNames: ''!

!TextPrinter class methodsFor: 'class initialization' stamp: 'ar 4/30/98 18:30'!
initialize
	"TextPrinter initialize"
	self defaultPaperSize: self paperSizeA4.! !


!TextPrinter class methodsFor: 'instance creation' stamp: 'ar 4/30/98 15:42'!
new
	^super new initialize! !


!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'!
defaultPaperSize
	^DefaultPaperSize! !

!TextPrinter class methodsFor: 'accessing' stamp: 'ar 4/30/98 18:31'!
defaultPaperSize: aPoint
	DefaultPaperSize := aPoint! !

!TextPrinter class methodsFor: 'accessing' stamp: 'dew 3/7/2000 20:39'!
defaultTextPrinter
	"This is the global default TextPrinter instance."
	DefaultTextPrinter isNil ifTrue: [DefaultTextPrinter _ self new].
	^DefaultTextPrinter! !


!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'!
mm2in: aPoint
	"Convert aPoint from millimeters to inches"
	^aPoint / 25.4! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSize10x14
	^10.0@14.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSize11x17
	^11.0@17.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA3
	^self mm2in: 297@420! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA4
	^self mm2in: 210@297! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeA5
	^self mm2in: 148@210! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeB4
	^self mm2in: 250@354! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:27'!
paperSizeB5
	^self mm2in: 182@257! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeCSheet
	^17.0@22.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeDSheet
	^22.0@34.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeESheet
	^34.0@44.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope10
	^4.125@9.5
! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope11
	^4.5@10.375! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope12
	^4.75@11! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope14
	^5.0@11.5! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelope9
	^3.875@8.875! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB4
	^self mm2in: 250@353! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB5
	^self mm2in: 176@250! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeB6
	^self mm2in: 176@125! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:28'!
paperSizeEnvelopeC3
	^self mm2in: 324@458! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC4
	^self mm2in: 229@324! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC5
	^self mm2in: 162@229! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC6
	^self mm2in: 114@162! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeEnvelopeC65
	^self mm2in: 114@229! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldGerman
	"German standard fanfold"
	^8.5@12.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldLegalGerman
	"German legal fanfold"
	^8.5@13.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFanfoldUS
	"US standard fanfold"
	^14.875@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeFolio
	^8.5@13.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeLegal
	^8.5@14.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeLetter
	^8.5@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:29'!
paperSizeNote
	^8.5@11.0! !

!TextPrinter class methodsFor: 'paper sizes' stamp: 'ar 4/30/98 18:30'!
paperSizeTabloid
	^11.0@17.0! !
TextURL subclass: #TextSqkPageLink
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!
!TextSqkPageLink commentStamp: '<historical>' prior: 0!
I represent a link to either a SqueakPage in a BookMorph, or a regular url.  See TextMorphEditor changeEmphasis:.  
!
]style[(81 31 4)f1,f1LTextMorphEditor changeEmphasis:;,f1!


!TextSqkPageLink methodsFor: 'as yet unclassified' stamp: 'tk 1/12/1999 12:56'!
actOnClickFor: textMorph
	"I represent a link to either a SqueakPage in a BookMorph, or a regular url"

	| book |
	((url endsWith: '.bo') or: [url endsWith: '.sp']) ifFalse: [
		^ super actOnClickFor: textMorph].
	book _ textMorph ownerThatIsA: BookMorph.
	book ifNotNil: [book goToPageUrl: url].
	"later handle case of page being in another book, not this one"
	^ true! !

!TextSqkPageLink methodsFor: 'as yet unclassified' stamp: 'tk 1/13/1999 08:14'!
writeScanOn: strm

	strm nextPut: $q; nextPutAll: url; nextPut: $;! !
TextURL subclass: #TextSqkProjectLink
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:27'!
actOnClickFor: textMorph

	Project enterIfThereOrFind: url.
	^ true! !

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:24'!
analyze: aString

	^url _ aString! !

!TextSqkProjectLink methodsFor: 'as yet unclassified' stamp: 'RAA 10/19/2000 16:29'!
writeScanOn: strm

	strm nextPut: $p; nextPutAll: url; nextPut: $;! !
WriteStream subclass: #TextStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!

!TextStream methodsFor: 'as yet unclassified'!
applyAttribute: att beginningAt: startPos
	collection addAttribute: att from: startPos to: self position! !

!TextStream methodsFor: 'as yet unclassified'!
nextPutAll: aCollection 
	"Optimized access to get around Text at:Put: overhead"
	| n |
	n _ aCollection size.
	((aCollection isMemberOf: String) not or: [position + n > writeLimit])
		ifTrue: [^ super nextPutAll: aCollection].
	collection string
		replaceFrom: position+1
		to: position + n
		with: aCollection
		startingAt: 1.
	position _ position + n! !

!TextStream methodsFor: 'as yet unclassified'!
withAttribute: att do: strmBlock
	| pos1 val |
	pos1 _ self position.
	val _ strmBlock value.
	collection addAttribute: att from: pos1+1 to: self position.
	^ val! !

!TextStream methodsFor: 'as yet unclassified' stamp: 'djp 11/6/1999 20:30'!
withAttributes: attributes do: streamBlock 
	| pos1 val |
	pos1 _ self position.
	val _ streamBlock value.
	attributes do: [:attribute |
		collection
			addAttribute: attribute
			from: pos1 + 1
			to: self position].
	^ val! !
Object subclass: #TextStyle
	instanceVariableNames: 'fontArray fontFamilySize lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Text'!
!TextStyle commentStamp: '<historical>' prior: 0!
A textStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text.  Typically one makes a copy of a master textStyle (such as TextStyle default), and then that copy may get altered in the process of editing.  Bad things can happen if you do not copy first.

Each of my instances consists of...
	fontArray		An array of StrikeFonts
	fontFamilySize	unused
	lineGrid			An integer; default line spacing for paragraphs
	baseline			An integer; default baseline (dist from line top to bottom of an 'a')
	alignment		An integer; text alignment, see TextStyle alignment:
	firstIndent		An integer; indent of first line in pixels
	restIndent		An integer; indent of remaining lines in pixels
	rightIndent		An integer; indent of right margin rel to section
	tabsArray		An array of integers giving tab offsets in pixels
	marginTabsArray	An array of margin tabs
	leading			An integer giving default vertical line separation

For a concrete example, look at TextStyle default copy inspect!
]style[(367 10 211 20 381 30)f1,f1LStrikeFont Comment;,f1,f1LTextStyle alignment:;,f1,f1dTextStyle default copy inspect;;!


!TextStyle methodsFor: 'accessing' stamp: 'di 10/24/97 11:17'!
= other
	other class == self class ifFalse: [^ false].
	1 to: self class instSize do:
		[:i | (self instVarAt: i) == (other instVarAt: i) ifFalse: [^ false]].
	^ true! !

!TextStyle methodsFor: 'accessing'!
alignment
	"Answer the code for the current setting of the alignment."

	^alignment! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 15:17'!
alignment: anInteger 
	"Set the current setting of the alignment to be anInteger:
	0=left flush, 1=right flush, 2=centered, 3=justified."

	alignment _ anInteger \\ (Justified + 1)! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 15:16'!
alignmentSymbol
	"Answer the symbol for the current setting of the alignment."
	alignment = LeftFlush ifTrue:[^#leftFlush].
	alignment = Centered ifTrue:[^#centered].
	alignment = RightFlush ifTrue:[^#rightFlush].
	alignment = Justified ifTrue:[^#justified].
	^#leftFlush! !

!TextStyle methodsFor: 'accessing'!
baseline
	"Answer the distance from the top of the line to the bottom of most of the 
	characters (by convention, bottom of the letter 'A')."

	^baseline! !

!TextStyle methodsFor: 'accessing'!
baseline: anInteger 
	"Set the distance from the top of the line to the bottom of most of the 
	characters."

	baseline _ anInteger! !

!TextStyle methodsFor: 'accessing'!
centered
	alignment _ 2! !

!TextStyle methodsFor: 'accessing' stamp: 'sw 12/6/1999 12:31'!
defaultFont
	^ fontArray at: self defaultFontIndex! !

!TextStyle methodsFor: 'accessing'!
firstIndent
	"Answer the horizontal indenting of the first line of a paragraph in the 
	style of the receiver."

	^firstIndent! !

!TextStyle methodsFor: 'accessing'!
firstIndent: anInteger 
	"Set the horizontal indenting of the first line of a paragraph in the style 
	of the receiver to be the argument, anInteger."

	firstIndent _ anInteger! !

!TextStyle methodsFor: 'accessing'!
fontNamed: fontName  "TextStyle default fontNamed: 'TimesRoman10'"
	^ fontArray detect: [:x | x name sameAs: fontName]! !

!TextStyle methodsFor: 'accessing'!
fontNames  "TextStyle default fontNames"
	^ fontArray collect: [:x | x name]! !

!TextStyle methodsFor: 'accessing' stamp: 'tk 6/26/1998 15:03'!
fontNamesAndSizes  "TextStyle default fontNames"
	^ fontArray collect: [:x | x name, ' ', x height printString]! !

!TextStyle methodsFor: 'accessing' stamp: 'ar 9/21/2000 11:53'!
fontNamesWithPointSizes
	^ fontArray collect:
		[:x | x fontNameWithPointSize]

  "TextStyle default fontNamesWithPointSizes"! !

!TextStyle methodsFor: 'accessing'!
justified
	alignment _ 3! !

!TextStyle methodsFor: 'accessing'!
leading
	"Leading (from typographers historical use of extra lead (type metal))
	is the extra spacing above and beyond that needed just to accomodate
	the various font heights in the set."
	^ leading! !

!TextStyle methodsFor: 'accessing'!
leading: yDelta

	leading _ yDelta! !

!TextStyle methodsFor: 'accessing'!
leftFlush
	alignment _ 0! !

!TextStyle methodsFor: 'accessing'!
lineGrid
	"Answer the relative space between lines of a paragraph in the style of 
	the receiver."

	^lineGrid! !

!TextStyle methodsFor: 'accessing'!
lineGrid: anInteger 
	"Set the relative space between lines of a paragraph in the style of the 
	receiver to be the argument, anInteger."

	lineGrid _ anInteger! !

!TextStyle methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:57'!
printOn: aStream
	super printOn: aStream.
	aStream space; nextPutAll: self defaultFont name! !

!TextStyle methodsFor: 'accessing'!
restIndent
	"Answer the indent for all but the first line of a paragraph in the style 
	of the receiver."

	^restIndent! !

!TextStyle methodsFor: 'accessing'!
restIndent: anInteger 
	"Set the indent for all but the first line of a paragraph in the style of the 
	receiver to be the argument, anInteger."

	restIndent _ anInteger! !

!TextStyle methodsFor: 'accessing'!
rightFlush
	alignment _ 1! !

!TextStyle methodsFor: 'accessing'!
rightIndent
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver."

	^rightIndent! !

!TextStyle methodsFor: 'accessing'!
rightIndent: anInteger 
	"Answer the right margin indent for the lines of a paragraph in the style 
	of the receiver to be the argument, anInteger."

	rightIndent _ anInteger! !


!TextStyle methodsFor: 'tabs and margins'!
clearIndents
	"Reset all the margin (index) settings to be 0."

	self firstIndent: 0.
	self restIndent: 0.
	self rightIndent: 0! !

!TextStyle methodsFor: 'tabs and margins'!
leftMarginTabAt: marginIndex 
	"Set the 'nesting' level of left margin indents of the paragraph in the 
	style of the receiver to be the argument, marginIndex."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: 1]
		ifFalse: [^0]	
	"The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor."
! !

!TextStyle methodsFor: 'tabs and margins'!
nextTabXFrom: anX leftMargin: leftMargin rightMargin: rightMargin 
	"Tab stops are distances from the left margin. Set the distance into the 
	argument, anX, normalized for the paragraph's left margin."

	| normalizedX tabX |
	normalizedX _ anX - leftMargin.
	1 to: tabsArray size do: 
		[:i | (tabX _ tabsArray at: i) > normalizedX 
				ifTrue: [^leftMargin + tabX min: rightMargin]].
	^rightMargin! !

!TextStyle methodsFor: 'tabs and margins'!
rightMarginTabAt: marginIndex 
	"Set the 'nesting' level of right margin indents of the paragraph in the 
	style of the receiver to be marginIndex."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: 2]
		ifFalse: [^0]
	"The marginTabsArray is an Array of tuples.  The Array is indexed according 
	to the marginIndex, the 'nesting' level of the requestor."
! !

!TextStyle methodsFor: 'tabs and margins'!
tabWidth
	"Answer the width of a tab."

	^DefaultTab! !


!TextStyle methodsFor: 'fonts and font indexes' stamp: 'tk 6/26/1998 15:58'!
collectionFromFileNamed: fileName
	"Read the file.  It is an TextStyle whose StrikeFonts are to be added to the system.  (Written by fooling SmartRefStream, so it won't write a DiskProxy!!)  These fonts will be added to the master TextSytle for this font family.  
	To write out fonts: 
		| ff | ff _ ReferenceStream fileNamed: 'new fonts'.
		TextConstants at: #forceFontWriting put: true.
		ff nextPut: (TextConstants at: #AFontName).
			'do not mix font families in the TextStyle written out'.
		TextConstants at: #forceFontWriting put: false.
		ff close.
	To read: (TextStyle default collectionFromFileNamed: 'new fonts')
*** Do not remove this method *** "

	| ff this newName style heights |
	ff _ ReferenceStream fileNamed: fileName.
	this _ ff nextAndClose.	"Only works if file created by special code above"
	newName _ this fontArray first name.
	this fontArray do: [:aFont | aFont name = newName ifFalse: [
		self error: 'All must be same family']].
	style _ TextConstants at: newName asSymbol ifAbsent: [
		^ TextConstants at: newName asSymbol put: this].		"new family"
	this fontArray do: [:aFont | "add new fonts"
		heights _ style fontArray collect: [:bFont | bFont height].
		(heights includes: aFont height) ifFalse: [
			style fontAt: style fontArray size + 1 put: aFont]].
! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/8/1999 18:02'!
consistOnlyOf: aFont
	fontArray _ Array with: aFont.
	defaultFontIndex _ 1! !

!TextStyle methodsFor: 'fonts and font indexes'!
flushFonts
	"Clean out the fonts, an aid when snapshotting claims too many are 
	holding onto Display."

	(self confirm: 
'flushFonts is very dangerous.
Are you foolish or clever enough to proceed?')
		ifTrue: [1 to: fontArray size do: [:index | fontArray at: index put: nil]]
		ifFalse: [Transcript cr; show: 'flushFonts cancelled']

	"TextStyle default flushFonts"! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/6/1999 13:54'!
fontIndexOf: aFont
	^ fontArray indexOf: aFont ifAbsent: [nil]! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'di 10/11/97 09:23'!
fontIndexOfSize: desiredHeight
	"Returns an index in fontArray of the font with height <= desiredHeight"
	"Leading is not inluded in the comparison"
	| bestMatch bestIndex d |
	bestMatch _ 9999.  bestIndex _ 1.
	1 to: fontArray size do:
		[:i | d _ desiredHeight - (fontArray at: i) height.
		d = 0 ifTrue: [^ i].
		(d > 0 and: [d < bestMatch]) ifTrue: [bestIndex _ i. bestMatch _ d]].
	^ bestIndex! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 1/18/2000 21:34'!
fontOfPointSize: aPointSize
	^ fontArray detect: [:aFont | aFont pointSize = aPointSize] ifNone: [nil]! !

!TextStyle methodsFor: 'fonts and font indexes' stamp: 'di 10/11/97 09:33'!
fontOfSize: aHeight
	"See fontIndexOfSize.
	Returns the actual font.  Leading not considered."

	^ fontArray at: (self fontIndexOfSize: aHeight)! !


!TextStyle methodsFor: 'private'!
consolidate
	"If this style includes any fonts that are also in the default style,
	then replace them with references to the default ones."
"
	TextStyle allInstancesDo: [:s | s == TextStyle default ifFalse: [s consolidate]]
"
	| defFonts font |
	defFonts _ TextStyle default fontArray.
	1 to: fontArray size do:
		[:i | font _ fontArray at: i.
		1 to: defFonts size do:
			[:j | (font name asUppercase copyWithout: $ )
			= ((defFonts at: j) name asUppercase copyWithout: $ )
			ifTrue: [fontArray at: i put: (defFonts at: j)]]]! !

!TextStyle methodsFor: 'private'!
fontArray
	"Only for writing out fonts, etc.  8/16/96 tk"
	^ fontArray! !

!TextStyle methodsFor: 'private' stamp: 'di 3/20/1999 22:31'!
fontAt: index 
	"This is private because no object outside TextStyle should depend on the 
	representation of the font family in fontArray."

	^ fontArray atPin: index! !

!TextStyle methodsFor: 'private'!
fontAt: index put: font
	"Automatically grow the array.  8/20/96 tk"
	index > fontArray size ifTrue: [
		fontArray _ fontArray, (Array new: index - fontArray size)].
	fontArray at: index put: font! !

!TextStyle methodsFor: 'private'!
gridForFont: fontIndex withLead: leadInteger 
	"Force whole style to suit one of its fonts. Assumes only one font referred
	to by runs."
	| font |
	font _ self fontAt: fontIndex.
	self lineGrid: font height + leadInteger.
	self baseline: font ascent.
	self leading: leadInteger! !

!TextStyle methodsFor: 'private'!
marginTabAt: marginIndex side: sideIndex 
	"The marginTabsArray is an Array of tuples.  The Array is indexed
	according to the marginIndex, the 'nesting' level of the requestor.
	sideIndex is 1 for left, 2 for right."

	(marginIndex > 0 and: [marginIndex < marginTabsArray size])
		ifTrue: [^(marginTabsArray at: marginIndex) at: sideIndex]
		ifFalse: [^0]! !

!TextStyle methodsFor: 'private' stamp: 'tk 8/20/96'!
newFontArray: anArray
	"Currently there is no supporting protocol for changing these arrays. If an editor wishes to implement margin setting, then a copy of the default should be stored with these instance variables.  
	, Make size depend on first font."

	fontArray _ anArray.
	lineGrid _ (fontArray at: 1) height + leading.	"For whole family"
	baseline _ (fontArray at: 1) ascent + leading.
	alignment _ 0.
	firstIndent _ 0.
	restIndent _ 0.
	rightIndent _ 0.
	tabsArray _ DefaultTabsArray.
	marginTabsArray _ DefaultMarginTabsArray
"
TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default fontArray].
"! !


!TextStyle methodsFor: 'Disk I/O' stamp: 'tk 9/25/2000 10:10'!
storeDataOn: aDataStream
	"The shared arrays in tabsArray and marginTabsArray are the globals DefaultTabsArray and DefaultMarginTabsArray.  DiskProxies will be substituted for these in (Array objectForDataStream:)."

	^ super storeDataOn: aDataStream! !

!TextStyle methodsFor: 'Disk I/O' stamp: 'di 11/19/1999 20:12'!
veryDeepCopyWith: deepCopier
	"All inst vars are meant to be shared"

	self == #veryDeepCopyWith:.	"to satisfy checkVariables"
	^ deepCopier references at: self ifAbsent: [
		deepCopier references at: self put: self clone].	"remember"! !


!TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 12:30'!
defaultFontIndex
	^ defaultFontIndex ifNil: [defaultFontIndex _ 1]! !

!TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 13:50'!
defaultFontIndex: anIndex
	defaultFontIndex _ anIndex! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextStyle class
	instanceVariableNames: ''!

!TextStyle class methodsFor: 'instance creation' stamp: 'di 6/16/97 12:31'!
changeDefaultFontSizeBy: delta      "TextStyle changeDefaultFontSizeBy: 1"
	"This sample method recreates the default textStyle, with font 1 being a size
	larger than the smallest.  It then initializes most references in the system
	as well, although most windows will have to beclosed and reopened to get the effect."
	| allFonts |
	allFonts _ TextStyle default fontArray asSortedCollection: [:a :b | a height < b height].
	TextConstants at: #DefaultTextStyle put:
		(TextStyle fontArray: ((1 to: allFonts size) collect: [:i | allFonts atWrap: i+delta])).
	PopUpMenu initialize.  "Change this method for difft menu font"
	ListParagraph initialize.  "Change this method for difft ListPane font"
	StandardSystemView initialize.  "Change this method for difft Window label font"
! !

!TextStyle class methodsFor: 'instance creation'!
fontArray: anArray 
	"Answer an instance of me with fonts those in the argument, anArray."

	^self new newFontArray: anArray! !

!TextStyle class methodsFor: 'instance creation'!
initDefaultFontsAndStyle
	"This provides the system with 10 and 12-pt basal fonts.
	Bold and italic versions will be automatically generated as needed"
	| fontArray |	
	fontArray _ Array new: 2.
	fontArray at: 1 put: (StrikeFont new readFromStrike2: 'NewYork10.sf2').
	fontArray at: 2 put: (StrikeFont new readFromStrike2: 'NewYork12.sf2').
	TextConstants at: #DefaultTextStyle put:
		(TextStyle fontArray: fontArray).

	"TextStyle initDefaultFontsAndStyle."! !

!TextStyle class methodsFor: 'instance creation'!
new
	^ super new leading: 2! !


!TextStyle class methodsFor: 'constants'!
default
	"Answer the system default text style."

	^DefaultTextStyle! !

!TextStyle class methodsFor: 'constants' stamp: 'sw 12/6/1999 12:32'!
defaultFont
	"Answer the default system font"

	^ DefaultTextStyle defaultFont! !

!TextStyle class methodsFor: 'constants' stamp: 'di 10/20/97 20:08'!
named: familyName
	^ TextConstants at: familyName asSymbol ifAbsent: [nil]! !
TextAction subclass: #TextURL
	instanceVariableNames: 'url '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Text'!

!TextURL methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:04'!
actOnClickFor: anObject
	"Do what you can with this URL.  Later a web browser."

	| response m |

	(url beginsWith: 'sqPr://') ifTrue: [
		ProjectLoading thumbnailFromUrl: (url copyFrom: 8 to: url size).
		^self		"should not get here, but what the heck"
	].
	"if it's a web browser, tell it to jump"
	anObject isWebBrowser
		ifTrue: [anObject jumpToUrl: url. ^ true]
		ifFalse: [((anObject respondsTo: #model) and: [anObject model isWebBrowser])
				ifTrue: [anObject model jumpToUrl: url. ^ true]].

		"if it's a morph, see if it is contained in a web browser"
		(anObject isKindOf: Morph) ifTrue: [
			m _ anObject.
			[ m ~= nil ] whileTrue: [
				(m isWebBrowser) ifTrue: [
					m  jumpToUrl: url.
					^true ].
				(m hasProperty: #webBrowserView) ifTrue: [
					m model jumpToUrl: url.
					^true ].
				m _ m owner. ]
		].

	"no browser in sight.  ask if we should start a new browser"
	(self confirm: 'open a browser to view this URL?') ifTrue: [
		Scamper openOnUrl: url.
		^ true ].

	"couldn't display in a browser.  Offer to put up just the source"

	response _ (PopUpMenu labels: 'View web page as source\Cancel' withCRs)
		startUpWithCaption: 'Couldn''t find a web browser.  View
page as source?'.
	response = 1 ifTrue: [HTTPSocket httpShowPage: url].
	^ true! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 16:47'!
analyze: aString

	| list |
	list _ super analyze: aString.
	url _ list at: 1.
	^ list at: 2! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/30/97 10:33'!
info
	^ url! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 08:55'!
url: aString
	url _ aString! !

!TextURL methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 13:45'!
writeScanOn: strm

	strm nextPut: $R; nextPutAll: url; nextPut: $;! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TextURL class
	instanceVariableNames: ''!

!TextURL class methodsFor: 'as yet unclassified' stamp: 'tk 12/16/97 09:24'!
scanFrom: strm
	"read a link in the funny format used by Text styles on files. Rhttp://www.disney.com;"

	^ self new url: (strm upTo: $;)! !
Object subclass: #TheWorldMenu
	instanceVariableNames: 'myProject myWorld myHand '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Kernel'!

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 10:16'!
adaptToWorld: aWorld

        myWorld _ aWorld.
        myProject _ nil.                "figure it out if and when needed. maybe make it easier to find"
        myHand _ aWorld primaryHand.! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 10:18'!
beIsolated
        "Establish this project as an isolation layer.
        Further method changes made here will be revoked when you leave the project."

        self projectForMyWorld beIsolated.! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 18:54'!
changeBackgroundColor
	"Let the user select a new background color for the world"

	myWorld changeColorTarget: myWorld selector: #color: originalColor: myWorld color hand: myWorld activeHand.
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 19:17'!
cleanUpWorld
	(SelectionMenu confirm:
'This will remove all windows except those
containing unsubmitted text edits, and will
also remove all non-window morphs (other
than flaps) found on the desktop.  Are you
sure you want to do this?')
		ifFalse: [^ self].

	myWorld allNonFlapRelatedSubmorphs do:
		[:m | m delete].
	(SystemWindow windowsIn: myWorld satisfying: [:w | w model canDiscardEdits])
		do: [:w | w delete]! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/26/2000 11:17'!
createStandardPartsBin

	myHand presenter createStandardPartsBin! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:18'!
inspectWorldModel
	| insp |

	insp _ InspectorBrowser openAsMorphOn: myWorld model.
	myWorld addMorph: insp; startStepping: insp! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/26/2000 11:17'!
launchCustomPartsBin

	myHand presenter launchCustomPartsBin! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 10/15/2000 18:02'!
loadProject

	| stdFileMenuResult |
	"Put up a Menu and let the user choose a '.project' file to load.  Create a thumbnail and jump into the project."

	Project canWeLoadAProjectNow ifFalse: [^ self].
	stdFileMenuResult _ ((StandardFileMenu new) pattern: '*.pr'; 
		oldFileFrom: FileDirectory default ) 
			startUpWithCaption: 'Select a File:'.
	stdFileMenuResult ifNil: [^ nil].
	ProjectLoading 
		openFromDirectory: stdFileMenuResult directory 
		andFileName: stdFileMenuResult name
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/26/2000 10:47'!
lookForSlips

	Smalltalk changes lookForSlips! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/12/2000 18:28'!
menu: titleString

	| menu |

	(menu _ MenuMorph entitled: titleString) 
		defaultTarget: self; 
		addStayUpItem.
	self colorForDebugging: menu.
	^menu
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 17:31'!
mvcProjectsAllowed

	^Preferences mvcProjectsAllowed and: [Smalltalk includesKey: #StandardSystemView]! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 07:42'!
newMorphOfClass: morphClass event: evt
	"Attach a new morph of the given class to the invoking hand."

	| m |
	m _ morphClass new.
	m installModelIn: myWorld.  "a chance to install model pointers"
	m wantsToBeOpenedInWorld
		ifTrue:[myWorld addMorph: m]
		ifFalse:[evt hand attachMorph: m].
	myWorld startSteppingSubmorphsOf: m.
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/26/2000 08:43'!
openChangeSorter1

	ChangeSorter new morphicWindow openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/26/2000 08:43'!
openChangeSorter2

	DualChangeSorter new morphicWindow openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/12/2000 18:14'!
openEmail
	"open an email interface"

	Celeste open! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:52'!
openFileList

	FileList openAsMorph openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:55'!
openIRC
	"open an interface to Internet Relay Chat"

	IRCConnection new openView; openDirectMessagesObserver! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 17:32'!
openMVCProject

	ProjectViewMorph newMVCProject openInWorld.
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 10/6/2000 13:54'!
openMorphicProject

	Project newMorphicOn: nil
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:50'!
openSelectorBrowser

	SelectorBrowser new morphicWindow openInWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:53'!
openTranscript

	(Transcript openAsMorphLabel: 'Transcript') openInWorld: myWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:51'!
openWorkspace

	Workspace new openAsMorphLabel: 'Workspace' inWorld: myWorld! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 2/1/2001 15:55'!
printWorldOnFile
	"Ask the user for a filename and print the world as postscript."

	myWorld printPSToFileNamed: 'SqueakScreen'
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 10:17'!
projectForMyWorld

        ^myProject ifNil: [myProject _ myWorld project]! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/15/2000 10:18'!
propagateChanges.
        "The changes made in this isolated project will be propagated to projects above."

        self projectForMyWorld propagateChanges.! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 17:55'!
quitSession

	Smalltalk
		snapshot: (self confirm: 'Save changes before quitting?' orCancel: [^ self])
		andQuit: true! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'mdr 9/4/2000 11:05'!
readMorphFromAFile
	"Produce a morph from a file -- either a saved .morph file or a graphics file"

	| morphOrList ff aName f m |
	aName _ Utilities chooseFileWithSuffixFromList:
(#('.morph'), Utilities graphicsFileSuffixes) withCaption: 'Choose a file
to load'.
	aName ifNil: [^ self].  "User made no choice"
	aName == #none ifTrue: [^ self inform: 
'Sorry, no suitable files found
(names should end with .morph, .gif,
.bmp, .jpeg, .jpe, .jp, or .form)'].

	(aName asLowercase endsWith: '.morph')
		ifTrue:
			[ff _ FileStream readOnlyFileNamed: aName.
			morphOrList _ ff fileInObjectAndCode.		"code filed in is the Model class"
			"the file may contain either a single morph or an array of morphs"
			myWorld addMorphsAndModel: morphOrList]
		ifFalse:
			[f _ Form fromFileNamed: aName.
			f ifNil: [^ self error: 'unrecognized image file format'].
			m _ myWorld drawingClass new form: f.
			myHand attachMorph: m]
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 17:54'!
saveAndQuit

	Smalltalk snapshot: true andQuit: true! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 17:53'!
saveSession

	Smalltalk snapshot: true andQuit: false! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:13'!
saveWorldInFile
	"Save the world's submorphs, model, and stepList in a file.  "

	| fileName fileStream aClass |
	fileName _ FillInTheBlank request: 'File name for this morph?'.
	fileName isEmpty ifTrue: [^ self].  "abort"

	"Save only model, stepList, submorphs in this world"
	myWorld submorphsDo: [:m |
		m allMorphsDo: [:subM | subM prepareToBeSaved]].	"Amen"

	fileStream _ FileStream newFileNamed: fileName, '.morph'.
	aClass _ myWorld model ifNil: [nil] ifNotNil: [myWorld model class].
	fileStream fileOutClass: aClass andObject: myWorld.
! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:53'!
setDisplayDepth
	"Let the user choose a new depth for the display. "

	| result oldDepth |
	oldDepth _ Display depth.
	(result _ (SelectionMenu selections: Display supportedDisplayDepths) startUpWithCaption:
'Choose a display depth
(it is currently ' , oldDepth printString , ')') ifNotNil: [Display newDepth: result].
	(Smalltalk isMorphic and: [(Display depth < 4) ~= (oldDepth < 4)])
		ifTrue:
			["Repaint windows since they look better all white in depth < 4"
			(SystemWindow windowsIn: myWorld satisfying: [:w | true]) do:
				[:w |
				oldDepth < 4
					ifTrue: [w restoreDefaultPaneColor]
					ifFalse: [w updatePaneColors]]]! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 19:21'!
splitNewMorphList: list depth: d

	| middle c prev next out |

	d <= 0 ifTrue:[^Array with: list].
	middle _ list size // 2 + 1.
	c _ (list at: middle) name first.
	prev _ middle - 1.
	[prev > 0 and:[(list at: prev) name first = c]] 
		whileTrue:[prev _ prev - 1].
	next _ middle + 1.
	[next <= list size and:[(list at: next) name first = c]]
		whileTrue:[next _ next + 1].
	"Choose the better cluster"
	(middle - prev) < (next - middle)
		ifTrue:[middle _ prev+1]
		ifFalse:[middle _ next].
	middle = 1 ifTrue:[middle _ next].
	middle >= list size ifTrue:[middle _ prev+1].
	(middle = 1 or:[middle >= list size]) ifTrue:[^Array with: list].
	out _ WriteStream on: Array new.
	out nextPutAll: (self splitNewMorphList: (list copyFrom: 1 to: middle-1) depth: d-1).
	out nextPutAll: (self splitNewMorphList: (list copyFrom: middle to: list size) depth: d-1).
	^out contents.! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 6/2/2000 10:54'!
startMessageTally

	(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen') ifTrue:
		[MessageTally spyOn:
			[[Sensor primMousePt y > 0] whileTrue: [Display doOneCycleMorphic]]]! !

!TheWorldMenu methodsFor: 'as yet unclassified'!
startThenBrowseMessageTally
	(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen')
		ifTrue: [TimeProfileBrowser
				onBlock: [[Sensor primMousePt y > 10]
						whileTrue: [Display doOneCycleMorphic]]]! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 19:02'!
world: aWorld project: aProject hand: aHand

	myWorld _ aWorld.
	myProject _ aProject.
	myHand _ aHand.! !

!TheWorldMenu methodsFor: 'as yet unclassified' stamp: 'RAA 5/24/2000 18:29'!
worldMenuHelp
	| aList aMenu cnts explanation |
	"self currentWorld primaryHand worldMenuHelp"

	aList _ OrderedCollection new.
	#(helpMenu changesMenu openMenu debugMenu projectMenu scriptingMenu windowsMenu playfieldMenu appearanceMenu) 
		with:
	#('help' 'changes' 'open' 'debug' 'projects' 'authoring tools' 'windows & flaps' 'playfield options' 'appearance') do:
		[:sel :title | aMenu _ self perform: sel.
			aMenu items do:
				[:it | (((cnts _ it contents) = 'keep this menu up') or: [cnts size = 0])
					ifFalse: [aList add: (cnts, ' - ', title)]]].
	aList _ aList asSortedCollection: [:a :b | a asLowercase < b asLowercase].

	explanation _ String streamContents: [:aStream | aList do:
		[:anItem | aStream nextPutAll: anItem; cr]].

	(StringHolder new contents: explanation)
		openLabel: 'Where in the world menu is...'! !


!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 5/25/2000 07:42'!
alphabeticalMorphMenu

	| list splitLists menu firstChar lastChar subMenu |
	list _ Morph withAllSubclasses select:[:m | m includeInNewMorphMenu].
	list _ list asArray sortBy:[:c1 :c2| c1 name < c2 name].
	splitLists _ self splitNewMorphList: list depth: 3.
	menu _ MenuMorph new defaultTarget: self.
	1 to: splitLists size do:[:i|
		i = 1 ifTrue:[firstChar _ $A]
			ifFalse:[firstChar _ ((splitLists at: i-1) last name first asInteger + 1) asCharacter].
		i = splitLists size
			ifTrue:[lastChar _ $Z]
			ifFalse:[lastChar _ (splitLists at: i) last name first].
		subMenu _ MenuMorph new.
		(splitLists at: i) do:[:cl|
			subMenu add: cl name
					target: self
					selector: #newMorphOfClass:event:
					argument: cl].
		menu add: firstChar asString,' - ', lastChar asString subMenu: subMenu.
	].
	^menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 7/4/2000 10:14'!
appearanceMenu
	"Build the appearance menu for the world."
	| screenCtrl |

	screenCtrl _ ScreenController new.
	^self fillIn: (self menu: 'appearance...') from: {

		{'window colors...' . { Preferences . #windowSpecificationPanel} . 'Lets you specify colors for standard system windows.'}.
		{'system fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}.
		{'text highlight color...' . { Preferences . #chooseTextHighlightColor} . 'Choose which color should be used for text highlighting in Morphic.'}.
		{'insertion point color...' . { Preferences . #chooseInsertionPointColor} . 'Choose which color to use for the text insertion point in Morphic.'}.
		nil.
		{#menuColorString . { Preferences . #toggleMenuColorPolicy} . 'Governs whether menu colors should be derived from the desktop color.'}.
		{#roundedCornersString . { Preferences . #toggleRoundedCorners} . 'Governs whether morphic windows and menus should have rounded corners.'}.
		nil.
		{'full screen on' . { screenCtrl . #fullScreenOn} . 'puts you in full-screen mode, if not already there.'}.
		{'full screen off' . { screenCtrl . #fullScreenOff} . 'if in full-screen mode, takes you out of it.'}.
		nil.
		{'set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}.
		{'set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}.
		{'set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}.
		{'use texture background' . { #myWorld . #setStandardTexture} . 'apply a graph-paper-like texture background to the desktop.'}.
		nil.
		{'clear turtle trails from desktop' . { #myWorld . #clearTurtleTrails} . 'remove any pigment laid down on the desktop by objects moving with their pens down.'}.

	}! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 1/25/2001 15:28'!
buildWorldMenu
	"Build the menu that is put up when the screen-desktop is clicked on"

	| menu |

	menu _ MenuMorph new defaultTarget: self.
	self colorForDebugging: menu.
	menu addStayUpItem.
	self fillIn: menu from: {
		{'previous project' . { #myWorld . #goBack } }.
		{'jump to project...' . { #myWorld . #jumpToProject } }.
		{'save project on file...' . { #myWorld  . #saveOnFile } }.
		{'load project from file...' . { self  . #loadProject } }.
		nil}.
	myWorld addUndoItemsTo: menu.

		self fillIn: menu from: {
		{'restore display (r)' . { Display . #restoreMorphicDisplay } }.
		nil}.
	Preferences simpleMenus ifFalse:
		[self fillIn: menu from: { 
			{'open...' . { self  . #openWindow } }.
			{'windows & flaps...' . { self  . #windowsDo } }.
			{'changes...' . { self  . #changesDo } }}].
	self fillIn: menu from: { 
		{'help...' . { self  . #helpDo } }.
		{'appearance...' . { self  . #appearanceDo } }}.

	Preferences simpleMenus ifFalse:
		[self fillIn: menu from: {
			{'do...' . { Utilities . #offerCommonRequests} } }].

	self fillIn: menu from: { 
		nil.
		{'new morph...' . { self  . #newMorph } }.
		{'authoring tools...' . { self  . #scriptingDo } }.
		{'playfield options...' . { self  . #playfieldDo } }.
		{'projects...' . { self  . #projectDo } }}.
	Preferences simpleMenus ifFalse:
		[self fillIn: menu from: { 
			{'print PS to file...' . { self  . #printWorldOnFile } }.
			{'debug...' . { self  . #debugDo } }}].
	self fillIn: menu from: { 
		nil.
		{'save' . { self  . #saveSession } }.
		{'save as...' . { Smalltalk . #saveAs } }.
		{'save and quit' . { self  . #saveAndQuit } }.
		{'quit' . { self  . #quitSession } }}.

	^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 2/2/2001 22:14'!
changesMenu
        "Build the changes menu for the world."

        | menu |
        menu _ self menu: 'changes...'.
        self fillIn: menu from: {
                { 'file out current change set' . { Utilities . #fileOutChanges}.
                                'Write the current change set out to a file whose name reflects the change set name and the current date & time.'}.
                { 'create new change set...' . { ChangeSorter . #newChangeSet}. 'Create a new change set and make it the current one.'}.
                { 'browse changed methods' . { Smalltalk . #browseChangedMessages}.  'Open a message-list browser showing all methods in the current change set'}.
                { 'check change set for slips' . { Smalltalk changes . #lookForSlips}.
                                'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'}.

                nil.
                { 'simple change sorter' . {self. #openChangeSorter1}.  'Open a 3-paned changed-set viewing tool'}.
                { 'dual change sorter' . {self. #openChangeSorter2}.
                                'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'}.
               { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.
                nil.
                { 'browse recent submissions' . { Utilities . #browseRecentSubmissions}.
                                'Open a new recent-submissions browser.  A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted.  If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions.'}.

                { 'find recent submissions (R)' . { #myWorld . #openRecentSubmissionsBrowser:}.
                                'Make an open recent-submissions browser be the the front-window, expanding a collapsed one or creating a new one if necessary.  A recent-submissions browser is a message-list browser that shows the most recent methods that have been submitted, latest first.  If you submit changes within that browser, it will keep up-to-date, always showing the most recent submissions at the top of the browser.'}.

			nil.
                { 'recently logged changes...' . { ChangeList . #browseRecentLog}.'Open a change-list browser on the latter part of the changes log.'}.

                { 'recent log file...' . { Smalltalk . #writeRecentToFile}.
                                'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'}.

                nil.
                { 'save world as morph file' . {self. #saveWorldInFile}. 'Save a file that, when reloaded, reconstitutes the current World.'}.
                nil.
        }.
        self projectForMyWorld isIsolated ifTrue: [
                self fillIn: menu from: { 
                        { 'propagate changes upward' . {self. #propagateChanges}.
                                'The changes made in this isolated project will propagate to projects up to the next isolation layer.'}.
                }.
        ] ifFalse: [
                self fillIn: menu from: { 
                        { 'isolate changes of this project' . {self. #beIsolated}.
                                'Isolate this project and its subprojects from the rest of the system.  Changes to methods here will be revoked when you leave this project.'}.
                }.
        ].

        ^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 6/16/2000 09:50'!
colorForDebugging: aMenu

        "aMenu color: self myMenuColor"

        "aMenu color: Color lightRed"

! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 1/3/2001 07:12'!
debugMenu

        | menu |

        menu _ self menu: 'debug...'.
        ^self fillIn: menu from: { 
                { 'inspect world' . { #myWorld . #inspect } }.
                { 'explore world' . { #myWorld . #explore } }.
                { 'inspect model' . { self . #inspectWorldModel } }.
                        " { 'talk to world...' . { self . #typeInMessageToWorld } }."
                { 'start MessageTally' . { self . #startMessageTally } }.
                { 'start/browse MessageTally' . { self . #startThenBrowseMessageTally } }.
                { 'open process browser' . { ProcessBrowser . #open } }.
                nil.
                        "(self hasProperty: #errorOnDraw) ifTrue:  Later make this come up only when needed."
                { 'start drawing again' . { #myWorld . #resumeAfterDrawError } }.
                { 'start stepping again' . { #myWorld . #resumeAfterStepError } }.
                nil.
                { 'call #tempCommand' . { #myWorld . #tempCommand } }.
                { 'define #tempCommand' . { #myWorld . #defineTempCommand } }.
        }
! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 11/6/2000 15:16'!
fillIn: aMenu from: dataForMenu
	"A menu constructor utility by RAA.  dataForMenu is a list of items which mean:
			nil							Indicates to add a line

			first element is symbol		Add updating item with the symbol as the wording selector
			second element is a list		second element has the receiver and selector

			first element is a string		Add menu item with the string as its wording
			second element is a list		second element has the receiver and selector

			a third element exists		Use it as the balloon text
			a fourth element exists		Use it as the enablement selector (updating case only)"
	| item |

	dataForMenu do: [ :itemData |
		itemData ifNil: [aMenu addLine] ifNotNil:
			[item _ (itemData first isKindOf: Symbol)
				ifTrue: 
					[aMenu 
						addUpdating: itemData first 
						target: self 
						selector: #doMenuItem:with: 
						argumentList: {itemData second}]
				 ifFalse:
					[aMenu 
						add: itemData first 
						target: self 
						selector: #doMenuItem:with: 
						argumentList: {itemData second}].
			itemData size >= 3 ifTrue:
				[aMenu balloonTextForLastItem: itemData third.
			itemData size >= 4 ifTrue:
				[item enablementSelector: itemData fourth]]]].

	^ aMenu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 10/5/2000 17:44'!
helpMenu
        "Build the help menu for the world."
        | screenCtrl |

        screenCtrl _ ScreenController new.
        ^self fillIn: (self menu: 'help...') from:
        {
                {'about this system...'. {Smalltalk. #aboutThisSystem}. 'current version information.'}.
                {'update code from server'. {Utilities. #updateFromServer}. 'load latest code updates via the internet'}.
                {'preferences...'. {Preferences. #openPreferencesInspector}. 'view and change various options.'}.
                nil.
                {'command-key help'. { Utilities . #openCommandKeyHelp}. 'summary of keyboard shortcuts.'}.
                {'world menu help'. { self . #worldMenuHelp}. 'helps find menu items buried in submenus.'}.
                        "{'info about flaps' . { Utilities . #explainFlaps}. 'describes how to enable and use flaps.'}."
                {'font size summary' . { Utilities . #fontSizeSummary}.  'summary of names and sizes of available fonts.'}.
                {'useful expressions' . { Utilities . #openStandardWorkspace}. 'a window full of useful expressions.'}.
                {'graphical imports' . { Smalltalk . #viewImageImports}.  'view the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList'}.
                {'standard graphics library' . { ScriptingSystem . #inspectFormDictionary}.  'lets you view and change the system''s standard library of graphics.'}.
                nil.
                {'telemorphic...' . {self. #remoteDo}.  'commands for doing multi-machine "telemorphic" experiments'}.
                {#soundEnablingString . { Preferences . #toggleSoundEnabling}. 'turning sound off will completely disable Squeak''s use of sound.'}.
                {'definition for...' . { Utilities . #lookUpDefinition}.  'if connected to the internet, use this to look up the definition of an English word.'}.
                nil.

                {'set author initials...' . { screenCtrl . #setAuthorInitials }. 'supply initials to be used to identify the author of code and other content.'}.
                {'vm statistics' . { screenCtrl . #vmStatistics}.  'obtain some intriguing data about the vm.'}.
                {'space left' . { screenCtrl . #garbageCollect}. 'perform a full garbage-collection and report how many bytes of space remain in the image.'}.
        }

! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 6/2/2000 08:48'!
myMenuColor

	| c |
	c _ myWorld color.
	c isColor ifTrue: [^c atLeastAsLuminentAs: 0.2].
	^Color white! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 10/5/2000 19:12'!
newMorph
	| menu subMenu catDict shortCat class |

	menu _ self menu: 'Add a new morph'.
	menu 
		add: 'from paste buffer' target: myHand action: #pasteMorph;
		add: 'from a file...' target: self action: #readMorphFromAFile;
		add: 'from alphabetical list' subMenu: self alphabeticalMorphMenu;
		add: 'grab patch from screen' target: myWorld action: #grabDrawingFromScreen:;
		add: 'make new drawing' target: myWorld action: #newDrawingFromMenu:;
		add: 'make link to project...' target: self action: #projectThumbnail;
		addLine.

	catDict _ Dictionary new.
	SystemOrganization categories do:
		[:cat |
		((cat beginsWith: 'Morphic-')
				and: [(#('Morphic-Menus' 'Morphic-Support') includes: cat) not])
		ifTrue:
			[shortCat _ cat copyFrom: 'Morphic-' size+1 to: cat size.
			(SystemOrganization listAtCategoryNamed: cat) do:
				[:cName | class _ Smalltalk at: cName.
				((class inheritsFrom: Morph)
					and: [class includeInNewMorphMenu])
					ifTrue:
					[(catDict includesKey: shortCat) 
					ifTrue: [(catDict at: shortCat) addLast: class]
					ifFalse: [catDict at: shortCat put: (OrderedCollection with: class)]]]]].

	catDict keys asSortedCollection do:
		[:categ |
		subMenu _ MenuMorph new.
		((catDict at: categ) asSortedCollection: [:c1 :c2 | c1 name < c2 name]) do:
			[:cl | subMenu add: cl name
					target: self
					selector: #newMorphOfClass:event:
					argument: cl].
		menu add: categ subMenu: subMenu].

	self doPopUp: menu.
! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 1/31/2001 17:06'!
openMenu

        "Build the open window menu for the world."
        | menu |
        menu _ self menu: 'open...'.
        self fillIn: menu from: {

                {'browser' . { Browser . #openBrowser} }.
                {'package browser' . { PackagePaneBrowser . #openBrowser} }.
                {'method finder' . { self . #openSelectorBrowser} }.
                {'workspace' . {self . #openWorkspace} }.
                {'file list' . {self . #openFileList} }.
                {'file...' . { FileList . #openFileDirectly} }.
                {'transcript' . {self . #openTranscript} }.
                {'inner world' . { WorldWindow . #test1} }.
                nil.
                {'simple change sorter' . {self . #openChangeSorter1} }.
                {'dual change sorter' . {self . #openChangeSorter2} }.
                nil.
                {'email reader' . {self . #openEmail} }.
                {'web browser' . { Scamper . #openAsMorph} }.
                {'IRC chat' . {self . #openIRC} }.
                nil.
        }.
        self mvcProjectsAllowed ifTrue: [
                self fillIn: menu from: { {'mvc project' . {self. #openMVCProject} } }
        ].
        ^self fillIn: menu from: { 
                {'morphic project' . {self. #openMorphicProject} }.
        }.

! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 5/24/2000 22:34'!
playfieldMenu

	^ myWorld playfieldOptionsMenu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'RAA 2/3/2001 16:34'!
projectMenu
	"Build the project menu for the world."
	| menu |

	self flag: #bob0302.

	menu _ self menu: 'projects...'.
	self fillIn: menu from: { 
		{ 'save on server (also makes a local copy)' . { #myProject . #storeOnServer } }.
		{ 'save to a different server' . { #myProject . #saveAs } }.
		{ 'save project on local file only' . { #myWorld . #saveOnFile } }.
		{ 'see if server version is more recent...' . { #myProject . #loadFromServer } }.
		{ 'load project from file...' . { self . #loadProject } }.
		nil.
		{ #universalTilesString . { self . #toggleTileEra }. 'yes: new tiles in scripts and viewers.
no: old tiles'}.
		{ #largeTilesString . { self . #toggleLargeTiles }. 
	'yes: tiles in scripts and viewers are tall and green. no: tiles are short and transparent'}.
		nil.
	}.

	self fillIn: menu from:
		{{'show project hierarchy'. {Project. #showProjectHierarchyInWindow}. 'Opens a window that shows names and relationships of all the projects in your system.'}.
		nil}.

	self mvcProjectsAllowed ifTrue: [
		self fillIn: menu from: {
			{ 'create new mvc project'. { self . #openMVCProject } }.
		}
	].
	self fillIn: menu from: { 
		{ 'create new morphic project' . { self . #openMorphicProject } }.
		nil.
		{ 'go to previous project' . { Project . #returnToPreviousProject } }.
		{ 'go to next project' . { Project . #advanceToNextProject } }.
		{ 'jump to project...' . { #myWorld . #jumpToProject } }.
	}.
	Preferences simpleMenus ifFalse: [
		self fillIn: menu from: { 
			nil.
			{ 'save for future revert' . { #myProject . #saveForRevert } }.
			{ 'revert to saved copy' . { #myProject . #revert } }.
		}.
	].

	^ menu! !

!TheWorldMenu methodsFor: 'construction' stamp: 'ar 10/24/2000 14:08'!
remoteMenu
        "Build the Telemorphic menu for the world."

        ^self fillIn: (self menu: 'Telemorphic') from: {
                { 'local host address' . { #myWorld . #reportLocalAddress } }.
                { 'connect remote user' . { #myWorld . #connectRemoteUser } }.
                { 'disconnect remote user' . { #myWorld . #disconnectRemoteUser } }.
                { 'disconnect all remote users' . { #myWorld . #disconnectAllRemoteUsers } }.
        }! !

!TheWorldMenu methodsFor: 'construction' stamp: 'sw 1/30/2001 23:54'!
scriptingMenu
        "Build the scripting menu for the world."

        ^ self fillIn: (self menu: 'authoring tools...') from: { 
                { 'standard parts bin' . { self . #createStandardPartsBin}. 'A bin of standard parts, from which you can drag out useful morphs.'}.
                { 'custom parts bin' . { self . #launchCustomPartsBin}. 'A customized bin of parts.  To define what the custom parts bin is, edit any existing parts bin and tell it to be saved as the custom parts bin.'}.
                { 'view trash contents' . { #myWorld . #openScrapsBook:}. 'The place where all your trashed morphs go.'}.
                { 'empty trash can' . { Utilities . #emptyScrapsBook}. 'Empty out all the morphs that have accumulated in the trash can.'}.
			nil.
                { 'new scripting area' . { #myWorld . #detachableScriptingSpace}. 'A window set up for simple scripting.'}.
			 { 'summary of scripts' . {#myWorld . #printScriptSummary}. 'Produces a summary of scripted objects in the project, and all of their scripts.'}.
			 { 'status of scripts' . {#myWorld . #showStatusOfAllScripts}. 'Lets you view the status of all the scripts belonging to all the scripted objects of the project.'}.
                nil.
                { 'unlock locked objects' . { #myWorld . #unlockContents}. 'If any items on the world desktop are currently locked, unlock them.'}.
                { 'unhide hidden objects' . { #myWorld . #showHiders}. 'If any items on the world desktop are currently hidden, make them visible.'}.
        }! !


!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'sw 11/6/2000 13:56'!
globalFlapsEnabled
	"Answer whether global flaps are enabled"

	^ Preferences useGlobalFlaps! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'sw 11/6/2000 13:54'!
newGlobalFlapString
	"Answer a string for the new-global-flap item in the flap menu"

	^ 'new global flap...'! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'RAA 5/26/2000 11:30'!
suppressFlapsString

	^ Utilities suppressFlapsString! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'RAA 5/26/2000 11:28'!
useGlobalFlapsString

	^ Utilities useGlobalFlapsString! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'sw 11/6/2000 13:52'!
whichGlobalFlapsString
	"Answer a string for the which-global-flaps menu item"

	^ 'which global flaps...'! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'RAA 5/26/2000 10:27'!
windowsDo
	"Build the windows menu for the world."

	self doPopUp: self windowsMenu! !

!TheWorldMenu methodsFor: 'windows & flaps menu' stamp: 'sw 2/1/2001 23:13'!
windowsMenu
        "Build the windows menu for the world."

        ^ self fillIn: (self menu: 'windows & flaps...') from: {  
                { 'find window' . { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'}.

                { 'find changed browsers...' . { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.

                { 'find changed windows...' . { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}.
			nil.

                { 'find a transcript (t)' . { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window'}.

               { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}.
			 nil.

                { #staggerPolicyString . { self . #toggleWindowPolicy }. 'stagger: new windows positioned so you can see a portion of each one.
                tile: new windows positioned so that they do not overlap others, if possible.'}.

                nil.
                { 'collapse all windows' . { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.'}.
                { 'expand all windows' . { #myWorld . #expandAll }. 'Expand all collapsed windows back to their expanded forms.'}.
                { 'close top window (w)' . { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.'}.
                { 'send top window to back (\)' . { SystemWindow . #sendTopWindowToBack  }. 'Make the topmost window become the backmost one, and activate the window just beneath it.'}.
			 { 'move windows onscreen' . { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen'}.

                nil.
                { 'delete unchanged windows' . { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.'}.
                { 'delete non-windows' . { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.'}.
                { 'delete both of the above' . { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.'}.

                nil.
            "    { #suppressFlapsString . { self . #toggleFlapSuppressionInProject }. 'Governs whether flaps should be shown in this project'}."
                { #useGlobalFlapsString . { self. #toggleWhetherToUseGlobalFlaps }. 'Governs whether a universal set of "global" flaps should be sharable by all morphic projects.'}.
			{ #whichGlobalFlapsString . { Utilities. #offerGlobalFlapsMenu }. 'Put up a menu that allows you to choose which global flaps to show in this project'. #globalFlapsEnabled}.

                { #newGlobalFlapString  . { Utilities . #addGlobalFlap }. 'Create a new flap that will be shared by all morphic projects'.  #globalFlapsEnabled}.
                nil.

                { 'new project flap...'  . { Utilities . #addLocalFlap }. 'Create a new flap to be used only in this project.'}.
                { 'add stack-tools flap'  . { Utilities . #addStackToolsFlap }. 'Add a flap in this project that offers tools for creating stacks and cards.'}.
				nil.

                { 'about flaps...' . { Utilities . #explainFlaps }. 'Gives a window full of details about how to use flaps.'}.

        }! !


!TheWorldMenu methodsFor: 'action' stamp: 'ar 10/5/2000 19:04'!
doMenuItem: aCollection with: event
	| realTarget selector nArgs |
	selector _ aCollection second.
	nArgs _ selector numArgs.
	^[
		realTarget _ aCollection first.
		realTarget == #myWorld ifTrue: [realTarget _ myWorld].
		realTarget == #myHand ifTrue: [realTarget _ myHand].
		realTarget == #myProject ifTrue: [realTarget _ self projectForMyWorld].
		nArgs = 0 
			ifTrue:[realTarget perform: selector]
			ifFalse:[realTarget perform: selector with: event].
	] on: RequestCurrentWorldNotification do: [ :ex | ex resume: myWorld ]
! !

!TheWorldMenu methodsFor: 'action' stamp: 'tk 2/2/2001 15:03'!
largeTilesString

	^ (myProject parameterAt: #largeTiles ifAbsent: [false]) not
		ifTrue: ['<yes>large tiles']
		ifFalse: ['<no>large tiles']! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'!
menuColorString

	^ Preferences menuColorString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 8/31/2000 14:19'!
projectThumbnail
	"Offer the user a menu of project names. Attach to the hand a thumbnail of the project the user selects."

	| menu projName pr |
	menu _ CustomMenu new.
	menu 
		add: (CurrentProjectRefactoring currentProjectName, ' (current)') 
		action: CurrentProjectRefactoring currentProjectName.
	menu addLine.
	Project allNames do: [:n | menu add: n action: n].
	projName _ menu startUpWithCaption: 'Select a project'.
	projName ifNotNil:
		[(pr _ Project named: projName) 
			ifNotNil: [myHand attachMorph: (ProjectViewMorph on: pr)]
			ifNil: [self inform: 'can''t seem to find that project']].! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 10:18'!
roundedCornersString

	^ Preferences roundedCornersString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 6/27/2000 09:04'!
setGradientColor

	myWorld setGradientColor: myHand lastEvent! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 08:35'!
soundEnablingString

	^ Preferences soundEnablingString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:31'!
staggerPolicyString

	^ Preferences staggerPolicyString! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:30'!
toggleFlapSuppressionInProject

	Utilities toggleFlapSuppressionInProject! !

!TheWorldMenu methodsFor: 'action' stamp: 'tk 2/2/2001 15:02'!
toggleLargeTiles
	"tall or small new tiles in scriptors"

	myProject projectParameterAt: #largeTiles put: 
		(myProject parameterAt: #largeTiles ifAbsent: [false]) not! !

!TheWorldMenu methodsFor: 'action' stamp: 'tk 2/2/2001 14:48'!
toggleTileEra
	"old or new tiles in scriptors"

	myWorld setProperty: #universalTiles toValue: 
		(myWorld valueOfProperty: #universalTiles ifAbsent: [false]) not! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:29'!
toggleWhetherToUseGlobalFlaps

	Utilities toggleWhetherToUseGlobalFlaps! !

!TheWorldMenu methodsFor: 'action' stamp: 'RAA 5/26/2000 11:32'!
toggleWindowPolicy

	Preferences toggleWindowPolicy! !

!TheWorldMenu methodsFor: 'action' stamp: 'tk 2/2/2001 15:04'!
universalTilesString
	^ (myWorld valueOfProperty: #universalTiles ifAbsent: [false])
		ifTrue: ['<yes>new tiles in viewers and scripts']
		ifFalse: ['<no>new tiles in viewers and scripts']! !


!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:25'!
appearanceDo
	"Build and show the appearance menu for the world."

	self doPopUp: self appearanceMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
changesDo
	"Build the changes menu for the world."

	self doPopUp: self changesMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
debugDo

	self doPopUp: self debugMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 6/12/2000 09:13'!
doPopUp: aMenu

	aMenu popUpForHand: myHand in: myWorld.
! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
helpDo
	"Build and show the help menu for the world."

	self doPopUp: self helpMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
openWindow

	self doPopUp: self openMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
playfieldDo
	"Build the playfield menu for the world."

	self doPopUp: myWorld playfieldOptionsMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
projectDo
	"Build and show the project menu for the world."

	self doPopUp: self projectMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:26'!
remoteDo

	self doPopUp: self remoteMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:27'!
scriptingDo

	self doPopUp: self scriptingMenu! !

!TheWorldMenu methodsFor: 'popups' stamp: 'RAA 5/26/2000 10:27'!
standardFontDo
	"Build and show the standard font menu"

	self doPopUp: Preferences fontConfigurationMenu! !
Object subclass: #ThirtyTwoBitRegister
	instanceVariableNames: 'hi low '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Digital Signatures'!
!ThirtyTwoBitRegister commentStamp: '<historical>' prior: 0!
I represent a 32-bit register. An instance of me can hold any non-negative integer in the range [0..(2^32 - 1)]. Operations are performed on my contents in place, like a hardware register, and results are always modulo 2^32.

This class is primarily meant for use by the SecureHashAlgorithm class.
!


!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:03'!
asInteger
	"Answer the integer value of my current contents."

	^ (hi bitShift: 16) + low
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'!
hi

	^ hi
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'!
load: anInteger
	"Set my contents to the value of given integer."

	low _ anInteger bitAnd: 16rFFFF.
	hi _ (anInteger bitShift: -16) bitAnd: 16rFFFF.
	self asInteger = anInteger
		ifFalse: [self error: 'out of range: ', anInteger printString].
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/14/1999 16:07'!
loadFrom: aByteArray at: index
	"Load my 32-bit value from the four bytes of the given ByteArray starting at the given index. Consider the first byte to contain the most significant bits of the word (i.e., use big-endian byte ordering)."

	hi _ ((aByteArray at: index) bitShift: 8) + ( aByteArray at: index + 1).
	low _ ((aByteArray at: index + 2) bitShift: 8) + ( aByteArray at: index + 3).
! !

!ThirtyTwoBitRegister methodsFor: 'accessing' stamp: 'jm 12/7/1999 15:26'!
low

	^ low! !


!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:36'!
+= aThirtTwoBitRegister
	"Replace my contents with the sum of the given register and my current contents."

	| lowSum |
	lowSum _ low + aThirtTwoBitRegister low.
	hi _ (hi + aThirtTwoBitRegister hi + (lowSum bitShift: -16)) bitAnd: 16rFFFF.
	low _ lowSum bitAnd: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:41'!
bitAnd: aThirtTwoBitRegister
	"Replace my contents with the bitwise AND of the given register and my current contents."

	hi _ hi bitAnd: aThirtTwoBitRegister hi.
	low _ low bitAnd: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'!
bitInvert
	"Replace my contents with the bitwise inverse my current contents."

	hi _ hi bitXor: 16rFFFF.
	low _ low bitXor: 16rFFFF.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:40'!
bitOr: aThirtTwoBitRegister
	"Replace my contents with the bitwise OR of the given register and my current contents."

	hi _ hi bitOr: aThirtTwoBitRegister hi.
	low _ low bitOr: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 15:38'!
bitXor: aThirtTwoBitRegister
	"Replace my contents with the bitwise exclusive OR of the given register and my current contents."

	hi _ hi bitXor: aThirtTwoBitRegister hi.
	low _ low bitXor: aThirtTwoBitRegister low.
! !

!ThirtyTwoBitRegister methodsFor: 'accumulator ops' stamp: 'jm 12/7/1999 23:09'!
leftRotateBy: bits
	"Rotate my contents left by the given number of bits, retaining exactly 32 bits."
	"Details: Perform this operation with as little LargeInteger arithmetic as possible."

	| bitCount s1 s2 newHi |
	"ensure bitCount is in range [0..32]"
	bitCount _ bits \\ 32.
	bitCount < 0 ifTrue: [bitCount _ bitCount + 32].

	bitCount > 16
		ifTrue: [
			s1 _ bitCount - 16.
			s2 _ s1 - 16.
			newHi _ ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			low _ ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			hi _ newHi]
		ifFalse: [
			s1 _ bitCount.
			s2 _ s1 - 16.
			newHi _ ((hi bitShift: s1) bitAnd: 16rFFFF) bitOr: (low bitShift: s2).
			low _ ((low bitShift: s1) bitAnd: 16rFFFF) bitOr: (hi bitShift: s2).
			hi _ newHi]
! !


!ThirtyTwoBitRegister methodsFor: 'copying' stamp: 'jm 12/7/1999 15:26'!
copy
	"Use the clone primitive for speed."

	<primitive: 148>
	^ super copy
! !


!ThirtyTwoBitRegister methodsFor: 'printing' stamp: 'jm 12/14/1999 16:05'!
printOn: aStream
	"Print my contents in hex with a leading 'R' to show that it is a register object being printed."

	aStream nextPutAll: 'R:'.
	self asInteger printOn: aStream base: 16.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThirtyTwoBitRegister class
	instanceVariableNames: ''!

!ThirtyTwoBitRegister class methodsFor: 'instance creation' stamp: 'jm 12/14/1999 16:05'!
new
	"Answer a new instance whose initial contents is zero."

	^ super new load: 0
! !
AlignmentMorphBob1 subclass: #ThreadNavigationMorph
	instanceVariableNames: 'listOfPages currentIndex loadedProject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Navigators'!

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:29'!
addButtons

	self addARow: {
		self inAColumn: {self buttonFirst}.
		self inAColumn: {self buttonPrevious}.
		self inAColumn: {self buttonForward}.
		self inAColumn: {self buttonLast}.
		self inAColumn: {self buttonExit}.
	}.
! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:31'!
colorForButtons

	^color darker! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:52'!
currentIndex

	^currentIndex! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:29'!
deleteCurrentPage

	| outerWrapper |

	loadedProject ifNil: [^self].
	outerWrapper _ loadedProject world ownerThatIsA: EmbeddedWorldBorderMorph.
	outerWrapper ifNil: [^self].
	outerWrapper delete.
	loadedProject _ nil.

! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 11:37'!
ensureSuitableDefaults

	listOfPages ifNil: [listOfPages _ OrderedCollection new].
	currentIndex ifNil: [currentIndex _ 0].

! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:32'!
exitTheSequence

	self deleteCurrentPage.
	self delete.! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:26'!
firstPage

	listOfPages isEmpty ifTrue: [^1 beep].
	currentIndex _ 1.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:31'!
fontForButtons

	^TextStyle defaultFont! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:41'!
initialColor

	^Color red lighter! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/10/2000 11:38'!
initialize

	super initialize.
	self useRoundedCorners.
	self layoutInset: 6.
	color _ self initialColor.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self ensureSuitableDefaults.

	self addButtons.
! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:27'!
lastPage

	listOfPages isEmpty ifTrue: [^1 beep].
	currentIndex _ listOfPages size.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 18:49'!
listOfPages: aCollection

	listOfPages _ aCollection! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:24'!
loadPage

	| theProject projectInfo url gotoPage theBook |

	projectInfo _ listOfPages at: currentIndex.
	url _ projectInfo at: 1.
	gotoPage _ projectInfo at: 2 ifAbsent: [nil].
	[
		[Project fromUrl: url]
			on: ProjectEntryNotification
			do: [ :ex | 
				self deleteCurrentPage.
				theProject _ ex projectToEnter enterAsActiveSubprojectWithin: self world.
				theProject world showExpandedView.
				loadedProject _ theProject.
				gotoPage ifNotNil: [
					theBook _ loadedProject world findA: BookMorph.
					theBook ifNotNil: [
						theBook goToPage: gotoPage
					].
				].
				^loadedProject
			].
	]
		on: RequestCurrentWorldNotification
		do: [ :ex | ex resume: self world ]
! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:26'!
loadPageWithProgress

	ComplexProgressIndicator new 
		targetMorph: self;
		historyCategory: 'project loading';
		withProgressDo: [self loadPage]
! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:25'!
makeButton: aString balloonText: anotherString for: aSymbol

	^SimpleButtonDelayedMenuMorph new 
		target: self;
		borderColor: #raised;
		color: self colorForButtons;
		label: aString font: self fontForButtons;
		setBalloonText: anotherString;
		actionSelector: aSymbol.

! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 18:09'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^15		"Navigators are behind menus and balloons, but in front of most other stuff"! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:53'!
nextPage

	self currentIndex >= listOfPages size ifTrue: [^1 beep].
	currentIndex _ self currentIndex + 1.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:53'!
previousPage

	self currentIndex <= 1 ifTrue: [^1 beep].
	currentIndex _ self currentIndex - 1.
	self loadPageWithProgress.! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 17:50'!
showMenuFor: actionSelector event: evt

	"no-op here"! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/9/2000 16:33'!
step

	| delta |

	owner == self world ifFalse: [^ self].
	owner addMorphInLayer: self.
	delta _ self bounds amountToTranslateWithin: self worldBounds.
	delta = (0 @ 0) ifFalse: [self position: self position + delta].
! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:22'!
stepTime

	^250! !

!ThreadNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/27/2000 17:59'!
wantsSteps

	^true! !


!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:28'!
buttonExit

	^self makeButton: 'Exit' balloonText: 'Exit the sequence' for: #exitTheSequence.


! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:26'!
buttonFirst

	^self makeButton: 'First' balloonText: 'First page in sequence' for: #firstPage
! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonForward

	^self makeButton: 'Forward >' balloonText: 'Next page in sequence' for: #nextPage

! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonLast

	^self makeButton: 'Last' balloonText: 'Last page in sequence' for: #lastPage

! !

!ThreadNavigationMorph methodsFor: 'buttons' stamp: 'RAA 11/9/2000 16:27'!
buttonPrevious

	^self makeButton: '< Back' balloonText: 'Previous page in sequence' for: #previousPage
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreadNavigationMorph class
	instanceVariableNames: ''!

!ThreadNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 6/28/2000 08:20'!
example1
"
ThreadNavigationMorph example1
"
	self new
		listOfPages: #(
			('ftp://209.143.91.36/Drive A Car')
			('ftp://209.143.91.36/Teachers & NewTech' 1)
			('ftp://209.143.91.36/Teachers & NewTech' 2)
			('ftp://209.143.91.36/Lander')
		);
		openInWorld! !
Object subclass: #ThreeDSChunkDescription
	instanceVariableNames: 'id name comment '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Import'!
!ThreeDSChunkDescription commentStamp: '<historical>' prior: 0!
This is a Class supporting debugging the ThreeDSParser. It's not needed for the actual parsing process. Instances are automatically created from the chunk documentation for each chunk (see ThreeDSParser class  'utilities' protocol) and stored in the Dictionary ChunkDescriptions. They act as Associations by itself.

Instance Variables:
	id			<Integer>  the chunk id
	name		<String>  an identifier
	comment	<String>  a comment, if available
	
The printOn: method is sensitive to the Shift key -- only if pressed, the comment is shown.!


!ThreeDSChunkDescription methodsFor: 'accessing'!
comment
	^comment! !

!ThreeDSChunkDescription methodsFor: 'accessing'!
id
	^id! !

!ThreeDSChunkDescription methodsFor: 'accessing'!
name
	^name! !


!ThreeDSChunkDescription methodsFor: 'comparing'!
= aChunk
	^id = aChunk id! !

!ThreeDSChunkDescription methodsFor: 'comparing'!
hash
	^id hash! !


!ThreeDSChunkDescription methodsFor: 'private'!
removeSeparators: aString
	"Remove leading and trailing separators"

	| start end |
	start := 1.
	end := aString size.
	[start <= end and: [(aString at: start) isSeparator]] whileTrue: [start := start + 1].
	[start < end and: [(aString at: end) isSeparator]] whileTrue: [end := end - 1].
	(start = 1 and: [end = aString size]) ifTrue: [^aString].
	start = end ifTrue: [^''].
	^aString copyFrom: start to: end! !

!ThreeDSChunkDescription methodsFor: 'private'!
setId: anID name: aName comment: aComment
	"Initialize receiver"

	id := anID.
	name := aName.
	comment := self removeSeparators: aComment.! !


!ThreeDSChunkDescription methodsFor: 'association'!
key
	^id! !

!ThreeDSChunkDescription methodsFor: 'association'!
value
	^self! !


!ThreeDSChunkDescription methodsFor: 'printing' stamp: 'bf 3/16/2000 18:58'!
printOn: aStream

	aStream nextPutAll: 'Chunk('.
	id printOn: aStream base: 16.
	aStream 
		nextPut: $h;
		space;
		nextPutAll: name.
	Sensor commandKeyPressed ifTrue: [
		aStream space; nextPut: $<; nextPutAll: comment; nextPut: $>].
	aStream nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreeDSChunkDescription class
	instanceVariableNames: ''!

!ThreeDSChunkDescription class methodsFor: 'instance creation'!
id: anID name: aName comment: aComment

	^self new setId: anID name: aName comment: aComment! !
Object subclass: #ThreeDSParser
	instanceVariableNames: 'source chunkPos chunkID chunkLen indent log informer classSpec '
	classVariableNames: 'ChunkDescriptions DefaultSpec '
	poolDictionaries: ''
	category: 'Balloon3D-Import'!
!ThreeDSParser commentStamp: '<historical>' prior: 0!
(c) 1996-97 Bert Freudenberg, neŽ SchšnwŠlder, (bert@isg.cs.uni-magdeburg.de) University of Magdeburg, Germany.

Modified 1998 by Andreas Raab (Andreas.Raab@disney.com) for Squeak.

Class ThreeDSParser reads a 3DS File (AutoDesk 3D Studio's native format). It isn't a real parser at all, I chose this name for consistency with the other scene parser classes. For description of 3DS format I used "The Unofficial 3DStudio 3DS File Format v1.0" by Jeff Lewis and the "3ds_bin" by Jim Pitts et. al., see #chunkDocumentation on the Class side.

Instance Variables:
	source		<Stream>	binary stream on source file
	chunkPos	<Integer>	File position of current chunk
	chunkID	<Integer>	ID of current cunk
	chunkLen	<Integer>	Length of current chunk
	indent		<Integer | nil>	If nil, no log is written. Otherwise the current nesting level.
	informer	<Block>		A block taking the progress value while reading
	classSpec	<Dictionary | nil> Specification of the classes to construct.

Class Variables:
	ChunkDescriptions	<Dictionary of: ThreeDSChunkDescription>
		For debugging only. ChunkDescriptions generated from the documentation
	DefaultSpec	<Dictionary | nil>
		The default class specification to use.
!


!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/6/1999 20:34'!
classSpec: aDictionary
	classSpec _ aDictionary! !

!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/6/1999 01:21'!
parse: aStream
	"Read the 3DS file from the given stream"
	| s |
	'Reading 3DS file' displayProgressAt: Sensor cursorPoint
		from: 0 to: aStream size during:[:bar|
			self informer: bar.
			s _ self parseStream: aStream.
	].
	^s! !

!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/15/1999 05:16'!
parse: aStream using: spec
	"Read the 3DS file from the given stream"
	self classSpec: spec.
	^self parse: aStream! !

!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/6/1999 01:28'!
parseFileNamed: aString
	"Read the 3DS file from the given stream"
	| s f |
	f _ FileStream readOnlyFileNamed: aString.
	f binary.
	'Reading 3DS file ', aString  displayProgressAt: Sensor cursorPoint
		from: 0 to: f size during:[:bar|
			self informer: bar.
			s _ self parseStream: f.
		].
	f close.
	^s! !

!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/6/1999 20:50'!
parseFileNamed: aString using: spec
	"Read the 3DS file from the given stream"
	self classSpec: spec.
	^self parseFileNamed: aString! !

!ThreeDSParser methodsFor: 'initialize-release' stamp: 'ar 2/15/1999 05:30'!
parseStream: aStream
	"Read the 3DS file from the given stream"
	| sceneSpec |
	source := aStream.
	source binary.
	indent := 0.
	log := Sensor leftShiftDown ifTrue: [
		Sensor controlKeyPressed
			ifTrue: [FileStream fileNamed: (FillInTheBlank request: 'Parser log file:' initialAnswer: 'parser.log')]
			ifFalse: [Transcript]].
	log == Transcript ifTrue: [log clear].
	sceneSpec := self scene.
	log == nil ifFalse: [log == Transcript ifTrue: [log flush] ifFalse: [log close]].
	^self sceneClass from3DS: sceneSpec! !


!ThreeDSParser methodsFor: 'accessing' stamp: 'ar 2/6/1999 01:22'!
informer
	^informer! !

!ThreeDSParser methodsFor: 'accessing' stamp: 'ar 2/6/1999 01:22'!
informer: anObject
	informer _ anObject! !


!ThreeDSParser methodsFor: 'reading' stamp: 'ar 2/6/1999 20:53'!
scene
	"Whole file"
	| renderObjects |
	self chunkHeader.
	chunkID == 16r3D3D ifTrue: [^self meshData].
	chunkID == 16r4D4D ifFalse: [^nil].
	self recognize: #(
		(16r3D3D meshData 1)
		(16rB000 keyframeData 2)
		) do: [:item | self indexed: item
			do: [:data | renderObjects := data]
			do: [:data | (renderObjects at: #globals) at: #keyframes put: data]].
	^renderObjects! !


!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 19:55'!
camera
	"Subchunk of namedObject"

	| cameraSpec |
	cameraSpec _ Dictionary new.
	cameraSpec at: #position put: self vector3.
	cameraSpec at: #target put: self vector3.
	cameraSpec at: #roll put: self float.
	cameraSpec at: #focal put: self float.
	"May be followed by near/far range"
	self recognize: #((16r4720 twoFloats)) do: [:item | 
		cameraSpec at: #near put: item first.
		cameraSpec at: #far put: item second].
	^self cameraClass from3DS: cameraSpec! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 20:02'!
light
	"Subchunk of namedObject"

	| pos lightSpec |
	pos := self vector3.
	lightSpec := self recognize: #(
		(16r0010 colorFloat color)		"Color of light source"
		(16r0011 color24 color)		"Color of light source"
		(16r4610 spot ->)				"Spot light specs, see #spot"
		(16r4620 flag off)			"Light off flag (default on)"
		(16r4659 float innerRange)	"Attenuation min range"
		(16r465A float outerRange)	"Attenuation max range"
		(16r465B float multiplier))	"Intensity multiplier (default 1.0)"
		as: Dictionary.
	lightSpec at: #position put: pos.
	^(lightSpec includesKey: #spot )
		ifTrue: [self spotLightClass from3DS: lightSpec]
		ifFalse:[self pointLightClass from3DS: lightSpec]! !

!ThreeDSParser methodsFor: 'reading-mesh'!
meshData
	"Subchunk of scene"
	| renderObjects globals |
	globals := Dictionary 
				with: (#constants -> Dictionary new) 
				with: (#cameras -> Dictionary new) 
				with: (#lights -> Dictionary new)
				with: (#materials -> Dictionary new).
	renderObjects := Dictionary with: (#globals -> globals).				
	self recognize: #(
		(16r4000 namedObject)
		(16r2100 materialColor ambientColor)
		(16r1100 cString bgBitmap)
		(16rAFFF materialEntry ->)
		(16r1200 materialColor backgroundColor)
		(16r1300 verticalGradient ->)
		) do: [:item | 
			item key == #verticalGradient
				ifTrue:[globals add: item].
			item key == #materialEntry
				ifTrue:[(globals at: #materials) add: item value].
			item key == #backgroundColor
				ifTrue: [(globals at: #constants) at: item key asString put: item value].
			item key == #ambientColor
				ifTrue: [(globals at: #constants) at: item key asString put: item value] ifFalse:[
			item key == #bgBitmap
				ifTrue: [(globals at: #constants) at: item key asString put: item value] ifFalse:[
			item key == #triMesh 
				ifTrue: [renderObjects add: item value] ifFalse: [
			item key == #light 
				ifTrue: [(globals at: #lights) add: item value] ifFalse: [
			item key == #camera 
				ifTrue: [(globals at: #cameras) add: item value]]]]]].
	^renderObjects! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 01:14'!
namedObject
	"Subchunk of meshData"
	"Contains triMesh, light, or camera. Answer association"

	| name |
	name := self cString.
	self recognize: #(
		(16r4100 triMesh ->)
		(16r4600 light ->)
		(16r4700 camera ->))
		do: [:item | ^item key -> (name -> item value)].
	^nil! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 21:46'!
smoothList
	"Optional subchunk of faceList"

	| count smooth |
	count := chunkLen - 6 // 4.
	smooth := Array new: count.
	1 to: count do: [:i | smooth at: i put: self uLong].
	^smooth! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 01:00'!
spot
	"Subchunk of light"

	| spot result |
	spot := Dictionary new.
	spot 
		at: #target put: self vector3;
		at: #hotspotAngle put: self float;
		at: #falloffAngle put: self float.
	result := self recognize: #(
		(16r4651 flag rectangular)
		(16r4652 flag overshoot)
		(16r4653 flag projector)) as: Dictionary.
	spot at: #rectangular put:(result at: #rectangular ifAbsent: [false]).
	spot at: #overshoot put: (result at: #overshoot ifAbsent: [false]).
	spot at: #projector put: (result at: #projector ifAbsent: [false]).
	^spot! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 01:03'!
triList
	"Subchunk of triMesh"
	| count triList triangle vertices flags smoothList matGroup |
	count := self uShort.
	triList := Array new: count.
	1 to: count do: [ :i |
		vertices := #(A B C) collect: [:j | self uShort + 1].
		flags := self uShort bitAnd: 7.
		triangle := vertices -> flags.
		triList at: i put: triangle].
	"May be followed by smoothlist"
	self recognize: #(
		(16r4150 smoothList ->) 
		(16r4130 cString materialGroup))
	do:[:item|
		#smoothList == item key
			ifTrue:[smoothList := item value].
		#materialGroup == item key
			ifTrue:[matGroup := item value].
	].
	^Array with: triList with: smoothList with: matGroup.! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 20:13'!
triMesh
	"Subchunk of namedObject"
	| objSpec |
	"Read vertex coordinates and indexed triangles"
	objSpec _ self recognize: #(
		(16r4110 vertexList ->)		"List of vertices"
		(16r4140 textureVertices ->)	"List of texture coords (per vertex)"
		(16r4160 matrix ->)			"Transformation of mesh object"
		(16r4120 triList ->)) 			"Triangle information (see #triList)"
			as: Dictionary.
	^self meshObjectClass from3DS: objSpec! !

!ThreeDSParser methodsFor: 'reading-mesh' stamp: 'ar 2/6/1999 22:56'!
vertexList
	"Subchunk of triMesh"
	| count vertices |
	count := self uShort.
	vertices := self vertexArrayClass new: count.
	1 to: count do: [:i |
		vertices at: i put: self vector3].
	^vertices! !


!ThreeDSParser methodsFor: 'reading-material'!
materialColor

	^self recognize: #(
		(16r0010 colorFloat)
		(16r0011 color24))! !

!ThreeDSParser methodsFor: 'reading-material' stamp: 'ar 2/6/1999 20:25'!
materialEntry
	"Globally defined materials"
	| name materialSpec |
	name := 'unknown'.
	materialSpec := Dictionary new.
	self recognize: #(
		(16rA000 cString name)
		(16rA010 materialColor ambient)
		(16rA020 materialColor diffuse)
		(16rA030 materialColor specular)
		(16rA200 textureMap texture)
		(16rA040 percentageChunk shininessHighlight)
		(16rA041 percentageChunk shininessColorScale)
		) do: [:item | 
			item key == #name ifTrue:[
				log == nil ifFalse: [log crtab: indent+1; print: item value].
				name := item value.
			] ifFalse:[
				item key == #texture ifTrue:[materialSpec addAll: item value]
				ifFalse:[materialSpec at: item key put: item value]]].
	materialSpec at: #name put: name.
	^name -> (self materialClass from3DS: materialSpec)! !

!ThreeDSParser methodsFor: 'reading-material'!
textureMap
	| name percent |
	name := nil.
	percent := 1.0.
	self recognize:#(
		(16rA300 cString texName)
		(16r0030 short texPercent)
		(16r0031 float texPercent))
	do:[:item|
		item key == #texName ifTrue:[name := item value].
		item key == #texPercent ifTrue:[percent := item value / 100.0]].
	^Array 	with:(#textureName -> name)
			with: (#texturePercentage -> percent).! !

!ThreeDSParser methodsFor: 'reading-material' stamp: 'ar 2/6/1999 23:29'!
textureVertices
	"Subchunk of tri object"
	| nVerts texCoords u v |
	nVerts := self uShort.
	texCoords := self textureArrayClass new: nVerts.
	1 to: nVerts do:[:i|
		u := self float.
		v := self float.
		texCoords at: i put: (u@v).
	].
	^texCoords.! !

!ThreeDSParser methodsFor: 'reading-material'!
verticalGradient

	| midPt start mid stop|
	midPt := self float.
	self recognize:#( (16r0010 colorFloat) )
		do:[:color|
			start isNil ifTrue:[start := color] ifFalse:[
			mid isNil ifTrue:[mid := color] ifFalse:[
			stop isNil ifTrue:[stop := color]]]].
	^Array with: start with: mid with: stop! !


!ThreeDSParser methodsFor: 'reading-keyframe'!
keyframeData
	"Subchunk of scene"
	
	| data info|
	data := Dictionary new.
	data at: #info put: (info := Dictionary new).
	self recognize: #(
		(16rB00A keyframeHeader header)
		(16rB008 twoLongs segments)
		(16rB009 long current)
		(16rB001 node ambientLight)
		(16rB002 node objects)
		(16rB003 node cameras)
		(16rB004 node targets)
		(16rB005 node lights)
		(16rB006 node lightTargets)
		(16rB007 node spotlights)
		)
		do: [:item |
			#header == item key ifTrue: [
				info addAll: item value] ifFalse: [
			#segments == item key ifTrue: [
				info add: item.
				log == nil ifFalse: [log crtab: indent+1; print: item value]] ifFalse: [
			#current == item key ifTrue: [
				info add: item.
				log == nil ifFalse: [log crtab: indent+1; print: item value]] ifFalse: [
			(data at: item key ifAbsentPut: [Dictionary new]) 
				add: item value]]]].
	^data! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 01:15'!
keyframeHeader
	"Subchunk of keyframeData"
	
	| name len revision |
	revision := self short.
	name := self cString.
	len := self long.
	log == nil ifFalse: [log crtab: indent; 
		nextPutAll: 'File: '; print: name; nextPutAll: ' frames: '; print: len; nextPutAll: ' revision: '; print: revision].
	^Array 
		with: (#frames->len)
		with: (#file->name)! !

!ThreeDSParser methodsFor: 'reading-keyframe'!
node
	"Subchunk of keyframeData"
	
	| nodeData |
	nodeData := Dictionary new.
	self recognize: #(
		(16rB030 short id)
		(16rB010 nodeHeader header)
		(16rB011 cString instanceName)
		(16rB013 vector3 pivot)
		(16rB014 twoVector3 boundingBox)
		(16rB015 float smoothAngle)
		(16rB020 trackVector positionTrack)
		(16rB021 trackRotation rotationTrack)
		(16rB022 trackVector scaleTrack)
		(16rB023 trackFloat fovTrack)
		(16rB024 trackFloat rollTrack)
		(16rB025 trackColor colorTrack)
		(16rB026 trackCString morphTrack)
		(16rB027 trackFloat hotspotTrack)
		(16rB028 trackFloat falloffTrack)
		(16rB029 trackFlag hideTrack)
		) do: [:item |
			item key == #header 
				ifTrue: [nodeData addAll: item value]
				ifFalse: [nodeData add: item].
			log == nil ifFalse: [(#(id pivot boundingBox instanceName) includes: item key) ifTrue: [
				log crtab: indent+1; print: item value]]].
	^(nodeData at: #id ifAbsent:[^nil]) -> nodeData! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 01:00'!
nodeHeader
	"Subchunk of node"
	| name hierarchy unknown isHidden |
	name := self cString.
	unknown := (1 to: 4) collect: [:i | source next].
	hierarchy := self short.
	isHidden := (unknown at: 2) anyMask: 8.
	log ==nil ifFalse: [log crtab: indent; 
		nextPutAll: 'Name: '; print: name; nextPutAll: ' Hierarchy: '; print: hierarchy; 
		nextPutAll: ' Unknown: '; print: unknown.
		(isHidden) ifTrue:[log nextPutAll:' hidden'.]].
	^Array with: (#name->name)
		with: (#hierarchy->hierarchy)
		with:(#hidden -> isHidden)! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 18:18'!
trackCString
	"Read keyframes defining a string (morph)"
	
	| string |
	^self trackCollect: [:params|
		"@@: Still to do ..."
		"params == nil ifFalse:[self halt]."
		string := self cString.
		log == nil ifFalse: [log print: string].
		string].! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'bf 3/16/2000 18:22'!
trackCollect: aBlock
	"Read keyframes, return Array with values of aBlock "
	
	| flags keys frame unknown1 paramFlags params paramMask param |
	"Track header"
	flags := self short.
	unknown1 := (1 to: 2) collect: [:i | self long].
	keys := self long.
	"Log"
	log == nil ifFalse: [log crtab: indent; nextPutAll: 'Flags: '; print: flags; 
		nextPutAll: ' {', flags hex, '}';
		nextPutAll: ' Unknown: '; print: unknown1].
	"Keys"
	^(1 to: keys) collect: [:i |
		params := nil.
		"Key header"
		frame := self long.
		paramFlags := self short.
		"Log"
		log == nil ifFalse: [log crtab: indent; print: frame; nextPutAll: ':	['; print: paramFlags; nextPutAll: ']	'].
		"Params, if not default"
		paramFlags = 0 ifFalse: [
			params := Dictionary new.
			paramMask := 1.
			#(tension: continuity: bias: easeTo: easeFrom:) with: 
			#(true true true false false) do: [:what :symmetric |
				param := (paramFlags bitAnd: paramMask) ~= 0
					ifTrue: [self float]
					ifFalse: [0.0].
				log == nil ifFalse: [log crtab: indent+1; print: param; space; nextPutAll: what; space;
					print: (symmetric ifTrue: [25 * (1 + param)] ifFalse: [param * 50]) rounded].
				params at: what put: param.
				paramMask := paramMask bitShift: 1].
			log == nil ifFalse: [log crtab: indent+1]].
		log == nil ifFalse: [log nextPutAll: 'Data: '].
		"Data"
		frame -> (aBlock value: params)]! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 18:18'!
trackColor
	"Read keyframes interpolating a color"
	
	| color |
	^self trackCollect: [:params|
		"@@: Still to do ..."
		"params == nil ifFalse:[self halt]."
		color := self colorFloat.
		log == nil ifFalse: [log print: color].
		color].! !

!ThreeDSParser methodsFor: 'reading-keyframe'!
trackFlag
	"Read keyframes for a flag (hide)"
	
	| flag |
	flag := false.
	^self trackCollect: [:params|
		"@@: Still to do ..."
		"params == nil ifFalse:[self halt]."
		flag := flag not.
		log == nil ifFalse: [log print: flag].
		flag].! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 18:18'!
trackFloat
	"Read keyframes interpolating a float (hotspot, falloff, roll, etc.)"
	
	| float |
	^self trackCollect: [:params|
		"@@: Still to do ..."
		"params == nil ifFalse:[self halt]."
		float := self float.
		log == nil ifFalse: [log print: float].
		float].! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 18:19'!
trackRotation
	"Read keyframes interpolating a rotation"
	
	| angle axis |
	^self trackCollect: [:params|
		"@@: Still to do ..."
		"params == nil ifFalse:[self halt]."
		angle := self float.
		axis := self vector3.
		log == nil ifFalse: [log print: axis; space; print: angle radiansToDegrees].
		B3DRotation radiansAngle: angle negated axis: axis].! !

!ThreeDSParser methodsFor: 'reading-keyframe' stamp: 'ar 2/6/1999 20:59'!
trackVector

	"Read keyframes interpolating a vector (position, scale)"
	| vector spec splClass |
	^self trackCollect: [:params|
		params ifNil:[spec _ Dictionary new] ifNotNil:[spec _ params].
		vector := self vector3.
		spec at: #position put: vector.
		log == nil ifFalse: [log print: vector].
		splClass _ self splineVertexClass.
		splClass
			ifNil:[vector]
			ifNotNil:[splClass from3DS: spec]].! !


!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:53'!
cString
	"Generic Subchunk containing a cstring"
	| s c |
	s := WriteStream on: (String new: 128).
	[(c := source next) ~= 0] whileTrue: 
		[s nextPut: c asCharacter].
	^s contents! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 19:51'!
color24
	"Color from 3 bytes"
	| red green blue |
	red := source next.
	green := source next.
	blue := source next.
	^Color
		r: red / 255.0 
		g: green / 255.0
		b: blue / 255.0! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 19:51'!
colorFloat
	"Color from 3 floats"

	| red green blue |
	red := self float.
	green := self float.
	blue := self float.
	^Color r: red g: green b: blue! !

!ThreeDSParser methodsFor: 'reading-primitives'!
container
	"Generic container chunk"
	
	self recognize: #()! !

!ThreeDSParser methodsFor: 'reading-primitives'!
flag
	"Generic Subchunk -- if found, answer true"

	^true! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:55'!
float
	"Generic Subchunk containing a float"
	| fltArray |
	fltArray _ FloatArray new: 1.
	fltArray basicAt: 1 put: self uLong.
	^fltArray at: 1.! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:55'!
long
	"Generic Subchunk containing a long"
	^(source next: 4) longAt: 1 bigEndian: false.! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 02:08'!
matrix
	"float matrix[4][3]"
	
	| m |
	m := B3DMatrix4x4 identity.
	1 to: 4 do: [:column |
		1 to: 3 do: [:row |
			m basicAt: row-1*4+column put: self uLong.
			"m row: row column: column put: source readFloat"]].
	^m! !

!ThreeDSParser methodsFor: 'reading-primitives'!
percentageChunk

	^(self recognize: #((16r0030 short) (16r0031 float))) / 100.0.! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:57'!
short
	"Generic Subchunk containing a short"
	^(source next: 2) shortAt: 1 bigEndian: false! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:57'!
twoFloats
	"Generic Subchunk containing two floats"
	^Array with: self float with: self float! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:58'!
twoLongs
	"Generic Subchunk containing two longs"
	^Array with: self long with: self long! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:58'!
twoShorts
	"Generic Subchunk containing two shorts"
	^Array with: self short with: self short! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:58'!
twoVector3
	"Generic Subchunk containing two points"
	^Array with: self vector3 with: self vector3! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:56'!
uLong
	"Generic Subchunk containing a long"
	^(source next: 4) unsignedLongAt: 1 bigEndian: false.! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 2/6/1999 00:57'!
uShort
	"Generic Subchunk containing a short"
	^(source next: 2) unsignedShortAt: 1 bigEndian: false! !

!ThreeDSParser methodsFor: 'reading-primitives' stamp: 'ar 3/19/2000 14:12'!
vector3
	"Generic Subchunk containing a vector"
	| x y z |
	x _ self float.
	"Swap z and y"
	z _ self float.
	y _ self float.
	^B3DVector3 x: x y: y z: z! !


!ThreeDSParser methodsFor: 'executing'!
indexed: item do: firstBlock do: secondBlock 
	"According to item's key evaluate one of the blocks with item's value"

	self indexed: item doBlocks: (Array with: firstBlock with: secondBlock)! !

!ThreeDSParser methodsFor: 'executing'!
indexed: item do: firstBlock do: secondBlock do: thirdBlock
	"According to item's key evaluate one of the blocks with item's value"

	self indexed: item doBlocks: 
		(Array with: firstBlock with: secondBlock with: thirdBlock)! !

!ThreeDSParser methodsFor: 'executing'!
indexed: item doBlocks: blocks
	"According to item's key evaluate one of the blocks with item's value"

	(blocks at: item key) value: item value! !


!ThreeDSParser methodsFor: 'dispatching'!
recognize: dispatcherArray
	"Answer first item found"

	| first |
	first := nil.
	self recognize: dispatcherArray do: [:item |
		first == nil ifTrue: [first := item]].
	^first! !

!ThreeDSParser methodsFor: 'dispatching'!
recognize: dispatcherArray as: resultCollectionClass 
	"Collect all items in a new resultCollectionClass"

	| resultCollection |
	resultCollection := resultCollectionClass new.
	self recognize: dispatcherArray do: [:item | resultCollection add: item].
	^resultCollection! !

!ThreeDSParser methodsFor: 'dispatching'!
recognize: dispatcherArray do: aBlock
	"Provide default end position"

	self recognize: dispatcherArray do: aBlock inChunksUpTo: chunkPos + chunkLen! !

!ThreeDSParser methodsFor: 'dispatching'!
recognize: dispatcherArray do: aBlock inChunksUpTo: endPos
	"Scan chunks up to endPos, process those mentioned in dispatcherArray"

	| nextChunkPos item |
	nextChunkPos := source position.
	[nextChunkPos < endPos] whileTrue: [
		"Read header"
		self chunkHeader.
		nextChunkPos := chunkPos + chunkLen.
		"Dispatch"
		(item := self dispatchID: chunkID in: dispatcherArray) notNil
			ifTrue: [aBlock value: item].
		"Skip to next chunk"
		source position = nextChunkPos ifFalse: [
			self logUnreadBytes: nextChunkPos.
			source position: nextChunkPos]].! !


!ThreeDSParser methodsFor: 'private' stamp: 'ar 2/6/1999 01:16'!
chunkHeader
	"Read header of a chunk, store in instance variables"

	chunkPos := source position.
	chunkID := self uShort.
	chunkLen := self long.
	self informer value: chunkPos.
	self printChunkInfo! !

!ThreeDSParser methodsFor: 'private' stamp: 'ar 2/6/1999 18:18'!
logUnreadBytes: nextChunkPos

	| pos |
	log isNil ifFalse: [
		pos := source position.
		pos = (chunkPos + 6)
			ifFalse: [log crtab: indent + 1; print: nextChunkPos - pos;
				nextPutAll: ' Byte'].
		log nextPutAll: ' unread 		***']! !

!ThreeDSParser methodsFor: 'private'!
printChunkInfo

	log == nil ifFalse: [
		log	crtab: indent; 
			print: (self chunkDescriptionFor: chunkID);
			space;
			print: (chunkLen - 6);
			nextPutAll: ' Byte'.
		log == Transcript ifTrue: [log flush].
	].! !


!ThreeDSParser methodsFor: 'private-dispatching'!
dispatchID: id in: dispatcher
	"Look for id in dispatcher, and process it, if found"

	| index sel result |
	(index := self findID: id in: dispatcher) isNil ifTrue: [^nil].
	sel := self getSelectorFor: index in: dispatcher.
	indent := indent + 1.
	result := self perform: sel. 
	indent := indent - 1.
	result == nil ifTrue: [^nil].
	^self makeResult: result for: index in: dispatcher.! !

!ThreeDSParser methodsFor: 'private-dispatching'!
findID: id in: dispatcher
	"Return index of id in dispatcher, nil if not found"

	1 to: dispatcher size do: [:i |
		((dispatcher at: i) at: 1) = id ifTrue: [^i]].
	^nil! !

!ThreeDSParser methodsFor: 'private-dispatching'!
getSelectorFor: index in: dispatcher
	"Return method selector"

	^(dispatcher at: index) at: 2! !

!ThreeDSParser methodsFor: 'private-dispatching'!
makeResult: result for: index in: dispatcher
	"Answer Association if needed"

	| disp sym |
	disp := dispatcher at: index.
	disp size < 3 		"return result itself"
		ifTrue: [^result].
	sym := disp at: 3.
	sym = #->		"return selector -> result"
		 ifTrue: [^(disp at: 2) -> result].
	"return symbol -> result"
	^sym -> result! !


!ThreeDSParser methodsFor: 'private-util'!
chunkDescriptionFor: id
	"Answer chunk description for id"
	
	^self class chunkDescriptionFor: id! !


!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:31'!
cameraClass
	^self specAt: #camera! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:31'!
materialClass
	^self specAt: #material! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:31'!
meshObjectClass
	^self specAt: #meshObject! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:31'!
pointLightClass
	^self specAt: #pointLight! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:32'!
sceneClass
	^self specAt: #scene! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:33'!
specAt: aSymbol
	^self specAt: aSymbol ifAbsent:[nil]! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:36'!
specAt: aSymbol ifAbsent: aBlock
	| classSymbol |
	classSpec ifNil:[^aBlock value].
	classSymbol _ classSpec at: aSymbol ifAbsent:[^aBlock value].
	classSymbol ifNil:[^aBlock value].
	^Smalltalk at: classSymbol ifAbsent: aBlock
	! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:59'!
splineVertexClass
	^self specAt: #splineVertex! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:32'!
spotLightClass
	^self specAt: #spotLight! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:33'!
textureArrayClass
	^self specAt: #textureArray ifAbsent:[Array]! !

!ThreeDSParser methodsFor: 'construction classes' stamp: 'ar 2/6/1999 20:33'!
vertexArrayClass
	^self specAt: #vertexArray ifAbsent:[Array]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreeDSParser class
	instanceVariableNames: ''!

!ThreeDSParser class methodsFor: 'utilities'!
chunkDescriptionFor: id
	"Answer chunk description for id"
	
	^self chunkDescriptions at: id ifAbsent: []! !

!ThreeDSParser class methodsFor: 'utilities'!
chunkDescriptions

	ChunkDescriptions == nil ifTrue: [self initializeChunkDescriptions].
	^ChunkDescriptions! !

!ThreeDSParser class methodsFor: 'utilities'!
chunkDocumentation
	"From: The Unofficial 3DStudio 3DS File Format v1.0 by Jeff Lewis"
	"http://www.leo.org/pub/comp/graphics/3d/viewpoint/format_specs/3DS_details.rtf.gz"
	
	^
'0000H	NULL_CHUNK
0001H	UnknownChunk
0002H	M3D_VERSION
	short version;
0005H	M3D_KFVERSION
0010H	COLOR_F
	float red, grn, blu;
0011H	COLOR_24
	char red, grn, blu;
0012H	LIN_COLOR_24
	char red, grn, blu;
0013H	LIN_COLOR_F
	float red, grn, blu;
0030H	INT_PERCENTAGE
	short percentage;
0031H	FLOAT_PERCENTAGE
	float percentage;
0100H	MASTER_SCALE
	float scale;
0995H	ChunkType
0996H	ChunkUnique
0997H	NotChunk
0998H	Container
0999H	IsChunk
0c3cH	C_SXP_SELFI_MASKDATA
1100H	BIT_MAP
	cstr filename;
1101H	USE_BIT_MAP
1200H	SOLID_BGND	followed by color_f
1201H	USE_SOLID_BGND
1300H	V_GRADIENT	followed by three color_f: start, mid, end
	float midpoint;
1301H	USE_V_GRADIENT
1400H	LO_SHADOW_BIAS
	float bias;
1410H	HI_SHADOW_BIAS
1420H	SHADOW_MAP_SIZE
	short size;
1430H	SHADOW_SAMPLES
1440H	SHADOW_RANGE
1450H	SHADOW_FILTER
	float filter;
1460H	RAY_BIAS
	float bias;
1500H	O_CONSTS
	float plane_x, plane_y, plane_z;
2100H	AMBIENT_LIGHT
2200H	FOG		followed by color_f, fog_bgnd
	float near_plane, near_density;
	float far_plane, far_density;
2201H	USE_FOG
2210H	FOG_BGND
2300H	DISTANCE_CUE	followed by dcue_bgnd
	float near_plane, near_density;
	float far_plane, far_density;
2301H	USE_DISTANCE_CUE
2302H	LAYER_FOG
	float fog_z_from, fog_z_to;
	float fog_density;
	short fog_type;
2303H	USE_LAYER_FOG
2310H	DCUE_BGND
2d2dH	SMAGIC
2d3dH	LMAGIC
3000H	DEFAULT_VIEW
3010H	VIEW_TOP
	float targe_x, target_y, target_z;
	float view_width;
3020H	VIEW_BOTTOM
	float targe_x, target_y, target_z;
	float view_width;
3030H	VIEW_LEFT
	float targe_x, target_y, target_z;
	float view_width;
3040H	VIEW_RIGHT
	float targe_x, target_y, target_z;
	float view_width;
3050H	VIEW_FRONT
	float targe_x, target_y, target_z;
	float view_width;
3060H	VIEW_BACK
	float targe_x, target_y, target_z;
	float view_width;
3070H	VIEW_USER
	float targe_x, target_y, target_z;
	float view_width;
3080H	VIEW_CAMERA
	cstr camera_name;
3090H	VIEW_WINDOW
3d3dH	MDATA	Mesh Data Magic Number (.3DS files sub of 4d4d)
3d3eH	MESH_VERSION
3daaH	MLIBMAGIC	Material Library Magic Number (.MLI files)
3dc2H	PRJMAGIC	3dS Project Magic Number (.PRJ files)
3dffH	MATMAGIC	Material File Magic Number (.MAT files)
4000H	NAMED_OBJECT
	cstr name;
4010H	OBJ_HIDDEN
4011H	OBJ_VIS_LOFTER
4012H	OBJ_DOESNT_CAST
4013H	OBJ_MATTE
4014H	OBJ_FAST
4015H	OBJ_PROCEDURAL
4016H	OBJ_FROZEN
4017H	OBJ_DONT_RCVSHADOW
4100H	N_TRI_OBJECT	named triangle object
			followed by point_array, point_flag_array, mesh_matrix,
			face_array
4110H	POINT_ARRAY
	short npoints;
	struct {
		float x, y, z;
		} points[npoints];
4111H	POINT_FLAG_ARRAY
	short nflags;
	short flags[nflags];
4120H	FACE_ARRAY	may be followed by smooth_group
	short nfaces;
	struct {
		short vertex1, vertex2, vertex3;
		short flags;
		} facearray[nfaces];
4130H	MSH_MAT_GROUP	mesh_material_group
	cstr material_name;
	short nfaces;
	short facenum[nfaces];
4131H	OLD_MAT_GROUP
4140H	TEX_VERTS
	short nverts;
	struct {
		float x, y;
		} vertices[nverts];
4150H	SMOOTH_GROUP
	short grouplist[n]	determined by length, seems to be 4 per face
4160H	MESH_MATRIX
	float matrix[4][3];
4165H	MESH_COLOR
	short color_index;
4170H	MESH_TEXTURE_INFO
	short map_type;
	float x_tiling, y_tiling;
	float icon_x, icon_y, icon_z;
	float matrix[4][3];
	float scaling, plan_icon_w, plan_icon_h, cyl_icon_h;
4181H	PROC_NAME
4182H	PROC_DATA
4190H	MSH_BOXMAP
4400H	N_D_L_OLD
4500H	N_CAM_OLD
4600H	N_DIRECT_LIGHT	followed by color_f
	float x, y, z;
4610H	DL_SPOTLIGHT
	float target_x, target_y, target_z;
	float hotspot_ang;
	float falloff_ang;
4620H	DL_OFF
4625H	DL_ATTENUATE
4627H	DL_RAYSHAD
4630H	DL_SHADOWED
4640H	DL_LOCAL_SHADOW
4641H	DL_LOCAL_SHADOW2
4650H	DL_SEE_CONE
4651H	DL_SPOT_RECTANGULAR
4652H	DL_SPOT_OVERSHOOT
4653H	DL_SPOT_PROJECTOR
4654H	DL_EXCLUDE
4655H	DL_RANGE
4656H	DL_SPOT_ROLL
	float roll_ang;
4657H	DL_SPOT_ASPECT
4658H	DL_RAY_BIAS
	float bias;
4659H	DL_INNER_RANGE
	float range;
465aH	DL_OUTER_RANGE
	float range;
465bH	DL_MULTIPLIER
	float multiple;
4680H	N_AMBIENT_LIGHT
4700H	N_CAMERA
	float camera_x, camera_y, camera_z;
	float target_x, target_y, target_z;
	float bank_angle;
	float focus;
4710H	CAM_SEE_CONE
4720H	CAM_RANGES
	float near_range, far_range;
4d4dH	M3DMAGIC	3DS Magic Number (.3DS file)
4f00H	HIERARCHY
4f10H	PARENT_OBJECT
4f20H	PIVOT_OBJECT
4f30H	PIVOT_LIMITS
4f40H	PIVOT_ORDER
4f50H	XLATE_RANGE
5000H	POLY_2D
5010H	SHAPE_OK
5011H	SHAPE_NOT_OK
5020H	SHAPE_HOOK
6000H	PATH_3D
6005H	PATH_MATRIX
6010H	SHAPE_2D
6020H	M_SCALE
6030H	M_TWIST
6040H	M_TEETER
6050H	M_FIT
6060H	M_BEVEL
6070H	XZ_CURVE
6080H	YZ_CURVE
6090H	INTERPCT
60a0H	DEFORM_LIMIT
6100H	USE_CONTOUR
6110H	USE_TWEEN
6120H	USE_SCALE
6130H	USE_TWIST
6140H	USE_TEETER
6150H	USE_FIT
6160H	USE_BEVEL
7000H	VIEWPORT_LAYOUT_OLD
7001H	VIEWPORT_LAYOUT	followed by viewport_size, viewport_data
	short form, top, ready, wstate, swapws, swapport, swapcur;
7010H	VIEWPORT_DATA_OLD
7011H	VIEWPORT_DATA
	short flags, axis_lockout;
	short win_x, win_y, win_w, winh_, win_view;
	float zoom;
	float worldcenter_x, worldcenter_y, worldcenter_z;
	float horiz_ang, vert_ang;
	cstr camera_name;
7012H	VIEWPORT_DATA_3
	short flags, axis_lockout;
	short win_x, win_y, win_w, winh_, win_view;
	float zoom;
	float worldcenter_x, worldcenter_y, worldcenter_z;
	float horiz_ang, vert_ang;
	cstr camera_name;
7020H	VIEWPORT_SIZE
	short x, y, w, h;
7030H	NETWORK_VIEW
8000H	XDATA_SECTION
8001H	XDATA_ENTRY
8002H	XDATA_APPNAME
8003H	XDATA_STRING
8004H	XDATA_FLOAT
8005H	XDATA_DOUBLE
8006H	XDATA_SHORT
8007H	XDATA_LONG
8008H	XDATA_VOID
8009H	XDATA_GROUP
800aH	XDATA_RFU6
800bH	XDATA_RFU5
800cH	XDATA_RFU4
800dH	XDATA_RFU3
800eH	XDATA_RFU2
800fH	XDATA_RFU1
80f0H	PARENT_NAME
a000H	MAT_NAME
	cstr material_name;
a010H	MAT_AMBIENT	followed by color chunk
a020H	MAT_DIFFUSE	followed by color chunk
a030H	MAT_SPECULAR	followed by color chunk
a040H	MAT_SHININESS	followed by percentage chunk
a041H	MAT_SHIN2PCT	followed by percentage chunk
a042H	MAT_SHIN3PCT	followed by percentage chunk
a050H	MAT_TRANSPARENCY	followed by percentage chunk
a052H	MAT_XPFALL	followed by percentage chunk
a053H	MAT_REFBLUR	followed by percentage chunk
a080H	MAT_SELF_ILLUM
a081H	MAT_TWO_SIDE
a082H	MAT_DECAL
a083H	MAT_ADDITIVE
a084H	MAT_SELF_ILPCT	followed by percentage chunk
a085H	MAT_WIRE
a086H	MAT_SUPERSMP
a087H	MAT_WIRESIZE
	float wire_size;
a088H	MAT_FACEMAP
a08aH	MAT_XPFALLIN
a08cH	MAT_PHONGSOFT
a08eH	MAT_WIREABS
a100H	MAT_SHADING
	short shading_value;
a200H	MAT_TEXMAP	followed by percentage chunk, mat_mapname,
			mat_map_tiling, mat_map_texblur...
a204H	MAT_SPECMAP	followed by percentage_chunk, mat_mapname
a210H	MAT_OPACMAP	followed by percentage_chunk, mat_mapname
a220H	MAT_REFLMAP	followed by percentage_chunk, mat_mapname
a230H	MAT_BUMPMAP	followed by percentage_chunk, mat_mapname
a240H	MAT_USE_XPFALL
a250H	MAT_USE_REFBLUR
a252H	MAT_BUMP_PERCENT
a300H	MAT_MAPNAME
	cstr filename;
a310H	MAT_ACUBIC
a320H	MAT_SXP_TEXT_DATA
a321H	MAT_SXP_TEXT2_DATA
a322H	MAT_SXP_OPAC_DATA
a324H	MAT_SXP_BUMP_DATA
a325H	MAT_SXP_SPEC_DATA
a326H	MAT_SXP_SHIN_DATA
a328H	MAT_SXP_SELFI_DATA
a32aH	MAT_SXP_TEXT_MASKDATA
a32cH	MAT_SXP_TEXT2_MASKDATA
a32eH	MAT_SXP_OPAC_MASKDATA
a330H	MAT_SXP_BUMP_MASKDATA
a332H	MAT_SXP_SPEC_MASKDATA
a334H	MAT_SXP_SHIN_MASKDATA
a336H	MAT_SXP_SELFI_MASKDATA
a338H	MAT_SXP_REFL_MASKDATA
a33aH	MAT_TEX2MAP
a33cH	MAT_SHINMAP
a33dH	MAT_SELFIMAP
a33eH	MAT_TEXMASK
a340H	MAT_TEX2MASK
a342H	MAT_OPACMASK
a344H	MAT_BUMPMASK
a346H	MAT_SHINMASK
a348H	MAT_SPECMASK
a34aH	MAT_SELFIMASK
a34cH	MAT_REFLMASK
a350H	MAT_MAP_TILINGOLD
a351H	MAT_MAP_TILING
	short flags;
a352H	MAT_MAP_TEXBLUR_OLD
a353H	MAT_MAP_TEXBLUR
	float blurring;
a354H	MAT_MAP_USCALE
a356H	MAT_MAP_VSCALE
a358H	MAT_MAP_UOFFSET
a35aH	MAT_MAP_VOFFSET
a35cH	MAT_MAP_ANG
a360H	MAT_MAP_COL1
a362H	MAT_MAP_COL2
a364H	MAT_MAP_RCOL
a366H	MAT_MAP_GCOL
a368H	MAT_MAP_BCOL
afffH	MAT_ENTRY
b000H	KFDATA	followed by kfhdr
b001H	AMBIENT_NODE_TAG
b002H	OBJECT_NODE_TAG	followed by node_hdr, pivot, pos_track_tag,
			rot_track_tag, scl_track_tag, morph_smooth...
b003H	CAMERA_NODE_TAG	followed by node_hdr, pos_track_tag, fov_track_tag,
			roll_track_tag...
b004H	TARGET_NODE_TAG	followed by node_hdr, pos_track_tag...
b005H	LIGHT_NODE_TAG	followed by node_hdr, pos_track_tag, col_track_tag...
b006H	L_TARGET_NODE_TAG	followed by node_id, node_hdr, pos_track_tag
b007H	SPOTLIGHT_NODE_TAG followed by node_id, node_hdr, pos_track_tag,					hot_track_tag, fall_track_tag, roll_track_tag,
			col_track_tag...
b008H	KFSEG
	long start, end;
b009H	KFCURTIME
	long curframe;
b00aH	KFHDR	followed by viewport_layout, kfseg, kfcurtime,
			object_node_tag, light_node_tag, target_node_tag,
			camera_node_tag, l_target_node_tag, spotlight_node_tag
			ambient_node_tag...
	short revision;
	cstr filename;
	short animlen;
b010H	NODE_HDR
	cstr objname;
	short flags1;
	short flags2;
	short heirarchy;	?
b011H	INSTANCE_NAME
b012H	PRESCALE
b013H	PIVOT
	float pivot_x, pivot_y, pivot_z;
b014H	BOUNDBOX
b015H	MORPH_SMOOTH
	float morph_smoothing_angle_rad;
b020H	POS_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float pos_x, pos_y, pos_z;
		} pos[keys];
b021H	ROT_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float rotation_rad;
		float axis_x, axis_y, axis_z;
		} rot[keys];
b022H	SCL_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float scale_x, scale_y, scale_z;
		} scale[keys];
b023H	FOV_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float camera_field_of_view;
		} fov[keys]
b024H	ROLL_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float camera_roll;
		} roll[keys];
b025H	COL_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float red, rgn, blu;
		} color[keys];
b026H	MORPH_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		cstr obj_name;
		} morph[keys];
b027H	HOT_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float hotspot_ang;
		} hotspot[keys];
b028H	FALL_TRACK_TAG
	short flags;
	short unknown[4];
	short keys;
	short unknown;
	struct {
		short framenum;
		long unknown;
		float falloff_ang;
		} falloff[keys];
b029H	HIDE_TRACK_TAG
b030H	NODE_ID
	short id;
c010H	C_MDRAWER
c020H	C_TDRAWER
c030H	C_SHPDRAWER
c040H	C_MODDRAWER
c050H	C_RIPDRAWER
c060H	C_TXDRAWER
c062H	C_PDRAWER
c064H	C_MTLDRAWER
c066H	C_FLIDRAWER
c067H	C_CUBDRAWER
c070H	C_MFILE
c080H	C_SHPFILE
c090H	C_MODFILE
c0a0H	C_RIPFILE
c0b0H	C_TXFILE
c0b2H	C_PFILE
c0b4H	C_MTLFILE
c0b6H	C_FLIFILE
c0b8H	C_PALFILE
c0c0H	C_TX_STRING
c0d0H	C_CONSTS
c0e0H	C_SNAPS
c0f0H	C_GRIDS
c100H	C_ASNAPS
c110H	C_GRID_RANGE
c120H	C_RENDTYPE
c130H	C_PROGMODE
c140H	C_PREVMODE
c150H	C_MODWMODE
c160H	C_MODMODEL
c170H	C_ALL_LINES
c180H	C_BACK_TYPE
c190H	C_MD_CS
c1a0H	C_MD_CE
c1b0H	C_MD_SML
c1c0H	C_MD_SMW
c1c3H	C_LOFT_WITH_TEXTURE
c1c4H	C_LOFT_L_REPEAT
c1c5H	C_LOFT_W_REPEAT
c1c6H	C_LOFT_UV_NORMALIZE
c1c7H	C_WELD_LOFT
c1d0H	C_MD_PDET
c1e0H	C_MD_SDET
c1f0H	C_RGB_RMODE
c200H	C_RGB_HIDE
c202H	C_RGB_MAPSW
c204H	C_RGB_TWOSIDE
c208H	C_RGB_SHADOW
c210H	C_RGB_AA
c220H	C_RGB_OVW
c230H	C_RGB_OVH
c23dH	CMAGIC
c240H	C_RGB_PICTYPE
c250H	C_RGB_OUTPUT
c253H	C_RGB_TODISK
c254H	C_RGB_COMPRESS
c255H	C_JPEG_COMPRESSION
c256H	C_RGB_DISPDEV
c259H	C_RGB_HARDDEV
c25aH	C_RGB_PATH
c25bH	C_BITMAP_DRAWER
c260H	C_RGB_FILE
c270H	C_RGB_OVASPECT
c271H	C_RGB_ANIMTYPE
c272H	C_RENDER_ALL
c273H	C_REND_FROM
c274H	C_REND_TO
c275H	C_REND_NTH
c276H	C_PAL_TYPE
c277H	C_RND_TURBO
c278H	C_RND_MIP
c279H	C_BGND_METHOD
c27aH	C_AUTO_REFLECT
c27bH	C_VP_FROM
c27cH	C_VP_TO
c27dH	C_VP_NTH
c27eH	C_REND_TSTEP
c27fH	C_VP_TSTEP
c280H	C_SRDIAM
c290H	C_SRDEG
c2a0H	C_SRSEG
c2b0H	C_SRDIR
c2c0H	C_HETOP
c2d0H	C_HEBOT
c2e0H	C_HEHT
c2f0H	C_HETURNS
c300H	C_HEDEG
c310H	C_HESEG
c320H	C_HEDIR
c330H	C_QUIKSTUFF
c340H	C_SEE_LIGHTS
c350H	C_SEE_CAMERAS
c360H	C_SEE_3D
c370H	C_MESHSEL
c380H	C_MESHUNSEL
c390H	C_POLYSEL
c3a0H	C_POLYUNSEL
c3a2H	C_SHPLOCAL
c3a4H	C_MSHLOCAL
c3b0H	C_NUM_FORMAT
c3c0H	C_ARCH_DENOM
c3d0H	C_IN_DEVICE
c3e0H	C_MSCALE
c3f0H	C_COMM_PORT
c400H	C_TAB_BASES
c410H	C_TAB_DIVS
c420H	C_MASTER_SCALES
c430H	C_SHOW_1STVERT
c440H	C_SHAPER_OK
c450H	C_LOFTER_OK
c460H	C_EDITOR_OK
c470H	C_KEYFRAMER_OK
c480H	C_PICKSIZE
c490H	C_MAPTYPE
c4a0H	C_MAP_DISPLAY
c4b0H	C_TILE_XY
c4c0H	C_MAP_XYZ
c4d0H	C_MAP_SCALE
c4e0H	C_MAP_MATRIX_OLD
c4e1H	C_MAP_MATRIX
c4f0H	C_MAP_WID_HT
c500H	C_OBNAME
c510H	C_CAMNAME
c520H	C_LTNAME
c525H	C_CUR_MNAME
c526H	C_CURMTL_FROM_MESH
c527H	C_GET_SHAPE_MAKE_FACES
c530H	C_DETAIL
c540H	C_VERTMARK
c550H	C_MSHAX
c560H	C_MSHCP
c570H	C_USERAX
c580H	C_SHOOK
c590H	C_RAX
c5a0H	C_STAPE
c5b0H	C_LTAPE
c5c0H	C_ETAPE
c5c8H	C_KTAPE
c5d0H	C_SPHSEGS
c5e0H	C_GEOSMOOTH
c5f0H	C_HEMISEGS
c600H	C_PRISMSEGS
c610H	C_PRISMSIDES
c620H	C_TUBESEGS
c630H	C_TUBESIDES
c640H	C_TORSEGS
c650H	C_TORSIDES
c660H	C_CONESIDES
c661H	C_CONESEGS
c670H	C_NGPARMS
c680H	C_PTHLEVEL
c690H	C_MSCSYM
c6a0H	C_MFTSYM
c6b0H	C_MTTSYM
c6c0H	C_SMOOTHING
c6d0H	C_MODICOUNT
c6e0H	C_FONTSEL
c6f0H	C_TESS_TYPE
c6f1H	C_TESS_TENSION
c700H	C_SEG_START
c705H	C_SEG_END
c710H	C_CURTIME
c715H	C_ANIMLENGTH
c720H	C_PV_FROM
c725H	C_PV_TO
c730H	C_PV_DOFNUM
c735H	C_PV_RNG
c740H	C_PV_NTH
c745H	C_PV_TYPE
c750H	C_PV_METHOD
c755H	C_PV_FPS
c765H	C_VTR_FRAMES
c770H	C_VTR_HDTL
c771H	C_VTR_HD
c772H	C_VTR_TL
c775H	C_VTR_IN
c780H	C_VTR_PK
c785H	C_VTR_SH
c790H	C_WORK_MTLS
c792H	C_WORK_MTLS_2
c793H	C_WORK_MTLS_3
c794H	C_WORK_MTLS_4
c7a1H	C_BGTYPE
c7b0H	C_MEDTILE
c7d0H	C_LO_CONTRAST
c7d1H	C_HI_CONTRAST
c7e0H	C_FROZ_DISPLAY
c7f0H	C_BOOLWELD
c7f1H	C_BOOLTYPE
c900H	C_ANG_THRESH
c901H	C_SS_THRESH
c903H	C_TEXTURE_BLUR_DEFAULT
ca00H	C_MAPDRAWER
ca01H	C_MAPDRAWER1
ca02H	C_MAPDRAWER2
ca03H	C_MAPDRAWER3
ca04H	C_MAPDRAWER4
ca05H	C_MAPDRAWER5
ca06H	C_MAPDRAWER6
ca07H	C_MAPDRAWER7
ca08H	C_MAPDRAWER8
ca09H	C_MAPDRAWER9
ca10H	C_MAPDRAWER_ENTRY
ca20H	C_BACKUP_FILE
ca21H	C_DITHER_256
ca22H	C_SAVE_LAST
ca23H	C_USE_ALPHA
ca24H	C_TGA_DEPTH
ca25H	C_REND_FIELDS
ca26H	C_REFLIP
ca27H	C_SEL_ITEMTOG
ca28H	C_SEL_RESET
ca29H	C_STICKY_KEYINF
ca2aH	C_WELD_THRESHOLD
ca2bH	C_ZCLIP_POINT
ca2cH	C_ALPHA_SPLIT
ca30H	C_KF_SHOW_BACKFACE
ca40H	C_OPTIMIZE_LOFT
ca42H	C_TENS_DEFAULT
ca44H	C_CONT_DEFAULT
ca46H	C_BIAS_DEFAULT
ca50H	C_DXFNAME_SRC
ca60H	C_AUTO_WELD
ca70H	C_AUTO_UNIFY
ca80H	C_AUTO_SMOOTH
ca90H	C_DXF_SMOOTH_ANG
caa0H	C_SMOOTH_ANG
cb00H	C_WORK_MTLS_5
cb01H	C_WORK_MTLS_6
cb02H	C_WORK_MTLS_7
cb03H	C_WORK_MTLS_8
cb04H	C_WORKMTL
cb10H	C_SXP_TEXT_DATA
cb11H	C_SXP_OPAC_DATA
cb12H	C_SXP_BUMP_DATA
cb13H	C_SXP_SHIN_DATA
cb20H	C_SXP_TEXT2_DATA
cb24H	C_SXP_SPEC_DATA
cb28H	C_SXP_SELFI_DATA
cb30H	C_SXP_TEXT_MASKDATA
cb32H	C_SXP_TEXT2_MASKDATA
cb34H	C_SXP_OPAC_MASKDATA
cb36H	C_SXP_BUMP_MASKDATA
cb38H	C_SXP_SPEC_MASKDATA
cb3aH	C_SXP_SHIN_MASKDATA
cb3eH	C_SXP_REFL_MASKDATA
cc00H	C_NET_USE_VPOST
cc10H	C_NET_USE_GAMMA
cc20H	C_NET_FIELD_ORDER
cd00H	C_BLUR_FRAMES
cd10H	C_BLUR_SAMPLES
cd20H	C_BLUR_DUR
cd30H	C_HOT_METHOD
cd40H	C_HOT_CHECK
cd50H	C_PIXEL_SIZE
cd60H	C_DISP_GAMMA
cd70H	C_FBUF_GAMMA
cd80H	C_FILE_OUT_GAMMA
cd82H	C_FILE_IN_GAMMA
cd84H	C_GAMMA_CORRECT
cd90H	C_APPLY_DISP_GAMMA
cda0H	C_APPLY_FBUF_GAMMA
cdb0H	C_APPLY_FILE_GAMMA
cdc0H	C_FORCE_WIRE
cdd0H	C_RAY_SHADOWS
cde0H	C_MASTER_AMBIENT
cdf0H	C_SUPER_SAMPLE
ce00H	C_OBJECT_MBLUR
ce10H	C_MBLUR_DITHER
ce20H	C_DITHER_24
ce30H	C_SUPER_BLACK
ce40H	C_SAFE_FRAME
ce50H	C_VIEW_PRES_RATIO
ce60H	C_BGND_PRES_RATIO
ce70H	C_NTH_SERIAL_NUM
d000H	VPDATA
d100H	P_QUEUE_ENTRY
d110H	P_QUEUE_IMAGE
d114H	P_QUEUE_USEIGAMMA
d120H	P_QUEUE_PROC
d130H	P_QUEUE_SOLID
d140H	P_QUEUE_GRADIENT
d150H	P_QUEUE_KF
d152H	P_QUEUE_MOTBLUR
d153H	P_QUEUE_MB_REPEAT
d160H	P_QUEUE_NONE
d180H	P_QUEUE_RESIZE
d185H	P_QUEUE_OFFSET
d190H	P_QUEUE_ALIGN
d1a0H	P_CUSTOM_SIZE
d210H	P_ALPH_NONE
d220H	P_ALPH_PSEUDO
d221H	P_ALPH_OP_PSEUDO
d222H	P_ALPH_BLUR
d225H	P_ALPH_PCOL
d230H	P_ALPH_C0
d231H	P_ALPH_OP_KEY
d235H	P_ALPH_KCOL
d238H	P_ALPH_OP_NOCONV
d240H	P_ALPH_IMAGE
d250H	P_ALPH_ALPHA
d260H	P_ALPH_QUES
d265H	P_ALPH_QUEIMG
d270H	P_ALPH_CUTOFF
d280H	P_ALPHANEG
d300H	P_TRAN_NONE
d310H	P_TRAN_IMAGE
d312H	P_TRAN_FRAMES
d320H	P_TRAN_FADEIN
d330H	P_TRAN_FADEOUT
d340H	P_TRANNEG
d400H	P_RANGES
d500H	P_PROC_DATA
f020H	POS_TRACK_TAG_KEY
f021H	ROT_TRACK_TAG_KEY
f022H	SCL_TRACK_TAG_KEY
f023H	FOV_TRACK_TAG_KEY
f024H	ROLL_TRACK_TAG_KEY
f025H	COL_TRACK_TAG_KEY
f026H	MORPH_TRACK_TAG_KEY
f027H	HOT_TRACK_TAG_KEY
f028H	FALL_TRACK_TAG_KEY
f110H	POINT_ARRAY_ENTRY
f111H	POINT_FLAG_ARRAY_ENTRY
f120H	FACE_ARRAY_ENTRY
f130H	MSH_MAT_GROUP_ENTRY
f140H	TEX_VERTS_ENTRY
f150H	SMOOTH_GROUP_ENTRY
ffffH	DUMMY'! !

!ThreeDSParser class methodsFor: 'utilities'!
clearChunkDescriptions
	"Reset Class variable ChunkDescriptions"

	ChunkDescriptions := nil.! !

!ThreeDSParser class methodsFor: 'utilities' stamp: 'sma 3/15/2000 20:59'!
initializeChunkDescriptions
	"Initialize Class variable ChunkDescriptions from the documentation"
	"ThreeDSParser initializeChunkDescriptions "

	| s id tag comment sl c |
	s := ReadStream on: self chunkDocumentation.
	ChunkDescriptions := Dictionary new: 100.
	id := tag := comment := nil.
	[s atEnd] whileFalse: [
		s peek = Character tab
			ifFalse: [
				id isNil ifFalse: [
					ChunkDescriptions add: (ThreeDSChunkDescription
						id: id name: tag comment: comment contents)].
				id := Integer readFrom: s base: 16.
				s skip: 2.
				sl := ReadStream on: (s upTo: Character cr).
				tag := OrderedCollection new.
				[(c := sl next) isNil or: [c isSeparator]] whileFalse: [tag add: c].
				tag := String withAll: tag.
				sl skipSeparators.
				comment := WriteStream on: String new]
			ifTrue: [comment nextPutAll: s nextLine; nextPut: Character cr]
		].
	ChunkDescriptions add: (ThreeDSChunkDescription
						id: id name: tag comment: comment contents)! !


!ThreeDSParser class methodsFor: 'class initialization' stamp: 'ar 2/6/1999 21:00'!
defaultSpec
	"The default spec is a dictionary with
		#camera -> CameraClassName (e.g., #B3DCamera3DS)
		#material -> MaterialClassName (e.g., #B3DMaterial3DS)
		#meshObject -> MeshObjectClassName (e.g., #B3DObject3DS)
		#pointLight -> PointLightClassName (e.g., #B3DPositionalLight)
		#spotLight -> SpotLightClassName (e.g., #B3DSpotLight)
		#scene -> SceneClassName (e.g., #B3DScene3DS)
		#splineVertex -> SplineVertexClass (e.g., B3DSplineVertex3DS)
	all responding to #from3DS: aDictionary and
		#vertexArray -> VertexArrayClassName (e.g., #B3DVector3Array)
		#textureArray -> TextureArrayClassName (e.g., #B3DTexture2Array)
	for constructing large arrays of vertex / texture coordinates
	(responding to the standard array messages #new: #at: and #at:put:)
	"
	"ThreeDSParser defaultSpec"
	^DefaultSpec! !

!ThreeDSParser class methodsFor: 'class initialization' stamp: 'ar 2/6/1999 20:45'!
defaultSpec: aDictionary
	"ThreeDSParser defaultSpec"
	DefaultSpec _ aDictionary! !

!ThreeDSParser class methodsFor: 'class initialization' stamp: 'ar 2/12/1999 17:53'!
initialize
	"ThreeDSParser initialize"
	self defaultSpec: nil. "Reset the default spec"! !

!ThreeDSParser class methodsFor: 'class initialization' stamp: 'ar 4/24/1999 04:00'!
initializeB3D		"ThreeDSParser initializeB3D"
	"Initialize the 3DS Parser to use the Balloon 3D standard representations"
	| spec |
	spec _ Dictionary new.
	#(	(#camera 		#B3DCamera)
		(#material  		#B3DMaterial)
		(#meshObject 	nil"#B3DSceneObject")
		(#pointLight 	#B3DPositionalLight)
		(#spotLight 		#B3DSpotLight)
		(#splineVertex	nil "#B3DSplineVertex3DS")
		(#scene 		nil "#B3DScene")
		(#vertexArray 	#B3DVector3Array)
		(#textureArray 	#B3DTexture2Array)
	) do:[:array| spec at: array first put: array last].
	self defaultSpec: spec.
! !


!ThreeDSParser class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 05:17'!
parse: aStream
	"Answer a dictionary of name->RenderObject associations"
	^self parse: aStream using: self defaultSpec.! !

!ThreeDSParser class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 05:17'!
parse: aStream using: aSpec
	"Answer a dictionary of name->RenderObject associations"
	^self new parse: aStream using: aSpec! !

!ThreeDSParser class methodsFor: 'instance creation' stamp: 'ar 2/6/1999 20:26'!
parseFileNamed: aString
	"Answer a dictionary of name->RenderObject associations"
	^self parseFileNamed: aString using: self defaultSpec.! !

!ThreeDSParser class methodsFor: 'instance creation' stamp: 'ar 2/15/1999 05:17'!
parseFileNamed: aString using: aSpec
	"Answer a dictionary of name->RenderObject associations"
	^self new parseFileNamed: aString using: aSpec.! !
ImageMorph subclass: #ThreePhaseButtonMorph
	instanceVariableNames: 'offImage pressedImage state target actionSelector arguments actWhen '
	classVariableNames: 'AuthorModeOwner '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!ThreePhaseButtonMorph commentStamp: '<historical>' prior: 0!
A button morph with separate images for on, off, and pressed with the mouse. 

When the event actWhen occurs, send actionSelector with 'arguments' to target.  For other events, default to my eventHandler.  The current event is not supplied in the arguments to the actionSelector.  

image (a.k.a. onImage) may not be nil.  offImage and pressedImage may be nil.  nil there means be transparent and show the underlying object.  

Tools for debugging:
Display the images momentarily under program control (for positioning) (self is an instance).
	self state: #on.  self state: #off.
	self state: #pressed.  self state: #off.
Display a rectangle where the button is.
	Display fillWithColor: bounds + (self world viewBox origin).
	self invalidRect: bounds.!


!ThreePhaseButtonMorph methodsFor: 'initialize-release' stamp: 'sma 3/24/2000 11:50'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	target isMorph
		ifTrue:
			[target isWorldMorph ifTrue: [self target: aWorld].
			target isHandMorph ifTrue: [self target: aWorld primaryHand]]
		ifFalse: [(target isKindOf: Presenter) ifTrue: [self target: aWorld presenter]]! !

!ThreePhaseButtonMorph methodsFor: 'initialize-release' stamp: 'tk 7/1/97 08:34'!
initialize

	super initialize.
	state _ #off.
	target _ nil.
	actionSelector _ #flash.
	arguments _ EmptyArray.
	actWhen _ #buttonUp.

	"self on: #mouseStillDown send: #dragIfAuthoring: to: self."
		"real move should include a call on dragIfAuthoring: "! !


!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'!
actWhen: condition
	"Accepts symbols:  #buttonDown, #buttonUp, and #whilePressed"
	actWhen _ condition! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'!
actionSelector

	^ actionSelector
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:49'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 12:39'!
arguments
	^ arguments! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 7/1/97 08:39'!
arguments: aCollection

	arguments _ aCollection asArray copy.
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/29/97 21:04'!
authorModeOwner: aMorph
	AuthorModeOwner _ aMorph! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/29/97 21:02'!
dragIfAuthoring: evt
	"Allow simple dragging if the class var is set to my owner."
	owner == AuthorModeOwner ifTrue: [
		self center: evt cursorPoint].
	^ owner == AuthorModeOwner! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
offImage
	^ offImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:08'!
offImage: aForm
	offImage _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
onImage
	^ image! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:08'!
onImage: aForm
	image _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 10/19/97 15:02'!
pressedImage
	^ pressedImage! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:09'!
pressedImage: aForm
	pressedImage _ aForm.
	self invalidRect: self bounds.! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 11:01'!
state: newState
	"Change the image and invalidate the rect."

	newState == state ifTrue: [^ self].
	state _ newState.
	self invalidRect: bounds.	"All three images must be the same size"! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'!
target

	^ target
! !

!ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'tk 6/30/97 10:50'!
target: anObject

	target _ anObject
! !


!ThreePhaseButtonMorph methodsFor: 'testing' stamp: 'sw 3/8/1999 13:56'!
isOn
	^ state == #on! !


!ThreePhaseButtonMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:07'!
drawOn: aCanvas

	state == #off ifTrue: [
		offImage ifNotNil: [aCanvas paintImage: offImage at: bounds origin]].
	state == #pressed ifTrue: [
		pressedImage ifNotNil: [aCanvas paintImage: pressedImage at: bounds origin]].
	state == #on ifTrue: [
		image ifNotNil: [aCanvas paintImage: image at: bounds origin]].! !


!ThreePhaseButtonMorph methodsFor: 'geometry' stamp: 'tk 7/1/97 09:14'!
extent
	"Do it normally"

	^ bounds extent! !

!ThreePhaseButtonMorph methodsFor: 'geometry' stamp: 'tk 7/1/97 09:14'!
extent: aPoint
	"Do it normally"
	
	self changed.
	bounds _ bounds topLeft extent: aPoint.
	self layoutChanged.
	self changed.
! !


!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'jm 7/28/97 11:56'!
updateReferencesUsing: aDictionary
	"If the arguments array points at a morph we are copying, then update it to point to the new copy. This method also copies the arguments array itself, which is important!!"

	super updateReferencesUsing: aDictionary.
	arguments _ arguments collect:
		[:old | aDictionary at: old ifAbsent: [old]].
! !

!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:02'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
arguments _ arguments collect: [:each |
	deepCopier references at: each ifAbsent: [each]].
! !

!ThreePhaseButtonMorph methodsFor: 'copying' stamp: 'tk 1/8/1999 09:01'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
offImage _ offImage veryDeepCopyWith: deepCopier.
pressedImage _ pressedImage veryDeepCopyWith: deepCopier.
state _ state veryDeepCopyWith: deepCopier.
"target _ target.		Weakly copied"
"actionSelector _ actionSelector.		Symbol"
"arguments _ arguments.		Weakly copied"
actWhen _ actWhen.		"Symbol"! !


!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'tk 6/30/97 10:52'!
doButtonAction
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionSelector withArguments: arguments]].
! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'RAA 8/15/2000 16:27'!
doButtonAction: evt
	| moreArgs |
	"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."

	target ifNil: [^self].
	actionSelector ifNil: [^self].
	Cursor normal showWhile: [
		moreArgs _ actionSelector numArgs > arguments size ifTrue: [
			arguments copyWith: evt
		] ifFalse: [
			arguments
		].
		target perform: actionSelector withArguments: moreArgs
	]! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'tk 6/30/97 10:52'!
handlesMouseDown: evt

	^ true
! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'!
handlesMouseStillDown: evt
	^actWhen == #whilePressed! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:16'!
mouseDown: evt
	| now dt |
	self state: #pressed.
	actWhen == #buttonDown
		ifTrue:
			[self doButtonAction]
		ifFalse:
			[now _ Time millisecondClockValue.
			super mouseDown: evt.
			"Allow on:send:to: to set the response to events other than actWhen"
			dt _ Time millisecondClockValue - now max: 0.  "Time it took to do"
			dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]].
	self mouseStillDown: evt.! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:18'!
mouseMove: evt
	(self containsPoint: evt cursorPoint)
		ifTrue: [self state: #pressed.
				super mouseMove: evt]
				"Allow on:send:to: to set the response to events other than actWhen"
		ifFalse: [self state: #off].
! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'!
mouseStillDown: evt
	actWhen == #whilePressed ifFalse:[^self].
	(self containsPoint: evt cursorPoint) ifTrue:[self doButtonAction].! !

!ThreePhaseButtonMorph methodsFor: 'event handling' stamp: 'ar 10/25/2000 18:17'!
mouseUp: evt
	"Allow on:send:to: to set the response to events other than actWhen"
	actWhen == #buttonUp ifFalse: [^super mouseUp: evt].

	(self containsPoint: evt cursorPoint) ifTrue: [
		self state: #on.
		self doButtonAction: evt
	] ifFalse: [
		self state: #off.
		target ifNotNil: [target mouseUpBalk: evt]
	].
	"Allow owner to keep it selected for radio buttons"
! !


!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: 'ar 10/11/2000 14:05'!
step
	(self hasProperty: #doesButtonAction) ifTrue:[
		self doButtonAction.
		self setProperty: #didButtonAction toValue: true.
	].! !

!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: 'ar 10/11/2000 14:05'!
stepTime
	(self hasProperty: #doesButtonAction) ifTrue:[^1].
	^super stepTime! !

!ThreePhaseButtonMorph methodsFor: 'stepping' stamp: 'ar 10/11/2000 14:06'!
wantsSteps
	^(self hasProperty: #doesButtonAction) or:[super wantsSteps]! !


!ThreePhaseButtonMorph methodsFor: 'printing' stamp: 'sw 11/11/1998 15:01'!
printOn: aStream

	| string |

	aStream nextPutAll: '3PButton'.
	arguments size > 0 ifTrue: [string _ arguments at: (2 min: arguments size)].
	aStream nextPutAll: '('.
	(string ~~ nil and: [string ~~ self])
		ifTrue:
			[aStream print: string; space]
		ifFalse:
			[aStream print: actionSelector; space].
	aStream print: self identityHash;
			nextPutAll: ')'.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThreePhaseButtonMorph class
	instanceVariableNames: ''!

!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:23'!
checkBox
	"Answer a button pre-initialized with checkbox images."
	| f |
	^self new
		onImage: (f _ ScriptingSystem formAtKey: 'CheckBoxOn');
		pressedImage: (ScriptingSystem formAtKey: 'CheckBoxPressed');
		offImage: (ScriptingSystem formAtKey: 'CheckBoxOff');
		extent: f extent + (2@0);
		yourself
! !

!ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'bf 10/8/1999 15:14'!
radioButton
	"Answer a button pre-initialized with radiobutton images."
	| f |
	^self new
		onImage: (f _ ScriptingSystem formAtKey: 'RadioButtonOn');
		pressedImage: (ScriptingSystem formAtKey: 'RadioButtonPressed');
		offImage: (ScriptingSystem formAtKey: 'RadioButtonOff');
		extent: f extent + (2@0);
		yourself
! !


!ThreePhaseButtonMorph class methodsFor: 'class initialization' stamp: 'ar 5/25/2000 18:01'!
initialize
	"ThreePhaseButtonMorph initialize"
	| extent inset |
	extent _ 12@12.
	inset _ 3.

	#('CheckBoxOff' 'CheckBoxOn' 'CheckBoxPressed') do: [:button |
		| f r |
		f _ ColorForm extent: extent depth: 1.
		f colors: {Color transparent. Color black}.
		f borderWidth: 1.
		r _ f boundingBox insetBy: inset.
		button = 'CheckBoxPressed' ifTrue: [f border: r width: 1].
		button = 'CheckBoxOn' ifTrue: [f fillBlack: r].
		ScriptingSystem saveForm: f atKey: button].

	#('RadioButtonOff' 'RadioButtonOn' 'RadioButtonPressed') do: [:button |
		| f r c |
		f _ ColorForm extent: extent depth: 1.
		f colors: {Color transparent. Color black}.
		r _ f boundingBox.
		c _ f getCanvas.
		c frameOval: r color: Color black.
		r _ r insetBy: inset.
		button = 'RadioButtonPressed' ifTrue:
			[c frameOval: r color: Color black].
		button = 'RadioButtonOn' ifTrue:
			[c fillOval: r color: Color black].
		ScriptingSystem saveForm: f atKey: button]! !
RectangleMorph subclass: #ThumbnailMorph
	instanceVariableNames: 'objectToView viewSelector lastSketchForm lastFormShown drawTime '
	classVariableNames: 'RecursionDepth RecursionMax '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ThumbnailMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 14:57'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
objectToView _ deepCopier references at: objectToView ifAbsent: [objectToView].! !

!ThumbnailMorph methodsFor: 'copying' stamp: 'ar 10/26/2000 23:55'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"objectToView _ objectToView.		Weakly copied"
viewSelector _ viewSelector veryDeepCopyWith: deepCopier.
lastSketchForm _ lastSketchForm veryDeepCopyWith: deepCopier.
lastFormShown _ lastFormShown veryDeepCopyWith: deepCopier.
drawTime _ drawTime veryDeepCopyWith: deepCopier.
! !


!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/10/1999 09:52'!
actualViewee
	"Return the actual morph to be viewed, or nil if there isn't an appropriate morph to view."

	| aMorph actualViewee |
	aMorph _ self morphToView ifNil: [^ nil]. 
	aMorph isInWorld ifFalse: [^ nil].
	actualViewee _ viewSelector ifNil: [aMorph] ifNotNil: [objectToView perform: viewSelector].
	actualViewee == 0 ifTrue: [^ nil].  "valueAtCursor result for an empty HolderMorph"
	actualViewee ifNil: [actualViewee _ objectToView].
	actualViewee isMorph ifFalse: [actualViewee _ actualViewee costume].
	(actualViewee isMorph and: 
		[actualViewee isFlexMorph and: [actualViewee submorphs size = 1]])
			ifTrue: [actualViewee _ actualViewee firstSubmorph].
	^ actualViewee! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 23:44'!
drawMeOn: aCanvas
	"Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside."

	| actualViewee viewedMorphBox myBox scale c shrunkForm aWorld |
	super drawOn: aCanvas.
	((((actualViewee _ self actualViewee) ~~ nil and: [(aWorld _ actualViewee world) ~~ nil])
			and: [aWorld ~~ actualViewee or: [lastFormShown == nil]]) and: [RecursionDepth + 1 < RecursionMax])
		ifTrue:
			[RecursionDepth _ RecursionDepth + 1.
			viewedMorphBox _ actualViewee fullBounds.

			myBox _ self innerBounds.
			scale _ myBox width / (viewedMorphBox width max: viewedMorphBox
		height).
			c _ Display defaultCanvasClass extent: viewedMorphBox extent depth: aCanvas depth.
			c translateBy: viewedMorphBox topLeft negated 
				"recursion happens here"
				during:[:tempCanvas| tempCanvas fullDrawMorph: actualViewee].
			shrunkForm _ c form magnify: c form boundingBox by: scale smoothing: 1.
			lastFormShown _ shrunkForm.
			RecursionDepth _ RecursionDepth - 1]
		ifFalse:  "This branch used if we've recurred, or if the thumbnail views a World that's already been rendered once, or if the referent is not in a world at the moment"
			[lastFormShown ifNotNil: [shrunkForm _ lastFormShown]].


	shrunkForm ifNotNil:
		[aCanvas paintImage: shrunkForm at: self center - shrunkForm boundingBox
center]

	"sw 12/20/1999 13:35 special-case code for SketchMorph commented out, since it seems to have done more harm than good:
 			((actualViewee isKindOf: SketchMorph) and: [false])
				ifTrue:
					[diag _ actualViewee form extent  asInteger.
					viewedMorphBox _
						(actualViewee bounds center - (diag // 2)) extent: diag@diag]
				ifFalse:
					[viewedMorphBox _ actualViewee fullBounds]."! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 23:45'!
drawOn: aCanvas
	"Draw a small view of a morph in another place. Guard against infinite recursion if that morph has a thumbnail of itself inside."
	| time |
	time _ Time millisecondClockValue.
	self drawMeOn: aCanvas.
	drawTime _ Time millisecondClockValue - time.
	drawTime < 0 ifTrue:[drawTime _ nil].
! !

!ThumbnailMorph methodsFor: 'as yet unclassified'!
initialize

	super initialize.
	self extent: 25@25.
	self color: (Color r: 0.781 g: 0.781 b: 0.781).
	self borderWidth: 1.
! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/7/1999 22:55'!
installAsWonderlandTextureOn: anActor
	"Make the receiver a texture for the given actor"
	self morphRepresented installAsWonderlandTextureOn: anActor! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/26/2000 13:50'!
morphToView
	"If the receiver is viewing some object, answer a morph can be thought of as being viewed;  A gesture is made toward generalizing this beyond the morph/player regime, in that a plain blue rectangle is returned rather than simply failing if the referent is not itself displayable."

	objectToView ifNil: [^ nil].
	^ objectToView isMorph
		ifTrue:
			[objectToView]
		ifFalse:
			[(objectToView isKindOf: Player)
				ifTrue:
					[objectToView costume]
				ifFalse:
					[RectangleMorph new color: Color blue]]
! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/9/2000 18:35'!
objectToView: objectOrNil
	(objectOrNil isMorph and: [objectOrNil allMorphs includes: self]) ifTrue:
		["cannot view a morph containing myself or drawOn: goes into infinite recursion"
		objectToView _ nil.
		^ self].
	objectToView _ objectOrNil! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/9/2000 18:35'!
objectToView: objectOrNil viewSelector: aSelector
	self objectToView: objectOrNil.
	viewSelector _ aSelector! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'jm 2/27/98 16:49'!
step
	"Optimization: Don't redraw if we're viewing some kind of SketchMorph and its rotated Form hasn't changed."

	| viewee f |
	viewee _ self actualViewee.
	(viewee isKindOf: SketchMorph) ifTrue: [
		f _ viewee rotatedForm.
		f == lastSketchForm ifTrue: [^ self].
		lastSketchForm _ f].
	self changed.
! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/26/2000 23:53'!
stepTime 
	"Adjust my step time to the time it takes drawing my referent"
	drawTime ifNil:[^ 250].
	^(20*drawTime) max: 250.! !

!ThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/15/1998 15:18'!
tearOffTile
	(objectToView isKindOf: Player) ifTrue: [^ objectToView tearOffTileForSelf].

	objectToView ifNil: [^ nil].
	^ objectToView isMorph
		ifTrue:
			[objectToView]
		ifFalse:
			[objectToView costume]
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ThumbnailMorph class
	instanceVariableNames: ''!

!ThumbnailMorph class methodsFor: 'as yet unclassified' stamp: 'tk 9/8/97
08:30'!
initialize
	RecursionMax _ 2.
	RecursionDepth _ 0.! !

!ThumbnailMorph class methodsFor: 'as yet unclassified' stamp: 'sw 5/3/1998 19:12'!
recursionReset
	"ThumbnailMorph recursionReset"
	"Reset the RecursionDepth counter in case the user interrupted
during a thumbnail being drawn.  Do this just once in a while when no
drawOn: is being called.  tk 9/8/97"

	RecursionDepth _ 0.! !
AlignmentMorph subclass: #TileLikeMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!TileLikeMorph methodsFor: 'testing' stamp: 'ar 10/7/2000 16:50'!
isTileLike
	^true! !


!TileLikeMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/7/2000 16:52'!
aboutToBeGrabbedBy: aHand
	| editor |
	editor _ self topEditor.
	editor ifNotNil:[editor scriptEdited].
	^super aboutToBeGrabbedBy: aHand! !
MessageNode subclass: #TileMessageNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Tile Scriptors'!

!TileMessageNode methodsFor: 'trickery' stamp: 'RAA 6/9/2000 18:25'!
printIfNilNotNil: aMorph indent: level

	| newNode |
	newNode _ aMorph parseNode clone.
	newNode receiver ifNotNil:
		[newNode receiver: newNode receiver ifNilReceiver].	"fudge so it prints right"

	(arguments first isJust: NodeNil) ifTrue:
		[^ newNode morphFromKeywords: #ifNotNil:
				arguments: { arguments second }
				on: aMorph indent: level].
	(arguments second isJust: NodeNil) ifTrue:
		[^ newNode morphFromKeywords: #ifNil:
				arguments: { arguments first }
				on: aMorph indent: level].
	^ newNode morphFromKeywords: #ifNil:ifNotNil:
			arguments: arguments
			on: aMorph indent: level! !

!TileMessageNode methodsFor: 'trickery' stamp: 'BJP 6/9/2000 12:37'!
printIfOn: aStream indent: level 
"Just copied the old MessageNode one down here."
	(arguments last isJust: NodeNil)
		ifTrue: [^ self
				printKeywords: #ifTrue:
				arguments: (Array with: arguments first)
				on: aStream
				indent: level].
	(arguments last isJust: NodeFalse)
		ifTrue: [^ self
				printKeywords: #and:
				arguments: (Array with: arguments first)
				on: aStream
				indent: level].
	(arguments first isJust: NodeNil)
		ifTrue: [^ self
				printKeywords: #ifFalse:
				arguments: (Array with: arguments last)
				on: aStream
				indent: level].
	(arguments first isJust: NodeTrue)
		ifTrue: [^ self
				printKeywords: #or:
				arguments: (Array with: arguments last)
				on: aStream
				indent: level].
	self
		printKeywords: #ifTrue:ifFalse:
		arguments: arguments
		on: aStream
		indent: level! !

!TileMessageNode methodsFor: 'trickery' stamp: 'RAA 8/15/1999 16:23'!
printKeywords: key arguments: args on: morph indent: level

	^morph parseNode
		morphFromKeywords: key 
		arguments: args 
		on: morph 
		indent: level
! !

!TileMessageNode methodsFor: 'trickery' stamp: 'RAA 6/9/2000 15:32'!
printReceiver: rcvr on: aMorph indent: level
					
	"I don't think we need this to do anything since we already printed the receiver ourself"
! !

!TileMessageNode methodsFor: 'trickery' stamp: 'RAA 6/9/2000 16:50'!
printToDoOn: aMorph indent: level

	| limitNode |
	
	limitNode _ (arguments last == nil or: [(arguments last isMemberOf: AssignmentNode) not])
		ifTrue: [arguments first]
		ifFalse: [arguments last value].
	(selector key = #to:by:do:
			and: [(arguments at: 2) isConstantNumber
				and: [(arguments at: 2) key = 1]])
		ifTrue: [self printKeywords: #to:do:
					arguments: (Array with: limitNode with: (arguments at: 3))
					on: aMorph indent: level]
		ifFalse: [self printKeywords: selector key
					arguments: (Array with: limitNode) , arguments allButFirst
					on: aMorph indent: level]! !

!TileMessageNode methodsFor: 'trickery' stamp: 'RAA 6/9/2000 17:15'!
printWhileOn: aMorph indent: level

	(arguments first isJust: NodeNil) ifTrue: [
		selector _ SelectorNode new
			key: (selector key == #whileTrue:
				ifTrue: [#whileTrue] ifFalse: [#whileFalse])
			code: #macro.
		arguments _ Array new
	].
	self printKeywords: selector key arguments: arguments
		on: aMorph indent: level! !
RectangleMorph subclass: #TileMorph
	instanceVariableNames: 'type slotName literal operatorOrExpression actualObject downArrow upArrow suffixArrow typeColor lastArrowTick nArrowTicks operatorReadoutString possessive retractArrow '
	classVariableNames: 'DownPicture RetractPicture SuffixArrowAllowance SuffixPicture UpArrowAllowance UpPicture UpdatingOperators '
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!TileMorph commentStamp: '<historical>' prior: 0!
A tile with up, down and suffix arrows.

To install new Forms for the arrows, just nil out UpPicture, DownPicture,
or SuffixPicture.
Create actors with the picture you want and write it out with these file names:
'tile inc arrow.morph' 'tile dec arrow.morph' 'tile suffix
arrow.morph'.  Make sure that file is in the same directory as the image.
Open an EToy.!


!TileMorph methodsFor: 'misc' stamp: 'sw 9/17/1999 08:00'!
basicWidth
	"Provide a nominal minimum, exclusive of arrows and independent of label width"

	^ operatorOrExpression
		ifNotNil:
			[3]
		ifNil:
			[18]! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/10/1998 08:33'!
colorChangedForSubmorph: aSubmorph
	"Invoked when the user selects a new color on a colorTile or a color-seer-tile; need to recompile the script."
	self acceptNewLiteral! !

!TileMorph methodsFor: 'misc' stamp: 'sw 11/3/97 01:11'!
copyRecordingIn: aDict
	| new |
	new _ super copyRecordingIn: aDict.
	downArrow ifNotNil:
		[new downArrow: 
			((aDict includesKey: downArrow)
				ifTrue: [aDict at: downArrow]
				ifFalse: [downArrow copyRecordingIn: aDict])].

	upArrow ifNotNil:
		[new upArrow: 
			((aDict includesKey: upArrow)
				ifTrue: [aDict at: upArrow]
				ifFalse: [upArrow copyRecordingIn: aDict])].

	suffixArrow ifNotNil:
		[new suffixArrow: 
			((aDict includesKey: suffixArrow)
				ifTrue: [aDict at: suffixArrow]
				ifFalse: [suffixArrow copyRecordingIn: aDict])].
	"actualObject gets fixed by a different mechanism.  The commented-out code below caused big difficulties when a script was being copied for use in the same actor"
"	actualObject ifNotNil:
		[new actualObject: 
			((aDict includesKey: actualObject)
				ifTrue: [aDict at: actualObject]
				ifFalse: [actualObject copyRecordingIn: aDict])]."

	^ new
! !

!TileMorph methodsFor: 'misc' stamp: 'tk 10/1/97 18:24'!
isTileLike
	"Can be dropped into a script"
	^ true! !

!TileMorph methodsFor: 'misc' stamp: 'sw 4/21/1998 21:34'!
isTileScriptingElement
	^ true! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/17/1999 08:02'!
minimumWidth
	| aWidth |
	aWidth _ self basicWidth.
	upArrow ifNotNil: [aWidth _ aWidth + UpArrowAllowance].
	suffixArrow ifNotNil: [aWidth _ aWidth + SuffixArrowAllowance].
	^ aWidth
	! !

!TileMorph methodsFor: 'misc' stamp: 'sw 1/29/98 00:45'!
numericValue
	literal isNumber ifFalse: [^ 0].
	^ literal! !

!TileMorph methodsFor: 'misc' stamp: 'sw 4/28/1998 00:14'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' - ', type printString.
	operatorOrExpression ifNotNil: [aStream nextPutAll: ' op= ', operatorOrExpression printString].
	slotName ifNotNil: [aStream nextPutAll: ' op= ', slotName printString].! !

!TileMorph methodsFor: 'misc' stamp: 'sw 1/21/98 17:44'!
restoreTypeColor
	self borderColor: Color black.
	typeColor ifNotNil: [self color: typeColor]! !

!TileMorph methodsFor: 'misc' stamp: 'sw 5/25/2000 15:52'!
scriptPerformer
	"Guard against obscure circumstance in which the tile itself has an associated Player, which then might be asked to interact in inappropriate ways with, for example, an UpdatingStringMorph to provide the literal for a RandomNumberTile.  This is at best a finger in the dike.  Still very unsatisfactory!!"
	^ self! !

!TileMorph methodsFor: 'misc' stamp: 'sw 9/15/2000 06:00'!
setLiteralInitially: anObject
	"Establish the initial literal.  Get the label correct, but do *not* send the value back to the target via the setter (unlike #literal:)"

	literal _ anObject.
	self updateLiteralLabel! !

!TileMorph methodsFor: 'misc' stamp: 'sw 4/3/98 23:36'!
typeColor: aColor
	borderColor _ aColor.
	typeColor _ aColor.
	color _ typeColor! !

!TileMorph methodsFor: 'misc' stamp: 'sw 5/2/1998 15:01'!
useUniformTileColor
	self color: ScriptingSystem uniformTileInteriorColor! !

!TileMorph methodsFor: 'misc' stamp: 'sw 11/5/97 12:18'!
wantsKeyboardFocusFor: aSubmorph
	^ type == #literal ! !


!TileMorph methodsFor: 'initialization' stamp: 'sw 10/3/97 18:00'!
actualObject
	^ actualObject! !

!TileMorph methodsFor: 'initialization' stamp: 'di 8/11/1998 22:13'!
bePossessive
	possessive _ true.
	self line1: actualObject externalName, '''s'! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 1/14/2001 00:47'!
bringUpToDate
	"Make certain, if the receiver is an object-reference tile, that it shows the current external name of the object, which may just have changed.  This only applies to the Player regime." 

	| newLabel |
		(type == #objRef and: [actualObject isKindOf: Player]) ifTrue:
		[newLabel _ actualObject externalName.
		self isPossessive ifTrue:
			[newLabel _ newLabel, '''s'].
		self line1: newLabel]! !

!TileMorph methodsFor: 'initialization' stamp: 'ar 11/8/2000 23:45'!
initialize

	super initialize.
	self extent: 1@1.
	self typeColor: (Color r: 0.8 g: 1.0 b: 0.6).
	self borderWidth: 1.
	type _ #literal.  "#literal, #slotRef, #objRef, #operator, #expression"
	slotName _ ''.
	literal _ 1.

	self layoutPolicy: TableLayout new.
	self cellInset: 2@0.
	self layoutInset: 1@0.
	self listDirection: #leftToRight.
	self wrapCentering: #center.
	self hResizing: #shrinkWrap.
	self vResizing: #spaceFill.
! !

!TileMorph methodsFor: 'initialization' stamp: 'di 8/11/1998 22:13'!
isPossessive
	possessive == nil ifTrue: [^ false].
	^ possessive! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/28/2000 12:27'!
referTo: anObject
	"Make the receiver be an object-reference tile whose referent is anObject"

	type _ #objRef.
	typeColor _ ScriptingSystem colorForType: anObject basicType.
	actualObject _ anObject.
	self line1: anObject uniqueNameForReference! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 10/30/2000 08:58'!
retargetFrom: oldPlayer to: newPlayer
	"Change the receiver so that if formerly it referred to oldPlayer, it refers to newPlayer instead"

	| newLabel |
	(type == #objRef  and: [actualObject == oldPlayer]) ifTrue:
		[actualObject _ newPlayer.
		[newLabel _ actualObject externalName.
		self isPossessive ifTrue:
			[newLabel _ newLabel, '''s'].
		self line1: newLabel]]! !

!TileMorph methodsFor: 'initialization'!
setExpression: exprString label: labelString

	type _ #expression.
	operatorOrExpression _ exprString.
	self line1: labelString.
! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 10/11/2000 04:15'!
setLiteral: anObject
	"Set the receiver's literal to be anObject.  Create a readout morph and add it to the receiver, deleting any existing one that may be there."

	| m already |
	already _ submorphs detect: [:aSubMorph  | aSubMorph isKindOf: UpdatingStringMorph] ifNone: [nil].
	already ifNotNil: [already delete].
	type _ #literal.
	m _ UpdatingStringMorph contents: ' ' font: ScriptingSystem fontForTiles.
	m target: self; getSelector: #literal; putSelector: #literal:.
	(anObject isKindOf: String orOf: Text) ifTrue: [m useStringFormat].
	self addMorphBack: m.
	self setLiteralInitially: anObject.
! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 10/30/2000 16:54'!
setObjectRef: aString actualObject: anObject
	"Set the receiver to bear an object reference to the given object.  aString is historical and no longer used"

	type _ #objRef.
	actualObject _ anObject.
	self line1: anObject nameForViewer
! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 12/30/1998 14:12'!
setOperator: aString

	type _ #operator.
	operatorOrExpression _ aString asSymbol.
 	self line1: (ScriptingSystem wordingForOperator: aString).
	(ScriptingSystem doesOperatorWantArrows: operatorOrExpression)
		ifTrue: [self addArrows; updateLiteralLabel].

	"operatorOrExpression == #heading ifTrue: [self halt]."! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/21/2000 23:04'!
setOperatorAndUseArrows: aString
	"Set the operator as per aString, and add up/down arrows"

	type _ #operator.
	operatorOrExpression _ aString asSymbol.
 	self line1: (ScriptingSystem wordingForOperator: aString).
	self addArrows; updateLiteralLabel.
	submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: operatorOrExpression)! !

!TileMorph methodsFor: 'initialization' stamp: 'sw 9/8/2000 11:10'!
setSlotRefOperator: aString
	"aString represents the name of a slot that the receiver is to represent; configure the receiver to serve thi duty, and set upthe wording on the tile appropriately"

	type _ #operator.
	operatorOrExpression _ ScriptingSystem getterSelectorFor: aString.
	operatorReadoutString _ aString.
 	self line1: aString! !


!TileMorph methodsFor: 'accessing' stamp: 'ar 9/15/2000 23:31'!
abandonLabelFocus
	"If the receiver's label has editing focus, abandon it"
	self flag: #arNote. "Probably unnecessary"
	self currentHand releaseKeyboardFocus: self labelMorph.! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/6/1998 11:02'!
associatedPlayer
	^ actualObject! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/1/97 01:48'!
downArrow: a
	downArrow _ a! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 4/27/1998 16:10'!
labelMorph
	^ submorphs detect: [:m | m isKindOf: StringMorph] ifNone: [nil].! !

!TileMorph methodsFor: 'accessing' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self! !

!TileMorph methodsFor: 'accessing'!
literal

	^ literal
! !

!TileMorph methodsFor: 'accessing' stamp: 'di 9/18/97 12:02'!
literal: anObject

	literal _ anObject.
	self updateLiteralLabel.
	self acceptNewLiteral.		"Show that we are out of date, install is needed"
! !

!TileMorph methodsFor: 'accessing'!
operatorOrExpression

	^ operatorOrExpression
! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 10/21/1998 15:55'!
playerBearingCode
	"Answer the actual Player object who will be the 'self' when the receiver is being asked to generate code"
	| anEditor |
	(anEditor _ self topEditor) ifNotNil: [^ anEditor playerScripted].
	^ (self nearestOwnerThat: [:m | m isAViewer]) scriptedPlayer! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 7/4/1998 18:01'!
resultType

	type == #literal ifTrue:
		[(literal isKindOf: Number) ifTrue: [^ #number].
		(literal isKindOf: String) ifTrue: [^ #string].
		(literal isKindOf: Point) ifTrue: [^ #point].
		(literal isKindOf: String) ifTrue: [^ #string].
		(literal isKindOf: Boolean) ifTrue: [^ #boolean].
		(literal isKindOf: Morph) ifTrue: [^ #costume]  "This last one dubious!!"].

	type == #expression ifTrue:
		[^ #number].

	type == #objRef ifTrue: [^ #player].
	^ #unknown
! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/9/1998 14:18'!
slotName
	"Caution: the slotName is not in use!!"
	^ slotName
! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/1/97 01:48'!
suffixArrow: a
	suffixArrow _ a! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 10/18/97 18:03'!
topEditor

	^ self outermostMorphThat: [:m | 
		(m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]].
! !

!TileMorph methodsFor: 'accessing'!
type

	^ type
! !

!TileMorph methodsFor: 'accessing' stamp: 'sw 11/1/97 01:48'!
upArrow: a
	upArrow _ a! !


!TileMorph methodsFor: 'mouse handling' stamp: 'ar 9/18/2000 18:03'!
handlerForMouseDown: anEvent
	"Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event"
	| aPoint |
	upArrow ifNotNil:
		[(upArrow bounds containsPoint: (aPoint _ anEvent cursorPoint))
			ifTrue: [^self].
		(downArrow bounds containsPoint: aPoint)
			ifTrue: [^self]].

	^super handlerForMouseDown: anEvent! !

!TileMorph methodsFor: 'mouse handling' stamp: 'ar 10/3/2000 14:56'!
handlesMouseDown: evt
	"Answer whether the receiver would handle the mouseDown represented by evt"

	| aPoint |
	aPoint _ evt cursorPoint.
	(operatorOrExpression notNil and: [upArrow notNil]) ifTrue: [^ true].
		"Click on the operator presents list of alternatives"

	upArrow ifNotNil: [((upArrow bounds containsPoint: aPoint) or: [downArrow bounds containsPoint: aPoint])
		ifTrue: [^ true]].
	suffixArrow ifNotNil: [(suffixArrow bounds containsPoint: aPoint)
		ifTrue: [^ true]].
	retractArrow ifNotNil: [(retractArrow bounds containsPoint: aPoint)
		ifTrue: [^ true]].
	^ super handlesMouseDown: evt! !

!TileMorph methodsFor: 'mouse handling' stamp: 'ar 10/22/2000 17:42'!
handlesMouseStillDown: evt
	^true! !

!TileMorph methodsFor: 'mouse handling' stamp: 'sw 7/30/1999 13:08'!
isCandidateForAutomaticViewing
	^ false! !

!TileMorph methodsFor: 'mouse handling' stamp: 'ar 10/25/2000 18:38'!
mouseDown: evt
	"The mouse went down on the receiver; take appropriate action"

	| aPoint |
	"Note: evt is in local coordinates, so bounds is better than boundsInWorld"

	aPoint _ evt cursorPoint.
	nArrowTicks _ 0.
	upArrow ifNotNil:
		[(upArrow bounds containsPoint: aPoint) ifTrue: [^ self mouseStillDown: evt].
		(downArrow bounds containsPoint: aPoint) ifTrue: [^ self mouseStillDown: evt].
		"next line maybe outside this block & below it"
		operatorOrExpression ifNotNil: [^ self presentOperatorAlternatives: evt]].
	
	suffixArrow ifNotNil:
		[(suffixArrow bounds containsPoint: aPoint)
			 ifTrue: [self showSuffixChoices.  ^ self]].
	retractArrow ifNotNil:
		[(retractArrow bounds containsPoint: aPoint)
			 ifTrue: [self deleteLastTwoTiles.  ^ self]].
	^ super mouseDown: evt! !

!TileMorph methodsFor: 'mouse handling' stamp: 'ar 10/22/2000 17:43'!
mouseStillDown: evt
	| aPoint label |
	"See if arrows are being pressed and call arrowAction:..."
	self flag: #arNote. "Fix 'significant' events below"
	upArrow ifNotNil:
		[aPoint _ evt cursorPoint.
		(label _ self labelMorph) ifNotNil:
			[label step. literal _ label valueFromContents].
		(upArrow containsPoint: aPoint) ifTrue:
			[self abandonLabelFocus.
			self variableDelay:
				[self arrowAction: 1].
			^ evt "hand noteSignificantEvent: evt"].
		(downArrow containsPoint: aPoint) ifTrue:
			[self abandonLabelFocus.
			self variableDelay:
				[self arrowAction: -1].
			^ evt "hand noteSignificantEvent: evt"]].

	super mouseStillDown: evt.
! !

!TileMorph methodsFor: 'mouse handling' stamp: 'sw 11/22/2000 10:50'!
presentOperatorAlternatives: evt
	"The receiver is a tile that represents an operator; a click on the receiver's label will pop up a menu of alternative operator choices"

	| result ops |

	((ops _ ScriptingSystem arithmeticalOperatorsAndHelpStrings first) includes: operatorOrExpression) ifFalse:
		[((ops _ ScriptingSystem numericComparitorsAndHelpStrings first) includes: operatorOrExpression)
			ifFalse: [^ self]].
		
	(result _ (SelectionMenu selections: ops) startUp) ifNotNil:
		[self setOperatorAndUseArrows: result asString.
		self scriptEdited]! !


!TileMorph methodsFor: 'arrows' stamp: 'ar 11/2/2000 22:29'!
addArrows
	| frame |
	downArrow _ ImageMorph new image: DownPicture.
	upArrow _ ImageMorph new image: UpPicture.
	frame _ Morph new color: Color transparent.
	frame 
		layoutPolicy: TableLayout new;
		listDirection: #topToBottom;
		hResizing: #shrinkWrap; 
		vResizing: #shrinkWrap;
		cellInset: 0@1;
		layoutInset: 0@1.
	frame addMorphBack: upArrow; addMorphBack: downArrow.
	self addMorphFront: frame.
! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/16/2000 09:48'!
addRetractArrow
	"Must be situated in a script"

	self couldRetract ifNil: [^ self].
	retractArrow _ ImageMorph new image: RetractPicture.
	suffixArrow ifNotNil: [
		self addMorph: retractArrow inFrontOf: suffixArrow].
	fullBounds _ nil.
	self extent: self fullBounds extent! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 11/2/2000 22:30'!
addSuffixArrow

	suffixArrow _ ImageMorph new image: SuffixPicture.
	self addMorphBack: suffixArrow.! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 10/12/97 15:05'!
addSuffixIfCan
	"Should this tile have a suffix arrow?"

	self addSuffixArrow.! !

!TileMorph methodsFor: 'arrows' stamp: 'sw 9/21/2000 22:40'!
arrowAction: delta
	"Do what is appropriate when an arrow on the tile is pressed; delta will be +1 or -1"

	| index aList |
	owner ifNil: [^ self].
	(type == #literal and: [literal isNumber])
		ifTrue:
			[self literal: literal + delta. ^ self layoutChanged.].

	(type == #literal and: [literal isKindOf: Boolean])
		ifTrue: [self literal: literal not.  ^ self layoutChanged].

	operatorOrExpression ifNotNil:
		[aList _ #(+ - * / // \\ min: max:).
		index _ aList indexOf: operatorOrExpression.
		index  > 0 ifTrue:
			[self setOperatorAndUseArrows: (aList atWrap: index + delta)].

		aList _ #(< <= = ~= > >= isDivisibleBy:).
		index _ aList indexOf: operatorOrExpression.
		index  > 0 ifTrue:
			[owner firstSubmorph type = #number 
				ifTrue: [self setOperator: (aList atWrap: index + delta)]
				ifFalse: [self setOperator: (#(= ~=) atWrap: index - 2 + delta)]].
						"Color does not understand <"
			submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: operatorOrExpression).
			^ self acceptNewLiteral]
	! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/16/2000 08:59'!
couldRetract
	"See if it makes sense to retract this tile and the op before it.  Return the phrase that gets retracted, or nil if not allowed."
	| phrase pad |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
	(pad _ phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
	(phrase firstSubmorph "goodPad") type == pad type ifFalse: [
		phrase submorphs size < 3 ifFalse: [^ nil].	"types should have matched"
		"Go up a level"
		(phrase _ pad ownerThatIsA: PhraseTileMorph) ifNil: [^ nil].
		(pad _ phrase ownerThatIsA: TilePadMorph) ifNil: [^ nil].
		(phrase firstSubmorph "goodPad") type == pad type ifFalse: [^ nil].
		].
	^ phrase
! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 9/24/2000 19:11'!
deleteLastTwoTiles
	"Remove the current suffix (last two tiles) in this line of tiles"
	| phrase pad goodPad |
	(phrase _ self couldRetract) ifNil: [^ self].
	pad _ phrase ownerThatIsA: TilePadMorph.
	goodPad _ phrase firstSubmorph.
	pad owner addMorphBack: goodPad.
	pad delete.
	(goodPad lastSubmorph respondsTo: #addSuffixArrow) 
		ifTrue: [goodPad lastSubmorph addSuffixArrow; addRetractArrow]
		ifFalse: [goodPad lastSubmorph lastSubmorph addSuffixArrow; addRetractArrow].
	goodPad topEditor install. "recompile"! !

!TileMorph methodsFor: 'arrows' stamp: 'tk 8/10/2000 14:34'!
deleteSuffixArrow

	suffixArrow delete.
	suffixArrow _ nil.
	retractArrow ifNotNil: ["backward compat"
		retractArrow delete.
		retractArrow _ nil].
	self updateLiteralLabel! !

!TileMorph methodsFor: 'arrows' stamp: 'ar 9/24/2000 19:10'!
showSuffixChoices
	"The suffix arrow has been hit, so respond appropriately"

	| plusPhrase phrase pad outer num |
	(phrase _ self ownerThatIsA: PhraseTileMorph) ifNil: [^ self].

	(type == #literal) & (literal isNumber) ifTrue: ["Tile is a constant number"
		phrase lastSubmorph == owner "pad"
			ifTrue: ["we are adding the first time (at end of our phrase)"
				plusPhrase _ self presenter phraseForReceiver: literal 
						op: #+ arg: 1 resultType: #number.
				plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
				owner acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
				num _ plusPhrase firstSubmorph firstSubmorph.
				num deleteSuffixArrow]].

	type == #operator ifTrue: ["Tile is accessor of an expression"
		phrase resultType == #number ifTrue:
			[outer _ phrase ownerThatIsA: PhraseTileMorph.
			pad _ self ownerThatIsA: TilePadMorph.
			outer ifNotNil:
				[outer lastSubmorph == pad ifTrue: [ "first time"
					plusPhrase _ self presenter phraseForReceiver: 1 
							op: #+ arg: 1 resultType: #number.
					plusPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: #+).
					pad acceptDroppingMorph: plusPhrase event: self primaryHand lastEvent.
					plusPhrase firstSubmorph removeAllMorphs; addMorph: phrase.	"car's heading"
					self deleteSuffixArrow.
					pad topEditor install "recompile"]]]].

	(phrase topEditor ifNil: [phrase]) enforceTileColorPolicy! !

!TileMorph methodsFor: 'arrows' stamp: 'di 3/15/1999 00:22'!
variableDelay: aBlock

	| now delay dt |
	nArrowTicks ifNil: [nArrowTicks _ 1].
	now _ Time millisecondClockValue.
	aBlock value.
	delay _ nArrowTicks > 5 ifTrue: [100] ifFalse: [300].
	nArrowTicks _ nArrowTicks + 1.
	dt _ Time millisecondClockValue - now max: 0.  "Time it took to do."
	dt < delay ifTrue: [(Delay forMilliseconds: delay - dt) wait].
! !


!TileMorph methodsFor: 'code generation' stamp: 'sw 2/12/98 13:23'!
acceptNewLiteral
	"Tell the scriptEditor who I belong to that I have a new literal value."
	| topScript |
	topScript _ self outermostMorphThat:
		[:m | m isKindOf: ScriptEditorMorph].
	topScript ifNotNil: [topScript installWithNewLiteral]! !

!TileMorph methodsFor: 'code generation' stamp: 'sw 9/2/1999 15:01'!
codeString
	^ String streamContents: [:aStream | self storeCodeOn: aStream indent: 1]
! !

!TileMorph methodsFor: 'code generation'!
precedingTileType
	"Return the slot reference type of the preceding TileMorph in my owner."

	| row i tile |
	row _ owner submorphs.
	i _ row indexOf: self.
	((i > 1) and: [(tile _ row at: i - 1) isKindOf: TileMorph])
		ifTrue: [^ tile type]
		ifFalse: [^ #unknown].
! !

!TileMorph methodsFor: 'code generation' stamp: 'sw 9/26/97 10:51'!
scriptEdited
	"Tell the scriptEditor who I belong to that I have changed.  "
	| him |
	(him _ self outermostMorphThat: [:m| m isKindOf: ScriptEditorMorph])
		ifNotNil: [him scriptEdited]! !

!TileMorph methodsFor: 'code generation' stamp: 'sw 10/30/2000 16:57'!
storeCodeOn: aStream indent: tabCount
	"Store code representing the receiver onto the stream, with the given amount of indentation"

	| op playerBearingCode |
	playerBearingCode _ self playerBearingCode.  "Must determine whom is scripted for what follows to work; if it's ever nil, we've got trouble"
	type = #expression ifTrue:
		[^ aStream
			nextPut: $(;
			nextPutAll: operatorOrExpression;
			nextPut: $)].

	type = #literal ifTrue:
		[^ aStream
			nextPut: $(;
			nextPutAll: literal printString;
			nextPut: $)].

	type == #objRef ifTrue:
		[^ (playerBearingCode == actualObject)
			ifTrue:
				["If the object is the method's own 'self' then we MUST, rather than just MAY, put out 'self' rather than the referencer call, though the latter will temporarily work if only one instance of the uniclass exists."
				aStream nextPutAll: 'self']
			ifFalse:
				[Preferences capitalizedReferences "Global dictionary References"
					ifTrue:
						[self flag: #deferred.  "Start deploying the meesage-receiver hints soon"
						aStream nextPutAll: actualObject uniqueNameForReference]

					ifFalse:
						"old class-inst-var-based scheme used  Feb 1998 to Oct 2000, and indeed
						ongoing in school year 2000-01 at the open school"
						[aStream nextPutAll: 'self class '.
						aStream nextPutAll: (playerBearingCode class referenceSelectorFor: actualObject)]]].

	type = #operator ifTrue:
		[((UpdatingOperators includesKey: operatorOrExpression) and:
		 [self precedingTileType = #slotRef])
			ifTrue: [op _ UpdatingOperators at: operatorOrExpression]
			ifFalse: [op _ operatorOrExpression].
		^ op isEmpty
			ifTrue: [aStream position: aStream position - 1]
			ifFalse: [aStream nextPutAll: op]].

"The following branch has long been disused
	type = #slotRef ifTrue:
		[self isThisEverCalled.
		refType _ self slotRefType.
		refType = #get ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: (Utilities getterSelectorFor: slotName)].
		refType = #set ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: (Utilities setterSelectorFor: slotName);
				nextPut: $:].
		refType = #update ifTrue:
			[^ aStream
				nextPutAll: targetName;
				space;
				nextPutAll: slotName;
				nextPutAll: ': ';
				nextPutAll: targetName;
				space;
				nextPutAll: slotName]]"
! !


!TileMorph methodsFor: 'private' stamp: 'ar 11/2/2000 19:21'!
convertAlignment
	"Convert the receiver's alignment rules"
	| where frame |
	owner ifNotNil:[
		owner class == TilePadMorph ifTrue:[
			owner layoutPolicy: TableLayout new.
			owner hResizing: #shrinkWrap.
			owner vResizing: #spaceFill.
		].
	].
	self layoutPolicy: TableLayout new.
	self cellInset: 2@0.
	self layoutInset: 1@0.
	self listDirection: #leftToRight.
	self wrapCentering: #center.
	self hResizing: #shrinkWrap.
	self vResizing: #spaceFill.
	"Now convert up and down arrow"
	(upArrow notNil and:[upArrow owner == self "e.g., not converted"
		and:[downArrow notNil and:[downArrow owner == self]]]) ifTrue:[
			"where to insert the frame"
			where _ (submorphs indexOf: upArrow) min: (submorphs indexOf: downArrow).
			frame _ Morph new color: Color transparent.
			frame 
				layoutPolicy: TableLayout new;
				listDirection: #topToBottom;
				hResizing: #shrinkWrap; 
				vResizing: #shrinkWrap;
				cellInset: 0@1;
				layoutInset: 0@1.
			self privateAddMorph: frame atIndex: where.
			frame addMorphBack: upArrow; addMorphBack: downArrow.
		].
! !

!TileMorph methodsFor: 'private' stamp: 'sw 10/30/2000 09:00'!
line1: line1
	"Emblazon the receiver with the requested label.  If the receiver already has a label, make the new label be of the same class"

	| m desiredW classToUse lab |
	classToUse _ (lab _ self labelMorph) ifNotNil: [lab class] ifNil: [StringMorph].
	self removeAllMorphs.
	m _ classToUse contents: line1 font: ScriptingSystem fontForTiles.
	desiredW _ m width + 6.
	self extent: (desiredW max: self minimumWidth) @ self class defaultH.
	m position: self center - (m extent // 2).
	self addMorph: m.
! !

!TileMorph methodsFor: 'private' stamp: 'sw 5/2/1998 15:01'!
line1: line1 line2: line2

	| m1 m2 desiredW |
	self removeAllMorphs.
	m1 _ StringMorph contents: line1 font: ScriptingSystem fontForTiles.
	m2 _ StringMorph contents: line2 font: ScriptingSystem fontForTiles.
	desiredW _ (m1 width max: m2 width) + 6.
	self extent: (desiredW max: self minimumWidth) @ self class defaultH.
	m1 position: (bounds center x - (m1 width // 2) + 1)@(bounds top + 1).
	m2 position: (bounds center x - (m2 width // 2) + 1)@(m1 bottom - 2).
	self addMorph: m1; addMorph: m2.
! !

!TileMorph methodsFor: 'private' stamp: 'ar 11/8/2000 23:46'!
ownerChanged
	super ownerChanged.
	(owner class == TilePadMorph and:[owner layoutPolicy isNil]) ifTrue:[
		owner layoutPolicy: TableLayout new.
		owner hResizing: #shrinkWrap.
		owner vResizing: #spaceFill.
	].! !

!TileMorph methodsFor: 'private' stamp: 'tk 8/14/2000 13:32'!
test
	| pos hh |
	"Set the position of all my submorphs.  Compute my bounds.  Caller must call layoutChanged or set fullBounds to nil."

	fullBounds ifNil: [
		pos _ self topLeft.
		self submorphsDo: [:sub | 
			hh _ (self class defaultH - sub height) // 2.	"center in Y"
			sub privateBounds: (pos + (2@hh) extent: sub extent).
			pos x: (sub right min: 1200)].	"2 pixels spacing on left"
		bounds _ bounds topLeft corner: pos + (2 @ self class defaultH).
		fullBounds _ bounds.
		].
	owner class == TilePadMorph ifTrue: [owner bounds: bounds].
	^ fullBounds! !

!TileMorph methodsFor: 'private' stamp: 'tk 8/14/2000 23:14'!
updateLiteralLabel

	| myLabel |
	(myLabel _ self labelMorph) ifNil: [^ self].

	myLabel acceptValue:
		(type == #literal
			ifTrue:
				[literal] 
			ifFalse: [operatorReadoutString 
				ifNil:		[ScriptingSystem wordingForOperator: operatorOrExpression]
				ifNotNil:  	[operatorReadoutString]]).
	self changed.! !



!TileMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:15'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
actualObject _ deepCopier references at: actualObject ifAbsent: [actualObject].! !

!TileMorph methodsFor: 'copying' stamp: 'tk 8/10/2000 14:29'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
type _ type veryDeepCopyWith: deepCopier.
slotName _ slotName veryDeepCopyWith: deepCopier.
literal _ literal veryDeepCopyWith: deepCopier.
operatorOrExpression _ operatorOrExpression veryDeepCopyWith: deepCopier.
"actualObject _ actualObject.		Weakly copied"
downArrow _ downArrow veryDeepCopyWith: deepCopier.
upArrow _ upArrow veryDeepCopyWith: deepCopier.
suffixArrow _ suffixArrow veryDeepCopyWith: deepCopier.
typeColor _ typeColor veryDeepCopyWith: deepCopier.
lastArrowTick _ lastArrowTick veryDeepCopyWith: deepCopier.
nArrowTicks _ nArrowTicks veryDeepCopyWith: deepCopier.
operatorReadoutString _ operatorReadoutString veryDeepCopyWith: deepCopier.
possessive _ possessive veryDeepCopyWith: deepCopier.
retractArrow _ retractArrow veryDeepCopyWith: deepCopier.! !


!TileMorph methodsFor: 'tiles from method' stamp: 'tk 8/6/1999 16:00'!
selectorTile: msgNode in: aScriptor
	| sel selTile |
	"Make a selector (operator) tile"

	sel _ msgNode selector key.
	sel == #color:sees: ifTrue: [
		selTile _ (Viewer new) colorSeesPhrase submorphs second.	"ColorSeer tile"
		selTile colorSwatchColor: msgNode arguments first eval.
		^ selTile].
	^ self setOperator: sel! !

!TileMorph methodsFor: 'tiles from method' stamp: 'tk 8/6/1999 15:32'!
tilesFrom: argNode type: selType in: aScriptor
	| argType |
	"for an argument or receiver"

	argType _ selType.
	(argNode isKindOf: LiteralNode) 
		ifTrue: [argType ifNil: [argType _ argNode literalValue basicType].
			^ (aScriptor playerScripted tileForArgType: argType)
					setLiteral: argNode literalValue]
		ifFalse: [^ TilePadMorph new tilesFrom: argNode in: aScriptor].
! !


!TileMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/7/2000 16:52'!
aboutToBeGrabbedBy: aHand
	| editor |
	editor _ self topEditor.
	editor ifNotNil:[editor scriptEdited].
	^super aboutToBeGrabbedBy: aHand! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TileMorph class
	instanceVariableNames: ''!

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:40'!
downPicture
	^ DownPicture! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:39'!
downPicture: p
	DownPicture _ p! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 17:30'!
fixCaretForms
	"TileMorph fixCaretForms"
	"UpPicture storeString"
	"DownPicture storeString"

	UpPicture _  Form
	extent: 9@8
	depth: 16
	fromArray: #( 0 0 60817408 0 0 0 0 60818336 0 0 0 928 60818336 60817408 0 0 928 60818336 60817408 0 0 60818336 60818336 60818336 0 928 60818336 60818336 60818336 0 928 60818336 60818336 60818336 60817408 60818336 60818336 60818336 60818336 60817408)
	offset: 0@0.

	DownPicture _ Form
	extent: 9@8
	depth: 16
	fromArray: #( 60818336 60818336 60818336 60818336 60817408 928 60818336 60818336 60818336 60817408 928 60818336 60818336 60818336 0 0 60818336 60818336 60818336 0 0 928 60818336 60817408 0 0 928 60818336 60817408 0 0 0 60818336 0 0 0 0 60817408 0 0)
	offset: 0@8.

	SuffixPicture _  Form
	extent: 10@8
	depth: 16
	fromArray: #( 928 0 0 0 0 60818336 60818336 0 0 0 60818336 60818336 60818336 60817408 0 60818336 60818336 60818336 60818336 0 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 60818336 0 60818336 60818336 60818336 0 0)
	offset: 0@0! !

!TileMorph class methodsFor: 'class initialization' stamp: 'tk 8/15/2000 11:00'!
initialize
	"TileMorph readInArrowGraphics    -- call manually if necessary to bring graphics forward"
	"TileMorph initialize"

	UpdatingOperators _ Dictionary new.
	UpdatingOperators at: #incr: put: #+.
	UpdatingOperators at: #decr: put: #-.
	UpdatingOperators at: #set: put: ''.

	RetractPicture ifNil: [
		RetractPicture _ (SuffixPicture flipBy: #horizontal centerAt: (SuffixPicture center))].
	SuffixArrowAllowance _ 5 + SuffixPicture width + RetractPicture width.
	UpArrowAllowance _ 10.
! !

!TileMorph class methodsFor: 'class initialization' stamp: 'mdr 9/4/2000 11:06'!
readInArrowGraphics
	"TileMorph readInArrowGraphics"

	| obj |
	obj _ (FileStream readOnlyFileNamed: 'tile inc arrow.morph') fileInObjectAndCode.
	UpPicture _ obj form.

	obj _ (FileStream readOnlyFileNamed: 'tile dec arrow.morph') fileInObjectAndCode.
	DownPicture _ obj form.

	obj _ (FileStream readOnlyFileNamed: 'tile suffix arrow.morph')fileInObjectAndCode.
	SuffixPicture _ obj form.! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:48'!
suffixPicture
	^ SuffixPicture! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:48'!
suffixPicture: p
	SuffixPicture _ p! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:29'!
upPicture
	^ UpPicture! !

!TileMorph class methodsFor: 'class initialization' stamp: 'sw 1/21/98 16:29'!
upPicture: p
	UpPicture _ p! !


!TileMorph class methodsFor: 'constants' stamp: 'tk 9/17/97 17:24'!
defaultH

	^ 22! !
Morph subclass: #TilePadMorph
	instanceVariableNames: 'type '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!
!TilePadMorph commentStamp: '<historical>' prior: 0!
The drop target for colored tiles.  Landing pad.  In the hierarchy, but not a tile itself.  Would like to eliminate this, but an attempt at it failed. !


!TilePadMorph methodsFor: 'code generation' stamp: 'jm 5/28/1998 19:10'!
storeCodeOn: aStream indent: tabCount

	submorphs do: [:m | m storeCodeOn: aStream indent: tabCount].
! !


!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 9/17/1999 08:04'!
basicWidth
	^ 18
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/4/1999 18:02'!
isColorConstant: aParseNode
	"Is this a Color constant, of the form (MessageNode (VariableNode Color->Color) (SelectorNode #r:g:b:) (LiteralNode LiteralNode LiteralNode))"

	| rec |
	((rec _ aParseNode receiver) isKindOf: VariableNode) ifFalse: [^ false].
	rec key class == Association ifFalse: [^ false].
	rec key value == Color ifFalse: [^ false].
	aParseNode selector key == #r:g:b: ifFalse: [^ false].
	aParseNode arguments  size = 3 ifFalse: [^ false].
	^ true
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/3/1999 13:25'!
isOutsideRef: aParseNode
	"Is this a reference to an outside Player, of the form (self class refUnscriptedPlayer1)?
(MessageNode (VariableNode 'self') (SelectorNode 'class')) (SelectorNode 'refUnscriptedPlayer1')"

	| rec |
	((rec _ aParseNode receiver) isKindOf: MessageNode) ifFalse: [^ false].
	rec receiver isSelfPseudoVariable ifFalse: [^ false].
	rec selector key == #class ifFalse: [^ false].
	aParseNode selector key numArgs = 0 ifFalse: [^ false].
	(aParseNode selector key beginsWith: 'ref') ifFalse: [^ false].
	^ true
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/16/2000 10:01'!
lastTile
	"The tile that might get an extension arrow"

	^ self lastSubmorph lastTile! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 9/17/1999 08:03'!
setType: aSymbol

	type _ aSymbol.
	self color: (ScriptingSystem colorForType: type).
	self extent: (self basicWidth @ TileMorph defaultH)
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 8/4/1999 18:57'!
tilesFrom: aParseNode in: aScriptor
	"Make a Pad and a Tile for a variable, self, a number, or other literal"

	| outsideObj tile |
	(aParseNode isKindOf: LiteralNode) ifTrue: [
		type _ #literal.
		^ self addMorph: (aParseNode literalValue newTileMorphRepresentative)].
	(aParseNode isKindOf: VariableNode) ifTrue: [
		aParseNode isSelfPseudoVariable ifTrue: [
			tile _ (CategoryViewer new) tileForPlayer: aScriptor playerScripted.
			type _ tile type.
			^ self addMorph: tile].
		(aParseNode key = 'true') | (aParseNode key = 'false') ifTrue: [
			type _ #literal.
			^ self addMorph: (aParseNode key first == $t) newTileMorphRepresentative]].

	(aParseNode isKindOf: MessageNode) ifTrue: [
		(self isColorConstant: aParseNode) ifTrue: [
			type _ #color.
			^ self addMorph: (aParseNode eval newTileMorphRepresentative)]].
		
	(aParseNode isKindOf: MessageNode) ifTrue: [
		(self isOutsideRef: aParseNode) ifTrue: [
			outsideObj _ aScriptor playerScripted class perform: aParseNode selector key.
			tile _ (CategoryViewer new) tileForPlayer: outsideObj.
			type _ tile type.
			^ self addMorph: tile]].

	(aParseNode isKindOf: MessageNode) ifTrue: [
		^ PhraseTileMorph new tilesFrom: aParseNode in: aScriptor].
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'tk 10/31/97 10:14'!
topEditor

	^ self outermostMorphThat: [:m | 
		(m isKindOf: ScriptEditorMorph) or: [m isKindOf: CompoundTileMorph]].
! !

!TilePadMorph methodsFor: 'miscellaneous' stamp: 'sw 10/3/97 18:00'!
type
	^ type! !


!TilePadMorph methodsFor: 'mouse' stamp: 'tk 8/16/2000 10:02'!
acceptDroppingMorph: aMorph event: evt

	| editor wasPossessive |
	wasPossessive _ submorphs size > 0 and: [submorphs first isPossessive].
	self prepareToUndoDropOf: aMorph.
	self removeAllMorphs.
	aMorph position: self position.
	self addMorph: aMorph.
	wasPossessive ifTrue: [aMorph bePossessive].
	aMorph lastTile addRetractArrow.	"if can"
	(editor _ self topEditor) ifNotNil: [editor install]
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'jm 6/26/97 08:30'!
canAccept: aMorph

	((aMorph isKindOf: PhraseTileMorph) or:
	 [aMorph isKindOf: TileMorph]) ifTrue: [
		^ aMorph resultType == type].
	^ false
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'di 7/3/1998 14:25'!
handlesDragOver: evt

	^ true
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'jm 6/25/97 16:57'!
handlesMouseOver: evt

	^ true
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt

	^ true
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'sw 10/29/1998 16:07'!
mouseEnter: evt
	"Show drag/drop feedback."

	| h m |
	h _ evt hand.
	h submorphCount ~= 1 ifTrue: [^ self].
	m _ h firstSubmorph.
	(self canAccept: m) ifTrue:
		[self color: (ScriptingSystem brightColorForType: type).
		self submorphsDo: [:subM |
			(subM isKindOf: TileMorph) ifTrue:
				[subM color: (ScriptingSystem brightColorFor: subM color)]]].
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:08'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!TilePadMorph methodsFor: 'mouse' stamp: 'sw 10/29/1998 16:08'!
mouseLeave: evt
	"Clear drag/drop feedback."

	color ~= (ScriptingSystem colorForType: type) ifTrue:
		[self color: (ScriptingSystem colorForType: type).
		self submorphsDo: [:subM |
			(subM isKindOf: TileMorph) ifTrue:
				[subM color: (ScriptingSystem unbrightColorFor: subM color)]]].
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!TilePadMorph methodsFor: 'mouse' stamp: 'ar 10/25/2000 23:13'!
prepareToUndoDropOf: aMorph

	| m |
	self mouseLeave: MouseMoveEvent new.
	m _ self owner.
	[m == nil] whileFalse: [
		(m isKindOf: ScriptEditorMorph) ifTrue: [^ m prepareToUndoDropOf: aMorph].
		m _ m owner].
! !

!TilePadMorph methodsFor: 'mouse' stamp: 'jm 6/26/97 08:30'!
wantsDroppedMorph: aMorph event: evt

	^ self canAccept: aMorph
! !


!TilePadMorph methodsFor: 'printing' stamp: 'sma 6/1/2000 09:19'!
printOn: aStream
	super printOn: aStream.
	aStream nextPutAll: ' type='; print: type! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TilePadMorph class
	instanceVariableNames: ''!


!TilePadMorph class methodsFor: 'color' stamp: 'sw 5/8/1998 13:40'!
colorFudge
	^ 0.4! !
Magnitude subclass: #Time
	instanceVariableNames: 'seconds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Magnitudes'!
!Time commentStamp: '<historical>' prior: 0!
I represent the time of day.

Internally I store the number of seconds since midnight.!


!Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 19:48'!
hours
	"Answer the number of hours the receiver represents."

	^seconds // 3600! !

!Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 00:48'!
minutes
	"Answer the number of minutes the receiver represents."

	^seconds \\ 3600 // 60! !

!Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 00:00'!
seconds
	"Answer the number of seconds the receiver represents."

	^seconds \\ 3600 \\ 60! !


!Time methodsFor: 'arithmetic'!
addTime: timeAmount
	"Answer a Time that is timeInterval after the receiver. timeInterval is an 
	instance of Date or Time."

	^Time fromSeconds: self asSeconds + timeAmount asSeconds! !

!Time methodsFor: 'arithmetic'!
subtractTime: timeAmount 
	"Answer a Time that is timeInterval before the receiver. timeInterval is 
	an instance of Date or Time."

	^Time fromSeconds: self asSeconds - timeAmount asSeconds! !


!Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'!
< aTime 
	"Answer whether aTime is earlier than the receiver."

	^seconds < aTime asSeconds! !

!Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'!
= aTime 
	"Answer whether aTime represents the same second as the receiver."

	self species = aTime species
		ifTrue: [ ^seconds = aTime asSeconds ]
		ifFalse: [ ^false ].! !

!Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'!
hash
	"Hash must be redefined since = was redefined."

	^seconds hash! !


!Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:44'!
hhmm24
	"Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits"

	^(String streamContents: 
		[ :aStream | self print24: true showSeconds: false on: aStream ])
			copyWithout: $:! !

!Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:44'!
intervalString
	"Treat the time as a difference.  Give it in hours and minutes with two digits of accuracy."

	| hh mm ss |
	hh _ self hours = 0 ifTrue: [''] ifFalse: [' ', self hours printString, ' hours'].
	mm _ self minutes = 0 ifTrue: [''] ifFalse: [' ', self minutes printString, ' minutes'].
	ss _ self seconds = 0 ifTrue: [''] ifFalse: [' ', self seconds printString, ' seconds'].
	hh size > 0 ifTrue: [ss _ ''].
	^ hh, mm, ss! !

!Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:43'!
print24
	"Return as 8-digit string 'hh:mm:ss', with leading zeros if needed"

	^String streamContents:
		[ :aStream | self print24: true on: aStream ]

! !

!Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:41'!
print24: hr24 on: aStream 
	"Format is 'hh:mm:ss' or 'h:mm:ss am' "

	self print24: hr24 showSeconds: true on: aStream 
! !

!Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:42'!
print24: hr24 showSeconds: showSeconds on: aStream 
	"Format is 'hh:mm:ss' or 'h:mm:ss am'  or, if showSeconds is false, 'hh:mm' or 'h:mm am'"

	| h m s |
	h _ self hours. m _ self minutes. s _ self seconds.
	hr24
	ifTrue:
	[
		h < 10 ifTrue: [ aStream nextPutAll: '0' ].
		h printOn: aStream
	]
	ifFalse:
	[
		h > 12
		ifTrue: [ h - 12 printOn: aStream]
		ifFalse: 
		[
			h < 1
				ifTrue: [ 12 printOn: aStream ]
				ifFalse: [ h printOn: aStream ]
		]
	].

	aStream nextPutAll: (m < 10 ifTrue: [':0'] ifFalse: [':']).
	m printOn: aStream.

	showSeconds ifTrue:
	[
		aStream nextPutAll: (s < 10 ifTrue: [':0'] ifFalse: [':']).
		s printOn: aStream
	].

	hr24 ifFalse:
	[
		aStream nextPutAll: (h < 12 ifTrue: [' am'] ifFalse: [' pm'])
	].
! !

!Time methodsFor: 'printing' stamp: 'tk 9/7/2000 00:09'!
printMinutes
	"Return as string 'hh:mm pm'  "

	^String streamContents:
		[ :aStream | self print24: false showSeconds: false on: aStream ]

! !

!Time methodsFor: 'printing' stamp: 'dhhi 9/16/2000 17:06'!
printOn: aStream 
	self seconds = 0
		ifTrue: [self print24: false showSeconds: false on: aStream]
		ifFalse: [self print24: false on: aStream]! !

!Time methodsFor: 'printing' stamp: 'di 9/22/2000 12:46'!
storeOn: aStream

	aStream print: self printString; nextPutAll: ' asTime'! !


!Time methodsFor: 'converting' stamp: 'BP 5/17/2000 00:00'!
asSeconds
	"Answer the number of seconds since midnight of the receiver."

	^seconds! !


!Time methodsFor: 'private' stamp: 'BP 5/17/2000 19:45'!
hours: anInteger

	self hours: anInteger minutes: 0 seconds: 0.! !

!Time methodsFor: 'private' stamp: 'BP 5/17/2000 00:00'!
hours: hourInteger minutes: minInteger seconds: secInteger

	self setSeconds: (hourInteger * 3600) + (minInteger * 60) + secInteger.! !

!Time methodsFor: 'private' stamp: 'BP 5/17/2000 00:00'!
setSeconds: secondCount

	seconds _ secondCount
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Time class
	instanceVariableNames: ''!

!Time class methodsFor: 'instance creation' stamp: 'BP 5/17/2000 19:53'!
fromSeconds: secondCount 
	"Answer an instance of me that is secondCount number of seconds since midnight."

	^self new 
		setSeconds: secondCount;
		yourself.! !

!Time class methodsFor: 'instance creation'!
now
	"Answer an instnace of me representing the time right now--this is a 24 
	hour clock."

	^self dateAndTimeNow at: 2! !

!Time class methodsFor: 'instance creation' stamp: 'BP 5/17/2000 19:53'!
readFrom: aStream
	"Read a Time from the stream in the form:
		<hour>:<minute>:<second> <am/pm>

	<minute>, <second> or <am/pm> may be omitted.  e.g. 1:59:30 pm; 8AM; 15:30"

	| hour minute second ampm |
	hour _ Integer readFrom: aStream.
	minute _ 0.
	second _ 0.
	(aStream peekFor: $:) ifTrue:
	[
		minute _ Integer readFrom: aStream.
		(aStream peekFor: $:) ifTrue: [ second _ Integer readFrom: aStream ]
	].
	aStream skipSeparators.
	(aStream atEnd not and: [aStream peek isLetter])
	ifTrue:
	[
		ampm _ aStream next asLowercase.
		(ampm = $p and: [hour < 12]) ifTrue: [hour _ hour + 12].
		(ampm = $a and: [hour = 12]) ifTrue: [hour _ 0].
		(aStream peekFor: $m) ifFalse: [aStream peekFor: $M]
	].
	^self fromSeconds: 60*(60*hour+minute)+second

	"Time readFrom: (ReadStream on: '2:23:09 pm')"
! !


!Time class methodsFor: 'general inquiries' stamp: 'tk 8/30/2000 21:46'!
condenseBunches: aCollectionOfSeconds
	| secArray pause now out prev bunchEnd ago |
	"Identify the major intervals in a bunch of numbers.  Each number is a seconds since 1901 that represents a date and time.  We want the last event in a bunch.  Return array of seconds for:
	Every event in the last half hour.
	Every bunch separated by 30 min in the last 24 hours.
	Every bunch separated by two hours before that."
"Time condenseBunches: 
	(#(20 400 401  20000 20200 20300   40000 45000  200000 201000 202000) collect: [:tt | 
		self totalSeconds - tt]) 
"
	secArray _ aCollectionOfSeconds asSortedCollection.
	pause _ 1.
	now _ self totalSeconds.
	out _ OrderedCollection new.
	prev _ 0.
	bunchEnd _ nil.
	secArray reverseDo: [:secs | "descending"
		ago _ now - secs.
		ago > (60*30) ifTrue: [pause _ "60*30" 1800].
		ago > (60*60*24) ifTrue: [pause _ "60*120" 7200].
		ago - prev >= pause ifTrue: [out add: bunchEnd.  bunchEnd _ secs].
		prev _ ago].
	out add: bunchEnd.
	out removeFirst.
	^ out! !

!Time class methodsFor: 'general inquiries' stamp: 'JZH 11/8/1998 13:03'!
dateAndTimeFromSeconds: secondCount

	^ Array
		with: (Date fromSeconds: secondCount)
		with: (Time fromSeconds: secondCount \\ 86400)
! !

!Time class methodsFor: 'general inquiries' stamp: 'ls 7/25/1998 01:16'!
dateAndTimeNow
	"Answer a two-element Array of (Date today, Time now)."

	| secondCount d t |
	secondCount _ self primSecondsClock.
	d _ Date fromSeconds: secondCount.
	t _ Time fromSeconds: secondCount \\ 86400.
	^ Array with: d with: t! !

!Time class methodsFor: 'general inquiries' stamp: 'tk 8/30/2000 22:42'!
humanWordsForSecondsAgo: secs
	| date today |
	"Return natural language for this date and time in the past."

	secs <= 1 ifTrue: [^ 'a second ago'].
	secs < 45 ifTrue: [^ secs printString, ' seconds ago'].
	secs < 90 ifTrue: [^ 'a minute ago'].
	secs < "45*60" 2700 ifTrue: [^ (secs//60) printString, ' minutes ago'].
	secs < "90*60" 5400 ifTrue: [^ 'an hour ago'].
	secs < "18*60*60" 64800 ifTrue: [^ (secs//3600) printString, ' hours ago'].
	date _ Date fromSeconds: self totalSeconds - secs.		"now work with dates"
	today _ Date today.
	date > (today subtractDays: 2) ifTrue: [^ 'yesterday'].
	date > (today subtractDays: 8) ifTrue: [^ 'last ', date weekday].
	date > (today subtractDays: 13) ifTrue: [^ 'a week ago'].
	date > (today subtractDays: 28) ifTrue: [
		^ ((today subtractDate: date)//7) printString, ' weeks ago'].
	date > (today subtractDays: 45) ifTrue: [^ 'a month ago'].
	date > (today subtractDays: 300) ifTrue: [^ 'last ', date monthName].
	^ date monthName, ', ', date year printString

"Example
#(0.5 30 62 130 4000 10000 60000 90000 345600 864000 1728000 3456000 17280000 34560000 345600000) collect: [:ss | Time humanWordsForSecondsAgo: ss].
"! !

!Time class methodsFor: 'general inquiries'!
millisecondClockValue
	"Answer the number of milliseconds since the millisecond clock was last 
	reset or rolled over."

	^ self primMillisecondClock! !

!Time class methodsFor: 'general inquiries' stamp: 'mir 10/29/1999 18:27'!
milliseconds: currentTime since: lastTime
	| delta |
	"Answer the elapsed time since last recorded in milliseconds.
	Compensate for rollover."

	delta _ currentTime - lastTime.
	^delta < 0
		ifTrue: [SmallInteger maxVal + delta]
		ifFalse: [delta]
! !

!Time class methodsFor: 'general inquiries' stamp: 'mir 10/29/1999 18:24'!
millisecondsSince: lastTime
	"Answer the elapsed time since last recorded in milliseconds.
	Compensate for rollover."

	^self milliseconds: self millisecondClockValue since: lastTime! !

!Time class methodsFor: 'general inquiries'!
millisecondsToRun: timedBlock 
	"Answer the number of milliseconds timedBlock takes to return its value."

	| initialMilliseconds |
	initialMilliseconds _ self millisecondClockValue.
	timedBlock value.
	^self millisecondClockValue - initialMilliseconds! !

!Time class methodsFor: 'general inquiries' stamp: 'tk 10/3/2000 13:53'!
namesForTimes: arrayOfSeconds
	| simpleEnglish prev final prevPair myPair |
	"Return English descriptions of the times in the array.  They are each seconds since 1901.  If two names are the same, append the date and time to distinguish them."

	simpleEnglish _ arrayOfSeconds collect: [:secsAgo |
		self humanWordsForSecondsAgo: self totalSeconds - secsAgo].
	prev _ ''.
	final _ simpleEnglish copy.
	simpleEnglish withIndexDo: [:eng :ind | 
		eng = prev ifFalse: [eng]
			ifTrue: ["both say 'a month ago'"
				prevPair _ self dateAndTimeFromSeconds: 
						(arrayOfSeconds at: ind-1).
				myPair _ self dateAndTimeFromSeconds: 
						(arrayOfSeconds at: ind).
				(final at: ind-1) = prev ifTrue: ["only has 'a month ago'"
					final at: ind-1 put: 
							(final at: ind-1), ', ', prevPair first mmddyyyy].
				final at: ind put: 
							(final at: ind), ', ', myPair first mmddyyyy.
				prevPair first = myPair first 
					ifTrue: [
						(final at: ind-1) last == $m ifFalse: ["date but no time"
							final at: ind-1 put: 
								(final at: ind-1), ', ', prevPair second printMinutes].
						final at: ind put: 
							(final at: ind), ', ', myPair second printMinutes]].
		prev _ eng].
	^ final! !

!Time class methodsFor: 'general inquiries'!
totalSeconds
	"Answer the total seconds from January 1, 1901."

	^ self primSecondsClock! !


!Time class methodsFor: 'private'!
primMillisecondClock
	"Primitive. Answer the number of milliseconds since the millisecond clock
	 was last reset or rolled over. Answer zero if the primitive fails.
	 Optional. See Object documentation whatIsAPrimitive."

	<primitive: 135>
	^ 0! !

!Time class methodsFor: 'private'!
primSecondsClock
	"Answer the number of seconds since 00:00 on the morning of
	 January 1, 1901 (a 32-bit unsigned number).
	 Essential. See Object documentation whatIsAPrimitive. "

	<primitive: 137>
	self primitiveFailed! !


!Time class methodsFor: 'benchmarks' stamp: 'ar 9/6/1999 17:51'!
benchmarkMillisecondClock		"Time benchmarkMillisecondClock"
	"Benchmark the time spent in a call to Time>>millisecondClockValue.
	On the VM level this tests the efficiency of calls to ioMSecs()."
	"PII/400 Windows 98: 0.725 microseconds per call"
	| temp1 temp2 temp3 delayTime nLoops time |
	delayTime _ 5000. "Time to run benchmark is approx. 2*delayTime"

	"Don't run the benchmark if we have an active delay since
	we will measure the additional penalty in the primitive dispatch
	mechanism (see #benchmarkPrimitiveResponseDelay)."
	Delay anyActive ifTrue:[
		^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].

	"Flush the cache for this benchmark so we will have
	a clear cache hit for each send to #millisecondClockValue below"
	Object flushCache.
	temp1 _ 0.
	temp2 _ self. "e.g., temp1 == Time"
	temp3 _ self millisecondClockValue + delayTime.

	"Now check how often we can run the following loop in the given time"
	[temp2 millisecondClockValue < temp3]
		whileTrue:[temp1 _ temp1 + 1].

	nLoops _ temp1. "Remember the loops we have run during delayTime"

	"Setup the second loop"
	temp1 _ 0.
	temp3 _ nLoops.

	"Now measure how much time we spend without sending #millisecondClockValue"
	time _ Time millisecondClockValue.
	[temp1 < temp3]
		whileTrue:[temp1 _ temp1 + 1].
	time _ Time millisecondClockValue - time.

	"And compute the number of microseconds spent per call to #millisecondClockValue"
	^((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString,
		' microseconds per call to Time>>millisecondClockValue'! !

!Time class methodsFor: 'benchmarks' stamp: 'ar 9/6/1999 18:02'!
benchmarkPrimitiveResponseDelay	"Time benchmarkPrimitiveResponseDelay"
	"Benchmark the overhead for primitive dispatches with an active Delay.
	On the VM level, this tests the efficiency of ioLowResMSecs."

	"PII/400 Windows98: 0.128 microseconds per prim"

	"ar 9/6/1999: This value is *extremely* important for stuff like sockets etc.
	I had a bad surprise when Michael pointed this particular problem out:
	Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead
	of 157.4 microseconds per primitive call - meaning you can't get no more than
	approx. 6000 primitives per second on my 400Mhz PII system with an active delay!!
	BTW, it finally explains why Squeak seemed soooo slow when running PWS or 
	other socket stuff. The new version (not using clock() but some Windows function) 
	looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)."

	| nLoops bb index baseTime actualTime delayTime |
	delayTime _ 5000. "Time to run this test is approx. 3*delayTime"

	Delay anyActive ifTrue:[
		^self notify:'Some delay is currently active.
Running this benchmark will not give any useful result.'].

	bb _ Array new: 1. "The object we send the prim message to"

	"Compute the # of loops we'll run in a decent amount of time"
	[(Delay forMilliseconds: delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	nLoops _ 0.
	[Delay anyActive] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		nLoops _ nLoops + 1.
	].

	"Flush the cache and make sure #basicSize is in there"
	Object flushCache.
	bb basicSize.

	"Now run the loop without any active delay
	for getting an idea about its actual speed."
	baseTime _ self millisecondClockValue.
	index _ nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index _ index - 1.
	].
	baseTime _ self millisecondClockValue - baseTime.

	"Setup the active delay but try to never make it active"
	[(Delay forMilliseconds: delayTime + delayTime) wait] 
		forkAt: Processor userInterruptPriority.

	"And run the loop"
	actualTime _ self millisecondClockValue.
	index _ nLoops.
	[index > 0] whileTrue:[
		bb basicSize; basicSize; basicSize; basicSize; basicSize; 
			basicSize; basicSize; basicSize; basicSize; basicSize.
		index _ index - 1.
	].
	actualTime _ self millisecondClockValue - actualTime.

	"And get us some result"
	^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString,
		' microseconds overhead per primitive call'! !
MessageSet subclass: #TimeProfileBrowser
	instanceVariableNames: 'selectedClass selectedSelector block tally '
	classVariableNames: 'TextMenu '
	poolDictionaries: ''
	category: 'Tools-Debugger'!
!TimeProfileBrowser commentStamp: '<historical>' prior: 0!
A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block.  It is useful for finding performance bottlenecks in code. When optimizing code it can
be hard to know what methods actually constitute the bulk of the execution time. Is it a few
methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times?

The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent.

Example:
TimeProfileBrowser onBlock: [20 timesRepeat:  [Transcript show: 100 factorial printString]]
!


!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
block
	"Answer the receiver's 'block'."

	^block! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
block: anObject
	"Set the receiver's instance variable 'block' to be anObject."

	block := anObject! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedClass
	"Answer the receiver's 'selectedClass'."

	^selectedClass! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedClass: anObject
	"Set the receiver's instance variable 'selectedClass' to be anObject."

	selectedClass := anObject! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedSelector
	"Answer the receiver's 'selectedSelector'."

	^selectedSelector! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
selectedSelector: anObject
	"Set the receiver's instance variable 'selectedSelector' to be anObject."

	selectedSelector := anObject! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
tally
	"Answer the receiver's 'tally'."

	^tally! !

!TimeProfileBrowser methodsFor: 'accessing' stamp: 'stp 05/08/1999 11:37'!
tally: anObject
	"Set the receiver's instance variable 'tally' to be anObject."

	tally := anObject! !


!TimeProfileBrowser methodsFor: 'private' stamp: 'dvf 7/5/2000 18:48'!
initializeMessageList: anArray
	messageList _ anArray.
	messageListIndex _ 0.
	contents _ ''! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'stp 05/08/1999 15:36'!
messageListKey: aChar from: view
	"Respond to a Command key. Cmd-D means re-run block."

	aChar == $d ifTrue: [^ Cursor execute showWhile: [self runBlock]].
	^ self arrowKey: aChar from: view! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'stp 05/08/1999 15:27'!
messageListMenu: aMenu shifted: shifted
	"Add a menu to the inherited one."

	| menu |
	menu := super messageListMenu: aMenu shifted: shifted.
"	menu addItem: (0)."
	^menu! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'di 11/4/2000 12:12'!
runBlock
	| stream list result |
	tally := MessageTally new.
	result _ tally spyEvery: 16 on: block.
	stream := ReadWriteStream with: (String streamContents: [:s | tally report: s; close]).
	stream reset.
	list := OrderedCollection new.
	[stream atEnd] whileFalse: [list add: stream nextLine].
	self initializeMessageList: list.
	self changed: #messageList.
	self changed: #messageListIndex.
	^ result
! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'sma 3/15/2000 21:42'!
selectedMessage
	"Answer the source method for the currently selected message."
	| source |
	self setClassAndSelectorIn: [:class :selector | 
		source _ class sourceMethodAt: selector ifAbsent: [^ 'Missing'].
		Preferences browseWithPrettyPrint ifTrue:
			[source _ class compilerClass new
				format: source in: class notifying: nil decorated: false].
		^ source asText makeSelectorBoldIn: class].
	^''! !

!TimeProfileBrowser methodsFor: 'private' stamp: 'dew 3/2/2000 20:04'!
setClassAndSelectorIn: csBlock
	"Decode strings of the form    <selectorName> (<className> [class])  "

	| string strm class sel parens |
	messageListIndex < 3 ifTrue: [^contents := nil].		"Ignore first 2 lines"
	string _ self selection asString.
	string isEmpty ifTrue: [^contents := nil].
	string first == $* ifTrue: [^contents := nil].		"Ignore lines starting with *"
	parens := string includes: $(.					"Does it have open-paren?"
	strm := ReadStream on: string.
	parens
		ifTrue: [strm skipTo: $(.		"easy case"
			class := strm upTo: $).
			strm next: 2.
			sel := strm upToEnd]
		ifFalse: [strm position: (string findString: ' class>>').
			strm position > 0
				ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])]
				ifTrue:
					[ | subString |  "find the next to last space character"
					subString := strm contents copyFrom: 1 to: (string findLast: [ :ch | ch == $ ]) - 1.
					strm position: (subString findLast: [ :ch | ch == $ ])].
		"ifFalse: [strm position: (string findLast: [ :ch | ch == $ ])."
			class := strm upTo: $>.
			strm next.
			sel := strm upToEnd].
	class isEmpty ifTrue: [^contents := nil].
	sel isEmpty ifTrue: [^contents := nil].
	^MessageSet parse: (class, ' ', sel) toClassAndSelector: csBlock! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TimeProfileBrowser class
	instanceVariableNames: ''!

!TimeProfileBrowser class methodsFor: 'instance creation' stamp: 'di 11/4/2000 12:12'!
onBlock: block
	"Open a profile browser on the given block, thereby running the block and 
	 collecting the message tally."
	"TimeProfileBrowser onBlock: [20 timesRepeat: 
			[Transcript show: 100 factorial printString]]"

	| inst result |
	inst := self new.
	inst block: block.
	result _ inst runBlock.
	self open: inst name: 'Time Profile'.
	^ result! !
SketchMorph subclass: #TinyPaint
	instanceVariableNames: 'brush brushSize brushColor lastMouse '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!TinyPaint methodsFor: 'initialization' stamp: 'jm 11/4/97 07:15'!
initialize

	super initialize.
	color _ Color veryVeryLightGray.
	brushColor _ Color red.
	brushSize _ 3.
	self clear.
! !


!TinyPaint methodsFor: 'events' stamp: 'sw 5/11/1998 14:02'!
handlesMouseDown: evt

	^ self inPartsBin not
! !

!TinyPaint methodsFor: 'events' stamp: 'jm 5/6/1998 16:28'!
mouseDown: evt

	lastMouse _ evt cursorPoint.
	brush drawFrom: lastMouse - bounds origin to: lastMouse - bounds origin.
	self invalidRect:
		((lastMouse - brush sourceForm extent) corner:
		 (lastMouse + brush sourceForm extent)).
! !

!TinyPaint methodsFor: 'events' stamp: 'jm 11/4/97 07:15'!
mouseMove: evt

	| p |
	p _ evt cursorPoint.
	p = lastMouse ifTrue: [^ self].
	brush drawFrom: lastMouse - bounds origin to: p - bounds origin.
	self invalidRect: (
		((lastMouse min: p) - brush sourceForm extent) corner:
		((lastMouse max: p) + brush sourceForm extent)).
	lastMouse _ p.
! !


!TinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'clear' action: #clear.
	aCustomMenu add: 'pen color' action: #setPenColor:.
	aCustomMenu add: 'pen size' action: #setPenSize.
	aCustomMenu add: 'fill' action: #fill.
! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:15'!
brushColor: aColor

	brushColor _ aColor.
	brush color: aColor.
! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 5/6/1998 16:23'!
clear

	self form: ((Form extent: 125@100 depth: 8) fillColor: color).
	brush _ Pen newOnForm: originalForm.
	brush roundNib: brushSize.
	brush color: brushColor.
! !

!TinyPaint methodsFor: 'menu' stamp: 'bf 1/5/2000 19:39'!
fill

	| fillPt |
	Cursor blank show.
	Cursor crossHair showWhile:
		[fillPt _ Sensor waitButton - self position].
	originalForm shapeFill: brushColor interiorPoint: fillPt.
	self changed.
! !

!TinyPaint methodsFor: 'menu' stamp: 'ar 10/5/2000 18:54'!
setPenColor: evt

	self changeColorTarget: self selector: #brushColor: originalColor: brushColor hand: evt hand.! !

!TinyPaint methodsFor: 'menu' stamp: 'jm 11/4/97 07:16'!
setPenSize

	| menu sizes nibSize |
	menu _ CustomMenu new.
	sizes _ (0 to: 5), (6 to: 12 by: 2), (15 to: 40 by: 5).
	sizes do: [:w | menu add: w printString action: w].
	nibSize _ menu startUp.
	nibSize ifNotNil: [
		brushSize _ nibSize.
		brush roundNib: nibSize].
! !
FormInput subclass: #ToggleButtonInput
	instanceVariableNames: 'button name value state checkedByDefault '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-HTML Forms'!
!ToggleButtonInput commentStamp: '<historical>' prior: 0!
an input from a toggle button!


!ToggleButtonInput methodsFor: 'accessing' stamp: 'bolot 11/3/1999 20:33'!
name
	^name! !

!ToggleButtonInput methodsFor: 'accessing' stamp: 'bolot 11/3/1999 20:33'!
value
	^value! !


!ToggleButtonInput methodsFor: 'private-initialize' stamp: 'bolot 11/3/1999 20:30'!
button: aButtonMorph
	button _ aButtonMorph! !

!ToggleButtonInput methodsFor: 'private-initialize' stamp: 'bolot 11/3/1999 20:30'!
name: aName value: aValue checkedByDefault: aFlag
	name _ aName.
	value _ aValue.
	checkedByDefault _ aFlag.
	state _ checkedByDefault! !


!ToggleButtonInput methodsFor: 'input handling' stamp: 'bolot 11/3/1999 20:40'!
active
	^self name isNil not and: [state]! !


!ToggleButtonInput methodsFor: 'button state' stamp: 'bolot 11/3/1999 20:25'!
pressed
	^state! !

!ToggleButtonInput methodsFor: 'button state' stamp: 'bf 11/4/1999 21:49'!
pressed: aBoolean
	state _ aBoolean.
	self changed: #pressed.
	button ifNotNil: [button step].
	^true! !

!ToggleButtonInput methodsFor: 'button state' stamp: 'bolot 11/3/1999 20:25'!
toggle
	"my button has been clicked on!!"

	self pressed: self pressed not.
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ToggleButtonInput class
	instanceVariableNames: ''!

!ToggleButtonInput class methodsFor: 'instance creation' stamp: 'bolot 11/3/1999 20:30'!
name: aName value: aValue checkedByDefault: aFlag
	^ self new name: aName value: aValue checkedByDefault: aFlag! !
ThreePhaseButtonMorph subclass: #ToggleButtonMorph
	instanceVariableNames: 'stateSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/2/97 16:52'!
buttonDownToToggleState
	| targetState |
	self doButtonAction.
	targetState _ (target perform: stateSelector) ifTrue: [#on] ifFalse: [#off].
	targetState = state ifFalse: [self toggleState]! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/19/97 15:11'!
mouseDown: evt
	self buttonDownToToggleState! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/19/97 15:06'!
mouseMove: evt
! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/19/97 15:02'!
mouseUp: evt
! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/19/97 19:43'!
setInitialState
	state _ (target perform: stateSelector) == true
		ifTrue:
			[#on]
		ifFalse:
			[#off]! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/19/97 15:23'!
stateSelector: sym
	stateSelector _ sym! !

!ToggleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/2/97 17:03'!
toggleState
	self state: ((state == #off) ifTrue: [#on] ifFalse: [#off])! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ToggleButtonMorph class
	instanceVariableNames: ''!

!ToggleButtonMorph class methodsFor: 'as yet unclassified' stamp: 'tk 6/24/1999 11:50'!
fixTargetPresenters
	"ToggleButtonMorph fixTargetPresenters"
	"Repair faulty instances from the first 'etoy-template' experiment, such that the instances refer to the local presenter rather than to a phantom and irrelevant world"
	self allSubInstancesDo:
		[:m | (m target isKindOf: Presenter) ifTrue:
			[m target: m presenter]]! !
WriteStream subclass: #TranscriptStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!TranscriptStream commentStamp: '<historical>' prior: 0!
This class is a much simpler implementation of Transcript protocol that supports multiple views and very simple conversion to morphic.  Because it inherits from Stream, it is automatically compatible with code that is designe to write to streams.!


!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/9/2000 09:11'!
closeAllViews  "Transcript closeAllViews"

	self dependents do:
		[:d |
		(d isKindOf: PluggableTextView) ifTrue: [d topView controller closeAndUnscheduleNoTerminate].
		(d isKindOf: SystemWindow) ifTrue: [d delete]]! !

!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/8/1998 13:12'!
open
	| openCount |
	openCount _ 0.
	self dependents do:
		[:d | ((d isKindOf: PluggableTextView) or:
			[d isKindOf: PluggableTextMorph]) ifTrue: [openCount _ openCount + 1]].
	openCount = 0
		ifTrue: [self openLabel: 'Transcript']
		ifFalse: [self openLabel: 'Transcript #' , (openCount+1) printString]! !

!TranscriptStream methodsFor: 'initialization' stamp: 'di 5/27/1998 16:36'!
openAsMorphLabel: labelString 
	"Build a morph viewing this transcriptStream"
	| window |
	window _ (SystemWindow labelled: labelString) model: self.
	window addMorph: (PluggableTextMorph on: self text: nil accept: nil
			readSelection: nil menu: #codePaneMenu:shifted:)
		frame: (0@0 corner: 1@1).
	^ window! !

!TranscriptStream methodsFor: 'initialization' stamp: 'sma 4/30/2000 10:16'!
openLabel: aString 
	"Open a window on this transcriptStream"

	| topView codeView |
	Smalltalk isMorphic ifTrue: [^ (self openAsMorphLabel: aString) openInWorld].

	topView _ (StandardSystemView new) model: self.
	topView borderWidth: 1.
	topView label: aString.
	topView minimumSize: 100 @ 50.

	codeView _ PluggableTextView on: self text: nil accept: nil
					readSelection: nil menu: #codePaneMenu:shifted:.
	codeView window: (0@0 extent: 200@200).
	topView addSubView: codeView.
	topView controller open! !


!TranscriptStream methodsFor: 'access' stamp: 'di 3/16/1999 21:38'!
characterLimit
	"Tell the views how much to retain on screen"
	^ 20000! !


!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 3/15/2000 21:28'!
bs
	self position > 0 ifTrue: [^ self skip: -1].
	self changed: #bs! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'!
clear
	"Clear all characters and redisplay the view"
	self changed: #clearText.
	self reset! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'!
endEntry
	"Display all the characters since the last endEntry, and reset the stream"
	self changed: #appendEntry.
	self reset! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 4/22/2000 16:58'!
flush
	self endEntry! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'di 5/8/1998 12:35'!
pastEndPut: anObject
	"If the stream reaches its limit, just output the contents and reset."
	self endEntry.
	^ self nextPut: anObject! !

!TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 2/26/2000 19:31'!
show: anObject  "TextCollector compatibility"
	self nextPutAll: anObject asString; endEntry! !


!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/27/1998 16:44'!
codePaneMenu: aMenu shifted: shifted
	"Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
	^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
! !

!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/29/1998 17:13'!
perform: selector orSendTo: otherTarget
	"Selector was just chosen from a menu by a user.  If can respond, then
perform it on myself. If not, send it to otherTarget, presumably the
editPane from which the menu was invoked."

	(self respondsTo: selector)
		ifTrue: [^ self perform: selector]
		ifFalse: [^ otherTarget perform: selector]! !

!TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/3/1999 22:49'!
release

	self dependents do:
		[:view | (view isMorph and: [view isInWorld not])
					ifTrue: [self removeDependent: view]]! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TranscriptStream class
	instanceVariableNames: ''!

!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 13:51'!
new
	^ self on: (String new: 1000)
"
INSTALLING:
TextCollector allInstances do:
	[:t | t breakDependents.
	t become: TranscriptStream new].

TESTING: (Execute this text in a workspace)
Do this first...
	tt _ TranscriptStream new.
	tt openLabel: 'Transcript test 1'.
Then this will open a second view -- ooooh...
	tt openLabel: 'Transcript test 2'.
And finally make them do something...
	tt clear.
	[Sensor anyButtonPressed] whileFalse:
		[1 to: 20 do: [:i | tt print: (2 raisedTo: i-1); cr; endEntry]].
"! !

!TranscriptStream class methodsFor: 'as yet unclassified' stamp: 'di 5/8/1998 12:44'!
newTranscript: aTextCollector 
	"Store aTextCollector as the value of the system global Transcript."
	Smalltalk at: #Transcript put: aTextCollector! !
ReadWriteStream subclass: #Transcripter
	instanceVariableNames: 'frame para '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!Transcripter commentStamp: '<historical>' prior: 0!
Transcripter is a dog-simple scrolling stream with display.  It is intended to operate with no support from MVC or color in a minimal, or headless version of Squeak.  No attention has been paid to appearance or performance.!


!Transcripter methodsFor: 'initialization' stamp: 'di 8/14/97 12:44'!
initInFrame: rect
	frame _ rect insetBy: 2.  "Leave room for border"
	para _ Paragraph withText: self contents asText
				style: TextStyle default
				compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
				clippingRectangle: frame
				foreColor: self black backColor: self white! !


!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:41'!
clear
	Display fill: (frame insetBy: -2) fillColor: self black;
			fill: frame fillColor: self white.
	self on: (String new: 100); endEntry! !

!Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:44'!
endEntry
	| c d cb |
	c _ self contents.
	Display extent ~= DisplayScreen actualScreenSize ifTrue:
		["Handle case of user resizing physical window"
		DisplayScreen startUp.
		frame _ frame intersect: Display boundingBox.
		^ self clear; show: c].
	para setWithText: c asText
		style: TextStyle default
		compositionRectangle: ((frame insetBy: 4) withHeight: 9999)
		clippingRectangle: frame
		foreColor: self black backColor: self white.
	d _ para compositionRectangle bottom - frame bottom.
	d > 0 ifTrue:
		["Scroll up to keep all contents visible"
		cb _ para characterBlockAtPoint: para compositionRectangle topLeft
											+ (0@(d+para lineGrid)).
		self on: (c copyFrom: cb stringIndex to: c size).
		readLimit_ position_ collection size.
		^ self endEntry].
	para display! !

!Transcripter methodsFor: 'accessing' stamp: 'sma 2/26/2000 19:35'!
show: anObject
	self nextPutAll: anObject asString; endEntry! !


!Transcripter methodsFor: 'command line' stamp: 'di 8/12/97 22:11'!
confirm: queryString 
	| choice |
	[true]
		whileTrue: 
			[choice _ self request: queryString , '
Please type yes or no followed by return'.
			choice first asUppercase = $Y ifTrue: [^ true].
			choice first asUppercase = $N ifTrue: [^ false]]! !

!Transcripter methodsFor: 'command line' stamp: 'di 11/3/2000 18:52'!
readEvalPrint
	| line okToRevert |
	okToRevert _ true.
	[#('quit' 'exit' 'done' ) includes: (line _ self request: '>')]
		whileFalse:
		[line = 'revert'
		ifTrue: [okToRevert
			ifTrue: [Utilities revertLastMethodSubmission.
					self cr; show: 'reverted: ' , Utilities mostRecentlySubmittedMessage.
					okToRevert _ false]
			ifFalse: [self cr; show: 'Only one level of revert currently supported']]
		ifFalse: [self cr; show: ([Compiler evaluate: line] ifError: [:err :ex | err])]]! !

!Transcripter methodsFor: 'command line' stamp: 'sma 2/26/2000 19:39'!
request: prompt
	| startPos char contents | 
	self cr; show: prompt.
	startPos _ position.
	[[Sensor keyboardPressed] whileFalse.
	(char _ Sensor keyboard) = Character cr]
		whileFalse:
		[char = Character backspace
			ifTrue: [readLimit _ position _ (position - 1 max: startPos)]
			ifFalse: [self nextPut: char].
		self endEntry].
	contents _ self contents.
	^ contents copyFrom: startPos + 1 to: contents size! !


!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'!
black
	Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"].
	^ Color black! !

!Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'!
white
	Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"].
	^ Color white! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Transcripter class
	instanceVariableNames: ''!

!Transcripter class methodsFor: 'instance creation' stamp: 'di 8/14/97 12:09'!
newInFrame: frame
"
(Transcripter newInFrame: (0@0 extent: 100@200))
	nextPutAll: 'Hello there'; endEntry;
	cr; print: 355.0/113; endEntry;
	readEvalPrint.
"
	| transcript |
	transcript _ self on: (String new: 100).
	transcript initInFrame: frame.
	^ transcript clear! !

!Transcripter class methodsFor: 'instance creation' stamp: 'ar 11/16/1999 20:16'!
startTranscriptProcess   "Transcripter startTranscriptProcess"
	| activeProcess |
	Transcript _ self newInFrame: Display boundingBox.
	activeProcess _ [Transcript readEvalPrint.
					Smalltalk processShutDownList: true; quitPrimitive]
						newProcess
					priority: Processor userSchedulingPriority.
	activeProcess resume.
	Processor terminateActive
! !


!Transcripter class methodsFor: 'utilities' stamp: 'di 11/3/2000 18:47'!
emergencyEvaluator
	(Transcripter newInFrame: (0@0 corner: 320@200))
		show: 'Type ''revert'' to revert your last method change.
Type ''exit'' to exit the emergency evaluator.';
		readEvalPrint! !
Morph subclass: #TransferMorph
	instanceVariableNames: 'transferType passenger draggedMorph source dropNotifyRecipient accepted resultRecipient copy '
	classVariableNames: 'CopyPlusIcon '
	poolDictionaries: ''
	category: 'Morphic-Support'!

!TransferMorph methodsFor: 'testing' stamp: 'mir 5/5/2000 14:39'!
shouldCopy
	^copy! !


!TransferMorph methodsFor: 'private' stamp: 'sr 6/6/2000 07:19'!
animationForMoveSuccess: success 
	| start stop slideForm |
	success
		ifTrue: [^ self]
		ifFalse: 
			[start _ self fullBounds origin.
			stop _ self source bounds origin].
	start = stop ifTrue: [^ self].
	slideForm _ self imageFormForRectangle: ((self fullBounds origin corner: self fullBounds corner + self activeHand shadowOffset)
					merge: self activeHand bounds).
	slideForm offset: 0 @ 0.
	slideForm
		slideWithFirstFrom: start
		to: stop
		nSteps: 12
		delay: 20! !

!TransferMorph methodsFor: 'private' stamp: 'svp 5/16/2000 18:29'!
initDraggedMorph
	| plusMorph |
	draggedMorph ifNil: [
		draggedMorph _ self passenger asDraggableMorph.
		self shouldCopy ifTrue: [
			plusMorph _ ImageMorph new image: CopyPlusIcon.
			draggedMorph addMorph: plusMorph.
			plusMorph position: plusMorph width negated@0].
		draggedMorph position: self position.
		self extent: (draggedMorph fullBounds extent + (6@6)).
		draggedMorph align: draggedMorph topLeft with: (self topLeft + (3@3)).
		self addMorph: draggedMorph]! !

!TransferMorph methodsFor: 'private' stamp: 'mir 5/14/2000 00:11'!
privateFullMoveBy: delta 
	super privateFullMoveBy: delta.
	self changed: #position! !


!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'!
copy
	copy _ true! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 16:11'!
dragTransferType
	^transferType! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 16:11'!
dragTransferType: aSymbol
	transferType _ aSymbol! !

!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 17:34'!
draggedMorph
	draggedMorph ifNil: [self initDraggedMorph].
	^draggedMorph! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:31'!
draggedMorph: aMorph
	draggedMorph _ aMorph! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'!
dropNotifyRecipient
	^dropNotifyRecipient! !

!TransferMorph methodsFor: 'accessing' stamp: 'panda 4/25/2000 16:14'!
dropNotifyRecipient: anObject
	dropNotifyRecipient _ anObject! !

!TransferMorph methodsFor: 'accessing' stamp: 'mir 5/5/2000 14:39'!
move
	copy _ false! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:52'!
passenger
	^passenger! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'!
passenger: anObject
	passenger _ anObject! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 11:55'!
source
	^source! !

!TransferMorph methodsFor: 'accessing' stamp: 'sr 4/16/2000 18:53'!
source: anObject
	source _ anObject! !


!TransferMorph methodsFor: 'initialization' stamp: 'svp 5/16/2000 18:28'!
initialize
	super initialize.
	self extent: 0@0.
	accepted _ false.
	copy _ false.
	self color: (Color blue alpha: 0.4)! !


!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 20:01'!
aboutToBeGrabbedBy: aHand 
	"The receiver is being grabbed by a hand.                           
	Perform necessary adjustments (if any) and return the actual morph    
	     that should be added to the hand."
	"Since this morph has been initialized automatically with bounds origin   
	     0@0, we have to move it to aHand position."
	super aboutToBeGrabbedBy: aHand.
	self draggedMorph.
	self align: self bottomLeft with: aHand position! !

!TransferMorph methodsFor: 'dropping/grabbing'!
justDroppedInto: targetMorph event: anEvent 
	"If only world wants this TransferMorph, treat it as unaccepted (see also >>delete)."

	super justDroppedInto: targetMorph event: anEvent.
	accepted _ targetMorph ~= self world.
	self animationForMoveSuccess: accepted.
	accepted ifTrue: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropAcceptedMorph: self from: targetMorph]].
	self delete! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'sr 4/16/2000 18:53'!
result: result 
	^ self result: result from: nil! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'sr 4/16/2000 15:08'!
result: aResult from: aResultGenerator 
	"Send aResult of the drop operation computed by aResultGenerator to a   
	resultRecipient, if it exists."
	self resultRecipient ifNotNil: [self resultRecipient dropResult: aResult from: aResultGenerator]! !

!TransferMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/6/2000 17:30'!
undoGrabCommand
	^nil! !


!TransferMorph methodsFor: 'submorphs-add/remove' stamp: 'mir 5/15/2000 18:05'!
delete
	"See also >>justDroppedInto:event:."
	accepted ifFalse: [self dropNotifyRecipient ifNotNil: [self dropNotifyRecipient dropRejectedMorph: self]].
	self changed: #deleted.
	self breakDependents.
	super delete! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransferMorph class
	instanceVariableNames: ''!

!TransferMorph class methodsFor: 'instance creation' stamp: 'sr 4/13/2000 21:52'!
withPassenger: anObject 
	^ self withPassenger: anObject from: nil! !

!TransferMorph class methodsFor: 'instance creation' stamp: 'mir 5/6/2000 21:21'!
withPassenger: anObject from: source 
	| ddm |
	ddm _ self new.
	ddm passenger: anObject.
	ddm source: source.
	Sensor shiftPressed ifTrue: [ddm copy].
	^ ddm! !


!TransferMorph class methodsFor: 'class initialization' stamp: 'mir 5/5/2000 14:49'!
initIcons
	"TransferMorph initIcons"

	CopyPlusIcon _ Form
		extent: 16@16
		depth: 8
		fromArray: #( 0 0 65535 0 0 0 16768220 4278190080 0 0 16768220 4278190080 0 255 4294958300 4294967040 0 65500 3705461980 3705462015 0 65500 3705461980 3705462015 0 255 4294958300 4294967295 0 0 16768220 4278190080 0 0 16768220 4278190080 0 0 65535 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
		offset: 0@0! !

!TransferMorph class methodsFor: 'class initialization' stamp: 'mir 5/5/2000 14:48'!
initialize
	"TransferMorph initialize"

	self initIcons! !
Morph subclass: #TransferMorphAnimation
	instanceVariableNames: 'transferMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!TransferMorphAnimation methodsFor: 'update' stamp: 'mir 5/15/2000 18:05'!
update: aSymbol	
	aSymbol == #deleted
		ifTrue: [self delete].
	aSymbol == #position
		ifTrue: [self updateAnimation].
	self changed! !

!TransferMorphAnimation methodsFor: 'update' stamp: 'mir 5/15/2000 18:02'!
updateAnimation! !


!TransferMorphAnimation methodsFor: 'initialization' stamp: 'RAA 6/2/2000 16:43'!
on: aTransferMorph

	self flag: #bob.		"there was a reference to World, but the class seems to be unused"

	self color: Color transparent.
	transferMorph _ aTransferMorph.
	transferMorph addDependent: self.
	Display getCurrentMorphicWorld addMorph: self	"or perhaps aTransferMorph world"! !


!TransferMorphAnimation methodsFor: 'accessing' stamp: 'mir 5/14/2000 00:10'!
transferMorph
	^transferMorph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransferMorphAnimation class
	instanceVariableNames: ''!

!TransferMorphAnimation class methodsFor: 'instance creation' stamp: 'mir 5/14/2000 00:07'!
on: aTransferMorph
	^self new on: aTransferMorph! !
TransferMorphAnimation subclass: #TransferMorphLineAnimation
	instanceVariableNames: 'polygon '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Support'!

!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'di 9/9/2000 09:59'!
initPolygon
	polygon _ (LineMorph from: self transferMorph source bounds center
				to: self transferMorph bounds center
				color: Color black width: 2)
			dashedBorder: {10. 10. Color white}.
	self addMorph: polygon
! !

!TransferMorphLineAnimation methodsFor: 'initialization' stamp: 'mir 5/14/2000 00:12'!
on: aTransferMorph
	super on: aTransferMorph.
	self initPolygon! !


!TransferMorphLineAnimation methodsFor: 'update' stamp: 'di 9/9/2000 09:46'!
updateAnimation
	polygon verticesAt: 2 put: self transferMorph center! !
Morph subclass: #TransformMorph
	instanceVariableNames: 'transform smoothing '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TransformMorph commentStamp: '<historical>' prior: 0!
A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds.  Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position).  Rotation and scaling are relative to the local origin, (0@0).

TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not.  If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset.  If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds.!


!TransformMorph methodsFor: 'initialization'!
initialize
	super initialize.
	color _ Color lightGreen.
	smoothing _ 1.
	transform _ MorphicTransform identity.
! !


!TransformMorph methodsFor: 'accessing'!
angle
	^ transform angle! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 1/30/2001 23:20'!
angle: newAngle

	self changed.
	transform _ transform withAngle: newAngle.
	self layoutChanged.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
offset
	^ transform offset + self innerBounds topLeft! !

!TransformMorph methodsFor: 'accessing'!
offset: newOffset

	transform _ transform withOffset: newOffset - self innerBounds topLeft.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
scale
	^ transform scale! !

!TransformMorph methodsFor: 'accessing' stamp: 'jm 4/17/1998 05:23'!
scale: newScale

	self changed.
	transform _ transform withScale: newScale.
	self layoutChanged.
	self changed.
! !

!TransformMorph methodsFor: 'accessing'!
setOffset: newOffset angle: newAngle scale: newScale

	transform _ MorphicTransform offset: newOffset angle: newAngle scale: newScale.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
smoothing: cellSize
	smoothing _ cellSize.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
smoothingOff
	smoothing _ 1.
	self changed! !

!TransformMorph methodsFor: 'accessing'!
smoothingOn
	smoothing _ 2.
	self changed! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'!
transform
	^transform! !

!TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'!
transform: aTransform
	transform _ aTransform.! !



!TransformMorph methodsFor: 'drawing' stamp: 'di 2/23/98 14:44'!
colorForInsets
	^ owner ifNil: [color] ifNotNil: [owner color]! !

!TransformMorph methodsFor: 'drawing' stamp: 'di 10/16/1999 16:03'!
drawSubmorphsOn: aCanvas

	aCanvas transformBy: transform
		clippingTo: self innerBounds
		during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ]
		smoothing: smoothing! !


!TransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:42'!
containsPoint: aPoint
	(bounds containsPoint: aPoint) ifFalse: [^ false].
	self hasSubmorphs
		ifTrue: [self submorphsDo: 
					[:m | (m fullBounds containsPoint: (transform globalPointToLocal: aPoint))
							ifTrue: [^ true]].
				^ false]
		ifFalse: [^ true]! !

!TransformMorph methodsFor: 'geometry' stamp: 'di 1/30/2001 22:40'!
contentBounds
	self hasSubmorphs ifTrue:
		[^ (transform localBoundsToGlobal: self submorphBounds) truncated].
	^ self fullBounds! !

!TransformMorph methodsFor: 'geometry' stamp: 'di 11/20/2000 11:54'!
fullBounds
	"Overridden to clip submorph hit detection to my bounds."
	"It might be better to override doLayoutIn:, and remove this method"

	fullBounds ifNotNil:[^ fullBounds].
	fullBounds _ bounds.
	submorphs do: [:m| m ownerChanged].
	^ fullBounds! !

!TransformMorph methodsFor: 'geometry' stamp: 'jm 5/16/1998 19:54'!
privateFullMoveBy: delta
	"Private!! Relocate me, but not my subMorphs."

	self privateMoveBy: delta.
	transform _ transform withOffset: (transform offset - delta).
! !

!TransformMorph methodsFor: 'geometry'!
submorphBounds
	| subBounds |
	subBounds _ nil.
	self submorphsDo:
		[:m |
		subBounds ifNil: [subBounds _ m fullBounds]
				ifNotNil: [subBounds _ subBounds quickMerge: m fullBounds]].
	^ subBounds! !

!TransformMorph methodsFor: 'geometry' stamp: 'sw 12/29/1999 15:51'!
wantsHaloFromClick
	^ false! !


!TransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:49'!
invalidRect: damageRect from: aMorph
	"Translate damage reports from submorphs by the scrollOffset."
	aMorph == self
		ifTrue:[super invalidRect: damageRect from: self]
		ifFalse:[super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds) expandBy: 1) from: self].! !


!TransformMorph methodsFor: 'events' stamp: 'ar 10/22/2000 18:00'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !

!TransformMorph methodsFor: 'events' stamp: 'ar 9/12/2000 00:28'!
transformFrom: uberMorph
	"Return a transform to map coorinates of uberMorph, a morph above me in my owner chain, into the coordinates of my submorphs."

	(self == uberMorph or:[owner == nil]) ifTrue: [^ transform].
	^ (owner transformFrom: uberMorph) composedWithLocal: transform! !


!TransformMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:04'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	smoothing = 1
		ifTrue: [aCustomMenu add: 'turn on smoothing' action: #smoothingOn]
		ifFalse: [aCustomMenu add: 'turn off smoothing' action: #smoothingOff]! !
TransformationMorph subclass: #TransformationB2Morph
	instanceVariableNames: 'worldBoundsToShow useRegularWarpBlt '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TransformationB2Morph commentStamp: '<historical>' prior: 0!
A transformation which:

- is content to let someone else decide my bounds (I do not try to minimally enclose my submorphs)
- can use bi-linear interpolation!


!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 11/22/2000 08:12'!
adjustAfter: changeBlock 

	"same as super, but without reference position stuff"

	changeBlock value.
	self chooseSmoothing.
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]
! !

!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/2000 13:32'!
computeBounds

	"the transform bounds must remain under the control of the owner in this case"! !

!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 12/17/2000 13:25'!
drawSubmorphsOn: aCanvas

	| r1 fullG r2 actualCanvas newClip where deferredMorphs case |
	(self innerBounds intersects: aCanvas clipRect) ifFalse: [^self].
	useRegularWarpBlt == true ifTrue: [
		^aCanvas 
			transformBy: transform
			clippingTo: ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) rounded
			during: [:myCanvas |
				submorphs reverseDo:[:m | myCanvas fullDrawMorph: m]
			]
			smoothing: smoothing
	].
	r1 _ self innerBounds intersect: aCanvas clipRect.
	r1 area = 0 ifTrue: [^self].
	fullG _ (transform localBoundsToGlobal: self firstSubmorph fullBounds) rounded.
	r2 _ r1 intersect: fullG.
	r2 area = 0 ifTrue: [^self].
	newClip _ (r2 expandBy: 1) rounded intersect: self innerBounds rounded.
	deferredMorphs _ #().
	aCanvas 
		transform2By: transform		"#transformBy: for pure WarpBlt"
		clippingTo: newClip
		during: [:myCanvas |
			self scale > 1.0 ifTrue: [
				actualCanvas _ MultiResolutionCanvas new initializeFrom: myCanvas.
				actualCanvas deferredMorphs: (deferredMorphs _ OrderedCollection new).
			] ifFalse: [
				actualCanvas _ myCanvas.
			].
			submorphs reverseDo:[:m | actualCanvas fullDrawMorph: m].
		]
		smoothing: smoothing.

	deferredMorphs do: [ :each |
		where _ each bounds: each fullBounds in: self.
		case _ 2.
		case = 1 ifTrue: [where _ where origin rounded extent: where extent rounded].
		case = 2 ifTrue: [where _ where rounded].
		each drawHighResolutionOn: aCanvas in: where.
	].

! !

!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 11/20/2000 18:17'!
extent: aPoint

	| newExtent |

	newExtent _ aPoint truncated.
	bounds extent = newExtent ifTrue: [^self].
	bounds _ bounds topLeft extent: newExtent.
	"self recomputeExtent."

! !

!TransformationB2Morph methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/2000 12:44'!
useRegularWarpBlt: aBoolean

	useRegularWarpBlt _ aBoolean! !
TransformMorph subclass: #TransformationMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Basic'!
!TransformationMorph commentStamp: '<historical>' prior: 0!
A TransformationMorph is like a transformMorph, except that it does not clip, and its bounds include its entire submorph.  TransformationMorphs are assumed to have only one submorph -- the idea is that it is a wrapper that enables its submorph to scale and rotate.  A TMorph may come to have more than one submorph if, eg, a menu sprouts a sub menu, using the transformationMorph temporarily as its world, but this ability is only sparsely supported (as in layoutChanged).!


!TransformationMorph methodsFor: 'initialization' stamp: 'di 2/21/98 14:35'!
asFlexOf: aMorph
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."
	| pos |
	pos _ aMorph position.
	self addMorph: aMorph.
	aMorph position: (aMorph extent // 2) negated.
	self position: pos.
	transform _ transform withOffset: aMorph position - pos
! !

!TransformationMorph methodsFor: 'initialization' stamp: 'di 9/30/1998 23:12'!
flexing: aMorph byTransformation: tfm
	"Initialize me with position and bounds of aMorph,
	and with an offset that provides centered rotation."

	(aMorph isKindOf: TransformationMorph)
		ifTrue: [aMorph submorphsDo: [:m | self addMorph: m clone]]
		ifFalse: [self addMorph: aMorph].
	transform _ tfm.
	self chooseSmoothing.
	self layoutChanged.! !


!TransformationMorph methodsFor: 'accessing' stamp: 'ar 4/18/2000 16:21'!
extent: newExtent
	| scaleFactor |
	self adjustAfter:
		[scaleFactor _ (self scale * newExtent r / self fullBounds extent r) max: 0.1.
		self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]! !

!TransformationMorph methodsFor: 'accessing' stamp: 'jm 4/25/1998 05:55'!
hasNoScaleOrRotation

	^ transform isPureTranslation
! !

!TransformationMorph methodsFor: 'accessing' stamp: 'sw 5/13/1998 10:32'!
innocuousName
	| r |
	^ (r _ self renderedMorph) == self
		ifTrue: [super innocuousName] ifFalse: [r innocuousName]! !

!TransformationMorph methodsFor: 'accessing' stamp: 'jm 4/17/1998 00:44'!
isFlexMorph

	^ true
! !

!TransformationMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 13:46'!
isRenderer

	^ true
! !

!TransformationMorph methodsFor: 'accessing' stamp: 'sw 7/14/1999 16:49'!
printOn: aStream
	super printOn: aStream.
	submorphs size > 0
		ifFalse:
			[aStream nextPutAll: ' with no transformee!!']
		ifTrue:
			[aStream nextPutAll: ' on ', submorphs first printString]! !

!TransformationMorph methodsFor: 'accessing' stamp: 'ar 11/15/1998 23:43'!
referencePosition
	^ transform localPointToGlobal: self renderedMorph referencePosition! !

!TransformationMorph methodsFor: 'accessing' stamp: 'di 2/20/98 14:53'!
rotationDegrees
	^ self angle radiansToDegrees negated! !

!TransformationMorph methodsFor: 'accessing' stamp: 'ar 9/22/2000 14:17'!
rotationDegrees: degrees
	self adjustAfter:[self angle: degrees degreesToRadians negated]! !

!TransformationMorph methodsFor: 'accessing' stamp: 'ar 9/23/2000 13:40'!
scaleToMatch: aPoint
	| scaleFactor tfm originalScale |
	tfm _ transform withScale: 1.0.
	originalScale _ ((tfm localBoundsToGlobal: self renderedMorph fullBounds) corner -
		(tfm localPointToGlobal: self renderedMorph referencePosition)) r.
	"Catch cases where the reference point is on fullBounds corner"
	originalScale < 1.0 ifTrue:[originalScale _ 1.0].
	scaleFactor _ (aPoint - self referencePosition) r / originalScale.
	scaleFactor _ scaleFactor < 1.0
		ifTrue: [scaleFactor detentBy: 0.05 atMultiplesOf: 0.25 snap: false]
		ifFalse: [scaleFactor detentBy: 0.1 atMultiplesOf: 0.5 snap: false].
	self adjustAfter:[self scale: ((scaleFactor min: 8.0) max: 0.1)].! !


!TransformationMorph methodsFor: 'drawing' stamp: 'di 2/23/98 19:59'!
drawOn: aCanvas
	submorphs isEmpty ifTrue: [super drawOn: aCanvas]! !


!TransformationMorph methodsFor: 'change reporting' stamp: 'ar 10/25/2000 16:21'!
layoutChanged
	"Recompute bounds as a result of change"
	self computeBounds.
	super layoutChanged! !


!TransformationMorph methodsFor: 'menu' stamp: 'ar 9/27/2000 14:01'!
removeFlexShell
	"Remove the shell used to make a morph rotatable and scalable."

	| oldHalo unflexed pensDown player myWorld refPos |
	refPos _ self referencePosition.
	myWorld _ self world.
	oldHalo _ self halo.
	submorphs isEmpty ifTrue: [^ self delete].
	unflexed _ self firstSubmorph.
	pensDown _ OrderedCollection new.
	self allMorphsDo:  "Note any pens down -- must not be down during the move"
		[:m | ((player _ m player) notNil and: [player getPenDown]) ifTrue:
			[m == player costume ifTrue:
				[pensDown add: player.
				player setPenDown: false]]].
	self submorphs do: [:m |
		m position: self center - (m extent // 2).
		owner addMorph: m].
	unflexed absorbStateFromRenderer: self.
	pensDown do: [:p | p setPenDown: true].
	oldHalo ifNotNil: [oldHalo setTarget: unflexed].
	myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed].
	self delete.
	unflexed referencePosition: refPos.
	^ unflexed! !


!TransformationMorph methodsFor: 'private' stamp: 'di 9/30/1998 22:49'!
adjustAfter: changeBlock 
	"Cause this morph to remain cetered where it was before, and
	choose appropriate smoothing, after a change of scale or rotation."
	| oldRefPos |
	oldRefPos _ self referencePosition.
	changeBlock value.
	self chooseSmoothing.
	self penUpWhile: [self position: self position + (oldRefPos - self referencePosition)].
	self layoutChanged.
	owner ifNotNil: [owner invalidRect: bounds]
! !

!TransformationMorph methodsFor: 'private' stamp: 'di 10/16/1999 16:48'!
chooseSmoothing
	"Choose appropriate smoothing, after a change of scale or rotation."

	(self scale < 1.0 or: [self angle ~= (self angle roundTo: Float pi / 2.0)])
		ifTrue: [smoothing _ 2]
		ifFalse: [smoothing _ 1]! !

!TransformationMorph methodsFor: 'private' stamp: 'di 11/18/1999 15:44'!
replaceSubmorph: oldMorph by: newMorph
	| t b |
	t _ transform.
	b _ bounds.
	super replaceSubmorph: oldMorph by: newMorph.
	transform _ t.
	bounds _ b.
	self layoutChanged! !


!TransformationMorph methodsFor: 'e-toy support' stamp: 'di 10/1/2000 11:48'!
degreesOfFlex
	"Return any rotation due to flexing"
	^ self rotationDegrees! !

!TransformationMorph methodsFor: 'e-toy support' stamp: 'ar 9/22/2000 20:44'!
forwardDirection
	^self renderedMorph forwardDirection! !

!TransformationMorph methodsFor: 'e-toy support' stamp: 'ar 9/22/2000 20:44'!
forwardDirection: degrees
	^self renderedMorph forwardDirection: degrees! !

!TransformationMorph methodsFor: 'e-toy support' stamp: 'ar 9/22/2000 13:38'!
heading
	^self renderedMorph heading! !

!TransformationMorph methodsFor: 'e-toy support' stamp: 'ar 9/22/2000 13:38'!
heading: newHeading
	self renderedMorph heading: newHeading! !


!TransformationMorph methodsFor: 'dropping/grabbing' stamp: 'ar 10/22/2000 18:26'!
grabTransform
	"Return the transform for the receiver which should be applied during grabbing"
	self renderedMorph isWorldMorph 
		ifTrue:[^owner ifNil:[IdentityTransform new] ifNotNil:[owner grabTransform]].
	^owner ifNil:[self transform] ifNotNil:[owner grabTransform composedWithLocal: self transform]! !


!TransformationMorph methodsFor: 'geometry' stamp: 'ar 11/21/2000 17:00'!
computeBounds
	self hasSubmorphs ifTrue:
		[bounds _ (transform localBoundsToGlobal:
					(Rectangle merging:
						(self submorphs collect: [:m | m fullBounds]))) truncated
				expandBy: 1].
	fullBounds _ bounds.! !

!TransformationMorph methodsFor: 'geometry' stamp: 'ar 10/25/2000 16:24'!
transformedBy: aTransform
	self changed.
	self transform: (self transform composedWithGlobal: aTransform).
	self computeBounds.
	self changed.! !


!TransformationMorph methodsFor: 'stepping and presenter' stamp: 'mdr 10/3/2000 11:28'!
stepTime
	"Answer the stepTime of my rendered morph if posible"

	| rendered |
	rendered _ self renderedMorph.
	rendered = self ifTrue: [^super stepTime].	"Hack to avoid infinite recursion"
	^rendered stepTime.
	! !
Morph subclass: #TransitionMorph
	instanceVariableNames: 'startMorph endMorph startBlock completionBlock stepNumber nSteps stepTime startForm endForm effect direction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!TransitionMorph commentStamp: '<historical>' prior: 0!
A transitionMorph inserts itself in the morphic object structure during a visual transition.  It has a stepNumber that runs from 1 to nSteps.  This class handles a large family of wipe-like transitions by itself.  Subclasses may implement other transitions such as dissolves and zooms.!


!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 12:52'!
completeReplacement

	self delete.
	completionBlock value! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 1/2/1999 20:55'!
initiateReplacement
	| n |
	startForm _ effect = #dissolve
		ifTrue: [(startMorph imageForm: 16 forRectangle: bounds) offset: 0@0]
		ifFalse: [(startMorph imageFormForRectangle: bounds) offset: 0@0].
	endForm _ (endMorph imageFormForRectangle: bounds) offset: 0@0.

	nSteps == nil ifTrue:
		[self nSteps: 30 stepTime: 10.
		(#(zoom pageForward pageBack) includes: effect) ifTrue:
			[n _ 20 * 100000 // self bounds area min: 20 max: 4.
			self nSteps: n stepTime: 10].
		(#dissolve = effect) ifTrue:
			[n _ 20 * 50000 // self bounds area min: 20 max: 4.
			self nSteps: n stepTime: 10]].

	startBlock value.  "with forms in place there should b no further delay."
	self arrangeToStartStepping.
! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/14/1998 12:25'!
nSteps: n stepTime: msPerStep
	nSteps _ n.
	stepTime _ msPerStep! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 13:32'!
showTransitionFrom: startingMorph to: endingMorph in: containingMorph
	whenStart: firstBlock whenDone: doneBlock

	effect == #none ifTrue: [firstBlock value.  ^ doneBlock value].

	self startMorph: startingMorph endMorph: endingMorph
		startBlock: firstBlock completionBlock: doneBlock.
	stepNumber _ 0.

	self bounds: startingMorph bounds.
	endingMorph privateOwner: self.  "Allows test of transition in progress"
	containingMorph owner privateAddMorph: self atIndex: 
		(containingMorph owner submorphs indexOf: containingMorph).

	self initiateReplacement! !

!TransitionMorph methodsFor: 'initialization' stamp: 'di 12/20/1998 10:46'!
startMorph: start endMorph: end startBlock: firstBlock completionBlock: aBlock
	startMorph _ start.
	endMorph _ end.
	startBlock _ firstBlock.
	completionBlock _ aBlock! !


!TransitionMorph methodsFor: 'drawing' stamp: 'di 1/5/1999 08:37'!
areasRemainingToFill: aRectangle
	"May be overridden by any subclasses with opaque regions"

	^ aRectangle areasOutside: self bounds! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawDissolveOn: aCanvas
	"startForm and endFrom are both fixed, but the dissolve ration changes."

	startForm copyBits: endForm at: 0@0 translucent: stepNumber asFloat / (nSteps*2).

	aCanvas drawImage: startForm at: self position.
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawFrenchDoorOn: aCanvas
	"startForm and endFrom are both fixed, but a border expands out from a vertical (or H) slit, revealing endForm.
	It's like opening a pair of doors."
	| box innerForm outerForm boxExtent h w |
	h _ self height. w _ self width.
	direction = #in ifTrue: [innerForm _ endForm.  outerForm _ startForm.
							boxExtent _ self stepFrom: 0@h to: self extent].
	direction = #out ifTrue: [innerForm _ startForm.  outerForm _ endForm.
							boxExtent _ self stepFrom: self extent to: 0@h].
	direction = #inH ifTrue: [innerForm _ endForm.  outerForm _ startForm.
							boxExtent _ self stepFrom: w@0 to: self extent].
	direction = #outH ifTrue: [innerForm _ startForm.  outerForm _ endForm.
							boxExtent _ self stepFrom: self extent to: w@0].
		
	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated).

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'di 12/22/1998 20:58'!
drawOn: aCanvas
	"During the transition process, the reveal and obscure areas will be invalidated,
	so we should be drawing on a canvas that clips to only the changing region."

	(stepNumber between: 1 and: nSteps) ifFalse: [^ self].
	effect = #slideOver ifTrue: [^ self drawSlideOverOn: aCanvas].
	effect = #slideBoth ifTrue: [^ self drawSlideBothOn: aCanvas].
	effect = #slideAway ifTrue: [^ self drawSlideAwayOn: aCanvas].
	effect = #slideBorder ifTrue: [^ self drawSlideBorderOn: aCanvas].
	effect = #pageForward ifTrue: [^ self drawPageForwardOn: aCanvas].
	effect = #pageBack ifTrue: [^ self drawPageBackOn: aCanvas].
	effect = #frenchDoor ifTrue: [^ self drawFrenchDoorOn: aCanvas].
	effect = #zoomFrame ifTrue: [^ self drawZoomFrameOn: aCanvas].
	effect = #zoom ifTrue: [^ self drawZoomOn: aCanvas].
	effect = #dissolve ifTrue: [^ self drawDissolveOn: aCanvas].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'!
drawPageBackOn: aCanvas
	"endForm grows in the given direction, overlaying endForm."
	| offset growRect scale |
	aCanvas drawImage: startForm at: self position.

	offset _ self stepFrom: self extent * direction negated to: 0@0.
	growRect _ (bounds translateBy: offset) intersect: bounds.
	scale _ growRect extent asFloatPoint / bounds extent.
	aCanvas drawImage: (endForm magnify: endForm boundingBox by: scale smoothing: 1)
		at: growRect topLeft.

	((growRect translateBy: direction) areasOutside: growRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawPageForwardOn: aCanvas
	"startForm shrinks in the given direction, revealing endForm."
	| offset shrinkRect scale |
	aCanvas drawImage: endForm at: self position.

	offset _ self stepFrom: 0@0 to: self extent * direction.
	shrinkRect _ (bounds translateBy: offset) intersect: bounds.
	scale _ shrinkRect extent asFloatPoint / bounds extent.
	aCanvas drawImage: (startForm magnify: startForm boundingBox by: scale smoothing: 1)
		at: shrinkRect topLeft.

	((shrinkRect translateBy: direction negated) areasOutside: shrinkRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideAwayOn: aCanvas
	"startMorph slides away in the given direction, revealing up the endMorph."
	| startLoc moveRect |
	startLoc _ self stepFrom: self position to: self position + (self extent * direction).
	moveRect _ startForm boundingBox translateBy: startLoc.

	aCanvas drawImage: endForm at: self position.
	aCanvas drawImage: startForm at: startLoc.

	((moveRect translateBy: direction negated) areasOutside: moveRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideBorderOn: aCanvas
	"startForm and endFrom are both fixed, but a border slides in the given direction, revealing endForm.  (It's like opening a can of sardines ;-)."
	| endRect box sourceRect boxLoc |
	box _ endForm boundingBox.
	boxLoc _ self stepFrom: box topLeft - (box extent * direction) to: box topLeft.
	sourceRect _ box translateBy: boxLoc.
	endRect _ sourceRect translateBy: self position.

	((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse:
		[aCanvas drawImage: startForm at: self position].
	aCanvas drawImage: endForm at: self position + boxLoc sourceRect: sourceRect.

	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'!
drawSlideBothOn: aCanvas
	"endMorph slides in the given direction, as startMorph slides out of its way."
	| endLoc endRect startLoc |
	startLoc _ self stepFrom: self position to: self position + (self extent * direction).
	aCanvas drawImage: startForm at: startLoc.

	endLoc _ self stepFrom: self position - (self extent * direction) to: self position.
	aCanvas drawImage: endForm at: endLoc.

	endRect _ endForm boundingBox translateBy: endLoc.
	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawSlideOverOn: aCanvas
	"endMorph slides in the given direction, covering up the startMorph."
	| endLoc endRect |
	endLoc _ self stepFrom: self position - (self extent * direction) to: self position.
	endRect _ endForm boundingBox translateBy: endLoc.

	((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse:
		[aCanvas drawImage: startForm at: self position].
	aCanvas drawImage: endForm at: endLoc.

	((endRect translateBy: direction) areasOutside: endRect) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawZoomFrameOn: aCanvas
	"startForm and endFrom are both fixed, but a square border expands out from the center (or back), revealing endForm.
	It's like passing through a portal."
	| box innerForm outerForm boxExtent |
	direction = #in
		ifTrue: [innerForm _ endForm.  outerForm _ startForm.
				boxExtent _ self stepFrom: 0@0 to: self extent]
		ifFalse: [innerForm _ startForm.  outerForm _ endForm.
				boxExtent _ self stepFrom: self extent to: 0@0].
		
	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated).

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !

!TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'!
drawZoomOn: aCanvas
	"Zoom in: endForm expands overlaying startForm.
	Zoom out: startForm contracts revealing endForm."
	| box innerForm outerForm boxExtent scale |
	direction = #in
		ifTrue: [innerForm _ endForm.  outerForm _ startForm.
				boxExtent _ self stepFrom: 0@0 to: self extent]
		ifFalse: [innerForm _ startForm.  outerForm _ endForm.
				boxExtent _ self stepFrom: self extent to: 0@0].

	aCanvas drawImage: outerForm at: self position.

	box _ Rectangle center: self center extent: boxExtent.
	scale _ box extent asFloatPoint / bounds extent.
	aCanvas drawImage: (innerForm magnify: innerForm boundingBox by: scale smoothing: 1)
		at: box topLeft.

	((box expandBy: 1) areasOutside: box) do:
		[:r | aCanvas fillRectangle: r color: Color black].
! !


!TransitionMorph methodsFor: 'change reporting' stamp: 'di 12/22/1998 20:59'!
changed
	"The default (super) method is, generally much slower than need be, since many transitions only change part of the screen on any given step of the animation.  The purpose of this method is to effect some of those savings."
	| loc box boxPrev h w |
	(stepNumber between: 1 and: nSteps) ifFalse: [^ super changed].
	effect = #slideBoth ifTrue: [^ super changed].
	effect = #slideOver ifTrue:
		[loc _ self stepFrom: self position - (self extent * direction) to: self position.
		^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)].
	effect = #slideAway ifTrue:
		[loc _ self prevStepFrom: self position to: self position + (self extent * direction).
		^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)].
	effect = #slideBorder ifTrue:
		[box _ endForm boundingBox translateBy:
				(self stepFrom: self topLeft - (self extent * direction) to: self topLeft).
		boxPrev _ endForm boundingBox translateBy:
				(self prevStepFrom: self topLeft - (self extent * direction) to: self topLeft).
		^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
	effect = #pageForward ifTrue:
		[loc _ self prevStepFrom: 0@0 to: self extent * direction.
		^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)].
	effect = #pageBack ifTrue:
		[loc _ self stepFrom: self extent * direction negated to: 0@0.
		^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)].
	effect = #frenchDoor ifTrue:
		[h _ self height. w _ self width.
		direction = #in ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: 0@h to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: 0@h to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #out ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: 0@h).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: 0@h).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box].
		direction = #inH ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: w@0 to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: w@0 to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #outH ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: w@0).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: w@0).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]].
	effect = #zoomFrame ifTrue:
		[direction = #in ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: 0@0 to: self extent).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: 0@0 to: self extent).
			^ self invalidate: (box expandBy: 1) areasOutside: boxPrev].
		direction = #out ifTrue:
			[box _ Rectangle center: self center
							extent: (self stepFrom: self extent to: 0@0).
			boxPrev _ Rectangle center: self center
							extent: (self prevStepFrom: self extent to: 0@0).
			^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]].
	effect = #zoom ifTrue:
		[box _ Rectangle center: self center extent:
			(direction = #in
				ifTrue: [self stepFrom: 0@0 to: self extent]
				ifFalse: [self prevStepFrom: self extent to: 0@0]).
		^ self invalidRect: ((box expandBy: 1) intersect: bounds)].
	^ super changed
! !

!TransitionMorph methodsFor: 'change reporting' stamp: 'di 12/22/1998 20:10'!
invalidate: box1 areasOutside: box2

	((box1 intersect: bounds) areasOutside: (box2 intersect: bounds))
		do: [:r | self invalidRect: r]! !


!TransitionMorph methodsFor: 'stepping' stamp: 'di 12/14/1998 12:30'!
step
	(stepNumber _ stepNumber + 1) <= nSteps
		ifTrue: [self changed]
		ifFalse: [self completeReplacement]! !

!TransitionMorph methodsFor: 'stepping' stamp: 'di 12/15/1998 13:52'!
stepTime
	^ stepTime! !


!TransitionMorph methodsFor: 'private' stamp: 'di 12/22/1998 21:01'!
effect: effectSymbol direction: dirSymbol
	| i |
	effect _ effectSymbol.

	"Default directions"
	(#(zoom zoomFrame frenchDoor) includes: effectSymbol)
		ifTrue: [(#(in out inH outH) includes: dirSymbol)
					ifTrue: [direction _ dirSymbol]
					ifFalse: [direction _ #in]]
		ifFalse: [i _ #(right downRight down downLeft left upLeft up upRight)
						indexOf: dirSymbol ifAbsent: [5].
				direction _ (0@0) eightNeighbors at: i].! !

!TransitionMorph methodsFor: 'private' stamp: 'di 12/15/1998 11:42'!
prevStepFrom: p1 to: p2
	"Used for recalling dimensions from previous step."

	^ (p2-p1) * (stepNumber-1) // nSteps + p1! !

!TransitionMorph methodsFor: 'private' stamp: 'di 12/14/1998 12:43'!
stepFrom: p1 to: p2
	"This gives p1 for stepCount = 0, moving to p2 for stepCount = nSteps"

	^ (p2-p1) * stepNumber // nSteps + p1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TransitionMorph class
	instanceVariableNames: ''!

!TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 22:01'!
effect: effectSymbol direction: dirSymbol
	^ self new effect: effectSymbol direction: dirSymbol! !

!TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 21:37'!
effect: effectSymbol direction: dirSymbol inverse: inverse
	| invEffect invDir i dirSet |
	inverse ifFalse: [^ self effect: effectSymbol direction: dirSymbol].

	invEffect _ effectSymbol.
	effectSymbol = #pageForward ifTrue: [invEffect _ #pageBack].
	effectSymbol = #pageBack ifTrue: [invEffect _ #pageForward].
	effectSymbol = #slideOver ifTrue: [invEffect _ #slideAway].
	effectSymbol = #slideAway ifTrue: [invEffect _ #slideOver].

	invDir _ dirSymbol.
	dirSet _ self directionsForEffect: effectSymbol.
	(i _ dirSet indexOf: dirSymbol) > 0
		ifTrue: [invDir _ dirSet atWrap: i + (dirSet size // 2)].

	^ self effect: invEffect direction: invDir! !

!TransitionMorph class methodsFor: 'initialization' stamp: 'di 11/16/1998 15:37'!
includeInNewMorphMenu
	"Transitions aren't meaningful without initializations"
	^ false! !


!TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:58'!
allEffects
	^ #(none
		slideOver slideBoth slideAway slideBorder
		pageForward pageBack 
		frenchDoor
		zoomFrame zoom
		dissolve)! !

!TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:59'!
directionsForEffect: eff
	 "All these arrays are ordered so inverse is atWrap: size//2."
	(#(slideOver slideBoth slideAway slideBorder) includes: eff)
		ifTrue: [^ #(right downRight down downLeft left upLeft up upRight)].
	(#(pageForward pageBack) includes: eff)
		ifTrue: [^ #(right down left up)].
	(#(frenchDoor) includes: eff)
		ifTrue: [^ #(in inH out outH)].
	(#(zoomFrame zoom) includes: eff)
		ifTrue: [^ #(in out)].
	^ Array new! !
ArrayedCollection variableSubclass: #TranslatedMethod
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TranslatedMethod class
	instanceVariableNames: ''!

!TranslatedMethod class methodsFor: 'class initialization' stamp: 'ikp 1/10/98 02:34'!
initialize
	self becomeCompact.
	Smalltalk recreateSpecialObjectsArray.
	Smalltalk specialObjectsArray size = 41
		ifFalse: [self error: 'Please check size of special objects array!!']! !
Color subclass: #TranslucentColor
	instanceVariableNames: 'alpha '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!TranslucentColor commentStamp: '<historical>' prior: 0!
A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue.  This allows creating forms with translucency for use with the alpha blend function of BitBlt.  An alpha of zero is transparent, and 1.0 is opaque.!


!TranslucentColor methodsFor: 'accessing'!
alpha
	"Return my alpha value, a number between 0.0 and 1.0 where 0.0 is completely transparent and 1.0 is completely opaque."

	^ alpha asFloat / 255.0
! !


!TranslucentColor methodsFor: 'equality'!
hash

	^ rgb bitXor: alpha
! !


!TranslucentColor methodsFor: 'printing' stamp: 'mir 7/21/1999 11:43'!
storeArrayValuesOn: aStream

	self isTransparent ifTrue: [
		^ aStream space].
	super storeArrayValuesOn: aStream.

	aStream space.
	(self alpha roundTo: 0.001) storeOn: aStream.

! !

!TranslucentColor methodsFor: 'printing' stamp: 'di 9/27/2000 13:33'!
storeOn: aStream

	self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)'].
	super storeOn: aStream.
	aStream
		skip: -1;	  "get rid of trailing )"
		nextPutAll: ' alpha: ';
		print: (self alpha roundTo: 0.001);
		nextPutAll: ')'.
! !


!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/15/1999 11:44'!
alpha: alphaValue
	alphaValue = 1.0 ifTrue:
		[^ Color basicNew
			setPrivateRed: self privateRed
			green: self privateGreen
			blue: self privateBlue].
	^ super alpha: alphaValue! !

!TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'!
asNontranslucentColor
	^ self alpha: 1.0! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 3/25/2000 17:56'!
balancedPatternForDepth: depth
	"Return an appropriate bit pattern or stipple.  This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency."

	alpha = 0 ifTrue: [^ Bitmap with: 0].
	^ super balancedPatternForDepth: depth! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/14/1999 20:05'!
bitPatternForDepth: depth
	"Return an appropriate bit pattern or stipple.  This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency."

	alpha = 0 ifTrue: [^ Bitmap with: 0].
	^ super bitPatternForDepth: depth! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/6/1999 16:15'!
pixelValueForDepth: d
	"Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths."

	alpha = 0 ifTrue: [^ 0].
	^ super pixelValueForDepth: d! !

!TranslucentColor methodsFor: 'conversions' stamp: 'di 1/6/1999 16:14'!
pixelWordForDepth: depth
	"Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths."

	| basicPixelWord |
	alpha = 0 ifTrue: [^ 0].
	basicPixelWord _ super pixelWordForDepth: depth.
	depth < 32
		ifTrue: [^ basicPixelWord]
		ifFalse: [^ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: (alpha bitShift: 24)].
! !

!TranslucentColor methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:30'!
scaledPixelValue32
	"Return the alpha scaled pixel value for depth 32"
	| pv32 a b g r |
	pv32 _ super scaledPixelValue32.
	a _ (self alpha * 255.0) rounded.
	b _ (pv32 bitAnd: 255) * a // 256.
	g _ ((pv32 bitShift: -8) bitAnd: 255) * a // 256.
	r _ ((pv32 bitShift: -16) bitAnd: 255) * a // 256.
	^b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! !


!TranslucentColor methodsFor: 'private'!
privateAlpha
	"Return my raw alpha value, an integer in the range 0..255. Used for fast equality testing."

	^ alpha
! !

!TranslucentColor methodsFor: 'private'!
setRgb: rgbValue alpha: alphaValue
	"Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255."

	rgb == nil ifFalse: [self attemptToMutateError].
	rgb _ rgbValue.
	alpha _ (255.0 * alphaValue) asInteger min: 255 max: 0.
! !


!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTranslucent
	^ alpha < 255! !

!TranslucentColor methodsFor: 'queries' stamp: 'di 1/3/1999 12:22'!
isTranslucentColor
	"This means: self isTranslucent, but isTransparent not"
	^ alpha > 0! !

!TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'!
isTransparent
	^ alpha = 0! !


!TranslucentColor methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:50'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"1/13/1999 -- old versions did not have alpha??"
	varDict at: 'alpha' ifAbsent: [^ Color transparent].

	^super convertToCurrentVersion: varDict refStream: smartRefStrm.
	! !
Morph subclass: #TranslucentProgessMorph
	instanceVariableNames: 'opaqueBackgroundColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/29/2000 17:22'!
drawOn: aCanvas

	| revealPercentage revealingStyle revealingColor revealingBounds revealToggle x baseColor revealTimes secondsRemaining scanner stringToDraw where fontToUse innerBounds |
	
	innerBounds _ bounds.
	opaqueBackgroundColor ifNotNil: [
		aCanvas 
			frameAndFillRectangle: bounds
			fillColor: opaqueBackgroundColor
			borderWidth: 8
			borderColor: Color blue.
		innerBounds _ innerBounds insetBy: 8.
	].
	revealTimes _ (self valueOfProperty: #revealTimes) ifNil: [^self].
	revealPercentage _ (revealTimes first / revealTimes second) asFloat.
	revealingStyle _ self revealingStyle.
	x _ self valueOfProperty: #progressStageNumber ifAbsent: [1].
	baseColor _ Color perform: (#(red blue green magenta cyan yellow) atPin: x).
	revealingColor _ baseColor alpha: 0.2.
	revealingStyle = 3 ifTrue: [	"wrap and change color"
		revealPercentage > 1.0 ifTrue: [
			revealingColor _ baseColor alpha: (0.2 + (revealingStyle / 10) min: 0.5).
		].
		revealPercentage _ revealPercentage fractionPart.
	].
	revealingStyle = 2 ifTrue: [	"peg at 75 and blink"
		revealPercentage > 0.75 ifTrue: [
			revealToggle _ self valueOfProperty: #revealToggle ifAbsent: [true].
			self setProperty: #revealToggle toValue: revealToggle not.
			revealToggle ifTrue: [revealingColor _ baseColor alpha: 0.8.].
		].
		revealPercentage _ revealPercentage min: 0.75.
	].
	revealingBounds _ innerBounds withLeft: innerBounds left + (innerBounds width * revealPercentage) truncated.
	aCanvas 
		fillRectangle: revealingBounds
		color: revealingColor.
	secondsRemaining _ (revealTimes second - revealTimes first / 1000) rounded.
	secondsRemaining > 0 ifTrue: [
		fontToUse _ StrikeFont familyName: 'ComicBold' size: 24.
		scanner _ DisplayScanner
			quickPrintOn: aCanvas form 
			box: innerBounds 
			font: fontToUse 
			color: Color black.
		stringToDraw _ secondsRemaining printString.
		where _ innerBounds corner - ((scanner stringWidth: stringToDraw) @ scanner lineHeight).
		scanner 
			drawString: stringToDraw 
			at: where.
		scanner _ DisplayScanner
			quickPrintOn: aCanvas form 
			box: innerBounds 
			font: fontToUse 
			color: Color white.
		scanner 
			drawString: stringToDraw 
			at: where - (1@1).
	]. 


! !

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/19/2000 18:52'!
morphicLayerNumber

	"helpful for insuring some morphs always appear in front of or behind others.
	smaller numbers are in front"

	^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].

	"progress morphs are behind menus and balloons, but in front of most other stuff"! !

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/29/2000 11:35'!
opaqueBackgroundColor: aColor

	opaqueBackgroundColor _ aColor! !

!TranslucentProgessMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/23/2000 11:19'!
revealingStyle

">>>>
	1 = original, no change after 100%
	2 = hold at last 25% and blink until done
	3 = wrap around from 100% back to 0 and go again. change color after first
<<<<"
	^3
! !
ThreePhaseButtonMorph subclass: #TrashCanMorph
	instanceVariableNames: ''
	classVariableNames: 'TrashPic TrashPicOn '
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!TrashCanMorph methodsFor: 'initialization' stamp: 'sw 8/29/2000 15:07'!
initialize
	"Initialize the receiver's graphics, name, and balloon-help"

	super initialize.
	self image: TrashPicOn;
		offImage: TrashPic;
		pressedImage: TrashPicOn.
	self setNameTo: 'Trash'.
	self setBalloonText:
'To remove an object, drop it on a trash can.'.
! !


!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:14'!
doubleClick: evt
	| palette |
	palette _ self standardPalette.
	((palette notNil and: [palette isInWorld]) and: [palette hasScrapsTab])
		ifTrue:
			[palette showScrapsTab]
		ifFalse:
			[self world openScrapsBook: evt].! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 7/3/1998 13:17'!
handlesDragOver: evt

	^ self inPartsBin not
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 10/6/2000 00:17'!
handlesMouseDown: evt

	^ self inPartsBin not! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 7/3/1998 13:33'!
handlesMouseOver: evt

	^ self inPartsBin not
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 07:51'!
handlesMouseOverDragging: evt

	^ self inPartsBin not
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:02'!
mouseDown: evt
	| paintBox |
	evt hand visible: true.
	"See if a stamp is being dropped into the trash. It is not held by the hand."
	(paintBox _ self findActivePaintBox) ifNotNil: [
		paintBox getSpecial == #stamp: ifTrue: [
			paintBox deleteCurrentStamp: evt.  "throw away stamp..."
			self primaryHand showTemporaryCursor: nil.
			^ self]].	  "... and don't open trash"
	evt hand waitForClicksOrDrag: self event: evt.
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:13'!
mouseEnter: event
	"Present feedback for potential deletion."
	| hand firstSub |
	hand _ event hand.
	(((hand submorphCount > 0) and: [(firstSub _ hand submorphs first) ~~ self]) and:
			[self wantsDroppedMorph: firstSub event: event])
		ifTrue: 
			[Preferences soundsEnabled ifTrue: [self class playMouseEnterSound].
			hand visible: false.
			self world abandonAllHalos.
			self state: #pressed]
		ifFalse:
			[self showStampIn: hand]
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseEnterDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseEnter: evt! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 10/5/2000 16:18'!
mouseLeave: event
	"Present feedback for aborted deletion."
	| hand |
	hand _ event hand.
	((hand submorphCount > 0) and:
	 [hand submorphs first ~~ self])
		ifTrue:
			[Preferences soundsEnabled ifTrue: [self class playMouseLeaveSound].
			hand visible: true.
			self state: #off]
		ifFalse:
			[self stopShowingStampIn: hand].
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:08'!
mouseLeaveDragging: evt
	"Test button state elsewhere if at all"
	^ self mouseLeave: evt! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:13'!
mouseMove: evt
	| hand firstSub |
	hand _ evt hand.
	(((hand submorphCount > 0) and: [(firstSub _ hand submorphs first) ~~ self]) and:
			[self wantsDroppedMorph: firstSub event: evt])
		ifTrue: 
			[super mouseMove: evt]
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'jm 5/22/1998 10:35'!
mouseUp: evt
	"Close the lid when you're through!!"

	self state: #off.
! !

!TrashCanMorph methodsFor: 'event handling' stamp: 'ar 12/11/2000 12:08'!
startDrag: evt
	evt hand grabMorph: self.! !


!TrashCanMorph methodsFor: 'dropping' stamp: 'ar 10/5/2000 16:18'!
acceptDroppingMorph: aMorph event: evt

	Preferences soundsEnabled ifTrue:
		[Preferences preserveTrash 
			ifFalse:
				[self playSoundNamed: 'scratch']
			ifTrue:
				[self class playDeleteSound]].

	evt hand visible: true.
	self state: #off.
	aMorph delete.
	aMorph == Utilities scrapsBook ifFalse:
		[Utilities addToTrash: aMorph]! !

!TrashCanMorph methodsFor: 'dropping' stamp: 'sw 8/15/2000 17:03'!
wantsDroppedMorph: aMorph event: evt

	^ ((aMorph ~~ self) and: [aMorph ~~ Utilities scrapsBook]) and:
		[aMorph willingToBeDiscarded]! !


!TrashCanMorph methodsFor: 'private' stamp: 'sw 8/22/1998 22:44'!
findActivePaintBox
	"If painting, return the active PaintBoxMorph. If not painting, or if the paint box cannot be found, return nil."

	| w m |
	w _ self world.
	w ifNil: [^ nil].
	(w findA: SketchEditorMorph) ifNil: [^ nil].  "not painting"
	(m _ w findA: PaintBoxMorph) ifNotNil: [^ m].
	^ nil
! !

!TrashCanMorph methodsFor: 'private' stamp: 'jm 5/22/1998 10:13'!
showStampIn: aHand
	"If painting and in stamp mode, show the stamp that is about to be thrown away."

	| paintBox curs |
	paintBox _ self findActivePaintBox.
	paintBox ifNotNil: [
		"See if a stamp is being dropped into the trash. It is not actually held by the hand."
		paintBox getSpecial == #stamp: ifTrue: [
			curs _ paintBox actionCursor.
			aHand showTemporaryCursor: curs hotSpotOffset: curs center]].
! !

!TrashCanMorph methodsFor: 'private' stamp: 'jm 5/22/1998 10:16'!
stopShowingStampIn: aHand
	"Revert to the normal cursor."

	aHand showTemporaryCursor: nil.
! !


!TrashCanMorph methodsFor: 'other' stamp: 'sw 9/14/1998 12:02'!
printOn: aStream
	aStream nextPutAll: 'a TrashCanMorph'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TrashCanMorph class
	instanceVariableNames: ''!

!TrashCanMorph class methodsFor: 'miscellaneous' stamp: 'sw 8/18/1999 19:55'!
moveToTrash: aMorph
	Preferences soundsEnabled ifTrue:
		[Preferences preserveTrash 
			ifFalse:
				[self playSoundNamed: 'scratch']
			ifTrue:
				[self playDeleteSound]].

	aMorph delete.
	aMorph == Utilities scrapsBook ifFalse:
		[Utilities addToTrash: aMorph]! !


!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:00'!
playDeleteSound
	"TrashCanMorph playDeleteSound"

	| snd |
	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		snd _ sampledSound
			samples: self samplesForDelete
			samplingRate: 22050.
		snd play].
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:01'!
playMouseEnterSound
	"TrashCanMorph playMouseEnterSound"

	| snd |
	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		snd _ sampledSound
				samples: self samplesForMouseEnter
			samplingRate: 22050.
		snd play].
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:03'!
playMouseLeaveSound
	"TrashCanMorph playMouseLeaveSound"

	| snd |
	Smalltalk at: #SampledSound ifPresent: [:sampledSound |
		snd _ sampledSound
			samples: self samplesForMouseLeave
				samplingRate: 22050.
		snd play].
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:00'!
samplesForDelete

	^ #(0 11 5 18 42 35 28 54 42 59 52 44 16 18 33 6 -39 -30 -39 -37 -61 -61 -55 -83 -71 -42 -66 -45 -61 -40 -22 1 -3 33 61 69 44 59 59 64 44 81 62 79 91 62 45 55 1 -8 -10 -1 -16 -33 -20 -57 -54 -18 10 5 -1 -6 25 62 47 49 79 52 20 50 76 94 74 91 100 94 69 67 76 76 44 71 62 64 91 93 96 113 93 125 120 108 76 67 79 54 79 69 64 83 37 39 35 6 -13 -57 -62 -52 -79 -94 -100 -78 -105 -101 -59 -69 -64 -25 -55 -33 -57 -33 -39 -33 -16 -16 -16 -30 -25 -1 -27 -32 -39 -44 -1 -18 -23 -61 -55 -45 -67 -74 -47 -23 -22 -55 -50 -18 -47 -39 -22 -32 -28 -45 -28 -50 -69 -83 -83 -66 -93 -84 -74 -74 -84 -76 -94 -52 -69 -62 -35 -3 11 -16 28 5 -10 0 3 25 -1 20 32 25 44 59 18 11 -32 0 -11 -28 -55 -67 -62 -64 -57 -49 -76 -239 -980 -1731 -1565 -478 1153 2646 2919 1799 -1385 -5482 -8325 -8427 -4347 2556 9606 13864 12797 7894 731 -6395 -9218 -6222 1491 9207 12724 10783 3258 -6050 -12631 -14020 -9175 -454 8771 14419 13457 7050 -1679 -8875 -11346 -7670 960 10478 16383 15908 10112 2191 -5150 -8398 -6123 644 8334 12364 11062 5163 -2966 -9760 -12327 -9012 -1947 4977 8880 8495 4412 -1704 -6697 -7935 -5491 -186 5557 9289 9235 4955 -819 -4990 -5843 -3005 2128 7204 9606 7728 2439 -3872 -8469 -9930 -7226 -1385 4532 7567 6452 2154 -3136 -7248 -8045 -4493 1794 7582 10089 8636 3994 -1994 -6473 -7257 -3774 1894 6760 9011 7177 1979 -4364 -8760 -9067 -5465 332 5596 7764 5742 284 -5345 -8517 -7840 -3480 2838 8592 10639 7918 2485 -3435 -7177 -7341 -3630 2542 7333 8449 5514 15 -5645 -9192 -8368 -3540 3111 8083 9218 6558 941 -5119 -8500 -7748 -2905 3329 8259 9891 6975 1192 -4921 -8285 -7411 -3123 3090 7961 9206 5967 -130 -5728 -8793 -7886 -3061 3637 8965 9864 6471 683 -5121 -8324 -7547 -2720 3679 8050 8714 5236 -373 -6032 -9138 -7679 -2653 3679 8166 8982 5906 -111 -5825 -8561 -7094 -2091 3874 8412 9128 5533 -361 -5918 -8320 -6939 -2222 4016 8376 8831 4987 -943 -6130 -8678 -7102 -2117 4149 8322 8296 4768 -744 -5827 -8144 -6444 -1172 4732 8463 8412 4659 -1111 -6519 -8782 -6838 -1876 3818 7423 7601 3966 -1852 -6722 -8505 -6354 -1297 4366 8266 8217 4386 -1206 -5891 -7589 -5647 -595 5092 8402 7645 3372 -2274 -7031 -8958 -6814 -1560 4329 7654 7123 3477 -1869 -6393 -7899 -5367 88 5572 8632 8001 3994 -1711 -6441 -7793 -5287 -393 4497 7216 6430 2176 -3494 -7572 -8412 -5660 -476 4873 7782 6690 2393 -2805 -6588 -7323 -4649 614 5879 8327 6904 2609 -2773 -6848 -7927 -5150 117 5087 7272 5923 1730 -3616 -7575 -8117 -4951 332 5082 7314 6100 1716 -3587 -7162 -7338 -4064 1063 5860 7922 6178 1477 -3845 -7267 -7575 -4571 537 5260 7199 5292 826 -4115 -7486 -7689 -4446 938 5637 7201 5421 1063 -3815 -7109 -7141 -3667 1448 5660 6990 4983 519 -4622 -7833 -7543 -3996 1080 5323 6922 5028 385 -4480 -7416 -7070 -3789 1145 5533 6878 4693 40 -4734 -7506 -7268 -3827 1353 5650 6756 4347 -161 -4821 -7581 -7051 -3301 1993 5847 6707 4347 -198 -4888 -7582 -6814 -2926 2076 5860 6719 4339 -313 -5104 -7557 -6685 -2960 1915 5679 6573 3945 -814 -5333 -7572 -6588 -2787 2269 6052 6597 3789 -877 -5189 -7406 -6525 -2636 2447 5996 6307 3497 -1070 -5450 -7609 -6463 -2340 2658 5945 6230 3482 -1158 -5519 -7458 -5949 -1767 3039 6341 6612 3603 -1267 -5625 -7343 -5857 -1774 3033 6279 6346 3156 -1653 -5721 -7357 -5877 -1742 3158 6256 6039 2848 -1752 -5721 -7285 -5643 -1223 3635 6464 6159 2960 -1731 -5771 -7229 -5280 -936 3662 6266 5823 2488 -2386 -6329 -7457 -5362 -1044 3521 6339 5962 2564 -2183 -5850 -6875 -4841 -536 4120 6763 6062 2488 -2111 -5681 -6838 -4873 -605 3845 6190 5268 1777 -2759 -6413 -7419 -5162 -680 3692 5964 5234 1888 -2556 -5979 -6624 -4157 242 4497 6702 5860 2200 -2597 -6054 -6732 -4381 -111 4183 6330 5153 1346 -3170 -6430 -7031 -4688 -198 4213 6335 5180 1519 -2753 -5777 -6198 -3531 958 5024 6619 5234 1523 -3048 -6295 -6753 -4157 137 3986 5665 4412 788 -3545 -6449 -6469 -3735 539 4539 6246 4921 1172 -3100 -5918 -6010 -3352 905 4800 6313 4702 865 -3363 -6118 -6254 -3609 753 4529 5842 4178 466 -3628 -6305 -6174 -3231 1195 4854 6112 4497 715 -3550 -6183 -5972 -3043 1265 4843 6030 4203 264 -3915 -6352 -5945 -2961 1328 4907 6001 4025 50 -3949 -6240 -5808 -2731 1620 5085 5932 3872 5 -3961 -6174 -5640 -2408 1971 5204 5806 3587 -347 -4320 -6493 -5674 -2252 2103 5245 5818 3709 -300 -4249 -6215 -5309 -2066 2078 5077 5591 3262 -809 -4558 -6335 -5384 -2111 2062 5097 5460 3022 -951 -4570 -6283 -5192 -1733 2491 5348 5475 3024 -912 -4546 -6217 -5077 -1557 2597 5245 5301 2785 -1263 -4934 -6522 -5226 -1716 2385 5104 5206 2680 -1328 -4860 -6276 -4933 -1472 2549 5211 5238 2602 -1389 -4778 -6118 -4834 -1379 2664 5109 4880 2156 -1731 -5007 -6259 -4754 -1121 2883 5297 4973 2318 -1620 -4939 -6086 -4395 -697 3187 5426 5082 2242 -1738 -5026 -6037 -4332 -754 3012 5156 4665 1777 -2237 -5294 -6125 -4310 -676 3177 5313 4707 1704 -2171 -5167 -5962 -4134 -434 3307 5221 4456 1421 -2371 -5287 -5974 -3954 -188 3542 5297 4424 1389 -2456 -5362 -5854 -3667 161 3709 5435 4476 1255 -2671 -5472 -5828 -3589 215 3804 5409 4402 1138 -2724 -5324 -5599 -3384 378 3901 5396 4091 868 -2871 -5385 -5572 -3270 525 3884 5155 3828 575 -3119 -5518 -5503 -2994 826 4095 5277 3886 615 -3100 -5348 -5202 -2603 1202 4405 5579 4064 602 -3109 -5419 -5272 -2790 899 4067 5100 3521 122 -3477 -5592 -5270 -2585 1314 4537 5531 3905 485 -3089 -5226 -4956 -2347 1443 4476 5236 3463 11 -3604 -5711 -5257 -2473 1341 4363 5141 3385 -28 -3584 -5504 -4973 -2164 1586 4456 5218 3413 -64 -3496 -5321 -4707 -1969 1721 4571 5109 3195 -329 -3723 -5474 -4821 -1969 1776 4503 4921 2919 -522 -3845 -5506 -4654 -1676 2057 4687 5036 3068 -415 -3721 -5323 -4408 -1430 2169 4614 4882 2788 -695 -3915 -5313 -4337 -1396 2132 4519 4702 2544 -905 -3866 -5124 -3993 -988 2586 4865 4841 2573 -877 -3859 -5050 -3949 -902 2556 4668 4510 2223 -1141 -4108 -5170 -3808 -703 2720 4719 4553 2271 -1131 -3972 -4907 -3489 -390 2919 4890 4537 2088 -1385 -4154 -4934 -3447 -337 2949 4792 4325 1743 -1562 -4181 -4856 -3273 -33 3316 5041 4439 1923 -1424 -3959 -4570 -2910 317 3423 4907 4088 1355 -2054 -4624 -5056 -3187 140 3307 4809 4030 1323 -2069 -4432 -4695 -2724 597 3694 5114 4179 1360 -1966 -4229 -4478 -2602 675 3715 5019 3932 1027 -2281 -4537 -4753 -2714 656 3687 4919 3859 1085 -2127 -4312 -4403 -2332 965 3786 4910 3750 882 -2391 -4437 -4402 -2254 933 3703 4646 3397 396 -2761 -4724 -4539 -2305 980 3754 4756 3469 590 -2468 -4317 -4120 -1871 1389 4050 4788 3321 318 -2715 -4503 -4201 -1837 1438 4025 4685 3201 220 -2892 -4629 -4167 -1665 1653 4171 4763 3180 93 -2975 -4602 -4015 -1499 1777 4212 4668 2927 -195 -3214 -4712 -4027 -1443 1877 4278 4609 2759 -451 -3440 -4853 -4093 -1385 1983 4334 4570 2726 -405 -3326 -4680 -3794 -1068 2210 4410 4547 2595 -554 -3460 -4715 -3725 -987 2203 4300 4352 2317 -875 -3669 -4760 -3687 -941 2237 4312 4330 2291 -778 -3453 -4486 -3475 -775 2271 4218 4105 1969 -1070 -3682 -4656 -3518 -661 2424 4262 4018 1854 -1197 -3718 -4505 -3141 -252 2809 4564 4264 2067 -1039 -3611 -4369 -3028 -201 2761 4427 4040 1772 -1318 -3740 -4352 -2907 -52 2939 4553 4008 1657 -1414 -3784 -4364 -2858 71 3089 4629 4098 1794 -1219 -3535 -4025 -2500 373 3224 4571 3896 1487 -1553 -3828 -4269 -2661 281 3126 4547 3891 1552 -1413 -3640 -3989 -2363 529 3341 4719 4010 1545 -1452 -3640 -3988 -2305 653 3467 4729 3866 1292 -1740 -3849 -4091 -2325 671 3436 4602 3716 1219 -1733 -3760 -3867 -1994 1031 3708 4758 3730 1100 -1925 -3891 -3898 -1938 1044 3640 4625 3557 921 -2020 -3859 -3776 -1813 1116 3687 4617 3465 815 -2079 -3828 -3713 -1708 1263 3759 4544 3307 641 -2169 -3855 -3674 -1608 1362 3750 4410 3090 425 -2383 -4022 -3725 -1533 1491 3835 4488 3167 390 -2378 -3928 -3509 -1257 1728 4013 4573 3123 286 -2473 -3894 -3404 -1080 1884 4078 4466 2853 -5 -2678 -4035 -3440 -1097 1857 3996 4295 2678 -137 -2821 -4118 -3421 -983 1959 4054 4283 2648 -196 -2873 -4054 -3273 -751 2161 4159 4334 2556 -320 -2965 -4064 -3201 -743 2176 4144 4225 2424 -491 -2999 -4011 -3065 -524 2366 4218 4166 2266 -527 -3007 -3950 -2995 -441 2446 4186 4011 2055 -793 -3221 -4122 -3048 -497 2269 3910 3759 1847 -951 -3318 -4032 -2861 -261 2461 4044 3777 1764 -1048 -3282 -3888 -2595 8 2720 4200 3747 1609 -1195 -3413 -4006 -2727 -94 2586 4001 3501 1396 -1321 -3396 -3835 -2456 164 2756 3984 3385 1253 -1458 -3540 -3889 -2427 161 2654 3835 3194 978 -1743 -3638 -3838 -2295 322 2819 3964 3211 939 -1698 -3550 -3689 -2147 446 2883 3884 3016 726 -1901 -3667 -3765 -2123 530 2870 3745 2848 568 -2028 -3721 -3652 -1884 743 3014 3804 2827 478 -2144 -3779 -3686 -1910 685 2910 3669 2636 249 -2295 -3828 -3676 -1867 787 3011 3681 2564 169 -2269 -3684 -3424 -1508 1109 3282 3789 2575 134 -2334 -3779 -3482 -1543 1073 3099 3608 2339 -127 -2620 -3944 -3519 -1525 1092 3151 3535 2273 -193 -2580 -3787 -3318 -1296 1326 3309 3652 2234 -256 -2634 -3888 -3409 -1348 1282 3204 3491 2125 -346 -2666 -3811 -3204 -1114 1441 3253 3462 2008 -432 -2714 -3692 -3007 -861 1662 3399 3499 1940 -547 -2821 -3765 -2983 -854 1648 3346 3394 1743 -761 -2958 -3849 -3087 -822 1676 3304 3282 1636 -822 -2963 -3772 -2878 -644 1835 3375 3296 1599 -831 -2924 -3667 -2702 -446 1998 3489 3307 1604 -885 -2949 -3667 -2658 -408 1984 3421 3207 1407 -1005 -3028 -3592 -2493 -223 2183 3519 3168 1323 -1124 -3078 -3621 -2468 -157 2191 3465 3090 1216 -1211 -3123 -3584 -2390 -106 2201 3424 2983 1031 -1414 -3236 -3594 -2278 52 2393 3518 2982 1026 -1372 -3185 -3492 -2174 217 2481 3558 2990 999 -1399 -3104 -3323 -1944 391 2603 3528 2824 765 -1645 -3338 -3516 -2118 259 2439 3404 2700 654 -1716 -3375 -3479 -1952 439 2602 3455 2704 617 -1772 -3360 -3404 -1901 493 2585 3413 2571 442 -1901 -3413 -3358 -1742 676 2719 3458 2583 442 -1862 -3275 -3184 -1514 848 2836 3482 2495 313 -1981 -3404 -3224 -1543 771 2719 3268 2198 22 -2217 -3523 -3218 -1457 934 2870 3380 2242 59 -2137 -3336 -3000 -1255 1077 2880 3290 2110 -83 -2249 -3472 -3087 -1267 1111 2885 3257 2040 -176 -2349 -3455 -3004 -1129 1255 3036 3316 2039 -227 -2339 -3367 -2824 -929 1423 3077 3287 1959 -317 -2425 -3404 -2826 -843 1430 3068 3162 1762 -476 -2500 -3382 -2659 -727 1562 3083 3145 1742 -512 -2522 -3314 -2559 -602 1664 3136 3073 1555 -715 -2690 -3413 -2556 -503 1757 3190 3055 1450 -804 -2731 -3387 -2464 -390 1826 3150 2944 1301 -988 -2887 -3487 -2491 -402 1808 3073 2807 1145 -1095 -2921 -3406 -2352 -208 1950 3141 2802 1072 -1204 -2977 -3394 -2252 -139 2044 3163 2751 988 -1284 -2999 -3350 -2217 -88 2015 3102 2629 783 -1424 -3044 -3346 -2157 -30 2050 2988 2449 636 -1582 -3178 -3411 -2135 33 2055 3016 2424 588 -1604 -3153 -3331 -2032 105 2123 3004 2344 451 -1704 -3204 -3309 -1933 240 2208 3055 2334 446 -1723 -3175 -3231 -1818 359 2308 3090 2346 386 -1787 -3260 -3265 -1820 356 2266 2999 2193 254 -1933 -3348 -3302 -1774 369 2222 2917 2042 49 -2030 -3348 -3221 -1676 551 2424 2995 2054 59 -2069 -3306 -3095 -1494 698 2522 3017 1974 -76 -2184 -3380 -3114 -1440 812 2568 3072 2033 -28 -2128 -3285 -2956 -1228 978 2724 3102 2010 -72 -2132 -3243 -2871 -1197 1016 2712 3029 1879 -193 -2206 -3229 -2775 -1056 1151 2797 3009 1818 -259 -2251 -3228 -2729 -924 1199 2758 2960 1718 -366 -2324 -3206 -2607 -812 1346 2836 2951 1687 -417 -2296 -3068 -2403 -625 1489 2924 2973 1616 -495 -2352 -3067 -2391 -554 1545 2861 2807 1397 -666 -2452 -3170 -2430 -598 1455 2785 2736 1312 -666 -2441 -3082 -2300 -371 1625 2866 2787 1319 -715 -2419 -3014 -2215 -357 1630 2768 2593 1134 -895 -2544 -3051 -2178 -300 1721 2892 2634 1145 -873 -2515 -2951 -2057 -198 1786 2807 2505 988 -1041 -2620 -2987 -2040 -173 1787 2775 2424 878 -1146 -2653 -2960 -1923 -22 1884 2870 2447 839 -1131 -2622 -2897 -1799 150 2027 2955 2466 880 -1138 -2624 -2885 -1730 215 2008 2792 2244 532 -1406 -2788 -2907 -1703 271 2074 2865 2293 571 -1377 -2724 -2844 -1597 359 2159 2905 2247 524 -1426 -2756 -2770 -1526 385 2118 2799 2111 366 -1521 -2792 -2805 -1494 476 2227 2856 2176 419 -1497 -2702 -2664 -1365 576 2242 2846 2050 288 -1597 -2805 -2685 -1346 610 2278 2780 1937 101 -1784 -2922 -2737 -1321 656 2274 2778 1906 101 -1762 -2860 -2610 -1156 798 2368 2831 1903 113 -1745 -2832 -2569 -1114 817 2385 2771 1847 64 -1781 -2734 -2446 -980 972 2488 2827 1830 -37 -1804 -2773 -2381 -854 1075 2529 2805 1762 -115 -1871 -2814 -2424 -863 995 2388 2588 1572 -262 -1977 -2756 -2281 -768 1187 2551 2702 1616 -217 -1921 -2693 -2156 -525 1368 2688 2802 1681 -176 -1843 -2583 -2054 -486 1362 2622 2668 1482 -310 -1964 -2658 -2030 -407 1440 2632 2615 1414 -419 -1998 -2603 -1949 -308 1501 2646 2553 1251 -544 -2111 -2641 -1891 -203 1606 2693 2558 1221 -636 -2152 -2639 -1867 -169 1662 2737 2547 1212 -588 -2088 -2498 -1655 66 1843 2843 2575 1178 -659 -2118 -2500 -1614 84 1874 2810 2476 1056 -807 -2218 -2522 -1633 91 1833 2736 2359 912 -917 -2295 -2539 -1521 210 1962 2793 2374 877 -956 -2273 -2486 -1486 273 1960 2763 2318 846 -924 -2200 -2364 -1294 463 2123 2812 2301 746 -1033 -2281 -2395 -1277 478 2088 2770 2203 668 -1089 -2273 -2325 -1138 593 2156 2782 2140 586 -1177 -2335 -2295 -1131 673 2266 2788 2115 527 -1240 -2337 -2291 -1065 714 2232 2751 2049 415 -1301 -2344 -2203 -912 893 2398 2875 2103 441 -1287 -2285 -2145 -860 919 2373 2787 1955 291 -1384 -2390 -2218 -926 895 2315 2670 1786 118 -1521 -2456 -2156 -763 1043 2485 2775 1905 215 -1428 -2301 -1988 -605 1143 2486 2773 1811 106 -1504 -2330 -1949 -517 1224 2539 2766 1765 -1 -1609 -2354 -1901 -485 1265 2576 2702 1630 -103 -1664 -2429 -1998 -532 1202 2383 2439 1382 -313 -1859 -2522 -1972 -449 1268 2454 2522 1407 -266 -1801 -2391 -1793 -269 1458 2597 2563 1399 -335 -1806 -2393 -1781 -264 1457 2571 2525 1296 -424 -1881 -2419 -1738 -169 1570 2620 2485 1246 -483 -1893 -2373 -1645 -76 1594 2564 2400 1128 -595 -2039 -2476 -1670 -79 1582 2556 2366 1092 -661 -2010 -2352 -1514 42 1745 2668 2398 1085 -602 -1954 -2271 -1428 161 1794 2649 2296 1000 -680 -1991 -2286 -1416 208 1781 2580 2232 882 -783 -2025 -2223 -1270 357 1925 2659 2237 856 -861 -2084 -2254 -1331 264 1833 2527 2105 724 -924 -2098 -2169 -1211 463 2013 2658 2137 717 -951 -2037 -2125 -1067 580 2088 2704 2156 712 -922 -1998 -2030 -975 687 2101 2625 2033 553 -1068 -2105 -2113 -992 614 2054 2544 1925 393 -1209 -2193 -2120 -978 659 2095 2553 1852 371 -1175 -2167 -2055 -907 712 2117 2532 1833 351 -1221 -2191 -2064 -904 722 2089 2497 1755 251 -1306 -2191 -1996 -809 793 2079 2441 1687 159 -1350 -2232 -1959 -717 875 2159 2439 1591 74 -1423 -2210 -1928 -710 904 2117 2327 1511 0 -1455 -2184 -1832 -544 1070 2242 2419 1545 6 -1440 -2161 -1769 -468 1124 2271 2393 1463 -93 -1541 -2206 -1748 -459 1145 2278 2366 1367 -193 -1575 -2225 -1774 -398 1206 2305 2327 1348 -193 -1597 -2240 -1767 -379 1195 2225 2232 1192 -351 -1692 -2218 -1655 -300 1255 2262 2245 1173 -381 -1740 -2223 -1589 -193 1358 2339 2254 1162 -359 -1698 -2137 -1513 -130 1419 2361 2208 1099 -480 -1771 -2242 -1558 -110 1399 2259 2096 965 -566 -1838 -2200 -1501 -69 1440 2279 2064 956 -566 -1796 -2127 -1367 47 1509 2339 2071 854 -666 -1862 -2105 -1321 125 1599 2378 2079 834 -676 -1816 -2062 -1279 167 1625 2349 1998 792 -726 -1860 -2055 -1178 296 1692 2369 1979 714 -802 -1893 -2084 -1211 261 1664 2237 1779 464 -1005 -2033 -2147 -1245 259 1594 2166 1720 434 -1065 -2061 -2095 -1133 371 1750 2251 1742 417 -1055 -2010 -2003 -1033 476 1747 2210 1621 274 -1178 -2098 -2074 -1051 405 1660 2091 1502 145 -1277 -2162 -2062 -1043 446 1704 2091 1430 117 -1302 -2130 -2008 -924 534 1752 2081 1391 6 -1401 -2186 -2016 -924 551 1669 1938 1233 -144 -1443 -2208 -1949 -810 656 1764 2040 1273 -74 -1399 -2100 -1818 -690 741 1816 2006 1199 -137 -1418 -2110 -1808 -673 737 1740 1866 1055 -293 -1597 -2213 -1793 -644 736 1752 1869 1050 -301 -1584 -2159 -1776 -568 810 1796 1871 1005 -364 -1608 -2164 -1706 -534 843 1798 1833 919 -422 -1660 -2137 -1655 -454 917 1830 1784 866 -449 -1647 -2147 -1604 -424 965 1801 1743 821 -566 -1743 -2128 -1562 -305 1000 1820 1704 753 -619 -1781 -2127 -1565 -334 1000 1874 1733 710 -631 -1726 -2074 -1487 -225 1072 1849 1676 690 -670 -1771 -2072 -1409 -150 1134 1842 1630 622 -744 -1801 -2088 -1375 -118 1112 1793 1572 517 -861 -1860 -2061 -1360 -125 1153 1801 1499 435 -863 -1843 -2011 -1287 -15 1250 1871 1496 419 -888 -1866 -2020 -1263 25 1240 1801 1457 354 -941 -1864 -1971 -1153 123 1290 1808 1416 300 -992 -1882 -1974 -1136 101 1265 1735 1287 169 -1145 -2027 -2006 -1172 88 1243 1709 1223 74 -1185 -2022 -1994 -1090 201 1290 1665 1151 -5 -1270 -2037 -1964 -1029 254 1341 1723 1148 -30 -1243 -1998 -1893 -990 313 1404 1692 1116 -88 -1318 -2061 -1901 -966 335 1372 1657 1007 -184 -1409 -2127 -1972 -1012 273 1297 1553 922 -283 -1502 -2195 -1944 -924 359 1353 1581 934 -257 -1472 -2069 -1782 -743 544 1508 1721 1005 -239 -1430 -2013 -1728 -726 568 1513 1687 946 -274 -1453 -2000 -1706 -615 656 1560 1662 916 -303 -1462 -2018 -1660 -619 641 1506 1558 765 -459 -1584 -2078 -1667 -602 614 1463 1504 707 -507 -1609 -2050 -1591 -502 732 1547 1574 746 -434 -1467 -1896 -1414 -320 873 1638 1558 717 -546 -1572 -1920 -1423 -303 914 1626 1499 622 -576 -1601 -1947 -1440 -315 878 1564 1413 497 -700 -1630 -1901 -1340 -235 943 1635 1450 505 -673 -1626 -1838 -1268 -117 1063 1699 1487 566 -598 -1531 -1754 -1133 6 1155 1725 1477 520 -692 -1577 -1721 -1087 50 1187 1782 1497 541 -634 -1526 -1698 -1005 122 1201 1737 1426 424 -741 -1599 -1704 -1051 98 1219 1728 1363 347 -795 -1614 -1650 -910 278 1353 1830 1470 405 -761 -1553 -1575 -782 407 1414 1867 1394 356 -827 -1587 -1589 -810 320 1326 1735 1304 232 -916 -1650 -1601 -790 378 1401 1748 1262 196 -924 -1606 -1538 -720 463 1453 1774 1262 215 -880 -1591 -1465 -619 542 1487 1760 1224 169 -924 -1567 -1379 -486 658 1604 1874 1328 256 -834 -1433 -1297 -476 680 1601 1816 1236 149 -922 -1492 -1307 -434 705 1579 1733 1136 59 -1005 -1540 -1331 -395 756 1616 1789 1146 67 -944 -1440 -1162 -234 897 1698 1796 1162 54 -965 -1433 -1126 -196 909 1742 1826 1116 39 -951 -1385 -1117 -179 985 1740 1777 1100 -3 -973 -1397 -1065 -139 965 1709 1708 1009 -83 -1061 -1492 -1114 -176 914 1630 1640 902 -188 -1100 -1497 -1082 -135 948 1676 1636 887 -137 -1063 -1382 -966 10 1061 1728 1681 890 -196 -1095 -1360 -888 52 1082 1706 1594 775 -300 -1194 -1472 -994 -25 1014 1628 1484 690 -420 -1262 -1480 -1007 -10 1063 1653 1467 631 -413 -1268 -1460 -951 27 1033 1557 1336 508 -544 -1350 -1552 -999 1 1027 1506 1307 486 -568 -1367 -1492 -904 123 1082 1574 1307 437 -602 -1372 -1474 -880 135 1083 1518 1204 320 -717 -1489 -1574 -980 22 965 1401 1092 188 -858 -1536 -1564 -893 120 1029 1372 1038 173 -824 -1484 -1470 -809 225 1095 1435 1063 156 -851 -1492 -1482 -804 189 1075 1357 992 79 -941 -1541 -1513 -817 186 1038 1329 909 -1 -951 -1550 -1487 -776 242 1068 1319 907 -37 -970 -1562 -1433 -703 281 1111 1338 877 -22 -994 -1547 -1382 -646 359 1158 1375 877 -39 -917 -1424 -1279 -513 488 1246 1396 895 -42 -944 -1430 -1251 -444 493 1180 1296 748 -193 -1056 -1523 -1294 -507 471 1189 1294 754 -176 -1068 -1426 -1178 -354 617 1314 1423 832 -137 -1029 -1413 -1138 -379 566 1257 1306 693 -251 -1112 -1494 -1204 -366 595 1224 1217 608 -351 -1167 -1513 -1184 -340 595 1201 1206 551 -368 -1260 -1558 -1240 -403 519 1117 1089 435 -536 -1324 -1623 -1250 -366 575 1173 1122 468 -466 -1309 -1516 -1111 -244 680 1257 1162 486 -441 -1211 -1443 -1011 -161 763 1258 1160 463 -481 -1258 -1414 -955 -105 773 1243 1104 435 -491 -1216 -1382 -949 -118 800 1263 1089 332 -585 -1250 -1363 -926 -47 832 1262 1027 296 -598 -1258 -1368 -829 54 919 1299 1085 378 -515 -1153 -1219 -703 189 997 1391 1145 393 -517 -1141 -1201 -678 213 1036 1363 1104 303 -605 -1216 -1279 -683 193 983 1304 1011 249 -641 -1223 -1251 -646 245 1046 1299 1002 205 -671 -1216 -1173 -554 354 1136 1397 1043 225 -659 -1189 -1133 -498 368 1139 1391 1004 178 -646 -1160 -1056 -478 432 1160 1401 978 161 -653 -1138 -1089 -420 459 1139 1341 927 115 -695 -1170 -1038 -381 468 1148 1316 893 61 -744 -1201 -1061 -376 503 1173 1341 899 49 -731 -1155 -1000 -312 536 1168 1335 853 27 -754 -1167 -983 -279 575 1219 1297 797 -8 -790 -1145 -931 -234 617 1223 1245 737 -89 -863 -1195 -949 -218 617 1167 1202 693 -183 -895 -1216 -951 -220 629 1172 1199 664 -128 -836 -1134 -844 -108 731 1265 1229 659 -157 -860 -1119 -809 -91 734 1240 1178 595 -229 -975 -1194 -870 -111 678 1150 1136 537 -283 -943 -1165 -800 -71 766 1226 1106 520 -271 -924 -1129 -800 -49 785 1221 1072 476 -361 -980 -1162 -753 1 768 1204 1063 415 -364 -994 -1122 -678 83 868 1268 1109 498 -329 -938 -1039 -631 137 880 1234 1009 354 -422 -1041 -1109 -663 72 832 1182 994 335 -478 -1029 -1136 -649 152 885 1234 1004 320 -471 -999 -1044 -539 247 926 1272 1070 373 -381 -939 -987 -490 256 966 1294 1007 305 -461 -972 -963 -469 278 966 1228 927 218 -529 -1044 -1041 -517 264 924 1143 853 105 -632 -1104 -1048 -507 313 943 1143 788 98 -670 -1100 -1019 -429 339 968 1141 822 117 -603 -1002 -907 -334 454 1050 1195 795 96 -612 -1014 -934 -369 412 983 1073 680 -47 -759 -1153 -1021 -419 335 919 1053 697 -15 -724 -1067 -916 -332 420 966 1055 659 -67 -734 -1106 -917 -349 385 929 1034 600 -96 -734 -1029 -885 -217 513 1060 1082 676 -40 -698 -1005 -785 -193 580 1063 1097 670 -45 -707 -1005 -787 -178 512 1029 1016 505 -217 -829 -1094 -827 -196 517 949 944 480 -229 -836 -1041 -753 -135 602 1100 1068 615 -83 -695 -948 -644 27 710 1133 1073 549 -179 -793 -1005 -736 -71 617 1044 990 463 -266 -831 -1017 -680 -45 658 1063 978 430 -245 -815 -944 -624 42 707 1034 910 376 -327 -880 -1014 -653 -55 636 966 812 290 -393 -917 -1022 -612 61 698 1034 902 327 -386 -912 -1005 -598 44 673 1002 838 261 -464 -944 -1053 -661 27 676 949 739 130 -537 -1031 -1097 -687 -18 653 922 690 113 -547 -1036 -1033 -597 105 719 983 751 149 -536 -978 -983 -546 125 737 949 681 79 -573 -1005 -1002 -559 108 720 895 648 28 -653 -1050 -1011 -524 137 681 834 536 -93 -754 -1160 -1085 -624 79 603 758 463 -184 -829 -1189 -1080 -563 79 631 788 434 -178 -809 -1129 -965 -454 201 724 861 497 -139 -724 -1082 -980 -405 227 729 804 430 -206 -814 -1158 -992 -439 218 683 751 351 -264 -890 -1177 -988 -449 159 661 726 356 -295 -904 -1131 -936 -415 242 697 707 301 -307 -870 -1106 -926 -337 296 739 739 356 -300 -829 -1053 -814 -212 407 821 839 378 -268 -829 -1026 -814 -232 361 749 744 274 -366 -910 -1090 -814 -254 347 751 676 184 -402 -924 -1077 -785 -189 419 763 683 240 -354 -885 -1017 -707 -117 481 812 722 290 -296 -793 -919 -590 -15 576 897 805 322 -312 -809 -890 -598 -64 544 839 715 242 -385 -836 -895 -592 10 602 878 765 291 -315 -731 -815 -454 123 707 955 826 300 -291 -717 -775 -434 139 710 973 788 254 -347 -732 -765 -391 189 714 961 776 249 -330 -707 -709 -332 230 736 941 736 196 -398 -783 -805 -408 195 663 838 632 94 -490 -849 -815 -435 162 648 822 607 83 -481 -826 -768 -320 259 731 873 649 135 -429 -734 -664 -247 335 802 921 629 89 -463 -753 -681 -300 247 693 792 513 -27 -566 -838 -714 -315 271 697 798 493 -22 -564 -860 -707 -245 281 722 819 541 -13 -505 -734 -617 -195 390 814 858 539 11 -520 -739 -607 -149 449 815 848 497 -45 -510 -790 -605 -171 369 775 780 461 -103 -603 -809 -639 -189 329 693 687 354 -183 -671 -843 -654 -193 368 739 770 376 -149 -575 -761 -578 -93 452 839 804 403 -134 -568 -726 -508 -45 498 778 773 371 -161 -625 -766 -530 -57 485 824 731 378 -179 -598 -727 -532 -25 502 773 698 291 -212 -670 -790 -546 -83 420 712 608 218 -293 -703 -787 -524 -49 471 739 649 274 -249 -661 -739 -452 57 532 810 710 274 -234 -619 -698 -413 61 558 758 602 169 -351 -732 -798 -517 -28 435 653 493 52 -408 -810 -817 -490 20 525 719 532 89 -407 -780 -804 -474 1 463 656 466 40 -463 -785 -809 -459 22 452 642 493 13 -435 -754 -717 -366 113 541 714 471 33 -456 -773 -748 -429 61 495 625 420 -15 -502 -838 -751 -402 106 500 610 395 -37 -510 -787 -739 -342 157 549 646 427 -20 -463 -734 -670 -290 208 608 709 452 -20 -469 -724 -666 -273 218 622 648 390 -44 -495).
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 11:01'!
samplesForMouseEnter

	^ #(-37 -24 -30 -30 -25 -23 -11 -8 -38 -40 -34 -21 -18 -27 -34 -20 2 11 8 10 5 7 10 14 34 28 34 54 59 47 54 25 27 43 33 48 23 40 59 63 47 46 27 47 43 41 46 50 64 57 46 57 44 48 12 17 24 28 18 23 27 -7 -17 2 4 1 -4 18 12 11 34 25 43 18 11 20 43 43 11 12 31 -5 -11 -43 -41 -17 -23 -28 -38 -33 -48 -64 -61 -53 -61 -54 -56 -73 -73 -48 -48 -63 -92 -102 -90 -92 -115 -93 -90 -109 -120 -112 -119 -141 -136 -128 -146 -143 -141 -129 -118 -139 -132 -120 -103 -100 -96 -79 -71 -83 -79 -77 -87 -73 -73 -43 -24 -5 -10 20 23 -5 -4 0 28 20 -11 20 4 -11 -23 20 27 7 8 -2 -7 -15 -27 4 0 -8 -34 -31 -38 -34 -50 -40 -64 -46 -59 -51 -82 -80 -82 -80 -89 -95 -122 -89 -97 -67 -64 -31 -21 -34 -56 -25 -35 -48 -63 -37 -54 -34 8 40 82 161 306 503 921 1638 2549 3458 4074 4290 3947 2988 1528 -293 -2417 -4592 -6693 -8734 -10727 -12641 -14255 -15466 -16249 -16383 -15965 -15159 -14019 -12574 -10934 -9124 -7214 -5191 -3092 -856 1418 3639 5667 7543 9156 10532 11608 12361 12795 12922 12755 12307 11574 10473 8964 7129 5084 2911 596 -1773 -4103 -6374 -8593 -10593 -12355 -13748 -14599 -14866 -14527 -13593 -12109 -10146 -7697 -4933 -2022 881 3689 6302 8638 10580 12067 13052 13602 13774 13543 13046 12276 11271 9965 8426 6677 4771 2731 607 -1469 -3420 -5217 -6790 -8196 -9401 -10377 -11001 -11242 -11095 -10600 -9729 -8581 -7114 -5423 -3563 -1566 488 2577 4556 6448 8234 9786 11143 12136 12756 13034 12936 12489 11744 10678 9320 7673 5775 3813 1813 -182 -2113 -3924 -5606 -7123 -8439 -9477 -10213 -10688 -10855 -10663 -10109 -9278 -8125 -6682 -5004 -3147 -1171 791 2762 4655 6386 7944 9222 10201 10800 11120 11163 10885 10313 9434 8363 7050 5604 4048 2395 711 -872 -2376 -3707 -4894 -5875 -6667 -7214 -7489 -7480 -7251 -6739 -6039 -5102 -3987 -2754 -1475 -207 1094 2392 3590 4686 5639 6469 7178 7758 8142 8273 8187 7883 7398 6803 6056 5188 4152 3075 1968 866 -184 -1197 -2143 -2964 -3615 -4163 -4572 -4907 -5100 -5141 -5018 -4723 -4288 -3725 -3031 -2198 -1246 -276 704 1661 2529 3377 4140 4835 5333 5721 5941 6098 6048 5846 5498 5047 4467 3816 3131 2444 1659 856 57 -636 -1301 -1946 -2549 -3099 -3548 -3871 -4057 -4143 -4153 -3999 -3753 -3380 -2893 -2338 -1742 -1098 -391 380 1111 1822 2543 3206 3784 4283 4638 4868 4955 4894 4713 4385 3938 3365 2679 1910 1089 272 -564 -1379 -2145 -2902 -3583 -4127 -4562 -4866 -5010 -4949 -4785 -4468 -4026 -3463 -2817 -2070 -1256 -398 462 1297 2147 2922 3613 4211 4732 5178 5449 5617 5608 5456 5168 4727 4120 3404 2561 1646 706 -218 -1212 -2160 -3018 -3688 -4293 -4726 -5015 -5195 -5231 -5096 -4788 -4321 -3754 -3057 -2240 -1363 -433 515 1446 2340 3118 3820 4401 4851 5133 5256 5195 5011 4696 4209 3627 2934 2168 1334 434 -475 -1357 -2211 -2981 -3669 -4285 -4771 -5116 -5322 -5382 -5315 -5067 -4701 -4169 -3518 -2775 -1937 -1036 -165 735 1626 2440 3115 3681 4154 4467 4625 4681 4589 4344 4008 3583 3008 2353 1615 777 -57 -872 -1713 -2486 -3206 -3843 -4391 -4840 -5116 -5273 -5277 -5128 -4831 -4418 -3868 -3252 -2533 -1744 -898 -67 780 1570 2300 2913 3463 3874 4159 4331 4353 4248 4028 3668 3184 2633 1949 1216 426 -341 -1109 -1852 -2512 -3102 -3597 -3983 -4224 -4349 -4339 -4183 -3910 -3520 -3065 -2510 -1885 -1242 -588 54 685 1249 1839 2352 2777 3106 3327 3466 3488 3417 3234 2948 2617 2185 1671 1117 564 -15 -608 -1174 -1700 -2196 -2650 -3039 -3296 -3481 -3587 -3568 -3460 -3273 -2983 -2614 -2156 -1658 -1154 -626 -89 421 921 1413 1865 2266 2602 2818 3004 3090 3036 2944 2824 2565 2214 1837 1422 954 469 -15 -490 -960 -1413 -1806 -2139 -2421 -2703 -2877 -2949 -2974 -2964 -2820 -2608 -2340 -1972 -1592 -1154 -680 -190 267 745 1183 1592 1947 2225 2473 2624 2696 2723 2692 2565 2408 2219 1916 1579 1200 797 368 -115 -549 -994 -1408 -1767 -2037 -2241 -2394 -2469 -2497 -2427 -2317 -2150 -1887 -1551 -1197 -778 -346 103 544 942 1390 1766 2077 2353 2535 2657 2697 2700 2615 2473 2257 1980 1677 1287 871 466 21 -377 -757 -1134 -1464 -1713 -1932 -2096 -2208 -2243 -2235 -2168 -2051 -1854 -1566 -1229 -888 -499 -100 319 719 1124 1481 1801 2084 2306 2434 2469 2476 2431 2287 2101 1825 1527 1194 836 483 123 -231 -593 -931 -1251 -1541 -1796 -1978 -2122 -2188 -2162 -2106 -1903 -1717 -1467 -1140 -814 -463 -115 254 617 950 1284 1550 1753 1880 1992 1988 1930 1829 1695 1475 1226 924 603 293 -27 -345 -640 -954 -1217 -1471 -1687 -1832 -1917 -1985 -1960 -1900 -1750 -1546 -1356 -1092 -771 -469 -135 200 555 895 1176 1429 1628 1786 1920 1968 1966 1924 1842 1704 1464 1200 922 600 285 -21 -348 -614 -840 -1073 -1266 -1397 -1501 -1595 -1635 -1638 -1585 -1464 -1311 -1151 -971 -735 -501 -267 -43 210 398 643 865 1050 1206 1333 1419 1418 1410 1383 1281 1147 996 803 621 437 226 23 -148 -309 -466 -611 -748 -849 -912 -964 -1016 -1039 -1032 -990 -868 -757 -621 -440 -256 -118 43 194 354 470 564 653 718 780 809 793 748 672 587 453 321 151 8 -142 -308 -499 -647 -819 -950 -1073 -1169 -1243 -1276 -1282 -1262 -1219 -1140 -1016 -921 -809 -624 -475 -335 -142 25 182 339 483 613 702 796 856 899 898 902 858 826 735 656 529 395 263 146 -14 -167 -346 -480 -633 -715 -806 -878 -955 -958 -978 -930 -891 -794 -705 -616 -477 -336 -243 -112 4 109 205 276 332 430 480 519 508 521 513 518 463 384 319 227 112 -8 -100 -202 -348 -505 -596 -725 -833 -906 -951 -940 -927 -883 -806 -692 -542 -365 -207 -60 80 249 400 483 584 626 650 657 634 585 493 443 351 238 158 63 -30 -123 -185 -279 -359 -400 -470 -529 -570 -561 -594 -601 -588 -570 -524 -477 -414 -328 -236 -141 -37 48 99 204 287 391 441 472 495 516 476 418 371 292 204 99 -10 -43 -118 -207 -253 -303 -341 -349 -359 -342 -338 -305 -264 -227 -164 -119 -46 38 99 138 174 227 234 215 231 262 234 227 237 273 218 198 192 192 135 119 90 44 -27 -40 -73 -99 -132 -149 -154 -128 -92 -46 -23 38 59 59 51 57 50 28 17 37 -10 2 -4 -40 -71 -96 -126 -142 -194 -227 -274 -300 -345 -362 -369 -357 -345 -335 -303 -256 -223 -191 -141 -116 -71 -80 -96 -74 -86 -120 -141 -181 -249 -315 -372 -388 -397 -430 -449 -460 -462 -417 -391 -357 -299 -253 -175 -119 -34 43 128 198 241 282 357 410 436 444 472 473 441 413 358 260 191 96 -12 -74 -164 -270 -346 -437 -513 -594 -652 -704 -728 -750 -735 -668 -626 -544 -456 -341 -244 -138 -34 89 195 293 381 459 476 549 597 600 620 601 572 532 475 417 351 233 135 63 -44 -142 -230 -295 -385 -405 -450 -472 -492 -463 -482 -477 -460 -440 -393 -339 -326 -257 -190 -126 -35 63 146 201 283 355 393 401 427 441 411 382 335 282 241 200 133 90 30 -8 -64 -116 -142 -175 -213 -223 -244 -274 -280 -272 -280 -264 -241 -262 -249 -228 -211 -156 -128 -64 -21 43 80 129 142 187 215 227 230 237 243 254 266 267 273 256 254 251 253 236 208 164 128 69 54 30 -18 -69 -86 -106 -143 -167 -188 -218 -246 -247 -233 -220 -169 -138 -95 -44 -23 18 69 116 188 236 298 380 440 503 516 538 544 516 485 475 427 374 310 292 220 109 57 5 -100 -184 -276 -362 -436 -480 -512 -539 -531 -524 -511 -452 -371 -302 -260 -169 -95 -46 59 156 208 262 336 397 421 436 441 427 427 414 368 332 298 237 197 145 93 46 0 -48 -89 -112 -138 -132 -118 -73 -23 0).
! !

!TrashCanMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/16/1998 10:58'!
samplesForMouseLeave

	^ #(230 254 256 242 234 246 206 211 179 175 133 111 106 91 46 53 35 54 17 40 67 98 79 114 127 167 162 133 130 119 91 82 98 90 75 87 45 19 -17 1 -16 -1 8 12 -1 53 71 85 109 117 106 159 138 154 133 161 122 138 85 72 67 51 46 20 6 3 -8 8 -8 -4 -1 22 38 53 43 85 71 103 88 87 45 51 43 59 16 -9 -17 1 -45 -20 -32 -8 -38 3 -20 20 43 53 43 37 24 54 30 58 59 32 20 33 17 8 -30 -56 -72 -111 -133 -127 -122 -111 -129 -111 -108 -112 -108 -111 -135 -100 -130 -111 -158 -125 -121 -104 -96 -111 -135 -106 -111 -104 -133 -111 -143 -137 -140 -130 -109 -103 -119 -62 -59 -67 -62 -33 -41 -12 -43 -46 -43 -38 -71 -87 -100 -80 -125 -124 -145 -132 -145 -111 -148 -106 -95 -79 -51 -14 -17 8 22 85 93 111 116 127 138 133 96 67 53 72 45 -22 -30 -20 -33 16 27 121 177 335 500 756 1023 1362 1738 2131 2465 2769 2932 3032 2951 2609 1980 1102 -43 -1326 -2769 -4181 -5598 -6852 -7906 -8630 -9014 -8982 -8390 -7257 -5645 -3637 -1415 1029 3476 5953 8267 10196 11595 12386 12531 12089 10938 9187 6826 4120 1124 -1933 -4946 -7699 -10138 -12005 -13244 -13719 -13418 -12384 -10706 -8485 -5808 -2796 421 3640 6629 9344 11524 13121 14054 14261 13735 12528 10643 8209 5307 2125 -1265 -4592 -7693 -10426 -12683 -14290 -15200 -15273 -14514 -12881 -10583 -7628 -4171 -448 3303 6911 10154 12921 14914 16133 16383 15750 14259 12040 9164 5772 2083 -1721 -5395 -8751 -11629 -13799 -15261 -15758 -15399 -14104 -11989 -9176 -5801 -2022 1844 5593 9006 11905 14064 15405 15842 15387 13957 11834 9005 5754 2215 -1402 -4888 -8044 -10744 -12739 -14054 -14519 -14216 -13070 -11186 -8680 -5729 -2501 789 4023 6924 9450 11320 12489 12920 12629 11614 9949 7764 5214 2411 -495 -3327 -5845 -8006 -9690 -10820 -11288 -11133 -10271 -8914 -6992 -4820 -2357 174 2643 4910 6853 8361 9360 9729 9537 8811 7573 5908 3939 1799 -448 -2695 -4641 -6343 -7628 -8525 -8926 -8785 -8177 -7118 -5640 -3861 -1943 43 2047 3813 5332 6502 7292 7601 7455 6837 5872 4578 3054 1305 -482 -2228 -3781 -5133 -6187 -6850 -7136 -7039 -6529 -5688 -4489 -3071 -1489 109 1726 3166 4447 5398 6034 6235 6151 5651 4847 3747 2483 997 -464 -1915 -3221 -4323 -5159 -5708 -5929 -5812 -5328 -4601 -3635 -2478 -1165 75 1324 2432 3366 4011 4423 4557 4439 3961 3326 2470 1494 422 -616 -1596 -2506 -3267 -3797 -4124 -4258 -4142 -3740 -3235 -2527 -1702 -832 43 919 1718 2391 2820 3151 3276 3206 2988 2569 1983 1321 587 -125 -837 -1516 -2112 -2554 -2854 -2951 -2883 -2669 -2285 -1771 -1186 -539 119 779 1363 1889 2223 2457 2528 2451 2177 1776 1271 681 88 -500 -1079 -1592 -2009 -2283 -2420 -2354 -2230 -1904 -1460 -942 -385 198 766 1263 1660 1967 2138 2185 2094 1889 1518 1102 577 56 -463 -971 -1423 -1799 -2070 -2222 -2244 -2112 -1910 -1554 -1166 -679 -162 353 797 1195 1505 1733 1844 1863 1696 1489 1144 731 267 -201 -706 -1157 -1525 -1834 -2036 -2089 -2033 -1893 -1644 -1281 -865 -367 85 572 968 1342 1591 1783 1812 1699 1481 1186 811 413 -66 -534 -965 -1333 -1699 -1920 -2046 -2022 -1964 -1721 -1410 -989 -505 -14 471 929 1337 1673 1863 1989 1993 1854 1634 1318 898 477 -50 -484 -940 -1320 -1657 -1852 -1978 -1928 -1778 -1531 -1199 -785 -316 174 634 1092 1470 1789 2022 2107 2081 1999 1715 1374 939 488 -27 -493 -953 -1326 -1644 -1880 -1997 -1960 -1875 -1639 -1345 -927 -511 -85 342 834 1202 1570 1801 1938 1989 1893 1721 1436 1068 663 216 -185 -632 -1040 -1384 -1625 -1783 -1857 -1836 -1659 -1466 -1131 -748 -359 46 476 852 1200 1445 1600 1678 1710 1544 1297 1003 676 246 -175 -621 -990 -1353 -1628 -1855 -1947 -1965 -1851 -1639 -1341 -973 -524 -106 376 776 1160 1492 1715 1815 1838 1738 1589 1279 979 559 106 -285 -731 -1128 -1450 -1731 -1922 -2001 -2005 -1863 -1636 -1316 -948 -545 -137 306 755 1126 1466 1717 1893 1955 1915 1760 1531 1190 844 384 -61 -511 -921 -1299 -1584 -1773 -1889 -1880 -1730 -1520 -1152 -716 -256 156 622 1057 1437 1709 1873 1925 1902 1718 1431 1103 706 272 -164 -563 -915 -1224 -1450 -1592 -1642 -1596 -1441 -1194 -879 -527 -133 274 705 1015 1294 1515 1610 1671 1592 1412 1195 876 556 214 -153 -495 -800 -1037 -1189 -1307 -1308 -1260 -1087 -879 -626 -335 8 321 651 900 1137 1299 1402 1387 1341 1165 950 689 388 50 -266 -572 -823 -1028 -1203 -1287 -1265 -1197 -1052 -847 -539 -253 72 411 708 976 1236 1404 1470 1433 1350 1181 965 679 366 71 -217 -547 -789 -971 -1039 -1082 -1008 -884 -726 -476 -185 104 403 697 939 1097 1232 1247 1257 1124 955 756 534 224 -38 -332 -537 -731 -889 -981 -992 -937 -839 -747 -547 -324 -111 116 343 547 724 847 924 910 902 777 676 482 301 85 -104 -272 -445 -597 -702 -779 -782 -800 -766 -653 -500 -390 -187 -59 114 259 417 508 603 643 676 626 572 463 366 200 54 -119 -237 -398 -501 -637 -698 -731 -722 -714 -624 -519 -369 -246 -82 54 248 372 492 540 592 589 526 426 358 211 56 -90 -206 -372 -476 -592 -640 -666 -661 -598 -487 -367 -211 -66 151 290 430 526 663 695 753 719 724 629 563 430 300 153 20 -85 -158 -251 -296 -309 -301 -269 -217 -153 -51 33 151 230 345 429 495 527 558 568 572 508 421 321 240 111 43 -114 -175 -232 -267 -288 -305 -300 -214 -180 -79 4 104 206 324 403 511 555 580 585 618 563 498 458 382 308 279 198 148 108 95 51 51 50 66 91 104 116 162 183 214 195 253 261 274 279 267 266 285 266 285 254 258 254 243 269 235 180 175 154 179 159 119 164 216 227 274 314 371 398 461 495 532 509 485 498 401 325 271 164 100 -27 -116 -166 -204 -230 -227 -222 -166 -106 -4 127 258 364 485 577 663 708 753 743 718 608 547 440 298 188 75 -71 -153 -204 -227 -246 -208 -198 -140 -85 43 137 254 343 438 524 593 610 631 605 572 511 456 338 250 154 62 -17 -33 -103 -77 -114 -69 -38 59 117 193 288 369 390 429 438 456 408 353 303 235 140 80 -29 -95 -164 -192 -208 -185 -166 -119 -58 95 198 288 371 488 519 563 598 582 547 482 387 277 112 4 -132 -179 -319 -376 -447 -416 -416 -382 -298 -169 -80 69 211 364 490 624 718 774 789 811 768 721 601 509 384 271 154 33 -95 -138 -216 -259 -253 -237 -198 -171 -109 -22 56 167 264 374 450 530 551 584 595 553 500 458 348 275 146 51 -62 -166 -201 -254 -295 -266 -253 -164 -137 -59 11 98 214 343 403 514 550 603 632 593 543 509 405 337 196 111 17 -61 -146 -188 -242 -229 -224 -201 -187 -129 -104 -37 77 112 166 237 275 311 292 292 290 235 162 111 43 4 -59 -72 -124 -140 -140 -117 -108 -61 -24 56 109 158 169 240 264 284 292 275 266 256 185 124 109 64 1 -41 -72 -87 -80 -77 -46 -35 -11 41 43 56 69 101 116 119 133 108 51 56 53 59 9 43 32 67 95 104 109 150 167 171 183 204 213 190 171 172 122 130 98 95 30 16 -20 -46 -88 -83 -74 -56 -19 33 85 119 201 272 279 319 342 364 369 376 335 325 282 213 158 108 8 -30 -116 -130 -169 -182 -164 -140 -137 -82 -54 32 116 175 225 284 317 379 369 377 342 314).
! !
Boolean subclass: #True
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!True commentStamp: '<historical>' prior: 0!
True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing.

Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.!


!True methodsFor: 'logical operations'!
& alternativeObject 
	"Evaluating conjunction -- answer alternativeObject since receiver is true."

	^alternativeObject! !

!True methodsFor: 'logical operations'!
not
	"Negation--answer false since the receiver is true."

	^false! !

!True methodsFor: 'logical operations'!
| aBoolean 
	"Evaluating disjunction (OR) -- answer true since the receiver is true."

	^self! !


!True methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer the value of alternativeBlock since
	the receiver is true."

	^alternativeBlock value! !

!True methodsFor: 'controlling'!
ifFalse: alternativeBlock 
	"Since the condition is true, the value is the true alternative, which is nil. 
	Execution does not actually reach here because the expression is compiled 
	in-line."

	^nil! !

!True methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True methodsFor: 'controlling'!
ifTrue: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually 
	reach here because the expression is compiled in-line."

	^alternativeBlock value! !

!True methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer with the value of trueAlternativeBlock. Execution does not 
	actually reach here because the expression is compiled in-line."

	^trueAlternativeBlock value! !

!True methodsFor: 'controlling'!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer true since the receiver is true."

	^self! !


!True methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: 'true'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

True class
	instanceVariableNames: ''!

!True class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 11:09'!
initializedInstance
	^ true! !
ComponentLikeModel subclass: #TwoWayScrollPane
	instanceVariableNames: 'getMenuSelector getMenuTitleSelector xScrollBar yScrollBar scroller '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!
!TwoWayScrollPane commentStamp: '<historical>' prior: 0!
The scroller (a transform) of a scrollPane is driven by the scrollBar.  The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears halfway down the pane.  The total distance to achieve this range is called the totalScrollRange.!


!TwoWayScrollPane methodsFor: 'initialization' stamp: 'RAA 10/6/1998 19:43'!
initialize
	| |
	super initialize.
	borderWidth _ 2.  borderColor _ #inset.

	yScrollBar := ScrollBar new model: self slotName: 'yScrollBar'.
	yScrollBar borderWidth: 2; borderColor: #inset.
	self addMorph: yScrollBar.

	xScrollBar := ScrollBar new model: self slotName: 'xScrollBar'.
	xScrollBar borderWidth: 2; borderColor: #inset.
	self addMorph: xScrollBar.

	scroller := TransformMorph new color: Color transparent.
	scroller offset: 0@0.
	self addMorph: scroller.

	self on: #mouseEnter send: #mouseEnter: to: self.
	self on: #mouseLeave send: #mouseLeave: to: self.
	self extent: 150@120! !


!TwoWayScrollPane methodsFor: 'access' stamp: 'sw 2/12/98 00:30'!
colorForInsets
	"My submorphs use the surrounding color"
	| aColor |
	(aColor _ owner color) ifKindOf: Color thenDo: [:c | ^ aColor].
	"This workaround relates to cases where the scrollPane's color is not a true color but rather an InfiniteForm, which is not happy to be returned here"
	^ Color white! !

!TwoWayScrollPane methodsFor: 'access' stamp: 'RAA 10/6/1998 19:45'!
scroller
	^ scroller! !

!TwoWayScrollPane methodsFor: 'access' stamp: 'di 6/7/97 10:42'!
wantsSlot
	"For now do it the old way, until we sort this out"
	^ true! !


!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 10/6/1998 18:40'!
containsPoint: aPoint
	(super containsPoint: aPoint) ifTrue: [^ true].
	"Also include scrollbar when it is extended..."
	"used to handle retractable scrolbar"
	^ false! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/13/1999 14:50'!
extent: newExtent
	super extent: (newExtent max: 36@16).
	self resizeScrollBar; resizeScroller; setScrollDeltas! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'di 1/31/2001 09:59'!
fitContentsUpTo: maxFitSize
	"Implements the autoFit feature:  If the #maxAutoFitSize property is set, then change my size to track any changes in the extent of my contents up to the max extent.  Above that extent, use scrollbars.  Typically one uses the #hideUnneededScrollbars property as well."

	"Adjust my size to fit my contents reasonably snugly"

	self extent: (scroller contentBounds extent
				+ (yScrollBar width@xScrollBar height)
				+ (borderWidth*2) min: maxFitSize)
				 ! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/13/1999 15:56'!
leftoverScrollRange
	"Return the entire scrolling range minus the currently viewed area."
	^ self totalScrollRange - (self innerBounds extent * 3 // 4) max: 0@0
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 10/6/1998 19:00'!
resizeScrollBar
	"used to handle left vs right scrollbar"
	yScrollBar bounds: (bounds topLeft extent: 16 @ (bounds height - 16)).
	xScrollBar bounds: ((bounds left + 16) @ (bounds bottom - 16)  extent: (bounds width - 16) @ 16).
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'di 1/29/2001 14:18'!
resizeScroller
	| inner |
	"used to handle left vs right scrollbar"
	inner _ self innerBounds.
	scroller bounds: (inner topLeft + (yScrollBar width@0) corner: (inner bottomRight - (0@xScrollBar height)))! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 10/6/1998 18:40'!
scrollBarFills: aRectangle
	"Return true if a flop-out scrollbar fills the rectangle"
	"used to handle retractable scrolbar"
	^ false! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/24/1999 18:13'!
scrollBy: delta
	"Move the contents in the direction delta."
	"For now, delta is assumed to have a zero x-component. Used by scrollIntoView:"
	| r newOffset |

	newOffset _ (scroller offset - delta max: 0@0) min: self leftoverScrollRange.
	scroller offset: newOffset.

	r _ self leftoverScrollRange.
	r y = 0
		ifTrue: [yScrollBar value: 0.0]
		ifFalse: [yScrollBar value: newOffset y asFloat / r y].
	r x = 0
		ifTrue: [xScrollBar value: 0.0]
		ifFalse: [xScrollBar value: newOffset x asFloat / r x].
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/21/1999 10:17'!
scrollIntoView: desiredRectangle extra: anumber
	| shift |

	shift _ desiredRectangle deltaToEnsureInOrCentered: (
		scroller offset extent: scroller bounds extent
	)  extra: anumber.
	shift = (0 @ 0) ifFalse: [self scrollBy: (0@0) - shift].
! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'di 1/28/2001 21:37'!
setScrollDeltas
	| range scrollDelta totalRange innerBounds |
	totalRange _ self totalScrollRange ifNil: [^ self].
	range _ self leftoverScrollRange.
	innerBounds _ self innerBounds.
	scrollDelta _ 10 @ 10.
	self hideOrShowScrollBar: xScrollBar forRange: totalRange x - (innerBounds width - yScrollBar width).
	range x = 0
		ifTrue: [xScrollBar scrollDelta: 0.02 pageDelta: 0.2.
				xScrollBar interval: 1.0]
		ifFalse: [xScrollBar scrollDelta: (scrollDelta x / range x) asFloat
						pageDelta: (innerBounds width - scrollDelta x / range x) asFloat.
				xScrollBar interval: (innerBounds width - scrollDelta x / totalRange x) asFloat].
	self hideOrShowScrollBar: yScrollBar forRange: totalRange y - (innerBounds height - xScrollBar height).
	range y = 0
		ifTrue: [yScrollBar scrollDelta: 0.02 pageDelta: 0.2.
				xScrollBar interval: 1.0]
		ifFalse: [yScrollBar scrollDelta: (scrollDelta y / range y) asFloat
						pageDelta: (innerBounds height - scrollDelta y / range y) asFloat.
				yScrollBar interval: (innerBounds height - scrollDelta y / totalRange y) asFloat]! !

!TwoWayScrollPane methodsFor: 'geometry' stamp: 'RAA 8/13/1999 15:43'!
totalScrollRange

	"Return the entire scrolling range."
	^ ((scroller submorphBounds ifNil: [^nil]) encompass: 0@0) extent

! !


!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'RAA 6/9/2000 15:05'!
hideOrShowScrollBar

	^self		"we don't support retractable at the moment"! !

!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'di 1/23/2001 07:36'!
hideOrShowScrollBar: scrollBar forRange: range

	(self hasProperty: #hideUnneededScrollbars) ifFalse: [^ self].
	(submorphs includes: scrollBar)
		ifTrue: [range <= 0 ifTrue: [scrollBar model: nil; delete]]
		ifFalse: [range > 0 ifTrue: [scrollBar model: self.  self addMorph: scrollBar]]
! !

!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'RAA 10/6/1998 18:38'!
mouseEnter: event

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'retractable scroll bar' stamp: 'RAA 10/6/1998 18:38'!
mouseLeave: event

	"used to handle retractable scrolbar"! !


!TwoWayScrollPane methodsFor: 'pane events' stamp: 'di 5/7/1998 09:52'!
handlesMouseDown: evt
	^ true! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'di 7/3/1998 12:07'!
handlesMouseOver: evt
	^ true! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'RAA 10/6/1998 19:45'!
keyStroke: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"

	scroller submorphs last keyStroke: evt! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'RAA 10/6/1998 19:45'!
mouseDown: evt
	evt yellowButtonPressed  "First check for option (menu) click"
		ifTrue: [^ self yellowButtonActivity: evt shiftPressed].
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'RAA 10/6/1998 19:45'!
mouseMove: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseMove: (evt transformedBy: (scroller transformFrom: self))]! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'RAA 10/6/1998 19:45'!
mouseUp: evt
	"If pane is not full, pass the event to the last submorph,
	assuming it is the most appropriate recipient (!!)"
	scroller hasSubmorphs ifTrue:
		[scroller submorphs last mouseUp: (evt transformedBy: (scroller transformFrom: self))]! !

!TwoWayScrollPane methodsFor: 'pane events' stamp: 'RAA 11/23/2000 10:16'!
rejectsEvent: anEvent

	scroller submorphs isEmpty ifTrue: [^true].	"something messed up here"
	scroller firstSubmorph isSyntaxMorph ifTrue: [^ super rejectsEvent: anEvent].
	^self visible not		"ignore locked status"! !


!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
scrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'!
shiftedYellowButtonActivity
	^ self yellowButtonActivity: true! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'!
unshiftedYellowButtonActivity
	^ self yellowButtonActivity: false! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 10/6/1998 22:38'!
xScrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 8/24/1999 16:01'!
xScrollBarValue: scrollValue 

	"although there appear to be no senders, see Slider>>setValue:"

	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: self leftoverScrollRange x * scrollValue @ scroller offset y! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 10/6/1998 22:37'!
yScrollBarMenuButtonPressed: event
	^ self yellowButtonActivity: event shiftPressed! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 8/13/1999 15:55'!
yScrollBarValue: scrollValue

	"although there appear to be no senders, see Slider>>setValue:"

	scroller hasSubmorphs ifFalse: [^ self].
	scroller offset: scroller offset x @ (self leftoverScrollRange y * scrollValue)! !

!TwoWayScrollPane methodsFor: 'scroll bar events' stamp: 'RAA 6/12/2000 09:01'!
yellowButtonActivity: shiftKeyState
	| menu |
	(menu _ self getMenu: shiftKeyState) ifNotNil:
		[menu setInvokingView: self.
		menu popUpEvent: self activeHand lastEvent in: self world]! !


!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:39'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'sw 9/23/1998 08:47'!
getMenu: shiftKeyState
	"Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key."
	| menu aMenu aTitle |
	getMenuSelector == nil ifTrue: [^ nil].
	menu _ MenuMorph new defaultTarget: model.
	aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector].
	getMenuSelector numArgs = 1 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	getMenuSelector numArgs = 2 ifTrue:
		[aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState.
		aTitle ifNotNil:  [aMenu addTitle: aTitle].
		^ aMenu].
	^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:41'!
leftOrRight  "Change scroll bar location"

	"used to handle left vs right scrollbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'!
menuTitleSelector: aSelector
	getMenuTitleSelector _ aSelector! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:38'!
retractableOrNot  "Change scroll bar operation"

	"used to handle retractable scrolbar"! !

!TwoWayScrollPane methodsFor: 'menu' stamp: 'RAA 10/6/1998 18:41'!
scrollBarOnLeft: aBoolean

	"used to handle left vs right scrollbar"! !


!TwoWayScrollPane methodsFor: 'layout' stamp: 'ar 2/1/2001 17:00'!
doLayoutIn: layoutBounds
	"layout has changed. update scroll deltas or whatever else"
	self valueOfProperty: #maxAutoFitSize ifPresentDo:
		[:maxFitSize |
		self fitContentsUpTo: maxFitSize.
		^super doLayoutIn: layoutBounds].
	scroller ifNotNil: [self setScrollDeltas].
	super doLayoutIn: layoutBounds.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

TwoWayScrollPane class
	instanceVariableNames: ''!

!TwoWayScrollPane class methodsFor: 'as yet unclassified' stamp: 'di 2/21/98 11:02'!
includeInNewMorphMenu
	"OK to instantiate"
	^ true! !
BasicButton subclass: #URLMorph
	instanceVariableNames: 'url page isBookmark book '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-SqueakPage'!
!URLMorph commentStamp: '<historical>' prior: 0!
This morph represents a URL for a SqueakPage. It displays the thumbnail for the associated page, if available. Used in page sorters and for bookmarks.

This morph has several options:
  a. It can act like a thumbnail for sorting (in which case it can be picked up and dragged) or it acts as a bookmark (in which case shift clicking on it activates it).
  b. If it has book set to true, it is a page in a book.  Clicking fetches the index of the book, opens it to the first page, and puts it in the hand.

A thumbnail on a known book:
	(URLMorph grabURL: 'ftp://doltest1.disney.com/squeak/test/p1.sp')
		book: true.

A thumbnail on a single PasteUpMorph:
Make a PasteUpMorph with any morphs in it.
Decide where it should live, make a url string, and copy it.
	'file://HardDisk/books/book1/myPage.sp'
	'ftp://doltest1.disney.com/squeak/test/p1.sp'
Choose 'Save as Web Morph'
Paste in the url.
Drop the resulting thumbnail into some morph.

See SqueakPage's comment for the stages of in/out.

url 
page 		A SqueakPage
isBookmark 		Boolean
book 	A Boolean -- whether I represent a whole book or a page.
!


!URLMorph methodsFor: 'initialization' stamp: 'jm 6/17/1998 07:16'!
initialize

	super initialize.
	color _ Color lightGray.
	isBookmark _ false.
! !


!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 21:49'!
book

	^ book
! !

!URLMorph methodsFor: 'accessing' stamp: 'tk 2/17/1999 12:38'!
book: aUrl
	"A notation about what book this page is in.  true means page is in same book as url strm says.  Set to the url of the Book if the book has a different stem url.  nil or false if not for a book page at all."

	book _ aUrl! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:16'!
isBookmark

	^ isBookmark
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:17'!
isBookmark: aBoolean
	"Make this morph behave as a clickable bookmark if the argument is true."

	isBookmark _ aBoolean.
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/16/1998 18:07'!
page
	"Answer the cached page that this morph represents."

	^ page
! !

!URLMorph methodsFor: 'accessing' stamp: 'jm 6/17/1998 07:05'!
url
	"Answer the URL for the page that this morph represents."

	^ url
! !


!URLMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:07'!
drawOn: aCanvas
	"Draw thumbnail for my page, if it is available. Otherwise, just draw a rectangle." 

| thumbnail oldExt |
color == Color transparent 
	ifTrue: ["show thumbnail"
		thumbnail _ self thumbnailOrNil.
		thumbnail
			ifNil: [aCanvas frameRectangle: bounds width: borderWidth 
						color: borderColor.
				aCanvas fillRectangle: (bounds insetBy: borderWidth) color: color]
			ifNotNil: [oldExt _ bounds extent.
				bounds _ bounds origin extent: thumbnail extent + (2@2).
				aCanvas frameRectangle: bounds width: borderWidth color: borderColor.
				aCanvas paintImage: thumbnail at: bounds origin + borderWidth.
				oldExt = thumbnail extent ifFalse: [self layoutChanged]]]
	ifFalse: ["show labeled button"
		^ super drawOn: aCanvas]
! !


!URLMorph methodsFor: 'event handling' stamp: 'tk 1/13/1999 08:04'!
handlesMouseDown: event

	^ isBookmark & event shiftPressed
! !

!URLMorph methodsFor: 'event handling' stamp: 'tk 10/2/1998 08:55'!
handlesMouseUp: evt

	^ isBookmark
! !

!URLMorph methodsFor: 'event handling' stamp: 'tk 10/2/1998 08:58'!
mouseDown: evt
	"do nothing"
! !

!URLMorph methodsFor: 'event handling' stamp: 'sma 4/30/2000 10:52'!
mouseUp: evt
	| pg ow newPage mm bookUrl bk |
	"If url of a book, open it to that page, or bring it in and open to that page."
	book ifNotNil: [book == false ifFalse: [
		(bookUrl _ book) class == String ifFalse: [
			bookUrl _ (SqueakPage stemUrl: url), '.bo'].
		(bk _ BookMorph isInWorld: self world withUrl: bookUrl) class ~~ Symbol 
			ifTrue: [^ bk goToPageUrl: url].
		bk == #conflict ifTrue: [
			^ self inform: 'This book is already open in some other project'].
		(bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self].
		bk goToPageUrl: url.	"turn to the page"
		^ HandMorph attach: bk]].

	"If inside a SqueakPage, replace it!!"
	pg _ self enclosingPage.
	pg ifNotNil: [
		(ow _ pg contentsMorph owner) ifNotNil: [
			pg contentsMorph delete.	"from its owner"
			newPage _ SqueakPageCache atURL: url.
			mm _ newPage fetchContents.
			mm ifNotNil: [ow addMorph: mm.
				page _ newPage].
			^ self]].
	"If I am a project, jump  -- not done yet"

	"For now, just put new page on the hand"
	newPage _ SqueakPageCache atURL: url.
	mm _ newPage fetchInformIfError.
	mm ifNotNil: [self primaryHand attachMorph: mm.
		page _ newPage].

! !


!URLMorph methodsFor: 'updating' stamp: 'jm 6/17/1998 14:15'!
pageHasChanged: aSqueakPage
	"The given page has changed. Update this morph if it refers to the given page."

	| thumbnail |
	page == aSqueakPage ifFalse: [^ self].  "this change does not affect me"
	thumbnail _ self thumbnailOrNil.
	thumbnail ifNotNil: [
		self extent: (thumbnail extent + 2).
		self changed].
! !


!URLMorph methodsFor: 'private' stamp: 'tk 11/23/1998 17:37'!
enclosingBook
	"rethink this since class WebBookMorph is gone"! !

!URLMorph methodsFor: 'private' stamp: 'di 11/13/2000 00:55'!
enclosingPage
	"Answer the inner-most SqueakPage contents that contains this morph, or nil if there isn't one."

	self allOwnersDo:
		[:m | (m isKindOf: PasteUpMorph)
			ifTrue: [(SqueakPageCache pageForMorph: m) ifNotNilDo: [:pg | ^ pg]]].
	^ nil
! !

!URLMorph methodsFor: 'private' stamp: 'RAA 8/30/2000 11:56'!
label: aString font: aFontOrNil

	| oldLabel m aFont |
	(oldLabel _ self findA: StringMorph)
		ifNotNil: [oldLabel delete].
	(oldLabel _ self findA: TextMorph)
		ifNotNil: [oldLabel delete].
	aFont _ aFontOrNil ifNil: [Preferences standardButtonFont].
	m _ TextMorph new contents: aString; beAllFont: aFont.
	self extent: (m width + 6) @ (m height + 6).
	m position: self center - (m extent // 2).
	self addMorph: m.
	m lock
! !

!URLMorph methodsFor: 'private' stamp: 'tk 10/2/1998 08:20'!
setURL: aURLString page: aSqueakPage
	"Initialize the receiver for the given URL and page."

	url _ aURLString.
	page _ aSqueakPage.
	page ifNotNil: [self pageHasChanged: page].
! !

!URLMorph methodsFor: 'private' stamp: 'tk 2/24/1999 12:31'!
thumbnailOrNil
	"Answer the thumbnail Form for the page this morph represents. Answer nil if no thumbnail is available."

	| thum |
	page ifNil: [page _ SqueakPageCache atURL: url].
	(thum _ page thumbnail) ifNil: [^ nil].
	^ (thum isKindOf: Form) 
		ifTrue: [thum]
		ifFalse: [thum form]	"a BookPageThumbnailMorph"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

URLMorph class
	instanceVariableNames: ''!

!URLMorph class methodsFor: 'instance creation' stamp: 'tk 2/27/1999 14:18'!
grabForBook: bookMorph
	"Create a URLMorph for this book.  Put it into the hand."

	| um bookUrl pageUrl pg |
	bookUrl _ bookMorph valueOfProperty: #url.
	pageUrl _ bookMorph currentPage url.	"should have one!!"
	pg _ SqueakPageCache atURL: pageUrl.
	(SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: pageUrl) 
		ifTrue: [bookUrl _ true].		"not a shared book"
	um _ URLMorph newForURL: pageUrl.
	um setURL: pageUrl page: pg.
	pg isContentsInMemory ifTrue: [pg computeThumbnail].
	um isBookmark: true.
	um book: bookUrl.
	um removeAllMorphs.
	um color: Color transparent.
	Smalltalk currentHand attachMorph: um.
	^ um! !

!URLMorph class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:52'!
grabURL: aURLString
	"Create a URLMorph for this url.  Drop it and click it to get the SqueakPage."

	| um |
	(um _ self new) isBookmark: true; setURL: aURLString page: nil.
	HandMorph attach: um.
	^ um! !

!URLMorph class methodsFor: 'instance creation' stamp: 'jm 6/17/1998 07:35'!
newBookmarkForURL: aURLString

	^ (self newForURL: aURLString) isBookmark: true
! !

!URLMorph class methodsFor: 'instance creation' stamp: 'tk 10/2/1998 12:08'!
newForURL: aURLString

	| pg |
	pg _ SqueakPageCache atURL: aURLString.
	^ self new setURL: aURLString page: pg
! !
Object subclass: #URLmap
	instanceVariableNames: 'pages directory action '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Pluggable Web Server'!

!URLmap methodsFor: 'linking' stamp: 'mjg 9/1/1998 12:41'!
linkFor: string from: peer storingTo: aList
	| uString newpage |
	uString _ string asUppercase.
	(self isStringRooted: uString)
		ifTrue: ["an external URL"
			(self isStringAnImage: uString)
				ifTrue: ["Looks like an image URL"
						^self imageURL: string]
				ifFalse: [^self externalURL: string]]
		ifFalse: [ "Serious!! Gotta provide-a-link!! But check for
image or local action first"
				(self isStringAnImage: uString)
					ifTrue: [^self localImageURL: string].
				(self isStringALocalAction: uString)
					ifTrue:[^self localActionURL: string].
			newpage _ pages at: string asLowercase ifAbsent: [nil].
			newpage isNil
				ifTrue: [ "Create a new page"
					newpage _ self newpage: string
from: peer.].
			(aList indexOf: newpage) ~= 0
				ifFalse: [aList add: newpage]. "Add only if
not there"
			^self pageURL: newpage]! !

!URLmap methodsFor: 'linking' stamp: 'mjg 9/1/1998 12:47'!
linkFor: string from: peer storingTo: aList page: aPage
	| uString placeID |

	uString _ string asUppercase.
	(uString beginsWith: 'APPEND HERE') ifTrue: [
		placeID _ uString copyFrom: (13 min: uString size) to:
uString size.
		^'<a href="', aPage url, '.insert.', placeID ,'">','Append
Here','</a>'].
			"later an image here"
	^self linkFor: string from: peer storingTo: aList.
! !


!URLmap methodsFor: 'searching' stamp: 'BJP 9/7/1998 01:06'!
recent
	| response sortedPages currentDate |
	sortedPages _ pages reject: [:page | page pageStatus = #new].
"We definitely want the reject: first, so we sort a smaller collection.
Having the variable name be 'sortedPages' is a bit of a misnomer, though."

"I think we shouldn't do all this for each call to recent changes. After
all, most of the time, it's *hasn't* changed, and when it *has*, it's
pretty much only added something to the end. At the very least we should
cache the sorted, filtered collection."

"And really, why is this in URLmap? Recent Changes is a kind of page. I'd
rather see it as a swikipage, perhaps standardly defined (that is, when you
set up a swiki, you get a front page, a formatting page, and a Recent
Changes page). That is, SwikiPages could store text (as they do now) or
cgi-ish functions (like recent). That way, we could design custom templates
for them, etc.

At the very least, there needs to be better labeling. Why not call the
category with these page functions, 'dynamic pages', or somethign similar?"

"A different condsideration: It would be nice to have arbitrary filters:
e.g., 'past ten days', 'all pages *not* yet edited', etc., and be able to
combine them. Would work as a 'search for various attributes' feature which
one might or might not expose to the user."
	sortedPages _ sortedPages asSortedCollection: [:a :b | (a date = b
date) ifTrue: [a time > b time]
			ifFalse: [a date > b date]].
	response _ WriteStream on: String new.
	response nextPutAll: '<h2>Recent Changes</h2><ul>'.
	currentDate _ Date new.
	sortedPages do: [:page |
		(currentDate ~= page date)
		ifTrue: [
			currentDate _ page date.
			response nextPutAll: '</ul><p><b>',(currentDate
printString),'</b><p><ul>'.].
		response nextPutAll: '<li>',(self pageURL: page),'...',(page
address).].
	response nextPutAll: '</ul>'.
	^response contents

		! !

!URLmap methodsFor: 'searching' stamp: 'mjg 12/5/97 12:21'!
searchFor: aString
	| hitlines response |
	hitlines _ pages select: [:each | each text includesSubstring: aString caseSensitive: false].
	hitlines isEmpty
	ifTrue: [^aString, ' not found']
	ifFalse: [
		response _ WriteStream on: String new.
		response nextPutAll: '<h2>Search results for ',aString,'</h2><ul>'.
		hitlines do: [:each
			|response nextPutAll: '<li>',(self pageURL: each),'...',(each address)].
		response nextPutAll: '</ul>'.
		^response contents].
! !


!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
action
	"Answer the receiver's 'action'."

	^action! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
action: anObject
	"Set the receiver's instance variable 'action' to be anObject."

	action := anObject! !

!URLmap methodsFor: 'accessing' stamp: 'tk 2/3/98 15:47'!
at: key
	"Return page of a given key."

	^pages at: key asLowercase ifAbsent: [nil]! !

!URLmap methodsFor: 'accessing' stamp: 'tk 2/3/98 15:47'!
at: key put: anObject
	"Add anObject to the pages list."

	pages at: key asLowercase put: anObject! !

!URLmap methodsFor: 'accessing' stamp: 'JZH 10/13/1998 22:56'!
atID: id
	"Return page of a given key."
	| idString |
	idString _ id isInteger ifTrue: [id printString] ifFalse: [id].
	^ pages detect: [:page | page coreID = idString] ifNone: [self
atID: '1']! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
directory
	"Answer the receiver's 'directory'."

	^directory! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
directory: anObject
	"Set the receiver's instance variable 'directory' to be anObject."

	directory := anObject! !

!URLmap methodsFor: 'accessing' stamp: 'TPR 7/27/1998 15:16'!
externalURL: aString
	"make a non-local  URL"
	^'<a href="',aString,'">',aString,'</a>'! !

!URLmap methodsFor: 'accessing' stamp: 'TPR 7/27/1998 15:15'!
imageURL: aString
	"make a non-local image URL"
	^'<img src="', aString,'" alt="', aString,'">'! !

!URLmap methodsFor: 'accessing' stamp: 'TPR 7/27/1998 15:10'!
localActionURL: aString
	|string|
	"fake up a more ordinary URL by dropping the shriek chars"
	string _ aString copyWithout: $!!.
	^'<a href="',string,'">',string,'</a>'! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 9/1/1998 12:32'!
localImageURL: aString
	"make a local image URL"
	^'<img src="',action name, '/', aString,'" alt="', action name,'/',
aString,'">'! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 10/14/1998 14:38'!
pageURL: aPage
	(aPage pageStatus = #new)
		ifTrue:
			[(action isKindOf: CachedSwikiAction)
			ifFalse: [^'<u>',(aPage name),'</u><a href="', 
				(action pageURL: aPage),'.edit">?</a>']
			ifTrue: [^'<u>',(aPage name),'</u><a href="',
				(action pwsURL),(action name),'.',(aPage coreID),'.edit">?</a>']
				"Underlines new but not yet edited pages"]
		ifFalse:
			[^'<a href="', (action pageURL: aPage),'">',(aPage name),'</a>']

"Logically, there should be editPageUrl in SwikiAction as well. After all,
we might want to define other URL schemes." ! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
pages
	"Answer the receiver's 'pages'."

	^pages! !

!URLmap methodsFor: 'accessing' stamp: 'mjg 11/25/97 16:31'!
pages: anObject
	"Set the receiver's instance variable 'pages' to be anObject."

	pages := anObject! !


!URLmap methodsFor: 'creating' stamp: 'mjg 11/26/97 12:27'!
allPagesFrom: pageRef
	^self allPagesFrom: pageRef for: '' "Probably won't create new pages here"! !

!URLmap methodsFor: 'creating' stamp: 'BJP 9/7/1998 00:52'!
allPagesFrom: pageRef for: request
	| formattedPage refPages allPages peer |
	(request isKindOf: PWS) ifTrue: [peer _ request peerName] ifFalse:
[peer_''].
	formattedPage _ pageRef copy.  "Make a copy, then format the text."
	refPages _ OrderedCollection new.
	formattedPage formatted: (action formatter swikify: (pageRef text)

	linkhandler: [:link | self linkFor: link

				from: peer

				storingTo: refPages]).
	"This filtering should be generalized a tad, methinks. Perhaps
incorparated into the
	linkhandler."
	refPages _ refPages reject: [:page | page pageStatus = #new].
	"Now, put all referenced pages into the page"
	allPages _ WriteStream on: String new.
	allPages nextPutAll: '<h2>',(pageRef name),'</h2>', formattedPage
formatted.
	refPages do: [:page |
		allPages nextPutAll: '<h2>',(page name),'</h2>'.
		allPages nextPutAll: (HTMLformatter swikify: (page text)

	linkhandler: [:link | self linkFor: link

				from: peer

				storingTo:
(OrderedCollection new)]).].
	formattedPage formatted: allPages contents. "Put all the pages into THE
page"
	^formattedPage
! !

!URLmap methodsFor: 'creating' stamp: 'mjg 10/9/1998 13:06'!
newpage: label from: peer
	| newpage newfile |
	newfile _ ((pages inject: 0 into: [:max :p |
		p coreID asNumber > max ifTrue: [p coreID asNumber]
				ifFalse: [max]]) + 1) printString.
	newpage _ action class pageClass new.
	self at: label put: newpage.
	newpage address: peer.
	newpage date: (Date today).
	newpage time: (Time now).
	newpage coreID: newfile.
	newpage name: label.
	newpage file: ((ServerAction serverDirectory),
		directory, (ServerAction pathSeparator), newfile).
	newpage pageStatus: #new.
	newpage text: 'Describe ',label,' here'.
	newpage map: self.
	newpage url: (action name),'.',newfile.
	^newpage
! !

!URLmap methodsFor: 'creating' stamp: 'mjg 8/28/1998 19:48'!
storeID: id text: text from: peer
	| page |
	page _ self atID: id.
	page date: (Date today).
	page time: (Time now).
	page text: text.
	page address: peer.
	^ page! !

!URLmap methodsFor: 'creating' stamp: 'tk 7/14/1998 19:32'!
storeID: id text: insertedText insertAt: idString
	"Insert in a place in the text.  Just before '*append here 34*' if
idString is '34'."
	| page bigText ind toInsert |
	page _ self atID: id.
	page date: (Date today).
	bigText _ page text.
	ind _ bigText findString: '*append here ',idString,'*' startingAt:
1.	"always lower case"
	ind = 0 ifTrue: [^ page].		"could not find that place"
	"Make sure new text surrounded by line feeds"
	toInsert _ (insertedText last == Character linefeed)
		ifTrue: [insertedText]
		ifFalse: [insertedText, (String with: Character linefeed)].
	((insertedText first == Character linefeed) or: [
		(bigText at: (ind-1 max: 1)) == Character linefeed])
			ifFalse: [toInsert _ (String with: Character
linefeed), toInsert].
	page text: (bigText copyReplaceFrom: ind to: ind-1 with: toInsert).
	"page address: peer.  Don't sign with person who only added"
	^ page! !


!URLmap methodsFor: 'private' stamp: 'TPR 7/27/1998 14:51'!
isStringALocalAction: anUpperCasedString
	"check the string to see if it starts and end with  a shriek - code
for a Swiki action such as Comment or whatever"
	^(anUpperCasedString size >=2) and:
	[anUpperCasedString first = $!! and:
	[anUpperCasedString last= $!!]]! !

!URLmap methodsFor: 'private' stamp: 'mjg 9/21/1998 10:47'!
isStringAnImage: anUpperCasedString
	"check the string to see if it end with something that makes it likely to be an image URL"
	^(anUpperCasedString endsWith: '.GIF') or:
		[(anUpperCasedString endsWith: '.JPEG') or:
		[anUpperCasedString endsWith: '.JPG']]! !

!URLmap methodsFor: 'private' stamp: 'TPR 7/27/1998 14:37'!
isStringRooted: anUpperCasedString
	"check the string to see if it starts with something that makes it
lkely to be a rooted URL"
	^(anUpperCasedString indexOfSubCollection: 'HTTP' startingAt: 1) =
1 or:
	[(anUpperCasedString indexOfSubCollection: 'FTP' startingAt: 1) = 1 or:
	[(anUpperCasedString indexOfSubCollection: 'MAILTO' startingAt: 1)
= 1]]! !


!URLmap methodsFor: 'fileRendering' stamp: 'mjg 8/31/1998 16:53'!
addToGlossary: myName as: myURL
	|aStream |
	"Add to a CR-delimited file of 'pageName' and 'URL' separated by
vertical bars '|'"
	aStream _ directory oldFileNamed: 'glossary'.
	aStream open.
	aStream setToEnd.
	aStream nextPutAll: myName,'|',myURL; cr.
	aStream close.


	! !

!URLmap methodsFor: 'fileRendering' stamp: 'mjg 9/1/1998 09:44'!
readGlossary: aStream
	|aLine pieces name url newpage|
	"Expect a CR-delimited file of 'pageName' and 'URL' separated by
vertical bars '|'"
	self pages: (Dictionary new).
	aStream open.
	[aStream atEnd] whileFalse:
		[aLine := aStream upTo: (Character cr).
		pieces _ aLine findTokens: '|'.
		name _ pieces at: 1.
		url _ pieces at: 2.
		newpage _ SwikiPage new.
		newpage coreID: url.
		newpage map: self.
		newpage name: name.
		pages at: name asLowercase put: newpage].
	aStream close.


	! !

!URLmap methodsFor: 'fileRendering' stamp: 'mjg 9/1/1998 09:47'!
writeGlossary
	"Write out the pages dictionary as a CR-delimited file of pagename
and URL"
	|aStream |
	aStream _ directory oldFileNamed: 'glossary'.
	aStream open.
	pages keys asSortedCollection do: [:each |
		aStream nextPutAll: (pages at: each) name,'|',(pages at:
each) coreID; cr.].
	aStream close.


	! !
Object subclass: #UndefinedObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
!UndefinedObject commentStamp: '<historical>' prior: 0!
I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.!


!UndefinedObject methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'!
clone
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying' stamp: 'sw 9/26/97 10:31'!
copyRecordingIn: aDictionary
	^ self! !

!UndefinedObject methodsFor: 'copying'!
deepCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying'!
shallowCopy
	"Only one instance of UndefinedObject should ever be made, so answer 
	with self."! !

!UndefinedObject methodsFor: 'copying' stamp: 'tk 8/20/1998 16:07'!
veryDeepCopyWith: deepCopier
	"Return self.  I can't be copied.  Do not record me."! !


!UndefinedObject methodsFor: 'printing' stamp: 'sw 10/29/1998 16:34'!
newTileMorphRepresentative
	^ UndescribedTile new! !

!UndefinedObject methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'nil'! !

!UndefinedObject methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:." 

	aStream nextPutAll: 'nil'! !


!UndefinedObject methodsFor: 'testing' stamp: 'di 11/8/2000 21:23'!
doIfNotNil: aBlock
	"Deprecated;  use ifNotNilDo:"

	^ self ifNotNilDo: aBlock! !

!UndefinedObject methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'!
haltIfNil
	self halt! !

!UndefinedObject methodsFor: 'testing'!
ifNil: aBlock
	"A convenient test, in conjunction with Object ifNil:"

	^ aBlock value! !

!UndefinedObject methodsFor: 'testing'!
ifNil: nilBlock ifNotNil: ifNotNilBlock
	"Evaluate the block for nil because I'm == nil"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing'!
ifNotNil: aBlock
	"A convenient test, in conjunction with Object ifNotNil:"

	^ self! !

!UndefinedObject methodsFor: 'testing'!
ifNotNil: ifNotNilBlock ifNil: nilBlock 
	"If I got here, I am nil, so evaluate the block nilBlock"

	^ nilBlock value! !

!UndefinedObject methodsFor: 'testing' stamp: 'di 11/8/2000 21:22'!
ifNotNilDo: aBlock
	"Override to do nothing."

	^ self
! !

!UndefinedObject methodsFor: 'testing' stamp: 'sw 4/7/1999 17:44'!
isEmptyOrNil
	"Answer whether the receiver contains any elements, or is nil.  Useful in numerous situations where one wishes the same reaction to an empty collection or to nil"
	^ true! !

!UndefinedObject methodsFor: 'testing' stamp: 'sma 6/6/2000 22:53'!
isLiteral
	^ true! !

!UndefinedObject methodsFor: 'testing'!
isNil 
	"Refer to the comment in Object|isNil."

	^true! !

!UndefinedObject methodsFor: 'testing'!
notNil 
	"Refer to the comment in Object|notNil."

	^false! !


!UndefinedObject methodsFor: 'dependents access'!
addDependent: ignored 
	"Refer to the comment in Object|dependents."

	self error: 'Nil should not have dependents'! !

!UndefinedObject methodsFor: 'dependents access'!
release
	"Nil release is a no-op"! !

!UndefinedObject methodsFor: 'dependents access'!
suspend
	"Kills off processes that didn't terminate properly"
	"Display reverse; reverse."  "<-- So we can catch the suspend bug"
	Processor terminateActive! !


!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:49'!
addSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:57'!
environment
	"Necessary to support disjoint class hierarchies."
	^Smalltalk! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ikp 9/26/97 14:45'!
removeSubclass: aClass
	"Ignored -- necessary to support disjoint class hierarchies"! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 18:56'!
subclass: nameOfClass  "Define root (superclass = nil) of a class hierarchy"
	instanceVariableNames: instVarNames
	classVariableNames: classVarNames
	poolDictionaries: poolDictnames
	category: category
	^(ClassBuilder new)
		superclass: self
		subclass: nameOfClass
		instanceVariableNames: instVarNames
		classVariableNames: classVarNames
		poolDictionaries: poolDictnames
		category: category
! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 8/29/1999 12:49'!
subclassDefinerClass
	"For disjunct class hierarchies -- how should subclasses of nil be evaluated"
	^Compiler! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:55'!
subclasses
	"Return all the subclasses of nil"
	| classList |
	classList _ WriteStream on: Array new.
	self subclassesDo:[:class| classList nextPut: class].
	^classList contents! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 15:44'!
subclassesDo: aBlock
	"Evaluate aBlock with all subclasses of nil."
	^Class subclassesDo:[:cl| 
		cl isMeta ifTrue:[aBlock value: cl soleInstance]].! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'tk 8/18/1999 17:46'!
subclassesDoGently: aBlock
	"Evaluate aBlock with all subclasses of nil.  Others are not direct subclasses of Class."

	^ Class subclassesDoGently: [:cl | 
			cl isMeta ifTrue: [aBlock value: cl soleInstance]].! !

!UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/13/1999 06:08'!
typeOfClass
	"Necessary to support disjoint class hierarchies."
	^#normal! !


!UndefinedObject methodsFor: '3ds parser support' stamp: 'ar 2/6/1999 20:18'!
from3DS: aDictionary
	^aDictionary! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndefinedObject class
	instanceVariableNames: ''!

!UndefinedObject class methodsFor: 'instance creation' stamp: 'sw 5/5/2000 09:32'!
initializedInstance
	^ nil! !

!UndefinedObject class methodsFor: 'instance creation'!
new
	self error: 'You may not create any more undefined objects--use nil'! !
TileMorph subclass: #UndescribedTile
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!UndescribedTile methodsFor: 'initialization' stamp: 'sw 10/29/1998 16:45'!
initialize
	super initialize.
	self extent: (20 @ 22)! !
Object subclass: #UndoAction
	instanceVariableNames: 'wrappedAction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoAction commentStamp: '<historical>' prior: 0!
Undo the effects of the wrapped Action.
!


!UndoAction methodsFor: 'undoing' stamp: 'jsp 2/23/1999 14:21'!
undoIt
	"Undo the wrapped action"

	wrappedAction value.
! !


!UndoAction methodsFor: 'accessing' stamp: 'di 3/10/2000 08:40'!
rectifyActorClassesInBlocks  "UndoAction allInstancesDo: [:ua | ua rectifyActorClassesInBlocks]"
	"Rectify obsolete class refs held onto by UndoActions"

	| ctxt obs |
	ctxt _ wrappedAction home.
	1 to: ctxt size do:
		[:i | obs _ ctxt at: i.
		((obs isKindOf: Behavior) and: [obs isObsolete])
			ifTrue: [ctxt at: i put: obs nonObsoleteClass]]! !

!UndoAction methodsFor: 'accessing' stamp: 'jsp 2/23/1999 14:23'!
setAction: anAction
	"Specify the undo action to wrap."

	wrappedAction _ anAction.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoAction class
	instanceVariableNames: ''!

!UndoAction class methodsFor: 'instance creation' stamp: 'jsp 2/23/1999 14:33'!
new: anAction
	"Create a wrapper for undoing an animation"

	| newUndo |

	newUndo _ UndoAction new.
	newUndo setAction: anAction.
	^ newUndo.! !
Object subclass: #UndoAnimation
	instanceVariableNames: 'wrappedAnimation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoAnimation commentStamp: '<historical>' prior: 0!
Undo an Animation.  Currently Wonderlands undo animations by running them in reverse with a compressed duration.
!


!UndoAnimation methodsFor: 'accessing' stamp: 'jsp 2/16/1999 12:45'!
setAnimation: anAnimation
	"Set wrapped animation."

	wrappedAnimation _ anAnimation.
! !


!UndoAnimation methodsFor: 'undoing' stamp: 'jsp 2/16/1999 12:45'!
undoIt
	"Undo by running the wrapped animation."

	wrappedAnimation start.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoAnimation class
	instanceVariableNames: ''!

!UndoAnimation class methodsFor: 'instance creation' stamp: 'jsp 2/16/1999 12:46'!
new: anAnimation
	"Create a wrapper for undoing an animation"

	| newUndo |

	newUndo _ UndoAnimation new.
	newUndo setAnimation: anAnimation.
	^ newUndo.! !
Object subclass: #UndoByStopping
	instanceVariableNames: 'stoppableItem myUndoStack '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoByStopping commentStamp: '<historical>' prior: 0!
This class undoes some action by stopping it.  If the action is already stopped then the next undo action is popped off the stack and evaluated.
!


!UndoByStopping methodsFor: 'initialization' stamp: 'jsp 3/30/1999 11:40'!
initializeWith: anActionorAnimation in: aStack
	"Initialize this instance"

	stoppableItem _ anActionorAnimation.
	myUndoStack _ aStack.
! !


!UndoByStopping methodsFor: 'undoing' stamp: 'jsp 3/30/1999 11:40'!
undoIt
	"Undo by stopping the stoppable item"

	(stoppableItem isDone) ifTrue: [ myUndoStack popAndUndo ]
						   ifFalse: [ stoppableItem stop ].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoByStopping class
	instanceVariableNames: ''!

!UndoByStopping class methodsFor: 'instance creation' stamp: 'jsp 3/30/1999 11:37'!
new: stopable in: aStack
	"Create a new instance and initialize it"

	^ self new initializeWith: stopable in: aStack.
! !
Object subclass: #UndoChangeList
	instanceVariableNames: 'changeList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoChangeList commentStamp: '<historical>' prior: 0!
This class wraps a list of multiple undo actions, and tells them to undo all at the same time.
!


!UndoChangeList methodsFor: 'initialization' stamp: 'jsp 4/5/1999 15:18'!
initialize
	"Initialize this method by creating an empty change list."

	changeList _ OrderedCollection new.
! !

!UndoChangeList methodsFor: 'initialization' stamp: 'jsp 4/5/1999 15:20'!
setChangeList: aCollection

	changeList _ aCollection.
! !


!UndoChangeList methodsFor: 'adding changes' stamp: 'jsp 4/5/1999 15:19'!
add: someUndo
	"Add an undoable to the change list"

	changeList addLast: someUndo.
! !


!UndoChangeList methodsFor: 'undoing' stamp: 'jsp 4/5/1999 15:20'!
undoIt
	"Undo by undoing all the changes in the change list"

	changeList do: [:undoable | undoable undoIt ].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoChangeList class
	instanceVariableNames: ''!

!UndoChangeList class methodsFor: 'instance creation' stamp: 'jsp 4/5/1999 15:18'!
new

	^ super new initialize.
! !
Object subclass: #UndoColorChange
	instanceVariableNames: 'theActor originalColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoColorChange commentStamp: '<historical>' prior: 0!
This class does a color change to an object.
!


!UndoColorChange methodsFor: 'accessing' stamp: 'ar 11/7/1999 21:27'!
getActor
	^theActor! !

!UndoColorChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 16:31'!
setActor: anActor andOriginalColor: aColor
	"Set the original color to undo back to"

	theActor _ anActor.
	originalColor _ aColor.! !


!UndoColorChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 16:31'!
undoIt
	"Set the object's color back to its original value"

	| anim |

	anim _ theActor setColor: originalColor duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoColorChange class
	instanceVariableNames: ''!

!UndoColorChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 16:00'!
for: anActor from: aColor
	"Create a new UndoColorChange instance using aColor as the original color"

	^ self new setActor: anActor andOriginalColor: aColor.
! !
Object subclass: #UndoPOVChange
	instanceVariableNames: 'theActor originalPOV '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoPOVChange commentStamp: '<historical>' prior: 0!
This class undoes a point of view change to an object.
!


!UndoPOVChange methodsFor: 'accessing' stamp: 'ar 11/7/1999 20:15'!
getActor
	^theActor! !

!UndoPOVChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 14:24'!
setActor: anActor andOriginalPOV: pov
	"Set the original POV to undo back to"

	theActor _ anActor.
	originalPOV _ pov.! !


!UndoPOVChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 14:25'!
undoIt
	"Set the object's POV back to its original value"

	| anim |

	anim _ theActor setPointOfView: originalPOV duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoPOVChange class
	instanceVariableNames: ''!

!UndoPOVChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 16:00'!
for: anActor from: pov
	"Create a new UndoPOVChange instance using pov as the original point of view"

	^ self new setActor: anActor andOriginalPOV: pov.
! !
Object subclass: #UndoParentChange
	instanceVariableNames: 'oldParent theActor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoParentChange commentStamp: '<historical>' prior: 0!
This class implements undo for reparenting operations.
!


!UndoParentChange methodsFor: 'initialization' stamp: 'jsp 4/5/1999 15:55'!
initializeWith: aParent for: anActor
	"Initialize the instance variables."

	oldParent _ aParent.
	theActor _ anActor.
! !


!UndoParentChange methodsFor: 'undoing' stamp: 'jsp 4/5/1999 15:56'!
undoIt
	"Undo the parent change"

	theActor reparentTo: oldParent.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoParentChange class
	instanceVariableNames: ''!

!UndoParentChange class methodsFor: 'instance creation' stamp: 'jsp 4/5/1999 15:56'!
newFor: anActor from: theParent
	"Create and initialize a new instance"

	^ super new initializeWith: theParent for: anActor.! !
Object subclass: #UndoPositionChange
	instanceVariableNames: 'theActor originalPosition '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoPositionChange commentStamp: '<historical>' prior: 0!
This class undoes actor motion.
!


!UndoPositionChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 11:19'!
setActor: anActor andOriginalPosition: position
	"Set the original position to undo back to"

	theActor _ anActor.
	originalPosition _ position.
! !


!UndoPositionChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 11:21'!
undoIt
	"Move the object back to its original position"

	| anim |

	anim _ theActor moveTo: originalPosition duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoPositionChange class
	instanceVariableNames: ''!

!UndoPositionChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 16:00'!
for: anActor from: position
	"Create a new UndoPositionChange instance using position as the original position"

	^ self new setActor: anActor andOriginalPosition: position.
! !
Object subclass: #UndoRotationChange
	instanceVariableNames: 'theActor originalRotation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoRotationChange commentStamp: '<historical>' prior: 0!
This class undoes actor rotation.
!


!UndoRotationChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 11:23'!
setActor: anActor andOriginalRotation: rotation
	"Set the original rotation to undo back to"

	theActor _ anActor.
	originalRotation _ rotation.
! !


!UndoRotationChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 11:24'!
undoIt
	"Move the object back to its original position"

	| anim |

	anim _ theActor turnTo: originalRotation duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoRotationChange class
	instanceVariableNames: ''!

!UndoRotationChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 15:59'!
for: anActor from: rotation
	"Create a new UndoRotationChange instance using rotation as the original rotation"

	^ self new setActor: anActor andOriginalRotation: rotation.
! !
Object subclass: #UndoShowHide
	instanceVariableNames: 'theActor undoingHide '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoShowHide commentStamp: '<historical>' prior: 0!
This class shows a hidden object and hides a shown actor.
!


!UndoShowHide methodsFor: 'accessing' stamp: 'jsp 3/19/1999 13:58'!
setActorForHide: anActor
	"Set this undo event to undo a hide (show the actor)."

	theActor _ anActor.
	undoingHide _ true.
! !

!UndoShowHide methodsFor: 'accessing' stamp: 'jsp 3/19/1999 13:58'!
setActorForShow: anActor
	"Set this undo event to undo a show (hide the actor)."

	theActor _ anActor.
	undoingHide _ false.
! !


!UndoShowHide methodsFor: 'undoing' stamp: 'jsp 3/19/1999 13:56'!
undoIt
	"Undo the show or hide event"

	(undoingHide) 	ifTrue: [ theActor setHidden: false ]
					ifFalse: [ theActor setHidden: true ].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoShowHide class
	instanceVariableNames: ''!

!UndoShowHide class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 15:59'!
undoHideFor: anActor
	"Create an undo event that will show the actor"

	^ (self new) setActorForHide: anActor.
! !

!UndoShowHide class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 15:59'!
undoShowFor: anActor
	"Create an undo event that will show the actor"

	^ (self new) setActorForShow: anActor.
! !
Object subclass: #UndoSizeChange
	instanceVariableNames: 'theActor originalSize '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoSizeChange commentStamp: '<historical>' prior: 0!
This class undoes the resizing of an actor.
!


!UndoSizeChange methodsFor: 'accessing' stamp: 'ar 11/7/1999 20:16'!
getActor
	^theActor! !

!UndoSizeChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 16:48'!
setActor: anActor andOriginalSize: size
	"Set the original rotation to undo back to"

	theActor _ anActor.
	originalSize _ size.
! !


!UndoSizeChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 16:49'!
undoIt
	"Move the object back to its original position"

	| anim |

	anim _ theActor setSize: originalSize duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoSizeChange class
	instanceVariableNames: ''!

!UndoSizeChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 15:59'!
for: anActor from: size
	"Create a new UndoSizeChange instance using size as the original size"

	^ self new setActor: anActor andOriginalSize: size.
! !
Object subclass: #UndoTextureChange
	instanceVariableNames: 'theActor originalTexture '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoTextureChange commentStamp: '<historical>' prior: 0!
This class undoes an actor texture change.
!


!UndoTextureChange methodsFor: 'accessing' stamp: 'jsp 3/19/1999 15:57'!
setActor: anActor andTexture: aTexture
	"Store the old texture and the actor to restore it to"

	theActor _ anActor.
	originalTexture _ aTexture.
! !


!UndoTextureChange methodsFor: 'undoing' stamp: 'jsp 3/19/1999 16:14'!
undoIt
	"Restore the object's old texture"

	theActor setTexturePointer: originalTexture.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoTextureChange class
	instanceVariableNames: ''!

!UndoTextureChange class methodsFor: 'instance creation' stamp: 'jsp 3/19/1999 15:59'!
for: anActor from: oldTexture
	"Wrap an actor and its old texture so that we can undo the texture change"

	^ (self new) setActor: anActor andTexture: oldTexture.
! !
Object subclass: #UndoVisibilityChange
	instanceVariableNames: 'theActor originalVisibility '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Undo'!
!UndoVisibilityChange commentStamp: '<historical>' prior: 0!
This class undoes a change in an actor's visibility.
!


!UndoVisibilityChange methodsFor: 'accessing' stamp: 'jsp 3/8/1999 16:36'!
setActor: anActor andOriginalVisibility: aVisibility
	"Set the original visibility to undo back to"

	theActor _ anActor.
	originalVisibility _ aVisibility.! !


!UndoVisibilityChange methodsFor: 'undoing' stamp: 'jsp 3/8/1999 16:37'!
undoIt
	"Set the object's visibility back to its original value"

	| anim |

	anim _ theActor setVisibility: originalVisibility duration: 0.5.
	anim setUndoable: false.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UndoVisibilityChange class
	instanceVariableNames: ''!

!UndoVisibilityChange class methodsFor: 'instance creation' stamp: 'jsp 3/8/1999 16:38'!
for: anActor from: aVisibility
	"Create a new UndoVisibilityChange instance using aVisibility as the original visibility"

	^ super new setActor: anActor andOriginalVisibility: aVisibility.
! !
MethodInterface subclass: #UniclassScript
	instanceVariableNames: 'playerClass currentScriptEditor formerScriptingTiles isTextuallyCoded '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!UniclassScript commentStamp: '<historical>' prior: 0!
Represents a script of uniclass.  Holds the ScriptEditorMorph structures for the current version of a user-defined tile script, as well as previous versions thereof.

playerClass				The actual uniclass with which this script is associated.	
selector					The script''s selector
defaultStatus			The status to apply to new instances of the class by default
defaultFiresPerTick		How many fires per tick, by default, should be allowed if ticking.
currentScriptEditor		The current version of the ScriptEditorMorph for the script
formerScriptingTiles		A collection of pairs, (<timeStamp>  (list of morphs))  each pair characterizing a prior tile version!


!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/30/2001 11:37'!
convertFromUserScript: aUserScript
	"The argument represents an old UserScript object.  convert it over"

	defaultStatus _ aUserScript status.
	isTextuallyCoded _ aUserScript isTextuallyCoded.
	currentScriptEditor _ aUserScript currentScriptEditor.
	formerScriptingTiles _  aUserScript formerScriptEditors ifNotNil:
		[aUserScript formerScriptEditors collect:
			[:aScriptEditor |
				Array with: aScriptEditor timeStamp with: aScriptEditor submorphs allButFirst]]! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:44'!
initialize
	"Initialize the receiver by setting its inst vars to default values"

	super initialize.
	isTextuallyCoded _ false

! !

!UniclassScript methodsFor: 'initialization' stamp: 'sw 1/23/2001 18:28'!
playerClass: aPlayerClass selector: aSelector
	"Set the playerClass and selector of the receiver"

	playerClass _ aPlayerClass.
	selector _ aSelector! !


!UniclassScript methodsFor: 'script editor' stamp: 'sw 1/30/2001 20:08'!
bringUpToDate
	"Bring all versions of the receiver's tile-script source up to date"

	currentScriptEditor ifNotNil: [currentScriptEditor bringUpToDate].
	formerScriptingTiles isEmptyOrNil ifFalse:
		[formerScriptingTiles do:
			[:aPair | aPair second do:
				[:aMorph | (aMorph allMorphs select: [:s | s isTileScriptingElement]) do:
					[:el | el bringUpToDate]]]]! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 1/23/2001 17:12'!
currentScriptEditor: anEditor
	"Set the receiver's currentScriptEditor as indicated"

	currentScriptEditor _ anEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'di 1/31/2001 10:56'!
instantiatedScriptEditor
	"Return the current script editor, creating it if necessary"

	| aPlayer |
	(currentScriptEditor == nil or: [currentScriptEditor == #textuallyCoded]) ifTrue:
		[aPlayer _ playerClass someInstance.
		currentScriptEditor _ ScriptEditorMorph new
				setMorph: aPlayer costume
				scriptName: selector.
		self isTextuallyCoded ifTrue:
			[currentScriptEditor showSourceInScriptor].
		defaultStatus == #ticking ifTrue:
			[aPlayer costume arrangeToStartStepping]].
	
	^ currentScriptEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 1/29/2001 22:02'!
instantiatedScriptEditorForPlayer: aPlayer
	"Return the current script editor, creating it if necessary"

	currentScriptEditor ifNil:
		[currentScriptEditor _ (playerClass includesSelector: selector) 
			ifTrue: [ScriptEditorMorph new 
				fromExistingMethod: selector 
				forPlayer: aPlayer]
			ifFalse: [ScriptEditorMorph new
				setMorph: aPlayer costume
				scriptName: selector].
		defaultStatus == #ticking ifTrue:
			[aPlayer costume arrangeToStartStepping]].
	
	^ currentScriptEditor! !

!UniclassScript methodsFor: 'script editor' stamp: 'sw 1/30/2001 13:05'!
releaseCachedState
	"release all non-showing scriptors.  What do we do about versions????"

	self isTextuallyCoded ifTrue:
		[formerScriptingTiles _ OrderedCollection new].
	currentScriptEditor ifNil: [^ self].
	true ifTrue: [^ self].	"<<< to test the reconstruction of scripts, change to false"
	currentScriptEditor world ifNil: ["not showing"
		currentScriptEditor _ nil]! !


!UniclassScript methodsFor: 'textually coded' stamp: 'sw 1/30/2001 14:47'!
becomeTextuallyCoded
	"Transform the receiver into one which is textually coded"

	isTextuallyCoded _ true! !

!UniclassScript methodsFor: 'textually coded' stamp: 'sw 1/23/2001 17:14'!
isTextuallyCoded
	"Answer whether the receiver is textually coded"

	^ isTextuallyCoded! !


!UniclassScript methodsFor: 'versions' stamp: 'sw 1/30/2001 13:39'!
revertScriptVersionFrom: anEditor
	"Let user choose which prior tile version to revert to, and revert to it"

	| aMenu chosenStampAndTileList |
	formerScriptingTiles isEmptyOrNil ifTrue: [^ self beep].
	formerScriptingTiles size == 1
		ifTrue:
			[chosenStampAndTileList _ formerScriptingTiles first]
		ifFalse:
			[aMenu _ SelectionMenu labelList: (formerScriptingTiles collect: [:e | e first])
				selections: formerScriptingTiles.
			chosenStampAndTileList _ aMenu startUp].
	chosenStampAndTileList ifNotNil:
		[anEditor reinsertSavedTiles: chosenStampAndTileList second.
		isTextuallyCoded _ false]! !

!UniclassScript methodsFor: 'versions' stamp: 'sw 1/30/2001 13:38'!
revertToLastSavedTileVersionFor: anEditor
	"revert to the last saved tile version"

	formerScriptingTiles isEmptyOrNil ifFalse:
		[anEditor reinsertSavedTiles: formerScriptingTiles last second].
	isTextuallyCoded _ false! !

!UniclassScript methodsFor: 'versions' stamp: 'sw 1/30/2001 13:03'!
saveScriptVersion: timeStamp
	"Save the tile script version by appending a pair of the form

		<time stamp>     <morph list>

to my list of former scripting tiles.  The morph-list will get copied back into the Scriptor following restoration."

	((currentScriptEditor notNil and: [currentScriptEditor showingMethodPane not]) and:
		[currentScriptEditor submorphs size > 1]) ifTrue:
			[formerScriptingTiles ifNil: [formerScriptingTiles _ OrderedCollection new].
			formerScriptingTiles add:
				(Array with: timeStamp
					with: (currentScriptEditor submorphs allButFirst collect: [:m | m fullCopyWithoutFormerOwner])).
			formerScriptingTiles size > 100 ifTrue: [^ self halt: 'apparent runaway versions']]! !

!UniclassScript methodsFor: 'versions' stamp: 'sw 1/30/2001 11:31'!
savedTileVersionsCount
	"Answer the number of saved tile versions of the script"

	^ formerScriptingTiles ifNil: [0] ifNotNil: [formerScriptingTiles size]! !
FileDirectory subclass: #UnixFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
!UnixFileDirectory commentStamp: '<historical>' prior: 0!
I represent a Unix FileDirectory.
!


!UnixFileDirectory methodsFor: 'file names' stamp: 'bf 3/22/2000 18:24'!
fullPathFor: path
	"Return the fully-qualified path name for the given file."
	path isEmpty ifTrue: [^ pathName].
	path first = $/ ifTrue: [^ path].
	^ pathName = '/'			"Only root dir ends with a slash"
		ifTrue: ['/' , path]
		ifFalse: [pathName , '/' , path]! !


!UnixFileDirectory methodsFor: 'private' stamp: 'jm 12/4/97 23:43'!
setPathName: pathString
	"Unix path names start with a leading delimiter character."

	(pathString isEmpty or: [pathString first ~= self pathNameDelimiter])
		ifTrue: [pathName _ self pathNameDelimiter asString, pathString]
		ifFalse: [pathName _ pathString].
! !


!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 12:58'!
directoryExists: filenameOrPath
	"Handles the special case of testing for the root dir: there isn't a
	possibility to express the root dir as full pathname like '/foo'."

	^ filenameOrPath = '/' or: [super directoryExists: filenameOrPath]! !

!UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 13:03'!
fileOrDirectoryExists: filenameOrPath 
	"Handles the special case of testing for the root dir: there isn't a 
	possibility to express the root dir as full pathname like '/foo'."

	^ filenameOrPath = '/' or: [super fileOrDirectoryExists: filenameOrPath]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnixFileDirectory class
	instanceVariableNames: ''!

!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'yo 2/4/1999 06:40'!
maxFileNameLength

	^ 255! !

!UnixFileDirectory class methodsFor: 'platform specific' stamp: 'jm 9/17/97 15:48'!
pathNameDelimiter

	^ $/
! !
FMSound subclass: #UnloadedSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!UnloadedSound commentStamp: '<historical>' prior: 0!
Instances of me, which are really just FMSounds, are used placeholders for sounds that have been unloaded from this image but which may be re-loaded later.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnloadedSound class
	instanceVariableNames: ''!

!UnloadedSound class methodsFor: 'as yet unclassified' stamp: 'jm 1/14/1999 12:00'!
default
	"UnloadedSound default play"

	| snd p |
	snd _ super new modulation: 1 ratio: 1.
	p _ OrderedCollection new.
	p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0.
	snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
	^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
! !
UnscriptedPlayer subclass: #UnscriptedCardPlayer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!UnscriptedCardPlayer methodsFor: 'root class' stamp: 'sw 1/30/2001 22:42'!
rootClassForUniclasses
	"Answer the class that should be subclassed when the receiver is made into a uniclass"

	^ CardPlayer! !
Player subclass: #UnscriptedPlayer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!UnscriptedPlayer commentStamp: '<historical>' prior: 0!
My instances are Player objects that have not been scripted, and which hence do not require a unique scripts dictionary, etc.  As soon as the needed, I am transformed automatically into a unique subclass of Player.!


!UnscriptedPlayer methodsFor: 'uniclass' stamp: 'sw 1/30/2001 22:43'!
assureUniClass
	"Create a uniclass and become the receiver into it"

	| anInstance |
	anInstance _ self rootClassForUniclasses instanceOfUniqueClass.
	anInstance initializeCostumesFrom: self.
	self become: anInstance.
	^ anInstance! !

!UnscriptedPlayer methodsFor: 'uniclass' stamp: 'sw 1/30/2001 22:42'!
rootClassForUniclasses
	"Answer the class that should be subclassed when the receiver is made into a uniclass"

	^ Player! !


!UnscriptedPlayer methodsFor: 'queries' stamp: 'sw 8/10/1998 16:23'!
belongsToUniClass
	^ false! !

!UnscriptedPlayer methodsFor: 'queries' stamp: 'sw 12/28/1998 10:27'!
hasUserDefinedScripts
	^ false! !

!UnscriptedPlayer methodsFor: 'queries' stamp: 'sw 12/28/1998 10:27'!
hasUserDefinedSlots
	^ false! !

!UnscriptedPlayer methodsFor: 'queries' stamp: 'sw 10/19/1999 08:30'!
wantsSteps
	"Has no scripts"
	^ false! !


!UnscriptedPlayer methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1998 13:13'!
copyUniClass
	self error: 'oops, copyUniClass sent to an UnscriptedPlayer'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UnscriptedPlayer class
	instanceVariableNames: 'ephemeralPlayerRef '!

!UnscriptedPlayer class methodsFor: 'reference' stamp: 'sw 9/30/1998 09:14'!
ephemeralPlayerRef
	"UnscriptedPlayer ephemeralPlayerRef"
	^ ephemeralPlayerRef! !

!UnscriptedPlayer class methodsFor: 'reference' stamp: 'sw 9/30/1998 09:05'!
referenceSelectorFor: anObject
	"The use of this is for immediate evaluation of lines of script in a Viewer.  The class inst var 'ephemeralPlayerRef' is constantly reused for this purpose."

	ephemeralPlayerRef _ anObject.
	^ 'ephemeralPlayerRef'! !


!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 16:23'!
acceptsLoggingOfCompilation
	^ true! !

!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 8/17/1998 07:33'!
isSystemDefined
	^ true! !

!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 10/23/1999 22:51'!
isUniClass
	^ false! !

!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1998 13:33'!
newUserInstance
	"Answer an instance of an appropriate class to serve as a user object in the containment hierarchy"

	^ self new! !

!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 8/17/1998 07:34'!
officialClass
	^ self! !

!UnscriptedPlayer class methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1998 13:49'!
wantsChangeSetLogging
	^ true! !
Behavior subclass: #Unsigned
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'VMConstruction-TestPlugins'!
!Unsigned commentStamp: '<historical>' prior: 0!
Coercion specification for 32-bit unsigned numbers.

Note: "x asOop: Unsigned" can cause garbage collection when x is outside SmallInteger range.!


!Unsigned methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 09:49'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg ccgLoad: aBlock expr: aString asUnsignedValueFrom: anInteger! !

!Unsigned methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 09:50'!
ccgDeclareCForVar: aSymbolOrString

	^'unsigned ', aSymbolOrString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Unsigned class
	instanceVariableNames: ''!

!Unsigned class methodsFor: 'as yet unclassified' stamp: 'acg 10/5/1999 06:04'!
ccg: cg generateCoerceToOopFrom: aNode on: aStream

	cg generateCoerceToUnsignedObjectFrom: aNode on: aStream! !

!Unsigned class methodsFor: 'as yet unclassified' stamp: 'acg 10/5/1999 06:11'!
ccg: cg generateCoerceToValueFrom: aNode on: aStream

	cg generateCoerceToUnsignedValueFrom: aNode on: aStream! !

!Unsigned class methodsFor: 'as yet unclassified' stamp: 'acg 9/20/1999 11:30'!
ccgCanConvertFrom: anObject

	anObject isInteger ifFalse: 
		[self error: 'Not an Integer object'. ^false].
	anObject >= 0 ifFalse: 
		[self error: 'Object is negative integer'. ^false].
	anObject < (2 raisedToInteger: 32) ifFalse: 
		[self error: 'Object is too large'. ^false].
	^true! !
UpdatingStringMorph subclass: #UpdatingBooleanStringMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!UpdatingBooleanStringMorph commentStamp: '<historical>' prior: 0!
A customized updating-string-morph used for displaying and editing boolean values; mouse-down on one of these is inerpreted as a request to toggle.!


!UpdatingBooleanStringMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/1/1998 16:59'!
handlesMouseDown: evt
	^ true! !

!UpdatingBooleanStringMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/1/1998 16:49'!
informTarget
	| newValue |
	((target ~~ nil) and: [putSelector ~~ nil]) ifTrue:
		[newValue _ self valueFromContents.
		newValue ifNotNil:
			[target scriptPerformer perform: putSelector with: getSelector with: newValue.
			target isMorph ifTrue: [target changed]].
			self growable ifTrue:
				[self readFromTarget; fitContents.
				owner updateLiteralLabel]]! !

!UpdatingBooleanStringMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/16/1999 13:30'!
mouseDown: evt
	self color: Color red! !

!UpdatingBooleanStringMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/25/1999 10:27'!
mouseUp: evt
	(bounds containsPoint: evt cursorPoint)
		ifTrue:
			[self contentsClipped: (target perform: getSelector) not asString.
			self informTarget]
		ifFalse:
			[self beep].
	self color: Color black! !
MenuItemMorph subclass: #UpdatingMenuItemMorph
	instanceVariableNames: 'wordingProvider wordingSelector enablementSelector wordingArgument '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Menus'!
!UpdatingMenuItemMorph commentStamp: '<historical>' prior: 0!
A menu item whose textual label and whose enablement are updatable.  The wordingProvider provides the current wording, upon being being sent the wordingSelector.

The item can also dynamically update whether or not it should be enabled; to do this, give it an enablementSelector, which is also sent to the wordingProvider..!


!UpdatingMenuItemMorph methodsFor: 'world' stamp: 'sma 3/24/2000 11:51'!
adaptToWorld: aWorld
	super adaptToWorld: aWorld.
	wordingProvider isMorph
		ifTrue:
			[wordingProvider isWorldMorph ifTrue: [	wordingProvider _ aWorld].
			wordingProvider isHandMorph ifTrue: [wordingProvider _ aWorld primaryHand]]
		ifFalse: [(wordingProvider isKindOf: Presenter) ifTrue: [wordingProvider _ aWorld presenter]]! !


!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'di 9/9/2000 10:49'!
enablement

	(enablementSelector isKindOf: BlockContext)
		ifTrue: [^ enablementSelector value]
		ifFalse: [^ wordingProvider perform: enablementSelector]! !

!UpdatingMenuItemMorph methodsFor: 'enablement' stamp: 'di 9/9/2000 10:44'!
enablementSelector: aSelector

	(aSelector isKindOf: BlockContext)
		ifTrue: [enablementSelector _ aSelector copyForSaving]
		ifFalse: [enablementSelector _ aSelector]! !


!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: 'ar 10/7/2000 15:35'!
arrangeToStartSteppingIn: aWorld
	super arrangeToStartSteppingIn: aWorld.
	self updateContents.! !

!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: 'ar 10/7/2000 15:34'!
step
	super step.
	self updateContents.! !

!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: 'sw 6/11/1999 18:31'!
stepTime
	^ 1200! !

!UpdatingMenuItemMorph methodsFor: 'stepping' stamp: 'ar 10/29/2000 02:41'!
updateContents
	| newString enablement nArgs |
	wordingProvider ifNil:[^self].
	wordingSelector ifNotNil:[
		newString _ contents.
		nArgs _ wordingSelector numArgs.
		nArgs == 0 ifTrue:[newString _ wordingProvider perform: wordingSelector].
		nArgs == arguments size ifTrue:[
			newString _ wordingProvider perform: wordingSelector withArguments: arguments].
		newString = contents ifFalse: [self contents: newString]].
	enablementSelector ifNotNil:[
		(enablement _ self enablement) == isEnabled 
			ifFalse:[self isEnabled: enablement]]! !


!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 11/6/2000 09:55'!
wordingArgument: anArgument
	"Set the receiver's wordingArgument as indicated"

	wordingArgument _ anArgument! !

!UpdatingMenuItemMorph methodsFor: 'wording' stamp: 'sw 6/11/1999 15:12'!
wordingProvider: aProvider wordingSelector: aSelector
	wordingProvider _ aProvider.
	wordingSelector _ aSelector! !

RectangleMorph subclass: #UpdatingRectangleMorph
	instanceVariableNames: 'target lastValue getSelector putSelector contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Support'!
!UpdatingRectangleMorph commentStamp: '<historical>' prior: 0!
Intended for use as a color swatch coupled to a color obtained from the target, but made just slightly more general than that.!


!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'!
contents
	^ contents! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 9/4/97 21:43'!
contents: c
	contents _ c! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
getSelector: aSymbol

	getSelector _ aSymbol.
! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'!
putSelector
	^ putSelector! !

!UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'sw 10/30/97 00:55'!
putSelector: aSymbol
	putSelector _ aSymbol! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
target

	^ target
! !

!UpdatingRectangleMorph methodsFor: 'accessing'!
target: anObject

	target _ anObject.
! !


!UpdatingRectangleMorph methodsFor: 'stepping' stamp: 'sw 7/15/1999 07:27'!
step
	| s |
	super step.
	s _ self readFromTarget.
	s = contents ifFalse:
		[self contents: s.
		self color: s]
! !

!UpdatingRectangleMorph methodsFor: 'stepping'!
stepTime

	^ 50! !


!UpdatingRectangleMorph methodsFor: 'target access' stamp: 'jm 4/25/1998 05:03'!
readFromTarget

	| v |
	((target == nil) or: [getSelector == nil]) ifTrue: [^ contents].
	target isInWorld ifFalse: [^ contents].
	v _ target scriptPerformer perform: getSelector.
	lastValue _ v.
	^ v ! !


!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'sw 10/30/97 01:05'!
handlesMouseDown: evt
	^ putSelector ~~ nil! !

!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'ar 10/5/2000 18:54'!
mouseUp: evt

	self changeColorTarget: self selector: #setTargetColor: originalColor: color hand: evt hand.! !

!UpdatingRectangleMorph methodsFor: 'setting' stamp: 'sw 2/15/98 13:52'!
setTargetColor: aColor

	putSelector ifNotNil:
		[self color: aColor.
		contents _ aColor.
		target scriptPerformer perform: self putSelector withArguments: (Array with: aColor)]
! !


!UpdatingRectangleMorph methodsFor: 'display' stamp: 'sw 10/24/1998 21:23'!
drawOn: aCanvas 
	"Copied down from BorderedMorph, with the substitution that the color inst var of the receiver here might well be something like #raised or some other symbol, which the frameAndFillRectangle... methods barf on."

	| insetColor colorToFill |
	colorToFill _ (color isKindOf: Color) ifTrue: [color] ifFalse: [Color gray].
	borderWidth = 0 ifTrue: [  "no border"
		aCanvas fillRectangle: bounds color: color.
		^ self].

	borderColor == #raised ifTrue:
		[^ aCanvas frameAndFillRectangle: bounds
			fillColor: colorToFill
			borderWidth: borderWidth
			topLeftColor: colorToFill lighter
			bottomRightColor: colorToFill darker].

	borderColor == #inset ifTrue:
		[insetColor _ owner colorForInsets.
		^ aCanvas frameAndFillRectangle: bounds
			fillColor: colorToFill
			borderWidth: borderWidth
			topLeftColor: insetColor darker
			bottomRightColor: insetColor lighter].

	"solid color border"
	aCanvas frameAndFillRectangle: bounds
		fillColor: colorToFill
		borderWidth: borderWidth
		borderColor: borderColor.! !


!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].! !

!UpdatingRectangleMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 17:17'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"target _ target.		Weakly copied"
lastValue _ lastValue veryDeepCopyWith: deepCopier.
"getSelector _ getSelector.		a Symbol"
"putSelector _ putSelector.		a Symbol"
contents _ contents veryDeepCopyWith: deepCopier.! !


!UpdatingRectangleMorph methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1999 15:31'!
initialize
	super initialize.
	borderColor _ Color lightGray lighter ! !
SimpleButtonMorph subclass: #UpdatingSimpleButtonMorph
	instanceVariableNames: 'wordingProvider wordingSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!UpdatingSimpleButtonMorph commentStamp: '<historical>' prior: 0!
Adds to SimpleButtonMorph the ability to keep its own wording up to date by send a given message (indicated by its wordingSelector) to a given object (indicated by its wordingTarget, and normally the same as its target.)!


!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 08:56'!
step
	"If appropriate update the receiver's label"

	| newString |
	super step.
	wordingProvider ifNotNil:
		[newString _ wordingProvider perform: wordingSelector.
		newString = self label ifFalse: [self labelString: newString; changed]]! !

!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 08:57'!
stepTime
	"Answer the desired time between steps in milliseconds.  If the receiver has a wordingProvider that may dynamically provide changed wording for the label, step once every 1.5 seconds"

	^ wordingProvider ifNotNil: [1500] ifNil: [super stepTime]! !

!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 08:55'!
wantsSteps
	"Answer whether the receiver wishes to be sent the #step message.  In the current case, this decision depends on whether there is a wordingProvider which can dynamically provide fresh wording for the button's label"

	^ wordingProvider notNil! !

!UpdatingSimpleButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/11/1999 18:30'!
wordingSelector: aSelector
	wordingSelector _ aSelector.
	wordingProvider ifNil: [wordingProvider _ target]! !
StringMorph subclass: #UpdatingStringMorph
	instanceVariableNames: 'format target lastValue getSelector putSelector floatPrecision growable stepTime autoAcceptOnFocusLoss minimumWidth maximumWidth '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!
!UpdatingStringMorph commentStamp: '<historical>' prior: 0!
floatPrecision = 1. to round to integer.
floatPrecision = .1 to round to 1 decimal place, etc.
!


!UpdatingStringMorph methodsFor: 'initialization' stamp: 'sw 9/10/1999 09:59'!
initialize

	super initialize.
	format _ #default.  "formats: #string, #default"
	target _ getSelector _ putSelector _  nil.
	floatPrecision _ 1.
	growable _ true.
	stepTime _ 50.
	autoAcceptOnFocusLoss _ true.
	minimumWidth _ 8.
	maximumWidth _ 300.
! !


!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/9/1999 16:47'!
autoAcceptOnFocusLoss
	^ autoAcceptOnFocusLoss ~~ false! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 10:45'!
autoAcceptOnFocusLoss: aBoolean
	autoAcceptOnFocusLoss _ aBoolean! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'tk 8/14/2000 23:12'!
fitContents

	| scanner newExtent |
	scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse.
	newExtent _ (((scanner stringWidth: contents) max: self minimumWidth) min: self maximumWidth)  @ scanner lineHeight.
	(self extent = newExtent) ifFalse:
		[self extent: newExtent.
		self changed]
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'!
floatPrecision

	floatPrecision ifNil: [floatPrecision _ 1].
	^ floatPrecision
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'!
floatPrecision: aNumber

	floatPrecision _ aNumber.
! !

!UpdatingStringMorph methodsFor: 'accessing'!
getSelector

	^ getSelector
! !

!UpdatingStringMorph methodsFor: 'accessing'!
getSelector: aSymbol

	getSelector _ aSymbol.
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:21'!
growable

	^ growable ~~ false
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'!
growable: aBoolean

	growable _ aBoolean.
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 10:07'!
maximumWidth
	"Answer the maximum width that the receiver can have.   A nil value means no maximum, and for practical purposes results in a value of 99999 here temporarily, for help in future debugging"

	^ maximumWidth ifNil: [99999]! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 9/10/1999 09:59'!
minimumWidth
	"Answer the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	^ minimumWidth ifNil: [minimumWidth _ 8]! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'tk 12/1/2000 15:08'!
minimumWidth: aWidth
	"Set the minimum width that the receiver can have.  A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!!  Obeyed by fitContents."

	minimumWidth _ aWidth! !

!UpdatingStringMorph methodsFor: 'accessing'!
putSelector

	^ putSelector
! !

!UpdatingStringMorph methodsFor: 'accessing'!
putSelector: aSymbol

	putSelector _ aSymbol.
! !

!UpdatingStringMorph methodsFor: 'accessing'!
target

	^ target
! !

!UpdatingStringMorph methodsFor: 'accessing' stamp: 'sw 3/11/2000 20:05'!
target: anObject

	target _ anObject.
	getSelector ifNotNil: [floatPrecision _ anObject defaultFloatPrecisionFor: getSelector]
! !


!UpdatingStringMorph methodsFor: 'stepping' stamp: 'sw 7/15/1999 07:28'!
step
	| s |
	super step.
	hasFocus ifFalse:
		["update contents, but only if user isn't editing this string"
		s _ self readFromTarget.
		s = contents ifFalse:
			[self updateContentsFrom: s]]
! !

!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:17'!
stepTime

	^ stepTime ifNil: [50]
! !

!UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:23'!
stepTime: mSecsPerStep

	stepTime _ mSecsPerStep truncated.
! !

!UpdatingStringMorph methodsFor: 'stepping' stamp: 'sw 6/26/1998 07:31'!
updateContentsFrom: aValue
	self growable
		ifTrue:
			[self contents: aValue]
		ifFalse:
			[self contentsClipped: aValue]! !

!UpdatingStringMorph methodsFor: 'stepping' stamp: 'di 12/13/2000 14:21'!
wantsSteps
	"Don't start me stepping if I have nothing to do."

	((target == nil) or: [getSelector == nil]) ifTrue: [^ false].
	^ super wantsSteps
! !


!UpdatingStringMorph methodsFor: 'formats'!
useDefaultFormat
	"Use the object's own printString format."

	format _ #default.
! !

!UpdatingStringMorph methodsFor: 'formats'!
useStringFormat

	format _ #string.! !


!UpdatingStringMorph methodsFor: 'target access' stamp: 'tk 8/14/2000 23:11'!
acceptValue: aValue

	self updateContentsFrom: (self acceptValueFromTarget: aValue).
! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 2/1/1999 14:39'!
acceptValueFromTarget: v
	lastValue _ v.
	format = #string ifTrue: [^ v asString].
	(format = #default and: [v isNumber]) ifTrue:
		[v isInteger ifTrue: [^ v asInteger printString].
		(v isKindOf: Float) ifTrue: [^ (v roundTo: self floatPrecision) printString]].
	^ v printString
! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'tk 8/14/2000 23:13'!
informTarget

	| newValue |
	((target ~~ nil) and: [putSelector ~~ nil]) ifTrue:
		[newValue _ self valueFromContents.
		newValue ifNotNil:
			[target scriptPerformer perform: putSelector with: newValue.
			target isMorph ifTrue: [target changed]].
			self fitContents.
			"self growable ifTrue:
				[self readFromTarget; fitContents.
				owner ifNotNil:  [owner updateLiteralLabel]]"]! !

!UpdatingStringMorph methodsFor: 'target access' stamp: 'sw 10/25/1998 00:56'!
readFromTarget

	| v |
	((target == nil) or: [getSelector == nil]) ifTrue: [^ contents].
	v _ target scriptPerformer perform: getSelector.
	^ self acceptValueFromTarget: v! !

!UpdatingStringMorph methodsFor: 'target access'!
valueFromContents
	"Return a new value from the current contents string."

	format = #string ifTrue: [^ contents].
	^ Compiler evaluate: contents
! !


!UpdatingStringMorph methodsFor: 'editing'!
acceptContents

	self informTarget.
! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 10/6/1998 08:26'!
addCustomMenuItems: menu hand: aHandMorph

	| prefix |
	super addCustomMenuItems: menu hand: aHandMorph.
	prefix _ self growable
		ifTrue:
			['stop']
		ifFalse:
			['start'].
	menu add: prefix, ' being growable' action: #toggleGrowability.
	menu add: 'decimal places...' action: #setPrecision.
	menu add: 'font size...' action: #setFontSize.
	menu add: 'font style...' action: #setFontStyle! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 12/1/2000 15:37'!
doneWithEdits
	"If in a SyntaxMorph, shrink min width after editing"

	super doneWithEdits.
	(owner respondsTo: #parseNode) ifTrue: [minimumWidth _ 8].! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'ar 10/6/2000 00:17'!
handlesMouseDown: evt
	(owner wantsKeyboardFocusFor: self)
		ifTrue:[^true].
	^ super handlesMouseDown: evt! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 11/29/2000 13:54'!
lostFocusWithoutAccepting
	"The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus -- typically by clicking on some editable text somewhere else -- without having accepted the current edits."

	self autoAcceptOnFocusLoss ifTrue: [self doneWithEdits; acceptContents]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'tk 12/1/2000 15:36'!
mouseDown: evt
	(owner wantsKeyboardFocusFor: self) ifTrue:
		[putSelector ifNotNil: [
			minimumWidth _ (49 max: minimumWidth).	"leave space for editing"
			self launchMiniEditor: evt]]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 1/19/2000 11:48'!
setFontSize
	| sizes reply family |
	family _ font ifNil: [TextStyle default] ifNotNil: [font textStyle].
	family ifNil: [family _ TextStyle default].  "safety net -- this line SHOULD be unnecessary now"
	sizes _ 	family fontNamesWithPointSizes.
	reply _ (SelectionMenu labelList: sizes selections: sizes) startUp.
	reply ifNotNil:
		[self font: (family fontAt: (sizes indexOf: reply))]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 12/7/1999 11:45'!
setFontStyle
	| aList reply style |
	aList _ (TextConstants select: [:anItem | anItem isKindOf: TextStyle])
			keys asOrderedCollection.
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ~~ nil ifTrue:
		[(style _ TextStyle named: reply) ifNil: [self beep. ^ true].
		self font: (style defaultFont)]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 10/5/1998 15:31'!
setPrecision
	| aList aMenu reply |
	aList _ #('0' '1' '2' '3' '4' '5').
	aMenu _ SelectionMenu labels: aList selections: aList.
	reply _ aMenu startUpWithCaption: 'How many decimal places?'.
	reply ifNotNil:
		[self floatPrecision:
			(#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001) at: (aList indexOf: reply))]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 6/26/1998 07:47'!
toggleGrowability
	growable _ self growable not.
	self updateContentsFrom: self readFromTarget.
	growable ifTrue: [self fitContents]! !

!UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 5/6/1998 12:59'!
wouldAcceptKeyboardFocus
	^ (self hasProperty: #okToTextEdit) or: [super wouldAcceptKeyboardFocus]! !


!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 1/7/1999 15:37'!
veryDeepFixupWith: deepCopier
	"If target field is weakly copied, fix it here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
target _ deepCopier references at: target ifAbsent: [target].
! !

!UpdatingStringMorph methodsFor: 'copying' stamp: 'tk 12/7/1999 10:48'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared."

	super veryDeepInner: deepCopier.
	format _ format veryDeepCopyWith: deepCopier.
	target _ target.					"Weakly copied"
	lastValue _ lastValue veryDeepCopyWith: deepCopier.
	getSelector _ getSelector.			"Symbol"
	putSelector _ putSelector.		"Symbol"
	floatPrecision _ floatPrecision veryDeepCopyWith: deepCopier.
	growable _ growable veryDeepCopyWith: deepCopier.
	stepTime _ stepTime veryDeepCopyWith: deepCopier.
	autoAcceptOnFocusLoss _ autoAcceptOnFocusLoss veryDeepCopyWith: deepCopier.
	minimumWidth _ minimumWidth veryDeepCopyWith: deepCopier.
	maximumWidth _ maximumWidth veryDeepCopyWith: deepCopier.
! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UpdatingStringMorph class
	instanceVariableNames: ''!

!UpdatingStringMorph class methodsFor: 'instance creation' stamp: 'sw 3/10/2000 17:27'!
on: targetObject selector: aSymbol

	^ self new
		getSelector: aSymbol;
		target: targetObject

! !
UpdatingStringMorph subclass: #UpdatingStringMorphWithArgument
	instanceVariableNames: 'argumentTarget argumentGetSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!UpdatingStringMorphWithArgument methodsFor: 'as yet unclassified' stamp: 'sw 10/25/1998 00:20'!
argumentTarget: t argumentGetSelector: s
	argumentTarget _ t.
	argumentGetSelector _ s! !

!UpdatingStringMorphWithArgument methodsFor: 'as yet unclassified' stamp: 'sw 10/25/1998 00:57'!
readFromTarget
	| v |
	argumentTarget ifNil: [^ super readFromTarget].
	v _ target perform: getSelector with: (argumentTarget perform: argumentGetSelector).
	^ self acceptValueFromTarget: v! !


!UpdatingStringMorphWithArgument methodsFor: 'copying' stamp: 'tk 1/7/1999 15:40'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
argumentTarget _ deepCopier references at: argumentTarget 
			ifAbsent: [argumentTarget].
! !

!UpdatingStringMorphWithArgument methodsFor: 'copying' stamp: 'tk 1/7/1999 15:39'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
"argumentTarget _ argumentTarget.		Weakly copied"
argumentGetSelector _ argumentGetSelector veryDeepCopyWith: deepCopier.! !
ThreePhaseButtonMorph subclass: #UpdatingThreePhaseButtonMorph
	instanceVariableNames: 'getSelector getArgument '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'bf 10/8/1999 15:08'!
doButtonAction
	"Since the action likely changes our state, do a step so we're updated immediately"
	super doButtonAction.
	self step
! !

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/8/1999 13:50'!
getSelector: sel
	getSelector _ sel! !

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'bf 10/14/1999 21:11'!
mouseUp: evt
	"Since mouseUp likely changes our state, do a step so we're updated immediately"
	super mouseUp: evt.
	self step! !

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/14/2000 15:27'!
step
	| newBoolean |
	super step.
	state == #pressed ifTrue: [^ self].
	newBoolean _ target perform: getSelector.
	newBoolean == self isOn
		ifFalse:
			[self state: (newBoolean == true ifTrue: [#on] ifFalse: [#off])]! !

!UpdatingThreePhaseButtonMorph methodsFor: 'as yet unclassified' stamp: 'sw 3/8/1999 13:50'!
wantsSteps
	^ true! !
Object subclass: #Url
	instanceVariableNames: 'fragment '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!
!Url commentStamp: '<historical>' prior: 0!
A Uniform Resource Locator.  It specifies the location of a document on the Internet.  The base class is abstract; child classes break different types of URLs down in ways appropriate for that type.!


!Url methodsFor: 'parsing' stamp: 'ls 8/5/1998 00:57'!
newFromRelativeText: aString
	"return a URL relative to the current one, given by aString.  For instance, if self is 'http://host/dir/file', and aString is '/dir2/file2', then the return will be a Url for 'http://host/dir2/file2'"

	"if the scheme is the same, or not specified, then use the same class"

	| newSchemeName remainder fragmentStart newFragment newUrl bare |

	bare _ aString withBlanksTrimmed.
	newSchemeName _ Url schemeNameForString: bare.
	(newSchemeName isNil not and: [ newSchemeName ~= self schemeName ]) ifTrue: [
		"different scheme -- start from scratch"
		^Url absoluteFromText: aString ].

	remainder _ bare.

	"remove the fragment, if any"
	fragmentStart _ remainder indexOf: $#.
	fragmentStart > 0 ifTrue: [
		newFragment _ remainder copyFrom: fragmentStart+1 to: remainder size. 
		remainder _ remainder copyFrom: 1 to: fragmentStart-1].

	"remove the scheme name"
	newSchemeName ifNotNil: [
		remainder _ remainder copyFrom: (newSchemeName size + 2) to: remainder size ].

	"create and initialize the new url"
	newUrl _ self class new privateInitializeFromText: remainder  relativeTo: self.


	"set the fragment"
	newUrl privateFragment: newFragment.


	^newUrl! !

!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:50'!
privateInitializeFromText: aString
	^self subclassResponsibility! !

!Url methodsFor: 'parsing' stamp: 'ls 8/4/1998 00:55'!
privateInitializeFromText: aString relativeTo: aUrl
	"initialize from the given string, as a relative URL.  aString will have had the scheme name removed, if it was present to begin with.  If it was, then the scheme name was the same as the receiver's scheme name"

	"by default, just do regular initialization"
	^self privateInitializeFromText: aString! !


!Url methodsFor: 'classification' stamp: 'ls 6/16/1998 16:22'!
scheme
	"return a string with the scheme of this URL.  For instance, HTTP"
	^self subclassResponsibility! !

!Url methodsFor: 'classification' stamp: 'ls 7/3/1998 21:11'!
schemeName
	"return a lowercase string with the scheme of this URL.  For instance, 'http'"
	^self subclassResponsibility! !


!Url methodsFor: 'printing' stamp: 'ls 6/20/1998 19:55'!
printOn: aStream
	aStream nextPutAll: self toText! !

!Url methodsFor: 'printing' stamp: 'ls 6/20/1998 19:55'!
toText
	"give a String representation of the Url, suitable for printing, etc."
	^self subclassResponsibility! !


!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:41'!
activate
	"spawn an external handler for this URL"
	! !

!Url methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:40'!
hasContents
	"whether this URL can download contents to be displayed; if not, it fundamentally requires an outside application to deal with it.  For example, mailto: and telnet: urls"
	^false! !

!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'!
retrieveContents
	"return a MIMEObject with the object's contents, or nil if the object could not be retrieved"
	^nil! !

!Url methodsFor: 'downloading' stamp: 'ls 7/23/1998 20:14'!
retrieveContentsForBrowser: aBrowser
	"return a MIMEObject with the object's contents, or nil if the object could not be retrieved.  Since aBrowser is specified, this could do browser specific things"
	^self retrieveContents! !


!Url methodsFor: 'converting' stamp: 'ls 7/14/1998 03:17'!
asText
	^self asString asText! !

!Url methodsFor: 'converting' stamp: 'ls 6/29/1998 00:36'!
asUrl
	^self! !

!Url methodsFor: 'converting' stamp: 'ls 7/3/1998 21:11'!
asUrlRelativeTo: aUrl
	^self! !


!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:41'!
fragment
	^fragment! !

!Url methodsFor: 'fragment' stamp: 'ls 8/4/1998 01:02'!
privateFragment: aString
	fragment _ aString! !

!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:19'!
withFragment: newFragment
	"return a URL which is the same except that it has a different fragment"
	^self copy privateFragment: newFragment; yourself! !

!Url methodsFor: 'fragment' stamp: 'ls 6/1/2000 16:26'!
withoutFragment
	"return a URL which is identical to the receiver except that it has no fragment associated with it"
	^self withFragment: nil! !


!Url methodsFor: 'accessing' stamp: 'mir 2/22/2000 18:05'!
authority
	^''! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Url class
	instanceVariableNames: ''!

!Url class methodsFor: 'parsing' stamp: 'ls 8/4/1998 20:42'!
absoluteFromText: aString
	"Url absoluteFromText: 'http://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part'" 
	"Url absoluteFromText: 'msw://chaos.resnet.gatech.edu:9000/testbook?top'"
	"Url absoluteFromText: 'telnet:chaos.resnet.gatech.edu'"
	"Url absoluteFromText: 'file:/etc/passwd'"

	| remainder scheme fragment ind newUrl |

	"trim surrounding whitespace"
	remainder _ aString withBlanksTrimmed.	

	"extract the fragment, if any"
	ind _ remainder indexOf: $#.
	ind > 0 ifTrue: [
		fragment _ remainder copyFrom: ind+1 to: remainder size.
		remainder _ remainder copyFrom: 1 to: ind-1 ].

	"choose class based on the scheme name, and let that class do the bulk of the parsing"
	scheme _ self schemeNameForString: remainder.

	scheme = nil ifTrue: [
		newUrl _ HttpUrl new privateInitializeFromText: remainder ].

	(scheme = 'http') ifTrue: [ newUrl _ HttpUrl new privateInitializeFromText: remainder ].
	(scheme = 'msw') ifTrue: [ newUrl _ MswUrl new privateInitializeFromText: remainder ]. 
	(scheme = 'ftp') ifTrue:[ newUrl _ FtpUrl new privateInitializeFromText: remainder ].
	(scheme = 'file') ifTrue: [newUrl _ FileUrl new privateInitializeFromText: remainder ].
	
	(scheme = 'browser') ifTrue: [ newUrl _ BrowserUrl new privateInitializeFromText: remainder ].
	(scheme = 'mailto') ifTrue: [ newUrl _ MailtoUrl new privateInitializeFromText: remainder ].

	newUrl ifNil: [  newUrl _ GenericUrl new privateInitializeFromText: remainder ].


	"set the fragment"
	newUrl privateFragment: fragment.


	"all done"
	^newUrl! !

!Url class methodsFor: 'parsing' stamp: 'sma 4/30/2000 11:18'!
schemeNameForString: aString
	"get the scheme name from a string, or return nil if it's not specified.  used in internal parsing routines--an outsider may as well use asUrl.  lowercases the return value."
	"Url schemeNameForString: 'http://www.yahoo.com'"
	"Url schemeNameForString: '/etc/passwed'"
	"Url schemeNameForString: '/etc/testing:1.2.3'"

	| idx schemeName |
	idx _ aString indexOf: $: ifAbsent: [^ nil].
	schemeName _ aString copyFrom: 1 to: idx - 1.
	(schemeName allSatisfy: [:each | each isLetter]) ifFalse: [^ nil].
	^ schemeName asLowercase! !


!Url class methodsFor: 'testing' stamp: 'ls 8/4/1998 02:42'!
quickieTest
	"run some quick tests on the Url hierarchy"
	"
	Url quickieTest
	"
	| tests url block correct actual numCorrect numWrong baseUrl |
	"each item in tests in a two-element array.  it has a block, followed by the string the block should evaluate to"

	tests _ OrderedCollection new.

	"parsing absolute urls of various kinds"

	tests add: (Array with: 
		[url _ 'hTTp://chaos.resnet.gatech.edu:8000/docs/java/index.html?A%20query%20#part' asUrl.
		url schemeName, '|', url authority, '|', url path first, '|', url path size printString, '|', url query, '|',url fragment.]
		with: 'http|chaos.resnet.gatech.edu:8000|docs|3|A%20query%20|part').

	tests add: (Array with:
		[url _ 'ftP://some.server/some/directory/' asUrl.
		url schemeName, '|', url class name, '|', url authority, '|', url path first , '|', url path size printString]
		with: 'ftp|FtpUrl|some.server|some|3').
	tests add: (Array with:
		[url _ 'telNet:chaos.resnet.gatech.edu#goo' asUrl.
		url schemeName, '|', url locator, '|', url fragment] 
		with: 'telnet|chaos.resnet.gatech.edu|goo').


	tests add: (Array with:
		[url _ Url absoluteFromText: 'file:/etc/passwd#foo'.
		url schemeName, '|', url path first, '|', url path size printString, '|', url fragment]
		with: 'file|etc|2|foo').


	tests add: (Array with: 
		[url _ Url absoluteFromText: 'browser:bookmarks#mainPart'.
		url schemeName, '|', url locator, '|', url fragment, '|', url class name ]
		with: 'browser|bookmarks|mainPart|BrowserUrl').


	tests add: (Array with:
		[url _ 'fILE:/foo/bar//zookie/?fakequery/#fragger' asUrl.
		url schemeName, '|', url class name, '|', url path first, '|', url path size printString, '|', url fragment]
		with: 'file|FileUrl|foo|5|fragger').


	"relative urls of each kind, relative to the original"
	tests add: (Array with: [
		baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
		url _ baseUrl newFromRelativeText: 'ftp://a.b'.
		url toText]
		with: 'ftp://a.b/').

	tests add: (Array with: [
		baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
		url _ baseUrl newFromRelativeText: 'ftp:xyz'.
		url toText.]
		with: 'ftp://somewhere/some/dir/xyz').

	tests add: (Array with: [
		baseUrl _ 'http://some.where/some/dir?query1#fragment1' asUrl.
		url _ baseUrl newFromRelativeText: '../another/dir/?query2#fragment2'.
		url toText]
		with: 'http://some.where/another/dir/?query2#fragment2').

	tests add: (Array with: [
		baseUrl _ 'file:/some/dir#fragment1' asUrl.
		url _ baseUrl newFromRelativeText: 'file:../another/dir/#fragment2'.
		url toText]
		with: 'file:/another/dir/#fragment2').

	"relative urls of a different scheme"
	tests add: (Array with: [
		baseUrl _ 'ftp://somewhere/some/dir/?query#fragment' asUrl.
		url _ baseUrl newFromRelativeText: 'http:xyz'.
		url toText.]
		with: 'http://xyz/').



	"run the tests"
	numCorrect _ 0.
	numWrong _ 0.
	tests do: [ :test |
		block _ test at: 1.
		correct _ test at: 2.
		actual _ block value.
		Transcript show: actual.
		correct = actual 
			ifTrue: [ numCorrect _ numCorrect + 1 ]
			ifFalse: [
				numWrong _ numWrong + 1.
				Transcript show: '<-- should be: ', correct ].
		Transcript cr. ].
	Transcript show: numCorrect printString, ' correct, ', numWrong printString, ' wrong.', String cr.
	numWrong > 0 
		ifTrue: [ Transcript show: 'happy hacking!!' ]
		ifFalse: [ Transcript show: 'yay!!!!!!' ].
	Transcript cr.! !
OrderedCollection subclass: #UrlArgumentList
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Network-Url'!

!UrlArgumentList methodsFor: 'enumerating' stamp: 'mir 7/27/1999 16:01'!
associationsDo: aBlock
	self do: [:each | 
		aBlock value: each]! !


!UrlArgumentList methodsFor: 'private' stamp: 'mir 7/27/1999 16:20'!
argumentNamed: argName
	^self
		detect: [:each | each key = argName]
		ifNone: [nil]! !


!UrlArgumentList methodsFor: 'adding' stamp: 'mir 7/27/1999 16:19'!
add: argName value: argValue
	| argAssociation |
	argAssociation _ self argumentNamed: argName.
	argAssociation isNil
		ifTrue: [self add: (argName -> (OrderedCollection with: argValue))]
		ifFalse: [argAssociation value add: argValue]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

UrlArgumentList class
	instanceVariableNames: ''!

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:25'!
with: argAssoc
	| argList |
	argList _ self new.
	argList add: argAssoc key value: argAssoc value.
	^argList! !

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'!
with: firstArgAssoc with: secondArgAssoc
	| argList |
	argList _ self with: firstArgAssoc.
	argList add: secondArgAssoc key value: secondArgAssoc value.
	^argList! !

!UrlArgumentList class methodsFor: 'instance creation' stamp: 'mir 7/27/1999 16:26'!
with: firstArgAssoc with: secondArgAssoc with: thirdArgAssoc
	| argList |
	argList _ self with: firstArgAssoc with: secondArgAssoc.
	argList add: thirdArgAssoc key value: thirdArgAssoc value.
	^argList! !
MorphicEvent subclass: #UserInputEvent
	instanceVariableNames: 'type buttons position handler wasHandled '
	classVariableNames: ''
	poolDictionaries: 'EventSensorConstants '
	category: 'Morphic-Events'!

!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'!
copyHandlerState: anEvent
	"Copy the handler state from anEvent. Used for quickly transferring handler information between transformed events."
	handler _ anEvent handler.
	wasHandled _ anEvent wasHandled.! !

!UserInputEvent methodsFor: 'initialize' stamp: 'ar 9/13/2000 15:54'!
resetHandlerFields
	"Reset anything that is used to cross-communicate between two eventual handlers during event dispatch"
	handler _ nil.
	wasHandled _ false.! !


!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'!
buttons
	"Return the a word encoding the mouse and modifier buttons for this event."

	^ buttons! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
handler
	^handler! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
handler: anObject
	handler _ anObject! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:45'!
position
	^position! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:45'!
type
	"Return a symbol indicating the type this event."

	^ type! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
wasHandled
	^wasHandled! !

!UserInputEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 15:54'!
wasHandled: aBool
	wasHandled _ aBool.! !


!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'!
anyModifierKeyPressed
	"ignore, however, the shift keys 'cause that's not REALLY a command key "

	^ self buttons anyMask: 16r70	"cmd | opt | ctrl"! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:43'!
commandKeyPressed
	"Answer true if the command key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 64! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'!
controlKeyPressed
	"Answer true if the control key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 16! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'!
macOptionKeyPressed
	"Answer whether the option key on the Macintosh keyboard was being held down when this event occurred. Macintosh specific."

	Preferences macOptionKeyAllowed ifFalse: [self notify: 'Portability note:
MorphicEvent>>macOptionKeyPressed is not portable.
Please use MorphicEvent>>yellowButtonPressed instead!!'].
	^ buttons anyMask: 32! !

!UserInputEvent methodsFor: 'modifier state' stamp: 'ar 9/13/2000 15:44'!
shiftPressed
	"Answer true if the shift key on the keyboard was being held down when this event occurred."

	^ buttons anyMask: 8
! !


!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:57'!
buttonString
	"Return a string identifying the currently pressed buttons"
	| string |
	string _ ''.
	self redButtonPressed ifTrue:[string _ string,'red '].
	self yellowButtonPressed ifTrue:[string _ string,'yellow '].
	self blueButtonPressed ifTrue:[string _ string,'blue '].
	^string! !

!UserInputEvent methodsFor: 'printing' stamp: 'ar 10/7/2000 21:56'!
modifierString
	"Return a string identifying the currently pressed modifiers"
	| string |
	string _ ''.
	self commandKeyPressed ifTrue:[string _ string,'CMD '].
	self shiftPressed ifTrue:[string _ string,'SHIFT '].
	self controlKeyPressed ifTrue:[string _ string,'CTRL '].
	^string! !


!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
transformBy: aMorphicTransform
	"Transform the receiver into a local coordinate system."
	position _  aMorphicTransform globalPointToLocal: position.! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
transformedBy: aMorphicTransform
	"Return the receiver transformed by the given transform into a local coordinate system."
	^self shallowCopy transformBy: aMorphicTransform! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:37'!
translateBy: delta
	"add delta to cursorPoint, and return the new event"
	position _ position + delta.! !

!UserInputEvent methodsFor: 'transforming' stamp: 'ar 10/9/2000 00:38'!
translatedBy: delta
	"add delta to cursorPoint, and return the new event"
	^self shallowCopy translateBy: delta! !


!UserInputEvent methodsFor: 'encoding' stamp: 'ar 10/25/2000 23:23'!
encodedAsStringArray
	"encode the receiver into an array of strings, such that it can be retrieved via the fromStringArray: class method"
	^{
		type.
		CanvasEncoder encodePoint: position.
		CanvasEncoder encodeInteger: buttons.
	}! !


!UserInputEvent methodsFor: 'private' stamp: 'ar 10/24/2000 16:33'!
setPosition: aPoint
	position _ aPoint! !
ScriptInstantiation subclass: #UserScript
	instanceVariableNames: 'currentScriptEditor formerScriptEditors '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!
!UserScript commentStamp: '<historical>' prior: 0!
Holds the ScriptEditorMorph structures for the current version of a user-defined tile script, as well as previous versions thereof.
	currentScriptEditor	The current version of the ScriptEditorMorph for the script
	formerScriptEditors 	Earlier versions of the script, for recapturing via the Versions feature
							(a dictionary, <timeStamp> -> ScriptEditorMorph!



!UserScript methodsFor: 'script editor' stamp: 'sw 5/19/1998 12:18'!
allScriptVersionsDo: aBlock
	self isTextuallyCoded ifFalse: [aBlock value: currentScriptEditor].
	formerScriptEditors ifNotNil: [formerScriptEditors do:
		[:ed | aBlock value: ed]]! !

!UserScript methodsFor: 'script editor' stamp: 'sw 5/13/1998 15:38'!
bringUpToDate
	self allScriptVersionsDo: [:v | v bringUpToDate]! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/25/2001 10:32'!
currentScriptEditor
	"Answer the currentScriptEditor value"

	^ currentScriptEditor! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/29/98 22:55'!
currentScriptEditor: anEditor
	currentScriptEditor _ anEditor! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/25/2001 10:32'!
formerScriptEditors
	"Answer the formerScriptEditors value"

	^ formerScriptEditors! !

!UserScript methodsFor: 'script editor' stamp: 'sw 1/23/2001 11:28'!
instantiatedScriptEditor
	"Return the current script editor, creating it if necessary"

	self isTextuallyCoded ifTrue:
			[^ (player costume pasteUpMorph ifNil: [player costume "the world, backstop"]) scriptorForTextualScript: selector ofPlayer: player].

	currentScriptEditor ifNil:
		[currentScriptEditor _ (player class includesSelector: selector) 
			ifTrue: [ScriptEditorMorph new 
				fromExistingMethod: selector 
				forPlayer: player]
			ifFalse: [ScriptEditorMorph new
				setMorph: player costume
				scriptName: selector].
		status == #ticking ifTrue: [player costume arrangeToStartStepping]].
	
	^ currentScriptEditor! !

!UserScript methodsFor: 'script editor' stamp: 'tk 11/30/2000 16:32'!
releaseCachedState
	"release all non-showing scriptors.  What do we do about versions????"

	self isTextuallyCoded ifTrue: [formerScriptEditors _ OrderedCollection new].
		"to test new tiles.  We 'commit' to current script."
	currentScriptEditor ifNil: [^ self].
	true ifTrue: [^ self].	"<<< to test the reconstruction of scripts, change to false"
	currentScriptEditor world ifNil: ["not showing"
		currentScriptEditor _ nil].

! !


!UserScript methodsFor: 'textually coded' stamp: 'sw 5/19/1998 14:13'!
becomeTextuallyCoded
	currentScriptEditor _ #textuallyCoded! !

!UserScript methodsFor: 'textually coded' stamp: 'sw 5/19/1998 09:55'!
isTextuallyCoded
	^ currentScriptEditor == #textuallyCoded! !


!UserScript methodsFor: 'versions' stamp: 'sw 10/10/2000 11:04'!
revertScriptVersionFrom: anEditor
	"Let user choose which prior tile version to revert to, and revert to it"

	| aMenu result |
	formerScriptEditors isEmptyOrNil ifTrue: [^ self beep].
	formerScriptEditors size == 1
		ifTrue:
			[result _ formerScriptEditors first]
		ifFalse:
			[aMenu _ SelectionMenu labelList: (formerScriptEditors collect: [:e | e timeStamp])
				selections: formerScriptEditors.
			result _ aMenu startUp].
	result ifNotNil:
		[self revertScriptVersionFrom: anEditor installing: result]! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/30/2000 08:54'!
revertScriptVersionFrom: anEditor installing: aSavedEditor
	"Replace anEditor with a brought-up-to-date version of aSavedEditor"

	| aPosition oldOwner |
	aPosition _ anEditor position.
	oldOwner _ anEditor topRendererOrSelf owner.
	anEditor delete.
	currentScriptEditor _ aSavedEditor bringUpToDate install.
	player costume viewAfreshIn: oldOwner showingScript: selector at: aPosition! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/10/2000 11:07'!
revertToLastSavedTileVersionFor: anEditor
	"revert to the last saved tile version"

	formerScriptEditors isEmptyOrNil ifFalse:
		[self revertScriptVersionFrom: anEditor installing: formerScriptEditors last]! !

!UserScript methodsFor: 'versions' stamp: 'sw 5/19/1998 14:12'!
saveScriptVersion: timeStampCurrentlyIgnored
	self isTextuallyCoded ifFalse:
		[formerScriptEditors == nil ifTrue: [formerScriptEditors _ OrderedCollection new].
		currentScriptEditor ifNotNil: [formerScriptEditors add: currentScriptEditor fullCopy].
		formerScriptEditors size > 100 ifTrue: [^ self halt: 'apparent runaway versions']]! !

!UserScript methodsFor: 'versions' stamp: 'sw 10/30/2000 08:54'!
savedTileVersionsCount
	"Answer the number of saved tile versions of the script"

	^ formerScriptEditors ifNil: [0] ifNotNil: [formerScriptEditors size]! !


!UserScript methodsFor: 'updating' stamp: 'sw 1/22/2001 16:45'!
updateToPlayer: aPlayer
	"Set aPlayer as the current player referenced by the receiver and its script editor"

	(currentScriptEditor notNil and: [currentScriptEditor ~~ #textuallyCoded]) ifTrue:
		[currentScriptEditor updateToPlayer: aPlayer].
	player _ aPlayer! !
Object subclass: #Utilities
	instanceVariableNames: ''
	classVariableNames: 'AuthorInitials AuthorName CommonRequestStrings FlapTabs LastStats RecentSubmissions ScrapsBook UpdateDownloader UpdateUrlLists '
	poolDictionaries: ''
	category: 'System-Support'!
!Utilities commentStamp: '<historical>' prior: 0!
A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don't naturally attach to anything else.  1/96 sw!


!Utilities methodsFor: 'look in class' stamp: 'sw 10/13/1998 13:14'!
seeClassSide
	"All the code for Utilitites is on the class side"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Utilities class
	instanceVariableNames: ''!

!Utilities class methodsFor: 'fetching updates' stamp: 'sr 5/30/2000 02:28'!
applyUpdatesFromDisk
	"Utilities applyUpdatesFromDisk"
	self applyUpdatesFromDiskToUpdateNumber: 1000000 "one million should be sufficient ;-)"! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sr 5/30/2000 02:24'!
applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber
	"To use this mechanism, be sure all updates you want to have considered
	are in a folder named 'updates' which resides in the same directory as  
	your image.  Having done that, simply evaluate:  
	  
	Utilities applyUpdatesFromDiskToUpdateNumber: 1234

	and all numbered updates <= lastUpdateNumber not yet in the image will be loaded, in
	numerical order."
	| previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded |
	previousHighest _ ChangeSorter highestNumberedChangeSet.
	currentUpdateNumber _ previousHighest.
	done _ false.
	(FileDirectory default directoryNames includes: 'updates')
		ifFalse: [^ self inform: 'Error: cannot find "updates" folder'].
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.
	[done]
		whileFalse: 
			[currentUpdateNumber _ currentUpdateNumber + 1.
			currentUpdateNumber > lastUpdateNumber
				ifTrue: [done _ true]
				ifFalse: 
					[fileNames _ updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'.
					fileNames size > 1 ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , '
(at this point it is probably best to remedy
the situation on disk, then try again.)'].
					fileNames size == 0
						ifTrue: [done _ true]
						ifFalse: [ChangeSorter newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first)
								named: fileNames first]]].
	aMessage _ (loaded _ currentUpdateNumber - previousHighest - 1) = 0
				ifTrue: ['No new updates found.']
				ifFalse: [loaded printString , ' update(s) loaded.'].
	self inform: aMessage , '
Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 5/16/2000 13:33'!
broadcastUpdatesFrom: n1 to: n2 except: skipList
"
	ChangeSorter removeChangeSetsNamedSuchThat:
		[:name | name first isDigit and: [name initialIntegerOrNil > 412]].
	Utilities readServerUpdatesSaveLocally: true updateImage: true.
	Utilities broadcastUpdatesFrom: 413 to: 999 except: #().

	Utilities readServerUpdatesSaveLocally: true updateImage: false
       The expression above ftps all updates not in the current image
over to the local
       hard disk, but does NOT absorb them into the current image
"
	| fileNames fileNamesInOrder fileNamesUnnumbered names choice file
csname updateDirectory |
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.
	fileNames _ updateDirectory fileNames select:
		[:n | n first isDigit
			and: [(n initialIntegerOrNil between: n1 and: n2)
			and: [(skipList includes: n initialIntegerOrNil) not]]].
	fileNamesInOrder _ fileNames asSortedCollection: [:a :b | a
initialIntegerOrNil < b initialIntegerOrNil].
	fileNamesUnnumbered _ fileNamesInOrder collect:
		[:n | n copyFrom: (n findFirst: [:c | c isDigit not]) to: n size].
	(csname _ fileNamesUnnumbered asBag sortedCounts first) key > 1
		ifTrue: [self halt: 'Repeated name: ' , csname value].
	(file _ fileNamesUnnumbered select: [:n | (n occurrencesOf: $.) > 1])
size > 0
		ifTrue: [self halt: file first , ' has multiple periods'].
	fileNamesInOrder with: fileNamesUnnumbered do:
		[:n :nu | updateDirectory rename: n toBe: nu].

	names _ ServerDirectory groupNames asSortedArray.
	choice _ (SelectionMenu labelList: names selections: names) startUp.
	choice == nil ifTrue: [^ self].
	(ServerDirectory groupNamed: choice) putUpdateMulti:
fileNamesUnnumbered fromDirectory: updateDirectory
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/12/2000 22:16'!
chooseUpdateList
	"When there is more than one set of update servers, let the user choose which we will update from.  Put it at the front of the list. Return false if the user aborted.  If the preference #promptForUpdateServer is false, then suppress that prompt, in effect using the same server choice that was used the previous time (a convenience for those of us who always answer the same thing to the prompt.)"

	| index him |
	((UpdateUrlLists size > 1) and: [Preferences promptForUpdateServer])
		ifTrue:
			[index _ (PopUpMenu labelArray: (UpdateUrlLists collect: [:each | each first]) lines: #()) 
				startUpWithCaption: 'Choose a group of servers
from which to fetch updates.'.
			index > 0 ifTrue:
				[him _ UpdateUrlLists at: index.
				UpdateUrlLists removeAt: index.
				UpdateUrlLists addFirst: him].
			^ index > 0].
	^ true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 9/21/97 01:12'!
extractThisVersion: list
	"Pull out the part of the list that applies to this version."

	| delims lines ii out eToySystem |
	(eToySystem _ Smalltalk at: #EToySystem ifAbsent: [nil]) ifNil: [^ #()].
	delims _ String with: Character cr with: Character linefeed.
	lines _ list findTokens: delims.
	ii _ lines indexOf: '#', eToySystem version.
	ii = 0 ifTrue: [^ #()].
	out _ OrderedCollection new.
	[(ii _ ii + 1) <= lines size] whileTrue:
		[(lines at: ii) first == $# ifTrue: [^ out "next version"].
		(lines at: ii) first == $* ifFalse: [out addLast: (lines at: ii)]].	"keep, except comments"
	^ out! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 2/16/98 16:16'!
lastUpdateNum: updatesFileStrm
	"Look in the Updates file and see what the last sequence number is.  Warn the user if the version it is under is not this image's version."

	| verIndex seqIndex char ver seqNum |
	verIndex _ seqIndex _ 0.	 "last # starting a line and last digit starting a line"
	seqNum _ 0.
	updatesFileStrm reset; ascii.
	[char _ updatesFileStrm next.
	 updatesFileStrm atEnd] whileFalse: [
		char == Character cr ifTrue: [
			updatesFileStrm peek == $# ifTrue: [verIndex _ updatesFileStrm position +1.
				seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far"
					updatesFileStrm position: seqIndex.
					ver _ SmallInteger readFrom: updatesFileStrm.
					seqNum _ seqNum max: ver.
					updatesFileStrm position: verIndex-1]].
			updatesFileStrm peek isDigit ifTrue: [seqIndex _ updatesFileStrm position]]].

	seqIndex = 0 ifFalse: ["See if last num of old version if biggest so far"
		updatesFileStrm position: seqIndex.
		ver _ SmallInteger readFrom: updatesFileStrm.
		seqNum _ seqNum max: ver.
		updatesFileStrm setToEnd].
	^ seqNum! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 8/20/1999 10:25'!
newUpdatesOn: serverList throughNumber: aNumber
	"Return a list of fully formed URLs of update files we do not yet have.  Go to the listed servers and look at the file 'updates.list' for the names of the last N update files.  We look backwards for the first one we have, and make the list from there.  tk 9/10/97
	No updates numbered higher than aNumber (if it is not nil) are returned " 

	| existing doc list out ff raw char maxNumber itsNumber |
	maxNumber _ aNumber ifNil: [99999].
	out _ OrderedCollection new.
	existing _ ChangeSorter allChangeSetNames.
	existing _ existing collect: [:cngSet | cngSet copyReplaceAll: '/' with: '_'].
			"Replace slashes with underbars"
	serverList do: [:server |
		doc _ HTTPSocket httpGet: server,'updates.list' accept: 'application/octet-stream'.
		"test here for server being up"
		doc class == RWBinaryOrTextStream ifTrue:
			[raw _ doc reset; contents.	"one file name per line"
			list _ self extractThisVersion: raw.
			list reverseDo: [:fileName |
				ff _ (fileName findTokens: '/') last.	"allow subdirectories"

				(existing includes: ff sansPeriodSuffix)
					ifFalse:
						[itsNumber _ ff initialIntegerOrNil. 
						(itsNumber == nil or: [itsNumber <= maxNumber])
							ifTrue:
								[out addFirst: server, fileName]]
					ifTrue: [^ out]].
			((out size > 0) or: [char _ doc reset; skipSeparators; next.
				(char == $*) | (char == $#)]) ifTrue:
					[^ out "we have our list"]].	"else got error msg instead of file"
		"Server was down, try next one"].
	PopUpMenu notify: 'All code update servers seem to be unavailable'.
	^ out! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 5/7/1998 17:38'!
objectStrmFromUpdates: fileName
	"Go to the known servers and look for this file in the updates folder.  It is an auxillery file, like .morph or a .gif.  Return a RWBinaryOrTextStream on it.    Meant to be called from during the getting of updates from the server.  That assures that (Utilities serverUrls) returns the right group of servers."

| urls doc |
Cursor wait showWhile: [
	urls _ Utilities serverUrls collect: [:url | url, 'updates/', fileName].
	urls do: [:aUrl |
		doc _ HTTPSocket httpGet: aUrl accept: 'application/octet-stream'.
		"test here for server being up"
		doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]].

PopUpMenu notify: 'All update servers are unavailable, or bad file name'.
^ nil! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 7/8/2000 12:23'!
olderVersNum: restOfText from: updateStrm default: sequence
	| savePos before rest after |
	"Inserting an update in an earlier version, not the latest.  See if there is a gap in the numbering, and pick the lowest unused number there."

"number before"
savePos _ updateStrm position.   before _ after _ nil.
[before == nil] whileTrue: [
	[(updateStrm next = Character cr)] whileFalse: [updateStrm skip: -2].
	updateStrm peek isDigit 
		ifTrue: [before _ SmallInteger readFrom: updateStrm]
		ifFalse: [updateStrm skip: -4]].
updateStrm position: savePos.

"number after"
rest _ ReadStream on: restOfText.
[after == nil & (rest atEnd not)] whileTrue: [
	[(rest next = Character cr)] whileFalse.
	rest peek isDigit 
		ifTrue: [after _ SmallInteger readFrom: rest]].
after ifNil: [^ sequence].

"is there a gap?"
^ after - before > 1 ifTrue: [before] ifFalse: [sequence]! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 9/24/1998 06:26'!
position: updateStrm atVersion: version
	"Set the stream to the end of the last line of updates names for this version.  Usually the end of the file.  We will add a new update name.   Return the contents of the rest of the file."

	| char foundIt where data |
	updateStrm reset; ascii.
	foundIt _ false.
	[char _ updateStrm next.
	 updateStrm atEnd] whileFalse: [
		char == Character cr ifTrue: [
			updateStrm peek == $# ifTrue: [
				foundIt ifTrue: ["Next section"
					where _ updateStrm position.
					data _ updateStrm upTo: (255 asCharacter).
					updateStrm position: where.
					^ data].	"won't be found -- copy all the way to the end"
				updateStrm next.
				(updateStrm nextMatchAll: version) ifTrue: [
					(updateStrm atEnd or: [(updateStrm peek = Character cr) | 
						(updateStrm peek = Character lf)]) ifTrue: [
							foundIt _ true
					]]]]].
	foundIt ifTrue: [
		updateStrm setToEnd.
		^ ''].
	self error: 'The current version does not have a section in the Updates file'.
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/13/1999 23:21'!
readNextUpdateFromServer
	"Utilities readNextUpdateFromServer"
	self updateFromServerThroughUpdateNumber: (ChangeSorter highestNumberedChangeSet + 1)! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 02:02'!
readServerUpdatesSaveLocally: saveLocally updateImage: updateImage
	^ self readServerUpdatesThrough: nil saveLocally: saveLocally updateImage: updateImage! !

!Utilities class methodsFor: 'fetching updates' stamp: 'mir 10/6/2000 14:54'!
readServerUpdatesThrough: maxNumber saveLocally: saveLocally updateImage: updateImage
	"Scan the update server(s) for unassimilated updates. If maxNumber is not nil, it represents the highest-numbered update to load.  This makes it possible to update only up to a particular point.   If saveLocally is true, then save local copies of the update files on disc.  If updateImage is true, then absorb the updates into the current image.

A file on the server called updates.list has the names of the last N update files.  We look backwards for the first one we do not have, and start there"
"* To add a new update:  Name it starting with a new two-digit code.  
* Do not use %, /, *, space, or more than one period in the name of an update file.
* The update name does not need to have any relation to the version name.
* Figure out which versions of the system the update makes sense for.
* Add the name of the file to each version's category below.
* Put this file and the update file on all of the servers.
*
* To make a new version of the system:  Pick a name for it (no restrictions)
* Put # and exactly that name on a new line at the end of this file.
* During the release process, fill in exactly that name in the dialog box.
* Put this file on the server."

"Utilities readServerUpdatesThrough: 828 saveLocally: false updateImage: true"
"Utilities readServerUpdatesThrough: 828 saveLocally: true updateImage: true"

	| urls failed loaded str docQueue this nextDoc docQueueSema |
	Utilities chooseUpdateList ifFalse: [^ self].	"ask the user which kind of updates"
	Cursor wait showWhile: [

	urls _ self newUpdatesOn: (Utilities serverUrls collect: [:url | url, 'updates/']) 
				throughNumber: maxNumber.
	loaded _ 0.
	failed _ nil.

	"send downloaded documents throuh this queue"
	docQueue := SharedQueue new.

	"this semaphore keeps too many documents from beeing queueed up at a time"
	docQueueSema := Semaphore new.
	5 timesRepeat: [ docQueueSema signal ].

	"fork a process to download the updates"
	self retrieveUrls: urls ontoQueue: docQueue withWaitSema: docQueueSema.

	"process downloaded updates in the foreground"
	[ this _ docQueue next.
	  nextDoc _ docQueue next.  
	  nextDoc = #failed ifTrue: [ failed _ this ].
	  (failed isNil and: [ nextDoc ~= #finished ])
	] whileTrue: [
		failed ifNil: [
			nextDoc reset; text.
			nextDoc size = 0 ifTrue: [ failed _ this ]. ].
		failed ifNil: [
			nextDoc peek asciiValue = 4	"pure object file"
				ifTrue: [failed _ this]].	"Must be fileIn, not pure object file"
		failed ifNil: [
			"(this endsWith: '.html') ifTrue: [doc _ doc asHtml]."
				"HTML source code not supported here yet"
			updateImage ifTrue:	
				[ChangeSorter newChangesFromStream: nextDoc
					named: (this findTokens: '/') last].
			saveLocally ifTrue:
				[self saveUpdate: nextDoc onFile: (this findTokens: '/') last].	"if wanted"
			loaded _ loaded + 1].

		docQueueSema signal].
	].

	"report to user"
	str _ loaded printString ,' new update file(s) processed.'.
	failed ifNotNil: [str _ str, '\Could not load ' withCRs, 
		(urls size - loaded) printString ,' update file(s).',
		'\Starting with "' withCRs, failed, '".'].
	failed ifNil: [
		"DocLibrary external ifNotNil: [
			DocLibrary external updateMethodVersions] are not using this yet"].
	self inform: str.

! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 5/7/1998 17:04'!
removeDisney
	"remove the Disney server from the update lists.  For external release."

	UpdateUrlLists copy do: [:pair |
		(pair first includesSubstring: 'Disney' caseSensitive: false) ifTrue: [
			UpdateUrlLists remove: pair]].
	Smalltalk removeKey: #UpdatesAtDOL ifAbsent: [].
	Smalltalk removeKey: #UpdatesAtWebPage ifAbsent: [].

! !

!Utilities class methodsFor: 'fetching updates' stamp: 'RAA 12/17/2000 16:17'!
retrieveUrls: urls ontoQueue: queue withWaitSema: waitSema 
	"download the given list of URLs. The queue will be loaded alternately  
	with url's and with the retrieved contents. If a download fails, the  
	contents will be #failed. If all goes well, a special pair with an empty  
	URL and the contents #finished will be put on the queue. waitSema is  
	waited on every time before a new document is downloaded; this keeps 
	the downloader from getting too far  ahead of the main process"
	"kill the existing downloader if there is one"
	| doc |
	UpdateDownloader
		ifNotNil: [UpdateDownloader terminate].
	"fork a new downloading process"
	UpdateDownloader _ [urls
				do: [:url | 
					waitSema wait.
					queue nextPut: url.
					doc _ HTTPSocket httpGet: url accept: 'application/octet-stream'.
					doc class == String
						ifTrue: [queue nextPut: #failed.
							UpdateDownloader _ nil.
							Processor activeProcess terminate]
						ifFalse: [queue nextPut: doc]].
			queue nextPut: ''.
			queue nextPut: #finished.
			UpdateDownloader _ nil] newProcess.
	UpdateDownloader priority: Processor userInterruptPriority.
	"start the process running"
	UpdateDownloader resume! !

!Utilities class methodsFor: 'fetching updates' stamp: 'th 4/25/2000 12:59'!
saveUpdate: doc onFile: fileName
	"Save the update on a local file.  With or without the update number on the front, depending on the preference #updateRemoveSequenceNum"

	| file fName pos updateDirectory |

	(FileDirectory default directoryNames includes: 'updates') ifFalse:
		[FileDirectory default createDirectory: 'updates'].
	updateDirectory _ FileDirectory default directoryNamed: 'updates'.

	fName _ fileName.
	(Preferences valueOfFlag: #updateRemoveSequenceNum) ifTrue:
		[pos _ fName findFirst: [:c | c isDigit not].
		fName _ fName copyFrom: pos to: fName size].
	doc reset; ascii.
	(updateDirectory fileExists: fName) ifFalse:
		[file _ updateDirectory newFileNamed: fName.
		file nextPutAll: doc contents.
		file close].
! !

!Utilities class methodsFor: 'fetching updates' stamp: 'di 10/16/1999 23:21'!
serverUrls 
	"Return the current list of server URLs.  For code updates.  Format of UpdateUrlLists is 
#( ('squeak updates' ('url1' 'url2'))
    ('some other updates' ('url3' 'url4')))"

	| list |
	list _ UpdateUrlLists first last.

	"If there is a dead server, return a copy with that server last" 
	list clone withIndexDo: [:aName :ind |
	(aName beginsWith: Socket deadServer) ifTrue: [
		list _ list asOrderedCollection.	"and it's a copy"
		list removeAt: ind.
		list addLast: aName]].

	^ list asArray! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 10/13/1998 16:03'!
updateFromServer
	"Update the image by loading all pending updates from the server.  Also save local copies of the update files if the #updateSavesFile preference is set to true"

	self readServerUpdatesSaveLocally: Preferences updateSavesFile updateImage: true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'sw 1/10/1999 01:59'!
updateFromServerThroughUpdateNumber: aNumber
	"Update the image by loading all pending updates from the server.  Also save local copies of the update files if the #updateSavesFile preference is set to true"

	self readServerUpdatesThrough: aNumber saveLocally: Preferences updateSavesFile updateImage: true! !

!Utilities class methodsFor: 'fetching updates' stamp: 'tk 5/7/1998 17:03'!
updateUrlLists

	UpdateUrlLists ifNil: [UpdateUrlLists _ OrderedCollection new].
	^ UpdateUrlLists! !

!Utilities class methodsFor: 'fetching updates' stamp: 'RAA 12/17/2000 16:19'!
zapUpdateDownloader

	UpdateDownloader ifNotNil: [UpdateDownloader terminate].
	UpdateDownloader _ nil.! !


!Utilities class methodsFor: 'debugging'!
inspectCollection: aCollection notifying: aView
	aCollection size = 0 
		ifTrue: [aView notNil 
			ifTrue: [^ aView flash]
			ifFalse: [^ self]].
	aCollection size = 1
		ifTrue: [aCollection first inspect]
		ifFalse: [aCollection asArray inspect]! !


!Utilities class methodsFor: 'investigations'!
inspectGlobals
	"Utilities  inspectGlobals"
	| associations aDict |
	associations _ ((Smalltalk keys select: [:aKey | ((Smalltalk at: aKey) isKindOf: Class) not]) asSortedArray collect:
		[:aKey | Smalltalk associationAt: aKey]).
	aDict _ IdentityDictionary new.
	associations do: [:as | aDict add: as].
	aDict inspectWithLabel: 'The Globals'! !

!Utilities class methodsFor: 'investigations' stamp: 'sw 3/27/2000 15:34'!
reportSenderCountsFor: selectorList
	"Produce a report on the number of senders of each of the selectors in the list.  1/27/96 sw"

	| total report thisSize |
	total _ 0.
	report _ '
'.
	selectorList do:
		[:selector | thisSize _ (Smalltalk allCallsOn: selector) size.
		report _ report, thisSize printString, String tab, selector printString, String cr.
		total _ total + thisSize].
	report _ report, '--- ------------------
'.
	report _ report, total printString, String tab, 'TOTAL
'.
	^ report! !


!Utilities class methodsFor: 'identification' stamp: 'dhhi 11/6/97 16:48'!
authorInitials
	"Answer the initials to be used to identify the current code author.  "

	[AuthorInitials isEmpty] whileTrue: [self setAuthorInitials].
	^ AuthorInitials! !

!Utilities class methodsFor: 'identification' stamp: 'sw 7/6/1998 11:49'!
authorInitialsPerSe
	"Answer the currently-prevailing author initials, such as they, empty or not"

	^ AuthorInitials! !

!Utilities class methodsFor: 'identification' stamp: 'sma 6/1/2000 12:07'!
authorName
	AuthorName ifNil: [self setAuthorName].
	^ AuthorName! !

!Utilities class methodsFor: 'identification' stamp: 'RAA 12/28/2000 16:32'!
authorNamePerSe

	^ AuthorName! !

!Utilities class methodsFor: 'identification' stamp: 'tk 4/10/98 06:25'!
changeStamp 
	"Answer a string to be pasted into source code to mark who changed it and when."
	^ self authorInitials , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 1/29/2001 09:28'!
changeStampPerSe
	"Answer a string to be pasted into source code to mark who changed it and when."

	^ (self authorInitialsPerSe ifNil: ['¥']) , ' ' , Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification'!
copyrightNotice
	^ 'Copyright 1985-96, Apple Computer, Inc.'! !

!Utilities class methodsFor: 'identification' stamp: 'tk 4/10/1998 07:16'!
dateStamp
	"Utilities dateStamp"
	^ Date today mmddyyyy, ' ',
		((String streamContents: [:s | Time now print24: true on: s]) copyFrom: 1 to: 5)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 22:45'!
dateTimeSuffix
	"Answer a string which indicates the date and time, intended for use in building fileout filenames, etc."

	"Utilities dateTimeSuffix"
	^ Preferences twentyFourHourFileStamps
		ifFalse:
			[self monthDayTimeStringFrom: Time primSecondsClock]
		ifTrue:
			[self monthDayTime24StringFrom: Time primSecondsClock]! !

!Utilities class methodsFor: 'identification' stamp: 'di 6/13/97 13:52'!
fixStamp: changeStamp 
	| parts |
	parts _ changeStamp findTokens: ' '.
	(parts size > 0 and: [parts last first isLetter]) ifTrue:
		["Put initials first in all time stamps..."
		^ String streamContents:
				[:s | s nextPutAll: parts last.
				parts allButLast do: [:p | s space; nextPutAll: p]]].
	^ changeStamp! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'!
monthDayTime24StringFrom: aSecondCount
	| aDate aTime |
	"From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form
             ddMMMhhmm		where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock.

          Utilities monthDayTime24StringFrom: Time primSecondsClock
"

	aDate _ Date fromSeconds: aSecondCount.
	aTime _ Time fromSeconds: aSecondCount \\ 86400.

	^ (aDate dayOfMonth asTwoCharacterString), 
		(aDate monthName copyFrom: 1 to: 3), 
		(aTime hhmm24)! !

!Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'!
monthDayTimeStringFrom: aSecondCount
	| aDate aTime |
	"From the date/time represented by aSecondCount, produce a string which indicates the date and time in the form:
		ddMMMhhmmPP	  where:
							dd is a two-digit day-of-month,
							MMM is the alpha month abbreviation,
							hhmm is the time,
							PP is either am or pm

          Utilities monthDayTimeStringFrom: Time primSecondsClock
"

	aDate _ Date fromSeconds: aSecondCount.
	aTime _ Time fromSeconds: aSecondCount \\ 86400.

	^ (aDate dayOfMonth asTwoCharacterString), 
		(aDate monthName copyFrom: 1 to: 3), 
		((aTime hours \\ 12) asTwoCharacterString), 
		(aTime minutes asTwoCharacterString),
		(aTime hours > 12 ifTrue: ['pm'] ifFalse: ['am'])! !

!Utilities class methodsFor: 'identification' stamp: 'dhhi 11/6/97 16:47'!
setAuthorInitials
	"Put up a dialog allowing the user to specify the author's initials.  "

	self setAuthorInitials:
		(FillInTheBlank request: 'Please type your initals: '
					initialAnswer: AuthorInitials)! !

!Utilities class methodsFor: 'identification' stamp: 'di 9/11/2000 13:10'!
setAuthorInitials: aString

	AuthorInitials _ aString.

	"Case of being reset due to, eg, copy of image."
	aString isEmpty ifTrue: [AuthorName _ nil]! !

!Utilities class methodsFor: 'identification' stamp: 'sma 6/1/2000 12:08'!
setAuthorName
	AuthorName _ FillInTheBlank 
			request: 'Please type your name:'
			initialAnswer: 'Your Name'! !


!Utilities class methodsFor: 'support windows' stamp: 'sw 12/6/2000 20:30'!
commandKeyMappings
	^ self class firstCommentAt: #commandKeyMappings

"Lower-case command keys
(use with Cmd key on Mac and Alt key on other platforms)

a	Select all
b	Browse it (selection is a class name or cursor is over a class-list or message-list)
c	Copy selection
d	Do it (selection is a valid expression)
e	Exchange selection with prior selection
f	Find
g	Find again
h	Set selection as search string for find again
i	Inspect it (selection is a valid expression, or selection is over an inspect-ilst)
j	Again once (do the last text-related operation again)
k	Set font
l	Cancel
m	Implementors of it (selection is a message selector or cursor is over a class-list or message-list)
n	Senders of it (selection is a message selector or cursor is over a class-list or message-list)
o	Spawn current method
p	Print it (selection is a valid expression)
q	Query symbol (toggle all possible completion for a given prefix)
r	Recognizer
s	Save (i.e. accept)
t	Finds a Transcript (when cursor is over the desktop)
u	Toggle alignment
v	Paste
w	Delete preceding word (over text);  Close-window (over morphic desktop)
x	Cut selection
y	Swap characters
z	Undo

Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want.  Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line.  Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers.

Upper-case command keys
(use with Shift-Cmd, or Ctrl on Mac
 or Shift-Alt on other platforms; sometimes Ctrl works too)

A	Advance argument
B	Browse it in this same browser (in System browsers only)
C	Compare argument to clipboard
D	Duplicate
E	Method strings containing it
F	Insert 'ifFalse:'
I	Inspect via Object Explorer
J	Again many (apply the previous text command repeatedly until the end of the text)
K	Set style
L	Outdent (move selection one tab-stop left)
N	References to it (selection is a class name, or cursor is over a class-list or message-list)
O	Open single-message browser (in message lists)
P	Make project link
R	Indent (move selection one tab-stap right)
S	Search
T	Insert 'ifTrue:'
U	Convert linefeeds to carriage returns in selection
V	Paste author's initials
W	Selectors containing it (in text); show-world-menu (when issued with cursor over desktop)
X	Force selection to lowercase
Y	Force selection to uppercase
Z	Capitalize all words in selection

Other special keys

Backspace	Backward delete character
Del			Forward delete character
Shift-Bcksp	Backward delete word
Shift-Del	Forward delete word
Esc			Select current type-in

\			Send top window to back

Cursor keys
left, right,
up, or
down		Move cursor left, right, up or down
Ctrl+Left	Move cursor left one word
Ctrl+Right	Move cursor right one word
Home		Move cursor to begin of line or begin of text
End			Move cursor to end of line or end of text
PgUp, or
Ctrl+Up		Move cursor up one page
PgDown, or
Ctrl+Down	Move cursor down one page

Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, which is, compared to other systems, still a limitation aka bug.

Other Cmd-key combinations (does not work on all platforms)

Return		Insert return followed by as many tabs as the previous line
			(with a further adjustment for additional brackets in that line)
Space		Select the current word as with double clicking

Enclose the selection in a kind of bracket.  Each is a toggle.
(does not work on all platforms)
Ctrl-(	Enclose within ( and ), or remove enclosing ( and )
Ctrl-[	Enclose within [ and ], or remove enclosing [ and ]
Crtl-{	Enclose within { and }, or remove enclosing { and }
Ctrl-<	Enclose within < and >, or remove enclosing < and >
Ctrl-'	Enclose within ' and ', or remove enclosing ' and '
Ctrl-""	Enclose within "" and "", or remove enclosing "" and ""

Note also that you can double-click just inside any of the above delimiters (or at the beginning or end of a line) to select the text enclosed.

Text Emphasis...
(does not work on all platforms)
Cmd-1	10 point font
Cmd-2	12 point font
Cmd-3	18 point font
Cmd-4	24 point font
Cmd-5	36 point font
Cmd-6	color, action-on-click, link to class comment, link to method, url
		Brings up a menu.  To remove these properties, select
		more than the active part and then use command-0.
Cmd-7	bold
Cmd-8	italic
Cmd-9	narrow (same as negative kern)
Cmd-0	plain text (resets all emphasis)
Cmd--	underlined (toggles it)
Cmd-=	struck out (toggles it)

Shift-Cmd--	(aka _) negative kern (letters 1 pixel closer)
Shift-Cmd-+	positive kern (letters 1 pixel larger spread)
"! !

!Utilities class methodsFor: 'support windows' stamp: 'di 9/23/1998 01:53'!
openCommandKeyHelp
	"Open a window giving command key help."
	"Utilities openCommandKeyHelp"

	(StringHolder new contents: self commandKeyMappings)
		openLabel: 'Command Key Actions'
! !

!Utilities class methodsFor: 'support windows' stamp: 'di 9/23/1998 02:02'!
openStandardWorkspace 
	"Open up a throwaway workspace with useful expressions in it.  1/22/96 sw"
	"Utilities openStandardWorkspace"

	(StringHolder new contents: self standardWorkspaceContents)
		openLabel: 'Useful Expressions ', Date today printString! !

!Utilities class methodsFor: 'support windows' stamp: 'sw 1/19/2000 13:59'!
standardWorkspaceContents
	^ self class firstCommentAt: #standardWorkspaceContents

	"Smalltalk recover: 10000.
ChangeList browseRecentLog.
ChangeList browseRecent: 2000.

Preferences editAnnotations.
Utilities reinstateDefaultFlaps. 
Preferences resetCategoryInfo

(FileStream oldFileNamed: 'Lives of the Wolves') edit.
(FileStream oldFileNamed: 'tuesdayFixes.cs') fileIn
ChangeList browseFile: 'myChanges.st'

TextStyle default fontAt: 7 put: (StrikeFont new readMacFontHex: 'Cairo 18')

StandardSystemView browseAllAccessesTo: 'maximumSize'.
StandardSystemView doCacheBits  ""restore fast windows mode in mvc""

Symbol selectorsContaining: 'rsCon'.
Smalltalk browseMethodsWhoseNamesContain: 'screen'.

Browser newOnClass: Utilities.
Browser fullOnClass: SystemDictionary.

FormView allInstances inspect.
StandardSystemView someInstance inspect.

Utilities storeTextWindowContentsToFileNamed: 'TextWindows'
Utilities reconstructTextWindowsFromFileNamed: 'TextWindows'

ScriptingSystem resetStandardPartsBin.
ScheduledControllers screenController openMorphicConstructionWorld.
ScheduledControllers screenController openMorphicWorld.

SystemOrganization categoryOfElement: #Controller. 
ParagraphEditor organization categoryOfElement: #changeEmphasis.

Cursor wait showWhile: [Sensor waitButton].

Smalltalk bytesLeft asStringWithCommas.
Symbol instanceCount. 
Time millisecondsToRun:
	[Smalltalk allCallsOn: #asOop]
MessageTally spyOn: [Smalltalk allCallsOn: #asOop].

"

"Utilities openStandardWorkspace"! !


!Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:17'!
informUser: aString during: aBlock
	"Display a message above (or below if insufficient room) the cursor during execution of the given block."
	"Utilities informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]"

	Smalltalk isMorphic
		ifTrue:
			[(MVCMenuMorph from: (SelectionMenu labels: '') title: aString)
				displayAt: Sensor cursorPoint during: [aBlock value].
			^ self].

	(SelectionMenu labels: '')
		displayAt: Sensor cursorPoint
		withCaption: aString
		during: [aBlock value]! !

!Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:18'!
informUserDuring: aBlock
	"Display a message above (or below if insufficient room) the cursor during execution of the given block."
	"Utilities informUserDuring:[:bar|
		#(one two three) do:[:info|
			bar value: info.
			(Delay forSeconds: 1) wait]]"
	Smalltalk isMorphic
		ifTrue:
			[(MVCMenuMorph from: (SelectionMenu labels: '') title: '						')
				informUserAt: Sensor cursorPoint during: aBlock.
			^ self].
	aBlock value:[:string| Transcript cr; show: string]! !


!Utilities class methodsFor: 'miscellaneous' stamp: 'ar 1/31/2001 17:06'!
addSampleWindowsTo: aPage
	"Add windows representing a browser, a workspace, etc., to aPage"
	|  aWindow pu |
	aWindow _ Browser new openAsMorphEditing: nil.
	aWindow setLabel: 'System Browser'.
	aPage addMorphBack: aWindow applyModelExtent.
	aWindow _ PackagePaneBrowser new openAsMorphEditing: nil.
	aWindow setLabel: 'Package Browser'.
	aPage addMorphBack: aWindow applyModelExtent.
	aWindow _ Workspace new embeddedInMorphicWindowLabeled: 'Workspace'.
	aPage addMorphBack: aWindow applyModelExtent.
	aPage addMorphBack: FileList openAsMorph applyModelExtent.

	aPage addMorphBack: DualChangeSorter new morphicWindow applyModelExtent.
	aPage addMorphBack: ChangeSorter new morphicWindow applyModelExtent.

	aWindow _ SelectorBrowser new morphicWindow.
	aWindow setLabel: 'Selector Browser'.
	aPage addMorphBack: aWindow.
	aPage addMorphBack: ((pu _ PasteUpMorph newSticky borderInset) embeddedInMorphicWindowLabeled: 'assembly').
	pu color: (Color r: 0.839 g: 1.0 b: 0.935)! !

!Utilities class methodsFor: 'miscellaneous'!
awaitMouseUpIn: box repeating: doBlock ifSucceed: succBlock
	"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock.  While waiting for the mouse to come up, repeatedly execute doBlock. 5/11/96 sw
	6/10/96 sw: call new method that adds extra feature"

	^ self awaitMouseUpIn: box whileMouseDownDo: doBlock whileMouseDownInsideDo: [] ifSucceed: succBlock! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'JMM 3/31/2000 20:41'!
awaitMouseUpIn: box whileMouseDownDo: doBlock1 whileMouseDownInsideDo: doBlock2 ifSucceed: succBlock
	"The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock.  While waiting for the mouse to come up, repeatedly execute doBlock1, and also, if the cursor is within the box, execute doBlock2.  6/10/96 sw
3/31/00 JMM added logic to stop multiple redraws"

	| p inside lightForm darkForm isLight |

	p _ Sensor cursorPoint.
	inside _ box insetBy: 1.
	isLight _ true.
	lightForm _ Form fromDisplay: inside.
	darkForm _ lightForm deepCopy reverse.
	[Sensor anyButtonPressed] whileTrue:
		[doBlock1 value.
		(box containsPoint: (p _ Sensor cursorPoint))
			ifTrue: [doBlock2 value.
					isLight ifTrue: 
						[isLight _ false.
						darkForm displayAt: inside origin]]
			ifFalse: [isLight ifFalse:
						[isLight _ true.
						lightForm displayAt: inside origin]]].
	(box containsPoint: p)
		ifTrue: [lightForm displayAt: inside origin.
				^ succBlock value]
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 9/6/2000 09:06'!
cleanseOtherworldlySteppers
	"If the current project is a morphic one, then remove from its steplist those morphs that are not really in the world"

	| old delta |
	Smalltalk isMorphic ifTrue:
		[old _ self currentWorld stepListSize.
		self currentWorld steppingMorphsNotInWorld do: [:m | m delete].
		self currentWorld cleanseStepList.
		(delta _ (old - self currentWorld stepListSize)) > 0 ifTrue:
			[Transcript cr; show: (delta asString, ' morphs removed from steplist')]]

	"Utilities cleanseOtherworldlySteppers"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'mdr 8/31/2000 18:54'!
convertCRtoLF: fileName
	"Convert the given file to LF line endings. Put the result in a file with the extention '.lf'"

	| in out c justPutCR |
	in _ (FileStream readOnlyFileNamed: fileName) binary.
	out _  (FileStream newFileNamed: fileName, '.lf') binary.
	justPutCR _ false.
	[in atEnd] whileFalse: [
		c _ in next.
		c = 10
			ifTrue: [
				out nextPut: 13.
				justPutCR _ true]
			ifFalse: [
				(justPutCR and: [c = 10]) ifFalse: [out nextPut: c].
				justPutCR _ false]].
	in close.
	out close.
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sbw 10/13/1999 22:28'!
createPageTestWorkspace
	"Used to generate a workspace window for testing page up and page down stuff."
	"Utilities createPageTestWorkspace"

	| numberOfLines maxStringLength minLineCounterSize lineCounterSize offsetSize stream headerConstant prevStart prevStrLen prevLineNumber stringLen lineNumber start log pad charIndex char |
	numberOfLines _ 400.
	maxStringLength _ 22.
	minLineCounterSize _ 3.
	lineCounterSize _ (numberOfLines log asInteger + 1) max: minLineCounterSize.
	offsetSize _ 5.
	stream _ ReadWriteStream on: ''.
	headerConstant _ lineCounterSize + 1 + offsetSize + 1.
	prevStart _ headerConstant negated.
	prevStrLen _ 0.
	prevLineNumber _ 0.
	numberOfLines timesRepeat: [
		stringLen _ maxStringLength atRandom max: 1.
		lineNumber _ prevLineNumber + 1.
		start _ prevStart + prevStrLen + headerConstant + 1.
		prevStart _ start.
		prevStrLen _ stringLen.
		prevLineNumber _ lineNumber.
		log _ lineNumber log asInteger.
		pad _ lineCounterSize - log - 1.
		pad timesRepeat: [stream nextPutAll: '0'].
		stream nextPutAll: lineNumber printString.
		stream space.
		log _ start log asInteger.
		pad _ offsetSize - log - 1.
		pad timesRepeat: [stream nextPutAll: '0'].
		stream nextPutAll: start printString.
		stream space.
		charIndex _ 'a' first asInteger.
		stringLen timesRepeat: [
			char _ Character value: charIndex.
			charIndex _ charIndex + 1.
			stream nextPut: char].
		lineNumber = numberOfLines ifFalse: [stream cr]
		].
	(Workspace new contents: stream contents) openLabel: 'Test Data'.
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 4/7/1999 11:42'!
decommissionTheAllCategory
	"Utilities decommissionTheAllCategory"
	"Moves all methods that are in a category named 'all' into the default 'as yet unclassified' category"

	| org aCategory methodCount classCount any |
	methodCount _ 0.
	classCount _ 0.
	Smalltalk allBehaviorsDo:
		[:aClass | org _ aClass organization.
			any _ false.
			aClass selectorsDo:
				[:aSelector |
					aCategory _ org categoryOfElement: aSelector.
					aCategory = #all ifTrue:
						[org classify: aSelector under: ClassOrganizer default suppressIfDefault: false.
						methodCount _ methodCount + 1.
						any _ true]].
			any ifTrue: [classCount _ classCount + 1].
			org removeEmptyCategories].
	Transcript cr; show: methodCount printString, ' methods in ', classCount printString, ' classes moved
from "all" to "as yet unclassified"'
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sma 4/30/2000 10:17'!
emergencyCollapse
	Smalltalk isMorphic ifTrue: [^ self].
	ScheduledControllers screenController emergencyCollapse! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/4/2001 09:51'!
fileOutUnnumberedChangeSets
	"File out all nonempty change sets whose names do not start with numbers, without checking for slips"

	| aList |
	"Utilities fileOutUnnumberedChangeSets"

	aList _ ChangeSorter allChangeSetNames reject:
		[:aName | ((aName startsWithDigit or: [(ChangeSorter changeSetNamed: aName) isEmpty]) or: [aName beginsWith: 'Play With Me']) or: [aName = 'MakeInternal']].
	Preferences setFlag: #checkForSlips toValue: false during: 
		[self fileOutChangeSetsNamed: aList asSortedArray]! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/30/98 15:44'!
getterSelectorFor: aName
	"Utilities getterSelectorFor: #elvis"
	^ ('get', (aName asString capitalized)) asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 5/19/2000 16:04'!
inherentSelectorForGetter: aGetterSelector
	"Given a selector of the form #getAbc, return the inherent slotname selector that corresponds, which is to say, getterSelector with the leading 'get' removed and with the next character forced to lower case; this is the inverse of #getterSelectorFor:"

	"Utilities inherentSelectorForGetter: #getWidth"
	((aGetterSelector size < 4) or: [(aGetterSelector beginsWith: 'get') not])
			ifTrue: [ ^ aGetterSelector].
	^ ((aGetterSelector at: 4) asLowercase asString, (aGetterSelector copyFrom: 5 to: aGetterSelector size)) asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'mdr 9/4/2000 11:07'!
instanceComparisonsBetween: fileName1 and: fileName2
	"For differential results, run printSpaceAnalysis twice with different fileNames,
	then run this method...
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'.
			--- do something that uses space here ---
		Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'.
		Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'"

	| instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace |
	instCountDict _ Dictionary new.
	report _ ReadWriteStream on: ''.
	f _ FileStream readOnlyFileNamed: fileName1.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size == 4 or: [items size == 5]) ifTrue:
			[instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]].
	f close.

	f _ FileStream readOnlyFileNamed: fileName2.
	[f atEnd] whileFalse:
		[aString _ f upTo: Character cr.
		items _ aString findTokens: ' '.
		(items size == 4 or: [items size == 5]) ifTrue:
			[className _ items first.
			newInstCount _ items third asNumber.
			newSpace _ items fourth asNumber.
			oldPair _ instCountDict at: className ifAbsent: [nil].
			oldInstCount _ oldPair ifNil: [0] ifNotNil: [oldPair first].
			oldSpace _ oldPair ifNil: [0] ifNotNil: [oldPair second].
			oldInstCount ~= newInstCount ifTrue:
				[report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]].
	f close.

	(StringHolder new contents: report contents)
		openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2! !

!Utilities class methodsFor: 'miscellaneous'!
isObject: anObject memberOfOneOf: aCollectionOfClassnames
	aCollectionOfClassnames do:
		[:classname | (anObject isMemberOf: (Smalltalk at: classname)) ifTrue: [^ true]].
	^ false! !

!Utilities class methodsFor: 'miscellaneous'!
keyLike: aString satisfying: aBlock
	"Return a key like aString that satisfies aBlock.  The block should provide a test for acceptability -- typically the test is about whether the key is already in use.  aBlock should return a boolean.  8/11/96 sw"

	| stemAndSuffix suffix stem newKey |
	(aBlock value: aString) ifTrue: [^ aString].
	stemAndSuffix _ aString stemAndNumericSuffix.
	suffix _ stemAndSuffix last + 1.
	stem _ stemAndSuffix first.
	[aBlock value: (newKey _ stem, suffix printString)]
		whileFalse:
			[suffix _ suffix + 1].
	^ newKey
! !

!Utilities class methodsFor: 'miscellaneous'!
keyLike: aString withTrailing: trailerString satisfying: aBlock
	"Return a key like (aString, trailerString) that satisfies aBlock.  The block should provide a test for acceptability -- typically the test is about whether the key is already in use.  aBlock should return a boolean.  8/11/96 sw"

	| stemAndSuffix suffix stem composite |
	composite _ aString, trailerString.
	(aBlock value: composite) ifTrue: [^ composite].
	stemAndSuffix _ aString stemAndNumericSuffix.
	suffix _ stemAndSuffix last + 1.
	stem _ stemAndSuffix first.
	[aBlock value: (composite _ stem, suffix printString, trailerString)]
		whileFalse:
			[suffix _ suffix + 1].
	^ composite
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 7/18/1999 21:22'!
lookUpDefinition
	| aWord aDefinition |
	(aWord _ FillInTheBlank request: 'Enter a word:') isEmpty ifTrue: [^ self].
	(aDefinition _ WordNet definitionsFor: aWord) ifNil: [^ self].
	(StringHolder new contents: aDefinition)
		openLabel: aWord

"Utilities lookUpDefinition"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'nk 10/29/2000 12:44'!
methodDiffFor: aString class: aClass selector: aSelector 
	^ (aClass includesSelector: aSelector)
		ifTrue: [TextDiffBuilder
				buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector)
				to: aString
inClass: aClass]
		ifFalse: [aString copy]! !

!Utilities class methodsFor: 'miscellaneous'!
nextClockwiseSideAfter: aSide
 	aSide == #left ifTrue:
		[^ #top].
	aSide == #right ifTrue:
		[^ #bottom].
	aSide == #top ifTrue:
		[^ #right].
	^ #left! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'jm 5/3/1998 20:12'!
openScratchWorkspaceLabeled: labelString contents: initialContents
	"Open a scratch text view with the given label on the given string. A scratch text view won't warn you about unsaved changes when you close it."
	"Utilities openScratchWorkspaceLabeled: 'Scratch' contents: 'Hello. world!!'"

	| model topView stringView |
	model _ StringHolder new contents: initialContents.
	topView _ StandardSystemView new.
	topView
		model: model;
		label: labelString;
		minimumSize: 180@120.
	topView borderWidth: 1.
	stringView _ PluggableTextView on: model 
		text: #contents
		accept: nil
		readSelection: #contentsSelection
		menu: #codePaneMenu:shifted:.
	stringView
		askBeforeDiscardingEdits: false;
		window: (0@0 extent: 180@120).
	topView addSubView: stringView.
	topView controller open.
! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeCornerFrom: aCorner
	"Answer the corner diagonally opposite to aCorner.  6/27/96 sw"

	aCorner == #topLeft
		ifTrue:
			[^ #bottomRight].
	aCorner == #topRight
		ifTrue:
			[^ #bottomLeft].
	aCorner == #bottomLeft
		ifTrue:
			[^ #topRight].
	^ #topLeft! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeModeTo: aMode
 	aMode == #readOnly ifTrue: [^ #writeOnly].
	aMode == #writeOnly ifTrue: [^ #readOnly].
	^ aMode! !

!Utilities class methodsFor: 'miscellaneous'!
oppositeSideTo: aSide
 	aSide == #left ifTrue:
		[^ #right].
	aSide == #right ifTrue:
		[^ #left].
	aSide == #top ifTrue:
		[^ #bottom].
	^ #top! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/5/1999 01:30'!
reconstructTextWindowsFromFileNamed: aName
	"Utilities reconstructTextWindowsFromFileNamed: 'TextWindows'"
	| aReferenceStream aDict |
	aReferenceStream _ ReferenceStream fileNamed: aName.
	aDict _ aReferenceStream next.
	aReferenceStream close.
	aDict associationsDo:
		[:assoc |
			(StringHolder new contents: assoc value) openLabel: assoc key andTerminate: false].
	Smalltalk isMorphic ifFalse:
		[ScheduledControllers restore.
		Processor terminateActive]! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 10/20/1999 13:48'!
setClassAndSelectorFrom: messageIDString in: csBlock
	"Decode strings of the form <className> [class] <selectorName>.   If <className> does not exist as a class, use nil for the class in the block"

	| aStream aClass maybeClass sel |
	aStream _ ReadStream on: messageIDString.
	aClass _ Smalltalk at: (aStream upTo: $ ) asSymbol ifAbsent: [nil].
	maybeClass _ aStream upTo: $ .
	sel _ aStream upTo: $ .
	((maybeClass = 'class') & (sel size ~= 0))
		ifTrue:
			[aClass
				ifNil:
					[csBlock value: nil value: sel asSymbol]
				ifNotNil:
					[csBlock value: aClass class value: sel asSymbol]]
		ifFalse:
			[csBlock value: aClass value: maybeClass asSymbol]


"
Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].

Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString].
"
! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/30/98 15:12'!
setterSelectorFor: aName
	"Utilities setterSelectorFor: #elvis"
	^ (('set', (aName asString capitalized)), ':') asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 2/16/1999 18:07'!
simpleSetterFor: aSymbol
	"Utilities simpleSetterFor: #right"
	^ (aSymbol, ':') asSymbol! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'sw 9/8/2000 10:02'!
steplistToolsWorkspace
	^ ((StringHolder new contents:  'self currentWorld listOfSteppingMorphs asArray inspectWithLabel: ''stepping morphs''.
Utilities cleanseOtherworldlySteppers.
self currentWorld steppingMorphsNotInWorld do: [:m | m delete].
self currentWorld stepListSummary.
self currentWorld stepListSize.
self currentHand attachMorph: FrameRateMorph new') embeddedInMorphicWindowLabeled: 'Steplist workspace')

setWindowColor: (Color r: 0.9 g: 0.7 b: 0.5);
			openInWorld: self currentWorld extent: (550 @ 140)

"Utilities steplistToolsWorkspace"! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'RAA 5/25/2000 10:23'!
storeTextWindowContentsToFileNamed: aName
	"Utilities storeTextWindowContentsToFileNamed: 'TextWindows'"
	| windows aDict assoc aRefStream textToUse aTextView |

	"there is a reference to World, but this method seems to be unused"


	aDict _ Dictionary new.
	Smalltalk isMorphic
		ifTrue:
			[windows _ Display bestGuessOfCurrentWorld submorphs select: [:m | m isKindOf: SystemWindow].
			windows do:
				[:w | assoc _ w titleAndPaneText.
				assoc ifNotNil:
					[w holdsTranscript ifFalse:
						[aDict add: assoc]]]]
		ifFalse:
			[windows _ ScheduledControllers controllersSatisfying:
				[:c | (c model isMemberOf: StringHolder) or: [c model isKindOf: Workspace]].
			windows do:
				[:aController | 
					aTextView _ aController view subViews detect: [:m | m isKindOf: PluggableTextView] ifNone: [nil].
					textToUse _ aTextView
						ifNil:		[aController model contents]
						ifNotNil:	[aTextView controller text].  "The latest edits, whether accepted or not"
					aDict at: aController view label put: textToUse]].

	aDict size = 0 ifTrue: [^ self inform: 'no windows found to export.'].

	aRefStream _ ReferenceStream fileNamed: aName.
	aRefStream nextPut: aDict.
	aRefStream close.
	self inform: 'Done!!  ', aDict size printString, ' window(s) exported.'! !

!Utilities class methodsFor: 'miscellaneous' stamp: 'jm 4/20/1999 11:29'!
timeStampForMethod: method
	"Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available."

	| position file preamble stamp tokens tokenCount |
	method fileIndex == 0 ifTrue: [^ String new].  "no source pointer for this method"
	position _ method filePosition.
	file _ SourceFiles at: method fileIndex.
	file ifNil: [^ String new].  "sources file not available"
	file _ file readOnlyCopy.
	file position: (0 max: position - 150).  "Skip back to before the preamble"
		[file position < (position - 1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].
		stamp _ String new.
		tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [Scanner new scanTokens: preamble]
			ifFalse: [Array new  "ie cant be back ref"].
		(((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount - 3) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
							stamp _ tokens at: tokenCount - 2]].
		((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokenCount  - 1) = #stamp:
					ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokenCount]].
	file close.
	^ stamp! !


!Utilities class methodsFor: 'common requests' stamp: 'sw 12/1/1999 16:09'!
appendToCommonRequests: aString
	self commonRequestStrings: (CommonRequestStrings contents, String cr, aString)

"Utilities appendToCommonRequests: 'self beep'"
! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 10/15/1998 15:14'!
closeAllDebuggers
	"Utilities closeAllDebuggers"
	Smalltalk isMorphic
	ifTrue:
		[(SystemWindow allSubInstances select: [:w | w model isKindOf: Debugger])
			do: [:w | w delete]]
	ifFalse:
		[(StandardSystemController allInstances select: [:w | w model isKindOf: Debugger])
			do: [:w | w closeAndUnscheduleNoTerminate]]! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 12/12/96'!
commonRequestStrings: aString
	"Initialize the common request strings from aString.  "

	CommonRequestStrings _ StringHolder new contents: aString! !

!Utilities class methodsFor: 'common requests' stamp: 'tk 5/4/1998 17:35'!
editCommonRequestStrings
	"Let the user edit the common request strings.  2/1/96 sw"

	CommonRequestStrings openLabel: 'Common Request Strings'! !

!Utilities class methodsFor: 'common requests'!
evaluate: aString in: aContext to: aReceiver
	"evaluate aString in the given context, and return the result.  2/2/96 sw"
	| result |
	result _ Compiler new
				evaluate: aString
				in: aContext
				to: aReceiver
				notifying: nil
				ifFail: [^ #failedDoit].
	^ result! !

!Utilities class methodsFor: 'common requests'!
initialize
	"Initialize the class variables.  5/16/96 sw"
	self initializeCommonRequestStrings.
	RecentSubmissions _ OrderedCollection new! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 5/26/2000 16:26'!
initializeCommonRequestStrings
	"Initialize an array of common request strings.  2/1/96 sw"

	CommonRequestStrings _ StringHolder new contents: 
'Utilities emergencyCollapse
Utilities closeAllDebuggers
Sensor keyboard
Cursor normal show
ParagraphEditor abandonChangeText
----------------------------------
Preferences enable: #cmdDotEnabled
Form fromUser bitEdit
Display border: (0@0 extent: 640@480) width: 2
----------------------------------
Undeclared inspect
Undeclared removeUnreferencedKeys; inspect
Transcript clear
ChangeSorter removeEmptyUnnamedChangeSets
Utilities reconstructTextWindowsFromFileNamed: ''TextWindows''.
Utilities storeTextWindowContentsToFileNamed: ''TextWindows''.
self currentHand attachMorph: (FrameRateMorph new contents: ''FrameRate'').
----------------------------------
ChangeSorter removeEmptyUnnamedChangeSets
ChangeSorter reorderChangeSets.
Utilities grabScreenAndSaveOnDisk'

"Utilities initializeCommonRequestStrings"! !

!Utilities class methodsFor: 'common requests' stamp: 'sw 1/22/1999 14:02'!
offerCommonRequests
	"Offer up the common-requests menu.  If the user chooses one, then evaluate it, and -- provided the value is a number or string -- show it in the Transcript."

	"Utilities offerCommonRequests"

	| reply result aMenu index normalItemCount strings |

	(CommonRequestStrings == nil or: [CommonRequestStrings isKindOf: Array])
		ifTrue:
			[self initializeCommonRequestStrings].
	strings _ CommonRequestStrings contents.
	normalItemCount _ strings asString lineCount.
	aMenu _ PopUpMenu labels: (strings asString, '
edit this menu') lines: (Array with: normalItemCount).

	index _ aMenu startUp.
	index == 0 ifTrue: [^ self].
	reply _ aMenu labelString lineNumber: index.
	reply size == 0 ifTrue: [^ self].
	index > normalItemCount ifTrue:
		[^ self editCommonRequestStrings].

	result _ self evaluate: reply in: nil to: nil.
	(result isKindOf: Number) | (result isKindOf: String)
		ifTrue:
			[Transcript cr; nextPutAll: result printString]! !


!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 1/17/97'!
browseRecentSubmissions
	"Open up a browser on the most recent methods submitted in the image.  5/96 sw.
	5/29/96 sw: fixed so the browser doesn't go all wonkie after you submit more code
	: reverse the order, have most recent submissions at the top of the list	
	: use RecentMessageList"

	"Utilities browseRecentSubmissions"

	| recentMessages |
	self recentMethodSubmissions size == 0 ifTrue:
		[^ SelectionMenu notify: 'There are no recent submissions'].
	
	recentMessages _ RecentSubmissions copy reversed.
	RecentMessageSet openMessageList: recentMessages name: 'Recently submitted methods -- youngest first ' autoSelect: nil! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 10/19/1999 17:52'!
mostRecentlySubmittedMessage
	^ RecentSubmissions last! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'di 3/19/2000 08:28'!
noteMethodSubmission: selectorName forClass: class
	| submission className |
	class wantsChangeSetLogging ifFalse: [^ self].
	className _ class name.
	self purgeRecentSubmissionsOfMissingMethods.
	submission _ className asString, ' ', selectorName.
	(self recentMethodSubmissions includes: submission)
		ifTrue: [RecentSubmissions remove: submission]
		ifFalse: [(RecentSubmissions size >= self numberOfRecentSubmissionsToStore) 
					ifTrue: [RecentSubmissions removeFirst]].
	RecentSubmissions addLast: submission! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 2/16/98 04:48'!
numberOfRecentSubmissionsToStore
	"Answer how many methods back the 'recent method submissions' history should store"
	^ 30! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 10/20/1999 14:03'!
purgeRecentSubmissionsOfMissingMethods
	"Utilities purgeRecentSubmissionsOfMissingMethods"

	| result |
	RecentSubmissions _ RecentSubmissions select:
		[:aSubmission |
			Utilities setClassAndSelectorFrom: aSubmission in: 
				[:aClass :aSelector |
					result _ aClass notNil and: [(aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil]].
			result]! !

!Utilities class methodsFor: 'recent method submissions'!
recentMethodSubmissions
	"Answer the list of recent method submissions, in order.  5/16/96 sw"

	RecentSubmissions == nil ifTrue: [RecentSubmissions _ OrderedCollection new].
	^ RecentSubmissions! !

!Utilities class methodsFor: 'recent method submissions' stamp: 'sw 5/30/2000 09:58'!
revertLastMethodSubmission
	| changeRecords |
	"If the most recent method submission was a method change, revert
	that change, and if it was a submission of a brand-new method, 
	remove that method."

	RecentSubmissions isEmptyOrNil ifTrue: [^ self beep].
	Utilities setClassAndSelectorFrom: RecentSubmissions last in:
		[:aClass :aSelector |
			aClass ifNil: [^ self beep].
			changeRecords _ aClass changeRecordsAt: aSelector.
			changeRecords isEmptyOrNil ifTrue: [^ self beep].
			changeRecords size == 1
				ifTrue:
					["method has no prior version, so reverting in this case means removing"
					aClass removeSelector: aSelector]
				ifFalse:
					[changeRecords second fileIn]]

"Utilities revertLastMethodSubmission"! !


!Utilities class methodsFor: 'graphical support' stamp: 'sw 11/23/1999 10:37'!
grabScreenAndSaveOnDisk  "Utilities grabScreenAndSaveOnDisk"
	| form fileName |
	form _ Form fromUser.
	form bits size = 0 ifTrue: [^ self beep].
	fileName _ FileDirectory default nextNameFor: 'Squeak' extension: 'gif'.
	Utilities informUser: 'Writing ' , fileName
		during: [GIFReadWriter putForm: form onFileNamed: fileName].! !

!Utilities class methodsFor: 'graphical support'!
showFormsAcrossTopOfScreen: aFormList
	"Display the given array of forms across the top of the screen, wrapping to subsequent lines if needed.    Useful for example for looking at sets of rotations and animations.  6/10/96 sw"

	| position maxHeight screenBox ceiling |

	position _ 20.
	maxHeight _ 0.
	ceiling _ 0.
	screenBox _ Display boundingBox.
	aFormList do:
		[:elem | elem displayAt: (position @ ceiling).
			maxHeight _ maxHeight max: elem boundingBox height.
			position _ position + elem boundingBox width + 5.
			position > (screenBox right - 100) ifTrue:
				[position _ 20.
				ceiling _ ceiling + maxHeight + 10.
				maxHeight _ 0]]! !

!Utilities class methodsFor: 'graphical support' stamp: 'di 4/13/1999 20:22'!
showFormsDictAcrossTopOfScreen: formDict
	"Display the given Dictionary of forms across the top of the screen, wrapping to subsequent lines if needed.  Beneath each, put the name of the associated key."

	"Utilities showFormsDictAcrossTopOfScreen: HaloIcons"

	| position maxHeight screenBox ceiling elem box h labelWidth keyString |

	position _ 20.
	maxHeight _ 0.
	ceiling _ 0.
	screenBox _ Display boundingBox.
	formDict associationsDo:
		[:assoc | (elem _ assoc value) displayAt: (position @ ceiling).
			box _ elem boundingBox.
			h _ box height.
			keyString _ (assoc key isKindOf: String) ifTrue: [assoc key] ifFalse: [assoc key printString].
			keyString displayAt: (position @ (ceiling + h)).
			labelWidth _ TextStyle default defaultFont widthOfString: keyString.
			maxHeight _ maxHeight max: h.
			position _ position + (box width max: labelWidth) + 5.
			position > (screenBox right - 100) ifTrue:
				[position _ 20.
				ceiling _ ceiling + maxHeight + 15.
				maxHeight _ 0]]! !


!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 11/30/1999 16:43'!
actualTextStyles
	| aDict |
	"Utilities actualTextStyles"

	"Answer dictionary whose keys are the names of styles in the system and whose values are the actual styles"

	aDict _ TextConstants select: [:thang | thang isKindOf: TextStyle].
	aDict removeKey: #DefaultTextStyle.
	^ aDict! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/12/1999 17:42'!
browseVersionsForClass: aClass selector: aSelector
	VersionsBrowser
		browseVersionsOf: (aClass compiledMethodAt: aSelector)
		class: aClass
		meta: aClass isMeta
		category: (aClass organization categoryOfElement: aSelector)
		selector: aSelector! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 8/16/97 13:13'!
chooseFileWithSuffix: aSuffix
	"Utilities chooseFileWithSuffix: '.gif'"
	| aList aName |
	aList _ FileDirectory default fileNamesMatching: '*', aSuffix.
	aList size > 0
		ifTrue:
			[aName _ (SelectionMenu selections: aList) startUpWithCaption: 'Choose a file'.
			^ aName]
		ifFalse:
			[self inform: 'Sorry, there are no files
whose names end with "', aSuffix, '".'.
			^ nil]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/5/1998 17:58'!
chooseFileWithSuffixFromList: aSuffixList withCaption: aCaption
	"Pop up a list of all files in the default directory which have a suffix in the list.  Return #none if there are none; return nil if the user backs out of the menu without making a choice."
	"Utilities chooseFileWithSuffixFromList: #('.gif' '.jpg')"
	| aList aName |
	aList _ OrderedCollection new.
	aSuffixList do:
		[:aSuffix | aList addAll: (FileDirectory default fileNamesMatching: '*', aSuffix)].
	^ aList size > 0
		ifTrue:
			[aName _ (SelectionMenu selections: aList) startUpWithCaption: aCaption.
			aName]
		ifFalse:
			[#none]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 9/13/97 20:44'!
classCategoriesStartingWith: aPrefix
	"Answer a list of system class categories beginning with the given prefix"

	"Utilities classCategoriesStartingWith: 'Files'"

	^ SystemOrganization categories select:
		[:aCat | (aCat asString findString:  aPrefix startingAt: 1) = 1]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 1/9/2001 05:34'!
classFromPattern: pattern withCaption: aCaption
	"If there is a class whose name exactly given by pattern, return it.
	If there is only one class in the system whose name matches pattern, return it.
	Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen.
	This method ignores tab, space, & cr characters in the pattern"

	| toMatch potentialClassNames classNames exactMatch index |
	(toMatch _  pattern copyWithoutAll:
			{Character space.  Character cr.  Character tab})
		isEmpty ifTrue: [^ nil].
	Symbol hasInterned: toMatch ifTrue:
		[:patternSymbol | Smalltalk at: patternSymbol ifPresent:
			[:maybeClass | (maybeClass isKindOf: Class) ifTrue: [^ maybeClass]]].

	toMatch _ (toMatch copyWithout: $.) asLowercase.
	potentialClassNames _ Smalltalk classNames asOrderedCollection.
	classNames _ pattern last = $. 
		ifTrue: [potentialClassNames select:
					[:nm |  nm asLowercase = toMatch]]
		ifFalse: [potentialClassNames select: 
					[:n | n includesSubstring: toMatch caseSensitive: false]].
	classNames isEmpty ifTrue: [^ nil].
	exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil].

	index _ classNames size = 1
		ifTrue:	[1]
		ifFalse:	[exactMatch
			ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpWithCaption: aCaption]
			ifNotNil: [classNames addFirst: exactMatch.
				(PopUpMenu labelArray: classNames lines: #(1)) startUpWithCaption: aCaption]].
	index = 0 ifTrue: [^ nil].
	^ Smalltalk at: (classNames at: index) asSymbol

"
	Utilities classFromPattern: 'CharRecog'
	Utilities classFromPattern: 'rRecog'
	Utilities classFromPattern: 'znak'
	Utilities classFromPattern: 'orph'
"
! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'di 10/20/97 20:16'!
fontSizesFor: aName
	| aStyle |
	aStyle _ TextStyle named: aName asSymbol.
	aStyle ifNil: [self halt: 'not found'].
	^ aStyle fontArray collect: [:f | f height]

"Utilities fontSizesFor: 'Palatino'"! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/6/1998 14:09'!
graphicsFileSuffixes
	"Answer a list of filename suffixes which signal file content which we are able to internalize"

	^#('.gif' '.bmp' '.jpg' '.jpeg' '.jpe', '.form')! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 4/30/1998 12:20'!
inviolateInstanceVariableNames
	"Answer a list of instance variable names not to be used.  (Place holder for real list)"
	^ #('thisContext' 'self')! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 4/30/1998 12:20'!
isLegalInstVarName: aString
	"Answer whether aString is a legal instance variable name."

	^ ((Scanner isLiteralSymbol: aString) and: [(aString includes: $:) not]) and:
		[(self inviolateInstanceVariableNames includes:  aString) not]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'di 10/20/97 20:22'!
knownTextStyles   "Utilities knownTextStyles"
	^ (TextConstants select: [:thang | thang isKindOf: TextStyle]) keys asSortedArray

! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'tk 4/21/1998 07:59'!
methodHierarchyBrowserForClass: aClass selector: sel
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."
	| list tab stab aClassNonMeta isMeta theClassOrMeta |

	aClass ifNil: [^ self].
	sel ifNil: [^ self].
	aClassNonMeta _ aClass theNonMetaClass.
	isMeta _ aClassNonMeta ~~ aClass.
	list _ OrderedCollection new.
	tab _ ''.
	aClass allSuperclasses reverseDo:
		[:cl |
		(cl includesSelector: sel) ifTrue:
			[list addLast: tab , cl name, ' ', sel].
		tab _ tab , '  '].
	aClassNonMeta allSubclassesWithLevelDo:
		[:cl :level |
		theClassOrMeta _ isMeta ifTrue: [cl class] ifFalse: [cl].
		(theClassOrMeta includesSelector: sel) ifTrue:
			[stab _ ''.  1 to: level do: [:i | stab _ stab , '  '].
			list addLast: tab , stab , theClassOrMeta name, ' ', sel]]
	 	startingLevel: 0.
	Smalltalk browseMessageList: list
		name: 'Inheritance of ' , sel

"Utilities methodHierarchyBrowserForClass: ParagraphEditor selector: #isControlActive"! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 9/13/97 20:44'!
removeMorphicClassesFromChanges
	| morphicCats |
	morphicCats _ self classCategoriesStartingWith: 'Morphic'.
	morphicCats do:
		[:cat |
		(SystemOrganization superclassOrder: cat)
			do: [:class | class removeFromChanges]].

! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 7/31/97 17:37'!
removeUserClassesFromChanges
	"Remove from the current ChangeSet all user-spawned classes, which are recognized by the fact their names end in digits"

	"Utiliies removeUserClassesFromChanges"

	(Object withAllSubclasses select: [:c | c name endsWithDigit]) do:
		[:aClass | aClass removeFromChanges]! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'tk 4/7/98 14:00'!
spawnHierarchyForClass: aClass selector: aSelector
	"Create and schedule a new class hierarchy browser on the requested class/selector."
	| newBrowser |
	(aClass == nil)  ifTrue: [^ self].
	(newBrowser _ Browser new) setClass: aClass selector: aSelector.
	newBrowser spawnHierarchy.

"Utilities spawnHierarchyForClass: SmallInteger selector: #hash"! !

!Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/6/2000 22:47'!
wellFormedInstanceVariableNameFrom: aString
	"Answer a legal instance variable name, derived from aString"

	| cleansedString |
	cleansedString _ aString select: [:ch | ch isDigit or: [ch isLetter]].
	(cleansedString size == 0 or: [cleansedString first isDigit])
		ifTrue: [cleansedString _ 'a', cleansedString]
		ifFalse:	[cleansedString _ cleansedString withFirstCharacterDownshifted].

	[self isLegalInstVarName: cleansedString] whileFalse:
		[cleansedString _ cleansedString, 'x'].
	^ cleansedString

"Utilities wellFormedInstanceVariableNameFrom:  '234 xx\ Uml /ler42342380-4'"! !


!Utilities class methodsFor: 'durable menus' stamp: 'di 9/22/1998 14:49'!
windowFromMenu: aMenu target: aTarget title: aTitle
	"Supply a default list of colors"
	^ self windowFromMenu: aMenu target: aTarget title: aTitle
		colorPattern: #(lightRed lightGreen lightBlue lightYellow lightGray lightCyan lightMagenta lightOrange)! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 9/22/1998 14:48'!
windowFromMenu: aMenu target: aTarget title: aTitle colorPattern: aColorPattern
	| labelList targetList selectionList i |
	selectionList _ aMenu selections.
	labelList _ (1 to: selectionList size) collect:
		[:ind | aMenu labelString lineNumber: ind].
	targetList _  (1 to: selectionList size) collect: [:ind | aTarget].

	(i _ labelList indexOf: 'keep this menu up') > 0 ifTrue:
		[selectionList _ selectionList copyReplaceFrom: i to: i with: Array new.
		labelList _ labelList copyReplaceFrom: i to: i with: Array new.
		targetList _ targetList copyReplaceFrom: i to: i with: Array new].

	self windowMenuWithLabels:  labelList colorPattern: aColorPattern targets: targetList selections: selectionList title: aTitle! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 11/27/1999 08:23'!
windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList title: aTitle
	| aWorld colorList  pos delta aButton  rightmost widthToUse |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	aWorld _ MVCWiWPasteUpMorph newWorldForProject: nil.
	colorList _  (1 to: labelList size) collect:
		[:ind | Color colorFrom: (colorPattern at: (ind \\ colorPattern size + 1))].
			
	pos _ 4 @ 6.
	delta _ 0 @ 30.
	rightmost _ 0.

	1 to: labelList size do:
		[:index |
			aButton _ SimpleButtonMorph new.
			aButton label: (labelList at: index); 
				color: (colorList at: index); 
				target: (targetList at: index);
				actionSelector: (selectionList at: index);
				position: pos.
			rightmost _ rightmost max: aButton right.
			pos _ pos + delta.
			aWorld addMorphBack: aButton].
	widthToUse _ rightmost + 10.
	aWorld submorphs do:
		[:m | m position: (((widthToUse - m width) // 2) @ m position y)].
	aWorld setProperty: #initialExtent toValue: (widthToUse @ (aButton bottom + 10)).
	aWorld openWithTitle: aTitle cautionOnClose: false! !

!Utilities class methodsFor: 'durable menus' stamp: 'di 11/27/1999 08:24'!
windowMenuWithLabels: labelList colorPattern: colorPattern  targets: targetList selections: selectionList wordingSelectors: wordingList title: aTitle
	| aWorld colorList  pos delta aButton  rightmost widthToUse wordingSelector |
	Smalltalk verifyMorphicAvailability ifFalse: [^ self].
	aWorld _ MVCWiWPasteUpMorph newWorldForProject: nil.
	colorList _  (1 to: labelList size) collect:
		[:ind | Color colorFrom: (colorPattern at: (ind \\ colorPattern size + 1))].
			
	pos _ 4 @ 6.
	delta _ 0 @ 30.
	rightmost _ 0.

	1 to: labelList size do:
		[:index |
			wordingSelector _ wordingList at: index.
			aButton _ wordingSelector
				ifNil:
					[SimpleButtonMorph new]
				ifNotNil:
					[UpdatingSimpleButtonMorph new].
			aButton label: (labelList at: index); 
				color: (colorList at: index); 
				target: (targetList at: index);
				actionSelector: (selectionList at: index);
				position: pos.
			wordingSelector ifNotNil: [aButton wordingSelector: wordingSelector].
			rightmost _ rightmost max: aButton right.
			pos _ pos + delta.
			aWorld addMorphBack: aButton].
	widthToUse _ rightmost + 10.
	aWorld startSteppingSubmorphsOf: aWorld.
	aWorld submorphs do:
		[:m | m position: (((widthToUse - m width) // 2) @ m position y)].
	aWorld setProperty: #initialExtent toValue: (widthToUse @ (aButton bottom + 10)).
	aWorld openWithTitle: aTitle cautionOnClose: false! !


!Utilities class methodsFor: 'vm statistics' stamp: 'RAA 1/26/2001 14:54'!
vmStatisticsReportString
	"StringHolderView open: (StringHolder new contents:
		Utilities vmStatisticsReportString) label: 'VM Statistics'"

	| params oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount mcMisses mcHits icHits upTime sendCount tms tmSize upTime2 fullGCs2 fullGCTime2 incrGCs2 incrGCTime2 tenureCount2 str |
	params _ Smalltalk getVMParameters.
	oldSpaceEnd			_ params at: 1.
	youngSpaceEnd		_ params at: 2.
	memoryEnd			_ params at: 3.
	fullGCs				_ params at: 7.
	fullGCTime			_ params at: 8.
	incrGCs				_ params at: 9.
	incrGCTime			_ params at: 10.
	tenureCount			_ params at: 11.
	mcMisses			_ params at: 15.
	mcHits				_ params at: 16.
	icHits				_ params at: 17.
	upTime _ Time millisecondClockValue.
	sendCount _ mcMisses + mcHits + icHits.
	tms _ TranslatedMethod allSubInstances.
	tmSize _ tms inject: 0 into: [:sum :tm | sum + (tm size * 4)].

	str _ WriteStream on: (String new: 1000).
	str	nextPutAll: 'uptime			';
		print: (upTime / 1000 / 60 // 60); nextPut: $h;
		print: (upTime / 1000 / 60 \\ 60) asInteger; nextPut: $m;
		print: (upTime / 1000 \\ 60) asInteger; nextPut: $s; cr.

	str	nextPutAll: 'memory			';
		nextPutAll: memoryEnd asStringWithCommas; nextPutAll: ' bytes'; cr.
	str	nextPutAll:	'	old			';
		nextPutAll: oldSpaceEnd asStringWithCommas; nextPutAll: ' bytes (';
		print: ((oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	young		';
		nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommas; nextPutAll: ' bytes (';
		print: ((youngSpaceEnd - oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	used		';
		nextPutAll: youngSpaceEnd asStringWithCommas; nextPutAll: ' bytes (';
		print: ((youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
	str	nextPutAll: '	free		';
		nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommas; nextPutAll: ' bytes (';
		print: ((memoryEnd - youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr.

	str	nextPutAll: 'GCs				';
		nextPutAll: (fullGCs + incrGCs) asStringWithCommas.
	fullGCs + incrGCs > 0 ifTrue: [
		str
			nextPutAll: ' ('; 
			print: ((upTime / (fullGCs + incrGCs)) roundTo: 1); 
			nextPutAll: 'ms between GCs)'
	].
	str cr.
	str	nextPutAll: '	full			';
		print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((fullGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	fullGCs = 0 ifFalse:
		[str	nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms'].
	str	cr.
	str	nextPutAll: '	incr		';
		print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms (';
		print: ((incrGCTime / upTime * 100) roundTo: 1.0);
		nextPutAll: '% uptime), avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms'; cr.
	str	nextPutAll: '	tenures		';
		nextPutAll: tenureCount asStringWithCommas.
	tenureCount = 0 ifFalse:
		[str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)'].
	str	cr.

LastStats ifNil: [LastStats _ Array new: 6]
ifNotNil: [
	upTime2 _ upTime - (LastStats at: 1).
	fullGCs2 _ fullGCs - (LastStats at: 2).
	fullGCTime2 _ fullGCTime - (LastStats at: 3).
	incrGCs2 _ incrGCs - (LastStats at: 4).
	incrGCTime2 _ incrGCTime - (LastStats at: 5).
	tenureCount2 _ tenureCount - (LastStats at: 6).

	str	nextPutAll: 'Since last view	';
		nextPutAll: (fullGCs2 + incrGCs2) asStringWithCommas.
	fullGCs2 + incrGCs2 > 0 ifTrue: [
		str
			nextPutAll: ' ('; 
			print: ((upTime2 / (fullGCs2 + incrGCs2)) roundTo: 1); 
			nextPutAll: 'ms between GCs)'.
	].
	str cr.
	str	nextPutAll: '	uptime		'; print: ((upTime2 / 1000.0) roundTo: 0.1); nextPutAll: 's'; cr.
	str	nextPutAll: '	full			';
		print: fullGCs2; nextPutAll: ' totalling '; nextPutAll: fullGCTime2 asStringWithCommas; nextPutAll: 'ms (';
		print: ((fullGCTime2 / upTime2 * 100) roundTo: 1.0);
		nextPutAll: '% uptime)'.
	fullGCs2 = 0 ifFalse:
		[str	nextPutAll: ', avg '; print: ((fullGCTime2 / fullGCs2) roundTo: 1.0); nextPutAll: 'ms'].
	str	cr.
	str	nextPutAll: '	incr		';
		print: incrGCs2; nextPutAll: ' totalling '; nextPutAll: incrGCTime2 asStringWithCommas; nextPutAll: 'ms (';
		print: ((incrGCTime2 / upTime2 * 100) roundTo: 1.0);
		nextPutAll: '% uptime), avg '.
	incrGCs2 > 0 ifTrue: [
		 str print: ((incrGCTime2 / incrGCs2) roundTo: 1.0); nextPutAll: 'ms'
	].
	str cr.
	str	nextPutAll: '	tenures		';
		nextPutAll: tenureCount2 asStringWithCommas.
	tenureCount2 = 0 ifFalse:
		[str nextPutAll: ' (avg '; print: (incrGCs2 / tenureCount2) asInteger; nextPutAll: ' GCs/tenure)'].
	str	cr.
].
	LastStats at: 1 put: upTime.
	LastStats at: 2 put: fullGCs.
	LastStats at: 3 put: fullGCTime.
	LastStats at: 4 put: incrGCs.
	LastStats at: 5 put: incrGCTime.
	LastStats at: 6 put: tenureCount.

	sendCount > 0 ifTrue: [
		str	nextPutAll: 'sends			';
			nextPutAll: sendCount asStringWithCommas; cr.
		str	nextPutAll: '	full			';
			nextPutAll: mcMisses asStringWithCommas;
			nextPutAll: ' ('; print: ((mcMisses / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
		str	nextPutAll: '	m-cache	';
			nextPutAll: mcHits asStringWithCommas;
			nextPutAll: ' ('; print: ((mcHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr.
		str	nextPutAll: '	i-cache		';
			nextPutAll: icHits asStringWithCommas;
			nextPutAll: ' ('; print: ((icHits / sendCount * 100) roundTo: 0.1); nextPutAll: '%)'; cr].

	icHits > 0 ifTrue: [
		str	nextPutAll: 'methods			';
			nextPutAll: tms size asStringWithCommas; nextPutAll: ' translated'; cr.
		str	nextPutAll: '	size			';
			nextPutAll: tmSize asStringWithCommas; nextPutAll: ' bytes, avg ';
			print: ((tmSize / tms size) roundTo: 0.1); nextPutAll: ' bytes/method'; cr.
		str	nextPutAll: '	memory		';
			print: ((tmSize / youngSpaceEnd * 100) roundTo: 0.1); nextPutAll: '% of used, ';
			print: ((tmSize / memoryEnd * 100) roundTo: 0.1); nextPutAll: '% of available'; cr].

	^ str contents
! !

!Utilities class methodsFor: 'vm statistics' stamp: 'di 12/4/2000 12:16'!
vmStatisticsShortString
	"Convenience item for access to recent statistics only"
	"StringHolderView open: (StringHolder new contents: Utilities vmStatisticsShortString)
		label: 'VM Recent Statistics'"

	^ (ReadStream on: self vmStatisticsReportString) upToAll: 'Since'; upTo: Character cr; upToEnd
! !


!Utilities class methodsFor: 'tailoring system' stamp: 'sw 5/7/1998 22:54'!
stripMethods: tripletList messageCode: messageString
	"Used to 'cap' methods that need to be protected for proprietary reasons, etc.; call this with a list of triplets of symbols of the form  (<class name>  <#instance or #class> <selector name>), and with a string to be produced as part of the error msg if any of the methods affected is reached"

	| aClass sel keywords codeString |
	tripletList do:
		[:triplet |  
			(aClass _ (Smalltalk at: triplet first ifAbsent: [nil])) notNil ifTrue:
				[triplet second == #class ifTrue:
					[aClass _ aClass class].
				sel _ triplet third.
				keywords _ sel keywords.
				(keywords size == 1 and: [keywords first asSymbol isKeyword not])
					ifTrue:
						[codeString _ keywords first asString]
					ifFalse:
						[codeString _ ''.
						keywords withIndexDo:
							[:kwd :index |
								codeString _ codeString, ' ', (keywords at: index), ' ',
									'arg', index printString]].
				codeString _ codeString, '
	self codeStrippedOut: ', (messageString surroundedBySingleQuotes).

				aClass compile: codeString classified: 'stripped']]! !


!Utilities class methodsFor: 'fileout' stamp: 'sw 2/15/1999 12:24'!
fileOutChanges
	"File out the current change set to a file whose name is a function of the current date and time."

	Smalltalk changes fileOut.
	Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString
! !


!Utilities class methodsFor: 'flaps' stamp: 'RAA 11/5/2000 09:49'!
addGlobalFlap

	| aMenu reply aFlapTab |

	aMenu _ MVCMenuMorph entitled: 'which edge should it stick to? '.
	aMenu defaultTarget: aMenu.
	#(left right top bottom) do:
		[:sym | aMenu add: sym selector: #selectMVCItem: argument: sym].
	reply _ aMenu invokeAt: self currentHand position in: self currentWorld.
	reply ifNotNil:
		[aFlapTab _ self newFlapTitled: 'Untitled Flap' onEdge: reply.
		self addGlobalFlap: aFlapTab.
	self currentWorld addGlobalFlaps]
	
! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 6/14/1999 15:58'!
addGlobalFlap: aFlapTab
	FlapTabs ifNil: [FlapTabs _ OrderedCollection new].
	FlapTabs add: aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 11/5/2000 09:49'!
addLocalFlap

	| aMenu reply aFlapTab aWorld |

	aMenu _ MVCMenuMorph entitled: 'Where should the new flap cling?'.
	aMenu defaultTarget: aMenu.
	#(left right top bottom) do:
		[:sym | aMenu add: sym selector: #selectMVCItem: argument: sym].
	reply _ aMenu invokeAt: self currentHand position in: self currentWorld.
	reply ifNotNil:
		[aFlapTab _ self newFlapTitled: 'Flap' onEdge: reply.
		(aWorld _ self currentWorld) addMorphFront: aFlapTab.
		aFlapTab adaptToWorld: aWorld]
	
! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 3/6/2000 14:10'!
addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: flapBlock
	"If any global flap satisfies flapBlock, add aMorph to it at the given position."

	| aFlapTab flapPasteUp |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	flapPasteUp addMorph: aMorph asElementNumber: aNumber.
	flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 1/4/2001 09:08'!
addProjectNavigationButtonsTo: aMorph
	"Add prev, next, and go-to buttons at the top of aMorph"

	| aButton aFont |
	aButton _ SimpleButtonMorph new target: Project.
	aButton actionSelector: #returnToPreviousProject.
	aFont _ StrikeFont familyName: #ComicBold size: 24.
	aButton label: '<' font: aFont; borderWidth: 0.
	aButton firstSubmorph color: Color red lighter.
	aButton beTransparent.
	aButton position: 30 @ 12.
	aButton setBalloonText: 'previous project'.
	aMorph addMorph: aButton.

	aButton _ aButton fullCopy.
	aButton actionSelector: #advanceToNextProject.
	aButton label: '>' font: aFont; borderWidth: 0.
	aButton firstSubmorph color: Color red lighter.
	aButton position: 150 @ 14.
	aButton setBalloonText: 'next project'.
	aMorph addMorph: aButton.

	aButton _ aButton fullCopy actWhen: #buttonDown.
	aButton actionSelector: #jumpToProject; target: Project.
	aButton label: 'Go...' font: (StrikeFont familyName: #ComicBold size: 19); borderWidth: 0.
	aButton position: 78 @ 16.
	aButton firstSubmorph color: Color red lighter.
	aButton setBalloonText: 'go directly to a project'.
	aMorph addMorph: aButton! !

!Utilities class methodsFor: 'flaps' stamp: 'tk 1/8/2001 10:41'!
addStackToolsFlap
	"Add a flap with stack tools in it"

	| aFlap aFlapTab aTextMorph aSketch  aMorph |
	"Utilities reinstateDefaultFlaps. Utilities addStackToolsFlap"
	(ScriptingSystem formAtKey: #CedarPic) ifNil:
		[^ self notYetImplemented].

	aFlap _ self newPartsFlapPage beSticky.
	aFlap setProperty: #maximumThumbnailWidth toValue: 80.
	aFlap setProperty: #flap toValue: true.
	aFlap color: (Color green muchLighter lighter alpha: 0.3).

	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab assumeString: 'Stack Tools' font: Preferences standardFlapFont orientation: #horizontal color: Color brown lighter lighter.
	aFlapTab edgeToAdhereTo: #bottom; inboard: false.
	aFlapTab setToPopOutOnDragOver: false.
	aFlapTab setToPopOutOnMouseOver: false.

	aFlap addMorphBack: StackMorph authoringPrototype.

	aTextMorph _ TextMorph authoringPrototype.
	aTextMorph contents: 'background
label' asText.  
	aTextMorph beAllFont: (StrikeFont familyName: #NewYork size: 18).
	aTextMorph color: Color brown.
	aTextMorph setProperty: #shared toValue: true.
	aFlap addMorphBack: aTextMorph.

	"Ted's fields, maybe good point of departure...
	aTextMorph _ TextFieldMorph authoringPrototype.
	aTextMorph setProperty: #shared toValue: true.
	aFlap addMorphBack: aTextMorph."

	aFlap addMorphBack: ScriptableButton authoringPrototype markAsPartsDonor beSticky.

	"NB: Here is where we will put the prototype(s) for background/foreground fields; for the moment, vanilla TextMorphs are used, with the scrolling PTMWM temporarily commented out pending some more work.  A successor to Ted's TextFieldMorph, or some new kind of carefully-thought-through morph that will generally serve the community as the archetypal 'Field', is ultimately needed"

	#(TextMorph "PluggableTextMorphWithModel" TextFieldMorph ) do:
		[:sym |
			aMorph _ (Smalltalk at: sym) authoringPrototype.
			aMorph contents: 'background field' asText allBold.
			aMorph setProperty: #shared toValue: true.
			aMorph setNameTo: (sym == #TextMorph ifTrue: ['field1'] ifFalse: ['scrollingField1']).
			aMorph setProperty: #holdsSeparateDataForEachInstance toValue: true.
			aFlap addMorphBack: aMorph].

	"aFlap addMorphBack: ScriptableListMorph authoringPrototype beSticky -- SOON!!"
	
	#(CedarPic) do:
		[:sym | 
			aSketch _ SketchMorph newSticky form: ((ScriptingSystem formAtKey: sym) ifNil: [ScriptingSystem formAtKey: #squeakyMouse]).
			aSketch setProperty: #shared toValue: true.
			aSketch setProperty: #holdsSeparateDataForEachInstance toValue: true.
			aFlap addMorphBack: aSketch].

	"aCardReference _ CardReference authoringProtoype beSticky.
	aCardReference card: Card new.  "

	aFlap addMorphBack: StackMorph previousCardButton markAsPartsDonor.
	aFlap addMorphBack: StackMorph nextCardButton markAsPartsDonor.

	#( PaintInvokingMorph "ImageMorph  RectangleMorph EllipseMorph StarMorph  CurveMorph PolygonMorph SimpleSliderMorph") do:
		[:sym | aFlap addMorphBack: (Smalltalk at: sym) authoringPrototype].

	aFlap addMorphBack: TrashCanMorph new markAsPartsDonor.
	aFlap addMorphBack: ScriptingSystem scriptControlButtons markAsPartsDonor.

	aFlap replaceTallSubmorphsByThumbnails.

	aFlapTab position: ((2 * (self currentWorld width // 3)) @ (self currentWorld height - aFlapTab height)).

	aFlap setProperty: #flap toValue: true.
	aFlap color: (Color red muchLighter "alpha: 0.2").
	aFlap extent: self currentWorld width @ 100.
	
	self currentWorld addMorphFront: aFlapTab.  
	"a local flap, but we could as easily make it global by:
		self addGlobalFlap: aFlapTab.  self currentWorld addGlobalFlaps"! !

!Utilities class methodsFor: 'flaps' stamp: 'jm 5/26/1999 16:17'!
addSystemStatusLinesTo: aPlayfield
	"Add three lines of system status info beneath the other items on aPlayfield"
	| aString |
	aString _ UpdatingStringMorph new target: Smalltalk.
	aString useStringFormat; color: Color blue; stepTime: 3000; getSelector: #version.
	aString setBalloonText: 'Indicates the official Squeak release code of the current image.'.
	aPlayfield addCenteredAtBottom: aString offset: 8.
	aString left: (aPlayfield left + 6).

	aString _ aString fullCopy getSelector: #lastUpdateString.
	aString setBalloonText: 'Indicates the update number of the last official update present in the image.'.
	aPlayfield addCenteredAtBottom: aString offset: 6.
	aString left: (aPlayfield left + 6).

	aString _ aString fullCopy getSelector: #currentChangeSetString.
	aString setBalloonText: 'Indicates the name of the current change set.'.
	aPlayfield addCenteredAtBottom: aString offset: 6.
	aString left: (aPlayfield left + 6)! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 3/6/2000 14:11'!
addToSuppliesFlap: aMorph asElementNumber: aNumber
	self addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying:
		[:aFlap | aFlap wording = 'Supplies']
	! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/22/1999 16:18'!
bringFlapsToFront
	self currentWorld bringFlapTabsToFront! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/16/1999 18:29'!
clobberFlapTabList
	"Utilities clobberFlapTabList"

	FlapTabs _ nil! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 6/16/2000 09:08'!
currentMenuFlap
        "answer the global menu flap or nil."

        ^self globalFlapTabsIfAny detect: [:aTab | 
                (aTab submorphs size > 0) and:  [(aTab submorphs first isKindOf: TextMorph) and: 
                [(aTab submorphs first contents string copyWithout: $ ) = 'Menus']]
        ] ifNone: [nil]
! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 10/18/2000 18:45'!
deleteMorphsSatisfying: deleteBlock fromGlobalFlapSatisfying: flapBlock
	"If any global flap satisfies flapBlock, Then delete objects satisfying from deleteBlock from it"

	| aFlapTab flapPasteUp |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	flapPasteUp submorphs do:
		[:aMorph | (deleteBlock value: aMorph) ifTrue: [aMorph delete]]! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 6/20/1999 22:56'!
explainFlaps
	"Open a window giving flap  help."
	"Utilities explainFlaps"
	| aString |
	aString _ 
'Flaps are like drawers on the edge of the screen, which can be opened so that you can use what is inside them, and closed when you do not need them.  They have many possible uses, a few of which are illustrated by the default set of flaps you can get as described below.

"Global flaps" are available in every morphic project.  As you move from project to project, you will see the same flaps in each.   To get started using global flaps, set the "useGlobalFlaps" Preference to true, or choose "start using global flaps" from the windows/flaps menu.

"Project flaps" are flaps that belong to a single morphic project.

If a flap is set up as a parts bin (such as the default Tools and Supplies flaps), you can use it to create new objects -- just mouse-over the tab so that the flap will open up, then find the object you want, and drag it; when the cursor leaves the flap, the flap itself will disappear, and you''ll be left holding the new object -- just click to place it exactly where you want it.

If a flap is *not* set up as a parts bin (such as the default "Squeak" flap at the left edge of the screen) you can park objects there (this is an easy way to move objects from project to project) and you can place your own private controls there, etc.  Everything in the default "Squeak" flap (and all the other default flaps, for that matter) is there only for illustrative purposes -- every user will want to fine-tune the flaps to suit his/her own style and needs.

Each flap may be set up to appear on mouseover, dragover, both, or neither.  See the menu items described below for more about these and other options.

You can open a closed flap by clicking on its tab, or by dragging the tab toward the center of the screen

You can close an open flap by clicking on its tab or by dragging the tab back off the edge of the screen.

Drag the tab of a flap to reposition the tab and to resize the flap itself.  Repositioning starts when you drag the cursor out of the original tab area.

If flaps or their tabs seem wrongly positioned or lost, try issuing a restoreDisplay from the screen menu.

The red-halo menu on a flap gives you access to the "flap..." submenu which allows you to change its properties.   For greatest ease of use, request "keep this menu up" here -- that way, you can easily explore all the options in the menu.

tab color...				Lets you change the color of the flap''s tab.
flap color...				Lets you change the color of the flap itself.

use textual tab...		If the tab is not textual, makes it become textual.
change tab wording...	If the tab is already textual, allows you to edit
							its wording.

use graphical tab...		If the tab is not graphical, makes it become
							graphical.
choose tab graphic...	If the tab is already graphical, allows you
							to change the picture.

use solid tab...			If the tab is not solid, makes it become solid, i.e.
							appear as a solid band of color along the
							entire length or width of the screen.

parts-bin behavior		If set, then dragging an object from the flap
							tears off a new copy of the object.

dragover				If set, the flap opens on dragover and closes
							again on drag-leave.

mouseover				If set, the flap opens on mouseover and closes
							again on mouse-leave. 

cling to edge...			Governs which edge (left, right, top, bottom)
							the flap adheres to.

destroy this flap		Deletes the flap.

To define a new flap, use "new global flap..." or "new project flap...", found in the "windows and flaps" menu.

To reinstate the default system flaps, evaluate "Utilities reinstateDefaultFlaps"  (caveat -- this will first remove all existing flaps, including any that you may have manually added or edited.)

If flaps that you wish to use appear to be buried behind other objects on your screen, simply clicking on the desktop background will bring all flap tabs to the front.

To add, delete, or edit things on a given flap, it is often wise first to suspend the flap''s mouse-over and drag-over sensitivity, so it won''t keep disappearing on you while you''re trying to work with it.

The "Menu" flap provided in the default flap-set provides a service that will be valuable to some (it gives a sense of place to many standard menu item, and allows you to avoid navigating through submenus) and dismaying to others (who should destroy the flap immediately -- do this by bringing up the red-halo menu for the "Menu" tab, and then choosing "destroy this flap").

'.
	
  

	(StringHolder new contents: aString)
		openLabel: 'Flaps in Morphic'

	! !

!Utilities class methodsFor: 'flaps' stamp: 'tk 9/25/2000 10:57'!
globalFlapTab: aName
	| nn |
	"Find a global flap tab by name.  May be either 'flap: Tools' or 'Tools'. "

	nn _ (aName beginsWith: 'flap: ') ifTrue: [aName] ifFalse: ['flap: ', aName].
	^ self globalFlapTabsIfAny detect: [:ft | ft flapMenuTitle = nn] ifNone: [nil]! !

!Utilities class methodsFor: 'flaps' stamp: 'tk 10/6/2000 13:07'!
globalFlapTabOrDummy: aName
	| gg |
	"Find a global flap tab by name.  May be either 'flap: Tools' or 'Tools'.  Be sure to supply a "

	(gg _ self globalFlapTab: aName) ifNil: [
		^ StringMorph contents: aName, ' can''t be found'].
	^ gg! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/26/1999 14:43'!
globalFlapTabs
	FlapTabs ifNil: [self initializeStandardFlaps].
	^ FlapTabs! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 3/25/1999 11:46'!
globalFlapTabsIfAny
	"Answer a list of the global flap tabs, but it they don't exist, just answer an empty list"
	^ FlapTabs copy ifNil: [Array new]! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 5/20/2000 00:51'!
initializeStandardFlaps
	"Utilities initializeStandardFlaps"
	FlapTabs _ OrderedCollection new.
	FlapTabs add: (self standardLeftFlap setToPopOutOnDragOver: false).
	FlapTabs add: self standardBottomFlap.
	FlapTabs add: self standardRightFlap.
	FlapTabs add: (self menuFlap setToPopOutOnDragOver: false).
	FlapTabs do:
		[:aFlapTab | 
			aFlapTab setToPopOutOnMouseOver: false].

	^ FlapTabs! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 12/16/2000 11:20'!
menuFlap
	| aFlap aFlapTab aHolder verticalHolder aMenu |
	aFlap _ PasteUpMorph newSticky color: Color transparent; extent: self currentWorld width @ 264; borderWidth: 0; padding: 0.

	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab color: Color brown lighter.
	aFlapTab assumeString: 'Menus' font: Preferences standardFlapFont orientation: #horizontal color: Color blue muchLighter.
	aFlapTab setToPopOutOnMouseOver: true.
	aFlapTab edgeToAdhereTo: #top; inboard: false.

	aFlapTab position: ((Display width - aFlapTab width) // 2) @ 0.
	aFlap beFlap: true.
	aFlap color: (Color blue muchLighter alpha: 0.6).
	aFlap extent: self currentWorld width @ 267.
	aHolder _ AlignmentMorph newRow beSticky beTransparent hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft.

	#(openMenu helpMenu windowsMenu (changesMenu debugMenu ) (playfieldMenu scriptingMenu )) do:
		[:elem |
			(elem isKindOf: Array)
				ifTrue:
					[verticalHolder _ AlignmentMorph newColumn beSticky beTransparent.
					verticalHolder hResizing: #shrinkWrap; layoutInset: 0; wrapCentering: #center; cellPositioning: #topCenter.
					elem do:
						[:aMenuSymbol |
							verticalHolder addMorphBack: ((aMenu _ self currentWorld getWorldMenu: aMenuSymbol) beSticky; stayUp: true).
							aMenu beSticky.
							aMenu borderWidth: 1.
							aMenu submorphs second delete].
					aHolder addMorphBack: verticalHolder]
				ifFalse:
					[aHolder addMorphBack: ((aMenu _ self currentWorld getWorldMenu: elem) beSticky; stayUp: true).
					aMenu submorphs second delete.
					aMenu beSticky.
					aMenu borderWidth: 1]].

	aFlap addMorphBack: aHolder.

	^ aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 10/2/2000 17:01'!
newFlapTitled: aString onEdge: anEdge

	^self newFlapTitled: aString onEdge: anEdge inPasteUp: self currentWorld
! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 10/2/2000 17:37'!
newFlapTitled: aString onEdge: anEdge inPasteUp: aPasteUpMorph
	| aFlap aFlapTab  orientation |

	aFlap _ PasteUpMorph newSticky.
	aFlapTab _ FlapTab new referent: aFlap.
	orientation _ (#(left right) includes: anEdge)
		ifTrue:	[#vertical]
		ifFalse:	[#horizontal].
	aFlapTab 
		assumeString: aString 
		font: Preferences standardFlapFont 
		orientation: orientation 
		color: Color veryLightGray.
	aFlapTab edgeToAdhereTo: anEdge; inboard: false.

	anEdge == #left ifTrue:
		[aFlapTab position: (aPasteUpMorph left @ aPasteUpMorph top).
		aFlap extent: (200 @ aPasteUpMorph height)].
	anEdge == #right ifTrue:
		[aFlapTab position: ((aPasteUpMorph right - aFlapTab width) @ aPasteUpMorph top).
		aFlap extent: (200 @ aPasteUpMorph height)].
	anEdge == #top ifTrue:
		[aFlapTab position: ((aPasteUpMorph left + 50) @ aPasteUpMorph top).
		aFlap extent: (aPasteUpMorph width @ 200)].
	anEdge == #bottom ifTrue:
		[aFlapTab position: ((aPasteUpMorph left + 50) @ (aPasteUpMorph bottom - aFlapTab height)).
		aFlap extent: (aPasteUpMorph width @ 200)].

	aFlap beFlap: true.
	aFlap color: (Color veryLightGray muchLighter).

	^ aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 10/11/1999 13:17'!
newPartsFlapPage
	| aPage |
	aPage _ PasteUpMorph new borderWidth: 0.
	aPage color: Color white; padding: 6.
	aPage autoLineLayout: true.
	aPage isPartsBin: true.
	aPage setProperty: #alwaysShowThumbnail toValue: true.
	^ aPage! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 11/6/2000 13:58'!
offerGlobalFlapsMenu
	"Put up a menu that lets the user control which global flaps are to be shown in this project"

	| aMenu anItem |
	aMenu _ MenuMorph new defaultTarget: Project current.
	aMenu addTitle: 'Global flaps to
show in this project'.
	aMenu addStayUpItem.
	Utilities globalFlapTabs do:
		[:aFlapTab |
			anItem _ aMenu addUpdating: #globalFlapEnabledString: enablementSelector: nil target: Project current selector: #enableDisableGlobalFlap: argumentList: (Array with: aFlapTab).
			anItem wordingArgument: aFlapTab].
	aMenu popUpForHand: self currentHand in: self currentWorld! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/22/1999 17:02'!
orientationForEdge: anEdge
	^ (#(left right) includes: anEdge)
		ifTrue:	[#vertical]
		ifFalse:	[#horizontal]! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/26/1999 15:47'!
reinstateDefaultFlaps
	"Utilities reinstateDefaultFlaps"
	self currentWorld deleteAllFlapArtifacts.
	self clobberFlapTabList.
	self initializeStandardFlaps.
	self currentWorld addGlobalFlaps.
! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 11/6/2000 14:24'!
removeFlapTab: aFlapTab keepInList: aBoolean
	"Remove the given flap tab from the screen, and, if aBoolean is true, also from the global list"

	(FlapTabs ~~ nil and: [FlapTabs includes: aFlapTab])
		ifTrue:
			[aBoolean ifFalse: [self removeFromGlobalFlapTabList: aFlapTab].
			aFlapTab referent delete.
			aFlapTab delete]! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 11/6/2000 14:23'!
removeFromGlobalFlapTabList: aFlapTab
	"If the flap tab is in the global list, remove it"

	FlapTabs remove: aFlapTab ifAbsent: []! !

!Utilities class methodsFor: 'flaps' stamp: 'ar 1/31/2001 17:06'!
replaceBrowserInToolsFlap
	self replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isMemberOf: Browser]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  ((Browser new openAsMorphEditing: nil) applyModelExtent setLabel: 'System Browser').

	self replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isMemberOf: PackagePaneBrowser]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  ((PackagePaneBrowser new openAsMorphEditing: nil) applyModelExtent setLabel: 'Package Browser')

! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 9/1/2000 06:11'!
replaceChangeSortersInToolsFlap
	"Get prototypes of the latest versions of the the Change Sorters into the Tools flap"

	self replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isMemberOf: ChangeSorter]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  (ChangeSorter new morphicWindow applyModelExtent).

	self replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isMemberOf: DualChangeSorter]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  (DualChangeSorter new morphicWindow applyModelExtent)
! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 6/16/2000 09:08'!
replaceMenuFlap
        "if there is a global menu flap, replace it with an updated one."

        | aFlapTab |
        aFlapTab _ self currentMenuFlap ifNil: [^ self].
        self removeFlapTab: aFlapTab keepInList: false.
        self addGlobalFlap: self menuFlap.
        Smalltalk isMorphic ifTrue: [Display bestGuessOfCurrentWorld addGlobalFlaps]

"Utilities replaceMenuFlap"! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 5/3/1999 22:44'!
replacePartSatisfying: elementBlock inGlobalFlapSatisfying: flapBlock with: replacement
	"If any global flap satisfies flapBlock, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc."

	| aFlapTab flapPasteUp anElement |
	aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self].
	flapPasteUp _ aFlapTab referent.
	anElement _ flapPasteUp submorphs detect: [:aMorph | elementBlock value: aMorph] ifNone: [^ self].
	flapPasteUp replaceSubmorph: anElement by: replacement.
	flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true.

"Utilities replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented label = 'scripting area']]]
inGlobalFlapSatisfying: [:fl | (fl submorphs size > 0) and:  [(fl submorphs first isKindOf: TextMorph) and: [(fl submorphs first contents string copyWithout: Character cr) = 'Tools']]] with: ScriptingSystem newScriptingSpace"! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 3/8/2000 12:59'!
replaceScriptingAreaInToolsFlap
	"Utilities replaceScriptingAreaInToolsFlap"
	self replacePartSatisfying: [:el |  (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented model isKindOf: ScriptingDomain]]]
inGlobalFlapSatisfying: [:f1 | f1 wording = 'Tools'] with:  ScriptingSystem newScriptingSpace! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 7/13/1999 15:47'!
replaceToolsFlap
	"if there is a global tools flap, replace it with an updated one."

	| aFlapTab |
	aFlapTab _ self globalFlapTabsIfAny detect:
		[:aTab | (aTab submorphs size > 0) and:  [(aTab submorphs first isKindOf: TextMorph) and: [(aTab submorphs first contents string copyWithout: Character cr) = 'Tools']]] ifNone: [^ self].
	self removeFlapTab: aFlapTab keepInList: false.
	self addGlobalFlap: self standardRightFlap.
	self currentWorld ifNotNil: [self currentWorld addGlobalFlaps]

"Utilities replaceToolsFlap"! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 6/14/1999 09:56'!
showingGlobalFlapsString
	^ Preferences valueOfFlag: #useGlobalFlaps.! !

!Utilities class methodsFor: 'flaps' stamp: 'ar 11/8/2000 22:38'!
standardBottomFlap
	"Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen"

	|  aFlapTab aPage |
	aPage _ self newPartsFlapPage.
	aPage setProperty: #maximumThumbnailWidth toValue: 80.
	aFlapTab _ FlapTab new referent: aPage beSticky.
	aFlapTab color: Color red lighter.
	aFlapTab setToPopOutOnDragOver: true.
	aFlapTab setToPopOutOnMouseOver: true.
	aFlapTab assumeString: 'Supplies' font: Preferences standardFlapFont orientation: #horizontal color: Color red lighter.
	aFlapTab edgeToAdhereTo: #bottom; inboard: false.

	aPage extent: self currentWorld width @ 100.

	aPage addMorphBack: Command undoRedoButtons markAsPartsDonor.
	aPage addMorphBack: TrashCanMorph new markAsPartsDonor.
	aPage addMorphBack: ScriptingSystem scriptControlButtons markAsPartsDonor.

	#(PaintInvokingMorph RectangleMorph EllipseMorph StarMorph  CurveMorph PolygonMorph TextMorph ) do:
		[:sym | aPage addMorphBack: (Smalltalk at: sym) authoringPrototype].

	aPage addMorphBack: ScriptingSystem prototypicalHolder.
	aPage addMorphBack: RectangleMorph roundRectPrototype.

	#(ImageMorph ScriptableButton SimpleSliderMorph
		PasteUpMorph   BookMorph TabbedPalette 
		JoystickMorph  ) do:
		[:sym | aPage addMorphBack: (Smalltalk at: sym) authoringPrototype].

	aPage addMorphBack: Morph new previousPageButton markAsPartsDonor.
	aPage addMorphBack: Morph new nextPageButton markAsPartsDonor.
	aPage addMorphBack: ScriptingSystem holderWithAlphabet markAsPartsDonor.
	aPage addMorphBack: (ClockMorph authoringPrototype showSeconds: false) step.

	aPage replaceTallSubmorphsByThumbnails.

	aFlapTab position: ((Display width - aFlapTab width) // 2 @ (self currentWorld height - aFlapTab height)).
	aPage beFlap: true.
	aPage color: (Color red muchLighter "alpha: 0.2").
	aPage extent: self currentWorld width @ 100.
	
	^ aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'ar 9/28/2000 14:01'!
standardLeftFlap
	| aFlap aFlapTab aButton aClock buttonColor anOffset |

	aFlap _ PasteUpMorph newSticky borderWidth: 0.
	aFlapTab _ FlapTab new referent: aFlap.
	aFlapTab assumeString: 'Squeak' font: Preferences standardFlapFont orientation: #vertical color: Color brown lighter lighter.
	aFlapTab edgeToAdhereTo: #left; inboard: false.
	aFlapTab setToPopOutOnDragOver: true.
	aFlapTab setToPopOutOnMouseOver: true.

	aFlapTab position: (0 @ ((Display height - aFlapTab height) // 2)).
	aFlap beFlap: true.
	aFlap color: (Color brown muchLighter lighter "alpha: 0.3").
	aFlap extent: 200 @ self currentWorld height.

	self addProjectNavigationButtonsTo: aFlap.
	anOffset _ 16.

	buttonColor _ Color green muchLighter.
	aButton _ SimpleButtonMorph new target: Smalltalk.
	aButton color: buttonColor.
	aButton actionSelector: #saveSession.
	aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.'.
	aButton label: 'snapshot'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ aButton fullCopy target: Utilities.
	aButton actionSelector: #fileOutChanges.
	aButton label: 'file out changes'.
	aButton setBalloonText: 'File out the current change set to disk.'.
	aFlap addMorph: aButton.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ aButton fullCopy target: Utilities.
	aButton actionSelector: #browseRecentSubmissions.
	aButton setBalloonText: 'Open a message-list browser showing the 20 most-recently-submitted methods.'.
	aButton label: 'recent submissions'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aClock _ ClockMorph newSticky.
	aClock color: Color red.
	aClock showSeconds: false.
	aClock font: (TextStyle default fontAt: 3).
	aClock step.
	aClock setBalloonText: 'The time of day.  If you prefer to see seconds, check out my menu.'.
	aFlap addCenteredAtBottom: aClock offset: anOffset.

	aButton _ aButton fullCopy target: Preferences.
	aButton actionSelector: #openPreferencesInspector.
	aButton setBalloonText: 'Open a window allowing me to view and change various Preferences.'.
	aButton label: 'preferences...'.
	aButton color: Color cyan muchLighter.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ aButton fullCopy target: Utilities.
	aButton actionSelector: #updateFromServer.
	aButton label: 'load code updates'.
	aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	self addSystemStatusLinesTo: aFlap.

	aButton _ SimpleButtonMorph new target: self.
	aButton actionSelector: #explainFlaps; color: buttonColor.
	aButton label: 'About flaps...'.
	aButton setBalloonText: 'Click here to get a window of information about flaps.'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ aButton fullCopy target: Preferences; actionSelector: #editAnnotations;
		label: 'Annotations...'.
	aButton setBalloonText: 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation pane of method-list browsers.'.
	aFlap addCenteredAtBottom: aButton offset: anOffset.

	aButton _ TrashCanMorph newSticky.
	aFlap addCenteredAtBottom: aButton offset: anOffset.
	aButton startStepping.

	^ aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 1/4/2001 09:18'!
standardRightFlap
	"Answer a newly-created flap which adheres to the right edge of the screen and which holds prototypes of standard tools"

	|  aFlapTab aPage |
	aPage _ self newPartsFlapPage.
	aFlapTab _ FlapTab new referent: aPage beSticky.
	aFlapTab color: Color red lighter.
	aFlapTab assumeString: 'Tools' font: Preferences standardFlapFont orientation: #vertical color: Color orange lighter.
	aFlapTab edgeToAdhereTo: #right; inboard: false.
	aFlapTab setToPopOutOnDragOver: true.
	aFlapTab setToPopOutOnMouseOver: true.

	aPage extent: (90 @ self currentWorld height).
	self addSampleWindowsTo: aPage.
	aPage addMorphBack: ScriptingSystem newScriptingSpace.
	aPage addMorphBack: RecordingControlsMorph authoringPrototype.
	aPage replaceTallSubmorphsByThumbnails.

  "This hard-coded list is regrettable but expedient"
	#('System Browser' 'Package Browser' 'Workspace' 'File List' 'Dual Change Sorter' 'Single Change Sorter' 'Selector Browser' 'Assembly Area' 'Scripting Area' 'Sound Recorder') doWithIndex: 
		[:help :index |
			(aPage submorphs at: index) setBalloonText: help].

	aFlapTab position: (self currentWorld width - aFlapTab width) @ ((Display height - aFlapTab height) // 2).
	aPage beFlap: true.
	aPage color: (Color brown muchLighter alpha: 0.5).
	aPage extent: (90 @ self currentWorld height).
	
	^ aFlapTab! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 9/21/2000 22:52'!
suppressFlapsString
	"Answer the string to be shown in a menu to represent the suppress-flaps-in-this-project status"

	^ (CurrentProjectRefactoring currentFlapsSuppressed)
		ifFalse: ['<yes>show flaps']
		ifTrue: ['<no>show flaps']
! !

!Utilities class methodsFor: 'flaps' stamp: 'RAA 6/3/2000 10:57'!
toggleFlapSuppressionInProject
	Preferences useGlobalFlaps ifFalse:
		[^ self inform: 
'CAUTION!!  Global flaps are currently 
disabled, and must be reenabled for 
this option to be meaningful.'].

	CurrentProjectRefactoring currentToggleFlapsSuppressed.
	Display restoreMorphicDisplay.! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 2/26/1999 15:49'!
toggleWhetherToShowFlaps
	Preferences setPreference: #useGlobalFlaps toValue: Preferences useGlobalFlaps not! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 6/14/1999 09:56'!
toggleWhetherToUseGlobalFlaps
	Preferences setPreference: #useGlobalFlaps toValue: Preferences useGlobalFlaps not! !

!Utilities class methodsFor: 'flaps' stamp: 'ar 10/5/2000 19:09'!
updateMenuFlap
        | aFlap selectors newMenu newMenuTitle oldMenu |

        aFlap _ (self currentMenuFlap ifNil: [^self]) referent.
        selectors _ #(openMenu helpMenu windowsMenu changesMenu 
                debugMenu playfieldMenu scriptingMenu ).
        selectors do: [:menuSelector |
                (newMenu _ self currentWorld getWorldMenu: menuSelector)
                        beSticky;
                        stayUp: true.
                newMenu submorphs second delete.        "remove the stay up item"
                newMenu borderWidth: 1.

                (newMenuTitle _ newMenu titleGuesstimate) ifNotNil: [
                        oldMenu _ aFlap 
                                findDeepSubmorphThat: [ :each |
                                        (each isKindOf: MenuMorph) and: 
                                                [each titleGuesstimate = newMenuTitle]
                                ] 
                                ifAbsent: [nil].
                        oldMenu ifNotNil: [
                                oldMenu owner
                                        replaceSubmorph: oldMenu 
                                        by: newMenu.
                        ].
                ].
        ].
        ^ aFlap! !

!Utilities class methodsFor: 'flaps' stamp: 'sw 9/21/2000 22:52'!
useGlobalFlapsString
	"Answer the string to be shown in a menu to represent the use-global-flaps status"

	^ (Preferences valueOfFlag: #useGlobalFlaps)
			ifTrue: ['<yes>use global flaps']
			ifFalse: ['<no>use global flaps']! !


!Utilities class methodsFor: 'scraps' stamp: 'sw 8/18/1999 19:56'!
addToTrash: aMorph
	"Paste the object onto a page of the system Trash book, unless the preference is set to empty the trash immediately."

	| aBook aPage |
	Preferences preserveTrash ifFalse: [^ self].

	aBook _ self scrapsBook.
	aMorph position: aBook pages first position + (0@40).
	aBook pages do: [:pp | 
		(pp submorphs size = 1 and: [pp hasProperty: #trash]) ifTrue:  "perhaps remove that property here"
			["page is blank"
			^ pp addMorph: aMorph]].
	aPage _ aBook insertPageLabel: Time dateAndTimeNow printString
		morphs: (Array with: aMorph).
	aPage setProperty: #trash toValue: true! !

!Utilities class methodsFor: 'scraps' stamp: 'sw 10/21/1999 17:42'!
emptyScrapsBook
	"Utilities emptyScrapsBook"
	| oldScraps |
	oldScraps _ ScrapsBook.
	ScrapsBook _ nil.
	self scrapsBook.  "Creates it afresh"
	(oldScraps notNil and: [oldScraps owner notNil])
		ifTrue:
			[ScrapsBook position: oldScraps position.
			oldScraps owner replaceSubmorph: oldScraps by: ScrapsBook.
			ScrapsBook changed; layoutChanged]! !

!Utilities class methodsFor: 'scraps' stamp: 'sw 3/23/1999 09:18'!
maybeEmptyTrash
	(self confirm: 'Do you really want to empty the trash?')
		ifTrue: [self emptyScrapsBook]! !

!Utilities class methodsFor: 'scraps' stamp: 'ar 11/9/2000 21:24'!
scrapsBook
	| header aButton label |
	ScrapsBook ifNil:
		[ScrapsBook _ BookMorph new pageSize: 200@300; setNameTo: 'scraps'.
		ScrapsBook color: Color yellow muchLighter.
		ScrapsBook borderColor: Color darkGray; borderWidth: 2.
		ScrapsBook removeEverything; showPageControls; insertPage.
		header _ AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter.
		header setProperty: #header toValue: true.
		header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: Preferences standardButtonFont).
		aButton target: ScrapsBook; color:  Color tan; actionSelector: #delete;
				setBalloonText: 'Close the trashcan.
(to view again later, click on any trashcan).'.

		header addMorphBack: AlignmentMorph newVariableTransparentSpacer beSticky.
		header addMorphBack: 	(label _ UpdatingStringMorph new target: self) beSticky.
		label getSelector: #trashTitle; useStringFormat; step.
		header addMorphBack: AlignmentMorph newVariableTransparentSpacer beSticky.
		header addMorphBack: (aButton _ SimpleButtonMorph new label: 'E' font: Preferences standardButtonFont).
		aButton target: Utilities; color:  Color veryLightGray; actionSelector: #maybeEmptyTrash;
				setBalloonText: 'Click here to empty the trash.'.
		ScrapsBook currentPage addMorph: (TextMorph new contents: 'Objects you drag into the trash will automatically be saved here, one object per page, in case you need them later.  To disable this feature set the "preserveTrash" Preference to false.

You can individually expunge objects by hitting the - control, and you can empty out all the objects in the trash can by hitting the "E" button at top right.'
			wrappedTo: 190).

		ScrapsBook addMorphFront: header.
		ScrapsBook setProperty: #scraps toValue: true].
	^ ScrapsBook

	"Utilities emptyScrapsBook"
! !

!Utilities class methodsFor: 'scraps' stamp: 'sw 3/7/1999 02:23'!
scrapsBook: aBook
	"Utilities scrapsBook: nil"
	ScrapsBook _ nil! !

!Utilities class methodsFor: 'scraps' stamp: 'sw 3/23/1999 12:23'!
trashTitle
	| label pgs |
	label _ 'T R A S H'.
	^ (pgs _ ScrapsBook pages size) < 2
		ifTrue:
			[label]
		ifFalse:
			[label, '  (', pgs printString, ' pages)']! !


!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/19/2000 11:24'!
fontArrayForStyle: aName
	^ ((TextStyle named: aName asSymbol) ifNil: [self error: 'text style not found']) fontArray

"Utilities fontArrayForStyle: 'Palatino'"
"Utilities fontPointSizesFor: 'Elmo'"! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/18/2000 21:35'!
fontMenuForStyle: styleName target: target selector: selector
 	| aMenu |
	aMenu _ MenuMorph entitled: styleName.
 	(Utilities pointSizesFor: styleName) do:
		[:aWidth |
			aMenu 
				add: (aWidth asString, ' Point') 
				target: target 
				selector: selector
				argument: ((TextStyle named: styleName) fontOfPointSize: aWidth).
                aMenu lastItem font: ((TextStyle named: styleName) fontOfPointSize: aWidth)].
        ^ aMenu! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/19/2000 11:26'!
fontPointSizesFor: aName
	^ (self fontArrayForStyle: aName) collect: [:f | f pointSize]

"Utilities fontPointSizesFor: 'Palatino'"
"Utilities fontPointSizesFor: 'Elmo'"! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/18/2000 21:37'!
fontSizeSummary
	"Utilities fontSizeSummary"
	| aString aList |
	aList _ Utilities knownTextStyles.
	aString _ String streamContents:
		[:aStream |
			aList do: [:aStyleName |
				aStream nextPutAll:
					aStyleName, '  ',
					(Utilities fontPointSizesFor: aStyleName) asArray storeString.
				aStream cr]].
	(StringHolder new contents: aString)
		openLabel: 'Font styles and sizes'! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/19/2000 11:30'!
fontWidthsFor: aName
	^ (self fontArrayForStyle: aName) collect: [:f | f maxWidth]

"Utilities fontWidthsFor: 'ComicPlain'"! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/19/2000 11:13'!
mvcPromptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
        | aMenu aChoice aStyle namesAndSizes aFont |
	"Utilities mvcPromptForFont: 'Choose system font style' andSendTo: Utilities withSelector: #setSystemFontTo:"
	aMenu _ CustomMenu new.
	Utilities actualTextStyles keys do:
		[:styleName |
			aMenu add: styleName action: styleName].
	aChoice _ aMenu startUpWithCaption: aPrompt.
	aChoice ifNil: [^ self].
	aMenu _ CustomMenu new.
	aStyle _ TextStyle named: aChoice.
	(namesAndSizes _ aStyle fontNamesWithPointSizes) do:
		[:aString | aMenu add: aString action: aString].
	aChoice _ aMenu startUpWithCaption: nil.
	aChoice ifNil: [^ self].
	aFont _ aStyle fontAt: (namesAndSizes indexOf: aChoice).
	aTarget perform: aSelector with: aFont! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'sw 1/19/2000 11:31'!
pointSizesFor: aName
	^ (self fontArrayForStyle: aName) collect: [:f | f pointSize]

"Utilities pointSizesFor: 'Palatino'"! !

!Utilities class methodsFor: 'text styles and fonts' stamp: 'ar 10/5/2000 19:32'!
promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
        "Utilities promptForFont: 'Choose system font:' andSendTo: Utilities withSelector: #setSystemFontTo:"
        "NOTE: Morphic ONLY!!!!.  Derived from a method written by Robin Gibson"

        | menu subMenu |
        menu _ MenuMorph entitled: aPrompt.
        Utilities actualTextStyles keys do: [:styleName|
                subMenu _ self fontMenuForStyle: styleName target: aTarget selector: aSelector.
                menu add: styleName subMenu: subMenu.
                menu lastItem font: ((TextStyle named: styleName) fontOfSize: 18)].

        menu popUpInWorld: self currentWorld! !
Object subclass: #UtteranceVisitor
	instanceVariableNames: 'clause phrase word syllable '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 18:53'!
clause: aClause
	clause _ aClause.
	clause phrases do: [ :each | each accept: self].
	phrase _ word _ syllable _ nil! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 18:53'!
phrase: aPhrase
	phrase _ aPhrase.
	phrase words do: [ :each | each accept: self].
	word _ syllable _ nil! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/10/1999 02:46'!
speaker: aSpeaker
	^ self! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 16:36'!
syllable: aSyllable
	syllable _ aSyllable! !

!UtteranceVisitor methodsFor: 'visiting' stamp: 'len 12/8/1999 18:53'!
word: aWord
	word _ aWord.
	word syllables do: [ :each | each accept: self].
	syllable _ nil! !
Object subclass: #VRMLBaseNode
	instanceVariableNames: 'myEvents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLBaseNode methodsFor: 'initialize' stamp: 'ar 3/13/98 01:26'!
fromSpec: aNodeSpec! !


!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 19:06'!
attributeValueNamed: aString
	"Return the value of the given attribute string as defined in the receiver.
	Note: When switching to a full class representation for VRML objects we can
	get rid of this and use actual accessors."
	| attr |
	attr _ (self attributeNamed: aString) ifNil:[^nil].
	^self getAttributeValue: attr! !

!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 3/13/98 13:45'!
children
	^nil! !

!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 8/18/1999 09:18'!
inEventNamed: aString
	| spec inAttr |
	spec _ self nodeSpec.
	inAttr _ spec attributeNamed: aString.
	inAttr == nil ifFalse:[
		(inAttr attrClass = 'exposedField' or:[inAttr attrClass = 'eventIn'])
			ifFalse:[inAttr _ nil]].
	(inAttr == nil and:[aString beginsWith:'set_']) ifTrue:[
		inAttr _ spec attributeNamed: (aString copyFrom: 5 to: aString size)].
	inAttr == nil ifFalse:[
		(inAttr attrClass = 'exposedField' or:[inAttr attrClass = 'eventIn'])
			ifFalse:[inAttr _ nil]].
	^inAttr! !

!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 3/13/98 13:39'!
name
	^self nodeSpec name! !

!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:26'!
nodeSpec
	^self subclassResponsibility! !

!VRMLBaseNode methodsFor: 'accessing' stamp: 'ar 8/18/1999 09:18'!
outEventNamed: aString
	| spec outAttr |
	spec _ self nodeSpec.
	outAttr _ spec attributeNamed: aString.
	outAttr == nil ifFalse:[
		(outAttr attrClass = 'exposedField' or:[outAttr attrClass = 'eventOut'])
			ifFalse:[outAttr _ nil]].
	(outAttr == nil and:[aString endsWith:'_changed']) ifTrue:[
		outAttr _ spec attributeNamed: (aString copyFrom: 1 to: aString size - 8)].
	outAttr == nil ifFalse:[
		(outAttr attrClass = 'exposedField' or:[outAttr attrClass = 'eventOut'])
			ifFalse:[outAttr _ nil]].
	^outAttr! !


!VRMLBaseNode methodsFor: 'printing' stamp: 'ar 3/12/98 22:40'!
printOn: aStream
	self printOn: aStream asVRMLStream indent: 0.! !

!VRMLBaseNode methodsFor: 'printing' stamp: 'ar 3/13/98 01:26'!
printOn: aStream indent: level
	self nodeSpec print: self on: aStream indent: level.! !


!VRMLBaseNode methodsFor: 'testing' stamp: 'ar 3/13/98 00:28'!
isPrototype
	^false! !


!VRMLBaseNode methodsFor: 'enumerating' stamp: 'ar 8/18/1999 19:39'!
doWith: aVRMLEnumerator
	aVRMLEnumerator doNode: self.! !


!VRMLBaseNode methodsFor: 'copying' stamp: 'ar 3/13/98 14:37'!
vrmlProtoCopy
	^self shallowCopy! !


!VRMLBaseNode methodsFor: 'private' stamp: 'ar 5/4/2000 18:14'!
myEvents
	^myEvents! !

!VRMLBaseNode methodsFor: 'private' stamp: 'ar 5/4/2000 18:14'!
myEvents: eventList
	myEvents _ eventList! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLBaseNode class
	instanceVariableNames: ''!

!VRMLBaseNode class methodsFor: 'instance creation' stamp: 'ar 3/13/98 01:25'!
fromSpec: aNodeSpec
	^self new fromSpec: aNodeSpec! !
VRMLBaseNode subclass: #VRMLClassNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLClassNode methodsFor: 'accessing' stamp: 'ar 8/18/1999 09:17'!
nodeSpec
	^self class nodeSpec! !


!VRMLClassNode methodsFor: 'initialize' stamp: 'ar 5/4/2000 15:21'!
fromSpec: aNodeSpec
	aNodeSpec attributes do:[:attr|
		attr isEvent ifFalse:[attr setValue: attr value in: self]].! !


!VRMLClassNode methodsFor: 'attributes-generic' stamp: 'ar 5/4/2000 17:35'!
attributeNamed: aString
	^self nodeSpec attributeNamed: aString.
! !

!VRMLClassNode methodsFor: 'attributes-generic' stamp: 'ar 5/4/2000 15:17'!
getAttributeValue: aVRMLNodeAttribute
	aVRMLNodeAttribute isEvent
		ifTrue:[^nil]
		ifFalse:[^self perform: aVRMLNodeAttribute getterName]! !

!VRMLClassNode methodsFor: 'attributes-generic' stamp: 'ar 5/4/2000 15:15'!
setAttribute: aVRMLNodeAttribute toValue: newValue
	self perform: aVRMLNodeAttribute setterName with: newValue! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLClassNode class
	instanceVariableNames: 'nodeSpec '!

!VRMLClassNode class methodsFor: 'accessing' stamp: 'ar 5/4/2000 18:43'!
compileAccessors
	"Compile all accessors for the receiver"
	| varName typeName |
	(self nodeSpec attributes select:[:attr| attr isEvent not]) do:[:attr|
		varName _ (attr name copyReplaceAll:'_' with: '').
		typeName _ (attr type copyReplaceAll:'_' with: '').
		typeName first isUppercase ifFalse:[
			typeName _ typeName first asUppercase asString, 
				(typeName copyFrom: 2 to: typeName size)].
		self compile:(String streamContents:[:s|
			s nextPutAll: varName; crtab.
			s nextPutAll: '"This is an automatically generated accessor"'; crtab.
			s nextPutAll:'^'; nextPutAll: varName])
			classified: 'accessing'.
		self compile: (String streamContents:[:s|
			s nextPutAll: varName; nextPutAll:': a'; nextPutAll: typeName; crtab.
			s nextPutAll: '"This is an automatically generated accessor"'; crtab.
			(attr isExposedField and:[attr isSingleField]) ifTrue:[
				s nextPutAll: varName; nextPutAll:' = a'; nextPutAll: typeName; 
					nextPutAll:' ifFalse:['; crtab: 2].
			s nextPutAll: varName; nextPutAll:' := a'; nextPutAll: typeName; nextPutAll:'.'.
			attr isExposedField ifTrue:[
				s crtab.
				attr isSingleField ifTrue:[s tab].
				s nextPutAll: 'self trigger: #'; print: (attr name,'_changed');
						nextPutAll: ' with: '; nextPutAll: varName.
				attr isSingleField ifTrue:[s nextPutAll:']']]])
			classified: 'accessing'.
	].
! !

!VRMLClassNode class methodsFor: 'accessing' stamp: 'ar 5/4/2000 18:35'!
compileEnumerator
	"Compile #nodesDo: for the receiver"
	| varName typeName s |
	s _ WriteStream on: (String new: 100).
	s nextPutAll: 'nodesDo: aBlock'.
	s crtab; nextPutAll:'"This method was automatically generated"'.
	s crtab; nextPutAll:'aBlock value: self.'.
	(self nodeSpec attributes select:[:attr| attr isEvent not]) do:[:attr|
		varName _ (attr name copyReplaceAll:'_' with: '').
		typeName _ attr type.
		(typeName = 'SFNode') ifTrue:[
			s crtab; nextPutAll: varName; nextPutAll:' ifNotNil:['; nextPutAll: varName;
					nextPutAll:' nodesDo: aBlock].'.
		].
		(typeName = 'MFNode') ifTrue:[
			s crtab; nextPutAll: varName; nextPutAll:' ifNotNil:['; nextPutAll: varName;
				nextPutAll:' do:[:doNode| doNode nodesDo: aBlock]].'.
		].
	].
	self compile: s contents classified: 'enumerating'.! !

!VRMLClassNode class methodsFor: 'accessing' stamp: 'ar 8/18/1999 09:11'!
nodeSpec
	^nodeSpec! !

!VRMLClassNode class methodsFor: 'accessing' stamp: 'ar 8/18/1999 09:11'!
nodeSpec: aSpec
	nodeSpec _ aSpec! !
VRMLClassNode subclass: #VRMLCompositeNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLCompositeNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 18:22'!
addChildren: childList
	self children: (self children, childList).! !

!VRMLCompositeNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 18:22'!
removeChildren: childList
	self children: (self children reject:[:child| childList includes: child]).! !
VRMLNamedNode subclass: #VRMLDefNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLDefNode methodsFor: 'printing' stamp: 'ar 3/12/98 21:50'!
printOn: aVRMLStream indent: aLevel

	aVRMLStream 
		nextPutAll: 'DEF ';
		nextPutAll: name;
		space.
	node printOn: aVRMLStream indent: aLevel.! !
VRMLNodeAttribute subclass: #VRMLDynamicAttribute
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLDynamicAttribute commentStamp: '<historical>' prior: 0!
A VRMLDynamicAttribute is a hidden attribute used for storing information in a VRMLNode which is not part of the standard spec.!


!VRMLDynamicAttribute methodsFor: 'printing' stamp: 'ar 3/13/98 14:07'!
print: aVRMLNode on: aVRMLStream indent: aLevel
	"Do nothing"! !

!VRMLDynamicAttribute methodsFor: 'printing' stamp: 'ar 3/13/98 14:14'!
printOn: aVRMLStream indent: aLevel
	"Do nothing"! !


!VRMLDynamicAttribute methodsFor: 'testing' stamp: 'ar 3/13/98 14:22'!
isDynamic
	^true! !
Object subclass: #VRMLEnumerator
	instanceVariableNames: ''
	classVariableNames: 'EnumActions '
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLEnumerator commentStamp: '<historical>' prior: 0!
A VRMLEnumerator enumerates a tree of VRML nodes and dispatches the nodes to appropriate actions.!


!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 09:52'!
doChildrenOf: aVRMLNode
	| children |
	children := aVRMLNode children.
	children isNil ifTrue:[^self].
	children do:[:each| each doWith: self].! !

!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 09:59'!
doInterpolator: aVRMLNode
	^self! !

!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 09:59'!
doLight: aVRMLNode
	^self! !

!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 19:38'!
doNamedNode: aVRMLNode
	^self doNode: aVRMLNode node! !

!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 09:52'!
doNode: aVRMLNode
	| action |
	action := EnumActions at: aVRMLNode name ifAbsent:[nil].
	action ifNotNil:[self perform: action with: aVRMLNode].! !

!VRMLEnumerator methodsFor: 'enumerating' stamp: 'ar 8/18/1999 09:59'!
doSensor: aVRMLNode
	^self! !


!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doAnchor: aVRMLNode
	"This method was automatically generated"
	^self doChildrenOf: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doAppearance: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doAudioClip: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doBackground: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doBillboard: aVRMLNode
	"This method was automatically generated"
	^self doChildrenOf: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doBox: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCollision: aVRMLNode
	"This method was automatically generated"
	^self doChildrenOf: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doColor: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doColorInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCone: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCoordinate: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCoordinateInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCylinder: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doCylinderSensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doDirectionalLight: aVRMLNode
	"This method was automatically generated"
	^self doLight: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doElevationGrid: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doExtrusion: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doFog: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doFontStyle: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doGroup: aVRMLNode
	"This method was automatically generated"
	^self doChildrenOf: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doImageTexture: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doIndexedFaceSet: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doIndexedLineSet: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doInline: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doLOD: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doMaterial: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doMovieTexture: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doNavigationInfo: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doNormal: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doNormalInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doOrientationInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doPixelTexture: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doPlaneSensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doPointLight: aVRMLNode
	"This method was automatically generated"
	^self doLight: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doPointSet: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doPositionInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doProximitySensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doScalarInterpolator: aVRMLNode
	"This method was automatically generated"
	^self doInterpolator: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doScript: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doShape: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doSound: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doSphere: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doSphereSensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doSpotLight: aVRMLNode
	"This method was automatically generated"
	^self doLight: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doSwitch: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doText: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doTextureCoordinate: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doTextureTransform: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doTimeSensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doTouchSensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doTransform: aVRMLNode
	"This method was automatically generated"
	^self doChildrenOf: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doViewpoint: aVRMLNode
	"This method was automatically generated"
	^self! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doVisibilitySensor: aVRMLNode
	"This method was automatically generated"
	^self doSensor: aVRMLNode! !

!VRMLEnumerator methodsFor: 'enumerating nodes' stamp: 'ar 8/18/1999 09:59'!
doWorldInfo: aVRMLNode
	"This method was automatically generated"
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLEnumerator class
	instanceVariableNames: ''!

!VRMLEnumerator class methodsFor: 'class initialization' stamp: 'ar 8/18/1999 09:58'!
compileSelector: selector spec: nodeSpec

	| isComposite source |
	isComposite := nodeSpec containsAttribute: 'children' ofType: 'MFNode'.
	source := String streamContents:[:s|
		s nextPutAll: selector.
		s nextPutAll:' aVRMLNode'.
		s crtab; nextPutAll:'"This method was automatically generated"'.
		s crtab; nextPutAll:'^self'.
		('*Light*' match: nodeSpec name ) ifTrue:[
			s nextPutAll:' doLight: aVRMLNode'.
		] ifFalse:[
		('*Interpolator*' match: nodeSpec name) ifTrue:[
			s nextPutAll:' doInterpolator: aVRMLNode'.
		] ifFalse:[
		('*Sensor*' match: nodeSpec name) ifTrue:[
			s nextPutAll:' doSensor: aVRMLNode'.
		] ifFalse:[
			isComposite ifTrue:[s nextPutAll:' doChildrenOf: aVRMLNode']]]].
		].
	self compile: source classified: 'enumerating nodes'.
! !

!VRMLEnumerator class methodsFor: 'class initialization' stamp: 'ar 9/16/1999 14:44'!
initialize
	"VRMLEnumerator initialize"
	| selector |
	EnumActions := Dictionary new.
	VRMLNodeSpec initialize.
	VRMLNodeSpec currentSpecs do:[:nodeSpec|
		selector := ('do',nodeSpec name,':') asSymbol.
		EnumActions at: nodeSpec name put: selector.
		(self includesSelector: selector) ifFalse:[
			self compileSelector: selector spec: nodeSpec.
		].
	].! !
VRMLProtoClassNode subclass: #VRMLExternProtoClassNode
	instanceVariableNames: 'urlList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLExternProtoClassNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:53'!
urlList
	^urlList! !

!VRMLExternProtoClassNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:53'!
urlList: anObject
	urlList _ anObject! !


!VRMLExternProtoClassNode methodsFor: 'printing' stamp: 'ar 3/13/98 01:54'!
printOn: aVRMLStream indent: aLevel
	| first |
	aVRMLStream 
		nextPutAll:'EXTERNPROTO ';
		nextPutAll: self nodeSpec name;
		nextPutAll:' [';
		crtab: aLevel+1.
	self nodeSpec attributes do:[:attr|
		attr printExternOn: aVRMLStream indent: aLevel+1.
	].
	aVRMLStream nextPutAll:']'.
	aVRMLStream crtab: aLevel;
		nextPut:$[; space.
	first := true.
	self urlList do:[:string|
		first ifFalse:[aVRMLStream crtab: aLevel].
		aVRMLStream writeString: string.
		first := false].
	aVRMLStream nextPut:$].
	aVRMLStream cr.! !
VRMLBaseNode subclass: #VRMLGenericNode
	instanceVariableNames: 'attributes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLGenericNode methodsFor: 'initialize' stamp: 'ar 3/13/98 00:21'!
fromSpec: aVRMLNodeSpec
	aVRMLNodeSpec defineGenericIn: self.! !

!VRMLGenericNode methodsFor: 'initialize' stamp: 'ar 3/13/98 00:21'!
initialize
	attributes := Dictionary new.! !


!VRMLGenericNode methodsFor: 'testing' stamp: 'ar 3/12/98 21:23'!
isGeneric
	^true! !


!VRMLGenericNode methodsFor: 'attributes' stamp: 'ar 8/18/1999 20:20'!
attributeNamed: aString
	| attr |
	attr _ self nodeSpec attributeNamed: aString.
	attr == nil ifTrue:[^nil].
	^self attributes at: attr ifAbsent:[attr].! !

!VRMLGenericNode methodsFor: 'attributes' stamp: 'ar 3/12/98 21:39'!
defineAttribute: aVRMLAttribute

	attributes at: aVRMLAttribute put: aVRMLAttribute copy! !

!VRMLGenericNode methodsFor: 'attributes' stamp: 'ar 5/4/2000 19:13'!
getAttributeValue: aVRMLAttribute
	^(self attributes at: aVRMLAttribute ifAbsent:[aVRMLAttribute]) value! !

!VRMLGenericNode methodsFor: 'attributes' stamp: 'ar 3/12/98 21:38'!
setAttribute: aVRMLNodeAttribute toValue: newValue
	(self attributes at: aVRMLNodeAttribute) value: newValue! !


!VRMLGenericNode methodsFor: 'accessing' stamp: 'ar 3/12/98 21:39'!
attributes
	^attributes! !

!VRMLGenericNode methodsFor: 'accessing' stamp: 'ar 3/13/98 14:36'!
attributes: aCollection
	attributes := aCollection! !

!VRMLGenericNode methodsFor: 'accessing' stamp: 'ar 3/13/98 13:47'!
children
	| attr |
	attr := self nodeSpec getFieldNamed: 'children'.
	^attr ifNotNil:[self getAttributeValue: attr].! !

!VRMLGenericNode methodsFor: 'accessing' stamp: 'ar 3/13/98 00:21'!
nodeSpec
	^self subclassResponsibility! !


!VRMLGenericNode methodsFor: 'printing' stamp: 'ar 3/13/98 00:21'!
printOn: aStream indent: level
	self nodeSpec print: self on: aStream indent: level.! !


!VRMLGenericNode methodsFor: 'copying' stamp: 'ar 3/13/98 14:29'!
vrmlProtoCopy
	| attrCopy |
	attrCopy := Dictionary new: self attributes size.
	self attributes associationsDo:[:assoc|
		attrCopy at: assoc key put:  assoc value vrmlProtoCopy.
	].
	^self shallowCopy attributes: attrCopy.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLGenericNode class
	instanceVariableNames: ''!

!VRMLGenericNode class methodsFor: 'instance creation' stamp: 'ar 3/12/98 21:33'!
fromSpec: aVRMLNodeSpec
	^self new fromSpec: aVRMLNodeSpec! !

!VRMLGenericNode class methodsFor: 'instance creation' stamp: 'ar 3/12/98 21:33'!
new
	^super new initialize! !
VRMLClassNode subclass: #VRMLInterpolatorNode
	instanceVariableNames: 'fraction value lastIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLInterpolatorNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 16:51'!
fraction
	^fraction! !

!VRMLInterpolatorNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 17:07'!
fraction: newFraction
	"Do my interpolation based on the new values"
	| keys values index delta newValue |
	fraction = newFraction ifTrue:[^self].
	keys _ self key.
	values _ self keyValue.
	newFraction <= keys first ifTrue:[^self value: values first].
	newFraction >= keys last ifTrue:[^self value: values first].
	index _ self largerIndexOf: newFraction in: keys.
	delta _ newFraction - (keys at: index-1).
	newValue _ (values at: index-1) interpolateTo: (values at: index) at: delta.
	fraction _ newFraction.
	self value: newValue.! !

!VRMLInterpolatorNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 16:51'!
value
	^value! !

!VRMLInterpolatorNode methodsFor: 'accessing' stamp: 'ar 5/4/2000 16:51'!
value: newValue
	value _ newValue.
	self trigger: #'value_changed' with: newValue.! !


!VRMLInterpolatorNode methodsFor: 'private' stamp: 'ar 5/4/2000 17:22'!
largerIndexOf: aFraction in: anArray
	"Find the index of the given fraction in anArray"
	| index low high |
	(lastIndex == nil) ifTrue:[
		"Search entire array"
		low _ 1.
		high _ anArray size.
	] ifFalse:[
		"Unroll the first test for a quick hit of small fractional changes"
		(anArray at: lastIndex) >= aFraction ifTrue:[
			(anArray at: lastIndex - 1) <= aFraction 
				ifTrue:[^lastIndex]
				ifFalse:[	high _ lastIndex-1]. "No need to look further"
		] ifFalse:[
			low _ lastIndex. "No need to look further"
		].
	].
		
	[index _ high + low // 2.
	low > high]
		whileFalse:[
			(anArray at: index) <= aFraction
				ifTrue: [low _ index + 1]
				ifFalse: [high _ index - 1]].
	^lastIndex _ low! !
VRMLBaseNode subclass: #VRMLNamedNode
	instanceVariableNames: 'name node '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLNamedNode methodsFor: 'initialize' stamp: 'ar 3/12/98 21:48'!
name: aString node: aNode
	name := aString.
	node := aNode.! !


!VRMLNamedNode methodsFor: 'accessing' stamp: 'ar 8/18/1999 19:37'!
name
	^name! !

!VRMLNamedNode methodsFor: 'accessing' stamp: 'ar 8/18/1999 19:38'!
node
	^node! !


!VRMLNamedNode methodsFor: 'copying' stamp: 'ar 3/13/98 14:29'!
vrmlProtoCopy
	^node vrmlProtoCopy! !


!VRMLNamedNode methodsFor: 'enumerating' stamp: 'ar 8/18/1999 19:38'!
doWith: aVRMLEnumerator
	aVRMLEnumerator doNamedNode: self.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLNamedNode class
	instanceVariableNames: ''!

!VRMLNamedNode class methodsFor: 'instance creation' stamp: 'ar 3/12/98 21:48'!
name: aString node: aNode
	^self new name: aString node: aNode! !
Object subclass: #VRMLNodeAttribute
	instanceVariableNames: 'type name value attrClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLNodeAttribute commentStamp: '<historical>' prior: 0!
This class defines a generic attribute of a VRML node.

Instance variables:
	type		<String>	The type of the attribute (e.g., 'SFFloat', 'MFString')
	name		<String>	The name of the attribute (e.g., 'children')
	value		<Object>	The (default or current) value of the attribute
	attrClass	<String>	The attribute class (e.g., 'exposedField', 'field', 'eventIn', 'eventOut')!


!VRMLNodeAttribute methodsFor: 'reading' stamp: 'ar 3/12/98 23:29'!
readFrom: aVRMLStream in: aParser
	^aParser readAttribute: self from: aVRMLStream! !


!VRMLNodeAttribute methodsFor: 'initialize' stamp: 'ar 3/12/98 21:27'!
name: nameString type: typeString value: defaultValue
	name := nameString.
	type := typeString.
	value := defaultValue.! !

!VRMLNodeAttribute methodsFor: 'initialize' stamp: 'ar 8/17/1999 21:45'!
name: nameString type: typeString value: defaultValue attrClass: classString
	name := nameString.
	type := typeString.
	value := defaultValue.
	attrClass := classString.! !


!VRMLNodeAttribute methodsFor: 'printing' stamp: 'ar 3/12/98 21:56'!
print: aVRMLNode on: aVRMLStream indent: aLevel
	| newValue |
	newValue := aVRMLNode getAttributeValue: self.
	newValue = value ifTrue:[^self].
	aVRMLStream crtab: aLevel.
	VRMLWriter writeAttribute: self on: aVRMLStream value: newValue indent: aLevel.! !

!VRMLNodeAttribute methodsFor: 'printing' stamp: 'ar 3/13/98 01:53'!
printExternOn: aVRMLStream indent: aLevel
	aVRMLStream 
		nextPutAll: self attributeClass; 
		space; 
		nextPutAll: self type; 
		space;
		nextPutAll: self name;
		crtab: aLevel.
! !

!VRMLNodeAttribute methodsFor: 'printing' stamp: 'ar 8/18/1999 09:48'!
printOn: aStream
	aStream 
		"nextPutAll: self class name;
		nextPut:$(;"
		nextPut:$[;
		print: attrClass;
		nextPutAll:'] ';
		print: type;
		space;
		print: name;
		space.
	value isCollection
		ifTrue:[aStream print: value asArray]
		ifFalse:[aStream print: value].
! !

!VRMLNodeAttribute methodsFor: 'printing' stamp: 'ar 3/13/98 01:44'!
printOn: aVRMLStream indent: aLevel
	"aVRMLStream crtab: aLevel."
	aVRMLStream nextPutAll: self attributeClass; space; nextPutAll: self type; space.
	VRMLWriter writeAttribute: self on: aVRMLStream value: value indent: aLevel.! !


!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 8/17/1999 22:07'!
attrClass
	^attrClass! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/13/98 01:37'!
attributeClass
	^'field'! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 5/4/2000 15:17'!
getterName
	^self selectorString asSymbol! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 22:39'!
name
	^name! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 5/4/2000 15:09'!
selectorString
	^self name copyReplaceAll:'_' with: ''! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 21:37'!
setValue: newValue in: aVRMLNode
	aVRMLNode 
		setAttribute: self toValue: newValue.
! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 21:28'!
setValueIn: aVRMLNode
	self setValue: value in: aVRMLNode! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 5/4/2000 15:09'!
setterName
	^(self selectorString copyWith: $:) asSymbol! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 22:40'!
type
	^type! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 21:41'!
value
	^value! !

!VRMLNodeAttribute methodsFor: 'accessing' stamp: 'ar 3/12/98 21:39'!
value: anObject
	value _ anObject! !


!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 3/13/98 14:39'!
containsNodes
	^type = 'MFNode' or:[type = 'SFNode']! !

!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 3/13/98 14:22'!
isDynamic
	^false! !

!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 5/4/2000 15:18'!
isEvent
	^'event*' match: self attrClass! !

!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 5/4/2000 16:37'!
isExposedField
	^self attrClass = 'exposedField'! !

!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 3/13/98 14:41'!
isMultiType
	^type first = $M! !

!VRMLNodeAttribute methodsFor: 'testing' stamp: 'ar 5/4/2000 18:46'!
isSingleField
	^self type first = $S! !


!VRMLNodeAttribute methodsFor: 'copying' stamp: 'ar 3/13/98 14:42'!
vrmlProtoCopy
	| valueCopy |
	self containsNodes
		ifTrue:[valueCopy := self vrmlProtoCopyValues]
		ifFalse:[valueCopy := self value shallowCopy].
 	^self shallowCopy value: valueCopy! !

!VRMLNodeAttribute methodsFor: 'copying' stamp: 'ar 3/13/98 14:42'!
vrmlProtoCopyValues
	self isMultiType ifFalse:[^self value vrmlProtoCopy].
	^self value collect:[:node| node vrmlProtoCopy].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLNodeAttribute class
	instanceVariableNames: ''!

!VRMLNodeAttribute class methodsFor: 'instance creation' stamp: 'ar 8/17/1999 21:46'!
name: nameString type: typeString value: defaultValue attrClass: classString

	^self new name: nameString type: typeString value: defaultValue attrClass: classString! !
Object subclass: #VRMLNodeParser
	instanceVariableNames: 'nodeTypes scene protoList infoBar defName '
	classVariableNames: 'VRMLFieldTypes VRMLRuntimeFieldTypes VRMLScriptFieldTypes VRMLStatements '
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLNodeParser commentStamp: '<historical>' prior: 0!
A VRMLNodeParser creates a generic tree of VRMLNodes from a VRML file. These nodes are not intended to be used directly in a 3D system; they should be used to create a retained mode description for the 3D rendering system.

Instance variables:
	nodeTypes 	<Collection of: VRMLNodeSpec>	The specs used for construction the VRML nodes
	scene 		<VRMLScene>					The scene which will be defined by the parser
	protoList 	<Collection of: VRMLNodeSpec>	Prototypes currently under construction
	infoBar 	<BlockContext>					Progress indicator

Class variables:
	VRMLFieldTypes 			<Dictionary>		Basic VRML field types
	VRMLRuntimeFieldTypes 	<Dictionary>		The field types in a valid VRML file
	VRMLScriptFieldTypes 		<Dictionary>		The field types for node definitions
	VRMLStatements 			<Dictionary>		The valid statements in a VRML file!


!VRMLNodeParser methodsFor: 'initialize' stamp: 'ar 8/17/1999 19:31'!
initialize
	| specs |
	specs _ self nodeSpecs.
	specs == nil ifTrue:[
		nodeTypes _ Dictionary new.
	] ifFalse:[
		nodeTypes _ Dictionary new: specs size.
		specs do:[:nodeSpec|
			nodeTypes at: nodeSpec name put: nodeSpec.
		].
	].! !


!VRMLNodeParser methodsFor: 'parsing' stamp: 'ar 3/11/98 20:04'!
parseField: aVRMLStream
	| fieldType fieldValue |
	aVRMLStream backup.
	fieldType := aVRMLStream readName.
	fieldValue := self dispatchOn: fieldType
						in: VRMLFieldTypes
						with: aVRMLStream
						ifNone:[nil].
	aVRMLStream restoreIf: fieldValue isNil.
	^fieldValue! !


!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldBoolFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readBool! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldColorFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readColor! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldFloatFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readFloat! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldImageFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readImage! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldInt32From: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readInt32! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/12/98 00:49'!
readSingleFieldNodeFrom: aVRMLStream
	"This method was automatically generated"
	aVRMLStream backup.
	aVRMLStream readName = 'NULL' ifTrue:[
		aVRMLStream discard.
		^nil].
	aVRMLStream restore.
	^self parseStatement: aVRMLStream! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldRotationFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readRotation! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldStringFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readString! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldTimeFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readTime! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldVec2fFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readVec2f! !

!VRMLNodeParser methodsFor: 'single field parsing' stamp: 'ar 3/11/98 23:10'!
readSingleFieldVec3fFrom: aVRMLStream
	"This method was automatically generated"
	^aVRMLStream readVec3f! !


!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 8/17/1999 21:51'!
parseAttribute: aVRMLStream from: aDictionary
	| attrClass type name value isEvent |
	aVRMLStream skipSeparators.
	attrClass := aVRMLStream readName.
	isEvent := attrClass = 'eventIn' or:[attrClass = 'eventOut'].
	aVRMLStream skipSeparators.
	type := aVRMLStream readName.
	aVRMLStream skipSeparators.
	name := aVRMLStream readName.
	aVRMLStream skipSeparators.
	isEvent ifFalse:[
		value := self dispatchOn: type
							in: aDictionary
							with: aVRMLStream
							ifNone:[self error:'Unknown attribute type: ',type]].
	^VRMLNodeAttribute name: name type: type value: value attrClass: attrClass! !

!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 3/13/98 01:29'!
parseDefinition: aVRMLStream
	| name attributes attr spec vrmlClassName |
	aVRMLStream skipSeparators.
	name := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream nextChar = ${ ifFalse:[
		self error:'Node definition expected'.
	].
	attributes := OrderedCollection new.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $}] whileFalse:[
		attr := self parseAttribute: aVRMLStream from: VRMLScriptFieldTypes.
		attr ifNotNil:[attributes add: attr].
	].
	aVRMLStream skip: 1.
	spec := VRMLNodeSpec name: name attributes: attributes.
	vrmlClassName := (self vrmlClassNameFor: name) asSymbol.
	(Smalltalk includesKey: vrmlClassName)
		ifTrue:[spec vrmlClass: (Smalltalk at: vrmlClassName)]
		ifFalse:[spec vrmlClass: VRMLStandardNode].
	^spec! !

!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 3/11/98 23:06'!
parseDefinitions: aVRMLStream
	| nodes |
	aVRMLStream reset.
	nodes := OrderedCollection new.
	[aVRMLStream skipSeparators.
	aVRMLStream atEnd] whileFalse:[
		nodes add: (self parseDefinition: aVRMLStream).
	].
	^nodes! !

!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 8/17/1999 21:47'!
parseExternAttribute: aVRMLStream
	| attrClass type name isEvent |
	aVRMLStream skipSeparators.
	attrClass := aVRMLStream readName.
	isEvent := attrClass = 'eventIn' or:[attrClass = 'eventOut'].
	aVRMLStream skipSeparators.
	type := aVRMLStream readName.
	aVRMLStream skipSeparators.
	name := aVRMLStream readName.
	aVRMLStream skipSeparators.
	isEvent ifTrue:[^nil].
	^VRMLNodeAttribute name: name type: type value: nil attrClass: attrClass! !

!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 3/13/98 00:07'!
parseScriptEvent: aVRMLStream
	"Dummy"
	^nil! !

!VRMLNodeParser methodsFor: 'definition parsing' stamp: 'ar 3/13/98 00:07'!
parseScriptField: aVRMLStream
	"Dummy"
	^nil! !


!VRMLNodeParser methodsFor: 'private' stamp: 'ar 3/11/98 22:46'!
dispatchOn: key in: table with: arg ifNone: aBlock
	^self perform: (table at: key ifAbsent:[^aBlock value]) with: arg.! !

!VRMLNodeParser methodsFor: 'private' stamp: 'ar 3/12/98 21:20'!
nodeSpecs
	^VRMLNodeSpec currentSpecs! !

!VRMLNodeParser methodsFor: 'private' stamp: 'ar 11/5/2000 17:18'!
progressUpdate: aVRMLStream
	infoBar ifNil:[^self].
	infoBar value: (aVRMLStream position * 100 // aVRMLStream size).! !

!VRMLNodeParser methodsFor: 'private' stamp: 'ar 3/13/98 01:03'!
skipParens: endChar from: aVRMLStream
	| char |
	[true] whileTrue:[
		aVRMLStream skipSeparators.
		char := aVRMLStream nextChar.
		char = endChar ifTrue:[^self].
		char = $[ ifTrue:[self skipParens:$] from: aVRMLStream].
		char = ${ ifTrue:[self skipParens:$] from: aVRMLStream].
		char = $" ifTrue:[
			aVRMLStream skip: -1.
			aVRMLStream readString].
	].! !

!VRMLNodeParser methodsFor: 'private' stamp: 'ar 3/12/98 19:31'!
vrmlClassNameFor: aString
	^self class vrmlClassNameFor: aString! !


!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 5/4/2000 14:43'!
defineNode: aNode
	"Define aNode if necessary"
	defName ifNotNil:[
		scene defineNode: defName value: aNode.
		defName _ nil]
! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 5/4/2000 14:42'!
parseDEF: aVRMLStream
	| nodeName nodeValue |
	aVRMLStream skipSeparators.
	defName := nodeName := aVRMLStream readName.
	nodeValue := self parseStatement: aVRMLStream.
	defName := nil.
	^VRMLDefNode name: nodeName node: nodeValue! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 3/13/98 14:19'!
parseEXTERNPROTO: aVRMLStream
	| spec urlList subScene protoNode |
	spec := self parseExternProtoSpec: aVRMLStream.
	aVRMLStream skipSeparators.
	urlList := self readMultiFieldStringFrom: aVRMLStream.
	subScene := self class parseURLs: urlList.
	scene addPrototype: (subScene prototypeAt: spec name) spec: spec.
	protoNode := (VRMLExternProtoClassNode fromSpec: spec) urlList: urlList.
	scene addNode: protoNode.
	^nil! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 3/13/98 01:12'!
parseIS: aVRMLStream with: aVRMLNodeAttribute

	| outerScopeName |
	outerScopeName := aVRMLStream readName.
	^aVRMLNodeAttribute value! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 8/17/1999 21:47'!
parsePROTO: aVRMLStream
	| spec nodeList node protoNode protoAttr |
	spec := self parseProtoSpec: aVRMLStream.
	aVRMLStream skipSeparators.
	aVRMLStream next = ${ ifFalse:[^self error:'Prototype body expected'].
	protoList ifNil:[protoList := OrderedCollection new].
	protoList add: spec.
	nodeList := OrderedCollection new.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $}] whileFalse:[
		node := self parseStatement: aVRMLStream.
		node ifNotNil:[nodeList add: node].
	].
	aVRMLStream skip: 1.
	protoList remove: spec.
	protoNode := VRMLProtoClassNode fromSpec: spec.
	protoNode protoValues: nodeList.
	protoAttr := VRMLDynamicAttribute name:'protoType' type: 'SFNode' value: protoNode attrClass: nil.
	spec addAttribute: protoAttr.
	scene addPrototype: protoNode spec: spec.
	scene addNode: protoNode.
	protoList isEmpty ifTrue:[protoList := nil].
	^nil! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 8/17/1999 22:21'!
parseROUTE: aVRMLStream
	| fromNode outEvent toNode inEvent |
	aVRMLStream skipSeparators.
	fromNode := aVRMLStream readName.
	aVRMLStream next = $. ifFalse:[^self error:'Period expected'].
	outEvent := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream readName = 'TO' ifFalse:[^self error:'TO expected'].
	aVRMLStream skipSeparators.
	toNode := aVRMLStream readName.
	aVRMLStream next = $. ifFalse:[^self error:'Period expected'].
	inEvent := aVRMLStream readName.
	scene routeFrom: fromNode event: outEvent to: toNode event: inEvent.
	^nil! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 9/17/1999 00:30'!
parseScene: aVRMLStream
	^self parseScene: aVRMLStream url:''! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 9/17/1999 00:30'!
parseScene: aVRMLStream url: sceneURL
	| version node |
	version := aVRMLStream resetAndCheckVersion.
	version isNil ifTrue:[^self error:'No VRML file'].
	version first = '2.0' ifFalse:[^self error:'Wrong VRML version (',version first,')'].
	version last = 'utf8' ifFalse:[^self error:'Wrong VRML character definition set (not utf8)'].

	'Reading VRML file' 
		displayProgressAt: Sensor cursorPoint
		from: 0 to: 100
		during:[:bar|
			infoBar := bar.
			scene := VRMLScene new.
			scene fileURL: sceneURL.
			[aVRMLStream skipSeparators.
			aVRMLStream atEnd] whileFalse:[
				node := self parseStatement: aVRMLStream.
				node ifNotNil:[scene addNode: node].
			].
	].
	^scene! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 11/5/2000 17:19'!
parseStatement: aVRMLStream
	| token |
	aVRMLStream skipSeparators.
	token := aVRMLStream readName.
	(VRMLStatements includesKey: token) ifTrue:[
		^self dispatchOn: token in: VRMLStatements with: aVRMLStream ifNone:[]].
	(nodeTypes includesKey: token) ifTrue:[
		self progressUpdate: aVRMLStream.
		^(nodeTypes at: token) readFrom: aVRMLStream in: self].
	self error:'Unkown token'.! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 5/4/2000 13:58'!
parseStatement: token from: aVRMLStream
	(VRMLStatements includesKey: token) ifTrue:[
		^self dispatchOn: token in: VRMLStatements with: aVRMLStream ifNone:[]].
	self error:'Unkown token'.! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 3/12/98 21:51'!
parseUSE: aVRMLStream
	| nodeName |
	aVRMLStream skipSeparators.
	nodeName := aVRMLStream readName.
	^VRMLUseNode name: nodeName node: (scene definedNode: nodeName)! !

!VRMLNodeParser methodsFor: 'scene parsing' stamp: 'ar 3/13/98 00:12'!
readAttribute: aVRMLNodeAttribute from: aVRMLStream
	aVRMLStream skipSeparators.
	self isPrototyping ifTrue:[
		aVRMLStream backup.
		(aVRMLStream next: 2) = 'IS' ifTrue:[
			aVRMLStream discard.
			^self parseIS: aVRMLStream with: aVRMLNodeAttribute.
		].
		aVRMLStream restore.
	].
	^self dispatchOn: aVRMLNodeAttribute type
			in: VRMLRuntimeFieldTypes
			with: aVRMLStream
			ifNone:[^self error:'Unknown attribute type: ',aVRMLNodeAttribute type]! !


!VRMLNodeParser methodsFor: 'proto-parsing' stamp: 'ar 3/13/98 01:16'!
parseExternProtoSpec: aVRMLStream
	| protoName attributes attr spec vrmlClassName |
	aVRMLStream skipSeparators.
	protoName := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream next = $[ ifFalse:[^self error:'Interface expected'].
	attributes := OrderedCollection new.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $]] whileFalse:[
		attr := self parseExternAttribute: aVRMLStream.
		attr ifNotNil:[attributes add: attr].
	].
	aVRMLStream skip: 1.
	spec := VRMLNodeSpec name: protoName attributes: attributes.
	spec vrmlClass: VRMLProtoNode.
	vrmlClassName := (self vrmlClassNameFor: protoName) asSymbol.
	(Smalltalk includesKey: vrmlClassName)
		ifTrue:[spec vrmlClass: (Smalltalk at: vrmlClassName)].
	nodeTypes at: protoName put: spec.
	^spec! !

!VRMLNodeParser methodsFor: 'proto-parsing' stamp: 'ar 3/13/98 01:16'!
parseProtoSpec: aVRMLStream
	| protoName attributes attr spec vrmlClassName |
	aVRMLStream skipSeparators.
	protoName := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream next = $[ ifFalse:[^self error:'Interface expected'].
	attributes := OrderedCollection new.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $]] whileFalse:[
		attr := self parseAttribute: aVRMLStream from: VRMLFieldTypes.
		attr ifNotNil:[attributes add: attr].
	].
	aVRMLStream skip: 1.
	spec := VRMLNodeSpec name: protoName attributes: attributes.
	spec vrmlClass: VRMLProtoNode.
	vrmlClassName := (self vrmlClassNameFor: protoName) asSymbol.
	(Smalltalk includesKey: vrmlClassName)
		ifTrue:[spec vrmlClass: (Smalltalk at: vrmlClassName)].
	nodeTypes at: protoName put: spec.
	^spec! !


!VRMLNodeParser methodsFor: 'script parsing' stamp: 'ar 3/13/98 01:40'!
parseScript: aVRMLStream

	aVRMLStream skipSeparators.
	aVRMLStream next = ${ ifFalse:[^self error: 'Script definition expected'].
	self skipParens: $} from: aVRMLStream.
	^VRMLUndefinedNode new.! !

!VRMLNodeParser methodsFor: 'script parsing' stamp: 'ar 3/13/98 00:19'!
readScriptEvent: aVRMLStream
	| type name outer |
	aVRMLStream skipSeparators.
	type := aVRMLStream readName.
	aVRMLStream skipSeparators.
	name := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	aVRMLStream readName = 'IS' ifTrue:[
		aVRMLStream discard.
		aVRMLStream skipSeparators.
		outer := aVRMLStream readName.
	] ifFalse:[aVRMLStream restore].
	^nil! !

!VRMLNodeParser methodsFor: 'script parsing' stamp: 'ar 3/13/98 00:19'!
readScriptField: aVRMLStream
	| type name outer |
	aVRMLStream skipSeparators.
	type := aVRMLStream readName.
	aVRMLStream skipSeparators.
	name := aVRMLStream readName.
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	aVRMLStream readName = 'IS' ifTrue:[
		aVRMLStream discard.
		aVRMLStream skipSeparators.
		outer := aVRMLStream readName.
	] ifFalse:[aVRMLStream restore].
	^nil! !


!VRMLNodeParser methodsFor: 'testing' stamp: 'ar 3/12/98 23:37'!
isPrototyping
	^protoList notNil! !

!VRMLNodeParser methodsFor: 'testing' stamp: 'ar 5/4/2000 13:59'!
isStatement: token
	^VRMLStatements includesKey: token! !

!VRMLNodeParser methodsFor: 'testing' stamp: 'ar 5/4/2000 14:42'!
needsDef
	^defName notNil! !


!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldColorFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (B3DColor4Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldColorFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldColorFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldFloatFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (B3DFloatArray new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldFloatFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldFloatFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldInt32From: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (IntegerArray new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldInt32From: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldInt32From: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldNodeFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldNodeFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldNodeFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldRotationFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (B3DRotationArray new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldRotationFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldRotationFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldStringFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldStringFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldStringFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldTimeFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldTimeFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldTimeFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldVec2fFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (B3DVector2Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldVec2fFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldVec2fFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

!VRMLNodeParser methodsFor: 'multi field parsing' stamp: 'ar 11/5/2000 17:19'!
readMultiFieldVec3fFrom: aVRMLStream	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: (B3DVector3Array new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self readSingleFieldVec3fFrom: aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self readSingleFieldVec3fFrom: aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLNodeParser class
	instanceVariableNames: ''!

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 3/12/98 00:36'!
new
	^super new initialize! !

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 3/12/98 00:33'!
parse: aStream
	^self new parseScene: aStream asVRMLStream.! !

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 9/17/1999 00:30'!
parse: aStream url: sceneURL
	^self new parseScene: aStream asVRMLStream url: sceneURL! !

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 9/17/1999 00:29'!
parseFileNamed: aString
	"VRMLNodeParser parseFileNamed:'C:\WDI-Website\Link 3D Models\08-17-99\vrml\test.wrl'"
	"MessageTally spyOn:[
		VRMLNodeParser 
			parseFileNamed:'C:\WDI-Website\Link 3D Models\08-17-99\vrml\linkvrml97.WRL']"
	| stream result |
	stream := FileStream readOnlyFileNamed: aString.
	stream size < 500000 "cache in memory"
		ifTrue:[result _ self parse: (ReadStream on: stream contentsOfEntireFile) url: stream name]
		ifFalse:[result := self parse: stream].
	stream close.
	^result! !

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 3/12/98 00:32'!
parseString: aString
	^self parse: (ReadStream on: aString)! !

!VRMLNodeParser class methodsFor: 'instance creation' stamp: 'ar 3/13/98 00:50'!
parseURLs: aCollection
	"Parse a collection of URLs return the result of first success"
	^VRMLScene new! !


!VRMLNodeParser class methodsFor: 'class initialization' stamp: 'ar 5/4/2000 16:00'!
initFields
	"VRMLNodeParser initialize"
	| selString multi typeString singleString multiString selector sym type |
	VRMLFieldTypes := Dictionary new.
#(
(MFColor B3DColor4Array)
(MFFloat B3DFloatArray)
(MFInt32 IntegerArray)
(MFNode Array)
(MFRotation B3DRotationArray)
(MFString Array)
(MFTime Array)
(MFVec2f B3DVector2Array)
(MFVec3f B3DVector3Array)
(SFBool)
(SFColor) 
(SFFloat)
(SFImage)
(SFInt32)
(SFNode)
(SFRotation)
(SFString)
(SFTime)
(SFVec2f)
(SFVec3f)
) do:[:spec|
	sym _ spec first.
	type _ spec last.
	multi := sym first = $M.
	typeString := sym copyFrom: 3 to: sym size.
	singleString := 'readSingleField', typeString, 'From:'.
	multiString := 'readMultiField', typeString, 'From:'.
	selString := multi ifTrue:[multiString] ifFalse:[singleString].
	selector := selString asSymbol.
	VRMLFieldTypes at: sym asString put: selector.
	(self includesSelector: selector) ifFalse:[
		multi
			ifTrue:[self compileMultiFieldMethod: selString single: singleString type: type]
			ifFalse:[self compileSingleFieldMethod: selString type: typeString]].
]. ! !

!VRMLNodeParser class methodsFor: 'class initialization' stamp: 'ar 3/13/98 00:12'!
initRuntimeFields
	"VRMLNodeParser initialize"
	VRMLRuntimeFieldTypes := Dictionary new.
	VRMLFieldTypes associationsDo:[:assoc|
		VRMLRuntimeFieldTypes at: assoc key put: assoc value.
	].
	VRMLRuntimeFieldTypes
		at: 'fieldType' put: #readScriptField:;
		at: 'eventType' put: #readScriptEvent:;
		yourself.! !

!VRMLNodeParser class methodsFor: 'class initialization' stamp: 'ar 3/13/98 00:06'!
initScriptFields
	"VRMLNodeParser initialize"
	| |
	VRMLScriptFieldTypes := Dictionary new.
	VRMLFieldTypes associationsDo:[:assoc|
		VRMLScriptFieldTypes at: assoc key put: assoc value.
	].
	VRMLScriptFieldTypes
		at: 'fieldType' put: #parseScriptField:;
		at: 'eventType' put: #parseScriptEvent:;
		yourself.! !

!VRMLNodeParser class methodsFor: 'class initialization' stamp: 'ar 3/13/98 00:58'!
initStatements
	"VRMLNodeParser initialize"
	VRMLStatements := Dictionary new.
	#(
	DEF
	USE
	PROTO
	EXTERNPROTO
	ROUTE
	Script
	) do:[:sym| VRMLStatements at: sym asString put: ('parse',sym,':') asSymbol]! !

!VRMLNodeParser class methodsFor: 'class initialization' stamp: 'ar 3/13/98 00:11'!
initialize
	"VRMLNodeParser initialize"
	self initFields.
	self initScriptFields.
	self initRuntimeFields.
	self initStatements.! !


!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 5/4/2000 15:12'!
buildClasses
	"VRMLNodeParser buildClasses"
	Utilities informUserDuring:[:bar|
	VRMLNodeSpec currentSpecs do:[:nodeSpec|
		bar value: 'Compiling ', nodeSpec name.
		(nodeSpec attributeNamed: 'children') notNil ifTrue:[
			self compileCompositeNode: nodeSpec.
		] ifFalse:[
		('*Light*' match: nodeSpec name ) ifTrue:[
			self compileLightNode: nodeSpec.
		] ifFalse:[
		('*Interpolator*' match: nodeSpec name) ifTrue:[
			self compileInterpolatorNode: nodeSpec.
		] ifFalse:[
		('*Sensor*' match: nodeSpec name) ifTrue:[
			self compileSensorNode: nodeSpec.
		] ifFalse:[
			self compileSimpleNode: nodeSpec.
		]]]]].
	].! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 5/4/2000 18:23'!
compileCompositeNode: nodeSpec
	^self compileNode: nodeSpec superClass: VRMLCompositeNode category:'VRML-Nodes-Composite'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 5/4/2000 16:52'!
compileInterpolatorNode: nodeSpec
	^self compileNode: nodeSpec superClass: VRMLInterpolatorNode category:'VRML-Nodes-Interpolators'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 8/18/1999 09:12'!
compileLightNode: nodeSpec
	^self compileNode: nodeSpec superClass: VRMLClassNode category:'VRML-Nodes-Light'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 11/5/2000 17:18'!
compileMultiFieldMethod: selString single: singleString type: mfFieldType
	| source |
	source := String streamContents:[:s|
		s nextPutAll: selString.
		s nextPutAll:' aVRMLStream'.
		s nextPutAll:((
'	"This method was automatically generated"
	| fields nFields |
	fields := WriteStream on: ($MF_FIELD_TYPE$ new: 100).
	aVRMLStream skipSeparators.
	aVRMLStream backup.
	(aVRMLStream nextChar = $[) ifFalse:[
		aVRMLStream restore.
		fields nextPut: (self $READSINGLE$ aVRMLStream).
		^fields contents].
	aVRMLStream discard.
	nFields _ 0.
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $] ] whileFalse:[
		(nFields bitAnd: 255) = 0 ifTrue:[self progressUpdate: aVRMLStream].
		fields nextPut: (self $READSINGLE$ aVRMLStream).
		nFields _ nFields + 1.
	].
	aVRMLStream nextChar.
	^fields contents.' 
		copyReplaceAll:'$READSINGLE$' with: singleString)
		copyReplaceAll:'$MF_FIELD_TYPE$' with: mfFieldType).
	].
	self compile: source classified:'multi field parsing'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 5/4/2000 18:25'!
compileNode: nodeSpec superClass: aClass category: aString
	| varNames theClass |
	(aClass includesBehavior: VRMLClassNode) ifFalse:[^self halt].
	varNames := WriteStream on: (String new).
	nodeSpec attributes do:[:attr|
		('event*' match: attr attrClass ) ifFalse:[
			varNames nextPutAll: (attr name copyReplaceAll:'_' with: '').
			varNames space.
		].
	].
	theClass := aClass subclass: (self vrmlClassNameFor: nodeSpec name) asSymbol
		instanceVariableNames: varNames contents
		classVariableNames: ''
		poolDictionaries: ''
		category: aString.
	theClass nodeSpec: nodeSpec.
	theClass compileAccessors.
	theClass compileEnumerator.
	nodeSpec vrmlClass: theClass.! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 8/18/1999 09:12'!
compileSensorNode: nodeSpec
	^self compileNode: nodeSpec superClass: VRMLClassNode category:'VRML-Nodes-Sensors'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 8/18/1999 09:12'!
compileSimpleNode: nodeSpec
	^self compileNode: nodeSpec superClass: VRMLClassNode category:'VRML-Nodes-Simple'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 3/11/98 21:21'!
compileSingleFieldMethod: selString type: typeString
	| source |
	source := String streamContents:[:s|
		s nextPutAll: selString.
		s nextPutAll:' aVRMLStream'.
		s crtab.
		s nextPutAll:'"This method was automatically generated"'.
		s crtab.
		s nextPutAll:'^aVRMLStream read'.
		s nextPutAll: typeString.
	].
	self compile: source classified:'single field parsing'! !

!VRMLNodeParser class methodsFor: 'private' stamp: 'ar 3/12/98 19:30'!
vrmlClassNameFor: aString
	^'VRML',aString,'Node'! !


!VRMLNodeParser class methodsFor: 'documentation' stamp: 'ar 3/11/98 23:36'!
vrml97NodeDefinition
	"Node definitions from the VRML97 spec"
^'Anchor { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField MFNode   children        []
  exposedField SFString description     "" 
  exposedField MFString parameter       []
  exposedField MFString url             []
  field        SFVec3f  bboxCenter      0 0 0     # (-,)
  field        SFVec3f  bboxSize        -1 -1 -1  # (0,) or -1,-1,-1
}
Appearance { 
  exposedField SFNode material          NULL
  exposedField SFNode texture           NULL
  exposedField SFNode textureTransform  NULL
}
AudioClip { 
  exposedField   SFString description      ""
  exposedField   SFBool   loop             FALSE
  exposedField   SFFloat  pitch            1.0        # (0,)
  exposedField   SFTime   startTime        0          # (-,)
  exposedField   SFTime   stopTime         0          # (-,)
  exposedField   MFString url              []
  eventOut       SFTime   duration_changed
  eventOut       SFBool   isActive
}
Background { 
  eventIn      SFBool   set_bind
  exposedField MFFloat  groundAngle  []         # [0,/2]
  exposedField MFColor  groundColor  []         # [0,1]
  exposedField MFString backUrl      []
  exposedField MFString bottomUrl    []
  exposedField MFString frontUrl     []
  exposedField MFString leftUrl      []
  exposedField MFString rightUrl     []
  exposedField MFString topUrl       []
  exposedField MFFloat  skyAngle     []         # [0,]
  exposedField MFColor  skyColor     0 0 0      # [0,1]
  eventOut     SFBool   isBound
}
Billboard { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField SFVec3f  axisOfRotation 0 1 0     #	(-,)
  exposedField MFNode   children       []
  field        SFVec3f  bboxCenter     0 0 0     #	(-,)
  field        SFVec3f  bboxSize       -1 -1 -1  #	(0,) or -1,-1,-1
}
Box { 
  field    SFVec3f size  2 2 2        #	(0,	)
}
Collision { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField MFNode   children        []
  exposedField SFBool   collide         TRUE
  field        SFVec3f  bboxCenter      0 0 0      # (-,)
  field        SFVec3f  bboxSize        -1 -1 -1   # (0,) or -1,-1,-1
  field        SFNode   proxy           NULL
  eventOut     SFTime   collideTime
}
Color { 
  exposedField MFColor color  []         # [0,1]
}
ColorInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFColor keyValue      []    # [0,1]
  eventOut     SFColor value_changed
}
Cone { 
  field     SFFloat   bottomRadius 1        # (0,)
  field     SFFloat   height       2        # (0,)
  field     SFBool    side         TRUE
  field     SFBool    bottom       TRUE
}
Coordinate { 
  exposedField MFVec3f point  []      # (-,)
}
CoordinateInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFVec3f keyValue      []    # (-,)
  eventOut     MFVec3f value_changed
}
Cylinder { 
  field    SFBool    bottom  TRUE
  field    SFFloat   height  2         # (0,)
  field    SFFloat   radius  1         # (0,)
  field    SFBool    side    TRUE
  field    SFBool    top     TRUE
}
CylinderSensor { 
  exposedField SFBool     autoOffset TRUE
  exposedField SFFloat    diskAngle  0.262       # (0,/2)
  exposedField SFBool     enabled    TRUE
  exposedField SFFloat    maxAngle   -1          # [-2,2]
  exposedField SFFloat    minAngle   0           # [-2,2]
  exposedField SFFloat    offset     0           # (-,)
  eventOut     SFBool     isActive
  eventOut     SFRotation rotation_changed
  eventOut     SFVec3f    trackPoint_changed
}
DirectionalLight { 
  exposedField SFFloat ambientIntensity  0        # [0,1]
  exposedField SFColor color             1 1 1    # [0,1]
  exposedField SFVec3f direction         0 0 -1   # (-,)
  exposedField SFFloat intensity         1        # [0,1]
  exposedField SFBool  on                TRUE 
}
ElevationGrid { 
  eventIn      MFFloat  set_height
  exposedField SFNode   color             NULL
  exposedField SFNode   normal            NULL
  exposedField SFNode   texCoord          NULL
  field        MFFloat  height            []      # (-,)
  field        SFBool   ccw               TRUE
  field        SFBool   colorPerVertex    TRUE
  field        SFFloat  creaseAngle       0       # [0,]
  field        SFBool   normalPerVertex   TRUE
  field        SFBool   solid             TRUE
  field        SFInt32  xDimension        0       # [0,)
  field        SFFloat  xSpacing          1.0     # (0,)
  field        SFInt32  zDimension        0       # [0,)
  field        SFFloat  zSpacing          1.0     # (0,)
}
Extrusion { 
  eventIn MFVec2f    set_crossSection
  eventIn MFRotation set_orientation
  eventIn MFVec2f    set_scale
  eventIn MFVec3f    set_spine
  field   SFBool     beginCap         TRUE
  field   SFBool     ccw              TRUE
  field   SFBool     convex           TRUE
  field   SFFloat    creaseAngle      0                # [0,)
  field   MFVec2f    crossSection     [ 1 1, 1 -1, -1 -1,
                                       -1 1, 1  1 ]    # (-,)
  field   SFBool     endCap           TRUE
  field   MFRotation orientation      0 0 1 0          # [-1,1],(-,)
  field   MFVec2f    scale            1 1              # (0,)
  field   SFBool     solid            TRUE
  field   MFVec3f    spine            [ 0 0 0, 0 1 0 ] # (-,)
}
Fog { 
  exposedField SFColor  color            1 1 1      # [0,1]
  exposedField SFString fogType          "LINEAR"
  exposedField SFFloat  visibilityRange  0          # [0,)
  eventIn      SFBool   set_bind
  eventOut     SFBool   isBound
}
FontStyle { 
  field MFString family       "SERIF"
  field SFBool   horizontal   TRUE
  field MFString justify      "BEGIN"
  field SFString language     ""
  field SFBool   leftToRight  TRUE
  field SFFloat  size         1.0          # (0,)
  field SFFloat  spacing      1.0          # [0,)
  field SFString style        "PLAIN"
  field SFBool   topToBottom  TRUE
}
Group { 
  eventIn      MFNode  addChildren
  eventIn      MFNode  removeChildren
  exposedField MFNode  children      []
  field        SFVec3f bboxCenter    0 0 0     #	(-,)
  field        SFVec3f bboxSize      -1 -1 -1  #	(0,)	or	-1,-1,-1
}
ImageTexture { 
  exposedField MFString url     []
  field        SFBool   repeatS TRUE
  field        SFBool   repeatT TRUE
}
IndexedFaceSet { 
  eventIn       MFInt32 set_colorIndex
  eventIn       MFInt32 set_coordIndex
  eventIn       MFInt32 set_normalIndex
  eventIn       MFInt32 set_texCoordIndex
  exposedField  SFNode  color             NULL
  exposedField  SFNode  coord             NULL
  exposedField  SFNode  normal            NULL
  exposedField  SFNode  texCoord          NULL
  field         SFBool  ccw               TRUE
  field         MFInt32 colorIndex        []        # [-1,)
  field         SFBool  colorPerVertex    TRUE
  field         SFBool  convex            TRUE
  field         MFInt32 coordIndex        []        # [-1,)
  field         SFFloat creaseAngle       0         # [0,)
  field         MFInt32 normalIndex       []        # [-1,)
  field         SFBool  normalPerVertex   TRUE
  field         SFBool  solid             TRUE
  field         MFInt32 texCoordIndex     []        # [-1,)
}
IndexedLineSet { 
  eventIn       MFInt32 set_colorIndex
  eventIn       MFInt32 set_coordIndex
  exposedField  SFNode  color             NULL
  exposedField  SFNode  coord             NULL
  field         MFInt32 colorIndex        []     # [-1,)
  field         SFBool  colorPerVertex    TRUE
  field         MFInt32 coordIndex        []     # [-1,)
}
Inline { 
  exposedField MFString url        []
  field        SFVec3f  bboxCenter 0 0 0     #	(-,)
  field        SFVec3f  bboxSize   -1 -1 -1  #	(0,)	or	-1,-1,-1
}
LOD { 
  exposedField MFNode  level    [] 
  field        SFVec3f center   0 0 0    #	(-,)
  field        MFFloat range    []       #	(0,)
}
Material { 
  exposedField SFFloat ambientIntensity  0.2         #	[0,1]
  exposedField SFColor diffuseColor      0.8 0.8 0.8 #	[0,1]
  exposedField SFColor emissiveColor     0 0 0       #	[0,1]
  exposedField SFFloat shininess         0.2         #	[0,1]
  exposedField SFColor specularColor     0 0 0       #	[0,1]
  exposedField SFFloat transparency      0           #	[0,1]
}
MovieTexture { 
  exposedField SFBool   loop             FALSE
  exposedField SFFloat  speed            1.0      #	(-,)
  exposedField SFTime   startTime        0        #	(-,)
  exposedField SFTime   stopTime         0        #	(-,)
  exposedField MFString url              []
  field        SFBool   repeatS          TRUE
  field        SFBool   repeatT          TRUE
  eventOut     SFTime   duration_changed
  eventOut     SFBool   isActive
}
NavigationInfo { 
  eventIn      SFBool   set_bind
  exposedField MFFloat  avatarSize      [0.25, 1.6, 0.75] #	[0,)
  exposedField SFBool   headlight       TRUE
  exposedField SFFloat  speed           1.0               #	[0,)
  exposedField MFString type            ["WALK", "ANY"]
  exposedField SFFloat  visibilityLimit 0.0               #	[0,)
  eventOut     SFBool   isBound
}
Normal { 
  exposedField MFVec3f vector  []   #	(-,)
}
NormalInterpolator { 
  eventIn      SFFloat set_fraction       #	(-,)
  exposedField MFFloat key           []   #	(-,)
  exposedField MFVec3f keyValue      []   #	(-,)
  eventOut     MFVec3f value_changed
}
OrientationInterpolator { 
  eventIn      SFFloat    set_fraction      #	(-,)
  exposedField MFFloat    key           []  #	(-,)
  exposedField MFRotation keyValue      []  # [-1,1],(-,)
  eventOut     SFRotation value_changed
}
PixelTexture { 
  exposedField SFImage  image      0 0 0    # see 5.5, SFImage
  field        SFBool   repeatS    TRUE
  field        SFBool   repeatT    TRUE
}
PlaneSensor { 
  exposedField SFBool  autoOffset          TRUE
  exposedField SFBool  enabled             TRUE
  exposedField SFVec2f maxPosition         -1 -1     # (-,)
  exposedField SFVec2f minPosition         0 0       # (-,)
  exposedField SFVec3f offset              0 0 0     # (-,)
  eventOut     SFBool  isActive
  eventOut     SFVec3f trackPoint_changed
  eventOut     SFVec3f translation_changed
}
PointLight { 
  exposedField SFFloat ambientIntensity  0       # [0,1]
  exposedField SFVec3f attenuation       1 0 0   # [0,)
  exposedField SFColor color             1 1 1   # [0,1]
  exposedField SFFloat intensity         1       # [0,1]
  exposedField SFVec3f location          0 0 0   # (-,)
  exposedField SFBool  on                TRUE 
  exposedField SFFloat radius            100     # [0,)
}
PointSet { 
  exposedField  SFNode  color      NULL
  exposedField  SFNode  coord      NULL
}
PositionInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFVec3f keyValue      []    # (-,)
  eventOut     SFVec3f value_changed
}
ProximitySensor { 
  exposedField SFVec3f    center      0 0 0    # (-,)
  exposedField SFVec3f    size        0 0 0    # [0,)
  exposedField SFBool     enabled     TRUE
  eventOut     SFBool     isActive
  eventOut     SFVec3f    position_changed
  eventOut     SFRotation orientation_changed
  eventOut     SFTime     enterTime
  eventOut     SFTime     exitTime
}
ScalarInterpolator { 
  eventIn      SFFloat set_fraction         # (-,)
  exposedField MFFloat key           []     # (-,)
  exposedField MFFloat keyValue      []     # (-,)
  eventOut     SFFloat value_changed
}
Script { 
  exposedField MFString url           [] 
  field        SFBool   directOutput  FALSE
  field        SFBool   mustEvaluate  FALSE
  # And any number of:
  #eventIn      eventType eventName
  #field        fieldType fieldName initialValue
  #eventOut     eventType eventName
}
Shape { 

  exposedField SFNode appearance NULL
  exposedField SFNode geometry   NULL
}
Sound { 
  exposedField SFVec3f  direction     0 0 1   # (-,)
  exposedField SFFloat  intensity     1       # [0,1]
  exposedField SFVec3f  location      0 0 0   # (-,)
  exposedField SFFloat  maxBack       10      # [0,)
  exposedField SFFloat  maxFront      10      # [0,)
  exposedField SFFloat  minBack       1       # [0,)
  exposedField SFFloat  minFront      1       # [0,)
  exposedField SFFloat  priority      0       # [0,1]
  exposedField SFNode   source        NULL
  field        SFBool   spatialize    TRUE
}
Sphere { 
  field SFFloat radius  1    # (0,)
}
SphereSensor { 
  exposedField SFBool     autoOffset        TRUE
  exposedField SFBool     enabled           TRUE
  exposedField SFRotation offset            0 1 0 0  # [-1,1],(-,)
  eventOut     SFBool     isActive
  eventOut     SFRotation rotation_changed
  eventOut     SFVec3f    trackPoint_changed
}
SpotLight { 
  exposedField SFFloat ambientIntensity  0         # [0,1]
  exposedField SFVec3f attenuation       1 0 0     # [0,)
  exposedField SFFloat beamWidth         1.570796  # (0,/2]
  exposedField SFColor color             1 1 1     # [0,1]
  exposedField SFFloat cutOffAngle       0.785398  # (0,/2]
  exposedField SFVec3f direction         0 0 -1    # (-,)
  exposedField SFFloat intensity         1         # [0,1]
  exposedField SFVec3f location          0 0 0     # (-,)
  exposedField SFBool  on                TRUE
  exposedField SFFloat radius            100       # [0,)
}
Switch { 
  exposedField    MFNode  choice      []
  exposedField    SFInt32 whichChoice -1    # [-1,)
}
Text { 
  exposedField  MFString string    []
  exposedField  SFNode   fontStyle NULL
  exposedField  MFFloat  length    []      # [0,)
  exposedField  SFFloat  maxExtent 0.0     # [0,)
}
TextureCoordinate { 
  exposedField MFVec2f point  []      # (-,)
}
TextureTransform { 
  exposedField SFVec2f center      0 0     # (-,)
  exposedField SFFloat rotation    0       # (-,)
  exposedField SFVec2f scale       1 1     # (-,)
  exposedField SFVec2f translation 0 0     # (-,)
}
TimeSensor { 
  exposedField SFTime   cycleInterval 1       # (0,)
  exposedField SFBool   enabled       TRUE
  exposedField SFBool   loop          FALSE
  exposedField SFTime   startTime     0       # (-,)
  exposedField SFTime   stopTime      0       # (-,)
  eventOut     SFTime   cycleTime
  eventOut     SFFloat  fraction_changed      # [0,	1]
  eventOut     SFBool   isActive
  eventOut     SFTime   time
}
TouchSensor { 
  exposedField SFBool  enabled TRUE
  eventOut     SFVec3f hitNormal_changed
  eventOut     SFVec3f hitPoint_changed
  eventOut     SFVec2f hitTexCoord_changed
  eventOut     SFBool  isActive
  eventOut     SFBool  isOver
  eventOut     SFTime  touchTime
}
Transform { 
  eventIn      MFNode      addChildren
  eventIn      MFNode      removeChildren
  exposedField SFVec3f     center           0 0 0    #	(-,)
  exposedField MFNode      children         []
  exposedField SFRotation  rotation         0 0 1 0  # [-1,1],(-,)
  exposedField SFVec3f     scale            1 1 1    #	(0,)
  exposedField SFRotation  scaleOrientation 0 0 1 0  # [-1,1],(-,)
  exposedField SFVec3f     translation      0 0 0    #	(-,)
  field        SFVec3f     bboxCenter       0 0 0    #	(-,)
  field        SFVec3f     bboxSize         -1 -1 -1 #	(0,)	or	-1,-1,-1
} 
Viewpoint { 
  eventIn      SFBool     set_bind
  exposedField SFFloat    fieldOfView    0.785398  #	(0,)
  exposedField SFBool     jump           TRUE
  exposedField SFRotation orientation    0 0 1 0   # [-1,1],(-,)
  exposedField SFVec3f    position       0 0 10    #	(-,)
  field        SFString   description    ""
  eventOut     SFTime     bindTime
  eventOut     SFBool     isBound
}
VisibilitySensor { 
  exposedField SFVec3f center   0 0 0      #	(-,)
  exposedField SFBool  enabled  TRUE
  exposedField SFVec3f size     0 0 0      #	[0,)
  eventOut     SFTime  enterTime
  eventOut     SFTime  exitTime
  eventOut     SFBool  isActive
}
WorldInfo { 
  field MFString info  []
  field SFString title ""
}
'! !

!VRMLNodeParser class methodsFor: 'documentation' stamp: 'ar 3/12/98 18:18'!
vrml97Nodes
	"VRMLNodeParser vrml97Nodes"
	| stream |
	stream := VRMLStream on: (ReadStream on: self vrml97NodeDefinition).
	^VRMLNodeParser new parseDefinitions: stream! !


!VRMLNodeParser class methodsFor: 'examples' stamp: 'ar 3/12/98 00:34'!
exD10
	"VRMLNodeParser parseString: VRMLNodeParser exD10"
^'#VRML V2.0 utf8

Shape { 
    geometry PointSet {
        coord DEF mypts Coordinate { point [ 0 0 0, 2 2 2, 3 3 3 ] }
        color Color { color [ 1 0 0, 0 1 0, 0 0 1 ] }
    }
}

Transform {
    translation 2 0 0

    children Shape {
        geometry PointSet {
	    coord USE mypts
	    color Color { color [ .5 .5 0, 0 .5 .5, 1 1 1 ] }
        }
    }
}
'! !
Object subclass: #VRMLNodeSpec
	instanceVariableNames: 'name attributes vrmlClass nodeId attrDict '
	classVariableNames: 'CurrentSpecs UndefinedSpec '
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLNodeSpec commentStamp: '<historical>' prior: 0!
This class represents the specification for a VRML node.

Instance variables:
	name		<String>		The name of the node
	attributes	<Collection of: VRMLNodeAttribute>	All defined attributes for this node
	vrmlClass	<Class>		The class used for constructing an instance of this spec
	nodeId		<Integer|nil>	The index of this node in the spec list
	attrDict		<Dictionary>	The mapping of names to attributes!


!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/13/98 14:04'!
addAttribute: aVRMLNodeAttribute
	self attributes add: aVRMLNodeAttribute.
	self attrDict at: aVRMLNodeAttribute name put: aVRMLNodeAttribute.! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/13/98 14:04'!
attrDict
	^attrDict ifNil:[attrDict := Dictionary new].! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/13/98 14:04'!
attributeNamed: aName
	^self attrDict at: aName ifAbsent:[nil]! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 22:18'!
attributes
	^attributes! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/13/98 14:22'!
defineGenericIn: aVRMLNode
	self assert:[aVRMLNode isGeneric].
	self attributes do:[:attr|
		attr isDynamic ifFalse:[aVRMLNode defineAttribute: attr].
	].! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/13/98 13:47'!
getFieldNamed: aString
	^self attributeNamed: aString! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 22:36'!
name
	^name! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 22:37'!
newInstance
	| vrmlInstance |
	vrmlClass isNil ifTrue:[self error:'No class'].
	vrmlInstance := vrmlClass fromSpec: self.
	^vrmlInstance! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 21:38'!
nodeId
	^nodeId! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 21:07'!
nodeId: anObject
	nodeId _ anObject! !

!VRMLNodeSpec methodsFor: 'accessing' stamp: 'ar 3/12/98 22:17'!
vrmlClass: anObject
	vrmlClass _ anObject! !


!VRMLNodeSpec methodsFor: 'printing' stamp: 'ar 3/13/98 00:53'!
print: aVRMLNode on: aVRMLStream indent: level

	aVRMLStream nextPutAll: name.
	aVRMLStream space.
	aVRMLStream nextPut: ${; space; space.
	self attributes do:[:attr|
		attr print: aVRMLNode on: aVRMLStream indent: level + 1.
	].
	aVRMLStream skip: -1.
	aVRMLStream nextPut:$}.! !

!VRMLNodeSpec methodsFor: 'printing' stamp: 'ar 3/13/98 00:53'!
printOn: aStream
	aStream nextPut:$[.
	aStream print: nodeId.
	aStream nextPutAll:'] '.
	aStream nextPutAll: name.
	aStream nextPutAll:' {'.
	aStream cr.
	self attributes do:[:attr|
		attr printOn: aStream.
		aStream cr.
	].
	aStream nextPut:$}.! !


!VRMLNodeSpec methodsFor: 'initialize' stamp: 'ar 3/13/98 01:28'!
name: aString attributes: aCollection
	name := aString.
	attributes := aCollection.
	attrDict := Dictionary new: attributes size.
	vrmlClass := VRMLUndefinedNode.
	aCollection do:[:attr| attrDict at: attr name put: attr].! !


!VRMLNodeSpec methodsFor: 'reading' stamp: 'ar 5/4/2000 13:57'!
readAttributeFrom: aVRMLStream in: aParser
	"Read an attribute"
	| attrName attrSpec attrValue |
	attrName := aVRMLStream readName.
	attrSpec := self attributeNamed: attrName.
	attrSpec notNil ifTrue:[
		attrValue := attrSpec readFrom: aVRMLStream in: aParser.
		^attrSpec -> attrValue].
	(aParser isStatement: attrName) ifTrue:[
		aParser parseStatement: attrName from: aVRMLStream.
		^nil].
	self warn:'Unknown attribute: ', attrName.
	aVRMLStream skip: 1.
	^nil! !

!VRMLNodeSpec methodsFor: 'reading' stamp: 'ar 5/4/2000 14:44'!
readFrom: aVRMLStream in: aParser
	"Read a node"
	| assoc vrmlInstance |
	vrmlInstance := self newInstance.
	aParser defineNode: vrmlInstance.
	aVRMLStream skipSeparators.
	aVRMLStream nextChar = ${ ifFalse:[^self error:'Node definition expected'].
	[aVRMLStream skipSeparators.
	aVRMLStream peekChar = $}] whileFalse:[
		assoc := self readAttributeFrom: aVRMLStream in: aParser.
		assoc ifNotNil:[assoc key setValue: assoc value in: vrmlInstance].
	].
	aVRMLStream nextChar.
	^vrmlInstance! !


!VRMLNodeSpec methodsFor: 'testing' stamp: 'ar 3/13/98 13:32'!
containsAttribute: nameString ofType: typeString
	| attr |
	attr := self attributeNamed: nameString.
	^attr isNil
		ifTrue:[false]
		ifFalse:[attr type = typeString]! !


!VRMLNodeSpec methodsFor: 'debug' stamp: 'ar 5/4/2000 13:48'!
warn: aString
	self inform: aString.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLNodeSpec class
	instanceVariableNames: ''!

!VRMLNodeSpec class methodsFor: 'accessing' stamp: 'ar 3/12/98 21:09'!
currentSpecs
	^CurrentSpecs! !

!VRMLNodeSpec class methodsFor: 'accessing' stamp: 'ar 3/13/98 01:30'!
undefinedSpec
	^UndefinedSpec! !


!VRMLNodeSpec class methodsFor: 'vrml97' stamp: 'ar 3/13/98 00:08'!
vrml97NodeDefinition
	"Node definitions from the VRML97 spec - HACKED in Script node!!"
^'Anchor { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField MFNode   children        []
  exposedField SFString description     "" 
  exposedField MFString parameter       []
  exposedField MFString url             []
  field        SFVec3f  bboxCenter      0 0 0     # (-,)
  field        SFVec3f  bboxSize        -1 -1 -1  # (0,) or -1,-1,-1
}
Appearance { 
  exposedField SFNode material          NULL
  exposedField SFNode texture           NULL
  exposedField SFNode textureTransform  NULL
}
AudioClip { 
  exposedField   SFString description      ""
  exposedField   SFBool   loop             FALSE
  exposedField   SFFloat  pitch            1.0        # (0,)
  exposedField   SFTime   startTime        0          # (-,)
  exposedField   SFTime   stopTime         0          # (-,)
  exposedField   MFString url              []
  eventOut       SFTime   duration_changed
  eventOut       SFBool   isActive
}
Background { 
  eventIn      SFBool   set_bind
  exposedField MFFloat  groundAngle  []         # [0,/2]
  exposedField MFColor  groundColor  []         # [0,1]
  exposedField MFString backUrl      []
  exposedField MFString bottomUrl    []
  exposedField MFString frontUrl     []
  exposedField MFString leftUrl      []
  exposedField MFString rightUrl     []
  exposedField MFString topUrl       []
  exposedField MFFloat  skyAngle     []         # [0,]
  exposedField MFColor  skyColor     0 0 0      # [0,1]
  eventOut     SFBool   isBound
}
Billboard { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField SFVec3f  axisOfRotation 0 1 0     #	(-,)
  exposedField MFNode   children       []
  field        SFVec3f  bboxCenter     0 0 0     #	(-,)
  field        SFVec3f  bboxSize       -1 -1 -1  #	(0,) or -1,-1,-1
}
Box { 
  field    SFVec3f size  2 2 2        #	(0,	)
}
Collision { 
  eventIn      MFNode   addChildren
  eventIn      MFNode   removeChildren
  exposedField MFNode   children        []
  exposedField SFBool   collide         TRUE
  field        SFVec3f  bboxCenter      0 0 0      # (-,)
  field        SFVec3f  bboxSize        -1 -1 -1   # (0,) or -1,-1,-1
  field        SFNode   proxy           NULL
  eventOut     SFTime   collideTime
}
Color { 
  exposedField MFColor color  []         # [0,1]
}
ColorInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFColor keyValue      []    # [0,1]
  eventOut     SFColor value_changed
}
Cone { 
  field     SFFloat   bottomRadius 1        # (0,)
  field     SFFloat   height       2        # (0,)
  field     SFBool    side         TRUE
  field     SFBool    bottom       TRUE
}
Coordinate { 
  exposedField MFVec3f point  []      # (-,)
}
CoordinateInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFVec3f keyValue      []    # (-,)
  eventOut     MFVec3f value_changed
}
Cylinder { 
  field    SFBool    bottom  TRUE
  field    SFFloat   height  2         # (0,)
  field    SFFloat   radius  1         # (0,)
  field    SFBool    side    TRUE
  field    SFBool    top     TRUE
}
CylinderSensor { 
  exposedField SFBool     autoOffset TRUE
  exposedField SFFloat    diskAngle  0.262       # (0,/2)
  exposedField SFBool     enabled    TRUE
  exposedField SFFloat    maxAngle   -1          # [-2,2]
  exposedField SFFloat    minAngle   0           # [-2,2]
  exposedField SFFloat    offset     0           # (-,)
  eventOut     SFBool     isActive
  eventOut     SFRotation rotation_changed
  eventOut     SFVec3f    trackPoint_changed
}
DirectionalLight { 
  exposedField SFFloat ambientIntensity  0        # [0,1]
  exposedField SFColor color             1 1 1    # [0,1]
  exposedField SFVec3f direction         0 0 -1   # (-,)
  exposedField SFFloat intensity         1        # [0,1]
  exposedField SFBool  on                TRUE 
}
ElevationGrid { 
  eventIn      MFFloat  set_height
  exposedField SFNode   color             NULL
  exposedField SFNode   normal            NULL
  exposedField SFNode   texCoord          NULL
  field        MFFloat  height            []      # (-,)
  field        SFBool   ccw               TRUE
  field        SFBool   colorPerVertex    TRUE
  field        SFFloat  creaseAngle       0       # [0,]
  field        SFBool   normalPerVertex   TRUE
  field        SFBool   solid             TRUE
  field        SFInt32  xDimension        0       # [0,)
  field        SFFloat  xSpacing          1.0     # (0,)
  field        SFInt32  zDimension        0       # [0,)
  field        SFFloat  zSpacing          1.0     # (0,)
}
Extrusion { 
  eventIn MFVec2f    set_crossSection
  eventIn MFRotation set_orientation
  eventIn MFVec2f    set_scale
  eventIn MFVec3f    set_spine
  field   SFBool     beginCap         TRUE
  field   SFBool     ccw              TRUE
  field   SFBool     convex           TRUE
  field   SFFloat    creaseAngle      0                # [0,)
  field   MFVec2f    crossSection     [ 1 1, 1 -1, -1 -1,
                                       -1 1, 1  1 ]    # (-,)
  field   SFBool     endCap           TRUE
  field   MFRotation orientation      0 0 1 0          # [-1,1],(-,)
  field   MFVec2f    scale            1 1              # (0,)
  field   SFBool     solid            TRUE
  field   MFVec3f    spine            [ 0 0 0, 0 1 0 ] # (-,)
}
Fog { 
  exposedField SFColor  color            1 1 1      # [0,1]
  exposedField SFString fogType          "LINEAR"
  exposedField SFFloat  visibilityRange  0          # [0,)
  eventIn      SFBool   set_bind
  eventOut     SFBool   isBound
}
FontStyle { 
  field MFString family       "SERIF"
  field SFBool   horizontal   TRUE
  field MFString justify      "BEGIN"
  field SFString language     ""
  field SFBool   leftToRight  TRUE
  field SFFloat  size         1.0          # (0,)
  field SFFloat  spacing      1.0          # [0,)
  field SFString style        "PLAIN"
  field SFBool   topToBottom  TRUE
}
Group { 
  eventIn      MFNode  addChildren
  eventIn      MFNode  removeChildren
  exposedField MFNode  children      []
  field        SFVec3f bboxCenter    0 0 0     #	(-,)
  field        SFVec3f bboxSize      -1 -1 -1  #	(0,)	or	-1,-1,-1
}
ImageTexture { 
  exposedField MFString url     []
  field        SFBool   repeatS TRUE
  field        SFBool   repeatT TRUE
}
IndexedFaceSet { 
  eventIn       MFInt32 set_colorIndex
  eventIn       MFInt32 set_coordIndex
  eventIn       MFInt32 set_normalIndex
  eventIn       MFInt32 set_texCoordIndex
  exposedField  SFNode  color             NULL
  exposedField  SFNode  coord             NULL
  exposedField  SFNode  normal            NULL
  exposedField  SFNode  texCoord          NULL
  field         SFBool  ccw               TRUE
  field         MFInt32 colorIndex        []        # [-1,)
  field         SFBool  colorPerVertex    TRUE
  field         SFBool  convex            TRUE
  field         MFInt32 coordIndex        []        # [-1,)
  field         SFFloat creaseAngle       0         # [0,)
  field         MFInt32 normalIndex       []        # [-1,)
  field         SFBool  normalPerVertex   TRUE
  field         SFBool  solid             TRUE
  field         MFInt32 texCoordIndex     []        # [-1,)
}
IndexedLineSet { 
  eventIn       MFInt32 set_colorIndex
  eventIn       MFInt32 set_coordIndex
  exposedField  SFNode  color             NULL
  exposedField  SFNode  coord             NULL
  field         MFInt32 colorIndex        []     # [-1,)
  field         SFBool  colorPerVertex    TRUE
  field         MFInt32 coordIndex        []     # [-1,)
}
Inline { 
  exposedField MFString url        []
  field        SFVec3f  bboxCenter 0 0 0     #	(-,)
  field        SFVec3f  bboxSize   -1 -1 -1  #	(0,)	or	-1,-1,-1
}
LOD { 
  exposedField MFNode  level    [] 
  field        SFVec3f center   0 0 0    #	(-,)
  field        MFFloat range    []       #	(0,)
}
Material { 
  exposedField SFFloat ambientIntensity  0.2         #	[0,1]
  exposedField SFColor diffuseColor      0.8 0.8 0.8 #	[0,1]
  exposedField SFColor emissiveColor     0 0 0       #	[0,1]
  exposedField SFFloat shininess         0.2         #	[0,1]
  exposedField SFColor specularColor     0 0 0       #	[0,1]
  exposedField SFFloat transparency      0           #	[0,1]
}
MovieTexture { 
  exposedField SFBool   loop             FALSE
  exposedField SFFloat  speed            1.0      #	(-,)
  exposedField SFTime   startTime        0        #	(-,)
  exposedField SFTime   stopTime         0        #	(-,)
  exposedField MFString url              []
  field        SFBool   repeatS          TRUE
  field        SFBool   repeatT          TRUE
  eventOut     SFTime   duration_changed
  eventOut     SFBool   isActive
}
NavigationInfo { 
  eventIn      SFBool   set_bind
  exposedField MFFloat  avatarSize      [0.25, 1.6, 0.75] #	[0,)
  exposedField SFBool   headlight       TRUE
  exposedField SFFloat  speed           1.0               #	[0,)
  exposedField MFString type            ["WALK", "ANY"]
  exposedField SFFloat  visibilityLimit 0.0               #	[0,)
  eventOut     SFBool   isBound
}
Normal { 
  exposedField MFVec3f vector  []   #	(-,)
}
NormalInterpolator { 
  eventIn      SFFloat set_fraction       #	(-,)
  exposedField MFFloat key           []   #	(-,)
  exposedField MFVec3f keyValue      []   #	(-,)
  eventOut     MFVec3f value_changed
}
OrientationInterpolator { 
  eventIn      SFFloat    set_fraction      #	(-,)
  exposedField MFFloat    key           []  #	(-,)
  exposedField MFRotation keyValue      []  # [-1,1],(-,)
  eventOut     SFRotation value_changed
}
PixelTexture { 
  exposedField SFImage  image      0 0 0    # see 5.5, SFImage
  field        SFBool   repeatS    TRUE
  field        SFBool   repeatT    TRUE
}
PlaneSensor { 
  exposedField SFBool  autoOffset          TRUE
  exposedField SFBool  enabled             TRUE
  exposedField SFVec2f maxPosition         -1 -1     # (-,)
  exposedField SFVec2f minPosition         0 0       # (-,)
  exposedField SFVec3f offset              0 0 0     # (-,)
  eventOut     SFBool  isActive
  eventOut     SFVec3f trackPoint_changed
  eventOut     SFVec3f translation_changed
}
PointLight { 
  exposedField SFFloat ambientIntensity  0       # [0,1]
  exposedField SFVec3f attenuation       1 0 0   # [0,)
  exposedField SFColor color             1 1 1   # [0,1]
  exposedField SFFloat intensity         1       # [0,1]
  exposedField SFVec3f location          0 0 0   # (-,)
  exposedField SFBool  on                TRUE 
  exposedField SFFloat radius            100     # [0,)
}
PointSet { 
  exposedField  SFNode  color      NULL
  exposedField  SFNode  coord      NULL
}
PositionInterpolator { 
  eventIn      SFFloat set_fraction        # (-,)
  exposedField MFFloat key           []    # (-,)
  exposedField MFVec3f keyValue      []    # (-,)
  eventOut     SFVec3f value_changed
}
ProximitySensor { 
  exposedField SFVec3f    center      0 0 0    # (-,)
  exposedField SFVec3f    size        0 0 0    # [0,)
  exposedField SFBool     enabled     TRUE
  eventOut     SFBool     isActive
  eventOut     SFVec3f    position_changed
  eventOut     SFRotation orientation_changed
  eventOut     SFTime     enterTime
  eventOut     SFTime     exitTime
}
ScalarInterpolator { 
  eventIn      SFFloat set_fraction         # (-,)
  exposedField MFFloat key           []     # (-,)
  exposedField MFFloat keyValue      []     # (-,)
  eventOut     SFFloat value_changed
}
Script { 
  exposedField MFString url           [] 
  field        SFBool   directOutput  FALSE
  field        SFBool   mustEvaluate  FALSE
  # And any number of:
	#eventIn      eventType eventName
	#field        fieldType fieldName initialValue
	#eventOut     eventType eventName
	# AR note: This has been hacked !!
	dummy		eventType	eventIn
	dummy		eventType	eventOut
	dummy 		fieldType	field
}
Shape { 

  exposedField SFNode appearance NULL
  exposedField SFNode geometry   NULL
}
Sound { 
  exposedField SFVec3f  direction     0 0 1   # (-,)
  exposedField SFFloat  intensity     1       # [0,1]
  exposedField SFVec3f  location      0 0 0   # (-,)
  exposedField SFFloat  maxBack       10      # [0,)
  exposedField SFFloat  maxFront      10      # [0,)
  exposedField SFFloat  minBack       1       # [0,)
  exposedField SFFloat  minFront      1       # [0,)
  exposedField SFFloat  priority      0       # [0,1]
  exposedField SFNode   source        NULL
  field        SFBool   spatialize    TRUE
}
Sphere { 
  field SFFloat radius  1    # (0,)
}
SphereSensor { 
  exposedField SFBool     autoOffset        TRUE
  exposedField SFBool     enabled           TRUE
  exposedField SFRotation offset            0 1 0 0  # [-1,1],(-,)
  eventOut     SFBool     isActive
  eventOut     SFRotation rotation_changed
  eventOut     SFVec3f    trackPoint_changed
}
SpotLight { 
  exposedField SFFloat ambientIntensity  0         # [0,1]
  exposedField SFVec3f attenuation       1 0 0     # [0,)
  exposedField SFFloat beamWidth         1.570796  # (0,/2]
  exposedField SFColor color             1 1 1     # [0,1]
  exposedField SFFloat cutOffAngle       0.785398  # (0,/2]
  exposedField SFVec3f direction         0 0 -1    # (-,)
  exposedField SFFloat intensity         1         # [0,1]
  exposedField SFVec3f location          0 0 0     # (-,)
  exposedField SFBool  on                TRUE
  exposedField SFFloat radius            100       # [0,)
}
Switch { 
  exposedField    MFNode  choice      []
  exposedField    SFInt32 whichChoice -1    # [-1,)
}
Text { 
  exposedField  MFString string    []
  exposedField  SFNode   fontStyle NULL
  exposedField  MFFloat  length    []      # [0,)
  exposedField  SFFloat  maxExtent 0.0     # [0,)
}
TextureCoordinate { 
  exposedField MFVec2f point  []      # (-,)
}
TextureTransform { 
  exposedField SFVec2f center      0 0     # (-,)
  exposedField SFFloat rotation    0       # (-,)
  exposedField SFVec2f scale       1 1     # (-,)
  exposedField SFVec2f translation 0 0     # (-,)
}
TimeSensor { 
  exposedField SFTime   cycleInterval 1       # (0,)
  exposedField SFBool   enabled       TRUE
  exposedField SFBool   loop          FALSE
  exposedField SFTime   startTime     0       # (-,)
  exposedField SFTime   stopTime      0       # (-,)
  eventOut     SFTime   cycleTime
  eventOut     SFFloat  fraction_changed      # [0,	1]
  eventOut     SFBool   isActive
  eventOut     SFTime   time
}
TouchSensor { 
  exposedField SFBool  enabled TRUE
  eventOut     SFVec3f hitNormal_changed
  eventOut     SFVec3f hitPoint_changed
  eventOut     SFVec2f hitTexCoord_changed
  eventOut     SFBool  isActive
  eventOut     SFBool  isOver
  eventOut     SFTime  touchTime
}
Transform { 
  eventIn      MFNode      addChildren
  eventIn      MFNode      removeChildren
  exposedField SFVec3f     center           0 0 0    #	(-,)
  exposedField MFNode      children         []
  exposedField SFRotation  rotation         0 0 1 0  # [-1,1],(-,)
  exposedField SFVec3f     scale            1 1 1    #	(0,)
  exposedField SFRotation  scaleOrientation 0 0 1 0  # [-1,1],(-,)
  exposedField SFVec3f     translation      0 0 0    #	(-,)
  field        SFVec3f     bboxCenter       0 0 0    #	(-,)
  field        SFVec3f     bboxSize         -1 -1 -1 #	(0,)	or	-1,-1,-1
} 
Viewpoint { 
  eventIn      SFBool     set_bind
  exposedField SFFloat    fieldOfView    0.785398  #	(0,)
  exposedField SFBool     jump           TRUE
  exposedField SFRotation orientation    0 0 1 0   # [-1,1],(-,)
  exposedField SFVec3f    position       0 0 10    #	(-,)
  field        SFString   description    ""
  eventOut     SFTime     bindTime
  eventOut     SFBool     isBound
}
VisibilitySensor { 
  exposedField SFVec3f center   0 0 0      #	(-,)
  exposedField SFBool  enabled  TRUE
  exposedField SFVec3f size     0 0 0      #	[0,)
  eventOut     SFTime  enterTime
  eventOut     SFTime  exitTime
  eventOut     SFBool  isActive
}
WorldInfo { 
  field MFString info  []
  field SFString title ""
}
'! !

!VRMLNodeSpec class methodsFor: 'vrml97' stamp: 'ar 3/12/98 21:04'!
vrml97Nodes
	"VRMLNodeSpec initialize"
	| stream |
	stream := VRMLStream on: (ReadStream on: self vrml97NodeDefinition).
	^VRMLNodeParser new parseDefinitions: stream! !


!VRMLNodeSpec class methodsFor: 'class initialization' stamp: 'ar 8/17/1999 19:33'!
initialize
	"VRMLNodeSpec initialize"
	VRMLStream initialize.
	VRMLNodeParser initialize.
	CurrentSpecs := self vrml97Nodes.
	UndefinedSpec := VRMLNodeSpec name:'Undefined' attributes: #().
	CurrentSpecs doWithIndex:[:nodeSpec :index|
		nodeSpec nodeId: index.
	].! !


!VRMLNodeSpec class methodsFor: 'instance creation' stamp: 'ar 3/12/98 22:16'!
name: aString attributes: aCollection
	^self new name: aString attributes: aCollection! !
VRMLUnhandledNode subclass: #VRMLProtoClassNode
	instanceVariableNames: 'protoSpec protoValues '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLProtoClassNode methodsFor: 'initialize' stamp: 'ar 3/13/98 01:21'!
fromSpec: aSpec
	protoSpec := aSpec! !


!VRMLProtoClassNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:31'!
nodeSpec
	^protoSpec! !

!VRMLProtoClassNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:36'!
protoValues
	^protoValues! !

!VRMLProtoClassNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:31'!
protoValues: anObject
	protoValues _ anObject! !


!VRMLProtoClassNode methodsFor: 'printing' stamp: 'ar 3/13/98 01:43'!
printOn: aStream indent: aLevel
	aStream 
		nextPutAll:'PROTO ';
		nextPutAll: self nodeSpec name;
		nextPutAll:' [';
		crtab: aLevel+1.
	self nodeSpec attributes do:[:attr|
		attr printOn: aStream indent: aLevel+1.
	].
	aStream nextPutAll:'] {'.
	aStream crtab: aLevel.
	self protoValues do:[:value|
		value printOn: aStream indent: aLevel+1.
		aStream crtab: aLevel.
	].
	aStream nextPut:$}.
! !


!VRMLProtoClassNode methodsFor: 'copying' stamp: 'ar 3/13/98 14:26'!
vrmlProtoCopy
	^self shallowCopy protoValues: (self protoValues collect:[:each| each vrmlProtoCopy])! !
VRMLGenericNode subclass: #VRMLProtoNode
	instanceVariableNames: 'nodeSpec protoType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLProtoNode methodsFor: 'initialize' stamp: 'ar 3/13/98 14:23'!
fromSpec: aNodeSpec
	nodeSpec := aNodeSpec.
	super fromSpec: aNodeSpec.
	protoType := (aNodeSpec attributeNamed:'protoType') value vrmlProtoCopy.! !


!VRMLProtoNode methodsFor: 'accessing' stamp: 'ar 3/13/98 00:24'!
nodeSpec
	^nodeSpec! !


!VRMLProtoNode methodsFor: 'testing' stamp: 'ar 3/13/98 00:27'!
isPrototype
	^true! !


!VRMLProtoNode methodsFor: 'enumerating' stamp: 'ar 8/18/1999 10:02'!
doWith: aVRMLEnumerator
	protoType doWith: aVRMLEnumerator! !
Object subclass: #VRMLScene
	instanceVariableNames: 'fileURL nodes defs protos actions sourceNodes targetNodes '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/12/98 20:26'!
addNode: aVRMLNode
	self nodes add: aVRMLNode! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/13/98 00:41'!
addPrototype: aCollection spec: aNodeSpec
	self prototypes at: aNodeSpec put: aCollection! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/13/98 00:57'!
defineNode: nodeName value: aVRMLNode
	self definedNodes at: nodeName put: aVRMLNode.
! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/12/98 20:25'!
definedNode: nodeName 
	^self definedNodes at: nodeName! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/12/98 20:25'!
definedNodes
	^defs ifNil:[defs := Dictionary new]! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/12/98 20:23'!
nodes
	^nodes ifNil:[nodes := OrderedCollection new].! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/13/98 01:40'!
prototypeAt: aNodeSpec
	^self prototypes at: aNodeSpec ifAbsent:[Array with:VRMLUndefinedNode new].! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/13/98 00:41'!
prototypes
	^protos ifNil:[protos := Dictionary new].! !

!VRMLScene methodsFor: 'node accessing' stamp: 'ar 3/13/98 13:43'!
renderNodes
	^self nodes! !


!VRMLScene methodsFor: 'printing' stamp: 'ar 3/12/98 21:55'!
printOn: aStream

	VRMLWriter default writeScene: self on: aStream asVRMLStream.! !


!VRMLScene methodsFor: 'actions' stamp: 'ar 8/17/1999 22:13'!
actions
	^actions ifNil:[actions _ Dictionary new].! !

!VRMLScene methodsFor: 'actions' stamp: 'ar 5/4/2000 16:35'!
eventSelectorFor: aString
	"Make an ST80 type message from aString"
	| selector |
	(aString beginsWith: 'set_') ifTrue:[
		selector _ aString copyFrom: 5 to: aString size.
	] ifFalse:[
		selector _ aString.
	].
	selector _ selector copyReplaceAll:'_' with: ''.
	selector _ selector copyWith: $:.
	^selector asSymbol! !

!VRMLScene methodsFor: 'actions' stamp: 'ar 8/31/2000 18:48'!
routeFrom: fromNode event: outEventName to: toNode event: inEventName
	| source target |
	sourceNodes ifNil:[
		sourceNodes _ IdentitySet new.
		targetNodes _ IdentitySet new].
	source _ self definedNode: fromNode.
	target _ self definedNode: toNode.
	sourceNodes add: source.
	targetNodes add: target.
	source
		when: outEventName asSymbol
		send: (self eventSelectorFor: inEventName)
		to: target! !


!VRMLScene methodsFor: 'enumerating' stamp: 'ar 8/18/1999 19:45'!
doWith: aVRMLEnumerator
	nodes do:[:node| node doWith: aVRMLEnumerator].! !


!VRMLScene methodsFor: 'accessing' stamp: 'ar 9/14/1999 20:03'!
fileURL
	^fileURL! !

!VRMLScene methodsFor: 'accessing' stamp: 'ar 9/14/1999 20:04'!
fileURL: aURL
	fileURL _ aURL! !

!VRMLScene methodsFor: 'accessing' stamp: 'ar 8/31/2000 18:56'!
sourceNodes
	^sourceNodes ifNil:[#()].! !

!VRMLScene methodsFor: 'accessing' stamp: 'ar 8/31/2000 18:56'!
targetNodes
	^targetNodes ifNil:[#()].! !
VRMLGenericNode subclass: #VRMLStandardNode
	instanceVariableNames: 'nodeId '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLStandardNode methodsFor: 'initialize' stamp: 'ar 3/13/98 00:23'!
fromSpec: aNodeSpec
	nodeId := aNodeSpec nodeId.
	super fromSpec: aNodeSpec! !


!VRMLStandardNode methodsFor: 'accessing' stamp: 'ar 3/13/98 00:23'!
nodeSpec
	^VRMLNodeSpec currentSpecs at: nodeId! !
Object subclass: #VRMLStream
	instanceVariableNames: 'theStream backups '
	classVariableNames: 'DigitValues NonFirstChars NonRestChars SeparatorChars '
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLStream commentStamp: '<historical>' prior: 0!
A VRMLStream supports reading/writing of UTF8 characters and the basic VRML types such as Int32, Float, Bool, and String.!


!VRMLStream methodsFor: 'initialize' stamp: 'ar 9/17/1999 00:20'!
on: refStream
	theStream := refStream.
	backups := OrderedCollection new: 100.! !

!VRMLStream methodsFor: 'initialize' stamp: 'ar 9/17/1999 00:20'!
reset
	backups := OrderedCollection new: 100.
	theStream reset.! !

!VRMLStream methodsFor: 'initialize' stamp: 'ls 12/4/1999 21:07'!
resetAndCheckVersion
	"Check for #VRML V2.0 utf8"
	| version charSet char |
	self reset.
	"Check basic type of VRML file"
	'#VRML V' do:[:c| theStream next = c ifFalse:[^nil]].
	version := theStream next: 3.
	charSet := WriteStream on: String new.
	theStream next = Character space ifTrue:[
		[char := theStream next.
		char asciiValue = 32 or:[char asciiValue = 13 or:[char asciiValue =
10]]
		] whileFalse:[ charSet nextPut: char].
	].
	self reset.
	^Array with: version with: charSet contents.! !


!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/14/1999 20:05'!
name
	^theStream name! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/11/98 22:52'!
next
	^self nextChar! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/17/1999 00:20'!
nextByte
	| byte |
	byte _ theStream next.
	byte == nil
		ifTrue:[^nil]
		ifFalse:[^byte asInteger]! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/12/98 18:29'!
nextPut: aChar
	^self nextPutChar: aChar.! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/12/98 18:30'!
nextPutAll: aCollection
	aCollection do: [:v | self nextPut: v].
	^aCollection! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/11/98 22:52'!
peekFor: anObject
	| nextObject |
	self atEnd ifTrue: [^false].
	nextObject _ self next.
	"peek for matching element"
	anObject = nextObject ifTrue: [^true].
	"gobble it if found"
	self position: self position - 1.
	^false! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/17/1999 00:19'!
position
	^theStream position! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/17/1999 00:19'!
position: aNumber
	theStream position: aNumber.! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/13/98 02:01'!
size
	^theStream size! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/17/1999 00:20'!
skip: n
	theStream skip: n.! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 3/11/98 22:25'!
skipLine
	| char |
	[char := self nextChar.
	char asciiValue = 13 or:[char asciiValue = 10]] whileFalse.
! !

!VRMLStream methodsFor: 'accessing' stamp: 'ar 9/17/1999 00:12'!
skipSeparators
	| char |
	[(char := self nextChar) == nil ifTrue:[^self].
	SeparatorChars includes: char asciiValue] whileTrue:[
		char = $# ifTrue:[self skipLine].
	].
	self skip: -1.! !


!VRMLStream methodsFor: 'testing' stamp: 'ar 3/11/98 22:28'!
atEnd
	^theStream atEnd! !


!VRMLStream methodsFor: 'backup-restore' stamp: 'ar 3/11/98 19:39'!
backup
	backups addLast: self position.! !

!VRMLStream methodsFor: 'backup-restore' stamp: 'ar 3/11/98 19:40'!
discard
	backups removeLast! !

!VRMLStream methodsFor: 'backup-restore' stamp: 'ar 3/11/98 19:40'!
restore
	self position: backups removeLast.! !

!VRMLStream methodsFor: 'backup-restore' stamp: 'ar 3/11/98 19:40'!
restoreIf: aBoolean
	aBoolean
		ifTrue:[self restore]
		ifFalse:[self discard]! !


!VRMLStream methodsFor: 'character reading' stamp: 'ar 9/17/1999 00:08'!
firstChar
	| char |
	self backup.
	char := self utf8Char.
	(char == nil or:[NonFirstChars includes: char asciiValue]) ifTrue:[
		self restore.
		^nil
	] ifFalse:[
		self discard.
		^char
	].! !

!VRMLStream methodsFor: 'character reading' stamp: 'ar 3/11/98 22:30'!
nextChar
	^self utf8Char! !

!VRMLStream methodsFor: 'character reading' stamp: 'ar 3/11/98 22:37'!
peekChar
	| pos char |
	pos := self position.
	char := self nextChar.
	self position: pos.
	^char! !

!VRMLStream methodsFor: 'character reading' stamp: 'ar 9/17/1999 00:13'!
restChar
	| char |
	self backup.
	char := self utf8Char.
	(char == nil or:[NonRestChars includes: char asciiValue]) ifTrue:[
		self restore.
		^nil
	] ifFalse:[
		self discard.
		^char
	].! !

!VRMLStream methodsFor: 'character reading' stamp: 'ar 9/17/1999 00:08'!
utf8Char
	"Note: we silently clamp every char to US ASCII range"
	| firstByte lastByte maskValue prevByte |
	firstByte := lastByte := self nextByte.
	firstByte == nil ifTrue:[^nil].
	firstByte < 128 ifTrue:[^Character value: firstByte].
	self halt.
	"More than one byte"
	maskValue := 2r00100000.
	[prevByte := lastByte.
	lastByte := self nextByte.
	(firstByte bitAnd: maskValue) = 0] whileTrue:[
		maskValue := maskValue bitShift: -1.
	].
	^Character value: (lastByte bitAnd: 2r00111111) + ((prevByte bitAnd: 1) bitShift: 6).
! !


!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/12/98 23:41'!
next: anInteger
   | array |
array _ String new: anInteger.
    1 to: anInteger do: [:i |
        array at: i put: self next].
    ^ array! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/11/98 20:41'!
readBool
	| string bool |
	self backup.
	string := self readName.
	string = 'TRUE' ifTrue:[bool := true].
	string = 'FALSE' ifTrue:[bool := false].
	self restoreIf: bool isNil.
	^bool! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 5/4/2000 15:48'!
readColor
	^self readFloatVector: 3 do:[:array|
		B3DColor4 r: (array at: 1) g: (array at: 2) b: (array at: 3) a: 1.0
	].
! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/11/98 21:21'!
readDouble
	^self readFloat! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 9/15/1999 16:03'!
readFloat
	| intVal fracVal expVal char s floatValue fracExp negative |
	self backup.
	s := ReadWriteStream on: (String new: 10).
	fracVal := 0.0.
	"Read sign"
	negative _ self peekChar = $-.
	negative ifTrue:[self skip: 1].
	"Read integer part"
	(self peekChar = $.) 
		ifTrue:[intVal := 0]
		ifFalse:[intVal := self readInt32].
	"Read fraction part"
	self peekChar = $. ifTrue:[
		self skip: 1.
		fracExp := 1.
		[(char := self nextChar) isDigit] whileTrue:[s nextPut: char. fracExp := fracExp * 10].
		self skip: -1.
		s reset.
		fracVal := Integer readFrom: s.
		fracVal := fracVal asFloat / fracExp asFloat.
	].
	"Check for exponent"
	self peekChar asLowercase = $e ifTrue:[
		self skip: 1.
		expVal := self readInt32.
	] ifFalse:[expVal := 1].
	floatValue := intVal asFloat + fracVal.
	expVal = 1 ifFalse:[ floatValue := floatValue raisedTo: expVal].
	self discard.
	negative
		ifTrue:[^0.0 - floatValue]
		ifFalse:[^floatValue]! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/12/98 01:05'!
readFloatVector: n do: aBlock
	| vec value |
	self backup.
	vec := Array new: n.
	1 to: n do:[:i |
		value := self readFloat.
		value isNil ifTrue:[self restore. ^nil].
		vec at: i put: value.
		i < n ifTrue:[self skipSeparators].
	].
	self discard.
	^aBlock value: vec! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/12/98 01:23'!
readImage
	| width height nComponents pixels size |
	width := self readInt32.
	self skipSeparators.
	height := self readInt32.
	size := width * height.
	self skipSeparators.
	nComponents := self readInt32.
	self skipSeparators.
	nComponents <= 4 ifTrue:[
		pixels := Bitmap new: size.
	] ifFalse:[
		pixels := Array new: size.
	].
	1 to: size do:[:i|
		self skipSeparators.
		pixels at: i put: self readInt32.
	].
	^Array with: width with: height with: nComponents with: pixels.! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 9/17/1999 00:10'!
readInt32
	| negative intVal char |
	self backup.
	negative := false.
	"Read sign"
	char := self nextChar.
	char isDigit ifFalse:[
		char = $- ifTrue:[
			negative := true
		] ifFalse:[
			char = $+ ifFalse:[ self restore. ^nil]].
		char := self nextChar].
	(char = $0 and:[self peekChar asLowercase = $x]) ifTrue:[
		"hexadecimal notation"
		self skip: 1.
		intVal := self readInteger: 16.
	] ifFalse:[
		"decimal notation"
		self skip: -1.
		intVal := self readInteger: 10.
	].
	self discard.
	^negative
		ifTrue:[0 - intVal]
		ifFalse:[intVal]! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/12/98 18:39'!
readName
	| out char |
	self skipSeparators.
	out := WriteStream on: (String new: 20).
	char := self firstChar.
	char ifNil:[^nil].
	out nextPut: char.
	[char := self restChar.
	char notNil] whileTrue:[
		out nextPut: char.
	].
	^out contents! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 5/4/2000 15:49'!
readRotation
	^self readFloatVector: 4 do:[:array|
		B3DRotation radiansAngle: (array at: 4) axis: 
			(B3DVector3 x: (array at: 1) y: (array at: 2) z: (array at: 3))
	].! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/11/98 21:19'!
readString
	| out char |
	out := WriteStream on: (String new: 10).
	self peekChar = $" ifFalse:[ ^nil].
	self skip: 1.
	[char := self nextChar.
	char = $\ ifTrue:[char := self nextChar].
	char = $"] whileFalse:[out nextPut: char].
	^out contents! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 3/11/98 21:20'!
readTime
	^self readDouble! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 5/4/2000 15:50'!
readVec2f
	^self readFloatVector: 2 do:[:array| B3DVector2 x: (array at: 1) y: (array at: 2)].! !

!VRMLStream methodsFor: 'reading data' stamp: 'ar 5/4/2000 15:50'!
readVec3f

	^self readFloatVector: 3 do:[:array| 
		B3DVector3 x: (array at: 1) y: (array at: 2) z: (array at: 3)].! !


!VRMLStream methodsFor: 'converting' stamp: 'ar 3/12/98 00:33'!
asVRMLStream
	^self! !


!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:20'!
writeBool: aBoolean
	self nextPutAll: (aBoolean ifTrue:['TRUE'] ifFalse:['FALSE']).
! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:21'!
writeDouble: aDouble
	self writeFloat: aDouble! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:22'!
writeFloat: aFloat
	self nextPutAll: aFloat printString.! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:26'!
writeFloatVector: aCollection
	1 to: aCollection size do:[:i|
		self writeFloat: (aCollection at: i).
		i < aCollection size ifTrue:[self space].
	].! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:24'!
writeImage: anArray
	| width height nComponents pixels size |
	width := anArray at: 1.
	height := anArray at: 2.
	size := width * height.
	nComponents := anArray at: 3.
	pixels := anArray at: 4.

	self writeInt32: width.
	self space.
	self writeInt32: height.
	self space.
	self writeInt32: nComponents.
	self space.
	1 to: size do:[:i|
		self writeInt32: (pixels at: i).
	].
! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:25'!
writeInt32: anInteger
	self nextPutAll: anInteger printString.! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:25'!
writeRotation: anArray
	self writeFloatVector: anArray.! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:27'!
writeString: aString
	self nextPut:$".
	aString do:[:char|
		char = $" ifTrue:[self nextPut:$\].
		char = $\ ifTrue:[self nextPut:$\].
		self nextPut: char.
	].
	self nextPut:$".
! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:28'!
writeTime: aTime
	self writeDouble: aTime! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:28'!
writeVec2f: anArray
	self writeFloatVector: anArray.! !

!VRMLStream methodsFor: 'writing data' stamp: 'ar 3/12/98 18:28'!
writeVec3f: anArray
	self writeFloatVector: anArray.! !


!VRMLStream methodsFor: 'character writing' stamp: 'ar 3/12/98 21:55'!
cr
	theStream cr.! !

!VRMLStream methodsFor: 'character writing' stamp: 'ar 3/13/98 02:35'!
crtab
	self crtab: 1.! !

!VRMLStream methodsFor: 'character writing' stamp: 'ar 3/13/98 02:35'!
crtab: level
	theStream cr.
	theStream next: level put: Character space! !

!VRMLStream methodsFor: 'character writing' stamp: 'ar 3/12/98 18:39'!
nextPutChar: aChar
	| firstChar lastChar |
	aChar asciiValue < 128 ifTrue:[^theStream nextPut: aChar].
	firstChar := 2r11000000 + (aChar asciiValue bitShift: -6).
	lastChar := 2r10000000 + (aChar asciiValue bitAnd: 2r00111111).
	theStream nextPut: firstChar asCharacter; nextPut: lastChar asCharacter.
	^aChar! !

!VRMLStream methodsFor: 'character writing' stamp: 'ar 3/12/98 19:20'!
space
	theStream space.! !


!VRMLStream methodsFor: 'writing fields' stamp: 'ar 3/12/98 20:50'!
writeColor: aColor
	self writeFloat: (aColor red roundTo: 0.001).
	self space.
	self writeFloat: (aColor green roundTo: 0.001).
	self space.
	self writeFloat: (aColor blue roundTo: 0.001).
! !


!VRMLStream methodsFor: 'private-reading' stamp: 'ar 9/17/1999 00:01'!
digitValueOf: char
	^DigitValues at: char asciiValue + 1! !

!VRMLStream methodsFor: 'private-reading' stamp: 'ar 9/17/1999 00:00'!
readInteger: base 
	"Optimized version of Integer>>readFrom:base: for the VRML stream"
	| digit value neg startPos aStream char |
	aStream _ self.
	char _ aStream next.
	char = $-
		ifTrue:[	neg _ true.
				char _ aStream next]
		ifFalse:[	neg _ false.
				char = $+ ifTrue:[char _ aStream next]].
	value _ 0.
	startPos _ aStream position-1.
	[char == nil] whileFalse:[
		digit _ self digitValueOf: char.
		(digit < 0 or: [digit >= base]) ifTrue:[
			aStream skip: -1.
			aStream position = startPos ifTrue: [self error: 'At least one digit expected here'].
			neg ifTrue: [^ 0 - value].
			^ value
		] ifFalse: [value _ value * base + digit].
		char _ aStream next].
	neg ifTrue: [^ 0 - value].
	^ value! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLStream class
	instanceVariableNames: ''!

!VRMLStream class methodsFor: 'class initialization' stamp: 'ar 9/17/1999 00:04'!
initialize
	"VRMLStream initialize"
	NonFirstChars := Set new: 100.
	NonFirstChars 
		addAll: (16r30 to: 16r39);
		addAll: (16r0 to: 16r20);
		addAll: #(16r22 16r23 16r27 16r2B 16r2C 16r2D 16r2E 16r5B 16r5C 16r5D 16r7B 16r7D 16r7F).
	NonRestChars := Set new: 100.
	NonRestChars
		addAll: (16r0 to: 16r20);
		addAll: #(16r22 16r23 16r27 16r2C 16r2E 16r5B 16r5C 16r5D 16r7B 16r7D 16r7F).

	SeparatorChars := Set new: 10.
	SeparatorChars addAll: #(16r0D 16r0A 16r20 16r09 16r2C 16r23).

	DigitValues _ Array new: 256.
	DigitValues atAllPut: -1.
	0 to: $9 asciiValue do:[:i|
		DigitValues at: i+1 put: i - $0 asciiValue].
	$A asciiValue to: $Z asciiValue do:[:i|
		DigitValues at: i+1 put: i - $A asciiValue + 10].
	0 to: 255 do:[:i|
		(DigitValues at: i+1) = (Character value: i) digitValue
			ifFalse:[^self error:'Digit value initialization failed'].
	].! !


!VRMLStream class methodsFor: 'instance creation' stamp: 'ar 3/11/98 22:20'!
on: refStream
	^self new on: refStream! !
VRMLBaseNode subclass: #VRMLUndefinedNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLUndefinedNode methodsFor: 'accessing' stamp: 'ar 3/13/98 01:27'!
nodeSpec
	^VRMLNodeSpec undefinedSpec! !
VRMLBaseNode subclass: #VRMLUnhandledNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!
VRMLNamedNode subclass: #VRMLUseNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML BaseNodes'!

!VRMLUseNode methodsFor: 'printing' stamp: 'ar 3/12/98 22:43'!
printOn: aVRMLStream indent: aLevel

	aVRMLStream 
		nextPutAll: 'USE ';
		nextPutAll: name;
		space.! !
VRMLEnumerator subclass: #VRMLWonderlandBuilder
	instanceVariableNames: 'myWonderland scene attributes baseActor currentActor defaultCamera progress '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLWonderlandBuilder commentStamp: '<historical>' prior: 0!
This class builds a Wonderland representation from a given scene.!


!VRMLWonderlandBuilder methodsFor: 'initialize' stamp: 'ar 9/14/1999 23:33'!
initializeFor: aWonderland
	myWonderland _ aWonderland.
	defaultCamera _ aWonderland getDefaultCamera.! !

!VRMLWonderlandBuilder methodsFor: 'initialize' stamp: 'ar 8/18/1999 19:46'!
on: aVRMLScene
	scene _ aVRMLScene! !


!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/14/1999 23:57'!
baseActor
	^baseActor! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/14/1999 23:57'!
baseActor: aWonderlandActor
	baseActor _ aWonderlandActor.
	self currentActor: baseActor.! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/15/1999 16:29'!
buildActors
	"Using the given VRML scene build a set of actors for Wonderland"
	attributes _ Dictionary new.
	Utilities informUserDuring:[:bar| 
		progress _ bar.
		scene doWith: self].! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/14/1999 19:39'!
buildActorsFor: aWonderland
	"Using the given VRML scene build a set of actors for Wonderland"
	self initializeFor: aWonderland.
	self buildActors.! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 8/26/1999 12:28'!
createActorFor: aMesh
	^self createActorFor: aMesh suffix:''! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/16/1999 19:52'!
createActorFor: aMesh defaultName: aString
	^self createActorFor: aMesh
			name: (attributes at: #currentName ifAbsent:[aString])
			suffix: ''! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/16/1999 23:23'!
createActorFor: aMesh name: aString suffix: suffix
	| actor |
	actor _ myWonderland createSimpleActor: aMesh 
					named: aString, suffix
					parent: currentActor.
	"actor setMaterial: (attributes at: #currentMaterial ifAbsent:[nil])."
	aMesh == nil ifFalse:[attributes at: #currentShape put: actor].
	^actor! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/9/1999 12:29'!
createActorFor: aMesh suffix: aString
	^self createActorFor: aMesh
			name: (attributes at: #currentName ifAbsent:['unnamed'])
			suffix: aString! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/14/1999 19:43'!
currentActor
	^currentActor! !

!VRMLWonderlandBuilder methodsFor: 'building actors' stamp: 'ar 9/14/1999 19:43'!
currentActor: aWonderlandActor
	currentActor _ aWonderlandActor! !


!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:02'!
doAppearance: node
	| attr |
	(attr _ node attributeValueNamed: 'material') notNil
		ifTrue:[attr doWith: self].
	(attr _ node attributeValueNamed: 'texture') notNil
		ifTrue:[attr doWith: self].
	(attr _ node attributeValueNamed: 'textureTransform') notNil
		ifTrue:[attr doWith: self].
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 18:58'!
doBox: node
	| size box |
	size _ (node attributeValueNamed:'size').
	box _ B3DIndexedMesh vrml97Box.
	self createActorFor: box defaultName:'box'.
	currentActor resizeRightNow: size first @ size second @ size third undoable: false.
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 18:58'!
doColor: node
	| colors |
	colors _ (node attributeValueNamed: 'color').
	attributes at: #currentColors put: (colors collect:[:c| c asB3DColor])! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 18:58'!
doCone: node
	| radius height doSide doBottom cone |
	radius _ (node attributeValueNamed:'bottomRadius').
	height _ (node attributeValueNamed:'height').
	doSide _ (node attributeValueNamed:'side').
	doBottom _ (node attributeValueNamed:'bottom').
	cone _ B3DIndexedMesh vrml97Cone: doSide bottom: doBottom.
	self createActorFor: cone defaultName:'cone'.
	currentActor resizeRightNow: radius @ height @ radius undoable: false.
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 8/31/2000 19:16'!
doCoordinate: node
	| attr points interpolator |
	(attr _ node attributeValueNamed: 'point') notNil ifTrue:[
		points _ self mfVec3fFrom: attr.
		(scene targetNodes includes: node) ifTrue:[
			interpolator _ nil.
			scene sourceNodes do:[:n|
				n myEvents do:[:set|
					set do:[:msg| msg receiver == node ifTrue:[interpolator _ n]]]].
			interpolator _ self mfVec3fFromInterpolator: interpolator.
		].
	].
	points == nil
		ifTrue:[attributes removeKey: #currentPoints]
		ifFalse:[attributes at: #currentPoints put: points].
	interpolator == nil
		ifTrue:[attributes removeKey: #interpolatorPoints ifAbsent:[]]
		ifFalse:[attributes at: #interpolatorPoints put: interpolator].
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 18:59'!
doCylinder: node
	| radius height doSide doBottom doTop cylinder |
	radius _ (node attributeValueNamed:'radius').
	height _ (node attributeValueNamed:'height').
	doSide _ (node attributeValueNamed:'side').
	doBottom _ (node attributeValueNamed:'bottom').
	doTop _ (node attributeValueNamed:'top').
	cylinder _ B3DIndexedMesh vrml97Cylinder: doSide bottom: doBottom top: doTop.
	self createActorFor: cylinder defaultName:'cylinder'.
	currentActor resizeRightNow: radius @ height @ radius undoable: false.
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 18:59'!
doDirectionalLight: node
	| ambientIntensity intensity color on material light dir |
	ambientIntensity _ (node attributeValueNamed:'ambientIntensity').
	intensity _ (node attributeValueNamed: 'intensity').
	color _ (node attributeValueNamed: 'color').
	dir _ self positionFrom: (node attributeValueNamed:'direction').
	on _ (node attributeValueNamed:'on').
	material _ B3DMaterialColor new.
	material ambientPart: (color * ambientIntensity).
	material diffusePart: (color * intensity).
	light _ myWonderland makeLight: (Wonderland wonderlandConstants at: 'directional').
	light lightColor: material.
	light setDirection: dir.
	currentActor ifNotNil:[light reparentTo: currentActor].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:03'!
doImageTexture: node
	| attr texFileName tex |
	"Create a new texture."
	(attr _ node attributeValueNamed: 'url') notNil
		ifTrue:[
			texFileName _ (FileDirectory on: (FileDirectory dirPathFor: scene fileURL)) fullNameFor: attr first.
			(FileDirectory default fileExists: texFileName)
				ifTrue:[tex _ myWonderland makeTextureFrom: texFileName].
			attributes at: #currentTexture put: tex].
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 8/31/2000 21:39'!
doIndexedFaceSet: node
	| attr faces points mesh ipPoints meshList map |
	attributes at: #currentPoints put: nil.
	(attr _ node attributeValueNamed: 'coord') notNil
		ifTrue:[attr doWith: self].
	points _ attributes at: #currentPoints.
	ipPoints _ attributes at: #interpolatorPoints ifAbsent:[nil].
	points ifNil:[^self].
	(attr _ node attributeValueNamed: 'coordIndex') notNil
		ifTrue:[faces _ self facesFrom: attr for: points].
	faces ifNil:[^self].
	mesh _ B3DSimpleMesh withAll: faces.
	self assignIndexedNormals: node in: mesh.
	self assignIndexedTexCoords: node in: mesh.
	self assignIndexedColors: node in: mesh.
	mesh _ mesh asIndexedTriangleMesh.
	ipPoints == nil ifFalse:[
		"Re-map points for interpolated meshes"
		map _ Dictionary new: points size * 2.
		points doWithIndex:[:pt :index| map at: pt put: index].
		meshList _ ipPoints collect:[:pts|
			mesh clone vertices: (mesh vertices collect:[:pt| pts at: (map at: pt)])].
		mesh _ B3DInterpolatedMesh new initialize meshes: meshList.
	].
	"Try to recycle the actors"
	(currentActor == nil or:[currentActor hasMesh])
		ifTrue:[self createActorFor: mesh]
		ifFalse:[	currentActor setMesh: mesh.
				attributes at: #currentShape put: currentActor].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:00'!
doLOD: node
	| levels |
	levels _ (node attributeValueNamed: 'level').
	levels size > 0 ifTrue:[
		levels last doWith: self.
	].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:03'!
doMaterial: node
	| ambientIntensity diffuseColor emissiveColor shininess specularColor material |
	ambientIntensity _ (node attributeValueNamed: 'ambientIntensity').
	diffuseColor _ (node attributeValueNamed: 'diffuseColor').
	emissiveColor _ (node attributeValueNamed:'emissiveColor').
	shininess _ (node attributeValueNamed: 'shininess').
	specularColor _ (node attributeValueNamed: 'specularColor').
	"transparency _ (node attributeValueNamed:'transparency')."
	material _ B3DMaterial new.
	material ambientPart: (diffuseColor * ambientIntensity).
	material diffusePart: diffuseColor.
	material specularPart: specularColor.
	material emission: emissiveColor.
	material shininess: shininess.
	attributes at: #currentMaterial put: material.! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:03'!
doNormal: node
	| attr points |
	(attr _ node attributeValueNamed: 'vector') notNil
		ifTrue:[points _ self mfVec3fFrom: attr].
	points == nil
		ifTrue:[attributes removeKey: #currentNormals]
		ifFalse:[attributes at: #currentNormals put: points].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:03'!
doShape: node
	| attr shape |
	attributes at: #currentTexture put: nil.
	attributes at: #currentMaterial put: nil.
	attributes at: #currentShape put: nil.
	(attr _ node attributeValueNamed: 'appearance') notNil
		ifTrue:[attr doWith: self].
	(attr _ node attributeValueNamed: 'geometry') notNil
		ifTrue:[attr doWith: self].
	shape _ attributes at: #currentShape.
	shape == nil ifFalse:[
		shape setMaterial: (attributes at: #currentMaterial ifAbsent:[nil]).
		shape setTexturePointer: (attributes at: #currentTexture ifAbsent:[nil])].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:01'!
doSphere: node
	| radius sphere |
	radius _ (node attributeValueNamed:'radius').
	sphere _ B3DIndexedMesh vrml97Sphere.
	self createActorFor: sphere defaultName:'sphere'.
	currentActor resizeRightNow: radius @ radius @ radius undoable: false.
! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:01'!
doSwitch: node
	| choices which |
	choices _ (node attributeValueNamed:'choices').
	which _ (node attributeValueNamed: 'whichChoice') + 1.
	(which > 0 and:[which <= choices size])
		ifTrue:[(choices at: which) doWith: self].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:03'!
doTextureCoordinate: node

	| attr points |
	(attr _ node attributeValueNamed: 'point') notNil
		ifTrue:[points _ self mfVec2fFrom: attr].
	points == nil
		ifTrue:[attributes removeKey: #currentTexCoords]
		ifFalse:[attributes at: #currentTexCoords put: points].! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:04'!
doTransform: node
	| attr c r s sr t xform oldActor |
	attr _ node attributeValueNamed: 'center'.
	attr notNil ifTrue:[c _ self positionFrom: attr].
	attr _ node attributeValueNamed: 'rotation'.
	attr notNil ifTrue:[r _ self rotationFrom: attr].
	attr _ node attributeValueNamed: 'scale'.
	attr notNil ifTrue:[s _ self scaleFrom: attr].
	attr _ node attributeValueNamed: 'scaleOrientation'.
	attr notNil ifTrue:[sr _ self rotationFrom: attr].
	attr _ node attributeValueNamed: 'translation'.
	attr notNil ifTrue:[t _ self positionFrom: attr].
	xform _ B3DMatrix4x4 identity.
	xform translation: t+c.
	xform _ xform composedWithLocal: r asMatrix4x4.
	xform _ xform composedWithLocal: sr asMatrix4x4.
	xform _ xform composedWithLocal: (B3DMatrix4x4 identity scaling: s).
	xform _ xform composedWithLocal: sr negated asMatrix4x4.
	xform _ xform composedWithLocal: (B3DMatrix4x4 identity translation: c negated).
	oldActor _ currentActor.
	currentActor _ self createActorFor: nil.
	currentActor setComposite: xform.
	super doTransform: node.
	currentActor _ oldActor.! !

!VRMLWonderlandBuilder methodsFor: 'enumerating nodes' stamp: 'ar 5/4/2000 19:04'!
doViewpoint: node
	| attr pos r fov name m camera |
	attr _ node attributeValueNamed: 'position'.
	attr notNil ifTrue:[pos _ self positionFrom: attr].
	attr _ node attributeValueNamed: 'orientation'.
	attr notNil ifTrue:[r _ self rotationFrom: attr].
	attr _ node attributeValueNamed: 'fieldOfView'.
	attr notNil ifTrue:[fov _ attr radiansToDegrees].
	attr _ node attributeValueNamed: 'description'.
	attr notNil ifTrue:[name _ attr].
	m _ B3DMatrix4x4 identity.
	m _ m composedWithGlobal: (r asMatrix4x4).
	m _ m composedWithGlobal: (B3DMatrix4x4 withOffset: pos).
	(currentActor == baseActor and:[defaultCamera ~~ nil]) ifTrue:[
		camera _ defaultCamera.
		defaultCamera _ nil.
	] ifFalse:[
		camera _ myWonderland makeCameraNamed: (name ifNil:['camera']) parent: currentActor.
	].
	camera setComposite: m.
	camera setFieldOfView: fov.! !


!VRMLWonderlandBuilder methodsFor: 'building meshes' stamp: 'ar 5/4/2000 19:01'!
assignIndexedColors: node in: mesh
	| attr colors colorIndex faces vertices |
	attributes at: #currentColors put: nil.
	(attr _ node attributeValueNamed: 'color') notNil
		ifTrue:[attr doWith: self].
	colors _ attributes at: #currentColors.
	(colors == nil or:[colors size = 0]) ifTrue:[^self].
	attr _ (node attributeValueNamed: 'colorIndex').
	attr size = 0 ifTrue:[attr _ (node attributeValueNamed:'coordIndex')].
	colorIndex _ ReadStream on: attr.
	faces _ mesh faces.
	1 to: faces size do:[:i|
		vertices _ (faces at: i) vertices.
		[colorIndex next = -1] whileTrue.
		colorIndex skip: -1.
		1 to: vertices size do:[:index|
			(vertices at: index) color: (colors at: colorIndex next + 1).
		].
	].
! !

!VRMLWonderlandBuilder methodsFor: 'building meshes' stamp: 'ar 5/4/2000 19:02'!
assignIndexedNormals: node in: mesh
	| attr normals nrmlIndex faces vertices |
	attributes at: #currentNormals put: nil.
	(attr _ node attributeValueNamed: 'normal') notNil
		ifTrue:[attr doWith: self].
	normals _ attributes at: #currentNormals.
	normals == nil ifTrue:[^self].
	attr _ (node attributeValueNamed: 'normalIndex').
	attr size = 0 ifTrue:[attr _ (node attributeValueNamed: 'coordIndex')].
	nrmlIndex _ ReadStream on: attr.
	faces _ mesh faces.
	1 to: faces size do:[:i|
		vertices _ (faces at: i) vertices.
		[nrmlIndex next = -1] whileTrue.
		nrmlIndex skip: -1.
		1 to: vertices size do:[:index|
			(vertices at: index) normal: (normals at: nrmlIndex next + 1).
		].
	].
! !

!VRMLWonderlandBuilder methodsFor: 'building meshes' stamp: 'ar 5/4/2000 19:02'!
assignIndexedTexCoords: node in: mesh
	| attr faces vertices texCoords texIndex |
	attributes at: #currentTexCoords put: nil.
	(attr _ node attributeValueNamed: 'texCoord') notNil
		ifTrue:[attr doWith: self].
	texCoords _ attributes at: #currentTexCoords.
	texCoords == nil ifTrue:[^self].
	attr _ (node attributeValueNamed: 'texCoordIndex').
	attr size = 0 ifTrue:[attr _ (node attributeValueNamed:'coordIndex')].
	texIndex _ ReadStream on: attr.
	faces _ mesh faces.
	1 to: faces size do:[:i|
		vertices _ (faces at: i) vertices.
		[texIndex next = -1] whileTrue.
		texIndex skip: -1.
		1 to: vertices size do:[:index|
			(vertices at: index) texCoord: (texCoords at: texIndex next + 1).
		].
	].
! !

!VRMLWonderlandBuilder methodsFor: 'building meshes' stamp: 'ar 9/14/1999 23:04'!
facesFrom: anArray for: vertices
	"Create and return a set of faces from the given index array"
	| faces vtx |
	vtx _ WriteStream on: (Array new: 4).
	faces _ WriteStream on: (Array new: anArray size // 4).
	anArray do:[:idx|
		idx = -1 ifTrue:[
			vtx position > 2 
				ifTrue:[faces nextPut: (B3DSimpleMeshFace withAll: vtx contents)].
			vtx reset.
		] ifFalse:[
			vtx nextPut: (B3DSimpleMeshVertex new position: (vertices at: idx+1)).
		].
	].
	^faces contents! !

!VRMLWonderlandBuilder methodsFor: 'building meshes' stamp: 'ar 8/19/1999 13:11'!
indexedFacesFrom: anArray
	"Create and return a set of faces from the given index array"
	| faces index idx0 idx1 idx2 |
	faces _ WriteStream on: (B3DIndexedTriangleArray new: anArray size // 4).
	index _ 0.
	[index < anArray size] whileTrue:[
		idx0 _ anArray at: (index _ index + 1).
		idx1 _ anArray at: (index _ index + 1).
		[idx2 _ anArray at: (index _ index + 1).
		faces nextPut: (B3DIndexedTriangle with: idx0+1 with: idx1+1 with: idx2+1).
		idx1 _ idx2.
		index < anArray size
			ifTrue:[idx2 _ anArray at: (index_index+1)]
			ifFalse:[idx2 _ -1].
		idx2 = -1] whileFalse.
	].
	^faces contents! !


!VRMLWonderlandBuilder methodsFor: 'enumerating' stamp: 'ar 9/15/1999 16:29'!
doNamedNode: node
	| lastName |
	progress value:'Creating ', node name,' ...'.
	lastName _ attributes at: #currentName ifAbsent:[nil].
	attributes at: #currentName put: node name.
	super doNamedNode: node.
	lastName
		ifNil:[attributes removeKey: #currentName]
		ifNotNil:[attributes at: #currentName put: lastName].! !


!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 9/15/1999 16:16'!
mfVec2fFrom: anArray
	"Convert the given array into a B3DVector2Array"
	| pts |
	pts _ WriteStream on: (B3DTexture2Array new: anArray size).
	anArray do:[:spec|
		pts nextPut: (B3DVector2 u: (spec at: 1) v: (spec at: 2)).
	].
	^pts contents! !

!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 9/15/1999 17:33'!
mfVec3fFrom: anArray
	"Convert the given array into a B3DVector3Array"
	| pts |
	pts _ WriteStream on: (B3DVector3Array new: anArray size).
	anArray do:[:spec|
		pts nextPut: (B3DVector3 x: (spec at: 1) y: (spec at: 2) z: 0.0 - (spec at: 3)).
	].
	^pts contents! !

!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 8/31/2000 19:13'!
mfVec3fFromInterpolator: node
	| key value len values vv keySize |
	key _ node attributeValueNamed: 'key'.
	value _ node attributeValueNamed: 'keyValue'.
	keySize _ key size.
	values _ Array new: keySize.
	len _ value size // keySize.
	1 to: values size do:[:i|
		vv _ B3DVector3Array new: len.
		vv replaceFrom: 1 to: len with: value startingAt: (i-1 * len)+1.
		values at: i put: (self mfVec3fFrom: vv).
	].
	^values! !

!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 9/15/1999 17:33'!
positionFrom: attr
	"Fix up coord systems"
	^B3DVector3 x: (attr at: 1) y: (attr at: 2) z: 0.0 - (attr at: 3).
! !

!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 7/14/2000 10:14'!
rotationFrom: attr
	"Fix up coord systems.
	FIXME: attr should always be a B3DRotation but for now
	the defaults are arrays. How ugly..."
	attr class == Array
		ifTrue:[^B3DRotation radiansAngle: (attr at: 4) negated axis: 
			(B3DVector3 x: (attr at: 1) y: (attr at: 2) z: (attr at: 3))]
		ifFalse:[^attr negated]! !

!VRMLWonderlandBuilder methodsFor: 'converting' stamp: 'ar 9/15/1999 18:05'!
scaleFrom: attr
	"Fix up coord systems"
	^B3DVector3 x: (attr at: 1) y: (attr at: 2) z: (attr at: 3).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLWonderlandBuilder class
	instanceVariableNames: ''!

!VRMLWonderlandBuilder class methodsFor: 'instance creation' stamp: 'ar 8/18/1999 19:46'!
on: aVRMLScene
	^self new on: aVRMLScene! !
Object subclass: #VRMLWriter
	instanceVariableNames: ''
	classVariableNames: 'Default VRMLFieldTypes '
	poolDictionaries: ''
	category: 'Balloon3D-VRML Definition'!
!VRMLWriter commentStamp: '<historical>' prior: 0!
A VRMLWriter supports writing a set of VRMLNodes (or entire scenes) in VRML format.!


!VRMLWriter methodsFor: 'data writing' stamp: 'ar 3/12/98 19:56'!
storeSingleFieldNode: aField on: aVRMLStream indent: level 
	aField printOn: aVRMLStream indent: level.
! !

!VRMLWriter methodsFor: 'data writing' stamp: 'ar 3/12/98 19:19'!
writeAttribute: aVRMLNodeAttribute on: aVRMLStream value: value indent: aLevel
	aVRMLStream nextPutAll: aVRMLNodeAttribute name.
	aVRMLStream space.
	self perform: (VRMLFieldTypes at: aVRMLNodeAttribute type)
			with: value
			with: aVRMLStream
			with: aLevel.
	aVRMLStream crtab: aLevel.! !

!VRMLWriter methodsFor: 'data writing' stamp: 'ar 3/12/98 19:13'!
writeAttribute: aVRMLNodeAttribute value: value indent: aLevel
	self nextPutAll: aVRMLNodeAttribute name.
	self space.
	self perform: (VRMLFieldTypes at: aVRMLNodeAttribute type)
			with: aVRMLNodeAttribute
			with: value
			with: aLevel.
	self crtab: aLevel.! !

!VRMLWriter methodsFor: 'data writing' stamp: 'ar 8/17/1999 22:20'!
writeScene: aScene on: aVRMLStream
	aVRMLStream nextPutAll:'#VRML V2.0 utf8'; cr.
	aScene nodes do:[:node| 
		node printOn: aVRMLStream indent: 0.
		aVRMLStream cr.].
	aScene actions keysAndValuesDo:[:fromName :outDict|
		outDict keysAndValuesDo:[:outEvt :toDict|
			toDict keysAndValuesDo:[:toName :inSet|
				inSet do:[:inEvt|
		aVRMLStream 
			nextPutAll:'ROUTE ';
			nextPutAll: fromName;
			nextPut:$.;
			nextPutAll: outEvt name;
			nextPutAll:' TO ';
			nextPutAll: toName;
			nextPut:$.;
			nextPutAll: inEvt name;
			cr]]]].! !


!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldColor: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldColor: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldFloat: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldFloat: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldInt32: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldInt32: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldNode: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldNode: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldRotation: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldRotation: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldString: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldString: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldTime: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldTime: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldVec2f: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldVec2f: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !

!VRMLWriter methodsFor: 'multi field writing' stamp: 'ar 3/12/98 22:42'!
writeMultiFieldVec3f: fields on: aVRMLStream indent: level 
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleFieldVec3f: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].! !


!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldBool: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeBool: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldColor: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeColor: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldFloat: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeFloat: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldImage: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeImage: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldInt32: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeInt32: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldRotation: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeRotation: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldString: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeString: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldTime: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeTime: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldVec2f: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeVec2f: aField! !

!VRMLWriter methodsFor: 'single field writing' stamp: 'ar 3/12/98 22:42'!
storeSingleFieldVec3f: aField on: aVRMLStream indent: level 
	"This method was automatically generated"
	^aVRMLStream writeVec3f: aField! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VRMLWriter class
	instanceVariableNames: ''!

!VRMLWriter class methodsFor: 'class initialization' stamp: 'ar 3/12/98 22:42'!
initFields
	"VRMLWriter initialize"
	| selString multi typeString selector singleString multiString |
	VRMLFieldTypes := Dictionary new.
	#(
MFColor 
MFFloat 
MFInt32 
MFNode 
MFRotation 
MFString 
MFTime 
MFVec2f 
MFVec3f 

	SFBool 
SFColor 
SFFloat 
SFImage 
SFInt32 
SFNode 
SFRotation 
SFString 
SFTime 
SFVec2f 
SFVec3f) do:[:sym|
	multi := sym first = $M.
	typeString := sym copyFrom: 3 to: sym size.
	singleString := 'storeSingleField', typeString, ':on:indent:'.
	multiString := 'writeMultiField', typeString, ':on:indent:'.
	selString := multi ifTrue:[multiString] ifFalse:[singleString].
	selector := selString asSymbol.
	VRMLFieldTypes at: sym asString put: selector.
	(self includesSelector: selector) ifFalse:[
		multi
			ifTrue:[self compileMultiFieldMethod: selString type: typeString]
			ifFalse:[self compileSingleFieldMethod: selString type: typeString]].
]. ! !

!VRMLWriter class methodsFor: 'class initialization' stamp: 'ar 3/12/98 18:55'!
initialize
	"VRMLWriter initialize"
	self initFields.! !


!VRMLWriter class methodsFor: 'private' stamp: 'bf 3/16/2000 19:16'!
compileMultiFieldMethod: selString type: typeString
	| source selParts |
	source := String streamContents:[:s|
		selParts := selString findTokens: ':'.
		s nextPutAll: (selParts at: 1).
		s nextPutAll: ': fields '.
		s nextPutAll: (selParts at: 2).
		s nextPutAll: ': aVRMLStream '.
		s nextPutAll: (selParts at: 3).
		s nextPutAll: ': level '.
		s nextPutAll:('
	"This method was automatically generated"
	aVRMLStream nextPut: $[.
	1 to: fields size do:[:i|
		i > 1 ifTrue:[aVRMLStream crtab: level+1].
		self storeSingleField$TYPESTRING$: (fields at: i) on: aVRMLStream indent: level+1].
	aVRMLStream nextPut:$].' copyReplaceAll:'$TYPESTRING$' with: typeString).
	].
	self compile: source classified:'multi field writing'! !

!VRMLWriter class methodsFor: 'private' stamp: 'bf 3/16/2000 19:17'!
compileSingleFieldMethod: selString type: typeString
	| source selParts |
	source := String streamContents:[:s|
		selParts := selString findTokens: ':'.
		s nextPutAll: (selParts at: 1).
		s nextPutAll: ': aField '.
		s nextPutAll: (selParts at: 2).
		s nextPutAll: ': aVRMLStream '.
		s nextPutAll: (selParts at: 3).
		s nextPutAll: ': level '.
		s crtab.
		s nextPutAll:'"This method was automatically generated"'.
		s crtab.
		s nextPutAll:'^aVRMLStream write'.
		s nextPutAll: typeString.
		s nextPutAll:': aField'.
	].
	self compile: source classified:'single field writing'! !


!VRMLWriter class methodsFor: 'accessing' stamp: 'ar 3/12/98 19:16'!
default
	^Default isNil
		ifTrue:[Default := self new]
		ifFalse:[Default].! !

!VRMLWriter class methodsFor: 'accessing' stamp: 'ar 3/12/98 20:03'!
writeAttribute: aVRMLNodeAttribute on: aVRMLStream value: value indent: aLevel

	^self default writeAttribute: aVRMLNodeAttribute on: aVRMLStream value: value indent: aLevel! !
Model subclass: #ValueHolder
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!

!ValueHolder methodsFor: 'as yet unclassified' stamp: 'ls 8/5/1998 07:49'!
contents
	^contents! !

!ValueHolder methodsFor: 'as yet unclassified' stamp: 'sw 1/28/1999 12:35'!
contents: newContents
	contents _ newContents.
	self contentsChanged! !
ObjectWithDocumentation subclass: #ValueSpecification
	instanceVariableNames: 'selector protocol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!
ObjectWithDocumentation subclass: #Variable
	instanceVariableNames: 'defaultValue floatPrecision variableName variableType '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Protocols'!

!Variable methodsFor: 'name' stamp: 'sw 12/11/2000 14:07'!
variableName
	"Answer the variable name of the receiver"

	^ variableName! !


!Variable methodsFor: 'type' stamp: 'sw 12/11/2000 14:06'!
variableType
	"Anser the variable type of the receiver"

	^ variableType! !

!Variable methodsFor: 'type' stamp: 'sw 12/11/2000 14:06'!
variableType: aType
	"Set the receiver's variable type as requested"

	variableType _ aType! !


!Variable methodsFor: 'value' stamp: 'sw 12/11/2000 14:06'!
defaultValue
	"Answer the default value to be supplied to the receiver"

	^ defaultValue! !
Object subclass: #VariableDock
	instanceVariableNames: 'variableName type definingMorph morphGetSelector morphPutSelector playerGetSelector playerPutSelector defaultValue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Stacks'!
!VariableDock commentStamp: '<historical>' prior: 0!
Represents a variable held in a Player on behalf of a Morph.  When a new Player gets installed in the Morph, variables representing the old player need to be committed to the old player's storage, if not already done, and then new values for the variables need to be obtained from the new Player.  The VariableDock does the actual data transfer.

variableName 		A Symbol.  The name by which this variable known in the bearer,  a Card
type 				An object representing the variable's type.  Initially, we, like the rest
						use a Symbol to represent this.
						Presently #string #number #boolean #object #reference #sound etc.
definingMorph		The morph that requested storage of this variable
morphGetSelector	The message to be sent to the morph to obtain the variable's value
morphPutSelector	The message to be sent to the morph to put a new var value into it
owningClass			The Uniclass of which this is an instance variable
playerGetSelector 	The message to be sent to the Player to obtain its current stored value
playerPutSelector 	The message to be sent to the Player to set a new stored value
defaultValue		The value to set for the variable by default
floatPrecision		e.g. 0, 0.1, 0.001.  Only relevant for numeric-type variables
!


!VariableDock methodsFor: 'initialization' stamp: 'sw 10/26/2000 13:33'!
dockMorphUpToInstance: anInstance
	"Dock my defining morph up to the given player instance.  NB: The odious #cardInstance mechanism used here was a last-minute stopgap for some demo, which surely should not be allowed to survive."

	definingMorph setProperty: #cardInstance toValue: anInstance.
	definingMorph perform: morphPutSelector with: (anInstance perform: playerGetSelector)! !

!VariableDock methodsFor: 'initialization' stamp: 'sw 10/30/2000 08:52'!
storeMorphDataInInstance: anInstance
	"Store the morph instance data represented by the receiver into the card instance provided.  This is done by retrieving the datum value from the morph that holds it on the card, and putting it into the card instance"

	anInstance perform: playerPutSelector with: (definingMorph perform: morphGetSelector)! !

!VariableDock methodsFor: 'initialization' stamp: 'sw 10/30/2000 08:52'!
variableName: aSymbol type: aType definingMorph: aMorph morphGetSelector: getterSymbol morphPutSelector: putterSymbol
	"Initialize the receiver as indicated"

	variableName _ aSymbol asSymbol.
	type _ aType.
	definingMorph _ aMorph.
	morphGetSelector _ getterSymbol.
	morphPutSelector _ putterSymbol.
	self computePlayerGetterAndSetterSelectors! !


!VariableDock methodsFor: 'getters and setters' stamp: 'sw 10/30/2000 10:55'!
computePlayerGetterAndSetterSelectors
	"Compute and remember the getter and setter selectors for obtaining and setting values from the player instance"

	playerGetSelector _ Utilities getterSelectorFor: variableName.
	playerPutSelector _ Utilities setterSelectorFor: variableName! !


!VariableDock methodsFor: 'name' stamp: 'sw 10/30/2000 08:52'!
variableName
	"Answer the variable name represented by the receiver"

	^ variableName! !

!VariableDock methodsFor: 'name' stamp: 'sw 10/30/2000 08:51'!
variableName: aSymbol
	"Set the receiver's variableName as indicated, and recompute corresponding getters and setters"

	variableName _ aSymbol asSymbol.
	self computePlayerGetterAndSetterSelectors! !


!VariableDock methodsFor: 'type and default value' stamp: 'sw 10/30/2000 08:52'!
defaultValue: aValue
	"Set the receiver's default value as indicated"

	defaultValue _ aValue! !

!VariableDock methodsFor: 'type and default value' stamp: 'sw 10/29/2000 17:40'!
variableType
	"Answer the data type of the receiver"

	^ type! !


!VariableDock methodsFor: 'printing' stamp: 'sw 10/30/2000 08:50'!
printOn: aStream
	"Print a description of the receiver onto the given stream"

	super printOn: aStream.
	variableName ifNotNil: [aStream nextPutAll: (' (var name = ', variableName, ')')].
	type ifNotNil: [aStream nextPutAll: (' (type = ', type, ')')]! !
LeafNode subclass: #VariableNode
	instanceVariableNames: 'name '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
!VariableNode commentStamp: '<historical>' prior: 0!
I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables: the key is the Object Reference.!


!VariableNode methodsFor: 'initialize-release'!
asStorableNode: encoder
	^ self! !

!VariableNode methodsFor: 'initialize-release'!
name: varName index: i type: type
	"Only used for initting instVar refs"
	name _ varName.
	self key: varName
		index: i
		type: type! !

!VariableNode methodsFor: 'initialize-release'!
name: string key: object code: byte
	"Only used for initting std variables, nil, true, false, self, etc."
	name _ string.
	key _ object.
	code _ byte! !

!VariableNode methodsFor: 'initialize-release'!
name: varName key: objRef index: i type: type
	"Only used for initting global (litInd) variables"
	name _ varName.
	self key: objRef
		index: i
		type: type! !


!VariableNode methodsFor: 'testing'!
assignmentCheck: encoder at: location

	(encoder cantStoreInto: name)
		ifTrue: [^ location]
		ifFalse: [^ -1]
! !

!VariableNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^code < LdNil! !

!VariableNode methodsFor: 'testing' stamp: 'tk 1/30/2001 14:04'!
isSelfPseudoVariable
	"Answer if this ParseNode represents the 'self' pseudo-variable."

	^ (key = 'self') | (name = '{{self}}')! !

!VariableNode methodsFor: 'testing'!
isVariableReference

	^true! !

!VariableNode methodsFor: 'testing' stamp: 'di 2/3/1999 09:41'!
type
	"This code attempts to reconstruct the type from its encoding in code.
		This allows one to test, for instance, (aNode type = LdInstType)."
	| type |
	code < 0 ifTrue: [^ code negated].
	code < 256 ifFalse: [^ code // 256].
	type _ CodeBases findFirst: [:one | code < one].
	type = 0
		ifTrue: [^ 5]
		ifFalse: [^ type - 1]! !


!VariableNode methodsFor: 'code generation'!
emitForReturn: stack on: strm

	(code >= LdSelf and: [code <= LdNil])
		ifTrue: 
			["short returns"
			strm nextPut: EndMethod - 4 + (code - LdSelf).
			stack push: 1 "doesnt seem right"]
		ifFalse: 
			[super emitForReturn: stack on: strm]! !

!VariableNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	code < 256
		ifTrue: 
			[strm nextPut: (code = LdSuper ifTrue: [LdSelf] ifFalse: [code]).
			stack push: 1]
		ifFalse: 
			[self emitLong: LoadLong on: strm.
			stack push: 1]! !

!VariableNode methodsFor: 'code generation'!
emitStore: stack on: strm

	self emitLong: Store on: strm! !

!VariableNode methodsFor: 'code generation'!
emitStorePop: stack on: strm
	(code between: 0 and: 7)
		ifTrue: 
			[strm nextPut: ShortStoP + code "short stopop inst"]
		ifFalse:
			[(code between: 16 and: 23)
				ifTrue: [strm nextPut: ShortStoP + 8 + code - 16 "short stopop temp"]
				ifFalse: [(code >= 256 and: [code \\ 256 > 63 and: [code // 256 = 4]])
						ifTrue: [self emitLong: Store on: strm. strm nextPut: Pop]
						ifFalse: [self emitLong: StorePop on: strm]]].
	stack pop: 1! !

!VariableNode methodsFor: 'code generation' stamp: 'di 2/6/2000 10:52'!
fieldOffset  "Return temp or instVar offset for this variable"

	code < 256
		ifTrue: 
			[^ code \\ 16]
		ifFalse: 
			[^ code \\ 256]! !

!VariableNode methodsFor: 'code generation'!
sizeForReturn: encoder

	(code >= LdSelf and: [code <= LdNil])
		ifTrue: ["short returns" ^1].
	^super sizeForReturn: encoder! !

!VariableNode methodsFor: 'code generation'!
sizeForStore: encoder
	self reserve: encoder.
	code < 256 ifTrue: [^ 2].
	(code \\ 256) <= 63 ifTrue: [^ 2].
	^ 3! !

!VariableNode methodsFor: 'code generation'!
sizeForStorePop: encoder
	self reserve: encoder.
	(code < 24 and: [code noMask: 8]) ifTrue: [^ 1].
	code < 256 ifTrue: [^ 2].
	code \\ 256 <= 63 ifTrue: [^ 2].  "extended StorePop"
	code // 256 = 1 ifTrue: [^ 3].  "dbl extended StorePopInst"
	code // 256 = 4 ifTrue: [^ 4].  "dbl extended StoreLitVar , Pop"
	self halt.  "Shouldn't get here"! !


!VariableNode methodsFor: 'printing' stamp: 'di 4/5/2000 15:11'!
printOn: aStream indent: level 
	aStream withStyleFor: #variable
		do: [aStream nextPutAll: name].
! !


!VariableNode methodsFor: 'C translation' stamp: 'jm 11/25/1998 18:44'!
asTranslatorNode

	name = 'true' ifTrue: [^ TConstantNode new setValue: true].
	name = 'false' ifTrue: [^ TConstantNode new setValue: false].
	^ TVariableNode new setName: name
! !


!VariableNode methodsFor: 'tiles' stamp: 'tk 1/30/2001 14:19'!
asMorphicSyntaxIn: parent

	^ parent addToken: name
			type: #variable 
			on: self clone	"don't hand out the prototype!! See VariableNode>>initialize"
! !

!VariableNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 16:34'!
currentValueIn: aContext

	aContext ifNil: [^nil].
	^((self variableGetterBlockIn: aContext) ifNil: [^nil]) value printString
	

! !

!VariableNode methodsFor: 'tiles' stamp: 'RAA 8/16/1999 12:36'!
explanation

	self isSelfPseudoVariable ifTrue: [^'the pseudo variable <self> (refers to the receiver)'].
	^(#('instance' 'temporary' 'LIT3' 'global') 
			at: self type 
			ifAbsent: ['UNK',self type printString]),' variable <',name,'>'
		

	"LdInstType _ 1.
	LdTempType _ 2.
	LdLitType _ 3.
	LdLitIndType _ 4.
"

! !

!VariableNode methodsFor: 'tiles' stamp: 'RAA 8/24/1999 17:56'!
variableGetterBlockIn: aContext

	| temps index ivars |

	(self type = 4 and: [key isKindOf: Association]) ifTrue: [
		^[key value]
	].
	aContext ifNil: [^nil].
	self isSelfPseudoVariable ifTrue: [^[aContext receiver]].
	self type = 1 ifTrue: [
		ivars _ aContext receiver class allInstVarNames.
		index _ ivars indexOf: name ifAbsent: [^nil].
		^[aContext receiver instVarAt: index]
	].
	self type = 2 ifTrue: [
		temps _ aContext tempNames.
		index _ temps indexOf: name ifAbsent: [^nil].
		^[aContext tempAt: index]
	].
	^nil
! !


!VariableNode methodsFor: 'accessing' stamp: 'tk 1/30/2001 13:45'!
name
	^ name! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VariableNode class
	instanceVariableNames: ''!

!VariableNode class methodsFor: 'class initialization'!
initialize    "VariableNode initialize.  Decompiler initialize"
	| encoder |
	encoder _ Encoder new.
	StdVariables _ Dictionary new: 16.
	encoder
		fillDict: StdVariables
		with: VariableNode
		mapping: #('self' 'thisContext' 'super' 'nil' 'false' 'true' )
		to: (Array with: LdSelf with: LdThisContext with: LdSuper)
				, (Array with: LdNil with: LdFalse with: LdTrue).
	StdSelectors _ Dictionary new: 64.
	encoder
		fillDict: StdSelectors
		with: SelectorNode
		mapping: ((1 to: Smalltalk specialSelectorSize) collect: 
							[:i | Smalltalk specialSelectorAt: i])
		to: (SendPlus to: SendPlus + 31).
	StdLiterals _ LiteralDictionary new: 16.
	encoder
		fillDict: StdLiterals
		with: LiteralNode
		mapping: #(-1 0 1 2 )
		to: (LdMinus1 to: LdMinus1 + 3).
	encoder initScopeAndLiteralTables.

	NodeNil _ encoder encodeVariable: 'nil'.
	NodeTrue _ encoder encodeVariable: 'true'.
	NodeFalse _ encoder encodeVariable: 'false'.
	NodeSelf _ encoder encodeVariable: 'self'.
	NodeThisContext _ encoder encodeVariable: 'thisContext'.
	NodeSuper _ encoder encodeVariable: 'super'! !
ChangeList subclass: #VersionsBrowser
	instanceVariableNames: 'classOfMethod selectorOfMethod '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Changes'!

!VersionsBrowser methodsFor: 'init & update' stamp: 'sw 5/6/2000 01:16'!
changeListButtonSpecs

	^#(
		('compare to current'
		compareToCurrentVersion
		'opens a separate window which shows the text differences between the selected version and the current version')

		('revert'
		fileInSelections
		'reverts the method to the version selected')

		('remove from changes'
		removeMethodFromChanges
		'remove this method from the current change set')

		('help'
		offerVersionsHelp
		'further explanation about use of Versions browsers')
		)! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'sw 11/28/1999 22:50'!
reformulateList
	| aMethod |
	"Some uncertainty about how to deal with lost methods here"
	aMethod _ classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self].
	
	self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod.
	self changed: #list. "for benefit of mvc"
	listIndex _ 1.
	self changed: #listIndex.
	self contentsChanged
! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'ar 5/17/2000 18:30'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
	| position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |
	selectorOfMethod _ selector.
	currentCompiledMethod _ method.
	classOfMethod _ meta ifTrue: [class class] ifFalse: [class].
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	method fileIndex == 0 ifTrue: [^ nil].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].

		"Preamble is likely a linked method preamble, if we're in
			a changes file (not the sources file).  Try to parse it
			for prior source position and file index"
		prevPos _ nil.
		stamp _ ''.
		(preamble findString: 'methodsFor:' startingAt: 1) > 0
			ifTrue: [tokens _ Scanner new scanTokens: preamble]
			ifFalse: [tokens _ Array new  "ie cant be back ref"].
		((tokens size between: 7 and: 8)
			and: [(tokens at: tokens size-5) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-3) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size-2.
						prevPos _ tokens last.
						prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos.
						prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]
				ifFalse: ["Old format gives no stamp; prior pointer in two parts"
						prevPos _ tokens at: tokens size-2.
						prevFileIndex _ tokens last].
				(prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
		((tokens size between: 5 and: 6)
			and: [(tokens at: tokens size-3) = #methodsFor:])
			ifTrue:
				[(tokens at: tokens size-1) = #stamp:
				ifTrue: ["New format gives change stamp and unified prior pointer"
						stamp _ tokens at: tokens size]].
 		self addItem:
				(ChangeRecord new file: file position: position type: #method
						class: class name category: category meta: meta stamp: stamp)
			text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
		position _ prevPos.
		prevPos notNil ifTrue:
			[file _ sourceFilesCopy at: prevFileIndex]].
	sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
	listSelections _ Array new: list size withAll: false! !

!VersionsBrowser methodsFor: 'init & update' stamp: 'di 11/28/2000 01:25'!
updateListsAndCodeIn: aWindow
	| aMethod |
	aMethod _ classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false].
	aMethod == currentCompiledMethod
		ifFalse:
			["Do not attempt to formulate if there is no source pointer.
			It probably means it has been recompiled, but the source hasn't been written
			(as during a display of the 'save text simply?' confirmation)."
			aMethod last ~= 0 ifTrue: [self reformulateList]].
	^ true
! !


!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 17:51'!
fileInSelections 
	super fileInSelections.
	self reformulateList! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:49'!
offerVersionsHelp
	(StringHolder new contents: self versionsHelpString)
		openLabel: 'Versions Browsers'! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 1/3/2001 06:50'!
removeMethodFromChanges
	"Remove my method from the current change set"

	Smalltalk changes removeSelectorChanges: selectorOfMethod class: classOfMethod.
	self changed: #annotation
! !

!VersionsBrowser methodsFor: 'menu' stamp: 'tk 9/7/2000 15:05'!
versionFrom: secsSince1901
	| strings vTime |
	"Return changeRecord of the version in effect at that time.  Accept in the VersionsBrowser does not use this code."

	changeList do: [:cngRec |
		(strings _ cngRec stamp findTokens: ' ') size > 2 ifTrue: [
				vTime _ strings second asDate asSeconds + 
							strings third asTime asSeconds.
				vTime <= secsSince1901 ifTrue: ["this one"
					^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]].
	"was not defined that early.  Don't delete the method."
	^ changeList last	"earliest one may be OK"	! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 1/25/2001 07:41'!
versionsHelpString
	^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc.

To revert to an earlier version, select it (in the list pane) and then do any of the following:
  *  Choose "revert to this version" from the list pane menu.
  *  Hit the "revert" button,
  *  Type ENTER in the code pane
  *  Type cmd-s (alt-s) in the code pane.

The code pane shows the source for the selected version.  If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane.  Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane.

To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button.  (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.)

If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date.

Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set.  This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion.

Note:  the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.'! !

!VersionsBrowser methodsFor: 'menu' stamp: 'sw 1/25/2001 06:32'!
versionsMenu: aMenu
	"Fill aMenu with menu items appropriate to the receiver"

	^ aMenu addList: #(

		('compare to current'		compareToCurrentVersion)
		('revert to this version'		fileInSelections)
		('remove from changes'		removeMethodFromChanges)
		('toggle diffing (D)'			toggleDiffing)
		('update list'				reformulateList)
		('help...'					offerVersionsHelp))
! !


!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 07:03'!
selectedClass
	"Answer the class currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ classOfMethod theNonMetaClass! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:26'!
selectedClassOrMetaClass
	"Answer the class or metaclass currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ classOfMethod! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 1/25/2001 06:10'!
selectedMessageName
	"Answer the message name currently selected in the browser.  In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane"

	^ selectorOfMethod! !

!VersionsBrowser methodsFor: 'misc' stamp: 'sw 10/19/1999 15:04'!
showsVersions
	^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

VersionsBrowser class
	instanceVariableNames: ''!

!VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'di 1/11/2000 12:45'!
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector 
	^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil! !

!VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'di 1/11/2000 12:44'!
browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer 
	| changeList |
	Cursor read showWhile:
		[changeList _ self new
			scanVersionsOf: method class: class meta: meta
			category: msgCategory selector: selector].
	changeList ifNil: [^ self inform: 'No versions available'].

	sourcePointer ifNotNil:
		[changeList setLostMethodPointer: sourcePointer].

	self open: changeList name: 'Recent versions of ' ,
selector multiSelect: false! !

!VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 17:21'!
timeStampFor: aSelector class: aClass reverseOrdinal: anInteger
	"Answer the time stamp corresponding to some version of the given method, nil if none.  The reverseOrdinal parameter is interpreted as:  1 = current version; 2 = last-but-one version, etc."
	
	| method aChangeList |
	method _ aClass compiledMethodAt: aSelector ifAbsent: [^ nil].
	aChangeList _ self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector.
	^ aChangeList ifNil: [nil] ifNotNil:
		[aChangeList list size >= anInteger
			ifTrue:
				[(aChangeList changeList at: anInteger) stamp]
			ifFalse:
				[nil]]! !

!VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 15:01'!
versionCountForSelector: aSelector class: aClass
	"Answer the number of versions known to the system for the given class and method, including the current version.  A result of greater than one means that there is at least one superseded version.  Answer zero if no logged version can be obtained."
	
	| method aChangeList |
	method _ aClass compiledMethodAt: aSelector ifAbsent: [^ 0].
	aChangeList _ self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector.
	^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]! !
Morph subclass: #VeryPickyMorph
	instanceVariableNames: 'passengerMorph '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Tools-Explorer'!
!VeryPickyMorph commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!


!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/1998 21:55'!
complexContents

	^passengerMorph complexContents! !

!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/1998 22:02'!
delete

	passengerMorph ifNotNil: [passengerMorph delete].
	super delete! !

!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 14:58'!
drawOn: aCanvas

	aCanvas frameRectangle: bounds width: 1 color: Color red! !

!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 14:58'!
initialize

	super initialize.
	bounds _ 0@0 extent: 8@10
	"bounds _ 0@0 extent: 17@22"
! !

!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 15:23'!
justDroppedInto: targetMorph event: evt

	passengerMorph ifNil: [^self "delete"].
	passengerMorph noLongerBeingDragged.
	(targetMorph isKindOf: IndentingListItemMorph) ifFalse: [
		passengerMorph changed.
		passengerMorph _ nil.
		owner privateRemoveMorph: self.
		self privateOwner: nil.
	].! !

!VeryPickyMorph methodsFor: 'as yet unclassified' stamp: 'RAA 7/15/1998 21:53'!
passengerMorph: anotherMorph

	passengerMorph _ anotherMorph! !
Object subclass: #View
	instanceVariableNames: 'model controller superView subViews transformation viewport window displayTransformation insetDisplayBox borderWidth borderColor insideColor boundingBox '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!View commentStamp: '<historical>' prior: 0!
My instances are intended to be components in a structured picture. Each View in the structured picture can contain other Views as sub-components. These sub-components are called subViews. A View can be a subView of only one View. This View is called its superView. The set of Views in a structured picture forms a hierarchy. The one View in the hierarchy that has no superView is called the topView of the structured picture. A View in a structured picture with no subViews is called a bottom View. A View and all of its subViews, and all of their subViews and so on, are treated as a unit in many operations on the View. For example, if a View is displayed, all of its subViews are displayed as well. There are several categories of operations that can be performed on a View. Among these are the following:
	
	1.	Adding subViews to a View.
	2.	Positioning subViews within a View.
	3.	Deleting subViews from a View.
	4.	Transforming a View.
	5.	Displaying a View.
	
Each View has its own coordinate system. In order to change from one coordinate system to another, each View has two transformations associated with it. The local transformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the coordinate system of the superView of the View. The displayTransformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the display screen coordinate system.
	
The part of the space that is to be made visible is represented by the window of the View. The window of a View is a Rectangle expressed in the coordinate system of the View. The area occupied by a View in the coordinate system of its superView is called its viewport. The viewport of a View is its window transformed by its local transformation. The region of the display screen occupied by a View is called its displayBox. The display box of a View can include a border. The width of the border expressed in display screen coordinates is called the border width of the View. The color of the border is called the border color. The region of the display box of a View excluding the border is called the inset display box. The color of the inset display box is called the inside color of the View.!


!View methodsFor: 'initialize-release'!
initialize
	"Initialize the state of the receiver. Subclasses should include 'super 
	initialize' when redefining this message to insure proper initialization."

	self resetSubViews.
	transformation _ WindowingTransformation identity.
	self borderWidth: 0! !

!View methodsFor: 'initialize-release'!
release
	"Remove the receiver from its model's list of dependents (if the model
	exists), and release all of its subViews. It is used to break possible cycles
	in the receiver and should be sent when the receiver is no longer needed.
	Subclasses should include 'super release.' when redefining release."

	model removeDependent: self.
	model _ nil.
	controller release.
	controller _ nil.
	subViews ~~ nil ifTrue: [subViews do: [:aView | aView release]].
	subViews _ nil.
	superView _ nil! !

!View methodsFor: 'initialize-release'!
setDefaultBackgroundColor
	"Obtain the background color from the receiver's model, unless the #uniformWindowColors preference is set to true, in which case obtain it from generic Object; and install it as the receiver's background color.  5/1/96 sw"

	| colorToUse |
	colorToUse _ Preferences uniformWindowColors
		ifTrue:
			[Object new defaultBackgroundColor]
		ifFalse:
			[model defaultBackgroundColor].
	self backgroundColor: colorToUse! !


!View methodsFor: 'testing' stamp: 'tk 4/13/1998 22:58'!
canDiscardEdits
	"Return true if this pane is not dirty."

	^ true
! !

!View methodsFor: 'testing'!
containsPoint: aPoint
	"Answer whether aPoint is within the receiver's display box. It is sent to 
	a View's subViews by View|subViewAt: in order to determine which 
	subView contains the cursor point (so that, for example, control can be 
	pass down to that subView's controller)."

	^ self insetDisplayBox containsPoint: aPoint! !

!View methodsFor: 'testing' stamp: 'jm 3/17/98 13:35'!
hasUnacceptedEdits
	"Return true if this view has unaccepted edits."

	^ false
! !

!View methodsFor: 'testing'!
isObscured

	| topController displayRect |
	(topController _ self topView controller)
		== ScheduledControllers activeController
			ifTrue: [^false].
	displayRect _ self insetDisplayBox.
	ScheduledControllers scheduledControllers do: [:ctrlr |
		ctrlr == topController ifTrue: [^false].
		(displayRect intersects: ctrlr view insetDisplayBox)
			ifTrue: [^true]].
	self error: 'not in ScheduledControllers'.
	^false! !


!View methodsFor: 'model access'!
model
	"Answer the receiver's model."

	^model! !

!View methodsFor: 'model access'!
model: aModel 
	"Set the receiver's model to aModel. The model of the receiver's controller 
	is also set to aModel."

	self model: aModel controller: controller! !


!View methodsFor: 'superView access'!
isTopView
	"Answer whether the receiver is a top view, that is, if it has no 
	superView."

	^superView == nil! !

!View methodsFor: 'superView access'!
superView
	"Answer the superView of the receiver."

	^superView! !

!View methodsFor: 'superView access'!
topView
	"Answer the root of the tree of Views in which the receiver is a node. 
	The root of the tree is found by going up the superView path until 
	reaching a View whose superView is nil."

	superView == nil
		ifTrue: [^self]
		ifFalse: [^superView topView]! !


!View methodsFor: 'subView access'!
firstSubView
	"Answer the first subView in the receiver's list of subViews if it is not 
	empty, else nil."

	subViews isEmpty
		ifTrue: [^nil]
		ifFalse: [^subViews first]! !

!View methodsFor: 'subView access'!
lastSubView
	"Answer the last subView in the receiver's list of subViews if it is not 
	empty, else nil."

	subViews isEmpty
		ifTrue: [^nil]
		ifFalse: [^subViews last]! !

!View methodsFor: 'subView access'!
resetSubViews
	"Set the list of subviews to an empty collection."
	
	subViews _ OrderedCollection new! !

!View methodsFor: 'subView access'!
subViewContaining: aPoint 
	"Answer the first subView that contains aPoint within its window and 
	answer nil, otherwise. It is typically sent from a Controller in order to 
	determine where to pass control (usually to the Controller of the View 
	returned by View|subViewContaining:)."

	subViews reverseDo: 
		[:aSubView | 
		(aSubView displayBox containsPoint: aPoint) ifTrue: [^aSubView]].
	^nil! !

!View methodsFor: 'subView access'!
subViewSatisfying: aBlock
	"Return the first subview that satisfies aBlock, or nil if none does.  1/31/96 sw"

	^ subViews detect: [:aView | aBlock value: aView] ifNone: [nil]! !

!View methodsFor: 'subView access'!
subViews
	"Answer the receiver's collection of subViews."

	^subViews! !

!View methodsFor: 'subView access'!
textEditorView
	"Return the first view in the receiver whose controller is a ParagraphEdior, or nil if none.  1/31/96 sw"

	(controller isKindOf: ParagraphEditor) ifTrue: [^ self].
	^ self subViewSatisfying:
		[:v | v textEditorView ~~ nil]! !


!View methodsFor: 'controller access'!
controller
	"If the receiver's controller is nil (the default case), answer an initialized 
	instance of the receiver's default controller. If the receiver does not 
	allow a controller, answer the symbol #NoControllerAllowed."

	controller == nil ifTrue: [self controller: self defaultController].
	^controller! !

!View methodsFor: 'controller access'!
controller: aController 
	"Set the receiver's controller to aController. #NoControllerAllowed can be 
	specified to indicate that the receiver will not have a controller. The 
	model of aController is set to the receiver's model."

	self model: model controller: aController! !

!View methodsFor: 'controller access'!
defaultController
	"Answer an initialized instance of the receiver's default controller. 
	Subclasses should redefine this message only if the default controller 
	instances need to be initialized in a nonstandard way."

	^self defaultControllerClass new! !

!View methodsFor: 'controller access'!
defaultControllerClass
	"Answer the class of the default controller for the receiver. Subclasses 
	should redefine View|defaultControllerClass if the class of the default 
	controller is not Controller."

	^Controller! !

!View methodsFor: 'controller access'!
model: aModel controller: aController 
	"Set the receiver's model to aModel, add the receiver to aModel's list of 
	dependents, and set the receiver's controller to aController. Subsequent 
	changes to aModel (see Model|change) will result in View|update: 
	messages being sent to the receiver. #NoControllerAllowed for the value 
	of aController indicates that no default controller is available; nil for the 
	value of aController indicates that the default controller is to be used 
	when needed. If aController is neither #NoControllerAllowed nor nil, its 
	view is set to the receiver and its model is set to aModel."

	model ~~ nil & (model ~~ aModel)
		ifTrue: [model removeDependent: self].
	aModel ~~ nil & (aModel ~~ model)
		ifTrue: [aModel addDependent: self].
	model _ aModel.
	aController ~~ nil
		ifTrue: 
			[aController view: self.
			aController model: aModel].
	controller _ aController! !


!View methodsFor: 'basic control sequence'!
subViewWantingControl
	"Answer the first subView that has a controller that now wants control."

	subViews reverseDo: 
		[:aSubView | aSubView controller isControlWanted ifTrue: [^aSubView]].
	^nil! !


!View methodsFor: 'window access'!
defaultWindow
	"Build the minimum Rectangle that encloses all the windows of the 
	receiver's subViews. The answer is a Rectangle obtained by expanding 
	this minimal Rectangle by the borderWidth of the receiver. If the 
	receiver has no subViews, then a Rectangle enclosing the entire display 
	screen is answered. It is used internally by View methods if no window 
	has been specified for the View. Specialized subclasses of View should 
	redefine View|defaultWindow to handle the default case for instances 
	that have no subViews."

	| aRectangle |
	subViews isEmpty ifTrue: [^DisplayScreen boundingBox].
	aRectangle _ self firstSubView viewport.
	subViews do: [:aView | aRectangle _ aRectangle merge: aView viewport].
	^aRectangle expandBy: borderWidth! !

!View methodsFor: 'window access'!
insetWindow
	"Answer a Rectangle that is obtained by insetting the receiver's window 
	rectangle by the border width."

	^self getWindow insetBy: borderWidth! !

!View methodsFor: 'window access'!
window
	"Answer a copy of the receiver's window."

	^self getWindow copy! !

!View methodsFor: 'window access'!
window: aWindow 
	"Set the receiver's window to a copy of aWindow."

	self setWindow: aWindow copy! !


!View methodsFor: 'viewport access'!
viewport
	"Answer a copy of the receiver's viewport."

	^self getViewport copy! !


!View methodsFor: 'display box access'!
apparentDisplayBox
	^self insetDisplayBox expandBy: 2 @ 2! !

!View methodsFor: 'display box access'!
boundingBox
	"Answer the bounding box which for the default case is the rectangular 
	area surrounding the bounding boxes of all the subViews."

	boundingBox ~~ nil
		ifTrue: [^boundingBox]
		ifFalse: [^self computeBoundingBox]! !

!View methodsFor: 'display box access'!
computeBoundingBox
	"Answer the minimum Rectangle that encloses the bounding boxes of the 
	receiver's subViews. If the receiver has no subViews, then the bounding 
	box is the receiver's window. Subclasses should redefine 
	View|boundingBox if a more suitable default for the case of no subViews 
	is available."

	| aRectangle |
	subViews isEmpty ifTrue: [^self getWindow].
	aRectangle _ self firstSubView transform: self firstSubView boundingBox.
	subViews do: 
		[:aView | 
		aRectangle _ aRectangle merge: (aView transform: aView boundingBox).].
	^aRectangle expandBy: borderWidth! !

!View methodsFor: 'display box access'!
displayBox
	"Answer the receiver's inset display box (see View|insetDisplayBox) 
	expanded by the borderWidth. The display box represents the region of 
	the display screen in which the receiver (including the border) is 
	displayed. If the receiver is totally clipped by the display screen and its 
	superView, the resulting Rectangle will be invalid."

	^self insetDisplayBox expandBy: borderWidth! !

!View methodsFor: 'display box access' stamp: 'acg 2/23/2000 00:08'!
insetDisplayBox
	"Answer the receiver's inset display box. The inset display box is the 
	intersection of the receiver's window, tranformed to display coordinates, 
	and the inset display box of the superView, inset by the border width. 
	The inset display box represents the region of the display screen in 
	which the inside of the receiver (all except the border) is displayed. If 
	the receiver is totally clipped by the display screen and its superView, 
	the resulting Rectangle will be invalid."

	insetDisplayBox ifNil: [insetDisplayBox _ self computeInsetDisplayBox].
	^insetDisplayBox! !


!View methodsFor: 'lock access'!
isLocked
	"Answer whether the receiver is locked. A View is 'locked' if its display 
	transformation and inset display box are defined. If these are undefined, 
	the View is 'unlocked'. The display transformation and inset display box 
	become undefined when the transformation of the View (or the 
	transformation of a View in its superView chain) is changed, or when 
	the superView of the View is changed, or any other change to the View 
	that affects the display screen coordinates of the View. The locking and 
	unlocking of a View is handled automatically by the internal methods of 
	the View, but can also be done explicitly if desired (see View|lock, and 
	View|unlock)."

	displayTransformation == nil | (insetDisplayBox == nil)
		ifTrue: [^false]
		ifFalse: [^true]! !

!View methodsFor: 'lock access'!
isUnlocked
	"Answer whether the receiver is unlocked. See comment in 
	View|isLocked."

	^displayTransformation == nil & (insetDisplayBox == nil)! !

!View methodsFor: 'lock access'!
lock
	"'Lock' the receiver and all of its subViews (see View|isLocked). This has 
	the effect of computing and storing the display transformation (see 
	View|displayTransformation) and inset display box (see 
	View|insetDisplayBox) of the receiver and all its subViews. The locking 
	and unlocking of a View is handled automatically by the internal 
	methods of the View, but can also be done explicitly if desired."

	self isLocked ifTrue: [^self].
	displayTransformation _ self computeDisplayTransformation.
	insetDisplayBox _ self computeInsetDisplayBox.
	subViews do: [:aSubView | aSubView lock]! !

!View methodsFor: 'lock access'!
unlock
	"Unlock the receiver and all of its subViews (see View|isUnlocked). This 
	has the effect of forcing the display transformation (see 
	View|displayTransformation) and inset display box (see 
	View|insetDisplayBox) of the receiver and all its subViews to be 
	recomputed the next time they are referenced. The locking and 
	unlocking of a View is handled automatically by the internal methods of 
	the View, but can also be done explicitly if desired."

	self isUnlocked ifTrue: [^self].
	displayTransformation _ nil.
	insetDisplayBox _ nil.
	subViews do: [:aSubView | aSubView unlock]! !


!View methodsFor: 'subView inserting'!
addSubView: aView 
	"Remove aView from the tree of Views it is in (if any) and adds it to the 
	rear of the list of subViews of the receiver. Set the superView of aView 
	to be the receiver. It is typically used to build up a hierarchy of Views 
	(a structured picture). An error notification is generated if aView is the 
	same as the receiver or its superView, and so on."

	self addSubView: aView ifCyclic: [self error: 'cycle in subView structure.']! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView above: lowerView
	"Adds aView (see View|addSubView:) so that it lies above topView."

	self addSubView: aSubView
		align: aSubView viewport bottomLeft
		with: lowerView viewport topLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView align: aPoint1 with: aPoint2 
	"Add aView to the receiver's list of subViews (see View|addSubView:) 
	and translate aView so that aPoint1 coincides with aPoint2. It is typically 
	used to build up a hierarchy of Views (a structured picture). Normally, 
	aPoint1 is a point on aView's viewport (e.g. aView viewport topLeft), 
	and aPoint2 is either an arbitrary point in the receiver's coordinate 
	system or a point on the receiver's window (e.g., self window topRight)."

	self addSubView: aSubView.
	aSubView align: aPoint1 with: aPoint2! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView below: lowerView
	"Add the argument, aSubView, (see View|addSubView:) so that it lies 
	below the view, topView."

	self addSubView: aSubView
		align: aSubView viewport topLeft
		with: lowerView viewport bottomLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aView ifCyclic: exceptionBlock 
	"Remove aView from the tree of Views it is in (if any) and add it to the 
	rear of the list of subViews of the receiver. Set the superView of aView 
	to be the receiver. It is typically used to build up a hierarchy of Views 
	(a structured picture). An error notification is generated if aView is the 
	same as the receiver or its superView, and so on."

	(self isCyclic: aView)
		ifTrue: [exceptionBlock value]
		ifFalse: 
			[aView removeFromSuperView.
			subViews addLast: aView.
			aView superView: self]! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView toLeftOf: rightView
	"Adds aView (see addSubView:) so that it lies to the right of rightView."

	self addSubView: aSubView
		align: aSubView viewport topRight
		with:  rightView viewport topLeft! !

!View methodsFor: 'subView inserting'!
addSubView: aSubView toRightOf: leftView
	"Add the argument, aSubView, (see View|addSubView:) so that it lies to 
	the right of the view, leftView."

	self addSubView: aSubView
		align: aSubView viewport topLeft
		with: leftView viewport topRight! !

!View methodsFor: 'subView inserting'!
addSubView: aView viewport: aViewport 
	"Add aView to the receiver's list of subViews (see View|addSubView:) and 
	applies to aView a scale and translation computed from its window and 
	aViewport (such that its window fills aViewport)."

	self addSubView: aView.
	aView window: aView window viewport: aViewport! !

!View methodsFor: 'subView inserting'!
addSubView: aView window: aWindow viewport: aViewport 
	"Add aView to the receiver's list of subViews (see View|addSubView:) 
	and applies to aView a scale and translation computed from aWindow 
	and aViewport (such that aWindow fills aViewport)."

	self addSubView: aView.
	aView window: aWindow viewport: aViewport! !


!View methodsFor: 'subView removing'!
releaseSubView: aView 
	"Delete aView from the receiver's list of subViews and send it the 
	message 'release' (so that it can break up cycles with subViews, etc.)."

	self removeSubView: aView.
	aView release! !

!View methodsFor: 'subView removing'!
releaseSubViews
	"Release (see View|releaseSubView:) all subViews in the receiver's list of 
	subViews."

	subViews do: [:aView | aView release].
	self resetSubViews! !

!View methodsFor: 'subView removing'!
removeFromSuperView
	"Delete the receiver from its superView's collection of subViews."

	superView ~= nil ifTrue: [superView removeSubView: self]! !

!View methodsFor: 'subView removing'!
removeSubView: aView 
	"Delete aView from the receiver's list of subViews. If the list of subViews 
	does not contain aView, create an error notification."

	subViews remove: aView.
	aView superView: nil.
	aView unlock! !

!View methodsFor: 'subView removing'!
removeSubViews
	"Delete all the receiver's subViews."

	subViews do: 
		[:aView | 
		aView superView: nil.
		aView unlock].
	self resetSubViews! !


!View methodsFor: 'displaying'!
clippingTo: rect do: aBlock

	superView clippingTo: rect do: aBlock! !

!View methodsFor: 'displaying'!
display
	"Display the receiver's border, display the receiver, then display the 
	subViews of the receiver. Can be sent to the top View of a structured 
	picture in order to display the entire structure, or to any particular View 
	in the structure in order to display that View and its subViews. It is 
	typically sent in response to an update request to a View."

	self displayBorder.
	self displayView.
	self displaySubViews! !

!View methodsFor: 'displaying'!
displayBorder
	"Display the receiver's border (using the receiver's borderColor)."

	borderWidth = 0
		ifTrue:
			[insideColor == nil
				ifFalse: 
					[Display fill: self displayBox fillColor: self backgroundColor]]
		ifFalse:
			[Display
				border: self displayBox
				widthRectangle: borderWidth
				rule: Form over
				fillColor: self foregroundColor.
			insideColor == nil ifFalse:
				[Display fill: self insetDisplayBox fillColor: self backgroundColor]]! !

!View methodsFor: 'displaying'!
displayClippingTo: rect

	| bigRect |
	bigRect _ rect insetBy: -1.
	self clippingTo: bigRect do: [Display clippingTo: bigRect do: [self display]]
! !

!View methodsFor: 'displaying'!
displayDeEmphasized
	self display; deEmphasize! !

!View methodsFor: 'displaying'!
displaySubViews
	"Display all the subViews of the receiver."

	subViews do: [:aSubView | aSubView display]! !

!View methodsFor: 'displaying'!
displayView
	"Subclasses should redefine View|displayView in order to display 
	particular objects associated with the View such as labels, lines, and 
	boxes."

	^self! !

!View methodsFor: 'displaying'!
displayViewDeEmphasized
	self displayView; deEmphasizeView! !

!View methodsFor: 'displaying'!
inspectFirstSubView
	subViews notNil ifTrue:
		[subViews size > 0 ifTrue:
			[(subViews at: 1) inspect]]! !

!View methodsFor: 'displaying'!
inspectModel
	model notNil
		ifTrue: [^ model inspect]
		ifFalse: [self flash]! !

!View methodsFor: 'displaying'!
inspectView
	^self inspect! !

!View methodsFor: 'displaying'!
maximumSize
	"Answer the maximum size of the receiver."

	^ 10000 @ 10000
	! !

!View methodsFor: 'displaying'!
minimumSize
	"Answer the minimum size of the receiver."
	^ 10 @ 10
	! !


!View methodsFor: 'deEmphasizing'!
deEmphasize
	"Modify the emphasis (highlighting, special tabs) of the receiver. This 
	includes objects such as labels, lines, and boxes. Typically used so that 
	the receiver is not presented as active. Do this for the receiver and then 
	for each of the receiver's subViews."

	self deEmphasizeView.
	self deEmphasizeSubViews! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeForDebugger
	"Overridden by StandardSystemView. This default behavior does nothing."
! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeSubViews
	"Send the deEmphasize message to each of the receiver's subviews."

	subViews do: [:aSubView | aSubView deEmphasize]! !

!View methodsFor: 'deEmphasizing'!
deEmphasizeView
	"Subclasses should redefine View|deEmphasizeView in order to modify 
	the emphasis (highlighting, special tabs) of particular objects associated 
	with the View such as labels, lines, and boxes."

	^self! !

!View methodsFor: 'deEmphasizing'!
emphasize
	"Modify the emphasis (highlighting, special tabs) of the receiver. This 
	includes objects such as labels, lines, and boxes. Typically used so that 
	the receiver is presented as active. Do this for the receiver and then 
	for each of the receiver's subViews."

	self emphasizeView.
	self emphasizeSubViews! !

!View methodsFor: 'deEmphasizing'!
emphasizeSubViews
	"Send the emphasize message to each of the receiver's subviews."

	subViews do: [:aSubView | aSubView emphasize]! !

!View methodsFor: 'deEmphasizing'!
emphasizeView
	"Subclasses should redefine View|emphasizeView in order to modify 
	the emphasis (highlighting, special tabs) of particular objects associated 
	with the View such as labels, lines, and boxes."

	^self! !


!View methodsFor: 'display transformation'!
displayTransform: anObject 
	"Apply the display transformation of the receiver to anObject (see 
	View|displayTransformation) and answer the resulting scaled, translated 
	object. It is normally applied to Rectangles, Points, and other objects with 
	coordinates defined in the View's local coordinate system in order to get 
	a corresponding object in display coordinates."

	^(self displayTransformation applyTo: anObject) rounded! !

!View methodsFor: 'display transformation'!
displayTransformation
	"Answer a WindowingTransformation that is the result of composing all 
	local transformations in the receiver's superView chain with the 
	receiver's own local transformation. The resulting transformation 
	transforms objects in the receiver's coordinate system into objects in the 
	display screen coordinate system."

	displayTransformation == nil
		ifTrue: [displayTransformation _ self computeDisplayTransformation].
	^displayTransformation! !

!View methodsFor: 'display transformation'!
inverseDisplayTransform: aPoint 
	"Answer a Point that is obtained from the argument, aPoint, by applying 
	to it the inverse of the receiver's display transformation. It is typically 
	used by the Controller of the receiver in order to convert a point in 
	display coordinates, such as the cursor point, to the local coordinate 
	system of the receiver."

	^self displayTransformation applyInverseTo: aPoint! !


!View methodsFor: 'transforming'!
align: aPoint1 with: aPoint2 
	"Add a translation of (aPoint2 - aPoint1) to the receiver's local 
	transformation. The point in the receiver's coordinate system that 
	previously was transformed to aPoint1 in the superView's coordinate 
	system will now be transformed to aPoint2 in the superView's coordinate 
	system. Other points will be translated by the same amount. It is 
	normally used when adding subViews to their superView in order to 
	line up the Viewport of one subView with that of another subView (see 
	View|addSubView:align:with:). aPoint1 and aPoint2 are usually points on 
	the viewports that are to be aligned. For example, 'subView2 align: 
	subView2 viewport topLeft with: subView1 viewport topRight' would be 
	used to place the viewport of subView2 next to the viewport of 
	subView1 with the topLeft and topRight corners, respectively, 
	coinciding. It is also possible to align the viewport of a subView with 
	the window of the superView, e.g., 'subView align: subView viewport 
	center with: superView window center'. View|align:with: assumes that 
	the view has been properly scaled, if necessary, to match its superView 
	(see View|scaleBy:). Typically, the coordinate systems of the receiver 
	and its superView will differ only by a translation offset so that no 
	scaling is necessary."

	self setTransformation: (transformation align: aPoint1 with: aPoint2)! !

!View methodsFor: 'transforming'!
scale: aScale translation: aTranslation 
	"The x component of aScale (a Point) specifies the scale (translation) in 
	the x direction; the y component specifies the scale (translation) in the y 
	direction. aScale can optionally be an instance of Integer or Float in 
	order to specify uniform scaling in both directions. Create a new local 
	transformation for the receiver with a scale factor of aScale and a 
	translation offset of aTranslation. When the transformation is applied (see 
	View|transform:), the scale is applied first, followed by the translation. It 
	is typically used when building a superView from its subViews in order 
	to line up the viewports of the subViews in the desired way. If no 
	scaling is required between subView and superView, then 
	View|align:with: is often more convenient to use."

	self setTransformation:
		(WindowingTransformation scale: aScale translation: aTranslation)! !

!View methodsFor: 'transforming'!
scaleBy: aScale 
	"The x component of aScale (a Point) specifies the scale in the x 
	direction; the y component specifies the scale in the y direction. aScale 
	can, optionally, be an instance of Integer or Float in order to specify 
	uniform scaling in both directions. Scales the View by aScale. The scale 
	is concatenated with the current transformation of the receiver and is 
	applied when View|transform is sent. This happens automatically in the 
	process of displaying the receiver, for example."

	self setTransformation: (transformation scaleBy: aScale)! !

!View methodsFor: 'transforming'!
transform: anObject 
	"Apply the local transformation of the receiver to anObject and answer 
	the resulting transformation. It is used to get the superView coordinates 
	of an object. For example, the viewport is equal to the window 
	transformed."

	^transformation applyTo: anObject! !

!View methodsFor: 'transforming'!
transformation
	"Answer a copy of the receiver's local transformation."

	^transformation copy! !

!View methodsFor: 'transforming'!
transformation: aTransformation 
	"Set the receiver's local transformation to a copy of aTransformation, 
	unlock the receiver (see View|unlock) and set the viewport to undefined 
	(this forces it to be recomputed when needed)."

	self setTransformation: aTransformation copy! !

!View methodsFor: 'transforming'!
translateBy: aPoint 
	"Translate the receiver by aPoint. The translation is concatenated with 
	the current transformation of the receiver and is applied when 
	View|transform is sent. This happens automatically in the process of 
	displaying the receiver."

	self setTransformation: (transformation translateBy: aPoint)! !

!View methodsFor: 'transforming'!
window: aWindow viewport: aViewport 
	"Set the receiver's window to aWindow, set its viewport to aViewport, and 
	create a new local transformation for the receiver based on aWindow and 
	aViewport. The receiver is scaled and translated so that aWindow, when 
	transformed, coincides with aViewport. It is used to position a subView's 
	window within some specific region of its superView's area. For example, 
	'subView window: aRectangle1 viewport: aRectangle2' sets subView's 
	window to aRectangle1, its viewport to aRectangle2, and its local 
	transformation to one that transforms aRectangle1 to aRectange2."

	self window: aWindow.
	self setTransformation:
		(WindowingTransformation window: aWindow viewport: aViewport).
	self getViewport! !


!View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:34'!
backgroundColor
	Display depth <= 2 ifTrue: [^ Color white].
	insideColor ifNotNil: [^ Color colorFrom: insideColor].
	^ superView == nil
		ifFalse: [superView backgroundColor]
		ifTrue:	[Color white]! !

!View methodsFor: 'bordering' stamp: 'tk 10/21/97 12:31'!
backgroundColor: aColor
	Display depth = 1 ifTrue:
		[(aColor ~= nil and: [aColor isTransparent not]) ifTrue:
			["Avoid stipple due to attempts to match non-whites"
			^ insideColor _ Color white]].
	insideColor _ aColor! !

!View methodsFor: 'bordering'!
borderWidth
	"Answer either 0, indicating no border, or a Rectangle whose left value is 
	the width in display coordinates of the receiver's left border. Right, top, 
	and bottom widths are analogous. The border width is initially 0. A 
	View with a border width of 0 will not have any border displayed."

	^borderWidth! !

!View methodsFor: 'bordering'!
borderWidth: anInteger
	"Set the four border widths of the receiver to anInteger."

	self
		borderWidthLeft: anInteger
		right: anInteger
		top: anInteger
		bottom: anInteger! !

!View methodsFor: 'bordering'!
borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4
	"Set the border widths of the receiver. These arguments represent the left, 
	right, top, and bottom border widths."

	borderWidth _
			Rectangle
				left: anInteger1
				right: anInteger2
				top: anInteger3
				bottom: anInteger4.
	self unlock! !

!View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:35'!
foregroundColor
	borderColor ifNotNil: [^ Color colorFrom: borderColor].
	^ superView == nil
		ifFalse: [superView foregroundColor]
		ifTrue:	[Color black]! !

!View methodsFor: 'bordering'!
foregroundColor: aColor
	borderColor _ aColor! !

!View methodsFor: 'bordering'!
insideColor: aColor 
	^ self backgroundColor: aColor! !


!View methodsFor: 'scrolling'!
scrollBy: aPoint 
	"The x component of aPoint specifies the amount of scrolling in the x 
	direction; the y component specifies the amount of scrolling in the y 
	direction. The amounts are specified in the receiver's local coordinate 
	system. Scroll the receiver up or down, left or right. The window of the 
	receiver is kept stationary and the subViews and other objects in the 
	receiver are translated relative to it. Scrolling doesn't change the 
	insetDisplayBox or the viewport since the change in the transformation 
	is canceled by the change in the window. In other words, all display 
	objects in the view, except the window, are translated by the scrolling 
	operation.
	Note: subclasses may override to return false if no scrolling takes place."

	| aRectangle |
	aRectangle _ insetDisplayBox.
	transformation _ transformation scrollBy: aPoint.
	window _ self getWindow translateBy: aPoint x negated @ aPoint y negated.
	self unlock.
	insetDisplayBox _ aRectangle.
	^ true! !


!View methodsFor: 'clearing'!
clear
	"Use the border color to paint the display box (including the border, see 
	View|displayBox) of the receiver."

	borderColor ~= nil ifTrue: [self clear: Color black]! !

!View methodsFor: 'clearing'!
clear: aColor 
	"Use aColor to paint the display box (including the border, see 
	View|displayBox) of the receiver."

	aColor ~= nil ifTrue: [Display fill: self displayBox fillColor: aColor]! !

!View methodsFor: 'clearing'!
clearInside
	"Use the inside color to paint the inset display box (excluding the border, 
	see View|insetDisplayBox) of the receiver."

	self clearInside: self backgroundColor! !

!View methodsFor: 'clearing'!
clearInside: aColor 
	"Use aColor to paint the inset display box (excluding the border, see 
	View|insetDisplayBox) of the receiver."

	aColor ~~ nil ifTrue: [Display fill: self insetDisplayBox fillColor: aColor]! !


!View methodsFor: 'indicating'!
flash
	"Cause the inset display box (the display box excluding the border, see 
	View|insetDisplayBox) of the receiver to complement twice in succession."

	Display flash: self insetDisplayBox! !

!View methodsFor: 'indicating'!
highlight
	"Cause the inset display box (the display box excluding the border, see 
	View|insetDisplayBox) of the receiver to complement."

	Display reverse: self insetDisplayBox! !


!View methodsFor: 'updating'!
update
	"Normally sent by the receiver's model in order to notify the receiver of 
	a change in the model's state. Subclasses implement this message to do 
	particular update actions. A typical action that might be required is to 
	redisplay the receiver."

	self update: self! !

!View methodsFor: 'updating'!
update: aParameter 
	"Normally sent by the receiver's model in order to notify the receiver of 
	a change in the model's state. Subclasses implement this message to do 
	particular update actions. A typical action that might be required is to 
	redisplay the receiver."

	^self! !


!View methodsFor: 'private'!
computeDisplayTransformation
	"Answer a WindowingTransformation that transforms the coordinate 
	system of the View into that of the display screen. The transformation is 
	computed by composing the View's transformation with all transformations 
	along its superView chain. It is sent by View|displayTransformation when
	the View is unlocked (see View|unlock)."

	self isTopView
		ifTrue: [^transformation]
		ifFalse: [^superView displayTransformation compose: transformation]! !

!View methodsFor: 'private'!
computeInsetDisplayBox
	"Compute the View's inset display box by intersecting the superView's
	inset display box with the View's window transformed to display
	coordinates and then inseting the result by the border width. It is sent by 
	View|insetDisplayBox if the inset display box is nil.

	The insetDisplayBox points are truncated to prevent sending floating point numbers to QuickDraw which will die."

	self isTopView
		ifTrue:
			[^((self displayTransform: self getWindow) insetBy: borderWidth) truncated]
		ifFalse:
			[^(superView insetDisplayBox
				intersect: (self displayTransform: self getWindow)) truncated
						insetBy: borderWidth]! !

!View methodsFor: 'private'!
getController
	"Answer the View's controller if one exists. nil indicates that the default
	controller is to be used."

	^controller! !

!View methodsFor: 'private'!
getViewport
	"Answer the Rectangle representing the View's viewport (in the
	coordinate system of the superclass). If no viewport has been specified,
	the View's window transformed into the superView's coordinate system is
	saved and returned. It should be used by methods of View and subclasses
	(instead of directly referring to the viewport) unless it is known that a
	viewport actually exists. It should not be used outside of View or
	subclasses because the viewport is not sharable."

	viewport == nil ifTrue: [viewport _ (self transform: self getWindow) truncated].
	^viewport! !

!View methodsFor: 'private'!
getWindow
	"Answer the Rectangle that represents the window of this View. If no
	window has been specified, a default window (see View|defaultWindow)
	is created, saved, and returned. Should be used by methods of View and
	subclasses to access the View window instead of directly accessing the
	field unless it is known that a window actually exists. It is not to be used
	outside of View (or subclasses) because the window is not sharable.
	View|window should be used for outside access to the window."

	window == nil ifTrue: [self setWindow: self defaultWindow].
	^window! !

!View methodsFor: 'private'!
isCyclic: aView 
	"Answer true if aView is the same as this View or its superView, false 
	otherwise."

	self == aView ifTrue: [^true].
	self isTopView ifTrue: [^false].
	^superView isCyclic: aView! !

!View methodsFor: 'private'!
setTransformation: aTransformation 
	"Set the View's local transformation to aTransformation, unlock the View 
	(see View|unlock), and set the viewport to undefined (this forces it to be 
	recomputed when needed). Should be used instead of setting the 
	transformation directly."

	transformation _ aTransformation.
	self unlock.
	viewport _ nil! !

!View methodsFor: 'private'!
setWindow: aWindow 
	"Set the View's window to aWindow and unlock the View (see
	View|unlock). View|setWindow should be used by methods of View and
	subclasses to set the View window (rather than directly setting the
	instance variable) to insure that the View is unlocked."

	window _ aWindow.
	viewport _ nil.
	self unlock! !

!View methodsFor: 'private'!
superView: aView 
	"Set the View's superView to aView and unlock the View (see
	View|unlock). It is sent by View|addSubView: in order to properly set all
	the links."

	superView _ aView.
	self unlock! !


!View methodsFor: 'miscellaneous'!
clipRect
	^ superView clipRect! !

!View methodsFor: 'miscellaneous'!
clipRect: r
	superView clipRect: r! !

!View methodsFor: 'miscellaneous'!
gridSpacing
	^ superView gridSpacing! !

!View methodsFor: 'miscellaneous'!
nestedViewport

	"The viewport size used to control scaling of nested user views."

	^ (0@0 extent: self viewport extent)
			insetBy: 16 @ 16! !

!View methodsFor: 'miscellaneous'!
printViewSpecOn: strm nested: level
	"Print window and viewport specs
	of this and all nested views."
	strm crtab: level; nextPutAll: self class name.
	strm crtab: level; nextPutAll: 'window: '; print: self window.
	strm crtab: level; nextPutAll: 'viewport: '; print: self viewport.
	strm crtab: level; nextPutAll: 'displayBox: '; print: self displayBox.
	strm crtab: level; nextPutAll: 'border: '; print: self borderWidth.
	subViews do: [:v | v printViewSpecOn: strm nested: level+1]! !

!View methodsFor: 'miscellaneous'!
stretchFrame: newFrameBlock startingWith: startFrame 
	"Track the outline of a newFrame as long as mouse drags it.
	Maintain max and min constraints throughout the drag"
	| frame newFrame click |
	frame _ startFrame origin extent: ((startFrame extent min: self maximumSize)
											max: self minimumSize).
	Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
	click _ false.
	[click and: [Sensor noButtonPressed]] whileFalse: 
		[Processor yield.
		click _ click | Sensor anyButtonPressed.
		newFrame _ newFrameBlock value: frame.
		newFrame _ newFrame topLeft extent: ((newFrame extent min: self maximumSize)
											max: self minimumSize).
		newFrame = frame ifFalse:
			[Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
			Display border: newFrame width: 2 rule: Form reverse fillColor: Color gray.
			frame _ newFrame]].
	Display border: frame width: 2 rule: Form reverse fillColor: Color gray.
	^ frame! !


!View methodsFor: 'morphic compatibility' stamp: 'mdr 1/24/2000 17:27'!
setBalloonText: aString
	"Unfortunately we just ignore this help text because we are not morphic"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

View class
	instanceVariableNames: ''!

!View class methodsFor: 'instance creation'!
new
	"Answer an initialized instance of me. The transformation is an identity 
	transformation, the borderWidth is 0, the borderColor is black, and the 
	insideColor is transparent."

	^super new initialize! !
AlignmentMorph subclass: #Viewer
	instanceVariableNames: 'scriptedPlayer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting'!

!Viewer methodsFor: 'copying' stamp: 'tk 1/7/1999 17:01'!
veryDeepFixupWith: deepCopier
	"If target and arguments fields were weakly copied, fix them here.  If they were in the tree being copied, fix them up, otherwise point to the originals!!!!"

super veryDeepFixupWith: deepCopier.
scriptedPlayer _ deepCopier references at: scriptedPlayer ifAbsent: [scriptedPlayer].! !

!Viewer methodsFor: 'copying' stamp: 'tk 1/8/1999 07:42'!
veryDeepInner: deepCopier
	"Copy all of my instance variables.  Some need to be not copied at all, but shared.  	Warning!!!!  Every instance variable defined in this class must be handled.  We must also implement veryDeepFixupWith:.  See DeepCopier class comment."

super veryDeepInner: deepCopier.
scriptedPlayer _ scriptedPlayer.		"Weakly copied"
	"Store into it to satisfy checkVariables"! !


!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/29/1998 16:08'!
colorSeesPhrase
	| outerPhrase |
	outerPhrase _ PhraseTileMorph new setOperator: #+ "temp dummy" 
				type: #boolean rcvrType: #player argType: #color.
	"Install (ColorSeerTile new) in middle position"
	(outerPhrase submorphs at: 2) delete.	"operator"
	outerPhrase addMorphBack: ColorSeerTile new.
	(outerPhrase submorphs at: 2) goBehind.		"Make it third"
	outerPhrase submorphs last addMorph: (ColorTileMorph new typeColor: 
		(ScriptingSystem colorForType: #color)).
	^ outerPhrase! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/22/1998 12:25'!
controlButtonColor
	^ Color blue muchLighter! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/30/2000 17:03'!
filteringScheme
	"The filteringScheme dictates how the viewer will obtain the subparts to show.  In the first implementation, we used the following choices:
		minimal		specially-designated methods in root class + everything defined in uniclass
		standard	a canonical point of departure
		most		everything up to but not including Object
		custom		everything up to but not including some limit class designated by user
		myOwn		exactly the methods of defined in my own class (like existing Smalltalk browsers)
		all			everything from root class right up to Object"

	"Later we may want individual category viewers to have their own choice here, but for now we have a single control for the entire outer viewer??"

	| determiner |
	(determiner _ self ownerThatIsA: StandardViewer) ifNil: [^ #standard].
	^ determiner filteringScheme! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'ar 11/9/2000 22:00'!
initialize
	super initialize.
	self useRoundedCorners.
	self hResizing: #shrinkWrap; vResizing: #shrinkWrap.! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1998 15:55'!
isAViewer
	^ true! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1999 08:43'!
isCandidateForAutomaticViewing
	^ false! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 1/26/2001 15:26'!
newPermanentScript
	"Create a new, empty script and attach it to the hand"

	| aMorph |
	self scriptedPlayer assureUniClass.
	aMorph _ ImageMorph new image: (ScriptingSystem formAtKey: 'newScript').
	aMorph setProperty: #newPermanentScript toValue: true.
	aMorph setProperty: #newPermanentPlayer toValue: self scriptedPlayer.
	self primaryHand attachMorph: aMorph! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 4/7/1999 17:26'!
nextCostume
	| aList aPlayer itsCurrent anIndex newIndex |
	aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows.
	aList isEmptyOrNil ifTrue: [^ self beep].
	itsCurrent _ aPlayer costume renderedMorph.
	anIndex _ aList indexOf: itsCurrent ifAbsent: [nil].
	newIndex _ anIndex
		ifNil:		[1]
		ifNotNil:	[anIndex + 1].
	newIndex > aList size ifTrue: [newIndex _ 1].
	aPlayer renderedCostume: (aList at: newIndex).
	self presenter ifNotNil: [self presenter updateViewer: self]! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 11/5/1998 15:48'!
noteDeletionOf: aMorph
	| pal |
	aMorph player == scriptedPlayer ifTrue:
		[(pal _ self standardPalette)
			ifNotNil: [pal showNoPalette]
			ifNil:	[self delete]]   "Viewer on a discarded player"! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/25/2000 08:30'!
objectViewed
	"Answer the graphical object to which the receiver's phrases apply"

	^ (scriptedPlayer isKindOf: Player)
		ifTrue:
			[scriptedPlayer costume]
		ifFalse:
			[scriptedPlayer]! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 4/7/1999 17:26'!
previousCostume
	| aList aPlayer itsCurrent anIndex newIndex |
	aList _ (aPlayer _ scriptedPlayer) availableCostumesForArrows.
	aList isEmptyOrNil ifTrue: [^ self beep].
	itsCurrent _ aPlayer costume renderedMorph.
	anIndex _ aList indexOf: itsCurrent ifAbsent: [nil].
	newIndex _ anIndex
		ifNil:		[aList size]
		ifNotNil:	[anIndex - 1].
	newIndex < 1 ifTrue: [newIndex _ aList size].
	aPlayer renderedCostume: (aList at: newIndex).
	self presenter ifNotNil: [self presenter updateViewer: self]! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/6/2000 22:41'!
retargetFrom: oldPlayer to: newPlayer
	"Retarget the receiver so that instead of viewing oldPlayer, it now views newPlayer, which are expected to be different instances of the same uniclass"

	scriptedPlayer == oldPlayer
		ifTrue:
			[self allMorphs do:  "nightmarishly special-cased, sorry"
				[:aMorph | 
					(aMorph isKindOf: Viewer) ifTrue:  "includes self"
						[aMorph scriptedPlayer: newPlayer].
					((aMorph isKindOf: UpdatingStringMorph) and: [aMorph target == oldPlayer]) ifTrue:
						[aMorph target: newPlayer].
					(aMorph isKindOf: TileMorph) ifTrue:
						[aMorph retargetFrom: oldPlayer to: newPlayer]]]! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1998 15:56'!
scriptedPlayer
	^ scriptedPlayer! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/20/1998 13:20'!
scriptedPlayer: aPlayer
	scriptedPlayer _ aPlayer! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'sw 10/29/1998 16:09'!
seesColorPhrase
	| outerPhrase seesColorTile |
	outerPhrase _ PhraseTileMorph new setOperator: #+ "temp dummy" 
				type: #boolean rcvrType: #player argType: #color.
	"Install (ColorSeerTile new) in middle position"
	(outerPhrase submorphs at: 2) delete.	"operator"
	seesColorTile _ TileMorph new setOperator: #seesColor:.
	outerPhrase addMorphBack: seesColorTile.
	(outerPhrase submorphs at: 2) goBehind.		"Make it third"
"	selfTile _ self tileForSelf bePossessive.	Done by caller.
	selfTile position: 1.
	outerPhrase firstSubmorph addMorph: selfTile.
"
	outerPhrase submorphs last addMorph: (ColorTileMorph new typeColor: 
		(ScriptingSystem colorForType: #color)).
	^ outerPhrase! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'RAA 1/13/2001 11:14'!
touchesAPhrase

	| outerPhrase |

	outerPhrase _ PhraseTileMorph new setOperator: #+ "temp dummy" 
				type: #boolean rcvrType: #player argType: #player.

	(outerPhrase submorphs at: 2) delete.	"operator"
	outerPhrase addMorphBack: (TileMorph new setOperator: #touchesA:).
	(outerPhrase submorphs at: 2) goBehind.		"Make it third"

	outerPhrase submorphs last addMorph: (
		TileMorph new
			setObjectRef: nil "disused parm"
			actualObject: scriptedPlayer;
			typeColor: (ScriptingSystem colorForType: #player)
	).
	^ outerPhrase! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'ar 9/18/2000 18:34'!
wantsToBeDroppedInto: aMorph
	"Return true if it's okay to drop the receiver into aMorph"
	^aMorph isWorldMorph "only into worlds"! !

!Viewer methodsFor: 'as yet unclassified' stamp: 'di 9/24/2000 12:55'!
worldMorphsDo: aBlock  "No worlds hiding here"

	^ self! !



!Viewer methodsFor: 'queries' stamp: 'sw 10/27/2000 13:20'!
aboutMethod: aSelector
	"Give the user documentation for the selector"

	| aClass help |
	aClass _ scriptedPlayer class classThatUnderstands: aSelector.
	help _ aClass firstCommentAt: aSelector.
	help ifNotNil:
		[self inform: (help string withNoLineLongerThan: 25)]
! !

!Viewer methodsFor: 'queries' stamp: 'sw 10/27/2000 11:32'!
browseImplementorsOf: aSelector
	"Open a browser on implementors of aSelector"

	Smalltalk browseAllImplementorsOf: aSelector

! !

!Viewer methodsFor: 'queries' stamp: 'sw 10/30/2000 17:00'!
browseMethodFull: aSelector
	"Open a traditional browser on aSelector, in whatever class implements aSelector"

	| aClass |
	aClass _ scriptedPlayer class classThatUnderstands: aSelector.
	Browser fullOnClass: aClass selector: aSelector

! !

!Viewer methodsFor: 'queries' stamp: 'sw 10/27/2000 11:38'!
browseMethodInheritance: aSelector
	"Open an inheritance browser on aSelector"

	| aClass |
	aClass _ scriptedPlayer class classThatUnderstands: aSelector.
	Utilities methodHierarchyBrowserForClass: aClass selector: aSelector

! !

!Viewer methodsFor: 'queries' stamp: 'sw 10/27/2000 11:33'!
browseSendersOf: aSelector
	"Open a browser on senders of aSelector"

	Smalltalk browseAllCallsOn: aSelector

! !

!Viewer methodsFor: 'queries' stamp: 'sw 10/30/2000 17:00'!
browseVersionsOf: aSelector
	"Open a browser on versions of aSelector"

	| aClass |
	aClass _ scriptedPlayer class classThatUnderstands: aSelector.
	Utilities browseVersionsForClass: aClass selector: aSelector
! !
AlignmentMorph subclass: #ViewerEntry
	instanceVariableNames: 'helpPane '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!ViewerEntry methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:44'!
initialize
	super initialize.
	color _ Color r: 1.0 g: 0.985 b: 0.985.
	self layoutInset: 0! !


!ViewerEntry methodsFor: 'access' stamp: 'sw 11/5/1998 10:09'!
entryType
	^ self viewerRow entryType! !

!ViewerEntry methodsFor: 'access' stamp: 'sw 12/28/1998 13:02'!
phraseTileMorph
	"Answer the phraseTileMorph within the receiver"

	^ ((self entryType == #systemScript) or: [self entryType == #userScript])
		ifTrue:
			[self viewerRow findA: PhraseTileMorph]
		ifFalse:
			[self error: 'slot rows do not contain a phrase tile morph']! !

!ViewerEntry methodsFor: 'access' stamp: 'sw 12/28/1998 13:01'!
playerBearingCode
	^ owner owner scriptedPlayer! !

!ViewerEntry methodsFor: 'access' stamp: 'sw 11/5/1998 10:09'!
viewerRow
	"Answer the ViewerRow object, that contains the controls and the phraseTile"
	^ submorphs first! !


!ViewerEntry methodsFor: 'contents' stamp: 'sw 11/6/1998 11:14'!
contents: c notifying: k
	"later, spruce this up so that it can accept input such as new method source"
	| info |
	(info _ self userSlotInformation)
		ifNotNil:
			[info documentation: c.
			^ true].
	self beep.
	^ false! !

!ViewerEntry methodsFor: 'contents' stamp: 'sw 11/5/1998 09:31'!
contentsSelection
	"Not well understood why this needs to be here!!"
	^ 1 to: 0! !


!ViewerEntry methodsFor: 'menu' stamp: 'sw 11/9/1998 13:57'!
codePaneMenu: aMenu shifted: shifted
	^ aMenu 
		labels: 'menu
eventually
will
be
useful'
		lines: #(1)
		selections: #(beep flash beep flash beep)! !


!ViewerEntry methodsFor: 'slot' stamp: 'sw 1/13/1999 12:57'!
slotName
	"Assuming the receiver represents a slot, return its name"

	^  self viewerRow elementSymbol! !

!ViewerEntry methodsFor: 'slot' stamp: 'sw 12/28/1998 12:50'!
userSlotInformation
	"If the receiver represents a user-defined slot, then return its info; if not, retun nil"
	| aSlotName info |
	((self entryType == #systemSlot) or: [self entryType == #userSlot])
		ifFalse:
			[^ nil].
	aSlotName _ self slotName.
	^ ((info _ self playerBearingCode slotInfo) includesKey: aSlotName)
		ifTrue:
			[info at: aSlotName]
		ifFalse:
			[nil]! !


!ViewerEntry methodsFor: 'user interface' stamp: 'sw 11/5/1998 21:04'!
detailButtonPressed
	helpPane
		ifNotNil:
			[helpPane delete.
			helpPane _ nil]
		ifNil:
			[self addHelpPane]! !

FlapTab subclass: #ViewerFlapTab
	instanceVariableNames: 'scriptedPlayer '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Palettes'!

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:55'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	aMenu add: 'flap color...' target: self action: #changeFlapColor.
! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:57'!
addCustomMenuItems: aMenu hand: aHandMorph

	aMenu addLine.
	aMenu addUpdating: #compactFlapString target: self action: #changeCompactFlap.
	aMenu addLine.
	aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior.
	aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior.
	aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo.
	aMenu addLine.
	aMenu add: 'destroy this flap' action: #destroyFlap.! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'tk 1/31/2001 16:03'!
allNonSubmorphMorphs
	"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy.  Especially the non-showing pages in BookMorphs."

	^ flapShowing 
		ifTrue: [#()]
		ifFalse: [Array with: referent]! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:58'!
changeCompactFlap
	self makeFlapCompact: self isFlapCompact not.! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:56'!
compactFlapString
	^self isFlapCompact
		ifTrue:['<on>compact flap']
		ifFalse:['<off>compact flap']! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'sw 7/7/1999 12:50'!
graphicalMorphForTab
	^ ThumbnailMorph new  objectToView: scriptedPlayer viewSelector: #costume! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'tk 1/31/2001 10:09'!
hibernate
	| ut |
	"drop my viewer to save space when writing to the disk."

	ut _ self world valueOfProperty: #universalTiles ifAbsent: [false].
	referent submorphs do: 
		[:m | (m isKindOf: Viewer) ifTrue: [ut ifTrue: [m delete]]].
! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'sw 7/7/1999 13:14'!
initializeFor: aPlayer topAt: aTop

	scriptedPlayer _ aPlayer.
	self useGraphicalTab.
	self top: aTop! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'sw 7/7/1999 13:28'!
isCurrentlyGraphical
	^ true! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:54'!
isFlapCompact
	"Return true if the referent of the receiver represents a 'compact' flap"
	referent layoutPolicy ifNil:[^false].
	referent layoutPolicy isTableLayout ifFalse:[^false].
	referent vResizing == #shrinkWrap ifFalse:[^false].
	^true! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'ar 12/19/2000 18:55'!
makeFlapCompact: aBool
	"Return true if the referent of the receiver represents a 'compact' flap"
	aBool ifTrue:[
		referent
			layoutPolicy: TableLayout new;
			vResizing: #shrinkWrap;
			useRoundedCorners.
	] ifFalse:[
		referent
			layoutPolicy: nil;
			vResizing: #rigid;
			useSquareCorners.
	].! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'sw 6/25/1999 22:07'!
scriptedPlayer
	^ scriptedPlayer! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'RAA 10/3/2000 11:34'!
showFlap
	super showFlap.
	Preferences oneViewerFlapAtATime ifTrue:
		[self pasteUpMorph hideViewerFlapsOtherThanFor: scriptedPlayer]! !

!ViewerFlapTab methodsFor: 'as yet unclassified' stamp: 'tk 1/31/2001 12:28'!
unhibernate
	| wasShowing viewer |
	"recreate my viewer"

	referent ifNotNil: [
		(referent findA: Viewer) ifNotNil: [^self].
	].
	wasShowing _ flapShowing.
	viewer _ self presenter viewMorph: scriptedPlayer costume.
	wasShowing ifFalse: [self hideFlap].
	^ viewer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ViewerFlapTab class
	instanceVariableNames: ''!

!ViewerFlapTab class methodsFor: 'as yet unclassified' stamp: 'sw 7/1/1999 11:39'!
defaultNameStemForInstances
	^ 'viewerFlapTab'! !

!ViewerFlapTab class methodsFor: 'as yet unclassified' stamp: 'kfr 5/3/2000 12:52'!
includeInNewMorphMenu
	"Not to be instantiated from the menu"
	^ false! !
AlignmentMorph subclass: #ViewerRow
	instanceVariableNames: 'elementSymbol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Scripting Tiles'!

!ViewerRow methodsFor: 'initialization' stamp: 'ar 11/9/2000 20:44'!
initialize
	super initialize.
	self layoutInset: 1! !


!ViewerRow methodsFor: 'access' stamp: 'sw 2/1/1999 13:00'!
elementSymbol
	^ elementSymbol! !

!ViewerRow methodsFor: 'access' stamp: 'sw 1/13/1999 12:47'!
elementSymbol: aSymbol
	elementSymbol _ aSymbol! !

!ViewerRow methodsFor: 'access' stamp: 'sw 1/13/1999 12:52'!
entryType
	"systemSlot userSlot systemScript userScript"
	^ self playerBearingCode elementTypeFor: elementSymbol! !

!ViewerRow methodsFor: 'access' stamp: 'sw 12/28/1998 13:10'!
playerBearingCode
	^ owner playerBearingCode! !


!ViewerRow methodsFor: 'user interface' stamp: 'sw 11/5/1998 09:16'!
detail
	owner detailButtonPressed! !

ObjectWithDocumentation subclass: #Vocabulary
	instanceVariableNames: 'vocabularyName categories methodInterfaces '
	classVariableNames: 'AllMethodInterfaces AllVocabularies '
	poolDictionaries: ''
	category: 'System-Protocols'!
!Vocabulary commentStamp: '<historical>' prior: 0!
Vocabulary

  vocabularyName	a Symbol -- the formal name by which this vocabulary is known.
  categories			a list of MethodCategory objects: the categories that comprise the vocabulary
  methodInterfaces 	an IdentityDictionary; keys are method selectors, values are MethodInterfaces

  AllMethodInterfaces		This class variable is available to hold on to all method interfaces
							defined in the system, regardless of class.  Not deployed in 
							the first version of this code to be circulated externally.!


!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 16:31'!
allCategoryName
	"Answer the name by which the 'all' category is known.  This is redundant with two other things, including ClassOrganizer allCategory, at the moment -- should be cleaned up someday."

	^ '-- all --' asSymbol! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 16:31'!
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
	"Answer a list of all methods in the etoy interface which are in the given category, on behalf of aClass and possibly anObject.  Note that there is no limitClass at play here."

	| aCategory |
	categoryName ifNil: [^ OrderedCollection new].
	categoryName = self allCategoryName ifTrue:
		[^ methodInterfaces collect: [:anInterface | anInterface selector]].

	aCategory _ categories detect: [:cat | cat categoryName == categoryName asSymbol] ifNone: [^ OrderedCollection new].
	^ aCategory elementsInOrder collect: [:anElement | anElement selector] thenSelect:
			[:aSelector | aClass canUnderstand: aSelector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/26/2001 16:22'!
allSelectorsInVocabulary
	"Answer a list of all selectors in the vocabulary"

	^ methodInterfaces collect: [:m | m selector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/6/2001 06:27'!
atKey: aKey putMethodInterface: anInterface
	"Place the given interface at the given key"

	methodInterfaces at: aKey put: anInterface! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/13/2000 20:02'!
categories
	"Answer a list of the categories in the receiver"

	^ categories! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:13'!
categoriesContaining: aSelector forClass: aClass
	"Answer a list of categories that include aSelector"

	^ self categories select:
		[:aCategory | aCategory includesKey: aSelector]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/11/2000 15:31'!
categoryAt: aSymbol
	"Answer the category which has the given symbol as its categoryName, else nil if none found"

	^ categories detect: [:aCategory | aCategory categoryName == aSymbol] ifNone: [nil]! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 16:31'!
categoryCommentFor: aCategoryName
	"Answer diocumentation for the given category name, a symbol"

	categories do:
		[:cat | cat categoryName == aCategoryName ifTrue: [^ cat documentation]].

	aCategoryName = self allCategoryName ifTrue:
		[^ 'Shows all methods, whatever other categories they may belong to'].
	#(
	(all					'Danger!! An old designation that usually does NOT include all of anything!!')
	('as yet unclassified'	'Methods not yet given a specific classification in some class in which they are implemented')
	(private				'Methods that should only be called by self'))

		do:
			[:pair | pair first = aCategoryName ifTrue: [^ pair second]].

	^ aCategoryName, ' is a category that currently has no documentation'
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/30/2001 12:40'!
categoryDefiningSelector: aSelector forClass: targetClass
	"Answer which category defines the selector for the given class.  Note reimplementor"

	^ self nameOfCategoryContaining: aSelector! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/26/2001 16:22'!
categoryListForInstance: targetObject ofClass: aClass limitClass: mostGenericClass
	"Answer the category list for the given instance (may be nil) of the given class, considering only code implemented in mostGenericClass and lower"

	| classToUse foundAMethod classThatImplements |
	classToUse _ targetObject ifNotNil: [targetObject class] ifNil: [aClass].

	^ categories
		select:
			[:aCategory |
				foundAMethod _ false.
				aCategory elementsInOrder do:
					[:aSpec |
						classThatImplements _  classToUse classThatUnderstands: aSpec selector.
						(classThatImplements notNil and: [classThatImplements includesBehavior: mostGenericClass])
							ifTrue:
								[foundAMethod _ true]].
				foundAMethod]
		thenCollect:
			[:aCategory | aCategory categoryName]
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 05:55'!
classToUseFromInstance: anInstance ofClass: aClass
	"A small convenience to assist in complications arising because an instance is sometimes provided and sometimes not"

	^ anInstance ifNotNil: [anInstance class] ifNil: [aClass]
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/12/2000 06:06'!
encompassesAPriori: aClass
	"Answer whether the receiver  a priori encompasses aClass -- see implementors"

	^ false! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 21:57'!
includesSelector: aSelector
	"Answer whether the given selector is known to the vocabulary"

	^ methodInterfaces includesKey: aSelector! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/14/2000 06:04'!
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
	"Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower"

	| classToUse aClass |

	(methodInterfaces includesKey: aSelector) ifFalse: [^ false].
	classToUse _ self classToUseFromInstance: anInstance ofClass: aTargetClass.
	^ (aClass _ classToUse whichClassIncludesSelector: aSelector)
		ifNil:
			[false]
		ifNotNil:
			[aClass includesBehavior: mostGenericClass]
! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 1/28/2001 01:20'!
nameOfCategoryContaining: aSelector
	"Answer a category that include aSelector, or nil if none"

	^ (self categories detect:
		[:aCategory | aCategory includesKey: aSelector] ifNone: [^ nil]) categoryName! !

!Vocabulary methodsFor: 'queries' stamp: 'sw 12/1/2000 22:05'!
vocabularyName
	"Answer the name of the vocabulary"

	^ vocabularyName! !


!Vocabulary methodsFor: 'initialization' stamp: 'sw 12/11/2000 15:31'!
addCategory: aCategory
	"Add the given category to my categories list"

	categories add: aCategory! !

!Vocabulary methodsFor: 'initialization' stamp: 'sw 1/26/2001 23:03'!
addCategoryNamed: aCategoryName
	"Add a category of the given name to my categories list,"

	categories add: (ElementCategory new categoryName: aCategoryName asSymbol)! !

!Vocabulary methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:17'!
initialize
	"Initialize the receiver (automatically called when instances are created via 'new')"

	super initialize.
	vocabularyName _ #unnamed.
	categories _ OrderedCollection new.
	methodInterfaces _ IdentityDictionary new.
	self documentation: 'A vocabulary that has not yet been documented'.
! !

!Vocabulary methodsFor: 'initialization' stamp: 'sw 12/1/2000 22:06'!
vocabularyName: aName
	"Set the name of the vocabulary as indicated"

	vocabularyName _ aName! !


!Vocabulary methodsFor: 'printing' stamp: 'sw 12/1/2000 22:05'!
printOn: aStream
	"Append to the argument, aStream, a sequence of characters that   identifies the receiver."

	super printOn: aStream.
	vocabularyName ifNotNil: [aStream nextPutAll: ' named "', vocabularyName, '"']! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Vocabulary class
	instanceVariableNames: ''!

!Vocabulary class methodsFor: 'class initialization' stamp: 'sw 1/27/2001 23:49'!
initialize
	"Initialize a few standard vocabularies and place them in the AllVocabularies list."

	self initializeStandardVocabularies.

	"Vocabulary initialize"

! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'sw 1/28/2001 02:37'!
initializeStandardVocabularies
	"Initialize a few standard vocabularies and place them in the AllVocabularies list."

	AllVocabularies _ OrderedCollection new.
	self addVocabulary: EToyVocabulary new.
	self addVocabulary: self newTestVocabulary.
	self addVocabulary: self newPublicVocabulary.
	self addVocabulary: FullVocabulary new.
	self addVocabulary: self newNumberVocabulary.

	"Vocabulary initialize"

! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'sw 12/14/2000 17:29'!
newPublicVocabulary
	| aVocabulary |
	"Answer a public vocabulary"

	aVocabulary _ ScreenedVocabulary new.
	aVocabulary vocabularyName: #Public.
	aVocabulary documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'.

	aVocabulary categoryScreeningBlock: [:aCategoryName | (aCategoryName beginsWith: 'private') not].
	aVocabulary methodScreeningBlock: [:aSelector | 
		((aSelector beginsWith: 'private') or: [aSelector beginsWith: 'pvt']) not].
	^ aVocabulary
! !

!Vocabulary class methodsFor: 'class initialization' stamp: 'sw 1/28/2001 23:42'!
newTestVocabulary
	"Answer a Test vocabulary -- something to mess with, to illustrate and explore ideas."

	| aVocabulary  aMethodInterface aMethodCategory |
	aVocabulary _ Vocabulary new.

	aVocabulary vocabularyName: #Test.
	aVocabulary documentation: 'An illustrative vocabulary for testing'.

	#((#'class membership' 	'Whether an object can respond to a given message, etc.' 	(isKindOf: class respondsTo:))
	(conversion 			'Messages to convert from one kind of object to another' 		(as:  asString))
	(copying				'Messages for making copies of objects'						(copy copyFrom:))
	(equality 				'Testing whether two objects are equal' 						( = ~= == ~~))
	(dependents				'Support for dependency notification'						(addDependent: removeDependent: release))) do:

		[:item | 
			aMethodCategory _ ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface _ MethodInterface new initializeFor: aSelector.
					aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			aVocabulary addCategory: aMethodCategory].

	^ aVocabulary
! !


!Vocabulary class methodsFor: 'access' stamp: 'sw 1/28/2001 00:28'!
addVocabulary: aVocabulary
	"Add a vocabulary to the list of standard vocabularies"

	self allVocabularies.  "Assures initialization"
	AllVocabularies add: aVocabulary! !

!Vocabulary class methodsFor: 'access' stamp: 'sw 1/27/2001 23:51'!
allVocabularies
	"Answer a list of the currently-defined vocabularies in my AllVocabularies list"

	^ (AllVocabularies ifNil: [AllVocabularies _ self initializeStandardVocabularies]) copy! !


!Vocabulary class methodsFor: 'standard vocabularies' stamp: 'sw 1/26/2001 19:50'!
eToyVocabulary
	"Anser the etoy vocabulary, if one exists in the AllVocabularies list"

	^ self allVocabularies detect: [:aVocabulary | aVocabulary vocabularyName == #eToy] ifNone: [nil]! !

!Vocabulary class methodsFor: 'standard vocabularies' stamp: 'sw 1/26/2001 19:50'!
fullVocabulary
	"Answer the full vocabulary in my AllVocabularies list, creating it if necessary"

	| it |
	^ self allVocabularies detect: [:aVocabulary | aVocabulary isMemberOf: FullVocabulary]
		ifNone: [AllVocabularies add: (it _ FullVocabulary new).  it]! !

!Vocabulary class methodsFor: 'standard vocabularies' stamp: 'sw 1/26/2001 19:50'!
publicVocabulary
	"Answer the public vocabulary, which admits through all non-private categories & selectors"

	^ self allVocabularies detect: [:aVocabulary | aVocabulary vocabularyName = #Public] ifNone: [self newPublicVocabulary]

	"Vocabulary publicVocabulary"! !

!Vocabulary class methodsFor: 'standard vocabularies' stamp: 'sw 1/28/2001 02:36'!
testVocabulary
	"Answer the Test vocabulary lurking in my AllVocabularies list"

	^ self allVocabularies detect: [:aVocabulary | aVocabulary vocabularyName == #Test] ifNone: [nil]! !


!Vocabulary class methodsFor: 'method interfaces' stamp: 'sw 1/26/2001 23:23'!
methodInterfaceFor: aSelector
	"Answer the methodInterface object for the given selector, or nil if none in the repository"

	^ AllMethodInterfaces at: aSelector ifAbsent: [nil]! !

!Vocabulary class methodsFor: 'method interfaces' stamp: 'sw 1/26/2001 23:24'!
storeInterface: aMethodInterface forSelector: aSelector
	"Store the given method interface at the given selector"

	AllMethodInterfaces at: aSelector put: aMethodInterface! !


!Vocabulary class methodsFor: 'type vocabularies' stamp: 'sw 1/28/2001 02:37'!
newNumberVocabulary
	"Answer a Vocabulary object representing the Number vocabulary to the list of AllVocabularies" 

	| aVocabulary aMethodCategory aMethodInterface |
	"Vocabulary newNumberVocabulary"

	aVocabulary _ self new vocabularyName: #Number.
		aVocabulary documentation: 'Numbers are things that can do arithmetic, have their magnitudes compared, etc.'.


#((arithmetic 				'Basic numeric operation'
		(* + - / // \\ abs negated quo: reciprocal rem:))
(#'mathematical functions'	'Trigonometric and exponential functions'
		(arcCos arcSin arcTan arcTan: cos exp floorLog: interpolateTo:at: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan))
('comparing'				'Determining which of two numbers is larger'
		(= < > <= >= ~= ~~))
('converting' 				'Converting a number to another form'
		(@ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees))) do:

		[:item | 
			aMethodCategory _ ElementCategory new categoryName: item first.
			aMethodCategory documentation: item second.
			item third do:
				[:aSelector | 
					aMethodInterface _ MethodInterface new initializeFor: aSelector.
					aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
					aMethodCategory elementAt: aSelector put: aMethodInterface].
			aVocabulary addCategory: aMethodCategory].

	^ aVocabulary

"
(('truncation and round off' ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated)
('testing' basicType even isDivisibleBy: isInf isInfinite isNaN isNumber isZero negative odd positive sign strictlyPositive)
('converting' @ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees)
('intervals' to: to:by: to:by:do: to:do:)
('printing' defaultLabelForInspector isOrAreStringWith: newTileMorphRepresentative printOn: printStringBase: storeOn: storeOn:base: storeStringBase: stringForReadout)
('comparing' closeTo:)
('filter streaming' byteEncode:)
('as yet unclassified' reduce)"



! !

!Vocabulary class methodsFor: 'type vocabularies' stamp: 'sw 1/28/2001 18:00'!
numberVocabulary
	"Answer the standard vocabulary representing numbers"

	^ self allVocabularies detect: [:aVocabulary | aVocabulary vocabularyName == #number] ifNone: [nil]! !
Object subclass: #Voice
	instanceVariableNames: 'name sound '
	classVariableNames: 'Voices '
	poolDictionaries: ''
	category: 'Speech-Events'!
!Voice commentStamp: '<historical>' prior: 0!
I am an abstract class for speaking voices that know how to play VoiceEvents.!


!Voice methodsFor: 'initialization' stamp: 'len 9/26/1999 17:20'!
initialize
	name _ 'anonymous'! !


!Voice methodsFor: 'accessing' stamp: 'len 6/21/1998 20:07'!
name
	^ name! !

!Voice methodsFor: 'accessing' stamp: 'len 6/21/1998 20:07'!
name: aString
	name _ aString! !

!Voice methodsFor: 'accessing' stamp: 'len 9/15/1999 23:54'!
sound
	^ sound! !


!Voice methodsFor: 'converting' stamp: 'len 9/7/1999 01:26'!
+ aVoice
	"Answer the composition of the receiver with the argument."
	^ CompositeVoice new add: self; add: aVoice; yourself! !


!Voice methodsFor: 'playing' stamp: 'len 12/22/1999 03:51'!
flush
	"Play all the events in the queue."
	sound notNil ifTrue: [sound done: true; play. sound _ nil]! !

!Voice methodsFor: 'playing' stamp: 'len 12/22/1999 03:29'!
playBuffer: buffer at: time
	| tail |
	tail _ SampledSound samples: buffer samplingRate: self samplingRate.
	sound isNil
		ifTrue: [sound _ QueueSound new startTime: time - SoundPlayer bufferMSecs.
				sound add: tail; play]
		ifFalse: [sound add: tail]! !

!Voice methodsFor: 'playing' stamp: 'len 8/28/1999 23:04'!
playGesturalEvent: event at: time
	^ self! !

!Voice methodsFor: 'playing' stamp: 'len 8/28/1999 23:05'!
playPhoneticEvent: event at: time
	^ self! !

!Voice methodsFor: 'playing' stamp: 'len 9/14/1999 00:19'!
playSilenceMSecs: msecs
	Transcript cr; show: 'silence ', msecs printString, 'msecs'.
	sound isNil ifTrue: [^ self].
	sound add: (RestSound dur: msecs / 1000.0)! !

!Voice methodsFor: 'playing' stamp: 'len 12/22/1999 03:51'!
reset
	"Reset the state of the receiver."
	sound notNil ifTrue: [sound done: true. sound _ nil]! !


!Voice methodsFor: 'printing' stamp: 'len 8/28/1999 03:04'!
printOn: aStream
	aStream nextPutAll: self class name; nextPutAll: ' ('; nextPutAll: self name; nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Voice class
	instanceVariableNames: ''!

!Voice class methodsFor: 'instance creation' stamp: 'len 9/13/1999 00:58'!
default
	self voices isEmpty ifTrue: [^ KlattVoice new].
	^ self voices detect: [ :one | one name = 'Kurt']
		ifNone: [self voices detect: [ :one | one samplingRate >= 16000]
					ifNone: [self voices anyOne]]! !

!Voice class methodsFor: 'instance creation' stamp: 'len 6/21/1998 19:52'!
new
	^ super new initialize! !


!Voice class methodsFor: 'class initialization' stamp: 'len 6/7/1999 01:33'!
initialize
	"
	Voice initialize
	"

	Voices _ Set new! !


!Voice class methodsFor: 'accessing' stamp: 'len 6/7/1999 01:33'!
addVoice: aVoice
	^ self voices add: aVoice! !

!Voice class methodsFor: 'accessing' stamp: 'len 6/21/1999 00:51'!
doesNotUnderstand: aMessage
	self voices do: [ :each | each name asLowercase = aMessage selector asString ifTrue: [^ each]].
	^ super doesNotUnderstand: aMessage! !

!Voice class methodsFor: 'accessing' stamp: 'len 9/14/1999 00:16'!
named: aString
	^ self voices detect: [ :one | one name = aString]! !

!Voice class methodsFor: 'accessing' stamp: 'len 6/7/1999 01:33'!
voices
	^ Voices! !
Object subclass: #VoiceEvent
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-Events'!
!VoiceEvent commentStamp: '<historical>' prior: 0!
I am an abstract class for all events to be played on speaking Voices, such as PhoneticEvents or GesturalEvents.!


!VoiceEvent methodsFor: 'accessing' stamp: 'len 8/28/1999 03:06'!
duration
	"Answer the duration (in seconds) of the receiver."
	^ 0! !

!VoiceEvent methodsFor: 'accessing' stamp: 'len 8/29/1999 02:18'!
voice
	"Answer the default voice for the receiver."
	^ Voice default! !


!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
play
	^ self playOn: self voice! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
playAt: time
	^ self playOn: self voice at: time! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 12/24/1999 02:23'!
playDelayed: delay
	self playAt: Time millisecondClockValue + delay! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 23:11'!
playOn: aVoice
	self playOn: aVoice at: Time millisecondClockValue! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 8/28/1999 03:54'!
playOn: aVoice at: time
	self subclassResponsibility! !

!VoiceEvent methodsFor: 'playing' stamp: 'len 9/13/1999 00:46'!
playOn: aVoice delayed: delay
	self playOn: aVoice at: Time millisecondClockValue + delay! !


!VoiceEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isGestural
	^ false! !

!VoiceEvent methodsFor: 'testing' stamp: 'len 8/29/1999 21:17'!
isPhonetic
	^ false! !


!VoiceEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
compress: aNumber
	self stretch: 1.0 / aNumber! !

!VoiceEvent methodsFor: 'transforming' stamp: 'len 8/29/1999 03:13'!
stretch: aNumber
	^ self! !
Envelope subclass: #VolumeEnvelope
	instanceVariableNames: 'currentVol targetVol mSecsForChange '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 8/17/1998 17:29'!
computeSlopeAtMSecs: mSecs
	"Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached."

	| t i |
	((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [  "decay phase"
		t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
		i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
		i == nil ifTrue: [  "past end"
			targetVol _ points last y * decayScale.
			mSecsForChange _ 0.
			nextRecomputeTime _ mSecs + 1000000.
			^ self].
		targetVol _ (points at: i) y * decayScale.
		mSecsForChange _ (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4.
		nextRecomputeTime _ mSecs + mSecsForChange.
		^ self].

	mSecs < loopStartMSecs ifTrue: [  "attack phase"
		i _ self indexOfPointAfterMSecs: mSecs startingAt: 1.
		targetVol _ (points at: i) y.
		mSecsForChange _ ((points at: i) x - mSecs) max: 4.
		nextRecomputeTime _ mSecs + mSecsForChange.
		((loopEndMSecs ~~ nil) and: [nextRecomputeTime > loopEndMSecs])
			ifTrue: [nextRecomputeTime _ loopEndMSecs].
		^ self].

	"sustain and loop phase"
	noChangesDuringLoop ifTrue: [
		targetVol _ (points at: loopEndIndex) y.
		mSecsForChange _ 10.
		loopEndMSecs == nil
			ifTrue: [nextRecomputeTime _ mSecs + 10]  "unknown end time"
			ifFalse: [nextRecomputeTime _ loopEndMSecs].
		^ self].

	loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y].  "looping on a single point"
	t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
	i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
	targetVol _ (points at: i) y.
	mSecsForChange _ ((points at: i) x - t) max: 4.
	nextRecomputeTime _ (mSecs + mSecsForChange) min: loopEndMSecs.
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 18:51'!
reset
	"Reset the state for this envelope."

	super reset.
	target initialVolume: points first y * scale.
	nextRecomputeTime _ 0.
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 2/4/98 07:27'!
updateSelector
	"Needed by the envelope editor."

	^ #volume:
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 07:04'!
updateTargetAt: mSecs
	"Update the volume envelope slope and limit for my target. Answer false."

	mSecs < nextRecomputeTime ifTrue: [^ false].
	self computeSlopeAtMSecs: mSecs.
	mSecsForChange < 5 ifTrue: [mSecsForChange _ 5].  "don't change instantly to avoid clicks"
	target adjustVolumeTo: targetVol * scale overMSecs: mSecsForChange.
	^ false
! !

!VolumeEnvelope methodsFor: 'as yet unclassified' stamp: 'jm 8/17/1998 08:00'!
volume: aNumber
	"Set the maximum volume of a volume-controlling envelope."

	scale _ aNumber asFloat.
! !
Notification subclass: #Warning
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!Warning commentStamp: '<historical>' prior: 0!
A Warning is a Notification which by default should be brought to the attention of the user.!


!Warning methodsFor: 'exceptionDescription' stamp: 'tfei 6/7/1999 13:31'!
defaultAction
	"The user should be notified of the occurrence of an exceptional occurrence and given an option of continuing or aborting the computation. The description of the occurrence should include any text specified as the argument of the #signal: message."

	| continue |
	continue := self confirm: 'Warning: ', self messageText, ' Continue?'.
	continue ifTrue: [self resume]! !


!Warning methodsFor: 'private-exceptionSignaler' stamp: 'tfei 1/10/2000 18:23'!
signal
	"Signal the occurrence of an exceptional condition."
	"Warning is overriding this and marking it private in order to get around an apparent contradiction within the ANSI specification:
		Warning>>defaultAction must give the user the option to 'abort the computation'.
		Warning is resumable.
		Exception>>signal must return to its caller if it reaches a defaultAction in the case of a resumable exception.
		Therefore, Warning needs to invoke a handler action from its defaultAction; that handler action would seem to be return:, but according to the spec, 'It is erroneous to directly or indirectly send this message from within a #defaultAction method  to the receiver of the #defaultAction method.'

We have chosen to support the apparently intended behavior of Warning, at the expense of introducing a mildly unpleasant hack - in case of an unhandled Warning, we determine whether the user has elected to continue or not.  In the latter case, this process needs to terminate immediately, without returning to the sender of #signal.  To accomplish this, we nil out the sender on the call stack, and then use MethodContext>>cannotReturn: to open a notifier and allow the environment to continue in use."

	| result |
	initialContext == nil ifTrue: [initialContext := thisContext sender].
	resignalException := nil.
	(self setHandlerFrom: initialContext) == nil
		ifTrue:
			[self defaultAction.
			"if user elected to continue the computation, execution did not reach this line"
			initialContext unwindTo: nil.
			thisContext terminateTo: nil]
		ifFalse:
			[result := self handlerAction.
			^resignalException == nil
				ifTrue: [result]
				ifFalse: [resignalException signal]]! !
BitBlt subclass: #WarpBlt
	instanceVariableNames: 'p1x p1y p1z p2x p2y p2z p3x p3y p3z p4x p4y p4z cellSize sourceRGBmap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Primitives'!
!WarpBlt commentStamp: '<historical>' prior: 0!
WarpBlt is a little warp-drive added on to BitBlt.  It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits.

The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle.  Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg.  See the method Rectangle asQuad.

WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective.  Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.!


!WarpBlt methodsFor: 'setup'!
cellSize
	^ cellSize! !

!WarpBlt methodsFor: 'setup' stamp: 'jm 4/11/1999 12:00'!
cellSize: s
	cellSize _ s.
	cellSize = 1 ifTrue: [^ self].
	colorMap _ Color colorMapIfNeededFrom: 32 to: destForm depth.
! !


!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:09'!
mixPix: pix sourceMap: sourceMap destMap: destMap
	"Average the pixels in array pix to produce a destination pixel.
	First average the RGB values either from the pixels directly,
	or as supplied in the sourceMap.  Then return either the resulting
	RGB value directly, or use it to index the destination color map." 
	| r g b rgb nPix bitsPerColor d |
	nPix _ pix size.
	r _ 0. g _ 0. b _ 0.
	1 to: nPix do:
		[:i |   "Sum R, G, B values for each pixel"
		rgb _ sourceForm depth <= 8
				ifTrue: [sourceMap at: (pix at: i) + 1]
				ifFalse: [sourceForm depth = 32
						ifTrue: [pix at: i]
						ifFalse: [self rgbMap: (pix at: i) from: 5 to: 8]].
		r _ r + ((rgb bitShift: -16) bitAnd: 16rFF).
		g _ g + ((rgb bitShift: -8) bitAnd: 16rFF).
		b _ b + ((rgb bitShift: 0) bitAnd: 16rFF)].
	destMap == nil
		ifTrue: [bitsPerColor _ 3.  "just in case eg depth <= 8 and no map"
				destForm depth = 16 ifTrue: [bitsPerColor _ 5].
				destForm depth = 32 ifTrue: [bitsPerColor _ 8]]
		ifFalse: [destMap size = 512 ifTrue: [bitsPerColor _ 3].
				destMap size = 4096 ifTrue: [bitsPerColor _ 4].
				destMap size = 32768 ifTrue: [bitsPerColor _ 5]].
	d _ bitsPerColor - 8.
	rgb _ ((r // nPix bitShift: d) bitShift: bitsPerColor*2)
		+ ((g // nPix bitShift: d) bitShift: bitsPerColor)
		+ ((b // nPix bitShift: d) bitShift: 0).
	destMap == nil
		ifTrue: [^ rgb]
		ifFalse: [^ destMap at: rgb+1]! !

!WarpBlt methodsFor: 'smoothing' stamp: 'di 6/24/97 00:08'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
	"NOTE: This code is copied verbatim from BitBltSimulation so that it
	may be removed from the system"
	"Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
	| mask d srcPix destPix |
	self inline: true.
	(d _ nBitsOut - nBitsIn) > 0
		ifTrue:
			["Expand to more bits by zero-fill"
			mask _ (1 << nBitsIn) - 1.  "Transfer mask"
			srcPix _ sourcePixel << d.
			mask _ mask << d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix << d.
			^ destPix + (srcPix bitAnd: mask)
				 	+ (srcPix << d bitAnd: mask << nBitsOut)]
		ifFalse:
			["Compress to fewer bits by truncation"
			d = 0 ifTrue: [^ sourcePixel].  "no compression"
			sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
			d _ nBitsIn - nBitsOut.
			mask _ (1 << nBitsOut) - 1.  "Transfer mask"
			srcPix _ sourcePixel >> d.
			destPix _ srcPix bitAnd: mask.
			mask _ mask << nBitsOut.
			srcPix _ srcPix >> d.
			destPix _ destPix + (srcPix bitAnd: mask)
					+ (srcPix >> d bitAnd: mask << nBitsOut).
			destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
			^ destPix]! !


!WarpBlt methodsFor: 'primitives'!
copyQuad: pts toRect: destRect
	self sourceQuad: pts destRect: destRect.
	self warpBits! !

!WarpBlt methodsFor: 'primitives'!
deltaFrom: x1 to: x2 nSteps: n
	"Utility routine for computing Warp increments.
	x1 is starting pixel, x2 is ending pixel;  assumes n >= 1"
	| fixedPtOne |
	fixedPtOne _ 16384.  "1.0 in fixed-pt representation"
	x2 > x1
		ifTrue: [^ x2 - x1 + fixedPtOne // (n+1) + 1]
		ifFalse: [x2 = x1 ifTrue: [^ 0].
				^ 0 - (x1 - x2 + fixedPtOne // (n+1) + 1)]! !

!WarpBlt methodsFor: 'primitives' stamp: 'jm 5/2/1999 07:09'!
sourceForm: srcForm destRect: dstRectangle
	"Set up a WarpBlt from the entire source Form to the given destination rectangle."

	| w h |
	sourceForm _ srcForm.
	sourceX _ sourceY _ 0.
	destX _ dstRectangle left.
	destY _ dstRectangle top.
	width _ dstRectangle width.
	height _ dstRectangle height.
	w _ 16384 * (srcForm width - 1).
	h _ 16384 * (srcForm height - 1).
	p1x _ 0.
	p2x _ 0.
	p3x _ w.
	p4x _ w.
	p1y _ 0.
	p2y _ h.
	p3y _ h.
	p4y _ 0.
	p1z _ p2z _ p3z _ p4z _ 16384.  "z-warp ignored for now"
! !

!WarpBlt methodsFor: 'primitives'!
sourceQuad: pts destRect: aRectangle
	| fixedPt1 |
	sourceX _ sourceY _ 0.
	self destRect: aRectangle.
	fixedPt1 _ (pts at: 1) x isInteger ifTrue: [16384] ifFalse: [16384.0].
	p1x _ (pts at: 1) x * fixedPt1.
	p2x _ (pts at: 2) x * fixedPt1.
	p3x _ (pts at: 3) x * fixedPt1.
	p4x _ (pts at: 4) x * fixedPt1.
	p1y _ (pts at: 1) y * fixedPt1.
	p2y _ (pts at: 2) y * fixedPt1.
	p3y _ (pts at: 3) y * fixedPt1.
	p4y _ (pts at: 4) y * fixedPt1.
	p1z _ p2z _ p3z _ p4z _ 16384.  "z-warp ignored for now"
! !

!WarpBlt methodsFor: 'primitives'!
startFrom: x1 to: x2 offset: sumOfDeltas
	"Utility routine for computing Warp increments."
	x2 >= x1
		ifTrue: [^ x1]
		ifFalse: [^ x2 - sumOfDeltas]! !

!WarpBlt methodsFor: 'primitives' stamp: 'jm 4/11/1999 13:45'!
warpBits
	"Move those pixels!!"

	self warpBitsSmoothing: cellSize
		sourceMap: (sourceForm colormapIfNeededForDepth: 32).
! !

!WarpBlt methodsFor: 'primitives' stamp: 'ar 2/2/2001 15:09'!
warpBitsSmoothing: n sourceMap: sourceMap
	| deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps |
	<primitive: 'primitiveWarpBits' module: 'BitBltPlugin'>

	"Check for compressed source, destination or halftone forms"
	((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((destForm isKindOf: Form) and: [destForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].
	((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
		ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap].

	(width < 1) | (height < 1) ifTrue: [^ self].
	fixedPtOne _ 16384.  "1.0 in fixed-pt representation"
	n > 1 ifTrue:
		[(destForm depth < 16 and: [colorMap == nil])
			ifTrue: ["color map is required to smooth non-RGB dest"
					^ self primitiveFail].
		pix _ Array new: n*n].

	nSteps _ height-1 max: 1.
	deltaP12 _ (self deltaFrom: p1x to: p2x nSteps: nSteps)
			@ (self deltaFrom: p1y to: p2y nSteps: nSteps).
	pA _ (self startFrom: p1x to: p2x offset: nSteps*deltaP12 x)
		@ (self startFrom: p1y to: p2y offset: nSteps*deltaP12 y).
	deltaP43 _ (self deltaFrom: p4x to: p3x nSteps: nSteps)
			@ (self deltaFrom: p4y to: p3y nSteps: nSteps).
	pB _ (self startFrom: p4x to: p3x offset: nSteps*deltaP43 x)
		@ (self startFrom: p4y to: p3y offset: nSteps*deltaP43 y).

	picker _ BitBlt current bitPeekerFromForm: sourceForm.
	poker _ BitBlt current bitPokerToForm: destForm.
	poker clipRect: self clipRect.
	nSteps _ width-1 max: 1.
	destY to: destY+height-1 do:
		[:y |
		deltaPAB _ (self deltaFrom: pA x to: pB x nSteps: nSteps)
				@ (self deltaFrom: pA y to: pB y nSteps: nSteps).
		sp _ (self startFrom: pA x to: pB x offset: nSteps*deltaPAB x)
			@ (self startFrom: pA y to: pB y offset: nSteps*deltaPAB x).
		destX to: destX+width-1 do:
			[:x | 
			n = 1
			ifTrue:
				[poker pixelAt: x@y
						put: (picker pixelAt: sp // fixedPtOne asPoint)]
			ifFalse:
				[0 to: n-1 do:
					[:dx | 0 to: n-1 do:
						[:dy |
						pix at: dx*n+dy+1 put:
								(picker pixelAt: sp
									+ (deltaPAB*dx//n)
									+ (deltaP12*dy//n)
										// fixedPtOne asPoint)]].
				poker pixelAt: x@y put: (self mixPix: pix
										sourceMap: sourceMap
										destMap: colorMap)].
			sp _ sp + deltaPAB].
		pA _ pA + deltaP12.
		pB _ pB + deltaP43]! !


!WarpBlt methodsFor: 'system simulation' stamp: 'ar 10/27/1999 23:48'!
warpBitsSimulated
	"Simulate WarpBlt"
	self warpBitsSimulated: cellSize
		sourceMap: (sourceForm colormapIfNeededForDepth: 32).
! !

!WarpBlt methodsFor: 'system simulation' stamp: 'ar 10/27/1999 23:47'!
warpBitsSimulated: n sourceMap: sourceMap
	"Simulate WarpBlt"
	BitBltSimulation warpBitsFrom: self.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WarpBlt class
	instanceVariableNames: ''!

!WarpBlt class methodsFor: 'initialization'!
toForm: destinationForm
	"Default cell size is 1 (no pixel smoothing)"
	^ (super toForm: destinationForm) cellSize: 1! !


!WarpBlt class methodsFor: 'examples'!
test1   "Display restoreAfter: [WarpBlt test1]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p ext |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext)]! !

!WarpBlt class methodsFor: 'examples' stamp: 'sma 4/22/2000 20:23'!
test12   "Display restoreAfter: [WarpBlt test12]"
	"Just like test1, but comparing smooth to non-smooth warps"
	| warp pts r1 p0 p ext warp2 |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle originFromUser: 50@50.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 2;  "installs a colormap"
		clipRect: (0@0 extent: r1 extent*5);
		sourceForm: Display;
		combinationRule: Form over.
	warp2 _ (self toForm: Display)
		clipRect: ((0@0 extent: r1 extent*5) translateBy: 250@0);
		sourceForm: Display;
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) asIntegerPoint.
		warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext).
		warp2 copyQuad: pts toRect: ((r1 extent*5-ext//2 extent: ext) translateBy: 250@0).
		]! !

!WarpBlt class methodsFor: 'examples'!
test3   "Display restoreAfter: [WarpBlt test3]"

	"The Squeak Release Mandala - 9/23/96 di"

	"Move the mouse near the center of the square.
	Up and down affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box map d t |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	"Make a color map that steps through the color space"
	map _ (Display depth > 8
		ifTrue: ["RGB is a bit messy..."
				d _ Display depth = 16 ifTrue: [5] ifFalse: [8].
				(1 to: 512) collect: [:i | t _ i bitAnd: 511.
					((t bitAnd: 16r7) bitShift: d-3)
					+ ((t bitAnd: 16r38) bitShift: d-3*2)
					+ ((t bitAnd: 16r1C0) bitShift: d-3*3)]]
		ifFalse: ["otherwise simple"
				1 to: (1 bitShift: Display depth)])
			as: Bitmap.
	warp _ (WarpBlt toForm: Display)
		clipRect: box;
		sourceForm: Display;
		colorMap: map;
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!WarpBlt class methodsFor: 'examples'!
test4   "Display restoreAfter: [WarpBlt test4]"

	"The Squeak Release Mandala - 9/23/96 di
	This version does smoothing"

	"Move the mouse near the center ofhe square.
	Up and dn affects shrink/grow
	Left and right affect rotation angle"
	| warp pts p0 p box |
	box _ 100@100 extent: 300@300.
	Display border: (box expandBy: 2) width: 2.

	warp _ (WarpBlt toForm: Display)
		clipRect: box;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	p0 _ box center.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ (box insetBy: p y - p0 y) innerCorners
			collect: [:pt | pt rotateBy: p x - p0 x / 50.0 about: p0].
		warp copyQuad: pts toRect: box]! !

!WarpBlt class methodsFor: 'examples'!
test5   "Display restoreAfter: [WarpBlt test5]"
	"Demonstrates variable scale and rotate"
	| warp pts r1 p0 p |
	Utilities informUser: 'Choose a rectangle with interesting stuff'
		during: [r1 _ Rectangle fromUser.
				Sensor waitNoButton].
	Utilities informUser: 'Now click down and up
and move the mouse around the dot'
		during: [p0 _ Sensor waitClickButton.
				(Form dotOfSize: 8) displayAt: p0].
	warp _ (self toForm: Display)
		cellSize: 1;
		sourceForm: Display;
		cellSize: 2;  "installs a colormap"
		combinationRule: Form over.
	[Sensor anyButtonPressed] whileFalse:
		[p _ Sensor cursorPoint.
		pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight}
			collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center].
		warp copyQuad: pts toRect: (r1 translateBy: r1 width@0)]! !


!WarpBlt class methodsFor: 'form rotation' stamp: 'jm 11/16/97 10:50'!
rotate: srcForm degrees: angleInDegrees center: aPoint scaleBy: scalePoint smoothing: cellSize
	"Rotate the given Form the given number of degrees about the given center and scale its width and height by x and y of the given scale point. Smooth using the given cell size, an integer between 1 and 3, where 1 means no smoothing. Return a pair where the first element is the rotated Form and the second is the position offset required to align the center of the rotated Form with that of the original. Note that the dimensions of the resulting Form generally differ from those of the original."

	| srcRect center radians dstOrigin dstCorner p dstRect inverseScale quad dstForm newCenter warpSrc |
	srcRect _ srcForm boundingBox.
	center _ srcRect center.
	radians _ angleInDegrees degreesToRadians.
	dstOrigin _ dstCorner _ center.
	srcRect corners do: [:corner |
		"find the limits of a rectangle that just encloses the rotated
		 original; in general, this rectangle will be larger than the
		 original (e.g., consider a square rotated by 45 degrees)"
		p _ ((corner - center) scaleBy: scalePoint) + center.
		p _ (p rotateBy: radians about: center) rounded.
		dstOrigin _ dstOrigin min: p.
		dstCorner _ dstCorner max: p].

	"rotate the enclosing rectangle back to get the source quadrilateral"
	dstRect _ dstOrigin corner: dstCorner.
	inverseScale _ (1.0 / scalePoint x)@(1.0 / scalePoint y).
	quad _ dstRect innerCorners collect: [:corner |
		p _ corner rotateBy: radians negated about: center.
		((p - center) scaleBy: inverseScale) + center].

	"make a Form to hold the result and do the rotation"
	warpSrc _ srcForm.
	(srcForm isKindOf: ColorForm)
		ifTrue: [
			cellSize > 1
				ifTrue: [
					warpSrc _ Form extent: srcForm extent depth: 16.
					srcForm displayOn: warpSrc.
					dstForm _ Form extent: dstRect extent depth: 16]  "use 16-bit depth to allow smoothing"
				ifFalse: [
					dstForm _ srcForm class extent: dstRect extent depth: srcForm depth]]
		ifFalse: [
			dstForm _ srcForm class extent: dstRect extent depth: srcForm depth].

	(WarpBlt toForm: dstForm)
		sourceForm: warpSrc;
		colorMap: (dstForm colormapIfNeededForDepth: warpSrc depth);
		cellSize: cellSize;  "installs a new colormap if cellSize > 1"
		combinationRule: Form paint;
		copyQuad: quad toRect: dstForm boundingBox.

	(dstForm isKindOf: ColorForm) ifTrue: [dstForm colors: srcForm colors copy].
	newCenter _ (center rotateBy: radians about: aPoint) truncated.
	^ Array with: dstForm with: dstRect origin + (newCenter - center)
! !


!WarpBlt class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:00'!
current
	"Return the class currently to be used for WarpBlt"
	^Display defaultWarpBltClass! !
EllipseMorph subclass: #WatchMorph
	instanceVariableNames: 'fontName cColor handsColor romanNumerals antialias '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!WatchMorph commentStamp: '<historical>' prior: 0!
This class is a representation of a watch.
The labels' font is changeble. Labels' font size increase or decrease when resizing me.

WatchMorph new openInWorld
(WatchMorph fontName: 'ComicPlain') openInWorld		" transparent "
(WatchMorph fontName: 'ComicBold' bgColor: Color white centerColor: Color black) openInWorld

Structure:
	fontName		String -- the labels' font name
	cColor			Color -- center color
	handsColor		Color
	romanNumerals	Boolean
	antialias		Boolean!


!WatchMorph methodsFor: 'initialization' stamp: 'di 5/16/2000 21:18'!
extent: newExtent

	super extent: newExtent.
	self createLabels! !

!WatchMorph methodsFor: 'initialization' stamp: 'bf 5/17/2000 18:47'!
initialize  "Establish all default parameters..."
	super initialize.
	self color: Color green.
	self handsColor: Color red.
	self centerColor: Color gray.
	romanNumerals _ false.
	antialias _ false.
	fontName _ 'NewYork'.
	self extent: 130@130.
	self start.! !


!WatchMorph methodsFor: 'accessing' stamp: 'bf 5/18/2000 11:06'!
antialias: aBoolean
	antialias _ aBoolean! !

!WatchMorph methodsFor: 'accessing' stamp: 'rlf 3/17/2000 02:13'!
centerColor: aColor

	cColor _ aColor! !

!WatchMorph methodsFor: 'accessing' stamp: 'di 5/16/2000 21:45'!
fontName: aString

	fontName _ aString.
	self createLabels! !

!WatchMorph methodsFor: 'accessing' stamp: 'rjf 5/11/2000 00:03'!
handsColor: aColor

	handsColor _ aColor! !


!WatchMorph methodsFor: 'labels' stamp: 'ak 5/19/2000 21:47'!
createLabels
	| numeral font h r |
	self removeAllMorphs.
	font _ StrikeFont familyName: fontName size: (h _ self height min: self width)//8.
	r _ 1.0 - (1.4 * font height / h).
	1 to: 12 do:
		[:hour |
		numeral _ romanNumerals
			ifTrue: [hour romanString]
			ifFalse: [hour asString].
		self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1)
			center: (self radius: r hourAngle: hour)) lock]! !


!WatchMorph methodsFor: 'drawing' stamp: 'di 8/11/2000 17:16'!
drawOn: aCanvas
	| pHour pMin pSec time |
	time _ Time now.
	pHour _ self radius: 0.6 hourAngle: time hours + (time minutes/60.0).
	pMin _ self radius: 0.72 hourAngle: (time minutes / 5.0).
	pSec _ self radius: 0.8 hourAngle: (time seconds / 5.0).
	time hours < 12
		ifTrue: [self centerColor: Color veryLightGray]
		ifFalse: [self centerColor: Color darkGray].

	antialias ifTrue: [
		aCanvas asBalloonCanvas
			aaLevel: 4;
			drawOval: (bounds insetBy: borderWidth // 2 + 1) color: self fillStyle
				borderWidth: borderWidth borderColor: borderColor;
			drawOval: (bounds insetBy: self extent*0.35) color: cColor
				borderWidth: 0 borderColor: Color black;
			drawPolygon: {self center. pHour}
				color: Color transparent borderWidth: 3 borderColor: handsColor;
			drawPolygon: {self center. pMin}
				color: Color transparent borderWidth: 2 borderColor: handsColor;
			drawPolygon: {self center. pSec}
				color: Color transparent borderWidth: 1 borderColor: handsColor]
		ifFalse: [
			super drawOn: aCanvas.
			aCanvas
				fillOval: (bounds insetBy: self extent*0.35) color: cColor;
				line: self center to: pHour width: 3 color: handsColor;
				line: self center to: pMin width: 2 color: handsColor;
				line: self center to: pSec width: 1 color: handsColor.]
! !


!WatchMorph methodsFor: 'menus' stamp: 'bf 5/18/2000 10:54'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Add morph-specific items to the given menu which was invoked by the given hand."

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu add: 'change font...' action: #changeFont.
	romanNumerals
		ifTrue: [aCustomMenu add: 'use latin numerals' action: #toggleRoman]
		ifFalse: [aCustomMenu add: 'use roman numerals' action: #toggleRoman].
	aCustomMenu add: 'toggle antialiasing' action: #toggleAntialias.
	aCustomMenu add: 'change hands color...' action: #changeHandsColor.
	aCustomMenu add: 'change center color...' action: #changeCenterColor! !

!WatchMorph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:46'!
changeCenterColor
	"Let the user change the color of the center of the watch"

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #centerColor:;
		originalColor: self color;
		putUpFor: self near: self fullBounds! !

!WatchMorph methodsFor: 'menus' stamp: 'di 5/16/2000 21:48'!
changeFont

	self fontName: ((SelectionMenu labelList: StrikeFont familyNames
							selections: StrikeFont familyNames) startUp
					ifNil: [^ self])! !

!WatchMorph methodsFor: 'menus' stamp: 'sw 9/6/2000 18:46'!
changeHandsColor
	"Let the user change the color of the hands of the watch."

	ColorPickerMorph new
		choseModalityFromPreference;
		sourceHand: self activeHand;
		target: self;
		selector: #handsColor:;
		originalColor: self color;
		putUpFor: self near: self fullBounds! !

!WatchMorph methodsFor: 'menus' stamp: 'bf 5/17/2000 18:46'!
toggleAntialias
	antialias _ antialias not! !

!WatchMorph methodsFor: 'menus' stamp: 'di 5/16/2000 21:19'!
toggleRoman

	romanNumerals _ romanNumerals not.
	self createLabels! !


!WatchMorph methodsFor: 'private' stamp: 'di 5/16/2000 22:22'!
radius: unitRadius hourAngle: hourAngle
	"unitRadius goes from 0.0 at the center to 1.0 on the circumference.
	hourAngle runs from 0.0 clockwise around to 12.0 with wrapping."

	^ self center + (self extent * (Point r: 0.5 * unitRadius
									degrees: hourAngle * 30.0 - 90.0)).! !


!WatchMorph methodsFor: 'stepping' stamp: 'rlf 3/17/2000 12:59'!
step
	self changed.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WatchMorph class
	instanceVariableNames: ''!

!WatchMorph class methodsFor: 'as yet unclassified' stamp: 'rlf 3/17/2000 03:51'!
fontName: aString

	^self fontName: aString bgColor: nil centerColor: nil! !

!WatchMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/16/2000 21:43'!
fontName: aString bgColor: aColor centerColor: otherColor
	^ self new
		fontName: aString;
		color: aColor;
		centerColor: otherColor! !
AlignmentMorph subclass: #WaveEditor
	instanceVariableNames: 'graph samplingRate perceivedFrequency loopEnd loopLength loopCycles possibleLoopStarts keyboard '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Interface'!
!WaveEditor commentStamp: '<historical>' prior: 0!
This tool was created to aid in the preparation of LoopedSampledSound objects. It includes support for finding good loop points with a little help from the user.  Namely, the user must identify a good ending point for the loop (typically just before the decay phase begins) and identify one cycle of the waveform. After that, the  "choose loop point" menu command can be invoked to search backwards to find and rank all possible loop starting points. Some experimentation is usually required to find a loop that "breaths" in a natural way.

This tool can also be used as a general viewer of numerical sequences of any kind, such as time-varying functions, FFT data, etc.!


!WaveEditor methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:25'!
addControls

	| slider b r m |
	b _ SimpleButtonMorph new target: self; borderColor: Color black.
	r _ AlignmentMorph newRow.
	r color: b color; borderWidth: 0; layoutInset: 0.
	r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
	r wrapCentering: #topLeft.
	r addMorphBack: (b fullCopy label: 'X';					actionSelector: #delete).
	r addMorphBack: (b fullCopy label: '<>'; actWhen: #buttonDown;
															actionSelector: #invokeMenu).
	r addMorphBack: (b fullCopy label: 'Play';				actionSelector: #play).
	r addMorphBack: (b fullCopy label: 'Play Before';		actionSelector: #playBeforeCursor).
	r addMorphBack: (b fullCopy label: 'Play After';			actionSelector: #playAfterCursor).
	r addMorphBack: (b fullCopy label: 'Play Loop';			actionSelector: #playLoop).
	r addMorphBack: (b fullCopy label: 'Test';				actionSelector: #playTestNote).
	r addMorphBack: (b fullCopy label: 'Save';				actionSelector: #saveInstrument).
	r addMorphBack: (b fullCopy label: 'Set Loop End';		actionSelector: #setLoopEnd).
	r addMorphBack: (b fullCopy label: 'One Cycle';			actionSelector: #setOneCycle).
	r addMorphBack: (b fullCopy label: 'Set Loop Start';		actionSelector: #setLoopStart).
	self addMorphBack: r.

	r _ AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter.

	m _ StringMorph new contents: 'Index: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #cursor; putSelector: #cursor:;
		growable: false; width: 71; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Value: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #valueAtCursor; putSelector: #valueAtCursor:;
		growable: false; width: 50; step.
	r addMorphBack: m.

	slider _ SimpleSliderMorph new
		color: color;
		extent: 200@2;
		target: self;
		actionSelector: #scrollTime:.
	r addMorphBack: slider.

	m _ Morph new color: r color; extent: 10@5.  "spacer"
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: graph; getSelector: #startIndex; putSelector: #startIndex:;
		width: 40; step.
	r addMorphBack: m.

	self addMorphBack: r.

! !

!WaveEditor methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:25'!
addLoopPointControls

	| r m |
	r _ AlignmentMorph newRow.
	r color: self color; borderWidth: 0; layoutInset: 0.
	r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter.

	m _ StringMorph new contents: 'Loop end: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopEnd; putSelector: #loopEnd:;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Loop length: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopLength; putSelector: #loopLength:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Loop cycles: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #loopCycles; putSelector: #loopCycles:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	m _ StringMorph new contents: 'Frequency: '.
	r addMorphBack: m.
	m _ UpdatingStringMorph new
		target: self; getSelector: #perceivedFrequency; putSelector: #perceivedFrequency:;
		floatPrecision: 0.001;
		growable: false; width: 50; step.
	r addMorphBack: m.

	self addMorphBack: r.
! !

!WaveEditor methodsFor: 'initialization' stamp: 'ar 11/9/2000 21:25'!
initialize

	super initialize.
	samplingRate _ SoundPlayer samplingRate.
	loopEnd _ loopLength _ 0.
	loopCycles _ 1.
	perceivedFrequency _ 0.  "zero means unknown"
	self extent: 5@5;
		listDirection: #topToBottom;
		wrapCentering: #topLeft;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		layoutInset: 3;
		color: Color lightGray;
		borderWidth: 2.
	graph _ GraphMorph new extent: 450@100.
	graph cursor: 0.
	graph cursorColorAtZeroCrossings: Color blue.
	self addControls.
	self addLoopPointControls.
	self addMorphBack: graph.
	self addMorphBack: (Morph newBounds: (0@0 extent: 0@3) color: Color transparent).
	self addMorphBack: (keyboard _ PianoKeyboardMorph new).
! !


!WaveEditor methodsFor: 'menu' stamp: 'di 6/22/1999 08:46'!
chooseLoopStart 

	| bestLoops menu secs choice start |
	possibleLoopStarts ifNil: [
		Utilities
			informUser: 'Finding possible loop points...'
			during: [possibleLoopStarts _ self findPossibleLoopStartsFrom: graph cursor]].
	bestLoops _ possibleLoopStarts copyFrom: 1 to: (100 min: possibleLoopStarts size).
	menu _ CustomMenu new.
	bestLoops do: [:entry |
		secs _ ((loopEnd - entry first) asFloat / self samplingRate) roundTo: 0.01.
		menu add: entry third printString, ' cycles; ', secs printString, ' secs' action: entry].
	choice _ menu startUp.
	choice ifNil: [^ self].
	loopCycles _ choice at: 3.
	start _ self fractionalLoopStartAt: choice first.
	self loopLength: (loopEnd asFloat - start) + 1.0.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/18/1998 07:04'!
invokeMenu
	"Invoke a menu of additonal functions for this WaveEditor."

	| aMenu |
	aMenu _ CustomMenu new.
	aMenu addList:	#(
		('play straight through'		play)
		('play before cursor'		playBeforeCursor)
		('play after cursor'			playAfterCursor)
		('play test note'				playTestNote)
		('play loop'					playLoop)
		('trim before cursor'		trimBeforeCursor)
		('trim after cursor'			trimAfterCursor)
		('choose loop start'			chooseLoopStart)
		('jump to loop start'			jumpToLoopStart)
		('jump to loop end'			jumpToLoopEnd)
		('make unlooped'			setUnlooped)
		('make unpitched'			setUnpitched)
		('show envelope'			showEnvelope)
		('show FFT'					showFFTAtCursor)).
	aMenu invokeOn: self defaultSelection: nil.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/3/1998 12:42'!
jumpToLoopEnd

	graph cursor: loopEnd; centerCursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 10:09'!
jumpToLoopStart

	graph cursor: (loopEnd - loopLength) truncated; centerCursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/21/1999 22:11'!
makeLoopedSampledSound

	| data end snd basePitch |
	data _ graph data.
	((loopEnd = 0) or: [loopLength = 0])
		ifTrue: [  "save as unlooped"
			perceivedFrequency = 0
				ifTrue: [basePitch _ 100.0]
				ifFalse: [basePitch _ perceivedFrequency].
			snd _ LoopedSampledSound new
				unloopedSamples: data pitch: basePitch samplingRate: samplingRate]
		ifFalse: [
			end _ (loopEnd min: data size) max: 1.
			basePitch _ (samplingRate * loopCycles) / loopLength.
			snd _ LoopedSampledSound new
				samples: data loopEnd: end loopLength: loopLength
				pitch: basePitch samplingRate: samplingRate].
	snd addReleaseEnvelope.
	^ snd
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 7/9/1998 09:23'!
play

	graph data size < 2 ifTrue: [^ self].
	(SampledSound samples: graph data samplingRate: samplingRate) play.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:40'!
playAfterCursor

	self playFrom: graph cursor to: graph data size.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:39'!
playBeforeCursor

	self playFrom: 1 to: graph cursor.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:02'!
playFrom: start to: end

	| sz i1 i2 snd |
	sz _ graph data size.
	i1 _ ((start + 1) min: sz) max: 1.
	i2 _ ((end + 1) min: sz) max: i1.
	(i1 + 2) >= i2 ifTrue: [^ self].
	snd _ SampledSound
		samples: (graph data copyFrom: i1 to: i2)
		samplingRate: samplingRate.
	snd play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:39'!
playLoop

	| sz i1 i2 snd len |
	sz _ graph data size.
	i1 _ ((loopEnd - loopLength) truncated min: sz) max: 1.
	i2 _ (loopEnd min: sz) max: i1.
	len _ (i2 - i1) + 1.
	len < 2 ifTrue: [^ self].

	snd _ LoopedSampledSound new
		samples: (graph data copyFrom: i1 to: i2)
		loopEnd: len
		loopLength: loopLength
		pitch: 100.0
		samplingRate: samplingRate.

	"sustain for the longer of four loops or two seconds"
	snd setPitch: 100.0
		dur: (((4.0 * loopLength) / samplingRate) max: 2.0)
		loudness: 0.5.
	snd play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:38'!
playTestNote

	| data end snd loopDur dur |
	(loopEnd = 0 or: [loopLength = 0]) ifTrue: [^ self].
	data _ graph data.
	end _ (loopEnd min: data size) max: 1.
	snd _ LoopedSampledSound new
		samples: data loopEnd: end loopLength: loopLength
		pitch: 100.0 samplingRate: samplingRate.

	loopDur _ (4.0 * loopLength / samplingRate) max: 2.0.  "longer of 4 loops or 2 seconds"
	dur _ (data size / samplingRate) + loopDur.
	(snd
		addReleaseEnvelope;
		setPitch: 100.0 dur: dur loudness: 0.5) play.
! !

!WaveEditor methodsFor: 'menu' stamp: 'di 6/21/1999 17:58'!
saveInstrument

	| name |
	name _ FillInTheBlank request: 'Instrument name?'.
	name isEmpty ifTrue: [^ self].
	AbstractSound soundNamed: name put: self makeLoopedSampledSound.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 7/31/1998 11:06'!
setLoopEnd

	graph cursor: (self zeroCrossingAfter: graph cursor) - 1.
	self loopEnd: graph cursor.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 7/9/1998 08:21'!
setLoopStart
	"Assuming that the loop end and approximate frequency have been set, this method uses the current cursor position to determine the loop length and the number of cycles."

	| start len |
	start _ graph cursor.
	((start >= loopEnd) or: [perceivedFrequency = 0]) ifTrue: [
		^ self inform:
'Please set the loop end and the approximate frequency
first, then position the cursor one or more cycles
before the loop end and try this again.'].
	len _ (loopEnd - start) + 1.
	loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded.
	self loopLength: len.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setOneCycle
	"Set the approximate frequency based on a single cycle specified by the user. To use this, first set the loop end, then place the cursor one full cycle before the loop end and invoke this method."

	| len |
	len _ loopEnd - graph cursor.
	len > 0 ifTrue: [
		loopCycles _ 1.
		self loopLength: len].
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setUnlooped
	"Make this sound play straight through without looping."

	loopLength _ 0.
	loopCycles _ 1.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'!
setUnpitched
	"Make this instrument be unpitched and unlooped. Suitable for percussive sounds that should not be pitch-shifted when played. By convention, such sounds are played at a pitch of 100.0 to obtain their original pitch."

	loopLength _ 0.
	loopCycles _ 0.
	perceivedFrequency _ 100.0.
! !

!WaveEditor methodsFor: 'menu' stamp: 'di 7/16/1999 08:30'!
showEnvelope
	"Show an envelope wave constructed by collecting the maximum absolute value of the samples in fixed-size time windows of mSecsPerQuantum."

	| data mSecsPerQuantum samplesPerQuantum result endOfQuantum maxThisQuantum s nSamples |
	data _ graph data.
	mSecsPerQuantum _ 10.
	samplesPerQuantum _ (mSecsPerQuantum / 1000.0) * self samplingRate.
	result _ WriteStream on: (Array new: data size // samplesPerQuantum).
	endOfQuantum _ samplesPerQuantum.
	maxThisQuantum _ 0.
	nSamples _ (data isKindOf: SoundBuffer)
		ifTrue: [data monoSampleCount]
		ifFalse: [data size].
	1 to: nSamples do: [:i |
		i asFloat > endOfQuantum ifTrue: [
			result nextPut: maxThisQuantum.
			maxThisQuantum _ 0.
			endOfQuantum _ endOfQuantum + samplesPerQuantum].
		s _ data at: i.
		s < 0 ifTrue: [s _ 0 - s].
		s > maxThisQuantum ifTrue: [maxThisQuantum _ s]].
	WaveEditor openOn: result contents.
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 8/18/1998 07:21'!
showFFTAtCursor

	| data start availableSamples nu n fft r |
	data _ graph data.
	start _ graph cursor max: 1.
	availableSamples _ (data size - start) + 1.
	nu _ 12.
	nu > (availableSamples highBit - 1) ifTrue:
		[^ self inform: 'Too few samples after the cursor to take an FFT.'].
	n _ 2 raisedTo: nu.
	fft _ FFT new nu: nu.
	fft realData: ((start to: start + n - 1) collect: [:i | data at: i]).
	fft transformForward: true.
	r _ (1 to: n // 2) collect:
		[:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt].
	WaveEditor openOn: r.

! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:48'!
trimAfterCursor

	graph data: (graph data copyFrom: 1 to: graph cursor).
! !

!WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:52'!
trimBeforeCursor

	graph data: (graph data copyFrom: graph cursor to: graph data size).
	graph cursor: 1.

! !


!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/5/1998 12:43'!
data: newData

	graph data: newData.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/3/2004 18:16'!
graph

	^ graph
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 09:48'!
loopCycles

	^ loopCycles
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:21'!
loopCycles: aNumber

	loopCycles _ aNumber.
	self loopLength: loopLength.  "updates frequency"
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 6/30/1998 17:20'!
loopEnd

	^ loopEnd
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/31/1998 14:01'!
loopEnd: aNumber

	loopEnd _ (aNumber asInteger max: 1) min: graph data size.
	possibleLoopStarts _ nil.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 08:38'!
loopLength

	^ loopLength
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 21:03'!
loopLength: aNumber

	loopLength _ aNumber.
	((loopCycles > 0) and: [loopLength > 0]) ifTrue: [
		perceivedFrequency _ samplingRate asFloat * loopCycles / loopLength].

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 10:08'!
loopStart

	^ (loopEnd - loopLength) truncated + 1
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:46'!
loopStart: index

	| start len |
	start _ self fractionalLoopStartAt: index.
	len _ (loopEnd asFloat - start) + 1.0.
	loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded.
	self loopLength: len.
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:31'!
perceivedFrequency

	^ perceivedFrequency

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:32'!
perceivedFrequency: aNumber

	perceivedFrequency _ aNumber.
	(loopCycles > 0) ifTrue: [
		loopLength _ samplingRate asFloat * loopCycles / perceivedFrequency].
! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'!
samplingRate

	^ samplingRate

! !

!WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'!
samplingRate: samplesPerSecond

	samplingRate _ samplesPerSecond.
! !


!WaveEditor methodsFor: 'other' stamp: 'jm 7/30/1998 18:51'!
autoCorrolationBetween: index1 and: index2 length: length
	"Answer the cummulative error between the portions of my waveform starting at the given two indices and extending for the given length. The larger this error, the greater the difference between the two waveforms."

	| data error i1 e |
	data _ graph data.
	error _ 0.
	i1 _ index1.
	index2 to: (index2 + length - 1) do: [:i2 |
		e _ (data at: i1) - (data at: i2).
		e < 0 ifTrue: [e _ 0 - e].
		error _ error + e.
		i1 _ i1 + 1].
	^ error
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 7/28/1998 02:29'!
errorBetween: sampleArray1 and: sampleArray2
	"Answer the cummulative error between the two sample arrays, which are assumed to be the same size."

	| error e |
	error _ 0.
	1 to: sampleArray1 size do: [:i |
		e _ (sampleArray1 at: i) - (sampleArray2 at: i).
		e < 0 ifTrue: [e _ 0 - e].
		error _ error + e].
	^ error
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 8/17/1998 11:25'!
findPossibleLoopStartsFrom: index
	"Assume loopEnd is one sample before a zero-crossing."

	| r postLoopCycleStart i postLoopCycleLength cycleLength cycleCount err oldI |
	r _ OrderedCollection new.

	"Record the start and length of the first cycle after the loop endpoint."
	postLoopCycleStart _ loopEnd + 1.  "Assumed to be a zero-crossing."
	i _ self zeroCrossingAfter: postLoopCycleStart + (0.9 * samplingRate / perceivedFrequency) asInteger.
	postLoopCycleLength _ i - loopEnd - 1.

	"Step backwards one cycle at a time, using zero-crossings to find the
	 beginning of each cycle, and record the auto-corrolation error between
	 each cycle and the cycle following the loop endpoint. Assume pitch may shift gradually."
	i _ self zeroCrossingAfter: postLoopCycleStart - (1.1 * postLoopCycleLength) asInteger.
	cycleLength _ postLoopCycleStart - i.
	cycleCount _ 1.
	[cycleLength > 0] whileTrue: [
		err _ self autoCorrolationBetween: i and: postLoopCycleStart length: postLoopCycleLength.
		r add: (Array
				with: i
				with: err
				with: cycleCount
				with: (((loopEnd - i) asFloat / self samplingRate) roundTo: 0.01)).
		oldI _ i.
		i _ self zeroCrossingAfter: oldI - (1.1 * cycleLength) asInteger.
		cycleLength _ oldI - i.  "will be zero when start of data is encountered"
		cycleCount _ cycleCount + 1].
	r _ r asSortedCollection: [:e1 :e2 | (e1 at: 2) < (e2 at: 2)].
	^ r asArray
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 8/17/1998 11:27'!
fractionalLoopStartAt: index
	"Answer the fractional index starting point near the given integral index that results in the closest match with the cycle following the loop end."
	"Note: could do this more efficiently by sliding downhill on the error curve to find lowest error."

	| oneCycle w1 minErr w2 err bestIndex |
	oneCycle _ (samplingRate / perceivedFrequency) rounded.
	w1 _ self interpolatedWindowAt: loopEnd + 1 width: oneCycle.
	minErr _ SmallInteger maxVal.
	((index - 2) max: 1) to: ((index + 2) min: graph data size) by: 0.01 do: [:i |
		w2 _ self interpolatedWindowAt: i width: oneCycle.
		err _ self errorBetween: w1 and: w2.
		err < minErr ifTrue: [
			bestIndex _ i.
			minErr _ err]].
	^ bestIndex
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 7/31/1998 11:54'!
interpolatedWindowAt: index width: nSamples
	"Return an array of N samples starting at the given index in my data."

	| scale data baseIndex scaledFrac scaledOneMinusFrac prevSample nextSample v |
	scale _ 10000.
	data _ graph data.
	index isInteger
		ifTrue: [^ (index to: index + nSamples - 1) collect: [:i | data at: i]].
	baseIndex _ index truncated.
	scaledFrac _ ((index asFloat - baseIndex) * scale) truncated.
	scaledOneMinusFrac _ scale - scaledFrac.
	prevSample _ data at: baseIndex.
	^ (baseIndex + 1 to: baseIndex + nSamples) collect: [:i |
		nextSample _ data at: i.
		v _ ((nextSample * scaledFrac) + (prevSample * scaledOneMinusFrac)) // scale.
		prevSample _ nextSample.
		v].
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 9/19/1998 15:03'!
normalize: sampleArray
	"Return a copy of the given sample array scaled to use the maximum 16-bit sample range. Remove any D.C. offset."

	| max abs scale out |
	max _ 0.
	sampleArray do: [:s |
		s > 0 ifTrue: [abs _ s] ifFalse: [abs _ 0 - s].
		abs > max ifTrue: [max _ abs]].
	scale _ ((1 << 15) - 1) asFloat / max.

	out _ sampleArray species new: sampleArray size.
	1 to: sampleArray size do: [:i |
		out at: i put: (scale * (sampleArray at: i)) truncated].
	^ out
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 6/30/1998 16:11'!
scrollTime: relativeValue

	graph startIndex: relativeValue * (graph data size - (graph width // 2)).
! !

!WaveEditor methodsFor: 'other' stamp: 'di 6/21/1999 17:59'!
step

	keyboard soundPrototype: self makeLoopedSampledSound! !

!WaveEditor methodsFor: 'other' stamp: 'jm 9/20/1998 09:13'!
stretch: sampleArray by: stretchFactor
	"Return an array consisting of the given samples \stretched in time by the given factor."

	| out end incr i frac index |
	out _ OrderedCollection new: (stretchFactor * sampleArray size) asInteger + 1.
	end _ (sampleArray size - 1) asFloat.
	incr _ 1.0 / stretchFactor.
	i _ 1.0.
	[i < end] whileTrue: [
		frac _ i fractionPart.
		index _ i truncated.
		i _ i + incr.
		out addLast:
			(((1.0 - frac) * (sampleArray at: index)) + (frac * (sampleArray at: index + 1))) rounded].
	^ out asArray
! !

!WaveEditor methodsFor: 'other' stamp: 'jm 8/10/1998 15:08'!
zeroCrossingAfter: index
	"Find the index of the next negative-to-non-negative transition at or after the current index. The result is the index, i, of a zero crossing such that the sample at i-1 is negative and the sample at i is zero or positive. Answer the index of the last sample if the end of the array is encountered before finding a zero crossing."

	| data end i |
	data _ graph data.
	end _ data size.
	index <= 1 ifTrue: [^ 1].
	i _ index - 1.
	[(i <= end) and: [(data at: i) >= 0]] whileTrue: [i _ i + 1].  "find next negative sample"
	i >= end ifTrue: [^ end].

	i _ i + 1.
	[(i <= end) and: [(data at: i) < 0]] whileTrue: [i _ i + 1].  "find next non-negative sample"
	^ i
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WaveEditor class
	instanceVariableNames: ''!

!WaveEditor class methodsFor: 'instance creation' stamp: 'jm 9/6/1999 11:21'!
openOn: dataCollection
	"Open a new WaveEditor on the given sequencable collection of data."

	^ (self new data: dataCollection) openInWorld
! !
SoundCodec subclass: #WaveletCodec
	instanceVariableNames: 'fwt samplesPerFrame nLevels alpha beta '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound-Synthesis'!
!WaveletCodec commentStamp: '<historical>' prior: 0!
The Wavelet codec performs a wavelet transform on the original data.  It then achieves its compression by thresholding the transformed data, converting all values below a given magnitude to zero, and then run-coding the resulting data.  The run-coding provides automatic variable compression depending on the parameters chosen.

As is, this codec achieves reasonable reproduction at 10:1 compression, although the quality from the GSMCodec is definitely better.  I feel that the quality would be comparable if uLaw scaling were introduced prior to thresholding.

The nice thing about using wavelets is there are numerous factors to play with for better performance:
	nLevels - the "order" of the transform performed
	alpha and beta - these specify the wavelet shape (some are better for speech)
	the actual threshold used
By simply changing these parameters, one can easily vary the compression achieved from 5:1 to 50:1, and listen to the quality at each step.

The specific format for an encoded buffer is as follows:
	4 bytes: frameCount.
	4 bytes: samplesPerFrame.
	4 bytes: nLevels.
	4 bytes: alpha asIEEE32BitWord.
	4 bytes: beta asIEEE32BitWord.
	frameCount occurrences of...
		2 bytes: frameSize in bytes, not including these 2
			may be = 0 for complete silence, meaning no scale even.
		4 bytes: scale asIEEE32BitWord.
		A series of 1- or 2-byte values encoded as follows:
			0-111: 	a run of N+1 consecutive 0's;
			112-127:	a run of (N-112)*256 + nextByte + 1 consecutive 0's;
			128-255:	a 15-bit signed value = (N*256 + nextByte) - 32768 - 16384.!


!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:22'!
bytesPerEncodedFrame
	"Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."

	^ 0
! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 3/8/1999 08:20'!
decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
	"Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| frameBase coeffArray scale i c nullCount samples sourceFrameEnd frameSize inStream val |
	inStream _ ReadStream on: srcByteArray from: srcIndex to: srcByteArray size.
	"frameCount _ " inStream nextNumber: 4.
	samplesPerFrame _ inStream nextNumber: 4.
	nLevels _ inStream nextNumber: 4.
	alpha _ Float fromIEEE32Bit: (inStream nextNumber: 4).
	beta _ Float fromIEEE32Bit: (inStream nextNumber: 4).
	fwt ifNil:
		["NOTE: This should read parameters from the encoded data"
		fwt _ FWT new.
		fwt nSamples: samplesPerFrame nLevels: nLevels.
		fwt setAlpha: alpha beta: beta].
	frameBase _ dstIndex.
	coeffArray _ fwt coeffs.  "A copy that we can modify"

	1 to: frameCount do:
		[:frame | 

		"Decode the scale for this frame"
		frameSize _ inStream nextNumber: 2.
		sourceFrameEnd _ frameSize + inStream position.
		scale _ Float fromIEEE32Bit: (inStream nextNumber: 4).

		"Expand run-coded samples to scaled float values."
		i _ 5.
		[i <= coeffArray size]
			whileTrue:
			[c _ inStream next.
			c < 128
				ifTrue: [nullCount _ c < 112
							ifTrue: [c + 1]
							ifFalse: [(c-112)*256 + inStream next + 1].
						i to: i + nullCount - 1 do: [:j | coeffArray at: j put: 0.0].
						i _ i + nullCount]
				ifFalse: [val _ (c*256 + inStream next) - 32768 - 16384.
						coeffArray at: i put: val * scale.
						i _ i + 1]].

		"Copy float values into the wavelet sample array"		
			fwt coeffs: coeffArray.

		"Compute the transform"
		fwt transformForward: false.

		"Determine the scale for this frame"
		samples _ fwt samples.
		samples size = samplesPerFrame ifFalse: [self error: 'frame size error'].
		1 to: samples size do:
			[:j | dstSoundBuffer at: frameBase + j - 1 put: (samples at: j) asInteger].

		inStream position = sourceFrameEnd ifFalse: [self error: 'frame size error'].
		frameBase _ frameBase + samplesPerFrame].

	^ Array with: inStream position + 1 - srcIndex
			with: frameBase - dstIndex! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'RAA 6/2/2000 11:06'!
encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
	"Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
	"Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."

	| frameBase coeffs maxVal minVal c scale nullCount frameI outFrameSize threshold sm outStream cMin val |
	threshold _ 2000.
	fwt ifNil:
		[samplesPerFrame _ self samplesPerFrame.
		nLevels _ 8.
		"Here are some sample mother wavelets, with the compression achieved on a
		sample of my voice at a threshold of 2000:
									compression achieved "
		alpha _ 0.0.  beta _ 0.0.		"12.1"
		alpha _ 1.72.  beta _ 1.51.	"14.0"
		alpha _ -1.86.  beta _ -1.53.	"14.4"
		alpha _ 1.28.  beta _ -0.86.	"15.9"
		alpha _ -1.15.  beta _ 0.69.	"16.0"
		fwt _ FWT new.
		fwt nSamples: samplesPerFrame nLevels: nLevels.
		fwt setAlpha: alpha beta: beta].

	(outStream _ WriteStream on: dstByteArray from: dstIndex to: dstByteArray size)
		nextNumber: 4 put: frameCount;
		nextNumber: 4 put: samplesPerFrame;
		nextNumber: 4 put: nLevels;
		nextNumber: 4 put: alpha asIEEE32BitWord;
		nextNumber: 4 put: beta asIEEE32BitWord.
	frameBase _ srcIndex.
	1 to: frameCount do:
		[:frame | 

		"Copy float values into the wavelet sample array"		
		fwt samples: ((frameBase to: frameBase + samplesPerFrame-1) 
				collect: [:i | (srcSoundBuffer at: i) asFloat]).

		"Compute the transform"
		fwt transformForward: true.

		frameI _ outStream position+1.  "Reserve space for frame size"
		outStream nextNumber: 2 put: 0.

		"Determine and output the scale for this frame"
		coeffs _ fwt coeffs.
		maxVal _ 0.0.  minVal _ 0.0.
		5 to: coeffs size do:
			[:i | c _ coeffs at: i.
			c > maxVal ifTrue: [maxVal _ c].
			c < minVal ifTrue: [minVal _ c]].
		scale _ (maxVal max: minVal negated) / 16000.0.  "Will scale all to -16k..16k: 15 bits"
		outStream nextNumber: 4 put: scale asIEEE32BitWord.

		"Copy scaled values, with run-coded sequences of 0's, to destByteArray"
		nullCount _ 0.
		cMin _ threshold / scale.
		5 to: coeffs size do:
			[:i | c _ (coeffs at: i) / scale.
			c abs < cMin
			ifTrue: ["Below threshold -- count nulls."
					nullCount _ nullCount + 1]
			ifFalse: ["Above threshold -- emit prior null count and this sample."
					nullCount > 0 ifTrue:
						[nullCount <= 112
						ifTrue: [outStream nextNumber: 1 put: nullCount-1]
						ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1].
						nullCount _ 0].
						val _ c asInteger + 16384 + 32768.  "Map -16k..16k into 32k..64k"
						outStream nextNumber: 2 put: val]].

					nullCount > 0 ifTrue:
						[nullCount <= 112
						ifTrue: [outStream nextNumber: 1 put: nullCount-1]
						ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1]].
		outFrameSize _ outStream position+1 - frameI - 2.  "Write frame size back at the beginning"
		(WriteStream on: dstByteArray from: frameI to: dstByteArray size)
			nextNumber: 2 put: outFrameSize.
		frameBase _ frameBase + samplesPerFrame].

"This displays a temporary indication of compression achieved"
sm _ TextMorph new contents: (((frameBase - srcIndex) *2.0 / (outStream position+1 - dstIndex) truncateTo: 0.1) printString , ' : 1') asText allBold.
sm position: Sensor cursorPoint + (-20@30).
Display getCurrentMorphicWorld addMorph: sm.
Display doOneCycleNowMorphic.
sm delete.

	outStream position > dstByteArray size ifTrue:
		["The calling routine only provides buffer space for compression of 2:1 or better.  If you are just testing things, you can increase it to, eg, codeFrameSize _ frameSize*3, which would be sufficient for a threshold of 0 (lossless conversion)."
		self error: 'Buffer overrun'].

	^ Array with: frameBase - srcIndex
			with: outStream position+1 - dstIndex! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 16:49'!
frameCount: aByteArray
	"Compute the frame count for this byteArray.  This default computation will have to be overridden by codecs with variable frame sizes."

	^ (ReadStream on: aByteArray) nextNumber: 4.
! !

!WaveletCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:17'!
samplesPerFrame
	"Answer the number of sound samples per compression frame."

	^ 4096
! !
Array weakSubclass: #WeakArray
	instanceVariableNames: ''
	classVariableNames: 'FinalizationDependents FinalizationLock FinalizationProcess FinalizationSemaphore IsFinalizationSupported '
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakArray commentStamp: '<historical>' prior: 0!
WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakArray class
	instanceVariableNames: ''!

!WeakArray class methodsFor: 'class initialization' stamp: 'ar 10/7/1998 16:45'!
initialize
	"WeakArray initialize"
	"Do we need to initialize specialObjectsArray?"
	Smalltalk specialObjectsArray size < 42 
		ifTrue:[Smalltalk recreateSpecialObjectsArray].
	"Check if Finalization is supported by this VM"
	IsFinalizationSupported _ nil.
	self isFinalizationSupported ifFalse:[^self].

	FinalizationProcess notNil ifTrue:[FinalizationProcess terminate].
	FinalizationSemaphore := Smalltalk specialObjectsArray at: 42.
	FinalizationDependents isNil ifTrue:[
		FinalizationDependents := WeakArray new: 10.
	].
	FinalizationLock := Semaphore forMutualExclusion.
	FinalizationProcess := [self finalizationProcess] newProcess.
	FinalizationProcess priority: Processor userInterruptPriority.
	FinalizationProcess resume.! !


!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'!
addWeakDependent: anObject
	| finished index weakDependent |
	self isFinalizationSupported ifFalse:[^self].
	FinalizationLock critical:[
		finished := false.
		index := 0.
		[index := index + 1.
		finished not and:[index <= FinalizationDependents size]] whileTrue:[
			weakDependent := FinalizationDependents at: index.
			weakDependent isNil ifTrue:[
				FinalizationDependents at: index put: anObject.
				finished := true.
			].
		].
		finished ifFalse:[
			"Grow linearly"
			FinalizationDependents := FinalizationDependents, (WeakArray new: 10).
			FinalizationDependents at: index put: anObject.
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !

!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/7/1998 15:30'!
isFinalizationSupported
	"Check if this VM supports the finalization mechanism"
	| tempObject |
	IsFinalizationSupported ifNotNil:[^IsFinalizationSupported].
	tempObject _ WeakArray new: 1.
	"Check if the class format 4 is correctly understood by the VM.
	If the weak class support is not installed then the VM will report
	any weak class as containing 32bit words - not pointers"
	(tempObject at: 1) = nil 
		ifFalse:[^IsFinalizationSupported _false].
	"Check if objects are correctly freed"
	self pvtCreateTemporaryObjectIn: tempObject.
	Smalltalk garbageCollect.
	^IsFinalizationSupported _ (tempObject at: 1) == nil! !

!WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'!
removeWeakDependent: anObject
	self isFinalizationSupported ifFalse:[^self].
	FinalizationLock critical:[
		1 to: FinalizationDependents size do:[:i|
			((FinalizationDependents at: i) == anObject) ifTrue:[
				FinalizationDependents at: i put: nil.
			].
		].
	] ifError:[:msg :rcvr| rcvr error: msg].! !

!WeakArray class methodsFor: 'accessing' stamp: 'nk 10/28/2000 20:26'!
runningFinalizationProcess
	"Answer the FinalizationProcess I am running, if any"
	^FinalizationProcess! !


!WeakArray class methodsFor: 'private' stamp: 'ar 10/8/1998 11:19'!
finalizationProcess

	[true] whileTrue:[
		FinalizationSemaphore wait.
		FinalizationLock critical:[
			FinalizationDependents do:[:weakDependent|
				weakDependent isNil 
					ifFalse:[weakDependent finalizeValues].
			].
		] ifError:[:msg :rcvr| rcvr error: msg].
	].! !

!WeakArray class methodsFor: 'private' stamp: 'ar 10/7/1998 15:24'!
pvtCreateTemporaryObjectIn: tempObject
	"We have to create the temporary object in a separate stack frame"
	tempObject at: 1 put: Object new! !
Association subclass: #WeakKeyAssociation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
!WeakKeyAssociation commentStamp: '<historical>' prior: 0!
I am an association holding only weakly on my key.!


!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:45'!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^self key < aLookupKey key! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
= aLookupKey

	self species = aLookupKey species
		ifTrue: [^self key = aLookupKey key]
		ifFalse: [^false]! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
hash
	"Hash is reimplemented because = is implemented."

	^self key hash! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^self key hashMappedBy: map! !

!WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:47'!
identityHashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^ self key identityHashMappedBy: map! !


!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'!
printOn: aStream
	self key printOn: aStream.
	aStream nextPutAll: '->'.
	self value printOn: aStream! !

!WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'!
storeOn: aStream
	aStream 
		nextPut: $(;
		nextPutAll: self class name;
		nextPutAll:' key: '.
	self key storeOn: aStream.
	aStream nextPutAll: ' value: '.
	self value storeOn: aStream.
	aStream nextPut: $)! !


!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:54'!
key
	^key isNil
		ifTrue:[nil]
		ifFalse:[key at: 1]! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:45'!
key: aKey
	key := WeakArray with: aKey! !

!WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:44'!
key: aKey value: anObject
	key := WeakArray with: key.
	value := anObject.! !
Dictionary subclass: #WeakKeyDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakKeyDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys.

See WeakRegistry for an example of use.
!


!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:00'!
finalizeValues
	"remove all nil keys and rehash the receiver afterwards"
	| assoc |
	1 to: array size do:[:i|
		assoc _ array at: i.
		(assoc notNil and:[assoc key == nil]) ifTrue:[array at: i put: nil].
	].
	self rehash.! !

!WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 10/21/2000 20:01'!
finalizeValues: finiObjects
	"Remove all associations with key == nil and value is in finiObjects.
	This method is folded with #rehash for efficiency."
	| oldArray assoc newIndex |
	oldArray _ array.
	array _ Array new: oldArray size.
	tally _ 0.
	1 to: array size do:[:i|
		assoc _ oldArray at: i.
		assoc ifNotNil:[
			(assoc key == nil and:[finiObjects includes: assoc value]) ifFalse:[
				newIndex _ self scanForNil: assoc key.
				self atNewIndex: newIndex put: assoc].
		].
	].! !


!WeakKeyDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:02'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	key isNil ifTrue:[^anObject].
	index _ self findElementOrNil: key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)]
		ifFalse: [element value: anObject].
	^ anObject! !


!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:58'!
fixCollisionsFrom: oldIndex
	"The element at index has been removed and replaced by nil."
	self rehash. "Do it the hard way - we may have any number of nil keys and #rehash deals with them"! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:56'!
rehash
	"Rehash the receiver. Reimplemented to allow for multiple nil keys"
	| oldArray assoc newIndex |
	oldArray _ array.
	array _ Array new: oldArray size.
	tally _ 0.
	1 to: array size do:[:i|
		assoc _ oldArray at: i.
		assoc ifNotNil:[
			newIndex _ self scanForNil: assoc key.
			self atNewIndex: newIndex put: assoc.
		].
	].! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:46'!
scanFor: anObject
	"ar 10/21/2000: The method has been copied to this location to indicate that whenever #scanFor: changes #scanForNil: must be changed in the receiver as well."
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements."
	| element start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == nil or: [element key = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !

!WeakKeyDictionary methodsFor: 'private' stamp: 'ar 10/21/2000 19:46'!
scanForNil: anObject
	"Private. Scan the key array for the first slot containing nil (indicating an empty slot). Answer the index of that slot."
	| start finish |
	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | (array at: index) == nil ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !


!WeakKeyDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:00'!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !
Collection subclass: #WeakRegistry
	instanceVariableNames: 'valueDictionary accessLock '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakRegistry commentStamp: '<historical>' prior: 0!
I am a registry for objects needing finalization. When an object is added the object as well as its executor is stored. When the object is garbage collected, the executor can take the appropriate action for any resources associated with the object.

See also:
	Object executor
	Object actAsExecutor
	Object finalize
!


!WeakRegistry methodsFor: 'finalization' stamp: 'ar 10/22/2000 20:24'!
finalizeValues
	"Some of our elements may have gone away. Look for those and activate the associated executors."
	| finiObjects |
	finiObjects := nil.
	"First collect the objects."
	self protected:[
		valueDictionary associationsDo:[:assoc|
			assoc key isNil ifTrue:[
				finiObjects isNil 
					ifTrue:[finiObjects := OrderedCollection with: assoc value]
					ifFalse:[finiObjects add: assoc value]]
		].
		finiObjects isNil ifFalse:[valueDictionary finalizeValues: finiObjects asArray].
	].
	"Then do the finalization"
	finiObjects isNil ifTrue:[^self].
	finiObjects do:[:each| each finalize].
! !


!WeakRegistry methodsFor: 'adding' stamp: 'ar 3/21/98 16:33'!
add: anObject
	"Add anObject to the receiver. Store the object as well as the associated executor."
	| executor |
	executor := anObject executor.
	self protected:[
		valueDictionary at: anObject put: executor.
	].
	^anObject! !


!WeakRegistry methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'!
size
	^ self protected: [valueDictionary size]! !

!WeakRegistry methodsFor: 'accessing' stamp: 'ar 3/20/98 19:31'!
species
	^Set! !


!WeakRegistry methodsFor: 'initialize' stamp: 'ar 3/21/98 16:08'!
initialize: n
	valueDictionary := WeakKeyDictionary new: n.
	accessLock := Semaphore forMutualExclusion.! !


!WeakRegistry methodsFor: 'private' stamp: 'ar 10/8/1998 11:18'!
protected: aBlock
	"Execute aBlock protected by the accessLock"
	^accessLock isNil
		ifTrue:[aBlock value]
		ifFalse:[accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]! !


!WeakRegistry methodsFor: 'enumerating' stamp: 'ar 3/21/98 18:36'!
do: aBlock
	^self protected:[
		valueDictionary keysDo: aBlock.
	].
! !


!WeakRegistry methodsFor: 'removing' stamp: 'ar 3/21/98 21:12'!
remove: oldObject ifAbsent: exceptionBlock
	"Remove oldObject as one of the receiver's elements."
	| removedObject |
	oldObject isNil ifTrue:[^oldObject].
	self protected:[
		removedObject := valueDictionary removeKey: oldObject ifAbsent:[nil].
	].
	^removedObject isNil
		ifTrue:[exceptionBlock value]
		ifFalse:[removedObject].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakRegistry class
	instanceVariableNames: ''!

!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:32'!
new
	^self new: 5! !

!WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:33'!
new: n
	| registry |
	registry := super new initialize: n.
	WeakArray addWeakDependent: registry.
	^registry! !
Set subclass: #WeakSet
	instanceVariableNames: 'flag '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'!
add: newObject
	"Include newObject as one of the receiver's elements, but only if
	not already present. Answer newObject"

	| index |
	newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element'].
	index _ self findElementOrNil: newObject.
	((array at: index) == flag or: [(array at: index) isNil])
		ifTrue: [self atNewIndex: index put: newObject].
	^newObject! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:46'!
do: aBlock
	| each |

	tally = 0 ifTrue: [^self].
	1 to: array size do:
		[:index |
			((each _ array at: index) == nil or: [each == flag])
				ifFalse: [aBlock value: each]
		]! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:13'!
do: aBlock after: anElement
	| each startIndex |

	tally = 0 ifTrue: [^self].
	startIndex _ anElement ifNil: [1] ifNotNil:
		[self findElementOrNil: anElement].
	startIndex + 1 to: array size do:
		[:index |
			((each _ array at: index) == nil or: [each == flag])
				ifFalse: [aBlock value: each]
		]! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/30/2000 13:15'!
includes: anObject 
	^(array at: (self findElementOrNil: anObject)) ~~ flag! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 16:02'!
like: anObject
	"Answer an object in the receiver that is equal to anObject,
	nil if no such object is found. Relies heavily on hash properties"

	| index element |

	^(index _ self scanFor: anObject) = 0
		ifFalse: [(element _ array at: index) == flag ifFalse: [element]]! !

!WeakSet methodsFor: 'public' stamp: 'di 2/3/2001 16:46'!
printElementsOn: aStream
	| oldPos |
	aStream nextPut: $(.
	oldPos _ aStream position.
	self do: [:element | aStream print: element; space].
	aStream position > oldPos ifTrue: [aStream skip: -1 "remove the extra space"].
	aStream nextPut: $)! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:08'!
remove: oldObject ifAbsent: aBlock

	| index |
	index _ self findElementOrNil: oldObject.
	(array at: index) == flag ifTrue: [ ^ aBlock value ].
	array at: index put: flag.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^oldObject! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:12'!
size
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	^tally! !

!WeakSet methodsFor: 'public' stamp: 'SqR 8/23/2000 15:17'!
slowSize
	"Careful!! Answer the maximum amount
	of elements in the receiver, not the
	exact amount"

	tally _ array inject: 0 into:
		[:total :each | (each == nil or: [each == flag])
			ifTrue: [total] ifFalse: [total + 1]].
	^tally! !


!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 14:30'!
fixCollisionsFrom: index
	"The element at index has been removed and replaced by nil.
	This method moves forward from there, relocating any entries
	that had been placed below due to collisions with this one"

	| length oldIndex newIndex element |

	oldIndex _ index.
	length _ array size.
	[oldIndex = length
			ifTrue: [oldIndex _ 1]
			ifFalse: [oldIndex _ oldIndex + 1].
	(element _ self keyAt: oldIndex) == flag]
		whileFalse: 
			[newIndex _ self findElementOrNil: element.
			oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
grow
	"Grow the elements array and reinsert the old elements"

	self growTo: array size + self growSize! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
growTo: anInteger
	"Grow the elements array and reinsert the old elements"

	| oldElements |

	oldElements _ array.
	array _ WeakArray new: anInteger.
	array atAllPut: flag.
	tally _ 0.
	oldElements do:
		[:each | (each == flag or: [each == nil]) ifFalse: [self noCheckAdd: each]]! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 14:38'!
init: n
	"Initialize array to an array size of n"

	flag _ Object new.
	array _ WeakArray new: n.
	array atAllPut: flag.
	tally _ 0! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 15:43'!
rehash
	self growTo: array size! !

!WeakSet methodsFor: 'private' stamp: 'SqR 8/23/2000 14:35'!
scanFor: anObject
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements"

	| element start finish |

	start _ (anObject hash \\ array size) + 1.
	finish _ array size.

	"Search from (hash mod size) to the end."
	start to: finish do:
		[:index | ((element _ array at: index) == flag or: [element = anObject])
			ifTrue: [^ index ]].

	"Search from 1 to where we started."
	1 to: start-1 do:
		[:index | ((element _ array at: index) == flag or: [element = anObject])
			ifTrue: [^ index ]].

	^ 0  "No match AND no empty slot"! !
LookupKey weakSubclass: #WeakValueAssociation
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!

!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:11'!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key _ aKey.
	self value: anObject! !

!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'!
value
	^self at: 1! !

!WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	self at: 1 put: anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeakValueAssociation class
	instanceVariableNames: ''!

!WeakValueAssociation class methodsFor: 'instance creation' stamp: 'r++ 5/27/2000 18:07'!
key: anObject value: bObject
	^ self new key: anObject value: bObject! !


!WeakValueAssociation class methodsFor: 'as yet unclassified' stamp: 'r++ 5/27/2000 18:12'!
new
	^ self new: 1! !
Dictionary subclass: #WeakValueDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Weak'!
!WeakValueDictionary commentStamp: '<historical>' prior: 0!
I am a dictionary holding only weakly on my values. Clients may expect to get a nil value for any object they request.!


!WeakValueDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:02'!
add: anAssociation
	self at: anAssociation key put: anAssociation value.
	^ anAssociation! !


!WeakValueDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:01'!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	index _ self findElementOrNil: key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: (WeakValueAssociation key: key value: anObject)]
		ifFalse: [element value: anObject].
	^ anObject! !
PluggableTextMorph subclass: #WebPageMorph
	instanceVariableNames: 'getBgSelector asColor image '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Windows'!

!WebPageMorph methodsFor: 'change reporting' stamp: 'AK 12/7/1999 01:31'!
layoutChanged
		"Udate the image and compute new bounds"
		self changed.
		self update: getBgSelector.
		super layoutChanged.
		self changed.! !


!WebPageMorph methodsFor: 'model access' stamp: 'AK 12/4/1999 01:27'!
getBg
	"Retrieve the current model background color/image"

	getBgSelector == nil ifTrue: [^Color white].
	^ (model perform: getBgSelector) ifNil: [Color white]
	
! !


!WebPageMorph methodsFor: 'updating' stamp: 'di 6/13/2000 08:49'!
update: aSymbol

	super update: aSymbol.
	aSymbol == getBgSelector ifTrue:
		[ (self isImage: self getBg) ifTrue:[image _ self drawImage: self getBg]
								ifFalse:[ image _ nil.
										self color: self getBg]]! !


!WebPageMorph methodsFor: 'other' stamp: 'AK 12/7/1999 01:10'!
drawImage: aForm 
	| aImage patternBox targetBox map |
	aImage _ Form extent: self extent depth: Display depth.
	patternBox _ aForm boundingBox.
	targetBox _ aImage boundingBox.
	map _ aForm colormapIfNeededForDepth: aImage depth.
	targetBox left to: targetBox right - 1 by: patternBox width do:
		[:x |
		targetBox top to: targetBox bottom - 1 by: patternBox height do:
			[:y | aImage copyBits: patternBox from: aForm at: x @ y colorMap: map ]].
	^aImage! !

!WebPageMorph methodsFor: 'other' stamp: 'AK 12/4/1999 02:24'!
isImage: aForm

		(aForm isKindOf: Form) ifFalse:[^false].
		^true! !


!WebPageMorph methodsFor: 'initialization' stamp: 'AK 12/7/1999 01:25'!
on: aModel bg: getBgSel text: getTextSel readSelection: getSelectionSel menu: getMenuSel
	
	self on: aModel text: getTextSel accept: nil readSelection: getSelectionSel menu: getMenuSel.
	getBgSelector _ getBgSel.
	
	! !


!WebPageMorph methodsFor: 'drawing' stamp: 'AK 12/4/1999 02:37'!
drawOn: aCanvas

		super drawOn: aCanvas.	
		image = nil ifFalse:[aCanvas image: image at: bounds origin].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WebPageMorph class
	instanceVariableNames: ''!

!WebPageMorph class methodsFor: 'instance creation' stamp: 'AK 12/4/1999 02:50'!
on: model bg: getBgSel text: getTextSel readSelection: getSelectionSel menu: getMenuSel
	^self new on: model
		bg: getBgSel
		text: getTextSel
		readSelection: getSelectionSel
		menu: getMenuSel! !
Date subclass: #Week
	instanceVariableNames: ''
	classVariableNames: 'StartMonday '
	poolDictionaries: ''
	category: 'Kernel-Magnitudes'!
!Week commentStamp: '<historical>' prior: 0!
Weeks begin in #Monday and end in #Sunday!


!Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:13'!
asDate
	"Answer the first day of the week."
	^ Date
		newDay: self dayOfMonth
		month: self monthName
		year: self year! !

!Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:14'!
next
	^ self class fromDate: (self firstDate addDays: 7)! !

!Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:14'!
previous
	^ self class fromDate: (self firstDate subtractDays: 7)! !


!Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:14'!
duration
	^ 7! !

!Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 13:17'!
firstDate
	^ self asDate! !

!Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:17'!
index
	^ self indexInMonth: self firstDate month! !

!Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:16'!
indexInMonth: aMonth
	"1=first week, 2=second week, etc."
	^ (Date dayOfWeek: aMonth weekday) + self dayOfMonth - 2  // 7 + 1! !

!Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:17'!
lastDate
	^ self firstDate addDays: 6! !


!Week methodsFor: 'enumerating' stamp: 'LC 7/27/1998 04:08'!
do: aBlock
	| date |
	date _ self asDate.
	7 timesRepeat:
		[aBlock value: date.
		date _ date addDays: 1]! !


!Week methodsFor: 'printing' stamp: 'LC 7/28/1998 00:37'!
printOn: aStream
	aStream nextPutAll:
		self month printString, ', ',
		(#('1st week' '2nd week' '3rd week' '4th week' '5th week' '6th week') at: self index)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Week class
	instanceVariableNames: ''!

!Week class methodsFor: 'instance creation' stamp: 'sge 5/19/2000 21:02'!
fromDate: aDate
	| startDay |
	startDay _ aDate previous: (self startMonday 
								ifTrue: [#Monday] ifFalse: [#Sunday]).
	^ self
		newDay: startDay dayOfMonth
		month: startDay monthName
		year: startDay year! !


!Week class methodsFor: 'class variables' stamp: 'sge 5/18/2000 05:50'!
startMonday
	StartMonday ifNil: [StartMonday _ true].
	^ StartMonday! !

!Week class methodsFor: 'class variables' stamp: 'sge 5/18/2000 06:24'!
toggleStartMonday
	StartMonday _ self startMonday not! !
AlignmentMorph subclass: #WeekMorph
	instanceVariableNames: 'week month tileRect '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!WeekMorph methodsFor: 'all' stamp: 'dhhi 9/14/2000 14:16'!
initialize

	^ self initializeForWeek: Date today week
		month: Date today month
		tileRect: (0@0 extent: 23@19)
		model: nil! !

!WeekMorph methodsFor: 'all' stamp: 'dhhi 9/14/2000 20:42'!
initializeDays: modelOrNil
	| extent days tile |
	self removeAllMorphs.
	days _ OrderedCollection new: 7.
	extent _ self tile extent.
	week do:
		[:each |
		tile _ (self tileLabeled: each dayOfMonth printString) extent: extent.
		each month = month ifFalse:
			[tile color: Color gray; offColor: Color gray; onColor: Color veryLightGray].
		modelOrNil ifNotNil:
			[tile target: modelOrNil;
				actionSelector: #setDate:fromButton:down:;
				arguments: {each. tile}].
		days add: tile].
	days reverseDo: [:each | self addMorph: each]! !

!WeekMorph methodsFor: 'all' stamp: 'ar 11/9/2000 20:59'!
initializeForWeek: aWeek month: aMonth tileRect: rect model: aModel

	super initialize.
	tileRect _ rect.
	self layoutInset: 0;
		color: Color transparent;
		listDirection: #leftToRight;
		hResizing: #shrinkWrap;
		disableDragNDrop;
		height: tileRect height.
	self week: aWeek month: aMonth model: aModel
! !

!WeekMorph methodsFor: 'all' stamp: 'LC 7/27/1998 23:39'!
next
	^ self class on: week next! !

!WeekMorph methodsFor: 'all' stamp: 'LC 7/27/1998 23:43'!
selectedDates
	| answer |
	answer _ SortedCollection new.
	self submorphsDo:
		[:each |
		((each respondsTo: #onColor) and: [each color = each onColor])
			ifTrue:
				[answer add:
					(Date
						newDay: each label asNumber
						month: week firstDate monthName
						year: week firstDate year)]].
	^ answer! !

!WeekMorph methodsFor: 'all' stamp: 'di 9/6/2000 22:49'!
tile
	| onColor offColor |
	offColor _ Color r: 0.4 g: 0.8 b: 0.6.
	onColor _ offColor alphaMixed: 1/2 with: Color white.
	^ SimpleSwitchMorph new
		offColor: offColor;
		onColor: onColor;
		borderWidth: 1;
		useSquareCorners;
		extent: tileRect extent! !

!WeekMorph methodsFor: 'all' stamp: 'di 9/6/2000 22:49'!
tileLabeled: labelString
	| onColor offColor |
	offColor _ Color r: 0.4 g: 0.8 b: 0.6.
	onColor _ offColor alphaMixed: 1/2 with: Color white.
	^ (SimpleSwitchMorph newWithLabel: labelString)
		offColor: offColor;
		onColor: onColor;
		borderWidth: 1;
		useSquareCorners;
		extent: tileRect extent;
		setSwitchState: false! !

!WeekMorph methodsFor: 'all' stamp: 'ar 11/9/2000 20:59'!
title
	"Answer a title with the names of the days."
	| title extent days |
	title _ AlignmentMorph new
		layoutInset: 0;
		color: Color red;
		listDirection: #leftToRight;
		vResizing: #shrinkWarp;
		height: tileRect height.
		extent _ self tile extent.
	days _ Week startMonday
		ifTrue: [7 to: 1 by: -1]       "Original code, Mon-Sun."
		ifFalse: [#(6 5 4 3 2 1 7)].   "Sun-Sat."
	(days collect: [:each | Date nameOfDay: each]) do:
		[:each |
		title addMorph:
			((self tileLabeled: (each copyFrom: 1 to: 2))
				extent: extent)].
	^ title
	! !

!WeekMorph methodsFor: 'all' stamp: 'dhhi 9/14/2000 13:58'!
week: aWeek month: aMonth model: aModel
	week _ aWeek.
	month _ aMonth.
	self initializeDays: aModel! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WeekMorph class
	instanceVariableNames: ''!

!WeekMorph class methodsFor: 'instance creation' stamp: 'LC 7/28/1998 00:53'!
includeInNewMorphMenu
	"Return true for all classes that can be instantiated from the menu"
	^ false! !

!WeekMorph class methodsFor: 'instance creation' stamp: 'dhhi 9/14/2000 14:10'!
newWeek: aWeek month: aMonth tileRect: rect model: aModel

	^ self basicNew initializeForWeek: aWeek month: aMonth tileRect: rect model: aModel
! !

!WeekMorph class methodsFor: 'instance creation' stamp: 'dhhi 9/14/2000 14:17'!
on: aDate
	^ self new
		week: aDate week
		month: aDate month
		model: nil! !
BorderedMorph subclass: #WheelMorph
	instanceVariableNames: 'target actionSelector factor circular old angle maxAngle lastRedraw '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Viewing'!

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/13/2000 12:56'!
actionSelector
	^ actionSelector
! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/13/2000 12:57'!
actionSelector: aSymbolOrString

	(nil = aSymbolOrString or:
	 ['nil' = aSymbolOrString or:
	 [aSymbolOrString isEmpty]])
		ifTrue: [^ actionSelector _ nil].

	actionSelector _ aSymbolOrString asSymbol.

! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 11:32'!
angle
	^angle! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 11:33'!
angle: aNumber
	angle := aNumber! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 17:02'!
factor
	^factor! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 17:03'!
factor: aFloat
	factor := aFloat! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 11:35'!
maxAngle
	^maxAngle! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/19/2000 11:35'!
maxAngle: aNumber
	maxAngle := aNumber! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/13/2000 12:47'!
target
	^target! !

!WheelMorph methodsFor: 'accessing' stamp: 'ti 3/13/2000 12:48'!
target: aTargetObject
	target := aTargetObject! !


!WheelMorph methodsFor: 'drawing' stamp: 'bf 3/24/2000 10:55'!
drawOn: aCanvas
	| interval delta frame x0 x1 y0 y1 deltaX deltaY  hilitColor shadowColor |
	super drawOn: aCanvas.		"border & background"
	borderColor isColor
		ifTrue: [hilitColor _ shadowColor _ borderColor]
		ifFalse: [hilitColor := color lighter lighter.
			shadowColor := color darker darker].
	frame := self innerBounds insetBy: 2.
	aCanvas frameAndFillRectangle: frame fillColor: color
		borderWidth: 1 topLeftColor: hilitColor bottomRightColor: shadowColor.
	frame _ frame insetBy: (borderColor isColor ifTrue: [1] ifFalse: [2]).
	x0 := frame origin x.
	x1 := frame corner x.
	y0 := frame origin y.
	y1 := frame corner y.
	deltaX := (x1 - x0) / 2.
	deltaY := (y1 - y0) / 2.
	interval := 10.
	delta := self angle \\ interval.
	1 to: (self maxAngle / (2 * interval)) rounded do: [ :i |
		| x y |
		self isHorizontal ifTrue: [
			x := x0 + deltaX - (((i * interval + delta) * (2 * Float pi / 360.0)) cos * deltaX).
			aCanvas fillRectangle: (Rectangle origin: (x-1)@y0 corner: x@y1) color: hilitColor.
			borderColor isColor ifFalse:
				 [aCanvas fillRectangle: (Rectangle origin: x@y0 corner: (x+1)@y1) color: shadowColor]]
		ifFalse: [
			y := y0 + deltaY - (((i * interval + delta) * (2 * Float pi / 360.0)) cos * deltaY).
			aCanvas fillRectangle: (Rectangle origin: x0@(y-1) corner: x1@y) color: hilitColor.
			borderColor isColor ifFalse:
				 [aCanvas fillRectangle: (Rectangle origin: x0@y corner: x1@(y+1)) color: shadowColor]]]! !


!WheelMorph methodsFor: 'event handling' stamp: 'ti 3/19/2000 17:03'!
doTargetAction: cursorPoint
	| new delta |
	self isHorizontal
		ifTrue: [new := cursorPoint x]
		ifFalse: [new := cursorPoint y].
	delta := new - old.
	delta isZero ifTrue: [^self].
	self addAngle: delta.
	(target ~~ nil and: [actionSelector ~~ nil]) ifTrue: [
		Cursor normal showWhile: [
			target perform: actionSelector withArguments: (Array with: (delta * self factor))]].
	old := new.
! !

!WheelMorph methodsFor: 'event handling' stamp: 'ti 3/19/2000 14:50'!
handlesMouseDown: evt
	^true
! !

!WheelMorph methodsFor: 'event handling' stamp: 'ti 3/14/2000 18:09'!
mouseDown: evt
	self isHorizontal
		ifTrue: [old := evt cursorPoint x]
		ifFalse: [old := evt cursorPoint y].! !

!WheelMorph methodsFor: 'event handling' stamp: 'ti 3/19/2000 14:51'!
mouseMove: evt
	(evt anyButtonPressed)
		ifTrue: [self doTargetAction: evt cursorPoint]! !


!WheelMorph methodsFor: 'initialization' stamp: 'ti 3/23/2000 11:52'!
initialize
	super initialize.
	self target: nil.
	self actionSelector: #flash.
	self angle: 0.
	self maxAngle: 360.
	self factor: 1.0.
	self extent: 100@18.
	self beCircular.
	self borderColor: #raised.
	self borderWidth: 1.
	self color: Color lightGray.
	lastRedraw := 0.! !


!WheelMorph methodsFor: 'private' stamp: 'ti 3/20/2000 15:58'!
addAngle: aNumber
	| new |
	new := self angle + aNumber.
	self isCircular ifTrue: [new := new \\ self maxAngle].
	self angle: new.
	lastRedraw := lastRedraw + aNumber.
	(lastRedraw abs > 2) ifTrue: [
		lastRedraw := 0.
		self changed]! !


!WheelMorph methodsFor: 'properties' stamp: 'ti 3/20/2000 13:18'!
beCircular
	circular := true! !

!WheelMorph methodsFor: 'properties' stamp: 'bf 3/23/2000 18:34'!
beHorizontal
	self isHorizontal
		ifFalse: [self extent: self extent transposed] ! !

!WheelMorph methodsFor: 'properties' stamp: 'ti 3/20/2000 13:19'!
beLinear
	circular := false! !

!WheelMorph methodsFor: 'properties' stamp: 'bf 3/23/2000 18:34'!
beVertical
	self isHorizontal
		ifTrue: [self extent: self extent transposed] ! !

!WheelMorph methodsFor: 'properties' stamp: 'ti 3/20/2000 13:19'!
isCircular
	^circular! !

!WheelMorph methodsFor: 'properties' stamp: 'bf 3/23/2000 18:26'!
isHorizontal
	^ bounds isWide! !

!WheelMorph methodsFor: 'properties' stamp: 'ti 3/20/2000 13:19'!
isLinear
	^circular not! !

!WheelMorph methodsFor: 'properties' stamp: 'ti 3/22/2000 19:12'!
isVertical
	^self isHorizontal not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WheelMorph class
	instanceVariableNames: ''!

!WheelMorph class methodsFor: 'examples' stamp: 'ti 3/24/2000 17:33'!
example
	"See B3DSceneExplorerMorph>>initialize for usage."
	"WheelMorph example"

	B3DSceneExplorerMorph new openInWorld! !
PasteUpMorph subclass: #WiWPasteUpMorph
	instanceVariableNames: 'parentWorld hostWindow pendingEvent displayChangeSignatureOnEntry '
	classVariableNames: 'Debug '
	poolDictionaries: ''
	category: 'Morphic-Worlds'!
!WiWPasteUpMorph commentStamp: '<historical>' prior: 0!
This subclass of PasteUpMorph provides special support for viewing of a world in an inner window (WorldWindow).!


!WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 5/24/2000 10:31'!
hostWindow: x

	hostWindow _ x.
	worldState canvas: nil.	"safer to start from scratch"
	self viewBox: hostWindow panelRect.
! !

!WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/20/1999 15:11'!
initialize

	super initialize.
	parentWorld _ World.
! !

!WiWPasteUpMorph methodsFor: 'initialization' stamp: 'ar 9/15/2000 23:29'!
viewBox: newViewBox

	| vb |

	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	((vb _ self viewBox) == nil or: [vb ~= newViewBox])
		ifTrue: [worldState canvas: nil].

	worldState viewBox: newViewBox.

	bounds _ newViewBox.
	worldState assuredCanvas.
	"Paragraph problem workaround; clear selections to avoid screen droppings:"
	self flag: #arNote. "Probably unnecessary"
	worldState handsDo: [:h | h releaseKeyboardFocus].
	self fullRepaintNeeded.

! !


!WiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 5/25/2000 15:11'!
becomeTheActiveWorldWith: evt
	| outerWorld |
	World == self ifTrue: [^ self].
	worldState resetDamageRecorder.	"since we may have moved, old data no longer valid"
	hostWindow setStripeColorsFrom: Color green.
	worldState canvas: nil.	"safer to start from scratch"
	displayChangeSignatureOnEntry _ Display displayChangeSignature.

	"Messy stuff to clear flaps from outer world"
	Utilities globalFlapTabs do: [:f | f changed].
	outerWorld _ World.
	World _ self.
		self installFlaps.
	World _ outerWorld.
		outerWorld displayWorld.
	World _ self.

	self viewBox: hostWindow panelRect.
	self startSteppingSubmorphsOf: self.
	self changed.
	pendingEvent _ nil.
	evt ifNotNil: [self primaryHand handleEvent: (evt setHand: self primaryHand)].

! !

!WiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 5/25/2000 15:11'!
revertToParentWorldWithEvent: evt

	"RAA 27 Nov 99 - if the display changed while we were in charge, parent may need to redraw"

	worldState resetDamageRecorder.	"Terminate local display"
	World _ parentWorld.
	World assuredCanvas.
	World installFlaps.
	hostWindow setStripeColorsFrom: Color red.
	(displayChangeSignatureOnEntry = Display displayChangeSignature) ifFalse: [
		World fullRepaintNeeded; displayWorld
	].
	evt ifNotNil: [World restartWorldCycleWithEvent: evt].

! !

!WiWPasteUpMorph methodsFor: 'activation' stamp: 'di 11/26/1999 14:09'!
validateMouseEvent: evt

	evt isMouseDown ifFalse: [^ self].

	"any click outside returns us to our home world"
	(self bounds containsPoint: evt cursorPoint) ifFalse: [
		self revertToParentWorldWithEvent: evt.
	].! !


!WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 5/25/2000 15:27'!
doDeferredUpdating
	"If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."

	PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
	(Display deferUpdates: true) ifNil: [^ false].  "deferred updates not supported"

	self resetViewBox.
	^ true
! !

!WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/23/1999 09:01'!
doOneCycle

	pendingEvent ifNotNil: [
		self primaryHand handleEvent: (pendingEvent setHand: self primaryHand).
		pendingEvent _ nil.
	].
	^super doOneCycle.! !

!WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 6/3/2000 09:49'!
restartWorldCycleWithEvent: evt

	"redispatch that click in outer world"

	pendingEvent _ evt.
	CurrentProjectRefactoring currentSpawnNewProcessAndTerminateOld: true
! !

!WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/25/1999 10:11'!
runStepMethods

	"self == World ifFalse: [^ self]."		"not sure why this was here, but MVC doesn't like it"
	super runStepMethods! !


!WiWPasteUpMorph methodsFor: 'drawing' stamp: 'RAA 5/25/2000 08:04'!
restoreDisplay

	Display restoreMorphicDisplay.	"I don't actually expect this to be called"! !


!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/14/1999 12:05'!
extent: x

	super extent: x.
	self resetViewBox.! !

!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 5/24/2000 10:50'!
resetViewBox

	| c |
	(c _ worldState canvas) == nil ifTrue: [^self resetViewBoxForReal].
	c form == Display ifFalse: [^self resetViewBoxForReal].
	c origin = (0@0) ifFalse: [^self resetViewBoxForReal].
	c clipRect extent = (self viewBox intersect: parentWorld viewBox) extent ifFalse: [^self resetViewBoxForReal].
			
! !

!WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/6/2000 17:42'!
resetViewBoxForReal

	| newClip |
	self viewBox ifNil: [^self].
	newClip _ self viewBox intersect: parentWorld viewBox.
	worldState canvas: (
		Display getCanvas
			copyOffset:  0@0
			clipRect: newClip
	)! !


!WiWPasteUpMorph methodsFor: 'events' stamp: 'di 11/26/1999 08:14'!
mouseDown: evt

	(World == self or: [World isNil]) ifTrue: [^ super mouseDown: evt].
	(self bounds containsPoint: evt cursorPoint) ifFalse: [^ self].

	self becomeTheActiveWorldWith: evt.
! !


!WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 15:45'!
displayWorld

	"RAA 27 Nov 99 - if we are not active, then the parent should do the drawing"

	self flag: #bob.			"probably not needed"

	World == self ifTrue: [^super displayWorld].
	parentWorld ifNotNil: [^parentWorld displayWorld].
	^super displayWorld		"in case MVC needs it"! !

!WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'di 11/27/1999 10:27'!
goBack
	PopUpMenu notify: 'Project changes are not yet allowed
from inner worlds.'! !

!WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'di 11/27/1999 10:27'!
jumpToProject
	PopUpMenu notify: 'Project changes are not yet allowed
from inner worlds.'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WiWPasteUpMorph class
	instanceVariableNames: ''!

!WiWPasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/20/1999 08:05'!
say: x

	(Debug ifNil: [Debug _ OrderedCollection new])
		add: x asString,'
'.
	Debug size > 500 ifTrue: [Debug _ Debug copyFrom: 200 to: Debug size]! !

!WiWPasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/1999 11:04'!
show

	Debug inspect.
	Debug _ OrderedCollection new.! !
Win32HGDIObj subclass: #Win32HBrush
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Win32HBrush class
	instanceVariableNames: ''!

!Win32HBrush class methodsFor: 'instance creation' stamp: 'TBn 6/15/2000 22:44'!
createHatchBrush: aStyle color: aColor 
	"Creates an instance of the receiver that has the specified hatch pattern and color"
	^ self apiCreateHatchBrush: aStyle with: aColor asColorref! !

!Win32HBrush class methodsFor: 'instance creation' stamp: 'ar 1/25/2000 17:03'!
createSolidBrush: aCOLORREF
	<apicall: Win32HBrush 'CreateSolidBrush' (ulong) module: 'gdi32.dll'>
	^self externalCallFailed! !


!Win32HBrush class methodsFor: 'api calls' stamp: 'TBn 6/15/2000 22:42'!
apiCreateHatchBrush: aStyle with: colorref 
	"Creates a logical brush that has the specified hatch pattern and color"
	<apicall: Win32HBrush 'CreateHatchBrush' (long ulong) module: 'gdi32.dll'>
	^ self externalCallFailed! !


!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:01'!
backwardDiagonalWithColor: aColor 
	"45-degree downward left-to-right hatch brush"
	^ self createHatchBrush: 3 color: aColor! !

!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:06'!
crossWithColor: aColor 
	"Horizontal and vertical crosshatch brush"
	^ self createHatchBrush: 4 color: aColor! !

!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:03'!
diagonalCrossWithColor: aColor 
	"45-degree crosshatch brush"
	^ self createHatchBrush: 5 color: aColor! !

!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:02'!
forwardDiagonalWithColor: aColor 
	"45-degree upward left-to-right hatch brush"
	^ self createHatchBrush: 2 color: aColor! !

!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:04'!
horizontalWithColor: aColor 
	"Horizontal hatch brush"
	^ self createHatchBrush: 0 color: aColor! !

!Win32HBrush class methodsFor: 'hatch brushes' stamp: 'TBn 6/15/2000 23:05'!
verticalWithColor: aColor 
	"Horizontal hatch brush"
	^ self createHatchBrush: 1 color: aColor ! !
Win32Handle subclass: #Win32HDC
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

!Win32HDC methodsFor: 'initialize-release' stamp: 'ar 12/2/1999 18:31'!
delete
	handle == nil
		ifFalse:[self apiDeleteDC: self].
	handle _ nil.! !


!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 21:24'!
drawFocusRectangle: aRect  
	"draws a rectangle in the style used to indicate that the rectangle has the focus"
 
	self
		apiDrawFocusRect: self
		with: (Win32Rectangle fromRectangle: aRect)
	 
	 ! !

!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 21:45'!
drawFrameControl: aRect type: aType style: aStyle
	"Draws a frame control of the specified type and style (integer values)"
	self apiDrawFrameControl: self with: (Win32Rectangle fromRectangle: aRect) with: aType with: aStyle! !

!Win32HDC methodsFor: 'drawing' stamp: 'ar 12/2/1999 18:18'!
ellipse: aRect
	^self apiEllipse: self with: aRect left with: aRect top with: aRect right with: aRect bottom! !

!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 20:38'!
fillRectangle: aRect color: aColor 
	"fills an area of the display with the given color"
	| brush |
	 
	brush _ Win32HBrush createSolidBrush: aColor asColorref.
	self
		apiFillRect: self
		with: (Win32Rectangle fromRectangle: aRect)
		with: brush.
	brush delete! !

!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 21:08'!
floodFillAt: aPoint boundaryColor: aColor fillColor: anotherColor 
	"fills an area of the display with the given color"
	| newBrush oldBrush |
	newBrush _ Win32HBrush createSolidBrush: anotherColor asColorref.
	oldBrush _ self selectObject: newBrush.
	(self
		apiExtFloodFill: self
		with: aPoint x
		with: aPoint y
		with: aColor asColorref
		with: 0) inspect.
	self selectObject: oldBrush.
	newBrush delete! !

!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 22:38'!
frameRectangle: aRect brush: aBrush
	"Draws a border around the specified rectangle by using the specified brush. The width and height of the border are always one logical unit."
 
	self
		apiFrameRect: self
		with: (Win32Rectangle fromRectangle: aRect)
		with: aBrush.
 ! !

!Win32HDC methodsFor: 'drawing' stamp: 'ar 12/2/1999 18:18'!
lineTo: aPoint
	^self apiLineTo: self with: aPoint x with: aPoint y! !

!Win32HDC methodsFor: 'drawing' stamp: 'ar 12/2/1999 18:19'!
moveTo: aPoint
	^self apiMoveToEx: self with: aPoint x with: aPoint y with: nil! !

!Win32HDC methodsFor: 'drawing' stamp: 'ar 12/2/1999 18:19'!
rectangle: aRect
	^self apiRectangle: self with: aRect left with: aRect top with: aRect right with: aRect bottom! !

!Win32HDC methodsFor: 'drawing' stamp: 'TBn 6/15/2000 21:16'!
roundRectangle: aRect width: width height: height 
	^ self
		apiRoundRect: self
		with: aRect left
		with: aRect top
		with: aRect right
		with: aRect bottom
		with: width
		with: height! !

!Win32HDC methodsFor: 'drawing' stamp: 'ar 12/2/1999 18:19'!
selectObject: aHGDIOBJ
	^self apiSelectObject: self with: aHGDIOBJ! !


!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:03'!
apiDeleteDC: aHDC
	<apicall: bool 'DeleteDC' (Win32HDC) module:'gdi32.dll'>
	^self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 21:25'!
apiDrawFocusRect: aHDC with: lpRect 
	"Draws a rectangle in the style used to indicate that the rectangle has 
	the focus."
	<apicall: bool 'DrawFocusRect' (Win32HDC Win32Rectangle*) module: 'user32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 21:42'!
apiDrawFrameControl: aHDC with: lpRect with: type with: state
	"Draws a frame control of the specified type and style"
	<apicall: bool 'DrawFrameControl' (Win32HDC Win32Rectangle* ulong ulong) module: 'user32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:03'!
apiEllipse: aHDC with: left with: top with: right with: bottom
	<apicall: bool 'Ellipse' (Win32HDC long long long long) module: 'gdi32.dll'>
	^self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 20:34'!
apiExtFloodFill: aHDC with: x with: y with: colorref with: fillType 
	"fills an area of the display surface with the current brush"
	<apicall: bool 'ExtFloodFill' (Win32HDC long long ulong ulong) module: 'gdi32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 20:22'!
apiFillRect: aHDC with: lpRect with: brush 
	"Fills a rectangle by using the specified brush. This function includes  
	the left and top borders, but excludes the right and bottom borders of  
	the rectangle.  
	"
	<apicall: char 'FillRect' (Win32HDC Win32Rectangle* Win32HBrush) module: 'user32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 22:36'!
apiFrameRect: aHDC with: lpRect with: brush 
	"Draws a border around the specified rectangle by using the specified brush. The width and height of the border are always one logical unit."
	<apicall: char 'FrameRect' (Win32HDC Win32Rectangle* Win32HBrush) module: 'user32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:03'!
apiLineTo: aHDC with: x with: y
	<apicall: bool 'LineTo' (Win32HDC long long) module:'gdi32.dll'>
	^self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:03'!
apiMoveToEx: aHDC with: x with: y with: pt
	<apicall: bool 'MoveToEx' (Win32HDC long long Win32Point*) module: 'gdi32.dll'>
	^self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:04'!
apiRectangle: aHDC with: left with: top with: right with: bottom
	<apicall: bool 'Rectangle' (Win32HDC long long long long) module: 'gdi32.dll'>
	^self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'TBn 6/15/2000 21:14'!
apiRoundRect: aHDC with: left with: top with: right with: bottom with: width with: height
	"Draws a rectangle with rounded corners. The rectangle is outlined by  
	using the current pen and filled by using the current brush"
	<apicall: bool 'RoundRect' (Win32HDC long long long long long long) module: 'gdi32.dll'>
	^ self externalCallFailed! !

!Win32HDC methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:04'!
apiSelectObject: aHDC with: aHGDIOBJ
	<apicall: Win32HGDIObj 'SelectObject' (Win32HDC Win32HGDIObj) module: 'gdi32.dll'>
	^self externalCallFailed! !
Win32Handle subclass: #Win32HGDIObj
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

!Win32HGDIObj methodsFor: 'initialize-release' stamp: 'ar 12/2/1999 18:20'!
delete
	self apiDeleteObject: self! !


!Win32HGDIObj methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:07'!
apiDeleteObject: aHGDIOBJ
	<apicall: bool 'DeleteObject' (Win32HGDIObj) module: 'gdi32.dll'>
	^self externalCallFailed! !
ExternalStructure subclass: #Win32Handle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Win32Handle class
	instanceVariableNames: ''!

!Win32Handle class methodsFor: 'accessing' stamp: 'ar 1/27/2000 01:07'!
fields
	"Win32Handle defineFields"
	"The following really means
		typedef void* Win32Handle;
	"
	^#(nil	'void*') "an opaque 32bit handle"! !
ExternalStructure subclass: #Win32Point
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

!Win32Point methodsFor: 'accessing' stamp: 'ar 12/2/1999 23:14'!
x
	"This method was automatically generated"
	^handle signedLongAt: 1! !

!Win32Point methodsFor: 'accessing' stamp: 'ar 12/2/1999 23:14'!
x: anObject
	"This method was automatically generated"
	handle signedLongAt: 1 put: anObject! !

!Win32Point methodsFor: 'accessing' stamp: 'ar 12/2/1999 23:14'!
y
	"This method was automatically generated"
	^handle signedLongAt: 5! !

!Win32Point methodsFor: 'accessing' stamp: 'ar 12/2/1999 23:14'!
y: anObject
	"This method was automatically generated"
	handle signedLongAt: 5 put: anObject! !


!Win32Point methodsFor: 'converting' stamp: 'ar 11/21/1999 18:48'!
asPoint
	^self x @ self y! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Win32Point class
	instanceVariableNames: ''!

!Win32Point class methodsFor: 'accessing' stamp: 'ar 12/2/1999 23:14'!
fields
	"POINT defineFields"
	^#(
		(x 'long')
		(y 'long')
	)! !


!Win32Point class methodsFor: 'instance creation' stamp: 'ar 12/2/1999 18:23'!
getCursorPos
	| pt |
	pt _ self new.
	self apiGetCursorPos: pt.
	^pt! !


!Win32Point class methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:08'!
apiGetCursorPos: pt
	<apicall: bool 'GetCursorPos' (Win32Point*) module: 'user32.dll'>
	^self externalCallFailed! !
ExternalStructure subclass: #Win32Rectangle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
bottom
	"This method was automatically generated"
	^handle signedLongAt: 13! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
bottom: anObject
	"This method was automatically generated"
	handle signedLongAt: 13 put: anObject! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
left
	"This method was automatically generated"
	^handle signedLongAt: 1! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
left: anObject
	"This method was automatically generated"
	handle signedLongAt: 1 put: anObject! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'TBn 6/15/2000 19:48'!
left: left top: top right: right bottom: bottom
	"sets the coordinates of the receiver"

	self left: left.
	self top: top.
	self right: right.
	self bottom: bottom ! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
right
	"This method was automatically generated"
	^handle signedLongAt: 9! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
right: anObject
	"This method was automatically generated"
	handle signedLongAt: 9 put: anObject! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
top
	"This method was automatically generated"
	^handle signedLongAt: 5! !

!Win32Rectangle methodsFor: 'accessing' stamp: 'sma 6/25/2000 17:07'!
top: anObject
	"This method was automatically generated"
	handle signedLongAt: 5 put: anObject! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Win32Rectangle class
	instanceVariableNames: ''!

!Win32Rectangle class methodsFor: 'accessing' stamp: 'TBn 6/15/2000 19:44'!
fields
	"Win32Rectangle defineFields"
	^ #(#(#left 'long') #(#top 'long') #(#right 'long') #(#bottom 'long') )! !


!Win32Rectangle class methodsFor: 'instance creation' stamp: 'TBn 6/15/2000 19:49'!
fromRectangle: rc 
	"returns an instance of the receiver from the given smalltalk rectangle"
	^ self new left: rc left top: rc top right: rc right bottom: rc bottom  ! !
ExternalObject subclass: #Win32Shell
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!
!Win32Shell commentStamp: '<historical>' prior: 0!
This class wrappes the Windows 32 shell.

Try 
	Win32Shell new shellOpen: 'c:\image.bmp' 		to open a document
	Win32Shell new shellOpen: 'c:\myprogram.exe' 	to start an executable
	Win32Shell new shellExplore: 'c:\'				to explore a directory
	Win32Shell new shellFind: 'c:\' 					to initiate a search

Note that this class is platform specific.
 
 !


!Win32Shell methodsFor: 'operations' stamp: 'TBn 6/14/2000 09:39'!
shellExplore: aPathString
	"Explores the folder specified by aPathString"

	(self shellExecute: nil 
		lpOperation: 'explore'
		lpFile: aPathString
		lpParameters: nil
		lpDirectory: nil
		nShowCmd: 1) <= 32 ifTrue: [self error: 'system error']! !

!Win32Shell methodsFor: 'operations' stamp: 'TBn 6/14/2000 09:59'!
shellFind: aPathString
	"Initiates a search starting from the specified directory."

	(self shellExecute: nil 
		lpOperation: 'find'
		lpFile: nil
		lpParameters: nil
		lpDirectory: aPathString
		nShowCmd: 1) <= 32 ifTrue: [self error: 'system error']! !

!Win32Shell methodsFor: 'operations' stamp: 'TBn 6/14/2000 09:37'!
shellOpen: aFileString
	"Opens the file specified by aFileString. The file can be an executable file, a document file, 
	 or a folder."

	(self shellExecute: nil 
		lpOperation: 'open'
		lpFile: aFileString
		lpParameters: nil
		lpDirectory: nil
		nShowCmd: 1) <= 32 ifTrue: [self error: 'system error']! !


!Win32Shell methodsFor: 'api calls' stamp: 'sma 6/14/2000 20:17'!
shellExecute: hwnd lpOperation: opString lpFile: fileString lpParameters: parmString lpDirectory: dirString nShowCmd: anInteger
	"Opens or prints the specified file, which can be an executable or document file.
		HINSTANCE ShellExecute(
	  		HWND hwnd,			// handle to parent window
			LPCTSTR lpOperation,	// pointer to string that specifies operation to perform
			LPCTSTR lpFile,		// pointer to filename or folder name string
			LPCTSTR lpParameters,	// pointer to string that specifies executable-file parameters 
			LPCTSTR lpDirectory,	// pointer to string that specifies default directory
			INT nShowCmd 			// whether file is shown when opened
		);"
	<apicall: long 'ShellExecuteA' (long char* char* char* char* ulong) module:'shell32.dll'>! !
Win32Handle subclass: #Win32Window
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-Win32'!
!Win32Window commentStamp: '<historical>' prior: 0!
Here's a simple Win32 example:
	| hwnd dc dst |
	hwnd _ Win32Window getFocus. "fetch the window currently having the focus"
	dc _ hwnd getDC. "grab the dc or the window"
	dst _ 100.
	dc moveTo: 0@0.
	"draw a rect"
	dc lineTo: dst@0. dc lineTo: dst@dst. dc lineTo: 0@dst. dc lineTo: 0@0.
	"and a cross"
	dc lineTo: dst@dst. dc moveTo: dst@0. dc lineTo: 0@dst.
	hwnd releaseDC: dc.!


!Win32Window methodsFor: 'accessing' stamp: 'ar 12/2/1999 18:21'!
getDC
	"Return the DC associated with the window"
	^self apiGetDC: self! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 1/28/2000 19:40'!
getHDCDuring: aBlock
	"Provide a Win32 HDC during the execution of aBlock"
	| hDC |
	hDC _ self getDC.
	[aBlock value: hDC] ensure:[self releaseDC: hDC].! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 1/27/2000 01:12'!
messageBox: aString
	"Win32Window getFocus messageBox:'Hello World'"
	^self messageBox: aString title:'Squeak'! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 1/27/2000 01:13'!
messageBox: aString title: aTitle
	"Win32Window getFocus messageBox:'Hello World' title:'News from Squeak:'"
	^self messageBox: aString title: aTitle flags: 0! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 1/27/2000 01:13'!
messageBox: aString title: aTitle flags: flags
	"Win32Window getFocus messageBox:'Are you ready???' title:'News from Squeak:' flags: 3"
	^self apiMessageBox: self text: aString title: aTitle flags: flags! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 12/2/1999 18:21'!
releaseDC: aHDC
	"Release the given DC"
	self apiReleaseDC: self with: aHDC! !

!Win32Window methodsFor: 'accessing' stamp: 'ar 12/2/1999 18:21'!
screenToClient: aPoint
	self apiScreenToClient: self with: aPoint.
	^aPoint! !


!Win32Window methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:09'!
apiGetDC: aHWND
	<apicall: Win32HDC 'GetDC' (Win32Window) module: 'user32.dll'>
	^self externalCallFailed! !

!Win32Window methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:09'!
apiMessageBox: aHWND text: aString title: aTitle flags: flags
	<apicall: long 'MessageBoxA' (Win32Window char* char* ulong) module:'user32.dll'>
	^self externalCallFailed! !

!Win32Window methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:09'!
apiReleaseDC: aHWND with: aHDC
	<apicall: long 'ReleaseDC' (Win32Window Win32HDC) module:'user32.dll'>
	^self externalCallFailed! !

!Win32Window methodsFor: 'api calls' stamp: 'ar 1/25/2000 17:10'!
apiScreenToClient: aHWND with: aPOINT
	<apicall: bool 'ScreenToClient' (Win32Window Win32Point*) module: 'user32.dll'>
	^self externalCallFailed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Win32Window class
	instanceVariableNames: ''!

!Win32Window class methodsFor: 'accessing' stamp: 'ar 1/25/2000 17:10'!
getDesktopWindow
	"Return the HWND describing the desktop"
	<apicall: Win32Window 'GetDesktopWindow' (void) module: 'user32.dll'>
	^self externalCallFailed! !

!Win32Window class methodsFor: 'accessing' stamp: 'ar 1/25/2000 17:10'!
getFocus
	"Return the HWND currently having the input focus"
	<apicall: Win32Window 'GetFocus' (void) module: 'user32.dll'>
	^self externalCallFailed! !


!Win32Window class methodsFor: 'examples' stamp: 'ar 1/28/2000 19:41'!
coloredEllipses "Win32Window coloredEllipses"
	"Draw a bunch of ellipses"
	| rnd pt1 pt2 w h colors newBrush oldBrush |
	colors _ Color colorNames collect:[:cName| (Color perform: cName)].
	"convert to COLORREF"
	colors _ colors collect:[:c| 
		(c red * 255) asInteger + 
			((c green * 255) asInteger << 8) + 
				((c blue * 255) asInteger << 16)].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	self getFocus getHDCDuring:[:hDC|
		[Sensor anyButtonPressed] whileFalse:[
			newBrush _ Win32HBrush createSolidBrush: colors atRandom.
			oldBrush _ hDC selectObject: newBrush.
			pt1 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
			pt2 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
			hDC ellipse: (Rectangle encompassing: (Array with: pt1 with: pt2)).
			hDC selectObject: oldBrush.
			newBrush delete.
		].
	].
	Display forceToScreen.! !

!Win32Window class methodsFor: 'examples' stamp: 'ar 1/28/2000 19:41'!
coloredRectangles "Win32Window coloredRectangles"
	"Draw a bunch of ellipses"
	| rnd pt1 pt2 w h colors newBrush oldBrush n nPixels time r |
	colors _ Color colorNames collect:[:cName| (Color perform: cName)].
	"convert to COLORREF"
	colors _ colors collect:[:c| 
		(c red * 255) asInteger + 
			((c green * 255) asInteger << 8) + 
				((c blue * 255) asInteger << 16)].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	self getFocus getHDCDuring:[:hDC|
		n _ 0.
		nPixels _ 0.
		time _ Time millisecondClockValue.
		[Sensor anyButtonPressed] whileFalse:[
			newBrush _ Win32HBrush createSolidBrush: colors atRandom.
			oldBrush _ hDC selectObject: newBrush.
			pt1 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
			pt2 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
			hDC rectangle: (r _ Rectangle encompassing: (Array with: pt1 with: pt2)).
			hDC selectObject: oldBrush.
			newBrush delete.
			n _ n + 1.
			nPixels _ nPixels + ((r right - r left) * (r bottom - r top)).
			(n \\ 100) = 0 ifTrue:[
				'Pixel fillRate: ', (nPixels * 1000 // (Time millisecondClockValue - time))
					asStringWithCommas displayAt: 0@0].
		].
	].
	Display forceToScreen.! !

!Win32Window class methodsFor: 'examples' stamp: 'ar 1/28/2000 17:49'!
win32Draw "Win32Window win32Draw"
	"Draw a bunch of lines using the Windows API"
	| hWnd hDC pt |
	hWnd _ Win32Window getFocus.
	hDC _ hWnd getDC.
	hDC moveTo: (hWnd screenToClient: Win32Point getCursorPos).
	[Sensor anyButtonPressed] whileFalse:[
		pt _ Win32Point getCursorPos.
		hWnd screenToClient: pt.
		hDC lineTo: pt.
	].
	hWnd releaseDC: hDC.
	Display forceToScreen.! !
Object subclass: #WindowingTransformation
	instanceVariableNames: 'scale translation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Framework'!
!WindowingTransformation commentStamp: '<historical>' prior: 0!
My instances are used to transform objects from a source coordinate system to a destination coordinate system. Each instance contains a scale and a translation which can be applied to objects that respond to scaleBy: and translateBy:. It can be created with a default identity scale and translation, or with a specified scale and translation, or with a scale and translation computed from a window (a Rectangle in the source coordinate system) and a viewport (a Rectangle in the destination coordinate system). In applying a WindowingTransformation to an object, the object is first scaled (around the origin of the source coordinate system) and then translated. WindowingTransformations can be composed to form a single compound transformation.!


!WindowingTransformation methodsFor: 'scrolling'!
scrollBy: aPoint 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of the current translation plus aPoint scaled by 
	the current scale. It is used when the translation is known in source 
	coordinates, rather than scaled source coordinates (see 
	WindowingTransformation|translateBy:). An example is that of scrolling 
	objects with respect to a stationary window in the source coordinate 
	system. If no scaling is in effect (scale = nil), then 
	WindowingTransformation|translateBy: and 
	WindowingTransformation|scrollBy: are equivalent."

	| newTranslation |
	scale == nil
		ifTrue: [newTranslation _ aPoint]
		ifFalse: [newTranslation _ scale * aPoint].
	^self translateBy: newTranslation! !


!WindowingTransformation methodsFor: 'transforming'!
align: point1 with: point2 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of (aPoint2 - aPoint1). It is normally used when 
	the source and destination coordinate systems are scaled the same (that 
	is, there is no scaling between them), and is then a convenient way of 
	specifying a translation, given two points that are intended to coincide."

	^self translateBy: point2 - point1! !

!WindowingTransformation methodsFor: 'transforming'!
noScale
	"Answer true if the identity scale is in effect; answer false, otherwise."

	^scale == nil! !

!WindowingTransformation methodsFor: 'transforming'!
scale
	"Answer a copy of the point that represents the current scale of the 
	receiver."

	scale == nil
		ifTrue: [^1.0 @ 1.0]
		ifFalse: [^scale copy]! !

!WindowingTransformation methodsFor: 'transforming'!
scaleBy: aScale 
	"Answer a WindowingTransformation with the scale and translation of 
	the receiver both scaled by aScale."

	| checkedScale newScale newTranslation |
	aScale == nil
		ifTrue: 
			[newScale _ scale.
			newTranslation _ translation]
		ifFalse: 
			[checkedScale _ self checkScale: aScale.
			scale == nil
				ifTrue: [newScale _ checkedScale]
				ifFalse: [newScale _ scale * checkedScale].
			newTranslation _ checkedScale * translation].
	^WindowingTransformation scale: newScale translation: newTranslation! !

!WindowingTransformation methodsFor: 'transforming'!
translateBy: aPoint 
	"Answer a WindowingTransformation with the same scale as the receiver 
	and with a translation of the current translation plus aPoint. It is used 
	when the translation is known in scaled source coordinates, rather than 
	source coordinates (see WindowingTransformation|scrollBy:). If no scaling 
	is in effect (scale = nil), then WindowingTransformation|translateBy: and 
	WindowingTransformation|scrollBy: are equivalent."

	^WindowingTransformation scale: scale translation: translation + aPoint! !

!WindowingTransformation methodsFor: 'transforming'!
translation
	"Answer a copy of the receiver's translation."

	^translation copy! !


!WindowingTransformation methodsFor: 'applying transform'!
applyInverseTo: anObject 
	"Apply the inverse of the receiver to anObject and answer the result. 
	Used to map some object in destination coordinates to one in source 
	coordinates."

	| transformedObject |
	transformedObject _ anObject translateBy: translation x negated @ translation y negated.
	scale == nil
		ifFalse: [transformedObject _ transformedObject scaleBy: 1.0 / scale x @ (1.0 / scale y)].
	^transformedObject! !

!WindowingTransformation methodsFor: 'applying transform'!
applyTo: anObject 
	"Apply the receiver to anObject and answer the result. Used to map some 
	object in source coordinates to one in destination coordinates."

	| transformedObject |
	scale == nil
		ifTrue: [transformedObject _ anObject]
		ifFalse: [transformedObject _ anObject scaleBy: scale].
	transformedObject _ transformedObject translateBy: translation.
	^transformedObject! !

!WindowingTransformation methodsFor: 'applying transform'!
compose: aTransformation 
	"Answer a WindowingTransformation that is the composition of the 
	receiver and aTransformation. The effect of applying the resulting 
	WindowingTransformation to an object is the same as that of first 
	applying aTransformation to the object and then applying the receiver to 
	its result."

	| aTransformationScale newScale newTranslation |
	aTransformationScale _ aTransformation scale.
	scale == nil
		ifTrue: 
			[aTransformation noScale
				ifTrue: [newScale _ nil]
				ifFalse: [newScale _ aTransformationScale].
			newTranslation _ translation + aTransformation translation]
		ifFalse: 
			[aTransformation noScale
				ifTrue: [newScale _ scale]
				ifFalse: [newScale _ scale * aTransformationScale].
			newTranslation _ translation + (scale * aTransformation translation)].
	^WindowingTransformation scale: newScale translation: newTranslation! !


!WindowingTransformation methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: self class name, ' scale: ';
		print: scale; nextPutAll: ' translation: ';
		print: translation! !


!WindowingTransformation methodsFor: 'private'!
checkScale: aScale
	"Convert aScale to the internal format of a floating-point Point."

 	| checkedScale |
	checkedScale _ aScale asPoint.
	^checkedScale x asFloat @ checkedScale y asFloat! !

!WindowingTransformation methodsFor: 'private'!
setScale: aScale translation: aTranslation 
	"Sets the scale to aScale and the translation to aTranslation."

	scale _ aScale.
	translation _ aTranslation! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WindowingTransformation class
	instanceVariableNames: ''!

!WindowingTransformation class methodsFor: 'instance creation'!
identity
	"Answer an instance of me with no scaling (nil) and no translation 
	(0@0)."

	^self new setScale: nil translation: 0 @ 0! !

!WindowingTransformation class methodsFor: 'instance creation'!
scale: aScale translation: aTranslation 
	"Answer an instance of me with a scale factor of aScale and a translation 
	offset of aTranslation. When the transformation is applied (see 
	WindowingTransformation|apply:), the scale is applied first, followed by 
	the translation."

	^self new setScale: aScale translation: aTranslation! !

!WindowingTransformation class methodsFor: 'instance creation'!
window: aWindow viewport: aViewport 
	"Answer an instance of me with a scale and translation based on 
	aWindow and aViewport. The scale and translation are computed such 
	that aWindow, when transformed, coincides with aViewport."

	| scale translation |
	aViewport width = aWindow width & (aViewport height = aWindow height)
		ifTrue:
			[scale _ nil]
		ifFalse:
			[scale _ aViewport width asFloat / aWindow width asFloat
						@ (aViewport height asFloat / aWindow height asFloat)].
	scale == nil
		ifTrue: [translation _ aViewport left - aWindow left
								@ (aViewport top - aWindow top)]
		ifFalse: [translation _ aViewport left - (scale x * aWindow left)
								@ (aViewport top - (scale y * aWindow top))].
	^self new setScale: scale translation: translation! !
PolygonMorph subclass: #WireMorph
	instanceVariableNames: 'pins '
	classVariableNames: 'InputPinForm IoPinForm OutputPinForm '
	poolDictionaries: ''
	category: 'Morphic-Components'!

!WireMorph methodsFor: 'as yet unclassified' stamp: 'ar 10/5/2000 17:30'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

	super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
	aMenu add: 'delete' target: self action: #dismissMorph:! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 22:49'!
addHandles
	super addHandles.
	"Don't show endpoint handles"
	handles first delete.
	handles last delete! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/4/1998 00:12'!
delete
	pins do: [:p | p removeWire: self].
	pins first isIsolated 
		ifTrue: [pins first removeVariableAccess.
				pins second isIsolated
					ifTrue: [pins second removeModelVariable]]
		ifFalse: [pins second isIsolated
					ifTrue: [pins second removeVariableAccess]
					ifFalse: [pins second addModelVariable]].
	super delete! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/2/1998 16:05'!
fromPin: pin1 toPin: pin2
	pins _ Array with: pin1 with: pin2! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 22:35'!
handlesMouseDown: evt
	^ evt buttons noMask: 16r78  "ie no modifier keys pressed"! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 23:01'!
mouseUp: evt
	handles == nil
		ifTrue: [self addHandles]
		ifFalse: [self removeHandles]! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/2/1998 15:17'!
otherPinFrom: aPin
	(pins at: 1) = aPin
		ifTrue: [^ pins at: 2]
		ifFalse: [^ pins at: 1]! !

!WireMorph methodsFor: 'as yet unclassified' stamp: 'di 5/6/1998 14:22'!
pinMoved
	| newVerts |
	newVerts _ vertices copy.
	newVerts at: 1 put: pins first wiringEndPoint.
	newVerts at: newVerts size put: pins last wiringEndPoint.
	self setVertices: newVerts! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WireMorph class
	instanceVariableNames: ''!

!WireMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/3/1998 10:09'!
includeInNewMorphMenu
	^ false! !
Object subclass: #Wonderland
	instanceVariableNames: 'myScheduler myNamespace sharedMeshDict sharedTextureDict myUndoStack defaultCamera cameraList lightList sceneObject scriptEditor actorClassList '
	classVariableNames: 'ActorPrototypeClasses '
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Core'!
!Wonderland commentStamp: '<historical>' prior: 0!
What is Squeak-Alice?

Alice (http://www.alice.org) is an authoring tool designed to allow people without programming experience to build interactive 3D worlds. The Stage 3 Research Group (Randy Pausch director) started the Alice project at the University of Virginia, and is continuing their work at Carnegie Mellon University (http://www.cs.cmu.edu/~stage). Squeak-Alice brings the ideas and the ideals of Alice to Squeak, with the goal of introducing even more people to 3D graphics and allowing them to author in the medium.

Wonderlands are the basic building blocks of Squeak-Alice; a Wonderland is an interactive 3D world.

To create a Wonderland, evaluate:

Wonderland new

This creates a script editor, a control panel, and a window into the 3D world. From here you're ready to start building your world.

Jeff Pierce
jpierce@cs.cmu.edu
!


!Wonderland methodsFor: 'initialize-reset-release' stamp: 'jsp 7/8/1999 23:33'!
initialize
	"This method initializes the Wonderland."

	| ground |

	"Initialize the list of actor UniClasses"
	actorClassList _ OrderedCollection new.

	"Initialize the shared mesh and texture directories"
	sharedMeshDict _ Dictionary new.
	sharedTextureDict _ Dictionary new.

	"Initialize this Wonderland's shared namespace"
	myNamespace _ WonderlandConstants copy.

	"Create the Wonderland's scheduler"
	myScheduler _ Scheduler new.
	myNamespace at: 'scheduler' put: myScheduler.

	"Create the undo stack for this Wonderland."
	myUndoStack _ WonderlandUndoStack new.

	"The scene object is the root of the object tree - all objects in the Wonderland are children (directly or indirectly) of the scene. "
	sceneObject _ WonderlandScene newFor: self.
	myNamespace at: 'scene' put: sceneObject.

	"Create a script editor for this Wonderland"
	self makeScriptEditor.

	"Create some default objects"
	ground _ self makeActor.
	ground setMesh: (WonderlandConstants at: 'groundMesh').
	ground setTexturePointer: (WonderlandConstants at: 'groundTexture').
	ground becomePart.
	ground setColor: {0.2902. 0.8000. 0.0000} duration: rightNow.
	ground setName: 'ground'.
	myNamespace at: 'ground' put: ground.

	"Initialize the light list and create a default light"
	lightList _ OrderedCollection new.
	self makeLight.
	lightList last moveTo: {0. 2. 0} duration: rightNow.
	
	"Create the default camera"
	cameraList _ OrderedCollection new.
	defaultCamera _ self makeCamera.

	"Clean out the Undo stack - we don't want people undoing the init stuff"
	myUndoStack reset.

	"Throw this Wonderland into the shared namespace"
	myNamespace at: 'w' put: self.

! !

!Wonderland methodsFor: 'initialize-reset-release' stamp: 'ar 11/5/2000 16:58'!
objectForDataStream: refStrm
	self prepareToBeSaved.		"Amen"
	^ self
! !

!Wonderland methodsFor: 'initialize-reset-release' stamp: 'ar 11/5/2000 16:58'!
prepareToBeSaved
	"We are about to be written out. Release everything we don't want to carry around"
	myUndoStack reset.
	sharedMeshDict _ Dictionary new.
	sharedTextureDict _ Dictionary new.
! !

!Wonderland methodsFor: 'initialize-reset-release' stamp: 'di 3/10/2000 08:30'!
rectifyActorClassList  "Wonderland allInstancesDo: [:w | w rectifyActorClassList]"
	"Attempt to restore the actorClassList by replacing obsolete classes by current classes of the same name"

	actorClassList _ actorClassList collect:
		[:obs |
		(obs name beginsWith: 'AnObsolete')
			ifTrue: [obs nonObsoleteClass]
			ifFalse: [obs]]! !

!Wonderland methodsFor: 'initialize-reset-release' stamp: 'jsp 4/23/1999 12:11'!
release
	"This method cleans up the Wonderland."

	cameraList do: [:camera | camera release].

	scriptEditor delete.

	"Clean up any uniclasses we created"
	actorClassList do: [:aClass | aClass removeFromSystem ].
! !

!Wonderland methodsFor: 'initialize-reset-release' stamp: 'jsp 7/9/1999 15:01'!
reset
	"Reset this Wonderland"

	| ground |

	"Reset the scheduler"
	myScheduler reset.

	"Reset the shared mesh and texture directories"
	sharedMeshDict _ Dictionary new.
	sharedTextureDict _ Dictionary new.

	"Reset the list of actor uniclasses"
	actorClassList do: [:aClass | aClass removeFromSystem ].
	actorClassList _ OrderedCollection new.

	"Initialize this Wonderland's shared namespace"
	myNamespace _ WonderlandConstants copy.

	"Rebuild the namespace"
	myNamespace at: 'scheduler' put: myScheduler.
	myNamespace at: 'w' put: self.

	"Create a new scene"
	sceneObject _ WonderlandScene newFor: self.
	myNamespace at: 'scene' put: sceneObject.

	"Recreate the default objects"
	ground _ self makeActor.
	ground setMesh: (WonderlandConstants at: 'groundMesh').
	ground setTexturePointer: (WonderlandConstants at: 'groundTexture').
	ground becomePart.
	ground setName: 'ground'.
	ground setColor: {0.2902. 0.8000. 0.0000} duration: rightNow.
	myNamespace at: 'ground' put: ground.

	"Re-initialize the light list and create a default light"
	lightList _ OrderedCollection new.
	self makeLight.
	lightList last moveTo: {0. 2. 0} duration: rightNow.

	"Wipe out the existing cameras"
	cameraList do: [:camera | camera release].
	
	"Recreate the default camera"
	cameraList _ OrderedCollection new.
	defaultCamera _ self makeCamera.

	"Reset the script editor's namespace"
	scriptEditor resetNamespace.

	"Update the actor browser"
	scriptEditor updateActorBrowser.

	"Reset the undo stack"
	myUndoStack reset.


! !


!Wonderland methodsFor: 'composite animations' stamp: 'jsp 2/14/1999 18:14'!
doInOrder: animations
	"Create a new SequentialAnimation instance and pass it the child animations that make it up."

	| newSA |
	newSA _ SequentialAnimation new.

	newSA children: animations undoable: true inWonderland: self.

	^ newSA.
! !

!Wonderland methodsFor: 'composite animations' stamp: 'jsp 2/14/1999 18:14'!
doTogether: animations
	"Create a new ParallelAnimation instance and pass it the child animations that make it up."

	| newPA |
	newPA _ ParallelAnimation new.

	newPA children: animations undoable: true inWonderland: self.

	^ newPA.
! !


!Wonderland methodsFor: 'accessing' stamp: 'jsp 4/8/1999 15:58'!
getActorClassList
	"Return the list of actor classes"

	^ actorClassList.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 4/9/1999 15:34'!
getCameraList

	^ cameraList.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 2/5/1999 16:30'!
getDefaultCamera
	"Returns a handle on the Wonderland's default camera."

	^ defaultCamera.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 4/1/1999 17:36'!
getEditor
	"Return the editor for this wonderland"

	^ scriptEditor.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 3/10/1999 16:41'!
getLights
	"Return the list of lights in the Wonderland"

	^ lightList.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 4/1/1999 16:17'!
getNamespace
	"Return the dictionary that comprises this Wonderland's namespace"

	^ myNamespace.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 2/8/1999 17:04'!
getScene
	"Returns the current scene object."

	^ sceneObject.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 2/4/1999 17:18'!
getScheduler
	"Returns the Wonderland's scheduler."

	^ myScheduler.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 3/10/1999 15:54'!
getSharedMeshDict
	"Return the shared mesh dictionary"

	^ sharedMeshDict.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 3/10/1999 15:54'!
getSharedTextureDict
	"Return the shared texture dictionary"

	^ sharedTextureDict.
! !

!Wonderland methodsFor: 'accessing' stamp: 'jsp 2/15/1999 10:23'!
getUndoStack
	"Returns the Wonderland's undo stack."

	^ myUndoStack.
! !


!Wonderland methodsFor: 'drawing' stamp: 'jsp 2/8/1999 15:40'!
renderWonderland: aRenderer
	"Tell all the objects in the Wonderland to render themselves."

	sceneObject renderOn: aRenderer.

! !


!Wonderland methodsFor: 'undo' stamp: 'jsp 2/14/1999 18:43'!
undo
	"Undo the last action the user performed in the Wonderland.  This pulls a block context off the animation stack and executes it."

	myUndoStack popAndUndo.

	! !


!Wonderland methodsFor: 'creating' stamp: 'ar 4/24/1999 04:48'!
createHierarchyFrom3DS: globals
	| keyframes objects hierarchy name parentID parentName parent |
	hierarchy _ Dictionary new.
	keyframes _ globals at: #keyframes ifAbsent:[^hierarchy].
	objects _ keyframes at: #objects ifAbsent:[^hierarchy].
	objects do:[:obj|
		name _ obj at: #name.
		parentID _ obj at: #hierarchy.
		parent _ objects at: parentID ifAbsent:[nil].
		parent == nil ifFalse:[
			parentName _ parent at: #name.
			name = parentName
				ifFalse:[hierarchy at: name put: parentName]].
	].
	^hierarchy! !

!Wonderland methodsFor: 'creating' stamp: 'ar 5/27/1999 16:17'!
createSimpleActor: aMesh named: aString parent: parentActor
	| newActor |
	newActor _ self makeActorNamed: aString.
	aMesh ifNotNil:[newActor setMesh: aMesh].
	parentActor ifNotNil:[
		newActor reparentTo: parentActor.
		newActor becomePart].
	^newActor! !

!Wonderland methodsFor: 'creating' stamp: 'ar 11/10/1999 15:34'!
duplicateActor: anActor
	"Creates a new actor without any geometry"
	| newActor |
	newActor _ anActor clone postCopy.
	anActor getParent == nil ifFalse:[
		anActor getParent addChild: newActor.
		newActor setParent: anActor getParent].
	newActor setName: anActor getName,'2'.
	scriptEditor updateActorBrowser.

	"Add an undo item to undo the creation of this object"
	myUndoStack push: (UndoAction new: [ newActor removeFromScene.
						 					scriptEditor updateActorBrowser. ]).

	^ newActor.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 4/24/1999 05:39'!
fixNameFrom: aString
	"Fix the name to be a valid Smalltalk name (e.g., so that we can compile it as an inst var and accessor message)"

	| aName |
	aName _ aString select:[:c| c isAlphaNumeric].
	aName isEmpty ifTrue:[aName _ 'unkwown'].
	aName first isUppercase ifTrue:[aName _ aName first asLowercase asString, (aName copyFrom: 2 to: aName size)].
	aName first isLetter ifFalse:[aName _ 'a', aName].
	^aName! !

!Wonderland methodsFor: 'creating' stamp: 'jsp 7/8/1999 23:26'!
makeActor
	"Creates a new actor without any geometry"

	^ self makeActorNamed: 'unnamed'.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 19:43'!
makeActorFrom3DS: filename
	"Creates a new actor using the specification from the given file"

	| parent name baseActor newActor actorClass scene globals hierarchy meshSize materials material textureName cameras newCamera |

	myUndoStack closeStack.

	scene _ ThreeDSParser parseFileNamed: filename.
	scene ifNil:[^nil].
	globals _ scene at: #globals.
	materials _ globals at: #materials ifAbsent:[Dictionary new].
	"The remaining objects are the actual named meshes,"
	scene removeKey: #globals.
	hierarchy _ self createHierarchyFrom3DS: globals.

	baseActor _ self makeBaseActorFrom: filename.

	"Now create the actors"
	scene associationsDo:[:assoc|
		name _ assoc key.
		actorClass _ WonderlandActor newUniqueClassInstVars: '' classInstVars: ''.
		newActor _ actorClass createFor: self.
		actorClassList addLast: actorClass.
		newActor setName: (self fixNameFrom: name).
		"newActor setTexture: texture."
		newActor setMesh: (B3DSTriangleMesh from3DS: assoc value).
		material _ materials at: (assoc value at: #triList) last ifAbsent:[nil].
		(material isKindOf: Association) ifTrue:[
			"Note: In this case the name of the texture is the key"
			textureName _ material key.
			material _ material value].
		newActor setMaterial: material.
		"newActor setComposite: matrix."
		assoc value: newActor.
	].

	"Create hierarchy"
	scene associationsDo:[:assoc|
		name _ assoc key.
		newActor _ assoc value.
		newActor setName: (self uniqueNameFrom: name).
		parent _ hierarchy at: name ifAbsent:[nil].
		parent == nil ifFalse:[parent _ scene at: parent ifAbsent:[nil]].
		parent == nil ifTrue:[parent _ baseActor].
		newActor reparentTo: parent.
		newActor becomePart.
	].

	"Create the cameras"
	cameras _ globals at: #cameras.
	cameras associationsDo:[:assoc|
		name _ assoc key.
		newCamera _ WonderlandCamera createFor: self.
		newCamera setName: (self fixNameFrom: name).
		newCamera copySettingsFrom: assoc value.
		newCamera reparentTo: baseActor.
		newCamera becomePart.
	].

	meshSize _ baseActor getBoundingBox extent length.
	meshSize > 100.0 ifTrue:[
		(self inform:'This actor is huge!!
You should rescale it to a reasonable size.')].
	meshSize < 0.01 ifTrue:[
		self inform:'This actor is tiny!!
You should rescale it to a reasonable size.'].
		
	myUndoStack openStack.

	"Ensure that the new actor's name is unique"
	myNamespace at: baseActor getName put: baseActor.
	scriptEditor updateActorBrowser.

	"Add an undo item to undo the creation of this object"
	myUndoStack push: (UndoAction new: [ baseActor removeFromScene.
											myNamespace removeKey: baseActor getName ifAbsent: [].
											scriptEditor updateActorBrowser.  ] ).

	^ baseActor.
! !

!Wonderland methodsFor: 'creating' stamp: 'jsp 4/22/1999 14:57'!
makeActorFrom: filename
	"Creates a new actor using the specification from the given file"

	| aFile words line startSubstr index parent name texture meshFile matrix baseActor newActor protoClass actorClass fileVersion |

	myUndoStack closeStack.
	words _ (filename findTokens: #.).

	((words last) = 'mdl') ifTrue: [
			aFile _ (CrLfFileStream readOnlyFileNamed: filename) ascii.

			"First see if we need to create a prototype class for this model"
			(ActorPrototypeClasses includesKey: (aFile localName))
					ifTrue: [ protoClass _ ActorPrototypeClasses at: (aFile localName) ]
					ifFalse: [
							"Make a new prototype class for this model"
							protoClass _ (WonderlandActor newUniqueClassInstVars: ''
															classInstVars: '').
							ActorPrototypeClasses at: (aFile localName) put: protoClass.
							].

			"Check what version this mdl file is"
			line _ aFile upTo: (Character cr).
			line _ aFile upTo: (Character cr).
			line _ aFile upTo: (Character cr).

			((line truncateTo: 7) = 'version')
					ifTrue: [ fileVersion _ 1 ]
					ifFalse: [ fileVersion _ 0 ].

			[ line _ aFile upTo: (Character cr).
			  (aFile atEnd) ifTrue: [ true ]
			  			ifFalse: [ words _ line findTokens: '='.
								  false ]
			] whileFalse: [

					"See if we're creating a new object"
					(((words size) > 1) and: [ ((words at: 2) beginsWith: ' _MakeObject')
											or: [ (words at: 2) beginsWith: ' Alice.MakeObject' ] ])

						ifTrue: [
						(fileVersion = 0)
							ifTrue: [
								words _ line findTokens: #,.
								parent _ (words at: 2) withBlanksTrimmed.
								name _ (((words at: 3) withBlanksTrimmed)
													findBetweenSubStrs: '"') at: 1.
									]
							ifFalse: [
								name _ (words at: 1) truncateTo: (((words at: 1) size) - 1).
								parent _ ((words at: 3) findTokens: #,) at: 1.
									].

						"Now pull in the texture to use"
						startSubstr _ name , '.SetTexture'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						texture _ (line findBetweenSubStrs: '"') at: 2.
						texture _ (aFile directory pathName), FileDirectory slash, texture.

						"Read the composite matrix to use"
						startSubstr _ name , '._SetLocalTransformation'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						matrix _ B3DMatrix4x4 new.
						words _ line findBetweenSubStrs: ',()'.
						words removeAllSuchThat: [:str | str = ' '].

						index _ words size.
						4 to: 1 by: -1 do: [:i | 
							4 to: 1 by: -1 do: [:j | matrix at: i at: j put: 
										((words at: index) withBlanksTrimmed) asNumber.
										   		index _ index - 1. ]. ].

						1 to: 4 do: [:i | index _ matrix at: i at: 4.
									   matrix at: i at: 4 put: (matrix at: 4 at: i).
									   matrix at: 4 at: i put: index. ].

						matrix a14: (matrix a14 negated).

						"Read the mesh file to use"
						startSubstr _ 'LoadGeometry'.
						[(line _ aFile upTo: (Character cr)) beginsWith: startSubstr] whileFalse: [].

						meshFile _ (line findBetweenSubStrs: '"') at: 2.
						meshFile _ (aFile directory pathName), FileDirectory slash, meshFile.

						"Now build the actor name"
						words _ name findTokens: '.'.
						name _ words last.
						name at: 1 put: ((name at: 1) asLowercase).

						"Now build the parent name"
						parent _ parent copyReplaceAll: '.' with: ' '.

						"Now create the object"
						(parent = 'None') ifTrue: [
								actorClass _ protoClass newUniqueClassInstVars: '' classInstVars: ''.
								baseActor _ actorClass createFor: self.
								actorClassList addLast: actorClass.
								baseActor setName: name.
								baseActor setTexture: texture.
								baseActor loadMeshFromFile: meshFile.
								baseActor setComposite: matrix.
												]  "end base actor creation"

										ifFalse: [
								actorClass _ WonderlandActor newUniqueClassInstVars: ''
																classInstVars: ''.
								newActor _ actorClass createFor: self.
								actorClassList addLast: actorClass.
								newActor setName: name.
								parent _ (baseActor getChildNamed: parent).
								newActor reparentTo: parent.
								newActor becomePart.
								newActor setTexture: texture.
								newActor loadMeshFromFile: meshFile.
								newActor setComposite: matrix.
												]. "end new actor with parent"

															]. "end MakeObject parsing"

											]. "end file parsing"

			aFile close.
			myUndoStack openStack.

			"Ensure that the new actor's name is unique"
			name _ self uniqueNameFrom: (baseActor getName).
			baseActor setName: name.
			myNamespace at: name put: baseActor.
			scriptEditor updateActorBrowser.

			"Add an undo item to undo the creation of this object"
			myUndoStack push: (UndoAction new: [ baseActor removeFromScene.
													myNamespace removeKey: name ifAbsent: [].
													scriptEditor updateActorBrowser.  ] ).

			^ baseActor.
								]. " end mdl file parsing"
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 8/31/2000 18:40'!
makeActorFromVRML: filename
	"Creates a new actor using the specification from the given file"
	| baseActor parserClass builderClass scene |

	parserClass _ Smalltalk at: #VRMLNodeParser ifAbsent:[
		self reportErrorToUser:'No VRML parser found'.
		^self].
	builderClass _ Smalltalk at: #VRMLWonderlandBuilder ifAbsent:[
		self reportErrorToUser:'No VRML to Alice converter found'.
		^self].
	myUndoStack closeStack.
	baseActor _ self makeBaseActorFrom: filename.
	parserClass == nil
		ifFalse:[scene _ parserClass parseFileNamed: filename].
	(builderClass == nil or:[scene == nil])
		ifFalse:[(builderClass on: scene) 
					baseActor: baseActor;
					buildActorsFor: self].
	scene _ nil.
	myUndoStack openStack.

	"Ensure that the new actor's name is unique"
	myNamespace at: baseActor getName put: baseActor.
	scriptEditor updateActorBrowser.

	"Add an undo item to undo the creation of this object"
	myUndoStack push: (UndoAction new: [ baseActor removeFromScene.
											myNamespace removeKey: baseActor getName ifAbsent: [].
											scriptEditor updateActorBrowser.  ] ).

	^ baseActor.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 8/31/2000 17:15'!
makeActorFromVRML: filename named: actorName
	"Creates a new actor using the specification from the given file"
	| baseActor parserClass builderClass scene |

	parserClass _ Smalltalk at: #VRMLNodeParser ifAbsent:[
		self reportErrorToUser:'No VRML parser found'.
		^self].
	builderClass _ Smalltalk at: #VRMLWonderlandBuilder ifAbsent:[
		self reportErrorToUser:'No VRML to Alice converter found'.
		^self].
	myUndoStack closeStack.
	baseActor _ self makeBaseActorFrom: filename.
	baseActor setName: (self uniqueNameFrom: actorName).
	parserClass == nil
		ifFalse:[scene _ parserClass parseFileNamed: filename].
	(builderClass == nil or:[scene == nil])
		ifFalse:[(builderClass on: scene) 
					baseActor: baseActor;
					buildActorsFor: self].
	myUndoStack openStack.

	"Ensure that the new actor's name is unique"
	myNamespace at: baseActor getName put: baseActor.
	scriptEditor updateActorBrowser.

	"Add an undo item to undo the creation of this object"
	myUndoStack push: (UndoAction new: [ baseActor removeFromScene.
											myNamespace removeKey: baseActor getName ifAbsent: [].
											scriptEditor updateActorBrowser.  ] ).

	^ baseActor.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 5/27/1999 16:13'!
makeActorNamed: aString
	"Creates a new actor without any geometry"

	| newClass newActor name |

	newClass _ WonderlandActor newUniqueClassInstVars: '' classInstVars: ''.
	newActor _ (newClass createFor: self).
	actorClassList addLast: newClass.

	scriptEditor ifNotNil: [ 
				name _ self uniqueNameFrom: aString.
				newActor setName: name.
				myNamespace at: name put: newActor.
				scriptEditor updateActorBrowser.
						].

	"Add an undo item to undo the creation of this object"
	myUndoStack push: (UndoAction new: [ newActor removeFromScene.
											myNamespace removeKey: name ifAbsent: [].
						 					scriptEditor updateActorBrowser. ]).

	^ newActor.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 19:40'!
makeBaseActorFrom: filename
	| protoClass actorClass baseActor name |
	"First see if we need to create a prototype class for this model"
	protoClass _ self protoClassFor: filename.
	"Base actor creation"
	actorClass _ protoClass newUniqueClassInstVars: '' classInstVars: ''.
	baseActor _ actorClass createFor: self.
	actorClassList addLast: actorClass.
	name _ FileDirectory localNameFor: filename.
	(name findString: FileDirectory dot) = 0 ifFalse:[
		name _ name copyFrom: 1 to: (name findString: FileDirectory dot)-1].
	baseActor setName: (self uniqueNameFrom: name).
	^baseActor! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 23:40'!
makeCamera
	"Add a new camera to the Wonderland"
	^self makeCameraNamed:'camera'! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 23:40'!
makeCameraNamed: aString
	"Add a new camera to the Wonderland"
	| newClass newCamera name windowName |
	newClass _ WonderlandCamera newUniqueClassInstVars: '' classInstVars: ''.
	newCamera _ newClass createFor: self.
	actorClassList addLast: newClass.

	name _ self uniqueNameFrom: aString.
	newCamera setName: name.
	myNamespace at: name put: newCamera.

	windowName _ self uniqueNameFrom: aString,'Window'.
	myNamespace at: windowName put: (newCamera getMorph).

	cameraList addLast: newCamera.
	scriptEditor updateActorBrowser.

	"Add an undo action to remove this camera"
	myUndoStack push: (UndoAction new: [  cameraList remove: newCamera.
											newCamera removeFromScene.
											myNamespace removeKey: name ifAbsent: [].
											myNamespace removeKey: windowName.
											newCamera release.
											scriptEditor updateActorBrowser ]).

	^ newCamera.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 23:41'!
makeCameraNamed: aString parent: parentActor
	"Add a new camera to the Wonderland"
	| newCamera |
	newCamera _ self makeCameraNamed: aString.
	parentActor == nil ifFalse:[
		newCamera reparentTo: parentActor.
		newCamera becomePart].
	^newCamera! !

!Wonderland methodsFor: 'creating' stamp: 'jsp 4/29/1999 10:55'!
makeLight
	"Create a positional light and add it to the Wonderland"

	^ self makeLight: positional.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 8/19/1999 16:23'!
makeLight: lightType
	"Create a light of the specified type and add it to the Wonderland"
	^self makeLight: lightType named: nil! !

!Wonderland methodsFor: 'creating' stamp: 'ar 8/19/1999 16:23'!
makeLight: lightType named: aString
	"Create a light of the specified type and add it to the Wonderland"

	| newClass theLight name |

	"Make sure the user gave us a type of light"
	[ WonderlandVerifier VerifyLight: lightType ]
		ifError: [ :msg :rcvr |
			self reportErrorToUser:
				'Squeak could not determine the type of light to create because ', msg.
			^ nil ].

	"The user gave us a valid type type, so proceed"
	(lightType = ambient)
		ifTrue: [ newClass _ WonderlandAmbientLight newUniqueClassInstVars: ''
									classInstVars: ''.
					theLight _ newClass createFor: self. ]
		ifFalse: [ (lightType = positional)
			ifTrue: [ newClass _ WonderlandPositionalLight newUniqueClassInstVars: ''
										classInstVars: ''.
					theLight _ newClass createFor: self. ]
			ifFalse: [ (lightType = directional)
				ifTrue: [ newClass _ WonderlandDirectionalLight newUniqueClassInstVars: ''
										classInstVars: ''.
						theLight _ newClass createFor: self. ]
				ifFalse: [ newClass _ WonderlandSpotLight newUniqueClassInstVars: ''
										classInstVars: ''.
						theLight _ newClass createFor: self. ]
					]
				].

	actorClassList addLast: newClass.
	name _ self uniqueNameFrom: (aString ifNil:['light']).
	theLight setName: name.
	myNamespace at: name put: theLight.
	scriptEditor updateActorBrowser.

	lightList addLast: theLight.

	^ theLight.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 6/3/1999 12:35'!
makePlaneNamed: aString
	"Create a simple plane"
	| tex vertices faces mesh |
	tex _ B3DTexture2Array new: 4.
	tex at: 1 put: (0@0); at: 2 put: (1@0); at: 3 put: (1@1); at: 4 put: (0@1).
	vertices _ B3DVector3Array new: 4.
	vertices  at: 1 put: -1@1@-1; at: 2 put: 1@1@-1; at: 3 put: 1@-1@-1; at: 4 put: -1@-1@-1.
	vertices do:[:vtx| vtx *= 0.5].
	faces _ B3DIndexedTriangleArray new: 2.
	faces at: 1 put: (B3DIndexedTriangle with: 1 with: 2 with: 3).
	faces at: 2 put: (B3DIndexedTriangle with: 3 with: 4 with: 1).
	mesh _ B3DIndexedTriangleMesh new.
	mesh vertices: vertices.
	mesh faces: faces.
	mesh texCoords: tex.
	self createSimpleActor: mesh named: aString parent: nil.
! !

!Wonderland methodsFor: 'creating' stamp: 'jsp 4/1/1999 16:21'!
makeScriptEditor
	"Create a new script editor for this Wonderland"

	scriptEditor _ WonderlandEditor newFor: self.
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 9/14/1999 20:02'!
makeTextureFrom: filename
	"Create a texture from the given file name"
	^self makeTextureFrom: filename flipping: false! !

!Wonderland methodsFor: 'creating' stamp: 'ar 11/5/2000 16:59'!
makeTextureFrom: filename flipping: aBool
	"Create a texture from the given file name and flip it in y if requested"
	| tex |
	filename == nil ifTrue:[^nil].
	^self getSharedTextureDict at: filename ifAbsentPut:[
		tex _ (Form fromFileNamed: filename) asTexture.
		aBool ifTrue:[tex flipVertically].
		tex wrap: true.
		tex interpolate: true.
		tex envMode: 0.
	].
! !

!Wonderland methodsFor: 'creating' stamp: 'ar 4/24/1999 03:52'!
protoClassFor: aFilename
	| localName protoClass |
	localName _ FileDirectory localNameFor: aFilename.
	(ActorPrototypeClasses includesKey: localName)
			ifTrue: [ protoClass _ ActorPrototypeClasses at: localName ]
			ifFalse: ["Make a new prototype class for this model"
					protoClass _ (WonderlandActor newUniqueClassInstVars: '' classInstVars: '').
					ActorPrototypeClasses at: localName put: protoClass].
	^protoClass! !

!Wonderland methodsFor: 'creating' stamp: 'ar 4/24/1999 05:10'!
uniqueNameFrom: aString
	"If aName is unique to this wonderland's namespace, returns that name. Otherwise creates a unique variant and returns that."

	| index aName |
	aName _ self fixNameFrom: aString.
	(myNamespace includesKey: aName)
			ifFalse: [ ^ aName ]
			ifTrue: [
						index _ 2.
						[ myNamespace includesKey: (aName , (index asString)) ]
							whileTrue: [ index _ index + 1 ].
						^ aName , (index asString).
					].
! !


!Wonderland methodsFor: 'error handling' stamp: 'jsp 3/24/1999 10:15'!
reportErrorToUser: errorString
	"When any object in a Wonderland discovers an error it creates an error report and then calls this method to display the error to the user."

	| errWin tm |

	errWin _ SystemWindowWithButton labelled: 'Ooops'.
	errWin openInWorldExtent: 400@100.
	errWin color: (Color white).

	tm _ TextMorph new.
	tm initialize.
	errWin addMorph: tm.

	tm color: (Color red).
	tm contents: errorString wrappedTo: 380.
	tm position: ((errWin position) + (10@20)).
	tm lock.

	errWin height: (tm height) + 30.

	errorSound play.



! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Wonderland class
	instanceVariableNames: ''!

!Wonderland class methodsFor: 'instance creation' stamp: 'di 4/20/1999 12:03'!
new   "Wonderland new" 
	"Create and initialize a new Wonderland."
	B3DPrimitiveEngine isAvailable ifFalse: [
	(self confirm: 'WARNING: This Squeak does not have real 3D support.
Opening a Wonderland will EXTREMELY time consuming.
Are you sure you want to do this?
(NO is probably the right answer :-)') ifFalse: [^ self]].
	Display depth < 8 ifTrue:
		[(self confirm: 'The display depth should be set to at least 8 bit.
Shall I do this now for you?') ifTrue: [Display newDepth: 8]].
	^ super new initialize
! !


!Wonderland class methodsFor: 'class initialization' stamp: 'jsp 4/6/1999 16:52'!
initialize
	"Initialize the WonderlandClass by creating the ActorPrototypeClasses collection"

	ActorPrototypeClasses _ Dictionary new.
! !


!Wonderland class methodsFor: 'actor prototype mgmt' stamp: 'di 3/10/2000 08:49'!
rectifyActorPrototypeClasses  "Wonderland rectifyActorPrototypeClasses"
	"Rectify any obsolete prototype class references"

	ActorPrototypeClasses keysDo:
		[:key | (ActorPrototypeClasses at: key) isObsolete ifTrue:
				[ActorPrototypeClasses at: key
					put: (ActorPrototypeClasses at: key) nonObsoleteClass]]
! !

!Wonderland class methodsFor: 'actor prototype mgmt' stamp: 'jsp 4/23/1999 12:11'!
removeActorPrototypesFromSystem
	"Clean out all the actor prototypes - this involves removing those classes from the Smalltalk dictionary"

	ActorPrototypeClasses do: [:aClass | aClass removeFromSystem ].

	ActorPrototypeClasses _ Dictionary new.
! !


!Wonderland class methodsFor: 'accessing' stamp: 'ar 8/19/1999 16:20'!
wonderlandConstants
	^WonderlandConstants! !
Hierarchical subclass: #WonderlandActor
	instanceVariableNames: 'myName myWonderland myMesh myTexture myMaterial myColor composite scaleMatrix hidden firstClass myReactions myProperties '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Objects'!
!WonderlandActor commentStamp: '<historical>' prior: 0!
The WonderlandActor class provides the basic behaviors for 3D objects.  These behaviors include (but are not limited to):

- move
- moveTo
- turn
- turnTo
- roll
- pointAt
- place
- resize

For more details, see the Wonderlands ActiveEssay (coming soon to a theater near you).
 !


!WonderlandActor methodsFor: 'initialize' stamp: 'ar 6/2/1999 14:15'!
initializeDefaultReactions
	"Set up our default reactions"
	myReactions _ Dictionary new.
	self respondWith: [:event | self onLeftMouseDown: event] to: leftMouseDown.
	self respondWith: [:event | self onLeftMouseUp: event] to: leftMouseUp.
! !

!WonderlandActor methodsFor: 'initialize' stamp: 'ar 6/2/1999 14:16'!
initializeFor: aWonderland
	"Initialize the instance variables for the WonderlandActor"

	super initialize.

	myName _ 'Unnamed'.
	myWonderland _ aWonderland.
	myParent _ aWonderland getScene.
	myParent addChild: self.

	"Initialize our material"
	myMaterial _ B3DMaterial new.
	myMaterial ambientPart: Color white.
	myMaterial diffusePart: Color white.
	myMaterial specularPart: Color white.

	"Set up our default properties"
	myColor _ B3DColor4 r: 1.0 g: 1.0 b: 1.0 a: 1.0.
	composite _ B3DMatrix4x4 identity.
	scaleMatrix _ B3DMatrix4x4 identity.

	"Setup the default reactions"
	self initializeDefaultReactions.

	hidden _ false.
	firstClass _ true.
! !

!WonderlandActor methodsFor: 'initialize' stamp: 'ar 9/1/2000 05:22'!
initializeNoReactions
	myReactions _ Dictionary new.! !


!WonderlandActor methodsFor: 'drawing' stamp: 'ar 11/7/1999 18:46'!
drawMesh: aRenderer
	"Draw the mesh for this actor."
	| recorder bounds |

	myMaterial ifNotNil: [
			aRenderer pushMaterial.
			aRenderer material: myMaterial.
						].

	myTexture ifNotNil: [
			aRenderer pushTexture.
			aRenderer texture: myTexture.
						].

	"Note: Using myMesh>>renderOn: here prevents meshes from being picked!!"
	myMesh ifNotNil: [ bounds _ myMesh renderOn: aRenderer].

	myTexture ifNotNil: [ aRenderer popTexture ].

	myMaterial ifNotNil: [ aRenderer popMaterial ].

	"Pass the 2D extent back to the recorder (if any)"
	recorder _ aRenderer valueOfProperty: #boundsRecorder.
	recorder == nil ifFalse:[recorder setBounds: bounds for: self].! !

!WonderlandActor methodsFor: 'drawing' stamp: 'ar 11/7/1999 18:46'!
renderOn: aRenderer
	"Draw the actor."

	"Save the old transformation matrix"
	aRenderer pushMatrix.

	"Modify the matrix using our composite matrix for position and orientation"
	aRenderer transformBy: composite.

	"Save the new transformation matrix"
	aRenderer pushMatrix.

	"Modify the matrix using our scale matrix - we do this seperately to avoid scaling space"
	aRenderer transformBy: scaleMatrix.

	"Draw our mesh if the object is not hidden"
	(hidden) ifFalse: [ self drawMesh: aRenderer ].

	"Remove the scaling matrix"
	aRenderer popMatrix.

	"Set the default texture for our children"
	myTexture ifNotNil:[aRenderer pushTexture; texture: myTexture].

	"Draw our children.
	Note: For correct picking it is important to use B3DRenderEngine>>render: here."
	myChildren do: [:child | aRenderer render: child].

	"Restore the old texture"
	myTexture ifNotNil:[aRenderer popTexture].

	"Restore the old matrix"
	aRenderer popMatrix.! !


!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 4/9/1999 14:06'!
angularDistanceTo: aRotationVector
	"Returns the angular distance in degrees between the actor's current orientation and an (x, y, z) rotation vector"

	| m sum angles vector1 vector2 |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aRotationVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can only calculate the distance from ' , myName , ' to an actor or 3D point.'.
			^ nil ].

	"Our arguments check out, so determine the distance"
	m _ B3DMatrix4x4 identity.
	m rotation: (self getRotationVector).

	m _ m composeWith: (B3DMatrix4x4 identity translation: (B3DVector3 x:0 y:0 z:1)).
	vector1 _ m translation.

	m setIdentity.

	(aRotationVector isKindOf: WonderlandActor)
		ifTrue: [
				angles _ aRotationVector getAngles: myParent.
				m rotation: (B3DVector3 x: (angles at: 1) y: (angles at: 2) z: (angles at: 3)).
				]
		ifFalse: [
				m rotation: (B3DVector3 x: (aRotationVector at: 1) y: (aRotationVector at: 2)
										z: (aRotationVector at: 3)).
				].

	m _ m composeWith: (B3DMatrix4x4 identity translation: (B3DVector3 x:0 y:0 z:1)).
	vector2 _ m translation.

	sum _ ((vector1 x) * (vector2 x)) + ((vector1 y) * (vector2 y)) + ((vector1 z) * (vector2 z)).

	^ ((sum / ((vector1 length) * (vector2 length))) arcCos) radiansToDegrees.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/17/1999 10:44'!
asString
	"Returns the name of the object."

	^ myName.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/4/1999 15:35'!
becomeFirstClass
	"Make the actor a first class object."

	firstClass _ true.

	(myWonderland getUndoStack) push: (UndoAction new: [ firstClass _ false ]).
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/4/1999 15:35'!
becomePart
	"Make the actor a part."

	firstClass _ false.

	(myWonderland getUndoStack) push: (UndoAction new: [ firstClass _ true ]).
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/18/1999 16:43'!
distanceTo: aVector
	"Returns the distance from the object to the specified point in the parent's coordinate system"

	| pos |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can only calculate the distance from ' , myName , ' to an actor or 3D point.'.
			^ nil ].

	(aVector isKindOf: WonderlandActor)
		ifTrue: [ pos _ aVector getPosition: self.
				 ^ ((pos at: 1) squared + (pos at: 2) squared + (pos at: 3) squared) sqrt ]
		ifFalse: [ pos _ self getPositionVector.
				  ((aVector at: 1) = asIs) ifTrue: [ aVector at: 1 put: (pos x) ].
				  ((aVector at: 2) = asIs) ifTrue: [ aVector at: 2 put: (pos y) ].
				  ((aVector at: 3) = asIs) ifTrue: [ aVector at: 3 put: (pos z) ].
				  ^ ((self getPositionVector) - aVector) length ].
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 4/5/1999 15:10'!
getAllParts
	"Return all of this actor's parts"

	| parts |

	parts _ OrderedCollection new.

	myChildren do: [:child | (child isPart) ifTrue: [
						parts addLast: child.
						parts _ parts , (child getAllParts).
												].
					].

	^ parts.

	! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/19/1999 14:33'!
getBoundingBox
	"Returns the actor's bounding box"

	| size x y z nOrigin nCorner childBBox cOrigin cCorner meshBBox mOrigin mCorner |

	(myMesh notNil)
		ifTrue: [ meshBBox _ myMesh boundingBox.
				 size _ self getSizeVector.
				 mOrigin _ meshBBox origin.
				 mCorner _ meshBBox corner.

				 x _ (mOrigin x) * (size x).
				 y _ (mOrigin y) * (size y).
				 z _ (mOrigin z) * (size z).
				 nOrigin _ B3DVector3 x: x y: y z: z.

				 x _ (mCorner x) * (size x).
				 y _ (mCorner y) * (size y).
				 z _ (mCorner z) * (size z).
				 nCorner _ B3DVector3 x: x y: y z: z.
				]
		ifFalse: [ nOrigin _ (B3DVector3 x:0 y:0 z:0).
				  nCorner _ (B3DVector3 x:0 y:0 z:0) ].


	myChildren do: [:child | 
			(child isPart) ifTrue: [
									childBBox _ child getBoundingBox: self.
				 					cOrigin _ childBBox origin.
				 					cCorner _ childBBox corner.
									nOrigin _ nOrigin min: cOrigin.
									nCorner _ nCorner max: cCorner.
								 ].
					].

	^ Rectangle origin: nOrigin corner: nCorner.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/19/1999 14:41'!
getBoundingBox: reference
	"Returns the actor's bounding box"

	| RUF LDB min max cMatrix tMatrix tVector meshBBox |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the bounding box of ' , myName , ' relative to ', (reference asString) , ' because ', msg.
			^ nil ].

	meshBBox _ self getBoundingBox.
	LDB _ meshBBox origin.
	RUF _ meshBBox corner.

	cMatrix _ (reference getMatrixToRoot) composeWith: (self getMatrixFromRoot).
	tMatrix _ B3DMatrix4x4 identity.

	tMatrix _ cMatrix composeWith: (tMatrix translation: RUF).
	min _ tMatrix translation.
	max _ tMatrix translation.
				
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: LDB)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	"Right up behind"
	tVector _ B3DVector3 x: (RUF x) y: (RUF y) z: (LDB z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.
	
	"Left up behind"
	tVector _ B3DVector3 x: (LDB x) y: (RUF y) z: (LDB z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	"Left up front"
	tVector _ B3DVector3 x: (LDB x) y: (RUF y) z: (RUF z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	"Right down behind"
	tVector _ B3DVector3 x: (RUF x) y: (LDB y) z: (LDB z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	"Right down front"
	tVector _ B3DVector3 x: (RUF x) y: (LDB y) z: (RUF z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	"Left down front"
	tVector _ B3DVector3 x: (LDB x) y: (LDB y) z: (RUF z).
	tMatrix setIdentity.
	tVector _ (cMatrix composeWith: (tMatrix translation: tVector)) translation.	
	min _ min min: tVector.
	max _ max max: tVector.

	^ Rectangle origin: min corner: max.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/19/1999 16:28'!
getFaceCount
	"Return the number of faces in this actor and its parts"

	| count |

	(myMesh notNil) ifTrue: [ count _ myMesh faces size ]
					 ifFalse: [ count _ 0 ].

	myChildren do: [:child | (child isPart) ifTrue: [ count _ count + (child getFaceCount) ] ].

	^ count.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 3/22/1999 14:14'!
getWonderland
	"Return the wonderland this actor is a part of"

	^ myWonderland.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 7/8/1999 23:20'!
hasParts
	"Return true if the receiver has any children that are parts"

	self partsDo: [:child | ^ true ].

	^ false.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 2/9/1999 10:09'!
isFirstClass
	"Returns true if the object is a First Class object"

	^ firstClass.
! !

!WonderlandActor methodsFor: 'accessing' stamp: 'jsp 2/9/1999 10:10'!
isPart
	"Returns true if the object is a Part."

	^ (firstClass not).
! !


!WonderlandActor methodsFor: 'parent-child' stamp: 'jsp 4/7/1999 16:06'!
becomeChildOf: anObject
	"Update the undo stack and make this actor a child of the specified object."

	| oldParent |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyReferenceFrame: anObject ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can only make ' , myName , ' a child of other actors or the scene, and ', msg.
			^ nil ].

	(self == anObject) ifTrue: [
		myWonderland reportErrorToUser: 'Squeak can not make ' , myName , ' a child of itself.'.
		^ nil ].
		
	oldParent _ myParent.

	(myWonderland getUndoStack) push: (UndoAction new: [self reparentTo: oldParent]).

	self reparentTo: anObject.
! !


!WonderlandActor methodsFor: 'playing sound' stamp: 'jsp 4/22/1999 11:26'!
playSound: soundFile
	"Create an animation that plays the sound and lasts the duration of the sound"

	| aSound extension |

	extension _ (soundFile findTokens: '.') last.

	(extension = 'wav')
		ifTrue: [ [ aSound _ SampledSound fromWaveFileNamed: soundFile ]
					ifError: [ :msg : rcvr | myWonderland reportErrorToUser:
										(soundFile asString) , ' is not a valid sound.'.
											^ nil ]
				]
		ifFalse: [ aSound _ SampledSound soundNamed: soundFile.
				  aSound ifNil: [ ^ nil ] ].

	^ myWonderland doTogether: {
				self do: [ aSound play ].
				self wait: (aSound duration)
								}.
! !


!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/4/1999 11:53'!
alignWith: anObject
	"This method sets the orientation of this instance to be the same as that of the specified object."

	^ self turnTo: anObject duration: 1.0 style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/8/1999 17:02'!
alignWith: anObject duration: aDuration
	"This method sets the orientation of this instance to be the same as that of the specified object."

	^ self turnTo: anObject duration: aDuration.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/4/1999 11:52'!
alignWith: anObject duration: aDuration style: aStyle
	"This method sets the orientation of this instance to be the same as that of the specified object."

	^ self turnTo: anObject duration: aDuration style: aStyle.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'ar 8/31/2000 19:59'!
animateMeshTo: param
	^ (self animateMeshTo: param duration: 1.0
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'ar 8/31/2000 20:01'!
animateMeshTo: param duration: aDuration
	^ (self animateMeshTo: param duration: aDuration style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'ar 8/31/2000 19:59'!
animateMeshTo: param duration: aDuration style: aStyle
	"Turns the object to point at the specified target using the specified style over the specified duration."
	| anim |
	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumber: param ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what to animate to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use animating ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to animate ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	anim object: self
			update: [:t | self setMeshAnimationParameter: t ]
			getStartState: [self getMeshAnimationParameter]
			getEndState: [ param ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 4/5/1999 14:33'!
destroy
	"Destroy the object over 1 second"

	self destroy: 1.0.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 4/19/1999 11:24'!
destroy: aDuration
	"Implements the animated destroy of an actor.  This takes all the actors parts and spins them off in an arbitrary direction"

	| anim allAnims undoActions childList partsList |

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for destroying ' , myName , ' because ', msg.
			^ nil ].

	"The parameter checks out, so start the setup"
	undoActions _ OrderedCollection new.
	allAnims _ OrderedCollection new.
	childList _ self getAllChildren.
	partsList _ self getAllParts.
	partsList addFirst: self.

	"Do it for the top level object"

	"We need to do this for every part"
	childList do: [:child |
		(child isPart)
			ifTrue: [

				"Make sure our POV gets reset on undo"
				undoActions addFirst: (UndoPOVChange for: child from: (child getPointOfView)).
				
				"Create the animation for moving toward a random endpoint"
				anim _ child moveTo: { (-2 to: 2) atRandom. (-2 to: 2) atRandom.
							(-2 to: 2) atRandom} duration: aDuration
							asSeenBy: (myWonderland getScene) style: abruptly.

				anim stop.
				anim setUndoable: false.
				allAnims addLast: anim.

				"Create the animation for spinning this object"
				child turnToRightNow: { (0 to: 360) atRandom. (0 to: 360) atRandom.
							(0 to: 360) atRandom} undoable: false.

				anim _ child turn: left turns: aDuration speed: 1.
				anim stop.
				anim setUndoable: false.
				allAnims addLast: anim.
					]
			ifFalse: [
				"Make the non-part children point to this actor's parent"
				undoActions addLast: (UndoParentChange newFor: child from: (child getParent)).
				child reparentTo: (self getParent).
					].
					].

	"Add an undo action to put the objects back in the scene"	
	undoActions addFirst: (UndoAction new: [ (myWonderland getScene) addChild: self.
											 myWonderland getEditor updateActorBrowser ]).

	"Add the undo list to the stack"
	(myWonderland getUndoStack) push: (UndoChangeList new setChangeList: undoActions).

	"Create the animation to remove the parts from the scene and update the actor browser"
	anim _ self do: [ self removeFromScene.
					 myWonderland getEditor updateActorBrowser ].

	"Now start our parallel animation"
	anim _ myWonderland doInOrder: { myWonderland doTogether: allAnims. anim }.
	anim setUndoable: false.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:09'!
move: aDirection
	"Move the actor one meter in the specified direction, taking 1 second and using the Gently animation style."

	^ (self move: aDirection distance: 1.0 duration: 1.0
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:09'!
move: aDirection asSeenBy: reference
	"Move the actor one meter in the specified direction, taking 1 second and using the Gently animation style."

	^ (self move: aDirection distance: 1.0 duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:10'!
move: aDirection distance: aDistance 
	"Move the actor the specified distance in the specified direction, taking 1 second and using the Gently animation style."

	^ (self move: aDirection distance: aDistance duration: 1.0
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:07'!
move: aDirection distance: aDistance asSeenBy: reference
	"Move the actor the specified distance in the specified direction, taking 1 second and using the Gently animation style."

	^ (self move: aDirection distance: aDistance duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:24'!
move: aDirection distance: aDistance duration: aDuration
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: aDistance ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
				^ nil ].

		self moveRightNow: aDirection distance: aDistance undoable: true.
		^ self. ].

	^ (self move: aDirection distance: aDistance duration: aDuration style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:25'!
move: aDirection distance: aDistance duration: aDuration asSeenBy: reference
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: aDistance ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		self moveRightNow: aDirection distance: aDistance asSeenBy: reference undoable: true.
		^ self. ].

	^ (self move: aDirection distance: aDistance duration: aDuration asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:17'!
move: aDirection distance: aDistance duration: aDuration asSeenBy: reference style: aStyle
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim a3DVector tmpVector tMatrix newComposite |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: aDistance ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpVector _ (B3DVector3 x:0 y:0 z:0).
	tMatrix _ B3DMatrix4x4 identity.

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	anim object: self
			update: [:tPos | newComposite _ (reference getMatrixToRoot)
										composeWith: (self getMatrixFromRoot).
						 composite _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith:
										(tMatrix translation: (tPos - tmpVector)))
										composeWith: newComposite.
						 tmpVector _ tPos]
			getStartState: [tmpVector x:0; y:0; z:0.
								(B3DVector3 x:0 y:0 z:0) ]
			getEndState: [ a3DVector ]
			getReverseState: [ a3DVector negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:18'!
move: aDirection distance: aDistance duration: aDuration style: aStyle
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim a3DVector tmpVector tMatrix |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: aDistance ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpVector _ (B3DVector3 x:0 y:0 z:0).
	tMatrix _ B3DMatrix4x4 identity.

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	anim object: self
			update: [:tPos | composite _ composite composeWith:
												(tMatrix translation: (tPos - tmpVector)).
							tmpVector _ tPos]
			getStartState: [tmpVector x:0; y:0; z:0.
								(B3DVector3 x:0 y:0 z:0) ]
			getEndState: [ a3DVector ]
			getReverseState: [ a3DVector negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:18'!
move: aDirection distance: aDistance speed: aSpeed
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim a3DVector tmpVector tMatrix aDuration |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: aDistance ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpVector _ (B3DVector3 x:0 y:0 z:0).
	tMatrix _ B3DMatrix4x4 identity.

	aDuration _ (aDistance / aSpeed) abs.

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	anim object: self
			update: [:tPos | composite _ composite composeWith:
												(tMatrix translation: (tPos - tmpVector)).
							tmpVector _ tPos]
			getStartState: [tmpVector x:0; y:0; z:0.
								(B3DVector3 x:0 y:0 z:0) ]
			getEndState: [ a3DVector ]
			getReverseState: [ a3DVector negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:16'!
move: aDirection distance: aDistance speed: aSpeed asSeenBy: reference
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim a3DVector aDuration tmpVector tMatrix newComposite |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: aDistance ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the distance to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpVector _ (B3DVector3 x:0 y:0 z:0).
	tMatrix _ B3DMatrix4x4 identity.

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	aDuration _ (aDistance / aSpeed) abs.

	anim object: self
			update: [:tPos | newComposite _ (reference getMatrixToRoot)
										composeWith: (self getMatrixFromRoot).
						 composite _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith:
										(tMatrix translation: (tPos - tmpVector)))
										composeWith: newComposite.
						 tmpVector _ tPos]
			getStartState: [tmpVector x:0; y:0; z:0.
								(B3DVector3 x:0 y:0 z:0) ]
			getEndState: [ a3DVector ]
			getReverseState: [ a3DVector negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:18'!
move: aDirection speed: aSpeed
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	"The parameters check out, so go ahead and start the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							undoable: false ].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:20'!
move: aDirection speed: aSpeed asSeenBy: reference
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							asSeenBy: reference
							undoable: false ].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:28'!
move: aDirection speed: aSpeed asSeenBy: reference for: aLifetime
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move because ', msg.
			^ nil ].

	"The parameters check out, so start the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							asSeenBy: reference
							undoable: false ]
		   for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:31'!
move: aDirection speed: aSpeed asSeenBy: reference until: aCondition
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move because ', msg.
			^ nil ].

	"The parameters check out, so start the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							asSeenBy: reference
							undoable: false ]
		   until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:29'!
move: aDirection speed: aSpeed for: aLifetime
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move because ', msg.
			^ nil ].

	"The parameters check out, so start the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							undoable: false ]
		   for: aLifetime.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:33'!
move: aDirection speed: aSpeed until: aCondition
	"Creates and returns an action that moves the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to move ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move because ', msg.
			^ nil ].

	"The parameters check out, so start the action"
	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveRightNow: aDirection
							distance: ((myWonderland getScheduler getElapsedTime) * aSpeed)
							undoable: false ]
		   until: aCondition.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:10'!
moveTo: aVector
	"Moves the object to the specified position in its parent's coordinate system over 1 second using the Gently animation style."

	^ (self moveTo: aVector duration: 1.0
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:10'!
moveTo: aVector asSeenBy: reference
	"Moves the object to the specified position in its parent's coordinate system over 1 second using the Gently animation style."

	^ (self moveTo: aVector duration: 1.0 asSeenBy: reference
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:56'!
moveTo: aVector asSeenBy: reference eachFrameFor: aLifetime
	"Move the actor to a specified point each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move to this position because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveToRightNow: aVector asSeenBy: reference undoable: false ]
			for: aLifetime.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:57'!
moveTo: aVector asSeenBy: reference eachFrameUntil: aCondition
	"Move the actor to a specified point each frame until the condition returns true."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long ' , myName , ' should move to this position because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveToRightNow: aVector asSeenBy: reference undoable: false ]
			until: aCondition.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 09:47'!
moveTo: aVector duration: aDuration
	"Moves the object to the specified position in its parent's coordinate system over the specified duration using the Gently animation style."


	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyDuration: aDuration ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
				^ nil ].

		self moveToRightNow: aVector undoable: true.
		^ self. ].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyDuration: aDuration ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self moveToRightNow: aVector	undoable: false ].
									].

	^ (self moveTo: aVector duration: aDuration
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 09:47'!
moveTo: aVector duration: aDuration asSeenBy: reference
	"Moves the object to the specified position in its parent's coordinate system over the specified duration using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyDuration: aDuration ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		self moveToRightNow: aVector asSeenBy: reference undoable: true.
		^ self ].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyDuration: aDuration ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self moveToRightNow: aVector	asSeenBy: reference undoable: false ].
									].

	^ (self moveTo: aVector duration: aDuration asSeenBy: reference
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:53'!
moveTo: aVector duration: aDuration asSeenBy: reference style: aStyle
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	| anim endStateFunc pos newComposite vectorMatrix |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not move ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	endStateFunc _ [
		vectorMatrix _ B3DMatrix4x4 identity.
		pos _ self getPosition: reference.
		((aVector at: 1) = asIs) ifFalse: [ pos at: 1 put: (aVector at: 1) ].
		((aVector at: 2) = asIs) ifFalse: [ pos at: 2 put: (aVector at: 2) ].
		((aVector at: 3) = asIs) ifFalse: [ pos at: 3 put: (aVector at: 3) ].
		vectorMatrix translation: (B3DVector3 x: (pos at: 1) y: (pos at: 2) z: (pos at: 3)).
		newComposite _ (myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot).
		newComposite _ newComposite composeWith: vectorMatrix.
		newComposite translation.
					].


	anim object: self
			update: [:tPos | self setPositionVector: tPos]
			getStartState: [self getPositionVector]
			getEndState: endStateFunc
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:48'!
moveTo: aVector duration: aDuration style: aStyle
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	| anim pos endStateFunc |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].


	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	(aVector isKindOf: WonderlandActor)
		ifTrue: [ endStateFunc _ [ pos _ aVector getPosition: myParent.
				 				   B3DVector3 x: (pos at: 1) y: (pos at: 2) z: (pos at: 3). ]
				]
		ifFalse: [ endStateFunc _ [
						pos _ self getPositionVector.
				  		((aVector at: 1) = asIs) ifFalse: [pos x: (aVector at: 1) ].
				  		((aVector at: 2) = asIs) ifFalse: [pos y: (aVector at: 2) ].
				  		((aVector at: 3) = asIs) ifFalse: [pos z: (aVector at: 3) ].
				  		pos.
								]
				].

	anim object: self
			update: [:tPos | self setPositionVector: tPos]
			getStartState: [self getPositionVector]
			getEndState: endStateFunc
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:56'!
moveTo: aVector eachFrameFor: aLifetime
	"Move the actor to a specified point each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should move to this position because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveToRightNow: aVector undoable: false ]
			for: aLifetime.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:57'!
moveTo: aVector eachFrameUntil: aCondition
	"Move the actor to a specified point each frame until the condition returns true."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long ' , myName , ' should move to this position because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self moveToRightNow: aVector undoable: false ]
			until: aCondition.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:07'!
moveTo: aVector speed: aSpeed 
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	^ self moveTo: aVector duration: (((self distanceTo: aVector) / aSpeed) abs) style: abruptly.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 16:07'!
moveTo: aVector speed: aSpeed asSeenBy: reference
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	^ self moveTo: aVector duration: (((self distanceTo: aVector) / aSpeed) abs)
			asSeenBy: reference style: abruptly.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/4/1999 15:45'!
nudge: aDirection
	"Nudge the actor one length in the specified direction, taking 1 second and using the Gently animation style."

	^ (self nudge: aDirection distance: 1.0 duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/4/1999 15:50'!
nudge: aDirection distance: aDistance
	"Nudge the actor the specified object lengths in the specified direction, taking one second and using the Gently animation style."

	^ self nudge: aDirection distance: aDistance duration: 1.0 style: gently.
	

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 17:00'!
nudge: aDirection distance: aDistance duration: aDuration 
	"Nudge the actor the specified object lengths in the specified direction, taking the specified duration and using the Gently animation style."

	|  size newDistance |
	
	(aDuration = rightNow) ifTrue: [
			size _ self getSize.

			((aDirection = #left) or: [ aDirection = #right ])
				ifTrue: [ newDistance _ aDistance * (size at: 1) ]
				ifFalse: [

			((aDirection = #up) or: [ aDirection = #down ])
				ifTrue: [ newDistance _ aDistance * (size at: 2) ]
				ifFalse: [

			((aDirection = #forward) or: [ (aDirection = #back) or: [aDirection = #backward]])
				ifTrue: [ newDistance _ aDistance * (size at: 3) ]
				ifFalse: [ 	myWonderland reportErrorToUser: 'Squeak could not determine which direction to nudge the object because ' , (aDirection asString) , 'is not a valid direction.'.
							^ nil.]]].


			^ self moveRightNow: aDirection distance: newDistance undoable: true ].

	^ self nudge: aDirection distance: aDistance duration: aDuration style: gently.
	

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 17:01'!
nudge: aDirection distance: aDistance duration: aDuration style: aStyle
	"Nudge the actor the specified object lengths in the specified direction, taking the specified duration and using the specified animation style."

	|  size newDistance |
	
	size _ self getSize.

	((aDirection = #left) or: [ aDirection = #right ])
		ifTrue: [ newDistance _ aDistance * (size at: 1) ]
		ifFalse: [

	((aDirection = #up) or: [ aDirection = #down ])
		ifTrue: [ newDistance _ aDistance * (size at: 2) ]
		ifFalse: [

	((aDirection = #forward) or: [ (aDirection = #back) or: [aDirection = #backward]])
		ifTrue: [ newDistance _ aDistance * (size at: 3) ]
		ifFalse: [ 	myWonderland reportErrorToUser: 'Squeak could not determine which direction to nudge ' , myName, ' because ' , (aDirection asString) , ' is not a valid direction.'.
					^ nil.]]].

	^ self move: aDirection distance: newDistance duration: aDuration style: aStyle.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/4/1999 10:57'!
place: aLocation object: aTarget
	"Moves this object to one of several pre-determined locations relative to the target object."

	 ^ self place: aLocation object: aTarget duration: 1.0 style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 09:48'!
place: aLocation object: aTarget duration: aDuration 
	"Moves this object to one of several pre-determined locations relative to the target object."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyLocation: aLocation ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyActor: aTarget ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
				^ nil ].

		self placeRightNow: aLocation object: aTarget undoable: true.
		^ self. ].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyLocation: aLocation ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyActor: aTarget ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self placeRightNow: aLocation object: aTarget undoable: false ].
									].

	 ^ self place: aLocation object: aTarget duration: aDuration style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 17:27'!
place: aLocation object: aTarget duration: aDuration style: aStyle
	"Moves this object to one of several pre-determined locations relative to the target object."

	 | anim selfPos selfBBox selfLBB selfRUF objBBox objLBB objRUF pos |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyLocation: aLocation ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyActor: aTarget ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for placing ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to place ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	selfBBox _ self getBoundingBox: aTarget.
	selfLBB _ selfBBox origin.
	selfRUF _ selfBBox corner.

	objBBox _ aTarget getBoundingBox.
	objLBB _ objBBox origin.
	objRUF _ objBBox corner.

	selfPos _ self getPosition: aTarget.

	((aLocation = onTopOf) or: [ aLocation = above])
	ifTrue: [
				pos _ { 0. (objRUF y) + ((selfPos at: 2) - (selfLBB y)). 0}
			]
 	ifFalse: [

	((aLocation = onBottomOf) or: [ (aLocation = beneath) or: [ aLocation = below ] ])
	ifTrue: [
				pos _ { 0. (objLBB y) - ((selfRUF y) - (selfPos at: 2)). 0}
			]
	ifFalse: [

	(aLocation = toLeftOf)
	ifTrue: [
				pos _ { (objLBB x) - ((selfRUF x) - (selfPos at: 1)). 0. 0 }
			]
	ifFalse: [

	(aLocation = toRightOf)
	ifTrue: [
				pos _ { (objRUF x) + ((selfPos at: 1) - (selfLBB x)). 0. 0 }
			]
	ifFalse: [

	(aLocation = inFrontOf)
	ifTrue: [
				pos _ { 0. 0. (objRUF z) + ((selfPos at: 3) - (selfLBB z)) }
			]
	ifFalse: [

	((aLocation = inBackOf) or: [ aLocation = behind])
	ifTrue: [
				pos _ { 0. 0. (objLBB z) - ((selfRUF z) - (selfPos at:3)) }
			]
	ifFalse: [

	(aLocation = onCeilingOf)
	ifTrue: [
				pos _ { 0. (objRUF y) - ((selfRUF y) - (selfPos at:2)). 0}
			]
	ifFalse: [

	(aLocation = onFloorOf)
	ifTrue: [
				pos _ { 0. (objLBB y) + ((selfPos at: 2) - (selfLBB y)). 0}
			]
	ifFalse: [ self error: 'Unrecognized target surface' ]]]]]]]].


	anim _	self moveTo: pos duration: aDuration asSeenBy: aTarget style: aStyle.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 17:30'!
place: aLocation object: aTarget eachFrameFor: aLifetime 
	"Moves this object to one of several pre-determined locations relative to the target object each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyLocation: aLocation ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyActor: aTarget ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long it should place ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self placeRightNow: aLocation object: aTarget undoable: false ]
			for: aLifetime.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/17/1999 17:30'!
place: aLocation object: aTarget eachFrameUntil: aCondition
	"Moves this object to one of several pre-determined locations relative to the target object each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyLocation: aLocation ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyActor: aTarget ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long it should place ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self placeRightNow: aLocation object: aTarget undoable: false ]
			until: aCondition.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:10'!
pointAt: target
	"Turns the object to point at the specified target over the specified duration using the Gently animation style."

	^ (self pointAt: target duration: 1.0
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/29/1999 14:39'!
pointAt: target duration: aDuration
	"Turns the object to point at the specified target over the specified duration using the Gently animation style."


	(aDuration = rightNow) ifTrue: [
		"Check the target to make sure it's valid"
		[ WonderlandVerifier VerifyTargetOrPixel: target ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what to point ' , myName , ' at because ', msg.
				^ nil ].
		self pointAtRightNow: target undoable: true.
		^ self. ].

	(aDuration = eachFrame) ifTrue: [
		"Check the target to make sure it's valid"
		[ WonderlandVerifier VerifyTargetOrPixel: target ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what to point ' , myName , ' at because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self pointAtRightNow: target undoable: false ].
									].

	^ (self pointAt: target duration: aDuration style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/29/1999 14:39'!
pointAt: target duration: aDuration style: aStyle
	"Turns the object to point at the specified target using the specified style over the specified duration."

	| anim |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTargetOrPixel: target ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what to point ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for pointing ' , myName , ' at ' , (target asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to point ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	anim object: self
			update: [:tQuat | self setRotationMatrix: (tQuat asMatrix4x4) ]
			getStartState: [ composite asQuaternion ]
			getEndState: [ (self getPointAtMatrix: target) asQuaternion ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/29/1999 14:39'!
pointAt: target eachFrameFor: aLifetime
	"Turns the object to point at the specified target each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTargetOrPixel: target ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what to point ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should point ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self pointAtRightNow: target undoable: false ]
			for: aLifetime.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/29/1999 14:39'!
pointAt: target eachFrameUntil: aCondition
	"Turns the object to point at the specified target each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTargetOrPixel: target ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what to point ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should point ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self pointAtRightNow: target undoable: false ]
			until: aCondition.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/24/1999 16:46'!
resize: amount
	"Resize the object by the specified amount over 1 second using the Gently animation style."

	"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumberOrTriple: amount ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
				^ nil ].

	(amount isNumber)
		ifTrue: [ ^ (self resizeTopToBottom: amount leftToRight: amount frontToBack: amount
						duration: 1.0
						style: gently). ]
		ifFalse: [  ^ (self resizeTopToBottom: (amount at: 2)
						leftToRight: (amount at: 1)
						frontToBack: (amount at: 3)
						duration: 1.0
						style: gently). ].


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/24/1999 16:51'!
resize: amount duration: aDuration
	"Resize the object by the specified amount over the specified duration using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumberOrTriple: amount ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
				^ nil ].

		(amount isNumber)
			ifTrue: [ self resizeRightNow: (B3DVector3 x: amount y: amount z: amount)
							undoable: true. ]
			ifFalse: [ self resizeRightNow: (B3DVector3 x: (amount at: 1) y: (amount at: 2)
							z: (amount at: 3)) undoable: true. ].
		^ self.
									].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumberOrTriple: amount ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

		(amount isNumber)
			ifTrue: [ ^ self doEachFrame: [ self resizeRightNow: (B3DVector3 x: amount y:
												amount z: amount) undoable: false ] ]
			ifFalse: [ ^ self doEachFrame: [ self resizeRightNow: (B3DVector3 x: (amount at: 1)
												y: (amount at: 2) z: (amount at: 3))
												undoable: true. ] ].
									].

	(amount isNumber)
		ifTrue: [ ^ (self resizeTopToBottom: amount leftToRight: amount frontToBack: amount
						duration: 1.0
						style: gently). ]
		ifFalse: [  ^ (self resizeTopToBottom: (amount at: 2)
						leftToRight: (amount at: 1)
						frontToBack: (amount at: 3)
						duration: 1.0
						style: gently). ].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/24/1999 16:47'!
resize: amount duration: aDuration style: aStyle
	"Resize the object by the specified amount over the specified duration using the specified animation style."

	"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumberOrTriple: amount ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
				^ nil ].

	(amount isNumber)
		ifTrue: [ ^ (self resizeTopToBottom: amount leftToRight: amount frontToBack: amount
						duration: 1.0
						style: gently). ]
		ifFalse: [  ^ (self resizeTopToBottom: (amount at: 2)
						leftToRight: (amount at: 1)
						frontToBack: (amount at: 3)
						duration: 1.0
						style: gently). ].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/24/1999 16:53'!
resize: amount eachFrameFor: aLifetime
	"Resize the object by the specified amount each frame for the specified lifetime."

	| aVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumberOrTriple: amount ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should resize ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

	(amount isNumber)
		ifTrue: [ aVector _ (B3DVector3 x: amount y: amount z: amount) ]
		ifFalse: [ aVector _ (B3DVector3 x: (amount at: 1) y: (amount at: 2)
									 z: (amount at: 3)) ].

	^ self doEachFrame: [ self resizeRightNow: aVector undoable: false ]
			for: aLifetime.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/24/1999 16:53'!
resize: amount eachFrameUntil: aCondition
	"Resize the object by the specified amount each frame until the condition returns true."

	| aVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumber: amount ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should resize ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

	(amount isNumber)
		ifTrue: [ aVector _ (B3DVector3 x: amount y: amount z: amount) ]
		ifFalse: [ aVector _ (B3DVector3 x: (amount at: 1) y: (amount at: 2)
									 z: (amount at: 3)) ].

	^ self doEachFrame: [ self resizeRightNow: aVector undoable: false ]
			until: aCondition.


! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/22/1999 12:42'!
resizeLikeRubber: amount dimension: aDimension
	"Resizes the object using a volume preserving resize"

	^ self resizeLikeRubber: amount dimension: aDimension duration: 1.0 style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/22/1999 12:42'!
resizeLikeRubber: amount dimension: aDimension duration: aDuration
	"Resizes the object using a volume preserving resize"

	| x y z |

	(aDuration = rightNow) ifTrue: [
		(aDimension = leftToRight)
			ifTrue: [
						x _ amount.
						y _ 1 / (amount sqrt).
						z _ 1 / (amount sqrt).
					]
			ifFalse: [ (aDimension = topToBottom)
					ifTrue: [
								x _ 1 / (amount sqrt).
								y _ amount.
								z _ 1 / (amount sqrt).
							]
					ifFalse: [ (aDimension = frontToBack)
							ifTrue: [
										x _ 1 / (amount sqrt).
										y _ 1 / (amount sqrt).
										z _ amount.
									].
							].
					].

			^ self resize: { x. y. z } duration: aDuration.
		].

	^ self resizeLikeRubber: amount dimension: aDimension duration: aDuration style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/22/1999 12:29'!
resizeLikeRubber: amount dimension: aDimension duration: aDuration style: aStyle
	"Resizes the object using a volume preserving resize"

	| x y z |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDimension: aDimension ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine along which dimension to resize ' , myName , '  because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: amount ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , '  because ', msg.
			^ nil ].

	(aDimension = leftToRight)
		ifTrue: [
					x _ amount.
					y _ 1 / (amount sqrt).
					z _ 1 / (amount sqrt).
				]
		ifFalse: [ (aDimension = topToBottom)
				ifTrue: [
							x _ 1 / (amount sqrt).
							y _ amount.
							z _ 1 / (amount sqrt).
						]
				ifFalse: [ (aDimension = frontToBack)
						ifTrue: [
									x _ 1 / (amount sqrt).
									y _ 1 / (amount sqrt).
									z _ amount.
								].
						].
				].

	^ self resizeTopToBottom: y leftToRight: x frontToBack: z duration: aDuration style: aStyle.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:11'!
resizeTopToBottom: height leftToRight: width frontToBack: thickness
	"Resize the object by the specified amount over 1 second using the Gently animation style."

	^ (self resizeTopToBottom: height leftToRight: width frontToBack: thickness
				duration: 1.0
				style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:04'!
resizeTopToBottom: height leftToRight: width frontToBack: thickness duration: aDuration
	"Resize the object by the specified amount over the specified duration using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumber: height ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from top to bottom because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: width ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from left to right because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: thickness ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from front to back because ', msg.
				^ nil ].

		self resizeRightNow: (B3DVector3 x: width y: height z: thickness) undoable: true.
		^ self.
									].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyNumber: height ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from top to bottom because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: width ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from left to right because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: thickness ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from front to back because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

		^ self doEachFrame: [ self resizeRightNow: (B3DVector3 x: width y: height z: thickness)
									undoable: false ]
									].

	^ (self resizeTopToBottom: height leftToRight: width frontToBack: thickness
				duration: aDuration style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:03'!
resizeTopToBottom: height leftToRight: width frontToBack: thickness duration: aDuration style: aStyle
	"Resize the object by the specified amount over the specified duration."

	| anim tmpVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumber: height ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from top to bottom because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: width ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from left to right because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: thickness ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from front to back because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for resizing ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to resize ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpVector _ B3DVector3 x: 1.0 y: 1.0 z: 1.0.

	anim object: self
			update: [:tScale | self scaleByVector: (tScale / tmpVector).
							tmpVector _ tScale]
			getStartState: [ tmpVector x: 1.0; y: 1.0; z: 1.0.
									(B3DVector3 x: 1.0 y: 1.0 z: 1.0) ]
			getEndState: [ B3DVector3 x: width y: height z: thickness ]
			getReverseState: [ B3DVector3 x: (1 / width) y: (1 / height) z: (1 / thickness) ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:07'!
resizeTopToBottom: height leftToRight: width frontToBack: thickness eachFrameFor: aLifetime
	"Resize the object by the specified amount each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumber: height ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from top to bottom because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: width ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from left to right because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: thickness ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from front to back because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should resize ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

	^ self doEachFrame: [ self resizeRightNow: (B3DVector3 x: width y: height z: thickness)
									undoable: false ]
			for: aLifetime.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:07'!
resizeTopToBottom: height leftToRight: width frontToBack: thickness eachFrameUntil: aCondition
	"Resize the object by the specified amount each frame until the condition is true."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyNumber: height ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from top to bottom because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: width ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from left to right because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: thickness ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how much to resize ' , myName , ' from front to back because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should resize ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).

	^ self doEachFrame: [ self resizeRightNow: (B3DVector3 x: width y: height z: thickness)
									undoable: false ]
			until: aCondition.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:50'!
roll: aDirection
	"Roll the actor a quarter turn in the specified direction, taking 1 second and using the Gently animation style."

	^ (self roll: aDirection turns: 0.25 duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:50'!
roll: aDirection asSeenBy: reference
	"Roll the actor 1/4 turn in the specified direction, taking 1 second and using the Gently animation style."

	^ (self roll: aDirection turns: 0.25 duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:43'!
roll: aDirection speed: aSpeed
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:44'!
roll: aDirection speed: aSpeed asSeenBy: reference
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:45'!
roll: aDirection speed: aSpeed asSeenBy: reference for: aLifetime
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should roll ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						]
		   for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:46'!
roll: aDirection speed: aSpeed asSeenBy: reference until: aCondition
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should roll ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						]
		   until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:45'!
roll: aDirection speed: aSpeed for: aLifetime
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should roll ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						]
		   for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:46'!
roll: aDirection speed: aSpeed until: aCondition
	"Creates and returns an action that rolls the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should roll ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self rollRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						]
		   until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:47'!
roll: aDirection turns: numTurns
	"Roll the actor the specified number of turns in the specified direction, taking 1 second and using the Gently animation style."

	^ (self roll: aDirection turns: numTurns duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:48'!
roll: aDirection turns: numTurns asSeenBy: reference
	"Roll the actor the specified number of turns in the specified direction, taking 1 second and using the Gently animation style."

	^ (self roll: aDirection turns: numTurns duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:48'!
roll: aDirection turns: numTurns duration: aDuration
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: numTurns ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
				^ nil ].

			self rollRightNow: aDirection numberOfTurns: numTurns undoable: true.
			^ self. ].

	^ (self roll: aDirection turns: numTurns duration: aDuration
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:49'!
roll: aDirection turns: numTurns duration: aDuration asSeenBy: reference
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: numTurns ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

			self rollRightNow: aDirection numberOfTurns: numTurns
						asSeenBy: reference undoable: true.
			^ self. ].

	^ (self roll: aDirection turns: numTurns duration: aDuration asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:50'!
roll: aDirection turns: numTurns duration: aDuration asSeenBy: reference style: aStyle
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the specified animation style."

	| anim updateFunc degrees lastAmount buildMatrix newMatrix tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for rolling ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to roll ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so go ahead and build the animation"
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	buildMatrix _ [ :rotMatrix | newMatrix _ reference getMatrixToRoot.
						newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
						newMatrix _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith: rotMatrix)
										composeWith: newMatrix. ].

	(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
				^ nil ]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:50'!
roll: aDirection turns: numTurns duration: aDuration style: aStyle
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the specified animation style."

	| anim updateFunc degrees lastAmount tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for rolling ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to roll ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so go ahead and build the animation"
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
				^ nil ]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:51'!
roll: aDirection turns: numTurns speed: aSpeed
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the specified animation style."

	| anim aDuration updateFunc degrees lastAmount tMatrix |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	aDuration _ (numTurns / aSpeed) abs.
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
				^ nil ]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:51'!
roll: aDirection turns: numTurns speed: aSpeed asSeenBy: reference
	"Roll the actor the specified number of turns in the specified direction, taking the specified duration and using the specified animation style."

	| anim aDuration updateFunc degrees lastAmount buildMatrix newMatrix tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the number of turns to roll ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to roll ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not roll ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	anim _ RelativeAnimation new.
	aDuration _ (numTurns / aSpeed) abs.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	buildMatrix _ [ :rotMatrix | newMatrix _ reference getMatrixToRoot.
						newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
						newMatrix _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith: rotMatrix)
										composeWith: newMatrix. ].

	(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
				^ nil ]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/5/1999 12:23'!
standUp
	"Rotate the object to align it along its parent's up vector"

	^ self turnTo: #(0 #asIs 0) duration: 1.0 style: gently.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/8/1999 15:15'!
standUpWithDuration: duration
	"Rotate the object to align it along its parent's up vector"

	^ self turnTo: #(0 #asIs 0) duration: duration.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/5/1999 12:23'!
standUpWithDuration: duration style: aStyle
	"Rotate the object to align it along its parent's up vector"

	^ self turnTo: #(0 #asIs 0) duration: duration style: aStyle.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:58'!
turn: aDirection
	"Turn the actor once around in the specified direction, taking 1 second and using the Gently animation style."

	^ (self turn: aDirection turns: 0.25 duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:59'!
turn: aDirection asSeenBy: reference
	"Turn the actor once around in the specified direction, taking 1 second and using the Gently animation style."

	^ (self turn: aDirection turns: 0.25 duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:08'!
turn: aDirection speed: aSpeed
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:09'!
turn: aDirection speed: aSpeed asSeenBy: reference
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						].
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:10'!
turn: aDirection speed: aSpeed asSeenBy: reference for: aLifetime
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						]
		   for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:11'!
turn: aDirection speed: aSpeed asSeenBy: reference until: aCondition
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				asSeenBy: reference
				undoable: false
						]
		   until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:10'!
turn: aDirection speed: aSpeed for: aLifetime
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						]
		   for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:11'!
turn: aDirection speed: aSpeed until: aCondition
	"Creates and returns an action that turn the object in the specified direction at the specified speed."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [
				self turnRightNow: aDirection
				numberOfTurns: ((myWonderland getScheduler getElapsedTime) * aSpeed)
				undoable: false
						]
		   until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 11:01'!
turn: aDirection turns: numTurns
	"Turn the actor the specified number of turns in the specified direction, taking one second and using the Gently animation style."

	^ (self turn: aDirection turns: numTurns duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 11:00'!
turn: aDirection turns: numTurns asSeenBy: reference
	"Turn the actor the specified number of turns in the specified direction, taking one second and using the Gently animation style."

	^ (self turn: aDirection turns: numTurns duration: 1.0 asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 11:00'!
turn: aDirection turns: numTurns duration: aDuration
	"Turn the actor the specified distance in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: numTurns ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
				^ nil ].

		self turnRightNow: aDirection numberOfTurns: numTurns undoable: true.
		^ self. ].

	^ (self turn: aDirection turns: numTurns duration: aDuration style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:59'!
turn: aDirection turns: numTurns duration: aDuration asSeenBy: reference
	"Turn the actor the specified distance in the specified direction, taking the specified duration and using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyDirection: aDirection ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyNumber: numTurns ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		self turnRightNow: aDirection numberOfTurns: numTurns
								asSeenBy: reference undoable: true.
		^ self. ].

	^ (self turn: aDirection turns: numTurns duration: aDuration asSeenBy: reference
			style: gently).

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:58'!
turn: aDirection turns: numTurns duration: aDuration asSeenBy: reference style: aStyle
	"Turn the actor the specified numberOfTurns in the specified direction, taking the specified duration and using the specified animation style."

	| anim updateFunc degrees lastAmount buildMatrix newMatrix tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for turning ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to turn ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so go ahead and build the animation"
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	buildMatrix _ [ :rotMatrix | newMatrix _ reference getMatrixToRoot.
						newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
						newMatrix _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith: rotMatrix)
										composeWith: newMatrix. ].

	(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle] ]

		ifFalse: [(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated ]

		ifFalse: [(((aDirection = #up) or: [aDirection = #back]) or: [aDirection = #backward])
			ifTrue: [
				updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle].
				degrees _ degrees negated ]

		ifFalse: [((aDirection = #down) or: [aDirection = #forward]) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #ccw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #cw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:57'!
turn: aDirection turns: numTurns duration: aDuration style: aStyle
	"Turn the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim updateFunc degrees lastAmount tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for turning ' , myName , ' because ', msg.
			^ nil ].


	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to turn ' , myName , ' because ', msg.
			^ nil ].

	"The parameters check out, so go ahead and build the animation"
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle] ]

		ifFalse: [(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated ]

		ifFalse: [(((aDirection = #up) or: [aDirection = #back]) or: [aDirection = #backward])
			ifTrue: [
				updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle].
				degrees _ degrees negated ]

		ifFalse: [((aDirection = #down) or: [aDirection = #forward]) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #ccw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #cw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:56'!
turn: aDirection turns: numTurns speed: aSpeed
	"Turn the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim aDuration updateFunc degrees lastAmount tMatrix |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	aDuration _ (numTurns / aSpeed) abs.

	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle] ]

		ifFalse: [(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated ]

		ifFalse: [(((aDirection = #up) or: [aDirection = #back]) or: [aDirection = #backward])
			ifTrue: [
				updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle].
				degrees _ degrees negated ]

		ifFalse: [((aDirection = #down) or: [aDirection = #forward]) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #ccw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #cw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. self rotateByMatrix:
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/19/1999 10:56'!
turn: aDirection turns: numTurns speed: aSpeed asSeenBy: reference
	"Turn the actor the specified numberOfTurns in the specified direction, taking the specified duration and using the specified animation style."

	| anim aDuration updateFunc degrees lastAmount buildMatrix newMatrix tMatrix|

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: numTurns ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how many turns to turn ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the speed to turn ' , myName , ' at because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	aDuration _ (numTurns / aSpeed) abs.
	anim _ RelativeAnimation new.
	degrees _ 360 * numTurns.
	lastAmount _ 0.
	tMatrix _ B3DMatrix4x4 new.

	buildMatrix _ [ :rotMatrix | newMatrix _ reference getMatrixToRoot.
						newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
						newMatrix _ (((myParent getMatrixToRoot)
										composeWith: (reference getMatrixFromRoot))
										composeWith: rotMatrix)
										composeWith: newMatrix. ].

	(aDirection = #right) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle] ]

		ifFalse: [(aDirection = #left) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundY: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated ]

		ifFalse: [(((aDirection = #up) or: [aDirection = #back]) or: [aDirection = #backward])
			ifTrue: [
				updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle].
				degrees _ degrees negated ]

		ifFalse: [((aDirection = #down) or: [aDirection = #forward]) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundX: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #ccw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle]]

		ifFalse: [(aDirection = #cw) ifTrue: [
			updateFunc _ [:tAngle | tMatrix setIdentity. composite _ buildMatrix value: 
										(tMatrix rotationAroundZ: (tAngle - lastAmount)).
							lastAmount _ tAngle].
			degrees _ degrees negated. ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].
	
	anim object: self
			update: updateFunc
			getStartState: [ lastAmount _ 0. (Interpolateable value: 0) ]
			getEndState: [ degrees ]
			getReverseState: [ degrees negated ]
			style: abruptly
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:12'!
turnTo: aVector
	"Turns the object to the specified orientation in its parent's coordinate system over one second using the Gently animation style."

	^ (self turnTo: aVector duration: 1.0
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:22'!
turnTo: aVector AsSeenBy: reference eachFrameFor: aLifetime
	"Turns the object to the specified orientation in its parent's coordinate system each frame for the specified lifetime."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self turnToRightNow: aVector asSeenBy: reference undoable: false ]
			for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:21'!
turnTo: aVector AsSeenBy: reference eachFrameUntil: aCondition
	"Turns the object to the specified orientation in its parent's coordinate system each frame until the condition returns true."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self turnToRightNow: aVector asSeenBy: reference undoable: false ]
			until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/1/1999 14:12'!
turnTo: aVector asSeenBy: reference
	"Turns the object to the specified orientation in its parent's coordinate system over one second using the Gently animation style."

	^ (self turnTo: aVector duration: 1.0 asSeenBy: reference
			style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:16'!
turnTo: aVector duration: aDuration
	"Turns the object to the specified orientation in its parent's coordinate system over the specified duration using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
				^ nil ].

		self turnToRightNow: aVector undoable: true.
		^ self. ].

	(aDuration = eachFrame) ifTrue: [
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self turnToRightNow: aVector	undoable: false ].
									].

	^ (self turnTo: aVector duration: aDuration style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:19'!
turnTo: aVector duration: aDuration asSeenBy: reference
	"Turns the object to the specified orientation in its parent's coordinate system over the specified duration using the Gently animation style."

	(aDuration = rightNow) ifTrue: [
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		self turnToRightNow: aVector asSeenBy: reference undoable: true.
		^ self. ].

	(aDuration = eachFrame) ifTrue: [
		"Check our arguments to make sure they're valid"
		[ WonderlandVerifier VerifyTarget: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
				^ nil ].

		[ WonderlandVerifier VerifyReferenceFrame: reference ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
				^ nil ].

		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

		^ self doEachFrame: [ self turnToRightNow: aVector asSeenBy: reference undoable: false ].
									].

	^ (self turnTo: aVector duration: aDuration asSeenBy: reference style: gently).
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:18'!
turnTo: aVector duration: aDuration asSeenBy: reference style: aStyle
	"Turns the object to the specified orientation in its parent's coordinate system using the specified style over the specified duration."

	| anim endStateFunc angles newComposite vectorMatrix |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for turning ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not turn ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to turn ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	vectorMatrix _ B3DMatrix4x4 identity.
	endStateFunc _ [
		vectorMatrix setIdentity.
		angles _ self getAngles: reference.
		((aVector at: 1) = asIs) ifFalse: [ angles at: 1 put: (aVector at: 1) ].
		((aVector at: 2) = asIs) ifFalse: [ angles at: 2 put: (aVector at: 2) ].
		((aVector at: 3) = asIs) ifFalse: [ angles at: 3 put: (aVector at: 3) ].
		vectorMatrix rotation: (B3DVector3 x: (angles at: 1) y: (angles at: 2) z: (angles at: 3)).
		newComposite _ (myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot).
		newComposite _ newComposite composeWith: vectorMatrix.
		newComposite asQuaternion.
					].

	anim object: self
			update: [:tQuat | self setRotationMatrix: (tQuat asMatrix4x4) ]
			getStartState: [ composite asQuaternion ]
			getEndState: endStateFunc
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:16'!
turnTo: aVector duration: aDuration style: aStyle
	"Turns the object to the specified orientation in its parent's coordinate system using the specified style over the specified duration."

	| anim endStateFunc m angles |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the duration to use for turning ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to turn ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	m _ B3DMatrix4x4 identity.

	(aVector isKindOf: WonderlandActor)
		ifTrue: [ endStateFunc _ [
						m setIdentity.
						angles _ aVector getAngles: myParent.
						m rotation: (B3DVector3 x: (angles at: 1) y: (angles at: 2) z: (angles at: 3)).
						m asQuaternion.
								 ]
				]
		ifFalse: [ endStateFunc _ [
						m setIdentity.
						angles _ self getRotationVector.
						((aVector at: 1) = asIs) ifFalse: [ angles x: (aVector at: 1) ].
						((aVector at: 2) = asIs) ifFalse: [ angles y: (aVector at: 2) ].
						((aVector at: 3) = asIs) ifFalse: [ angles z: (aVector at: 3) ].
						m rotation: angles.
						m asQuaternion.
								 ]
				].


	anim object: self
			update: [:tQuat | self setRotationMatrix: (tQuat asMatrix4x4) ]
			getStartState: [ composite asQuaternion ]
			getEndState: endStateFunc
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:22'!
turnTo: aVector eachFrameFor: aLifetime
	"Turns the object to the specified orientation in its parent's coordinate system each frame for aLifetime seconds."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self turnToRightNow: aVector	undoable: false ]
			for: aLifetime.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 11:21'!
turnTo: aVector eachFrameUntil: aCondition
	"Turns the object to the specified orientation in its parent's coordinate system each frame until the condition returns true."

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to turn ' , myName , ' to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long it should turn ' , myName , ' because ', msg.
			^ nil ].

	myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).

	^ self doEachFrame: [ self turnToRightNow: aVector	undoable: false ]
			until: aCondition.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 4/9/1999 14:09'!
turnTo: aVector speed: aSpeed 
	"Turns the object to the specified orientation in its parent's coordinate system at aSpeed turns per second."

	^ self turnTo: aVector duration: (((self angularDistanceTo: aVector) / (aSpeed * 360)) abs)
			style: abruptly.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 4/9/1999 14:09'!
turnTo: aVector speed: aSpeed asSeenBy: reference
	"Turns the object to the specified orientation in the reference's coordinate system at aSpeed turns per second."

	^ self turnTo: aVector duration: (((self angularDistanceTo: aVector) / (aSpeed * 360)) abs)
				asSeenBy: reference style: abruptly.

! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/9/1999 15:56'!
wait
	"Creates an animation where the object merely waits for one second"

	| anim |

	anim _ RelativeAnimation new.

	anim object: self
			update: [:temp | temp ]
			getStartState: [ Interpolateable value: 0 ]
			getEndState: [ 1.0 ]
			getReverseState: [ 1.0 ]
			style: [:elapsed :total | WonderlandStyle abruptlyAfter: elapsed outOf: total]
			duration: 1.0
			undoable: true
			inWonderland: myWonderland.

	^ anim.! !

!WonderlandActor methodsFor: 'primitive behaviors' stamp: 'jsp 3/18/1999 10:51'!
wait: time
	"Creates an animation where the object merely waits for the specified amount of time"

	| anim |

	[ WonderlandVerifier VerifyDuration: time ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine how long ' , myName , ' should wait because ', msg.
			^ nil ].

	anim _ RelativeAnimation new.

	anim object: self
			update: [:temp | temp ]
			getStartState: [ Interpolateable value: 0 ]
			getEndState: [ time ]
			getReverseState: [ time ]
			style: [:elapsed :total | WonderlandStyle abruptlyAfter: elapsed outOf: total]
			duration: time
			undoable: true
			inWonderland: myWonderland.

	^ anim.! !


!WonderlandActor methodsFor: 'get property' stamp: 'ar 6/2/1999 15:31'!
getActiveTexture
	^myTexture isMorph
		ifTrue:[myTexture]
		ifFalse:[nil]! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 2/24/1999 11:46'!
getAngles
	"Return the object's current orientation in its parent's coordinate system"

	| a3DVector anArray |

	anArray _ Array new: 3.
	a3DVector _ composite rotation.

	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	^ anArray.

	! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/18/1999 16:57'!
getAngles: reference
	"Returns the object's orientation relative to a reference object"

	| newComposite anArray a3DVector |

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not determine the angles of ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	newComposite _ reference getMatrixToRoot.
	a3DVector _ (newComposite composeWith: (self getMatrixFromRoot)) rotation.

	anArray _ Array new: 3.
	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	^ anArray.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 18:31'!
getBounds
	"Return the 2D bounds of the receiver as seen by the default camera"
	^self getBoundsFor: myWonderland getDefaultCamera.! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 18:32'!
getBoundsFor: aCamera
	"Return the 2D bounds of the receiver as seen by the camera"
	^aCamera getBoundsForActor: self! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/1/1999 13:26'!
getColor
	"Return the actor's color"

	| tmpArray  |
	tmpArray _ Array new:3.

	tmpArray at:1 put: (myColor red).
	tmpArray at:2 put: (myColor green).
	tmpArray at:3 put: (myColor blue).

	^ tmpArray.! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 18:33'!
getFullBounds
	"Return the 2D bounds of the receiver and its children or nil if not visible"
	^self getFullBoundsFor: myWonderland getDefaultCamera.! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 18:32'!
getFullBoundsFor: aCamera
	"Return the 2D bounds of the receiver and its children or nil if not visible"
	| box bounds |
	box _ self getBoundsFor: aCamera.
	myChildren do:[:child|
		bounds _ child getFullBoundsFor: aCamera.
		bounds == nil ifFalse:[
			box == nil ifTrue:[box _ bounds] ifFalse:[box _ box quickMerge: bounds].
		].
	].
	^box! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/8/1999 16:54'!
getGlobalPosition: aVector
	"Return the global position of the given vector"
	| vv cc |
	vv _ B3DVector3 x: (aVector at: 1) y: (aVector at: 2) z: (aVector at: 3).
	cc _ composite composeWith: scaleMatrix.
	vv _ cc localPointToGlobal: vv.
	^(Array with: vv x with: vv y with: vv z)! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/8/1999 16:53'!
getLocalPosition: aVector
	"Return the local position of the given vector"
	| vv cc |
	vv _ B3DVector3 x: (aVector at: 1) y: (aVector at: 2) z: (aVector at: 3).
	cc _ composite composeWith: scaleMatrix.
	vv _ cc inverseTransformation localPointToGlobal: vv.
	^(Array with: vv x with: vv y with: vv z)! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 4/24/1999 05:25'!
getMaterial
	^myMaterial! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/12/1999 15:22'!
getName
	"Returns the object's name"

	^ myName.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 2/24/1999 12:45'!
getPointOfView
	"Returns the object's position and orientation"

	| anArray a3DVector |

	a3DVector _ composite translation.

	anArray _ Array new: 6.
	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	a3DVector _ composite rotation.
	anArray at: 4 put: (a3DVector x).
	anArray at: 5 put: (a3DVector y).
	anArray at: 6 put: (a3DVector z).

	^ anArray.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/18/1999 16:57'!
getPointOfView: reference
	"Returns the object's position and orientation"

	| newComposite anArray a3DVector |

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can determine the point of view of ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	newComposite _ reference getMatrixToRoot.
	newComposite _ newComposite composeWith: (self getMatrixFromRoot).

	a3DVector _ newComposite translation.

	anArray _ Array new: 6.
	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	a3DVector _ newComposite rotation.
	anArray at: 4 put: (a3DVector x).
	anArray at: 5 put: (a3DVector y).
	anArray at: 6 put: (a3DVector z).

	^ anArray.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 2/10/1999 17:05'!
getPosition
	"Return the object's current position in its parent's coordinate system"

	| a3DVector anArray |

	anArray _ Array new: 3.
	a3DVector _ composite translation.

	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	^ anArray.

	! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/18/1999 16:58'!
getPosition: reference
	"Returns the object's position relative to a reference object"

	| newComposite anArray a3DVector |

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not determine the position of ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	newComposite _ reference getMatrixToRoot.
	a3DVector _ (newComposite composeWith: (self getMatrixFromRoot)) translation.

	anArray _ Array new: 3.
	anArray at: 1 put: (a3DVector x).
	anArray at: 2 put: (a3DVector y).
	anArray at: 3 put: (a3DVector z).

	^ anArray.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/25/1999 14:59'!
getPositionInPicturePlane
	"Returns the actor's position in the picture plane of the default camera"

	| camera d x y z pos |

	camera _ myWonderland getDefaultCamera.

	pos _ self getPosition: camera.
	d _ (camera getFrustum) near.

	z _ (pos at: 3) abs.

	(z = 0) ifTrue: 	[
						x _ 0.
						y _ 0.
					]
			ifFalse: [
						x _ (d / z) * (pos at: 1).
						y _ (d / z) * (pos at: 2).
					].
					
	^ x @ y.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 4/19/1999 15:18'!
getPositionInPicturePlane: aCamera
	"Returns the actor's position in the picture plane of the given camera"

	| d x y z pos |

	pos _ self getPosition: aCamera.
	d _ (aCamera getFrustum) near.

	z _ (pos at: 3) abs.

	(z = 0) ifTrue: 	[
						x _ 0.
						y _ 0.
					]
			ifFalse: [
						x _ (d / z) * (pos at: 1).
						y _ (d / z) * (pos at: 2).
					].
					
	^ x @ y.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/25/1999 15:59'!
getPositionInPixels
	"Returns the actor's position in pixels in the Squeak window"

	| camera morph point x y frustum |

	camera _ myWonderland getDefaultCamera.
	morph _ camera getMorph.

	point _ self getPositionInPicturePlane.

	frustum _ camera getFrustum.

	((point x) < 0) ifTrue: [
			x _ (morph center x) - (((point x) / (frustum left)) * ((morph width) / 2))
						]
				ifFalse: [
			x _ (morph center x) + (((point x) / (frustum right)) * ((morph width) / 2))
						].

	((point y) < 0) ifTrue: [
			y _ (morph center y) + (((point y) / (frustum bottom)) * ((morph height) / 2))
						]
				ifFalse: [
			y _ (morph center y) - (((point y) / (frustum top)) * ((morph height) / 2))
						].

	^ (x @ y) rounded.
	! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 4/22/1999 17:52'!
getPositionInPixels: camera
	"Returns the actor's position in pixels in the Squeak window"

	| morph point x y frustum |

	morph _ camera getMorph.

	point _ self getPositionInPicturePlane: camera.

	frustum _ camera getFrustum.

	((point x) < 0) ifTrue: [
			x _ (morph center x) - (((point x) / (frustum left)) * ((morph width) / 2))
						]
				ifFalse: [
			x _ (morph center x) + (((point x) / (frustum right)) * ((morph width) / 2))
						].

	((point y) < 0) ifTrue: [
			y _ (morph center y) + (((point y) / (frustum bottom)) * ((morph height) / 2))
						]
				ifFalse: [
			y _ (morph center y) - (((point y) / (frustum top)) * ((morph height) / 2))
						].

	^ (x @ y) rounded.
	! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 22:33'!
getProperty: aSymbol
	^self getProperty: aSymbol ifAbsent:[nil]! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/7/1999 22:17'!
getProperty: aSymbol ifAbsent: aBlock
	myProperties == nil ifTrue:[^aBlock value].
	^myProperties at: aSymbol ifAbsent: aBlock! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/19/1999 14:45'!
getSize
	"Returns the scale factor of the actor"

	| anArray meshSize |

	meshSize _ self getBoundingBox extent.

	anArray _ Array new: 3.
	anArray at: 1 put: (meshSize x).
	anArray at: 2 put: (meshSize y).
	anArray at: 3 put: (meshSize z).

	^ anArray.
! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 9/16/1999 16:30'!
getTexturePointer
	^myTexture! !

!WonderlandActor methodsFor: 'get property' stamp: 'ar 11/8/1999 13:14'!
getUserPointOfView
	"Return the user defined point of view for this object"
	^self getProperty: #userPointOfView! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 3/1/1999 11:50'!
getVisibility
	"Returns the actor's visibility"

	^ ((myMaterial ambientPart) alpha)
! !

!WonderlandActor methodsFor: 'get property' stamp: 'jsp 2/11/1999 10:12'!
isHidden
	"Returns true if the object is hidden."

	^ hidden.
! !


!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/19/1999 14:00'!
hide
	"Tell the object that it should not draw itself each frame"

	(myWonderland getUndoStack) push: (UndoShowHide undoHideFor: self).

	self setHidden: true.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 14:39'!
setColor: newColor
	"Set the actor's color"

	 ^ (self setColor: newColor duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 13:58'!
setColor: newColor duration: time
	"Set the actor's color"

	(time = rightNow) ifTrue: [
		[ WonderlandVerifier VerifyColor: newColor ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what color to make ' , myName , ' because ', msg.
				^ nil ].

		self setColorRightNow: newColor undoable: true.
		^ self. ].

	^ (self setColor: newColor duration:time style: gently)

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 13:58'!
setColor: newColor duration: time style: aStyle
	"Set the actor's color"

	| anim aColor |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyColor: newColor ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what color to make ' , myName , ' because ', msg.
			^ nil ].


	[ WonderlandVerifier VerifyDuration: time ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the color of ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use for changing the color of ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	((newColor at: 1) isNumber)
				ifTrue: [ aColor _ B3DColor4 red: (newColor at: 1) green: (newColor at: 2)
										blue: (newColor at: 3) alpha: (myColor alpha) ]
				ifFalse: [ aColor _ Color perform: newColor.
						  aColor _ B3DColor4 red: (aColor red) green: (aColor green)
										blue: (aColor blue) alpha: (myColor alpha) ].

	anim _ AbsoluteAnimation new.
	anim object: self
			update: [:tColor | self setColorVector: tColor]
			getStartState: [self getColorVector]
			getEndState: [ aColor ]
			style: aStyle
			duration: time
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'ar 4/24/1999 05:25'!
setMaterial: aMaterial
	myMaterial _ aMaterial! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/24/1999 10:25'!
setMesh: aMesh
	"Sets the actor's mesh"

	myMesh _ aMesh.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/12/1999 15:22'!
setName: newName
	"Sets the object's name"

	myName _ newName.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/3/1999 17:44'!
setPointOfView: aVector
	"Sets the object's position and orientation"

	^ self setPointOfView: aVector duration: 1.0 style: gently.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/3/1999 17:45'!
setPointOfView: aVector asSeenBy: reference
	"Sets the object's position and orientation"

	^ self setPointOfView: aVector duration: 1.0 asSeenBy: reference style: gently.

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:46'!
setPointOfView: aVector asSeenBy: reference eachFrameFor: aLifetime
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	( aVector isKindOf: WonderlandActor) ifTrue: [
			myWonderland reportErrorToUser: 'Squeak does not allow you to use an Actor to specify the point of view when using asSeenBy.'.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not set the point of view for ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should keep this point of view because ', msg.
			^ nil ].

	positionVector _ Array new: 3.
	positionVector at: 1 put: (aVector at: 1).
	positionVector at: 2 put: (aVector at: 2).
	positionVector at: 3 put: (aVector at: 3).

	rotationVector _ Array new: 3.
	rotationVector at: 1 put: (aVector at: 4).
	rotationVector at: 2 put: (aVector at: 5).
	rotationVector at: 3 put: (aVector at: 6).

	myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

	^ self doEachFrame: [ 
							self moveToRightNow: positionVector undoable: false.
							self turnToRightNow: rotationVector undoable: false.
						]
			for: aLifetime.

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:46'!
setPointOfView: aVector asSeenBy: reference eachFrameUntil: aCondition
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	( aVector isKindOf: WonderlandActor) ifTrue: [
			myWonderland reportErrorToUser: 'Squeak does not allow you to use an Actor to specify the point of view when using asSeenBy.'.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not set the point of view for ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long ' , myName , ' should keep this point of view because ', msg.
			^ nil ].

	positionVector _ Array new: 3.
	positionVector at: 1 put: (aVector at: 1).
	positionVector at: 2 put: (aVector at: 2).
	positionVector at: 3 put: (aVector at: 3).

	rotationVector _ Array new: 3.
	rotationVector at: 1 put: (aVector at: 4).
	rotationVector at: 2 put: (aVector at: 5).
	rotationVector at: 3 put: (aVector at: 6).

	myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

	^ self doEachFrame: [ 
							self moveToRightNow: positionVector undoable: false.
							self turnToRightNow: rotationVector undoable: false.
						]
			until: aCondition.

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:27'!
setPointOfView: aVector duration: aDuration
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	((aDuration = rightNow) or: [ aDuration = eachFrame ]) ifTrue: [
		[ WonderlandVerifier VerifyPointOfView: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
				^ nil ].

		(aVector isKindOf: WonderlandActor)
			ifTrue: [
						positionVector _ aVector.
						rotationVector _ aVector.
					]
			ifFalse: [
						positionVector _ Array new: 3.
						positionVector at: 1 put: (aVector at: 1).
						positionVector at: 2 put: (aVector at: 2).
						positionVector at: 3 put: (aVector at: 3).

						rotationVector _ Array new: 3.
						rotationVector at: 1 put: (aVector at: 4).
						rotationVector at: 2 put: (aVector at: 5).
						rotationVector at: 3 put: (aVector at: 6).
					].

			myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

			(aDuration = eachFrame) ifTrue: [
				^ self doEachFrame: [ 
										self moveToRightNow: positionVector undoable: false.
										self turnToRightNow: rotationVector undoable: false.
									]
											].

			self moveToRightNow: positionVector undoable: false.
			self turnToRightNow: rotationVector undoable: false.
			^ self ].

	^ self setPointOfView: aVector duration: aDuration style: gently.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:46'!
setPointOfView: aVector duration: aDuration asSeenBy: reference
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	((aDuration = rightNow) or: [ aDuration = eachFrame ]) ifTrue: [
			[ WonderlandVerifier VerifyPointOfView: aVector ]
				ifError: [ :msg :rcvr |
					myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
					^ nil ].

			( aVector isKindOf: WonderlandActor) ifTrue: [
					myWonderland reportErrorToUser: 'Squeak does not allow you to use an Actor to specify the point of view when using asSeenBy.'.
					^ nil ].

			[ WonderlandVerifier VerifyReferenceFrame: reference ]
				ifError: [ :msg :rcvr |
					myWonderland reportErrorToUser:
						'Squeak can not set the point of view for ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
					^ nil ].

			positionVector _ Array new: 3.
			positionVector at: 1 put: (aVector at: 1).
			positionVector at: 2 put: (aVector at: 2).
			positionVector at: 3 put: (aVector at: 3).

			rotationVector _ Array new: 3.
			rotationVector at: 1 put: (aVector at: 4).
			rotationVector at: 2 put: (aVector at: 5).
			rotationVector at: 3 put: (aVector at: 6).

			myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

			(aDuration = eachFrame) ifTrue: [
				^ self doEachFrame: [ 
										self moveToRightNow: positionVector undoable: false.
										self turnToRightNow: rotationVector undoable: false.
									]
											].

			self moveToRightNow: positionVector asSeenBy: reference undoable: false.
			self turnToRightNow: rotationVector asSeenBy: reference undoable: false.
			^ self ].

	^ self setPointOfView: aVector duration: aDuration asSeenBy: reference style: gently.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:46'!
setPointOfView: aVector duration: aDuration asSeenBy: reference style: aStyle
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	( aVector isKindOf: WonderlandActor) ifTrue: [
			myWonderland reportErrorToUser: 'Squeak does not allow you to use an Actor to specify the point of view when using asSeenBy.'.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the point of view for ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyReferenceFrame: reference ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak can not set the point of view for ' , myName , ' relative to ' , (reference asString) , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use for changing the point of view for ' , myName , ' because ', msg.
			^ nil ].

	positionVector _ Array new: 3.
	positionVector at: 1 put: (aVector at: 1).
	positionVector at: 2 put: (aVector at: 2).
	positionVector at: 3 put: (aVector at: 3).

	rotationVector _ Array new: 3.
	rotationVector at: 1 put: (aVector at: 4).
	rotationVector at: 2 put: (aVector at: 5).
	rotationVector at: 3 put: (aVector at: 6).

	^ myWonderland doTogether: { self moveTo: positionVector duration: aDuration
												asSeenBy: reference style: aStyle.
								  self turnTo: rotationVector duration: aDuration
												asSeenBy: reference style: aStyle }.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:19'!
setPointOfView: aVector duration: aDuration style: aStyle
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the point of view for ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use for changing the point of view for ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so built the animation"
	(aVector isKindOf: WonderlandActor)
		ifTrue: [
					positionVector _ aVector.
					rotationVector _ aVector.
				]
		ifFalse: [
					positionVector _ Array new: 3.
					positionVector at: 1 put: (aVector at: 1).
					positionVector at: 2 put: (aVector at: 2).
					positionVector at: 3 put: (aVector at: 3).

					rotationVector _ Array new: 3.
					rotationVector at: 1 put: (aVector at: 4).
					rotationVector at: 2 put: (aVector at: 5).
					rotationVector at: 3 put: (aVector at: 6).
				].

	^ myWonderland doTogether: { self moveTo: positionVector duration: aDuration style: aStyle.
								self turnTo: rotationVector duration: aDuration style: aStyle }.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:24'!
setPointOfView: aVector eachFrameFor: aLifetime
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aLifetime ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should keep this point of view because ', msg.
			^ nil ].

	(aVector isKindOf: WonderlandActor)
			ifTrue: [
						positionVector _ aVector.
						rotationVector _ aVector.
					]
			ifFalse: [
						positionVector _ Array new: 3.
						positionVector at: 1 put: (aVector at: 1).
						positionVector at: 2 put: (aVector at: 2).
						positionVector at: 3 put: (aVector at: 3).

						rotationVector _ Array new: 3.
						rotationVector at: 1 put: (aVector at: 4).
						rotationVector at: 2 put: (aVector at: 5).
						rotationVector at: 3 put: (aVector at: 6).
					].

	myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

	^ self doEachFrame: [ 
							self moveToRightNow: positionVector undoable: false.
							self turnToRightNow: rotationVector undoable: false.
						]
			for: aLifetime.

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:25'!
setPointOfView: aVector eachFrameUntil: aCondition
	"Sets the object's position and orientation"

	| positionVector rotationVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPointOfView: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what point of view to assign ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long ' , myName , ' should keep this point of view because ', msg.
			^ nil ].

	(aVector isKindOf: WonderlandActor)
			ifTrue: [
						positionVector _ aVector.
						rotationVector _ aVector.
					]
			ifFalse: [
						positionVector _ Array new: 3.
						positionVector at: 1 put: (aVector at: 1).
						positionVector at: 2 put: (aVector at: 2).
						positionVector at: 3 put: (aVector at: 3).

						rotationVector _ Array new: 3.
						rotationVector at: 1 put: (aVector at: 4).
						rotationVector at: 2 put: (aVector at: 5).
						rotationVector at: 3 put: (aVector at: 6).
					].

	myWonderland getUndoStack push: (UndoPOVChange for: self
														from: (self getPointOfView)).

	^ self doEachFrame: [ 
							self moveToRightNow: positionVector undoable: false.
							self turnToRightNow: rotationVector undoable: false.
						]
			until: aCondition.

! !

!WonderlandActor methodsFor: 'set property' stamp: 'ar 11/7/1999 22:19'!
setProperty: aSymbol toValue: anObject
	anObject == nil ifTrue:["Remove property"
		myProperties ifNotNil:[^myProperties removeKey: aSymbol ifAbsent:[nil]]].
	myProperties == nil ifTrue:[myProperties _ IdentityDictionary new].
	myProperties at: aSymbol put: anObject.! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/4/1999 16:07'!
setSize: aVector
	"Sets the object's position and orientation"

	^ (self setSize: aVector duration: 1.0 style: gently).

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/18/1999 15:07'!
setSize: aVector duration: time
	"Sets the object's position and orientation"

	(time = rightNow) ifTrue: [
		[ WonderlandVerifier VerifyTriple: aVector ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what size to make ' , myName , ' because ', msg.
				^ nil ].

		self setSizeRightNow: aVector undoable: true.
		^ self. ].

	^ (self setSize: aVector duration:time style: gently).

! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/19/1999 15:21'!
setSize: aVector duration: time style: aStyle
	"Sets the object's position and orientation"

	| meshSize |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTriple: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what size to make ' , myName , ' because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	meshSize _ self getBoundingBox extent.

	"Now make sure we don't accidentally divide by zero"
	((meshSize x) = 0) ifTrue: [ aVector at: 1 put: 1.
							    meshSize x: 1 ].

	((meshSize y) = 0) ifTrue: [ aVector at: 2 put: 1.
							    meshSize y: 1 ].

	((meshSize z) = 0) ifTrue: [ aVector at: 3 put: 1.
							    meshSize z: 1 ].

	^ self resizeTopToBottom: (aVector at: 2) / (meshSize y)
			leftToRight: (aVector at: 1) / (meshSize x)
			frontToBack: (aVector at: 3) / (meshSize z)
			duration: time
			style: aStyle.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'ar 9/14/1999 20:02'!
setTexture: textureFile
	"Sets the object's texture"
	(myWonderland getUndoStack) push: (UndoTextureChange for: self from: myTexture).
	myTexture _ myWonderland makeTextureFrom: textureFile flipping: true.
	myChildren do: [:child | (child isPart) ifTrue: [ child setTexturePointer: myTexture ] ].
! !

!WonderlandActor methodsFor: 'set property' stamp: 'ar 5/27/1999 16:49'!
setTextureFromUser
	"Set the texture from the user"
	| form |
	form _ Form fromUser.
	self setTexturePointer: form asTexture.! !

!WonderlandActor methodsFor: 'set property' stamp: 'ar 11/8/1999 13:14'!
setUserPointOfView: aPOV
	"Return the user defined point of view for this object"
	^self setProperty: #userPointOfView toValue: aPOV! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/1/1999 14:15'!
setVisibility: newVisibility
	"Sets the current object's visibility"

	^ (self setVisibility: newVisibility duration: 1.0
			style: gently).
! !

!WonderlandActor methodsFor: 'set property' stamp: 'bf 3/16/2000 19:00'!
setVisibility: newVisibility duration: time
	"Sets the current object's visibility"

	(time = rightNow) ifTrue: [
		[ WonderlandVerifier Verify0To1Number: newVisibility ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what visibility to make ' , myName , ' because ', msg.
				^ nil ].

		self setVisibilityRightNow: newVisibility undoable: true.
		^ self. ].

	^ (self setVisibility: newVisibility duration: time
			style: gently).

! !

!WonderlandActor methodsFor: 'set property' stamp: 'bf 3/16/2000 19:00'!
setVisibility: newVisibility duration: time style: aStyle
	"Sets the current object's visibility"

	| anim |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier Verify0To1Number: newVisibility ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what visibility to make ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: time ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the visibility of ' , myName , ' because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use for changing the visibility of ' , myName , ' because ', msg.
			^ nil ].

	anim _ AbsoluteAnimation new.
	anim object: self
			update: [:tColor | self setColorVector: tColor]
			getStartState: [self getColorVector]
			getEndState: [B3DColor4 red: (myColor red) green: (myColor green)
						blue: (myColor blue) alpha: newVisibility]
			style: aStyle
			duration: time
			undoable: true
			inWonderland: myWonderland.


	^ anim.
! !

!WonderlandActor methodsFor: 'set property' stamp: 'jsp 3/19/1999 14:01'!
show
	"Tell the object that it should draw itself each frame"

	(myWonderland getUndoStack) push: (UndoShowHide undoShowFor: self).

	self setHidden: false.
! !


!WonderlandActor methodsFor: 'private' stamp: 'ar 11/8/1999 01:07'!
adjustToTextureIfNecessary
	| texExtent texRatio myExtent myRatio |
	"Adjust the receiver to the texture extent if necessary"
	(self getProperty: #adjustToTexture) == true ifFalse:[^self]. "Don't adjust"
	texExtent _ self getTexturePointer extent.
	texRatio _ texExtent x / texExtent y.
	myExtent _ self getBoundingBox extent.
	myRatio _ myExtent x / myExtent y.
	self resize: (Array with: texRatio / myRatio with: 1.0 with: 1.0) duration: 2! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 4/8/1999 14:46'!
getChildNamed: childName
	"Returns the child with the specified name if it is a child of this object"

	| theChild nameParts |

	childName at: 1 put: ((childName at: 1) asLowercase).

	"First see if they're looking for me"
	(myName = childName) ifTrue: [ ^ self ].

	nameParts _ childName findTokens: ' '.
	nameParts do: [:name | name at: 1 put: ((name at: 1) asLowercase) ].

	((nameParts first) = myName) ifTrue: [ nameParts removeFirst ].
	theChild _ self.
	nameParts do: [:aName | theChild _ theChild perform: (aName asSymbol) ].
	^ theChild.! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/1/1999 13:27'!
getColorVector
	"Returns the actor's color/alpha vector"

	^ myColor.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/24/1999 16:15'!
getComposite
	"Returns the actor's composite matrix"

	^ composite.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/22/1999 14:30'!
getMatrixFromRoot
	"Returns the composite transformation matrix from the root down to this instance"

	^ (myParent getMatrixFromRoot) composeWith: composite.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/22/1999 14:32'!
getMatrixToRoot
	"Returns the composite transformation matrix from this instance up to the root"

	^ ((myParent getMatrixFromRoot) composeWith: composite) inverseTransformation.
! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 8/20/1999 00:56'!
getMesh
	^myMesh! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 8/31/2000 20:01'!
getMeshAnimationParameter
	myMesh == nil ifTrue:[^0.0].
	^myMesh animationParameter! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/29/1999 14:44'!
getPointAtMatrix: target
	"create a matrix such that the actor looks at the target using the upDirection"
	| aVector m1 m2 |

	m1 _ B3DMatrix4x4 identity.
	m2 _ B3DMatrix4x4 identity.

	"Calculate the vector to look along"
	(target isKindOf: WonderlandActor)
		ifTrue: [ aVector _ (target getMatrixFromRoot translation) -
								(self getMatrixFromRoot translation) ]
		ifFalse: [ (target isKindOf: Point)
					ifTrue: [
							aVector _ ((myWonderland getDefaultCamera)
								transformScreenPointToScenePoint: target atDepthOf: self).
							aVector _ B3DVector3 x: (aVector at: 1) y: (aVector at: 2)
												z: (aVector at: 3).
							aVector _ aVector - (self getMatrixFromRoot translation).
							]
					ifFalse: [
							aVector _ (B3DVector3 x: (target at: 1) y: (target at: 2)
									z: (target at: 3)) - (self getMatrixFromRoot translation).
							].
				].


	"Calculate the rotation around the z-axis"
	((aVector z) = 0) ifTrue: [ ((aVector x ) > 0) ifTrue: [ m1 rotationAroundY: 90 ]
												ifFalse: [ ((aVector x) = 0) 
													ifTrue: [ m1 rotationAroundY: 0 ]
													ifFalse: [ m1 rotationAroundY: -90 ] ]
							]
					ifFalse: [ ((aVector z) > 0)
									ifTrue: [ m1 rotationAroundY:
										(((aVector x) / (aVector z)) arcTan radiansToDegrees) ]
									ifFalse: [ m1 rotationAroundY: (180 +
										(((aVector x) / (aVector z)) arcTan radiansToDegrees)) ]
							].

	((aVector length) = 0) ifFalse: [
		m2 rotationAroundX: (((aVector y) / (aVector length)) arcSin radiansToDegrees negated) ].

	^ (myParent getMatrixToRoot) composeWith: (m1 composeWith: m2).
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/10/1999 16:45'!
getPositionVector
	"Returns the current position as a vector."

	^ (composite translation).
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/24/1999 11:11'!
getRotationVector
	"Returns the current rotation as a vector."

	^ (composite rotation).
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/24/1999 14:34'!
getSizeVector
	"Returns the object's current size as a vector"

	^ (B3DVector3 x: (scaleMatrix a11) y: (scaleMatrix a22) z: (scaleMatrix a33)).
! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 8/19/1999 11:40'!
hasMesh
	^myMesh notNil! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/12/1999 10:13'!
loadMeshFromFile: meshFile
	"Load this object's mesh from the specified file"

	| dict words |

	dict _ myWonderland getSharedMeshDict.

	myMesh _ dict at: meshFile
				ifAbsent: [
							words _ (meshFile findTokens: #.).

							((words last) = 'vfb') ifTrue: [
								myMesh _ WonderlandMesh fromVFBFile: meshFile ].

							((words last) = 'obj') ifTrue: [
								myMesh _ WonderlandMesh fromOBJFile: meshFile ].

							dict at: meshFile put: myMesh.
						].
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/23/1999 12:03'!
makeVectorFromDistance: aDistance andDirection: aDirection
	"Generates the vector the object should move along using the specified direction"

	| a3DVector |

	(aDirection = right) ifTrue: [a3DVector _ B3DVector3 x: aDistance y: 0 z: 0]
		ifFalse: [(aDirection = left) ifTrue: [a3DVector _ B3DVector3 x: -1 * aDistance y:0 z:0]
		ifFalse: [(aDirection = up) ifTrue: [a3DVector _ B3DVector3 x: 0 y: aDistance z:0]
		ifFalse: [(aDirection = down) ifTrue: [a3DVector _ B3DVector3 x: 0 y: -1 * aDistance z:0]
		ifFalse: [(aDirection = forward) ifTrue: [a3DVector _ B3DVector3 x: 0 y: 0 z: aDistance]
		ifFalse: [((aDirection = back) or: [aDirection = #backward])
					 ifTrue: [a3DVector _ B3DVector3 x: 0 y: 0 z: -1 * aDistance]
		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].

	^ a3DVector.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/18/1999 10:18'!
moveRightNow: aDirection distance: aDistance asSeenBy: reference undoable: isUndoable
	"Move this object in the specified direction instantaneously"

	| a3DVector aMatrix newComposite |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoPositionChange for: self from: (self getPosition)).
						].

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	aMatrix _ B3DMatrix4x4 identity translation: a3DVector.

	newComposite _ (reference getMatrixToRoot) composeWith: (self getMatrixFromRoot).
	composite _ (((myParent getMatrixToRoot)
							composeWith: (reference getMatrixFromRoot))
							composeWith: aMatrix)
							composeWith: newComposite.


! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/18/1999 10:18'!
moveRightNow: aDirection distance: aDistance undoable: isUndoable
	"Move this object in the specified direction instantaneously"

	| a3DVector aMatrix |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoPositionChange for: self from: (self getPosition)).
						].

	[ a3DVector _ self makeVectorFromDistance: aDistance andDirection: aDirection. ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak does not know how to move ' , myName , ' in that direction.'.
			^ nil ].

	aMatrix _ B3DMatrix4x4 identity translation: a3DVector.

	composite _ composite composeWith: aMatrix.


! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 12:42'!
moveToRightNow: aVector asSeenBy: reference undoable: isUndoable
	"Move this object in the specified direction instantaneously"

	| pos aMatrix newComposite |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoPositionChange for: self from: (self getPosition)).
						].

	aMatrix _ B3DMatrix4x4 identity.
	pos _ self getPosition: reference.
	((aVector at: 1) = asIs) ifFalse: [ pos at: 1 put: (aVector at: 1) ].
	((aVector at: 2) = asIs) ifFalse: [ pos at: 2 put: (aVector at: 2) ].
	((aVector at: 3) = asIs) ifFalse: [ pos at: 3 put: (aVector at: 3) ].
	aMatrix translation: (B3DVector3 x: (pos at: 1) y: (pos at: 2) z: (pos at: 3)).
	newComposite _ (myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot).
	newComposite _ newComposite composeWith: aMatrix.
		newComposite translation.
	self setPositionVector: (newComposite translation).

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 12:39'!
moveToRightNow: aVector undoable: isUndoable
	"Move this object in the specified direction instantaneously"

	| pos |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoPositionChange for: self from: (self getPosition)).
						].

	(aVector isKindOf: WonderlandActor)
		ifTrue: [ pos _ aVector getPositionVector ]
		ifFalse: [ pos _ self getPositionVector.
				  ((aVector at: 1) = asIs) ifFalse: [pos x: (aVector at: 1) ].
				  ((aVector at: 2) = asIs) ifFalse: [pos y: (aVector at: 2) ].
				  ((aVector at: 3) = asIs) ifFalse: [pos z: (aVector at: 3) ].
				].

	self setPositionVector: pos.

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 16:02'!
placeRightNow: aLocation object: aTarget undoable: isUndoable
	"Instantaneously move the object to the specified place."

	 | selfPos selfBBox selfLBB selfRUF objBBox objLBB objRUF pos |

	selfBBox _ self getBoundingBox: aTarget.
	selfLBB _ selfBBox origin.
	selfRUF _ selfBBox corner.

	objBBox _ aTarget getBoundingBox.
	objLBB _ objBBox origin.
	objRUF _ objBBox corner.

	selfPos _ self getPosition: aTarget.

	((aLocation = onTopOf) or: [ aLocation = above])
	ifTrue: [
				pos _ { 0. (objRUF y) + ((selfPos at: 2) - (selfLBB y)). 0}
			]
 	ifFalse: [

	((aLocation = onBottomOf) or: [ (aLocation = beneath) or: [ aLocation = below ] ])
	ifTrue: [
				pos _ { 0. (objLBB y) - ((selfRUF y) - (selfPos at: 2)). 0}
			]
	ifFalse: [

	(aLocation = toLeftOf)
	ifTrue: [
				pos _ { (objLBB x) - ((selfRUF x) - (selfPos at: 1)). 0. 0 }
			]
	ifFalse: [

	(aLocation = toRightOf)
	ifTrue: [
				pos _ { (objRUF x) + ((selfPos at: 1) - (selfLBB x)). 0. 0 }
			]
	ifFalse: [

	(aLocation = inFrontOf)
	ifTrue: [
				pos _ { 0. 0. (objRUF z) + ((selfPos at: 3) - (selfLBB z)) }
			]
	ifFalse: [

	((aLocation = inBackOf) or: [ aLocation = behind])
	ifTrue: [
				pos _ { 0. 0. (objLBB z) - ((selfRUF z) - (selfPos at:3)) }
			]
	ifFalse: [

	(aLocation = onCeilingOf)
	ifTrue: [
				pos _ { 0. (objRUF y) - ((selfRUF y) - (selfPos at:2)). 0}
			]
	ifFalse: [

	(aLocation = onFloorOf)
	ifTrue: [
				pos _ { 0. (objLBB y) + ((selfPos at: 2) - (selfLBB y)). 0}
			]
	ifFalse: [ self error: 'Unrecognized target surface' ]]]]]]]].


	self moveToRightNow: pos asSeenBy: aTarget undoable: isUndoable.! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 15:57'!
pointAtRightNow: aTarget undoable: isUndoable
	"Turn this object to the specified orientation instantaneously"

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoRotationChange for: self from: (self getAngles)).
						].

	self setRotationMatrix: (self getPointAtMatrix: aTarget).


! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 11/10/1999 15:30'!
postCopy
	| props |
	composite _ composite copy.
	scaleMatrix _ scaleMatrix copy.
	props _ myProperties.
	myProperties _ nil.
	props = nil ifFalse:[
		props keysAndValuesDo:[:k :v| self setProperty: k toValue: v]].! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 4/5/1999 14:55'!
removeFromScene
	"Remove this actor from the scene."

	"Break ties with the current parent"
	myParent removeChild: self.

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 4/9/1999 14:35'!
reparentTo: anObject
	"Make this actor a child of the specified object."

	| newComposite classList parentClass |

	classList _ myWonderland getActorClassList.

	"First break ties with the current parent"
	myParent removeChild: self.
	parentClass _ myParent class.

	(parentClass == WonderlandScene)
		ifTrue: [
				myWonderland getNamespace removeKey: myName ifAbsent: [].
				]
		ifFalse: [
				classList remove: parentClass.
				parentClass removeSelector: (myName asSymbol).
				parentClass removeInstVarName: myName.
				classList addLast: (myParent class).
				].

	"Figure out the new composite transformation matrix"
	newComposite _ anObject getMatrixToRoot.
	newComposite _ newComposite composeWith: (self getMatrixFromRoot).
	
	"Now build ties with the new parent"
	anObject addChild: self.
	myParent _ anObject.
	parentClass _ myParent class.

	(parentClass == WonderlandScene)
		ifTrue: [
				(myWonderland getNamespace at: myName ifAbsent: [ nil ])
					ifNotNil: [ myName _ myWonderland uniqueNameFrom: myName ].

				(myWonderland getNamespace at: myName put: self).
				]
		ifFalse: [
				myName _ parentClass uniqueNameFrom: myName.		
				classList remove: parentClass.
				myParent addInstanceVarNamed: myName withValue: self.
				(myParent class) compile: (myName , '
											^ ' , myName, '.').
				classList addLast: (myParent class).
				].

	composite _ newComposite.

	"Now update the actor browser"
	myWonderland getEditor updateActorBrowser.! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 17:01'!
resizeRightNow: aVector undoable: isUndoable
	"Set this object's size instantaneously"

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).
						].

	self scaleByVector: aVector.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/18/1999 10:40'!
rollRightNow: aDirection numberOfTurns: numTurns asSeenBy: reference undoable: isUndoable
	"Turn the object instantaneously the specified number of turns in the specified direction"

	| tMatrix degrees  newMatrix |

	tMatrix _ B3DMatrix4x4 identity.
	degrees _ 360 * numTurns.

	(isUndoable = true) ifTrue: [
		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).
						].

	(aDirection = left) ifTrue: [ tMatrix rotationAroundZ: degrees ]
	ifFalse: [(aDirection = right) ifTrue: [ tMatrix rotationAroundZ: (degrees negated) ]
								ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
										^ nil ]].

	newMatrix _ reference getMatrixToRoot.
	newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
	composite _ (((myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot))
											composeWith: tMatrix)
											composeWith: newMatrix.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/18/1999 10:40'!
rollRightNow: aDirection numberOfTurns: numTurns undoable: isUndoable
	"Turn the object instantaneously the specified number of turns in the specified direction"

	| tMatrix degrees  |

	tMatrix _ B3DMatrix4x4 identity.
	degrees _ 360 * numTurns.

	(isUndoable = true) ifTrue: [
		myWonderland getUndoStack push: (UndoRotationChange for: self from: (self getAngles)).
						].

	(aDirection = left) ifTrue: [ tMatrix rotationAroundZ: degrees ]
		ifFalse: [(aDirection = right) ifTrue: [ tMatrix rotationAroundZ: (degrees negated) ]
									ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to roll ' , myName , ' ', (aDirection asString) , '.'.
											^ nil ]].

	self rotateByMatrix: tMatrix.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/10/1999 16:46'!
rotateByMatrix: aMatrix
	"Rotate the object by composing its rotation matrix with the given matrix."

	composite _ composite composeWith: aMatrix.! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/11/1999 08:57'!
scaleByMatrix: aMatrix
	"Scale the object by composing its scale matrix with the given matrix."

	scaleMatrix _ scaleMatrix composeWith: aMatrix.! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/19/1999 11:50'!
scaleByVector: aVector
	"Scale the object by the given vector."

	| aMatrix |
	aMatrix _ B3DMatrix4x4 identity.

	"Scale my matrix"
	aMatrix scalingX: (aVector x) y: (aVector y) z: (aVector z).
	scaleMatrix _ scaleMatrix composeWith: aMatrix.

	"Now scale my parts"
	myChildren do: [:child | (child isPart) ifTrue: [
								child setPositionVector: (child getPositionVector) * aVector.
								child scaleByVector: aVector
												].
					].
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 16:33'!
setColorRightNow: newColor undoable: isUndoable
	"Change this instance's color instantaneously"

	| aColor |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoColorChange for: self from: (self getColor)) ].

	((newColor at: 1) isNumber)
				ifTrue: [ aColor _ B3DColor4 red: (newColor at: 1) green: (newColor at: 2)
										blue: (newColor at: 3) alpha: (myColor alpha) ]
				ifFalse: [ aColor _ Color perform: newColor.
						  aColor _ B3DColor4 red: (aColor red) green: (aColor green)
										blue: (aColor blue) alpha: (myColor alpha) ].

	self setColorVector: aColor.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 4/23/1999 15:01'!
setColorVector: aColor
	"Instaneously sets the object's color/alpha vector and copies it down the object tree for all objects that are parts of this object"

	"Set our color"
	myColor _ aColor.
	myMaterial ambientPart: myColor.
	myMaterial diffusePart: myColor.
	myMaterial specularPart: myColor.

	"Set the color of our parts"
	myChildren do: [:child | (child isPart) ifTrue: [child setColorVector: aColor] ].
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/12/1999 16:38'!
setComposite: newComposite
	"Sets the actor's composite matrix"

	composite _ newComposite.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/19/1999 13:55'!
setHidden: aBoolean
	"Set the object's hidden status (including its parts)"

	hidden _ aBoolean.

	"Set the show/hide status of our parts"
	myChildren do: [:child | (child isPart) ifTrue: [child setHidden: aBoolean] ].
! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 8/31/2000 20:03'!
setMeshAnimationParameter: param
	myMesh == nil ifTrue:[^self].
	myMesh animationParameter: param! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 9/17/1999 14:23'!
setPivot: aVector
	"Modify the object to use the specified point as the pivot point."

	| matrix invMatrix b3dVector |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyTarget: aVector ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what pivot to use because ', msg.
			^ nil ].


	"Our parameters check out, so change the pivot"
	(aVector isKindOf: WonderlandActor)
		ifTrue: [ matrix _ aVector getMatrixFromRoot. ]
		ifFalse: [ b3dVector _ B3DVector3 x: (aVector at: 1) y: (aVector at: 2)
									z: (aVector at: 3).
				  matrix _ B3DMatrix4x4 identity translation: b3dVector ].

	"Add an undo action"
	b3dVector _ self getMatrixFromRoot translation.
	myWonderland getUndoStack push: (UndoAction new: [self setPivot: b3dVector ]).

	invMatrix _ (matrix inverseTransformation) composeWith: (self getMatrixFromRoot).

	myMesh ifNotNil: [ myMesh _ myMesh copy.
					    myMesh vertices: (myMesh vertices copy).
					    myMesh transformBy: invMatrix ].

	composite _ (myParent getMatrixToRoot) composeWith: matrix.

	(self getChildren) do: [:child | child setComposite:
										(invMatrix composeWith: (child getComposite)) ].

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/10/1999 16:46'!
setPositionVector: aVector
	"Instantaneously sets the actor's current position"

	composite translation: aVector.

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/25/1999 09:43'!
setRotationMatrix: aMatrix
	"Rotate the object by blamming the rotation component of its matrix with the given matrix."

	composite a11: (aMatrix a11).
	composite a12: (aMatrix a12).
	composite a13: (aMatrix a13).

	composite a21: (aMatrix a21).
	composite a22: (aMatrix a22).
	composite a23: (aMatrix a23).

	composite a31: (aMatrix a31).
	composite a32: (aMatrix a32).
	composite a33: (aMatrix a33).
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 2/24/1999 09:54'!
setRotationVector: aVector
	"Instantaneously blam the actor's rotation"

	composite rotation: aVector.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/19/1999 16:07'!
setSizeRightNow: aVector undoable: isUndoable
	"Set this object's size instantaneously"

	| meshSize |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoSizeChange for: self from: (self getSize)).
						].

	meshSize _ self getBoundingBox extent.

	"Now make sure we don't accidentally divide by zero"
	((meshSize x) = 0) ifTrue: [ aVector at: 1 put: 1.
							    meshSize x: 1 ].

	((meshSize y) = 0) ifTrue: [ aVector at: 2 put: 1.
							    meshSize y: 1 ].

	((meshSize z) = 0) ifTrue: [ aVector at: 3 put: 1.
							    meshSize z: 1 ].

	^ self scaleByVector: (B3DVector3 x: ((aVector at: 1) / (meshSize x))
									y: ((aVector at: 2) / (meshSize y))
									z: ((aVector at: 3) / (meshSize z)) ).


! !

!WonderlandActor methodsFor: 'private' stamp: 'ar 6/2/1999 14:05'!
setTexturePointer: texture
	"Sets the object's texture"
	myTexture _ texture.
	self partsDo:[:part| part setTexturePointer: texture].
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 16:42'!
setVisibilityRightNow: newVisibility undoable: isUndoable
	"Change this instance's visibility instantaneously"

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoVisibilityChange for: self
																 from: (self getVisibility)) ].

	self setColorVector: (B3DColor4 red: (myColor red) green: (myColor green)
						blue: (myColor blue) alpha: newVisibility).
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 15:25'!
turnRightNow: aDirection numberOfTurns: numTurns asSeenBy: reference undoable: isUndoable
	"Turn the object instantaneously the specified number of turns in the specified direction"

	| tMatrix degrees  newMatrix |

	tMatrix _ B3DMatrix4x4 identity.
	degrees _ 360 * numTurns.

	(isUndoable = true) ifTrue: [
		myWonderland getUndoStack push: (UndoPOVChange for: self from: (self getPointOfView)).
						].

	(aDirection = right) ifTrue: [ tMatrix rotationAroundY: degrees ]
		ifFalse: [(aDirection = left) ifTrue: [ tMatrix rotationAroundY: (degrees negated) ]

		ifFalse: [(((aDirection = up) or: [aDirection = back]) or: [aDirection = backward])
			ifTrue: [ tMatrix rotationAroundX: (degrees negated) ]

		ifFalse: [((aDirection = down) or: [aDirection = forward]) ifTrue: [
			tMatrix rotationAroundX: degrees ]

		ifFalse: [(aDirection = ccw) ifTrue: [ tMatrix rotationAroundZ: degrees ]

		ifFalse: [(aDirection = cw) ifTrue: [ tMatrix rotationAroundZ: (degrees negated) ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].

	newMatrix _ reference getMatrixToRoot.
	newMatrix _ newMatrix composeWith: (self getMatrixFromRoot).
	composite _ (((myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot))
											composeWith: tMatrix)
											composeWith: newMatrix.

! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 14:59'!
turnRightNow: aDirection numberOfTurns: numTurns undoable: isUndoable
	"Turn the object instantaneously the specified number of turns in the specified direction"

	| tMatrix degrees  |

	tMatrix _ B3DMatrix4x4 identity.
	degrees _ 360 * numTurns.

	(isUndoable = true) ifTrue: [
		myWonderland getUndoStack push: (UndoRotationChange for: self from: (self getAngles)).
						].

	(aDirection = right) ifTrue: [ tMatrix rotationAroundY: degrees ]
		ifFalse: [(aDirection = left) ifTrue: [ tMatrix rotationAroundY: (degrees negated) ]

		ifFalse: [(((aDirection = up) or: [aDirection = back]) or: [aDirection = backward])
			ifTrue: [ tMatrix rotationAroundX: (degrees negated) ]

		ifFalse: [((aDirection = down) or: [aDirection = forward]) ifTrue: [
			tMatrix rotationAroundX: degrees ]

		ifFalse: [(aDirection = ccw) ifTrue: [ tMatrix rotationAroundZ: degrees ]

		ifFalse: [(aDirection = cw) ifTrue: [ tMatrix rotationAroundZ: (degrees negated) ]

		ifFalse: [ self error: 'Unrecognized direction' ]]]]]].

	self rotateByMatrix: tMatrix.
! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 15:48'!
turnToRightNow: aVector asSeenBy: reference undoable: isUndoable
	"Turn this object to the specified orientation instantaneously"

	| m angles newComposite |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoRotationChange for: self from: (self getAngles)).
						].

	m _ B3DMatrix4x4 identity.
	angles _ self getAngles: reference.
	((aVector at: 1) = asIs) ifFalse: [ angles at: 1 put: (aVector at: 1) ].
	((aVector at: 2) = asIs) ifFalse: [ angles at: 2 put: (aVector at: 2) ].
	((aVector at: 3) = asIs) ifFalse: [ angles at: 3 put: (aVector at: 3) ].
	m rotation: (B3DVector3 x: (angles at: 1) y: (angles at: 2) z: (angles at: 3)).
	newComposite _ (myParent getMatrixToRoot) composeWith: (reference getMatrixFromRoot).
	self setRotationMatrix: (newComposite composeWith: m).


! !

!WonderlandActor methodsFor: 'private' stamp: 'jsp 3/8/1999 15:43'!
turnToRightNow: aVector undoable: isUndoable
	"Turn this object to the specified orientation instantaneously"

	| m angles |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoRotationChange for: self from: (self getAngles)).
						].

	m _ B3DMatrix4x4 identity.

	(aVector isKindOf: WonderlandActor)
		ifTrue: [ angles _ aVector getAngles: myParent.
				  m rotation: (B3DVector3 x: (angles at: 1) y: (angles at: 2) z: (angles at: 3)).
				]
		ifFalse: [ angles _ self getRotationVector.
				  ((aVector at: 1) = asIs) ifFalse: [ angles x: (aVector at: 1) ].
				  ((aVector at: 2) = asIs) ifFalse: [ angles y: (aVector at: 2) ].
				  ((aVector at: 3) = asIs) ifFalse: [ angles z: (aVector at: 3) ].
				  m rotation: angles.
				].

	self setRotationMatrix: m.

! !


!WonderlandActor methodsFor: 'do-ing' stamp: 'jsp 3/18/1999 17:07'!
do: aBlock
	"Build an animation that causes the object to execute the block"

	| anim |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyZeroArgumentBlock: aBlock ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not make ' , myName , ' do what you asked because ', msg.
			^ nil ].

	anim _ RelativeAnimation new.

	anim object: self
		update: [:tmp | aBlock value ]
		getStartState: [ Interpolateable value: 0 ]
		getEndState: [ 1 ]
		getReverseState: [ 1 ]
		style: abruptly
		duration: 0
		undoable: false
		inWonderland: myWonderland.

	^ anim.! !

!WonderlandActor methodsFor: 'do-ing' stamp: 'jsp 3/30/1999 11:38'!
doEachFrame: aBlock
	"Build an action that causes the object to execute the block every frame"

	| newAction |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyZeroArgumentBlock: aBlock ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not make ' , myName , ' do what you asked because ', msg.
			^ nil ].

	newAction _ Action do: aBlock toObject: self inScheduler: (myWonderland getScheduler).
	(myWonderland getUndoStack) push:
			(UndoByStopping new: newAction in: (myWonderland getUndoStack)).

	^ newAction.! !

!WonderlandActor methodsFor: 'do-ing' stamp: 'jsp 3/30/1999 11:38'!
doEachFrame: aBlock for: aDuration
	"Build an action that causes the object to execute the block every frame for the specified amount of time"

	| newAction |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyZeroArgumentBlock: aBlock ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not make ' , myName , ' do what you asked because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNonNegativeNumber: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine how long ' , myName , ' should do this because ', msg.
			^ nil ].

	newAction _ Action do: aBlock eachframefor: aDuration toObject: self
						inScheduler: (myWonderland getScheduler).
	(myWonderland getUndoStack) push:
			(UndoByStopping new: newAction in: (myWonderland getUndoStack)).

	^ newAction.
! !

!WonderlandActor methodsFor: 'do-ing' stamp: 'jsp 3/30/1999 11:39'!
doEachFrame: aBlock until: aCondition
	"Build an action that causes the object to execute the block every frame until the specified condition is true"

	| newAction |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyZeroArgumentBlock: aBlock ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not make ' , myName , ' do what you asked because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyCondition: aCondition ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine for how long ' , myName , ' should do this because ', msg.
			^ nil ].

	newAction _ Action do: aBlock eachframeuntil: aCondition toObject: self
						inScheduler: (myWonderland getScheduler).
	(myWonderland getUndoStack) push:
			(UndoByStopping new: newAction in: (myWonderland getUndoStack)).

	^ newAction.! !


!WonderlandActor methodsFor: 'animated state' stamp: 'jsp 3/9/1999 16:18'!
getActions
	"Return the actions currently affecting this object"

	^ (myWonderland getScheduler) getActionsFor: self.
! !

!WonderlandActor methodsFor: 'animated state' stamp: 'jsp 3/9/1999 16:18'!
getAnimations
	"Return the animations currently affecting this object"

	^ (myWonderland getScheduler) getAnimationsFor: self.
! !

!WonderlandActor methodsFor: 'animated state' stamp: 'jsp 3/15/1999 16:15'!
pause
	"Pause any actions and animations associated with this object"

	| scheduler |

	scheduler _ myWonderland getScheduler.

	(scheduler getAnimationsFor: self) do: [:anim | anim pause ].

	(scheduler getActionsFor: self) do: [:action | action pause ].

	myChildren do: [:child | (child isPart) ifTrue: [ child pause ] ].! !

!WonderlandActor methodsFor: 'animated state' stamp: 'jsp 3/15/1999 16:15'!
resume
	"Resume any actions and animations associated with this object"

	| scheduler |

	scheduler _ myWonderland getScheduler.

	(scheduler getAnimationsFor: self) do: [:anim | anim resume ].

	(scheduler getActionsFor: self) do: [:action | action resume ].

	myChildren do: [:child | (child isPart) ifTrue: [ child resume ] ].! !

!WonderlandActor methodsFor: 'animated state' stamp: 'jsp 3/15/1999 16:15'!
stop
	"Stop any actions and animations associated with this object"

	| scheduler |

	scheduler _ myWonderland getScheduler.

	(scheduler getAnimationsFor: self) do: [:anim | anim stop ].

	(scheduler getActionsFor: self) do: [:action | action stop ].

	myChildren do: [:child | (child isPart) ifTrue: [ child stop ] ].! !


!WonderlandActor methodsFor: 'printing' stamp: 'ar 4/18/1999 00:49'!
printOn: aStream
	aStream 
		nextPutAll: self class name;
		nextPut:$<;
		print: myName;
		nextPut:$>.! !


!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 17:26'!
addResponse: aReaction to: evtType
	"Add a new response to the given event type"

	| newReaction currentReactions |

	(myReactions includesKey: evtType)
		ifFalse: [ myReactions at: evtType put: OrderedCollection new ].

	currentReactions _ myReactions at: evtType.

	newReaction _ WonderlandReaction new: aReaction.

	currentReactions addLast: newReaction.

	^ newReaction.
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 13:44'!
getReactionsTo: eventType
	"Return this actor's reactions to the given event type.  Because only first class actors react to mouse events, if this actor is a part pass this message up to its parent object."

	(self isFirstClass)
		ifTrue: [ (myReactions includesKey: eventType)
					ifTrue: [^ myReactions at: eventType ]
					ifFalse: [ ^ nil ].
				]
		ifFalse: [ ^ myParent getReactionsTo: eventType ].
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 16:19'!
onLeftMouseDown: event
	"The default response to left mouse down events"

	(event getCameraMorph) setEventFocus: self.
	(myWonderland getUndoStack) push: (UndoPOVChange for: self from: (self getPointOfView)).

	self respondWith: [:anEvent | self onMouseMove: anEvent] to: mouseMove.
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 17:13'!
onLeftMouseUp: event
	"The default response to left mouse up events"

	(event getCameraMorph) setEventFocus: nil.
	self respondWith: nil to: mouseMove.
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/22/1999 17:43'!
onMouseMove: event
	"The default response to mouse motion events"

	| deltaX deltaY screenPos scenePos depth camera |

	deltaX _ event getCursorDelta x.
	deltaY _ event getCursorDelta y.
	camera _ event getCamera.

	(Sensor shiftPressed)
		ifTrue: [ (Sensor controlKeyPressed)
					ifTrue: [
						"If both shift and control are pressed, tumble the bunny"
							scenePos _ self getPosition.
							self moveToRightNow: { 0. 0. 0 } asSeenBy: (myWonderland getScene)
									undoable: false.
							self turnRightNow: down numberOfTurns: (deltaY * 0.01)
									asSeenBy: (myWonderland getScene) undoable: false.
							self turnRightNow: left numberOfTurns: (deltaX * 0.01)
									asSeenBy: (myWonderland getScene) undoable: false.
							self moveToRightNow: scenePos undoable: false.

							]

					ifFalse: [
						"If only shift is pressed move the actor up/down"
						screenPos _ (self getPositionInPixels: camera) + (0@deltaY).
						scenePos _ camera transformScreenPointToScenePoint: screenPos
												atDepthOf: self.
						self moveToRightNow: (scenePos) asSeenBy: (myWonderland getScene)
								undoable: false.
							].
				]
		ifFalse: [ (Sensor controlKeyPressed)
					ifTrue: [
							scenePos _ self getPosition.
							self moveToRightNow: { 0. 0. 0 } asSeenBy: (myWonderland getScene)
									undoable: false.
							self turnRightNow: left numberOfTurns: (deltaX * 0.01)
									asSeenBy: (myWonderland getScene) undoable: false.
							self moveToRightNow: scenePos undoable: false.
							]
					ifFalse: [
						"If no modifier keys are held down, move the actor forward-back
						and left-right"
						screenPos _ (self getPositionInPixels: camera) + (deltaX@0).
						depth _ ((self getPosition: camera) at: 3) - (deltaY * 0.01).
						scenePos _ camera transformScreenVectorToSceneVector:
							(B3DVector3 x: (screenPos x) y: (screenPos y) z: depth).

						self moveToRightNow: { scenePos at: 1. asIs. scenePos at: 3 }
								asSeenBy: (myWonderland getScene) undoable: false.
							].
				].
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 13:29'!
removeResponse: aReaction to: evtType
	"Remove the response to the given event type"

	(myReactions includesKey: evtType)
		ifTrue: [ (myReactions at: evtType) remove: aReaction ].
! !

!WonderlandActor methodsFor: 'event handling' stamp: 'jsp 4/19/1999 14:30'!
respondWith: aReaction to: evtType
	"Set this actor's response to the given event type"

	| reaction collection |

	aReaction ifNil: [ myReactions removeKey: evtType ifAbsent: [].
					  ^ nil ].

	reaction _ WonderlandReaction new: aReaction.

	collection _ OrderedCollection new.
	collection addLast: reaction.

	myReactions at: evtType put: collection.

	^ reaction.
! !


!WonderlandActor methodsFor: 'morphic reactions' stamp: 'ar 10/10/2000 22:04'!
dispatchEvent: event to: aMorph
	| evt delta |
	evt _ event getMorphicEvent.
	delta _ (myTexture mapPrimitiveVertex: event getVertex) - evt position.
	evt _ evt translatedBy: delta.
	evt resetHandlerFields.
	"Make sure my texture thinks it's in the world otherwise we might run into problems"
	aMorph isInWorld ifFalse:[aMorph privateOwner: event getCameraMorph].
	aMorph processEvent: evt.! !

!WonderlandActor methodsFor: 'morphic reactions' stamp: 'ar 10/10/2000 21:33'!
morphicKeyPress: event
	"Handle the given event"
	myTexture isMorph ifTrue:[self dispatchEvent: event to: myTexture].! !

!WonderlandActor methodsFor: 'morphic reactions' stamp: 'ar 10/10/2000 21:32'!
morphicMouseDown: event
	"Handle the given event.
	If a local viewpoint is defined go to this viewpoint."
	| vp |
	(event getMorphicEvent shiftPressed and:[(vp _ self getUserPointOfView) notNil])
		ifTrue:[event getCameraMorph getCamera 
					setPointOfView: vp
					duration: 2
					asSeenBy: self.
				"Set an additional flag to avoid inbetween shift key changes"
				^self setProperty: #userTransition toValue: true].
	myTexture isMorph ifTrue:[
		self dispatchEvent: event to: myTexture.
	].! !

!WonderlandActor methodsFor: 'morphic reactions' stamp: 'ar 10/10/2000 21:32'!
morphicMouseMove: event
	"Handle the given event"
	(event getMorphicEvent shiftPressed and:[self getUserPointOfView notNil])
		ifTrue:[^self]. "Reserved for navigation"
	(self getProperty: #userTransition) == true ifTrue:[^true]. "Shift key went up"
	myTexture isMorph ifTrue:[
		self dispatchEvent: event to: myTexture.
	].! !

!WonderlandActor methodsFor: 'morphic reactions' stamp: 'ar 10/10/2000 21:33'!
morphicMouseUp: event
	"Handle the given event"
	(event getMorphicEvent shiftPressed and:[self getUserPointOfView notNil])
		ifTrue:[^self]. "Reserved for navigation"
	(self getProperty: #userTransition) == true ifTrue:["Shift key went up"
		^self setProperty: #userTransition toValue: nil].
	myTexture isMorph ifTrue:[
		self dispatchEvent: event to: myTexture.
	].! !


!WonderlandActor methodsFor: 'enumerating' stamp: 'ar 6/2/1999 14:04'!
allPartsDo: aBlock
	"Recursively evaluate aBlock with all elements of the receiver that are a part of its parent"
	self partsDo:[:child|
		aBlock value: child.
		child allPartsDo: aBlock]! !

!WonderlandActor methodsFor: 'enumerating' stamp: 'ar 6/2/1999 14:03'!
partsDo: aBlock
	"Evaluate aBlock with all elements of the receiver that are a part of it"
	myChildren do:[:child| child isPart ifTrue:[aBlock value: child]].! !


!WonderlandActor methodsFor: 'testing' stamp: 'ar 11/8/1999 14:00'!
hasActiveTexture
	"Return true if the receiver has an active texture that wants events routed directly."
	^(self getProperty: #activeTexture) == true! !

!WonderlandActor methodsFor: 'testing' stamp: 'laza 3/21/2000 15:59'!
isHandmade
	^(self getProperty: #handmade) == true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandActor class
	instanceVariableNames: ''!

!WonderlandActor class methodsFor: 'instance creation' stamp: 'jsp 3/10/1999 16:14'!
createFor: aWonderland
	"Create a new instance for this Wonderland."

	^ super new initializeFor: aWonderland.
! !


!WonderlandActor class methodsFor: 'change logging' stamp: 'jsp 4/23/1999 11:50'!
acceptsLoggingOfCompilation

	^ self == WonderlandActor.
! !

!WonderlandActor class methodsFor: 'change logging' stamp: 'jsp 4/23/1999 11:50'!
wantsChangeSetLogging

	^ self == WonderlandActor.


! !


!WonderlandActor class methodsFor: 'unique name creation' stamp: 'tk 5/7/1999 15:14'!
isSystemDefined
	^ name endsWithDigit not! !

!WonderlandActor class methodsFor: 'unique name creation' stamp: 'jsp 4/8/1999 16:20'!
uniqueNameFrom: aName
	"If aName is not an instance variable of this class, returns aName.  Otherwise it returns a unique name based on aName that is not an instance var."

	| index |

	(self instVarNames includes: aName) ifFalse: [ ^ aName ].

	index _ 2.
	[ self instVarNames includes: (aName , (index asString)) ]
		whileTrue: [ index _ index + 1 ].

	^ aName , (index asString).
	! !
WonderlandActor subclass: #WonderlandActor1
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor10
	instanceVariableNames: 'mallet '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!

!WonderlandActor10 methodsFor: 'as yet unclassified'!
mallet
	^ mallet! !
WonderlandActor subclass: #WonderlandActor11
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor12
	instanceVariableNames: 'mallet '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!

!WonderlandActor12 methodsFor: 'as yet unclassified'!
mallet
	^ mallet! !
WonderlandActor subclass: #WonderlandActor13
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor14
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor2
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor2 subclass: #WonderlandActor21
	instanceVariableNames: 'drum head body '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!

!WonderlandActor21 methodsFor: 'as yet unclassified'!
body
	^ body! !

!WonderlandActor21 methodsFor: 'as yet unclassified'!
drum
	^ drum! !

!WonderlandActor21 methodsFor: 'as yet unclassified'!
head
	^ head! !
WonderlandActor subclass: #WonderlandActor3
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor4
	instanceVariableNames: 'glasses rightEar leftEar '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!

!WonderlandActor4 methodsFor: 'as yet unclassified'!
glasses
	^ glasses! !

!WonderlandActor4 methodsFor: 'as yet unclassified'!
leftEar
	^ leftEar! !

!WonderlandActor4 methodsFor: 'as yet unclassified'!
rightEar
	^ rightEar! !
WonderlandActor subclass: #WonderlandActor5
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor6
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor7
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
WonderlandActor subclass: #WonderlandActor8
	instanceVariableNames: 'leftLeg leftArm rightArm rightLeg '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!

!WonderlandActor8 methodsFor: 'as yet unclassified'!
leftArm
	^ leftArm! !

!WonderlandActor8 methodsFor: 'as yet unclassified'!
leftLeg
	^ leftLeg! !

!WonderlandActor8 methodsFor: 'as yet unclassified'!
rightArm
	^ rightArm! !

!WonderlandActor8 methodsFor: 'as yet unclassified'!
rightLeg
	^ rightLeg! !
WonderlandActor subclass: #WonderlandActor9
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-UserObjects'!
StringHolder subclass: #WonderlandActorBrowser
	instanceVariableNames: 'myWonderland myListMorph actorListIndex selectedActor actorViewer '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandActorBrowser commentStamp: '<historical>' prior: 0!
This class implements the actor browser.  The name of every actor in the Wonderland namespace is listed. The formatting is determined by the parent-child hierarchy.  Children of an actor are listed below and to the right of that actor.  The scene is at the root of the actor tree, and so is at the top left of the hierarchy.

Any actor listed in the actor browser can be addressed by that name in the script editor.

!


!WonderlandActorBrowser methodsFor: 'initialize-release' stamp: 'jsp 6/29/1999 01:50'!
initializeWith: aWonderland
	"Initialize this instance."

	myWonderland _ aWonderland.
	actorListIndex _ 0.
	selectedActor _ nil.
	actorViewer _ nil.

	myListMorph _ (PluggableListMorph on: self list: #actorList
						selected: #actorListIndex changeSelected: #actorListIndex:
						menu: #actorMenu: keystroke: #systemCatListKey:from:).
	myListMorph name: 'Actors'.
	myListMorph scrollBarOnLeft: false.
	myListMorph extent: 140@320.
	myListMorph color: (Color r: 0.627 g: 0.909 b: 0.972).
	myListMorph retractable: false.
! !


!WonderlandActorBrowser methodsFor: 'accessing' stamp: 'jsp 4/1/1999 16:57'!
getMorph
	"Return my morph"

	^ myListMorph.! !

!WonderlandActorBrowser methodsFor: 'accessing' stamp: 'jsp 6/29/1999 01:44'!
getSelectedActor
	"Returns the currently selected actor in the actor browser."

	^ selectedActor.
! !

!WonderlandActorBrowser methodsFor: 'accessing' stamp: 'jsp 6/29/1999 01:52'!
setActorViewer: anActorViewer
	"Sets the WonderlandActorViewer to update when the user changes the selected object in the browser"

	actorViewer _ anActorViewer.
! !


!WonderlandActorBrowser methodsFor: 'actor list functions' stamp: 'kfr 7/18/2000 09:57'!
actorMenu: aMenu
	"Builds the menu to display when the user right clicks on an actor"

	(selectedActor isKindOf: WonderlandScene) | (selectedActor = nil)
	ifTrue: [ ^ aMenu ].

	(selectedActor isFirstClass)
		ifTrue: [
			^ aMenu addList: {
								{'Point camera at'. #pointAt}.
								{'Turn around once'. #turnAround}.
								{'Become part'. #becomePart }.
								{'Stand up'. #standUp}.
								{'Grow'. #grow}.
								{'Shrink'. #shrink}.
								{'Squash'. #squash}.
								{'Stretch'. #stretch}.
								{'Destroy'. #destroy}
							  }.
				]
		ifFalse: [
			^ aMenu addList: {
								{'Point camera at'. #pointAt}.
								{'Turn around once'. #turnAround}.
								{'Become first class'. #becomeFirstClass }.
								{'Stand up'. #standUp}.
								{'Grow'. #grow}.
								{'Shrink'. #shrink}.
								{'Squash'. #squash}.
								{'Stretch'. #stretch}.
								{'Destroy'. #destroy}
							  }.
				].
! !


!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 12:14'!
becomeFirstClass
	"Make the selected actor first class"

	selectedActor becomeFirstClass.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 12:13'!
becomePart
	"Make the selected actor a part"

	selectedActor becomePart.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:51'!
destroy
	"Destroy the selected actor."

	selectedActor destroy.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:57'!
grow
	"Make the selected actor grow"

	selectedActor resize: 1.5.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:48'!
pointAt
	"Point the default camera at the selected object"

	myWonderland getDefaultCamera pointAt: selectedActor.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:57'!
shrink
	"Make the selected actor shrink"

	selectedActor resize: (1.0 / 1.5).
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:57'!
squash
	"Squash the selected actor."

	selectedActor resizeLikeRubber: (1.0 / 1.5) dimension: topToBottom.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:52'!
standUp
	"Make the selected actor stand up"

	selectedActor standUp.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 11:57'!
stretch
	"Stretch the selected actor"

	selectedActor resizeLikeRubber: 1.5 dimension: topToBottom.
! !

!WonderlandActorBrowser methodsFor: 'actor menu functions' stamp: 'jsp 4/13/1999 12:01'!
turnAround
	"Make the selected actor turnAround"

	selectedActor turn: left turns: 1 duration: 2.
! !


!WonderlandActorBrowser methodsFor: 'actor list management' stamp: 'jsp 4/1/1999 17:53'!
actorList
	"Returns a list of actors in the scene"

	| scene |

	scene _ myWonderland getScene.

	^ { scene getName } , (scene appendChildrenNamesTo: '    ').
! !

!WonderlandActorBrowser methodsFor: 'actor list management' stamp: 'jsp 4/1/1999 16:48'!
actorListIndex
	"Return the index of the currently selected actor"

	^ actorListIndex.
! !

!WonderlandActorBrowser methodsFor: 'actor list management' stamp: 'jsp 6/29/1999 01:55'!
actorListIndex: anInteger
	"Set the index of the currently selected actor."

	| scene childList |

	actorListIndex _ anInteger.
	myListMorph selectionIndex: anInteger.

	(anInteger = 0)
		ifTrue: [
					selectedActor _ nil.
				]
		ifFalse: [
					scene _ myWonderland getScene.
					childList _ scene getAllChildren.
					childList addFirst: scene.
					selectedActor _ childList at: anInteger.
				].

	actorViewer ifNotNil: [
		actorViewer setSelectedActor: selectedActor.
	].

	self contentsChanged.
! !

!WonderlandActorBrowser methodsFor: 'actor list management' stamp: 'jsp 4/1/1999 17:38'!
updateActorList
	"Updates the actor list."

	self changed: #actorList.

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandActorBrowser class
	instanceVariableNames: ''!

!WonderlandActorBrowser class methodsFor: 'instance creation' stamp: 'jsp 4/1/1999 16:44'!
newFor: aWonderland
	"Create a new actor browser for the Wonderland"

	^ self new initializeWith: aWonderland.
! !
WonderlandMorph subclass: #WonderlandActorData
	instanceVariableNames: 'nameMorph positionMorph rotationMorph parentMorph '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandActorData methodsFor: 'initialization' stamp: 'jsp 7/9/1999 16:23'!
initialize
	"Initialize this morph by setting up the various submorphs to be able to show data about a WonderlandActor"

	| aMorph |

	super initialize.
	self color: (Color r: 0.815 g: 0.972 b: 0.878).
	self bounds: (0@0 corner: 300@120).

	nameMorph _ TextMorph new.
	nameMorph contents: 'Name: (No actor selected)'.
	nameMorph topLeft: 10@10.
	self addMorph: nameMorph.

	parentMorph _ TextMorph new.
	parentMorph contents: 'Parent: '.
	parentMorph topLeft: 10@25.
	self addMorph: parentMorph.

	aMorph _ TextMorph new.
	aMorph contents: 'Position relative to parent'.
	aMorph topLeft: 10@55.
	self addMorph: aMorph.

	positionMorph _ TextMorph new.
	positionMorph contents: ((Character tab) asString) , 'Right:    Up:    Forward: '.
	positionMorph topLeft: 10@70.
	self addMorph: positionMorph.

	aMorph _ TextMorph new.
	aMorph contents: 'Rotation about'.
	aMorph topLeft: 10@100.
	self addMorph: aMorph.

	rotationMorph _ TextMorph new.
	rotationMorph contents: ((Character tab) asString) , 'Left-Right axis: ' ,
				((Character cr) asString) , ((Character tab) asString) , 'Up-Down axis: ',
				((Character cr) asString) , ((Character tab) asString) , 'Forward-Back axis: '.
	rotationMorph topLeft: 10@115.
	self addMorph: rotationMorph.

! !


!WonderlandActorData methodsFor: 'setting actor' stamp: 'jsp 7/9/1999 16:20'!
setActor: anActor
	"Set the actor whose data this morph should show and update the displayed data."

	| position rotation |

	(anActor isNil)
		ifTrue: [
				nameMorph contents: 'Name: (No actor selected)'.
				parentMorph contents: 'Parent: '.	
				positionMorph contents: ((Character tab) asString) , 'Right:    Up:    Forward: '.
				rotationMorph contents: ((Character tab) asString) , 'Left-Right axis: ' ,
					((Character cr) asString) , ((Character tab) asString) , 'Up-Down axis: ',
					((Character cr) asString) , ((Character tab) asString) , 'Forward-Back axis: '.
				]

		ifFalse: [
				nameMorph contents: ('Name: ' , (anActor getName)).

				(anActor isKindOf: WonderlandActor)
					ifTrue: [
							parentMorph contents: ('Parent: ' , (anActor getParent getName)).

							position _ anActor getPosition.
							position at: 1 put: ((((position at: 1) * 1000) rounded / 1000.0) asString).
							position at: 2 put: ((((position at: 2) * 1000) rounded / 1000.0) asString).
							position at: 3 put: ((((position at: 3) * 1000) rounded / 1000.0) asString).
							positionMorph contents: ((Character tab) asString) , ('Right: ',
								(position at: 1) , '  Up: ', (position at: 2) , '  Forward: ' ,
								(position at: 3)).

							rotation _ anActor getAngles.
							rotation at: 1 put: ((((rotation at: 1) * 1000) rounded / 1000.0) asString).
							rotation at: 2 put: ((((rotation at: 2) * 1000) rounded / 1000.0) asString).
							rotation at: 3 put: ((((rotation at: 3) * 1000) rounded / 1000.0) asString).
							rotationMorph contents: ((Character tab) asString) , 'Left-Right axis: ' ,
								(rotation at: 1) , ((Character cr) asString) ,
								((Character tab) asString) , 'Up-Down axis: ' , (rotation at: 2) , 
								((Character cr) asString) , ((Character tab) asString) ,
								'Forward-Back axis: ' , (rotation at: 3).

							]
					ifFalse: [
							parentMorph contents: 'Parent: None'.	
							positionMorph contents: ((Character tab) asString) ,
									'Right:    Up:    Forward: '.
							rotationMorph contents: ((Character tab) asString) , 'Left-Right axis: ' ,
								((Character cr) asString) , ((Character tab) asString) ,
								'Up-Down axis: ', ((Character cr) asString) ,
								((Character tab) asString) , 'Forward-Back axis: '.
							]

				].



! !
Morph subclass: #WonderlandActorViewer
	instanceVariableNames: 'thumbnailMorph thumbnailCamera selectedActor dataMorph updatingIsOn updatingAction '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandActorViewer methodsFor: 'initialization' stamp: 'jsp 7/8/1999 21:56'!
initialize
	"Initialize this morph"

	super initialize.

	updatingIsOn _ false.

	self name: 'Actor Info'.
	self extent: 500@350.
	self color: (Color r: 0.815 g: 0.972 b: 0.878).

	dataMorph _ WonderlandActorData new.
	self addMorph: dataMorph.
	dataMorph topLeft: 200@10.
! !

!WonderlandActorViewer methodsFor: 'initialization' stamp: 'jsp 7/8/1999 15:58'!
initializeWith: aWonderland
	"Do the Wonderland specific setup for this viewer."

	thumbnailCamera _ WonderlandStillCamera createFor: aWonderland.
	thumbnailCamera turnBackgroundOff.

	thumbnailMorph _ thumbnailCamera getMorph.
	thumbnailMorph topLeft: 10@10.
	self addMorph: thumbnailMorph.
! !


!WonderlandActorViewer methodsFor: 'updating' stamp: 'jsp 7/8/1999 22:49'!
setSelectedActor: anActor
	"Update the actor viewer to reflect the information for this actor"

	selectedActor _ anActor.

	thumbnailCamera setFocusObject: anActor.
	dataMorph setActor: anActor.


! !

!WonderlandActorViewer methodsFor: 'updating' stamp: 'jsp 7/8/1999 22:49'!
turnUpdatingOff
	"Set the actor viewer to stop updating the selected actor's data."

	updatingIsOn _ false.
! !

!WonderlandActorViewer methodsFor: 'updating' stamp: 'jsp 7/8/1999 22:49'!
turnUpdatingOn
	"Set the actor viewer to constantly update the selected actor's data."

	updatingIsOn _ true.

! !


!WonderlandActorViewer methodsFor: 'stepping' stamp: 'jsp 7/8/1999 23:08'!
step

	(updatingIsOn and: [ selectedActor notNil ] )
		ifTrue: [
				dataMorph setActor: selectedActor.
				thumbnailCamera setFocusObject: selectedActor.
				].

! !

!WonderlandActorViewer methodsFor: 'stepping' stamp: 'jsp 7/8/1999 22:52'!
stepTime

	^ 1000.
! !

!WonderlandActorViewer methodsFor: 'stepping' stamp: 'jsp 7/8/1999 22:52'!
wantsSteps

	^ true.
! !
WonderlandLightSource subclass: #WonderlandAmbientLight
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Lights'!

!WonderlandAmbientLight methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:47'!
computeAttenuationFor: distance
	^1.0! !

!WonderlandAmbientLight methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:48'!
computeDirectionTo: aB3DPrimitiveVertex
	^B3DVector3 zero! !

!WonderlandAmbientLight methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:48'!
shadeVertexBuffer: vb with: aMaterial into: colorArray
	"Overridden for simplicity and speed"
	| color |
	false ifTrue:[^super shadeVertexBuffer: vb with: aMaterial into: colorArray].
	self flag: #b3dPrimitive.
	vb trackAmbientColor ifTrue:[
		1 to: vb vertexCount do:[:i|
			color _ (vb primitiveB3dColorAt: i) * lightColor ambientPart.
			colorArray add: color at: i.
		].
	] ifFalse:[
		color _ aMaterial ambientPart * lightColor ambientPart.
		colorArray += color.
	].! !


!WonderlandAmbientLight methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:45'!
hasDiffusePart
	^false! !

!WonderlandAmbientLight methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:46'!
hasSpecularPart
	^false! !


!WonderlandAmbientLight methodsFor: 'converting' stamp: 'jsp 4/23/1999 14:47'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight |
	primLight _ B3DPrimitiveLight new.
	primLight ambientPart: lightColor ambientPart.
	primLight flags: FlagAmbientPart.
	^primLight! !

!WonderlandAmbientLight methodsFor: 'converting' stamp: 'jsp 4/23/1999 14:47'!
transformedBy: aTransformer
	^self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandAmbientLight class
	instanceVariableNames: ''!

!WonderlandAmbientLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:44'!
acceptsLoggingOfCompilation

	^ self == WonderlandAmbientLight.! !

!WonderlandAmbientLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:45'!
wantsChangeSetLogging

	^ self == WonderlandAmbientLight.

! !
WonderlandActor subclass: #WonderlandCamera
	instanceVariableNames: 'perspective viewMatrix myMorph drawSceneBackground bounds '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Objects'!
!WonderlandCamera commentStamp: '<historical>' prior: 0!
The WonderlandCamera class extends the WonderlandActor functionality with the methods for specifying the viewing parameters.  Every view into the 3D world is assigned a camera, and each camera renders into a different morph.

WonderlandCamera also know how to transform points on the 2D desktop into the 3D wonderland.
!


!WonderlandCamera methodsFor: 'initialize-release' stamp: 'ar 4/25/1999 06:48'!
copySettingsFrom: aB3DCamera
	"Copy my settings from the given B3DCamera"
	| transformer |
	transformer _ B3DVertexTransformer new.
	transformer loadIdentity.
	transformer lookFrom: aB3DCamera position to: aB3DCamera target up: aB3DCamera up.
	self setComposite: transformer modelViewMatrix inverseTransformation.
	perspective _ aB3DCamera perspective.! !

!WonderlandCamera methodsFor: 'initialize-release' stamp: 'jsp 3/25/1999 15:59'!
initializeFor: aWonderland
	"Initializes the camera."

	super initializeFor: aWonderland.

	"Set the camera's mesh and geometry"
	self setMesh: (WonderlandConstants at: 'cameraMesh').
	self setTexturePointer: (WonderlandConstants at: 'cameraTexture').
	
	"Set the camera initial position"
	composite translation: (B3DVector3 x: -1.5 y: 0.5 z: 2.6).
	self turnTo: #(180 -30 180) duration: #rightNow.

	"Initialize the camera viewing parameters"
	perspective _ B3DCameraPerspective new.
	self setFieldOfView: 40.0.
	self setAspectRatio: 1.0.
	self setNearClippingPlane: 0.1.
	self setFarClippingPlane: 10000.0.

	viewMatrix _ B3DMatrix4x4 new.

	"Create a WonderlandCameraMorph for the camera to render into"
	myMorph _ WonderlandCameraMorph new.
	myMorph initializeWithCamera: self.
	myMorph openInWorld.

	"Initially draw the scene background"
	drawSceneBackground _ true.
! !

!WonderlandCamera methodsFor: 'initialize-release' stamp: 'jsp 3/22/1999 11:07'!
release
	"Destroy the renderer"

	myMorph delete.

! !


!WonderlandCamera methodsFor: 'rendering' stamp: 'ar 5/28/2000 12:24'!
pickAt: aPoint
	"Return the top object at the given point or nil"
	^self render: (B3DRenderEngine defaultForPlatformOn: nil) pickingAt: aPoint! !

!WonderlandCamera methodsFor: 'rendering' stamp: 'ar 5/28/2000 12:24'!
pickObjectAndVertexAt: aPoint
	"Return an association with the top object and the primitive vertex at the given point or nil"
	^self render: (B3DRenderEngine defaultForPlatformOn: nil) 
		pickingAt: aPoint
		withPrimitiveVertex: true.! !

!WonderlandCamera methodsFor: 'rendering' stamp: 'ar 4/18/1999 00:10'!
render: aRenderer
	^self render: aRenderer pickingAt: nil.! !

!WonderlandCamera methodsFor: 'rendering' stamp: 'ar 6/2/1999 13:20'!
render: aRenderEngine pickingAt: aPointOrNil
	"Render one frame of the Wonderland using this camera.
	If aPointOrNil is not nil then return the top most object at this point.
	Note: If picking, no objects are actually drawn."
	^self render: aRenderEngine pickingAt: aPointOrNil withPrimitiveVertex: false! !

!WonderlandCamera methodsFor: 'rendering' stamp: 'ar 11/7/1999 18:49'!
render: aRenderEngine pickingAt: aPointOrNil withPrimitiveVertex: aBoolean
	"Render one frame of the Wonderland using this camera.
	If aPointOrNil is not nil then pick the top most object at this point.
	For picking only: If aBoolean is true return an association 
	object -> B3DPrimitiveVertex; otherwise simply return the top most object.
	Note: If picking, no objects are actually drawn."
	| aRenderer pickedObject |
	aRenderer _ aRenderEngine. "A couple of things must be set before we can pick!!"

	aRenderer viewport: (myMorph bounds insetBy: 1@1).

	(drawSceneBackground)
		ifTrue: [ aRenderer clearViewport: (myWonderland getScene) getColorObject. ]
		ifFalse: [ ].

	aRenderer clearDepthBuffer.
	aRenderer loadIdentity.

	"Add any existing lights to the renderer for this camera"
	(myWonderland getLights) do: [:light | aRenderer addLight: light ].

	"Calculate our view matrix by inverting the camera's composite matrix and hand it
	to the renderer - note that this will eventually have to walk up the tree"
	viewMatrix _ self getMatrixToRoot.
	aRenderer transformBy: viewMatrix.

	aRenderer perspective: perspective.

	"Initialize picking if necessary"
	aPointOrNil == nil
		ifTrue:[	"Record 2D bounds if not picking"
				aRenderer setProperty: #boundsRecorder toValue: self.
				bounds _ IdentityDictionary new: (bounds ifNil:[10] ifNotNil:[bounds size])]
		ifFalse:[	"Make us a picker"
				aRenderer _ aRenderer asPickerAt: aPointOrNil].

	"Now render the scene"
	myWonderland renderWonderland: aRenderer.

	"Force the renderer to draw to the screen"
	aRenderer finish.

	"Fetch the picked object"
	aPointOrNil ifNotNil:[
		aBoolean
			ifTrue:[pickedObject _ aRenderer topMostObject -> aRenderer topMostVertex]
			ifFalse:[pickedObject _ aRenderer topMostObject]].

	aRenderer destroy.

	^pickedObject "Will be nil if not picking"! !


!WonderlandCamera methodsFor: 'get property' stamp: 'jsp 2/11/1999 11:13'!
getAspectRatio
	"Returns the camera's current aspect ratio."

	^ perspective aspectRatio.
! !

!WonderlandCamera methodsFor: 'get property' stamp: 'ar 11/7/1999 18:34'!
getBoundsForActor: anActor
	"Return the 2D bounds of the actor as seen by the receiver"
	bounds == nil ifTrue:[^nil].
	^bounds at: anActor ifAbsent:[nil]! !

!WonderlandCamera methodsFor: 'get property' stamp: 'jsp 2/11/1999 11:15'!
getFarClippingPlane
	"Returns the camera's far clipping plane"

	^ perspective farDistance.
! !

!WonderlandCamera methodsFor: 'get property' stamp: 'jsp 3/25/1999 15:58'!
getFieldOfView
	"Returns the camera's field of view."

	^ (perspective fieldOfView) * 2.
! !

!WonderlandCamera methodsFor: 'get property' stamp: 'jsp 2/11/1999 11:14'!
getNearClippingPlane
	"Returns the camera's near clipping plane"

	^ perspective nearDistance.
! !


!WonderlandCamera methodsFor: 'set property' stamp: 'jsp 2/11/1999 11:12'!
setAspectRatio: aFloat
	"Sets the camera's aspect ratio"

	perspective aspectRatio: aFloat.
! !

!WonderlandCamera methodsFor: 'set property' stamp: 'ar 11/7/1999 18:50'!
setBounds: aRectangle for: anActor
	"Record the 2D bounds for the given actor during a rendering pass"
	aRectangle == nil ifFalse:[bounds at: anActor put: (aRectangle intersect: myMorph bounds)].! !

!WonderlandCamera methodsFor: 'set property' stamp: 'jsp 2/11/1999 11:15'!
setFarClippingPlane: aFloat
	"Sets the camera's far clipping plane - anything farther than this won't be drawn."

	perspective farDistance: aFloat.
! !

!WonderlandCamera methodsFor: 'set property' stamp: 'jsp 3/25/1999 15:58'!
setFieldOfView: aFloat
	"Sets the camera's field of view."

	perspective fieldOfView: (aFloat / 2).
! !

!WonderlandCamera methodsFor: 'set property' stamp: 'jsp 4/23/1999 12:07'!
setName: newName
	"Sets the object's name"

	myName _ newName.
	myMorph name: myName.
! !

!WonderlandCamera methodsFor: 'set property' stamp: 'jsp 2/11/1999 11:14'!
setNearClippingPlane: aFloat
	"Sets the camera's near clipping plane - anything closer than this won't be drawn."

	perspective nearDistance: aFloat.
! !


!WonderlandCamera methodsFor: 'accessing' stamp: 'ar 4/28/1999 23:48'!
drawSceneBackground
	^drawSceneBackground! !

!WonderlandCamera methodsFor: 'accessing' stamp: 'jsp 3/22/1999 14:25'!
getMorph
	"Returns the camera window morph that this camera renders into"

	^ myMorph.
! !

!WonderlandCamera methodsFor: 'accessing' stamp: 'jsp 3/30/1999 16:28'!
resetPointOfView
	"Return the camera to it's 'home' position and orientation"

	^ self setPointOfView: { -1.5. 0.5. 2.6. 180. -30. 180}.
! !

!WonderlandCamera methodsFor: 'accessing' stamp: 'jsp 3/22/1999 16:19'!
turnBackgroundOff
	"Stop drawing the scene background"

	drawSceneBackground _ false.! !

!WonderlandCamera methodsFor: 'accessing' stamp: 'jsp 3/22/1999 16:19'!
turnBackgroundOn
	"Resume drawing the scene background"

	drawSceneBackground _ true.! !


!WonderlandCamera methodsFor: 'primitive behaviors'!
destroy: t1 
	| t2 t3 t4 |
	t4 _ OrderedCollection new.
	t3 _ self getAllChildren.
	t3
		do: [:t5 | t5 isFirstClass
				ifTrue: [t4
						addLast: (UndoParentChange newFor: t5 from: t5 getParent).
					t5 reparentTo: self getParent]].
	self removeFromScene.
	myMorph delete.
	t2 _ myWonderland getCameraList.
	t2 remove: self.
	t4
		addLast: (UndoAction
				new: [myMorph openInWorld.
					myWonderland getScene addChild: self.
					t2 addLast: self]).
	myWonderland getUndoStack
		push: (UndoChangeList new setChangeList: t4)! !


!WonderlandCamera methodsFor: 'transforming' stamp: 'jsp 3/29/1999 10:58'!
transformScreenPointToScenePoint: aPoint
	"Converts a pixel point to a position in the 3D scene. Uses the near clipping plane distance for the depth in the scene."

	| d  x y m frustum vector |

	frustum _ self getFrustum.

	d _ frustum near.

	x _ ((aPoint x) - (myMorph center x)) / ((myMorph width) / 2) * (frustum right).
	y _ (((aPoint y) - (myMorph center y)) / ((myMorph height) / 2)) * (frustum bottom).

	m _ B3DMatrix4x4 identity.
	m translation: (B3DVector3 x: x y: y z: d).
	m _ (self getMatrixFromRoot) composeWith: m.

	vector _ (m translation).

	^ { vector at: 1. vector at: 2. vector at: 3 }.
! !

!WonderlandCamera methodsFor: 'transforming' stamp: 'jsp 3/29/1999 11:00'!
transformScreenPointToScenePoint: aPoint atDepthOf: anActor
	"Converts a pixel point to a position in the 3D scene using the actor to scale the position of the point. Uses the actor's distance from the camera to determine the depth in the scene."

	| d  x y m scale frustum vector |

	frustum _ self getFrustum.

	d _ (anActor getPosition: self) at: 3.
	scale _ d / (frustum near).

	x _ ((aPoint x) - (myMorph center x)) / ((myMorph width) / 2) * (frustum right) * scale.
	y _ (((aPoint y) - (myMorph center y)) / ((myMorph height) / 2)) * (frustum bottom) * scale.

	m _ B3DMatrix4x4 identity.
	m translation: (B3DVector3 x: x y: y z: d).
	m _ (self getMatrixFromRoot) composeWith: m.

	vector _ (m translation).

	^ { vector at: 1. vector at: 2. vector at: 3 }.
! !

!WonderlandCamera methodsFor: 'transforming' stamp: 'jsp 3/29/1999 10:58'!
transformScreenPointToScenePoint: aPoint using: anActor
	"Converts a pixel point to a position in the 3D scene using the actor to scale the position of the point. Uses the near clipping plane distance for the depth in the scene."

	| d  x y m scale frustum vector |

	frustum _ self getFrustum.

	d _ frustum near.
	scale _ ((anActor getPosition: self) at: 3) / d.

	x _ ((aPoint x) - (myMorph center x)) / ((myMorph width) / 2) * (frustum right) * scale.
	y _ (((aPoint y) - (myMorph center y)) / ((myMorph height) / 2)) * (frustum bottom) * scale.

	m _ B3DMatrix4x4 identity.
	m translation: (B3DVector3 x: x y: y z: d).
	m _ (self getMatrixFromRoot) composeWith: m.

	vector _ (m translation).

	^ { vector at: 1. vector at: 2. vector at: 3 }.
! !

!WonderlandCamera methodsFor: 'transforming' stamp: 'jsp 4/19/1999 15:30'!
transformScreenVectorToSceneVector: aVector
	"Converts a picture plane vector to a position in the 3D scene."

	| x y d m frustum scale vector |

	frustum _ self getFrustum.

	d _ aVector at: 3.
	scale _ d / (frustum near).

	x _ ((aVector x) - (myMorph center x)) / ((myMorph width) / 2) * (frustum right) * scale.
	y _ (((aVector y) - (myMorph center y)) / ((myMorph height) / 2)) * (frustum bottom) * scale.

	m _ B3DMatrix4x4 identity.
	m translation: (B3DVector3 x: x y: y z: d).
	m _ (self getMatrixFromRoot) composeWith: m.

	vector _ (m translation).

	^ { vector at: 1. vector at: 2. vector at: 3 }.
! !


!WonderlandCamera methodsFor: 'private' stamp: 'jsp 3/25/1999 10:48'!
getFrustum
	"Returns the camera's frustum"

	^ perspective asFrustum.
! !

!WonderlandCamera methodsFor: 'private' stamp: 'jsp 3/25/1999 10:50'!
getPerspectiveMatrix
	"Returns the camera's perspective matrix"

	^ perspective asFrustum asPerspectiveMatrix.
! !


!WonderlandCamera methodsFor: 'debug' stamp: 'ar 11/7/1999 18:39'!
debugDrawRectsOn: aCanvas
	bounds == nil ifTrue:[^self].
	bounds keysAndValuesDo:[:actor :rect|
		aCanvas frameRectangle: rect color: Color white.
	].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandCamera class
	instanceVariableNames: ''!

!WonderlandCamera class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:12'!
acceptsLoggingOfCompilation
	^ (self == WonderlandCamera).
! !

!WonderlandCamera class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:12'!
wantsChangeSetLogging
	^ (self == WonderlandCamera).
! !
ImageMorph subclass: #WonderlandCameraControls
	instanceVariableNames: 'myCamera myScheduler myUndoStack moveAction myMoveScale myRotationScale '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandCameraControls commentStamp: '<historical>' prior: 0!
This class implements the controls for manipulating the viewpoint of a camera using the mouse.

Currently clicking and dragging on the bitmap moves the camera forward/back and turns it left/right.

Shift-clicking and dragging moves the camera left/right and up/down.

Control-clicking and dragging turns the camera left/right.

Shift-Control-clicking and dragging turns the camera up/down.

!


!WonderlandCameraControls methodsFor: 'initialization' stamp: 'jsp 4/9/1999 16:24'!
initializeWith: aCamera
	"Initialize this instance"

	| b |

	myCamera _ aCamera.
	myScheduler _ (aCamera getWonderland) getScheduler.
	myUndoStack _ (aCamera getWonderland) getUndoStack.

	image _ camControlsBMP.

	self extent: 59@60.
	b _ (aCamera getMorph) bounds.
	self position: ((b center x) - 30) @ (b bottom).
	self openInWorld.
! !


!WonderlandCameraControls methodsFor: 'accessing' stamp: 'jsp 3/30/1999 10:15'!
extent: aPoint

	bounds extent = aPoint ifFalse: [
		self changed.
		bounds _ bounds topLeft extent: aPoint.
		self layoutChanged.
		self changed].! !

!WonderlandCameraControls methodsFor: 'accessing' stamp: 'ar 11/6/2000 14:48'!
getCenter
	^self valueOfProperty: #center ifAbsent:[self center]! !

!WonderlandCameraControls methodsFor: 'accessing' stamp: 'ar 11/6/2000 14:48'!
setCenter: aPoint
	aPoint == nil
		ifTrue:[self removeProperty: #center]
		ifFalse:[self setProperty: #center toValue: aPoint].! !


!WonderlandCameraControls methodsFor: 'event handling' stamp: 'jsp 3/30/1999 10:24'!
handlesMouseDown: evt

	^ true.
! !

!WonderlandCameraControls methodsFor: 'event handling' stamp: 'jsp 3/30/1999 11:28'!
mouseDown: evt
	"Handle a mouse down event."

	myUndoStack push: (UndoPOVChange for: myCamera from: (myCamera getPointOfView)).

	moveAction _ myCamera doEachFrame: [ self moveCamera ].
! !

!WonderlandCameraControls methodsFor: 'event handling' stamp: 'jsp 3/30/1999 10:52'!
mouseUp: evt
	"Handle a mouse up event."

	moveAction stop.
! !


!WonderlandCameraControls methodsFor: 'camera control' stamp: 'ar 11/6/2000 14:48'!
moveCamera
	"Move the camera an amount and direction determined by the current position of the mouse and which modifier keys are held down."
	| offset dt |
	myMoveScale == nil ifTrue:[myMoveScale _ 0.1].
	myRotationScale == nil ifTrue:[myRotationScale _ 0.01].
	dt _ myScheduler getElapsedTime.
	offset _ (self getCenter) - (0@8) - (Sensor mousePoint).

	(Sensor shiftPressed)
		ifTrue: [ (Sensor controlKeyPressed)
					ifTrue: [
						myCamera turnRightNow: up numberOfTurns: (dt * (offset y) * myRotationScale)
										undoable: false.
							]
					ifFalse: [
						myCamera moveRightNow: up distance: (dt * (offset y) * myMoveScale)
										undoable: false.
						myCamera moveRightNow: left distance: (dt * (offset x) * myMoveScale)
										undoable: false.
							].
				]
		ifFalse: [ (Sensor controlKeyPressed)
					ifTrue: [
						myCamera turnRightNow: left numberOfTurns: (dt * (offset x) * myRotationScale)
										undoable: false.
							]
					ifFalse: [
						myCamera moveRightNow: forward distance: (dt * (offset y) * myMoveScale)
										undoable: false.
						myCamera turnRightNow: left numberOfTurns: (dt * (offset x) * myRotationScale)
										undoable: false.
							].
				].
! !


!WonderlandCameraControls methodsFor: 'properties' stamp: 'ar 9/16/1999 16:36'!
getMoveScale
	^myMoveScale! !

!WonderlandCameraControls methodsFor: 'properties' stamp: 'ar 9/16/1999 16:36'!
getRotationScale
	^myRotationScale! !

!WonderlandCameraControls methodsFor: 'properties' stamp: 'ar 9/16/1999 16:36'!
setMoveScale: aNumber
	myMoveScale _ aNumber.! !

!WonderlandCameraControls methodsFor: 'properties' stamp: 'ar 9/16/1999 16:37'!
setRotationScale: aNumber
	myRotationScale _ aNumber.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandCameraControls class
	instanceVariableNames: ''!

!WonderlandCameraControls class methodsFor: 'instance creation' stamp: 'jsp 3/30/1999 09:57'!
newFor: aCamera
	"Initialize the camera controls and assign the camera they're controlling"

	^ self new initializeWith: aCamera.
! !
WonderlandMorph subclass: #WonderlandCameraMorph
	instanceVariableNames: 'myCamera myControls eventFocus lastCursorPoint mouseUpButton firstPersonControls mode outline currentActor currentPosition currentCanvas currentColor currentNib lastPosition paintMode palette restore backup pickedPoint pickedActor '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandCameraMorph commentStamp: '<historical>' prior: 0!
This class implements the morph that provides a view into the 3D world.  Each instance has a camera assigned to it that determines the viewpoint and parameters of the view.  Each instance also has the camera controls for that camera attached to it, and is responsible for showing or hiding them.

!


!WonderlandCameraMorph methodsFor: 'accessing' stamp: 'ar 11/7/1999 19:18'!
getCamera
	^myCamera! !

!WonderlandCameraMorph methodsFor: 'accessing' stamp: 'laza 2/2/2000 16:10'!
mode
	^ mode
! !

!WonderlandCameraMorph methodsFor: 'accessing' stamp: 'laza 2/2/2000 16:10'!
mode: aSymbol
	mode _ aSymbol! !

!WonderlandCameraMorph methodsFor: 'accessing' stamp: 'ar 4/6/2000 18:33'!
outline
	^ outline ifNil:[outline _ POSimplePolygon new].! !

!WonderlandCameraMorph methodsFor: 'accessing' stamp: 'laza 3/20/2000 16:27'!
outline: aSimplePolygon
	outline _ aSimplePolygon! !


!WonderlandCameraMorph methodsFor: 'change reporting' stamp: 'jsp 3/4/1999 14:40'!
layoutChanged
	"Process the changed layout and then change the aspect ratio of the camera to match"

	super layoutChanged.

	myCamera setAspectRatio: ((self width) / (self height)) asFloat.
! !


!WonderlandCameraMorph methodsFor: 'controls' stamp: 'kfr 8/7/2000 16:40'!
deleteCameraControls
	"Hide the camera controls for the camera rendering into this window"
	(self submorphOfClass: WonderlandCameraControls)
		ifNotNil: [myControls delete.
			myControls _ nil]! !

!WonderlandCameraMorph methodsFor: 'controls' stamp: 'ar 9/16/1999 16:38'!
getCameraControls
	myControls == nil ifTrue:[
		self showCameraControls.
		self hideCameraControls.
	].
	^myControls! !

!WonderlandCameraMorph methodsFor: 'controls' stamp: 'jsp 3/30/1999 15:00'!
hideCameraControls
	"Hide the camera controls for the camera rendering into this window"

	myControls ifNotNil: [ myControls hide ].

! !

!WonderlandCameraMorph methodsFor: 'controls' stamp: 'jsp 3/30/1999 15:02'!
showCameraControls
	"Show the camera controls for the camera rendering into this window"

	myControls ifNil: [
			myControls _ WonderlandCameraControls newFor: myCamera.
			self addMorph: myControls.
					  ].

	myControls show.
! !


!WonderlandCameraMorph methodsFor: 'debug' stamp: 'ar 5/25/2000 18:02'!
debugDraw
	Display deferUpdates: false.
	self fullDrawOn: (Display getCanvas).
	Display deferUpdates: false.
	Display forceToScreen: bounds.! !


!WonderlandCameraMorph methodsFor: 'drag and drop' stamp: 'sma 4/30/2000 10:19'!
acceptDroppingMorph: aMorph event: evt
	"This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. This default implementation just adds the given morph to the receiver."
	| actor |
	actor _ myCamera pickAt: evt cursorPoint.
	actor == nil ifTrue:[^self addMorphFront: aMorph]. "This should never happen."
	myWonderland getUndoStack push: (UndoTextureChange for: actor from: actor getTexturePointer).
	aMorph installAsWonderlandTextureOn: actor.
	self world abandonAllHalos.
	"AAAARRRRGGGGGHHHH!!!!!!!!"
	aMorph owner ifNotNil:[aMorph owner privateRemoveMorph: aMorph].
	aMorph privateOwner: self.
	"Note: The above makes aMorph invisible to stupid HandMorph but keeps it in the world so it can continue stepping"
	actor adjustToTextureIfNecessary.! !

!WonderlandCameraMorph methodsFor: 'drag and drop' stamp: 'ar 11/7/1999 21:09'!
wantsDroppedMorph: aMorph event: evt
	"Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. The default implementation returns false.
NOTE: the event is assumed to be in global (world) coordinates."
	| pt |
	(super wantsDroppedMorph: aMorph event: evt) ifFalse:[^false].
	pt _ self transformFromWorld globalPointToLocal: evt cursorPoint.
	(myCamera pickAt: pt) == nil ifTrue:[^false].
	^true! !


!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'ar 11/7/2000 15:16'!
areasRemainingToFill: aRectangle
	^(myCamera drawSceneBackground or:[self bgCacheValid])
		ifTrue:[aRectangle areasOutside: self bounds]
		ifFalse:[Array with: aRectangle]! !

!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'ar 11/7/2000 15:24'!
bgCacheValid
	| bg |
	bg _ self valueOfProperty: #backgroundSnapshot ifAbsent:[^false].
	^bg extent = self extent and:[bg depth = Display depth and:[Display isB3DDisplayScreen == bg isExternalForm]]! !

!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'ar 11/7/2000 15:24'!
drawOn: aCanvas 
	| bg |
	bg _ self valueOfProperty: #backgroundSnapshot.
	bg == nil ifFalse:[
		(self bgCacheValid) ifFalse:[
			bg _ Display allocateForm: self extent.
			Display displayOn: bg at: bounds origin negated.
			self setProperty: #backgroundSnapshot toValue: bg.
		].
		aCanvas drawImage: bg at: bounds origin.
	].
	aCanvas asBalloonCanvas render: self.
	self outline ifNotNil: [self sketchOn: aCanvas].
	"*** hack ***"
	pickedPoint _ nil.! !

!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'ar 11/7/2000 15:15'!
releaseCachedState
	| bg |
	bg _ self valueOfProperty: #backgroundSnapshot.
	bg == nil ifTrue:[^self].
	self setProperty: #backgroundSnapshot toValue: (Form extent: 1@1).
! !

!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'jsp 3/22/1999 10:47'!
renderOn: aRenderer

	"Tell our camera to draw"
	myCamera render: aRenderer.
! !

!WonderlandCameraMorph methodsFor: 'drawing' stamp: 'ar 5/26/2000 15:51'!
sketchOn: aCanvas
	| vtx prev next |
	vtx _ ReadStream on: self outline vertices.
	vtx atEnd ifTrue:[^self].
	prev _ vtx next.
	[vtx atEnd] whileFalse: [
		next _ vtx next.
		aCanvas line: prev to: next width: 5 color: Color red.
		prev _ next]! !


!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 11/6/2000 23:38'!
containsPoint: aPoint event: anEvent
	(anEvent isMouseOver or:[firstPersonControls == true]) ifTrue:[
		"Approximate for mouseOver; they're just sent too often"
		^self bounds containsPoint: aPoint].
	^super containsPoint: aPoint event: anEvent! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 6/2/1999 14:33'!
convertEvent: evt
	"Create a Wonderland event that will be dispatched later on from the given MorphicEvent."
	| newEvent temp clickedActor clickedVertex |
	eventFocus 
		ifNil:[ "Find the clicked actor under the cursor"
			temp _ myCamera pickObjectAndVertexAt: evt cursorPoint.
			clickedActor _ temp key.
			clickedVertex _ temp value]
		ifNotNil: [ "Route all events to the object having the focus"
			clickedActor _ eventFocus.
			clickedVertex _ nil].
	clickedActor ifNotNil:[
		newEvent _ WonderlandEvent new.
		newEvent setMorphicEvent: evt.
		newEvent setCameraMorph: self.
		newEvent setActor: clickedActor.
		newEvent setCamera: myCamera.
		newEvent setCursorDelta: ((evt cursorPoint) - lastCursorPoint).
		newEvent setCursorPoint: (lastCursorPoint _ evt cursorPoint).
		newEvent setVertex: clickedVertex.
		evt isKeystroke ifTrue:[newEvent setKey: (evt keyCharacter)].
	].
	^newEvent! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 5/27/1999 15:44'!
doFirstPersonControl: aBoolean
	firstPersonControls _ aBoolean! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 9/16/1999 16:39'!
firstPersonKeystroke: evt
	"Handle a keyboard event"
	| keyValue |
	lastCursorPoint _ evt cursorPoint.
	keyValue _ evt keyValue.
	evt shiftPressed ifTrue:[
		keyValue = 28 ifTrue:[^myCamera move: left distance: 0.25].
		keyValue = 29 ifTrue:[^myCamera move: right distance: 0.25].
		keyValue = 30 ifTrue:[^myCamera move: forward distance: 0.25].
		keyValue = 31 ifTrue:[^myCamera move: backward distance: 0.25].
	] ifFalse:[
		keyValue = 28 ifTrue:[^myCamera turn: left turns:  0.0625 duration: 0.25 style: abruptly].
		keyValue = 29 ifTrue:[^myCamera turn: right turns:  0.0625 duration: 0.25 style: abruptly].
		keyValue = 30 ifTrue:[^myCamera move: forward].
		keyValue = 31 ifTrue:[^myCamera move: backward].
	].! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 6/2/1999 13:45'!
getEventFocus
	"Return the actor that all events should go to. If not explicitly specified, choose the actor under the mouse cursor.  If no actor is under the mouse cursor, return nil.
	ar 6/2/1999: This method is more or less obsolete. For event handling, #convertEvent: should be used."
	self flag: #obsolete.

	eventFocus ifNotNil: [ ^ eventFocus ].

	^ myCamera pickAt: (Sensor cursorPoint).
! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:00'!
handlesKeyboard: evt
	^true! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'jsp 4/19/1999 12:53'!
handlesMouseDown: evt
	"We want to handle mouse up and down events, so return true"

	^ true.
! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'jsp 4/19/1999 17:42'!
handlesMouseOver: evt
	"We want to handle mouse enter/leave events, so return true."

	^ true.

! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 11/7/1999 23:27'!
keyStroke: evt
	"Handle a keyboard event"

	| newEvent reactions |
	firstPersonControls == true "For existing camera morphs"
		ifTrue:[^self firstPersonKeystroke: evt].

	newEvent _ self convertEvent: evt.
	newEvent ifNil:[^self].
	"Check for active textures"
	newEvent getActor hasActiveTexture 
		ifTrue:[^newEvent getActor morphicKeyPress: newEvent].
	"Route to actor"
	reactions _ newEvent getActor getReactionsTo: keyPress.
	reactions ifNotNil:[ 
		reactions do: [:aReaction | aReaction reactTo: newEvent ]].
! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 11/6/2000 14:58'!
mouseDown: evt 
	"When the user clicks in a camera window, determine which actor the    
	         user clicked on and have that actor respond to the event"
	| newEvent reactions |
	firstPersonControls == true ifTrue:[
		myControls setCenter: evt position.
		myControls mouseDown: evt.
		evt hand needsToBeDrawn ifFalse:[Cursor crossHair show].
		^self
	].
	newEvent _ self convertEvent: evt.
	newEvent
		ifNotNil: 
			[((mode = #paint and: [newEvent getVertex ~= nil]) and: [evt commandKeyPressed not])
				ifTrue:
					[self prepareAction: newEvent.
					^self perform: palette action with: newEvent]
				ifFalse:
					[newEvent getActor hasActiveTexture
						ifTrue: [^ newEvent getActor morphicMouseDown: newEvent].
					evt redButtonPressed
						ifTrue: 
							[reactions _ newEvent getActor getReactionsTo: leftMouseDown.
							mouseUpButton _ leftMouseUp]
						ifFalse: [evt yellowButtonPressed
								ifTrue: 
									[reactions _ newEvent getActor getReactionsTo: rightMouseDown.
									mouseUpButton _ rightMouseUp]
								ifFalse: [reactions _ nil]].
					reactions ifNotNil: [reactions do: [:aReaction | aReaction reactTo: newEvent]]]]! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:25'!
mouseEnter: evt
	"When the mouse enters our window give it the keyboard focus"

	evt hand newKeyboardFocus: self.

	mode = #paint ifTrue: [evt hand showTemporaryCursor: palette actionCursor].
! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 9/15/2000 23:31'!
mouseLeave: evt
	"When the mouse leaves our window release the keyboard focus"

	evt hand releaseKeyboardFocus: self.

	mode = #paint ifTrue: [evt hand showTemporaryCursor: nil]
! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 11/6/2000 14:49'!
mouseMove: evt 
	"When the user clicks in a camera window, determine which actor the    
	    user clicked on and have that actor respond to the event"
	| newEvent reactions |
	firstPersonControls == true ifTrue:[^self].
	newEvent _ self convertEvent: evt.
	mode = #stroke
		ifTrue: [self recordStroke: evt cursorPoint]
		ifFalse: [newEvent
				ifNotNil: 
					[((mode = #paint and: [newEvent getVertex ~= nil]) and: [evt commandKeyPressed not])
						ifTrue:
							[newEvent getActor = currentActor
								ifTrue: [
									self prepareAction: newEvent.
									^self perform: palette action with: newEvent]]
						ifFalse: [
							newEvent getActor hasActiveTexture
								ifTrue: [^ newEvent getActor morphicMouseMove: newEvent].
								reactions _ newEvent getActor getReactionsTo: mouseMove.
								reactions ifNotNil: [reactions do: [:aReaction | aReaction reactTo: newEvent]]]]]! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'ar 11/6/2000 14:50'!
mouseUp: evt 
	"When the user clicks in a camera window, determine which actor the    
	user clicked on and have that actor respond to the event"
	| newEvent reactions |
	firstPersonControls == true ifTrue:[
		myControls mouseUp: evt.
		myControls setCenter: nil.
		evt hand needsToBeDrawn ifFalse:[Cursor normal show].
		^self
	].
	self mode = #stroke ifTrue: [self createPoohActor. ^ self mode: nil].
	newEvent _ self convertEvent: evt.
	newEvent ifNil: [^ self].
	(self mode = #paint and: [newEvent getVertex ~= nil])
		ifTrue:
			[self prepareAction: newEvent.
			^ self perform: palette action with: newEvent].
	newEvent getActor hasActiveTexture ifTrue: [^ newEvent getActor morphicMouseUp: newEvent].
	reactions _ newEvent getActor getReactionsTo: mouseUpButton.
	reactions ifNotNil: [reactions do: [:aReaction | aReaction reactTo: newEvent]]! !

!WonderlandCameraMorph methodsFor: 'event handling' stamp: 'jsp 4/19/1999 13:58'!
setEventFocus: anActor
	"Set the actor that all events should go to"

	eventFocus _ anActor.
! !


!WonderlandCameraMorph methodsFor: 'geometry' stamp: 'ar 9/10/2000 16:06'!
containsPoint: aPoint
	"Perform a full picking op if the camera does not draw the background"
	myCamera drawSceneBackground
		ifTrue:[^super containsPoint: aPoint].
	"*** hack ***"
	pickedPoint = aPoint 
		ifFalse:[pickedActor _ myCamera pickAt: aPoint].
	pickedPoint _ aPoint.
	^pickedActor notNil! !


!WonderlandCameraMorph methodsFor: 'halos and balloon help' stamp: 'laza 3/24/2000 13:56'!
balloonHelpTextForHandle: aHandle
	|  itsSelector |
	itsSelector _ aHandle eventHandler firstMouseSelector.
	itsSelector == #strokeMode ifTrue: [^'Create Pooh Object'].
	^ super balloonHelpTextForHandle: aHandle! !


!WonderlandCameraMorph methodsFor: 'initialization' stamp: 'RAA 6/3/2000 10:56'!
initialize
	super initialize.
	lastCursorPoint _ 0 @ 0.
	CurrentProjectRefactoring currentAddGuard: self.

	"Teddy"
	self mode: #view.
	self outline: POSimplePolygon new! !

!WonderlandCameraMorph methodsFor: 'initialization' stamp: 'jsp 4/23/1999 12:06'!
initializeWithCamera: aCamera
	"Initialize this instance and hand it a camera"

	myCamera _ aCamera.
	myWonderland _ aCamera getWonderland.
	self name: (myCamera getName).

	"Use a transparent background"
	color _ (Color transparent).

	self bounds: (20@20 corner: 170@170)! !

!WonderlandCameraMorph methodsFor: 'initialization' stamp: 'ar 4/19/1999 04:31'!
okayToEnterProject
	"Check if it is okay to enter the project containing the receiver"
	B3DPrimitiveEngine isAvailable ifFalse:[
		^(self confirm:'You are about to enter a project requiring 3D primitive support.
This support is currently NOT available.
Do you really want to enter the project?')].
	^true! !


!WonderlandCameraMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 15:09'!
addCustomMenuItems: aCustomMenu hand: aHandMorph 
	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addUpdating: #snapshotBackgroundString action: #toggleSnapshotBackground.
	aCustomMenu addUpdating: #getDragAndDropState action: #toggleDragAndDropState.
	(myControls == nil)
		
		ifTrue:[aCustomMenu add: 'showCameraControls' action: #showCameraControls]
ifFalse:[aCustomMenu add: 'hideCameraControls' action: #deleteCameraControls]
		
	
! !

!WonderlandCameraMorph methodsFor: 'menu' stamp: 'panda 4/25/2000 15:49'!
getDragAndDropState
	self dragNDropEnabled
		ifTrue:[^'close to drag and drop']
		ifFalse:[^'open to drag and drop']! !

!WonderlandCameraMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 15:08'!
snapshotBackgroundString
	^(self hasProperty: #backgroundSnapshot) 
		ifTrue:[^'<on>background snapshot'] 
		ifFalse:['<off>background snapshot'].! !

!WonderlandCameraMorph methodsFor: 'menu' stamp: 'panda 4/25/2000 15:43'!
toggleDragAndDropState
	self dragNDropEnabled
		ifTrue:[self disableDragNDrop]
		ifFalse:[self enableDragNDrop]! !

!WonderlandCameraMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 15:09'!
toggleSnapshotBackground
	(self hasProperty: #backgroundSnapshot)
		ifTrue:[self removeProperty: #backgroundSnapshot]
		ifFalse:[self setProperty: #backgroundSnapshot toValue: (Form extent: 1@1)].! !


!WonderlandCameraMorph methodsFor: 'picking points' stamp: 'jsp 3/29/1999 11:51'!
pickPointInBounds: boundary
	"Chooses a random point so that this morph lies within the specified bounds"

	| xpos ypos |

	xpos _ (boundary left) + (0 to: ((boundary width) - (bounds width))) atRandom.
	ypos _ (boundary top) + (0 to: ((boundary height) - (bounds height))) atRandom.

	^ xpos@ypos.

! !

!WonderlandCameraMorph methodsFor: 'picking points' stamp: 'jsp 3/29/1999 11:46'!
pickPointOnBounds: boundary
	"Chooses a random point so that an edge of this morph lies on the specified bounds"

	| side pos |

	"First choose which side to move the morph to"
	side _ (1 to: 4) atRandom.

	"Now choose where on that side to move to"
	((side = 1) or: [ side = 3 ])
			ifTrue: [ pos _ (0 to: ((boundary height) - (bounds height))) atRandom]
			ifFalse: [ pos _ (0 to: ((boundary width) - (bounds width))) atRandom ].

	"Now assemble the point)"
	"left"
	(side = 1) ifTrue: [ ^ (boundary left)@((boundary top) + pos) ].

	"top"
	(side = 2) ifTrue: [ ^ ((boundary left) + pos) @ (boundary top) ].

	"right"
	(side = 3) ifTrue: [ ^ ((boundary right) - (bounds width)) @ ((boundary top) + pos) ].

	"bottom"
	^ ((boundary left) + pos) @ ((boundary bottom) - (bounds height)).
! !


!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'laza 3/20/2000 16:20'!
clearStroke
	self outline vertices: OrderedCollection new.! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'ar 4/6/2000 18:58'!
createPoohActor
	| tdo actor |
	outline normalizeTo: 20.
	"outline reduceTo: 80."

	outline _ outline normalizedWithin: self bounds.

	tdo _ POObject createOn: self outline.

	actor _ self getWonderland makeActorNamed: 'pooh'.
	actor setProperty: #handmade toValue: true;
	 setMesh: tdo asB3DSimpleMesh;
	 setColor: brown;
	 setTexturePointer: ((Form extent: 256@128 depth: Display depth) fillColor: Color white) asTexture.

	"actor scaleByMatrix: (B3DMatrix4x4 identity setScale: 0.01@0.01@0.01)."
	actor setComposite: (myCamera getMatrixFromRoot composedWithLocal: (B3DMatrix4x4 withOffset: 0@0@2)).

	self clearStroke.
	Cursor normal beCursor! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'laza 3/24/2000 15:31'!
drawOnTextureOf: anActor from: texStart to: texEnd
	"texStart and texEnd are Coordinates on a Texture"
	| texture range start end |
	texture _ anActor getTexturePointer.
	range _ texture extent.
	start _ range * texStart.
	end _ range * texEnd.
	texture drawLine: (Form dotOfSize: 3) from: start to: end clippingBox: (1@1 extent: range) rule: Form over fillColor: nil 

! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'sma 4/30/2000 10:19'!
paintMode
	| temp clickedActor |
	self mode: #paint.

	temp _ myCamera pickObjectAndVertexAt: Sensor cursorPoint.
	clickedActor _ temp key.

	backup _ clickedActor getTexturePointer deepCopy.

	palette _ self world paintBox.
	palette position: self position + (self extent x @ 0); focusMorph: self.! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'sma 4/30/2000 10:20'!
paintModeFor: anActor
	self mode: #paint.
	(self world paintBox) position: self position + (self extent x @ 0); focusMorph: self.! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'laza 3/20/2000 16:11'!
recordStroke: p
	self outline add: p! !

!WonderlandCameraMorph methodsFor: 'pooh' stamp: 'laza 3/20/2000 16:55'!
strokeMode
	self clearStroke.
	self mode: #stroke.
	Cursor crossHair beCursor.
	self removeHalo.! !


!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 15:50'!
clear: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 14:18'!
ellipse: newEvent
	| type |
	type _ newEvent getMorphicEvent type.
	self perform: (type, 'Ellipse:') asSymbol with: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 15:42'!
erase: newEvent
	currentCanvas fillRectangle: (currentPosition extent: currentNib extent) color: Color white

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 15:51'!
fill: newEvent
	currentCanvas form shapeFill: currentColor interiorPoint: currentPosition! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 13:42'!
line: newEvent
	| type |
	type _ newEvent getMorphicEvent type.
	self perform: (type, 'Line:') asSymbol with: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 14:18'!
mouseDownEllipse: newEvent
	self mouseDownLine: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 16:00'!
mouseDownLine: newEvent
	self storeTexture.
	lastPosition _ currentPosition
	
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 16:40'!
mouseDownRect: newEvent
	self mouseDownLine: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 16:06'!
mouseMoveEllipse: newEvent
	| rect |
	self restoreTexture.
	rect _ Rectangle encompassing: { lastPosition. currentPosition }.
	currentCanvas fillOval: rect color: currentColor borderWidth: currentNib extent x borderColor: Color black

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 15:59'!
mouseMoveLine: newEvent
	self restoreTexture.
	currentCanvas line: lastPosition to: currentPosition width: currentNib extent x color: currentColor

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 16:02'!
mouseMoveRect: newEvent
	| rect |
	self restoreTexture.
	rect _ Rectangle encompassing: { lastPosition. currentPosition }.
	currentCanvas frameAndFillRectangle: rect fillColor: currentColor borderWidth: currentNib extent x borderColor: Color black

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 16:06'!
mouseUpEllipse: newEvent

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 14:20'!
mouseUpLine: newEvent

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 16:43'!
mouseUpRect: newEvent

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 15:41'!
paint: newEvent
	currentCanvas stencil: currentNib at: currentPosition color: currentColor

! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 15:50'!
polygon: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'ar 5/25/2000 18:02'!
prepareAction: newEvent
	|  range  |
	currentColor _ palette getColor.
	currentNib _ palette getNib.
	currentActor _ newEvent getActor.
	currentCanvas _ (currentActor getTexturePointer getCanvas).
	range _ currentCanvas extent.
	currentPosition _ newEvent getVertex texCoords * range - (currentNib extent // 2).! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 16:41'!
rect: newEvent
	| type |
	type _ newEvent getMorphicEvent type.
	self perform: (type, 'Rect:') asSymbol with: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/30/2000 10:02'!
restoreTexture
	self restoreTextureFrom: restore! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/30/2000 10:02'!
restoreTextureFrom: aForm
	| texture |
	texture _ aForm deepCopy.
	currentActor setTexturePointer: texture.
	currentCanvas setForm: texture.! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/27/2000 15:50'!
stamp: newEvent
! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 09:27'!
star: newEvent
	"verts _ (0 to: 350 by: 36) collect: [:angle |
		(Point r: (oldR _ oldR = ext ifTrue: [ext*5//12] ifFalse: [ext]) degrees: angle + pt degrees)
			+ strokeOrigin].
	
	poly _ PolygonMorph new addHandles.
	poly color: currentColor; borderWidth: currentNib extent x; borderColor: Color black.
	poly privateOwner: self.
	poly bounds: (strokeOrigin extent: ext).
	poly setVertices: verts.
	poly drawOn: formCanvas."! !

!WonderlandCameraMorph methodsFor: 'pooh-actions' stamp: 'laza 3/29/2000 16:00'!
storeTexture
	restore _ currentCanvas form deepCopy.
! !


!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/30/2000 10:04'!
cancel
	mode _ nil.
	self restoreTextureFrom: backup.
	palette delete! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/24/2000 16:38'!
cancelPainting: aPaintBoxMorph
	^self cancel! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 4/5/2000 09:55'!
clear
	currentActor ifNotNil: [
		currentActor setTexturePointer: ((Form extent: 256@128 depth: Display depth) fillColor: Color white) asTexture]
! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/24/2000 16:32'!
clearPainting: aPaintBoxMorph
	"Clear the image after user issued #clear in aPaintBoxMorph"
	^self clear! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/24/2000 16:32'!
paletteAttached: aPaintBoxMorph
	"A new palette has been attached to the receiver.
	Don't know what to do here..."! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/30/2000 11:08'!
paletteDetached: aPaintBoxMorph
	self cancel	! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/30/2000 11:03'!
save
	(self getWonderland getUndoStack) push: (UndoTextureChange for: currentActor from: backup).
	palette delete.
	mode _ nil
! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/24/2000 16:33'!
savePainting: aPaintBoxMorph
	"Save the image after user issued #keep in aPaintBoxMorph"
	^self save! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/30/2000 10:03'!
undo
	self restoreTextureFrom: backup! !

!WonderlandCameraMorph methodsFor: 'pooh-palette' stamp: 'laza 3/24/2000 16:39'!
undoPainting: aPaintBoxMorph
	^self undo! !



!WonderlandCameraMorph methodsFor: 'stepping' stamp: 'ar 9/10/2000 16:04'!
step

	self changed.
	"*** hack ***"
	pickedPoint _ nil.! !

!WonderlandCameraMorph methodsFor: 'stepping' stamp: 'jsp 3/22/1999 10:25'!
stepTime
	
	^ 1.
! !

!WonderlandCameraMorph methodsFor: 'stepping' stamp: 'jsp 3/22/1999 10:25'!
wantsSteps

	^ true.
! !


!WonderlandCameraMorph methodsFor: 'wrappers' stamp: 'ar 11/7/1999 21:57'!
addHalo: evt
	"Add a halo to an object"
	| actor wrapper root |
	self removeAllWrappers. "Get rid of them"
	evt == nil ifTrue:[^super addHalo: evt].
	actor _ myCamera pickAt: evt cursorPoint.
	actor == nil ifTrue:[^super addHalo: evt]. "Nothing hit"
	wrapper _ WonderlandWrapperMorph on: actor.
	root _ wrapper createHierarchy.
	root computeFullBounds: self.
	self addMorphFront: root.
	wrapper addHalo. "Add programatically"! !

!WonderlandCameraMorph methodsFor: 'wrappers' stamp: 'ar 11/7/1999 21:57'!
addHalo: evt from: formerHaloOwner
	"Special case if the formerHaloOwner was a wrapper within the receiver"
	self removeAllWrappers. "Get rid of them"
	(formerHaloOwner isKindOf: WonderlandWrapperMorph)
		ifTrue:[^super addHalo: evt] "Add a halo to me"
		ifFalse:[^self addHalo: evt] "Add a halo from pick"! !

!WonderlandCameraMorph methodsFor: 'wrappers' stamp: 'ar 11/7/1999 22:00'!
removeAllWrappers
	submorphs do:[:m|
		(m isKindOf: WonderlandWrapperMorph) ifTrue:[m delete]].! !


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandCameraMorph class
	instanceVariableNames: ''!

!WonderlandCameraMorph class methodsFor: 'initialize-release' stamp: 'laza 3/24/2000 14:23'!
initialize
	"WonderlandCameraMorph initialize"
	self installPoohIcon! !


!WonderlandCameraMorph class methodsFor: 'pooh stuff' stamp: 'laza 4/4/2000 14:14'!
installPoohIcon
	ScriptingSystem saveForm:
			((ColorForm
			extent: 16 @ 16
			depth: 1
			fromArray: #(0 0 0 473432064 536346624 229638144 267386880 106954752
							62914560 132120576 267386880 536346624 511180800 0 0 0 )
			offset: 0 @ 0)
			colorsFromArray: #((1.0 1.0 1.0 ) (0.0 0.0 0.004 ) ))
		atKey: 'Halo-Pooh'! !

!WonderlandCameraMorph class methodsFor: 'pooh stuff' stamp: 'laza 4/5/2000 10:19'!
openPoohAboutWindow
	"WonderlandCameraMorph openPoohAboutWindow"
	| window image text button extent |

	extent _ Display extent // 3 * (1.5@1.5).

	window _ SystemWindow labelled: 'About Pooh'.

	image _ (ImageMorph new image: self poohAboutImage).
	text _ TextMorph new contentsWrapped: self poohAboutText; occlusionsOnOff.
	button _ SimpleButtonMorph new label: 'Ok'; target: window; actionSelector: #delete.

	window addMorph: text frame: (0.01@0.01 corner: 0.99@0.84).
	window addMorph: image frame: (0.01@0.01 corner: 0.99@0.84).
	window addMorph: button frame: (0.45@0.85 corner: 0.55@0.99).

	window setWindowColor: Color white;
		color: Color white.

	window openInWorldExtent: extent.
! !

!WonderlandCameraMorph class methodsFor: 'pooh stuff' stamp: 'laza 4/4/2000 16:02'!
poohAboutImage
 ^  (ColorForm
	extent: 105@109
	depth: 4
	fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 273 0 0 0 0 0 0 0 0 0 0 0 0 0 4369 286261248 0 0 0 0 0 0 0 0 0 0 0 0 1118481 286330880 0 0 0 0 0 0 0 0 0 0 0 0 17895698 554766336 0 0 0 0 0 0 0 0 0 0 0 1 286331426 571543552 0 0 0 0 0 0 0 0 0 0 0 17 286401058 572592145 268435456 1118480 0 0 0 0 0 0 0 0 0 273 287449634 572592401 285212672 1118481 285212672 0 0 0 0 0 0 0 0 4369 287449634 572592401 286326784 286331153 286261248 0 0 0 0 0 0 0 17895697 286331153 287449634 571543825 286331137 286331409 286330880 0 0 0 0 0 0 69632 286331153 286335505 287449634 571543842 554766609 286335522 286330880 0 0 0 0 0 0 69905 286331153 286335249 287449634 571543842 572592401 286335522 286330880 0 0 0 0 0 0 285217041 286331426 572662033 287449634 571543842 572662305 286401058 554766592 0 0 0 0 0 1 286265617 286335522 572596497 287449634 554766882 572662305 287449634 554766592 0 0 0 0 0 1 286331153 303112738 554770705 287449634 554766882 572662306 287449634 571543552 0 0 0 0 0 1 286331426 572662306 286335505 287449634 286335522 572662306 287449634 554766336 0 0 0 0 0 17 286331426 572662305 286401057 287449634 554836514 572662306 555885090 286330880 0 0 0 0 0 4369 286401058 572662305 287449634 287449634 572662306 572662306 572662306 286330880 0 0 0 0 0 1118481 287449634 572662289 304226850 572662306 572662306 572662306 571544098 286326784 0 0 0 0 0 1118481 287449634 572662289 304226850 572662306 572662306 572662306 571544097 286261248 0 0 0 0 0 1118481 304226850 572662289 304226850 572662306 572662306 572662306 572592657 286261248 0 0 0 0 0 17895698 572662306 572662289 572662306 572662306 572662306 572662306 572592401 268435456 0 0 0 0 0 286331426 572662306 572662289 572662306 572662306 572662306 572662306 571543825 0 0 0 0 0 1 286331426 572662306 572662289 572662306 572662306 572662306 572662306 571543825 0 0 0 0 0 17 287449634 572662306 572662290 554770978 572662306 572662306 572662306 571543552 0 0 0 0 0 273 304226850 572662306 572662289 286335522 572662306 572662306 572662306 571543552 0 0 0 0 0 273 304226850 572662306 572662289 286401058 572662306 572662306 572662306 571543552 0 0 0 0 0 69905 572662306 572662306 572662289 287449634 572662306 572662306 572662306 571543552 0 0 0 0 0 69905 572662306 572662306 572662289 304226850 572662306 572662306 572662306 571543552 0 0 0 0 0 1118482 572662306 572662306 572662289 287449634 572662306 572662306 572662306 554766336 0 0 0 0 0 286331170 572662305 286331154 572662033 303112738 572662306 572662306 572662306 286326784 0 0 0 0 0 286331170 572662305 286331153 572662033 303112738 572662306 572662306 572662306 286326784 0 0 0 0 17 286331426 572662306 286331153 572657937 286335522 572662306 572662306 572662306 286261248 0 0 0 0 273 286335522 572662306 572592401 572657937 554836514 572662306 572662306 572662305 286261248 0 0 0 0 273 286401058 572662306 572657953 304222481 555885090 572662306 572662306 572662305 286261248 0 0 0 0 273 286401058 572662306 572662033 304222482 555885090 572662306 572662306 572662289 285212672 0 0 0 0 273 286401058 572662306 572662033 287445266 287449634 572662306 572662306 572662289 285212672 0 0 0 0 273 287449634 572662306 572662033 304222482 304226850 572662306 572662306 572662033 285212672 0 0 0 0 4369 287449634 572662306 572662289 287449362 304226850 572662306 572662306 572662033 285212672 0 0 0 0 1118481 304226850 572662306 572662305 287449362 287449634 572662306 572662306 572657937 268435456 0 0 0 0 1118481 572662306 572662306 572662305 286400785 287449634 572662306 572662306 572657937 0 0 0 0 0 1118481 572662306 572662306 572662306 286335249 287449634 572662306 572662306 572592400 0 0 0 0 0 4370 572662306 554770978 572662306 286331153 554836514 572662306 572592401 286331136 0 0 0 0 0 69906 572662306 554770978 572662306 286331409 286335522 571613457 286331153 286331152 0 0 0 0 0 1118482 571548194 554770978 572662306 286331153 286335522 554766609 286331153 286331153 0 0 0 0 0 17895970 554832146 554770978 572662306 571543825 554766609 286331153 286470963 858993425 268435456 0 0 0 0 286331170 286396690 554770978 572662306 554766609 286331153 286331187 858993457 286339857 285212672 0 0 0 0 286331426 286400785 286335522 572662306 554766609 286396689 286339891 286331153 286331153 286261248 0 0 0 1 286343441 304226833 286335522 572662306 572657937 286331153 286331153 286331153 288559377 286330880 0 0 0 1 286331153 304226834 286331426 572662306 572657937 286331153 288428305 286331153 286331153 286330880 0 0 0 1 286331169 572662289 286331170 572662306 572662033 286331155 286331153 286331155 856895763 304156928 0 0 0 0 286331426 572657938 286331154 572662306 572662306 554766609 286331699 856756497 286331153 287379728 0 0 0 0 286335522 572657953 287445265 572662306 572662306 554770705 286331153 286331155 858984721 304222480 0 0 0 1 286335522 572662289 304222481 287449634 572662306 572596770 554766609 858993459 858984721 572657936 0 0 0 0 286331154 572662306 554766609 286401058 572662306 572662306 572662033 286331153 288559378 572662033 0 0 0 0 286331170 572662306 554770961 286401058 572662306 572662306 572662289 286331699 858984738 572662033 0 0 0 0 286331426 572662306 572657953 286401058 572662306 572662306 572662305 319886097 286331170 572662033 0 0 0 1 286335522 572662306 572657937 286331426 572662306 572662306 572662306 286331699 856756770 572657936 0 0 0 1 286335522 572662306 572657937 554766609 572662306 572662306 572662306 288428305 286331170 572657936 0 0 0 1 286335522 572662306 572662306 554766609 286401058 572662306 572662306 286331153 286331170 572657936 0 0 0 17 286335522 572662306 572657937 572662033 286331153 286401058 572662306 286331153 286331154 572592384 0 0 0 17 286335522 572662306 572662306 571543825 286331153 286335521 304222498 286331155 858853649 571543552 0 0 0 17 286335522 572662306 572657937 286331153 286331665 286331170 287445537 286331699 858984721 286330880 0 0 0 17 286331426 572662306 572657937 304226850 286331153 286331153 286331153 286470417 286331153 286330880 0 0 0 17 286331426 572662306 572662306 572662305 286331155 288428305 286331153 286462227 286331697 286330880 17825792 0 0 273 286331426 572662306 572662306 572662289 286331153 858992913 286331153 286331153 322122547 858853377 286326784 0 0 273 286335522 572662306 572662306 572662306 286331153 286331153 288559411 823202065 286462227 858853393 286331136 0 0 273 286335522 572662306 572662306 572662306 554836497 286331155 856756531 286331697 286462227 858853649 571543808 0 0 273 286335522 572662306 572662306 572662306 572662289 286339891 286331187 858993459 858993459 856756497 572592400 0 0 273 286335522 572662306 572657937 286335522 571543825 286331153 286331153 286331153 286331153 286331170 287379729 0 0 273 286335522 572662306 304222481 286331425 286331153 286331153 288568081 286331153 322122547 856756514 287445265 0 0 17 286335522 572662305 287379729 286331153 287449617 286331155 858992913 554775347 858993459 856756513 287445265 0 0 17 286335522 572662033 287449634 572662289 287445265 286470961 286331170 571543857 286331153 286331169 572662033 0 0 17 303112482 572657937 287449634 572662289 286331153 286462225 321982754 571543825 286462771 856756513 287383825 0 0 17 303108386 572592401 287449634 572662306 286400785 286331153 286331170 571543859 858993459 858853666 304156945 0 0 1 286331169 572592401 572662306 572662306 286331153 286462225 286331426 571543825 286331153 286331170 287379728 0 0 1 286331169 572596497 572662306 572662306 287379730 554766609 823202338 571609361 858993459 856756498 304156944 0 0 1 286396705 572592402 572662306 572662306 572592418 286331153 286331426 572657939 858984721 286331154 304156944 0 0 0 286331409 304156962 572662306 572662306 572662033 286339857 286335522 571609361 286462771 856756753 304222480 0 0 0 286331153 287379746 572662306 572662306 572662289 286331155 286331425 303178001 858993459 823202081 572657936 0 0 0 17895697 286331170 572662306 572662306 572662305 286331155 286331425 572662035 856756497 286335266 572657936 0 0 0 69905 571543842 572662306 572662306 572662306 572592401 554770977 287383825 322122547 856760609 572657920 0 0 0 69905 572592402 572662306 572662306 572662306 571740434 554836497 304161043 858984721 286331153 304156928 0 0 0 69905 304156945 572662306 572662306 572662306 572596770 554836497 572596499 823202065 319885585 572592384 0 0 0 4369 286396690 286331154 572662306 572592674 571548193 336732433 572592401 322122545 288428306 572592384 0 0 0 273 286331153 554766609 304161314 572592674 554836513 287449361 572592403 858853649 288493858 304156928 0 0 0 273 286331153 287445265 286331425 572592674 304226849 287449362 572592401 286331153 823202338 304156928 0 0 0 0 286331153 286331153 286331153 287445282 304226849 304226578 572592435 825299219 286331425 571543808 0 0 0 0 286331153 286331154 287445266 287445282 286401057 304222482 572592401 286470963 287449633 571543552 0 0 0 0 268505361 286331153 286331153 286331426 554836513 304222497 554766611 858993459 824320273 286326784 0 0 0 0 273 286331153 286331153 286331153 286335249 287379985 571543825 286331153 286396689 286261248 0 0 0 0 0 17895697 286331153 286331153 286335250 287449361 554766609 286331153 286331153 268435456 0 0 0 0 0 4353 286331153 286396689 286335506 287449362 286331153 286331153 286330880 0 0 0 0 0 0 0 0 286331153 286331153 286331154 286331153 0 0 0 0 0 0 0 0 0 0 4369 286331153 286331153 286261248 0 0 0 0 0 0 0 0 0 0 17 286331153 286331169 286261248 0 0 0 0 0 0 0 0 0 0 0 1118481 286331153 268435456 0 0 0 0 0 0 0 0 0 0 0 4369 286331153 0 0 0 0 0 0 0 0 0 0 0 0 0 1118481 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
	offset: 0@0)
	colorsFromArray: #(#( ) #(0.0 0.0 0.0) #(1.0 1.0 0.333) #(0.501 0.0 0.0) #(0.753 0.862 0.753) #( ) #( ) #( ) #( ) #( ) #( ) #( ) #( ) #( ) #( ) #( )  )! !

!WonderlandCameraMorph class methodsFor: 'pooh stuff' stamp: 'laza 4/4/2000 16:44'!
poohAboutText
	| about url font pattern start end |
	about _ '     Pooh

This software is based on the work of Takeo Igarashi, Satoshi Matsuoka and Hidehiko Tanaka, which is described in "Teddy: A Sketching Interface for 3D Freeform Design".

To play around with Pooh just open a Wonderland and bring up the halos on the CameraMorph. Click on the Pooh halo and start drawing an outline. After that you can bring up the halos on the generated object and click on the Paint halo to draw on the surface. (Or have a look at this tape)' asText.


	font _ TextFontChange new fontNumber: 3.

	pattern _ 'Pooh'.
	start _ about string findString: pattern.
	end _ start + pattern size.
	about addAttribute: font from: start to: end.
	about makeBoldFrom: start to: end.

	pattern _ 'Takeo Igarashi'.
	start _ about string findString: pattern.
	end _ start + pattern size.
	url _ TextURL new url: 'http://www.mtl.t.u-tokyo.ac.jp/~takeo/teddy/teddy.htm'.
	about addAttribute: url from: start to: end.

	pattern _ 'open a Wonderland'.
	start _ about string findString: pattern.
	end _ start + pattern size.
	url _ TextDoIt new evalString: 'Wonderland new'.
	about addAttribute: url from: start to: end.

	pattern _ 'tape'.
	start _ about string findString: pattern.
	end _ start + pattern size.
	url _ TextDoIt new evalString: 'WonderlandCameraMorph poohPlayTape'.
	about addAttribute: url from: start to: end.

	^ about! !

!WonderlandCameraMorph class methodsFor: 'pooh stuff' stamp: 'laza 4/5/2000 10:13'!
poohPlayTape
	"| tape source | 
	tape _ FileStream fileNamed: 'pooh.tape'.
	source _ 'poohTape	^''', tape contentsOfEntireFile, ''''.
	(WonderlandCameraMorph class methodsFor: 'pooh stuff') scanFrom: (ReadStream on: source)"
	"WonderlandCameraMorph poohPlayTape"
	| stream player |
	stream _ ReadStream on: self poohTape.
	player _ EventRecorderMorph readFrom: stream.
	player openInWorld.
	Wonderland new.
	player play.
	player delete.! !

!WonderlandCameraMorph class methodsFor: 'pooh stuff'!
poohTape	^'36 mouseMove 59 236 0 0
589 mouseMove 60 233 0 0
34 mouseMove 60 232 0 0
73 mouseMove 60 231 0 0
35 mouseMove 61 231 0 0
28 mouseMove 62 230 0 0
35 mouseMove 62 228 0 0
62 mouseMove 63 226 0 0
39 mouseMove 65 224 0 0
35 mouseMove 66 222 0 0
37 mouseMove 67 220 0 0
28 mouseMove 69 217 0 0
35 mouseMove 70 215 0 0
28 mouseMove 70 214 0 0
36 mouseMove 71 213 0 0
82 mouseMove 72 212 0 0
29 mouseMove 72 210 0 0
34 mouseMove 73 209 0 0
28 mouseMove 73 208 0 0
36 mouseMove 74 206 0 0
30 mouseMove 74 204 0 0
41 mouseMove 74 202 0 0
36 mouseMove 75 200 0 0
28 mouseMove 75 198 0 0
35 mouseMove 75 197 0 0
63 mouseMove 76 195 0 0
38 mouseMove 77 191 0 0
36 mouseMove 79 186 0 0
35 mouseMove 81 182 0 0
35 mouseMove 82 179 0 0
28 mouseMove 83 177 0 0
37 mouseMove 84 173 0 0
28 mouseMove 85 171 0 0
43 mouseMove 87 164 0 0
35 mouseMove 88 160 0 0
29 mouseMove 89 156 0 0
36 mouseMove 90 149 0 0
28 mouseMove 91 144 0 0
37 mouseMove 91 139 0 0
28 mouseMove 91 138 0 0
51 mouseMove 92 132 0 0
29 mouseMove 92 129 0 0
35 mouseMove 92 124 0 0
28 mouseMove 92 120 0 0
36 mouseMove 92 115 0 0
28 mouseMove 92 111 0 0
54 mouseMove 92 107 0 0
36 mouseMove 92 105 0 0
28 mouseMove 92 103 0 0
36 mouseMove 92 99 0 0
28 mouseMove 92 96 0 0
36 mouseMove 92 92 0 0
28 mouseMove 92 89 0 0
48 mouseMove 92 85 0 0
27 mouseMove 92 83 0 0
35 mouseMove 92 81 0 0
28 mouseMove 92 79 0 0
35 mouseMove 92 76 0 0
36 mouseMove 92 74 0 0
32 mouseMove 92 72 0 0
45 mouseMove 92 69 0 0
29 mouseMove 92 66 0 0
35 mouseMove 92 64 0 0
3339 mouseDown 92 64 1 0
138 mouseMove 92 64 1 0
59 mouseUp 92 64 0 0
34 mouseMove 92 64 0 0
753 mouseMove 95 65 0 0
29 mouseMove 101 68 0 0
38 mouseMove 114 76 0 0
29 mouseMove 116 77 0 0
67 mouseMove 117 78 0 0
28 mouseMove 118 78 0 0
51 mouseMove 119 79 0 0
28 mouseMove 120 80 0 0
38 mouseMove 122 81 0 0
29 mouseMove 124 82 0 0
35 mouseMove 125 82 0 0
77 mouseMove 128 84 0 0
36 mouseMove 130 84 0 0
28 mouseMove 131 85 0 0
37 mouseMove 134 86 0 0
30 mouseMove 137 87 0 0
37 mouseMove 143 88 0 0
35 mouseMove 145 88 0 0
46 mouseMove 148 89 0 0
37 mouseMove 151 90 0 0
28 mouseMove 153 90 0 0
36 mouseMove 156 90 0 0
30 mouseMove 159 91 0 0
36 mouseMove 163 91 0 0
40 mouseMove 168 92 0 0
36 mouseMove 171 92 0 0
29 mouseMove 173 92 0 0
34 mouseMove 176 93 0 0
37 mouseMove 179 94 0 0
29 mouseMove 179 95 0 0
37 mouseMove 180 95 0 0
45 mouseMove 181 96 0 0
1953 mouseDown 181 96 4 0
118 mouseUp 181 96 0 0
28 mouseMove 181 96 0 0
584 mouseMove 178 93 0 0
39 mouseMove 175 91 0 0
34 mouseMove 174 90 0 0
64 mouseMove 170 89 0 0
28 mouseMove 168 87 0 0
34 mouseMove 162 85 0 0
46 mouseMove 157 83 0 0
29 mouseMove 156 82 0 0
35 mouseMove 154 81 0 0
28 mouseMove 152 79 0 0
35 mouseMove 151 78 0 0
28 mouseMove 150 77 0 0
50 mouseMove 148 75 0 0
28 mouseMove 145 74 0 0
36 mouseMove 141 72 0 0
30 mouseMove 138 70 0 0
35 mouseMove 136 69 0 0
28 mouseMove 134 67 0 0
35 mouseMove 130 65 0 0
46 mouseMove 126 64 0 0
28 mouseMove 125 63 0 0
36 mouseMove 122 62 0 0
28 mouseMove 120 62 0 0
35 mouseMove 118 61 0 0
28 mouseMove 116 61 0 0
53 mouseMove 113 60 0 0
27 mouseMove 112 59 0 0
62 mouseMove 111 59 0 0
35 mouseMove 109 58 0 0
60 mouseMove 106 57 0 0
35 mouseMove 105 57 0 0
39 mouseMove 104 56 0 0
183 mouseDown 104 56 4 0
83 mouseMove 103 56 4 0
45 mouseMove 101 56 4 0
50 mouseMove 98 55 4 0
45 mouseMove 96 55 4 0
62 mouseMove 92 55 4 0
47 mouseMove 89 55 4 0
45 mouseMove 87 55 4 0
46 mouseMove 83 55 4 0
53 mouseMove 80 55 4 0
73 mouseMove 77 55 4 0
48 mouseMove 74 55 4 0
46 mouseMove 71 56 4 0
47 mouseMove 68 58 4 0
65 mouseMove 64 61 4 0
47 mouseMove 62 63 4 0
47 mouseMove 60 65 4 0
47 mouseMove 58 66 4 0
65 mouseMove 54 70 4 0
54 mouseMove 51 73 4 0
47 mouseMove 49 76 4 0
49 mouseMove 47 80 4 0
56 mouseMove 46 83 4 0
47 mouseMove 46 86 4 0
51 mouseMove 46 90 4 0
47 mouseMove 46 92 4 0
47 mouseMove 46 96 4 0
63 mouseMove 46 100 4 0
56 mouseMove 46 106 4 0
49 mouseMove 48 112 4 0
52 mouseMove 50 116 4 0
62 mouseMove 54 121 4 0
48 mouseMove 56 123 4 0
52 mouseMove 59 126 4 0
48 mouseMove 61 128 4 0
59 mouseMove 64 130 4 0
49 mouseMove 68 133 4 0
56 mouseMove 73 136 4 0
48 mouseMove 77 137 4 0
59 mouseMove 84 138 4 0
49 mouseMove 88 139 4 0
58 mouseMove 96 140 4 0
50 mouseMove 101 140 4 0
48 mouseMove 106 140 4 0
52 mouseMove 108 140 4 0
52 mouseMove 112 140 4 0
51 mouseMove 116 139 4 0
48 mouseMove 120 137 4 0
49 mouseMove 124 135 4 0
67 mouseMove 131 131 4 0
49 mouseMove 134 127 4 0
51 mouseMove 138 124 4 0
49 mouseMove 140 121 4 0
60 mouseMove 143 116 4 0
55 mouseMove 145 110 4 0
49 mouseMove 147 106 4 0
56 mouseMove 148 100 4 0
59 mouseMove 148 95 4 0
57 mouseMove 148 89 4 0
50 mouseMove 148 85 4 0
48 mouseMove 148 82 4 0
70 mouseMove 148 79 4 0
55 mouseMove 148 77 4 0
49 mouseMove 148 74 4 0
48 mouseMove 148 72 4 0
50 mouseMove 147 69 4 0
67 mouseMove 145 65 4 0
50 mouseMove 143 62 4 0
56 mouseMove 141 60 4 0
58 mouseMove 140 59 4 0
102 mouseMove 139 59 4 0
48 mouseMove 139 58 4 0
110 mouseUp 139 58 0 0
1457 mouseMove 139 58 0 0
3329 mouseMove 140 59 0 0
84 mouseMove 141 60 0 0
57 mouseMove 142 60 0 0
63 mouseMove 145 60 0 0
64 mouseMove 152 61 0 0
71 mouseMove 161 62 0 0
65 mouseMove 169 63 0 0
62 mouseMove 179 64 0 0
76 mouseMove 225 72 0 0
60 mouseMove 240 75 0 0
68 mouseMove 243 76 0 0
71 mouseMove 248 78 0 0
121 mouseMove 248 81 0 0
61 mouseMove 248 87 0 0
80 mouseMove 248 91 0 0
66 mouseMove 248 94 0 0
59 mouseMove 248 98 0 0
80 mouseMove 248 107 0 0
61 mouseMove 247 111 0 0
64 mouseMove 246 115 0 0
69 mouseMove 244 121 0 0
65 mouseMove 243 124 0 0
268 mouseDown 243 124 4 0
198 mouseUp 243 124 0 0
56 mouseMove 243 124 0 0
1710 mouseDown 243 124 2 0
100 mouseMove 243 124 2 0
85 mouseUp 243 124 0 0
71 mouseMove 243 124 0 0
634 mouseMove 250 125 0 0
83 mouseMove 253 125 0 0
58 mouseMove 254 127 0 0
83 mouseMove 254 133 0 0
78 mouseMove 254 135 0 0
58 mouseMove 254 136 0 0
84 mouseMove 254 137 0 0
454 mouseDown 254 137 4 0
84 mouseUp 254 137 0 0
76 mouseMove 254 137 0 0
4817 mouseMove 249 137 0 0
58 mouseMove 245 137 0 0
66 mouseMove 240 136 0 0
76 mouseMove 236 133 0 0
60 mouseMove 230 130 0 0
66 mouseMove 221 125 0 0
71 mouseMove 215 122 0 0
73 mouseMove 208 118 0 0
67 mouseMove 203 116 0 0
61 mouseMove 195 113 0 0
77 mouseMove 186 110 0 0
60 mouseMove 178 107 0 0
66 mouseMove 170 104 0 0
70 mouseMove 164 102 0 0
68 mouseMove 154 99 0 0
67 mouseMove 147 98 0 0
60 mouseMove 141 96 0 0
71 mouseMove 132 93 0 0
61 mouseMove 122 91 0 0
66 mouseMove 116 90 0 0
72 mouseMove 110 89 0 0
66 mouseMove 103 88 0 0
74 mouseMove 100 88 0 0
70 mouseMove 96 87 0 0
371 mouseDown 96 87 1 0
199 mouseUp 96 87 0 0
85 mouseMove 96 87 0 0
504 mouseMove 95 88 0 0
69 mouseMove 93 90 0 0
62 mouseMove 93 91 0 0
77 mouseMove 92 93 0 0
68 mouseMove 92 94 0 0
1548 mouseDown 92 94 4 0
104 mouseUp 92 94 0 0
287 mouseMove 92 94 0 0
492 mouseMove 93 95 0 0
74 mouseMove 98 95 0 0
84 mouseMove 114 95 0 0
74 mouseMove 132 92 0 0
69 mouseMove 142 91 0 0
82 mouseMove 153 90 0 0
73 mouseMove 163 90 0 0
70 mouseMove 178 90 0 0
83 mouseMove 182 90 0 0
69 mouseMove 191 90 0 0
72 mouseMove 195 93 0 0
82 mouseMove 200 98 0 0
69 mouseMove 203 104 0 0
66 mouseMove 205 110 0 0
88 mouseMove 206 117 0 0
71 mouseMove 207 123 0 0
73 mouseMove 207 128 0 0
84 mouseMove 207 132 0 0
63 mouseMove 209 135 0 0
69 mouseMove 211 140 0 0
156 mouseMove 221 141 0 0
63 mouseMove 223 141 0 0
144 mouseMove 229 141 0 0
69 mouseMove 239 138 0 0
86 mouseMove 241 136 0 0
776 mouseMove 235 136 0 0
71 mouseMove 227 136 0 0
87 mouseMove 217 136 0 0
68 mouseMove 211 125 0 0
64 mouseMove 203 101 0 0
86 mouseMove 202 98 0 0
279 mouseMove 192 95 0 0
69 mouseMove 187 93 0 0
70 mouseMove 149 81 0 0
82 mouseMove 124 72 0 0
66 mouseMove 101 64 0 0
66 mouseMove 98 63 0 0
80 mouseMove 90 63 0 0
69 mouseMove 88 63 0 0
79 mouseMove 81 64 0 0
95 mouseMove 72 65 0 0
69 mouseMove 62 65 0 0
69 mouseMove 58 65 0 0
433 mouseDown 58 65 4 0
143 mouseUp 58 65 0 0
81 mouseMove 58 65 0 0
343 mouseMove 64 66 0 0
62 mouseMove 78 66 0 0
63 mouseMove 81 66 0 0
140 mouseMove 77 66 0 0
64 mouseMove 75 66 0 0
61 mouseMove 69 66 0 0
76 mouseMove 59 66 0 0
65 mouseMove 57 66 0 0
58 mouseMove 56 66 0 0
84 mouseMove 54 66 0 0
59 mouseMove 53 66 0 0
528 mouseMove 54 66 0 0
210 mouseMove 55 66 0 0
259 mouseDown 55 66 4 0
126 mouseMove 55 66 4 0
187 mouseMove 57 67 4 0
82 mouseMove 58 68 4 0
80 mouseMove 59 68 4 0
94 mouseMove 60 68 4 0
89 mouseMove 61 68 4 0
103 mouseMove 62 68 4 0
81 mouseMove 63 68 4 0
369 mouseMove 63 67 4 0
81 mouseMove 63 66 4 0
93 mouseMove 62 65 4 0
103 mouseMove 60 64 4 0
195 mouseMove 59 64 4 0
82 mouseMove 58 64 4 0
189 mouseUp 63 64 0 0
86 mouseMove 78 64 0 0
77 mouseMove 94 64 0 0
61 mouseMove 101 64 0 0
64 mouseMove 106 64 0 0
131 mouseMove 111 64 0 0
66 mouseMove 127 66 0 0
59 mouseMove 129 66 0 0
73 mouseMove 130 66 0 0
60 mouseMove 132 66 0 0
210 mouseMove 132 64 0 0
65 mouseMove 131 63 0 0
201 mouseDown 131 63 4 0
126 mouseMove 128 63 4 0
83 mouseMove 125 63 4 0
81 mouseMove 124 63 4 0
95 mouseMove 123 63 4 0
184 mouseMove 122 64 4 0
93 mouseMove 122 67 4 0
92 mouseMove 122 68 4 0
84 mouseMove 123 69 4 0
86 mouseMove 126 70 4 0
100 mouseMove 127 70 4 0
82 mouseMove 128 70 4 0
105 mouseMove 129 70 4 0
81 mouseMove 130 70 4 0
83 mouseMove 131 69 4 0
106 mouseMove 131 67 4 0
81 mouseMove 132 66 4 0
83 mouseMove 132 64 4 0
112 mouseMove 131 63 4 0
83 mouseMove 130 62 4 0
104 mouseMove 128 62 4 0
85 mouseMove 127 62 4 0
81 mouseMove 126 62 4 0
94 mouseMove 124 64 4 0
85 mouseMove 124 65 4 0
173 mouseMove 124 66 4 0
87 mouseMove 124 67 4 0
103 mouseMove 125 67 4 0
87 mouseMove 126 67 4 0
178 mouseUp 126 67 0 0
80 mouseMove 126 67 0 0
527 mouseMove 126 68 0 0
60 mouseMove 142 71 0 0
65 mouseMove 160 76 0 0
79 mouseMove 166 86 0 0
69 mouseMove 178 101 0 0
66 mouseMove 186 112 0 0
88 mouseMove 192 121 0 0
61 mouseMove 193 127 0 0
65 mouseMove 198 144 0 0
65 mouseMove 200 149 0 0
71 mouseMove 200 153 0 0
63 mouseMove 200 154 0 0
60 mouseMove 200 159 0 0
75 mouseMove 200 169 0 0
62 mouseMove 200 177 0 0
140 mouseMove 200 196 0 0
80 mouseMove 200 201 0 0
60 mouseMove 200 204 0 0
70 mouseMove 200 210 0 0
76 mouseMove 196 218 0 0
61 mouseMove 189 221 0 0
66 mouseMove 162 228 0 0
72 mouseMove 134 235 0 0
67 mouseMove 126 236 0 0
63 mouseMove 117 236 0 0
81 mouseMove 111 235 0 0
66 mouseMove 105 234 0 0
60 mouseMove 101 233 0 0
75 mouseMove 97 233 0 0
60 mouseMove 92 233 0 0
205 mouseMove 91 234 0 0
70 mouseMove 91 236 0 0
59 mouseMove 91 237 0 0
202 mouseDown 91 237 4 0
328 mouseMove 91 237 4 0
206 mouseUp 91 237 0 0
191 mouseMove 91 237 0 0
71 mouseMove 91 239 0 0
60 mouseMove 90 242 0 0
64 mouseMove 90 245 0 0
80 mouseMove 90 247 0 0
194 mouseMove 91 247 0 0
67 mouseMove 111 242 0 0
61 mouseMove 160 240 0 0
66 mouseMove 170 240 0 0
78 mouseMove 181 239 0 0
61 mouseMove 186 239 0 0
66 mouseMove 191 237 0 0
78 mouseMove 216 233 0 0
67 mouseMove 247 228 0 0
164 mouseMove 248 226 0 0
119 mouseMove 248 225 0 0
599 mouseDown 248 225 4 0
69 mouseMove 248 225 4 0
139 mouseUp 248 225 0 0
91 mouseMove 248 225 0 0
67 mouseMove 244 200 0 0
68 mouseMove 232 163 0 0
60 mouseMove 230 153 0 0
81 mouseMove 225 141 0 0
65 mouseMove 222 137 0 0
60 mouseMove 221 136 0 0
121 mouseDown 221 136 4 0
70 mouseMove 221 136 4 0
65 mouseUp 221 136 0 0
101 mouseMove 221 136 0 0
190 mouseMove 219 136 0 0
65 mouseMove 135 122 0 0
67 mouseMove 91 106 0 0
61 mouseMove 89 104 0 0
81 mouseMove 82 101 0 0
65 mouseMove 80 97 0 0
58 mouseMove 79 95 0 0
77 mouseMove 78 93 0 0
60 mouseMove 76 90 0 0
65 mouseMove 75 87 0 0
69 mouseMove 74 85 0 0
64 mouseMove 73 83 0 0
63 mouseMove 73 82 0 0
60 mouseMove 71 78 0 0
77 mouseMove 68 74 0 0
68 mouseMove 67 73 0 0
64 mouseMove 66 72 0 0
68 mouseMove 65 70 0 0
720 mouseDown 66 70 4 0
114 mouseMove 66 70 4 0
117 mouseMove 68 72 4 0
103 mouseMove 70 74 4 0
115 mouseMove 72 76 4 0
99 mouseMove 73 78 4 0
101 mouseMove 74 81 4 0
93 mouseMove 75 82 4 0
119 mouseMove 77 85 4 0
92 mouseMove 80 89 4 0
93 mouseMove 82 91 4 0
100 mouseMove 84 93 4 0
98 mouseMove 91 98 4 0
115 mouseMove 98 103 4 0
93 mouseMove 103 106 4 0
113 mouseMove 106 108 4 0
98 mouseMove 108 108 4 0
100 mouseMove 109 108 4 0
300 mouseMove 113 110 4 0
101 mouseMove 116 111 4 0
100 mouseMove 119 113 4 0
102 mouseMove 120 113 4 0
708 mouseUp 120 113 0 0
114 mouseMove 120 113 0 0
452 mouseMove 123 113 0 0
60 mouseMove 128 113 0 0
152 mouseMove 131 113 0 0
61 mouseMove 138 113 0 0
66 mouseMove 145 113 0 0
70 mouseMove 149 114 0 0
66 mouseMove 154 114 0 0
61 mouseMove 159 115 0 0
64 mouseMove 165 115 0 0
83 mouseMove 169 116 0 0
69 mouseMove 173 116 0 0
72 mouseMove 184 119 0 0
102 mouseMove 211 126 0 0
61 mouseMove 216 128 0 0
79 mouseMove 222 133 0 0
66 mouseMove 229 146 0 0
60 mouseMove 236 166 0 0
78 mouseMove 240 175 0 0
59 mouseMove 241 176 0 0
64 mouseMove 241 178 0 0
194 mouseMove 241 181 0 0
142 mouseMove 241 182 0 0
66 mouseMove 241 184 0 0
323 mouseMove 242 184 0 0
739 mouseDown 242 184 4 0
65 mouseMove 242 184 4 0
655 mouseUp 242 184 0 0
77 mouseMove 242 184 0 0
470 mouseMove 242 186 0 0
81 mouseMove 237 212 0 0
60 mouseMove 234 222 0 0
66 mouseMove 232 226 0 0
64 mouseMove 227 232 0 0
69 mouseMove 219 238 0 0
167 mouseMove 216 244 0 0
67 mouseMove 216 246 0 0
525 mouseMove 215 246 0 0
205 mouseDown 215 246 4 0
328 mouseMove 215 246 4 0
193 mouseUp 215 246 0 0
215 mouseMove 215 246 0 0
134 mouseMove 215 243 0 0
67 mouseMove 220 233 0 0
72 mouseMove 230 224 0 0
141 mouseMove 224 161 0 0
76 mouseMove 154 123 0 0
64 mouseMove 144 121 0 0
60 mouseMove 140 122 0 0
66 mouseMove 124 123 0 0
72 mouseMove 110 122 0 0
68 mouseMove 85 114 0 0
68 mouseMove 74 111 0 0
76 mouseMove 66 109 0 0
64 mouseMove 63 107 0 0
62 mouseMove 57 104 0 0
65 mouseMove 53 102 0 0
80 mouseMove 52 101 0 0
66 mouseMove 50 99 0 0
66 mouseMove 48 98 0 0
397 mouseMove 47 97 0 0
213 mouseMove 47 96 0 0
844 mouseMove 45 96 0 0
66 mouseMove 44 96 0 0
71 mouseMove 42 95 0 0
77 mouseMove 39 94 0 0
123 mouseDown 39 94 4 0
142 mouseMove 40 99 4 0
115 mouseMove 43 103 4 0
96 mouseMove 45 108 4 0
91 mouseMove 47 111 4 0
111 mouseMove 50 116 4 0
93 mouseMove 52 119 4 0
110 mouseMove 57 122 4 0
98 mouseMove 58 125 4 0
103 mouseMove 66 130 4 0
102 mouseMove 70 131 4 0
201 mouseMove 73 132 4 0
407 mouseUp 73 132 0 0
87 mouseMove 73 132 0 0
153 mouseDown 73 132 4 0
131 mouseMove 83 133 4 0
108 mouseMove 94 133 4 0
96 mouseMove 100 133 4 0
103 mouseMove 104 133 4 0
100 mouseMove 107 133 4 0
100 mouseMove 112 132 4 0
206 mouseMove 113 132 4 0
511 mouseUp 113 132 0 0
91 mouseMove 113 132 0 0
272 mouseDown 113 132 4 0
126 mouseMove 122 127 4 0
125 mouseMove 130 120 4 0
99 mouseMove 133 118 4 0
101 mouseMove 139 113 4 0
101 mouseMove 142 109 4 0
106 mouseMove 143 106 4 0
95 mouseMove 146 100 4 0
100 mouseMove 147 94 4 0
200 mouseMove 147 93 4 0
610 mouseUp 147 93 0 0
112 mouseMove 147 93 0 0
2788 mouseMove 168 93 0 0
69 mouseMove 191 95 0 0
226 mouseMove 191 96 0 0
72 mouseMove 195 104 0 0
61 mouseMove 195 110 0 0
67 mouseMove 195 124 0 0
77 mouseMove 193 153 0 0
61 mouseMove 193 205 0 0
162 mouseMove 193 239 0 0
67 mouseMove 194 251 0 0
69 mouseMove 200 275 0 0
78 mouseMove 206 315 0 0
144 mouseMove 202 352 0 0
71 mouseMove 202 370 0 0
67 mouseMove 202 383 0 0
61 mouseMove 202 391 0 0
67 mouseMove 202 399 0 0
73 mouseMove 202 404 0 0
60 mouseMove 205 409 0 0
63 mouseMove 205 410 0 0
69 mouseMove 207 411 0 0
669 mouseMove 208 411 0 0
1192 mouseDown 208 411 4 0
72 mouseMove 208 411 4 0
79 mouseUp 208 411 0 0
158 mouseMove 208 411 0 0
474 mouseMove 208 410 0 0
79 mouseMove 208 408 0 0
66 mouseMove 211 396 0 0
69 mouseMove 223 381 0 0
65 mouseMove 232 368 0 0
66 mouseMove 247 340 0 0
60 mouseMove 258 306 0 0
81 mouseMove 264 290 0 0
60 mouseMove 268 282 0 0
66 mouseMove 271 271 0 0
85 mouseMove 273 250 0 0
60 mouseMove 274 236 0 0
66 mouseMove 271 217 0 0
61 mouseMove 271 205 0 0
83 mouseMove 269 189 0 0
68 mouseMove 265 178 0 0
60 mouseMove 265 167 0 0
77 mouseMove 265 154 0 0
61 mouseMove 265 143 0 0
65 mouseMove 265 139 0 0
68 mouseMove 265 138 0 0
65 mouseMove 265 135 0 0
67 mouseMove 265 127 0 0
58 mouseMove 265 125 0 0
79 mouseMove 265 124 0 0
530 mouseDown 265 124 2 0
106 mouseMove 265 124 2 0
75 mouseUp 265 124 0 0
74 mouseMove 265 124 0 0
493 mouseMove 267 125 0 0
98 mouseMove 268 128 0 0
77 mouseMove 268 131 0 0
76 mouseMove 268 132 0 0
58 mouseMove 268 133 0 0
77 mouseMove 269 134 0 0
63 mouseMove 270 135 0 0
202 mouseDown 270 135 4 0
109 mouseUp 270 135 0 0
85 mouseMove 270 135 0 0
2924 mouseMove 270 136 0 0
2716 mouseMove 278 133 0 0
84 mouseMove 281 130 0 0
60 mouseMove 283 128 0 0
66 mouseMove 291 124 0 0
61 mouseMove 299 119 0 0
70 mouseMove 311 110 0 0
70 mouseMove 315 105 0 0
61 mouseMove 324 101 0 0
80 mouseMove 333 97 0 0
60 mouseMove 337 94 0 0
67 mouseMove 343 91 0 0
113 mouseMove 354 88 0 0
59 mouseMove 357 86 0 0
64 mouseMove 359 85 0 0
1280 keystroke 359 85 0 112
194 mouseMove 359 85 0 0
64 keystroke 359 85 0 111
100 mouseMove 359 85 0 0
149 keystroke 359 85 0 111
110 mouseMove 359 85 0 0
183 keystroke 359 85 0 104
125 mouseMove 359 85 0 0
263 keystroke 359 85 0 32
109 mouseMove 359 85 0 0
474 keystroke 359 85 0 116
98 mouseMove 359 85 0 0
268 keystroke 359 85 0 117
117 mouseMove 359 85 0 0
122 keystroke 359 85 0 114
115 mouseMove 359 85 0 0
64 keystroke 359 85 0 110
127 mouseMove 359 85 0 0
403 mouseMove 359 85 8 0
1 keystroke 359 85 8 58
98 mouseMove 359 85 8 0
204 mouseMove 359 85 0 0
1 keystroke 359 85 0 32
116 mouseMove 359 85 0 0
185 keystroke 359 85 0 108
113 mouseMove 359 85 0 0
59 keystroke 359 85 0 101
118 mouseMove 359 85 0 0
63 keystroke 359 85 0 102
99 mouseMove 359 85 0 0
78 keystroke 359 85 0 116
94 mouseMove 359 85 0 0
865 keystroke 359 85 0 32
117 mouseMove 359 85 0 0
465 keystroke 359 85 0 116
99 mouseMove 359 85 0 0
262 keystroke 359 85 0 117
131 mouseMove 359 85 0 0
60 keystroke 359 85 0 114
103 mouseMove 359 85 0 0
193 keystroke 359 85 0 110
124 mouseMove 359 85 0 0
65 keystroke 359 85 0 115
120 mouseMove 359 85 0 0
1172 mouseMove 359 85 8 0
1 keystroke 359 85 8 58
97 mouseMove 359 85 8 0
336 mouseMove 359 85 0 0
1 keystroke 359 85 0 32
108 mouseMove 359 85 0 0
346 keystroke 359 85 0 49
98 mouseMove 359 85 0 0
252 keystroke 359 85 0 48
126 mouseMove 359 85 0 0
63 keystroke 359 85 0 48
107 mouseMove 359 85 0 0
726 keystroke 359 85 0 32
100 mouseMove 359 85 0 0
411 keystroke 359 85 0 100
107 mouseMove 359 85 0 0
64 keystroke 359 85 0 117
105 mouseMove 359 85 0 0
142 keystroke 359 85 0 114
119 mouseMove 359 85 0 0
0 keystroke 359 85 0 97
100 mouseMove 359 85 0 0
63 keystroke 359 85 0 116
119 mouseMove 359 85 0 0
212 keystroke 359 85 0 105
101 mouseMove 359 85 0 0
60 keystroke 359 85 0 111
97 mouseMove 359 85 0 0
252 keystroke 359 85 0 110
119 mouseMove 359 85 0 0
1399 mouseMove 359 85 8 0
1 keystroke 359 85 8 58
100 mouseMove 359 85 8 0
203 mouseMove 359 85 0 0
1 keystroke 359 85 0 32
114 mouseMove 359 85 0 0
263 keystroke 359 85 0 53
100 mouseMove 359 85 0 0
287 keystroke 359 85 0 48
97 mouseMove 359 85 0 0
143 keystroke 359 85 0 48
98 mouseMove 359 85 0 0
266 keystroke 359 85 0 32
111 mouseMove 359 85 0 0
121 keystroke 359 85 0 115
119 mouseMove 359 85 0 0
1 keystroke 359 85 0 116
99 mouseMove 359 85 0 0
143 keystroke 359 85 0 121
115 mouseMove 359 85 0 0
255 keystroke 359 85 0 108
99 mouseMove 359 85 0 0
1 keystroke 359 85 0 101
119 mouseMove 359 85 0 0
866 mouseMove 359 85 8 0
1 keystroke 359 85 8 58
102 mouseMove 359 85 8 0
128 mouseMove 359 85 0 0
1 keystroke 359 85 0 32
107 mouseMove 359 85 0 0
63 keystroke 359 85 0 97
111 mouseMove 359 85 0 0
60 keystroke 359 85 0 98
100 mouseMove 359 85 0 0
913 keystroke 359 85 0 114
106 mouseMove 359 85 0 0
590 keystroke 359 85 0 117
118 mouseMove 359 85 0 0
199 keystroke 359 85 0 112
120 mouseMove 359 85 0 0
262 keystroke 359 85 0 116
101 mouseMove 359 85 0 0
263 keystroke 359 85 0 108
128 mouseMove 359 85 0 0
323 keystroke 359 85 0 121
126 mouseMove 359 85 0 0
1912 mouseMove 359 85 64 0
1 keystroke 359 85 64 100
219 mouseMove 359 85 64 0
3744 mouseMove 307 85 64 0
84 mouseMove 202 85 64 0
60 mouseMove 190 85 64 0
54 mouseMove 178 85 64 0
61 mouseMove 135 83 64 0
65 mouseMove 126 83 64 0
59 mouseMove 120 83 64 0
62 mouseMove 113 82 64 0
72 mouseMove 112 82 64 0
62 mouseMove 107 82 64 0
53 mouseMove 106 82 64 0
58 mouseMove 104 82 64 0
87 mouseMove 102 82 64 0
54 mouseMove 101 82 64 0
184 mouseMove 99 82 64 0
60 mouseMove 97 82 64 0
128 mouseMove 96 82 64 0
65 mouseMove 94 82 64 0
370 mouseMove 94 81 64 0
83 mouseDown 94 81 1 0
221 mouseUp 94 81 0 0
105 mouseMove 94 81 0 0
544 mouseMove 86 91 0 0
325 mouseMove 94 91 0 0
111 mouseMove 97 90 0 0
227 mouseDown 97 90 4 0
104 mouseUp 97 90 0 0
294 mouseMove 97 90 0 0
595 mouseMove 100 90 0 0
112 mouseMove 117 97 0 0
116 mouseMove 133 96 0 0
107 mouseMove 142 96 0 0
110 mouseMove 158 97 0 0
105 mouseMove 168 101 0 0
118 mouseMove 180 108 0 0
111 mouseMove 188 117 0 0
116 mouseMove 191 128 0 0
102 mouseMove 194 138 0 0
114 mouseMove 194 144 0 0
106 mouseMove 194 156 0 0
121 mouseMove 194 158 0 0
228 mouseDown 194 158 4 0
100 mouseUp 194 158 0 0
105 mouseMove 194 158 0 0
853 mouseMove 215 185 0 0
139 mouseMove 220 203 0 0
62 mouseMove 220 205 0 0
119 mouseMove 219 205 0 0
60 mouseMove 211 209 0 0
67 mouseMove 209 210 0 0
160 mouseMove 210 212 0 0
67 mouseMove 211 213 0 0
296 mouseDown 211 213 4 0
303 mouseUp 211 213 0 0
223 mouseMove 211 221 0 0
70 mouseMove 211 228 0 0
62 mouseMove 211 235 0 0
63 mouseMove 211 236 0 0
83 mouseMove 211 239 0 0
123 mouseMove 211 241 0 0
58 mouseMove 211 249 0 0
62 mouseMove 211 253 0 0
175 mouseDown 211 253 4 0
335 mouseUp 211 253 0 0
209 mouseMove 211 253 0 0
226 mouseMove 211 252 0 0
60 mouseMove 211 242 0 0
60 mouseMove 211 237 0 0
120 mouseMove 211 236 0 0
180 mouseMove 205 224 0 0
57 mouseMove 187 192 0 0
57 mouseMove 187 190 0 0
133 mouseMove 184 182 0 0
63 mouseMove 180 171 0 0
63 mouseMove 166 150 0 0
149 mouseMove 151 136 0 0
58 mouseMove 134 117 0 0
73 mouseMove 110 103 0 0
56 mouseMove 106 101 0 0
60 mouseMove 84 88 0 0
63 mouseMove 79 87 0 0
79 mouseMove 77 86 0 0
65 mouseMove 74 85 0 0
66 mouseMove 73 84 0 0
78 mouseMove 72 84 0 0
129 mouseMove 72 83 0 0
512 mouseDown 72 83 4 0
113 mouseMove 72 83 4 0
7709 mouseUp 72 83 0 0
78 mouseMove 72 83 0 0
425 mouseMove 76 83 0 0
54 mouseMove 78 83 0 0
128 mouseMove 80 83 0 0
57 mouseMove 94 87 0 0
72 mouseMove 110 93 0 0
64 mouseMove 122 101 0 0
57 mouseMove 133 109 0 0
63 mouseMove 138 113 0 0
76 mouseMove 144 117 0 0
58 mouseMove 149 121 0 0
62 mouseMove 154 125 0 0
67 mouseMove 160 131 0 0
65 mouseMove 164 137 0 0
69 mouseMove 166 142 0 0
62 mouseMove 171 151 0 0
78 mouseMove 175 162 0 0
75 mouseMove 176 167 0 0
64 mouseMove 181 175 0 0
66 mouseMove 184 179 0 0
141 mouseMove 192 190 0 0
78 mouseMove 197 199 0 0
60 mouseMove 198 204 0 0
67 mouseMove 201 212 0 0
87 mouseMove 201 218 0 0
55 mouseMove 201 222 0 0
58 mouseMove 200 227 0 0
62 mouseMove 198 233 0 0
74 mouseMove 197 235 0 0
176 mouseMove 191 235 0 0
59 mouseMove 188 234 0 0
55 mouseMove 187 231 0 0
56 mouseMove 186 229 0 0
75 mouseMove 184 226 0 0
54 mouseMove 179 225 0 0
60 mouseMove 174 225 0 0
69 mouseMove 168 226 0 0
63 mouseMove 160 227 0 0
62 mouseMove 153 227 0 0
63 mouseMove 139 225 0 0
71 mouseMove 131 221 0 0
66 mouseMove 127 219 0 0
67 mouseMove 120 218 0 0
71 mouseMove 110 218 0 0
62 mouseMove 107 219 0 0
198 mouseMove 111 219 0 0
58 mouseMove 112 219 0 0
135 mouseDown 112 219 4 0
317 mouseMove 112 219 4 0
413 mouseUp 112 219 0 0
205 mouseMove 112 219 0 0
353 mouseMove 116 222 0 0
69 mouseMove 116 224 0 0
60 mouseMove 117 226 0 0
60 mouseMove 117 229 0 0
71 mouseMove 118 229 0 0
56 mouseMove 118 230 0 0
60 mouseMove 118 232 0 0
55 mouseMove 118 233 0 0
60 mouseMove 118 235 0 0
60 mouseMove 119 235 0 0
56 mouseDown 119 235 4 0
340 mouseMove 119 235 4 0
406 mouseUp 119 235 0 0
194 mouseMove 119 235 0 0
197 mouseMove 119 219 0 0
57 mouseMove 116 200 0 0
75 mouseMove 115 187 0 0
62 mouseMove 114 178 0 0
57 mouseMove 112 169 0 0
151 mouseMove 111 151 0 0
61 mouseMove 110 144 0 0
73 mouseMove 110 137 0 0
54 mouseMove 109 133 0 0
60 mouseMove 108 128 0 0
53 mouseMove 107 123 0 0
71 mouseMove 105 117 0 0
59 mouseMove 103 112 0 0
53 mouseMove 103 111 0 0
61 mouseMove 102 108 0 0
72 mouseMove 101 104 0 0
58 mouseMove 100 99 0 0
61 mouseMove 100 96 0 0
64 mouseMove 99 93 0 0
63 mouseMove 99 92 0 0
63 mouseMove 99 91 0 0
197 mouseMove 99 90 0 0
523 mouseMove 98 93 0 0
75 mouseMove 98 95 0 0
60 mouseMove 98 96 0 0
62 mouseMove 98 99 0 0
54 mouseMove 98 100 0 0
80 mouseMove 98 101 0 0
54 mouseMove 98 102 0 0
189 mouseDown 98 102 4 0
103 mouseMove 98 102 4 0
5163 mouseUp 98 102 0 0
83 mouseMove 98 102 0 0
237 mouseMove 105 103 0 0
59 mouseMove 113 103 0 0
131 mouseMove 119 103 0 0
60 mouseMove 127 104 0 0
66 mouseMove 138 106 0 0
61 mouseMove 143 106 0 0
57 mouseMove 149 107 0 0
63 mouseMove 154 107 0 0
72 mouseMove 160 107 0 0
56 mouseMove 167 107 0 0
70 mouseMove 179 107 0 0
82 mouseMove 180 107 0 0
76 mouseMove 186 107 0 0
55 mouseMove 190 107 0 0
60 mouseMove 192 108 0 0
67 mouseMove 210 122 0 0
63 mouseMove 214 132 0 0
66 mouseMove 216 141 0 0
59 mouseMove 217 142 0 0
85 mouseMove 220 154 0 0
67 mouseMove 224 169 0 0
55 mouseMove 224 173 0 0
73 mouseMove 226 187 0 0
61 mouseMove 229 200 0 0
63 mouseMove 239 228 0 0
87 mouseMove 242 251 0 0
61 mouseMove 242 284 0 0
64 mouseMove 242 304 0 0
62 mouseMove 242 341 0 0
67 mouseMove 242 353 0 0
61 mouseMove 239 368 0 0
57 mouseMove 237 376 0 0
76 mouseMove 234 382 0 0
60 mouseMove 231 388 0 0
54 mouseMove 223 400 0 0
61 mouseMove 219 405 0 0
63 mouseMove 215 410 0 0
53 mouseMove 213 413 0 0
548 mouseMove 212 413 0 0
197 mouseDown 212 413 4 0
84 mouseMove 212 413 4 0
63 mouseUp 212 413 0 0
149 mouseMove 212 413 0 0
267 mouseMove 304 305 0 0
57 mouseMove 460 181 0 0
109 mouseMove 461 138 0 0
62 mouseMove 452 133 0 0
61 mouseMove 448 132 0 0
55 mouseMove 442 131 0 0
72 mouseMove 440 132 0 0
348 mouseDown 440 132 4 0
86 mouseUp 440 132 0 0
66 mouseMove 440 132 0 0
945 keystroke 440 132 0 13
129 mouseMove 440 132 0 0
307 keystroke 440 132 0 112
131 mouseMove 440 132 0 0
120 keystroke 440 132 0 111
116 mouseMove 440 132 0 0
1 keystroke 440 132 0 111
109 mouseMove 440 132 0 0
410 keystroke 440 132 0 104
119 mouseMove 440 132 0 0
137 keystroke 440 132 0 32
124 mouseMove 440 132 0 0
236 keystroke 440 132 0 115
106 mouseMove 440 132 0 0
1 keystroke 440 132 0 116
112 mouseMove 440 132 0 0
177 keystroke 440 132 0 111
114 mouseMove 440 132 0 0
65 keystroke 440 132 0 112
117 mouseMove 440 132 0 0
1081 mouseMove 440 132 64 0
0 keystroke 440 132 64 100
223 mouseMove 440 132 64 0
1271 mouseMove 408 132 64 0
55 mouseMove 372 132 64 0
82 mouseMove 367 131 64 0
62 mouseMove 347 131 64 0
59 mouseMove 306 129 64 0
73 mouseMove 273 129 64 0
72 mouseMove 245 127 64 0
55 mouseMove 234 127 64 0
61 mouseMove 220 127 64 0
66 mouseMove 209 127 64 0
63 mouseMove 197 127 64 0
55 mouseMove 189 127 64 0
61 mouseMove 173 131 64 0
73 mouseMove 154 139 64 0
55 mouseMove 134 154 64 0
62 mouseMove 122 161 64 0
72 mouseMove 114 167 64 0
60 mouseMove 110 171 64 0
55 mouseMove 105 174 64 0
69 mouseMove 99 179 64 0
65 mouseMove 94 187 64 0
61 mouseMove 89 195 64 0
64 mouseMove 86 203 64 0
74 mouseMove 85 208 64 0
61 mouseMove 84 211 64 0
55 mouseMove 84 216 64 0
62 mouseMove 84 219 64 0
74 mouseMove 84 222 64 0
60 mouseMove 84 226 64 0
53 mouseMove 84 228 64 0
71 mouseMove 84 229 64 0
53 mouseDown 84 229 4 0
61 mouseMove 84 229 4 0
132 mouseUp 84 229 0 0
'! !
WonderlandMorph subclass: #WonderlandControls
	instanceVariableNames: 'myScheduler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandControls commentStamp: '<historical>' prior: 0!
This class implements the control panel for Wonderlands, including the Undo button and Quit button.
!


!WonderlandControls methodsFor: 'initialization' stamp: 'jsp 4/12/1999 17:02'!
initializeWith: aWonderland
	"Initialize the instance"

	| exitButton resetButton undoButton |

	myWonderland _ aWonderland.
	myScheduler _ myWonderland getScheduler.

	"Use a white background"
	color _ (Color r: 0.784 g: 0.784 b: 0.784).

	"Now add our buttons"
	undoButton _ SimpleButtonMorph new.
	undoButton initialize.
	undoButton label: 'Undo'.
	undoButton color: (Color green).
	undoButton target: myWonderland.
	undoButton actionSelector: #undo.
	self addMorph: undoButton.

	resetButton _ SimpleButtonMorph new.
	resetButton initialize.
	resetButton label: 'Reset'.
	resetButton color: (Color yellow).
	resetButton target: myWonderland.
	resetButton actionSelector: #reset.
	self addMorph: resetButton.

	exitButton _ SimpleButtonMorph new.
	exitButton initialize.
	exitButton label: 'Quit'.
	exitButton color: (Color red).
	exitButton target: self.
	exitButton actionSelector: #quitWonderland.
	self addMorph: exitButton.

	undoButton bounds: (5@10 corner: 45@40).
	resetButton bounds: (50@10 corner: 90@40).
	exitButton bounds: (95@10 corner: 135@40).

	"Size and position the window"
	self extent: 140@50.
! !


!WonderlandControls methodsFor: 'actions' stamp: 'jsp 4/12/1999 16:46'!
quitWonderland
	"Destroy the wonderland"

	myWonderland release.
! !


!WonderlandControls methodsFor: 'stepping' stamp: 'jsp 3/23/1999 15:04'!
step

	myScheduler tick.
! !

!WonderlandControls methodsFor: 'stepping' stamp: 'jsp 3/23/1999 15:03'!
stepTime
	
	^ 1.
! !

!WonderlandControls methodsFor: 'stepping' stamp: 'jsp 3/23/1999 15:03'!
wantsSteps

	^ true.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandControls class
	instanceVariableNames: ''!

!WonderlandControls class methodsFor: 'instance creation' stamp: 'jsp 3/23/1999 15:30'!
newFor: aWonderland
	"Create a new instance"

	^ self new initializeWith: aWonderland.
! !
WonderlandLightSource subclass: #WonderlandDirectionalLight
	instanceVariableNames: 'direction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Lights'!

!WonderlandDirectionalLight methodsFor: 'shading' stamp: 'jsp 4/29/1999 13:45'!
computeAttenuationFor: distance
	"Since a directional light is positioned at virtual infinity, it cannot have any attenuation"

	^1.0! !

!WonderlandDirectionalLight methodsFor: 'shading' stamp: 'jsp 4/29/1999 13:48'!
computeDirectionTo: aB3DPrimitiveVertex
	"A directional light has an explicit direction regardless of the vertex position"

	^ (self getRotationVector).! !


!WonderlandDirectionalLight methodsFor: 'converting' stamp: 'jsp 4/29/1999 13:48'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight flags |
	primLight _ B3DPrimitiveLight new.
	primLight direction: (self getRotationVector).
	flags _ FlagDirectional.
	lightColor ambientPart isZero ifFalse:[
		primLight ambientPart: lightColor ambientPart.
		flags _ flags bitOr: FlagAmbientPart].
	lightColor diffusePart isZero ifFalse:[
		primLight diffusePart: lightColor diffusePart.
		flags _ flags bitOr: FlagDiffusePart].
	lightColor specularPart isZero ifFalse:[
		primLight specularPart: lightColor specularPart.
		flags _ flags bitOr: FlagSpecularPart].
	primLight flags: flags.
	^primLight! !

!WonderlandDirectionalLight methodsFor: 'converting' stamp: 'jsp 4/29/1999 13:49'!
transformedBy: aTransformer
	^(super transformedBy: aTransformer)
				setRotationVector: (aTransformer transformDirection: direction)! !


!WonderlandDirectionalLight methodsFor: 'private' stamp: 'ar 8/19/1999 16:26'!
setDirection: dir
	direction _ dir.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandDirectionalLight class
	instanceVariableNames: ''!

!WonderlandDirectionalLight class methodsFor: 'change logging' stamp: 'jsp 7/25/1999 23:26'!
acceptsLoggingOfCompilation

	^ self == WonderlandDirectionalLight.
! !

!WonderlandDirectionalLight class methodsFor: 'change logging' stamp: 'jsp 7/25/1999 23:26'!
wantsChangeSetLogging

	^ self == WonderlandDirectionalLight.

! !
WonderlandMorph subclass: #WonderlandEditor
	instanceVariableNames: 'myTabs myControls myActorBrowser '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandEditor commentStamp: '<historical>' prior: 0!
This class implements the tabbed palette that includes the script editor and the actor browser.
!


!WonderlandEditor methodsFor: 'initialization' stamp: 'jsp 8/21/1999 16:52'!
initializeWith: aWonderland
	"Initialize the editor with the Wonderland."

	myWonderland _ aWonderland.

	myTabs _ (WonderlandEditorTabs newFor: aWonderland).
	self addMorph: myTabs.

	myActorBrowser _ (WonderlandActorBrowser newFor: myWonderland).
	myActorBrowser setActorViewer: (myTabs getActorViewer).
	self addMorph: (myActorBrowser getMorph).

	myControls _ WonderlandControls newFor: aWonderland.
	self addMorph: myControls.

	self position: 200@20.
	self extent: 650@375.
	self color: (Color r: 0.784 g: 0.784 b: 0.784).
	self openInWorld.
! !


!WonderlandEditor methodsFor: 'accessing' stamp: 'jsp 4/12/1999 16:23'!
resetNamespace
	"Reset the namespace used by the script editor"

	myTabs resetNamespace.
! !

!WonderlandEditor methodsFor: 'accessing' stamp: 'jsp 4/1/1999 17:37'!
updateActorBrowser
	"Tells the actor browser to update the list of actors"

	myActorBrowser updateActorList.
! !


!WonderlandEditor methodsFor: 'resizing' stamp: 'jsp 8/21/1999 17:25'!
extent: aPoint

	| newPoint aMorph |

	bounds extent = aPoint
		ifFalse: [
			self changed.

			newPoint _ aPoint.
			(aPoint x < 370) ifTrue: [ newPoint _ 370@(aPoint y) ].
			(aPoint y < 130) ifTrue: [ newPoint _ (newPoint x)@130 ].

			aMorph _ myActorBrowser getMorph.
			aMorph extent: 140@((newPoint y) - 52).
			aMorph position: (self position + (0@50)).

			myTabs extent: (newPoint x - 142)@(newPoint y - 4).
			myTabs position: (self position + (142@0)).

			bounds _ bounds topLeft extent: newPoint.
			self layoutChanged.
			self changed.
				].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandEditor class
	instanceVariableNames: ''!

!WonderlandEditor class methodsFor: 'instance creation' stamp: 'jsp 4/1/1999 15:04'!
newFor: aWonderland
	"Create a new editor for the Wonderland"

	^ self new initializeWith: aWonderland.
! !
TabbedPalette subclass: #WonderlandEditorTabs
	instanceVariableNames: 'myWonderland myScriptEditor myActorViewer myQuickReference '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandEditorTabs methodsFor: 'initialization' stamp: 'jsp 4/12/1999 16:15'!
addPanel: aMorph
	"Adds a new panel to the editor."

	(self tabsMorph) addTab: (ReferenceMorph forMorph: aMorph).
	(self pages) add: aMorph.! !

!WonderlandEditorTabs methodsFor: 'initialization' stamp: 'jsp 6/29/1999 01:41'!
initializeWith: aWonderland
	"Initialize the editor with the Wonderland."

	myWonderland _ aWonderland.

	myScriptEditor _ (WonderlandScriptEditor new).
	self addPanel: (myScriptEditor getMorph).
	(self tabsMorph submorphs at: 1) tabSelected.
	myScriptEditor setBindings: (myWonderland getNamespace).

	myActorViewer _ WonderlandActorViewer new.
	myActorViewer initializeWith: aWonderland.
	self addPanel: myActorViewer.

	myQuickReference _ (WonderlandQuickReference new).
	self addPanel: (myQuickReference getMorph).
! !


!WonderlandEditorTabs methodsFor: 'accessing' stamp: 'jsp 8/21/1999 17:19'!
extent: aPoint

	| newPoint |

	bounds extent = aPoint
		ifFalse: [
			self changed.

			newPoint _ (aPoint x)@(aPoint y - 20).

			myScriptEditor getMorph extent: newPoint.
			myActorViewer extent: newPoint.
			myQuickReference getMorph extent: newPoint.

			bounds _ bounds topLeft extent: aPoint.
			self layoutChanged.
			self changed
				].
! !

!WonderlandEditorTabs methodsFor: 'accessing' stamp: 'jsp 6/29/1999 01:53'!
getActorViewer

	^ myActorViewer.
! !

!WonderlandEditorTabs methodsFor: 'accessing' stamp: 'jsp 7/9/1999 15:03'!
resetNamespace
	"Reset the namespace used by the script editor"

	myScriptEditor setBindings: (myWonderland getNamespace).
	myActorViewer setSelectedActor: nil.

! !


!WonderlandEditorTabs methodsFor: 'user-interface' stamp: 'jsp 7/8/1999 22:26'!
selectTab: aTab
	"In addition to setting the tab, if it's the actor viewer let that tab know that it's open"

	super selectTab: aTab.

	(aTab morphToInstall isKindOf: WonderlandActorViewer)
		ifTrue: [ myActorViewer turnUpdatingOn ]
		ifFalse: [ myActorViewer ifNotNil: [ myActorViewer turnUpdatingOff ] ].

! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandEditorTabs class
	instanceVariableNames: ''!

!WonderlandEditorTabs class methodsFor: 'instance creation' stamp: 'jsp 4/12/1999 16:19'!
newFor: aWonderland
	"Create new tabs for the Wonderland editor"

	^ self new initializeWith: aWonderland.
! !
Object subclass: #WonderlandEvent
	instanceVariableNames: 'actor camera cursorPoint cursorDelta key morph vertex morphicEvent '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Misc'!

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:54'!
getActor

	^ actor.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:54'!
getCamera

	^ camera.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:54'!
getCameraMorph
	"Return the camera window the user clicked in"

	^ morph.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 14:37'!
getCursorDelta

	^ cursorDelta.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:55'!
getCursorPoint

	^ cursorPoint.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:56'!
getKey

	^ key.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'ar 6/2/1999 14:32'!
getMorphicEvent
	^morphicEvent! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'ar 6/2/1999 13:23'!
getVertex
	"Return the primitive vertex from picking operations"
	^vertex! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:54'!
setActor: anActor

	actor _ anActor.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:53'!
setCamera: aCamera

	camera _ aCamera.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:53'!
setCameraMorph: aMorph
	"Set the camera window the user clicked in"

	morph _ aMorph.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 14:37'!
setCursorDelta: aPoint

	cursorDelta _ aPoint.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:55'!
setCursorPoint: aPoint

	cursorPoint _ aPoint.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'jsp 4/19/1999 13:56'!
setKey: aKey

	key _ aKey.
! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'ar 6/2/1999 14:32'!
setMorphicEvent: aMorphicEvent
	morphicEvent _ aMorphicEvent! !

!WonderlandEvent methodsFor: 'accessing' stamp: 'ar 6/2/1999 13:23'!
setVertex: aB3DPrimitiveVertex
	"Set the primitive vertex from picking operations"
	vertex _ aB3DPrimitiveVertex.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandEvent class
	instanceVariableNames: ''!

!WonderlandEvent class methodsFor: 'class initialization' stamp: 'jsp 4/19/1999 17:47'!
initialize
	"Add some new constants to the WonderlandConstants shared pool"

	WonderlandConstants at: 'leftMouseDown' put: 'leftMouseDown'.
	WonderlandConstants at: 'leftMouseUp' put: 'leftMouseUp'.
	WonderlandConstants at: 'rightMouseDown' put: 'rightMouseDown'.
	WonderlandConstants at: 'rightMouseUp' put: 'rightMouseUp'.
	WonderlandConstants at: 'leftMouseClick' put: 'leftMouseUp'.
	WonderlandConstants at: 'rightMouseClick' put: 'rightMouseUp'.
	WonderlandConstants at: 'mouseMove' put: 'mouseMove'.
	WonderlandConstants at: 'keyPress' put: 'keyPress'.
	
 ! !
WonderlandActor subclass: #WonderlandLightSource
	instanceVariableNames: 'lightColor '
	classVariableNames: ''
	poolDictionaries: 'B3DEngineConstants '
	category: 'Balloon3D-Wonderland Lights'!

!WonderlandLightSource methodsFor: 'initialization' stamp: 'jsp 4/29/1999 11:43'!
initializeFor: aWonderland
	"Initialize the light"

	super initializeFor: aWonderland.

	"Set the light's mesh and texture"
	self setMesh: (WonderlandConstants at: 'lightMesh').
	self setTexturePointer: (WonderlandConstants at: 'lightTexture').

	lightColor _ B3DMaterialColor new.
	self setColorVector: (B3DColor4 r: 1.0 g: 1.0 b: 1.0 a: 1.0).
! !


!WonderlandLightSource methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:04'!
computeAttenuationFor: distance
	^self subclassResponsibility! !

!WonderlandLightSource methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:04'!
computeDirectionTo: aB3DPrimitiveVertex
	^self subclassResponsibility! !

!WonderlandLightSource methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:04'!
computeSpotFactor: light2Vertex
	"Compute the spot factor for a spot light"
	| lightDirection cosAngle minCos deltaCos maxCos |
	lightDirection _ self direction.
	cosAngle _ (lightDirection dot: light2Vertex) negated.
	(cosAngle < (minCos _ self hotSpotMinCosine)) ifTrue:[^0.0].
	maxCos _ self hotSpotMaxCosine.
"	maxCos = 1.0 ifFalse:["
		deltaCos _ self hotSpotDeltaCosine.
		deltaCos <= 0.00001 ifTrue:[
			"No delta -- a sharp boundary between on and off.
			Since off has already been determined above, we are on"
			^1.0].
		"Scale the angle to 0/1 range"
		cosAngle _ (cosAngle - minCos) / deltaCos.
		self flag: #TODO. "Don't scale by (maxCos - minCos)"
"	]."
	self flag: #TODO. "Use table lookup for spot exponent"
	^cosAngle raisedTo: self spotExponent! !

!WonderlandLightSource methodsFor: 'shading' stamp: 'ar 8/20/1999 00:57'!
shadeVertexBuffer: vb with: aMaterial into: colorArray
	"This is the generic shading function similar to the primitive.
	Subclasses may implement optimized versions but should evaluate
	exactly to the same value as in here if they are to be converted into
	B3DPrimitiveLights."
	| color vtxArray ambientColor vtx direction distance scale cosAngle diffusePart specularPart specDir specularFactor |
	self flag: #b3dPrimitive.
	vtxArray _ vb vertexArray.
	(self hasAmbientPart and:[vb trackAmbientColor not])
		ifTrue:[ambientColor _ aMaterial ambientPart * lightColor ambientPart].
	(self hasDiffusePart and:[vb trackDiffuseColor not])
		ifTrue:[diffusePart _ aMaterial diffusePart].
	(self hasSpecularPart and:[vb trackSpecularColor not])
		ifTrue:[specularPart _ aMaterial specularPart].
	1 to: vb vertexCount do:[:i|
		vtx _ vtxArray at: i.
		color _ colorArray at: i.

		"Compute the direction and distance of light source from vertex"
		direction _ self computeDirectionTo: vtx.
		distance _ direction length.
		(distance = 0.0 or:[distance = 1.0]) ifFalse:[direction /= distance negated].

		"Compute the attenuation for the given distance"
		self isAttenuated
			ifTrue:[scale _ self computeAttenuationFor: distance]
			ifFalse:[scale _ 1.0].

		"Compute spot light factor"
		self hasSpot
			ifTrue:[scale _ scale * (self computeSpotFactor: direction)].

		"Compute ambient part"
		self hasAmbientPart ifTrue:[
			vb trackAmbientColor 
				ifTrue:[ambientColor _ vtx b3dColor * lightColor ambientPart].
			color += (ambientColor * scale).
		].

		"Compute the diffuse part of the light"
		self hasDiffusePart ifTrue:[
			"Compute angle from light->vertex to vertex normal"
			cosAngle _ vtx normal dot: direction.
			"For one-sided lighting negate cosAngle if necessary"
			(vb twoSidedLighting not and:[cosAngle < 0.0]) 
				ifTrue:[cosAngle _ 0.0 - cosAngle].
			"For two-sided lighting check if cosAngle > 0.0 meaning that it is a front face"
			cosAngle > 0.0 ifTrue:[
				vb trackDiffuseColor ifTrue:[diffusePart _ vtx b3dColor].
				color += (diffusePart * lightColor diffusePart * (cosAngle * scale)).
			].
		].

		"Compute specular part of the light"
		(self hasSpecularPart and:[aMaterial shininess > 0.0]) ifTrue:[
			vb useLocalViewer 
				ifTrue:[specDir _ direction - vtx position safelyNormalized]
				ifFalse:[specDir _ direction - (0@0@1.0)].
			cosAngle _ vtx normal dot: specDir.
			cosAngle > 0.0 ifTrue:[
				"Normalize the angle"
				cosAngle _ cosAngle / specDir length.
				"cosAngle should be somewhere between 0 and 1.
				If not, then the vertex normal was not normalized"
				cosAngle > 1.0 ifTrue:[
					specularFactor _ cosAngle raisedTo: aMaterial shininess.
				] ifFalse:[
					self flag: #TODO. "Use table lookup later"
					specularFactor _ cosAngle raisedTo: aMaterial shininess.
				].
				color += (specularPart * lightColor specularPart * specularFactor).
			].
		].
		self flag: #TODO. "Check specular part"
		colorArray at: i put: color.
	].! !


!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:01'!
direction
	"If the light is directional, return the NORMALIZED direction of the light"
	^B3DVector3 zero! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:02'!
hotSpotDeltaCosine
	"Return the cosine value of the delta radius of a spot light (the fall off region)"
	^self hotSpotMaxCosine - self hotSpotMinCosine! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:02'!
hotSpotMaxCosine
	"Return the cosine value of the outer radius of a spot light (the unlit region)"
	^0.0! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:02'!
hotSpotMinCosine
	"Return the cosine value of the inner radius of a spot light (the fully lit region)"
	^0.0! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:02'!
lightColor
	^lightColor! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:03'!
lightColor: aMaterialColor
	lightColor _ aMaterialColor! !

!WonderlandLightSource methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:03'!
spotExponent
	"Return the exponent to be used for the spot fall off computation"
	^1! !


!WonderlandLightSource methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:00'!
hasAmbientPart
	"Return true if the receiver contains an ambient part in its color"
	^true! !

!WonderlandLightSource methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:00'!
hasDiffusePart
	"Return true if the receiver contains a diffuse part in its color"
	^true! !

!WonderlandLightSource methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:00'!
hasSpecularPart
	"Return true if the receiver contains a specular part in its color"
	^true! !

!WonderlandLightSource methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:01'!
hasSpot
	"Return true if the receiver has a hot spot."
	^false! !

!WonderlandLightSource methodsFor: 'testing' stamp: 'jsp 4/23/1999 14:01'!
isAttenuated
	"Return true if the receiver contains an attenuation.
	If so, #computeAttenuationFor: must return the attenuation for the given distance."
	^true! !


!WonderlandLightSource methodsFor: 'converting' stamp: 'jsp 4/23/1999 12:10'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight that can be handled by the shader primitive directly. Light sources that cannot be represented as primitive should return nil. This will result in the callback of #shadeVertexBuffer from the shader."
	^nil! !

!WonderlandLightSource methodsFor: 'converting' stamp: 'jsp 4/23/1999 12:10'!
transformedBy: aTransformer
	^self clone! !


!WonderlandLightSource methodsFor: 'private' stamp: 'jsp 4/23/1999 15:02'!
setColorVector: aColor
	"Instaneously sets the object's color/alpha vector and copies it down the object tree for all objects that are parts of this object"

	"Set our color"
	myColor _ aColor.

	lightColor ambientPart: myColor.
	lightColor diffusePart: myColor.
	lightColor specularPart: myColor.

	myMaterial ambientPart: myColor.
	myMaterial diffusePart: myColor.
	myMaterial specularPart: myColor.

	"Set the color of our parts"
	myChildren do: [:child | (child isPart) ifTrue: [child setColorVector: aColor] ].
! !


!WonderlandLightSource methodsFor: 'primitive behaviors' stamp: 'jsp 4/29/1999 15:01'!
destroy: aDuration
	"Implements the animated destroy of a camera.  Unlike destroy for WonderlandActors, this method merely removes the camera from the scene and removes it render window from the world."

	| lightList childList undoActions |

	undoActions _ OrderedCollection new.
	childList _ self getAllChildren.

	childList do: [:child | 
			(child isFirstClass) ifTrue: [
				"Make the non-part children point to this actor's parent"
				undoActions addLast: (UndoParentChange newFor: child from: (child getParent)).
				child reparentTo: (self getParent).
								  		].
				].

	self removeFromScene.

	lightList _ myWonderland getLights.
	lightList remove: self.

	undoActions addLast: (UndoAction new: [ (myWonderland getScene) addChild: self.
									lightList addLast: self ]).

	(myWonderland getUndoStack) push: (UndoChangeList new setChangeList: undoActions).

				


! !


!WonderlandLightSource methodsFor: 'get property' stamp: 'jsp 4/30/1999 11:32'!
getBrightness
	"Returns the brightness of the light as a value between 0 and 1."

	^ ((myColor red) max: (myColor green)) max: (myColor blue).
! !


!WonderlandLightSource methodsFor: 'set property' stamp: 'jsp 4/30/1999 11:33'!
setBrightness: aNumber
	"Sets the brightness of the light between 0 and 1 by varying the color of the light."

	"The parameter checks out, so run the animation"
	self setBrightness: aNumber duration: 1.0.
! !

!WonderlandLightSource methodsFor: 'set property' stamp: 'jsp 4/30/1999 11:37'!
setBrightness: aNumber duration: aDuration
	"Sets the brightness of the light between 0 and 1 by varying the color of the light."

	| r g b scale currentBrightness |

	"First verify our arguments"
	[ WonderlandVerifier Verify0To1Number: aNumber ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not the brightness to make the light because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the brightness of the light because ', msg.
			^ nil ].

	currentBrightness _ self getBrightness.

	(currentBrightness = 0)
		ifTrue: [
					r _ aNumber.
					g _ aNumber.
					b _ aNumber.
				]
		ifFalse: [
					scale _ (aNumber / (self getBrightness)).
					r _ (myColor red) * scale.
					g _ (myColor green) * scale.
					b _ (myColor blue) * scale.
				].

	"Our parameters check out, so run the animation"
	self setColor: { r. g. b } duration: aDuration.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandLightSource class
	instanceVariableNames: ''!

!WonderlandLightSource class methodsFor: 'change logging' stamp: 'jsp 4/23/1999 11:50'!
acceptsLoggingOfCompilation

	^ true.! !

!WonderlandLightSource class methodsFor: 'change logging' stamp: 'jsp 4/23/1999 11:49'!
wantsChangeSetLogging

	^ true.


! !


!WonderlandLightSource class methodsFor: 'class initialization' stamp: 'jsp 4/29/1999 10:51'!
initialize
	"Add the light names to WonderlandConstants"

	WonderlandConstants at: 'ambient' put: 'ambientLight'.
	WonderlandConstants at: 'positional' put: 'positionalLight'.
	WonderlandConstants at: 'directional' put: 'directionalLight'.
	WonderlandConstants at: 'spotlight' put: 'spotLight'.
! !
B3DIndexedTriangleMesh subclass: #WonderlandMesh
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Mesh'!
!WonderlandMesh commentStamp: '<historical>' prior: 0!
This class extends the basic Balloon 3D mesh class with the ability to parse OBJ and VFB (used with Alice MDL files) files.
!


!WonderlandMesh methodsFor: 'initialize' stamp: 'jsp 3/11/1999 10:31'!
createFromOBJFile: filename
	"Read in a mesh from the obj file"

	| aFile pos line words oldWords triple pt1 pt2 pt3 vCount fCount index |
	
	aFile _ (CrLfFileStream readOnlyFileNamed: filename) ascii.
	line _ aFile upTo: (Character cr).
	words _ line findTokens: ' '.
	
	vCount _ 0.

	"Count the vertices"
	[ (words at: 1) = 'v' ] whileTrue: [ vCount _ vCount + 1.
									   line _ aFile upTo: (Character cr).
									   words _ line findTokens: ' ' ].

	"Now reset the file and grab the actual data"
	aFile position: 0.

	"Create the vertex array"
	vertices _ B3DVector3Array new: vCount.

	"Read in the vertices"
	line _ aFile upTo: (Character cr).
	words _ line findTokens: ' '.

	index _ 1.
	[ (words at: 1) = 'v' ] whileTrue: [ vertices at: index put:
													(B3DVector3 x: ((words at: 2) asNumber)
																y: ((words at: 3) asNumber)
																z: ((words at: 4) asNumber)).
									   index _ index + 1.
									   line _ aFile upTo: (Character cr).
									   words _ line findTokens: ' ' ].

	"Read in the texture coordinates"
	index _ 1.
	vtxTexCoords _ B3DTexture2Array new: vCount.
	[ (words at: 1) = 'vt' ] whileTrue: [ vtxTexCoords at: index
													put: (B3DVector2 u: ((words at: 2) asNumber)
																	v: ((words at: 3) asNumber)).
										index _ index + 1.
										line _ aFile upTo: (Character cr).
	  									words _ line findTokens: ' '.
									].

	"Read in the normals"
	index _ 1.
	vtxNormals _ B3DVector3Array new: vCount.
	[ (words at: 1) = 'vn' ] whileTrue: [ vtxNormals at: index
											put: (B3DVector3 x: ((words at: 2) asNumber)
															 y: ((words at: 3) asNumber)
															 z: ((words at: 4) asNumber)).
										index _ index + 1.
										line _ aFile upTo: (Character cr).
	  									words _ line findTokens: ' '.
 									].

	pos _ aFile position.
	oldWords _ words.

	"Count the faces"
	fCount _ 0.
	[ (words size) > 0 ] whileTrue: [((words at: 1) = 'f') ifTrue: [ fCount _ fCount + 1 ].
										line _ aFile upTo: (Character cr).
	  									words _ line findTokens: ' '. ].

	"Create the faces array"
	faces _ B3DIndexedTriangleArray new: fCount.

	aFile position: pos.
	words _ oldWords.

	index _ 1.
	"Read in the faces"
	[ (words size) > 0 ] whileTrue: [((words at: 1) = 'f') ifTrue: [ 
					triple _ (words at: 2) findTokens: '/'.
					pt1 _ (triple at: 1) asNumber.

					triple _ (words at: 3) findTokens: '/'.
					pt2 _ (triple at: 1) asNumber.

					triple _ (words at: 4) findTokens: '/'.
					pt3 _ (triple at: 1) asNumber.

					faces at: index put: (B3DIndexedTriangle with: pt1 with: pt2 with: pt3).
					index _ index + 1.
										].
					line _ aFile upTo: (Character cr).
	  				words _ line findTokens: ' '.
				].

	aFile close.
! !

!WonderlandMesh methodsFor: 'initialize' stamp: 'jsp 3/15/1999 11:10'!
createFromVFBFile: filename
	"Read in a mesh from the vfb file"

	| aFile w x y z bytes version vCount fCount verticesPerFace  |
	
	aFile _ (StandardFileStream readOnlyFileNamed: filename) binary.

	"Read in the version number"
	bytes _ aFile next: 4.
	version _ bytes unsignedLongAt: 1 bigEndian: false.

	(version = 1) ifTrue: [
							"Read in the number of vertices"
							bytes _ aFile next: 4.
							vCount _ bytes unsignedLongAt: 1 bigEndian: false.
						]
				ifFalse: [
							vCount _ version.
							version _ 0.
						].

	(vCount > 0) ifTrue: [
		vertices _ B3DVector3Array new: vCount.
		vtxNormals _ B3DVector3Array new: vCount.
		vtxTexCoords _ B3DTexture2Array new: vCount.

		"Read in the vertices"
		1 to: vCount do: [:i | bytes _ aFile next: 32.
						x _ Float fromIEEE32Bit: (bytes unsignedLongAt: 1 bigEndian: false).
						y _ Float fromIEEE32Bit: (bytes unsignedLongAt: 5 bigEndian: false).
						z _ Float fromIEEE32Bit: (bytes unsignedLongAt: 9 bigEndian: false).
						vertices at: i put: (B3DVector3 x: (x negated) y: y z: z).

						x _ Float fromIEEE32Bit: (bytes unsignedLongAt: 13 bigEndian: false).
						y _ Float fromIEEE32Bit: (bytes unsignedLongAt: 17 bigEndian: false).
						z _ Float fromIEEE32Bit: (bytes unsignedLongAt: 21 bigEndian: false).
						vtxNormals at: i put: (B3DVector3 x: (x negated) y: y z: z).

						x _ Float fromIEEE32Bit: (bytes unsignedLongAt: 25 bigEndian: false).
						y _ Float fromIEEE32Bit: (bytes unsignedLongAt: 29 bigEndian: false).
						vtxTexCoords at: i put: (B3DVector2 u: x v: y).

						].

		"Read in the number of faces"
		bytes _ aFile next: 4.
		fCount _ bytes unsignedLongAt: 1 bigEndian: false.

		(fCount > 0) ifTrue: [
				"Read past the faceDataCount value"
				aFile next: 4.

				(version = 0) ifTrue: [ verticesPerFace _ 0. ]
							ifFalse: [
										bytes _ aFile next: 4.
										verticesPerFace _ bytes unsignedLongAt: 1 bigEndian: false.
									].

				(verticesPerFace = 0) ifTrue: [
							faces _ B3DIndexedTriangleArray new: fCount.

							1 to: fCount do: [: i |
								bytes _ aFile next: 4.
								w _ bytes unsignedLongAt: 1 bigEndian: false.

								(w = 3) ifTrue: [
									bytes _ aFile next: 4.
									x _ (bytes unsignedLongAt: 1 bigEndian: false) + 1.

									bytes _ aFile next: 4.
									y _ (bytes unsignedLongAt: 1 bigEndian: false) + 1.

									bytes _ aFile next: 4.
									z _ (bytes unsignedLongAt: 1 bigEndian: false) + 1.

									faces at: i put: (B3DIndexedTriangle with: x with: y with: z).
 												]
										ifFalse: [ 1 to: w do: [: j | aFile next: 4] ].

											].
																		].

							].  " (end if fCount > 0) "
						]	" (end if vCount > 0) "
			ifFalse: [ ^ nil ].

	aFile close.


! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandMesh class
	instanceVariableNames: ''!

!WonderlandMesh class methodsFor: 'instanceCreation' stamp: 'jsp 2/17/1999 15:25'!
fromOBJFile: filename
	"Reads and creates a mesh from an OBJ file"

	^ (WonderlandMesh new) createFromOBJFile: filename.


				! !

!WonderlandMesh class methodsFor: 'instanceCreation' stamp: 'jsp 3/11/1999 15:03'!
fromVFBFile: filename
	"Reads and creates a mesh from an OBJ file"

	^ (WonderlandMesh new) createFromVFBFile: filename.
! !
Morph subclass: #WonderlandMorph
	instanceVariableNames: 'myWonderland '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandMorph methodsFor: 'accessing' stamp: 'jsp 4/12/1999 15:02'!
getWonderland

	^ myWonderland.
! !

!WonderlandMorph methodsFor: 'accessing' stamp: 'jsp 4/12/1999 15:02'!
setWonderland: aWonderland

	myWonderland _ aWonderland.
! !


!WonderlandMorph methodsFor: 'morph depth' stamp: 'jsp 4/20/1999 16:07'!
sendBehind: aMorph
	"Put this morph behind the specified morph"

	((self owner) = (aMorph owner))
		ifFalse: [ myWonderland reportErrorToUser: 'The morphs need to have the same owner to put one behind the other.'.
				  ^ nil. ].

	(self owner) addMorph: self behind: aMorph.
! !

!WonderlandMorph methodsFor: 'morph depth' stamp: 'jsp 4/20/1999 16:07'!
sendInFrontOf: aMorph
	"Put this morph in front of the specified morph"

	((self owner) = (aMorph owner))
		ifFalse: [ myWonderland reportErrorToUser: 'The morphs need to have the same owner to put one in front of the other.'.
				  ^ nil. ].

	(self owner) addMorph: self inFrontOf: aMorph.
! !

!WonderlandMorph methodsFor: 'morph depth' stamp: 'jsp 4/12/1999 15:45'!
sendToBack
	"Bring this morph to the back"

	self owner addMorphBack: self.
! !

!WonderlandMorph methodsFor: 'morph depth' stamp: 'jsp 4/12/1999 15:45'!
sendToFront
	"Bring this morph to the front"

	self owner addMorphFront: self.
! !


!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:56'!
move: aDirection distance: aDistance
	"Move the morph the specified distance in the specified direction"

	^ self move: aDirection distance: aDistance duration: 1.0 style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:56'!
move: aDirection distance: aDistance duration: aDuration
	"Move the morph the specified distance in the specified direction"

	^ self move: aDirection distance: aDistance duration: aDuration style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 15:01'!
move: aDirection distance: aDistance duration: aDuration style: aStyle
	"Move the actor the specified distance in the specified direction, taking the specified duration and using the specified animation style."

	| anim aPoint tmpPoint |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyDirection: aDirection ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the direction to move the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyNumber: aDistance ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the distance to move the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move the morph because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ RelativeAnimation new.
	tmpPoint _ 0@0.

	(aDirection = left) ifTrue: [ aPoint _ (aDistance negated)@0 ]
		ifFalse: [ (aDirection = right) ifTrue: [ aPoint _ aDistance@0 ]
					ifFalse: [ (aDirection = up) ifTrue: [ aPoint _ 0@(aDistance negated) ]
								ifFalse: [ (aDirection = down) ifTrue: [ aPoint _ 0@aDistance ]
										ifFalse: [ myWonderland reportErrorToUser: 'Squeak does not know how to move the morph in that direction.'.
												^ nil ].
										].
							].
				].

	anim object: self
			update: [:tPos | self position: ((self position) + ((tPos rounded) - tmpPoint)).
							tmpPoint _ tPos rounded]
			getStartState: [tmpPoint _ 0@0. Interpolateable value: 0@0. ]
			getEndState: [ aPoint ]
			getReverseState: [ aPoint negated ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:57'!
moveTo: aPoint
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	^ self moveTo: aPoint duration: 1.0 style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:57'!
moveTo: aPoint duration: aDuration
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	^ self moveTo: aPoint duration: aDuration style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:58'!
moveTo: aPoint duration: aDuration style: aStyle
	"Moves the object to the specified position in its parent's coordinate system using the specified style over the specified duration."

	| anim |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPoint: aPoint ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move the morph to because ', msg.
			^ nil ].


	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for moving the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to move the morph because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	anim object: self
			update: [:tPos | self position: (tPos rounded)]
			getStartState: [self position]
			getEndState: [ aPoint ]
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/12/1999 14:58'!
moveTo: aPoint speed: aSpeed
	"Moves the object to the specified position in its parent's coordinate system at the specified speed."

	| anim |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyPoint: aPoint ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to move the morph to because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyPositiveNumber: aSpeed]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the speed to move the morph because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	anim object: self
			update: [:tPos | self position: (tPos rounded)]
			getStartState: [self position]
			getEndState: [ aPoint ]
			style: abruptly
			duration: ((self position) dist: aPoint) / aSpeed
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/20/1999 14:29'!
place: aLocation morph: aMorph
	"Place this WonderlandMorph in the specified location relative to the specified morph over 1 second using the gently animation style."

	^ self place: aLocation morph: aMorph duration: 1.0 style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/20/1999 14:29'!
place: aLocation morph: aMorph duration: aDuration
	"Place this WonderlandMorph in the specified location relative to the specified morph over 1 second using the gently animation style."

	^ self place: aLocation morph: aMorph duration: aDuration style: gently.
! !

!WonderlandMorph methodsFor: 'primitive behaviors' stamp: 'jsp 4/20/1999 16:20'!
place: aLocation morph: aMorph duration: aDuration style: aStyle
	"Place this WonderlandMorph in the specified location relative to the specified morph."

	| anim endStateFunc |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyLocation: aLocation ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine where to place the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: aDuration ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for placing the morph because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use to place the morph because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	anim _ AbsoluteAnimation new.

	(aLocation = toLeftOf)
		ifTrue: [ endStateFunc _ [ ((aMorph left) - (self width)) @
										((aMorph center y) - ((self height) // 2)) ] ]
		ifFalse: [

	(aLocation = toRightOf)
		ifTrue: [ endStateFunc _ [ (aMorph right) @
										((aMorph center y) - ((self height) // 2)) ] ]
		ifFalse: [

	((aLocation = onTopOf) or: [ aLocation = above ])
		ifTrue: [ endStateFunc _ [ ((aMorph center x) - ((self width) // 2)) @
										((aMorph top) - (self height)) ] ]
		ifFalse: [

	(((aLocation = below) or: [ aLocation = beneath ]) or: [ aLocation = onBottomOf ])
		ifTrue: [ endStateFunc _ [ ((aMorph center x) - ((self width) // 2)) @
										(aMorph bottom) ] ]
		ifFalse: [

	(aLocation = onCeilingOf)
		ifTrue: [ endStateFunc _ [ ((aMorph center x) - ((self width) // 2)) @
										(aMorph top) ] ]
		ifFalse: [

	(aLocation = onFloorOf)
		ifTrue: [ endStateFunc _ [ ((aMorph center x) - ((self width) // 2)) @
										((aMorph bottom) - (self height)) ] ]
		ifFalse: [

	(aLocation = inFrontOf)
		ifTrue: [ endStateFunc _ [ self sendInFrontOf: aMorph.
								   self position ] ]
		ifFalse: [

	((aLocation = inBackOf) or: [ aLocation = behind ])
		ifTrue: [ endStateFunc _ [ self sendBehind: aMorph.
								   self position ] ]

				]]]]]]].

	anim object: self
			update: [:tPos | self position: (tPos rounded)]
			getStartState: [self position]
			getEndState: endStateFunc
			style: aStyle
			duration: aDuration
			undoable: true
			inWonderland: myWonderland.

	^ anim.
! !
WonderlandLightSource subclass: #WonderlandPositionalLight
	instanceVariableNames: 'attenuation '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Lights'!

!WonderlandPositionalLight methodsFor: 'initialization' stamp: 'jsp 4/23/1999 14:30'!
initialize
	"Initialize this light"

	attenuation _ B3DLightAttenuation constant: 1.0 linear: 0.0 squared: 0.0.! !

!WonderlandPositionalLight methodsFor: 'initialization' stamp: 'jsp 4/29/1999 11:10'!
initializeFor: aWonderland
	"Initialize this light"

	super initializeFor: aWonderland.

	attenuation _ B3DLightAttenuation constant: 1.0 linear: 0.0 squared: 0.0.! !


!WonderlandPositionalLight methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:27'!
attenuation
	^attenuation! !

!WonderlandPositionalLight methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:28'!
attenuation: aLightAttenuation
	attenuation _ aLightAttenuation! !

!WonderlandPositionalLight methodsFor: 'accessing' stamp: 'jsp 4/23/1999 14:28'!
position

	^ self getPositionVector.
! !


!WonderlandPositionalLight methodsFor: 'shading' stamp: 'jsp 4/23/1999 14:29'!
computeAttenuationFor: distance
	"Compute the attenuation for the given distance"
	^attenuation computeAttenuationFor: distance! !

!WonderlandPositionalLight methodsFor: 'shading' stamp: 'ar 8/19/1999 16:44'!
computeDirectionTo: aB3DPrimitiveVertex
	"Compute the lights direction to the given vertex"

	^ aB3DPrimitiveVertex  position - (self getPositionVector).
! !


!WonderlandPositionalLight methodsFor: 'converting' stamp: 'jsp 4/23/1999 14:26'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight flags |
	primLight _ B3DPrimitiveLight new.
	primLight position: (self getPositionVector).
	flags _ FlagPositional.
	self attenuation isIdentity not ifTrue:[
		primLight attenuation: self attenuation.
		flags _ flags bitOr: FlagAttenuated].
	lightColor ambientPart isZero ifFalse:[
		primLight ambientPart: lightColor ambientPart.
		flags _ flags bitOr: FlagAmbientPart].
	lightColor diffusePart isZero ifFalse:[
		primLight diffusePart: lightColor diffusePart.
		flags _ flags bitOr: FlagDiffusePart].
	lightColor specularPart isZero ifFalse:[
		primLight specularPart: lightColor specularPart.
		flags _ flags bitOr: FlagSpecularPart].
	primLight flags: flags.
	^primLight! !

!WonderlandPositionalLight methodsFor: 'converting' stamp: 'jsp 4/29/1999 11:24'!
transformedBy: aTransformer

	^(super transformedBy: aTransformer)
			setPositionVector: (aTransformer transformPosition: (self getPositionVector)).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandPositionalLight class
	instanceVariableNames: ''!

!WonderlandPositionalLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:45'!
acceptsLoggingOfCompilation

	^ self == WonderlandPositionalLight.! !

!WonderlandPositionalLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:45'!
wantsChangeSetLogging

	^ self == WonderlandPositionalLight.

! !
Workspace subclass: #WonderlandQuickReference
	instanceVariableNames: 'myTextEditor '
	classVariableNames: 'HelpText '
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandQuickReference methodsFor: 'initialize-release' stamp: 'jsp 8/21/1999 16:34'!
initialize
	"Create a modified workspace as our script editor"

	super initialize.

	myTextEditor _ (PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:).

	myTextEditor name: 'Quick Reference'.
	myTextEditor scrollBarOnLeft: false.
	myTextEditor retractable: false.
	myTextEditor extent: 500@350.
	myTextEditor color: (Color r: 0.815 g: 0.972 b: 0.878).
! !


!WonderlandQuickReference methodsFor: 'accessing' stamp: 'jsp 4/20/1999 12:12'!
contents
	"Return the help text"

	^ HelpText.
! !

!WonderlandQuickReference methodsFor: 'accessing' stamp: 'jsp 4/20/1999 12:10'!
getMorph
	"Returns the text editor morph"

	^ myTextEditor.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandQuickReference class
	instanceVariableNames: ''!

!WonderlandQuickReference class methodsFor: 'class initialization' stamp: 'jsp 4/20/1999 13:52'!
initialize
	"Initialize the help text."

	HelpText _ 'This Quick Reference tab lists the basic commands and command combinations.

Names in every Wonderland:
	scene - the scene containing all the actors
	scheduler - the animation scheduler
	camera - the default camera
	cameraWindow - the morph the default camera renders into
	ground - the ground plane
	w - the Wonderland


WonderlandActors
=====================

This section lists the commands for actors broken down by category.

Movement
------------

Useful constants:
	direction: left, right, up, down, forward, back
	duration: rightNow, eachFrame
	style: gently, abruptly, beginGently, endGently
	position: asIs
	location: onTopOf, below, beneath, inFrontOf, inBackOf, behind, toLeftOf,
			toRightOf, onFloorOf, onCeilingOf

move: <direction>
move: <direction> distance: <number>
move: <direction> distance: <number>
move: <direction> distance: <number> duration: <number>
move: <direction> distance: <number> duration: <number> style: <style>
move: <direction> asSeenBy: <actor>
move: <direction> distance: <number> asSeenBy: <actor>
move: <direction> distance: <number> duration: <number> asSeenBy: <actor>
move: <direction> distance: <number> duration: <number> asSeenBy: <actor> style: <style>

move: <direction> speed: <number>
move: <direction> speed: <number> for: <number>
move: <direction> speed: <number> until: <condition>
move: <direction> speed: <number> asSeenBy: <actor>
move: <direction> speed: <number> asSeenBy: <actor> for: <number>
move: <direction> speed: <number> asSeenBy: <actor> until: <condition>

For moveTo, the position may be a { right. up. forward } triple or an <actor>. The triple values may be a number or asIs (ex. { asIs. 0. asIs } ).

moveTo: <position>
moveTo: <position> duration: <number>
moveTo: <position> duration: <number> style: <style>
moveTo: <position> asSeenBy: <actor>
moveTo: <position> duration: <number> asSeenBy: <actor>
moveTo: <position> duration: <number> asSeenBy: <actor> style: <style>

moveTo: <position> eachFrameFor: <number>
moveTo: <position> eachFrameUntil: <condition>
moveTo: <position> asSeenBy: <actor> eachFrameFor: <number>
moveTo: <position> asSeenBy: <actor> eachFrameUntil: <condition>

moveTo: <position> speed: <number>
moveTo: <position> speed: <number> asSeenBy: <actor> 

nudge: <direction>
nudge: <direction> distance: <number>
nudge: <direction> distance: <number> duration: <number>
nudge: <direction> distance: <number> duration: <number> style: <style>

place: <location> object: <actor>
place: <location> object: <actor> duration: <number>
place: <location> object: <actor> duration: <number> style: <style>
place: <location> object: <actor> eachFrameFor: <number>
place: <location> object: <actor> eachFrameUntil: <condition>



Turning
---------

Useful constants
	direction: left, right, up, down, forward, back
	style: gently, abruptly, beginGently, endGently
	duration: rightNow, eachFrame

alignWith: <actor>
alignWith: <actor> duration: <number>
alignWith: <actor> duration: <number> style: <style>

For the pointAt command, a target may be an <actor>, a { right. up. forward } trip, or a x@y pixel value.

pointAt: <target>
pointAt: <target> duration: <number>
pointAt: <target> duration: <number> style: <style>
pointAt: <target> duration: <number> eachFrameFor: <number>
pointAt: <target> duration: <number> eachFrameUntil: <condition>

roll: <direction>
roll: <direction> turns: <number> 
roll: <direction> turns: <number> duration: <number>
roll: <direction> turns: <number> duration: <number> style: <style>

roll: <direction> asSeenBy: <actor>
roll: <direction> turns: <number> asSeenBy: <actor>
roll: <direction> turns: <number> duration: <number> asSeenBy: <actor>
roll: <direction> turns: <number> duration: <number> asSeenBy: <actor> style: <style>

roll: <direction> turns: <number> speed: <number>
roll: <direction> turns: <number> speed: <number> asSeenBy: <actor>

roll: <direction> speed: <number>
roll: <direction> speed: <number> for: <number>
roll: <direction> speed: <number> until: <condition>
roll: <direction> speed: <number> asSeenBy: <actor>
roll: <direction> speed: <number> asSeenBy: <actor> for: <number>
roll: <direction> speed: <number> asSeenBy: <actor> until: <condition>

standUp
standUpWithDuration: <number>
standUpWithDuration: <number> style: <style>

turn: <direction>
turn: <direction> turns: <number> 
turn: <direction> turns: <number> duration: <number>
turn: <direction> turns: <number> duration: <number> style: <style>

turn: <direction> asSeenBy: <actor>
turn: <direction> turns: <number> asSeenBy: <actor>
turn: <direction> turns: <number> duration: <number> asSeenBy: <actor>
turn: <direction> turns: <number> duration: <number> asSeenBy: <actor> style: <style>

turn: <direction> turns: <number> speed: <number>
turn: <direction> turns: <number> speed: <number> asSeenBy: <actor>

turn: <direction> speed: <number>
turn: <direction> speed: <number> for: <number>
turn: <direction> speed: <number> until: <condition>
turn: <direction> speed: <number> asSeenBy: <actor>
turn: <direction> speed: <number> asSeenBy: <actor> for: <number>
turn: <direction> speed: <number> asSeenBy: <actor> until: <condition>

For turnTo, the orientation may be a rotation about the  { right. up. forward } axes or an <actor>. The triple values may be a number or asIs (ex. { asIs. 0. asIs } ).

turnTo: <orientation>
turnTo: <orientation> duration: <number>
turnTo: <orientation> duration: <number> style: <style>

turnTo: <orientation> asSeenBy: <actor>
turnTo: <orientation> duration: <number> asSeenBy: <actor>
turnTo: <orientation> duration: <number> asSeenBy: <actor> style: <style>

turnTo: <orientation> eachFrameFor: <number>
turnTo: <orientation> eachFrameUntil: <condition>
turnTo: <orientation> asSeenBy: <actor> eachFrameFor: <number>
turnTo: <orientation> asSeenBy: <actor> eachFrameUntil: <condition>

turnTo: <orientation> speed: <number>
turnTo: <orientation> speed: <number> asSeenBy: <actor>


Moving and Turning
------------------------

Useful constants:
	target: asIs
	duration: rightNow, eachFrame
	style: gently, abruptly, beginGently, endGently

The target for setPointOfView may be another actor or a { rpos. upos. fpos. rrot. urot. frot } sextuple.

setPointOfView: <target>
setPointOfView: <target> duration: <number>
setPointOfView: <target> duration: <number> style: <style>

setPointOfView: <target> asSeenBy: <actor>
setPointOfView: <target> duration: <number> asSeenBy: <actor>
setPointOfView: <target> duration: <number> asSeenBy: <actor> style: <style>

setPointOfView: <target> eachFrameFor: <number>
setPointOfView: <target> eachFrameUntil: <condition>
setPointOfView: <target> asSeenBy: <actor> eachFrameFor: <number>
setPointOfView: <target> asSeenBy: <actor> eachFrameUntil: <condition>

Resizing
---------

Useful constants:
	dimension: topToBottom, leftToRight, frontToBack


A resize amount may be a <number> for uniform scaling or a { right. up. forward } triple for non-uniform resizing.

resize: <amount>
resize: <amount> duration: <number>
resize: <amount> duration: <number> style: <style>
resize: <amount> eachFrameFor: <number>
resize: <amount> eachFrameUntil: <condition>

resizeLikeRubber: <amount> dimension: <dimension>
resizeLikeRubber: <amount> dimension: <dimension> duration: <number>
resizeLikeRubber: <amount> dimension: <dimension> duration: <number> style: <style>

The size for a setSize are the desired { leftToRight. toptoBottom. frontToBack } dimensions.

setSize: <size>
setSize: <size> duration: <number>
setSize: <size> duration: <number> style: <style>

Waiting
---------

wait
wait: <number>


Actor Hierarchy
-------------------

becomeChildOf: <actor>
becomePart
becomeFirstClass


Playing Sounds
------------------

playSound: ''soundfile.wav''


Changing Color
------------------

A color may be a named color (red, green, blue, orange, yellow, periwinkle, etc) or a { red. green. blue } triple.

setColor: <color>
setColor: <color> duration: <number>
setColor: <color> duration: <number> style: <style>

Changing Visibility
----------------------

hide
show

setVisibility: <number>
setVisibility: <number> duration: <number>
setVisibility: <number> duration: <number> style: <style>

Changing Texture
---------------------

setTexture: ''texturefile.bmp''


Animated State
-----------------

pause
resume
stop

Adding Reactions
--------------------

Useful constants:
	event types: keyPress, leftMouseDown, leftMouseUp, leftMouseClick,
			rightMouseDown, rightMouseUp, rightMouseClick

addResponse: <block> to: <eventType>
removeResponse: <response> to: <eventType>
respondWith: <block> to: <eventType>

Destruction
-------------

destroy
destroy: <duration>


Wonderlands
===============

Creating
----------

makeActor
makeActorFrom: ''actorFile''

makeCamera


Composing Animations
--------------------------

doTogether and doInOrder both accept an ordered collection of animations.

doTogether: { animations }
doInOrder: { animations }

'.
! !
Object subclass: #WonderlandReaction
	instanceVariableNames: 'reaction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Misc'!

!WonderlandReaction methodsFor: 'initialization' stamp: 'jsp 4/19/1999 13:15'!
initializeWith: aReaction
	"Set the wrapped reaction"

	reaction _ aReaction.
! !


!WonderlandReaction methodsFor: 'react' stamp: 'jsp 4/19/1999 14:20'!
reactTo: event
	"Activate the reaction with the event."

	reaction value: event.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandReaction class
	instanceVariableNames: ''!

!WonderlandReaction class methodsFor: 'instance creation' stamp: 'jsp 4/19/1999 14:21'!
new: aReaction
	"Create a new WonderlandReaction instance.  This instance basically wraps a block that specifies what the given object should do"

	^ self new initializeWith: aReaction.
! !
Hierarchical subclass: #WonderlandScene
	instanceVariableNames: 'myWonderland myColor '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Objects'!
!WonderlandScene commentStamp: '<historical>' prior: 0!
Every Wonderland contains an instance of the WonderlandScene.  The scene is at the top of the object hierarchy: all objects are (directly or indirectly) children of the scene.  The scene also defines the global coordinate system for the 3D world.
!


!WonderlandScene methodsFor: 'initialization' stamp: 'jsp 3/15/1999 15:27'!
initializeFor: aWonderland
	"Initialize the Wonderland Scene."

	super initialize.

	"Set our properties"
	myWonderland _ aWonderland.
	myColor _ B3DColor4 r: 0.4 g: 0.6 b: 0.85 a: 1.
! !


!WonderlandScene methodsFor: 'drawing' stamp: 'ar 4/18/1999 00:27'!
renderOn: aRenderer
	"Tell the Scene's children to draw themselves"
	"Note: For correct picking, it is important to use B3DRenderEngine>>render: here."
	myChildren do: [:child | aRenderer render: child ].
! !


!WonderlandScene methodsFor: 'set property' stamp: 'jsp 3/1/1999 14:15'!
setColor: newColor
	"Set the scene's background color"

	^ (self setColor: newColor duration: 1.0
			style: gently)

! !

!WonderlandScene methodsFor: 'set property' stamp: 'jsp 3/22/1999 16:06'!
setColor: newColor duration: time
	"Set the scene's background color"

	(time = rightNow) ifTrue: [
		[ WonderlandVerifier VerifyColor: newColor ]
			ifError: [ :msg :rcvr |
				myWonderland reportErrorToUser: 'Squeak could not determine what color to make the scene because ', msg.
				^ nil ].
	
		^ self setColorRightNow: newColor undoable: true ].

	^ (self setColor: newColor duration:time style: gently)

! !

!WonderlandScene methodsFor: 'set property' stamp: 'jsp 3/22/1999 16:06'!
setColor: newColor duration: time style: aStyle
	"Set the actor's color"

	| anim aColor |

	"Check our arguments to make sure they're valid"
	[ WonderlandVerifier VerifyColor: newColor ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine what color to make the scene because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyDuration: time ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser:
				'Squeak could not determine the duration to use for changing the color of the scene because ', msg.
			^ nil ].

	[ WonderlandVerifier VerifyStyle: aStyle ]
		ifError: [ :msg :rcvr |
			myWonderland reportErrorToUser: 'Squeak could not determine the style to use for changing the color of the scene because ', msg.
			^ nil ].

	"Our parameters check out, so build the animation"
	((newColor at: 1) isNumber)
				ifTrue: [ aColor _ B3DColor4 red: (newColor at: 1) green: (newColor at: 2)
										blue: (newColor at: 3) alpha: 1.0 ]
				ifFalse: [ aColor _ Color perform: newColor.
						  aColor _ B3DColor4 red: (aColor red) green: (aColor green)
										blue: (aColor blue) alpha: 1.0 ].

	anim _ AbsoluteAnimation new.
	anim object: self
			update: [:tColor | self setColorVector: tColor]
			getStartState: [self getColorVector]
			getEndState: [ aColor ]
			style: aStyle
			duration: time
			undoable: true
			inWonderland: myWonderland.


	^ anim.
! !


!WonderlandScene methodsFor: 'get property' stamp: 'jsp 3/22/1999 10:55'!
getColor
	"Return the scene's background color"

	| tmpArray |

	myColor ifNil: [ ^ nil ].

	tmpArray _ Array new:3.
	
	tmpArray at:1 put: (myColor red).
	tmpArray at:2 put: (myColor green).
	tmpArray at:3 put: (myColor blue).

	^ tmpArray.! !


!WonderlandScene methodsFor: 'accessing' stamp: 'jsp 4/1/1999 17:26'!
asString
	"Return a string name for the scene"

	^ 'scene'.

! !

!WonderlandScene methodsFor: 'accessing' stamp: 'jsp 4/1/1999 17:26'!
getName
	"Return the scene's name"

	^ 'scene'.
! !


!WonderlandScene methodsFor: 'private' stamp: 'jsp 3/22/1999 10:16'!
getColorObject
	"Returns the scene's background color object"

	^ myColor.

! !

!WonderlandScene methodsFor: 'private' stamp: 'jsp 2/23/1999 15:40'!
getColorVector
	"Return the scene's background color"

	^ myColor.

! !

!WonderlandScene methodsFor: 'private' stamp: 'jsp 2/22/1999 14:39'!
getMatrixFromRoot
	"Returns the identity matrix"

	^ (B3DMatrix4x4 identity).
! !

!WonderlandScene methodsFor: 'private' stamp: 'jsp 2/22/1999 14:39'!
getMatrixToRoot
	"Returns the identity matrix"

	^ (B3DMatrix4x4 identity).
! !

!WonderlandScene methodsFor: 'private' stamp: 'jsp 3/22/1999 16:05'!
setColorRightNow: newColor undoable: isUndoable
	"Change this instance's color instantaneously"

	| aColor |

	(isUndoable) ifTrue: [
		myWonderland getUndoStack push: (UndoColorChange for: self from: (self getColor)) ].

	((newColor at: 1) isNumber)
				ifTrue: [ aColor _ B3DColor4 red: (newColor at: 1) green: (newColor at: 2)
										blue: (newColor at: 3) alpha: (1.0) ]
				ifFalse: [ aColor _ Color perform: newColor.
						  aColor _ B3DColor4 red: (aColor red) green: (aColor green)
										blue: (aColor blue) alpha: (1.0) ].

	self setColorVector: aColor.
! !

!WonderlandScene methodsFor: 'private' stamp: 'jsp 2/23/1999 15:36'!
setColorVector: aColor
	"Set the scene's background color instantaneously"

	myColor _ aColor.
! !


!WonderlandScene methodsFor: 'event-handling' stamp: 'jsp 4/19/1999 13:43'!
getReactionsTo: evtType

	^ nil.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandScene class
	instanceVariableNames: ''!

!WonderlandScene class methodsFor: 'instance creation' stamp: 'jsp 3/10/1999 16:10'!
newFor: aWonderland
	"Initialize the new instance for a Wonderland before returning it."

	^ super new initializeFor: aWonderland.
! !
Workspace subclass: #WonderlandScriptEditor
	instanceVariableNames: 'myTextEditor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandScriptEditor commentStamp: '<historical>' prior: 0!
This class implements the script editor for Wonderlands.  The script editor is a Wonderland that has been modified to use the Wonderland's namespace.
!


!WonderlandScriptEditor methodsFor: 'initialize-release' stamp: 'jsp 8/21/1999 16:34'!
initialize
	"Create a modified workspace as our script editor"

	super initialize.

	myTextEditor _ (PluggableTextMorph on: self text: #contents accept: #acceptContents:
			readSelection: nil menu: #codePaneMenu:shifted:).

	myTextEditor name: 'Script'.
	myTextEditor scrollBarOnLeft: false.
	myTextEditor retractable: false.
	myTextEditor extent: 500@350.
	myTextEditor color: (Color r: 0.815 g: 0.972 b: 0.878).
! !


!WonderlandScriptEditor methodsFor: 'accessing' stamp: 'jsp 4/1/1999 15:42'!
getMorph
	"Returns the text editor morph"

	^ myTextEditor.
! !
WonderlandPositionalLight subclass: #WonderlandSpotLight
	instanceVariableNames: 'target minCos maxCos deltaCos direction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Lights'!

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:53'!
direction
	^direction ifNil:[direction _ (target - (self getPositionVector)) safelyNormalize].! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
direction: aVector
	direction _ aVector! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
hotSpotDeltaCosine
	^deltaCos! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
hotSpotMaxCosine
	^maxCos! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
hotSpotMinCosine
	^minCos! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
maxAngle
	^maxCos arcCos radiansToDegrees! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:54'!
maxAngle: angle
	minCos _ angle degreesToRadians cos.
	maxCos ifNotNil:[deltaCos _ maxCos - minCos].! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:55'!
minAngle
	^minCos arcCos radiansToDegrees! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:55'!
minAngle: angle
	maxCos _ angle degreesToRadians cos.
	minCos ifNotNil:[deltaCos _ maxCos - minCos].! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:55'!
target
	^target! !

!WonderlandSpotLight methodsFor: 'accessing' stamp: 'jsp 4/29/1999 13:55'!
target: aVector
	target _ aVector! !


!WonderlandSpotLight methodsFor: 'testing' stamp: 'jsp 4/29/1999 13:51'!
hasSpot

	^ true.! !


!WonderlandSpotLight methodsFor: 'converting' stamp: 'jsp 4/29/1999 13:52'!
asPrimitiveLight
	"Convert the receiver into a B3DPrimitiveLight"
	| primLight |
	primLight _ super asPrimitiveLight.
	primLight flags: (primLight flags bitOr: FlagHasSpot).
	primLight spotMinCos: minCos.
	primLight spotMaxCos: maxCos.
	primLight spotDeltaCos: deltaCos.
	primLight spotExponent: self spotExponent.
	primLight direction: (target - (self getPositionVector)) safelyNormalize.
	^primLight! !

!WonderlandSpotLight methodsFor: 'converting' stamp: 'jsp 4/29/1999 15:46'!
transformedBy: aTransformer
	^(super transformedBy: aTransformer) 
		target: (aTransformer transformPosition: target).
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandSpotLight class
	instanceVariableNames: ''!

!WonderlandSpotLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:46'!
acceptsLoggingOfCompilation

	^ self == WonderlandSpotLight.! !

!WonderlandSpotLight class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:46'!
wantsChangeSetLogging

	^ self == WonderlandSpotLight.

! !
WonderlandCamera subclass: #WonderlandStillCamera
	instanceVariableNames: 'focusObject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Objects'!

!WonderlandStillCamera methodsFor: 'initialize-release' stamp: 'jsp 7/7/1999 17:49'!
initializeFor: aWonderland
	"Initializes the camera."

	super initializeFor: aWonderland.

	"Set the camera's mesh and geometry"
	self setMesh: nil.
	self setTexturePointer: nil.

	"Delete the WonderlandCameraMorph our superclass created"
	myMorph delete.	

	"Create a WonderlandStillCameraMorph for the camera to render into"
	myMorph _ WonderlandStillCameraMorph new.
	myMorph initializeWithCamera: self.
	myMorph openInWorld.

	"Initially we aren't focusing on any particular object"
	focusObject _ nil.

	"Initially draw the scene background"
	drawSceneBackground _ true.
! !


!WonderlandStillCamera methodsFor: 'private' stamp: 'jsp 6/29/1999 02:40'!
appearsInChildLists
	"Return false; we want to hide the still camera from the user"

	^ false.
! !


!WonderlandStillCamera methodsFor: 'assigning focus object' stamp: 'jsp 7/15/1999 15:13'!
setFocusObject: anActor
	"Assign the object in the Wonderland that the camera should focus on"

	| boundingBox origin corner center maxDimension distance frustum |

	focusObject _ anActor.

	anActor ifNotNil: [

			(anActor isKindOf: WonderlandActor)
				ifTrue: [ boundingBox _ anActor getBoundingBox.
						  origin _ boundingBox origin.
						  corner _ boundingBox corner.
						  center _ (origin + corner) / 2.0.

						  self turnToRightNow: { 0. 0. 0} asSeenBy: anActor undoable: false.
						  self turnRightNow: left numberOfTurns: 0.5 undoable: false.

						  maxDimension _ (((corner x - center x) max: (corner y - center y))
												max: (center x - origin x))
													max: (center y - origin y).

						  frustum _ self getFrustum.
						  distance _ ((frustum near) * maxDimension / (0.7 * (frustum right)))
										+ (corner z).

						  self moveToRightNow: { center x.
												  center y.
												  distance }
								asSeenBy: anActor undoable: false.

						  self moveRightNow: right distance: (maxDimension) undoable: false.
						  self moveRightNow: up distance: (maxDimension) undoable: false.
						  self turnRightNow: left numberOfTurns:
								((((maxDimension) arcTan: distance) radiansToDegrees) / 360.0)
								undoable: false.
						  self turnRightNow: down numberOfTurns:
								((((maxDimension) arcTan: distance) radiansToDegrees) / 360.0)
								undoable: false.
						]

				ifFalse: [ self moveToRightNow: { -1.5. 0.5. 2.6 } asSeenBy: anActor undoable: false.
						  self pointAtRightNow: { 0. 0. 0 } undoable: false.
						  self moveRightNow: back distance: 20 undoable: false ].

		].

	myMorph changed.
! !


!WonderlandStillCamera methodsFor: 'rendering' stamp: 'jsp 7/7/1999 18:42'!
render: aRenderEngine pickingAt: aPointOrNil withPrimitiveVertex: aBoolean
	"Override the parent method. A WonderlandStillCamera only renders the object that it's focusing on."

	| aRenderer pickedObject |
	aRenderer _ aRenderEngine. "A couple of things must be set before we can pick!!"

	aRenderer viewport: (myMorph bounds insetBy: 1@1).

	(drawSceneBackground)
		ifTrue: [ aRenderer clearViewport: (myWonderland getScene getColorObject). ]
		ifFalse: [ ].

	aRenderer clearDepthBuffer.
	aRenderer loadIdentity.

	focusObject ifNotNil: [

		"Add any existing lights to the renderer for this camera"
		(myWonderland getLights) do: [:light | aRenderer addLight: light ].

		"Calculate our view matrix by inverting the camera's composite matrix and hand it
		to the renderer - note that this will eventually have to walk up the tree"
		viewMatrix _ self getMatrixToRoot.
		aRenderer transformBy: viewMatrix.

		aRenderer perspective: perspective.

		"Initialize picking if necessary"
		aPointOrNil ifNotNil:[aRenderer _ aRenderer asPickerAt: aPointOrNil].

		(focusObject isKindOf: WonderlandScene)
			ifTrue: [ myWonderland renderWonderland: aRenderer ]
			ifFalse: [ aRenderer transformBy: (focusObject getParent getMatrixFromRoot).
					  focusObject renderOn: aRenderer ].

		"Fetch the picked object"
		aPointOrNil ifNotNil:[
			aBoolean
				ifTrue:[pickedObject _ aRenderer topMostObject -> aRenderer topMostVertex]
				ifFalse:[pickedObject _ aRenderer topMostObject]].

	].

	"Force the renderer to draw to the screen"
	aRenderer finish.

	aRenderer destroy.

	^pickedObject "Will be nil if not picking".
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandStillCamera class
	instanceVariableNames: ''!

!WonderlandStillCamera class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:11'!
acceptsLoggingOfCompilation
	^ (self == WonderlandStillCamera).
! !

!WonderlandStillCamera class methodsFor: 'change logging' stamp: 'jsp 7/8/1999 23:15'!
wantsChangeSetLogging
	^ (self == WonderlandStillCamera).
! !
WonderlandCameraMorph subclass: #WonderlandStillCameraMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Morphs'!

!WonderlandStillCameraMorph methodsFor: 'stepping' stamp: 'jsp 6/29/1999 01:07'!
wantsSteps

	^ false.
! !


!WonderlandStillCameraMorph methodsFor: 'controls' stamp: 'jsp 6/29/1999 01:20'!
hideCameraControls
	"Override our parent method to do nothing."



! !

!WonderlandStillCameraMorph methodsFor: 'controls' stamp: 'jsp 6/29/1999 01:20'!
showCameraControls
	"Override the parent method to do nothing."

! !


!WonderlandStillCameraMorph methodsFor: 'event handling' stamp: 'jsp 6/29/1999 01:08'!
handlesMouseDown: evt
	"We don't want to handle mouse up and down events, so return false"

	^ false.
! !

!WonderlandStillCameraMorph methodsFor: 'event handling' stamp: 'jsp 6/29/1999 01:08'!
handlesMouseOver: evt
	"We don't want to handle mouse enter/leave events, so return false."

	^ false.

! !
Object subclass: #WonderlandStyle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Balloon3D-Wonderland Misc'!
!WonderlandStyle commentStamp: '<historical>' prior: 0!
The WonderlandStyle class implements different animation styles.  The four styles this class provides are gently (slow-in, slow-out), beginGently (slow-in), endGently (slow-out), and abruptly (linear).

Animations use these styles through blocks of the form:

[ :elapsed :duration | WonderlandStyle beginGentlyAfter: elapsed outOf: duration ]

The intention is that using this mechanism the user can specify arbitrary styles using blocks and pass them to animations.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandStyle class
	instanceVariableNames: ''!

!WonderlandStyle class methodsFor: 'class initialization' stamp: 'jsp 4/2/1999 09:50'!
initialize
	"Add the style constants gently, beginGently, endGently, and abruptly to the WonderlandConstants dictionary"

	| dict |

	dict _ Smalltalk at: #WonderlandConstants.
	dict at: 'gently' put:
			[:elapsed :duration | WonderlandStyle gentlyAfter: elapsed outOf: duration ].
	dict at: 'beginGently' put:
			[:elapsed :duration | WonderlandStyle beginGentlyAfter: elapsed outOf: duration ].
	dict at: 'endGently' put:
			[:elapsed :duration | WonderlandStyle endGentlyAfter: elapsed outOf: duration ].
	dict at: 'abruptly' put:
			[:elapsed :duration | WonderlandStyle abruptlyAfter: elapsed outOf: duration ].
! !


!WonderlandStyle class methodsFor: 'instance creation' stamp: 'jsp 2/4/1999 14:58'!
new
	"Users shouldn't create any instances of this class, so this method throws an error if they try."

	self error: 'This class exists to generate style parameters, so it should not be instatiated.'
! !


!WonderlandStyle class methodsFor: 'generate parameters' stamp: 'jsp 3/1/1999 17:04'!
abruptlyAfter: elapsed outOf: duration
	"Returns the proportion done for an Abrupt animation style after elapsed seconds (out of duration seconds) have elapsed."

	(elapsed >= duration) ifTrue: [ ^ 1.0 ].

	^ (elapsed / duration).
! !

!WonderlandStyle class methodsFor: 'generate parameters' stamp: 'jsp 3/1/1999 17:04'!
beginGentlyAfter: elapsed outOf: duration
	"Returns the proportion done for an animation using the BeginGently style after elapsed seconds (out of duration seconds)."

	(elapsed >= duration) ifTrue: [ ^ 1.0 ].

	^ (self gently: (elapsed / duration) lowerBound: 0.99 upperBound: 0.999).
! !

!WonderlandStyle class methodsFor: 'generate parameters' stamp: 'jsp 3/1/1999 17:04'!
endGentlyAfter: elapsed outOf: duration
	"Returns the proportion done for an animation using the EndGently style after elapsed seconds (out of duration seconds)."

	(elapsed >= duration) ifTrue: [ ^ 1.0 ].

	^ (self gently: (elapsed / duration) lowerBound: 0.001 upperBound: 0.01).
! !

!WonderlandStyle class methodsFor: 'generate parameters' stamp: 'jsp 3/1/1999 17:05'!
gentlyAfter: elapsed outOf: duration
	"Returns the proportion done for an animation using the Gently style after elapsed seconds (out of duration seconds)."

	(elapsed >= duration) ifTrue: [ ^ 1.0 ].

	^ (self gently: (elapsed / duration) lowerBound: 0.3 upperBound: 0.8).
! !

!WonderlandStyle class methodsFor: 'generate parameters' stamp: 'jsp 2/4/1999 15:08'!
oneAfter: elapsed outOf: duration
	"Returns the proportion of Animation done using an instantaneous style - this is also 1.0."

	^ 1.0.
! !


!WonderlandStyle class methodsFor: 'private' stamp: 'jsp 2/4/1999 15:22'!
gently: x lowerBound: A upperBound: B
	"This method converts a linear proportion done to a slow in - slow out proportion. If x is less than A then the animation is in the slow in part, while if x is greater than B then the animation is in the slow out part."

	| y a3 b3 c3 m b2 |
 
 	(x < A) ifTrue: [ y _ ((B - 1)/(A *  ((B * B) - (A * B) + A - 1))) * x * x ]
		    ifFalse: [ (x > B) ifTrue: [
										a3 _ 1 / ((B * B) - (A * B) + A - 1).
										b3 _ -2 * a3.
										c3 _ 1 + a3.
  										y _ (a3 * x * x) + (b3 * x) + c3.
									]
							ifFalse: [
										m _ 2 * (B - 1) / ((B * B) - (A * B) + A - 1).
										b2 _ (0 - m) * A / 2.
										y _ m * x + b2.
									].
  				    ].

	^ y.
! !
Object subclass: #WonderlandUndoStack
	instanceVariableNames: 'theStack stackIsOpen maxStackDepth '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Undo'!
!WonderlandUndoStack commentStamp: '<historical>' prior: 0!
This class implements the undo stack for Wonderlands.  Every user action is added to the undo stack, and the user can then undo each action one at a time. This stack is intended to be "infinite" so that the user can always roll back to a safe state.  In practice the stack is actually depth limited (to 100 actions), but the user can adjust this depth using the setMaxDepth: message.

!


!WonderlandUndoStack methodsFor: 'initialization' stamp: 'jsp 3/24/1999 15:53'!
initialize
	"Initializes the undo stack."

	theStack _ OrderedCollection new.
	stackIsOpen _ true.
	maxStackDepth _ (WonderlandConstants at: 'maxUndoDepth').
! !


!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/8/1999 12:16'!
closeStack
	"Close the stack to prevent undoable items from being pushed onto it."

	stackIsOpen _ false.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/24/1999 15:54'!
getMaxDepth
	"Returns the current maximum depth of the undo stack"

	^ maxStackDepth.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 2/14/1999 18:36'!
isEmpty
	"Returns true if the undo stack is empty"

	^ (theStack size) = 0.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/8/1999 12:18'!
isOpen
	"Returns true if the undo stack is open"

	^ stackIsOpen.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/8/1999 12:16'!
openStack
	"Open the stack to allow undoable items to be pushed onto it."

	stackIsOpen _ true.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 2/14/1999 18:38'!
pop
	"Takes the top undo action off the stack."

	| lastItem |

	(theStack isEmpty) ifTrue: [lastItem _ nil]
					   ifFalse: [lastItem _ theStack removeLast].

	^ lastItem.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 2/16/1999 16:36'!
popAndUndo
	"Takes the top undo action off the stack and does it (undoing the original action)."

	| lastItem |

	(theStack isEmpty) ifTrue: [lastItem _ nil]
					   ifFalse: [lastItem _ (theStack removeLast) undoIt].

	^ lastItem.
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/24/1999 15:55'!
push: anAction
	"Pushes an undo action on the stack."

	(stackIsOpen) ifTrue: [ theStack addLast: anAction ].

	((theStack size) > maxStackDepth) ifTrue: [ theStack removeFirst ].
! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'jsp 3/24/1999 15:54'!
setMaxDepth: aNumber
	"Sets the current maximum depth of the undo stack"

	maxStackDepth _ aNumber.

! !

!WonderlandUndoStack methodsFor: 'accessing' stamp: 'ar 11/7/1999 20:13'!
top
	"Return the top undo action off the stack."

	| lastItem |

	(theStack isEmpty) ifTrue: [lastItem _ nil]
					   ifFalse: [lastItem _ theStack last].

	^ lastItem.
! !


!WonderlandUndoStack methodsFor: 'reset' stamp: 'jsp 3/30/1999 15:44'!
reset
	"Reset the undo stack."

	theStack _ OrderedCollection new.
	stackIsOpen _ true.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandUndoStack class
	instanceVariableNames: ''!

!WonderlandUndoStack class methodsFor: 'instance creation' stamp: 'jsp 2/14/1999 18:41'!
new
	"Create a new Wonderland undo stack and initializes it."

	^ super new initialize.
! !
Object subclass: #WonderlandVerifier
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Misc'!
!WonderlandVerifier commentStamp: '<historical>' prior: 0!
This class implements methods for verifying the parameters passed to methods.  The intention is that each parameter is verified, and if it's not of the expected type then an error message is constructed and displayed to the user. This provides a gentler method of informing the user of errors than throwing them into the debugger.
!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandVerifier class
	instanceVariableNames: ''!

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 14:53'!
Verify0To1Number: parameter
	"If the parameter is a valid number this method returns true, otherwise it throws an exception"

	(((parameter isNumber) and: [ parameter >= 0 ]) and: [ parameter <= 1 ])
					ifTrue: [ ^ true ]
					ifFalse: [ self error: (parameter asString) , ' is not a number between 0 and 1. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:23'!
VerifyActor: parameter
	"If the parameter is a valid WonderlandActor (or subclass) this method returns true, otherwise it throws an exception"

	(parameter isKindOf: WonderlandActor)
		ifTrue: [ ^ true ]
		ifFalse: [ self error: (parameter asString) , ' is not a valid Wonderland Actor. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 14:59'!
VerifyColor: parameter
	"If the parameter is a valid color (triple or named color) this method returns true, otherwise it throws an exception"

	(parameter isKindOf: SequenceableCollection)
		ifTrue: [
			(((((parameter size) = 3)
				and: [ ((parameter at: 1) isNumber) and:
							[ ((parameter at: 1) >= 0) and: [ ((parameter at: 1) <= 1) ] ] ] )
				and: [ ((parameter at: 2) isNumber) and:
 							[ ((parameter at: 2) >= 0) and: [ ((parameter at: 2) <= 1) ] ] ] )
				and: [ ((parameter at: 3) isNumber) and:
							[ ((parameter at: 3) >= 0) and: [ ((parameter at: 3) <= 1) ] ] ] )
					ifTrue: [ ^ true ]
					ifFalse: [ [ Color perform: parameter. ]
								ifError: [ :msg : rcvr | self error: (parameter asString) ,
												' is not a valid color. '].
							  ^ true.
							].
  				]
		ifFalse: [ self error: (parameter asString) , ' is not a valid color. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 13:45'!
VerifyCondition: parameter
	"If the parameter is a valid style (BlockContext that takes 1 parameter and returns a boolean) this method returns true, otherwise it throws an exception"

	| result | 

	[ result _ ((parameter value) isKindOf: Boolean) ] 
		ifError: [ :msg :rcvr |
					self error: 'your condition must be a block that returns true or false.' ].

	(result) ifTrue: [ ^ true ]
			ifFalse: [ self error: 'your condition does not return true or false. '].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/22/1999 12:25'!
VerifyDimension: parameter
	"If the parameter is a valid dimension this method returns true, otherwise it throws an exception"

	(((parameter = leftToRight) or: [ parameter = topToBottom ]) or: [ parameter = frontToBack ])
			ifTrue: [ ^ true ]
			ifFalse: [ self error: (parameter asString) , ' is not a valid dimension. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:41'!
VerifyDirection: parameter
	"If the parameter is a valid direction this method returns true, otherwise it throws an exception"

	(((((((((parameter = left) or: [ parameter = right ]) or: [ parameter = up ])
			or: [ parameter = down ]) or: [ parameter = forward ])
			or: [ parameter = back ]) or: [ parameter = backward ])
			or: [ parameter = ccw ]) or: [ parameter = cw ])
					ifTrue: [ ^ true ]
					ifFalse: [ self error: (parameter asString) , ' is not a valid direction. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:41'!
VerifyDuration: parameter
	"If the parameter is a valid duration this method returns true, otherwise it throws an exception"

	((( parameter = rightNow) or: [ parameter = eachFrame ])
		or: [ (parameter isNumber) and: [ parameter >= 0 ]	])
					ifTrue: [ ^ true ]
					ifFalse: [ self error: (parameter asString) , ' is not a valid duration. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 4/29/1999 15:11'!
VerifyLight: parameter
	"If the parameter is a valid type of light this method returns true, otherwise it throws an exception"

	((((parameter = ambient) or: [parameter = positional]) or: [parameter = directional])
			or: [parameter = spotlight])
		ifTrue: [ ^ true ]
		ifFalse: [ self error: (parameter asString) , ' is not a valid type of light. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:41'!
VerifyLocation: parameter
	"If the parameter is a valid location this method returns true, otherwise it throws an exception"

	((((((((((parameter = toLeftOf) or: [ parameter = toRightOf ]) or: [ parameter = onTopOf ])
			or: [ parameter = onBottomOf ]) or: [ parameter = inFrontOf ])
			or: [ parameter = inBackOf ]) or: [ parameter = behind ])
			or: [ parameter = below ]) or: [ parameter = onFloorOf ])
			or: [ parameter = onCeilingOf ])
					ifTrue: [ ^ true ]
					ifFalse: [ self error: (parameter asString) , ' is not a valid location. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 16:24'!
VerifyNonNegativeNumber: parameter
	"If the parameter is a valid number this method returns true, otherwise it throws an exception"

	((parameter isNumber) and: [ parameter >= 0 ])
			ifTrue: [ ^ true ]
			ifFalse: [ self error: (parameter asString) , ' is not a number greater than or equal to zero. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:23'!
VerifyNumber: parameter
	"If the parameter is a valid number this method returns true, otherwise it throws an exception"

	(parameter isNumber)
					ifTrue: [ ^ true ]
					ifFalse: [ self error: (parameter asString) , ' is not a valid number. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/24/1999 16:43'!
VerifyNumberOrTriple: parameter
	"If the parameter is a number or a valid triple this method returns true, otherwise it throws an exception"

	((parameter isNumber) or: [(((((parameter isKindOf: SequenceableCollection)
			and: [ (parameter size) = 3 ] )
			and: [ ((parameter at: 1) isNumber) ] )
			and: [ ((parameter at: 2) isNumber) ] )
 			and: [ ((parameter at: 3) isNumber) ] ) ])
 				ifTrue: [ ^ true ]
				ifFalse: [ self error: (parameter asString) , ' is not a number or triple. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/22/1999 16:25'!
VerifyPoint: parameter
	"If the parameter is a valid point this method returns true, otherwise it throws an exception"

	(parameter isKindOf: Point)
		ifTrue: [ ^ true ]
		ifFalse: [ self error: (parameter asString) , ' is not a valid point. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 15:16'!
VerifyPointOfView: parameter
	"If the parameter is a valid point of view (sextuple or kind of WonderlandActor) this method returns true, otherwise it throws an exception"

	((parameter isKindOf: WonderlandActor)
		or: 	[ (((((((parameter isKindOf: SequenceableCollection)
				and: [ (parameter size) = 6 ] )
				and: [ ((parameter at: 1) isNumber) or: [ (parameter at: 1) = asIs ] ] )
				and: [ ((parameter at: 2) isNumber) or: [ (parameter at: 2) = asIs ] ] )
				and: [ ((parameter at: 3) isNumber) or: [ (parameter at: 3) = asIs ] ] )
 				and: [ ((parameter at: 4) isNumber) or: [ (parameter at: 4) = asIs ] ] )
 				and: [ ((parameter at: 5) isNumber) or: [ (parameter at: 5) = asIs ] ] )
  				and: [ ((parameter at: 6) isNumber) or: [ (parameter at: 6) = asIs ] ]
  			])
				ifTrue: [ ^ true ]
				ifFalse: [ self error: (parameter asString) , ' is not a valid point of view. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:59'!
VerifyPositiveNumber: parameter
	"If the parameter is a valid number this method returns true, otherwise it throws an exception"

	((parameter isNumber) and: [ parameter > 0 ])
			ifTrue: [ ^ true ]
			ifFalse: [ self error: (parameter asString) , ' is not a number greater than zero. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 15:43'!
VerifyReferenceFrame: parameter
	"If the parameter is a valid WonderlandActor (or subclass) or WonderlandScene this method returns true, otherwise it throws an exception"

	((parameter isKindOf: WonderlandActor) or: [ parameter isKindOf: WonderlandScene])
		ifTrue: [ ^ true ]
		ifFalse: [ self error: (parameter asString) , ' does not have an orientation.' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 13:47'!
VerifyStyle: parameter
	"If the parameter is a valid style (BlockContext that takes 2 parameters) this method returns true, otherwise it throws an exception"

	| result |

	[ result _ ((parameter numArgs) = 2) ]
		ifError: [ :msg :rcvr |
					self error: 'your style was not a block that takes 2 parameters and returns a value between 0 and 1.' ].

	(result) ifTrue: [ ^ true ]
			ifFalse: [ self error: 'your style function did not take exactly 2 parameters. ' ].! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/17/1999 15:41'!
VerifyTarget: parameter
	"If the parameter is a valid target (triple or kind of WonderlandActor) this method returns true, otherwise it throws an exception"

	((parameter isKindOf: WonderlandActor)
		or: 	[ ((((parameter isKindOf: SequenceableCollection)
				and: [ (parameter size) = 3 ] )
				and: [ ((parameter at: 1) isNumber) or: [ (parameter at: 1) = asIs ] ] )
				and: [ ((parameter at: 2) isNumber) or: [ (parameter at: 2) = asIs ] ] )
 				and: [ ((parameter at: 3) isNumber) or: [ (parameter at: 3) = asIs ] ]
  			])
				ifTrue: [ ^ true ]
				ifFalse: [ self error: (parameter asString) , ' is not a valid target. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/29/1999 14:39'!
VerifyTargetOrPixel: parameter
	"If the parameter is a valid target (triple or kind of WonderlandActor) or a pixel coordinate this method returns true, otherwise it throws an exception"

	(((parameter isKindOf: WonderlandActor) or: [ parameter isKindOf: Point ])
		or: 	[ ((((parameter isKindOf: SequenceableCollection)
				and: [ (parameter size) = 3 ] )
				and: [ ((parameter at: 1) isNumber) or: [ (parameter at: 1) = asIs ] ] )
				and: [ ((parameter at: 2) isNumber) or: [ (parameter at: 2) = asIs ] ] )
 				and: [ ((parameter at: 3) isNumber) or: [ (parameter at: 3) = asIs ] ]
  			])
				ifTrue: [ ^ true ]
				ifFalse: [ self error: (parameter asString) , ' is not a valid target. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 15:05'!
VerifyTriple: parameter
	"If the parameter is a valid triple  this method returns true, otherwise it throws an exception"

	(((((parameter isKindOf: SequenceableCollection)
			and: [ (parameter size) = 3 ] )
			and: [ ((parameter at: 1) isNumber) ] )
			and: [ ((parameter at: 2) isNumber) ] )
 			and: [ ((parameter at: 3) isNumber) ] )
 				ifTrue: [ ^ true ]
				ifFalse: [ self error: (parameter asString) , ' is not a collection with 3 numbers. ' ].
! !

!WonderlandVerifier class methodsFor: 'parameter parsing' stamp: 'jsp 3/18/1999 17:05'!
VerifyZeroArgumentBlock: parameter
	"Return true if the parameter is a zero argument block, otherwise throw an exception"

	((parameter class) = BlockContext)
		ifTrue: [ ((parameter numArgs) = 0)
						ifTrue: [ ^ true ]
						ifFalse: [ self error: ' the block can not require arguments.' ]
				]
		ifFalse: [ self error: ' you need to supply a block that does not require arguments.' ].
! !
Morph subclass: #WonderlandWrapperMorph
	instanceVariableNames: 'myWonderland myActor '
	classVariableNames: ''
	poolDictionaries: 'WonderlandConstants '
	category: 'Balloon3D-Wonderland Morphs'!
!WonderlandWrapperMorph commentStamp: '<historical>' prior: 0!
A WonderlandWrapperMorph is temporarily created by Cmd-Clicking on an object in a 3D world. The wrappers map the behavior of morphs into 3D worlds so that 2D interactions result in appropriate changes in the 3D world (e.g., dragging, resizing) and state changes as well (e.g., color).

Wrappers are created as a hierarchical morph list on the object they represent. This is necessary to allow accesses to higher levels in the 3D hierarchy. Note that there are currently several inconsistent behaviors for 3D objects. This is related to the ridiculous attempt of HandMorph to completely understand the interaction hierarchy, e.g., the HandMorph dispatches all events to what it *thinks* the receiver should be. Naturally, this fails completely for 3D worlds where there is no hierarchy of morphs but which may nevertheless use input events.
!


!WonderlandWrapperMorph methodsFor: 'initialization' stamp: 'ar 11/7/1999 19:07'!
createHierarchy
	"Create a wrapper hierarchy representing the owners of the receiver"
	| actor wrapper |
	actor _ myActor getParent.
	actor == myWonderland getScene ifTrue:[^self]. "At top"
	"Create new wrapper"
	wrapper _ self class on: actor.
	wrapper addMorphFront: self.
	"And continue there"
	^wrapper createHierarchy! !

!WonderlandWrapperMorph methodsFor: 'initialization' stamp: 'ar 11/7/1999 19:03'!
setActor: anActor
	myActor _ anActor.
	myWonderland _ anActor getWonderland.
! !


!WonderlandWrapperMorph methodsFor: 'drawing' stamp: 'ar 11/8/1999 13:45'!
drawOn: aCanvas
	| morph |
	morph _ self getCameraMorph.
	morph == nil
		ifTrue:[super drawOn: aCanvas]
		ifFalse:[self computeBounds: morph. "Update bounds from camera"
			false ifTrue:["Show a rectangle for the wrappers"
				aCanvas frameRectangle: bounds color: Color white]]! !

!WonderlandWrapperMorph methodsFor: 'drawing' stamp: 'ar 11/7/1999 19:12'!
fullDrawOn: aCanvas
	super fullDrawOn: aCanvas.
	fullBounds _ nil. "Force recomputation"! !


!WonderlandWrapperMorph methodsFor: 'accessing' stamp: 'ar 11/7/1999 21:36'!
color
	^myActor getColorVector asColor! !

!WonderlandWrapperMorph methodsFor: 'accessing' stamp: 'ar 11/7/1999 21:30'!
color: aColor
	"Change the color of the actor"
	self undoOnTop: UndoColorChange using:[myActor getColor].
	myActor setColorVector: aColor asB3DColor! !

!WonderlandWrapperMorph methodsFor: 'accessing' stamp: 'ar 11/7/1999 19:15'!
getCameraMorph
	| morph |
	morph _ owner.
	[morph == nil] whileFalse:[
		(morph isKindOf: WonderlandCameraMorph) ifTrue:[^morph].
		morph _ morph owner].
	^nil! !

!WonderlandWrapperMorph methodsFor: 'accessing' stamp: 'ar 10/10/2000 22:16'!
hasHalo: aBool
	super hasHalo: aBool.
	aBool ifFalse:[self delete].! !

!WonderlandWrapperMorph methodsFor: 'accessing' stamp: 'ar 11/7/1999 19:30'!
knownName
	^myActor getName! !


!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 10/25/2000 17:52'!
addHandlesTo: aHaloMorph box: box
	| dismissHandle s |
	s _ aHaloMorph handleSize.
	myActor getTexturePointer == nil ifFalse:[
		aHaloMorph addHandleAt: box rightCenter color: Color lightGray on: #mouseDown send: #extractTexture: to: aHaloMorph target].

	aHaloMorph addHandleAt: box topLeft color: Color red icon: 'Halo-Menu'
		on: #mouseDown send: #doMenu:with: to: aHaloMorph.

	aHaloMorph addHandleAt: (box leftCenter + (0 @ (s+2)) min: box leftCenter + box bottomLeft // 2)
		color: Color lightBrown icon: 'Halo-Tile'
		on: #mouseDown send: #yourself "#tearOffTile" to: self.

	dismissHandle _ aHaloMorph addHandleAt: (box topLeft + ((s+2)@0) min: box topLeft + box topCenter // 2)
		color: Color red muchLighter icon: 'Halo-Dismiss'
		on: #mouseDown send: #mouseDownInDimissHandle:with: to: aHaloMorph.
	dismissHandle on: #mouseUp send: #maybeDismiss:with: to: aHaloMorph.
	dismissHandle on: #mouseDown send: #setDismissColor:with: to: aHaloMorph.
	dismissHandle on: #mouseMove send: #setDismissColor:with: to: aHaloMorph.

	aHaloMorph addHandleAt: box leftCenter color: Color cyan icon: 'Halo-View'
		on: #mouseDown send: #yourself "#openViewerForArgument" to: self.

	aHaloMorph addHandleAt: box topCenter color: Color black icon: 'Halo-Grab'
		on: #mouseDown send: #grabFromHalo:with: to: self.

	(aHaloMorph addHandleAt: (box topCenter + ((s+2)@0) min: box topCenter + box topRight // 2)
		color: Color brown icon: 'Halo-Drag'
		on: #mouseDown send: #dragStartFromHalo:with: to: self)
		on: #mouseMove send: #dragMoveFromHalo:with: to: self;
		on: #mouseUp send: #dragEndFromHalo:with: to: self.

	(aHaloMorph addHandleAt: box topRight color: Color green icon: 'Halo-Dup'
		on: #mouseDown send: #dupStartFromHalo:with: to: self)
		on: #mouseMove send: #dupMoveFromHalo:with: to: self;
		on: #mouseUp send: #dupEndFromHalo:with: to: self.

	Preferences showDebugHaloHandle ifTrue:
		[aHaloMorph addHandleAt: ((box topRight + box rightCenter) // 2)
			color: Color blue veryMuchLighter icon: 'Halo-Debug'
			on: #mouseDown send: #doDebug:with: to: aHaloMorph].

	(aHaloMorph addHandleAt: box bottomLeft color: Color blue icon: 'Halo-Rotate'
		on: #mouseDown send: #rotateStartFromHalo:with: to: self)
		on: #mouseMove send: #rotateMoveFromHalo:with: to: self;
		on: #mouseUp send: #rotateEndFromHalo:with: to: self.

	(aHaloMorph addHandleAt: box bottomRight color: Color yellow icon: 'Halo-Scale'
		on: #mouseDown send: #growStartFromHalo:with: to: self)
		on: #mouseMove send: #growMoveFromHalo:with: to: self;
		on: #mouseUp send: #growEndFromHalo:with: to: self.

	myActor isHandmade
		ifTrue: [
			(aHaloMorph addHandleAt: box center color: Color white icon: 'Halo-Paint'
				on: #mouseUp send: #paintMode to: self getCameraMorph)]

! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'sw 12/21/1999 16:36'!
addSimpleHandlesTo: aHaloMorph box: aBox
	self flag: #noteToAndreas. 
		 "May want to reimplement this for wonderland morphs.  For the moment, this basically disallows simple handles in the wonderland case."
	^ aHaloMorph addCircleHandles! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'laza 3/24/2000 16:15'!
balloonHelpTextForHandle: aHandle
	|  itsSelector |
	itsSelector _ aHandle eventHandler firstMouseSelector.
	#(	(rotateStartFromHalo:with:				'Rotate')
		(growStartFromHalo:with:				'Change size') 
		(dupStartFromHalo:with:					'Duplicate')
		(grabFromHalo:with:						'Pick up')
		(dragStartFromHalo:with:				'Move')
		(extractTexture:							'Extract texture')
		(paintMode								'Paint on surface')
	) do:
		[:pair | itsSelector == pair first ifTrue: [^ pair last]].
	^super balloonHelpTextForHandle: aHandle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 10/10/2000 22:14'!
dismissViaHalo
	myActor destroy.
	self delete.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:29'!
dragEndFromHalo: evt with: handle
	self dragPositionOffset: nil.
	self halo endInteraction.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 16:42'!
dragMoveFromHalo: evt with: handle
	| morph delta screenPos scenePos |
	morph _ self getCameraMorph.
	morph == nil ifTrue:[^self].
	delta _ (self pointFromWorld: evt cursorPoint - self dragPositionOffset) - self position.
	screenPos _ (myActor getPositionInPixels: morph getCamera) + delta.
	scenePos _ morph getCamera transformScreenPointToScenePoint: screenPos atDepthOf: myActor.
	myActor moveToRightNow: scenePos asSeenBy: (myWonderland getScene) undoable: false.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:16'!
dragPositionOffset
	^self valueOfProperty: #dragPositionOffset.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:16'!
dragPositionOffset: aPoint
	aPoint == nil
		ifTrue:[self removeProperty: #dragPositionOffset]
		ifFalse:[self setProperty: #dragPositionOffset toValue: aPoint].! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:17'!
dragStartFromHalo: evt with: handle
	self removeAllHandlesBut: handle.
	self dragPositionOffset: handle center - self positionInWorld.
	self undo: UndoPOVChange using: myActor getPointOfView.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/10/1999 15:32'!
dupEndFromHalo: evt with: handle
	^self dragEndFromHalo: evt with: handle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/10/1999 15:16'!
dupMoveFromHalo: evt with: handle
	^self dragMoveFromHalo: evt with: handle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/10/1999 15:16'!
dupStartFromHalo: evt with: handle
	| newActor |
	self removeAllHandlesBut: handle.
	newActor _ myWonderland duplicateActor: myActor.
	myActor _ newActor.
	self dragPositionOffset: handle center - self positionInWorld.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/7/1999 20:34'!
extractTexture: evt
	evt hand attachMorph: myActor getTexturePointer asMorph! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:25'!
grabFromHalo: evt with: handle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:30'!
growEndFromHalo: evt with: handle
	self growPositionOffset: nil.
	self halo endInteraction.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:39'!
growMoveFromHalo: evt with: handle
	| newExtent scale |
	newExtent _ (self pointFromWorld: (evt cursorPoint - self growPositionOffset)) - self topLeft.
	newExtent _ newExtent max: 1@1.
	scale _ newExtent r / bounds extent r.
	evt shiftPressed
		ifTrue:[scale _ B3DVector3 x: scale y: scale z: 1.0]
		ifFalse:[scale _ B3DVector3 x: scale y: scale z: scale].
 	myActor resizeRightNow: scale undoable: false.
	handle position: evt cursorPoint - (handle extent // 2).! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:20'!
growPositionOffset
	^self valueOfProperty: #growPositionOffset.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:20'!
growPositionOffset: aPoint
	aPoint == nil
		ifTrue:[self removeProperty: #growPositionOffset]
		ifFalse:[self setProperty: #growPositionOffset toValue: aPoint].! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:22'!
growStartFromHalo: evt with: handle

	self removeAllHandlesBut: handle.
	self growPositionOffset: evt cursorPoint - (self pointInWorld: self bottomRight).
	self undo: UndoSizeChange using: myActor getSize.! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:17'!
removeAllHandlesBut: aHandle
	| halo |
	halo _ self halo.
	halo == nil ifFalse:[halo removeAllHandlesBut: aHandle].! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:30'!
rotateEndFromHalo: evt with: handle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:30'!
rotateMoveFromHalo: evt with: handle! !

!WonderlandWrapperMorph methodsFor: 'handles' stamp: 'ar 11/8/1999 15:30'!
rotateStartFromHalo: evt with: handle! !


!WonderlandWrapperMorph methodsFor: 'private' stamp: 'ar 11/8/1999 14:10'!
computeBounds: morph
	| box |
	box _ myActor getFullBoundsFor: morph getCamera.
	box == nil ifFalse:[bounds _ box].! !

!WonderlandWrapperMorph methodsFor: 'private' stamp: 'ar 11/8/1999 14:10'!
computeFullBounds: cameraMorph
	self submorphsDo:[:m| m computeFullBounds: cameraMorph].
	self computeBounds: cameraMorph.
	fullBounds _ nil.! !

!WonderlandWrapperMorph methodsFor: 'private' stamp: 'ar 11/8/1999 15:18'!
undo: anUndoClass using: aValue
	"Check if we need to add an undo action."
	myWonderland getUndoStack push: (anUndoClass for: myActor from: aValue).! !

!WonderlandWrapperMorph methodsFor: 'private' stamp: 'ar 11/7/1999 21:29'!
undoOnTop: anUndoClass using: aBlock
	"Check if we need to add an undo action."
	| stack top |
	stack _ myWonderland getUndoStack.
	top _ stack top.
	((top isKindOf: anUndoClass) and:[top getActor == myActor]) ifFalse:[
		stack push: (anUndoClass for: myActor from: aBlock value)].
! !


!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 6/9/2000 19:17'!
addCustomMenuItems: aCustomMenu hand: aHand
	super addCustomMenuItems: aCustomMenu hand: aHand.
	aCustomMenu addLine.
	aCustomMenu addUpdating: #getHQTextureState action: #toggleHQTextureState.
	aCustomMenu addUpdating: #getActiveTextureState action: #toggleActiveTextureState.
	aCustomMenu addUpdating: #getTextureAdjust action: #toggleTextureAdjust.
	aCustomMenu add:'set user point of view' action:#setUserPointOfView.! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 11/7/1999 22:35'!
getActiveTextureState
	(myActor getProperty: #activeTexture) == true
		ifTrue:[^'disable active texture']
		ifFalse:[^'enable active texture']! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 6/9/2000 19:30'!
getHQTextureState
	| tex |
	tex _ myActor getTexturePointer.
	(tex isMorph and:[(tex valueOfProperty: #highQualityTexture) == true])
		ifTrue:[^'disable high quality texture']
		ifFalse:[^'enable high quality texture']! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 11/7/1999 22:38'!
getTextureAdjust
	(myActor getProperty: #adjustToTexture) == true
		ifTrue:[^'do not adjust to texture']
		ifFalse:[^'auto adjust to texture']! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 11/8/1999 13:17'!
setUserPointOfView
	| morph |
	morph _ self getCameraMorph.
	morph == nil ifTrue:[^self].
	myActor setUserPointOfView: (morph getCamera getPointOfView: myActor).! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 11/7/1999 22:35'!
toggleActiveTextureState
	(myActor getProperty: #activeTexture) == true
		ifTrue:[myActor setProperty: #activeTexture toValue: false]
		ifFalse:[myActor setProperty: #activeTexture toValue: true]! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 6/9/2000 19:31'!
toggleHQTextureState
	| tex |
	tex _ myActor getTexturePointer.
	tex isMorph ifFalse:[^self].
	(tex valueOfProperty: #highQualityTexture) == true
		ifTrue:[tex setProperty: #highQualityTexture toValue: false]
		ifFalse:[tex setProperty: #highQualityTexture toValue: true].
	tex changed.! !

!WonderlandWrapperMorph methodsFor: 'menu' stamp: 'ar 11/7/1999 22:36'!
toggleTextureAdjust
	(myActor getProperty: #adjustToTexture) == true
		ifTrue:[myActor setProperty: #adjustToTexture toValue: false]
		ifFalse:[myActor setProperty: #adjustToTexture toValue: true]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WonderlandWrapperMorph class
	instanceVariableNames: ''!

!WonderlandWrapperMorph class methodsFor: 'instance creation' stamp: 'ar 11/7/1999 19:03'!
on: anActor
	^self new setActor: anActor! !
Object subclass: #Word
	instanceVariableNames: 'string syllables '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Speech-TTS'!

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:47'!
accept: anObject
	anObject word: self! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:53'!
events
	| answer |
	answer _ CompositeEvent new.
	self syllables do: [ :each | answer addAll: each events].
	^ answer! !

!Word methodsFor: 'accessing' stamp: 'len 12/13/1999 02:33'!
lastSyllable
	^ self syllables last! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:49'!
string
	^ string! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:49'!
string: aString
	string _ aString! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
syllables
	^ syllables! !

!Word methodsFor: 'accessing' stamp: 'len 12/8/1999 17:48'!
syllables: aCollection
	syllables _ aCollection! !


!Word methodsFor: 'enumerating' stamp: 'len 12/13/1999 01:20'!
eventsDo: aBlock
	self syllables do: [ :syllable | syllable eventsDo: aBlock]! !


!Word methodsFor: 'testing' stamp: 'len 12/11/1999 13:11'!
isAccented
	^ (self syllables detect: [ :one | one isAccented] ifNone: []) notNil! !

!Word methodsFor: 'testing' stamp: 'len 12/8/1999 18:47'!
isPolysyllabic
	^ self syllables size > 1! !


!Word methodsFor: 'printing' stamp: 'len 12/13/1999 03:18'!
printOn: aStream
	aStream nextPutAll: (self isAccented ifTrue: [self string asUppercase] ifFalse: [self string])! !
ArrayedCollection variableWordSubclass: #WordArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
!WordArray commentStamp: '<historical>' prior: 0!
WordArrays store 32-bit unsigned Integer values.
!


!WordArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'!
asWordArray
	^self! !


!WordArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'!
atAllPut: value
	"Fill the receiver with the given value"

	<primitive: 145>
	super atAllPut: value! !

!WordArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'!
bytesPerElement
	"Number of bytes in each item.  This multiplied by (self size)*8 gives the number of bits stored."
	^ 4! !

!WordArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'!
defaultElement
	"Return the default element of the receiver"
	^0! !


!WordArray methodsFor: 'private' stamp: 'ar 2/15/1999 00:51'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	<primitive: 105>
	^super replaceFrom: start to: stop with: replacement startingAt: repStart ! !


!WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/24/2000 22:34'!
restoreEndianness
	"This word object was just read in from a stream.  It was stored in Big Endian (Mac) format.  Reverse the byte order if the current machine is Little Endian."

	Smalltalk endianness == #little 
		ifTrue: [
			self swapBytesFrom: 1 to: self size]
! !

!WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/22/2000 12:04'!
swapBytesFrom: start to: stop
	"Perform a bigEndian/littleEndian byte reversal of my words"
	| hack blt |
	"The implementation is a hack, but fast for large ranges"
	hack _ Form new hackBits: self.
	blt _ (BitBlt toForm: hack) sourceForm: hack.
	blt combinationRule: Form reverse.  "XOR"
	blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
	blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
	blt sourceX: 3; destX: 0; copyBits.
	blt sourceX: 0; destX: 3; copyBits.
	blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
	blt sourceX: 2; destX: 1; copyBits.
	blt sourceX: 1; destX: 2; copyBits.
! !

!WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/25/2000 18:16'!
writeOn: aStream 
	| reversed convertToBytes |
	"Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed).  Always store in Big Endian (Mac) byte order.  Do the writing at BitBlt speeds."

	convertToBytes _ aStream originalContents "collection" class isBytes.
	(aStream isKindOf: FileStream) ifTrue: [convertToBytes _ false].	"knows how"
	Smalltalk endianness == #big 
		ifTrue: ["no change"
			aStream nextInt32Put: self size.
			convertToBytes ifTrue: [self do: [:vv | aStream nextNumber: 4 put: vv]]
					"Later define (aStream nextPutWordsAll:) that uses BitBlt to 
					 put words on a byteStream quickly" 
				ifFalse: [aStream nextPutAll: self]]
		ifFalse: [
			reversed _ self clone.
			reversed swapBytesFrom: 1 to: reversed size.
			aStream nextInt32Put: reversed size.
			convertToBytes ifTrue: [reversed do: [:vv | aStream nextNumber: 4 put: vv]]
				ifFalse: [aStream nextPutAll: reversed]]
! !

!WordArray methodsFor: 'fileIn/Out' stamp: 'RAA 6/23/2000 08:22'!
writeOnGZIPByteStream: aStream 
	
	aStream nextPutAllWordArray: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WordArray class
	instanceVariableNames: ''!

!WordArray class methodsFor: 'as yet unclassified' stamp: 'ar 12/23/1999 14:34'!
newFromStream: s
	| len |
	s next = 16r80 ifTrue:
		["A compressed format.  Could copy what BitMap does, or use a 
		special sound compression format.  Callers normally compress their own way."
		^ self error: 'not implemented'].
	s skip: -1.
	len _ s nextInt32.
	^ s nextWordsInto: (self new: len)! !


!WordArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:19'!
ccg: cg emitLoadFor: aString from: anInteger on: aStream

	cg emitLoad: aString asIntPtrFrom: anInteger on: aStream! !

!WordArray class methodsFor: 'plugin generation' stamp: 'acg 9/20/1999 13:16'!
ccg: cg prolog: aBlock expr: aString index: anInteger

	^cg 
		ccgLoad: aBlock 
		expr: aString 
		asUnsignedPtrFrom: anInteger
		andThen: (cg ccgValBlock: 'isWords')! !

!WordArray class methodsFor: 'plugin generation' stamp: 'acg 9/17/1999 01:19'!
ccgDeclareCForVar: aSymbolOrString

	^'unsigned *', aSymbolOrString! !
WordArray variableWordSubclass: #WordArrayForSegment
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'!
restoreEndianness
	"This word object was just read in from a stream.  Do not correct the Endianness because the load primitive will reverse bytes as needed."

	"^ self"
! !

!WordArrayForSegment methodsFor: 'as yet unclassified' stamp: 'tk 1/24/2000 23:22'!
writeOn: aByteStream
	"Write quickly and disregard the endianness of the words.  Store the array of bits onto the argument, aStream.  (leading byte ~= 16r80) identifies this as raw bits (uncompressed)."

	aByteStream nextInt32Put: self size.	"4 bytes"
	aByteStream nextPutAll: self
! !
BorderedMorph subclass: #WordGameLetterMorph
	instanceVariableNames: 'letter originalLetter idString linkedLetters predecessor successor indexInQuote lineMorph letterMorph style '
	classVariableNames: 'IDFont IDHeight LetterFont LetterHeight '
	poolDictionaries: ''
	category: 'Morphic-Games'!
!WordGameLetterMorph commentStamp: '<historical>' prior: 0!
WordGameLetterMorph implements letter boxes for type-in and display of letter in word games.  Several variant displays are supported, depending on the setting of style, and blanks can be displayed as black boxes or empty letter boxes.

Default support for type-in is distributed between this class and WordGamePaneMorph

letter			the Character stored in this morph.
				Can be either blank or nil as well as a letter.
indexInQuote	a retained copy of the index of this character
				Facilitates responses to, eg, clicking or typing in this box.
				If indexInQuote==nil, then this is displayed as a black box
predecessor		another LetterMorph or nil
				Used for linked typing and, eg, word selection
successor		another LetterMorph or nil
				Used for linked typing and, eg, word selection
style			a Symbol, one of #(plain boxed underlined)
				Boxed and underlined display further depends on whether
				the id strings are nil or not.
				Each format has an associated default size

The following two variables are also submorphs, as are the id strings if present.
letterMorph		a StringMorph for displaying the letter
				Used when changing the letter to be displayed
lineMorph		a PolygonMorph used to display the underline
				and also to place the id string in underlined format!


!WordGameLetterMorph methodsFor: 'initialization' stamp: 'di 5/11/2000 07:33'!
id2: idString
	"Add further clue id for acrostic puzzles."

	| idMorph |
	idString ifNotNil:
		[idMorph _ StringMorph contents: idString font: IDFont.
		idMorph align: idMorph bounds topRight with: self bounds topRight + (-1@-1).
		self addMorph: idMorph].

! !

!WordGameLetterMorph methodsFor: 'initialization' stamp: 'di 5/11/2000 22:03'!
indexInQuote: qi id1: idString
	"Initialize me with the given index and an optional idString"

	| idMorph y |
	style = #boxed
		ifTrue: [idString == nil
				ifTrue: [self extent: 18@16; borderWidth: 1]
				ifFalse: [self extent: 26@24; borderWidth: 1]]
		ifFalse: [idString == nil
				ifTrue: [self extent: 18@16; borderWidth: 0]
				ifFalse: [self extent: 18@26; borderWidth: 0]].
	qi ifNil: [^ self color: Color gray].  "blank"
	self color: self normalColor.
	indexInQuote _ qi.
	style == #underlined
	ifTrue:
		[y _ self bottom - 2.
		idString ifNotNil: [y _ y - IDFont ascent + 2].
		lineMorph _ PolygonMorph
				vertices: {self left+2@y. self right-3@y}
				color: Color gray borderWidth: 1 borderColor: Color gray.
		self addMorph: lineMorph.
		idString ifNil: [^ self].
		idMorph _ StringMorph contents: idString font: IDFont.
		idMorph align: idMorph bounds bottomCenter
				with: self bounds bottomCenter + (0@(IDFont descent-1)).
		self addMorphBack: idMorph]
	ifFalse:
		[idString ifNil: [^ self].
		idMorph _ StringMorph contents: idString font: IDFont.
		idMorph align: idMorph bounds topLeft with: self bounds topLeft + (2@-1).
		self addMorph: idMorph]
"
World addMorph: (WordGameLetterMorph new boxed indexInQuote: 123 id1: '123';
							id2: 'H'; setLetter: $W).
World addMorph: (WordGameLetterMorph new underlined indexInQuote: 123 id1: '123';
							setLetter: $W).
World addMorph: (WordGameLetterMorph new underlined indexInQuote: 123 id1: nil;
							setLetter: $W).
"

! !

!WordGameLetterMorph methodsFor: 'initialization' stamp: 'di 5/8/2000 11:22'!
normalColor

	^ Color r: 1.0 g: 0.8 b: 0.2
! !

!WordGameLetterMorph methodsFor: 'initialization' stamp: 'di 5/7/2000 23:58'!
setLetter: aLetter

	^ self setLetter: aLetter color: Color black
! !

!WordGameLetterMorph methodsFor: 'initialization' stamp: 'di 5/11/2000 09:34'!
setLetter: aLetter color: aColor

	letterMorph ifNotNil: [letterMorph delete].
	letter _ aLetter.
	letter ifNil: [^ letterMorph _ nil].
	letterMorph _ StringMorph contents: aLetter asString font: LetterFont.
	letterMorph color: aColor.
	style == #boxed
		ifTrue:
		[letterMorph align: letterMorph bounds bottomCenter
					with: self bounds bottomCenter + (0@(LetterFont descent-2))]
		ifFalse:
		[lineMorph == nil
		ifTrue: [letterMorph align: letterMorph bounds bottomCenter
						with: self bounds bottomCenter + (0@(LetterFont descent-4))]
		ifFalse: [letterMorph align: letterMorph bounds bottomCenter
						with: self center x@(lineMorph top + LetterFont descent)]].
	self addMorphBack: letterMorph.

! !


!WordGameLetterMorph methodsFor: 'style inits' stamp: 'di 5/7/2000 17:00'!
boxed

	style _ #boxed! !

!WordGameLetterMorph methodsFor: 'style inits' stamp: 'di 5/7/2000 17:00'!
plain

	style _ #plain! !

!WordGameLetterMorph methodsFor: 'style inits' stamp: 'di 5/7/2000 17:01'!
underlined

	style _ #underlined! !


!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:42'!
indexInQuote

	^ indexInQuote! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:52'!
isBlank

	^ indexInQuote == nil! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 23:31'!
letter

	^ letter! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:43'!
predecessor

	^ predecessor! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:25'!
predecessor: pred

	predecessor _ pred
! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:43'!
successor

	^ successor! !

!WordGameLetterMorph methodsFor: 'accessing' stamp: 'di 5/7/2000 13:25'!
successor: succ

	successor _ succ
! !


!WordGameLetterMorph methodsFor: 'typing' stamp: 'di 10/14/2000 22:36'!
handlesKeyboard: evt
	^ true! !

!WordGameLetterMorph methodsFor: 'typing' stamp: 'di 5/9/2000 16:20'!
keyboardFocusChange: boolean

	| panel |
	boolean ifFalse:
		[panel _ self nearestOwnerThat: [:m | m respondsTo: #checkForLostFocus].
		panel ifNotNil: [panel checkForLostFocus]]! !

!WordGameLetterMorph methodsFor: 'typing' stamp: 'di 5/8/2000 11:21'!
unhighlight

	(self isBlank or: [self color = self normalColor])
		ifFalse: [self color: self normalColor]! !


!WordGameLetterMorph methodsFor: 'linking' stamp: 'di 5/7/2000 13:50'!
morphsInWordDo: aBlock

	aBlock value: self.
	(successor == nil or: [successor isBlank]) ifTrue: [^ self].
	successor morphsInWordDo: aBlock! !

!WordGameLetterMorph methodsFor: 'linking' stamp: 'di 5/7/2000 14:06'!
nextTypeableLetter

	successor ifNil: [^ self].
	successor isBlank ifTrue: [^ successor nextTypeableLetter].
	^ successor! !

!WordGameLetterMorph methodsFor: 'linking' stamp: 'di 5/7/2000 14:19'!
previousTypeableLetter

	predecessor ifNil: [^ self].
	predecessor isBlank ifTrue: [^ predecessor previousTypeableLetter].
	^ predecessor! !

!WordGameLetterMorph methodsFor: 'linking' stamp: 'di 5/7/2000 13:48'!
startOfWord

	(predecessor == nil or: [predecessor isBlank]) ifTrue: [^ self].
	^ predecessor startOfWord! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WordGameLetterMorph class
	instanceVariableNames: ''!

!WordGameLetterMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/10/2000 07:42'!
includeInNewMorphMenu

	^ false! !

!WordGameLetterMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/11/2000 07:15'!
initialize  "WordGameLetterMorph initialize"

	IDFont _ StrikeFont familyName: 'ComicPlain' size: 13.
	IDHeight _ IDFont height.
	LetterFont _ StrikeFont familyName: 'ComicBold' size: 19.
	LetterHeight _ LetterFont height.

! !
BorderedMorph subclass: #WordGamePanelMorph
	instanceVariableNames: 'letterMorphs haveTypedHere '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Games'!
!WordGamePanelMorph commentStamp: '<historical>' prior: 0!
WordGamePanelMorph provides some default support for clicking and typing in a panel with letterMorphs.

letterMorphs		a collection of LetterMorphs
					Useful in referring specifically to active letterMorphs
					when submorphs may contain other morphs

haveTypedHere		a Boolean used to determine how backspace should be handled!


!WordGamePanelMorph methodsFor: 'access' stamp: 'di 5/9/2000 22:27'!
letterMorphs

	^ letterMorphs! !


!WordGamePanelMorph methodsFor: 'menu' stamp: 'di 5/9/2000 21:53'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
	"Include our modest command set in the ctrl-menu"

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	self addMenuItemsTo: aCustomMenu hand: aHandMorph! !

!WordGamePanelMorph methodsFor: 'menu' stamp: 'di 5/9/2000 22:07'!
addMenuItemsTo: aCustomMenu hand: aHandMorph
	"override with actual menu items"! !


!WordGamePanelMorph methodsFor: 'events' stamp: 'di 5/10/2000 08:45'!
checkForLostFocus
	"Determine if the user has clicked outside this panel"

	self activeHand ifNil: [^ self].
	(self containsPoint: self activeHand position) ifFalse: [self lostFocus]! !

!WordGamePanelMorph methodsFor: 'events' stamp: 'di 5/11/2000 22:38'!
handlesMouseDown: event
	"Absorb mouseDown so stray clicks will not pick up the panel"

	^ true! !

!WordGamePanelMorph methodsFor: 'events' stamp: 'di 5/10/2000 09:46'!
keyStrokeEvent: evt letterMorph: morph
	"Handle typing.  Calls keyCharacter:atIndex:nextFocus: for further behavior."

	| affectedMorph keyCharacter nextFocus |
	evt keyCharacter = Character backspace
		ifTrue: ["<delete> zaps the current selection if there has been no typing,
				but it zaps the previous selection if there has been prior typing."
				haveTypedHere
					ifTrue: [affectedMorph _ morph previousTypeableLetter]
					ifFalse: [affectedMorph _ morph].
				keyCharacter _ Character space.
				nextFocus _ morph previousTypeableLetter]
		ifFalse: [affectedMorph _ morph.
				keyCharacter _ evt keyCharacter asUppercase.
				(keyCharacter isLetter or: [keyCharacter = Character space])
					ifFalse: [^ self].
				haveTypedHere _ true.
				nextFocus _ morph nextTypeableLetter.
				nextFocus == morph ifTrue:
					["If hit end of a word, change backspace mode"
					haveTypedHere _ false]].
	evt hand newKeyboardFocus: nextFocus.
	self unhighlight.
	nextFocus color: Color green.

	self keyCharacter: keyCharacter atIndex: affectedMorph indexInQuote nextFocus: nextFocus

! !

!WordGamePanelMorph methodsFor: 'events' stamp: 'di 5/10/2000 09:30'!
mouseDownEvent: evt letterMorph: morph

	haveTypedHere _ false.
	evt hand newKeyboardFocus: morph.
	self highlight: morph! !


!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/12/2000 00:28'!
clearTyping
	"Clear out all letters entered as a solution."

	letterMorphs do: [:m | (m letter notNil and: [m letter isLetter])
							ifTrue: [m setLetter: Character space]].
	self unhighlight.
! !

!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/10/2000 09:31'!
highlight: morph

	self unhighlight.
	morph color: Color green! !

!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/12/2000 00:53'!
isClean
	"Return true only if all cells are blank."

	letterMorphs do:
		[:m | (m letter notNil and: [m letter ~= $ ]) ifTrue: [^ false]].
	^ true
! !

!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/10/2000 08:37'!
keyCharacter: keyCharacter atIndex: indexOfAffectedMorph nextFocus: nextFocus

	"Override with actual response"
! !

!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/10/2000 08:44'!
lostFocus

	self unhighlight! !

!WordGamePanelMorph methodsFor: 'defaults' stamp: 'di 5/12/2000 09:54'!
unhighlight

	letterMorphs do: [:m | m ifNotNil: [m unhighlight]]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WordGamePanelMorph class
	instanceVariableNames: ''!

!WordGamePanelMorph class methodsFor: 'as yet unclassified' stamp: 'di 5/10/2000 07:41'!
includeInNewMorphMenu

	^ false! !
Object subclass: #WordNet
	instanceVariableNames: 'form url args word replyHTML parts partStreams rwStream replyParsed '
	classVariableNames: 'CanTranslateFrom Languages '
	poolDictionaries: ''
	category: 'Network-TelNet WordNet'!
!WordNet commentStamp: '<historical>' prior: 0!
Query the WordNet lexicon at Princeton Univ.  At http://www.cogsci.princeton.edu/cgi-bin/webwn/   To get the definition of a word, select any word in any text pane, and choose "definition of word" from the shift menu.  WordNet is also used for the "verify spelling of word" menu item.
	Subclasses are interfaces to other dictionaries.  The "choose language" item on the shift-menu lets you select a language (and its server).  (Preferences setPreference: #myLanguage toValue: #Portuguese).

WordNet openScamperOn: 'balloon'.


DD _ WordNet new.
DD definition: 'balloon'.
DD parts "of speech".
	 OrderedCollection ('noun' 'verb' )
DD sensesFor: 'noun'.
	 2
DD def: 1 for: 'noun'.
	 '(large tough non-rigid bag filled with gas or hot air)'
After the initial response, keep a separate stream for the definition of each part of speech.  Caller may later query them for information.
!


!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/18/1999 15:41'!
def: nth for: partOfSpeech

	| ii strm |
	parts ifNil: [self parts].
	(ii _ parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
	strm _ partStreams at: ii.
	strm reset.
	1 to: nth do: [:nn | 
		strm match: '<BR>',(String with: Character lf),nn printString, '.  '.
		strm match: ' -- '].
	^ strm upToAll: '<BR>'! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/19/2000 08:36'!
definition: theWord
	"look this word up in the basic way.  Return nil if there is trouble accessing the web site."
	| doc |
	word _ theWord.
	Cursor wait showWhile: [
		doc _ HTTPSocket 
			httpGetDocument: 'http://www.cogsci.princeton.edu/cgi-bin/webwn/' 
			args: 'stage=1&word=', word].
	replyHTML _ (doc isKindOf: MIMEDocument)
		ifTrue:
			[doc content]
		ifFalse:
			[nil].
	"self parseReply."

	^ replyHTML! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/18/1999 15:41'!
partOfSpeech

	rwStream ifNil: [self stream].
	rwStream reset.
	rwStream match: '<BR>The <B>'.
	^ rwStream upToAll: '</B>'! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/18/1999 15:41'!
partOfSpeechIn: aStrm

	aStrm reset.
	aStrm match: '<BR>The <B>'.
	^ aStrm upToAll: '</B>'! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 6/30/2000 11:36'!
parts
	"return the parts of speech this word can be.  Keep the streams for each"
	parts _ OrderedCollection new.
	partStreams _ OrderedCollection new.
	rwStream ifNil: [self stream].
	rwStream reset.
	rwStream match: '<HR>'.
	[rwStream atEnd] whileFalse: [
		partStreams add: (ReadStream on: (rwStream upToAll: '<HR>'))].
	partStreams do: [:pp |
		parts add: (self partOfSpeechIn: pp)].
	parts size = 0 ifTrue: [^ parts].
	parts last = '' ifTrue: [parts removeLast.  partStreams removeLast].
	^ parts ! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/18/1999 15:43'!
senses

	| ww |
	ww _ '"', word, '"'.
	rwStream ifNil: [self stream].
	rwStream reset.
	rwStream match: ww.
	rwStream match: ww.
	rwStream match: ' has '.
	^ (rwStream upTo: Character lf) asNumber! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/18/1999 15:44'!
sensesFor: partOfSpeech

	| ii strm |
	parts ifNil: [self parts].
	(ii _ parts indexOf: partOfSpeech) = 0 ifTrue: [^ nil].
	strm _ partStreams at: ii.
	strm reset.
	strm match: '"', word, '"'.
	strm match: ' has '.
	^ (strm upTo: Character lf) asNumber! !

!WordNet methodsFor: 'as yet unclassified' stamp: 'tk 7/16/1999 19:00'!
stream

	rwStream _  RWBinaryOrTextStream on: (String new: 1000).
	rwStream nextPutAll: replyHTML; reset.
	^ rwStream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WordNet class
	instanceVariableNames: ''!

!WordNet class methodsFor: 'as yet unclassified' stamp: 'tk 7/19/2000 14:33'!
canTranslateFrom

	Languages ifNil: [Languages _ #(English Portuguese).
		CanTranslateFrom _ #(French German Spanish English Portuguese 
			Italian Norwegian)].		"see www.freetranslation.com/"
	^ CanTranslateFrom ! !

!WordNet class methodsFor: 'as yet unclassified' stamp: 'sw 9/2/1999 15:38'!
definitionsFor: aWord
	| aDef parts item |
	aDef _ self new.
	(aDef definition: aWord) ifNil:
		[self inform: 'Sorry, cannot reach the WordNet
web site; task abandoned.'.
		^ nil].
	parts _ aDef parts.
	parts size = 0 ifTrue:
		[self inform: 'Sorry, ', aWord, ' not found.'.
		^ nil].

	^ String streamContents:
		[:defStream |
			defStream nextPutAll: aWord; cr.
			parts do:
				[:aPart |
					defStream cr.
					1 to: (aDef sensesFor: aPart) do:
						[:senseNumber |
							defStream nextPutAll: aPart.
							item _ aDef def: senseNumber for: aPart.
							defStream nextPutAll: (' (', senseNumber printString, ') ', (item copyFrom: 2 to: item size - 1)).
							defStream cr]]]

"WordNet definitionsFor: 'balloon'"
! !

!WordNet class methodsFor: 'as yet unclassified' stamp: 'tk 8/17/2000 15:06'!
languagePrefs
	| ch ll |
	"Set preference of which natural language is primary. Look up definitions in it, and correct spelling in it.  Also, let user set languages to translate from and to."

	self canTranslateFrom.		"sets defaults"
	ch _ PopUpMenu withCaption: 'Choose the natural language to use for:'
			chooseFrom: 'word definition and spelling verification (', 
					(Preferences valueOfFlag: #myLanguage) asString ,')...\',
				'language to translate from (',
					(Preferences valueOfFlag: #languageTranslateFrom) asString ,')...\',
				'language to translate to (',
					(Preferences valueOfFlag: #languageTranslateTo) asString ,')...\'.
	ch = 1 ifTrue: [
		ll _ PopUpMenu withCaption: 'The language for word definitions and spelling verification:'
			chooseFrom: Languages.
		ll > 0 ifTrue: [
			^ Preferences setPreference: #myLanguage toValue: (Languages at: ll) asSymbol]].
	ch = 2 ifTrue: [
		ll _ PopUpMenu withCaption: 'The language to translate from:'
			chooseFrom: CanTranslateFrom.
		ll > 0 ifTrue: [
			^ Preferences setPreference: #languageTranslateFrom 
				toValue: (CanTranslateFrom at: ll) asSymbol]].
	ch = 3 ifTrue: [
		ll _ PopUpMenu withCaption: 'The language to translate to'
			chooseFrom: CanTranslateFrom.
		ll > 0 ifTrue: [
			^ Preferences setPreference: #languageTranslateTo 
				toValue: (CanTranslateFrom at: ll) asSymbol]].

"Maybe let the user add another language when he knows ther server can take it."
"	ch _ (PopUpMenu labelArray: Languages, {'other...'.
			'Choose language to translate from...'})
		startUpWithCaption: 'Choose the language of dictionary for word definitions.'.
	ch = 0 ifTrue: [^ Preferences valueOfFlag: #myLanguage].
	(ch <= Languages size) ifTrue: [ll _ Languages at: ch].
	ch = (Languages size + 1) ifTrue: [
		ll _ FillInTheBlank request: 'Name of the primary language'].
	ll ifNotNil: [^ Preferences setPreference: #myLanguage toValue: ll asSymbol].
"! !

!WordNet class methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 13:57'!
lexiconServer
	| nl |
	"Look in Preferences to see what language the user wants, and what class knows about it."

	nl _ Preferences valueOfFlag: #myLanguage.
	nl == false ifTrue: [^ self].			"English, WordNet server"
	nl == #English ifTrue: [^ self].		"English, WordNet server"
	nl == #Portuguese ifTrue: [^ PortugueseLexiconServer].	"www.priberam.pt"

"	nl == #Deutsch ifTrue: [^ DeutschServerClass]. "	"class that knows about a server"

	self inform: 'Sorry, no known online dictionary in that language.'.
	^ self languagePrefs! !

!WordNet class methodsFor: 'as yet unclassified' stamp: 'tk 7/9/2000 22:05'!
openScamperOn: aWord
	| aUrl scamperWindow |
	"Open a Scamper web browser on the WordNet entry for this word.  If Scamper is already pointing at WordNet, use the same browser."

	aUrl _ 'http://www.cogsci.princeton.edu/cgi-bin/webwn/', 
		'?stage=1&word=', aWord.
	scamperWindow _ Scamper newOrExistingOn: aUrl.
	scamperWindow model jumpToUrl: aUrl asUrl.
	scamperWindow activate.
! !

!WordNet class methodsFor: 'as yet unclassified' stamp: 'tk 7/12/2000 13:58'!
verify: aWord
	"See if this spelling is in the WordNet lexicon.  Return a string of success, no-such-word, or can't reach the server."
	| aDef nl |
	
	aDef _ self new.
	(aDef definition: aWord) ifNil:
		[^ 'Sorry, cannot reach that web site.  Task abandoned.
(Make sure you have an internet connection.)'].
	nl _ Preferences valueOfFlag: #myLanguage.
	nl == false ifTrue: [nl _ #English].

	(aDef parts) size = 0 
		ifTrue: [^ 'Sorry, ', aWord, ' not found. (', nl, ' lexicon)']
		ifFalse: [^ aWord, ' is spelled correctly.'].

! !
StringHolder subclass: #Workspace
	instanceVariableNames: 'bindings acceptDroppedMorphs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-ST80 Remnants'!

!Workspace methodsFor: 'binding'!
bindingOf: aString
	bindings isNil
		ifTrue: [bindings _ Dictionary new].
	(bindings includesKey: aString)
		ifFalse: [bindings at: aString put: nil].
	^bindings associationAt: aString! !


!Workspace methodsFor: 'accessing' stamp: 'jsp 3/23/1999 12:19'!
setBindings: aDictionary
	"Sets the Workspace to use the specified dictionary as its namespace"

	bindings _ aDictionary.
! !


!Workspace methodsFor: 'as yet unclassified' stamp: 'jcg 7/8/2000 00:13'!
addModelItemsToWindowMenu: aMenu
	aMenu addLine.
	aMenu add: 'save contents to file...' target: self action: #saveContentsInFile.
	
	self acceptsDroppingMorphForReference 
		ifTrue: [aMenu 
					add: 'cease accepting dropping morph for reference' 
					target: self 
					action: #toggleDroppingMorphForReference] 
		ifFalse: [aMenu 
					add: 'start accepting dropping morph for reference' 
					target: self 
					action: #toggleDroppingMorphForReference] ! !

!Workspace methodsFor: 'as yet unclassified' stamp: 'dew 3/9/2000 00:13'!
saveContentsInFile
	"A bit of a hack to pass along this message to the controller or morph.  (Possibly this Workspace menu item could be deleted, since it's now in the text menu.)"
	| textMorph textView |

	textMorph _ self dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil].
	textMorph notNil ifTrue: [^ textMorph saveContentsInFile].

	textView _ self dependents detect: [:dep | dep isKindOf: PluggableTextView] ifNone: [nil].
	textView notNil ifTrue: [^ textView controller saveContentsInFile].
! !


!Workspace methodsFor: 'initialize-release' stamp: 'sma 11/11/2000 16:33'!
initialize

	super initialize.
	acceptDroppedMorphs _ false! !


!Workspace methodsFor: 'drag and drop' stamp: 'jcg 11/5/2000 22:28'!
acceptDroppingMorph: dropee event: evt inMorph: targetMorph 
	"Return the dropee to its old position, and add a reference to it at the cursor point."
	| bindingName |

	bindingName _  dropee externalName translateToLowercase, dropee identityHash printString..
	targetMorph correctSelectionWithString: bindingName, ' '.
	(self bindingOf: bindingName) value: dropee.
	dropee rejectDropMorphEvent: evt.
	^ true "success"
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/8/2000 00:10'!
acceptsDroppingMorphForReference

	^ acceptDroppedMorphs
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/8/2000 00:09'!
acceptsDroppingMorphForReference: trueFalse

	acceptDroppedMorphs _ trueFalse
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/8/2000 00:11'!
toggleDroppingMorphForReference

	acceptDroppedMorphs _ acceptDroppedMorphs not.
		
! !

!Workspace methodsFor: 'drag and drop' stamp: 'jcg 7/7/2000 11:16'!
wantsDroppedMorph: dropee event: evt inMorph: target

	^ acceptDroppedMorphs
		
! !


!Workspace methodsFor: 'object fileIn' stamp: 'RAA 12/20/2000 17:50'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	acceptDroppedMorphs ifNil: [acceptDroppedMorphs _ false].
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !
Object subclass: #WorldState
	instanceVariableNames: 'hands activeHand viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime remoteServer multiCanvas '
	classVariableNames: 'CanSurrenderToOS DeferredUIMessages DisableDeferredUpdates LastCycleTime MinCycleLapse '
	poolDictionaries: ''
	category: 'Morphic-Worlds'!

!WorldState methodsFor: 'initialization' stamp: 'RAA 1/5/2001 10:47'!
initialize

	hands _ Array new.
	damageRecorder_ DamageRecorder new.
	stepList _ Heap sortBlock: self stepListSortBlock.
	lastStepTime _ 0.
	lastAlarmTime _ 0.! !

!WorldState methodsFor: 'initialization' stamp: 'sw 9/5/2000 06:39'!
stepListSize
	^ stepList size! !

!WorldState methodsFor: 'initialization' stamp: 'RAA 1/7/2001 12:33'!
stepListSortBlock

	| answer |

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."

	^[ :stepMsg1 :stepMsg2 | 
		answer _ stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
		stepMsg1 _ stepMsg2 _ nil.
		answer
	]! !

!WorldState methodsFor: 'initialization' stamp: 'ar 10/22/2000 16:04'!
stepListSummary
	^ String streamContents:
		[:aStream |
			aStream nextPutAll: stepList size printString, ' items in steplist:'.
			stepList do:
				[:anElement | aStream nextPutAll: anElement receiver printString]]

"Transcript cr show: self currentWorld stepListSummary"! !


!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'!
checkIfUpdateNeeded

	damageRecorder updateIsNeeded ifTrue: [^true].
	hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]].
	^false  "display is already up-to-date"
! !

!WorldState methodsFor: 'update cycle' stamp: 'di 12/9/2000 10:58'!
displayWorld: aWorld submorphs: submorphs
	"Update this world's display."

	| deferredUpdateMode worldDamageRects handsToDraw handDamageRects allDamage |

	submorphs do: [:m | m fullBounds].  "force re-layout if needed"
	self checkIfUpdateNeeded ifFalse: [^ self].  "display is already up-to-date"

	deferredUpdateMode _ self doDeferredUpdatingFor: aWorld.
	deferredUpdateMode ifFalse: [self assuredCanvas].

	worldDamageRects _ self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas.  "repair world's damage on canvas"
	"self handsDo:[:h| h noticeDamageRects: worldDamageRects]."
	handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects.
	handDamageRects _ handsToDraw collect: [:h | h savePatchFrom: canvas].
	allDamage _ worldDamageRects, handDamageRects.

	handsToDraw reverseDo: [:h | canvas fullDrawMorph: h].  "draw hands onto world canvas"

	"*make this true to flash damaged areas for testing*"
	Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].

	canvas finish.
	"quickly copy altered rects of canvas to Display:"
	deferredUpdateMode
		ifTrue: [self forceDamageToScreen: allDamage]
		ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage].
	handsToDraw do: [:h | h restoreSavedPatchOn: canvas].  "restore world canvas under hands"
	Display deferUpdates: false; forceDisplayUpdate.
! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 6/6/2000 17:30'!
displayWorldAsTwoTone: aWorld submorphs: submorphs color: color
	"Display the world in living black-and-white. (This is typically done to save space.)"

	| f |
	f _ ColorForm extent: aWorld viewBox extent depth: 1.
	f colors: (Array with: color dominantColor with: Color black).
	self canvas: f getCanvas.

	"force the entire canvas to be redrawn"
	aWorld fullRepaintNeeded.
	self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas.  "redraw on offscreen canvas"
	canvas showAt: aWorld viewBox origin.  "copy redrawn areas to Display"
	Display forceDisplayUpdate.
	self canvas: nil.  "forget my canvas to save space"
! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 12:16'!
displayWorldSafely: aWorld
	"Update this world's display and keep track of errors during draw methods."

	| oldHandler errCtx errMorph |

	oldHandler _ Processor activeProcess errorHandler.
	[aWorld displayWorld] ifError: [:err :rcvr |
		"Handle a drawing error"
		errCtx _ thisContext.
		[
			errCtx _ errCtx sender.
			"Search the sender chain to find the morph causing the problem"
			[errCtx notNil and:[(errCtx receiver isKindOf: Morph) not]] 
				whileTrue:[errCtx _ errCtx sender].
			"If we're at the root of the context chain then we have a fatal drawing problem"
			errCtx == nil ifTrue:[^self handleFatalDrawingError: err].
			errMorph _ errCtx receiver.
			"If the morph causing the problem has already the #drawError flag set,
			then search for the next morph above in the caller chain."
			errMorph hasProperty: #errorOnDraw
		] whileTrue.
		errMorph setProperty: #errorOnDraw toValue: true.
		"Install the old error handler, so we can re-raise the error"
		Processor activeProcess errorHandler: oldHandler.
		rcvr error: err.
	].! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 10/26/2000 14:12'!
doDeferredUpdatingFor: aWorld
        "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."
	| properDisplay |
	PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
	(Display deferUpdates: true) ifNil: [^ false].  "deferred updates not supported"
	remoteServer ifNotNil:[
		self assuredCanvas.
		^true].
	properDisplay _ canvas notNil and: [canvas form == Display].
	aWorld == World ifTrue: [  "this world fills the entire Display"
		properDisplay ifFalse: [
			aWorld viewBox: Display boundingBox.    "do first since it may clear canvas"
			self canvas: (Display getCanvas copyClipRect: Display boundingBox).
		]
	] ifFalse: [  "this world is inside an MVC window"
		(properDisplay and: [canvas clipRect = aWorld viewBox]) ifFalse: [
			self canvas:
				(Display getCanvas copyOffset: 0@0 clipRect: aWorld viewBox)
		]
	].
	^ true
! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 11/26/2000 12:04'!
doOneCycleFor: aWorld

	self interCyclePause: (Preferences higherPerformance ifTrue: [1] ifFalse: [MinCycleLapse]).
	self doOneCycleNowFor: aWorld.! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 12:03'!
doOneCycleInBackground
	"Do one cycle of the interactive loop. This method is called repeatedly when this world is not the active window but is running in the background."

self halt.		"not ready for prime time"

	"process user input events, but only for remote hands"
	self handsDo: [:h |
		(h isKindOf: RemoteHandMorph) ifTrue: [
			activeHand _ h.
			h processEvents.
			activeHand _ nil]].

	self runStepMethods.
	self displayWorldSafely.
! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 7/23/2000 17:27'!
doOneCycleNowFor: aWorld
	"Do one cycle of the interactive loop. This method is called repeatedly when the world is running."

	self flag: #bob.		"need to consider remote hands in lower worlds"
	"process user input events"
	LastCycleTime _ Time millisecondClockValue.
	self handsDo: [:h |
		activeHand _ h.
		h processEvents.
		activeHand _ nil
	].

	aWorld runStepMethods.		"there are currently some variations here"
	self displayWorldSafely: aWorld.
! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 11:59'!
doOneSubCycleFor: aWorld
	"Like doOneCycle, but preserves activeHand."

	| currentHand |
	currentHand _ activeHand.
	self doOneCycleFor: aWorld.
	activeHand _ currentHand! !

!WorldState methodsFor: 'update cycle' stamp: 'ar 1/30/2001 19:34'!
drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas 
	"Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
were redrawn."
	| rectList c i n mm morphs rects rectToFill remnants rect |

	rectList _ damageRecorder invalidRectsFullBounds: aWorld viewBox.
	damageRecorder reset.
	n _ submorphs size.
	morphs _ OrderedCollection new: n*2.
	rects _ OrderedCollection new: n*2.
	rectList do: [:r |
		true
		ifTrue:
			["Experimental top-down drawing --
			Traverses top to bottom, stopping if the entire area is filled.
			If only a single rectangle remains, then continue with the reduced rectangle."
			rectToFill _ r.
			i _ 1.
			[rectToFill == nil or: [i > n]] whileFalse:
				[mm _ submorphs at: i.
				((mm fullBounds intersects: r) and: [mm visible]) ifTrue:
					[morphs addLast: mm.  rects addLast: rectToFill.
					remnants _ mm areasRemainingToFill: rectToFill.
					remnants size = 1 ifTrue: [rectToFill _ remnants first].
					remnants size = 0 ifTrue: [rectToFill _ nil]].
				i _ i+1].

			"Now paint from bottom to top, but using the reduced rectangles."
			rectToFill ifNotNil:[aWorld drawOn: (c _ aCanvas copyClipRect: rectToFill)].
			[morphs isEmpty] whileFalse:
				[(rect _ rects removeLast) == rectToFill ifFalse:
					[c _ aCanvas copyClipRect: (rectToFill _ rect)].
				c fullDrawMorph: morphs removeLast].
			morphs reset.  rects reset]
		ifFalse: [rectToFill ifNotNil:[aWorld drawOn: (aCanvas copyClipRect: rectToFill)].
				submorphs reverseDo: [:m | c fullDrawMorph: m]].
	].
	^ rectList! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 11/7/2000 13:54'!
forceDamageToScreen: allDamage

	"here for the convenience of NebraskaWorldState"
	allDamage do: [:r | Display forceToScreen: r].
	self remoteCanvasesDo: [ :each | 
		allDamage do: [:r | each forceToScreen: r].
		each displayIsFullyUpdated.
	].! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 10:16'!
handleFatalDrawingError: errMsg
	"Handle a fatal drawing error."
	Smalltalk isMorphic ifFalse:[^self error: errMsg]. "Can still handle it from MVC"
	Display deferUpdates: false. "Just in case"
	self primitiveError: errMsg.

	"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !

!WorldState methodsFor: 'update cycle' stamp: 'RAA 1/28/2001 16:22'!
interCyclePause: milliSecs
	"delay enough that the next interaction cycle won't happen too soon after the original; thus, if all the system is doing is polling for interaction, the overall CPU usage of Squeak will be low"

	| currentTime wait |

	currentTime _ Time millisecondClockValue.
	(lastCycleTime notNil and: [CanSurrenderToOS ~~ false]) ifTrue: [ 
		wait _ lastCycleTime + milliSecs - currentTime.
		wait > 0 ifTrue: [ 
			wait <= milliSecs  "big waits happen after a snapshot"
				ifTrue: [DisplayScreen checkForNewScreenSize.
						(Delay forMilliseconds: wait) wait ]. 
		].
	].
	"record the time AFTER the wait"
	lastCycleTime _  Time millisecondClockValue.
	CanSurrenderToOS _ true.! !

!WorldState methodsFor: 'update cycle' stamp: 'di 6/10/1999 22:40'!
startBackgroundProcess
	"Start a process to update this world in the background. Return the process created."

	| p |
	p _ [[true] whileTrue: [
		self doOneCycleInBackground.
		(Delay forMilliseconds: 20) wait]] newProcess.
	p resume.
	^ p
! !


!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:23'!
adjustWakeupTimes: now
	"Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)"
	| deltaTime |
	deltaTime _ now - lastStepTime.
	stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime].
	lastStepTime _ now.
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 15:22'!
adjustWakeupTimesIfNecessary
	"Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)."

	| now |
	now _ Time millisecondClockValue.
	((now < lastStepTime) or: [(now - lastStepTime) > 5000])
		 ifTrue: [self adjustWakeupTimes: now].  "clock slipped"
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:04'!
cleanseStepListForWorld: aWorld
	"Remove morphs from the step list that are not in this World.  Often were in a flap that has moved on to another world."

	| deletions morphToStep |
	stepList do: [:entry |
		morphToStep _ entry receiver.
		morphToStep world == aWorld ifFalse:[
			deletions ifNil: [deletions _ OrderedCollection new].
			deletions addLast: entry]].

	deletions ifNotNil:[
		deletions do: [:entry|
			entry receiver stopStepping]].

! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]].
	stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph selector: aSelector
	"Return true if the given morph is in the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[^true]].
	stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]].
	^ false! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:05'!
listOfSteppingMorphs
	^stepList collect:[:entry| entry receiver].
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:08'!
runLocalStepMethodsIn: aWorld
	"Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
	ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."

	| now morphToStep stepTime |
	now _ Time millisecondClockValue.
	self triggerAlarmsBefore: now.
	stepList size = 0 ifTrue: [^ self].
	((now < lastStepTime) or: [(now - lastStepTime) > 5000])
		 ifTrue: [self adjustWakeupTimes: now].  "clock slipped"
	[stepList isEmpty not and:[stepList first scheduledTime < now]] whileTrue:[
		lastStepMessage _ stepList removeFirst.
		morphToStep _ lastStepMessage receiver.
		(morphToStep shouldGetStepsFrom: aWorld) ifTrue:[
			lastStepMessage value: now.
			lastStepMessage ifNotNil:[
				stepTime _ lastStepMessage stepTime ifNil:[morphToStep stepTime].
				lastStepMessage scheduledTime: now + (stepTime max: 1).
				stepList add: lastStepMessage].
		].
		lastStepMessage _ nil.
	].
	lastStepTime _ now! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:07'!
runStepMethodsIn: aWorld
	"Perform periodic activity inbetween event cycles"
	| queue |

	queue _ self class deferredUIMessages.
	[queue isEmpty] whileFalse: [
		queue next value
	].
	self runLocalStepMethodsIn: aWorld.

	"we are using a normal #step for these now"
	"aWorld allLowerWorldsDo: [ :each | each runLocalStepMethods ]."
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
	"Add the given morph to the step list. Do nothing if it is already being stepped."

	self stopStepping: aMorph selector: aSelector.
	self adjustWakeupTimesIfNecessary.
	stepList add:(
		StepMessage 
			scheduledAt: scheduledTime
			stepTime: stepTime
			receiver: aMorph
			selector: aSelector
			arguments: args)! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage _ nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]).
! !

!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph selector: aSelector
	"Remove the given morph from the step list."
	lastStepMessage ifNotNil:[
		(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
			ifTrue:[lastStepMessage _ nil]].
	stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).! !


!WorldState methodsFor: 'canvas' stamp: 'ar 10/26/2000 14:10'!
assuredCanvas
	remoteServer ifNotNil:[^self assuredRemoteCanvas].
	(canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]])
		ifTrue:
			["allocate a new offscreen canvas the size of the window"
			self canvas: (Display defaultCanvasClass extent: viewBox extent)].
	^ self canvas! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
canvas

	^ canvas! !

!WorldState methodsFor: 'canvas' stamp: 'di 7/19/1999 16:45'!
canvas: x

	canvas _ x.
	damageRecorder == nil
		ifTrue: [damageRecorder _ DamageRecorder new]
		ifFalse: [damageRecorder doFullRepaint]! !

!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:12'!
doFullRepaint

	damageRecorder doFullRepaint
! !

!WorldState methodsFor: 'canvas' stamp: 'ar 1/30/2001 23:25'!
recordDamagedRect: damageRect

	damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated]
! !

!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:10'!
resetDamageRecorder

	damageRecorder reset
! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
viewBox

	^ viewBox! !

!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:58'!
viewBox: x

	viewBox _ x! !


!WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:42'!
activeHand

	^ activeHand! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:19'!
activeHand: aHandMorph

	"still needed until event loop with old code goes away"

	activeHand _ aHandMorph! !

!WorldState methodsFor: 'hands' stamp: 'ar 10/26/2000 14:51'!
addHand: aHandMorph
	"Add the given hand to the list of hands for this world."

	hands _ (hands copyWithout: aHandMorph) copyWith: aHandMorph.
! !

!WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'!
hands

	^ hands! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'!
handsDo: aBlock

	^ hands do: aBlock! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'!
handsReverseDo: aBlock

	^ hands reverseDo: aBlock! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:05'!
removeHand: aHandMorph
	"Remove the given hand from the list of hands for this world."

	(hands includes: aHandMorph) ifFalse: [^self].
	hands _ hands copyWithout: aHandMorph.
	activeHand == aHandMorph ifTrue: [activeHand _ nil].
! !

!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:56'!
selectHandsToDrawForDamage: damageList
	"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."

	| result hBnds |
	result _ OrderedCollection new.
	hands do: [:h |
		h needsToBeDrawn ifTrue: [
			h hasChanged
				ifTrue: [result add: h]
				ifFalse: [
					hBnds _ h fullBounds.
					(damageList detect: [:r | r intersects: hBnds] ifNone: [nil])
						ifNotNil: [result add: h]]]].
	^ result
! !


!WorldState methodsFor: 'object fileIn' stamp: 'RAA 1/5/2001 10:51'!
convertAlarms
	
	alarms ifNotNil: [alarms sortBlock: self alarmSortBlock].	"ensure cleaner block"

! !

!WorldState methodsFor: 'object fileIn' stamp: 'RAA 1/5/2001 10:48'!
convertStepList
	"Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"
	| newList wakeupTime morphToStep |

	(stepList isKindOf: Heap) ifTrue:[
		^stepList sortBlock: self stepListSortBlock	"ensure that we have a cleaner block"
	].
	newList _ Heap sortBlock: self stepListSortBlock.
	stepList do:[:entry|
		wakeupTime _ entry at: 2.
		morphToStep _ entry at: 1.
		newList add: (
			StepMessage
				scheduledAt: wakeupTime
				stepTime: nil
				receiver: morphToStep
				selector: #stepAt:
				arguments: nil).
	].
	stepList _ newList.! !

!WorldState methodsFor: 'object fileIn' stamp: 'RAA 1/5/2001 10:51'!
convertToCurrentVersion: varDict refStream: smartRefStrm
	
	"Convert the old to new step lists"
	self convertStepList.
	self convertAlarms.
	^super convertToCurrentVersion: varDict refStream: smartRefStrm.

! !


!WorldState methodsFor: 'undo support' stamp: 'RAA 9/21/2000 20:05'!
clearCommandHistory

	"useful prior to project saves"
	commandHistory _ nil! !

!WorldState methodsFor: 'undo support' stamp: 'ar 8/31/2000 22:57'!
commandHistory
	^commandHistory ifNil:[commandHistory _ CommandHistory new]! !


!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 16:43'!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
	"Add a new alarm with the given set of parameters"
	self alarms add: 
		(MorphicAlarm 
			scheduledAt: scheduledTime
			receiver: aTarget
			selector: aSelector
			arguments: argArray).! !

!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 17:11'!
adjustAlarmTimes: nowTime
	"Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)"
	| deltaTime |
	deltaTime _ nowTime - lastAlarmTime.
	self alarms do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].! !

!WorldState methodsFor: 'alarms' stamp: 'RAA 1/7/2001 12:33'!
alarmSortBlock

	| answer |

	"Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."

	^[ :alarm1 :alarm2 | 
		answer _ alarm1 scheduledTime < alarm2 scheduledTime.
		alarm1 _ alarm2 _ nil.
		answer
	]! !

!WorldState methodsFor: 'alarms' stamp: 'RAA 1/5/2001 10:46'!
alarms

	^alarms ifNil: [alarms _ Heap sortBlock: self alarmSortBlock]! !

!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 16:47'!
removeAlarm: aSelector for: aTarget
	"Remove the alarm with the given selector"
	| alarm |
	alarm _ self alarms 
		detect:[:any| any receiver == aTarget and:[any selector == aSelector]]
		ifNone:[nil].
	alarm == nil ifFalse:[self alarms remove: alarm].! !

!WorldState methodsFor: 'alarms' stamp: 'ar 10/22/2000 16:55'!
triggerAlarmsBefore: nowTime
	"Trigger all pending alarms that are to be executed before nowTime."
	| pending |
	lastAlarmTime ifNil:[lastAlarmTime _ nowTime].
	(nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000])
		ifTrue:[self adjustAlarmTimes: nowTime].
	pending _ self alarms.
	[pending isEmpty not and:[pending first scheduledTime < nowTime]]
		whileTrue:[pending removeFirst value: nowTime].
	lastAlarmTime _ nowTime.! !


!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:11'!
addRemoteCanvas: c
	self canvas: nil. "force recomputation"! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:17'!
assuredRemoteCanvas
	| newCanvas |
	(self canvas notNil) ifTrue: [ ^self canvas ].
	newCanvas := MultiCanvas new.
	newCanvas depth: 32.
	newCanvas extent: viewBox extent.
	self remoteCanvasesDo: [ :c | newCanvas addCanvas: c ].
	newCanvas addCanvas: Display getCanvas.

	"newCanvas := CachingCanvas on: newCanvas."
	self canvas: newCanvas.
	^newCanvas! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:44'!
releaseRemoteServer
	"My server has been transferred to some other world. Release pending references"
	remoteServer _ nil.
	self canvas: nil.! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:15'!
remoteCanvasesDo: aBlock
	remoteServer ifNil:[^self].
	^remoteServer clients do:[:client| aBlock value: client canvas]! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:08'!
remoteServer
	^remoteServer! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:29'!
remoteServer: aNebraskaServer
	remoteServer ifNotNil:[remoteServer destroy].
	remoteServer _ aNebraskaServer.
	self canvas: nil.! !

!WorldState methodsFor: 'Nebraska support' stamp: 'ar 10/26/2000 14:17'!
removeRemoteCanvas: c
	self canvas: nil.	"force withdrawal of remote from MultiCanvas"
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WorldState class
	instanceVariableNames: ''!

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:58'!
addDeferredUIMessage: valuableObject

	self deferredUIMessages nextPut: valuableObject.

! !

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:58'!
deferredUIMessages

	^DeferredUIMessages ifNil: [DeferredUIMessages _ SharedQueue new].
! !

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 7/15/2000 12:56'!
initialize
	"WorldState initialize"

	MinCycleLapse _ 20.		"allows 50 frames per second..."
	DisableDeferredUpdates _ false.
	DeferredUIMessages _ SharedQueue new.! !

!WorldState class methodsFor: 'class initialization' stamp: 'RAA 5/25/2000 15:15'!
new

	^super new initialize
	! !


!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 16:40'!
canSurrenderToOS: aBoolean

	CanSurrenderToOS _ aBoolean! !

!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 1/7/2001 16:32'!
classVersion

	^1		"force cleanup of alarms and stepList"! !

!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 17:28'!
lastCycleTime

	^LastCycleTime! !
Object subclass: #WorldViewModel
	instanceVariableNames: 'initialExtent '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ST80-Morphic'!
!WorldViewModel commentStamp: '<historical>' prior: 0!
Serves as a model for a WorldView -- a morphic world viewed within an mvc project.!


!WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:50'!
fullScreenSize
	"Answer the size to which a window displaying the receiver should be set"

	^ (0@0 extent: DisplayScreen actualScreenSize) copy! !

!WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:51'!
initialExtent
	initialExtent ifNotNil: [^ initialExtent].
	^ super initialExtent! !

!WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:51'!
initialExtent: anExtent
	initialExtent _ anExtent! !
SystemWindow subclass: #WorldWindow
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Worlds'!
!WorldWindow commentStamp: '<historical>' prior: 0!
A WorldWindow is a SystemWindow whose central area presents an inner Morphic world.

WorldWindows have a red title bar when the world inside is inactive. This changes to green when the world becomes the active world. The world inside becomes activated by clicking in it. When you click outside this world, the parent world resumes control. While its world is inactive, the WorldWindow may be moved and resized like any other.

It would be nice to make the world inside active whenever the WorldWindow was active, but this presents difficulties in moving and resizing, probably related to use of the global World instead of self world in many methods.

This facility is mainly the work of Bob Arning, with a number of tweaks by DI.
!


!WorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 23:05'!
buildWindowMenu

	| aMenu |
	aMenu _ super buildWindowMenu.
	{640@480. 800@600. 832@624. 1024@768} do: [ :each |
		aMenu 
			add: each x printString,' x ',each y printString 
			target: self 
			selector: #extent: 
			argument: each + (0@self labelHeight).
	].
	^aMenu! !

!WorldWindow methodsFor: 'as yet unclassified' stamp: 'di 11/25/1999 23:14'!
collapseOrExpand

	super collapseOrExpand.
	isCollapsed ifFalse: [model becomeTheActiveWorldWith: nil]! !

!WorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 11/14/1999 12:11'!
extent: x

	super extent: x.
	model ifNil: [^self].
	model extent: self panelRect extent.! !

!WorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 11/13/1999 23:24'!
fullBounds

	^self bounds! !

!WorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 11/23/1999 09:27'!
mouseUp: evt

	(self panelRect containsPoint: evt cursorPoint)
		ifTrue: [model becomeTheActiveWorldWith: evt]! !

!WorldWindow methodsFor: 'as yet unclassified' stamp: 'RAA 5/25/2000 08:15'!
openInWorld: aWorld
	"This msg and its callees result in the window being activeOnlyOnTop"
	self bounds: (RealEstateAgent initialFrameFor: self world: aWorld).
	self firstSubmorph position: (self left + 1) @ (self top + self labelHeight).
	aWorld addMorph: self.
	self activate.
	aWorld startSteppingSubmorphsOf: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WorldWindow class
	instanceVariableNames: ''!

!WorldWindow class methodsFor: 'as yet unclassified' stamp: 'di 11/17/1999 11:12'!
test1
	"WorldWindow test1."

	| window world |
	world _ WiWPasteUpMorph newWorldForProject: nil.
	window _ (WorldWindow labelled: 'Inner World') model: world.
	window addMorph: world.
	world hostWindow: window.
	window openInWorld
! !

!WorldWindow class methodsFor: 'as yet unclassified' stamp: 'di 11/17/1999 11:39'!
test2
	"WorldWindow test2."

	| window world scrollPane |
	world _ WiWPasteUpMorph newWorldForProject: nil.
	window _ (WorldWindow labelled: 'Scrollable World') model: world.
	window addMorph: (scrollPane _ TwoWayScrollPane new model: world)
		frame: (0@0 extent: 1.0@1.0).
	scrollPane scroller addMorph: world.
	world hostWindow: window.
	window openInWorld
! !
PositionableStream subclass: #WriteStream
	instanceVariableNames: 'writeLimit '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Streams'!
!WriteStream commentStamp: '<historical>' prior: 0!
I represent an accessor for a sequence of objects that can only store objects in the sequence.!


!WriteStream methodsFor: 'accessing'!
contents

	readLimit _ readLimit max: position.
	^collection copyFrom: 1 to: position! !

!WriteStream methodsFor: 'accessing'!
next

	self shouldNotImplement! !

!WriteStream methodsFor: 'accessing' stamp: 'di 3/8/1999 09:02'!
nextPut: anObject 
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 66>
	position >= writeLimit
		ifTrue: [^ self pastEndPut: anObject]
		ifFalse: 
			[position _ position + 1.
			^collection at: position put: anObject]! !

!WriteStream methodsFor: 'accessing' stamp: 'ls 8/20/1998 10:19'!
nextPutAll: aCollection
	| newEnd |

	collection class == aCollection class ifFalse: [
		^super nextPutAll: aCollection ].

	newEnd _ position + aCollection size.
	newEnd > writeLimit ifTrue: [
		collection _ collection,
			(collection species new: (newEnd - writeLimit + (collection size max: 20)) ).
		writeLimit _ collection size ].

	collection replaceFrom: position+1 to: newEnd  with: aCollection.
	position _ newEnd.! !

!WriteStream methodsFor: 'accessing'!
size

	^readLimit _ readLimit max: position! !


!WriteStream methodsFor: 'positioning'!
position: anInteger 
	"Refer to the comment in PositionableStream|position:."

	readLimit _ readLimit max: position.
	super position: anInteger! !

!WriteStream methodsFor: 'positioning'!
reset 
	"Refer to the comment in PositionableStream|reset."

	readLimit _ readLimit max: position.
	position _ 0! !

!WriteStream methodsFor: 'positioning' stamp: 'ar 11/12/1998 21:27'!
resetToStart
	readLimit _ position _ 0.! !


!WriteStream methodsFor: 'character writing'!
cr
	"Append a return character to the receiver."

	self nextPut: Character cr! !

!WriteStream methodsFor: 'character writing'!
crtab
	"Append a return character, followed by a single tab character, to the 
	receiver."

	self nextPut: Character cr.
	self nextPut: Character tab! !

!WriteStream methodsFor: 'character writing'!
crtab: anInteger 
	"Append a return character, followed by anInteger tab characters, to the 
	receiver."

	self nextPut: Character cr.
	anInteger timesRepeat: [self nextPut: Character tab]! !

!WriteStream methodsFor: 'character writing' stamp: 'di 6/7/2000 22:43'!
nextPutKeyword: keyword withArg: argValue
	"Emit a keyword/value pair in the alternate syntax"

	self nextPutAll: (keyword copyWithout: $:);
		nextPut: $(;
		store: argValue;
		nextPut: $)! !

!WriteStream methodsFor: 'character writing'!
space
	"Append a space character to the receiver."

	self nextPut: Character space! !

!WriteStream methodsFor: 'character writing'!
tab
	"Append a tab character to the receiver."

	self nextPut: Character tab! !

!WriteStream methodsFor: 'character writing' stamp: 'sr 4/8/2000 01:49'!
tab: anInteger 
	"Append anInteger tab characters to the receiver."

	anInteger timesRepeat: [self nextPut: Character tab]! !


!WriteStream methodsFor: 'fileIn/Out'!
nextChunkPut: aString
	"Append the argument, aString, to the receiver, doubling embedded terminators."

	| i remainder terminator |
	terminator _ $!!.
	remainder _ aString.
	[(i _ remainder indexOf: terminator) = 0] whileFalse:
		[self nextPutAll: (remainder copyFrom: 1 to: i).
		self nextPut: terminator.  "double imbedded terminators"
		remainder _ remainder copyFrom: i+1 to: remainder size].
	self nextPutAll: remainder; nextPut: terminator! !

!WriteStream methodsFor: 'fileIn/Out' stamp: 'di 2/2/98 13:03'!
nextChunkPutWithStyle: aStringOrText
	"Append the argument, aText, to the receiver, doubling embedded terminators.  Put out one chunk for the string and one for the style runs.  Mark the style with ]style[."

	aStringOrText class == String ifTrue: [^ self nextChunkPut: aStringOrText].
	aStringOrText runs coalesce.
	aStringOrText unembellished ifTrue: [^ self nextChunkPut: aStringOrText asString].

	self nextChunkPut: aStringOrText asString.
	self cr; nextPutAll: ']style['.
	self nextChunkPut: 
		(String streamContents: [:strm | 
			aStringOrText runs writeScanOn: strm]).

! !


!WriteStream methodsFor: 'printing'!
store: anObject 
	"Have anObject print on the receiver for purposes of rereading."

	anObject storeOn: self! !


!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:55'!
braceArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	^ collection! !

!WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:50'!
braceArray: anArray
	"This method is used in compilation of brace constructs.
	It MUST NOT be deleted or altered."

	collection _ anArray.
	position _ 0.
	readLimit _ 0.
	writeLimit _ anArray size.! !

!WriteStream methodsFor: 'private'!
on: aCollection

	super on: aCollection.
	readLimit _ 0.
	writeLimit _ aCollection size! !

!WriteStream methodsFor: 'private'!
on: aCollection from: firstIndex to: lastIndex

	| len |
	collection _ aCollection.
	readLimit _ 
		writeLimit _ lastIndex > (len _ collection size)
						ifTrue: [len]
						ifFalse: [lastIndex].
	position _ firstIndex <= 1
				ifTrue: [0]
				ifFalse: [firstIndex - 1]! !

!WriteStream methodsFor: 'private' stamp: 'di 6/20/97 08:39'!
pastEndPut: anObject
	collection _ collection ,
		(collection class new: ((collection size max: 20) min: 20000)).
	writeLimit _ collection size.
	collection at: (position _ position + 1) put: anObject! !

!WriteStream methodsFor: 'private'!
with: aCollection

	super on: aCollection.
	position _ readLimit _ writeLimit _ aCollection size! !

!WriteStream methodsFor: 'private'!
withAttribute: att do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !

!WriteStream methodsFor: 'private' stamp: 'djp 11/6/1999 23:15'!
withAttributes: attributes do: strmBlock 
	"No-op here is overriden in TextStream for font emphasis"
	^ strmBlock value! !


!WriteStream methodsFor: 'file open/close' stamp: 'mir 8/10/1999 11:56'!
flush! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

WriteStream class
	instanceVariableNames: ''!

!WriteStream class methodsFor: 'instance creation'!
on: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on a copy of the argument, aCollection, 
	determined by the indices firstIndex and lastIndex. Position the instance 
	at the beginning of the collection."

	^self basicNew
		on: aCollection
		from: firstIndex
		to: lastIndex! !

!WriteStream class methodsFor: 'instance creation'!
with: aCollection 
	"Answer an instance of me on the argument, aCollection, positioned to 
	store objects at the end of aCollection."

	^self basicNew with: aCollection! !

!WriteStream class methodsFor: 'instance creation'!
with: aCollection from: firstIndex to: lastIndex 
	"Answer an instance of me on the subcollection of the argument, 
	aCollection, determined by the indices firstIndex and lastIndex. Position 
	the instance to store at the end of the subcollection."

	^self basicNew with: (aCollection copyFrom: firstIndex to: lastIndex)! !
ExternalStructure subclass: #X11Display
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-X11'!

!X11Display methodsFor: 'initialize-release' stamp: 'ar 1/27/2000 16:45'!
closeDisplay
	handle == nil ifFalse:[
		self XCloseDisplay: self.
		handle _ nil].! !

!X11Display methodsFor: 'initialize-release' stamp: 'ar 1/27/2000 17:45'!
flush
	self XFlush: self! !

!X11Display methodsFor: 'initialize-release' stamp: 'ar 1/27/2000 17:51'!
sync
	^self XSync: self! !


!X11Display methodsFor: 'accessing' stamp: 'ar 1/27/2000 16:46'!
displayString
	^self XDisplayString: self! !

!X11Display methodsFor: 'accessing' stamp: 'ar 1/27/2000 16:51'!
getInputFocus
	| focus revert |
	focus _ X11Window new.
	focus display: self.
	revert _ WordArray new: 1.
	self XGetInputFocus: self with: focus with: revert.
	^focus! !

!X11Display methodsFor: 'accessing' stamp: 'bf 5/18/2000 15:10'!
queryPointer: aX11Window
	| root child rootX rootY winX winY mask |
	root _ X11Window new.
	child _ X11Window new.
	rootX _ WordArray new: 1.
	rootY _ WordArray new: 1.
	winX _ WordArray new: 1.
	winY _ WordArray new: 1.
	mask _ WordArray new: 1.
	self XQueryPointer: self window: aX11Window returnRoot: root child: child
		rootX: rootX rootY: rootY winX: winX winY: winY mask: mask.
	^{root. child. rootX first @ rootY first. winX first @ winY first. mask first}! !


!X11Display methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 16:45'!
XCloseDisplay: aDisplay
	<cdecl: void 'XCloseDisplay' (X11Display*) module:'X11'>
	^self externalCallFailed! !

!X11Display methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 16:45'!
XDisplayString: aDisplay
	<cdecl: char* 'XDisplayString' (X11Display*) module:'X11'>
	^self externalCallFailed! !

!X11Display methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 17:46'!
XFlush: xDisplay
	<cdecl: void 'XFlush' (X11Display*) module:'X11'>
	^self externalCallFailed! !

!X11Display methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 16:51'!
XGetInputFocus: display with: focus with: revert
	<cdecl: void 'XGetInputFocus' (X11Display* X11Window* long*) module: 'X11'>
	^self externalCallFailed! !

!X11Display methodsFor: 'xlib calls' stamp: 'bf 5/18/2000 15:20'!
XQueryPointer: display window: w returnRoot: root child: child rootX: rootX rootY: rootY winX: winX winY: winY mask: mask 
	<cdecl: bool 'XQueryPointer' (X11Display* X11Window X11Window* X11Window* long* long* long* long* long*) module: 'X11'>
	^self externalCallFailed! !

!X11Display methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 17:52'!
XSync: xDisplay
	<cdecl: void 'XSync' (X11Display*) module:'X11'>
	^self externalCallFailed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

X11Display class
	instanceVariableNames: ''!

!X11Display class methodsFor: 'field definition' stamp: 'ar 1/28/2000 19:08'!
fields
	"X11Display defineFields"
	"Note: The structure of Display is internal and only pointers to X11Display are used"
	^#()! !


!X11Display class methodsFor: 'instance creation' stamp: 'ar 1/27/2000 16:46'!
XOpenDisplay: displayName
	"X11Display XOpenDisplay: nil"
	<cdecl: X11Display* 'XOpenDisplay' (char*) module:'X11'>
	^self externalCallFailed! !


!X11Display class methodsFor: 'examples' stamp: 'ar 1/28/2000 19:19'!
coloredEllipses
	"X11Display coloredEllipses"
	| display window gc colors rnd w h pt1 pt2 r |
	display _ X11Display XOpenDisplay: nil.
	window _ display getInputFocus.
	gc _ X11GC on: window.
	colors _ Color colorNames collect:[:n| (Color perform: n) pixelWordForDepth: 32].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	[Sensor anyButtonPressed] whileFalse:[
		pt1 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
		pt2 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
		r _ Rectangle encompassing: (Array with: pt1 with: pt2).
		gc foreground: colors atRandom.
		gc fillOval: r.
		gc foreground: 0.
		gc drawOval: r.
		display sync.
	].
	gc free.
	display closeDisplay.
	Display forceToScreen.! !

!X11Display class methodsFor: 'examples' stamp: 'ls 1/19/2001 13:45'!
coloredRectangles
	"X11Display coloredRectangles"
	| display window gc colors rnd w h pt1 pt2 r nPixels time n |
	display _ X11Display XOpenDisplay: nil.
	window _ display getInputFocus.
	gc _ X11GC on: window.
	colors _ Color colorNames collect:[:cn| (Color perform: cn) pixelWordForDepth: 32].
	rnd _ Random new.
	w _ Display width.
	h _ Display height.
	n _ 0.
	nPixels _ 0.
	time _ Time millisecondClockValue.
	[Sensor anyButtonPressed] whileFalse:[
		pt1 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
		pt2 _ (rnd next * w) asInteger @ (rnd next * h) asInteger.
		r _ Rectangle encompassing: (Array with: pt1 with: pt2).
		gc foreground: colors atRandom.
		gc fillRectangle: r.
		gc foreground: 0.
		gc drawRectangle: r.
		display sync.
		n _ n + 1.
		nPixels _ nPixels + ((r right - r left) * (r bottom - r top)).
		(n \\ 100) = 0 ifTrue:[
			'Pixel fillRate: ', (nPixels * 1000 // (Time millisecondClockValue - time))
				asStringWithCommas displayAt: 0@0].
	].
	gc free.
	display closeDisplay.
	Display forceToScreen.! !

!X11Display class methodsFor: 'examples' stamp: 'bf 5/18/2000 15:28'!
x11Draw
	"X11Display x11Draw"
	| display window gc nextPt lastPt ptr |
	display _ X11Display XOpenDisplay: nil.
	window _ display getInputFocus.
	gc _ X11GC on: window.
	gc foreground: 0.
	lastPt _ nil.
	[ptr _ display queryPointer: window.	"{root. child. root pos. win pos. mask}"
	ptr last anyMask: 256] whileFalse:[
		nextPt _ ptr fourth.
		nextPt = lastPt ifFalse:[
			lastPt ifNotNil: [
				gc drawLineFrom: lastPt to: nextPt.
				display sync].
			lastPt _ nextPt].
	].
	gc free.
	display closeDisplay.
	Display forceToScreen.! !
ExternalStructure subclass: #X11Drawable
	instanceVariableNames: 'display '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-X11'!

!X11Drawable methodsFor: 'accessing' stamp: 'ar 1/27/2000 16:47'!
display
	^display! !

!X11Drawable methodsFor: 'accessing' stamp: 'ar 1/27/2000 16:48'!
display: aDisplay
	display _ aDisplay! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

X11Drawable class
	instanceVariableNames: ''!

!X11Drawable class methodsFor: 'field definition' stamp: 'ar 1/28/2000 19:18'!
fields
	"X11Drawable defineFields"
	^#( nil 'void*' )! !
ExternalStructure subclass: #X11GC
	instanceVariableNames: 'drawable '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-X11'!

!X11GC methodsFor: 'initialize-release' stamp: 'ar 1/28/2000 17:03'!
free
	handle == nil ifFalse:[
		self XFreeGC: self display with: self.
		handle _ nil.
	].! !


!X11GC methodsFor: 'accessing' stamp: 'ar 1/27/2000 16:49'!
display
	^drawable display! !

!X11GC methodsFor: 'accessing' stamp: 'ar 1/27/2000 13:01'!
drawable
	^drawable! !

!X11GC methodsFor: 'accessing' stamp: 'ar 1/27/2000 13:01'!
drawable: aDrawable
	drawable _ aDrawable! !


!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:34'!
background: pixelValue
	self XSetBackground: self display with: self with: pixelValue! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:32'!
drawLineFrom: pt1 to: pt2
	self XDrawLine: self display 
			with: drawable 
			with: self 
			with: pt1 x 
			with: pt1 y 
			with: pt2 x 
			with: pt2 y! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:34'!
drawOval: aRectangle
	self
		XDrawArc: self display
			with: drawable
			with: self
			with: aRectangle left
			with: aRectangle top
			with: aRectangle width
			with: aRectangle height
			with: 0
			with: 64*360! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:34'!
drawRectangle: aRectangle
	self
		XDrawRectangle: self display
			with: drawable
			with: self
			with: aRectangle left
			with: aRectangle top
			with: aRectangle width
			with: aRectangle height! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:34'!
fillOval: aRectangle
	self
		XFillArc: self display
			with: drawable
			with: self
			with: aRectangle left
			with: aRectangle top
			with: aRectangle width
			with: aRectangle height
			with: 0
			with: 64*360! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:35'!
fillRectangle: aRectangle
	self
		XFillRectangle: self display
			with: drawable
			with: self
			with: aRectangle left
			with: aRectangle top
			with: aRectangle width
			with: aRectangle height! !

!X11GC methodsFor: 'drawing' stamp: 'ar 1/28/2000 17:34'!
foreground: pixelValue
	self XSetForeground: self display with: self with: pixelValue
! !


!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 17:09'!
XDrawArc: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h with: a1 with: a2
	<cdecl: void 'XDrawArc' (X11Display* X11Drawable X11GC long long ulong ulong long long) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 16:43'!
XDrawLine: xDisplay with: aDrawable with: xGC with: x0 with: y0 with: x1 with: y1
	<cdecl: long 'XDrawLine' (X11Display* X11Drawable X11GC long long long long) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 17:08'!
XDrawRectangle: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h
	<cdecl: void 'XDrawRectangle' (X11Display* X11Drawable X11GC long long ulong ulong) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 17:09'!
XFillArc: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h with: a1 with: a2
	<cdecl: void 'XFillArc' (X11Display* X11Drawable X11GC long long ulong ulong long long) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/27/2000 16:56'!
XFillRectangle: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h
	<cdecl: void 'XFillRectangle' (X11Display* X11Drawable X11GC long long ulong ulong) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 17:04'!
XFreeGC: xDisplay with: xGC
	<cdecl: long 'XFreeGC' (X11Display* X11GC) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 14:54'!
XSetBackground: xDisplay with: xGC with: bg
	<cdecl: void 'XSetBackground' (X11Display* X11GC long) module: 'X11'>
	^self externalCallFailed! !

!X11GC methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 14:54'!
XSetForeground: xDisplay with: xGC with: fg
	<cdecl: void 'XSetForeground' (X11Display* X11GC long) module: 'X11'>
	^self externalCallFailed! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

X11GC class
	instanceVariableNames: ''!

!X11GC class methodsFor: 'field definition' stamp: 'ar 1/28/2000 19:18'!
fields
	"X11GC defineFields"
	^#( nil 'void*' )! !


!X11GC class methodsFor: 'instance creation' stamp: 'ar 1/28/2000 19:09'!
on: aDrawable
	| xgc |
	xgc _ self XCreateGC: aDrawable display with: aDrawable with: 0 with: nil.
	xgc drawable: aDrawable.
	^xgc! !


!X11GC class methodsFor: 'xlib calls' stamp: 'ar 1/28/2000 19:09'!
XCreateGC: xDisplay with: aDrawable with: valueMask with: values
	<cdecl: X11GC 'XCreateGC' (X11Display* X11Drawable ulong long*) module: 'X11'>
	^self externalCallFailed! !
X11Drawable subclass: #X11Window
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'FFI-Examples-X11'!
ImageReadWriter subclass: #XBMReadWriter
	instanceVariableNames: 'width height '
	classVariableNames: 'Flipbits '
	poolDictionaries: ''
	category: 'Graphics-Files'!

!XBMReadWriter methodsFor: 'private' stamp: 'wdc 2/2/1999 15:20'!
parseByteValue
	"skip over separators and return next bytevalue parsed as a C language number:
		0ddd is an octal digit.
		0xddd is a hex digit.
		ddd is decimal."
	| source mybase |
	stream skipSeparators.
	source _ ReadWriteStream on: String new.
	[stream atEnd or: [ stream peek isSeparator ]]
		whileFalse: [source nextPut: self next asUppercase].
	mybase _ 10. "Base 10 default"
	source reset.
	(source peek = $0) ifTrue: [
		mybase _ 8. "Octal or Hex, say its Octal unless overridden."
		source next.
		(source peek = $X) ifTrue: [
			mybase _ 16. "Ah.  It's Hex."
			source next.
			]
		].
	^ Integer readFrom: source base: mybase! !

!XBMReadWriter methodsFor: 'private' stamp: 'di 2/1/1999 08:23'!
readHeader
	"Set width and height, and position stream at start of bytes"
	| number setwidth setheight fieldName |
	setwidth _ setheight _ false.
		[((stream atEnd) or: [setwidth and: [setheight]])]
		whileFalse: [
	  	stream skipSeparators.
		(stream nextMatchAll: '#define ') ifFalse: [^ false].
		(stream skipTo: $_) ifFalse: [^ false].
		fieldName _ String streamContents:
			[:source |
			[(stream atEnd) or: [ stream peek isSeparator ]]
				whileFalse: [ source nextPut: stream next]].
	  	(fieldName = 'width') ifTrue: [
			stream skipSeparators.
			number _ Integer readFrom: stream.
			(number > 0) ifTrue: [setwidth _true].
	  		width _ number.].
		(fieldName = 'height') ifTrue: [
			stream skipSeparators.
			number _ Integer readFrom: stream.
			(number > 0) ifTrue: [setheight _ true].
			height _ number.
			].
		].
	(setwidth & setheight) ifFalse: [^ false].
	^ stream skipTo: ${
! !


!XBMReadWriter methodsFor: 'accessing' stamp: 'wdc 2/1/1999 07:15'!
nextImage
	"Read in the next xbm image from the stream."
	| form long incount chunks byteWidth pad fourway outcount total |
	stream reset.
	stream ascii.
	self readHeader.
	form _ ColorForm extent: width@height depth: 1.
	incount _ 0.	outcount _1.
	chunks _ Array new: 4.	byteWidth _ width + 7 // 8.
	total _ byteWidth * height.
	byteWidth > 4
		ifTrue: [ pad _ byteWidth \\ 4]
		ifFalse: [ pad _ 4 - byteWidth ].
	fourway _ 0.
	[(incount = total)] whileFalse: [
		incount _ incount + 1.
		fourway _ fourway + 1.
		chunks at: fourway put: (Flipbits at: ((self parseByteValue) +1)).
		(pad > 0 and: [(incount \\ byteWidth) = 0]) ifTrue: [
			1 to: pad do:
				[:q |	
  			fourway _ fourway + 1.	
			chunks at: fourway put: 0]
		].
		fourway = 4 ifTrue: [
			long _ Integer
				byte1: (chunks at: 4)
				byte2: (chunks at: 3)
				byte3: (chunks at: 2)
				byte4: (chunks at: 1).
			(form bits) at: outcount put: long.
			fourway _ 0.
			outcount _ outcount + 1].
		].
	 ^ form ! !

!XBMReadWriter methodsFor: 'accessing' stamp: 'wdc 2/1/1999 06:20'!
understandsImageFormat
	"Test to see if the image stream format is understood by this decoder.	This should be implemented in each subclass of ImageReadWriter so that	a proper decoder can be selected without ImageReadWriter having to know about all possible image file types."
	| first |
	first _ (stream next: 7) asString.
	^ (first = '#define')! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

XBMReadWriter class
	instanceVariableNames: ''!

!XBMReadWriter class methodsFor: 'class initialization' stamp: 'wdc 2/2/1999 15:28'!
initialize
	"XBMReadWriter initialize"
	| flippedByte |
	Flipbits _ (0 to: 255) collect:
     [:n |  "Compute the bit-reversal of the 8-bit value, n"
     flippedByte _ 0.
     0 to: 7 do: 
         [:i | 
         flippedByte _ flippedByte bitOr: ((n >> i bitAnd: 1) << (7-i))].
         flippedByte]! !
AbstractMediaEventMorph subclass: #ZASMCameraMarkMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:54'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
	"Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo."

	aMenu add: 'Go to this mark' action: #gotoMark.
	aMenu add: 'Set transition' action: #setTransition:.
	aMenu addLine.
	^super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph
! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/13/2000 09:09'!
addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime

	| startX pseudoEndTime |

	startX _ pianoRoll xForTime: startTimeInScore.
	pseudoEndTime _ pianoRoll timeForX: startX + self width.
	startTimeInScore > rightTime ifTrue: [^ self].  
	pseudoEndTime < leftTime ifTrue: [^ self].

	morphList add: 
		(self align: self bottomLeft
			with: startX @ self bottom).

! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 13:46'!
cameraController

	^(self valueOfProperty: #cameraController)! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 10:09'!
cameraPoint: aPoint cameraScale: aNumber controller: aController

	self setProperty: #cameraPoint toValue: aPoint.
	self setProperty: #cameraScale toValue: aNumber.
	self setProperty: #cameraController toValue: aController.
	self addMorph: (
		StringMorph contents: aPoint printString,'  ',(aNumber roundTo: 0.001) printString
	) lock.! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 13:57'!
cameraPoint: aPoint cameraScale: aNumber controller: aController page: aBookPage
 
	self setProperty: #cameraPoint toValue: aPoint.
	self setProperty: #cameraScale toValue: aNumber.
	self setProperty: #cameraController toValue: aController.
	self setProperty: #bookPage toValue: aBookPage.
	self addMorphBack: (ImageMorph new image: (aBookPage imageForm scaledToSize: 80@80)) lock.
	self setBalloonText: aPoint rounded printString,'  ',(aNumber roundTo: 0.001) printString! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:38'!
encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick

	| nextAmbient m nextDurationInMs program now finalMark thisPage nextPage |

	self gotoMark.
	nextAmbient _ nil.
	index to: track size do: [ :i |
		(nextAmbient isNil and: [((m _ track at: i) morph) isKindOf: self class]) ifTrue: [
			nextAmbient _ m.
		].
	].
	nextAmbient ifNil: [^self].
	nextDurationInMs _ (nextAmbient time - ticks * secsPerTick * 1000) rounded.
	finalMark _ nextAmbient morph.
	thisPage _ self valueOfProperty: #bookPage.
	nextPage _ finalMark valueOfProperty: #bookPage.
	(thisPage = nextPage or: [thisPage isNil | nextPage isNil]) ifFalse: [^finalMark gotoMark].
	now _ Time millisecondClockValue.
	program _ Dictionary new.
	program
		at: #startTime put: now;
		at: #endTime put: now + nextDurationInMs;
		at: #startPoint put: (self valueOfProperty: #cameraPoint);
		at: #endPoint put: (finalMark valueOfProperty: #cameraPoint);
		at: #startZoom put: (self valueOfProperty: #cameraScale);
		at: #endZoom put: (finalMark valueOfProperty: #cameraScale).

	self cameraController setProgrammedMoves: {program}.

! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:56'!
gotoMark

	self cameraController 
		turnToPage: (self valueOfProperty: #bookPage)
		position: (self valueOfProperty: #cameraPoint) 
		scale: (self valueOfProperty: #cameraScale)
		transition: (self valueOfProperty: #transitionSpec).
	self setCameraValues.


! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:39'!
handlesMouseDown: evt

	^true
! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/7/2000 11:37'!
initialize

	super initialize.
! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 23:26'!
justDroppedInto: newOwner event: anEvent

	| holder |

	newOwner isWorldMorph ifTrue: [
		holder _ ZASMScriptMorph new.
		holder 
			position: self position;
			setProperty: #cameraController toValue: self cameraController.
		self world addMorph: holder.
		holder addMorph: self.
		holder startStepping.
	].
	super justDroppedInto: newOwner event: anEvent! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:53'!
menuPageVisualFor: target event: evt

	| tSpec menu subMenu directionChoices |

	tSpec _ self 
		valueOfProperty: #transitionSpec
		ifAbsent: [
			(self valueOfProperty: #bookPage) 
				valueOfProperty: #transitionSpec
				ifAbsent: [{ 'silence' . #none. #none}]
		].
	menu _ (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
	TransitionMorph allEffects do: [:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect target: self
					selector: #setProperty:toValue:
					argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: #none))]
		ifFalse: [subMenu _ MenuMorph new.
				directionChoices do:
					[:dir |
					subMenu add: dir target: self
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect subMenu: subMenu]].

	menu popUpEvent: evt in: self world! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:43'!
mouseDown: evt

	evt shiftPressed ifTrue: [^self].
	self isSticky ifTrue: [^self].
	evt hand grabMorph: self.! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:43'!
mouseUp: evt

	evt shiftPressed ifTrue: [^self gotoMark].
! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 14:56'!
pauseFrom: scorePlayer

	self cameraController pauseProgrammedMoves.! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:27'!
resetFrom: scorePlayer

	"self cameraController setProgrammedMoves: nil."
! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:04'!
resumeFrom: scorePlayer

	self cameraController resumeProgrammedMoves! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 23:26'!
setCameraValues

	| camera |
	camera _ self cameraController.

	"ick... since one may fail to fully take due to constraints, retry"
	2 timesRepeat: [
		camera cameraPoint: (self valueOfProperty: #cameraPoint).
		camera cameraScale: (self valueOfProperty: #cameraScale).
	].

! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 15:54'!
setTransition: evt

	| tSpec menu subMenu directionChoices |

	tSpec _ self 
		valueOfProperty: #transitionSpec
		ifAbsent: [
			(self valueOfProperty: #bookPage) 
				valueOfProperty: #transitionSpec
				ifAbsent: [{ 'silence' . #none. #none}]
		].
	menu _ (MenuMorph entitled: 'Choose an effect
(it is now ' , tSpec second , ')') defaultTarget: self.
	TransitionMorph allEffects do: [:effect |
		directionChoices _ TransitionMorph directionsForEffect: effect.
		directionChoices isEmpty
		ifTrue: [menu add: effect target: self
					selector: #setProperty:toValue:
					argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: #none))]
		ifFalse: [subMenu _ MenuMorph new.
				directionChoices do:
					[:dir |
					subMenu add: dir target: self
						selector: #setProperty:toValue:
						argumentList: (Array with: #transitionSpec
									with: (Array with: tSpec first with: effect with: dir))].
				menu add: effect subMenu: subMenu]].

	menu popUpEvent: evt in: self world! !

!ZASMCameraMarkMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 15:34'!
veryDeepCopyWith: deepCopier
	| camera page |
	"Keep the same camera???"
 
	(camera _ self cameraController) ifNotNil: [
		(deepCopier references includesKey: camera) ifFalse: [
			"not recorded, outside our tree, use same camera"
			deepCopier references at: camera put: camera]].
	(page _ self valueOfProperty: #bookPage) ifNotNil: [
		(deepCopier references includesKey: page) ifFalse: [
			deepCopier references at: page put: page]].

	^ super veryDeepCopyWith: deepCopier

! !
PasteUpMorph subclass: #ZASMScriptMorph
	instanceVariableNames: 'somethingChanged '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 09:56'!
acceptDroppingMorph: aMorph event: evt

	super acceptDroppingMorph: aMorph event: evt.
	somethingChanged _ true.
	! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 10:18'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'save script' action: #saveScript.

! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:18'!
compileScript

	| newScript prevMark prevSteps data |

	self fixup.
	newScript _ OrderedCollection new.
	prevMark _ prevSteps _ nil.
	submorphs do: [ :each |
		(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
			prevMark ifNotNil: [
				data _ Dictionary new.
				data 
					at: #steps put: prevSteps;
					at: #startPoint put: (prevMark valueOfProperty: #cameraPoint);
					at: #endPoint put: (each valueOfProperty: #cameraPoint);
					at: #startZoom put: (prevMark valueOfProperty: #cameraScale);
					at: #endZoom put: (each valueOfProperty: #cameraScale).
				newScript add: data.
			].
			prevMark _ each.
		].
		(each isKindOf: ZASMStepsMorph) ifTrue: [
			prevSteps _ each getStepCount.
		].
	].
	^newScript
! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:03'!
decompileScript: aScript named: aString for: aController

	| newMorphs prevPt prevScale cameraPoint cameraScale mark |

	self removeAllMorphs.
	self setProperty: #cameraController toValue: aController.
	self setProperty: #cameraScriptName toValue: aString.

	newMorphs _ OrderedCollection new.
	prevPt _ prevScale _ nil.
	aScript do: [ :each |
		cameraPoint _ each at: #startPoint ifAbsent: [nil].
		cameraScale _ each at: #startZoom ifAbsent: [nil].
		(prevPt = cameraPoint and: [prevScale = cameraScale]) ifFalse: [
			mark _ ZASMCameraMarkMorph new.
			mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
			newMorphs add: mark.
		].
		newMorphs add: (ZASMStepsMorph new setStepCount: (each at: #steps ifAbsent: [10])).
		cameraPoint _ each at: #endPoint ifAbsent: [nil].
		cameraScale _ each at: #endZoom ifAbsent: [nil].
		mark _ ZASMCameraMarkMorph new.
		mark cameraPoint: cameraPoint cameraScale: cameraScale controller: aController.
		newMorphs add: mark.
		prevPt _ cameraPoint.
		prevScale _ cameraScale.
	].
	self addAllMorphs: newMorphs.
! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:16'!
fixup

	| newMorphs state fixed |

	somethingChanged _ false.
	newMorphs _ OrderedCollection new.
	state _ #new.
	fixed _ false.
	submorphs do: [ :each |
		(each isKindOf: ZASMCameraMarkMorph) ifTrue: [
			state == #mark ifTrue: [
				newMorphs add: (
					ZASMStepsMorph new setStepCount: 10
				).
				fixed _ true.
			].
			newMorphs add: each.
			state _ #mark.
		].
		(each isKindOf: ZASMStepsMorph) ifTrue: [
			state == #steps ifTrue: [
				fixed _ true.
			] ifFalse: [
				newMorphs add: each.
				state _ #steps.
			].
		].
	].
	fixed ifTrue: [
		self removeAllMorphs.
		self addAllMorphs: newMorphs.
	].! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 10:21'!
initialize

	somethingChanged _ true.
	super initialize.
	self dragEnabled: true.
	borderWidth _ 2.
	self layoutPolicy: TableLayout new.
	self listDirection: #topToBottom.
	self wrapCentering: #topLeft.
	self hResizing: #shrinkWrap.
	self vResizing: #shrinkWrap.
	self layoutInset: 6.
	color _ Color lightBlue.
	self borderColor: Color blue.
	self rubberBandCells: true. "default"! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 09:33'!
layoutChanged

	super layoutChanged.
	somethingChanged _ true.

	! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:02'!
saveScript

	| newScript scriptName |
	newScript _ self compileScript.
	scriptName _ FillInTheBlank 
		request: 'Name this script' 
		initialAnswer: (self valueOfProperty: #cameraScriptName ifAbsent: ['']).
	scriptName isEmptyOrNil ifTrue: [^self].
	(self valueOfProperty: #cameraController)
		saveScript: newScript
		as: scriptName.
	self delete.! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 10:36'!
step

	super step.
	somethingChanged ifFalse: [^self].
	self fixup.
! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 09:53'!
stepTime

	^500! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 09:02'!
wantsDroppedMorph: aMorph event: evt

	^aMorph isKindOf: ZASMCameraMarkMorph! !

!ZASMScriptMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 09:49'!
wantsSteps

	^true! !
StringMorph subclass: #ZASMStepsMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:24'!
getStepCount

	^[self contents asNumber] ifError: [ :a :b | 10]
	
! !

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:29'!
handlesMouseDown: evt

	^ true! !

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:25'!
initialize

	super initialize.
	color _ Color black.

! !

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:28'!
mouseDown: evt
	"If the shift key is pressed, make this string the keyboard input focus."

	self launchMiniEditor: evt
! !

!ZASMStepsMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:24'!
setStepCount: n

	self contents: n printString.

! !
FastInflateStream subclass: #ZLibReadStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compression'!

!ZLibReadStream methodsFor: 'initialize' stamp: 'ar 12/27/1999 15:38'!
on: aCollection from: firstIndex to: lastIndex
	"Check the header of the ZLib stream."
	| method byte |
	super on: aCollection from: firstIndex to: lastIndex.
	method _ self nextBits: 8.
	(method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method'].
	(method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size'].
	byte _ self nextBits: 8.
	(method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header'].
	(byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary'].
! !
ZipWriteStream subclass: #ZLibWriteStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compression'!

!ZLibWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/27/1999 15:48'!
on: aCollection
	super on: aCollection.
	encoder nextBits: 8 put: 120. "deflate method with 15bit window size"
	encoder nextBits: 8 put: 1. "check sum; no preset dictionary"
! !
Error subclass: #ZeroDivide
	instanceVariableNames: 'dividend '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Exceptions Kernel'!
!ZeroDivide commentStamp: '<historical>' prior: 0!
ZeroDivide may be signaled when a mathematical division by 0 is attempted.!


!ZeroDivide methodsFor: 'exceptionDescription' stamp: 'tfei 6/5/1999 17:29'!
dividend
	"Answer the number that was being divided by zero."

	^dividend! !

!ZeroDivide methodsFor: 'exceptionDescription' stamp: 'tfei 6/5/1999 17:26'!
isResumable
	
"Determine whether an exception is resumable."

	^true! !


!ZeroDivide methodsFor: 'exceptionBuilder' stamp: 'tfei 6/5/1999 17:34'!
dividend: argument
	"TFEI - Specify the number that was being divided by zero."

	dividend := argument! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZeroDivide class
	instanceVariableNames: ''!

!ZeroDivide class methodsFor: 'exceptionInstantiator' stamp: 'bf 9/27/1999 17:26'!
dividend: argument
	^self new dividend: argument; yourself! !
WriteStream subclass: #ZipEncoder
	instanceVariableNames: 'bitBuffer bitPosition encodedStream '
	classVariableNames: ''
	poolDictionaries: 'ZipConstants '
	category: 'System-Compression'!

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:38'!
close
	self flush.
	(encodedStream respondsTo: #close) ifTrue:[encodedStream close].! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'!
commit
	encodedStream next: position putAll: collection.
	position _ readLimit _ 0.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'!
flush
	self flushBits.
	self commit.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 16:35'!
flushBits
	"Flush currently unsent bits"
	[bitPosition > 0] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer _ bitBuffer bitShift: -8.
		bitPosition _ bitPosition - 8].
	bitPosition _ 0.! !

!ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 17:22'!
on: aCollectionOrStream
	aCollectionOrStream isStream 
		ifTrue:[encodedStream _ aCollectionOrStream]
		ifFalse:[	encodedStream _ WriteStream on: aCollectionOrStream].
	encodedStream isBinary
		ifTrue:[super on: (ByteArray new: 4096)]
		ifFalse:[super on: (String new: 4096)].
	bitPosition _ bitBuffer _ 0.! !


!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:45'!
bitPosition
	^encodedStream position + position * 8 + bitPosition.! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'!
encodedStream
	^encodedStream! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'!
nextBits: nBits put: value
	"Store a value of nBits"
	"self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]."
	bitBuffer _ bitBuffer bitOr: (value bitShift: bitPosition).
	bitPosition _ bitPosition + nBits.
	[bitPosition >= 8] whileTrue:[
		self nextBytePut: (bitBuffer bitAnd: 255).
		bitBuffer _ bitBuffer bitShift: -8.
		bitPosition _ bitPosition - 8].! !

!ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'!
nextBytePut: anObject 
	"Primitive. Insert the argument at the next position in the Stream
	represented by the receiver. Fail if the collection of this stream is not an
	Array or a String. Fail if the stream is positioned at its end, or if the
	position is out of bounds in the collection. Fail if the argument is not
	of the right type for the collection. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 66>
	position >= writeLimit
		ifTrue: [^ self pastEndPut: anObject]
		ifFalse: 
			[position _ position + 1.
			^collection byteAt: position put: anObject]! !


!ZipEncoder methodsFor: 'block encoding' stamp: 'ar 12/30/1999 18:39'!
sendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| result |
	result _ 0.
	[literalStream atEnd] whileFalse:[
		result _ result + (self privateSendBlock: literalStream
						with: distanceStream with: litTree with: distTree).
		self commit.
	].
	self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock).
	^result! !


!ZipEncoder methodsFor: 'private' stamp: 'ar 1/2/2000 16:38'!
pastEndPut: anObject
	"Flush the current buffer and store the new object at the beginning"
	self commit.
	^self nextBytePut: anObject asInteger! !

!ZipEncoder methodsFor: 'private' stamp: 'ar 2/2/2001 15:47'!
privateSendBlock: literalStream with: distanceStream with: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| lit dist code extra sum |
	<primitive: 'primitiveZipSendBlock' module: 'ZipPlugin'>
	sum _ 0.
	[lit _ literalStream next.
	dist _ distanceStream next.
	lit == nil] whileFalse:[
		dist = 0 ifTrue:["lit is a literal"
			sum _ sum + 1.
			self nextBits: (litTree bitLengthAt: lit)
				put: (litTree codeAt: lit).
		] ifFalse:["lit is match length"
			sum _ sum + lit + MinMatch.
			code _ (MatchLengthCodes at: lit + 1).
			self nextBits: (litTree bitLengthAt: code)
				put: (litTree codeAt: code).
			extra _ ExtraLengthBits at: code-NumLiterals.
			extra = 0 ifFalse:[
				lit _ lit - (BaseLength at: code-NumLiterals).
				self nextBits: extra put: lit.
			].
			dist _ dist - 1.
			dist < 256
				ifTrue:[code _ DistanceCodes at: dist + 1]
				ifFalse:[code _ DistanceCodes at: 257 + (dist bitShift: -7)].
			"self assert:[code < MaxDistCodes]."
			self nextBits: (distTree bitLengthAt: code)
				put: (distTree codeAt: code).
			extra _ ExtraDistanceBits at: code+1.
			extra = 0 ifFalse:[
				dist _ dist - (BaseDistance at: code+1).
				self nextBits: extra put: dist.
			].
		].
	].
	^sum! !
Object subclass: #ZipEncoderNode
	instanceVariableNames: 'value frequency height bitLength code parent left right '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compression'!
!ZipEncoderNode commentStamp: '<historical>' prior: 0!
ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams.

Instance variables:
	value 		<Integer>	- Encoded value
	frequency	<Integer>	- Number of occurences of the encoded value
	height 		<Integer>	- Height of the node in the tree
	bitLength 	<Integer>	- bit length of the code
	code		<Integer>	- Assigned code for this node
	parent		<ZipEncoderNode>		- Parent of this node
	left			<ZipEncoderNode>		- First child of this node
	right		<ZipEncoderNode>		- Second child of this node
!


!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 19:41'!
bitLength
	^bitLength ifNil:[0]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/30/1999 14:28'!
code
	^code ifNil:[0]! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:51'!
code: aCode
	self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]].
	code _ aCode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:36'!
frequency
	^frequency! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/28/1999 00:56'!
frequency: aNumber
	frequency _ aNumber! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/26/1999 10:44'!
height
	^height! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
left
	^left! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'!
left: aNode
	aNode parent: self.
	left _ aNode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
parent
	^parent! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
parent: aNode
	parent _ aNode! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
right
	^right! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'!
right: aNode
	aNode parent: self.
	right _ aNode.! !

!ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'!
value
	^value! !


!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/26/1999 11:49'!
encodeBitLength: blCounts from: aTree
	| index |
	"Note: If bitLength is not nil then the tree must be broken"
	bitLength == nil ifFalse:[self error:'Huffman tree is broken'].
	parent = nil 
		ifTrue:[bitLength _ 0]
		ifFalse:[bitLength _ parent bitLength + 1].
	self isLeaf ifTrue:[
		index _ bitLength + 1.
		blCounts at: index put: (blCounts at: index) + 1.
	] ifFalse:[
		left encodeBitLength: blCounts from: aTree.
		right encodeBitLength: blCounts from: aTree.
	].! !

!ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/27/1999 14:27'!
rotateToHeight: maxHeight
	"Rotate the tree to achieve maxHeight depth"
	| newParent |
	height < 4 ifTrue:[^self].
	self left: (left rotateToHeight: maxHeight-1).
	self right: (right rotateToHeight: maxHeight-1).
	height _ (left height max: right height) + 1.
	height <= maxHeight ifTrue:[^self].
	(left height - right height) abs <= 2 ifTrue:[^self].
	left height < right height ifTrue:[
		right right height >= right left height ifTrue:[
			newParent _ right.
			self right: newParent left.
			newParent left: self.
		] ifFalse:[
			newParent _ right left.
			right left: newParent right.
			newParent right: right.
			self right: newParent left.
			newParent left: self.
		].
	] ifFalse:[
		left left height >= left right height ifTrue:[
			newParent _ left.
			self left: newParent right.
			newParent right: self.
		] ifFalse:[
			newParent _ left right.
			left right: newParent left.
			newParent left: left.
			self left: newParent right.
			newParent right: self.
		].
	].
	parent computeHeight.
	^parent! !


!ZipEncoderNode methodsFor: 'testing' stamp: 'ar 12/24/1999 23:17'!
isLeaf
	^left == nil! !


!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:45'!
computeHeight
	^self isLeaf
		ifTrue:[height _ 0]
		ifFalse:[height _ (left computeHeight max: right computeHeight) + 1].! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/25/1999 18:14'!
leafNodes
	self isLeaf
		ifTrue:[^Array with: self]
		ifFalse:[^left leafNodes, right leafNodes]! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 12:05'!
setBitLengthTo: bl
	bitLength _ bl! !

!ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:46'!
setValue: v frequency: f height: h
	value _ v.
	frequency _ f.
	height _ h.! !


!ZipEncoderNode methodsFor: 'printing' stamp: 'ar 12/26/1999 10:46'!
printOn: aStream
	super printOn: aStream.
	aStream nextPut:$(;
		nextPutAll:'value = '; print: value;
		nextPutAll:', freq = '; print: frequency;
		nextPutAll:', bitLength = '; print: bitLength;
		nextPutAll:', code = '; print: code;
		nextPutAll:', height = '; print: height; 
	nextPut:$).! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipEncoderNode class
	instanceVariableNames: ''!

!ZipEncoderNode class methodsFor: 'instance creation' stamp: 'ar 12/26/1999 10:47'!
value: v frequency: f height: h
	^self new setValue: v frequency: f height: h! !
Object subclass: #ZipEncoderTree
	instanceVariableNames: 'bitLengths codes maxCode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compression'!
!ZipEncoderTree commentStamp: '<historical>' prior: 0!
ZipEncoderTree represents a huffman tree for encoding ZipStreams.

Instance variables:
	bitLengths	<WordArray>	 - Bit lengths of each generated code
	codes		<WordArray>	 - Codes for each value
	maxCode		<Integer>	- Maximum value with non-zero frequency!


!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:43'!
bitLengthAt: index
	^bitLengths at: index+1! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:32'!
bitLengths
	"Return an array of all bitLength values for valid codes"
	^bitLengths! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:04'!
codeAt: index
	^codes at: index+1! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:24'!
codes
	"Return an array of all valid codes"
	^codes! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 17:15'!
maxCode
	^maxCode! !

!ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:45'!
maxCode: aNumber
	maxCode _ aNumber.! !


!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:34'!
buildCodes: nodeList counts: blCounts maxDepth: depth
	"Build the codes for all nodes"
	| nextCode code node length |
	nextCode _ WordArray new: depth+1.
	code _ 0.
	1 to: depth do:[:bits|
		code _ (code + (blCounts at: bits)) << 1.
		nextCode at: bits+1 put: code].
	self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)].
	0 to: maxCode do:[:n|
		node _ nodeList at: n+1.
		length _ node bitLength.
		length = 0 ifFalse:[
			code _ nextCode at: length+1.
			node code: (self reverseBits: code length: length).
			nextCode at: length+1 put: code+1.
		].
	].! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'!
buildHierarchyFrom: aHeap
	"Build the node hierarchy based on the leafs in aHeap"
	| left right parent |
	[aHeap size > 1] whileTrue:[
		left _ aHeap removeFirst.
		right _ aHeap removeFirst.
		parent _ ZipEncoderNode value: -1 
			frequency: (left frequency + right frequency)
			height: (left height max: right height) + 1.
		left parent: parent.
		right parent: parent.
		parent left: left.
		parent right: right.
		aHeap add: parent].
	^aHeap removeFirst
! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 14:19'!
buildTree: nodeList maxDepth: depth
	"Build either the literal or the distance tree"
	| heap rootNode blCounts |
	heap _ Heap new: nodeList size // 3.
	heap sortBlock: self nodeSortBlock.
	"Find all nodes with non-zero frequency and add to heap"
	maxCode _ 0.
	nodeList do:[:dNode|
		dNode frequency = 0 ifFalse:[
			maxCode _ dNode value.
			heap add: dNode]].
	"The pkzip format requires that at least one distance code exists,
	and that at least one bit should be sent even if there is only one
	possible code. So to avoid special checks later on we force at least
	two codes of non zero frequency."
	heap size = 0 ifTrue:[
		self assert:[maxCode = 0].
		heap add: nodeList first.
		heap add: nodeList second.
		maxCode _ 1].
	heap size = 1 ifTrue:[
		nodeList first frequency = 0
			ifTrue:[heap add: nodeList first]
			ifFalse:[heap add: nodeList second].
		maxCode _ maxCode max: 1].
	rootNode _ self buildHierarchyFrom: heap.
	rootNode height > depth ifTrue:[
		rootNode _ rootNode rotateToHeight: depth.
		rootNode height > depth ifTrue:[self error:'Cannot encode tree']].
	blCounts _ WordArray new: depth+1.
	rootNode encodeBitLength: blCounts from: self.
	self buildCodes: nodeList counts: blCounts maxDepth: depth.
	self setValuesFrom: nodeList.! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:24'!
buildTreeFrom: frequencies maxDepth: depth
	"Build the receiver from the given frequency values"
	| nodeList |
	nodeList _ Array new: frequencies size.
	1 to: frequencies size do:[:i|
		nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0)
	].
	self buildTree: nodeList maxDepth: depth.! !

!ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'!
nodeSortBlock
	^[:n1 :n2|
		n1 frequency = n2 frequency
			ifTrue:[n1 height <= n2 height]
			ifFalse:[n1 frequency <= n2 frequency]].! !


!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'!
bitLengths: blArray codes: codeArray
	bitLengths _ blArray as: WordArray.
	codes _ codeArray as: WordArray.
	self assert:[(self bitLengthAt: maxCode) > 0].! !

!ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/26/1999 11:02'!
reverseBits: code length: length
	"Bit reverse the given code"
	| result bit bits |
	result _ 0.
	bits _ code.
	1 to: length do:[:i|
		bit _ bits bitAnd: 1.
		result _ result << 1 bitOr: bit.
		bits _ bits >> 1].
	^result! !

!ZipEncoderTree methodsFor: 'private' stamp: 'sma 6/1/2000 11:52'!
setValuesFrom: nodeList
	self bitLengths: (nodeList
			collect: [:n | n bitLength]
			from: 1
			to: maxCode + 1)
		codes: (nodeList
				collect: [:n | n code]
				from: 1
				to: maxCode + 1)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipEncoderTree class
	instanceVariableNames: ''!

!ZipEncoderTree class methodsFor: 'instance creation' stamp: 'ar 12/30/1999 01:25'!
buildTreeFrom: frequencies maxDepth: depth
	^self new buildTreeFrom: frequencies maxDepth: depth! !
DeflateStream subclass: #ZipWriteStream
	instanceVariableNames: 'literals distances literalFreq distanceFreq litCount matchCount encoder '
	classVariableNames: 'VerboseLevel '
	poolDictionaries: 'ZipConstants '
	category: 'System-Compression'!

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:38'!
close
	self deflateBlock.
	self flushBlock: true.
	encoder close.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:40'!
initialize
	super initialize.
	literals _ ByteArray new: WindowSize.
	distances _ WordArray new: WindowSize.
	literalFreq _ WordArray new: MaxLiteralCodes.
	distanceFreq _ WordArray new: MaxDistCodes.
	self initializeNewBlock.
! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 18:29'!
initializeNewBlock
	"Initialize the encoder for a new block of data"
	literalFreq atAllPut: 0.
	distanceFreq atAllPut: 0.
	literalFreq at: EndBlock+1 put: 1.
	litCount _ 0.
	matchCount _ 0.! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 17:23'!
on: aCollectionOrStream
	encoder _ ZipEncoder on: aCollectionOrStream.
	encoder isBinary
		ifTrue:[super on: ByteArray new]
		ifFalse:[super on: String new]! !

!ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:39'!
release
	"We're done with compression. Do some cleanup."
	literals _ distances _ literalFreq _ distanceFreq _ nil.! !


!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'!
encodedStream
	^encoder encodedStream! !

!ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 18:32'!
forcedMethod
	"Return a symbol describing an enforced method or nil if the method should
	be chosen adaptively. Valid symbols are
		#stored	- store blocks (do not compress)
		#fixed	- use fixed huffman trees
		#dynamic	- use dynamic huffman trees."
	^nil! !


!ZipWriteStream methodsFor: 'deflating' stamp: 'ar 2/2/2001 15:47'!
deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch
	"^DeflatePlugin doPrimitive:#primitiveDeflateBlock"
	<primitive: 'primitiveDeflateBlock' module: 'ZipPlugin'>
	^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! !


!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'!
encodeLiteral: lit
	"Encode the given literal"
	litCount _ litCount + 1.
	literals at: litCount put: lit.
	distances at: litCount put: 0.
	literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'!
encodeMatch: length distance: dist
	"Encode the given match of length length starting at dist bytes ahead"
	| literal distance |
	dist > 0 
		ifFalse:[^self error:'Distance must be positive'].
	length < MinMatch 
		ifTrue:[^self error:'Match length must be at least ', MinMatch printString].
	litCount _ litCount + 1.
	matchCount _ matchCount + 1.
	literals at: litCount put: length - MinMatch.
	distances at: litCount put: dist.
	literal _ (MatchLengthCodes at: length - MinMatch + 1).
	literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1.
	dist < 257
		ifTrue:[distance _ DistanceCodes at: dist]
		ifFalse:[distance _ DistanceCodes at: 257 + (dist - 1 bitShift: -7)].
	distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1.
	^self shouldFlush! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'!
flushBlock
	^self flushBlock: false! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/30/1999 11:54'!
flushBlock: lastBlock
	"Send the current block"
	| lastFlag bitsRequired method bitsSent
	storedLength fixedLength dynamicLength 
	blTree lTree dTree blBits blFreq |

	lastFlag _ lastBlock ifTrue:[1] ifFalse:[0].

	"Compute the literal/length and distance tree"
	lTree _ ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits.
	dTree _ ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits.

	"Compute the bit length tree"
	blBits _ lTree bitLengths, dTree bitLengths.
	blFreq _ WordArray new: MaxBitLengthCodes.
	self scanBitLengths: blBits into: blFreq.
	blTree _ ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits.

	"Compute the bit length for the current block.
	Note: Most of this could be computed on the fly but it's getting
	really ugly in this case so we do it afterwards."
	storedLength _ self storedBlockSize.
	fixedLength _ self fixedBlockSizeFor: lTree and: dTree.
	dynamicLength _ self dynamicBlockSizeFor: lTree and: dTree 
							using: blTree and: blFreq.
	VerboseLevel > 1 ifTrue:[
		Transcript cr; show:'Block sizes (S/F/D):';
			space; print: storedLength // 8; 
			nextPut:$/; print: fixedLength // 8; 
			nextPut:$/; print: dynamicLength // 8; space; endEntry].

	"Check which method to use"
	method _ self forcedMethod.
	method == nil ifTrue:[
		method _ (storedLength < fixedLength and:[storedLength < dynamicLength]) 
			ifTrue:[#stored]
			ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]].
	(method == #stored and:[blockStart < 0]) ifTrue:[
		"Cannot use #stored if the block is not available"
		method _ fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]].

	bitsSent _ encoder bitPosition. "# of bits sent before this block"
	bitsRequired _ nil.

	(method == #stored) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'S'].
		bitsRequired _ storedLength.
		encoder nextBits: 3 put: StoredBlock << 1 + lastFlag.
		self sendStoredBlock].

	(method == #fixed) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'F'].
		bitsRequired _ fixedLength.
		encoder nextBits: 3 put: FixedBlock << 1 + lastFlag.
		self sendFixedBlock].

	(method == #dynamic) ifTrue:[
		VerboseLevel > 0 ifTrue:[Transcript show:'D'].
		bitsRequired _ dynamicLength.
		encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag.
		self sendDynamicBlock: blTree 
			literalTree: lTree 
			distanceTree: dTree 
			bitLengths: blBits].

	bitsRequired = (encoder bitPosition - bitsSent)
		ifFalse:[self error:'Bits size mismatch'].

	lastBlock 
		ifTrue:[self release]
		ifFalse:[self initializeNewBlock].! !

!ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'!
shouldFlush
	"Check if we should flush the current block.
	Flushing can be useful if the input characteristics change."
	| nLits |
	litCount = literals size ifTrue:[^true]. "We *must* flush"
	(litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes"
	matchCount * 10 <= litCount ifTrue:[
		"This is basically random data. 
		There is no need to flush early since the overhead
		for encoding the trees will add to the overall size"
		^false].
	"Try to adapt to the input data.
	We flush if the ratio between matches and literals
	changes beyound a certain threshold"
	nLits _ litCount - matchCount.
	nLits <= matchCount ifTrue:[^false]. "whow!! so many matches"
	^nLits * 4 <= matchCount! !


!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 1/2/2000 16:36'!
sendStoredBlock
	"Send an uncompressed block"
	| inBytes |
	inBytes _ blockPosition - blockStart.
	encoder flushBits. "Skip to byte boundary"
	encoder nextBits: 16 put: inBytes.
	encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF).
	encoder flushBits.
	1 to: inBytes do:[:i|
		encoder nextBytePut: (collection byteAt: blockStart+i)].! !

!ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 12/30/1999 00:42'!
storedBlockSize
	"Compute the length for the current block when stored as is"
	^3 "block type bits" 
		+ (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary"
			+ 32 "byte length + chksum" 
				+ (blockPosition - blockStart * 8) "actual data bits".! !


!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'!
fixedBlockSizeFor: lTree and: dTree
	"Compute the length for the current block using fixed huffman trees"
	| bits extra |
	bits _ 3 "block type".
	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		bits _ bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))].
	NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths"
		extra _ ExtraLengthBits at: i-NumLiterals.
		bits _ bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		extra _ ExtraDistanceBits at: i+1.
		bits _ bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))].

	^bits! !

!ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'!
sendFixedBlock
	"Send a block using fixed huffman trees"
	self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! !


!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 01:55'!
dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq
	"Compute the length for the current block using dynamic huffman trees"
	| bits index extra treeBits freq |
	bits _ 3 "block type" + 5 "literal codes length" + 5 "distance codes length".

	"Compute the # of bits for sending the bit length tree"
	treeBits _ 4. "Max index for bit length tree"
	index _ MaxBitLengthCodes.
	[index >= 4] whileTrue:[
		(index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0])
			ifTrue:[treeBits _ treeBits + (index * 3).
					index _ -1]
			ifFalse:[index _ index - 1]].

	"Compute the # of bits for sending the literal/distance tree.
	Note: The frequency are already stored in the blTree"
	0 to: 15 do:[:i| "First, the non-repeating values"
		freq _ blFreq at: i+1.
		freq > 0 ifTrue:[treeBits _ treeBits + (freq * (blTree bitLengthAt: i))]].
	"Now the repeating values"
	(Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl|
		freq _ blFreq at: i+1.
		freq > 0 ifTrue:[
			treeBits _ treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]].
	VerboseLevel > 1 ifTrue:[
		Transcript show:'['; print: treeBits; show:' bits for dynamic tree]'].
	bits _ bits + treeBits.

	"Compute the size of the compressed block"
	0 to: NumLiterals do:[:i| "encoding of literals"
		freq _ literalFreq at: i+1.
		freq > 0 ifTrue:[bits _ bits + (freq * (lTree bitLengthAt: i))]].
	NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths"
		freq _ literalFreq at: i+1.
		extra _ ExtraLengthBits at: i-NumLiterals.
		freq > 0 ifTrue:[bits _ bits + (freq * ((lTree bitLengthAt: i) + extra))]].
	0 to: dTree maxCode do:[:i| "encoding of distances"
		freq _ distanceFreq at: i+1.
		extra _ ExtraDistanceBits at: i+1.
		freq > 0 ifTrue:[bits _ bits + (freq * ((dTree bitLengthAt: i) + extra))]].

	^bits! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'!
scanBitLength: bitLength repeatCount: repeatCount into: anArray
	"Update the frequency for the aTree based on the given values"
	| count |
	count _ repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1.
			count _ (count - 138) max: 0].
		[count >= 3] whileTrue:[
			anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1.
			count _ (count - 10) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	] ifFalse:[
		anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1.
		count _ count - 1.
		[count >= 3] whileTrue:[
			anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1.
			count _ (count - 6) max: 0].
		count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count].
	].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'!
scanBitLengths: bits into: anArray
	"Scan the trees and determine the frequency of the bit lengths.
	For repeating codes, emit a repeat count."
	| lastValue lastCount value |
	bits size = 0 ifTrue:[^self].
	lastValue _ bits at: 1.
	lastCount _ 1.
	2 to: bits size do:[:i|
		value _ bits at: i.
		value = lastValue 
			ifTrue:[lastCount _ lastCount + 1]
			ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray.
					lastValue _ value.
					lastCount _ 1]].
	self scanBitLength: lastValue repeatCount: lastCount into: anArray.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLength: bitLength repeatCount: repeatCount tree: aTree
	"Send the given bitLength, repeating repeatCount times"
	| count |
	count _ repeatCount.
	bitLength = 0 ifTrue:[
		[count >= 11] whileTrue:[
			self sendBitLength: Repeat11To138 tree: aTree.
			encoder nextBits: 7 put: (count min: 138) - 11.
			count _ (count - 138) max: 0].
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To10 tree: aTree.
			encoder nextBits: 3 put: (count min: 10) - 3.
			count _ (count - 10) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	] ifFalse:[
		self sendBitLength: bitLength tree: aTree.
		count _ count - 1.
		[count >= 3] whileTrue:[
			self sendBitLength: Repeat3To6 tree: aTree.
			encoder nextBits: 2 put: (count min: 6) - 3.
			count _ (count - 6) max: 0].
		count timesRepeat:[self sendBitLength: bitLength tree: aTree].
	].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLength: bitLength tree: aTree
	"Send the given bitLength"
	encoder nextBits: (aTree bitLengthAt: bitLength) 
		put: (aTree codeAt: bitLength).! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendBitLengthTree: blTree
	"Send the bit length tree"
	| blIndex bitLength |
	MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex|
		blIndex _ BitLengthOrder at: maxIndex.
		bitLength _ blIndex <= blTree maxCode 
			ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
		(maxIndex = 4 or:[bitLength > 0]) ifTrue:[
			encoder nextBits: 4 put: maxIndex - 4.
			1 to: maxIndex do:[:j|
				blIndex _ BitLengthOrder at: j.
				bitLength _ blIndex <= blTree maxCode 
					ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0].
				encoder nextBits: 3 put: bitLength].
			^self]].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 00:48'!
sendCompressedBlock: litTree with: distTree
	"Send the current block using the encodings from the given literal/length and distance tree"
	| sum |
	sum _ encoder
			sendBlock: (ReadStream on: literals from: 1 to: litCount)
			with: (ReadStream on: distances from: 1 to: litCount)
			with: litTree
			with: distTree.
	sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/29/1999 18:19'!
sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits
	"Send a block using dynamic huffman trees"
	self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits.
	self sendCompressedBlock: lTree with: dTree.! !

!ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'!
sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits
	"Send all the trees needed for dynamic huffman tree encoding"
	| lastValue lastCount value |
	encoder nextBits: 5 put: (lTree maxCode - 256).
	encoder nextBits: 5 put: (dTree maxCode).
	self sendBitLengthTree: blTree.
	bits size = 0 ifTrue:[^self].
	lastValue _ bits at: 1.
	lastCount _ 1.
	2 to: bits size do:[:i|
		value _ bits at: i.
		value = lastValue 
			ifTrue:[lastCount _ lastCount + 1]
			ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree.
					lastValue _ value.
					lastCount _ 1]].
	self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZipWriteStream class
	instanceVariableNames: ''!

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 00:31'!
initialize
	"ZipWriteStream initialize"
	#(
		MaxBits MaxBitLengthBits EndBlock
		StoredBlock FixedBlock DynamicBlock 
		NumLiterals MaxLengthCodes MaxDistCodes MaxBitLengthCodes MaxLiteralCodes
		Repeat3To6 Repeat3To10 Repeat11To138
		ExtraLengthBits ExtraDistanceBits ExtraBitLengthBits BitLengthOrder
		BaseLength MatchLengthCodes BaseDistance DistanceCodes 
		FixedLiteralTree FixedDistanceTree
	) do:[:sym|
		ZipConstants declare: sym from: Undeclared.
	].
	VerboseLevel _ 0.
	MaxBits _ 15.
	MaxBitLengthBits _ 7.
	EndBlock _ 256.

	StoredBlock _ 0.
	FixedBlock _ 1.
	DynamicBlock _ 2.

	NumLiterals _ 256.
	MaxLengthCodes _ 29.
	MaxDistCodes _ 30.
	MaxBitLengthCodes _ 19.
	MaxLiteralCodes _ NumLiterals + MaxLengthCodes + 1. "+ End of Block"

	Repeat3To6 _ 16. "Repeat previous bit length 3-6 times (2 bits repeat count)"
	Repeat3To10 _ 17. "Repeat previous bit length 3-10 times (3 bits repeat count)"
	Repeat11To138 _ 18. "Repeat previous bit length 11-138 times (7 bits repeat count)"

	self initializeExtraBits.
	self initializeLengthCodes.
	self initializeDistanceCodes.
	self initializeFixedTrees.! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:26'!
initializeDistanceCodes
	| dist |
	BaseDistance _ WordArray new: MaxDistCodes.
	DistanceCodes _ WordArray new: 512.
	dist _ 0.
	1 to: 16 do:[:code|
		BaseDistance at: code put: dist.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n|
			dist _ dist + 1.
			DistanceCodes at: dist put: code-1]].
	dist = 256 ifFalse:[self error:'Whoops?!!'].
	dist _ dist >> 7.
	17 to: MaxDistCodes do:[:code|
		BaseDistance at: code put: dist << 7.
		1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n|
			dist _ dist + 1.
			DistanceCodes at: 256 + dist put: code-1]].
! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:27'!
initializeExtraBits
	ExtraLengthBits _ 
		WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0).
	ExtraDistanceBits _ 
		WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13).
	ExtraBitLengthBits _ 
		WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7).
	BitLengthOrder _
		WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15).
! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 14:25'!
initializeFixedTrees
	"ZipWriteStream initializeFixedTrees"
	| counts nodes |
	FixedLiteralTree _ ZipEncoderTree new.
	FixedLiteralTree maxCode: 287.
	counts _ WordArray new: MaxBits+1.
	counts at: 7+1 put: 24.
	counts at: 8+1 put: 144+8.
	counts at: 9+1 put: 112.
	nodes _ Array new: 288.
	1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)].
	0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9].
	256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7].
	280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8].
	FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits.
	FixedLiteralTree setValuesFrom: nodes.

	FixedDistanceTree _ ZipEncoderTree new.
	FixedDistanceTree maxCode: MaxDistCodes.
	FixedDistanceTree
		bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5)
		codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).! !

!ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:26'!
initializeLengthCodes
	| length |
	BaseLength _ WordArray new: MaxLengthCodes.
	MatchLengthCodes _ WordArray new: MaxMatch - MinMatch + 1.
	length _ 0.
	1 to: MaxLengthCodes - 1 do:[:code|
		BaseLength at: code put: length.
		1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n|
			length _ length + 1.
			MatchLengthCodes at: length put: NumLiterals + code]].
! !


!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
baseDistance
	^BaseDistance! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
baseLength
	^BaseLength! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'!
distanceCodes
	^DistanceCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
extraDistanceBits
	^ExtraDistanceBits! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'!
extraLengthBits
	^ExtraLengthBits! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'!
matchLengthCodes
	^MatchLengthCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'!
maxDistanceCodes
	^MaxDistCodes! !

!ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'!
maxLiteralCodes
	^MaxLiteralCodes! !


!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:48'!
compressAndDecompress: aFile using: tempName stats: stats
	| fileSize tempFile result |
	aFile == nil ifTrue:[^nil].
	fileSize _ aFile size.
	(fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil].
	Transcript cr; show:'Testing ', aFile name,' ... '.
	tempFile _ StandardFileStream new open: tempName forWrite: true.
	'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint
		from: 1 to: aFile size during:[:bar|
			result _ self regressionCompress: aFile into: tempFile notifiying: bar stats: stats].
	result ifTrue:[
		'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint
			from: 0 to: aFile size during:[:bar|
				result _ self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]].
	aFile close.
	tempFile close.
	FileDirectory default deleteFileNamed: tempName ifAbsent:[].
	result ~~ false ifTrue:[
		Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')'].
	^result! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 21:11'!
logProblem: reason for: aFile
	| errFile |
	errFile _ FileStream fileNamed:'problems.log'.
	errFile position: errFile size.
	errFile cr; nextPutAll: aFile name;
			cr; nextPutAll: reason.
	errFile close.
	Transcript show:' failed (', reason,')'.
	aFile close.
	^false! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'!
printRegressionStats: stats from: fd
	| raw compressed numFiles |
	raw _ stats at: #rawSize ifAbsent:[0].
	raw = 0 ifTrue:[^self].
	compressed _ stats at: #compressedSize ifAbsent:[0].
	numFiles _ stats at: #numFiles ifAbsent:[0].
	Transcript cr; nextPutAll: fd pathName.
	Transcript crtab; nextPutAll:'Files compressed: ', numFiles asStringWithCommas.
	Transcript crtab; nextPutAll:'Bytes compressed: ', raw asStringWithCommas.
	Transcript crtab; nextPutAll:'Avg. compression ratio: ';
		print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01).
	Transcript endEntry.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:44'!
regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats
	"Compress aFile into tempFile"
	| zip encoded buffer |
	aFile binary.
	aFile position: 0.
	tempFile binary.
	buffer _ ByteArray new: 4096.
	zip _ self on: (ByteArray new: 10000).
	encoded _ zip encodedStream.
	[aFile atEnd] whileFalse:[
		progressBar value: aFile position.
		zip nextPutAll: (aFile nextInto: buffer).
		encoded position > 0 ifTrue:[
			tempFile nextPutAll: encoded contents.
			encoded position: 0]].
	zip close.
	tempFile nextPutAll: encoded contents.
	^true! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:45'!
regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats
	"Validate aFile as decompressed from tempFile"
	| unzip rawSize compressedSize buffer1 buffer2 |
	rawSize _ aFile size.
	compressedSize _ tempFile size.
	aFile ascii.
	aFile position: 0.
	tempFile ascii.
	tempFile position: 0.
	buffer1 _ String new: 4096.
	buffer2 _ buffer1 copy.
	unzip _ FastInflateStream on: tempFile.
	[aFile atEnd] whileFalse:[
		progressBar value: aFile position.
		buffer1 _ aFile nextInto: buffer1.
		buffer2 _ unzip nextInto: buffer2.
		buffer1 = buffer2
			ifFalse:[^self logProblem: 'contents ' for: aFile].
	].
	unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile].
	stats at: #rawSize put:
		(stats at: #rawSize ifAbsent:[0]) + rawSize.
	stats at: #compressedSize put:
		(stats at: #compressedSize ifAbsent:[0]) + compressedSize.
	^compressedSize asFloat / rawSize asFloat.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'!
regressionTest "ZipWriteStream regressionTest"
	"Compress and decompress everything we can 
	find to validate that compression works as expected."
	self regressionTestFrom: (FileDirectory default).! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:46'!
regressionTestFrom: fd
	"ZipWriteStream regressionTestFrom: FileDirectory default"
	"ZipWriteStream regressionTestFrom: (FileDirectory on:'')"
	"ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')"
	| tempName stats |
	Transcript clear.
	stats _ Dictionary new.
	tempName _ FileDirectory default fullNameFor: '$$sqcompress$$'.
	FileDirectory default deleteFileNamed: tempName.
	self regressionTestFrom: fd using: tempName stats: stats.! !

!ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:47'!
regressionTestFrom: fd using: tempName stats: stats
	| files file fullName |
	files _ fd fileNames asSortedCollection.
	files do:[:fName|
		file _ nil.
		fullName _ fd fullNameFor: fName.
		fullName = tempName ifFalse:[
			file _ StandardFileStream new open: fullName forWrite: false].
		self compressAndDecompress: file using: tempName stats: stats].
	stats at: #numFiles put: (stats at: #numFiles ifAbsent:[0]) + files size.
	files _ nil.
	self printRegressionStats: stats from: fd.
	fd directoryNames asSortedCollection do:[:dName|
		self regressionTestFrom: (fd directoryNamed: dName) using: tempName stats: stats.
	].! !
RectangleMorph subclass: #ZoomAndScrollControllerMorph
	instanceVariableNames: 'mouseDownPoint mouseMovePoint panAndTiltFactor zoomFactor target hasFocus currentKeyDown upDownCodes changeKeysState programmedMoves '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:21'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

	super addCustomMenuItems: aCustomMenu hand: aHandMorph.
	aCustomMenu addLine.
	aCustomMenu add: 'change tilt and zoom keys' action: #changeKeys.
	aCustomMenu add: 'run an existing camera script' action: #runAScript.
	aCustomMenu add: 'edit an existing camera script' action: #editAScript.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 15:45'!
cameraPoint

	target ifNil: [^0@0].
	^target cameraPoint
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 15:48'!
cameraPoint: aPoint

	target ifNil: [^self].
	target cameraPoint: aPoint! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 17:07'!
cameraPointRounded

	^self cameraPoint rounded! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 16:27'!
cameraScale

	target ifNil: [^1.0].
	^target scale
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 11:43'!
cameraScale: aNumber

	target ifNil: [^self].
	target changeScaleTo: aNumber! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:14'!
changeKeys

	upDownCodes _ Dictionary new.
	changeKeysState _ #(up down in out).
	self changed.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 14:54'!
currentCameraVersion

	^2! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 16:06'!
deadZoneWidth

	^8
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:30'!
doProgrammedMoves

	| thisMove startPoint endPoint startZoom endZoom newScale newPoint fractionLeft |

	programmedMoves isEmptyOrNil ifTrue: [
		^programmedMoves _ nil
	].
	thisMove _ programmedMoves first.
	thisMove at: #pauseTime ifPresent: [ :ignore | ^self].

	fractionLeft _ self fractionLeftInMove: thisMove.
	fractionLeft ifNil: [^programmedMoves _ programmedMoves allButFirst].

	startPoint _ thisMove at: #startPoint ifAbsentPut: [self cameraPoint].
	endPoint _ thisMove at: #endPoint ifAbsentPut: [self cameraPoint].

	startZoom _ thisMove at: #startZoom ifAbsentPut: [self cameraScale].
	endZoom _ thisMove at: #endZoom ifAbsentPut: [self cameraScale].
	newScale _ endZoom - (endZoom - startZoom * fractionLeft).
	newPoint _ (endPoint - (endPoint - startPoint * fractionLeft)) "rounded".
	target changeScaleTo: newScale.
	target cameraPoint: newPoint.

	fractionLeft <= 0 ifTrue: [^programmedMoves _ programmedMoves allButFirst].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:24'!
drawOn: aCanvas

	| dw bullsEye f |

	super drawOn: aCanvas.
	changeKeysState ifNotNil: [
		f _ (
			StringMorph contents: 'Press the key to be used for "',changeKeysState first,'"'
		) imageForm.
		aCanvas paintImage: f at: self center - (f extent // 2).
		^self
	].
	mouseDownPoint ifNil: [^self].
	dw _ self deadZoneWidth.
	bullsEye _ mouseDownPoint - (dw@dw//2) extent: dw@dw.
	aCanvas 
		fillRectangle: (bullsEye left @ self top corner: bullsEye right @ self bottom) 
		color: (Color red alpha: 0.3).
	aCanvas 
		fillRectangle: (self left @ bullsEye top corner: self right @ bullsEye bottom) 
		color: (Color red alpha: 0.3).
	aCanvas 
		fillRectangle: bullsEye 
		color: (Color red alpha: 0.4).
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 12:03'!
editAScript

	| d names reply s |
	d _ self targetScriptDictionary.
	names _ d keys asSortedCollection.
	reply _ (SelectionMenu labelList: names selections: names) startUpWithCaption: 'Script to edit?'.
	reply ifNil: [^ self].
	(s _ ZASMScriptMorph new)
		decompileScript: (d at: reply) named: reply for: self;
		fullBounds;
		align: s center with: self center;
		openInWorld
	! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/6/2000 13:08'!
fractionLeftInMove: thisMove

	| steps stepsRemaining fractionLeft endTime startTime |

	(thisMove includesKey: #steps) ifTrue: [
		steps _ thisMove at: #steps ifAbsentPut: [1].
		stepsRemaining _ thisMove at: #stepsRemaining ifAbsentPut: [steps].
		stepsRemaining < 1 ifTrue: [^nil].
		stepsRemaining _ stepsRemaining - 1.
		fractionLeft _ stepsRemaining / steps. 
		thisMove at: #stepsRemaining put: stepsRemaining.
	] ifFalse: [
		endTime _ thisMove at: #endTime ifAbsent: [^nil].
		startTime _ thisMove at: #startTime ifAbsent: [^nil].
		fractionLeft _ (endTime - Time millisecondClockValue) / (endTime - startTime).
	].
	^fractionLeft max: 0
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 15:35'!
grabCameraPositionEvent: anEvent morph: aMorph
 
	| mark |
	mark _ ZASMCameraMarkMorph new.
	mark 
		cameraPoint: self cameraPoint
		cameraScale: self cameraScale
		controller: self
		page: target.
	anEvent hand attachMorph: mark.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 16:21'!
handlesKeyboard: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:22'!
handlesMouseDown: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 16:21'!
handlesMouseOver: evt

	^true! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 16:24'!
hasFocus

	^ hasFocus! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/11/2000 17:07'!
initialize

	| displayer dataMorph |

	super initialize.
	hasFocus _ true.
	currentKeyDown _ Set new.
	upDownCodes _ Dictionary new.
	upDownCodes
		at: 126 put: #up;		"arrow keys on the mac"
		at: 125 put: #down;
		at: 123 put: #out;
		at: 124 put: #in.
	color _ Color lightBlue.
	self 
		extent: 40@40;
		vResizing: #rigid;
		hResizing: #spaceFill;
		borderWidth: 0;
		borderColor: Color transparent;
		setBalloonText: 'Drag in here to zoom, tilt and pan the page above'.
	dataMorph _ AlignmentMorph newColumn.
	dataMorph 
		color: Color yellow;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap.
	dataMorph on: #mouseDown send: #grabCameraPositionEvent:morph: to: self.
 	displayer _ UpdatingStringMorph new
		getSelector: #cameraPointRounded;
		target: self;
		growable: true;
		putSelector: nil.
	dataMorph addMorph: displayer lock.

 	displayer _ UpdatingStringMorph new
		getSelector: #cameraScale;
		target: self;
		growable: true;
		floatPrecision: 0.001;
		putSelector: nil.
	dataMorph addMorph: displayer lock.
	self addMorph: dataMorph.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:22'!
keyDown: anEvent

	changeKeysState ifNotNil: [
		upDownCodes at: anEvent keyValue put: changeKeysState first.
		changeKeysState _ changeKeysState allButFirst.
		changeKeysState isEmpty ifTrue: [changeKeysState _ nil].
		currentKeyDown _ Set new.
		^self changed
	].
	currentKeyDown add: anEvent keyValue.
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 14:55'!
keyStroke: anEvent

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:21'!
keyUp: anEvent

	currentKeyDown remove: anEvent keyValue ifAbsent: [].! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:23'!
mouseDown: evt

	mouseDownPoint _ evt cursorPoint.
	self changed.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 18:23'!
mouseEnter: evt

	evt hand newKeyboardFocus: self.
	currentKeyDown _ Set new.
	hasFocus _ true.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:25'!
mouseLeave: evt

	evt hand releaseKeyboardFocus: self.
	currentKeyDown _ Set new.
	hasFocus _ false.
	mouseMovePoint _ mouseDownPoint _ nil.
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:23'!
mouseMove: evt

	mouseMovePoint _ evt cursorPoint.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:23'!
mouseUp: evt

	mouseMovePoint _ mouseDownPoint _ nil.
	self changed.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/12/2000 13:55'!
patchOldVersion1

	"hack.. use this as an opportunity to fix old versions"
	self allMorphsDo: [:m |
		((m isKindOf: UpdatingStringMorph) and: [m getSelector == #cameraPoint]) ifTrue: [
			m getSelector: #cameraPointRounded
		].
	].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:30'!
pauseProgrammedMoves

	programmedMoves isEmptyOrNil ifTrue: [^self].
	programmedMoves first
		at: #pauseTime
		put: Time millisecondClockValue
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:38'!
resumeProgrammedMoves

	| thisStep |

	programmedMoves isEmptyOrNil ifTrue: [^self].
	(thisStep _ programmedMoves first)
		at: #pauseTime
		ifPresent: [ :pauseTime |
			thisStep 
				at: #startTime 
				put: (thisStep at: #startTime) + Time millisecondClockValue - pauseTime.
			thisStep removeKey: #pauseTime ifAbsent: [].
		].
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:45'!
runAScript

	| d names reply |
	d _ self targetScriptDictionary.
	names _ d keys asSortedCollection.
	reply _ (SelectionMenu labelList: names selections: names) startUpWithCaption: 'Script to run?'.
	reply ifNil: [^ self].
	programmedMoves _ (d at: reply) veryDeepCopy.! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:34'!
saveScript: newScript as: scriptName

	self targetScriptDictionary at: scriptName put: newScript.

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 15:38'!
setProgrammedMoves: aCollection

	programmedMoves _ aCollection
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/18/2000 14:55'!
step

	| delta halfDW action |

	(self valueOfProperty: #currentCameraVersion ifAbsent: [0]) = 
							self currentCameraVersion ifFalse: [
		self patchOldVersion1.
		self setProperty: #currentCameraVersion toValue: self currentCameraVersion.
	].
	super step.
	self doProgrammedMoves.

	(currentKeyDown ifNil: [#()]) do: [ :each |
		action _ upDownCodes at: each ifAbsent: [#fugeddaboutit].
		action == #in ifTrue: [
			target scaleImageBy: -10.
		].
		action == #out ifTrue: [
			target scaleImageBy: 10.
		].
		action == #up ifTrue: [
			target tiltImageBy: -20.
		].
		action == #down ifTrue: [
			target tiltImageBy: 20.
		].
	].
	mouseMovePoint ifNil: [^self].
	mouseDownPoint ifNil: [^self].
	target ifNil: [^self].
	halfDW _ self deadZoneWidth // 2.
	delta _ mouseMovePoint - mouseDownPoint.
	delta x abs <= halfDW ifTrue: [delta _ 0@delta y].
	delta y abs <= halfDW ifTrue: [delta _ delta x@0].
	
	target panImageBy: delta x.



! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 15:28'!
stepTime

	^10

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:53'!
target: x

	target _ x.
! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/3/2000 11:34'!
targetScriptDictionary

	| scriptDict |
	target ifNil: [^Dictionary new].
	^target 
		valueOfProperty: #namedCameraScripts 
		ifAbsent: [
			scriptDict _ Dictionary new.
			target setProperty: #namedCameraScripts toValue: scriptDict.
			scriptDict
		].

! !

!ZoomAndScrollControllerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:53'!
turnToPage: page position: aPoint scale: aNumber transition: aSpec
 
	| myBook |

	target == page ifTrue: [^false].
	page ifNil: [^false].
	myBook _ (self ownerThatIsA: StoryboardBookMorph) ifNil: [^ false].
	2 timesRepeat: [
		page
			cameraPoint: aPoint;
			changeScaleTo: aNumber
	].
	BookMorph turnOffSoundWhile: [
		myBook 
			goToPageMorph: page 
			transitionSpec: aSpec.
	].
	^true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZoomAndScrollControllerMorph class
	instanceVariableNames: ''!

!ZoomAndScrollControllerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 12/2/2000 14:48'!
additionsToViewerCategories
	"Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories."

	^ #((#storyboard
			(
	(slot cameraPoint 'the camera point' point readWrite player cameraPoint player cameraPoint:)
			)
	))! !
PasteUpMorph subclass: #ZoomAndScrollMorph
	instanceVariableNames: 'sourceRectangle usingBalloon panAndTiltFactor zoomFactor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Demo'!
!ZoomAndScrollMorph commentStamp: '<historical>' prior: 0!
I am the outer part of a transformed view of another pasteup. I know how to translate requests to pan, tilt and zoom into appropriate changes to the transformation!


!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/8/2000 12:27'!
changeOffsetBy: aPoint

	| transform rounder roundPt |

	"improve behavior at high magnification by rounding change to whole source pixels"
	transform _ self myTransformMorph.
	rounder _ [ :val |
		"(val abs + (transform scale * 0.99) roundTo: transform scale) * val sign"
		"looks like rounding wasn't a good solution"
		val
	].
	roundPt _ (rounder value: aPoint x) @ (rounder value: aPoint y).

	self changeOffsetTo: transform offset + roundPt.
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
changeOffsetTo: aPoint

	| transform trialOffset innerPasteup keepWidth keepHeight |

	transform _ self myTransformMorph.
	keepWidth _ transform width "// 4".
	keepHeight _ transform height "// 4".
	innerPasteup _ transform firstSubmorph.
	trialOffset _ aPoint.
	trialOffset _ 
		(trialOffset x 
			min: (innerPasteup width * transform scale) - keepWidth 
			max: keepWidth - transform width) @ 
		(trialOffset y 
			min: (innerPasteup height * transform scale) - keepHeight 
			max: keepHeight - transform height).
	transform offset: trialOffset.

! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/16/2000 17:51'!
changeScaleTo: aNumber

	| transform innerPasteup min1 min2 newScale oldPoint |

	transform _ self myTransformMorph.
	"oldScale _ transform scale."
	innerPasteup _ transform firstSubmorph.

	min1 _ transform width / innerPasteup width asFloat.
	min2 _ transform height / innerPasteup height asFloat.
	newScale _ (aNumber max: min1) max: min2.

	oldPoint _ self cameraPoint.
	transform scale: newScale.
	self cameraPoint: oldPoint.

	"scaleR _ newScale / oldScale.
	half _ transform extent // 2.
	half _ 0@0.
	self changeOffsetBy: scaleR * (transform offset + half) - half - transform offset."

"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:12'!
changeTiltFactor: x

	panAndTiltFactor _ x! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:13'!
changeZoomFactor: x

	zoomFactor _ x! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
extent: extentPoint

	super extent: extentPoint.
	self myTransformMorph bounds: self innerBounds.
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:15'!
getTiltFactor

	^panAndTiltFactor ifNil: [panAndTiltFactor _ 0.5].
	
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 16:16'!
getZoomFactor

	^zoomFactor ifNil: [zoomFactor _ 0.5].
	
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 22:49'!
panImageBy: pixels

	self changeOffsetBy: (pixels * self getTiltFactor * 0.1) @ 0.

	"steps _ (pixels abs / 6) exp rounded * pixels sign."
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="

! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
scaleImageBy: pixels

	| scalePerPixel steps transform factor |

	transform _ self myTransformMorph.
	(steps _ (pixels * self getZoomFactor * 0.2) rounded) = 0 ifTrue: [^self].
	scalePerPixel _ 1.01.
	factor _ scalePerPixel raisedTo: steps abs.
	steps > 0 ifTrue: [
		factor _ 1.0 / factor.
	].
	self changeScaleTo: (transform scale * factor min: 10.0 max: 0.1).
! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2000 18:31'!
step

	| innerPasteUp overlap |

	innerPasteUp _ self myTransformMorph firstSubmorph.
	overlap _ (innerPasteUp submorphs 
		inject: 0@0 
		into: [ :min :each | min min: each position]) rounded.
	overlap = (0@0) ifFalse: [
		innerPasteUp submorphs do: [ :each | each position: each position - overlap].
		innerPasteUp layoutChanged.
	].



! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/1/2000 08:04'!
stepTime

	^10		"ms"! !

!ZoomAndScrollMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2000 22:50'!
tiltImageBy: pixels

	self changeOffsetBy: 0 @ (pixels * self getTiltFactor * 0.1)

"	steps _ (pixels abs / 6) exp rounded * pixels sign.
"
"==Alan's preferred factors
pan = 0.0425531914893617
zoom = 0.099290780141844
==="
! !


!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'RAA 11/30/2000 16:45'!
createInteriorTransform

	| innerPasteUp tm |
	innerPasteUp _ PasteUpMorph new.
	innerPasteUp 
		borderWidth: 0;
		minHeight: 100;
		minWidth: 100;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		position: 0@0;
		extent: 100@100.
	tm _ TransformationB2Morph new.
	tm setProperty: #rotationCenter toValue: 0@0.
	tm useRegularWarpBlt: usingBalloon not.
	self addMorph: tm.
	tm addMorph: innerPasteUp.
	tm beSticky.
	innerPasteUp beSticky.
	tm
		scale: 1.0;
		offset: 0@0.
	! !

!ZoomAndScrollMorph methodsFor: 'initialization' stamp: 'RAA 11/21/2000 16:05'!
initialize

	usingBalloon _ true.
	super initialize.
	color _ Color lightGray.
	borderColor _ Color red.
	self createInteriorTransform.

! !


!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/11/2000 17:05'!
cameraPoint

	^self myTransformMorph transform globalPointToLocal: self innerBounds center

! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
cameraPoint: newPt

	| transform |

	transform _ self myTransformMorph.
	self changeOffsetTo: newPt * transform scale - (transform innerBounds extent // 2) 

! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:30'!
myTransformMorph

	^self firstSubmorph
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
offsetX

	^self myTransformMorph offset x
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
offsetX: aNumber

	| transform |

	transform _ self myTransformMorph.
	transform offset: aNumber @ transform offset y
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
offsetY

	^self myTransformMorph offset y
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:31'!
offsetY: aNumber

	| transform |

	transform _ self myTransformMorph.
	transform offset: transform offset x @ aNumber
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/5/2000 18:33'!
scale

	^self myTransformMorph scale
! !

!ZoomAndScrollMorph methodsFor: 'scripting' stamp: 'RAA 12/16/2000 17:51'!
scale: aValue

	self myTransformMorph scale: aValue.
! !


!ZoomAndScrollMorph methodsFor: 'drag and drop' stamp: 'RAA 11/21/2000 12:37'!
acceptDroppingMorph: morphToDrop event: evt

	^morphToDrop rejectDropMorphEvent: evt.		"put it back where it came from"

! !

!ZoomAndScrollMorph methodsFor: 'drag and drop' stamp: 'RAA 11/22/2000 15:40'!
wantsDroppedMorph: aMorph event: evt

	"we don't, really, but it avoids problem of outer pasteup rejecting a drop for inner pasteup"
	^true! !
TransformMorph subclass: #ZoomMorph
	instanceVariableNames: 'fromMorph toMorph boundsSeq finalAction '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-Widgets'!

!ZoomMorph methodsFor: 'as yet unclassified'!
initialize
	super initialize.
	color _ Color transparent! !

!ZoomMorph methodsFor: 'as yet unclassified'!
step

	boundsSeq isEmpty ifTrue:
		["If all done, then grant one final request and vanish"
		finalAction value.
		^ self delete].

	"Otherwise, zoom to the next rectangle"
	self zoomTo: boundsSeq removeFirst! !

!ZoomMorph methodsFor: 'as yet unclassified'!
stepTime

	^ 40! !

!ZoomMorph methodsFor: 'as yet unclassified'!
zoomFromMorph: m1 toMorph: m2 andThen: actionBlock
	| nSteps topLeft r2 r1 extent ratio r mouthDeltas |
	fromMorph _ m1.
	toMorph _ m2.
	r1 _ fromMorph fullBounds.
	r2 _ toMorph fullBounds.
	finalAction _ actionBlock.
	nSteps _ 8.
	boundsSeq _ OrderedCollection new.
	r _ (1/nSteps) asFloat.
	ratio _ r.
r1 _ 105@326 corner: 130@348.
mouthDeltas _ {-7@24. -6@21. -6@18. -4@14. -4@10. -3@8. -3@3. 0@0}.
	1 to: nSteps do:
		[:i | topLeft _ ((r2 topLeft - r1 topLeft) * ratio) asIntegerPoint + r1 topLeft.
		extent _ ((r2 extent - r1 extent) * ratio) asIntegerPoint + r1 extent.
		boundsSeq addLast: (topLeft + (mouthDeltas at: i) extent: extent).
		ratio _ ratio + r].
	self addMorph: toMorph.
	self step! !

!ZoomMorph methodsFor: 'as yet unclassified'!
zoomTo: newBounds
	| scale |
	self bounds: newBounds.
	scale _ newBounds extent / toMorph fullBounds extent.
	self setOffset: toMorph position - self position angle: 0.0 scale: scale! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ZoomMorph class
	instanceVariableNames: ''!

!ZoomMorph class methodsFor: 'as yet unclassified' stamp: 'di 10/6/1998 13:15'!
includeInNewMorphMenu
	"Zooms aren't meaningful without initializations"
	^ false! !